summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Net
diff options
context:
space:
mode:
authorSiep Kroonenberg <siepo@cybercomm.nl>2011-02-17 12:20:49 +0000
committerSiep Kroonenberg <siepo@cybercomm.nl>2011-02-17 12:20:49 +0000
commit316ee97c621496b0fe3267f57cce81bee44ca1e6 (patch)
treecb2cab1192b4f58a7971af19b213e980bceda4b4 /Master/tlpkg/tlperl/lib/Net
parentcd0f87b5d39480d85ad9bd4ee37f520f75bed560 (diff)
Moving old tlperl prior to committing new one
git-svn-id: svn://tug.org/texlive/trunk@21422 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Net')
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Net/Cmd.pm783
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Net/Config.eg49
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Net/Config.pm312
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Net/Domain.pm347
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Net/FTP.pm1829
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Net/FTP/A.pm111
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Net/FTP/E.pm8
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Net/FTP/I.pm80
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Net/FTP/L.pm8
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Net/FTP/dataconn.pm124
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Net/HTTP.pm279
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Net/HTTP/Methods.pm593
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Net/HTTP/NB.pm105
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Net/HTTPS.pm59
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Net/Hostname.pm.eg14
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Net/NNTP.pm1140
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Net/Netrc.pm325
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Net/POP3.pm742
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Net/Ping.pm1777
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Net/SMTP.pm867
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Net/SMTP/TLS.pm401
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Net/SSL.pm607
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Net/SSLeay.pm2610
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Net/SSLeay/Handle.pm394
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Net/Time.pm151
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Net/hostent.pm151
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Net/libnetFAQ.pod303
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Net/netent.pm169
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Net/protoent.pm96
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Net/servent.pm113
30 files changed, 0 insertions, 14547 deletions
diff --git a/Master/tlpkg/tlperl/lib/Net/Cmd.pm b/Master/tlpkg/tlperl/lib/Net/Cmd.pm
deleted file mode 100755
index 4f0e4449f80..00000000000
--- a/Master/tlpkg/tlperl/lib/Net/Cmd.pm
+++ /dev/null
@@ -1,783 +0,0 @@
-# Net::Cmd.pm
-#
-# Copyright (c) 1995-2006 Graham Barr <gbarr@pobox.com>. All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-
-package Net::Cmd;
-
-require 5.001;
-require Exporter;
-
-use strict;
-use vars qw(@ISA @EXPORT $VERSION);
-use Carp;
-use Symbol 'gensym';
-
-BEGIN {
- if ($^O eq 'os390') {
- require Convert::EBCDIC;
-
- # Convert::EBCDIC->import;
- }
-}
-
-BEGIN {
- if (!eval { require utf8 }) {
- *is_utf8 = sub { 0 };
- }
- elsif (eval { utf8::is_utf8(undef); 1 }) {
- *is_utf8 = \&utf8::is_utf8;
- }
- elsif (eval { require Encode; Encode::is_utf8(undef); 1 }) {
- *is_utf8 = \&Encode::is_utf8;
- }
- else {
- *is_utf8 = sub { $_[0] =~ /[^\x00-\xff]/ };
- }
-}
-
-$VERSION = "2.29";
-@ISA = qw(Exporter);
-@EXPORT = qw(CMD_INFO CMD_OK CMD_MORE CMD_REJECT CMD_ERROR CMD_PENDING);
-
-
-sub CMD_INFO {1}
-sub CMD_OK {2}
-sub CMD_MORE {3}
-sub CMD_REJECT {4}
-sub CMD_ERROR {5}
-sub CMD_PENDING {0}
-
-my %debug = ();
-
-my $tr = $^O eq 'os390' ? Convert::EBCDIC->new() : undef;
-
-
-sub toebcdic {
- my $cmd = shift;
-
- unless (exists ${*$cmd}{'net_cmd_asciipeer'}) {
- my $string = $_[0];
- my $ebcdicstr = $tr->toebcdic($string);
- ${*$cmd}{'net_cmd_asciipeer'} = $string !~ /^\d+/ && $ebcdicstr =~ /^\d+/;
- }
-
- ${*$cmd}{'net_cmd_asciipeer'}
- ? $tr->toebcdic($_[0])
- : $_[0];
-}
-
-
-sub toascii {
- my $cmd = shift;
- ${*$cmd}{'net_cmd_asciipeer'}
- ? $tr->toascii($_[0])
- : $_[0];
-}
-
-
-sub _print_isa {
- no strict qw(refs);
-
- my $pkg = shift;
- my $cmd = $pkg;
-
- $debug{$pkg} ||= 0;
-
- my %done = ();
- my @do = ($pkg);
- my %spc = ($pkg, "");
-
- while ($pkg = shift @do) {
- next if defined $done{$pkg};
-
- $done{$pkg} = 1;
-
- my $v =
- defined ${"${pkg}::VERSION"}
- ? "(" . ${"${pkg}::VERSION"} . ")"
- : "";
-
- my $spc = $spc{$pkg};
- $cmd->debug_print(1, "${spc}${pkg}${v}\n");
-
- if (@{"${pkg}::ISA"}) {
- @spc{@{"${pkg}::ISA"}} = (" " . $spc{$pkg}) x @{"${pkg}::ISA"};
- unshift(@do, @{"${pkg}::ISA"});
- }
- }
-}
-
-
-sub debug {
- @_ == 1 or @_ == 2 or croak 'usage: $obj->debug([LEVEL])';
-
- my ($cmd, $level) = @_;
- my $pkg = ref($cmd) || $cmd;
- my $oldval = 0;
-
- if (ref($cmd)) {
- $oldval = ${*$cmd}{'net_cmd_debug'} || 0;
- }
- else {
- $oldval = $debug{$pkg} || 0;
- }
-
- return $oldval
- unless @_ == 2;
-
- $level = $debug{$pkg} || 0
- unless defined $level;
-
- _print_isa($pkg)
- if ($level && !exists $debug{$pkg});
-
- if (ref($cmd)) {
- ${*$cmd}{'net_cmd_debug'} = $level;
- }
- else {
- $debug{$pkg} = $level;
- }
-
- $oldval;
-}
-
-
-sub message {
- @_ == 1 or croak 'usage: $obj->message()';
-
- my $cmd = shift;
-
- wantarray
- ? @{${*$cmd}{'net_cmd_resp'}}
- : join("", @{${*$cmd}{'net_cmd_resp'}});
-}
-
-
-sub debug_text { $_[2] }
-
-
-sub debug_print {
- my ($cmd, $out, $text) = @_;
- print STDERR $cmd, ($out ? '>>> ' : '<<< '), $cmd->debug_text($out, $text);
-}
-
-
-sub code {
- @_ == 1 or croak 'usage: $obj->code()';
-
- my $cmd = shift;
-
- ${*$cmd}{'net_cmd_code'} = "000"
- unless exists ${*$cmd}{'net_cmd_code'};
-
- ${*$cmd}{'net_cmd_code'};
-}
-
-
-sub status {
- @_ == 1 or croak 'usage: $obj->status()';
-
- my $cmd = shift;
-
- substr(${*$cmd}{'net_cmd_code'}, 0, 1);
-}
-
-
-sub set_status {
- @_ == 3 or croak 'usage: $obj->set_status(CODE, MESSAGE)';
-
- my $cmd = shift;
- my ($code, $resp) = @_;
-
- $resp = [$resp]
- unless ref($resp);
-
- (${*$cmd}{'net_cmd_code'}, ${*$cmd}{'net_cmd_resp'}) = ($code, $resp);
-
- 1;
-}
-
-
-sub command {
- my $cmd = shift;
-
- unless (defined fileno($cmd)) {
- $cmd->set_status("599", "Connection closed");
- return $cmd;
- }
-
-
- $cmd->dataend()
- if (exists ${*$cmd}{'net_cmd_last_ch'});
-
- if (scalar(@_)) {
- local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
-
- my $str = join(
- " ",
- map {
- /\n/
- ? do { my $n = $_; $n =~ tr/\n/ /; $n }
- : $_;
- } @_
- );
- $str = $cmd->toascii($str) if $tr;
- $str .= "\015\012";
-
- my $len = length $str;
- my $swlen;
-
- $cmd->close
- unless (defined($swlen = syswrite($cmd, $str, $len)) && $swlen == $len);
-
- $cmd->debug_print(1, $str)
- if ($cmd->debug);
-
- ${*$cmd}{'net_cmd_resp'} = []; # the response
- ${*$cmd}{'net_cmd_code'} = "000"; # Made this one up :-)
- }
-
- $cmd;
-}
-
-
-sub ok {
- @_ == 1 or croak 'usage: $obj->ok()';
-
- my $code = $_[0]->code;
- 0 < $code && $code < 400;
-}
-
-
-sub unsupported {
- my $cmd = shift;
-
- ${*$cmd}{'net_cmd_resp'} = ['Unsupported command'];
- ${*$cmd}{'net_cmd_code'} = 580;
- 0;
-}
-
-
-sub getline {
- my $cmd = shift;
-
- ${*$cmd}{'net_cmd_lines'} ||= [];
-
- return shift @{${*$cmd}{'net_cmd_lines'}}
- if scalar(@{${*$cmd}{'net_cmd_lines'}});
-
- my $partial = defined(${*$cmd}{'net_cmd_partial'}) ? ${*$cmd}{'net_cmd_partial'} : "";
- my $fd = fileno($cmd);
-
- return undef
- unless defined $fd;
-
- my $rin = "";
- vec($rin, $fd, 1) = 1;
-
- my $buf;
-
- until (scalar(@{${*$cmd}{'net_cmd_lines'}})) {
- my $timeout = $cmd->timeout || undef;
- my $rout;
-
- my $select_ret = select($rout = $rin, undef, undef, $timeout);
- if ($select_ret > 0) {
- unless (sysread($cmd, $buf = "", 1024)) {
- carp(ref($cmd) . ": Unexpected EOF on command channel")
- if $cmd->debug;
- $cmd->close;
- return undef;
- }
-
- substr($buf, 0, 0) = $partial; ## prepend from last sysread
-
- my @buf = split(/\015?\012/, $buf, -1); ## break into lines
-
- $partial = pop @buf;
-
- push(@{${*$cmd}{'net_cmd_lines'}}, map {"$_\n"} @buf);
-
- }
- else {
- my $msg = $select_ret ? "Error or Interrupted: $!" : "Timeout";
- carp("$cmd: $msg") if ($cmd->debug);
- return undef;
- }
- }
-
- ${*$cmd}{'net_cmd_partial'} = $partial;
-
- if ($tr) {
- foreach my $ln (@{${*$cmd}{'net_cmd_lines'}}) {
- $ln = $cmd->toebcdic($ln);
- }
- }
-
- shift @{${*$cmd}{'net_cmd_lines'}};
-}
-
-
-sub ungetline {
- my ($cmd, $str) = @_;
-
- ${*$cmd}{'net_cmd_lines'} ||= [];
- unshift(@{${*$cmd}{'net_cmd_lines'}}, $str);
-}
-
-
-sub parse_response {
- return ()
- unless $_[1] =~ s/^(\d\d\d)(.?)//o;
- ($1, $2 eq "-");
-}
-
-
-sub response {
- my $cmd = shift;
- my ($code, $more) = (undef) x 2;
-
- ${*$cmd}{'net_cmd_resp'} ||= [];
-
- while (1) {
- my $str = $cmd->getline();
-
- return CMD_ERROR
- unless defined($str);
-
- $cmd->debug_print(0, $str)
- if ($cmd->debug);
-
- ($code, $more) = $cmd->parse_response($str);
- unless (defined $code) {
- $cmd->ungetline($str);
- last;
- }
-
- ${*$cmd}{'net_cmd_code'} = $code;
-
- push(@{${*$cmd}{'net_cmd_resp'}}, $str);
-
- last unless ($more);
- }
-
- substr($code, 0, 1);
-}
-
-
-sub read_until_dot {
- my $cmd = shift;
- my $fh = shift;
- my $arr = [];
-
- while (1) {
- my $str = $cmd->getline() or return undef;
-
- $cmd->debug_print(0, $str)
- if ($cmd->debug & 4);
-
- last if ($str =~ /^\.\r?\n/o);
-
- $str =~ s/^\.\././o;
-
- if (defined $fh) {
- print $fh $str;
- }
- else {
- push(@$arr, $str);
- }
- }
-
- $arr;
-}
-
-
-sub datasend {
- my $cmd = shift;
- my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_;
- my $line = join("", @$arr);
-
- # encode to individual utf8 bytes if
- # $line is a string (in internal UTF-8)
- utf8::encode($line) if is_utf8($line);
-
- return 0 unless defined(fileno($cmd));
-
- my $last_ch = ${*$cmd}{'net_cmd_last_ch'};
- $last_ch = ${*$cmd}{'net_cmd_last_ch'} = "\012" unless defined $last_ch;
-
- return 1 unless length $line;
-
- if ($cmd->debug) {
- foreach my $b (split(/\n/, $line)) {
- $cmd->debug_print(1, "$b\n");
- }
- }
-
- $line =~ tr/\r\n/\015\012/ unless "\r" eq "\015";
-
- my $first_ch = '';
-
- if ($last_ch eq "\015") {
- $first_ch = "\012" if $line =~ s/^\012//;
- }
- elsif ($last_ch eq "\012") {
- $first_ch = "." if $line =~ /^\./;
- }
-
- $line =~ s/\015?\012(\.?)/\015\012$1$1/sg;
-
- substr($line, 0, 0) = $first_ch;
-
- ${*$cmd}{'net_cmd_last_ch'} = substr($line, -1, 1);
-
- my $len = length($line);
- my $offset = 0;
- my $win = "";
- vec($win, fileno($cmd), 1) = 1;
- my $timeout = $cmd->timeout || undef;
-
- local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
-
- while ($len) {
- my $wout;
- my $s = select(undef, $wout = $win, undef, $timeout);
- if ((defined $s and $s > 0) or -f $cmd) # -f for testing on win32
- {
- my $w = syswrite($cmd, $line, $len, $offset);
- unless (defined($w)) {
- carp("$cmd: $!") if $cmd->debug;
- return undef;
- }
- $len -= $w;
- $offset += $w;
- }
- else {
- carp("$cmd: Timeout") if ($cmd->debug);
- return undef;
- }
- }
-
- 1;
-}
-
-
-sub rawdatasend {
- my $cmd = shift;
- my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_;
- my $line = join("", @$arr);
-
- return 0 unless defined(fileno($cmd));
-
- return 1
- unless length($line);
-
- if ($cmd->debug) {
- my $b = "$cmd>>> ";
- print STDERR $b, join("\n$b", split(/\n/, $line)), "\n";
- }
-
- my $len = length($line);
- my $offset = 0;
- my $win = "";
- vec($win, fileno($cmd), 1) = 1;
- my $timeout = $cmd->timeout || undef;
-
- local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
- while ($len) {
- my $wout;
- if (select(undef, $wout = $win, undef, $timeout) > 0) {
- my $w = syswrite($cmd, $line, $len, $offset);
- unless (defined($w)) {
- carp("$cmd: $!") if $cmd->debug;
- return undef;
- }
- $len -= $w;
- $offset += $w;
- }
- else {
- carp("$cmd: Timeout") if ($cmd->debug);
- return undef;
- }
- }
-
- 1;
-}
-
-
-sub dataend {
- my $cmd = shift;
-
- return 0 unless defined(fileno($cmd));
-
- my $ch = ${*$cmd}{'net_cmd_last_ch'};
- my $tosend;
-
- if (!defined $ch) {
- return 1;
- }
- elsif ($ch ne "\012") {
- $tosend = "\015\012";
- }
-
- $tosend .= ".\015\012";
-
- local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
-
- $cmd->debug_print(1, ".\n")
- if ($cmd->debug);
-
- syswrite($cmd, $tosend, length $tosend);
-
- delete ${*$cmd}{'net_cmd_last_ch'};
-
- $cmd->response() == CMD_OK;
-}
-
-# read and write to tied filehandle
-sub tied_fh {
- my $cmd = shift;
- ${*$cmd}{'net_cmd_readbuf'} = '';
- my $fh = gensym();
- tie *$fh, ref($cmd), $cmd;
- return $fh;
-}
-
-# tie to myself
-sub TIEHANDLE {
- my $class = shift;
- my $cmd = shift;
- return $cmd;
-}
-
-# Tied filehandle read. Reads requested data length, returning
-# end-of-file when the dot is encountered.
-sub READ {
- my $cmd = shift;
- my ($len, $offset) = @_[1, 2];
- return unless exists ${*$cmd}{'net_cmd_readbuf'};
- my $done = 0;
- while (!$done and length(${*$cmd}{'net_cmd_readbuf'}) < $len) {
- ${*$cmd}{'net_cmd_readbuf'} .= $cmd->getline() or return;
- $done++ if ${*$cmd}{'net_cmd_readbuf'} =~ s/^\.\r?\n\Z//m;
- }
-
- $_[0] = '';
- substr($_[0], $offset + 0) = substr(${*$cmd}{'net_cmd_readbuf'}, 0, $len);
- substr(${*$cmd}{'net_cmd_readbuf'}, 0, $len) = '';
- delete ${*$cmd}{'net_cmd_readbuf'} if $done;
-
- return length $_[0];
-}
-
-
-sub READLINE {
- my $cmd = shift;
-
- # in this context, we use the presence of readbuf to
- # indicate that we have not yet reached the eof
- return unless exists ${*$cmd}{'net_cmd_readbuf'};
- my $line = $cmd->getline;
- return if $line =~ /^\.\r?\n/;
- $line;
-}
-
-
-sub PRINT {
- my $cmd = shift;
- my ($buf, $len, $offset) = @_;
- $len ||= length($buf);
- $offset += 0;
- return unless $cmd->datasend(substr($buf, $offset, $len));
- ${*$cmd}{'net_cmd_sending'}++; # flag that we should call dataend()
- return $len;
-}
-
-
-sub CLOSE {
- my $cmd = shift;
- my $r = exists(${*$cmd}{'net_cmd_sending'}) ? $cmd->dataend : 1;
- delete ${*$cmd}{'net_cmd_readbuf'};
- delete ${*$cmd}{'net_cmd_sending'};
- $r;
-}
-
-1;
-
-__END__
-
-
-=head1 NAME
-
-Net::Cmd - Network Command class (as used by FTP, SMTP etc)
-
-=head1 SYNOPSIS
-
- use Net::Cmd;
-
- @ISA = qw(Net::Cmd);
-
-=head1 DESCRIPTION
-
-C<Net::Cmd> is a collection of methods that can be inherited by a sub class
-of C<IO::Handle>. These methods implement the functionality required for a
-command based protocol, for example FTP and SMTP.
-
-=head1 USER METHODS
-
-These methods provide a user interface to the C<Net::Cmd> object.
-
-=over 4
-
-=item debug ( VALUE )
-
-Set the level of debug information for this object. If C<VALUE> is not given
-then the current state is returned. Otherwise the state is changed to
-C<VALUE> and the previous state returned.
-
-Different packages
-may implement different levels of debug but a non-zero value results in
-copies of all commands and responses also being sent to STDERR.
-
-If C<VALUE> is C<undef> then the debug level will be set to the default
-debug level for the class.
-
-This method can also be called as a I<static> method to set/get the default
-debug level for a given class.
-
-=item message ()
-
-Returns the text message returned from the last command
-
-=item code ()
-
-Returns the 3-digit code from the last command. If a command is pending
-then the value 0 is returned
-
-=item ok ()
-
-Returns non-zero if the last code value was greater than zero and
-less than 400. This holds true for most command servers. Servers
-where this does not hold may override this method.
-
-=item status ()
-
-Returns the most significant digit of the current status code. If a command
-is pending then C<CMD_PENDING> is returned.
-
-=item datasend ( DATA )
-
-Send data to the remote server, converting LF to CRLF. Any line starting
-with a '.' will be prefixed with another '.'.
-C<DATA> may be an array or a reference to an array.
-
-=item dataend ()
-
-End the sending of data to the remote server. This is done by ensuring that
-the data already sent ends with CRLF then sending '.CRLF' to end the
-transmission. Once this data has been sent C<dataend> calls C<response> and
-returns true if C<response> returns CMD_OK.
-
-=back
-
-=head1 CLASS METHODS
-
-These methods are not intended to be called by the user, but used or
-over-ridden by a sub-class of C<Net::Cmd>
-
-=over 4
-
-=item debug_print ( DIR, TEXT )
-
-Print debugging information. C<DIR> denotes the direction I<true> being
-data being sent to the server. Calls C<debug_text> before printing to
-STDERR.
-
-=item debug_text ( TEXT )
-
-This method is called to print debugging information. TEXT is
-the text being sent. The method should return the text to be printed
-
-This is primarily meant for the use of modules such as FTP where passwords
-are sent, but we do not want to display them in the debugging information.
-
-=item command ( CMD [, ARGS, ... ])
-
-Send a command to the command server. All arguments a first joined with
-a space character and CRLF is appended, this string is then sent to the
-command server.
-
-Returns undef upon failure
-
-=item unsupported ()
-
-Sets the status code to 580 and the response text to 'Unsupported command'.
-Returns zero.
-
-=item response ()
-
-Obtain a response from the server. Upon success the most significant digit
-of the status code is returned. Upon failure, timeout etc., I<undef> is
-returned.
-
-=item parse_response ( TEXT )
-
-This method is called by C<response> as a method with one argument. It should
-return an array of 2 values, the 3-digit status code and a flag which is true
-when this is part of a multi-line response and this line is not the list.
-
-=item getline ()
-
-Retrieve one line, delimited by CRLF, from the remote server. Returns I<undef>
-upon failure.
-
-B<NOTE>: If you do use this method for any reason, please remember to add
-some C<debug_print> calls into your method.
-
-=item ungetline ( TEXT )
-
-Unget a line of text from the server.
-
-=item rawdatasend ( DATA )
-
-Send data to the remote server without performing any conversions. C<DATA>
-is a scalar.
-
-=item read_until_dot ()
-
-Read data from the remote server until a line consisting of a single '.'.
-Any lines starting with '..' will have one of the '.'s removed.
-
-Returns a reference to a list containing the lines, or I<undef> upon failure.
-
-=item tied_fh ()
-
-Returns a filehandle tied to the Net::Cmd object. After issuing a
-command, you may read from this filehandle using read() or <>. The
-filehandle will return EOF when the final dot is encountered.
-Similarly, you may write to the filehandle in order to send data to
-the server after issuing a command that expects data to be written.
-
-See the Net::POP3 and Net::SMTP modules for examples of this.
-
-=back
-
-=head1 EXPORTS
-
-C<Net::Cmd> exports six subroutines, five of these, C<CMD_INFO>, C<CMD_OK>,
-C<CMD_MORE>, C<CMD_REJECT> and C<CMD_ERROR>, correspond to possible results
-of C<response> and C<status>. The sixth is C<CMD_PENDING>.
-
-=head1 AUTHOR
-
-Graham Barr <gbarr@pobox.com>
-
-=head1 COPYRIGHT
-
-Copyright (c) 1995-2006 Graham Barr. All rights reserved.
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=cut
diff --git a/Master/tlpkg/tlperl/lib/Net/Config.eg b/Master/tlpkg/tlperl/lib/Net/Config.eg
deleted file mode 100755
index 77dc1f138b8..00000000000
--- a/Master/tlpkg/tlperl/lib/Net/Config.eg
+++ /dev/null
@@ -1,49 +0,0 @@
-package Net::Config;
-
-require Exporter;
-use vars qw(@ISA @EXPORT %NetConfig);
-use strict;
-
-@EXPORT = qw(%NetConfig);
-@ISA = qw(Exporter);
-
-# WARNING WARNING WARNING WARNING WARNING WARNING WARNING
-# WARNING WARNING WARNING WARNING WARNING WARNING WARNING
-#
-# Below this line is auto-generated, *ANY* changes will be lost
-
-%NetConfig = (
- # the followinf parameters are all lists of hosts for the
- # respective protocols.
- nntp_hosts => [],
- snpp_hosts => [],
- pop3_hosts => [],
- smtp_hosts => [],
- ph_hosts => [],
- daytime_hosts => [],
- time_hosts => [],
-
- # your internet domain
- inet_domain => undef,
-
- # If you have an ftp proxy firewall (not an http firewall)
- # then set this to the name of the firewall
- ftp_firewall => undef,
-
- # set if all connections done via the firewall should use
- # passive data connections
- ftp_ext_passive => 0,
-
- # set if all connections not done via the firewall should use
- # passive data connections
- ftp_int_passive => 0,
-
- # If set the make test will attempt to connect to the hosts above
- test_hosts => 0,
-
- # Used during Configure (which you are not using) to do
- # DNS lookups to ensure hosts exist
- test_exist => 0,
-
-);
-1;
diff --git a/Master/tlpkg/tlperl/lib/Net/Config.pm b/Master/tlpkg/tlperl/lib/Net/Config.pm
deleted file mode 100755
index db51c1fc0d2..00000000000
--- a/Master/tlpkg/tlperl/lib/Net/Config.pm
+++ /dev/null
@@ -1,312 +0,0 @@
-# Net::Config.pm
-#
-# Copyright (c) 2000 Graham Barr <gbarr@pobox.com>. All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-
-package Net::Config;
-
-require Exporter;
-use vars qw(@ISA @EXPORT %NetConfig $VERSION $CONFIGURE $LIBNET_CFG);
-use Socket qw(inet_aton inet_ntoa);
-use strict;
-
-@EXPORT = qw(%NetConfig);
-@ISA = qw(Net::LocalCfg Exporter);
-$VERSION = "1.11";
-
-eval { local $SIG{__DIE__}; require Net::LocalCfg };
-
-%NetConfig = (
- nntp_hosts => [],
- snpp_hosts => [],
- pop3_hosts => [],
- smtp_hosts => [],
- ph_hosts => [],
- daytime_hosts => [],
- time_hosts => [],
- inet_domain => undef,
- ftp_firewall => undef,
- ftp_ext_passive => 1,
- ftp_int_passive => 1,
- test_hosts => 1,
- test_exist => 1,
-);
-
-#
-# Try to get as much configuration info as possible from InternetConfig
-#
-$^O eq 'MacOS' and eval <<TRY_INTERNET_CONFIG;
-use Mac::InternetConfig;
-
-{
-my %nc = (
- nntp_hosts => [ \$InternetConfig{ kICNNTPHost() } ],
- pop3_hosts => [ \$InternetConfig{ kICMailAccount() } =~ /\@(.*)/ ],
- smtp_hosts => [ \$InternetConfig{ kICSMTPHost() } ],
- ftp_testhost => \$InternetConfig{ kICFTPHost() } ? \$InternetConfig{ kICFTPHost()} : undef,
- ph_hosts => [ \$InternetConfig{ kICPhHost() } ],
- ftp_ext_passive => \$InternetConfig{"646F676F\xA5UsePassiveMode"} || 0,
- ftp_int_passive => \$InternetConfig{"646F676F\xA5UsePassiveMode"} || 0,
- socks_hosts =>
- \$InternetConfig{ kICUseSocks() } ? [ \$InternetConfig{ kICSocksHost() } ] : [],
- ftp_firewall =>
- \$InternetConfig{ kICUseFTPProxy() } ? [ \$InternetConfig{ kICFTPProxyHost() } ] : [],
-);
-\@NetConfig{keys %nc} = values %nc;
-}
-TRY_INTERNET_CONFIG
-
-my $file = __FILE__;
-my $ref;
-$file =~ s/Config.pm/libnet.cfg/;
-if (-f $file) {
- $ref = eval { local $SIG{__DIE__}; do $file };
- if (ref($ref) eq 'HASH') {
- %NetConfig = (%NetConfig, %{$ref});
- $LIBNET_CFG = $file;
- }
-}
-if ($< == $> and !$CONFIGURE) {
- my $home = eval { local $SIG{__DIE__}; (getpwuid($>))[7] } || $ENV{HOME};
- $home ||= $ENV{HOMEDRIVE} . ($ENV{HOMEPATH} || '') if defined $ENV{HOMEDRIVE};
- if (defined $home) {
- $file = $home . "/.libnetrc";
- $ref = eval { local $SIG{__DIE__}; do $file } if -f $file;
- %NetConfig = (%NetConfig, %{$ref})
- if ref($ref) eq 'HASH';
- }
-}
-my ($k, $v);
-while (($k, $v) = each %NetConfig) {
- $NetConfig{$k} = [$v]
- if ($k =~ /_hosts$/ and $k ne "test_hosts" and defined($v) and !ref($v));
-}
-
-# Take a hostname and determine if it is inside the firewall
-
-
-sub requires_firewall {
- shift; # ignore package
- my $host = shift;
-
- return 0 unless defined $NetConfig{'ftp_firewall'};
-
- $host = inet_aton($host) or return -1;
- $host = inet_ntoa($host);
-
- if (exists $NetConfig{'local_netmask'}) {
- my $quad = unpack("N", pack("C*", split(/\./, $host)));
- my $list = $NetConfig{'local_netmask'};
- $list = [$list] unless ref($list);
- foreach (@$list) {
- my ($net, $bits) = (m#^(\d+\.\d+\.\d+\.\d+)/(\d+)$#) or next;
- my $mask = ~0 << (32 - $bits);
- my $addr = unpack("N", pack("C*", split(/\./, $net)));
-
- return 0 if (($addr & $mask) == ($quad & $mask));
- }
- return 1;
- }
-
- return 0;
-}
-
-use vars qw(*is_external);
-*is_external = \&requires_firewall;
-
-1;
-
-__END__
-
-=head1 NAME
-
-Net::Config - Local configuration data for libnet
-
-=head1 SYNOPSYS
-
- use Net::Config qw(%NetConfig);
-
-=head1 DESCRIPTION
-
-C<Net::Config> holds configuration data for the modules in the libnet
-distribution. During installation you will be asked for these values.
-
-The configuration data is held globally in a file in the perl installation
-tree, but a user may override any of these values by providing their own. This
-can be done by having a C<.libnetrc> file in their home directory. This file
-should return a reference to a HASH containing the keys described below.
-For example
-
- # .libnetrc
- {
- nntp_hosts => [ "my_preferred_host" ],
- ph_hosts => [ "my_ph_server" ],
- }
- __END__
-
-=head1 METHODS
-
-C<Net::Config> defines the following methods. They are methods as they are
-invoked as class methods. This is because C<Net::Config> inherits from
-C<Net::LocalCfg> so you can override these methods if you want.
-
-=over 4
-
-=item requires_firewall HOST
-
-Attempts to determine if a given host is outside your firewall. Possible
-return values are.
-
- -1 Cannot lookup hostname
- 0 Host is inside firewall (or there is no ftp_firewall entry)
- 1 Host is outside the firewall
-
-This is done by using hostname lookup and the C<local_netmask> entry in
-the configuration data.
-
-=back
-
-=head1 NetConfig VALUES
-
-=over 4
-
-=item nntp_hosts
-
-=item snpp_hosts
-
-=item pop3_hosts
-
-=item smtp_hosts
-
-=item ph_hosts
-
-=item daytime_hosts
-
-=item time_hosts
-
-Each is a reference to an array of hostnames (in order of preference),
-which should be used for the given protocol
-
-=item inet_domain
-
-Your internet domain name
-
-=item ftp_firewall
-
-If you have an FTP proxy firewall (B<NOT> an HTTP or SOCKS firewall)
-then this value should be set to the firewall hostname. If your firewall
-does not listen to port 21, then this value should be set to
-C<"hostname:port"> (eg C<"hostname:99">)
-
-=item ftp_firewall_type
-
-There are many different ftp firewall products available. But unfortunately
-there is no standard for how to traverse a firewall. The list below shows the
-sequence of commands that Net::FTP will use
-
- user Username for remote host
- pass Password for remote host
- fwuser Username for firewall
- fwpass Password for firewall
- remote.host The hostname of the remote ftp server
-
-=over 4
-
-=item 0
-
-There is no firewall
-
-=item 1
-
- USER user@remote.host
- PASS pass
-
-=item 2
-
- USER fwuser
- PASS fwpass
- USER user@remote.host
- PASS pass
-
-=item 3
-
- USER fwuser
- PASS fwpass
- SITE remote.site
- USER user
- PASS pass
-
-=item 4
-
- USER fwuser
- PASS fwpass
- OPEN remote.site
- USER user
- PASS pass
-
-=item 5
-
- USER user@fwuser@remote.site
- PASS pass@fwpass
-
-=item 6
-
- USER fwuser@remote.site
- PASS fwpass
- USER user
- PASS pass
-
-=item 7
-
- USER user@remote.host
- PASS pass
- AUTH fwuser
- RESP fwpass
-
-=back
-
-=item ftp_ext_passive
-
-=item ftp_int_passive
-
-FTP servers can work in passive or active mode. Active mode is when
-you want to transfer data you have to tell the server the address and
-port to connect to. Passive mode is when the server provide the
-address and port and you establish the connection.
-
-With some firewalls active mode does not work as the server cannot
-connect to your machine (because you are behind a firewall) and the firewall
-does not re-write the command. In this case you should set C<ftp_ext_passive>
-to a I<true> value.
-
-Some servers are configured to only work in passive mode. If you have
-one of these you can force C<Net::FTP> to always transfer in passive
-mode; when not going via a firewall, by setting C<ftp_int_passive> to
-a I<true> value.
-
-=item local_netmask
-
-A reference to a list of netmask strings in the form C<"134.99.4.0/24">.
-These are used by the C<requires_firewall> function to determine if a given
-host is inside or outside your firewall.
-
-=back
-
-The following entries are used during installation & testing on the
-libnet package
-
-=over 4
-
-=item test_hosts
-
-If true then C<make test> may attempt to connect to hosts given in the
-configuration.
-
-=item test_exists
-
-If true then C<Configure> will check each hostname given that it exists
-
-=back
-
-=cut
diff --git a/Master/tlpkg/tlperl/lib/Net/Domain.pm b/Master/tlpkg/tlperl/lib/Net/Domain.pm
deleted file mode 100755
index 330909da49d..00000000000
--- a/Master/tlpkg/tlperl/lib/Net/Domain.pm
+++ /dev/null
@@ -1,347 +0,0 @@
-# Net::Domain.pm
-#
-# Copyright (c) 1995-1998 Graham Barr <gbarr@pobox.com>. All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-
-package Net::Domain;
-
-require Exporter;
-
-use Carp;
-use strict;
-use vars qw($VERSION @ISA @EXPORT_OK);
-use Net::Config;
-
-@ISA = qw(Exporter);
-@EXPORT_OK = qw(hostname hostdomain hostfqdn domainname);
-
-$VERSION = "2.20";
-
-my ($host, $domain, $fqdn) = (undef, undef, undef);
-
-# Try every conceivable way to get hostname.
-
-
-sub _hostname {
-
- # we already know it
- return $host
- if (defined $host);
-
- if ($^O eq 'MSWin32') {
- require Socket;
- my ($name, $alias, $type, $len, @addr) = gethostbyname($ENV{'COMPUTERNAME'} || 'localhost');
- while (@addr) {
- my $a = shift(@addr);
- $host = gethostbyaddr($a, Socket::AF_INET());
- last if defined $host;
- }
- if (defined($host) && index($host, '.') > 0) {
- $fqdn = $host;
- ($host, $domain) = $fqdn =~ /^([^\.]+)\.(.*)$/;
- }
- return $host;
- }
- elsif ($^O eq 'MacOS') {
- chomp($host = `hostname`);
- }
- elsif ($^O eq 'VMS') { ## multiple varieties of net s/w makes this hard
- $host = $ENV{'UCX$INET_HOST'} if defined($ENV{'UCX$INET_HOST'});
- $host = $ENV{'MULTINET_HOST_NAME'} if defined($ENV{'MULTINET_HOST_NAME'});
- if (index($host, '.') > 0) {
- $fqdn = $host;
- ($host, $domain) = $fqdn =~ /^([^\.]+)\.(.*)$/;
- }
- return $host;
- }
- else {
- local $SIG{'__DIE__'};
-
- # syscall is preferred since it avoids tainting problems
- eval {
- my $tmp = "\0" x 256; ## preload scalar
- eval {
- package main;
- require "syscall.ph";
- defined(&main::SYS_gethostname);
- }
- || eval {
- package main;
- require "sys/syscall.ph";
- defined(&main::SYS_gethostname);
- }
- and $host =
- (syscall(&main::SYS_gethostname, $tmp, 256) == 0)
- ? $tmp
- : undef;
- }
-
- # POSIX
- || eval {
- require POSIX;
- $host = (POSIX::uname())[1];
- }
-
- # trusty old hostname command
- || eval {
- chop($host = `(hostname) 2>/dev/null`); # BSD'ish
- }
-
- # sysV/POSIX uname command (may truncate)
- || eval {
- chop($host = `uname -n 2>/dev/null`); ## SYSV'ish && POSIX'ish
- }
-
- # Apollo pre-SR10
- || eval { $host = (split(/[:\. ]/, `/com/host`, 6))[0]; }
-
- || eval { $host = ""; };
- }
-
- # remove garbage
- $host =~ s/[\0\r\n]+//go;
- $host =~ s/(\A\.+|\.+\Z)//go;
- $host =~ s/\.\.+/\./go;
-
- $host;
-}
-
-
-sub _hostdomain {
-
- # we already know it
- return $domain
- if (defined $domain);
-
- local $SIG{'__DIE__'};
-
- return $domain = $NetConfig{'inet_domain'}
- if defined $NetConfig{'inet_domain'};
-
- # try looking in /etc/resolv.conf
- # putting this here and assuming that it is correct, eliminates
- # calls to gethostbyname, and therefore DNS lookups. This helps
- # those on dialup systems.
-
- local *RES;
- local ($_);
-
- if (open(RES, "/etc/resolv.conf")) {
- while (<RES>) {
- $domain = $1
- if (/\A\s*(?:domain|search)\s+(\S+)/);
- }
- close(RES);
-
- return $domain
- if (defined $domain);
- }
-
- # just try hostname and system calls
-
- my $host = _hostname();
- my (@hosts);
-
- @hosts = ($host, "localhost");
-
- unless (defined($host) && $host =~ /\./) {
- my $dom = undef;
- eval {
- my $tmp = "\0" x 256; ## preload scalar
- eval {
- package main;
- require "syscall.ph";
- }
- || eval {
- package main;
- require "sys/syscall.ph";
- }
- and $dom =
- (syscall(&main::SYS_getdomainname, $tmp, 256) == 0)
- ? $tmp
- : undef;
- };
-
- if ($^O eq 'VMS') {
- $dom ||= $ENV{'TCPIP$INET_DOMAIN'}
- || $ENV{'UCX$INET_DOMAIN'};
- }
-
- chop($dom = `domainname 2>/dev/null`)
- unless (defined $dom || $^O =~ /^(?:cygwin|MSWin32)/);
-
- if (defined $dom) {
- my @h = ();
- $dom =~ s/^\.+//;
- while (length($dom)) {
- push(@h, "$host.$dom");
- $dom =~ s/^[^.]+.+// or last;
- }
- unshift(@hosts, @h);
- }
- }
-
- # Attempt to locate FQDN
-
- foreach (grep { defined $_ } @hosts) {
- my @info = gethostbyname($_);
-
- next unless @info;
-
- # look at real name & aliases
- my $site;
- foreach $site ($info[0], split(/ /, $info[1])) {
- if (rindex($site, ".") > 0) {
-
- # Extract domain from FQDN
-
- ($domain = $site) =~ s/\A[^\.]+\.//;
- return $domain;
- }
- }
- }
-
- # Look for environment variable
-
- $domain ||= $ENV{LOCALDOMAIN} || $ENV{DOMAIN};
-
- if (defined $domain) {
- $domain =~ s/[\r\n\0]+//g;
- $domain =~ s/(\A\.+|\.+\Z)//g;
- $domain =~ s/\.\.+/\./g;
- }
-
- $domain;
-}
-
-
-sub domainname {
-
- return $fqdn
- if (defined $fqdn);
-
- _hostname();
- _hostdomain();
-
- # Assumption: If the host name does not contain a period
- # and the domain name does, then assume that they are correct
- # this helps to eliminate calls to gethostbyname, and therefore
- # eleminate DNS lookups
-
- return $fqdn = $host . "." . $domain
- if (defined $host
- and defined $domain
- and $host !~ /\./
- and $domain =~ /\./);
-
- # For hosts that have no name, just an IP address
- return $fqdn = $host if defined $host and $host =~ /^\d+(\.\d+){3}$/;
-
- my @host = defined $host ? split(/\./, $host) : ('localhost');
- my @domain = defined $domain ? split(/\./, $domain) : ();
- my @fqdn = ();
-
- # Determine from @host & @domain the FQDN
-
- my @d = @domain;
-
-LOOP:
- while (1) {
- my @h = @host;
- while (@h) {
- my $tmp = join(".", @h, @d);
- if ((gethostbyname($tmp))[0]) {
- @fqdn = (@h, @d);
- $fqdn = $tmp;
- last LOOP;
- }
- pop @h;
- }
- last unless shift @d;
- }
-
- if (@fqdn) {
- $host = shift @fqdn;
- until ((gethostbyname($host))[0]) {
- $host .= "." . shift @fqdn;
- }
- $domain = join(".", @fqdn);
- }
- else {
- undef $host;
- undef $domain;
- undef $fqdn;
- }
-
- $fqdn;
-}
-
-
-sub hostfqdn { domainname() }
-
-
-sub hostname {
- domainname()
- unless (defined $host);
- return $host;
-}
-
-
-sub hostdomain {
- domainname()
- unless (defined $domain);
- return $domain;
-}
-
-1; # Keep require happy
-
-__END__
-
-=head1 NAME
-
-Net::Domain - Attempt to evaluate the current host's internet name and domain
-
-=head1 SYNOPSIS
-
- use Net::Domain qw(hostname hostfqdn hostdomain domainname);
-
-=head1 DESCRIPTION
-
-Using various methods B<attempt> to find the Fully Qualified Domain Name (FQDN)
-of the current host. From this determine the host-name and the host-domain.
-
-Each of the functions will return I<undef> if the FQDN cannot be determined.
-
-=over 4
-
-=item hostfqdn ()
-
-Identify and return the FQDN of the current host.
-
-=item domainname ()
-
-An alias for hostfqdn ().
-
-=item hostname ()
-
-Returns the smallest part of the FQDN which can be used to identify the host.
-
-=item hostdomain ()
-
-Returns the remainder of the FQDN after the I<hostname> has been removed.
-
-=back
-
-=head1 AUTHOR
-
-Graham Barr <gbarr@pobox.com>.
-Adapted from Sys::Hostname by David Sundstrom <sunds@asictest.sc.ti.com>
-
-=head1 COPYRIGHT
-
-Copyright (c) 1995-1998 Graham Barr. All rights reserved.
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=cut
diff --git a/Master/tlpkg/tlperl/lib/Net/FTP.pm b/Master/tlpkg/tlperl/lib/Net/FTP.pm
deleted file mode 100755
index 9ed6d385d9c..00000000000
--- a/Master/tlpkg/tlperl/lib/Net/FTP.pm
+++ /dev/null
@@ -1,1829 +0,0 @@
-# Net::FTP.pm
-#
-# Copyright (c) 1995-2004 Graham Barr <gbarr@pobox.com>. All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-#
-# Documentation (at end) improved 1996 by Nathan Torkington <gnat@frii.com>.
-
-package Net::FTP;
-
-require 5.001;
-
-use strict;
-use vars qw(@ISA $VERSION);
-use Carp;
-
-use Socket 1.3;
-use IO::Socket;
-use Time::Local;
-use Net::Cmd;
-use Net::Config;
-use Fcntl qw(O_WRONLY O_RDONLY O_APPEND O_CREAT O_TRUNC);
-
-$VERSION = '2.77';
-@ISA = qw(Exporter Net::Cmd IO::Socket::INET);
-
-# Someday I will "use constant", when I am not bothered to much about
-# compatability with older releases of perl
-
-use vars qw($TELNET_IAC $TELNET_IP $TELNET_DM);
-($TELNET_IAC, $TELNET_IP, $TELNET_DM) = (255, 244, 242);
-
-
-BEGIN {
-
- # make a constant so code is fast'ish
- my $is_os390 = $^O eq 'os390';
- *trEBCDIC = sub () {$is_os390}
-}
-
-
-sub new {
- my $pkg = shift;
- my ($peer, %arg);
- if (@_ % 2) {
- $peer = shift;
- %arg = @_;
- }
- else {
- %arg = @_;
- $peer = delete $arg{Host};
- }
-
- my $host = $peer;
- my $fire = undef;
- my $fire_type = undef;
-
- if (exists($arg{Firewall}) || Net::Config->requires_firewall($peer)) {
- $fire = $arg{Firewall}
- || $ENV{FTP_FIREWALL}
- || $NetConfig{ftp_firewall}
- || undef;
-
- if (defined $fire) {
- $peer = $fire;
- delete $arg{Port};
- $fire_type = $arg{FirewallType}
- || $ENV{FTP_FIREWALL_TYPE}
- || $NetConfig{firewall_type}
- || undef;
- }
- }
-
- my $ftp = $pkg->SUPER::new(
- PeerAddr => $peer,
- PeerPort => $arg{Port} || 'ftp(21)',
- LocalAddr => $arg{'LocalAddr'},
- Proto => 'tcp',
- Timeout => defined $arg{Timeout}
- ? $arg{Timeout}
- : 120
- )
- or return undef;
-
- ${*$ftp}{'net_ftp_host'} = $host; # Remote hostname
- ${*$ftp}{'net_ftp_type'} = 'A'; # ASCII/binary/etc mode
- ${*$ftp}{'net_ftp_blksize'} = abs($arg{'BlockSize'} || 10240);
-
- ${*$ftp}{'net_ftp_localaddr'} = $arg{'LocalAddr'};
-
- ${*$ftp}{'net_ftp_firewall'} = $fire
- if (defined $fire);
- ${*$ftp}{'net_ftp_firewall_type'} = $fire_type
- if (defined $fire_type);
-
- ${*$ftp}{'net_ftp_passive'} =
- int exists $arg{Passive} ? $arg{Passive}
- : exists $ENV{FTP_PASSIVE} ? $ENV{FTP_PASSIVE}
- : defined $fire ? $NetConfig{ftp_ext_passive}
- : $NetConfig{ftp_int_passive}; # Whew! :-)
-
- $ftp->hash(exists $arg{Hash} ? $arg{Hash} : 0, 1024);
-
- $ftp->autoflush(1);
-
- $ftp->debug(exists $arg{Debug} ? $arg{Debug} : undef);
-
- unless ($ftp->response() == CMD_OK) {
- $ftp->close();
- $@ = $ftp->message;
- undef $ftp;
- }
-
- $ftp;
-}
-
-##
-## User interface methods
-##
-
-
-sub host {
- my $me = shift;
- ${*$me}{'net_ftp_host'};
-}
-
-
-sub hash {
- my $ftp = shift; # self
-
- my ($h, $b) = @_;
- unless ($h) {
- delete ${*$ftp}{'net_ftp_hash'};
- return [\*STDERR, 0];
- }
- ($h, $b) = (ref($h) ? $h : \*STDERR, $b || 1024);
- select((select($h), $| = 1)[0]);
- $b = 512 if $b < 512;
- ${*$ftp}{'net_ftp_hash'} = [$h, $b];
-}
-
-
-sub quit {
- my $ftp = shift;
-
- $ftp->_QUIT;
- $ftp->close;
-}
-
-
-sub DESTROY { }
-
-
-sub ascii { shift->type('A', @_); }
-sub binary { shift->type('I', @_); }
-
-
-sub ebcdic {
- carp "TYPE E is unsupported, shall default to I";
- shift->type('E', @_);
-}
-
-
-sub byte {
- carp "TYPE L is unsupported, shall default to I";
- shift->type('L', @_);
-}
-
-# Allow the user to send a command directly, BE CAREFUL !!
-
-
-sub quot {
- my $ftp = shift;
- my $cmd = shift;
-
- $ftp->command(uc $cmd, @_);
- $ftp->response();
-}
-
-
-sub site {
- my $ftp = shift;
-
- $ftp->command("SITE", @_);
- $ftp->response();
-}
-
-
-sub mdtm {
- my $ftp = shift;
- my $file = shift;
-
- # Server Y2K bug workaround
- #
- # sigh; some idiotic FTP servers use ("19%d",tm.tm_year) instead of
- # ("%d",tm.tm_year+1900). This results in an extra digit in the
- # string returned. To account for this we allow an optional extra
- # digit in the year. Then if the first two digits are 19 we use the
- # remainder, otherwise we subtract 1900 from the whole year.
-
- $ftp->_MDTM($file)
- && $ftp->message =~ /((\d\d)(\d\d\d?))(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/
- ? timegm($8, $7, $6, $5, $4 - 1, $2 eq '19' ? $3 : ($1 - 1900))
- : undef;
-}
-
-
-sub size {
- my $ftp = shift;
- my $file = shift;
- my $io;
- if ($ftp->supported("SIZE")) {
- return $ftp->_SIZE($file)
- ? ($ftp->message =~ /(\d+)\s*(bytes?\s*)?$/)[0]
- : undef;
- }
- elsif ($ftp->supported("STAT")) {
- my @msg;
- return undef
- unless $ftp->_STAT($file) && (@msg = $ftp->message) == 3;
- my $line;
- foreach $line (@msg) {
- return (split(/\s+/, $line))[4]
- if $line =~ /^[-rwxSsTt]{10}/;
- }
- }
- else {
- my @files = $ftp->dir($file);
- if (@files) {
- return (split(/\s+/, $1))[4]
- if $files[0] =~ /^([-rwxSsTt]{10}.*)$/;
- }
- }
- undef;
-}
-
-
-sub login {
- my ($ftp, $user, $pass, $acct) = @_;
- my ($ok, $ruser, $fwtype);
-
- unless (defined $user) {
- require Net::Netrc;
-
- my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_host'});
-
- ($user, $pass, $acct) = $rc->lpa()
- if ($rc);
- }
-
- $user ||= "anonymous";
- $ruser = $user;
-
- $fwtype = ${*$ftp}{'net_ftp_firewall_type'}
- || $NetConfig{'ftp_firewall_type'}
- || 0;
-
- if ($fwtype && defined ${*$ftp}{'net_ftp_firewall'}) {
- if ($fwtype == 1 || $fwtype == 7) {
- $user .= '@' . ${*$ftp}{'net_ftp_host'};
- }
- else {
- require Net::Netrc;
-
- my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'});
-
- my ($fwuser, $fwpass, $fwacct) = $rc ? $rc->lpa() : ();
-
- if ($fwtype == 5) {
- $user = join('@', $user, $fwuser, ${*$ftp}{'net_ftp_host'});
- $pass = $pass . '@' . $fwpass;
- }
- else {
- if ($fwtype == 2) {
- $user .= '@' . ${*$ftp}{'net_ftp_host'};
- }
- elsif ($fwtype == 6) {
- $fwuser .= '@' . ${*$ftp}{'net_ftp_host'};
- }
-
- $ok = $ftp->_USER($fwuser);
-
- return 0 unless $ok == CMD_OK || $ok == CMD_MORE;
-
- $ok = $ftp->_PASS($fwpass || "");
-
- return 0 unless $ok == CMD_OK || $ok == CMD_MORE;
-
- $ok = $ftp->_ACCT($fwacct)
- if defined($fwacct);
-
- if ($fwtype == 3) {
- $ok = $ftp->command("SITE", ${*$ftp}{'net_ftp_host'})->response;
- }
- elsif ($fwtype == 4) {
- $ok = $ftp->command("OPEN", ${*$ftp}{'net_ftp_host'})->response;
- }
-
- return 0 unless $ok == CMD_OK || $ok == CMD_MORE;
- }
- }
- }
-
- $ok = $ftp->_USER($user);
-
- # Some dumb firewalls don't prefix the connection messages
- $ok = $ftp->response()
- if ($ok == CMD_OK && $ftp->code == 220 && $user =~ /\@/);
-
- if ($ok == CMD_MORE) {
- unless (defined $pass) {
- require Net::Netrc;
-
- my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_host'}, $ruser);
-
- ($ruser, $pass, $acct) = $rc->lpa()
- if ($rc);
-
- $pass = '-anonymous@'
- if (!defined $pass && (!defined($ruser) || $ruser =~ /^anonymous/o));
- }
-
- $ok = $ftp->_PASS($pass || "");
- }
-
- $ok = $ftp->_ACCT($acct)
- if (defined($acct) && ($ok == CMD_MORE || $ok == CMD_OK));
-
- if ($fwtype == 7 && $ok == CMD_OK && defined ${*$ftp}{'net_ftp_firewall'}) {
- my ($f, $auth, $resp) = _auth_id($ftp);
- $ftp->authorize($auth, $resp) if defined($resp);
- }
-
- $ok == CMD_OK;
-}
-
-
-sub account {
- @_ == 2 or croak 'usage: $ftp->account( ACCT )';
- my $ftp = shift;
- my $acct = shift;
- $ftp->_ACCT($acct) == CMD_OK;
-}
-
-
-sub _auth_id {
- my ($ftp, $auth, $resp) = @_;
-
- unless (defined $resp) {
- require Net::Netrc;
-
- $auth ||= eval { (getpwuid($>))[0] } || $ENV{NAME};
-
- my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'}, $auth)
- || Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'});
-
- ($auth, $resp) = $rc->lpa()
- if ($rc);
- }
- ($ftp, $auth, $resp);
-}
-
-
-sub authorize {
- @_ >= 1 || @_ <= 3 or croak 'usage: $ftp->authorize( [AUTH [, RESP]])';
-
- my ($ftp, $auth, $resp) = &_auth_id;
-
- my $ok = $ftp->_AUTH($auth || "");
-
- $ok = $ftp->_RESP($resp || "")
- if ($ok == CMD_MORE);
-
- $ok == CMD_OK;
-}
-
-
-sub rename {
- @_ == 3 or croak 'usage: $ftp->rename(FROM, TO)';
-
- my ($ftp, $from, $to) = @_;
-
- $ftp->_RNFR($from)
- && $ftp->_RNTO($to);
-}
-
-
-sub type {
- my $ftp = shift;
- my $type = shift;
- my $oldval = ${*$ftp}{'net_ftp_type'};
-
- return $oldval
- unless (defined $type);
-
- return undef
- unless ($ftp->_TYPE($type, @_));
-
- ${*$ftp}{'net_ftp_type'} = join(" ", $type, @_);
-
- $oldval;
-}
-
-
-sub alloc {
- my $ftp = shift;
- my $size = shift;
- my $oldval = ${*$ftp}{'net_ftp_allo'};
-
- return $oldval
- unless (defined $size);
-
- return undef
- unless ($ftp->_ALLO($size, @_));
-
- ${*$ftp}{'net_ftp_allo'} = join(" ", $size, @_);
-
- $oldval;
-}
-
-
-sub abort {
- my $ftp = shift;
-
- send($ftp, pack("CCC", $TELNET_IAC, $TELNET_IP, $TELNET_IAC), MSG_OOB);
-
- $ftp->command(pack("C", $TELNET_DM) . "ABOR");
-
- ${*$ftp}{'net_ftp_dataconn'}->close()
- if defined ${*$ftp}{'net_ftp_dataconn'};
-
- $ftp->response();
-
- $ftp->status == CMD_OK;
-}
-
-
-sub get {
- my ($ftp, $remote, $local, $where) = @_;
-
- my ($loc, $len, $buf, $resp, $data);
- local *FD;
-
- my $localfd = ref($local) || ref(\$local) eq "GLOB";
-
- ($local = $remote) =~ s#^.*/##
- unless (defined $local);
-
- croak("Bad remote filename '$remote'\n")
- if $remote =~ /[\r\n]/s;
-
- ${*$ftp}{'net_ftp_rest'} = $where if defined $where;
- my $rest = ${*$ftp}{'net_ftp_rest'};
-
- delete ${*$ftp}{'net_ftp_port'};
- delete ${*$ftp}{'net_ftp_pasv'};
-
- $data = $ftp->retr($remote)
- or return undef;
-
- if ($localfd) {
- $loc = $local;
- }
- else {
- $loc = \*FD;
-
- unless (sysopen($loc, $local, O_CREAT | O_WRONLY | ($rest ? O_APPEND: O_TRUNC))) {
- carp "Cannot open Local file $local: $!\n";
- $data->abort;
- return undef;
- }
- }
-
- if ($ftp->type eq 'I' && !binmode($loc)) {
- carp "Cannot binmode Local file $local: $!\n";
- $data->abort;
- close($loc) unless $localfd;
- return undef;
- }
-
- $buf = '';
- my ($count, $hashh, $hashb, $ref) = (0);
-
- ($hashh, $hashb) = @$ref
- if ($ref = ${*$ftp}{'net_ftp_hash'});
-
- my $blksize = ${*$ftp}{'net_ftp_blksize'};
- local $\; # Just in case
-
- while (1) {
- last unless $len = $data->read($buf, $blksize);
-
- if (trEBCDIC && $ftp->type ne 'I') {
- $buf = $ftp->toebcdic($buf);
- $len = length($buf);
- }
-
- if ($hashh) {
- $count += $len;
- print $hashh "#" x (int($count / $hashb));
- $count %= $hashb;
- }
- unless (print $loc $buf) {
- carp "Cannot write to Local file $local: $!\n";
- $data->abort;
- close($loc)
- unless $localfd;
- return undef;
- }
- }
-
- print $hashh "\n" if $hashh;
-
- unless ($localfd) {
- unless (close($loc)) {
- carp "Cannot close file $local (perhaps disk space) $!\n";
- return undef;
- }
- }
-
- unless ($data->close()) # implied $ftp->response
- {
- carp "Unable to close datastream";
- return undef;
- }
-
- return $local;
-}
-
-
-sub cwd {
- @_ == 1 || @_ == 2 or croak 'usage: $ftp->cwd( [ DIR ] )';
-
- my ($ftp, $dir) = @_;
-
- $dir = "/" unless defined($dir) && $dir =~ /\S/;
-
- $dir eq ".."
- ? $ftp->_CDUP()
- : $ftp->_CWD($dir);
-}
-
-
-sub cdup {
- @_ == 1 or croak 'usage: $ftp->cdup()';
- $_[0]->_CDUP;
-}
-
-
-sub pwd {
- @_ == 1 || croak 'usage: $ftp->pwd()';
- my $ftp = shift;
-
- $ftp->_PWD();
- $ftp->_extract_path;
-}
-
-# rmdir( $ftp, $dir, [ $recurse ] )
-#
-# Removes $dir on remote host via FTP.
-# $ftp is handle for remote host
-#
-# If $recurse is TRUE, the directory and deleted recursively.
-# This means all of its contents and subdirectories.
-#
-# Initial version contributed by Dinkum Software
-#
-sub rmdir {
- @_ == 2 || @_ == 3 or croak('usage: $ftp->rmdir( DIR [, RECURSE ] )');
-
- # Pick off the args
- my ($ftp, $dir, $recurse) = @_;
- my $ok;
-
- return $ok
- if $ok = $ftp->_RMD($dir)
- or !$recurse;
-
- # Try to delete the contents
- # Get a list of all the files in the directory
- my @filelist = grep { !/^\.{1,2}$/ } $ftp->ls($dir);
-
- return undef
- unless @filelist; # failed, it is probably not a directory
-
- # Go thru and delete each file or the directory
- my $file;
- foreach $file (map { m,/, ? $_ : "$dir/$_" } @filelist) {
- next # successfully deleted the file
- if $ftp->delete($file);
-
- # Failed to delete it, assume its a directory
- # Recurse and ignore errors, the final rmdir() will
- # fail on any errors here
- return $ok
- unless $ok = $ftp->rmdir($file, 1);
- }
-
- # Directory should be empty
- # Try to remove the directory again
- # Pass results directly to caller
- # If any of the prior deletes failed, this
- # rmdir() will fail because directory is not empty
- return $ftp->_RMD($dir);
-}
-
-
-sub restart {
- @_ == 2 || croak 'usage: $ftp->restart( BYTE_OFFSET )';
-
- my ($ftp, $where) = @_;
-
- ${*$ftp}{'net_ftp_rest'} = $where;
-
- return undef;
-}
-
-
-sub mkdir {
- @_ == 2 || @_ == 3 or croak 'usage: $ftp->mkdir( DIR [, RECURSE ] )';
-
- my ($ftp, $dir, $recurse) = @_;
-
- $ftp->_MKD($dir) || $recurse
- or return undef;
-
- my $path = $dir;
-
- unless ($ftp->ok) {
- my @path = split(m#(?=/+)#, $dir);
-
- $path = "";
-
- while (@path) {
- $path .= shift @path;
-
- $ftp->_MKD($path);
-
- $path = $ftp->_extract_path($path);
- }
-
- # If the creation of the last element was not successful, see if we
- # can cd to it, if so then return path
-
- unless ($ftp->ok) {
- my ($status, $message) = ($ftp->status, $ftp->message);
- my $pwd = $ftp->pwd;
-
- if ($pwd && $ftp->cwd($dir)) {
- $path = $dir;
- $ftp->cwd($pwd);
- }
- else {
- undef $path;
- }
- $ftp->set_status($status, $message);
- }
- }
-
- $path;
-}
-
-
-sub delete {
- @_ == 2 || croak 'usage: $ftp->delete( FILENAME )';
-
- $_[0]->_DELE($_[1]);
-}
-
-
-sub put { shift->_store_cmd("stor", @_) }
-sub put_unique { shift->_store_cmd("stou", @_) }
-sub append { shift->_store_cmd("appe", @_) }
-
-
-sub nlst { shift->_data_cmd("NLST", @_) }
-sub list { shift->_data_cmd("LIST", @_) }
-sub retr { shift->_data_cmd("RETR", @_) }
-sub stor { shift->_data_cmd("STOR", @_) }
-sub stou { shift->_data_cmd("STOU", @_) }
-sub appe { shift->_data_cmd("APPE", @_) }
-
-
-sub _store_cmd {
- my ($ftp, $cmd, $local, $remote) = @_;
- my ($loc, $sock, $len, $buf);
- local *FD;
-
- my $localfd = ref($local) || ref(\$local) eq "GLOB";
-
- unless (defined $remote) {
- croak 'Must specify remote filename with stream input'
- if $localfd;
-
- require File::Basename;
- $remote = File::Basename::basename($local);
- }
- if (defined ${*$ftp}{'net_ftp_allo'}) {
- delete ${*$ftp}{'net_ftp_allo'};
- }
- else {
-
- # if the user hasn't already invoked the alloc method since the last
- # _store_cmd call, figure out if the local file is a regular file(not
- # a pipe, or device) and if so get the file size from stat, and send
- # an ALLO command before sending the STOR, STOU, or APPE command.
- my $size = do { local $^W; -f $local && -s _ }; # no ALLO if sending data from a pipe
- $ftp->_ALLO($size) if $size;
- }
- croak("Bad remote filename '$remote'\n")
- if $remote =~ /[\r\n]/s;
-
- if ($localfd) {
- $loc = $local;
- }
- else {
- $loc = \*FD;
-
- unless (sysopen($loc, $local, O_RDONLY)) {
- carp "Cannot open Local file $local: $!\n";
- return undef;
- }
- }
-
- if ($ftp->type eq 'I' && !binmode($loc)) {
- carp "Cannot binmode Local file $local: $!\n";
- return undef;
- }
-
- delete ${*$ftp}{'net_ftp_port'};
- delete ${*$ftp}{'net_ftp_pasv'};
-
- $sock = $ftp->_data_cmd($cmd, $remote)
- or return undef;
-
- $remote = ($ftp->message =~ /FILE:\s*(.*)/)[0]
- if 'STOU' eq uc $cmd;
-
- my $blksize = ${*$ftp}{'net_ftp_blksize'};
-
- my ($count, $hashh, $hashb, $ref) = (0);
-
- ($hashh, $hashb) = @$ref
- if ($ref = ${*$ftp}{'net_ftp_hash'});
-
- while (1) {
- last unless $len = read($loc, $buf = "", $blksize);
-
- if (trEBCDIC && $ftp->type ne 'I') {
- $buf = $ftp->toascii($buf);
- $len = length($buf);
- }
-
- if ($hashh) {
- $count += $len;
- print $hashh "#" x (int($count / $hashb));
- $count %= $hashb;
- }
-
- my $wlen;
- unless (defined($wlen = $sock->write($buf, $len)) && $wlen == $len) {
- $sock->abort;
- close($loc)
- unless $localfd;
- print $hashh "\n" if $hashh;
- return undef;
- }
- }
-
- print $hashh "\n" if $hashh;
-
- close($loc)
- unless $localfd;
-
- $sock->close()
- or return undef;
-
- if ('STOU' eq uc $cmd and $ftp->message =~ m/unique\s+file\s*name\s*:\s*(.*)\)|"(.*)"/) {
- require File::Basename;
- $remote = File::Basename::basename($+);
- }
-
- return $remote;
-}
-
-
-sub port {
- @_ == 1 || @_ == 2 or croak 'usage: $ftp->port([PORT])';
-
- my ($ftp, $port) = @_;
- my $ok;
-
- delete ${*$ftp}{'net_ftp_intern_port'};
-
- unless (defined $port) {
-
- # create a Listen socket at same address as the command socket
-
- ${*$ftp}{'net_ftp_listen'} ||= IO::Socket::INET->new(
- Listen => 5,
- Proto => 'tcp',
- Timeout => $ftp->timeout,
- LocalAddr => $ftp->sockhost,
- );
-
- my $listen = ${*$ftp}{'net_ftp_listen'};
-
- my ($myport, @myaddr) = ($listen->sockport, split(/\./, $listen->sockhost));
-
- $port = join(',', @myaddr, $myport >> 8, $myport & 0xff);
-
- ${*$ftp}{'net_ftp_intern_port'} = 1;
- }
-
- $ok = $ftp->_PORT($port);
-
- ${*$ftp}{'net_ftp_port'} = $port;
-
- $ok;
-}
-
-
-sub ls { shift->_list_cmd("NLST", @_); }
-sub dir { shift->_list_cmd("LIST", @_); }
-
-
-sub pasv {
- @_ == 1 or croak 'usage: $ftp->pasv()';
-
- my $ftp = shift;
-
- delete ${*$ftp}{'net_ftp_intern_port'};
-
- $ftp->_PASV && $ftp->message =~ /(\d+(,\d+)+)/
- ? ${*$ftp}{'net_ftp_pasv'} = $1
- : undef;
-}
-
-
-sub unique_name {
- my $ftp = shift;
- ${*$ftp}{'net_ftp_unique'} || undef;
-}
-
-
-sub supported {
- @_ == 2 or croak 'usage: $ftp->supported( CMD )';
- my $ftp = shift;
- my $cmd = uc shift;
- my $hash = ${*$ftp}{'net_ftp_supported'} ||= {};
-
- return $hash->{$cmd}
- if exists $hash->{$cmd};
-
- return $hash->{$cmd} = 0
- unless $ftp->_HELP($cmd);
-
- my $text = $ftp->message;
- if ($text =~ /following\s+commands/i) {
- $text =~ s/^.*\n//;
- while ($text =~ /(\*?)(\w+)(\*?)/sg) {
- $hash->{"\U$2"} = !length("$1$3");
- }
- }
- else {
- $hash->{$cmd} = $text !~ /unimplemented/i;
- }
-
- $hash->{$cmd} ||= 0;
-}
-
-##
-## Deprecated methods
-##
-
-
-sub lsl {
- carp "Use of Net::FTP::lsl deprecated, use 'dir'"
- if $^W;
- goto &dir;
-}
-
-
-sub authorise {
- carp "Use of Net::FTP::authorise deprecated, use 'authorize'"
- if $^W;
- goto &authorize;
-}
-
-
-##
-## Private methods
-##
-
-
-sub _extract_path {
- my ($ftp, $path) = @_;
-
- # This tries to work both with and without the quote doubling
- # convention (RFC 959 requires it, but the first 3 servers I checked
- # didn't implement it). It will fail on a server which uses a quote in
- # the message which isn't a part of or surrounding the path.
- $ftp->ok
- && $ftp->message =~ /(?:^|\s)\"(.*)\"(?:$|\s)/
- && ($path = $1) =~ s/\"\"/\"/g;
-
- $path;
-}
-
-##
-## Communication methods
-##
-
-
-sub _dataconn {
- my $ftp = shift;
- my $data = undef;
- my $pkg = "Net::FTP::" . $ftp->type;
-
- eval "require " . $pkg;
-
- $pkg =~ s/ /_/g;
-
- delete ${*$ftp}{'net_ftp_dataconn'};
-
- if (defined ${*$ftp}{'net_ftp_pasv'}) {
- my @port = map { 0 + $_ } split(/,/, ${*$ftp}{'net_ftp_pasv'});
-
- $data = $pkg->new(
- PeerAddr => join(".", @port[0 .. 3]),
- PeerPort => $port[4] * 256 + $port[5],
- LocalAddr => ${*$ftp}{'net_ftp_localaddr'},
- Proto => 'tcp'
- );
- }
- elsif (defined ${*$ftp}{'net_ftp_listen'}) {
- $data = ${*$ftp}{'net_ftp_listen'}->accept($pkg);
- close(delete ${*$ftp}{'net_ftp_listen'});
- }
-
- if ($data) {
- ${*$data} = "";
- $data->timeout($ftp->timeout);
- ${*$ftp}{'net_ftp_dataconn'} = $data;
- ${*$data}{'net_ftp_cmd'} = $ftp;
- ${*$data}{'net_ftp_blksize'} = ${*$ftp}{'net_ftp_blksize'};
- }
-
- $data;
-}
-
-
-sub _list_cmd {
- my $ftp = shift;
- my $cmd = uc shift;
-
- delete ${*$ftp}{'net_ftp_port'};
- delete ${*$ftp}{'net_ftp_pasv'};
-
- my $data = $ftp->_data_cmd($cmd, @_);
-
- return
- unless (defined $data);
-
- require Net::FTP::A;
- bless $data, "Net::FTP::A"; # Force ASCII mode
-
- my $databuf = '';
- my $buf = '';
- my $blksize = ${*$ftp}{'net_ftp_blksize'};
-
- while ($data->read($databuf, $blksize)) {
- $buf .= $databuf;
- }
-
- my $list = [split(/\n/, $buf)];
-
- $data->close();
-
- if (trEBCDIC) {
- for (@$list) { $_ = $ftp->toebcdic($_) }
- }
-
- wantarray
- ? @{$list}
- : $list;
-}
-
-
-sub _data_cmd {
- my $ftp = shift;
- my $cmd = uc shift;
- my $ok = 1;
- my $where = delete ${*$ftp}{'net_ftp_rest'} || 0;
- my $arg;
-
- for $arg (@_) {
- croak("Bad argument '$arg'\n")
- if $arg =~ /[\r\n]/s;
- }
-
- if ( ${*$ftp}{'net_ftp_passive'}
- && !defined ${*$ftp}{'net_ftp_pasv'}
- && !defined ${*$ftp}{'net_ftp_port'})
- {
- my $data = undef;
-
- $ok = defined $ftp->pasv;
- $ok = $ftp->_REST($where)
- if $ok && $where;
-
- if ($ok) {
- $ftp->command($cmd, @_);
- $data = $ftp->_dataconn();
- $ok = CMD_INFO == $ftp->response();
- if ($ok) {
- $data->reading
- if $data && $cmd =~ /RETR|LIST|NLST/;
- return $data;
- }
- $data->_close
- if $data;
- }
- return undef;
- }
-
- $ok = $ftp->port
- unless (defined ${*$ftp}{'net_ftp_port'}
- || defined ${*$ftp}{'net_ftp_pasv'});
-
- $ok = $ftp->_REST($where)
- if $ok && $where;
-
- return undef
- unless $ok;
-
- $ftp->command($cmd, @_);
-
- return 1
- if (defined ${*$ftp}{'net_ftp_pasv'});
-
- $ok = CMD_INFO == $ftp->response();
-
- return $ok
- unless exists ${*$ftp}{'net_ftp_intern_port'};
-
- if ($ok) {
- my $data = $ftp->_dataconn();
-
- $data->reading
- if $data && $cmd =~ /RETR|LIST|NLST/;
-
- return $data;
- }
-
-
- close(delete ${*$ftp}{'net_ftp_listen'});
-
- return undef;
-}
-
-##
-## Over-ride methods (Net::Cmd)
-##
-
-
-sub debug_text { $_[2] =~ /^(pass|resp|acct)/i ? "$1 ....\n" : $_[2]; }
-
-
-sub command {
- my $ftp = shift;
-
- delete ${*$ftp}{'net_ftp_port'};
- $ftp->SUPER::command(@_);
-}
-
-
-sub response {
- my $ftp = shift;
- my $code = $ftp->SUPER::response();
-
- delete ${*$ftp}{'net_ftp_pasv'}
- if ($code != CMD_MORE && $code != CMD_INFO);
-
- $code;
-}
-
-
-sub parse_response {
- return ($1, $2 eq "-")
- if $_[1] =~ s/^(\d\d\d)([- ]?)//o;
-
- my $ftp = shift;
-
- # Darn MS FTP server is a load of CRAP !!!!
- return ()
- unless ${*$ftp}{'net_cmd_code'} + 0;
-
- (${*$ftp}{'net_cmd_code'}, 1);
-}
-
-##
-## Allow 2 servers to talk directly
-##
-
-
-sub pasv_xfer_unique {
- my ($sftp, $sfile, $dftp, $dfile) = @_;
- $sftp->pasv_xfer($sfile, $dftp, $dfile, 1);
-}
-
-
-sub pasv_xfer {
- my ($sftp, $sfile, $dftp, $dfile, $unique) = @_;
-
- ($dfile = $sfile) =~ s#.*/##
- unless (defined $dfile);
-
- my $port = $sftp->pasv
- or return undef;
-
- $dftp->port($port)
- or return undef;
-
- return undef
- unless ($unique ? $dftp->stou($dfile) : $dftp->stor($dfile));
-
- unless ($sftp->retr($sfile) && $sftp->response == CMD_INFO) {
- $sftp->retr($sfile);
- $dftp->abort;
- $dftp->response();
- return undef;
- }
-
- $dftp->pasv_wait($sftp);
-}
-
-
-sub pasv_wait {
- @_ == 2 or croak 'usage: $ftp->pasv_wait(NON_PASV_FTP)';
-
- my ($ftp, $non_pasv) = @_;
- my ($file, $rin, $rout);
-
- vec($rin = '', fileno($ftp), 1) = 1;
- select($rout = $rin, undef, undef, undef);
-
- $ftp->response();
- $non_pasv->response();
-
- return undef
- unless $ftp->ok() && $non_pasv->ok();
-
- return $1
- if $ftp->message =~ /unique file name:\s*(\S*)\s*\)/;
-
- return $1
- if $non_pasv->message =~ /unique file name:\s*(\S*)\s*\)/;
-
- return 1;
-}
-
-
-sub feature {
- @_ == 2 or croak 'usage: $ftp->feature( NAME )';
- my ($ftp, $feat) = @_;
-
- my $feature = ${*$ftp}{net_ftp_feature} ||= do {
- my @feat;
-
- # Example response
- # 211-Features:
- # MDTM
- # REST STREAM
- # SIZE
- # 211 End
-
- @feat = map { /^\s+(.*\S)/ } $ftp->message
- if $ftp->_FEAT;
-
- \@feat;
- };
-
- return grep { /^\Q$feat\E\b/i } @$feature;
-}
-
-
-sub cmd { shift->command(@_)->response() }
-
-########################################
-#
-# RFC959 commands
-#
-
-
-sub _ABOR { shift->command("ABOR")->response() == CMD_OK }
-sub _ALLO { shift->command("ALLO", @_)->response() == CMD_OK }
-sub _CDUP { shift->command("CDUP")->response() == CMD_OK }
-sub _NOOP { shift->command("NOOP")->response() == CMD_OK }
-sub _PASV { shift->command("PASV")->response() == CMD_OK }
-sub _QUIT { shift->command("QUIT")->response() == CMD_OK }
-sub _DELE { shift->command("DELE", @_)->response() == CMD_OK }
-sub _CWD { shift->command("CWD", @_)->response() == CMD_OK }
-sub _PORT { shift->command("PORT", @_)->response() == CMD_OK }
-sub _RMD { shift->command("RMD", @_)->response() == CMD_OK }
-sub _MKD { shift->command("MKD", @_)->response() == CMD_OK }
-sub _PWD { shift->command("PWD", @_)->response() == CMD_OK }
-sub _TYPE { shift->command("TYPE", @_)->response() == CMD_OK }
-sub _RNTO { shift->command("RNTO", @_)->response() == CMD_OK }
-sub _RESP { shift->command("RESP", @_)->response() == CMD_OK }
-sub _MDTM { shift->command("MDTM", @_)->response() == CMD_OK }
-sub _SIZE { shift->command("SIZE", @_)->response() == CMD_OK }
-sub _HELP { shift->command("HELP", @_)->response() == CMD_OK }
-sub _STAT { shift->command("STAT", @_)->response() == CMD_OK }
-sub _FEAT { shift->command("FEAT", @_)->response() == CMD_OK }
-sub _APPE { shift->command("APPE", @_)->response() == CMD_INFO }
-sub _LIST { shift->command("LIST", @_)->response() == CMD_INFO }
-sub _NLST { shift->command("NLST", @_)->response() == CMD_INFO }
-sub _RETR { shift->command("RETR", @_)->response() == CMD_INFO }
-sub _STOR { shift->command("STOR", @_)->response() == CMD_INFO }
-sub _STOU { shift->command("STOU", @_)->response() == CMD_INFO }
-sub _RNFR { shift->command("RNFR", @_)->response() == CMD_MORE }
-sub _REST { shift->command("REST", @_)->response() == CMD_MORE }
-sub _PASS { shift->command("PASS", @_)->response() }
-sub _ACCT { shift->command("ACCT", @_)->response() }
-sub _AUTH { shift->command("AUTH", @_)->response() }
-
-
-sub _USER {
- my $ftp = shift;
- my $ok = $ftp->command("USER", @_)->response();
-
- # A certain brain dead firewall :-)
- $ok = $ftp->command("user", @_)->response()
- unless $ok == CMD_MORE or $ok == CMD_OK;
-
- $ok;
-}
-
-
-sub _SMNT { shift->unsupported(@_) }
-sub _MODE { shift->unsupported(@_) }
-sub _SYST { shift->unsupported(@_) }
-sub _STRU { shift->unsupported(@_) }
-sub _REIN { shift->unsupported(@_) }
-
-1;
-
-__END__
-
-=head1 NAME
-
-Net::FTP - FTP Client class
-
-=head1 SYNOPSIS
-
- use Net::FTP;
-
- $ftp = Net::FTP->new("some.host.name", Debug => 0)
- or die "Cannot connect to some.host.name: $@";
-
- $ftp->login("anonymous",'-anonymous@')
- or die "Cannot login ", $ftp->message;
-
- $ftp->cwd("/pub")
- or die "Cannot change working directory ", $ftp->message;
-
- $ftp->get("that.file")
- or die "get failed ", $ftp->message;
-
- $ftp->quit;
-
-=head1 DESCRIPTION
-
-C<Net::FTP> is a class implementing a simple FTP client in Perl as
-described in RFC959. It provides wrappers for a subset of the RFC959
-commands.
-
-=head1 OVERVIEW
-
-FTP stands for File Transfer Protocol. It is a way of transferring
-files between networked machines. The protocol defines a client
-(whose commands are provided by this module) and a server (not
-implemented in this module). Communication is always initiated by the
-client, and the server responds with a message and a status code (and
-sometimes with data).
-
-The FTP protocol allows files to be sent to or fetched from the
-server. Each transfer involves a B<local file> (on the client) and a
-B<remote file> (on the server). In this module, the same file name
-will be used for both local and remote if only one is specified. This
-means that transferring remote file C</path/to/file> will try to put
-that file in C</path/to/file> locally, unless you specify a local file
-name.
-
-The protocol also defines several standard B<translations> which the
-file can undergo during transfer. These are ASCII, EBCDIC, binary,
-and byte. ASCII is the default type, and indicates that the sender of
-files will translate the ends of lines to a standard representation
-which the receiver will then translate back into their local
-representation. EBCDIC indicates the file being transferred is in
-EBCDIC format. Binary (also known as image) format sends the data as
-a contiguous bit stream. Byte format transfers the data as bytes, the
-values of which remain the same regardless of differences in byte size
-between the two machines (in theory - in practice you should only use
-this if you really know what you're doing).
-
-=head1 CONSTRUCTOR
-
-=over 4
-
-=item new ([ HOST ] [, OPTIONS ])
-
-This is the constructor for a new Net::FTP object. C<HOST> is the
-name of the remote host to which an FTP connection is required.
-
-C<HOST> is optional. If C<HOST> is not given then it may instead be
-passed as the C<Host> option described below.
-
-C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
-Possible options are:
-
-B<Host> - FTP host to connect to. It may be a single scalar, as defined for
-the C<PeerAddr> option in L<IO::Socket::INET>, or a reference to
-an array with hosts to try in turn. The L</host> method will return the value
-which was used to connect to the host.
-
-
-B<Firewall> - The name of a machine which acts as an FTP firewall. This can be
-overridden by an environment variable C<FTP_FIREWALL>. If specified, and the
-given host cannot be directly connected to, then the
-connection is made to the firewall machine and the string C<@hostname> is
-appended to the login identifier. This kind of setup is also referred to
-as an ftp proxy.
-
-B<FirewallType> - The type of firewall running on the machine indicated by
-B<Firewall>. This can be overridden by an environment variable
-C<FTP_FIREWALL_TYPE>. For a list of permissible types, see the description of
-ftp_firewall_type in L<Net::Config>.
-
-B<BlockSize> - This is the block size that Net::FTP will use when doing
-transfers. (defaults to 10240)
-
-B<Port> - The port number to connect to on the remote machine for the
-FTP connection
-
-B<Timeout> - Set a timeout value (defaults to 120)
-
-B<Debug> - debug level (see the debug method in L<Net::Cmd>)
-
-B<Passive> - If set to a non-zero value then all data transfers will
-be done using passive mode. If set to zero then data transfers will be
-done using active mode. If the machine is connected to the Internet
-directly, both passive and active mode should work equally well.
-Behind most firewall and NAT configurations passive mode has a better
-chance of working. However, in some rare firewall configurations,
-active mode actually works when passive mode doesn't. Some really old
-FTP servers might not implement passive transfers. If not specified,
-then the transfer mode is set by the environment variable
-C<FTP_PASSIVE> or if that one is not set by the settings done by the
-F<libnetcfg> utility. If none of these apply then passive mode is
-used.
-
-B<Hash> - If given a reference to a file handle (e.g., C<\*STDERR>),
-print hash marks (#) on that filehandle every 1024 bytes. This
-simply invokes the C<hash()> method for you, so that hash marks
-are displayed for all transfers. You can, of course, call C<hash()>
-explicitly whenever you'd like.
-
-B<LocalAddr> - Local address to use for all socket connections, this
-argument will be passed to L<IO::Socket::INET>
-
-If the constructor fails undef will be returned and an error message will
-be in $@
-
-=back
-
-=head1 METHODS
-
-Unless otherwise stated all methods return either a I<true> or I<false>
-value, with I<true> meaning that the operation was a success. When a method
-states that it returns a value, failure will be returned as I<undef> or an
-empty list.
-
-=over 4
-
-=item login ([LOGIN [,PASSWORD [, ACCOUNT] ] ])
-
-Log into the remote FTP server with the given login information. If
-no arguments are given then the C<Net::FTP> uses the C<Net::Netrc>
-package to lookup the login information for the connected host.
-If no information is found then a login of I<anonymous> is used.
-If no password is given and the login is I<anonymous> then I<anonymous@>
-will be used for password.
-
-If the connection is via a firewall then the C<authorize> method will
-be called with no arguments.
-
-=item authorize ( [AUTH [, RESP]])
-
-This is a protocol used by some firewall ftp proxies. It is used
-to authorise the user to send data out. If both arguments are not specified
-then C<authorize> uses C<Net::Netrc> to do a lookup.
-
-=item site (ARGS)
-
-Send a SITE command to the remote server and wait for a response.
-
-Returns most significant digit of the response code.
-
-=item ascii
-
-Transfer file in ASCII. CRLF translation will be done if required
-
-=item binary
-
-Transfer file in binary mode. No transformation will be done.
-
-B<Hint>: If both server and client machines use the same line ending for
-text files, then it will be faster to transfer all files in binary mode.
-
-=item rename ( OLDNAME, NEWNAME )
-
-Rename a file on the remote FTP server from C<OLDNAME> to C<NEWNAME>. This
-is done by sending the RNFR and RNTO commands.
-
-=item delete ( FILENAME )
-
-Send a request to the server to delete C<FILENAME>.
-
-=item cwd ( [ DIR ] )
-
-Attempt to change directory to the directory given in C<$dir>. If
-C<$dir> is C<"..">, the FTP C<CDUP> command is used to attempt to
-move up one directory. If no directory is given then an attempt is made
-to change the directory to the root directory.
-
-=item cdup ()
-
-Change directory to the parent of the current directory.
-
-=item pwd ()
-
-Returns the full pathname of the current directory.
-
-=item restart ( WHERE )
-
-Set the byte offset at which to begin the next data transfer. Net::FTP simply
-records this value and uses it when during the next data transfer. For this
-reason this method will not return an error, but setting it may cause
-a subsequent data transfer to fail.
-
-=item rmdir ( DIR [, RECURSE ])
-
-Remove the directory with the name C<DIR>. If C<RECURSE> is I<true> then
-C<rmdir> will attempt to delete everything inside the directory.
-
-=item mkdir ( DIR [, RECURSE ])
-
-Create a new directory with the name C<DIR>. If C<RECURSE> is I<true> then
-C<mkdir> will attempt to create all the directories in the given path.
-
-Returns the full pathname to the new directory.
-
-=item alloc ( SIZE [, RECORD_SIZE] )
-
-The alloc command allows you to give the ftp server a hint about the size
-of the file about to be transferred using the ALLO ftp command. Some storage
-systems use this to make intelligent decisions about how to store the file.
-The C<SIZE> argument represents the size of the file in bytes. The
-C<RECORD_SIZE> argument indicates a maximum record or page size for files
-sent with a record or page structure.
-
-The size of the file will be determined, and sent to the server
-automatically for normal files so that this method need only be called if
-you are transferring data from a socket, named pipe, or other stream not
-associated with a normal file.
-
-=item ls ( [ DIR ] )
-
-Get a directory listing of C<DIR>, or the current directory.
-
-In an array context, returns a list of lines returned from the server. In
-a scalar context, returns a reference to a list.
-
-=item dir ( [ DIR ] )
-
-Get a directory listing of C<DIR>, or the current directory in long format.
-
-In an array context, returns a list of lines returned from the server. In
-a scalar context, returns a reference to a list.
-
-=item get ( REMOTE_FILE [, LOCAL_FILE [, WHERE]] )
-
-Get C<REMOTE_FILE> from the server and store locally. C<LOCAL_FILE> may be
-a filename or a filehandle. If not specified, the file will be stored in
-the current directory with the same leafname as the remote file.
-
-If C<WHERE> is given then the first C<WHERE> bytes of the file will
-not be transferred, and the remaining bytes will be appended to
-the local file if it already exists.
-
-Returns C<LOCAL_FILE>, or the generated local file name if C<LOCAL_FILE>
-is not given. If an error was encountered undef is returned.
-
-=item put ( LOCAL_FILE [, REMOTE_FILE ] )
-
-Put a file on the remote server. C<LOCAL_FILE> may be a name or a filehandle.
-If C<LOCAL_FILE> is a filehandle then C<REMOTE_FILE> must be specified. If
-C<REMOTE_FILE> is not specified then the file will be stored in the current
-directory with the same leafname as C<LOCAL_FILE>.
-
-Returns C<REMOTE_FILE>, or the generated remote filename if C<REMOTE_FILE>
-is not given.
-
-B<NOTE>: If for some reason the transfer does not complete and an error is
-returned then the contents that had been transferred will not be remove
-automatically.
-
-=item put_unique ( LOCAL_FILE [, REMOTE_FILE ] )
-
-Same as put but uses the C<STOU> command.
-
-Returns the name of the file on the server.
-
-=item append ( LOCAL_FILE [, REMOTE_FILE ] )
-
-Same as put but appends to the file on the remote server.
-
-Returns C<REMOTE_FILE>, or the generated remote filename if C<REMOTE_FILE>
-is not given.
-
-=item unique_name ()
-
-Returns the name of the last file stored on the server using the
-C<STOU> command.
-
-=item mdtm ( FILE )
-
-Returns the I<modification time> of the given file
-
-=item size ( FILE )
-
-Returns the size in bytes for the given file as stored on the remote server.
-
-B<NOTE>: The size reported is the size of the stored file on the remote server.
-If the file is subsequently transferred from the server in ASCII mode
-and the remote server and local machine have different ideas about
-"End Of Line" then the size of file on the local machine after transfer
-may be different.
-
-=item supported ( CMD )
-
-Returns TRUE if the remote server supports the given command.
-
-=item hash ( [FILEHANDLE_GLOB_REF],[ BYTES_PER_HASH_MARK] )
-
-Called without parameters, or with the first argument false, hash marks
-are suppressed. If the first argument is true but not a reference to a
-file handle glob, then \*STDERR is used. The second argument is the number
-of bytes per hash mark printed, and defaults to 1024. In all cases the
-return value is a reference to an array of two: the filehandle glob reference
-and the bytes per hash mark.
-
-=item feature ( NAME )
-
-Determine if the server supports the specified feature. The return
-value is a list of lines the server responded with to describe the
-options that it supports for the given feature. If the feature is
-unsupported then the empty list is returned.
-
- if ($ftp->feature( 'MDTM' )) {
- # Do something
- }
-
- if (grep { /\bTLS\b/ } $ftp->feature('AUTH')) {
- # Server supports TLS
- }
-
-=back
-
-The following methods can return different results depending on
-how they are called. If the user explicitly calls either
-of the C<pasv> or C<port> methods then these methods will
-return a I<true> or I<false> value. If the user does not
-call either of these methods then the result will be a
-reference to a C<Net::FTP::dataconn> based object.
-
-=over 4
-
-=item nlst ( [ DIR ] )
-
-Send an C<NLST> command to the server, with an optional parameter.
-
-=item list ( [ DIR ] )
-
-Same as C<nlst> but using the C<LIST> command
-
-=item retr ( FILE )
-
-Begin the retrieval of a file called C<FILE> from the remote server.
-
-=item stor ( FILE )
-
-Tell the server that you wish to store a file. C<FILE> is the
-name of the new file that should be created.
-
-=item stou ( FILE )
-
-Same as C<stor> but using the C<STOU> command. The name of the unique
-file which was created on the server will be available via the C<unique_name>
-method after the data connection has been closed.
-
-=item appe ( FILE )
-
-Tell the server that we want to append some data to the end of a file
-called C<FILE>. If this file does not exist then create it.
-
-=back
-
-If for some reason you want to have complete control over the data connection,
-this includes generating it and calling the C<response> method when required,
-then the user can use these methods to do so.
-
-However calling these methods only affects the use of the methods above that
-can return a data connection. They have no effect on methods C<get>, C<put>,
-C<put_unique> and those that do not require data connections.
-
-=over 4
-
-=item port ( [ PORT ] )
-
-Send a C<PORT> command to the server. If C<PORT> is specified then it is sent
-to the server. If not, then a listen socket is created and the correct information
-sent to the server.
-
-=item pasv ()
-
-Tell the server to go into passive mode. Returns the text that represents the
-port on which the server is listening, this text is in a suitable form to
-sent to another ftp server using the C<port> method.
-
-=back
-
-The following methods can be used to transfer files between two remote
-servers, providing that these two servers can connect directly to each other.
-
-=over 4
-
-=item pasv_xfer ( SRC_FILE, DEST_SERVER [, DEST_FILE ] )
-
-This method will do a file transfer between two remote ftp servers. If
-C<DEST_FILE> is omitted then the leaf name of C<SRC_FILE> will be used.
-
-=item pasv_xfer_unique ( SRC_FILE, DEST_SERVER [, DEST_FILE ] )
-
-Like C<pasv_xfer> but the file is stored on the remote server using
-the STOU command.
-
-=item pasv_wait ( NON_PASV_SERVER )
-
-This method can be used to wait for a transfer to complete between a passive
-server and a non-passive server. The method should be called on the passive
-server with the C<Net::FTP> object for the non-passive server passed as an
-argument.
-
-=item abort ()
-
-Abort the current data transfer.
-
-=item quit ()
-
-Send the QUIT command to the remote FTP server and close the socket connection.
-
-=back
-
-=head2 Methods for the adventurous
-
-C<Net::FTP> inherits from C<Net::Cmd> so methods defined in C<Net::Cmd> may
-be used to send commands to the remote FTP server.
-
-=over 4
-
-=item quot (CMD [,ARGS])
-
-Send a command, that Net::FTP does not directly support, to the remote
-server and wait for a response.
-
-Returns most significant digit of the response code.
-
-B<WARNING> This call should only be used on commands that do not require
-data connections. Misuse of this method can hang the connection.
-
-=back
-
-=head1 THE dataconn CLASS
-
-Some of the methods defined in C<Net::FTP> return an object which will
-be derived from this class.The dataconn class itself is derived from
-the C<IO::Socket::INET> class, so any normal IO operations can be performed.
-However the following methods are defined in the dataconn class and IO should
-be performed using these.
-
-=over 4
-
-=item read ( BUFFER, SIZE [, TIMEOUT ] )
-
-Read C<SIZE> bytes of data from the server and place it into C<BUFFER>, also
-performing any <CRLF> translation necessary. C<TIMEOUT> is optional, if not
-given, the timeout value from the command connection will be used.
-
-Returns the number of bytes read before any <CRLF> translation.
-
-=item write ( BUFFER, SIZE [, TIMEOUT ] )
-
-Write C<SIZE> bytes of data from C<BUFFER> to the server, also
-performing any <CRLF> translation necessary. C<TIMEOUT> is optional, if not
-given, the timeout value from the command connection will be used.
-
-Returns the number of bytes written before any <CRLF> translation.
-
-=item bytes_read ()
-
-Returns the number of bytes read so far.
-
-=item abort ()
-
-Abort the current data transfer.
-
-=item close ()
-
-Close the data connection and get a response from the FTP server. Returns
-I<true> if the connection was closed successfully and the first digit of
-the response from the server was a '2'.
-
-=back
-
-=head1 UNIMPLEMENTED
-
-The following RFC959 commands have not been implemented:
-
-=over 4
-
-=item B<SMNT>
-
-Mount a different file system structure without changing login or
-accounting information.
-
-=item B<HELP>
-
-Ask the server for "helpful information" (that's what the RFC says) on
-the commands it accepts.
-
-=item B<MODE>
-
-Specifies transfer mode (stream, block or compressed) for file to be
-transferred.
-
-=item B<SYST>
-
-Request remote server system identification.
-
-=item B<STAT>
-
-Request remote server status.
-
-=item B<STRU>
-
-Specifies file structure for file to be transferred.
-
-=item B<REIN>
-
-Reinitialize the connection, flushing all I/O and account information.
-
-=back
-
-=head1 REPORTING BUGS
-
-When reporting bugs/problems please include as much information as possible.
-It may be difficult for me to reproduce the problem as almost every setup
-is different.
-
-A small script which yields the problem will probably be of help. It would
-also be useful if this script was run with the extra options C<Debug => 1>
-passed to the constructor, and the output sent with the bug report. If you
-cannot include a small script then please include a Debug trace from a
-run of your program which does yield the problem.
-
-=head1 AUTHOR
-
-Graham Barr <gbarr@pobox.com>
-
-=head1 SEE ALSO
-
-L<Net::Netrc>
-L<Net::Cmd>
-
-ftp(1), ftpd(8), RFC 959
-http://www.cis.ohio-state.edu/htbin/rfc/rfc959.html
-
-=head1 USE EXAMPLES
-
-For an example of the use of Net::FTP see
-
-=over 4
-
-=item http://www.csh.rit.edu/~adam/Progs/
-
-C<autoftp> is a program that can retrieve, send, or list files via
-the FTP protocol in a non-interactive manner.
-
-=back
-
-=head1 CREDITS
-
-Henry Gabryjelski <henryg@WPI.EDU> - for the suggestion of creating directories
-recursively.
-
-Nathan Torkington <gnat@frii.com> - for some input on the documentation.
-
-Roderick Schertler <roderick@gate.net> - for various inputs
-
-=head1 COPYRIGHT
-
-Copyright (c) 1995-2004 Graham Barr. All rights reserved.
-This program is free software; you can redistribute it and/or modify it
-under the same terms as Perl itself.
-
-=cut
diff --git a/Master/tlpkg/tlperl/lib/Net/FTP/A.pm b/Master/tlpkg/tlperl/lib/Net/FTP/A.pm
deleted file mode 100755
index 427d02b19e9..00000000000
--- a/Master/tlpkg/tlperl/lib/Net/FTP/A.pm
+++ /dev/null
@@ -1,111 +0,0 @@
-##
-## Package to read/write on ASCII data connections
-##
-
-package Net::FTP::A;
-use strict;
-use vars qw(@ISA $buf $VERSION);
-use Carp;
-
-require Net::FTP::dataconn;
-
-@ISA = qw(Net::FTP::dataconn);
-$VERSION = "1.18";
-
-
-sub read {
- my $data = shift;
- local *buf = \$_[0];
- shift;
- my $size = shift || croak 'read($buf,$size,[$offset])';
- my $timeout = @_ ? shift: $data->timeout;
-
- if (length(${*$data}) < $size && !${*$data}{'net_ftp_eof'}) {
- my $blksize = ${*$data}{'net_ftp_blksize'};
- $blksize = $size if $size > $blksize;
-
- my $l = 0;
- my $n;
-
- READ:
- {
- my $readbuf = defined(${*$data}{'net_ftp_cr'}) ? "\015" : '';
-
- $data->can_read($timeout)
- or croak "Timeout";
-
- if ($n = sysread($data, $readbuf, $blksize, length $readbuf)) {
- ${*$data}{'net_ftp_bytesread'} += $n;
- ${*$data}{'net_ftp_cr'} =
- substr($readbuf, -1) eq "\015"
- ? chop($readbuf)
- : undef;
- }
- else {
- return undef
- unless defined $n;
-
- ${*$data}{'net_ftp_eof'} = 1;
- }
-
- $readbuf =~ s/\015\012/\n/sgo;
- ${*$data} .= $readbuf;
-
- unless (length(${*$data})) {
-
- redo READ
- if ($n > 0);
-
- $size = length(${*$data})
- if ($n == 0);
- }
- }
- }
-
- $buf = substr(${*$data}, 0, $size);
- substr(${*$data}, 0, $size) = '';
-
- length $buf;
-}
-
-
-sub write {
- my $data = shift;
- local *buf = \$_[0];
- shift;
- my $size = shift || croak 'write($buf,$size,[$timeout])';
- my $timeout = @_ ? shift: $data->timeout;
-
- my $nr = (my $tmp = substr($buf, 0, $size)) =~ tr/\r\n/\015\012/;
- $tmp =~ s/([^\015])\012/$1\015\012/sg if $nr;
- $tmp =~ s/^\012/\015\012/ unless ${*$data}{'net_ftp_outcr'};
- ${*$data}{'net_ftp_outcr'} = substr($tmp, -1) eq "\015";
-
- # If the remote server has closed the connection we will be signal'd
- # when we write. This can happen if the disk on the remote server fills up
-
- local $SIG{PIPE} = 'IGNORE'
- unless ($SIG{PIPE} || '') eq 'IGNORE'
- or $^O eq 'MacOS';
-
- my $len = length($tmp);
- my $off = 0;
- my $wrote = 0;
-
- my $blksize = ${*$data}{'net_ftp_blksize'};
-
- while ($len) {
- $data->can_write($timeout)
- or croak "Timeout";
-
- $off += $wrote;
- $wrote = syswrite($data, substr($tmp, $off), $len > $blksize ? $blksize : $len);
- return undef
- unless defined($wrote);
- $len -= $wrote;
- }
-
- $size;
-}
-
-1;
diff --git a/Master/tlpkg/tlperl/lib/Net/FTP/E.pm b/Master/tlpkg/tlperl/lib/Net/FTP/E.pm
deleted file mode 100755
index d480cd72955..00000000000
--- a/Master/tlpkg/tlperl/lib/Net/FTP/E.pm
+++ /dev/null
@@ -1,8 +0,0 @@
-package Net::FTP::E;
-
-require Net::FTP::I;
-
-@ISA = qw(Net::FTP::I);
-$VERSION = "0.01";
-
-1;
diff --git a/Master/tlpkg/tlperl/lib/Net/FTP/I.pm b/Master/tlpkg/tlperl/lib/Net/FTP/I.pm
deleted file mode 100755
index 449bb99eab6..00000000000
--- a/Master/tlpkg/tlperl/lib/Net/FTP/I.pm
+++ /dev/null
@@ -1,80 +0,0 @@
-##
-## Package to read/write on BINARY data connections
-##
-
-package Net::FTP::I;
-
-use vars qw(@ISA $buf $VERSION);
-use Carp;
-
-require Net::FTP::dataconn;
-
-@ISA = qw(Net::FTP::dataconn);
-$VERSION = "1.12";
-
-
-sub read {
- my $data = shift;
- local *buf = \$_[0];
- shift;
- my $size = shift || croak 'read($buf,$size,[$timeout])';
- my $timeout = @_ ? shift: $data->timeout;
-
- my $n;
-
- if ($size > length ${*$data} and !${*$data}{'net_ftp_eof'}) {
- $data->can_read($timeout)
- or croak "Timeout";
-
- my $blksize = ${*$data}{'net_ftp_blksize'};
- $blksize = $size if $size > $blksize;
-
- unless ($n = sysread($data, ${*$data}, $blksize, length ${*$data})) {
- return undef unless defined $n;
- ${*$data}{'net_ftp_eof'} = 1;
- }
- }
-
- $buf = substr(${*$data}, 0, $size);
-
- $n = length($buf);
-
- substr(${*$data}, 0, $n) = '';
-
- ${*$data}{'net_ftp_bytesread'} += $n;
-
- $n;
-}
-
-
-sub write {
- my $data = shift;
- local *buf = \$_[0];
- shift;
- my $size = shift || croak 'write($buf,$size,[$timeout])';
- my $timeout = @_ ? shift: $data->timeout;
-
- # If the remote server has closed the connection we will be signal'd
- # when we write. This can happen if the disk on the remote server fills up
-
- local $SIG{PIPE} = 'IGNORE'
- unless ($SIG{PIPE} || '') eq 'IGNORE'
- or $^O eq 'MacOS';
- my $sent = $size;
- my $off = 0;
-
- my $blksize = ${*$data}{'net_ftp_blksize'};
- while ($sent > 0) {
- $data->can_write($timeout)
- or croak "Timeout";
-
- my $n = syswrite($data, $buf, $sent > $blksize ? $blksize : $sent, $off);
- return undef unless defined($n);
- $sent -= $n;
- $off += $n;
- }
-
- $size;
-}
-
-1;
diff --git a/Master/tlpkg/tlperl/lib/Net/FTP/L.pm b/Master/tlpkg/tlperl/lib/Net/FTP/L.pm
deleted file mode 100755
index f7423cb9f95..00000000000
--- a/Master/tlpkg/tlperl/lib/Net/FTP/L.pm
+++ /dev/null
@@ -1,8 +0,0 @@
-package Net::FTP::L;
-
-require Net::FTP::I;
-
-@ISA = qw(Net::FTP::I);
-$VERSION = "0.01";
-
-1;
diff --git a/Master/tlpkg/tlperl/lib/Net/FTP/dataconn.pm b/Master/tlpkg/tlperl/lib/Net/FTP/dataconn.pm
deleted file mode 100755
index e7645cbd930..00000000000
--- a/Master/tlpkg/tlperl/lib/Net/FTP/dataconn.pm
+++ /dev/null
@@ -1,124 +0,0 @@
-##
-## Generic data connection package
-##
-
-package Net::FTP::dataconn;
-
-use Carp;
-use vars qw(@ISA $timeout $VERSION);
-use Net::Cmd;
-use Errno;
-
-$VERSION = '0.11';
-@ISA = qw(IO::Socket::INET);
-
-
-sub reading {
- my $data = shift;
- ${*$data}{'net_ftp_bytesread'} = 0;
-}
-
-
-sub abort {
- my $data = shift;
- my $ftp = ${*$data}{'net_ftp_cmd'};
-
- # no need to abort if we have finished the xfer
- return $data->close
- if ${*$data}{'net_ftp_eof'};
-
- # for some reason if we continously open RETR connections and not
- # read a single byte, then abort them after a while the server will
- # close our connection, this prevents the unexpected EOF on the
- # command channel -- GMB
- if (exists ${*$data}{'net_ftp_bytesread'}
- && (${*$data}{'net_ftp_bytesread'} == 0))
- {
- my $buf = "";
- my $timeout = $data->timeout;
- $data->can_read($timeout) && sysread($data, $buf, 1);
- }
-
- ${*$data}{'net_ftp_eof'} = 1; # fake
-
- $ftp->abort; # this will close me
-}
-
-
-sub _close {
- my $data = shift;
- my $ftp = ${*$data}{'net_ftp_cmd'};
-
- $data->SUPER::close();
-
- delete ${*$ftp}{'net_ftp_dataconn'}
- if exists ${*$ftp}{'net_ftp_dataconn'}
- && $data == ${*$ftp}{'net_ftp_dataconn'};
-}
-
-
-sub close {
- my $data = shift;
- my $ftp = ${*$data}{'net_ftp_cmd'};
-
- if (exists ${*$data}{'net_ftp_bytesread'} && !${*$data}{'net_ftp_eof'}) {
- my $junk;
- $data->read($junk, 1, 0);
- return $data->abort unless ${*$data}{'net_ftp_eof'};
- }
-
- $data->_close;
-
- $ftp->response() == CMD_OK
- && $ftp->message =~ /unique file name:\s*(\S*)\s*\)/
- && (${*$ftp}{'net_ftp_unique'} = $1);
-
- $ftp->status == CMD_OK;
-}
-
-
-sub _select {
- my ($data, $timeout, $do_read) = @_;
- my ($rin, $rout, $win, $wout, $tout, $nfound);
-
- vec($rin = '', fileno($data), 1) = 1;
-
- ($win, $rin) = ($rin, $win) unless $do_read;
-
- while (1) {
- $nfound = select($rout = $rin, $wout = $win, undef, $tout = $timeout);
-
- last if $nfound >= 0;
-
- croak "select: $!"
- unless $!{EINTR};
- }
-
- $nfound;
-}
-
-
-sub can_read {
- _select(@_[0, 1], 1);
-}
-
-
-sub can_write {
- _select(@_[0, 1], 0);
-}
-
-
-sub cmd {
- my $ftp = shift;
-
- ${*$ftp}{'net_ftp_cmd'};
-}
-
-
-sub bytes_read {
- my $ftp = shift;
-
- ${*$ftp}{'net_ftp_bytesread'} || 0;
-}
-
-1;
diff --git a/Master/tlpkg/tlperl/lib/Net/HTTP.pm b/Master/tlpkg/tlperl/lib/Net/HTTP.pm
deleted file mode 100755
index 120de285f71..00000000000
--- a/Master/tlpkg/tlperl/lib/Net/HTTP.pm
+++ /dev/null
@@ -1,279 +0,0 @@
-package Net::HTTP;
-
-use strict;
-use vars qw($VERSION @ISA $SOCKET_CLASS);
-
-$VERSION = "5.834";
-unless ($SOCKET_CLASS) {
- eval { require IO::Socket::INET } || require IO::Socket;
- $SOCKET_CLASS = "IO::Socket::INET";
-}
-require Net::HTTP::Methods;
-require Carp;
-
-@ISA = ($SOCKET_CLASS, 'Net::HTTP::Methods');
-
-sub new {
- my $class = shift;
- Carp::croak("No Host option provided") unless @_;
- $class->SUPER::new(@_);
-}
-
-sub configure {
- my($self, $cnf) = @_;
- $self->http_configure($cnf);
-}
-
-sub http_connect {
- my($self, $cnf) = @_;
- $self->SUPER::configure($cnf);
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-Net::HTTP - Low-level HTTP connection (client)
-
-=head1 SYNOPSIS
-
- use Net::HTTP;
- my $s = Net::HTTP->new(Host => "www.perl.com") || die $@;
- $s->write_request(GET => "/", 'User-Agent' => "Mozilla/5.0");
- my($code, $mess, %h) = $s->read_response_headers;
-
- while (1) {
- my $buf;
- my $n = $s->read_entity_body($buf, 1024);
- die "read failed: $!" unless defined $n;
- last unless $n;
- print $buf;
- }
-
-=head1 DESCRIPTION
-
-The C<Net::HTTP> class is a low-level HTTP client. An instance of the
-C<Net::HTTP> class represents a connection to an HTTP server. The
-HTTP protocol is described in RFC 2616. The C<Net::HTTP> class
-supports C<HTTP/1.0> and C<HTTP/1.1>.
-
-C<Net::HTTP> is a sub-class of C<IO::Socket::INET>. You can mix the
-methods described below with reading and writing from the socket
-directly. This is not necessary a good idea, unless you know what you
-are doing.
-
-The following methods are provided (in addition to those of
-C<IO::Socket::INET>):
-
-=over
-
-=item $s = Net::HTTP->new( %options )
-
-The C<Net::HTTP> constructor method takes the same options as
-C<IO::Socket::INET>'s as well as these:
-
- Host: Initial host attribute value
- KeepAlive: Initial keep_alive attribute value
- SendTE: Initial send_te attribute_value
- HTTPVersion: Initial http_version attribute value
- PeerHTTPVersion: Initial peer_http_version attribute value
- MaxLineLength: Initial max_line_length attribute value
- MaxHeaderLines: Initial max_header_lines attribute value
-
-The C<Host> option is also the default for C<IO::Socket::INET>'s
-C<PeerAddr>. The C<PeerPort> defaults to 80 if not provided.
-
-The C<Listen> option provided by C<IO::Socket::INET>'s constructor
-method is not allowed.
-
-If unable to connect to the given HTTP server then the constructor
-returns C<undef> and $@ contains the reason. After a successful
-connect, a C<Net:HTTP> object is returned.
-
-=item $s->host
-
-Get/set the default value of the C<Host> header to send. The $host
-must not be set to an empty string (or C<undef>) for HTTP/1.1.
-
-=item $s->keep_alive
-
-Get/set the I<keep-alive> value. If this value is TRUE then the
-request will be sent with headers indicating that the server should try
-to keep the connection open so that multiple requests can be sent.
-
-The actual headers set will depend on the value of the C<http_version>
-and C<peer_http_version> attributes.
-
-=item $s->send_te
-
-Get/set the a value indicating if the request will be sent with a "TE"
-header to indicate the transfer encodings that the server can choose to
-use. The list of encodings announced as accepted by this client depends
-on availability of the following modules: C<Compress::Raw::Zlib> for
-I<deflate>, and C<IO::Compress::Gunzip> for I<gzip>.
-
-=item $s->http_version
-
-Get/set the HTTP version number that this client should announce.
-This value can only be set to "1.0" or "1.1". The default is "1.1".
-
-=item $s->peer_http_version
-
-Get/set the protocol version number of our peer. This value will
-initially be "1.0", but will be updated by a successful
-read_response_headers() method call.
-
-=item $s->max_line_length
-
-Get/set a limit on the length of response line and response header
-lines. The default is 8192. A value of 0 means no limit.
-
-=item $s->max_header_length
-
-Get/set a limit on the number of header lines that a response can
-have. The default is 128. A value of 0 means no limit.
-
-=item $s->format_request($method, $uri, %headers, [$content])
-
-Format a request message and return it as a string. If the headers do
-not include a C<Host> header, then a header is inserted with the value
-of the C<host> attribute. Headers like C<Connection> and
-C<Keep-Alive> might also be added depending on the status of the
-C<keep_alive> attribute.
-
-If $content is given (and it is non-empty), then a C<Content-Length>
-header is automatically added unless it was already present.
-
-=item $s->write_request($method, $uri, %headers, [$content])
-
-Format and send a request message. Arguments are the same as for
-format_request(). Returns true if successful.
-
-=item $s->format_chunk( $data )
-
-Returns the string to be written for the given chunk of data.
-
-=item $s->write_chunk($data)
-
-Will write a new chunk of request entity body data. This method
-should only be used if the C<Transfer-Encoding> header with a value of
-C<chunked> was sent in the request. Note, writing zero-length data is
-a no-op. Use the write_chunk_eof() method to signal end of entity
-body data.
-
-Returns true if successful.
-
-=item $s->format_chunk_eof( %trailers )
-
-Returns the string to be written for signaling EOF when a
-C<Transfer-Encoding> of C<chunked> is used.
-
-=item $s->write_chunk_eof( %trailers )
-
-Will write eof marker for chunked data and optional trailers. Note
-that trailers should not really be used unless is was signaled
-with a C<Trailer> header.
-
-Returns true if successful.
-
-=item ($code, $mess, %headers) = $s->read_response_headers( %opts )
-
-Read response headers from server and return it. The $code is the 3
-digit HTTP status code (see L<HTTP::Status>) and $mess is the textual
-message that came with it. Headers are then returned as key/value
-pairs. Since key letter casing is not normalized and the same key can
-even occur multiple times, assigning these values directly to a hash
-is not wise. Only the $code is returned if this method is called in
-scalar context.
-
-As a side effect this method updates the 'peer_http_version'
-attribute.
-
-Options might be passed in as key/value pairs. There are currently
-only two options supported; C<laxed> and C<junk_out>.
-
-The C<laxed> option will make read_response_headers() more forgiving
-towards servers that have not learned how to speak HTTP properly. The
-C<laxed> option is a boolean flag, and is enabled by passing in a TRUE
-value. The C<junk_out> option can be used to capture bad header lines
-when C<laxed> is enabled. The value should be an array reference.
-Bad header lines will be pushed onto the array.
-
-The C<laxed> option must be specified in order to communicate with
-pre-HTTP/1.0 servers that don't describe the response outcome or the
-data they send back with a header block. For these servers
-peer_http_version is set to "0.9" and this method returns (200,
-"Assumed OK").
-
-The method will raise an exception (die) if the server does not speak
-proper HTTP or if the C<max_line_length> or C<max_header_length>
-limits are reached. If the C<laxed> option is turned on and
-C<max_line_length> and C<max_header_length> checks are turned off,
-then no exception will be raised and this method will always
-return a response code.
-
-=item $n = $s->read_entity_body($buf, $size);
-
-Reads chunks of the entity body content. Basically the same interface
-as for read() and sysread(), but the buffer offset argument is not
-supported yet. This method should only be called after a successful
-read_response_headers() call.
-
-The return value will be C<undef> on read errors, 0 on EOF, -1 if no data
-could be returned this time, otherwise the number of bytes assigned
-to $buf. The $buf is set to "" when the return value is -1.
-
-You normally want to retry this call if this function returns either
--1 or C<undef> with C<$!> as EINTR or EAGAIN (see L<Errno>). EINTR
-can happen if the application catches signals and EAGAIN can happen if
-you made the socket non-blocking.
-
-This method will raise exceptions (die) if the server does not speak
-proper HTTP. This can only happen when reading chunked data.
-
-=item %headers = $s->get_trailers
-
-After read_entity_body() has returned 0 to indicate end of the entity
-body, you might call this method to pick up any trailers.
-
-=item $s->_rbuf
-
-Get/set the read buffer content. The read_response_headers() and
-read_entity_body() methods use an internal buffer which they will look
-for data before they actually sysread more from the socket itself. If
-they read too much, the remaining data will be left in this buffer.
-
-=item $s->_rbuf_length
-
-Returns the number of bytes in the read buffer. This should always be
-the same as:
-
- length($s->_rbuf)
-
-but might be more efficient.
-
-=back
-
-=head1 SUBCLASSING
-
-The read_response_headers() and read_entity_body() will invoke the
-sysread() method when they need more data. Subclasses might want to
-override this method to control how reading takes place.
-
-The object itself is a glob. Subclasses should avoid using hash key
-names prefixed with C<http_> and C<io_>.
-
-=head1 SEE ALSO
-
-L<LWP>, L<IO::Socket::INET>, L<Net::HTTP::NB>
-
-=head1 COPYRIGHT
-
-Copyright 2001-2003 Gisle Aas.
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
-=cut
diff --git a/Master/tlpkg/tlperl/lib/Net/HTTP/Methods.pm b/Master/tlpkg/tlperl/lib/Net/HTTP/Methods.pm
deleted file mode 100755
index 22cc272b47e..00000000000
--- a/Master/tlpkg/tlperl/lib/Net/HTTP/Methods.pm
+++ /dev/null
@@ -1,593 +0,0 @@
-package Net::HTTP::Methods;
-
-require 5.005; # 4-arg substr
-
-use strict;
-use vars qw($VERSION);
-
-$VERSION = "5.834";
-
-my $CRLF = "\015\012"; # "\r\n" is not portable
-
-*_bytes = defined(&utf8::downgrade) ?
- sub {
- unless (utf8::downgrade($_[0], 1)) {
- require Carp;
- Carp::croak("Wide character in HTTP request (bytes required)");
- }
- return $_[0];
- }
- :
- sub {
- return $_[0];
- };
-
-
-sub new {
- my $class = shift;
- unshift(@_, "Host") if @_ == 1;
- my %cnf = @_;
- require Symbol;
- my $self = bless Symbol::gensym(), $class;
- return $self->http_configure(\%cnf);
-}
-
-sub http_configure {
- my($self, $cnf) = @_;
-
- die "Listen option not allowed" if $cnf->{Listen};
- my $explict_host = (exists $cnf->{Host});
- my $host = delete $cnf->{Host};
- my $peer = $cnf->{PeerAddr} || $cnf->{PeerHost};
- if (!$peer) {
- die "No Host option provided" unless $host;
- $cnf->{PeerAddr} = $peer = $host;
- }
-
- if ($peer =~ s,:(\d+)$,,) {
- $cnf->{PeerPort} = int($1); # always override
- }
- if (!$cnf->{PeerPort}) {
- $cnf->{PeerPort} = $self->http_default_port;
- }
-
- if (!$explict_host) {
- $host = $peer;
- $host =~ s/:.*//;
- }
- if ($host && $host !~ /:/) {
- my $p = $cnf->{PeerPort};
- $host .= ":$p" if $p != $self->http_default_port;
- }
-
- $cnf->{Proto} = 'tcp';
-
- my $keep_alive = delete $cnf->{KeepAlive};
- my $http_version = delete $cnf->{HTTPVersion};
- $http_version = "1.1" unless defined $http_version;
- my $peer_http_version = delete $cnf->{PeerHTTPVersion};
- $peer_http_version = "1.0" unless defined $peer_http_version;
- my $send_te = delete $cnf->{SendTE};
- my $max_line_length = delete $cnf->{MaxLineLength};
- $max_line_length = 8*1024 unless defined $max_line_length;
- my $max_header_lines = delete $cnf->{MaxHeaderLines};
- $max_header_lines = 128 unless defined $max_header_lines;
-
- return undef unless $self->http_connect($cnf);
-
- $self->host($host);
- $self->keep_alive($keep_alive);
- $self->send_te($send_te);
- $self->http_version($http_version);
- $self->peer_http_version($peer_http_version);
- $self->max_line_length($max_line_length);
- $self->max_header_lines($max_header_lines);
-
- ${*$self}{'http_buf'} = "";
-
- return $self;
-}
-
-sub http_default_port {
- 80;
-}
-
-# set up property accessors
-for my $method (qw(host keep_alive send_te max_line_length max_header_lines peer_http_version)) {
- my $prop_name = "http_" . $method;
- no strict 'refs';
- *$method = sub {
- my $self = shift;
- my $old = ${*$self}{$prop_name};
- ${*$self}{$prop_name} = shift if @_;
- return $old;
- };
-}
-
-# we want this one to be a bit smarter
-sub http_version {
- my $self = shift;
- my $old = ${*$self}{'http_version'};
- if (@_) {
- my $v = shift;
- $v = "1.0" if $v eq "1"; # float
- unless ($v eq "1.0" or $v eq "1.1") {
- require Carp;
- Carp::croak("Unsupported HTTP version '$v'");
- }
- ${*$self}{'http_version'} = $v;
- }
- $old;
-}
-
-sub format_request {
- my $self = shift;
- my $method = shift;
- my $uri = shift;
-
- my $content = (@_ % 2) ? pop : "";
-
- for ($method, $uri) {
- require Carp;
- Carp::croak("Bad method or uri") if /\s/ || !length;
- }
-
- push(@{${*$self}{'http_request_method'}}, $method);
- my $ver = ${*$self}{'http_version'};
- my $peer_ver = ${*$self}{'http_peer_http_version'} || "1.0";
-
- my @h;
- my @connection;
- my %given = (host => 0, "content-length" => 0, "te" => 0);
- while (@_) {
- my($k, $v) = splice(@_, 0, 2);
- my $lc_k = lc($k);
- if ($lc_k eq "connection") {
- $v =~ s/^\s+//;
- $v =~ s/\s+$//;
- push(@connection, split(/\s*,\s*/, $v));
- next;
- }
- if (exists $given{$lc_k}) {
- $given{$lc_k}++;
- }
- push(@h, "$k: $v");
- }
-
- if (length($content) && !$given{'content-length'}) {
- push(@h, "Content-Length: " . length($content));
- }
-
- my @h2;
- if ($given{te}) {
- push(@connection, "TE") unless grep lc($_) eq "te", @connection;
- }
- elsif ($self->send_te && gunzip_ok()) {
- # gzip is less wanted since the IO::Uncompress::Gunzip interface for
- # it does not really allow chunked decoding to take place easily.
- push(@h2, "TE: deflate,gzip;q=0.3");
- push(@connection, "TE");
- }
-
- unless (grep lc($_) eq "close", @connection) {
- if ($self->keep_alive) {
- if ($peer_ver eq "1.0") {
- # from looking at Netscape's headers
- push(@h2, "Keep-Alive: 300");
- unshift(@connection, "Keep-Alive");
- }
- }
- else {
- push(@connection, "close") if $ver ge "1.1";
- }
- }
- push(@h2, "Connection: " . join(", ", @connection)) if @connection;
- unless ($given{host}) {
- my $h = ${*$self}{'http_host'};
- push(@h2, "Host: $h") if $h;
- }
-
- return _bytes(join($CRLF, "$method $uri HTTP/$ver", @h2, @h, "", $content));
-}
-
-
-sub write_request {
- my $self = shift;
- $self->print($self->format_request(@_));
-}
-
-sub format_chunk {
- my $self = shift;
- return $_[0] unless defined($_[0]) && length($_[0]);
- return _bytes(sprintf("%x", length($_[0])) . $CRLF . $_[0] . $CRLF);
-}
-
-sub write_chunk {
- my $self = shift;
- return 1 unless defined($_[0]) && length($_[0]);
- $self->print(_bytes(sprintf("%x", length($_[0])) . $CRLF . $_[0] . $CRLF));
-}
-
-sub format_chunk_eof {
- my $self = shift;
- my @h;
- while (@_) {
- push(@h, sprintf "%s: %s$CRLF", splice(@_, 0, 2));
- }
- return _bytes(join("", "0$CRLF", @h, $CRLF));
-}
-
-sub write_chunk_eof {
- my $self = shift;
- $self->print($self->format_chunk_eof(@_));
-}
-
-
-sub my_read {
- die if @_ > 3;
- my $self = shift;
- my $len = $_[1];
- for (${*$self}{'http_buf'}) {
- if (length) {
- $_[0] = substr($_, 0, $len, "");
- return length($_[0]);
- }
- else {
- return $self->sysread($_[0], $len);
- }
- }
-}
-
-
-sub my_readline {
- my $self = shift;
- my $what = shift;
- for (${*$self}{'http_buf'}) {
- my $max_line_length = ${*$self}{'http_max_line_length'};
- my $pos;
- while (1) {
- # find line ending
- $pos = index($_, "\012");
- last if $pos >= 0;
- die "$what line too long (limit is $max_line_length)"
- if $max_line_length && length($_) > $max_line_length;
-
- # need to read more data to find a line ending
- READ:
- {
- my $n = $self->sysread($_, 1024, length);
- unless (defined $n) {
- redo READ if $!{EINTR};
- if ($!{EAGAIN}) {
- # Hmm, we must be reading from a non-blocking socket
- # XXX Should really wait until this socket is readable,...
- select(undef, undef, undef, 0.1); # but this will do for now
- redo READ;
- }
- # if we have already accumulated some data let's at least
- # return that as a line
- die "$what read failed: $!" unless length;
- }
- unless ($n) {
- return undef unless length;
- return substr($_, 0, length, "");
- }
- }
- }
- die "$what line too long ($pos; limit is $max_line_length)"
- if $max_line_length && $pos > $max_line_length;
-
- my $line = substr($_, 0, $pos+1, "");
- $line =~ s/(\015?\012)\z// || die "Assert";
- return wantarray ? ($line, $1) : $line;
- }
-}
-
-
-sub _rbuf {
- my $self = shift;
- if (@_) {
- for (${*$self}{'http_buf'}) {
- my $old;
- $old = $_ if defined wantarray;
- $_ = shift;
- return $old;
- }
- }
- else {
- return ${*$self}{'http_buf'};
- }
-}
-
-sub _rbuf_length {
- my $self = shift;
- return length ${*$self}{'http_buf'};
-}
-
-
-sub _read_header_lines {
- my $self = shift;
- my $junk_out = shift;
-
- my @headers;
- my $line_count = 0;
- my $max_header_lines = ${*$self}{'http_max_header_lines'};
- while (my $line = my_readline($self, 'Header')) {
- if ($line =~ /^(\S+?)\s*:\s*(.*)/s) {
- push(@headers, $1, $2);
- }
- elsif (@headers && $line =~ s/^\s+//) {
- $headers[-1] .= " " . $line;
- }
- elsif ($junk_out) {
- push(@$junk_out, $line);
- }
- else {
- die "Bad header: '$line'\n";
- }
- if ($max_header_lines) {
- $line_count++;
- if ($line_count >= $max_header_lines) {
- die "Too many header lines (limit is $max_header_lines)";
- }
- }
- }
- return @headers;
-}
-
-
-sub read_response_headers {
- my($self, %opt) = @_;
- my $laxed = $opt{laxed};
-
- my($status, $eol) = my_readline($self, 'Status');
- unless (defined $status) {
- die "Server closed connection without sending any data back";
- }
-
- my($peer_ver, $code, $message) = split(/\s+/, $status, 3);
- if (!$peer_ver || $peer_ver !~ s,^HTTP/,, || $code !~ /^[1-5]\d\d$/) {
- die "Bad response status line: '$status'" unless $laxed;
- # assume HTTP/0.9
- ${*$self}{'http_peer_http_version'} = "0.9";
- ${*$self}{'http_status'} = "200";
- substr(${*$self}{'http_buf'}, 0, 0) = $status . ($eol || "");
- return 200 unless wantarray;
- return (200, "Assumed OK");
- };
-
- ${*$self}{'http_peer_http_version'} = $peer_ver;
- ${*$self}{'http_status'} = $code;
-
- my $junk_out;
- if ($laxed) {
- $junk_out = $opt{junk_out} || [];
- }
- my @headers = $self->_read_header_lines($junk_out);
-
- # pick out headers that read_entity_body might need
- my @te;
- my $content_length;
- for (my $i = 0; $i < @headers; $i += 2) {
- my $h = lc($headers[$i]);
- if ($h eq 'transfer-encoding') {
- my $te = $headers[$i+1];
- $te =~ s/^\s+//;
- $te =~ s/\s+$//;
- push(@te, $te) if length($te);
- }
- elsif ($h eq 'content-length') {
- # ignore bogus and overflow values
- if ($headers[$i+1] =~ /^\s*(\d{1,15})(?:\s|$)/) {
- $content_length = $1;
- }
- }
- }
- ${*$self}{'http_te'} = join(",", @te);
- ${*$self}{'http_content_length'} = $content_length;
- ${*$self}{'http_first_body'}++;
- delete ${*$self}{'http_trailers'};
- return $code unless wantarray;
- return ($code, $message, @headers);
-}
-
-
-sub read_entity_body {
- my $self = shift;
- my $buf_ref = \$_[0];
- my $size = $_[1];
- die "Offset not supported yet" if $_[2];
-
- my $chunked;
- my $bytes;
-
- if (${*$self}{'http_first_body'}) {
- ${*$self}{'http_first_body'} = 0;
- delete ${*$self}{'http_chunked'};
- delete ${*$self}{'http_bytes'};
- my $method = shift(@{${*$self}{'http_request_method'}});
- my $status = ${*$self}{'http_status'};
- if ($method eq "HEAD") {
- # this response is always empty regardless of other headers
- $bytes = 0;
- }
- elsif (my $te = ${*$self}{'http_te'}) {
- my @te = split(/\s*,\s*/, lc($te));
- die "Chunked must be last Transfer-Encoding '$te'"
- unless pop(@te) eq "chunked";
-
- for (@te) {
- if ($_ eq "deflate" && inflate_ok()) {
- #require Compress::Raw::Zlib;
- my ($i, $status) = Compress::Raw::Zlib::Inflate->new();
- die "Can't make inflator: $status" unless $i;
- $_ = sub { my $out; $i->inflate($_[0], \$out); $out }
- }
- elsif ($_ eq "gzip" && gunzip_ok()) {
- #require IO::Uncompress::Gunzip;
- my @buf;
- $_ = sub {
- push(@buf, $_[0]);
- return "" unless $_[1];
- my $input = join("", @buf);
- my $output;
- IO::Uncompress::Gunzip::gunzip(\$input, \$output, Transparent => 0)
- or die "Can't gunzip content: $IO::Uncompress::Gunzip::GunzipError";
- return \$output;
- };
- }
- elsif ($_ eq "identity") {
- $_ = sub { $_[0] };
- }
- else {
- die "Can't handle transfer encoding '$te'";
- }
- }
-
- @te = reverse(@te);
-
- ${*$self}{'http_te2'} = @te ? \@te : "";
- $chunked = -1;
- }
- elsif (defined(my $content_length = ${*$self}{'http_content_length'})) {
- $bytes = $content_length;
- }
- elsif ($status =~ /^(?:1|[23]04)/) {
- # RFC 2616 says that these responses should always be empty
- # but that does not appear to be true in practice [RT#17907]
- $bytes = 0;
- }
- else {
- # XXX Multi-Part types are self delimiting, but RFC 2616 says we
- # only has to deal with 'multipart/byteranges'
-
- # Read until EOF
- }
- }
- else {
- $chunked = ${*$self}{'http_chunked'};
- $bytes = ${*$self}{'http_bytes'};
- }
-
- if (defined $chunked) {
- # The state encoded in $chunked is:
- # $chunked == 0: read CRLF after chunk, then chunk header
- # $chunked == -1: read chunk header
- # $chunked > 0: bytes left in current chunk to read
-
- if ($chunked <= 0) {
- my $line = my_readline($self, 'Entity body');
- if ($chunked == 0) {
- die "Missing newline after chunk data: '$line'"
- if !defined($line) || $line ne "";
- $line = my_readline($self, 'Entity body');
- }
- die "EOF when chunk header expected" unless defined($line);
- my $chunk_len = $line;
- $chunk_len =~ s/;.*//; # ignore potential chunk parameters
- unless ($chunk_len =~ /^([\da-fA-F]+)\s*$/) {
- die "Bad chunk-size in HTTP response: $line";
- }
- $chunked = hex($1);
- if ($chunked == 0) {
- ${*$self}{'http_trailers'} = [$self->_read_header_lines];
- $$buf_ref = "";
-
- my $n = 0;
- if (my $transforms = delete ${*$self}{'http_te2'}) {
- for (@$transforms) {
- $$buf_ref = &$_($$buf_ref, 1);
- }
- $n = length($$buf_ref);
- }
-
- # in case somebody tries to read more, make sure we continue
- # to return EOF
- delete ${*$self}{'http_chunked'};
- ${*$self}{'http_bytes'} = 0;
-
- return $n;
- }
- }
-
- my $n = $chunked;
- $n = $size if $size && $size < $n;
- $n = my_read($self, $$buf_ref, $n);
- return undef unless defined $n;
-
- ${*$self}{'http_chunked'} = $chunked - $n;
-
- if ($n > 0) {
- if (my $transforms = ${*$self}{'http_te2'}) {
- for (@$transforms) {
- $$buf_ref = &$_($$buf_ref, 0);
- }
- $n = length($$buf_ref);
- $n = -1 if $n == 0;
- }
- }
- return $n;
- }
- elsif (defined $bytes) {
- unless ($bytes) {
- $$buf_ref = "";
- return 0;
- }
- my $n = $bytes;
- $n = $size if $size && $size < $n;
- $n = my_read($self, $$buf_ref, $n);
- return undef unless defined $n;
- ${*$self}{'http_bytes'} = $bytes - $n;
- return $n;
- }
- else {
- # read until eof
- $size ||= 8*1024;
- return my_read($self, $$buf_ref, $size);
- }
-}
-
-sub get_trailers {
- my $self = shift;
- @{${*$self}{'http_trailers'} || []};
-}
-
-BEGIN {
-my $gunzip_ok;
-my $inflate_ok;
-
-sub gunzip_ok {
- return $gunzip_ok if defined $gunzip_ok;
-
- # Try to load IO::Uncompress::Gunzip.
- local $@;
- local $SIG{__DIE__};
- $gunzip_ok = 0;
-
- eval {
- require IO::Uncompress::Gunzip;
- $gunzip_ok++;
- };
-
- return $gunzip_ok;
-}
-
-sub inflate_ok {
- return $inflate_ok if defined $inflate_ok;
-
- # Try to load Compress::Raw::Zlib.
- local $@;
- local $SIG{__DIE__};
- $inflate_ok = 0;
-
- eval {
- require Compress::Raw::Zlib;
- $inflate_ok++;
- };
-
- return $inflate_ok;
-}
-
-} # BEGIN
-
-1;
diff --git a/Master/tlpkg/tlperl/lib/Net/HTTP/NB.pm b/Master/tlpkg/tlperl/lib/Net/HTTP/NB.pm
deleted file mode 100755
index e4145116f6a..00000000000
--- a/Master/tlpkg/tlperl/lib/Net/HTTP/NB.pm
+++ /dev/null
@@ -1,105 +0,0 @@
-package Net::HTTP::NB;
-
-use strict;
-use vars qw($VERSION @ISA);
-
-$VERSION = "5.810";
-
-require Net::HTTP;
-@ISA=qw(Net::HTTP);
-
-sub sysread {
- my $self = $_[0];
- if (${*$self}{'httpnb_read_count'}++) {
- ${*$self}{'http_buf'} = ${*$self}{'httpnb_save'};
- die "Multi-read\n";
- }
- my $buf;
- my $offset = $_[3] || 0;
- my $n = sysread($self, $_[1], $_[2], $offset);
- ${*$self}{'httpnb_save'} .= substr($_[1], $offset);
- return $n;
-}
-
-sub read_response_headers {
- my $self = shift;
- ${*$self}{'httpnb_read_count'} = 0;
- ${*$self}{'httpnb_save'} = ${*$self}{'http_buf'};
- my @h = eval { $self->SUPER::read_response_headers(@_) };
- if ($@) {
- return if $@ eq "Multi-read\n";
- die;
- }
- return @h;
-}
-
-sub read_entity_body {
- my $self = shift;
- ${*$self}{'httpnb_read_count'} = 0;
- ${*$self}{'httpnb_save'} = ${*$self}{'http_buf'};
- # XXX I'm not so sure this does the correct thing in case of
- # transfer-encoding tranforms
- my $n = eval { $self->SUPER::read_entity_body(@_); };
- if ($@) {
- $_[0] = "";
- return -1;
- }
- return $n;
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-Net::HTTP::NB - Non-blocking HTTP client
-
-=head1 SYNOPSIS
-
- use Net::HTTP::NB;
- my $s = Net::HTTP::NB->new(Host => "www.perl.com") || die $@;
- $s->write_request(GET => "/");
-
- use IO::Select;
- my $sel = IO::Select->new($s);
-
- READ_HEADER: {
- die "Header timeout" unless $sel->can_read(10);
- my($code, $mess, %h) = $s->read_response_headers;
- redo READ_HEADER unless $code;
- }
-
- while (1) {
- die "Body timeout" unless $sel->can_read(10);
- my $buf;
- my $n = $s->read_entity_body($buf, 1024);
- last unless $n;
- print $buf;
- }
-
-=head1 DESCRIPTION
-
-Same interface as C<Net::HTTP> but it will never try multiple reads
-when the read_response_headers() or read_entity_body() methods are
-invoked. This make it possible to multiplex multiple Net::HTTP::NB
-using select without risk blocking.
-
-If read_response_headers() did not see enough data to complete the
-headers an empty list is returned.
-
-If read_entity_body() did not see new entity data in its read
-the value -1 is returned.
-
-=head1 SEE ALSO
-
-L<Net::HTTP>
-
-=head1 COPYRIGHT
-
-Copyright 2001 Gisle Aas.
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
-=cut
diff --git a/Master/tlpkg/tlperl/lib/Net/HTTPS.pm b/Master/tlpkg/tlperl/lib/Net/HTTPS.pm
deleted file mode 100755
index bfed714870c..00000000000
--- a/Master/tlpkg/tlperl/lib/Net/HTTPS.pm
+++ /dev/null
@@ -1,59 +0,0 @@
-package Net::HTTPS;
-
-use strict;
-use vars qw($VERSION $SSL_SOCKET_CLASS @ISA);
-
-$VERSION = "5.819";
-
-# Figure out which SSL implementation to use
-if ($SSL_SOCKET_CLASS) {
- # somebody already set it
-}
-elsif ($Net::SSL::VERSION) {
- $SSL_SOCKET_CLASS = "Net::SSL";
-}
-elsif ($IO::Socket::SSL::VERSION) {
- $SSL_SOCKET_CLASS = "IO::Socket::SSL"; # it was already loaded
-}
-else {
- eval { require Net::SSL; }; # from Crypt-SSLeay
- if ($@) {
- my $old_errsv = $@;
- eval {
- require IO::Socket::SSL;
- };
- if ($@) {
- $old_errsv =~ s/\s\(\@INC contains:.*\)/)/g;
- die $old_errsv . $@;
- }
- $SSL_SOCKET_CLASS = "IO::Socket::SSL";
- }
- else {
- $SSL_SOCKET_CLASS = "Net::SSL";
- }
-}
-
-require Net::HTTP::Methods;
-
-@ISA=($SSL_SOCKET_CLASS, 'Net::HTTP::Methods');
-
-sub configure {
- my($self, $cnf) = @_;
- $self->http_configure($cnf);
-}
-
-sub http_connect {
- my($self, $cnf) = @_;
- $self->SUPER::configure($cnf);
-}
-
-sub http_default_port {
- 443;
-}
-
-# The underlying SSLeay classes fails to work if the socket is
-# placed in non-blocking mode. This override of the blocking
-# method makes sure it stays the way it was created.
-sub blocking { } # noop
-
-1;
diff --git a/Master/tlpkg/tlperl/lib/Net/Hostname.pm.eg b/Master/tlpkg/tlperl/lib/Net/Hostname.pm.eg
deleted file mode 100755
index 4736c1a6ef2..00000000000
--- a/Master/tlpkg/tlperl/lib/Net/Hostname.pm.eg
+++ /dev/null
@@ -1,14 +0,0 @@
-#
-
-package Sys::Hostname;
-
-use Net::Domain qw(hostname);
-use Carp;
-
-require Exporter;
-@ISA = qw(Exporter);
-@EXPORT = qw(hostname);
-
-carp "deprecated package 'Sys::Hostname', use Net::Domain" if $^W;
-
-1;
diff --git a/Master/tlpkg/tlperl/lib/Net/NNTP.pm b/Master/tlpkg/tlperl/lib/Net/NNTP.pm
deleted file mode 100755
index a742aed04c8..00000000000
--- a/Master/tlpkg/tlperl/lib/Net/NNTP.pm
+++ /dev/null
@@ -1,1140 +0,0 @@
-# Net::NNTP.pm
-#
-# Copyright (c) 1995-1997 Graham Barr <gbarr@pobox.com>. All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-
-package Net::NNTP;
-
-use strict;
-use vars qw(@ISA $VERSION $debug);
-use IO::Socket;
-use Net::Cmd;
-use Carp;
-use Time::Local;
-use Net::Config;
-
-$VERSION = "2.24";
-@ISA = qw(Net::Cmd IO::Socket::INET);
-
-
-sub new {
- my $self = shift;
- my $type = ref($self) || $self;
- my ($host, %arg);
- if (@_ % 2) {
- $host = shift;
- %arg = @_;
- }
- else {
- %arg = @_;
- $host = delete $arg{Host};
- }
- my $obj;
-
- $host ||= $ENV{NNTPSERVER} || $ENV{NEWSHOST};
-
- my $hosts = defined $host ? [$host] : $NetConfig{nntp_hosts};
-
- @{$hosts} = qw(news)
- unless @{$hosts};
-
- my $h;
- foreach $h (@{$hosts}) {
- $obj = $type->SUPER::new(
- PeerAddr => ($host = $h),
- PeerPort => $arg{Port} || 'nntp(119)',
- Proto => 'tcp',
- Timeout => defined $arg{Timeout}
- ? $arg{Timeout}
- : 120
- )
- and last;
- }
-
- return undef
- unless defined $obj;
-
- ${*$obj}{'net_nntp_host'} = $host;
-
- $obj->autoflush(1);
- $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
-
- unless ($obj->response() == CMD_OK) {
- $obj->close;
- return undef;
- }
-
- my $c = $obj->code;
- my @m = $obj->message;
-
- unless (exists $arg{Reader} && $arg{Reader} == 0) {
-
- # if server is INN and we have transfer rights the we are currently
- # talking to innd not nnrpd
- if ($obj->reader) {
-
- # If reader suceeds the we need to consider this code to determine postok
- $c = $obj->code;
- }
- else {
-
- # I want to ignore this failure, so restore the previous status.
- $obj->set_status($c, \@m);
- }
- }
-
- ${*$obj}{'net_nntp_post'} = $c == 200 ? 1 : 0;
-
- $obj;
-}
-
-
-sub host {
- my $me = shift;
- ${*$me}{'net_nntp_host'};
-}
-
-
-sub debug_text {
- my $nntp = shift;
- my $inout = shift;
- my $text = shift;
-
- if ( (ref($nntp) and $nntp->code == 350 and $text =~ /^(\S+)/)
- || ($text =~ /^(authinfo\s+pass)/io))
- {
- $text = "$1 ....\n";
- }
-
- $text;
-}
-
-
-sub postok {
- @_ == 1 or croak 'usage: $nntp->postok()';
- my $nntp = shift;
- ${*$nntp}{'net_nntp_post'} || 0;
-}
-
-
-sub article {
- @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->article( [ MSGID ], [ FH ] )';
- my $nntp = shift;
- my @fh;
-
- @fh = (pop) if @_ == 2 || (@_ && (ref($_[0]) || ref(\$_[0]) eq 'GLOB'));
-
- $nntp->_ARTICLE(@_)
- ? $nntp->read_until_dot(@fh)
- : undef;
-}
-
-
-sub articlefh {
- @_ >= 1 && @_ <= 2 or croak 'usage: $nntp->articlefh( [ MSGID ] )';
- my $nntp = shift;
-
- return unless $nntp->_ARTICLE(@_);
- return $nntp->tied_fh;
-}
-
-
-sub authinfo {
- @_ == 3 or croak 'usage: $nntp->authinfo( USER, PASS )';
- my ($nntp, $user, $pass) = @_;
-
- $nntp->_AUTHINFO("USER", $user) == CMD_MORE
- && $nntp->_AUTHINFO("PASS", $pass) == CMD_OK;
-}
-
-
-sub authinfo_simple {
- @_ == 3 or croak 'usage: $nntp->authinfo( USER, PASS )';
- my ($nntp, $user, $pass) = @_;
-
- $nntp->_AUTHINFO('SIMPLE') == CMD_MORE
- && $nntp->command($user, $pass)->response == CMD_OK;
-}
-
-
-sub body {
- @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->body( [ MSGID ], [ FH ] )';
- my $nntp = shift;
- my @fh;
-
- @fh = (pop) if @_ == 2 || (@_ && ref($_[0]) || ref(\$_[0]) eq 'GLOB');
-
- $nntp->_BODY(@_)
- ? $nntp->read_until_dot(@fh)
- : undef;
-}
-
-
-sub bodyfh {
- @_ >= 1 && @_ <= 2 or croak 'usage: $nntp->bodyfh( [ MSGID ] )';
- my $nntp = shift;
- return unless $nntp->_BODY(@_);
- return $nntp->tied_fh;
-}
-
-
-sub head {
- @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->head( [ MSGID ], [ FH ] )';
- my $nntp = shift;
- my @fh;
-
- @fh = (pop) if @_ == 2 || (@_ && ref($_[0]) || ref(\$_[0]) eq 'GLOB');
-
- $nntp->_HEAD(@_)
- ? $nntp->read_until_dot(@fh)
- : undef;
-}
-
-
-sub headfh {
- @_ >= 1 && @_ <= 2 or croak 'usage: $nntp->headfh( [ MSGID ] )';
- my $nntp = shift;
- return unless $nntp->_HEAD(@_);
- return $nntp->tied_fh;
-}
-
-
-sub nntpstat {
- @_ == 1 || @_ == 2 or croak 'usage: $nntp->nntpstat( [ MSGID ] )';
- my $nntp = shift;
-
- $nntp->_STAT(@_) && $nntp->message =~ /(<[^>]+>)/o
- ? $1
- : undef;
-}
-
-
-sub group {
- @_ == 1 || @_ == 2 or croak 'usage: $nntp->group( [ GROUP ] )';
- my $nntp = shift;
- my $grp = ${*$nntp}{'net_nntp_group'} || undef;
-
- return $grp
- unless (@_ || wantarray);
-
- my $newgrp = shift;
-
- return wantarray ? () : undef
- unless $nntp->_GROUP($newgrp || $grp || "")
- && $nntp->message =~ /(\d+)\s+(\d+)\s+(\d+)\s+(\S+)/;
-
- my ($count, $first, $last, $group) = ($1, $2, $3, $4);
-
- # group may be replied as '(current group)'
- $group = ${*$nntp}{'net_nntp_group'}
- if $group =~ /\(/;
-
- ${*$nntp}{'net_nntp_group'} = $group;
-
- wantarray
- ? ($count, $first, $last, $group)
- : $group;
-}
-
-
-sub help {
- @_ == 1 or croak 'usage: $nntp->help()';
- my $nntp = shift;
-
- $nntp->_HELP
- ? $nntp->read_until_dot
- : undef;
-}
-
-
-sub ihave {
- @_ >= 2 or croak 'usage: $nntp->ihave( MESSAGE-ID [, MESSAGE ])';
- my $nntp = shift;
- my $mid = shift;
-
- $nntp->_IHAVE($mid) && $nntp->datasend(@_)
- ? @_ == 0 || $nntp->dataend
- : undef;
-}
-
-
-sub last {
- @_ == 1 or croak 'usage: $nntp->last()';
- my $nntp = shift;
-
- $nntp->_LAST && $nntp->message =~ /(<[^>]+>)/o
- ? $1
- : undef;
-}
-
-
-sub list {
- @_ == 1 or croak 'usage: $nntp->list()';
- my $nntp = shift;
-
- $nntp->_LIST
- ? $nntp->_grouplist
- : undef;
-}
-
-
-sub newgroups {
- @_ >= 2 or croak 'usage: $nntp->newgroups( SINCE [, DISTRIBUTIONS ])';
- my $nntp = shift;
- my $time = _timestr(shift);
- my $dist = shift || "";
-
- $dist = join(",", @{$dist})
- if ref($dist);
-
- $nntp->_NEWGROUPS($time, $dist)
- ? $nntp->_grouplist
- : undef;
-}
-
-
-sub newnews {
- @_ >= 2 && @_ <= 4
- or croak 'usage: $nntp->newnews( SINCE [, GROUPS [, DISTRIBUTIONS ]])';
- my $nntp = shift;
- my $time = _timestr(shift);
- my $grp = @_ ? shift: $nntp->group;
- my $dist = shift || "";
-
- $grp ||= "*";
- $grp = join(",", @{$grp})
- if ref($grp);
-
- $dist = join(",", @{$dist})
- if ref($dist);
-
- $nntp->_NEWNEWS($grp, $time, $dist)
- ? $nntp->_articlelist
- : undef;
-}
-
-
-sub next {
- @_ == 1 or croak 'usage: $nntp->next()';
- my $nntp = shift;
-
- $nntp->_NEXT && $nntp->message =~ /(<[^>]+>)/o
- ? $1
- : undef;
-}
-
-
-sub post {
- @_ >= 1 or croak 'usage: $nntp->post( [ MESSAGE ] )';
- my $nntp = shift;
-
- $nntp->_POST() && $nntp->datasend(@_)
- ? @_ == 0 || $nntp->dataend
- : undef;
-}
-
-
-sub postfh {
- my $nntp = shift;
- return unless $nntp->_POST();
- return $nntp->tied_fh;
-}
-
-
-sub quit {
- @_ == 1 or croak 'usage: $nntp->quit()';
- my $nntp = shift;
-
- $nntp->_QUIT;
- $nntp->close;
-}
-
-
-sub slave {
- @_ == 1 or croak 'usage: $nntp->slave()';
- my $nntp = shift;
-
- $nntp->_SLAVE;
-}
-
-##
-## The following methods are not implemented by all servers
-##
-
-
-sub active {
- @_ == 1 || @_ == 2 or croak 'usage: $nntp->active( [ PATTERN ] )';
- my $nntp = shift;
-
- $nntp->_LIST('ACTIVE', @_)
- ? $nntp->_grouplist
- : undef;
-}
-
-
-sub active_times {
- @_ == 1 or croak 'usage: $nntp->active_times()';
- my $nntp = shift;
-
- $nntp->_LIST('ACTIVE.TIMES')
- ? $nntp->_grouplist
- : undef;
-}
-
-
-sub distributions {
- @_ == 1 or croak 'usage: $nntp->distributions()';
- my $nntp = shift;
-
- $nntp->_LIST('DISTRIBUTIONS')
- ? $nntp->_description
- : undef;
-}
-
-
-sub distribution_patterns {
- @_ == 1 or croak 'usage: $nntp->distributions()';
- my $nntp = shift;
-
- my $arr;
- local $_;
-
- $nntp->_LIST('DISTRIB.PATS')
- && ($arr = $nntp->read_until_dot)
- ? [grep { /^\d/ && (chomp, $_ = [split /:/]) } @$arr]
- : undef;
-}
-
-
-sub newsgroups {
- @_ == 1 || @_ == 2 or croak 'usage: $nntp->newsgroups( [ PATTERN ] )';
- my $nntp = shift;
-
- $nntp->_LIST('NEWSGROUPS', @_)
- ? $nntp->_description
- : undef;
-}
-
-
-sub overview_fmt {
- @_ == 1 or croak 'usage: $nntp->overview_fmt()';
- my $nntp = shift;
-
- $nntp->_LIST('OVERVIEW.FMT')
- ? $nntp->_articlelist
- : undef;
-}
-
-
-sub subscriptions {
- @_ == 1 or croak 'usage: $nntp->subscriptions()';
- my $nntp = shift;
-
- $nntp->_LIST('SUBSCRIPTIONS')
- ? $nntp->_articlelist
- : undef;
-}
-
-
-sub listgroup {
- @_ == 1 || @_ == 2 or croak 'usage: $nntp->listgroup( [ GROUP ] )';
- my $nntp = shift;
-
- $nntp->_LISTGROUP(@_)
- ? $nntp->_articlelist
- : undef;
-}
-
-
-sub reader {
- @_ == 1 or croak 'usage: $nntp->reader()';
- my $nntp = shift;
-
- $nntp->_MODE('READER');
-}
-
-
-sub xgtitle {
- @_ == 1 || @_ == 2 or croak 'usage: $nntp->xgtitle( [ PATTERN ] )';
- my $nntp = shift;
-
- $nntp->_XGTITLE(@_)
- ? $nntp->_description
- : undef;
-}
-
-
-sub xhdr {
- @_ >= 2 && @_ <= 4 or croak 'usage: $nntp->xhdr( HEADER, [ MESSAGE-SPEC ] )';
- my $nntp = shift;
- my $hdr = shift;
- my $arg = _msg_arg(@_);
-
- $nntp->_XHDR($hdr, $arg)
- ? $nntp->_description
- : undef;
-}
-
-
-sub xover {
- @_ == 2 || @_ == 3 or croak 'usage: $nntp->xover( MESSAGE-SPEC )';
- my $nntp = shift;
- my $arg = _msg_arg(@_);
-
- $nntp->_XOVER($arg)
- ? $nntp->_fieldlist
- : undef;
-}
-
-
-sub xpat {
- @_ == 4 || @_ == 5 or croak '$nntp->xpat( HEADER, PATTERN, MESSAGE-SPEC )';
- my $nntp = shift;
- my $hdr = shift;
- my $pat = shift;
- my $arg = _msg_arg(@_);
-
- $pat = join(" ", @$pat)
- if ref($pat);
-
- $nntp->_XPAT($hdr, $arg, $pat)
- ? $nntp->_description
- : undef;
-}
-
-
-sub xpath {
- @_ == 2 or croak 'usage: $nntp->xpath( MESSAGE-ID )';
- my ($nntp, $mid) = @_;
-
- return undef
- unless $nntp->_XPATH($mid);
-
- my $m;
- ($m = $nntp->message) =~ s/^\d+\s+//o;
- my @p = split /\s+/, $m;
-
- wantarray ? @p : $p[0];
-}
-
-
-sub xrover {
- @_ == 2 || @_ == 3 or croak 'usage: $nntp->xrover( MESSAGE-SPEC )';
- my $nntp = shift;
- my $arg = _msg_arg(@_);
-
- $nntp->_XROVER($arg)
- ? $nntp->_description
- : undef;
-}
-
-
-sub date {
- @_ == 1 or croak 'usage: $nntp->date()';
- my $nntp = shift;
-
- $nntp->_DATE
- && $nntp->message =~ /(\d{4})(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/
- ? timegm($6, $5, $4, $3, $2 - 1, $1 - 1900)
- : undef;
-}
-
-
-##
-## Private subroutines
-##
-
-
-sub _msg_arg {
- my $spec = shift;
- my $arg = "";
-
- if (@_) {
- carp "Depriciated passing of two message numbers, " . "pass a reference"
- if $^W;
- $spec = [$spec, $_[0]];
- }
-
- if (defined $spec) {
- if (ref($spec)) {
- $arg = $spec->[0];
- if (defined $spec->[1]) {
- $arg .= "-"
- if $spec->[1] != $spec->[0];
- $arg .= $spec->[1]
- if $spec->[1] > $spec->[0];
- }
- }
- else {
- $arg = $spec;
- }
- }
-
- $arg;
-}
-
-
-sub _timestr {
- my $time = shift;
- my @g = reverse((gmtime($time))[0 .. 5]);
- $g[1] += 1;
- $g[0] %= 100;
- sprintf "%02d%02d%02d %02d%02d%02d GMT", @g;
-}
-
-
-sub _grouplist {
- my $nntp = shift;
- my $arr = $nntp->read_until_dot
- or return undef;
-
- my $hash = {};
- my $ln;
-
- foreach $ln (@$arr) {
- my @a = split(/[\s\n]+/, $ln);
- $hash->{$a[0]} = [@a[1, 2, 3]];
- }
-
- $hash;
-}
-
-
-sub _fieldlist {
- my $nntp = shift;
- my $arr = $nntp->read_until_dot
- or return undef;
-
- my $hash = {};
- my $ln;
-
- foreach $ln (@$arr) {
- my @a = split(/[\t\n]/, $ln);
- my $m = shift @a;
- $hash->{$m} = [@a];
- }
-
- $hash;
-}
-
-
-sub _articlelist {
- my $nntp = shift;
- my $arr = $nntp->read_until_dot;
-
- chomp(@$arr)
- if $arr;
-
- $arr;
-}
-
-
-sub _description {
- my $nntp = shift;
- my $arr = $nntp->read_until_dot
- or return undef;
-
- my $hash = {};
- my $ln;
-
- foreach $ln (@$arr) {
- chomp($ln);
-
- $hash->{$1} = $ln
- if $ln =~ s/^\s*(\S+)\s*//o;
- }
-
- $hash;
-
-}
-
-##
-## The commands
-##
-
-
-sub _ARTICLE { shift->command('ARTICLE', @_)->response == CMD_OK }
-sub _AUTHINFO { shift->command('AUTHINFO', @_)->response }
-sub _BODY { shift->command('BODY', @_)->response == CMD_OK }
-sub _DATE { shift->command('DATE')->response == CMD_INFO }
-sub _GROUP { shift->command('GROUP', @_)->response == CMD_OK }
-sub _HEAD { shift->command('HEAD', @_)->response == CMD_OK }
-sub _HELP { shift->command('HELP', @_)->response == CMD_INFO }
-sub _IHAVE { shift->command('IHAVE', @_)->response == CMD_MORE }
-sub _LAST { shift->command('LAST')->response == CMD_OK }
-sub _LIST { shift->command('LIST', @_)->response == CMD_OK }
-sub _LISTGROUP { shift->command('LISTGROUP', @_)->response == CMD_OK }
-sub _NEWGROUPS { shift->command('NEWGROUPS', @_)->response == CMD_OK }
-sub _NEWNEWS { shift->command('NEWNEWS', @_)->response == CMD_OK }
-sub _NEXT { shift->command('NEXT')->response == CMD_OK }
-sub _POST { shift->command('POST', @_)->response == CMD_MORE }
-sub _QUIT { shift->command('QUIT', @_)->response == CMD_OK }
-sub _SLAVE { shift->command('SLAVE', @_)->response == CMD_OK }
-sub _STAT { shift->command('STAT', @_)->response == CMD_OK }
-sub _MODE { shift->command('MODE', @_)->response == CMD_OK }
-sub _XGTITLE { shift->command('XGTITLE', @_)->response == CMD_OK }
-sub _XHDR { shift->command('XHDR', @_)->response == CMD_OK }
-sub _XPAT { shift->command('XPAT', @_)->response == CMD_OK }
-sub _XPATH { shift->command('XPATH', @_)->response == CMD_OK }
-sub _XOVER { shift->command('XOVER', @_)->response == CMD_OK }
-sub _XROVER { shift->command('XROVER', @_)->response == CMD_OK }
-sub _XTHREAD { shift->unsupported }
-sub _XSEARCH { shift->unsupported }
-sub _XINDEX { shift->unsupported }
-
-##
-## IO/perl methods
-##
-
-
-sub DESTROY {
- my $nntp = shift;
- defined(fileno($nntp)) && $nntp->quit;
-}
-
-
-1;
-
-__END__
-
-=head1 NAME
-
-Net::NNTP - NNTP Client class
-
-=head1 SYNOPSIS
-
- use Net::NNTP;
-
- $nntp = Net::NNTP->new("some.host.name");
- $nntp->quit;
-
-=head1 DESCRIPTION
-
-C<Net::NNTP> is a class implementing a simple NNTP client in Perl as described
-in RFC977. C<Net::NNTP> inherits its communication methods from C<Net::Cmd>
-
-=head1 CONSTRUCTOR
-
-=over 4
-
-=item new ( [ HOST ] [, OPTIONS ])
-
-This is the constructor for a new Net::NNTP object. C<HOST> is the
-name of the remote host to which a NNTP connection is required. If not
-given then it may be passed as the C<Host> option described below. If no host is passed
-then two environment variables are checked, first C<NNTPSERVER> then
-C<NEWSHOST>, then C<Net::Config> is checked, and if a host is not found
-then C<news> is used.
-
-C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
-Possible options are:
-
-B<Host> - NNTP host to connect to. It may be a single scalar, as defined for
-the C<PeerAddr> option in L<IO::Socket::INET>, or a reference to
-an array with hosts to try in turn. The L</host> method will return the value
-which was used to connect to the host.
-
-B<Timeout> - Maximum time, in seconds, to wait for a response from the
-NNTP server, a value of zero will cause all IO operations to block.
-(default: 120)
-
-B<Debug> - Enable the printing of debugging information to STDERR
-
-B<Reader> - If the remote server is INN then initially the connection
-will be to nnrpd, by default C<Net::NNTP> will issue a C<MODE READER> command
-so that the remote server becomes innd. If the C<Reader> option is given
-with a value of zero, then this command will not be sent and the
-connection will be left talking to nnrpd.
-
-=back
-
-=head1 METHODS
-
-Unless otherwise stated all methods return either a I<true> or I<false>
-value, with I<true> meaning that the operation was a success. When a method
-states that it returns a value, failure will be returned as I<undef> or an
-empty list.
-
-=over 4
-
-=item article ( [ MSGID|MSGNUM ], [FH] )
-
-Retrieve the header, a blank line, then the body (text) of the
-specified article.
-
-If C<FH> is specified then it is expected to be a valid filehandle
-and the result will be printed to it, on success a true value will be
-returned. If C<FH> is not specified then the return value, on success,
-will be a reference to an array containing the article requested, each
-entry in the array will contain one line of the article.
-
-If no arguments are passed then the current article in the currently
-selected newsgroup is fetched.
-
-C<MSGNUM> is a numeric id of an article in the current newsgroup, and
-will change the current article pointer. C<MSGID> is the message id of
-an article as shown in that article's header. It is anticipated that the
-client will obtain the C<MSGID> from a list provided by the C<newnews>
-command, from references contained within another article, or from the
-message-id provided in the response to some other commands.
-
-If there is an error then C<undef> will be returned.
-
-=item body ( [ MSGID|MSGNUM ], [FH] )
-
-Like C<article> but only fetches the body of the article.
-
-=item head ( [ MSGID|MSGNUM ], [FH] )
-
-Like C<article> but only fetches the headers for the article.
-
-=item articlefh ( [ MSGID|MSGNUM ] )
-
-=item bodyfh ( [ MSGID|MSGNUM ] )
-
-=item headfh ( [ MSGID|MSGNUM ] )
-
-These are similar to article(), body() and head(), but rather than
-returning the requested data directly, they return a tied filehandle
-from which to read the article.
-
-=item nntpstat ( [ MSGID|MSGNUM ] )
-
-The C<nntpstat> command is similar to the C<article> command except that no
-text is returned. When selecting by message number within a group,
-the C<nntpstat> command serves to set the "current article pointer" without
-sending text.
-
-Using the C<nntpstat> command to
-select by message-id is valid but of questionable value, since a
-selection by message-id does B<not> alter the "current article pointer".
-
-Returns the message-id of the "current article".
-
-=item group ( [ GROUP ] )
-
-Set and/or get the current group. If C<GROUP> is not given then information
-is returned on the current group.
-
-In a scalar context it returns the group name.
-
-In an array context the return value is a list containing, the number
-of articles in the group, the number of the first article, the number
-of the last article and the group name.
-
-=item ihave ( MSGID [, MESSAGE ])
-
-The C<ihave> command informs the server that the client has an article
-whose id is C<MSGID>. If the server desires a copy of that
-article, and C<MESSAGE> has been given the it will be sent.
-
-Returns I<true> if the server desires the article and C<MESSAGE> was
-successfully sent,if specified.
-
-If C<MESSAGE> is not specified then the message must be sent using the
-C<datasend> and C<dataend> methods from L<Net::Cmd>
-
-C<MESSAGE> can be either an array of lines or a reference to an array.
-
-=item last ()
-
-Set the "current article pointer" to the previous article in the current
-newsgroup.
-
-Returns the message-id of the article.
-
-=item date ()
-
-Returns the date on the remote server. This date will be in a UNIX time
-format (seconds since 1970)
-
-=item postok ()
-
-C<postok> will return I<true> if the servers initial response indicated
-that it will allow posting.
-
-=item authinfo ( USER, PASS )
-
-Authenticates to the server (using AUTHINFO USER / AUTHINFO PASS)
-using the supplied username and password. Please note that the
-password is sent in clear text to the server. This command should not
-be used with valuable passwords unless the connection to the server is
-somehow protected.
-
-=item list ()
-
-Obtain information about all the active newsgroups. The results is a reference
-to a hash where the key is a group name and each value is a reference to an
-array. The elements in this array are:- the last article number in the group,
-the first article number in the group and any information flags about the group.
-
-=item newgroups ( SINCE [, DISTRIBUTIONS ])
-
-C<SINCE> is a time value and C<DISTRIBUTIONS> is either a distribution
-pattern or a reference to a list of distribution patterns.
-The result is the same as C<list>, but the
-groups return will be limited to those created after C<SINCE> and, if
-specified, in one of the distribution areas in C<DISTRIBUTIONS>.
-
-=item newnews ( SINCE [, GROUPS [, DISTRIBUTIONS ]])
-
-C<SINCE> is a time value. C<GROUPS> is either a group pattern or a reference
-to a list of group patterns. C<DISTRIBUTIONS> is either a distribution
-pattern or a reference to a list of distribution patterns.
-
-Returns a reference to a list which contains the message-ids of all news posted
-after C<SINCE>, that are in a groups which matched C<GROUPS> and a
-distribution which matches C<DISTRIBUTIONS>.
-
-=item next ()
-
-Set the "current article pointer" to the next article in the current
-newsgroup.
-
-Returns the message-id of the article.
-
-=item post ( [ MESSAGE ] )
-
-Post a new article to the news server. If C<MESSAGE> is specified and posting
-is allowed then the message will be sent.
-
-If C<MESSAGE> is not specified then the message must be sent using the
-C<datasend> and C<dataend> methods from L<Net::Cmd>
-
-C<MESSAGE> can be either an array of lines or a reference to an array.
-
-The message, either sent via C<datasend> or as the C<MESSAGE>
-parameter, must be in the format as described by RFC822 and must
-contain From:, Newsgroups: and Subject: headers.
-
-=item postfh ()
-
-Post a new article to the news server using a tied filehandle. If
-posting is allowed, this method will return a tied filehandle that you
-can print() the contents of the article to be posted. You must
-explicitly close() the filehandle when you are finished posting the
-article, and the return value from the close() call will indicate
-whether the message was successfully posted.
-
-=item slave ()
-
-Tell the remote server that I am not a user client, but probably another
-news server.
-
-=item quit ()
-
-Quit the remote server and close the socket connection.
-
-=back
-
-=head2 Extension methods
-
-These methods use commands that are not part of the RFC977 documentation. Some
-servers may not support all of them.
-
-=over 4
-
-=item newsgroups ( [ PATTERN ] )
-
-Returns a reference to a hash where the keys are all the group names which
-match C<PATTERN>, or all of the groups if no pattern is specified, and
-each value contains the description text for the group.
-
-=item distributions ()
-
-Returns a reference to a hash where the keys are all the possible
-distribution names and the values are the distribution descriptions.
-
-=item subscriptions ()
-
-Returns a reference to a list which contains a list of groups which
-are recommended for a new user to subscribe to.
-
-=item overview_fmt ()
-
-Returns a reference to an array which contain the names of the fields returned
-by C<xover>.
-
-=item active_times ()
-
-Returns a reference to a hash where the keys are the group names and each
-value is a reference to an array containing the time the groups was created
-and an identifier, possibly an Email address, of the creator.
-
-=item active ( [ PATTERN ] )
-
-Similar to C<list> but only active groups that match the pattern are returned.
-C<PATTERN> can be a group pattern.
-
-=item xgtitle ( PATTERN )
-
-Returns a reference to a hash where the keys are all the group names which
-match C<PATTERN> and each value is the description text for the group.
-
-=item xhdr ( HEADER, MESSAGE-SPEC )
-
-Obtain the header field C<HEADER> for all the messages specified.
-
-The return value will be a reference
-to a hash where the keys are the message numbers and each value contains
-the text of the requested header for that message.
-
-=item xover ( MESSAGE-SPEC )
-
-The return value will be a reference
-to a hash where the keys are the message numbers and each value contains
-a reference to an array which contains the overview fields for that
-message.
-
-The names of the fields can be obtained by calling C<overview_fmt>.
-
-=item xpath ( MESSAGE-ID )
-
-Returns the path name to the file on the server which contains the specified
-message.
-
-=item xpat ( HEADER, PATTERN, MESSAGE-SPEC)
-
-The result is the same as C<xhdr> except the is will be restricted to
-headers where the text of the header matches C<PATTERN>
-
-=item xrover
-
-The XROVER command returns reference information for the article(s)
-specified.
-
-Returns a reference to a HASH where the keys are the message numbers and the
-values are the References: lines from the articles
-
-=item listgroup ( [ GROUP ] )
-
-Returns a reference to a list of all the active messages in C<GROUP>, or
-the current group if C<GROUP> is not specified.
-
-=item reader
-
-Tell the server that you are a reader and not another server.
-
-This is required by some servers. For example if you are connecting to
-an INN server and you have transfer permission your connection will
-be connected to the transfer daemon, not the NNTP daemon. Issuing
-this command will cause the transfer daemon to hand over control
-to the NNTP daemon.
-
-Some servers do not understand this command, but issuing it and ignoring
-the response is harmless.
-
-=back
-
-=head1 UNSUPPORTED
-
-The following NNTP command are unsupported by the package, and there are
-no plans to do so.
-
- AUTHINFO GENERIC
- XTHREAD
- XSEARCH
- XINDEX
-
-=head1 DEFINITIONS
-
-=over 4
-
-=item MESSAGE-SPEC
-
-C<MESSAGE-SPEC> is either a single message-id, a single message number, or
-a reference to a list of two message numbers.
-
-If C<MESSAGE-SPEC> is a reference to a list of two message numbers and the
-second number in a range is less than or equal to the first then the range
-represents all messages in the group after the first message number.
-
-B<NOTE> For compatibility reasons only with earlier versions of Net::NNTP
-a message spec can be passed as a list of two numbers, this is deprecated
-and a reference to the list should now be passed
-
-=item PATTERN
-
-The C<NNTP> protocol uses the C<WILDMAT> format for patterns.
-The WILDMAT format was first developed by Rich Salz based on
-the format used in the UNIX "find" command to articulate
-file names. It was developed to provide a uniform mechanism
-for matching patterns in the same manner that the UNIX shell
-matches filenames.
-
-Patterns are implicitly anchored at the
-beginning and end of each string when testing for a match.
-
-There are five pattern matching operations other than a strict
-one-to-one match between the pattern and the source to be
-checked for a match.
-
-The first is an asterisk C<*> to match any sequence of zero or more
-characters.
-
-The second is a question mark C<?> to match any single character. The
-third specifies a specific set of characters.
-
-The set is specified as a list of characters, or as a range of characters
-where the beginning and end of the range are separated by a minus (or dash)
-character, or as any combination of lists and ranges. The dash can
-also be included in the set as a character it if is the beginning
-or end of the set. This set is enclosed in square brackets. The
-close square bracket C<]> may be used in a set if it is the first
-character in the set.
-
-The fourth operation is the same as the
-logical not of the third operation and is specified the same
-way as the third with the addition of a caret character C<^> at
-the beginning of the test string just inside the open square
-bracket.
-
-The final operation uses the backslash character to
-invalidate the special meaning of an open square bracket C<[>,
-the asterisk, backslash or the question mark. Two backslashes in
-sequence will result in the evaluation of the backslash as a
-character with no special meaning.
-
-=over 4
-
-=item Examples
-
-=item C<[^]-]>
-
-matches any single character other than a close square
-bracket or a minus sign/dash.
-
-=item C<*bdc>
-
-matches any string that ends with the string "bdc"
-including the string "bdc" (without quotes).
-
-=item C<[0-9a-zA-Z]>
-
-matches any single printable alphanumeric ASCII character.
-
-=item C<a??d>
-
-matches any four character string which begins
-with a and ends with d.
-
-=back
-
-=back
-
-=head1 SEE ALSO
-
-L<Net::Cmd>
-
-=head1 AUTHOR
-
-Graham Barr <gbarr@pobox.com>
-
-=head1 COPYRIGHT
-
-Copyright (c) 1995-1997 Graham Barr. All rights reserved.
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=cut
diff --git a/Master/tlpkg/tlperl/lib/Net/Netrc.pm b/Master/tlpkg/tlperl/lib/Net/Netrc.pm
deleted file mode 100755
index 28c826b38cd..00000000000
--- a/Master/tlpkg/tlperl/lib/Net/Netrc.pm
+++ /dev/null
@@ -1,325 +0,0 @@
-# Net::Netrc.pm
-#
-# Copyright (c) 1995-1998 Graham Barr <gbarr@pobox.com>. All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-
-package Net::Netrc;
-
-use Carp;
-use strict;
-use FileHandle;
-use vars qw($VERSION);
-
-$VERSION = "2.12";
-
-my %netrc = ();
-
-
-sub _readrc {
- my $host = shift;
- my ($home, $file);
-
- if ($^O eq "MacOS") {
- $home = $ENV{HOME} || `pwd`;
- chomp($home);
- $file = ($home =~ /:$/ ? $home . "netrc" : $home . ":netrc");
- }
- else {
-
- # Some OS's don't have `getpwuid', so we default to $ENV{HOME}
- $home = eval { (getpwuid($>))[7] } || $ENV{HOME};
- $home ||= $ENV{HOMEDRIVE} . ($ENV{HOMEPATH} || '') if defined $ENV{HOMEDRIVE};
- $file = $home . "/.netrc";
- }
-
- my ($login, $pass, $acct) = (undef, undef, undef);
- my $fh;
- local $_;
-
- $netrc{default} = undef;
-
- # OS/2 and Win32 do not handle stat in a way compatable with this check :-(
- unless ($^O eq 'os2'
- || $^O eq 'MSWin32'
- || $^O eq 'MacOS'
- || $^O =~ /^cygwin/)
- {
- my @stat = stat($file);
-
- if (@stat) {
- if ($stat[2] & 077) {
- carp "Bad permissions: $file";
- return;
- }
- if ($stat[4] != $<) {
- carp "Not owner: $file";
- return;
- }
- }
- }
-
- if ($fh = FileHandle->new($file, "r")) {
- my ($mach, $macdef, $tok, @tok) = (0, 0);
-
- while (<$fh>) {
- undef $macdef if /\A\n\Z/;
-
- if ($macdef) {
- push(@$macdef, $_);
- next;
- }
-
- s/^\s*//;
- chomp;
-
- while (length && s/^("((?:[^"]+|\\.)*)"|((?:[^\\\s]+|\\.)*))\s*//) {
- (my $tok = $+) =~ s/\\(.)/$1/g;
- push(@tok, $tok);
- }
-
- TOKEN:
- while (@tok) {
- if ($tok[0] eq "default") {
- shift(@tok);
- $mach = bless {};
- $netrc{default} = [$mach];
-
- next TOKEN;
- }
-
- last TOKEN
- unless @tok > 1;
-
- $tok = shift(@tok);
-
- if ($tok eq "machine") {
- my $host = shift @tok;
- $mach = bless {machine => $host};
-
- $netrc{$host} = []
- unless exists($netrc{$host});
- push(@{$netrc{$host}}, $mach);
- }
- elsif ($tok =~ /^(login|password|account)$/) {
- next TOKEN unless $mach;
- my $value = shift @tok;
-
- # Following line added by rmerrell to remove '/' escape char in .netrc
- $value =~ s/\/\\/\\/g;
- $mach->{$1} = $value;
- }
- elsif ($tok eq "macdef") {
- next TOKEN unless $mach;
- my $value = shift @tok;
- $mach->{macdef} = {}
- unless exists $mach->{macdef};
- $macdef = $mach->{machdef}{$value} = [];
- }
- }
- }
- $fh->close();
- }
-}
-
-
-sub lookup {
- my ($pkg, $mach, $login) = @_;
-
- _readrc()
- unless exists $netrc{default};
-
- $mach ||= 'default';
- undef $login
- if $mach eq 'default';
-
- if (exists $netrc{$mach}) {
- if (defined $login) {
- my $m;
- foreach $m (@{$netrc{$mach}}) {
- return $m
- if (exists $m->{login} && $m->{login} eq $login);
- }
- return undef;
- }
- return $netrc{$mach}->[0];
- }
-
- return $netrc{default}->[0]
- if defined $netrc{default};
-
- return undef;
-}
-
-
-sub login {
- my $me = shift;
-
- exists $me->{login}
- ? $me->{login}
- : undef;
-}
-
-
-sub account {
- my $me = shift;
-
- exists $me->{account}
- ? $me->{account}
- : undef;
-}
-
-
-sub password {
- my $me = shift;
-
- exists $me->{password}
- ? $me->{password}
- : undef;
-}
-
-
-sub lpa {
- my $me = shift;
- ($me->login, $me->password, $me->account);
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-Net::Netrc - OO interface to users netrc file
-
-=head1 SYNOPSIS
-
- use Net::Netrc;
-
- $mach = Net::Netrc->lookup('some.machine');
- $login = $mach->login;
- ($login, $password, $account) = $mach->lpa;
-
-=head1 DESCRIPTION
-
-C<Net::Netrc> is a class implementing a simple interface to the .netrc file
-used as by the ftp program.
-
-C<Net::Netrc> also implements security checks just like the ftp program,
-these checks are, first that the .netrc file must be owned by the user and
-second the ownership permissions should be such that only the owner has
-read and write access. If these conditions are not met then a warning is
-output and the .netrc file is not read.
-
-=head1 THE .netrc FILE
-
-The .netrc file contains login and initialization information used by the
-auto-login process. It resides in the user's home directory. The following
-tokens are recognized; they may be separated by spaces, tabs, or new-lines:
-
-=over 4
-
-=item machine name
-
-Identify a remote machine name. The auto-login process searches
-the .netrc file for a machine token that matches the remote machine
-specified. Once a match is made, the subsequent .netrc tokens
-are processed, stopping when the end of file is reached or an-
-other machine or a default token is encountered.
-
-=item default
-
-This is the same as machine name except that default matches
-any name. There can be only one default token, and it must be
-after all machine tokens. This is normally used as:
-
- default login anonymous password user@site
-
-thereby giving the user automatic anonymous login to machines
-not specified in .netrc.
-
-=item login name
-
-Identify a user on the remote machine. If this token is present,
-the auto-login process will initiate a login using the
-specified name.
-
-=item password string
-
-Supply a password. If this token is present, the auto-login
-process will supply the specified string if the remote server
-requires a password as part of the login process.
-
-=item account string
-
-Supply an additional account password. If this token is present,
-the auto-login process will supply the specified string
-if the remote server requires an additional account password.
-
-=item macdef name
-
-Define a macro. C<Net::Netrc> only parses this field to be compatible
-with I<ftp>.
-
-=back
-
-=head1 CONSTRUCTOR
-
-The constructor for a C<Net::Netrc> object is not called new as it does not
-really create a new object. But instead is called C<lookup> as this is
-essentially what it does.
-
-=over 4
-
-=item lookup ( MACHINE [, LOGIN ])
-
-Lookup and return a reference to the entry for C<MACHINE>. If C<LOGIN> is given
-then the entry returned will have the given login. If C<LOGIN> is not given then
-the first entry in the .netrc file for C<MACHINE> will be returned.
-
-If a matching entry cannot be found, and a default entry exists, then a
-reference to the default entry is returned.
-
-If there is no matching entry found and there is no default defined, or
-no .netrc file is found, then C<undef> is returned.
-
-=back
-
-=head1 METHODS
-
-=over 4
-
-=item login ()
-
-Return the login id for the netrc entry
-
-=item password ()
-
-Return the password for the netrc entry
-
-=item account ()
-
-Return the account information for the netrc entry
-
-=item lpa ()
-
-Return a list of login, password and account information fir the netrc entry
-
-=back
-
-=head1 AUTHOR
-
-Graham Barr <gbarr@pobox.com>
-
-=head1 SEE ALSO
-
-L<Net::Netrc>
-L<Net::Cmd>
-
-=head1 COPYRIGHT
-
-Copyright (c) 1995-1998 Graham Barr. All rights reserved.
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=cut
diff --git a/Master/tlpkg/tlperl/lib/Net/POP3.pm b/Master/tlpkg/tlperl/lib/Net/POP3.pm
deleted file mode 100755
index 8381c81815e..00000000000
--- a/Master/tlpkg/tlperl/lib/Net/POP3.pm
+++ /dev/null
@@ -1,742 +0,0 @@
-# Net::POP3.pm
-#
-# Copyright (c) 1995-2004 Graham Barr <gbarr@pobox.com>. All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-
-package Net::POP3;
-
-use strict;
-use IO::Socket;
-use vars qw(@ISA $VERSION $debug);
-use Net::Cmd;
-use Carp;
-use Net::Config;
-
-$VERSION = "2.29";
-
-@ISA = qw(Net::Cmd IO::Socket::INET);
-
-
-sub new {
- my $self = shift;
- my $type = ref($self) || $self;
- my ($host, %arg);
- if (@_ % 2) {
- $host = shift;
- %arg = @_;
- }
- else {
- %arg = @_;
- $host = delete $arg{Host};
- }
- my $hosts = defined $host ? [$host] : $NetConfig{pop3_hosts};
- my $obj;
- my @localport = exists $arg{ResvPort} ? (LocalPort => $arg{ResvPort}) : ();
-
- my $h;
- foreach $h (@{$hosts}) {
- $obj = $type->SUPER::new(
- PeerAddr => ($host = $h),
- PeerPort => $arg{Port} || 'pop3(110)',
- Proto => 'tcp',
- @localport,
- Timeout => defined $arg{Timeout}
- ? $arg{Timeout}
- : 120
- )
- and last;
- }
-
- return undef
- unless defined $obj;
-
- ${*$obj}{'net_pop3_host'} = $host;
-
- $obj->autoflush(1);
- $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
-
- unless ($obj->response() == CMD_OK) {
- $obj->close();
- return undef;
- }
-
- ${*$obj}{'net_pop3_banner'} = $obj->message;
-
- $obj;
-}
-
-
-sub host {
- my $me = shift;
- ${*$me}{'net_pop3_host'};
-}
-
-##
-## We don't want people sending me their passwords when they report problems
-## now do we :-)
-##
-
-
-sub debug_text { $_[2] =~ /^(pass|rpop)/i ? "$1 ....\n" : $_[2]; }
-
-
-sub login {
- @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->login( USER, PASS )';
- my ($me, $user, $pass) = @_;
-
- if (@_ <= 2) {
- ($user, $pass) = $me->_lookup_credentials($user);
- }
-
- $me->user($user)
- and $me->pass($pass);
-}
-
-
-sub apop {
- @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->apop( USER, PASS )';
- my ($me, $user, $pass) = @_;
- my $banner;
- my $md;
-
- if (eval { local $SIG{__DIE__}; require Digest::MD5 }) {
- $md = Digest::MD5->new();
- }
- elsif (eval { local $SIG{__DIE__}; require MD5 }) {
- $md = MD5->new();
- }
- else {
- carp "You need to install Digest::MD5 or MD5 to use the APOP command";
- return undef;
- }
-
- return undef
- unless ($banner = (${*$me}{'net_pop3_banner'} =~ /(<.*>)/)[0]);
-
- if (@_ <= 2) {
- ($user, $pass) = $me->_lookup_credentials($user);
- }
-
- $md->add($banner, $pass);
-
- return undef
- unless ($me->_APOP($user, $md->hexdigest));
-
- $me->_get_mailbox_count();
-}
-
-
-sub user {
- @_ == 2 or croak 'usage: $pop3->user( USER )';
- $_[0]->_USER($_[1]) ? 1 : undef;
-}
-
-
-sub pass {
- @_ == 2 or croak 'usage: $pop3->pass( PASS )';
-
- my ($me, $pass) = @_;
-
- return undef
- unless ($me->_PASS($pass));
-
- $me->_get_mailbox_count();
-}
-
-
-sub reset {
- @_ == 1 or croak 'usage: $obj->reset()';
-
- my $me = shift;
-
- return 0
- unless ($me->_RSET);
-
- if (defined ${*$me}{'net_pop3_mail'}) {
- local $_;
- foreach (@{${*$me}{'net_pop3_mail'}}) {
- delete $_->{'net_pop3_deleted'};
- }
- }
-}
-
-
-sub last {
- @_ == 1 or croak 'usage: $obj->last()';
-
- return undef
- unless $_[0]->_LAST && $_[0]->message =~ /(\d+)/;
-
- return $1;
-}
-
-
-sub top {
- @_ == 2 || @_ == 3 or croak 'usage: $pop3->top( MSGNUM [, NUMLINES ])';
- my $me = shift;
-
- return undef
- unless $me->_TOP($_[0], $_[1] || 0);
-
- $me->read_until_dot;
-}
-
-
-sub popstat {
- @_ == 1 or croak 'usage: $pop3->popstat()';
- my $me = shift;
-
- return ()
- unless $me->_STAT && $me->message =~ /(\d+)\D+(\d+)/;
-
- ($1 || 0, $2 || 0);
-}
-
-
-sub list {
- @_ == 1 || @_ == 2 or croak 'usage: $pop3->list( [ MSGNUM ] )';
- my $me = shift;
-
- return undef
- unless $me->_LIST(@_);
-
- if (@_) {
- $me->message =~ /\d+\D+(\d+)/;
- return $1 || undef;
- }
-
- my $info = $me->read_until_dot
- or return undef;
-
- my %hash = map { (/(\d+)\D+(\d+)/) } @$info;
-
- return \%hash;
-}
-
-
-sub get {
- @_ == 2 or @_ == 3 or croak 'usage: $pop3->get( MSGNUM [, FH ])';
- my $me = shift;
-
- return undef
- unless $me->_RETR(shift);
-
- $me->read_until_dot(@_);
-}
-
-
-sub getfh {
- @_ == 2 or croak 'usage: $pop3->getfh( MSGNUM )';
- my $me = shift;
-
- return unless $me->_RETR(shift);
- return $me->tied_fh;
-}
-
-
-sub delete {
- @_ == 2 or croak 'usage: $pop3->delete( MSGNUM )';
- my $me = shift;
- return 0 unless $me->_DELE(@_);
- ${*$me}{'net_pop3_deleted'} = 1;
-}
-
-
-sub uidl {
- @_ == 1 || @_ == 2 or croak 'usage: $pop3->uidl( [ MSGNUM ] )';
- my $me = shift;
- my $uidl;
-
- $me->_UIDL(@_)
- or return undef;
- if (@_) {
- $uidl = ($me->message =~ /\d+\s+([\041-\176]+)/)[0];
- }
- else {
- my $ref = $me->read_until_dot
- or return undef;
- my $ln;
- $uidl = {};
- foreach $ln (@$ref) {
- my ($msg, $uid) = $ln =~ /^\s*(\d+)\s+([\041-\176]+)/;
- $uidl->{$msg} = $uid;
- }
- }
- return $uidl;
-}
-
-
-sub ping {
- @_ == 2 or croak 'usage: $pop3->ping( USER )';
- my $me = shift;
-
- return () unless $me->_PING(@_) && $me->message =~ /(\d+)\D+(\d+)/;
-
- ($1 || 0, $2 || 0);
-}
-
-
-sub _lookup_credentials {
- my ($me, $user) = @_;
-
- require Net::Netrc;
-
- $user ||= eval { local $SIG{__DIE__}; (getpwuid($>))[0] }
- || $ENV{NAME}
- || $ENV{USER}
- || $ENV{LOGNAME};
-
- my $m = Net::Netrc->lookup(${*$me}{'net_pop3_host'}, $user);
- $m ||= Net::Netrc->lookup(${*$me}{'net_pop3_host'});
-
- my $pass = $m
- ? $m->password || ""
- : "";
-
- ($user, $pass);
-}
-
-
-sub _get_mailbox_count {
- my ($me) = @_;
- my $ret = ${*$me}{'net_pop3_count'} =
- ($me->message =~ /(\d+)\s+message/io) ? $1 : ($me->popstat)[0];
-
- $ret ? $ret : "0E0";
-}
-
-
-sub _STAT { shift->command('STAT')->response() == CMD_OK }
-sub _LIST { shift->command('LIST', @_)->response() == CMD_OK }
-sub _RETR { shift->command('RETR', $_[0])->response() == CMD_OK }
-sub _DELE { shift->command('DELE', $_[0])->response() == CMD_OK }
-sub _NOOP { shift->command('NOOP')->response() == CMD_OK }
-sub _RSET { shift->command('RSET')->response() == CMD_OK }
-sub _QUIT { shift->command('QUIT')->response() == CMD_OK }
-sub _TOP { shift->command('TOP', @_)->response() == CMD_OK }
-sub _UIDL { shift->command('UIDL', @_)->response() == CMD_OK }
-sub _USER { shift->command('USER', $_[0])->response() == CMD_OK }
-sub _PASS { shift->command('PASS', $_[0])->response() == CMD_OK }
-sub _APOP { shift->command('APOP', @_)->response() == CMD_OK }
-sub _PING { shift->command('PING', $_[0])->response() == CMD_OK }
-
-
-sub _RPOP { shift->command('RPOP', $_[0])->response() == CMD_OK }
-sub _LAST { shift->command('LAST')->response() == CMD_OK }
-
-
-sub _CAPA { shift->command('CAPA')->response() == CMD_OK }
-
-
-sub quit {
- my $me = shift;
-
- $me->_QUIT;
- $me->close;
-}
-
-
-sub DESTROY {
- my $me = shift;
-
- if (defined fileno($me) and ${*$me}{'net_pop3_deleted'}) {
- $me->reset;
- $me->quit;
- }
-}
-
-##
-## POP3 has weird responses, so we emulate them to look the same :-)
-##
-
-
-sub response {
- my $cmd = shift;
- my $str = $cmd->getline() or return undef;
- my $code = "500";
-
- $cmd->debug_print(0, $str)
- if ($cmd->debug);
-
- if ($str =~ s/^\+OK\s*//io) {
- $code = "200";
- }
- elsif ($str =~ s/^\+\s*//io) {
- $code = "300";
- }
- else {
- $str =~ s/^-ERR\s*//io;
- }
-
- ${*$cmd}{'net_cmd_resp'} = [$str];
- ${*$cmd}{'net_cmd_code'} = $code;
-
- substr($code, 0, 1);
-}
-
-
-sub capa {
- my $this = shift;
- my ($capa, %capabilities);
-
- # Fake a capability here
- $capabilities{APOP} = '' if ($this->banner() =~ /<.*>/);
-
- if ($this->_CAPA()) {
- $capabilities{CAPA} = 1;
- $capa = $this->read_until_dot();
- %capabilities = (%capabilities, map {/^\s*(\S+)\s*(.*)/} @$capa);
- }
- else {
-
- # Check AUTH for SASL capabilities
- if ($this->command('AUTH')->response() == CMD_OK) {
- my $mechanism = $this->read_until_dot();
- $capabilities{SASL} = join " ", map {m/([A-Z0-9_-]+)/} @{$mechanism};
- }
- }
-
- return ${*$this}{'net_pop3e_capabilities'} = \%capabilities;
-}
-
-
-sub capabilities {
- my $this = shift;
-
- ${*$this}{'net_pop3e_capabilities'} || $this->capa;
-}
-
-
-sub auth {
- my ($self, $username, $password) = @_;
-
- eval {
- require MIME::Base64;
- require Authen::SASL;
- } or $self->set_status(500, ["Need MIME::Base64 and Authen::SASL todo auth"]), return 0;
-
- my $capa = $self->capa;
- my $mechanisms = $capa->{SASL} || 'CRAM-MD5';
-
- my $sasl;
-
- if (ref($username) and UNIVERSAL::isa($username, 'Authen::SASL')) {
- $sasl = $username;
- my $user_mech = $sasl->mechanism || '';
- my @user_mech = split(/\s+/, $user_mech);
- my %user_mech;
- @user_mech{@user_mech} = ();
-
- my @server_mech = split(/\s+/, $mechanisms);
- my @mech = @user_mech
- ? grep { exists $user_mech{$_} } @server_mech
- : @server_mech;
- unless (@mech) {
- $self->set_status(
- 500,
- [ 'Client SASL mechanisms (',
- join(', ', @user_mech),
- ') do not match the SASL mechnism the server announces (',
- join(', ', @server_mech), ')',
- ]
- );
- return 0;
- }
-
- $sasl->mechanism(join(" ", @mech));
- }
- else {
- die "auth(username, password)" if not length $username;
- $sasl = Authen::SASL->new(
- mechanism => $mechanisms,
- callback => {
- user => $username,
- pass => $password,
- authname => $username,
- }
- );
- }
-
- # We should probably allow the user to pass the host, but I don't
- # currently know and SASL mechanisms that are used by smtp that need it
- my ($hostname) = split /:/, ${*$self}{'net_pop3_host'};
- my $client = eval { $sasl->client_new('pop', $hostname, 0) };
-
- unless ($client) {
- my $mech = $sasl->mechanism;
- $self->set_status(
- 500,
- [ " Authen::SASL failure: $@",
- '(please check if your local Authen::SASL installation',
- "supports mechanism '$mech'"
- ]
- );
- return 0;
- }
-
- my ($token) = $client->client_start
- or do {
- my $mech = $client->mechanism;
- $self->set_status(
- 500,
- [ ' Authen::SASL failure: $client->client_start ',
- "mechanism '$mech' hostname #$hostname#",
- $client->error
- ]
- );
- return 0;
- };
-
- # We dont support sasl mechanisms that encrypt the socket traffic.
- # todo that we would really need to change the ISA hierarchy
- # so we dont inherit from IO::Socket, but instead hold it in an attribute
-
- my @cmd = ("AUTH", $client->mechanism);
- my $code;
-
- push @cmd, MIME::Base64::encode_base64($token, '')
- if defined $token and length $token;
-
- while (($code = $self->command(@cmd)->response()) == CMD_MORE) {
-
- my ($token) = $client->client_step(MIME::Base64::decode_base64(($self->message)[0])) or do {
- $self->set_status(
- 500,
- [ ' Authen::SASL failure: $client->client_step ',
- "mechanism '", $client->mechanism, " hostname #$hostname#, ",
- $client->error
- ]
- );
- return 0;
- };
-
- @cmd = (MIME::Base64::encode_base64(defined $token ? $token : '', ''));
- }
-
- $code == CMD_OK;
-}
-
-
-sub banner {
- my $this = shift;
-
- return ${*$this}{'net_pop3_banner'};
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-Net::POP3 - Post Office Protocol 3 Client class (RFC1939)
-
-=head1 SYNOPSIS
-
- use Net::POP3;
-
- # Constructors
- $pop = Net::POP3->new('pop3host');
- $pop = Net::POP3->new('pop3host', Timeout => 60);
-
- if ($pop->login($username, $password) > 0) {
- my $msgnums = $pop->list; # hashref of msgnum => size
- foreach my $msgnum (keys %$msgnums) {
- my $msg = $pop->get($msgnum);
- print @$msg;
- $pop->delete($msgnum);
- }
- }
-
- $pop->quit;
-
-=head1 DESCRIPTION
-
-This module implements a client interface to the POP3 protocol, enabling
-a perl5 application to talk to POP3 servers. This documentation assumes
-that you are familiar with the POP3 protocol described in RFC1939.
-
-A new Net::POP3 object must be created with the I<new> method. Once
-this has been done, all POP3 commands are accessed via method calls
-on the object.
-
-=head1 CONSTRUCTOR
-
-=over 4
-
-=item new ( [ HOST ] [, OPTIONS ] 0
-
-This is the constructor for a new Net::POP3 object. C<HOST> is the
-name of the remote host to which an POP3 connection is required.
-
-C<HOST> is optional. If C<HOST> is not given then it may instead be
-passed as the C<Host> option described below. If neither is given then
-the C<POP3_Hosts> specified in C<Net::Config> will be used.
-
-C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
-Possible options are:
-
-B<Host> - POP3 host to connect to. It may be a single scalar, as defined for
-the C<PeerAddr> option in L<IO::Socket::INET>, or a reference to
-an array with hosts to try in turn. The L</host> method will return the value
-which was used to connect to the host.
-
-B<ResvPort> - If given then the socket for the C<Net::POP3> object
-will be bound to the local port given using C<bind> when the socket is
-created.
-
-B<Timeout> - Maximum time, in seconds, to wait for a response from the
-POP3 server (default: 120)
-
-B<Debug> - Enable debugging information
-
-=back
-
-=head1 METHODS
-
-Unless otherwise stated all methods return either a I<true> or I<false>
-value, with I<true> meaning that the operation was a success. When a method
-states that it returns a value, failure will be returned as I<undef> or an
-empty list.
-
-=over 4
-
-=item auth ( USERNAME, PASSWORD )
-
-Attempt SASL authentication.
-
-=item user ( USER )
-
-Send the USER command.
-
-=item pass ( PASS )
-
-Send the PASS command. Returns the number of messages in the mailbox.
-
-=item login ( [ USER [, PASS ]] )
-
-Send both the USER and PASS commands. If C<PASS> is not given the
-C<Net::POP3> uses C<Net::Netrc> to lookup the password using the host
-and username. If the username is not specified then the current user name
-will be used.
-
-Returns the number of messages in the mailbox. However if there are no
-messages on the server the string C<"0E0"> will be returned. This is
-will give a true value in a boolean context, but zero in a numeric context.
-
-If there was an error authenticating the user then I<undef> will be returned.
-
-=item apop ( [ USER [, PASS ]] )
-
-Authenticate with the server identifying as C<USER> with password C<PASS>.
-Similar to L</login>, but the password is not sent in clear text.
-
-To use this method you must have the Digest::MD5 or the MD5 module installed,
-otherwise this method will return I<undef>.
-
-=item banner ()
-
-Return the sever's connection banner
-
-=item capa ()
-
-Return a reference to a hash of the capabilities of the server. APOP
-is added as a pseudo capability. Note that I've been unable to
-find a list of the standard capability values, and some appear to
-be multi-word and some are not. We make an attempt at intelligently
-parsing them, but it may not be correct.
-
-=item capabilities ()
-
-Just like capa, but only uses a cache from the last time we asked
-the server, so as to avoid asking more than once.
-
-=item top ( MSGNUM [, NUMLINES ] )
-
-Get the header and the first C<NUMLINES> of the body for the message
-C<MSGNUM>. Returns a reference to an array which contains the lines of text
-read from the server.
-
-=item list ( [ MSGNUM ] )
-
-If called with an argument the C<list> returns the size of the message
-in octets.
-
-If called without arguments a reference to a hash is returned. The
-keys will be the C<MSGNUM>'s of all undeleted messages and the values will
-be their size in octets.
-
-=item get ( MSGNUM [, FH ] )
-
-Get the message C<MSGNUM> from the remote mailbox. If C<FH> is not given
-then get returns a reference to an array which contains the lines of
-text read from the server. If C<FH> is given then the lines returned
-from the server are printed to the filehandle C<FH>.
-
-=item getfh ( MSGNUM )
-
-As per get(), but returns a tied filehandle. Reading from this
-filehandle returns the requested message. The filehandle will return
-EOF at the end of the message and should not be reused.
-
-=item last ()
-
-Returns the highest C<MSGNUM> of all the messages accessed.
-
-=item popstat ()
-
-Returns a list of two elements. These are the number of undeleted
-elements and the size of the mbox in octets.
-
-=item ping ( USER )
-
-Returns a list of two elements. These are the number of new messages
-and the total number of messages for C<USER>.
-
-=item uidl ( [ MSGNUM ] )
-
-Returns a unique identifier for C<MSGNUM> if given. If C<MSGNUM> is not
-given C<uidl> returns a reference to a hash where the keys are the
-message numbers and the values are the unique identifiers.
-
-=item delete ( MSGNUM )
-
-Mark message C<MSGNUM> to be deleted from the remote mailbox. All messages
-that are marked to be deleted will be removed from the remote mailbox
-when the server connection closed.
-
-=item reset ()
-
-Reset the status of the remote POP3 server. This includes resetting the
-status of all messages to not be deleted.
-
-=item quit ()
-
-Quit and close the connection to the remote POP3 server. Any messages marked
-as deleted will be deleted from the remote mailbox.
-
-=back
-
-=head1 NOTES
-
-If a C<Net::POP3> object goes out of scope before C<quit> method is called
-then the C<reset> method will called before the connection is closed. This
-means that any messages marked to be deleted will not be.
-
-=head1 SEE ALSO
-
-L<Net::Netrc>,
-L<Net::Cmd>
-
-=head1 AUTHOR
-
-Graham Barr <gbarr@pobox.com>
-
-=head1 COPYRIGHT
-
-Copyright (c) 1995-2003 Graham Barr. All rights reserved.
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=cut
diff --git a/Master/tlpkg/tlperl/lib/Net/Ping.pm b/Master/tlpkg/tlperl/lib/Net/Ping.pm
deleted file mode 100755
index e9fff93eeaa..00000000000
--- a/Master/tlpkg/tlperl/lib/Net/Ping.pm
+++ /dev/null
@@ -1,1777 +0,0 @@
-package Net::Ping;
-
-require 5.002;
-require Exporter;
-
-use strict;
-use vars qw(@ISA @EXPORT $VERSION
- $def_timeout $def_proto $def_factor
- $max_datasize $pingstring $hires $source_verify $syn_forking);
-use Fcntl qw( F_GETFL F_SETFL O_NONBLOCK );
-use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW PF_INET SOL_SOCKET SO_ERROR
- inet_aton inet_ntoa sockaddr_in );
-use POSIX qw( ENOTCONN ECONNREFUSED ECONNRESET EINPROGRESS EWOULDBLOCK EAGAIN WNOHANG );
-use FileHandle;
-use Carp;
-
-@ISA = qw(Exporter);
-@EXPORT = qw(pingecho);
-$VERSION = "2.36";
-
-sub SOL_IP { 0; };
-sub IP_TOS { 1; };
-
-# Constants
-
-$def_timeout = 5; # Default timeout to wait for a reply
-$def_proto = "tcp"; # Default protocol to use for pinging
-$def_factor = 1.2; # Default exponential backoff rate.
-$max_datasize = 1024; # Maximum data bytes in a packet
-# The data we exchange with the server for the stream protocol
-$pingstring = "pingschwingping!\n";
-$source_verify = 1; # Default is to verify source endpoint
-$syn_forking = 0;
-
-if ($^O =~ /Win32/i) {
- # Hack to avoid this Win32 spewage:
- # Your vendor has not defined POSIX macro ECONNREFUSED
- my @pairs = (ECONNREFUSED => 10061, # "Unknown Error" Special Win32 Response?
- ENOTCONN => 10057,
- ECONNRESET => 10054,
- EINPROGRESS => 10036,
- EWOULDBLOCK => 10035,
- );
- while (my $name = shift @pairs) {
- my $value = shift @pairs;
- # When defined, these all are non-zero
- unless (eval $name) {
- no strict 'refs';
- *{$name} = defined prototype \&{$name} ? sub () {$value} : sub {$value};
- }
- }
-# $syn_forking = 1; # XXX possibly useful in < Win2K ?
-};
-
-# h2ph "asm/socket.h"
-# require "asm/socket.ph";
-sub SO_BINDTODEVICE {25;}
-
-# Description: The pingecho() subroutine is provided for backward
-# compatibility with the original Net::Ping. It accepts a host
-# name/IP and an optional timeout in seconds. Create a tcp ping
-# object and try pinging the host. The result of the ping is returned.
-
-sub pingecho
-{
- my ($host, # Name or IP number of host to ping
- $timeout # Optional timeout in seconds
- ) = @_;
- my ($p); # A ping object
-
- $p = Net::Ping->new("tcp", $timeout);
- $p->ping($host); # Going out of scope closes the connection
-}
-
-# Description: The new() method creates a new ping object. Optional
-# parameters may be specified for the protocol to use, the timeout in
-# seconds and the size in bytes of additional data which should be
-# included in the packet.
-# After the optional parameters are checked, the data is constructed
-# and a socket is opened if appropriate. The object is returned.
-
-sub new
-{
- my ($this,
- $proto, # Optional protocol to use for pinging
- $timeout, # Optional timeout in seconds
- $data_size, # Optional additional bytes of data
- $device, # Optional device to use
- $tos, # Optional ToS to set
- ) = @_;
- my $class = ref($this) || $this;
- my $self = {};
- my ($cnt, # Count through data bytes
- $min_datasize # Minimum data bytes required
- );
-
- bless($self, $class);
-
- $proto = $def_proto unless $proto; # Determine the protocol
- croak('Protocol for ping must be "icmp", "udp", "tcp", "syn", "stream", or "external"')
- unless $proto =~ m/^(icmp|udp|tcp|syn|stream|external)$/;
- $self->{"proto"} = $proto;
-
- $timeout = $def_timeout unless $timeout; # Determine the timeout
- croak("Default timeout for ping must be greater than 0 seconds")
- if $timeout <= 0;
- $self->{"timeout"} = $timeout;
-
- $self->{"device"} = $device;
-
- $self->{"tos"} = $tos;
-
- $min_datasize = ($proto eq "udp") ? 1 : 0; # Determine data size
- $data_size = $min_datasize unless defined($data_size) && $proto ne "tcp";
- croak("Data for ping must be from $min_datasize to $max_datasize bytes")
- if ($data_size < $min_datasize) || ($data_size > $max_datasize);
- $data_size-- if $self->{"proto"} eq "udp"; # We provide the first byte
- $self->{"data_size"} = $data_size;
-
- $self->{"data"} = ""; # Construct data bytes
- for ($cnt = 0; $cnt < $self->{"data_size"}; $cnt++)
- {
- $self->{"data"} .= chr($cnt % 256);
- }
-
- $self->{"local_addr"} = undef; # Don't bind by default
- $self->{"retrans"} = $def_factor; # Default exponential backoff rate
- $self->{"econnrefused"} = undef; # Default Connection refused behavior
-
- $self->{"seq"} = 0; # For counting packets
- if ($self->{"proto"} eq "udp") # Open a socket
- {
- $self->{"proto_num"} = (getprotobyname('udp'))[2] ||
- croak("Can't udp protocol by name");
- $self->{"port_num"} = (getservbyname('echo', 'udp'))[2] ||
- croak("Can't get udp echo port by name");
- $self->{"fh"} = FileHandle->new();
- socket($self->{"fh"}, PF_INET, SOCK_DGRAM,
- $self->{"proto_num"}) ||
- croak("udp socket error - $!");
- if ($self->{'device'}) {
- setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
- or croak "error binding to device $self->{'device'} $!";
- }
- if ($self->{'tos'}) {
- setsockopt($self->{"fh"}, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
- or croak "error configuring tos to $self->{'tos'} $!";
- }
- }
- elsif ($self->{"proto"} eq "icmp")
- {
- croak("icmp ping requires root privilege") if ($> and $^O ne 'VMS' and $^O ne 'cygwin');
- $self->{"proto_num"} = (getprotobyname('icmp'))[2] ||
- croak("Can't get icmp protocol by name");
- $self->{"pid"} = $$ & 0xffff; # Save lower 16 bits of pid
- $self->{"fh"} = FileHandle->new();
- socket($self->{"fh"}, PF_INET, SOCK_RAW, $self->{"proto_num"}) ||
- croak("icmp socket error - $!");
- if ($self->{'device'}) {
- setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
- or croak "error binding to device $self->{'device'} $!";
- }
- if ($self->{'tos'}) {
- setsockopt($self->{"fh"}, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
- or croak "error configuring tos to $self->{'tos'} $!";
- }
- }
- elsif ($self->{"proto"} eq "tcp" || $self->{"proto"} eq "stream")
- {
- $self->{"proto_num"} = (getprotobyname('tcp'))[2] ||
- croak("Can't get tcp protocol by name");
- $self->{"port_num"} = (getservbyname('echo', 'tcp'))[2] ||
- croak("Can't get tcp echo port by name");
- $self->{"fh"} = FileHandle->new();
- }
- elsif ($self->{"proto"} eq "syn")
- {
- $self->{"proto_num"} = (getprotobyname('tcp'))[2] ||
- croak("Can't get tcp protocol by name");
- $self->{"port_num"} = (getservbyname('echo', 'tcp'))[2] ||
- croak("Can't get tcp echo port by name");
- if ($syn_forking) {
- $self->{"fork_rd"} = FileHandle->new();
- $self->{"fork_wr"} = FileHandle->new();
- pipe($self->{"fork_rd"}, $self->{"fork_wr"});
- $self->{"fh"} = FileHandle->new();
- $self->{"good"} = {};
- $self->{"bad"} = {};
- } else {
- $self->{"wbits"} = "";
- $self->{"bad"} = {};
- }
- $self->{"syn"} = {};
- $self->{"stop_time"} = 0;
- }
- elsif ($self->{"proto"} eq "external")
- {
- # No preliminary work needs to be done.
- }
-
- return($self);
-}
-
-# Description: Set the local IP address from which pings will be sent.
-# For ICMP and UDP pings, this calls bind() on the already-opened socket;
-# for TCP pings, just saves the address to be used when the socket is
-# opened. Returns non-zero if successful; croaks on error.
-sub bind
-{
- my ($self,
- $local_addr # Name or IP number of local interface
- ) = @_;
- my ($ip # Packed IP number of $local_addr
- );
-
- croak("Usage: \$p->bind(\$local_addr)") unless @_ == 2;
- croak("already bound") if defined($self->{"local_addr"}) &&
- ($self->{"proto"} eq "udp" || $self->{"proto"} eq "icmp");
-
- $ip = inet_aton($local_addr);
- croak("nonexistent local address $local_addr") unless defined($ip);
- $self->{"local_addr"} = $ip; # Only used if proto is tcp
-
- if ($self->{"proto"} eq "udp" || $self->{"proto"} eq "icmp")
- {
- CORE::bind($self->{"fh"}, sockaddr_in(0, $ip)) ||
- croak("$self->{'proto'} bind error - $!");
- }
- elsif (($self->{"proto"} ne "tcp") && ($self->{"proto"} ne "syn"))
- {
- croak("Unknown protocol \"$self->{proto}\" in bind()");
- }
-
- return 1;
-}
-
-# Description: A select() wrapper that compensates for platform
-# peculiarities.
-sub mselect
-{
- if ($_[3] > 0 and $^O eq 'MSWin32') {
- # On windows, select() doesn't process the message loop,
- # but sleep() will, allowing alarm() to interrupt the latter.
- # So we chop up the timeout into smaller pieces and interleave
- # select() and sleep() calls.
- my $t = $_[3];
- my $gran = 0.5; # polling granularity in seconds
- my @args = @_;
- while (1) {
- $gran = $t if $gran > $t;
- my $nfound = select($_[0], $_[1], $_[2], $gran);
- undef $nfound if $nfound == -1;
- $t -= $gran;
- return $nfound if $nfound or !defined($nfound) or $t <= 0;
-
- sleep(0);
- ($_[0], $_[1], $_[2]) = @args;
- }
- }
- else {
- my $nfound = select($_[0], $_[1], $_[2], $_[3]);
- undef $nfound if $nfound == -1;
- return $nfound;
- }
-}
-
-# Description: Allow UDP source endpoint comparison to be
-# skipped for those remote interfaces that do
-# not response from the same endpoint.
-
-sub source_verify
-{
- my $self = shift;
- $source_verify = 1 unless defined
- ($source_verify = ((defined $self) && (ref $self)) ? shift() : $self);
-}
-
-# Description: Set whether or not the connect
-# behavior should enforce remote service
-# availability as well as reachability.
-
-sub service_check
-{
- my $self = shift;
- $self->{"econnrefused"} = 1 unless defined
- ($self->{"econnrefused"} = shift());
-}
-
-sub tcp_service_check
-{
- service_check(@_);
-}
-
-# Description: Set exponential backoff for retransmission.
-# Should be > 1 to retain exponential properties.
-# If set to 0, retransmissions are disabled.
-
-sub retrans
-{
- my $self = shift;
- $self->{"retrans"} = shift;
-}
-
-# Description: allows the module to use milliseconds as returned by
-# the Time::HiRes module
-
-$hires = 0;
-sub hires
-{
- my $self = shift;
- $hires = 1 unless defined
- ($hires = ((defined $self) && (ref $self)) ? shift() : $self);
- require Time::HiRes if $hires;
-}
-
-sub time
-{
- return $hires ? Time::HiRes::time() : CORE::time();
-}
-
-# Description: Sets or clears the O_NONBLOCK flag on a file handle.
-sub socket_blocking_mode
-{
- my ($self,
- $fh, # the file handle whose flags are to be modified
- $block) = @_; # if true then set the blocking
- # mode (clear O_NONBLOCK), otherwise
- # set the non-blocking mode (set O_NONBLOCK)
-
- my $flags;
- if ($^O eq 'MSWin32' || $^O eq 'VMS') {
- # FIONBIO enables non-blocking sockets on windows and vms.
- # FIONBIO is (0x80000000|(4<<16)|(ord('f')<<8)|126), as per winsock.h, ioctl.h
- my $f = 0x8004667e;
- my $v = pack("L", $block ? 0 : 1);
- ioctl($fh, $f, $v) or croak("ioctl failed: $!");
- return;
- }
- if ($flags = fcntl($fh, F_GETFL, 0)) {
- $flags = $block ? ($flags & ~O_NONBLOCK) : ($flags | O_NONBLOCK);
- if (!fcntl($fh, F_SETFL, $flags)) {
- croak("fcntl F_SETFL: $!");
- }
- } else {
- croak("fcntl F_GETFL: $!");
- }
-}
-
-# Description: Ping a host name or IP number with an optional timeout.
-# First lookup the host, and return undef if it is not found. Otherwise
-# perform the specific ping method based on the protocol. Return the
-# result of the ping.
-
-sub ping
-{
- my ($self,
- $host, # Name or IP number of host to ping
- $timeout, # Seconds after which ping times out
- ) = @_;
- my ($ip, # Packed IP number of $host
- $ret, # The return value
- $ping_time, # When ping began
- );
-
- croak("Usage: \$p->ping(\$host [, \$timeout])") unless @_ == 2 || @_ == 3;
- $timeout = $self->{"timeout"} unless $timeout;
- croak("Timeout must be greater than 0 seconds") if $timeout <= 0;
-
- $ip = inet_aton($host);
- return () unless defined($ip); # Does host exist?
-
- # Dispatch to the appropriate routine.
- $ping_time = &time();
- if ($self->{"proto"} eq "external") {
- $ret = $self->ping_external($ip, $timeout);
- }
- elsif ($self->{"proto"} eq "udp") {
- $ret = $self->ping_udp($ip, $timeout);
- }
- elsif ($self->{"proto"} eq "icmp") {
- $ret = $self->ping_icmp($ip, $timeout);
- }
- elsif ($self->{"proto"} eq "tcp") {
- $ret = $self->ping_tcp($ip, $timeout);
- }
- elsif ($self->{"proto"} eq "stream") {
- $ret = $self->ping_stream($ip, $timeout);
- }
- elsif ($self->{"proto"} eq "syn") {
- $ret = $self->ping_syn($host, $ip, $ping_time, $ping_time+$timeout);
- } else {
- croak("Unknown protocol \"$self->{proto}\" in ping()");
- }
-
- return wantarray ? ($ret, &time() - $ping_time, inet_ntoa($ip)) : $ret;
-}
-
-# Uses Net::Ping::External to do an external ping.
-sub ping_external {
- my ($self,
- $ip, # Packed IP number of the host
- $timeout # Seconds after which ping times out
- ) = @_;
-
- eval { require Net::Ping::External; }
- or croak('Protocol "external" not supported on your system: Net::Ping::External not found');
- return Net::Ping::External::ping(ip => $ip, timeout => $timeout);
-}
-
-use constant ICMP_ECHOREPLY => 0; # ICMP packet types
-use constant ICMP_UNREACHABLE => 3; # ICMP packet types
-use constant ICMP_ECHO => 8;
-use constant ICMP_STRUCT => "C2 n3 A"; # Structure of a minimal ICMP packet
-use constant SUBCODE => 0; # No ICMP subcode for ECHO and ECHOREPLY
-use constant ICMP_FLAGS => 0; # No special flags for send or recv
-use constant ICMP_PORT => 0; # No port with ICMP
-
-sub ping_icmp
-{
- my ($self,
- $ip, # Packed IP number of the host
- $timeout # Seconds after which ping times out
- ) = @_;
-
- my ($saddr, # sockaddr_in with port and ip
- $checksum, # Checksum of ICMP packet
- $msg, # ICMP packet to send
- $len_msg, # Length of $msg
- $rbits, # Read bits, filehandles for reading
- $nfound, # Number of ready filehandles found
- $finish_time, # Time ping should be finished
- $done, # set to 1 when we are done
- $ret, # Return value
- $recv_msg, # Received message including IP header
- $from_saddr, # sockaddr_in of sender
- $from_port, # Port packet was sent from
- $from_ip, # Packed IP of sender
- $from_type, # ICMP type
- $from_subcode, # ICMP subcode
- $from_chk, # ICMP packet checksum
- $from_pid, # ICMP packet id
- $from_seq, # ICMP packet sequence
- $from_msg # ICMP message
- );
-
- $self->{"seq"} = ($self->{"seq"} + 1) % 65536; # Increment sequence
- $checksum = 0; # No checksum for starters
- $msg = pack(ICMP_STRUCT . $self->{"data_size"}, ICMP_ECHO, SUBCODE,
- $checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"});
- $checksum = Net::Ping->checksum($msg);
- $msg = pack(ICMP_STRUCT . $self->{"data_size"}, ICMP_ECHO, SUBCODE,
- $checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"});
- $len_msg = length($msg);
- $saddr = sockaddr_in(ICMP_PORT, $ip);
- $self->{"from_ip"} = undef;
- $self->{"from_type"} = undef;
- $self->{"from_subcode"} = undef;
- send($self->{"fh"}, $msg, ICMP_FLAGS, $saddr); # Send the message
-
- $rbits = "";
- vec($rbits, $self->{"fh"}->fileno(), 1) = 1;
- $ret = 0;
- $done = 0;
- $finish_time = &time() + $timeout; # Must be done by this time
- while (!$done && $timeout > 0) # Keep trying if we have time
- {
- $nfound = mselect((my $rout=$rbits), undef, undef, $timeout); # Wait for packet
- $timeout = $finish_time - &time(); # Get remaining time
- if (!defined($nfound)) # Hmm, a strange error
- {
- $ret = undef;
- $done = 1;
- }
- elsif ($nfound) # Got a packet from somewhere
- {
- $recv_msg = "";
- $from_pid = -1;
- $from_seq = -1;
- $from_saddr = recv($self->{"fh"}, $recv_msg, 1500, ICMP_FLAGS);
- ($from_port, $from_ip) = sockaddr_in($from_saddr);
- ($from_type, $from_subcode) = unpack("C2", substr($recv_msg, 20, 2));
- if ($from_type == ICMP_ECHOREPLY) {
- ($from_pid, $from_seq) = unpack("n3", substr($recv_msg, 24, 4))
- if length $recv_msg >= 28;
- } else {
- ($from_pid, $from_seq) = unpack("n3", substr($recv_msg, 52, 4))
- if length $recv_msg >= 56;
- }
- $self->{"from_ip"} = $from_ip;
- $self->{"from_type"} = $from_type;
- $self->{"from_subcode"} = $from_subcode;
- if (($from_pid == $self->{"pid"}) && # Does the packet check out?
- (! $source_verify || (inet_ntoa($from_ip) eq inet_ntoa($ip))) &&
- ($from_seq == $self->{"seq"})) {
- if ($from_type == ICMP_ECHOREPLY) {
- $ret = 1;
- $done = 1;
- } elsif ($from_type == ICMP_UNREACHABLE) {
- $done = 1;
- }
- }
- } else { # Oops, timed out
- $done = 1;
- }
- }
- return $ret;
-}
-
-sub icmp_result {
- my ($self) = @_;
- my $ip = $self->{"from_ip"} || "";
- $ip = "\0\0\0\0" unless 4 == length $ip;
- return (inet_ntoa($ip),($self->{"from_type"} || 0), ($self->{"from_subcode"} || 0));
-}
-
-# Description: Do a checksum on the message. Basically sum all of
-# the short words and fold the high order bits into the low order bits.
-
-sub checksum
-{
- my ($class,
- $msg # The message to checksum
- ) = @_;
- my ($len_msg, # Length of the message
- $num_short, # The number of short words in the message
- $short, # One short word
- $chk # The checksum
- );
-
- $len_msg = length($msg);
- $num_short = int($len_msg / 2);
- $chk = 0;
- foreach $short (unpack("n$num_short", $msg))
- {
- $chk += $short;
- } # Add the odd byte in
- $chk += (unpack("C", substr($msg, $len_msg - 1, 1)) << 8) if $len_msg % 2;
- $chk = ($chk >> 16) + ($chk & 0xffff); # Fold high into low
- return(~(($chk >> 16) + $chk) & 0xffff); # Again and complement
-}
-
-
-# Description: Perform a tcp echo ping. Since a tcp connection is
-# host specific, we have to open and close each connection here. We
-# can't just leave a socket open. Because of the robust nature of
-# tcp, it will take a while before it gives up trying to establish a
-# connection. Therefore, we use select() on a non-blocking socket to
-# check against our timeout. No data bytes are actually
-# sent since the successful establishment of a connection is proof
-# enough of the reachability of the remote host. Also, tcp is
-# expensive and doesn't need our help to add to the overhead.
-
-sub ping_tcp
-{
- my ($self,
- $ip, # Packed IP number of the host
- $timeout # Seconds after which ping times out
- ) = @_;
- my ($ret # The return value
- );
-
- $! = 0;
- $ret = $self -> tcp_connect( $ip, $timeout);
- if (!$self->{"econnrefused"} &&
- $! == ECONNREFUSED) {
- $ret = 1; # "Connection refused" means reachable
- }
- $self->{"fh"}->close();
- return $ret;
-}
-
-sub tcp_connect
-{
- my ($self,
- $ip, # Packed IP number of the host
- $timeout # Seconds after which connect times out
- ) = @_;
- my ($saddr); # Packed IP and Port
-
- $saddr = sockaddr_in($self->{"port_num"}, $ip);
-
- my $ret = 0; # Default to unreachable
-
- my $do_socket = sub {
- socket($self->{"fh"}, PF_INET, SOCK_STREAM, $self->{"proto_num"}) ||
- croak("tcp socket error - $!");
- if (defined $self->{"local_addr"} &&
- !CORE::bind($self->{"fh"}, sockaddr_in(0, $self->{"local_addr"}))) {
- croak("tcp bind error - $!");
- }
- if ($self->{'device'}) {
- setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
- or croak("error binding to device $self->{'device'} $!");
- }
- if ($self->{'tos'}) {
- setsockopt($self->{"fh"}, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
- or croak "error configuring tos to $self->{'tos'} $!";
- }
- };
- my $do_connect = sub {
- $self->{"ip"} = $ip;
- # ECONNREFUSED is 10061 on MSWin32. If we pass it as child error through $?,
- # we'll get (10061 & 255) = 77, so we cannot check it in the parent process.
- return ($ret = connect($self->{"fh"}, $saddr) || ($! == ECONNREFUSED && !$self->{"econnrefused"}));
- };
- my $do_connect_nb = sub {
- # Set O_NONBLOCK property on filehandle
- $self->socket_blocking_mode($self->{"fh"}, 0);
-
- # start the connection attempt
- if (!connect($self->{"fh"}, $saddr)) {
- if ($! == ECONNREFUSED) {
- $ret = 1 unless $self->{"econnrefused"};
- } elsif ($! != EINPROGRESS && ($^O ne 'MSWin32' || $! != EWOULDBLOCK)) {
- # EINPROGRESS is the expected error code after a connect()
- # on a non-blocking socket. But if the kernel immediately
- # determined that this connect() will never work,
- # Simply respond with "unreachable" status.
- # (This can occur on some platforms with errno
- # EHOSTUNREACH or ENETUNREACH.)
- return 0;
- } else {
- # Got the expected EINPROGRESS.
- # Just wait for connection completion...
- my ($wbits, $wout, $wexc);
- $wout = $wexc = $wbits = "";
- vec($wbits, $self->{"fh"}->fileno, 1) = 1;
-
- my $nfound = mselect(undef,
- ($wout = $wbits),
- ($^O eq 'MSWin32' ? ($wexc = $wbits) : undef),
- $timeout);
- warn("select: $!") unless defined $nfound;
-
- if ($nfound && vec($wout, $self->{"fh"}->fileno, 1)) {
- # the socket is ready for writing so the connection
- # attempt completed. test whether the connection
- # attempt was successful or not
-
- if (getpeername($self->{"fh"})) {
- # Connection established to remote host
- $ret = 1;
- } else {
- # TCP ACK will never come from this host
- # because there was an error connecting.
-
- # This should set $! to the correct error.
- my $char;
- sysread($self->{"fh"},$char,1);
- $! = ECONNREFUSED if ($! == EAGAIN && $^O =~ /cygwin/i);
-
- $ret = 1 if (!$self->{"econnrefused"}
- && $! == ECONNREFUSED);
- }
- } else {
- # the connection attempt timed out (or there were connect
- # errors on Windows)
- if ($^O =~ 'MSWin32') {
- # If the connect will fail on a non-blocking socket,
- # winsock reports ECONNREFUSED as an exception, and we
- # need to fetch the socket-level error code via getsockopt()
- # instead of using the thread-level error code that is in $!.
- if ($nfound && vec($wexc, $self->{"fh"}->fileno, 1)) {
- $! = unpack("i", getsockopt($self->{"fh"}, SOL_SOCKET,
- SO_ERROR));
- }
- }
- }
- }
- } else {
- # Connection established to remote host
- $ret = 1;
- }
-
- # Unset O_NONBLOCK property on filehandle
- $self->socket_blocking_mode($self->{"fh"}, 1);
- $self->{"ip"} = $ip;
- return $ret;
- };
-
- if ($syn_forking) {
- # Buggy Winsock API doesn't allow nonblocking connect.
- # Hence, if our OS is Windows, we need to create a separate
- # process to do the blocking connect attempt.
- # XXX Above comments are not true at least for Win2K, where
- # nonblocking connect works.
-
- $| = 1; # Clear buffer prior to fork to prevent duplicate flushing.
- $self->{'tcp_chld'} = fork;
- if (!$self->{'tcp_chld'}) {
- if (!defined $self->{'tcp_chld'}) {
- # Fork did not work
- warn "Fork error: $!";
- return 0;
- }
- &{ $do_socket }();
-
- # Try a slow blocking connect() call
- # and report the status to the parent.
- if ( &{ $do_connect }() ) {
- $self->{"fh"}->close();
- # No error
- exit 0;
- } else {
- # Pass the error status to the parent
- # Make sure that $! <= 255
- exit($! <= 255 ? $! : 255);
- }
- }
-
- &{ $do_socket }();
-
- my $patience = &time() + $timeout;
-
- my ($child, $child_errno);
- $? = 0; $child_errno = 0;
- # Wait up to the timeout
- # And clean off the zombie
- do {
- $child = waitpid($self->{'tcp_chld'}, &WNOHANG());
- $child_errno = $? >> 8;
- select(undef, undef, undef, 0.1);
- } while &time() < $patience && $child != $self->{'tcp_chld'};
-
- if ($child == $self->{'tcp_chld'}) {
- if ($self->{"proto"} eq "stream") {
- # We need the socket connected here, in parent
- # Should be safe to connect because the child finished
- # within the timeout
- &{ $do_connect }();
- }
- # $ret cannot be set by the child process
- $ret = !$child_errno;
- } else {
- # Time must have run out.
- # Put that choking client out of its misery
- kill "KILL", $self->{'tcp_chld'};
- # Clean off the zombie
- waitpid($self->{'tcp_chld'}, 0);
- $ret = 0;
- }
- delete $self->{'tcp_chld'};
- $! = $child_errno;
- } else {
- # Otherwise don't waste the resources to fork
-
- &{ $do_socket }();
-
- &{ $do_connect_nb }();
- }
-
- return $ret;
-}
-
-sub DESTROY {
- my $self = shift;
- if ($self->{'proto'} eq 'tcp' &&
- $self->{'tcp_chld'}) {
- # Put that choking client out of its misery
- kill "KILL", $self->{'tcp_chld'};
- # Clean off the zombie
- waitpid($self->{'tcp_chld'}, 0);
- }
-}
-
-# This writes the given string to the socket and then reads it
-# back. It returns 1 on success, 0 on failure.
-sub tcp_echo
-{
- my $self = shift;
- my $timeout = shift;
- my $pingstring = shift;
-
- my $ret = undef;
- my $time = &time();
- my $wrstr = $pingstring;
- my $rdstr = "";
-
- eval <<'EOM';
- do {
- my $rin = "";
- vec($rin, $self->{"fh"}->fileno(), 1) = 1;
-
- my $rout = undef;
- if($wrstr) {
- $rout = "";
- vec($rout, $self->{"fh"}->fileno(), 1) = 1;
- }
-
- if(mselect($rin, $rout, undef, ($time + $timeout) - &time())) {
-
- if($rout && vec($rout,$self->{"fh"}->fileno(),1)) {
- my $num = syswrite($self->{"fh"}, $wrstr, length $wrstr);
- if($num) {
- # If it was a partial write, update and try again.
- $wrstr = substr($wrstr,$num);
- } else {
- # There was an error.
- $ret = 0;
- }
- }
-
- if(vec($rin,$self->{"fh"}->fileno(),1)) {
- my $reply;
- if(sysread($self->{"fh"},$reply,length($pingstring)-length($rdstr))) {
- $rdstr .= $reply;
- $ret = 1 if $rdstr eq $pingstring;
- } else {
- # There was an error.
- $ret = 0;
- }
- }
-
- }
- } until &time() > ($time + $timeout) || defined($ret);
-EOM
-
- return $ret;
-}
-
-
-
-
-# Description: Perform a stream ping. If the tcp connection isn't
-# already open, it opens it. It then sends some data and waits for
-# a reply. It leaves the stream open on exit.
-
-sub ping_stream
-{
- my ($self,
- $ip, # Packed IP number of the host
- $timeout # Seconds after which ping times out
- ) = @_;
-
- # Open the stream if it's not already open
- if(!defined $self->{"fh"}->fileno()) {
- $self->tcp_connect($ip, $timeout) or return 0;
- }
-
- croak "tried to switch servers while stream pinging"
- if $self->{"ip"} ne $ip;
-
- return $self->tcp_echo($timeout, $pingstring);
-}
-
-# Description: opens the stream. You would do this if you want to
-# separate the overhead of opening the stream from the first ping.
-
-sub open
-{
- my ($self,
- $host, # Host or IP address
- $timeout # Seconds after which open times out
- ) = @_;
-
- my ($ip); # Packed IP number of the host
- $ip = inet_aton($host);
- $timeout = $self->{"timeout"} unless $timeout;
-
- if($self->{"proto"} eq "stream") {
- if(defined($self->{"fh"}->fileno())) {
- croak("socket is already open");
- } else {
- $self->tcp_connect($ip, $timeout);
- }
- }
-}
-
-
-# Description: Perform a udp echo ping. Construct a message of
-# at least the one-byte sequence number and any additional data bytes.
-# Send the message out and wait for a message to come back. If we
-# get a message, make sure all of its parts match. If they do, we are
-# done. Otherwise go back and wait for the message until we run out
-# of time. Return the result of our efforts.
-
-use constant UDP_FLAGS => 0; # Nothing special on send or recv
-sub ping_udp
-{
- my ($self,
- $ip, # Packed IP number of the host
- $timeout # Seconds after which ping times out
- ) = @_;
-
- my ($saddr, # sockaddr_in with port and ip
- $ret, # The return value
- $msg, # Message to be echoed
- $finish_time, # Time ping should be finished
- $flush, # Whether socket needs to be disconnected
- $connect, # Whether socket needs to be connected
- $done, # Set to 1 when we are done pinging
- $rbits, # Read bits, filehandles for reading
- $nfound, # Number of ready filehandles found
- $from_saddr, # sockaddr_in of sender
- $from_msg, # Characters echoed by $host
- $from_port, # Port message was echoed from
- $from_ip # Packed IP number of sender
- );
-
- $saddr = sockaddr_in($self->{"port_num"}, $ip);
- $self->{"seq"} = ($self->{"seq"} + 1) % 256; # Increment sequence
- $msg = chr($self->{"seq"}) . $self->{"data"}; # Add data if any
-
- if ($self->{"connected"}) {
- if ($self->{"connected"} ne $saddr) {
- # Still connected to wrong destination.
- # Need to flush out the old one.
- $flush = 1;
- }
- } else {
- # Not connected yet.
- # Need to connect() before send()
- $connect = 1;
- }
-
- # Have to connect() and send() instead of sendto()
- # in order to pick up on the ECONNREFUSED setting
- # from recv() or double send() errno as utilized in
- # the concept by rdw @ perlmonks. See:
- # http://perlmonks.thepen.com/42898.html
- if ($flush) {
- # Need to socket() again to flush the descriptor
- # This will disconnect from the old saddr.
- socket($self->{"fh"}, PF_INET, SOCK_DGRAM,
- $self->{"proto_num"});
- }
- # Connect the socket if it isn't already connected
- # to the right destination.
- if ($flush || $connect) {
- connect($self->{"fh"}, $saddr); # Tie destination to socket
- $self->{"connected"} = $saddr;
- }
- send($self->{"fh"}, $msg, UDP_FLAGS); # Send it
-
- $rbits = "";
- vec($rbits, $self->{"fh"}->fileno(), 1) = 1;
- $ret = 0; # Default to unreachable
- $done = 0;
- my $retrans = 0.01;
- my $factor = $self->{"retrans"};
- $finish_time = &time() + $timeout; # Ping needs to be done by then
- while (!$done && $timeout > 0)
- {
- if ($factor > 1)
- {
- $timeout = $retrans if $timeout > $retrans;
- $retrans*= $factor; # Exponential backoff
- }
- $nfound = mselect((my $rout=$rbits), undef, undef, $timeout); # Wait for response
- my $why = $!;
- $timeout = $finish_time - &time(); # Get remaining time
-
- if (!defined($nfound)) # Hmm, a strange error
- {
- $ret = undef;
- $done = 1;
- }
- elsif ($nfound) # A packet is waiting
- {
- $from_msg = "";
- $from_saddr = recv($self->{"fh"}, $from_msg, 1500, UDP_FLAGS);
- if (!$from_saddr) {
- # For example an unreachable host will make recv() fail.
- if (!$self->{"econnrefused"} &&
- ($! == ECONNREFUSED ||
- $! == ECONNRESET)) {
- # "Connection refused" means reachable
- # Good, continue
- $ret = 1;
- }
- $done = 1;
- } else {
- ($from_port, $from_ip) = sockaddr_in($from_saddr);
- if (!$source_verify ||
- (($from_ip eq $ip) && # Does the packet check out?
- ($from_port == $self->{"port_num"}) &&
- ($from_msg eq $msg)))
- {
- $ret = 1; # It's a winner
- $done = 1;
- }
- }
- }
- elsif ($timeout <= 0) # Oops, timed out
- {
- $done = 1;
- }
- else
- {
- # Send another in case the last one dropped
- if (send($self->{"fh"}, $msg, UDP_FLAGS)) {
- # Another send worked? The previous udp packet
- # must have gotten lost or is still in transit.
- # Hopefully this new packet will arrive safely.
- } else {
- if (!$self->{"econnrefused"} &&
- $! == ECONNREFUSED) {
- # "Connection refused" means reachable
- # Good, continue
- $ret = 1;
- }
- $done = 1;
- }
- }
- }
- return $ret;
-}
-
-# Description: Send a TCP SYN packet to host specified.
-sub ping_syn
-{
- my $self = shift;
- my $host = shift;
- my $ip = shift;
- my $start_time = shift;
- my $stop_time = shift;
-
- if ($syn_forking) {
- return $self->ping_syn_fork($host, $ip, $start_time, $stop_time);
- }
-
- my $fh = FileHandle->new();
- my $saddr = sockaddr_in($self->{"port_num"}, $ip);
-
- # Create TCP socket
- if (!socket ($fh, PF_INET, SOCK_STREAM, $self->{"proto_num"})) {
- croak("tcp socket error - $!");
- }
-
- if (defined $self->{"local_addr"} &&
- !CORE::bind($fh, sockaddr_in(0, $self->{"local_addr"}))) {
- croak("tcp bind error - $!");
- }
-
- if ($self->{'device'}) {
- setsockopt($fh, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
- or croak("error binding to device $self->{'device'} $!");
- }
- if ($self->{'tos'}) {
- setsockopt($fh, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
- or croak "error configuring tos to $self->{'tos'} $!";
- }
- # Set O_NONBLOCK property on filehandle
- $self->socket_blocking_mode($fh, 0);
-
- # Attempt the non-blocking connect
- # by just sending the TCP SYN packet
- if (connect($fh, $saddr)) {
- # Non-blocking, yet still connected?
- # Must have connected very quickly,
- # or else it wasn't very non-blocking.
- #warn "WARNING: Nonblocking connect connected anyway? ($^O)";
- } else {
- # Error occurred connecting.
- if ($! == EINPROGRESS || ($^O eq 'MSWin32' && $! == EWOULDBLOCK)) {
- # The connection is just still in progress.
- # This is the expected condition.
- } else {
- # Just save the error and continue on.
- # The ack() can check the status later.
- $self->{"bad"}->{$host} = $!;
- }
- }
-
- my $entry = [ $host, $ip, $fh, $start_time, $stop_time ];
- $self->{"syn"}->{$fh->fileno} = $entry;
- if ($self->{"stop_time"} < $stop_time) {
- $self->{"stop_time"} = $stop_time;
- }
- vec($self->{"wbits"}, $fh->fileno, 1) = 1;
-
- return 1;
-}
-
-sub ping_syn_fork {
- my ($self, $host, $ip, $start_time, $stop_time) = @_;
-
- # Buggy Winsock API doesn't allow nonblocking connect.
- # Hence, if our OS is Windows, we need to create a separate
- # process to do the blocking connect attempt.
- my $pid = fork();
- if (defined $pid) {
- if ($pid) {
- # Parent process
- my $entry = [ $host, $ip, $pid, $start_time, $stop_time ];
- $self->{"syn"}->{$pid} = $entry;
- if ($self->{"stop_time"} < $stop_time) {
- $self->{"stop_time"} = $stop_time;
- }
- } else {
- # Child process
- my $saddr = sockaddr_in($self->{"port_num"}, $ip);
-
- # Create TCP socket
- if (!socket ($self->{"fh"}, PF_INET, SOCK_STREAM, $self->{"proto_num"})) {
- croak("tcp socket error - $!");
- }
-
- if (defined $self->{"local_addr"} &&
- !CORE::bind($self->{"fh"}, sockaddr_in(0, $self->{"local_addr"}))) {
- croak("tcp bind error - $!");
- }
-
- if ($self->{'device'}) {
- setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
- or croak("error binding to device $self->{'device'} $!");
- }
- if ($self->{'tos'}) {
- setsockopt($self->{"fh"}, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
- or croak "error configuring tos to $self->{'tos'} $!";
- }
-
- $!=0;
- # Try to connect (could take a long time)
- connect($self->{"fh"}, $saddr);
- # Notify parent of connect error status
- my $err = $!+0;
- my $wrstr = "$$ $err";
- # Force to 16 chars including \n
- $wrstr .= " "x(15 - length $wrstr). "\n";
- syswrite($self->{"fork_wr"}, $wrstr, length $wrstr);
- exit;
- }
- } else {
- # fork() failed?
- die "fork: $!";
- }
- return 1;
-}
-
-# Description: Wait for TCP ACK from host specified
-# from ping_syn above. If no host is specified, wait
-# for TCP ACK from any of the hosts in the SYN queue.
-sub ack
-{
- my $self = shift;
-
- if ($self->{"proto"} eq "syn") {
- if ($syn_forking) {
- my @answer = $self->ack_unfork(shift);
- return wantarray ? @answer : $answer[0];
- }
- my $wbits = "";
- my $stop_time = 0;
- if (my $host = shift) {
- # Host passed as arg
- if (exists $self->{"bad"}->{$host}) {
- if (!$self->{"econnrefused"} &&
- $self->{"bad"}->{ $host } &&
- (($! = ECONNREFUSED)>0) &&
- $self->{"bad"}->{ $host } eq "$!") {
- # "Connection refused" means reachable
- # Good, continue
- } else {
- # ECONNREFUSED means no good
- return ();
- }
- }
- my $host_fd = undef;
- foreach my $fd (keys %{ $self->{"syn"} }) {
- my $entry = $self->{"syn"}->{$fd};
- if ($entry->[0] eq $host) {
- $host_fd = $fd;
- $stop_time = $entry->[4]
- || croak("Corrupted SYN entry for [$host]");
- last;
- }
- }
- croak("ack called on [$host] without calling ping first!")
- unless defined $host_fd;
- vec($wbits, $host_fd, 1) = 1;
- } else {
- # No $host passed so scan all hosts
- # Use the latest stop_time
- $stop_time = $self->{"stop_time"};
- # Use all the bits
- $wbits = $self->{"wbits"};
- }
-
- while ($wbits !~ /^\0*\z/) {
- my $timeout = $stop_time - &time();
- # Force a minimum of 10 ms timeout.
- $timeout = 0.01 if $timeout <= 0.01;
-
- my $winner_fd = undef;
- my $wout = $wbits;
- my $fd = 0;
- # Do "bad" fds from $wbits first
- while ($wout !~ /^\0*\z/) {
- if (vec($wout, $fd, 1)) {
- # Wipe it from future scanning.
- vec($wout, $fd, 1) = 0;
- if (my $entry = $self->{"syn"}->{$fd}) {
- if ($self->{"bad"}->{ $entry->[0] }) {
- $winner_fd = $fd;
- last;
- }
- }
- }
- $fd++;
- }
-
- if (defined($winner_fd) or my $nfound = mselect(undef, ($wout=$wbits), undef, $timeout)) {
- if (defined $winner_fd) {
- $fd = $winner_fd;
- } else {
- # Done waiting for one of the ACKs
- $fd = 0;
- # Determine which one
- while ($wout !~ /^\0*\z/ &&
- !vec($wout, $fd, 1)) {
- $fd++;
- }
- }
- if (my $entry = $self->{"syn"}->{$fd}) {
- # Wipe it from future scanning.
- delete $self->{"syn"}->{$fd};
- vec($self->{"wbits"}, $fd, 1) = 0;
- vec($wbits, $fd, 1) = 0;
- if (!$self->{"econnrefused"} &&
- $self->{"bad"}->{ $entry->[0] } &&
- (($! = ECONNREFUSED)>0) &&
- $self->{"bad"}->{ $entry->[0] } eq "$!") {
- # "Connection refused" means reachable
- # Good, continue
- } elsif (getpeername($entry->[2])) {
- # Connection established to remote host
- # Good, continue
- } else {
- # TCP ACK will never come from this host
- # because there was an error connecting.
-
- # This should set $! to the correct error.
- my $char;
- sysread($entry->[2],$char,1);
- # Store the excuse why the connection failed.
- $self->{"bad"}->{$entry->[0]} = $!;
- if (!$self->{"econnrefused"} &&
- (($! == ECONNREFUSED) ||
- ($! == EAGAIN && $^O =~ /cygwin/i))) {
- # "Connection refused" means reachable
- # Good, continue
- } else {
- # No good, try the next socket...
- next;
- }
- }
- # Everything passed okay, return the answer
- return wantarray ?
- ($entry->[0], &time() - $entry->[3], inet_ntoa($entry->[1]))
- : $entry->[0];
- } else {
- warn "Corrupted SYN entry: unknown fd [$fd] ready!";
- vec($wbits, $fd, 1) = 0;
- vec($self->{"wbits"}, $fd, 1) = 0;
- }
- } elsif (defined $nfound) {
- # Timed out waiting for ACK
- foreach my $fd (keys %{ $self->{"syn"} }) {
- if (vec($wbits, $fd, 1)) {
- my $entry = $self->{"syn"}->{$fd};
- $self->{"bad"}->{$entry->[0]} = "Timed out";
- vec($wbits, $fd, 1) = 0;
- vec($self->{"wbits"}, $fd, 1) = 0;
- delete $self->{"syn"}->{$fd};
- }
- }
- } else {
- # Weird error occurred with select()
- warn("select: $!");
- $self->{"syn"} = {};
- $wbits = "";
- }
- }
- }
- return ();
-}
-
-sub ack_unfork {
- my ($self,$host) = @_;
- my $stop_time = $self->{"stop_time"};
- if ($host) {
- # Host passed as arg
- if (my $entry = $self->{"good"}->{$host}) {
- delete $self->{"good"}->{$host};
- return ($entry->[0], &time() - $entry->[3], inet_ntoa($entry->[1]));
- }
- }
-
- my $rbits = "";
- my $timeout;
-
- if (keys %{ $self->{"syn"} }) {
- # Scan all hosts that are left
- vec($rbits, fileno($self->{"fork_rd"}), 1) = 1;
- $timeout = $stop_time - &time();
- # Force a minimum of 10 ms timeout.
- $timeout = 0.01 if $timeout < 0.01;
- } else {
- # No hosts left to wait for
- $timeout = 0;
- }
-
- if ($timeout > 0) {
- my $nfound;
- while ( keys %{ $self->{"syn"} } and
- $nfound = mselect((my $rout=$rbits), undef, undef, $timeout)) {
- # Done waiting for one of the ACKs
- if (!sysread($self->{"fork_rd"}, $_, 16)) {
- # Socket closed, which means all children are done.
- return ();
- }
- my ($pid, $how) = split;
- if ($pid) {
- # Flush the zombie
- waitpid($pid, 0);
- if (my $entry = $self->{"syn"}->{$pid}) {
- # Connection attempt to remote host is done
- delete $self->{"syn"}->{$pid};
- if (!$how || # If there was no error connecting
- (!$self->{"econnrefused"} &&
- $how == ECONNREFUSED)) { # "Connection refused" means reachable
- if ($host && $entry->[0] ne $host) {
- # A good connection, but not the host we need.
- # Move it from the "syn" hash to the "good" hash.
- $self->{"good"}->{$entry->[0]} = $entry;
- # And wait for the next winner
- next;
- }
- return ($entry->[0], &time() - $entry->[3], inet_ntoa($entry->[1]));
- }
- } else {
- # Should never happen
- die "Unknown ping from pid [$pid]";
- }
- } else {
- die "Empty response from status socket?";
- }
- }
- if (defined $nfound) {
- # Timed out waiting for ACK status
- } else {
- # Weird error occurred with select()
- warn("select: $!");
- }
- }
- if (my @synners = keys %{ $self->{"syn"} }) {
- # Kill all the synners
- kill 9, @synners;
- foreach my $pid (@synners) {
- # Wait for the deaths to finish
- # Then flush off the zombie
- waitpid($pid, 0);
- }
- }
- $self->{"syn"} = {};
- return ();
-}
-
-# Description: Tell why the ack() failed
-sub nack {
- my $self = shift;
- my $host = shift || croak('Usage> nack($failed_ack_host)');
- return $self->{"bad"}->{$host} || undef;
-}
-
-# Description: Close the connection.
-
-sub close
-{
- my ($self) = @_;
-
- if ($self->{"proto"} eq "syn") {
- delete $self->{"syn"};
- } elsif ($self->{"proto"} eq "tcp") {
- # The connection will already be closed
- } else {
- $self->{"fh"}->close();
- }
-}
-
-sub port_number {
- my $self = shift;
- if(@_) {
- $self->{port_num} = shift @_;
- $self->service_check(1);
- }
- return $self->{port_num};
-}
-
-
-1;
-__END__
-
-=head1 NAME
-
-Net::Ping - check a remote host for reachability
-
-=head1 SYNOPSIS
-
- use Net::Ping;
-
- $p = Net::Ping->new();
- print "$host is alive.\n" if $p->ping($host);
- $p->close();
-
- $p = Net::Ping->new("icmp");
- $p->bind($my_addr); # Specify source interface of pings
- foreach $host (@host_array)
- {
- print "$host is ";
- print "NOT " unless $p->ping($host, 2);
- print "reachable.\n";
- sleep(1);
- }
- $p->close();
-
- $p = Net::Ping->new("tcp", 2);
- # Try connecting to the www port instead of the echo port
- $p->port_number(getservbyname("http", "tcp"));
- while ($stop_time > time())
- {
- print "$host not reachable ", scalar(localtime()), "\n"
- unless $p->ping($host);
- sleep(300);
- }
- undef($p);
-
- # Like tcp protocol, but with many hosts
- $p = Net::Ping->new("syn");
- $p->port_number(getservbyname("http", "tcp"));
- foreach $host (@host_array) {
- $p->ping($host);
- }
- while (($host,$rtt,$ip) = $p->ack) {
- print "HOST: $host [$ip] ACKed in $rtt seconds.\n";
- }
-
- # High precision syntax (requires Time::HiRes)
- $p = Net::Ping->new();
- $p->hires();
- ($ret, $duration, $ip) = $p->ping($host, 5.5);
- printf("$host [ip: $ip] is alive (packet return time: %.2f ms)\n", 1000 * $duration)
- if $ret;
- $p->close();
-
- # For backward compatibility
- print "$host is alive.\n" if pingecho($host);
-
-=head1 DESCRIPTION
-
-This module contains methods to test the reachability of remote
-hosts on a network. A ping object is first created with optional
-parameters, a variable number of hosts may be pinged multiple
-times and then the connection is closed.
-
-You may choose one of six different protocols to use for the
-ping. The "tcp" protocol is the default. Note that a live remote host
-may still fail to be pingable by one or more of these protocols. For
-example, www.microsoft.com is generally alive but not "icmp" pingable.
-
-With the "tcp" protocol the ping() method attempts to establish a
-connection to the remote host's echo port. If the connection is
-successfully established, the remote host is considered reachable. No
-data is actually echoed. This protocol does not require any special
-privileges but has higher overhead than the "udp" and "icmp" protocols.
-
-Specifying the "udp" protocol causes the ping() method to send a udp
-packet to the remote host's echo port. If the echoed packet is
-received from the remote host and the received packet contains the
-same data as the packet that was sent, the remote host is considered
-reachable. This protocol does not require any special privileges.
-It should be borne in mind that, for a udp ping, a host
-will be reported as unreachable if it is not running the
-appropriate echo service. For Unix-like systems see L<inetd(8)>
-for more information.
-
-If the "icmp" protocol is specified, the ping() method sends an icmp
-echo message to the remote host, which is what the UNIX ping program
-does. If the echoed message is received from the remote host and
-the echoed information is correct, the remote host is considered
-reachable. Specifying the "icmp" protocol requires that the program
-be run as root or that the program be setuid to root.
-
-If the "external" protocol is specified, the ping() method attempts to
-use the C<Net::Ping::External> module to ping the remote host.
-C<Net::Ping::External> interfaces with your system's default C<ping>
-utility to perform the ping, and generally produces relatively
-accurate results. If C<Net::Ping::External> if not installed on your
-system, specifying the "external" protocol will result in an error.
-
-If the "syn" protocol is specified, the ping() method will only
-send a TCP SYN packet to the remote host then immediately return.
-If the syn packet was sent successfully, it will return a true value,
-otherwise it will return false. NOTE: Unlike the other protocols,
-the return value does NOT determine if the remote host is alive or
-not since the full TCP three-way handshake may not have completed
-yet. The remote host is only considered reachable if it receives
-a TCP ACK within the timeout specified. To begin waiting for the
-ACK packets, use the ack() method as explained below. Use the
-"syn" protocol instead the "tcp" protocol to determine reachability
-of multiple destinations simultaneously by sending parallel TCP
-SYN packets. It will not block while testing each remote host.
-demo/fping is provided in this distribution to demonstrate the
-"syn" protocol as an example.
-This protocol does not require any special privileges.
-
-=head2 Functions
-
-=over 4
-
-=item Net::Ping->new([$proto [, $def_timeout [, $bytes [, $device [, $tos ]]]]]);
-
-Create a new ping object. All of the parameters are optional. $proto
-specifies the protocol to use when doing a ping. The current choices
-are "tcp", "udp", "icmp", "stream", "syn", or "external".
-The default is "tcp".
-
-If a default timeout ($def_timeout) in seconds is provided, it is used
-when a timeout is not given to the ping() method (below). The timeout
-must be greater than 0 and the default, if not specified, is 5 seconds.
-
-If the number of data bytes ($bytes) is given, that many data bytes
-are included in the ping packet sent to the remote host. The number of
-data bytes is ignored if the protocol is "tcp". The minimum (and
-default) number of data bytes is 1 if the protocol is "udp" and 0
-otherwise. The maximum number of data bytes that can be specified is
-1024.
-
-If $device is given, this device is used to bind the source endpoint
-before sending the ping packet. I believe this only works with
-superuser privileges and with udp and icmp protocols at this time.
-
-If $tos is given, this ToS is configured into the socket.
-
-=item $p->ping($host [, $timeout]);
-
-Ping the remote host and wait for a response. $host can be either the
-hostname or the IP number of the remote host. The optional timeout
-must be greater than 0 seconds and defaults to whatever was specified
-when the ping object was created. Returns a success flag. If the
-hostname cannot be found or there is a problem with the IP number, the
-success flag returned will be undef. Otherwise, the success flag will
-be 1 if the host is reachable and 0 if it is not. For most practical
-purposes, undef and 0 and can be treated as the same case. In array
-context, the elapsed time as well as the string form of the ip the
-host resolved to are also returned. The elapsed time value will
-be a float, as retuned by the Time::HiRes::time() function, if hires()
-has been previously called, otherwise it is returned as an integer.
-
-=item $p->source_verify( { 0 | 1 } );
-
-Allows source endpoint verification to be enabled or disabled.
-This is useful for those remote destinations with multiples
-interfaces where the response may not originate from the same
-endpoint that the original destination endpoint was sent to.
-This only affects udp and icmp protocol pings.
-
-This is enabled by default.
-
-=item $p->service_check( { 0 | 1 } );
-
-Set whether or not the connect behavior should enforce
-remote service availability as well as reachability. Normally,
-if the remote server reported ECONNREFUSED, it must have been
-reachable because of the status packet that it reported.
-With this option enabled, the full three-way tcp handshake
-must have been established successfully before it will
-claim it is reachable. NOTE: It still does nothing more
-than connect and disconnect. It does not speak any protocol
-(i.e., HTTP or FTP) to ensure the remote server is sane in
-any way. The remote server CPU could be grinding to a halt
-and unresponsive to any clients connecting, but if the kernel
-throws the ACK packet, it is considered alive anyway. To
-really determine if the server is responding well would be
-application specific and is beyond the scope of Net::Ping.
-For udp protocol, enabling this option demands that the
-remote server replies with the same udp data that it was sent
-as defined by the udp echo service.
-
-This affects the "udp", "tcp", and "syn" protocols.
-
-This is disabled by default.
-
-=item $p->tcp_service_check( { 0 | 1 } );
-
-Deprecated method, but does the same as service_check() method.
-
-=item $p->hires( { 0 | 1 } );
-
-Causes this module to use Time::HiRes module, allowing milliseconds
-to be returned by subsequent calls to ping().
-
-This is disabled by default.
-
-=item $p->bind($local_addr);
-
-Sets the source address from which pings will be sent. This must be
-the address of one of the interfaces on the local host. $local_addr
-may be specified as a hostname or as a text IP address such as
-"192.168.1.1".
-
-If the protocol is set to "tcp", this method may be called any
-number of times, and each call to the ping() method (below) will use
-the most recent $local_addr. If the protocol is "icmp" or "udp",
-then bind() must be called at most once per object, and (if it is
-called at all) must be called before the first call to ping() for that
-object.
-
-=item $p->open($host);
-
-When you are using the "stream" protocol, this call pre-opens the
-tcp socket. It's only necessary to do this if you want to
-provide a different timeout when creating the connection, or
-remove the overhead of establishing the connection from the
-first ping. If you don't call C<open()>, the connection is
-automatically opened the first time C<ping()> is called.
-This call simply does nothing if you are using any protocol other
-than stream.
-
-=item $p->ack( [ $host ] );
-
-When using the "syn" protocol, use this method to determine
-the reachability of the remote host. This method is meant
-to be called up to as many times as ping() was called. Each
-call returns the host (as passed to ping()) that came back
-with the TCP ACK. The order in which the hosts are returned
-may not necessarily be the same order in which they were
-SYN queued using the ping() method. If the timeout is
-reached before the TCP ACK is received, or if the remote
-host is not listening on the port attempted, then the TCP
-connection will not be established and ack() will return
-undef. In list context, the host, the ack time, and the
-dotted ip string will be returned instead of just the host.
-If the optional $host argument is specified, the return
-value will be pertaining to that host only.
-This call simply does nothing if you are using any protocol
-other than syn.
-
-=item $p->nack( $failed_ack_host );
-
-The reason that host $failed_ack_host did not receive a
-valid ACK. Useful to find out why when ack( $fail_ack_host )
-returns a false value.
-
-=item $p->close();
-
-Close the network connection for this ping object. The network
-connection is also closed by "undef $p". The network connection is
-automatically closed if the ping object goes out of scope (e.g. $p is
-local to a subroutine and you leave the subroutine).
-
-=item $p->port_number([$port_number])
-
-When called with a port number, the port number used to ping is set to
-$port_number rather than using the echo port. It also has the effect
-of calling C<$p-E<gt>service_check(1)> causing a ping to return a successful
-response only if that specific port is accessible. This function returns
-the value of the port that C<ping()> will connect to.
-
-=item pingecho($host [, $timeout]);
-
-To provide backward compatibility with the previous version of
-Net::Ping, a pingecho() subroutine is available with the same
-functionality as before. pingecho() uses the tcp protocol. The
-return values and parameters are the same as described for the ping()
-method. This subroutine is obsolete and may be removed in a future
-version of Net::Ping.
-
-=back
-
-=head1 NOTES
-
-There will be less network overhead (and some efficiency in your
-program) if you specify either the udp or the icmp protocol. The tcp
-protocol will generate 2.5 times or more traffic for each ping than
-either udp or icmp. If many hosts are pinged frequently, you may wish
-to implement a small wait (e.g. 25ms or more) between each ping to
-avoid flooding your network with packets.
-
-The icmp protocol requires that the program be run as root or that it
-be setuid to root. The other protocols do not require special
-privileges, but not all network devices implement tcp or udp echo.
-
-Local hosts should normally respond to pings within milliseconds.
-However, on a very congested network it may take up to 3 seconds or
-longer to receive an echo packet from the remote host. If the timeout
-is set too low under these conditions, it will appear that the remote
-host is not reachable (which is almost the truth).
-
-Reachability doesn't necessarily mean that the remote host is actually
-functioning beyond its ability to echo packets. tcp is slightly better
-at indicating the health of a system than icmp because it uses more
-of the networking stack to respond.
-
-Because of a lack of anything better, this module uses its own
-routines to pack and unpack ICMP packets. It would be better for a
-separate module to be written which understands all of the different
-kinds of ICMP packets.
-
-=head1 INSTALL
-
-The latest source tree is available via cvs:
-
- cvs -z3 -q -d :pserver:anonymous@cvs.roobik.com.:/usr/local/cvsroot/freeware checkout Net-Ping
- cd Net-Ping
-
-The tarball can be created as follows:
-
- perl Makefile.PL ; make ; make dist
-
-The latest Net::Ping release can be found at CPAN:
-
- $CPAN/modules/by-module/Net/
-
-1) Extract the tarball
-
- gtar -zxvf Net-Ping-xxxx.tar.gz
- cd Net-Ping-xxxx
-
-2) Build:
-
- make realclean
- perl Makefile.PL
- make
- make test
-
-3) Install
-
- make install
-
-Or install it RPM Style:
-
- rpm -ta SOURCES/Net-Ping-xxxx.tar.gz
-
- rpm -ih RPMS/noarch/perl-Net-Ping-xxxx.rpm
-
-=head1 BUGS
-
-For a list of known issues, visit:
-
-https://rt.cpan.org/NoAuth/Bugs.html?Dist=Net-Ping
-
-To report a new bug, visit:
-
-https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net-Ping
-
-=head1 AUTHORS
-
- Current maintainer:
- bbb@cpan.org (Rob Brown)
-
- External protocol:
- colinm@cpan.org (Colin McMillen)
-
- Stream protocol:
- bronson@trestle.com (Scott Bronson)
-
- Original pingecho():
- karrer@bernina.ethz.ch (Andreas Karrer)
- pmarquess@bfsec.bt.co.uk (Paul Marquess)
-
- Original Net::Ping author:
- mose@ns.ccsn.edu (Russell Mosemann)
-
-=head1 COPYRIGHT
-
-Copyright (c) 2002-2003, Rob Brown. All rights reserved.
-
-Copyright (c) 2001, Colin McMillen. All rights reserved.
-
-This program is free software; you may redistribute it and/or
-modify it under the same terms as Perl itself.
-
-$Id: Ping.pm,v 1.86 2003/06/27 21:31:07 rob Exp $
-
-=cut
diff --git a/Master/tlpkg/tlperl/lib/Net/SMTP.pm b/Master/tlpkg/tlperl/lib/Net/SMTP.pm
deleted file mode 100755
index a28496d6886..00000000000
--- a/Master/tlpkg/tlperl/lib/Net/SMTP.pm
+++ /dev/null
@@ -1,867 +0,0 @@
-# Net::SMTP.pm
-#
-# Copyright (c) 1995-2004 Graham Barr <gbarr@pobox.com>. All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-
-package Net::SMTP;
-
-require 5.001;
-
-use strict;
-use vars qw($VERSION @ISA);
-use Socket 1.3;
-use Carp;
-use IO::Socket;
-use Net::Cmd;
-use Net::Config;
-
-$VERSION = "2.31";
-
-@ISA = qw(Net::Cmd IO::Socket::INET);
-
-
-sub new {
- my $self = shift;
- my $type = ref($self) || $self;
- my ($host, %arg);
- if (@_ % 2) {
- $host = shift;
- %arg = @_;
- }
- else {
- %arg = @_;
- $host = delete $arg{Host};
- }
- my $hosts = defined $host ? $host : $NetConfig{smtp_hosts};
- my $obj;
-
- my $h;
- foreach $h (@{ref($hosts) ? $hosts : [$hosts]}) {
- $obj = $type->SUPER::new(
- PeerAddr => ($host = $h),
- PeerPort => $arg{Port} || 'smtp(25)',
- LocalAddr => $arg{LocalAddr},
- LocalPort => $arg{LocalPort},
- Proto => 'tcp',
- Timeout => defined $arg{Timeout}
- ? $arg{Timeout}
- : 120
- )
- and last;
- }
-
- return undef
- unless defined $obj;
-
- $obj->autoflush(1);
-
- $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
-
- unless ($obj->response() == CMD_OK) {
- $obj->close();
- return undef;
- }
-
- ${*$obj}{'net_smtp_exact_addr'} = $arg{ExactAddresses};
- ${*$obj}{'net_smtp_host'} = $host;
-
- (${*$obj}{'net_smtp_banner'}) = $obj->message;
- (${*$obj}{'net_smtp_domain'}) = $obj->message =~ /\A\s*(\S+)/;
-
- unless ($obj->hello($arg{Hello} || "")) {
- $obj->close();
- return undef;
- }
-
- $obj;
-}
-
-
-sub host {
- my $me = shift;
- ${*$me}{'net_smtp_host'};
-}
-
-##
-## User interface methods
-##
-
-
-sub banner {
- my $me = shift;
-
- return ${*$me}{'net_smtp_banner'} || undef;
-}
-
-
-sub domain {
- my $me = shift;
-
- return ${*$me}{'net_smtp_domain'} || undef;
-}
-
-
-sub etrn {
- my $self = shift;
- defined($self->supports('ETRN', 500, ["Command unknown: 'ETRN'"]))
- && $self->_ETRN(@_);
-}
-
-
-sub auth {
- my ($self, $username, $password) = @_;
-
- eval {
- require MIME::Base64;
- require Authen::SASL;
- } or $self->set_status(500, ["Need MIME::Base64 and Authen::SASL todo auth"]), return 0;
-
- my $mechanisms = $self->supports('AUTH', 500, ["Command unknown: 'AUTH'"]);
- return unless defined $mechanisms;
-
- my $sasl;
-
- if (ref($username) and UNIVERSAL::isa($username, 'Authen::SASL')) {
- $sasl = $username;
- $sasl->mechanism($mechanisms);
- }
- else {
- die "auth(username, password)" if not length $username;
- $sasl = Authen::SASL->new(
- mechanism => $mechanisms,
- callback => {
- user => $username,
- pass => $password,
- authname => $username,
- }
- );
- }
-
- # We should probably allow the user to pass the host, but I don't
- # currently know and SASL mechanisms that are used by smtp that need it
- my $client = $sasl->client_new('smtp', ${*$self}{'net_smtp_host'}, 0);
- my $str = $client->client_start;
-
- # We dont support sasl mechanisms that encrypt the socket traffic.
- # todo that we would really need to change the ISA hierarchy
- # so we dont inherit from IO::Socket, but instead hold it in an attribute
-
- my @cmd = ("AUTH", $client->mechanism);
- my $code;
-
- push @cmd, MIME::Base64::encode_base64($str, '')
- if defined $str and length $str;
-
- while (($code = $self->command(@cmd)->response()) == CMD_MORE) {
- @cmd = (
- MIME::Base64::encode_base64(
- $client->client_step(MIME::Base64::decode_base64(($self->message)[0])), ''
- )
- );
- }
-
- $code == CMD_OK;
-}
-
-
-sub hello {
- my $me = shift;
- my $domain = shift || "localhost.localdomain";
- my $ok = $me->_EHLO($domain);
- my @msg = $me->message;
-
- if ($ok) {
- my $h = ${*$me}{'net_smtp_esmtp'} = {};
- my $ln;
- foreach $ln (@msg) {
- $h->{uc $1} = $2
- if $ln =~ /(\w+)\b[= \t]*([^\n]*)/;
- }
- }
- elsif ($me->status == CMD_ERROR) {
- @msg = $me->message
- if $ok = $me->_HELO($domain);
- }
-
- return undef unless $ok;
-
- $msg[0] =~ /\A\s*(\S+)/;
- return ($1 || " ");
-}
-
-
-sub supports {
- my $self = shift;
- my $cmd = uc shift;
- return ${*$self}{'net_smtp_esmtp'}->{$cmd}
- if exists ${*$self}{'net_smtp_esmtp'}->{$cmd};
- $self->set_status(@_)
- if @_;
- return;
-}
-
-
-sub _addr {
- my $self = shift;
- my $addr = shift;
- $addr = "" unless defined $addr;
-
- if (${*$self}{'net_smtp_exact_addr'}) {
- return $1 if $addr =~ /^\s*(<.*>)\s*$/s;
- }
- else {
- return $1 if $addr =~ /(<[^>]*>)/;
- $addr =~ s/^\s+|\s+$//sg;
- }
-
- "<$addr>";
-}
-
-
-sub mail {
- my $me = shift;
- my $addr = _addr($me, shift);
- my $opts = "";
-
- if (@_) {
- my %opt = @_;
- my ($k, $v);
-
- if (exists ${*$me}{'net_smtp_esmtp'}) {
- my $esmtp = ${*$me}{'net_smtp_esmtp'};
-
- if (defined($v = delete $opt{Size})) {
- if (exists $esmtp->{SIZE}) {
- $opts .= sprintf " SIZE=%d", $v + 0;
- }
- else {
- carp 'Net::SMTP::mail: SIZE option not supported by host';
- }
- }
-
- if (defined($v = delete $opt{Return})) {
- if (exists $esmtp->{DSN}) {
- $opts .= " RET=" . ((uc($v) eq "FULL") ? "FULL" : "HDRS");
- }
- else {
- carp 'Net::SMTP::mail: DSN option not supported by host';
- }
- }
-
- if (defined($v = delete $opt{Bits})) {
- if ($v eq "8") {
- if (exists $esmtp->{'8BITMIME'}) {
- $opts .= " BODY=8BITMIME";
- }
- else {
- carp 'Net::SMTP::mail: 8BITMIME option not supported by host';
- }
- }
- elsif ($v eq "binary") {
- if (exists $esmtp->{'BINARYMIME'} && exists $esmtp->{'CHUNKING'}) {
- $opts .= " BODY=BINARYMIME";
- ${*$me}{'net_smtp_chunking'} = 1;
- }
- else {
- carp 'Net::SMTP::mail: BINARYMIME option not supported by host';
- }
- }
- elsif (exists $esmtp->{'8BITMIME'} or exists $esmtp->{'BINARYMIME'}) {
- $opts .= " BODY=7BIT";
- }
- else {
- carp 'Net::SMTP::mail: 8BITMIME and BINARYMIME options not supported by host';
- }
- }
-
- if (defined($v = delete $opt{Transaction})) {
- if (exists $esmtp->{CHECKPOINT}) {
- $opts .= " TRANSID=" . _addr($me, $v);
- }
- else {
- carp 'Net::SMTP::mail: CHECKPOINT option not supported by host';
- }
- }
-
- if (defined($v = delete $opt{Envelope})) {
- if (exists $esmtp->{DSN}) {
- $v =~ s/([^\041-\176]|=|\+)/sprintf "+%02x", ord($1)/sge;
- $opts .= " ENVID=$v";
- }
- else {
- carp 'Net::SMTP::mail: DSN option not supported by host';
- }
- }
-
- if (defined($v = delete $opt{ENVID})) {
-
- # expected to be in a format as required by RFC 3461, xtext-encoded
- if (exists $esmtp->{DSN}) {
- $opts .= " ENVID=$v";
- }
- else {
- carp 'Net::SMTP::mail: DSN option not supported by host';
- }
- }
-
- if (defined($v = delete $opt{AUTH})) {
-
- # expected to be in a format as required by RFC 2554,
- # rfc2821-quoted and xtext-encoded, or <>
- if (exists $esmtp->{AUTH}) {
- $v = '<>' if !defined($v) || $v eq '';
- $opts .= " AUTH=$v";
- }
- else {
- carp 'Net::SMTP::mail: AUTH option not supported by host';
- }
- }
-
- if (defined($v = delete $opt{XVERP})) {
- if (exists $esmtp->{'XVERP'}) {
- $opts .= " XVERP";
- }
- else {
- carp 'Net::SMTP::mail: XVERP option not supported by host';
- }
- }
-
- carp 'Net::SMTP::recipient: unknown option(s) ' . join(" ", keys %opt) . ' - ignored'
- if scalar keys %opt;
- }
- else {
- carp 'Net::SMTP::mail: ESMTP not supported by host - options discarded :-(';
- }
- }
-
- $me->_MAIL("FROM:" . $addr . $opts);
-}
-
-
-sub send { my $me = shift; $me->_SEND("FROM:" . _addr($me, $_[0])) }
-sub send_or_mail { my $me = shift; $me->_SOML("FROM:" . _addr($me, $_[0])) }
-sub send_and_mail { my $me = shift; $me->_SAML("FROM:" . _addr($me, $_[0])) }
-
-
-sub reset {
- my $me = shift;
-
- $me->dataend()
- if (exists ${*$me}{'net_smtp_lastch'});
-
- $me->_RSET();
-}
-
-
-sub recipient {
- my $smtp = shift;
- my $opts = "";
- my $skip_bad = 0;
-
- if (@_ && ref($_[-1])) {
- my %opt = %{pop(@_)};
- my $v;
-
- $skip_bad = delete $opt{'SkipBad'};
-
- if (exists ${*$smtp}{'net_smtp_esmtp'}) {
- my $esmtp = ${*$smtp}{'net_smtp_esmtp'};
-
- if (defined($v = delete $opt{Notify})) {
- if (exists $esmtp->{DSN}) {
- $opts .= " NOTIFY=" . join(",", map { uc $_ } @$v);
- }
- else {
- carp 'Net::SMTP::recipient: DSN option not supported by host';
- }
- }
-
- if (defined($v = delete $opt{ORcpt})) {
- if (exists $esmtp->{DSN}) {
- $opts .= " ORCPT=" . $v;
- }
- else {
- carp 'Net::SMTP::recipient: DSN option not supported by host';
- }
- }
-
- carp 'Net::SMTP::recipient: unknown option(s) ' . join(" ", keys %opt) . ' - ignored'
- if scalar keys %opt;
- }
- elsif (%opt) {
- carp 'Net::SMTP::recipient: ESMTP not supported by host - options discarded :-(';
- }
- }
-
- my @ok;
- my $addr;
- foreach $addr (@_) {
- if ($smtp->_RCPT("TO:" . _addr($smtp, $addr) . $opts)) {
- push(@ok, $addr) if $skip_bad;
- }
- elsif (!$skip_bad) {
- return 0;
- }
- }
-
- return $skip_bad ? @ok : 1;
-}
-
-BEGIN {
- *to = \&recipient;
- *cc = \&recipient;
- *bcc = \&recipient;
-}
-
-
-sub data {
- my $me = shift;
-
- if (exists ${*$me}{'net_smtp_chunking'}) {
- carp 'Net::SMTP::data: CHUNKING extension in use, must call bdat instead';
- }
- else {
- my $ok = $me->_DATA() && $me->datasend(@_);
-
- $ok && @_
- ? $me->dataend
- : $ok;
- }
-}
-
-
-sub bdat {
- my $me = shift;
-
- if (exists ${*$me}{'net_smtp_chunking'}) {
- my $data = shift;
-
- $me->_BDAT(length $data)
- && $me->rawdatasend($data)
- && $me->response() == CMD_OK;
- }
- else {
- carp 'Net::SMTP::bdat: CHUNKING extension is not in use, call data instead';
- }
-}
-
-
-sub bdatlast {
- my $me = shift;
-
- if (exists ${*$me}{'net_smtp_chunking'}) {
- my $data = shift;
-
- $me->_BDAT(length $data, "LAST")
- && $me->rawdatasend($data)
- && $me->response() == CMD_OK;
- }
- else {
- carp 'Net::SMTP::bdat: CHUNKING extension is not in use, call data instead';
- }
-}
-
-
-sub datafh {
- my $me = shift;
- return unless $me->_DATA();
- return $me->tied_fh;
-}
-
-
-sub expand {
- my $me = shift;
-
- $me->_EXPN(@_)
- ? ($me->message)
- : ();
-}
-
-
-sub verify { shift->_VRFY(@_) }
-
-
-sub help {
- my $me = shift;
-
- $me->_HELP(@_)
- ? scalar $me->message
- : undef;
-}
-
-
-sub quit {
- my $me = shift;
-
- $me->_QUIT;
- $me->close;
-}
-
-
-sub DESTROY {
-
- # ignore
-}
-
-##
-## RFC821 commands
-##
-
-
-sub _EHLO { shift->command("EHLO", @_)->response() == CMD_OK }
-sub _HELO { shift->command("HELO", @_)->response() == CMD_OK }
-sub _MAIL { shift->command("MAIL", @_)->response() == CMD_OK }
-sub _RCPT { shift->command("RCPT", @_)->response() == CMD_OK }
-sub _SEND { shift->command("SEND", @_)->response() == CMD_OK }
-sub _SAML { shift->command("SAML", @_)->response() == CMD_OK }
-sub _SOML { shift->command("SOML", @_)->response() == CMD_OK }
-sub _VRFY { shift->command("VRFY", @_)->response() == CMD_OK }
-sub _EXPN { shift->command("EXPN", @_)->response() == CMD_OK }
-sub _HELP { shift->command("HELP", @_)->response() == CMD_OK }
-sub _RSET { shift->command("RSET")->response() == CMD_OK }
-sub _NOOP { shift->command("NOOP")->response() == CMD_OK }
-sub _QUIT { shift->command("QUIT")->response() == CMD_OK }
-sub _DATA { shift->command("DATA")->response() == CMD_MORE }
-sub _BDAT { shift->command("BDAT", @_) }
-sub _TURN { shift->unsupported(@_); }
-sub _ETRN { shift->command("ETRN", @_)->response() == CMD_OK }
-sub _AUTH { shift->command("AUTH", @_)->response() == CMD_OK }
-
-1;
-
-__END__
-
-=head1 NAME
-
-Net::SMTP - Simple Mail Transfer Protocol Client
-
-=head1 SYNOPSIS
-
- use Net::SMTP;
-
- # Constructors
- $smtp = Net::SMTP->new('mailhost');
- $smtp = Net::SMTP->new('mailhost', Timeout => 60);
-
-=head1 DESCRIPTION
-
-This module implements a client interface to the SMTP and ESMTP
-protocol, enabling a perl5 application to talk to SMTP servers. This
-documentation assumes that you are familiar with the concepts of the
-SMTP protocol described in RFC821.
-
-A new Net::SMTP object must be created with the I<new> method. Once
-this has been done, all SMTP commands are accessed through this object.
-
-The Net::SMTP class is a subclass of Net::Cmd and IO::Socket::INET.
-
-=head1 EXAMPLES
-
-This example prints the mail domain name of the SMTP server known as mailhost:
-
- #!/usr/local/bin/perl -w
-
- use Net::SMTP;
-
- $smtp = Net::SMTP->new('mailhost');
- print $smtp->domain,"\n";
- $smtp->quit;
-
-This example sends a small message to the postmaster at the SMTP server
-known as mailhost:
-
- #!/usr/local/bin/perl -w
-
- use Net::SMTP;
-
- $smtp = Net::SMTP->new('mailhost');
-
- $smtp->mail($ENV{USER});
- $smtp->to('postmaster');
-
- $smtp->data();
- $smtp->datasend("To: postmaster\n");
- $smtp->datasend("\n");
- $smtp->datasend("A simple test message\n");
- $smtp->dataend();
-
- $smtp->quit;
-
-=head1 CONSTRUCTOR
-
-=over 4
-
-=item new ( [ HOST ] [, OPTIONS ] )
-
-This is the constructor for a new Net::SMTP object. C<HOST> is the
-name of the remote host to which an SMTP connection is required.
-
-C<HOST> is optional. If C<HOST> is not given then it may instead be
-passed as the C<Host> option described below. If neither is given then
-the C<SMTP_Hosts> specified in C<Net::Config> will be used.
-
-C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
-Possible options are:
-
-B<Hello> - SMTP requires that you identify yourself. This option
-specifies a string to pass as your mail domain. If not given localhost.localdomain
-will be used.
-
-B<Host> - SMTP host to connect to. It may be a single scalar, as defined for
-the C<PeerAddr> option in L<IO::Socket::INET>, or a reference to
-an array with hosts to try in turn. The L</host> method will return the value
-which was used to connect to the host.
-
-B<LocalAddr> and B<LocalPort> - These parameters are passed directly
-to IO::Socket to allow binding the socket to a local port.
-
-B<Timeout> - Maximum time, in seconds, to wait for a response from the
-SMTP server (default: 120)
-
-B<ExactAddresses> - If true the all ADDRESS arguments must be as
-defined by C<addr-spec> in RFC2822. If not given, or false, then
-Net::SMTP will attempt to extract the address from the value passed.
-
-B<Debug> - Enable debugging information
-
-
-Example:
-
-
- $smtp = Net::SMTP->new('mailhost',
- Hello => 'my.mail.domain',
- Timeout => 30,
- Debug => 1,
- );
-
- # the same
- $smtp = Net::SMTP->new(
- Host => 'mailhost',
- Hello => 'my.mail.domain',
- Timeout => 30,
- Debug => 1,
- );
-
- # Connect to the default server from Net::config
- $smtp = Net::SMTP->new(
- Hello => 'my.mail.domain',
- Timeout => 30,
- );
-
-=back
-
-=head1 METHODS
-
-Unless otherwise stated all methods return either a I<true> or I<false>
-value, with I<true> meaning that the operation was a success. When a method
-states that it returns a value, failure will be returned as I<undef> or an
-empty list.
-
-=over 4
-
-=item banner ()
-
-Returns the banner message which the server replied with when the
-initial connection was made.
-
-=item domain ()
-
-Returns the domain that the remote SMTP server identified itself as during
-connection.
-
-=item hello ( DOMAIN )
-
-Tell the remote server the mail domain which you are in using the EHLO
-command (or HELO if EHLO fails). Since this method is invoked
-automatically when the Net::SMTP object is constructed the user should
-normally not have to call it manually.
-
-=item host ()
-
-Returns the value used by the constructor, and passed to IO::Socket::INET,
-to connect to the host.
-
-=item etrn ( DOMAIN )
-
-Request a queue run for the DOMAIN given.
-
-=item auth ( USERNAME, PASSWORD )
-
-Attempt SASL authentication.
-
-=item mail ( ADDRESS [, OPTIONS] )
-
-=item send ( ADDRESS )
-
-=item send_or_mail ( ADDRESS )
-
-=item send_and_mail ( ADDRESS )
-
-Send the appropriate command to the server MAIL, SEND, SOML or SAML. C<ADDRESS>
-is the address of the sender. This initiates the sending of a message. The
-method C<recipient> should be called for each address that the message is to
-be sent to.
-
-The C<mail> method can some additional ESMTP OPTIONS which is passed
-in hash like fashion, using key and value pairs. Possible options are:
-
- Size => <bytes>
- Return => "FULL" | "HDRS"
- Bits => "7" | "8" | "binary"
- Transaction => <ADDRESS>
- Envelope => <ENVID> # xtext-encodes its argument
- ENVID => <ENVID> # similar to Envelope, but expects argument encoded
- XVERP => 1
- AUTH => <submitter> # encoded address according to RFC 2554
-
-The C<Return> and C<Envelope> parameters are used for DSN (Delivery
-Status Notification).
-
-The submitter address in C<AUTH> option is expected to be in a format as
-required by RFC 2554, in an RFC2821-quoted form and xtext-encoded, or <> .
-
-=item reset ()
-
-Reset the status of the server. This may be called after a message has been
-initiated, but before any data has been sent, to cancel the sending of the
-message.
-
-=item recipient ( ADDRESS [, ADDRESS, [...]] [, OPTIONS ] )
-
-Notify the server that the current message should be sent to all of the
-addresses given. Each address is sent as a separate command to the server.
-Should the sending of any address result in a failure then the process is
-aborted and a I<false> value is returned. It is up to the user to call
-C<reset> if they so desire.
-
-The C<recipient> method can also pass additional case-sensitive OPTIONS as an
-anonymous hash using key and value pairs. Possible options are:
-
- Notify => ['NEVER'] or ['SUCCESS','FAILURE','DELAY'] (see below)
- ORcpt => <ORCPT>
- SkipBad => 1 (to ignore bad addresses)
-
-If C<SkipBad> is true the C<recipient> will not return an error when a bad
-address is encountered and it will return an array of addresses that did
-succeed.
-
- $smtp->recipient($recipient1,$recipient2); # Good
- $smtp->recipient($recipient1,$recipient2, { SkipBad => 1 }); # Good
- $smtp->recipient($recipient1,$recipient2, { Notify => ['FAILURE','DELAY'], SkipBad => 1 }); # Good
- @goodrecips=$smtp->recipient(@recipients, { Notify => ['FAILURE'], SkipBad => 1 }); # Good
- $smtp->recipient("$recipient,$recipient2"); # BAD
-
-Notify is used to request Delivery Status Notifications (DSNs), but your
-SMTP/ESMTP service may not respect this request depending upon its version and
-your site's SMTP configuration.
-
-Leaving out the Notify option usually defaults an SMTP service to its default
-behavior equivalent to ['FAILURE'] notifications only, but again this may be
-dependent upon your site's SMTP configuration.
-
-The NEVER keyword must appear by itself if used within the Notify option and "requests
-that a DSN not be returned to the sender under any conditions."
-
- {Notify => ['NEVER']}
-
- $smtp->recipient(@recipients, { Notify => ['NEVER'], SkipBad => 1 }); # Good
-
-You may use any combination of these three values 'SUCCESS','FAILURE','DELAY' in
-the anonymous array reference as defined by RFC3461 (see http://rfc.net/rfc3461.html
-for more information. Note: quotations in this topic from same.).
-
-A Notify parameter of 'SUCCESS' or 'FAILURE' "requests that a DSN be issued on
-successful delivery or delivery failure, respectively."
-
-A Notify parameter of 'DELAY' "indicates the sender's willingness to receive
-delayed DSNs. Delayed DSNs may be issued if delivery of a message has been
-delayed for an unusual amount of time (as determined by the Message Transfer
-Agent (MTA) at which the message is delayed), but the final delivery status
-(whether successful or failure) cannot be determined. The absence of the DELAY
-keyword in a NOTIFY parameter requests that a "delayed" DSN NOT be issued under
-any conditions."
-
- {Notify => ['SUCCESS','FAILURE','DELAY']}
-
- $smtp->recipient(@recipients, { Notify => ['FAILURE','DELAY'], SkipBad => 1 }); # Good
-
-ORcpt is also part of the SMTP DSN extension according to RFC3461.
-It is used to pass along the original recipient that the mail was first
-sent to. The machine that generates a DSN will use this address to inform
-the sender, because he can't know if recipients get rewritten by mail servers.
-It is expected to be in a format as required by RFC3461, xtext-encoded.
-
-=item to ( ADDRESS [, ADDRESS [...]] )
-
-=item cc ( ADDRESS [, ADDRESS [...]] )
-
-=item bcc ( ADDRESS [, ADDRESS [...]] )
-
-Synonyms for C<recipient>.
-
-=item data ( [ DATA ] )
-
-Initiate the sending of the data from the current message.
-
-C<DATA> may be a reference to a list or a list. If specified the contents
-of C<DATA> and a termination string C<".\r\n"> is sent to the server. And the
-result will be true if the data was accepted.
-
-If C<DATA> is not specified then the result will indicate that the server
-wishes the data to be sent. The data must then be sent using the C<datasend>
-and C<dataend> methods described in L<Net::Cmd>.
-
-=item expand ( ADDRESS )
-
-Request the server to expand the given address Returns an array
-which contains the text read from the server.
-
-=item verify ( ADDRESS )
-
-Verify that C<ADDRESS> is a legitimate mailing address.
-
-Most sites usually disable this feature in their SMTP service configuration.
-Use "Debug => 1" option under new() to see if disabled.
-
-=item help ( [ $subject ] )
-
-Request help text from the server. Returns the text or undef upon failure
-
-=item quit ()
-
-Send the QUIT command to the remote SMTP server and close the socket connection.
-
-=back
-
-=head1 ADDRESSES
-
-Net::SMTP attempts to DWIM with addresses that are passed. For
-example an application might extract The From: line from an email
-and pass that to mail(). While this may work, it is not recommended.
-The application should really use a module like L<Mail::Address>
-to extract the mail address and pass that.
-
-If C<ExactAddresses> is passed to the constructor, then addresses
-should be a valid rfc2821-quoted address, although Net::SMTP will
-accept accept the address surrounded by angle brackets.
-
- funny user@domain WRONG
- "funny user"@domain RIGHT, recommended
- <"funny user"@domain> OK
-
-=head1 SEE ALSO
-
-L<Net::Cmd>
-
-=head1 AUTHOR
-
-Graham Barr <gbarr@pobox.com>
-
-=head1 COPYRIGHT
-
-Copyright (c) 1995-2004 Graham Barr. All rights reserved.
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=cut
diff --git a/Master/tlpkg/tlperl/lib/Net/SMTP/TLS.pm b/Master/tlpkg/tlperl/lib/Net/SMTP/TLS.pm
deleted file mode 100755
index 10f9f196e40..00000000000
--- a/Master/tlpkg/tlperl/lib/Net/SMTP/TLS.pm
+++ /dev/null
@@ -1,401 +0,0 @@
-=head1 NAME
-
-Net::SMTP::TLS - An SMTP client supporting TLS and AUTH
-
-=head1 VERSION
-
-Version 0.12
-
-=head1 SYNOPSIS
-
- use Net::SMTP::TLS;
- my $mailer = new Net::SMTP::TLS(
- 'your.mail.host',
- Hello => 'some.host.name',
- Port => 25, #redundant
- User => 'emailguy',
- Password=> 's3cr3t');
- $mailer->mail('emailguy@your.mail.host');
- $mailer->to('someonecool@somewhere.else');
- $mailer->data;
- $mailer->datasend("Sent thru TLS!");
- $mailer->dataend;
- $mailer->quit;
-
-=head1 DESCRIPTION
-
-B<Net::SMTP::TLS> is a TLS and AUTH capable SMTP client which offers an interface that users will find familiar from L<Net::SMTP>. B<Net::SMTP::TLS> implements a subset of the methods provided by that module, but certainly not (yet) a complete mirror image of that API.
-
-The methods supported by B<Net::SMTP::TLS> are used in the above example. Though self explanatory for the most part, please see the perldoc for L<Net::SMTP> if you are unclear.
-
-The differences in the methods provided are as follows:
-
-=over
-
-The I<mail> method does not take the options list taken by L<Net::SMTP>
-
-The I<to> method also does not take options, and is the only method available to set the recipient (unlike the many synonyms provided by L<Net::SMTP>).
-
-The constructor takes a limited number of L<Net::SMTP>'s parameters. The constructor for B<Net::SMTP::TLS> takes the following (in addition to the hostname of the mail server, which must be the first parameter and is not explicitly named):
-
-=over
-
-NoTLS - In the unlikely event that you need to use this class to perform non-TLS SMTP (you ought to be using Net::SMTP itself for that...), this will turn off TLS when supplied with a true value. This will most often cause an error related to authentication when used on a server that requires TLS
-
-Hello - hostname used in the EHLO command
-
-Port - port to connect to the SMTP service (defaults to 25)
-
-Timeout - Timeout for inital socket connection (defaults to 5, passed directly to L<IO::Socket::INET>)
-
-User - username for SMTP AUTH
-
-Password - password for SMTP AUTH
-
-=back
-
-=back
-
-=head1 TLS and AUTHentication
-
-During construction of an B<Net::SMTP::TLS> instance, the full login process will occur. This involves first sending EHLO to the server, then initiating a TLS session through STARTTLS. Once this is complete, the module will attempt to login using the credentials supplied by the constructor, if such credentials have been supplied.
-
-The AUTH method will depend on the features returned by the server after the EHLO command. Based on that, CRAM-MD5 will be used if available, followed by LOGIN, followed by PLAIN. Please note that LOGIN is the only method of authentication that has been tested. CRAM-MD5 and PLAIN login functionality was taken directly from the script mentioned in the acknowledgements section, however, I have not tested them personally.
-
-=head1 ERROR HANDLING
-
-This module will croak in the event of an SMTP error. Should you wish to handle this gracefully in your application, you may wrap your mail transmission in an eval {} block and check $@ afterward.
-
-=head1 ACKNOWLEDGEMENTS
-
-This code was blatantly plagiarized from Michal Ludvig's smtp-client.pl script. See L<http://www.logix.cz/michal/devel/smtp> for his excellent work.
-
-=head1 AUTHOR
-
-Alexander Christian Westholm, awestholm at verizon dawt net
-
-Improvements courtesy of Tomek Zielinski
-
-=cut
-
-package Net::SMTP::TLS;
-
-use strict;
-use warnings;
-
-our $VERSION = '0.12';
-use Carp;
-
-use Net::SSLeay;
-use IO::Socket::INET;
-use IO::Socket::SSL;
-use MIME::Base64 qw[encode_base64 decode_base64];
-use Digest::HMAC_MD5 qw[hmac_md5_hex];
-
-BEGIN { #set up Net::SSLeay's internals
- Net::SSLeay::load_error_strings();
- Net::SSLeay::SSLeay_add_ssl_algorithms();
- Net::SSLeay::randomize();
-}
-
-sub new {
- my $pkg = shift;
- my $host= shift;
- my %args= @_;
- $args{Host} = $host;
- $args{Hello}= "localhost" if not $args{Hello};
- # make the non-SSL socket that will later be
- # transformed
- $args{sock} = new IO::Socket::INET(
- PeerAddr => $host,
- PeerPort => $args{Port} || 25,
- Proto => 'tcp',
- Timeout => $args{Timeout} || 5)
- or croak "Connect failed :$@\n";
-
- my $me = bless \%args, $pkg;
- # read the line immediately after connecting
- my ($rsp,$txt) = $me->_response();
- if(not $rsp == 220){
- croak "Could not connect to SMTP server: $host $txt\n";
- }
- $me->hello(); # the first hello, 2nd after starttls
- $me->starttls() if not $args{NoTLS}; # why we're here, after all
- $me->login() if($me->{User} and $me->{Password});
- return $me;
-}
-
-# simply print a command to the server
-sub _command {
- my $me = shift;
- my $command = shift;
- $me->{sock}->printf($command."\015\012");
-}
-
-# read a line from the server and parse the
-# CODE SEPERATOR TEXT response format
-sub _response {
- my $me = shift;
- my $line = $me->{sock}->getline();
- my @rsp = ($line =~ /(\d+)(.)([^\r]*)/);
- # reverse things so the seperator is at the end...
- # that way we don't have to get fancy with the return
- # values for calls that don't require the "more indicator"
- return ($rsp[0],$rsp[2],$rsp[1]);
-}
-
-# issue an EHLO command using the hostname provided to the constructor via
-# the Hello paramter, which defaults to localhost. After that, read
-# all the ESMTP capabilities returned by the server
-sub hello {
- my $me = shift;
- $me->_command("EHLO ".$me->{Hello});
- my ($num,$txt,$more) = $me->_response();
- if(not $num == 250){
- croak "EHLO command failed: $num $txt\n";
- }
- my %features = ();
- # SMTP uses the dash to seperate the status code from
- # the response text while there are more lines remaining
- while($more eq '-'){
- ($num,$txt,$more) = $me->_response();
- $txt =~ s/[\n|\r]//g;
- $txt =~ /(\S+)\s(.*)$/;
- my ($feat, $parm) = ($txt =~ /^(\w+)[= ]*(.*)$/);
- $features{$feat} = $parm;
- }
- $me->{features} = \%features;
- return 1;
-}
-
-# the magic! issue the STARTTLS command and
-# use IO::Socket::SSL to transform that no-good
-# plain old socket into an SSL socket
-sub starttls {
- my $me = shift;
- $me->_command("STARTTLS");
- my ($num,$txt) = $me->_response();
- if(not $num == 220){
- croak "Invalid response for STARTTLS: $num $txt\n";
- }
- if(not IO::Socket::SSL::socket_to_SSL($me->{sock},
- SSL_version => "SSLv3 TLSv1")){
- croak "Couldn't start TLS: ".IO::Socket::SSL::errstr."\n";
- }
- $me->hello();
-}
-
-# based on the AUTH line returned in the features after EHLO,
-# determine which type of authentication to perform
-sub login {
- my $me = shift;
- my $type= $me->{features}->{AUTH};
- if(not $type){
- croak "Server did not return AUTH in capabilities\n";
- }
- if($type =~ /CRAM\-MD5/){
- $me->auth_MD5();
- }elsif($type =~ /LOGIN/){
- $me->auth_LOGIN();
- }elsif($type =~ /PLAIN/){
- $me->auth_PLAIN();
- }else{
- croak "Unsupported Authentication mechanism\n";
- }
-}
-
-# perform a LOGIN authentication...
-# works well on my box.
-sub auth_LOGIN {
- my $me = shift;
- $me->_command("AUTH LOGIN");
- my ($num,$txt) = $me->_response();
- if(not $num == 334){
- croak "Cannot authenticate via LOGIN: $num $txt\n";
- }
- $me->_command(encode_base64($me->{User},""));
- ($num,$txt) = $me->_response();
- if(not $num == 334){
- croak "Auth failed: $num $txt\n";
- }
- $me->_command(encode_base64($me->{Password},""));
- ($num,$txt) = $me->_response();
- if(not $num == 235){
- croak "Auth failed: $num $txt\n";
- }
-}
-
-# use MD5 to login... gets the ticket from the text
-# of the line returned after the auth command is issued.
-# NOTE: untested
-sub auth_MD5{
- my $me =shift;
- $me->_command("AUTH CRAM-MD5");
- my ($num,$txt) = $me->_response();
- if(not $num == 334){
- croak "Cannot authenticate via CRAM-MD5: $num $txt\n";
- }
- my $ticket = decode_base64($txt) or
- croak "Unable to decode ticket";
- my $md5_pass = hmac_md5_hex($ticket, $me->{Password});
- $me->_command(encode_base64(
- $me->{User}." ".$md5_pass, ""));
- ($num,$txt) = $me->_response();
- if(not $num == 235){
- croak "Auth failed: $num $txt\n";
- }
-}
-
-# perform plain authentication
-sub auth_PLAIN{
- my $me = shift;
- my $user= $me->{User};
- my $pass= $me->{Password};
- $me->_command(sprintf("AUTH PLAIN %S",
- encode_base64("$user\0$user\0$pass","")));
- my ($num,$txt) = $me->_response();
- if(not $num == 235){
- croak "Auth failed: $num $txt\n";
- }
-}
-
-sub _addr {
- my $addr = shift;
- $addr = "" unless defined $addr;
-
- return $1 if $addr =~ /(<[^>]*>)/;
- $addr =~ s/^\s+|\s+$//sg;
-
- "<$addr>";
-}
-
-# send the MAIL FROM: <addr> command
-sub mail {
- my $me = shift;
- my $from= shift;
- $me->_command("MAIL FROM: "._addr($from));
- my ($num,$txt) = $me->_response();
- if(not $num == 250){
- croak "Could't set FROM: $num $txt\n";
- }
-}
-
-# send the RCPT TO: <addr> command
-sub recipient
-{
- my $me = shift;
-
-
- my $addr;
- foreach $addr (@_)
- {
- $me->_command("RCPT TO: "._addr($addr));
- my ($num,$txt) = $me->_response();
- if(not $num == 250){
- croak "Couldn't send TO <$addr>: $num $txt\n";
- }
- }
-}
-
-BEGIN {
- *to = \&recipient;
- *cc = \&recipient;
- *bcc = \&recipient;
-}
-
-
-# start the body of the message
-# I would probably have designed the public methods of
-# this class differently, but this is to keep with
-# Net::SMTP's API
-sub data {
- my $me = shift;
- $me->_command("DATA");
- my ($num,$txt) = $me->_response();
- if(not $num == 354){
- croak "Data failed: $num $txt\n";
- }
-}
-
-# send stuff over raw (for use as message body)
-sub datasend {
- my $cmd = shift;
- my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_;
- my $line = join("" ,@$arr);
-
- return 0 unless defined(fileno($cmd->{sock}));
-
- my $last_ch = $cmd->{last_ch};
- $last_ch = $cmd->{last_ch} = "\012" unless defined $last_ch;
-
- return 1 unless length $line;
-
- $line =~ tr/\r\n/\015\012/ unless "\r" eq "\015";
-
- my $first_ch = '';
-
- if ($last_ch eq "\015") {
- $first_ch = "\012" if $line =~ s/^\012//;
- }
- elsif ($last_ch eq "\012") {
- $first_ch = "." if $line =~ /^\./;
- }
-
- $line =~ s/\015?\012(\.?)/\015\012$1$1/sg;
-
- substr($line,0,0) = $first_ch;
-
- $cmd->{last_ch} = substr($line,-1,1);
-
- my $len = length($line);
- my $offset = 0;
- my $win = "";
- vec($win,fileno($cmd->{sock}),1) = 1;
- my $timeout = $cmd->{sock}->timeout || undef;
-
- local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
-
- while($len)
- {
- my $wout;
- if (select(undef,$wout=$win, undef, $timeout) > 0 or -f $cmd->{sock}) # -f for testing on win32
- {
- my $w = syswrite($cmd->{sock}, $line, $len, $offset);
- unless (defined($w))
- {
- carp("Error: $!");
- return undef;
- }
- $len -= $w;
- }
- else
- {
- carp("Error: Timeout");
- return undef;
- }
- }
-
-}
-
-# end the message body submission by a line with nothing
-# but a period on it.
-sub dataend {
- my $me = shift;
- $me->_command("\015\012.");
- my ($num,$txt) = $me->_response();
- if(not $num == 250){
- croak "Couldn't send mail: $num $txt\n";
- }
-}
-
-# politely disconnect from the SMTP server.
-sub quit {
- my $me = shift;
- $me->_command("QUIT");
- my ($num, $txt) = $me->_response();
- if(not $num == 221){
- croak "An error occurred disconnecting from the mail server: $num $txt\n";
- }
-}
-
-1;
diff --git a/Master/tlpkg/tlperl/lib/Net/SSL.pm b/Master/tlpkg/tlperl/lib/Net/SSL.pm
deleted file mode 100755
index f14435aeb69..00000000000
--- a/Master/tlpkg/tlperl/lib/Net/SSL.pm
+++ /dev/null
@@ -1,607 +0,0 @@
-package Net::SSL;
-
-use strict;
-use MIME::Base64;
-use Socket;
-use Carp;
-
-use vars qw(@ISA $VERSION $NEW_ARGS);
-$VERSION = '2.84';
-
-require IO::Socket;
-@ISA=qw(IO::Socket::INET);
-
-my %REAL; # private to this package only
-my $DEFAULT_VERSION = '23';
-my $CRLF = "\015\012";
-my $SEND_USERAGENT_TO_PROXY = 0;
-
-require Crypt::SSLeay;
-
-sub _default_context {
- require Crypt::SSLeay::MainContext;
- Crypt::SSLeay::MainContext::main_ctx(@_);
-}
-
-sub _alarm_set {
- return if $^O eq 'MSWin32' or $^O eq 'NetWare';
- alarm(shift);
-}
-
-sub new {
- my($class, %arg) = @_;
- local $NEW_ARGS = \%arg;
- $class->SUPER::new(%arg);
-}
-
-sub DESTROY {
- my $self = shift;
- delete $REAL{$self};
- local $@;
- eval { $self->SUPER::DESTROY; };
-}
-
-sub configure {
- my($self, $arg) = @_;
- my $ssl_version = delete $arg->{SSL_Version} ||
- $ENV{HTTPS_VERSION} || $DEFAULT_VERSION;
- my $ssl_debug = delete $arg->{SSL_Debug} || $ENV{HTTPS_DEBUG} || 0;
-
- my $ctx = delete $arg->{SSL_Context} || _default_context($ssl_version);
-
- *$self->{ssl_ctx} = $ctx;
- *$self->{ssl_version} = $ssl_version;
- *$self->{ssl_debug} = $ssl_debug;
- *$self->{ssl_arg} = $arg;
- *$self->{ssl_peer_addr} = $arg->{PeerAddr};
- *$self->{ssl_peer_port} = $arg->{PeerPort};
- *$self->{ssl_new_arg} = $NEW_ARGS;
- *$self->{ssl_peer_verify} = 0;
-
- ## Crypt::SSLeay must also aware the SSL Proxy before calling
- ## $socket->configure($args). Because the $sock->configure() will
- ## die when failed to resolve the destination server IP address,
- ## whether the SSL proxy is used or not!
- ## - dqbai, 2003-05-10
- if (my $proxy = $self->proxy) {
- ($arg->{PeerAddr}, $arg->{PeerPort}) = split(':',$proxy);
- $arg->{PeerPort} || croak("no port given for proxy server $proxy");
- }
-
- $self->SUPER::configure($arg);
-}
-
-# override to make sure there is really a timeout
-sub timeout {
- shift->SUPER::timeout || 60;
-}
-
-sub blocking {
- my $self = shift;
- $self->SUPER::blocking(@_);
-}
-
-sub connect {
- my $self = shift;
-
- # configure certs on connect() time, so we can throw an undef
- # and have LWP understand the error
- eval { $self->configure_certs() };
- if($@) {
- $@ = "configure certs failed: $@; $!";
- $self->die_with_error($@);
- }
-
- # finished, update set_verify status
- if(my $rv = *$self->{ssl_ctx}->set_verify()) {
- *$self->{ssl_peer_verify} = $rv;
- }
-
- if ($self->proxy) {
- # don't die() in connect, just return undef and set $@
- my $proxy_connect = eval { $self->proxy_connect_helper(@_) };
- if(! $proxy_connect || $@) {
- $@ = "proxy connect failed: $@; $!";
- croak($@);
- }
- }
- else {
- *$self->{io_socket_peername}=@_ == 1 ? $_[0] : IO::Socket::sockaddr_in(@_);
- if(!$self->SUPER::connect(@_)) {
- # better to die than return here
- $@ = "Connect failed: $@; $!";
- croak($@);
- }
- }
-
- my $debug = *$self->{ssl_debug} || 0;
- my $ssl = Crypt::SSLeay::Conn->new(*$self->{ssl_ctx}, $debug, $self);
- my $arg = *$self->{ssl_arg};
- my $new_arg = *$self->{ssl_new_arg};
- $arg->{SSL_Debug} = $debug;
-
- eval {
- local $SIG{ALRM} = sub { $self->die_with_error("SSL connect timeout") };
- # timeout / 2 because we have 3 possible connects here
- _alarm_set($self->timeout / 2);
-
- my $rv;
- {
- local $SIG{PIPE} = \&die;
- $rv = eval { $ssl->connect; };
- }
- if (not defined $rv or $rv <= 0) {
- _alarm_set(0);
- $ssl = undef;
- my %args = (%$new_arg, %$arg);
- if(*$self->{ssl_version} == 23) {
- $args{SSL_Version} = 3;
- # the new connect might itself be overridden with a REAL SSL
- my $new_ssl = Net::SSL->new(%args);
- $REAL{$self} = $REAL{$new_ssl} || $new_ssl;
- return $REAL{$self};
- }
- elsif(*$self->{ssl_version} == 3) {
- # $self->die_with_error("SSL negotiation failed");
- $args{SSL_Version} = 2;
- my $new_ssl = Net::SSL->new(%args);
- $REAL{$self} = $new_ssl;
- return $new_ssl;
- }
- else {
- # don't die, but do set $@, and return undef
- eval { $self->die_with_error("SSL negotiation failed") };
- croak($@);
- }
- }
- _alarm_set(0);
- };
-
- # odd error in eval {} block, maybe alarm outside the evals
- if($@) {
- $@ = "$@; $!";
- croak($@);
- }
-
- # successful SSL connection gets stored
- *$self->{ssl_ssl} = $ssl;
- $self;
-}
-
-# Delegate these calls to the Crypt::SSLeay::Conn object
-sub get_peer_certificate {
- my $self = shift;
- $self = $REAL{$self} || $self;
- *$self->{ssl_ssl}->get_peer_certificate(@_);
-}
-
-sub get_peer_verify {
- my $self = shift;
- $self = $REAL{$self} || $self;
- *$self->{ssl_peer_verify};
-}
-
-sub get_shared_ciphers {
- my $self = shift;
- $self = $REAL{$self} || $self;
- *$self->{ssl_ssl}->get_shared_ciphers(@_);
-}
-
-sub get_cipher {
- my $self = shift;
- $self = $REAL{$self} || $self;
- *$self->{ssl_ssl}->get_cipher(@_);
-}
-
-sub ssl_context {
- my $self = shift;
- $self = $REAL{$self} || $self;
- *$self->{ssl_ctx};
-}
-
-sub die_with_error {
- my $self=shift;
- my $reason=shift;
-
- my @err;
- while(my $err=Crypt::SSLeay::Err::get_error_string()) {
- push @err, $err;
- }
- croak("$reason: " . join( ' | ', @err ));
-}
-
-sub read {
- my $self = shift;
- $self = $REAL{$self} || $self;
-
- local $SIG{__DIE__} = \&Carp::confess;
- local $SIG{ALRM} = sub { $self->die_with_error("SSL read timeout") };
-
- _alarm_set($self->timeout);
- my $n = *$self->{ssl_ssl}->read(@_);
- _alarm_set(0);
- $self->die_with_error("read failed") if !defined $n;
-
- $n;
-}
-
-sub write {
- my $self = shift;
- $self = $REAL{$self} || $self;
- my $n = *$self->{ssl_ssl}->write(@_);
- $self->die_with_error("write failed") if !defined $n;
- $n;
-}
-
-*sysread = \&read;
-*syswrite = \&write;
-
-sub print {
- my $self = shift;
- $self = $REAL{$self} || $self;
- # should we care about $, and $\??
- # I think it is too expensive...
- $self->write(join("", @_));
-}
-
-sub printf {
- my $self = shift;
- $self = $REAL{$self} || $self;
- my $fmt = shift;
- $self->write(sprintf($fmt, @_));
-}
-
-sub getchunk {
- my $self = shift;
- $self = $REAL{$self} || $self;
- my $buf = ''; # warnings
- my $n = $self->read($buf, 32768);
- return unless defined $n;
- $buf;
-}
-
-# This is really inefficient, but we only use it for reading the proxy response
-# so that does not really matter.
-sub getline {
- my $self = shift;
- $self = $REAL{$self} || $self;
- my $val="";
- my $buf;
- do {
- $self->SUPER::recv($buf, 1);
- $val .= $buf;
- } until ($buf eq "\n");
-
- $val;
-}
-
-# XXX: no way to disable <$sock>?? (tied handle perhaps?)
-
-sub get_lwp_object {
- my $self = shift;
-
- my $lwp_object;
- my $i = 0;
- while(1) {
- package DB;
- my @stack = caller($i++);
- last unless @stack;
- my @stack_args = @DB::args;
- my $stack_object = $stack_args[0] || next;
- return $stack_object
- if ref($stack_object)
- and $stack_object->isa('LWP::UserAgent');
- }
- return undef;
-}
-
-sub send_useragent_to_proxy {
- if (my $val = shift) {
- $SEND_USERAGENT_TO_PROXY = $val;
- }
- return $SEND_USERAGENT_TO_PROXY;
-}
-
-sub proxy_connect_helper {
- my $self = shift;
-
- my $proxy = $self->proxy;
- my ($proxy_host, $proxy_port) = split(':',$proxy);
- $proxy_port || croak("no port given for proxy server $proxy");
-
- my $proxy_addr = gethostbyname($proxy_host);
- $proxy_addr || croak("can't resolve proxy server name: $proxy_host, $!");
-
- my($peer_port, $peer_addr) = (*$self->{ssl_peer_port}, *$self->{ssl_peer_addr});
- $peer_addr || croak("no peer addr given");
- $peer_port || croak("no peer port given");
-
- # see if the proxy should be bypassed
- my @no_proxy = split( /\s*,\s*/, $ENV{NO_PROXY} || $ENV{no_proxy} || '');
- my $is_proxied = 1;
- my $domain;
- for $domain (@no_proxy) {
- if ($peer_addr =~ /\Q$domain\E$/) {
- $is_proxied = 0;
- last;
- }
- }
-
- if ($is_proxied) {
- $self->SUPER::connect($proxy_port, $proxy_addr)
- || croak("proxy connect to $proxy_host:$proxy_port failed: $!");
- }
- else {
- $self->SUPER::connect($peer_port, $peer_addr)
- || croak("proxy bypass to $peer_addr:$peer_addr failed: $!");
- }
-
- my $connect_string;
- if ($ENV{"HTTPS_PROXY_USERNAME"} || $ENV{"HTTPS_PROXY_PASSWORD"}) {
- my $user = $ENV{"HTTPS_PROXY_USERNAME"};
- my $pass = $ENV{"HTTPS_PROXY_PASSWORD"};
-
- my $credentials = encode_base64("$user:$pass", "");
- $connect_string = join($CRLF,
- "CONNECT $peer_addr:$peer_port HTTP/1.0",
- "Proxy-authorization: Basic $credentials"
- );
- }
- else {
- $connect_string = "CONNECT $peer_addr:$peer_port HTTP/1.0";
- }
- $connect_string .= $CRLF;
-
- if (send_useragent_to_proxy()) {
- my $lwp_object = $self->get_lwp_object;
- if($lwp_object && $lwp_object->agent) {
- $connect_string .= "User-Agent: ".$lwp_object->agent.$CRLF;
- }
- }
-
- $connect_string .= $CRLF;
- $self->SUPER::send($connect_string);
- my $header;
- my $n = $self->SUPER::sysread($header, 8192);
- my $conn_ok = ($header =~ /HTTP\/\d+\.\d+\s+200\s+/is) ? 1 : 0;
-
- if (not $conn_ok) {
- croak("PROXY ERROR HEADER, could be non-SSL URL:\n$header");
- }
-
- $conn_ok;
-}
-
-# code adapted from LWP::UserAgent, with $ua->env_proxy API
-sub proxy {
- my $proxy_server = $ENV{HTTPS_PROXY} || $ENV{https_proxy};
- return unless $proxy_server;
-
- $proxy_server =~ s|\Ahttps?://||i;
- $proxy_server;
-}
-
-sub configure_certs {
- my $self = shift;
- my $ctx = *$self->{ssl_ctx};
-
- my $count = 0;
- for (qw(HTTPS_PKCS12_FILE HTTPS_CERT_FILE HTTPS_KEY_FILE)) {
- my $file = $ENV{$_};
- if ($file) {
- (-e $file) or croak("$file file does not exist: $!");
- (-r $file) or croak("$file file is not readable");
- $count++;
- if (/PKCS12/) {
- $count++;
- $ctx->use_pkcs12_file($file ,$ENV{'HTTPS_PKCS12_PASSWORD'}) || croak("failed to load $file: $!");
- last;
- }
- elsif (/CERT/) {
- $ctx->use_certificate_file($file ,1) || croak("failed to load $file: $!");
- }
- elsif (/KEY/) {
- $ctx->use_PrivateKey_file($file, 1) || croak("failed to load $file: $!");
- }
- else {
- croak("setting $_ not supported");
- }
- }
- }
-
- # if both configs are set, then verify them
- if ($count == 2) {
- if (! $ctx->check_private_key) {
- croak("Private key and certificate do not match");
- }
- }
-
- $count; # number of successful cert loads/checks
-}
-
-sub accept { shift->_unimpl("accept") }
-sub getc { shift->_unimpl("getc") }
-sub ungetc { shift->_unimpl("ungetc") }
-sub getlines { shift->_unimpl("getlines"); }
-
-sub _unimpl {
- my($self, $meth) = @_;
- croak("$meth not implemented for Net::SSL sockets");
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-Net::SSL - support for Secure Sockets Layer
-
-=head1 METHODS
-
-=over 4
-
-=item new
-
-Creates a new C<Net::SSL> object.
-
-=item configure
-
-Configures a C<Net::SSL> socket for operation.
-
-=item configure_certs
-
-Sets up a certificate file to use for communicating with on
-the socket.
-
-=item connect
-
-=item die_with_error
-
-=item get_cipher
-
-=item get_lwp_object
-
-Walks up the caller stack and looks for something blessed into
-the C<LWP::UserAgent> namespace and returns it. Vaguely deprecated.
-
-=item get_peer_certificate
-
-Gets the peer certificate from the underlying C<Crypt::SSLeay::Conn>
-object.
-
-=item get_peer_verify
-
-=item get_shared_ciphers
-
-=item getchunk
-
-Attempts to read up to 32KiB of data from the socket. Returns
-C<undef> if nothing was read, otherwise returns the data as
-a scalar.
-
-=item getline
-
-Reads one character at a time until a newline is encountered,
-and returns the line, including the newline. Grossly
-inefficient.
-
-=item print
-
-Concatenates the input parameters and writes them to the socket.
-Does not honour C<$,> nor C<$/>. Returns the number of bytes written.
-
-=item printf
-
-Performs a C<sprintf> of the input parameters (thus, the first
-parameter must be the format), and writes the result to the socket.
-Returns the number of bytes written.
-
-=item proxy
-
-Returns the hostname of an https proxy server, as specified by the
-C<HTTPS_PROXY> environment variable.
-
-=item proxy_connect_helper
-
-Helps set up a connection through a proxy.
-
-=item read
-
-Performs a read on the socket and returns the result.
-
-=item ssl_context
-
-=item sysread
-
-Is an alias of C<read>.
-
-=item timeout
-
-Returns the timeout value of the socket as defined by the implementing
-class or 60 seconds by default.
-
-=item blocking
-
-Returns a boolean indicating whether the underlying socket is in
-blocking mode. By default, Net::SSL sockets are in blocking mode.
-
- $sock->blocking(0); # set to non-blocking mode
-
-This method simply calls the underlying C<blocking> method of the
-IO::Socket object.
-
-=item write
-
-Writes the parameters passed in (thus, a list) to the socket. Returns
-the number of bytes written.
-
-=item syswrite
-
-Is an alias of C<write>.
-
-=item accept
-
-Not yet implemented. Will die if called.
-
-=item getc
-
-Not yet implemented. Will die if called.
-
-=item getlines
-
-Not yet implemented. Will die if called.
-
-=item ungetc
-
-Not yet implemented. Will die if called.
-
-=item send_useragent_to_proxy
-
-By default (as of version 2.80 of C<Net::SSL> in the 0.54 distribution
-of Crypt::SSLeay), the user agent string is no longer sent to the
-proxy (but will continue to be sent to the remote host).
-
-The previous behaviour was of marginal benefit, and could cause
-fatal errors in certain scenarios (see CPAN bug #4759) and so no
-longer happens by default.
-
-To reinstate the old behaviour, call C<Net::SSL::send_useragent_to_proxy>
-with a true value (usually 1).
-
-=back
-
-=head1 DIAGNOSTICS
-
- "no port given for proxy server <proxy>"
-
-A proxy was specified for configuring a socket, but no port number
-was given. Ensure that the proxy is specified as a host:port pair,
-such as C<proxy.example.com:8086>.
-
- "configure certs failed: <contents of $@>; <contents of $!>"
-
- "proxy connect failed: <contents of $@>; <contents of $!>"
-
- "Connect failed: <contents of $@>; <contents of $!>"
-
-During connect().
-
-=head2 SEE ALSO
-
-=over 4
-
-=item IO::Socket::INET
-
-C<Net::SSL> is implemented by subclassing C<IO::Socket::INET>, hence
-methods not specifically overridden are defined by that package.
-
-=item Net::SSLeay
-
-A package that provides a Perl-level interface to the C<openssl>
-secure sockets layer library.
-
-=back
-
-=cut
-
diff --git a/Master/tlpkg/tlperl/lib/Net/SSLeay.pm b/Master/tlpkg/tlperl/lib/Net/SSLeay.pm
deleted file mode 100755
index 08a0ec30f6a..00000000000
--- a/Master/tlpkg/tlperl/lib/Net/SSLeay.pm
+++ /dev/null
@@ -1,2610 +0,0 @@
-# Net::SSLeay.pm - Perl module for using Eric Young's implementation of SSL
-#
-# Copyright (c) 1996-2003 Sampo Kellomaki <sampo@iki.fi>, All Rights Reserved.
-# Copyright (C) 2005 Florian Ragwitz <rafl@debian.org>, All Rights Reserved.
-# Copyright (C) 2005 Mike McCauley <mikem@open.com.au>, All Rights Reserved.
-#
-# $Id$
-#
-# Version 1.04, 31.3.1999
-# 30.7.1999, Tracking OpenSSL-0.9.3a changes, --Sampo
-# 31.7.1999, version 1.05 --Sampo
-# 7.4.2001, fixed input error upon 0, OpenSSL-0.9.6a, version 1.06 --Sampo
-# 18.4.2001, added TLSv1 support by Stephen C. Koehler
-# <koehler@securecomputing.com>, version 1.07, --Sampo
-# 25.4.2001, 64 bit fixes by Marko Asplund <aspa@kronodoc.fi> --Sampo
-# 17.4.2001, more error codes from aspa --Sampo
-# 25.9.2001, added heaps and piles of newer OpenSSL auxiliary functions --Sampo
-# 6.11.2001, got rid of $p_errs madness --Sampo
-# 9.11.2001, added EGD (entropy gathering daemon) reference info --Sampo
-# 7.12.2001, Added proxy support by Bruno De Wolf <bruno.dewolf@@pandora._be>
-# 6.1.2002, cosmetic fix to socket options from Kwindla Hultman Kramer <kwindla@@allafrica_.com>
-# 25.3.2002, added post_https_cert and friends per patch from
-# mock@@obscurity.ogr, --Sampo
-# 3.4.2002, added `use bytes' from Marcus Taylor <marcus@@semantico_.com>
-# This avoids unicode/utf8 (as may appear in some XML docs)
-# from fooling the length comuptations. Dropped support for
-# perl5.005_03 because I do not have opportunity to test it. --Sampo
-# 5.4.2002, improved Unicode gotcha eliminator to support old perls --Sampo
-# 8.4.2002, added a small line end fix from Petr Dousa (pdousa@@kerio_.com)
-# 17.5.2002, Added BIO_s_mem, BIO_new, BIO_free, BIO_write, BIO_read
-# BIO_eof, BIO_pending, BIO_wpending, RSA_generate_key, RSA_free
-# --mikem@open._com.au
-# 10.8.2002, Added SSL_peek patch to ssl_read_until from
-# Peter Behroozi <peter@@fhpwireless_.com> --Sampo
-# 21.8.2002, Added SESSION_get_master_key, SSL_get_client_random, SSL_get_server_random
-# --mikem@open.com_.au
-# 2.9.2002, Added SSL_CTX_get_cert_store, X509_STORE_add_cert, X509_STORE_add_crl
-# X509_STORE_set_flags, X509_load_cert_file, X509_load_crl_file
-# X509_load_cert_crl_file, PEM_read_bio_X509_CRL,
-# constants for X509_V_FLAG_* in order to support certificate revocation lists.
-# --mikem@open.com_.au
-# 6.9.2002, fixed X509_STORE_set_flags to X509_STORE_CTX_set_flags, --Sampo
-# 19.9.2002, applied patch from Tim Engler <tim@burntcouch_.com>
-# 18.2.2003, applied patch from Toni Andjelkovic <toni@soth._at>
-# 13.6.2003, partially applied leak patch by Marian Jancar <mjancar@suse._cz>
-# 25.6.2003, write_partial() return value patch from
-# Kim Minh Kaplan <kmkaplan@selfoffice._com>
-# 17.8.2003, added http support :-) --Sampo
-# 17.8.2003, started 1.25 dev --Sampo
-# 30.11.2005, Applied a patch by Peter Behroozi that adds get1_session() for session caching --Florian
-# 30.11.2005, Applied a patch by ex8k-hbn@asahi-net.or.jp that limits the chunk size for tcp_read_all --Florian
-# 30.11.2005, Applied a patch by ivan-cpan-rt@420.am that avoids adding a Host header if an own is specified in do_httpx3
-# 13.12.2005, Added comments re thread safety and resetting of default_passwd_callback after use
-# --mikem@open.com.au
-#
-# The distribution and use of this module are subject to the conditions
-# listed in LICENSE file at the root of OpenSSL-0.9.7b
-# distribution (i.e. free, but mandatory attribution and NO WARRANTY).
-
-package Net::SSLeay;
-
-use strict;
-use Carp;
-use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD $CRLF);
-use Socket;
-use Errno;
-
-require Exporter;
-use AutoLoader;
-
-# 0=no warns, 1=only errors, 2=ciphers, 3=progress, 4=dump data
-$Net::SSLeay::trace = 0; # Do not change here, use
- # $Net::SSLeay::trace = [1-4] in caller
-
-# 2 = insist on v2 SSL protocol
-# 3 = insist on v3 SSL
-# 10 = insist on TLSv1
-# 0 or undef = guess (v23)
-#
-$Net::SSLeay::ssl_version = 0; # don't change here, use
- # Net::SSLeay::version=[2,3,0] in caller
-
-#define to enable the "cat /proc/$$/stat" stuff
-$Net::SSLeay::linux_debug = 0;
-
-# Number of seconds to sleep after sending message and before half
-# closing connection. Useful with antiquated broken servers.
-$Net::SSLeay::slowly = 0;
-
-# RANDOM NUMBER INITIALIZATION
-#
-# Edit to your taste. Using /dev/random would be more secure, but may
-# block if randomness is not available, thus the default is
-# /dev/urandom. $how_random determines how many bits of randomness to take
-# from the device. You should take enough (read SSLeay/doc/rand), but
-# beware that randomness is limited resource so you should not waste
-# it either or you may end up with randomness depletion (situation where
-# /dev/random would block and /dev/urandom starts to return predictable
-# numbers).
-#
-# N.B. /dev/urandom does not exit on all systems, such as Solaris 2.6. In that
-# case you should get a third party package that emulates /dev/urandom
-# (e.g. via named pipe) or supply a random number file. Some such
-# packages are documented in Caveat section of the POD documentation.
-
-$Net::SSLeay::random_device = '/dev/urandom';
-$Net::SSLeay::how_random = 512;
-
-$VERSION = '1.35';
-@ISA = qw(Exporter);
-@EXPORT_OK = qw(
- AT_MD5_WITH_RSA_ENCRYPTION
- CB_ACCEPT_EXIT
- CB_ACCEPT_LOOP
- CB_CONNECT_EXIT
- CB_CONNECT_LOOP
- CK_DES_192_EDE3_CBC_WITH_MD5
- CK_DES_192_EDE3_CBC_WITH_SHA
- CK_DES_64_CBC_WITH_MD5
- CK_DES_64_CBC_WITH_SHA
- CK_DES_64_CFB64_WITH_MD5_1
- CK_IDEA_128_CBC_WITH_MD5
- CK_NULL
- CK_NULL_WITH_MD5
- CK_RC2_128_CBC_EXPORT40_WITH_MD5
- CK_RC2_128_CBC_WITH_MD5
- CK_RC4_128_EXPORT40_WITH_MD5
- CK_RC4_128_WITH_MD5
- CLIENT_VERSION
- ERROR_NONE
- ERROR_SSL
- ERROR_SYSCALL
- ERROR_WANT_CONNECT
- ERROR_WANT_READ
- ERROR_WANT_WRITE
- ERROR_WANT_X509_LOOKUP
- ERROR_ZERO_RETURN
- CT_X509_CERTIFICATE
- FILETYPE_ASN1
- FILETYPE_PEM
- F_CLIENT_CERTIFICATE
- F_CLIENT_HELLO
- F_CLIENT_MASTER_KEY
- F_D2I_SSL_SESSION
- F_GET_CLIENT_FINISHED
- F_GET_CLIENT_HELLO
- F_GET_CLIENT_MASTER_KEY
- F_GET_SERVER_FINISHED
- F_GET_SERVER_HELLO
- F_GET_SERVER_VERIFY
- F_I2D_SSL_SESSION
- F_READ_N
- F_REQUEST_CERTIFICATE
- F_SERVER_HELLO
- F_SSL_ACCEPT
- F_SSL_CERT_NEW
- F_SSL_CONNECT
- F_SSL_ENC_DES_CBC_INIT
- F_SSL_ENC_DES_CFB_INIT
- F_SSL_ENC_DES_EDE3_CBC_INIT
- F_SSL_ENC_IDEA_CBC_INIT
- F_SSL_ENC_NULL_INIT
- F_SSL_ENC_RC2_CBC_INIT
- F_SSL_ENC_RC4_INIT
- F_SSL_GET_NEW_SESSION
- F_SSL_MAKE_CIPHER_LIST
- F_SSL_NEW
- F_SSL_READ
- F_SSL_RSA_PRIVATE_DECRYPT
- F_SSL_RSA_PUBLIC_ENCRYPT
- F_SSL_SESSION_NEW
- F_SSL_SESSION_PRINT_FP
- F_SSL_SET_CERTIFICATE
- F_SSL_SET_FD
- F_SSL_SET_RFD
- F_SSL_SET_WFD
- F_SSL_STARTUP
- F_SSL_USE_CERTIFICATE
- F_SSL_USE_CERTIFICATE_ASN1
- F_SSL_USE_CERTIFICATE_FILE
- F_SSL_USE_PRIVATEKEY
- F_SSL_USE_PRIVATEKEY_ASN1
- F_SSL_USE_PRIVATEKEY_FILE
- F_SSL_USE_RSAPRIVATEKEY
- F_SSL_USE_RSAPRIVATEKEY_ASN1
- F_SSL_USE_RSAPRIVATEKEY_FILE
- F_WRITE_PENDING
- GEN_OTHERNAME
- GEN_EMAIL
- GEN_DNS
- GEN_X400
- GEN_DIRNAME
- GEN_EDIPARTY
- GEN_URI
- GEN_IPADD
- GEN_RID
- MAX_MASTER_KEY_LENGTH_IN_BITS
- MAX_RECORD_LENGTH_2_BYTE_HEADER
- MAX_RECORD_LENGTH_3_BYTE_HEADER
- MAX_SSL_SESSION_ID_LENGTH_IN_BYTES
- MIN_RSA_MODULUS_LENGTH_IN_BYTES
- MT_CLIENT_CERTIFICATE
- MT_CLIENT_FINISHED
- MT_CLIENT_HELLO
- MT_CLIENT_MASTER_KEY
- MT_ERROR
- MT_REQUEST_CERTIFICATE
- MT_SERVER_FINISHED
- MT_SERVER_HELLO
- MT_SERVER_VERIFY
- NOTHING
- NID_undef
- NID_algorithm
- NID_rsadsi
- NID_pkcs
- NID_md2
- NID_md5
- NID_rc4
- NID_rsaEncryption
- NID_md2WithRSAEncryption
- NID_md5WithRSAEncryption
- NID_pbeWithMD2AndDES_CBC
- NID_pbeWithMD5AndDES_CBC
- NID_X500
- NID_X509
- NID_commonName
- NID_countryName
- NID_localityName
- NID_stateOrProvinceName
- NID_organizationName
- NID_organizationalUnitName
- NID_rsa
- NID_pkcs7
- NID_pkcs7_data
- NID_pkcs7_signed
- NID_pkcs7_enveloped
- NID_pkcs7_signedAndEnveloped
- NID_pkcs7_digest
- NID_pkcs7_encrypted
- NID_pkcs3
- NID_dhKeyAgreement
- NID_des_ecb
- NID_des_cfb64
- NID_des_cbc
- NID_des_ede
- NID_des_ede3
- NID_idea_cbc
- NID_idea_cfb64
- NID_idea_ecb
- NID_rc2_cbc
- NID_rc2_ecb
- NID_rc2_cfb64
- NID_rc2_ofb64
- NID_sha
- NID_shaWithRSAEncryption
- NID_des_ede_cbc
- NID_des_ede3_cbc
- NID_des_ofb64
- NID_idea_ofb64
- NID_pkcs9
- NID_pkcs9_emailAddress
- NID_pkcs9_unstructuredName
- NID_pkcs9_contentType
- NID_pkcs9_messageDigest
- NID_pkcs9_signingTime
- NID_pkcs9_countersignature
- NID_pkcs9_challengePassword
- NID_pkcs9_unstructuredAddress
- NID_pkcs9_extCertAttributes
- NID_netscape
- NID_netscape_cert_extension
- NID_netscape_data_type
- NID_des_ede_cfb64
- NID_des_ede3_cfb64
- NID_des_ede_ofb64
- NID_des_ede3_ofb64
- NID_sha1
- NID_sha1WithRSAEncryption
- NID_dsaWithSHA
- NID_dsa_2
- NID_pbeWithSHA1AndRC2_CBC
- NID_id_pbkdf2
- NID_dsaWithSHA1_2
- NID_netscape_cert_type
- NID_netscape_base_url
- NID_netscape_revocation_url
- NID_netscape_ca_revocation_url
- NID_netscape_renewal_url
- NID_netscape_ca_policy_url
- NID_netscape_ssl_server_name
- NID_netscape_comment
- NID_netscape_cert_sequence
- NID_desx_cbc
- NID_id_ce
- NID_subject_key_identifier
- NID_key_usage
- NID_private_key_usage_period
- NID_subject_alt_name
- NID_issuer_alt_name
- NID_basic_constraints
- NID_crl_number
- NID_certificate_policies
- NID_authority_key_identifier
- NID_bf_cbc
- NID_bf_ecb
- NID_bf_cfb64
- NID_bf_ofb64
- NID_mdc2
- NID_mdc2WithRSA
- NID_rc4_40
- NID_rc2_40_cbc
- NID_givenName
- NID_surname
- NID_initials
- NID_uniqueIdentifier
- NID_crl_distribution_points
- NID_md5WithRSA
- NID_serialNumber
- NID_title
- NID_description
- NID_cast5_cbc
- NID_cast5_ecb
- NID_cast5_cfb64
- NID_cast5_ofb64
- NID_pbeWithMD5AndCast5_CBC
- NID_dsaWithSHA1
- NID_md5_sha1
- NID_sha1WithRSA
- NID_dsa
- NID_ripemd160
- NID_ripemd160WithRSA
- NID_rc5_cbc
- NID_rc5_ecb
- NID_rc5_cfb64
- NID_rc5_ofb64
- NID_rle_compression
- NID_zlib_compression
- NID_ext_key_usage
- NID_id_pkix
- NID_id_kp
- NID_server_auth
- NID_client_auth
- NID_code_sign
- NID_email_protect
- NID_time_stamp
- NID_ms_code_ind
- NID_ms_code_com
- NID_ms_ctl_sign
- NID_ms_sgc
- NID_ms_efs
- NID_ns_sgc
- NID_delta_crl
- NID_crl_reason
- NID_invalidity_date
- NID_sxnet
- NID_pbe_WithSHA1And128BitRC4
- NID_pbe_WithSHA1And40BitRC4
- NID_pbe_WithSHA1And3_Key_TripleDES_CBC
- NID_pbe_WithSHA1And2_Key_TripleDES_CBC
- NID_pbe_WithSHA1And128BitRC2_CBC
- NID_pbe_WithSHA1And40BitRC2_CBC
- NID_keyBag
- NID_pkcs8ShroudedKeyBag
- NID_certBag
- NID_crlBag
- NID_secretBag
- NID_safeContentsBag
- NID_friendlyName
- NID_localKeyID
- NID_x509Certificate
- NID_sdsiCertificate
- NID_x509Crl
- NID_pbes2
- NID_pbmac1
- NID_hmacWithSHA1
- NID_id_qt_cps
- NID_id_qt_unotice
- NID_rc2_64_cbc
- NID_SMIMECapabilities
- NID_pbeWithMD2AndRC2_CBC
- NID_pbeWithMD5AndRC2_CBC
- NID_pbeWithSHA1AndDES_CBC
- NID_ms_ext_req
- NID_ext_req
- NID_name
- NID_dnQualifier
- NID_id_pe
- NID_id_ad
- NID_info_access
- NID_ad_OCSP
- NID_ad_ca_issuers
- NID_OCSP_sign
- OPENSSL_VERSION_NUMBER
- PE_BAD_CERTIFICATE
- PE_NO_CERTIFICATE
- PE_NO_CIPHER
- PE_UNSUPPORTED_CERTIFICATE_TYPE
- READING
- RWERR_BAD_MAC_DECODE
- RWERR_BAD_WRITE_RETRY
- RWERR_INTERNAL_ERROR
- R_BAD_AUTHENTICATION_TYPE
- R_BAD_CHECKSUM
- R_BAD_MAC_DECODE
- R_BAD_RESPONSE_ARGUMENT
- R_BAD_SSL_FILETYPE
- R_BAD_SSL_SESSION_ID_LENGTH
- R_BAD_STATE
- R_BAD_WRITE_RETRY
- R_CHALLENGE_IS_DIFFERENT
- R_CIPHER_CODE_TOO_LONG
- R_CIPHER_TABLE_SRC_ERROR
- R_CONECTION_ID_IS_DIFFERENT
- R_INVALID_CHALLENGE_LENGTH
- R_NO_CERTIFICATE_SET
- R_NO_CERTIFICATE_SPECIFIED
- R_NO_CIPHER_LIST
- R_NO_CIPHER_MATCH
- R_NO_CIPHER_WE_TRUST
- R_NO_PRIVATEKEY
- R_NO_PUBLICKEY
- R_NO_READ_METHOD_SET
- R_NO_WRITE_METHOD_SET
- R_NULL_SSL_CTX
- R_PEER_DID_NOT_RETURN_A_CERTIFICATE
- R_PEER_ERROR
- R_PEER_ERROR_CERTIFICATE
- R_PEER_ERROR_NO_CIPHER
- R_PEER_ERROR_UNSUPPORTED_CERTIFICATE_TYPE
- R_PERR_ERROR_NO_CERTIFICATE
- R_PUBLIC_KEY_ENCRYPT_ERROR
- R_PUBLIC_KEY_IS_NOT_RSA
- R_PUBLIC_KEY_NO_RSA
- R_READ_WRONG_PACKET_TYPE
- R_REVERSE_KEY_ARG_LENGTH_IS_WRONG
- R_REVERSE_MASTER_KEY_LENGTH_IS_WRONG
- R_REVERSE_SSL_SESSION_ID_LENGTH_IS_WRONG
- R_SHORT_READ
- R_SSL_SESSION_ID_IS_DIFFERENT
- R_UNABLE_TO_EXTRACT_PUBLIC_KEY
- R_UNDEFINED_INIT_STATE
- R_UNKNOWN_REMOTE_ERROR_TYPE
- R_UNKNOWN_STATE
- R_UNSUPORTED_CIPHER
- R_WRONG_PUBLIC_KEY_TYPE
- R_X509_LIB
- RSA_3
- RSA_F4
- SERVER_VERSION
- SESSION
- SESSION_ASN1_VERSION
- ST_ACCEPT
- ST_BEFORE
- ST_CLIENT_START_ENCRYPTION
- ST_CONNECT
- ST_GET_CLIENT_FINISHED_A
- ST_GET_CLIENT_FINISHED_B
- ST_GET_CLIENT_HELLO_A
- ST_GET_CLIENT_HELLO_B
- ST_GET_CLIENT_MASTER_KEY_A
- ST_GET_CLIENT_MASTER_KEY_B
- ST_GET_SERVER_FINISHED_A
- ST_GET_SERVER_FINISHED_B
- ST_GET_SERVER_HELLO_A
- ST_GET_SERVER_HELLO_B
- ST_GET_SERVER_VERIFY_A
- ST_GET_SERVER_VERIFY_B
- ST_INIT
- ST_OK
- ST_READ_BODY
- ST_READ_HEADER
- ST_SEND_CLIENT_CERTIFICATE_A
- ST_SEND_CLIENT_CERTIFICATE_B
- ST_SEND_CLIENT_CERTIFICATE_C
- ST_SEND_CLIENT_CERTIFICATE_D
- ST_SEND_CLIENT_FINISHED_A
- ST_SEND_CLIENT_FINISHED_B
- ST_SEND_CLIENT_HELLO_A
- ST_SEND_CLIENT_HELLO_B
- ST_SEND_CLIENT_MASTER_KEY_A
- ST_SEND_CLIENT_MASTER_KEY_B
- ST_SEND_REQUEST_CERTIFICATE_A
- ST_SEND_REQUEST_CERTIFICATE_B
- ST_SEND_REQUEST_CERTIFICATE_C
- ST_SEND_REQUEST_CERTIFICATE_D
- ST_SEND_SERVER_FINISHED_A
- ST_SEND_SERVER_FINISHED_B
- ST_SEND_SERVER_HELLO_A
- ST_SEND_SERVER_HELLO_B
- ST_SEND_SERVER_VERIFY_A
- ST_SEND_SERVER_VERIFY_B
- ST_SERVER_START_ENCRYPTION
- ST_X509_GET_CLIENT_CERTIFICATE
- ST_X509_GET_SERVER_CERTIFICATE
- TXT_DES_192_EDE3_CBC_WITH_MD5
- TXT_DES_192_EDE3_CBC_WITH_SHA
- TXT_DES_64_CBC_WITH_MD5
- TXT_DES_64_CBC_WITH_SHA
- TXT_DES_64_CFB64_WITH_MD5_1
- TXT_IDEA_128_CBC_WITH_MD5
- TXT_NULL
- TXT_NULL_WITH_MD5
- TXT_RC2_128_CBC_EXPORT40_WITH_MD5
- TXT_RC2_128_CBC_WITH_MD5
- TXT_RC4_128_EXPORT40_WITH_MD5
- TXT_RC4_128_WITH_MD5
- VERIFY_CLIENT_ONCE
- VERIFY_FAIL_IF_NO_PEER_CERT
- VERIFY_NONE
- VERIFY_PEER
- WRITING
- X509_LOOKUP
- X509_V_FLAG_CB_ISSUER_CHECK
- X509_V_FLAG_USE_CHECK_TIME
- X509_V_FLAG_CRL_CHECK
- X509_V_FLAG_CRL_CHECK_ALL
- X509_V_FLAG_IGNORE_CRITICAL
- CTX_new
- CTX_v2_new
- CTX_v3_new
- CTX_v23_new
- CTX_free
- new
- free
- accept
- clear
- connect
- set_fd
- set_rfd
- set_wfd
- get_fd
- read
- write
- peek
- use_RSAPrivateKey
- use_RSAPrivateKey_ASN1
- use_RSAPrivateKey_file
- CTX_use_RSAPrivateKey_file
- use_PrivateKey
- use_PrivateKey_ASN1
- use_PrivateKey_file
- use_certificate
- use_certificate_ASN1
- use_certificate_file
- CTX_use_certificate_file
- load_error_strings
- ERR_load_SSL_strings
- ERR_load_RAND_strings
- state_string
- rstate_string
- state_string_long
- rstate_string_long
- get_time
- set_time
- get_timeout
- set_timeout
- copy_session_id
- set_read_ahead
- get_read_ahead
- pending
- get_cipher_list
- set_cipher_list
- get_cipher
- get_shared_ciphers
- get_peer_certificate
- set_verify
- flush_sessions
- set_bio
- get_rbio
- get_wbio
- SESSION_new
- SESSION_print
- SESSION_free
- i2d_SSL_SESSION
- set_session
- add_session
- remove_session
- d2i_SSL_SESSION
- BIO_f_ssl
- BIO_new
- BIO_new_file
- BIO_s_mem
- BIO_free
- BIO_read
- BIO_write
- BIO_eof
- BIO_pending
- BIO_wpending
- ERR_get_error
- ERR_error_string
- err
- clear_error
- X509_get_issuer_name
- X509_get_subject_name
- X509_NAME_oneline
- X509_NAME_get_text_by_NID
- CTX_get_cert_store
- X509_STORE_add_cert
- X509_STORE_add_crl
- X509_STORE_CTX_set_flags
- X509_load_cert_file
- X509_load_crl_file
- X509_load_cert_crl_file
- PEM_read_bio_X509_CRL
- die_if_ssl_error
- die_now
- print_errs
- set_cert_and_key
- set_server_cert_and_key
- make_form
- make_headers
- do_https
- get_https
- post_https
- get_https4
- post_https4
- sslcat
- ssl_read_CRLF
- ssl_read_all
- ssl_read_until
- ssl_write_CRLF
- ssl_write_all
- get_http
- post_http
- get_httpx
- post_httpx
- get_https3
- post_https3
- get_http4
- post_http4
- get_httpx4
- post_httpx4
- tcpcat
- tcpxcat
- tcp_read_CRLF
- tcp_read_all
- tcp_read_until
- tcp_write_CRLF
- tcp_write_all
- dump_peer_certificate
- RSA_generate_key
- RSA_free
- X509_free
- SESSION_get_master_key
- get_client_random
- get_server_random
-);
-
-sub AUTOLOAD {
- # This AUTOLOAD is used to 'autoload' constants from the constant()
- # XS function. If a constant is not found then control is passed
- # to the AUTOLOAD in AutoLoader.
-
- my $constname;
- ($constname = $AUTOLOAD) =~ s/.*:://;
- my $val = constant($constname);
- if ($! != 0) {
- if ($! =~ /((Invalid)|(not valid))/i || $!{EINVAL}) {
- $AutoLoader::AUTOLOAD = $AUTOLOAD;
- goto &AutoLoader::AUTOLOAD;
- }
- else {
- croak "Your vendor has not defined SSLeay macro $constname";
- }
- }
- eval "sub $AUTOLOAD { $val }";
- goto &$AUTOLOAD;
-}
-
-eval {
- require XSLoader;
- XSLoader::load('Net::SSLeay', $VERSION);
- 1;
-} or do {
- require DynaLoader;
- push @ISA, 'DynaLoader';
- bootstrap Net::SSLeay $VERSION;
-};
-
-# Preloaded methods go here.
-
-$CRLF = "\x0d\x0a"; # because \r\n is not fully portable
-
-### Print SSLeay error stack
-
-sub print_errs {
- my ($msg) = @_;
- my ($count, $err, $errs, $e) = (0,0,'');
- while ($err = ERR_get_error()) {
- $count ++;
- $e = "$msg $$: $count - " . ERR_error_string($err) . "\n";
- $errs .= $e;
- warn $e if $Net::SSLeay::trace;
- }
- return $errs;
-}
-
-# Death is conditional to SSLeay errors existing, i.e. this function checks
-# for errors and only dies in affirmative.
-# usage: Net::SSLeay::write($ssl, "foo") or die_if_ssl_error("SSL write ($!)");
-
-sub die_if_ssl_error {
- my ($msg) = @_;
- die "$$: $msg\n" if print_errs($msg);
-}
-
-# Unconditional death. Used to print SSLeay errors before dying.
-# usage: Net::SSLeay::connect($ssl) or die_now("Failed SSL connect ($!)");
-
-sub die_now {
- my ($msg) = @_;
- print_errs($msg);
- die "$$: $msg\n";
-}
-
-# Perl 5.6.* unicode support causes that length() no longer reliably
-# reflects the byte length of a string. This eval is to fix that.
-# Thanks to Sean Burke for the snippet.
-
-BEGIN{
-eval 'use bytes; sub blength ($) { length $_[0] }';
-$@ and eval ' sub blength ($) { length $_[0] }' ;
-}
-
-# Autoload methods go after =cut, and are processed by the autosplit program.
-
-1;
-__END__
-# Documentation. Use `perl-root/pod/pod2html SSLeay.pm` to output html
-
-=head1 NAME
-
-Net::SSLeay - Perl extension for using OpenSSL
-
-=head1 SYNOPSIS
-
- use Net::SSLeay qw(get_https post_https sslcat make_headers make_form);
-
- ($page) = get_https('www.bacus.pt', 443, '/'); # 1
-
- ($page, $response, %reply_headers)
- = get_https('www.bacus.pt', 443, '/', # 2
- make_headers(User-Agent => 'Cryptozilla/5.0b1',
- Referer => 'https://www.bacus.pt'
- ));
-
- ($page, $result, %headers) = # 2b
- = get_https('www.bacus.pt', 443, '/protected.html',
- make_headers(Authorization =>
- 'Basic ' . MIME::Base64::encode("$user:$pass",''))
- );
-
- ($page, $response, %reply_headers)
- = post_https('www.bacus.pt', 443, '/foo.cgi', '', # 3
- make_form(OK => '1',
- name => 'Sampo'
- ));
-
- $reply = sslcat($host, $port, $request); # 4
-
- ($reply, $err, $server_cert) = sslcat($host, $port, $request); # 5
-
- $Net::SSLeay::trace = 2; # 0=no debugging, 1=ciphers, 2=trace, 3=dump data
-
-=head1 DESCRIPTION
-
-There is a related module called C<Net::SSLeay::Handle> included in this
-distribution that you might want to use instead. It has its own pod
-documentation.
-
-This module offers some high level convinience functions for accessing
-web pages on SSL servers (for symmetry, same API is offered for
-accessing http servers, too), a C<sslcat()> function for writing your own
-clients, and finally access to the SSL api of SSLeay/OpenSSL package
-so you can write servers or clients for more complicated applications.
-
-For high level functions it is most convinient to import them to your
-main namespace as indicated in the synopsis.
-
-Case 1 demonstrates typical invocation of get_https() to fetch an HTML
-page from secure server. The first argument provides host name or ip
-in dotted decimal notation of the remote server to contact. Second
-argument is the TCP port at the remote end (your own port is picked
-arbitrarily from high numbered ports as usual for TCP). The third
-argument is the URL of the page without the host name part. If in
-doubt consult HTTP specifications at L<http://www.w3c.org>.
-
-Case 2 demonstrates full fledged use of C<get_https()>. As can be seen,
-C<get_https()> parses the response and response headers and returns them as
-a list, which can be captured in a hash for later reference. Also a
-fourth argument to C<get_https()> is used to insert some additional headers
-in the request. C<make_headers()> is a function that will convert a list or
-hash to such headers. By default C<get_https()> supplies C<Host> (make virtual
-hosting easy) and C<Accept> (reportedly needed by IIS) headers.
-
-Case 2b demonstrates how to get password protected page. Refer to
-HTTP protocol specifications for further details (e.g. RFC-2617).
-
-Case 3 invokes C<post_https()> to submit a HTML/CGI form to secure
-server. First four arguments are equal to C<get_https()> (note that empty
-string (C<''>) is passed as header argument). The fifth argument is the
-contents of the form formatted according to CGI specification. In this
-case the helper function C<make_https()> is used to do the formatting,
-but you could pass any string. The C<post_https()> automatically adds
-C<Content-Type> and C<Content-Length> headers to the request.
-
-Case 4 shows the fundamental C<sslcat()> function (inspired in spirit by
-C<netcat> utility :-). Its your swiss army knife that allows you to
-easily contact servers, send some data, and then get the response. You
-are responsible for formatting the data and parsing the response -
-C<sslcat()> is just a transport.
-
-Case 5 is a full invocation of C<sslcat()> which allows return of errors
-as well as the server (peer) certificate.
-
-The C<$trace> global variable can be used to control the verbosity of high
-level functions. Level 0 guarantees silence, level 1 (the default)
-only emits error messages.
-
-=head2 Alternate versions of the API
-
-The above mentioned functions actually return the response headers as
-a list, which only gets converted to hash upon assignment (this
-assignment looses information if the same header occurs twice, as may
-be the case with cookies). There are also other variants of the
-functions that return unprocessed headers and that return a reference
-to a hash.
-
- ($page, $response, @headers) = get_https('www.bacus.pt', 443, '/');
- for ($i = 0; $i < $#headers; $i+=2) {
- print "$headers[$i] = " . $headers[$i+1] . "\n";
- }
-
- ($page, $response, $headers, $server_cert)
- = get_https3('www.bacus.pt', 443, '/');
- print "$headers\n";
-
- ($page, $response, %headers_ref, $server_cert)
- = get_https4('www.bacus.pt', 443, '/');
- for $k (sort keys %{headers_ref}) {
- for $v (@{$headers_ref{$k}}) {
- print "$k = $v\n";
- }
- }
-
-All of the above code fragments accomplish the same thing: display all
-values of all headers. The API functions ending in "3" return the
-headers simply as a scalar string and it is up to the application to
-split them up. The functions ending in "4" return a reference to
-hash of arrays (see L<perlref> and L<perllol> if you are
-not familiar with complex perl data structures). To access single value
-of such header hash you would do something like
-
- print $headers_ref{COOKIE}[0];
-
-The variants 3 and 4 also allow you to discover the server certificate
-in case you would like to store or display it, e.g.
-
- ($p, $resp, $hdrs, $server_cert) = get_https3('www.bacus.pt', 443, '/');
- if (!defined($server_cert) || ($server_cert == 0)) {
- warn "Subject Name: undefined, Issuer Name: undefined";
- } else {
- warn 'Subject Name: '
- . Net::SSLeay::X509_NAME_oneline(
- Net::SSLeay::X509_get_subject_name($server_cert))
- . 'Issuer Name: '
- . Net::SSLeay::X509_NAME_oneline(
- Net::SSLeay::X509_get_issuer_name($server_cert));
- }
-
-Beware that this method only allows after the fact verification of
-the certificate: by the time C<get_https3()> has returned the https
-request has already been sent to the server, whether you decide to
-tryst it or not. To do the verification correctly you must either
-employ the OpenSSL certificate verification framework or use
-the lower level API to first connect and verify the certificate
-and only then send the http data. See implementation of C<ds_https3()>
-for guidance on how to do this.
-
-=head2 Using client certificates
-
-Secure web communications are encrypted using symmetric crypto keys
-exchanged using encryption based on the certificate of the
-server. Therefore in all SSL connections the server must have a
-certificate. This serves both to authenticate the server to the
-clients and to perform the key exchange.
-
-Sometimes it is necessary to authenticate the client as well. Two
-options are available: HTTP basic authentication and client side
-certificate. The basic authentication over HTTPS is actually quite
-safe because HTTPS guarantees that the password will not travel in
-clear. Never-the-less, problems like easily guessable passwords
-remain. The client certificate method involves authentication of the
-client at SSL level using a certificate. For this to work, both the
-client and the server will have certificates (which typically are
-different) and private keys.
-
-The API functions outlined above accept additional arguments that
-allow one to supply the client side certificate and key files. The
-format of these files is the same as used for server certificates and
-the caveat about encrypting private key applies.
-
- ($page, $result, %headers) = # 2c
- = get_https('www.bacus.pt', 443, '/protected.html',
- make_headers(Authorization =>
- 'Basic ' . MIME::Base64::encode("$user:$pass",'')),
- '', $mime_type6, $path_to_crt7, $path_to_key8);
-
- ($page, $response, %reply_headers)
- = post_https('www.bacus.pt', 443, '/foo.cgi', # 3b
- make_headers('Authorization' =>
- 'Basic ' . MIME::Base64::encode("$user:$pass",'')),
- make_form(OK => '1', name => 'Sampo'),
- $mime_type6, $path_to_crt7, $path_to_key8);
-
-Case 2c demonstrates getting password protected page that also requires
-client certificate, i.e. it is possible to use both authentication
-methods simultaneously.
-
-Case 3b is full blown post to secure server that requires both password
-authentication and client certificate, just like in case 2c.
-
-Note: Client will not send a certificate unless the server requests one.
-This is typically achieved by setting verify mode to C<VERIFY_PEER> on the
-server:
-
- Net::SSLeay::set_verify(ssl, Net::SSLeay::VERIFY_PEER, 0);
-
-See C<perldoc ~openssl/doc/ssl/SSL_CTX_set_verify.pod> for full description.
-
-=head2 Working through Web proxy
-
-C<Net::SSLeay> can use a web proxy to make its connections. You need to
-first set the proxy host and port using C<set_proxy()> and then just
-use the normal API functions, e.g:
-
- Net::SSLeay::set_proxy('gateway.myorg.com', 8080);
- ($page) = get_https('www.bacus.pt', 443, '/');
-
-If your proxy requires authentication, you can supply username and
-password as well
-
- Net::SSLeay::set_proxy('gateway.myorg.com', 8080, 'joe', 'salainen');
- ($page, $result, %headers) =
- = get_https('www.bacus.pt', 443, '/protected.html',
- make_headers(Authorization =>
- 'Basic ' . MIME::Base64::encode("susie:pass",''))
- );
-
-This example demonstrates case where we authenticate to the proxy as
-C<"joe"> and to the final web server as C<"susie">. Proxy authentication
-requires C<MIME::Base64> module to work.
-
-=head2 Certificate verification and Certificate Revoocation Lists (CRLs)
-
-OpenSSL supports the ability to verify peer certificates. It can also
-optionally check the peer certificate against a Certificate Revocation
-List (CRL) from the certificates issuer. A CRL is a file, created by
-the certificate issuer that lists all the certificates that it
-previously signed, but which it now revokes. CRLs are in PEM format.
-
-You can enable C<Net::SSLeay CRL> checking like this:
-
- &Net::SSLeay::X509_STORE_CTX_set_flags
- (&Net::SSLeay::CTX_get_cert_store($ssl),
- &Net::SSLeay::X509_V_FLAG_CRL_CHECK);
-
-After setting this flag, if OpenSSL checks a peer's certificate, then
-it will attempt to find a CRL for the issuer. It does this by looking
-for a specially named file in the search directory specified by
-CTX_load_verify_locations. CRL files are named with the hash of the
-issuer's subject name, followed by C<.r0>, C<.r1> etc. For example
-C<ab1331b2.r0>, C<ab1331b2.r1>. It will read all the .r files for the
-issuer, and then check for a revocation of the peer cerificate in all
-of them. (You can also force it to look in a specific named CRL
-file., see below). You can find out the hash of the issuer subject
-name in a CRL with
-
- openssl crl -in crl.pem -hash -noout
-
-If the peer certificate does not pass the revocation list, or if no
-CRL is found, then the handshaking fails with an error.
-
-You can also force OpenSSL to look for CRLs in one or more arbitrarily
-named files.
-
- my $bio = Net::SSLeay::BIO_new_file($crlfilename, 'r');
- my $crl = Net::SSLeay::PEM_read_bio_X509_CRL($bio);
- if ($crl) {
- Net::SSLeay::X509_STORE_add_crl(Net::SSLeay::CTX_get_cert_store($ssl, $crl);
- } else {
- error reading CRL....
- }
-
-
-=head2 Convenience routines
-
-To be used with Low level API
-
- Net::SSLeay::randomize($rn_seed_file,$additional_seed);
- Net::SSLeay::set_cert_and_key($ctx, $cert_path, $key_path);
- $cert = Net::SSLeay::dump_peer_certificate($ssl);
- Net::SSLeay::ssl_write_all($ssl, $message) or die "ssl write failure";
- $got = Net::SSLeay::ssl_read_all($ssl) or die "ssl read failure";
-
- $got = Net::SSLeay::ssl_read_CRLF($ssl [, $max_length]);
- $got = Net::SSLeay::ssl_read_until($ssl [, $delimit [, $max_length]]);
- Net::SSLeay::ssl_write_CRLF($ssl, $message);
-
-C<randomize()> seeds the eay PRNG with C</dev/urandom> (see top of C<SSLeay.pm>
-for how to change or configure this) and optionally with user provided
-data. It is very important to properly seed your random numbers, so
-do not forget to call this. The high level API functions automatically
-call C<randomize()> so it is not needed with them. See also caveats.
-
-C<set_cert_and_key()> takes two file names as arguments and sets
-the certificate and private key to those. This can be used to
-set either cerver certificates or client certificates.
-
-C<dump_peer_certificate()> allows you to get plaintext description of the
-certificate the peer (usually server) presented to us.
-
-C<ssl_read_all()> and C<ssl_write_all()> provide true blocking semantics for
-these operations (see limitation, below, for explanation). These are
-much preferred to the low level API equivalents (which implement BSD
-blocking semantics). The message argument to C<ssl_write_all()> can be
-reference. This is helpful to avoid unnecessary copy when writing
-something big, e.g:
-
- $data = 'A' x 1000000000;
- Net::SSLeay::ssl_write_all($ssl, \$data) or die "ssl write failed";
-
-C<ssl_read_CRLF()> uses C<ssl_read_all()> to read in a line terminated with a
-carriage return followed by a linefeed (CRLF). The CRLF is included in
-the returned scalar.
-
-C<ssl_read_until()> uses C<ssl_read_all()> to read from the SSL input
-stream until it encounters a programmer specified delimiter.
-If the delimiter is undefined, C<$/> is used. If C<$/> is undefined,
-C<\n> is used. One can optionally set a maximum length of bytes to read
-from the SSL input stream.
-
-C<ssl_write_CRLF()> writes C<$message> and appends CRLF to the SSL output stream.
-
-=head2 Low level API
-
-In addition to the high level functions outlined above, this module
-contains straight forward access to SSL part of OpenSSL C api. Only the SSL
-subpart of OpenSSL is implemented (if anyone wants to implement other
-parts, feel free to submit patches).
-
-See C<ssl.h> header from OpenSSL C distribution for list of low lever
-SSLeay functions to call (to check if some function has been
-implemented see directly in SSLeay.xs). The module strips SSLeay names
-of the initial C<"SSL_">, generally you should use C<Net::SSLeay::> in
-place. For example:
-
-In C:
-
- #include <ssl.h>
-
- err = SSL_set_verify (ssl, SSL_VERIFY_CLIENT_ONCE,
- &your_call_back_here);
-
-In Perl:
-
- use Net::SSLeay;
-
- $err = Net::SSLeay::set_verify ($ssl,
- Net::SSLeay::VERIFY_CLIENT_ONCE,
- \&your_call_back_here);
-
-If the function does not start by C<SSL_> you should use the full
-function name, e.g.:
-
- $err = Net::SSLeay::ERR_get_error;
-
-Following new functions behave in perlish way:
-
- $got = Net::SSLeay::read($ssl);
- # Performs SSL_read, but returns $got
- # resized according to data received.
- # Returns undef on failure.
-
- Net::SSLeay::write($ssl, $foo) || die;
- # Performs SSL_write, but automatically
- # figures out the size of $foo
-
-In order to use the low level API you should start your programs with
-the following incantation:
-
- use Net::SSLeay qw(die_now die_if_ssl_error);
- Net::SSLeay::load_error_strings();
- Net::SSLeay::SSLeay_add_ssl_algorithms(); # Important!
- Net::SSLeay::ENGINE_load_builtin_engines(); # If you want built-in engines
- Net::SSLeay::ENGINE_register_all_complete(); # If you want built-in engines
- Net::SSLeay::randomize();
-
-C<die_now()> and C<die_if_ssl_error()> are used to conveniently print SSLeay error
-stack when something goes wrong, thusly:
-
- Net::SSLeay::connect($ssl) or die_now("Failed SSL connect ($!)");
- Net::SSLeay::write($ssl, "foo") or die_if_ssl_error("SSL write ($!)");
-
-You can also use C<Net::SSLeay::print_errs()> to dump the error stack without
-exiting the program. As can be seen, your code becomes much more readable
-if you import the error reporting functions to your main name space.
-
-I can not emphasize enough the need to check error returns. Use these
-functions even in most simple programs, they will reduce debugging
-time greatly. Do not ask questions in mailing list without having
-first sprinkled these in your code.
-
-=head2 Sockets
-
-Perl uses file handles for all I/O. While SSLeay has quite flexible BIO
-mechanism and perl has evolved PerlIO mechanism, this module still
-sticks to using file descriptors. Thus to attach SSLeay to socket you
-should use C<fileno()> to extract the underlying file descriptor:
-
- Net::SSLeay::set_fd($ssl, fileno(S)); # Must use fileno
-
-You should also set C<$|> to 1 to eliminate STDIO buffering so you do not
-get confused if you use perl I/O functions to manipulate your socket
-handle.
-
-If you need to C<select(2)> on the socket, go right ahead, but be warned
-that OpenSSL does some internal buffering so SSL_read does not always
-return data even if socket selected for reading (just keep on
-selecting and trying to read). C<Net::SSLeay> is no different from the
-C language OpenSSL in this respect.
-
-=head2 Callbacks
-
-At this moment the implementation of verify_callback is crippeled in
-the sense that at any given time there can be only one call back which
-is shared by all SSL contexts, sessions and connections. This is
-due to having to keep the reference to the perl call back in a
-static variable so that the callback C glue can find it. To remove
-this restriction would require either a more complex data structure
-(like a hash?) in XSUB to map the call backs to their owners or,
-cleaner, adding a context pointer in the SSL structure. This context would
-then be passed to the C callback, which in our case would be the glue
-to look up the proper Perl function from the context and call it.
-
----- inaccurate ----
-The verify call back looks like this in C:
-
- int (*callback)(int ok,X509 *subj_cert,X509 *issuer_cert,
- int depth,int errorcode,char *arg,STACK *cert_chain)
-
-The corresponding Perl function should be something like this:
-
- sub verify {
- my ($ok, $subj_cert, $issuer_cert, $depth, $errorcode,
- $arg, $chain) = @_;
- print "Verifying certificate...\n";
- ...
- return $ok;
- }
-
-It is used like this:
-
- Net::SSLeay::set_verify ($ssl, Net::SSLeay::VERIFY_PEER, \&verify);
-
-Callbacks for decrypting private keys are implemented, but have the
-same limitation as the verify_callback implementation (one password
-callback shared between all contexts.) You might use it something
-like this:
-
- Net::SSLeay::CTX_set_default_passwd_cb($ctx, sub { "top-secret" });
- Net::SSLeay::CTX_use_PrivateKey_file($ctx, "key.pem",
- Net::SSLeay::FILETYPE_PEM)
- or die "Error reading private key";
- Net::SSLeay::CTX_set_default_passwd_cb($ctx, undef);
-
-No other callbacks are implemented. You do not need to use any
-callback for simple (i.e. normal) cases where the SSLeay built-in
-verify mechanism satisfies your needs.
-
-It is desirable to reset these callbacks to undef immediately after use to prevent
-thread safety problems and crashes on exit that can occur if different threads
-set different callbacks.
-
----- end inaccurate ----
-
-If you want to use callback stuff, see examples/callback.pl! Its the
-only one I am able to make work reliably.
-
-=head2 X509 and RAND stuff
-
-This module largely lacks interface to the X509 and RAND routines, but
-as I was lazy and needed them, the following kludges are implemented:
-
- $x509_name = Net::SSLeay::X509_get_subject_name($x509_cert);
- $x509_name = Net::SSLeay::X509_get_issuer_name($x509_cert);
- print Net::SSLeay::X509_NAME_oneline($x509_name);
- $text = Net::SSLeay::X509_NAME_get_text_by_NID($name, $nid);
-
- ($type1, $subject1, $type2, $subject2, ...) =
- Net::SSLeay::X509_get_subjectAltNames($x509_cert)
-
- subjectAltName types as per x509v3.h GEN_*, for example
- GEN_DNS or GEN_IPADD which can be imported.
-
- Net::SSLeay::RAND_seed($buf); # Perlishly figures out buf size
- Net::SSLeay::RAND_bytes($buf, $num);
- Net::SSLeay::RAND_pseudo_bytes($buf, $num);
- Net::SSLeay::RAND_add($buf, $num, $entropy);
- Net::SSLeay::RAND_poll();
- Net::SSLeay::RAND_status();
- Net::SSLeay::RAND_cleanup();
- Net::SSLeay::RAND_file_name($num);
- Net::SSLeay::RAND_load_file($file_name, $how_many_bytes);
- Net::SSLeay::RAND_write_file($file_name);
- Net::SSLeay::RAND_egd($path);
- Net::SSLeay::RAND_egd_bytes($path, $bytes);
-
-Actually you should consider using the following helper functions:
-
- print Net::SSLeay::dump_peer_certificate($ssl);
- Net::SSLeay::randomize();
-
-=head2 RSA interface
-
-Some RSA functions are available:
-
- $rsakey = Net::SSLeay::RSA_generate_key();
- Net::SSLeay::CTX_set_tmp_rsa($ctx, $rsakey);
- Net::SSLeay::RSA_free($rsakey);
-
-=head2 BIO interface
-
-Some BIO functions are available:
-
- Net::SSLeay::BIO_s_mem();
- $bio = Net::SSLeay::BIO_new(BIO_s_mem())
- $bio = Net::SSLeay::BIO_new_file($filename, $mode);
- Net::SSLeay::BIO_free($bio)
- $count = Net::SSLeay::BIO_write($data);
- $data = Net::SSLeay::BIO_read($bio);
- $data = Net::SSLeay::BIO_read($bio, $maxbytes);
- $is_eof = Net::SSLeay::BIO_eof($bio);
- $count = Net::SSLeay::BIO_pending($bio);
- $count = Net::SSLeay::BIO_wpending ($bio);
-
-=head2 Low level API
-
-Some very low level API functions are available:
-
- $client_random = Net::SSLeay::get_client_random($ssl);
- $server_random = Net::SSLeay::get_server_random($ssl);
- $session = Net::SSLeay::get_session($ssl);
- $master_key = Net::SSLeay::SESSION_get_master_key($session);
- Net::SSLeay::SESSION_set_master_key($session, $master_secret);
- $keyblocksize = Net::SSLeay::get_keyblock_size($session);
-
-=head2 HTTP (without S) API
-
-Over the years it has become clear that it would be convenient to use
-the light weight flavour API of C<Net::SSLeay> also for normal HTTP (see
-LWP for heavy weight object oriented approach). In fact it would be
-nice to be able to flip https on and off on the fly. Thus regular HTTP
-support was evolved.
-
- use Net::SSLeay qw(get_http post_http tcpcat
- get_httpx post_httpx tcpxcat
- make_headers make_form);
-
- ($page, $result, %headers) =
- = get_http('www.bacus.pt', 443, '/protected.html',
- make_headers(Authorization =>
- 'Basic ' . MIME::Base64::encode("$user:$pass",''))
- );
-
- ($page, $response, %reply_headers)
- = post_http('www.bacus.pt', 443, '/foo.cgi', '',
- make_form(OK => '1',
- name => 'Sampo'
- ));
-
- ($reply, $err) = tcpcat($host, $port, $request);
-
- ($page, $result, %headers) =
- = get_httpx($usessl, 'www.bacus.pt', 443, '/protected.html',
- make_headers(Authorization =>
- 'Basic ' . MIME::Base64::encode("$user:$pass",''))
- );
-
- ($page, $response, %reply_headers)
- = post_httpx($usessl, 'www.bacus.pt', 443, '/foo.cgi', '',
- make_form(OK => '1', name => 'Sampo' ));
-
- ($reply, $err, $server_cert) = tcpxcat($usessl, $host, $port, $request);
-
-As can be seen, the C<"x"> family of APIs takes as first argument a flag
-which indicated whether SSL is used or not.
-
-=head1 EXAMPLES
-
-One very good example is to look at the implementation of C<sslcat()> in the
-C<SSLeay.pm> file.
-
-Following is a simple SSLeay client (with too little error checking :-(
-
- #!/usr/local/bin/perl
- use Socket;
- use Net::SSLeay qw(die_now die_if_ssl_error) ;
- Net::SSLeay::load_error_strings();
- Net::SSLeay::SSLeay_add_ssl_algorithms();
- Net::SSLeay::randomize();
-
- ($dest_serv, $port, $msg) = @ARGV; # Read command line
- $port = getservbyname ($port, 'tcp') unless $port =~ /^\d+$/;
- $dest_ip = gethostbyname ($dest_serv);
- $dest_serv_params = sockaddr_in($port, $dest_ip);
-
- socket (S, &AF_INET, &SOCK_STREAM, 0) or die "socket: $!";
- connect (S, $dest_serv_params) or die "connect: $!";
- select (S); $| = 1; select (STDOUT); # Eliminate STDIO buffering
-
- # The network connection is now open, lets fire up SSL
-
- $ctx = Net::SSLeay::CTX_new() or die_now("Failed to create SSL_CTX $!");
- Net::SSLeay::CTX_set_options($ctx, &Net::SSLeay::OP_ALL)
- and die_if_ssl_error("ssl ctx set options");
- $ssl = Net::SSLeay::new($ctx) or die_now("Failed to create SSL $!");
- Net::SSLeay::set_fd($ssl, fileno(S)); # Must use fileno
- $res = Net::SSLeay::connect($ssl) and die_if_ssl_error("ssl connect");
- print "Cipher `" . Net::SSLeay::get_cipher($ssl) . "'\n";
-
- # Exchange data
-
- $res = Net::SSLeay::write($ssl, $msg); # Perl knows how long $msg is
- die_if_ssl_error("ssl write");
- CORE::shutdown S, 1; # Half close --> No more output, sends EOF to server
- $got = Net::SSLeay::read($ssl); # Perl returns undef on failure
- die_if_ssl_error("ssl read");
- print $got;
-
- Net::SSLeay::free ($ssl); # Tear down connection
- Net::SSLeay::CTX_free ($ctx);
- close S;
-
-Following is a simple SSLeay echo server (non forking):
-
- #!/usr/local/bin/perl -w
- use Socket;
- use Net::SSLeay qw(die_now die_if_ssl_error);
- Net::SSLeay::load_error_strings();
- Net::SSLeay::SSLeay_add_ssl_algorithms();
- Net::SSLeay::randomize();
-
- $our_ip = "\0\0\0\0"; # Bind to all interfaces
- $port = 1235;
- $sockaddr_template = 'S n a4 x8';
- $our_serv_params = pack ($sockaddr_template, &AF_INET, $port, $our_ip);
-
- socket (S, &AF_INET, &SOCK_STREAM, 0) or die "socket: $!";
- bind (S, $our_serv_params) or die "bind: $!";
- listen (S, 5) or die "listen: $!";
- $ctx = Net::SSLeay::CTX_new () or die_now("CTX_new ($ctx): $!");
- Net::SSLeay::CTX_set_options($ctx, &Net::SSLeay::OP_ALL)
- and die_if_ssl_error("ssl ctx set options");
-
- # Following will ask password unless private key is not encrypted
- Net::SSLeay::CTX_use_RSAPrivateKey_file ($ctx, 'plain-rsa.pem',
- &Net::SSLeay::FILETYPE_PEM);
- die_if_ssl_error("private key");
- Net::SSLeay::CTX_use_certificate_file ($ctx, 'plain-cert.pem',
- &Net::SSLeay::FILETYPE_PEM);
- die_if_ssl_error("certificate");
-
- while (1) {
- print "Accepting connections...\n";
- ($addr = accept (NS, S)) or die "accept: $!";
- select (NS); $| = 1; select (STDOUT); # Piping hot!
-
- ($af,$client_port,$client_ip) = unpack($sockaddr_template,$addr);
- @inetaddr = unpack('C4',$client_ip);
- print "$af connection from " .
- join ('.', @inetaddr) . ":$client_port\n";
-
- # We now have a network connection, lets fire up SSLeay...
-
- $ssl = Net::SSLeay::new($ctx) or die_now("SSL_new ($ssl): $!");
- Net::SSLeay::set_fd($ssl, fileno(NS));
-
- $err = Net::SSLeay::accept($ssl) and die_if_ssl_error('ssl accept');
- print "Cipher `" . Net::SSLeay::get_cipher($ssl) . "'\n";
-
- # Connected. Exchange some data.
-
- $got = Net::SSLeay::read($ssl); # Returns undef on fail
- die_if_ssl_error("ssl read");
- print "Got `$got' (" . length ($got) . " chars)\n";
-
- Net::SSLeay::write ($ssl, uc ($got)) or die "write: $!";
- die_if_ssl_error("ssl write");
-
- Net::SSLeay::free ($ssl); # Tear down connection
- close NS;
- }
-
-Yet another echo server. This one runs from C</etc/inetd.conf> so it avoids
-all the socket code overhead. Only caveat is opening rsa key file -
-it had better be without any encryption or else it will not know where
-to ask for the password. Note how C<STDIN> and C<STDOUT> are wired to SSL.
-
- #!/usr/local/bin/perl
- # /etc/inetd.conf
- # ssltst stream tcp nowait root /path/to/server.pl server.pl
- # /etc/services
- # ssltst 1234/tcp
-
- use Net::SSLeay qw(die_now die_if_ssl_error);
- Net::SSLeay::load_error_strings();
- Net::SSLeay::SSLeay_add_ssl_algorithms();
- Net::SSLeay::randomize();
-
- chdir '/key/dir' or die "chdir: $!";
- $| = 1; # Piping hot!
- open LOG, ">>/dev/console" or die "Can't open log file $!";
- select LOG; print "server.pl started\n";
-
- $ctx = Net::SSLeay::CTX_new() or die_now "CTX_new ($ctx) ($!)";
- $ssl = Net::SSLeay::new($ctx) or die_now "new ($ssl) ($!)";
- Net::SSLeay::set_options($ssl, &Net::SSLeay::OP_ALL)
- and die_if_ssl_error("ssl set options");
-
- # We get already open network connection from inetd, now we just
- # need to attach SSLeay to STDIN and STDOUT
- Net::SSLeay::set_rfd($ssl, fileno(STDIN));
- Net::SSLeay::set_wfd($ssl, fileno(STDOUT));
-
- Net::SSLeay::use_RSAPrivateKey_file ($ssl, 'plain-rsa.pem',
- Net::SSLeay::FILETYPE_PEM);
- die_if_ssl_error("private key");
- Net::SSLeay::use_certificate_file ($ssl, 'plain-cert.pem',
- Net::SSLeay::FILETYPE_PEM);
- die_if_ssl_error("certificate");
-
- Net::SSLeay::accept($ssl) and die_if_ssl_err("ssl accept: $!");
- print "Cipher `" . Net::SSLeay::get_cipher($ssl) . "'\n";
-
- $got = Net::SSLeay::read($ssl);
- die_if_ssl_error("ssl read");
- print "Got `$got' (" . length ($got) . " chars)\n";
-
- Net::SSLeay::write ($ssl, uc($got)) or die "write: $!";
- die_if_ssl_error("ssl write");
-
- Net::SSLeay::free ($ssl); # Tear down the connection
- Net::SSLeay::CTX_free ($ctx);
- close LOG;
-
-There are also a number of example/test programs in the examples directory:
-
- sslecho.pl - A simple server, not unlike the one above
- minicli.pl - Implements a client using low level SSLeay routines
- sslcat.pl - Demonstrates using high level sslcat utility function
- get_page.pl - Is a utility for getting html pages from secure servers
- callback.pl - Demonstrates certificate verification and callback usage
- stdio_bulk.pl - Does SSL over Unix pipes
- ssl-inetd-serv.pl - SSL server that can be invoked from inetd.conf
- httpd-proxy-snif.pl - Utility that allows you to see how a browser
- sends https request to given server and what reply
- it gets back (very educative :-)
- makecert.pl - Creates a self signed cert (does not use this module)
-
-=head1 LIMITATIONS
-
-C<Net::SSLeay::read()> uses internal buffer of 32KB, thus no single read
-will return more. In practice one read returns much less, usually
-as much as fits in one network packet. To work around this,
-you should use a loop like this:
-
- $reply = '';
- while ($got = Net::SSLeay::read($ssl)) {
- last if print_errs('SSL_read');
- $reply .= $got;
- }
-
-Although there is no built-in limit in C<Net::SSLeay::write()>, the network
-packet size limitation applies here as well, thus use:
-
- $written = 0;
-
- while ($written < length($message)) {
- $written += Net::SSLeay::write($ssl, substr($message, $written));
- last if print_errs('SSL_write');
- }
-
-Or alternatively you can just use the following convinence functions:
-
- Net::SSLeay::ssl_write_all($ssl, $message) or die "ssl write failure";
- $got = Net::SSLeay::ssl_read_all($ssl) or die "ssl read failure";
-
-=head1 KNOWN BUGS AND CAVEATS
-
-Autoloader emits
-
- Argument "xxx" isn't numeric in entersub at blib/lib/Net/SSLeay.pm'
-
-warning if die_if_ssl_error is made autoloadable. If you figure out why,
-drop me a line.
-
-Callback set using C<SSL_set_verify()> does not appear to work. This may
-well be eay problem (e.g. see C<ssl/ssl_lib.c> line 1029). Try using
-C<SSL_CTX_set_verify()> instead and do not be surprised if even this stops
-working in future versions.
-
-Callback and certificate verification stuff is generally too little tested.
-
-Random numbers are not initialized randomly enough, especially if you
-do not have C</dev/random> and/or C</dev/urandom> (such as in Solaris
-platforms - but I've been suggested that cryptorand daemon from SUNski
-package solves this). In this case you should investigate third party
-software that can emulate these devices, e.g. by way of a named pipe
-to some program.
-
-Another gotcha with random number initialization is randomness
-depletion. This phenomenon, which has been extensively discussed in
-OpenSSL, Apache-SSL, and Apache-mod_ssl forums, can cause your
-script to block if you use C</dev/random> or to operate insecurely
-if you use C</dev/urandom>. What happens is that when too much
-randomness is drawn from the operating system's randomness pool
-then randomness can temporarily be unavailable. C</dev/random> solves
-this problem by waiting until enough randomness can be gathered - and
-this can take a long time since blocking reduces activity in the
-machine and less activity provides less random events: a vicious circle.
-C</dev/urandom> solves this dilemma more pragmatically by simply returning
-predictable "random" numbers. SomeC< /dev/urandom> emulation software
-however actually seems to implement C</dev/random> semantics. Caveat emptor.
-
-I've been pointed to two such daemons by Mik Firestone <mik@@speed.stdio._com>
-who has used them on Solaris 8:
-
-=over
-
-=item 1
-
-Entropy Gathering Daemon (EGD) at L<http://www.lothar.com/tech/crypto/>
-
-=item 2
-
-Pseudo-random number generating daemon (PRNGD) at
-L<http://www.aet.tu-cottbus.de/personen/jaenicke/postfix_tls/prngd.html>
-
-=back
-
-If you are using the low level API functions to communicate with other
-SSL implementations, you would do well to call
-
- Net::SSLeay::CTX_set_options($ctx, &Net::SSLeay::OP_ALL)
- and die_if_ssl_error("ssl ctx set options");
-
-to cope with some well know bugs in some other SSL
-implementations. The high level API functions always set all known
-compatibility options.
-
-Sometimes C<sslcat()> (and the high level HTTPS functions that build on it)
-is too fast in signaling the EOF to legacy HTTPS servers. This causes
-the server to return empty page. To work around this problem you can
-set global variable
-
- $Net::SSLeay::slowly = 1; # Add sleep so broken servers can keep up
-
-HTTP/1.1 is not supported. Specifically this module does not know to
-issue or serve multiple http requests per connection. This is a serious
-short coming, but using SSL session cache on your server helps to
-alleviate the CPU load somewhat.
-
-As of version 1.09 many newer OpenSSL auxiliary functions were
-added (from C<REM_AUTOMATICALLY_GENERATED_1_09> onwards in C<SSLeay.xs>).
-Unfortunately I have not had any opportunity to test these. Some of
-them are trivial enough that I believe they "just work", but others
-have rather complex interfaces with function pointers and all. In these
-cases you should proceed wit great caution.
-
-This module defaults to using OpenSSL automatic protocol negotiation
-code for automatically detecting the version of the SSL protocol
-that the other end talks. With most web servers this works just
-fine, but once in a while I get complaints from people that the module
-does not work with some web servers. Usually this can be solved
-by explicitly setting the protocol version, e.g.
-
- $Net::SSLeay::ssl_version = 2; # Insist on SSLv2
- $Net::SSLeay::ssl_version = 3; # Insist on SSLv3
- $Net::SSLeay::ssl_version = 10; # Insist on TLSv1
-
-Although the autonegotiation is nice to have, the SSL standards
-do not formally specify any such mechanism. Most of the world has
-accepted the SSLeay/OpenSSL way of doing it as the de facto standard. But
-for the few that think differently, you have to explicitly speak
-the correct version. This is not really a bug, but rather a deficiency
-in the standards. If a site refuses to respond or sends back some
-nonsensical error codes (at SSL handshake level), try this option
-before mailing me.
-
-The high level API returns the certificate of the peer, thus allowing
-one to check what certificate was supplied. However, you will only be
-able to check the certificate after the fact, i.e. you already sent
-your form data by the time you find out that you did not trust them,
-oops.
-
-So, while being able to know the certificate after the fact is surely
-useful, the security minded would still choose to do the connection
-and certificate verification first and only after that exchange data
-with the site. Currently none of the high level API functions do
-this, thus you would have to program it using the low level API. A
-good place to start is to see how C<Net::SSLeay::http_cat()> function
-is implemented.
-
-The high level API functions use a global file handle C<SSLCAT_S>
-internally. This really should not be a problem because there is no
-way to interleave the high level API functions, unless you use threads
-(but threads are not very well supported in perl anyway (as of version
-5.6.1). However, you may run into problems if you call undocumented
-internal functions in an interleaved fashion.
-
-=head1 DIAGNOSTICS
-
-=over
-
-=item Random number generator not seeded!!!
-
-B<(W)> This warning indicates that C<randomize()> was not able to read
-C</dev/random> or C</dev/urandom>, possibly because your system does not
-have them or they are differently named. You can still use SSL, but
-the encryption will not be as strong.
-
-=item open_tcp_connection: destination host not found:`server' (port 123) ($!)
-
-Name lookup for host named C<server> failed.
-
-=item open_tcp_connection: failed `server', 123 ($!)
-
-The name was resolved, but establising the TCP connection failed.
-
-=item msg 123: 1 - error:140770F8:SSL routines:SSL23_GET_SERVER_HELLO:unknown proto
-
-SSLeay error string. First (123) number is PID, second number (1) indicates
-the position of the error message in SSLeay error stack. You often see
-a pile of these messages as errors cascade.
-
-=item msg 123: 1 - error:02001002::lib(2) :func(1) :reason(2)
-
-The same as above, but you didn't call load_error_strings() so SSLeay
-couldn't verbosely explain the error. You can still find out what it
-means with this command:
-
- /usr/local/ssl/bin/ssleay errstr 02001002
-
-=item Password is being asked for private key
-
-This is normal behaviour if your private key is encrypted. Either
-you have to supply the password or you have to use unencrypted
-private key. Scan OpenSSL.org for the FAQ that explains how to
-do this (or just study examples/makecert.pl which is used
-during C<make test> to do just that).
-
-=back
-
-=head1 REPORTING BUGS AND SUPPORT
-
-Bug reports, patch submission, feature requests, subversion access to the latest
-source code etc can be obtained at
-L<http://alioth.debian.org/projects/net-ssleay>
-
-The developer mailing list (for people interested in contributin to the source code)
-can be found at
-L<http://lists.alioth.debian.org/mailman/listinfo/net-ssleay-devel>
-
-Commercial support for Net::SSLeay may be obtained from
-
- Symlabs (netssleay@symlabs.com)
- Tel: +351-214.222.630
- Fax: +351-214.222.637
-
-=head1 VERSION
-
-There are currently two perl modules for using OpenSSL C
-library: C<Net::SSLeay> (maintaned by me) and C<SSLeay> (maintained by OpenSSL
-team). This module is the C<Net::SSLeay> variant.
-
-At the time of making this release, Eric's module was still quite
-sketchy and could not be used for real work, thus I felt motivated to
-make this maintenance release. This module is not planned to evolve to
-contain any further functionality, i.e. I will concentrate on just
-making a simple SSL connection over TCP socket. Presumably Eric's own
-module will offer full SSLeay API one day.
-
-This module uses OpenSSL-0.9.6c. It does not work with any earlier
-version and there is no guarantee that it will work with later
-versions either, though as long as C API does not change, it
-should. This module requires Perl 5.005 or newer, though I
-believe it would build with Perl 5.002 or newer.
-
-=head1 BUGS
-
-Please report any bugs or feature requests to
-C<bug-net_ssleay.pm at rt.cpan.org>, or through the web interface at
-L<http://rt.cpan.org/Public/Dist/Display.html?Name=Net_SSLeay.pm>.
-I will be notified, and then you'll automatically be notified of progress on
-your bug as I make changes.
-
-=head1 SUPPORT
-
-You can find documentation for this module with the C<perldoc> command.
-
- perldoc Net::SSLeay
-
-You can also look for information at:
-
-=over 4
-
-=item * AnnoCPAN: Annotated CPAN documentation
-
-L<http://annocpan.org/dist/Net_SSLeay.pm>
-
-=item * CPAN Ratings
-
-L<http://cpanratings.perl.org/d/Net_SSLeay.pm>
-
-=item * RT: CPAN's request tracker
-
-L<http://rt.cpan.org/Public/Dist/Display.html?Name=Net_SSLeay.pm>
-
-=item * Search CPAN
-
-L<http://search.cpan.org/dist/Net_SSLeay.pm>
-
-=back
-
-=head1 AUTHOR
-
-Maintained by Mike McCauley and Florian Ragwitz since November 2005
-
-Originally written by Sampo Kellomäki <sampo@symlabs.com>
-
-=head1 COPYRIGHT
-
-Copyright (c) 1996-2003 Sampo Kellomäki <sampo@symlabs.com>
-
-Copyright (C) 2005-2006 Florian Ragwitz <rafl@debian.org>
-
-Copyright (C) 2005 Mike McCauley <mikem@open.com.au>
-
-All Rights Reserved.
-
-Distribution and use of this module is under the same terms as the
-OpenSSL package itself (i.e. free, but mandatory attribution; NO
-WARRANTY). Please consult LICENSE file in the root of the OpenSSL
-distribution.
-
-While the source distribution of this perl module does not contain
-Eric's or OpenSSL's code, if you use this module you will use OpenSSL
-library. Please give Eric and OpenSSL team credit (as required by
-their licenses).
-
-And remember, you, and nobody else but you, are responsible for
-auditing this module and OpenSSL library for security problems,
-backdoors, and general suitability for your application.
-
-=head1 SEE ALSO
-
- Net::SSLeay::Handle - File handle interface
- ./Net_SSLeay/examples - Example servers and a clients
- <http://symlabs.com/Net_SSLeay/index.html> - Net::SSLeay.pm home
- <http://symlabs.com/Net_SSLeay/smime.html> - Another module using OpenSSL
- <http://www.openssl.org/> - OpenSSL source, documentation, etc
- openssl-users-request@openssl.org - General OpenSSL mailing list
- <http://home.netscape.com/newsref/std/SSL.html> - SSL Draft specification
- <http://www.w3c.org> - HTTP specifications
- <http://www.ietf.org/rfc/rfc2617.txt> - How to send password
- <http://www.lothar.com/tech/crypto/> - Entropy Gathering Daemon (EGD)
- <http://www.aet.tu-cottbus.de/personen/jaenicke/postfix_tls/prngd.html>
- - pseudo-random number generating daemon (PRNGD)
- perl(1)
- perlref(1)
- perllol(1)
- perldoc ~openssl/doc/ssl/SSL_CTX_set_verify.pod
-
-=cut
-
-# ';
-
-### Some methods that are macros in C
-
-sub want_nothing { want(shift) == 1 }
-sub want_read { want(shift) == 2 }
-sub want_write { want(shift) == 3 }
-sub want_X509_lookup { want(shift) == 4 }
-
-###
-### Open TCP stream to given host and port, looking up the details
-### from system databases or DNS.
-###
-
-sub open_tcp_connection {
- my ($dest_serv, $port) = @_;
- my ($errs);
-
- $port = getservbyname($port, 'tcp') unless $port =~ /^\d+$/;
- my $dest_serv_ip = gethostbyname($dest_serv);
- unless (defined($dest_serv_ip)) {
- $errs = "$0 $$: open_tcp_connection: destination host not found:"
- . " `$dest_serv' (port $port) ($!)\n";
- warn $errs if $trace;
- return wantarray ? (0, $errs) : 0;
- }
- my $sin = sockaddr_in($port, $dest_serv_ip);
-
- warn "Opening connection to $dest_serv:$port (" .
- inet_ntoa($dest_serv_ip) . ")" if $trace>2;
-
- my $proto = getprotobyname('tcp');
- if (socket (SSLCAT_S, &PF_INET(), &SOCK_STREAM(), $proto)) {
- warn "next connect" if $trace>3;
- if (CORE::connect (SSLCAT_S, $sin)) {
- my $old_out = select (SSLCAT_S); $| = 1; select ($old_out);
- warn "connected to $dest_serv, $port" if $trace>3;
- return wantarray ? (1, undef) : 1; # Success
- }
- }
- $errs = "$0 $$: open_tcp_connection: failed `$dest_serv', $port ($!)\n";
- warn $errs if $trace;
- close SSLCAT_S;
- return wantarray ? (0, $errs) : 0; # Fail
-}
-
-### Open connection via standard web proxy, if one was defined
-### using set_proxy().
-
-sub open_proxy_tcp_connection {
- my ($dest_serv, $port) = @_;
- return open_tcp_connection($dest_serv, $port) if !$proxyhost;
-
- warn "Connect via proxy: $proxyhost:$proxyport" if $trace>2;
- my ($ret, $errs) = open_tcp_connection($proxyhost, $proxyport);
- return wantarray ? (0, $errs) : 0 if !$ret; # Connection fail
-
- warn "Asking proxy to connect to $dest_serv:$port" if $trace>2;
- #print SSLCAT_S "CONNECT $dest_serv:$port HTTP/1.0$proxyauth$CRLF$CRLF";
- #my $line = <SSLCAT_S>; # *** bug? Mixing stdio with syscall read?
- ($ret, $errs) =
- tcp_write_all("CONNECT $dest_serv:$port HTTP/1.0$proxyauth$CRLF$CRLF");
- return wantarray ? (0,$errs) : 0 if $errs;
- ($line, $errs) = tcp_read_until($CRLF . $CRLF, 1024);
- warn "Proxy response: $line" if $trace>2;
- return wantarray ? (0,$errs) : 0 if $errs;
- return wantarray ? (1,'') : 1; # Success
-}
-
-###
-### read and write helpers that block
-###
-
-sub debug_read {
- my ($replyr, $gotr) = @_;
- my $vm = $trace>2 && $linux_debug ?
- (split ' ', `cat /proc/$$/stat`)[22] : 'vm_unknown';
- warn " got " . blength($$gotr) . ':'
- . blength($$replyr) . " bytes (VM=$vm).\n" if $trace == 3;
- warn " got `$$gotr' (" . blength($$gotr) . ':'
- . blength($$replyr) . " bytes, VM=$vm)\n" if $trace>3;
-}
-
-sub ssl_read_all {
- my ($ssl,$how_much) = @_;
- $how_much = 2000000000 unless $how_much;
- my ($got, $errs);
- my $reply = '';
-
- while ($how_much > 0) {
- $got = Net::SSLeay::read($ssl,
- ($how_much > 32768) ? 32768 : $how_much
- );
- last if $errs = print_errs('SSL_read');
- $how_much -= blength($got);
- debug_read(\$reply, \$got) if $trace>1;
- last if $got eq ''; # EOF
- $reply .= $got;
- }
-
- return wantarray ? ($reply, $errs) : $reply;
-}
-
-sub tcp_read_all {
- my ($how_much) = @_;
- $how_much = 2000000000 unless $how_much;
- my ($n, $got, $errs);
- my $reply = '';
-
- my $bsize = 0x10000;
- while ($how_much > 0) {
- $n = sysread(SSLCAT_S,$got, (($bsize < $how_much) ? $bsize : $how_much));
- warn "Read error: $! ($n,$how_much)" unless defined $n;
- last if !$n; # EOF
- $how_much -= $n;
- debug_read(\$reply, \$got) if $trace>1;
- $reply .= $got;
- }
- return wantarray ? ($reply, $errs) : $reply;
-}
-
-sub ssl_write_all {
- my $ssl = $_[0];
- my ($data_ref, $errs);
- if (ref $_[1]) {
- $data_ref = $_[1];
- } else {
- $data_ref = \$_[1];
- }
- my ($wrote, $written, $to_write) = (0,0, blength($$data_ref));
- my $vm = $trace>2 && $linux_debug ?
- (split ' ', `cat /proc/$$/stat`)[22] : 'vm_unknown';
- warn " write_all VM at entry=$vm\n" if $trace>2;
- while ($to_write) {
- #sleep 1; # *** DEBUG
- warn "partial `$$data_ref'\n" if $trace>3;
- $wrote = write_partial($ssl, $written, $to_write, $$data_ref);
- if (defined $wrote && ($wrote > 0)) { # write_partial can return -1
- $written += $wrote;
- $to_write -= $wrote;
- }
- $vm = $trace>2 && $linux_debug ?
- (split ' ', `cat /proc/$$/stat`)[22] : 'vm_unknown';
- warn " written so far $wrote:$written bytes (VM=$vm)\n" if $trace>2;
-
- $errs .= print_errs('SSL_write');
- return (wantarray ? (undef, $errs) : undef) if $errs;
- }
- return wantarray ? ($written, $errs) : $written;
-}
-
-sub tcp_write_all {
- my ($data_ref, $errs);
- if (ref $_[0]) {
- $data_ref = $_[0];
- } else {
- $data_ref = \$_[0];
- }
- my ($wrote, $written, $to_write) = (0,0, blength($$data_ref));
- my $vm = $trace>2 && $linux_debug ?
- (split ' ', `cat /proc/$$/stat`)[22] : 'vm_unknown';
- warn " write_all VM at entry=$vm to_write=$to_write\n" if $trace>2;
- while ($to_write) {
- warn "partial `$$data_ref'\n" if $trace>3;
- $wrote = syswrite(SSLCAT_S, $$data_ref, $to_write, $written);
- if (defined $wrote && ($wrote > 0)) { # write_partial can return -1
- $written += $wrote;
- $to_write -= $wrote;
- } elsif (!defined($wrote)) {
- warn "tcp_write_all: $!";
- return (wantarray ? (undef, "$!") : undef);
- }
- $vm = $trace>2 && $linux_debug ?
- (split ' ', `cat /proc/$$/stat`)[22] : 'vm_unknown';
- warn " written so far $wrote:$written bytes (VM=$vm)\n" if $trace>2;
- }
- return wantarray ? ($written, '') : $written;
-}
-
-### from patch by Clinton Wong <clintdw@netcom.com>
-
-# ssl_read_until($ssl [, $delimit [, $max_length]])
-# if $delimit missing, use $/ if it exists, otherwise use \n
-# read until delimiter reached, up to $max_length chars if defined
-
-sub ssl_read_until ($;$$) {
- my ($ssl,$delim, $max_length) = @_;
- local $[;
-
- # guess the delim string if missing
- if ( ! defined $delim ) {
- if ( defined $/ && length $/ ) { $delim = $/ }
- else { $delim = "\n" } # Note: \n,$/ value depends on the platform
- }
- my $len_delim = length $delim;
-
- my ($got);
- my $reply = '';
-
- # If we have OpenSSL 0.9.6a or later, we can use SSL_peek to
- # speed things up.
- # N.B. 0.9.6a has security problems, so the support for
- # anything earlier than 0.9.6e will be dropped soon.
- if (&Net::SSLeay::OPENSSL_VERSION_NUMBER >= 0x0090601f) {
- $max_length = 2000000000 unless (defined $max_length);
- my ($pending, $peek_length, $found, $done);
- while (blength($reply) < $max_length and !$done) {
- #Block if necessary until we get some data
- $got = Net::SSLeay::peek($ssl,1);
- last if print_errs('SSL_peek');
-
- $pending = Net::SSLeay::pending($ssl) + blength($reply);
- $peek_length = ($pending > $max_length) ? $max_length : $pending;
- $peek_length -= blength($reply);
- $got = Net::SSLeay::peek($ssl, $peek_length);
- last if print_errs('SSL_peek');
- $peek_length = blength($got);
-
- #$found = index($got, $delim); # Old and broken
-
- # the delimiter may be split across two gets, so we prepend
- # a little from the last get onto this one before we check
- # for a match
- my $match;
- if(blength($reply) >= blength($delim) - 1) {
- #if what we've read so far is greater or equal
- #in length of what we need to prepatch
- $match = substr $reply, blength($reply) - blength($delim) + 1;
- } else {
- $match = $reply;
- }
-
- $match .= $got;
- $found = index($match, $delim);
-
- if ($found > -1) {
- #$got = Net::SSLeay::read($ssl, $found+$len_delim);
- #read up to the end of the delimiter
- $got = Net::SSLeay::read($ssl,
- $found + $len_delim
- - ((blength $match) - (blength $got)));
- $done = 1;
- } else {
- $got = Net::SSLeay::read($ssl, $peek_length);
- $done = 1 if ($peek_length == $max_length - blength($reply));
- }
-
- last if print_errs('SSL_read');
- debug_read(\$reply, \$got) if $trace>1;
- last if $got eq '';
- $reply .= $got;
- }
- } else {
- while (!defined $max_length || length $reply < $max_length) {
- $got = Net::SSLeay::read($ssl,1); # one by one
- last if print_errs('SSL_read');
- debug_read(\$reply, \$got) if $trace>1;
- last if $got eq '';
- $reply .= $got;
- last if $len_delim
- && substr($reply, blength($reply)-$len_delim) eq $delim;
- }
- }
- return $reply;
-}
-
-sub tcp_read_until {
- my ($delim, $max_length) = @_;
- local $[;
-
- # guess the delim string if missing
- if ( ! defined $delim ) {
- if ( defined $/ && length $/ ) { $delim = $/ }
- else { $delim = "\n" } # Note: \n,$/ value depends on the platform
- }
- my $len_delim = length $delim;
-
- my ($n,$got);
- my $reply = '';
-
- while (!defined $max_length || length $reply < $max_length) {
- $n = sysread(SSLCAT_S, $got, 1); # one by one
- warn "tcp_read_until: $!" if !defined $n;
- debug_read(\$reply, \$got) if $trace>1;
- last if !$n; # EOF
- $reply .= $got;
- last if $len_delim
- && substr($reply, blength($reply)-$len_delim) eq $delim;
- }
- return $reply;
-}
-
-# ssl_read_CRLF($ssl [, $max_length])
-sub ssl_read_CRLF ($;$) { ssl_read_until($_[0], $CRLF, $_[1]) }
-sub tcp_read_CRLF { tcp_read_until($CRLF, $_[0]) }
-
-# ssl_write_CRLF($ssl, $message) writes $message and appends CRLF
-sub ssl_write_CRLF ($$) {
- # the next line uses less memory but might use more network packets
- return ssl_write_all($_[0], $_[1]) + ssl_write_all($_[0], $CRLF);
-
- # the next few lines do the same thing at the expense of memory, with
- # the chance that it will use less packets, since CRLF is in the original
- # message and won't be sent separately.
-
- #my $data_ref;
- #if (ref $_[1]) { $data_ref = $_[1] }
- # else { $data_ref = \$_[1] }
- #my $message = $$data_ref . $CRLF;
- #return ssl_write_all($_[0], \$message);
-}
-
-sub tcp_write_CRLF {
- # the next line uses less memory but might use more network packets
- return tcp_write_all($_[0]) + tcp_write_all($CRLF);
-
- # the next few lines do the same thing at the expense of memory, with
- # the chance that it will use less packets, since CRLF is in the original
- # message and won't be sent separately.
-
- #my $data_ref;
- #if (ref $_[1]) { $data_ref = $_[1] }
- # else { $data_ref = \$_[1] }
- #my $message = $$data_ref . $CRLF;
- #return tcp_write_all($_[0], \$message);
-}
-
-### Quickly print out with whom we're talking
-
-sub dump_peer_certificate ($) {
- my ($ssl) = @_;
- my $cert = get_peer_certificate($ssl);
- return if print_errs('get_peer_certificate');
- print "no cert defined\n" if !defined($cert);
- # Cipher=NONE with empty cert fix
- if (!defined($cert) || ($cert == 0)) {
- warn "cert = `$cert'\n" if $trace;
- return "Subject Name: undefined\nIssuer Name: undefined\n";
- } else {
- my $x = 'Subject Name: '
- . X509_NAME_oneline(X509_get_subject_name($cert)) . "\n"
- . 'Issuer Name: '
- . X509_NAME_oneline(X509_get_issuer_name($cert)) . "\n";
- Net::SSLeay::X509_free($cert);
- return $x;
- }
-}
-
-### Arrange some randomness for eay PRNG
-
-sub randomize (;$$) {
- my ($rn_seed_file, $seed, $egd_path) = @_;
- my $rnsf = defined($rn_seed_file) && -r $rn_seed_file;
-
- $egd_path = '';
- $egd_path = $ENV{'EGD_PATH'} if $ENV{'EGD_PATH'};
-
- RAND_seed(rand() + $$); # Stir it with time and pid
-
- unless ($rnsf || -r $Net::SSLeay::random_device || $seed || -S $egd_path) {
- warn "Random number generator not seeded!!!" if $trace;
- }
-
- RAND_load_file($rn_seed_file, -s _) if $rnsf;
- RAND_seed($seed) if $seed;
- RAND_seed($ENV{RND_SEED}) if $ENV{RND_SEED};
- RAND_egd($egd_path) if -e $egd_path && -S _;
- RAND_load_file($Net::SSLeay::random_device, $Net::SSLeay::how_random/8)
- if -r $Net::SSLeay::random_device;
-}
-
-sub new_x_ctx {
- if ($ssl_version == 2) { $ctx = CTX_v2_new(); }
- elsif ($ssl_version == 3) { $ctx = CTX_v3_new(); }
- elsif ($ssl_version == 10) { $ctx = CTX_tlsv1_new(); }
- else { $ctx = CTX_new(); }
- return $ctx;
-}
-
-###
-### Basic request - response primitive (don't use for https)
-###
-
-sub sslcat { # address, port, message, $crt, $key --> reply / (reply,errs,cert)
- my ($dest_serv, $port, $out_message, $crt_path, $key_path) = @_;
- my ($ctx, $ssl, $got, $errs, $written);
-
- ($got, $errs) = open_proxy_tcp_connection($dest_serv, $port);
- return (wantarray ? (undef, $errs) : undef) unless $got;
-
- ### Do SSL negotiation stuff
-
- warn "Creating SSL $ssl_version context...\n" if $trace>2;
- load_error_strings(); # Some bloat, but I'm after ease of use
- SSLeay_add_ssl_algorithms(); # and debuggability.
- randomize();
-
- $ctx = new_x_ctx();
- goto cleanup2 if $errs = print_errs('CTX_new') or !$ctx;
-
- CTX_set_options($ctx, &OP_ALL);
- goto cleanup2 if $errs = print_errs('CTX_set_options');
-
- warn "Cert `$crt_path' given without key" if $crt_path && !$key_path;
- set_cert_and_key($ctx, $crt_path, $key_path) if $crt_path;
-
- warn "Creating SSL connection (context was '$ctx')...\n" if $trace>2;
- $ssl = new($ctx);
- goto cleanup if $errs = print_errs('SSL_new') or !$ssl;
-
- warn "Setting fd (ctx $ctx, con $ssl)...\n" if $trace>2;
- set_fd($ssl, fileno(SSLCAT_S));
- goto cleanup if $errs = print_errs('set_fd');
-
- warn "Entering SSL negotiation phase...\n" if $trace>2;
-
- if ($trace>2) {
- my $i = 0;
- my $p = '';
- my $cipher_list = 'Cipher list: ';
- $p=Net::SSLeay::get_cipher_list($ssl,$i);
- $cipher_list .= $p if $p;
- do {
- $i++;
- $cipher_list .= ', ' . $p if $p;
- $p=Net::SSLeay::get_cipher_list($ssl,$i);
- } while $p;
- $cipher_list .= '\n';
- warn $cipher_list;
- }
-
- $got = Net::SSLeay::connect($ssl);
- warn "SSLeay connect returned $got\n" if $trace>2;
- goto cleanup if $errs = print_errs('SSL_connect');
-
- my $server_cert = get_peer_certificate($ssl);
- print_errs('get_peer_certificate');
- if ($trace>1) {
- warn "Cipher `" . get_cipher($ssl) . "'\n";
- print_errs('get_ciper');
- warn dump_peer_certificate($ssl);
- }
-
- ### Connected. Exchange some data (doing repeated tries if necessary).
-
- warn "sslcat $$: sending " . blength($out_message) . " bytes...\n"
- if $trace==3;
- warn "sslcat $$: sending `$out_message' (" . blength($out_message)
- . " bytes)...\n" if $trace>3;
- ($written, $errs) = ssl_write_all($ssl, $out_message);
- goto cleanup unless $written;
-
- sleep $slowly if $slowly; # Closing too soon can abort broken servers
- CORE::shutdown SSLCAT_S, 1; # Half close --> No more output, send EOF to server
-
- warn "waiting for reply...\n" if $trace>2;
- ($got, $errs) = ssl_read_all($ssl);
- warn "Got " . blength($got) . " bytes.\n" if $trace==3;
- warn "Got `$got' (" . blength($got) . " bytes)\n" if $trace>3;
-
-cleanup:
- free ($ssl);
- $errs .= print_errs('SSL_free');
-cleanup2:
- CTX_free ($ctx);
- $errs .= print_errs('CTX_free');
- close SSLCAT_S;
- return wantarray ? ($got, $errs, $server_cert) : $got;
-}
-
-sub tcpcat { # address, port, message, $crt, $key --> reply / (reply,errs,cert)
- my ($dest_serv, $port, $out_message) = @_;
- my ($got, $errs, $written);
-
- ($got, $errs) = open_proxy_tcp_connection($dest_serv, $port);
- return (wantarray ? (undef, $errs) : undef) unless $got;
-
- ### Connected. Exchange some data (doing repeated tries if necessary).
-
- warn "tcpcat $$: sending " . blength($out_message) . " bytes...\n"
- if $trace==3;
- warn "tcpcat $$: sending `$out_message' (" . blength($out_message)
- . " bytes)...\n" if $trace>3;
- ($written, $errs) = tcp_write_all($out_message);
- goto cleanup unless $written;
-
- sleep $slowly if $slowly; # Closing too soon can abort broken servers
- CORE::shutdown SSLCAT_S, 1; # Half close --> No more output, send EOF to server
-
- warn "waiting for reply...\n" if $trace>2;
- ($got, $errs) = tcp_read_all($ssl);
- warn "Got " . blength($got) . " bytes.\n" if $trace==3;
- warn "Got `$got' (" . blength($got) . " bytes)\n" if $trace>3;
-
-cleanup:
- close SSLCAT_S;
- return wantarray ? ($got, $errs) : $got;
-}
-
-sub tcpxcat {
- my ($usessl, $site, $port, $req, $crt_path, $key_path) = @_;
- if ($usessl) {
- return sslcat($site, $port, $req, $crt_path, $key_path);
- } else {
- return tcpcat($site, $port, $req);
- }
-}
-
-###
-### Basic request - response primitive, this is different from sslcat
-### because this does not shutdown the connection.
-###
-
-sub https_cat { # address, port, message --> returns reply / (reply,errs,cert)
- my ($dest_serv, $port, $out_message, $crt_path, $key_path) = @_;
- my ($ctx, $ssl, $got, $errs, $written);
-
- ($got, $errs) = open_proxy_tcp_connection($dest_serv, $port);
- return (wantarray ? (undef, $errs) : undef) unless $got;
-
- ### Do SSL negotiation stuff
-
- warn "Creating SSL $ssl_version context...\n" if $trace>2;
- load_error_strings(); # Some bloat, but I'm after ease of use
- SSLeay_add_ssl_algorithms(); # and debuggability.
- randomize();
-
- $ctx = new_x_ctx();
- goto cleanup2 if $errs = print_errs('CTX_new') or !$ctx;
-
- CTX_set_options($ctx, &OP_ALL);
- goto cleanup2 if $errs = print_errs('CTX_set_options');
-
- warn "Cert `$crt_path' given without key" if $crt_path && !$key_path;
- set_cert_and_key($ctx, $crt_path, $key_path) if $crt_path;
-
- warn "Creating SSL connection (context was '$ctx')...\n" if $trace>2;
- $ssl = new($ctx);
- goto cleanup if $errs = print_errs('SSL_new') or !$ssl;
-
- warn "Setting fd (ctx $ctx, con $ssl)...\n" if $trace>2;
- set_fd($ssl, fileno(SSLCAT_S));
- goto cleanup if $errs = print_errs('set_fd');
-
- warn "Entering SSL negotiation phase...\n" if $trace>2;
-
- if ($trace>2) {
- my $i = 0;
- my $p = '';
- my $cipher_list = 'Cipher list: ';
- $p=Net::SSLeay::get_cipher_list($ssl,$i);
- $cipher_list .= $p if $p;
- do {
- $i++;
- $cipher_list .= ', ' . $p if $p;
- $p=Net::SSLeay::get_cipher_list($ssl,$i);
- } while $p;
- $cipher_list .= '\n';
- warn $cipher_list;
- }
-
- $got = Net::SSLeay::connect($ssl);
- warn "SSLeay connect failed" if $trace>2 && $got==0;
- goto cleanup if $errs = print_errs('SSL_connect');
-
- my $server_cert = get_peer_certificate($ssl);
- print_errs('get_peer_certificate');
- if ($trace>1) {
- warn "Cipher `" . get_cipher($ssl) . "'\n";
- print_errs('get_ciper');
- warn dump_peer_certificate($ssl);
- }
-
- ### Connected. Exchange some data (doing repeated tries if necessary).
-
- warn "https_cat $$: sending " . blength($out_message) . " bytes...\n"
- if $trace==3;
- warn "https_cat $$: sending `$out_message' (" . blength($out_message)
- . " bytes)...\n" if $trace>3;
- ($written, $errs) = ssl_write_all($ssl, $out_message);
- goto cleanup unless $written;
-
- warn "waiting for reply...\n" if $trace>2;
- ($got, $errs) = ssl_read_all($ssl);
- warn "Got " . blength($got) . " bytes.\n" if $trace==3;
- warn "Got `$got' (" . blength($got) . " bytes)\n" if $trace>3;
-
-cleanup:
- free ($ssl);
- $errs .= print_errs('SSL_free');
-cleanup2:
- CTX_free ($ctx);
- $errs .= print_errs('CTX_free');
- close SSLCAT_S;
- return wantarray ? ($got, $errs, $server_cert) : $got;
-}
-
-sub http_cat { # address, port, message --> returns reply / (reply,errs,cert)
- my ($dest_serv, $port, $out_message) = @_;
- my ($got, $errs, $written);
-
- ($got, $errs) = open_proxy_tcp_connection($dest_serv, $port);
- return (wantarray ? (undef, $errs) : undef) unless $got;
-
- ### Connected. Exchange some data (doing repeated tries if necessary).
-
- warn "http_cat $$: sending " . blength($out_message) . " bytes...\n"
- if $trace==3;
- warn "http_cat $$: sending `$out_message' (" . blength($out_message)
- . " bytes)...\n" if $trace>3;
- ($written, $errs) = tcp_write_all($out_message);
- goto cleanup unless $written;
-
- warn "waiting for reply...\n" if $trace>2;
- ($got, $errs) = tcp_read_all(200000);
- warn "Got " . blength($got) . " bytes.\n" if $trace==3;
- warn "Got `$got' (" . blength($got) . " bytes)\n" if $trace>3;
-
-cleanup:
- close SSLCAT_S;
- return wantarray ? ($got, $errs) : $got;
-}
-
-sub httpx_cat {
- my ($usessl, $site, $port, $req, $crt_path, $key_path) = @_;
- warn "httpx_cat: usessl=$usessl ($site:$port)" if $trace;
- if ($usessl) {
- return https_cat($site, $port, $req, $crt_path, $key_path);
- } else {
- return http_cat($site, $port, $req);
- }
-}
-
-###
-### Easy set up of private key and certificate
-###
-
-sub set_cert_and_key ($$$) {
- my ($ctx, $cert_path, $key_path) = @_;
- my $errs = '';
- # Following will ask password unless private key is not encrypted
- CTX_use_RSAPrivateKey_file ($ctx, $key_path, &FILETYPE_PEM);
- $errs .= print_errs("private key `$key_path' ($!)");
- CTX_use_certificate_file ($ctx, $cert_path, &FILETYPE_PEM);
- $errs .= print_errs("certificate `$cert_path' ($!)");
- return wantarray ? (undef, $errs) : ($errs eq '');
-}
-
-### Old deprecated API
-
-sub set_server_cert_and_key ($$$) { &set_cert_and_key }
-
-### Set up to use web proxy
-
-sub set_proxy ($$;**) {
- ($proxyhost, $proxyport, $proxyuser, $proxypass) = @_;
- require MIME::Base64 if $proxyuser;
- $proxyauth = $CRLF . 'Proxy-authorization: Basic '
- . MIME::Base64::encode("$proxyuser:$proxypass", '')
- if $proxyuser;
-}
-
-###
-### Easy https manipulation routines
-###
-
-sub make_form {
- my (@fields) = @_;
- my $form;
- while (@fields) {
- my ($name, $data) = (shift(@fields), shift(@fields));
- $data =~ s/([^\w\-.\@\$ ])/sprintf("%%%2.2x",ord($1))/gse;
- $data =~ tr[ ][+];
- $form .= "$name=$data&";
- }
- chop $form;
- return $form;
-}
-
-sub make_headers {
- my (@headers) = @_;
- my $headers;
- while (@headers) {
- my $header = shift(@headers);
- my $value = shift(@headers);
- $header =~ s/:$//;
- $value =~ s/\x0d?\x0a$//; # because we add it soon, see below
- $headers .= "$header: $value$CRLF";
- }
- return $headers;
-}
-
-sub do_httpx3 {
- my ($method, $usessl, $site, $port, $path, $headers,
- $content, $mime_type, $crt_path, $key_path) = @_;
- my ($response, $page, $h,$v);
-
- if ($content) {
- $mime_type = "application/x-www-form-urlencoded" unless $mime_type;
- my $len = blength($content);
- $content = "Content-Type: $mime_type$CRLF"
- . "Content-Length: $len$CRLF$CRLF$content";
- } else {
- $content = "$CRLF$CRLF";
- }
- my $req = "$method $path HTTP/1.0$CRLF";
- unless (defined $headers && $headers =~ /^Host:/m) {
- $req .= "Host: $site";
- unless (($port == 80 && !$usessl) || ($port == 443 && $usessl)) {
- $req .= ":$port";
- }
- $req .= $CRLF;
- }
- $req .= (defined $headers ? $headers : '') . "Accept: */*$CRLF$content";
-
- warn "do_httpx3($method,$usessl,$site:$port)" if $trace;
- my ($http, $errs, $server_cert)
- = httpx_cat($usessl, $site, $port, $req, $crt_path, $key_path);
- return (undef, "HTTP/1.0 900 NET OR SSL ERROR$CRLF$CRLF$errs") if $errs;
-
- $http = '' if !defined $http;
- ($headers, $page) = split /\s?\n\s?\n/, $http, 2;
- warn "headers >$headers< page >>$page<< http >>>$http<<<" if $trace>1;
- ($response, $headers) = split /\s?\n/, $headers, 2;
- return ($page, $response, $headers, $server_cert);
-}
-
-sub do_https3 { splice(@_,1,0) = 1; do_httpx3; } # Legacy undocumented
-
-### do_https2() is a legacy version in the sense that it is unable
-### to return all instances of duplicate headers.
-
-sub do_httpx2 {
- my ($page, $response, $headers, $server_cert) = &do_httpx3;
- X509_free($server_cert) if defined $server_cert;
- return ($page, $response,
- map( { ($h,$v)=/^(\S+)\:\s*(.*)$/; (uc($h),$v); }
- split(/\s?\n/, $headers)
- )
- );
-}
-
-sub do_https2 { splice(@_,1,0) = 1; do_httpx2; } # Legacy undocumented
-
-### Returns headers as a hash where multiple instances of same header
-### are handled correctly.
-
-sub do_httpx4 {
- my ($page, $response, $headers, $server_cert) = &do_httpx3;
- X509_free($server_cert) if defined $server_cert;
- my %hr = ();
- for my $hh (split /\s?\n/, $headers) {
- my ($h,$v)=/^(\S+)\:\s*(.*)$/;
- push @{$hr{uc($h)}}, $v;
- }
- return ($page, $response, \%hr);
-}
-
-sub do_https4 { splice(@_,1,0) = 1; do_httpx4; } # Legacy undocumented
-
-# https
-
-sub get_https { do_httpx2(GET => 1, @_) }
-sub post_https { do_httpx2(POST => 1, @_) }
-sub put_https { do_httpx2(PUT => 1, @_) }
-sub head_https { do_httpx2(HEAD => 1, @_) }
-
-sub get_https3 { do_httpx3(GET => 1, @_) }
-sub post_https3 { do_httpx3(POST => 1, @_) }
-sub put_https3 { do_httpx3(PUT => 1, @_) }
-sub head_https3 { do_httpx3(HEAD => 1, @_) }
-
-sub get_https4 { do_httpx4(GET => 1, @_) }
-sub post_https4 { do_httpx4(POST => 1, @_) }
-sub put_https4 { do_httpx4(PUT => 1, @_) }
-sub head_https4 { do_httpx4(HEAD => 1, @_) }
-
-# http
-
-sub get_http { do_httpx2(GET => 0, @_) }
-sub post_http { do_httpx2(POST => 0, @_) }
-sub put_http { do_httpx2(PUT => 0, @_) }
-sub head_http { do_httpx2(HEAD => 0, @_) }
-
-sub get_http3 { do_httpx3(GET => 0, @_) }
-sub post_http3 { do_httpx3(POST => 0, @_) }
-sub put_http3 { do_httpx3(PUT => 0, @_) }
-sub head_http3 { do_httpx3(HEAD => 0, @_) }
-
-sub get_http4 { do_httpx4(GET => 0, @_) }
-sub post_http4 { do_httpx4(POST => 0, @_) }
-sub put_http4 { do_httpx4(PUT => 0, @_) }
-sub head_http4 { do_httpx4(HEAD => 0, @_) }
-
-# Either https or http
-
-sub get_httpx { do_httpx2(GET => @_) }
-sub post_httpx { do_httpx2(POST => @_) }
-sub put_httpx { do_httpx2(PUT => @_) }
-sub head_httpx { do_httpx2(HEAD => @_) }
-
-sub get_httpx3 { do_httpx3(GET => @_) }
-sub post_httpx3 { do_httpx3(POST => @_) }
-sub put_httpx3 { do_httpx3(PUT => @_) }
-sub head_httpx3 { do_httpx3(HEAD => @_) }
-
-sub get_httpx4 { do_httpx4(GET => @_) }
-sub post_httpx4 { do_httpx4(POST => @_) }
-sub put_httpx4 { do_httpx4(PUT => @_) }
-sub head_httpx4 { do_httpx4(HEAD => @_) }
-
-### Legacy, don't use
-# ($page, $respone_or_err, %headers) = do_https(...);
-
-sub do_https {
- my ($site, $port, $path, $method, $headers,
- $content, $mime_type, $crt_path, $key_path) = @_;
-
- do_https2($method, $site, $port, $path, $headers,
- $content, $mime_type, $crt_path, $key_path);
-}
-
-1;
-__END__
diff --git a/Master/tlpkg/tlperl/lib/Net/SSLeay/Handle.pm b/Master/tlpkg/tlperl/lib/Net/SSLeay/Handle.pm
deleted file mode 100755
index d4dfb59f7de..00000000000
--- a/Master/tlpkg/tlperl/lib/Net/SSLeay/Handle.pm
+++ /dev/null
@@ -1,394 +0,0 @@
-package Net::SSLeay::Handle;
-
-require 5.005_03;
-use strict;
-
-use Socket;
-use Net::SSLeay;
-
-require Exporter;
-
-=head1 NAME
-
-Net::SSLeay::Handle - Perl module that lets SSL (HTTPS) sockets be
-handled as standard file handles.
-
-=head1 SYNOPSIS
-
- use Net::SSLeay::Handle qw/shutdown/;
- my ($host, $port) = ("localhost", 443);
-
- tie(*SSL, "Net::SSLeay::Handle", $host, $port);
-
- print SSL "GET / HTTP/1.0\r\n";
- shutdown(\*SSL, 1);
- print while (<SSL>);
- close SSL;
-
-=head1 DESCRIPTION
-
-Net::SSLeay::Handle allows you to request and receive HTTPS web pages
-using "old-fashion" file handles as in:
-
- print SSL "GET / HTTP/1.0\r\n";
-
-and
-
- print while (<SSL>);
-
-If you export the shutdown routine, then the only extra code that
-you need to add to your program is the tie function as in:
-
- my $socket;
- if ($scheme eq "https") {
- tie(*S2, "Net::SSLeay::Handle", $host, $port);
- $socket = \*S2;
- else {
- $socket = Net::SSLeay::Handle->make_socket($host, $port);
- }
- print $socket $request_headers;
- ...
-
-=cut
-
-use vars qw(@ISA @EXPORT_OK $VERSION);
-@ISA = qw(Exporter);
-@EXPORT_OK = qw(shutdown);
-$VERSION = '0.61';
-
-my $Initialized; #-- only _initialize() once
-my $Debug = 0; #-- pretty hokey
-my %Glob_Ref; #-- used to make unique \*S names for versions < 5.6
-
-#== Tie Handle Methods ========================================================
-#
-# see perldoc perltie for details.
-#
-#==============================================================================
-
-sub TIEHANDLE {
- my ($class, $socket, $port) = @_;
- $Debug > 10 and print "TIEHANDLE(@{[join ', ', @_]})\n";
-
- ref $socket eq "GLOB" or $socket = $class->make_socket($socket, $port);
-
- $class->_initialize();
-
- my $ctx = Net::SSLeay::CTX_new() or die_now("Failed to create SSL_CTX $!");
- my $ssl = Net::SSLeay::new($ctx) or die_now("Failed to create SSL $!");
-
- my $fileno = fileno($socket);
-
- Net::SSLeay::set_fd($ssl, $fileno); # Must use fileno
-
- my $resp = Net::SSLeay::connect($ssl);
-
- $Debug and print "Cipher '" . Net::SSLeay::get_cipher($ssl) . "'\n";
-
- my $self = bless {
- ssl => $ssl,
- ctx => $ctx,
- socket => $socket,
- fileno => $fileno,
- }, $class;
-
- return $self;
-}
-
-sub PRINT {
- my $self = shift;
-
- my $ssl = _get_ssl($self);
- my $resp = 0;
- for my $msg (@_) {
- defined $msg or last;
- $resp = Net::SSLeay::write($ssl, $msg) or last;
- }
- return $resp;
-}
-
-sub READLINE {
- my $self = shift;
- my $ssl = _get_ssl($self);
- if (wantarray) {
- my @lines;
- while (my $line = Net::SSLeay::ssl_read_until($ssl)) {
- push @lines, $line;
- }
- return @lines;
- } else {
- my $line = Net::SSLeay::ssl_read_until($ssl);
- return $line ? $line : undef;
- }
-}
-
-sub READ {
- my ($self, $buf, $len, $offset) = \ (@_);
- my $ssl = _get_ssl($$self);
- defined($$offset) or
- return length($$buf = Net::SSLeay::ssl_read_all($ssl, $$len));
-
- defined(my $read = Net::SSLeay::ssl_read_all($ssl, $$len))
- or return undef;
-
- my $buf_len = length($$buf);
- $$offset > $buf_len and $$buf .= chr(0) x ($$offset - $buf_len);
- substr($$buf, $$offset) = $read;
- return length($read);
-}
-
-sub WRITE {
- my $self = shift;
- my ($buf, $len, $offset) = @_;
- $offset = 0 unless defined $offset;
-
- # Return number of characters written.
- my $ssl = $self->_get_ssl();
- return $len if Net::SSLeay::write($ssl, substr($buf, $offset, $len));
- return undef;
-}
-
-sub CLOSE {
- my $self = shift;
- my $fileno = $self->{fileno};
- $Debug > 10 and print "close($fileno)\n";
- Net::SSLeay::free ($self->{ssl});
- Net::SSLeay::CTX_free ($self->{ctx});
- close $self->{socket};
-}
-
-sub FILENO { $_[0]->{fileno} }
-
-
-=head1 FUNCTIONS
-
-=over
-
-=item shutdown
-
- shutdown(\*SOCKET, $mode)
-
-Calls to the main shutdown() don't work with tied sockets created with this
-module. This shutdown should be able to distinquish between tied and untied
-sockets and do the right thing.
-
-=cut
-
-sub shutdown {
- my ($obj, @params) = @_;
-
- my $socket = UNIVERSAL::isa($obj, 'Net::SSLeay::Handle') ?
- $obj->{socket} : $obj;
- return shutdown($socket, @params);
-}
-
-=item debug
-
- my $debug = Net::SSLeay::Handle->debug()
- Net::SSLeay::Handle->debug(1)
-
-Get/set debuging mode. Always returns the debug value before the function call.
-if an additional argument is given the debug option will be set to this value.
-
-=cut
-
-sub debug {
- my ($class, $debug) = @_;
- my $old_debug = $Debug;
- @_ >1 and $Debug = $debug || 0;
- return $old_debug;
-}
-
-#=== Internal Methods =========================================================
-
-=item make_socket
-
- my $sock = Net::SSLeay::Handle->make_socket($host, $port);
-
-Creates a socket that is connected to $post using $port. It uses
-$Net::SSLeay::proxyhost and proxyport if set and authentificates itself against
-this proxy depending on $Net::SSLeay::proxyauth. It also turns autoflush on for
-the created socket.
-
-=cut
-
-sub make_socket {
- my ($class, $host, $port) = @_;
- $Debug > 10 and print "_make_socket(@{[join ', ', @_]})\n";
- $host ||= 'localhost';
- $port ||= 443;
-
- my $phost = $Net::SSLeay::proxyhost;
- my $pport = $Net::SSLeay::proxyhost ? $Net::SSLeay::proxyport : $port;
-
- my $dest_ip = gethostbyname($phost || $host);
- my $host_params = sockaddr_in($pport, $dest_ip);
- my $socket = $^V ? undef : $class->_glob_ref("$host:$port");
-
- socket($socket, &PF_INET(), &SOCK_STREAM(), 0) or die "socket: $!";
- connect($socket, $host_params) or die "connect: $!";
-
- my $old_select = select($socket); $| = 1; select($old_select);
- $phost and do {
- my $auth = $Net::SSLeay::proxyauth;
- my $CRLF = $Net::SSLeay::CRLF;
- print $socket "CONNECT $host:$port HTTP/1.0$auth$CRLF$CRLF";
- my $line = <$socket>;
- };
- return $socket;
-}
-
-=back
-
-=cut
-
-#--- _glob_ref($strings) ------------------------------------------------------
-#
-# Create a unique namespace name and return a glob ref to it. Would be great
-# to use the fileno but need this before we get back the fileno.
-# NEED TO LOCK THIS ROUTINE IF USING THREADS. (but it is only used for
-# versions < 5.6 :)
-#------------------------------------------------------------------------------
-
-sub _glob_ref {
- my $class = shift;
- my $preamb = join("", @_) || "_glob_ref";
- my $num = ++$Glob_Ref{$preamb};
- my $name = "$preamb:$num";
- no strict 'refs';
- my $glob_ref = \*$name;
- use strict 'refs';
-
- $Debug and do {
- print "GLOB_REF $preamb\n";
- while (my ($k, $v) = each %Glob_Ref) {print "$k = $v\n"}
- print "\n";
- };
-
- return $glob_ref;
-}
-
-sub _initialize {
- $Initialized++ and return;
- Net::SSLeay::load_error_strings();
- Net::SSLeay::SSLeay_add_ssl_algorithms();
- Net::SSLeay::randomize();
-}
-
-sub __dummy {
- my $host = $Net::SSLeay::proxyhost;
- my $port = $Net::SSLeay::proxyport;
- my $auth = $Net::SSLeay::proxyauth;
-}
-
-#--- _get_self($socket) -------------------------------------------------------
-# Returns a hash containing attributes for $socket (= \*SOMETHING) based
-# on fileno($socket). Will return undef if $socket was not created here.
-#------------------------------------------------------------------------------
-
-sub _get_self { return $_[0]; }
-
-#--- _get_ssl($socket) --------------------------------------------------------
-# Returns a the "ssl" attribute for $socket (= \*SOMETHING) based
-# on fileno($socket). Will cause a warning and return undef if $socket was not
-# created here.
-#------------------------------------------------------------------------------
-
-sub _get_ssl {
- return $_[0]->{ssl};
-}
-
-1;
-
-__END__
-
-=head2 USING EXISTING SOCKETS
-
-One of the motivations for writing this module was to avoid
-duplicating socket creation code (which is mostly error handling).
-The calls to tie() above where it is passed a $host and $port is
-provided for convenience testing. If you already have a socket
-connected to the right host and port, S1, then you can do something
-like:
-
- my $socket \*S1;
- if ($scheme eq "https") {
- tie(*S2, "Net::SSLeay::Handle", $socket);
- $socket = \*S2;
- }
- my $last_sel = select($socket); $| = 1; select($last_sel);
- print $socket $request_headers;
- ...
-
-Note: As far as I know you must be careful with the globs in the tie()
-function. The first parameter must be a glob (*SOMETHING) and the
-last parameter must be a reference to a glob (\*SOMETHING_ELSE) or a
-scaler that was assigned to a reference to a glob (as in the example
-above)
-
-Also, the two globs must be different. When I tried to use the same
-glob, I got a core dump.
-
-=head2 EXPORT
-
-None by default.
-
-You can export the shutdown() function.
-
-It is suggested that you do export shutdown() or use the fully
-qualified Net::SSLeay::Handle::shutdown() function to shutdown SSL
-sockets. It should be smart enough to distinguish between SSL and
-non-SSL sockets and do the right thing.
-
-=head1 EXAMPLES
-
- use Net::SSLeay::Handle qw/shutdown/;
- my ($host, $port) = ("localhost", 443);
-
- tie(*SSL, "Net::SSLeay::Handle", $host, $port);
-
- print SSL "GET / HTTP/1.0\r\n";
- shutdown(\*SSL, 1);
- print while (<SSL>);
- close SSL;
-
-=head1 TODO
-
-Better error handling. Callback routine?
-
-=head1 CAVEATS
-
-Tying to a file handle is a little tricky (for me at least).
-
-The first parameter to tie() must be a glob (*SOMETHING) and the last
-parameter must be a reference to a glob (\*SOMETHING_ELSE) or a scaler
-that was assigned to a reference to a glob ($s = \*SOMETHING_ELSE).
-Also, the two globs must be different. When I tried to use the same
-glob, I got a core dump.
-
-I was able to associate attributes to globs created by this module
-(like *SSL above) by making a hash of hashes keyed by the file head1.
-
-Support for old perls may not be 100%. If in trouble try 5.6.0 or
-newer.
-
-=head1 CHANGES
-
-Please see Net-SSLeay-Handle-0.50/Changes file.
-
-=head1 KNOWN BUGS
-
-If you let this module construct sockets for you with Perl versions
-below v.5.6 then there is a slight memory leak. Other upgrade your
-Perl, or create the sockets yourself. The leak was created to let
-these older versions of Perl access more than one Handle at a time.
-
-=head1 AUTHOR
-
-Jim Bowlin jbowlin@linklint.org
-
-=head1 SEE ALSO
-
-Net::SSLeay, perl(1), http://openssl.org/
-
-=cut
diff --git a/Master/tlpkg/tlperl/lib/Net/Time.pm b/Master/tlpkg/tlperl/lib/Net/Time.pm
deleted file mode 100755
index 6f1dd04586e..00000000000
--- a/Master/tlpkg/tlperl/lib/Net/Time.pm
+++ /dev/null
@@ -1,151 +0,0 @@
-# Net::Time.pm
-#
-# Copyright (c) 1995-2004 Graham Barr <gbarr@pobox.com>. All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-
-package Net::Time;
-
-use strict;
-use vars qw($VERSION @ISA @EXPORT_OK $TIMEOUT);
-use Carp;
-use IO::Socket;
-require Exporter;
-use Net::Config;
-use IO::Select;
-
-@ISA = qw(Exporter);
-@EXPORT_OK = qw(inet_time inet_daytime);
-
-$VERSION = "2.10";
-
-$TIMEOUT = 120;
-
-
-sub _socket {
- my ($pname, $pnum, $host, $proto, $timeout) = @_;
-
- $proto ||= 'udp';
-
- my $port = (getservbyname($pname, $proto))[2] || $pnum;
-
- my $hosts = defined $host ? [$host] : $NetConfig{$pname . '_hosts'};
-
- my $me;
-
- foreach $host (@$hosts) {
- $me = IO::Socket::INET->new(
- PeerAddr => $host,
- PeerPort => $port,
- Proto => $proto
- )
- and last;
- }
-
- return unless $me;
-
- $me->send("\n")
- if $proto eq 'udp';
-
- $timeout = $TIMEOUT
- unless defined $timeout;
-
- IO::Select->new($me)->can_read($timeout)
- ? $me
- : undef;
-}
-
-
-sub inet_time {
- my $s = _socket('time', 37, @_) || return undef;
- my $buf = '';
- my $offset = 0 | 0;
-
- return undef
- unless defined $s->recv($buf, length(pack("N", 0)));
-
- # unpack, we | 0 to ensure we have an unsigned
- my $time = (unpack("N", $buf))[0] | 0;
-
- # the time protocol return time in seconds since 1900, convert
- # it to a the required format
-
- if ($^O eq "MacOS") {
-
- # MacOS return seconds since 1904, 1900 was not a leap year.
- $offset = (4 * 31536000) | 0;
- }
- else {
-
- # otherwise return seconds since 1972, there were 17 leap years between
- # 1900 and 1972
- $offset = (70 * 31536000 + 17 * 86400) | 0;
- }
-
- $time - $offset;
-}
-
-
-sub inet_daytime {
- my $s = _socket('daytime', 13, @_) || return undef;
- my $buf = '';
-
- defined($s->recv($buf, 1024))
- ? $buf
- : undef;
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-Net::Time - time and daytime network client interface
-
-=head1 SYNOPSIS
-
- use Net::Time qw(inet_time inet_daytime);
-
- print inet_time(); # use default host from Net::Config
- print inet_time('localhost');
- print inet_time('localhost', 'tcp');
-
- print inet_daytime(); # use default host from Net::Config
- print inet_daytime('localhost');
- print inet_daytime('localhost', 'tcp');
-
-=head1 DESCRIPTION
-
-C<Net::Time> provides subroutines that obtain the time on a remote machine.
-
-=over 4
-
-=item inet_time ( [HOST [, PROTOCOL [, TIMEOUT]]])
-
-Obtain the time on C<HOST>, or some default host if C<HOST> is not given
-or not defined, using the protocol as defined in RFC868. The optional
-argument C<PROTOCOL> should define the protocol to use, either C<tcp> or
-C<udp>. The result will be a time value in the same units as returned
-by time() or I<undef> upon failure.
-
-=item inet_daytime ( [HOST [, PROTOCOL [, TIMEOUT]]])
-
-Obtain the time on C<HOST>, or some default host if C<HOST> is not given
-or not defined, using the protocol as defined in RFC867. The optional
-argument C<PROTOCOL> should define the protocol to use, either C<tcp> or
-C<udp>. The result will be an ASCII string or I<undef> upon failure.
-
-=back
-
-=head1 AUTHOR
-
-Graham Barr <gbarr@pobox.com>
-
-=head1 COPYRIGHT
-
-Copyright (c) 1995-2004 Graham Barr. All rights reserved.
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=cut
diff --git a/Master/tlpkg/tlperl/lib/Net/hostent.pm b/Master/tlpkg/tlperl/lib/Net/hostent.pm
deleted file mode 100755
index 3a2fc013877..00000000000
--- a/Master/tlpkg/tlperl/lib/Net/hostent.pm
+++ /dev/null
@@ -1,151 +0,0 @@
-package Net::hostent;
-use strict;
-
-use 5.006_001;
-our $VERSION = '1.01';
-our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
-BEGIN {
- use Exporter ();
- @EXPORT = qw(gethostbyname gethostbyaddr gethost);
- @EXPORT_OK = qw(
- $h_name @h_aliases
- $h_addrtype $h_length
- @h_addr_list $h_addr
- );
- %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] );
-}
-use vars @EXPORT_OK;
-
-# Class::Struct forbids use of @ISA
-sub import { goto &Exporter::import }
-
-use Class::Struct qw(struct);
-struct 'Net::hostent' => [
- name => '$',
- aliases => '@',
- addrtype => '$',
- 'length' => '$',
- addr_list => '@',
-];
-
-sub addr { shift->addr_list->[0] }
-
-sub populate (@) {
- return unless @_;
- my $hob = new();
- $h_name = $hob->[0] = $_[0];
- @h_aliases = @{ $hob->[1] } = split ' ', $_[1];
- $h_addrtype = $hob->[2] = $_[2];
- $h_length = $hob->[3] = $_[3];
- $h_addr = $_[4];
- @h_addr_list = @{ $hob->[4] } = @_[ (4 .. $#_) ];
- return $hob;
-}
-
-sub gethostbyname ($) { populate(CORE::gethostbyname(shift)) }
-
-sub gethostbyaddr ($;$) {
- my ($addr, $addrtype);
- $addr = shift;
- require Socket unless @_;
- $addrtype = @_ ? shift : Socket::AF_INET();
- populate(CORE::gethostbyaddr($addr, $addrtype))
-}
-
-sub gethost($) {
- if ($_[0] =~ /^\d+(?:\.\d+(?:\.\d+(?:\.\d+)?)?)?$/) {
- require Socket;
- &gethostbyaddr(Socket::inet_aton(shift));
- } else {
- &gethostbyname;
- }
-}
-
-1;
-__END__
-
-=head1 NAME
-
-Net::hostent - by-name interface to Perl's built-in gethost*() functions
-
-=head1 SYNOPSIS
-
- use Net::hostent;
-
-=head1 DESCRIPTION
-
-This module's default exports override the core gethostbyname() and
-gethostbyaddr() functions, replacing them with versions that return
-"Net::hostent" objects. This object has methods that return the similarly
-named structure field name from the C's hostent structure from F<netdb.h>;
-namely name, aliases, addrtype, length, and addr_list. The aliases and
-addr_list methods return array reference, the rest scalars. The addr
-method is equivalent to the zeroth element in the addr_list array
-reference.
-
-You may also import all the structure fields directly into your namespace
-as regular variables using the :FIELDS import tag. (Note that this still
-overrides your core functions.) Access these fields as variables named
-with a preceding C<h_>. Thus, C<$host_obj-E<gt>name()> corresponds to
-$h_name if you import the fields. Array references are available as
-regular array variables, so for example C<@{ $host_obj-E<gt>aliases()
-}> would be simply @h_aliases.
-
-The gethost() function is a simple front-end that forwards a numeric
-argument to gethostbyaddr() by way of Socket::inet_aton, and the rest
-to gethostbyname().
-
-To access this functionality without the core overrides,
-pass the C<use> an empty import list, and then access
-function functions with their full qualified names.
-On the other hand, the built-ins are still available
-via the C<CORE::> pseudo-package.
-
-=head1 EXAMPLES
-
- use Net::hostent;
- use Socket;
-
- @ARGV = ('netscape.com') unless @ARGV;
-
- for $host ( @ARGV ) {
-
- unless ($h = gethost($host)) {
- warn "$0: no such host: $host\n";
- next;
- }
-
- printf "\n%s is %s%s\n",
- $host,
- lc($h->name) eq lc($host) ? "" : "*really* ",
- $h->name;
-
- print "\taliases are ", join(", ", @{$h->aliases}), "\n"
- if @{$h->aliases};
-
- if ( @{$h->addr_list} > 1 ) {
- my $i;
- for $addr ( @{$h->addr_list} ) {
- printf "\taddr #%d is [%s]\n", $i++, inet_ntoa($addr);
- }
- } else {
- printf "\taddress is [%s]\n", inet_ntoa($h->addr);
- }
-
- if ($h = gethostbyaddr($h->addr)) {
- if (lc($h->name) ne lc($host)) {
- printf "\tThat addr reverses to host %s!\n", $h->name;
- $host = $h->name;
- redo;
- }
- }
- }
-
-=head1 NOTE
-
-While this class is currently implemented using the Class::Struct
-module to build a struct-like class, you shouldn't rely upon this.
-
-=head1 AUTHOR
-
-Tom Christiansen
diff --git a/Master/tlpkg/tlperl/lib/Net/libnetFAQ.pod b/Master/tlpkg/tlperl/lib/Net/libnetFAQ.pod
deleted file mode 100755
index e6ec362f36a..00000000000
--- a/Master/tlpkg/tlperl/lib/Net/libnetFAQ.pod
+++ /dev/null
@@ -1,303 +0,0 @@
-=head1 NAME
-
-libnetFAQ - libnet Frequently Asked Questions
-
-=head1 DESCRIPTION
-
-=head2 Where to get this document
-
-This document is distributed with the libnet distribution, and is also
-available on the libnet web page at
-
- http://search.cpan.org/~gbarr/libnet/
-
-=head2 How to contribute to this document
-
-You may mail corrections, additions, and suggestions to me
-gbarr@pobox.com.
-
-=head1 Author and Copyright Information
-
-Copyright (c) 1997-1998 Graham Barr. All rights reserved.
-This document is free; you can redistribute it and/or modify it
-under the terms of the Artistic License.
-
-=head2 Disclaimer
-
-This information is offered in good faith and in the hope that it may
-be of use, but is not guaranteed to be correct, up to date, or suitable
-for any particular purpose whatsoever. The authors accept no liability
-in respect of this information or its use.
-
-
-=head1 Obtaining and installing libnet
-
-=head2 What is libnet ?
-
-libnet is a collection of perl5 modules which all related to network
-programming. The majority of the modules available provided the
-client side of popular server-client protocols that are used in
-the internet community.
-
-=head2 Which version of perl do I need ?
-
-libnet has been know to work with versions of perl from 5.002 onwards. However
-if your release of perl is prior to perl5.004 then you will need to
-obtain and install the IO distribution from CPAN. If you have perl5.004
-or later then you will have the IO modules in your installation already,
-but CPAN may contain updates.
-
-=head2 What other modules do I need ?
-
-The only modules you will need installed are the modules from the IO
-distribution. If you have perl5.004 or later you will already have
-these modules.
-
-=head2 What machines support libnet ?
-
-libnet itself is an entirely perl-code distribution so it should work
-on any machine that perl runs on. However IO may not work
-with some machines and earlier releases of perl. But this
-should not be the case with perl version 5.004 or later.
-
-=head2 Where can I get the latest libnet release
-
-The latest libnet release is always on CPAN, you will find it
-in
-
- http://www.cpan.org/modules/by-module/Net/
-
-The latest release and information is also available on the libnet web page
-at
-
- http://search.cpan.org/~gbarr/libnet/
-
-=head1 Using Net::FTP
-
-=head2 How do I download files from an FTP server ?
-
-An example taken from an article posted to comp.lang.perl.misc
-
- #!/your/path/to/perl
-
- # a module making life easier
-
- use Net::FTP;
-
- # for debugging: $ftp = Net::FTP->new('site','Debug',10);
- # open a connection and log in!
-
- $ftp = Net::FTP->new('target_site.somewhere.xxx');
- $ftp->login('username','password');
-
- # set transfer mode to binary
-
- $ftp->binary();
-
- # change the directory on the ftp site
-
- $ftp->cwd('/some/path/to/somewhere/');
-
- foreach $name ('file1', 'file2', 'file3') {
-
- # get's arguments are in the following order:
- # ftp server's filename
- # filename to save the transfer to on the local machine
- # can be simply used as get($name) if you want the same name
-
- $ftp->get($name,$name);
- }
-
- # ftp done!
-
- $ftp->quit;
-
-=head2 How do I transfer files in binary mode ?
-
-To transfer files without <LF><CR> translation Net::FTP provides
-the C<binary> method
-
- $ftp->binary;
-
-=head2 How can I get the size of a file on a remote FTP server ?
-
-=head2 How can I get the modification time of a file on a remote FTP server ?
-
-=head2 How can I change the permissions of a file on a remote server ?
-
-The FTP protocol does not have a command for changing the permissions
-of a file on the remote server. But some ftp servers may allow a chmod
-command to be issued via a SITE command, eg
-
- $ftp->quot('site chmod 0777',$filename);
-
-But this is not guaranteed to work.
-
-=head2 Can I do a reget operation like the ftp command ?
-
-=head2 How do I get a directory listing from an FTP server ?
-
-=head2 Changing directory to "" does not fail ?
-
-Passing an argument of "" to ->cwd() has the same affect of calling ->cwd()
-without any arguments. Turn on Debug (I<See below>) and you will see what is
-happening
-
- $ftp = Net::FTP->new($host, Debug => 1);
- $ftp->login;
- $ftp->cwd("");
-
-gives
-
- Net::FTP=GLOB(0x82196d8)>>> CWD /
- Net::FTP=GLOB(0x82196d8)<<< 250 CWD command successful.
-
-=head2 I am behind a SOCKS firewall, but the Firewall option does not work ?
-
-The Firewall option is only for support of one type of firewall. The type
-supported is an ftp proxy.
-
-To use Net::FTP, or any other module in the libnet distribution,
-through a SOCKS firewall you must create a socks-ified perl executable
-by compiling perl with the socks library.
-
-=head2 I am behind an FTP proxy firewall, but cannot access machines outside ?
-
-Net::FTP implements the most popular ftp proxy firewall approach. The scheme
-implemented is that where you log in to the firewall with C<user@hostname>
-
-I have heard of one other type of firewall which requires a login to the
-firewall with an account, then a second login with C<user@hostname>. You can
-still use Net::FTP to traverse these firewalls, but a more manual approach
-must be taken, eg
-
- $ftp = Net::FTP->new($firewall) or die $@;
- $ftp->login($firewall_user, $firewall_passwd) or die $ftp->message;
- $ftp->login($ext_user . '@' . $ext_host, $ext_passwd) or die $ftp->message.
-
-=head2 My ftp proxy firewall does not listen on port 21
-
-FTP servers usually listen on the same port number, port 21, as any other
-FTP server. But there is no reason why this has to be the case.
-
-If you pass a port number to Net::FTP then it assumes this is the port
-number of the final destination. By default Net::FTP will always try
-to connect to the firewall on port 21.
-
-Net::FTP uses IO::Socket to open the connection and IO::Socket allows
-the port number to be specified as part of the hostname. So this problem
-can be resolved by either passing a Firewall option like C<"hostname:1234">
-or by setting the C<ftp_firewall> option in Net::Config to be a string
-in in the same form.
-
-=head2 Is it possible to change the file permissions of a file on an FTP server ?
-
-The answer to this is "maybe". The FTP protocol does not specify a command to change
-file permissions on a remote host. However many servers do allow you to run the
-chmod command via the C<SITE> command. This can be done with
-
- $ftp->site('chmod','0775',$file);
-
-=head2 I have seen scripts call a method message, but cannot find it documented ?
-
-Net::FTP, like several other packages in libnet, inherits from Net::Cmd, so
-all the methods described in Net::Cmd are also available on Net::FTP
-objects.
-
-=head2 Why does Net::FTP not implement mput and mget methods
-
-The quick answer is because they are easy to implement yourself. The long
-answer is that to write these in such a way that multiple platforms are
-supported correctly would just require too much code. Below are
-some examples how you can implement these yourself.
-
-sub mput {
- my($ftp,$pattern) = @_;
- foreach my $file (glob($pattern)) {
- $ftp->put($file) or warn $ftp->message;
- }
-}
-
-sub mget {
- my($ftp,$pattern) = @_;
- foreach my $file ($ftp->ls($pattern)) {
- $ftp->get($file) or warn $ftp->message;
- }
-}
-
-
-=head1 Using Net::SMTP
-
-=head2 Why can't the part of an Email address after the @ be used as the hostname ?
-
-The part of an Email address which follows the @ is not necessarily a hostname,
-it is a mail domain. To find the name of a host to connect for a mail domain
-you need to do a DNS MX lookup
-
-=head2 Why does Net::SMTP not do DNS MX lookups ?
-
-Net::SMTP implements the SMTP protocol. The DNS MX lookup is not part
-of this protocol.
-
-=head2 The verify method always returns true ?
-
-Well it may seem that way, but it does not. The verify method returns true
-if the command succeeded. If you pass verify an address which the
-server would normally have to forward to another machine, the command
-will succeed with something like
-
- 252 Couldn't verify <someone@there> but will attempt delivery anyway
-
-This command will fail only if you pass it an address in a domain
-the server directly delivers for, and that address does not exist.
-
-=head1 Debugging scripts
-
-=head2 How can I debug my scripts that use Net::* modules ?
-
-Most of the libnet client classes allow options to be passed to the
-constructor, in most cases one option is called C<Debug>. Passing
-this option with a non-zero value will turn on a protocol trace, which
-will be sent to STDERR. This trace can be useful to see what commands
-are being sent to the remote server and what responses are being
-received back.
-
- #!/your/path/to/perl
-
- use Net::FTP;
-
- my $ftp = new Net::FTP($host, Debug => 1);
- $ftp->login('gbarr','password');
- $ftp->quit;
-
-this script would output something like
-
- Net::FTP: Net::FTP(2.22)
- Net::FTP: Exporter
- Net::FTP: Net::Cmd(2.0801)
- Net::FTP: IO::Socket::INET
- Net::FTP: IO::Socket(1.1603)
- Net::FTP: IO::Handle(1.1504)
-
- Net::FTP=GLOB(0x8152974)<<< 220 imagine FTP server (Version wu-2.4(5) Tue Jul 29 11:17:18 CDT 1997) ready.
- Net::FTP=GLOB(0x8152974)>>> user gbarr
- Net::FTP=GLOB(0x8152974)<<< 331 Password required for gbarr.
- Net::FTP=GLOB(0x8152974)>>> PASS ....
- Net::FTP=GLOB(0x8152974)<<< 230 User gbarr logged in. Access restrictions apply.
- Net::FTP=GLOB(0x8152974)>>> QUIT
- Net::FTP=GLOB(0x8152974)<<< 221 Goodbye.
-
-The first few lines tell you the modules that Net::FTP uses and their versions,
-this is useful data to me when a user reports a bug. The last seven lines
-show the communication with the server. Each line has three parts. The first
-part is the object itself, this is useful for separating the output
-if you are using multiple objects. The second part is either C<<<<<> to
-show data coming from the server or C<&gt&gt&gt&gt> to show data
-going to the server. The remainder of the line is the command
-being sent or response being received.
-
-=head1 AUTHOR AND COPYRIGHT
-
-Copyright (c) 1997 Graham Barr.
-All rights reserved.
-
diff --git a/Master/tlpkg/tlperl/lib/Net/netent.pm b/Master/tlpkg/tlperl/lib/Net/netent.pm
deleted file mode 100755
index f7d32cb9254..00000000000
--- a/Master/tlpkg/tlperl/lib/Net/netent.pm
+++ /dev/null
@@ -1,169 +0,0 @@
-package Net::netent;
-use strict;
-
-use 5.006_001;
-our $VERSION = '1.00';
-our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
-BEGIN {
- use Exporter ();
- @EXPORT = qw(getnetbyname getnetbyaddr getnet);
- @EXPORT_OK = qw(
- $n_name @n_aliases
- $n_addrtype $n_net
- );
- %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] );
-}
-use vars @EXPORT_OK;
-
-# Class::Struct forbids use of @ISA
-sub import { goto &Exporter::import }
-
-use Class::Struct qw(struct);
-struct 'Net::netent' => [
- name => '$',
- aliases => '@',
- addrtype => '$',
- net => '$',
-];
-
-sub populate (@) {
- return unless @_;
- my $nob = new();
- $n_name = $nob->[0] = $_[0];
- @n_aliases = @{ $nob->[1] } = split ' ', $_[1];
- $n_addrtype = $nob->[2] = $_[2];
- $n_net = $nob->[3] = $_[3];
- return $nob;
-}
-
-sub getnetbyname ($) { populate(CORE::getnetbyname(shift)) }
-
-sub getnetbyaddr ($;$) {
- my ($net, $addrtype);
- $net = shift;
- require Socket if @_;
- $addrtype = @_ ? shift : Socket::AF_INET();
- populate(CORE::getnetbyaddr($net, $addrtype))
-}
-
-sub getnet($) {
- if ($_[0] =~ /^\d+(?:\.\d+(?:\.\d+(?:\.\d+)?)?)?$/) {
- require Socket;
- &getnetbyaddr(Socket::inet_aton(shift));
- } else {
- &getnetbyname;
- }
-}
-
-1;
-__END__
-
-=head1 NAME
-
-Net::netent - by-name interface to Perl's built-in getnet*() functions
-
-=head1 SYNOPSIS
-
- use Net::netent qw(:FIELDS);
- getnetbyname("loopback") or die "bad net";
- printf "%s is %08X\n", $n_name, $n_net;
-
- use Net::netent;
-
- $n = getnetbyname("loopback") or die "bad net";
- { # there's gotta be a better way, eh?
- @bytes = unpack("C4", pack("N", $n->net));
- shift @bytes while @bytes && $bytes[0] == 0;
- }
- printf "%s is %08X [%d.%d.%d.%d]\n", $n->name, $n->net, @bytes;
-
-=head1 DESCRIPTION
-
-This module's default exports override the core getnetbyname() and
-getnetbyaddr() functions, replacing them with versions that return
-"Net::netent" objects. This object has methods that return the similarly
-named structure field name from the C's netent structure from F<netdb.h>;
-namely name, aliases, addrtype, and net. The aliases
-method returns an array reference, the rest scalars.
-
-You may also import all the structure fields directly into your namespace
-as regular variables using the :FIELDS import tag. (Note that this still
-overrides your core functions.) Access these fields as variables named
-with a preceding C<n_>. Thus, C<$net_obj-E<gt>name()> corresponds to
-$n_name if you import the fields. Array references are available as
-regular array variables, so for example C<@{ $net_obj-E<gt>aliases()
-}> would be simply @n_aliases.
-
-The getnet() function is a simple front-end that forwards a numeric
-argument to getnetbyaddr(), and the rest
-to getnetbyname().
-
-To access this functionality without the core overrides,
-pass the C<use> an empty import list, and then access
-function functions with their full qualified names.
-On the other hand, the built-ins are still available
-via the C<CORE::> pseudo-package.
-
-=head1 EXAMPLES
-
-The getnet() functions do this in the Perl core:
-
- sv_setiv(sv, (I32)nent->n_net);
-
-The gethost() functions do this in the Perl core:
-
- sv_setpvn(sv, hent->h_addr, len);
-
-That means that the address comes back in binary for the
-host functions, and as a regular perl integer for the net ones.
-This seems a bug, but here's how to deal with it:
-
- use strict;
- use Socket;
- use Net::netent;
-
- @ARGV = ('loopback') unless @ARGV;
-
- my($n, $net);
-
- for $net ( @ARGV ) {
-
- unless ($n = getnetbyname($net)) {
- warn "$0: no such net: $net\n";
- next;
- }
-
- printf "\n%s is %s%s\n",
- $net,
- lc($n->name) eq lc($net) ? "" : "*really* ",
- $n->name;
-
- print "\taliases are ", join(", ", @{$n->aliases}), "\n"
- if @{$n->aliases};
-
- # this is stupid; first, why is this not in binary?
- # second, why am i going through these convolutions
- # to make it looks right
- {
- my @a = unpack("C4", pack("N", $n->net));
- shift @a while @a && $a[0] == 0;
- printf "\taddr is %s [%d.%d.%d.%d]\n", $n->net, @a;
- }
-
- if ($n = getnetbyaddr($n->net)) {
- if (lc($n->name) ne lc($net)) {
- printf "\tThat addr reverses to net %s!\n", $n->name;
- $net = $n->name;
- redo;
- }
- }
- }
-
-=head1 NOTE
-
-While this class is currently implemented using the Class::Struct
-module to build a struct-like class, you shouldn't rely upon this.
-
-=head1 AUTHOR
-
-Tom Christiansen
diff --git a/Master/tlpkg/tlperl/lib/Net/protoent.pm b/Master/tlpkg/tlperl/lib/Net/protoent.pm
deleted file mode 100755
index 2cbccad3cbc..00000000000
--- a/Master/tlpkg/tlperl/lib/Net/protoent.pm
+++ /dev/null
@@ -1,96 +0,0 @@
-package Net::protoent;
-use strict;
-
-use 5.006_001;
-our $VERSION = '1.00';
-our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
-BEGIN {
- use Exporter ();
- @EXPORT = qw(getprotobyname getprotobynumber getprotoent getproto);
- @EXPORT_OK = qw( $p_name @p_aliases $p_proto );
- %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] );
-}
-use vars @EXPORT_OK;
-
-# Class::Struct forbids use of @ISA
-sub import { goto &Exporter::import }
-
-use Class::Struct qw(struct);
-struct 'Net::protoent' => [
- name => '$',
- aliases => '@',
- proto => '$',
-];
-
-sub populate (@) {
- return unless @_;
- my $pob = new();
- $p_name = $pob->[0] = $_[0];
- @p_aliases = @{ $pob->[1] } = split ' ', $_[1];
- $p_proto = $pob->[2] = $_[2];
- return $pob;
-}
-
-sub getprotoent ( ) { populate(CORE::getprotoent()) }
-sub getprotobyname ($) { populate(CORE::getprotobyname(shift)) }
-sub getprotobynumber ($) { populate(CORE::getprotobynumber(shift)) }
-
-sub getproto ($;$) {
- no strict 'refs';
- return &{'getprotoby' . ($_[0]=~/^\d+$/ ? 'number' : 'name')}(@_);
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-Net::protoent - by-name interface to Perl's built-in getproto*() functions
-
-=head1 SYNOPSIS
-
- use Net::protoent;
- $p = getprotobyname(shift || 'tcp') || die "no proto";
- printf "proto for %s is %d, aliases are %s\n",
- $p->name, $p->proto, "@{$p->aliases}";
-
- use Net::protoent qw(:FIELDS);
- getprotobyname(shift || 'tcp') || die "no proto";
- print "proto for $p_name is $p_proto, aliases are @p_aliases\n";
-
-=head1 DESCRIPTION
-
-This module's default exports override the core getprotoent(),
-getprotobyname(), and getnetbyport() functions, replacing them with
-versions that return "Net::protoent" objects. They take default
-second arguments of "tcp". This object has methods that return the
-similarly named structure field name from the C's protoent structure
-from F<netdb.h>; namely name, aliases, and proto. The aliases method
-returns an array reference, the rest scalars.
-
-You may also import all the structure fields directly into your namespace
-as regular variables using the :FIELDS import tag. (Note that this still
-overrides your core functions.) Access these fields as variables named
-with a preceding C<p_>. Thus, C<$proto_obj-E<gt>name()> corresponds to
-$p_name if you import the fields. Array references are available as
-regular array variables, so for example C<@{ $proto_obj-E<gt>aliases()
-}> would be simply @p_aliases.
-
-The getproto() function is a simple front-end that forwards a numeric
-argument to getprotobyport(), and the rest to getprotobyname().
-
-To access this functionality without the core overrides,
-pass the C<use> an empty import list, and then access
-function functions with their full qualified names.
-On the other hand, the built-ins are still available
-via the C<CORE::> pseudo-package.
-
-=head1 NOTE
-
-While this class is currently implemented using the Class::Struct
-module to build a struct-like class, you shouldn't rely upon this.
-
-=head1 AUTHOR
-
-Tom Christiansen
diff --git a/Master/tlpkg/tlperl/lib/Net/servent.pm b/Master/tlpkg/tlperl/lib/Net/servent.pm
deleted file mode 100755
index 78a16814555..00000000000
--- a/Master/tlpkg/tlperl/lib/Net/servent.pm
+++ /dev/null
@@ -1,113 +0,0 @@
-package Net::servent;
-use strict;
-
-use 5.006_001;
-our $VERSION = '1.01';
-our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
-BEGIN {
- use Exporter ();
- @EXPORT = qw(getservbyname getservbyport getservent getserv);
- @EXPORT_OK = qw( $s_name @s_aliases $s_port $s_proto );
- %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] );
-}
-use vars @EXPORT_OK;
-
-# Class::Struct forbids use of @ISA
-sub import { goto &Exporter::import }
-
-use Class::Struct qw(struct);
-struct 'Net::servent' => [
- name => '$',
- aliases => '@',
- port => '$',
- proto => '$',
-];
-
-sub populate (@) {
- return unless @_;
- my $sob = new();
- $s_name = $sob->[0] = $_[0];
- @s_aliases = @{ $sob->[1] } = split ' ', $_[1];
- $s_port = $sob->[2] = $_[2];
- $s_proto = $sob->[3] = $_[3];
- return $sob;
-}
-
-sub getservent ( ) { populate(CORE::getservent()) }
-sub getservbyname ($;$) { populate(CORE::getservbyname(shift,shift||'tcp')) }
-sub getservbyport ($;$) { populate(CORE::getservbyport(shift,shift||'tcp')) }
-
-sub getserv ($;$) {
- no strict 'refs';
- return &{'getservby' . ($_[0]=~/^\d+$/ ? 'port' : 'name')}(@_);
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-Net::servent - by-name interface to Perl's built-in getserv*() functions
-
-=head1 SYNOPSIS
-
- use Net::servent;
- $s = getservbyname(shift || 'ftp') || die "no service";
- printf "port for %s is %s, aliases are %s\n",
- $s->name, $s->port, "@{$s->aliases}";
-
- use Net::servent qw(:FIELDS);
- getservbyname(shift || 'ftp') || die "no service";
- print "port for $s_name is $s_port, aliases are @s_aliases\n";
-
-=head1 DESCRIPTION
-
-This module's default exports override the core getservent(),
-getservbyname(), and
-getnetbyport() functions, replacing them with versions that return
-"Net::servent" objects. They take default second arguments of "tcp". This object has methods that return the similarly
-named structure field name from the C's servent structure from F<netdb.h>;
-namely name, aliases, port, and proto. The aliases
-method returns an array reference, the rest scalars.
-
-You may also import all the structure fields directly into your namespace
-as regular variables using the :FIELDS import tag. (Note that this still
-overrides your core functions.) Access these fields as variables named
-with a preceding C<s_>. Thus, C<$serv_obj-E<gt>name()> corresponds to
-$s_name if you import the fields. Array references are available as
-regular array variables, so for example C<@{ $serv_obj-E<gt>aliases()}>
-would be simply @s_aliases.
-
-The getserv() function is a simple front-end that forwards a numeric
-argument to getservbyport(), and the rest to getservbyname().
-
-To access this functionality without the core overrides,
-pass the C<use> an empty import list, and then access
-function functions with their full qualified names.
-On the other hand, the built-ins are still available
-via the C<CORE::> pseudo-package.
-
-=head1 EXAMPLES
-
- use Net::servent qw(:FIELDS);
-
- while (@ARGV) {
- my ($service, $proto) = ((split m!/!, shift), 'tcp');
- my $valet = getserv($service, $proto);
- unless ($valet) {
- warn "$0: No service: $service/$proto\n"
- next;
- }
- printf "service $service/$proto is port %d\n", $valet->port;
- print "alias are @s_aliases\n" if @s_aliases;
- }
-
-=head1 NOTE
-
-While this class is currently implemented using the Class::Struct
-module to build a struct-like class, you shouldn't rely upon this.
-
-=head1 AUTHOR
-
-Tom Christiansen