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__ |