Commit | Line | Data |
---|---|---|
406c51ee JH |
1 | # Net::POP3.pm |
2 | # | |
2e173144 CBW |
3 | # Versions up to 2.29 Copyright (c) 1995-2004 Graham Barr <gbarr@pobox.com>. |
4 | # All rights reserved. | |
db956464 | 5 | # Changes in Version 2.29_01 onwards Copyright (C) 2013-2015 Steve Hay. All |
2e173144 | 6 | # rights reserved. |
a4f8ff46 SH |
7 | # This module is free software; you can redistribute it and/or modify it under |
8 | # the same terms as Perl itself, i.e. under the terms of either the GNU General | |
9 | # Public License or the Artistic License, as specified in the F<LICENCE> file. | |
406c51ee JH |
10 | |
11 | package Net::POP3; | |
12 | ||
2e173144 CBW |
13 | use 5.008001; |
14 | ||
406c51ee | 15 | use strict; |
2e173144 CBW |
16 | use warnings; |
17 | ||
18 | use Carp; | |
406c51ee | 19 | use IO::Socket; |
406c51ee | 20 | use Net::Cmd; |
406c51ee JH |
21 | use Net::Config; |
22 | ||
bfdb5bfe | 23 | our $VERSION = "3.08"; |
406c51ee | 24 | |
2e173144 CBW |
25 | # Code for detecting if we can use SSL |
26 | my $ssl_class = eval { | |
27 | require IO::Socket::SSL; | |
28 | # first version with default CA on most platforms | |
2901a52f CBW |
29 | no warnings 'numeric'; |
30 | IO::Socket::SSL->VERSION(2.007); | |
2e173144 | 31 | } && 'IO::Socket::SSL'; |
406c51ee | 32 | |
2e173144 | 33 | my $nossl_warn = !$ssl_class && |
2901a52f | 34 | 'To use SSL please install IO::Socket::SSL with version>=2.007'; |
2e173144 CBW |
35 | |
36 | # Code for detecting if we can use IPv6 | |
db956464 | 37 | my $family_key = 'Domain'; |
2e173144 CBW |
38 | my $inet6_class = eval { |
39 | require IO::Socket::IP; | |
2901a52f | 40 | no warnings 'numeric'; |
db956464 CBW |
41 | IO::Socket::IP->VERSION(0.20) || die; |
42 | $family_key = 'Family'; | |
2e173144 CBW |
43 | } && 'IO::Socket::IP' || eval { |
44 | require IO::Socket::INET6; | |
2901a52f | 45 | no warnings 'numeric'; |
2e173144 CBW |
46 | IO::Socket::INET6->VERSION(2.62); |
47 | } && 'IO::Socket::INET6'; | |
48 | ||
db956464 | 49 | |
2e173144 CBW |
50 | sub can_ssl { $ssl_class }; |
51 | sub can_inet6 { $inet6_class }; | |
52 | ||
53 | our @ISA = ('Net::Cmd', $inet6_class || 'IO::Socket::INET'); | |
b3f6f6a6 RGS |
54 | |
55 | sub new { | |
56 | my $self = shift; | |
57 | my $type = ref($self) || $self; | |
58 | my ($host, %arg); | |
59 | if (@_ % 2) { | |
60 | $host = shift; | |
61 | %arg = @_; | |
62 | } | |
63 | else { | |
64 | %arg = @_; | |
65 | $host = delete $arg{Host}; | |
66 | } | |
67 | my $hosts = defined $host ? [$host] : $NetConfig{pop3_hosts}; | |
68 | my $obj; | |
b3f6f6a6 | 69 | |
2e173144 CBW |
70 | if ($arg{SSL}) { |
71 | # SSL from start | |
72 | die $nossl_warn if !$ssl_class; | |
73 | $arg{Port} ||= 995; | |
74 | } | |
75 | ||
76 | $arg{Timeout} = 120 if ! defined $arg{Timeout}; | |
77 | ||
78 | foreach my $h (@{$hosts}) { | |
b3f6f6a6 RGS |
79 | $obj = $type->SUPER::new( |
80 | PeerAddr => ($host = $h), | |
81 | PeerPort => $arg{Port} || 'pop3(110)', | |
82 | Proto => 'tcp', | |
db956464 CBW |
83 | $family_key => $arg{Domain} || $arg{Family}, |
84 | LocalAddr => $arg{LocalAddr}, | |
85 | LocalPort => exists($arg{ResvPort}) ? $arg{ResvPort} : $arg{LocalPort}, | |
2e173144 | 86 | Timeout => $arg{Timeout}, |
b3f6f6a6 RGS |
87 | ) |
88 | and last; | |
406c51ee JH |
89 | } |
90 | ||
2e173144 | 91 | return |
b3f6f6a6 | 92 | unless defined $obj; |
406c51ee | 93 | |
2e173144 | 94 | ${*$obj}{'net_pop3_arg'} = \%arg; |
2901a52f | 95 | ${*$obj}{'net_pop3_host'} = $host; |
2e173144 | 96 | if ($arg{SSL}) { |
2901a52f | 97 | Net::POP3::_SSL->start_SSL($obj,%arg) or return; |
2e173144 CBW |
98 | } |
99 | ||
b3f6f6a6 RGS |
100 | $obj->autoflush(1); |
101 | $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef); | |
406c51ee | 102 | |
b3f6f6a6 RGS |
103 | unless ($obj->response() == CMD_OK) { |
104 | $obj->close(); | |
2e173144 | 105 | return; |
406c51ee JH |
106 | } |
107 | ||
b3f6f6a6 | 108 | ${*$obj}{'net_pop3_banner'} = $obj->message; |
406c51ee | 109 | |
b3f6f6a6 | 110 | $obj; |
406c51ee JH |
111 | } |
112 | ||
b3f6f6a6 | 113 | |
f92f3fcb | 114 | sub host { |
b3f6f6a6 RGS |
115 | my $me = shift; |
116 | ${*$me}{'net_pop3_host'}; | |
f92f3fcb GB |
117 | } |
118 | ||
406c51ee JH |
119 | ## |
120 | ## We don't want people sending me their passwords when they report problems | |
121 | ## now do we :-) | |
122 | ## | |
123 | ||
b3f6f6a6 | 124 | |
406c51ee JH |
125 | sub debug_text { $_[2] =~ /^(pass|rpop)/i ? "$1 ....\n" : $_[2]; } |
126 | ||
406c51ee | 127 | |
b3f6f6a6 RGS |
128 | sub login { |
129 | @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->login( USER, PASS )'; | |
130 | my ($me, $user, $pass) = @_; | |
131 | ||
132 | if (@_ <= 2) { | |
133 | ($user, $pass) = $me->_lookup_credentials($user); | |
134 | } | |
406c51ee | 135 | |
b3f6f6a6 RGS |
136 | $me->user($user) |
137 | and $me->pass($pass); | |
406c51ee JH |
138 | } |
139 | ||
2e173144 CBW |
140 | sub starttls { |
141 | my $self = shift; | |
142 | $ssl_class or die $nossl_warn; | |
143 | $self->_STLS or return; | |
144 | Net::POP3::_SSL->start_SSL($self, | |
145 | %{ ${*$self}{'net_pop3_arg'} }, # (ssl) args given in new | |
146 | @_ # more (ssl) args | |
147 | ) or return; | |
148 | return 1; | |
149 | } | |
12df23ee | 150 | |
b3f6f6a6 RGS |
151 | sub apop { |
152 | @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->apop( USER, PASS )'; | |
153 | my ($me, $user, $pass) = @_; | |
154 | my $banner; | |
155 | my $md; | |
406c51ee | 156 | |
b3f6f6a6 RGS |
157 | if (eval { local $SIG{__DIE__}; require Digest::MD5 }) { |
158 | $md = Digest::MD5->new(); | |
159 | } | |
160 | elsif (eval { local $SIG{__DIE__}; require MD5 }) { | |
161 | $md = MD5->new(); | |
162 | } | |
163 | else { | |
164 | carp "You need to install Digest::MD5 or MD5 to use the APOP command"; | |
2e173144 | 165 | return; |
b3f6f6a6 RGS |
166 | } |
167 | ||
2e173144 | 168 | return |
b3f6f6a6 | 169 | unless ($banner = (${*$me}{'net_pop3_banner'} =~ /(<.*>)/)[0]); |
406c51ee | 170 | |
b3f6f6a6 RGS |
171 | if (@_ <= 2) { |
172 | ($user, $pass) = $me->_lookup_credentials($user); | |
173 | } | |
406c51ee | 174 | |
b3f6f6a6 | 175 | $md->add($banner, $pass); |
406c51ee | 176 | |
2e173144 | 177 | return |
b3f6f6a6 | 178 | unless ($me->_APOP($user, $md->hexdigest)); |
406c51ee | 179 | |
b3f6f6a6 | 180 | $me->_get_mailbox_count(); |
406c51ee JH |
181 | } |
182 | ||
b3f6f6a6 RGS |
183 | |
184 | sub user { | |
185 | @_ == 2 or croak 'usage: $pop3->user( USER )'; | |
186 | $_[0]->_USER($_[1]) ? 1 : undef; | |
406c51ee JH |
187 | } |
188 | ||
406c51ee | 189 | |
b3f6f6a6 RGS |
190 | sub pass { |
191 | @_ == 2 or croak 'usage: $pop3->pass( PASS )'; | |
406c51ee | 192 | |
b3f6f6a6 | 193 | my ($me, $pass) = @_; |
406c51ee | 194 | |
2e173144 | 195 | return |
b3f6f6a6 RGS |
196 | unless ($me->_PASS($pass)); |
197 | ||
198 | $me->_get_mailbox_count(); | |
406c51ee JH |
199 | } |
200 | ||
406c51ee | 201 | |
b3f6f6a6 RGS |
202 | sub reset { |
203 | @_ == 1 or croak 'usage: $obj->reset()'; | |
204 | ||
205 | my $me = shift; | |
406c51ee | 206 | |
b3f6f6a6 RGS |
207 | return 0 |
208 | unless ($me->_RSET); | |
686337f3 | 209 | |
b3f6f6a6 RGS |
210 | if (defined ${*$me}{'net_pop3_mail'}) { |
211 | local $_; | |
212 | foreach (@{${*$me}{'net_pop3_mail'}}) { | |
213 | delete $_->{'net_pop3_deleted'}; | |
406c51ee JH |
214 | } |
215 | } | |
216 | } | |
217 | ||
406c51ee | 218 | |
b3f6f6a6 RGS |
219 | sub last { |
220 | @_ == 1 or croak 'usage: $obj->last()'; | |
221 | ||
2e173144 | 222 | return |
406c51ee JH |
223 | unless $_[0]->_LAST && $_[0]->message =~ /(\d+)/; |
224 | ||
b3f6f6a6 | 225 | return $1; |
406c51ee JH |
226 | } |
227 | ||
406c51ee | 228 | |
b3f6f6a6 RGS |
229 | sub top { |
230 | @_ == 2 || @_ == 3 or croak 'usage: $pop3->top( MSGNUM [, NUMLINES ])'; | |
231 | my $me = shift; | |
232 | ||
2e173144 | 233 | return |
406c51ee JH |
234 | unless $me->_TOP($_[0], $_[1] || 0); |
235 | ||
b3f6f6a6 | 236 | $me->read_until_dot; |
406c51ee JH |
237 | } |
238 | ||
406c51ee | 239 | |
b3f6f6a6 RGS |
240 | sub popstat { |
241 | @_ == 1 or croak 'usage: $pop3->popstat()'; | |
242 | my $me = shift; | |
243 | ||
244 | return () | |
406c51ee JH |
245 | unless $me->_STAT && $me->message =~ /(\d+)\D+(\d+)/; |
246 | ||
b3f6f6a6 | 247 | ($1 || 0, $2 || 0); |
406c51ee JH |
248 | } |
249 | ||
406c51ee | 250 | |
b3f6f6a6 RGS |
251 | sub list { |
252 | @_ == 1 || @_ == 2 or croak 'usage: $pop3->list( [ MSGNUM ] )'; | |
253 | my $me = shift; | |
254 | ||
2e173144 | 255 | return |
406c51ee JH |
256 | unless $me->_LIST(@_); |
257 | ||
b3f6f6a6 RGS |
258 | if (@_) { |
259 | $me->message =~ /\d+\D+(\d+)/; | |
260 | return $1 || undef; | |
406c51ee | 261 | } |
686337f3 | 262 | |
b3f6f6a6 | 263 | my $info = $me->read_until_dot |
2e173144 | 264 | or return; |
406c51ee | 265 | |
b3f6f6a6 | 266 | my %hash = map { (/(\d+)\D+(\d+)/) } @$info; |
406c51ee | 267 | |
b3f6f6a6 | 268 | return \%hash; |
406c51ee JH |
269 | } |
270 | ||
406c51ee | 271 | |
b3f6f6a6 RGS |
272 | sub get { |
273 | @_ == 2 or @_ == 3 or croak 'usage: $pop3->get( MSGNUM [, FH ])'; | |
274 | my $me = shift; | |
275 | ||
2e173144 | 276 | return |
406c51ee JH |
277 | unless $me->_RETR(shift); |
278 | ||
b3f6f6a6 | 279 | $me->read_until_dot(@_); |
406c51ee JH |
280 | } |
281 | ||
12df23ee | 282 | |
b3f6f6a6 RGS |
283 | sub getfh { |
284 | @_ == 2 or croak 'usage: $pop3->getfh( MSGNUM )'; | |
285 | my $me = shift; | |
12df23ee | 286 | |
b3f6f6a6 RGS |
287 | return unless $me->_RETR(shift); |
288 | return $me->tied_fh; | |
289 | } | |
12df23ee GB |
290 | |
291 | ||
b3f6f6a6 RGS |
292 | sub delete { |
293 | @_ == 2 or croak 'usage: $pop3->delete( MSGNUM )'; | |
294 | my $me = shift; | |
295 | return 0 unless $me->_DELE(@_); | |
296 | ${*$me}{'net_pop3_deleted'} = 1; | |
406c51ee JH |
297 | } |
298 | ||
406c51ee | 299 | |
b3f6f6a6 RGS |
300 | sub uidl { |
301 | @_ == 1 || @_ == 2 or croak 'usage: $pop3->uidl( [ MSGNUM ] )'; | |
302 | my $me = shift; | |
303 | my $uidl; | |
304 | ||
305 | $me->_UIDL(@_) | |
2e173144 | 306 | or return; |
b3f6f6a6 RGS |
307 | if (@_) { |
308 | $uidl = ($me->message =~ /\d+\s+([\041-\176]+)/)[0]; | |
406c51ee | 309 | } |
b3f6f6a6 RGS |
310 | else { |
311 | my $ref = $me->read_until_dot | |
2e173144 | 312 | or return; |
b3f6f6a6 | 313 | $uidl = {}; |
2e173144 | 314 | foreach my $ln (@$ref) { |
b3f6f6a6 RGS |
315 | my ($msg, $uid) = $ln =~ /^\s*(\d+)\s+([\041-\176]+)/; |
316 | $uidl->{$msg} = $uid; | |
317 | } | |
406c51ee | 318 | } |
b3f6f6a6 | 319 | return $uidl; |
406c51ee JH |
320 | } |
321 | ||
406c51ee | 322 | |
b3f6f6a6 RGS |
323 | sub ping { |
324 | @_ == 2 or croak 'usage: $pop3->ping( USER )'; | |
325 | my $me = shift; | |
326 | ||
327 | return () unless $me->_PING(@_) && $me->message =~ /(\d+)\D+(\d+)/; | |
406c51ee | 328 | |
b3f6f6a6 | 329 | ($1 || 0, $2 || 0); |
406c51ee JH |
330 | } |
331 | ||
b3f6f6a6 RGS |
332 | |
333 | sub _lookup_credentials { | |
12df23ee GB |
334 | my ($me, $user) = @_; |
335 | ||
336 | require Net::Netrc; | |
337 | ||
b3f6f6a6 RGS |
338 | $user ||= eval { local $SIG{__DIE__}; (getpwuid($>))[0] } |
339 | || $ENV{NAME} | |
340 | || $ENV{USER} | |
341 | || $ENV{LOGNAME}; | |
12df23ee | 342 | |
b3f6f6a6 | 343 | my $m = Net::Netrc->lookup(${*$me}{'net_pop3_host'}, $user); |
12df23ee GB |
344 | $m ||= Net::Netrc->lookup(${*$me}{'net_pop3_host'}); |
345 | ||
b3f6f6a6 RGS |
346 | my $pass = $m |
347 | ? $m->password || "" | |
348 | : ""; | |
12df23ee GB |
349 | |
350 | ($user, $pass); | |
351 | } | |
352 | ||
b3f6f6a6 RGS |
353 | |
354 | sub _get_mailbox_count { | |
12df23ee | 355 | my ($me) = @_; |
b3f6f6a6 RGS |
356 | my $ret = ${*$me}{'net_pop3_count'} = |
357 | ($me->message =~ /(\d+)\s+message/io) ? $1 : ($me->popstat)[0]; | |
12df23ee GB |
358 | |
359 | $ret ? $ret : "0E0"; | |
360 | } | |
361 | ||
686337f3 | 362 | |
8723f121 SH |
363 | sub _STAT { shift->command('STAT' )->response() == CMD_OK } |
364 | sub _LIST { shift->command('LIST', @_)->response() == CMD_OK } | |
b3f6f6a6 RGS |
365 | sub _RETR { shift->command('RETR', $_[0])->response() == CMD_OK } |
366 | sub _DELE { shift->command('DELE', $_[0])->response() == CMD_OK } | |
8723f121 SH |
367 | sub _NOOP { shift->command('NOOP' )->response() == CMD_OK } |
368 | sub _RSET { shift->command('RSET' )->response() == CMD_OK } | |
369 | sub _QUIT { shift->command('QUIT' )->response() == CMD_OK } | |
370 | sub _TOP { shift->command( 'TOP', @_)->response() == CMD_OK } | |
371 | sub _UIDL { shift->command('UIDL', @_)->response() == CMD_OK } | |
b3f6f6a6 RGS |
372 | sub _USER { shift->command('USER', $_[0])->response() == CMD_OK } |
373 | sub _PASS { shift->command('PASS', $_[0])->response() == CMD_OK } | |
8723f121 | 374 | sub _APOP { shift->command('APOP', @_)->response() == CMD_OK } |
b3f6f6a6 | 375 | sub _PING { shift->command('PING', $_[0])->response() == CMD_OK } |
b3f6f6a6 | 376 | sub _RPOP { shift->command('RPOP', $_[0])->response() == CMD_OK } |
8723f121 SH |
377 | sub _LAST { shift->command('LAST' )->response() == CMD_OK } |
378 | sub _CAPA { shift->command('CAPA' )->response() == CMD_OK } | |
2e173144 | 379 | sub _STLS { shift->command("STLS", )->response() == CMD_OK } |
f92f3fcb | 380 | |
406c51ee | 381 | |
b3f6f6a6 RGS |
382 | sub quit { |
383 | my $me = shift; | |
384 | ||
385 | $me->_QUIT; | |
386 | $me->close; | |
406c51ee JH |
387 | } |
388 | ||
406c51ee | 389 | |
b3f6f6a6 RGS |
390 | sub DESTROY { |
391 | my $me = shift; | |
392 | ||
393 | if (defined fileno($me) and ${*$me}{'net_pop3_deleted'}) { | |
394 | $me->reset; | |
395 | $me->quit; | |
406c51ee JH |
396 | } |
397 | } | |
398 | ||
399 | ## | |
400 | ## POP3 has weird responses, so we emulate them to look the same :-) | |
401 | ## | |
402 | ||
b3f6f6a6 | 403 | |
f92f3fcb GB |
404 | sub response { |
405 | my $cmd = shift; | |
2e173144 | 406 | my $str = $cmd->getline() or return; |
f92f3fcb | 407 | my $code = "500"; |
406c51ee | 408 | |
f92f3fcb GB |
409 | $cmd->debug_print(0, $str) |
410 | if ($cmd->debug); | |
406c51ee | 411 | |
f92f3fcb GB |
412 | if ($str =~ s/^\+OK\s*//io) { |
413 | $code = "200"; | |
406c51ee | 414 | } |
f92f3fcb GB |
415 | elsif ($str =~ s/^\+\s*//io) { |
416 | $code = "300"; | |
417 | } | |
418 | else { | |
419 | $str =~ s/^-ERR\s*//io; | |
406c51ee JH |
420 | } |
421 | ||
f92f3fcb GB |
422 | ${*$cmd}{'net_cmd_resp'} = [$str]; |
423 | ${*$cmd}{'net_cmd_code'} = $code; | |
406c51ee | 424 | |
f92f3fcb GB |
425 | substr($code, 0, 1); |
426 | } | |
427 | ||
428 | ||
429 | sub capa { | |
b3f6f6a6 RGS |
430 | my $this = shift; |
431 | my ($capa, %capabilities); | |
f92f3fcb | 432 | |
b3f6f6a6 RGS |
433 | # Fake a capability here |
434 | $capabilities{APOP} = '' if ($this->banner() =~ /<.*>/); | |
f92f3fcb | 435 | |
b3f6f6a6 RGS |
436 | if ($this->_CAPA()) { |
437 | $capabilities{CAPA} = 1; | |
438 | $capa = $this->read_until_dot(); | |
439 | %capabilities = (%capabilities, map {/^\s*(\S+)\s*(.*)/} @$capa); | |
440 | } | |
441 | else { | |
442 | ||
443 | # Check AUTH for SASL capabilities | |
444 | if ($this->command('AUTH')->response() == CMD_OK) { | |
445 | my $mechanism = $this->read_until_dot(); | |
446 | $capabilities{SASL} = join " ", map {m/([A-Z0-9_-]+)/} @{$mechanism}; | |
7cf5cf7c | 447 | } |
b3f6f6a6 RGS |
448 | } |
449 | ||
450 | return ${*$this}{'net_pop3e_capabilities'} = \%capabilities; | |
f92f3fcb GB |
451 | } |
452 | ||
b3f6f6a6 | 453 | |
f92f3fcb | 454 | sub capabilities { |
b3f6f6a6 | 455 | my $this = shift; |
f92f3fcb | 456 | |
b3f6f6a6 | 457 | ${*$this}{'net_pop3e_capabilities'} || $this->capa; |
f92f3fcb | 458 | } |
7cf5cf7c | 459 | |
f92f3fcb | 460 | |
b3f6f6a6 RGS |
461 | sub auth { |
462 | my ($self, $username, $password) = @_; | |
463 | ||
464 | eval { | |
465 | require MIME::Base64; | |
466 | require Authen::SASL; | |
467 | } or $self->set_status(500, ["Need MIME::Base64 and Authen::SASL todo auth"]), return 0; | |
468 | ||
469 | my $capa = $self->capa; | |
470 | my $mechanisms = $capa->{SASL} || 'CRAM-MD5'; | |
471 | ||
472 | my $sasl; | |
473 | ||
474 | if (ref($username) and UNIVERSAL::isa($username, 'Authen::SASL')) { | |
475 | $sasl = $username; | |
476 | my $user_mech = $sasl->mechanism || ''; | |
477 | my @user_mech = split(/\s+/, $user_mech); | |
478 | my %user_mech; | |
479 | @user_mech{@user_mech} = (); | |
480 | ||
481 | my @server_mech = split(/\s+/, $mechanisms); | |
482 | my @mech = @user_mech | |
483 | ? grep { exists $user_mech{$_} } @server_mech | |
484 | : @server_mech; | |
485 | unless (@mech) { | |
486 | $self->set_status( | |
487 | 500, | |
488 | [ 'Client SASL mechanisms (', | |
489 | join(', ', @user_mech), | |
490 | ') do not match the SASL mechnism the server announces (', | |
491 | join(', ', @server_mech), ')', | |
492 | ] | |
493 | ); | |
7cf5cf7c SP |
494 | return 0; |
495 | } | |
b3f6f6a6 RGS |
496 | |
497 | $sasl->mechanism(join(" ", @mech)); | |
498 | } | |
499 | else { | |
500 | die "auth(username, password)" if not length $username; | |
501 | $sasl = Authen::SASL->new( | |
502 | mechanism => $mechanisms, | |
503 | callback => { | |
504 | user => $username, | |
505 | pass => $password, | |
506 | authname => $username, | |
507 | } | |
508 | ); | |
509 | } | |
510 | ||
511 | # We should probably allow the user to pass the host, but I don't | |
512 | # currently know and SASL mechanisms that are used by smtp that need it | |
513 | my ($hostname) = split /:/, ${*$self}{'net_pop3_host'}; | |
514 | my $client = eval { $sasl->client_new('pop', $hostname, 0) }; | |
515 | ||
516 | unless ($client) { | |
517 | my $mech = $sasl->mechanism; | |
518 | $self->set_status( | |
519 | 500, | |
520 | [ " Authen::SASL failure: $@", | |
521 | '(please check if your local Authen::SASL installation', | |
522 | "supports mechanism '$mech'" | |
523 | ] | |
524 | ); | |
525 | return 0; | |
526 | } | |
527 | ||
528 | my ($token) = $client->client_start | |
529 | or do { | |
530 | my $mech = $client->mechanism; | |
531 | $self->set_status( | |
532 | 500, | |
533 | [ ' Authen::SASL failure: $client->client_start ', | |
534 | "mechanism '$mech' hostname #$hostname#", | |
535 | $client->error | |
536 | ] | |
537 | ); | |
538 | return 0; | |
539 | }; | |
540 | ||
07513bb4 | 541 | # We don't support sasl mechanisms that encrypt the socket traffic. |
b3f6f6a6 | 542 | # todo that we would really need to change the ISA hierarchy |
07513bb4 | 543 | # so we don't inherit from IO::Socket, but instead hold it in an attribute |
b3f6f6a6 RGS |
544 | |
545 | my @cmd = ("AUTH", $client->mechanism); | |
546 | my $code; | |
547 | ||
548 | push @cmd, MIME::Base64::encode_base64($token, '') | |
549 | if defined $token and length $token; | |
550 | ||
551 | while (($code = $self->command(@cmd)->response()) == CMD_MORE) { | |
552 | ||
553 | my ($token) = $client->client_step(MIME::Base64::decode_base64(($self->message)[0])) or do { | |
554 | $self->set_status( | |
555 | 500, | |
556 | [ ' Authen::SASL failure: $client->client_step ', | |
557 | "mechanism '", $client->mechanism, " hostname #$hostname#, ", | |
7cf5cf7c | 558 | $client->error |
b3f6f6a6 | 559 | ] |
7cf5cf7c | 560 | ); |
b3f6f6a6 RGS |
561 | return 0; |
562 | }; | |
563 | ||
564 | @cmd = (MIME::Base64::encode_base64(defined $token ? $token : '', '')); | |
565 | } | |
f92f3fcb | 566 | |
b3f6f6a6 | 567 | $code == CMD_OK; |
f92f3fcb GB |
568 | } |
569 | ||
b3f6f6a6 | 570 | |
f92f3fcb | 571 | sub banner { |
b3f6f6a6 | 572 | my $this = shift; |
f92f3fcb | 573 | |
b3f6f6a6 | 574 | return ${*$this}{'net_pop3_banner'}; |
406c51ee JH |
575 | } |
576 | ||
2e173144 CBW |
577 | { |
578 | package Net::POP3::_SSL; | |
579 | our @ISA = ( $ssl_class ? ($ssl_class):(), 'Net::POP3' ); | |
580 | sub starttls { die "POP3 connection is already in SSL mode" } | |
581 | sub start_SSL { | |
582 | my ($class,$pop3,%arg) = @_; | |
583 | delete @arg{ grep { !m{^SSL_} } keys %arg }; | |
584 | ( $arg{SSL_verifycn_name} ||= $pop3->host ) | |
a4f8ff46 | 585 | =~s{(?<!:):[\w()]+$}{}; # strip port |
2901a52f | 586 | $arg{SSL_hostname} = $arg{SSL_verifycn_name} |
a4f8ff46 | 587 | if ! defined $arg{SSL_hostname} && $class->can_client_sni; |
2e173144 CBW |
588 | $arg{SSL_verifycn_scheme} ||= 'pop3'; |
589 | my $ok = $class->SUPER::start_SSL($pop3,%arg); | |
590 | $@ = $ssl_class->errstr if !$ok; | |
591 | return $ok; | |
592 | } | |
593 | } | |
594 | ||
595 | ||
596 | ||
406c51ee JH |
597 | 1; |
598 | ||
599 | __END__ | |
600 | ||
601 | =head1 NAME | |
602 | ||
12df23ee | 603 | Net::POP3 - Post Office Protocol 3 Client class (RFC1939) |
406c51ee JH |
604 | |
605 | =head1 SYNOPSIS | |
606 | ||
607 | use Net::POP3; | |
686337f3 | 608 | |
406c51ee JH |
609 | # Constructors |
610 | $pop = Net::POP3->new('pop3host'); | |
611 | $pop = Net::POP3->new('pop3host', Timeout => 60); | |
2e173144 | 612 | $pop = Net::POP3->new('pop3host', SSL => 1, Timeout => 60); |
406c51ee | 613 | |
dea4d7df GB |
614 | if ($pop->login($username, $password) > 0) { |
615 | my $msgnums = $pop->list; # hashref of msgnum => size | |
616 | foreach my $msgnum (keys %$msgnums) { | |
617 | my $msg = $pop->get($msgnum); | |
618 | print @$msg; | |
619 | $pop->delete($msgnum); | |
620 | } | |
621 | } | |
622 | ||
623 | $pop->quit; | |
624 | ||
406c51ee JH |
625 | =head1 DESCRIPTION |
626 | ||
627 | This module implements a client interface to the POP3 protocol, enabling | |
628 | a perl5 application to talk to POP3 servers. This documentation assumes | |
12df23ee | 629 | that you are familiar with the POP3 protocol described in RFC1939. |
db956464 CBW |
630 | With L<IO::Socket::SSL> installed it also provides support for implicit and |
631 | explicit TLS encryption, i.e. POP3S or POP3+STARTTLS. | |
406c51ee JH |
632 | |
633 | A new Net::POP3 object must be created with the I<new> method. Once | |
634 | this has been done, all POP3 commands are accessed via method calls | |
635 | on the object. | |
636 | ||
db956464 CBW |
637 | The Net::POP3 class is a subclass of Net::Cmd and (depending on avaibility) of |
638 | IO::Socket::IP, IO::Socket::INET6 or IO::Socket::INET. | |
639 | ||
487a122b | 640 | |
406c51ee JH |
641 | =head1 CONSTRUCTOR |
642 | ||
643 | =over 4 | |
644 | ||
8723f121 | 645 | =item new ( [ HOST ] [, OPTIONS ] ) |
406c51ee JH |
646 | |
647 | This is the constructor for a new Net::POP3 object. C<HOST> is the | |
f92f3fcb | 648 | name of the remote host to which an POP3 connection is required. |
406c51ee | 649 | |
f92f3fcb GB |
650 | C<HOST> is optional. If C<HOST> is not given then it may instead be |
651 | passed as the C<Host> option described below. If neither is given then | |
652 | the C<POP3_Hosts> specified in C<Net::Config> will be used. | |
406c51ee JH |
653 | |
654 | C<OPTIONS> are passed in a hash like fashion, using key and value pairs. | |
655 | Possible options are: | |
656 | ||
f92f3fcb GB |
657 | B<Host> - POP3 host to connect to. It may be a single scalar, as defined for |
658 | the C<PeerAddr> option in L<IO::Socket::INET>, or a reference to | |
659 | an array with hosts to try in turn. The L</host> method will return the value | |
660 | which was used to connect to the host. | |
661 | ||
2e173144 CBW |
662 | B<Port> - port to connect to. |
663 | Default - 110 for plain POP3 and 995 for POP3s (direct SSL). | |
664 | ||
665 | B<SSL> - If the connection should be done from start with SSL, contrary to later | |
666 | upgrade with C<starttls>. | |
667 | You can use SSL arguments as documented in L<IO::Socket::SSL>, but it will | |
668 | usually use the right arguments already. | |
669 | ||
db956464 CBW |
670 | B<LocalAddr> and B<LocalPort> - These parameters are passed directly |
671 | to IO::Socket to allow binding the socket to a specific local address and port. | |
672 | For compatibility with older versions B<ResvPort> can be used instead of | |
673 | B<LocalPort>. | |
674 | ||
675 | B<Domain> - This parameter is passed directly to IO::Socket and makes it | |
676 | possible to enforce IPv4 connections even if L<IO::Socket::IP> is used as super | |
677 | class. Alternatively B<Family> can be used. | |
406c51ee JH |
678 | |
679 | B<Timeout> - Maximum time, in seconds, to wait for a response from the | |
680 | POP3 server (default: 120) | |
681 | ||
682 | B<Debug> - Enable debugging information | |
683 | ||
684 | =back | |
685 | ||
686 | =head1 METHODS | |
687 | ||
688 | Unless otherwise stated all methods return either a I<true> or I<false> | |
689 | value, with I<true> meaning that the operation was a success. When a method | |
690 | states that it returns a value, failure will be returned as I<undef> or an | |
691 | empty list. | |
692 | ||
487a122b SH |
693 | C<Net::POP3> inherits from C<Net::Cmd> so methods defined in C<Net::Cmd> may |
694 | be used to send commands to the remote POP3 server in addition to the methods | |
695 | documented here. | |
696 | ||
406c51ee JH |
697 | =over 4 |
698 | ||
2e173144 CBW |
699 | =item host () |
700 | ||
701 | Returns the value used by the constructor, and passed to IO::Socket::INET, | |
702 | to connect to the host. | |
703 | ||
f92f3fcb GB |
704 | =item auth ( USERNAME, PASSWORD ) |
705 | ||
706 | Attempt SASL authentication. | |
707 | ||
406c51ee JH |
708 | =item user ( USER ) |
709 | ||
710 | Send the USER command. | |
711 | ||
712 | =item pass ( PASS ) | |
713 | ||
714 | Send the PASS command. Returns the number of messages in the mailbox. | |
715 | ||
716 | =item login ( [ USER [, PASS ]] ) | |
717 | ||
d1be9408 | 718 | Send both the USER and PASS commands. If C<PASS> is not given the |
406c51ee JH |
719 | C<Net::POP3> uses C<Net::Netrc> to lookup the password using the host |
720 | and username. If the username is not specified then the current user name | |
721 | will be used. | |
722 | ||
723 | Returns the number of messages in the mailbox. However if there are no | |
724 | messages on the server the string C<"0E0"> will be returned. This is | |
725 | will give a true value in a boolean context, but zero in a numeric context. | |
726 | ||
727 | If there was an error authenticating the user then I<undef> will be returned. | |
728 | ||
2e173144 CBW |
729 | =item starttls ( SSLARGS ) |
730 | ||
731 | Upgrade existing plain connection to SSL. | |
732 | You can use SSL arguments as documented in L<IO::Socket::SSL>, but it will | |
733 | usually use the right arguments already. | |
734 | ||
12df23ee | 735 | =item apop ( [ USER [, PASS ]] ) |
406c51ee JH |
736 | |
737 | Authenticate with the server identifying as C<USER> with password C<PASS>. | |
12df23ee | 738 | Similar to L</login>, but the password is not sent in clear text. |
406c51ee | 739 | |
12df23ee GB |
740 | To use this method you must have the Digest::MD5 or the MD5 module installed, |
741 | otherwise this method will return I<undef>. | |
406c51ee | 742 | |
f92f3fcb GB |
743 | =item banner () |
744 | ||
745 | Return the sever's connection banner | |
746 | ||
747 | =item capa () | |
748 | ||
3c4b39be | 749 | Return a reference to a hash of the capabilities of the server. APOP |
f92f3fcb GB |
750 | is added as a pseudo capability. Note that I've been unable to |
751 | find a list of the standard capability values, and some appear to | |
752 | be multi-word and some are not. We make an attempt at intelligently | |
753 | parsing them, but it may not be correct. | |
754 | ||
755 | =item capabilities () | |
756 | ||
757 | Just like capa, but only uses a cache from the last time we asked | |
758 | the server, so as to avoid asking more than once. | |
759 | ||
406c51ee JH |
760 | =item top ( MSGNUM [, NUMLINES ] ) |
761 | ||
762 | Get the header and the first C<NUMLINES> of the body for the message | |
763 | C<MSGNUM>. Returns a reference to an array which contains the lines of text | |
764 | read from the server. | |
765 | ||
766 | =item list ( [ MSGNUM ] ) | |
767 | ||
768 | If called with an argument the C<list> returns the size of the message | |
769 | in octets. | |
770 | ||
771 | If called without arguments a reference to a hash is returned. The | |
772 | keys will be the C<MSGNUM>'s of all undeleted messages and the values will | |
773 | be their size in octets. | |
774 | ||
775 | =item get ( MSGNUM [, FH ] ) | |
776 | ||
777 | Get the message C<MSGNUM> from the remote mailbox. If C<FH> is not given | |
778 | then get returns a reference to an array which contains the lines of | |
779 | text read from the server. If C<FH> is given then the lines returned | |
780 | from the server are printed to the filehandle C<FH>. | |
781 | ||
12df23ee GB |
782 | =item getfh ( MSGNUM ) |
783 | ||
784 | As per get(), but returns a tied filehandle. Reading from this | |
785 | filehandle returns the requested message. The filehandle will return | |
786 | EOF at the end of the message and should not be reused. | |
787 | ||
406c51ee JH |
788 | =item last () |
789 | ||
790 | Returns the highest C<MSGNUM> of all the messages accessed. | |
791 | ||
792 | =item popstat () | |
793 | ||
794 | Returns a list of two elements. These are the number of undeleted | |
795 | elements and the size of the mbox in octets. | |
796 | ||
797 | =item ping ( USER ) | |
798 | ||
799 | Returns a list of two elements. These are the number of new messages | |
800 | and the total number of messages for C<USER>. | |
801 | ||
802 | =item uidl ( [ MSGNUM ] ) | |
803 | ||
804 | Returns a unique identifier for C<MSGNUM> if given. If C<MSGNUM> is not | |
805 | given C<uidl> returns a reference to a hash where the keys are the | |
806 | message numbers and the values are the unique identifiers. | |
807 | ||
808 | =item delete ( MSGNUM ) | |
809 | ||
810 | Mark message C<MSGNUM> to be deleted from the remote mailbox. All messages | |
811 | that are marked to be deleted will be removed from the remote mailbox | |
812 | when the server connection closed. | |
813 | ||
814 | =item reset () | |
815 | ||
3c4b39be | 816 | Reset the status of the remote POP3 server. This includes resetting the |
406c51ee JH |
817 | status of all messages to not be deleted. |
818 | ||
819 | =item quit () | |
820 | ||
821 | Quit and close the connection to the remote POP3 server. Any messages marked | |
822 | as deleted will be deleted from the remote mailbox. | |
823 | ||
2e173144 CBW |
824 | =item can_inet6 () |
825 | ||
826 | Returns whether we can use IPv6. | |
827 | ||
828 | =item can_ssl () | |
829 | ||
830 | Returns whether we can use SSL. | |
831 | ||
406c51ee JH |
832 | =back |
833 | ||
834 | =head1 NOTES | |
835 | ||
836 | If a C<Net::POP3> object goes out of scope before C<quit> method is called | |
837 | then the C<reset> method will called before the connection is closed. This | |
838 | means that any messages marked to be deleted will not be. | |
839 | ||
840 | =head1 SEE ALSO | |
841 | ||
12df23ee | 842 | L<Net::Netrc>, |
2e173144 CBW |
843 | L<Net::Cmd>, |
844 | L<IO::Socket::SSL> | |
406c51ee JH |
845 | |
846 | =head1 AUTHOR | |
847 | ||
2e173144 CBW |
848 | Graham Barr E<lt>F<gbarr@pobox.com>E<gt> |
849 | ||
850 | Steve Hay E<lt>F<shay@cpan.org>E<gt> is now maintaining libnet as of version | |
851 | 1.22_02 | |
406c51ee JH |
852 | |
853 | =head1 COPYRIGHT | |
854 | ||
2e173144 | 855 | Versions up to 2.29 Copyright (c) 1995-2004 Graham Barr. All rights reserved. |
db956464 | 856 | Changes in Version 2.29_01 onwards Copyright (C) 2013-2015 Steve Hay. All |
2e173144 CBW |
857 | rights reserved. |
858 | ||
a4f8ff46 SH |
859 | This module is free software; you can redistribute it and/or modify it under the |
860 | same terms as Perl itself, i.e. under the terms of either the GNU General Public | |
861 | License or the Artistic License, as specified in the F<LICENCE> file. | |
406c51ee JH |
862 | |
863 | =cut |