KevinSchoenmayer/GseTDDUebungKCLR
2
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial Commit

Browse Source
This commit is contained in:
Riley Schneider
2025-12-03 16:38:10 +01:00
parent c5e26bf594
commit b732d8d4b5
17680 changed files with 5977495 additions and 2 deletions
Download Patch File Download Diff File Expand all files Collapse all files

910
database/perl/lib/Net/Cmd.pm Normal file
View File

@@ -0,0 +1,910 @@
# Net::Cmd.pm
#
# Copyright (C) 1995-2006 Graham Barr. All rights reserved.
# Copyright (C) 2013-2016, 2020 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.13";
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, $resp)';
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()>.
=head2 Public Methods
These methods provide a user interface to the C<Net::Cmd> object.
=over 4
=item C<debug($level)>
Set the level of debug information for this object. If C<$level> is not given
then the current state is returned. Otherwise the state is changed to
C<$level> 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<$level> 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 C<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 C<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 C<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 C<status()>
Returns the most significant digit of the current status code. If a command
is pending then C<CMD_PENDING> is returned.
=item C<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 C<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
=head2 Protected 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 C<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 C<debug_text($dir, $text)>
This method is called to print debugging information. C<$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 C<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 C<unsupported()>
Sets the status code to 580 and the response text to 'Unsupported command'.
Returns zero.
=item C<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 C<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 C<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 C<ungetline($text)>
Unget a line of text from the server.
=item C<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 C<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 C<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
=head2 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
The following symbols are, or can be, exported by this module:
=over 4
=item Default Exports
C<CMD_INFO>,
C<CMD_OK>,
C<CMD_MORE>,
C<CMD_REJECT>,
C<CMD_ERROR>,
C<CMD_PENDING>.
(These correspond to possible results of C<response()> and C<status()>.)
=item Optional Exports
I<None>.
=item Export Tags
I<None>.
=back
=head1 KNOWN BUGS
See L<https://rt.cpan.org/Dist/Display.html?Status=Active&Queue=libnet>.
=head1 AUTHOR
Graham Barr E<lt>L<gbarr@pobox.com|mailto:gbarr@pobox.com>E<gt>.
Steve Hay E<lt>L<shay@cpan.org|mailto: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, 2020 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.
=head1 VERSION
Version 3.13
=head1 DATE
23 Dec 2020
=head1 HISTORY
See the F<Changes> file.
=cut

381
database/perl/lib/Net/Config.pm Normal file
View File

@@ -0,0 +1,381 @@
# Net::Config.pm
#
# Copyright (C) 2000 Graham Barr. All rights reserved.
# Copyright (C) 2013-2014, 2016, 2020 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.13";
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__
=head2 Class 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 C<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
=head2 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 EXPORTS
The following symbols are, or can be, exported by this module:
=over 4
=item Default Exports
C<%NetConfig>.
=item Optional Exports
I<None>.
=item Export Tags
I<None>.
=back
=head1 KNOWN BUGS
I<None>.
=head1 AUTHOR
Graham Barr E<lt>L<gbarr@pobox.com|mailto:gbarr@pobox.com>E<gt>.
Steve Hay E<lt>L<shay@cpan.org|mailto:shay@cpan.org>E<gt> is now maintaining
libnet as of version 1.22_02.
=head1 COPYRIGHT
Copyright (C) 2000 Graham Barr. All rights reserved.
Copyright (C) 2013-2014, 2016, 2020 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.
=head1 VERSION
Version 3.13
=head1 DATE
23 Dec 2020
=head1 HISTORY
See the F<Changes> file.
=cut

408
database/perl/lib/Net/Domain.pm Normal file
View File

@@ -0,0 +1,408 @@
# Net::Domain.pm
#
# Copyright (C) 1995-1998 Graham Barr. All rights reserved.
# Copyright (C) 2013-2014, 2020 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.13";
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.
=head2 Functions
=over 4
=item C<hostfqdn()>
Identify and return the FQDN of the current host.
=item C<domainname()>
An alias for hostfqdn().
=item C<hostname()>
Returns the smallest part of the FQDN which can be used to identify the host.
=item C<hostdomain()>
Returns the remainder of the FQDN after the I<hostname> has been removed.
=back
=head1 EXPORTS
The following symbols are, or can be, exported by this module:
=over 4
=item Default Exports
I<None>.
=item Optional Exports
C<hostname>,
C<hostdomain>,
C<hostfqdn>,
C<domainname>.
=item Export Tags
I<None>.
=back
=head1 KNOWN BUGS
See L<https://rt.cpan.org/Dist/Display.html?Status=Active&Queue=libnet>.
=head1 AUTHOR
Graham Barr E<lt>L<gbarr@pobox.com|mailto:gbarr@pobox.com>E<gt>.
Adapted from Sys::Hostname by David Sundstrom
E<lt>L<sunds@asictest.sc.ti.com|mailto:sunds@asictest.sc.ti.com>E<gt>.
Steve Hay E<lt>L<shay@cpan.org|mailto: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, 2020 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.
=head1 VERSION
Version 3.13
=head1 DATE
23 Dec 2020
=head1 HISTORY
See the F<Changes> file.
=cut

