From: Graham Barr Date: Wed, 21 Nov 2001 18:30:10 +0000 (+0000) Subject: Sync file with libnet-1.0901-tobe X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c85707204c5d2a93ef021c88e43a92ba2d602304;p=p5sagit%2Fp5-mst-13.2.git Sync file with libnet-1.0901-tobe p4raw-id: //depot/perl@13178 --- diff --git a/MANIFEST b/MANIFEST index d83019a..5790403 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1136,11 +1136,14 @@ lib/Net/README.libnet libnet lib/Net/servent.pm By-name interface to Perl's builtin getserv* lib/Net/servent.t See if Net::servtent works lib/Net/SMTP.pm libnet +lib/Net/t/config.t libnet lib/Net/t/ftp.t libnet lib/Net/t/hostname.t libnet +lib/Net/t/libnet_t.pl libnet lib/Net/t/nntp.t libnet lib/Net/t/require.t libnet lib/Net/t/smtp.t libnet +lib/Net/t/time.t libnet lib/Net/Time.pm libnet lib/newgetopt.pl A perl library supporting long option parsing lib/NEXT.pm Pseudo-class NEXT for method redispatch diff --git a/lib/Net/ChangeLog.libnet b/lib/Net/ChangeLog.libnet index db4d1de..8ddb94e 100644 --- a/lib/Net/ChangeLog.libnet +++ b/lib/Net/ChangeLog.libnet @@ -1,3 +1,75 @@ +Change 683 on 2001/11/20 by (Graham Barr) + + Various doc cleanups + +Change 675 on 2001/11/20 by (Graham Barr) + + t/hostname.t + - Add test to check that hostname() does not modify $_ + +Change 674 on 2001/11/20 by (Graham Barr) + + Net::Config + - Dont treat "test_hosts" as an array of host names + +Change 673 on 2001/11/20 by (Graham Barr) + + Added test for Net::Netrc + patch from chromatic + +Change 672 on 2001/11/20 by (Graham Barr) + + Net::FTP + - Dont send QUIT on DESTROY. Causes problems when fork() is used. + +Change 671 on 2001/11/20 by (Graham Barr) + + Net::Domain + - Fix bug causing $_ to be modified + +Change 670 on 2001/11/20 by (Graham Barr) + + Net::FTP + - Send -anonymous@ as the password for the anonymous user, not + the real username. Patch from Eduardo P?rez Ureta + +Change 669 on 2001/11/20 by (Graham Barr) + + Add VERSION numbers to Net::FTP::L and Net::FTP::E + +Change 668 on 2001/11/20 by (Graham Barr) + + Net::Config + - Read some default values using Mac::InternetConfig if we are on the Mac + patch from Chris Nandor + +Change 667 on 2001/11/20 by (Graham Barr) + + Net::SMTP + - Add support for SASL AUTH (only PLAIN right now) + patch from Meng Weng Wong + +Change 666 on 2001/11/20 by (Graham Barr) + + t/config.t + - Use a fake inet_aton so we know that it will fail when expected + +Change 665 on 2001/11/02 by (Graham Barr) + + Release 1.09 + +Change 664 on 2001/10/29 by (Graham Barr) + + Added test for Net::Config from chromatic + +Change 663 on 2001/10/26 by (Graham Barr) + + More fixes from the core for undefs + +Change 662 on 2001/10/26 by (Graham Barr) + + Make tests compatable with the perl core distribution + Change 661 on 2001/10/26 by (Graham Barr) Add install-nomake to install libnet on machines that do not diff --git a/lib/Net/Config.pm b/lib/Net/Config.pm index 23db846..c09b834 100644 --- a/lib/Net/Config.pm +++ b/lib/Net/Config.pm @@ -13,7 +13,7 @@ use strict; @EXPORT = qw(%NetConfig); @ISA = qw(Net::LocalCfg Exporter); -$VERSION = "1.08"; # $Id: //depot/libnet/Net/Config.pm#13 $ +$VERSION = "1.09"; # $Id: //depot/libnet/Net/Config.pm#16 $ eval { local $SIG{__DIE__}; require Net::LocalCfg }; @@ -33,6 +33,30 @@ eval { local $SIG{__DIE__}; require Net::LocalCfg }; test_exist => 1, ); +# +# Try to get as much configuration info as possible from InternetConfig +# +$^O eq 'MacOS' and eval <<'TRY_INTERNET_CONFIG'; +use Mac::InternetConfig; + +{ +my %nc = ( + nntp_hosts => [ $InternetConfig{ kICNNTPHost()} ], + pop3_hosts => [ $InternetConfig{ kICMailAccount()} =~ /@(.*)/ ], + smtp_hosts => [ $InternetConfig{ kICSMTPHost()} ], + ftp_testhost => [ $InternetConfig{ kICFTPHost()} ], + ph_hosts => [ $InternetConfig{ kICPhHost()} ], + ftp_ext_passive => $InternetConfig{"646F676F€UsePassiveMode"} || 0, + ftp_int_passive => $InternetConfig{"646F676F€UsePassiveMode"} || 0, + socks_hosts => + $InternetConfig{kICUseSocks()} ? [ $InternetConfig{kICSocksHost()} ] : [], + ftp_firewall => + $InternetConfig{kICUseFTPProxy()} ? [ $InternetConfig{kICFTPProxyHost()} ] : [], +); +@NetConfig{keys %nc} = values %nc; +} +TRY_INTERNET_CONFIG + my $file = __FILE__; my $ref; $file =~ s/Config.pm/libnet.cfg/; @@ -56,7 +80,7 @@ if ($< == $> and !$CONFIGURE) { my ($k,$v); while(($k,$v) = each %NetConfig) { $NetConfig{$k} = [ $v ] - if($k =~ /_hosts$/ && !ref($v)); + if($k =~ /_hosts$/ and $k ne "test_hosts" and defined($v) and !ref($v)); } # Take a hostname and determine if it is inside the firewall @@ -285,6 +309,6 @@ If true then C will check each hostname given that it exists =for html
-I<$Id: //depot/libnet/Net/Config.pm#13 $> +I<$Id: //depot/libnet/Net/Config.pm#16 $> =cut diff --git a/lib/Net/Domain.pm b/lib/Net/Domain.pm index 62b9d96..b79ec8f 100644 --- a/lib/Net/Domain.pm +++ b/lib/Net/Domain.pm @@ -16,7 +16,7 @@ use Net::Config; @ISA = qw(Exporter); @EXPORT_OK = qw(hostname hostdomain hostfqdn domainname); -$VERSION = "2.16"; # $Id: //depot/libnet/Net/Domain.pm#18 $ +$VERSION = "2.17"; # $Id: //depot/libnet/Net/Domain.pm#19 $ my($host,$domain,$fqdn) = (undef,undef,undef); @@ -127,6 +127,7 @@ sub _hostdomain { # those on dialup systems. local *RES; + local($_); if(open(RES,"/etc/resolv.conf")) { while() { @@ -143,7 +144,6 @@ sub _hostdomain { my $host = _hostname(); my(@hosts); - local($_); @hosts = ($host,"localhost"); @@ -331,6 +331,6 @@ it under the same terms as Perl itself. =for html
-I<$Id: //depot/libnet/Net/Domain.pm#18 $> +I<$Id: //depot/libnet/Net/Domain.pm#19 $> =cut diff --git a/lib/Net/FTP.pm b/lib/Net/FTP.pm index ffa21e1..d2780d3 100644 --- a/lib/Net/FTP.pm +++ b/lib/Net/FTP.pm @@ -22,7 +22,7 @@ use Net::Config; use Fcntl qw(O_WRONLY O_RDONLY O_APPEND O_CREAT O_TRUNC); # use AutoLoader qw(AUTOLOAD); -$VERSION = "2.61"; # $Id: //depot/libnet/Net/FTP.pm#61 $ +$VERSION = "2.62"; # $Id: //depot/libnet/Net/FTP.pm#64 $ @ISA = qw(Exporter Net::Cmd IO::Socket::INET); # Someday I will "use constant", when I am not bothered to much about @@ -142,11 +142,7 @@ sub quit $ftp->close; } -sub DESTROY -{ - my $ftp = shift; - defined(fileno($ftp)) && $ftp->quit -} +sub DESTROY {} sub ascii { shift->type('A',@_); } sub binary { shift->type('I',@_); } @@ -310,7 +306,7 @@ sub login { ($ruser,$pass,$acct) = $rc->lpa() if ($rc); - $pass = "-" . (eval { (getpwuid($>))[0] } || $ENV{NAME} ) . '@' + $pass = '-anonymous@' if (!defined $pass && (!defined($ruser) || $ruser =~ /^anonymous/o)); } @@ -1200,7 +1196,7 @@ Net::FTP - FTP Client class use Net::FTP; $ftp = Net::FTP->new("some.host.name", Debug => 0); - $ftp->login("anonymous",'me@here.there'); + $ftp->login("anonymous",'-anonymous@'); $ftp->cwd("/pub"); $ftp->get("that.file"); $ftp->quit; @@ -1517,7 +1513,7 @@ C and those that do not require data connections. =item port ( [ PORT ] ) Send a C command to the server. If C is specified then it is sent -to the server. If not, the a listen socket is created and the correct information +to the server. If not, then a listen socket is created and the correct information sent to the server. =item pasv () @@ -1718,6 +1714,6 @@ under the same terms as Perl itself. =for html
-I<$Id: //depot/libnet/Net/FTP.pm#61 $> +I<$Id: //depot/libnet/Net/FTP.pm#64 $> =cut diff --git a/lib/Net/FTP/E.pm b/lib/Net/FTP/E.pm index 6e458bd..d480cd7 100644 --- a/lib/Net/FTP/E.pm +++ b/lib/Net/FTP/E.pm @@ -3,5 +3,6 @@ package Net::FTP::E; require Net::FTP::I; @ISA = qw(Net::FTP::I); +$VERSION = "0.01"; 1; diff --git a/lib/Net/FTP/L.pm b/lib/Net/FTP/L.pm index fbb5a5a..f7423cb 100644 --- a/lib/Net/FTP/L.pm +++ b/lib/Net/FTP/L.pm @@ -3,5 +3,6 @@ package Net::FTP::L; require Net::FTP::I; @ISA = qw(Net::FTP::I); +$VERSION = "0.01"; 1; diff --git a/lib/Net/NNTP.pm b/lib/Net/NNTP.pm index 53df6e0..0078cf4 100644 --- a/lib/Net/NNTP.pm +++ b/lib/Net/NNTP.pm @@ -14,7 +14,7 @@ use Carp; use Time::Local; use Net::Config; -$VERSION = "2.20"; # $Id: //depot/libnet/Net/NNTP.pm#13 $ +$VERSION = "2.20"; # $Id: //depot/libnet/Net/NNTP.pm#14 $ @ISA = qw(Net::Cmd IO::Socket::INET); sub new @@ -1064,6 +1064,6 @@ it under the same terms as Perl itself. =for html
-I<$Id: //depot/libnet/Net/NNTP.pm#13 $> +I<$Id: //depot/libnet/Net/NNTP.pm#14 $> =cut diff --git a/lib/Net/POP3.pm b/lib/Net/POP3.pm index f23157c..89f0313 100644 --- a/lib/Net/POP3.pm +++ b/lib/Net/POP3.pm @@ -13,7 +13,7 @@ use Net::Cmd; use Carp; use Net::Config; -$VERSION = "2.22"; # $Id: //depot/libnet/Net/POP3.pm#19 $ +$VERSION = "2.22"; # $Id: //depot/libnet/Net/POP3.pm#20 $ @ISA = qw(Net::Cmd IO::Socket::INET); @@ -520,6 +520,6 @@ it under the same terms as Perl itself. =for html
-I<$Id: //depot/libnet/Net/POP3.pm#19 $> +I<$Id: //depot/libnet/Net/POP3.pm#20 $> =cut diff --git a/lib/Net/SMTP.pm b/lib/Net/SMTP.pm index ce5777d..627903d 100644 --- a/lib/Net/SMTP.pm +++ b/lib/Net/SMTP.pm @@ -16,7 +16,7 @@ use IO::Socket; use Net::Cmd; use Net::Config; -$VERSION = "2.17"; # $Id: //depot/libnet/Net/SMTP.pm#17 $ +$VERSION = "2.18"; # $Id: //depot/libnet/Net/SMTP.pm#19 $ @ISA = qw(Net::Cmd IO::Socket::INET); @@ -92,6 +92,31 @@ sub etrn { $self->_ETRN(@_); } +sub auth { # auth(username, password) by mengwong 20011106. the only supported mechanism at this time is PLAIN. + # + # my $auth = $smtp->supports("AUTH"); + # $smtp->auth("username", "password") or die $smtp->message; + # + + require MIME::Base64; + + my $self = shift; + my ($username, $password) = @_; + die "auth(username, password)" if not length $username; + + my $mechanisms = $self->supports('AUTH',500,["Command unknown: 'AUTH'"]); + return unless defined $mechanisms; + + if (not grep { uc $_ eq "PLAIN" } split ' ', $mechanisms) { + $self->set_status(500, ["PLAIN mechanism not supported; server supports $mechanisms"]); + return; + } + my $authstring = MIME::Base64::encode_base64(join "\0", ($username)x2, $password); + $authstring =~ s/\n//g; # wrap long lines + + $self->_AUTH("PLAIN $authstring"); +} + sub hello { my $me = shift; @@ -376,6 +401,7 @@ sub _QUIT { shift->command("QUIT")->response() == CMD_OK } sub _DATA { shift->command("DATA")->response() == CMD_MORE } sub _TURN { shift->unsupported(@_); } sub _ETRN { shift->command("ETRN", @_)->response() == CMD_OK } +sub _AUTH { shift->command("AUTH", @_)->response() == CMD_OK } 1; @@ -503,6 +529,12 @@ normally not have to call it manually. Request a queue run for the DOMAIN given. +=item auth ( USERNAME, PASSWORD ) + +Attempt SASL authentication. At this time only the PLAIN mechanism is supported. + +At some point in the future support for using Authen::SASL will be added + =item mail ( ADDRESS [, OPTIONS] ) =item send ( ADDRESS ) @@ -609,6 +641,6 @@ it under the same terms as Perl itself. =for html
-I<$Id: //depot/libnet/Net/SMTP.pm#17 $> +I<$Id: //depot/libnet/Net/SMTP.pm#19 $> =cut diff --git a/lib/Net/libnetFAQ.pod b/lib/Net/libnetFAQ.pod index 1216ff7..d370e84 100644 --- a/lib/Net/libnetFAQ.pod +++ b/lib/Net/libnetFAQ.pod @@ -303,5 +303,5 @@ All rights reserved. =for html
-I<$Id: //depot/libnet/Net/libnetFAQ.pod#4 $> +I<$Id: //depot/libnet/Net/libnetFAQ.pod#5 $> diff --git a/lib/Net/t/config.t b/lib/Net/t/config.t new file mode 100644 index 0000000..95a77aa --- /dev/null +++ b/lib/Net/t/config.t @@ -0,0 +1,45 @@ +#!./perl -w + +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = '../lib'; + } +} + +(my $libnet_t = __FILE__) =~ s/config.t/libnet_t.pl/; +require $libnet_t; + +print "1..10\n"; + +use Net::Config; +ok( exists $INC{'Net/Config.pm'}, 'Net::Config should have been used' ); +ok( keys %NetConfig, '%NetConfig should be imported' ); + +undef $NetConfig{'ftp_firewall'}; +is( Net::Config->requires_firewall(), 0, + 'requires_firewall() should return 0 without ftp_firewall defined' ); + +$NetConfig{'ftp_firewall'} = 1; +is( Net::Config->requires_firewall(''), -1, + '... should return -1 without a valid hostname' ); + +delete $NetConfig{'local_netmask'}; +is( Net::Config->requires_firewall('127.0.0.1'), 0, + '... should return 0 without local_netmask defined' ); + +$NetConfig{'local_netmask'} = '127.0.0.1/24'; +is( Net::Config->requires_firewall('127.0.0.1'), 0, + '... should return false if host is within netmask' ); +is( Net::Config->requires_firewall('192.168.10.0'), 1, + '... should return true if host is outside netmask' ); + +# now try more netmasks +$NetConfig{'local_netmask'} = [ '127.0.0.1/24', '10.0.0.0/8' ]; +is( Net::Config->requires_firewall('10.10.255.254'), 0, + '... should find success with mutiple local netmasks' ); +is( Net::Config->requires_firewall('192.168.10.0'), 1, + '... should handle failure with multiple local netmasks' ); + +is( \&Net::Config::is_external, \&Net::Config::requires_firewall, + 'is_external() should be an alias for requires_firewall()' ); diff --git a/lib/Net/t/libnet_t.pl b/lib/Net/t/libnet_t.pl new file mode 100644 index 0000000..ed245e6 --- /dev/null +++ b/lib/Net/t/libnet_t.pl @@ -0,0 +1,37 @@ + +my $number = 0; +sub ok { + my ($condition, $name) = @_; + + my $message = $condition ? "ok " : "not ok "; + $message .= ++$number; + $message .= " # $name" if defined $name; + print $message, "\n"; + return $condition; +} + +sub is { + my ($got, $expected, $name) = @_; + + for ($got, $expected) { + $_ = 'undef' unless defined $_; + } + + unless (ok($got eq $expected, $name)) { + warn "Got: '$got'\nExpected: '$expected'\n" . join(' ', caller) . "\n"; + } +} + +sub skip { + my ($reason, $num) = @_; + $reason ||= ''; + $number ||= 1; + + for (1 .. $num) { + $number++; + print "ok $number # skip $reason\n"; + } +} + +1; + diff --git a/lib/Net/t/time.t b/lib/Net/t/time.t new file mode 100644 index 0000000..2239fba --- /dev/null +++ b/lib/Net/t/time.t @@ -0,0 +1,127 @@ +#!./perl -w + +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = '../lib'; + } + $INC{'IO/Socket.pm'} = 1; + $INC{'IO/Select.pm'} = 1; + $INC{'IO/Socket/INET.pm'} = 1; +} + +(my $libnet_t = __FILE__) =~ s/time.t/libnet_t.pl/; +require $libnet_t; + +print "1..12\n"; +# cannot use(), otherwise it will use IO::Socket and IO::Select +eval{ require Net::Time; }; +ok( !$@, 'should be able to require() Net::Time safely' ); +ok( exists $INC{'Net/Time.pm'}, 'should be able to use Net::Time' ); + +# force the socket to fail +make_fail('IO::Socket::INET', 'new'); +my $badsock = Net::Time::_socket('foo', 1, 'bar', 'baz'); +is( $badsock, undef, '_socket() should fail if Socket creation fails' ); + +# if socket is created with protocol UDP (default), it will send a newline +my $sock = Net::Time::_socket('foo', 2, 'bar'); +ok( $sock->isa('IO::Socket::INET'), 'should be an IO::Socket::INET object' ); +is( $sock->{sent}, "\n", 'should send \n with UDP protocol set' ); +is( $sock->{timeout}, 120, 'timeout should default to 120' ); + +# now try it with a custom timeout and a different protocol +$sock = Net::Time::_socket('foo', 3, 'bar', 'tcp', 11); +ok( $sock->isa('IO::Socket::INET'), 'should be an IO::Socket::INET object' ); +is( $sock->{sent}, undef, '_socket() should send nothing unless UDP protocol' ); +is( $sock->{PeerAddr}, 'bar', '_socket() should set PeerAddr in socket' ); +is( $sock->{timeout}, 11, '_socket() should respect custom timeout value' ); + +# inet_daytime +# check for correct args (daytime, 13) +IO::Socket::INET::set_message('z'); +is( Net::Time::inet_daytime('bob'), 'z', 'inet_daytime() should receive data' ); + +# magic numbers defined in Net::Time +my $offset = $^O eq 'MacOS' ? + (4 * 31536000) : (70 * 31536000 + 17 * 86400); + +# check for correct args (time, 13) +# pretend it is only six seconds since the offset, create a fake message +# inet_time +IO::Socket::INET::set_message(pack("N", $offset + 6)); +is( Net::Time::inet_time('foo'), 6, + 'inet_time() should calculate time since offset for time()' ); + + +my %fail; + +sub make_fail { + my ($pack, $func, $num) = @_; + $num = 1 unless defined $num; + + $fail{$pack}{$func} = $num; +} + +package IO::Socket::INET; + +$fail{'IO::Socket::INET'} = { + new => 0, + 'send' => 0, +}; + +sub new { + my $class = shift; + return if $fail{$class}{new} and $fail{$class}{new}--; + bless( { @_ }, $class ); +} + +sub send { + my $self = shift; + my $class = ref($self); + return if $fail{$class}{'send'} and $fail{$class}{'send'}--; + $self->{sent} .= shift; +} + +my $msg; +sub set_message { + if (ref($_[0])) { + $_[0]->{msg} = $_[1]; + } else { + $msg = shift; + } +} + +sub do_recv { + my ($len, $msg) = @_[1,2]; + $_[0] .= substr($msg, 0, $len); +} + +sub recv { + my ($self, $buf, $length, $flags) = @_; + my $message = exists $self->{msg} ? + $self->{msg} : $msg; + + if (defined($message)) { + do_recv($_[1], $length, $message); + } + 1; +} + +package IO::Select; + +sub new { + my $class = shift; + return if defined $fail{$class}{new} and $fail{$class}{new}--; + bless({sock => shift}, $class); +} + +sub can_read { + my ($self, $timeout) = @_; + my $class = ref($self); + return if defined $fail{$class}{can_read} and $fail{class}{can_read}--; + $self->{sock}{timeout} = $timeout; + 1; +} + +1;