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