2057
database/perl/lib/Net/FTP.pm Normal file
View File

File diff suppressed because it is too large Load Diff

115
database/perl/lib/Net/FTP/A.pm Normal file
View File

@@ -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.13";
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;

13
database/perl/lib/Net/FTP/E.pm Normal file
View File

@@ -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.13";
1;

84
database/perl/lib/Net/FTP/I.pm Normal file
View File

@@ -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.13";
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;

13
database/perl/lib/Net/FTP/L.pm Normal file
View File

@@ -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.13";
1;

237
database/perl/lib/Net/FTP/dataconn.pm Normal file
View File

@@ -0,0 +1,237 @@
##
## 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.13';
$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 SYNOPSIS
# Perform IO operations on an FTP client data connection object:
$num_bytes_read = $obj->read($buffer, $size);
$num_bytes_read = $obj->read($buffer, $size, $timeout);
$num_bytes_written = $obj->write($buffer, $size);
$num_bytes_written = $obj->write($buffer, $size, $timeout);
$num_bytes_read_so_far = $obj->bytes_read();
$obj->abort();
$closed_successfully = $obj->close();
=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 C<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 C<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 C<bytes_read()>
Returns the number of bytes read so far.
=item C<abort()>
Abort the current data transfer.
=item C<close()>
Close the data connection and get a response from the FTP server. Returns
I<true> if the connection was closed successfully and the first digit of
the response from the server was a '2'.
=back
=head1 EXPORTS
I<None>.
=head1 KNOWN BUGS
I<None>.
=head1 AUTHOR
Graham Barr E<lt>L<gbarr@pobox.com|mailto:gbarr@pobox.com>E<gt>.
Steve Hay E<lt>L<shay@cpan.org|mailto:shay@cpan.org>E<gt> is now maintaining
libnet as of version 1.22_02.
=head1 COPYRIGHT
Copyright (C) 1997-2010 Graham Barr. All rights reserved.
Copyright (C) 2013-2014, 2020 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.
=head1 VERSION
Version 3.13
=head1 DATE
23 Dec 2020
=head1 HISTORY
See the F<Changes> file.
=cut

1321
database/perl/lib/Net/NNTP.pm Normal file
View File

File diff suppressed because it is too large Load Diff

366
database/perl/lib/Net/Netrc.pm Normal file
View File

@@ -0,0 +1,366 @@
# Net::Netrc.pm
#
# Copyright (C) 1995-1998 Graham Barr. All rights reserved.
# Copyright (C) 2013-2014, 2020 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.13";
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.
=head2 The F<.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
=head2 Class Methods
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 C<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
=head2 Object Methods
=over 4
=item C<login()>
Return the login id for the netrc entry
=item C<password()>
Return the password for the netrc entry
=item C<account()>
Return the account information for the netrc entry
=item C<lpa()>
Return a list of login, password and account information for the netrc entry
=back
=head1 EXPORTS
I<None>.
=head1 KNOWN BUGS
See L<https://rt.cpan.org/Dist/Display.html?Status=Active&Queue=libnet>.
=head1 SEE ALSO
L<Net::Cmd>.
=head1 AUTHOR
Graham Barr E<lt>L<gbarr@pobox.com|mailto:gbarr@pobox.com>E<gt>.
Steve Hay E<lt>L<shay@cpan.org|mailto: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, 2020 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.
=head1 VERSION
Version 3.13
=head1 DATE
23 Dec 2020
=head1 HISTORY
See the F<Changes> file.
=cut

882
database/perl/lib/Net/POP3.pm Normal file
View File

