diff options
author | Siep Kroonenberg <siepo@cybercomm.nl> | 2011-02-17 12:20:49 +0000 |
---|---|---|
committer | Siep Kroonenberg <siepo@cybercomm.nl> | 2011-02-17 12:20:49 +0000 |
commit | 316ee97c621496b0fe3267f57cce81bee44ca1e6 (patch) | |
tree | cb2cab1192b4f58a7971af19b213e980bceda4b4 /Master/tlpkg/tlperl/lib/Net | |
parent | cd0f87b5d39480d85ad9bd4ee37f520f75bed560 (diff) |
Moving old tlperl prior to committing new one
git-svn-id: svn://tug.org/texlive/trunk@21422 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Net')
30 files changed, 0 insertions, 14547 deletions
diff --git a/Master/tlpkg/tlperl/lib/Net/Cmd.pm b/Master/tlpkg/tlperl/lib/Net/Cmd.pm deleted file mode 100755 index 4f0e4449f80..00000000000 --- a/Master/tlpkg/tlperl/lib/Net/Cmd.pm +++ /dev/null @@ -1,783 +0,0 @@ -# Net::Cmd.pm -# -# Copyright (c) 1995-2006 Graham Barr <gbarr@pobox.com>. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package Net::Cmd; - -require 5.001; -require Exporter; - -use strict; -use vars qw(@ISA @EXPORT $VERSION); -use Carp; -use Symbol 'gensym'; - -BEGIN { - if ($^O eq 'os390') { - require Convert::EBCDIC; - - # Convert::EBCDIC->import; - } -} - -BEGIN { - if (!eval { require utf8 }) { - *is_utf8 = sub { 0 }; - } - elsif (eval { utf8::is_utf8(undef); 1 }) { - *is_utf8 = \&utf8::is_utf8; - } - elsif (eval { require Encode; Encode::is_utf8(undef); 1 }) { - *is_utf8 = \&Encode::is_utf8; - } - else { - *is_utf8 = sub { $_[0] =~ /[^\x00-\xff]/ }; - } -} - -$VERSION = "2.29"; -@ISA = qw(Exporter); -@EXPORT = qw(CMD_INFO CMD_OK CMD_MORE CMD_REJECT CMD_ERROR CMD_PENDING); - - -sub CMD_INFO {1} -sub CMD_OK {2} -sub CMD_MORE {3} -sub CMD_REJECT {4} -sub CMD_ERROR {5} -sub CMD_PENDING {0} - -my %debug = (); - -my $tr = $^O eq 'os390' ? Convert::EBCDIC->new() : undef; - - -sub toebcdic { - my $cmd = shift; - - unless (exists ${*$cmd}{'net_cmd_asciipeer'}) { - my $string = $_[0]; - my $ebcdicstr = $tr->toebcdic($string); - ${*$cmd}{'net_cmd_asciipeer'} = $string !~ /^\d+/ && $ebcdicstr =~ /^\d+/; - } - - ${*$cmd}{'net_cmd_asciipeer'} - ? $tr->toebcdic($_[0]) - : $_[0]; -} - - -sub toascii { - my $cmd = shift; - ${*$cmd}{'net_cmd_asciipeer'} - ? $tr->toascii($_[0]) - : $_[0]; -} - - -sub _print_isa { - no strict qw(refs); - - my $pkg = shift; - my $cmd = $pkg; - - $debug{$pkg} ||= 0; - - my %done = (); - my @do = ($pkg); - my %spc = ($pkg, ""); - - while ($pkg = shift @do) { - next if defined $done{$pkg}; - - $done{$pkg} = 1; - - my $v = - defined ${"${pkg}::VERSION"} - ? "(" . ${"${pkg}::VERSION"} . ")" - : ""; - - my $spc = $spc{$pkg}; - $cmd->debug_print(1, "${spc}${pkg}${v}\n"); - - if (@{"${pkg}::ISA"}) { - @spc{@{"${pkg}::ISA"}} = (" " . $spc{$pkg}) x @{"${pkg}::ISA"}; - unshift(@do, @{"${pkg}::ISA"}); - } - } -} - - -sub debug { - @_ == 1 or @_ == 2 or croak 'usage: $obj->debug([LEVEL])'; - - my ($cmd, $level) = @_; - my $pkg = ref($cmd) || $cmd; - my $oldval = 0; - - if (ref($cmd)) { - $oldval = ${*$cmd}{'net_cmd_debug'} || 0; - } - else { - $oldval = $debug{$pkg} || 0; - } - - return $oldval - unless @_ == 2; - - $level = $debug{$pkg} || 0 - unless defined $level; - - _print_isa($pkg) - if ($level && !exists $debug{$pkg}); - - if (ref($cmd)) { - ${*$cmd}{'net_cmd_debug'} = $level; - } - else { - $debug{$pkg} = $level; - } - - $oldval; -} - - -sub message { - @_ == 1 or croak 'usage: $obj->message()'; - - my $cmd = shift; - - wantarray - ? @{${*$cmd}{'net_cmd_resp'}} - : join("", @{${*$cmd}{'net_cmd_resp'}}); -} - - -sub debug_text { $_[2] } - - -sub debug_print { - my ($cmd, $out, $text) = @_; - print STDERR $cmd, ($out ? '>>> ' : '<<< '), $cmd->debug_text($out, $text); -} - - -sub code { - @_ == 1 or croak 'usage: $obj->code()'; - - my $cmd = shift; - - ${*$cmd}{'net_cmd_code'} = "000" - unless exists ${*$cmd}{'net_cmd_code'}; - - ${*$cmd}{'net_cmd_code'}; -} - - -sub status { - @_ == 1 or croak 'usage: $obj->status()'; - - my $cmd = shift; - - substr(${*$cmd}{'net_cmd_code'}, 0, 1); -} - - -sub set_status { - @_ == 3 or croak 'usage: $obj->set_status(CODE, MESSAGE)'; - - my $cmd = shift; - my ($code, $resp) = @_; - - $resp = [$resp] - unless ref($resp); - - (${*$cmd}{'net_cmd_code'}, ${*$cmd}{'net_cmd_resp'}) = ($code, $resp); - - 1; -} - - -sub command { - my $cmd = shift; - - unless (defined fileno($cmd)) { - $cmd->set_status("599", "Connection closed"); - return $cmd; - } - - - $cmd->dataend() - if (exists ${*$cmd}{'net_cmd_last_ch'}); - - if (scalar(@_)) { - local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS'; - - my $str = join( - " ", - map { - /\n/ - ? do { my $n = $_; $n =~ tr/\n/ /; $n } - : $_; - } @_ - ); - $str = $cmd->toascii($str) if $tr; - $str .= "\015\012"; - - my $len = length $str; - my $swlen; - - $cmd->close - unless (defined($swlen = syswrite($cmd, $str, $len)) && $swlen == $len); - - $cmd->debug_print(1, $str) - if ($cmd->debug); - - ${*$cmd}{'net_cmd_resp'} = []; # the response - ${*$cmd}{'net_cmd_code'} = "000"; # Made this one up :-) - } - - $cmd; -} - - -sub ok { - @_ == 1 or croak 'usage: $obj->ok()'; - - my $code = $_[0]->code; - 0 < $code && $code < 400; -} - - -sub unsupported { - my $cmd = shift; - - ${*$cmd}{'net_cmd_resp'} = ['Unsupported command']; - ${*$cmd}{'net_cmd_code'} = 580; - 0; -} - - -sub getline { - my $cmd = shift; - - ${*$cmd}{'net_cmd_lines'} ||= []; - - return shift @{${*$cmd}{'net_cmd_lines'}} - if scalar(@{${*$cmd}{'net_cmd_lines'}}); - - my $partial = defined(${*$cmd}{'net_cmd_partial'}) ? ${*$cmd}{'net_cmd_partial'} : ""; - my $fd = fileno($cmd); - - return undef - unless defined $fd; - - my $rin = ""; - vec($rin, $fd, 1) = 1; - - my $buf; - - until (scalar(@{${*$cmd}{'net_cmd_lines'}})) { - my $timeout = $cmd->timeout || undef; - my $rout; - - my $select_ret = select($rout = $rin, undef, undef, $timeout); - if ($select_ret > 0) { - unless (sysread($cmd, $buf = "", 1024)) { - carp(ref($cmd) . ": Unexpected EOF on command channel") - if $cmd->debug; - $cmd->close; - return undef; - } - - substr($buf, 0, 0) = $partial; ## prepend from last sysread - - my @buf = split(/\015?\012/, $buf, -1); ## break into lines - - $partial = pop @buf; - - push(@{${*$cmd}{'net_cmd_lines'}}, map {"$_\n"} @buf); - - } - else { - my $msg = $select_ret ? "Error or Interrupted: $!" : "Timeout"; - carp("$cmd: $msg") if ($cmd->debug); - return undef; - } - } - - ${*$cmd}{'net_cmd_partial'} = $partial; - - if ($tr) { - foreach my $ln (@{${*$cmd}{'net_cmd_lines'}}) { - $ln = $cmd->toebcdic($ln); - } - } - - shift @{${*$cmd}{'net_cmd_lines'}}; -} - - -sub ungetline { - my ($cmd, $str) = @_; - - ${*$cmd}{'net_cmd_lines'} ||= []; - unshift(@{${*$cmd}{'net_cmd_lines'}}, $str); -} - - -sub parse_response { - return () - unless $_[1] =~ s/^(\d\d\d)(.?)//o; - ($1, $2 eq "-"); -} - - -sub response { - my $cmd = shift; - my ($code, $more) = (undef) x 2; - - ${*$cmd}{'net_cmd_resp'} ||= []; - - while (1) { - my $str = $cmd->getline(); - - return CMD_ERROR - unless defined($str); - - $cmd->debug_print(0, $str) - if ($cmd->debug); - - ($code, $more) = $cmd->parse_response($str); - unless (defined $code) { - $cmd->ungetline($str); - last; - } - - ${*$cmd}{'net_cmd_code'} = $code; - - push(@{${*$cmd}{'net_cmd_resp'}}, $str); - - last unless ($more); - } - - substr($code, 0, 1); -} - - -sub read_until_dot { - my $cmd = shift; - my $fh = shift; - my $arr = []; - - while (1) { - my $str = $cmd->getline() or return undef; - - $cmd->debug_print(0, $str) - if ($cmd->debug & 4); - - last if ($str =~ /^\.\r?\n/o); - - $str =~ s/^\.\././o; - - if (defined $fh) { - print $fh $str; - } - else { - push(@$arr, $str); - } - } - - $arr; -} - - -sub datasend { - my $cmd = shift; - my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_; - my $line = join("", @$arr); - - # encode to individual utf8 bytes if - # $line is a string (in internal UTF-8) - utf8::encode($line) if is_utf8($line); - - return 0 unless defined(fileno($cmd)); - - my $last_ch = ${*$cmd}{'net_cmd_last_ch'}; - $last_ch = ${*$cmd}{'net_cmd_last_ch'} = "\012" unless defined $last_ch; - - return 1 unless length $line; - - if ($cmd->debug) { - foreach my $b (split(/\n/, $line)) { - $cmd->debug_print(1, "$b\n"); - } - } - - $line =~ tr/\r\n/\015\012/ unless "\r" eq "\015"; - - my $first_ch = ''; - - if ($last_ch eq "\015") { - $first_ch = "\012" if $line =~ s/^\012//; - } - elsif ($last_ch eq "\012") { - $first_ch = "." if $line =~ /^\./; - } - - $line =~ s/\015?\012(\.?)/\015\012$1$1/sg; - - substr($line, 0, 0) = $first_ch; - - ${*$cmd}{'net_cmd_last_ch'} = substr($line, -1, 1); - - my $len = length($line); - my $offset = 0; - my $win = ""; - vec($win, fileno($cmd), 1) = 1; - my $timeout = $cmd->timeout || undef; - - local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS'; - - while ($len) { - my $wout; - my $s = select(undef, $wout = $win, undef, $timeout); - if ((defined $s and $s > 0) or -f $cmd) # -f for testing on win32 - { - my $w = syswrite($cmd, $line, $len, $offset); - unless (defined($w)) { - carp("$cmd: $!") if $cmd->debug; - return undef; - } - $len -= $w; - $offset += $w; - } - else { - carp("$cmd: Timeout") if ($cmd->debug); - return undef; - } - } - - 1; -} - - -sub rawdatasend { - my $cmd = shift; - my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_; - my $line = join("", @$arr); - - return 0 unless defined(fileno($cmd)); - - return 1 - unless length($line); - - if ($cmd->debug) { - my $b = "$cmd>>> "; - print STDERR $b, join("\n$b", split(/\n/, $line)), "\n"; - } - - my $len = length($line); - my $offset = 0; - my $win = ""; - vec($win, fileno($cmd), 1) = 1; - my $timeout = $cmd->timeout || undef; - - local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS'; - while ($len) { - my $wout; - if (select(undef, $wout = $win, undef, $timeout) > 0) { - my $w = syswrite($cmd, $line, $len, $offset); - unless (defined($w)) { - carp("$cmd: $!") if $cmd->debug; - return undef; - } - $len -= $w; - $offset += $w; - } - else { - carp("$cmd: Timeout") if ($cmd->debug); - return undef; - } - } - - 1; -} - - -sub dataend { - my $cmd = shift; - - return 0 unless defined(fileno($cmd)); - - my $ch = ${*$cmd}{'net_cmd_last_ch'}; - my $tosend; - - if (!defined $ch) { - return 1; - } - elsif ($ch ne "\012") { - $tosend = "\015\012"; - } - - $tosend .= ".\015\012"; - - local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS'; - - $cmd->debug_print(1, ".\n") - if ($cmd->debug); - - syswrite($cmd, $tosend, length $tosend); - - delete ${*$cmd}{'net_cmd_last_ch'}; - - $cmd->response() == CMD_OK; -} - -# read and write to tied filehandle -sub tied_fh { - my $cmd = shift; - ${*$cmd}{'net_cmd_readbuf'} = ''; - my $fh = gensym(); - tie *$fh, ref($cmd), $cmd; - return $fh; -} - -# tie to myself -sub TIEHANDLE { - my $class = shift; - my $cmd = shift; - return $cmd; -} - -# Tied filehandle read. Reads requested data length, returning -# end-of-file when the dot is encountered. -sub READ { - my $cmd = shift; - my ($len, $offset) = @_[1, 2]; - return unless exists ${*$cmd}{'net_cmd_readbuf'}; - my $done = 0; - while (!$done and length(${*$cmd}{'net_cmd_readbuf'}) < $len) { - ${*$cmd}{'net_cmd_readbuf'} .= $cmd->getline() or return; - $done++ if ${*$cmd}{'net_cmd_readbuf'} =~ s/^\.\r?\n\Z//m; - } - - $_[0] = ''; - substr($_[0], $offset + 0) = substr(${*$cmd}{'net_cmd_readbuf'}, 0, $len); - substr(${*$cmd}{'net_cmd_readbuf'}, 0, $len) = ''; - delete ${*$cmd}{'net_cmd_readbuf'} if $done; - - return length $_[0]; -} - - -sub READLINE { - my $cmd = shift; - - # in this context, we use the presence of readbuf to - # indicate that we have not yet reached the eof - return unless exists ${*$cmd}{'net_cmd_readbuf'}; - my $line = $cmd->getline; - return if $line =~ /^\.\r?\n/; - $line; -} - - -sub PRINT { - my $cmd = shift; - my ($buf, $len, $offset) = @_; - $len ||= length($buf); - $offset += 0; - return unless $cmd->datasend(substr($buf, $offset, $len)); - ${*$cmd}{'net_cmd_sending'}++; # flag that we should call dataend() - return $len; -} - - -sub CLOSE { - my $cmd = shift; - my $r = exists(${*$cmd}{'net_cmd_sending'}) ? $cmd->dataend : 1; - delete ${*$cmd}{'net_cmd_readbuf'}; - delete ${*$cmd}{'net_cmd_sending'}; - $r; -} - -1; - -__END__ - - -=head1 NAME - -Net::Cmd - Network Command class (as used by FTP, SMTP etc) - -=head1 SYNOPSIS - - use Net::Cmd; - - @ISA = qw(Net::Cmd); - -=head1 DESCRIPTION - -C<Net::Cmd> is a collection of methods that can be inherited by a sub class -of C<IO::Handle>. These methods implement the functionality required for a -command based protocol, for example FTP and SMTP. - -=head1 USER METHODS - -These methods provide a user interface to the C<Net::Cmd> object. - -=over 4 - -=item debug ( VALUE ) - -Set the level of debug information for this object. If C<VALUE> is not given -then the current state is returned. Otherwise the state is changed to -C<VALUE> and the previous state returned. - -Different packages -may implement different levels of debug but a non-zero value results in -copies of all commands and responses also being sent to STDERR. - -If C<VALUE> is C<undef> then the debug level will be set to the default -debug level for the class. - -This method can also be called as a I<static> method to set/get the default -debug level for a given class. - -=item message () - -Returns the text message returned from the last command - -=item code () - -Returns the 3-digit code from the last command. If a command is pending -then the value 0 is returned - -=item ok () - -Returns non-zero if the last code value was greater than zero and -less than 400. This holds true for most command servers. Servers -where this does not hold may override this method. - -=item status () - -Returns the most significant digit of the current status code. If a command -is pending then C<CMD_PENDING> is returned. - -=item datasend ( DATA ) - -Send data to the remote server, converting LF to CRLF. Any line starting -with a '.' will be prefixed with another '.'. -C<DATA> may be an array or a reference to an array. - -=item dataend () - -End the sending of data to the remote server. This is done by ensuring that -the data already sent ends with CRLF then sending '.CRLF' to end the -transmission. Once this data has been sent C<dataend> calls C<response> and -returns true if C<response> returns CMD_OK. - -=back - -=head1 CLASS METHODS - -These methods are not intended to be called by the user, but used or -over-ridden by a sub-class of C<Net::Cmd> - -=over 4 - -=item debug_print ( DIR, TEXT ) - -Print debugging information. C<DIR> denotes the direction I<true> being -data being sent to the server. Calls C<debug_text> before printing to -STDERR. - -=item debug_text ( TEXT ) - -This method is called to print debugging information. TEXT is -the text being sent. The method should return the text to be printed - -This is primarily meant for the use of modules such as FTP where passwords -are sent, but we do not want to display them in the debugging information. - -=item command ( CMD [, ARGS, ... ]) - -Send a command to the command server. All arguments a first joined with -a space character and CRLF is appended, this string is then sent to the -command server. - -Returns undef upon failure - -=item unsupported () - -Sets the status code to 580 and the response text to 'Unsupported command'. -Returns zero. - -=item response () - -Obtain a response from the server. Upon success the most significant digit -of the status code is returned. Upon failure, timeout etc., I<undef> is -returned. - -=item parse_response ( TEXT ) - -This method is called by C<response> as a method with one argument. It should -return an array of 2 values, the 3-digit status code and a flag which is true -when this is part of a multi-line response and this line is not the list. - -=item getline () - -Retrieve one line, delimited by CRLF, from the remote server. Returns I<undef> -upon failure. - -B<NOTE>: If you do use this method for any reason, please remember to add -some C<debug_print> calls into your method. - -=item ungetline ( TEXT ) - -Unget a line of text from the server. - -=item rawdatasend ( DATA ) - -Send data to the remote server without performing any conversions. C<DATA> -is a scalar. - -=item read_until_dot () - -Read data from the remote server until a line consisting of a single '.'. -Any lines starting with '..' will have one of the '.'s removed. - -Returns a reference to a list containing the lines, or I<undef> upon failure. - -=item tied_fh () - -Returns a filehandle tied to the Net::Cmd object. After issuing a -command, you may read from this filehandle using read() or <>. The -filehandle will return EOF when the final dot is encountered. -Similarly, you may write to the filehandle in order to send data to -the server after issuing a command that expects data to be written. - -See the Net::POP3 and Net::SMTP modules for examples of this. - -=back - -=head1 EXPORTS - -C<Net::Cmd> exports six subroutines, five of these, C<CMD_INFO>, C<CMD_OK>, -C<CMD_MORE>, C<CMD_REJECT> and C<CMD_ERROR>, correspond to possible results -of C<response> and C<status>. The sixth is C<CMD_PENDING>. - -=head1 AUTHOR - -Graham Barr <gbarr@pobox.com> - -=head1 COPYRIGHT - -Copyright (c) 1995-2006 Graham Barr. All rights reserved. -This program is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/Master/tlpkg/tlperl/lib/Net/Config.eg b/Master/tlpkg/tlperl/lib/Net/Config.eg deleted file mode 100755 index 77dc1f138b8..00000000000 --- a/Master/tlpkg/tlperl/lib/Net/Config.eg +++ /dev/null @@ -1,49 +0,0 @@ -package Net::Config; - -require Exporter; -use vars qw(@ISA @EXPORT %NetConfig); -use strict; - -@EXPORT = qw(%NetConfig); -@ISA = qw(Exporter); - -# WARNING WARNING WARNING WARNING WARNING WARNING WARNING -# WARNING WARNING WARNING WARNING WARNING WARNING WARNING -# -# Below this line is auto-generated, *ANY* changes will be lost - -%NetConfig = ( - # the followinf parameters are all lists of hosts for the - # respective protocols. - nntp_hosts => [], - snpp_hosts => [], - pop3_hosts => [], - smtp_hosts => [], - ph_hosts => [], - daytime_hosts => [], - time_hosts => [], - - # your internet domain - inet_domain => undef, - - # If you have an ftp proxy firewall (not an http firewall) - # then set this to the name of the firewall - ftp_firewall => undef, - - # set if all connections done via the firewall should use - # passive data connections - ftp_ext_passive => 0, - - # set if all connections not done via the firewall should use - # passive data connections - ftp_int_passive => 0, - - # If set the make test will attempt to connect to the hosts above - test_hosts => 0, - - # Used during Configure (which you are not using) to do - # DNS lookups to ensure hosts exist - test_exist => 0, - -); -1; diff --git a/Master/tlpkg/tlperl/lib/Net/Config.pm b/Master/tlpkg/tlperl/lib/Net/Config.pm deleted file mode 100755 index db51c1fc0d2..00000000000 --- a/Master/tlpkg/tlperl/lib/Net/Config.pm +++ /dev/null @@ -1,312 +0,0 @@ -# Net::Config.pm -# -# Copyright (c) 2000 Graham Barr <gbarr@pobox.com>. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package Net::Config; - -require Exporter; -use vars qw(@ISA @EXPORT %NetConfig $VERSION $CONFIGURE $LIBNET_CFG); -use Socket qw(inet_aton inet_ntoa); -use strict; - -@EXPORT = qw(%NetConfig); -@ISA = qw(Net::LocalCfg Exporter); -$VERSION = "1.11"; - -eval { local $SIG{__DIE__}; require Net::LocalCfg }; - -%NetConfig = ( - nntp_hosts => [], - snpp_hosts => [], - pop3_hosts => [], - smtp_hosts => [], - ph_hosts => [], - daytime_hosts => [], - time_hosts => [], - inet_domain => undef, - ftp_firewall => undef, - ftp_ext_passive => 1, - ftp_int_passive => 1, - test_hosts => 1, - 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() } ? \$InternetConfig{ kICFTPHost()} : undef, - ph_hosts => [ \$InternetConfig{ kICPhHost() } ], - ftp_ext_passive => \$InternetConfig{"646F676F\xA5UsePassiveMode"} || 0, - ftp_int_passive => \$InternetConfig{"646F676F\xA5UsePassiveMode"} || 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/; -if (-f $file) { - $ref = eval { local $SIG{__DIE__}; do $file }; - if (ref($ref) eq 'HASH') { - %NetConfig = (%NetConfig, %{$ref}); - $LIBNET_CFG = $file; - } -} -if ($< == $> and !$CONFIGURE) { - my $home = eval { local $SIG{__DIE__}; (getpwuid($>))[7] } || $ENV{HOME}; - $home ||= $ENV{HOMEDRIVE} . ($ENV{HOMEPATH} || '') if defined $ENV{HOMEDRIVE}; - if (defined $home) { - $file = $home . "/.libnetrc"; - $ref = eval { local $SIG{__DIE__}; do $file } if -f $file; - %NetConfig = (%NetConfig, %{$ref}) - if ref($ref) eq 'HASH'; - } -} -my ($k, $v); -while (($k, $v) = each %NetConfig) { - $NetConfig{$k} = [$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 - - -sub requires_firewall { - shift; # ignore package - my $host = shift; - - return 0 unless defined $NetConfig{'ftp_firewall'}; - - $host = inet_aton($host) or return -1; - $host = inet_ntoa($host); - - if (exists $NetConfig{'local_netmask'}) { - my $quad = unpack("N", pack("C*", split(/\./, $host))); - my $list = $NetConfig{'local_netmask'}; - $list = [$list] unless ref($list); - foreach (@$list) { - my ($net, $bits) = (m#^(\d+\.\d+\.\d+\.\d+)/(\d+)$#) or next; - my $mask = ~0 << (32 - $bits); - my $addr = unpack("N", pack("C*", split(/\./, $net))); - - return 0 if (($addr & $mask) == ($quad & $mask)); - } - return 1; - } - - return 0; -} - -use vars qw(*is_external); -*is_external = \&requires_firewall; - -1; - -__END__ - -=head1 NAME - -Net::Config - Local configuration data for libnet - -=head1 SYNOPSYS - - use Net::Config qw(%NetConfig); - -=head1 DESCRIPTION - -C<Net::Config> holds configuration data for the modules in the libnet -distribution. During installation you will be asked for these values. - -The configuration data is held globally in a file in the perl installation -tree, but a user may override any of these values by providing their own. This -can be done by having a C<.libnetrc> file in their home directory. This file -should return a reference to a HASH containing the keys described below. -For example - - # .libnetrc - { - nntp_hosts => [ "my_preferred_host" ], - ph_hosts => [ "my_ph_server" ], - } - __END__ - -=head1 METHODS - -C<Net::Config> defines the following methods. They are methods as they are -invoked as class methods. This is because C<Net::Config> inherits from -C<Net::LocalCfg> so you can override these methods if you want. - -=over 4 - -=item requires_firewall HOST - -Attempts to determine if a given host is outside your firewall. Possible -return values are. - - -1 Cannot lookup hostname - 0 Host is inside firewall (or there is no ftp_firewall entry) - 1 Host is outside the firewall - -This is done by using hostname lookup and the C<local_netmask> entry in -the configuration data. - -=back - -=head1 NetConfig VALUES - -=over 4 - -=item nntp_hosts - -=item snpp_hosts - -=item pop3_hosts - -=item smtp_hosts - -=item ph_hosts - -=item daytime_hosts - -=item time_hosts - -Each is a reference to an array of hostnames (in order of preference), -which should be used for the given protocol - -=item inet_domain - -Your internet domain name - -=item ftp_firewall - -If you have an FTP proxy firewall (B<NOT> an HTTP or SOCKS firewall) -then this value should be set to the firewall hostname. If your firewall -does not listen to port 21, then this value should be set to -C<"hostname:port"> (eg C<"hostname:99">) - -=item ftp_firewall_type - -There are many different ftp firewall products available. But unfortunately -there is no standard for how to traverse a firewall. The list below shows the -sequence of commands that Net::FTP will use - - user Username for remote host - pass Password for remote host - fwuser Username for firewall - fwpass Password for firewall - remote.host The hostname of the remote ftp server - -=over 4 - -=item 0 - -There is no firewall - -=item 1 - - USER user@remote.host - PASS pass - -=item 2 - - USER fwuser - PASS fwpass - USER user@remote.host - PASS pass - -=item 3 - - USER fwuser - PASS fwpass - SITE remote.site - USER user - PASS pass - -=item 4 - - USER fwuser - PASS fwpass - OPEN remote.site - USER user - PASS pass - -=item 5 - - USER user@fwuser@remote.site - PASS pass@fwpass - -=item 6 - - USER fwuser@remote.site - PASS fwpass - USER user - PASS pass - -=item 7 - - USER user@remote.host - PASS pass - AUTH fwuser - RESP fwpass - -=back - -=item ftp_ext_passive - -=item ftp_int_passive - -FTP servers can work in passive or active mode. Active mode is when -you want to transfer data you have to tell the server the address and -port to connect to. Passive mode is when the server provide the -address and port and you establish the connection. - -With some firewalls active mode does not work as the server cannot -connect to your machine (because you are behind a firewall) and the firewall -does not re-write the command. In this case you should set C<ftp_ext_passive> -to a I<true> value. - -Some servers are configured to only work in passive mode. If you have -one of these you can force C<Net::FTP> to always transfer in passive -mode; when not going via a firewall, by setting C<ftp_int_passive> to -a I<true> value. - -=item local_netmask - -A reference to a list of netmask strings in the form C<"134.99.4.0/24">. -These are used by the C<requires_firewall> function to determine if a given -host is inside or outside your firewall. - -=back - -The following entries are used during installation & testing on the -libnet package - -=over 4 - -=item test_hosts - -If true then C<make test> may attempt to connect to hosts given in the -configuration. - -=item test_exists - -If true then C<Configure> will check each hostname given that it exists - -=back - -=cut diff --git a/Master/tlpkg/tlperl/lib/Net/Domain.pm b/Master/tlpkg/tlperl/lib/Net/Domain.pm deleted file mode 100755 index 330909da49d..00000000000 --- a/Master/tlpkg/tlperl/lib/Net/Domain.pm +++ /dev/null @@ -1,347 +0,0 @@ -# Net::Domain.pm -# -# Copyright (c) 1995-1998 Graham Barr <gbarr@pobox.com>. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package Net::Domain; - -require Exporter; - -use Carp; -use strict; -use vars qw($VERSION @ISA @EXPORT_OK); -use Net::Config; - -@ISA = qw(Exporter); -@EXPORT_OK = qw(hostname hostdomain hostfqdn domainname); - -$VERSION = "2.20"; - -my ($host, $domain, $fqdn) = (undef, undef, undef); - -# Try every conceivable way to get hostname. - - -sub _hostname { - - # we already know it - return $host - if (defined $host); - - if ($^O eq 'MSWin32') { - require Socket; - my ($name, $alias, $type, $len, @addr) = gethostbyname($ENV{'COMPUTERNAME'} || 'localhost'); - while (@addr) { - my $a = shift(@addr); - $host = gethostbyaddr($a, Socket::AF_INET()); - last if defined $host; - } - if (defined($host) && index($host, '.') > 0) { - $fqdn = $host; - ($host, $domain) = $fqdn =~ /^([^\.]+)\.(.*)$/; - } - return $host; - } - elsif ($^O eq 'MacOS') { - chomp($host = `hostname`); - } - elsif ($^O eq 'VMS') { ## multiple varieties of net s/w makes this hard - $host = $ENV{'UCX$INET_HOST'} if defined($ENV{'UCX$INET_HOST'}); - $host = $ENV{'MULTINET_HOST_NAME'} if defined($ENV{'MULTINET_HOST_NAME'}); - if (index($host, '.') > 0) { - $fqdn = $host; - ($host, $domain) = $fqdn =~ /^([^\.]+)\.(.*)$/; - } - return $host; - } - else { - local $SIG{'__DIE__'}; - - # syscall is preferred since it avoids tainting problems - eval { - my $tmp = "\0" x 256; ## preload scalar - eval { - package main; - require "syscall.ph"; - defined(&main::SYS_gethostname); - } - || eval { - package main; - require "sys/syscall.ph"; - defined(&main::SYS_gethostname); - } - and $host = - (syscall(&main::SYS_gethostname, $tmp, 256) == 0) - ? $tmp - : undef; - } - - # POSIX - || eval { - require POSIX; - $host = (POSIX::uname())[1]; - } - - # trusty old hostname command - || eval { - chop($host = `(hostname) 2>/dev/null`); # BSD'ish - } - - # sysV/POSIX uname command (may truncate) - || eval { - chop($host = `uname -n 2>/dev/null`); ## SYSV'ish && POSIX'ish - } - - # Apollo pre-SR10 - || eval { $host = (split(/[:\. ]/, `/com/host`, 6))[0]; } - - || eval { $host = ""; }; - } - - # remove garbage - $host =~ s/[\0\r\n]+//go; - $host =~ s/(\A\.+|\.+\Z)//go; - $host =~ s/\.\.+/\./go; - - $host; -} - - -sub _hostdomain { - - # we already know it - return $domain - if (defined $domain); - - local $SIG{'__DIE__'}; - - return $domain = $NetConfig{'inet_domain'} - if defined $NetConfig{'inet_domain'}; - - # try looking in /etc/resolv.conf - # putting this here and assuming that it is correct, eliminates - # calls to gethostbyname, and therefore DNS lookups. This helps - # those on dialup systems. - - local *RES; - local ($_); - - if (open(RES, "/etc/resolv.conf")) { - while (<RES>) { - $domain = $1 - if (/\A\s*(?:domain|search)\s+(\S+)/); - } - close(RES); - - return $domain - if (defined $domain); - } - - # just try hostname and system calls - - my $host = _hostname(); - my (@hosts); - - @hosts = ($host, "localhost"); - - unless (defined($host) && $host =~ /\./) { - my $dom = undef; - eval { - my $tmp = "\0" x 256; ## preload scalar - eval { - package main; - require "syscall.ph"; - } - || eval { - package main; - require "sys/syscall.ph"; - } - and $dom = - (syscall(&main::SYS_getdomainname, $tmp, 256) == 0) - ? $tmp - : undef; - }; - - if ($^O eq 'VMS') { - $dom ||= $ENV{'TCPIP$INET_DOMAIN'} - || $ENV{'UCX$INET_DOMAIN'}; - } - - chop($dom = `domainname 2>/dev/null`) - unless (defined $dom || $^O =~ /^(?:cygwin|MSWin32)/); - - if (defined $dom) { - my @h = (); - $dom =~ s/^\.+//; - while (length($dom)) { - push(@h, "$host.$dom"); - $dom =~ s/^[^.]+.+// or last; - } - unshift(@hosts, @h); - } - } - - # Attempt to locate FQDN - - foreach (grep { defined $_ } @hosts) { - my @info = gethostbyname($_); - - next unless @info; - - # look at real name & aliases - my $site; - foreach $site ($info[0], split(/ /, $info[1])) { - if (rindex($site, ".") > 0) { - - # Extract domain from FQDN - - ($domain = $site) =~ s/\A[^\.]+\.//; - return $domain; - } - } - } - - # Look for environment variable - - $domain ||= $ENV{LOCALDOMAIN} || $ENV{DOMAIN}; - - if (defined $domain) { - $domain =~ s/[\r\n\0]+//g; - $domain =~ s/(\A\.+|\.+\Z)//g; - $domain =~ s/\.\.+/\./g; - } - - $domain; -} - - -sub domainname { - - return $fqdn - if (defined $fqdn); - - _hostname(); - _hostdomain(); - - # Assumption: If the host name does not contain a period - # and the domain name does, then assume that they are correct - # this helps to eliminate calls to gethostbyname, and therefore - # eleminate DNS lookups - - return $fqdn = $host . "." . $domain - if (defined $host - and defined $domain - and $host !~ /\./ - and $domain =~ /\./); - - # For hosts that have no name, just an IP address - return $fqdn = $host if defined $host and $host =~ /^\d+(\.\d+){3}$/; - - my @host = defined $host ? split(/\./, $host) : ('localhost'); - my @domain = defined $domain ? split(/\./, $domain) : (); - my @fqdn = (); - - # Determine from @host & @domain the FQDN - - my @d = @domain; - -LOOP: - while (1) { - my @h = @host; - while (@h) { - my $tmp = join(".", @h, @d); - if ((gethostbyname($tmp))[0]) { - @fqdn = (@h, @d); - $fqdn = $tmp; - last LOOP; - } - pop @h; - } - last unless shift @d; - } - - if (@fqdn) { - $host = shift @fqdn; - until ((gethostbyname($host))[0]) { - $host .= "." . shift @fqdn; - } - $domain = join(".", @fqdn); - } - else { - undef $host; - undef $domain; - undef $fqdn; - } - - $fqdn; -} - - -sub hostfqdn { domainname() } - - -sub hostname { - domainname() - unless (defined $host); - return $host; -} - - -sub hostdomain { - domainname() - unless (defined $domain); - return $domain; -} - -1; # Keep require happy - -__END__ - -=head1 NAME - -Net::Domain - Attempt to evaluate the current host's internet name and domain - -=head1 SYNOPSIS - - use Net::Domain qw(hostname hostfqdn hostdomain domainname); - -=head1 DESCRIPTION - -Using various methods B<attempt> to find the Fully Qualified Domain Name (FQDN) -of the current host. From this determine the host-name and the host-domain. - -Each of the functions will return I<undef> if the FQDN cannot be determined. - -=over 4 - -=item hostfqdn () - -Identify and return the FQDN of the current host. - -=item domainname () - -An alias for hostfqdn (). - -=item hostname () - -Returns the smallest part of the FQDN which can be used to identify the host. - -=item hostdomain () - -Returns the remainder of the FQDN after the I<hostname> has been removed. - -=back - -=head1 AUTHOR - -Graham Barr <gbarr@pobox.com>. -Adapted from Sys::Hostname by David Sundstrom <sunds@asictest.sc.ti.com> - -=head1 COPYRIGHT - -Copyright (c) 1995-1998 Graham Barr. All rights reserved. -This program is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/Master/tlpkg/tlperl/lib/Net/FTP.pm b/Master/tlpkg/tlperl/lib/Net/FTP.pm deleted file mode 100755 index 9ed6d385d9c..00000000000 --- a/Master/tlpkg/tlperl/lib/Net/FTP.pm +++ /dev/null @@ -1,1829 +0,0 @@ -# Net::FTP.pm -# -# Copyright (c) 1995-2004 Graham Barr <gbarr@pobox.com>. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -# -# Documentation (at end) improved 1996 by Nathan Torkington <gnat@frii.com>. - -package Net::FTP; - -require 5.001; - -use strict; -use vars qw(@ISA $VERSION); -use Carp; - -use Socket 1.3; -use IO::Socket; -use Time::Local; -use Net::Cmd; -use Net::Config; -use Fcntl qw(O_WRONLY O_RDONLY O_APPEND O_CREAT O_TRUNC); - -$VERSION = '2.77'; -@ISA = qw(Exporter Net::Cmd IO::Socket::INET); - -# Someday I will "use constant", when I am not bothered to much about -# compatability with older releases of perl - -use vars qw($TELNET_IAC $TELNET_IP $TELNET_DM); -($TELNET_IAC, $TELNET_IP, $TELNET_DM) = (255, 244, 242); - - -BEGIN { - - # make a constant so code is fast'ish - my $is_os390 = $^O eq 'os390'; - *trEBCDIC = sub () {$is_os390} -} - - -sub new { - my $pkg = shift; - my ($peer, %arg); - if (@_ % 2) { - $peer = shift; - %arg = @_; - } - else { - %arg = @_; - $peer = delete $arg{Host}; - } - - my $host = $peer; - my $fire = undef; - my $fire_type = undef; - - if (exists($arg{Firewall}) || Net::Config->requires_firewall($peer)) { - $fire = $arg{Firewall} - || $ENV{FTP_FIREWALL} - || $NetConfig{ftp_firewall} - || undef; - - if (defined $fire) { - $peer = $fire; - delete $arg{Port}; - $fire_type = $arg{FirewallType} - || $ENV{FTP_FIREWALL_TYPE} - || $NetConfig{firewall_type} - || undef; - } - } - - my $ftp = $pkg->SUPER::new( - PeerAddr => $peer, - PeerPort => $arg{Port} || 'ftp(21)', - LocalAddr => $arg{'LocalAddr'}, - Proto => 'tcp', - Timeout => defined $arg{Timeout} - ? $arg{Timeout} - : 120 - ) - or return undef; - - ${*$ftp}{'net_ftp_host'} = $host; # Remote hostname - ${*$ftp}{'net_ftp_type'} = 'A'; # ASCII/binary/etc mode - ${*$ftp}{'net_ftp_blksize'} = abs($arg{'BlockSize'} || 10240); - - ${*$ftp}{'net_ftp_localaddr'} = $arg{'LocalAddr'}; - - ${*$ftp}{'net_ftp_firewall'} = $fire - if (defined $fire); - ${*$ftp}{'net_ftp_firewall_type'} = $fire_type - if (defined $fire_type); - - ${*$ftp}{'net_ftp_passive'} = - int exists $arg{Passive} ? $arg{Passive} - : exists $ENV{FTP_PASSIVE} ? $ENV{FTP_PASSIVE} - : defined $fire ? $NetConfig{ftp_ext_passive} - : $NetConfig{ftp_int_passive}; # Whew! :-) - - $ftp->hash(exists $arg{Hash} ? $arg{Hash} : 0, 1024); - - $ftp->autoflush(1); - - $ftp->debug(exists $arg{Debug} ? $arg{Debug} : undef); - - unless ($ftp->response() == CMD_OK) { - $ftp->close(); - $@ = $ftp->message; - undef $ftp; - } - - $ftp; -} - -## -## User interface methods -## - - -sub host { - my $me = shift; - ${*$me}{'net_ftp_host'}; -} - - -sub hash { - my $ftp = shift; # self - - my ($h, $b) = @_; - unless ($h) { - delete ${*$ftp}{'net_ftp_hash'}; - return [\*STDERR, 0]; - } - ($h, $b) = (ref($h) ? $h : \*STDERR, $b || 1024); - select((select($h), $| = 1)[0]); - $b = 512 if $b < 512; - ${*$ftp}{'net_ftp_hash'} = [$h, $b]; -} - - -sub quit { - my $ftp = shift; - - $ftp->_QUIT; - $ftp->close; -} - - -sub DESTROY { } - - -sub ascii { shift->type('A', @_); } -sub binary { shift->type('I', @_); } - - -sub ebcdic { - carp "TYPE E is unsupported, shall default to I"; - shift->type('E', @_); -} - - -sub byte { - carp "TYPE L is unsupported, shall default to I"; - shift->type('L', @_); -} - -# Allow the user to send a command directly, BE CAREFUL !! - - -sub quot { - my $ftp = shift; - my $cmd = shift; - - $ftp->command(uc $cmd, @_); - $ftp->response(); -} - - -sub site { - my $ftp = shift; - - $ftp->command("SITE", @_); - $ftp->response(); -} - - -sub mdtm { - my $ftp = shift; - my $file = shift; - - # Server Y2K bug workaround - # - # sigh; some idiotic FTP servers use ("19%d",tm.tm_year) instead of - # ("%d",tm.tm_year+1900). This results in an extra digit in the - # string returned. To account for this we allow an optional extra - # digit in the year. Then if the first two digits are 19 we use the - # remainder, otherwise we subtract 1900 from the whole year. - - $ftp->_MDTM($file) - && $ftp->message =~ /((\d\d)(\d\d\d?))(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/ - ? timegm($8, $7, $6, $5, $4 - 1, $2 eq '19' ? $3 : ($1 - 1900)) - : undef; -} - - -sub size { - my $ftp = shift; - my $file = shift; - my $io; - if ($ftp->supported("SIZE")) { - return $ftp->_SIZE($file) - ? ($ftp->message =~ /(\d+)\s*(bytes?\s*)?$/)[0] - : undef; - } - elsif ($ftp->supported("STAT")) { - my @msg; - return undef - unless $ftp->_STAT($file) && (@msg = $ftp->message) == 3; - my $line; - foreach $line (@msg) { - return (split(/\s+/, $line))[4] - if $line =~ /^[-rwxSsTt]{10}/; - } - } - else { - my @files = $ftp->dir($file); - if (@files) { - return (split(/\s+/, $1))[4] - if $files[0] =~ /^([-rwxSsTt]{10}.*)$/; - } - } - undef; -} - - -sub login { - my ($ftp, $user, $pass, $acct) = @_; - my ($ok, $ruser, $fwtype); - - unless (defined $user) { - require Net::Netrc; - - my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_host'}); - - ($user, $pass, $acct) = $rc->lpa() - if ($rc); - } - - $user ||= "anonymous"; - $ruser = $user; - - $fwtype = ${*$ftp}{'net_ftp_firewall_type'} - || $NetConfig{'ftp_firewall_type'} - || 0; - - if ($fwtype && defined ${*$ftp}{'net_ftp_firewall'}) { - if ($fwtype == 1 || $fwtype == 7) { - $user .= '@' . ${*$ftp}{'net_ftp_host'}; - } - else { - require Net::Netrc; - - my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'}); - - my ($fwuser, $fwpass, $fwacct) = $rc ? $rc->lpa() : (); - - if ($fwtype == 5) { - $user = join('@', $user, $fwuser, ${*$ftp}{'net_ftp_host'}); - $pass = $pass . '@' . $fwpass; - } - else { - if ($fwtype == 2) { - $user .= '@' . ${*$ftp}{'net_ftp_host'}; - } - elsif ($fwtype == 6) { - $fwuser .= '@' . ${*$ftp}{'net_ftp_host'}; - } - - $ok = $ftp->_USER($fwuser); - - return 0 unless $ok == CMD_OK || $ok == CMD_MORE; - - $ok = $ftp->_PASS($fwpass || ""); - - return 0 unless $ok == CMD_OK || $ok == CMD_MORE; - - $ok = $ftp->_ACCT($fwacct) - if defined($fwacct); - - if ($fwtype == 3) { - $ok = $ftp->command("SITE", ${*$ftp}{'net_ftp_host'})->response; - } - elsif ($fwtype == 4) { - $ok = $ftp->command("OPEN", ${*$ftp}{'net_ftp_host'})->response; - } - - return 0 unless $ok == CMD_OK || $ok == CMD_MORE; - } - } - } - - $ok = $ftp->_USER($user); - - # Some dumb firewalls don't prefix the connection messages - $ok = $ftp->response() - if ($ok == CMD_OK && $ftp->code == 220 && $user =~ /\@/); - - if ($ok == CMD_MORE) { - unless (defined $pass) { - require Net::Netrc; - - my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_host'}, $ruser); - - ($ruser, $pass, $acct) = $rc->lpa() - if ($rc); - - $pass = '-anonymous@' - if (!defined $pass && (!defined($ruser) || $ruser =~ /^anonymous/o)); - } - - $ok = $ftp->_PASS($pass || ""); - } - - $ok = $ftp->_ACCT($acct) - if (defined($acct) && ($ok == CMD_MORE || $ok == CMD_OK)); - - if ($fwtype == 7 && $ok == CMD_OK && defined ${*$ftp}{'net_ftp_firewall'}) { - my ($f, $auth, $resp) = _auth_id($ftp); - $ftp->authorize($auth, $resp) if defined($resp); - } - - $ok == CMD_OK; -} - - -sub account { - @_ == 2 or croak 'usage: $ftp->account( ACCT )'; - my $ftp = shift; - my $acct = shift; - $ftp->_ACCT($acct) == CMD_OK; -} - - -sub _auth_id { - my ($ftp, $auth, $resp) = @_; - - unless (defined $resp) { - require Net::Netrc; - - $auth ||= eval { (getpwuid($>))[0] } || $ENV{NAME}; - - my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'}, $auth) - || Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'}); - - ($auth, $resp) = $rc->lpa() - if ($rc); - } - ($ftp, $auth, $resp); -} - - -sub authorize { - @_ >= 1 || @_ <= 3 or croak 'usage: $ftp->authorize( [AUTH [, RESP]])'; - - my ($ftp, $auth, $resp) = &_auth_id; - - my $ok = $ftp->_AUTH($auth || ""); - - $ok = $ftp->_RESP($resp || "") - if ($ok == CMD_MORE); - - $ok == CMD_OK; -} - - -sub rename { - @_ == 3 or croak 'usage: $ftp->rename(FROM, TO)'; - - my ($ftp, $from, $to) = @_; - - $ftp->_RNFR($from) - && $ftp->_RNTO($to); -} - - -sub type { - my $ftp = shift; - my $type = shift; - my $oldval = ${*$ftp}{'net_ftp_type'}; - - return $oldval - unless (defined $type); - - return undef - unless ($ftp->_TYPE($type, @_)); - - ${*$ftp}{'net_ftp_type'} = join(" ", $type, @_); - - $oldval; -} - - -sub alloc { - my $ftp = shift; - my $size = shift; - my $oldval = ${*$ftp}{'net_ftp_allo'}; - - return $oldval - unless (defined $size); - - return undef - unless ($ftp->_ALLO($size, @_)); - - ${*$ftp}{'net_ftp_allo'} = join(" ", $size, @_); - - $oldval; -} - - -sub abort { - my $ftp = shift; - - send($ftp, pack("CCC", $TELNET_IAC, $TELNET_IP, $TELNET_IAC), MSG_OOB); - - $ftp->command(pack("C", $TELNET_DM) . "ABOR"); - - ${*$ftp}{'net_ftp_dataconn'}->close() - if defined ${*$ftp}{'net_ftp_dataconn'}; - - $ftp->response(); - - $ftp->status == CMD_OK; -} - - -sub get { - my ($ftp, $remote, $local, $where) = @_; - - my ($loc, $len, $buf, $resp, $data); - local *FD; - - my $localfd = ref($local) || ref(\$local) eq "GLOB"; - - ($local = $remote) =~ s#^.*/## - unless (defined $local); - - croak("Bad remote filename '$remote'\n") - if $remote =~ /[\r\n]/s; - - ${*$ftp}{'net_ftp_rest'} = $where if defined $where; - my $rest = ${*$ftp}{'net_ftp_rest'}; - - delete ${*$ftp}{'net_ftp_port'}; - delete ${*$ftp}{'net_ftp_pasv'}; - - $data = $ftp->retr($remote) - or return undef; - - if ($localfd) { - $loc = $local; - } - else { - $loc = \*FD; - - unless (sysopen($loc, $local, O_CREAT | O_WRONLY | ($rest ? O_APPEND: O_TRUNC))) { - carp "Cannot open Local file $local: $!\n"; - $data->abort; - return undef; - } - } - - if ($ftp->type eq 'I' && !binmode($loc)) { - carp "Cannot binmode Local file $local: $!\n"; - $data->abort; - close($loc) unless $localfd; - return undef; - } - - $buf = ''; - my ($count, $hashh, $hashb, $ref) = (0); - - ($hashh, $hashb) = @$ref - if ($ref = ${*$ftp}{'net_ftp_hash'}); - - my $blksize = ${*$ftp}{'net_ftp_blksize'}; - local $\; # Just in case - - while (1) { - last unless $len = $data->read($buf, $blksize); - - if (trEBCDIC && $ftp->type ne 'I') { - $buf = $ftp->toebcdic($buf); - $len = length($buf); - } - - if ($hashh) { - $count += $len; - print $hashh "#" x (int($count / $hashb)); - $count %= $hashb; - } - unless (print $loc $buf) { - carp "Cannot write to Local file $local: $!\n"; - $data->abort; - close($loc) - unless $localfd; - return undef; - } - } - - print $hashh "\n" if $hashh; - - unless ($localfd) { - unless (close($loc)) { - carp "Cannot close file $local (perhaps disk space) $!\n"; - return undef; - } - } - - unless ($data->close()) # implied $ftp->response - { - carp "Unable to close datastream"; - return undef; - } - - return $local; -} - - -sub cwd { - @_ == 1 || @_ == 2 or croak 'usage: $ftp->cwd( [ DIR ] )'; - - my ($ftp, $dir) = @_; - - $dir = "/" unless defined($dir) && $dir =~ /\S/; - - $dir eq ".." - ? $ftp->_CDUP() - : $ftp->_CWD($dir); -} - - -sub cdup { - @_ == 1 or croak 'usage: $ftp->cdup()'; - $_[0]->_CDUP; -} - - -sub pwd { - @_ == 1 || croak 'usage: $ftp->pwd()'; - my $ftp = shift; - - $ftp->_PWD(); - $ftp->_extract_path; -} - -# rmdir( $ftp, $dir, [ $recurse ] ) -# -# Removes $dir on remote host via FTP. -# $ftp is handle for remote host -# -# If $recurse is TRUE, the directory and deleted recursively. -# This means all of its contents and subdirectories. -# -# Initial version contributed by Dinkum Software -# -sub rmdir { - @_ == 2 || @_ == 3 or croak('usage: $ftp->rmdir( DIR [, RECURSE ] )'); - - # Pick off the args - my ($ftp, $dir, $recurse) = @_; - my $ok; - - return $ok - if $ok = $ftp->_RMD($dir) - or !$recurse; - - # Try to delete the contents - # Get a list of all the files in the directory - my @filelist = grep { !/^\.{1,2}$/ } $ftp->ls($dir); - - return undef - unless @filelist; # failed, it is probably not a directory - - # Go thru and delete each file or the directory - my $file; - foreach $file (map { m,/, ? $_ : "$dir/$_" } @filelist) { - next # successfully deleted the file - if $ftp->delete($file); - - # Failed to delete it, assume its a directory - # Recurse and ignore errors, the final rmdir() will - # fail on any errors here - return $ok - unless $ok = $ftp->rmdir($file, 1); - } - - # Directory should be empty - # Try to remove the directory again - # Pass results directly to caller - # If any of the prior deletes failed, this - # rmdir() will fail because directory is not empty - return $ftp->_RMD($dir); -} - - -sub restart { - @_ == 2 || croak 'usage: $ftp->restart( BYTE_OFFSET )'; - - my ($ftp, $where) = @_; - - ${*$ftp}{'net_ftp_rest'} = $where; - - return undef; -} - - -sub mkdir { - @_ == 2 || @_ == 3 or croak 'usage: $ftp->mkdir( DIR [, RECURSE ] )'; - - my ($ftp, $dir, $recurse) = @_; - - $ftp->_MKD($dir) || $recurse - or return undef; - - my $path = $dir; - - unless ($ftp->ok) { - my @path = split(m#(?=/+)#, $dir); - - $path = ""; - - while (@path) { - $path .= shift @path; - - $ftp->_MKD($path); - - $path = $ftp->_extract_path($path); - } - - # If the creation of the last element was not successful, see if we - # can cd to it, if so then return path - - unless ($ftp->ok) { - my ($status, $message) = ($ftp->status, $ftp->message); - my $pwd = $ftp->pwd; - - if ($pwd && $ftp->cwd($dir)) { - $path = $dir; - $ftp->cwd($pwd); - } - else { - undef $path; - } - $ftp->set_status($status, $message); - } - } - - $path; -} - - -sub delete { - @_ == 2 || croak 'usage: $ftp->delete( FILENAME )'; - - $_[0]->_DELE($_[1]); -} - - -sub put { shift->_store_cmd("stor", @_) } -sub put_unique { shift->_store_cmd("stou", @_) } -sub append { shift->_store_cmd("appe", @_) } - - -sub nlst { shift->_data_cmd("NLST", @_) } -sub list { shift->_data_cmd("LIST", @_) } -sub retr { shift->_data_cmd("RETR", @_) } -sub stor { shift->_data_cmd("STOR", @_) } -sub stou { shift->_data_cmd("STOU", @_) } -sub appe { shift->_data_cmd("APPE", @_) } - - -sub _store_cmd { - my ($ftp, $cmd, $local, $remote) = @_; - my ($loc, $sock, $len, $buf); - local *FD; - - my $localfd = ref($local) || ref(\$local) eq "GLOB"; - - unless (defined $remote) { - croak 'Must specify remote filename with stream input' - if $localfd; - - require File::Basename; - $remote = File::Basename::basename($local); - } - if (defined ${*$ftp}{'net_ftp_allo'}) { - delete ${*$ftp}{'net_ftp_allo'}; - } - else { - - # if the user hasn't already invoked the alloc method since the last - # _store_cmd call, figure out if the local file is a regular file(not - # a pipe, or device) and if so get the file size from stat, and send - # an ALLO command before sending the STOR, STOU, or APPE command. - my $size = do { local $^W; -f $local && -s _ }; # no ALLO if sending data from a pipe - $ftp->_ALLO($size) if $size; - } - croak("Bad remote filename '$remote'\n") - if $remote =~ /[\r\n]/s; - - if ($localfd) { - $loc = $local; - } - else { - $loc = \*FD; - - unless (sysopen($loc, $local, O_RDONLY)) { - carp "Cannot open Local file $local: $!\n"; - return undef; - } - } - - if ($ftp->type eq 'I' && !binmode($loc)) { - carp "Cannot binmode Local file $local: $!\n"; - return undef; - } - - delete ${*$ftp}{'net_ftp_port'}; - delete ${*$ftp}{'net_ftp_pasv'}; - - $sock = $ftp->_data_cmd($cmd, $remote) - or return undef; - - $remote = ($ftp->message =~ /FILE:\s*(.*)/)[0] - if 'STOU' eq uc $cmd; - - my $blksize = ${*$ftp}{'net_ftp_blksize'}; - - my ($count, $hashh, $hashb, $ref) = (0); - - ($hashh, $hashb) = @$ref - if ($ref = ${*$ftp}{'net_ftp_hash'}); - - while (1) { - last unless $len = read($loc, $buf = "", $blksize); - - if (trEBCDIC && $ftp->type ne 'I') { - $buf = $ftp->toascii($buf); - $len = length($buf); - } - - if ($hashh) { - $count += $len; - print $hashh "#" x (int($count / $hashb)); - $count %= $hashb; - } - - my $wlen; - unless (defined($wlen = $sock->write($buf, $len)) && $wlen == $len) { - $sock->abort; - close($loc) - unless $localfd; - print $hashh "\n" if $hashh; - return undef; - } - } - - print $hashh "\n" if $hashh; - - close($loc) - unless $localfd; - - $sock->close() - or return undef; - - if ('STOU' eq uc $cmd and $ftp->message =~ m/unique\s+file\s*name\s*:\s*(.*)\)|"(.*)"/) { - require File::Basename; - $remote = File::Basename::basename($+); - } - - return $remote; -} - - -sub port { - @_ == 1 || @_ == 2 or croak 'usage: $ftp->port([PORT])'; - - my ($ftp, $port) = @_; - my $ok; - - delete ${*$ftp}{'net_ftp_intern_port'}; - - unless (defined $port) { - - # create a Listen socket at same address as the command socket - - ${*$ftp}{'net_ftp_listen'} ||= IO::Socket::INET->new( - Listen => 5, - Proto => 'tcp', - Timeout => $ftp->timeout, - LocalAddr => $ftp->sockhost, - ); - - my $listen = ${*$ftp}{'net_ftp_listen'}; - - my ($myport, @myaddr) = ($listen->sockport, split(/\./, $listen->sockhost)); - - $port = join(',', @myaddr, $myport >> 8, $myport & 0xff); - - ${*$ftp}{'net_ftp_intern_port'} = 1; - } - - $ok = $ftp->_PORT($port); - - ${*$ftp}{'net_ftp_port'} = $port; - - $ok; -} - - -sub ls { shift->_list_cmd("NLST", @_); } -sub dir { shift->_list_cmd("LIST", @_); } - - -sub pasv { - @_ == 1 or croak 'usage: $ftp->pasv()'; - - my $ftp = shift; - - delete ${*$ftp}{'net_ftp_intern_port'}; - - $ftp->_PASV && $ftp->message =~ /(\d+(,\d+)+)/ - ? ${*$ftp}{'net_ftp_pasv'} = $1 - : undef; -} - - -sub unique_name { - my $ftp = shift; - ${*$ftp}{'net_ftp_unique'} || undef; -} - - -sub supported { - @_ == 2 or croak 'usage: $ftp->supported( CMD )'; - my $ftp = shift; - my $cmd = uc shift; - my $hash = ${*$ftp}{'net_ftp_supported'} ||= {}; - - return $hash->{$cmd} - if exists $hash->{$cmd}; - - return $hash->{$cmd} = 0 - unless $ftp->_HELP($cmd); - - my $text = $ftp->message; - if ($text =~ /following\s+commands/i) { - $text =~ s/^.*\n//; - while ($text =~ /(\*?)(\w+)(\*?)/sg) { - $hash->{"\U$2"} = !length("$1$3"); - } - } - else { - $hash->{$cmd} = $text !~ /unimplemented/i; - } - - $hash->{$cmd} ||= 0; -} - -## -## Deprecated methods -## - - -sub lsl { - carp "Use of Net::FTP::lsl deprecated, use 'dir'" - if $^W; - goto &dir; -} - - -sub authorise { - carp "Use of Net::FTP::authorise deprecated, use 'authorize'" - if $^W; - goto &authorize; -} - - -## -## Private methods -## - - -sub _extract_path { - my ($ftp, $path) = @_; - - # This tries to work both with and without the quote doubling - # convention (RFC 959 requires it, but the first 3 servers I checked - # didn't implement it). It will fail on a server which uses a quote in - # the message which isn't a part of or surrounding the path. - $ftp->ok - && $ftp->message =~ /(?:^|\s)\"(.*)\"(?:$|\s)/ - && ($path = $1) =~ s/\"\"/\"/g; - - $path; -} - -## -## Communication methods -## - - -sub _dataconn { - my $ftp = shift; - my $data = undef; - my $pkg = "Net::FTP::" . $ftp->type; - - eval "require " . $pkg; - - $pkg =~ s/ /_/g; - - delete ${*$ftp}{'net_ftp_dataconn'}; - - if (defined ${*$ftp}{'net_ftp_pasv'}) { - my @port = map { 0 + $_ } split(/,/, ${*$ftp}{'net_ftp_pasv'}); - - $data = $pkg->new( - PeerAddr => join(".", @port[0 .. 3]), - PeerPort => $port[4] * 256 + $port[5], - LocalAddr => ${*$ftp}{'net_ftp_localaddr'}, - Proto => 'tcp' - ); - } - elsif (defined ${*$ftp}{'net_ftp_listen'}) { - $data = ${*$ftp}{'net_ftp_listen'}->accept($pkg); - close(delete ${*$ftp}{'net_ftp_listen'}); - } - - if ($data) { - ${*$data} = ""; - $data->timeout($ftp->timeout); - ${*$ftp}{'net_ftp_dataconn'} = $data; - ${*$data}{'net_ftp_cmd'} = $ftp; - ${*$data}{'net_ftp_blksize'} = ${*$ftp}{'net_ftp_blksize'}; - } - - $data; -} - - -sub _list_cmd { - my $ftp = shift; - my $cmd = uc shift; - - delete ${*$ftp}{'net_ftp_port'}; - delete ${*$ftp}{'net_ftp_pasv'}; - - my $data = $ftp->_data_cmd($cmd, @_); - - return - unless (defined $data); - - require Net::FTP::A; - bless $data, "Net::FTP::A"; # Force ASCII mode - - my $databuf = ''; - my $buf = ''; - my $blksize = ${*$ftp}{'net_ftp_blksize'}; - - while ($data->read($databuf, $blksize)) { - $buf .= $databuf; - } - - my $list = [split(/\n/, $buf)]; - - $data->close(); - - if (trEBCDIC) { - for (@$list) { $_ = $ftp->toebcdic($_) } - } - - wantarray - ? @{$list} - : $list; -} - - -sub _data_cmd { - my $ftp = shift; - my $cmd = uc shift; - my $ok = 1; - my $where = delete ${*$ftp}{'net_ftp_rest'} || 0; - my $arg; - - for $arg (@_) { - croak("Bad argument '$arg'\n") - if $arg =~ /[\r\n]/s; - } - - if ( ${*$ftp}{'net_ftp_passive'} - && !defined ${*$ftp}{'net_ftp_pasv'} - && !defined ${*$ftp}{'net_ftp_port'}) - { - my $data = undef; - - $ok = defined $ftp->pasv; - $ok = $ftp->_REST($where) - if $ok && $where; - - if ($ok) { - $ftp->command($cmd, @_); - $data = $ftp->_dataconn(); - $ok = CMD_INFO == $ftp->response(); - if ($ok) { - $data->reading - if $data && $cmd =~ /RETR|LIST|NLST/; - return $data; - } - $data->_close - if $data; - } - return undef; - } - - $ok = $ftp->port - unless (defined ${*$ftp}{'net_ftp_port'} - || defined ${*$ftp}{'net_ftp_pasv'}); - - $ok = $ftp->_REST($where) - if $ok && $where; - - return undef - unless $ok; - - $ftp->command($cmd, @_); - - return 1 - if (defined ${*$ftp}{'net_ftp_pasv'}); - - $ok = CMD_INFO == $ftp->response(); - - return $ok - unless exists ${*$ftp}{'net_ftp_intern_port'}; - - if ($ok) { - my $data = $ftp->_dataconn(); - - $data->reading - if $data && $cmd =~ /RETR|LIST|NLST/; - - return $data; - } - - - close(delete ${*$ftp}{'net_ftp_listen'}); - - return undef; -} - -## -## Over-ride methods (Net::Cmd) -## - - -sub debug_text { $_[2] =~ /^(pass|resp|acct)/i ? "$1 ....\n" : $_[2]; } - - -sub command { - my $ftp = shift; - - delete ${*$ftp}{'net_ftp_port'}; - $ftp->SUPER::command(@_); -} - - -sub response { - my $ftp = shift; - my $code = $ftp->SUPER::response(); - - delete ${*$ftp}{'net_ftp_pasv'} - if ($code != CMD_MORE && $code != CMD_INFO); - - $code; -} - - -sub parse_response { - return ($1, $2 eq "-") - if $_[1] =~ s/^(\d\d\d)([- ]?)//o; - - my $ftp = shift; - - # Darn MS FTP server is a load of CRAP !!!! - return () - unless ${*$ftp}{'net_cmd_code'} + 0; - - (${*$ftp}{'net_cmd_code'}, 1); -} - -## -## Allow 2 servers to talk directly -## - - -sub pasv_xfer_unique { - my ($sftp, $sfile, $dftp, $dfile) = @_; - $sftp->pasv_xfer($sfile, $dftp, $dfile, 1); -} - - -sub pasv_xfer { - my ($sftp, $sfile, $dftp, $dfile, $unique) = @_; - - ($dfile = $sfile) =~ s#.*/## - unless (defined $dfile); - - my $port = $sftp->pasv - or return undef; - - $dftp->port($port) - or return undef; - - return undef - unless ($unique ? $dftp->stou($dfile) : $dftp->stor($dfile)); - - unless ($sftp->retr($sfile) && $sftp->response == CMD_INFO) { - $sftp->retr($sfile); - $dftp->abort; - $dftp->response(); - return undef; - } - - $dftp->pasv_wait($sftp); -} - - -sub pasv_wait { - @_ == 2 or croak 'usage: $ftp->pasv_wait(NON_PASV_FTP)'; - - my ($ftp, $non_pasv) = @_; - my ($file, $rin, $rout); - - vec($rin = '', fileno($ftp), 1) = 1; - select($rout = $rin, undef, undef, undef); - - $ftp->response(); - $non_pasv->response(); - - return undef - unless $ftp->ok() && $non_pasv->ok(); - - return $1 - if $ftp->message =~ /unique file name:\s*(\S*)\s*\)/; - - return $1 - if $non_pasv->message =~ /unique file name:\s*(\S*)\s*\)/; - - return 1; -} - - -sub feature { - @_ == 2 or croak 'usage: $ftp->feature( NAME )'; - my ($ftp, $feat) = @_; - - my $feature = ${*$ftp}{net_ftp_feature} ||= do { - my @feat; - - # Example response - # 211-Features: - # MDTM - # REST STREAM - # SIZE - # 211 End - - @feat = map { /^\s+(.*\S)/ } $ftp->message - if $ftp->_FEAT; - - \@feat; - }; - - return grep { /^\Q$feat\E\b/i } @$feature; -} - - -sub cmd { shift->command(@_)->response() } - -######################################## -# -# RFC959 commands -# - - -sub _ABOR { shift->command("ABOR")->response() == CMD_OK } -sub _ALLO { shift->command("ALLO", @_)->response() == CMD_OK } -sub _CDUP { shift->command("CDUP")->response() == CMD_OK } -sub _NOOP { shift->command("NOOP")->response() == CMD_OK } -sub _PASV { shift->command("PASV")->response() == CMD_OK } -sub _QUIT { shift->command("QUIT")->response() == CMD_OK } -sub _DELE { shift->command("DELE", @_)->response() == CMD_OK } -sub _CWD { shift->command("CWD", @_)->response() == CMD_OK } -sub _PORT { shift->command("PORT", @_)->response() == CMD_OK } -sub _RMD { shift->command("RMD", @_)->response() == CMD_OK } -sub _MKD { shift->command("MKD", @_)->response() == CMD_OK } -sub _PWD { shift->command("PWD", @_)->response() == CMD_OK } -sub _TYPE { shift->command("TYPE", @_)->response() == CMD_OK } -sub _RNTO { shift->command("RNTO", @_)->response() == CMD_OK } -sub _RESP { shift->command("RESP", @_)->response() == CMD_OK } -sub _MDTM { shift->command("MDTM", @_)->response() == CMD_OK } -sub _SIZE { shift->command("SIZE", @_)->response() == CMD_OK } -sub _HELP { shift->command("HELP", @_)->response() == CMD_OK } -sub _STAT { shift->command("STAT", @_)->response() == CMD_OK } -sub _FEAT { shift->command("FEAT", @_)->response() == CMD_OK } -sub _APPE { shift->command("APPE", @_)->response() == CMD_INFO } -sub _LIST { shift->command("LIST", @_)->response() == CMD_INFO } -sub _NLST { shift->command("NLST", @_)->response() == CMD_INFO } -sub _RETR { shift->command("RETR", @_)->response() == CMD_INFO } -sub _STOR { shift->command("STOR", @_)->response() == CMD_INFO } -sub _STOU { shift->command("STOU", @_)->response() == CMD_INFO } -sub _RNFR { shift->command("RNFR", @_)->response() == CMD_MORE } -sub _REST { shift->command("REST", @_)->response() == CMD_MORE } -sub _PASS { shift->command("PASS", @_)->response() } -sub _ACCT { shift->command("ACCT", @_)->response() } -sub _AUTH { shift->command("AUTH", @_)->response() } - - -sub _USER { - my $ftp = shift; - my $ok = $ftp->command("USER", @_)->response(); - - # A certain brain dead firewall :-) - $ok = $ftp->command("user", @_)->response() - unless $ok == CMD_MORE or $ok == CMD_OK; - - $ok; -} - - -sub _SMNT { shift->unsupported(@_) } -sub _MODE { shift->unsupported(@_) } -sub _SYST { shift->unsupported(@_) } -sub _STRU { shift->unsupported(@_) } -sub _REIN { shift->unsupported(@_) } - -1; - -__END__ - -=head1 NAME - -Net::FTP - FTP Client class - -=head1 SYNOPSIS - - use Net::FTP; - - $ftp = Net::FTP->new("some.host.name", Debug => 0) - or die "Cannot connect to some.host.name: $@"; - - $ftp->login("anonymous",'-anonymous@') - or die "Cannot login ", $ftp->message; - - $ftp->cwd("/pub") - or die "Cannot change working directory ", $ftp->message; - - $ftp->get("that.file") - or die "get failed ", $ftp->message; - - $ftp->quit; - -=head1 DESCRIPTION - -C<Net::FTP> is a class implementing a simple FTP client in Perl as -described in RFC959. It provides wrappers for a subset of the RFC959 -commands. - -=head1 OVERVIEW - -FTP stands for File Transfer Protocol. It is a way of transferring -files between networked machines. The protocol defines a client -(whose commands are provided by this module) and a server (not -implemented in this module). Communication is always initiated by the -client, and the server responds with a message and a status code (and -sometimes with data). - -The FTP protocol allows files to be sent to or fetched from the -server. Each transfer involves a B<local file> (on the client) and a -B<remote file> (on the server). In this module, the same file name -will be used for both local and remote if only one is specified. This -means that transferring remote file C</path/to/file> will try to put -that file in C</path/to/file> locally, unless you specify a local file -name. - -The protocol also defines several standard B<translations> which the -file can undergo during transfer. These are ASCII, EBCDIC, binary, -and byte. ASCII is the default type, and indicates that the sender of -files will translate the ends of lines to a standard representation -which the receiver will then translate back into their local -representation. EBCDIC indicates the file being transferred is in -EBCDIC format. Binary (also known as image) format sends the data as -a contiguous bit stream. Byte format transfers the data as bytes, the -values of which remain the same regardless of differences in byte size -between the two machines (in theory - in practice you should only use -this if you really know what you're doing). - -=head1 CONSTRUCTOR - -=over 4 - -=item new ([ HOST ] [, OPTIONS ]) - -This is the constructor for a new Net::FTP object. C<HOST> is the -name of the remote host to which an FTP connection is required. - -C<HOST> is optional. If C<HOST> is not given then it may instead be -passed as the C<Host> option described below. - -C<OPTIONS> are passed in a hash like fashion, using key and value pairs. -Possible options are: - -B<Host> - FTP host to connect to. It may be a single scalar, as defined for -the C<PeerAddr> option in L<IO::Socket::INET>, or a reference to -an array with hosts to try in turn. The L</host> method will return the value -which was used to connect to the host. - - -B<Firewall> - The name of a machine which acts as an FTP firewall. This can be -overridden by an environment variable C<FTP_FIREWALL>. If specified, and the -given host cannot be directly connected to, then the -connection is made to the firewall machine and the string C<@hostname> is -appended to the login identifier. This kind of setup is also referred to -as an ftp proxy. - -B<FirewallType> - The type of firewall running on the machine indicated by -B<Firewall>. This can be overridden by an environment variable -C<FTP_FIREWALL_TYPE>. For a list of permissible types, see the description of -ftp_firewall_type in L<Net::Config>. - -B<BlockSize> - This is the block size that Net::FTP will use when doing -transfers. (defaults to 10240) - -B<Port> - The port number to connect to on the remote machine for the -FTP connection - -B<Timeout> - Set a timeout value (defaults to 120) - -B<Debug> - debug level (see the debug method in L<Net::Cmd>) - -B<Passive> - If set to a non-zero value then all data transfers will -be done using passive mode. If set to zero then data transfers will be -done using active mode. If the machine is connected to the Internet -directly, both passive and active mode should work equally well. -Behind most firewall and NAT configurations passive mode has a better -chance of working. However, in some rare firewall configurations, -active mode actually works when passive mode doesn't. Some really old -FTP servers might not implement passive transfers. If not specified, -then the transfer mode is set by the environment variable -C<FTP_PASSIVE> or if that one is not set by the settings done by the -F<libnetcfg> utility. If none of these apply then passive mode is -used. - -B<Hash> - If given a reference to a file handle (e.g., C<\*STDERR>), -print hash marks (#) on that filehandle every 1024 bytes. This -simply invokes the C<hash()> method for you, so that hash marks -are displayed for all transfers. You can, of course, call C<hash()> -explicitly whenever you'd like. - -B<LocalAddr> - Local address to use for all socket connections, this -argument will be passed to L<IO::Socket::INET> - -If the constructor fails undef will be returned and an error message will -be in $@ - -=back - -=head1 METHODS - -Unless otherwise stated all methods return either a I<true> or I<false> -value, with I<true> meaning that the operation was a success. When a method -states that it returns a value, failure will be returned as I<undef> or an -empty list. - -=over 4 - -=item login ([LOGIN [,PASSWORD [, ACCOUNT] ] ]) - -Log into the remote FTP server with the given login information. If -no arguments are given then the C<Net::FTP> uses the C<Net::Netrc> -package to lookup the login information for the connected host. -If no information is found then a login of I<anonymous> is used. -If no password is given and the login is I<anonymous> then I<anonymous@> -will be used for password. - -If the connection is via a firewall then the C<authorize> method will -be called with no arguments. - -=item authorize ( [AUTH [, RESP]]) - -This is a protocol used by some firewall ftp proxies. It is used -to authorise the user to send data out. If both arguments are not specified -then C<authorize> uses C<Net::Netrc> to do a lookup. - -=item site (ARGS) - -Send a SITE command to the remote server and wait for a response. - -Returns most significant digit of the response code. - -=item ascii - -Transfer file in ASCII. CRLF translation will be done if required - -=item binary - -Transfer file in binary mode. No transformation will be done. - -B<Hint>: If both server and client machines use the same line ending for -text files, then it will be faster to transfer all files in binary mode. - -=item rename ( OLDNAME, NEWNAME ) - -Rename a file on the remote FTP server from C<OLDNAME> to C<NEWNAME>. This -is done by sending the RNFR and RNTO commands. - -=item delete ( FILENAME ) - -Send a request to the server to delete C<FILENAME>. - -=item cwd ( [ DIR ] ) - -Attempt to change directory to the directory given in C<$dir>. If -C<$dir> is C<"..">, the FTP C<CDUP> command is used to attempt to -move up one directory. If no directory is given then an attempt is made -to change the directory to the root directory. - -=item cdup () - -Change directory to the parent of the current directory. - -=item pwd () - -Returns the full pathname of the current directory. - -=item restart ( WHERE ) - -Set the byte offset at which to begin the next data transfer. Net::FTP simply -records this value and uses it when during the next data transfer. For this -reason this method will not return an error, but setting it may cause -a subsequent data transfer to fail. - -=item rmdir ( DIR [, RECURSE ]) - -Remove the directory with the name C<DIR>. If C<RECURSE> is I<true> then -C<rmdir> will attempt to delete everything inside the directory. - -=item mkdir ( DIR [, RECURSE ]) - -Create a new directory with the name C<DIR>. If C<RECURSE> is I<true> then -C<mkdir> will attempt to create all the directories in the given path. - -Returns the full pathname to the new directory. - -=item alloc ( SIZE [, RECORD_SIZE] ) - -The alloc command allows you to give the ftp server a hint about the size -of the file about to be transferred using the ALLO ftp command. Some storage -systems use this to make intelligent decisions about how to store the file. -The C<SIZE> argument represents the size of the file in bytes. The -C<RECORD_SIZE> argument indicates a maximum record or page size for files -sent with a record or page structure. - -The size of the file will be determined, and sent to the server -automatically for normal files so that this method need only be called if -you are transferring data from a socket, named pipe, or other stream not -associated with a normal file. - -=item ls ( [ DIR ] ) - -Get a directory listing of C<DIR>, or the current directory. - -In an array context, returns a list of lines returned from the server. In -a scalar context, returns a reference to a list. - -=item dir ( [ DIR ] ) - -Get a directory listing of C<DIR>, or the current directory in long format. - -In an array context, returns a list of lines returned from the server. In -a scalar context, returns a reference to a list. - -=item get ( REMOTE_FILE [, LOCAL_FILE [, WHERE]] ) - -Get C<REMOTE_FILE> from the server and store locally. C<LOCAL_FILE> may be -a filename or a filehandle. If not specified, the file will be stored in -the current directory with the same leafname as the remote file. - -If C<WHERE> is given then the first C<WHERE> bytes of the file will -not be transferred, and the remaining bytes will be appended to -the local file if it already exists. - -Returns C<LOCAL_FILE>, or the generated local file name if C<LOCAL_FILE> -is not given. If an error was encountered undef is returned. - -=item put ( LOCAL_FILE [, REMOTE_FILE ] ) - -Put a file on the remote server. C<LOCAL_FILE> may be a name or a filehandle. -If C<LOCAL_FILE> is a filehandle then C<REMOTE_FILE> must be specified. If -C<REMOTE_FILE> is not specified then the file will be stored in the current -directory with the same leafname as C<LOCAL_FILE>. - -Returns C<REMOTE_FILE>, or the generated remote filename if C<REMOTE_FILE> -is not given. - -B<NOTE>: If for some reason the transfer does not complete and an error is -returned then the contents that had been transferred will not be remove -automatically. - -=item put_unique ( LOCAL_FILE [, REMOTE_FILE ] ) - -Same as put but uses the C<STOU> command. - -Returns the name of the file on the server. - -=item append ( LOCAL_FILE [, REMOTE_FILE ] ) - -Same as put but appends to the file on the remote server. - -Returns C<REMOTE_FILE>, or the generated remote filename if C<REMOTE_FILE> -is not given. - -=item unique_name () - -Returns the name of the last file stored on the server using the -C<STOU> command. - -=item mdtm ( FILE ) - -Returns the I<modification time> of the given file - -=item size ( FILE ) - -Returns the size in bytes for the given file as stored on the remote server. - -B<NOTE>: The size reported is the size of the stored file on the remote server. -If the file is subsequently transferred from the server in ASCII mode -and the remote server and local machine have different ideas about -"End Of Line" then the size of file on the local machine after transfer -may be different. - -=item supported ( CMD ) - -Returns TRUE if the remote server supports the given command. - -=item hash ( [FILEHANDLE_GLOB_REF],[ BYTES_PER_HASH_MARK] ) - -Called without parameters, or with the first argument false, hash marks -are suppressed. If the first argument is true but not a reference to a -file handle glob, then \*STDERR is used. The second argument is the number -of bytes per hash mark printed, and defaults to 1024. In all cases the -return value is a reference to an array of two: the filehandle glob reference -and the bytes per hash mark. - -=item feature ( NAME ) - -Determine if the server supports the specified feature. The return -value is a list of lines the server responded with to describe the -options that it supports for the given feature. If the feature is -unsupported then the empty list is returned. - - if ($ftp->feature( 'MDTM' )) { - # Do something - } - - if (grep { /\bTLS\b/ } $ftp->feature('AUTH')) { - # Server supports TLS - } - -=back - -The following methods can return different results depending on -how they are called. If the user explicitly calls either -of the C<pasv> or C<port> methods then these methods will -return a I<true> or I<false> value. If the user does not -call either of these methods then the result will be a -reference to a C<Net::FTP::dataconn> based object. - -=over 4 - -=item nlst ( [ DIR ] ) - -Send an C<NLST> command to the server, with an optional parameter. - -=item list ( [ DIR ] ) - -Same as C<nlst> but using the C<LIST> command - -=item retr ( FILE ) - -Begin the retrieval of a file called C<FILE> from the remote server. - -=item stor ( FILE ) - -Tell the server that you wish to store a file. C<FILE> is the -name of the new file that should be created. - -=item stou ( FILE ) - -Same as C<stor> but using the C<STOU> command. The name of the unique -file which was created on the server will be available via the C<unique_name> -method after the data connection has been closed. - -=item appe ( FILE ) - -Tell the server that we want to append some data to the end of a file -called C<FILE>. If this file does not exist then create it. - -=back - -If for some reason you want to have complete control over the data connection, -this includes generating it and calling the C<response> method when required, -then the user can use these methods to do so. - -However calling these methods only affects the use of the methods above that -can return a data connection. They have no effect on methods C<get>, C<put>, -C<put_unique> and those that do not require data connections. - -=over 4 - -=item port ( [ PORT ] ) - -Send a C<PORT> command to the server. If C<PORT> is specified then it is sent -to the server. If not, then a listen socket is created and the correct information -sent to the server. - -=item pasv () - -Tell the server to go into passive mode. Returns the text that represents the -port on which the server is listening, this text is in a suitable form to -sent to another ftp server using the C<port> method. - -=back - -The following methods can be used to transfer files between two remote -servers, providing that these two servers can connect directly to each other. - -=over 4 - -=item pasv_xfer ( SRC_FILE, DEST_SERVER [, DEST_FILE ] ) - -This method will do a file transfer between two remote ftp servers. If -C<DEST_FILE> is omitted then the leaf name of C<SRC_FILE> will be used. - -=item pasv_xfer_unique ( SRC_FILE, DEST_SERVER [, DEST_FILE ] ) - -Like C<pasv_xfer> but the file is stored on the remote server using -the STOU command. - -=item pasv_wait ( NON_PASV_SERVER ) - -This method can be used to wait for a transfer to complete between a passive -server and a non-passive server. The method should be called on the passive -server with the C<Net::FTP> object for the non-passive server passed as an -argument. - -=item abort () - -Abort the current data transfer. - -=item quit () - -Send the QUIT command to the remote FTP server and close the socket connection. - -=back - -=head2 Methods for the adventurous - -C<Net::FTP> inherits from C<Net::Cmd> so methods defined in C<Net::Cmd> may -be used to send commands to the remote FTP server. - -=over 4 - -=item quot (CMD [,ARGS]) - -Send a command, that Net::FTP does not directly support, to the remote -server and wait for a response. - -Returns most significant digit of the response code. - -B<WARNING> This call should only be used on commands that do not require -data connections. Misuse of this method can hang the connection. - -=back - -=head1 THE dataconn CLASS - -Some of the methods defined in C<Net::FTP> return an object which will -be derived from this class.The dataconn class itself is derived from -the C<IO::Socket::INET> class, so any normal IO operations can be performed. -However the following methods are defined in the dataconn class and IO should -be performed using these. - -=over 4 - -=item read ( BUFFER, SIZE [, TIMEOUT ] ) - -Read C<SIZE> bytes of data from the server and place it into C<BUFFER>, also -performing any <CRLF> translation necessary. C<TIMEOUT> is optional, if not -given, the timeout value from the command connection will be used. - -Returns the number of bytes read before any <CRLF> translation. - -=item write ( BUFFER, SIZE [, TIMEOUT ] ) - -Write C<SIZE> bytes of data from C<BUFFER> to the server, also -performing any <CRLF> translation necessary. C<TIMEOUT> is optional, if not -given, the timeout value from the command connection will be used. - -Returns the number of bytes written before any <CRLF> translation. - -=item bytes_read () - -Returns the number of bytes read so far. - -=item abort () - -Abort the current data transfer. - -=item close () - -Close the data connection and get a response from the FTP server. Returns -I<true> if the connection was closed successfully and the first digit of -the response from the server was a '2'. - -=back - -=head1 UNIMPLEMENTED - -The following RFC959 commands have not been implemented: - -=over 4 - -=item B<SMNT> - -Mount a different file system structure without changing login or -accounting information. - -=item B<HELP> - -Ask the server for "helpful information" (that's what the RFC says) on -the commands it accepts. - -=item B<MODE> - -Specifies transfer mode (stream, block or compressed) for file to be -transferred. - -=item B<SYST> - -Request remote server system identification. - -=item B<STAT> - -Request remote server status. - -=item B<STRU> - -Specifies file structure for file to be transferred. - -=item B<REIN> - -Reinitialize the connection, flushing all I/O and account information. - -=back - -=head1 REPORTING BUGS - -When reporting bugs/problems please include as much information as possible. -It may be difficult for me to reproduce the problem as almost every setup -is different. - -A small script which yields the problem will probably be of help. It would -also be useful if this script was run with the extra options C<Debug => 1> -passed to the constructor, and the output sent with the bug report. If you -cannot include a small script then please include a Debug trace from a -run of your program which does yield the problem. - -=head1 AUTHOR - -Graham Barr <gbarr@pobox.com> - -=head1 SEE ALSO - -L<Net::Netrc> -L<Net::Cmd> - -ftp(1), ftpd(8), RFC 959 -http://www.cis.ohio-state.edu/htbin/rfc/rfc959.html - -=head1 USE EXAMPLES - -For an example of the use of Net::FTP see - -=over 4 - -=item http://www.csh.rit.edu/~adam/Progs/ - -C<autoftp> is a program that can retrieve, send, or list files via -the FTP protocol in a non-interactive manner. - -=back - -=head1 CREDITS - -Henry Gabryjelski <henryg@WPI.EDU> - for the suggestion of creating directories -recursively. - -Nathan Torkington <gnat@frii.com> - for some input on the documentation. - -Roderick Schertler <roderick@gate.net> - for various inputs - -=head1 COPYRIGHT - -Copyright (c) 1995-2004 Graham Barr. All rights reserved. -This program is free software; you can redistribute it and/or modify it -under the same terms as Perl itself. - -=cut diff --git a/Master/tlpkg/tlperl/lib/Net/FTP/A.pm b/Master/tlpkg/tlperl/lib/Net/FTP/A.pm deleted file mode 100755 index 427d02b19e9..00000000000 --- a/Master/tlpkg/tlperl/lib/Net/FTP/A.pm +++ /dev/null @@ -1,111 +0,0 @@ -## -## Package to read/write on ASCII data connections -## - -package Net::FTP::A; -use strict; -use vars qw(@ISA $buf $VERSION); -use Carp; - -require Net::FTP::dataconn; - -@ISA = qw(Net::FTP::dataconn); -$VERSION = "1.18"; - - -sub read { - my $data = shift; - local *buf = \$_[0]; - shift; - my $size = shift || croak 'read($buf,$size,[$offset])'; - my $timeout = @_ ? shift: $data->timeout; - - if (length(${*$data}) < $size && !${*$data}{'net_ftp_eof'}) { - my $blksize = ${*$data}{'net_ftp_blksize'}; - $blksize = $size if $size > $blksize; - - my $l = 0; - my $n; - - READ: - { - my $readbuf = defined(${*$data}{'net_ftp_cr'}) ? "\015" : ''; - - $data->can_read($timeout) - or croak "Timeout"; - - if ($n = sysread($data, $readbuf, $blksize, length $readbuf)) { - ${*$data}{'net_ftp_bytesread'} += $n; - ${*$data}{'net_ftp_cr'} = - substr($readbuf, -1) eq "\015" - ? chop($readbuf) - : undef; - } - else { - return undef - unless defined $n; - - ${*$data}{'net_ftp_eof'} = 1; - } - - $readbuf =~ s/\015\012/\n/sgo; - ${*$data} .= $readbuf; - - unless (length(${*$data})) { - - redo READ - if ($n > 0); - - $size = length(${*$data}) - if ($n == 0); - } - } - } - - $buf = substr(${*$data}, 0, $size); - substr(${*$data}, 0, $size) = ''; - - length $buf; -} - - -sub write { - my $data = shift; - local *buf = \$_[0]; - shift; - my $size = shift || croak 'write($buf,$size,[$timeout])'; - my $timeout = @_ ? shift: $data->timeout; - - my $nr = (my $tmp = substr($buf, 0, $size)) =~ tr/\r\n/\015\012/; - $tmp =~ s/([^\015])\012/$1\015\012/sg if $nr; - $tmp =~ s/^\012/\015\012/ unless ${*$data}{'net_ftp_outcr'}; - ${*$data}{'net_ftp_outcr'} = substr($tmp, -1) eq "\015"; - - # If the remote server has closed the connection we will be signal'd - # when we write. This can happen if the disk on the remote server fills up - - local $SIG{PIPE} = 'IGNORE' - unless ($SIG{PIPE} || '') eq 'IGNORE' - or $^O eq 'MacOS'; - - my $len = length($tmp); - my $off = 0; - my $wrote = 0; - - my $blksize = ${*$data}{'net_ftp_blksize'}; - - while ($len) { - $data->can_write($timeout) - or croak "Timeout"; - - $off += $wrote; - $wrote = syswrite($data, substr($tmp, $off), $len > $blksize ? $blksize : $len); - return undef - unless defined($wrote); - $len -= $wrote; - } - - $size; -} - -1; diff --git a/Master/tlpkg/tlperl/lib/Net/FTP/E.pm b/Master/tlpkg/tlperl/lib/Net/FTP/E.pm deleted file mode 100755 index d480cd72955..00000000000 --- a/Master/tlpkg/tlperl/lib/Net/FTP/E.pm +++ /dev/null @@ -1,8 +0,0 @@ -package Net::FTP::E; - -require Net::FTP::I; - -@ISA = qw(Net::FTP::I); -$VERSION = "0.01"; - -1; diff --git a/Master/tlpkg/tlperl/lib/Net/FTP/I.pm b/Master/tlpkg/tlperl/lib/Net/FTP/I.pm deleted file mode 100755 index 449bb99eab6..00000000000 --- a/Master/tlpkg/tlperl/lib/Net/FTP/I.pm +++ /dev/null @@ -1,80 +0,0 @@ -## -## Package to read/write on BINARY data connections -## - -package Net::FTP::I; - -use vars qw(@ISA $buf $VERSION); -use Carp; - -require Net::FTP::dataconn; - -@ISA = qw(Net::FTP::dataconn); -$VERSION = "1.12"; - - -sub read { - my $data = shift; - local *buf = \$_[0]; - shift; - my $size = shift || croak 'read($buf,$size,[$timeout])'; - my $timeout = @_ ? shift: $data->timeout; - - my $n; - - if ($size > length ${*$data} and !${*$data}{'net_ftp_eof'}) { - $data->can_read($timeout) - or croak "Timeout"; - - my $blksize = ${*$data}{'net_ftp_blksize'}; - $blksize = $size if $size > $blksize; - - unless ($n = sysread($data, ${*$data}, $blksize, length ${*$data})) { - return undef unless defined $n; - ${*$data}{'net_ftp_eof'} = 1; - } - } - - $buf = substr(${*$data}, 0, $size); - - $n = length($buf); - - substr(${*$data}, 0, $n) = ''; - - ${*$data}{'net_ftp_bytesread'} += $n; - - $n; -} - - -sub write { - my $data = shift; - local *buf = \$_[0]; - shift; - my $size = shift || croak 'write($buf,$size,[$timeout])'; - my $timeout = @_ ? shift: $data->timeout; - - # If the remote server has closed the connection we will be signal'd - # when we write. This can happen if the disk on the remote server fills up - - local $SIG{PIPE} = 'IGNORE' - unless ($SIG{PIPE} || '') eq 'IGNORE' - or $^O eq 'MacOS'; - my $sent = $size; - my $off = 0; - - my $blksize = ${*$data}{'net_ftp_blksize'}; - while ($sent > 0) { - $data->can_write($timeout) - or croak "Timeout"; - - my $n = syswrite($data, $buf, $sent > $blksize ? $blksize : $sent, $off); - return undef unless defined($n); - $sent -= $n; - $off += $n; - } - - $size; -} - -1; diff --git a/Master/tlpkg/tlperl/lib/Net/FTP/L.pm b/Master/tlpkg/tlperl/lib/Net/FTP/L.pm deleted file mode 100755 index f7423cb9f95..00000000000 --- a/Master/tlpkg/tlperl/lib/Net/FTP/L.pm +++ /dev/null @@ -1,8 +0,0 @@ -package Net::FTP::L; - -require Net::FTP::I; - -@ISA = qw(Net::FTP::I); -$VERSION = "0.01"; - -1; diff --git a/Master/tlpkg/tlperl/lib/Net/FTP/dataconn.pm b/Master/tlpkg/tlperl/lib/Net/FTP/dataconn.pm deleted file mode 100755 index e7645cbd930..00000000000 --- a/Master/tlpkg/tlperl/lib/Net/FTP/dataconn.pm +++ /dev/null @@ -1,124 +0,0 @@ -## -## Generic data connection package -## - -package Net::FTP::dataconn; - -use Carp; -use vars qw(@ISA $timeout $VERSION); -use Net::Cmd; -use Errno; - -$VERSION = '0.11'; -@ISA = qw(IO::Socket::INET); - - -sub reading { - my $data = shift; - ${*$data}{'net_ftp_bytesread'} = 0; -} - - -sub abort { - my $data = shift; - my $ftp = ${*$data}{'net_ftp_cmd'}; - - # no need to abort if we have finished the xfer - return $data->close - if ${*$data}{'net_ftp_eof'}; - - # for some reason if we continously open RETR connections and not - # read a single byte, then abort them after a while the server will - # close our connection, this prevents the unexpected EOF on the - # command channel -- GMB - if (exists ${*$data}{'net_ftp_bytesread'} - && (${*$data}{'net_ftp_bytesread'} == 0)) - { - my $buf = ""; - my $timeout = $data->timeout; - $data->can_read($timeout) && sysread($data, $buf, 1); - } - - ${*$data}{'net_ftp_eof'} = 1; # fake - - $ftp->abort; # this will close me -} - - -sub _close { - my $data = shift; - my $ftp = ${*$data}{'net_ftp_cmd'}; - - $data->SUPER::close(); - - delete ${*$ftp}{'net_ftp_dataconn'} - if exists ${*$ftp}{'net_ftp_dataconn'} - && $data == ${*$ftp}{'net_ftp_dataconn'}; -} - - -sub close { - my $data = shift; - my $ftp = ${*$data}{'net_ftp_cmd'}; - - if (exists ${*$data}{'net_ftp_bytesread'} && !${*$data}{'net_ftp_eof'}) { - my $junk; - $data->read($junk, 1, 0); - return $data->abort unless ${*$data}{'net_ftp_eof'}; - } - - $data->_close; - - $ftp->response() == CMD_OK - && $ftp->message =~ /unique file name:\s*(\S*)\s*\)/ - && (${*$ftp}{'net_ftp_unique'} = $1); - - $ftp->status == CMD_OK; -} - - -sub _select { - my ($data, $timeout, $do_read) = @_; - my ($rin, $rout, $win, $wout, $tout, $nfound); - - vec($rin = '', fileno($data), 1) = 1; - - ($win, $rin) = ($rin, $win) unless $do_read; - - while (1) { - $nfound = select($rout = $rin, $wout = $win, undef, $tout = $timeout); - - last if $nfound >= 0; - - croak "select: $!" - unless $!{EINTR}; - } - - $nfound; -} - - -sub can_read { - _select(@_[0, 1], 1); -} - - -sub can_write { - _select(@_[0, 1], 0); -} - - -sub cmd { - my $ftp = shift; - - ${*$ftp}{'net_ftp_cmd'}; -} - - -sub bytes_read { - my $ftp = shift; - - ${*$ftp}{'net_ftp_bytesread'} || 0; -} - -1; diff --git a/Master/tlpkg/tlperl/lib/Net/HTTP.pm b/Master/tlpkg/tlperl/lib/Net/HTTP.pm deleted file mode 100755 index 120de285f71..00000000000 --- a/Master/tlpkg/tlperl/lib/Net/HTTP.pm +++ /dev/null @@ -1,279 +0,0 @@ -package Net::HTTP; - -use strict; -use vars qw($VERSION @ISA $SOCKET_CLASS); - -$VERSION = "5.834"; -unless ($SOCKET_CLASS) { - eval { require IO::Socket::INET } || require IO::Socket; - $SOCKET_CLASS = "IO::Socket::INET"; -} -require Net::HTTP::Methods; -require Carp; - -@ISA = ($SOCKET_CLASS, 'Net::HTTP::Methods'); - -sub new { - my $class = shift; - Carp::croak("No Host option provided") unless @_; - $class->SUPER::new(@_); -} - -sub configure { - my($self, $cnf) = @_; - $self->http_configure($cnf); -} - -sub http_connect { - my($self, $cnf) = @_; - $self->SUPER::configure($cnf); -} - -1; - -__END__ - -=head1 NAME - -Net::HTTP - Low-level HTTP connection (client) - -=head1 SYNOPSIS - - use Net::HTTP; - my $s = Net::HTTP->new(Host => "www.perl.com") || die $@; - $s->write_request(GET => "/", 'User-Agent' => "Mozilla/5.0"); - my($code, $mess, %h) = $s->read_response_headers; - - while (1) { - my $buf; - my $n = $s->read_entity_body($buf, 1024); - die "read failed: $!" unless defined $n; - last unless $n; - print $buf; - } - -=head1 DESCRIPTION - -The C<Net::HTTP> class is a low-level HTTP client. An instance of the -C<Net::HTTP> class represents a connection to an HTTP server. The -HTTP protocol is described in RFC 2616. The C<Net::HTTP> class -supports C<HTTP/1.0> and C<HTTP/1.1>. - -C<Net::HTTP> is a sub-class of C<IO::Socket::INET>. You can mix the -methods described below with reading and writing from the socket -directly. This is not necessary a good idea, unless you know what you -are doing. - -The following methods are provided (in addition to those of -C<IO::Socket::INET>): - -=over - -=item $s = Net::HTTP->new( %options ) - -The C<Net::HTTP> constructor method takes the same options as -C<IO::Socket::INET>'s as well as these: - - Host: Initial host attribute value - KeepAlive: Initial keep_alive attribute value - SendTE: Initial send_te attribute_value - HTTPVersion: Initial http_version attribute value - PeerHTTPVersion: Initial peer_http_version attribute value - MaxLineLength: Initial max_line_length attribute value - MaxHeaderLines: Initial max_header_lines attribute value - -The C<Host> option is also the default for C<IO::Socket::INET>'s -C<PeerAddr>. The C<PeerPort> defaults to 80 if not provided. - -The C<Listen> option provided by C<IO::Socket::INET>'s constructor -method is not allowed. - -If unable to connect to the given HTTP server then the constructor -returns C<undef> and $@ contains the reason. After a successful -connect, a C<Net:HTTP> object is returned. - -=item $s->host - -Get/set the default value of the C<Host> header to send. The $host -must not be set to an empty string (or C<undef>) for HTTP/1.1. - -=item $s->keep_alive - -Get/set the I<keep-alive> value. If this value is TRUE then the -request will be sent with headers indicating that the server should try -to keep the connection open so that multiple requests can be sent. - -The actual headers set will depend on the value of the C<http_version> -and C<peer_http_version> attributes. - -=item $s->send_te - -Get/set the a value indicating if the request will be sent with a "TE" -header to indicate the transfer encodings that the server can choose to -use. The list of encodings announced as accepted by this client depends -on availability of the following modules: C<Compress::Raw::Zlib> for -I<deflate>, and C<IO::Compress::Gunzip> for I<gzip>. - -=item $s->http_version - -Get/set the HTTP version number that this client should announce. -This value can only be set to "1.0" or "1.1". The default is "1.1". - -=item $s->peer_http_version - -Get/set the protocol version number of our peer. This value will -initially be "1.0", but will be updated by a successful -read_response_headers() method call. - -=item $s->max_line_length - -Get/set a limit on the length of response line and response header -lines. The default is 8192. A value of 0 means no limit. - -=item $s->max_header_length - -Get/set a limit on the number of header lines that a response can -have. The default is 128. A value of 0 means no limit. - -=item $s->format_request($method, $uri, %headers, [$content]) - -Format a request message and return it as a string. If the headers do -not include a C<Host> header, then a header is inserted with the value -of the C<host> attribute. Headers like C<Connection> and -C<Keep-Alive> might also be added depending on the status of the -C<keep_alive> attribute. - -If $content is given (and it is non-empty), then a C<Content-Length> -header is automatically added unless it was already present. - -=item $s->write_request($method, $uri, %headers, [$content]) - -Format and send a request message. Arguments are the same as for -format_request(). Returns true if successful. - -=item $s->format_chunk( $data ) - -Returns the string to be written for the given chunk of data. - -=item $s->write_chunk($data) - -Will write a new chunk of request entity body data. This method -should only be used if the C<Transfer-Encoding> header with a value of -C<chunked> was sent in the request. Note, writing zero-length data is -a no-op. Use the write_chunk_eof() method to signal end of entity -body data. - -Returns true if successful. - -=item $s->format_chunk_eof( %trailers ) - -Returns the string to be written for signaling EOF when a -C<Transfer-Encoding> of C<chunked> is used. - -=item $s->write_chunk_eof( %trailers ) - -Will write eof marker for chunked data and optional trailers. Note -that trailers should not really be used unless is was signaled -with a C<Trailer> header. - -Returns true if successful. - -=item ($code, $mess, %headers) = $s->read_response_headers( %opts ) - -Read response headers from server and return it. The $code is the 3 -digit HTTP status code (see L<HTTP::Status>) and $mess is the textual -message that came with it. Headers are then returned as key/value -pairs. Since key letter casing is not normalized and the same key can -even occur multiple times, assigning these values directly to a hash -is not wise. Only the $code is returned if this method is called in -scalar context. - -As a side effect this method updates the 'peer_http_version' -attribute. - -Options might be passed in as key/value pairs. There are currently -only two options supported; C<laxed> and C<junk_out>. - -The C<laxed> option will make read_response_headers() more forgiving -towards servers that have not learned how to speak HTTP properly. The -C<laxed> option is a boolean flag, and is enabled by passing in a TRUE -value. The C<junk_out> option can be used to capture bad header lines -when C<laxed> is enabled. The value should be an array reference. -Bad header lines will be pushed onto the array. - -The C<laxed> option must be specified in order to communicate with -pre-HTTP/1.0 servers that don't describe the response outcome or the -data they send back with a header block. For these servers -peer_http_version is set to "0.9" and this method returns (200, -"Assumed OK"). - -The method will raise an exception (die) if the server does not speak -proper HTTP or if the C<max_line_length> or C<max_header_length> -limits are reached. If the C<laxed> option is turned on and -C<max_line_length> and C<max_header_length> checks are turned off, -then no exception will be raised and this method will always -return a response code. - -=item $n = $s->read_entity_body($buf, $size); - -Reads chunks of the entity body content. Basically the same interface -as for read() and sysread(), but the buffer offset argument is not -supported yet. This method should only be called after a successful -read_response_headers() call. - -The return value will be C<undef> on read errors, 0 on EOF, -1 if no data -could be returned this time, otherwise the number of bytes assigned -to $buf. The $buf is set to "" when the return value is -1. - -You normally want to retry this call if this function returns either --1 or C<undef> with C<$!> as EINTR or EAGAIN (see L<Errno>). EINTR -can happen if the application catches signals and EAGAIN can happen if -you made the socket non-blocking. - -This method will raise exceptions (die) if the server does not speak -proper HTTP. This can only happen when reading chunked data. - -=item %headers = $s->get_trailers - -After read_entity_body() has returned 0 to indicate end of the entity -body, you might call this method to pick up any trailers. - -=item $s->_rbuf - -Get/set the read buffer content. The read_response_headers() and -read_entity_body() methods use an internal buffer which they will look -for data before they actually sysread more from the socket itself. If -they read too much, the remaining data will be left in this buffer. - -=item $s->_rbuf_length - -Returns the number of bytes in the read buffer. This should always be -the same as: - - length($s->_rbuf) - -but might be more efficient. - -=back - -=head1 SUBCLASSING - -The read_response_headers() and read_entity_body() will invoke the -sysread() method when they need more data. Subclasses might want to -override this method to control how reading takes place. - -The object itself is a glob. Subclasses should avoid using hash key -names prefixed with C<http_> and C<io_>. - -=head1 SEE ALSO - -L<LWP>, L<IO::Socket::INET>, L<Net::HTTP::NB> - -=head1 COPYRIGHT - -Copyright 2001-2003 Gisle Aas. - -This library is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -=cut diff --git a/Master/tlpkg/tlperl/lib/Net/HTTP/Methods.pm b/Master/tlpkg/tlperl/lib/Net/HTTP/Methods.pm deleted file mode 100755 index 22cc272b47e..00000000000 --- a/Master/tlpkg/tlperl/lib/Net/HTTP/Methods.pm +++ /dev/null @@ -1,593 +0,0 @@ -package Net::HTTP::Methods; - -require 5.005; # 4-arg substr - -use strict; -use vars qw($VERSION); - -$VERSION = "5.834"; - -my $CRLF = "\015\012"; # "\r\n" is not portable - -*_bytes = defined(&utf8::downgrade) ? - sub { - unless (utf8::downgrade($_[0], 1)) { - require Carp; - Carp::croak("Wide character in HTTP request (bytes required)"); - } - return $_[0]; - } - : - sub { - return $_[0]; - }; - - -sub new { - my $class = shift; - unshift(@_, "Host") if @_ == 1; - my %cnf = @_; - require Symbol; - my $self = bless Symbol::gensym(), $class; - return $self->http_configure(\%cnf); -} - -sub http_configure { - my($self, $cnf) = @_; - - die "Listen option not allowed" if $cnf->{Listen}; - my $explict_host = (exists $cnf->{Host}); - my $host = delete $cnf->{Host}; - my $peer = $cnf->{PeerAddr} || $cnf->{PeerHost}; - if (!$peer) { - die "No Host option provided" unless $host; - $cnf->{PeerAddr} = $peer = $host; - } - - if ($peer =~ s,:(\d+)$,,) { - $cnf->{PeerPort} = int($1); # always override - } - if (!$cnf->{PeerPort}) { - $cnf->{PeerPort} = $self->http_default_port; - } - - if (!$explict_host) { - $host = $peer; - $host =~ s/:.*//; - } - if ($host && $host !~ /:/) { - my $p = $cnf->{PeerPort}; - $host .= ":$p" if $p != $self->http_default_port; - } - - $cnf->{Proto} = 'tcp'; - - my $keep_alive = delete $cnf->{KeepAlive}; - my $http_version = delete $cnf->{HTTPVersion}; - $http_version = "1.1" unless defined $http_version; - my $peer_http_version = delete $cnf->{PeerHTTPVersion}; - $peer_http_version = "1.0" unless defined $peer_http_version; - my $send_te = delete $cnf->{SendTE}; - my $max_line_length = delete $cnf->{MaxLineLength}; - $max_line_length = 8*1024 unless defined $max_line_length; - my $max_header_lines = delete $cnf->{MaxHeaderLines}; - $max_header_lines = 128 unless defined $max_header_lines; - - return undef unless $self->http_connect($cnf); - - $self->host($host); - $self->keep_alive($keep_alive); - $self->send_te($send_te); - $self->http_version($http_version); - $self->peer_http_version($peer_http_version); - $self->max_line_length($max_line_length); - $self->max_header_lines($max_header_lines); - - ${*$self}{'http_buf'} = ""; - - return $self; -} - -sub http_default_port { - 80; -} - -# set up property accessors -for my $method (qw(host keep_alive send_te max_line_length max_header_lines peer_http_version)) { - my $prop_name = "http_" . $method; - no strict 'refs'; - *$method = sub { - my $self = shift; - my $old = ${*$self}{$prop_name}; - ${*$self}{$prop_name} = shift if @_; - return $old; - }; -} - -# we want this one to be a bit smarter -sub http_version { - my $self = shift; - my $old = ${*$self}{'http_version'}; - if (@_) { - my $v = shift; - $v = "1.0" if $v eq "1"; # float - unless ($v eq "1.0" or $v eq "1.1") { - require Carp; - Carp::croak("Unsupported HTTP version '$v'"); - } - ${*$self}{'http_version'} = $v; - } - $old; -} - -sub format_request { - my $self = shift; - my $method = shift; - my $uri = shift; - - my $content = (@_ % 2) ? pop : ""; - - for ($method, $uri) { - require Carp; - Carp::croak("Bad method or uri") if /\s/ || !length; - } - - push(@{${*$self}{'http_request_method'}}, $method); - my $ver = ${*$self}{'http_version'}; - my $peer_ver = ${*$self}{'http_peer_http_version'} || "1.0"; - - my @h; - my @connection; - my %given = (host => 0, "content-length" => 0, "te" => 0); - while (@_) { - my($k, $v) = splice(@_, 0, 2); - my $lc_k = lc($k); - if ($lc_k eq "connection") { - $v =~ s/^\s+//; - $v =~ s/\s+$//; - push(@connection, split(/\s*,\s*/, $v)); - next; - } - if (exists $given{$lc_k}) { - $given{$lc_k}++; - } - push(@h, "$k: $v"); - } - - if (length($content) && !$given{'content-length'}) { - push(@h, "Content-Length: " . length($content)); - } - - my @h2; - if ($given{te}) { - push(@connection, "TE") unless grep lc($_) eq "te", @connection; - } - elsif ($self->send_te && gunzip_ok()) { - # gzip is less wanted since the IO::Uncompress::Gunzip interface for - # it does not really allow chunked decoding to take place easily. - push(@h2, "TE: deflate,gzip;q=0.3"); - push(@connection, "TE"); - } - - unless (grep lc($_) eq "close", @connection) { - if ($self->keep_alive) { - if ($peer_ver eq "1.0") { - # from looking at Netscape's headers - push(@h2, "Keep-Alive: 300"); - unshift(@connection, "Keep-Alive"); - } - } - else { - push(@connection, "close") if $ver ge "1.1"; - } - } - push(@h2, "Connection: " . join(", ", @connection)) if @connection; - unless ($given{host}) { - my $h = ${*$self}{'http_host'}; - push(@h2, "Host: $h") if $h; - } - - return _bytes(join($CRLF, "$method $uri HTTP/$ver", @h2, @h, "", $content)); -} - - -sub write_request { - my $self = shift; - $self->print($self->format_request(@_)); -} - -sub format_chunk { - my $self = shift; - return $_[0] unless defined($_[0]) && length($_[0]); - return _bytes(sprintf("%x", length($_[0])) . $CRLF . $_[0] . $CRLF); -} - -sub write_chunk { - my $self = shift; - return 1 unless defined($_[0]) && length($_[0]); - $self->print(_bytes(sprintf("%x", length($_[0])) . $CRLF . $_[0] . $CRLF)); -} - -sub format_chunk_eof { - my $self = shift; - my @h; - while (@_) { - push(@h, sprintf "%s: %s$CRLF", splice(@_, 0, 2)); - } - return _bytes(join("", "0$CRLF", @h, $CRLF)); -} - -sub write_chunk_eof { - my $self = shift; - $self->print($self->format_chunk_eof(@_)); -} - - -sub my_read { - die if @_ > 3; - my $self = shift; - my $len = $_[1]; - for (${*$self}{'http_buf'}) { - if (length) { - $_[0] = substr($_, 0, $len, ""); - return length($_[0]); - } - else { - return $self->sysread($_[0], $len); - } - } -} - - -sub my_readline { - my $self = shift; - my $what = shift; - for (${*$self}{'http_buf'}) { - my $max_line_length = ${*$self}{'http_max_line_length'}; - my $pos; - while (1) { - # find line ending - $pos = index($_, "\012"); - last if $pos >= 0; - die "$what line too long (limit is $max_line_length)" - if $max_line_length && length($_) > $max_line_length; - - # need to read more data to find a line ending - READ: - { - my $n = $self->sysread($_, 1024, length); - unless (defined $n) { - redo READ if $!{EINTR}; - if ($!{EAGAIN}) { - # Hmm, we must be reading from a non-blocking socket - # XXX Should really wait until this socket is readable,... - select(undef, undef, undef, 0.1); # but this will do for now - redo READ; - } - # if we have already accumulated some data let's at least - # return that as a line - die "$what read failed: $!" unless length; - } - unless ($n) { - return undef unless length; - return substr($_, 0, length, ""); - } - } - } - die "$what line too long ($pos; limit is $max_line_length)" - if $max_line_length && $pos > $max_line_length; - - my $line = substr($_, 0, $pos+1, ""); - $line =~ s/(\015?\012)\z// || die "Assert"; - return wantarray ? ($line, $1) : $line; - } -} - - -sub _rbuf { - my $self = shift; - if (@_) { - for (${*$self}{'http_buf'}) { - my $old; - $old = $_ if defined wantarray; - $_ = shift; - return $old; - } - } - else { - return ${*$self}{'http_buf'}; - } -} - -sub _rbuf_length { - my $self = shift; - return length ${*$self}{'http_buf'}; -} - - -sub _read_header_lines { - my $self = shift; - my $junk_out = shift; - - my @headers; - my $line_count = 0; - my $max_header_lines = ${*$self}{'http_max_header_lines'}; - while (my $line = my_readline($self, 'Header')) { - if ($line =~ /^(\S+?)\s*:\s*(.*)/s) { - push(@headers, $1, $2); - } - elsif (@headers && $line =~ s/^\s+//) { - $headers[-1] .= " " . $line; - } - elsif ($junk_out) { - push(@$junk_out, $line); - } - else { - die "Bad header: '$line'\n"; - } - if ($max_header_lines) { - $line_count++; - if ($line_count >= $max_header_lines) { - die "Too many header lines (limit is $max_header_lines)"; - } - } - } - return @headers; -} - - -sub read_response_headers { - my($self, %opt) = @_; - my $laxed = $opt{laxed}; - - my($status, $eol) = my_readline($self, 'Status'); - unless (defined $status) { - die "Server closed connection without sending any data back"; - } - - my($peer_ver, $code, $message) = split(/\s+/, $status, 3); - if (!$peer_ver || $peer_ver !~ s,^HTTP/,, || $code !~ /^[1-5]\d\d$/) { - die "Bad response status line: '$status'" unless $laxed; - # assume HTTP/0.9 - ${*$self}{'http_peer_http_version'} = "0.9"; - ${*$self}{'http_status'} = "200"; - substr(${*$self}{'http_buf'}, 0, 0) = $status . ($eol || ""); - return 200 unless wantarray; - return (200, "Assumed OK"); - }; - - ${*$self}{'http_peer_http_version'} = $peer_ver; - ${*$self}{'http_status'} = $code; - - my $junk_out; - if ($laxed) { - $junk_out = $opt{junk_out} || []; - } - my @headers = $self->_read_header_lines($junk_out); - - # pick out headers that read_entity_body might need - my @te; - my $content_length; - for (my $i = 0; $i < @headers; $i += 2) { - my $h = lc($headers[$i]); - if ($h eq 'transfer-encoding') { - my $te = $headers[$i+1]; - $te =~ s/^\s+//; - $te =~ s/\s+$//; - push(@te, $te) if length($te); - } - elsif ($h eq 'content-length') { - # ignore bogus and overflow values - if ($headers[$i+1] =~ /^\s*(\d{1,15})(?:\s|$)/) { - $content_length = $1; - } - } - } - ${*$self}{'http_te'} = join(",", @te); - ${*$self}{'http_content_length'} = $content_length; - ${*$self}{'http_first_body'}++; - delete ${*$self}{'http_trailers'}; - return $code unless wantarray; - return ($code, $message, @headers); -} - - -sub read_entity_body { - my $self = shift; - my $buf_ref = \$_[0]; - my $size = $_[1]; - die "Offset not supported yet" if $_[2]; - - my $chunked; - my $bytes; - - if (${*$self}{'http_first_body'}) { - ${*$self}{'http_first_body'} = 0; - delete ${*$self}{'http_chunked'}; - delete ${*$self}{'http_bytes'}; - my $method = shift(@{${*$self}{'http_request_method'}}); - my $status = ${*$self}{'http_status'}; - if ($method eq "HEAD") { - # this response is always empty regardless of other headers - $bytes = 0; - } - elsif (my $te = ${*$self}{'http_te'}) { - my @te = split(/\s*,\s*/, lc($te)); - die "Chunked must be last Transfer-Encoding '$te'" - unless pop(@te) eq "chunked"; - - for (@te) { - if ($_ eq "deflate" && inflate_ok()) { - #require Compress::Raw::Zlib; - my ($i, $status) = Compress::Raw::Zlib::Inflate->new(); - die "Can't make inflator: $status" unless $i; - $_ = sub { my $out; $i->inflate($_[0], \$out); $out } - } - elsif ($_ eq "gzip" && gunzip_ok()) { - #require IO::Uncompress::Gunzip; - my @buf; - $_ = sub { - push(@buf, $_[0]); - return "" unless $_[1]; - my $input = join("", @buf); - my $output; - IO::Uncompress::Gunzip::gunzip(\$input, \$output, Transparent => 0) - or die "Can't gunzip content: $IO::Uncompress::Gunzip::GunzipError"; - return \$output; - }; - } - elsif ($_ eq "identity") { - $_ = sub { $_[0] }; - } - else { - die "Can't handle transfer encoding '$te'"; - } - } - - @te = reverse(@te); - - ${*$self}{'http_te2'} = @te ? \@te : ""; - $chunked = -1; - } - elsif (defined(my $content_length = ${*$self}{'http_content_length'})) { - $bytes = $content_length; - } - elsif ($status =~ /^(?:1|[23]04)/) { - # RFC 2616 says that these responses should always be empty - # but that does not appear to be true in practice [RT#17907] - $bytes = 0; - } - else { - # XXX Multi-Part types are self delimiting, but RFC 2616 says we - # only has to deal with 'multipart/byteranges' - - # Read until EOF - } - } - else { - $chunked = ${*$self}{'http_chunked'}; - $bytes = ${*$self}{'http_bytes'}; - } - - if (defined $chunked) { - # The state encoded in $chunked is: - # $chunked == 0: read CRLF after chunk, then chunk header - # $chunked == -1: read chunk header - # $chunked > 0: bytes left in current chunk to read - - if ($chunked <= 0) { - my $line = my_readline($self, 'Entity body'); - if ($chunked == 0) { - die "Missing newline after chunk data: '$line'" - if !defined($line) || $line ne ""; - $line = my_readline($self, 'Entity body'); - } - die "EOF when chunk header expected" unless defined($line); - my $chunk_len = $line; - $chunk_len =~ s/;.*//; # ignore potential chunk parameters - unless ($chunk_len =~ /^([\da-fA-F]+)\s*$/) { - die "Bad chunk-size in HTTP response: $line"; - } - $chunked = hex($1); - if ($chunked == 0) { - ${*$self}{'http_trailers'} = [$self->_read_header_lines]; - $$buf_ref = ""; - - my $n = 0; - if (my $transforms = delete ${*$self}{'http_te2'}) { - for (@$transforms) { - $$buf_ref = &$_($$buf_ref, 1); - } - $n = length($$buf_ref); - } - - # in case somebody tries to read more, make sure we continue - # to return EOF - delete ${*$self}{'http_chunked'}; - ${*$self}{'http_bytes'} = 0; - - return $n; - } - } - - my $n = $chunked; - $n = $size if $size && $size < $n; - $n = my_read($self, $$buf_ref, $n); - return undef unless defined $n; - - ${*$self}{'http_chunked'} = $chunked - $n; - - if ($n > 0) { - if (my $transforms = ${*$self}{'http_te2'}) { - for (@$transforms) { - $$buf_ref = &$_($$buf_ref, 0); - } - $n = length($$buf_ref); - $n = -1 if $n == 0; - } - } - return $n; - } - elsif (defined $bytes) { - unless ($bytes) { - $$buf_ref = ""; - return 0; - } - my $n = $bytes; - $n = $size if $size && $size < $n; - $n = my_read($self, $$buf_ref, $n); - return undef unless defined $n; - ${*$self}{'http_bytes'} = $bytes - $n; - return $n; - } - else { - # read until eof - $size ||= 8*1024; - return my_read($self, $$buf_ref, $size); - } -} - -sub get_trailers { - my $self = shift; - @{${*$self}{'http_trailers'} || []}; -} - -BEGIN { -my $gunzip_ok; -my $inflate_ok; - -sub gunzip_ok { - return $gunzip_ok if defined $gunzip_ok; - - # Try to load IO::Uncompress::Gunzip. - local $@; - local $SIG{__DIE__}; - $gunzip_ok = 0; - - eval { - require IO::Uncompress::Gunzip; - $gunzip_ok++; - }; - - return $gunzip_ok; -} - -sub inflate_ok { - return $inflate_ok if defined $inflate_ok; - - # Try to load Compress::Raw::Zlib. - local $@; - local $SIG{__DIE__}; - $inflate_ok = 0; - - eval { - require Compress::Raw::Zlib; - $inflate_ok++; - }; - - return $inflate_ok; -} - -} # BEGIN - -1; diff --git a/Master/tlpkg/tlperl/lib/Net/HTTP/NB.pm b/Master/tlpkg/tlperl/lib/Net/HTTP/NB.pm deleted file mode 100755 index e4145116f6a..00000000000 --- a/Master/tlpkg/tlperl/lib/Net/HTTP/NB.pm +++ /dev/null @@ -1,105 +0,0 @@ -package Net::HTTP::NB; - -use strict; -use vars qw($VERSION @ISA); - -$VERSION = "5.810"; - -require Net::HTTP; -@ISA=qw(Net::HTTP); - -sub sysread { - my $self = $_[0]; - if (${*$self}{'httpnb_read_count'}++) { - ${*$self}{'http_buf'} = ${*$self}{'httpnb_save'}; - die "Multi-read\n"; - } - my $buf; - my $offset = $_[3] || 0; - my $n = sysread($self, $_[1], $_[2], $offset); - ${*$self}{'httpnb_save'} .= substr($_[1], $offset); - return $n; -} - -sub read_response_headers { - my $self = shift; - ${*$self}{'httpnb_read_count'} = 0; - ${*$self}{'httpnb_save'} = ${*$self}{'http_buf'}; - my @h = eval { $self->SUPER::read_response_headers(@_) }; - if ($@) { - return if $@ eq "Multi-read\n"; - die; - } - return @h; -} - -sub read_entity_body { - my $self = shift; - ${*$self}{'httpnb_read_count'} = 0; - ${*$self}{'httpnb_save'} = ${*$self}{'http_buf'}; - # XXX I'm not so sure this does the correct thing in case of - # transfer-encoding tranforms - my $n = eval { $self->SUPER::read_entity_body(@_); }; - if ($@) { - $_[0] = ""; - return -1; - } - return $n; -} - -1; - -__END__ - -=head1 NAME - -Net::HTTP::NB - Non-blocking HTTP client - -=head1 SYNOPSIS - - use Net::HTTP::NB; - my $s = Net::HTTP::NB->new(Host => "www.perl.com") || die $@; - $s->write_request(GET => "/"); - - use IO::Select; - my $sel = IO::Select->new($s); - - READ_HEADER: { - die "Header timeout" unless $sel->can_read(10); - my($code, $mess, %h) = $s->read_response_headers; - redo READ_HEADER unless $code; - } - - while (1) { - die "Body timeout" unless $sel->can_read(10); - my $buf; - my $n = $s->read_entity_body($buf, 1024); - last unless $n; - print $buf; - } - -=head1 DESCRIPTION - -Same interface as C<Net::HTTP> but it will never try multiple reads -when the read_response_headers() or read_entity_body() methods are -invoked. This make it possible to multiplex multiple Net::HTTP::NB -using select without risk blocking. - -If read_response_headers() did not see enough data to complete the -headers an empty list is returned. - -If read_entity_body() did not see new entity data in its read -the value -1 is returned. - -=head1 SEE ALSO - -L<Net::HTTP> - -=head1 COPYRIGHT - -Copyright 2001 Gisle Aas. - -This library is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -=cut diff --git a/Master/tlpkg/tlperl/lib/Net/HTTPS.pm b/Master/tlpkg/tlperl/lib/Net/HTTPS.pm deleted file mode 100755 index bfed714870c..00000000000 --- a/Master/tlpkg/tlperl/lib/Net/HTTPS.pm +++ /dev/null @@ -1,59 +0,0 @@ -package Net::HTTPS; - -use strict; -use vars qw($VERSION $SSL_SOCKET_CLASS @ISA); - -$VERSION = "5.819"; - -# Figure out which SSL implementation to use -if ($SSL_SOCKET_CLASS) { - # somebody already set it -} -elsif ($Net::SSL::VERSION) { - $SSL_SOCKET_CLASS = "Net::SSL"; -} -elsif ($IO::Socket::SSL::VERSION) { - $SSL_SOCKET_CLASS = "IO::Socket::SSL"; # it was already loaded -} -else { - eval { require Net::SSL; }; # from Crypt-SSLeay - if ($@) { - my $old_errsv = $@; - eval { - require IO::Socket::SSL; - }; - if ($@) { - $old_errsv =~ s/\s\(\@INC contains:.*\)/)/g; - die $old_errsv . $@; - } - $SSL_SOCKET_CLASS = "IO::Socket::SSL"; - } - else { - $SSL_SOCKET_CLASS = "Net::SSL"; - } -} - -require Net::HTTP::Methods; - -@ISA=($SSL_SOCKET_CLASS, 'Net::HTTP::Methods'); - -sub configure { - my($self, $cnf) = @_; - $self->http_configure($cnf); -} - -sub http_connect { - my($self, $cnf) = @_; - $self->SUPER::configure($cnf); -} - -sub http_default_port { - 443; -} - -# The underlying SSLeay classes fails to work if the socket is -# placed in non-blocking mode. This override of the blocking -# method makes sure it stays the way it was created. -sub blocking { } # noop - -1; diff --git a/Master/tlpkg/tlperl/lib/Net/Hostname.pm.eg b/Master/tlpkg/tlperl/lib/Net/Hostname.pm.eg deleted file mode 100755 index 4736c1a6ef2..00000000000 --- a/Master/tlpkg/tlperl/lib/Net/Hostname.pm.eg +++ /dev/null @@ -1,14 +0,0 @@ -# - -package Sys::Hostname; - -use Net::Domain qw(hostname); -use Carp; - -require Exporter; -@ISA = qw(Exporter); -@EXPORT = qw(hostname); - -carp "deprecated package 'Sys::Hostname', use Net::Domain" if $^W; - -1; diff --git a/Master/tlpkg/tlperl/lib/Net/NNTP.pm b/Master/tlpkg/tlperl/lib/Net/NNTP.pm deleted file mode 100755 index a742aed04c8..00000000000 --- a/Master/tlpkg/tlperl/lib/Net/NNTP.pm +++ /dev/null @@ -1,1140 +0,0 @@ -# Net::NNTP.pm -# -# Copyright (c) 1995-1997 Graham Barr <gbarr@pobox.com>. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package Net::NNTP; - -use strict; -use vars qw(@ISA $VERSION $debug); -use IO::Socket; -use Net::Cmd; -use Carp; -use Time::Local; -use Net::Config; - -$VERSION = "2.24"; -@ISA = qw(Net::Cmd IO::Socket::INET); - - -sub new { - my $self = shift; - my $type = ref($self) || $self; - my ($host, %arg); - if (@_ % 2) { - $host = shift; - %arg = @_; - } - else { - %arg = @_; - $host = delete $arg{Host}; - } - my $obj; - - $host ||= $ENV{NNTPSERVER} || $ENV{NEWSHOST}; - - my $hosts = defined $host ? [$host] : $NetConfig{nntp_hosts}; - - @{$hosts} = qw(news) - unless @{$hosts}; - - my $h; - foreach $h (@{$hosts}) { - $obj = $type->SUPER::new( - PeerAddr => ($host = $h), - PeerPort => $arg{Port} || 'nntp(119)', - Proto => 'tcp', - Timeout => defined $arg{Timeout} - ? $arg{Timeout} - : 120 - ) - and last; - } - - return undef - unless defined $obj; - - ${*$obj}{'net_nntp_host'} = $host; - - $obj->autoflush(1); - $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef); - - unless ($obj->response() == CMD_OK) { - $obj->close; - return undef; - } - - my $c = $obj->code; - my @m = $obj->message; - - unless (exists $arg{Reader} && $arg{Reader} == 0) { - - # if server is INN and we have transfer rights the we are currently - # talking to innd not nnrpd - if ($obj->reader) { - - # If reader suceeds the we need to consider this code to determine postok - $c = $obj->code; - } - else { - - # I want to ignore this failure, so restore the previous status. - $obj->set_status($c, \@m); - } - } - - ${*$obj}{'net_nntp_post'} = $c == 200 ? 1 : 0; - - $obj; -} - - -sub host { - my $me = shift; - ${*$me}{'net_nntp_host'}; -} - - -sub debug_text { - my $nntp = shift; - my $inout = shift; - my $text = shift; - - if ( (ref($nntp) and $nntp->code == 350 and $text =~ /^(\S+)/) - || ($text =~ /^(authinfo\s+pass)/io)) - { - $text = "$1 ....\n"; - } - - $text; -} - - -sub postok { - @_ == 1 or croak 'usage: $nntp->postok()'; - my $nntp = shift; - ${*$nntp}{'net_nntp_post'} || 0; -} - - -sub article { - @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->article( [ MSGID ], [ FH ] )'; - my $nntp = shift; - my @fh; - - @fh = (pop) if @_ == 2 || (@_ && (ref($_[0]) || ref(\$_[0]) eq 'GLOB')); - - $nntp->_ARTICLE(@_) - ? $nntp->read_until_dot(@fh) - : undef; -} - - -sub articlefh { - @_ >= 1 && @_ <= 2 or croak 'usage: $nntp->articlefh( [ MSGID ] )'; - my $nntp = shift; - - return unless $nntp->_ARTICLE(@_); - return $nntp->tied_fh; -} - - -sub authinfo { - @_ == 3 or croak 'usage: $nntp->authinfo( USER, PASS )'; - my ($nntp, $user, $pass) = @_; - - $nntp->_AUTHINFO("USER", $user) == CMD_MORE - && $nntp->_AUTHINFO("PASS", $pass) == CMD_OK; -} - - -sub authinfo_simple { - @_ == 3 or croak 'usage: $nntp->authinfo( USER, PASS )'; - my ($nntp, $user, $pass) = @_; - - $nntp->_AUTHINFO('SIMPLE') == CMD_MORE - && $nntp->command($user, $pass)->response == CMD_OK; -} - - -sub body { - @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->body( [ MSGID ], [ FH ] )'; - my $nntp = shift; - my @fh; - - @fh = (pop) if @_ == 2 || (@_ && ref($_[0]) || ref(\$_[0]) eq 'GLOB'); - - $nntp->_BODY(@_) - ? $nntp->read_until_dot(@fh) - : undef; -} - - -sub bodyfh { - @_ >= 1 && @_ <= 2 or croak 'usage: $nntp->bodyfh( [ MSGID ] )'; - my $nntp = shift; - return unless $nntp->_BODY(@_); - return $nntp->tied_fh; -} - - -sub head { - @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->head( [ MSGID ], [ FH ] )'; - my $nntp = shift; - my @fh; - - @fh = (pop) if @_ == 2 || (@_ && ref($_[0]) || ref(\$_[0]) eq 'GLOB'); - - $nntp->_HEAD(@_) - ? $nntp->read_until_dot(@fh) - : undef; -} - - -sub headfh { - @_ >= 1 && @_ <= 2 or croak 'usage: $nntp->headfh( [ MSGID ] )'; - my $nntp = shift; - return unless $nntp->_HEAD(@_); - return $nntp->tied_fh; -} - - -sub nntpstat { - @_ == 1 || @_ == 2 or croak 'usage: $nntp->nntpstat( [ MSGID ] )'; - my $nntp = shift; - - $nntp->_STAT(@_) && $nntp->message =~ /(<[^>]+>)/o - ? $1 - : undef; -} - - -sub group { - @_ == 1 || @_ == 2 or croak 'usage: $nntp->group( [ GROUP ] )'; - my $nntp = shift; - my $grp = ${*$nntp}{'net_nntp_group'} || undef; - - return $grp - unless (@_ || wantarray); - - my $newgrp = shift; - - return wantarray ? () : undef - unless $nntp->_GROUP($newgrp || $grp || "") - && $nntp->message =~ /(\d+)\s+(\d+)\s+(\d+)\s+(\S+)/; - - my ($count, $first, $last, $group) = ($1, $2, $3, $4); - - # group may be replied as '(current group)' - $group = ${*$nntp}{'net_nntp_group'} - if $group =~ /\(/; - - ${*$nntp}{'net_nntp_group'} = $group; - - wantarray - ? ($count, $first, $last, $group) - : $group; -} - - -sub help { - @_ == 1 or croak 'usage: $nntp->help()'; - my $nntp = shift; - - $nntp->_HELP - ? $nntp->read_until_dot - : undef; -} - - -sub ihave { - @_ >= 2 or croak 'usage: $nntp->ihave( MESSAGE-ID [, MESSAGE ])'; - my $nntp = shift; - my $mid = shift; - - $nntp->_IHAVE($mid) && $nntp->datasend(@_) - ? @_ == 0 || $nntp->dataend - : undef; -} - - -sub last { - @_ == 1 or croak 'usage: $nntp->last()'; - my $nntp = shift; - - $nntp->_LAST && $nntp->message =~ /(<[^>]+>)/o - ? $1 - : undef; -} - - -sub list { - @_ == 1 or croak 'usage: $nntp->list()'; - my $nntp = shift; - - $nntp->_LIST - ? $nntp->_grouplist - : undef; -} - - -sub newgroups { - @_ >= 2 or croak 'usage: $nntp->newgroups( SINCE [, DISTRIBUTIONS ])'; - my $nntp = shift; - my $time = _timestr(shift); - my $dist = shift || ""; - - $dist = join(",", @{$dist}) - if ref($dist); - - $nntp->_NEWGROUPS($time, $dist) - ? $nntp->_grouplist - : undef; -} - - -sub newnews { - @_ >= 2 && @_ <= 4 - or croak 'usage: $nntp->newnews( SINCE [, GROUPS [, DISTRIBUTIONS ]])'; - my $nntp = shift; - my $time = _timestr(shift); - my $grp = @_ ? shift: $nntp->group; - my $dist = shift || ""; - - $grp ||= "*"; - $grp = join(",", @{$grp}) - if ref($grp); - - $dist = join(",", @{$dist}) - if ref($dist); - - $nntp->_NEWNEWS($grp, $time, $dist) - ? $nntp->_articlelist - : undef; -} - - -sub next { - @_ == 1 or croak 'usage: $nntp->next()'; - my $nntp = shift; - - $nntp->_NEXT && $nntp->message =~ /(<[^>]+>)/o - ? $1 - : undef; -} - - -sub post { - @_ >= 1 or croak 'usage: $nntp->post( [ MESSAGE ] )'; - my $nntp = shift; - - $nntp->_POST() && $nntp->datasend(@_) - ? @_ == 0 || $nntp->dataend - : undef; -} - - -sub postfh { - my $nntp = shift; - return unless $nntp->_POST(); - return $nntp->tied_fh; -} - - -sub quit { - @_ == 1 or croak 'usage: $nntp->quit()'; - my $nntp = shift; - - $nntp->_QUIT; - $nntp->close; -} - - -sub slave { - @_ == 1 or croak 'usage: $nntp->slave()'; - my $nntp = shift; - - $nntp->_SLAVE; -} - -## -## The following methods are not implemented by all servers -## - - -sub active { - @_ == 1 || @_ == 2 or croak 'usage: $nntp->active( [ PATTERN ] )'; - my $nntp = shift; - - $nntp->_LIST('ACTIVE', @_) - ? $nntp->_grouplist - : undef; -} - - -sub active_times { - @_ == 1 or croak 'usage: $nntp->active_times()'; - my $nntp = shift; - - $nntp->_LIST('ACTIVE.TIMES') - ? $nntp->_grouplist - : undef; -} - - -sub distributions { - @_ == 1 or croak 'usage: $nntp->distributions()'; - my $nntp = shift; - - $nntp->_LIST('DISTRIBUTIONS') - ? $nntp->_description - : undef; -} - - -sub distribution_patterns { - @_ == 1 or croak 'usage: $nntp->distributions()'; - my $nntp = shift; - - my $arr; - local $_; - - $nntp->_LIST('DISTRIB.PATS') - && ($arr = $nntp->read_until_dot) - ? [grep { /^\d/ && (chomp, $_ = [split /:/]) } @$arr] - : undef; -} - - -sub newsgroups { - @_ == 1 || @_ == 2 or croak 'usage: $nntp->newsgroups( [ PATTERN ] )'; - my $nntp = shift; - - $nntp->_LIST('NEWSGROUPS', @_) - ? $nntp->_description - : undef; -} - - -sub overview_fmt { - @_ == 1 or croak 'usage: $nntp->overview_fmt()'; - my $nntp = shift; - - $nntp->_LIST('OVERVIEW.FMT') - ? $nntp->_articlelist - : undef; -} - - -sub subscriptions { - @_ == 1 or croak 'usage: $nntp->subscriptions()'; - my $nntp = shift; - - $nntp->_LIST('SUBSCRIPTIONS') - ? $nntp->_articlelist - : undef; -} - - -sub listgroup { - @_ == 1 || @_ == 2 or croak 'usage: $nntp->listgroup( [ GROUP ] )'; - my $nntp = shift; - - $nntp->_LISTGROUP(@_) - ? $nntp->_articlelist - : undef; -} - - -sub reader { - @_ == 1 or croak 'usage: $nntp->reader()'; - my $nntp = shift; - - $nntp->_MODE('READER'); -} - - -sub xgtitle { - @_ == 1 || @_ == 2 or croak 'usage: $nntp->xgtitle( [ PATTERN ] )'; - my $nntp = shift; - - $nntp->_XGTITLE(@_) - ? $nntp->_description - : undef; -} - - -sub xhdr { - @_ >= 2 && @_ <= 4 or croak 'usage: $nntp->xhdr( HEADER, [ MESSAGE-SPEC ] )'; - my $nntp = shift; - my $hdr = shift; - my $arg = _msg_arg(@_); - - $nntp->_XHDR($hdr, $arg) - ? $nntp->_description - : undef; -} - - -sub xover { - @_ == 2 || @_ == 3 or croak 'usage: $nntp->xover( MESSAGE-SPEC )'; - my $nntp = shift; - my $arg = _msg_arg(@_); - - $nntp->_XOVER($arg) - ? $nntp->_fieldlist - : undef; -} - - -sub xpat { - @_ == 4 || @_ == 5 or croak '$nntp->xpat( HEADER, PATTERN, MESSAGE-SPEC )'; - my $nntp = shift; - my $hdr = shift; - my $pat = shift; - my $arg = _msg_arg(@_); - - $pat = join(" ", @$pat) - if ref($pat); - - $nntp->_XPAT($hdr, $arg, $pat) - ? $nntp->_description - : undef; -} - - -sub xpath { - @_ == 2 or croak 'usage: $nntp->xpath( MESSAGE-ID )'; - my ($nntp, $mid) = @_; - - return undef - unless $nntp->_XPATH($mid); - - my $m; - ($m = $nntp->message) =~ s/^\d+\s+//o; - my @p = split /\s+/, $m; - - wantarray ? @p : $p[0]; -} - - -sub xrover { - @_ == 2 || @_ == 3 or croak 'usage: $nntp->xrover( MESSAGE-SPEC )'; - my $nntp = shift; - my $arg = _msg_arg(@_); - - $nntp->_XROVER($arg) - ? $nntp->_description - : undef; -} - - -sub date { - @_ == 1 or croak 'usage: $nntp->date()'; - my $nntp = shift; - - $nntp->_DATE - && $nntp->message =~ /(\d{4})(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/ - ? timegm($6, $5, $4, $3, $2 - 1, $1 - 1900) - : undef; -} - - -## -## Private subroutines -## - - -sub _msg_arg { - my $spec = shift; - my $arg = ""; - - if (@_) { - carp "Depriciated passing of two message numbers, " . "pass a reference" - if $^W; - $spec = [$spec, $_[0]]; - } - - if (defined $spec) { - if (ref($spec)) { - $arg = $spec->[0]; - if (defined $spec->[1]) { - $arg .= "-" - if $spec->[1] != $spec->[0]; - $arg .= $spec->[1] - if $spec->[1] > $spec->[0]; - } - } - else { - $arg = $spec; - } - } - - $arg; -} - - -sub _timestr { - my $time = shift; - my @g = reverse((gmtime($time))[0 .. 5]); - $g[1] += 1; - $g[0] %= 100; - sprintf "%02d%02d%02d %02d%02d%02d GMT", @g; -} - - -sub _grouplist { - my $nntp = shift; - my $arr = $nntp->read_until_dot - or return undef; - - my $hash = {}; - my $ln; - - foreach $ln (@$arr) { - my @a = split(/[\s\n]+/, $ln); - $hash->{$a[0]} = [@a[1, 2, 3]]; - } - - $hash; -} - - -sub _fieldlist { - my $nntp = shift; - my $arr = $nntp->read_until_dot - or return undef; - - my $hash = {}; - my $ln; - - foreach $ln (@$arr) { - my @a = split(/[\t\n]/, $ln); - my $m = shift @a; - $hash->{$m} = [@a]; - } - - $hash; -} - - -sub _articlelist { - my $nntp = shift; - my $arr = $nntp->read_until_dot; - - chomp(@$arr) - if $arr; - - $arr; -} - - -sub _description { - my $nntp = shift; - my $arr = $nntp->read_until_dot - or return undef; - - my $hash = {}; - my $ln; - - foreach $ln (@$arr) { - chomp($ln); - - $hash->{$1} = $ln - if $ln =~ s/^\s*(\S+)\s*//o; - } - - $hash; - -} - -## -## The commands -## - - -sub _ARTICLE { shift->command('ARTICLE', @_)->response == CMD_OK } -sub _AUTHINFO { shift->command('AUTHINFO', @_)->response } -sub _BODY { shift->command('BODY', @_)->response == CMD_OK } -sub _DATE { shift->command('DATE')->response == CMD_INFO } -sub _GROUP { shift->command('GROUP', @_)->response == CMD_OK } -sub _HEAD { shift->command('HEAD', @_)->response == CMD_OK } -sub _HELP { shift->command('HELP', @_)->response == CMD_INFO } -sub _IHAVE { shift->command('IHAVE', @_)->response == CMD_MORE } -sub _LAST { shift->command('LAST')->response == CMD_OK } -sub _LIST { shift->command('LIST', @_)->response == CMD_OK } -sub _LISTGROUP { shift->command('LISTGROUP', @_)->response == CMD_OK } -sub _NEWGROUPS { shift->command('NEWGROUPS', @_)->response == CMD_OK } -sub _NEWNEWS { shift->command('NEWNEWS', @_)->response == CMD_OK } -sub _NEXT { shift->command('NEXT')->response == CMD_OK } -sub _POST { shift->command('POST', @_)->response == CMD_MORE } -sub _QUIT { shift->command('QUIT', @_)->response == CMD_OK } -sub _SLAVE { shift->command('SLAVE', @_)->response == CMD_OK } -sub _STAT { shift->command('STAT', @_)->response == CMD_OK } -sub _MODE { shift->command('MODE', @_)->response == CMD_OK } -sub _XGTITLE { shift->command('XGTITLE', @_)->response == CMD_OK } -sub _XHDR { shift->command('XHDR', @_)->response == CMD_OK } -sub _XPAT { shift->command('XPAT', @_)->response == CMD_OK } -sub _XPATH { shift->command('XPATH', @_)->response == CMD_OK } -sub _XOVER { shift->command('XOVER', @_)->response == CMD_OK } -sub _XROVER { shift->command('XROVER', @_)->response == CMD_OK } -sub _XTHREAD { shift->unsupported } -sub _XSEARCH { shift->unsupported } -sub _XINDEX { shift->unsupported } - -## -## IO/perl methods -## - - -sub DESTROY { - my $nntp = shift; - defined(fileno($nntp)) && $nntp->quit; -} - - -1; - -__END__ - -=head1 NAME - -Net::NNTP - NNTP Client class - -=head1 SYNOPSIS - - use Net::NNTP; - - $nntp = Net::NNTP->new("some.host.name"); - $nntp->quit; - -=head1 DESCRIPTION - -C<Net::NNTP> is a class implementing a simple NNTP client in Perl as described -in RFC977. C<Net::NNTP> inherits its communication methods from C<Net::Cmd> - -=head1 CONSTRUCTOR - -=over 4 - -=item new ( [ HOST ] [, OPTIONS ]) - -This is the constructor for a new Net::NNTP object. C<HOST> is the -name of the remote host to which a NNTP connection is required. If not -given then it may be passed as the C<Host> option described below. If no host is passed -then two environment variables are checked, first C<NNTPSERVER> then -C<NEWSHOST>, then C<Net::Config> is checked, and if a host is not found -then C<news> is used. - -C<OPTIONS> are passed in a hash like fashion, using key and value pairs. -Possible options are: - -B<Host> - NNTP host to connect to. It may be a single scalar, as defined for -the C<PeerAddr> option in L<IO::Socket::INET>, or a reference to -an array with hosts to try in turn. The L</host> method will return the value -which was used to connect to the host. - -B<Timeout> - Maximum time, in seconds, to wait for a response from the -NNTP server, a value of zero will cause all IO operations to block. -(default: 120) - -B<Debug> - Enable the printing of debugging information to STDERR - -B<Reader> - If the remote server is INN then initially the connection -will be to nnrpd, by default C<Net::NNTP> will issue a C<MODE READER> command -so that the remote server becomes innd. If the C<Reader> option is given -with a value of zero, then this command will not be sent and the -connection will be left talking to nnrpd. - -=back - -=head1 METHODS - -Unless otherwise stated all methods return either a I<true> or I<false> -value, with I<true> meaning that the operation was a success. When a method -states that it returns a value, failure will be returned as I<undef> or an -empty list. - -=over 4 - -=item article ( [ MSGID|MSGNUM ], [FH] ) - -Retrieve the header, a blank line, then the body (text) of the -specified article. - -If C<FH> is specified then it is expected to be a valid filehandle -and the result will be printed to it, on success a true value will be -returned. If C<FH> is not specified then the return value, on success, -will be a reference to an array containing the article requested, each -entry in the array will contain one line of the article. - -If no arguments are passed then the current article in the currently -selected newsgroup is fetched. - -C<MSGNUM> is a numeric id of an article in the current newsgroup, and -will change the current article pointer. C<MSGID> is the message id of -an article as shown in that article's header. It is anticipated that the -client will obtain the C<MSGID> from a list provided by the C<newnews> -command, from references contained within another article, or from the -message-id provided in the response to some other commands. - -If there is an error then C<undef> will be returned. - -=item body ( [ MSGID|MSGNUM ], [FH] ) - -Like C<article> but only fetches the body of the article. - -=item head ( [ MSGID|MSGNUM ], [FH] ) - -Like C<article> but only fetches the headers for the article. - -=item articlefh ( [ MSGID|MSGNUM ] ) - -=item bodyfh ( [ MSGID|MSGNUM ] ) - -=item headfh ( [ MSGID|MSGNUM ] ) - -These are similar to article(), body() and head(), but rather than -returning the requested data directly, they return a tied filehandle -from which to read the article. - -=item nntpstat ( [ MSGID|MSGNUM ] ) - -The C<nntpstat> command is similar to the C<article> command except that no -text is returned. When selecting by message number within a group, -the C<nntpstat> command serves to set the "current article pointer" without -sending text. - -Using the C<nntpstat> command to -select by message-id is valid but of questionable value, since a -selection by message-id does B<not> alter the "current article pointer". - -Returns the message-id of the "current article". - -=item group ( [ GROUP ] ) - -Set and/or get the current group. If C<GROUP> is not given then information -is returned on the current group. - -In a scalar context it returns the group name. - -In an array context the return value is a list containing, the number -of articles in the group, the number of the first article, the number -of the last article and the group name. - -=item ihave ( MSGID [, MESSAGE ]) - -The C<ihave> command informs the server that the client has an article -whose id is C<MSGID>. If the server desires a copy of that -article, and C<MESSAGE> has been given the it will be sent. - -Returns I<true> if the server desires the article and C<MESSAGE> was -successfully sent,if specified. - -If C<MESSAGE> is not specified then the message must be sent using the -C<datasend> and C<dataend> methods from L<Net::Cmd> - -C<MESSAGE> can be either an array of lines or a reference to an array. - -=item last () - -Set the "current article pointer" to the previous article in the current -newsgroup. - -Returns the message-id of the article. - -=item date () - -Returns the date on the remote server. This date will be in a UNIX time -format (seconds since 1970) - -=item postok () - -C<postok> will return I<true> if the servers initial response indicated -that it will allow posting. - -=item authinfo ( USER, PASS ) - -Authenticates to the server (using AUTHINFO USER / AUTHINFO PASS) -using the supplied username and password. Please note that the -password is sent in clear text to the server. This command should not -be used with valuable passwords unless the connection to the server is -somehow protected. - -=item list () - -Obtain information about all the active newsgroups. The results is a reference -to a hash where the key is a group name and each value is a reference to an -array. The elements in this array are:- the last article number in the group, -the first article number in the group and any information flags about the group. - -=item newgroups ( SINCE [, DISTRIBUTIONS ]) - -C<SINCE> is a time value and C<DISTRIBUTIONS> is either a distribution -pattern or a reference to a list of distribution patterns. -The result is the same as C<list>, but the -groups return will be limited to those created after C<SINCE> and, if -specified, in one of the distribution areas in C<DISTRIBUTIONS>. - -=item newnews ( SINCE [, GROUPS [, DISTRIBUTIONS ]]) - -C<SINCE> is a time value. C<GROUPS> is either a group pattern or a reference -to a list of group patterns. C<DISTRIBUTIONS> is either a distribution -pattern or a reference to a list of distribution patterns. - -Returns a reference to a list which contains the message-ids of all news posted -after C<SINCE>, that are in a groups which matched C<GROUPS> and a -distribution which matches C<DISTRIBUTIONS>. - -=item next () - -Set the "current article pointer" to the next article in the current -newsgroup. - -Returns the message-id of the article. - -=item post ( [ MESSAGE ] ) - -Post a new article to the news server. If C<MESSAGE> is specified and posting -is allowed then the message will be sent. - -If C<MESSAGE> is not specified then the message must be sent using the -C<datasend> and C<dataend> methods from L<Net::Cmd> - -C<MESSAGE> can be either an array of lines or a reference to an array. - -The message, either sent via C<datasend> or as the C<MESSAGE> -parameter, must be in the format as described by RFC822 and must -contain From:, Newsgroups: and Subject: headers. - -=item postfh () - -Post a new article to the news server using a tied filehandle. If -posting is allowed, this method will return a tied filehandle that you -can print() the contents of the article to be posted. You must -explicitly close() the filehandle when you are finished posting the -article, and the return value from the close() call will indicate -whether the message was successfully posted. - -=item slave () - -Tell the remote server that I am not a user client, but probably another -news server. - -=item quit () - -Quit the remote server and close the socket connection. - -=back - -=head2 Extension methods - -These methods use commands that are not part of the RFC977 documentation. Some -servers may not support all of them. - -=over 4 - -=item newsgroups ( [ PATTERN ] ) - -Returns a reference to a hash where the keys are all the group names which -match C<PATTERN>, or all of the groups if no pattern is specified, and -each value contains the description text for the group. - -=item distributions () - -Returns a reference to a hash where the keys are all the possible -distribution names and the values are the distribution descriptions. - -=item subscriptions () - -Returns a reference to a list which contains a list of groups which -are recommended for a new user to subscribe to. - -=item overview_fmt () - -Returns a reference to an array which contain the names of the fields returned -by C<xover>. - -=item active_times () - -Returns a reference to a hash where the keys are the group names and each -value is a reference to an array containing the time the groups was created -and an identifier, possibly an Email address, of the creator. - -=item active ( [ PATTERN ] ) - -Similar to C<list> but only active groups that match the pattern are returned. -C<PATTERN> can be a group pattern. - -=item xgtitle ( PATTERN ) - -Returns a reference to a hash where the keys are all the group names which -match C<PATTERN> and each value is the description text for the group. - -=item xhdr ( HEADER, MESSAGE-SPEC ) - -Obtain the header field C<HEADER> for all the messages specified. - -The return value will be a reference -to a hash where the keys are the message numbers and each value contains -the text of the requested header for that message. - -=item xover ( MESSAGE-SPEC ) - -The return value will be a reference -to a hash where the keys are the message numbers and each value contains -a reference to an array which contains the overview fields for that -message. - -The names of the fields can be obtained by calling C<overview_fmt>. - -=item xpath ( MESSAGE-ID ) - -Returns the path name to the file on the server which contains the specified -message. - -=item xpat ( HEADER, PATTERN, MESSAGE-SPEC) - -The result is the same as C<xhdr> except the is will be restricted to -headers where the text of the header matches C<PATTERN> - -=item xrover - -The XROVER command returns reference information for the article(s) -specified. - -Returns a reference to a HASH where the keys are the message numbers and the -values are the References: lines from the articles - -=item listgroup ( [ GROUP ] ) - -Returns a reference to a list of all the active messages in C<GROUP>, or -the current group if C<GROUP> is not specified. - -=item reader - -Tell the server that you are a reader and not another server. - -This is required by some servers. For example if you are connecting to -an INN server and you have transfer permission your connection will -be connected to the transfer daemon, not the NNTP daemon. Issuing -this command will cause the transfer daemon to hand over control -to the NNTP daemon. - -Some servers do not understand this command, but issuing it and ignoring -the response is harmless. - -=back - -=head1 UNSUPPORTED - -The following NNTP command are unsupported by the package, and there are -no plans to do so. - - AUTHINFO GENERIC - XTHREAD - XSEARCH - XINDEX - -=head1 DEFINITIONS - -=over 4 - -=item MESSAGE-SPEC - -C<MESSAGE-SPEC> is either a single message-id, a single message number, or -a reference to a list of two message numbers. - -If C<MESSAGE-SPEC> is a reference to a list of two message numbers and the -second number in a range is less than or equal to the first then the range -represents all messages in the group after the first message number. - -B<NOTE> For compatibility reasons only with earlier versions of Net::NNTP -a message spec can be passed as a list of two numbers, this is deprecated -and a reference to the list should now be passed - -=item PATTERN - -The C<NNTP> protocol uses the C<WILDMAT> format for patterns. -The WILDMAT format was first developed by Rich Salz based on -the format used in the UNIX "find" command to articulate -file names. It was developed to provide a uniform mechanism -for matching patterns in the same manner that the UNIX shell -matches filenames. - -Patterns are implicitly anchored at the -beginning and end of each string when testing for a match. - -There are five pattern matching operations other than a strict -one-to-one match between the pattern and the source to be -checked for a match. - -The first is an asterisk C<*> to match any sequence of zero or more -characters. - -The second is a question mark C<?> to match any single character. The -third specifies a specific set of characters. - -The set is specified as a list of characters, or as a range of characters -where the beginning and end of the range are separated by a minus (or dash) -character, or as any combination of lists and ranges. The dash can -also be included in the set as a character it if is the beginning -or end of the set. This set is enclosed in square brackets. The -close square bracket C<]> may be used in a set if it is the first -character in the set. - -The fourth operation is the same as the -logical not of the third operation and is specified the same -way as the third with the addition of a caret character C<^> at -the beginning of the test string just inside the open square -bracket. - -The final operation uses the backslash character to -invalidate the special meaning of an open square bracket C<[>, -the asterisk, backslash or the question mark. Two backslashes in -sequence will result in the evaluation of the backslash as a -character with no special meaning. - -=over 4 - -=item Examples - -=item C<[^]-]> - -matches any single character other than a close square -bracket or a minus sign/dash. - -=item C<*bdc> - -matches any string that ends with the string "bdc" -including the string "bdc" (without quotes). - -=item C<[0-9a-zA-Z]> - -matches any single printable alphanumeric ASCII character. - -=item C<a??d> - -matches any four character string which begins -with a and ends with d. - -=back - -=back - -=head1 SEE ALSO - -L<Net::Cmd> - -=head1 AUTHOR - -Graham Barr <gbarr@pobox.com> - -=head1 COPYRIGHT - -Copyright (c) 1995-1997 Graham Barr. All rights reserved. -This program is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/Master/tlpkg/tlperl/lib/Net/Netrc.pm b/Master/tlpkg/tlperl/lib/Net/Netrc.pm deleted file mode 100755 index 28c826b38cd..00000000000 --- a/Master/tlpkg/tlperl/lib/Net/Netrc.pm +++ /dev/null @@ -1,325 +0,0 @@ -# Net::Netrc.pm -# -# Copyright (c) 1995-1998 Graham Barr <gbarr@pobox.com>. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package Net::Netrc; - -use Carp; -use strict; -use FileHandle; -use vars qw($VERSION); - -$VERSION = "2.12"; - -my %netrc = (); - - -sub _readrc { - my $host = shift; - my ($home, $file); - - if ($^O eq "MacOS") { - $home = $ENV{HOME} || `pwd`; - chomp($home); - $file = ($home =~ /:$/ ? $home . "netrc" : $home . ":netrc"); - } - else { - - # Some OS's don't have `getpwuid', so we default to $ENV{HOME} - $home = eval { (getpwuid($>))[7] } || $ENV{HOME}; - $home ||= $ENV{HOMEDRIVE} . ($ENV{HOMEPATH} || '') if defined $ENV{HOMEDRIVE}; - $file = $home . "/.netrc"; - } - - my ($login, $pass, $acct) = (undef, undef, undef); - my $fh; - local $_; - - $netrc{default} = undef; - - # OS/2 and Win32 do not handle stat in a way compatable with this check :-( - unless ($^O eq 'os2' - || $^O eq 'MSWin32' - || $^O eq 'MacOS' - || $^O =~ /^cygwin/) - { - my @stat = stat($file); - - if (@stat) { - if ($stat[2] & 077) { - carp "Bad permissions: $file"; - return; - } - if ($stat[4] != $<) { - carp "Not owner: $file"; - return; - } - } - } - - if ($fh = FileHandle->new($file, "r")) { - my ($mach, $macdef, $tok, @tok) = (0, 0); - - while (<$fh>) { - undef $macdef if /\A\n\Z/; - - if ($macdef) { - push(@$macdef, $_); - next; - } - - s/^\s*//; - chomp; - - while (length && s/^("((?:[^"]+|\\.)*)"|((?:[^\\\s]+|\\.)*))\s*//) { - (my $tok = $+) =~ s/\\(.)/$1/g; - push(@tok, $tok); - } - - TOKEN: - while (@tok) { - if ($tok[0] eq "default") { - shift(@tok); - $mach = bless {}; - $netrc{default} = [$mach]; - - next TOKEN; - } - - last TOKEN - unless @tok > 1; - - $tok = shift(@tok); - - if ($tok eq "machine") { - my $host = shift @tok; - $mach = bless {machine => $host}; - - $netrc{$host} = [] - unless exists($netrc{$host}); - push(@{$netrc{$host}}, $mach); - } - elsif ($tok =~ /^(login|password|account)$/) { - next TOKEN unless $mach; - my $value = shift @tok; - - # Following line added by rmerrell to remove '/' escape char in .netrc - $value =~ s/\/\\/\\/g; - $mach->{$1} = $value; - } - elsif ($tok eq "macdef") { - next TOKEN unless $mach; - my $value = shift @tok; - $mach->{macdef} = {} - unless exists $mach->{macdef}; - $macdef = $mach->{machdef}{$value} = []; - } - } - } - $fh->close(); - } -} - - -sub lookup { - my ($pkg, $mach, $login) = @_; - - _readrc() - unless exists $netrc{default}; - - $mach ||= 'default'; - undef $login - if $mach eq 'default'; - - if (exists $netrc{$mach}) { - if (defined $login) { - my $m; - foreach $m (@{$netrc{$mach}}) { - return $m - if (exists $m->{login} && $m->{login} eq $login); - } - return undef; - } - return $netrc{$mach}->[0]; - } - - return $netrc{default}->[0] - if defined $netrc{default}; - - return undef; -} - - -sub login { - my $me = shift; - - exists $me->{login} - ? $me->{login} - : undef; -} - - -sub account { - my $me = shift; - - exists $me->{account} - ? $me->{account} - : undef; -} - - -sub password { - my $me = shift; - - exists $me->{password} - ? $me->{password} - : undef; -} - - -sub lpa { - my $me = shift; - ($me->login, $me->password, $me->account); -} - -1; - -__END__ - -=head1 NAME - -Net::Netrc - OO interface to users netrc file - -=head1 SYNOPSIS - - use Net::Netrc; - - $mach = Net::Netrc->lookup('some.machine'); - $login = $mach->login; - ($login, $password, $account) = $mach->lpa; - -=head1 DESCRIPTION - -C<Net::Netrc> is a class implementing a simple interface to the .netrc file -used as by the ftp program. - -C<Net::Netrc> also implements security checks just like the ftp program, -these checks are, first that the .netrc file must be owned by the user and -second the ownership permissions should be such that only the owner has -read and write access. If these conditions are not met then a warning is -output and the .netrc file is not read. - -=head1 THE .netrc FILE - -The .netrc file contains login and initialization information used by the -auto-login process. It resides in the user's home directory. The following -tokens are recognized; they may be separated by spaces, tabs, or new-lines: - -=over 4 - -=item machine name - -Identify a remote machine name. The auto-login process searches -the .netrc file for a machine token that matches the remote machine -specified. Once a match is made, the subsequent .netrc tokens -are processed, stopping when the end of file is reached or an- -other machine or a default token is encountered. - -=item default - -This is the same as machine name except that default matches -any name. There can be only one default token, and it must be -after all machine tokens. This is normally used as: - - default login anonymous password user@site - -thereby giving the user automatic anonymous login to machines -not specified in .netrc. - -=item login name - -Identify a user on the remote machine. If this token is present, -the auto-login process will initiate a login using the -specified name. - -=item password string - -Supply a password. If this token is present, the auto-login -process will supply the specified string if the remote server -requires a password as part of the login process. - -=item account string - -Supply an additional account password. If this token is present, -the auto-login process will supply the specified string -if the remote server requires an additional account password. - -=item macdef name - -Define a macro. C<Net::Netrc> only parses this field to be compatible -with I<ftp>. - -=back - -=head1 CONSTRUCTOR - -The constructor for a C<Net::Netrc> object is not called new as it does not -really create a new object. But instead is called C<lookup> as this is -essentially what it does. - -=over 4 - -=item lookup ( MACHINE [, LOGIN ]) - -Lookup and return a reference to the entry for C<MACHINE>. If C<LOGIN> is given -then the entry returned will have the given login. If C<LOGIN> is not given then -the first entry in the .netrc file for C<MACHINE> will be returned. - -If a matching entry cannot be found, and a default entry exists, then a -reference to the default entry is returned. - -If there is no matching entry found and there is no default defined, or -no .netrc file is found, then C<undef> is returned. - -=back - -=head1 METHODS - -=over 4 - -=item login () - -Return the login id for the netrc entry - -=item password () - -Return the password for the netrc entry - -=item account () - -Return the account information for the netrc entry - -=item lpa () - -Return a list of login, password and account information fir the netrc entry - -=back - -=head1 AUTHOR - -Graham Barr <gbarr@pobox.com> - -=head1 SEE ALSO - -L<Net::Netrc> -L<Net::Cmd> - -=head1 COPYRIGHT - -Copyright (c) 1995-1998 Graham Barr. All rights reserved. -This program is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/Master/tlpkg/tlperl/lib/Net/POP3.pm b/Master/tlpkg/tlperl/lib/Net/POP3.pm deleted file mode 100755 index 8381c81815e..00000000000 --- a/Master/tlpkg/tlperl/lib/Net/POP3.pm +++ /dev/null @@ -1,742 +0,0 @@ -# Net::POP3.pm -# -# Copyright (c) 1995-2004 Graham Barr <gbarr@pobox.com>. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package Net::POP3; - -use strict; -use IO::Socket; -use vars qw(@ISA $VERSION $debug); -use Net::Cmd; -use Carp; -use Net::Config; - -$VERSION = "2.29"; - -@ISA = qw(Net::Cmd IO::Socket::INET); - - -sub new { - my $self = shift; - my $type = ref($self) || $self; - my ($host, %arg); - if (@_ % 2) { - $host = shift; - %arg = @_; - } - else { - %arg = @_; - $host = delete $arg{Host}; - } - my $hosts = defined $host ? [$host] : $NetConfig{pop3_hosts}; - my $obj; - my @localport = exists $arg{ResvPort} ? (LocalPort => $arg{ResvPort}) : (); - - my $h; - foreach $h (@{$hosts}) { - $obj = $type->SUPER::new( - PeerAddr => ($host = $h), - PeerPort => $arg{Port} || 'pop3(110)', - Proto => 'tcp', - @localport, - Timeout => defined $arg{Timeout} - ? $arg{Timeout} - : 120 - ) - and last; - } - - return undef - unless defined $obj; - - ${*$obj}{'net_pop3_host'} = $host; - - $obj->autoflush(1); - $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef); - - unless ($obj->response() == CMD_OK) { - $obj->close(); - return undef; - } - - ${*$obj}{'net_pop3_banner'} = $obj->message; - - $obj; -} - - -sub host { - my $me = shift; - ${*$me}{'net_pop3_host'}; -} - -## -## We don't want people sending me their passwords when they report problems -## now do we :-) -## - - -sub debug_text { $_[2] =~ /^(pass|rpop)/i ? "$1 ....\n" : $_[2]; } - - -sub login { - @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->login( USER, PASS )'; - my ($me, $user, $pass) = @_; - - if (@_ <= 2) { - ($user, $pass) = $me->_lookup_credentials($user); - } - - $me->user($user) - and $me->pass($pass); -} - - -sub apop { - @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->apop( USER, PASS )'; - my ($me, $user, $pass) = @_; - my $banner; - my $md; - - if (eval { local $SIG{__DIE__}; require Digest::MD5 }) { - $md = Digest::MD5->new(); - } - elsif (eval { local $SIG{__DIE__}; require MD5 }) { - $md = MD5->new(); - } - else { - carp "You need to install Digest::MD5 or MD5 to use the APOP command"; - return undef; - } - - return undef - unless ($banner = (${*$me}{'net_pop3_banner'} =~ /(<.*>)/)[0]); - - if (@_ <= 2) { - ($user, $pass) = $me->_lookup_credentials($user); - } - - $md->add($banner, $pass); - - return undef - unless ($me->_APOP($user, $md->hexdigest)); - - $me->_get_mailbox_count(); -} - - -sub user { - @_ == 2 or croak 'usage: $pop3->user( USER )'; - $_[0]->_USER($_[1]) ? 1 : undef; -} - - -sub pass { - @_ == 2 or croak 'usage: $pop3->pass( PASS )'; - - my ($me, $pass) = @_; - - return undef - unless ($me->_PASS($pass)); - - $me->_get_mailbox_count(); -} - - -sub reset { - @_ == 1 or croak 'usage: $obj->reset()'; - - my $me = shift; - - return 0 - unless ($me->_RSET); - - if (defined ${*$me}{'net_pop3_mail'}) { - local $_; - foreach (@{${*$me}{'net_pop3_mail'}}) { - delete $_->{'net_pop3_deleted'}; - } - } -} - - -sub last { - @_ == 1 or croak 'usage: $obj->last()'; - - return undef - unless $_[0]->_LAST && $_[0]->message =~ /(\d+)/; - - return $1; -} - - -sub top { - @_ == 2 || @_ == 3 or croak 'usage: $pop3->top( MSGNUM [, NUMLINES ])'; - my $me = shift; - - return undef - unless $me->_TOP($_[0], $_[1] || 0); - - $me->read_until_dot; -} - - -sub popstat { - @_ == 1 or croak 'usage: $pop3->popstat()'; - my $me = shift; - - return () - unless $me->_STAT && $me->message =~ /(\d+)\D+(\d+)/; - - ($1 || 0, $2 || 0); -} - - -sub list { - @_ == 1 || @_ == 2 or croak 'usage: $pop3->list( [ MSGNUM ] )'; - my $me = shift; - - return undef - unless $me->_LIST(@_); - - if (@_) { - $me->message =~ /\d+\D+(\d+)/; - return $1 || undef; - } - - my $info = $me->read_until_dot - or return undef; - - my %hash = map { (/(\d+)\D+(\d+)/) } @$info; - - return \%hash; -} - - -sub get { - @_ == 2 or @_ == 3 or croak 'usage: $pop3->get( MSGNUM [, FH ])'; - my $me = shift; - - return undef - unless $me->_RETR(shift); - - $me->read_until_dot(@_); -} - - -sub getfh { - @_ == 2 or croak 'usage: $pop3->getfh( MSGNUM )'; - my $me = shift; - - return unless $me->_RETR(shift); - return $me->tied_fh; -} - - -sub delete { - @_ == 2 or croak 'usage: $pop3->delete( MSGNUM )'; - my $me = shift; - return 0 unless $me->_DELE(@_); - ${*$me}{'net_pop3_deleted'} = 1; -} - - -sub uidl { - @_ == 1 || @_ == 2 or croak 'usage: $pop3->uidl( [ MSGNUM ] )'; - my $me = shift; - my $uidl; - - $me->_UIDL(@_) - or return undef; - if (@_) { - $uidl = ($me->message =~ /\d+\s+([\041-\176]+)/)[0]; - } - else { - my $ref = $me->read_until_dot - or return undef; - my $ln; - $uidl = {}; - foreach $ln (@$ref) { - my ($msg, $uid) = $ln =~ /^\s*(\d+)\s+([\041-\176]+)/; - $uidl->{$msg} = $uid; - } - } - return $uidl; -} - - -sub ping { - @_ == 2 or croak 'usage: $pop3->ping( USER )'; - my $me = shift; - - return () unless $me->_PING(@_) && $me->message =~ /(\d+)\D+(\d+)/; - - ($1 || 0, $2 || 0); -} - - -sub _lookup_credentials { - my ($me, $user) = @_; - - require Net::Netrc; - - $user ||= eval { local $SIG{__DIE__}; (getpwuid($>))[0] } - || $ENV{NAME} - || $ENV{USER} - || $ENV{LOGNAME}; - - my $m = Net::Netrc->lookup(${*$me}{'net_pop3_host'}, $user); - $m ||= Net::Netrc->lookup(${*$me}{'net_pop3_host'}); - - my $pass = $m - ? $m->password || "" - : ""; - - ($user, $pass); -} - - -sub _get_mailbox_count { - my ($me) = @_; - my $ret = ${*$me}{'net_pop3_count'} = - ($me->message =~ /(\d+)\s+message/io) ? $1 : ($me->popstat)[0]; - - $ret ? $ret : "0E0"; -} - - -sub _STAT { shift->command('STAT')->response() == CMD_OK } -sub _LIST { shift->command('LIST', @_)->response() == CMD_OK } -sub _RETR { shift->command('RETR', $_[0])->response() == CMD_OK } -sub _DELE { shift->command('DELE', $_[0])->response() == CMD_OK } -sub _NOOP { shift->command('NOOP')->response() == CMD_OK } -sub _RSET { shift->command('RSET')->response() == CMD_OK } -sub _QUIT { shift->command('QUIT')->response() == CMD_OK } -sub _TOP { shift->command('TOP', @_)->response() == CMD_OK } -sub _UIDL { shift->command('UIDL', @_)->response() == CMD_OK } -sub _USER { shift->command('USER', $_[0])->response() == CMD_OK } -sub _PASS { shift->command('PASS', $_[0])->response() == CMD_OK } -sub _APOP { shift->command('APOP', @_)->response() == CMD_OK } -sub _PING { shift->command('PING', $_[0])->response() == CMD_OK } - - -sub _RPOP { shift->command('RPOP', $_[0])->response() == CMD_OK } -sub _LAST { shift->command('LAST')->response() == CMD_OK } - - -sub _CAPA { shift->command('CAPA')->response() == CMD_OK } - - -sub quit { - my $me = shift; - - $me->_QUIT; - $me->close; -} - - -sub DESTROY { - my $me = shift; - - if (defined fileno($me) and ${*$me}{'net_pop3_deleted'}) { - $me->reset; - $me->quit; - } -} - -## -## POP3 has weird responses, so we emulate them to look the same :-) -## - - -sub response { - my $cmd = shift; - my $str = $cmd->getline() or return undef; - my $code = "500"; - - $cmd->debug_print(0, $str) - if ($cmd->debug); - - if ($str =~ s/^\+OK\s*//io) { - $code = "200"; - } - elsif ($str =~ s/^\+\s*//io) { - $code = "300"; - } - else { - $str =~ s/^-ERR\s*//io; - } - - ${*$cmd}{'net_cmd_resp'} = [$str]; - ${*$cmd}{'net_cmd_code'} = $code; - - substr($code, 0, 1); -} - - -sub capa { - my $this = shift; - my ($capa, %capabilities); - - # Fake a capability here - $capabilities{APOP} = '' if ($this->banner() =~ /<.*>/); - - if ($this->_CAPA()) { - $capabilities{CAPA} = 1; - $capa = $this->read_until_dot(); - %capabilities = (%capabilities, map {/^\s*(\S+)\s*(.*)/} @$capa); - } - else { - - # Check AUTH for SASL capabilities - if ($this->command('AUTH')->response() == CMD_OK) { - my $mechanism = $this->read_until_dot(); - $capabilities{SASL} = join " ", map {m/([A-Z0-9_-]+)/} @{$mechanism}; - } - } - - return ${*$this}{'net_pop3e_capabilities'} = \%capabilities; -} - - -sub capabilities { - my $this = shift; - - ${*$this}{'net_pop3e_capabilities'} || $this->capa; -} - - -sub auth { - my ($self, $username, $password) = @_; - - eval { - require MIME::Base64; - require Authen::SASL; - } or $self->set_status(500, ["Need MIME::Base64 and Authen::SASL todo auth"]), return 0; - - my $capa = $self->capa; - my $mechanisms = $capa->{SASL} || 'CRAM-MD5'; - - my $sasl; - - if (ref($username) and UNIVERSAL::isa($username, 'Authen::SASL')) { - $sasl = $username; - my $user_mech = $sasl->mechanism || ''; - my @user_mech = split(/\s+/, $user_mech); - my %user_mech; - @user_mech{@user_mech} = (); - - my @server_mech = split(/\s+/, $mechanisms); - my @mech = @user_mech - ? grep { exists $user_mech{$_} } @server_mech - : @server_mech; - unless (@mech) { - $self->set_status( - 500, - [ 'Client SASL mechanisms (', - join(', ', @user_mech), - ') do not match the SASL mechnism the server announces (', - join(', ', @server_mech), ')', - ] - ); - return 0; - } - - $sasl->mechanism(join(" ", @mech)); - } - else { - die "auth(username, password)" if not length $username; - $sasl = Authen::SASL->new( - mechanism => $mechanisms, - callback => { - user => $username, - pass => $password, - authname => $username, - } - ); - } - - # We should probably allow the user to pass the host, but I don't - # currently know and SASL mechanisms that are used by smtp that need it - my ($hostname) = split /:/, ${*$self}{'net_pop3_host'}; - my $client = eval { $sasl->client_new('pop', $hostname, 0) }; - - unless ($client) { - my $mech = $sasl->mechanism; - $self->set_status( - 500, - [ " Authen::SASL failure: $@", - '(please check if your local Authen::SASL installation', - "supports mechanism '$mech'" - ] - ); - return 0; - } - - my ($token) = $client->client_start - or do { - my $mech = $client->mechanism; - $self->set_status( - 500, - [ ' Authen::SASL failure: $client->client_start ', - "mechanism '$mech' hostname #$hostname#", - $client->error - ] - ); - return 0; - }; - - # We dont support sasl mechanisms that encrypt the socket traffic. - # todo that we would really need to change the ISA hierarchy - # so we dont inherit from IO::Socket, but instead hold it in an attribute - - my @cmd = ("AUTH", $client->mechanism); - my $code; - - push @cmd, MIME::Base64::encode_base64($token, '') - if defined $token and length $token; - - while (($code = $self->command(@cmd)->response()) == CMD_MORE) { - - my ($token) = $client->client_step(MIME::Base64::decode_base64(($self->message)[0])) or do { - $self->set_status( - 500, - [ ' Authen::SASL failure: $client->client_step ', - "mechanism '", $client->mechanism, " hostname #$hostname#, ", - $client->error - ] - ); - return 0; - }; - - @cmd = (MIME::Base64::encode_base64(defined $token ? $token : '', '')); - } - - $code == CMD_OK; -} - - -sub banner { - my $this = shift; - - return ${*$this}{'net_pop3_banner'}; -} - -1; - -__END__ - -=head1 NAME - -Net::POP3 - Post Office Protocol 3 Client class (RFC1939) - -=head1 SYNOPSIS - - use Net::POP3; - - # Constructors - $pop = Net::POP3->new('pop3host'); - $pop = Net::POP3->new('pop3host', Timeout => 60); - - if ($pop->login($username, $password) > 0) { - my $msgnums = $pop->list; # hashref of msgnum => size - foreach my $msgnum (keys %$msgnums) { - my $msg = $pop->get($msgnum); - print @$msg; - $pop->delete($msgnum); - } - } - - $pop->quit; - -=head1 DESCRIPTION - -This module implements a client interface to the POP3 protocol, enabling -a perl5 application to talk to POP3 servers. This documentation assumes -that you are familiar with the POP3 protocol described in RFC1939. - -A new Net::POP3 object must be created with the I<new> method. Once -this has been done, all POP3 commands are accessed via method calls -on the object. - -=head1 CONSTRUCTOR - -=over 4 - -=item new ( [ HOST ] [, OPTIONS ] 0 - -This is the constructor for a new Net::POP3 object. C<HOST> is the -name of the remote host to which an POP3 connection is required. - -C<HOST> is optional. If C<HOST> is not given then it may instead be -passed as the C<Host> option described below. If neither is given then -the C<POP3_Hosts> specified in C<Net::Config> will be used. - -C<OPTIONS> are passed in a hash like fashion, using key and value pairs. -Possible options are: - -B<Host> - POP3 host to connect to. It may be a single scalar, as defined for -the C<PeerAddr> option in L<IO::Socket::INET>, or a reference to -an array with hosts to try in turn. The L</host> method will return the value -which was used to connect to the host. - -B<ResvPort> - If given then the socket for the C<Net::POP3> object -will be bound to the local port given using C<bind> when the socket is -created. - -B<Timeout> - Maximum time, in seconds, to wait for a response from the -POP3 server (default: 120) - -B<Debug> - Enable debugging information - -=back - -=head1 METHODS - -Unless otherwise stated all methods return either a I<true> or I<false> -value, with I<true> meaning that the operation was a success. When a method -states that it returns a value, failure will be returned as I<undef> or an -empty list. - -=over 4 - -=item auth ( USERNAME, PASSWORD ) - -Attempt SASL authentication. - -=item user ( USER ) - -Send the USER command. - -=item pass ( PASS ) - -Send the PASS command. Returns the number of messages in the mailbox. - -=item login ( [ USER [, PASS ]] ) - -Send both the USER and PASS commands. If C<PASS> is not given the -C<Net::POP3> uses C<Net::Netrc> to lookup the password using the host -and username. If the username is not specified then the current user name -will be used. - -Returns the number of messages in the mailbox. However if there are no -messages on the server the string C<"0E0"> will be returned. This is -will give a true value in a boolean context, but zero in a numeric context. - -If there was an error authenticating the user then I<undef> will be returned. - -=item apop ( [ USER [, PASS ]] ) - -Authenticate with the server identifying as C<USER> with password C<PASS>. -Similar to L</login>, but the password is not sent in clear text. - -To use this method you must have the Digest::MD5 or the MD5 module installed, -otherwise this method will return I<undef>. - -=item banner () - -Return the sever's connection banner - -=item capa () - -Return a reference to a hash of the capabilities of the server. APOP -is added as a pseudo capability. Note that I've been unable to -find a list of the standard capability values, and some appear to -be multi-word and some are not. We make an attempt at intelligently -parsing them, but it may not be correct. - -=item capabilities () - -Just like capa, but only uses a cache from the last time we asked -the server, so as to avoid asking more than once. - -=item top ( MSGNUM [, NUMLINES ] ) - -Get the header and the first C<NUMLINES> of the body for the message -C<MSGNUM>. Returns a reference to an array which contains the lines of text -read from the server. - -=item list ( [ MSGNUM ] ) - -If called with an argument the C<list> returns the size of the message -in octets. - -If called without arguments a reference to a hash is returned. The -keys will be the C<MSGNUM>'s of all undeleted messages and the values will -be their size in octets. - -=item get ( MSGNUM [, FH ] ) - -Get the message C<MSGNUM> from the remote mailbox. If C<FH> is not given -then get returns a reference to an array which contains the lines of -text read from the server. If C<FH> is given then the lines returned -from the server are printed to the filehandle C<FH>. - -=item getfh ( MSGNUM ) - -As per get(), but returns a tied filehandle. Reading from this -filehandle returns the requested message. The filehandle will return -EOF at the end of the message and should not be reused. - -=item last () - -Returns the highest C<MSGNUM> of all the messages accessed. - -=item popstat () - -Returns a list of two elements. These are the number of undeleted -elements and the size of the mbox in octets. - -=item ping ( USER ) - -Returns a list of two elements. These are the number of new messages -and the total number of messages for C<USER>. - -=item uidl ( [ MSGNUM ] ) - -Returns a unique identifier for C<MSGNUM> if given. If C<MSGNUM> is not -given C<uidl> returns a reference to a hash where the keys are the -message numbers and the values are the unique identifiers. - -=item delete ( MSGNUM ) - -Mark message C<MSGNUM> to be deleted from the remote mailbox. All messages -that are marked to be deleted will be removed from the remote mailbox -when the server connection closed. - -=item reset () - -Reset the status of the remote POP3 server. This includes resetting the -status of all messages to not be deleted. - -=item quit () - -Quit and close the connection to the remote POP3 server. Any messages marked -as deleted will be deleted from the remote mailbox. - -=back - -=head1 NOTES - -If a C<Net::POP3> object goes out of scope before C<quit> method is called -then the C<reset> method will called before the connection is closed. This -means that any messages marked to be deleted will not be. - -=head1 SEE ALSO - -L<Net::Netrc>, -L<Net::Cmd> - -=head1 AUTHOR - -Graham Barr <gbarr@pobox.com> - -=head1 COPYRIGHT - -Copyright (c) 1995-2003 Graham Barr. All rights reserved. -This program is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/Master/tlpkg/tlperl/lib/Net/Ping.pm b/Master/tlpkg/tlperl/lib/Net/Ping.pm deleted file mode 100755 index e9fff93eeaa..00000000000 --- a/Master/tlpkg/tlperl/lib/Net/Ping.pm +++ /dev/null @@ -1,1777 +0,0 @@ -package Net::Ping; - -require 5.002; -require Exporter; - -use strict; -use vars qw(@ISA @EXPORT $VERSION - $def_timeout $def_proto $def_factor - $max_datasize $pingstring $hires $source_verify $syn_forking); -use Fcntl qw( F_GETFL F_SETFL O_NONBLOCK ); -use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW PF_INET SOL_SOCKET SO_ERROR - inet_aton inet_ntoa sockaddr_in ); -use POSIX qw( ENOTCONN ECONNREFUSED ECONNRESET EINPROGRESS EWOULDBLOCK EAGAIN WNOHANG ); -use FileHandle; -use Carp; - -@ISA = qw(Exporter); -@EXPORT = qw(pingecho); -$VERSION = "2.36"; - -sub SOL_IP { 0; }; -sub IP_TOS { 1; }; - -# Constants - -$def_timeout = 5; # Default timeout to wait for a reply -$def_proto = "tcp"; # Default protocol to use for pinging -$def_factor = 1.2; # Default exponential backoff rate. -$max_datasize = 1024; # Maximum data bytes in a packet -# The data we exchange with the server for the stream protocol -$pingstring = "pingschwingping!\n"; -$source_verify = 1; # Default is to verify source endpoint -$syn_forking = 0; - -if ($^O =~ /Win32/i) { - # Hack to avoid this Win32 spewage: - # Your vendor has not defined POSIX macro ECONNREFUSED - my @pairs = (ECONNREFUSED => 10061, # "Unknown Error" Special Win32 Response? - ENOTCONN => 10057, - ECONNRESET => 10054, - EINPROGRESS => 10036, - EWOULDBLOCK => 10035, - ); - while (my $name = shift @pairs) { - my $value = shift @pairs; - # When defined, these all are non-zero - unless (eval $name) { - no strict 'refs'; - *{$name} = defined prototype \&{$name} ? sub () {$value} : sub {$value}; - } - } -# $syn_forking = 1; # XXX possibly useful in < Win2K ? -}; - -# h2ph "asm/socket.h" -# require "asm/socket.ph"; -sub SO_BINDTODEVICE {25;} - -# Description: The pingecho() subroutine is provided for backward -# compatibility with the original Net::Ping. It accepts a host -# name/IP and an optional timeout in seconds. Create a tcp ping -# object and try pinging the host. The result of the ping is returned. - -sub pingecho -{ - my ($host, # Name or IP number of host to ping - $timeout # Optional timeout in seconds - ) = @_; - my ($p); # A ping object - - $p = Net::Ping->new("tcp", $timeout); - $p->ping($host); # Going out of scope closes the connection -} - -# Description: The new() method creates a new ping object. Optional -# parameters may be specified for the protocol to use, the timeout in -# seconds and the size in bytes of additional data which should be -# included in the packet. -# After the optional parameters are checked, the data is constructed -# and a socket is opened if appropriate. The object is returned. - -sub new -{ - my ($this, - $proto, # Optional protocol to use for pinging - $timeout, # Optional timeout in seconds - $data_size, # Optional additional bytes of data - $device, # Optional device to use - $tos, # Optional ToS to set - ) = @_; - my $class = ref($this) || $this; - my $self = {}; - my ($cnt, # Count through data bytes - $min_datasize # Minimum data bytes required - ); - - bless($self, $class); - - $proto = $def_proto unless $proto; # Determine the protocol - croak('Protocol for ping must be "icmp", "udp", "tcp", "syn", "stream", or "external"') - unless $proto =~ m/^(icmp|udp|tcp|syn|stream|external)$/; - $self->{"proto"} = $proto; - - $timeout = $def_timeout unless $timeout; # Determine the timeout - croak("Default timeout for ping must be greater than 0 seconds") - if $timeout <= 0; - $self->{"timeout"} = $timeout; - - $self->{"device"} = $device; - - $self->{"tos"} = $tos; - - $min_datasize = ($proto eq "udp") ? 1 : 0; # Determine data size - $data_size = $min_datasize unless defined($data_size) && $proto ne "tcp"; - croak("Data for ping must be from $min_datasize to $max_datasize bytes") - if ($data_size < $min_datasize) || ($data_size > $max_datasize); - $data_size-- if $self->{"proto"} eq "udp"; # We provide the first byte - $self->{"data_size"} = $data_size; - - $self->{"data"} = ""; # Construct data bytes - for ($cnt = 0; $cnt < $self->{"data_size"}; $cnt++) - { - $self->{"data"} .= chr($cnt % 256); - } - - $self->{"local_addr"} = undef; # Don't bind by default - $self->{"retrans"} = $def_factor; # Default exponential backoff rate - $self->{"econnrefused"} = undef; # Default Connection refused behavior - - $self->{"seq"} = 0; # For counting packets - if ($self->{"proto"} eq "udp") # Open a socket - { - $self->{"proto_num"} = (getprotobyname('udp'))[2] || - croak("Can't udp protocol by name"); - $self->{"port_num"} = (getservbyname('echo', 'udp'))[2] || - croak("Can't get udp echo port by name"); - $self->{"fh"} = FileHandle->new(); - socket($self->{"fh"}, PF_INET, SOCK_DGRAM, - $self->{"proto_num"}) || - croak("udp socket error - $!"); - if ($self->{'device'}) { - setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'})) - or croak "error binding to device $self->{'device'} $!"; - } - if ($self->{'tos'}) { - setsockopt($self->{"fh"}, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'})) - or croak "error configuring tos to $self->{'tos'} $!"; - } - } - elsif ($self->{"proto"} eq "icmp") - { - croak("icmp ping requires root privilege") if ($> and $^O ne 'VMS' and $^O ne 'cygwin'); - $self->{"proto_num"} = (getprotobyname('icmp'))[2] || - croak("Can't get icmp protocol by name"); - $self->{"pid"} = $$ & 0xffff; # Save lower 16 bits of pid - $self->{"fh"} = FileHandle->new(); - socket($self->{"fh"}, PF_INET, SOCK_RAW, $self->{"proto_num"}) || - croak("icmp socket error - $!"); - if ($self->{'device'}) { - setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'})) - or croak "error binding to device $self->{'device'} $!"; - } - if ($self->{'tos'}) { - setsockopt($self->{"fh"}, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'})) - or croak "error configuring tos to $self->{'tos'} $!"; - } - } - elsif ($self->{"proto"} eq "tcp" || $self->{"proto"} eq "stream") - { - $self->{"proto_num"} = (getprotobyname('tcp'))[2] || - croak("Can't get tcp protocol by name"); - $self->{"port_num"} = (getservbyname('echo', 'tcp'))[2] || - croak("Can't get tcp echo port by name"); - $self->{"fh"} = FileHandle->new(); - } - elsif ($self->{"proto"} eq "syn") - { - $self->{"proto_num"} = (getprotobyname('tcp'))[2] || - croak("Can't get tcp protocol by name"); - $self->{"port_num"} = (getservbyname('echo', 'tcp'))[2] || - croak("Can't get tcp echo port by name"); - if ($syn_forking) { - $self->{"fork_rd"} = FileHandle->new(); - $self->{"fork_wr"} = FileHandle->new(); - pipe($self->{"fork_rd"}, $self->{"fork_wr"}); - $self->{"fh"} = FileHandle->new(); - $self->{"good"} = {}; - $self->{"bad"} = {}; - } else { - $self->{"wbits"} = ""; - $self->{"bad"} = {}; - } - $self->{"syn"} = {}; - $self->{"stop_time"} = 0; - } - elsif ($self->{"proto"} eq "external") - { - # No preliminary work needs to be done. - } - - return($self); -} - -# Description: Set the local IP address from which pings will be sent. -# For ICMP and UDP pings, this calls bind() on the already-opened socket; -# for TCP pings, just saves the address to be used when the socket is -# opened. Returns non-zero if successful; croaks on error. -sub bind -{ - my ($self, - $local_addr # Name or IP number of local interface - ) = @_; - my ($ip # Packed IP number of $local_addr - ); - - croak("Usage: \$p->bind(\$local_addr)") unless @_ == 2; - croak("already bound") if defined($self->{"local_addr"}) && - ($self->{"proto"} eq "udp" || $self->{"proto"} eq "icmp"); - - $ip = inet_aton($local_addr); - croak("nonexistent local address $local_addr") unless defined($ip); - $self->{"local_addr"} = $ip; # Only used if proto is tcp - - if ($self->{"proto"} eq "udp" || $self->{"proto"} eq "icmp") - { - CORE::bind($self->{"fh"}, sockaddr_in(0, $ip)) || - croak("$self->{'proto'} bind error - $!"); - } - elsif (($self->{"proto"} ne "tcp") && ($self->{"proto"} ne "syn")) - { - croak("Unknown protocol \"$self->{proto}\" in bind()"); - } - - return 1; -} - -# Description: A select() wrapper that compensates for platform -# peculiarities. -sub mselect -{ - if ($_[3] > 0 and $^O eq 'MSWin32') { - # On windows, select() doesn't process the message loop, - # but sleep() will, allowing alarm() to interrupt the latter. - # So we chop up the timeout into smaller pieces and interleave - # select() and sleep() calls. - my $t = $_[3]; - my $gran = 0.5; # polling granularity in seconds - my @args = @_; - while (1) { - $gran = $t if $gran > $t; - my $nfound = select($_[0], $_[1], $_[2], $gran); - undef $nfound if $nfound == -1; - $t -= $gran; - return $nfound if $nfound or !defined($nfound) or $t <= 0; - - sleep(0); - ($_[0], $_[1], $_[2]) = @args; - } - } - else { - my $nfound = select($_[0], $_[1], $_[2], $_[3]); - undef $nfound if $nfound == -1; - return $nfound; - } -} - -# Description: Allow UDP source endpoint comparison to be -# skipped for those remote interfaces that do -# not response from the same endpoint. - -sub source_verify -{ - my $self = shift; - $source_verify = 1 unless defined - ($source_verify = ((defined $self) && (ref $self)) ? shift() : $self); -} - -# Description: Set whether or not the connect -# behavior should enforce remote service -# availability as well as reachability. - -sub service_check -{ - my $self = shift; - $self->{"econnrefused"} = 1 unless defined - ($self->{"econnrefused"} = shift()); -} - -sub tcp_service_check -{ - service_check(@_); -} - -# Description: Set exponential backoff for retransmission. -# Should be > 1 to retain exponential properties. -# If set to 0, retransmissions are disabled. - -sub retrans -{ - my $self = shift; - $self->{"retrans"} = shift; -} - -# Description: allows the module to use milliseconds as returned by -# the Time::HiRes module - -$hires = 0; -sub hires -{ - my $self = shift; - $hires = 1 unless defined - ($hires = ((defined $self) && (ref $self)) ? shift() : $self); - require Time::HiRes if $hires; -} - -sub time -{ - return $hires ? Time::HiRes::time() : CORE::time(); -} - -# Description: Sets or clears the O_NONBLOCK flag on a file handle. -sub socket_blocking_mode -{ - my ($self, - $fh, # the file handle whose flags are to be modified - $block) = @_; # if true then set the blocking - # mode (clear O_NONBLOCK), otherwise - # set the non-blocking mode (set O_NONBLOCK) - - my $flags; - if ($^O eq 'MSWin32' || $^O eq 'VMS') { - # FIONBIO enables non-blocking sockets on windows and vms. - # FIONBIO is (0x80000000|(4<<16)|(ord('f')<<8)|126), as per winsock.h, ioctl.h - my $f = 0x8004667e; - my $v = pack("L", $block ? 0 : 1); - ioctl($fh, $f, $v) or croak("ioctl failed: $!"); - return; - } - if ($flags = fcntl($fh, F_GETFL, 0)) { - $flags = $block ? ($flags & ~O_NONBLOCK) : ($flags | O_NONBLOCK); - if (!fcntl($fh, F_SETFL, $flags)) { - croak("fcntl F_SETFL: $!"); - } - } else { - croak("fcntl F_GETFL: $!"); - } -} - -# Description: Ping a host name or IP number with an optional timeout. -# First lookup the host, and return undef if it is not found. Otherwise -# perform the specific ping method based on the protocol. Return the -# result of the ping. - -sub ping -{ - my ($self, - $host, # Name or IP number of host to ping - $timeout, # Seconds after which ping times out - ) = @_; - my ($ip, # Packed IP number of $host - $ret, # The return value - $ping_time, # When ping began - ); - - croak("Usage: \$p->ping(\$host [, \$timeout])") unless @_ == 2 || @_ == 3; - $timeout = $self->{"timeout"} unless $timeout; - croak("Timeout must be greater than 0 seconds") if $timeout <= 0; - - $ip = inet_aton($host); - return () unless defined($ip); # Does host exist? - - # Dispatch to the appropriate routine. - $ping_time = &time(); - if ($self->{"proto"} eq "external") { - $ret = $self->ping_external($ip, $timeout); - } - elsif ($self->{"proto"} eq "udp") { - $ret = $self->ping_udp($ip, $timeout); - } - elsif ($self->{"proto"} eq "icmp") { - $ret = $self->ping_icmp($ip, $timeout); - } - elsif ($self->{"proto"} eq "tcp") { - $ret = $self->ping_tcp($ip, $timeout); - } - elsif ($self->{"proto"} eq "stream") { - $ret = $self->ping_stream($ip, $timeout); - } - elsif ($self->{"proto"} eq "syn") { - $ret = $self->ping_syn($host, $ip, $ping_time, $ping_time+$timeout); - } else { - croak("Unknown protocol \"$self->{proto}\" in ping()"); - } - - return wantarray ? ($ret, &time() - $ping_time, inet_ntoa($ip)) : $ret; -} - -# Uses Net::Ping::External to do an external ping. -sub ping_external { - my ($self, - $ip, # Packed IP number of the host - $timeout # Seconds after which ping times out - ) = @_; - - eval { require Net::Ping::External; } - or croak('Protocol "external" not supported on your system: Net::Ping::External not found'); - return Net::Ping::External::ping(ip => $ip, timeout => $timeout); -} - -use constant ICMP_ECHOREPLY => 0; # ICMP packet types -use constant ICMP_UNREACHABLE => 3; # ICMP packet types -use constant ICMP_ECHO => 8; -use constant ICMP_STRUCT => "C2 n3 A"; # Structure of a minimal ICMP packet -use constant SUBCODE => 0; # No ICMP subcode for ECHO and ECHOREPLY -use constant ICMP_FLAGS => 0; # No special flags for send or recv -use constant ICMP_PORT => 0; # No port with ICMP - -sub ping_icmp -{ - my ($self, - $ip, # Packed IP number of the host - $timeout # Seconds after which ping times out - ) = @_; - - my ($saddr, # sockaddr_in with port and ip - $checksum, # Checksum of ICMP packet - $msg, # ICMP packet to send - $len_msg, # Length of $msg - $rbits, # Read bits, filehandles for reading - $nfound, # Number of ready filehandles found - $finish_time, # Time ping should be finished - $done, # set to 1 when we are done - $ret, # Return value - $recv_msg, # Received message including IP header - $from_saddr, # sockaddr_in of sender - $from_port, # Port packet was sent from - $from_ip, # Packed IP of sender - $from_type, # ICMP type - $from_subcode, # ICMP subcode - $from_chk, # ICMP packet checksum - $from_pid, # ICMP packet id - $from_seq, # ICMP packet sequence - $from_msg # ICMP message - ); - - $self->{"seq"} = ($self->{"seq"} + 1) % 65536; # Increment sequence - $checksum = 0; # No checksum for starters - $msg = pack(ICMP_STRUCT . $self->{"data_size"}, ICMP_ECHO, SUBCODE, - $checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"}); - $checksum = Net::Ping->checksum($msg); - $msg = pack(ICMP_STRUCT . $self->{"data_size"}, ICMP_ECHO, SUBCODE, - $checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"}); - $len_msg = length($msg); - $saddr = sockaddr_in(ICMP_PORT, $ip); - $self->{"from_ip"} = undef; - $self->{"from_type"} = undef; - $self->{"from_subcode"} = undef; - send($self->{"fh"}, $msg, ICMP_FLAGS, $saddr); # Send the message - - $rbits = ""; - vec($rbits, $self->{"fh"}->fileno(), 1) = 1; - $ret = 0; - $done = 0; - $finish_time = &time() + $timeout; # Must be done by this time - while (!$done && $timeout > 0) # Keep trying if we have time - { - $nfound = mselect((my $rout=$rbits), undef, undef, $timeout); # Wait for packet - $timeout = $finish_time - &time(); # Get remaining time - if (!defined($nfound)) # Hmm, a strange error - { - $ret = undef; - $done = 1; - } - elsif ($nfound) # Got a packet from somewhere - { - $recv_msg = ""; - $from_pid = -1; - $from_seq = -1; - $from_saddr = recv($self->{"fh"}, $recv_msg, 1500, ICMP_FLAGS); - ($from_port, $from_ip) = sockaddr_in($from_saddr); - ($from_type, $from_subcode) = unpack("C2", substr($recv_msg, 20, 2)); - if ($from_type == ICMP_ECHOREPLY) { - ($from_pid, $from_seq) = unpack("n3", substr($recv_msg, 24, 4)) - if length $recv_msg >= 28; - } else { - ($from_pid, $from_seq) = unpack("n3", substr($recv_msg, 52, 4)) - if length $recv_msg >= 56; - } - $self->{"from_ip"} = $from_ip; - $self->{"from_type"} = $from_type; - $self->{"from_subcode"} = $from_subcode; - if (($from_pid == $self->{"pid"}) && # Does the packet check out? - (! $source_verify || (inet_ntoa($from_ip) eq inet_ntoa($ip))) && - ($from_seq == $self->{"seq"})) { - if ($from_type == ICMP_ECHOREPLY) { - $ret = 1; - $done = 1; - } elsif ($from_type == ICMP_UNREACHABLE) { - $done = 1; - } - } - } else { # Oops, timed out - $done = 1; - } - } - return $ret; -} - -sub icmp_result { - my ($self) = @_; - my $ip = $self->{"from_ip"} || ""; - $ip = "\0\0\0\0" unless 4 == length $ip; - return (inet_ntoa($ip),($self->{"from_type"} || 0), ($self->{"from_subcode"} || 0)); -} - -# Description: Do a checksum on the message. Basically sum all of -# the short words and fold the high order bits into the low order bits. - -sub checksum -{ - my ($class, - $msg # The message to checksum - ) = @_; - my ($len_msg, # Length of the message - $num_short, # The number of short words in the message - $short, # One short word - $chk # The checksum - ); - - $len_msg = length($msg); - $num_short = int($len_msg / 2); - $chk = 0; - foreach $short (unpack("n$num_short", $msg)) - { - $chk += $short; - } # Add the odd byte in - $chk += (unpack("C", substr($msg, $len_msg - 1, 1)) << 8) if $len_msg % 2; - $chk = ($chk >> 16) + ($chk & 0xffff); # Fold high into low - return(~(($chk >> 16) + $chk) & 0xffff); # Again and complement -} - - -# Description: Perform a tcp echo ping. Since a tcp connection is -# host specific, we have to open and close each connection here. We -# can't just leave a socket open. Because of the robust nature of -# tcp, it will take a while before it gives up trying to establish a -# connection. Therefore, we use select() on a non-blocking socket to -# check against our timeout. No data bytes are actually -# sent since the successful establishment of a connection is proof -# enough of the reachability of the remote host. Also, tcp is -# expensive and doesn't need our help to add to the overhead. - -sub ping_tcp -{ - my ($self, - $ip, # Packed IP number of the host - $timeout # Seconds after which ping times out - ) = @_; - my ($ret # The return value - ); - - $! = 0; - $ret = $self -> tcp_connect( $ip, $timeout); - if (!$self->{"econnrefused"} && - $! == ECONNREFUSED) { - $ret = 1; # "Connection refused" means reachable - } - $self->{"fh"}->close(); - return $ret; -} - -sub tcp_connect -{ - my ($self, - $ip, # Packed IP number of the host - $timeout # Seconds after which connect times out - ) = @_; - my ($saddr); # Packed IP and Port - - $saddr = sockaddr_in($self->{"port_num"}, $ip); - - my $ret = 0; # Default to unreachable - - my $do_socket = sub { - socket($self->{"fh"}, PF_INET, SOCK_STREAM, $self->{"proto_num"}) || - croak("tcp socket error - $!"); - if (defined $self->{"local_addr"} && - !CORE::bind($self->{"fh"}, sockaddr_in(0, $self->{"local_addr"}))) { - croak("tcp bind error - $!"); - } - if ($self->{'device'}) { - setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'})) - or croak("error binding to device $self->{'device'} $!"); - } - if ($self->{'tos'}) { - setsockopt($self->{"fh"}, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'})) - or croak "error configuring tos to $self->{'tos'} $!"; - } - }; - my $do_connect = sub { - $self->{"ip"} = $ip; - # ECONNREFUSED is 10061 on MSWin32. If we pass it as child error through $?, - # we'll get (10061 & 255) = 77, so we cannot check it in the parent process. - return ($ret = connect($self->{"fh"}, $saddr) || ($! == ECONNREFUSED && !$self->{"econnrefused"})); - }; - my $do_connect_nb = sub { - # Set O_NONBLOCK property on filehandle - $self->socket_blocking_mode($self->{"fh"}, 0); - - # start the connection attempt - if (!connect($self->{"fh"}, $saddr)) { - if ($! == ECONNREFUSED) { - $ret = 1 unless $self->{"econnrefused"}; - } elsif ($! != EINPROGRESS && ($^O ne 'MSWin32' || $! != EWOULDBLOCK)) { - # EINPROGRESS is the expected error code after a connect() - # on a non-blocking socket. But if the kernel immediately - # determined that this connect() will never work, - # Simply respond with "unreachable" status. - # (This can occur on some platforms with errno - # EHOSTUNREACH or ENETUNREACH.) - return 0; - } else { - # Got the expected EINPROGRESS. - # Just wait for connection completion... - my ($wbits, $wout, $wexc); - $wout = $wexc = $wbits = ""; - vec($wbits, $self->{"fh"}->fileno, 1) = 1; - - my $nfound = mselect(undef, - ($wout = $wbits), - ($^O eq 'MSWin32' ? ($wexc = $wbits) : undef), - $timeout); - warn("select: $!") unless defined $nfound; - - if ($nfound && vec($wout, $self->{"fh"}->fileno, 1)) { - # the socket is ready for writing so the connection - # attempt completed. test whether the connection - # attempt was successful or not - - if (getpeername($self->{"fh"})) { - # Connection established to remote host - $ret = 1; - } else { - # TCP ACK will never come from this host - # because there was an error connecting. - - # This should set $! to the correct error. - my $char; - sysread($self->{"fh"},$char,1); - $! = ECONNREFUSED if ($! == EAGAIN && $^O =~ /cygwin/i); - - $ret = 1 if (!$self->{"econnrefused"} - && $! == ECONNREFUSED); - } - } else { - # the connection attempt timed out (or there were connect - # errors on Windows) - if ($^O =~ 'MSWin32') { - # If the connect will fail on a non-blocking socket, - # winsock reports ECONNREFUSED as an exception, and we - # need to fetch the socket-level error code via getsockopt() - # instead of using the thread-level error code that is in $!. - if ($nfound && vec($wexc, $self->{"fh"}->fileno, 1)) { - $! = unpack("i", getsockopt($self->{"fh"}, SOL_SOCKET, - SO_ERROR)); - } - } - } - } - } else { - # Connection established to remote host - $ret = 1; - } - - # Unset O_NONBLOCK property on filehandle - $self->socket_blocking_mode($self->{"fh"}, 1); - $self->{"ip"} = $ip; - return $ret; - }; - - if ($syn_forking) { - # Buggy Winsock API doesn't allow nonblocking connect. - # Hence, if our OS is Windows, we need to create a separate - # process to do the blocking connect attempt. - # XXX Above comments are not true at least for Win2K, where - # nonblocking connect works. - - $| = 1; # Clear buffer prior to fork to prevent duplicate flushing. - $self->{'tcp_chld'} = fork; - if (!$self->{'tcp_chld'}) { - if (!defined $self->{'tcp_chld'}) { - # Fork did not work - warn "Fork error: $!"; - return 0; - } - &{ $do_socket }(); - - # Try a slow blocking connect() call - # and report the status to the parent. - if ( &{ $do_connect }() ) { - $self->{"fh"}->close(); - # No error - exit 0; - } else { - # Pass the error status to the parent - # Make sure that $! <= 255 - exit($! <= 255 ? $! : 255); - } - } - - &{ $do_socket }(); - - my $patience = &time() + $timeout; - - my ($child, $child_errno); - $? = 0; $child_errno = 0; - # Wait up to the timeout - # And clean off the zombie - do { - $child = waitpid($self->{'tcp_chld'}, &WNOHANG()); - $child_errno = $? >> 8; - select(undef, undef, undef, 0.1); - } while &time() < $patience && $child != $self->{'tcp_chld'}; - - if ($child == $self->{'tcp_chld'}) { - if ($self->{"proto"} eq "stream") { - # We need the socket connected here, in parent - # Should be safe to connect because the child finished - # within the timeout - &{ $do_connect }(); - } - # $ret cannot be set by the child process - $ret = !$child_errno; - } else { - # Time must have run out. - # Put that choking client out of its misery - kill "KILL", $self->{'tcp_chld'}; - # Clean off the zombie - waitpid($self->{'tcp_chld'}, 0); - $ret = 0; - } - delete $self->{'tcp_chld'}; - $! = $child_errno; - } else { - # Otherwise don't waste the resources to fork - - &{ $do_socket }(); - - &{ $do_connect_nb }(); - } - - return $ret; -} - -sub DESTROY { - my $self = shift; - if ($self->{'proto'} eq 'tcp' && - $self->{'tcp_chld'}) { - # Put that choking client out of its misery - kill "KILL", $self->{'tcp_chld'}; - # Clean off the zombie - waitpid($self->{'tcp_chld'}, 0); - } -} - -# This writes the given string to the socket and then reads it -# back. It returns 1 on success, 0 on failure. -sub tcp_echo -{ - my $self = shift; - my $timeout = shift; - my $pingstring = shift; - - my $ret = undef; - my $time = &time(); - my $wrstr = $pingstring; - my $rdstr = ""; - - eval <<'EOM'; - do { - my $rin = ""; - vec($rin, $self->{"fh"}->fileno(), 1) = 1; - - my $rout = undef; - if($wrstr) { - $rout = ""; - vec($rout, $self->{"fh"}->fileno(), 1) = 1; - } - - if(mselect($rin, $rout, undef, ($time + $timeout) - &time())) { - - if($rout && vec($rout,$self->{"fh"}->fileno(),1)) { - my $num = syswrite($self->{"fh"}, $wrstr, length $wrstr); - if($num) { - # If it was a partial write, update and try again. - $wrstr = substr($wrstr,$num); - } else { - # There was an error. - $ret = 0; - } - } - - if(vec($rin,$self->{"fh"}->fileno(),1)) { - my $reply; - if(sysread($self->{"fh"},$reply,length($pingstring)-length($rdstr))) { - $rdstr .= $reply; - $ret = 1 if $rdstr eq $pingstring; - } else { - # There was an error. - $ret = 0; - } - } - - } - } until &time() > ($time + $timeout) || defined($ret); -EOM - - return $ret; -} - - - - -# Description: Perform a stream ping. If the tcp connection isn't -# already open, it opens it. It then sends some data and waits for -# a reply. It leaves the stream open on exit. - -sub ping_stream -{ - my ($self, - $ip, # Packed IP number of the host - $timeout # Seconds after which ping times out - ) = @_; - - # Open the stream if it's not already open - if(!defined $self->{"fh"}->fileno()) { - $self->tcp_connect($ip, $timeout) or return 0; - } - - croak "tried to switch servers while stream pinging" - if $self->{"ip"} ne $ip; - - return $self->tcp_echo($timeout, $pingstring); -} - -# Description: opens the stream. You would do this if you want to -# separate the overhead of opening the stream from the first ping. - -sub open -{ - my ($self, - $host, # Host or IP address - $timeout # Seconds after which open times out - ) = @_; - - my ($ip); # Packed IP number of the host - $ip = inet_aton($host); - $timeout = $self->{"timeout"} unless $timeout; - - if($self->{"proto"} eq "stream") { - if(defined($self->{"fh"}->fileno())) { - croak("socket is already open"); - } else { - $self->tcp_connect($ip, $timeout); - } - } -} - - -# Description: Perform a udp echo ping. Construct a message of -# at least the one-byte sequence number and any additional data bytes. -# Send the message out and wait for a message to come back. If we -# get a message, make sure all of its parts match. If they do, we are -# done. Otherwise go back and wait for the message until we run out -# of time. Return the result of our efforts. - -use constant UDP_FLAGS => 0; # Nothing special on send or recv -sub ping_udp -{ - my ($self, - $ip, # Packed IP number of the host - $timeout # Seconds after which ping times out - ) = @_; - - my ($saddr, # sockaddr_in with port and ip - $ret, # The return value - $msg, # Message to be echoed - $finish_time, # Time ping should be finished - $flush, # Whether socket needs to be disconnected - $connect, # Whether socket needs to be connected - $done, # Set to 1 when we are done pinging - $rbits, # Read bits, filehandles for reading - $nfound, # Number of ready filehandles found - $from_saddr, # sockaddr_in of sender - $from_msg, # Characters echoed by $host - $from_port, # Port message was echoed from - $from_ip # Packed IP number of sender - ); - - $saddr = sockaddr_in($self->{"port_num"}, $ip); - $self->{"seq"} = ($self->{"seq"} + 1) % 256; # Increment sequence - $msg = chr($self->{"seq"}) . $self->{"data"}; # Add data if any - - if ($self->{"connected"}) { - if ($self->{"connected"} ne $saddr) { - # Still connected to wrong destination. - # Need to flush out the old one. - $flush = 1; - } - } else { - # Not connected yet. - # Need to connect() before send() - $connect = 1; - } - - # Have to connect() and send() instead of sendto() - # in order to pick up on the ECONNREFUSED setting - # from recv() or double send() errno as utilized in - # the concept by rdw @ perlmonks. See: - # http://perlmonks.thepen.com/42898.html - if ($flush) { - # Need to socket() again to flush the descriptor - # This will disconnect from the old saddr. - socket($self->{"fh"}, PF_INET, SOCK_DGRAM, - $self->{"proto_num"}); - } - # Connect the socket if it isn't already connected - # to the right destination. - if ($flush || $connect) { - connect($self->{"fh"}, $saddr); # Tie destination to socket - $self->{"connected"} = $saddr; - } - send($self->{"fh"}, $msg, UDP_FLAGS); # Send it - - $rbits = ""; - vec($rbits, $self->{"fh"}->fileno(), 1) = 1; - $ret = 0; # Default to unreachable - $done = 0; - my $retrans = 0.01; - my $factor = $self->{"retrans"}; - $finish_time = &time() + $timeout; # Ping needs to be done by then - while (!$done && $timeout > 0) - { - if ($factor > 1) - { - $timeout = $retrans if $timeout > $retrans; - $retrans*= $factor; # Exponential backoff - } - $nfound = mselect((my $rout=$rbits), undef, undef, $timeout); # Wait for response - my $why = $!; - $timeout = $finish_time - &time(); # Get remaining time - - if (!defined($nfound)) # Hmm, a strange error - { - $ret = undef; - $done = 1; - } - elsif ($nfound) # A packet is waiting - { - $from_msg = ""; - $from_saddr = recv($self->{"fh"}, $from_msg, 1500, UDP_FLAGS); - if (!$from_saddr) { - # For example an unreachable host will make recv() fail. - if (!$self->{"econnrefused"} && - ($! == ECONNREFUSED || - $! == ECONNRESET)) { - # "Connection refused" means reachable - # Good, continue - $ret = 1; - } - $done = 1; - } else { - ($from_port, $from_ip) = sockaddr_in($from_saddr); - if (!$source_verify || - (($from_ip eq $ip) && # Does the packet check out? - ($from_port == $self->{"port_num"}) && - ($from_msg eq $msg))) - { - $ret = 1; # It's a winner - $done = 1; - } - } - } - elsif ($timeout <= 0) # Oops, timed out - { - $done = 1; - } - else - { - # Send another in case the last one dropped - if (send($self->{"fh"}, $msg, UDP_FLAGS)) { - # Another send worked? The previous udp packet - # must have gotten lost or is still in transit. - # Hopefully this new packet will arrive safely. - } else { - if (!$self->{"econnrefused"} && - $! == ECONNREFUSED) { - # "Connection refused" means reachable - # Good, continue - $ret = 1; - } - $done = 1; - } - } - } - return $ret; -} - -# Description: Send a TCP SYN packet to host specified. -sub ping_syn -{ - my $self = shift; - my $host = shift; - my $ip = shift; - my $start_time = shift; - my $stop_time = shift; - - if ($syn_forking) { - return $self->ping_syn_fork($host, $ip, $start_time, $stop_time); - } - - my $fh = FileHandle->new(); - my $saddr = sockaddr_in($self->{"port_num"}, $ip); - - # Create TCP socket - if (!socket ($fh, PF_INET, SOCK_STREAM, $self->{"proto_num"})) { - croak("tcp socket error - $!"); - } - - if (defined $self->{"local_addr"} && - !CORE::bind($fh, sockaddr_in(0, $self->{"local_addr"}))) { - croak("tcp bind error - $!"); - } - - if ($self->{'device'}) { - setsockopt($fh, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'})) - or croak("error binding to device $self->{'device'} $!"); - } - if ($self->{'tos'}) { - setsockopt($fh, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'})) - or croak "error configuring tos to $self->{'tos'} $!"; - } - # Set O_NONBLOCK property on filehandle - $self->socket_blocking_mode($fh, 0); - - # Attempt the non-blocking connect - # by just sending the TCP SYN packet - if (connect($fh, $saddr)) { - # Non-blocking, yet still connected? - # Must have connected very quickly, - # or else it wasn't very non-blocking. - #warn "WARNING: Nonblocking connect connected anyway? ($^O)"; - } else { - # Error occurred connecting. - if ($! == EINPROGRESS || ($^O eq 'MSWin32' && $! == EWOULDBLOCK)) { - # The connection is just still in progress. - # This is the expected condition. - } else { - # Just save the error and continue on. - # The ack() can check the status later. - $self->{"bad"}->{$host} = $!; - } - } - - my $entry = [ $host, $ip, $fh, $start_time, $stop_time ]; - $self->{"syn"}->{$fh->fileno} = $entry; - if ($self->{"stop_time"} < $stop_time) { - $self->{"stop_time"} = $stop_time; - } - vec($self->{"wbits"}, $fh->fileno, 1) = 1; - - return 1; -} - -sub ping_syn_fork { - my ($self, $host, $ip, $start_time, $stop_time) = @_; - - # Buggy Winsock API doesn't allow nonblocking connect. - # Hence, if our OS is Windows, we need to create a separate - # process to do the blocking connect attempt. - my $pid = fork(); - if (defined $pid) { - if ($pid) { - # Parent process - my $entry = [ $host, $ip, $pid, $start_time, $stop_time ]; - $self->{"syn"}->{$pid} = $entry; - if ($self->{"stop_time"} < $stop_time) { - $self->{"stop_time"} = $stop_time; - } - } else { - # Child process - my $saddr = sockaddr_in($self->{"port_num"}, $ip); - - # Create TCP socket - if (!socket ($self->{"fh"}, PF_INET, SOCK_STREAM, $self->{"proto_num"})) { - croak("tcp socket error - $!"); - } - - if (defined $self->{"local_addr"} && - !CORE::bind($self->{"fh"}, sockaddr_in(0, $self->{"local_addr"}))) { - croak("tcp bind error - $!"); - } - - if ($self->{'device'}) { - setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'})) - or croak("error binding to device $self->{'device'} $!"); - } - if ($self->{'tos'}) { - setsockopt($self->{"fh"}, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'})) - or croak "error configuring tos to $self->{'tos'} $!"; - } - - $!=0; - # Try to connect (could take a long time) - connect($self->{"fh"}, $saddr); - # Notify parent of connect error status - my $err = $!+0; - my $wrstr = "$$ $err"; - # Force to 16 chars including \n - $wrstr .= " "x(15 - length $wrstr). "\n"; - syswrite($self->{"fork_wr"}, $wrstr, length $wrstr); - exit; - } - } else { - # fork() failed? - die "fork: $!"; - } - return 1; -} - -# Description: Wait for TCP ACK from host specified -# from ping_syn above. If no host is specified, wait -# for TCP ACK from any of the hosts in the SYN queue. -sub ack -{ - my $self = shift; - - if ($self->{"proto"} eq "syn") { - if ($syn_forking) { - my @answer = $self->ack_unfork(shift); - return wantarray ? @answer : $answer[0]; - } - my $wbits = ""; - my $stop_time = 0; - if (my $host = shift) { - # Host passed as arg - if (exists $self->{"bad"}->{$host}) { - if (!$self->{"econnrefused"} && - $self->{"bad"}->{ $host } && - (($! = ECONNREFUSED)>0) && - $self->{"bad"}->{ $host } eq "$!") { - # "Connection refused" means reachable - # Good, continue - } else { - # ECONNREFUSED means no good - return (); - } - } - my $host_fd = undef; - foreach my $fd (keys %{ $self->{"syn"} }) { - my $entry = $self->{"syn"}->{$fd}; - if ($entry->[0] eq $host) { - $host_fd = $fd; - $stop_time = $entry->[4] - || croak("Corrupted SYN entry for [$host]"); - last; - } - } - croak("ack called on [$host] without calling ping first!") - unless defined $host_fd; - vec($wbits, $host_fd, 1) = 1; - } else { - # No $host passed so scan all hosts - # Use the latest stop_time - $stop_time = $self->{"stop_time"}; - # Use all the bits - $wbits = $self->{"wbits"}; - } - - while ($wbits !~ /^\0*\z/) { - my $timeout = $stop_time - &time(); - # Force a minimum of 10 ms timeout. - $timeout = 0.01 if $timeout <= 0.01; - - my $winner_fd = undef; - my $wout = $wbits; - my $fd = 0; - # Do "bad" fds from $wbits first - while ($wout !~ /^\0*\z/) { - if (vec($wout, $fd, 1)) { - # Wipe it from future scanning. - vec($wout, $fd, 1) = 0; - if (my $entry = $self->{"syn"}->{$fd}) { - if ($self->{"bad"}->{ $entry->[0] }) { - $winner_fd = $fd; - last; - } - } - } - $fd++; - } - - if (defined($winner_fd) or my $nfound = mselect(undef, ($wout=$wbits), undef, $timeout)) { - if (defined $winner_fd) { - $fd = $winner_fd; - } else { - # Done waiting for one of the ACKs - $fd = 0; - # Determine which one - while ($wout !~ /^\0*\z/ && - !vec($wout, $fd, 1)) { - $fd++; - } - } - if (my $entry = $self->{"syn"}->{$fd}) { - # Wipe it from future scanning. - delete $self->{"syn"}->{$fd}; - vec($self->{"wbits"}, $fd, 1) = 0; - vec($wbits, $fd, 1) = 0; - if (!$self->{"econnrefused"} && - $self->{"bad"}->{ $entry->[0] } && - (($! = ECONNREFUSED)>0) && - $self->{"bad"}->{ $entry->[0] } eq "$!") { - # "Connection refused" means reachable - # Good, continue - } elsif (getpeername($entry->[2])) { - # Connection established to remote host - # Good, continue - } else { - # TCP ACK will never come from this host - # because there was an error connecting. - - # This should set $! to the correct error. - my $char; - sysread($entry->[2],$char,1); - # Store the excuse why the connection failed. - $self->{"bad"}->{$entry->[0]} = $!; - if (!$self->{"econnrefused"} && - (($! == ECONNREFUSED) || - ($! == EAGAIN && $^O =~ /cygwin/i))) { - # "Connection refused" means reachable - # Good, continue - } else { - # No good, try the next socket... - next; - } - } - # Everything passed okay, return the answer - return wantarray ? - ($entry->[0], &time() - $entry->[3], inet_ntoa($entry->[1])) - : $entry->[0]; - } else { - warn "Corrupted SYN entry: unknown fd [$fd] ready!"; - vec($wbits, $fd, 1) = 0; - vec($self->{"wbits"}, $fd, 1) = 0; - } - } elsif (defined $nfound) { - # Timed out waiting for ACK - foreach my $fd (keys %{ $self->{"syn"} }) { - if (vec($wbits, $fd, 1)) { - my $entry = $self->{"syn"}->{$fd}; - $self->{"bad"}->{$entry->[0]} = "Timed out"; - vec($wbits, $fd, 1) = 0; - vec($self->{"wbits"}, $fd, 1) = 0; - delete $self->{"syn"}->{$fd}; - } - } - } else { - # Weird error occurred with select() - warn("select: $!"); - $self->{"syn"} = {}; - $wbits = ""; - } - } - } - return (); -} - -sub ack_unfork { - my ($self,$host) = @_; - my $stop_time = $self->{"stop_time"}; - if ($host) { - # Host passed as arg - if (my $entry = $self->{"good"}->{$host}) { - delete $self->{"good"}->{$host}; - return ($entry->[0], &time() - $entry->[3], inet_ntoa($entry->[1])); - } - } - - my $rbits = ""; - my $timeout; - - if (keys %{ $self->{"syn"} }) { - # Scan all hosts that are left - vec($rbits, fileno($self->{"fork_rd"}), 1) = 1; - $timeout = $stop_time - &time(); - # Force a minimum of 10 ms timeout. - $timeout = 0.01 if $timeout < 0.01; - } else { - # No hosts left to wait for - $timeout = 0; - } - - if ($timeout > 0) { - my $nfound; - while ( keys %{ $self->{"syn"} } and - $nfound = mselect((my $rout=$rbits), undef, undef, $timeout)) { - # Done waiting for one of the ACKs - if (!sysread($self->{"fork_rd"}, $_, 16)) { - # Socket closed, which means all children are done. - return (); - } - my ($pid, $how) = split; - if ($pid) { - # Flush the zombie - waitpid($pid, 0); - if (my $entry = $self->{"syn"}->{$pid}) { - # Connection attempt to remote host is done - delete $self->{"syn"}->{$pid}; - if (!$how || # If there was no error connecting - (!$self->{"econnrefused"} && - $how == ECONNREFUSED)) { # "Connection refused" means reachable - if ($host && $entry->[0] ne $host) { - # A good connection, but not the host we need. - # Move it from the "syn" hash to the "good" hash. - $self->{"good"}->{$entry->[0]} = $entry; - # And wait for the next winner - next; - } - return ($entry->[0], &time() - $entry->[3], inet_ntoa($entry->[1])); - } - } else { - # Should never happen - die "Unknown ping from pid [$pid]"; - } - } else { - die "Empty response from status socket?"; - } - } - if (defined $nfound) { - # Timed out waiting for ACK status - } else { - # Weird error occurred with select() - warn("select: $!"); - } - } - if (my @synners = keys %{ $self->{"syn"} }) { - # Kill all the synners - kill 9, @synners; - foreach my $pid (@synners) { - # Wait for the deaths to finish - # Then flush off the zombie - waitpid($pid, 0); - } - } - $self->{"syn"} = {}; - return (); -} - -# Description: Tell why the ack() failed -sub nack { - my $self = shift; - my $host = shift || croak('Usage> nack($failed_ack_host)'); - return $self->{"bad"}->{$host} || undef; -} - -# Description: Close the connection. - -sub close -{ - my ($self) = @_; - - if ($self->{"proto"} eq "syn") { - delete $self->{"syn"}; - } elsif ($self->{"proto"} eq "tcp") { - # The connection will already be closed - } else { - $self->{"fh"}->close(); - } -} - -sub port_number { - my $self = shift; - if(@_) { - $self->{port_num} = shift @_; - $self->service_check(1); - } - return $self->{port_num}; -} - - -1; -__END__ - -=head1 NAME - -Net::Ping - check a remote host for reachability - -=head1 SYNOPSIS - - use Net::Ping; - - $p = Net::Ping->new(); - print "$host is alive.\n" if $p->ping($host); - $p->close(); - - $p = Net::Ping->new("icmp"); - $p->bind($my_addr); # Specify source interface of pings - foreach $host (@host_array) - { - print "$host is "; - print "NOT " unless $p->ping($host, 2); - print "reachable.\n"; - sleep(1); - } - $p->close(); - - $p = Net::Ping->new("tcp", 2); - # Try connecting to the www port instead of the echo port - $p->port_number(getservbyname("http", "tcp")); - while ($stop_time > time()) - { - print "$host not reachable ", scalar(localtime()), "\n" - unless $p->ping($host); - sleep(300); - } - undef($p); - - # Like tcp protocol, but with many hosts - $p = Net::Ping->new("syn"); - $p->port_number(getservbyname("http", "tcp")); - foreach $host (@host_array) { - $p->ping($host); - } - while (($host,$rtt,$ip) = $p->ack) { - print "HOST: $host [$ip] ACKed in $rtt seconds.\n"; - } - - # High precision syntax (requires Time::HiRes) - $p = Net::Ping->new(); - $p->hires(); - ($ret, $duration, $ip) = $p->ping($host, 5.5); - printf("$host [ip: $ip] is alive (packet return time: %.2f ms)\n", 1000 * $duration) - if $ret; - $p->close(); - - # For backward compatibility - print "$host is alive.\n" if pingecho($host); - -=head1 DESCRIPTION - -This module contains methods to test the reachability of remote -hosts on a network. A ping object is first created with optional -parameters, a variable number of hosts may be pinged multiple -times and then the connection is closed. - -You may choose one of six different protocols to use for the -ping. The "tcp" protocol is the default. Note that a live remote host -may still fail to be pingable by one or more of these protocols. For -example, www.microsoft.com is generally alive but not "icmp" pingable. - -With the "tcp" protocol the ping() method attempts to establish a -connection to the remote host's echo port. If the connection is -successfully established, the remote host is considered reachable. No -data is actually echoed. This protocol does not require any special -privileges but has higher overhead than the "udp" and "icmp" protocols. - -Specifying the "udp" protocol causes the ping() method to send a udp -packet to the remote host's echo port. If the echoed packet is -received from the remote host and the received packet contains the -same data as the packet that was sent, the remote host is considered -reachable. This protocol does not require any special privileges. -It should be borne in mind that, for a udp ping, a host -will be reported as unreachable if it is not running the -appropriate echo service. For Unix-like systems see L<inetd(8)> -for more information. - -If the "icmp" protocol is specified, the ping() method sends an icmp -echo message to the remote host, which is what the UNIX ping program -does. If the echoed message is received from the remote host and -the echoed information is correct, the remote host is considered -reachable. Specifying the "icmp" protocol requires that the program -be run as root or that the program be setuid to root. - -If the "external" protocol is specified, the ping() method attempts to -use the C<Net::Ping::External> module to ping the remote host. -C<Net::Ping::External> interfaces with your system's default C<ping> -utility to perform the ping, and generally produces relatively -accurate results. If C<Net::Ping::External> if not installed on your -system, specifying the "external" protocol will result in an error. - -If the "syn" protocol is specified, the ping() method will only -send a TCP SYN packet to the remote host then immediately return. -If the syn packet was sent successfully, it will return a true value, -otherwise it will return false. NOTE: Unlike the other protocols, -the return value does NOT determine if the remote host is alive or -not since the full TCP three-way handshake may not have completed -yet. The remote host is only considered reachable if it receives -a TCP ACK within the timeout specified. To begin waiting for the -ACK packets, use the ack() method as explained below. Use the -"syn" protocol instead the "tcp" protocol to determine reachability -of multiple destinations simultaneously by sending parallel TCP -SYN packets. It will not block while testing each remote host. -demo/fping is provided in this distribution to demonstrate the -"syn" protocol as an example. -This protocol does not require any special privileges. - -=head2 Functions - -=over 4 - -=item Net::Ping->new([$proto [, $def_timeout [, $bytes [, $device [, $tos ]]]]]); - -Create a new ping object. All of the parameters are optional. $proto -specifies the protocol to use when doing a ping. The current choices -are "tcp", "udp", "icmp", "stream", "syn", or "external". -The default is "tcp". - -If a default timeout ($def_timeout) in seconds is provided, it is used -when a timeout is not given to the ping() method (below). The timeout -must be greater than 0 and the default, if not specified, is 5 seconds. - -If the number of data bytes ($bytes) is given, that many data bytes -are included in the ping packet sent to the remote host. The number of -data bytes is ignored if the protocol is "tcp". The minimum (and -default) number of data bytes is 1 if the protocol is "udp" and 0 -otherwise. The maximum number of data bytes that can be specified is -1024. - -If $device is given, this device is used to bind the source endpoint -before sending the ping packet. I believe this only works with -superuser privileges and with udp and icmp protocols at this time. - -If $tos is given, this ToS is configured into the socket. - -=item $p->ping($host [, $timeout]); - -Ping the remote host and wait for a response. $host can be either the -hostname or the IP number of the remote host. The optional timeout -must be greater than 0 seconds and defaults to whatever was specified -when the ping object was created. Returns a success flag. If the -hostname cannot be found or there is a problem with the IP number, the -success flag returned will be undef. Otherwise, the success flag will -be 1 if the host is reachable and 0 if it is not. For most practical -purposes, undef and 0 and can be treated as the same case. In array -context, the elapsed time as well as the string form of the ip the -host resolved to are also returned. The elapsed time value will -be a float, as retuned by the Time::HiRes::time() function, if hires() -has been previously called, otherwise it is returned as an integer. - -=item $p->source_verify( { 0 | 1 } ); - -Allows source endpoint verification to be enabled or disabled. -This is useful for those remote destinations with multiples -interfaces where the response may not originate from the same -endpoint that the original destination endpoint was sent to. -This only affects udp and icmp protocol pings. - -This is enabled by default. - -=item $p->service_check( { 0 | 1 } ); - -Set whether or not the connect behavior should enforce -remote service availability as well as reachability. Normally, -if the remote server reported ECONNREFUSED, it must have been -reachable because of the status packet that it reported. -With this option enabled, the full three-way tcp handshake -must have been established successfully before it will -claim it is reachable. NOTE: It still does nothing more -than connect and disconnect. It does not speak any protocol -(i.e., HTTP or FTP) to ensure the remote server is sane in -any way. The remote server CPU could be grinding to a halt -and unresponsive to any clients connecting, but if the kernel -throws the ACK packet, it is considered alive anyway. To -really determine if the server is responding well would be -application specific and is beyond the scope of Net::Ping. -For udp protocol, enabling this option demands that the -remote server replies with the same udp data that it was sent -as defined by the udp echo service. - -This affects the "udp", "tcp", and "syn" protocols. - -This is disabled by default. - -=item $p->tcp_service_check( { 0 | 1 } ); - -Deprecated method, but does the same as service_check() method. - -=item $p->hires( { 0 | 1 } ); - -Causes this module to use Time::HiRes module, allowing milliseconds -to be returned by subsequent calls to ping(). - -This is disabled by default. - -=item $p->bind($local_addr); - -Sets the source address from which pings will be sent. This must be -the address of one of the interfaces on the local host. $local_addr -may be specified as a hostname or as a text IP address such as -"192.168.1.1". - -If the protocol is set to "tcp", this method may be called any -number of times, and each call to the ping() method (below) will use -the most recent $local_addr. If the protocol is "icmp" or "udp", -then bind() must be called at most once per object, and (if it is -called at all) must be called before the first call to ping() for that -object. - -=item $p->open($host); - -When you are using the "stream" protocol, this call pre-opens the -tcp socket. It's only necessary to do this if you want to -provide a different timeout when creating the connection, or -remove the overhead of establishing the connection from the -first ping. If you don't call C<open()>, the connection is -automatically opened the first time C<ping()> is called. -This call simply does nothing if you are using any protocol other -than stream. - -=item $p->ack( [ $host ] ); - -When using the "syn" protocol, use this method to determine -the reachability of the remote host. This method is meant -to be called up to as many times as ping() was called. Each -call returns the host (as passed to ping()) that came back -with the TCP ACK. The order in which the hosts are returned -may not necessarily be the same order in which they were -SYN queued using the ping() method. If the timeout is -reached before the TCP ACK is received, or if the remote -host is not listening on the port attempted, then the TCP -connection will not be established and ack() will return -undef. In list context, the host, the ack time, and the -dotted ip string will be returned instead of just the host. -If the optional $host argument is specified, the return -value will be pertaining to that host only. -This call simply does nothing if you are using any protocol -other than syn. - -=item $p->nack( $failed_ack_host ); - -The reason that host $failed_ack_host did not receive a -valid ACK. Useful to find out why when ack( $fail_ack_host ) -returns a false value. - -=item $p->close(); - -Close the network connection for this ping object. The network -connection is also closed by "undef $p". The network connection is -automatically closed if the ping object goes out of scope (e.g. $p is -local to a subroutine and you leave the subroutine). - -=item $p->port_number([$port_number]) - -When called with a port number, the port number used to ping is set to -$port_number rather than using the echo port. It also has the effect -of calling C<$p-E<gt>service_check(1)> causing a ping to return a successful -response only if that specific port is accessible. This function returns -the value of the port that C<ping()> will connect to. - -=item pingecho($host [, $timeout]); - -To provide backward compatibility with the previous version of -Net::Ping, a pingecho() subroutine is available with the same -functionality as before. pingecho() uses the tcp protocol. The -return values and parameters are the same as described for the ping() -method. This subroutine is obsolete and may be removed in a future -version of Net::Ping. - -=back - -=head1 NOTES - -There will be less network overhead (and some efficiency in your -program) if you specify either the udp or the icmp protocol. The tcp -protocol will generate 2.5 times or more traffic for each ping than -either udp or icmp. If many hosts are pinged frequently, you may wish -to implement a small wait (e.g. 25ms or more) between each ping to -avoid flooding your network with packets. - -The icmp protocol requires that the program be run as root or that it -be setuid to root. The other protocols do not require special -privileges, but not all network devices implement tcp or udp echo. - -Local hosts should normally respond to pings within milliseconds. -However, on a very congested network it may take up to 3 seconds or -longer to receive an echo packet from the remote host. If the timeout -is set too low under these conditions, it will appear that the remote -host is not reachable (which is almost the truth). - -Reachability doesn't necessarily mean that the remote host is actually -functioning beyond its ability to echo packets. tcp is slightly better -at indicating the health of a system than icmp because it uses more -of the networking stack to respond. - -Because of a lack of anything better, this module uses its own -routines to pack and unpack ICMP packets. It would be better for a -separate module to be written which understands all of the different -kinds of ICMP packets. - -=head1 INSTALL - -The latest source tree is available via cvs: - - cvs -z3 -q -d :pserver:anonymous@cvs.roobik.com.:/usr/local/cvsroot/freeware checkout Net-Ping - cd Net-Ping - -The tarball can be created as follows: - - perl Makefile.PL ; make ; make dist - -The latest Net::Ping release can be found at CPAN: - - $CPAN/modules/by-module/Net/ - -1) Extract the tarball - - gtar -zxvf Net-Ping-xxxx.tar.gz - cd Net-Ping-xxxx - -2) Build: - - make realclean - perl Makefile.PL - make - make test - -3) Install - - make install - -Or install it RPM Style: - - rpm -ta SOURCES/Net-Ping-xxxx.tar.gz - - rpm -ih RPMS/noarch/perl-Net-Ping-xxxx.rpm - -=head1 BUGS - -For a list of known issues, visit: - -https://rt.cpan.org/NoAuth/Bugs.html?Dist=Net-Ping - -To report a new bug, visit: - -https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net-Ping - -=head1 AUTHORS - - Current maintainer: - bbb@cpan.org (Rob Brown) - - External protocol: - colinm@cpan.org (Colin McMillen) - - Stream protocol: - bronson@trestle.com (Scott Bronson) - - Original pingecho(): - karrer@bernina.ethz.ch (Andreas Karrer) - pmarquess@bfsec.bt.co.uk (Paul Marquess) - - Original Net::Ping author: - mose@ns.ccsn.edu (Russell Mosemann) - -=head1 COPYRIGHT - -Copyright (c) 2002-2003, Rob Brown. All rights reserved. - -Copyright (c) 2001, Colin McMillen. All rights reserved. - -This program is free software; you may redistribute it and/or -modify it under the same terms as Perl itself. - -$Id: Ping.pm,v 1.86 2003/06/27 21:31:07 rob Exp $ - -=cut diff --git a/Master/tlpkg/tlperl/lib/Net/SMTP.pm b/Master/tlpkg/tlperl/lib/Net/SMTP.pm deleted file mode 100755 index a28496d6886..00000000000 --- a/Master/tlpkg/tlperl/lib/Net/SMTP.pm +++ /dev/null @@ -1,867 +0,0 @@ -# Net::SMTP.pm -# -# Copyright (c) 1995-2004 Graham Barr <gbarr@pobox.com>. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package Net::SMTP; - -require 5.001; - -use strict; -use vars qw($VERSION @ISA); -use Socket 1.3; -use Carp; -use IO::Socket; -use Net::Cmd; -use Net::Config; - -$VERSION = "2.31"; - -@ISA = qw(Net::Cmd IO::Socket::INET); - - -sub new { - my $self = shift; - my $type = ref($self) || $self; - my ($host, %arg); - if (@_ % 2) { - $host = shift; - %arg = @_; - } - else { - %arg = @_; - $host = delete $arg{Host}; - } - my $hosts = defined $host ? $host : $NetConfig{smtp_hosts}; - my $obj; - - my $h; - foreach $h (@{ref($hosts) ? $hosts : [$hosts]}) { - $obj = $type->SUPER::new( - PeerAddr => ($host = $h), - PeerPort => $arg{Port} || 'smtp(25)', - LocalAddr => $arg{LocalAddr}, - LocalPort => $arg{LocalPort}, - Proto => 'tcp', - Timeout => defined $arg{Timeout} - ? $arg{Timeout} - : 120 - ) - and last; - } - - return undef - unless defined $obj; - - $obj->autoflush(1); - - $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef); - - unless ($obj->response() == CMD_OK) { - $obj->close(); - return undef; - } - - ${*$obj}{'net_smtp_exact_addr'} = $arg{ExactAddresses}; - ${*$obj}{'net_smtp_host'} = $host; - - (${*$obj}{'net_smtp_banner'}) = $obj->message; - (${*$obj}{'net_smtp_domain'}) = $obj->message =~ /\A\s*(\S+)/; - - unless ($obj->hello($arg{Hello} || "")) { - $obj->close(); - return undef; - } - - $obj; -} - - -sub host { - my $me = shift; - ${*$me}{'net_smtp_host'}; -} - -## -## User interface methods -## - - -sub banner { - my $me = shift; - - return ${*$me}{'net_smtp_banner'} || undef; -} - - -sub domain { - my $me = shift; - - return ${*$me}{'net_smtp_domain'} || undef; -} - - -sub etrn { - my $self = shift; - defined($self->supports('ETRN', 500, ["Command unknown: 'ETRN'"])) - && $self->_ETRN(@_); -} - - -sub auth { - my ($self, $username, $password) = @_; - - eval { - require MIME::Base64; - require Authen::SASL; - } or $self->set_status(500, ["Need MIME::Base64 and Authen::SASL todo auth"]), return 0; - - my $mechanisms = $self->supports('AUTH', 500, ["Command unknown: 'AUTH'"]); - return unless defined $mechanisms; - - my $sasl; - - if (ref($username) and UNIVERSAL::isa($username, 'Authen::SASL')) { - $sasl = $username; - $sasl->mechanism($mechanisms); - } - else { - die "auth(username, password)" if not length $username; - $sasl = Authen::SASL->new( - mechanism => $mechanisms, - callback => { - user => $username, - pass => $password, - authname => $username, - } - ); - } - - # We should probably allow the user to pass the host, but I don't - # currently know and SASL mechanisms that are used by smtp that need it - my $client = $sasl->client_new('smtp', ${*$self}{'net_smtp_host'}, 0); - my $str = $client->client_start; - - # We dont support sasl mechanisms that encrypt the socket traffic. - # todo that we would really need to change the ISA hierarchy - # so we dont inherit from IO::Socket, but instead hold it in an attribute - - my @cmd = ("AUTH", $client->mechanism); - my $code; - - push @cmd, MIME::Base64::encode_base64($str, '') - if defined $str and length $str; - - while (($code = $self->command(@cmd)->response()) == CMD_MORE) { - @cmd = ( - MIME::Base64::encode_base64( - $client->client_step(MIME::Base64::decode_base64(($self->message)[0])), '' - ) - ); - } - - $code == CMD_OK; -} - - -sub hello { - my $me = shift; - my $domain = shift || "localhost.localdomain"; - my $ok = $me->_EHLO($domain); - my @msg = $me->message; - - if ($ok) { - my $h = ${*$me}{'net_smtp_esmtp'} = {}; - my $ln; - foreach $ln (@msg) { - $h->{uc $1} = $2 - if $ln =~ /(\w+)\b[= \t]*([^\n]*)/; - } - } - elsif ($me->status == CMD_ERROR) { - @msg = $me->message - if $ok = $me->_HELO($domain); - } - - return undef unless $ok; - - $msg[0] =~ /\A\s*(\S+)/; - return ($1 || " "); -} - - -sub supports { - my $self = shift; - my $cmd = uc shift; - return ${*$self}{'net_smtp_esmtp'}->{$cmd} - if exists ${*$self}{'net_smtp_esmtp'}->{$cmd}; - $self->set_status(@_) - if @_; - return; -} - - -sub _addr { - my $self = shift; - my $addr = shift; - $addr = "" unless defined $addr; - - if (${*$self}{'net_smtp_exact_addr'}) { - return $1 if $addr =~ /^\s*(<.*>)\s*$/s; - } - else { - return $1 if $addr =~ /(<[^>]*>)/; - $addr =~ s/^\s+|\s+$//sg; - } - - "<$addr>"; -} - - -sub mail { - my $me = shift; - my $addr = _addr($me, shift); - my $opts = ""; - - if (@_) { - my %opt = @_; - my ($k, $v); - - if (exists ${*$me}{'net_smtp_esmtp'}) { - my $esmtp = ${*$me}{'net_smtp_esmtp'}; - - if (defined($v = delete $opt{Size})) { - if (exists $esmtp->{SIZE}) { - $opts .= sprintf " SIZE=%d", $v + 0; - } - else { - carp 'Net::SMTP::mail: SIZE option not supported by host'; - } - } - - if (defined($v = delete $opt{Return})) { - if (exists $esmtp->{DSN}) { - $opts .= " RET=" . ((uc($v) eq "FULL") ? "FULL" : "HDRS"); - } - else { - carp 'Net::SMTP::mail: DSN option not supported by host'; - } - } - - if (defined($v = delete $opt{Bits})) { - if ($v eq "8") { - if (exists $esmtp->{'8BITMIME'}) { - $opts .= " BODY=8BITMIME"; - } - else { - carp 'Net::SMTP::mail: 8BITMIME option not supported by host'; - } - } - elsif ($v eq "binary") { - if (exists $esmtp->{'BINARYMIME'} && exists $esmtp->{'CHUNKING'}) { - $opts .= " BODY=BINARYMIME"; - ${*$me}{'net_smtp_chunking'} = 1; - } - else { - carp 'Net::SMTP::mail: BINARYMIME option not supported by host'; - } - } - elsif (exists $esmtp->{'8BITMIME'} or exists $esmtp->{'BINARYMIME'}) { - $opts .= " BODY=7BIT"; - } - else { - carp 'Net::SMTP::mail: 8BITMIME and BINARYMIME options not supported by host'; - } - } - - if (defined($v = delete $opt{Transaction})) { - if (exists $esmtp->{CHECKPOINT}) { - $opts .= " TRANSID=" . _addr($me, $v); - } - else { - carp 'Net::SMTP::mail: CHECKPOINT option not supported by host'; - } - } - - if (defined($v = delete $opt{Envelope})) { - if (exists $esmtp->{DSN}) { - $v =~ s/([^\041-\176]|=|\+)/sprintf "+%02x", ord($1)/sge; - $opts .= " ENVID=$v"; - } - else { - carp 'Net::SMTP::mail: DSN option not supported by host'; - } - } - - if (defined($v = delete $opt{ENVID})) { - - # expected to be in a format as required by RFC 3461, xtext-encoded - if (exists $esmtp->{DSN}) { - $opts .= " ENVID=$v"; - } - else { - carp 'Net::SMTP::mail: DSN option not supported by host'; - } - } - - if (defined($v = delete $opt{AUTH})) { - - # expected to be in a format as required by RFC 2554, - # rfc2821-quoted and xtext-encoded, or <> - if (exists $esmtp->{AUTH}) { - $v = '<>' if !defined($v) || $v eq ''; - $opts .= " AUTH=$v"; - } - else { - carp 'Net::SMTP::mail: AUTH option not supported by host'; - } - } - - if (defined($v = delete $opt{XVERP})) { - if (exists $esmtp->{'XVERP'}) { - $opts .= " XVERP"; - } - else { - carp 'Net::SMTP::mail: XVERP option not supported by host'; - } - } - - carp 'Net::SMTP::recipient: unknown option(s) ' . join(" ", keys %opt) . ' - ignored' - if scalar keys %opt; - } - else { - carp 'Net::SMTP::mail: ESMTP not supported by host - options discarded :-('; - } - } - - $me->_MAIL("FROM:" . $addr . $opts); -} - - -sub send { my $me = shift; $me->_SEND("FROM:" . _addr($me, $_[0])) } -sub send_or_mail { my $me = shift; $me->_SOML("FROM:" . _addr($me, $_[0])) } -sub send_and_mail { my $me = shift; $me->_SAML("FROM:" . _addr($me, $_[0])) } - - -sub reset { - my $me = shift; - - $me->dataend() - if (exists ${*$me}{'net_smtp_lastch'}); - - $me->_RSET(); -} - - -sub recipient { - my $smtp = shift; - my $opts = ""; - my $skip_bad = 0; - - if (@_ && ref($_[-1])) { - my %opt = %{pop(@_)}; - my $v; - - $skip_bad = delete $opt{'SkipBad'}; - - if (exists ${*$smtp}{'net_smtp_esmtp'}) { - my $esmtp = ${*$smtp}{'net_smtp_esmtp'}; - - if (defined($v = delete $opt{Notify})) { - if (exists $esmtp->{DSN}) { - $opts .= " NOTIFY=" . join(",", map { uc $_ } @$v); - } - else { - carp 'Net::SMTP::recipient: DSN option not supported by host'; - } - } - - if (defined($v = delete $opt{ORcpt})) { - if (exists $esmtp->{DSN}) { - $opts .= " ORCPT=" . $v; - } - else { - carp 'Net::SMTP::recipient: DSN option not supported by host'; - } - } - - carp 'Net::SMTP::recipient: unknown option(s) ' . join(" ", keys %opt) . ' - ignored' - if scalar keys %opt; - } - elsif (%opt) { - carp 'Net::SMTP::recipient: ESMTP not supported by host - options discarded :-('; - } - } - - my @ok; - my $addr; - foreach $addr (@_) { - if ($smtp->_RCPT("TO:" . _addr($smtp, $addr) . $opts)) { - push(@ok, $addr) if $skip_bad; - } - elsif (!$skip_bad) { - return 0; - } - } - - return $skip_bad ? @ok : 1; -} - -BEGIN { - *to = \&recipient; - *cc = \&recipient; - *bcc = \&recipient; -} - - -sub data { - my $me = shift; - - if (exists ${*$me}{'net_smtp_chunking'}) { - carp 'Net::SMTP::data: CHUNKING extension in use, must call bdat instead'; - } - else { - my $ok = $me->_DATA() && $me->datasend(@_); - - $ok && @_ - ? $me->dataend - : $ok; - } -} - - -sub bdat { - my $me = shift; - - if (exists ${*$me}{'net_smtp_chunking'}) { - my $data = shift; - - $me->_BDAT(length $data) - && $me->rawdatasend($data) - && $me->response() == CMD_OK; - } - else { - carp 'Net::SMTP::bdat: CHUNKING extension is not in use, call data instead'; - } -} - - -sub bdatlast { - my $me = shift; - - if (exists ${*$me}{'net_smtp_chunking'}) { - my $data = shift; - - $me->_BDAT(length $data, "LAST") - && $me->rawdatasend($data) - && $me->response() == CMD_OK; - } - else { - carp 'Net::SMTP::bdat: CHUNKING extension is not in use, call data instead'; - } -} - - -sub datafh { - my $me = shift; - return unless $me->_DATA(); - return $me->tied_fh; -} - - -sub expand { - my $me = shift; - - $me->_EXPN(@_) - ? ($me->message) - : (); -} - - -sub verify { shift->_VRFY(@_) } - - -sub help { - my $me = shift; - - $me->_HELP(@_) - ? scalar $me->message - : undef; -} - - -sub quit { - my $me = shift; - - $me->_QUIT; - $me->close; -} - - -sub DESTROY { - - # ignore -} - -## -## RFC821 commands -## - - -sub _EHLO { shift->command("EHLO", @_)->response() == CMD_OK } -sub _HELO { shift->command("HELO", @_)->response() == CMD_OK } -sub _MAIL { shift->command("MAIL", @_)->response() == CMD_OK } -sub _RCPT { shift->command("RCPT", @_)->response() == CMD_OK } -sub _SEND { shift->command("SEND", @_)->response() == CMD_OK } -sub _SAML { shift->command("SAML", @_)->response() == CMD_OK } -sub _SOML { shift->command("SOML", @_)->response() == CMD_OK } -sub _VRFY { shift->command("VRFY", @_)->response() == CMD_OK } -sub _EXPN { shift->command("EXPN", @_)->response() == CMD_OK } -sub _HELP { shift->command("HELP", @_)->response() == CMD_OK } -sub _RSET { shift->command("RSET")->response() == CMD_OK } -sub _NOOP { shift->command("NOOP")->response() == CMD_OK } -sub _QUIT { shift->command("QUIT")->response() == CMD_OK } -sub _DATA { shift->command("DATA")->response() == CMD_MORE } -sub _BDAT { shift->command("BDAT", @_) } -sub _TURN { shift->unsupported(@_); } -sub _ETRN { shift->command("ETRN", @_)->response() == CMD_OK } -sub _AUTH { shift->command("AUTH", @_)->response() == CMD_OK } - -1; - -__END__ - -=head1 NAME - -Net::SMTP - Simple Mail Transfer Protocol Client - -=head1 SYNOPSIS - - use Net::SMTP; - - # Constructors - $smtp = Net::SMTP->new('mailhost'); - $smtp = Net::SMTP->new('mailhost', Timeout => 60); - -=head1 DESCRIPTION - -This module implements a client interface to the SMTP and ESMTP -protocol, enabling a perl5 application to talk to SMTP servers. This -documentation assumes that you are familiar with the concepts of the -SMTP protocol described in RFC821. - -A new Net::SMTP object must be created with the I<new> method. Once -this has been done, all SMTP commands are accessed through this object. - -The Net::SMTP class is a subclass of Net::Cmd and IO::Socket::INET. - -=head1 EXAMPLES - -This example prints the mail domain name of the SMTP server known as mailhost: - - #!/usr/local/bin/perl -w - - use Net::SMTP; - - $smtp = Net::SMTP->new('mailhost'); - print $smtp->domain,"\n"; - $smtp->quit; - -This example sends a small message to the postmaster at the SMTP server -known as mailhost: - - #!/usr/local/bin/perl -w - - use Net::SMTP; - - $smtp = Net::SMTP->new('mailhost'); - - $smtp->mail($ENV{USER}); - $smtp->to('postmaster'); - - $smtp->data(); - $smtp->datasend("To: postmaster\n"); - $smtp->datasend("\n"); - $smtp->datasend("A simple test message\n"); - $smtp->dataend(); - - $smtp->quit; - -=head1 CONSTRUCTOR - -=over 4 - -=item new ( [ HOST ] [, OPTIONS ] ) - -This is the constructor for a new Net::SMTP object. C<HOST> is the -name of the remote host to which an SMTP connection is required. - -C<HOST> is optional. If C<HOST> is not given then it may instead be -passed as the C<Host> option described below. If neither is given then -the C<SMTP_Hosts> specified in C<Net::Config> will be used. - -C<OPTIONS> are passed in a hash like fashion, using key and value pairs. -Possible options are: - -B<Hello> - SMTP requires that you identify yourself. This option -specifies a string to pass as your mail domain. If not given localhost.localdomain -will be used. - -B<Host> - SMTP host to connect to. It may be a single scalar, as defined for -the C<PeerAddr> option in L<IO::Socket::INET>, or a reference to -an array with hosts to try in turn. The L</host> method will return the value -which was used to connect to the host. - -B<LocalAddr> and B<LocalPort> - These parameters are passed directly -to IO::Socket to allow binding the socket to a local port. - -B<Timeout> - Maximum time, in seconds, to wait for a response from the -SMTP server (default: 120) - -B<ExactAddresses> - If true the all ADDRESS arguments must be as -defined by C<addr-spec> in RFC2822. If not given, or false, then -Net::SMTP will attempt to extract the address from the value passed. - -B<Debug> - Enable debugging information - - -Example: - - - $smtp = Net::SMTP->new('mailhost', - Hello => 'my.mail.domain', - Timeout => 30, - Debug => 1, - ); - - # the same - $smtp = Net::SMTP->new( - Host => 'mailhost', - Hello => 'my.mail.domain', - Timeout => 30, - Debug => 1, - ); - - # Connect to the default server from Net::config - $smtp = Net::SMTP->new( - Hello => 'my.mail.domain', - Timeout => 30, - ); - -=back - -=head1 METHODS - -Unless otherwise stated all methods return either a I<true> or I<false> -value, with I<true> meaning that the operation was a success. When a method -states that it returns a value, failure will be returned as I<undef> or an -empty list. - -=over 4 - -=item banner () - -Returns the banner message which the server replied with when the -initial connection was made. - -=item domain () - -Returns the domain that the remote SMTP server identified itself as during -connection. - -=item hello ( DOMAIN ) - -Tell the remote server the mail domain which you are in using the EHLO -command (or HELO if EHLO fails). Since this method is invoked -automatically when the Net::SMTP object is constructed the user should -normally not have to call it manually. - -=item host () - -Returns the value used by the constructor, and passed to IO::Socket::INET, -to connect to the host. - -=item etrn ( DOMAIN ) - -Request a queue run for the DOMAIN given. - -=item auth ( USERNAME, PASSWORD ) - -Attempt SASL authentication. - -=item mail ( ADDRESS [, OPTIONS] ) - -=item send ( ADDRESS ) - -=item send_or_mail ( ADDRESS ) - -=item send_and_mail ( ADDRESS ) - -Send the appropriate command to the server MAIL, SEND, SOML or SAML. C<ADDRESS> -is the address of the sender. This initiates the sending of a message. The -method C<recipient> should be called for each address that the message is to -be sent to. - -The C<mail> method can some additional ESMTP OPTIONS which is passed -in hash like fashion, using key and value pairs. Possible options are: - - Size => <bytes> - Return => "FULL" | "HDRS" - Bits => "7" | "8" | "binary" - Transaction => <ADDRESS> - Envelope => <ENVID> # xtext-encodes its argument - ENVID => <ENVID> # similar to Envelope, but expects argument encoded - XVERP => 1 - AUTH => <submitter> # encoded address according to RFC 2554 - -The C<Return> and C<Envelope> parameters are used for DSN (Delivery -Status Notification). - -The submitter address in C<AUTH> option is expected to be in a format as -required by RFC 2554, in an RFC2821-quoted form and xtext-encoded, or <> . - -=item reset () - -Reset the status of the server. This may be called after a message has been -initiated, but before any data has been sent, to cancel the sending of the -message. - -=item recipient ( ADDRESS [, ADDRESS, [...]] [, OPTIONS ] ) - -Notify the server that the current message should be sent to all of the -addresses given. Each address is sent as a separate command to the server. -Should the sending of any address result in a failure then the process is -aborted and a I<false> value is returned. It is up to the user to call -C<reset> if they so desire. - -The C<recipient> method can also pass additional case-sensitive OPTIONS as an -anonymous hash using key and value pairs. Possible options are: - - Notify => ['NEVER'] or ['SUCCESS','FAILURE','DELAY'] (see below) - ORcpt => <ORCPT> - SkipBad => 1 (to ignore bad addresses) - -If C<SkipBad> is true the C<recipient> will not return an error when a bad -address is encountered and it will return an array of addresses that did -succeed. - - $smtp->recipient($recipient1,$recipient2); # Good - $smtp->recipient($recipient1,$recipient2, { SkipBad => 1 }); # Good - $smtp->recipient($recipient1,$recipient2, { Notify => ['FAILURE','DELAY'], SkipBad => 1 }); # Good - @goodrecips=$smtp->recipient(@recipients, { Notify => ['FAILURE'], SkipBad => 1 }); # Good - $smtp->recipient("$recipient,$recipient2"); # BAD - -Notify is used to request Delivery Status Notifications (DSNs), but your -SMTP/ESMTP service may not respect this request depending upon its version and -your site's SMTP configuration. - -Leaving out the Notify option usually defaults an SMTP service to its default -behavior equivalent to ['FAILURE'] notifications only, but again this may be -dependent upon your site's SMTP configuration. - -The NEVER keyword must appear by itself if used within the Notify option and "requests -that a DSN not be returned to the sender under any conditions." - - {Notify => ['NEVER']} - - $smtp->recipient(@recipients, { Notify => ['NEVER'], SkipBad => 1 }); # Good - -You may use any combination of these three values 'SUCCESS','FAILURE','DELAY' in -the anonymous array reference as defined by RFC3461 (see http://rfc.net/rfc3461.html -for more information. Note: quotations in this topic from same.). - -A Notify parameter of 'SUCCESS' or 'FAILURE' "requests that a DSN be issued on -successful delivery or delivery failure, respectively." - -A Notify parameter of 'DELAY' "indicates the sender's willingness to receive -delayed DSNs. Delayed DSNs may be issued if delivery of a message has been -delayed for an unusual amount of time (as determined by the Message Transfer -Agent (MTA) at which the message is delayed), but the final delivery status -(whether successful or failure) cannot be determined. The absence of the DELAY -keyword in a NOTIFY parameter requests that a "delayed" DSN NOT be issued under -any conditions." - - {Notify => ['SUCCESS','FAILURE','DELAY']} - - $smtp->recipient(@recipients, { Notify => ['FAILURE','DELAY'], SkipBad => 1 }); # Good - -ORcpt is also part of the SMTP DSN extension according to RFC3461. -It is used to pass along the original recipient that the mail was first -sent to. The machine that generates a DSN will use this address to inform -the sender, because he can't know if recipients get rewritten by mail servers. -It is expected to be in a format as required by RFC3461, xtext-encoded. - -=item to ( ADDRESS [, ADDRESS [...]] ) - -=item cc ( ADDRESS [, ADDRESS [...]] ) - -=item bcc ( ADDRESS [, ADDRESS [...]] ) - -Synonyms for C<recipient>. - -=item data ( [ DATA ] ) - -Initiate the sending of the data from the current message. - -C<DATA> may be a reference to a list or a list. If specified the contents -of C<DATA> and a termination string C<".\r\n"> is sent to the server. And the -result will be true if the data was accepted. - -If C<DATA> is not specified then the result will indicate that the server -wishes the data to be sent. The data must then be sent using the C<datasend> -and C<dataend> methods described in L<Net::Cmd>. - -=item expand ( ADDRESS ) - -Request the server to expand the given address Returns an array -which contains the text read from the server. - -=item verify ( ADDRESS ) - -Verify that C<ADDRESS> is a legitimate mailing address. - -Most sites usually disable this feature in their SMTP service configuration. -Use "Debug => 1" option under new() to see if disabled. - -=item help ( [ $subject ] ) - -Request help text from the server. Returns the text or undef upon failure - -=item quit () - -Send the QUIT command to the remote SMTP server and close the socket connection. - -=back - -=head1 ADDRESSES - -Net::SMTP attempts to DWIM with addresses that are passed. For -example an application might extract The From: line from an email -and pass that to mail(). While this may work, it is not recommended. -The application should really use a module like L<Mail::Address> -to extract the mail address and pass that. - -If C<ExactAddresses> is passed to the constructor, then addresses -should be a valid rfc2821-quoted address, although Net::SMTP will -accept accept the address surrounded by angle brackets. - - funny user@domain WRONG - "funny user"@domain RIGHT, recommended - <"funny user"@domain> OK - -=head1 SEE ALSO - -L<Net::Cmd> - -=head1 AUTHOR - -Graham Barr <gbarr@pobox.com> - -=head1 COPYRIGHT - -Copyright (c) 1995-2004 Graham Barr. All rights reserved. -This program is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/Master/tlpkg/tlperl/lib/Net/SMTP/TLS.pm b/Master/tlpkg/tlperl/lib/Net/SMTP/TLS.pm deleted file mode 100755 index 10f9f196e40..00000000000 --- a/Master/tlpkg/tlperl/lib/Net/SMTP/TLS.pm +++ /dev/null @@ -1,401 +0,0 @@ -=head1 NAME - -Net::SMTP::TLS - An SMTP client supporting TLS and AUTH - -=head1 VERSION - -Version 0.12 - -=head1 SYNOPSIS - - use Net::SMTP::TLS; - my $mailer = new Net::SMTP::TLS( - 'your.mail.host', - Hello => 'some.host.name', - Port => 25, #redundant - User => 'emailguy', - Password=> 's3cr3t'); - $mailer->mail('emailguy@your.mail.host'); - $mailer->to('someonecool@somewhere.else'); - $mailer->data; - $mailer->datasend("Sent thru TLS!"); - $mailer->dataend; - $mailer->quit; - -=head1 DESCRIPTION - -B<Net::SMTP::TLS> is a TLS and AUTH capable SMTP client which offers an interface that users will find familiar from L<Net::SMTP>. B<Net::SMTP::TLS> implements a subset of the methods provided by that module, but certainly not (yet) a complete mirror image of that API. - -The methods supported by B<Net::SMTP::TLS> are used in the above example. Though self explanatory for the most part, please see the perldoc for L<Net::SMTP> if you are unclear. - -The differences in the methods provided are as follows: - -=over - -The I<mail> method does not take the options list taken by L<Net::SMTP> - -The I<to> method also does not take options, and is the only method available to set the recipient (unlike the many synonyms provided by L<Net::SMTP>). - -The constructor takes a limited number of L<Net::SMTP>'s parameters. The constructor for B<Net::SMTP::TLS> takes the following (in addition to the hostname of the mail server, which must be the first parameter and is not explicitly named): - -=over - -NoTLS - In the unlikely event that you need to use this class to perform non-TLS SMTP (you ought to be using Net::SMTP itself for that...), this will turn off TLS when supplied with a true value. This will most often cause an error related to authentication when used on a server that requires TLS - -Hello - hostname used in the EHLO command - -Port - port to connect to the SMTP service (defaults to 25) - -Timeout - Timeout for inital socket connection (defaults to 5, passed directly to L<IO::Socket::INET>) - -User - username for SMTP AUTH - -Password - password for SMTP AUTH - -=back - -=back - -=head1 TLS and AUTHentication - -During construction of an B<Net::SMTP::TLS> instance, the full login process will occur. This involves first sending EHLO to the server, then initiating a TLS session through STARTTLS. Once this is complete, the module will attempt to login using the credentials supplied by the constructor, if such credentials have been supplied. - -The AUTH method will depend on the features returned by the server after the EHLO command. Based on that, CRAM-MD5 will be used if available, followed by LOGIN, followed by PLAIN. Please note that LOGIN is the only method of authentication that has been tested. CRAM-MD5 and PLAIN login functionality was taken directly from the script mentioned in the acknowledgements section, however, I have not tested them personally. - -=head1 ERROR HANDLING - -This module will croak in the event of an SMTP error. Should you wish to handle this gracefully in your application, you may wrap your mail transmission in an eval {} block and check $@ afterward. - -=head1 ACKNOWLEDGEMENTS - -This code was blatantly plagiarized from Michal Ludvig's smtp-client.pl script. See L<http://www.logix.cz/michal/devel/smtp> for his excellent work. - -=head1 AUTHOR - -Alexander Christian Westholm, awestholm at verizon dawt net - -Improvements courtesy of Tomek Zielinski - -=cut - -package Net::SMTP::TLS; - -use strict; -use warnings; - -our $VERSION = '0.12'; -use Carp; - -use Net::SSLeay; -use IO::Socket::INET; -use IO::Socket::SSL; -use MIME::Base64 qw[encode_base64 decode_base64]; -use Digest::HMAC_MD5 qw[hmac_md5_hex]; - -BEGIN { #set up Net::SSLeay's internals - Net::SSLeay::load_error_strings(); - Net::SSLeay::SSLeay_add_ssl_algorithms(); - Net::SSLeay::randomize(); -} - -sub new { - my $pkg = shift; - my $host= shift; - my %args= @_; - $args{Host} = $host; - $args{Hello}= "localhost" if not $args{Hello}; - # make the non-SSL socket that will later be - # transformed - $args{sock} = new IO::Socket::INET( - PeerAddr => $host, - PeerPort => $args{Port} || 25, - Proto => 'tcp', - Timeout => $args{Timeout} || 5) - or croak "Connect failed :$@\n"; - - my $me = bless \%args, $pkg; - # read the line immediately after connecting - my ($rsp,$txt) = $me->_response(); - if(not $rsp == 220){ - croak "Could not connect to SMTP server: $host $txt\n"; - } - $me->hello(); # the first hello, 2nd after starttls - $me->starttls() if not $args{NoTLS}; # why we're here, after all - $me->login() if($me->{User} and $me->{Password}); - return $me; -} - -# simply print a command to the server -sub _command { - my $me = shift; - my $command = shift; - $me->{sock}->printf($command."\015\012"); -} - -# read a line from the server and parse the -# CODE SEPERATOR TEXT response format -sub _response { - my $me = shift; - my $line = $me->{sock}->getline(); - my @rsp = ($line =~ /(\d+)(.)([^\r]*)/); - # reverse things so the seperator is at the end... - # that way we don't have to get fancy with the return - # values for calls that don't require the "more indicator" - return ($rsp[0],$rsp[2],$rsp[1]); -} - -# issue an EHLO command using the hostname provided to the constructor via -# the Hello paramter, which defaults to localhost. After that, read -# all the ESMTP capabilities returned by the server -sub hello { - my $me = shift; - $me->_command("EHLO ".$me->{Hello}); - my ($num,$txt,$more) = $me->_response(); - if(not $num == 250){ - croak "EHLO command failed: $num $txt\n"; - } - my %features = (); - # SMTP uses the dash to seperate the status code from - # the response text while there are more lines remaining - while($more eq '-'){ - ($num,$txt,$more) = $me->_response(); - $txt =~ s/[\n|\r]//g; - $txt =~ /(\S+)\s(.*)$/; - my ($feat, $parm) = ($txt =~ /^(\w+)[= ]*(.*)$/); - $features{$feat} = $parm; - } - $me->{features} = \%features; - return 1; -} - -# the magic! issue the STARTTLS command and -# use IO::Socket::SSL to transform that no-good -# plain old socket into an SSL socket -sub starttls { - my $me = shift; - $me->_command("STARTTLS"); - my ($num,$txt) = $me->_response(); - if(not $num == 220){ - croak "Invalid response for STARTTLS: $num $txt\n"; - } - if(not IO::Socket::SSL::socket_to_SSL($me->{sock}, - SSL_version => "SSLv3 TLSv1")){ - croak "Couldn't start TLS: ".IO::Socket::SSL::errstr."\n"; - } - $me->hello(); -} - -# based on the AUTH line returned in the features after EHLO, -# determine which type of authentication to perform -sub login { - my $me = shift; - my $type= $me->{features}->{AUTH}; - if(not $type){ - croak "Server did not return AUTH in capabilities\n"; - } - if($type =~ /CRAM\-MD5/){ - $me->auth_MD5(); - }elsif($type =~ /LOGIN/){ - $me->auth_LOGIN(); - }elsif($type =~ /PLAIN/){ - $me->auth_PLAIN(); - }else{ - croak "Unsupported Authentication mechanism\n"; - } -} - -# perform a LOGIN authentication... -# works well on my box. -sub auth_LOGIN { - my $me = shift; - $me->_command("AUTH LOGIN"); - my ($num,$txt) = $me->_response(); - if(not $num == 334){ - croak "Cannot authenticate via LOGIN: $num $txt\n"; - } - $me->_command(encode_base64($me->{User},"")); - ($num,$txt) = $me->_response(); - if(not $num == 334){ - croak "Auth failed: $num $txt\n"; - } - $me->_command(encode_base64($me->{Password},"")); - ($num,$txt) = $me->_response(); - if(not $num == 235){ - croak "Auth failed: $num $txt\n"; - } -} - -# use MD5 to login... gets the ticket from the text -# of the line returned after the auth command is issued. -# NOTE: untested -sub auth_MD5{ - my $me =shift; - $me->_command("AUTH CRAM-MD5"); - my ($num,$txt) = $me->_response(); - if(not $num == 334){ - croak "Cannot authenticate via CRAM-MD5: $num $txt\n"; - } - my $ticket = decode_base64($txt) or - croak "Unable to decode ticket"; - my $md5_pass = hmac_md5_hex($ticket, $me->{Password}); - $me->_command(encode_base64( - $me->{User}." ".$md5_pass, "")); - ($num,$txt) = $me->_response(); - if(not $num == 235){ - croak "Auth failed: $num $txt\n"; - } -} - -# perform plain authentication -sub auth_PLAIN{ - my $me = shift; - my $user= $me->{User}; - my $pass= $me->{Password}; - $me->_command(sprintf("AUTH PLAIN %S", - encode_base64("$user\0$user\0$pass",""))); - my ($num,$txt) = $me->_response(); - if(not $num == 235){ - croak "Auth failed: $num $txt\n"; - } -} - -sub _addr { - my $addr = shift; - $addr = "" unless defined $addr; - - return $1 if $addr =~ /(<[^>]*>)/; - $addr =~ s/^\s+|\s+$//sg; - - "<$addr>"; -} - -# send the MAIL FROM: <addr> command -sub mail { - my $me = shift; - my $from= shift; - $me->_command("MAIL FROM: "._addr($from)); - my ($num,$txt) = $me->_response(); - if(not $num == 250){ - croak "Could't set FROM: $num $txt\n"; - } -} - -# send the RCPT TO: <addr> command -sub recipient -{ - my $me = shift; - - - my $addr; - foreach $addr (@_) - { - $me->_command("RCPT TO: "._addr($addr)); - my ($num,$txt) = $me->_response(); - if(not $num == 250){ - croak "Couldn't send TO <$addr>: $num $txt\n"; - } - } -} - -BEGIN { - *to = \&recipient; - *cc = \&recipient; - *bcc = \&recipient; -} - - -# start the body of the message -# I would probably have designed the public methods of -# this class differently, but this is to keep with -# Net::SMTP's API -sub data { - my $me = shift; - $me->_command("DATA"); - my ($num,$txt) = $me->_response(); - if(not $num == 354){ - croak "Data failed: $num $txt\n"; - } -} - -# send stuff over raw (for use as message body) -sub datasend { - my $cmd = shift; - my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_; - my $line = join("" ,@$arr); - - return 0 unless defined(fileno($cmd->{sock})); - - my $last_ch = $cmd->{last_ch}; - $last_ch = $cmd->{last_ch} = "\012" unless defined $last_ch; - - return 1 unless length $line; - - $line =~ tr/\r\n/\015\012/ unless "\r" eq "\015"; - - my $first_ch = ''; - - if ($last_ch eq "\015") { - $first_ch = "\012" if $line =~ s/^\012//; - } - elsif ($last_ch eq "\012") { - $first_ch = "." if $line =~ /^\./; - } - - $line =~ s/\015?\012(\.?)/\015\012$1$1/sg; - - substr($line,0,0) = $first_ch; - - $cmd->{last_ch} = substr($line,-1,1); - - my $len = length($line); - my $offset = 0; - my $win = ""; - vec($win,fileno($cmd->{sock}),1) = 1; - my $timeout = $cmd->{sock}->timeout || undef; - - local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS'; - - while($len) - { - my $wout; - if (select(undef,$wout=$win, undef, $timeout) > 0 or -f $cmd->{sock}) # -f for testing on win32 - { - my $w = syswrite($cmd->{sock}, $line, $len, $offset); - unless (defined($w)) - { - carp("Error: $!"); - return undef; - } - $len -= $w; - } - else - { - carp("Error: Timeout"); - return undef; - } - } - -} - -# end the message body submission by a line with nothing -# but a period on it. -sub dataend { - my $me = shift; - $me->_command("\015\012."); - my ($num,$txt) = $me->_response(); - if(not $num == 250){ - croak "Couldn't send mail: $num $txt\n"; - } -} - -# politely disconnect from the SMTP server. -sub quit { - my $me = shift; - $me->_command("QUIT"); - my ($num, $txt) = $me->_response(); - if(not $num == 221){ - croak "An error occurred disconnecting from the mail server: $num $txt\n"; - } -} - -1; diff --git a/Master/tlpkg/tlperl/lib/Net/SSL.pm b/Master/tlpkg/tlperl/lib/Net/SSL.pm deleted file mode 100755 index f14435aeb69..00000000000 --- a/Master/tlpkg/tlperl/lib/Net/SSL.pm +++ /dev/null @@ -1,607 +0,0 @@ -package Net::SSL; - -use strict; -use MIME::Base64; -use Socket; -use Carp; - -use vars qw(@ISA $VERSION $NEW_ARGS); -$VERSION = '2.84'; - -require IO::Socket; -@ISA=qw(IO::Socket::INET); - -my %REAL; # private to this package only -my $DEFAULT_VERSION = '23'; -my $CRLF = "\015\012"; -my $SEND_USERAGENT_TO_PROXY = 0; - -require Crypt::SSLeay; - -sub _default_context { - require Crypt::SSLeay::MainContext; - Crypt::SSLeay::MainContext::main_ctx(@_); -} - -sub _alarm_set { - return if $^O eq 'MSWin32' or $^O eq 'NetWare'; - alarm(shift); -} - -sub new { - my($class, %arg) = @_; - local $NEW_ARGS = \%arg; - $class->SUPER::new(%arg); -} - -sub DESTROY { - my $self = shift; - delete $REAL{$self}; - local $@; - eval { $self->SUPER::DESTROY; }; -} - -sub configure { - my($self, $arg) = @_; - my $ssl_version = delete $arg->{SSL_Version} || - $ENV{HTTPS_VERSION} || $DEFAULT_VERSION; - my $ssl_debug = delete $arg->{SSL_Debug} || $ENV{HTTPS_DEBUG} || 0; - - my $ctx = delete $arg->{SSL_Context} || _default_context($ssl_version); - - *$self->{ssl_ctx} = $ctx; - *$self->{ssl_version} = $ssl_version; - *$self->{ssl_debug} = $ssl_debug; - *$self->{ssl_arg} = $arg; - *$self->{ssl_peer_addr} = $arg->{PeerAddr}; - *$self->{ssl_peer_port} = $arg->{PeerPort}; - *$self->{ssl_new_arg} = $NEW_ARGS; - *$self->{ssl_peer_verify} = 0; - - ## Crypt::SSLeay must also aware the SSL Proxy before calling - ## $socket->configure($args). Because the $sock->configure() will - ## die when failed to resolve the destination server IP address, - ## whether the SSL proxy is used or not! - ## - dqbai, 2003-05-10 - if (my $proxy = $self->proxy) { - ($arg->{PeerAddr}, $arg->{PeerPort}) = split(':',$proxy); - $arg->{PeerPort} || croak("no port given for proxy server $proxy"); - } - - $self->SUPER::configure($arg); -} - -# override to make sure there is really a timeout -sub timeout { - shift->SUPER::timeout || 60; -} - -sub blocking { - my $self = shift; - $self->SUPER::blocking(@_); -} - -sub connect { - my $self = shift; - - # configure certs on connect() time, so we can throw an undef - # and have LWP understand the error - eval { $self->configure_certs() }; - if($@) { - $@ = "configure certs failed: $@; $!"; - $self->die_with_error($@); - } - - # finished, update set_verify status - if(my $rv = *$self->{ssl_ctx}->set_verify()) { - *$self->{ssl_peer_verify} = $rv; - } - - if ($self->proxy) { - # don't die() in connect, just return undef and set $@ - my $proxy_connect = eval { $self->proxy_connect_helper(@_) }; - if(! $proxy_connect || $@) { - $@ = "proxy connect failed: $@; $!"; - croak($@); - } - } - else { - *$self->{io_socket_peername}=@_ == 1 ? $_[0] : IO::Socket::sockaddr_in(@_); - if(!$self->SUPER::connect(@_)) { - # better to die than return here - $@ = "Connect failed: $@; $!"; - croak($@); - } - } - - my $debug = *$self->{ssl_debug} || 0; - my $ssl = Crypt::SSLeay::Conn->new(*$self->{ssl_ctx}, $debug, $self); - my $arg = *$self->{ssl_arg}; - my $new_arg = *$self->{ssl_new_arg}; - $arg->{SSL_Debug} = $debug; - - eval { - local $SIG{ALRM} = sub { $self->die_with_error("SSL connect timeout") }; - # timeout / 2 because we have 3 possible connects here - _alarm_set($self->timeout / 2); - - my $rv; - { - local $SIG{PIPE} = \¨ - $rv = eval { $ssl->connect; }; - } - if (not defined $rv or $rv <= 0) { - _alarm_set(0); - $ssl = undef; - my %args = (%$new_arg, %$arg); - if(*$self->{ssl_version} == 23) { - $args{SSL_Version} = 3; - # the new connect might itself be overridden with a REAL SSL - my $new_ssl = Net::SSL->new(%args); - $REAL{$self} = $REAL{$new_ssl} || $new_ssl; - return $REAL{$self}; - } - elsif(*$self->{ssl_version} == 3) { - # $self->die_with_error("SSL negotiation failed"); - $args{SSL_Version} = 2; - my $new_ssl = Net::SSL->new(%args); - $REAL{$self} = $new_ssl; - return $new_ssl; - } - else { - # don't die, but do set $@, and return undef - eval { $self->die_with_error("SSL negotiation failed") }; - croak($@); - } - } - _alarm_set(0); - }; - - # odd error in eval {} block, maybe alarm outside the evals - if($@) { - $@ = "$@; $!"; - croak($@); - } - - # successful SSL connection gets stored - *$self->{ssl_ssl} = $ssl; - $self; -} - -# Delegate these calls to the Crypt::SSLeay::Conn object -sub get_peer_certificate { - my $self = shift; - $self = $REAL{$self} || $self; - *$self->{ssl_ssl}->get_peer_certificate(@_); -} - -sub get_peer_verify { - my $self = shift; - $self = $REAL{$self} || $self; - *$self->{ssl_peer_verify}; -} - -sub get_shared_ciphers { - my $self = shift; - $self = $REAL{$self} || $self; - *$self->{ssl_ssl}->get_shared_ciphers(@_); -} - -sub get_cipher { - my $self = shift; - $self = $REAL{$self} || $self; - *$self->{ssl_ssl}->get_cipher(@_); -} - -sub ssl_context { - my $self = shift; - $self = $REAL{$self} || $self; - *$self->{ssl_ctx}; -} - -sub die_with_error { - my $self=shift; - my $reason=shift; - - my @err; - while(my $err=Crypt::SSLeay::Err::get_error_string()) { - push @err, $err; - } - croak("$reason: " . join( ' | ', @err )); -} - -sub read { - my $self = shift; - $self = $REAL{$self} || $self; - - local $SIG{__DIE__} = \&Carp::confess; - local $SIG{ALRM} = sub { $self->die_with_error("SSL read timeout") }; - - _alarm_set($self->timeout); - my $n = *$self->{ssl_ssl}->read(@_); - _alarm_set(0); - $self->die_with_error("read failed") if !defined $n; - - $n; -} - -sub write { - my $self = shift; - $self = $REAL{$self} || $self; - my $n = *$self->{ssl_ssl}->write(@_); - $self->die_with_error("write failed") if !defined $n; - $n; -} - -*sysread = \&read; -*syswrite = \&write; - -sub print { - my $self = shift; - $self = $REAL{$self} || $self; - # should we care about $, and $\?? - # I think it is too expensive... - $self->write(join("", @_)); -} - -sub printf { - my $self = shift; - $self = $REAL{$self} || $self; - my $fmt = shift; - $self->write(sprintf($fmt, @_)); -} - -sub getchunk { - my $self = shift; - $self = $REAL{$self} || $self; - my $buf = ''; # warnings - my $n = $self->read($buf, 32768); - return unless defined $n; - $buf; -} - -# This is really inefficient, but we only use it for reading the proxy response -# so that does not really matter. -sub getline { - my $self = shift; - $self = $REAL{$self} || $self; - my $val=""; - my $buf; - do { - $self->SUPER::recv($buf, 1); - $val .= $buf; - } until ($buf eq "\n"); - - $val; -} - -# XXX: no way to disable <$sock>?? (tied handle perhaps?) - -sub get_lwp_object { - my $self = shift; - - my $lwp_object; - my $i = 0; - while(1) { - package DB; - my @stack = caller($i++); - last unless @stack; - my @stack_args = @DB::args; - my $stack_object = $stack_args[0] || next; - return $stack_object - if ref($stack_object) - and $stack_object->isa('LWP::UserAgent'); - } - return undef; -} - -sub send_useragent_to_proxy { - if (my $val = shift) { - $SEND_USERAGENT_TO_PROXY = $val; - } - return $SEND_USERAGENT_TO_PROXY; -} - -sub proxy_connect_helper { - my $self = shift; - - my $proxy = $self->proxy; - my ($proxy_host, $proxy_port) = split(':',$proxy); - $proxy_port || croak("no port given for proxy server $proxy"); - - my $proxy_addr = gethostbyname($proxy_host); - $proxy_addr || croak("can't resolve proxy server name: $proxy_host, $!"); - - my($peer_port, $peer_addr) = (*$self->{ssl_peer_port}, *$self->{ssl_peer_addr}); - $peer_addr || croak("no peer addr given"); - $peer_port || croak("no peer port given"); - - # see if the proxy should be bypassed - my @no_proxy = split( /\s*,\s*/, $ENV{NO_PROXY} || $ENV{no_proxy} || ''); - my $is_proxied = 1; - my $domain; - for $domain (@no_proxy) { - if ($peer_addr =~ /\Q$domain\E$/) { - $is_proxied = 0; - last; - } - } - - if ($is_proxied) { - $self->SUPER::connect($proxy_port, $proxy_addr) - || croak("proxy connect to $proxy_host:$proxy_port failed: $!"); - } - else { - $self->SUPER::connect($peer_port, $peer_addr) - || croak("proxy bypass to $peer_addr:$peer_addr failed: $!"); - } - - my $connect_string; - if ($ENV{"HTTPS_PROXY_USERNAME"} || $ENV{"HTTPS_PROXY_PASSWORD"}) { - my $user = $ENV{"HTTPS_PROXY_USERNAME"}; - my $pass = $ENV{"HTTPS_PROXY_PASSWORD"}; - - my $credentials = encode_base64("$user:$pass", ""); - $connect_string = join($CRLF, - "CONNECT $peer_addr:$peer_port HTTP/1.0", - "Proxy-authorization: Basic $credentials" - ); - } - else { - $connect_string = "CONNECT $peer_addr:$peer_port HTTP/1.0"; - } - $connect_string .= $CRLF; - - if (send_useragent_to_proxy()) { - my $lwp_object = $self->get_lwp_object; - if($lwp_object && $lwp_object->agent) { - $connect_string .= "User-Agent: ".$lwp_object->agent.$CRLF; - } - } - - $connect_string .= $CRLF; - $self->SUPER::send($connect_string); - my $header; - my $n = $self->SUPER::sysread($header, 8192); - my $conn_ok = ($header =~ /HTTP\/\d+\.\d+\s+200\s+/is) ? 1 : 0; - - if (not $conn_ok) { - croak("PROXY ERROR HEADER, could be non-SSL URL:\n$header"); - } - - $conn_ok; -} - -# code adapted from LWP::UserAgent, with $ua->env_proxy API -sub proxy { - my $proxy_server = $ENV{HTTPS_PROXY} || $ENV{https_proxy}; - return unless $proxy_server; - - $proxy_server =~ s|\Ahttps?://||i; - $proxy_server; -} - -sub configure_certs { - my $self = shift; - my $ctx = *$self->{ssl_ctx}; - - my $count = 0; - for (qw(HTTPS_PKCS12_FILE HTTPS_CERT_FILE HTTPS_KEY_FILE)) { - my $file = $ENV{$_}; - if ($file) { - (-e $file) or croak("$file file does not exist: $!"); - (-r $file) or croak("$file file is not readable"); - $count++; - if (/PKCS12/) { - $count++; - $ctx->use_pkcs12_file($file ,$ENV{'HTTPS_PKCS12_PASSWORD'}) || croak("failed to load $file: $!"); - last; - } - elsif (/CERT/) { - $ctx->use_certificate_file($file ,1) || croak("failed to load $file: $!"); - } - elsif (/KEY/) { - $ctx->use_PrivateKey_file($file, 1) || croak("failed to load $file: $!"); - } - else { - croak("setting $_ not supported"); - } - } - } - - # if both configs are set, then verify them - if ($count == 2) { - if (! $ctx->check_private_key) { - croak("Private key and certificate do not match"); - } - } - - $count; # number of successful cert loads/checks -} - -sub accept { shift->_unimpl("accept") } -sub getc { shift->_unimpl("getc") } -sub ungetc { shift->_unimpl("ungetc") } -sub getlines { shift->_unimpl("getlines"); } - -sub _unimpl { - my($self, $meth) = @_; - croak("$meth not implemented for Net::SSL sockets"); -} - -1; - -__END__ - -=head1 NAME - -Net::SSL - support for Secure Sockets Layer - -=head1 METHODS - -=over 4 - -=item new - -Creates a new C<Net::SSL> object. - -=item configure - -Configures a C<Net::SSL> socket for operation. - -=item configure_certs - -Sets up a certificate file to use for communicating with on -the socket. - -=item connect - -=item die_with_error - -=item get_cipher - -=item get_lwp_object - -Walks up the caller stack and looks for something blessed into -the C<LWP::UserAgent> namespace and returns it. Vaguely deprecated. - -=item get_peer_certificate - -Gets the peer certificate from the underlying C<Crypt::SSLeay::Conn> -object. - -=item get_peer_verify - -=item get_shared_ciphers - -=item getchunk - -Attempts to read up to 32KiB of data from the socket. Returns -C<undef> if nothing was read, otherwise returns the data as -a scalar. - -=item getline - -Reads one character at a time until a newline is encountered, -and returns the line, including the newline. Grossly -inefficient. - -=item print - -Concatenates the input parameters and writes them to the socket. -Does not honour C<$,> nor C<$/>. Returns the number of bytes written. - -=item printf - -Performs a C<sprintf> of the input parameters (thus, the first -parameter must be the format), and writes the result to the socket. -Returns the number of bytes written. - -=item proxy - -Returns the hostname of an https proxy server, as specified by the -C<HTTPS_PROXY> environment variable. - -=item proxy_connect_helper - -Helps set up a connection through a proxy. - -=item read - -Performs a read on the socket and returns the result. - -=item ssl_context - -=item sysread - -Is an alias of C<read>. - -=item timeout - -Returns the timeout value of the socket as defined by the implementing -class or 60 seconds by default. - -=item blocking - -Returns a boolean indicating whether the underlying socket is in -blocking mode. By default, Net::SSL sockets are in blocking mode. - - $sock->blocking(0); # set to non-blocking mode - -This method simply calls the underlying C<blocking> method of the -IO::Socket object. - -=item write - -Writes the parameters passed in (thus, a list) to the socket. Returns -the number of bytes written. - -=item syswrite - -Is an alias of C<write>. - -=item accept - -Not yet implemented. Will die if called. - -=item getc - -Not yet implemented. Will die if called. - -=item getlines - -Not yet implemented. Will die if called. - -=item ungetc - -Not yet implemented. Will die if called. - -=item send_useragent_to_proxy - -By default (as of version 2.80 of C<Net::SSL> in the 0.54 distribution -of Crypt::SSLeay), the user agent string is no longer sent to the -proxy (but will continue to be sent to the remote host). - -The previous behaviour was of marginal benefit, and could cause -fatal errors in certain scenarios (see CPAN bug #4759) and so no -longer happens by default. - -To reinstate the old behaviour, call C<Net::SSL::send_useragent_to_proxy> -with a true value (usually 1). - -=back - -=head1 DIAGNOSTICS - - "no port given for proxy server <proxy>" - -A proxy was specified for configuring a socket, but no port number -was given. Ensure that the proxy is specified as a host:port pair, -such as C<proxy.example.com:8086>. - - "configure certs failed: <contents of $@>; <contents of $!>" - - "proxy connect failed: <contents of $@>; <contents of $!>" - - "Connect failed: <contents of $@>; <contents of $!>" - -During connect(). - -=head2 SEE ALSO - -=over 4 - -=item IO::Socket::INET - -C<Net::SSL> is implemented by subclassing C<IO::Socket::INET>, hence -methods not specifically overridden are defined by that package. - -=item Net::SSLeay - -A package that provides a Perl-level interface to the C<openssl> -secure sockets layer library. - -=back - -=cut - diff --git a/Master/tlpkg/tlperl/lib/Net/SSLeay.pm b/Master/tlpkg/tlperl/lib/Net/SSLeay.pm deleted file mode 100755 index 08a0ec30f6a..00000000000 --- a/Master/tlpkg/tlperl/lib/Net/SSLeay.pm +++ /dev/null @@ -1,2610 +0,0 @@ -# Net::SSLeay.pm - Perl module for using Eric Young's implementation of SSL -# -# Copyright (c) 1996-2003 Sampo Kellomaki <sampo@iki.fi>, All Rights Reserved. -# Copyright (C) 2005 Florian Ragwitz <rafl@debian.org>, All Rights Reserved. -# Copyright (C) 2005 Mike McCauley <mikem@open.com.au>, All Rights Reserved. -# -# $Id$ -# -# Version 1.04, 31.3.1999 -# 30.7.1999, Tracking OpenSSL-0.9.3a changes, --Sampo -# 31.7.1999, version 1.05 --Sampo -# 7.4.2001, fixed input error upon 0, OpenSSL-0.9.6a, version 1.06 --Sampo -# 18.4.2001, added TLSv1 support by Stephen C. Koehler -# <koehler@securecomputing.com>, version 1.07, --Sampo -# 25.4.2001, 64 bit fixes by Marko Asplund <aspa@kronodoc.fi> --Sampo -# 17.4.2001, more error codes from aspa --Sampo -# 25.9.2001, added heaps and piles of newer OpenSSL auxiliary functions --Sampo -# 6.11.2001, got rid of $p_errs madness --Sampo -# 9.11.2001, added EGD (entropy gathering daemon) reference info --Sampo -# 7.12.2001, Added proxy support by Bruno De Wolf <bruno.dewolf@@pandora._be> -# 6.1.2002, cosmetic fix to socket options from Kwindla Hultman Kramer <kwindla@@allafrica_.com> -# 25.3.2002, added post_https_cert and friends per patch from -# mock@@obscurity.ogr, --Sampo -# 3.4.2002, added `use bytes' from Marcus Taylor <marcus@@semantico_.com> -# This avoids unicode/utf8 (as may appear in some XML docs) -# from fooling the length comuptations. Dropped support for -# perl5.005_03 because I do not have opportunity to test it. --Sampo -# 5.4.2002, improved Unicode gotcha eliminator to support old perls --Sampo -# 8.4.2002, added a small line end fix from Petr Dousa (pdousa@@kerio_.com) -# 17.5.2002, Added BIO_s_mem, BIO_new, BIO_free, BIO_write, BIO_read -# BIO_eof, BIO_pending, BIO_wpending, RSA_generate_key, RSA_free -# --mikem@open._com.au -# 10.8.2002, Added SSL_peek patch to ssl_read_until from -# Peter Behroozi <peter@@fhpwireless_.com> --Sampo -# 21.8.2002, Added SESSION_get_master_key, SSL_get_client_random, SSL_get_server_random -# --mikem@open.com_.au -# 2.9.2002, Added SSL_CTX_get_cert_store, X509_STORE_add_cert, X509_STORE_add_crl -# X509_STORE_set_flags, X509_load_cert_file, X509_load_crl_file -# X509_load_cert_crl_file, PEM_read_bio_X509_CRL, -# constants for X509_V_FLAG_* in order to support certificate revocation lists. -# --mikem@open.com_.au -# 6.9.2002, fixed X509_STORE_set_flags to X509_STORE_CTX_set_flags, --Sampo -# 19.9.2002, applied patch from Tim Engler <tim@burntcouch_.com> -# 18.2.2003, applied patch from Toni Andjelkovic <toni@soth._at> -# 13.6.2003, partially applied leak patch by Marian Jancar <mjancar@suse._cz> -# 25.6.2003, write_partial() return value patch from -# Kim Minh Kaplan <kmkaplan@selfoffice._com> -# 17.8.2003, added http support :-) --Sampo -# 17.8.2003, started 1.25 dev --Sampo -# 30.11.2005, Applied a patch by Peter Behroozi that adds get1_session() for session caching --Florian -# 30.11.2005, Applied a patch by ex8k-hbn@asahi-net.or.jp that limits the chunk size for tcp_read_all --Florian -# 30.11.2005, Applied a patch by ivan-cpan-rt@420.am that avoids adding a Host header if an own is specified in do_httpx3 -# 13.12.2005, Added comments re thread safety and resetting of default_passwd_callback after use -# --mikem@open.com.au -# -# The distribution and use of this module are subject to the conditions -# listed in LICENSE file at the root of OpenSSL-0.9.7b -# distribution (i.e. free, but mandatory attribution and NO WARRANTY). - -package Net::SSLeay; - -use strict; -use Carp; -use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD $CRLF); -use Socket; -use Errno; - -require Exporter; -use AutoLoader; - -# 0=no warns, 1=only errors, 2=ciphers, 3=progress, 4=dump data -$Net::SSLeay::trace = 0; # Do not change here, use - # $Net::SSLeay::trace = [1-4] in caller - -# 2 = insist on v2 SSL protocol -# 3 = insist on v3 SSL -# 10 = insist on TLSv1 -# 0 or undef = guess (v23) -# -$Net::SSLeay::ssl_version = 0; # don't change here, use - # Net::SSLeay::version=[2,3,0] in caller - -#define to enable the "cat /proc/$$/stat" stuff -$Net::SSLeay::linux_debug = 0; - -# Number of seconds to sleep after sending message and before half -# closing connection. Useful with antiquated broken servers. -$Net::SSLeay::slowly = 0; - -# RANDOM NUMBER INITIALIZATION -# -# Edit to your taste. Using /dev/random would be more secure, but may -# block if randomness is not available, thus the default is -# /dev/urandom. $how_random determines how many bits of randomness to take -# from the device. You should take enough (read SSLeay/doc/rand), but -# beware that randomness is limited resource so you should not waste -# it either or you may end up with randomness depletion (situation where -# /dev/random would block and /dev/urandom starts to return predictable -# numbers). -# -# N.B. /dev/urandom does not exit on all systems, such as Solaris 2.6. In that -# case you should get a third party package that emulates /dev/urandom -# (e.g. via named pipe) or supply a random number file. Some such -# packages are documented in Caveat section of the POD documentation. - -$Net::SSLeay::random_device = '/dev/urandom'; -$Net::SSLeay::how_random = 512; - -$VERSION = '1.35'; -@ISA = qw(Exporter); -@EXPORT_OK = qw( - AT_MD5_WITH_RSA_ENCRYPTION - CB_ACCEPT_EXIT - CB_ACCEPT_LOOP - CB_CONNECT_EXIT - CB_CONNECT_LOOP - CK_DES_192_EDE3_CBC_WITH_MD5 - CK_DES_192_EDE3_CBC_WITH_SHA - CK_DES_64_CBC_WITH_MD5 - CK_DES_64_CBC_WITH_SHA - CK_DES_64_CFB64_WITH_MD5_1 - CK_IDEA_128_CBC_WITH_MD5 - CK_NULL - CK_NULL_WITH_MD5 - CK_RC2_128_CBC_EXPORT40_WITH_MD5 - CK_RC2_128_CBC_WITH_MD5 - CK_RC4_128_EXPORT40_WITH_MD5 - CK_RC4_128_WITH_MD5 - CLIENT_VERSION - ERROR_NONE - ERROR_SSL - ERROR_SYSCALL - ERROR_WANT_CONNECT - ERROR_WANT_READ - ERROR_WANT_WRITE - ERROR_WANT_X509_LOOKUP - ERROR_ZERO_RETURN - CT_X509_CERTIFICATE - FILETYPE_ASN1 - FILETYPE_PEM - F_CLIENT_CERTIFICATE - F_CLIENT_HELLO - F_CLIENT_MASTER_KEY - F_D2I_SSL_SESSION - F_GET_CLIENT_FINISHED - F_GET_CLIENT_HELLO - F_GET_CLIENT_MASTER_KEY - F_GET_SERVER_FINISHED - F_GET_SERVER_HELLO - F_GET_SERVER_VERIFY - F_I2D_SSL_SESSION - F_READ_N - F_REQUEST_CERTIFICATE - F_SERVER_HELLO - F_SSL_ACCEPT - F_SSL_CERT_NEW - F_SSL_CONNECT - F_SSL_ENC_DES_CBC_INIT - F_SSL_ENC_DES_CFB_INIT - F_SSL_ENC_DES_EDE3_CBC_INIT - F_SSL_ENC_IDEA_CBC_INIT - F_SSL_ENC_NULL_INIT - F_SSL_ENC_RC2_CBC_INIT - F_SSL_ENC_RC4_INIT - F_SSL_GET_NEW_SESSION - F_SSL_MAKE_CIPHER_LIST - F_SSL_NEW - F_SSL_READ - F_SSL_RSA_PRIVATE_DECRYPT - F_SSL_RSA_PUBLIC_ENCRYPT - F_SSL_SESSION_NEW - F_SSL_SESSION_PRINT_FP - F_SSL_SET_CERTIFICATE - F_SSL_SET_FD - F_SSL_SET_RFD - F_SSL_SET_WFD - F_SSL_STARTUP - F_SSL_USE_CERTIFICATE - F_SSL_USE_CERTIFICATE_ASN1 - F_SSL_USE_CERTIFICATE_FILE - F_SSL_USE_PRIVATEKEY - F_SSL_USE_PRIVATEKEY_ASN1 - F_SSL_USE_PRIVATEKEY_FILE - F_SSL_USE_RSAPRIVATEKEY - F_SSL_USE_RSAPRIVATEKEY_ASN1 - F_SSL_USE_RSAPRIVATEKEY_FILE - F_WRITE_PENDING - GEN_OTHERNAME - GEN_EMAIL - GEN_DNS - GEN_X400 - GEN_DIRNAME - GEN_EDIPARTY - GEN_URI - GEN_IPADD - GEN_RID - MAX_MASTER_KEY_LENGTH_IN_BITS - MAX_RECORD_LENGTH_2_BYTE_HEADER - MAX_RECORD_LENGTH_3_BYTE_HEADER - MAX_SSL_SESSION_ID_LENGTH_IN_BYTES - MIN_RSA_MODULUS_LENGTH_IN_BYTES - MT_CLIENT_CERTIFICATE - MT_CLIENT_FINISHED - MT_CLIENT_HELLO - MT_CLIENT_MASTER_KEY - MT_ERROR - MT_REQUEST_CERTIFICATE - MT_SERVER_FINISHED - MT_SERVER_HELLO - MT_SERVER_VERIFY - NOTHING - NID_undef - NID_algorithm - NID_rsadsi - NID_pkcs - NID_md2 - NID_md5 - NID_rc4 - NID_rsaEncryption - NID_md2WithRSAEncryption - NID_md5WithRSAEncryption - NID_pbeWithMD2AndDES_CBC - NID_pbeWithMD5AndDES_CBC - NID_X500 - NID_X509 - NID_commonName - NID_countryName - NID_localityName - NID_stateOrProvinceName - NID_organizationName - NID_organizationalUnitName - NID_rsa - NID_pkcs7 - NID_pkcs7_data - NID_pkcs7_signed - NID_pkcs7_enveloped - NID_pkcs7_signedAndEnveloped - NID_pkcs7_digest - NID_pkcs7_encrypted - NID_pkcs3 - NID_dhKeyAgreement - NID_des_ecb - NID_des_cfb64 - NID_des_cbc - NID_des_ede - NID_des_ede3 - NID_idea_cbc - NID_idea_cfb64 - NID_idea_ecb - NID_rc2_cbc - NID_rc2_ecb - NID_rc2_cfb64 - NID_rc2_ofb64 - NID_sha - NID_shaWithRSAEncryption - NID_des_ede_cbc - NID_des_ede3_cbc - NID_des_ofb64 - NID_idea_ofb64 - NID_pkcs9 - NID_pkcs9_emailAddress - NID_pkcs9_unstructuredName - NID_pkcs9_contentType - NID_pkcs9_messageDigest - NID_pkcs9_signingTime - NID_pkcs9_countersignature - NID_pkcs9_challengePassword - NID_pkcs9_unstructuredAddress - NID_pkcs9_extCertAttributes - NID_netscape - NID_netscape_cert_extension - NID_netscape_data_type - NID_des_ede_cfb64 - NID_des_ede3_cfb64 - NID_des_ede_ofb64 - NID_des_ede3_ofb64 - NID_sha1 - NID_sha1WithRSAEncryption - NID_dsaWithSHA - NID_dsa_2 - NID_pbeWithSHA1AndRC2_CBC - NID_id_pbkdf2 - NID_dsaWithSHA1_2 - NID_netscape_cert_type - NID_netscape_base_url - NID_netscape_revocation_url - NID_netscape_ca_revocation_url - NID_netscape_renewal_url - NID_netscape_ca_policy_url - NID_netscape_ssl_server_name - NID_netscape_comment - NID_netscape_cert_sequence - NID_desx_cbc - NID_id_ce - NID_subject_key_identifier - NID_key_usage - NID_private_key_usage_period - NID_subject_alt_name - NID_issuer_alt_name - NID_basic_constraints - NID_crl_number - NID_certificate_policies - NID_authority_key_identifier - NID_bf_cbc - NID_bf_ecb - NID_bf_cfb64 - NID_bf_ofb64 - NID_mdc2 - NID_mdc2WithRSA - NID_rc4_40 - NID_rc2_40_cbc - NID_givenName - NID_surname - NID_initials - NID_uniqueIdentifier - NID_crl_distribution_points - NID_md5WithRSA - NID_serialNumber - NID_title - NID_description - NID_cast5_cbc - NID_cast5_ecb - NID_cast5_cfb64 - NID_cast5_ofb64 - NID_pbeWithMD5AndCast5_CBC - NID_dsaWithSHA1 - NID_md5_sha1 - NID_sha1WithRSA - NID_dsa - NID_ripemd160 - NID_ripemd160WithRSA - NID_rc5_cbc - NID_rc5_ecb - NID_rc5_cfb64 - NID_rc5_ofb64 - NID_rle_compression - NID_zlib_compression - NID_ext_key_usage - NID_id_pkix - NID_id_kp - NID_server_auth - NID_client_auth - NID_code_sign - NID_email_protect - NID_time_stamp - NID_ms_code_ind - NID_ms_code_com - NID_ms_ctl_sign - NID_ms_sgc - NID_ms_efs - NID_ns_sgc - NID_delta_crl - NID_crl_reason - NID_invalidity_date - NID_sxnet - NID_pbe_WithSHA1And128BitRC4 - NID_pbe_WithSHA1And40BitRC4 - NID_pbe_WithSHA1And3_Key_TripleDES_CBC - NID_pbe_WithSHA1And2_Key_TripleDES_CBC - NID_pbe_WithSHA1And128BitRC2_CBC - NID_pbe_WithSHA1And40BitRC2_CBC - NID_keyBag - NID_pkcs8ShroudedKeyBag - NID_certBag - NID_crlBag - NID_secretBag - NID_safeContentsBag - NID_friendlyName - NID_localKeyID - NID_x509Certificate - NID_sdsiCertificate - NID_x509Crl - NID_pbes2 - NID_pbmac1 - NID_hmacWithSHA1 - NID_id_qt_cps - NID_id_qt_unotice - NID_rc2_64_cbc - NID_SMIMECapabilities - NID_pbeWithMD2AndRC2_CBC - NID_pbeWithMD5AndRC2_CBC - NID_pbeWithSHA1AndDES_CBC - NID_ms_ext_req - NID_ext_req - NID_name - NID_dnQualifier - NID_id_pe - NID_id_ad - NID_info_access - NID_ad_OCSP - NID_ad_ca_issuers - NID_OCSP_sign - OPENSSL_VERSION_NUMBER - PE_BAD_CERTIFICATE - PE_NO_CERTIFICATE - PE_NO_CIPHER - PE_UNSUPPORTED_CERTIFICATE_TYPE - READING - RWERR_BAD_MAC_DECODE - RWERR_BAD_WRITE_RETRY - RWERR_INTERNAL_ERROR - R_BAD_AUTHENTICATION_TYPE - R_BAD_CHECKSUM - R_BAD_MAC_DECODE - R_BAD_RESPONSE_ARGUMENT - R_BAD_SSL_FILETYPE - R_BAD_SSL_SESSION_ID_LENGTH - R_BAD_STATE - R_BAD_WRITE_RETRY - R_CHALLENGE_IS_DIFFERENT - R_CIPHER_CODE_TOO_LONG - R_CIPHER_TABLE_SRC_ERROR - R_CONECTION_ID_IS_DIFFERENT - R_INVALID_CHALLENGE_LENGTH - R_NO_CERTIFICATE_SET - R_NO_CERTIFICATE_SPECIFIED - R_NO_CIPHER_LIST - R_NO_CIPHER_MATCH - R_NO_CIPHER_WE_TRUST - R_NO_PRIVATEKEY - R_NO_PUBLICKEY - R_NO_READ_METHOD_SET - R_NO_WRITE_METHOD_SET - R_NULL_SSL_CTX - R_PEER_DID_NOT_RETURN_A_CERTIFICATE - R_PEER_ERROR - R_PEER_ERROR_CERTIFICATE - R_PEER_ERROR_NO_CIPHER - R_PEER_ERROR_UNSUPPORTED_CERTIFICATE_TYPE - R_PERR_ERROR_NO_CERTIFICATE - R_PUBLIC_KEY_ENCRYPT_ERROR - R_PUBLIC_KEY_IS_NOT_RSA - R_PUBLIC_KEY_NO_RSA - R_READ_WRONG_PACKET_TYPE - R_REVERSE_KEY_ARG_LENGTH_IS_WRONG - R_REVERSE_MASTER_KEY_LENGTH_IS_WRONG - R_REVERSE_SSL_SESSION_ID_LENGTH_IS_WRONG - R_SHORT_READ - R_SSL_SESSION_ID_IS_DIFFERENT - R_UNABLE_TO_EXTRACT_PUBLIC_KEY - R_UNDEFINED_INIT_STATE - R_UNKNOWN_REMOTE_ERROR_TYPE - R_UNKNOWN_STATE - R_UNSUPORTED_CIPHER - R_WRONG_PUBLIC_KEY_TYPE - R_X509_LIB - RSA_3 - RSA_F4 - SERVER_VERSION - SESSION - SESSION_ASN1_VERSION - ST_ACCEPT - ST_BEFORE - ST_CLIENT_START_ENCRYPTION - ST_CONNECT - ST_GET_CLIENT_FINISHED_A - ST_GET_CLIENT_FINISHED_B - ST_GET_CLIENT_HELLO_A - ST_GET_CLIENT_HELLO_B - ST_GET_CLIENT_MASTER_KEY_A - ST_GET_CLIENT_MASTER_KEY_B - ST_GET_SERVER_FINISHED_A - ST_GET_SERVER_FINISHED_B - ST_GET_SERVER_HELLO_A - ST_GET_SERVER_HELLO_B - ST_GET_SERVER_VERIFY_A - ST_GET_SERVER_VERIFY_B - ST_INIT - ST_OK - ST_READ_BODY - ST_READ_HEADER - ST_SEND_CLIENT_CERTIFICATE_A - ST_SEND_CLIENT_CERTIFICATE_B - ST_SEND_CLIENT_CERTIFICATE_C - ST_SEND_CLIENT_CERTIFICATE_D - ST_SEND_CLIENT_FINISHED_A - ST_SEND_CLIENT_FINISHED_B - ST_SEND_CLIENT_HELLO_A - ST_SEND_CLIENT_HELLO_B - ST_SEND_CLIENT_MASTER_KEY_A - ST_SEND_CLIENT_MASTER_KEY_B - ST_SEND_REQUEST_CERTIFICATE_A - ST_SEND_REQUEST_CERTIFICATE_B - ST_SEND_REQUEST_CERTIFICATE_C - ST_SEND_REQUEST_CERTIFICATE_D - ST_SEND_SERVER_FINISHED_A - ST_SEND_SERVER_FINISHED_B - ST_SEND_SERVER_HELLO_A - ST_SEND_SERVER_HELLO_B - ST_SEND_SERVER_VERIFY_A - ST_SEND_SERVER_VERIFY_B - ST_SERVER_START_ENCRYPTION - ST_X509_GET_CLIENT_CERTIFICATE - ST_X509_GET_SERVER_CERTIFICATE - TXT_DES_192_EDE3_CBC_WITH_MD5 - TXT_DES_192_EDE3_CBC_WITH_SHA - TXT_DES_64_CBC_WITH_MD5 - TXT_DES_64_CBC_WITH_SHA - TXT_DES_64_CFB64_WITH_MD5_1 - TXT_IDEA_128_CBC_WITH_MD5 - TXT_NULL - TXT_NULL_WITH_MD5 - TXT_RC2_128_CBC_EXPORT40_WITH_MD5 - TXT_RC2_128_CBC_WITH_MD5 - TXT_RC4_128_EXPORT40_WITH_MD5 - TXT_RC4_128_WITH_MD5 - VERIFY_CLIENT_ONCE - VERIFY_FAIL_IF_NO_PEER_CERT - VERIFY_NONE - VERIFY_PEER - WRITING - X509_LOOKUP - X509_V_FLAG_CB_ISSUER_CHECK - X509_V_FLAG_USE_CHECK_TIME - X509_V_FLAG_CRL_CHECK - X509_V_FLAG_CRL_CHECK_ALL - X509_V_FLAG_IGNORE_CRITICAL - CTX_new - CTX_v2_new - CTX_v3_new - CTX_v23_new - CTX_free - new - free - accept - clear - connect - set_fd - set_rfd - set_wfd - get_fd - read - write - peek - use_RSAPrivateKey - use_RSAPrivateKey_ASN1 - use_RSAPrivateKey_file - CTX_use_RSAPrivateKey_file - use_PrivateKey - use_PrivateKey_ASN1 - use_PrivateKey_file - use_certificate - use_certificate_ASN1 - use_certificate_file - CTX_use_certificate_file - load_error_strings - ERR_load_SSL_strings - ERR_load_RAND_strings - state_string - rstate_string - state_string_long - rstate_string_long - get_time - set_time - get_timeout - set_timeout - copy_session_id - set_read_ahead - get_read_ahead - pending - get_cipher_list - set_cipher_list - get_cipher - get_shared_ciphers - get_peer_certificate - set_verify - flush_sessions - set_bio - get_rbio - get_wbio - SESSION_new - SESSION_print - SESSION_free - i2d_SSL_SESSION - set_session - add_session - remove_session - d2i_SSL_SESSION - BIO_f_ssl - BIO_new - BIO_new_file - BIO_s_mem - BIO_free - BIO_read - BIO_write - BIO_eof - BIO_pending - BIO_wpending - ERR_get_error - ERR_error_string - err - clear_error - X509_get_issuer_name - X509_get_subject_name - X509_NAME_oneline - X509_NAME_get_text_by_NID - CTX_get_cert_store - X509_STORE_add_cert - X509_STORE_add_crl - X509_STORE_CTX_set_flags - X509_load_cert_file - X509_load_crl_file - X509_load_cert_crl_file - PEM_read_bio_X509_CRL - die_if_ssl_error - die_now - print_errs - set_cert_and_key - set_server_cert_and_key - make_form - make_headers - do_https - get_https - post_https - get_https4 - post_https4 - sslcat - ssl_read_CRLF - ssl_read_all - ssl_read_until - ssl_write_CRLF - ssl_write_all - get_http - post_http - get_httpx - post_httpx - get_https3 - post_https3 - get_http4 - post_http4 - get_httpx4 - post_httpx4 - tcpcat - tcpxcat - tcp_read_CRLF - tcp_read_all - tcp_read_until - tcp_write_CRLF - tcp_write_all - dump_peer_certificate - RSA_generate_key - RSA_free - X509_free - SESSION_get_master_key - get_client_random - get_server_random -); - -sub AUTOLOAD { - # This AUTOLOAD is used to 'autoload' constants from the constant() - # XS function. If a constant is not found then control is passed - # to the AUTOLOAD in AutoLoader. - - my $constname; - ($constname = $AUTOLOAD) =~ s/.*:://; - my $val = constant($constname); - if ($! != 0) { - if ($! =~ /((Invalid)|(not valid))/i || $!{EINVAL}) { - $AutoLoader::AUTOLOAD = $AUTOLOAD; - goto &AutoLoader::AUTOLOAD; - } - else { - croak "Your vendor has not defined SSLeay macro $constname"; - } - } - eval "sub $AUTOLOAD { $val }"; - goto &$AUTOLOAD; -} - -eval { - require XSLoader; - XSLoader::load('Net::SSLeay', $VERSION); - 1; -} or do { - require DynaLoader; - push @ISA, 'DynaLoader'; - bootstrap Net::SSLeay $VERSION; -}; - -# Preloaded methods go here. - -$CRLF = "\x0d\x0a"; # because \r\n is not fully portable - -### Print SSLeay error stack - -sub print_errs { - my ($msg) = @_; - my ($count, $err, $errs, $e) = (0,0,''); - while ($err = ERR_get_error()) { - $count ++; - $e = "$msg $$: $count - " . ERR_error_string($err) . "\n"; - $errs .= $e; - warn $e if $Net::SSLeay::trace; - } - return $errs; -} - -# Death is conditional to SSLeay errors existing, i.e. this function checks -# for errors and only dies in affirmative. -# usage: Net::SSLeay::write($ssl, "foo") or die_if_ssl_error("SSL write ($!)"); - -sub die_if_ssl_error { - my ($msg) = @_; - die "$$: $msg\n" if print_errs($msg); -} - -# Unconditional death. Used to print SSLeay errors before dying. -# usage: Net::SSLeay::connect($ssl) or die_now("Failed SSL connect ($!)"); - -sub die_now { - my ($msg) = @_; - print_errs($msg); - die "$$: $msg\n"; -} - -# Perl 5.6.* unicode support causes that length() no longer reliably -# reflects the byte length of a string. This eval is to fix that. -# Thanks to Sean Burke for the snippet. - -BEGIN{ -eval 'use bytes; sub blength ($) { length $_[0] }'; -$@ and eval ' sub blength ($) { length $_[0] }' ; -} - -# Autoload methods go after =cut, and are processed by the autosplit program. - -1; -__END__ -# Documentation. Use `perl-root/pod/pod2html SSLeay.pm` to output html - -=head1 NAME - -Net::SSLeay - Perl extension for using OpenSSL - -=head1 SYNOPSIS - - use Net::SSLeay qw(get_https post_https sslcat make_headers make_form); - - ($page) = get_https('www.bacus.pt', 443, '/'); # 1 - - ($page, $response, %reply_headers) - = get_https('www.bacus.pt', 443, '/', # 2 - make_headers(User-Agent => 'Cryptozilla/5.0b1', - Referer => 'https://www.bacus.pt' - )); - - ($page, $result, %headers) = # 2b - = get_https('www.bacus.pt', 443, '/protected.html', - make_headers(Authorization => - 'Basic ' . MIME::Base64::encode("$user:$pass",'')) - ); - - ($page, $response, %reply_headers) - = post_https('www.bacus.pt', 443, '/foo.cgi', '', # 3 - make_form(OK => '1', - name => 'Sampo' - )); - - $reply = sslcat($host, $port, $request); # 4 - - ($reply, $err, $server_cert) = sslcat($host, $port, $request); # 5 - - $Net::SSLeay::trace = 2; # 0=no debugging, 1=ciphers, 2=trace, 3=dump data - -=head1 DESCRIPTION - -There is a related module called C<Net::SSLeay::Handle> included in this -distribution that you might want to use instead. It has its own pod -documentation. - -This module offers some high level convinience functions for accessing -web pages on SSL servers (for symmetry, same API is offered for -accessing http servers, too), a C<sslcat()> function for writing your own -clients, and finally access to the SSL api of SSLeay/OpenSSL package -so you can write servers or clients for more complicated applications. - -For high level functions it is most convinient to import them to your -main namespace as indicated in the synopsis. - -Case 1 demonstrates typical invocation of get_https() to fetch an HTML -page from secure server. The first argument provides host name or ip -in dotted decimal notation of the remote server to contact. Second -argument is the TCP port at the remote end (your own port is picked -arbitrarily from high numbered ports as usual for TCP). The third -argument is the URL of the page without the host name part. If in -doubt consult HTTP specifications at L<http://www.w3c.org>. - -Case 2 demonstrates full fledged use of C<get_https()>. As can be seen, -C<get_https()> parses the response and response headers and returns them as -a list, which can be captured in a hash for later reference. Also a -fourth argument to C<get_https()> is used to insert some additional headers -in the request. C<make_headers()> is a function that will convert a list or -hash to such headers. By default C<get_https()> supplies C<Host> (make virtual -hosting easy) and C<Accept> (reportedly needed by IIS) headers. - -Case 2b demonstrates how to get password protected page. Refer to -HTTP protocol specifications for further details (e.g. RFC-2617). - -Case 3 invokes C<post_https()> to submit a HTML/CGI form to secure -server. First four arguments are equal to C<get_https()> (note that empty -string (C<''>) is passed as header argument). The fifth argument is the -contents of the form formatted according to CGI specification. In this -case the helper function C<make_https()> is used to do the formatting, -but you could pass any string. The C<post_https()> automatically adds -C<Content-Type> and C<Content-Length> headers to the request. - -Case 4 shows the fundamental C<sslcat()> function (inspired in spirit by -C<netcat> utility :-). Its your swiss army knife that allows you to -easily contact servers, send some data, and then get the response. You -are responsible for formatting the data and parsing the response - -C<sslcat()> is just a transport. - -Case 5 is a full invocation of C<sslcat()> which allows return of errors -as well as the server (peer) certificate. - -The C<$trace> global variable can be used to control the verbosity of high -level functions. Level 0 guarantees silence, level 1 (the default) -only emits error messages. - -=head2 Alternate versions of the API - -The above mentioned functions actually return the response headers as -a list, which only gets converted to hash upon assignment (this -assignment looses information if the same header occurs twice, as may -be the case with cookies). There are also other variants of the -functions that return unprocessed headers and that return a reference -to a hash. - - ($page, $response, @headers) = get_https('www.bacus.pt', 443, '/'); - for ($i = 0; $i < $#headers; $i+=2) { - print "$headers[$i] = " . $headers[$i+1] . "\n"; - } - - ($page, $response, $headers, $server_cert) - = get_https3('www.bacus.pt', 443, '/'); - print "$headers\n"; - - ($page, $response, %headers_ref, $server_cert) - = get_https4('www.bacus.pt', 443, '/'); - for $k (sort keys %{headers_ref}) { - for $v (@{$headers_ref{$k}}) { - print "$k = $v\n"; - } - } - -All of the above code fragments accomplish the same thing: display all -values of all headers. The API functions ending in "3" return the -headers simply as a scalar string and it is up to the application to -split them up. The functions ending in "4" return a reference to -hash of arrays (see L<perlref> and L<perllol> if you are -not familiar with complex perl data structures). To access single value -of such header hash you would do something like - - print $headers_ref{COOKIE}[0]; - -The variants 3 and 4 also allow you to discover the server certificate -in case you would like to store or display it, e.g. - - ($p, $resp, $hdrs, $server_cert) = get_https3('www.bacus.pt', 443, '/'); - if (!defined($server_cert) || ($server_cert == 0)) { - warn "Subject Name: undefined, Issuer Name: undefined"; - } else { - warn 'Subject Name: ' - . Net::SSLeay::X509_NAME_oneline( - Net::SSLeay::X509_get_subject_name($server_cert)) - . 'Issuer Name: ' - . Net::SSLeay::X509_NAME_oneline( - Net::SSLeay::X509_get_issuer_name($server_cert)); - } - -Beware that this method only allows after the fact verification of -the certificate: by the time C<get_https3()> has returned the https -request has already been sent to the server, whether you decide to -tryst it or not. To do the verification correctly you must either -employ the OpenSSL certificate verification framework or use -the lower level API to first connect and verify the certificate -and only then send the http data. See implementation of C<ds_https3()> -for guidance on how to do this. - -=head2 Using client certificates - -Secure web communications are encrypted using symmetric crypto keys -exchanged using encryption based on the certificate of the -server. Therefore in all SSL connections the server must have a -certificate. This serves both to authenticate the server to the -clients and to perform the key exchange. - -Sometimes it is necessary to authenticate the client as well. Two -options are available: HTTP basic authentication and client side -certificate. The basic authentication over HTTPS is actually quite -safe because HTTPS guarantees that the password will not travel in -clear. Never-the-less, problems like easily guessable passwords -remain. The client certificate method involves authentication of the -client at SSL level using a certificate. For this to work, both the -client and the server will have certificates (which typically are -different) and private keys. - -The API functions outlined above accept additional arguments that -allow one to supply the client side certificate and key files. The -format of these files is the same as used for server certificates and -the caveat about encrypting private key applies. - - ($page, $result, %headers) = # 2c - = get_https('www.bacus.pt', 443, '/protected.html', - make_headers(Authorization => - 'Basic ' . MIME::Base64::encode("$user:$pass",'')), - '', $mime_type6, $path_to_crt7, $path_to_key8); - - ($page, $response, %reply_headers) - = post_https('www.bacus.pt', 443, '/foo.cgi', # 3b - make_headers('Authorization' => - 'Basic ' . MIME::Base64::encode("$user:$pass",'')), - make_form(OK => '1', name => 'Sampo'), - $mime_type6, $path_to_crt7, $path_to_key8); - -Case 2c demonstrates getting password protected page that also requires -client certificate, i.e. it is possible to use both authentication -methods simultaneously. - -Case 3b is full blown post to secure server that requires both password -authentication and client certificate, just like in case 2c. - -Note: Client will not send a certificate unless the server requests one. -This is typically achieved by setting verify mode to C<VERIFY_PEER> on the -server: - - Net::SSLeay::set_verify(ssl, Net::SSLeay::VERIFY_PEER, 0); - -See C<perldoc ~openssl/doc/ssl/SSL_CTX_set_verify.pod> for full description. - -=head2 Working through Web proxy - -C<Net::SSLeay> can use a web proxy to make its connections. You need to -first set the proxy host and port using C<set_proxy()> and then just -use the normal API functions, e.g: - - Net::SSLeay::set_proxy('gateway.myorg.com', 8080); - ($page) = get_https('www.bacus.pt', 443, '/'); - -If your proxy requires authentication, you can supply username and -password as well - - Net::SSLeay::set_proxy('gateway.myorg.com', 8080, 'joe', 'salainen'); - ($page, $result, %headers) = - = get_https('www.bacus.pt', 443, '/protected.html', - make_headers(Authorization => - 'Basic ' . MIME::Base64::encode("susie:pass",'')) - ); - -This example demonstrates case where we authenticate to the proxy as -C<"joe"> and to the final web server as C<"susie">. Proxy authentication -requires C<MIME::Base64> module to work. - -=head2 Certificate verification and Certificate Revoocation Lists (CRLs) - -OpenSSL supports the ability to verify peer certificates. It can also -optionally check the peer certificate against a Certificate Revocation -List (CRL) from the certificates issuer. A CRL is a file, created by -the certificate issuer that lists all the certificates that it -previously signed, but which it now revokes. CRLs are in PEM format. - -You can enable C<Net::SSLeay CRL> checking like this: - - &Net::SSLeay::X509_STORE_CTX_set_flags - (&Net::SSLeay::CTX_get_cert_store($ssl), - &Net::SSLeay::X509_V_FLAG_CRL_CHECK); - -After setting this flag, if OpenSSL checks a peer's certificate, then -it will attempt to find a CRL for the issuer. It does this by looking -for a specially named file in the search directory specified by -CTX_load_verify_locations. CRL files are named with the hash of the -issuer's subject name, followed by C<.r0>, C<.r1> etc. For example -C<ab1331b2.r0>, C<ab1331b2.r1>. It will read all the .r files for the -issuer, and then check for a revocation of the peer cerificate in all -of them. (You can also force it to look in a specific named CRL -file., see below). You can find out the hash of the issuer subject -name in a CRL with - - openssl crl -in crl.pem -hash -noout - -If the peer certificate does not pass the revocation list, or if no -CRL is found, then the handshaking fails with an error. - -You can also force OpenSSL to look for CRLs in one or more arbitrarily -named files. - - my $bio = Net::SSLeay::BIO_new_file($crlfilename, 'r'); - my $crl = Net::SSLeay::PEM_read_bio_X509_CRL($bio); - if ($crl) { - Net::SSLeay::X509_STORE_add_crl(Net::SSLeay::CTX_get_cert_store($ssl, $crl); - } else { - error reading CRL.... - } - - -=head2 Convenience routines - -To be used with Low level API - - Net::SSLeay::randomize($rn_seed_file,$additional_seed); - Net::SSLeay::set_cert_and_key($ctx, $cert_path, $key_path); - $cert = Net::SSLeay::dump_peer_certificate($ssl); - Net::SSLeay::ssl_write_all($ssl, $message) or die "ssl write failure"; - $got = Net::SSLeay::ssl_read_all($ssl) or die "ssl read failure"; - - $got = Net::SSLeay::ssl_read_CRLF($ssl [, $max_length]); - $got = Net::SSLeay::ssl_read_until($ssl [, $delimit [, $max_length]]); - Net::SSLeay::ssl_write_CRLF($ssl, $message); - -C<randomize()> seeds the eay PRNG with C</dev/urandom> (see top of C<SSLeay.pm> -for how to change or configure this) and optionally with user provided -data. It is very important to properly seed your random numbers, so -do not forget to call this. The high level API functions automatically -call C<randomize()> so it is not needed with them. See also caveats. - -C<set_cert_and_key()> takes two file names as arguments and sets -the certificate and private key to those. This can be used to -set either cerver certificates or client certificates. - -C<dump_peer_certificate()> allows you to get plaintext description of the -certificate the peer (usually server) presented to us. - -C<ssl_read_all()> and C<ssl_write_all()> provide true blocking semantics for -these operations (see limitation, below, for explanation). These are -much preferred to the low level API equivalents (which implement BSD -blocking semantics). The message argument to C<ssl_write_all()> can be -reference. This is helpful to avoid unnecessary copy when writing -something big, e.g: - - $data = 'A' x 1000000000; - Net::SSLeay::ssl_write_all($ssl, \$data) or die "ssl write failed"; - -C<ssl_read_CRLF()> uses C<ssl_read_all()> to read in a line terminated with a -carriage return followed by a linefeed (CRLF). The CRLF is included in -the returned scalar. - -C<ssl_read_until()> uses C<ssl_read_all()> to read from the SSL input -stream until it encounters a programmer specified delimiter. -If the delimiter is undefined, C<$/> is used. If C<$/> is undefined, -C<\n> is used. One can optionally set a maximum length of bytes to read -from the SSL input stream. - -C<ssl_write_CRLF()> writes C<$message> and appends CRLF to the SSL output stream. - -=head2 Low level API - -In addition to the high level functions outlined above, this module -contains straight forward access to SSL part of OpenSSL C api. Only the SSL -subpart of OpenSSL is implemented (if anyone wants to implement other -parts, feel free to submit patches). - -See C<ssl.h> header from OpenSSL C distribution for list of low lever -SSLeay functions to call (to check if some function has been -implemented see directly in SSLeay.xs). The module strips SSLeay names -of the initial C<"SSL_">, generally you should use C<Net::SSLeay::> in -place. For example: - -In C: - - #include <ssl.h> - - err = SSL_set_verify (ssl, SSL_VERIFY_CLIENT_ONCE, - &your_call_back_here); - -In Perl: - - use Net::SSLeay; - - $err = Net::SSLeay::set_verify ($ssl, - Net::SSLeay::VERIFY_CLIENT_ONCE, - \&your_call_back_here); - -If the function does not start by C<SSL_> you should use the full -function name, e.g.: - - $err = Net::SSLeay::ERR_get_error; - -Following new functions behave in perlish way: - - $got = Net::SSLeay::read($ssl); - # Performs SSL_read, but returns $got - # resized according to data received. - # Returns undef on failure. - - Net::SSLeay::write($ssl, $foo) || die; - # Performs SSL_write, but automatically - # figures out the size of $foo - -In order to use the low level API you should start your programs with -the following incantation: - - use Net::SSLeay qw(die_now die_if_ssl_error); - Net::SSLeay::load_error_strings(); - Net::SSLeay::SSLeay_add_ssl_algorithms(); # Important! - Net::SSLeay::ENGINE_load_builtin_engines(); # If you want built-in engines - Net::SSLeay::ENGINE_register_all_complete(); # If you want built-in engines - Net::SSLeay::randomize(); - -C<die_now()> and C<die_if_ssl_error()> are used to conveniently print SSLeay error -stack when something goes wrong, thusly: - - Net::SSLeay::connect($ssl) or die_now("Failed SSL connect ($!)"); - Net::SSLeay::write($ssl, "foo") or die_if_ssl_error("SSL write ($!)"); - -You can also use C<Net::SSLeay::print_errs()> to dump the error stack without -exiting the program. As can be seen, your code becomes much more readable -if you import the error reporting functions to your main name space. - -I can not emphasize enough the need to check error returns. Use these -functions even in most simple programs, they will reduce debugging -time greatly. Do not ask questions in mailing list without having -first sprinkled these in your code. - -=head2 Sockets - -Perl uses file handles for all I/O. While SSLeay has quite flexible BIO -mechanism and perl has evolved PerlIO mechanism, this module still -sticks to using file descriptors. Thus to attach SSLeay to socket you -should use C<fileno()> to extract the underlying file descriptor: - - Net::SSLeay::set_fd($ssl, fileno(S)); # Must use fileno - -You should also set C<$|> to 1 to eliminate STDIO buffering so you do not -get confused if you use perl I/O functions to manipulate your socket -handle. - -If you need to C<select(2)> on the socket, go right ahead, but be warned -that OpenSSL does some internal buffering so SSL_read does not always -return data even if socket selected for reading (just keep on -selecting and trying to read). C<Net::SSLeay> is no different from the -C language OpenSSL in this respect. - -=head2 Callbacks - -At this moment the implementation of verify_callback is crippeled in -the sense that at any given time there can be only one call back which -is shared by all SSL contexts, sessions and connections. This is -due to having to keep the reference to the perl call back in a -static variable so that the callback C glue can find it. To remove -this restriction would require either a more complex data structure -(like a hash?) in XSUB to map the call backs to their owners or, -cleaner, adding a context pointer in the SSL structure. This context would -then be passed to the C callback, which in our case would be the glue -to look up the proper Perl function from the context and call it. - ----- inaccurate ---- -The verify call back looks like this in C: - - int (*callback)(int ok,X509 *subj_cert,X509 *issuer_cert, - int depth,int errorcode,char *arg,STACK *cert_chain) - -The corresponding Perl function should be something like this: - - sub verify { - my ($ok, $subj_cert, $issuer_cert, $depth, $errorcode, - $arg, $chain) = @_; - print "Verifying certificate...\n"; - ... - return $ok; - } - -It is used like this: - - Net::SSLeay::set_verify ($ssl, Net::SSLeay::VERIFY_PEER, \&verify); - -Callbacks for decrypting private keys are implemented, but have the -same limitation as the verify_callback implementation (one password -callback shared between all contexts.) You might use it something -like this: - - Net::SSLeay::CTX_set_default_passwd_cb($ctx, sub { "top-secret" }); - Net::SSLeay::CTX_use_PrivateKey_file($ctx, "key.pem", - Net::SSLeay::FILETYPE_PEM) - or die "Error reading private key"; - Net::SSLeay::CTX_set_default_passwd_cb($ctx, undef); - -No other callbacks are implemented. You do not need to use any -callback for simple (i.e. normal) cases where the SSLeay built-in -verify mechanism satisfies your needs. - -It is desirable to reset these callbacks to undef immediately after use to prevent -thread safety problems and crashes on exit that can occur if different threads -set different callbacks. - ----- end inaccurate ---- - -If you want to use callback stuff, see examples/callback.pl! Its the -only one I am able to make work reliably. - -=head2 X509 and RAND stuff - -This module largely lacks interface to the X509 and RAND routines, but -as I was lazy and needed them, the following kludges are implemented: - - $x509_name = Net::SSLeay::X509_get_subject_name($x509_cert); - $x509_name = Net::SSLeay::X509_get_issuer_name($x509_cert); - print Net::SSLeay::X509_NAME_oneline($x509_name); - $text = Net::SSLeay::X509_NAME_get_text_by_NID($name, $nid); - - ($type1, $subject1, $type2, $subject2, ...) = - Net::SSLeay::X509_get_subjectAltNames($x509_cert) - - subjectAltName types as per x509v3.h GEN_*, for example - GEN_DNS or GEN_IPADD which can be imported. - - Net::SSLeay::RAND_seed($buf); # Perlishly figures out buf size - Net::SSLeay::RAND_bytes($buf, $num); - Net::SSLeay::RAND_pseudo_bytes($buf, $num); - Net::SSLeay::RAND_add($buf, $num, $entropy); - Net::SSLeay::RAND_poll(); - Net::SSLeay::RAND_status(); - Net::SSLeay::RAND_cleanup(); - Net::SSLeay::RAND_file_name($num); - Net::SSLeay::RAND_load_file($file_name, $how_many_bytes); - Net::SSLeay::RAND_write_file($file_name); - Net::SSLeay::RAND_egd($path); - Net::SSLeay::RAND_egd_bytes($path, $bytes); - -Actually you should consider using the following helper functions: - - print Net::SSLeay::dump_peer_certificate($ssl); - Net::SSLeay::randomize(); - -=head2 RSA interface - -Some RSA functions are available: - - $rsakey = Net::SSLeay::RSA_generate_key(); - Net::SSLeay::CTX_set_tmp_rsa($ctx, $rsakey); - Net::SSLeay::RSA_free($rsakey); - -=head2 BIO interface - -Some BIO functions are available: - - Net::SSLeay::BIO_s_mem(); - $bio = Net::SSLeay::BIO_new(BIO_s_mem()) - $bio = Net::SSLeay::BIO_new_file($filename, $mode); - Net::SSLeay::BIO_free($bio) - $count = Net::SSLeay::BIO_write($data); - $data = Net::SSLeay::BIO_read($bio); - $data = Net::SSLeay::BIO_read($bio, $maxbytes); - $is_eof = Net::SSLeay::BIO_eof($bio); - $count = Net::SSLeay::BIO_pending($bio); - $count = Net::SSLeay::BIO_wpending ($bio); - -=head2 Low level API - -Some very low level API functions are available: - - $client_random = Net::SSLeay::get_client_random($ssl); - $server_random = Net::SSLeay::get_server_random($ssl); - $session = Net::SSLeay::get_session($ssl); - $master_key = Net::SSLeay::SESSION_get_master_key($session); - Net::SSLeay::SESSION_set_master_key($session, $master_secret); - $keyblocksize = Net::SSLeay::get_keyblock_size($session); - -=head2 HTTP (without S) API - -Over the years it has become clear that it would be convenient to use -the light weight flavour API of C<Net::SSLeay> also for normal HTTP (see -LWP for heavy weight object oriented approach). In fact it would be -nice to be able to flip https on and off on the fly. Thus regular HTTP -support was evolved. - - use Net::SSLeay qw(get_http post_http tcpcat - get_httpx post_httpx tcpxcat - make_headers make_form); - - ($page, $result, %headers) = - = get_http('www.bacus.pt', 443, '/protected.html', - make_headers(Authorization => - 'Basic ' . MIME::Base64::encode("$user:$pass",'')) - ); - - ($page, $response, %reply_headers) - = post_http('www.bacus.pt', 443, '/foo.cgi', '', - make_form(OK => '1', - name => 'Sampo' - )); - - ($reply, $err) = tcpcat($host, $port, $request); - - ($page, $result, %headers) = - = get_httpx($usessl, 'www.bacus.pt', 443, '/protected.html', - make_headers(Authorization => - 'Basic ' . MIME::Base64::encode("$user:$pass",'')) - ); - - ($page, $response, %reply_headers) - = post_httpx($usessl, 'www.bacus.pt', 443, '/foo.cgi', '', - make_form(OK => '1', name => 'Sampo' )); - - ($reply, $err, $server_cert) = tcpxcat($usessl, $host, $port, $request); - -As can be seen, the C<"x"> family of APIs takes as first argument a flag -which indicated whether SSL is used or not. - -=head1 EXAMPLES - -One very good example is to look at the implementation of C<sslcat()> in the -C<SSLeay.pm> file. - -Following is a simple SSLeay client (with too little error checking :-( - - #!/usr/local/bin/perl - use Socket; - use Net::SSLeay qw(die_now die_if_ssl_error) ; - Net::SSLeay::load_error_strings(); - Net::SSLeay::SSLeay_add_ssl_algorithms(); - Net::SSLeay::randomize(); - - ($dest_serv, $port, $msg) = @ARGV; # Read command line - $port = getservbyname ($port, 'tcp') unless $port =~ /^\d+$/; - $dest_ip = gethostbyname ($dest_serv); - $dest_serv_params = sockaddr_in($port, $dest_ip); - - socket (S, &AF_INET, &SOCK_STREAM, 0) or die "socket: $!"; - connect (S, $dest_serv_params) or die "connect: $!"; - select (S); $| = 1; select (STDOUT); # Eliminate STDIO buffering - - # The network connection is now open, lets fire up SSL - - $ctx = Net::SSLeay::CTX_new() or die_now("Failed to create SSL_CTX $!"); - Net::SSLeay::CTX_set_options($ctx, &Net::SSLeay::OP_ALL) - and die_if_ssl_error("ssl ctx set options"); - $ssl = Net::SSLeay::new($ctx) or die_now("Failed to create SSL $!"); - Net::SSLeay::set_fd($ssl, fileno(S)); # Must use fileno - $res = Net::SSLeay::connect($ssl) and die_if_ssl_error("ssl connect"); - print "Cipher `" . Net::SSLeay::get_cipher($ssl) . "'\n"; - - # Exchange data - - $res = Net::SSLeay::write($ssl, $msg); # Perl knows how long $msg is - die_if_ssl_error("ssl write"); - CORE::shutdown S, 1; # Half close --> No more output, sends EOF to server - $got = Net::SSLeay::read($ssl); # Perl returns undef on failure - die_if_ssl_error("ssl read"); - print $got; - - Net::SSLeay::free ($ssl); # Tear down connection - Net::SSLeay::CTX_free ($ctx); - close S; - -Following is a simple SSLeay echo server (non forking): - - #!/usr/local/bin/perl -w - use Socket; - use Net::SSLeay qw(die_now die_if_ssl_error); - Net::SSLeay::load_error_strings(); - Net::SSLeay::SSLeay_add_ssl_algorithms(); - Net::SSLeay::randomize(); - - $our_ip = "\0\0\0\0"; # Bind to all interfaces - $port = 1235; - $sockaddr_template = 'S n a4 x8'; - $our_serv_params = pack ($sockaddr_template, &AF_INET, $port, $our_ip); - - socket (S, &AF_INET, &SOCK_STREAM, 0) or die "socket: $!"; - bind (S, $our_serv_params) or die "bind: $!"; - listen (S, 5) or die "listen: $!"; - $ctx = Net::SSLeay::CTX_new () or die_now("CTX_new ($ctx): $!"); - Net::SSLeay::CTX_set_options($ctx, &Net::SSLeay::OP_ALL) - and die_if_ssl_error("ssl ctx set options"); - - # Following will ask password unless private key is not encrypted - Net::SSLeay::CTX_use_RSAPrivateKey_file ($ctx, 'plain-rsa.pem', - &Net::SSLeay::FILETYPE_PEM); - die_if_ssl_error("private key"); - Net::SSLeay::CTX_use_certificate_file ($ctx, 'plain-cert.pem', - &Net::SSLeay::FILETYPE_PEM); - die_if_ssl_error("certificate"); - - while (1) { - print "Accepting connections...\n"; - ($addr = accept (NS, S)) or die "accept: $!"; - select (NS); $| = 1; select (STDOUT); # Piping hot! - - ($af,$client_port,$client_ip) = unpack($sockaddr_template,$addr); - @inetaddr = unpack('C4',$client_ip); - print "$af connection from " . - join ('.', @inetaddr) . ":$client_port\n"; - - # We now have a network connection, lets fire up SSLeay... - - $ssl = Net::SSLeay::new($ctx) or die_now("SSL_new ($ssl): $!"); - Net::SSLeay::set_fd($ssl, fileno(NS)); - - $err = Net::SSLeay::accept($ssl) and die_if_ssl_error('ssl accept'); - print "Cipher `" . Net::SSLeay::get_cipher($ssl) . "'\n"; - - # Connected. Exchange some data. - - $got = Net::SSLeay::read($ssl); # Returns undef on fail - die_if_ssl_error("ssl read"); - print "Got `$got' (" . length ($got) . " chars)\n"; - - Net::SSLeay::write ($ssl, uc ($got)) or die "write: $!"; - die_if_ssl_error("ssl write"); - - Net::SSLeay::free ($ssl); # Tear down connection - close NS; - } - -Yet another echo server. This one runs from C</etc/inetd.conf> so it avoids -all the socket code overhead. Only caveat is opening rsa key file - -it had better be without any encryption or else it will not know where -to ask for the password. Note how C<STDIN> and C<STDOUT> are wired to SSL. - - #!/usr/local/bin/perl - # /etc/inetd.conf - # ssltst stream tcp nowait root /path/to/server.pl server.pl - # /etc/services - # ssltst 1234/tcp - - use Net::SSLeay qw(die_now die_if_ssl_error); - Net::SSLeay::load_error_strings(); - Net::SSLeay::SSLeay_add_ssl_algorithms(); - Net::SSLeay::randomize(); - - chdir '/key/dir' or die "chdir: $!"; - $| = 1; # Piping hot! - open LOG, ">>/dev/console" or die "Can't open log file $!"; - select LOG; print "server.pl started\n"; - - $ctx = Net::SSLeay::CTX_new() or die_now "CTX_new ($ctx) ($!)"; - $ssl = Net::SSLeay::new($ctx) or die_now "new ($ssl) ($!)"; - Net::SSLeay::set_options($ssl, &Net::SSLeay::OP_ALL) - and die_if_ssl_error("ssl set options"); - - # We get already open network connection from inetd, now we just - # need to attach SSLeay to STDIN and STDOUT - Net::SSLeay::set_rfd($ssl, fileno(STDIN)); - Net::SSLeay::set_wfd($ssl, fileno(STDOUT)); - - Net::SSLeay::use_RSAPrivateKey_file ($ssl, 'plain-rsa.pem', - Net::SSLeay::FILETYPE_PEM); - die_if_ssl_error("private key"); - Net::SSLeay::use_certificate_file ($ssl, 'plain-cert.pem', - Net::SSLeay::FILETYPE_PEM); - die_if_ssl_error("certificate"); - - Net::SSLeay::accept($ssl) and die_if_ssl_err("ssl accept: $!"); - print "Cipher `" . Net::SSLeay::get_cipher($ssl) . "'\n"; - - $got = Net::SSLeay::read($ssl); - die_if_ssl_error("ssl read"); - print "Got `$got' (" . length ($got) . " chars)\n"; - - Net::SSLeay::write ($ssl, uc($got)) or die "write: $!"; - die_if_ssl_error("ssl write"); - - Net::SSLeay::free ($ssl); # Tear down the connection - Net::SSLeay::CTX_free ($ctx); - close LOG; - -There are also a number of example/test programs in the examples directory: - - sslecho.pl - A simple server, not unlike the one above - minicli.pl - Implements a client using low level SSLeay routines - sslcat.pl - Demonstrates using high level sslcat utility function - get_page.pl - Is a utility for getting html pages from secure servers - callback.pl - Demonstrates certificate verification and callback usage - stdio_bulk.pl - Does SSL over Unix pipes - ssl-inetd-serv.pl - SSL server that can be invoked from inetd.conf - httpd-proxy-snif.pl - Utility that allows you to see how a browser - sends https request to given server and what reply - it gets back (very educative :-) - makecert.pl - Creates a self signed cert (does not use this module) - -=head1 LIMITATIONS - -C<Net::SSLeay::read()> uses internal buffer of 32KB, thus no single read -will return more. In practice one read returns much less, usually -as much as fits in one network packet. To work around this, -you should use a loop like this: - - $reply = ''; - while ($got = Net::SSLeay::read($ssl)) { - last if print_errs('SSL_read'); - $reply .= $got; - } - -Although there is no built-in limit in C<Net::SSLeay::write()>, the network -packet size limitation applies here as well, thus use: - - $written = 0; - - while ($written < length($message)) { - $written += Net::SSLeay::write($ssl, substr($message, $written)); - last if print_errs('SSL_write'); - } - -Or alternatively you can just use the following convinence functions: - - Net::SSLeay::ssl_write_all($ssl, $message) or die "ssl write failure"; - $got = Net::SSLeay::ssl_read_all($ssl) or die "ssl read failure"; - -=head1 KNOWN BUGS AND CAVEATS - -Autoloader emits - - Argument "xxx" isn't numeric in entersub at blib/lib/Net/SSLeay.pm' - -warning if die_if_ssl_error is made autoloadable. If you figure out why, -drop me a line. - -Callback set using C<SSL_set_verify()> does not appear to work. This may -well be eay problem (e.g. see C<ssl/ssl_lib.c> line 1029). Try using -C<SSL_CTX_set_verify()> instead and do not be surprised if even this stops -working in future versions. - -Callback and certificate verification stuff is generally too little tested. - -Random numbers are not initialized randomly enough, especially if you -do not have C</dev/random> and/or C</dev/urandom> (such as in Solaris -platforms - but I've been suggested that cryptorand daemon from SUNski -package solves this). In this case you should investigate third party -software that can emulate these devices, e.g. by way of a named pipe -to some program. - -Another gotcha with random number initialization is randomness -depletion. This phenomenon, which has been extensively discussed in -OpenSSL, Apache-SSL, and Apache-mod_ssl forums, can cause your -script to block if you use C</dev/random> or to operate insecurely -if you use C</dev/urandom>. What happens is that when too much -randomness is drawn from the operating system's randomness pool -then randomness can temporarily be unavailable. C</dev/random> solves -this problem by waiting until enough randomness can be gathered - and -this can take a long time since blocking reduces activity in the -machine and less activity provides less random events: a vicious circle. -C</dev/urandom> solves this dilemma more pragmatically by simply returning -predictable "random" numbers. SomeC< /dev/urandom> emulation software -however actually seems to implement C</dev/random> semantics. Caveat emptor. - -I've been pointed to two such daemons by Mik Firestone <mik@@speed.stdio._com> -who has used them on Solaris 8: - -=over - -=item 1 - -Entropy Gathering Daemon (EGD) at L<http://www.lothar.com/tech/crypto/> - -=item 2 - -Pseudo-random number generating daemon (PRNGD) at -L<http://www.aet.tu-cottbus.de/personen/jaenicke/postfix_tls/prngd.html> - -=back - -If you are using the low level API functions to communicate with other -SSL implementations, you would do well to call - - Net::SSLeay::CTX_set_options($ctx, &Net::SSLeay::OP_ALL) - and die_if_ssl_error("ssl ctx set options"); - -to cope with some well know bugs in some other SSL -implementations. The high level API functions always set all known -compatibility options. - -Sometimes C<sslcat()> (and the high level HTTPS functions that build on it) -is too fast in signaling the EOF to legacy HTTPS servers. This causes -the server to return empty page. To work around this problem you can -set global variable - - $Net::SSLeay::slowly = 1; # Add sleep so broken servers can keep up - -HTTP/1.1 is not supported. Specifically this module does not know to -issue or serve multiple http requests per connection. This is a serious -short coming, but using SSL session cache on your server helps to -alleviate the CPU load somewhat. - -As of version 1.09 many newer OpenSSL auxiliary functions were -added (from C<REM_AUTOMATICALLY_GENERATED_1_09> onwards in C<SSLeay.xs>). -Unfortunately I have not had any opportunity to test these. Some of -them are trivial enough that I believe they "just work", but others -have rather complex interfaces with function pointers and all. In these -cases you should proceed wit great caution. - -This module defaults to using OpenSSL automatic protocol negotiation -code for automatically detecting the version of the SSL protocol -that the other end talks. With most web servers this works just -fine, but once in a while I get complaints from people that the module -does not work with some web servers. Usually this can be solved -by explicitly setting the protocol version, e.g. - - $Net::SSLeay::ssl_version = 2; # Insist on SSLv2 - $Net::SSLeay::ssl_version = 3; # Insist on SSLv3 - $Net::SSLeay::ssl_version = 10; # Insist on TLSv1 - -Although the autonegotiation is nice to have, the SSL standards -do not formally specify any such mechanism. Most of the world has -accepted the SSLeay/OpenSSL way of doing it as the de facto standard. But -for the few that think differently, you have to explicitly speak -the correct version. This is not really a bug, but rather a deficiency -in the standards. If a site refuses to respond or sends back some -nonsensical error codes (at SSL handshake level), try this option -before mailing me. - -The high level API returns the certificate of the peer, thus allowing -one to check what certificate was supplied. However, you will only be -able to check the certificate after the fact, i.e. you already sent -your form data by the time you find out that you did not trust them, -oops. - -So, while being able to know the certificate after the fact is surely -useful, the security minded would still choose to do the connection -and certificate verification first and only after that exchange data -with the site. Currently none of the high level API functions do -this, thus you would have to program it using the low level API. A -good place to start is to see how C<Net::SSLeay::http_cat()> function -is implemented. - -The high level API functions use a global file handle C<SSLCAT_S> -internally. This really should not be a problem because there is no -way to interleave the high level API functions, unless you use threads -(but threads are not very well supported in perl anyway (as of version -5.6.1). However, you may run into problems if you call undocumented -internal functions in an interleaved fashion. - -=head1 DIAGNOSTICS - -=over - -=item Random number generator not seeded!!! - -B<(W)> This warning indicates that C<randomize()> was not able to read -C</dev/random> or C</dev/urandom>, possibly because your system does not -have them or they are differently named. You can still use SSL, but -the encryption will not be as strong. - -=item open_tcp_connection: destination host not found:`server' (port 123) ($!) - -Name lookup for host named C<server> failed. - -=item open_tcp_connection: failed `server', 123 ($!) - -The name was resolved, but establising the TCP connection failed. - -=item msg 123: 1 - error:140770F8:SSL routines:SSL23_GET_SERVER_HELLO:unknown proto - -SSLeay error string. First (123) number is PID, second number (1) indicates -the position of the error message in SSLeay error stack. You often see -a pile of these messages as errors cascade. - -=item msg 123: 1 - error:02001002::lib(2) :func(1) :reason(2) - -The same as above, but you didn't call load_error_strings() so SSLeay -couldn't verbosely explain the error. You can still find out what it -means with this command: - - /usr/local/ssl/bin/ssleay errstr 02001002 - -=item Password is being asked for private key - -This is normal behaviour if your private key is encrypted. Either -you have to supply the password or you have to use unencrypted -private key. Scan OpenSSL.org for the FAQ that explains how to -do this (or just study examples/makecert.pl which is used -during C<make test> to do just that). - -=back - -=head1 REPORTING BUGS AND SUPPORT - -Bug reports, patch submission, feature requests, subversion access to the latest -source code etc can be obtained at -L<http://alioth.debian.org/projects/net-ssleay> - -The developer mailing list (for people interested in contributin to the source code) -can be found at -L<http://lists.alioth.debian.org/mailman/listinfo/net-ssleay-devel> - -Commercial support for Net::SSLeay may be obtained from - - Symlabs (netssleay@symlabs.com) - Tel: +351-214.222.630 - Fax: +351-214.222.637 - -=head1 VERSION - -There are currently two perl modules for using OpenSSL C -library: C<Net::SSLeay> (maintaned by me) and C<SSLeay> (maintained by OpenSSL -team). This module is the C<Net::SSLeay> variant. - -At the time of making this release, Eric's module was still quite -sketchy and could not be used for real work, thus I felt motivated to -make this maintenance release. This module is not planned to evolve to -contain any further functionality, i.e. I will concentrate on just -making a simple SSL connection over TCP socket. Presumably Eric's own -module will offer full SSLeay API one day. - -This module uses OpenSSL-0.9.6c. It does not work with any earlier -version and there is no guarantee that it will work with later -versions either, though as long as C API does not change, it -should. This module requires Perl 5.005 or newer, though I -believe it would build with Perl 5.002 or newer. - -=head1 BUGS - -Please report any bugs or feature requests to -C<bug-net_ssleay.pm at rt.cpan.org>, or through the web interface at -L<http://rt.cpan.org/Public/Dist/Display.html?Name=Net_SSLeay.pm>. -I will be notified, and then you'll automatically be notified of progress on -your bug as I make changes. - -=head1 SUPPORT - -You can find documentation for this module with the C<perldoc> command. - - perldoc Net::SSLeay - -You can also look for information at: - -=over 4 - -=item * AnnoCPAN: Annotated CPAN documentation - -L<http://annocpan.org/dist/Net_SSLeay.pm> - -=item * CPAN Ratings - -L<http://cpanratings.perl.org/d/Net_SSLeay.pm> - -=item * RT: CPAN's request tracker - -L<http://rt.cpan.org/Public/Dist/Display.html?Name=Net_SSLeay.pm> - -=item * Search CPAN - -L<http://search.cpan.org/dist/Net_SSLeay.pm> - -=back - -=head1 AUTHOR - -Maintained by Mike McCauley and Florian Ragwitz since November 2005 - -Originally written by Sampo Kellomäki <sampo@symlabs.com> - -=head1 COPYRIGHT - -Copyright (c) 1996-2003 Sampo Kellomäki <sampo@symlabs.com> - -Copyright (C) 2005-2006 Florian Ragwitz <rafl@debian.org> - -Copyright (C) 2005 Mike McCauley <mikem@open.com.au> - -All Rights Reserved. - -Distribution and use of this module is under the same terms as the -OpenSSL package itself (i.e. free, but mandatory attribution; NO -WARRANTY). Please consult LICENSE file in the root of the OpenSSL -distribution. - -While the source distribution of this perl module does not contain -Eric's or OpenSSL's code, if you use this module you will use OpenSSL -library. Please give Eric and OpenSSL team credit (as required by -their licenses). - -And remember, you, and nobody else but you, are responsible for -auditing this module and OpenSSL library for security problems, -backdoors, and general suitability for your application. - -=head1 SEE ALSO - - Net::SSLeay::Handle - File handle interface - ./Net_SSLeay/examples - Example servers and a clients - <http://symlabs.com/Net_SSLeay/index.html> - Net::SSLeay.pm home - <http://symlabs.com/Net_SSLeay/smime.html> - Another module using OpenSSL - <http://www.openssl.org/> - OpenSSL source, documentation, etc - openssl-users-request@openssl.org - General OpenSSL mailing list - <http://home.netscape.com/newsref/std/SSL.html> - SSL Draft specification - <http://www.w3c.org> - HTTP specifications - <http://www.ietf.org/rfc/rfc2617.txt> - How to send password - <http://www.lothar.com/tech/crypto/> - Entropy Gathering Daemon (EGD) - <http://www.aet.tu-cottbus.de/personen/jaenicke/postfix_tls/prngd.html> - - pseudo-random number generating daemon (PRNGD) - perl(1) - perlref(1) - perllol(1) - perldoc ~openssl/doc/ssl/SSL_CTX_set_verify.pod - -=cut - -# '; - -### Some methods that are macros in C - -sub want_nothing { want(shift) == 1 } -sub want_read { want(shift) == 2 } -sub want_write { want(shift) == 3 } -sub want_X509_lookup { want(shift) == 4 } - -### -### Open TCP stream to given host and port, looking up the details -### from system databases or DNS. -### - -sub open_tcp_connection { - my ($dest_serv, $port) = @_; - my ($errs); - - $port = getservbyname($port, 'tcp') unless $port =~ /^\d+$/; - my $dest_serv_ip = gethostbyname($dest_serv); - unless (defined($dest_serv_ip)) { - $errs = "$0 $$: open_tcp_connection: destination host not found:" - . " `$dest_serv' (port $port) ($!)\n"; - warn $errs if $trace; - return wantarray ? (0, $errs) : 0; - } - my $sin = sockaddr_in($port, $dest_serv_ip); - - warn "Opening connection to $dest_serv:$port (" . - inet_ntoa($dest_serv_ip) . ")" if $trace>2; - - my $proto = getprotobyname('tcp'); - if (socket (SSLCAT_S, &PF_INET(), &SOCK_STREAM(), $proto)) { - warn "next connect" if $trace>3; - if (CORE::connect (SSLCAT_S, $sin)) { - my $old_out = select (SSLCAT_S); $| = 1; select ($old_out); - warn "connected to $dest_serv, $port" if $trace>3; - return wantarray ? (1, undef) : 1; # Success - } - } - $errs = "$0 $$: open_tcp_connection: failed `$dest_serv', $port ($!)\n"; - warn $errs if $trace; - close SSLCAT_S; - return wantarray ? (0, $errs) : 0; # Fail -} - -### Open connection via standard web proxy, if one was defined -### using set_proxy(). - -sub open_proxy_tcp_connection { - my ($dest_serv, $port) = @_; - return open_tcp_connection($dest_serv, $port) if !$proxyhost; - - warn "Connect via proxy: $proxyhost:$proxyport" if $trace>2; - my ($ret, $errs) = open_tcp_connection($proxyhost, $proxyport); - return wantarray ? (0, $errs) : 0 if !$ret; # Connection fail - - warn "Asking proxy to connect to $dest_serv:$port" if $trace>2; - #print SSLCAT_S "CONNECT $dest_serv:$port HTTP/1.0$proxyauth$CRLF$CRLF"; - #my $line = <SSLCAT_S>; # *** bug? Mixing stdio with syscall read? - ($ret, $errs) = - tcp_write_all("CONNECT $dest_serv:$port HTTP/1.0$proxyauth$CRLF$CRLF"); - return wantarray ? (0,$errs) : 0 if $errs; - ($line, $errs) = tcp_read_until($CRLF . $CRLF, 1024); - warn "Proxy response: $line" if $trace>2; - return wantarray ? (0,$errs) : 0 if $errs; - return wantarray ? (1,'') : 1; # Success -} - -### -### read and write helpers that block -### - -sub debug_read { - my ($replyr, $gotr) = @_; - my $vm = $trace>2 && $linux_debug ? - (split ' ', `cat /proc/$$/stat`)[22] : 'vm_unknown'; - warn " got " . blength($$gotr) . ':' - . blength($$replyr) . " bytes (VM=$vm).\n" if $trace == 3; - warn " got `$$gotr' (" . blength($$gotr) . ':' - . blength($$replyr) . " bytes, VM=$vm)\n" if $trace>3; -} - -sub ssl_read_all { - my ($ssl,$how_much) = @_; - $how_much = 2000000000 unless $how_much; - my ($got, $errs); - my $reply = ''; - - while ($how_much > 0) { - $got = Net::SSLeay::read($ssl, - ($how_much > 32768) ? 32768 : $how_much - ); - last if $errs = print_errs('SSL_read'); - $how_much -= blength($got); - debug_read(\$reply, \$got) if $trace>1; - last if $got eq ''; # EOF - $reply .= $got; - } - - return wantarray ? ($reply, $errs) : $reply; -} - -sub tcp_read_all { - my ($how_much) = @_; - $how_much = 2000000000 unless $how_much; - my ($n, $got, $errs); - my $reply = ''; - - my $bsize = 0x10000; - while ($how_much > 0) { - $n = sysread(SSLCAT_S,$got, (($bsize < $how_much) ? $bsize : $how_much)); - warn "Read error: $! ($n,$how_much)" unless defined $n; - last if !$n; # EOF - $how_much -= $n; - debug_read(\$reply, \$got) if $trace>1; - $reply .= $got; - } - return wantarray ? ($reply, $errs) : $reply; -} - -sub ssl_write_all { - my $ssl = $_[0]; - my ($data_ref, $errs); - if (ref $_[1]) { - $data_ref = $_[1]; - } else { - $data_ref = \$_[1]; - } - my ($wrote, $written, $to_write) = (0,0, blength($$data_ref)); - my $vm = $trace>2 && $linux_debug ? - (split ' ', `cat /proc/$$/stat`)[22] : 'vm_unknown'; - warn " write_all VM at entry=$vm\n" if $trace>2; - while ($to_write) { - #sleep 1; # *** DEBUG - warn "partial `$$data_ref'\n" if $trace>3; - $wrote = write_partial($ssl, $written, $to_write, $$data_ref); - if (defined $wrote && ($wrote > 0)) { # write_partial can return -1 - $written += $wrote; - $to_write -= $wrote; - } - $vm = $trace>2 && $linux_debug ? - (split ' ', `cat /proc/$$/stat`)[22] : 'vm_unknown'; - warn " written so far $wrote:$written bytes (VM=$vm)\n" if $trace>2; - - $errs .= print_errs('SSL_write'); - return (wantarray ? (undef, $errs) : undef) if $errs; - } - return wantarray ? ($written, $errs) : $written; -} - -sub tcp_write_all { - my ($data_ref, $errs); - if (ref $_[0]) { - $data_ref = $_[0]; - } else { - $data_ref = \$_[0]; - } - my ($wrote, $written, $to_write) = (0,0, blength($$data_ref)); - my $vm = $trace>2 && $linux_debug ? - (split ' ', `cat /proc/$$/stat`)[22] : 'vm_unknown'; - warn " write_all VM at entry=$vm to_write=$to_write\n" if $trace>2; - while ($to_write) { - warn "partial `$$data_ref'\n" if $trace>3; - $wrote = syswrite(SSLCAT_S, $$data_ref, $to_write, $written); - if (defined $wrote && ($wrote > 0)) { # write_partial can return -1 - $written += $wrote; - $to_write -= $wrote; - } elsif (!defined($wrote)) { - warn "tcp_write_all: $!"; - return (wantarray ? (undef, "$!") : undef); - } - $vm = $trace>2 && $linux_debug ? - (split ' ', `cat /proc/$$/stat`)[22] : 'vm_unknown'; - warn " written so far $wrote:$written bytes (VM=$vm)\n" if $trace>2; - } - return wantarray ? ($written, '') : $written; -} - -### from patch by Clinton Wong <clintdw@netcom.com> - -# ssl_read_until($ssl [, $delimit [, $max_length]]) -# if $delimit missing, use $/ if it exists, otherwise use \n -# read until delimiter reached, up to $max_length chars if defined - -sub ssl_read_until ($;$$) { - my ($ssl,$delim, $max_length) = @_; - local $[; - - # guess the delim string if missing - if ( ! defined $delim ) { - if ( defined $/ && length $/ ) { $delim = $/ } - else { $delim = "\n" } # Note: \n,$/ value depends on the platform - } - my $len_delim = length $delim; - - my ($got); - my $reply = ''; - - # If we have OpenSSL 0.9.6a or later, we can use SSL_peek to - # speed things up. - # N.B. 0.9.6a has security problems, so the support for - # anything earlier than 0.9.6e will be dropped soon. - if (&Net::SSLeay::OPENSSL_VERSION_NUMBER >= 0x0090601f) { - $max_length = 2000000000 unless (defined $max_length); - my ($pending, $peek_length, $found, $done); - while (blength($reply) < $max_length and !$done) { - #Block if necessary until we get some data - $got = Net::SSLeay::peek($ssl,1); - last if print_errs('SSL_peek'); - - $pending = Net::SSLeay::pending($ssl) + blength($reply); - $peek_length = ($pending > $max_length) ? $max_length : $pending; - $peek_length -= blength($reply); - $got = Net::SSLeay::peek($ssl, $peek_length); - last if print_errs('SSL_peek'); - $peek_length = blength($got); - - #$found = index($got, $delim); # Old and broken - - # the delimiter may be split across two gets, so we prepend - # a little from the last get onto this one before we check - # for a match - my $match; - if(blength($reply) >= blength($delim) - 1) { - #if what we've read so far is greater or equal - #in length of what we need to prepatch - $match = substr $reply, blength($reply) - blength($delim) + 1; - } else { - $match = $reply; - } - - $match .= $got; - $found = index($match, $delim); - - if ($found > -1) { - #$got = Net::SSLeay::read($ssl, $found+$len_delim); - #read up to the end of the delimiter - $got = Net::SSLeay::read($ssl, - $found + $len_delim - - ((blength $match) - (blength $got))); - $done = 1; - } else { - $got = Net::SSLeay::read($ssl, $peek_length); - $done = 1 if ($peek_length == $max_length - blength($reply)); - } - - last if print_errs('SSL_read'); - debug_read(\$reply, \$got) if $trace>1; - last if $got eq ''; - $reply .= $got; - } - } else { - while (!defined $max_length || length $reply < $max_length) { - $got = Net::SSLeay::read($ssl,1); # one by one - last if print_errs('SSL_read'); - debug_read(\$reply, \$got) if $trace>1; - last if $got eq ''; - $reply .= $got; - last if $len_delim - && substr($reply, blength($reply)-$len_delim) eq $delim; - } - } - return $reply; -} - -sub tcp_read_until { - my ($delim, $max_length) = @_; - local $[; - - # guess the delim string if missing - if ( ! defined $delim ) { - if ( defined $/ && length $/ ) { $delim = $/ } - else { $delim = "\n" } # Note: \n,$/ value depends on the platform - } - my $len_delim = length $delim; - - my ($n,$got); - my $reply = ''; - - while (!defined $max_length || length $reply < $max_length) { - $n = sysread(SSLCAT_S, $got, 1); # one by one - warn "tcp_read_until: $!" if !defined $n; - debug_read(\$reply, \$got) if $trace>1; - last if !$n; # EOF - $reply .= $got; - last if $len_delim - && substr($reply, blength($reply)-$len_delim) eq $delim; - } - return $reply; -} - -# ssl_read_CRLF($ssl [, $max_length]) -sub ssl_read_CRLF ($;$) { ssl_read_until($_[0], $CRLF, $_[1]) } -sub tcp_read_CRLF { tcp_read_until($CRLF, $_[0]) } - -# ssl_write_CRLF($ssl, $message) writes $message and appends CRLF -sub ssl_write_CRLF ($$) { - # the next line uses less memory but might use more network packets - return ssl_write_all($_[0], $_[1]) + ssl_write_all($_[0], $CRLF); - - # the next few lines do the same thing at the expense of memory, with - # the chance that it will use less packets, since CRLF is in the original - # message and won't be sent separately. - - #my $data_ref; - #if (ref $_[1]) { $data_ref = $_[1] } - # else { $data_ref = \$_[1] } - #my $message = $$data_ref . $CRLF; - #return ssl_write_all($_[0], \$message); -} - -sub tcp_write_CRLF { - # the next line uses less memory but might use more network packets - return tcp_write_all($_[0]) + tcp_write_all($CRLF); - - # the next few lines do the same thing at the expense of memory, with - # the chance that it will use less packets, since CRLF is in the original - # message and won't be sent separately. - - #my $data_ref; - #if (ref $_[1]) { $data_ref = $_[1] } - # else { $data_ref = \$_[1] } - #my $message = $$data_ref . $CRLF; - #return tcp_write_all($_[0], \$message); -} - -### Quickly print out with whom we're talking - -sub dump_peer_certificate ($) { - my ($ssl) = @_; - my $cert = get_peer_certificate($ssl); - return if print_errs('get_peer_certificate'); - print "no cert defined\n" if !defined($cert); - # Cipher=NONE with empty cert fix - if (!defined($cert) || ($cert == 0)) { - warn "cert = `$cert'\n" if $trace; - return "Subject Name: undefined\nIssuer Name: undefined\n"; - } else { - my $x = 'Subject Name: ' - . X509_NAME_oneline(X509_get_subject_name($cert)) . "\n" - . 'Issuer Name: ' - . X509_NAME_oneline(X509_get_issuer_name($cert)) . "\n"; - Net::SSLeay::X509_free($cert); - return $x; - } -} - -### Arrange some randomness for eay PRNG - -sub randomize (;$$) { - my ($rn_seed_file, $seed, $egd_path) = @_; - my $rnsf = defined($rn_seed_file) && -r $rn_seed_file; - - $egd_path = ''; - $egd_path = $ENV{'EGD_PATH'} if $ENV{'EGD_PATH'}; - - RAND_seed(rand() + $$); # Stir it with time and pid - - unless ($rnsf || -r $Net::SSLeay::random_device || $seed || -S $egd_path) { - warn "Random number generator not seeded!!!" if $trace; - } - - RAND_load_file($rn_seed_file, -s _) if $rnsf; - RAND_seed($seed) if $seed; - RAND_seed($ENV{RND_SEED}) if $ENV{RND_SEED}; - RAND_egd($egd_path) if -e $egd_path && -S _; - RAND_load_file($Net::SSLeay::random_device, $Net::SSLeay::how_random/8) - if -r $Net::SSLeay::random_device; -} - -sub new_x_ctx { - if ($ssl_version == 2) { $ctx = CTX_v2_new(); } - elsif ($ssl_version == 3) { $ctx = CTX_v3_new(); } - elsif ($ssl_version == 10) { $ctx = CTX_tlsv1_new(); } - else { $ctx = CTX_new(); } - return $ctx; -} - -### -### Basic request - response primitive (don't use for https) -### - -sub sslcat { # address, port, message, $crt, $key --> reply / (reply,errs,cert) - my ($dest_serv, $port, $out_message, $crt_path, $key_path) = @_; - my ($ctx, $ssl, $got, $errs, $written); - - ($got, $errs) = open_proxy_tcp_connection($dest_serv, $port); - return (wantarray ? (undef, $errs) : undef) unless $got; - - ### Do SSL negotiation stuff - - warn "Creating SSL $ssl_version context...\n" if $trace>2; - load_error_strings(); # Some bloat, but I'm after ease of use - SSLeay_add_ssl_algorithms(); # and debuggability. - randomize(); - - $ctx = new_x_ctx(); - goto cleanup2 if $errs = print_errs('CTX_new') or !$ctx; - - CTX_set_options($ctx, &OP_ALL); - goto cleanup2 if $errs = print_errs('CTX_set_options'); - - warn "Cert `$crt_path' given without key" if $crt_path && !$key_path; - set_cert_and_key($ctx, $crt_path, $key_path) if $crt_path; - - warn "Creating SSL connection (context was '$ctx')...\n" if $trace>2; - $ssl = new($ctx); - goto cleanup if $errs = print_errs('SSL_new') or !$ssl; - - warn "Setting fd (ctx $ctx, con $ssl)...\n" if $trace>2; - set_fd($ssl, fileno(SSLCAT_S)); - goto cleanup if $errs = print_errs('set_fd'); - - warn "Entering SSL negotiation phase...\n" if $trace>2; - - if ($trace>2) { - my $i = 0; - my $p = ''; - my $cipher_list = 'Cipher list: '; - $p=Net::SSLeay::get_cipher_list($ssl,$i); - $cipher_list .= $p if $p; - do { - $i++; - $cipher_list .= ', ' . $p if $p; - $p=Net::SSLeay::get_cipher_list($ssl,$i); - } while $p; - $cipher_list .= '\n'; - warn $cipher_list; - } - - $got = Net::SSLeay::connect($ssl); - warn "SSLeay connect returned $got\n" if $trace>2; - goto cleanup if $errs = print_errs('SSL_connect'); - - my $server_cert = get_peer_certificate($ssl); - print_errs('get_peer_certificate'); - if ($trace>1) { - warn "Cipher `" . get_cipher($ssl) . "'\n"; - print_errs('get_ciper'); - warn dump_peer_certificate($ssl); - } - - ### Connected. Exchange some data (doing repeated tries if necessary). - - warn "sslcat $$: sending " . blength($out_message) . " bytes...\n" - if $trace==3; - warn "sslcat $$: sending `$out_message' (" . blength($out_message) - . " bytes)...\n" if $trace>3; - ($written, $errs) = ssl_write_all($ssl, $out_message); - goto cleanup unless $written; - - sleep $slowly if $slowly; # Closing too soon can abort broken servers - CORE::shutdown SSLCAT_S, 1; # Half close --> No more output, send EOF to server - - warn "waiting for reply...\n" if $trace>2; - ($got, $errs) = ssl_read_all($ssl); - warn "Got " . blength($got) . " bytes.\n" if $trace==3; - warn "Got `$got' (" . blength($got) . " bytes)\n" if $trace>3; - -cleanup: - free ($ssl); - $errs .= print_errs('SSL_free'); -cleanup2: - CTX_free ($ctx); - $errs .= print_errs('CTX_free'); - close SSLCAT_S; - return wantarray ? ($got, $errs, $server_cert) : $got; -} - -sub tcpcat { # address, port, message, $crt, $key --> reply / (reply,errs,cert) - my ($dest_serv, $port, $out_message) = @_; - my ($got, $errs, $written); - - ($got, $errs) = open_proxy_tcp_connection($dest_serv, $port); - return (wantarray ? (undef, $errs) : undef) unless $got; - - ### Connected. Exchange some data (doing repeated tries if necessary). - - warn "tcpcat $$: sending " . blength($out_message) . " bytes...\n" - if $trace==3; - warn "tcpcat $$: sending `$out_message' (" . blength($out_message) - . " bytes)...\n" if $trace>3; - ($written, $errs) = tcp_write_all($out_message); - goto cleanup unless $written; - - sleep $slowly if $slowly; # Closing too soon can abort broken servers - CORE::shutdown SSLCAT_S, 1; # Half close --> No more output, send EOF to server - - warn "waiting for reply...\n" if $trace>2; - ($got, $errs) = tcp_read_all($ssl); - warn "Got " . blength($got) . " bytes.\n" if $trace==3; - warn "Got `$got' (" . blength($got) . " bytes)\n" if $trace>3; - -cleanup: - close SSLCAT_S; - return wantarray ? ($got, $errs) : $got; -} - -sub tcpxcat { - my ($usessl, $site, $port, $req, $crt_path, $key_path) = @_; - if ($usessl) { - return sslcat($site, $port, $req, $crt_path, $key_path); - } else { - return tcpcat($site, $port, $req); - } -} - -### -### Basic request - response primitive, this is different from sslcat -### because this does not shutdown the connection. -### - -sub https_cat { # address, port, message --> returns reply / (reply,errs,cert) - my ($dest_serv, $port, $out_message, $crt_path, $key_path) = @_; - my ($ctx, $ssl, $got, $errs, $written); - - ($got, $errs) = open_proxy_tcp_connection($dest_serv, $port); - return (wantarray ? (undef, $errs) : undef) unless $got; - - ### Do SSL negotiation stuff - - warn "Creating SSL $ssl_version context...\n" if $trace>2; - load_error_strings(); # Some bloat, but I'm after ease of use - SSLeay_add_ssl_algorithms(); # and debuggability. - randomize(); - - $ctx = new_x_ctx(); - goto cleanup2 if $errs = print_errs('CTX_new') or !$ctx; - - CTX_set_options($ctx, &OP_ALL); - goto cleanup2 if $errs = print_errs('CTX_set_options'); - - warn "Cert `$crt_path' given without key" if $crt_path && !$key_path; - set_cert_and_key($ctx, $crt_path, $key_path) if $crt_path; - - warn "Creating SSL connection (context was '$ctx')...\n" if $trace>2; - $ssl = new($ctx); - goto cleanup if $errs = print_errs('SSL_new') or !$ssl; - - warn "Setting fd (ctx $ctx, con $ssl)...\n" if $trace>2; - set_fd($ssl, fileno(SSLCAT_S)); - goto cleanup if $errs = print_errs('set_fd'); - - warn "Entering SSL negotiation phase...\n" if $trace>2; - - if ($trace>2) { - my $i = 0; - my $p = ''; - my $cipher_list = 'Cipher list: '; - $p=Net::SSLeay::get_cipher_list($ssl,$i); - $cipher_list .= $p if $p; - do { - $i++; - $cipher_list .= ', ' . $p if $p; - $p=Net::SSLeay::get_cipher_list($ssl,$i); - } while $p; - $cipher_list .= '\n'; - warn $cipher_list; - } - - $got = Net::SSLeay::connect($ssl); - warn "SSLeay connect failed" if $trace>2 && $got==0; - goto cleanup if $errs = print_errs('SSL_connect'); - - my $server_cert = get_peer_certificate($ssl); - print_errs('get_peer_certificate'); - if ($trace>1) { - warn "Cipher `" . get_cipher($ssl) . "'\n"; - print_errs('get_ciper'); - warn dump_peer_certificate($ssl); - } - - ### Connected. Exchange some data (doing repeated tries if necessary). - - warn "https_cat $$: sending " . blength($out_message) . " bytes...\n" - if $trace==3; - warn "https_cat $$: sending `$out_message' (" . blength($out_message) - . " bytes)...\n" if $trace>3; - ($written, $errs) = ssl_write_all($ssl, $out_message); - goto cleanup unless $written; - - warn "waiting for reply...\n" if $trace>2; - ($got, $errs) = ssl_read_all($ssl); - warn "Got " . blength($got) . " bytes.\n" if $trace==3; - warn "Got `$got' (" . blength($got) . " bytes)\n" if $trace>3; - -cleanup: - free ($ssl); - $errs .= print_errs('SSL_free'); -cleanup2: - CTX_free ($ctx); - $errs .= print_errs('CTX_free'); - close SSLCAT_S; - return wantarray ? ($got, $errs, $server_cert) : $got; -} - -sub http_cat { # address, port, message --> returns reply / (reply,errs,cert) - my ($dest_serv, $port, $out_message) = @_; - my ($got, $errs, $written); - - ($got, $errs) = open_proxy_tcp_connection($dest_serv, $port); - return (wantarray ? (undef, $errs) : undef) unless $got; - - ### Connected. Exchange some data (doing repeated tries if necessary). - - warn "http_cat $$: sending " . blength($out_message) . " bytes...\n" - if $trace==3; - warn "http_cat $$: sending `$out_message' (" . blength($out_message) - . " bytes)...\n" if $trace>3; - ($written, $errs) = tcp_write_all($out_message); - goto cleanup unless $written; - - warn "waiting for reply...\n" if $trace>2; - ($got, $errs) = tcp_read_all(200000); - warn "Got " . blength($got) . " bytes.\n" if $trace==3; - warn "Got `$got' (" . blength($got) . " bytes)\n" if $trace>3; - -cleanup: - close SSLCAT_S; - return wantarray ? ($got, $errs) : $got; -} - -sub httpx_cat { - my ($usessl, $site, $port, $req, $crt_path, $key_path) = @_; - warn "httpx_cat: usessl=$usessl ($site:$port)" if $trace; - if ($usessl) { - return https_cat($site, $port, $req, $crt_path, $key_path); - } else { - return http_cat($site, $port, $req); - } -} - -### -### Easy set up of private key and certificate -### - -sub set_cert_and_key ($$$) { - my ($ctx, $cert_path, $key_path) = @_; - my $errs = ''; - # Following will ask password unless private key is not encrypted - CTX_use_RSAPrivateKey_file ($ctx, $key_path, &FILETYPE_PEM); - $errs .= print_errs("private key `$key_path' ($!)"); - CTX_use_certificate_file ($ctx, $cert_path, &FILETYPE_PEM); - $errs .= print_errs("certificate `$cert_path' ($!)"); - return wantarray ? (undef, $errs) : ($errs eq ''); -} - -### Old deprecated API - -sub set_server_cert_and_key ($$$) { &set_cert_and_key } - -### Set up to use web proxy - -sub set_proxy ($$;**) { - ($proxyhost, $proxyport, $proxyuser, $proxypass) = @_; - require MIME::Base64 if $proxyuser; - $proxyauth = $CRLF . 'Proxy-authorization: Basic ' - . MIME::Base64::encode("$proxyuser:$proxypass", '') - if $proxyuser; -} - -### -### Easy https manipulation routines -### - -sub make_form { - my (@fields) = @_; - my $form; - while (@fields) { - my ($name, $data) = (shift(@fields), shift(@fields)); - $data =~ s/([^\w\-.\@\$ ])/sprintf("%%%2.2x",ord($1))/gse; - $data =~ tr[ ][+]; - $form .= "$name=$data&"; - } - chop $form; - return $form; -} - -sub make_headers { - my (@headers) = @_; - my $headers; - while (@headers) { - my $header = shift(@headers); - my $value = shift(@headers); - $header =~ s/:$//; - $value =~ s/\x0d?\x0a$//; # because we add it soon, see below - $headers .= "$header: $value$CRLF"; - } - return $headers; -} - -sub do_httpx3 { - my ($method, $usessl, $site, $port, $path, $headers, - $content, $mime_type, $crt_path, $key_path) = @_; - my ($response, $page, $h,$v); - - if ($content) { - $mime_type = "application/x-www-form-urlencoded" unless $mime_type; - my $len = blength($content); - $content = "Content-Type: $mime_type$CRLF" - . "Content-Length: $len$CRLF$CRLF$content"; - } else { - $content = "$CRLF$CRLF"; - } - my $req = "$method $path HTTP/1.0$CRLF"; - unless (defined $headers && $headers =~ /^Host:/m) { - $req .= "Host: $site"; - unless (($port == 80 && !$usessl) || ($port == 443 && $usessl)) { - $req .= ":$port"; - } - $req .= $CRLF; - } - $req .= (defined $headers ? $headers : '') . "Accept: */*$CRLF$content"; - - warn "do_httpx3($method,$usessl,$site:$port)" if $trace; - my ($http, $errs, $server_cert) - = httpx_cat($usessl, $site, $port, $req, $crt_path, $key_path); - return (undef, "HTTP/1.0 900 NET OR SSL ERROR$CRLF$CRLF$errs") if $errs; - - $http = '' if !defined $http; - ($headers, $page) = split /\s?\n\s?\n/, $http, 2; - warn "headers >$headers< page >>$page<< http >>>$http<<<" if $trace>1; - ($response, $headers) = split /\s?\n/, $headers, 2; - return ($page, $response, $headers, $server_cert); -} - -sub do_https3 { splice(@_,1,0) = 1; do_httpx3; } # Legacy undocumented - -### do_https2() is a legacy version in the sense that it is unable -### to return all instances of duplicate headers. - -sub do_httpx2 { - my ($page, $response, $headers, $server_cert) = &do_httpx3; - X509_free($server_cert) if defined $server_cert; - return ($page, $response, - map( { ($h,$v)=/^(\S+)\:\s*(.*)$/; (uc($h),$v); } - split(/\s?\n/, $headers) - ) - ); -} - -sub do_https2 { splice(@_,1,0) = 1; do_httpx2; } # Legacy undocumented - -### Returns headers as a hash where multiple instances of same header -### are handled correctly. - -sub do_httpx4 { - my ($page, $response, $headers, $server_cert) = &do_httpx3; - X509_free($server_cert) if defined $server_cert; - my %hr = (); - for my $hh (split /\s?\n/, $headers) { - my ($h,$v)=/^(\S+)\:\s*(.*)$/; - push @{$hr{uc($h)}}, $v; - } - return ($page, $response, \%hr); -} - -sub do_https4 { splice(@_,1,0) = 1; do_httpx4; } # Legacy undocumented - -# https - -sub get_https { do_httpx2(GET => 1, @_) } -sub post_https { do_httpx2(POST => 1, @_) } -sub put_https { do_httpx2(PUT => 1, @_) } -sub head_https { do_httpx2(HEAD => 1, @_) } - -sub get_https3 { do_httpx3(GET => 1, @_) } -sub post_https3 { do_httpx3(POST => 1, @_) } -sub put_https3 { do_httpx3(PUT => 1, @_) } -sub head_https3 { do_httpx3(HEAD => 1, @_) } - -sub get_https4 { do_httpx4(GET => 1, @_) } -sub post_https4 { do_httpx4(POST => 1, @_) } -sub put_https4 { do_httpx4(PUT => 1, @_) } -sub head_https4 { do_httpx4(HEAD => 1, @_) } - -# http - -sub get_http { do_httpx2(GET => 0, @_) } -sub post_http { do_httpx2(POST => 0, @_) } -sub put_http { do_httpx2(PUT => 0, @_) } -sub head_http { do_httpx2(HEAD => 0, @_) } - -sub get_http3 { do_httpx3(GET => 0, @_) } -sub post_http3 { do_httpx3(POST => 0, @_) } -sub put_http3 { do_httpx3(PUT => 0, @_) } -sub head_http3 { do_httpx3(HEAD => 0, @_) } - -sub get_http4 { do_httpx4(GET => 0, @_) } -sub post_http4 { do_httpx4(POST => 0, @_) } -sub put_http4 { do_httpx4(PUT => 0, @_) } -sub head_http4 { do_httpx4(HEAD => 0, @_) } - -# Either https or http - -sub get_httpx { do_httpx2(GET => @_) } -sub post_httpx { do_httpx2(POST => @_) } -sub put_httpx { do_httpx2(PUT => @_) } -sub head_httpx { do_httpx2(HEAD => @_) } - -sub get_httpx3 { do_httpx3(GET => @_) } -sub post_httpx3 { do_httpx3(POST => @_) } -sub put_httpx3 { do_httpx3(PUT => @_) } -sub head_httpx3 { do_httpx3(HEAD => @_) } - -sub get_httpx4 { do_httpx4(GET => @_) } -sub post_httpx4 { do_httpx4(POST => @_) } -sub put_httpx4 { do_httpx4(PUT => @_) } -sub head_httpx4 { do_httpx4(HEAD => @_) } - -### Legacy, don't use -# ($page, $respone_or_err, %headers) = do_https(...); - -sub do_https { - my ($site, $port, $path, $method, $headers, - $content, $mime_type, $crt_path, $key_path) = @_; - - do_https2($method, $site, $port, $path, $headers, - $content, $mime_type, $crt_path, $key_path); -} - -1; -__END__ diff --git a/Master/tlpkg/tlperl/lib/Net/SSLeay/Handle.pm b/Master/tlpkg/tlperl/lib/Net/SSLeay/Handle.pm deleted file mode 100755 index d4dfb59f7de..00000000000 --- a/Master/tlpkg/tlperl/lib/Net/SSLeay/Handle.pm +++ /dev/null @@ -1,394 +0,0 @@ -package Net::SSLeay::Handle; - -require 5.005_03; -use strict; - -use Socket; -use Net::SSLeay; - -require Exporter; - -=head1 NAME - -Net::SSLeay::Handle - Perl module that lets SSL (HTTPS) sockets be -handled as standard file handles. - -=head1 SYNOPSIS - - use Net::SSLeay::Handle qw/shutdown/; - my ($host, $port) = ("localhost", 443); - - tie(*SSL, "Net::SSLeay::Handle", $host, $port); - - print SSL "GET / HTTP/1.0\r\n"; - shutdown(\*SSL, 1); - print while (<SSL>); - close SSL; - -=head1 DESCRIPTION - -Net::SSLeay::Handle allows you to request and receive HTTPS web pages -using "old-fashion" file handles as in: - - print SSL "GET / HTTP/1.0\r\n"; - -and - - print while (<SSL>); - -If you export the shutdown routine, then the only extra code that -you need to add to your program is the tie function as in: - - my $socket; - if ($scheme eq "https") { - tie(*S2, "Net::SSLeay::Handle", $host, $port); - $socket = \*S2; - else { - $socket = Net::SSLeay::Handle->make_socket($host, $port); - } - print $socket $request_headers; - ... - -=cut - -use vars qw(@ISA @EXPORT_OK $VERSION); -@ISA = qw(Exporter); -@EXPORT_OK = qw(shutdown); -$VERSION = '0.61'; - -my $Initialized; #-- only _initialize() once -my $Debug = 0; #-- pretty hokey -my %Glob_Ref; #-- used to make unique \*S names for versions < 5.6 - -#== Tie Handle Methods ======================================================== -# -# see perldoc perltie for details. -# -#============================================================================== - -sub TIEHANDLE { - my ($class, $socket, $port) = @_; - $Debug > 10 and print "TIEHANDLE(@{[join ', ', @_]})\n"; - - ref $socket eq "GLOB" or $socket = $class->make_socket($socket, $port); - - $class->_initialize(); - - my $ctx = Net::SSLeay::CTX_new() or die_now("Failed to create SSL_CTX $!"); - my $ssl = Net::SSLeay::new($ctx) or die_now("Failed to create SSL $!"); - - my $fileno = fileno($socket); - - Net::SSLeay::set_fd($ssl, $fileno); # Must use fileno - - my $resp = Net::SSLeay::connect($ssl); - - $Debug and print "Cipher '" . Net::SSLeay::get_cipher($ssl) . "'\n"; - - my $self = bless { - ssl => $ssl, - ctx => $ctx, - socket => $socket, - fileno => $fileno, - }, $class; - - return $self; -} - -sub PRINT { - my $self = shift; - - my $ssl = _get_ssl($self); - my $resp = 0; - for my $msg (@_) { - defined $msg or last; - $resp = Net::SSLeay::write($ssl, $msg) or last; - } - return $resp; -} - -sub READLINE { - my $self = shift; - my $ssl = _get_ssl($self); - if (wantarray) { - my @lines; - while (my $line = Net::SSLeay::ssl_read_until($ssl)) { - push @lines, $line; - } - return @lines; - } else { - my $line = Net::SSLeay::ssl_read_until($ssl); - return $line ? $line : undef; - } -} - -sub READ { - my ($self, $buf, $len, $offset) = \ (@_); - my $ssl = _get_ssl($$self); - defined($$offset) or - return length($$buf = Net::SSLeay::ssl_read_all($ssl, $$len)); - - defined(my $read = Net::SSLeay::ssl_read_all($ssl, $$len)) - or return undef; - - my $buf_len = length($$buf); - $$offset > $buf_len and $$buf .= chr(0) x ($$offset - $buf_len); - substr($$buf, $$offset) = $read; - return length($read); -} - -sub WRITE { - my $self = shift; - my ($buf, $len, $offset) = @_; - $offset = 0 unless defined $offset; - - # Return number of characters written. - my $ssl = $self->_get_ssl(); - return $len if Net::SSLeay::write($ssl, substr($buf, $offset, $len)); - return undef; -} - -sub CLOSE { - my $self = shift; - my $fileno = $self->{fileno}; - $Debug > 10 and print "close($fileno)\n"; - Net::SSLeay::free ($self->{ssl}); - Net::SSLeay::CTX_free ($self->{ctx}); - close $self->{socket}; -} - -sub FILENO { $_[0]->{fileno} } - - -=head1 FUNCTIONS - -=over - -=item shutdown - - shutdown(\*SOCKET, $mode) - -Calls to the main shutdown() don't work with tied sockets created with this -module. This shutdown should be able to distinquish between tied and untied -sockets and do the right thing. - -=cut - -sub shutdown { - my ($obj, @params) = @_; - - my $socket = UNIVERSAL::isa($obj, 'Net::SSLeay::Handle') ? - $obj->{socket} : $obj; - return shutdown($socket, @params); -} - -=item debug - - my $debug = Net::SSLeay::Handle->debug() - Net::SSLeay::Handle->debug(1) - -Get/set debuging mode. Always returns the debug value before the function call. -if an additional argument is given the debug option will be set to this value. - -=cut - -sub debug { - my ($class, $debug) = @_; - my $old_debug = $Debug; - @_ >1 and $Debug = $debug || 0; - return $old_debug; -} - -#=== Internal Methods ========================================================= - -=item make_socket - - my $sock = Net::SSLeay::Handle->make_socket($host, $port); - -Creates a socket that is connected to $post using $port. It uses -$Net::SSLeay::proxyhost and proxyport if set and authentificates itself against -this proxy depending on $Net::SSLeay::proxyauth. It also turns autoflush on for -the created socket. - -=cut - -sub make_socket { - my ($class, $host, $port) = @_; - $Debug > 10 and print "_make_socket(@{[join ', ', @_]})\n"; - $host ||= 'localhost'; - $port ||= 443; - - my $phost = $Net::SSLeay::proxyhost; - my $pport = $Net::SSLeay::proxyhost ? $Net::SSLeay::proxyport : $port; - - my $dest_ip = gethostbyname($phost || $host); - my $host_params = sockaddr_in($pport, $dest_ip); - my $socket = $^V ? undef : $class->_glob_ref("$host:$port"); - - socket($socket, &PF_INET(), &SOCK_STREAM(), 0) or die "socket: $!"; - connect($socket, $host_params) or die "connect: $!"; - - my $old_select = select($socket); $| = 1; select($old_select); - $phost and do { - my $auth = $Net::SSLeay::proxyauth; - my $CRLF = $Net::SSLeay::CRLF; - print $socket "CONNECT $host:$port HTTP/1.0$auth$CRLF$CRLF"; - my $line = <$socket>; - }; - return $socket; -} - -=back - -=cut - -#--- _glob_ref($strings) ------------------------------------------------------ -# -# Create a unique namespace name and return a glob ref to it. Would be great -# to use the fileno but need this before we get back the fileno. -# NEED TO LOCK THIS ROUTINE IF USING THREADS. (but it is only used for -# versions < 5.6 :) -#------------------------------------------------------------------------------ - -sub _glob_ref { - my $class = shift; - my $preamb = join("", @_) || "_glob_ref"; - my $num = ++$Glob_Ref{$preamb}; - my $name = "$preamb:$num"; - no strict 'refs'; - my $glob_ref = \*$name; - use strict 'refs'; - - $Debug and do { - print "GLOB_REF $preamb\n"; - while (my ($k, $v) = each %Glob_Ref) {print "$k = $v\n"} - print "\n"; - }; - - return $glob_ref; -} - -sub _initialize { - $Initialized++ and return; - Net::SSLeay::load_error_strings(); - Net::SSLeay::SSLeay_add_ssl_algorithms(); - Net::SSLeay::randomize(); -} - -sub __dummy { - my $host = $Net::SSLeay::proxyhost; - my $port = $Net::SSLeay::proxyport; - my $auth = $Net::SSLeay::proxyauth; -} - -#--- _get_self($socket) ------------------------------------------------------- -# Returns a hash containing attributes for $socket (= \*SOMETHING) based -# on fileno($socket). Will return undef if $socket was not created here. -#------------------------------------------------------------------------------ - -sub _get_self { return $_[0]; } - -#--- _get_ssl($socket) -------------------------------------------------------- -# Returns a the "ssl" attribute for $socket (= \*SOMETHING) based -# on fileno($socket). Will cause a warning and return undef if $socket was not -# created here. -#------------------------------------------------------------------------------ - -sub _get_ssl { - return $_[0]->{ssl}; -} - -1; - -__END__ - -=head2 USING EXISTING SOCKETS - -One of the motivations for writing this module was to avoid -duplicating socket creation code (which is mostly error handling). -The calls to tie() above where it is passed a $host and $port is -provided for convenience testing. If you already have a socket -connected to the right host and port, S1, then you can do something -like: - - my $socket \*S1; - if ($scheme eq "https") { - tie(*S2, "Net::SSLeay::Handle", $socket); - $socket = \*S2; - } - my $last_sel = select($socket); $| = 1; select($last_sel); - print $socket $request_headers; - ... - -Note: As far as I know you must be careful with the globs in the tie() -function. The first parameter must be a glob (*SOMETHING) and the -last parameter must be a reference to a glob (\*SOMETHING_ELSE) or a -scaler that was assigned to a reference to a glob (as in the example -above) - -Also, the two globs must be different. When I tried to use the same -glob, I got a core dump. - -=head2 EXPORT - -None by default. - -You can export the shutdown() function. - -It is suggested that you do export shutdown() or use the fully -qualified Net::SSLeay::Handle::shutdown() function to shutdown SSL -sockets. It should be smart enough to distinguish between SSL and -non-SSL sockets and do the right thing. - -=head1 EXAMPLES - - use Net::SSLeay::Handle qw/shutdown/; - my ($host, $port) = ("localhost", 443); - - tie(*SSL, "Net::SSLeay::Handle", $host, $port); - - print SSL "GET / HTTP/1.0\r\n"; - shutdown(\*SSL, 1); - print while (<SSL>); - close SSL; - -=head1 TODO - -Better error handling. Callback routine? - -=head1 CAVEATS - -Tying to a file handle is a little tricky (for me at least). - -The first parameter to tie() must be a glob (*SOMETHING) and the last -parameter must be a reference to a glob (\*SOMETHING_ELSE) or a scaler -that was assigned to a reference to a glob ($s = \*SOMETHING_ELSE). -Also, the two globs must be different. When I tried to use the same -glob, I got a core dump. - -I was able to associate attributes to globs created by this module -(like *SSL above) by making a hash of hashes keyed by the file head1. - -Support for old perls may not be 100%. If in trouble try 5.6.0 or -newer. - -=head1 CHANGES - -Please see Net-SSLeay-Handle-0.50/Changes file. - -=head1 KNOWN BUGS - -If you let this module construct sockets for you with Perl versions -below v.5.6 then there is a slight memory leak. Other upgrade your -Perl, or create the sockets yourself. The leak was created to let -these older versions of Perl access more than one Handle at a time. - -=head1 AUTHOR - -Jim Bowlin jbowlin@linklint.org - -=head1 SEE ALSO - -Net::SSLeay, perl(1), http://openssl.org/ - -=cut diff --git a/Master/tlpkg/tlperl/lib/Net/Time.pm b/Master/tlpkg/tlperl/lib/Net/Time.pm deleted file mode 100755 index 6f1dd04586e..00000000000 --- a/Master/tlpkg/tlperl/lib/Net/Time.pm +++ /dev/null @@ -1,151 +0,0 @@ -# Net::Time.pm -# -# Copyright (c) 1995-2004 Graham Barr <gbarr@pobox.com>. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package Net::Time; - -use strict; -use vars qw($VERSION @ISA @EXPORT_OK $TIMEOUT); -use Carp; -use IO::Socket; -require Exporter; -use Net::Config; -use IO::Select; - -@ISA = qw(Exporter); -@EXPORT_OK = qw(inet_time inet_daytime); - -$VERSION = "2.10"; - -$TIMEOUT = 120; - - -sub _socket { - my ($pname, $pnum, $host, $proto, $timeout) = @_; - - $proto ||= 'udp'; - - my $port = (getservbyname($pname, $proto))[2] || $pnum; - - my $hosts = defined $host ? [$host] : $NetConfig{$pname . '_hosts'}; - - my $me; - - foreach $host (@$hosts) { - $me = IO::Socket::INET->new( - PeerAddr => $host, - PeerPort => $port, - Proto => $proto - ) - and last; - } - - return unless $me; - - $me->send("\n") - if $proto eq 'udp'; - - $timeout = $TIMEOUT - unless defined $timeout; - - IO::Select->new($me)->can_read($timeout) - ? $me - : undef; -} - - -sub inet_time { - my $s = _socket('time', 37, @_) || return undef; - my $buf = ''; - my $offset = 0 | 0; - - return undef - unless defined $s->recv($buf, length(pack("N", 0))); - - # unpack, we | 0 to ensure we have an unsigned - my $time = (unpack("N", $buf))[0] | 0; - - # the time protocol return time in seconds since 1900, convert - # it to a the required format - - if ($^O eq "MacOS") { - - # MacOS return seconds since 1904, 1900 was not a leap year. - $offset = (4 * 31536000) | 0; - } - else { - - # otherwise return seconds since 1972, there were 17 leap years between - # 1900 and 1972 - $offset = (70 * 31536000 + 17 * 86400) | 0; - } - - $time - $offset; -} - - -sub inet_daytime { - my $s = _socket('daytime', 13, @_) || return undef; - my $buf = ''; - - defined($s->recv($buf, 1024)) - ? $buf - : undef; -} - -1; - -__END__ - -=head1 NAME - -Net::Time - time and daytime network client interface - -=head1 SYNOPSIS - - use Net::Time qw(inet_time inet_daytime); - - print inet_time(); # use default host from Net::Config - print inet_time('localhost'); - print inet_time('localhost', 'tcp'); - - print inet_daytime(); # use default host from Net::Config - print inet_daytime('localhost'); - print inet_daytime('localhost', 'tcp'); - -=head1 DESCRIPTION - -C<Net::Time> provides subroutines that obtain the time on a remote machine. - -=over 4 - -=item inet_time ( [HOST [, PROTOCOL [, TIMEOUT]]]) - -Obtain the time on C<HOST>, or some default host if C<HOST> is not given -or not defined, using the protocol as defined in RFC868. The optional -argument C<PROTOCOL> should define the protocol to use, either C<tcp> or -C<udp>. The result will be a time value in the same units as returned -by time() or I<undef> upon failure. - -=item inet_daytime ( [HOST [, PROTOCOL [, TIMEOUT]]]) - -Obtain the time on C<HOST>, or some default host if C<HOST> is not given -or not defined, using the protocol as defined in RFC867. The optional -argument C<PROTOCOL> should define the protocol to use, either C<tcp> or -C<udp>. The result will be an ASCII string or I<undef> upon failure. - -=back - -=head1 AUTHOR - -Graham Barr <gbarr@pobox.com> - -=head1 COPYRIGHT - -Copyright (c) 1995-2004 Graham Barr. All rights reserved. -This program is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/Master/tlpkg/tlperl/lib/Net/hostent.pm b/Master/tlpkg/tlperl/lib/Net/hostent.pm deleted file mode 100755 index 3a2fc013877..00000000000 --- a/Master/tlpkg/tlperl/lib/Net/hostent.pm +++ /dev/null @@ -1,151 +0,0 @@ -package Net::hostent; -use strict; - -use 5.006_001; -our $VERSION = '1.01'; -our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); -BEGIN { - use Exporter (); - @EXPORT = qw(gethostbyname gethostbyaddr gethost); - @EXPORT_OK = qw( - $h_name @h_aliases - $h_addrtype $h_length - @h_addr_list $h_addr - ); - %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); -} -use vars @EXPORT_OK; - -# Class::Struct forbids use of @ISA -sub import { goto &Exporter::import } - -use Class::Struct qw(struct); -struct 'Net::hostent' => [ - name => '$', - aliases => '@', - addrtype => '$', - 'length' => '$', - addr_list => '@', -]; - -sub addr { shift->addr_list->[0] } - -sub populate (@) { - return unless @_; - my $hob = new(); - $h_name = $hob->[0] = $_[0]; - @h_aliases = @{ $hob->[1] } = split ' ', $_[1]; - $h_addrtype = $hob->[2] = $_[2]; - $h_length = $hob->[3] = $_[3]; - $h_addr = $_[4]; - @h_addr_list = @{ $hob->[4] } = @_[ (4 .. $#_) ]; - return $hob; -} - -sub gethostbyname ($) { populate(CORE::gethostbyname(shift)) } - -sub gethostbyaddr ($;$) { - my ($addr, $addrtype); - $addr = shift; - require Socket unless @_; - $addrtype = @_ ? shift : Socket::AF_INET(); - populate(CORE::gethostbyaddr($addr, $addrtype)) -} - -sub gethost($) { - if ($_[0] =~ /^\d+(?:\.\d+(?:\.\d+(?:\.\d+)?)?)?$/) { - require Socket; - &gethostbyaddr(Socket::inet_aton(shift)); - } else { - &gethostbyname; - } -} - -1; -__END__ - -=head1 NAME - -Net::hostent - by-name interface to Perl's built-in gethost*() functions - -=head1 SYNOPSIS - - use Net::hostent; - -=head1 DESCRIPTION - -This module's default exports override the core gethostbyname() and -gethostbyaddr() functions, replacing them with versions that return -"Net::hostent" objects. This object has methods that return the similarly -named structure field name from the C's hostent structure from F<netdb.h>; -namely name, aliases, addrtype, length, and addr_list. The aliases and -addr_list methods return array reference, the rest scalars. The addr -method is equivalent to the zeroth element in the addr_list array -reference. - -You may also import all the structure fields directly into your namespace -as regular variables using the :FIELDS import tag. (Note that this still -overrides your core functions.) Access these fields as variables named -with a preceding C<h_>. Thus, C<$host_obj-E<gt>name()> corresponds to -$h_name if you import the fields. Array references are available as -regular array variables, so for example C<@{ $host_obj-E<gt>aliases() -}> would be simply @h_aliases. - -The gethost() function is a simple front-end that forwards a numeric -argument to gethostbyaddr() by way of Socket::inet_aton, and the rest -to gethostbyname(). - -To access this functionality without the core overrides, -pass the C<use> an empty import list, and then access -function functions with their full qualified names. -On the other hand, the built-ins are still available -via the C<CORE::> pseudo-package. - -=head1 EXAMPLES - - use Net::hostent; - use Socket; - - @ARGV = ('netscape.com') unless @ARGV; - - for $host ( @ARGV ) { - - unless ($h = gethost($host)) { - warn "$0: no such host: $host\n"; - next; - } - - printf "\n%s is %s%s\n", - $host, - lc($h->name) eq lc($host) ? "" : "*really* ", - $h->name; - - print "\taliases are ", join(", ", @{$h->aliases}), "\n" - if @{$h->aliases}; - - if ( @{$h->addr_list} > 1 ) { - my $i; - for $addr ( @{$h->addr_list} ) { - printf "\taddr #%d is [%s]\n", $i++, inet_ntoa($addr); - } - } else { - printf "\taddress is [%s]\n", inet_ntoa($h->addr); - } - - if ($h = gethostbyaddr($h->addr)) { - if (lc($h->name) ne lc($host)) { - printf "\tThat addr reverses to host %s!\n", $h->name; - $host = $h->name; - redo; - } - } - } - -=head1 NOTE - -While this class is currently implemented using the Class::Struct -module to build a struct-like class, you shouldn't rely upon this. - -=head1 AUTHOR - -Tom Christiansen diff --git a/Master/tlpkg/tlperl/lib/Net/libnetFAQ.pod b/Master/tlpkg/tlperl/lib/Net/libnetFAQ.pod deleted file mode 100755 index e6ec362f36a..00000000000 --- a/Master/tlpkg/tlperl/lib/Net/libnetFAQ.pod +++ /dev/null @@ -1,303 +0,0 @@ -=head1 NAME - -libnetFAQ - libnet Frequently Asked Questions - -=head1 DESCRIPTION - -=head2 Where to get this document - -This document is distributed with the libnet distribution, and is also -available on the libnet web page at - - http://search.cpan.org/~gbarr/libnet/ - -=head2 How to contribute to this document - -You may mail corrections, additions, and suggestions to me -gbarr@pobox.com. - -=head1 Author and Copyright Information - -Copyright (c) 1997-1998 Graham Barr. All rights reserved. -This document is free; you can redistribute it and/or modify it -under the terms of the Artistic License. - -=head2 Disclaimer - -This information is offered in good faith and in the hope that it may -be of use, but is not guaranteed to be correct, up to date, or suitable -for any particular purpose whatsoever. The authors accept no liability -in respect of this information or its use. - - -=head1 Obtaining and installing libnet - -=head2 What is libnet ? - -libnet is a collection of perl5 modules which all related to network -programming. The majority of the modules available provided the -client side of popular server-client protocols that are used in -the internet community. - -=head2 Which version of perl do I need ? - -libnet has been know to work with versions of perl from 5.002 onwards. However -if your release of perl is prior to perl5.004 then you will need to -obtain and install the IO distribution from CPAN. If you have perl5.004 -or later then you will have the IO modules in your installation already, -but CPAN may contain updates. - -=head2 What other modules do I need ? - -The only modules you will need installed are the modules from the IO -distribution. If you have perl5.004 or later you will already have -these modules. - -=head2 What machines support libnet ? - -libnet itself is an entirely perl-code distribution so it should work -on any machine that perl runs on. However IO may not work -with some machines and earlier releases of perl. But this -should not be the case with perl version 5.004 or later. - -=head2 Where can I get the latest libnet release - -The latest libnet release is always on CPAN, you will find it -in - - http://www.cpan.org/modules/by-module/Net/ - -The latest release and information is also available on the libnet web page -at - - http://search.cpan.org/~gbarr/libnet/ - -=head1 Using Net::FTP - -=head2 How do I download files from an FTP server ? - -An example taken from an article posted to comp.lang.perl.misc - - #!/your/path/to/perl - - # a module making life easier - - use Net::FTP; - - # for debugging: $ftp = Net::FTP->new('site','Debug',10); - # open a connection and log in! - - $ftp = Net::FTP->new('target_site.somewhere.xxx'); - $ftp->login('username','password'); - - # set transfer mode to binary - - $ftp->binary(); - - # change the directory on the ftp site - - $ftp->cwd('/some/path/to/somewhere/'); - - foreach $name ('file1', 'file2', 'file3') { - - # get's arguments are in the following order: - # ftp server's filename - # filename to save the transfer to on the local machine - # can be simply used as get($name) if you want the same name - - $ftp->get($name,$name); - } - - # ftp done! - - $ftp->quit; - -=head2 How do I transfer files in binary mode ? - -To transfer files without <LF><CR> translation Net::FTP provides -the C<binary> method - - $ftp->binary; - -=head2 How can I get the size of a file on a remote FTP server ? - -=head2 How can I get the modification time of a file on a remote FTP server ? - -=head2 How can I change the permissions of a file on a remote server ? - -The FTP protocol does not have a command for changing the permissions -of a file on the remote server. But some ftp servers may allow a chmod -command to be issued via a SITE command, eg - - $ftp->quot('site chmod 0777',$filename); - -But this is not guaranteed to work. - -=head2 Can I do a reget operation like the ftp command ? - -=head2 How do I get a directory listing from an FTP server ? - -=head2 Changing directory to "" does not fail ? - -Passing an argument of "" to ->cwd() has the same affect of calling ->cwd() -without any arguments. Turn on Debug (I<See below>) and you will see what is -happening - - $ftp = Net::FTP->new($host, Debug => 1); - $ftp->login; - $ftp->cwd(""); - -gives - - Net::FTP=GLOB(0x82196d8)>>> CWD / - Net::FTP=GLOB(0x82196d8)<<< 250 CWD command successful. - -=head2 I am behind a SOCKS firewall, but the Firewall option does not work ? - -The Firewall option is only for support of one type of firewall. The type -supported is an ftp proxy. - -To use Net::FTP, or any other module in the libnet distribution, -through a SOCKS firewall you must create a socks-ified perl executable -by compiling perl with the socks library. - -=head2 I am behind an FTP proxy firewall, but cannot access machines outside ? - -Net::FTP implements the most popular ftp proxy firewall approach. The scheme -implemented is that where you log in to the firewall with C<user@hostname> - -I have heard of one other type of firewall which requires a login to the -firewall with an account, then a second login with C<user@hostname>. You can -still use Net::FTP to traverse these firewalls, but a more manual approach -must be taken, eg - - $ftp = Net::FTP->new($firewall) or die $@; - $ftp->login($firewall_user, $firewall_passwd) or die $ftp->message; - $ftp->login($ext_user . '@' . $ext_host, $ext_passwd) or die $ftp->message. - -=head2 My ftp proxy firewall does not listen on port 21 - -FTP servers usually listen on the same port number, port 21, as any other -FTP server. But there is no reason why this has to be the case. - -If you pass a port number to Net::FTP then it assumes this is the port -number of the final destination. By default Net::FTP will always try -to connect to the firewall on port 21. - -Net::FTP uses IO::Socket to open the connection and IO::Socket allows -the port number to be specified as part of the hostname. So this problem -can be resolved by either passing a Firewall option like C<"hostname:1234"> -or by setting the C<ftp_firewall> option in Net::Config to be a string -in in the same form. - -=head2 Is it possible to change the file permissions of a file on an FTP server ? - -The answer to this is "maybe". The FTP protocol does not specify a command to change -file permissions on a remote host. However many servers do allow you to run the -chmod command via the C<SITE> command. This can be done with - - $ftp->site('chmod','0775',$file); - -=head2 I have seen scripts call a method message, but cannot find it documented ? - -Net::FTP, like several other packages in libnet, inherits from Net::Cmd, so -all the methods described in Net::Cmd are also available on Net::FTP -objects. - -=head2 Why does Net::FTP not implement mput and mget methods - -The quick answer is because they are easy to implement yourself. The long -answer is that to write these in such a way that multiple platforms are -supported correctly would just require too much code. Below are -some examples how you can implement these yourself. - -sub mput { - my($ftp,$pattern) = @_; - foreach my $file (glob($pattern)) { - $ftp->put($file) or warn $ftp->message; - } -} - -sub mget { - my($ftp,$pattern) = @_; - foreach my $file ($ftp->ls($pattern)) { - $ftp->get($file) or warn $ftp->message; - } -} - - -=head1 Using Net::SMTP - -=head2 Why can't the part of an Email address after the @ be used as the hostname ? - -The part of an Email address which follows the @ is not necessarily a hostname, -it is a mail domain. To find the name of a host to connect for a mail domain -you need to do a DNS MX lookup - -=head2 Why does Net::SMTP not do DNS MX lookups ? - -Net::SMTP implements the SMTP protocol. The DNS MX lookup is not part -of this protocol. - -=head2 The verify method always returns true ? - -Well it may seem that way, but it does not. The verify method returns true -if the command succeeded. If you pass verify an address which the -server would normally have to forward to another machine, the command -will succeed with something like - - 252 Couldn't verify <someone@there> but will attempt delivery anyway - -This command will fail only if you pass it an address in a domain -the server directly delivers for, and that address does not exist. - -=head1 Debugging scripts - -=head2 How can I debug my scripts that use Net::* modules ? - -Most of the libnet client classes allow options to be passed to the -constructor, in most cases one option is called C<Debug>. Passing -this option with a non-zero value will turn on a protocol trace, which -will be sent to STDERR. This trace can be useful to see what commands -are being sent to the remote server and what responses are being -received back. - - #!/your/path/to/perl - - use Net::FTP; - - my $ftp = new Net::FTP($host, Debug => 1); - $ftp->login('gbarr','password'); - $ftp->quit; - -this script would output something like - - Net::FTP: Net::FTP(2.22) - Net::FTP: Exporter - Net::FTP: Net::Cmd(2.0801) - Net::FTP: IO::Socket::INET - Net::FTP: IO::Socket(1.1603) - Net::FTP: IO::Handle(1.1504) - - Net::FTP=GLOB(0x8152974)<<< 220 imagine FTP server (Version wu-2.4(5) Tue Jul 29 11:17:18 CDT 1997) ready. - Net::FTP=GLOB(0x8152974)>>> user gbarr - Net::FTP=GLOB(0x8152974)<<< 331 Password required for gbarr. - Net::FTP=GLOB(0x8152974)>>> PASS .... - Net::FTP=GLOB(0x8152974)<<< 230 User gbarr logged in. Access restrictions apply. - Net::FTP=GLOB(0x8152974)>>> QUIT - Net::FTP=GLOB(0x8152974)<<< 221 Goodbye. - -The first few lines tell you the modules that Net::FTP uses and their versions, -this is useful data to me when a user reports a bug. The last seven lines -show the communication with the server. Each line has three parts. The first -part is the object itself, this is useful for separating the output -if you are using multiple objects. The second part is either C<<<<<> to -show data coming from the server or C<>>>>> to show data -going to the server. The remainder of the line is the command -being sent or response being received. - -=head1 AUTHOR AND COPYRIGHT - -Copyright (c) 1997 Graham Barr. -All rights reserved. - diff --git a/Master/tlpkg/tlperl/lib/Net/netent.pm b/Master/tlpkg/tlperl/lib/Net/netent.pm deleted file mode 100755 index f7d32cb9254..00000000000 --- a/Master/tlpkg/tlperl/lib/Net/netent.pm +++ /dev/null @@ -1,169 +0,0 @@ -package Net::netent; -use strict; - -use 5.006_001; -our $VERSION = '1.00'; -our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); -BEGIN { - use Exporter (); - @EXPORT = qw(getnetbyname getnetbyaddr getnet); - @EXPORT_OK = qw( - $n_name @n_aliases - $n_addrtype $n_net - ); - %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); -} -use vars @EXPORT_OK; - -# Class::Struct forbids use of @ISA -sub import { goto &Exporter::import } - -use Class::Struct qw(struct); -struct 'Net::netent' => [ - name => '$', - aliases => '@', - addrtype => '$', - net => '$', -]; - -sub populate (@) { - return unless @_; - my $nob = new(); - $n_name = $nob->[0] = $_[0]; - @n_aliases = @{ $nob->[1] } = split ' ', $_[1]; - $n_addrtype = $nob->[2] = $_[2]; - $n_net = $nob->[3] = $_[3]; - return $nob; -} - -sub getnetbyname ($) { populate(CORE::getnetbyname(shift)) } - -sub getnetbyaddr ($;$) { - my ($net, $addrtype); - $net = shift; - require Socket if @_; - $addrtype = @_ ? shift : Socket::AF_INET(); - populate(CORE::getnetbyaddr($net, $addrtype)) -} - -sub getnet($) { - if ($_[0] =~ /^\d+(?:\.\d+(?:\.\d+(?:\.\d+)?)?)?$/) { - require Socket; - &getnetbyaddr(Socket::inet_aton(shift)); - } else { - &getnetbyname; - } -} - -1; -__END__ - -=head1 NAME - -Net::netent - by-name interface to Perl's built-in getnet*() functions - -=head1 SYNOPSIS - - use Net::netent qw(:FIELDS); - getnetbyname("loopback") or die "bad net"; - printf "%s is %08X\n", $n_name, $n_net; - - use Net::netent; - - $n = getnetbyname("loopback") or die "bad net"; - { # there's gotta be a better way, eh? - @bytes = unpack("C4", pack("N", $n->net)); - shift @bytes while @bytes && $bytes[0] == 0; - } - printf "%s is %08X [%d.%d.%d.%d]\n", $n->name, $n->net, @bytes; - -=head1 DESCRIPTION - -This module's default exports override the core getnetbyname() and -getnetbyaddr() functions, replacing them with versions that return -"Net::netent" objects. This object has methods that return the similarly -named structure field name from the C's netent structure from F<netdb.h>; -namely name, aliases, addrtype, and net. The aliases -method returns an array reference, the rest scalars. - -You may also import all the structure fields directly into your namespace -as regular variables using the :FIELDS import tag. (Note that this still -overrides your core functions.) Access these fields as variables named -with a preceding C<n_>. Thus, C<$net_obj-E<gt>name()> corresponds to -$n_name if you import the fields. Array references are available as -regular array variables, so for example C<@{ $net_obj-E<gt>aliases() -}> would be simply @n_aliases. - -The getnet() function is a simple front-end that forwards a numeric -argument to getnetbyaddr(), and the rest -to getnetbyname(). - -To access this functionality without the core overrides, -pass the C<use> an empty import list, and then access -function functions with their full qualified names. -On the other hand, the built-ins are still available -via the C<CORE::> pseudo-package. - -=head1 EXAMPLES - -The getnet() functions do this in the Perl core: - - sv_setiv(sv, (I32)nent->n_net); - -The gethost() functions do this in the Perl core: - - sv_setpvn(sv, hent->h_addr, len); - -That means that the address comes back in binary for the -host functions, and as a regular perl integer for the net ones. -This seems a bug, but here's how to deal with it: - - use strict; - use Socket; - use Net::netent; - - @ARGV = ('loopback') unless @ARGV; - - my($n, $net); - - for $net ( @ARGV ) { - - unless ($n = getnetbyname($net)) { - warn "$0: no such net: $net\n"; - next; - } - - printf "\n%s is %s%s\n", - $net, - lc($n->name) eq lc($net) ? "" : "*really* ", - $n->name; - - print "\taliases are ", join(", ", @{$n->aliases}), "\n" - if @{$n->aliases}; - - # this is stupid; first, why is this not in binary? - # second, why am i going through these convolutions - # to make it looks right - { - my @a = unpack("C4", pack("N", $n->net)); - shift @a while @a && $a[0] == 0; - printf "\taddr is %s [%d.%d.%d.%d]\n", $n->net, @a; - } - - if ($n = getnetbyaddr($n->net)) { - if (lc($n->name) ne lc($net)) { - printf "\tThat addr reverses to net %s!\n", $n->name; - $net = $n->name; - redo; - } - } - } - -=head1 NOTE - -While this class is currently implemented using the Class::Struct -module to build a struct-like class, you shouldn't rely upon this. - -=head1 AUTHOR - -Tom Christiansen diff --git a/Master/tlpkg/tlperl/lib/Net/protoent.pm b/Master/tlpkg/tlperl/lib/Net/protoent.pm deleted file mode 100755 index 2cbccad3cbc..00000000000 --- a/Master/tlpkg/tlperl/lib/Net/protoent.pm +++ /dev/null @@ -1,96 +0,0 @@ -package Net::protoent; -use strict; - -use 5.006_001; -our $VERSION = '1.00'; -our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); -BEGIN { - use Exporter (); - @EXPORT = qw(getprotobyname getprotobynumber getprotoent getproto); - @EXPORT_OK = qw( $p_name @p_aliases $p_proto ); - %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); -} -use vars @EXPORT_OK; - -# Class::Struct forbids use of @ISA -sub import { goto &Exporter::import } - -use Class::Struct qw(struct); -struct 'Net::protoent' => [ - name => '$', - aliases => '@', - proto => '$', -]; - -sub populate (@) { - return unless @_; - my $pob = new(); - $p_name = $pob->[0] = $_[0]; - @p_aliases = @{ $pob->[1] } = split ' ', $_[1]; - $p_proto = $pob->[2] = $_[2]; - return $pob; -} - -sub getprotoent ( ) { populate(CORE::getprotoent()) } -sub getprotobyname ($) { populate(CORE::getprotobyname(shift)) } -sub getprotobynumber ($) { populate(CORE::getprotobynumber(shift)) } - -sub getproto ($;$) { - no strict 'refs'; - return &{'getprotoby' . ($_[0]=~/^\d+$/ ? 'number' : 'name')}(@_); -} - -1; - -__END__ - -=head1 NAME - -Net::protoent - by-name interface to Perl's built-in getproto*() functions - -=head1 SYNOPSIS - - use Net::protoent; - $p = getprotobyname(shift || 'tcp') || die "no proto"; - printf "proto for %s is %d, aliases are %s\n", - $p->name, $p->proto, "@{$p->aliases}"; - - use Net::protoent qw(:FIELDS); - getprotobyname(shift || 'tcp') || die "no proto"; - print "proto for $p_name is $p_proto, aliases are @p_aliases\n"; - -=head1 DESCRIPTION - -This module's default exports override the core getprotoent(), -getprotobyname(), and getnetbyport() functions, replacing them with -versions that return "Net::protoent" objects. They take default -second arguments of "tcp". This object has methods that return the -similarly named structure field name from the C's protoent structure -from F<netdb.h>; namely name, aliases, and proto. The aliases method -returns an array reference, the rest scalars. - -You may also import all the structure fields directly into your namespace -as regular variables using the :FIELDS import tag. (Note that this still -overrides your core functions.) Access these fields as variables named -with a preceding C<p_>. Thus, C<$proto_obj-E<gt>name()> corresponds to -$p_name if you import the fields. Array references are available as -regular array variables, so for example C<@{ $proto_obj-E<gt>aliases() -}> would be simply @p_aliases. - -The getproto() function is a simple front-end that forwards a numeric -argument to getprotobyport(), and the rest to getprotobyname(). - -To access this functionality without the core overrides, -pass the C<use> an empty import list, and then access -function functions with their full qualified names. -On the other hand, the built-ins are still available -via the C<CORE::> pseudo-package. - -=head1 NOTE - -While this class is currently implemented using the Class::Struct -module to build a struct-like class, you shouldn't rely upon this. - -=head1 AUTHOR - -Tom Christiansen diff --git a/Master/tlpkg/tlperl/lib/Net/servent.pm b/Master/tlpkg/tlperl/lib/Net/servent.pm deleted file mode 100755 index 78a16814555..00000000000 --- a/Master/tlpkg/tlperl/lib/Net/servent.pm +++ /dev/null @@ -1,113 +0,0 @@ -package Net::servent; -use strict; - -use 5.006_001; -our $VERSION = '1.01'; -our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); -BEGIN { - use Exporter (); - @EXPORT = qw(getservbyname getservbyport getservent getserv); - @EXPORT_OK = qw( $s_name @s_aliases $s_port $s_proto ); - %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); -} -use vars @EXPORT_OK; - -# Class::Struct forbids use of @ISA -sub import { goto &Exporter::import } - -use Class::Struct qw(struct); -struct 'Net::servent' => [ - name => '$', - aliases => '@', - port => '$', - proto => '$', -]; - -sub populate (@) { - return unless @_; - my $sob = new(); - $s_name = $sob->[0] = $_[0]; - @s_aliases = @{ $sob->[1] } = split ' ', $_[1]; - $s_port = $sob->[2] = $_[2]; - $s_proto = $sob->[3] = $_[3]; - return $sob; -} - -sub getservent ( ) { populate(CORE::getservent()) } -sub getservbyname ($;$) { populate(CORE::getservbyname(shift,shift||'tcp')) } -sub getservbyport ($;$) { populate(CORE::getservbyport(shift,shift||'tcp')) } - -sub getserv ($;$) { - no strict 'refs'; - return &{'getservby' . ($_[0]=~/^\d+$/ ? 'port' : 'name')}(@_); -} - -1; - -__END__ - -=head1 NAME - -Net::servent - by-name interface to Perl's built-in getserv*() functions - -=head1 SYNOPSIS - - use Net::servent; - $s = getservbyname(shift || 'ftp') || die "no service"; - printf "port for %s is %s, aliases are %s\n", - $s->name, $s->port, "@{$s->aliases}"; - - use Net::servent qw(:FIELDS); - getservbyname(shift || 'ftp') || die "no service"; - print "port for $s_name is $s_port, aliases are @s_aliases\n"; - -=head1 DESCRIPTION - -This module's default exports override the core getservent(), -getservbyname(), and -getnetbyport() functions, replacing them with versions that return -"Net::servent" objects. They take default second arguments of "tcp". This object has methods that return the similarly -named structure field name from the C's servent structure from F<netdb.h>; -namely name, aliases, port, and proto. The aliases -method returns an array reference, the rest scalars. - -You may also import all the structure fields directly into your namespace -as regular variables using the :FIELDS import tag. (Note that this still -overrides your core functions.) Access these fields as variables named -with a preceding C<s_>. Thus, C<$serv_obj-E<gt>name()> corresponds to -$s_name if you import the fields. Array references are available as -regular array variables, so for example C<@{ $serv_obj-E<gt>aliases()}> -would be simply @s_aliases. - -The getserv() function is a simple front-end that forwards a numeric -argument to getservbyport(), and the rest to getservbyname(). - -To access this functionality without the core overrides, -pass the C<use> an empty import list, and then access -function functions with their full qualified names. -On the other hand, the built-ins are still available -via the C<CORE::> pseudo-package. - -=head1 EXAMPLES - - use Net::servent qw(:FIELDS); - - while (@ARGV) { - my ($service, $proto) = ((split m!/!, shift), 'tcp'); - my $valet = getserv($service, $proto); - unless ($valet) { - warn "$0: No service: $service/$proto\n" - next; - } - printf "service $service/$proto is port %d\n", $valet->port; - print "alias are @s_aliases\n" if @s_aliases; - } - -=head1 NOTE - -While this class is currently implemented using the Class::Struct -module to build a struct-like class, you shouldn't rely upon this. - -=head1 AUTHOR - -Tom Christiansen |