1# Copyright (c) 2008-2009 George Nistorica 2# All rights reserved. 3# This program is free software; you can redistribute it and/or 4# modify it under the same terms as Perl itself. See the LICENSE 5# file that comes with this distribution for more details. 6 7# ($rcs) = (' $Id: SMTP.pm,v 1.11 2009/01/28 12:45:15 george Exp $ ' =~ /(\d+(\.\d+)+)/); 8 9package POE::Filter::Transparent::SMTP; 10use strict; 11use warnings; 12 13use POE::Filter::Line; 14use Data::Dumper; 15use Carp; 16 17our $VERSION = q{0.2}; 18my $EOL = qq{\015\012}; 19 20sub new { 21 my $class = shift; 22 my @options = @_; 23 my %options = @options; 24 25 my ( $filter, $self, %filter_line_opts ); 26 if ( ref $class ) { 27 croak q{->new() is a class method!}; 28 } 29 30 foreach (qw/InputLiteral OutputLiteral/) { 31 if ( exists $options{$_} and defined $options{$_} ) { 32 $filter_line_opts{$_} = $options{$_}; 33 } 34 } 35 36 # we need this when outputing data prefixed by dot 37 if ( not exists $filter_line_opts{'OutputLiteral'} ) { 38 $self->{'OutputLiteral'} = $EOL; 39 } 40 else { 41 $self->{'OutputLiteral'} = $filter_line_opts{'OutputLiteral'}; 42 } 43 44 if ( exists $options{'Warn'} 45 and defined $options{'Warn'} 46 and $options{'Warn'} ) 47 { 48 $self->{'Warn'} = 1; 49 } 50 else { 51 $self->{'Warn'} = 0; 52 } 53 54 # check for EscapeSingleInputDot 55 # defaults to no 56 # useful for escaping Single Dot on a line in message bodies (not 57 # entire SMTP transaction logs, that include the message body as 58 # well) 59 60 if ( exists $options{'EscapeSingleInputDot'} 61 and defined $options{'EscapeSingleInputDot'} 62 and $options{'EscapeSingleInputDot'} ) 63 { 64 $self->{'EscapeSingleInputDot'} = 1; 65 } 66 else { 67 $self->{'EscapeSingleInputDot'} = 0; 68 } 69 70 # create the POE::Filter::Line filter to store inside our little so 71 # called object 72 $filter = POE::Filter::Line->new(%filter_line_opts); 73 $self->{'filter_line'} = $filter; 74 bless $self, $class; 75 return $self; 76} 77 78sub clone { 79 my $self = shift; 80 my $filter; 81 if ( not ref $self ) { 82 croak q{->clone() is not a package method!}; 83 } 84 my $new_obj = $self; 85 $filter = $new_obj->{'filter_line'}; 86 $filter = $filter->clone; 87 $new_obj->{'filter_line'} = $filter; 88 return $new_obj; 89} 90 91sub get_one_start { 92 my $self = shift; 93 my $arg = shift; 94 if ( ref $arg ne q{ARRAY} ) { 95 croak q{->get_one_start() accepts an array ref as argument}; 96 } 97 my $filter = $self->{'filter_line'}; 98 $filter->get_one_start($arg); 99 return; 100} 101 102sub get_one { 103 my $self = shift; 104 my $data; 105 my $filter = $self->{'filter_line'}; 106 $data = $filter->get_one(); 107 108 # remove the leading transparent dot 109 for ( my $i = 0 ; $i < scalar @{$data} ; $i++ ) { 110 if ( $data->[$i] =~ /^\.(\..*)$/os ) { 111 $data->[$i] = $1; 112 } 113 if ( $self->{'Warn'} and $data->[$i] =~ /^\..+$/os ) { 114 carp q{Data contains a single leading dot } 115 . q{and is not conforming to RFC 821 Section } 116 . q{4.5.2. TRANSPARENCY}; 117 } 118 } 119 return $data; 120} 121 122sub get { 123 my $self = shift; 124 my $raw_data = shift; 125 126 if ( ref $raw_data ne q{ARRAY} ) { 127 croak q{->get() accepts an array ref as argument}; 128 } 129 my $data = []; 130 my $temp; 131 132 $self->get_one_start($raw_data); 133 $temp = $self->get_one(); 134 while ( scalar @{$temp} ) { 135 push @{$data}, $temp->[0]; 136 $temp = $self->get_one(); 137 } 138 139 return $data; 140} 141 142sub put { 143 my $self = shift; 144 my $raw_data = shift; 145 if ( ref $raw_data ne q{ARRAY} ) { 146 croak q{->get_one_start() accepts an array ref as argument}; 147 } 148 my ( $filter, $lines, $literal ); 149 $literal = $self->{'OutputLiteral'}; 150 $filter = $self->{'filter_line'}; 151 $lines = $filter->put($raw_data); 152 153 # add an extra leading dot on lines starting with a dot 154 for ( my $i = 0 ; $i < scalar @{$lines} ; $i++ ) { 155 if ( $lines->[$i] =~ /^\..+$literal$/s ) { 156 $lines->[$i] = q{.} . $lines->[$i]; 157 } 158 159 # do we escape single dot? (for filtering message bodies, not 160 # entire SMTP transaction 161 if ( $self->{'EscapeSingleInputDot'} 162 and ( $lines->[$i] =~ /^\.$/so or $lines->[$i] =~ /^\.$literal$/so ) 163 ) 164 { 165 $lines->[$i] = q{.} . $lines->[$i]; 166 } 167 } 168 169 return $lines; 170} 171 172sub get_pending { 173 my $self = shift; 174 my $filter = $self->{'filter_line'}; 175 return $filter->get_pending(); 176} 177 1781; 179 180__END__ 181 182=pod 183 184=head1 NAME 185 186POE::Filter::Transparent::SMTP - Make SMTP transparency a breeze :) 187 188=head1 VERSION 189 190VERSION: 0.2 191 192=head1 SYNOPSIS 193 194 use POE::Filter::Transparent::SMTP; 195 196 my @array_of_things = ( 197 q{.first thing(no new line)}, 198 qq{.second thing (with new line)\n}, 199 q{.third thing (no new line}, 200 q{.}, # this is the message terminator, so it shouldn't be 201 # prepended with an extra dot 202 ); 203 my $filter = POE::Filter::Transparent::SMTP->new( ); 204 my $lines = $filter->put( \@array_of_things ); 205 206=head1 DESCRIPTION 207 208The filter aims to make SMTP data transparent just before going onto 209the wire as per RFC 821 Simple Mail Transfer Protocol Section 2104.5.2. TRANSPARENCY. See L<http://www.faqs.org/rfcs/rfc821.html> for 211details. 212 213Conversely the filter takes transparent data from the wire and 214converts it to the original format. 215 216The main purpose of this filter is to help 217L<POE::Component::Client::SMTP> create transparent messages when 218comunicating with an SMTP server. However the filter can be used by 219any Perl SMTP client or server. 220 221Internally it uses L<POE::Filter::Line> in order to split messages 222into lines. Also as stated in the RFC every line it puts on the wire 223is ended by <CRLF>. 224 225When receiving data from the wire (as it is the case for an SMTP 226server), lines should be separated with <CRLF> as the RFC 227specifies. However this is not always true as some SMTP clients are 228broken. So if you are using the filter on the receiving end maybe you 229would like to specify a regular expression that is more flexible for 230the line terminator. 231 232=head1 METHODS 233 234All methods are conforming to L<POE::Filter> specs. For more details 235have a look at L<POE::Filter> documentation. 236 237=head2 new HASHREF_OF_PARAMETERS 238 239 my $filter = POE::Filter::Transparent::SMTP->new( 240 InputLiteral => qq{\015\012}, 241 OutputLiteral => qq{\015\012}, 242 ); 243 244Creates a new filter. 245 246It accepts four optional arguments: 247 248=over 4 249 250=item InputLiteral 251 252InputLiteral is the same as InputLiteral for L<POE::Filter::Line> 253 254It defaults to whatever L<POE::Filter::Line> is defaulting. Currently 255L<POE::Filter::Line> tries to auto-detect the line separator, but that 256may lead to a race condition, please consult the L<POE::Filter::Line> 257documentation. 258 259=item OutputLiteral 260 261OutputLiteral is the same as OutputLiteral for L<POE::Filter::Line> 262 263It defaults to B<CRLF> if not specified otherwise. 264 265=item Warn 266 267In case L</get_one> receives lines starting with a leading dot and 268L</Warn> is enabled it issues a warning about this. By default the 269warning is disabled. 270 271=item EscapeSingleInputDot 272 273In case you want to escape the single dot when reading data. 274 275The parameter is useful for escaping single dots on a line when 276reading message bodies. Don't use this for filtering entire SMTP 277transaction logs as it will ruin your command '.' 278 279B<Defaults> to false 280 281=back 282 283=head2 get_one_start ARRAYREF 284 285 $filter->get_one_start( $array_ref_of_formatted_lines ); 286 287Accepts an array reference to a list of unprocessed chunks and adds 288them to the buffer in order to be processed. 289 290=head2 get_one 291 292 my $array_ref = $filter->get_one(); my $line = $array_ref->[0]; 293 294Returns zero or one processed record from the raw data buffer. The 295method is not greedy and is I<the preffered> method you should use to 296get processed records. 297 298=head2 get ARRAY_REF 299 300 my $lines = $filter->get( $array_ref_of_formatted_lines ); 301 for (my $i = 0; $i < scalar @{$lines}; $i++ ) { 302 # do something with $lines->[$i]; 303 } 304 305L</get> is the greedy form of L</get_one> and internally is 306implemented as one call of L</get_one_start> and a loop of 307L</get_one>. 308 309Normally you shouldn't use this as using L</get_one_start> and 310L</get_one> would make filter swapping easyer. 311 312=head2 put ARRAYREF 313 314 my @array_of_things = ( 315 q{.first thing(no new line)}, 316 qq{.second thing (with new line)\n}, 317 q{.third thing (no new line}, q{.}, 318 ); 319 my $lines = $filter->put( \@array_of_things ); 320 print Dumper( $lines ); 321 322would return something similar as below 323 324 $VAR1 = [ 325 '..first thing(no new line) 326 ', 327 '..second thing (with new line) 328 329 ', 330 '..third thing (no new line 331 ', 332 '. 333 ' 334 ]; 335 336L</put> takes an array ref of unprocessed records and prepares them to 337be put on the wire making the records SMTP Transparent. 338 339=head2 get_pending 340 341Returns a list of data that is in the buffer (without clearing it) or 342undef in case there is nothing in the buffer. 343 344=head2 clone 345 346 my $new_filter = $filter->clone(); 347 348Clones the current filter keeping the same parameters, but with an 349empty buffer. 350 351=head1 SEE ALSO 352 353L<POE> L<POE::Filter> L<POE::Filter::Line> 354L<POE::Component::Client::SMTP> L<POE::Component::Server::SimpleSMTP> 355 356=head1 KNOWN ISSUES 357 358By default, InputLiteral is set to the default L<POE::Filter::Line> 359which can become an issue if you are using the filter on the receiving 360end. 361 362=head1 BUGS 363 364Please report any bugs or feature requests to 365C<bug-poe-filter-transparent-smtp at rt.cpan.org>, or through the web 366interface at 367L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=POE-Filter-Transparent-SMTP>. 368I will be notified, and then you'll automatically be notified of 369progress on your bug as I make changes. 370 371=head1 SUPPORT 372 373You can find documentation for this module with the perldoc command. 374 375 perldoc POE::Filter::Transparent::SMTP 376 377You can also look for information at: 378 379=over 4 380 381=item * RT: CPAN's request tracker 382 383L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=POE-Filter-Transparent-SMTP> 384 385=item * AnnoCPAN: Annotated CPAN documentation 386 387L<http://annocpan.org/dist/POE-Filter-Transparent-SMTP> 388 389=item * CPAN Ratings 390 391L<http://cpanratings.perl.org/d/POE-Filter-Transparent-SMTP> 392 393=item * Search CPAN 394 395L<http://search.cpan.org/dist/POE-Filter-Transparent-SMTP> 396 397=back 398 399=head1 ACKNOWLEDGMENTS 400 401Thanks to Jay Jarvinen who pointed out that 402L<POE::Component::Client::SMTP> is not doing SMTP transparency as it 403should (RFC 821, Section 4.5.2. TRANSPARENCY) 404 405=head1 AUTHOR 406 407George Nistorica, ultradm __at cpan __dot org 408 409=head1 COPYRIGHT & LICENSE 410 411Copyright 2008-2009 George Nistorica, all rights reserved. This program is 412free software; you can redistribute it and/or modify it under the same 413terms as Perl itself. 414 415=cut 416