@@ -0,0 +1,882 @@
# Net::POP3.pm
#
# Copyright (C) 1995-2004 Graham Barr. All rights reserved.
# Copyright (C) 2013-2016, 2020 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.13";
# 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.
=head2 Class Methods
=over 4
=item C<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
=head2 Object 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 C<host()>
Returns the value used by the constructor, and passed to IO::Socket::INET,
to connect to the host.
=item C<auth($username, $password)>
Attempt SASL authentication.
=item C<user($user)>
Send the USER command.
=item C<pass($pass)>
Send the PASS command. Returns the number of messages in the mailbox.
=item C<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 C<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 C<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 C<banner()>
Return the sever's connection banner
=item C<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 C<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 C<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 C<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 C<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 C<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 C<last()>
Returns the highest C<$msgnum> of all the messages accessed.
=item C<popstat()>
Returns a list of two elements. These are the number of undeleted
elements and the size of the mbox in octets.
=item C<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 C<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 C<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 C<reset()>
Reset the status of the remote POP3 server. This includes resetting the
status of all messages to not be deleted.
=item C<quit()>
Quit and close the connection to the remote POP3 server. Any messages marked
as deleted will be deleted from the remote mailbox.
=item C<can_inet6()>
Returns whether we can use IPv6.
=item C<can_ssl()>
Returns whether we can use SSL.
=back
=head2 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 EXPORTS
I<None>.
=head1 KNOWN BUGS
See L<https://rt.cpan.org/Dist/Display.html?Status=Active&Queue=libnet>.
=head1 SEE ALSO
L<Net::Netrc>,
L<Net::Cmd>,
L<IO::Socket::SSL>.
=head1 AUTHOR
Graham Barr E<lt>L<gbarr@pobox.com|mailto:gbarr@pobox.com>E<gt>.
Steve Hay E<lt>L<shay@cpan.org|mailto: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, 2020 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.
=head1 VERSION
Version 3.13
=head1 DATE
23 Dec 2020
=head1 HISTORY
See the F<Changes> file.
=cut

2590
database/perl/lib/Net/Ping.pm Normal file
View File

File diff suppressed because it is too large Load Diff

1065
database/perl/lib/Net/SMTP.pm Normal file
View File

File diff suppressed because it is too large Load Diff

203
database/perl/lib/Net/Time.pm Normal file
View File

@@ -0,0 +1,203 @@
# Net::Time.pm
#
# Copyright (C) 1995-2004 Graham Barr. All rights reserved.
# Copyright (C) 2014, 2020 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.13";
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.
=head2 Functions
=over 4
=item C<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 C<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 EXPORTS
The following symbols are, or can be, exported by this module:
=over 4
=item Default Exports
I<None>.
=item Optional Exports
C<inet_time>,
C<inet_daytime>.
=item Export Tags
I<None>.
=back
=head1 KNOWN BUGS
I<None>.
=head1 AUTHOR
Graham Barr E<lt>L<gbarr@pobox.com|mailto:gbarr@pobox.com>E<gt>.
Steve Hay E<lt>L<shay@cpan.org|mailto: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, 2020 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.
=head1 VERSION
Version 3.13
=head1 DATE
23 Dec 2020
=head1 HISTORY
See the F<Changes> file.
=cut

156
database/perl/lib/Net/hostent.pm Normal file
View File

@@ -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

14
database/perl/lib/Net/libnet.cfg Normal file
View File

@@ -0,0 +1,14 @@
{
'smtp_hosts' => [],
'ftp_int_passive' => 1,
'snpp_hosts' => [],
'inet_domain' => undef,
'time_hosts' => [],
'ftp_testhost' => undef,
'nntp_hosts' => [],
'daytime_hosts' => [],
'pop3_hosts' => [],
'test_hosts' => 1,
'ph_hosts' => [],
'test_exist' => 1,
}

303
database/perl/lib/Net/libnetFAQ.pod Normal file
View File

@@ -0,0 +1,303 @@
=head1 NAME
libnetFAQ - libnet Frequently Asked Questions
=head1 DESCRIPTION
=head2 Where to get this document
This document is distributed with the libnet distribution, and is also
available on the libnet web page at
L<https://metacpan.org/release/libnet>
=head2 How to contribute to this document
You may report corrections, additions, and suggestions on the
CPAN Request Tracker at
L<https://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 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.
Steve Hay E<lt>L<shay@cpan.org|mailto: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
L<https://metacpan.org/release/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.

173
database/perl/lib/Net/netent.pm Normal file
View File

@@ -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

96
database/perl/lib/Net/protoent.pm Normal file
View File

@@ -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

113
database/perl/lib/Net/servent.pm Normal file
View File

@@ -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