File Coverage

blib/lib/POE/Filter/Transparent/SMTP.pm

Criterion	Covered	Total	%
statement	87	96	90.6
branch	16	26	61.5
condition	8	24	33.3
subroutine	12	12	100.0
pod	7	7	100.0
total	130	165	78.7

# Copyright (c) 2008-2009 George Nistorica
# All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.  See the LICENSE
# file that comes with this distribution for more details.

# 	($rcs) = (' $Id: SMTP.pm,v 1.11 2009/01/28 12:45:15 george Exp $ ' =~ /(\d+(\.\d+)+)/);

package POE::Filter::Transparent::SMTP;
use strict;
use warnings;

use POE::Filter::Line;
use Data::Dumper;
use Carp;

our $VERSION = q{0.2};
my $EOL = qq{\015\012};

sub new {
    my $class   = shift;
    my @options = @_;
    my %options = @options;

    my ( $filter, $self, %filter_line_opts );
    if ( ref $class ) {
        croak q{->new() is a class method!};
    }

    foreach (qw/InputLiteral OutputLiteral/) {
        if ( exists $options{$_} and defined $options{$_} ) {
            $filter_line_opts{$_} = $options{$_};
        }
    }

    # we need this when outputing data prefixed by dot
    if ( not exists $filter_line_opts{'OutputLiteral'} ) {
        $self->{'OutputLiteral'} = $EOL;
    }
    else {
        $self->{'OutputLiteral'} = $filter_line_opts{'OutputLiteral'};
    }

    if (    exists $options{'Warn'}
        and defined $options{'Warn'}
        and $options{'Warn'} )
    {
        $self->{'Warn'} = 1;
    }
    else {
        $self->{'Warn'} = 0;
    }

    # check for EscapeSingleInputDot
    # defaults to no
    # useful for escaping Single Dot on a line in message bodies (not
    # entire SMTP transaction logs, that include the message body as
    # well)

    if (    exists $options{'EscapeSingleInputDot'}
        and defined $options{'EscapeSingleInputDot'}
        and $options{'EscapeSingleInputDot'} )
    {
        $self->{'EscapeSingleInputDot'} = 1;
    }
    else {
        $self->{'EscapeSingleInputDot'} = 0;
    }

    # create the POE::Filter::Line filter to store inside our little so
    # called object
    $filter = POE::Filter::Line->new(%filter_line_opts);
    $self->{'filter_line'} = $filter;
    bless $self, $class;
    return $self;
}

sub clone {
    my $self = shift;
    my $filter;
    if ( not ref $self ) {
        croak q{->clone() is not a package method!};
    }
    my $new_obj = $self;
    $filter                   = $new_obj->{'filter_line'};
    $filter                   = $filter->clone;
    $new_obj->{'filter_line'} = $filter;
    return $new_obj;
}

sub get_one_start {
    my $self = shift;
    my $arg  = shift;
    if ( ref $arg ne q{ARRAY} ) {
        croak q{->get_one_start() accepts an array ref as argument};
    }
    my $filter = $self->{'filter_line'};
    $filter->get_one_start($arg);
    return;
}

sub get_one {
    my $self = shift;
    my $data;
    my $filter = $self->{'filter_line'};
    $data = $filter->get_one();

    # remove the leading transparent dot
    for ( my $i = 0 ; $i < scalar @{$data} ; $i++ ) {
        if ( $data->[$i] =~ /^\.(\..*)$/os ) {
            $data->[$i] = $1;
        }
        if ( $self->{'Warn'} and $data->[$i] =~ /^\..+$/os ) {
            carp q{Data contains a single leading dot }
              . q{and is not conforming to RFC 821 Section }
              . q{4.5.2. TRANSPARENCY};
        }
    }
    return $data;
}

sub get {
    my $self     = shift;
    my $raw_data = shift;

    if ( ref $raw_data ne q{ARRAY} ) {
        croak q{->get() accepts an array ref as argument};
    }
    my $data = [];
    my $temp;

    $self->get_one_start($raw_data);
    $temp = $self->get_one();
    while ( scalar @{$temp} ) {
        push @{$data}, $temp->[0];
        $temp = $self->get_one();
    }

    return $data;
}

sub put {
    my $self     = shift;
    my $raw_data = shift;
    if ( ref $raw_data ne q{ARRAY} ) {
        croak q{->get_one_start() accepts an array ref as argument};
    }
    my ( $filter, $lines, $literal );
    $literal = $self->{'OutputLiteral'};
    $filter  = $self->{'filter_line'};
    $lines   = $filter->put($raw_data);

    # add an extra leading dot on lines starting with a dot
    for ( my $i = 0 ; $i < scalar @{$lines} ; $i++ ) {
        if ( $lines->[$i] =~ /^\..+$literal$/s ) {
            $lines->[$i] = q{.} . $lines->[$i];
        }

        # do we escape single dot? (for filtering message bodies, not
        # entire SMTP transaction
        if ( $self->{'EscapeSingleInputDot'}
            and ( $lines->[$i] =~ /^\.$/so or $lines->[$i] =~ /^\.$literal$/so )
          )
        {
            $lines->[$i] = q{.} . $lines->[$i];
        }
    }

    return $lines;
}

sub get_pending {
    my $self   = shift;
    my $filter = $self->{'filter_line'};
    return $filter->get_pending();
}

1;

__END__