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