File Coverage

blib/lib/BW/Email.pm
Criterion Covered Total %
statement 15 158 9.4
branch 0 70 0.0
condition 0 32 0.0
subroutine 5 31 16.1
pod 20 25 80.0
total 40 316 12.6


line stmt bran cond sub pod time code
1             # BW::Email.pm
2             # Email support for BW::*
3             #
4             # by Bill Weinman - http://bw.org/
5             # Copyright (c) 1995-2010 The BearHeart Group, LLC
6             #
7             # See POD for History
8              
9             package BW::Email;
10 1     1   1170 use strict;
  1         2  
  1         85  
11 1     1   5 use warnings;
  1         2  
  1         32  
12              
13 1     1   4 use base qw( BW::Base );
  1         2  
  1         75  
14 1     1   5 use BW::Constants;
  1         2  
  1         72  
15 1     1   2743 use IO::Socket::INET;
  1         31437  
  1         9  
16              
17             our $VERSION = "1.0.3";
18              
19             sub _init
20             {
21 0     0     my $self = shift;
22 0           $self->SUPER::_init(@_);
23              
24 0 0 0       $self->helo( $ENV{HTTP_HOST} || $ENV{SERVER_NAME} || "mail" ) unless $self->helo;
25              
26 0 0         $self->smtp_port(25) unless $self->smtp_port;
27 0   0       $self->{received_from} = $ENV{REMOTE_ADDR} || '';
28 0 0         $self->{received_from} .= ' (' . $ENV{REMOTE_HOST} . ')' if $ENV{REMOTE_HOST};
29 0 0         $self->{received_with} = "$ENV{SERVER_PROTOCOL} ($ENV{GATEWAY_INTERFACE}/$ENV{REQUEST_METHOD})" if $ENV{SERVER_PROTOCOL};
30 0 0         $self->{received_okay} = TRUE if $self->{received_from};
31 0           $self->{smtp_date} = $self->smtpdate;
32 0           $self->{extra_headers} = {};
33              
34 0           $self->{smtp_rc} = [];
35              
36 0           return SUCCESS;
37             }
38              
39             # _setter_getter entry points
40 0     0 0   sub smtp_host { BW::Base::_setter_getter(@_); }
41 0     0 0   sub smtp_port { BW::Base::_setter_getter(@_); }
42 0     0 0   sub timeout { BW::Base::_setter_getter(@_); }
43 0     0 0   sub helo { BW::Base::_setter_getter(@_); }
44 0     0 1   sub email_to { BW::Base::_setter_getter(@_); }
45 0     0 1   sub email_to_name { BW::Base::_setter_getter(@_); }
46 0     0 1   sub email_from { BW::Base::_setter_getter(@_); }
47 0     0 1   sub email_from_name { BW::Base::_setter_getter(@_); }
48 0     0 1   sub email_body { BW::Base::_setter_getter(@_); }
49 0     0 1   sub email_subject { BW::Base::_setter_getter(@_); }
50              
51             sub validate_email
52             {
53 0     0 1   my $email = shift;
54              
55 0 0         if ( ref($email) ) { # allow for object or direct
56 0           $email = shift;
57             }
58              
59 0 0         return FAILURE unless $email;
60              
61             # this should really do a DNS test too.
62 0 0         if ( $email =~ /^[^\x00-\x20()\<\>\[\]\@\,\;\:\\\/"]+\@[^\x00-\x20()\<\>\[\]\@\,\;\:\\\/"]+$/i ) { return SUCCESS; }
  0            
63 0           else { return FAILURE }
64             }
65              
66             # smtpdate
67             # returns a formatted date string suitable for SMTP
68             #
69             sub smtpdate
70             {
71 0     0 1   my $self = shift;
72 0   0       my $t = shift || time;
73 0           my @days = qw( Sun Mon Tue Wed Thu Fri Sat );
74 0           my @months = qw( Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec );
75 0           my $i;
76 0           my ( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst ) = localtime(time);
77 0           my @gm = gmtime($t);
78 0 0         my $hoffset = sprintf( "%+2.02d00", ( $i = ( $hour - $gm[2] ) ) > 12 ? ( $i - 24 ) : $i );
79 0           return sprintf( "%s, %d %s %d %02d:%02d:%02d $hoffset", $days[$wday], $mday, $months[$mon], $year + 1900, $hour, $min, $sec );
80             }
81              
82             sub header
83             {
84 0     0 1   my $self = shift;
85              
86 0 0         if (@_) {
87 0           my $header_name = shift;
88 0   0       my $header_value = shift || '';
89 0           $self->{extra_headers}->{$header_name} = $header_value;
90             }
91 0           return $self->{extra_headers};
92             }
93              
94 0     0 1   sub headers { header(@_) }
95              
96             sub from_line
97             {
98 0     0 0   my $self = shift;
99 0 0         $self->{from_line} = $self->email_from_name ? $self->email_from_name . " <" . $self->email_from . ">" : $self->email_from;
100 0           return $self->{from_line};
101             }
102              
103             sub date
104             {
105 0     0 1   my $self = shift;
106 0           return $self->{smtp_date};
107             }
108              
109             sub to_line
110             {
111 0     0 1   my $self = shift;
112 0 0         $self->{to_line} = $self->email_to_name ? $self->email_to_name . " <" . $self->email_to . ">" : $self->email_to;
113 0           return $self->{to_line};
114             }
115              
116             sub return_path
117             {
118 0     0 1   my $self = shift;
119 0           my $rp = shift;
120 0 0         $self->{return_path} = $rp if $rp;
121 0   0       return $self->{return_path} || $self->email_from || '';
122             }
123              
124             sub message
125             {
126 0     0 1   my $self = shift;
127 0           my $s = '';
128              
129 0           my $body = $self->email_body;
130              
131             # this ensures that there are no bare linefeeds anywhere in the message.
132             # it seems a bit extreme, but it's the only way I could find that worked.
133 0 0         if ($body) {
134 0           my @body = split( /\x0a/, $body ); # split on LF
135 0           grep { s/\x0d$// } @body; # loose any extraneous CRs
  0            
136 0           $body = join( CRLF, @body ); # put 'em all back as CRLF
137             }
138              
139 0 0 0       return $self->_error("cannot build message without both FROM and TO") unless ( $self->email_from and $self->email_to );
140              
141 0           my $extra_headers = $self->headers;
142 0           my @top_headers = qw( Return-Path Errors-To );
143              
144 0           foreach my $h (@top_headers) {
145 0 0         $s .= "${h}: " . $extra_headers->{$h} . CRLF if $extra_headers->{$h};
146             }
147 0 0         $s .= 'Received: ' . $self->received . CRLF if $self->{received_okay};
148              
149 0           foreach my $h ( keys %$extra_headers ) {
150 0 0         next if grep { $h eq $_ } @top_headers; # skip top headers
  0            
151 0           $s .= $h . ": " . $extra_headers->{$h} . CRLF;
152             }
153              
154 0           $s .= 'Date: ' . $self->date . CRLF;
155 0 0         $s .= 'Subject: ' . $self->email_subject . CRLF if $self->email_subject;
156 0           $s .= 'From: ' . $self->from_line . CRLF;
157 0           $s .= 'To: ' . $self->to_line . CRLF;
158 0           $s .= CRLF;
159 0 0         $s .= $body . CRLF if $body;
160 0           return $s;
161             }
162              
163             sub received
164             {
165 0     0 1   my $self = shift;
166 0           my $s = '';
167              
168 0 0         $s .= "from " . $self->{received_from} if $self->{received_from};
169 0 0 0       $s .= CRLF . " " if $s and $self->helo;
170 0 0         $s .= "by " . $self->helo if $self->helo;
171 0 0 0       $s .= CRLF . " " if $s && $self->{received_with};
172 0 0         $s .= "with " . $self->{received_with} if $self->{received_with};
173 0 0         $s .= ";" . CRLF . " " if $s;
174 0           $s .= $self->{smtp_date};
175              
176 0           return $s;
177             }
178              
179             sub rc_line
180             {
181 0     0 1   my $self = shift;
182 0   0       my $line = shift || '';
183 0           my $socket = $self->{socket};
184              
185 0           $self->{smtp_result} = 0;
186 0           $self->{smtp_result_text} = '';
187 0           $self->{smtp_result_line} = '';
188              
189 0           while ( $line =~ /\d{3}-(.*)/ ) {
190 0           $self->{smtp_result_text} .= $1;
191 0           $line = $socket->getline;
192             }
193              
194 0           $line =~ s/[\x0d\x0a]+$//;
195 0           push @{ $self->{smtp_rc} }, $line;
  0            
196              
197 0           my ( $lh, $rh ) = split( m/ /, $line, 2 );
198 0   0       $self->{smtp_result} .= $lh || 0;
199 0   0       $self->{smtp_result_text} .= $rh || '';
200 0           $self->{smtp_result_line} .= $line;
201              
202 0           return $self->{smtp_rc};
203             }
204              
205             sub make_smtp_socket
206             {
207 0     0 1   my $self = shift;
208              
209 0 0         return $self->_error("make_smtp_socket: missing smtp_host value") unless($self->smtp_host);
210              
211 0           my $s = new IO::Socket::INET(
212             PeerAddr => $self->smtp_host,
213             PeerPort => $self->smtp_port,
214             Proto => 'tcp',
215             Timeout => $self->timeout
216             );
217              
218 0 0         return $self->_error("make_smtp_socket: $!") unless($s);
219              
220             # autoflush is already set in later versions of the IO library, but we do
221             # it here anyway -- it's cheap insurance
222 0           $s->autoflush(1);
223              
224 0           $self->{socket} = $s;
225             }
226              
227             sub smtp_lineout
228             {
229 0     0 1   my $self = shift;
230 0           my $line = shift;
231 0           my $socket = $self->{socket};
232 0           $socket->print( $line . CRLF );
233 0           $self->rc_line( $socket->getline );
234             }
235              
236             sub smtp_transaction
237             {
238 0     0 1   my $self = shift;
239 0           my $socket = $self->{socket};
240 0           my $rc = $self->{smtp_rc};
241              
242 0           $self->rc_line( scalar <$socket> ); # get the SMTP signon
243 0 0         return $self->_error(qq{SMTP Connect: SMTP server said "$self->{smtp_result_line}", quitting.})
244             unless $self->{smtp_result} == 220;
245              
246             # HELO
247 0           $self->smtp_lineout("HELO " . $self->helo);
248 0 0         return $self->_error(qq{SMTP HELO: SMTP server said "$self->{smtp_result_line}", quitting.})
249             unless $self->{smtp_result} == 250;
250              
251             # MAIL FROM
252 0           $self->smtp_lineout( "MAIL FROM:<" . $self->return_path . ">" );
253 0 0 0       return $self->_error(qq{SMTP MAIL FROM: SMTP server said "$self->{smtp_result_line}", quitting.})
254             unless ( $self->{smtp_result} >= 250 and $self->{smtp_result} < 260 );
255              
256             # RCPT TO
257 0           $self->smtp_lineout("RCPT TO:<" . $self->email_to . ">");
258 0 0 0       return $self->_error(qq{SMTP RCPT: SMTP server said "$self->{smtp_result_line}", quitting.})
259             unless ( $self->{smtp_result} >= 250 and $self->{smtp_result} < 260 );
260              
261             # Send the DATA command
262 0           $self->smtp_lineout('DATA');
263 0 0         return $self->_error(qq{SMTP DATA: SMTP server said "$self->{smtp_result_line}", quitting.})
264             unless $self->{smtp_result} == 354;
265              
266             # send the message itself
267 0           $socket->print( $self->message . CRLF . '.' . CRLF );
268 0           $self->rc_line( $socket->getline );
269 0 0         return $self->_error(qq{SMTP DATA End: SMTP server said "$self->{smtp_result_line}", quitting.})
270             unless $self->{smtp_result} == 250;
271              
272             # Done: send QUIT
273             # no need to check the value of the return code.
274 0           $self->smtp_lineout('QUIT');
275              
276 0           $socket->close;
277              
278 0           return $rc;
279             }
280              
281             sub send
282             {
283 0     0 1   my $self = shift;
284 0           my $message = $self->message;
285              
286 0 0         if ( $self->make_smtp_socket ) {
287 0           $self->smtp_transaction;
288             }
289             }
290              
291             1;
292              
293             __END__