diff options
Diffstat (limited to 'Master/tlpkg/tlperl.straw/lib/Net')
30 files changed, 14547 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl.straw/lib/Net/Cmd.pm b/Master/tlpkg/tlperl.straw/lib/Net/Cmd.pm new file mode 100755 index 00000000000..4f0e4449f80 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Net/Cmd.pm @@ -0,0 +1,783 @@ +# 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.straw/lib/Net/Config.eg b/Master/tlpkg/tlperl.straw/lib/Net/Config.eg new file mode 100755 index 00000000000..77dc1f138b8 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Net/Config.eg @@ -0,0 +1,49 @@ +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.straw/lib/Net/Config.pm b/Master/tlpkg/tlperl.straw/lib/Net/Config.pm new file mode 100755 index 00000000000..db51c1fc0d2 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Net/Config.pm @@ -0,0 +1,312 @@ +# 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.straw/lib/Net/Domain.pm b/Master/tlpkg/tlperl.straw/lib/Net/Domain.pm new file mode 100755 index 00000000000..330909da49d --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Net/Domain.pm @@ -0,0 +1,347 @@ +# 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.straw/lib/Net/FTP.pm b/Master/tlpkg/tlperl.straw/lib/Net/FTP.pm new file mode 100755 index 00000000000..9ed6d385d9c --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Net/FTP.pm @@ -0,0 +1,1829 @@ +# 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.straw/lib/Net/FTP/A.pm b/Master/tlpkg/tlperl.straw/lib/Net/FTP/A.pm new file mode 100755 index 00000000000..427d02b19e9 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Net/FTP/A.pm @@ -0,0 +1,111 @@ +## +## 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.straw/lib/Net/FTP/E.pm b/Master/tlpkg/tlperl.straw/lib/Net/FTP/E.pm new file mode 100755 index 00000000000..d480cd72955 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Net/FTP/E.pm @@ -0,0 +1,8 @@ +package Net::FTP::E; + +require Net::FTP::I; + +@ISA = qw(Net::FTP::I); +$VERSION = "0.01"; + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Net/FTP/I.pm b/Master/tlpkg/tlperl.straw/lib/Net/FTP/I.pm new file mode 100755 index 00000000000..449bb99eab6 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Net/FTP/I.pm @@ -0,0 +1,80 @@ +## +## 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.straw/lib/Net/FTP/L.pm b/Master/tlpkg/tlperl.straw/lib/Net/FTP/L.pm new file mode 100755 index 00000000000..f7423cb9f95 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Net/FTP/L.pm @@ -0,0 +1,8 @@ +package Net::FTP::L; + +require Net::FTP::I; + +@ISA = qw(Net::FTP::I); +$VERSION = "0.01"; + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Net/FTP/dataconn.pm b/Master/tlpkg/tlperl.straw/lib/Net/FTP/dataconn.pm new file mode 100755 index 00000000000..e7645cbd930 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Net/FTP/dataconn.pm @@ -0,0 +1,124 @@ +## +## 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.straw/lib/Net/HTTP.pm b/Master/tlpkg/tlperl.straw/lib/Net/HTTP.pm new file mode 100755 index 00000000000..120de285f71 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Net/HTTP.pm @@ -0,0 +1,279 @@ +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.straw/lib/Net/HTTP/Methods.pm b/Master/tlpkg/tlperl.straw/lib/Net/HTTP/Methods.pm new file mode 100755 index 00000000000..22cc272b47e --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Net/HTTP/Methods.pm @@ -0,0 +1,593 @@ +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.straw/lib/Net/HTTP/NB.pm b/Master/tlpkg/tlperl.straw/lib/Net/HTTP/NB.pm new file mode 100755 index 00000000000..e4145116f6a --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Net/HTTP/NB.pm @@ -0,0 +1,105 @@ +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.straw/lib/Net/HTTPS.pm b/Master/tlpkg/tlperl.straw/lib/Net/HTTPS.pm new file mode 100755 index 00000000000..bfed714870c --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Net/HTTPS.pm @@ -0,0 +1,59 @@ +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.straw/lib/Net/Hostname.pm.eg b/Master/tlpkg/tlperl.straw/lib/Net/Hostname.pm.eg new file mode 100755 index 00000000000..4736c1a6ef2 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Net/Hostname.pm.eg @@ -0,0 +1,14 @@ +# + +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.straw/lib/Net/NNTP.pm b/Master/tlpkg/tlperl.straw/lib/Net/NNTP.pm new file mode 100755 index 00000000000..a742aed04c8 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Net/NNTP.pm @@ -0,0 +1,1140 @@ +# 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.straw/lib/Net/Netrc.pm b/Master/tlpkg/tlperl.straw/lib/Net/Netrc.pm new file mode 100755 index 00000000000..28c826b38cd --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Net/Netrc.pm @@ -0,0 +1,325 @@ +# 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.straw/lib/Net/POP3.pm b/Master/tlpkg/tlperl.straw/lib/Net/POP3.pm new file mode 100755 index 00000000000..8381c81815e --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Net/POP3.pm @@ -0,0 +1,742 @@ +# 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.straw/lib/Net/Ping.pm b/Master/tlpkg/tlperl.straw/lib/Net/Ping.pm new file mode 100755 index 00000000000..e9fff93eeaa --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Net/Ping.pm @@ -0,0 +1,1777 @@ +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.straw/lib/Net/SMTP.pm b/Master/tlpkg/tlperl.straw/lib/Net/SMTP.pm new file mode 100755 index 00000000000..a28496d6886 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Net/SMTP.pm @@ -0,0 +1,867 @@ +# 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.straw/lib/Net/SMTP/TLS.pm b/Master/tlpkg/tlperl.straw/lib/Net/SMTP/TLS.pm new file mode 100755 index 00000000000..10f9f196e40 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Net/SMTP/TLS.pm @@ -0,0 +1,401 @@ +=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.straw/lib/Net/SSL.pm b/Master/tlpkg/tlperl.straw/lib/Net/SSL.pm new file mode 100755 index 00000000000..f14435aeb69 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Net/SSL.pm @@ -0,0 +1,607 @@ +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.straw/lib/Net/SSLeay.pm b/Master/tlpkg/tlperl.straw/lib/Net/SSLeay.pm new file mode 100755 index 00000000000..08a0ec30f6a --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Net/SSLeay.pm @@ -0,0 +1,2610 @@ +# 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.straw/lib/Net/SSLeay/Handle.pm b/Master/tlpkg/tlperl.straw/lib/Net/SSLeay/Handle.pm new file mode 100755 index 00000000000..d4dfb59f7de --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Net/SSLeay/Handle.pm @@ -0,0 +1,394 @@ +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.straw/lib/Net/Time.pm b/Master/tlpkg/tlperl.straw/lib/Net/Time.pm new file mode 100755 index 00000000000..6f1dd04586e --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Net/Time.pm @@ -0,0 +1,151 @@ +# 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.straw/lib/Net/hostent.pm b/Master/tlpkg/tlperl.straw/lib/Net/hostent.pm new file mode 100755 index 00000000000..3a2fc013877 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Net/hostent.pm @@ -0,0 +1,151 @@ +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.straw/lib/Net/libnetFAQ.pod b/Master/tlpkg/tlperl.straw/lib/Net/libnetFAQ.pod new file mode 100755 index 00000000000..e6ec362f36a --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Net/libnetFAQ.pod @@ -0,0 +1,303 @@ +=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.straw/lib/Net/netent.pm b/Master/tlpkg/tlperl.straw/lib/Net/netent.pm new file mode 100755 index 00000000000..f7d32cb9254 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Net/netent.pm @@ -0,0 +1,169 @@ +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.straw/lib/Net/protoent.pm b/Master/tlpkg/tlperl.straw/lib/Net/protoent.pm new file mode 100755 index 00000000000..2cbccad3cbc --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Net/protoent.pm @@ -0,0 +1,96 @@ +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.straw/lib/Net/servent.pm b/Master/tlpkg/tlperl.straw/lib/Net/servent.pm new file mode 100755 index 00000000000..78a16814555 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Net/servent.pm @@ -0,0 +1,113 @@ +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 |