summaryrefslogtreecommitdiff
path: root/systems/texlive/tlnet/tlpkg/tlperl/lib/Net
diff options
context:
space:
mode:
authorNorbert Preining <norbert@preining.info>2019-09-02 13:46:59 +0900
committerNorbert Preining <norbert@preining.info>2019-09-02 13:46:59 +0900
commite0c6872cf40896c7be36b11dcc744620f10adf1d (patch)
tree60335e10d2f4354b0674ec22d7b53f0f8abee672 /systems/texlive/tlnet/tlpkg/tlperl/lib/Net
Initial commit
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tlperl/lib/Net')
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/Net/Cmd.pm873
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/Net/Config.pm345
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/Net/Domain.pm365
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/Net/FTP.pm2049
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/Net/FTP/A.pm115
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/Net/FTP/E.pm13
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/Net/FTP/I.pm84
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/Net/FTP/L.pm13
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/Net/FTP/dataconn.pm182
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/Net/NNTP.pm1302
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/Net/Netrc.pm347
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/Net/POP3.pm863
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/Net/Ping.pm2475
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/Net/SMTP.pm1046
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/Net/Time.pm164
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/Net/hostent.pm156
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/Net/libnetFAQ.pod301
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/Net/netent.pm173
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/Net/protoent.pm96
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/Net/servent.pm113
20 files changed, 11075 insertions, 0 deletions
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/Cmd.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/Cmd.pm
new file mode 100644
index 0000000000..b695f64dd0
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/Cmd.pm
@@ -0,0 +1,873 @@
+# Net::Cmd.pm
+#
+# Copyright (C) 1995-2006 Graham Barr. All rights reserved.
+# Copyright (C) 2013-2016 Steve Hay. All rights reserved.
+# This module is free software; you can redistribute it and/or modify it under
+# the same terms as Perl itself, i.e. under the terms of either the GNU General
+# Public License or the Artistic License, as specified in the F<LICENCE> file.
+
+package Net::Cmd;
+
+use 5.008001;
+
+use strict;
+use warnings;
+
+use Carp;
+use Exporter;
+use Symbol 'gensym';
+use Errno 'EINTR';
+
+BEGIN {
+ if ($^O eq 'os390') {
+ require Convert::EBCDIC;
+
+ # Convert::EBCDIC->import;
+ }
+}
+
+our $VERSION = "3.11";
+our @ISA = qw(Exporter);
+our @EXPORT = qw(CMD_INFO CMD_OK CMD_MORE CMD_REJECT CMD_ERROR CMD_PENDING);
+
+use constant CMD_INFO => 1;
+use constant CMD_OK => 2;
+use constant CMD_MORE => 3;
+use constant CMD_REJECT => 4;
+use constant CMD_ERROR => 5;
+use constant CMD_PENDING => 0;
+
+use constant DEF_REPLY_CODE => 421;
+
+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 'refs'; ## no critic (TestingAndDebugging::ProhibitNoStrict)
+
+ 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'} = $cmd->DEF_REPLY_CODE
+ 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 = defined $resp ? [$resp] : []
+ unless ref($resp);
+
+ (${*$cmd}{'net_cmd_code'}, ${*$cmd}{'net_cmd_resp'}) = ($code, $resp);
+
+ 1;
+}
+
+sub _syswrite_with_timeout {
+ my $cmd = shift;
+ my $line = shift;
+
+ my $len = length($line);
+ my $offset = 0;
+ my $win = "";
+ vec($win, fileno($cmd), 1) = 1;
+ my $timeout = $cmd->timeout || undef;
+ my $initial = time;
+ my $pending = $timeout;
+
+ local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
+
+ while ($len) {
+ my $wout;
+ my $nfound = select(undef, $wout = $win, undef, $pending);
+ if ((defined $nfound and $nfound > 0) or -f $cmd) # -f for testing on win32
+ {
+ my $w = syswrite($cmd, $line, $len, $offset);
+ if (! defined($w) ) {
+ my $err = $!;
+ $cmd->close;
+ $cmd->_set_status_closed($err);
+ return;
+ }
+ $len -= $w;
+ $offset += $w;
+ }
+ elsif ($nfound == -1) {
+ if ( $! == EINTR ) {
+ if ( defined($timeout) ) {
+ redo if ($pending = $timeout - ( time - $initial ) ) > 0;
+ $cmd->_set_status_timeout;
+ return;
+ }
+ redo;
+ }
+ my $err = $!;
+ $cmd->close;
+ $cmd->_set_status_closed($err);
+ return;
+ }
+ else {
+ $cmd->_set_status_timeout;
+ return;
+ }
+ }
+
+ return 1;
+}
+
+sub _set_status_timeout {
+ my $cmd = shift;
+ my $pkg = ref($cmd) || $cmd;
+
+ $cmd->set_status($cmd->DEF_REPLY_CODE, "[$pkg] Timeout");
+ carp(ref($cmd) . ": " . (caller(1))[3] . "(): timeout") if $cmd->debug;
+}
+
+sub _set_status_closed {
+ my $cmd = shift;
+ my $err = shift;
+ my $pkg = ref($cmd) || $cmd;
+
+ $cmd->set_status($cmd->DEF_REPLY_CODE, "[$pkg] Connection closed");
+ carp(ref($cmd) . ": " . (caller(1))[3]
+ . "(): unexpected EOF on command channel: $err") if $cmd->debug;
+}
+
+sub _is_closed {
+ my $cmd = shift;
+ if (!defined fileno($cmd)) {
+ $cmd->_set_status_closed($!);
+ return 1;
+ }
+ return 0;
+}
+
+sub command {
+ my $cmd = shift;
+
+ return $cmd
+ if $cmd->_is_closed;
+
+ $cmd->dataend()
+ if (exists ${*$cmd}{'net_cmd_last_ch'});
+
+ if (scalar(@_)) {
+ my $str = join(
+ " ",
+ map {
+ /\n/
+ ? do { my $n = $_; $n =~ tr/\n/ /; $n }
+ : $_;
+ } @_
+ );
+ $str = $cmd->toascii($str) if $tr;
+ $str .= "\015\012";
+
+ $cmd->debug_print(1, $str)
+ if ($cmd->debug);
+
+ # though documented to return undef on failure, the legacy behavior
+ # was to return $cmd even on failure, so this odd construct does that
+ $cmd->_syswrite_with_timeout($str)
+ or return $cmd;
+ }
+
+ $cmd;
+}
+
+
+sub ok {
+ @_ == 1 or croak 'usage: $obj->ok()';
+
+ my $code = $_[0]->code;
+ 0 < $code && $code < 400;
+}
+
+
+sub unsupported {
+ my $cmd = shift;
+
+ $cmd->set_status(580, 'Unsupported command');
+
+ 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'} : "";
+
+ return
+ if $cmd->_is_closed;
+
+ my $fd = fileno($cmd);
+ 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)) {
+ my $err = $!;
+ $cmd->close;
+ $cmd->_set_status_closed($err);
+ return;
+ }
+
+ 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 {
+ $cmd->_set_status_timeout;
+ return;
+ }
+ }
+
+ ${*$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->set_status($cmd->DEF_REPLY_CODE, undef); # initialize the response
+
+ 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) {
+ carp("$cmd: response(): parse error in '$str'") if ($cmd->debug);
+ $cmd->ungetline($str);
+ $@ = $str; # $@ used as tunneling hack
+ return CMD_ERROR;
+ }
+
+ ${*$cmd}{'net_cmd_code'} = $code;
+
+ push(@{${*$cmd}{'net_cmd_resp'}}, $str);
+
+ last unless ($more);
+ }
+
+ return unless defined $code;
+ substr($code, 0, 1);
+}
+
+
+sub read_until_dot {
+ my $cmd = shift;
+ my $fh = shift;
+ my $arr = [];
+
+ while (1) {
+ my $str = $cmd->getline() or return;
+
+ $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);
+
+ # Perls < 5.10.1 (with the exception of 5.8.9) have a performance problem with
+ # the substitutions below when dealing with strings stored internally in
+ # UTF-8, so downgrade them (if possible).
+ # Data passed to datasend() should be encoded to octets upstream already so
+ # shouldn't even have the UTF-8 flag on to start with, but if it so happens
+ # that the octets are stored in an upgraded string (as can sometimes occur)
+ # then they would still downgrade without fail anyway.
+ # Only Unicode codepoints > 0xFF stored in an upgraded string will fail to
+ # downgrade. We fail silently in that case, and a "Wide character in print"
+ # warning will be emitted later by syswrite().
+ utf8::downgrade($line, 1) if $] < 5.010001 && $] != 5.008009;
+
+ return 0
+ if $cmd->_is_closed;
+
+ my $last_ch = ${*$cmd}{'net_cmd_last_ch'};
+
+ # We have not send anything yet, so last_ch = "\012" means we are at the start of a line
+ $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") {
+ # Remove \012 so it does not get prefixed with another \015 below
+ # and escape the . if there is one following it because the fixup
+ # below will not find it
+ $first_ch = "\012" if $line =~ s/^\012(\.?)/$1$1/;
+ }
+ elsif ($last_ch eq "\012") {
+ # Fixup below will not find the . as the first character of the buffer
+ $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);
+
+ $cmd->_syswrite_with_timeout($line)
+ or return;
+
+ 1;
+}
+
+
+sub rawdatasend {
+ my $cmd = shift;
+ my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_;
+ my $line = join("", @$arr);
+
+ return 0
+ if $cmd->_is_closed;
+
+ return 1
+ unless length($line);
+
+ if ($cmd->debug) {
+ my $b = "$cmd>>> ";
+ print STDERR $b, join("\n$b", split(/\n/, $line)), "\n";
+ }
+
+ $cmd->_syswrite_with_timeout($line)
+ or return;
+
+ 1;
+}
+
+
+sub dataend {
+ my $cmd = shift;
+
+ return 0
+ if $cmd->_is_closed;
+
+ my $ch = ${*$cmd}{'net_cmd_last_ch'};
+ my $tosend;
+
+ if (!defined $ch) {
+ return 1;
+ }
+ elsif ($ch ne "\012") {
+ $tosend = "\015\012";
+ }
+
+ $tosend .= ".\015\012";
+
+ $cmd->debug_print(1, ".\n")
+ if ($cmd->debug);
+
+ $cmd->_syswrite_with_timeout($tosend)
+ or return 0;
+
+ 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::Socket::INET>. These methods implement the functionality required for a
+command based protocol, for example FTP and SMTP.
+
+If your sub-class does not also derive from C<IO::Socket::INET> or similar (e.g.
+C<IO::Socket::IP>, C<IO::Socket::INET6> or C<IO::Socket::SSL>) then you must
+provide the following methods by other means yourself: C<close()> and
+C<timeout()>.
+
+=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. In a scalar
+context it returns a single string, in a list context it will return
+each line as a separate element. (See L<PSEUDO RESPONSES> below.)
+
+=item code ()
+
+Returns the 3-digit code from the last command. If a command is pending
+then the value 0 is returned. (See L<PSEUDO RESPONSES> below.)
+
+=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.
+The C<DATA> passed in must be encoded by the caller to octets of whatever
+encoding is required, e.g. by using the Encode module's C<encode()> function.
+
+=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 ( DIR, 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 are 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<CMD_ERROR> 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 last.
+
+=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.
+As with C<datasend()>, the C<DATA> passed in must be encoded by the caller
+to octets of whatever encoding is required, e.g. by using the Encode module's
+C<encode()> function.
+
+=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 PSEUDO RESPONSES
+
+Normally the values returned by C<message()> and C<code()> are
+obtained from the remote server, but in a few circumstances, as
+detailed below, C<Net::Cmd> will return values that it sets. You
+can alter this behavior by overriding DEF_REPLY_CODE() to specify
+a different default reply code, or overriding one of the specific
+error handling methods below.
+
+=over 4
+
+=item Initial value
+
+Before any command has executed or if an unexpected error occurs
+C<code()> will return "421" (temporary connection failure) and
+C<message()> will return undef.
+
+=item Connection closed
+
+If the underlying C<IO::Handle> is closed, or if there are
+any read or write failures, the file handle will be forced closed,
+and C<code()> will return "421" (temporary connection failure)
+and C<message()> will return "[$pkg] Connection closed"
+(where $pkg is the name of the class that subclassed C<Net::Cmd>).
+The _set_status_closed() method can be overridden to set a different
+message (by calling set_status()) or otherwise trap this error.
+
+=item Timeout
+
+If there is a read or write timeout C<code()> will return "421"
+(temporary connection failure) and C<message()> will return
+"[$pkg] Timeout" (where $pkg is the name of the class
+that subclassed C<Net::Cmd>). The _set_status_timeout() method
+can be overridden to set a different message (by calling set_status())
+or otherwise trap this error.
+
+=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 E<lt>F<gbarr@pobox.com>E<gt>.
+
+Steve Hay E<lt>F<shay@cpan.org>E<gt> is now maintaining libnet as of version
+1.22_02.
+
+=head1 COPYRIGHT
+
+Copyright (C) 1995-2006 Graham Barr. All rights reserved.
+
+Copyright (C) 2013-2016 Steve Hay. All rights reserved.
+
+=head1 LICENCE
+
+This module is free software; you can redistribute it and/or modify it under the
+same terms as Perl itself, i.e. under the terms of either the GNU General Public
+License or the Artistic License, as specified in the F<LICENCE> file.
+
+=cut
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/Config.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/Config.pm
new file mode 100644
index 0000000000..4f822a40a4
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/Config.pm
@@ -0,0 +1,345 @@
+# Net::Config.pm
+#
+# Copyright (C) 2000 Graham Barr. All rights reserved.
+# Copyright (C) 2013-2014, 2016 Steve Hay. All rights reserved.
+# This module is free software; you can redistribute it and/or modify it under
+# the same terms as Perl itself, i.e. under the terms of either the GNU General
+# Public License or the Artistic License, as specified in the F<LICENCE> file.
+
+package Net::Config;
+
+use 5.008001;
+
+use strict;
+use warnings;
+
+use Exporter;
+use Socket qw(inet_aton inet_ntoa);
+
+our @EXPORT = qw(%NetConfig);
+our @ISA = qw(Net::LocalCfg Exporter);
+our $VERSION = "3.11";
+
+our($CONFIGURE, $LIBNET_CFG);
+
+eval {
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
+ local $SIG{__DIE__};
+ require Net::LocalCfg;
+};
+
+our %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
+#
+{
+## no critic (BuiltinFunctions::ProhibitStringyEval)
+$^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;
+}
+
+*is_external = \&requires_firewall;
+
+1;
+
+__END__
+
+=head1 NAME
+
+Net::Config - Local configuration data for libnet
+
+=head1 SYNOPSIS
+
+ 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 0Z<>
+
+There is no firewall
+
+=item 1Z<>
+
+ USER user@remote.host
+ PASS pass
+
+=item 2Z<>
+
+ USER fwuser
+ PASS fwpass
+ USER user@remote.host
+ PASS pass
+
+=item 3Z<>
+
+ USER fwuser
+ PASS fwpass
+ SITE remote.site
+ USER user
+ PASS pass
+
+=item 4Z<>
+
+ USER fwuser
+ PASS fwpass
+ OPEN remote.site
+ USER user
+ PASS pass
+
+=item 5Z<>
+
+ USER user@fwuser@remote.site
+ PASS pass@fwpass
+
+=item 6Z<>
+
+ USER fwuser@remote.site
+ PASS fwpass
+ USER user
+ PASS pass
+
+=item 7Z<>
+
+ 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
+
+=head1 AUTHOR
+
+Graham Barr E<lt>F<gbarr@pobox.com>E<gt>.
+
+Steve Hay E<lt>F<shay@cpan.org>E<gt> is now maintaining libnet as of version
+1.22_02.
+
+=head1 COPYRIGHT
+
+Copyright (C) 1998-2011 Graham Barr. All rights reserved.
+
+Copyright (C) 2013-2014, 2016 Steve Hay. All rights reserved.
+
+=head1 LICENCE
+
+This module is free software; you can redistribute it and/or modify it under the
+same terms as Perl itself, i.e. under the terms of either the GNU General Public
+License or the Artistic License, as specified in the F<LICENCE> file.
+
+=cut
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/Domain.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/Domain.pm
new file mode 100644
index 0000000000..556cc15980
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/Domain.pm
@@ -0,0 +1,365 @@
+# Net::Domain.pm
+#
+# Copyright (C) 1995-1998 Graham Barr. All rights reserved.
+# Copyright (C) 2013-2014 Steve Hay. All rights reserved.
+# This module is free software; you can redistribute it and/or modify it under
+# the same terms as Perl itself, i.e. under the terms of either the GNU General
+# Public License or the Artistic License, as specified in the F<LICENCE> file.
+
+package Net::Domain;
+
+use 5.008001;
+
+use strict;
+use warnings;
+
+use Carp;
+use Exporter;
+use Net::Config;
+
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw(hostname hostdomain hostfqdn domainname);
+our $VERSION = "3.11";
+
+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"; ## no critic (Modules::RequireBarewordIncludes)
+ defined(&main::SYS_gethostname);
+ }
+ || eval {
+ package main;
+ require "sys/syscall.ph"; ## no critic (Modules::RequireBarewordIncludes)
+ 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 ($_);
+
+ if (open(my $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"; ## no critic (Modules::RequireBarewordIncludes)
+ }
+ || eval {
+ package main;
+ require "sys/syscall.ph"; ## no critic (Modules::RequireBarewordIncludes)
+ }
+ 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|android)/);
+
+ 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
+ foreach my $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();
+
+ # *.local names are special on darwin. If we call gethostbyname below, it
+ # may hang while waiting for another, non-existent computer to respond.
+ if($^O eq 'darwin' && $host =~ /\.local$/) {
+ return $host;
+ }
+
+ _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
+ # eliminate 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 E<lt>F<gbarr@pobox.com>E<gt>.
+
+Adapted from Sys::Hostname by David Sundstrom E<lt>F<sunds@asictest.sc.ti.com>E<gt>.
+
+Steve Hay E<lt>F<shay@cpan.org>E<gt> is now maintaining libnet as of version
+1.22_02.
+
+=head1 COPYRIGHT
+
+Copyright (C) 1995-1998 Graham Barr. All rights reserved.
+
+Copyright (C) 2013-2014 Steve Hay. All rights reserved.
+
+=head1 LICENCE
+
+This module is free software; you can redistribute it and/or modify it under the
+same terms as Perl itself, i.e. under the terms of either the GNU General Public
+License or the Artistic License, as specified in the F<LICENCE> file.
+
+=cut
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/FTP.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/FTP.pm
new file mode 100644
index 0000000000..14153be0d0
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/FTP.pm
@@ -0,0 +1,2049 @@
+# Net::FTP.pm
+#
+# Copyright (C) 1995-2004 Graham Barr. All rights reserved.
+# Copyright (C) 2013-2017 Steve Hay. All rights reserved.
+# This module is free software; you can redistribute it and/or modify it under
+# the same terms as Perl itself, i.e. under the terms of either the GNU General
+# Public License or the Artistic License, as specified in the F<LICENCE> file.
+#
+# Documentation (at end) improved 1996 by Nathan Torkington <gnat@frii.com>.
+
+package Net::FTP;
+
+use 5.008001;
+
+use strict;
+use warnings;
+
+use Carp;
+use Fcntl qw(O_WRONLY O_RDONLY O_APPEND O_CREAT O_TRUNC);
+use IO::Socket;
+use Net::Cmd;
+use Net::Config;
+use Socket;
+use Time::Local;
+
+our $VERSION = '3.11';
+
+our $IOCLASS;
+my $family_key;
+BEGIN {
+ # Code for detecting if we can use SSL
+ my $ssl_class = eval {
+ require IO::Socket::SSL;
+ # first version with default CA on most platforms
+ no warnings 'numeric';
+ IO::Socket::SSL->VERSION(2.007);
+ } && 'IO::Socket::SSL';
+
+ my $nossl_warn = !$ssl_class &&
+ 'To use SSL please install IO::Socket::SSL with version>=2.007';
+
+ # Code for detecting if we can use IPv6
+ my $inet6_class = eval {
+ require IO::Socket::IP;
+ no warnings 'numeric';
+ IO::Socket::IP->VERSION(0.25);
+ } && 'IO::Socket::IP' || eval {
+ require IO::Socket::INET6;
+ no warnings 'numeric';
+ IO::Socket::INET6->VERSION(2.62);
+ } && 'IO::Socket::INET6';
+
+ sub can_ssl { $ssl_class };
+ sub can_inet6 { $inet6_class };
+
+ $IOCLASS = $ssl_class || $inet6_class || 'IO::Socket::INET';
+ $family_key =
+ ( $ssl_class ? $ssl_class->can_ipv6 : $inet6_class || '' )
+ eq 'IO::Socket::IP'
+ ? 'Family' : 'Domain';
+}
+
+our @ISA = ('Exporter','Net::Cmd',$IOCLASS);
+
+use constant TELNET_IAC => 255;
+use constant TELNET_IP => 244;
+use constant TELNET_DM => 242;
+
+use constant EBCDIC => $^O eq '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 %tlsargs;
+ if (can_ssl()) {
+ # for name verification strip port from domain:port, ipv4:port, [ipv6]:port
+ (my $hostname = $host) =~s{(?<!:):\d+$}{};
+ %tlsargs = (
+ SSL_verifycn_scheme => 'ftp',
+ SSL_verifycn_name => $hostname,
+ # use SNI if supported by IO::Socket::SSL
+ $pkg->can_client_sni ? (SSL_hostname => $hostname):(),
+ # reuse SSL session of control connection in data connections
+ SSL_session_cache => Net::FTP::_SSL_SingleSessionCache->new,
+ );
+ # user defined SSL arg
+ $tlsargs{$_} = $arg{$_} for(grep { m{^SSL_} } keys %arg);
+
+ } elsif ($arg{SSL}) {
+ croak("IO::Socket::SSL >= 2.007 needed for SSL support");
+ }
+
+ my $ftp = $pkg->SUPER::new(
+ PeerAddr => $peer,
+ PeerPort => $arg{Port} || ($arg{SSL} ? 'ftps(990)' : 'ftp(21)'),
+ LocalAddr => $arg{'LocalAddr'},
+ $family_key => $arg{Domain} || $arg{Family},
+ Proto => 'tcp',
+ Timeout => defined $arg{Timeout} ? $arg{Timeout} : 120,
+ %tlsargs,
+ $arg{SSL} ? ():( SSL_startHandshake => 0 ),
+ ) or return;
+
+ ${*$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_domain'} = $arg{Domain} || $arg{Family};
+
+ ${*$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}{net_ftp_tlsargs} = \%tlsargs if %tlsargs;
+ if ($arg{SSL}) {
+ ${*$ftp}{net_ftp_tlsprot} = 'P';
+ ${*$ftp}{net_ftp_tlsdirect} = 1;
+ }
+
+ $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();
+ # keep @$ if no message. Happens, when response did not start with a code.
+ $@ = $ftp->message || $@;
+ undef $ftp;
+ }
+
+ $ftp;
+}
+
+##
+## User interface methods
+##
+
+
+sub host {
+ my $me = shift;
+ ${*$me}{'net_ftp_host'};
+}
+
+sub passive {
+ my $ftp = shift;
+ return ${*$ftp}{'net_ftp_passive'} unless @_;
+ ${*$ftp}{'net_ftp_passive'} = shift;
+}
+
+
+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
+ unless $ftp->_STAT($file) && (@msg = $ftp->message) == 3;
+ foreach my $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 starttls {
+ my $ftp = shift;
+ can_ssl() or croak("IO::Socket::SSL >= 2.007 needed for SSL support");
+ $ftp->is_SSL and croak("called starttls within SSL session");
+ $ftp->_AUTH('TLS') == CMD_OK or return;
+
+ $ftp->connect_SSL or return;
+ $ftp->prot('P');
+ return 1;
+}
+
+sub prot {
+ my ($ftp,$prot) = @_;
+ $prot eq 'C' or $prot eq 'P' or croak("prot must by C or P");
+ $ftp->_PBSZ(0) or return;
+ $ftp->_PROT($prot) or return;
+ ${*$ftp}{net_ftp_tlsprot} = $prot;
+ return 1;
+}
+
+sub stoptls {
+ my $ftp = shift;
+ $ftp->is_SSL or croak("called stoptls outside SSL session");
+ ${*$ftp}{net_ftp_tlsdirect} and croak("cannot stoptls direct SSL session");
+ $ftp->_CCC() or return;
+ $ftp->stop_SSL();
+ return 1;
+}
+
+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 || "");
+
+ return $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
+ 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
+ unless ($ftp->supported("ALLO") and $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;
+
+ 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;
+ }
+ }
+
+ if ($ftp->type eq 'I' && !binmode($loc)) {
+ carp "Cannot binmode Local file $local: $!\n";
+ $data->abort;
+ close($loc) unless $localfd;
+ return;
+ }
+
+ $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 (EBCDIC && $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;
+ }
+ }
+
+ print $hashh "\n" if $hashh;
+
+ unless ($localfd) {
+ unless (close($loc)) {
+ carp "Cannot close file $local (perhaps disk space) $!\n";
+ return;
+ }
+ }
+
+ unless ($data->close()) # implied $ftp->response
+ {
+ carp "Unable to close datastream";
+ return;
+ }
+
+ 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, excluding the current and parent directories
+ my @filelist = map { /^(?:\S+;)+ (.+)$/ ? ($1) : () } grep { !/^(?:\S+;)*type=[cp]dir;/i } $ftp->_list_cmd("MLSD", $dir);
+
+ # Fallback to using the less well-defined NLST command if MLSD fails
+ @filelist = grep { !/^\.{1,2}$/ } $ftp->ls($dir)
+ unless @filelist;
+
+ return
+ unless @filelist; # failed, it is probably not a directory
+
+ return $ftp->delete($dir)
+ if @filelist == 1 and $dir eq $filelist[0];
+
+ # Go thru and delete each file or the directory
+ foreach my $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;
+}
+
+
+sub mkdir {
+ @_ == 2 || @_ == 3 or croak 'usage: $ftp->mkdir( DIR [, RECURSE ] )';
+
+ my ($ftp, $dir, $recurse) = @_;
+
+ $ftp->_MKD($dir) || $recurse
+ or return;
+
+ 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";
+
+ if (!defined($remote) and 'STOU' ne uc($cmd)) {
+ 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}{'net_ftp_allo'} = $size if $size;
+ }
+ croak("Bad remote filename '$remote'\n")
+ if defined($remote) and $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;
+ }
+ }
+
+ if ($ftp->type eq 'I' && !binmode($loc)) {
+ carp "Cannot binmode Local file $local: $!\n";
+ return;
+ }
+
+ delete ${*$ftp}{'net_ftp_port'};
+ delete ${*$ftp}{'net_ftp_pasv'};
+
+ $sock = $ftp->_data_cmd($cmd, grep { defined } $remote)
+ or return;
+
+ $remote = ($ftp->message =~ /\w+\s*:\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 (EBCDIC && $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;
+ }
+ }
+
+ print $hashh "\n" if $hashh;
+
+ close($loc)
+ unless $localfd;
+
+ $sock->close()
+ or return;
+
+ 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: $self->port([PORT])';
+ return _eprt('PORT',@_);
+}
+
+sub eprt {
+ @_ == 1 || @_ == 2 or croak 'usage: $self->eprt([PORT])';
+ return _eprt('EPRT',@_);
+}
+
+sub _eprt {
+ my ($cmd,$ftp,$port) = @_;
+ delete ${*$ftp}{net_ftp_intern_port};
+ unless ($port) {
+ my $listen = ${*$ftp}{net_ftp_listen} ||= $IOCLASS->new(
+ Listen => 1,
+ Timeout => $ftp->timeout,
+ LocalAddr => $ftp->sockhost,
+ $family_key => $ftp->sockdomain,
+ can_ssl() ? (
+ %{ ${*$ftp}{net_ftp_tlsargs} },
+ SSL_startHandshake => 0,
+ ):(),
+ );
+ ${*$ftp}{net_ftp_intern_port} = 1;
+ my $fam = ($listen->sockdomain == AF_INET) ? 1:2;
+ if ( $cmd eq 'EPRT' || $fam == 2 ) {
+ $port = "|$fam|".$listen->sockhost."|".$listen->sockport."|";
+ $cmd = 'EPRT';
+ } else {
+ my $p = $listen->sockport;
+ $port = join(',',split(m{\.},$listen->sockhost),$p >> 8,$p & 0xff);
+ }
+ } elsif (ref($port) eq 'ARRAY') {
+ $port = join(',',split(m{\.},@$port[0]),@$port[1] >> 8,@$port[1] & 0xff);
+ }
+ my $ok = $cmd eq 'EPRT' ? $ftp->_EPRT($port) : $ftp->_PORT($port);
+ ${*$ftp}{net_ftp_port} = $port if $ok;
+ return $ok;
+}
+
+
+sub ls { shift->_list_cmd("NLST", @_); }
+sub dir { shift->_list_cmd("LIST", @_); }
+
+
+sub pasv {
+ my $ftp = shift;
+ @_ and croak 'usage: $ftp->port()';
+ return $ftp->epsv if $ftp->sockdomain != AF_INET;
+ delete ${*$ftp}{net_ftp_intern_port};
+
+ if ( $ftp->_PASV &&
+ $ftp->message =~ m{(\d+,\d+,\d+,\d+),(\d+),(\d+)} ) {
+ my $port = 256 * $2 + $3;
+ ( my $ip = $1 ) =~s{,}{.}g;
+ return ${*$ftp}{net_ftp_pasv} = [ $ip,$port ];
+ }
+ return;
+}
+
+sub epsv {
+ my $ftp = shift;
+ @_ and croak 'usage: $ftp->epsv()';
+ delete ${*$ftp}{net_ftp_intern_port};
+
+ $ftp->_EPSV && $ftp->message =~ m{\(([\x33-\x7e])\1\1(\d+)\1\)}
+ ? ${*$ftp}{net_ftp_pasv} = [ $ftp->peerhost, $2 ]
+ : 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} = 1
+ if $ftp->feature($cmd);
+
+ return $hash->{$cmd} = 0
+ unless $ftp->_HELP($cmd);
+
+ my $text = $ftp->message;
+ if ($text =~ /following.+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 $pkg = "Net::FTP::" . $ftp->type;
+ eval "require " . $pkg ## no critic (BuiltinFunctions::ProhibitStringyEval)
+ or croak("cannot load $pkg required for type ".$ftp->type);
+ $pkg =~ s/ /_/g;
+ delete ${*$ftp}{net_ftp_dataconn};
+
+ my $conn;
+ my $pasv = ${*$ftp}{net_ftp_pasv};
+ if ($pasv) {
+ $conn = $pkg->new(
+ PeerAddr => $pasv->[0],
+ PeerPort => $pasv->[1],
+ LocalAddr => ${*$ftp}{net_ftp_localaddr},
+ $family_key => ${*$ftp}{net_ftp_domain},
+ Timeout => $ftp->timeout,
+ can_ssl() ? (
+ SSL_startHandshake => 0,
+ $ftp->is_SSL ? (
+ SSL_reuse_ctx => $ftp,
+ SSL_verifycn_name => ${*$ftp}{net_ftp_tlsargs}{SSL_verifycn_name},
+ # This will cause the use of SNI if supported by IO::Socket::SSL.
+ $ftp->can_client_sni ? (
+ SSL_hostname => ${*$ftp}{net_ftp_tlsargs}{SSL_hostname}
+ ):(),
+ ) :( %{${*$ftp}{net_ftp_tlsargs}} ),
+ ):(),
+ ) or return;
+ } elsif (my $listen = delete ${*$ftp}{net_ftp_listen}) {
+ $conn = $listen->accept($pkg) or return;
+ $conn->timeout($ftp->timeout);
+ close($listen);
+ } else {
+ croak("no listener in active mode");
+ }
+
+ if (( ${*$ftp}{net_ftp_tlsprot} || '') eq 'P') {
+ if ($conn->connect_SSL) {
+ # SSL handshake ok
+ } else {
+ carp("failed to ssl upgrade dataconn: $IO::Socket::SSL::SSL_ERROR");
+ return;
+ }
+ }
+
+ ${*$ftp}{net_ftp_dataconn} = $conn;
+ ${*$conn} = "";
+ ${*$conn}{net_ftp_cmd} = $ftp;
+ ${*$conn}{net_ftp_blksize} = ${*$ftp}{net_ftp_blksize};
+ return $conn;
+}
+
+
+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 (EBCDIC) {
+ 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 my $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'})
+ {
+ return unless defined $ftp->pasv;
+
+ if ($where and !$ftp->_REST($where)) {
+ my ($status, $message) = ($ftp->status, $ftp->message);
+ $ftp->abort;
+ $ftp->set_status($status, $message);
+ return;
+ }
+
+ # first send command, then open data connection
+ # otherwise the peer might not do a full accept (with SSL
+ # handshake if PROT P)
+ $ftp->command($cmd, @_);
+ my $data = $ftp->_dataconn();
+ if (CMD_INFO == $ftp->response()) {
+ $data->reading
+ if $data && $cmd =~ /RETR|LIST|NLST|MLSD/;
+ return $data;
+ }
+ $data->_close if $data;
+
+ return;
+ }
+
+ $ok = $ftp->port
+ unless (defined ${*$ftp}{'net_ftp_port'}
+ || defined ${*$ftp}{'net_ftp_pasv'});
+
+ $ok = $ftp->_REST($where)
+ if $ok && $where;
+
+ return
+ unless $ok;
+
+ if ($cmd =~ /(STOR|APPE|STOU)/ and exists ${*$ftp}{net_ftp_allo} and
+ $ftp->supported("ALLO"))
+ {
+ $ftp->_ALLO(delete ${*$ftp}{net_ftp_allo})
+ or return;
+ }
+
+ $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|MLSD/;
+
+ return $data;
+ }
+
+
+ close(delete ${*$ftp}{'net_ftp_listen'});
+
+ return;
+}
+
+##
+## 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() || 5; # assume 500 if undef
+
+ 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 !!!!
+ # Expect to see undef here.
+ return ()
+ unless 0 + (${*$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;
+
+ $dftp->port($port)
+ or return;
+
+ return
+ unless ($unique ? $dftp->stou($dfile) : $dftp->stor($dfile));
+
+ unless ($sftp->retr($sfile) && $sftp->response == CMD_INFO) {
+ $sftp->retr($sfile);
+ $dftp->abort;
+ $dftp->response();
+ return;
+ }
+
+ $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);
+
+ my $dres = $ftp->response();
+ my $sres = $non_pasv->response();
+
+ return
+ unless $dres == CMD_OK && $sres == CMD_OK;
+
+ return
+ 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 + RFC2428 + RFC4217 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 _PBSZ { shift->command("PBSZ", @_)->response() == CMD_OK }
+sub _PROT { shift->command("PROT", @_)->response() == CMD_OK }
+sub _CCC { shift->command("CCC", @_)->response() == CMD_OK }
+sub _EPRT { shift->command("EPRT", @_)->response() == CMD_OK }
+sub _EPSV { shift->command("EPSV", @_)->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(@_) }
+
+{
+ # Session Cache with single entry
+ # used to make sure that we reuse same session for control and data channels
+ package Net::FTP::_SSL_SingleSessionCache;
+ sub new { my $x; return bless \$x,shift }
+ sub add_session {
+ my ($cache,$key,$session) = @_;
+ Net::SSLeay::SESSION_free($$cache) if $$cache;
+ $$cache = $session;
+ }
+ sub get_session {
+ my $cache = shift;
+ return $$cache
+ }
+ sub DESTROY {
+ my $cache = shift;
+ Net::SSLeay::SESSION_free($$cache) if $$cache;
+ }
+}
+
+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 the commonly used subset of the
+RFC959 commands.
+If L<IO::Socket::IP> or L<IO::Socket::INET6> is installed it also provides
+support for IPv6 as defined in RFC2428.
+And with L<IO::Socket::SSL> installed it provides support for implicit FTPS
+and explicit FTPS as defined in RFC4217.
+
+The Net::FTP class is a subclass of Net::Cmd and (depending on avaibility) of
+IO::Socket::IP, IO::Socket::INET6 or IO::Socket::INET.
+
+=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). This class does not support
+the EBCDIC or byte formats, and will default to binary instead if they
+are attempted.
+
+=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<SSL> - If the connection should be done from start with SSL, contrary to later
+upgrade with C<starttls>.
+
+B<SSL_*> - SSL arguments which will be applied when upgrading the control or
+data connection to SSL. You can use SSL arguments as documented in
+L<IO::Socket::SSL>, but it will usually use the right arguments already.
+
+B<Timeout> - Set a timeout value in seconds (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 the super class, i.e. L<IO::Socket::INET>
+or L<IO::Socket::IP>.
+
+B<Domain> - Domain to use, i.e. AF_INET or AF_INET6. This
+argument will be passed to the IO::Socket super class.
+This can be used to enforce IPv4 even with L<IO::Socket::IP>
+which would default to IPv6.
+B<Family> is accepted as alternative name for B<Domain>.
+
+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.
+
+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 in addition to the methods
+documented here.
+
+=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 starttls ()
+
+Upgrade existing plain connection to SSL.
+The SSL arguments have to be given in C<new> already because they are needed for
+data connections too.
+
+=item stoptls ()
+
+Downgrade existing SSL connection back to plain.
+This is needed to work with some FTP helpers at firewalls, which need to see the
+PORT and PASV commands and responses to dynamically open the necessary ports.
+In this case C<starttls> is usually only done to protect the authorization.
+
+=item prot ( LEVEL )
+
+Set what type of data channel protection the client and server will be using.
+Only C<LEVEL>s "C" (clear) and "P" (private) are supported.
+
+=item host ()
+
+Returns the value used by the constructor, and passed to the IO::Socket super
+class to connect to the host.
+
+=item account( ACCT )
+
+Set a string identifying the user's account.
+
+=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 type ( [ TYPE ] )
+
+Set or get if files will be transferred in ASCII or 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 passive ( [ PASSIVE ] )
+
+Set or get if data connections will be initiated in passive mode.
+
+=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 ] )
+
+=item eprt ( [ PORT ] )
+
+Send a C<PORT> (IPv4) or C<EPRT> (IPv6) 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 ()
+
+=item epsv ()
+
+Tell the server to go into passive mode (C<pasv> for IPv4, C<epsv> for IPv6).
+Returns the text that represents the port on which the server is listening, this
+text is in a suitable form to send to another ftp server using the C<port> or
+C<eprt> 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
+
+=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.
+
+=item can_inet6 ()
+
+Returns whether we can use IPv6.
+
+=item can_ssl ()
+
+Returns whether we can use SSL.
+
+=back
+
+=head1 THE dataconn CLASS
+
+Some of the methods defined in C<Net::FTP> return an object which will
+be derived from the C<Net::FTP::dataconn> class. See L<Net::FTP::dataconn> for
+more details.
+
+=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 E<lt>F<gbarr@pobox.com>E<gt>.
+
+Steve Hay E<lt>F<shay@cpan.org>E<gt> is now maintaining libnet as of version
+1.22_02.
+
+=head1 SEE ALSO
+
+L<Net::Netrc>,
+L<Net::Cmd>,
+L<IO::Socket::SSL>
+
+ftp(1), ftpd(8), RFC 959, RFC 2428, RFC 4217
+http://www.ietf.org/rfc/rfc959.txt
+http://www.ietf.org/rfc/rfc2428.txt
+http://www.ietf.org/rfc/rfc4217.txt
+
+=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.
+
+Copyright (C) 2013-2017 Steve Hay. All rights reserved.
+
+=head1 LICENCE
+
+This module is free software; you can redistribute it and/or modify it under the
+same terms as Perl itself, i.e. under the terms of either the GNU General Public
+License or the Artistic License, as specified in the F<LICENCE> file.
+
+=cut
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/FTP/A.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/FTP/A.pm
new file mode 100644
index 0000000000..0ea1ba2fbd
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/FTP/A.pm
@@ -0,0 +1,115 @@
+##
+## Package to read/write on ASCII data connections
+##
+
+package Net::FTP::A;
+
+use 5.008001;
+
+use strict;
+use warnings;
+
+use Carp;
+use Net::FTP::dataconn;
+
+our @ISA = qw(Net::FTP::dataconn);
+our $VERSION = "3.11";
+
+our $buf;
+
+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
+ 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/\015\012/sg if $nr;
+ $tmp =~ s/^\015// if ${*$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
+ unless defined($wrote);
+ $len -= $wrote;
+ }
+
+ $size;
+}
+
+1;
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/FTP/E.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/FTP/E.pm
new file mode 100644
index 0000000000..30b371a58b
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/FTP/E.pm
@@ -0,0 +1,13 @@
+package Net::FTP::E;
+
+use 5.008001;
+
+use strict;
+use warnings;
+
+use Net::FTP::I;
+
+our @ISA = qw(Net::FTP::I);
+our $VERSION = "3.11";
+
+1;
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/FTP/I.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/FTP/I.pm
new file mode 100644
index 0000000000..ec46ab0fda
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/FTP/I.pm
@@ -0,0 +1,84 @@
+##
+## Package to read/write on BINARY data connections
+##
+
+package Net::FTP::I;
+
+use 5.008001;
+
+use strict;
+use warnings;
+
+use Carp;
+use Net::FTP::dataconn;
+
+our @ISA = qw(Net::FTP::dataconn);
+our $VERSION = "3.11";
+
+our $buf;
+
+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 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 unless defined($n);
+ $sent -= $n;
+ $off += $n;
+ }
+
+ $size;
+}
+
+1;
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/FTP/L.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/FTP/L.pm
new file mode 100644
index 0000000000..d9a88576d9
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/FTP/L.pm
@@ -0,0 +1,13 @@
+package Net::FTP::L;
+
+use 5.008001;
+
+use strict;
+use warnings;
+
+use Net::FTP::I;
+
+our @ISA = qw(Net::FTP::I);
+our $VERSION = "3.11";
+
+1;
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/FTP/dataconn.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/FTP/dataconn.pm
new file mode 100644
index 0000000000..337b0e999b
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/FTP/dataconn.pm
@@ -0,0 +1,182 @@
+##
+## Generic data connection package
+##
+
+package Net::FTP::dataconn;
+
+use 5.008001;
+
+use strict;
+use warnings;
+
+use Carp;
+use Errno;
+use Net::Cmd;
+
+our $VERSION = '3.11';
+
+$Net::FTP::IOCLASS or die "please load Net::FTP before Net::FTP::dataconn";
+our @ISA = $Net::FTP::IOCLASS;
+
+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 continuously 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 defined $ftp
+ && 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;
+ eval { local($SIG{__DIE__}); $data->read($junk, 1, 0) };
+ return $data->abort unless ${*$data}{'net_ftp_eof'};
+ }
+
+ $data->_close;
+
+ return unless defined $ftp;
+
+ $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;
+
+__END__
+
+=head1 NAME
+
+Net::FTP::dataconn - FTP Client data connection class
+
+=head1 DESCRIPTION
+
+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
+
+=cut
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/NNTP.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/NNTP.pm
new file mode 100644
index 0000000000..0c22930148
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/NNTP.pm
@@ -0,0 +1,1302 @@
+# Net::NNTP.pm
+#
+# Copyright (C) 1995-1997 Graham Barr. All rights reserved.
+# Copyright (C) 2013-2016 Steve Hay. All rights reserved.
+# This module is free software; you can redistribute it and/or modify it under
+# the same terms as Perl itself, i.e. under the terms of either the GNU General
+# Public License or the Artistic License, as specified in the F<LICENCE> file.
+
+package Net::NNTP;
+
+use 5.008001;
+
+use strict;
+use warnings;
+
+use Carp;
+use IO::Socket;
+use Net::Cmd;
+use Net::Config;
+use Time::Local;
+
+our $VERSION = "3.11";
+
+# Code for detecting if we can use SSL
+my $ssl_class = eval {
+ require IO::Socket::SSL;
+ # first version with default CA on most platforms
+ no warnings 'numeric';
+ IO::Socket::SSL->VERSION(2.007);
+} && 'IO::Socket::SSL';
+
+my $nossl_warn = !$ssl_class &&
+ 'To use SSL please install IO::Socket::SSL with version>=2.007';
+
+# Code for detecting if we can use IPv6
+my $family_key = 'Domain';
+my $inet6_class = eval {
+ require IO::Socket::IP;
+ no warnings 'numeric';
+ IO::Socket::IP->VERSION(0.25) || die;
+ $family_key = 'Family';
+} && 'IO::Socket::IP' || eval {
+ require IO::Socket::INET6;
+ no warnings 'numeric';
+ IO::Socket::INET6->VERSION(2.62);
+} && 'IO::Socket::INET6';
+
+
+sub can_ssl { $ssl_class };
+sub can_inet6 { $inet6_class };
+
+our @ISA = ('Net::Cmd', $inet6_class || '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 %connect = ( Proto => 'tcp');
+
+ if ($arg{SSL}) {
+ # SSL from start
+ die $nossl_warn if ! $ssl_class;
+ $arg{Port} ||= 563;
+ $connect{$_} = $arg{$_} for(grep { m{^SSL_} } keys %arg);
+ }
+
+ foreach my $o (qw(LocalAddr LocalPort Timeout)) {
+ $connect{$o} = $arg{$o} if exists $arg{$o};
+ }
+ $connect{$family_key} = $arg{Domain} || $arg{Family};
+ $connect{Timeout} = 120 unless defined $connect{Timeout};
+ $connect{PeerPort} = $arg{Port} || 'nntp(119)';
+ foreach my $h (@{$hosts}) {
+ $connect{PeerAddr} = $h;
+ $obj = $type->SUPER::new(%connect) or next;
+ ${*$obj}{'net_nntp_host'} = $h;
+ ${*$obj}{'net_nntp_arg'} = \%arg;
+ if ($arg{SSL}) {
+ Net::NNTP::_SSL->start_SSL($obj,%arg) or next;
+ }
+ last:
+ }
+
+ return
+ unless defined $obj;
+
+ $obj->autoflush(1);
+ $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
+
+ unless ($obj->response() == CMD_OK) {
+ $obj->close;
+ return;
+ }
+
+ 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 succeeds 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 starttls {
+ my $self = shift;
+ $ssl_class or die $nossl_warn;
+ $self->_STARTTLS or return;
+ Net::NNTP::_SSL->start_SSL($self,
+ %{ ${*$self}{'net_nntp_arg'} }, # (ssl) args given in new
+ @_ # more (ssl) args
+ ) or return;
+ return 1;
+}
+
+
+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'};
+
+ return $grp
+ unless (@_ || wantarray);
+
+ my $newgrp = shift;
+
+ $newgrp = (defined($grp) and length($grp)) ? $grp : ""
+ unless defined($newgrp) and length($newgrp);
+
+ return
+ unless $nntp->_GROUP($newgrp) and $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 $_;
+
+ ## no critic (ControlStructures::ProhibitMutatingListFunctions)
+ $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
+ 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;
+
+ my $hash = {};
+
+ foreach my $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;
+
+ my $hash = {};
+
+ foreach my $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;
+
+ my $hash = {};
+
+ foreach my $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 _STARTTLS { shift->command("STARTTLS")->response() == CMD_MORE }
+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;
+}
+
+{
+ package Net::NNTP::_SSL;
+ our @ISA = ( $ssl_class ? ($ssl_class):(), 'Net::NNTP' );
+ sub starttls { die "NNTP connection is already in SSL mode" }
+ sub start_SSL {
+ my ($class,$nntp,%arg) = @_;
+ delete @arg{ grep { !m{^SSL_} } keys %arg };
+ ( $arg{SSL_verifycn_name} ||= $nntp->host )
+ =~s{(?<!:):[\w()]+$}{}; # strip port
+ $arg{SSL_hostname} = $arg{SSL_verifycn_name}
+ if ! defined $arg{SSL_hostname} && $class->can_client_sni;
+ my $ok = $class->SUPER::start_SSL($nntp,
+ SSL_verifycn_scheme => 'nntp',
+ %arg
+ );
+ $@ = $ssl_class->errstr if !$ok;
+ return $ok;
+ }
+}
+
+
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+Net::NNTP - NNTP Client class
+
+=head1 SYNOPSIS
+
+ use Net::NNTP;
+
+ $nntp = Net::NNTP->new("some.host.name");
+ $nntp->quit;
+
+ # start with SSL, e.g. nntps
+ $nntp = Net::NNTP->new("some.host.name", SSL => 1);
+
+ # start with plain and upgrade to SSL
+ $nntp = Net::NNTP->new("some.host.name");
+ $nntp->starttls;
+
+
+=head1 DESCRIPTION
+
+C<Net::NNTP> is a class implementing a simple NNTP client in Perl as described
+in RFC977 and RFC4642.
+With L<IO::Socket::SSL> installed it also provides support for implicit and
+explicit TLS encryption, i.e. NNTPS or NNTP+STARTTLS.
+
+The Net::NNTP class is a subclass of Net::Cmd and (depending on avaibility) of
+IO::Socket::IP, IO::Socket::INET6 or IO::Socket::INET.
+
+=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<Port> - port to connect to.
+Default - 119 for plain NNTP and 563 for immediate SSL (nntps).
+
+B<SSL> - If the connection should be done from start with SSL, contrary to later
+upgrade with C<starttls>.
+You can use SSL arguments as documented in L<IO::Socket::SSL>, but it will
+usually use the right arguments already.
+
+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 innd, by default C<Net::NNTP> will issue a C<MODE READER> command
+so that the remote server becomes nnrpd. 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 innd.
+
+B<LocalAddr> and B<LocalPort> - These parameters are passed directly
+to IO::Socket to allow binding the socket to a specific local address and port.
+
+B<Domain> - This parameter is passed directly to IO::Socket and makes it
+possible to enforce IPv4 connections even if L<IO::Socket::IP> is used as super
+class. Alternatively B<Family> can be used.
+
+=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.
+
+C<Net::NNTP> inherits from C<Net::Cmd> so methods defined in C<Net::Cmd> may
+be used to send commands to the remote NNTP server in addition to the methods
+documented here.
+
+=over 4
+
+=item host ()
+
+Returns the value used by the constructor, and passed to IO::Socket::INET,
+to connect to the host.
+
+=item starttls ()
+
+Upgrade existing plain connection to SSL.
+Any arguments necessary for SSL must be given in C<new> already.
+
+=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 help ( )
+
+Request help text (a short summary of commands that are understood by this
+implementation) from the server. Returns the text or undef upon failure.
+
+=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 then 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
+and must be encoded by the caller to octets of whatever encoding is required,
+e.g. by using the Encode module's C<encode()> function.
+
+=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 the original AUTHINFO USER / AUTHINFO PASS
+form, defined in RFC2980) 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 authinfo_simple ( USER, PASS )
+
+Authenticates to the server (using the proposed NNTP V2 AUTHINFO SIMPLE form,
+defined and deprecated in RFC2980) using the supplied username and password.
+As with L</authinfo> the password is sent in clear text.
+
+=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
+and must be encoded by the caller to octets of whatever encoding is required,
+e.g. by using the Encode module's C<encode()> function.
+
+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.
+
+=item can_inet6 ()
+
+Returns whether we can use IPv6.
+
+=item can_ssl ()
+
+Returns whether we can use SSL.
+
+=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 distribution_patterns ()
+
+Returns a reference to an array where each element, itself an array
+reference, consists of the three fields of a line of the distrib.pats list
+maintained by some NNTP servers, namely: a weight, a wildmat and a value
+which the client may use to construct a Distribution header.
+
+=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>,
+L<IO::Socket::SSL>
+
+=head1 AUTHOR
+
+Graham Barr E<lt>F<gbarr@pobox.com>E<gt>.
+
+Steve Hay E<lt>F<shay@cpan.org>E<gt> is now maintaining libnet as of version
+1.22_02.
+
+=head1 COPYRIGHT
+
+Copyright (C) 1995-1997 Graham Barr. All rights reserved.
+
+Copyright (C) 2013-2016 Steve Hay. All rights reserved.
+
+=head1 LICENCE
+
+This module is free software; you can redistribute it and/or modify it under the
+same terms as Perl itself, i.e. under the terms of either the GNU General Public
+License or the Artistic License, as specified in the F<LICENCE> file.
+
+=cut
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/Netrc.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/Netrc.pm
new file mode 100644
index 0000000000..46fba2787c
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/Netrc.pm
@@ -0,0 +1,347 @@
+# Net::Netrc.pm
+#
+# Copyright (C) 1995-1998 Graham Barr. All rights reserved.
+# Copyright (C) 2013-2014 Steve Hay. All rights reserved.
+# This module is free software; you can redistribute it and/or modify it under
+# the same terms as Perl itself, i.e. under the terms of either the GNU General
+# Public License or the Artistic License, as specified in the F<LICENCE> file.
+
+package Net::Netrc;
+
+use 5.008001;
+
+use strict;
+use warnings;
+
+use Carp;
+use FileHandle;
+
+our $VERSION = "3.11";
+
+our $TESTING;
+
+my %netrc = ();
+
+sub _readrc {
+ my($class, $host) = @_;
+ 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};
+ if (-e $home . "/.netrc") {
+ $file = $home . "/.netrc";
+ }
+ elsif (-e $home . "/_netrc") {
+ $file = $home . "/_netrc";
+ }
+ else {
+ return unless $TESTING;
+ }
+ }
+
+ my ($login, $pass, $acct) = (undef, undef, undef);
+ my $fh;
+ local $_;
+
+ $netrc{default} = undef;
+
+ # OS/2 and Win32 do not handle stat in a way compatible 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) { ## no critic (ValuesAndExpressions::ProhibitLeadingZeros)
+ 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 {}, $class;
+ $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}, $class;
+
+ $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 ($class, $mach, $login) = @_;
+
+ $class->_readrc()
+ unless exists $netrc{default};
+
+ $mach ||= 'default';
+ undef $login
+ if $mach eq 'default';
+
+ if (exists $netrc{$mach}) {
+ if (defined $login) {
+ foreach my $m (@{$netrc{$mach}}) {
+ return $m
+ if (exists $m->{login} && $m->{login} eq $login);
+ }
+ return;
+ }
+ return $netrc{$mach}->[0];
+ }
+
+ return $netrc{default}->[0]
+ if defined $netrc{default};
+
+ return;
+}
+
+
+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 for the netrc entry
+
+=back
+
+=head1 AUTHOR
+
+Graham Barr E<lt>F<gbarr@pobox.com>E<gt>.
+
+Steve Hay E<lt>F<shay@cpan.org>E<gt> is now maintaining libnet as of version
+1.22_02.
+
+=head1 SEE ALSO
+
+L<Net::Netrc>,
+L<Net::Cmd>
+
+=head1 COPYRIGHT
+
+Copyright (C) 1995-1998 Graham Barr. All rights reserved.
+
+Copyright (C) 2013-2014 Steve Hay. All rights reserved.
+
+=head1 LICENCE
+
+This module is free software; you can redistribute it and/or modify it under the
+same terms as Perl itself, i.e. under the terms of either the GNU General Public
+License or the Artistic License, as specified in the F<LICENCE> file.
+
+=cut
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/POP3.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/POP3.pm
new file mode 100644
index 0000000000..0811025b0a
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/POP3.pm
@@ -0,0 +1,863 @@
+# Net::POP3.pm
+#
+# Copyright (C) 1995-2004 Graham Barr. All rights reserved.
+# Copyright (C) 2013-2016 Steve Hay. All rights reserved.
+# This module is free software; you can redistribute it and/or modify it under
+# the same terms as Perl itself, i.e. under the terms of either the GNU General
+# Public License or the Artistic License, as specified in the F<LICENCE> file.
+
+package Net::POP3;
+
+use 5.008001;
+
+use strict;
+use warnings;
+
+use Carp;
+use IO::Socket;
+use Net::Cmd;
+use Net::Config;
+
+our $VERSION = "3.11";
+
+# Code for detecting if we can use SSL
+my $ssl_class = eval {
+ require IO::Socket::SSL;
+ # first version with default CA on most platforms
+ no warnings 'numeric';
+ IO::Socket::SSL->VERSION(2.007);
+} && 'IO::Socket::SSL';
+
+my $nossl_warn = !$ssl_class &&
+ 'To use SSL please install IO::Socket::SSL with version>=2.007';
+
+# Code for detecting if we can use IPv6
+my $family_key = 'Domain';
+my $inet6_class = eval {
+ require IO::Socket::IP;
+ no warnings 'numeric';
+ IO::Socket::IP->VERSION(0.25) || die;
+ $family_key = 'Family';
+} && 'IO::Socket::IP' || eval {
+ require IO::Socket::INET6;
+ no warnings 'numeric';
+ IO::Socket::INET6->VERSION(2.62);
+} && 'IO::Socket::INET6';
+
+
+sub can_ssl { $ssl_class };
+sub can_inet6 { $inet6_class };
+
+our @ISA = ('Net::Cmd', $inet6_class || '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;
+
+ if ($arg{SSL}) {
+ # SSL from start
+ die $nossl_warn if !$ssl_class;
+ $arg{Port} ||= 995;
+ }
+
+ $arg{Timeout} = 120 if ! defined $arg{Timeout};
+
+ foreach my $h (@{$hosts}) {
+ $obj = $type->SUPER::new(
+ PeerAddr => ($host = $h),
+ PeerPort => $arg{Port} || 'pop3(110)',
+ Proto => 'tcp',
+ $family_key => $arg{Domain} || $arg{Family},
+ LocalAddr => $arg{LocalAddr},
+ LocalPort => exists($arg{ResvPort}) ? $arg{ResvPort} : $arg{LocalPort},
+ Timeout => $arg{Timeout},
+ )
+ and last;
+ }
+
+ return
+ unless defined $obj;
+
+ ${*$obj}{'net_pop3_arg'} = \%arg;
+ ${*$obj}{'net_pop3_host'} = $host;
+ if ($arg{SSL}) {
+ Net::POP3::_SSL->start_SSL($obj,%arg) or return;
+ }
+
+ $obj->autoflush(1);
+ $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
+
+ unless ($obj->response() == CMD_OK) {
+ $obj->close();
+ return;
+ }
+
+ ${*$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 starttls {
+ my $self = shift;
+ $ssl_class or die $nossl_warn;
+ $self->_STLS or return;
+ Net::POP3::_SSL->start_SSL($self,
+ %{ ${*$self}{'net_pop3_arg'} }, # (ssl) args given in new
+ @_ # more (ssl) args
+ ) or return;
+ return 1;
+}
+
+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;
+ }
+
+ return
+ unless ($banner = (${*$me}{'net_pop3_banner'} =~ /(<.*>)/)[0]);
+
+ if (@_ <= 2) {
+ ($user, $pass) = $me->_lookup_credentials($user);
+ }
+
+ $md->add($banner, $pass);
+
+ return
+ 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
+ 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
+ unless $_[0]->_LAST && $_[0]->message =~ /(\d+)/;
+
+ return $1;
+}
+
+
+sub top {
+ @_ == 2 || @_ == 3 or croak 'usage: $pop3->top( MSGNUM [, NUMLINES ])';
+ my $me = shift;
+
+ return
+ 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
+ unless $me->_LIST(@_);
+
+ if (@_) {
+ $me->message =~ /\d+\D+(\d+)/;
+ return $1 || undef;
+ }
+
+ my $info = $me->read_until_dot
+ or return;
+
+ 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
+ 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;
+ if (@_) {
+ $uidl = ($me->message =~ /\d+\s+([\041-\176]+)/)[0];
+ }
+ else {
+ my $ref = $me->read_until_dot
+ or return;
+ $uidl = {};
+ foreach my $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 _STLS { shift->command("STLS", )->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;
+ 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 don't support sasl mechanisms that encrypt the socket traffic.
+ # todo that we would really need to change the ISA hierarchy
+ # so we don't 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'};
+}
+
+{
+ package Net::POP3::_SSL;
+ our @ISA = ( $ssl_class ? ($ssl_class):(), 'Net::POP3' );
+ sub starttls { die "POP3 connection is already in SSL mode" }
+ sub start_SSL {
+ my ($class,$pop3,%arg) = @_;
+ delete @arg{ grep { !m{^SSL_} } keys %arg };
+ ( $arg{SSL_verifycn_name} ||= $pop3->host )
+ =~s{(?<!:):[\w()]+$}{}; # strip port
+ $arg{SSL_hostname} = $arg{SSL_verifycn_name}
+ if ! defined $arg{SSL_hostname} && $class->can_client_sni;
+ $arg{SSL_verifycn_scheme} ||= 'pop3';
+ my $ok = $class->SUPER::start_SSL($pop3,%arg);
+ $@ = $ssl_class->errstr if !$ok;
+ return $ok;
+ }
+}
+
+
+
+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);
+ $pop = Net::POP3->new('pop3host', SSL => 1, 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.
+With L<IO::Socket::SSL> installed it also provides support for implicit and
+explicit TLS encryption, i.e. POP3S or POP3+STARTTLS.
+
+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.
+
+The Net::POP3 class is a subclass of Net::Cmd and (depending on avaibility) of
+IO::Socket::IP, IO::Socket::INET6 or IO::Socket::INET.
+
+
+=head1 CONSTRUCTOR
+
+=over 4
+
+=item new ( [ HOST ] [, OPTIONS ] )
+
+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<Port> - port to connect to.
+Default - 110 for plain POP3 and 995 for POP3s (direct SSL).
+
+B<SSL> - If the connection should be done from start with SSL, contrary to later
+upgrade with C<starttls>.
+You can use SSL arguments as documented in L<IO::Socket::SSL>, but it will
+usually use the right arguments already.
+
+B<LocalAddr> and B<LocalPort> - These parameters are passed directly
+to IO::Socket to allow binding the socket to a specific local address and port.
+For compatibility with older versions B<ResvPort> can be used instead of
+B<LocalPort>.
+
+B<Domain> - This parameter is passed directly to IO::Socket and makes it
+possible to enforce IPv4 connections even if L<IO::Socket::IP> is used as super
+class. Alternatively B<Family> can be used.
+
+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.
+
+C<Net::POP3> inherits from C<Net::Cmd> so methods defined in C<Net::Cmd> may
+be used to send commands to the remote POP3 server in addition to the methods
+documented here.
+
+=over 4
+
+=item host ()
+
+Returns the value used by the constructor, and passed to IO::Socket::INET,
+to connect to the host.
+
+=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 starttls ( SSLARGS )
+
+Upgrade existing plain connection to SSL.
+You can use SSL arguments as documented in L<IO::Socket::SSL>, but it will
+usually use the right arguments already.
+
+=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.
+
+=item can_inet6 ()
+
+Returns whether we can use IPv6.
+
+=item can_ssl ()
+
+Returns whether we can use SSL.
+
+=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>,
+L<IO::Socket::SSL>
+
+=head1 AUTHOR
+
+Graham Barr E<lt>F<gbarr@pobox.com>E<gt>.
+
+Steve Hay E<lt>F<shay@cpan.org>E<gt> is now maintaining libnet as of version
+1.22_02.
+
+=head1 COPYRIGHT
+
+Copyright (C) 1995-2004 Graham Barr. All rights reserved.
+
+Copyright (C) 2013-2016 Steve Hay. All rights reserved.
+
+=head1 LICENCE
+
+This module is free software; you can redistribute it and/or modify it under the
+same terms as Perl itself, i.e. under the terms of either the GNU General Public
+License or the Artistic License, as specified in the F<LICENCE> file.
+
+=cut
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/Ping.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/Ping.pm
new file mode 100644
index 0000000000..5aa32429cc
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/Ping.pm
@@ -0,0 +1,2475 @@
+package Net::Ping;
+
+require 5.002;
+require Exporter;
+
+use strict;
+our $hires;
+use Fcntl qw( F_GETFL F_SETFL O_NONBLOCK );
+use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW AF_INET PF_INET IPPROTO_TCP
+ SOL_SOCKET SO_ERROR SO_BROADCAST
+ IPPROTO_IP IP_TOS IP_TTL
+ inet_ntoa inet_aton getnameinfo sockaddr_in );
+use POSIX qw( ENOTCONN ECONNREFUSED ECONNRESET EINPROGRESS EWOULDBLOCK EAGAIN
+ WNOHANG );
+use FileHandle;
+use Carp;
+use Time::HiRes;
+
+our @ISA = qw(Exporter);
+our @EXPORT = qw(pingecho);
+our @EXPORT_OK = qw(wakeonlan);
+our $VERSION = "2.62";
+
+# Globals
+
+our $def_timeout = 5; # Default timeout to wait for a reply
+our $def_proto = "tcp"; # Default protocol to use for pinging
+our $def_factor = 1.2; # Default exponential backoff rate.
+our $def_family = AF_INET; # Default family.
+our $max_datasize = 1024; # Maximum data bytes in a packet
+# The data we exchange with the server for the stream protocol
+our $pingstring = "pingschwingping!\n";
+our $source_verify = 1; # Default is to verify source endpoint
+our $syn_forking = 0;
+
+# Constants
+
+my $AF_INET6 = eval { Socket::AF_INET6() } || 30;
+my $AF_UNSPEC = eval { Socket::AF_UNSPEC() };
+my $AI_NUMERICHOST = eval { Socket::AI_NUMERICHOST() } || 4;
+my $NI_NUMERICHOST = eval { Socket::NI_NUMERICHOST() } || 2;
+my $IPPROTO_IPV6 = eval { Socket::IPPROTO_IPV6() } || 41;
+#my $IPV6_HOPLIMIT = eval { Socket::IPV6_HOPLIMIT() }; # ping6 -h 0-255
+my $qr_family = qr/^(?:(?:(:?ip)?v?(?:4|6))|${\AF_INET}|$AF_INET6)$/;
+my $qr_family4 = qr/^(?:(?:(:?ip)?v?4)|${\AF_INET})$/;
+
+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 ?
+};
+
+# 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
+ $ttl, # Optional TTL to set
+ $family, # Optional address family (AF_INET)
+ ) = @_;
+ my $class = ref($this) || $this;
+ my $self = {};
+ my ($cnt, # Count through data bytes
+ $min_datasize # Minimum data bytes required
+ );
+
+ bless($self, $class);
+ if (ref $proto eq 'HASH') { # support named args
+ for my $k (qw(proto timeout data_size device tos ttl family
+ gateway host port bind retrans pingstring source_verify
+ econnrefused dontfrag
+ IPV6_USE_MIN_MTU IPV6_RECVPATHMTU IPV6_HOPLIMIT))
+ {
+ if (exists $proto->{$k}) {
+ $self->{$k} = $proto->{$k};
+ # some are still globals
+ if ($k eq 'pingstring') { $pingstring = $proto->{$k} }
+ if ($k eq 'source_verify') { $source_verify = $proto->{$k} }
+ delete $proto->{$k};
+ }
+ }
+ if (%$proto) {
+ croak("Invalid named argument: ",join(" ",keys (%$proto)));
+ }
+ $proto = $self->{'proto'};
+ }
+
+ $proto = $def_proto unless $proto; # Determine the protocol
+ croak('Protocol for ping must be "icmp", "icmpv6", "udp", "tcp", "syn", "stream" or "external"')
+ unless $proto =~ m/^(icmp|icmpv6|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;
+
+ if ($self->{'host'}) {
+ my $host = $self->{'host'};
+ my $ip = _resolv($host)
+ or croak("could not resolve host $host");
+ $self->{host} = $ip;
+ $self->{family} = $ip->{family};
+ }
+
+ if ($self->{bind}) {
+ my $addr = $self->{bind};
+ my $ip = _resolv($addr)
+ or croak("could not resolve local addr $addr");
+ $self->{local_addr} = $ip;
+ } else {
+ $self->{local_addr} = undef; # Don't bind by default
+ }
+
+ if ($self->{proto} eq 'icmp') {
+ croak('TTL must be from 0 to 255')
+ if ($ttl && ($ttl < 0 || $ttl > 255));
+ $self->{ttl} = $ttl;
+ }
+
+ if ($family) {
+ if ($family =~ $qr_family) {
+ if ($family =~ $qr_family4) {
+ $self->{family} = AF_INET;
+ } else {
+ $self->{family} = $AF_INET6;
+ }
+ } else {
+ croak('Family must be "ipv4" or "ipv6"')
+ }
+ } else {
+ $self->{family} = $def_family;
+ }
+
+ $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);
+ }
+
+ # Default exponential backoff rate
+ $self->{retrans} = $def_factor unless exists $self->{retrans};
+ # Default Connection refused behavior
+ $self->{econnrefused} = undef unless exists $self->{econnrefused};
+
+ $self->{seq} = 0; # For counting packets
+ if ($self->{proto} eq "udp") # Open a socket
+ {
+ $self->{proto_num} = eval { (getprotobyname('udp'))[2] } ||
+ croak("Can't udp protocol by name");
+ $self->{port_num} = $self->{port}
+ || (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 - $!");
+ $self->_setopts();
+ }
+ elsif ($self->{proto} eq "icmp")
+ {
+ croak("icmp ping requires root privilege") if !_isroot();
+ $self->{proto_num} = eval { (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 - $!");
+ $self->_setopts();
+ if ($self->{'ttl'}) {
+ setsockopt($self->{fh}, IPPROTO_IP, IP_TTL, pack("I*", $self->{'ttl'}))
+ or croak "error configuring ttl to $self->{'ttl'} $!";
+ }
+ }
+ elsif ($self->{proto} eq "icmpv6")
+ {
+ croak("icmpv6 ping requires root privilege") if !_isroot();
+ croak("Wrong family $self->{family} for icmpv6 protocol")
+ if $self->{family} and $self->{family} != $AF_INET6;
+ $self->{family} = $AF_INET6;
+ $self->{proto_num} = eval { (getprotobyname('ipv6-icmp'))[2] } ||
+ croak("Can't get ipv6-icmp protocol by name"); # 58
+ $self->{pid} = $$ & 0xffff; # Save lower 16 bits of pid
+ $self->{fh} = FileHandle->new();
+ socket($self->{fh}, $AF_INET6, SOCK_RAW, $self->{proto_num}) ||
+ croak("icmp socket error - $!");
+ $self->_setopts();
+ if ($self->{'gateway'}) {
+ my $g = $self->{gateway};
+ my $ip = _resolv($g)
+ or croak("nonexistent gateway $g");
+ $self->{family} eq $AF_INET6
+ or croak("gateway requires the AF_INET6 family");
+ $ip->{family} eq $AF_INET6
+ or croak("gateway address needs to be IPv6");
+ my $IPV6_NEXTHOP = eval { Socket::IPV6_NEXTHOP() } || 48; # IPV6_3542NEXTHOP, or 21
+ setsockopt($self->{fh}, $IPPROTO_IPV6, $IPV6_NEXTHOP, _pack_sockaddr_in($ip))
+ or croak "error configuring gateway to $g NEXTHOP $!";
+ }
+ if (exists $self->{IPV6_USE_MIN_MTU}) {
+ my $IPV6_USE_MIN_MTU = eval { Socket::IPV6_USE_MIN_MTU() } || 42;
+ setsockopt($self->{fh}, $IPPROTO_IPV6, $IPV6_USE_MIN_MTU,
+ pack("I*", $self->{'IPV6_USE_MIN_MT'}))
+ or croak "error configuring IPV6_USE_MIN_MT} $!";
+ }
+ if (exists $self->{IPV6_RECVPATHMTU}) {
+ my $IPV6_RECVPATHMTU = eval { Socket::IPV6_RECVPATHMTU() } || 43;
+ setsockopt($self->{fh}, $IPPROTO_IPV6, $IPV6_RECVPATHMTU,
+ pack("I*", $self->{'RECVPATHMTU'}))
+ or croak "error configuring IPV6_RECVPATHMTU $!";
+ }
+ if ($self->{'tos'}) {
+ my $proto = $self->{family} == AF_INET ? IPPROTO_IP : $IPPROTO_IPV6;
+ setsockopt($self->{fh}, $proto, IP_TOS, pack("I*", $self->{'tos'}))
+ or croak "error configuring tos to $self->{'tos'} $!";
+ }
+ if ($self->{'ttl'}) {
+ my $proto = $self->{family} == AF_INET ? IPPROTO_IP : $IPPROTO_IPV6;
+ setsockopt($self->{fh}, $proto, IP_TTL, pack("I*", $self->{'ttl'}))
+ or croak "error configuring ttl to $self->{'ttl'} $!";
+ }
+ }
+ elsif ($self->{proto} eq "tcp" || $self->{proto} eq "stream")
+ {
+ $self->{proto_num} = eval { (getprotobyname('tcp'))[2] } ||
+ croak("Can't get tcp protocol by name");
+ $self->{port_num} = $self->{port}
+ || (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} = eval { (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;
+ }
+
+ return($self);
+}
+
+# Description: Set the local IP address from which pings will be sent.
+# For ICMP, UDP and 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, # Hash of addr (string), addr_in (packed), family
+ $h # resolved hash
+ );
+
+ 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 = $self->_resolv($local_addr);
+ croak("nonexistent local address $local_addr") unless defined($ip);
+ $self->{local_addr} = $ip;
+
+ if (($self->{proto} ne "udp") &&
+ ($self->{proto} ne "icmp") &&
+ ($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;
+}
+
+sub _IsAdminUser {
+ return unless $^O eq 'MSWin32' or $^O eq "cygwin";
+ return unless eval { require Win32 };
+ return unless defined &Win32::IsAdminUser;
+ return Win32::IsAdminUser();
+}
+
+sub _isroot {
+ if (($> and $^O ne 'VMS' and $^O ne 'cygwin')
+ or (($^O eq 'MSWin32' or $^O eq 'cygwin')
+ and !_IsAdminUser())
+ or ($^O eq 'VMS'
+ and (`write sys\$output f\$privilege("SYSPRV")` =~ m/FALSE/))) {
+ return 0;
+ }
+ else {
+ return 1;
+ }
+}
+
+# Description: Sets ipv6 reachability
+# REACHCONF was removed in RFC3542, ping6 -R supports it. requires root.
+
+sub IPV6_REACHCONF
+{
+ my $self = shift;
+ my $on = shift;
+ if ($on) {
+ my $reachconf = eval { Socket::IPV6_REACHCONF() };
+ if (!$reachconf) {
+ carp "IPV6_REACHCONF not supported on this platform";
+ return 0;
+ }
+ if (!_isroot()) {
+ carp "IPV6_REACHCONF requires root permissions";
+ return 0;
+ }
+ $self->{IPV6_REACHCONF} = 1;
+ }
+ else {
+ return $self->{IPV6_REACHCONF};
+ }
+}
+
+# Description: set it on or off.
+
+sub IPV6_USE_MIN_MTU
+{
+ my $self = shift;
+ my $on = shift;
+ if (defined $on) {
+ my $IPV6_USE_MIN_MTU = eval { Socket::IPV6_USE_MIN_MTU() } || 43;
+ #if (!$IPV6_USE_MIN_MTU) {
+ # carp "IPV6_USE_MIN_MTU not supported on this platform";
+ # return 0;
+ #}
+ $self->{IPV6_USE_MIN_MTU} = $on ? 1 : 0;
+ setsockopt($self->{fh}, $IPPROTO_IPV6, $IPV6_USE_MIN_MTU,
+ pack("I*", $self->{'IPV6_USE_MIN_MT'}))
+ or croak "error configuring IPV6_USE_MIN_MT} $!";
+ }
+ else {
+ return $self->{IPV6_USE_MIN_MTU};
+ }
+}
+
+# Description: notify an according MTU
+
+sub IPV6_RECVPATHMTU
+{
+ my $self = shift;
+ my $on = shift;
+ if ($on) {
+ my $IPV6_RECVPATHMTU = eval { Socket::IPV6_RECVPATHMTU() } || 43;
+ #if (!$RECVPATHMTU) {
+ # carp "IPV6_RECVPATHMTU not supported on this platform";
+ # return 0;
+ #}
+ $self->{IPV6_RECVPATHMTU} = 1;
+ setsockopt($self->{fh}, $IPPROTO_IPV6, $IPV6_RECVPATHMTU,
+ pack("I*", $self->{'IPV6_RECVPATHMTU'}))
+ or croak "error configuring IPV6_RECVPATHMTU} $!";
+ }
+ else {
+ return $self->{IPV6_RECVPATHMTU};
+ }
+}
+
+# Description: allows the module to use milliseconds as returned by
+# the Time::HiRes module
+
+$hires = 1;
+sub hires
+{
+ my $self = shift;
+ $hires = 1 unless defined
+ ($hires = ((defined $self) && (ref $self)) ? shift() : $self);
+}
+
+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
+ $family, # Address family
+ ) = @_;
+ my ($ip, # Hash of addr (string), addr_in (packed), family
+ $ret, # The return value
+ $ping_time, # When ping began
+ );
+
+ $host = $self->{host} if !defined $host and $self->{host};
+ croak("Usage: \$p->ping([ \$host [, \$timeout [, \$family]]])") if @_ > 4 or !$host;
+ $timeout = $self->{timeout} unless $timeout;
+ croak("Timeout must be greater than 0 seconds") if $timeout <= 0;
+
+ if ($family) {
+ if ($family =~ $qr_family) {
+ if ($family =~ $qr_family4) {
+ $self->{family_local} = AF_INET;
+ } else {
+ $self->{family_local} = $AF_INET6;
+ }
+ } else {
+ croak('Family must be "ipv4" or "ipv6"')
+ }
+ } else {
+ $self->{family_local} = $self->{family};
+ }
+
+ $ip = $self->_resolv($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 "icmpv6") {
+ $ret = $self->ping_icmpv6($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, $self->ntop($ip)) : $ret;
+}
+
+# Uses Net::Ping::External to do an external ping.
+sub ping_external {
+ my ($self,
+ $ip, # Hash of addr (string), addr_in (packed), family
+ $timeout, # Seconds after which ping times out
+ $family
+ ) = @_;
+
+ $ip = $self->{host} if !defined $ip and $self->{host};
+ $timeout = $self->{timeout} if !defined $timeout and $self->{timeout};
+ my @addr = exists $ip->{addr_in}
+ ? ('ip' => $ip->{addr_in})
+ : ('host' => $ip->{host});
+
+ eval {
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
+ require Net::Ping::External;
+ } or croak('Protocol "external" not supported on your system: Net::Ping::External not found');
+ return Net::Ping::External::ping(@addr, timeout => $timeout,
+ family => $family);
+}
+
+# h2ph "asm/socket.h"
+# require "asm/socket.ph";
+use constant SO_BINDTODEVICE => 25;
+use constant ICMP_ECHOREPLY => 0; # ICMP packet types
+use constant ICMPv6_ECHOREPLY => 129; # ICMP packet types
+use constant ICMP_UNREACHABLE => 3; # ICMP packet types
+use constant ICMPv6_UNREACHABLE => 1; # ICMP packet types
+use constant ICMP_ECHO => 8;
+use constant ICMPv6_ECHO => 128;
+use constant ICMP_TIME_EXCEEDED => 11; # ICMP packet types
+use constant ICMP_PARAMETER_PROBLEM => 12; # ICMP packet types
+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
+use constant IP_MTU_DISCOVER => 10; # linux only
+
+sub ping_icmp
+{
+ my ($self,
+ $ip, # Hash of addr (string), addr_in (packed), family
+ $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
+ );
+
+ $ip = $self->{host} if !defined $ip and $self->{host};
+ $timeout = $self->{timeout} if !defined $timeout and $self->{timeout};
+
+ socket($self->{fh}, $ip->{family}, SOCK_RAW, $self->{proto_num}) ||
+ croak("icmp socket error - $!");
+
+ if (defined $self->{local_addr} &&
+ !CORE::bind($self->{fh}, _pack_sockaddr_in(0, $self->{local_addr}))) {
+ croak("icmp bind error - $!");
+ }
+ $self->_setopts();
+
+ $self->{seq} = ($self->{seq} + 1) % 65536; # Increment sequence
+ $checksum = 0; # No checksum for starters
+ if ($ip->{family} == AF_INET) {
+ $msg = pack(ICMP_STRUCT . $self->{data_size}, ICMP_ECHO, SUBCODE,
+ $checksum, $self->{pid}, $self->{seq}, $self->{data});
+ } else {
+ # how to get SRC
+ my $pseudo_header = pack('a16a16Nnn', $ip->{addr_in}, $ip->{addr_in}, 8+length($self->{data}), "\0", 0x003a);
+ $msg = pack(ICMP_STRUCT . $self->{data_size}, ICMPv6_ECHO, SUBCODE,
+ $checksum, $self->{pid}, $self->{seq}, $self->{data});
+ $msg = $pseudo_header.$msg
+ }
+ $checksum = Net::Ping->checksum($msg);
+ if ($ip->{family} == AF_INET) {
+ $msg = pack(ICMP_STRUCT . $self->{data_size}, ICMP_ECHO, SUBCODE,
+ $checksum, $self->{pid}, $self->{seq}, $self->{data});
+ } else {
+ $msg = pack(ICMP_STRUCT . $self->{data_size}, ICMPv6_ECHO, SUBCODE,
+ $checksum, $self->{pid}, $self->{seq}, $self->{data});
+ }
+ $len_msg = length($msg);
+ $saddr = _pack_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) = _unpack_sockaddr_in($from_saddr, $ip->{family});
+ ($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;
+ } elsif ($from_type == ICMPv6_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;
+ next if ($from_pid != $self->{pid});
+ next if ($from_seq != $self->{seq});
+ if (! $source_verify || ($self->ntop($from_ip) eq $self->ntop($ip))) { # Does the packet check out?
+ if (($from_type == ICMP_ECHOREPLY) || ($from_type == ICMPv6_ECHOREPLY)) {
+ $ret = 1;
+ $done = 1;
+ } elsif (($from_type == ICMP_UNREACHABLE) || ($from_type == ICMPv6_UNREACHABLE)) {
+ $done = 1;
+ } elsif ($from_type == ICMP_TIME_EXCEEDED) {
+ $ret = 0;
+ $done = 1;
+ }
+ }
+ } else { # Oops, timed out
+ $done = 1;
+ }
+ }
+ return $ret;
+}
+
+sub ping_icmpv6
+{
+ shift->ping_icmp(@_);
+}
+
+sub icmp_result {
+ my ($self) = @_;
+ my $addr = $self->{from_ip} || "";
+ $addr = "\0\0\0\0" unless 4 == length $addr;
+ return ($self->ntop($addr),($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, # Hash of addr (string), addr_in (packed), family
+ $timeout # Seconds after which ping times out
+ ) = @_;
+ my ($ret # The return value
+ );
+
+ $ip = $self->{host} if !defined $ip and $self->{host};
+ $timeout = $self->{timeout} if !defined $timeout and $self->{timeout};
+
+ $! = 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, # Hash of addr (string), addr_in (packed), family
+ $timeout # Seconds after which connect times out
+ ) = @_;
+ my ($saddr); # Packed IP and Port
+
+ $ip = $self->{host} if !defined $ip and $self->{host};
+ $timeout = $self->{timeout} if !defined $timeout and $self->{timeout};
+
+ $saddr = _pack_sockaddr_in($self->{port_num}, $ip);
+
+ my $ret = 0; # Default to unreachable
+
+ my $do_socket = sub {
+ socket($self->{fh}, $ip->{family}, SOCK_STREAM, $self->{proto_num}) ||
+ croak("tcp socket error - $!");
+ if (defined $self->{local_addr} &&
+ !CORE::bind($self->{fh}, _pack_sockaddr_in(0, $self->{local_addr}))) {
+ croak("tcp bind error - $!");
+ }
+ $self->_setopts();
+ };
+ my $do_connect = sub {
+ $self->{ip} = $ip->{addr_in};
+ # 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->{addr_in};
+ 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, $timeout, $pingstring) = @_;
+
+ $timeout = $self->{timeout} if !defined $timeout and $self->{timeout};
+ $pingstring = $self->{pingstring} if !defined $pingstring and $self->{pingstring};
+
+ 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, # Hash of addr (string), addr_in (packed), family
+ $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->{addr_in};
+
+ 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
+ $family
+ ) = @_;
+ my $ip; # Hash of addr (string), addr_in (packed), family
+ $host = $self->{host} unless defined $host;
+
+ if ($family) {
+ if ($family =~ $qr_family) {
+ if ($family =~ $qr_family4) {
+ $self->{family_local} = AF_INET;
+ } else {
+ $self->{family_local} = $AF_INET6;
+ }
+ } else {
+ croak('Family must be "ipv4" or "ipv6"')
+ }
+ } else {
+ $self->{family_local} = $self->{family};
+ }
+
+ $ip = $self->_resolv($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);
+ }
+ }
+}
+
+sub _dontfrag {
+ my $self = shift;
+ # bsd solaris
+ my $IP_DONTFRAG = eval { Socket::IP_DONTFRAG() };
+ if ($IP_DONTFRAG) {
+ my $i = 1;
+ setsockopt($self->{fh}, IPPROTO_IP, $IP_DONTFRAG, pack("I*", $i))
+ or croak "error configuring IP_DONTFRAG $!";
+ # Linux needs more: Path MTU Discovery as defined in RFC 1191
+ # For non SOCK_STREAM sockets it is the user's responsibility to packetize
+ # the data in MTU sized chunks and to do the retransmits if necessary.
+ # The kernel will reject packets that are bigger than the known path
+ # MTU if this flag is set (with EMSGSIZE).
+ if ($^O eq 'linux') {
+ my $i = 2; # IP_PMTUDISC_DO
+ setsockopt($self->{fh}, IPPROTO_IP, IP_MTU_DISCOVER, pack("I*", $i))
+ or croak "error configuring IP_MTU_DISCOVER $!";
+ }
+ }
+}
+
+# SO_BINDTODEVICE + IP_TOS
+sub _setopts {
+ my $self = shift;
+ 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'}) { # need to re-apply ToS (RT #6706)
+ setsockopt($self->{fh}, IPPROTO_IP, IP_TOS, pack("I*", $self->{'tos'}))
+ or croak "error applying tos to $self->{'tos'} $!";
+ }
+ if ($self->{'dontfrag'}) {
+ $self->_dontfrag;
+ }
+}
+
+
+# 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, # Hash of addr (string), addr_in (packed), family
+ $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 = _pack_sockaddr_in($self->{port_num}, $ip);
+ $self->{seq} = ($self->{seq} + 1) % 256; # Increment sequence
+ $msg = chr($self->{seq}) . $self->{data}; # Add data if any
+
+ socket($self->{fh}, $ip->{family}, SOCK_DGRAM,
+ $self->{proto_num}) ||
+ croak("udp socket error - $!");
+
+ if (defined $self->{local_addr} &&
+ !CORE::bind($self->{fh}, _pack_sockaddr_in(0, $self->{local_addr}))) {
+ croak("udp bind error - $!");
+ }
+
+ $self->_setopts();
+
+ 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}, $ip->{family}, SOCK_DGRAM,
+ $self->{proto_num});
+ $self->_setopts();
+ }
+ # 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) = _unpack_sockaddr_in($from_saddr, $ip->{family});
+ my $addr_in = ref($ip) eq "HASH" ? $ip->{addr_in} : $ip;
+ if (!$source_verify ||
+ (($from_ip eq $addr_in) && # 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 = _pack_sockaddr_in($self->{port_num}, $ip);
+
+ # Create TCP socket
+ if (!socket ($fh, $ip->{family}, SOCK_STREAM, $self->{proto_num})) {
+ croak("tcp socket error - $!");
+ }
+
+ if (defined $self->{local_addr} &&
+ !CORE::bind($fh, _pack_sockaddr_in(0, $self->{local_addr}))) {
+ croak("tcp bind error - $!");
+ }
+
+ $self->_setopts();
+ # 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->{port_num} ];
+ $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 = _pack_sockaddr_in($self->{port_num}, $ip);
+
+ # Create TCP socket
+ if (!socket ($self->{fh}, $ip->{family}, SOCK_STREAM, $self->{proto_num})) {
+ croak("tcp socket error - $!");
+ }
+
+ if (defined $self->{local_addr} &&
+ !CORE::bind($self->{fh}, _pack_sockaddr_in(0, $self->{local_addr}))) {
+ croak("tcp bind error - $!");
+ }
+
+ $self->_setopts();
+
+ $!=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 or $self->{host}) {
+ # Host passed as arg or as option to new
+ $host = $self->{host} unless defined $host;
+ 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], $self->ntop($entry->[1]), $entry->[5])
+ : $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], $self->ntop($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], $self->ntop($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
+ } elsif ($self->{proto} eq "external") {
+ # Nothing to close
+ } else {
+ $self->{fh}->close();
+ }
+}
+
+sub port_number {
+ my $self = shift;
+ if(@_) {
+ $self->{port_num} = shift @_;
+ $self->service_check(1);
+ }
+ return $self->{port_num};
+}
+
+sub ntop {
+ my($self, $ip) = @_;
+
+ # Vista doesn't define a inet_ntop. It has InetNtop instead.
+ # Not following ANSI... priceless. getnameinfo() is defined
+ # for Windows 2000 and later, so that may be the choice.
+
+ # Any port will work, even undef, but this will work for now.
+ # Socket warns when undef is passed in, but it still works.
+ my $port = getservbyname('echo', 'udp');
+ my $sockaddr = _pack_sockaddr_in($port, $ip);
+ my ($error, $address) = getnameinfo($sockaddr, $NI_NUMERICHOST);
+ croak $error if $error;
+ return $address;
+}
+
+sub wakeonlan {
+ my ($mac_addr, $host, $port) = @_;
+
+ # use the discard service if $port not passed in
+ if (! defined $host) { $host = '255.255.255.255' }
+ if (! defined $port || $port !~ /^\d+$/ ) { $port = 9 }
+
+ require IO::Socket::INET;
+ my $sock = IO::Socket::INET->new(Proto=>'udp') || return undef;
+
+ my $ip_addr = inet_aton($host);
+ my $sock_addr = sockaddr_in($port, $ip_addr);
+ $mac_addr =~ s/://g;
+ my $packet = pack('C6H*', 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, $mac_addr x 16);
+
+ setsockopt($sock, SOL_SOCKET, SO_BROADCAST, 1);
+ send($sock, $packet, 0, $sock_addr);
+ $sock->close;
+
+ return 1;
+}
+
+########################################################
+# DNS hostname resolution
+# return:
+# $h->{name} = host - as passed in
+# $h->{host} = host - as passed in without :port
+# $h->{port} = OPTIONAL - if :port, then value of port
+# $h->{addr} = resolved numeric address
+# $h->{addr_in} = aton/pton result
+# $h->{family} = AF_INET/6
+############################
+sub _resolv {
+ my ($self,
+ $name,
+ ) = @_;
+
+ my %h;
+ $h{name} = $name;
+ my $family = $self->{family};
+
+ if (defined($self->{family_local})) {
+ $family = $self->{family_local}
+ }
+
+# START - host:port
+ my $cnt = 0;
+
+ # Count ":"
+ $cnt++ while ($name =~ m/:/g);
+
+ # 0 = hostname or IPv4 address
+ if ($cnt == 0) {
+ $h{host} = $name
+ # 1 = IPv4 address with port
+ } elsif ($cnt == 1) {
+ ($h{host}, $h{port}) = split /:/, $name
+ # >=2 = IPv6 address
+ } elsif ($cnt >= 2) {
+ #IPv6 with port - [2001::1]:port
+ if ($name =~ /^\[.*\]:\d{1,5}$/) {
+ ($h{host}, $h{port}) = split /:([^:]+)$/, $name # split after last :
+ # IPv6 without port
+ } else {
+ $h{host} = $name
+ }
+ }
+
+ # Clean up host
+ $h{host} =~ s/\[//g;
+ $h{host} =~ s/\]//g;
+ # Clean up port
+ if (defined($h{port}) && (($h{port} !~ /^\d{1,5}$/) || ($h{port} < 1) || ($h{port} > 65535))) {
+ croak("Invalid port `$h{port}' in `$name'");
+ }
+# END - host:port
+
+ # address check
+ # new way
+ if ($Socket::VERSION >= 1.94) {
+ my %hints = (
+ family => $AF_UNSPEC,
+ protocol => IPPROTO_TCP,
+ flags => $AI_NUMERICHOST
+ );
+
+ # numeric address, return
+ my ($err, @getaddr) = Socket::getaddrinfo($h{host}, undef, \%hints);
+ if (defined($getaddr[0])) {
+ $h{addr} = $h{host};
+ $h{family} = $getaddr[0]->{family};
+ if ($h{family} == AF_INET) {
+ (undef, $h{addr_in}, undef, undef) = Socket::unpack_sockaddr_in $getaddr[0]->{addr};
+ } else {
+ (undef, $h{addr_in}, undef, undef) = Socket::unpack_sockaddr_in6 $getaddr[0]->{addr};
+ }
+ return \%h
+ }
+ # old way
+ } else {
+ # numeric address, return
+ my $ret = gethostbyname($h{host});
+ if (defined($ret) && (_inet_ntoa($ret) eq $h{host})) {
+ $h{addr} = $h{host};
+ $h{addr_in} = $ret;
+ $h{family} = AF_INET;
+ return \%h
+ }
+ }
+
+ # resolve
+ # new way
+ if ($Socket::VERSION >= 1.94) {
+ my %hints = (
+ family => $family,
+ protocol => IPPROTO_TCP
+ );
+
+ my ($err, @getaddr) = Socket::getaddrinfo($h{host}, undef, \%hints);
+ if (defined($getaddr[0])) {
+ my ($err, $address) = Socket::getnameinfo($getaddr[0]->{addr}, $NI_NUMERICHOST);
+ if (defined($address)) {
+ $h{addr} = $address;
+ $h{addr} =~ s/\%(.)*$//; # remove %ifID if IPv6
+ $h{family} = $getaddr[0]->{family};
+ if ($h{family} == AF_INET) {
+ (undef, $h{addr_in}, undef, undef) = Socket::unpack_sockaddr_in $getaddr[0]->{addr};
+ } else {
+ (undef, $h{addr_in}, undef, undef) = Socket::unpack_sockaddr_in6 $getaddr[0]->{addr};
+ }
+ return \%h
+ } else {
+ croak("getnameinfo($getaddr[0]->{addr}) failed - $err");
+ }
+ } else {
+ croak(sprintf("getaddrinfo($h{host},,%s) failed - $err",
+ $family == AF_INET ? "AF_INET" : "AF_INET6"));
+ }
+ # old way
+ } else {
+ if ($family == $AF_INET6) {
+ croak("Socket >= 1.94 required for IPv6 - found Socket $Socket::VERSION");
+ }
+
+ my @gethost = gethostbyname($h{host});
+ if (defined($gethost[4])) {
+ $h{addr} = inet_ntoa($gethost[4]);
+ $h{addr_in} = $gethost[4];
+ $h{family} = AF_INET;
+ return \%h
+ } else {
+ croak("gethostbyname($h{host}) failed - $^E");
+ }
+ }
+}
+
+sub _pack_sockaddr_in($$) {
+ my ($port,
+ $ip,
+ ) = @_;
+
+ my $addr = ref($ip) eq "HASH" ? $ip->{addr_in} : $ip;
+ if (length($addr) <= 4 ) {
+ return Socket::pack_sockaddr_in($port, $addr);
+ } else {
+ return Socket::pack_sockaddr_in6($port, $addr);
+ }
+}
+
+sub _unpack_sockaddr_in($;$) {
+ my ($addr,
+ $family,
+ ) = @_;
+
+ my ($port, $host);
+ if ($family == AF_INET || (!defined($family) and length($addr) <= 16 )) {
+ ($port, $host) = Socket::unpack_sockaddr_in($addr);
+ } else {
+ ($port, $host) = Socket::unpack_sockaddr_in6($addr);
+ }
+ return $port, $host
+}
+
+sub _inet_ntoa {
+ my ($addr
+ ) = @_;
+
+ my $ret;
+ if ($Socket::VERSION >= 1.94) {
+ my ($err, $address) = Socket::getnameinfo($addr, $NI_NUMERICHOST);
+ if (defined($address)) {
+ $ret = $address;
+ } else {
+ croak("getnameinfo($addr) failed - $err");
+ }
+ } else {
+ $ret = inet_ntoa($addr)
+ }
+
+ return $ret
+}
+
+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(scalar(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, timeout, bytes, device, tos, ttl, family,
+ host, port, bind, gateway, retrans, pingstring,
+ source_verify econnrefused dontfrag
+ IPV6_USE_MIN_MTU IPV6_RECVPATHMTU])
+
+Create a new ping object. All of the parameters are optional and can
+be passed as hash ref. All options besides the first 7 must be passed
+as hash ref.
+
+C<proto> specifies the protocol to use when doing a ping. The current
+choices are "tcp", "udp", "icmp", "icmpv6", "stream", "syn", or
+"external". The default is "tcp".
+
+If a C<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 (C<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 C<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.
+
+For icmp, C<ttl> can be specified to set the TTL of the outgoing packet.
+
+Valid C<family> values for IPv4:
+
+ 4, v4, ip4, ipv4, AF_INET (constant)
+
+Valid C<family> values for IPv6:
+
+ 6, v6, ip6, ipv6, AF_INET6 (constant)
+
+The C<host> argument implicitly specifies the family if the family
+argument is not given.
+
+The C<port> argument is only valid for a udp, tcp or stream ping, and will not
+do what you think it does. ping returns true when we get a "Connection refused"!
+The default is the echo port.
+
+The C<bind> argument specifies the local_addr to bind to.
+By specifying a bind argument you don't need the bind method.
+
+The C<gateway> argument is only valid for IPv6, and requires a IPv6
+address.
+
+The C<retrans> argument the exponential backoff rate, default 1.2.
+It matches the $def_factor global.
+
+The C<dontfrag> argument sets the IP_DONTFRAG bit, but note that
+IP_DONTFRAG is not yet defined by Socket, and not available on many
+systems. Then it is ignored. On linux it also sets IP_MTU_DISCOVER to
+IP_PMTUDISC_DO but need we don't chunk oversized packets. You need to
+set $data_size manually.
+
+=item $p->ping($host [, $timeout [, $family]]);
+
+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 returned 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 } );
+
+With 1 causes this module to use Time::HiRes module, allowing milliseconds
+to be returned by subsequent calls to ping().
+
+=item $p->time
+
+The current time, hires or not.
+
+=item $p->socket_blocking_mode( $fh, $mode );
+
+Sets or clears the O_NONBLOCK flag on a file handle.
+
+=item $p->IPV6_USE_MIN_MTU
+
+With argument sets the option.
+Without returns the option value.
+
+=item $p->IPV6_RECVPATHMTU
+
+Notify an according IPv6 MTU.
+
+With argument sets the option.
+Without returns the option value.
+
+=item $p->IPV6_HOPLIMIT
+
+With argument sets the option.
+Without returns the option value.
+
+=item $p->IPV6_REACHCONF I<NYI>
+
+Sets ipv6 reachability
+IPV6_REACHCONF was removed in RFC3542. ping6 -R supports it.
+IPV6_REACHCONF requires root/admin permissions.
+
+With argument sets the option.
+Without returns the option value.
+
+Not yet implemented.
+
+=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.
+
+The bind() call can be omitted when specifying the C<bind> option to
+new().
+
+=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.
+
+The $host argument can be omitted when specifying the C<host> option to
+new().
+
+=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, the dotted ip
+string, and the port number 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.
+
+When new() had a host option, this host will be used.
+Without host argument, all hosts are scanned.
+
+=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->ack_unfork($host)
+
+The variant called by ack() with the syn protocol and $syn_forking
+enabled.
+
+=item $p->ping_icmp([$host, $timeout, $family])
+
+The ping() method used with the icmp protocol.
+
+=item $p->ping_icmpv6([$host, $timeout, $family]) I<NYI>
+
+The ping() method used with the icmpv6 protocol.
+
+=item $p->ping_stream([$host, $timeout, $family])
+
+The ping() method used with the stream protocol.
+
+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.
+
+=item $p->ping_syn([$host, $ip, $start_time, $stop_time])
+
+The ping() method used with the syn protocol.
+Sends a TCP SYN packet to host specified.
+
+=item $p->ping_syn_fork([$host, $timeout, $family])
+
+The ping() method used with the forking syn protocol.
+
+=item $p->ping_tcp([$host, $timeout, $family])
+
+The ping() method used with the tcp protocol.
+
+=item $p->ping_udp([$host, $timeout, $family])
+
+The ping() method used with the udp protocol.
+
+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.
+
+=item $p->ping_external([$host, $timeout, $family])
+
+The ping() method used with the external protocol.
+Uses Net::Ping::External to do an external ping.
+
+=item $p->tcp_connect([$ip, $timeout])
+
+Initiates a TCP connection, for a tcp ping.
+
+=item $p->tcp_echo([$ip, $timeout, $pingstring])
+
+Performs a TCP echo.
+It writes the given string to the socket and then reads it
+back. It returns 1 on success, 0 on failure.
+
+=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 $p->mselect
+
+A select() wrapper that compensates for platform
+peculiarities.
+
+=item $p->ntop
+
+Platform abstraction over inet_ntop()
+
+=item $p->checksum($msg)
+
+Do a checksum on the message. Basically sum all of
+the short words and fold the high order bits into the low order bits.
+
+=item $p->icmp_result
+
+Returns a list of addr, type, subcode.
+
+=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.
+
+=item wakeonlan($mac, [$host, [$port]])
+
+Emit the popular wake-on-lan magic udp packet to wake up a local
+device. See also L<Net::Wake>, but this has the mac address as 1st arg.
+$host should be the local gateway. Without it will broadcast.
+
+Default host: '255.255.255.255'
+Default port: 9
+
+ perl -MNet::Ping=wakeonlan -e'wakeonlan "e0:69:95:35:68:d2"'
+
+=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 and icmpv6 protocols 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 git:
+
+ git clone https://github.com/rurban/net-ping.git Net-Ping
+ cd Net-Ping
+
+The tarball can be created as follows:
+
+ perl Makefile.PL ; make ; make dist
+
+The latest Net::Ping releases are included in cperl and perl5.
+
+=head1 BUGS
+
+For a list of known issues, visit:
+
+L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=Net-Ping>
+
+To report a new bug, visit:
+
+L<https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net-Ping> (stale)
+
+or call:
+
+ perlbug
+
+resp.:
+
+ cperlbug
+
+=head1 AUTHORS
+
+ Current maintainers:
+ perl11 (for cperl, with IPv6 support and more)
+ p5p (for perl5)
+
+ Previous maintainers:
+ bbb@cpan.org (Rob Brown)
+ Steve Peters
+
+ External protocol:
+ colinm@cpan.org (Colin McMillen)
+
+ Stream protocol:
+ bronson@trestle.com (Scott Bronson)
+
+ Wake-on-lan:
+ 1999-2003 Clinton Wong
+
+ 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) 2016, cPanel Inc. All rights reserved.
+
+Copyright (c) 2012, Steve Peters. All rights reserved.
+
+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.
+
+=cut
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/SMTP.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/SMTP.pm
new file mode 100644
index 0000000000..5eaf4220b6
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/SMTP.pm
@@ -0,0 +1,1046 @@
+# Net::SMTP.pm
+#
+# Copyright (C) 1995-2004 Graham Barr. All rights reserved.
+# Copyright (C) 2013-2016 Steve Hay. All rights reserved.
+# This module is free software; you can redistribute it and/or modify it under
+# the same terms as Perl itself, i.e. under the terms of either the GNU General
+# Public License or the Artistic License, as specified in the F<LICENCE> file.
+
+package Net::SMTP;
+
+use 5.008001;
+
+use strict;
+use warnings;
+
+use Carp;
+use IO::Socket;
+use Net::Cmd;
+use Net::Config;
+use Socket;
+
+our $VERSION = "3.11";
+
+# Code for detecting if we can use SSL
+my $ssl_class = eval {
+ require IO::Socket::SSL;
+ # first version with default CA on most platforms
+ no warnings 'numeric';
+ IO::Socket::SSL->VERSION(2.007);
+} && 'IO::Socket::SSL';
+
+my $nossl_warn = !$ssl_class &&
+ 'To use SSL please install IO::Socket::SSL with version>=2.007';
+
+# Code for detecting if we can use IPv6
+my $family_key = 'Domain';
+my $inet6_class = eval {
+ require IO::Socket::IP;
+ no warnings 'numeric';
+ IO::Socket::IP->VERSION(0.25) || die;
+ $family_key = 'Family';
+} && 'IO::Socket::IP' || eval {
+ require IO::Socket::INET6;
+ no warnings 'numeric';
+ IO::Socket::INET6->VERSION(2.62);
+} && 'IO::Socket::INET6';
+
+sub can_ssl { $ssl_class };
+sub can_inet6 { $inet6_class };
+
+our @ISA = ('Net::Cmd', $inet6_class || '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};
+ }
+
+ if ($arg{SSL}) {
+ # SSL from start
+ die $nossl_warn if !$ssl_class;
+ $arg{Port} ||= 465;
+ }
+
+ my $hosts = defined $host ? $host : $NetConfig{smtp_hosts};
+ my $obj;
+
+ $arg{Timeout} = 120 if ! defined $arg{Timeout};
+
+ foreach my $h (@{ref($hosts) ? $hosts : [$hosts]}) {
+ $obj = $type->SUPER::new(
+ PeerAddr => ($host = $h),
+ PeerPort => $arg{Port} || 'smtp(25)',
+ LocalAddr => $arg{LocalAddr},
+ LocalPort => $arg{LocalPort},
+ $family_key => $arg{Domain} || $arg{Family},
+ Proto => 'tcp',
+ Timeout => $arg{Timeout}
+ )
+ and last;
+ }
+
+ return
+ unless defined $obj;
+
+ ${*$obj}{'net_smtp_arg'} = \%arg;
+ ${*$obj}{'net_smtp_host'} = $host;
+
+ if ($arg{SSL}) {
+ Net::SMTP::_SSL->start_SSL($obj,%arg)
+ or return;
+ }
+
+ $obj->autoflush(1);
+
+ $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
+
+ unless ($obj->response() == CMD_OK) {
+ my $err = ref($obj) . ": " . $obj->code . " " . $obj->message;
+ $obj->close();
+ $@ = $err;
+ return;
+ }
+
+ ${*$obj}{'net_smtp_exact_addr'} = $arg{ExactAddresses};
+
+ (${*$obj}{'net_smtp_banner'}) = $obj->message;
+ (${*$obj}{'net_smtp_domain'}) = $obj->message =~ /\A\s*(\S+)/;
+
+ if (!exists $arg{SendHello} || $arg{SendHello}) {
+ unless ($obj->hello($arg{Hello} || "")) {
+ my $err = ref($obj) . ": " . $obj->code . " " . $obj->message;
+ $obj->close();
+ $@ = $err;
+ return;
+ }
+ }
+
+ $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;
+ my $requested_mechanisms = $sasl->mechanism();
+ if (! defined($requested_mechanisms) || $requested_mechanisms eq '') {
+ $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,
+ },
+ debug => $self->debug
+ );
+ }
+
+ my $client;
+ my $str;
+ do {
+ if ($client) {
+ # $client mechanism failed, so we need to exclude this mechanism from list
+ my $failed_mechanism = $client->mechanism;
+ return unless defined $failed_mechanism;
+ $self->debug_text("Auth mechanism failed: $failed_mechanism")
+ if $self->debug;
+ $mechanisms =~ s/\b\Q$failed_mechanism\E\b//;
+ return unless $mechanisms =~ /\S/;
+ $sasl->mechanism($mechanisms);
+ }
+
+ # 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
+
+ $client = $sasl->client_new('smtp', ${*$self}{'net_smtp_host'}, 0);
+ $str = $client->client_start;
+ } while (!defined $str);
+
+ # We don't support sasl mechanisms that encrypt the socket traffic.
+ # todo that we would really need to change the ISA hierarchy
+ # so we don't 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) {
+ my $str2 = MIME::Base64::decode_base64(($self->message)[0]);
+ $self->debug_print(0, "(decoded) " . $str2 . "\n") if $self->debug;
+
+ $str = $client->client_step($str2);
+ @cmd = (
+ MIME::Base64::encode_base64($str, '')
+ );
+
+ $self->debug_print(1, "(decoded) " . $str . "\n") if $self->debug;
+ }
+
+ $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'} = {};
+ foreach my $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 unless $ok;
+ ${*$me}{net_smtp_hello_domain} = $domain;
+
+ $msg[0] =~ /\A\s*(\S+)/;
+ return ($1 || " ");
+}
+
+sub starttls {
+ my $self = shift;
+ $ssl_class or die $nossl_warn;
+ $self->_STARTTLS or return;
+ Net::SMTP::_SSL->start_SSL($self,
+ %{ ${*$self}{'net_smtp_arg'} }, # (ssl) args given in new
+ @_ # more (ssl) args
+ ) or return;
+
+ # another hello after starttls to read new ESMTP capabilities
+ return $self->hello(${*$self}{net_smtp_hello_domain});
+}
+
+
+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;
+ foreach my $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 }
+sub _STARTTLS { shift->command("STARTTLS")->response() == CMD_OK }
+
+
+{
+ package Net::SMTP::_SSL;
+ our @ISA = ( $ssl_class ? ($ssl_class):(), 'Net::SMTP' );
+ sub starttls { die "SMTP connection is already in SSL mode" }
+ sub start_SSL {
+ my ($class,$smtp,%arg) = @_;
+ delete @arg{ grep { !m{^SSL_} } keys %arg };
+ ( $arg{SSL_verifycn_name} ||= $smtp->host )
+ =~s{(?<!:):[\w()]+$}{}; # strip port
+ $arg{SSL_hostname} = $arg{SSL_verifycn_name}
+ if ! defined $arg{SSL_hostname} && $class->can_client_sni;
+ $arg{SSL_verifycn_scheme} ||= 'smtp';
+ my $ok = $class->SUPER::start_SSL($smtp,%arg);
+ $@ = $ssl_class->errstr if !$ok;
+ return $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 RFC2821.
+With L<IO::Socket::SSL> installed it also provides support for implicit and
+explicit TLS encryption, i.e. SMTPS or SMTP+STARTTLS.
+
+The Net::SMTP class is a subclass of Net::Cmd and (depending on avaibility) of
+IO::Socket::IP, IO::Socket::INET6 or 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;
+
+ my $smtp = Net::SMTP->new('mailhost');
+
+ $smtp->mail($ENV{USER});
+ if ($smtp->to('postmaster')) {
+ $smtp->data();
+ $smtp->datasend("To: postmaster\n");
+ $smtp->datasend("\n");
+ $smtp->datasend("A simple test message\n");
+ $smtp->dataend();
+ } else {
+ print "Error: ", $smtp->message();
+ }
+
+ $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.
+
+On failure C<undef> will be returned and C<$@> will contain the reason
+for the failure.
+
+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<SendHello> - If false then the EHLO (or HELO) command that is normally sent
+when constructing the object will not be sent. In that case the command will
+have to be sent manually by calling C<hello()> instead.
+
+B<Host> - SMTP host to connect to. It may be a single scalar (hostname[:port]),
+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.
+Format - C<PeerHost> from L<IO::Socket::INET> new method.
+
+B<Port> - port to connect to.
+Default - 25 for plain SMTP and 465 for immediate SSL.
+
+B<SSL> - If the connection should be done from start with SSL, contrary to later
+upgrade with C<starttls>.
+You can use SSL arguments as documented in L<IO::Socket::SSL>, but it will
+usually use the right arguments already.
+
+B<LocalAddr> and B<LocalPort> - These parameters are passed directly
+to IO::Socket to allow binding the socket to a specific local address and port.
+
+B<Domain> - This parameter is passed directly to IO::Socket and makes it
+possible to enforce IPv4 connections even if L<IO::Socket::IP> is used as super
+class. Alternatively B<Family> can be used.
+
+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,
+ );
+
+ # the same with direct SSL
+ $smtp = Net::SMTP->new('mailhost',
+ Hello => 'my.mail.domain',
+ Timeout => 30,
+ Debug => 1,
+ SSL => 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.
+
+C<Net::SMTP> inherits from C<Net::Cmd> so methods defined in C<Net::Cmd> may
+be used to send commands to the remote SMTP server in addition to the methods
+documented here.
+
+=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 starttls ( SSLARGS )
+
+Upgrade existing plain connection to SSL.
+You can use SSL arguments as documented in L<IO::Socket::SSL>, but it will
+usually use the right arguments already.
+
+=item auth ( USERNAME, PASSWORD )
+
+=item auth ( SASL )
+
+Attempt SASL authentication. Requires Authen::SASL module. The first form
+constructs a new Authen::SASL object using the given username and password;
+the second form uses the given Authen::SASL object.
+
+=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://www.ietf.org/rfc/rfc3461.txt
+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 and must be encoded by the
+caller to octets of whatever encoding is required, e.g. by using the Encode
+module's C<encode()> function.
+
+If specified the contents of C<DATA> and a termination string C<".\r\n"> is
+sent to the server. 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 bdat ( DATA )
+
+=item bdatlast ( DATA )
+
+Use the alternate DATA command "BDAT" of the data chunking service extension
+defined in RFC1830 for efficiently sending large MIME messages.
+
+=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.
+
+=item can_inet6 ()
+
+Returns whether we can use IPv6.
+
+=item can_ssl ()
+
+Returns whether we can use SSL.
+
+=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 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>,
+L<IO::Socket::SSL>
+
+=head1 AUTHOR
+
+Graham Barr E<lt>F<gbarr@pobox.com>E<gt>.
+
+Steve Hay E<lt>F<shay@cpan.org>E<gt> is now maintaining libnet as of version
+1.22_02.
+
+=head1 COPYRIGHT
+
+Copyright (C) 1995-2004 Graham Barr. All rights reserved.
+
+Copyright (C) 2013-2016 Steve Hay. All rights reserved.
+
+=head1 LICENCE
+
+This module is free software; you can redistribute it and/or modify it under the
+same terms as Perl itself, i.e. under the terms of either the GNU General Public
+License or the Artistic License, as specified in the F<LICENCE> file.
+
+=cut
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/Time.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/Time.pm
new file mode 100644
index 0000000000..d049408538
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/Time.pm
@@ -0,0 +1,164 @@
+# Net::Time.pm
+#
+# Copyright (C) 1995-2004 Graham Barr. All rights reserved.
+# Copyright (C) 2014 Steve Hay. All rights reserved.
+# This module is free software; you can redistribute it and/or modify it under
+# the same terms as Perl itself, i.e. under the terms of either the GNU General
+# Public License or the Artistic License, as specified in the F<LICENCE> file.
+
+package Net::Time;
+
+use 5.008001;
+
+use strict;
+use warnings;
+
+use Carp;
+use Exporter;
+use IO::Select;
+use IO::Socket;
+use Net::Config;
+
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw(inet_time inet_daytime);
+
+our $VERSION = "3.11";
+
+our $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 my $addr (@$hosts) {
+ $me = IO::Socket::INET->new(
+ PeerAddr => $addr,
+ 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;
+ my $buf = '';
+ my $offset = 0 | 0;
+
+ return
+ 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;
+ 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 E<lt>F<gbarr@pobox.com>E<gt>.
+
+Steve Hay E<lt>F<shay@cpan.org>E<gt> is now maintaining libnet as of version
+1.22_02.
+
+=head1 COPYRIGHT
+
+Copyright (C) 1995-2004 Graham Barr. All rights reserved.
+
+Copyright (C) 2014 Steve Hay. All rights reserved.
+
+=head1 LICENCE
+
+This module is free software; you can redistribute it and/or modify it under the
+same terms as Perl itself, i.e. under the terms of either the GNU General Public
+License or the Artistic License, as specified in the F<LICENCE> file.
+
+=cut
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/hostent.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/hostent.pm
new file mode 100644
index 0000000000..8831919fb4
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/hostent.pm
@@ -0,0 +1,156 @@
+package Net::hostent;
+use strict;
+
+use 5.006_001;
+our $VERSION = '1.02';
+our (@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
+our (
+ $h_name, @h_aliases,
+ $h_addrtype, $h_length,
+ @h_addr_list, $h_addr
+);
+
+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 ] );
+}
+
+# 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/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/libnetFAQ.pod b/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/libnetFAQ.pod
new file mode 100644
index 0000000000..bcc53479ba
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/libnetFAQ.pod
@@ -0,0 +1,301 @@
+=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/dist/libnet/
+
+=head2 How to contribute to this document
+
+You may report corrections, additions, and suggestions on the
+CPAN Request Tracker at
+
+ http://rt.cpan.org/Public/Bug/Report.html?Queue=libnet
+
+=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.
+
+Steve Hay E<lt>F<shay@cpan.org>E<gt> is now maintaining libnet as of version
+1.22_02.
+
+=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 ?
+
+This version of libnet requires Perl 5.8.1 or higher.
+
+=head2 What other modules do I need ?
+
+No non-core modules are required for normal use, except on os390,
+which requires Convert::EBCDIC.
+
+Authen::SASL is required for AUTH support.
+
+IO::Socket::SSL version 2.007 or higher is required for SSL support.
+
+IO::Socket::IP version 0.25 or IO::Socket::INET6 version 2.62 is
+required for IPv6 support.
+
+=head2 What machines support libnet ?
+
+libnet itself is an entirely perl-code distribution so it should work
+on any machine that perl runs on.
+
+=head2 Where can I get the latest libnet release
+
+The latest libnet release is always on CPAN, you will find it
+in
+
+ http://search.cpan.org/dist/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 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-1998 Graham Barr. All rights reserved.
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/netent.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/netent.pm
new file mode 100644
index 0000000000..b21c5d11b8
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/netent.pm
@@ -0,0 +1,173 @@
+package Net::netent;
+use strict;
+
+use 5.006_001;
+our $VERSION = '1.01';
+our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
+our (
+ $n_name, @n_aliases,
+ $n_addrtype, $n_net
+);
+
+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 ] );
+}
+
+# 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/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/protoent.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/protoent.pm
new file mode 100644
index 0000000000..cef20fbd0b
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/protoent.pm
@@ -0,0 +1,96 @@
+package Net::protoent;
+use strict;
+
+use 5.006_001;
+our $VERSION = '1.01';
+our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
+our ( $p_name, @p_aliases, $p_proto );
+BEGIN {
+ use Exporter ();
+ @EXPORT = qw(getprotobyname getprotobynumber getprotoent getproto);
+ @EXPORT_OK = qw( $p_name @p_aliases $p_proto );
+ %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] );
+}
+
+# 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/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/servent.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/servent.pm
new file mode 100644
index 0000000000..a3b2bad2c2
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Net/servent.pm
@@ -0,0 +1,113 @@
+package Net::servent;
+use strict;
+
+use 5.006_001;
+our $VERSION = '1.02';
+our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
+our ( $s_name, @s_aliases, $s_port, $s_proto );
+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 ] );
+}
+
+# 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