@@ -1,3 +1,67 @@
+libnet 3.02 -- Fri Oct 10 2014
+
+ * Don't run interactive prompt() in Makefile.PL when in PERL_CORE.
+ * Fix $smtp->auth($sasl) to try the AUTH mechanism (if present) in the
+ Authen::SASL object before falling back on other mechanisms. [Resolves
+ CPAN RT#99415]
+
+libnet 3.01 -- Thu Oct 09 2014
+
+ * Require IO::Socket::SSL >= 1.999 to protect against a bad version (0.30) of
+ IO::Socket::IP and hopefully fix another bunch of CPAN Testers failures.
+ [Steffen Ullrich]
+
+libnet 3.00 -- Thu Oct 09 2014
+
+ * Skip Perl Critic, Pod and Pod Coverage tests unless AUTHOR_TESTING.
+ [Resolves CPAN RT#99399]
+ * Synchronize all $VERSIONs to the distribution's version number, bumping that
+ to 3.00 so that no $VERSIONs end up going backwards.
+
+libnet 1.30 -- Wed Oct 08 2014
+
+ * Sigh. Fix PAUSE indexing problem again. Net::SMTP::SSL is already used by
+ Net-SMTP-SSL.
+
+libnet 1.29 -- Wed Oct 08 2014
+
+ * Fix PAUSE indexing problem. Net::POP3::_SSLified and Net::SMTP::_SSLified
+ are already used by Net-SSLGlue.
+
+libnet 1.28 -- Wed Oct 08 2014
+
+ * Improve code()/message() initialization and error handling in Net::Cmd
+ [Tom Metro; resolves CPAN RT#14875]
+ * Don't use the ALLO command on FTP servers that don't support it. [Resolves
+ CPAN RT#95717]
+ * Stop Makefile.PL from requiring interactive configuration when running via
+ cpan, cpanp or cpanm: just accept all defaults in these cases, as when
+ running non-interactively. [Resolves CPAN RT#48966]
+ * Add optional POD coverage testing.
+ * Add optional POD testing.
+ * Add optional Perl::Critic testing.
+ * Make code Perl::Critic clean.
+ * Move Net/*.pm into lib/Net/ sub-directory within distribution. This is the
+ usual layout style these days.
+ * Change Net::SMTP::auth() so that it now falls back to another supported AUTH
+ method if a given AUTH method fails. [Ivan Baktsheev; closes PR#3]
+ * Change Net::SMTP::auth() so that it uses the SMTP AUTH mechanism(s)
+ specified in the Authen::SASL object if one is provided instead of a
+ username. If a plain text username is specified then use the first
+ reported SMTP AUTH method supported, as usual. [Ewen McNeill; resolves CPAN
+ RT#58002]
+ * Add support for IPv6 and SSL to Net::FTP, Net::NNTP, Net::POP3 and
+ Net::SMTP. These features are only available if the user has
+
+ a recent IO::Socket::SSL for SSL support
+ a recent IO::Socket::IP or an older IO::Socket::INET6 for IPv6 support
+
+ If no SSL module is available it will work as before, but attempts to use
+ the SSL functionality will result in an error message. If no IPv6 modules
+ are available it will just use IPv4 as before. With IPv6 modules installed
+ one can of course still access IPv4 hosts.
+ [Steffen Ullrich; resolves CPAN RT#93823]
+
libnet 1.27 -- Fri May 30 2014
* Simplified Makefile.PL requirements.
@@ -1,49 +0,0 @@
-package Net::Config;
-
-require Exporter;
-use vars qw(@ISA @EXPORT %NetConfig);
-use strict;
-
-@EXPORT = qw(%NetConfig);
-@ISA = qw(Exporter);
-
-# WARNING WARNING WARNING WARNING WARNING WARNING WARNING
-# WARNING WARNING WARNING WARNING WARNING WARNING WARNING
-#
-# Below this line is auto-generated, *ANY* changes will be lost
-
-%NetConfig = (
- # the followinf parameters are all lists of hosts for the
- # respective protocols.
- nntp_hosts => [],
- snpp_hosts => [],
- pop3_hosts => [],
- smtp_hosts => [],
- ph_hosts => [],
- daytime_hosts => [],
- time_hosts => [],
-
- # your internet domain
- inet_domain => undef,
-
- # If you have an ftp proxy firewall (not an http firewall)
- # then set this to the name of the firewall
- ftp_firewall => undef,
-
- # set if all connections done via the firewall should use
- # passive data connections
- ftp_ext_passive => 0,
-
- # set if all connections not done via the firewall should use
- # passive data connections
- ftp_int_passive => 0,
-
- # If set the make test will attempt to connect to the hosts above
- test_hosts => 0,
-
- # Used during Configure (which you are not using) to do
- # DNS lookups to ensure hosts exist
- test_exist => 0,
-
-);
-1;
@@ -1,13 +1,19 @@
-#!/usr/local/bin/perl
+#!perl
#
# $Id: Configure,v 1.8 1997/03/04 09:22:32 gbarr Exp $
+use 5.008001;
+
use strict;
-use IO::File;
-use Getopt::Std;
+use warnings;
+
use ExtUtils::MakeMaker qw(prompt);
+use Getopt::Std;
+use IO::File;
+
+## no critic (Subroutines::ProhibitSubroutinePrototypes)
-use vars qw($opt_d $opt_o);
+our($opt_d, $opt_o);
##
##
@@ -37,10 +43,9 @@ sub test_hostnames (\@)
{
my $hlist = shift;
my @h = ();
- my $host;
my $err = 0;
- foreach $host (@$hlist)
+ foreach my $host (@$hlist)
{
if(valid_host($host))
{
@@ -213,10 +218,9 @@ MASK:
sub default_hostname
{
- my $host;
my @host;
- foreach $host (@_)
+ foreach my $host (@_)
{
if(defined($host) && valid_host($host))
{
@@ -240,7 +244,10 @@ $libnet_cfg = "libnet.cfg"
my %oldcfg = ();
+{
+no warnings 'once';
$Net::Config::CONFIGURE = 1; # Suppress load of user overrides
+}
if( -f $libnet_cfg )
{
%oldcfg = ( %{ do $libnet_cfg } );
@@ -248,7 +255,10 @@ if( -f $libnet_cfg )
elsif (eval { require Net::Config })
{
$have_old = 1;
+ {
+ no warnings 'once';
%oldcfg = %Net::Config::NetConfig;
+ }
}
map { $cfg{lc $_} = $cfg{$_}; delete $cfg{$_} if /[A-Z]/ } keys %cfg;
@@ -567,8 +577,7 @@ print "Writing $libnet_cfg\n";
print $fh "{\n";
-my $key;
-foreach $key (keys %cfg) {
+foreach my $key (keys %cfg) {
my $val = $cfg{$key};
if(!defined($val)) {
$val = "undef";
@@ -1,14 +0,0 @@
-#
-
-package Sys::Hostname;
-
-use Net::Domain qw(hostname);
-use Carp;
-
-require Exporter;
-@ISA = qw(Exporter);
-@EXPORT = qw(hostname);
-
-carp "deprecated package 'Sys::Hostname', use Net::Domain" if $^W;
-
-1;
@@ -1,42 +1,51 @@
Changes
-Config.eg
Configure
-Hostname.pm.eg Example replacement for Hostname.pm
MANIFEST
+MANIFEST.SKIP
Makefile.PL
-Net/Cmd.pm
-Net/Config.pm
-Net/Domain.pm DNS Domain name lookup
-Net/FTP.pm File Transfer Protocol Client
-Net/FTP/A.pm
-Net/FTP/E.pm
-Net/FTP/I.pm
-Net/FTP/L.pm
-Net/FTP/dataconn.pm
-Net/NNTP.pm Network News Transfer Protocol
-Net/Netrc.pm .netrc lookup routines
-Net/POP3.pm Post Office Protocol
-Net/SMTP.pm Simple Mail Transfer Protocol Client
-Net/Time.pm time & nettime protocols
-Net/libnetFAQ.pod
README
demos/ftp
-demos/inetd
demos/nntp
demos/nntp.mirror
demos/pop3
demos/smtp.self
demos/time
-install-nomake
+lib/Net/Cmd.pm
+lib/Net/Config.pm
+lib/Net/Domain.pm DNS Domain name lookup
+lib/Net/FTP.pm File Transfer Protocol Client
+lib/Net/FTP/A.pm
+lib/Net/FTP/E.pm
+lib/Net/FTP/I.pm
+lib/Net/FTP/L.pm
+lib/Net/FTP/dataconn.pm
+lib/Net/NNTP.pm Network News Transfer Protocol
+lib/Net/Netrc.pm .netrc lookup routines
+lib/Net/POP3.pm Post Office Protocol
+lib/Net/SMTP.pm Simple Mail Transfer Protocol Client
+lib/Net/Time.pm time & nettime protocols
+lib/Net/libnetFAQ.pod
t/config.t
+t/critic.t
t/datasend.t
+t/external/smtp-ssl.t
+t/external/pop3-ssl.t
+t/external/ftp-ssl.t
t/ftp.t
t/hostname.t
t/libnet_t.pl
t/netrc.t
t/nntp.t
+t/nntp_ssl.t
+t/nntp_ipv6.t
+t/pod.t
+t/pod_coverage.t
t/require.t
t/smtp.t
+t/smtp_ssl.t
+t/smtp_ipv6.t
+t/pop3_ssl.t
+t/pop3_ipv6.t
t/time.t
META.yml Module YAML meta-data (added by MakeMaker)
META.json Module JSON meta-data (added by MakeMaker)
@@ -0,0 +1,19 @@
+# Source control system files
+^\.git/
+^\.gitignore$
+
+# Files generated by Makefile.PL
+^libnet.cfg$
+^Makefile$
+^MYMETA\.json$
+^MYMETA\.yml$
+
+# Files generated by *make
+^blib/
+^pm_to_blib$
+
+# Files generated by *make clean
+^Makefile\.old$
+
+# Files generated by *make dist
+^libnet-\d\.\d\d\.tar\.gz$
@@ -40,6 +40,56 @@
}
}
}
+ },
+ "IPv6" : {
+ "description" : "IPv6 support",
+ "prereqs" : {
+ "runtime" : {
+ "requires" : {
+ "IO::Socket::IP" : "0.20"
+ }
+ }
+ }
+ },
+ "SSL" : {
+ "description" : "SSL support",
+ "prereqs" : {
+ "runtime" : {
+ "requires" : {
+ "IO::Socket::SSL" : "1.999"
+ }
+ }
+ }
+ },
+ "critictest" : {
+ "description" : "Perl::Critic testing",
+ "prereqs" : {
+ "test" : {
+ "requires" : {
+ "Test::Perl::Critic" : "0"
+ }
+ }
+ }
+ },
+ "podcoveragetest" : {
+ "description" : "POD coverage testing",
+ "prereqs" : {
+ "test" : {
+ "requires" : {
+ "Test::Pod::Coverage" : "0.08"
+ }
+ }
+ }
+ },
+ "podtest" : {
+ "description" : "POD testing",
+ "prereqs" : {
+ "test" : {
+ "requires" : {
+ "Test::Pod" : "1.00"
+ }
+ }
+ }
}
},
"prereqs" : {
@@ -72,6 +122,7 @@
"Socket" : "1.3",
"Symbol" : "0",
"Time::Local" : "0",
+ "constant" : "0",
"perl" : "5.008001",
"strict" : "0",
"vars" : "0"
@@ -79,6 +130,7 @@
},
"test" : {
"requires" : {
+ "Config" : "0",
"Cwd" : "0"
}
}
@@ -90,5 +142,5 @@
"url" : "https://github.com/steve-m-hay/perl-libnet.git"
}
},
- "version" : "1.27"
+ "version" : "3.02"
}
@@ -3,6 +3,7 @@ abstract: 'Collection of network protocol modules'
author:
- 'Graham Barr <gbarr@pobox.com>, Steve Hay <shay@cpan.org>'
build_requires:
+ Config: '0'
Cwd: '0'
ExtUtils::MakeMaker: '0'
configure_requires:
@@ -33,6 +34,20 @@ optional_features:
requires:
Authen::SASL: '0'
MIME::Base64: '0'
+ IPv6:
+ description: 'IPv6 support'
+ requires:
+ IO::Socket::IP: '0.20'
+ SSL:
+ description: 'SSL support'
+ requires:
+ IO::Socket::SSL: '1.999'
+ critictest:
+ description: 'Perl::Critic testing'
+ podcoveragetest:
+ description: 'POD coverage testing'
+ podtest:
+ description: 'POD testing'
requires:
Carp: '0'
Errno: '0'
@@ -46,9 +61,10 @@ requires:
Socket: '1.3'
Symbol: '0'
Time::Local: '0'
+ constant: '0'
perl: '5.008001'
strict: '0'
vars: '0'
resources:
repository: https://github.com/steve-m-hay/perl-libnet.git
-version: '1.27'
+version: '3.02'
@@ -23,6 +23,10 @@ use warnings;
use ExtUtils::MakeMaker 6.64;
use ExtUtils::MakeMaker qw(WriteMakefile);
+## no critic (Subroutines::ProhibitSubroutinePrototypes)
+
+sub running_under_cpan();
+
#===============================================================================
# INITIALIZATION
#===============================================================================
@@ -42,13 +46,25 @@ MAIN: {
my %prereq_pms = ();
$prereq_pms{'Convert::EBCDIC'} = '0.06' if $^O eq 'os390';
+ my $xt = 'n';
+ if (not running_under_cpan() and not $ENV{PERL_CORE}) {
+ $xt = prompt("Should I do external tests?\n" .
+ "These tests will fail if there is no internet" .
+ " connection or if a firewall\n" .
+ "blocks or modifies some traffic.\n" .
+ "[y/N]", 'n');
+ }
+
+ my $tests = 't/*.t';
+ $tests .= ' t/external/*.t' if $xt =~ m/^y/io;
+
WriteMakefile(
NAME => 'Net',
DISTNAME => 'libnet',
ABSTRACT => 'Collection of network protocol modules',
AUTHOR => 'Graham Barr <gbarr@pobox.com>, Steve Hay <shay@cpan.org>',
LICENSE => 'perl_5',
- VERSION => '1.27',
+ VERSION => '3.02',
META_MERGE => {
'meta-spec' => {
@@ -84,6 +100,62 @@ MAIN: {
}
}
}
+ },
+
+ SSL => {
+ description => 'SSL support',
+ prereqs => {
+ runtime => {
+ requires => {
+ 'IO::Socket::SSL' => '1.999'
+ }
+ }
+ }
+ },
+
+ IPv6 => {
+ description => 'IPv6 support',
+ prereqs => {
+ runtime => {
+ requires => {
+ 'IO::Socket::IP' => '0.20'
+ # or IO::Socket::INET6 2.62
+ }
+ }
+ }
+ },
+
+ critictest => {
+ description => 'Perl::Critic testing',
+ prereqs => {
+ test => {
+ requires => {
+ 'Test::Perl::Critic' => '0'
+ }
+ }
+ }
+ },
+
+ podtest => {
+ description => 'POD testing',
+ prereqs => {
+ test => {
+ requires => {
+ 'Test::Pod' => '1.00'
+ }
+ }
+ }
+ },
+
+ podcoveragetest => {
+ description => 'POD coverage testing',
+ prereqs => {
+ test => {
+ requires => {
+ 'Test::Pod::Coverage' => '0.08'
+ }
+ }
+ }
}
}
},
@@ -101,7 +173,8 @@ MAIN: {
},
TEST_REQUIRES => {
- 'Cwd' => '0'
+ 'Config' => '0',
+ 'Cwd' => '0'
},
PREREQ_PM => {
@@ -118,6 +191,7 @@ MAIN: {
'Socket' => '1.3',
'Symbol' => '0',
'Time::Local' => '0',
+ 'constant' => '0',
'strict' => '0',
'vars' => '0'
},
@@ -128,6 +202,10 @@ MAIN: {
FILES => $CfgFile
},
+ test => {
+ TESTS => $tests
+ },
+
dist => {
PREOP => 'find $(DISTVNAME) -type d -print|xargs chmod 0755 && ' .
'find $(DISTVNAME) -type f -print|xargs chmod 0644',
@@ -142,10 +220,30 @@ MAIN: {
sub MY::post_initialize {
my $self = shift;
+
return '' if $self->{PERL_CORE};
- system(($^O eq 'VMS' ? 'mcr ': ()), $^X, 'Configure') unless -f $CfgFile;
+
+ if (not -f $CfgFile) {
+ my @args = qw(Configure);
+ push @args, '-d' if $ENV{PERL5_CPAN_IS_RUNNING} ||
+ $ENV{PERL5_CPANPLUS_IS_RUNNING} ||
+ $ENV{PERL5_CPANM_IS_RUNNING};
+ system(($^O eq 'VMS' ? 'mcr ': ()), $^X, @args)
+ }
+
$self->{PM}{$CfgFile} = $self->catfile('$(INST_LIBDIR)',$CfgPath);
+
return '';
}
#===============================================================================
+# SUBROUTINES
+#===============================================================================
+
+sub running_under_cpan() {
+ return $ENV{PERL5_CPAN_IS_RUNNING} || # cpan
+ $ENV{PERL5_CPANPLUS_IS_RUNNING} || # cpanp
+ $ENV{PERL5_CPANM_IS_RUNNING}; # cpanm
+}
+
+#===============================================================================
@@ -1,793 +0,0 @@
-# Net::Cmd.pm
-#
-# Copyright (c) 1995-2006 Graham Barr <gbarr@pobox.com>. All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-
-package Net::Cmd;
-
-require 5.001;
-require Exporter;
-
-use strict;
-use vars qw(@ISA @EXPORT $VERSION);
-use Carp;
-use Symbol 'gensym';
-
-BEGIN {
- if ($^O eq 'os390') {
- require Convert::EBCDIC;
-
- # Convert::EBCDIC->import;
- }
-}
-
-BEGIN {
- if (!eval { require utf8 }) {
- *is_utf8 = sub { 0 };
- }
- elsif (eval { utf8::is_utf8(undef); 1 }) {
- *is_utf8 = \&utf8::is_utf8;
- }
- elsif (eval { require Encode; Encode::is_utf8(undef); 1 }) {
- *is_utf8 = \&Encode::is_utf8;
- }
- else {
- *is_utf8 = sub { $_[0] =~ /[^\x00-\xff]/ };
- }
-}
-
-$VERSION = "2.30";
-@ISA = qw(Exporter);
-@EXPORT = qw(CMD_INFO CMD_OK CMD_MORE CMD_REJECT CMD_ERROR CMD_PENDING);
-
-
-sub CMD_INFO {1}
-sub CMD_OK {2}
-sub CMD_MORE {3}
-sub CMD_REJECT {4}
-sub CMD_ERROR {5}
-sub CMD_PENDING {0}
-
-my %debug = ();
-
-my $tr = $^O eq 'os390' ? Convert::EBCDIC->new() : undef;
-
-
-sub toebcdic {
- my $cmd = shift;
-
- unless (exists ${*$cmd}{'net_cmd_asciipeer'}) {
- my $string = $_[0];
- my $ebcdicstr = $tr->toebcdic($string);
- ${*$cmd}{'net_cmd_asciipeer'} = $string !~ /^\d+/ && $ebcdicstr =~ /^\d+/;
- }
-
- ${*$cmd}{'net_cmd_asciipeer'}
- ? $tr->toebcdic($_[0])
- : $_[0];
-}
-
-
-sub toascii {
- my $cmd = shift;
- ${*$cmd}{'net_cmd_asciipeer'}
- ? $tr->toascii($_[0])
- : $_[0];
-}
-
-
-sub _print_isa {
- no strict qw(refs);
-
- my $pkg = shift;
- my $cmd = $pkg;
-
- $debug{$pkg} ||= 0;
-
- my %done = ();
- my @do = ($pkg);
- my %spc = ($pkg, "");
-
- while ($pkg = shift @do) {
- next if defined $done{$pkg};
-
- $done{$pkg} = 1;
-
- my $v =
- defined ${"${pkg}::VERSION"}
- ? "(" . ${"${pkg}::VERSION"} . ")"
- : "";
-
- my $spc = $spc{$pkg};
- $cmd->debug_print(1, "${spc}${pkg}${v}\n");
-
- if (@{"${pkg}::ISA"}) {
- @spc{@{"${pkg}::ISA"}} = (" " . $spc{$pkg}) x @{"${pkg}::ISA"};
- unshift(@do, @{"${pkg}::ISA"});
- }
- }
-}
-
-
-sub debug {
- @_ == 1 or @_ == 2 or croak 'usage: $obj->debug([LEVEL])';
-
- my ($cmd, $level) = @_;
- my $pkg = ref($cmd) || $cmd;
- my $oldval = 0;
-
- if (ref($cmd)) {
- $oldval = ${*$cmd}{'net_cmd_debug'} || 0;
- }
- else {
- $oldval = $debug{$pkg} || 0;
- }
-
- return $oldval
- unless @_ == 2;
-
- $level = $debug{$pkg} || 0
- unless defined $level;
-
- _print_isa($pkg)
- if ($level && !exists $debug{$pkg});
-
- if (ref($cmd)) {
- ${*$cmd}{'net_cmd_debug'} = $level;
- }
- else {
- $debug{$pkg} = $level;
- }
-
- $oldval;
-}
-
-
-sub message {
- @_ == 1 or croak 'usage: $obj->message()';
-
- my $cmd = shift;
-
- wantarray
- ? @{${*$cmd}{'net_cmd_resp'}}
- : join("", @{${*$cmd}{'net_cmd_resp'}});
-}
-
-
-sub debug_text { $_[2] }
-
-
-sub debug_print {
- my ($cmd, $out, $text) = @_;
- print STDERR $cmd, ($out ? '>>> ' : '<<< '), $cmd->debug_text($out, $text);
-}
-
-
-sub code {
- @_ == 1 or croak 'usage: $obj->code()';
-
- my $cmd = shift;
-
- ${*$cmd}{'net_cmd_code'} = "000"
- unless exists ${*$cmd}{'net_cmd_code'};
-
- ${*$cmd}{'net_cmd_code'};
-}
-
-
-sub status {
- @_ == 1 or croak 'usage: $obj->status()';
-
- my $cmd = shift;
-
- substr(${*$cmd}{'net_cmd_code'}, 0, 1);
-}
-
-
-sub set_status {
- @_ == 3 or croak 'usage: $obj->set_status(CODE, MESSAGE)';
-
- my $cmd = shift;
- my ($code, $resp) = @_;
-
- $resp = [$resp]
- unless ref($resp);
-
- (${*$cmd}{'net_cmd_code'}, ${*$cmd}{'net_cmd_resp'}) = ($code, $resp);
-
- 1;
-}
-
-
-sub command {
- my $cmd = shift;
-
- unless (defined fileno($cmd)) {
- $cmd->set_status("599", "Connection closed");
- return $cmd;
- }
-
-
- $cmd->dataend()
- if (exists ${*$cmd}{'net_cmd_last_ch'});
-
- if (scalar(@_)) {
- local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
-
- my $str = join(
- " ",
- map {
- /\n/
- ? do { my $n = $_; $n =~ tr/\n/ /; $n }
- : $_;
- } @_
- );
- $str = $cmd->toascii($str) if $tr;
- $str .= "\015\012";
-
- my $len = length $str;
- my $swlen;
-
- $cmd->close
- unless (defined($swlen = syswrite($cmd, $str, $len)) && $swlen == $len);
-
- $cmd->debug_print(1, $str)
- if ($cmd->debug);
-
- ${*$cmd}{'net_cmd_resp'} = []; # the response
- ${*$cmd}{'net_cmd_code'} = "000"; # Made this one up :-)
- }
-
- $cmd;
-}
-
-
-sub ok {
- @_ == 1 or croak 'usage: $obj->ok()';
-
- my $code = $_[0]->code;
- 0 < $code && $code < 400;
-}
-
-
-sub unsupported {
- my $cmd = shift;
-
- ${*$cmd}{'net_cmd_resp'} = ['Unsupported command'];
- ${*$cmd}{'net_cmd_code'} = 580;
- 0;
-}
-
-
-sub getline {
- my $cmd = shift;
-
- ${*$cmd}{'net_cmd_lines'} ||= [];
-
- return shift @{${*$cmd}{'net_cmd_lines'}}
- if scalar(@{${*$cmd}{'net_cmd_lines'}});
-
- my $partial = defined(${*$cmd}{'net_cmd_partial'}) ? ${*$cmd}{'net_cmd_partial'} : "";
- my $fd = fileno($cmd);
-
- return undef
- unless defined $fd;
-
- my $rin = "";
- vec($rin, $fd, 1) = 1;
-
- my $buf;
-
- until (scalar(@{${*$cmd}{'net_cmd_lines'}})) {
- my $timeout = $cmd->timeout || undef;
- my $rout;
-
- my $select_ret = select($rout = $rin, undef, undef, $timeout);
- if ($select_ret > 0) {
- unless (sysread($cmd, $buf = "", 1024)) {
- carp(ref($cmd) . ": Unexpected EOF on command channel")
- if $cmd->debug;
- $cmd->close;
- return undef;
- }
-
- substr($buf, 0, 0) = $partial; ## prepend from last sysread
-
- my @buf = split(/\015?\012/, $buf, -1); ## break into lines
-
- $partial = pop @buf;
-
- push(@{${*$cmd}{'net_cmd_lines'}}, map {"$_\n"} @buf);
-
- }
- else {
- my $msg = $select_ret ? "Error or Interrupted: $!" : "Timeout";
- carp("$cmd: $msg") if ($cmd->debug);
- return undef;
- }
- }
-
- ${*$cmd}{'net_cmd_partial'} = $partial;
-
- if ($tr) {
- foreach my $ln (@{${*$cmd}{'net_cmd_lines'}}) {
- $ln = $cmd->toebcdic($ln);
- }
- }
-
- shift @{${*$cmd}{'net_cmd_lines'}};
-}
-
-
-sub ungetline {
- my ($cmd, $str) = @_;
-
- ${*$cmd}{'net_cmd_lines'} ||= [];
- unshift(@{${*$cmd}{'net_cmd_lines'}}, $str);
-}
-
-
-sub parse_response {
- return ()
- unless $_[1] =~ s/^(\d\d\d)(.?)//o;
- ($1, $2 eq "-");
-}
-
-
-sub response {
- my $cmd = shift;
- my ($code, $more) = (undef) x 2;
-
- ${*$cmd}{'net_cmd_resp'} ||= [];
-
- while (1) {
- my $str = $cmd->getline();
-
- return CMD_ERROR
- unless defined($str);
-
- $cmd->debug_print(0, $str)
- if ($cmd->debug);
-
- ($code, $more) = $cmd->parse_response($str);
- unless (defined $code) {
- $cmd->ungetline($str);
- $@ = $str; # $@ used as tunneling hack
- last;
- }
-
- ${*$cmd}{'net_cmd_code'} = $code;
-
- push(@{${*$cmd}{'net_cmd_resp'}}, $str);
-
- last unless ($more);
- }
-
- return undef 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 undef;
-
- $cmd->debug_print(0, $str)
- if ($cmd->debug & 4);
-
- last if ($str =~ /^\.\r?\n/o);
-
- $str =~ s/^\.\././o;
-
- if (defined $fh) {
- print $fh $str;
- }
- else {
- push(@$arr, $str);
- }
- }
-
- $arr;
-}
-
-
-sub datasend {
- my $cmd = shift;
- my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_;
- my $line = join("", @$arr);
-
- # encode to individual utf8 bytes if
- # $line is a string (in internal UTF-8)
- utf8::encode($line) if is_utf8($line);
-
- return 0 unless defined(fileno($cmd));
-
- my $last_ch = ${*$cmd}{'net_cmd_last_ch'};
-
- # 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);
-
- my $len = length($line);
- my $offset = 0;
- my $win = "";
- vec($win, fileno($cmd), 1) = 1;
- my $timeout = $cmd->timeout || undef;
-
- local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
-
- while ($len) {
- my $wout;
- my $s = select(undef, $wout = $win, undef, $timeout);
- if ((defined $s and $s > 0) or -f $cmd) # -f for testing on win32
- {
- my $w = syswrite($cmd, $line, $len, $offset);
- unless (defined($w)) {
- carp("$cmd: $!") if $cmd->debug;
- return undef;
- }
- $len -= $w;
- $offset += $w;
- }
- else {
- carp("$cmd: Timeout") if ($cmd->debug);
- return undef;
- }
- }
-
- 1;
-}
-
-
-sub rawdatasend {
- my $cmd = shift;
- my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_;
- my $line = join("", @$arr);
-
- return 0 unless defined(fileno($cmd));
-
- return 1
- unless length($line);
-
- if ($cmd->debug) {
- my $b = "$cmd>>> ";
- print STDERR $b, join("\n$b", split(/\n/, $line)), "\n";
- }
-
- my $len = length($line);
- my $offset = 0;
- my $win = "";
- vec($win, fileno($cmd), 1) = 1;
- my $timeout = $cmd->timeout || undef;
-
- local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
- while ($len) {
- my $wout;
- if (select(undef, $wout = $win, undef, $timeout) > 0) {
- my $w = syswrite($cmd, $line, $len, $offset);
- unless (defined($w)) {
- carp("$cmd: $!") if $cmd->debug;
- return undef;
- }
- $len -= $w;
- $offset += $w;
- }
- else {
- carp("$cmd: Timeout") if ($cmd->debug);
- return undef;
- }
- }
-
- 1;
-}
-
-
-sub dataend {
- my $cmd = shift;
-
- return 0 unless defined(fileno($cmd));
-
- my $ch = ${*$cmd}{'net_cmd_last_ch'};
- my $tosend;
-
- if (!defined $ch) {
- return 1;
- }
- elsif ($ch ne "\012") {
- $tosend = "\015\012";
- }
-
- $tosend .= ".\015\012";
-
- local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
-
- $cmd->debug_print(1, ".\n")
- if ($cmd->debug);
-
- syswrite($cmd, $tosend, length $tosend);
-
- delete ${*$cmd}{'net_cmd_last_ch'};
-
- $cmd->response() == CMD_OK;
-}
-
-# read and write to tied filehandle
-sub tied_fh {
- my $cmd = shift;
- ${*$cmd}{'net_cmd_readbuf'} = '';
- my $fh = gensym();
- tie *$fh, ref($cmd), $cmd;
- return $fh;
-}
-
-# tie to myself
-sub TIEHANDLE {
- my $class = shift;
- my $cmd = shift;
- return $cmd;
-}
-
-# Tied filehandle read. Reads requested data length, returning
-# end-of-file when the dot is encountered.
-sub READ {
- my $cmd = shift;
- my ($len, $offset) = @_[1, 2];
- return unless exists ${*$cmd}{'net_cmd_readbuf'};
- my $done = 0;
- while (!$done and length(${*$cmd}{'net_cmd_readbuf'}) < $len) {
- ${*$cmd}{'net_cmd_readbuf'} .= $cmd->getline() or return;
- $done++ if ${*$cmd}{'net_cmd_readbuf'} =~ s/^\.\r?\n\Z//m;
- }
-
- $_[0] = '';
- substr($_[0], $offset + 0) = substr(${*$cmd}{'net_cmd_readbuf'}, 0, $len);
- substr(${*$cmd}{'net_cmd_readbuf'}, 0, $len) = '';
- delete ${*$cmd}{'net_cmd_readbuf'} if $done;
-
- return length $_[0];
-}
-
-
-sub READLINE {
- my $cmd = shift;
-
- # in this context, we use the presence of readbuf to
- # indicate that we have not yet reached the eof
- return unless exists ${*$cmd}{'net_cmd_readbuf'};
- my $line = $cmd->getline;
- return if $line =~ /^\.\r?\n/;
- $line;
-}
-
-
-sub PRINT {
- my $cmd = shift;
- my ($buf, $len, $offset) = @_;
- $len ||= length($buf);
- $offset += 0;
- return unless $cmd->datasend(substr($buf, $offset, $len));
- ${*$cmd}{'net_cmd_sending'}++; # flag that we should call dataend()
- return $len;
-}
-
-
-sub CLOSE {
- my $cmd = shift;
- my $r = exists(${*$cmd}{'net_cmd_sending'}) ? $cmd->dataend : 1;
- delete ${*$cmd}{'net_cmd_readbuf'};
- delete ${*$cmd}{'net_cmd_sending'};
- $r;
-}
-
-1;
-
-__END__
-
-
-=head1 NAME
-
-Net::Cmd - Network Command class (as used by FTP, SMTP etc)
-
-=head1 SYNOPSIS
-
- use Net::Cmd;
-
- @ISA = qw(Net::Cmd);
-
-=head1 DESCRIPTION
-
-C<Net::Cmd> is a collection of methods that can be inherited by a sub class
-of C<IO::Handle>. These methods implement the functionality required for a
-command based protocol, for example FTP and SMTP.
-
-=head1 USER METHODS
-
-These methods provide a user interface to the C<Net::Cmd> object.
-
-=over 4
-
-=item debug ( VALUE )
-
-Set the level of debug information for this object. If C<VALUE> is not given
-then the current state is returned. Otherwise the state is changed to
-C<VALUE> and the previous state returned.
-
-Different packages
-may implement different levels of debug but a non-zero value results in
-copies of all commands and responses also being sent to STDERR.
-
-If C<VALUE> is C<undef> then the debug level will be set to the default
-debug level for the class.
-
-This method can also be called as a I<static> method to set/get the default
-debug level for a given class.
-
-=item message ()
-
-Returns the text message returned from the last command. In a scalar
-context it returns a single string, in a list context it will return
-each line as a separate element
-
-=item code ()
-
-Returns the 3-digit code from the last command. If a command is pending
-then the value 0 is returned
-
-=item ok ()
-
-Returns non-zero if the last code value was greater than zero and
-less than 400. This holds true for most command servers. Servers
-where this does not hold may override this method.
-
-=item status ()
-
-Returns the most significant digit of the current status code. If a command
-is pending then C<CMD_PENDING> is returned.
-
-=item datasend ( DATA )
-
-Send data to the remote server, converting LF to CRLF. Any line starting
-with a '.' will be prefixed with another '.'.
-C<DATA> may be an array or a reference to an array.
-
-=item dataend ()
-
-End the sending of data to the remote server. This is done by ensuring that
-the data already sent ends with CRLF then sending '.CRLF' to end the
-transmission. Once this data has been sent C<dataend> calls C<response> and
-returns true if C<response> returns CMD_OK.
-
-=back
-
-=head1 CLASS METHODS
-
-These methods are not intended to be called by the user, but used or
-over-ridden by a sub-class of C<Net::Cmd>
-
-=over 4
-
-=item debug_print ( DIR, TEXT )
-
-Print debugging information. C<DIR> denotes the direction I<true> being
-data being sent to the server. Calls C<debug_text> before printing to
-STDERR.
-
-=item debug_text ( TEXT )
-
-This method is called to print debugging information. TEXT is
-the text being sent. The method should return the text to be printed
-
-This is primarily meant for the use of modules such as FTP where passwords
-are sent, but we do not want to display them in the debugging information.
-
-=item command ( CMD [, ARGS, ... ])
-
-Send a command to the command server. All arguments a first joined with
-a space character and CRLF is appended, this string is then sent to the
-command server.
-
-Returns undef upon failure
-
-=item unsupported ()
-
-Sets the status code to 580 and the response text to 'Unsupported command'.
-Returns zero.
-
-=item response ()
-
-Obtain a response from the server. Upon success the most significant digit
-of the status code is returned. Upon failure, timeout etc., I<undef> is
-returned.
-
-=item parse_response ( TEXT )
-
-This method is called by C<response> as a method with one argument. It should
-return an array of 2 values, the 3-digit status code and a flag which is true
-when this is part of a multi-line response and this line is not the list.
-
-=item getline ()
-
-Retrieve one line, delimited by CRLF, from the remote server. Returns I<undef>
-upon failure.
-
-B<NOTE>: If you do use this method for any reason, please remember to add
-some C<debug_print> calls into your method.
-
-=item ungetline ( TEXT )
-
-Unget a line of text from the server.
-
-=item rawdatasend ( DATA )
-
-Send data to the remote server without performing any conversions. C<DATA>
-is a scalar.
-
-=item read_until_dot ()
-
-Read data from the remote server until a line consisting of a single '.'.
-Any lines starting with '..' will have one of the '.'s removed.
-
-Returns a reference to a list containing the lines, or I<undef> upon failure.
-
-=item tied_fh ()
-
-Returns a filehandle tied to the Net::Cmd object. After issuing a
-command, you may read from this filehandle using read() or <>. The
-filehandle will return EOF when the final dot is encountered.
-Similarly, you may write to the filehandle in order to send data to
-the server after issuing a command that expects data to be written.
-
-See the Net::POP3 and Net::SMTP modules for examples of this.
-
-=back
-
-=head1 EXPORTS
-
-C<Net::Cmd> exports six subroutines, five of these, C<CMD_INFO>, C<CMD_OK>,
-C<CMD_MORE>, C<CMD_REJECT> and C<CMD_ERROR>, correspond to possible results
-of C<response> and C<status>. The sixth is C<CMD_PENDING>.
-
-=head1 AUTHOR
-
-Graham Barr <gbarr@pobox.com>
-
-=head1 COPYRIGHT
-
-Copyright (c) 1995-2006 Graham Barr. All rights reserved.
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=cut
@@ -1,312 +0,0 @@
-# Net::Config.pm
-#
-# Copyright (c) 2000 Graham Barr <gbarr@pobox.com>. All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-
-package Net::Config;
-
-require Exporter;
-use vars qw(@ISA @EXPORT %NetConfig $VERSION $CONFIGURE $LIBNET_CFG);
-use Socket qw(inet_aton inet_ntoa);
-use strict;
-
-@EXPORT = qw(%NetConfig);
-@ISA = qw(Net::LocalCfg Exporter);
-$VERSION = "1.14";
-
-eval { local $SIG{__DIE__}; require Net::LocalCfg };
-
-%NetConfig = (
- nntp_hosts => [],
- snpp_hosts => [],
- pop3_hosts => [],
- smtp_hosts => [],
- ph_hosts => [],
- daytime_hosts => [],
- time_hosts => [],
- inet_domain => undef,
- ftp_firewall => undef,
- ftp_ext_passive => 1,
- ftp_int_passive => 1,
- test_hosts => 1,
- test_exist => 1,
-);
-
-#
-# Try to get as much configuration info as possible from InternetConfig
-#
-$^O eq 'MacOS' and eval <<TRY_INTERNET_CONFIG;
-use Mac::InternetConfig;
-
-{
-my %nc = (
- nntp_hosts => [ \$InternetConfig{ kICNNTPHost() } ],
- pop3_hosts => [ \$InternetConfig{ kICMailAccount() } =~ /\@(.*)/ ],
- smtp_hosts => [ \$InternetConfig{ kICSMTPHost() } ],
- ftp_testhost => \$InternetConfig{ kICFTPHost() } ? \$InternetConfig{ kICFTPHost()} : undef,
- ph_hosts => [ \$InternetConfig{ kICPhHost() } ],
- ftp_ext_passive => \$InternetConfig{"646F676F\xA5UsePassiveMode"} || 0,
- ftp_int_passive => \$InternetConfig{"646F676F\xA5UsePassiveMode"} || 0,
- socks_hosts =>
- \$InternetConfig{ kICUseSocks() } ? [ \$InternetConfig{ kICSocksHost() } ] : [],
- ftp_firewall =>
- \$InternetConfig{ kICUseFTPProxy() } ? [ \$InternetConfig{ kICFTPProxyHost() } ] : [],
-);
-\@NetConfig{keys %nc} = values %nc;
-}
-TRY_INTERNET_CONFIG
-
-my $file = __FILE__;
-my $ref;
-$file =~ s/Config.pm/libnet.cfg/;
-if (-f $file) {
- $ref = eval { local $SIG{__DIE__}; do $file };
- if (ref($ref) eq 'HASH') {
- %NetConfig = (%NetConfig, %{$ref});
- $LIBNET_CFG = $file;
- }
-}
-if ($< == $> and !$CONFIGURE) {
- my $home = eval { local $SIG{__DIE__}; (getpwuid($>))[7] } || $ENV{HOME};
- $home ||= $ENV{HOMEDRIVE} . ($ENV{HOMEPATH} || '') if defined $ENV{HOMEDRIVE};
- if (defined $home) {
- $file = $home . "/.libnetrc";
- $ref = eval { local $SIG{__DIE__}; do $file } if -f $file;
- %NetConfig = (%NetConfig, %{$ref})
- if ref($ref) eq 'HASH';
- }
-}
-my ($k, $v);
-while (($k, $v) = each %NetConfig) {
- $NetConfig{$k} = [$v]
- if ($k =~ /_hosts$/ and $k ne "test_hosts" and defined($v) and !ref($v));
-}
-
-# Take a hostname and determine if it is inside the firewall
-
-
-sub requires_firewall {
- shift; # ignore package
- my $host = shift;
-
- return 0 unless defined $NetConfig{'ftp_firewall'};
-
- $host = inet_aton($host) or return -1;
- $host = inet_ntoa($host);
-
- if (exists $NetConfig{'local_netmask'}) {
- my $quad = unpack("N", pack("C*", split(/\./, $host)));
- my $list = $NetConfig{'local_netmask'};
- $list = [$list] unless ref($list);
- foreach (@$list) {
- my ($net, $bits) = (m#^(\d+\.\d+\.\d+\.\d+)/(\d+)$#) or next;
- my $mask = ~0 << (32 - $bits);
- my $addr = unpack("N", pack("C*", split(/\./, $net)));
-
- return 0 if (($addr & $mask) == ($quad & $mask));
- }
- return 1;
- }
-
- return 0;
-}
-
-use vars qw(*is_external);
-*is_external = \&requires_firewall;
-
-1;
-
-__END__
-
-=head1 NAME
-
-Net::Config - Local configuration data for libnet
-
-=head1 SYNOPSYS
-
- use Net::Config qw(%NetConfig);
-
-=head1 DESCRIPTION
-
-C<Net::Config> holds configuration data for the modules in the libnet
-distribution. During installation you will be asked for these values.
-
-The configuration data is held globally in a file in the perl installation
-tree, but a user may override any of these values by providing their own. This
-can be done by having a C<.libnetrc> file in their home directory. This file
-should return a reference to a HASH containing the keys described below.
-For example
-
- # .libnetrc
- {
- nntp_hosts => [ "my_preferred_host" ],
- ph_hosts => [ "my_ph_server" ],
- }
- __END__
-
-=head1 METHODS
-
-C<Net::Config> defines the following methods. They are methods as they are
-invoked as class methods. This is because C<Net::Config> inherits from
-C<Net::LocalCfg> so you can override these methods if you want.
-
-=over 4
-
-=item requires_firewall HOST
-
-Attempts to determine if a given host is outside your firewall. Possible
-return values are.
-
- -1 Cannot lookup hostname
- 0 Host is inside firewall (or there is no ftp_firewall entry)
- 1 Host is outside the firewall
-
-This is done by using hostname lookup and the C<local_netmask> entry in
-the configuration data.
-
-=back
-
-=head1 NetConfig VALUES
-
-=over 4
-
-=item nntp_hosts
-
-=item snpp_hosts
-
-=item pop3_hosts
-
-=item smtp_hosts
-
-=item ph_hosts
-
-=item daytime_hosts
-
-=item time_hosts
-
-Each is a reference to an array of hostnames (in order of preference),
-which should be used for the given protocol
-
-=item inet_domain
-
-Your internet domain name
-
-=item ftp_firewall
-
-If you have an FTP proxy firewall (B<NOT> an HTTP or SOCKS firewall)
-then this value should be set to the firewall hostname. If your firewall
-does not listen to port 21, then this value should be set to
-C<"hostname:port"> (eg C<"hostname:99">)
-
-=item ftp_firewall_type
-
-There are many different ftp firewall products available. But unfortunately
-there is no standard for how to traverse a firewall. The list below shows the
-sequence of commands that Net::FTP will use
-
- user Username for remote host
- pass Password for remote host
- fwuser Username for firewall
- fwpass Password for firewall
- remote.host The hostname of the remote ftp server
-
-=over 4
-
-=item 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
-
-=cut
@@ -1,354 +0,0 @@
-# Net::Domain.pm
-#
-# Copyright (c) 1995-1998 Graham Barr <gbarr@pobox.com>. All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-
-package Net::Domain;
-
-require Exporter;
-
-use Carp;
-use strict;
-use vars qw($VERSION @ISA @EXPORT_OK);
-use Net::Config;
-
-@ISA = qw(Exporter);
-@EXPORT_OK = qw(hostname hostdomain hostfqdn domainname);
-
-$VERSION = "2.23";
-
-my ($host, $domain, $fqdn) = (undef, undef, undef);
-
-# Try every conceivable way to get hostname.
-
-
-sub _hostname {
-
- # we already know it
- return $host
- if (defined $host);
-
- if ($^O eq 'MSWin32') {
- require Socket;
- my ($name, $alias, $type, $len, @addr) = gethostbyname($ENV{'COMPUTERNAME'} || 'localhost');
- while (@addr) {
- my $a = shift(@addr);
- $host = gethostbyaddr($a, Socket::AF_INET());
- last if defined $host;
- }
- if (defined($host) && index($host, '.') > 0) {
- $fqdn = $host;
- ($host, $domain) = $fqdn =~ /^([^\.]+)\.(.*)$/;
- }
- return $host;
- }
- elsif ($^O eq 'MacOS') {
- chomp($host = `hostname`);
- }
- elsif ($^O eq 'VMS') { ## multiple varieties of net s/w makes this hard
- $host = $ENV{'UCX$INET_HOST'} if defined($ENV{'UCX$INET_HOST'});
- $host = $ENV{'MULTINET_HOST_NAME'} if defined($ENV{'MULTINET_HOST_NAME'});
- if (index($host, '.') > 0) {
- $fqdn = $host;
- ($host, $domain) = $fqdn =~ /^([^\.]+)\.(.*)$/;
- }
- return $host;
- }
- else {
- local $SIG{'__DIE__'};
-
- # syscall is preferred since it avoids tainting problems
- eval {
- my $tmp = "\0" x 256; ## preload scalar
- eval {
- package main;
- require "syscall.ph";
- defined(&main::SYS_gethostname);
- }
- || eval {
- package main;
- require "sys/syscall.ph";
- defined(&main::SYS_gethostname);
- }
- and $host =
- (syscall(&main::SYS_gethostname, $tmp, 256) == 0)
- ? $tmp
- : undef;
- }
-
- # POSIX
- || eval {
- require POSIX;
- $host = (POSIX::uname())[1];
- }
-
- # trusty old hostname command
- || eval {
- chop($host = `(hostname) 2>/dev/null`); # BSD'ish
- }
-
- # sysV/POSIX uname command (may truncate)
- || eval {
- chop($host = `uname -n 2>/dev/null`); ## SYSV'ish && POSIX'ish
- }
-
- # Apollo pre-SR10
- || eval { $host = (split(/[:\. ]/, `/com/host`, 6))[0]; }
-
- || eval { $host = ""; };
- }
-
- # remove garbage
- $host =~ s/[\0\r\n]+//go;
- $host =~ s/(\A\.+|\.+\Z)//go;
- $host =~ s/\.\.+/\./go;
-
- $host;
-}
-
-
-sub _hostdomain {
-
- # we already know it
- return $domain
- if (defined $domain);
-
- local $SIG{'__DIE__'};
-
- return $domain = $NetConfig{'inet_domain'}
- if defined $NetConfig{'inet_domain'};
-
- # try looking in /etc/resolv.conf
- # putting this here and assuming that it is correct, eliminates
- # calls to gethostbyname, and therefore DNS lookups. This helps
- # those on dialup systems.
-
- local *RES;
- local ($_);
-
- if (open(RES, "/etc/resolv.conf")) {
- while (<RES>) {
- $domain = $1
- if (/\A\s*(?:domain|search)\s+(\S+)/);
- }
- close(RES);
-
- return $domain
- if (defined $domain);
- }
-
- # just try hostname and system calls
-
- my $host = _hostname();
- my (@hosts);
-
- @hosts = ($host, "localhost");
-
- unless (defined($host) && $host =~ /\./) {
- my $dom = undef;
- eval {
- my $tmp = "\0" x 256; ## preload scalar
- eval {
- package main;
- require "syscall.ph";
- }
- || eval {
- package main;
- require "sys/syscall.ph";
- }
- and $dom =
- (syscall(&main::SYS_getdomainname, $tmp, 256) == 0)
- ? $tmp
- : undef;
- };
-
- if ($^O eq 'VMS') {
- $dom ||= $ENV{'TCPIP$INET_DOMAIN'}
- || $ENV{'UCX$INET_DOMAIN'};
- }
-
- chop($dom = `domainname 2>/dev/null`)
- unless (defined $dom || $^O =~ /^(?:cygwin|MSWin32|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
- my $site;
- foreach $site ($info[0], split(/ /, $info[1])) {
- if (rindex($site, ".") > 0) {
-
- # Extract domain from FQDN
-
- ($domain = $site) =~ s/\A[^\.]+\.//;
- return $domain;
- }
- }
- }
-
- # Look for environment variable
-
- $domain ||= $ENV{LOCALDOMAIN} || $ENV{DOMAIN};
-
- if (defined $domain) {
- $domain =~ s/[\r\n\0]+//g;
- $domain =~ s/(\A\.+|\.+\Z)//g;
- $domain =~ s/\.\.+/\./g;
- }
-
- $domain;
-}
-
-
-sub domainname {
-
- return $fqdn
- if (defined $fqdn);
-
- _hostname();
-
- # *.local names are special on darwin. If we call gethostbyname below, it
- # may hang while waiting for another, non-existent computer to respond.
- if($^O eq 'darwin' && $host =~ /\.local$/) {
- return $host;
- }
-
- _hostdomain();
-
- # Assumption: If the host name does not contain a period
- # and the domain name does, then assume that they are correct
- # this helps to eliminate calls to gethostbyname, and therefore
- # eliminate DNS lookups
-
- return $fqdn = $host . "." . $domain
- if (defined $host
- and defined $domain
- and $host !~ /\./
- and $domain =~ /\./);
-
- # For hosts that have no name, just an IP address
- return $fqdn = $host if defined $host and $host =~ /^\d+(\.\d+){3}$/;
-
- my @host = defined $host ? split(/\./, $host) : ('localhost');
- my @domain = defined $domain ? split(/\./, $domain) : ();
- my @fqdn = ();
-
- # Determine from @host & @domain the FQDN
-
- my @d = @domain;
-
-LOOP:
- while (1) {
- my @h = @host;
- while (@h) {
- my $tmp = join(".", @h, @d);
- if ((gethostbyname($tmp))[0]) {
- @fqdn = (@h, @d);
- $fqdn = $tmp;
- last LOOP;
- }
- pop @h;
- }
- last unless shift @d;
- }
-
- if (@fqdn) {
- $host = shift @fqdn;
- until ((gethostbyname($host))[0]) {
- $host .= "." . shift @fqdn;
- }
- $domain = join(".", @fqdn);
- }
- else {
- undef $host;
- undef $domain;
- undef $fqdn;
- }
-
- $fqdn;
-}
-
-
-sub hostfqdn { domainname() }
-
-
-sub hostname {
- domainname()
- unless (defined $host);
- return $host;
-}
-
-
-sub hostdomain {
- domainname()
- unless (defined $domain);
- return $domain;
-}
-
-1; # Keep require happy
-
-__END__
-
-=head1 NAME
-
-Net::Domain - Attempt to evaluate the current host's internet name and domain
-
-=head1 SYNOPSIS
-
- use Net::Domain qw(hostname hostfqdn hostdomain domainname);
-
-=head1 DESCRIPTION
-
-Using various methods B<attempt> to find the Fully Qualified Domain Name (FQDN)
-of the current host. From this determine the host-name and the host-domain.
-
-Each of the functions will return I<undef> if the FQDN cannot be determined.
-
-=over 4
-
-=item hostfqdn ()
-
-Identify and return the FQDN of the current host.
-
-=item domainname ()
-
-An alias for hostfqdn ().
-
-=item hostname ()
-
-Returns the smallest part of the FQDN which can be used to identify the host.
-
-=item hostdomain ()
-
-Returns the remainder of the FQDN after the I<hostname> has been removed.
-
-=back
-
-=head1 AUTHOR
-
-Graham Barr <gbarr@pobox.com>.
-Adapted from Sys::Hostname by David Sundstrom <sunds@asictest.sc.ti.com>
-
-=head1 COPYRIGHT
-
-Copyright (c) 1995-1998 Graham Barr. All rights reserved.
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=cut
@@ -1,111 +0,0 @@
-##
-## Package to read/write on ASCII data connections
-##
-
-package Net::FTP::A;
-use strict;
-use vars qw(@ISA $buf $VERSION);
-use Carp;
-
-require Net::FTP::dataconn;
-
-@ISA = qw(Net::FTP::dataconn);
-$VERSION = "1.19";
-
-
-sub read {
- my $data = shift;
- local *buf = \$_[0];
- shift;
- my $size = shift || croak 'read($buf,$size,[$offset])';
- my $timeout = @_ ? shift: $data->timeout;
-
- if (length(${*$data}) < $size && !${*$data}{'net_ftp_eof'}) {
- my $blksize = ${*$data}{'net_ftp_blksize'};
- $blksize = $size if $size > $blksize;
-
- my $l = 0;
- my $n;
-
- READ:
- {
- my $readbuf = defined(${*$data}{'net_ftp_cr'}) ? "\015" : '';
-
- $data->can_read($timeout)
- or croak "Timeout";
-
- if ($n = sysread($data, $readbuf, $blksize, length $readbuf)) {
- ${*$data}{'net_ftp_bytesread'} += $n;
- ${*$data}{'net_ftp_cr'} =
- substr($readbuf, -1) eq "\015"
- ? chop($readbuf)
- : undef;
- }
- else {
- return undef
- unless defined $n;
-
- ${*$data}{'net_ftp_eof'} = 1;
- }
-
- $readbuf =~ s/\015\012/\n/sgo;
- ${*$data} .= $readbuf;
-
- unless (length(${*$data})) {
-
- redo READ
- if ($n > 0);
-
- $size = length(${*$data})
- if ($n == 0);
- }
- }
- }
-
- $buf = substr(${*$data}, 0, $size);
- substr(${*$data}, 0, $size) = '';
-
- length $buf;
-}
-
-
-sub write {
- my $data = shift;
- local *buf = \$_[0];
- shift;
- my $size = shift || croak 'write($buf,$size,[$timeout])';
- my $timeout = @_ ? shift: $data->timeout;
-
- my $nr = (my $tmp = substr($buf, 0, $size)) =~ tr/\r\n/\015\012/;
- $tmp =~ s/(?<!\015)\012/\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 undef
- unless defined($wrote);
- $len -= $wrote;
- }
-
- $size;
-}
-
-1;
@@ -1,8 +0,0 @@
-package Net::FTP::E;
-
-require Net::FTP::I;
-
-@ISA = qw(Net::FTP::I);
-$VERSION = "0.01";
-
-1;
@@ -1,80 +0,0 @@
-##
-## Package to read/write on BINARY data connections
-##
-
-package Net::FTP::I;
-
-use vars qw(@ISA $buf $VERSION);
-use Carp;
-
-require Net::FTP::dataconn;
-
-@ISA = qw(Net::FTP::dataconn);
-$VERSION = "1.12";
-
-
-sub read {
- my $data = shift;
- local *buf = \$_[0];
- shift;
- my $size = shift || croak 'read($buf,$size,[$timeout])';
- my $timeout = @_ ? shift: $data->timeout;
-
- my $n;
-
- if ($size > length ${*$data} and !${*$data}{'net_ftp_eof'}) {
- $data->can_read($timeout)
- or croak "Timeout";
-
- my $blksize = ${*$data}{'net_ftp_blksize'};
- $blksize = $size if $size > $blksize;
-
- unless ($n = sysread($data, ${*$data}, $blksize, length ${*$data})) {
- return undef unless defined $n;
- ${*$data}{'net_ftp_eof'} = 1;
- }
- }
-
- $buf = substr(${*$data}, 0, $size);
-
- $n = length($buf);
-
- substr(${*$data}, 0, $n) = '';
-
- ${*$data}{'net_ftp_bytesread'} += $n;
-
- $n;
-}
-
-
-sub write {
- my $data = shift;
- local *buf = \$_[0];
- shift;
- my $size = shift || croak 'write($buf,$size,[$timeout])';
- my $timeout = @_ ? shift: $data->timeout;
-
- # If the remote server has closed the connection we will be signal'd
- # when we write. This can happen if the disk on the remote server fills up
-
- local $SIG{PIPE} = 'IGNORE'
- unless ($SIG{PIPE} || '') eq 'IGNORE'
- or $^O eq 'MacOS';
- my $sent = $size;
- my $off = 0;
-
- my $blksize = ${*$data}{'net_ftp_blksize'};
- while ($sent > 0) {
- $data->can_write($timeout)
- or croak "Timeout";
-
- my $n = syswrite($data, $buf, $sent > $blksize ? $blksize : $sent, $off);
- return undef unless defined($n);
- $sent -= $n;
- $off += $n;
- }
-
- $size;
-}
-
-1;
@@ -1,8 +0,0 @@
-package Net::FTP::L;
-
-require Net::FTP::I;
-
-@ISA = qw(Net::FTP::I);
-$VERSION = "0.01";
-
-1;
@@ -1,127 +0,0 @@
-##
-## Generic data connection package
-##
-
-package Net::FTP::dataconn;
-
-use Carp;
-use vars qw(@ISA $timeout $VERSION);
-use Net::Cmd;
-use Errno;
-
-$VERSION = '0.12';
-@ISA = qw(IO::Socket::INET);
-
-
-sub reading {
- my $data = shift;
- ${*$data}{'net_ftp_bytesread'} = 0;
-}
-
-
-sub abort {
- my $data = shift;
- my $ftp = ${*$data}{'net_ftp_cmd'};
-
- # no need to abort if we have finished the xfer
- return $data->close
- if ${*$data}{'net_ftp_eof'};
-
- # for some reason if we 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;
@@ -1,1861 +0,0 @@
-# Net::FTP.pm
-#
-# Copyright (c) 1995-2004 Graham Barr <gbarr@pobox.com>. All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-#
-# Documentation (at end) improved 1996 by Nathan Torkington <gnat@frii.com>.
-
-package Net::FTP;
-
-require 5.001;
-
-use strict;
-use vars qw(@ISA $VERSION);
-use Carp;
-
-use Socket 1.3;
-use IO::Socket;
-use Time::Local;
-use Net::Cmd;
-use Net::Config;
-use Fcntl qw(O_WRONLY O_RDONLY O_APPEND O_CREAT O_TRUNC);
-
-$VERSION = '2.79';
-@ISA = qw(Exporter Net::Cmd IO::Socket::INET);
-
-# Someday I will "use constant", when I am not bothered to much about
-# compatibility with older releases of perl
-
-use vars qw($TELNET_IAC $TELNET_IP $TELNET_DM);
-($TELNET_IAC, $TELNET_IP, $TELNET_DM) = (255, 244, 242);
-
-
-BEGIN {
-
- # make a constant so code is fast'ish
- my $is_os390 = $^O eq 'os390';
- *trEBCDIC = sub () {$is_os390}
-}
-
-
-sub new {
- my $pkg = shift;
- my ($peer, %arg);
- if (@_ % 2) {
- $peer = shift;
- %arg = @_;
- }
- else {
- %arg = @_;
- $peer = delete $arg{Host};
- }
-
- my $host = $peer;
- my $fire = undef;
- my $fire_type = undef;
-
- if (exists($arg{Firewall}) || Net::Config->requires_firewall($peer)) {
- $fire = $arg{Firewall}
- || $ENV{FTP_FIREWALL}
- || $NetConfig{ftp_firewall}
- || undef;
-
- if (defined $fire) {
- $peer = $fire;
- delete $arg{Port};
- $fire_type = $arg{FirewallType}
- || $ENV{FTP_FIREWALL_TYPE}
- || $NetConfig{firewall_type}
- || undef;
- }
- }
-
- my $ftp = $pkg->SUPER::new(
- PeerAddr => $peer,
- PeerPort => $arg{Port} || 'ftp(21)',
- LocalAddr => $arg{'LocalAddr'},
- Proto => 'tcp',
- Timeout => defined $arg{Timeout}
- ? $arg{Timeout}
- : 120
- )
- or return undef;
-
- ${*$ftp}{'net_ftp_host'} = $host; # Remote hostname
- ${*$ftp}{'net_ftp_type'} = 'A'; # ASCII/binary/etc mode
- ${*$ftp}{'net_ftp_blksize'} = abs($arg{'BlockSize'} || 10240);
-
- ${*$ftp}{'net_ftp_localaddr'} = $arg{'LocalAddr'};
-
- ${*$ftp}{'net_ftp_firewall'} = $fire
- if (defined $fire);
- ${*$ftp}{'net_ftp_firewall_type'} = $fire_type
- if (defined $fire_type);
-
- ${*$ftp}{'net_ftp_passive'} =
- int exists $arg{Passive} ? $arg{Passive}
- : exists $ENV{FTP_PASSIVE} ? $ENV{FTP_PASSIVE}
- : defined $fire ? $NetConfig{ftp_ext_passive}
- : $NetConfig{ftp_int_passive}; # Whew! :-)
-
- $ftp->hash(exists $arg{Hash} ? $arg{Hash} : 0, 1024);
-
- $ftp->autoflush(1);
-
- $ftp->debug(exists $arg{Debug} ? $arg{Debug} : undef);
-
- unless ($ftp->response() == CMD_OK) {
- $ftp->close();
- # keep @$ if no message. Happens, when response did not start with a code.
- $@ = $ftp->message || $@;
- undef $ftp;
- }
-
- $ftp;
-}
-
-##
-## User interface methods
-##
-
-
-sub host {
- my $me = shift;
- ${*$me}{'net_ftp_host'};
-}
-
-sub passive {
- my $ftp = shift;
- return ${*$ftp}{'net_ftp_passive'} unless @_;
- ${*$ftp}{'net_ftp_passive'} = shift;
-}
-
-
-sub hash {
- my $ftp = shift; # self
-
- my ($h, $b) = @_;
- unless ($h) {
- delete ${*$ftp}{'net_ftp_hash'};
- return [\*STDERR, 0];
- }
- ($h, $b) = (ref($h) ? $h : \*STDERR, $b || 1024);
- select((select($h), $| = 1)[0]);
- $b = 512 if $b < 512;
- ${*$ftp}{'net_ftp_hash'} = [$h, $b];
-}
-
-
-sub quit {
- my $ftp = shift;
-
- $ftp->_QUIT;
- $ftp->close;
-}
-
-
-sub DESTROY { }
-
-
-sub ascii { shift->type('A', @_); }
-sub binary { shift->type('I', @_); }
-
-
-sub ebcdic {
- carp "TYPE E is unsupported, shall default to I";
- shift->type('E', @_);
-}
-
-
-sub byte {
- carp "TYPE L is unsupported, shall default to I";
- shift->type('L', @_);
-}
-
-# Allow the user to send a command directly, BE CAREFUL !!
-
-
-sub quot {
- my $ftp = shift;
- my $cmd = shift;
-
- $ftp->command(uc $cmd, @_);
- $ftp->response();
-}
-
-
-sub site {
- my $ftp = shift;
-
- $ftp->command("SITE", @_);
- $ftp->response();
-}
-
-
-sub mdtm {
- my $ftp = shift;
- my $file = shift;
-
- # Server Y2K bug workaround
- #
- # sigh; some idiotic FTP servers use ("19%d",tm.tm_year) instead of
- # ("%d",tm.tm_year+1900). This results in an extra digit in the
- # string returned. To account for this we allow an optional extra
- # digit in the year. Then if the first two digits are 19 we use the
- # remainder, otherwise we subtract 1900 from the whole year.
-
- $ftp->_MDTM($file)
- && $ftp->message =~ /((\d\d)(\d\d\d?))(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/
- ? timegm($8, $7, $6, $5, $4 - 1, $2 eq '19' ? $3 : ($1 - 1900))
- : undef;
-}
-
-
-sub size {
- my $ftp = shift;
- my $file = shift;
- my $io;
- if ($ftp->supported("SIZE")) {
- return $ftp->_SIZE($file)
- ? ($ftp->message =~ /(\d+)\s*(bytes?\s*)?$/)[0]
- : undef;
- }
- elsif ($ftp->supported("STAT")) {
- my @msg;
- return undef
- unless $ftp->_STAT($file) && (@msg = $ftp->message) == 3;
- my $line;
- foreach $line (@msg) {
- return (split(/\s+/, $line))[4]
- if $line =~ /^[-rwxSsTt]{10}/;
- }
- }
- else {
- my @files = $ftp->dir($file);
- if (@files) {
- return (split(/\s+/, $1))[4]
- if $files[0] =~ /^([-rwxSsTt]{10}.*)$/;
- }
- }
- undef;
-}
-
-
-sub login {
- my ($ftp, $user, $pass, $acct) = @_;
- my ($ok, $ruser, $fwtype);
-
- unless (defined $user) {
- require Net::Netrc;
-
- my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_host'});
-
- ($user, $pass, $acct) = $rc->lpa()
- if ($rc);
- }
-
- $user ||= "anonymous";
- $ruser = $user;
-
- $fwtype = ${*$ftp}{'net_ftp_firewall_type'}
- || $NetConfig{'ftp_firewall_type'}
- || 0;
-
- if ($fwtype && defined ${*$ftp}{'net_ftp_firewall'}) {
- if ($fwtype == 1 || $fwtype == 7) {
- $user .= '@' . ${*$ftp}{'net_ftp_host'};
- }
- else {
- require Net::Netrc;
-
- my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'});
-
- my ($fwuser, $fwpass, $fwacct) = $rc ? $rc->lpa() : ();
-
- if ($fwtype == 5) {
- $user = join('@', $user, $fwuser, ${*$ftp}{'net_ftp_host'});
- $pass = $pass . '@' . $fwpass;
- }
- else {
- if ($fwtype == 2) {
- $user .= '@' . ${*$ftp}{'net_ftp_host'};
- }
- elsif ($fwtype == 6) {
- $fwuser .= '@' . ${*$ftp}{'net_ftp_host'};
- }
-
- $ok = $ftp->_USER($fwuser);
-
- return 0 unless $ok == CMD_OK || $ok == CMD_MORE;
-
- $ok = $ftp->_PASS($fwpass || "");
-
- return 0 unless $ok == CMD_OK || $ok == CMD_MORE;
-
- $ok = $ftp->_ACCT($fwacct)
- if defined($fwacct);
-
- if ($fwtype == 3) {
- $ok = $ftp->command("SITE", ${*$ftp}{'net_ftp_host'})->response;
- }
- elsif ($fwtype == 4) {
- $ok = $ftp->command("OPEN", ${*$ftp}{'net_ftp_host'})->response;
- }
-
- return 0 unless $ok == CMD_OK || $ok == CMD_MORE;
- }
- }
- }
-
- $ok = $ftp->_USER($user);
-
- # Some dumb firewalls don't prefix the connection messages
- $ok = $ftp->response()
- if ($ok == CMD_OK && $ftp->code == 220 && $user =~ /\@/);
-
- if ($ok == CMD_MORE) {
- unless (defined $pass) {
- require Net::Netrc;
-
- my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_host'}, $ruser);
-
- ($ruser, $pass, $acct) = $rc->lpa()
- if ($rc);
-
- $pass = '-anonymous@'
- if (!defined $pass && (!defined($ruser) || $ruser =~ /^anonymous/o));
- }
-
- $ok = $ftp->_PASS($pass || "");
- }
-
- $ok = $ftp->_ACCT($acct)
- if (defined($acct) && ($ok == CMD_MORE || $ok == CMD_OK));
-
- if ($fwtype == 7 && $ok == CMD_OK && defined ${*$ftp}{'net_ftp_firewall'}) {
- my ($f, $auth, $resp) = _auth_id($ftp);
- $ftp->authorize($auth, $resp) if defined($resp);
- }
-
- $ok == CMD_OK;
-}
-
-
-sub account {
- @_ == 2 or croak 'usage: $ftp->account( ACCT )';
- my $ftp = shift;
- my $acct = shift;
- $ftp->_ACCT($acct) == CMD_OK;
-}
-
-
-sub _auth_id {
- my ($ftp, $auth, $resp) = @_;
-
- unless (defined $resp) {
- require Net::Netrc;
-
- $auth ||= eval { (getpwuid($>))[0] } || $ENV{NAME};
-
- my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'}, $auth)
- || Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'});
-
- ($auth, $resp) = $rc->lpa()
- if ($rc);
- }
- ($ftp, $auth, $resp);
-}
-
-
-sub authorize {
- @_ >= 1 || @_ <= 3 or croak 'usage: $ftp->authorize( [AUTH [, RESP]])';
-
- my ($ftp, $auth, $resp) = &_auth_id;
-
- my $ok = $ftp->_AUTH($auth || "");
-
- $ok = $ftp->_RESP($resp || "")
- if ($ok == CMD_MORE);
-
- $ok == CMD_OK;
-}
-
-
-sub rename {
- @_ == 3 or croak 'usage: $ftp->rename(FROM, TO)';
-
- my ($ftp, $from, $to) = @_;
-
- $ftp->_RNFR($from)
- && $ftp->_RNTO($to);
-}
-
-
-sub type {
- my $ftp = shift;
- my $type = shift;
- my $oldval = ${*$ftp}{'net_ftp_type'};
-
- return $oldval
- unless (defined $type);
-
- return undef
- unless ($ftp->_TYPE($type, @_));
-
- ${*$ftp}{'net_ftp_type'} = join(" ", $type, @_);
-
- $oldval;
-}
-
-
-sub alloc {
- my $ftp = shift;
- my $size = shift;
- my $oldval = ${*$ftp}{'net_ftp_allo'};
-
- return $oldval
- unless (defined $size);
-
- return undef
- unless ($ftp->_ALLO($size, @_));
-
- ${*$ftp}{'net_ftp_allo'} = join(" ", $size, @_);
-
- $oldval;
-}
-
-
-sub abort {
- my $ftp = shift;
-
- send($ftp, pack("CCC", $TELNET_IAC, $TELNET_IP, $TELNET_IAC), MSG_OOB);
-
- $ftp->command(pack("C", $TELNET_DM) . "ABOR");
-
- ${*$ftp}{'net_ftp_dataconn'}->close()
- if defined ${*$ftp}{'net_ftp_dataconn'};
-
- $ftp->response();
-
- $ftp->status == CMD_OK;
-}
-
-
-sub get {
- my ($ftp, $remote, $local, $where) = @_;
-
- my ($loc, $len, $buf, $resp, $data);
- local *FD;
-
- my $localfd = ref($local) || ref(\$local) eq "GLOB";
-
- ($local = $remote) =~ s#^.*/##
- unless (defined $local);
-
- croak("Bad remote filename '$remote'\n")
- if $remote =~ /[\r\n]/s;
-
- ${*$ftp}{'net_ftp_rest'} = $where if defined $where;
- my $rest = ${*$ftp}{'net_ftp_rest'};
-
- delete ${*$ftp}{'net_ftp_port'};
- delete ${*$ftp}{'net_ftp_pasv'};
-
- $data = $ftp->retr($remote)
- or return undef;
-
- if ($localfd) {
- $loc = $local;
- }
- else {
- $loc = \*FD;
-
- unless (sysopen($loc, $local, O_CREAT | O_WRONLY | ($rest ? O_APPEND: O_TRUNC))) {
- carp "Cannot open Local file $local: $!\n";
- $data->abort;
- return undef;
- }
- }
-
- if ($ftp->type eq 'I' && !binmode($loc)) {
- carp "Cannot binmode Local file $local: $!\n";
- $data->abort;
- close($loc) unless $localfd;
- return undef;
- }
-
- $buf = '';
- my ($count, $hashh, $hashb, $ref) = (0);
-
- ($hashh, $hashb) = @$ref
- if ($ref = ${*$ftp}{'net_ftp_hash'});
-
- my $blksize = ${*$ftp}{'net_ftp_blksize'};
- local $\; # Just in case
-
- while (1) {
- last unless $len = $data->read($buf, $blksize);
-
- if (trEBCDIC && $ftp->type ne 'I') {
- $buf = $ftp->toebcdic($buf);
- $len = length($buf);
- }
-
- if ($hashh) {
- $count += $len;
- print $hashh "#" x (int($count / $hashb));
- $count %= $hashb;
- }
- unless (print $loc $buf) {
- carp "Cannot write to Local file $local: $!\n";
- $data->abort;
- close($loc)
- unless $localfd;
- return undef;
- }
- }
-
- print $hashh "\n" if $hashh;
-
- unless ($localfd) {
- unless (close($loc)) {
- carp "Cannot close file $local (perhaps disk space) $!\n";
- return undef;
- }
- }
-
- unless ($data->close()) # implied $ftp->response
- {
- carp "Unable to close datastream";
- return undef;
- }
-
- return $local;
-}
-
-
-sub cwd {
- @_ == 1 || @_ == 2 or croak 'usage: $ftp->cwd( [ DIR ] )';
-
- my ($ftp, $dir) = @_;
-
- $dir = "/" unless defined($dir) && $dir =~ /\S/;
-
- $dir eq ".."
- ? $ftp->_CDUP()
- : $ftp->_CWD($dir);
-}
-
-
-sub cdup {
- @_ == 1 or croak 'usage: $ftp->cdup()';
- $_[0]->_CDUP;
-}
-
-
-sub pwd {
- @_ == 1 || croak 'usage: $ftp->pwd()';
- my $ftp = shift;
-
- $ftp->_PWD();
- $ftp->_extract_path;
-}
-
-# rmdir( $ftp, $dir, [ $recurse ] )
-#
-# Removes $dir on remote host via FTP.
-# $ftp is handle for remote host
-#
-# If $recurse is TRUE, the directory and deleted recursively.
-# This means all of its contents and subdirectories.
-#
-# Initial version contributed by Dinkum Software
-#
-sub rmdir {
- @_ == 2 || @_ == 3 or croak('usage: $ftp->rmdir( DIR [, RECURSE ] )');
-
- # Pick off the args
- my ($ftp, $dir, $recurse) = @_;
- my $ok;
-
- return $ok
- if $ok = $ftp->_RMD($dir)
- or !$recurse;
-
- # Try to delete the contents
- # Get a list of all the files in the directory
- my @filelist = grep { !/^\.{1,2}$/ } $ftp->ls($dir);
-
- return undef
- unless @filelist; # failed, it is probably not a directory
-
- return $ftp->delete($dir)
- if @filelist == 1 and $dir eq $filelist[0];
-
- # Go thru and delete each file or the directory
- my $file;
- foreach $file (map { m,/, ? $_ : "$dir/$_" } @filelist) {
- next # successfully deleted the file
- if $ftp->delete($file);
-
- # Failed to delete it, assume its a directory
- # Recurse and ignore errors, the final rmdir() will
- # fail on any errors here
- return $ok
- unless $ok = $ftp->rmdir($file, 1);
- }
-
- # Directory should be empty
- # Try to remove the directory again
- # Pass results directly to caller
- # If any of the prior deletes failed, this
- # rmdir() will fail because directory is not empty
- return $ftp->_RMD($dir);
-}
-
-
-sub restart {
- @_ == 2 || croak 'usage: $ftp->restart( BYTE_OFFSET )';
-
- my ($ftp, $where) = @_;
-
- ${*$ftp}{'net_ftp_rest'} = $where;
-
- return undef;
-}
-
-
-sub mkdir {
- @_ == 2 || @_ == 3 or croak 'usage: $ftp->mkdir( DIR [, RECURSE ] )';
-
- my ($ftp, $dir, $recurse) = @_;
-
- $ftp->_MKD($dir) || $recurse
- or return undef;
-
- my $path = $dir;
-
- unless ($ftp->ok) {
- my @path = split(m#(?=/+)#, $dir);
-
- $path = "";
-
- while (@path) {
- $path .= shift @path;
-
- $ftp->_MKD($path);
-
- $path = $ftp->_extract_path($path);
- }
-
- # If the creation of the last element was not successful, see if we
- # can cd to it, if so then return path
-
- unless ($ftp->ok) {
- my ($status, $message) = ($ftp->status, $ftp->message);
- my $pwd = $ftp->pwd;
-
- if ($pwd && $ftp->cwd($dir)) {
- $path = $dir;
- $ftp->cwd($pwd);
- }
- else {
- undef $path;
- }
- $ftp->set_status($status, $message);
- }
- }
-
- $path;
-}
-
-
-sub delete {
- @_ == 2 || croak 'usage: $ftp->delete( FILENAME )';
-
- $_[0]->_DELE($_[1]);
-}
-
-
-sub put { shift->_store_cmd("stor", @_) }
-sub put_unique { shift->_store_cmd("stou", @_) }
-sub append { shift->_store_cmd("appe", @_) }
-
-
-sub nlst { shift->_data_cmd("NLST", @_) }
-sub list { shift->_data_cmd("LIST", @_) }
-sub retr { shift->_data_cmd("RETR", @_) }
-sub stor { shift->_data_cmd("STOR", @_) }
-sub stou { shift->_data_cmd("STOU", @_) }
-sub appe { shift->_data_cmd("APPE", @_) }
-
-
-sub _store_cmd {
- my ($ftp, $cmd, $local, $remote) = @_;
- my ($loc, $sock, $len, $buf);
- local *FD;
-
- my $localfd = ref($local) || ref(\$local) eq "GLOB";
-
- if (!defined($remote) and 'STOU' ne uc($cmd)) {
- croak 'Must specify remote filename with stream input'
- if $localfd;
-
- require File::Basename;
- $remote = File::Basename::basename($local);
- }
- if (defined ${*$ftp}{'net_ftp_allo'}) {
- delete ${*$ftp}{'net_ftp_allo'};
- }
- else {
-
- # if the user hasn't already invoked the alloc method since the last
- # _store_cmd call, figure out if the local file is a regular file(not
- # a pipe, or device) and if so get the file size from stat, and send
- # an ALLO command before sending the STOR, STOU, or APPE command.
- my $size = do { local $^W; -f $local && -s _ }; # no ALLO if sending data from a pipe
- ${*$ftp}{'net_ftp_allo'} = $size if $size;
- }
- croak("Bad remote filename '$remote'\n")
- if defined($remote) and $remote =~ /[\r\n]/s;
-
- if ($localfd) {
- $loc = $local;
- }
- else {
- $loc = \*FD;
-
- unless (sysopen($loc, $local, O_RDONLY)) {
- carp "Cannot open Local file $local: $!\n";
- return undef;
- }
- }
-
- if ($ftp->type eq 'I' && !binmode($loc)) {
- carp "Cannot binmode Local file $local: $!\n";
- return undef;
- }
-
- delete ${*$ftp}{'net_ftp_port'};
- delete ${*$ftp}{'net_ftp_pasv'};
-
- $sock = $ftp->_data_cmd($cmd, grep { defined } $remote)
- or return undef;
-
- $remote = ($ftp->message =~ /\w+\s*:\s*(.*)/)[0]
- if 'STOU' eq uc $cmd;
-
- my $blksize = ${*$ftp}{'net_ftp_blksize'};
-
- my ($count, $hashh, $hashb, $ref) = (0);
-
- ($hashh, $hashb) = @$ref
- if ($ref = ${*$ftp}{'net_ftp_hash'});
-
- while (1) {
- last unless $len = read($loc, $buf = "", $blksize);
-
- if (trEBCDIC && $ftp->type ne 'I') {
- $buf = $ftp->toascii($buf);
- $len = length($buf);
- }
-
- if ($hashh) {
- $count += $len;
- print $hashh "#" x (int($count / $hashb));
- $count %= $hashb;
- }
-
- my $wlen;
- unless (defined($wlen = $sock->write($buf, $len)) && $wlen == $len) {
- $sock->abort;
- close($loc)
- unless $localfd;
- print $hashh "\n" if $hashh;
- return undef;
- }
- }
-
- print $hashh "\n" if $hashh;
-
- close($loc)
- unless $localfd;
-
- $sock->close()
- or return undef;
-
- if ('STOU' eq uc $cmd and $ftp->message =~ m/unique\s+file\s*name\s*:\s*(.*)\)|"(.*)"/) {
- require File::Basename;
- $remote = File::Basename::basename($+);
- }
-
- return $remote;
-}
-
-
-sub port {
- @_ == 1 || @_ == 2 or croak 'usage: $ftp->port([PORT])';
-
- my ($ftp, $port) = @_;
- my $ok;
-
- delete ${*$ftp}{'net_ftp_intern_port'};
-
- unless (defined $port) {
-
- # create a Listen socket at same address as the command socket
-
- ${*$ftp}{'net_ftp_listen'} ||= IO::Socket::INET->new(
- Listen => 5,
- Proto => 'tcp',
- Timeout => $ftp->timeout,
- LocalAddr => $ftp->sockhost,
- );
-
- my $listen = ${*$ftp}{'net_ftp_listen'};
-
- my ($myport, @myaddr) = ($listen->sockport, split(/\./, $listen->sockhost));
-
- $port = join(',', @myaddr, $myport >> 8, $myport & 0xff);
-
- ${*$ftp}{'net_ftp_intern_port'} = 1;
- }
-
- $ok = $ftp->_PORT($port);
-
- ${*$ftp}{'net_ftp_port'} = $port;
-
- $ok;
-}
-
-
-sub ls { shift->_list_cmd("NLST", @_); }
-sub dir { shift->_list_cmd("LIST", @_); }
-
-
-sub pasv {
- @_ == 1 or croak 'usage: $ftp->pasv()';
-
- my $ftp = shift;
-
- delete ${*$ftp}{'net_ftp_intern_port'};
-
- $ftp->_PASV && $ftp->message =~ /(\d+(,\d+)+)/
- ? ${*$ftp}{'net_ftp_pasv'} = $1
- : undef;
-}
-
-
-sub unique_name {
- my $ftp = shift;
- ${*$ftp}{'net_ftp_unique'} || undef;
-}
-
-
-sub supported {
- @_ == 2 or croak 'usage: $ftp->supported( CMD )';
- my $ftp = shift;
- my $cmd = uc shift;
- my $hash = ${*$ftp}{'net_ftp_supported'} ||= {};
-
- return $hash->{$cmd}
- if exists $hash->{$cmd};
-
- return $hash->{$cmd} = 1
- if $ftp->feature($cmd);
-
- return $hash->{$cmd} = 0
- unless $ftp->_HELP($cmd);
-
- my $text = $ftp->message;
- if ($text =~ /following\s+commands/i) {
- $text =~ s/^.*\n//;
- while ($text =~ /(\*?)(\w+)(\*?)/sg) {
- $hash->{"\U$2"} = !length("$1$3");
- }
- }
- else {
- $hash->{$cmd} = $text !~ /unimplemented/i;
- }
-
- $hash->{$cmd} ||= 0;
-}
-
-##
-## Deprecated methods
-##
-
-
-sub lsl {
- carp "Use of Net::FTP::lsl deprecated, use 'dir'"
- if $^W;
- goto &dir;
-}
-
-
-sub authorise {
- carp "Use of Net::FTP::authorise deprecated, use 'authorize'"
- if $^W;
- goto &authorize;
-}
-
-
-##
-## Private methods
-##
-
-
-sub _extract_path {
- my ($ftp, $path) = @_;
-
- # This tries to work both with and without the quote doubling
- # convention (RFC 959 requires it, but the first 3 servers I checked
- # didn't implement it). It will fail on a server which uses a quote in
- # the message which isn't a part of or surrounding the path.
- $ftp->ok
- && $ftp->message =~ /(?:^|\s)\"(.*)\"(?:$|\s)/
- && ($path = $1) =~ s/\"\"/\"/g;
-
- $path;
-}
-
-##
-## Communication methods
-##
-
-
-sub _dataconn {
- my $ftp = shift;
- my $data = undef;
- my $pkg = "Net::FTP::" . $ftp->type;
-
- eval "require " . $pkg;
-
- $pkg =~ s/ /_/g;
-
- delete ${*$ftp}{'net_ftp_dataconn'};
-
- if (defined ${*$ftp}{'net_ftp_pasv'}) {
- my @port = map { 0 + $_ } split(/,/, ${*$ftp}{'net_ftp_pasv'});
-
- $data = $pkg->new(
- PeerAddr => join(".", @port[0 .. 3]),
- PeerPort => $port[4] * 256 + $port[5],
- LocalAddr => ${*$ftp}{'net_ftp_localaddr'},
- Proto => 'tcp',
- Timeout => $ftp->timeout
- );
- }
- elsif (defined ${*$ftp}{'net_ftp_listen'}) {
- $data = ${*$ftp}{'net_ftp_listen'}->accept($pkg);
- close(delete ${*$ftp}{'net_ftp_listen'});
- }
-
- if ($data) {
- ${*$data} = "";
- $data->timeout($ftp->timeout);
- ${*$ftp}{'net_ftp_dataconn'} = $data;
- ${*$data}{'net_ftp_cmd'} = $ftp;
- ${*$data}{'net_ftp_blksize'} = ${*$ftp}{'net_ftp_blksize'};
- }
-
- $data;
-}
-
-
-sub _list_cmd {
- my $ftp = shift;
- my $cmd = uc shift;
-
- delete ${*$ftp}{'net_ftp_port'};
- delete ${*$ftp}{'net_ftp_pasv'};
-
- my $data = $ftp->_data_cmd($cmd, @_);
-
- return
- unless (defined $data);
-
- require Net::FTP::A;
- bless $data, "Net::FTP::A"; # Force ASCII mode
-
- my $databuf = '';
- my $buf = '';
- my $blksize = ${*$ftp}{'net_ftp_blksize'};
-
- while ($data->read($databuf, $blksize)) {
- $buf .= $databuf;
- }
-
- my $list = [split(/\n/, $buf)];
-
- $data->close();
-
- if (trEBCDIC) {
- for (@$list) { $_ = $ftp->toebcdic($_) }
- }
-
- wantarray
- ? @{$list}
- : $list;
-}
-
-
-sub _data_cmd {
- my $ftp = shift;
- my $cmd = uc shift;
- my $ok = 1;
- my $where = delete ${*$ftp}{'net_ftp_rest'} || 0;
- my $arg;
-
- for $arg (@_) {
- croak("Bad argument '$arg'\n")
- if $arg =~ /[\r\n]/s;
- }
-
- if ( ${*$ftp}{'net_ftp_passive'}
- && !defined ${*$ftp}{'net_ftp_pasv'}
- && !defined ${*$ftp}{'net_ftp_port'})
- {
- my $data = undef;
-
- return undef unless defined $ftp->pasv;
- $data = $ftp->_dataconn() or return undef;
-
- if ($where and !$ftp->_REST($where)) {
- my ($status, $message) = ($ftp->status, $ftp->message);
- $ftp->abort;
- $ftp->set_status($status, $message);
- return undef;
- }
-
- $ftp->command($cmd, @_);
- if (CMD_INFO == $ftp->response()) {
- $data->reading
- if $cmd =~ /RETR|LIST|NLST/;
- return $data;
- }
- $data->_close;
-
- return undef;
- }
-
- $ok = $ftp->port
- unless (defined ${*$ftp}{'net_ftp_port'}
- || defined ${*$ftp}{'net_ftp_pasv'});
-
- $ok = $ftp->_REST($where)
- if $ok && $where;
-
- return undef
- unless $ok;
-
- if ($cmd =~ /(STOR|APPE|STOU)/ and exists ${*$ftp}{net_ftp_allo}) {
- $ftp->_ALLO(delete ${*$ftp}{net_ftp_allo})
- or return undef;
- }
-
- $ftp->command($cmd, @_);
-
- return 1
- if (defined ${*$ftp}{'net_ftp_pasv'});
-
- $ok = CMD_INFO == $ftp->response();
-
- return $ok
- unless exists ${*$ftp}{'net_ftp_intern_port'};
-
- if ($ok) {
- my $data = $ftp->_dataconn();
-
- $data->reading
- if $data && $cmd =~ /RETR|LIST|NLST/;
-
- return $data;
- }
-
-
- close(delete ${*$ftp}{'net_ftp_listen'});
-
- return undef;
-}
-
-##
-## Over-ride methods (Net::Cmd)
-##
-
-
-sub debug_text { $_[2] =~ /^(pass|resp|acct)/i ? "$1 ....\n" : $_[2]; }
-
-
-sub command {
- my $ftp = shift;
-
- delete ${*$ftp}{'net_ftp_port'};
- $ftp->SUPER::command(@_);
-}
-
-
-sub response {
- my $ftp = shift;
- my $code = $ftp->SUPER::response() || 5; # assume 500 if undef
-
- delete ${*$ftp}{'net_ftp_pasv'}
- if ($code != CMD_MORE && $code != CMD_INFO);
-
- $code;
-}
-
-
-sub parse_response {
- return ($1, $2 eq "-")
- if $_[1] =~ s/^(\d\d\d)([- ]?)//o;
-
- my $ftp = shift;
-
- # Darn MS FTP server is a load of CRAP !!!!
- # Expect to see undef here.
- return ()
- unless 0 + (${*$ftp}{'net_cmd_code'} || 0);
-
- (${*$ftp}{'net_cmd_code'}, 1);
-}
-
-##
-## Allow 2 servers to talk directly
-##
-
-
-sub pasv_xfer_unique {
- my ($sftp, $sfile, $dftp, $dfile) = @_;
- $sftp->pasv_xfer($sfile, $dftp, $dfile, 1);
-}
-
-
-sub pasv_xfer {
- my ($sftp, $sfile, $dftp, $dfile, $unique) = @_;
-
- ($dfile = $sfile) =~ s#.*/##
- unless (defined $dfile);
-
- my $port = $sftp->pasv
- or return undef;
-
- $dftp->port($port)
- or return undef;
-
- return undef
- unless ($unique ? $dftp->stou($dfile) : $dftp->stor($dfile));
-
- unless ($sftp->retr($sfile) && $sftp->response == CMD_INFO) {
- $sftp->retr($sfile);
- $dftp->abort;
- $dftp->response();
- return undef;
- }
-
- $dftp->pasv_wait($sftp);
-}
-
-
-sub pasv_wait {
- @_ == 2 or croak 'usage: $ftp->pasv_wait(NON_PASV_FTP)';
-
- my ($ftp, $non_pasv) = @_;
- my ($file, $rin, $rout);
-
- vec($rin = '', fileno($ftp), 1) = 1;
- select($rout = $rin, undef, undef, undef);
-
- my $dres = $ftp->response();
- my $sres = $non_pasv->response();
-
- return undef
- unless $dres == CMD_OK && $sres == CMD_OK;
-
- return undef
- unless $ftp->ok() && $non_pasv->ok();
-
- return $1
- if $ftp->message =~ /unique file name:\s*(\S*)\s*\)/;
-
- return $1
- if $non_pasv->message =~ /unique file name:\s*(\S*)\s*\)/;
-
- return 1;
-}
-
-
-sub feature {
- @_ == 2 or croak 'usage: $ftp->feature( NAME )';
- my ($ftp, $feat) = @_;
-
- my $feature = ${*$ftp}{net_ftp_feature} ||= do {
- my @feat;
-
- # Example response
- # 211-Features:
- # MDTM
- # REST STREAM
- # SIZE
- # 211 End
-
- @feat = map { /^\s+(.*\S)/ } $ftp->message
- if $ftp->_FEAT;
-
- \@feat;
- };
-
- return grep { /^\Q$feat\E\b/i } @$feature;
-}
-
-
-sub cmd { shift->command(@_)->response() }
-
-########################################
-#
-# RFC959 commands
-#
-
-
-sub _ABOR { shift->command("ABOR")->response() == CMD_OK }
-sub _ALLO { shift->command("ALLO", @_)->response() == CMD_OK }
-sub _CDUP { shift->command("CDUP")->response() == CMD_OK }
-sub _NOOP { shift->command("NOOP")->response() == CMD_OK }
-sub _PASV { shift->command("PASV")->response() == CMD_OK }
-sub _QUIT { shift->command("QUIT")->response() == CMD_OK }
-sub _DELE { shift->command("DELE", @_)->response() == CMD_OK }
-sub _CWD { shift->command("CWD", @_)->response() == CMD_OK }
-sub _PORT { shift->command("PORT", @_)->response() == CMD_OK }
-sub _RMD { shift->command("RMD", @_)->response() == CMD_OK }
-sub _MKD { shift->command("MKD", @_)->response() == CMD_OK }
-sub _PWD { shift->command("PWD", @_)->response() == CMD_OK }
-sub _TYPE { shift->command("TYPE", @_)->response() == CMD_OK }
-sub _RNTO { shift->command("RNTO", @_)->response() == CMD_OK }
-sub _RESP { shift->command("RESP", @_)->response() == CMD_OK }
-sub _MDTM { shift->command("MDTM", @_)->response() == CMD_OK }
-sub _SIZE { shift->command("SIZE", @_)->response() == CMD_OK }
-sub _HELP { shift->command("HELP", @_)->response() == CMD_OK }
-sub _STAT { shift->command("STAT", @_)->response() == CMD_OK }
-sub _FEAT { shift->command("FEAT", @_)->response() == CMD_OK }
-sub _APPE { shift->command("APPE", @_)->response() == CMD_INFO }
-sub _LIST { shift->command("LIST", @_)->response() == CMD_INFO }
-sub _NLST { shift->command("NLST", @_)->response() == CMD_INFO }
-sub _RETR { shift->command("RETR", @_)->response() == CMD_INFO }
-sub _STOR { shift->command("STOR", @_)->response() == CMD_INFO }
-sub _STOU { shift->command("STOU", @_)->response() == CMD_INFO }
-sub _RNFR { shift->command("RNFR", @_)->response() == CMD_MORE }
-sub _REST { shift->command("REST", @_)->response() == CMD_MORE }
-sub _PASS { shift->command("PASS", @_)->response() }
-sub _ACCT { shift->command("ACCT", @_)->response() }
-sub _AUTH { shift->command("AUTH", @_)->response() }
-
-
-sub _USER {
- my $ftp = shift;
- my $ok = $ftp->command("USER", @_)->response();
-
- # A certain brain dead firewall :-)
- $ok = $ftp->command("user", @_)->response()
- unless $ok == CMD_MORE or $ok == CMD_OK;
-
- $ok;
-}
-
-
-sub _SMNT { shift->unsupported(@_) }
-sub _MODE { shift->unsupported(@_) }
-sub _SYST { shift->unsupported(@_) }
-sub _STRU { shift->unsupported(@_) }
-sub _REIN { shift->unsupported(@_) }
-
-1;
-
-__END__
-
-=head1 NAME
-
-Net::FTP - FTP Client class
-
-=head1 SYNOPSIS
-
- use Net::FTP;
-
- $ftp = Net::FTP->new("some.host.name", Debug => 0)
- or die "Cannot connect to some.host.name: $@";
-
- $ftp->login("anonymous",'-anonymous@')
- or die "Cannot login ", $ftp->message;
-
- $ftp->cwd("/pub")
- or die "Cannot change working directory ", $ftp->message;
-
- $ftp->get("that.file")
- or die "get failed ", $ftp->message;
-
- $ftp->quit;
-
-=head1 DESCRIPTION
-
-C<Net::FTP> is a class implementing a simple FTP client in Perl as
-described in RFC959. It provides wrappers for a subset of the RFC959
-commands.
-
-The Net::FTP class is a subclass of Net::Cmd and IO::Socket::INET.
-
-=head1 OVERVIEW
-
-FTP stands for File Transfer Protocol. It is a way of transferring
-files between networked machines. The protocol defines a client
-(whose commands are provided by this module) and a server (not
-implemented in this module). Communication is always initiated by the
-client, and the server responds with a message and a status code (and
-sometimes with data).
-
-The FTP protocol allows files to be sent to or fetched from the
-server. Each transfer involves a B<local file> (on the client) and a
-B<remote file> (on the server). In this module, the same file name
-will be used for both local and remote if only one is specified. This
-means that transferring remote file C</path/to/file> will try to put
-that file in C</path/to/file> locally, unless you specify a local file
-name.
-
-The protocol also defines several standard B<translations> which the
-file can undergo during transfer. These are ASCII, EBCDIC, binary,
-and byte. ASCII is the default type, and indicates that the sender of
-files will translate the ends of lines to a standard representation
-which the receiver will then translate back into their local
-representation. EBCDIC indicates the file being transferred is in
-EBCDIC format. Binary (also known as image) format sends the data as
-a contiguous bit stream. Byte format transfers the data as bytes, the
-values of which remain the same regardless of differences in byte size
-between the two machines (in theory - in practice you should only use
-this if you really know what you're doing).
-
-=head1 CONSTRUCTOR
-
-=over 4
-
-=item new ([ HOST ] [, OPTIONS ])
-
-This is the constructor for a new Net::FTP object. C<HOST> is the
-name of the remote host to which an FTP connection is required.
-
-C<HOST> is optional. If C<HOST> is not given then it may instead be
-passed as the C<Host> option described below.
-
-C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
-Possible options are:
-
-B<Host> - FTP host to connect to. It may be a single scalar, as defined for
-the C<PeerAddr> option in L<IO::Socket::INET>, or a reference to
-an array with hosts to try in turn. The L</host> method will return the value
-which was used to connect to the host.
-
-
-B<Firewall> - The name of a machine which acts as an FTP firewall. This can be
-overridden by an environment variable C<FTP_FIREWALL>. If specified, and the
-given host cannot be directly connected to, then the
-connection is made to the firewall machine and the string C<@hostname> is
-appended to the login identifier. This kind of setup is also referred to
-as an ftp proxy.
-
-B<FirewallType> - The type of firewall running on the machine indicated by
-B<Firewall>. This can be overridden by an environment variable
-C<FTP_FIREWALL_TYPE>. For a list of permissible types, see the description of
-ftp_firewall_type in L<Net::Config>.
-
-B<BlockSize> - This is the block size that Net::FTP will use when doing
-transfers. (defaults to 10240)
-
-B<Port> - The port number to connect to on the remote machine for the
-FTP connection
-
-B<Timeout> - Set a timeout value in seconds (defaults to 120)
-
-B<Debug> - debug level (see the debug method in L<Net::Cmd>)
-
-B<Passive> - If set to a non-zero value then all data transfers will
-be done using passive mode. If set to zero then data transfers will be
-done using active mode. If the machine is connected to the Internet
-directly, both passive and active mode should work equally well.
-Behind most firewall and NAT configurations passive mode has a better
-chance of working. However, in some rare firewall configurations,
-active mode actually works when passive mode doesn't. Some really old
-FTP servers might not implement passive transfers. If not specified,
-then the transfer mode is set by the environment variable
-C<FTP_PASSIVE> or if that one is not set by the settings done by the
-F<libnetcfg> utility. If none of these apply then passive mode is
-used.
-
-B<Hash> - If given a reference to a file handle (e.g., C<\*STDERR>),
-print hash marks (#) on that filehandle every 1024 bytes. This
-simply invokes the C<hash()> method for you, so that hash marks
-are displayed for all transfers. You can, of course, call C<hash()>
-explicitly whenever you'd like.
-
-B<LocalAddr> - Local address to use for all socket connections, this
-argument will be passed to L<IO::Socket::INET>
-
-If the constructor fails undef will be returned and an error message will
-be in $@
-
-=back
-
-=head1 METHODS
-
-Unless otherwise stated all methods return either a I<true> or I<false>
-value, with I<true> meaning that the operation was a success. When a method
-states that it returns a value, failure will be returned as I<undef> or an
-empty list.
-
-C<Net::FTP> inherits from C<Net::Cmd> so methods defined in C<Net::Cmd> may
-be used to send commands to the remote FTP server in addition to the methods
-documented here.
-
-=over 4
-
-=item login ([LOGIN [,PASSWORD [, ACCOUNT] ] ])
-
-Log into the remote FTP server with the given login information. If
-no arguments are given then the C<Net::FTP> uses the C<Net::Netrc>
-package to lookup the login information for the connected host.
-If no information is found then a login of I<anonymous> is used.
-If no password is given and the login is I<anonymous> then I<anonymous@>
-will be used for password.
-
-If the connection is via a firewall then the C<authorize> method will
-be called with no arguments.
-
-=item authorize ( [AUTH [, RESP]])
-
-This is a protocol used by some firewall ftp proxies. It is used
-to authorise the user to send data out. If both arguments are not specified
-then C<authorize> uses C<Net::Netrc> to do a lookup.
-
-=item site (ARGS)
-
-Send a SITE command to the remote server and wait for a response.
-
-Returns most significant digit of the response code.
-
-=item ascii
-
-Transfer file in ASCII. CRLF translation will be done if required
-
-=item binary
-
-Transfer file in binary mode. No transformation will be done.
-
-B<Hint>: If both server and client machines use the same line ending for
-text files, then it will be faster to transfer all files in binary mode.
-
-=item rename ( OLDNAME, NEWNAME )
-
-Rename a file on the remote FTP server from C<OLDNAME> to C<NEWNAME>. This
-is done by sending the RNFR and RNTO commands.
-
-=item delete ( FILENAME )
-
-Send a request to the server to delete C<FILENAME>.
-
-=item cwd ( [ DIR ] )
-
-Attempt to change directory to the directory given in C<$dir>. If
-C<$dir> is C<"..">, the FTP C<CDUP> command is used to attempt to
-move up one directory. If no directory is given then an attempt is made
-to change the directory to the root directory.
-
-=item cdup ()
-
-Change directory to the parent of the current directory.
-
-=item passive ( [ PASSIVE ] )
-
-Set or get if data connections will be initiated in passive mode.
-
-=item pwd ()
-
-Returns the full pathname of the current directory.
-
-=item restart ( WHERE )
-
-Set the byte offset at which to begin the next data transfer. Net::FTP simply
-records this value and uses it when during the next data transfer. For this
-reason this method will not return an error, but setting it may cause
-a subsequent data transfer to fail.
-
-=item rmdir ( DIR [, RECURSE ])
-
-Remove the directory with the name C<DIR>. If C<RECURSE> is I<true> then
-C<rmdir> will attempt to delete everything inside the directory.
-
-=item mkdir ( DIR [, RECURSE ])
-
-Create a new directory with the name C<DIR>. If C<RECURSE> is I<true> then
-C<mkdir> will attempt to create all the directories in the given path.
-
-Returns the full pathname to the new directory.
-
-=item alloc ( SIZE [, RECORD_SIZE] )
-
-The alloc command allows you to give the ftp server a hint about the size
-of the file about to be transferred using the ALLO ftp command. Some storage
-systems use this to make intelligent decisions about how to store the file.
-The C<SIZE> argument represents the size of the file in bytes. The
-C<RECORD_SIZE> argument indicates a maximum record or page size for files
-sent with a record or page structure.
-
-The size of the file will be determined, and sent to the server
-automatically for normal files so that this method need only be called if
-you are transferring data from a socket, named pipe, or other stream not
-associated with a normal file.
-
-=item ls ( [ DIR ] )
-
-Get a directory listing of C<DIR>, or the current directory.
-
-In an array context, returns a list of lines returned from the server. In
-a scalar context, returns a reference to a list.
-
-=item dir ( [ DIR ] )
-
-Get a directory listing of C<DIR>, or the current directory in long format.
-
-In an array context, returns a list of lines returned from the server. In
-a scalar context, returns a reference to a list.
-
-=item get ( REMOTE_FILE [, LOCAL_FILE [, WHERE]] )
-
-Get C<REMOTE_FILE> from the server and store locally. C<LOCAL_FILE> may be
-a filename or a filehandle. If not specified, the file will be stored in
-the current directory with the same leafname as the remote file.
-
-If C<WHERE> is given then the first C<WHERE> bytes of the file will
-not be transferred, and the remaining bytes will be appended to
-the local file if it already exists.
-
-Returns C<LOCAL_FILE>, or the generated local file name if C<LOCAL_FILE>
-is not given. If an error was encountered undef is returned.
-
-=item put ( LOCAL_FILE [, REMOTE_FILE ] )
-
-Put a file on the remote server. C<LOCAL_FILE> may be a name or a filehandle.
-If C<LOCAL_FILE> is a filehandle then C<REMOTE_FILE> must be specified. If
-C<REMOTE_FILE> is not specified then the file will be stored in the current
-directory with the same leafname as C<LOCAL_FILE>.
-
-Returns C<REMOTE_FILE>, or the generated remote filename if C<REMOTE_FILE>
-is not given.
-
-B<NOTE>: If for some reason the transfer does not complete and an error is
-returned then the contents that had been transferred will not be remove
-automatically.
-
-=item put_unique ( LOCAL_FILE [, REMOTE_FILE ] )
-
-Same as put but uses the C<STOU> command.
-
-Returns the name of the file on the server.
-
-=item append ( LOCAL_FILE [, REMOTE_FILE ] )
-
-Same as put but appends to the file on the remote server.
-
-Returns C<REMOTE_FILE>, or the generated remote filename if C<REMOTE_FILE>
-is not given.
-
-=item unique_name ()
-
-Returns the name of the last file stored on the server using the
-C<STOU> command.
-
-=item mdtm ( FILE )
-
-Returns the I<modification time> of the given file
-
-=item size ( FILE )
-
-Returns the size in bytes for the given file as stored on the remote server.
-
-B<NOTE>: The size reported is the size of the stored file on the remote server.
-If the file is subsequently transferred from the server in ASCII mode
-and the remote server and local machine have different ideas about
-"End Of Line" then the size of file on the local machine after transfer
-may be different.
-
-=item supported ( CMD )
-
-Returns TRUE if the remote server supports the given command.
-
-=item hash ( [FILEHANDLE_GLOB_REF],[ BYTES_PER_HASH_MARK] )
-
-Called without parameters, or with the first argument false, hash marks
-are suppressed. If the first argument is true but not a reference to a
-file handle glob, then \*STDERR is used. The second argument is the number
-of bytes per hash mark printed, and defaults to 1024. In all cases the
-return value is a reference to an array of two: the filehandle glob reference
-and the bytes per hash mark.
-
-=item feature ( NAME )
-
-Determine if the server supports the specified feature. The return
-value is a list of lines the server responded with to describe the
-options that it supports for the given feature. If the feature is
-unsupported then the empty list is returned.
-
- if ($ftp->feature( 'MDTM' )) {
- # Do something
- }
-
- if (grep { /\bTLS\b/ } $ftp->feature('AUTH')) {
- # Server supports TLS
- }
-
-=back
-
-The following methods can return different results depending on
-how they are called. If the user explicitly calls either
-of the C<pasv> or C<port> methods then these methods will
-return a I<true> or I<false> value. If the user does not
-call either of these methods then the result will be a
-reference to a C<Net::FTP::dataconn> based object.
-
-=over 4
-
-=item nlst ( [ DIR ] )
-
-Send an C<NLST> command to the server, with an optional parameter.
-
-=item list ( [ DIR ] )
-
-Same as C<nlst> but using the C<LIST> command
-
-=item retr ( FILE )
-
-Begin the retrieval of a file called C<FILE> from the remote server.
-
-=item stor ( FILE )
-
-Tell the server that you wish to store a file. C<FILE> is the
-name of the new file that should be created.
-
-=item stou ( FILE )
-
-Same as C<stor> but using the C<STOU> command. The name of the unique
-file which was created on the server will be available via the C<unique_name>
-method after the data connection has been closed.
-
-=item appe ( FILE )
-
-Tell the server that we want to append some data to the end of a file
-called C<FILE>. If this file does not exist then create it.
-
-=back
-
-If for some reason you want to have complete control over the data connection,
-this includes generating it and calling the C<response> method when required,
-then the user can use these methods to do so.
-
-However calling these methods only affects the use of the methods above that
-can return a data connection. They have no effect on methods C<get>, C<put>,
-C<put_unique> and those that do not require data connections.
-
-=over 4
-
-=item port ( [ PORT ] )
-
-Send a C<PORT> command to the server. If C<PORT> is specified then it is sent
-to the server. If not, then a listen socket is created and the correct information
-sent to the server.
-
-=item pasv ()
-
-Tell the server to go into passive mode. Returns the text that represents the
-port on which the server is listening, this text is in a suitable form to
-sent to another ftp server using the C<port> method.
-
-=back
-
-The following methods can be used to transfer files between two remote
-servers, providing that these two servers can connect directly to each other.
-
-=over 4
-
-=item pasv_xfer ( SRC_FILE, DEST_SERVER [, DEST_FILE ] )
-
-This method will do a file transfer between two remote ftp servers. If
-C<DEST_FILE> is omitted then the leaf name of C<SRC_FILE> will be used.
-
-=item pasv_xfer_unique ( SRC_FILE, DEST_SERVER [, DEST_FILE ] )
-
-Like C<pasv_xfer> but the file is stored on the remote server using
-the STOU command.
-
-=item pasv_wait ( NON_PASV_SERVER )
-
-This method can be used to wait for a transfer to complete between a passive
-server and a non-passive server. The method should be called on the passive
-server with the C<Net::FTP> object for the non-passive server passed as an
-argument.
-
-=item abort ()
-
-Abort the current data transfer.
-
-=item quit ()
-
-Send the QUIT command to the remote FTP server and close the socket connection.
-
-=back
-
-=head2 Methods for the adventurous
-
-=over 4
-
-=item quot (CMD [,ARGS])
-
-Send a command, that Net::FTP does not directly support, to the remote
-server and wait for a response.
-
-Returns most significant digit of the response code.
-
-B<WARNING> This call should only be used on commands that do not require
-data connections. Misuse of this method can hang the connection.
-
-=back
-
-=head1 THE dataconn CLASS
-
-Some of the methods defined in C<Net::FTP> return an object which will
-be derived from this class.The dataconn class itself is derived from
-the C<IO::Socket::INET> class, so any normal IO operations can be performed.
-However the following methods are defined in the dataconn class and IO should
-be performed using these.
-
-=over 4
-
-=item read ( BUFFER, SIZE [, TIMEOUT ] )
-
-Read C<SIZE> bytes of data from the server and place it into C<BUFFER>, also
-performing any <CRLF> translation necessary. C<TIMEOUT> is optional, if not
-given, the timeout value from the command connection will be used.
-
-Returns the number of bytes read before any <CRLF> translation.
-
-=item write ( BUFFER, SIZE [, TIMEOUT ] )
-
-Write C<SIZE> bytes of data from C<BUFFER> to the server, also
-performing any <CRLF> translation necessary. C<TIMEOUT> is optional, if not
-given, the timeout value from the command connection will be used.
-
-Returns the number of bytes written before any <CRLF> translation.
-
-=item bytes_read ()
-
-Returns the number of bytes read so far.
-
-=item abort ()
-
-Abort the current data transfer.
-
-=item close ()
-
-Close the data connection and get a response from the FTP server. Returns
-I<true> if the connection was closed successfully and the first digit of
-the response from the server was a '2'.
-
-=back
-
-=head1 UNIMPLEMENTED
-
-The following RFC959 commands have not been implemented:
-
-=over 4
-
-=item B<SMNT>
-
-Mount a different file system structure without changing login or
-accounting information.
-
-=item B<HELP>
-
-Ask the server for "helpful information" (that's what the RFC says) on
-the commands it accepts.
-
-=item B<MODE>
-
-Specifies transfer mode (stream, block or compressed) for file to be
-transferred.
-
-=item B<SYST>
-
-Request remote server system identification.
-
-=item B<STAT>
-
-Request remote server status.
-
-=item B<STRU>
-
-Specifies file structure for file to be transferred.
-
-=item B<REIN>
-
-Reinitialize the connection, flushing all I/O and account information.
-
-=back
-
-=head1 REPORTING BUGS
-
-When reporting bugs/problems please include as much information as possible.
-It may be difficult for me to reproduce the problem as almost every setup
-is different.
-
-A small script which yields the problem will probably be of help. It would
-also be useful if this script was run with the extra options C<Debug => 1>
-passed to the constructor, and the output sent with the bug report. If you
-cannot include a small script then please include a Debug trace from a
-run of your program which does yield the problem.
-
-=head1 AUTHOR
-
-Graham Barr <gbarr@pobox.com>
-
-=head1 SEE ALSO
-
-L<Net::Netrc>
-L<Net::Cmd>
-
-ftp(1), ftpd(8), RFC 959
-http://www.ietf.org/rfc/rfc959.txt
-
-=head1 USE EXAMPLES
-
-For an example of the use of Net::FTP see
-
-=over 4
-
-=item http://www.csh.rit.edu/~adam/Progs/
-
-C<autoftp> is a program that can retrieve, send, or list files via
-the FTP protocol in a non-interactive manner.
-
-=back
-
-=head1 CREDITS
-
-Henry Gabryjelski <henryg@WPI.EDU> - for the suggestion of creating directories
-recursively.
-
-Nathan Torkington <gnat@frii.com> - for some input on the documentation.
-
-Roderick Schertler <roderick@gate.net> - for various inputs
-
-=head1 COPYRIGHT
-
-Copyright (c) 1995-2004 Graham Barr. All rights reserved.
-This program is free software; you can redistribute it and/or modify it
-under the same terms as Perl itself.
-
-=cut
@@ -1,1154 +0,0 @@
-# Net::NNTP.pm
-#
-# Copyright (c) 1995-1997 Graham Barr <gbarr@pobox.com>. All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-
-package Net::NNTP;
-
-use strict;
-use vars qw(@ISA $VERSION $debug);
-use IO::Socket;
-use Net::Cmd;
-use Carp;
-use Time::Local;
-use Net::Config;
-
-$VERSION = "2.26";
-@ISA = qw(Net::Cmd IO::Socket::INET);
-
-
-sub new {
- my $self = shift;
- my $type = ref($self) || $self;
- my ($host, %arg);
- if (@_ % 2) {
- $host = shift;
- %arg = @_;
- }
- else {
- %arg = @_;
- $host = delete $arg{Host};
- }
- my $obj;
-
- $host ||= $ENV{NNTPSERVER} || $ENV{NEWSHOST};
-
- my $hosts = defined $host ? [$host] : $NetConfig{nntp_hosts};
-
- @{$hosts} = qw(news)
- unless @{$hosts};
-
- my %connect = ( Proto => 'tcp');
- my $o;
- foreach $o (qw(LocalAddr Timeout)) {
- $connect{$o} = $arg{$o} if exists $arg{$o};
- }
- $connect{Timeout} = 120 unless defined $connect{Timeout};
- $connect{PeerPort} = $arg{Port} || 'nntp(119)';
- my $h;
- foreach $h (@{$hosts}) {
- $connect{PeerAddr} = $h;
- $obj = $type->SUPER::new(%connect)
- and last;
- }
-
- return undef
- unless defined $obj;
-
- ${*$obj}{'net_nntp_host'} = $connect{PeerAddr};
-
- $obj->autoflush(1);
- $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
-
- unless ($obj->response() == CMD_OK) {
- $obj->close;
- return undef;
- }
-
- my $c = $obj->code;
- my @m = $obj->message;
-
- unless (exists $arg{Reader} && $arg{Reader} == 0) {
-
- # if server is INN and we have transfer rights the we are currently
- # talking to innd not nnrpd
- if ($obj->reader) {
-
- # If reader succeeds the we need to consider this code to determine postok
- $c = $obj->code;
- }
- else {
-
- # I want to ignore this failure, so restore the previous status.
- $obj->set_status($c, \@m);
- }
- }
-
- ${*$obj}{'net_nntp_post'} = $c == 200 ? 1 : 0;
-
- $obj;
-}
-
-
-sub host {
- my $me = shift;
- ${*$me}{'net_nntp_host'};
-}
-
-
-sub debug_text {
- my $nntp = shift;
- my $inout = shift;
- my $text = shift;
-
- if ( (ref($nntp) and $nntp->code == 350 and $text =~ /^(\S+)/)
- || ($text =~ /^(authinfo\s+pass)/io))
- {
- $text = "$1 ....\n";
- }
-
- $text;
-}
-
-
-sub postok {
- @_ == 1 or croak 'usage: $nntp->postok()';
- my $nntp = shift;
- ${*$nntp}{'net_nntp_post'} || 0;
-}
-
-
-sub article {
- @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->article( [ MSGID ], [ FH ] )';
- my $nntp = shift;
- my @fh;
-
- @fh = (pop) if @_ == 2 || (@_ && (ref($_[0]) || ref(\$_[0]) eq 'GLOB'));
-
- $nntp->_ARTICLE(@_)
- ? $nntp->read_until_dot(@fh)
- : undef;
-}
-
-
-sub articlefh {
- @_ >= 1 && @_ <= 2 or croak 'usage: $nntp->articlefh( [ MSGID ] )';
- my $nntp = shift;
-
- return unless $nntp->_ARTICLE(@_);
- return $nntp->tied_fh;
-}
-
-
-sub authinfo {
- @_ == 3 or croak 'usage: $nntp->authinfo( USER, PASS )';
- my ($nntp, $user, $pass) = @_;
-
- $nntp->_AUTHINFO("USER", $user) == CMD_MORE
- && $nntp->_AUTHINFO("PASS", $pass) == CMD_OK;
-}
-
-
-sub authinfo_simple {
- @_ == 3 or croak 'usage: $nntp->authinfo( USER, PASS )';
- my ($nntp, $user, $pass) = @_;
-
- $nntp->_AUTHINFO('SIMPLE') == CMD_MORE
- && $nntp->command($user, $pass)->response == CMD_OK;
-}
-
-
-sub body {
- @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->body( [ MSGID ], [ FH ] )';
- my $nntp = shift;
- my @fh;
-
- @fh = (pop) if @_ == 2 || (@_ && ref($_[0]) || ref(\$_[0]) eq 'GLOB');
-
- $nntp->_BODY(@_)
- ? $nntp->read_until_dot(@fh)
- : undef;
-}
-
-
-sub bodyfh {
- @_ >= 1 && @_ <= 2 or croak 'usage: $nntp->bodyfh( [ MSGID ] )';
- my $nntp = shift;
- return unless $nntp->_BODY(@_);
- return $nntp->tied_fh;
-}
-
-
-sub head {
- @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->head( [ MSGID ], [ FH ] )';
- my $nntp = shift;
- my @fh;
-
- @fh = (pop) if @_ == 2 || (@_ && ref($_[0]) || ref(\$_[0]) eq 'GLOB');
-
- $nntp->_HEAD(@_)
- ? $nntp->read_until_dot(@fh)
- : undef;
-}
-
-
-sub headfh {
- @_ >= 1 && @_ <= 2 or croak 'usage: $nntp->headfh( [ MSGID ] )';
- my $nntp = shift;
- return unless $nntp->_HEAD(@_);
- return $nntp->tied_fh;
-}
-
-
-sub nntpstat {
- @_ == 1 || @_ == 2 or croak 'usage: $nntp->nntpstat( [ MSGID ] )';
- my $nntp = shift;
-
- $nntp->_STAT(@_) && $nntp->message =~ /(<[^>]+>)/o
- ? $1
- : undef;
-}
-
-
-sub group {
- @_ == 1 || @_ == 2 or croak 'usage: $nntp->group( [ GROUP ] )';
- my $nntp = shift;
- my $grp = ${*$nntp}{'net_nntp_group'};
-
- return $grp
- unless (@_ || wantarray);
-
- my $newgrp = shift;
-
- $newgrp = (defined($grp) and length($grp)) ? $grp : ""
- unless defined($newgrp) and length($newgrp);
-
- return
- unless $nntp->_GROUP($newgrp) and $nntp->message =~ /(\d+)\s+(\d+)\s+(\d+)\s+(\S+)/;
-
- my ($count, $first, $last, $group) = ($1, $2, $3, $4);
-
- # group may be replied as '(current group)'
- $group = ${*$nntp}{'net_nntp_group'}
- if $group =~ /\(/;
-
- ${*$nntp}{'net_nntp_group'} = $group;
-
- wantarray
- ? ($count, $first, $last, $group)
- : $group;
-}
-
-
-sub help {
- @_ == 1 or croak 'usage: $nntp->help()';
- my $nntp = shift;
-
- $nntp->_HELP
- ? $nntp->read_until_dot
- : undef;
-}
-
-
-sub ihave {
- @_ >= 2 or croak 'usage: $nntp->ihave( MESSAGE-ID [, MESSAGE ])';
- my $nntp = shift;
- my $mid = shift;
-
- $nntp->_IHAVE($mid) && $nntp->datasend(@_)
- ? @_ == 0 || $nntp->dataend
- : undef;
-}
-
-
-sub last {
- @_ == 1 or croak 'usage: $nntp->last()';
- my $nntp = shift;
-
- $nntp->_LAST && $nntp->message =~ /(<[^>]+>)/o
- ? $1
- : undef;
-}
-
-
-sub list {
- @_ == 1 or croak 'usage: $nntp->list()';
- my $nntp = shift;
-
- $nntp->_LIST
- ? $nntp->_grouplist
- : undef;
-}
-
-
-sub newgroups {
- @_ >= 2 or croak 'usage: $nntp->newgroups( SINCE [, DISTRIBUTIONS ])';
- my $nntp = shift;
- my $time = _timestr(shift);
- my $dist = shift || "";
-
- $dist = join(",", @{$dist})
- if ref($dist);
-
- $nntp->_NEWGROUPS($time, $dist)
- ? $nntp->_grouplist
- : undef;
-}
-
-
-sub newnews {
- @_ >= 2 && @_ <= 4
- or croak 'usage: $nntp->newnews( SINCE [, GROUPS [, DISTRIBUTIONS ]])';
- my $nntp = shift;
- my $time = _timestr(shift);
- my $grp = @_ ? shift: $nntp->group;
- my $dist = shift || "";
-
- $grp ||= "*";
- $grp = join(",", @{$grp})
- if ref($grp);
-
- $dist = join(",", @{$dist})
- if ref($dist);
-
- $nntp->_NEWNEWS($grp, $time, $dist)
- ? $nntp->_articlelist
- : undef;
-}
-
-
-sub next {
- @_ == 1 or croak 'usage: $nntp->next()';
- my $nntp = shift;
-
- $nntp->_NEXT && $nntp->message =~ /(<[^>]+>)/o
- ? $1
- : undef;
-}
-
-
-sub post {
- @_ >= 1 or croak 'usage: $nntp->post( [ MESSAGE ] )';
- my $nntp = shift;
-
- $nntp->_POST() && $nntp->datasend(@_)
- ? @_ == 0 || $nntp->dataend
- : undef;
-}
-
-
-sub postfh {
- my $nntp = shift;
- return unless $nntp->_POST();
- return $nntp->tied_fh;
-}
-
-
-sub quit {
- @_ == 1 or croak 'usage: $nntp->quit()';
- my $nntp = shift;
-
- $nntp->_QUIT;
- $nntp->close;
-}
-
-
-sub slave {
- @_ == 1 or croak 'usage: $nntp->slave()';
- my $nntp = shift;
-
- $nntp->_SLAVE;
-}
-
-##
-## The following methods are not implemented by all servers
-##
-
-
-sub active {
- @_ == 1 || @_ == 2 or croak 'usage: $nntp->active( [ PATTERN ] )';
- my $nntp = shift;
-
- $nntp->_LIST('ACTIVE', @_)
- ? $nntp->_grouplist
- : undef;
-}
-
-
-sub active_times {
- @_ == 1 or croak 'usage: $nntp->active_times()';
- my $nntp = shift;
-
- $nntp->_LIST('ACTIVE.TIMES')
- ? $nntp->_grouplist
- : undef;
-}
-
-
-sub distributions {
- @_ == 1 or croak 'usage: $nntp->distributions()';
- my $nntp = shift;
-
- $nntp->_LIST('DISTRIBUTIONS')
- ? $nntp->_description
- : undef;
-}
-
-
-sub distribution_patterns {
- @_ == 1 or croak 'usage: $nntp->distributions()';
- my $nntp = shift;
-
- my $arr;
- local $_;
-
- $nntp->_LIST('DISTRIB.PATS')
- && ($arr = $nntp->read_until_dot)
- ? [grep { /^\d/ && (chomp, $_ = [split /:/]) } @$arr]
- : undef;
-}
-
-
-sub newsgroups {
- @_ == 1 || @_ == 2 or croak 'usage: $nntp->newsgroups( [ PATTERN ] )';
- my $nntp = shift;
-
- $nntp->_LIST('NEWSGROUPS', @_)
- ? $nntp->_description
- : undef;
-}
-
-
-sub overview_fmt {
- @_ == 1 or croak 'usage: $nntp->overview_fmt()';
- my $nntp = shift;
-
- $nntp->_LIST('OVERVIEW.FMT')
- ? $nntp->_articlelist
- : undef;
-}
-
-
-sub subscriptions {
- @_ == 1 or croak 'usage: $nntp->subscriptions()';
- my $nntp = shift;
-
- $nntp->_LIST('SUBSCRIPTIONS')
- ? $nntp->_articlelist
- : undef;
-}
-
-
-sub listgroup {
- @_ == 1 || @_ == 2 or croak 'usage: $nntp->listgroup( [ GROUP ] )';
- my $nntp = shift;
-
- $nntp->_LISTGROUP(@_)
- ? $nntp->_articlelist
- : undef;
-}
-
-
-sub reader {
- @_ == 1 or croak 'usage: $nntp->reader()';
- my $nntp = shift;
-
- $nntp->_MODE('READER');
-}
-
-
-sub xgtitle {
- @_ == 1 || @_ == 2 or croak 'usage: $nntp->xgtitle( [ PATTERN ] )';
- my $nntp = shift;
-
- $nntp->_XGTITLE(@_)
- ? $nntp->_description
- : undef;
-}
-
-
-sub xhdr {
- @_ >= 2 && @_ <= 4 or croak 'usage: $nntp->xhdr( HEADER, [ MESSAGE-SPEC ] )';
- my $nntp = shift;
- my $hdr = shift;
- my $arg = _msg_arg(@_);
-
- $nntp->_XHDR($hdr, $arg)
- ? $nntp->_description
- : undef;
-}
-
-
-sub xover {
- @_ == 2 || @_ == 3 or croak 'usage: $nntp->xover( MESSAGE-SPEC )';
- my $nntp = shift;
- my $arg = _msg_arg(@_);
-
- $nntp->_XOVER($arg)
- ? $nntp->_fieldlist
- : undef;
-}
-
-
-sub xpat {
- @_ == 4 || @_ == 5 or croak '$nntp->xpat( HEADER, PATTERN, MESSAGE-SPEC )';
- my $nntp = shift;
- my $hdr = shift;
- my $pat = shift;
- my $arg = _msg_arg(@_);
-
- $pat = join(" ", @$pat)
- if ref($pat);
-
- $nntp->_XPAT($hdr, $arg, $pat)
- ? $nntp->_description
- : undef;
-}
-
-
-sub xpath {
- @_ == 2 or croak 'usage: $nntp->xpath( MESSAGE-ID )';
- my ($nntp, $mid) = @_;
-
- return undef
- unless $nntp->_XPATH($mid);
-
- my $m;
- ($m = $nntp->message) =~ s/^\d+\s+//o;
- my @p = split /\s+/, $m;
-
- wantarray ? @p : $p[0];
-}
-
-
-sub xrover {
- @_ == 2 || @_ == 3 or croak 'usage: $nntp->xrover( MESSAGE-SPEC )';
- my $nntp = shift;
- my $arg = _msg_arg(@_);
-
- $nntp->_XROVER($arg)
- ? $nntp->_description
- : undef;
-}
-
-
-sub date {
- @_ == 1 or croak 'usage: $nntp->date()';
- my $nntp = shift;
-
- $nntp->_DATE
- && $nntp->message =~ /(\d{4})(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/
- ? timegm($6, $5, $4, $3, $2 - 1, $1 - 1900)
- : undef;
-}
-
-
-##
-## Private subroutines
-##
-
-
-sub _msg_arg {
- my $spec = shift;
- my $arg = "";
-
- if (@_) {
- carp "Depriciated passing of two message numbers, " . "pass a reference"
- if $^W;
- $spec = [$spec, $_[0]];
- }
-
- if (defined $spec) {
- if (ref($spec)) {
- $arg = $spec->[0];
- if (defined $spec->[1]) {
- $arg .= "-"
- if $spec->[1] != $spec->[0];
- $arg .= $spec->[1]
- if $spec->[1] > $spec->[0];
- }
- }
- else {
- $arg = $spec;
- }
- }
-
- $arg;
-}
-
-
-sub _timestr {
- my $time = shift;
- my @g = reverse((gmtime($time))[0 .. 5]);
- $g[1] += 1;
- $g[0] %= 100;
- sprintf "%02d%02d%02d %02d%02d%02d GMT", @g;
-}
-
-
-sub _grouplist {
- my $nntp = shift;
- my $arr = $nntp->read_until_dot
- or return undef;
-
- my $hash = {};
- my $ln;
-
- foreach $ln (@$arr) {
- my @a = split(/[\s\n]+/, $ln);
- $hash->{$a[0]} = [@a[1, 2, 3]];
- }
-
- $hash;
-}
-
-
-sub _fieldlist {
- my $nntp = shift;
- my $arr = $nntp->read_until_dot
- or return undef;
-
- my $hash = {};
- my $ln;
-
- foreach $ln (@$arr) {
- my @a = split(/[\t\n]/, $ln);
- my $m = shift @a;
- $hash->{$m} = [@a];
- }
-
- $hash;
-}
-
-
-sub _articlelist {
- my $nntp = shift;
- my $arr = $nntp->read_until_dot;
-
- chomp(@$arr)
- if $arr;
-
- $arr;
-}
-
-
-sub _description {
- my $nntp = shift;
- my $arr = $nntp->read_until_dot
- or return undef;
-
- my $hash = {};
- my $ln;
-
- foreach $ln (@$arr) {
- chomp($ln);
-
- $hash->{$1} = $ln
- if $ln =~ s/^\s*(\S+)\s*//o;
- }
-
- $hash;
-
-}
-
-##
-## The commands
-##
-
-
-sub _ARTICLE { shift->command('ARTICLE', @_)->response == CMD_OK }
-sub _AUTHINFO { shift->command('AUTHINFO', @_)->response }
-sub _BODY { shift->command('BODY', @_)->response == CMD_OK }
-sub _DATE { shift->command('DATE')->response == CMD_INFO }
-sub _GROUP { shift->command('GROUP', @_)->response == CMD_OK }
-sub _HEAD { shift->command('HEAD', @_)->response == CMD_OK }
-sub _HELP { shift->command('HELP', @_)->response == CMD_INFO }
-sub _IHAVE { shift->command('IHAVE', @_)->response == CMD_MORE }
-sub _LAST { shift->command('LAST')->response == CMD_OK }
-sub _LIST { shift->command('LIST', @_)->response == CMD_OK }
-sub _LISTGROUP { shift->command('LISTGROUP', @_)->response == CMD_OK }
-sub _NEWGROUPS { shift->command('NEWGROUPS', @_)->response == CMD_OK }
-sub _NEWNEWS { shift->command('NEWNEWS', @_)->response == CMD_OK }
-sub _NEXT { shift->command('NEXT')->response == CMD_OK }
-sub _POST { shift->command('POST', @_)->response == CMD_MORE }
-sub _QUIT { shift->command('QUIT', @_)->response == CMD_OK }
-sub _SLAVE { shift->command('SLAVE', @_)->response == CMD_OK }
-sub _STAT { shift->command('STAT', @_)->response == CMD_OK }
-sub _MODE { shift->command('MODE', @_)->response == CMD_OK }
-sub _XGTITLE { shift->command('XGTITLE', @_)->response == CMD_OK }
-sub _XHDR { shift->command('XHDR', @_)->response == CMD_OK }
-sub _XPAT { shift->command('XPAT', @_)->response == CMD_OK }
-sub _XPATH { shift->command('XPATH', @_)->response == CMD_OK }
-sub _XOVER { shift->command('XOVER', @_)->response == CMD_OK }
-sub _XROVER { shift->command('XROVER', @_)->response == CMD_OK }
-sub _XTHREAD { shift->unsupported }
-sub _XSEARCH { shift->unsupported }
-sub _XINDEX { shift->unsupported }
-
-##
-## IO/perl methods
-##
-
-
-sub DESTROY {
- my $nntp = shift;
- defined(fileno($nntp)) && $nntp->quit;
-}
-
-
-1;
-
-__END__
-
-=head1 NAME
-
-Net::NNTP - NNTP Client class
-
-=head1 SYNOPSIS
-
- use Net::NNTP;
-
- $nntp = Net::NNTP->new("some.host.name");
- $nntp->quit;
-
-=head1 DESCRIPTION
-
-C<Net::NNTP> is a class implementing a simple NNTP client in Perl as described
-in RFC977.
-
-The Net::NNTP class is a subclass of Net::Cmd and IO::Socket::INET.
-
-=head1 CONSTRUCTOR
-
-=over 4
-
-=item new ( [ HOST ] [, OPTIONS ])
-
-This is the constructor for a new Net::NNTP object. C<HOST> is the
-name of the remote host to which a NNTP connection is required. If not
-given then it may be passed as the C<Host> option described below. If no host is passed
-then two environment variables are checked, first C<NNTPSERVER> then
-C<NEWSHOST>, then C<Net::Config> is checked, and if a host is not found
-then C<news> is used.
-
-C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
-Possible options are:
-
-B<Host> - NNTP host to connect to. It may be a single scalar, as defined for
-the C<PeerAddr> option in L<IO::Socket::INET>, or a reference to
-an array with hosts to try in turn. The L</host> method will return the value
-which was used to connect to the host.
-
-B<Timeout> - Maximum time, in seconds, to wait for a response from the
-NNTP server, a value of zero will cause all IO operations to block.
-(default: 120)
-
-B<Debug> - Enable the printing of debugging information to STDERR
-
-B<Reader> - If the remote server is INN then initially the connection
-will be to nnrpd, by default C<Net::NNTP> will issue a C<MODE READER> command
-so that the remote server becomes innd. If the C<Reader> option is given
-with a value of zero, then this command will not be sent and the
-connection will be left talking to nnrpd.
-
-B<LocalAddr> - If multiple IP addresses are present on the client host
-with a valid route to the destination, you can specify the address your
-C<Net::NNTP> connects from and this way override the operating system's
-pick.
-
-=back
-
-=head1 METHODS
-
-Unless otherwise stated all methods return either a I<true> or I<false>
-value, with I<true> meaning that the operation was a success. When a method
-states that it returns a value, failure will be returned as I<undef> or an
-empty list.
-
-C<Net::NNTP> inherits from C<Net::Cmd> so methods defined in C<Net::Cmd> may
-be used to send commands to the remote NNTP server in addition to the methods
-documented here.
-
-=over 4
-
-=item article ( [ MSGID|MSGNUM ], [FH] )
-
-Retrieve the header, a blank line, then the body (text) of the
-specified article.
-
-If C<FH> is specified then it is expected to be a valid filehandle
-and the result will be printed to it, on success a true value will be
-returned. If C<FH> is not specified then the return value, on success,
-will be a reference to an array containing the article requested, each
-entry in the array will contain one line of the article.
-
-If no arguments are passed then the current article in the currently
-selected newsgroup is fetched.
-
-C<MSGNUM> is a numeric id of an article in the current newsgroup, and
-will change the current article pointer. C<MSGID> is the message id of
-an article as shown in that article's header. It is anticipated that the
-client will obtain the C<MSGID> from a list provided by the C<newnews>
-command, from references contained within another article, or from the
-message-id provided in the response to some other commands.
-
-If there is an error then C<undef> will be returned.
-
-=item body ( [ MSGID|MSGNUM ], [FH] )
-
-Like C<article> but only fetches the body of the article.
-
-=item head ( [ MSGID|MSGNUM ], [FH] )
-
-Like C<article> but only fetches the headers for the article.
-
-=item articlefh ( [ MSGID|MSGNUM ] )
-
-=item bodyfh ( [ MSGID|MSGNUM ] )
-
-=item headfh ( [ MSGID|MSGNUM ] )
-
-These are similar to article(), body() and head(), but rather than
-returning the requested data directly, they return a tied filehandle
-from which to read the article.
-
-=item nntpstat ( [ MSGID|MSGNUM ] )
-
-The C<nntpstat> command is similar to the C<article> command except that no
-text is returned. When selecting by message number within a group,
-the C<nntpstat> command serves to set the "current article pointer" without
-sending text.
-
-Using the C<nntpstat> command to
-select by message-id is valid but of questionable value, since a
-selection by message-id does B<not> alter the "current article pointer".
-
-Returns the message-id of the "current article".
-
-=item group ( [ GROUP ] )
-
-Set and/or get the current group. If C<GROUP> is not given then information
-is returned on the current group.
-
-In a scalar context it returns the group name.
-
-In an array context the return value is a list containing, the number
-of articles in the group, the number of the first article, the number
-of the last article and the group name.
-
-=item ihave ( MSGID [, MESSAGE ])
-
-The C<ihave> command informs the server that the client has an article
-whose id is C<MSGID>. If the server desires a copy of that
-article, and C<MESSAGE> has been given the it will be sent.
-
-Returns I<true> if the server desires the article and C<MESSAGE> was
-successfully sent,if specified.
-
-If C<MESSAGE> is not specified then the message must be sent using the
-C<datasend> and C<dataend> methods from L<Net::Cmd>
-
-C<MESSAGE> can be either an array of lines or a reference to an array.
-
-=item last ()
-
-Set the "current article pointer" to the previous article in the current
-newsgroup.
-
-Returns the message-id of the article.
-
-=item date ()
-
-Returns the date on the remote server. This date will be in a UNIX time
-format (seconds since 1970)
-
-=item postok ()
-
-C<postok> will return I<true> if the servers initial response indicated
-that it will allow posting.
-
-=item authinfo ( USER, PASS )
-
-Authenticates to the server (using AUTHINFO USER / AUTHINFO PASS)
-using the supplied username and password. Please note that the
-password is sent in clear text to the server. This command should not
-be used with valuable passwords unless the connection to the server is
-somehow protected.
-
-=item list ()
-
-Obtain information about all the active newsgroups. The results is a reference
-to a hash where the key is a group name and each value is a reference to an
-array. The elements in this array are:- the last article number in the group,
-the first article number in the group and any information flags about the group.
-
-=item newgroups ( SINCE [, DISTRIBUTIONS ])
-
-C<SINCE> is a time value and C<DISTRIBUTIONS> is either a distribution
-pattern or a reference to a list of distribution patterns.
-The result is the same as C<list>, but the
-groups return will be limited to those created after C<SINCE> and, if
-specified, in one of the distribution areas in C<DISTRIBUTIONS>.
-
-=item newnews ( SINCE [, GROUPS [, DISTRIBUTIONS ]])
-
-C<SINCE> is a time value. C<GROUPS> is either a group pattern or a reference
-to a list of group patterns. C<DISTRIBUTIONS> is either a distribution
-pattern or a reference to a list of distribution patterns.
-
-Returns a reference to a list which contains the message-ids of all news posted
-after C<SINCE>, that are in a groups which matched C<GROUPS> and a
-distribution which matches C<DISTRIBUTIONS>.
-
-=item next ()
-
-Set the "current article pointer" to the next article in the current
-newsgroup.
-
-Returns the message-id of the article.
-
-=item post ( [ MESSAGE ] )
-
-Post a new article to the news server. If C<MESSAGE> is specified and posting
-is allowed then the message will be sent.
-
-If C<MESSAGE> is not specified then the message must be sent using the
-C<datasend> and C<dataend> methods from L<Net::Cmd>
-
-C<MESSAGE> can be either an array of lines or a reference to an array.
-
-The message, either sent via C<datasend> or as the C<MESSAGE>
-parameter, must be in the format as described by RFC822 and must
-contain From:, Newsgroups: and Subject: headers.
-
-=item postfh ()
-
-Post a new article to the news server using a tied filehandle. If
-posting is allowed, this method will return a tied filehandle that you
-can print() the contents of the article to be posted. You must
-explicitly close() the filehandle when you are finished posting the
-article, and the return value from the close() call will indicate
-whether the message was successfully posted.
-
-=item slave ()
-
-Tell the remote server that I am not a user client, but probably another
-news server.
-
-=item quit ()
-
-Quit the remote server and close the socket connection.
-
-=back
-
-=head2 Extension methods
-
-These methods use commands that are not part of the RFC977 documentation. Some
-servers may not support all of them.
-
-=over 4
-
-=item newsgroups ( [ PATTERN ] )
-
-Returns a reference to a hash where the keys are all the group names which
-match C<PATTERN>, or all of the groups if no pattern is specified, and
-each value contains the description text for the group.
-
-=item distributions ()
-
-Returns a reference to a hash where the keys are all the possible
-distribution names and the values are the distribution descriptions.
-
-=item subscriptions ()
-
-Returns a reference to a list which contains a list of groups which
-are recommended for a new user to subscribe to.
-
-=item overview_fmt ()
-
-Returns a reference to an array which contain the names of the fields returned
-by C<xover>.
-
-=item active_times ()
-
-Returns a reference to a hash where the keys are the group names and each
-value is a reference to an array containing the time the groups was created
-and an identifier, possibly an Email address, of the creator.
-
-=item active ( [ PATTERN ] )
-
-Similar to C<list> but only active groups that match the pattern are returned.
-C<PATTERN> can be a group pattern.
-
-=item xgtitle ( PATTERN )
-
-Returns a reference to a hash where the keys are all the group names which
-match C<PATTERN> and each value is the description text for the group.
-
-=item xhdr ( HEADER, MESSAGE-SPEC )
-
-Obtain the header field C<HEADER> for all the messages specified.
-
-The return value will be a reference
-to a hash where the keys are the message numbers and each value contains
-the text of the requested header for that message.
-
-=item xover ( MESSAGE-SPEC )
-
-The return value will be a reference
-to a hash where the keys are the message numbers and each value contains
-a reference to an array which contains the overview fields for that
-message.
-
-The names of the fields can be obtained by calling C<overview_fmt>.
-
-=item xpath ( MESSAGE-ID )
-
-Returns the path name to the file on the server which contains the specified
-message.
-
-=item xpat ( HEADER, PATTERN, MESSAGE-SPEC)
-
-The result is the same as C<xhdr> except the is will be restricted to
-headers where the text of the header matches C<PATTERN>
-
-=item xrover
-
-The XROVER command returns reference information for the article(s)
-specified.
-
-Returns a reference to a HASH where the keys are the message numbers and the
-values are the References: lines from the articles
-
-=item listgroup ( [ GROUP ] )
-
-Returns a reference to a list of all the active messages in C<GROUP>, or
-the current group if C<GROUP> is not specified.
-
-=item reader
-
-Tell the server that you are a reader and not another server.
-
-This is required by some servers. For example if you are connecting to
-an INN server and you have transfer permission your connection will
-be connected to the transfer daemon, not the NNTP daemon. Issuing
-this command will cause the transfer daemon to hand over control
-to the NNTP daemon.
-
-Some servers do not understand this command, but issuing it and ignoring
-the response is harmless.
-
-=back
-
-=head1 UNSUPPORTED
-
-The following NNTP command are unsupported by the package, and there are
-no plans to do so.
-
- AUTHINFO GENERIC
- XTHREAD
- XSEARCH
- XINDEX
-
-=head1 DEFINITIONS
-
-=over 4
-
-=item MESSAGE-SPEC
-
-C<MESSAGE-SPEC> is either a single message-id, a single message number, or
-a reference to a list of two message numbers.
-
-If C<MESSAGE-SPEC> is a reference to a list of two message numbers and the
-second number in a range is less than or equal to the first then the range
-represents all messages in the group after the first message number.
-
-B<NOTE> For compatibility reasons only with earlier versions of Net::NNTP
-a message spec can be passed as a list of two numbers, this is deprecated
-and a reference to the list should now be passed
-
-=item PATTERN
-
-The C<NNTP> protocol uses the C<WILDMAT> format for patterns.
-The WILDMAT format was first developed by Rich Salz based on
-the format used in the UNIX "find" command to articulate
-file names. It was developed to provide a uniform mechanism
-for matching patterns in the same manner that the UNIX shell
-matches filenames.
-
-Patterns are implicitly anchored at the
-beginning and end of each string when testing for a match.
-
-There are five pattern matching operations other than a strict
-one-to-one match between the pattern and the source to be
-checked for a match.
-
-The first is an asterisk C<*> to match any sequence of zero or more
-characters.
-
-The second is a question mark C<?> to match any single character. The
-third specifies a specific set of characters.
-
-The set is specified as a list of characters, or as a range of characters
-where the beginning and end of the range are separated by a minus (or dash)
-character, or as any combination of lists and ranges. The dash can
-also be included in the set as a character it if is the beginning
-or end of the set. This set is enclosed in square brackets. The
-close square bracket C<]> may be used in a set if it is the first
-character in the set.
-
-The fourth operation is the same as the
-logical not of the third operation and is specified the same
-way as the third with the addition of a caret character C<^> at
-the beginning of the test string just inside the open square
-bracket.
-
-The final operation uses the backslash character to
-invalidate the special meaning of an open square bracket C<[>,
-the asterisk, backslash or the question mark. Two backslashes in
-sequence will result in the evaluation of the backslash as a
-character with no special meaning.
-
-=over 4
-
-=item Examples
-
-=item C<[^]-]>
-
-matches any single character other than a close square
-bracket or a minus sign/dash.
-
-=item C<*bdc>
-
-matches any string that ends with the string "bdc"
-including the string "bdc" (without quotes).
-
-=item C<[0-9a-zA-Z]>
-
-matches any single printable alphanumeric ASCII character.
-
-=item C<a??d>
-
-matches any four character string which begins
-with a and ends with d.
-
-=back
-
-=back
-
-=head1 SEE ALSO
-
-L<Net::Cmd>
-
-=head1 AUTHOR
-
-Graham Barr <gbarr@pobox.com>
-
-=head1 COPYRIGHT
-
-Copyright (c) 1995-1997 Graham Barr. All rights reserved.
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=cut
@@ -1,333 +0,0 @@
-# Net::Netrc.pm
-#
-# Copyright (c) 1995-1998 Graham Barr <gbarr@pobox.com>. All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-
-package Net::Netrc;
-
-use Carp;
-use strict;
-use FileHandle;
-use vars qw($VERSION $TESTING);
-
-$VERSION = "2.14";
-
-my %netrc = ();
-
-
-sub _readrc {
- my $host = shift;
- my ($home, $file);
-
- if ($^O eq "MacOS") {
- $home = $ENV{HOME} || `pwd`;
- chomp($home);
- $file = ($home =~ /:$/ ? $home . "netrc" : $home . ":netrc");
- }
- else {
-
- # Some OS's don't have "getpwuid", so we default to $ENV{HOME}
- $home = eval { (getpwuid($>))[7] } || $ENV{HOME};
- $home ||= $ENV{HOMEDRIVE} . ($ENV{HOMEPATH} || '') if defined $ENV{HOMEDRIVE};
- 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) {
- carp "Bad permissions: $file";
- return;
- }
- if ($stat[4] != $<) {
- carp "Not owner: $file";
- return;
- }
- }
- }
-
- if ($fh = FileHandle->new($file, "r")) {
- my ($mach, $macdef, $tok, @tok) = (0, 0);
-
- while (<$fh>) {
- undef $macdef if /\A\n\Z/;
-
- if ($macdef) {
- push(@$macdef, $_);
- next;
- }
-
- s/^\s*//;
- chomp;
-
- while (length && s/^("((?:[^"]+|\\.)*)"|((?:[^\\\s]+|\\.)*))\s*//) {
- (my $tok = $+) =~ s/\\(.)/$1/g;
- push(@tok, $tok);
- }
-
- TOKEN:
- while (@tok) {
- if ($tok[0] eq "default") {
- shift(@tok);
- $mach = bless {};
- $netrc{default} = [$mach];
-
- next TOKEN;
- }
-
- last TOKEN
- unless @tok > 1;
-
- $tok = shift(@tok);
-
- if ($tok eq "machine") {
- my $host = shift @tok;
- $mach = bless {machine => $host};
-
- $netrc{$host} = []
- unless exists($netrc{$host});
- push(@{$netrc{$host}}, $mach);
- }
- elsif ($tok =~ /^(login|password|account)$/) {
- next TOKEN unless $mach;
- my $value = shift @tok;
-
- # Following line added by rmerrell to remove '/' escape char in .netrc
- $value =~ s/\/\\/\\/g;
- $mach->{$1} = $value;
- }
- elsif ($tok eq "macdef") {
- next TOKEN unless $mach;
- my $value = shift @tok;
- $mach->{macdef} = {}
- unless exists $mach->{macdef};
- $macdef = $mach->{machdef}{$value} = [];
- }
- }
- }
- $fh->close();
- }
-}
-
-
-sub lookup {
- my ($pkg, $mach, $login) = @_;
-
- _readrc()
- unless exists $netrc{default};
-
- $mach ||= 'default';
- undef $login
- if $mach eq 'default';
-
- if (exists $netrc{$mach}) {
- if (defined $login) {
- my $m;
- foreach $m (@{$netrc{$mach}}) {
- return $m
- if (exists $m->{login} && $m->{login} eq $login);
- }
- return undef;
- }
- return $netrc{$mach}->[0];
- }
-
- return $netrc{default}->[0]
- if defined $netrc{default};
-
- return undef;
-}
-
-
-sub login {
- my $me = shift;
-
- exists $me->{login}
- ? $me->{login}
- : undef;
-}
-
-
-sub account {
- my $me = shift;
-
- exists $me->{account}
- ? $me->{account}
- : undef;
-}
-
-
-sub password {
- my $me = shift;
-
- exists $me->{password}
- ? $me->{password}
- : undef;
-}
-
-
-sub lpa {
- my $me = shift;
- ($me->login, $me->password, $me->account);
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-Net::Netrc - OO interface to users netrc file
-
-=head1 SYNOPSIS
-
- use Net::Netrc;
-
- $mach = Net::Netrc->lookup('some.machine');
- $login = $mach->login;
- ($login, $password, $account) = $mach->lpa;
-
-=head1 DESCRIPTION
-
-C<Net::Netrc> is a class implementing a simple interface to the .netrc file
-used as by the ftp program.
-
-C<Net::Netrc> also implements security checks just like the ftp program,
-these checks are, first that the .netrc file must be owned by the user and
-second the ownership permissions should be such that only the owner has
-read and write access. If these conditions are not met then a warning is
-output and the .netrc file is not read.
-
-=head1 THE .netrc FILE
-
-The .netrc file contains login and initialization information used by the
-auto-login process. It resides in the user's home directory. The following
-tokens are recognized; they may be separated by spaces, tabs, or new-lines:
-
-=over 4
-
-=item machine name
-
-Identify a remote machine name. The auto-login process searches
-the .netrc file for a machine token that matches the remote machine
-specified. Once a match is made, the subsequent .netrc tokens
-are processed, stopping when the end of file is reached or an-
-other machine or a default token is encountered.
-
-=item default
-
-This is the same as machine name except that default matches
-any name. There can be only one default token, and it must be
-after all machine tokens. This is normally used as:
-
- default login anonymous password user@site
-
-thereby giving the user automatic anonymous login to machines
-not specified in .netrc.
-
-=item login name
-
-Identify a user on the remote machine. If this token is present,
-the auto-login process will initiate a login using the
-specified name.
-
-=item password string
-
-Supply a password. If this token is present, the auto-login
-process will supply the specified string if the remote server
-requires a password as part of the login process.
-
-=item account string
-
-Supply an additional account password. If this token is present,
-the auto-login process will supply the specified string
-if the remote server requires an additional account password.
-
-=item macdef name
-
-Define a macro. C<Net::Netrc> only parses this field to be compatible
-with I<ftp>.
-
-=back
-
-=head1 CONSTRUCTOR
-
-The constructor for a C<Net::Netrc> object is not called new as it does not
-really create a new object. But instead is called C<lookup> as this is
-essentially what it does.
-
-=over 4
-
-=item lookup ( MACHINE [, LOGIN ])
-
-Lookup and return a reference to the entry for C<MACHINE>. If C<LOGIN> is given
-then the entry returned will have the given login. If C<LOGIN> is not given then
-the first entry in the .netrc file for C<MACHINE> will be returned.
-
-If a matching entry cannot be found, and a default entry exists, then a
-reference to the default entry is returned.
-
-If there is no matching entry found and there is no default defined, or
-no .netrc file is found, then C<undef> is returned.
-
-=back
-
-=head1 METHODS
-
-=over 4
-
-=item login ()
-
-Return the login id for the netrc entry
-
-=item password ()
-
-Return the password for the netrc entry
-
-=item account ()
-
-Return the account information for the netrc entry
-
-=item lpa ()
-
-Return a list of login, password and account information for the netrc entry
-
-=back
-
-=head1 AUTHOR
-
-Graham Barr <gbarr@pobox.com>
-
-=head1 SEE ALSO
-
-L<Net::Netrc>
-L<Net::Cmd>
-
-=head1 COPYRIGHT
-
-Copyright (c) 1995-1998 Graham Barr. All rights reserved.
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=cut
@@ -1,744 +0,0 @@
-# Net::POP3.pm
-#
-# Copyright (c) 1995-2004 Graham Barr <gbarr@pobox.com>. All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-
-package Net::POP3;
-
-use strict;
-use IO::Socket;
-use vars qw(@ISA $VERSION $debug);
-use Net::Cmd;
-use Carp;
-use Net::Config;
-
-$VERSION = "2.31";
-
-@ISA = qw(Net::Cmd IO::Socket::INET);
-
-
-sub new {
- my $self = shift;
- my $type = ref($self) || $self;
- my ($host, %arg);
- if (@_ % 2) {
- $host = shift;
- %arg = @_;
- }
- else {
- %arg = @_;
- $host = delete $arg{Host};
- }
- my $hosts = defined $host ? [$host] : $NetConfig{pop3_hosts};
- my $obj;
- my @localport = exists $arg{ResvPort} ? (LocalPort => $arg{ResvPort}) : ();
-
- my $h;
- foreach $h (@{$hosts}) {
- $obj = $type->SUPER::new(
- PeerAddr => ($host = $h),
- PeerPort => $arg{Port} || 'pop3(110)',
- Proto => 'tcp',
- @localport,
- Timeout => defined $arg{Timeout}
- ? $arg{Timeout}
- : 120
- )
- and last;
- }
-
- return undef
- unless defined $obj;
-
- ${*$obj}{'net_pop3_host'} = $host;
-
- $obj->autoflush(1);
- $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
-
- unless ($obj->response() == CMD_OK) {
- $obj->close();
- return undef;
- }
-
- ${*$obj}{'net_pop3_banner'} = $obj->message;
-
- $obj;
-}
-
-
-sub host {
- my $me = shift;
- ${*$me}{'net_pop3_host'};
-}
-
-##
-## We don't want people sending me their passwords when they report problems
-## now do we :-)
-##
-
-
-sub debug_text { $_[2] =~ /^(pass|rpop)/i ? "$1 ....\n" : $_[2]; }
-
-
-sub login {
- @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->login( USER, PASS )';
- my ($me, $user, $pass) = @_;
-
- if (@_ <= 2) {
- ($user, $pass) = $me->_lookup_credentials($user);
- }
-
- $me->user($user)
- and $me->pass($pass);
-}
-
-
-sub apop {
- @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->apop( USER, PASS )';
- my ($me, $user, $pass) = @_;
- my $banner;
- my $md;
-
- if (eval { local $SIG{__DIE__}; require Digest::MD5 }) {
- $md = Digest::MD5->new();
- }
- elsif (eval { local $SIG{__DIE__}; require MD5 }) {
- $md = MD5->new();
- }
- else {
- carp "You need to install Digest::MD5 or MD5 to use the APOP command";
- return undef;
- }
-
- return undef
- unless ($banner = (${*$me}{'net_pop3_banner'} =~ /(<.*>)/)[0]);
-
- if (@_ <= 2) {
- ($user, $pass) = $me->_lookup_credentials($user);
- }
-
- $md->add($banner, $pass);
-
- return undef
- unless ($me->_APOP($user, $md->hexdigest));
-
- $me->_get_mailbox_count();
-}
-
-
-sub user {
- @_ == 2 or croak 'usage: $pop3->user( USER )';
- $_[0]->_USER($_[1]) ? 1 : undef;
-}
-
-
-sub pass {
- @_ == 2 or croak 'usage: $pop3->pass( PASS )';
-
- my ($me, $pass) = @_;
-
- return undef
- unless ($me->_PASS($pass));
-
- $me->_get_mailbox_count();
-}
-
-
-sub reset {
- @_ == 1 or croak 'usage: $obj->reset()';
-
- my $me = shift;
-
- return 0
- unless ($me->_RSET);
-
- if (defined ${*$me}{'net_pop3_mail'}) {
- local $_;
- foreach (@{${*$me}{'net_pop3_mail'}}) {
- delete $_->{'net_pop3_deleted'};
- }
- }
-}
-
-
-sub last {
- @_ == 1 or croak 'usage: $obj->last()';
-
- return undef
- unless $_[0]->_LAST && $_[0]->message =~ /(\d+)/;
-
- return $1;
-}
-
-
-sub top {
- @_ == 2 || @_ == 3 or croak 'usage: $pop3->top( MSGNUM [, NUMLINES ])';
- my $me = shift;
-
- return undef
- unless $me->_TOP($_[0], $_[1] || 0);
-
- $me->read_until_dot;
-}
-
-
-sub popstat {
- @_ == 1 or croak 'usage: $pop3->popstat()';
- my $me = shift;
-
- return ()
- unless $me->_STAT && $me->message =~ /(\d+)\D+(\d+)/;
-
- ($1 || 0, $2 || 0);
-}
-
-
-sub list {
- @_ == 1 || @_ == 2 or croak 'usage: $pop3->list( [ MSGNUM ] )';
- my $me = shift;
-
- return undef
- unless $me->_LIST(@_);
-
- if (@_) {
- $me->message =~ /\d+\D+(\d+)/;
- return $1 || undef;
- }
-
- my $info = $me->read_until_dot
- or return undef;
-
- my %hash = map { (/(\d+)\D+(\d+)/) } @$info;
-
- return \%hash;
-}
-
-
-sub get {
- @_ == 2 or @_ == 3 or croak 'usage: $pop3->get( MSGNUM [, FH ])';
- my $me = shift;
-
- return undef
- unless $me->_RETR(shift);
-
- $me->read_until_dot(@_);
-}
-
-
-sub getfh {
- @_ == 2 or croak 'usage: $pop3->getfh( MSGNUM )';
- my $me = shift;
-
- return unless $me->_RETR(shift);
- return $me->tied_fh;
-}
-
-
-sub delete {
- @_ == 2 or croak 'usage: $pop3->delete( MSGNUM )';
- my $me = shift;
- return 0 unless $me->_DELE(@_);
- ${*$me}{'net_pop3_deleted'} = 1;
-}
-
-
-sub uidl {
- @_ == 1 || @_ == 2 or croak 'usage: $pop3->uidl( [ MSGNUM ] )';
- my $me = shift;
- my $uidl;
-
- $me->_UIDL(@_)
- or return undef;
- if (@_) {
- $uidl = ($me->message =~ /\d+\s+([\041-\176]+)/)[0];
- }
- else {
- my $ref = $me->read_until_dot
- or return undef;
- my $ln;
- $uidl = {};
- foreach $ln (@$ref) {
- my ($msg, $uid) = $ln =~ /^\s*(\d+)\s+([\041-\176]+)/;
- $uidl->{$msg} = $uid;
- }
- }
- return $uidl;
-}
-
-
-sub ping {
- @_ == 2 or croak 'usage: $pop3->ping( USER )';
- my $me = shift;
-
- return () unless $me->_PING(@_) && $me->message =~ /(\d+)\D+(\d+)/;
-
- ($1 || 0, $2 || 0);
-}
-
-
-sub _lookup_credentials {
- my ($me, $user) = @_;
-
- require Net::Netrc;
-
- $user ||= eval { local $SIG{__DIE__}; (getpwuid($>))[0] }
- || $ENV{NAME}
- || $ENV{USER}
- || $ENV{LOGNAME};
-
- my $m = Net::Netrc->lookup(${*$me}{'net_pop3_host'}, $user);
- $m ||= Net::Netrc->lookup(${*$me}{'net_pop3_host'});
-
- my $pass = $m
- ? $m->password || ""
- : "";
-
- ($user, $pass);
-}
-
-
-sub _get_mailbox_count {
- my ($me) = @_;
- my $ret = ${*$me}{'net_pop3_count'} =
- ($me->message =~ /(\d+)\s+message/io) ? $1 : ($me->popstat)[0];
-
- $ret ? $ret : "0E0";
-}
-
-
-sub _STAT { shift->command('STAT' )->response() == CMD_OK }
-sub _LIST { shift->command('LIST', @_)->response() == CMD_OK }
-sub _RETR { shift->command('RETR', $_[0])->response() == CMD_OK }
-sub _DELE { shift->command('DELE', $_[0])->response() == CMD_OK }
-sub _NOOP { shift->command('NOOP' )->response() == CMD_OK }
-sub _RSET { shift->command('RSET' )->response() == CMD_OK }
-sub _QUIT { shift->command('QUIT' )->response() == CMD_OK }
-sub _TOP { shift->command( 'TOP', @_)->response() == CMD_OK }
-sub _UIDL { shift->command('UIDL', @_)->response() == CMD_OK }
-sub _USER { shift->command('USER', $_[0])->response() == CMD_OK }
-sub _PASS { shift->command('PASS', $_[0])->response() == CMD_OK }
-sub _APOP { shift->command('APOP', @_)->response() == CMD_OK }
-sub _PING { shift->command('PING', $_[0])->response() == CMD_OK }
-sub _RPOP { shift->command('RPOP', $_[0])->response() == CMD_OK }
-sub _LAST { shift->command('LAST' )->response() == CMD_OK }
-sub _CAPA { shift->command('CAPA' )->response() == CMD_OK }
-
-
-sub quit {
- my $me = shift;
-
- $me->_QUIT;
- $me->close;
-}
-
-
-sub DESTROY {
- my $me = shift;
-
- if (defined fileno($me) and ${*$me}{'net_pop3_deleted'}) {
- $me->reset;
- $me->quit;
- }
-}
-
-##
-## POP3 has weird responses, so we emulate them to look the same :-)
-##
-
-
-sub response {
- my $cmd = shift;
- my $str = $cmd->getline() or return undef;
- my $code = "500";
-
- $cmd->debug_print(0, $str)
- if ($cmd->debug);
-
- if ($str =~ s/^\+OK\s*//io) {
- $code = "200";
- }
- elsif ($str =~ s/^\+\s*//io) {
- $code = "300";
- }
- else {
- $str =~ s/^-ERR\s*//io;
- }
-
- ${*$cmd}{'net_cmd_resp'} = [$str];
- ${*$cmd}{'net_cmd_code'} = $code;
-
- substr($code, 0, 1);
-}
-
-
-sub capa {
- my $this = shift;
- my ($capa, %capabilities);
-
- # Fake a capability here
- $capabilities{APOP} = '' if ($this->banner() =~ /<.*>/);
-
- if ($this->_CAPA()) {
- $capabilities{CAPA} = 1;
- $capa = $this->read_until_dot();
- %capabilities = (%capabilities, map {/^\s*(\S+)\s*(.*)/} @$capa);
- }
- else {
-
- # Check AUTH for SASL capabilities
- if ($this->command('AUTH')->response() == CMD_OK) {
- my $mechanism = $this->read_until_dot();
- $capabilities{SASL} = join " ", map {m/([A-Z0-9_-]+)/} @{$mechanism};
- }
- }
-
- return ${*$this}{'net_pop3e_capabilities'} = \%capabilities;
-}
-
-
-sub capabilities {
- my $this = shift;
-
- ${*$this}{'net_pop3e_capabilities'} || $this->capa;
-}
-
-
-sub auth {
- my ($self, $username, $password) = @_;
-
- eval {
- require MIME::Base64;
- require Authen::SASL;
- } or $self->set_status(500, ["Need MIME::Base64 and Authen::SASL todo auth"]), return 0;
-
- my $capa = $self->capa;
- my $mechanisms = $capa->{SASL} || 'CRAM-MD5';
-
- my $sasl;
-
- if (ref($username) and UNIVERSAL::isa($username, 'Authen::SASL')) {
- $sasl = $username;
- my $user_mech = $sasl->mechanism || '';
- my @user_mech = split(/\s+/, $user_mech);
- my %user_mech;
- @user_mech{@user_mech} = ();
-
- my @server_mech = split(/\s+/, $mechanisms);
- my @mech = @user_mech
- ? grep { exists $user_mech{$_} } @server_mech
- : @server_mech;
- unless (@mech) {
- $self->set_status(
- 500,
- [ 'Client SASL mechanisms (',
- join(', ', @user_mech),
- ') do not match the SASL mechnism the server announces (',
- join(', ', @server_mech), ')',
- ]
- );
- return 0;
- }
-
- $sasl->mechanism(join(" ", @mech));
- }
- else {
- die "auth(username, password)" if not length $username;
- $sasl = Authen::SASL->new(
- mechanism => $mechanisms,
- callback => {
- user => $username,
- pass => $password,
- authname => $username,
- }
- );
- }
-
- # We should probably allow the user to pass the host, but I don't
- # currently know and SASL mechanisms that are used by smtp that need it
- my ($hostname) = split /:/, ${*$self}{'net_pop3_host'};
- my $client = eval { $sasl->client_new('pop', $hostname, 0) };
-
- unless ($client) {
- my $mech = $sasl->mechanism;
- $self->set_status(
- 500,
- [ " Authen::SASL failure: $@",
- '(please check if your local Authen::SASL installation',
- "supports mechanism '$mech'"
- ]
- );
- return 0;
- }
-
- my ($token) = $client->client_start
- or do {
- my $mech = $client->mechanism;
- $self->set_status(
- 500,
- [ ' Authen::SASL failure: $client->client_start ',
- "mechanism '$mech' hostname #$hostname#",
- $client->error
- ]
- );
- return 0;
- };
-
- # We 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'};
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-Net::POP3 - Post Office Protocol 3 Client class (RFC1939)
-
-=head1 SYNOPSIS
-
- use Net::POP3;
-
- # Constructors
- $pop = Net::POP3->new('pop3host');
- $pop = Net::POP3->new('pop3host', Timeout => 60);
-
- if ($pop->login($username, $password) > 0) {
- my $msgnums = $pop->list; # hashref of msgnum => size
- foreach my $msgnum (keys %$msgnums) {
- my $msg = $pop->get($msgnum);
- print @$msg;
- $pop->delete($msgnum);
- }
- }
-
- $pop->quit;
-
-=head1 DESCRIPTION
-
-This module implements a client interface to the POP3 protocol, enabling
-a perl5 application to talk to POP3 servers. This documentation assumes
-that you are familiar with the POP3 protocol described in RFC1939.
-
-A new Net::POP3 object must be created with the I<new> method. Once
-this has been done, all POP3 commands are accessed via method calls
-on the object.
-
-The Net::POP3 class is a subclass of Net::Cmd and IO::Socket::INET.
-
-=head1 CONSTRUCTOR
-
-=over 4
-
-=item new ( [ HOST ] [, OPTIONS ] )
-
-This is the constructor for a new Net::POP3 object. C<HOST> is the
-name of the remote host to which an POP3 connection is required.
-
-C<HOST> is optional. If C<HOST> is not given then it may instead be
-passed as the C<Host> option described below. If neither is given then
-the C<POP3_Hosts> specified in C<Net::Config> will be used.
-
-C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
-Possible options are:
-
-B<Host> - POP3 host to connect to. It may be a single scalar, as defined for
-the C<PeerAddr> option in L<IO::Socket::INET>, or a reference to
-an array with hosts to try in turn. The L</host> method will return the value
-which was used to connect to the host.
-
-B<ResvPort> - If given then the socket for the C<Net::POP3> object
-will be bound to the local port given using C<bind> when the socket is
-created.
-
-B<Timeout> - Maximum time, in seconds, to wait for a response from the
-POP3 server (default: 120)
-
-B<Debug> - Enable debugging information
-
-=back
-
-=head1 METHODS
-
-Unless otherwise stated all methods return either a I<true> or I<false>
-value, with I<true> meaning that the operation was a success. When a method
-states that it returns a value, failure will be returned as I<undef> or an
-empty list.
-
-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 auth ( USERNAME, PASSWORD )
-
-Attempt SASL authentication.
-
-=item user ( USER )
-
-Send the USER command.
-
-=item pass ( PASS )
-
-Send the PASS command. Returns the number of messages in the mailbox.
-
-=item login ( [ USER [, PASS ]] )
-
-Send both the USER and PASS commands. If C<PASS> is not given the
-C<Net::POP3> uses C<Net::Netrc> to lookup the password using the host
-and username. If the username is not specified then the current user name
-will be used.
-
-Returns the number of messages in the mailbox. However if there are no
-messages on the server the string C<"0E0"> will be returned. This is
-will give a true value in a boolean context, but zero in a numeric context.
-
-If there was an error authenticating the user then I<undef> will be returned.
-
-=item apop ( [ USER [, PASS ]] )
-
-Authenticate with the server identifying as C<USER> with password C<PASS>.
-Similar to L</login>, but the password is not sent in clear text.
-
-To use this method you must have the Digest::MD5 or the MD5 module installed,
-otherwise this method will return I<undef>.
-
-=item banner ()
-
-Return the sever's connection banner
-
-=item capa ()
-
-Return a reference to a hash of the capabilities of the server. APOP
-is added as a pseudo capability. Note that I've been unable to
-find a list of the standard capability values, and some appear to
-be multi-word and some are not. We make an attempt at intelligently
-parsing them, but it may not be correct.
-
-=item capabilities ()
-
-Just like capa, but only uses a cache from the last time we asked
-the server, so as to avoid asking more than once.
-
-=item top ( MSGNUM [, NUMLINES ] )
-
-Get the header and the first C<NUMLINES> of the body for the message
-C<MSGNUM>. Returns a reference to an array which contains the lines of text
-read from the server.
-
-=item list ( [ MSGNUM ] )
-
-If called with an argument the C<list> returns the size of the message
-in octets.
-
-If called without arguments a reference to a hash is returned. The
-keys will be the C<MSGNUM>'s of all undeleted messages and the values will
-be their size in octets.
-
-=item get ( MSGNUM [, FH ] )
-
-Get the message C<MSGNUM> from the remote mailbox. If C<FH> is not given
-then get returns a reference to an array which contains the lines of
-text read from the server. If C<FH> is given then the lines returned
-from the server are printed to the filehandle C<FH>.
-
-=item getfh ( MSGNUM )
-
-As per get(), but returns a tied filehandle. Reading from this
-filehandle returns the requested message. The filehandle will return
-EOF at the end of the message and should not be reused.
-
-=item last ()
-
-Returns the highest C<MSGNUM> of all the messages accessed.
-
-=item popstat ()
-
-Returns a list of two elements. These are the number of undeleted
-elements and the size of the mbox in octets.
-
-=item ping ( USER )
-
-Returns a list of two elements. These are the number of new messages
-and the total number of messages for C<USER>.
-
-=item uidl ( [ MSGNUM ] )
-
-Returns a unique identifier for C<MSGNUM> if given. If C<MSGNUM> is not
-given C<uidl> returns a reference to a hash where the keys are the
-message numbers and the values are the unique identifiers.
-
-=item delete ( MSGNUM )
-
-Mark message C<MSGNUM> to be deleted from the remote mailbox. All messages
-that are marked to be deleted will be removed from the remote mailbox
-when the server connection closed.
-
-=item reset ()
-
-Reset the status of the remote POP3 server. This includes resetting the
-status of all messages to not be deleted.
-
-=item quit ()
-
-Quit and close the connection to the remote POP3 server. Any messages marked
-as deleted will be deleted from the remote mailbox.
-
-=back
-
-=head1 NOTES
-
-If a C<Net::POP3> object goes out of scope before C<quit> method is called
-then the C<reset> method will called before the connection is closed. This
-means that any messages marked to be deleted will not be.
-
-=head1 SEE ALSO
-
-L<Net::Netrc>,
-L<Net::Cmd>
-
-=head1 AUTHOR
-
-Graham Barr <gbarr@pobox.com>
-
-=head1 COPYRIGHT
-
-Copyright (c) 1995-2003 Graham Barr. All rights reserved.
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=cut
@@ -1,883 +0,0 @@
-# Net::SMTP.pm
-#
-# Copyright (c) 1995-2004 Graham Barr <gbarr@pobox.com>. All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-
-package Net::SMTP;
-
-require 5.001;
-
-use strict;
-use vars qw($VERSION @ISA);
-use Socket 1.3;
-use Carp;
-use IO::Socket;
-use Net::Cmd;
-use Net::Config;
-
-$VERSION = "2.34";
-
-@ISA = qw(Net::Cmd IO::Socket::INET);
-
-
-sub new {
- my $self = shift;
- my $type = ref($self) || $self;
- my ($host, %arg);
- if (@_ % 2) {
- $host = shift;
- %arg = @_;
- }
- else {
- %arg = @_;
- $host = delete $arg{Host};
- }
- my $hosts = defined $host ? $host : $NetConfig{smtp_hosts};
- my $obj;
-
- my $h;
- foreach $h (@{ref($hosts) ? $hosts : [$hosts]}) {
- $obj = $type->SUPER::new(
- PeerAddr => ($host = $h),
- PeerPort => $arg{Port} || 'smtp(25)',
- LocalAddr => $arg{LocalAddr},
- LocalPort => $arg{LocalPort},
- Proto => 'tcp',
- Timeout => defined $arg{Timeout}
- ? $arg{Timeout}
- : 120
- )
- and last;
- }
-
- return undef
- unless defined $obj;
-
- $obj->autoflush(1);
-
- $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
-
- unless ($obj->response() == CMD_OK) {
- my $err = ref($obj) . ": " . $obj->code . " " . $obj->message;
- $obj->close();
- $@ = $err;
- return undef;
- }
-
- ${*$obj}{'net_smtp_exact_addr'} = $arg{ExactAddresses};
- ${*$obj}{'net_smtp_host'} = $host;
-
- (${*$obj}{'net_smtp_banner'}) = $obj->message;
- (${*$obj}{'net_smtp_domain'}) = $obj->message =~ /\A\s*(\S+)/;
-
- unless ($obj->hello($arg{Hello} || "")) {
- my $err = ref($obj) . ": " . $obj->code . " " . $obj->message;
- $obj->close();
- $@ = $err;
- return undef;
- }
-
- $obj;
-}
-
-
-sub host {
- my $me = shift;
- ${*$me}{'net_smtp_host'};
-}
-
-##
-## User interface methods
-##
-
-
-sub banner {
- my $me = shift;
-
- return ${*$me}{'net_smtp_banner'} || undef;
-}
-
-
-sub domain {
- my $me = shift;
-
- return ${*$me}{'net_smtp_domain'} || undef;
-}
-
-
-sub etrn {
- my $self = shift;
- defined($self->supports('ETRN', 500, ["Command unknown: 'ETRN'"]))
- && $self->_ETRN(@_);
-}
-
-
-sub auth {
- my ($self, $username, $password) = @_;
-
- eval {
- require MIME::Base64;
- require Authen::SASL;
- } or $self->set_status(500, ["Need MIME::Base64 and Authen::SASL todo auth"]), return 0;
-
- my $mechanisms = $self->supports('AUTH', 500, ["Command unknown: 'AUTH'"]);
- return unless defined $mechanisms;
-
- my $sasl;
-
- if (ref($username) and UNIVERSAL::isa($username, 'Authen::SASL')) {
- $sasl = $username;
- $sasl->mechanism($mechanisms);
- }
- else {
- die "auth(username, password)" if not length $username;
- $sasl = Authen::SASL->new(
- mechanism => $mechanisms,
- callback => {
- user => $username,
- pass => $password,
- authname => $username,
- }
- );
- }
-
- # We should probably allow the user to pass the host, but I don't
- # currently know and SASL mechanisms that are used by smtp that need it
- my $client = $sasl->client_new('smtp', ${*$self}{'net_smtp_host'}, 0);
- my $str = $client->client_start;
-
- # We don't support sasl mechanisms that encrypt the socket traffic.
- # todo that we would really need to change the ISA hierarchy
- # so we don't inherit from IO::Socket, but instead hold it in an attribute
-
- my @cmd = ("AUTH", $client->mechanism);
- my $code;
-
- push @cmd, MIME::Base64::encode_base64($str, '')
- if defined $str and length $str;
-
- while (($code = $self->command(@cmd)->response()) == CMD_MORE) {
- @cmd = (
- MIME::Base64::encode_base64(
- $client->client_step(MIME::Base64::decode_base64(($self->message)[0])), ''
- )
- );
- }
-
- $code == CMD_OK;
-}
-
-
-sub hello {
- my $me = shift;
- my $domain = shift || "localhost.localdomain";
- my $ok = $me->_EHLO($domain);
- my @msg = $me->message;
-
- if ($ok) {
- my $h = ${*$me}{'net_smtp_esmtp'} = {};
- my $ln;
- foreach $ln (@msg) {
- $h->{uc $1} = $2
- if $ln =~ /([-\w]+)\b[= \t]*([^\n]*)/;
- }
- }
- elsif ($me->status == CMD_ERROR) {
- @msg = $me->message
- if $ok = $me->_HELO($domain);
- }
-
- return undef unless $ok;
-
- $msg[0] =~ /\A\s*(\S+)/;
- return ($1 || " ");
-}
-
-
-sub supports {
- my $self = shift;
- my $cmd = uc shift;
- return ${*$self}{'net_smtp_esmtp'}->{$cmd}
- if exists ${*$self}{'net_smtp_esmtp'}->{$cmd};
- $self->set_status(@_)
- if @_;
- return;
-}
-
-
-sub _addr {
- my $self = shift;
- my $addr = shift;
- $addr = "" unless defined $addr;
-
- if (${*$self}{'net_smtp_exact_addr'}) {
- return $1 if $addr =~ /^\s*(<.*>)\s*$/s;
- }
- else {
- return $1 if $addr =~ /(<[^>]*>)/;
- $addr =~ s/^\s+|\s+$//sg;
- }
-
- "<$addr>";
-}
-
-
-sub mail {
- my $me = shift;
- my $addr = _addr($me, shift);
- my $opts = "";
-
- if (@_) {
- my %opt = @_;
- my ($k, $v);
-
- if (exists ${*$me}{'net_smtp_esmtp'}) {
- my $esmtp = ${*$me}{'net_smtp_esmtp'};
-
- if (defined($v = delete $opt{Size})) {
- if (exists $esmtp->{SIZE}) {
- $opts .= sprintf " SIZE=%d", $v + 0;
- }
- else {
- carp 'Net::SMTP::mail: SIZE option not supported by host';
- }
- }
-
- if (defined($v = delete $opt{Return})) {
- if (exists $esmtp->{DSN}) {
- $opts .= " RET=" . ((uc($v) eq "FULL") ? "FULL" : "HDRS");
- }
- else {
- carp 'Net::SMTP::mail: DSN option not supported by host';
- }
- }
-
- if (defined($v = delete $opt{Bits})) {
- if ($v eq "8") {
- if (exists $esmtp->{'8BITMIME'}) {
- $opts .= " BODY=8BITMIME";
- }
- else {
- carp 'Net::SMTP::mail: 8BITMIME option not supported by host';
- }
- }
- elsif ($v eq "binary") {
- if (exists $esmtp->{'BINARYMIME'} && exists $esmtp->{'CHUNKING'}) {
- $opts .= " BODY=BINARYMIME";
- ${*$me}{'net_smtp_chunking'} = 1;
- }
- else {
- carp 'Net::SMTP::mail: BINARYMIME option not supported by host';
- }
- }
- elsif (exists $esmtp->{'8BITMIME'} or exists $esmtp->{'BINARYMIME'}) {
- $opts .= " BODY=7BIT";
- }
- else {
- carp 'Net::SMTP::mail: 8BITMIME and BINARYMIME options not supported by host';
- }
- }
-
- if (defined($v = delete $opt{Transaction})) {
- if (exists $esmtp->{CHECKPOINT}) {
- $opts .= " TRANSID=" . _addr($me, $v);
- }
- else {
- carp 'Net::SMTP::mail: CHECKPOINT option not supported by host';
- }
- }
-
- if (defined($v = delete $opt{Envelope})) {
- if (exists $esmtp->{DSN}) {
- $v =~ s/([^\041-\176]|=|\+)/sprintf "+%02X", ord($1)/sge;
- $opts .= " ENVID=$v";
- }
- else {
- carp 'Net::SMTP::mail: DSN option not supported by host';
- }
- }
-
- if (defined($v = delete $opt{ENVID})) {
-
- # expected to be in a format as required by RFC 3461, xtext-encoded
- if (exists $esmtp->{DSN}) {
- $opts .= " ENVID=$v";
- }
- else {
- carp 'Net::SMTP::mail: DSN option not supported by host';
- }
- }
-
- if (defined($v = delete $opt{AUTH})) {
-
- # expected to be in a format as required by RFC 2554,
- # rfc2821-quoted and xtext-encoded, or <>
- if (exists $esmtp->{AUTH}) {
- $v = '<>' if !defined($v) || $v eq '';
- $opts .= " AUTH=$v";
- }
- else {
- carp 'Net::SMTP::mail: AUTH option not supported by host';
- }
- }
-
- if (defined($v = delete $opt{XVERP})) {
- if (exists $esmtp->{'XVERP'}) {
- $opts .= " XVERP";
- }
- else {
- carp 'Net::SMTP::mail: XVERP option not supported by host';
- }
- }
-
- carp 'Net::SMTP::recipient: unknown option(s) ' . join(" ", keys %opt) . ' - ignored'
- if scalar keys %opt;
- }
- else {
- carp 'Net::SMTP::mail: ESMTP not supported by host - options discarded :-(';
- }
- }
-
- $me->_MAIL("FROM:" . $addr . $opts);
-}
-
-
-sub send { my $me = shift; $me->_SEND("FROM:" . _addr($me, $_[0])) }
-sub send_or_mail { my $me = shift; $me->_SOML("FROM:" . _addr($me, $_[0])) }
-sub send_and_mail { my $me = shift; $me->_SAML("FROM:" . _addr($me, $_[0])) }
-
-
-sub reset {
- my $me = shift;
-
- $me->dataend()
- if (exists ${*$me}{'net_smtp_lastch'});
-
- $me->_RSET();
-}
-
-
-sub recipient {
- my $smtp = shift;
- my $opts = "";
- my $skip_bad = 0;
-
- if (@_ && ref($_[-1])) {
- my %opt = %{pop(@_)};
- my $v;
-
- $skip_bad = delete $opt{'SkipBad'};
-
- if (exists ${*$smtp}{'net_smtp_esmtp'}) {
- my $esmtp = ${*$smtp}{'net_smtp_esmtp'};
-
- if (defined($v = delete $opt{Notify})) {
- if (exists $esmtp->{DSN}) {
- $opts .= " NOTIFY=" . join(",", map { uc $_ } @$v);
- }
- else {
- carp 'Net::SMTP::recipient: DSN option not supported by host';
- }
- }
-
- if (defined($v = delete $opt{ORcpt})) {
- if (exists $esmtp->{DSN}) {
- $opts .= " ORCPT=" . $v;
- }
- else {
- carp 'Net::SMTP::recipient: DSN option not supported by host';
- }
- }
-
- carp 'Net::SMTP::recipient: unknown option(s) ' . join(" ", keys %opt) . ' - ignored'
- if scalar keys %opt;
- }
- elsif (%opt) {
- carp 'Net::SMTP::recipient: ESMTP not supported by host - options discarded :-(';
- }
- }
-
- my @ok;
- my $addr;
- foreach $addr (@_) {
- if ($smtp->_RCPT("TO:" . _addr($smtp, $addr) . $opts)) {
- push(@ok, $addr) if $skip_bad;
- }
- elsif (!$skip_bad) {
- return 0;
- }
- }
-
- return $skip_bad ? @ok : 1;
-}
-
-BEGIN {
- *to = \&recipient;
- *cc = \&recipient;
- *bcc = \&recipient;
-}
-
-
-sub data {
- my $me = shift;
-
- if (exists ${*$me}{'net_smtp_chunking'}) {
- carp 'Net::SMTP::data: CHUNKING extension in use, must call bdat instead';
- }
- else {
- my $ok = $me->_DATA() && $me->datasend(@_);
-
- $ok && @_
- ? $me->dataend
- : $ok;
- }
-}
-
-
-sub bdat {
- my $me = shift;
-
- if (exists ${*$me}{'net_smtp_chunking'}) {
- my $data = shift;
-
- $me->_BDAT(length $data)
- && $me->rawdatasend($data)
- && $me->response() == CMD_OK;
- }
- else {
- carp 'Net::SMTP::bdat: CHUNKING extension is not in use, call data instead';
- }
-}
-
-
-sub bdatlast {
- my $me = shift;
-
- if (exists ${*$me}{'net_smtp_chunking'}) {
- my $data = shift;
-
- $me->_BDAT(length $data, "LAST")
- && $me->rawdatasend($data)
- && $me->response() == CMD_OK;
- }
- else {
- carp 'Net::SMTP::bdat: CHUNKING extension is not in use, call data instead';
- }
-}
-
-
-sub datafh {
- my $me = shift;
- return unless $me->_DATA();
- return $me->tied_fh;
-}
-
-
-sub expand {
- my $me = shift;
-
- $me->_EXPN(@_)
- ? ($me->message)
- : ();
-}
-
-
-sub verify { shift->_VRFY(@_) }
-
-
-sub help {
- my $me = shift;
-
- $me->_HELP(@_)
- ? scalar $me->message
- : undef;
-}
-
-
-sub quit {
- my $me = shift;
-
- $me->_QUIT;
- $me->close;
-}
-
-
-sub DESTROY {
-
- # ignore
-}
-
-##
-## RFC821 commands
-##
-
-
-sub _EHLO { shift->command("EHLO", @_)->response() == CMD_OK }
-sub _HELO { shift->command("HELO", @_)->response() == CMD_OK }
-sub _MAIL { shift->command("MAIL", @_)->response() == CMD_OK }
-sub _RCPT { shift->command("RCPT", @_)->response() == CMD_OK }
-sub _SEND { shift->command("SEND", @_)->response() == CMD_OK }
-sub _SAML { shift->command("SAML", @_)->response() == CMD_OK }
-sub _SOML { shift->command("SOML", @_)->response() == CMD_OK }
-sub _VRFY { shift->command("VRFY", @_)->response() == CMD_OK }
-sub _EXPN { shift->command("EXPN", @_)->response() == CMD_OK }
-sub _HELP { shift->command("HELP", @_)->response() == CMD_OK }
-sub _RSET { shift->command("RSET")->response() == CMD_OK }
-sub _NOOP { shift->command("NOOP")->response() == CMD_OK }
-sub _QUIT { shift->command("QUIT")->response() == CMD_OK }
-sub _DATA { shift->command("DATA")->response() == CMD_MORE }
-sub _BDAT { shift->command("BDAT", @_) }
-sub _TURN { shift->unsupported(@_); }
-sub _ETRN { shift->command("ETRN", @_)->response() == CMD_OK }
-sub _AUTH { shift->command("AUTH", @_)->response() == CMD_OK }
-
-1;
-
-__END__
-
-=head1 NAME
-
-Net::SMTP - Simple Mail Transfer Protocol Client
-
-=head1 SYNOPSIS
-
- use Net::SMTP;
-
- # Constructors
- $smtp = Net::SMTP->new('mailhost');
- $smtp = Net::SMTP->new('mailhost', Timeout => 60);
-
-=head1 DESCRIPTION
-
-This module implements a client interface to the SMTP and ESMTP
-protocol, enabling a perl5 application to talk to SMTP servers. This
-documentation assumes that you are familiar with the concepts of the
-SMTP protocol described in RFC821.
-
-A new Net::SMTP object must be created with the I<new> method. Once
-this has been done, all SMTP commands are accessed through this object.
-
-The Net::SMTP class is a subclass of Net::Cmd and IO::Socket::INET.
-
-=head1 EXAMPLES
-
-This example prints the mail domain name of the SMTP server known as mailhost:
-
- #!/usr/local/bin/perl -w
-
- use Net::SMTP;
-
- $smtp = Net::SMTP->new('mailhost');
- print $smtp->domain,"\n";
- $smtp->quit;
-
-This example sends a small message to the postmaster at the SMTP server
-known as mailhost:
-
- #!/usr/local/bin/perl -w
-
- use Net::SMTP;
-
- my $smtp = Net::SMTP->new('mailhost');
-
- $smtp->mail($ENV{USER});
- if ($smtp->to('postmaster')) {
- $smtp->data();
- $smtp->datasend("To: postmaster\n");
- $smtp->datasend("\n");
- $smtp->datasend("A simple test message\n");
- $smtp->dataend();
- } else {
- print "Error: ", $smtp->message();
- }
-
- $smtp->quit;
-
-=head1 CONSTRUCTOR
-
-=over 4
-
-=item new ( [ HOST ] [, OPTIONS ] )
-
-This is the constructor for a new Net::SMTP object. C<HOST> is the
-name of the remote host to which an SMTP connection is required.
-
-On failure C<undef> will be returned and C<$@> will contain the reason
-for the failure.
-
-C<HOST> is optional. If C<HOST> is not given then it may instead be
-passed as the C<Host> option described below. If neither is given then
-the C<SMTP_Hosts> specified in C<Net::Config> will be used.
-
-C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
-Possible options are:
-
-B<Hello> - SMTP requires that you identify yourself. This option
-specifies a string to pass as your mail domain. If not given localhost.localdomain
-will be used.
-
-B<Host> - SMTP host to connect to. It may be a single scalar (hostname[:port]),
-as defined for the C<PeerAddr> option in L<IO::Socket::INET>, or a reference to
-an array with hosts to try in turn. The L</host> method will return the value
-which was used to connect to the host.
-
-B<Port> - port to connect to. Format - C<PeerHost> from L<IO::Socket::INET> new method.
-Default - 25.
-
-B<LocalAddr> and B<LocalPort> - These parameters are passed directly
-to IO::Socket to allow binding the socket to a local port.
-
-B<Timeout> - Maximum time, in seconds, to wait for a response from the
-SMTP server (default: 120)
-
-B<ExactAddresses> - If true the all ADDRESS arguments must be as
-defined by C<addr-spec> in RFC2822. If not given, or false, then
-Net::SMTP will attempt to extract the address from the value passed.
-
-B<Debug> - Enable debugging information
-
-
-Example:
-
-
- $smtp = Net::SMTP->new('mailhost',
- Hello => 'my.mail.domain',
- Timeout => 30,
- Debug => 1,
- );
-
- # the same
- $smtp = Net::SMTP->new(
- Host => 'mailhost',
- Hello => 'my.mail.domain',
- Timeout => 30,
- Debug => 1,
- );
-
- # Connect to the default server from Net::config
- $smtp = Net::SMTP->new(
- Hello => 'my.mail.domain',
- Timeout => 30,
- );
-
-=back
-
-=head1 METHODS
-
-Unless otherwise stated all methods return either a I<true> or I<false>
-value, with I<true> meaning that the operation was a success. When a method
-states that it returns a value, failure will be returned as I<undef> or an
-empty list.
-
-C<Net::SMTP> inherits from C<Net::Cmd> so methods defined in C<Net::Cmd> may
-be used to send commands to the remote SMTP server in addition to the methods
-documented here.
-
-=over 4
-
-=item banner ()
-
-Returns the banner message which the server replied with when the
-initial connection was made.
-
-=item domain ()
-
-Returns the domain that the remote SMTP server identified itself as during
-connection.
-
-=item hello ( DOMAIN )
-
-Tell the remote server the mail domain which you are in using the EHLO
-command (or HELO if EHLO fails). Since this method is invoked
-automatically when the Net::SMTP object is constructed the user should
-normally not have to call it manually.
-
-=item host ()
-
-Returns the value used by the constructor, and passed to IO::Socket::INET,
-to connect to the host.
-
-=item etrn ( DOMAIN )
-
-Request a queue run for the DOMAIN given.
-
-=item auth ( USERNAME, PASSWORD )
-
-Attempt SASL authentication. Requires Authen::SASL module.
-
-=item mail ( ADDRESS [, OPTIONS] )
-
-=item send ( ADDRESS )
-
-=item send_or_mail ( ADDRESS )
-
-=item send_and_mail ( ADDRESS )
-
-Send the appropriate command to the server MAIL, SEND, SOML or SAML. C<ADDRESS>
-is the address of the sender. This initiates the sending of a message. The
-method C<recipient> should be called for each address that the message is to
-be sent to.
-
-The C<mail> method can some additional ESMTP OPTIONS which is passed
-in hash like fashion, using key and value pairs. Possible options are:
-
- Size => <bytes>
- Return => "FULL" | "HDRS"
- Bits => "7" | "8" | "binary"
- Transaction => <ADDRESS>
- Envelope => <ENVID> # xtext-encodes its argument
- ENVID => <ENVID> # similar to Envelope, but expects argument encoded
- XVERP => 1
- AUTH => <submitter> # encoded address according to RFC 2554
-
-The C<Return> and C<Envelope> parameters are used for DSN (Delivery
-Status Notification).
-
-The submitter address in C<AUTH> option is expected to be in a format as
-required by RFC 2554, in an RFC2821-quoted form and xtext-encoded, or <> .
-
-=item reset ()
-
-Reset the status of the server. This may be called after a message has been
-initiated, but before any data has been sent, to cancel the sending of the
-message.
-
-=item recipient ( ADDRESS [, ADDRESS, [...]] [, OPTIONS ] )
-
-Notify the server that the current message should be sent to all of the
-addresses given. Each address is sent as a separate command to the server.
-Should the sending of any address result in a failure then the process is
-aborted and a I<false> value is returned. It is up to the user to call
-C<reset> if they so desire.
-
-The C<recipient> method can also pass additional case-sensitive OPTIONS as an
-anonymous hash using key and value pairs. Possible options are:
-
- Notify => ['NEVER'] or ['SUCCESS','FAILURE','DELAY'] (see below)
- ORcpt => <ORCPT>
- SkipBad => 1 (to ignore bad addresses)
-
-If C<SkipBad> is true the C<recipient> will not return an error when a bad
-address is encountered and it will return an array of addresses that did
-succeed.
-
- $smtp->recipient($recipient1,$recipient2); # Good
- $smtp->recipient($recipient1,$recipient2, { SkipBad => 1 }); # Good
- $smtp->recipient($recipient1,$recipient2, { Notify => ['FAILURE','DELAY'], SkipBad => 1 }); # Good
- @goodrecips=$smtp->recipient(@recipients, { Notify => ['FAILURE'], SkipBad => 1 }); # Good
- $smtp->recipient("$recipient,$recipient2"); # BAD
-
-Notify is used to request Delivery Status Notifications (DSNs), but your
-SMTP/ESMTP service may not respect this request depending upon its version and
-your site's SMTP configuration.
-
-Leaving out the Notify option usually defaults an SMTP service to its default
-behavior equivalent to ['FAILURE'] notifications only, but again this may be
-dependent upon your site's SMTP configuration.
-
-The NEVER keyword must appear by itself if used within the Notify option and "requests
-that a DSN not be returned to the sender under any conditions."
-
- {Notify => ['NEVER']}
-
- $smtp->recipient(@recipients, { Notify => ['NEVER'], SkipBad => 1 }); # Good
-
-You may use any combination of these three values 'SUCCESS','FAILURE','DELAY' in
-the anonymous array reference as defined by RFC3461 (see http://www.ietf.org/rfc/rfc3461.txt
-for more information. Note: quotations in this topic from same.).
-
-A Notify parameter of 'SUCCESS' or 'FAILURE' "requests that a DSN be issued on
-successful delivery or delivery failure, respectively."
-
-A Notify parameter of 'DELAY' "indicates the sender's willingness to receive
-delayed DSNs. Delayed DSNs may be issued if delivery of a message has been
-delayed for an unusual amount of time (as determined by the Message Transfer
-Agent (MTA) at which the message is delayed), but the final delivery status
-(whether successful or failure) cannot be determined. The absence of the DELAY
-keyword in a NOTIFY parameter requests that a "delayed" DSN NOT be issued under
-any conditions."
-
- {Notify => ['SUCCESS','FAILURE','DELAY']}
-
- $smtp->recipient(@recipients, { Notify => ['FAILURE','DELAY'], SkipBad => 1 }); # Good
-
-ORcpt is also part of the SMTP DSN extension according to RFC3461.
-It is used to pass along the original recipient that the mail was first
-sent to. The machine that generates a DSN will use this address to inform
-the sender, because he can't know if recipients get rewritten by mail servers.
-It is expected to be in a format as required by RFC3461, xtext-encoded.
-
-=item to ( ADDRESS [, ADDRESS [...]] )
-
-=item cc ( ADDRESS [, ADDRESS [...]] )
-
-=item bcc ( ADDRESS [, ADDRESS [...]] )
-
-Synonyms for C<recipient>.
-
-=item data ( [ DATA ] )
-
-Initiate the sending of the data from the current message.
-
-C<DATA> may be a reference to a list or a list. If specified the contents
-of C<DATA> and a termination string C<".\r\n"> is sent to the server. And the
-result will be true if the data was accepted.
-
-If C<DATA> is not specified then the result will indicate that the server
-wishes the data to be sent. The data must then be sent using the C<datasend>
-and C<dataend> methods described in L<Net::Cmd>.
-
-=item expand ( ADDRESS )
-
-Request the server to expand the given address Returns an array
-which contains the text read from the server.
-
-=item verify ( ADDRESS )
-
-Verify that C<ADDRESS> is a legitimate mailing address.
-
-Most sites usually disable this feature in their SMTP service configuration.
-Use "Debug => 1" option under new() to see if disabled.
-
-=item help ( [ $subject ] )
-
-Request help text from the server. Returns the text or undef upon failure
-
-=item quit ()
-
-Send the QUIT command to the remote SMTP server and close the socket connection.
-
-=back
-
-=head1 ADDRESSES
-
-Net::SMTP attempts to DWIM with addresses that are passed. For
-example an application might extract The From: line from an email
-and pass that to mail(). While this may work, it is not recommended.
-The application should really use a module like L<Mail::Address>
-to extract the mail address and pass that.
-
-If C<ExactAddresses> is passed to the constructor, then addresses
-should be a valid rfc2821-quoted address, although Net::SMTP will
-accept the address surrounded by angle brackets.
-
- funny user@domain WRONG
- "funny user"@domain RIGHT, recommended
- <"funny user"@domain> OK
-
-=head1 SEE ALSO
-
-L<Net::Cmd>
-
-=head1 AUTHOR
-
-Graham Barr <gbarr@pobox.com>
-
-=head1 COPYRIGHT
-
-Copyright (c) 1995-2004 Graham Barr. All rights reserved.
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=cut
@@ -1,151 +0,0 @@
-# Net::Time.pm
-#
-# Copyright (c) 1995-2004 Graham Barr <gbarr@pobox.com>. All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-
-package Net::Time;
-
-use strict;
-use vars qw($VERSION @ISA @EXPORT_OK $TIMEOUT);
-use Carp;
-use IO::Socket;
-require Exporter;
-use Net::Config;
-use IO::Select;
-
-@ISA = qw(Exporter);
-@EXPORT_OK = qw(inet_time inet_daytime);
-
-$VERSION = "2.11";
-
-$TIMEOUT = 120;
-
-
-sub _socket {
- my ($pname, $pnum, $host, $proto, $timeout) = @_;
-
- $proto ||= 'udp';
-
- my $port = (getservbyname($pname, $proto))[2] || $pnum;
-
- my $hosts = defined $host ? [$host] : $NetConfig{$pname . '_hosts'};
-
- my $me;
-
- foreach $host (@$hosts) {
- $me = IO::Socket::INET->new(
- PeerAddr => $host,
- PeerPort => $port,
- Proto => $proto
- )
- and last;
- }
-
- return unless $me;
-
- $me->send("\n")
- if $proto eq 'udp';
-
- $timeout = $TIMEOUT
- unless defined $timeout;
-
- IO::Select->new($me)->can_read($timeout)
- ? $me
- : undef;
-}
-
-
-sub inet_time {
- my $s = _socket('time', 37, @_) || return undef;
- my $buf = '';
- my $offset = 0 | 0;
-
- return undef
- unless defined $s->recv($buf, length(pack("N", 0)));
-
- # unpack, we | 0 to ensure we have an unsigned
- my $time = (unpack("N", $buf))[0] | 0;
-
- # the time protocol return time in seconds since 1900, convert
- # it to a the required format
-
- if ($^O eq "MacOS") {
-
- # MacOS return seconds since 1904, 1900 was not a leap year.
- $offset = (4 * 31536000) | 0;
- }
- else {
-
- # otherwise return seconds since 1972, there were 17 leap years between
- # 1900 and 1972
- $offset = (70 * 31536000 + 17 * 86400) | 0;
- }
-
- $time - $offset;
-}
-
-
-sub inet_daytime {
- my $s = _socket('daytime', 13, @_) || return undef;
- my $buf = '';
-
- defined($s->recv($buf, 1024))
- ? $buf
- : undef;
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-Net::Time - time and daytime network client interface
-
-=head1 SYNOPSIS
-
- use Net::Time qw(inet_time inet_daytime);
-
- print inet_time(); # use default host from Net::Config
- print inet_time('localhost');
- print inet_time('localhost', 'tcp');
-
- print inet_daytime(); # use default host from Net::Config
- print inet_daytime('localhost');
- print inet_daytime('localhost', 'tcp');
-
-=head1 DESCRIPTION
-
-C<Net::Time> provides subroutines that obtain the time on a remote machine.
-
-=over 4
-
-=item inet_time ( [HOST [, PROTOCOL [, TIMEOUT]]])
-
-Obtain the time on C<HOST>, or some default host if C<HOST> is not given
-or not defined, using the protocol as defined in RFC868. The optional
-argument C<PROTOCOL> should define the protocol to use, either C<tcp> or
-C<udp>. The result will be a time value in the same units as returned
-by time() or I<undef> upon failure.
-
-=item inet_daytime ( [HOST [, PROTOCOL [, TIMEOUT]]])
-
-Obtain the time on C<HOST>, or some default host if C<HOST> is not given
-or not defined, using the protocol as defined in RFC867. The optional
-argument C<PROTOCOL> should define the protocol to use, either C<tcp> or
-C<udp>. The result will be an ASCII string or I<undef> upon failure.
-
-=back
-
-=head1 AUTHOR
-
-Graham Barr <gbarr@pobox.com>
-
-=head1 COPYRIGHT
-
-Copyright (c) 1995-2004 Graham Barr. All rights reserved.
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=cut
@@ -1,302 +0,0 @@
-=head1 NAME
-
-libnetFAQ - libnet Frequently Asked Questions
-
-=head1 DESCRIPTION
-
-=head2 Where to get this document
-
-This document is distributed with the libnet distribution, and is also
-available on the libnet web page at
-
- http://search.cpan.org/dist/libnet/
-
-=head2 How to contribute to this document
-
-You may report corrections, additions, and suggestions on the
-CPAN request tracker at
-
- http://rt.cpan.org/Dist/Display.html?Name=libnet
-
-=head1 Author and Copyright Information
-
-Copyright (c) 1997-1998 Graham Barr. All rights reserved.
-This document is free; you can redistribute it and/or modify it
-under the terms of the Artistic License.
-
-Currently maintained by Steve Hay <shay@cpan.org>.
-
-=head2 Disclaimer
-
-This information is offered in good faith and in the hope that it may
-be of use, but is not guaranteed to be correct, up to date, or suitable
-for any particular purpose whatsoever. The authors accept no liability
-in respect of this information or its use.
-
-
-=head1 Obtaining and installing libnet
-
-=head2 What is libnet ?
-
-libnet is a collection of perl5 modules which all related to network
-programming. The majority of the modules available provided the
-client side of popular server-client protocols that are used in
-the internet community.
-
-=head2 Which version of perl do I need ?
-
-libnet has been know to work with versions of perl from 5.002 onwards. However
-if your release of perl is prior to perl5.004 then you will need to
-obtain and install the IO distribution from CPAN. If you have perl5.004
-or later then you will have the IO modules in your installation already,
-but CPAN may contain updates.
-
-=head2 What other modules do I need ?
-
-The only modules you will need installed are the modules from the IO
-distribution. If you have perl5.004 or later you will already have
-these modules.
-
-=head2 What machines support libnet ?
-
-libnet itself is an entirely perl-code distribution so it should work
-on any machine that perl runs on. However IO may not work
-with some machines and earlier releases of perl. But this
-should not be the case with perl version 5.004 or later.
-
-=head2 Where can I get the latest libnet release
-
-The latest libnet release is always on CPAN, you will find it
-in
-
- http://search.cpan.org/dist/libnet/
-
-=head1 Using Net::FTP
-
-=head2 How do I download files from an FTP server ?
-
-An example taken from an article posted to comp.lang.perl.misc
-
- #!/your/path/to/perl
-
- # a module making life easier
-
- use Net::FTP;
-
- # for debugging: $ftp = Net::FTP->new('site','Debug',10);
- # open a connection and log in!
-
- $ftp = Net::FTP->new('target_site.somewhere.xxx');
- $ftp->login('username','password');
-
- # set transfer mode to binary
-
- $ftp->binary();
-
- # change the directory on the ftp site
-
- $ftp->cwd('/some/path/to/somewhere/');
-
- foreach $name ('file1', 'file2', 'file3') {
-
- # get's arguments are in the following order:
- # ftp server's filename
- # filename to save the transfer to on the local machine
- # can be simply used as get($name) if you want the same name
-
- $ftp->get($name,$name);
- }
-
- # ftp done!
-
- $ftp->quit;
-
-=head2 How do I transfer files in binary mode ?
-
-To transfer files without <LF><CR> translation Net::FTP provides
-the C<binary> method
-
- $ftp->binary;
-
-=head2 How can I get the size of a file on a remote FTP server ?
-
-=head2 How can I get the modification time of a file on a remote FTP server ?
-
-=head2 How can I change the permissions of a file on a remote server ?
-
-The FTP protocol does not have a command for changing the permissions
-of a file on the remote server. But some ftp servers may allow a chmod
-command to be issued via a SITE command, eg
-
- $ftp->quot('site chmod 0777',$filename);
-
-But this is not guaranteed to work.
-
-=head2 Can I do a reget operation like the ftp command ?
-
-=head2 How do I get a directory listing from an FTP server ?
-
-=head2 Changing directory to "" does not fail ?
-
-Passing an argument of "" to ->cwd() has the same affect of calling ->cwd()
-without any arguments. Turn on Debug (I<See below>) and you will see what is
-happening
-
- $ftp = Net::FTP->new($host, Debug => 1);
- $ftp->login;
- $ftp->cwd("");
-
-gives
-
- Net::FTP=GLOB(0x82196d8)>>> CWD /
- Net::FTP=GLOB(0x82196d8)<<< 250 CWD command successful.
-
-=head2 I am behind a SOCKS firewall, but the Firewall option does not work ?
-
-The Firewall option is only for support of one type of firewall. The type
-supported is an ftp proxy.
-
-To use Net::FTP, or any other module in the libnet distribution,
-through a SOCKS firewall you must create a socks-ified perl executable
-by compiling perl with the socks library.
-
-=head2 I am behind an FTP proxy firewall, but cannot access machines outside ?
-
-Net::FTP implements the most popular ftp proxy firewall approach. The scheme
-implemented is that where you log in to the firewall with C<user@hostname>
-
-I have heard of one other type of firewall which requires a login to the
-firewall with an account, then a second login with C<user@hostname>. You can
-still use Net::FTP to traverse these firewalls, but a more manual approach
-must be taken, eg
-
- $ftp = Net::FTP->new($firewall) or die $@;
- $ftp->login($firewall_user, $firewall_passwd) or die $ftp->message;
- $ftp->login($ext_user . '@' . $ext_host, $ext_passwd) or die $ftp->message.
-
-=head2 My ftp proxy firewall does not listen on port 21
-
-FTP servers usually listen on the same port number, port 21, as any other
-FTP server. But there is no reason why this has to be the case.
-
-If you pass a port number to Net::FTP then it assumes this is the port
-number of the final destination. By default Net::FTP will always try
-to connect to the firewall on port 21.
-
-Net::FTP uses IO::Socket to open the connection and IO::Socket allows
-the port number to be specified as part of the hostname. So this problem
-can be resolved by either passing a Firewall option like C<"hostname:1234">
-or by setting the C<ftp_firewall> option in Net::Config to be a string
-in the same form.
-
-=head2 Is it possible to change the file permissions of a file on an FTP server ?
-
-The answer to this is "maybe". The FTP protocol does not specify a command to change
-file permissions on a remote host. However many servers do allow you to run the
-chmod command via the C<SITE> command. This can be done with
-
- $ftp->site('chmod','0775',$file);
-
-=head2 I have seen scripts call a method message, but cannot find it documented ?
-
-Net::FTP, like several other packages in libnet, inherits from Net::Cmd, so
-all the methods described in Net::Cmd are also available on Net::FTP
-objects.
-
-=head2 Why does Net::FTP not implement mput and mget methods
-
-The quick answer is because they are easy to implement yourself. The long
-answer is that to write these in such a way that multiple platforms are
-supported correctly would just require too much code. Below are
-some examples how you can implement these yourself.
-
-sub mput {
- my($ftp,$pattern) = @_;
- foreach my $file (glob($pattern)) {
- $ftp->put($file) or warn $ftp->message;
- }
-}
-
-sub mget {
- my($ftp,$pattern) = @_;
- foreach my $file ($ftp->ls($pattern)) {
- $ftp->get($file) or warn $ftp->message;
- }
-}
-
-
-=head1 Using Net::SMTP
-
-=head2 Why can't the part of an Email address after the @ be used as the hostname ?
-
-The part of an Email address which follows the @ is not necessarily a hostname,
-it is a mail domain. To find the name of a host to connect for a mail domain
-you need to do a DNS MX lookup
-
-=head2 Why does Net::SMTP not do DNS MX lookups ?
-
-Net::SMTP implements the SMTP protocol. The DNS MX lookup is not part
-of this protocol.
-
-=head2 The verify method always returns true ?
-
-Well it may seem that way, but it does not. The verify method returns true
-if the command succeeded. If you pass verify an address which the
-server would normally have to forward to another machine, the command
-will succeed with something like
-
- 252 Couldn't verify <someone@there> but will attempt delivery anyway
-
-This command will fail only if you pass it an address in a domain
-the server directly delivers for, and that address does not exist.
-
-=head1 Debugging scripts
-
-=head2 How can I debug my scripts that use Net::* modules ?
-
-Most of the libnet client classes allow options to be passed to the
-constructor, in most cases one option is called C<Debug>. Passing
-this option with a non-zero value will turn on a protocol trace, which
-will be sent to STDERR. This trace can be useful to see what commands
-are being sent to the remote server and what responses are being
-received back.
-
- #!/your/path/to/perl
-
- use Net::FTP;
-
- my $ftp = new Net::FTP($host, Debug => 1);
- $ftp->login('gbarr','password');
- $ftp->quit;
-
-this script would output something like
-
- Net::FTP: Net::FTP(2.22)
- Net::FTP: Exporter
- Net::FTP: Net::Cmd(2.0801)
- Net::FTP: IO::Socket::INET
- Net::FTP: IO::Socket(1.1603)
- Net::FTP: IO::Handle(1.1504)
-
- Net::FTP=GLOB(0x8152974)<<< 220 imagine FTP server (Version wu-2.4(5) Tue Jul 29 11:17:18 CDT 1997) ready.
- Net::FTP=GLOB(0x8152974)>>> user gbarr
- Net::FTP=GLOB(0x8152974)<<< 331 Password required for gbarr.
- Net::FTP=GLOB(0x8152974)>>> PASS ....
- Net::FTP=GLOB(0x8152974)<<< 230 User gbarr logged in. Access restrictions apply.
- Net::FTP=GLOB(0x8152974)>>> QUIT
- Net::FTP=GLOB(0x8152974)<<< 221 Goodbye.
-
-The first few lines tell you the modules that Net::FTP uses and their versions,
-this is useful data to me when a user reports a bug. The last seven lines
-show the communication with the server. Each line has three parts. The first
-part is the object itself, this is useful for separating the output
-if you are using multiple objects. The second part is either C<<<<<> to
-show data coming from the server or C<>>>>> to show data
-going to the server. The remainder of the line is the command
-being sent or response being received.
-
-=head1 AUTHOR AND COPYRIGHT
-
-Copyright (c) 1997 Graham Barr.
-All rights reserved.
-
@@ -34,7 +34,7 @@ If you have a Git client, then you can checkout the latest code with
INSTALLATION
-In order to use this package you will need Perl version 5.002 or
+In order to use this package you will need Perl version 5.8.1 or
better. You install libnet, as you would install any perl module
library, by running these commands:
@@ -57,20 +57,21 @@ together with libnet. These packages should be available on CPAN
CONFIGURE
-Normally when perl Makefile.PL is run it will run Configure which will
+Normally when Makefile.PL is run it will run Configure which will
ask some questions about your system. The results of these questions
will be stored in a file called libnet.cfg which will be installed
-alongside the other perl modules in this distribution. The Makefile.PL
+alongside the other perl modules in this distribution. Makefile.PL
will run Configure in an interactive mode unless these exists a file
-called libnet.cfg in the build directory.
+called libnet.cfg in the build directory or Makefile.PL itself is being
+run non-interactively or via cpan, cpanp or cpanm.
If you are on a system which cannot run this script you can create an
empty file to make Makefile.PL skip running Configure. If you want to
-keep your existing settings and not run interactivly the simple run
+keep your existing settings and not run interactivly then simply run
- Configure -d
+ perl Configure -d
-before running the Makefile.PL.
+before running Makefile.PL.
DOCUMENTATION
@@ -103,11 +104,11 @@ include a transcript of a run.
COPYRIGHT
- (C) 1996-2007 Graham Barr. All rights reserved.
+ Versions up to 1.22_01 (C) 1996-2007 Graham Barr. All rights reserved.
+ Changes in Version 1.22_02 onwards Copyright (C) 2013-2014 Steve Hay.
+ All rights reserved.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
-Currently maintained by Steve Hay <shay@cpan.org>.
-
Share and Enjoy!
@@ -1,19 +1,24 @@
-#!/usr/local/bin/perl
+#!perl
+
+use 5.008001;
+
+use strict;
+use warnings;
use blib;
-use Net::FTP;
use Getopt::Long;
+use Net::FTP;
-$opt_debug = undef;
-$opt_firewall = undef;
+our $opt_debug = undef;
+our $opt_firewall = undef;
GetOptions(qw(debug firewall=s));
-@firewall = defined $opt_firewall ? (Firewall => $opt_firewall) : ();
+my @firewall = defined $opt_firewall ? (Firewall => $opt_firewall) : ();
-foreach $host (@ARGV)
+foreach my $host (@ARGV)
{
- $ftp = Net::FTP->new($host, @firewall, Debug => $opt_debug ? 1 : 0);
+ my $ftp = Net::FTP->new($host, @firewall, Debug => $opt_debug ? 1 : 0);
$ftp->login();
print $ftp->pwd,"\n";
$ftp->quit;
@@ -1,9 +0,0 @@
-#!/usr/local/bin/perl
-
-use Net::DummyInetd;
-use Net::SMTP;
-
-$p = new Net::DummyInetd qw(/usr/lib/sendmail -ba -bs);
-
-$smtp = Net::SMTP->new('localhost', Port => $p->port, Debug => 7);
-$smtp->quit;
@@ -1,17 +1,23 @@
-#!/usr/local/bin/perl
+#!perl
+
+use 5.008001;
+
+use strict;
+use warnings;
use blib;
use Getopt::Long;
use Net::NNTP;
-$opt_debug = undef;
+our $opt_debug = undef;
GetOptions(qw(debug));
-@groups = @ARGV;
+my @groups = @ARGV;
-$nntp = Net::NNTP->new('news', Debug => $opt_debug ? 1 : 0);
+my $nntp = Net::NNTP->new('news', Debug => $opt_debug ? 1 : 0);
+my $subs;
if($subs = $nntp->newsgroups)
{
print join("\n",(keys %$subs)[0 .. 10]),"\n";
@@ -21,14 +27,14 @@ if($subs = $nntp->newsgroups)
warn $nntp->message;
}
-foreach $group (@groups)
+foreach my $group (@groups)
{
- $new = $nntp->newnews(time - 3600, lc $group);
+ my $news = $nntp->newnews(time - 3600, lc $group);
- if(ref($new) && scalar(@$new))
+ if(ref($news) && scalar(@$news))
{
- print@{$news}[0..3],"\n"
- if $news = $nntp->article($new->[-1]);
+ print @{$news}[0..3],"\n"
+ if $news = $nntp->article($news->[-1]);
warn $nntp->message
unless $news;
@@ -1,4 +1,4 @@
-#!/usr/bin/perl5
+#!perl
### Subject: Re: Fuller example of Net::NNTP?
### Date: Tue, 4 Feb 1997 10:37:58 -0800
@@ -20,9 +20,14 @@
### work on every system
###
+use 5.008001;
+
+use strict;
+use warnings;
+
use Net::NNTP;
-$BaseDir = '/usr/usenet';
+my $BaseDir = '/usr/usenet';
chdir($BaseDir) or die "Could not cd to $BaseDir\n";
# Format of grouplist is:
@@ -30,18 +35,21 @@ chdir($BaseDir) or die "Could not cd to $BaseDir\n";
# expirationdays is the number of days to leave the articles around;
# set it to 0 if you want the articles to stay forever
# If the groupname starts with a #, it is skipped
-open(GROUPLIST, 'grouplist.txt') or die "Could not open grouplist.txt\n";
-while(<GROUPLIST>) {
- $Line = $_; chomp($Line);
+my $GroupList;
+open($GroupList, '<', 'grouplist.txt') or die "Could not open grouplist.txt\n";
+my @Groups;
+while(<$GroupList>) {
+ my $Line = $_; chomp($Line);
if($Line eq '') { next }; # Skip blank lines
if(substr($Line, 0, 1) eq '#') { next }; # Skip comments
push(@Groups, $Line)
}
+close $GroupList;
-$NntpPtr = Net::NNTP->new('news.server.com');
+my $NntpPtr = Net::NNTP->new('news.server.com');
-foreach $GroupLine (@Groups) {
- ($GroupName, $GroupExp) = split(/\s/, $GroupLine, 2);
+foreach my $GroupLine (@Groups) {
+ my($GroupName, $GroupExp) = split(/\s/, $GroupLine, 2);
# Process the expiration first (still to be done...)
# See if this is a new group
@@ -51,29 +59,32 @@ foreach $GroupLine (@Groups) {
}
chdir("$BaseDir/$GroupName") or die "Couldn't chdir to $GroupName\n";
# Find the last article in the directory
- @AllInDir = <*>; @RevSortedAllInDir = reverse(sort(@AllInDir));
- $LenArr = @RevSortedAllInDir;
+ my @AllInDir = glob('*'); my @RevSortedAllInDir = reverse(sort(@AllInDir));
+ my $LenArr = @RevSortedAllInDir;
+ my $NumLastInDir;
if($LenArr > 0) { $NumLastInDir = $RevSortedAllInDir[0] }
else { $NumLastInDir = 0 }
- ($NumArt, $NumFirst, $NumLast, $XGroupName) =
-$NntpPtr->group($GroupName);
+ my($NumArt, $NumFirst, $NumLast, $XGroupName) =
+ $NntpPtr->group($GroupName);
if($NumLast == $NumLastInDir) { next } # No new articles
if($NumLast < $NumLastInDir)
{ die "In $GroupName, the last number was $NumLast, but the " .
" last number in the directory was $NumLastInDir\n" }
# Figure out which article to start from
+ my $GetArtNum;
if($NumLastInDir == 0) { $GetArtNum = $NumFirst }
else { $GetArtNum = $NumLastInDir + 1 }
# Now read each of the new articles
while(1) { # Loop until "last" is called
- $ArtRef = $NntpPtr->article($GetArtNum);
- @ArtArr = @$ArtRef; $ArtArrLen = @ArtArr;
+ my $ArtRef = $NntpPtr->article($GetArtNum);
+ my @ArtArr = @$ArtRef; my $ArtArrLen = @ArtArr;
if($ArtArrLen > 0 ) { # Skip article numbers that had 0 len
- open(OUT, ">$GetArtNum") or
+ my $Out;
+ open($Out, '>', $GetArtNum) or
die "Could not create $GroupName/$GetArtNum\n";
- print OUT @$ArtRef; close(OUT);
+ print $Out @$ArtRef; close($Out);
}
# Check if we're at the end
@@ -1,23 +1,28 @@
-#!/usr/local/bin/perl -w
+#!perl
+
+use 5.008001;
+
+use strict;
+use warnings;
use blib;
-use Net::POP3;
use Getopt::Long;
+use Net::POP3;
-$opt_debug = 0;
-$opt_user = undef;
+my $opt_debug = 0;
+my $opt_user = undef;
GetOptions(qw(debug user=s));
-$pop = Net::POP3->new('backup3', Debug => $opt_debug ? 6 : 0);
+my $pop = Net::POP3->new('backup3', Debug => $opt_debug ? 6 : 0);
-$user = $opt_user || $ENV{USER} || $ENV{LOGNAME};
+my $user = $opt_user || $ENV{USER} || $ENV{LOGNAME};
-$count = $pop->login($user);
+my $count = $pop->login($user);
if($count)
{
- $m = $pop->get(1);
+ my $m = $pop->get(1);
print @$m if $m;
}
@@ -1,8 +1,13 @@
-#!/usr/local/bin/perl -w
+#!perl
+
+use 5.008001;
+
+use strict;
+use warnings;
use blib;
-use Net::SMTP;
use Getopt::Long;
+use Net::SMTP;
=head1 NAME
@@ -38,9 +43,9 @@ Send the message to C<USERNAME>
=cut
-$opt_debug = undef;
-$opt_user = undef;
-$opt_help = undef;
+my $opt_debug = undef;
+my $opt_user = undef;
+my $opt_help = undef;
GetOptions(qw(debug user=s help));
exec("pod2text $0")
@@ -48,9 +53,9 @@ exec("pod2text $0")
Net::SMTP->debug(1) if $opt_debug;
-$smtp = Net::SMTP->new("mailhost");
+my $smtp = Net::SMTP->new("mailhost");
-$user = $opt_user || $ENV{USER} || $ENV{LOGNAME};
+my $user = $opt_user || $ENV{USER} || $ENV{LOGNAME};
$smtp->mail($user) && $smtp->to($user);
$smtp->reset;
@@ -59,7 +64,8 @@ if($smtp->mail($user) && $smtp->to($user))
{
$smtp->data();
- map { s/-USER-/$user/g } @data=<DATA>;
+ my @data;
+ map { s/-USER-/$user/g } @data=<DATA>; ## no critic (ControlStructures::ProhibitMutatingListFunctions)
$smtp->datasend(@data);
$smtp->dataend;
@@ -1,4 +1,9 @@
-#!/usr/local/bin/perl -w
+#!perl
+
+use 5.008001;
+
+use strict;
+use warnings;
use blib;
use Net::Time qw(inet_time inet_daytime);
@@ -1,37 +0,0 @@
-#!/bin/sh
-#
-# This script is included in this distribution for the benefit
-# of those users who cannot use MakeMaker and make to install.
-# Run this script with
-#
-# perl install-nomake [-s <directory>]
-#
-# -s Install into this directory instead of the system site_lib
-# (This directory must already exist)
-#
-
-eval 'exec perl -x -S $0 ${1+"$@"}'
- if $running_under_some_shell;
-
-#! -*- perl -*-
-
-use Config;
-use File::Spec;
-use Getopt::Long;
-use ExtUtils::Install qw(install);
-
-my $sitelib = $Config{'sitelibexp'};
-
-GetOptions(
- 'sitelib=s' => \$sitelib
-);
-
-die "$sitelib is not a directory: $!"
- unless -d $sitelib;
-
-my $src = File::Spec->curdir;
-
-die "This script must be run from the libnet distribution directory: $!\n"
- unless -f File::Spec->catfile($src, qw(Net FTP.pm));
-
-install( { $src => $sitelib }, 1,0,0);
@@ -0,0 +1,876 @@
+# Net::Cmd.pm
+#
+# Versions up to 2.29_1 Copyright (c) 1995-2006 Graham Barr <gbarr@pobox.com>.
+# All rights reserved.
+# Changes in Version 2.29_2 onwards Copyright (C) 2013-2014 Steve Hay. All
+# rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Net::Cmd;
+
+use 5.008001;
+
+use strict;
+use warnings;
+
+use Carp;
+use Exporter;
+use Symbol 'gensym';
+
+BEGIN {
+ if ($^O eq 'os390') {
+ require Convert::EBCDIC;
+
+ # Convert::EBCDIC->import;
+ }
+}
+
+BEGIN {
+ if (!eval { require utf8 }) {
+ *is_utf8 = sub { 0 };
+ }
+ elsif (eval { utf8::is_utf8(undef); 1 }) {
+ *is_utf8 = \&utf8::is_utf8;
+ }
+ elsif (eval { require Encode; Encode::is_utf8(undef); 1 }) {
+ *is_utf8 = \&Encode::is_utf8;
+ }
+ else {
+ *is_utf8 = sub { $_[0] =~ /[^\x00-\xff]/ };
+ }
+}
+
+our $VERSION = "3.02";
+our @ISA = qw(Exporter);
+our @EXPORT = qw(CMD_INFO CMD_OK CMD_MORE CMD_REJECT CMD_ERROR CMD_PENDING);
+
+use constant CMD_INFO => 1;
+use constant CMD_OK => 2;
+use constant CMD_MORE => 3;
+use constant CMD_REJECT => 4;
+use constant CMD_ERROR => 5;
+use constant CMD_PENDING => 0;
+
+use constant DEF_REPLY_CODE => 421;
+
+my %debug = ();
+
+my $tr = $^O eq 'os390' ? Convert::EBCDIC->new() : undef;
+
+sub toebcdic {
+ my $cmd = shift;
+
+ unless (exists ${*$cmd}{'net_cmd_asciipeer'}) {
+ my $string = $_[0];
+ my $ebcdicstr = $tr->toebcdic($string);
+ ${*$cmd}{'net_cmd_asciipeer'} = $string !~ /^\d+/ && $ebcdicstr =~ /^\d+/;
+ }
+
+ ${*$cmd}{'net_cmd_asciipeer'}
+ ? $tr->toebcdic($_[0])
+ : $_[0];
+}
+
+
+sub toascii {
+ my $cmd = shift;
+ ${*$cmd}{'net_cmd_asciipeer'}
+ ? $tr->toascii($_[0])
+ : $_[0];
+}
+
+
+sub _print_isa {
+ no strict 'refs'; ## no critic (TestingAndDebugging::ProhibitNoStrict)
+
+ my $pkg = shift;
+ my $cmd = $pkg;
+
+ $debug{$pkg} ||= 0;
+
+ my %done = ();
+ my @do = ($pkg);
+ my %spc = ($pkg, "");
+
+ while ($pkg = shift @do) {
+ next if defined $done{$pkg};
+
+ $done{$pkg} = 1;
+
+ my $v =
+ defined ${"${pkg}::VERSION"}
+ ? "(" . ${"${pkg}::VERSION"} . ")"
+ : "";
+
+ my $spc = $spc{$pkg};
+ $cmd->debug_print(1, "${spc}${pkg}${v}\n");
+
+ if (@{"${pkg}::ISA"}) {
+ @spc{@{"${pkg}::ISA"}} = (" " . $spc{$pkg}) x @{"${pkg}::ISA"};
+ unshift(@do, @{"${pkg}::ISA"});
+ }
+ }
+}
+
+
+sub debug {
+ @_ == 1 or @_ == 2 or croak 'usage: $obj->debug([LEVEL])';
+
+ my ($cmd, $level) = @_;
+ my $pkg = ref($cmd) || $cmd;
+ my $oldval = 0;
+
+ if (ref($cmd)) {
+ $oldval = ${*$cmd}{'net_cmd_debug'} || 0;
+ }
+ else {
+ $oldval = $debug{$pkg} || 0;
+ }
+
+ return $oldval
+ unless @_ == 2;
+
+ $level = $debug{$pkg} || 0
+ unless defined $level;
+
+ _print_isa($pkg)
+ if ($level && !exists $debug{$pkg});
+
+ if (ref($cmd)) {
+ ${*$cmd}{'net_cmd_debug'} = $level;
+ }
+ else {
+ $debug{$pkg} = $level;
+ }
+
+ $oldval;
+}
+
+
+sub message {
+ @_ == 1 or croak 'usage: $obj->message()';
+
+ my $cmd = shift;
+
+ wantarray
+ ? @{${*$cmd}{'net_cmd_resp'}}
+ : join("", @{${*$cmd}{'net_cmd_resp'}});
+}
+
+
+sub debug_text { $_[2] }
+
+
+sub debug_print {
+ my ($cmd, $out, $text) = @_;
+ print STDERR $cmd, ($out ? '>>> ' : '<<< '), $cmd->debug_text($out, $text);
+}
+
+
+sub code {
+ @_ == 1 or croak 'usage: $obj->code()';
+
+ my $cmd = shift;
+
+ ${*$cmd}{'net_cmd_code'} = $cmd->DEF_REPLY_CODE
+ unless exists ${*$cmd}{'net_cmd_code'};
+
+ ${*$cmd}{'net_cmd_code'};
+}
+
+
+sub status {
+ @_ == 1 or croak 'usage: $obj->status()';
+
+ my $cmd = shift;
+
+ substr(${*$cmd}{'net_cmd_code'}, 0, 1);
+}
+
+
+sub set_status {
+ @_ == 3 or croak 'usage: $obj->set_status(CODE, MESSAGE)';
+
+ my $cmd = shift;
+ my ($code, $resp) = @_;
+
+ $resp = defined $resp ? [$resp] : []
+ unless ref($resp);
+
+ (${*$cmd}{'net_cmd_code'}, ${*$cmd}{'net_cmd_resp'}) = ($code, $resp);
+
+ 1;
+}
+
+
+
+sub _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 $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: $!") 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(@_)) {
+ local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
+
+ my $str = join(
+ " ",
+ map {
+ /\n/
+ ? do { my $n = $_; $n =~ tr/\n/ /; $n }
+ : $_;
+ } @_
+ );
+ $str = $cmd->toascii($str) if $tr;
+ $str .= "\015\012";
+
+ my $len = length $str;
+ my $swlen;
+
+ $cmd->debug_print(1, $str)
+ if ($cmd->debug);
+
+ unless (defined($swlen = syswrite($cmd,$str,$len)) && $swlen == $len) {
+ $cmd->close;
+ $cmd->_set_status_closed;
+ 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)) {
+ $cmd->close;
+ $cmd->_set_status_closed;
+ 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);
+
+ # encode to individual utf8 bytes if
+ # $line is a string (in internal UTF-8)
+ utf8::encode($line) if is_utf8($line);
+
+ 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);
+
+ my $len = length($line);
+ my $offset = 0;
+ my $win = "";
+ vec($win, fileno($cmd), 1) = 1;
+ my $timeout = $cmd->timeout || undef;
+
+ local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
+
+ while ($len) {
+ my $wout;
+ my $s = select(undef, $wout = $win, undef, $timeout);
+ if ((defined $s and $s > 0) or -f $cmd) # -f for testing on win32
+ {
+ my $w = syswrite($cmd, $line, $len, $offset);
+ unless (defined($w) && $w == $len) {
+ $cmd->close;
+ $cmd->_set_status_closed;
+ return;
+ }
+ $len -= $w;
+ $offset += $w;
+ }
+ else {
+ $cmd->_set_status_timeout;
+ 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";
+ }
+
+ my $len = length($line);
+ my $offset = 0;
+ my $win = "";
+ vec($win, fileno($cmd), 1) = 1;
+ my $timeout = $cmd->timeout || undef;
+
+ local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
+ while ($len) {
+ my $wout;
+ if (select(undef, $wout = $win, undef, $timeout) > 0) {
+ my $w = syswrite($cmd, $line, $len, $offset);
+ unless (defined($w) && $w == $len) {
+ $cmd->close;
+ $cmd->_set_status_closed;
+ return;
+ }
+ $len -= $w;
+ $offset += $w;
+ }
+ else {
+ $cmd->_set_status_timeout;
+ 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";
+
+ local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
+
+ $cmd->debug_print(1, ".\n")
+ if ($cmd->debug);
+
+ my $len = length $tosend;
+ my $w = syswrite($cmd, $tosend, $len);
+ unless (defined($w) && $w == $len)
+ {
+ $cmd->close;
+ $cmd->_set_status_closed;
+ 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::Handle>. These methods implement the functionality required for a
+command based protocol, for example FTP and SMTP.
+
+=head1 USER METHODS
+
+These methods provide a user interface to the C<Net::Cmd> object.
+
+=over 4
+
+=item debug ( VALUE )
+
+Set the level of debug information for this object. If C<VALUE> is not given
+then the current state is returned. Otherwise the state is changed to
+C<VALUE> and the previous state returned.
+
+Different packages
+may implement different levels of debug but a non-zero value results in
+copies of all commands and responses also being sent to STDERR.
+
+If C<VALUE> is C<undef> then the debug level will be set to the default
+debug level for the class.
+
+This method can also be called as a I<static> method to set/get the default
+debug level for a given class.
+
+=item message ()
+
+Returns the text message returned from the last command. In a scalar
+context it returns a single string, in a list context it will return
+each line as a separate element. (See L<PSEUDO RESPONSES> below.)
+
+=item code ()
+
+Returns the 3-digit code from the last command. If a command is pending
+then the value 0 is returned. (See L<PSEUDO RESPONSES> below.)
+
+=item ok ()
+
+Returns non-zero if the last code value was greater than zero and
+less than 400. This holds true for most command servers. Servers
+where this does not hold may override this method.
+
+=item status ()
+
+Returns the most significant digit of the current status code. If a command
+is pending then C<CMD_PENDING> is returned.
+
+=item datasend ( DATA )
+
+Send data to the remote server, converting LF to CRLF. Any line starting
+with a '.' will be prefixed with another '.'.
+C<DATA> may be an array or a reference to an array.
+
+=item dataend ()
+
+End the sending of data to the remote server. This is done by ensuring that
+the data already sent ends with CRLF then sending '.CRLF' to end the
+transmission. Once this data has been sent C<dataend> calls C<response> and
+returns true if C<response> returns CMD_OK.
+
+=back
+
+=head1 CLASS METHODS
+
+These methods are not intended to be called by the user, but used or
+over-ridden by a sub-class of C<Net::Cmd>
+
+=over 4
+
+=item debug_print ( DIR, TEXT )
+
+Print debugging information. C<DIR> denotes the direction I<true> being
+data being sent to the server. Calls C<debug_text> before printing to
+STDERR.
+
+=item debug_text ( DIR, TEXT )
+
+This method is called to print debugging information. TEXT is
+the text being sent. The method should return the text to be printed.
+
+This is primarily meant for the use of modules such as FTP where passwords
+are sent, but we do not want to display them in the debugging information.
+
+=item command ( CMD [, ARGS, ... ])
+
+Send a command to the command server. All arguments are first joined with
+a space character and CRLF is appended, this string is then sent to the
+command server.
+
+Returns undef upon failure.
+
+=item unsupported ()
+
+Sets the status code to 580 and the response text to 'Unsupported command'.
+Returns zero.
+
+=item response ()
+
+Obtain a response from the server. Upon success the most significant digit
+of the status code is returned. Upon failure, timeout etc., I<CMD_ERROR> is
+returned.
+
+=item parse_response ( TEXT )
+
+This method is called by C<response> as a method with one argument. It should
+return an array of 2 values, the 3-digit status code and a flag which is true
+when this is part of a multi-line response and this line is not the last.
+
+=item getline ()
+
+Retrieve one line, delimited by CRLF, from the remote server. Returns I<undef>
+upon failure.
+
+B<NOTE>: If you do use this method for any reason, please remember to add
+some C<debug_print> calls into your method.
+
+=item ungetline ( TEXT )
+
+Unget a line of text from the server.
+
+=item rawdatasend ( DATA )
+
+Send data to the remote server without performing any conversions. C<DATA>
+is a scalar.
+
+=item read_until_dot ()
+
+Read data from the remote server until a line consisting of a single '.'.
+Any lines starting with '..' will have one of the '.'s removed.
+
+Returns a reference to a list containing the lines, or I<undef> upon failure.
+
+=item tied_fh ()
+
+Returns a filehandle tied to the Net::Cmd object. After issuing a
+command, you may read from this filehandle using read() or <>. The
+filehandle will return EOF when the final dot is encountered.
+Similarly, you may write to the filehandle in order to send data to
+the server after issuing a command that expects data to be written.
+
+See the Net::POP3 and Net::SMTP modules for examples of this.
+
+=back
+
+=head1 PSEUDO RESPONSES
+
+Normally the values returned by C<message()> and C<code()> are
+obtained from the remote server, but in a few circumstances, as
+detailed below, C<Net::Cmd> will return values that it sets. You
+can alter this behavior by overriding DEF_REPLY_CODE() to specify
+a different default reply code, or overriding one of the specific
+error handling methods below.
+
+=over 4
+
+=item Initial value
+
+Before any command has executed or if an unexpected error occurs
+C<code()> will return "421" (temporary connection failure) and
+C<message()> will return undef.
+
+=item Connection closed
+
+If the underlying C<IO::Handle> is closed, or if there are
+any read or write failures, the file handle will be forced closed,
+and C<code()> will return "421" (temporary connection failure)
+and C<message()> will return "[$pkg] Connection closed"
+(where $pkg is the name of the class that subclassed C<Net::Cmd>).
+The _set_status_closed() method can be overridden to set a different
+message (by calling set_status()) or otherwise trap this error.
+
+=item Timeout
+
+If there is a read or write timeout C<code()> will return "421"
+(temporary connection failure) and C<message()> will return
+"[$pkg] Timeout" (where $pkg is the name of the class
+that subclassed C<Net::Cmd>). The _set_status_timeout() method
+can be overridden to set a different message (by calling set_status())
+or otherwise trap this error.
+
+=back
+
+=head1 EXPORTS
+
+C<Net::Cmd> exports six subroutines, five of these, C<CMD_INFO>, C<CMD_OK>,
+C<CMD_MORE>, C<CMD_REJECT> and C<CMD_ERROR>, correspond to possible results
+of C<response> and C<status>. The sixth is C<CMD_PENDING>.
+
+=head1 AUTHOR
+
+Graham Barr E<lt>F<gbarr@pobox.com>E<gt>
+
+Steve Hay E<lt>F<shay@cpan.org>E<gt> is now maintaining libnet as of version
+1.22_02
+
+=head1 COPYRIGHT
+
+Versions up to 2.29_1 Copyright (c) 1995-2006 Graham Barr. All rights reserved.
+Changes in Version 2.29_2 onwards Copyright (C) 2013-2014 Steve Hay. All rights
+reserved.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
@@ -0,0 +1,322 @@
+# Net::Config.pm
+#
+# Versions up to 1.11 Copyright (c) 2000 Graham Barr <gbarr@pobox.com>.
+# All rights reserved.
+# Changes in Version 1.11_01 onwards Copyright (C) 2013-2014 Steve Hay. All
+# rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Net::Config;
+
+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.02";
+
+our($CONFIGURE, $LIBNET_CFG);
+
+eval { 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 SYNOPSYS
+
+ use Net::Config qw(%NetConfig);
+
+=head1 DESCRIPTION
+
+C<Net::Config> holds configuration data for the modules in the libnet
+distribution. During installation you will be asked for these values.
+
+The configuration data is held globally in a file in the perl installation
+tree, but a user may override any of these values by providing their own. This
+can be done by having a C<.libnetrc> file in their home directory. This file
+should return a reference to a HASH containing the keys described below.
+For example
+
+ # .libnetrc
+ {
+ nntp_hosts => [ "my_preferred_host" ],
+ ph_hosts => [ "my_ph_server" ],
+ }
+ __END__
+
+=head1 METHODS
+
+C<Net::Config> defines the following methods. They are methods as they are
+invoked as class methods. This is because C<Net::Config> inherits from
+C<Net::LocalCfg> so you can override these methods if you want.
+
+=over 4
+
+=item requires_firewall ( HOST )
+
+Attempts to determine if a given host is outside your firewall. Possible
+return values are.
+
+ -1 Cannot lookup hostname
+ 0 Host is inside firewall (or there is no ftp_firewall entry)
+ 1 Host is outside the firewall
+
+This is done by using hostname lookup and the C<local_netmask> entry in
+the configuration data.
+
+=back
+
+=head1 NetConfig VALUES
+
+=over 4
+
+=item nntp_hosts
+
+=item snpp_hosts
+
+=item pop3_hosts
+
+=item smtp_hosts
+
+=item ph_hosts
+
+=item daytime_hosts
+
+=item time_hosts
+
+Each is a reference to an array of hostnames (in order of preference),
+which should be used for the given protocol
+
+=item inet_domain
+
+Your internet domain name
+
+=item ftp_firewall
+
+If you have an FTP proxy firewall (B<NOT> an HTTP or SOCKS firewall)
+then this value should be set to the firewall hostname. If your firewall
+does not listen to port 21, then this value should be set to
+C<"hostname:port"> (eg C<"hostname:99">)
+
+=item ftp_firewall_type
+
+There are many different ftp firewall products available. But unfortunately
+there is no standard for how to traverse a firewall. The list below shows the
+sequence of commands that Net::FTP will use
+
+ user Username for remote host
+ pass Password for remote host
+ fwuser Username for firewall
+ fwpass Password for firewall
+ remote.host The hostname of the remote ftp server
+
+=over 4
+
+=item 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
+
+=cut
@@ -0,0 +1,362 @@
+# Net::Domain.pm
+#
+# Versions up to 2.21 Copyright (c) 1995-1998 Graham Barr <gbarr@pobox.com>.
+# All rights reserved.
+# Changes in Version 2.22 onwards Copyright (C) 2013-2014 Steve Hay. All rights
+# reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Net::Domain;
+
+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.02";
+
+my ($host, $domain, $fqdn) = (undef, undef, undef);
+
+# Try every conceivable way to get hostname.
+
+
+sub _hostname {
+
+ # we already know it
+ return $host
+ if (defined $host);
+
+ if ($^O eq 'MSWin32') {
+ require Socket;
+ my ($name, $alias, $type, $len, @addr) = gethostbyname($ENV{'COMPUTERNAME'} || 'localhost');
+ while (@addr) {
+ my $a = shift(@addr);
+ $host = gethostbyaddr($a, Socket::AF_INET());
+ last if defined $host;
+ }
+ if (defined($host) && index($host, '.') > 0) {
+ $fqdn = $host;
+ ($host, $domain) = $fqdn =~ /^([^\.]+)\.(.*)$/;
+ }
+ return $host;
+ }
+ elsif ($^O eq 'MacOS') {
+ chomp($host = `hostname`);
+ }
+ elsif ($^O eq 'VMS') { ## multiple varieties of net s/w makes this hard
+ $host = $ENV{'UCX$INET_HOST'} if defined($ENV{'UCX$INET_HOST'});
+ $host = $ENV{'MULTINET_HOST_NAME'} if defined($ENV{'MULTINET_HOST_NAME'});
+ if (index($host, '.') > 0) {
+ $fqdn = $host;
+ ($host, $domain) = $fqdn =~ /^([^\.]+)\.(.*)$/;
+ }
+ return $host;
+ }
+ else {
+ local $SIG{'__DIE__'};
+
+ # syscall is preferred since it avoids tainting problems
+ eval {
+ my $tmp = "\0" x 256; ## preload scalar
+ eval {
+ package main;
+ require "syscall.ph"; ## no critic (Modules::RequireBarewordIncludes)
+ defined(&main::SYS_gethostname);
+ }
+ || eval {
+ package main;
+ require "sys/syscall.ph"; ## no critic (Modules::RequireBarewordIncludes)
+ defined(&main::SYS_gethostname);
+ }
+ and $host =
+ (syscall(&main::SYS_gethostname, $tmp, 256) == 0)
+ ? $tmp
+ : undef;
+ }
+
+ # POSIX
+ || eval {
+ require POSIX;
+ $host = (POSIX::uname())[1];
+ }
+
+ # trusty old hostname command
+ || eval {
+ chop($host = `(hostname) 2>/dev/null`); # BSD'ish
+ }
+
+ # sysV/POSIX uname command (may truncate)
+ || eval {
+ chop($host = `uname -n 2>/dev/null`); ## SYSV'ish && POSIX'ish
+ }
+
+ # Apollo pre-SR10
+ || eval { $host = (split(/[:\. ]/, `/com/host`, 6))[0]; }
+
+ || eval { $host = ""; };
+ }
+
+ # remove garbage
+ $host =~ s/[\0\r\n]+//go;
+ $host =~ s/(\A\.+|\.+\Z)//go;
+ $host =~ s/\.\.+/\./go;
+
+ $host;
+}
+
+
+sub _hostdomain {
+
+ # we already know it
+ return $domain
+ if (defined $domain);
+
+ local $SIG{'__DIE__'};
+
+ return $domain = $NetConfig{'inet_domain'}
+ if defined $NetConfig{'inet_domain'};
+
+ # try looking in /etc/resolv.conf
+ # putting this here and assuming that it is correct, eliminates
+ # calls to gethostbyname, and therefore DNS lookups. This helps
+ # those on dialup systems.
+
+ local ($_);
+
+ if (open(my $res, '<', "/etc/resolv.conf")) {
+ while (<$res>) {
+ $domain = $1
+ if (/\A\s*(?:domain|search)\s+(\S+)/);
+ }
+ close($res);
+
+ return $domain
+ if (defined $domain);
+ }
+
+ # just try hostname and system calls
+
+ my $host = _hostname();
+ my (@hosts);
+
+ @hosts = ($host, "localhost");
+
+ unless (defined($host) && $host =~ /\./) {
+ my $dom = undef;
+ eval {
+ my $tmp = "\0" x 256; ## preload scalar
+ eval {
+ package main;
+ require "syscall.ph"; ## no critic (Modules::RequireBarewordIncludes)
+ }
+ || eval {
+ package main;
+ require "sys/syscall.ph"; ## no critic (Modules::RequireBarewordIncludes)
+ }
+ and $dom =
+ (syscall(&main::SYS_getdomainname, $tmp, 256) == 0)
+ ? $tmp
+ : undef;
+ };
+
+ if ($^O eq 'VMS') {
+ $dom ||= $ENV{'TCPIP$INET_DOMAIN'}
+ || $ENV{'UCX$INET_DOMAIN'};
+ }
+
+ chop($dom = `domainname 2>/dev/null`)
+ unless (defined $dom || $^O =~ /^(?:cygwin|MSWin32|android)/);
+
+ if (defined $dom) {
+ my @h = ();
+ $dom =~ s/^\.+//;
+ while (length($dom)) {
+ push(@h, "$host.$dom");
+ $dom =~ s/^[^.]+.+// or last;
+ }
+ unshift(@hosts, @h);
+ }
+ }
+
+ # Attempt to locate FQDN
+
+ foreach (grep { defined $_ } @hosts) {
+ my @info = gethostbyname($_);
+
+ next unless @info;
+
+ # look at real name & aliases
+ foreach my $site ($info[0], split(/ /, $info[1])) {
+ if (rindex($site, ".") > 0) {
+
+ # Extract domain from FQDN
+
+ ($domain = $site) =~ s/\A[^\.]+\.//;
+ return $domain;
+ }
+ }
+ }
+
+ # Look for environment variable
+
+ $domain ||= $ENV{LOCALDOMAIN} || $ENV{DOMAIN};
+
+ if (defined $domain) {
+ $domain =~ s/[\r\n\0]+//g;
+ $domain =~ s/(\A\.+|\.+\Z)//g;
+ $domain =~ s/\.\.+/\./g;
+ }
+
+ $domain;
+}
+
+
+sub domainname {
+
+ return $fqdn
+ if (defined $fqdn);
+
+ _hostname();
+
+ # *.local names are special on darwin. If we call gethostbyname below, it
+ # may hang while waiting for another, non-existent computer to respond.
+ if($^O eq 'darwin' && $host =~ /\.local$/) {
+ return $host;
+ }
+
+ _hostdomain();
+
+ # Assumption: If the host name does not contain a period
+ # and the domain name does, then assume that they are correct
+ # this helps to eliminate calls to gethostbyname, and therefore
+ # eliminate DNS lookups
+
+ return $fqdn = $host . "." . $domain
+ if (defined $host
+ and defined $domain
+ and $host !~ /\./
+ and $domain =~ /\./);
+
+ # For hosts that have no name, just an IP address
+ return $fqdn = $host if defined $host and $host =~ /^\d+(\.\d+){3}$/;
+
+ my @host = defined $host ? split(/\./, $host) : ('localhost');
+ my @domain = defined $domain ? split(/\./, $domain) : ();
+ my @fqdn = ();
+
+ # Determine from @host & @domain the FQDN
+
+ my @d = @domain;
+
+LOOP:
+ while (1) {
+ my @h = @host;
+ while (@h) {
+ my $tmp = join(".", @h, @d);
+ if ((gethostbyname($tmp))[0]) {
+ @fqdn = (@h, @d);
+ $fqdn = $tmp;
+ last LOOP;
+ }
+ pop @h;
+ }
+ last unless shift @d;
+ }
+
+ if (@fqdn) {
+ $host = shift @fqdn;
+ until ((gethostbyname($host))[0]) {
+ $host .= "." . shift @fqdn;
+ }
+ $domain = join(".", @fqdn);
+ }
+ else {
+ undef $host;
+ undef $domain;
+ undef $fqdn;
+ }
+
+ $fqdn;
+}
+
+
+sub hostfqdn { domainname() }
+
+
+sub hostname {
+ domainname()
+ unless (defined $host);
+ return $host;
+}
+
+
+sub hostdomain {
+ domainname()
+ unless (defined $domain);
+ return $domain;
+}
+
+1; # Keep require happy
+
+__END__
+
+=head1 NAME
+
+Net::Domain - Attempt to evaluate the current host's internet name and domain
+
+=head1 SYNOPSIS
+
+ use Net::Domain qw(hostname hostfqdn hostdomain domainname);
+
+=head1 DESCRIPTION
+
+Using various methods B<attempt> to find the Fully Qualified Domain Name (FQDN)
+of the current host. From this determine the host-name and the host-domain.
+
+Each of the functions will return I<undef> if the FQDN cannot be determined.
+
+=over 4
+
+=item hostfqdn ()
+
+Identify and return the FQDN of the current host.
+
+=item domainname ()
+
+An alias for hostfqdn ().
+
+=item hostname ()
+
+Returns the smallest part of the FQDN which can be used to identify the host.
+
+=item hostdomain ()
+
+Returns the remainder of the FQDN after the I<hostname> has been removed.
+
+=back
+
+=head1 AUTHOR
+
+Graham Barr E<lt>F<gbarr@pobox.com>E<gt>.
+Adapted from Sys::Hostname by David Sundstrom E<lt>F<sunds@asictest.sc.ti.com>E<gt>
+
+Steve Hay E<lt>F<shay@cpan.org>E<gt> is now maintaining libnet as of version
+1.22_02
+
+=head1 COPYRIGHT
+
+Versions up to 2.21 Copyright (c) 1995-1998 Graham Barr. All rights reserved.
+Changes in Version 2.22 onwards Copyright (C) 2013-2014 Steve Hay. All rights
+reserved.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
@@ -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.02";
+
+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;
@@ -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.02";
+
+1;
@@ -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.02";
+
+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;
@@ -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.02";
+
+1;
@@ -0,0 +1,182 @@
+##
+## Generic data connection package
+##
+
+package Net::FTP::dataconn;
+
+use 5.008001;
+
+use strict;
+use warnings;
+
+use Carp;
+use Errno;
+use Net::Cmd;
+
+our $VERSION = '3.02';
+
+$Net::FTP::IOCLASS or die "please load Net::FTP before Net::FTP::dataconn";
+our @ISA = $Net::FTP::IOCLASS;
+
+sub reading {
+ my $data = shift;
+ ${*$data}{'net_ftp_bytesread'} = 0;
+}
+
+
+sub abort {
+ my $data = shift;
+ my $ftp = ${*$data}{'net_ftp_cmd'};
+
+ # no need to abort if we have finished the xfer
+ return $data->close
+ if ${*$data}{'net_ftp_eof'};
+
+ # for some reason if we continuously open RETR connections and not
+ # read a single byte, then abort them after a while the server will
+ # close our connection, this prevents the unexpected EOF on the
+ # command channel -- GMB
+ if (exists ${*$data}{'net_ftp_bytesread'}
+ && (${*$data}{'net_ftp_bytesread'} == 0))
+ {
+ my $buf = "";
+ my $timeout = $data->timeout;
+ $data->can_read($timeout) && sysread($data, $buf, 1);
+ }
+
+ ${*$data}{'net_ftp_eof'} = 1; # fake
+
+ $ftp->abort; # this will close me
+}
+
+
+sub _close {
+ my $data = shift;
+ my $ftp = ${*$data}{'net_ftp_cmd'};
+
+ $data->SUPER::close();
+
+ delete ${*$ftp}{'net_ftp_dataconn'}
+ if defined $ftp
+ && exists ${*$ftp}{'net_ftp_dataconn'}
+ && $data == ${*$ftp}{'net_ftp_dataconn'};
+}
+
+
+sub close {
+ my $data = shift;
+ my $ftp = ${*$data}{'net_ftp_cmd'};
+
+ if (exists ${*$data}{'net_ftp_bytesread'} && !${*$data}{'net_ftp_eof'}) {
+ my $junk;
+ eval { local($SIG{__DIE__}); $data->read($junk, 1, 0) };
+ return $data->abort unless ${*$data}{'net_ftp_eof'};
+ }
+
+ $data->_close;
+
+ return unless defined $ftp;
+
+ $ftp->response() == CMD_OK
+ && $ftp->message =~ /unique file name:\s*(\S*)\s*\)/
+ && (${*$ftp}{'net_ftp_unique'} = $1);
+
+ $ftp->status == CMD_OK;
+}
+
+
+sub _select {
+ my ($data, $timeout, $do_read) = @_;
+ my ($rin, $rout, $win, $wout, $tout, $nfound);
+
+ vec($rin = '', fileno($data), 1) = 1;
+
+ ($win, $rin) = ($rin, $win) unless $do_read;
+
+ while (1) {
+ $nfound = select($rout = $rin, $wout = $win, undef, $tout = $timeout);
+
+ last if $nfound >= 0;
+
+ croak "select: $!"
+ unless $!{EINTR};
+ }
+
+ $nfound;
+}
+
+
+sub can_read {
+ _select(@_[0, 1], 1);
+}
+
+
+sub can_write {
+ _select(@_[0, 1], 0);
+}
+
+
+sub cmd {
+ my $ftp = shift;
+
+ ${*$ftp}{'net_ftp_cmd'};
+}
+
+
+sub bytes_read {
+ my $ftp = shift;
+
+ ${*$ftp}{'net_ftp_bytesread'} || 0;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Net::FTP::dataconn - FTP Client data connection class
+
+=head1 DESCRIPTION
+
+Some of the methods defined in C<Net::FTP> return an object which will
+be derived from this class. The dataconn class itself is derived from
+the C<IO::Socket::INET> class, so any normal IO operations can be performed.
+However the following methods are defined in the dataconn class and IO should
+be performed using these.
+
+=over 4
+
+=item read ( BUFFER, SIZE [, TIMEOUT ] )
+
+Read C<SIZE> bytes of data from the server and place it into C<BUFFER>, also
+performing any <CRLF> translation necessary. C<TIMEOUT> is optional, if not
+given, the timeout value from the command connection will be used.
+
+Returns the number of bytes read before any <CRLF> translation.
+
+=item write ( BUFFER, SIZE [, TIMEOUT ] )
+
+Write C<SIZE> bytes of data from C<BUFFER> to the server, also
+performing any <CRLF> translation necessary. C<TIMEOUT> is optional, if not
+given, the timeout value from the command connection will be used.
+
+Returns the number of bytes written before any <CRLF> translation.
+
+=item bytes_read ()
+
+Returns the number of bytes read so far.
+
+=item abort ()
+
+Abort the current data transfer.
+
+=item close ()
+
+Close the data connection and get a response from the FTP server. Returns
+I<true> if the connection was closed successfully and the first digit of
+the response from the server was a '2'.
+
+=back
+
+=cut
@@ -0,0 +1,2009 @@
+# Net::FTP.pm
+#
+# Versions up to 2.77_2 Copyright (c) 1995-2004 Graham Barr <gbarr@pobox.com>.
+# All rights reserved.
+# Changes in Version 2.77_3 onwards Copyright (C) 2013-2014 Steve Hay. All
+# rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+#
+# Documentation (at end) improved 1996 by Nathan Torkington <gnat@frii.com>.
+
+package Net::FTP;
+
+use 5.008001;
+
+use strict;
+use warnings;
+
+use Carp;
+use Fcntl qw(O_WRONLY O_RDONLY O_APPEND O_CREAT O_TRUNC);
+use IO::Socket;
+use Net::Cmd;
+use Net::Config;
+use Socket 1.3;
+use Time::Local;
+
+our $VERSION = '3.02';
+
+our $IOCLASS;
+BEGIN {
+ # Code for detecting if we can use SSL
+ my $ssl_class = eval {
+ require IO::Socket::SSL;
+ # first version with default CA on most platforms
+ IO::Socket::SSL->VERSION(1.999);
+ } && 'IO::Socket::SSL';
+
+ my $nossl_warn = !$ssl_class &&
+ 'To use SSL please install IO::Socket::SSL with version>=1.999';
+
+ # Code for detecting if we can use IPv6
+ my $inet6_class = eval {
+ require IO::Socket::IP;
+ IO::Socket::IP->VERSION(0.20);
+ } && 'IO::Socket::IP' || eval {
+ require IO::Socket::INET6;
+ IO::Socket::INET6->VERSION(2.62);
+ } && 'IO::Socket::INET6';
+
+ sub can_ssl { $ssl_class };
+ sub can_inet6 { $inet6_class };
+
+ $IOCLASS = $ssl_class || $inet6_class || 'IO::Socket::INET';
+}
+
+our @ISA = ('Exporter','Net::Cmd',$IOCLASS);
+
+use constant TELNET_IAC => 255;
+use constant TELNET_IP => 244;
+use constant TELNET_DM => 242;
+
+use constant EBCDIC => $^O eq 'os390';
+
+sub new {
+ my $pkg = shift;
+ my ($peer, %arg);
+ if (@_ % 2) {
+ $peer = shift;
+ %arg = @_;
+ }
+ else {
+ %arg = @_;
+ $peer = delete $arg{Host};
+ }
+
+ my $host = $peer;
+ my $fire = undef;
+ my $fire_type = undef;
+
+ if (exists($arg{Firewall}) || Net::Config->requires_firewall($peer)) {
+ $fire = $arg{Firewall}
+ || $ENV{FTP_FIREWALL}
+ || $NetConfig{ftp_firewall}
+ || undef;
+
+ if (defined $fire) {
+ $peer = $fire;
+ delete $arg{Port};
+ $fire_type = $arg{FirewallType}
+ || $ENV{FTP_FIREWALL_TYPE}
+ || $NetConfig{firewall_type}
+ || undef;
+ }
+ }
+
+ my %tlsargs;
+ if (can_ssl()) {
+ # for name verification strip port from domain:port, ipv4:port, [ipv6]:port
+ (my $hostname = $host) =~s{(?<!:):\d+$}{};
+ %tlsargs = (
+ SSL_verifycn_scheme => 'ftp',
+ SSL_verifycn_name => $hostname,
+ # reuse SSL session of control connection in data connections
+ SSL_session_cache => Net::FTP::_SSL_SingleSessionCache->new,
+ );
+ # user defined SSL arg
+ $tlsargs{$_} = $arg{$_} for(grep { m{^SSL_} } keys %arg);
+
+ } elsif ($arg{SSL}) {
+ croak("IO::Socket::SSL >= 1.999 needed for SSL support");
+ }
+
+ my $ftp = $pkg->SUPER::new(
+ PeerAddr => $peer,
+ PeerPort => $arg{Port} || ($arg{SSL} ? 'ftps(990)' : 'ftp(21)'),
+ LocalAddr => $arg{'LocalAddr'},
+ Proto => 'tcp',
+ Timeout => defined $arg{Timeout} ? $arg{Timeout} : 120,
+ %tlsargs,
+ $arg{SSL} ? ():( SSL_startHandshake => 0 ),
+ ) or return;
+
+ ${*$ftp}{'net_ftp_host'} = $host; # Remote hostname
+ ${*$ftp}{'net_ftp_type'} = 'A'; # ASCII/binary/etc mode
+ ${*$ftp}{'net_ftp_blksize'} = abs($arg{'BlockSize'} || 10240);
+
+ ${*$ftp}{'net_ftp_localaddr'} = $arg{'LocalAddr'};
+
+ ${*$ftp}{'net_ftp_firewall'} = $fire
+ if (defined $fire);
+ ${*$ftp}{'net_ftp_firewall_type'} = $fire_type
+ if (defined $fire_type);
+
+ ${*$ftp}{'net_ftp_passive'} =
+ int exists $arg{Passive} ? $arg{Passive}
+ : exists $ENV{FTP_PASSIVE} ? $ENV{FTP_PASSIVE}
+ : defined $fire ? $NetConfig{ftp_ext_passive}
+ : $NetConfig{ftp_int_passive}; # Whew! :-)
+
+ ${*$ftp}{net_ftp_tlsargs} = \%tlsargs if %tlsargs;
+ if ($arg{SSL}) {
+ ${*$ftp}{net_ftp_tlsprot} = 'P';
+ ${*$ftp}{net_ftp_tlsdirect} = 1;
+ }
+
+ $ftp->hash(exists $arg{Hash} ? $arg{Hash} : 0, 1024);
+
+ $ftp->autoflush(1);
+
+ $ftp->debug(exists $arg{Debug} ? $arg{Debug} : undef);
+
+ unless ($ftp->response() == CMD_OK) {
+ $ftp->close();
+ # keep @$ if no message. Happens, when response did not start with a code.
+ $@ = $ftp->message || $@;
+ undef $ftp;
+ }
+
+ $ftp;
+}
+
+##
+## User interface methods
+##
+
+
+sub host {
+ my $me = shift;
+ ${*$me}{'net_ftp_host'};
+}
+
+sub passive {
+ my $ftp = shift;
+ return ${*$ftp}{'net_ftp_passive'} unless @_;
+ ${*$ftp}{'net_ftp_passive'} = shift;
+}
+
+
+sub hash {
+ my $ftp = shift; # self
+
+ my ($h, $b) = @_;
+ unless ($h) {
+ delete ${*$ftp}{'net_ftp_hash'};
+ return [\*STDERR, 0];
+ }
+ ($h, $b) = (ref($h) ? $h : \*STDERR, $b || 1024);
+ select((select($h), $| = 1)[0]);
+ $b = 512 if $b < 512;
+ ${*$ftp}{'net_ftp_hash'} = [$h, $b];
+}
+
+
+sub quit {
+ my $ftp = shift;
+
+ $ftp->_QUIT;
+ $ftp->close;
+}
+
+
+sub DESTROY { }
+
+
+sub ascii { shift->type('A', @_); }
+sub binary { shift->type('I', @_); }
+
+
+sub ebcdic {
+ carp "TYPE E is unsupported, shall default to I";
+ shift->type('E', @_);
+}
+
+
+sub byte {
+ carp "TYPE L is unsupported, shall default to I";
+ shift->type('L', @_);
+}
+
+# Allow the user to send a command directly, BE CAREFUL !!
+
+
+sub quot {
+ my $ftp = shift;
+ my $cmd = shift;
+
+ $ftp->command(uc $cmd, @_);
+ $ftp->response();
+}
+
+
+sub site {
+ my $ftp = shift;
+
+ $ftp->command("SITE", @_);
+ $ftp->response();
+}
+
+
+sub mdtm {
+ my $ftp = shift;
+ my $file = shift;
+
+ # Server Y2K bug workaround
+ #
+ # sigh; some idiotic FTP servers use ("19%d",tm.tm_year) instead of
+ # ("%d",tm.tm_year+1900). This results in an extra digit in the
+ # string returned. To account for this we allow an optional extra
+ # digit in the year. Then if the first two digits are 19 we use the
+ # remainder, otherwise we subtract 1900 from the whole year.
+
+ $ftp->_MDTM($file)
+ && $ftp->message =~ /((\d\d)(\d\d\d?))(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/
+ ? timegm($8, $7, $6, $5, $4 - 1, $2 eq '19' ? $3 : ($1 - 1900))
+ : undef;
+}
+
+
+sub size {
+ my $ftp = shift;
+ my $file = shift;
+ my $io;
+ if ($ftp->supported("SIZE")) {
+ return $ftp->_SIZE($file)
+ ? ($ftp->message =~ /(\d+)\s*(bytes?\s*)?$/)[0]
+ : undef;
+ }
+ elsif ($ftp->supported("STAT")) {
+ my @msg;
+ return
+ unless $ftp->_STAT($file) && (@msg = $ftp->message) == 3;
+ foreach my $line (@msg) {
+ return (split(/\s+/, $line))[4]
+ if $line =~ /^[-rwxSsTt]{10}/;
+ }
+ }
+ else {
+ my @files = $ftp->dir($file);
+ if (@files) {
+ return (split(/\s+/, $1))[4]
+ if $files[0] =~ /^([-rwxSsTt]{10}.*)$/;
+ }
+ }
+ undef;
+}
+
+
+sub starttls {
+ my $ftp = shift;
+ can_ssl() or croak("IO::Socket::SSL >= 1.999 needed for SSL support");
+ $ftp->is_SSL and croak("called starttls within SSL session");
+ $ftp->_AUTH('TLS') == CMD_OK or return;
+
+ $ftp->connect_SSL or return;
+ $ftp->prot('P');
+ return 1;
+}
+
+sub prot {
+ my ($ftp,$prot) = @_;
+ $prot eq 'C' or $prot eq 'P' or croak("prot must by C or P");
+ $ftp->_PBSZ(0) or return;
+ $ftp->_PROT($prot) or return;
+ ${*$ftp}{net_ftp_tlsprot} = $prot;
+ return 1;
+}
+
+sub stoptls {
+ my $ftp = shift;
+ $ftp->is_SSL or croak("called stoptls outside SSL session");
+ ${*$ftp}{net_ftp_tlsdirect} and croak("cannot stoptls direct SSL session");
+ $ftp->_CCC() or return;
+ $ftp->stop_SSL();
+ return 1;
+}
+
+sub login {
+ my ($ftp, $user, $pass, $acct) = @_;
+ my ($ok, $ruser, $fwtype);
+
+ unless (defined $user) {
+ require Net::Netrc;
+
+ my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_host'});
+
+ ($user, $pass, $acct) = $rc->lpa()
+ if ($rc);
+ }
+
+ $user ||= "anonymous";
+ $ruser = $user;
+
+ $fwtype = ${*$ftp}{'net_ftp_firewall_type'}
+ || $NetConfig{'ftp_firewall_type'}
+ || 0;
+
+ if ($fwtype && defined ${*$ftp}{'net_ftp_firewall'}) {
+ if ($fwtype == 1 || $fwtype == 7) {
+ $user .= '@' . ${*$ftp}{'net_ftp_host'};
+ }
+ else {
+ require Net::Netrc;
+
+ my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'});
+
+ my ($fwuser, $fwpass, $fwacct) = $rc ? $rc->lpa() : ();
+
+ if ($fwtype == 5) {
+ $user = join('@', $user, $fwuser, ${*$ftp}{'net_ftp_host'});
+ $pass = $pass . '@' . $fwpass;
+ }
+ else {
+ if ($fwtype == 2) {
+ $user .= '@' . ${*$ftp}{'net_ftp_host'};
+ }
+ elsif ($fwtype == 6) {
+ $fwuser .= '@' . ${*$ftp}{'net_ftp_host'};
+ }
+
+ $ok = $ftp->_USER($fwuser);
+
+ return 0 unless $ok == CMD_OK || $ok == CMD_MORE;
+
+ $ok = $ftp->_PASS($fwpass || "");
+
+ return 0 unless $ok == CMD_OK || $ok == CMD_MORE;
+
+ $ok = $ftp->_ACCT($fwacct)
+ if defined($fwacct);
+
+ if ($fwtype == 3) {
+ $ok = $ftp->command("SITE", ${*$ftp}{'net_ftp_host'})->response;
+ }
+ elsif ($fwtype == 4) {
+ $ok = $ftp->command("OPEN", ${*$ftp}{'net_ftp_host'})->response;
+ }
+
+ return 0 unless $ok == CMD_OK || $ok == CMD_MORE;
+ }
+ }
+ }
+
+ $ok = $ftp->_USER($user);
+
+ # Some dumb firewalls don't prefix the connection messages
+ $ok = $ftp->response()
+ if ($ok == CMD_OK && $ftp->code == 220 && $user =~ /\@/);
+
+ if ($ok == CMD_MORE) {
+ unless (defined $pass) {
+ require Net::Netrc;
+
+ my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_host'}, $ruser);
+
+ ($ruser, $pass, $acct) = $rc->lpa()
+ if ($rc);
+
+ $pass = '-anonymous@'
+ if (!defined $pass && (!defined($ruser) || $ruser =~ /^anonymous/o));
+ }
+
+ $ok = $ftp->_PASS($pass || "");
+ }
+
+ $ok = $ftp->_ACCT($acct)
+ if (defined($acct) && ($ok == CMD_MORE || $ok == CMD_OK));
+
+ if ($fwtype == 7 && $ok == CMD_OK && defined ${*$ftp}{'net_ftp_firewall'}) {
+ my ($f, $auth, $resp) = _auth_id($ftp);
+ $ftp->authorize($auth, $resp) if defined($resp);
+ }
+
+ $ok == CMD_OK;
+}
+
+
+sub account {
+ @_ == 2 or croak 'usage: $ftp->account( ACCT )';
+ my $ftp = shift;
+ my $acct = shift;
+ $ftp->_ACCT($acct) == CMD_OK;
+}
+
+
+sub _auth_id {
+ my ($ftp, $auth, $resp) = @_;
+
+ unless (defined $resp) {
+ require Net::Netrc;
+
+ $auth ||= eval { (getpwuid($>))[0] } || $ENV{NAME};
+
+ my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'}, $auth)
+ || Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'});
+
+ ($auth, $resp) = $rc->lpa()
+ if ($rc);
+ }
+ ($ftp, $auth, $resp);
+}
+
+
+sub authorize {
+ @_ >= 1 || @_ <= 3 or croak 'usage: $ftp->authorize( [AUTH [, RESP]])';
+
+ my ($ftp, $auth, $resp) = &_auth_id;
+
+ my $ok = $ftp->_AUTH($auth || "");
+
+ $ok = $ftp->_RESP($resp || "")
+ if ($ok == CMD_MORE);
+
+ $ok == CMD_OK;
+}
+
+
+sub rename {
+ @_ == 3 or croak 'usage: $ftp->rename(FROM, TO)';
+
+ my ($ftp, $from, $to) = @_;
+
+ $ftp->_RNFR($from)
+ && $ftp->_RNTO($to);
+}
+
+
+sub type {
+ my $ftp = shift;
+ my $type = shift;
+ my $oldval = ${*$ftp}{'net_ftp_type'};
+
+ return $oldval
+ unless (defined $type);
+
+ return
+ unless ($ftp->_TYPE($type, @_));
+
+ ${*$ftp}{'net_ftp_type'} = join(" ", $type, @_);
+
+ $oldval;
+}
+
+
+sub alloc {
+ my $ftp = shift;
+ my $size = shift;
+ my $oldval = ${*$ftp}{'net_ftp_allo'};
+
+ return $oldval
+ unless (defined $size);
+
+ return
+ unless ($ftp->supported("ALLO") and $ftp->_ALLO($size, @_));
+
+ ${*$ftp}{'net_ftp_allo'} = join(" ", $size, @_);
+
+ $oldval;
+}
+
+
+sub abort {
+ my $ftp = shift;
+
+ send($ftp, pack("CCC", TELNET_IAC, TELNET_IP, TELNET_IAC), MSG_OOB);
+
+ $ftp->command(pack("C", TELNET_DM) . "ABOR");
+
+ ${*$ftp}{'net_ftp_dataconn'}->close()
+ if defined ${*$ftp}{'net_ftp_dataconn'};
+
+ $ftp->response();
+
+ $ftp->status == CMD_OK;
+}
+
+
+sub get {
+ my ($ftp, $remote, $local, $where) = @_;
+
+ my ($loc, $len, $buf, $resp, $data);
+ local *FD;
+
+ my $localfd = ref($local) || ref(\$local) eq "GLOB";
+
+ ($local = $remote) =~ s#^.*/##
+ unless (defined $local);
+
+ croak("Bad remote filename '$remote'\n")
+ if $remote =~ /[\r\n]/s;
+
+ ${*$ftp}{'net_ftp_rest'} = $where if defined $where;
+ my $rest = ${*$ftp}{'net_ftp_rest'};
+
+ delete ${*$ftp}{'net_ftp_port'};
+ delete ${*$ftp}{'net_ftp_pasv'};
+
+ $data = $ftp->retr($remote)
+ or return;
+
+ if ($localfd) {
+ $loc = $local;
+ }
+ else {
+ $loc = \*FD;
+
+ unless (sysopen($loc, $local, O_CREAT | O_WRONLY | ($rest ? O_APPEND: O_TRUNC))) {
+ carp "Cannot open Local file $local: $!\n";
+ $data->abort;
+ return;
+ }
+ }
+
+ if ($ftp->type eq 'I' && !binmode($loc)) {
+ carp "Cannot binmode Local file $local: $!\n";
+ $data->abort;
+ close($loc) unless $localfd;
+ return;
+ }
+
+ $buf = '';
+ my ($count, $hashh, $hashb, $ref) = (0);
+
+ ($hashh, $hashb) = @$ref
+ if ($ref = ${*$ftp}{'net_ftp_hash'});
+
+ my $blksize = ${*$ftp}{'net_ftp_blksize'};
+ local $\; # Just in case
+
+ while (1) {
+ last unless $len = $data->read($buf, $blksize);
+
+ if (EBCDIC && $ftp->type ne 'I') {
+ $buf = $ftp->toebcdic($buf);
+ $len = length($buf);
+ }
+
+ if ($hashh) {
+ $count += $len;
+ print $hashh "#" x (int($count / $hashb));
+ $count %= $hashb;
+ }
+ unless (print $loc $buf) {
+ carp "Cannot write to Local file $local: $!\n";
+ $data->abort;
+ close($loc)
+ unless $localfd;
+ return;
+ }
+ }
+
+ print $hashh "\n" if $hashh;
+
+ unless ($localfd) {
+ unless (close($loc)) {
+ carp "Cannot close file $local (perhaps disk space) $!\n";
+ return;
+ }
+ }
+
+ unless ($data->close()) # implied $ftp->response
+ {
+ carp "Unable to close datastream";
+ return;
+ }
+
+ return $local;
+}
+
+
+sub cwd {
+ @_ == 1 || @_ == 2 or croak 'usage: $ftp->cwd( [ DIR ] )';
+
+ my ($ftp, $dir) = @_;
+
+ $dir = "/" unless defined($dir) && $dir =~ /\S/;
+
+ $dir eq ".."
+ ? $ftp->_CDUP()
+ : $ftp->_CWD($dir);
+}
+
+
+sub cdup {
+ @_ == 1 or croak 'usage: $ftp->cdup()';
+ $_[0]->_CDUP;
+}
+
+
+sub pwd {
+ @_ == 1 || croak 'usage: $ftp->pwd()';
+ my $ftp = shift;
+
+ $ftp->_PWD();
+ $ftp->_extract_path;
+}
+
+# rmdir( $ftp, $dir, [ $recurse ] )
+#
+# Removes $dir on remote host via FTP.
+# $ftp is handle for remote host
+#
+# If $recurse is TRUE, the directory and deleted recursively.
+# This means all of its contents and subdirectories.
+#
+# Initial version contributed by Dinkum Software
+#
+sub rmdir {
+ @_ == 2 || @_ == 3 or croak('usage: $ftp->rmdir( DIR [, RECURSE ] )');
+
+ # Pick off the args
+ my ($ftp, $dir, $recurse) = @_;
+ my $ok;
+
+ return $ok
+ if $ok = $ftp->_RMD($dir)
+ or !$recurse;
+
+ # Try to delete the contents
+ # Get a list of all the files in the directory
+ my @filelist = grep { !/^\.{1,2}$/ } $ftp->ls($dir);
+
+ return
+ unless @filelist; # failed, it is probably not a directory
+
+ return $ftp->delete($dir)
+ if @filelist == 1 and $dir eq $filelist[0];
+
+ # Go thru and delete each file or the directory
+ foreach my $file (map { m,/, ? $_ : "$dir/$_" } @filelist) {
+ next # successfully deleted the file
+ if $ftp->delete($file);
+
+ # Failed to delete it, assume its a directory
+ # Recurse and ignore errors, the final rmdir() will
+ # fail on any errors here
+ return $ok
+ unless $ok = $ftp->rmdir($file, 1);
+ }
+
+ # Directory should be empty
+ # Try to remove the directory again
+ # Pass results directly to caller
+ # If any of the prior deletes failed, this
+ # rmdir() will fail because directory is not empty
+ return $ftp->_RMD($dir);
+}
+
+
+sub restart {
+ @_ == 2 || croak 'usage: $ftp->restart( BYTE_OFFSET )';
+
+ my ($ftp, $where) = @_;
+
+ ${*$ftp}{'net_ftp_rest'} = $where;
+
+ return;
+}
+
+
+sub mkdir {
+ @_ == 2 || @_ == 3 or croak 'usage: $ftp->mkdir( DIR [, RECURSE ] )';
+
+ my ($ftp, $dir, $recurse) = @_;
+
+ $ftp->_MKD($dir) || $recurse
+ or return;
+
+ my $path = $dir;
+
+ unless ($ftp->ok) {
+ my @path = split(m#(?=/+)#, $dir);
+
+ $path = "";
+
+ while (@path) {
+ $path .= shift @path;
+
+ $ftp->_MKD($path);
+
+ $path = $ftp->_extract_path($path);
+ }
+
+ # If the creation of the last element was not successful, see if we
+ # can cd to it, if so then return path
+
+ unless ($ftp->ok) {
+ my ($status, $message) = ($ftp->status, $ftp->message);
+ my $pwd = $ftp->pwd;
+
+ if ($pwd && $ftp->cwd($dir)) {
+ $path = $dir;
+ $ftp->cwd($pwd);
+ }
+ else {
+ undef $path;
+ }
+ $ftp->set_status($status, $message);
+ }
+ }
+
+ $path;
+}
+
+
+sub delete {
+ @_ == 2 || croak 'usage: $ftp->delete( FILENAME )';
+
+ $_[0]->_DELE($_[1]);
+}
+
+
+sub put { shift->_store_cmd("stor", @_) }
+sub put_unique { shift->_store_cmd("stou", @_) }
+sub append { shift->_store_cmd("appe", @_) }
+
+
+sub nlst { shift->_data_cmd("NLST", @_) }
+sub list { shift->_data_cmd("LIST", @_) }
+sub retr { shift->_data_cmd("RETR", @_) }
+sub stor { shift->_data_cmd("STOR", @_) }
+sub stou { shift->_data_cmd("STOU", @_) }
+sub appe { shift->_data_cmd("APPE", @_) }
+
+
+sub _store_cmd {
+ my ($ftp, $cmd, $local, $remote) = @_;
+ my ($loc, $sock, $len, $buf);
+ local *FD;
+
+ my $localfd = ref($local) || ref(\$local) eq "GLOB";
+
+ if (!defined($remote) and 'STOU' ne uc($cmd)) {
+ croak 'Must specify remote filename with stream input'
+ if $localfd;
+
+ require File::Basename;
+ $remote = File::Basename::basename($local);
+ }
+ if (defined ${*$ftp}{'net_ftp_allo'}) {
+ delete ${*$ftp}{'net_ftp_allo'};
+ }
+ else {
+
+ # if the user hasn't already invoked the alloc method since the last
+ # _store_cmd call, figure out if the local file is a regular file(not
+ # a pipe, or device) and if so get the file size from stat, and send
+ # an ALLO command before sending the STOR, STOU, or APPE command.
+ my $size = do { local $^W; -f $local && -s _ }; # no ALLO if sending data from a pipe
+ ${*$ftp}{'net_ftp_allo'} = $size if $size;
+ }
+ croak("Bad remote filename '$remote'\n")
+ if defined($remote) and $remote =~ /[\r\n]/s;
+
+ if ($localfd) {
+ $loc = $local;
+ }
+ else {
+ $loc = \*FD;
+
+ unless (sysopen($loc, $local, O_RDONLY)) {
+ carp "Cannot open Local file $local: $!\n";
+ return;
+ }
+ }
+
+ if ($ftp->type eq 'I' && !binmode($loc)) {
+ carp "Cannot binmode Local file $local: $!\n";
+ return;
+ }
+
+ delete ${*$ftp}{'net_ftp_port'};
+ delete ${*$ftp}{'net_ftp_pasv'};
+
+ $sock = $ftp->_data_cmd($cmd, grep { defined } $remote)
+ or return;
+
+ $remote = ($ftp->message =~ /\w+\s*:\s*(.*)/)[0]
+ if 'STOU' eq uc $cmd;
+
+ my $blksize = ${*$ftp}{'net_ftp_blksize'};
+
+ my ($count, $hashh, $hashb, $ref) = (0);
+
+ ($hashh, $hashb) = @$ref
+ if ($ref = ${*$ftp}{'net_ftp_hash'});
+
+ while (1) {
+ last unless $len = read($loc, $buf = "", $blksize);
+
+ if (EBCDIC && $ftp->type ne 'I') {
+ $buf = $ftp->toascii($buf);
+ $len = length($buf);
+ }
+
+ if ($hashh) {
+ $count += $len;
+ print $hashh "#" x (int($count / $hashb));
+ $count %= $hashb;
+ }
+
+ my $wlen;
+ unless (defined($wlen = $sock->write($buf, $len)) && $wlen == $len) {
+ $sock->abort;
+ close($loc)
+ unless $localfd;
+ print $hashh "\n" if $hashh;
+ return;
+ }
+ }
+
+ print $hashh "\n" if $hashh;
+
+ close($loc)
+ unless $localfd;
+
+ $sock->close()
+ or return;
+
+ if ('STOU' eq uc $cmd and $ftp->message =~ m/unique\s+file\s*name\s*:\s*(.*)\)|"(.*)"/) {
+ require File::Basename;
+ $remote = File::Basename::basename($+);
+ }
+
+ return $remote;
+}
+
+
+sub port {
+ @_ == 1 || @_ == 2 or croak 'usage: $self->port([PORT])';
+ return _eprt('PORT',@_);
+}
+
+sub eprt {
+ @_ == 1 || @_ == 2 or croak 'usage: $self->eprt([PORT])';
+ return _eprt('EPRT',@_);
+}
+
+sub _eprt {
+ my ($cmd,$ftp,$port) = @_;
+ delete ${*$ftp}{net_ftp_intern_port};
+ unless ($port) {
+ my $listen = ${*$ftp}{net_ftp_listen} ||= $IOCLASS->new(
+ Listen => 1,
+ Timeout => $ftp->timeout,
+ LocalAddr => $ftp->sockhost,
+ can_ssl() ? (
+ %{ ${*$ftp}{net_ftp_tlsargs} },
+ SSL_startHandshake => 0,
+ ):(),
+ );
+ ${*$ftp}{net_ftp_intern_port} = 1;
+ my $fam = ($listen->sockdomain == AF_INET) ? 1:2;
+ if ( $cmd eq 'EPRT' || $fam == 2 ) {
+ $port = "|$fam|".$listen->sockhost."|".$listen->sockport."|";
+ $cmd = 'EPRT';
+ } else {
+ my $p = $listen->sockport;
+ $port = join(',',split(m{\.},$listen->sockhost),$p >> 8,$p & 0xff);
+ }
+ }
+ my $ok = $cmd eq 'EPRT' ? $ftp->_EPRT($port) : $ftp->_PORT($port);
+ ${*$ftp}{net_ftp_port} = $port if $ok;
+ return $ok;
+}
+
+
+sub ls { shift->_list_cmd("NLST", @_); }
+sub dir { shift->_list_cmd("LIST", @_); }
+
+
+sub pasv {
+ my $ftp = shift;
+ @_ and croak 'usage: $ftp->port()';
+ return $ftp->epsv if $ftp->sockdomain != AF_INET;
+ delete ${*$ftp}{net_ftp_intern_port};
+
+ if ( $ftp->_PASV &&
+ $ftp->message =~ m{(\d+,\d+,\d+,\d+),(\d+),(\d+)} ) {
+ my $port = 256 * $2 + $3;
+ ( my $ip = $1 ) =~s{,}{.}g;
+ return ${*$ftp}{net_ftp_pasv} = [ $ip,$port ];
+ }
+ return;
+}
+
+sub epsv {
+ my $ftp = shift;
+ @_ and croak 'usage: $ftp->epsv()';
+ delete ${*$ftp}{net_ftp_intern_port};
+
+ $ftp->_EPSV && $ftp->message =~ m{\(([\x33-\x7e])\1\1(\d+)\1\)}
+ ? ${*$ftp}{net_ftp_pasv} = [ $ftp->peerhost, $2 ]
+ : undef;
+}
+
+
+sub unique_name {
+ my $ftp = shift;
+ ${*$ftp}{'net_ftp_unique'} || undef;
+}
+
+
+sub supported {
+ @_ == 2 or croak 'usage: $ftp->supported( CMD )';
+ my $ftp = shift;
+ my $cmd = uc shift;
+ my $hash = ${*$ftp}{'net_ftp_supported'} ||= {};
+
+ return $hash->{$cmd}
+ if exists $hash->{$cmd};
+
+ return $hash->{$cmd} = 1
+ if $ftp->feature($cmd);
+
+ return $hash->{$cmd} = 0
+ unless $ftp->_HELP($cmd);
+
+ my $text = $ftp->message;
+ if ($text =~ /following.+commands/i) {
+ $text =~ s/^.*\n//;
+ while ($text =~ /(\*?)(\w+)(\*?)/sg) {
+ $hash->{"\U$2"} = !length("$1$3");
+ }
+ }
+ else {
+ $hash->{$cmd} = $text !~ /unimplemented/i;
+ }
+
+ $hash->{$cmd} ||= 0;
+}
+
+##
+## Deprecated methods
+##
+
+
+sub lsl {
+ carp "Use of Net::FTP::lsl deprecated, use 'dir'"
+ if $^W;
+ goto &dir;
+}
+
+
+sub authorise {
+ carp "Use of Net::FTP::authorise deprecated, use 'authorize'"
+ if $^W;
+ goto &authorize;
+}
+
+
+##
+## Private methods
+##
+
+
+sub _extract_path {
+ my ($ftp, $path) = @_;
+
+ # This tries to work both with and without the quote doubling
+ # convention (RFC 959 requires it, but the first 3 servers I checked
+ # didn't implement it). It will fail on a server which uses a quote in
+ # the message which isn't a part of or surrounding the path.
+ $ftp->ok
+ && $ftp->message =~ /(?:^|\s)\"(.*)\"(?:$|\s)/
+ && ($path = $1) =~ s/\"\"/\"/g;
+
+ $path;
+}
+
+##
+## Communication methods
+##
+
+
+sub _dataconn {
+ my $ftp = shift;
+ my $pkg = "Net::FTP::" . $ftp->type;
+ eval "require " . $pkg ## no critic (BuiltinFunctions::ProhibitStringyEval)
+ or croak("cannot load $pkg required for type ".$ftp->type);
+ $pkg =~ s/ /_/g;
+ delete ${*$ftp}{net_ftp_dataconn};
+
+ my $conn;
+ my $pasv = ${*$ftp}{net_ftp_pasv};
+ if ($pasv) {
+ $conn = $pkg->new(
+ PeerAddr => $pasv->[0],
+ PeerPort => $pasv->[1],
+ LocalAddr => ${*$ftp}{net_ftp_localaddr},
+ Timeout => $ftp->timeout,
+ can_ssl() ? (
+ SSL_startHandshake => 0,
+ $ftp->is_SSL ? (
+ SSL_reuse_ctx => $ftp,
+ SSL_verifycn_name => ${*$ftp}{net_ftp_tlsargs}{SSL_verifycn_name},
+ ) :( %{${*$ftp}{net_ftp_tlsargs}} ),
+ ):(),
+ ) or return;
+ } elsif (my $listen = delete ${*$ftp}{net_ftp_listen}) {
+ $conn = $listen->accept($pkg) or return;
+ $conn->timeout($ftp->timeout);
+ close($listen);
+ } else {
+ croak("no listener in active mode");
+ }
+
+ if (( ${*$ftp}{net_ftp_tlsprot} || '') eq 'P') {
+ if ($conn->connect_SSL) {
+ # SSL handshake ok
+ } else {
+ carp("failed to ssl upgrade dataconn: $IO::Socket::SSL::SSL_ERROR");
+ return;
+ }
+ }
+
+ ${*$ftp}{net_ftp_dataconn} = $conn;
+ ${*$conn} = "";
+ ${*$conn}{net_ftp_cmd} = $ftp;
+ ${*$conn}{net_ftp_blksize} = ${*$ftp}{net_ftp_blksize};
+ return $conn;
+}
+
+
+sub _list_cmd {
+ my $ftp = shift;
+ my $cmd = uc shift;
+
+ delete ${*$ftp}{'net_ftp_port'};
+ delete ${*$ftp}{'net_ftp_pasv'};
+
+ my $data = $ftp->_data_cmd($cmd, @_);
+
+ return
+ unless (defined $data);
+
+ require Net::FTP::A;
+ bless $data, "Net::FTP::A"; # Force ASCII mode
+
+ my $databuf = '';
+ my $buf = '';
+ my $blksize = ${*$ftp}{'net_ftp_blksize'};
+
+ while ($data->read($databuf, $blksize)) {
+ $buf .= $databuf;
+ }
+
+ my $list = [split(/\n/, $buf)];
+
+ $data->close();
+
+ if (EBCDIC) {
+ for (@$list) { $_ = $ftp->toebcdic($_) }
+ }
+
+ wantarray
+ ? @{$list}
+ : $list;
+}
+
+
+sub _data_cmd {
+ my $ftp = shift;
+ my $cmd = uc shift;
+ my $ok = 1;
+ my $where = delete ${*$ftp}{'net_ftp_rest'} || 0;
+ my $arg;
+
+ for my $arg (@_) {
+ croak("Bad argument '$arg'\n")
+ if $arg =~ /[\r\n]/s;
+ }
+
+ if ( ${*$ftp}{'net_ftp_passive'}
+ && !defined ${*$ftp}{'net_ftp_pasv'}
+ && !defined ${*$ftp}{'net_ftp_port'})
+ {
+ return unless defined $ftp->pasv;
+
+ if ($where and !$ftp->_REST($where)) {
+ my ($status, $message) = ($ftp->status, $ftp->message);
+ $ftp->abort;
+ $ftp->set_status($status, $message);
+ return;
+ }
+
+ # first send command, then open data connection
+ # otherwise the peer might not do a full accept (with SSL
+ # handshake if PROT P)
+ $ftp->command($cmd, @_);
+ my $data = $ftp->_dataconn();
+ if (CMD_INFO == $ftp->response()) {
+ $data->reading
+ if $data && $cmd =~ /RETR|LIST|NLST/;
+ return $data;
+ }
+ $data->_close if $data;
+
+ return;
+ }
+
+ $ok = $ftp->port
+ unless (defined ${*$ftp}{'net_ftp_port'}
+ || defined ${*$ftp}{'net_ftp_pasv'});
+
+ $ok = $ftp->_REST($where)
+ if $ok && $where;
+
+ return
+ unless $ok;
+
+ if ($cmd =~ /(STOR|APPE|STOU)/ and exists ${*$ftp}{net_ftp_allo} and
+ $ftp->supported("ALLO"))
+ {
+ $ftp->_ALLO(delete ${*$ftp}{net_ftp_allo})
+ or return;
+ }
+
+ $ftp->command($cmd, @_);
+
+ return 1
+ if (defined ${*$ftp}{'net_ftp_pasv'});
+
+ $ok = CMD_INFO == $ftp->response();
+
+ return $ok
+ unless exists ${*$ftp}{'net_ftp_intern_port'};
+
+ if ($ok) {
+ my $data = $ftp->_dataconn();
+
+ $data->reading
+ if $data && $cmd =~ /RETR|LIST|NLST/;
+
+ return $data;
+ }
+
+
+ close(delete ${*$ftp}{'net_ftp_listen'});
+
+ return;
+}
+
+##
+## Over-ride methods (Net::Cmd)
+##
+
+
+sub debug_text { $_[2] =~ /^(pass|resp|acct)/i ? "$1 ....\n" : $_[2]; }
+
+
+sub command {
+ my $ftp = shift;
+
+ delete ${*$ftp}{'net_ftp_port'};
+ $ftp->SUPER::command(@_);
+}
+
+
+sub response {
+ my $ftp = shift;
+ my $code = $ftp->SUPER::response() || 5; # assume 500 if undef
+
+ delete ${*$ftp}{'net_ftp_pasv'}
+ if ($code != CMD_MORE && $code != CMD_INFO);
+
+ $code;
+}
+
+
+sub parse_response {
+ return ($1, $2 eq "-")
+ if $_[1] =~ s/^(\d\d\d)([- ]?)//o;
+
+ my $ftp = shift;
+
+ # Darn MS FTP server is a load of CRAP !!!!
+ # Expect to see undef here.
+ return ()
+ unless 0 + (${*$ftp}{'net_cmd_code'} || 0);
+
+ (${*$ftp}{'net_cmd_code'}, 1);
+}
+
+##
+## Allow 2 servers to talk directly
+##
+
+
+sub pasv_xfer_unique {
+ my ($sftp, $sfile, $dftp, $dfile) = @_;
+ $sftp->pasv_xfer($sfile, $dftp, $dfile, 1);
+}
+
+
+sub pasv_xfer {
+ my ($sftp, $sfile, $dftp, $dfile, $unique) = @_;
+
+ ($dfile = $sfile) =~ s#.*/##
+ unless (defined $dfile);
+
+ my $port = $sftp->pasv
+ or return;
+
+ $dftp->port($port)
+ or return;
+
+ return
+ unless ($unique ? $dftp->stou($dfile) : $dftp->stor($dfile));
+
+ unless ($sftp->retr($sfile) && $sftp->response == CMD_INFO) {
+ $sftp->retr($sfile);
+ $dftp->abort;
+ $dftp->response();
+ return;
+ }
+
+ $dftp->pasv_wait($sftp);
+}
+
+
+sub pasv_wait {
+ @_ == 2 or croak 'usage: $ftp->pasv_wait(NON_PASV_FTP)';
+
+ my ($ftp, $non_pasv) = @_;
+ my ($file, $rin, $rout);
+
+ vec($rin = '', fileno($ftp), 1) = 1;
+ select($rout = $rin, undef, undef, undef);
+
+ my $dres = $ftp->response();
+ my $sres = $non_pasv->response();
+
+ return
+ unless $dres == CMD_OK && $sres == CMD_OK;
+
+ return
+ unless $ftp->ok() && $non_pasv->ok();
+
+ return $1
+ if $ftp->message =~ /unique file name:\s*(\S*)\s*\)/;
+
+ return $1
+ if $non_pasv->message =~ /unique file name:\s*(\S*)\s*\)/;
+
+ return 1;
+}
+
+
+sub feature {
+ @_ == 2 or croak 'usage: $ftp->feature( NAME )';
+ my ($ftp, $feat) = @_;
+
+ my $feature = ${*$ftp}{net_ftp_feature} ||= do {
+ my @feat;
+
+ # Example response
+ # 211-Features:
+ # MDTM
+ # REST STREAM
+ # SIZE
+ # 211 End
+
+ @feat = map { /^\s+(.*\S)/ } $ftp->message
+ if $ftp->_FEAT;
+
+ \@feat;
+ };
+
+ return grep { /^\Q$feat\E\b/i } @$feature;
+}
+
+
+sub cmd { shift->command(@_)->response() }
+
+########################################
+#
+# RFC959 + RFC2428 + RFC4217 commands
+#
+
+
+sub _ABOR { shift->command("ABOR")->response() == CMD_OK }
+sub _ALLO { shift->command("ALLO", @_)->response() == CMD_OK }
+sub _CDUP { shift->command("CDUP")->response() == CMD_OK }
+sub _NOOP { shift->command("NOOP")->response() == CMD_OK }
+sub _PASV { shift->command("PASV")->response() == CMD_OK }
+sub _QUIT { shift->command("QUIT")->response() == CMD_OK }
+sub _DELE { shift->command("DELE", @_)->response() == CMD_OK }
+sub _CWD { shift->command("CWD", @_)->response() == CMD_OK }
+sub _PORT { shift->command("PORT", @_)->response() == CMD_OK }
+sub _RMD { shift->command("RMD", @_)->response() == CMD_OK }
+sub _MKD { shift->command("MKD", @_)->response() == CMD_OK }
+sub _PWD { shift->command("PWD", @_)->response() == CMD_OK }
+sub _TYPE { shift->command("TYPE", @_)->response() == CMD_OK }
+sub _RNTO { shift->command("RNTO", @_)->response() == CMD_OK }
+sub _RESP { shift->command("RESP", @_)->response() == CMD_OK }
+sub _MDTM { shift->command("MDTM", @_)->response() == CMD_OK }
+sub _SIZE { shift->command("SIZE", @_)->response() == CMD_OK }
+sub _HELP { shift->command("HELP", @_)->response() == CMD_OK }
+sub _STAT { shift->command("STAT", @_)->response() == CMD_OK }
+sub _FEAT { shift->command("FEAT", @_)->response() == CMD_OK }
+sub _PBSZ { shift->command("PBSZ", @_)->response() == CMD_OK }
+sub _PROT { shift->command("PROT", @_)->response() == CMD_OK }
+sub _CCC { shift->command("CCC", @_)->response() == CMD_OK }
+sub _EPRT { shift->command("EPRT", @_)->response() == CMD_OK }
+sub _EPSV { shift->command("EPSV", @_)->response() == CMD_OK }
+sub _APPE { shift->command("APPE", @_)->response() == CMD_INFO }
+sub _LIST { shift->command("LIST", @_)->response() == CMD_INFO }
+sub _NLST { shift->command("NLST", @_)->response() == CMD_INFO }
+sub _RETR { shift->command("RETR", @_)->response() == CMD_INFO }
+sub _STOR { shift->command("STOR", @_)->response() == CMD_INFO }
+sub _STOU { shift->command("STOU", @_)->response() == CMD_INFO }
+sub _RNFR { shift->command("RNFR", @_)->response() == CMD_MORE }
+sub _REST { shift->command("REST", @_)->response() == CMD_MORE }
+sub _PASS { shift->command("PASS", @_)->response() }
+sub _ACCT { shift->command("ACCT", @_)->response() }
+sub _AUTH { shift->command("AUTH", @_)->response() }
+
+
+sub _USER {
+ my $ftp = shift;
+ my $ok = $ftp->command("USER", @_)->response();
+
+ # A certain brain dead firewall :-)
+ $ok = $ftp->command("user", @_)->response()
+ unless $ok == CMD_MORE or $ok == CMD_OK;
+
+ $ok;
+}
+
+
+sub _SMNT { shift->unsupported(@_) }
+sub _MODE { shift->unsupported(@_) }
+sub _SYST { shift->unsupported(@_) }
+sub _STRU { shift->unsupported(@_) }
+sub _REIN { shift->unsupported(@_) }
+
+{
+ # Session Cache with single entry
+ # used to make sure that we reuse same session for control and data channels
+ package Net::FTP::_SSL_SingleSessionCache;
+ sub new { my $x; return bless \$x,shift }
+ sub add_session {
+ my ($cache,$key,$session) = @_;
+ Net::SSLeay::SESSION_free($$cache) if $$cache;
+ $$cache = $session;
+ }
+ sub get_session {
+ my $cache = shift;
+ return $$cache
+ }
+ sub DESTROY {
+ my $cache = shift;
+ Net::SSLeay::SESSION_free($$cache) if $$cache;
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Net::FTP - FTP Client class
+
+=head1 SYNOPSIS
+
+ use Net::FTP;
+
+ $ftp = Net::FTP->new("some.host.name", Debug => 0)
+ or die "Cannot connect to some.host.name: $@";
+
+ $ftp->login("anonymous",'-anonymous@')
+ or die "Cannot login ", $ftp->message;
+
+ $ftp->cwd("/pub")
+ or die "Cannot change working directory ", $ftp->message;
+
+ $ftp->get("that.file")
+ or die "get failed ", $ftp->message;
+
+ $ftp->quit;
+
+=head1 DESCRIPTION
+
+C<Net::FTP> is a class implementing a simple FTP client in Perl as
+described in RFC959. It provides wrappers for a subset of the RFC959
+commands.
+
+The Net::FTP class is a subclass of Net::Cmd and IO::Socket::INET.
+
+=head1 OVERVIEW
+
+FTP stands for File Transfer Protocol. It is a way of transferring
+files between networked machines. The protocol defines a client
+(whose commands are provided by this module) and a server (not
+implemented in this module). Communication is always initiated by the
+client, and the server responds with a message and a status code (and
+sometimes with data).
+
+The FTP protocol allows files to be sent to or fetched from the
+server. Each transfer involves a B<local file> (on the client) and a
+B<remote file> (on the server). In this module, the same file name
+will be used for both local and remote if only one is specified. This
+means that transferring remote file C</path/to/file> will try to put
+that file in C</path/to/file> locally, unless you specify a local file
+name.
+
+The protocol also defines several standard B<translations> which the
+file can undergo during transfer. These are ASCII, EBCDIC, binary,
+and byte. ASCII is the default type, and indicates that the sender of
+files will translate the ends of lines to a standard representation
+which the receiver will then translate back into their local
+representation. EBCDIC indicates the file being transferred is in
+EBCDIC format. Binary (also known as image) format sends the data as
+a contiguous bit stream. Byte format transfers the data as bytes, the
+values of which remain the same regardless of differences in byte size
+between the two machines (in theory - in practice you should only use
+this if you really know what you're doing). This class does not support
+the EBCDIC or byte formats, and will default to binary instead if they
+are attempted.
+
+=head1 CONSTRUCTOR
+
+=over 4
+
+=item new ([ HOST ] [, OPTIONS ])
+
+This is the constructor for a new Net::FTP object. C<HOST> is the
+name of the remote host to which an FTP connection is required.
+
+C<HOST> is optional. If C<HOST> is not given then it may instead be
+passed as the C<Host> option described below.
+
+C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
+Possible options are:
+
+B<Host> - FTP host to connect to. It may be a single scalar, as defined for
+the C<PeerAddr> option in L<IO::Socket::INET>, or a reference to
+an array with hosts to try in turn. The L</host> method will return the value
+which was used to connect to the host.
+
+B<Firewall> - The name of a machine which acts as an FTP firewall. This can be
+overridden by an environment variable C<FTP_FIREWALL>. If specified, and the
+given host cannot be directly connected to, then the
+connection is made to the firewall machine and the string C<@hostname> is
+appended to the login identifier. This kind of setup is also referred to
+as an ftp proxy.
+
+B<FirewallType> - The type of firewall running on the machine indicated by
+B<Firewall>. This can be overridden by an environment variable
+C<FTP_FIREWALL_TYPE>. For a list of permissible types, see the description of
+ftp_firewall_type in L<Net::Config>.
+
+B<BlockSize> - This is the block size that Net::FTP will use when doing
+transfers. (defaults to 10240)
+
+B<Port> - The port number to connect to on the remote machine for the
+FTP connection
+
+B<SSL> - If the connection should be done from start with SSL, contrary to later
+upgrade with C<starttls>.
+
+B<SSL_*> - SSL arguments which will be applied when upgrading the control or
+data connection to SSL. You can use SSL arguments as documented in
+L<IO::Socket::SSL>, but it will usually use the right arguments already.
+
+B<Timeout> - Set a timeout value in seconds (defaults to 120)
+
+B<Debug> - debug level (see the debug method in L<Net::Cmd>)
+
+B<Passive> - If set to a non-zero value then all data transfers will
+be done using passive mode. If set to zero then data transfers will be
+done using active mode. If the machine is connected to the Internet
+directly, both passive and active mode should work equally well.
+Behind most firewall and NAT configurations passive mode has a better
+chance of working. However, in some rare firewall configurations,
+active mode actually works when passive mode doesn't. Some really old
+FTP servers might not implement passive transfers. If not specified,
+then the transfer mode is set by the environment variable
+C<FTP_PASSIVE> or if that one is not set by the settings done by the
+F<libnetcfg> utility. If none of these apply then passive mode is
+used.
+
+B<Hash> - If given a reference to a file handle (e.g., C<\*STDERR>),
+print hash marks (#) on that filehandle every 1024 bytes. This
+simply invokes the C<hash()> method for you, so that hash marks
+are displayed for all transfers. You can, of course, call C<hash()>
+explicitly whenever you'd like.
+
+B<LocalAddr> - Local address to use for all socket connections, this
+argument will be passed to L<IO::Socket::INET>
+
+If the constructor fails undef will be returned and an error message will
+be in $@
+
+=back
+
+=head1 METHODS
+
+Unless otherwise stated all methods return either a I<true> or I<false>
+value, with I<true> meaning that the operation was a success. When a method
+states that it returns a value, failure will be returned as I<undef> or an
+empty list.
+
+C<Net::FTP> inherits from C<Net::Cmd> so methods defined in C<Net::Cmd> may
+be used to send commands to the remote FTP server in addition to the methods
+documented here.
+
+=over 4
+
+=item login ([LOGIN [,PASSWORD [, ACCOUNT] ] ])
+
+Log into the remote FTP server with the given login information. If
+no arguments are given then the C<Net::FTP> uses the C<Net::Netrc>
+package to lookup the login information for the connected host.
+If no information is found then a login of I<anonymous> is used.
+If no password is given and the login is I<anonymous> then I<anonymous@>
+will be used for password.
+
+If the connection is via a firewall then the C<authorize> method will
+be called with no arguments.
+
+=item starttls ()
+
+Upgrade existing plain connection to SSL.
+The SSL arguments have to be given in C<new> already because they are needed for
+data connections too.
+
+=item stoptls ()
+
+Downgrade existing SSL connection back to plain.
+This is needed to work with some FTP helpers at firewalls, which need to see the
+PORT and PASV commands and responses to dynamically open the necessary ports.
+In this case C<starttls> is usually only done to protect the authorization.
+
+=item prot ( LEVEL )
+
+Set what type of data channel protection the client and server will be using.
+Only C<LEVEL>s "C" (clear) and "P" (private) are supported.
+
+=item host ()
+
+Returns the value used by the constructor, and passed to IO::Socket::INET,
+to connect to the host.
+
+=item account( ACCT )
+
+Set a string identifying the user's account.
+
+=item authorize ( [AUTH [, RESP]])
+
+This is a protocol used by some firewall ftp proxies. It is used
+to authorise the user to send data out. If both arguments are not specified
+then C<authorize> uses C<Net::Netrc> to do a lookup.
+
+=item site (ARGS)
+
+Send a SITE command to the remote server and wait for a response.
+
+Returns most significant digit of the response code.
+
+=item ascii ()
+
+Transfer file in ASCII. CRLF translation will be done if required
+
+=item binary ()
+
+Transfer file in binary mode. No transformation will be done.
+
+B<Hint>: If both server and client machines use the same line ending for
+text files, then it will be faster to transfer all files in binary mode.
+
+=item type ( [ TYPE ] )
+
+Set or get if files will be transferred in ASCII or binary mode.
+
+=item rename ( OLDNAME, NEWNAME )
+
+Rename a file on the remote FTP server from C<OLDNAME> to C<NEWNAME>. This
+is done by sending the RNFR and RNTO commands.
+
+=item delete ( FILENAME )
+
+Send a request to the server to delete C<FILENAME>.
+
+=item cwd ( [ DIR ] )
+
+Attempt to change directory to the directory given in C<$dir>. If
+C<$dir> is C<"..">, the FTP C<CDUP> command is used to attempt to
+move up one directory. If no directory is given then an attempt is made
+to change the directory to the root directory.
+
+=item cdup ()
+
+Change directory to the parent of the current directory.
+
+=item passive ( [ PASSIVE ] )
+
+Set or get if data connections will be initiated in passive mode.
+
+=item pwd ()
+
+Returns the full pathname of the current directory.
+
+=item restart ( WHERE )
+
+Set the byte offset at which to begin the next data transfer. Net::FTP simply
+records this value and uses it when during the next data transfer. For this
+reason this method will not return an error, but setting it may cause
+a subsequent data transfer to fail.
+
+=item rmdir ( DIR [, RECURSE ])
+
+Remove the directory with the name C<DIR>. If C<RECURSE> is I<true> then
+C<rmdir> will attempt to delete everything inside the directory.
+
+=item mkdir ( DIR [, RECURSE ])
+
+Create a new directory with the name C<DIR>. If C<RECURSE> is I<true> then
+C<mkdir> will attempt to create all the directories in the given path.
+
+Returns the full pathname to the new directory.
+
+=item alloc ( SIZE [, RECORD_SIZE] )
+
+The alloc command allows you to give the ftp server a hint about the size
+of the file about to be transferred using the ALLO ftp command. Some storage
+systems use this to make intelligent decisions about how to store the file.
+The C<SIZE> argument represents the size of the file in bytes. The
+C<RECORD_SIZE> argument indicates a maximum record or page size for files
+sent with a record or page structure.
+
+The size of the file will be determined, and sent to the server
+automatically for normal files so that this method need only be called if
+you are transferring data from a socket, named pipe, or other stream not
+associated with a normal file.
+
+=item ls ( [ DIR ] )
+
+Get a directory listing of C<DIR>, or the current directory.
+
+In an array context, returns a list of lines returned from the server. In
+a scalar context, returns a reference to a list.
+
+=item dir ( [ DIR ] )
+
+Get a directory listing of C<DIR>, or the current directory in long format.
+
+In an array context, returns a list of lines returned from the server. In
+a scalar context, returns a reference to a list.
+
+=item get ( REMOTE_FILE [, LOCAL_FILE [, WHERE]] )
+
+Get C<REMOTE_FILE> from the server and store locally. C<LOCAL_FILE> may be
+a filename or a filehandle. If not specified, the file will be stored in
+the current directory with the same leafname as the remote file.
+
+If C<WHERE> is given then the first C<WHERE> bytes of the file will
+not be transferred, and the remaining bytes will be appended to
+the local file if it already exists.
+
+Returns C<LOCAL_FILE>, or the generated local file name if C<LOCAL_FILE>
+is not given. If an error was encountered undef is returned.
+
+=item put ( LOCAL_FILE [, REMOTE_FILE ] )
+
+Put a file on the remote server. C<LOCAL_FILE> may be a name or a filehandle.
+If C<LOCAL_FILE> is a filehandle then C<REMOTE_FILE> must be specified. If
+C<REMOTE_FILE> is not specified then the file will be stored in the current
+directory with the same leafname as C<LOCAL_FILE>.
+
+Returns C<REMOTE_FILE>, or the generated remote filename if C<REMOTE_FILE>
+is not given.
+
+B<NOTE>: If for some reason the transfer does not complete and an error is
+returned then the contents that had been transferred will not be remove
+automatically.
+
+=item put_unique ( LOCAL_FILE [, REMOTE_FILE ] )
+
+Same as put but uses the C<STOU> command.
+
+Returns the name of the file on the server.
+
+=item append ( LOCAL_FILE [, REMOTE_FILE ] )
+
+Same as put but appends to the file on the remote server.
+
+Returns C<REMOTE_FILE>, or the generated remote filename if C<REMOTE_FILE>
+is not given.
+
+=item unique_name ()
+
+Returns the name of the last file stored on the server using the
+C<STOU> command.
+
+=item mdtm ( FILE )
+
+Returns the I<modification time> of the given file
+
+=item size ( FILE )
+
+Returns the size in bytes for the given file as stored on the remote server.
+
+B<NOTE>: The size reported is the size of the stored file on the remote server.
+If the file is subsequently transferred from the server in ASCII mode
+and the remote server and local machine have different ideas about
+"End Of Line" then the size of file on the local machine after transfer
+may be different.
+
+=item supported ( CMD )
+
+Returns TRUE if the remote server supports the given command.
+
+=item hash ( [FILEHANDLE_GLOB_REF],[ BYTES_PER_HASH_MARK] )
+
+Called without parameters, or with the first argument false, hash marks
+are suppressed. If the first argument is true but not a reference to a
+file handle glob, then \*STDERR is used. The second argument is the number
+of bytes per hash mark printed, and defaults to 1024. In all cases the
+return value is a reference to an array of two: the filehandle glob reference
+and the bytes per hash mark.
+
+=item feature ( NAME )
+
+Determine if the server supports the specified feature. The return
+value is a list of lines the server responded with to describe the
+options that it supports for the given feature. If the feature is
+unsupported then the empty list is returned.
+
+ if ($ftp->feature( 'MDTM' )) {
+ # Do something
+ }
+
+ if (grep { /\bTLS\b/ } $ftp->feature('AUTH')) {
+ # Server supports TLS
+ }
+
+=back
+
+The following methods can return different results depending on
+how they are called. If the user explicitly calls either
+of the C<pasv> or C<port> methods then these methods will
+return a I<true> or I<false> value. If the user does not
+call either of these methods then the result will be a
+reference to a C<Net::FTP::dataconn> based object.
+
+=over 4
+
+=item nlst ( [ DIR ] )
+
+Send an C<NLST> command to the server, with an optional parameter.
+
+=item list ( [ DIR ] )
+
+Same as C<nlst> but using the C<LIST> command
+
+=item retr ( FILE )
+
+Begin the retrieval of a file called C<FILE> from the remote server.
+
+=item stor ( FILE )
+
+Tell the server that you wish to store a file. C<FILE> is the
+name of the new file that should be created.
+
+=item stou ( FILE )
+
+Same as C<stor> but using the C<STOU> command. The name of the unique
+file which was created on the server will be available via the C<unique_name>
+method after the data connection has been closed.
+
+=item appe ( FILE )
+
+Tell the server that we want to append some data to the end of a file
+called C<FILE>. If this file does not exist then create it.
+
+=back
+
+If for some reason you want to have complete control over the data connection,
+this includes generating it and calling the C<response> method when required,
+then the user can use these methods to do so.
+
+However calling these methods only affects the use of the methods above that
+can return a data connection. They have no effect on methods C<get>, C<put>,
+C<put_unique> and those that do not require data connections.
+
+=over 4
+
+=item port ( [ PORT ] )
+=item eprt ( [ PORT ] )
+
+Send a C<PORT> (IPv4) or C<EPRT> (IPv6) command to the server. If C<PORT> is
+specified then it is sent to the server. If not, then a listen socket is created
+and the correct information sent to the server.
+
+=item pasv ()
+=item epsv ()
+
+Tell the server to go into passive mode (C<pasv> for IPv4, C<epsv> for IPv6).
+Returns the text that represents the port on which the server is listening, this
+text is in a suitable form to send to another ftp server using the C<port> or
+C<eprt> method.
+
+=back
+
+The following methods can be used to transfer files between two remote
+servers, providing that these two servers can connect directly to each other.
+
+=over 4
+
+=item pasv_xfer ( SRC_FILE, DEST_SERVER [, DEST_FILE ] )
+
+This method will do a file transfer between two remote ftp servers. If
+C<DEST_FILE> is omitted then the leaf name of C<SRC_FILE> will be used.
+
+=item pasv_xfer_unique ( SRC_FILE, DEST_SERVER [, DEST_FILE ] )
+
+Like C<pasv_xfer> but the file is stored on the remote server using
+the STOU command.
+
+=item pasv_wait ( NON_PASV_SERVER )
+
+This method can be used to wait for a transfer to complete between a passive
+server and a non-passive server. The method should be called on the passive
+server with the C<Net::FTP> object for the non-passive server passed as an
+argument.
+
+=item abort ()
+
+Abort the current data transfer.
+
+=item quit ()
+
+Send the QUIT command to the remote FTP server and close the socket connection.
+
+=back
+
+=head2 Methods for the adventurous
+
+=over 4
+
+=item quot (CMD [,ARGS])
+
+Send a command, that Net::FTP does not directly support, to the remote
+server and wait for a response.
+
+Returns most significant digit of the response code.
+
+B<WARNING> This call should only be used on commands that do not require
+data connections. Misuse of this method can hang the connection.
+
+=item can_inet6 ()
+
+Returns whether we can use IPv6.
+
+=item can_ssl ()
+
+Returns whether we can use SSL.
+
+=back
+
+=head1 THE dataconn CLASS
+
+Some of the methods defined in C<Net::FTP> return an object which will
+be derived from the C<Net::FTP::dataconn> class. See L<Net::FTP::dataconn> for
+more details.
+
+=head1 UNIMPLEMENTED
+
+The following RFC959 commands have not been implemented:
+
+=over 4
+
+=item B<SMNT>
+
+Mount a different file system structure without changing login or
+accounting information.
+
+=item B<HELP>
+
+Ask the server for "helpful information" (that's what the RFC says) on
+the commands it accepts.
+
+=item B<MODE>
+
+Specifies transfer mode (stream, block or compressed) for file to be
+transferred.
+
+=item B<SYST>
+
+Request remote server system identification.
+
+=item B<STAT>
+
+Request remote server status.
+
+=item B<STRU>
+
+Specifies file structure for file to be transferred.
+
+=item B<REIN>
+
+Reinitialize the connection, flushing all I/O and account information.
+
+=back
+
+=head1 REPORTING BUGS
+
+When reporting bugs/problems please include as much information as possible.
+It may be difficult for me to reproduce the problem as almost every setup
+is different.
+
+A small script which yields the problem will probably be of help. It would
+also be useful if this script was run with the extra options C<Debug => 1>
+passed to the constructor, and the output sent with the bug report. If you
+cannot include a small script then please include a Debug trace from a
+run of your program which does yield the problem.
+
+=head1 AUTHOR
+
+Graham Barr E<lt>F<gbarr@pobox.com>E<gt>
+
+Steve Hay E<lt>F<shay@cpan.org>E<gt> is now maintaining libnet as of version
+1.22_02
+
+=head1 SEE ALSO
+
+L<Net::Netrc>,
+L<Net::Cmd>,
+L<IO::Socket::SSL>
+
+ftp(1), ftpd(8), RFC 959, RFC 2428, RFC 4217
+http://www.ietf.org/rfc/rfc959.txt
+http://www.ietf.org/rfc/rfc2428.txt
+http://www.ietf.org/rfc/rfc4217.txt
+
+=head1 USE EXAMPLES
+
+For an example of the use of Net::FTP see
+
+=over 4
+
+=item http://www.csh.rit.edu/~adam/Progs/
+
+C<autoftp> is a program that can retrieve, send, or list files via
+the FTP protocol in a non-interactive manner.
+
+=back
+
+=head1 CREDITS
+
+Henry Gabryjelski <henryg@WPI.EDU> - for the suggestion of creating directories
+recursively.
+
+Nathan Torkington <gnat@frii.com> - for some input on the documentation.
+
+Roderick Schertler <roderick@gate.net> - for various inputs
+
+=head1 COPYRIGHT
+
+Versions up to 2.77_2 Copyright (c) 1995-2004 Graham Barr. All rights reserved.
+Changes in Version 2.77_3 onwards Copyright (C) 2013-2014 Steve Hay. All rights
+reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
@@ -0,0 +1,1264 @@
+# Net::NNTP.pm
+#
+# Versions up to 2.24_1 Copyright (c) 1995-1997 Graham Barr <gbarr@pobox.com>.
+# All rights reserved.
+# Changes in Version 2.25 onwards Copyright (C) 2013-2014 Steve Hay. All rights
+# reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Net::NNTP;
+
+use 5.008001;
+
+use strict;
+use warnings;
+
+use Carp;
+use IO::Socket;
+use Net::Cmd;
+use Net::Config;
+use Time::Local;
+
+our $VERSION = "3.02";
+
+# Code for detecting if we can use SSL
+my $ssl_class = eval {
+ require IO::Socket::SSL;
+ # first version with default CA on most platforms
+ IO::Socket::SSL->VERSION(1.999);
+} && 'IO::Socket::SSL';
+
+my $nossl_warn = !$ssl_class &&
+ 'To use SSL please install IO::Socket::SSL with version>=1.999';
+
+# Code for detecting if we can use IPv6
+my $inet6_class = eval {
+ require IO::Socket::IP;
+ IO::Socket::IP->VERSION(0.20);
+} && 'IO::Socket::IP' || eval {
+ require IO::Socket::INET6;
+ IO::Socket::INET6->VERSION(2.62);
+} && 'IO::Socket::INET6';
+
+sub can_ssl { $ssl_class };
+sub can_inet6 { $inet6_class };
+
+our @ISA = ('Net::Cmd', $ssl_class || $inet6_class || 'IO::Socket::INET');
+
+
+sub new {
+ my $self = shift;
+ my $type = ref($self) || $self;
+ my ($host, %arg);
+ if (@_ % 2) {
+ $host = shift;
+ %arg = @_;
+ }
+ else {
+ %arg = @_;
+ $host = delete $arg{Host};
+ }
+ my $obj;
+
+ $host ||= $ENV{NNTPSERVER} || $ENV{NEWSHOST};
+
+ my $hosts = defined $host ? [$host] : $NetConfig{nntp_hosts};
+
+ @{$hosts} = qw(news)
+ unless @{$hosts};
+
+ my %connect = ( Proto => 'tcp');
+
+ if ($ssl_class) {
+ $connect{SSL_verifycn_scheme} = 'nntp';
+ $connect{$_} = $arg{$_} for(grep { m{^SSL_} } keys %arg);
+ if ($arg{SSL}) {
+ # SSL from start
+ $arg{Port} ||= 563;
+ } else {
+ # upgrade later with STARTTLS
+ $connect{SSL_startHandshake} = 0;
+ }
+ } elsif ($arg{SSL}) {
+ die $nossl_warn;
+ }
+
+ foreach my $o (qw(LocalAddr Timeout)) {
+ $connect{$o} = $arg{$o} if exists $arg{$o};
+ }
+ $connect{Timeout} = 120 unless defined $connect{Timeout};
+ $connect{PeerPort} = $arg{Port} || 'nntp(119)';
+ foreach my $h (@{$hosts}) {
+ $connect{PeerAddr} = $h;
+ $connect{SSL_verifycn_name} = $arg{SSL_verifycn_name} || $h if $ssl_class;
+ $obj = $type->SUPER::new(%connect)
+ and last;
+ }
+
+ return
+ unless defined $obj;
+
+ ${*$obj}{'net_nntp_host'} = $connect{PeerAddr};
+
+ $obj->autoflush(1);
+ $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
+
+ unless ($obj->response() == CMD_OK) {
+ $obj->close;
+ return;
+ }
+
+ my $c = $obj->code;
+ my @m = $obj->message;
+
+ unless (exists $arg{Reader} && $arg{Reader} == 0) {
+
+ # if server is INN and we have transfer rights the we are currently
+ # talking to innd not nnrpd
+ if ($obj->reader) {
+
+ # If reader succeeds the we need to consider this code to determine postok
+ $c = $obj->code;
+ }
+ else {
+
+ # I want to ignore this failure, so restore the previous status.
+ $obj->set_status($c, \@m);
+ }
+ }
+
+ ${*$obj}{'net_nntp_post'} = $c == 200 ? 1 : 0;
+
+ $obj;
+}
+
+
+sub host {
+ my $me = shift;
+ ${*$me}{'net_nntp_host'};
+}
+
+
+sub debug_text {
+ my $nntp = shift;
+ my $inout = shift;
+ my $text = shift;
+
+ if ( (ref($nntp) and $nntp->code == 350 and $text =~ /^(\S+)/)
+ || ($text =~ /^(authinfo\s+pass)/io))
+ {
+ $text = "$1 ....\n";
+ }
+
+ $text;
+}
+
+
+sub postok {
+ @_ == 1 or croak 'usage: $nntp->postok()';
+ my $nntp = shift;
+ ${*$nntp}{'net_nntp_post'} || 0;
+}
+
+
+sub starttls {
+ my $self = shift;
+ $ssl_class or die $nossl_warn;
+ $self->is_SSL and croak("NNTP connection is already in SSL mode");
+ $self->_STARTTLS or return;
+ $self->connect_SSL;
+}
+
+
+sub article {
+ @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->article( [ MSGID ], [ FH ] )';
+ my $nntp = shift;
+ my @fh;
+
+ @fh = (pop) if @_ == 2 || (@_ && (ref($_[0]) || ref(\$_[0]) eq 'GLOB'));
+
+ $nntp->_ARTICLE(@_)
+ ? $nntp->read_until_dot(@fh)
+ : undef;
+}
+
+
+sub articlefh {
+ @_ >= 1 && @_ <= 2 or croak 'usage: $nntp->articlefh( [ MSGID ] )';
+ my $nntp = shift;
+
+ return unless $nntp->_ARTICLE(@_);
+ return $nntp->tied_fh;
+}
+
+
+sub authinfo {
+ @_ == 3 or croak 'usage: $nntp->authinfo( USER, PASS )';
+ my ($nntp, $user, $pass) = @_;
+
+ $nntp->_AUTHINFO("USER", $user) == CMD_MORE
+ && $nntp->_AUTHINFO("PASS", $pass) == CMD_OK;
+}
+
+
+sub authinfo_simple {
+ @_ == 3 or croak 'usage: $nntp->authinfo( USER, PASS )';
+ my ($nntp, $user, $pass) = @_;
+
+ $nntp->_AUTHINFO('SIMPLE') == CMD_MORE
+ && $nntp->command($user, $pass)->response == CMD_OK;
+}
+
+
+sub body {
+ @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->body( [ MSGID ], [ FH ] )';
+ my $nntp = shift;
+ my @fh;
+
+ @fh = (pop) if @_ == 2 || (@_ && ref($_[0]) || ref(\$_[0]) eq 'GLOB');
+
+ $nntp->_BODY(@_)
+ ? $nntp->read_until_dot(@fh)
+ : undef;
+}
+
+
+sub bodyfh {
+ @_ >= 1 && @_ <= 2 or croak 'usage: $nntp->bodyfh( [ MSGID ] )';
+ my $nntp = shift;
+ return unless $nntp->_BODY(@_);
+ return $nntp->tied_fh;
+}
+
+
+sub head {
+ @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->head( [ MSGID ], [ FH ] )';
+ my $nntp = shift;
+ my @fh;
+
+ @fh = (pop) if @_ == 2 || (@_ && ref($_[0]) || ref(\$_[0]) eq 'GLOB');
+
+ $nntp->_HEAD(@_)
+ ? $nntp->read_until_dot(@fh)
+ : undef;
+}
+
+
+sub headfh {
+ @_ >= 1 && @_ <= 2 or croak 'usage: $nntp->headfh( [ MSGID ] )';
+ my $nntp = shift;
+ return unless $nntp->_HEAD(@_);
+ return $nntp->tied_fh;
+}
+
+
+sub nntpstat {
+ @_ == 1 || @_ == 2 or croak 'usage: $nntp->nntpstat( [ MSGID ] )';
+ my $nntp = shift;
+
+ $nntp->_STAT(@_) && $nntp->message =~ /(<[^>]+>)/o
+ ? $1
+ : undef;
+}
+
+
+sub group {
+ @_ == 1 || @_ == 2 or croak 'usage: $nntp->group( [ GROUP ] )';
+ my $nntp = shift;
+ my $grp = ${*$nntp}{'net_nntp_group'};
+
+ return $grp
+ unless (@_ || wantarray);
+
+ my $newgrp = shift;
+
+ $newgrp = (defined($grp) and length($grp)) ? $grp : ""
+ unless defined($newgrp) and length($newgrp);
+
+ return
+ unless $nntp->_GROUP($newgrp) and $nntp->message =~ /(\d+)\s+(\d+)\s+(\d+)\s+(\S+)/;
+
+ my ($count, $first, $last, $group) = ($1, $2, $3, $4);
+
+ # group may be replied as '(current group)'
+ $group = ${*$nntp}{'net_nntp_group'}
+ if $group =~ /\(/;
+
+ ${*$nntp}{'net_nntp_group'} = $group;
+
+ wantarray
+ ? ($count, $first, $last, $group)
+ : $group;
+}
+
+
+sub help {
+ @_ == 1 or croak 'usage: $nntp->help()';
+ my $nntp = shift;
+
+ $nntp->_HELP
+ ? $nntp->read_until_dot
+ : undef;
+}
+
+
+sub ihave {
+ @_ >= 2 or croak 'usage: $nntp->ihave( MESSAGE-ID [, MESSAGE ])';
+ my $nntp = shift;
+ my $mid = shift;
+
+ $nntp->_IHAVE($mid) && $nntp->datasend(@_)
+ ? @_ == 0 || $nntp->dataend
+ : undef;
+}
+
+
+sub last {
+ @_ == 1 or croak 'usage: $nntp->last()';
+ my $nntp = shift;
+
+ $nntp->_LAST && $nntp->message =~ /(<[^>]+>)/o
+ ? $1
+ : undef;
+}
+
+
+sub list {
+ @_ == 1 or croak 'usage: $nntp->list()';
+ my $nntp = shift;
+
+ $nntp->_LIST
+ ? $nntp->_grouplist
+ : undef;
+}
+
+
+sub newgroups {
+ @_ >= 2 or croak 'usage: $nntp->newgroups( SINCE [, DISTRIBUTIONS ])';
+ my $nntp = shift;
+ my $time = _timestr(shift);
+ my $dist = shift || "";
+
+ $dist = join(",", @{$dist})
+ if ref($dist);
+
+ $nntp->_NEWGROUPS($time, $dist)
+ ? $nntp->_grouplist
+ : undef;
+}
+
+
+sub newnews {
+ @_ >= 2 && @_ <= 4
+ or croak 'usage: $nntp->newnews( SINCE [, GROUPS [, DISTRIBUTIONS ]])';
+ my $nntp = shift;
+ my $time = _timestr(shift);
+ my $grp = @_ ? shift: $nntp->group;
+ my $dist = shift || "";
+
+ $grp ||= "*";
+ $grp = join(",", @{$grp})
+ if ref($grp);
+
+ $dist = join(",", @{$dist})
+ if ref($dist);
+
+ $nntp->_NEWNEWS($grp, $time, $dist)
+ ? $nntp->_articlelist
+ : undef;
+}
+
+
+sub next {
+ @_ == 1 or croak 'usage: $nntp->next()';
+ my $nntp = shift;
+
+ $nntp->_NEXT && $nntp->message =~ /(<[^>]+>)/o
+ ? $1
+ : undef;
+}
+
+
+sub post {
+ @_ >= 1 or croak 'usage: $nntp->post( [ MESSAGE ] )';
+ my $nntp = shift;
+
+ $nntp->_POST() && $nntp->datasend(@_)
+ ? @_ == 0 || $nntp->dataend
+ : undef;
+}
+
+
+sub postfh {
+ my $nntp = shift;
+ return unless $nntp->_POST();
+ return $nntp->tied_fh;
+}
+
+
+sub quit {
+ @_ == 1 or croak 'usage: $nntp->quit()';
+ my $nntp = shift;
+
+ $nntp->_QUIT;
+ $nntp->close;
+}
+
+
+sub slave {
+ @_ == 1 or croak 'usage: $nntp->slave()';
+ my $nntp = shift;
+
+ $nntp->_SLAVE;
+}
+
+##
+## The following methods are not implemented by all servers
+##
+
+
+sub active {
+ @_ == 1 || @_ == 2 or croak 'usage: $nntp->active( [ PATTERN ] )';
+ my $nntp = shift;
+
+ $nntp->_LIST('ACTIVE', @_)
+ ? $nntp->_grouplist
+ : undef;
+}
+
+
+sub active_times {
+ @_ == 1 or croak 'usage: $nntp->active_times()';
+ my $nntp = shift;
+
+ $nntp->_LIST('ACTIVE.TIMES')
+ ? $nntp->_grouplist
+ : undef;
+}
+
+
+sub distributions {
+ @_ == 1 or croak 'usage: $nntp->distributions()';
+ my $nntp = shift;
+
+ $nntp->_LIST('DISTRIBUTIONS')
+ ? $nntp->_description
+ : undef;
+}
+
+
+sub distribution_patterns {
+ @_ == 1 or croak 'usage: $nntp->distributions()';
+ my $nntp = shift;
+
+ my $arr;
+ local $_;
+
+ ## no critic (ControlStructures::ProhibitMutatingListFunctions)
+ $nntp->_LIST('DISTRIB.PATS')
+ && ($arr = $nntp->read_until_dot)
+ ? [grep { /^\d/ && (chomp, $_ = [split /:/]) } @$arr]
+ : undef;
+}
+
+
+sub newsgroups {
+ @_ == 1 || @_ == 2 or croak 'usage: $nntp->newsgroups( [ PATTERN ] )';
+ my $nntp = shift;
+
+ $nntp->_LIST('NEWSGROUPS', @_)
+ ? $nntp->_description
+ : undef;
+}
+
+
+sub overview_fmt {
+ @_ == 1 or croak 'usage: $nntp->overview_fmt()';
+ my $nntp = shift;
+
+ $nntp->_LIST('OVERVIEW.FMT')
+ ? $nntp->_articlelist
+ : undef;
+}
+
+
+sub subscriptions {
+ @_ == 1 or croak 'usage: $nntp->subscriptions()';
+ my $nntp = shift;
+
+ $nntp->_LIST('SUBSCRIPTIONS')
+ ? $nntp->_articlelist
+ : undef;
+}
+
+
+sub listgroup {
+ @_ == 1 || @_ == 2 or croak 'usage: $nntp->listgroup( [ GROUP ] )';
+ my $nntp = shift;
+
+ $nntp->_LISTGROUP(@_)
+ ? $nntp->_articlelist
+ : undef;
+}
+
+
+sub reader {
+ @_ == 1 or croak 'usage: $nntp->reader()';
+ my $nntp = shift;
+
+ $nntp->_MODE('READER');
+}
+
+
+sub xgtitle {
+ @_ == 1 || @_ == 2 or croak 'usage: $nntp->xgtitle( [ PATTERN ] )';
+ my $nntp = shift;
+
+ $nntp->_XGTITLE(@_)
+ ? $nntp->_description
+ : undef;
+}
+
+
+sub xhdr {
+ @_ >= 2 && @_ <= 4 or croak 'usage: $nntp->xhdr( HEADER, [ MESSAGE-SPEC ] )';
+ my $nntp = shift;
+ my $hdr = shift;
+ my $arg = _msg_arg(@_);
+
+ $nntp->_XHDR($hdr, $arg)
+ ? $nntp->_description
+ : undef;
+}
+
+
+sub xover {
+ @_ == 2 || @_ == 3 or croak 'usage: $nntp->xover( MESSAGE-SPEC )';
+ my $nntp = shift;
+ my $arg = _msg_arg(@_);
+
+ $nntp->_XOVER($arg)
+ ? $nntp->_fieldlist
+ : undef;
+}
+
+
+sub xpat {
+ @_ == 4 || @_ == 5 or croak '$nntp->xpat( HEADER, PATTERN, MESSAGE-SPEC )';
+ my $nntp = shift;
+ my $hdr = shift;
+ my $pat = shift;
+ my $arg = _msg_arg(@_);
+
+ $pat = join(" ", @$pat)
+ if ref($pat);
+
+ $nntp->_XPAT($hdr, $arg, $pat)
+ ? $nntp->_description
+ : undef;
+}
+
+
+sub xpath {
+ @_ == 2 or croak 'usage: $nntp->xpath( MESSAGE-ID )';
+ my ($nntp, $mid) = @_;
+
+ return
+ unless $nntp->_XPATH($mid);
+
+ my $m;
+ ($m = $nntp->message) =~ s/^\d+\s+//o;
+ my @p = split /\s+/, $m;
+
+ wantarray ? @p : $p[0];
+}
+
+
+sub xrover {
+ @_ == 2 || @_ == 3 or croak 'usage: $nntp->xrover( MESSAGE-SPEC )';
+ my $nntp = shift;
+ my $arg = _msg_arg(@_);
+
+ $nntp->_XROVER($arg)
+ ? $nntp->_description
+ : undef;
+}
+
+
+sub date {
+ @_ == 1 or croak 'usage: $nntp->date()';
+ my $nntp = shift;
+
+ $nntp->_DATE
+ && $nntp->message =~ /(\d{4})(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/
+ ? timegm($6, $5, $4, $3, $2 - 1, $1 - 1900)
+ : undef;
+}
+
+
+##
+## Private subroutines
+##
+
+
+sub _msg_arg {
+ my $spec = shift;
+ my $arg = "";
+
+ if (@_) {
+ carp "Depriciated passing of two message numbers, " . "pass a reference"
+ if $^W;
+ $spec = [$spec, $_[0]];
+ }
+
+ if (defined $spec) {
+ if (ref($spec)) {
+ $arg = $spec->[0];
+ if (defined $spec->[1]) {
+ $arg .= "-"
+ if $spec->[1] != $spec->[0];
+ $arg .= $spec->[1]
+ if $spec->[1] > $spec->[0];
+ }
+ }
+ else {
+ $arg = $spec;
+ }
+ }
+
+ $arg;
+}
+
+
+sub _timestr {
+ my $time = shift;
+ my @g = reverse((gmtime($time))[0 .. 5]);
+ $g[1] += 1;
+ $g[0] %= 100;
+ sprintf "%02d%02d%02d %02d%02d%02d GMT", @g;
+}
+
+
+sub _grouplist {
+ my $nntp = shift;
+ my $arr = $nntp->read_until_dot
+ or return;
+
+ my $hash = {};
+
+ foreach my $ln (@$arr) {
+ my @a = split(/[\s\n]+/, $ln);
+ $hash->{$a[0]} = [@a[1, 2, 3]];
+ }
+
+ $hash;
+}
+
+
+sub _fieldlist {
+ my $nntp = shift;
+ my $arr = $nntp->read_until_dot
+ or return;
+
+ my $hash = {};
+
+ foreach my $ln (@$arr) {
+ my @a = split(/[\t\n]/, $ln);
+ my $m = shift @a;
+ $hash->{$m} = [@a];
+ }
+
+ $hash;
+}
+
+
+sub _articlelist {
+ my $nntp = shift;
+ my $arr = $nntp->read_until_dot;
+
+ chomp(@$arr)
+ if $arr;
+
+ $arr;
+}
+
+
+sub _description {
+ my $nntp = shift;
+ my $arr = $nntp->read_until_dot
+ or return;
+
+ my $hash = {};
+
+ foreach my $ln (@$arr) {
+ chomp($ln);
+
+ $hash->{$1} = $ln
+ if $ln =~ s/^\s*(\S+)\s*//o;
+ }
+
+ $hash;
+
+}
+
+##
+## The commands
+##
+
+
+sub _ARTICLE { shift->command('ARTICLE', @_)->response == CMD_OK }
+sub _AUTHINFO { shift->command('AUTHINFO', @_)->response }
+sub _BODY { shift->command('BODY', @_)->response == CMD_OK }
+sub _DATE { shift->command('DATE')->response == CMD_INFO }
+sub _GROUP { shift->command('GROUP', @_)->response == CMD_OK }
+sub _HEAD { shift->command('HEAD', @_)->response == CMD_OK }
+sub _HELP { shift->command('HELP', @_)->response == CMD_INFO }
+sub _IHAVE { shift->command('IHAVE', @_)->response == CMD_MORE }
+sub _LAST { shift->command('LAST')->response == CMD_OK }
+sub _LIST { shift->command('LIST', @_)->response == CMD_OK }
+sub _LISTGROUP { shift->command('LISTGROUP', @_)->response == CMD_OK }
+sub _NEWGROUPS { shift->command('NEWGROUPS', @_)->response == CMD_OK }
+sub _NEWNEWS { shift->command('NEWNEWS', @_)->response == CMD_OK }
+sub _NEXT { shift->command('NEXT')->response == CMD_OK }
+sub _POST { shift->command('POST', @_)->response == CMD_MORE }
+sub _QUIT { shift->command('QUIT', @_)->response == CMD_OK }
+sub _SLAVE { shift->command('SLAVE', @_)->response == CMD_OK }
+sub _STARTTLS { shift->command("STARTTLS")->response() == CMD_MORE }
+sub _STAT { shift->command('STAT', @_)->response == CMD_OK }
+sub _MODE { shift->command('MODE', @_)->response == CMD_OK }
+sub _XGTITLE { shift->command('XGTITLE', @_)->response == CMD_OK }
+sub _XHDR { shift->command('XHDR', @_)->response == CMD_OK }
+sub _XPAT { shift->command('XPAT', @_)->response == CMD_OK }
+sub _XPATH { shift->command('XPATH', @_)->response == CMD_OK }
+sub _XOVER { shift->command('XOVER', @_)->response == CMD_OK }
+sub _XROVER { shift->command('XROVER', @_)->response == CMD_OK }
+sub _XTHREAD { shift->unsupported }
+sub _XSEARCH { shift->unsupported }
+sub _XINDEX { shift->unsupported }
+
+##
+## IO/perl methods
+##
+
+
+sub DESTROY {
+ my $nntp = shift;
+ defined(fileno($nntp)) && $nntp->quit;
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+Net::NNTP - NNTP Client class
+
+=head1 SYNOPSIS
+
+ use Net::NNTP;
+
+ $nntp = Net::NNTP->new("some.host.name");
+ $nntp->quit;
+
+ # start with SSL, e.g. nntps
+ $nntp = Net::NNTP->new("some.host.name", SSL => 1);
+
+ # start with plain and upgrade to SSL
+ $nntp = Net::NNTP->new("some.host.name");
+ $nntp->starttls;
+
+
+=head1 DESCRIPTION
+
+C<Net::NNTP> is a class implementing a simple NNTP client in Perl as described
+in RFC977 and RFC4642.
+
+The Net::NNTP class is a subclass of Net::Cmd and IO::Socket::INET.
+
+=head1 CONSTRUCTOR
+
+=over 4
+
+=item new ( [ HOST ] [, OPTIONS ])
+
+This is the constructor for a new Net::NNTP object. C<HOST> is the
+name of the remote host to which a NNTP connection is required. If not
+given then it may be passed as the C<Host> option described below. If no host is passed
+then two environment variables are checked, first C<NNTPSERVER> then
+C<NEWSHOST>, then C<Net::Config> is checked, and if a host is not found
+then C<news> is used.
+
+C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
+Possible options are:
+
+B<Host> - NNTP host to connect to. It may be a single scalar, as defined for
+the C<PeerAddr> option in L<IO::Socket::INET>, or a reference to
+an array with hosts to try in turn. The L</host> method will return the value
+which was used to connect to the host.
+
+B<Port> - port to connect to.
+Default - 119 for plain NNTP and 563 for immediate SSL (nntps).
+
+B<SSL> - If the connection should be done from start with SSL, contrary to later
+upgrade with C<starttls>.
+You can use SSL arguments as documented in L<IO::Socket::SSL>, but it will
+usually use the right arguments already.
+
+B<Timeout> - Maximum time, in seconds, to wait for a response from the
+NNTP server, a value of zero will cause all IO operations to block.
+(default: 120)
+
+B<Debug> - Enable the printing of debugging information to STDERR
+
+B<Reader> - If the remote server is INN then initially the connection
+will be to nnrpd, by default C<Net::NNTP> will issue a C<MODE READER> command
+so that the remote server becomes innd. If the C<Reader> option is given
+with a value of zero, then this command will not be sent and the
+connection will be left talking to nnrpd.
+
+B<LocalAddr> - If multiple IP addresses are present on the client host
+with a valid route to the destination, you can specify the address your
+C<Net::NNTP> connects from and this way override the operating system's
+pick.
+
+=back
+
+=head1 METHODS
+
+Unless otherwise stated all methods return either a I<true> or I<false>
+value, with I<true> meaning that the operation was a success. When a method
+states that it returns a value, failure will be returned as I<undef> or an
+empty list.
+
+C<Net::NNTP> inherits from C<Net::Cmd> so methods defined in C<Net::Cmd> may
+be used to send commands to the remote NNTP server in addition to the methods
+documented here.
+
+=over 4
+
+=item host ()
+
+Returns the value used by the constructor, and passed to IO::Socket::INET,
+to connect to the host.
+
+=item starttls ()
+
+Upgrade existing plain connection to SSL.
+Any arguments necessary for SSL must be given in C<new> already.
+
+=item article ( [ MSGID|MSGNUM ], [FH] )
+
+Retrieve the header, a blank line, then the body (text) of the
+specified article.
+
+If C<FH> is specified then it is expected to be a valid filehandle
+and the result will be printed to it, on success a true value will be
+returned. If C<FH> is not specified then the return value, on success,
+will be a reference to an array containing the article requested, each
+entry in the array will contain one line of the article.
+
+If no arguments are passed then the current article in the currently
+selected newsgroup is fetched.
+
+C<MSGNUM> is a numeric id of an article in the current newsgroup, and
+will change the current article pointer. C<MSGID> is the message id of
+an article as shown in that article's header. It is anticipated that the
+client will obtain the C<MSGID> from a list provided by the C<newnews>
+command, from references contained within another article, or from the
+message-id provided in the response to some other commands.
+
+If there is an error then C<undef> will be returned.
+
+=item body ( [ MSGID|MSGNUM ], [FH] )
+
+Like C<article> but only fetches the body of the article.
+
+=item head ( [ MSGID|MSGNUM ], [FH] )
+
+Like C<article> but only fetches the headers for the article.
+
+=item articlefh ( [ MSGID|MSGNUM ] )
+
+=item bodyfh ( [ MSGID|MSGNUM ] )
+
+=item headfh ( [ MSGID|MSGNUM ] )
+
+These are similar to article(), body() and head(), but rather than
+returning the requested data directly, they return a tied filehandle
+from which to read the article.
+
+=item nntpstat ( [ MSGID|MSGNUM ] )
+
+The C<nntpstat> command is similar to the C<article> command except that no
+text is returned. When selecting by message number within a group,
+the C<nntpstat> command serves to set the "current article pointer" without
+sending text.
+
+Using the C<nntpstat> command to
+select by message-id is valid but of questionable value, since a
+selection by message-id does B<not> alter the "current article pointer".
+
+Returns the message-id of the "current article".
+
+=item group ( [ GROUP ] )
+
+Set and/or get the current group. If C<GROUP> is not given then information
+is returned on the current group.
+
+In a scalar context it returns the group name.
+
+In an array context the return value is a list containing, the number
+of articles in the group, the number of the first article, the number
+of the last article and the group name.
+
+=item help ( )
+
+Request help text (a short summary of commands that are understood by this
+implementation) from the server. Returns the text or undef upon failure.
+
+=item ihave ( MSGID [, MESSAGE ])
+
+The C<ihave> command informs the server that the client has an article
+whose id is C<MSGID>. If the server desires a copy of that
+article, and C<MESSAGE> has been given the it will be sent.
+
+Returns I<true> if the server desires the article and C<MESSAGE> was
+successfully sent,if specified.
+
+If C<MESSAGE> is not specified then the message must be sent using the
+C<datasend> and C<dataend> methods from L<Net::Cmd>
+
+C<MESSAGE> can be either an array of lines or a reference to an array.
+
+=item last ()
+
+Set the "current article pointer" to the previous article in the current
+newsgroup.
+
+Returns the message-id of the article.
+
+=item date ()
+
+Returns the date on the remote server. This date will be in a UNIX time
+format (seconds since 1970)
+
+=item postok ()
+
+C<postok> will return I<true> if the servers initial response indicated
+that it will allow posting.
+
+=item authinfo ( USER, PASS )
+
+Authenticates to the server (using the original AUTHINFO USER / AUTHINFO PASS
+form, defined in RFC2980) using the supplied username and password. Please
+note that the password is sent in clear text to the server. This command
+should not be used with valuable passwords unless the connection to the server
+is somehow protected.
+
+=item authinfo_simple ( USER, PASS )
+
+Authenticates to the server (using the proposed NNTP V2 AUTHINFO SIMPLE form,
+defined and deprecated in RFC2980) using the supplied username and password.
+As with L</authinfo> the password is sent in clear text.
+
+=item list ()
+
+Obtain information about all the active newsgroups. The results is a reference
+to a hash where the key is a group name and each value is a reference to an
+array. The elements in this array are:- the last article number in the group,
+the first article number in the group and any information flags about the group.
+
+=item newgroups ( SINCE [, DISTRIBUTIONS ])
+
+C<SINCE> is a time value and C<DISTRIBUTIONS> is either a distribution
+pattern or a reference to a list of distribution patterns.
+The result is the same as C<list>, but the
+groups return will be limited to those created after C<SINCE> and, if
+specified, in one of the distribution areas in C<DISTRIBUTIONS>.
+
+=item newnews ( SINCE [, GROUPS [, DISTRIBUTIONS ]])
+
+C<SINCE> is a time value. C<GROUPS> is either a group pattern or a reference
+to a list of group patterns. C<DISTRIBUTIONS> is either a distribution
+pattern or a reference to a list of distribution patterns.
+
+Returns a reference to a list which contains the message-ids of all news posted
+after C<SINCE>, that are in a groups which matched C<GROUPS> and a
+distribution which matches C<DISTRIBUTIONS>.
+
+=item next ()
+
+Set the "current article pointer" to the next article in the current
+newsgroup.
+
+Returns the message-id of the article.
+
+=item post ( [ MESSAGE ] )
+
+Post a new article to the news server. If C<MESSAGE> is specified and posting
+is allowed then the message will be sent.
+
+If C<MESSAGE> is not specified then the message must be sent using the
+C<datasend> and C<dataend> methods from L<Net::Cmd>
+
+C<MESSAGE> can be either an array of lines or a reference to an array.
+
+The message, either sent via C<datasend> or as the C<MESSAGE>
+parameter, must be in the format as described by RFC822 and must
+contain From:, Newsgroups: and Subject: headers.
+
+=item postfh ()
+
+Post a new article to the news server using a tied filehandle. If
+posting is allowed, this method will return a tied filehandle that you
+can print() the contents of the article to be posted. You must
+explicitly close() the filehandle when you are finished posting the
+article, and the return value from the close() call will indicate
+whether the message was successfully posted.
+
+=item slave ()
+
+Tell the remote server that I am not a user client, but probably another
+news server.
+
+=item quit ()
+
+Quit the remote server and close the socket connection.
+
+=item can_inet6 ()
+
+Returns whether we can use IPv6.
+
+=item can_ssl ()
+
+Returns whether we can use SSL.
+
+=back
+
+=head2 Extension methods
+
+These methods use commands that are not part of the RFC977 documentation. Some
+servers may not support all of them.
+
+=over 4
+
+=item newsgroups ( [ PATTERN ] )
+
+Returns a reference to a hash where the keys are all the group names which
+match C<PATTERN>, or all of the groups if no pattern is specified, and
+each value contains the description text for the group.
+
+=item distributions ()
+
+Returns a reference to a hash where the keys are all the possible
+distribution names and the values are the distribution descriptions.
+
+=item distribution_patterns ()
+
+Returns a reference to an array where each element, itself an array
+reference, consists of the three fields of a line of the distrib.pats list
+maintained by some NNTP servers, namely: a weight, a wildmat and a value
+which the client may use to construct a Distribution header.
+
+=item subscriptions ()
+
+Returns a reference to a list which contains a list of groups which
+are recommended for a new user to subscribe to.
+
+=item overview_fmt ()
+
+Returns a reference to an array which contain the names of the fields returned
+by C<xover>.
+
+=item active_times ()
+
+Returns a reference to a hash where the keys are the group names and each
+value is a reference to an array containing the time the groups was created
+and an identifier, possibly an Email address, of the creator.
+
+=item active ( [ PATTERN ] )
+
+Similar to C<list> but only active groups that match the pattern are returned.
+C<PATTERN> can be a group pattern.
+
+=item xgtitle ( PATTERN )
+
+Returns a reference to a hash where the keys are all the group names which
+match C<PATTERN> and each value is the description text for the group.
+
+=item xhdr ( HEADER, MESSAGE-SPEC )
+
+Obtain the header field C<HEADER> for all the messages specified.
+
+The return value will be a reference
+to a hash where the keys are the message numbers and each value contains
+the text of the requested header for that message.
+
+=item xover ( MESSAGE-SPEC )
+
+The return value will be a reference
+to a hash where the keys are the message numbers and each value contains
+a reference to an array which contains the overview fields for that
+message.
+
+The names of the fields can be obtained by calling C<overview_fmt>.
+
+=item xpath ( MESSAGE-ID )
+
+Returns the path name to the file on the server which contains the specified
+message.
+
+=item xpat ( HEADER, PATTERN, MESSAGE-SPEC)
+
+The result is the same as C<xhdr> except the is will be restricted to
+headers where the text of the header matches C<PATTERN>
+
+=item xrover ()
+
+The XROVER command returns reference information for the article(s)
+specified.
+
+Returns a reference to a HASH where the keys are the message numbers and the
+values are the References: lines from the articles
+
+=item listgroup ( [ GROUP ] )
+
+Returns a reference to a list of all the active messages in C<GROUP>, or
+the current group if C<GROUP> is not specified.
+
+=item reader ()
+
+Tell the server that you are a reader and not another server.
+
+This is required by some servers. For example if you are connecting to
+an INN server and you have transfer permission your connection will
+be connected to the transfer daemon, not the NNTP daemon. Issuing
+this command will cause the transfer daemon to hand over control
+to the NNTP daemon.
+
+Some servers do not understand this command, but issuing it and ignoring
+the response is harmless.
+
+=back
+
+=head1 UNSUPPORTED
+
+The following NNTP command are unsupported by the package, and there are
+no plans to do so.
+
+ AUTHINFO GENERIC
+ XTHREAD
+ XSEARCH
+ XINDEX
+
+=head1 DEFINITIONS
+
+=over 4
+
+=item MESSAGE-SPEC
+
+C<MESSAGE-SPEC> is either a single message-id, a single message number, or
+a reference to a list of two message numbers.
+
+If C<MESSAGE-SPEC> is a reference to a list of two message numbers and the
+second number in a range is less than or equal to the first then the range
+represents all messages in the group after the first message number.
+
+B<NOTE> For compatibility reasons only with earlier versions of Net::NNTP
+a message spec can be passed as a list of two numbers, this is deprecated
+and a reference to the list should now be passed
+
+=item PATTERN
+
+The C<NNTP> protocol uses the C<WILDMAT> format for patterns.
+The WILDMAT format was first developed by Rich Salz based on
+the format used in the UNIX "find" command to articulate
+file names. It was developed to provide a uniform mechanism
+for matching patterns in the same manner that the UNIX shell
+matches filenames.
+
+Patterns are implicitly anchored at the
+beginning and end of each string when testing for a match.
+
+There are five pattern matching operations other than a strict
+one-to-one match between the pattern and the source to be
+checked for a match.
+
+The first is an asterisk C<*> to match any sequence of zero or more
+characters.
+
+The second is a question mark C<?> to match any single character. The
+third specifies a specific set of characters.
+
+The set is specified as a list of characters, or as a range of characters
+where the beginning and end of the range are separated by a minus (or dash)
+character, or as any combination of lists and ranges. The dash can
+also be included in the set as a character it if is the beginning
+or end of the set. This set is enclosed in square brackets. The
+close square bracket C<]> may be used in a set if it is the first
+character in the set.
+
+The fourth operation is the same as the
+logical not of the third operation and is specified the same
+way as the third with the addition of a caret character C<^> at
+the beginning of the test string just inside the open square
+bracket.
+
+The final operation uses the backslash character to
+invalidate the special meaning of an open square bracket C<[>,
+the asterisk, backslash or the question mark. Two backslashes in
+sequence will result in the evaluation of the backslash as a
+character with no special meaning.
+
+=over 4
+
+=item Examples
+
+=item C<[^]-]>
+
+matches any single character other than a close square
+bracket or a minus sign/dash.
+
+=item C<*bdc>
+
+matches any string that ends with the string "bdc"
+including the string "bdc" (without quotes).
+
+=item C<[0-9a-zA-Z]>
+
+matches any single printable alphanumeric ASCII character.
+
+=item C<a??d>
+
+matches any four character string which begins
+with a and ends with d.
+
+=back
+
+=back
+
+=head1 SEE ALSO
+
+L<Net::Cmd>,
+L<IO::Socket::SSL>
+
+=head1 AUTHOR
+
+Graham Barr E<lt>F<gbarr@pobox.com>E<gt>
+
+Steve Hay E<lt>F<shay@cpan.org>E<gt> is now maintaining libnet as of version
+1.22_02
+
+=head1 COPYRIGHT
+
+Versions up to 2.24_1 Copyright (c) 1995-1997 Graham Barr. All rights reserved.
+Changes in Version 2.25 onwards Copyright (C) 2013-2014 Steve Hay. All rights
+reserved.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
@@ -0,0 +1,345 @@
+# Net::Netrc.pm
+#
+# Versions up to 2.13 Copyright (c) 1995-1998 Graham Barr <gbarr@pobox.com>.
+# All rights reserved.
+# Changes in Version 2.13_01 onwards Copyright (C) 2013-2014 Steve Hay. All
+# rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Net::Netrc;
+
+use 5.008001;
+
+use strict;
+use warnings;
+
+use Carp;
+use FileHandle;
+
+our $VERSION = "3.02";
+
+our $TESTING;
+
+my %netrc = ();
+
+sub _readrc {
+ my($class, $host) = @_;
+ my ($home, $file);
+
+ if ($^O eq "MacOS") {
+ $home = $ENV{HOME} || `pwd`;
+ chomp($home);
+ $file = ($home =~ /:$/ ? $home . "netrc" : $home . ":netrc");
+ }
+ else {
+
+ # Some OS's don't have "getpwuid", so we default to $ENV{HOME}
+ $home = eval { (getpwuid($>))[7] } || $ENV{HOME};
+ $home ||= $ENV{HOMEDRIVE} . ($ENV{HOMEPATH} || '') if defined $ENV{HOMEDRIVE};
+ if (-e $home . "/.netrc") {
+ $file = $home . "/.netrc";
+ }
+ elsif (-e $home . "/_netrc") {
+ $file = $home . "/_netrc";
+ }
+ else {
+ return unless $TESTING;
+ }
+ }
+
+ my ($login, $pass, $acct) = (undef, undef, undef);
+ my $fh;
+ local $_;
+
+ $netrc{default} = undef;
+
+ # OS/2 and Win32 do not handle stat in a way compatible with this check :-(
+ unless ($^O eq 'os2'
+ || $^O eq 'MSWin32'
+ || $^O eq 'MacOS'
+ || $^O =~ /^cygwin/)
+ {
+ my @stat = stat($file);
+
+ if (@stat) {
+ if ($stat[2] & 077) { ## no critic (ValuesAndExpressions::ProhibitLeadingZeros)
+ carp "Bad permissions: $file";
+ return;
+ }
+ if ($stat[4] != $<) {
+ carp "Not owner: $file";
+ return;
+ }
+ }
+ }
+
+ if ($fh = FileHandle->new($file, "r")) {
+ my ($mach, $macdef, $tok, @tok) = (0, 0);
+
+ while (<$fh>) {
+ undef $macdef if /\A\n\Z/;
+
+ if ($macdef) {
+ push(@$macdef, $_);
+ next;
+ }
+
+ s/^\s*//;
+ chomp;
+
+ while (length && s/^("((?:[^"]+|\\.)*)"|((?:[^\\\s]+|\\.)*))\s*//) {
+ (my $tok = $+) =~ s/\\(.)/$1/g;
+ push(@tok, $tok);
+ }
+
+ TOKEN:
+ while (@tok) {
+ if ($tok[0] eq "default") {
+ shift(@tok);
+ $mach = bless {}, $class;
+ $netrc{default} = [$mach];
+
+ next TOKEN;
+ }
+
+ last TOKEN
+ unless @tok > 1;
+
+ $tok = shift(@tok);
+
+ if ($tok eq "machine") {
+ my $host = shift @tok;
+ $mach = bless {machine => $host}, $class;
+
+ $netrc{$host} = []
+ unless exists($netrc{$host});
+ push(@{$netrc{$host}}, $mach);
+ }
+ elsif ($tok =~ /^(login|password|account)$/) {
+ next TOKEN unless $mach;
+ my $value = shift @tok;
+
+ # Following line added by rmerrell to remove '/' escape char in .netrc
+ $value =~ s/\/\\/\\/g;
+ $mach->{$1} = $value;
+ }
+ elsif ($tok eq "macdef") {
+ next TOKEN unless $mach;
+ my $value = shift @tok;
+ $mach->{macdef} = {}
+ unless exists $mach->{macdef};
+ $macdef = $mach->{machdef}{$value} = [];
+ }
+ }
+ }
+ $fh->close();
+ }
+}
+
+
+sub lookup {
+ my ($class, $mach, $login) = @_;
+
+ $class->_readrc()
+ unless exists $netrc{default};
+
+ $mach ||= 'default';
+ undef $login
+ if $mach eq 'default';
+
+ if (exists $netrc{$mach}) {
+ if (defined $login) {
+ foreach my $m (@{$netrc{$mach}}) {
+ return $m
+ if (exists $m->{login} && $m->{login} eq $login);
+ }
+ return;
+ }
+ return $netrc{$mach}->[0];
+ }
+
+ return $netrc{default}->[0]
+ if defined $netrc{default};
+
+ return;
+}
+
+
+sub login {
+ my $me = shift;
+
+ exists $me->{login}
+ ? $me->{login}
+ : undef;
+}
+
+
+sub account {
+ my $me = shift;
+
+ exists $me->{account}
+ ? $me->{account}
+ : undef;
+}
+
+
+sub password {
+ my $me = shift;
+
+ exists $me->{password}
+ ? $me->{password}
+ : undef;
+}
+
+
+sub lpa {
+ my $me = shift;
+ ($me->login, $me->password, $me->account);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Net::Netrc - OO interface to users netrc file
+
+=head1 SYNOPSIS
+
+ use Net::Netrc;
+
+ $mach = Net::Netrc->lookup('some.machine');
+ $login = $mach->login;
+ ($login, $password, $account) = $mach->lpa;
+
+=head1 DESCRIPTION
+
+C<Net::Netrc> is a class implementing a simple interface to the .netrc file
+used as by the ftp program.
+
+C<Net::Netrc> also implements security checks just like the ftp program,
+these checks are, first that the .netrc file must be owned by the user and
+second the ownership permissions should be such that only the owner has
+read and write access. If these conditions are not met then a warning is
+output and the .netrc file is not read.
+
+=head1 THE .netrc FILE
+
+The .netrc file contains login and initialization information used by the
+auto-login process. It resides in the user's home directory. The following
+tokens are recognized; they may be separated by spaces, tabs, or new-lines:
+
+=over 4
+
+=item machine name
+
+Identify a remote machine name. The auto-login process searches
+the .netrc file for a machine token that matches the remote machine
+specified. Once a match is made, the subsequent .netrc tokens
+are processed, stopping when the end of file is reached or an-
+other machine or a default token is encountered.
+
+=item default
+
+This is the same as machine name except that default matches
+any name. There can be only one default token, and it must be
+after all machine tokens. This is normally used as:
+
+ default login anonymous password user@site
+
+thereby giving the user automatic anonymous login to machines
+not specified in .netrc.
+
+=item login name
+
+Identify a user on the remote machine. If this token is present,
+the auto-login process will initiate a login using the
+specified name.
+
+=item password string
+
+Supply a password. If this token is present, the auto-login
+process will supply the specified string if the remote server
+requires a password as part of the login process.
+
+=item account string
+
+Supply an additional account password. If this token is present,
+the auto-login process will supply the specified string
+if the remote server requires an additional account password.
+
+=item macdef name
+
+Define a macro. C<Net::Netrc> only parses this field to be compatible
+with I<ftp>.
+
+=back
+
+=head1 CONSTRUCTOR
+
+The constructor for a C<Net::Netrc> object is not called new as it does not
+really create a new object. But instead is called C<lookup> as this is
+essentially what it does.
+
+=over 4
+
+=item lookup ( MACHINE [, LOGIN ])
+
+Lookup and return a reference to the entry for C<MACHINE>. If C<LOGIN> is given
+then the entry returned will have the given login. If C<LOGIN> is not given then
+the first entry in the .netrc file for C<MACHINE> will be returned.
+
+If a matching entry cannot be found, and a default entry exists, then a
+reference to the default entry is returned.
+
+If there is no matching entry found and there is no default defined, or
+no .netrc file is found, then C<undef> is returned.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item login ()
+
+Return the login id for the netrc entry
+
+=item password ()
+
+Return the password for the netrc entry
+
+=item account ()
+
+Return the account information for the netrc entry
+
+=item lpa ()
+
+Return a list of login, password and account information for the netrc entry
+
+=back
+
+=head1 AUTHOR
+
+Graham Barr E<lt>F<gbarr@pobox.com>E<gt>
+
+Steve Hay E<lt>F<shay@cpan.org>E<gt> is now maintaining libnet as of version
+1.22_02
+
+=head1 SEE ALSO
+
+L<Net::Netrc>,
+L<Net::Cmd>
+
+=head1 COPYRIGHT
+
+Versions up to 2.13 Copyright (c) 1995-1998 Graham Barr. All rights reserved.
+Changes in Version 2.13_01 onwards Copyright (C) 2013-2014 Steve Hay. All
+rights reserved.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
@@ -0,0 +1,846 @@
+# Net::POP3.pm
+#
+# Versions up to 2.29 Copyright (c) 1995-2004 Graham Barr <gbarr@pobox.com>.
+# All rights reserved.
+# Changes in Version 2.29_01 onwards Copyright (C) 2013-2014 Steve Hay. All
+# rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Net::POP3;
+
+use 5.008001;
+
+use strict;
+use warnings;
+
+use Carp;
+use IO::Socket;
+use Net::Cmd;
+use Net::Config;
+
+our $VERSION = "3.02";
+
+# Code for detecting if we can use SSL
+my $ssl_class = eval {
+ require IO::Socket::SSL;
+ # first version with default CA on most platforms
+ IO::Socket::SSL->VERSION(1.999);
+} && 'IO::Socket::SSL';
+
+my $nossl_warn = !$ssl_class &&
+ 'To use SSL please install IO::Socket::SSL with version>=1.999';
+
+# Code for detecting if we can use IPv6
+my $inet6_class = eval {
+ require IO::Socket::IP;
+ IO::Socket::IP->VERSION(0.20);
+} && 'IO::Socket::IP' || eval {
+ require IO::Socket::INET6;
+ 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;
+ my @localport = exists $arg{ResvPort} ? (LocalPort => $arg{ResvPort}) : ();
+
+ 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',
+ @localport,
+ Timeout => $arg{Timeout},
+ )
+ and last;
+ }
+
+ return
+ unless defined $obj;
+
+ ${*$obj}{'net_pop3_arg'} = \%arg;
+ if ($arg{SSL}) {
+ Net::POP3::_SSL->start_SSL($obj,
+ SSL_verifycn_name => $host,%arg
+ ) or return;
+ }
+
+ ${*$obj}{'net_pop3_host'} = $host;
+
+ $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_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.
+
+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 IO::Socket::INET.
+
+=head1 CONSTRUCTOR
+
+=over 4
+
+=item new ( [ HOST ] [, OPTIONS ] )
+
+This is the constructor for a new Net::POP3 object. C<HOST> is the
+name of the remote host to which an POP3 connection is required.
+
+C<HOST> is optional. If C<HOST> is not given then it may instead be
+passed as the C<Host> option described below. If neither is given then
+the C<POP3_Hosts> specified in C<Net::Config> will be used.
+
+C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
+Possible options are:
+
+B<Host> - POP3 host to connect to. It may be a single scalar, as defined for
+the C<PeerAddr> option in L<IO::Socket::INET>, or a reference to
+an array with hosts to try in turn. The L</host> method will return the value
+which was used to connect to the host.
+
+B<Port> - port to connect to.
+Default - 110 for plain POP3 and 995 for POP3s (direct SSL).
+
+B<SSL> - If the connection should be done from start with SSL, contrary to later
+upgrade with C<starttls>.
+You can use SSL arguments as documented in L<IO::Socket::SSL>, but it will
+usually use the right arguments already.
+
+B<ResvPort> - If given then the socket for the C<Net::POP3> object
+will be bound to the local port given using C<bind> when the socket is
+created.
+
+B<Timeout> - Maximum time, in seconds, to wait for a response from the
+POP3 server (default: 120)
+
+B<Debug> - Enable debugging information
+
+=back
+
+=head1 METHODS
+
+Unless otherwise stated all methods return either a I<true> or I<false>
+value, with I<true> meaning that the operation was a success. When a method
+states that it returns a value, failure will be returned as I<undef> or an
+empty list.
+
+C<Net::POP3> inherits from C<Net::Cmd> so methods defined in C<Net::Cmd> may
+be used to send commands to the remote POP3 server in addition to the methods
+documented here.
+
+=over 4
+
+=item host ()
+
+Returns the value used by the constructor, and passed to IO::Socket::INET,
+to connect to the host.
+
+=item auth ( USERNAME, PASSWORD )
+
+Attempt SASL authentication.
+
+=item user ( USER )
+
+Send the USER command.
+
+=item pass ( PASS )
+
+Send the PASS command. Returns the number of messages in the mailbox.
+
+=item login ( [ USER [, PASS ]] )
+
+Send both the USER and PASS commands. If C<PASS> is not given the
+C<Net::POP3> uses C<Net::Netrc> to lookup the password using the host
+and username. If the username is not specified then the current user name
+will be used.
+
+Returns the number of messages in the mailbox. However if there are no
+messages on the server the string C<"0E0"> will be returned. This is
+will give a true value in a boolean context, but zero in a numeric context.
+
+If there was an error authenticating the user then I<undef> will be returned.
+
+=item starttls ( SSLARGS )
+
+Upgrade existing plain connection to SSL.
+You can use SSL arguments as documented in L<IO::Socket::SSL>, but it will
+usually use the right arguments already.
+
+=item apop ( [ USER [, PASS ]] )
+
+Authenticate with the server identifying as C<USER> with password C<PASS>.
+Similar to L</login>, but the password is not sent in clear text.
+
+To use this method you must have the Digest::MD5 or the MD5 module installed,
+otherwise this method will return I<undef>.
+
+=item banner ()
+
+Return the sever's connection banner
+
+=item capa ()
+
+Return a reference to a hash of the capabilities of the server. APOP
+is added as a pseudo capability. Note that I've been unable to
+find a list of the standard capability values, and some appear to
+be multi-word and some are not. We make an attempt at intelligently
+parsing them, but it may not be correct.
+
+=item capabilities ()
+
+Just like capa, but only uses a cache from the last time we asked
+the server, so as to avoid asking more than once.
+
+=item top ( MSGNUM [, NUMLINES ] )
+
+Get the header and the first C<NUMLINES> of the body for the message
+C<MSGNUM>. Returns a reference to an array which contains the lines of text
+read from the server.
+
+=item list ( [ MSGNUM ] )
+
+If called with an argument the C<list> returns the size of the message
+in octets.
+
+If called without arguments a reference to a hash is returned. The
+keys will be the C<MSGNUM>'s of all undeleted messages and the values will
+be their size in octets.
+
+=item get ( MSGNUM [, FH ] )
+
+Get the message C<MSGNUM> from the remote mailbox. If C<FH> is not given
+then get returns a reference to an array which contains the lines of
+text read from the server. If C<FH> is given then the lines returned
+from the server are printed to the filehandle C<FH>.
+
+=item getfh ( MSGNUM )
+
+As per get(), but returns a tied filehandle. Reading from this
+filehandle returns the requested message. The filehandle will return
+EOF at the end of the message and should not be reused.
+
+=item last ()
+
+Returns the highest C<MSGNUM> of all the messages accessed.
+
+=item popstat ()
+
+Returns a list of two elements. These are the number of undeleted
+elements and the size of the mbox in octets.
+
+=item ping ( USER )
+
+Returns a list of two elements. These are the number of new messages
+and the total number of messages for C<USER>.
+
+=item uidl ( [ MSGNUM ] )
+
+Returns a unique identifier for C<MSGNUM> if given. If C<MSGNUM> is not
+given C<uidl> returns a reference to a hash where the keys are the
+message numbers and the values are the unique identifiers.
+
+=item delete ( MSGNUM )
+
+Mark message C<MSGNUM> to be deleted from the remote mailbox. All messages
+that are marked to be deleted will be removed from the remote mailbox
+when the server connection closed.
+
+=item reset ()
+
+Reset the status of the remote POP3 server. This includes resetting the
+status of all messages to not be deleted.
+
+=item quit ()
+
+Quit and close the connection to the remote POP3 server. Any messages marked
+as deleted will be deleted from the remote mailbox.
+
+=item can_inet6 ()
+
+Returns whether we can use IPv6.
+
+=item can_ssl ()
+
+Returns whether we can use SSL.
+
+=back
+
+=head1 NOTES
+
+If a C<Net::POP3> object goes out of scope before C<quit> method is called
+then the C<reset> method will called before the connection is closed. This
+means that any messages marked to be deleted will not be.
+
+=head1 SEE ALSO
+
+L<Net::Netrc>,
+L<Net::Cmd>,
+L<IO::Socket::SSL>
+
+=head1 AUTHOR
+
+Graham Barr E<lt>F<gbarr@pobox.com>E<gt>
+
+Steve Hay E<lt>F<shay@cpan.org>E<gt> is now maintaining libnet as of version
+1.22_02
+
+=head1 COPYRIGHT
+
+Versions up to 2.29 Copyright (c) 1995-2004 Graham Barr. All rights reserved.
+Changes in Version 2.29_01 onwards Copyright (C) 2013-2014 Steve Hay. All
+rights reserved.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
@@ -0,0 +1,1013 @@
+# Net::SMTP.pm
+#
+# Versions up to 2.31_1 Copyright (c) 1995-2004 Graham Barr <gbarr@pobox.com>.
+# All rights reserved.
+# Changes in Version 2.31_2 onwards Copyright (C) 2013-2014 Steve Hay. All
+# rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Net::SMTP;
+
+use 5.008001;
+
+use strict;
+use warnings;
+
+use Carp;
+use IO::Socket;
+use Net::Cmd;
+use Net::Config;
+use Socket 1.3;
+
+our $VERSION = "3.02";
+
+# Code for detecting if we can use SSL
+my $ssl_class = eval {
+ require IO::Socket::SSL;
+ # first version with default CA on most platforms
+ IO::Socket::SSL->VERSION(1.999);
+} && 'IO::Socket::SSL';
+
+my $nossl_warn = !$ssl_class &&
+ 'To use SSL please install IO::Socket::SSL with version>=1.999';
+
+# Code for detecting if we can use IPv6
+my $inet6_class = eval {
+ require IO::Socket::IP;
+ IO::Socket::IP->VERSION(0.20);
+} && 'IO::Socket::IP' || eval {
+ require IO::Socket::INET6;
+ IO::Socket::INET6->VERSION(2.62);
+} && 'IO::Socket::INET6';
+
+sub can_ssl { $ssl_class };
+sub can_inet6 { $inet6_class };
+
+our @ISA = ('Net::Cmd', $inet6_class || 'IO::Socket::INET');
+
+sub new {
+ my $self = shift;
+ my $type = ref($self) || $self;
+ my ($host, %arg);
+ if (@_ % 2) {
+ $host = shift;
+ %arg = @_;
+ }
+ else {
+ %arg = @_;
+ $host = delete $arg{Host};
+ }
+
+ if ($arg{SSL}) {
+ # SSL from start
+ die $nossl_warn if !$ssl_class;
+ $arg{Port} ||= 465;
+ }
+
+ my $hosts = defined $host ? $host : $NetConfig{smtp_hosts};
+ my $obj;
+
+ $arg{Timeout} = 120 if ! defined $arg{Timeout};
+
+ foreach my $h (@{ref($hosts) ? $hosts : [$hosts]}) {
+ $obj = $type->SUPER::new(
+ PeerAddr => ($host = $h),
+ PeerPort => $arg{Port} || 'smtp(25)',
+ LocalAddr => $arg{LocalAddr},
+ LocalPort => $arg{LocalPort},
+ Proto => 'tcp',
+ Timeout => $arg{Timeout}
+ )
+ and last;
+ }
+
+ return
+ unless defined $obj;
+
+ ${*$obj}{'net_smtp_arg'} = \%arg;
+ if ($arg{SSL}) {
+ Net::SMTP::_SSL->start_SSL($obj,SSL_verifycn_name => $host,%arg)
+ or return;
+ }
+
+ $obj->autoflush(1);
+
+ $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
+
+ unless ($obj->response() == CMD_OK) {
+ my $err = ref($obj) . ": " . $obj->code . " " . $obj->message;
+ $obj->close();
+ $@ = $err;
+ return;
+ }
+
+ ${*$obj}{'net_smtp_exact_addr'} = $arg{ExactAddresses};
+ ${*$obj}{'net_smtp_host'} = $host;
+
+ (${*$obj}{'net_smtp_banner'}) = $obj->message;
+ (${*$obj}{'net_smtp_domain'}) = $obj->message =~ /\A\s*(\S+)/;
+
+ unless ($obj->hello($arg{Hello} || "")) {
+ my $err = ref($obj) . ": " . $obj->code . " " . $obj->message;
+ $obj->close();
+ $@ = $err;
+ return;
+ }
+
+ $obj;
+}
+
+
+sub host {
+ my $me = shift;
+ ${*$me}{'net_smtp_host'};
+}
+
+##
+## User interface methods
+##
+
+
+sub banner {
+ my $me = shift;
+
+ return ${*$me}{'net_smtp_banner'} || undef;
+}
+
+
+sub domain {
+ my $me = shift;
+
+ return ${*$me}{'net_smtp_domain'} || undef;
+}
+
+
+sub etrn {
+ my $self = shift;
+ defined($self->supports('ETRN', 500, ["Command unknown: 'ETRN'"]))
+ && $self->_ETRN(@_);
+}
+
+
+sub auth {
+ my ($self, $username, $password) = @_;
+
+ eval {
+ require MIME::Base64;
+ require Authen::SASL;
+ } or $self->set_status(500, ["Need MIME::Base64 and Authen::SASL todo auth"]), return 0;
+
+ my $mechanisms = $self->supports('AUTH', 500, ["Command unknown: 'AUTH'"]);
+ return unless defined $mechanisms;
+
+ my $sasl;
+
+ if (ref($username) and UNIVERSAL::isa($username, 'Authen::SASL')) {
+ $sasl = $username;
+ my $requested_mechanisms = $sasl->mechanism();
+ if (! defined($requested_mechanisms) || $requested_mechanisms eq '') {
+ $sasl->mechanism($mechanisms);
+ }
+ }
+ else {
+ die "auth(username, password)" if not length $username;
+ $sasl = Authen::SASL->new(
+ mechanism => $mechanisms,
+ callback => {
+ user => $username,
+ pass => $password,
+ authname => $username,
+ },
+ debug => $self->debug
+ );
+ }
+
+ my $client;
+ my $str;
+ do {
+ if ($client) {
+ # $client mechanism failed, so we need to exclude this mechanism from list
+ my $failed_mechanism = $client->mechanism;
+ $self->debug_text("Auth mechanism failed: $failed_mechanism")
+ if $self->debug;
+ $mechanisms =~ s/\b\Q$failed_mechanism\E\b//;
+ last unless $mechanisms =~ /\S/;
+ $sasl->mechanism($mechanisms);
+ }
+
+ # We should probably allow the user to pass the host, but I don't
+ # currently know and SASL mechanisms that are used by smtp that need it
+
+ $client = $sasl->client_new('smtp', ${*$self}{'net_smtp_host'}, 0);
+ $str = $client->client_start;
+ } while (!defined $str);
+
+ # We don't support sasl mechanisms that encrypt the socket traffic.
+ # todo that we would really need to change the ISA hierarchy
+ # so we don't inherit from IO::Socket, but instead hold it in an attribute
+
+ my @cmd = ("AUTH", $client->mechanism);
+ my $code;
+
+ push @cmd, MIME::Base64::encode_base64($str, '')
+ if defined $str and length $str;
+
+ while (($code = $self->command(@cmd)->response()) == CMD_MORE) {
+ @cmd = (
+ MIME::Base64::encode_base64(
+ $client->client_step(MIME::Base64::decode_base64(($self->message)[0])), ''
+ )
+ );
+ }
+
+ $code == CMD_OK;
+}
+
+
+sub hello {
+ my $me = shift;
+ my $domain = shift || "localhost.localdomain";
+ my $ok = $me->_EHLO($domain);
+ my @msg = $me->message;
+
+ if ($ok) {
+ my $h = ${*$me}{'net_smtp_esmtp'} = {};
+ foreach my $ln (@msg) {
+ $h->{uc $1} = $2
+ if $ln =~ /([-\w]+)\b[= \t]*([^\n]*)/;
+ }
+ }
+ elsif ($me->status == CMD_ERROR) {
+ @msg = $me->message
+ if $ok = $me->_HELO($domain);
+ }
+
+ return unless $ok;
+ ${*$me}{net_smtp_hello_domain} = $domain;
+
+ $msg[0] =~ /\A\s*(\S+)/;
+ return ($1 || " ");
+}
+
+sub starttls {
+ my $self = shift;
+ $ssl_class or die $nossl_warn;
+ $self->_STARTTLS or return;
+ Net::SMTP::_SSL->start_SSL($self,
+ %{ ${*$self}{'net_smtp_arg'} }, # (ssl) args given in new
+ @_ # more (ssl) args
+ ) or return;
+
+ # another hello after starttls to read new ESMTP capabilities
+ return $self->hello(${*$self}{net_smtp_hello_domain});
+}
+
+
+sub supports {
+ my $self = shift;
+ my $cmd = uc shift;
+ return ${*$self}{'net_smtp_esmtp'}->{$cmd}
+ if exists ${*$self}{'net_smtp_esmtp'}->{$cmd};
+ $self->set_status(@_)
+ if @_;
+ return;
+}
+
+
+sub _addr {
+ my $self = shift;
+ my $addr = shift;
+ $addr = "" unless defined $addr;
+
+ if (${*$self}{'net_smtp_exact_addr'}) {
+ return $1 if $addr =~ /^\s*(<.*>)\s*$/s;
+ }
+ else {
+ return $1 if $addr =~ /(<[^>]*>)/;
+ $addr =~ s/^\s+|\s+$//sg;
+ }
+
+ "<$addr>";
+}
+
+
+sub mail {
+ my $me = shift;
+ my $addr = _addr($me, shift);
+ my $opts = "";
+
+ if (@_) {
+ my %opt = @_;
+ my ($k, $v);
+
+ if (exists ${*$me}{'net_smtp_esmtp'}) {
+ my $esmtp = ${*$me}{'net_smtp_esmtp'};
+
+ if (defined($v = delete $opt{Size})) {
+ if (exists $esmtp->{SIZE}) {
+ $opts .= sprintf " SIZE=%d", $v + 0;
+ }
+ else {
+ carp 'Net::SMTP::mail: SIZE option not supported by host';
+ }
+ }
+
+ if (defined($v = delete $opt{Return})) {
+ if (exists $esmtp->{DSN}) {
+ $opts .= " RET=" . ((uc($v) eq "FULL") ? "FULL" : "HDRS");
+ }
+ else {
+ carp 'Net::SMTP::mail: DSN option not supported by host';
+ }
+ }
+
+ if (defined($v = delete $opt{Bits})) {
+ if ($v eq "8") {
+ if (exists $esmtp->{'8BITMIME'}) {
+ $opts .= " BODY=8BITMIME";
+ }
+ else {
+ carp 'Net::SMTP::mail: 8BITMIME option not supported by host';
+ }
+ }
+ elsif ($v eq "binary") {
+ if (exists $esmtp->{'BINARYMIME'} && exists $esmtp->{'CHUNKING'}) {
+ $opts .= " BODY=BINARYMIME";
+ ${*$me}{'net_smtp_chunking'} = 1;
+ }
+ else {
+ carp 'Net::SMTP::mail: BINARYMIME option not supported by host';
+ }
+ }
+ elsif (exists $esmtp->{'8BITMIME'} or exists $esmtp->{'BINARYMIME'}) {
+ $opts .= " BODY=7BIT";
+ }
+ else {
+ carp 'Net::SMTP::mail: 8BITMIME and BINARYMIME options not supported by host';
+ }
+ }
+
+ if (defined($v = delete $opt{Transaction})) {
+ if (exists $esmtp->{CHECKPOINT}) {
+ $opts .= " TRANSID=" . _addr($me, $v);
+ }
+ else {
+ carp 'Net::SMTP::mail: CHECKPOINT option not supported by host';
+ }
+ }
+
+ if (defined($v = delete $opt{Envelope})) {
+ if (exists $esmtp->{DSN}) {
+ $v =~ s/([^\041-\176]|=|\+)/sprintf "+%02X", ord($1)/sge;
+ $opts .= " ENVID=$v";
+ }
+ else {
+ carp 'Net::SMTP::mail: DSN option not supported by host';
+ }
+ }
+
+ if (defined($v = delete $opt{ENVID})) {
+
+ # expected to be in a format as required by RFC 3461, xtext-encoded
+ if (exists $esmtp->{DSN}) {
+ $opts .= " ENVID=$v";
+ }
+ else {
+ carp 'Net::SMTP::mail: DSN option not supported by host';
+ }
+ }
+
+ if (defined($v = delete $opt{AUTH})) {
+
+ # expected to be in a format as required by RFC 2554,
+ # rfc2821-quoted and xtext-encoded, or <>
+ if (exists $esmtp->{AUTH}) {
+ $v = '<>' if !defined($v) || $v eq '';
+ $opts .= " AUTH=$v";
+ }
+ else {
+ carp 'Net::SMTP::mail: AUTH option not supported by host';
+ }
+ }
+
+ if (defined($v = delete $opt{XVERP})) {
+ if (exists $esmtp->{'XVERP'}) {
+ $opts .= " XVERP";
+ }
+ else {
+ carp 'Net::SMTP::mail: XVERP option not supported by host';
+ }
+ }
+
+ carp 'Net::SMTP::recipient: unknown option(s) ' . join(" ", keys %opt) . ' - ignored'
+ if scalar keys %opt;
+ }
+ else {
+ carp 'Net::SMTP::mail: ESMTP not supported by host - options discarded :-(';
+ }
+ }
+
+ $me->_MAIL("FROM:" . $addr . $opts);
+}
+
+
+sub send { my $me = shift; $me->_SEND("FROM:" . _addr($me, $_[0])) }
+sub send_or_mail { my $me = shift; $me->_SOML("FROM:" . _addr($me, $_[0])) }
+sub send_and_mail { my $me = shift; $me->_SAML("FROM:" . _addr($me, $_[0])) }
+
+
+sub reset {
+ my $me = shift;
+
+ $me->dataend()
+ if (exists ${*$me}{'net_smtp_lastch'});
+
+ $me->_RSET();
+}
+
+
+sub recipient {
+ my $smtp = shift;
+ my $opts = "";
+ my $skip_bad = 0;
+
+ if (@_ && ref($_[-1])) {
+ my %opt = %{pop(@_)};
+ my $v;
+
+ $skip_bad = delete $opt{'SkipBad'};
+
+ if (exists ${*$smtp}{'net_smtp_esmtp'}) {
+ my $esmtp = ${*$smtp}{'net_smtp_esmtp'};
+
+ if (defined($v = delete $opt{Notify})) {
+ if (exists $esmtp->{DSN}) {
+ $opts .= " NOTIFY=" . join(",", map { uc $_ } @$v);
+ }
+ else {
+ carp 'Net::SMTP::recipient: DSN option not supported by host';
+ }
+ }
+
+ if (defined($v = delete $opt{ORcpt})) {
+ if (exists $esmtp->{DSN}) {
+ $opts .= " ORCPT=" . $v;
+ }
+ else {
+ carp 'Net::SMTP::recipient: DSN option not supported by host';
+ }
+ }
+
+ carp 'Net::SMTP::recipient: unknown option(s) ' . join(" ", keys %opt) . ' - ignored'
+ if scalar keys %opt;
+ }
+ elsif (%opt) {
+ carp 'Net::SMTP::recipient: ESMTP not supported by host - options discarded :-(';
+ }
+ }
+
+ my @ok;
+ foreach my $addr (@_) {
+ if ($smtp->_RCPT("TO:" . _addr($smtp, $addr) . $opts)) {
+ push(@ok, $addr) if $skip_bad;
+ }
+ elsif (!$skip_bad) {
+ return 0;
+ }
+ }
+
+ return $skip_bad ? @ok : 1;
+}
+
+BEGIN {
+ *to = \&recipient;
+ *cc = \&recipient;
+ *bcc = \&recipient;
+}
+
+
+sub data {
+ my $me = shift;
+
+ if (exists ${*$me}{'net_smtp_chunking'}) {
+ carp 'Net::SMTP::data: CHUNKING extension in use, must call bdat instead';
+ }
+ else {
+ my $ok = $me->_DATA() && $me->datasend(@_);
+
+ $ok && @_
+ ? $me->dataend
+ : $ok;
+ }
+}
+
+
+sub bdat {
+ my $me = shift;
+
+ if (exists ${*$me}{'net_smtp_chunking'}) {
+ my $data = shift;
+
+ $me->_BDAT(length $data)
+ && $me->rawdatasend($data)
+ && $me->response() == CMD_OK;
+ }
+ else {
+ carp 'Net::SMTP::bdat: CHUNKING extension is not in use, call data instead';
+ }
+}
+
+
+sub bdatlast {
+ my $me = shift;
+
+ if (exists ${*$me}{'net_smtp_chunking'}) {
+ my $data = shift;
+
+ $me->_BDAT(length $data, "LAST")
+ && $me->rawdatasend($data)
+ && $me->response() == CMD_OK;
+ }
+ else {
+ carp 'Net::SMTP::bdat: CHUNKING extension is not in use, call data instead';
+ }
+}
+
+
+sub datafh {
+ my $me = shift;
+ return unless $me->_DATA();
+ return $me->tied_fh;
+}
+
+
+sub expand {
+ my $me = shift;
+
+ $me->_EXPN(@_)
+ ? ($me->message)
+ : ();
+}
+
+
+sub verify { shift->_VRFY(@_) }
+
+
+sub help {
+ my $me = shift;
+
+ $me->_HELP(@_)
+ ? scalar $me->message
+ : undef;
+}
+
+
+sub quit {
+ my $me = shift;
+
+ $me->_QUIT;
+ $me->close;
+}
+
+
+sub DESTROY {
+
+ # ignore
+}
+
+##
+## RFC821 commands
+##
+
+
+sub _EHLO { shift->command("EHLO", @_)->response() == CMD_OK }
+sub _HELO { shift->command("HELO", @_)->response() == CMD_OK }
+sub _MAIL { shift->command("MAIL", @_)->response() == CMD_OK }
+sub _RCPT { shift->command("RCPT", @_)->response() == CMD_OK }
+sub _SEND { shift->command("SEND", @_)->response() == CMD_OK }
+sub _SAML { shift->command("SAML", @_)->response() == CMD_OK }
+sub _SOML { shift->command("SOML", @_)->response() == CMD_OK }
+sub _VRFY { shift->command("VRFY", @_)->response() == CMD_OK }
+sub _EXPN { shift->command("EXPN", @_)->response() == CMD_OK }
+sub _HELP { shift->command("HELP", @_)->response() == CMD_OK }
+sub _RSET { shift->command("RSET")->response() == CMD_OK }
+sub _NOOP { shift->command("NOOP")->response() == CMD_OK }
+sub _QUIT { shift->command("QUIT")->response() == CMD_OK }
+sub _DATA { shift->command("DATA")->response() == CMD_MORE }
+sub _BDAT { shift->command("BDAT", @_) }
+sub _TURN { shift->unsupported(@_); }
+sub _ETRN { shift->command("ETRN", @_)->response() == CMD_OK }
+sub _AUTH { shift->command("AUTH", @_)->response() == CMD_OK }
+sub _STARTTLS { shift->command("STARTTLS")->response() == CMD_OK }
+
+
+{
+ package Net::SMTP::_SSL;
+ our @ISA = ( $ssl_class ? ($ssl_class):(), 'Net::SMTP' );
+ sub starttls { die "SMTP connection is already in SSL mode" }
+ sub start_SSL {
+ my ($class,$smtp,%arg) = @_;
+ delete @arg{ grep { !m{^SSL_} } keys %arg };
+ ( $arg{SSL_verifycn_name} ||= $smtp->host )
+ =~s{(?<!:):[\w()]+$}{}; # strip port
+ $arg{SSL_verifycn_scheme} ||= 'smtp';
+ my $ok = $class->SUPER::start_SSL($smtp,%arg);
+ $@ = $ssl_class->errstr if !$ok;
+ return $ok;
+ }
+}
+
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+Net::SMTP - Simple Mail Transfer Protocol Client
+
+=head1 SYNOPSIS
+
+ use Net::SMTP;
+
+ # Constructors
+ $smtp = Net::SMTP->new('mailhost');
+ $smtp = Net::SMTP->new('mailhost', Timeout => 60);
+
+=head1 DESCRIPTION
+
+This module implements a client interface to the SMTP and ESMTP
+protocol, enabling a perl5 application to talk to SMTP servers. This
+documentation assumes that you are familiar with the concepts of the
+SMTP protocol described in RFC821.
+
+A new Net::SMTP object must be created with the I<new> method. Once
+this has been done, all SMTP commands are accessed through this object.
+
+The Net::SMTP class is a subclass of Net::Cmd and IO::Socket::INET.
+
+=head1 EXAMPLES
+
+This example prints the mail domain name of the SMTP server known as mailhost:
+
+ #!/usr/local/bin/perl -w
+
+ use Net::SMTP;
+
+ $smtp = Net::SMTP->new('mailhost');
+ print $smtp->domain,"\n";
+ $smtp->quit;
+
+This example sends a small message to the postmaster at the SMTP server
+known as mailhost:
+
+ #!/usr/local/bin/perl -w
+
+ use Net::SMTP;
+
+ my $smtp = Net::SMTP->new('mailhost');
+
+ $smtp->mail($ENV{USER});
+ if ($smtp->to('postmaster')) {
+ $smtp->data();
+ $smtp->datasend("To: postmaster\n");
+ $smtp->datasend("\n");
+ $smtp->datasend("A simple test message\n");
+ $smtp->dataend();
+ } else {
+ print "Error: ", $smtp->message();
+ }
+
+ $smtp->quit;
+
+=head1 CONSTRUCTOR
+
+=over 4
+
+=item new ( [ HOST ] [, OPTIONS ] )
+
+This is the constructor for a new Net::SMTP object. C<HOST> is the
+name of the remote host to which an SMTP connection is required.
+
+On failure C<undef> will be returned and C<$@> will contain the reason
+for the failure.
+
+C<HOST> is optional. If C<HOST> is not given then it may instead be
+passed as the C<Host> option described below. If neither is given then
+the C<SMTP_Hosts> specified in C<Net::Config> will be used.
+
+C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
+Possible options are:
+
+B<Hello> - SMTP requires that you identify yourself. This option
+specifies a string to pass as your mail domain. If not given localhost.localdomain
+will be used.
+
+B<Host> - SMTP host to connect to. It may be a single scalar (hostname[:port]),
+as defined for the C<PeerAddr> option in L<IO::Socket::INET>, or a reference to
+an array with hosts to try in turn. The L</host> method will return the value
+which was used to connect to the host.
+Format - C<PeerHost> from L<IO::Socket::INET> new method.
+
+B<Port> - port to connect to.
+Default - 25 for plain SMTP and 465 for immediate SSL.
+
+B<SSL> - If the connection should be done from start with SSL, contrary to later
+upgrade with C<starttls>.
+You can use SSL arguments as documented in L<IO::Socket::SSL>, but it will
+usually use the right arguments already.
+
+B<LocalAddr> and B<LocalPort> - These parameters are passed directly
+to IO::Socket to allow binding the socket to a local port.
+
+B<Timeout> - Maximum time, in seconds, to wait for a response from the
+SMTP server (default: 120)
+
+B<ExactAddresses> - If true the all ADDRESS arguments must be as
+defined by C<addr-spec> in RFC2822. If not given, or false, then
+Net::SMTP will attempt to extract the address from the value passed.
+
+B<Debug> - Enable debugging information
+
+
+Example:
+
+
+ $smtp = Net::SMTP->new('mailhost',
+ Hello => 'my.mail.domain',
+ Timeout => 30,
+ Debug => 1,
+ );
+
+ # the same
+ $smtp = Net::SMTP->new(
+ Host => 'mailhost',
+ Hello => 'my.mail.domain',
+ Timeout => 30,
+ Debug => 1,
+ );
+
+ # the same with direct SSL
+ $smtp = Net::SMTP->new('mailhost',
+ Hello => 'my.mail.domain',
+ Timeout => 30,
+ Debug => 1,
+ SSL => 1,
+ );
+
+ # Connect to the default server from Net::config
+ $smtp = Net::SMTP->new(
+ Hello => 'my.mail.domain',
+ Timeout => 30,
+ );
+
+=back
+
+=head1 METHODS
+
+Unless otherwise stated all methods return either a I<true> or I<false>
+value, with I<true> meaning that the operation was a success. When a method
+states that it returns a value, failure will be returned as I<undef> or an
+empty list.
+
+C<Net::SMTP> inherits from C<Net::Cmd> so methods defined in C<Net::Cmd> may
+be used to send commands to the remote SMTP server in addition to the methods
+documented here.
+
+=over 4
+
+=item banner ()
+
+Returns the banner message which the server replied with when the
+initial connection was made.
+
+=item domain ()
+
+Returns the domain that the remote SMTP server identified itself as during
+connection.
+
+=item hello ( DOMAIN )
+
+Tell the remote server the mail domain which you are in using the EHLO
+command (or HELO if EHLO fails). Since this method is invoked
+automatically when the Net::SMTP object is constructed the user should
+normally not have to call it manually.
+
+=item host ()
+
+Returns the value used by the constructor, and passed to IO::Socket::INET,
+to connect to the host.
+
+=item etrn ( DOMAIN )
+
+Request a queue run for the DOMAIN given.
+
+=item starttls ( SSLARGS )
+
+Upgrade existing plain connection to SSL.
+You can use SSL arguments as documented in L<IO::Socket::SSL>, but it will
+usually use the right arguments already.
+
+=item auth ( USERNAME, PASSWORD )
+
+Attempt SASL authentication. Requires Authen::SASL module.
+
+=item mail ( ADDRESS [, OPTIONS] )
+
+=item send ( ADDRESS )
+
+=item send_or_mail ( ADDRESS )
+
+=item send_and_mail ( ADDRESS )
+
+Send the appropriate command to the server MAIL, SEND, SOML or SAML. C<ADDRESS>
+is the address of the sender. This initiates the sending of a message. The
+method C<recipient> should be called for each address that the message is to
+be sent to.
+
+The C<mail> method can some additional ESMTP OPTIONS which is passed
+in hash like fashion, using key and value pairs. Possible options are:
+
+ Size => <bytes>
+ Return => "FULL" | "HDRS"
+ Bits => "7" | "8" | "binary"
+ Transaction => <ADDRESS>
+ Envelope => <ENVID> # xtext-encodes its argument
+ ENVID => <ENVID> # similar to Envelope, but expects argument encoded
+ XVERP => 1
+ AUTH => <submitter> # encoded address according to RFC 2554
+
+The C<Return> and C<Envelope> parameters are used for DSN (Delivery
+Status Notification).
+
+The submitter address in C<AUTH> option is expected to be in a format as
+required by RFC 2554, in an RFC2821-quoted form and xtext-encoded, or <> .
+
+=item reset ()
+
+Reset the status of the server. This may be called after a message has been
+initiated, but before any data has been sent, to cancel the sending of the
+message.
+
+=item recipient ( ADDRESS [, ADDRESS, [...]] [, OPTIONS ] )
+
+Notify the server that the current message should be sent to all of the
+addresses given. Each address is sent as a separate command to the server.
+Should the sending of any address result in a failure then the process is
+aborted and a I<false> value is returned. It is up to the user to call
+C<reset> if they so desire.
+
+The C<recipient> method can also pass additional case-sensitive OPTIONS as an
+anonymous hash using key and value pairs. Possible options are:
+
+ Notify => ['NEVER'] or ['SUCCESS','FAILURE','DELAY'] (see below)
+ ORcpt => <ORCPT>
+ SkipBad => 1 (to ignore bad addresses)
+
+If C<SkipBad> is true the C<recipient> will not return an error when a bad
+address is encountered and it will return an array of addresses that did
+succeed.
+
+ $smtp->recipient($recipient1,$recipient2); # Good
+ $smtp->recipient($recipient1,$recipient2, { SkipBad => 1 }); # Good
+ $smtp->recipient($recipient1,$recipient2, { Notify => ['FAILURE','DELAY'], SkipBad => 1 }); # Good
+ @goodrecips=$smtp->recipient(@recipients, { Notify => ['FAILURE'], SkipBad => 1 }); # Good
+ $smtp->recipient("$recipient,$recipient2"); # BAD
+
+Notify is used to request Delivery Status Notifications (DSNs), but your
+SMTP/ESMTP service may not respect this request depending upon its version and
+your site's SMTP configuration.
+
+Leaving out the Notify option usually defaults an SMTP service to its default
+behavior equivalent to ['FAILURE'] notifications only, but again this may be
+dependent upon your site's SMTP configuration.
+
+The NEVER keyword must appear by itself if used within the Notify option and "requests
+that a DSN not be returned to the sender under any conditions."
+
+ {Notify => ['NEVER']}
+
+ $smtp->recipient(@recipients, { Notify => ['NEVER'], SkipBad => 1 }); # Good
+
+You may use any combination of these three values 'SUCCESS','FAILURE','DELAY' in
+the anonymous array reference as defined by RFC3461 (see http://www.ietf.org/rfc/rfc3461.txt
+for more information. Note: quotations in this topic from same.).
+
+A Notify parameter of 'SUCCESS' or 'FAILURE' "requests that a DSN be issued on
+successful delivery or delivery failure, respectively."
+
+A Notify parameter of 'DELAY' "indicates the sender's willingness to receive
+delayed DSNs. Delayed DSNs may be issued if delivery of a message has been
+delayed for an unusual amount of time (as determined by the Message Transfer
+Agent (MTA) at which the message is delayed), but the final delivery status
+(whether successful or failure) cannot be determined. The absence of the DELAY
+keyword in a NOTIFY parameter requests that a "delayed" DSN NOT be issued under
+any conditions."
+
+ {Notify => ['SUCCESS','FAILURE','DELAY']}
+
+ $smtp->recipient(@recipients, { Notify => ['FAILURE','DELAY'], SkipBad => 1 }); # Good
+
+ORcpt is also part of the SMTP DSN extension according to RFC3461.
+It is used to pass along the original recipient that the mail was first
+sent to. The machine that generates a DSN will use this address to inform
+the sender, because he can't know if recipients get rewritten by mail servers.
+It is expected to be in a format as required by RFC3461, xtext-encoded.
+
+=item to ( ADDRESS [, ADDRESS [...]] )
+
+=item cc ( ADDRESS [, ADDRESS [...]] )
+
+=item bcc ( ADDRESS [, ADDRESS [...]] )
+
+Synonyms for C<recipient>.
+
+=item data ( [ DATA ] )
+
+Initiate the sending of the data from the current message.
+
+C<DATA> may be a reference to a list or a list. If specified the contents
+of C<DATA> and a termination string C<".\r\n"> is sent to the server. And the
+result will be true if the data was accepted.
+
+If C<DATA> is not specified then the result will indicate that the server
+wishes the data to be sent. The data must then be sent using the C<datasend>
+and C<dataend> methods described in L<Net::Cmd>.
+
+=item bdat ( DATA )
+
+=item bdatlast ( DATA )
+
+Use the alternate DATA command "BDAT" of the data chunking service extension
+defined in RFC1830 for efficiently sending large MIME messages.
+
+=item expand ( ADDRESS )
+
+Request the server to expand the given address Returns an array
+which contains the text read from the server.
+
+=item verify ( ADDRESS )
+
+Verify that C<ADDRESS> is a legitimate mailing address.
+
+Most sites usually disable this feature in their SMTP service configuration.
+Use "Debug => 1" option under new() to see if disabled.
+
+=item help ( [ $subject ] )
+
+Request help text from the server. Returns the text or undef upon failure
+
+=item quit ()
+
+Send the QUIT command to the remote SMTP server and close the socket connection.
+
+=item can_inet6 ()
+
+Returns whether we can use IPv6.
+
+=item can_ssl ()
+
+Returns whether we can use SSL.
+
+=back
+
+=head1 ADDRESSES
+
+Net::SMTP attempts to DWIM with addresses that are passed. For
+example an application might extract The From: line from an email
+and pass that to mail(). While this may work, it is not recommended.
+The application should really use a module like L<Mail::Address>
+to extract the mail address and pass that.
+
+If C<ExactAddresses> is passed to the constructor, then addresses
+should be a valid rfc2821-quoted address, although Net::SMTP will
+accept the address surrounded by angle brackets.
+
+ funny user@domain WRONG
+ "funny user"@domain RIGHT, recommended
+ <"funny user"@domain> OK
+
+=head1 SEE ALSO
+
+L<Net::Cmd>,
+L<IO::Socket::SSL>
+
+=head1 AUTHOR
+
+Graham Barr E<lt>F<gbarr@pobox.com>E<gt>
+
+Steve Hay E<lt>F<shay@cpan.org>E<gt> is now maintaining libnet as of version
+1.22_02
+
+=head1 COPYRIGHT
+
+Versions up to 2.31_1 Copyright (c) 1995-2004 Graham Barr. All rights reserved.
+Changes in Version 2.31_2 onwards Copyright (C) 2013-2014 Steve Hay. All rights
+reserved.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
@@ -0,0 +1,162 @@
+# Net::Time.pm
+#
+# Versions up to 2.10 Copyright (c) 1995-2004 Graham Barr <gbarr@pobox.com>.
+# All rights reserved.
+# Changes in Version 2.11 onwards Copyright (C) 2014 Steve Hay. All rights
+# reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Net::Time;
+
+use 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.02";
+
+our $TIMEOUT = 120;
+
+sub _socket {
+ my ($pname, $pnum, $host, $proto, $timeout) = @_;
+
+ $proto ||= 'udp';
+
+ my $port = (getservbyname($pname, $proto))[2] || $pnum;
+
+ my $hosts = defined $host ? [$host] : $NetConfig{$pname . '_hosts'};
+
+ my $me;
+
+ foreach my $addr (@$hosts) {
+ $me = IO::Socket::INET->new(
+ PeerAddr => $addr,
+ PeerPort => $port,
+ Proto => $proto
+ )
+ and last;
+ }
+
+ return unless $me;
+
+ $me->send("\n")
+ if $proto eq 'udp';
+
+ $timeout = $TIMEOUT
+ unless defined $timeout;
+
+ IO::Select->new($me)->can_read($timeout)
+ ? $me
+ : undef;
+}
+
+
+sub inet_time {
+ my $s = _socket('time', 37, @_) || return;
+ my $buf = '';
+ my $offset = 0 | 0;
+
+ return
+ unless defined $s->recv($buf, length(pack("N", 0)));
+
+ # unpack, we | 0 to ensure we have an unsigned
+ my $time = (unpack("N", $buf))[0] | 0;
+
+ # the time protocol return time in seconds since 1900, convert
+ # it to a the required format
+
+ if ($^O eq "MacOS") {
+
+ # MacOS return seconds since 1904, 1900 was not a leap year.
+ $offset = (4 * 31536000) | 0;
+ }
+ else {
+
+ # otherwise return seconds since 1972, there were 17 leap years between
+ # 1900 and 1972
+ $offset = (70 * 31536000 + 17 * 86400) | 0;
+ }
+
+ $time - $offset;
+}
+
+
+sub inet_daytime {
+ my $s = _socket('daytime', 13, @_) || return;
+ my $buf = '';
+
+ defined($s->recv($buf, 1024))
+ ? $buf
+ : undef;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Net::Time - time and daytime network client interface
+
+=head1 SYNOPSIS
+
+ use Net::Time qw(inet_time inet_daytime);
+
+ print inet_time(); # use default host from Net::Config
+ print inet_time('localhost');
+ print inet_time('localhost', 'tcp');
+
+ print inet_daytime(); # use default host from Net::Config
+ print inet_daytime('localhost');
+ print inet_daytime('localhost', 'tcp');
+
+=head1 DESCRIPTION
+
+C<Net::Time> provides subroutines that obtain the time on a remote machine.
+
+=over 4
+
+=item inet_time ( [HOST [, PROTOCOL [, TIMEOUT]]])
+
+Obtain the time on C<HOST>, or some default host if C<HOST> is not given
+or not defined, using the protocol as defined in RFC868. The optional
+argument C<PROTOCOL> should define the protocol to use, either C<tcp> or
+C<udp>. The result will be a time value in the same units as returned
+by time() or I<undef> upon failure.
+
+=item inet_daytime ( [HOST [, PROTOCOL [, TIMEOUT]]])
+
+Obtain the time on C<HOST>, or some default host if C<HOST> is not given
+or not defined, using the protocol as defined in RFC867. The optional
+argument C<PROTOCOL> should define the protocol to use, either C<tcp> or
+C<udp>. The result will be an ASCII string or I<undef> upon failure.
+
+=back
+
+=head1 AUTHOR
+
+Graham Barr E<lt>F<gbarr@pobox.com>E<gt>
+
+Steve Hay E<lt>F<shay@cpan.org>E<gt> is now maintaining libnet as of version
+1.22_02
+
+=head1 COPYRIGHT
+
+Versions up to 2.11 Copyright (c) 1995-2004 Graham Barr. All rights reserved.
+Changes in Version 2.11 onwards Copyright (C) 2014 Steve Hay. All rights
+reserved.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
@@ -0,0 +1,302 @@
+=head1 NAME
+
+libnetFAQ - libnet Frequently Asked Questions
+
+=head1 DESCRIPTION
+
+=head2 Where to get this document
+
+This document is distributed with the libnet distribution, and is also
+available on the libnet web page at
+
+ http://search.cpan.org/dist/libnet/
+
+=head2 How to contribute to this document
+
+You may report corrections, additions, and suggestions on the
+CPAN request tracker at
+
+ http://rt.cpan.org/Dist/Display.html?Name=libnet
+
+=head1 Author and Copyright Information
+
+Copyright (c) 1997-1998 Graham Barr. All rights reserved.
+This document is free; you can redistribute it and/or modify it
+under the terms of the Artistic License.
+
+Currently maintained by Steve Hay <shay@cpan.org>.
+
+=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 1.999 or higher is required for SSL support.
+
+IO::Socket::IP version 0.20 or IO::Socket::INET6 version 2.62 is
+required for IPv6 support.
+
+=head2 What machines support libnet ?
+
+libnet itself is an entirely perl-code distribution so it should work
+on any machine that perl runs on.
+
+=head2 Where can I get the latest libnet release
+
+The latest libnet release is always on CPAN, you will find it
+in
+
+ http://search.cpan.org/dist/libnet/
+
+=head1 Using Net::FTP
+
+=head2 How do I download files from an FTP server ?
+
+An example taken from an article posted to comp.lang.perl.misc
+
+ #!/your/path/to/perl
+
+ # a module making life easier
+
+ use Net::FTP;
+
+ # for debugging: $ftp = Net::FTP->new('site','Debug',10);
+ # open a connection and log in!
+
+ $ftp = Net::FTP->new('target_site.somewhere.xxx');
+ $ftp->login('username','password');
+
+ # set transfer mode to binary
+
+ $ftp->binary();
+
+ # change the directory on the ftp site
+
+ $ftp->cwd('/some/path/to/somewhere/');
+
+ foreach $name ('file1', 'file2', 'file3') {
+
+ # get's arguments are in the following order:
+ # ftp server's filename
+ # filename to save the transfer to on the local machine
+ # can be simply used as get($name) if you want the same name
+
+ $ftp->get($name,$name);
+ }
+
+ # ftp done!
+
+ $ftp->quit;
+
+=head2 How do I transfer files in binary mode ?
+
+To transfer files without <LF><CR> translation Net::FTP provides
+the C<binary> method
+
+ $ftp->binary;
+
+=head2 How can I get the size of a file on a remote FTP server ?
+
+=head2 How can I get the modification time of a file on a remote FTP server ?
+
+=head2 How can I change the permissions of a file on a remote server ?
+
+The FTP protocol does not have a command for changing the permissions
+of a file on the remote server. But some ftp servers may allow a chmod
+command to be issued via a SITE command, eg
+
+ $ftp->quot('site chmod 0777',$filename);
+
+But this is not guaranteed to work.
+
+=head2 Can I do a reget operation like the ftp command ?
+
+=head2 How do I get a directory listing from an FTP server ?
+
+=head2 Changing directory to "" does not fail ?
+
+Passing an argument of "" to ->cwd() has the same affect of calling ->cwd()
+without any arguments. Turn on Debug (I<See below>) and you will see what is
+happening
+
+ $ftp = Net::FTP->new($host, Debug => 1);
+ $ftp->login;
+ $ftp->cwd("");
+
+gives
+
+ Net::FTP=GLOB(0x82196d8)>>> CWD /
+ Net::FTP=GLOB(0x82196d8)<<< 250 CWD command successful.
+
+=head2 I am behind a SOCKS firewall, but the Firewall option does not work ?
+
+The Firewall option is only for support of one type of firewall. The type
+supported is an ftp proxy.
+
+To use Net::FTP, or any other module in the libnet distribution,
+through a SOCKS firewall you must create a socks-ified perl executable
+by compiling perl with the socks library.
+
+=head2 I am behind an FTP proxy firewall, but cannot access machines outside ?
+
+Net::FTP implements the most popular ftp proxy firewall approach. The scheme
+implemented is that where you log in to the firewall with C<user@hostname>
+
+I have heard of one other type of firewall which requires a login to the
+firewall with an account, then a second login with C<user@hostname>. You can
+still use Net::FTP to traverse these firewalls, but a more manual approach
+must be taken, eg
+
+ $ftp = Net::FTP->new($firewall) or die $@;
+ $ftp->login($firewall_user, $firewall_passwd) or die $ftp->message;
+ $ftp->login($ext_user . '@' . $ext_host, $ext_passwd) or die $ftp->message.
+
+=head2 My ftp proxy firewall does not listen on port 21
+
+FTP servers usually listen on the same port number, port 21, as any other
+FTP server. But there is no reason why this has to be the case.
+
+If you pass a port number to Net::FTP then it assumes this is the port
+number of the final destination. By default Net::FTP will always try
+to connect to the firewall on port 21.
+
+Net::FTP uses IO::Socket to open the connection and IO::Socket allows
+the port number to be specified as part of the hostname. So this problem
+can be resolved by either passing a Firewall option like C<"hostname:1234">
+or by setting the C<ftp_firewall> option in Net::Config to be a string
+in the same form.
+
+=head2 Is it possible to change the file permissions of a file on an FTP server ?
+
+The answer to this is "maybe". The FTP protocol does not specify a command to change
+file permissions on a remote host. However many servers do allow you to run the
+chmod command via the C<SITE> command. This can be done with
+
+ $ftp->site('chmod','0775',$file);
+
+=head2 I have seen scripts call a method message, but cannot find it documented ?
+
+Net::FTP, like several other packages in libnet, inherits from Net::Cmd, so
+all the methods described in Net::Cmd are also available on Net::FTP
+objects.
+
+=head2 Why does Net::FTP not implement mput and mget methods
+
+The quick answer is because they are easy to implement yourself. The long
+answer is that to write these in such a way that multiple platforms are
+supported correctly would just require too much code. Below are
+some examples how you can implement these yourself.
+
+sub mput {
+ my($ftp,$pattern) = @_;
+ foreach my $file (glob($pattern)) {
+ $ftp->put($file) or warn $ftp->message;
+ }
+}
+
+sub mget {
+ my($ftp,$pattern) = @_;
+ foreach my $file ($ftp->ls($pattern)) {
+ $ftp->get($file) or warn $ftp->message;
+ }
+}
+
+
+=head1 Using Net::SMTP
+
+=head2 Why can't the part of an Email address after the @ be used as the hostname ?
+
+The part of an Email address which follows the @ is not necessarily a hostname,
+it is a mail domain. To find the name of a host to connect for a mail domain
+you need to do a DNS MX lookup
+
+=head2 Why does Net::SMTP not do DNS MX lookups ?
+
+Net::SMTP implements the SMTP protocol. The DNS MX lookup is not part
+of this protocol.
+
+=head2 The verify method always returns true ?
+
+Well it may seem that way, but it does not. The verify method returns true
+if the command succeeded. If you pass verify an address which the
+server would normally have to forward to another machine, the command
+will succeed with something like
+
+ 252 Couldn't verify <someone@there> but will attempt delivery anyway
+
+This command will fail only if you pass it an address in a domain
+the server directly delivers for, and that address does not exist.
+
+=head1 Debugging scripts
+
+=head2 How can I debug my scripts that use Net::* modules ?
+
+Most of the libnet client classes allow options to be passed to the
+constructor, in most cases one option is called C<Debug>. Passing
+this option with a non-zero value will turn on a protocol trace, which
+will be sent to STDERR. This trace can be useful to see what commands
+are being sent to the remote server and what responses are being
+received back.
+
+ #!/your/path/to/perl
+
+ use Net::FTP;
+
+ my $ftp = new Net::FTP($host, Debug => 1);
+ $ftp->login('gbarr','password');
+ $ftp->quit;
+
+this script would output something like
+
+ Net::FTP: Net::FTP(2.22)
+ Net::FTP: Exporter
+ Net::FTP: Net::Cmd(2.0801)
+ Net::FTP: IO::Socket::INET
+ Net::FTP: IO::Socket(1.1603)
+ Net::FTP: IO::Handle(1.1504)
+
+ Net::FTP=GLOB(0x8152974)<<< 220 imagine FTP server (Version wu-2.4(5) Tue Jul 29 11:17:18 CDT 1997) ready.
+ Net::FTP=GLOB(0x8152974)>>> user gbarr
+ Net::FTP=GLOB(0x8152974)<<< 331 Password required for gbarr.
+ Net::FTP=GLOB(0x8152974)>>> PASS ....
+ Net::FTP=GLOB(0x8152974)<<< 230 User gbarr logged in. Access restrictions apply.
+ Net::FTP=GLOB(0x8152974)>>> QUIT
+ Net::FTP=GLOB(0x8152974)<<< 221 Goodbye.
+
+The first few lines tell you the modules that Net::FTP uses and their versions,
+this is useful data to me when a user reports a bug. The last seven lines
+show the communication with the server. Each line has three parts. The first
+part is the object itself, this is useful for separating the output
+if you are using multiple objects. The second part is either C<<<<<> to
+show data coming from the server or C<>>>>> to show data
+going to the server. The remainder of the line is the command
+being sent or response being received.
+
+=head1 AUTHOR AND COPYRIGHT
+
+Copyright (c) 1997 Graham Barr.
+All rights reserved.
+
@@ -1,16 +1,17 @@
-#!./perl -w
+#!perl
+
+use 5.008001;
+
+use strict;
+use warnings;
BEGIN {
- if ($ENV{PERL_CORE}) {
- chdir 't' if -d 't';
- @INC = '../lib';
- }
- if (!eval "require Socket") {
+ if (!eval { require Socket; 1 }) {
print "1..0 # no Socket\n"; exit 0;
}
undef *{Socket::inet_aton};
undef *{Socket::inet_ntoa};
- if (ord('A') == 193 && !eval "require Convert::EBCDIC") {
+ if (ord('A') == 193 && !eval { require Convert::EBCDIC; 1 }) {
print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0;
}
$INC{'Socket.pm'} = 1;
@@ -20,7 +21,7 @@ package Socket;
sub import {
my $pkg = caller();
- no strict 'refs';
+ no strict 'refs'; ## no critic (TestingAndDebugging::ProhibitNoStrict)
*{ $pkg . '::inet_aton' } = \&inet_aton;
*{ $pkg . '::inet_ntoa' } = \&inet_ntoa;
}
@@ -0,0 +1,46 @@
+#!perl
+#===============================================================================
+#
+# t/critic.t
+#
+# DESCRIPTION
+# Test script to check Perl::Critic conformance.
+#
+# COPYRIGHT
+# Copyright (C) 2014 Steve Hay. All rights reserved.
+#
+# LICENCE
+# You may distribute under the terms of either the GNU General Public License
+# or the Artistic License, as specified in the LICENCE file.
+#
+#===============================================================================
+
+use 5.008001;
+
+use strict;
+use warnings;
+
+use Test::More;
+
+#===============================================================================
+# MAIN PROGRAM
+#===============================================================================
+
+MAIN: {
+ plan skip_all => 'Author testing only' unless $ENV{AUTHOR_TESTING};
+
+ my $ok = eval {
+ require Test::Perl::Critic;
+ Test::Perl::Critic->import(-profile => '');
+ 1;
+ };
+
+ if (not $ok) {
+ plan skip_all => 'Test::Perl::Critic required to test with Perl::Critic';
+ }
+ else {
+ all_critic_ok('.');
+ }
+}
+
+#===============================================================================
@@ -1,14 +1,15 @@
-#!./perl -w
+#!perl
+
+use 5.008001;
+
+use strict;
+use warnings;
BEGIN {
- if ($ENV{PERL_CORE}) {
- chdir 't' if -d 't';
- @INC = '../lib';
- }
- if (!eval "require Socket") {
+ if (!eval { require Socket; 1 }) {
print "1..0 # no Socket\n"; exit 0;
}
- if (ord('A') == 193 && !eval "require Convert::EBCDIC") {
+ if (ord('A') == 193 && !eval { require Convert::EBCDIC; 1 }) {
print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0;
}
}
@@ -18,7 +19,7 @@ BEGIN {
use IO::File;
use Net::Cmd;
- @ISA = qw(Net::Cmd IO::File);
+ our @ISA = qw(Net::Cmd IO::File);
sub timeout { 0 }
@@ -0,0 +1,173 @@
+#!perl
+
+use 5.008001;
+
+use strict;
+use warnings;
+
+use Net::FTP;
+use Test::More;
+use File::Temp;
+use IO::Socket::INET;
+
+my $server = 'test.rebex.net';
+my $debug = 0;
+
+plan skip_all => "no SSL support" if ! Net::FTP->can_ssl;
+require IO::Socket::SSL;
+
+
+# first try to connect w/o ftp
+# plain
+diag( "connect inet to $server:21" );
+IO::Socket::INET->new( "$server:21" ) or do {
+ plan skip_all => "$server:21 not reachable";
+};
+
+# ssl to the right host
+diag( "connect inet to $server:990" );
+my $sock = IO::Socket::INET->new( "$server:990") or do {
+ plan skip_all => "$server:990 not reachable";
+};
+
+# now we need CAs
+my $cafh = File::Temp->new( UNLINK => 0, SUFFIX => '.crt' );
+my %sslargs = ( SSL_ca_file => $cafh->filename );
+print $cafh <DATA>;
+close($cafh);
+
+diag( "upgrade to ssl $server:990" );
+IO::Socket::SSL->start_SSL($sock,
+ SSL_verify_mode => 1,
+ SSL_verifycn_name => $server,
+ SSL_verifycn_scheme => 'ftp',
+ %sslargs,
+) or do {
+ plan skip_all => "$server:990 not upgradable to SSL: ".
+ $IO::Socket::SSL::SSL_ERROR;
+};
+
+plan tests => 9;
+
+# first direct SSL
+diag( "connect ftp over ssl to $server" );
+my $ftp = Net::FTP->new($server,
+ SSL => 1,
+ %sslargs,
+ Debug => $debug,
+ Passive => 1,
+);
+ok($ftp,"ftp ssl connect $server");
+$ftp->login("anonymous",'net-sslglue-ftp@test.perl')
+ or die "login to $server failed";
+diag("logged in");
+# check that we can talk on connection
+ok(~~$ftp->ls,"directory listing protected");
+$ftp->prot('C');
+ok(~~$ftp->ls,"directory listing clear");
+
+# then TLS upgrade inside plain connection
+$ftp = Net::FTP->new($server,
+ Passive => 1,
+ Debug => $debug,
+ %sslargs
+);
+ok($ftp,"ftp plain connect $server");
+my $ok = $ftp->starttls;
+ok($ok,"ssl upgrade");
+$ftp->login("anonymous",'net-sslglue-ftp@test.perl')
+ or die "login to $server failed";
+diag("logged in");
+# check that we can talk on connection
+ok(~~$ftp->ls,"directory listing protected");
+$ftp->prot('C');
+ok(~~$ftp->ls,"directory listing clear");
+$ok = $ftp->stoptls;
+ok($ok,"ssl downgrade");
+ok(~~$ftp->ls,"directory listing after downgrade");
+
+
+__DATA__
+# Subject: C=IL, O=StartCom Ltd., OU=Secure Digital Certificate Signing, CN=StartCom Class 2 Primary Intermediate Server CA
+# Issuer: C=IL, O=StartCom Ltd., OU=Secure Digital Certificate Signing, CN=StartCom Certification Authority
+-----BEGIN CERTIFICATE-----
+MIIGNDCCBBygAwIBAgIBGjANBgkqhkiG9w0BAQUFADB9MQswCQYDVQQGEwJJTDEW
+MBQGA1UEChMNU3RhcnRDb20gTHRkLjErMCkGA1UECxMiU2VjdXJlIERpZ2l0YWwg
+Q2VydGlmaWNhdGUgU2lnbmluZzEpMCcGA1UEAxMgU3RhcnRDb20gQ2VydGlmaWNh
+dGlvbiBBdXRob3JpdHkwHhcNMDcxMDI0MjA1NzA5WhcNMTcxMDI0MjA1NzA5WjCB
+jDELMAkGA1UEBhMCSUwxFjAUBgNVBAoTDVN0YXJ0Q29tIEx0ZC4xKzApBgNVBAsT
+IlNlY3VyZSBEaWdpdGFsIENlcnRpZmljYXRlIFNpZ25pbmcxODA2BgNVBAMTL1N0
+YXJ0Q29tIENsYXNzIDIgUHJpbWFyeSBJbnRlcm1lZGlhdGUgU2VydmVyIENBMIIB
+IjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEA4k85L6GMmoWtCA4IPlfyiAEh
+G5SpbOK426oZGEY6UqH1D/RujOqWjJaHeRNAUS8i8gyLhw9l33F0NENVsTUJm9m8
+H/rrQtCXQHK3Q5Y9upadXVACHJuRjZzArNe7LxfXyz6CnXPrB0KSss1ks3RVG7RL
+hiEs93iHMuAW5Nq9TJXqpAp+tgoNLorPVavD5d1Bik7mb2VsskDPF125w2oLJxGE
+d2H2wnztwI14FBiZgZl1Y7foU9O6YekO+qIw80aiuckfbIBaQKwn7UhHM7BUxkYa
+8zVhwQIpkFR+ZE3EMFICgtffziFuGJHXuKuMJxe18KMBL47SLoc6PbQpZ4rEAwID
+AQABo4IBrTCCAakwDwYDVR0TAQH/BAUwAwEB/zAOBgNVHQ8BAf8EBAMCAQYwHQYD
+VR0OBBYEFBHbI0X9VMxqcW+EigPXvvcBLyaGMB8GA1UdIwQYMBaAFE4L7xqkQFul
+F2mHMMo0aEPQQa7yMGYGCCsGAQUFBwEBBFowWDAnBggrBgEFBQcwAYYbaHR0cDov
+L29jc3Auc3RhcnRzc2wuY29tL2NhMC0GCCsGAQUFBzAChiFodHRwOi8vd3d3LnN0
+YXJ0c3NsLmNvbS9zZnNjYS5jcnQwWwYDVR0fBFQwUjAnoCWgI4YhaHR0cDovL3d3
+dy5zdGFydHNzbC5jb20vc2ZzY2EuY3JsMCegJaAjhiFodHRwOi8vY3JsLnN0YXJ0
+c3NsLmNvbS9zZnNjYS5jcmwwgYAGA1UdIAR5MHcwdQYLKwYBBAGBtTcBAgEwZjAu
+BggrBgEFBQcCARYiaHR0cDovL3d3dy5zdGFydHNzbC5jb20vcG9saWN5LnBkZjA0
+BggrBgEFBQcCARYoaHR0cDovL3d3dy5zdGFydHNzbC5jb20vaW50ZXJtZWRpYXRl
+LnBkZjANBgkqhkiG9w0BAQUFAAOCAgEAnQfh7pB2MWcWRXCMy4SLS1doRKWJwfJ+
+yyiL9edwd9W29AshYKWhdHMkIoDW2LqNomJdCTVCKfs5Y0ULpLA4Gmj0lRPM4EOU
+7Os5GuxXKdmZbfWEzY5zrsncavqenRZkkwjHHMKJVJ53gJD2uSl26xNnSFn4Ljox
+uMnTiOVfTtIZPUOO15L/zzi24VuKUx3OrLR2L9j3QGPV7mnzRX2gYsFhw3XtsntN
+rCEnME5ZRmqTF8rIOS0Bc2Vb6UGbERecyMhK76F2YC2uk/8M1TMTn08Tzt2G8fz4
+NVQVqFvnhX76Nwn/i7gxSZ4Nbt600hItuO3Iw/G2QqBMl3nf/sOjn6H0bSyEd6Si
+BeEX/zHdmvO4esNSwhERt1Axin/M51qJzPeGmmGSTy+UtpjHeOBiS0N9PN7WmrQQ
+oUCcSyrcuNDUnv3xhHgbDlePaVRCaHvqoO91DweijHOZq1X1BwnSrzgDapADDC+P
+4uhDwjHpb62H5Y29TiyJS1HmnExUdsASgVOb7KD8LJzaGJVuHjgmQid4YAjff20y
+6NjAbx/rJnWfk/x7G/41kNxTowemP4NVCitOYoIlzmYwXSzg+RkbdbmdmFamgyd6
+0Y+NWZP8P3PXLrQsldiL98l+x/ydrHIEH9LMF/TtNGCbnkqXBP7dcg5XVFEGcE3v
+qhykguAzx/Q=
+-----END CERTIFICATE-----
+# Subject: C=IL, O=StartCom Ltd., OU=Secure Digital Certificate Signing, CN=StartCom Certification Authority
+# Issuer: C=IL, O=StartCom Ltd., OU=Secure Digital Certificate Signing, CN=StartCom Certification Authority
+-----BEGIN CERTIFICATE-----
+MIIHhzCCBW+gAwIBAgIBLTANBgkqhkiG9w0BAQsFADB9MQswCQYDVQQGEwJJTDEW
+MBQGA1UEChMNU3RhcnRDb20gTHRkLjErMCkGA1UECxMiU2VjdXJlIERpZ2l0YWwg
+Q2VydGlmaWNhdGUgU2lnbmluZzEpMCcGA1UEAxMgU3RhcnRDb20gQ2VydGlmaWNh
+dGlvbiBBdXRob3JpdHkwHhcNMDYwOTE3MTk0NjM3WhcNMzYwOTE3MTk0NjM2WjB9
+MQswCQYDVQQGEwJJTDEWMBQGA1UEChMNU3RhcnRDb20gTHRkLjErMCkGA1UECxMi
+U2VjdXJlIERpZ2l0YWwgQ2VydGlmaWNhdGUgU2lnbmluZzEpMCcGA1UEAxMgU3Rh
+cnRDb20gQ2VydGlmaWNhdGlvbiBBdXRob3JpdHkwggIiMA0GCSqGSIb3DQEBAQUA
+A4ICDwAwggIKAoICAQDBiNsJvGxGfHiflXu1M5DycmLWwTYgIiRezul38kMKogZk
+pMyONvg45iPwbm2xPN1yo4UcodM9tDMr0y+v/uqwQVlntsQGfQqedIXWeUyAN3rf
+OQVSWff0G0ZDpNKFhdLDcfN1YjS6LIp/Ho/u7TTQEceWzVI9ujPW3U3eCztKS5/C
+Ji/6tRYccjV3yjxd5srhJosaNnZcAdt0FCX+7bWgiA/deMotHweXMAEtcnn6RtYT
+Kqi5pquDSR3l8u/d5AGOGAqPY1MWhWKpDhk6zLVmpsJrdAfkK+F2PrRt2PZE4XNi
+HzvEvqBTViVsUQn3qqvKv3b9bZvzndu/PWa8DFaqr5hIlTpL36dYUNk4dalb6kMM
+Av+Z6+hsTXBbKWWc3apdzK8BMewM69KN6Oqce+Zu9ydmDBpI125C4z/eIT574Q1w
++2OqqGwaVLRcJXrJosmLFqa7LH4XXgVNWG4SHQHuEhANxjJ/GP/89PrNbpHoNkm+
+Gkhpi8KWTRoSsmkXwQqQ1vp5Iki/untp+HDH+no32NgN0nZPV/+Qt+OR0t3vwmC3
+Zzrd/qqc8NSLf3Iizsafl7b4r4qgEKjZ+xjGtrVcUjyJthkqcwEKDwOzEmDyei+B
+26Nu/yYwl/WL3YlXtq09s68rxbd2AvCl1iuahhQqcvbjM4xdCUsT37uMdBNSSwID
+AQABo4ICEDCCAgwwDwYDVR0TAQH/BAUwAwEB/zAOBgNVHQ8BAf8EBAMCAQYwHQYD
+VR0OBBYEFE4L7xqkQFulF2mHMMo0aEPQQa7yMB8GA1UdIwQYMBaAFE4L7xqkQFul
+F2mHMMo0aEPQQa7yMIIBWgYDVR0gBIIBUTCCAU0wggFJBgsrBgEEAYG1NwEBATCC
+ATgwLgYIKwYBBQUHAgEWImh0dHA6Ly93d3cuc3RhcnRzc2wuY29tL3BvbGljeS5w
+ZGYwNAYIKwYBBQUHAgEWKGh0dHA6Ly93d3cuc3RhcnRzc2wuY29tL2ludGVybWVk
+aWF0ZS5wZGYwgc8GCCsGAQUFBwICMIHCMCcWIFN0YXJ0IENvbW1lcmNpYWwgKFN0
+YXJ0Q29tKSBMdGQuMAMCAQEagZZMaW1pdGVkIExpYWJpbGl0eSwgcmVhZCB0aGUg
+c2VjdGlvbiAqTGVnYWwgTGltaXRhdGlvbnMqIG9mIHRoZSBTdGFydENvbSBDZXJ0
+aWZpY2F0aW9uIEF1dGhvcml0eSBQb2xpY3kgYXZhaWxhYmxlIGF0IGh0dHA6Ly93
+d3cuc3RhcnRzc2wuY29tL3BvbGljeS5wZGYwEQYJYIZIAYb4QgEBBAQDAgAHMDgG
+CWCGSAGG+EIBDQQrFilTdGFydENvbSBGcmVlIFNTTCBDZXJ0aWZpY2F0aW9uIEF1
+dGhvcml0eTANBgkqhkiG9w0BAQsFAAOCAgEAjo/n3JR5fPGFf59Jb2vKXfuM/gTF
+wWLRfUKKvFO3lANmMD+x5wqnUCBVJX92ehQN6wQOQOY+2IirByeDqXWmN3PH/UvS
+Ta0XQMhGvjt/UfzDtgUx3M2FIk5xt/JxXrAaxrqTi3iSSoX4eA+D/i+tLPfkpLst
+0OcNOrg+zvZ49q5HJMqjNTbOx8aHmNrs++myziebiMMEofYLWWivydsQD032ZGNc
+pRJvkrKTlMeIFw6Ttn5ii5B/q06f/ON1FE8qMt9bDeD1e5MNq6HPh+GlBEXoPBKl
+CcWw0bdT82AUuoVpaiF8H3VhFyAXe2w7QSlc4axa0c2Mm+tgHRns9+Ww2vl5GKVF
+P0lDV9LdJNUso/2RjSe15esUBppMeyG7Oq0wBhjA2MFrLH9ZXF2RsXAiV+uKa0hK
+1Q8p7MZAwC+ITGgBF3f0JBlPvfrhsiAhS90a2Cl9qrjeVOwhVYBsHvUwyKMQ5bLm
+KhQxw4UtjJixhlpPiVktucf3HMiKf8CdBUrmQk9io20ppB+Fq9vlgcitKj1MXVuE
+JnHEhV5xJMqlG2zYYdMa4FTbzrqpMrUi9nNBCV24F10OD5mQ1kfabwo6YigUZ4LZ
+8dCAWZvLMdibD4x3TrVoivJs9iQOLWxwxXPR3hTQcY+203sC9uO41Alua551hDnm
+fyWl8kgAwKQB2j8=
+-----END CERTIFICATE-----
@@ -0,0 +1,58 @@
+#!perl
+
+use 5.008001;
+
+use strict;
+use warnings;
+
+use Net::POP3;
+use Test::More;
+
+my $host = 'pop.gmx.net';
+my $debug = 0;
+
+plan skip_all => "no SSL support" if ! Net::POP3->can_ssl;
+{
+no warnings 'once';
+plan skip_all => "no verified SSL connection to $host:995 - $@" if ! eval {
+ IO::Socket::SSL->new(PeerAddr => "$host:995", Timeout => 10)
+ || die($IO::Socket::SSL::SSL_ERROR||$!);
+};
+}
+
+plan tests => 2;
+
+SKIP: {
+ diag( "connect inet to $host:110" );
+ skip "no inet connect to $host:110",1
+ if ! IO::Socket::INET->new(PeerAddr => "$host:110", Timeout => 10);
+ my $pop3 = Net::POP3->new($host, Debug => $debug, Timeout => 10)
+ or skip "normal POP3 failed: $@",1;
+ skip "no STARTTLS support",1 if $pop3->message !~/STARTTLS/;
+
+ if (!$pop3->starttls) {
+ fail("starttls failed: ".$pop3->code." $@")
+ } else {
+ # we now should have access to SSL stuff
+ my $cipher = eval { $pop3->get_cipher };
+ if (!$cipher) {
+ fail("after starttls: not an SSL object");
+ } elsif ( $pop3->quit ) {
+ pass("starttls + quit ok, cipher=$cipher");
+ } else {
+ fail("quit after starttls failed: ".$pop3->code);
+ }
+ }
+}
+
+
+my $pop3 = Net::POP3->new($host, SSL => 1, Timeout => 10, Debug => $debug);
+# we now should have access to SSL stuff
+my $cipher = eval { $pop3->get_cipher };
+if (!$cipher) {
+ fail("after ssl connect: not an SSL object");
+} elsif ( $pop3->quit ) {
+ pass("ssl connect ok, cipher=$cipher");
+} else {
+ fail("quit after direct ssl failed: ".$pop3->code);
+}
@@ -0,0 +1,57 @@
+#!perl
+
+use 5.008001;
+
+use strict;
+use warnings;
+
+use Net::SMTP;
+use Test::More;
+
+my $host = 'mail.gmx.net';
+my $debug = 0;
+
+plan skip_all => "no SSL support" if ! Net::SMTP->can_ssl;
+{
+no warnings 'once';
+plan skip_all => "no verified SSL connection to $host:465 - $@" if ! eval {
+ IO::Socket::SSL->new("$host:465")
+ || die($IO::Socket::SSL::SSL_ERROR||$!);
+};
+}
+
+plan tests => 2;
+
+SKIP: {
+ diag( "connect inet to $host:25" );
+ skip "no inet connect to $host:25",1 if ! IO::Socket::INET->new("$host:25");
+ my $smtp = Net::SMTP->new($host, Debug => $debug)
+ or skip "normal SMTP failed: $@",1;
+ skip "no STARTTLS support",1 if $smtp->message !~/STARTTLS/;
+
+ if (!$smtp->starttls) {
+ fail("starttls failed: ".$smtp->code." $@")
+ } else {
+ # we now should have access to SSL stuff
+ my $cipher = eval { $smtp->get_cipher };
+ if (!$cipher) {
+ fail("after starttls: not an SSL object");
+ } elsif ( $smtp->quit ) {
+ pass("starttls + quit ok, cipher=$cipher");
+ } else {
+ fail("quit after starttls failed: ".$smtp->code);
+ }
+ }
+}
+
+
+my $smtp = Net::SMTP->new($host, SSL => 1, Debug => $debug);
+# we now should have access to SSL stuff
+my $cipher = eval { $smtp->get_cipher };
+if (!$cipher) {
+ fail("after ssl connect: not an SSL object");
+} elsif ( $smtp->quit ) {
+ pass("ssl connect ok, cipher=$cipher");
+} else {
+ fail("quit after direct ssl failed: ".$smtp->code);
+}
@@ -1,14 +1,15 @@
-#!./perl -w
+#!perl
+
+use 5.008001;
+
+use strict;
+use warnings;
BEGIN {
- unless (-d 'blib') {
- chdir 't' if -d 't';
- @INC = '../lib';
- }
- if (!eval "require Socket") {
+ if (!eval { require Socket; 1 }) {
print "1..0 # Skip: no Socket module\n"; exit 0;
}
- if (ord('A') == 193 && !eval "require Convert::EBCDIC") {
+ if (ord('A') == 193 && !eval { require Convert::EBCDIC; 1 }) {
print "1..0 # Skip: EBCDIC but no Convert::EBCDIC\n"; exit 0;
}
}
@@ -29,7 +30,7 @@ unless($NetConfig{test_hosts}) {
my $t = 1;
print "1..7\n";
-$ftp = Net::FTP->new($NetConfig{ftp_testhost})
+my $ftp = Net::FTP->new($NetConfig{ftp_testhost})
or (print("not ok 1\n"), exit);
printf "ok %d\n",$t++;
@@ -49,12 +50,14 @@ $ftp->cwd('/pub') or do {
print "not ";
};
+my $data;
if ($data = $ftp->stor('libnet.tst')) {
my $text = "abc\ndef\nqwe\n";
printf "ok %d\n",$t++;
$data->write($text,length $text);
$data->close;
$data = $ftp->retr('libnet.tst');
+ my $buf;
$data->read($buf,length $text);
$data->close;
print "not " unless $text eq $buf;
@@ -1,14 +1,15 @@
-#!./perl -w
+#!perl
+
+use 5.008001;
+
+use strict;
+use warnings;
BEGIN {
- unless (-d 'blib') {
- chdir 't' if -d 't';
- @INC = '../lib';
- }
- if (!eval "require Socket") {
+ if (!eval { require Socket; 1 }) {
print "1..0 # no Socket\n"; exit 0;
}
- if (ord('A') == 193 && !eval "require Convert::EBCDIC") {
+ if (ord('A') == 193 && !eval { require Convert::EBCDIC; 1 }) {
print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0;
}
}
@@ -23,7 +24,7 @@ unless($NetConfig{test_hosts}) {
print "1..5\n";
-$domain = domainname();
+my $domain = domainname();
if(defined $domain && $domain ne "") {
print "ok 1 - defined, non-empty domainname\n";
@@ -52,7 +53,7 @@ my @dummy = grep { defined hostname() and hostname() eq $_ } @domain;
: print "not ok 3\n";
my $name = hostname();
-my $domain = hostdomain();
+$domain = hostdomain();
if(defined $domain && defined $name && $name ne "" && $domain ne "") {
hostfqdn() eq $name . "." . $domain ? print "ok 4\n" : print "not ok 4\n";
domainname() eq $name . "." . $domain ? print "ok 5\n" : print "not ok 5\n";} else {
@@ -1,3 +1,7 @@
+use 5.008001;
+
+use strict;
+use warnings;
my $number = 0;
sub ok {
@@ -1,20 +1,19 @@
-#!./perl
+#!perl
+
+use 5.008001;
+
+use strict;
+use warnings;
BEGIN {
- if ($ENV{PERL_CORE}) {
- chdir 't' if -d 't';
- @INC = '../lib';
- }
- if (!eval "require Socket") {
+ if (!eval { require Socket; 1 }) {
print "1..0 # no Socket\n"; exit 0;
}
- if (ord('A') == 193 && !eval "require Convert::EBCDIC") {
+ if (ord('A') == 193 && !eval { require Convert::EBCDIC; 1 }) {
print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0;
}
}
-use strict;
-
use Cwd;
print "1..20\n";
@@ -48,7 +47,7 @@ $Net::Netrc::TESTING=$Net::Netrc::TESTING=1;
SKIP: {
skip('incompatible stat() handling for OS', 4), next SKIP
- if ($^O =~ /os2|win32|macos|cygwin/i or $] < 5.005);
+ if $^O =~ /os2|win32|macos|cygwin/i;
my $warn;
local $SIG{__WARN__} = sub {
@@ -56,8 +55,8 @@ SKIP: {
};
# add write access for group/other
- $stat[2] = 077;
- ok( !defined(Net::Netrc::_readrc()),
+ $stat[2] = 077; ## no critic (ValuesAndExpressions::ProhibitLeadingZeros)
+ ok( !defined(Net::Netrc->_readrc()),
'_readrc() should not read world-writable file' );
ok( scalar($warn =~ /^Bad permissions:/),
'... and should warn about it' );
@@ -66,7 +65,7 @@ SKIP: {
$stat[2] = 0;
if ($<) {
- ok( !defined(Net::Netrc::_readrc()),
+ ok( !defined(Net::Netrc->_readrc()),
'_readrc() should not read file owned by someone else' );
ok( scalar($warn =~ /^Not owner:/),
'... and should warn about it' );
@@ -93,7 +92,7 @@ macdef
LINES
# having set several lines and the uid, this should succeed
-is( Net::Netrc::_readrc(), 1, '_readrc() should succeed now' );
+is( Net::Netrc->_readrc(), 1, '_readrc() should succeed now' );
# on 'foo', the login is 'nigol'
is( Net::Netrc->lookup('foo')->{login}, 'nigol',
@@ -1,14 +1,15 @@
-#!./perl -w
+#!perl
+
+use 5.008001;
+
+use strict;
+use warnings;
BEGIN {
- unless (-d 'blib') {
- chdir 't' if -d 't';
- @INC = '../lib';
- }
- if (!eval "require Socket") {
+ if (!eval { require Socket; 1 }) {
print "1..0 # no Socket\n"; exit 0;
}
- if (ord('A') == 193 && !eval "require Convert::EBCDIC") {
+ if (ord('A') == 193 && !eval { require Convert::EBCDIC; 1 }) {
print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0;
}
}
@@ -26,13 +27,13 @@ print "1..4\n";
my $i = 1;
-$nntp = Net::NNTP->new(Debug => 0)
+my $nntp = Net::NNTP->new(Debug => 0)
or (print("not ok 1\n"), exit);
print "ok 1\n";
-my $grp;
-foreach $grp (qw(test alt.test control news.announce.newusers)) {
+my @grp;
+foreach my $grp (qw(test alt.test control news.announce.newusers)) {
@grp = $nntp->group($grp);
last if @grp;
}
@@ -0,0 +1,66 @@
+#!perl
+
+use 5.008001;
+
+use strict;
+use warnings;
+
+use Config;
+use File::Temp 'tempfile';
+use Net::NNTP;
+use Test::More;
+
+my $debug = 0; # Net::NNTP->new( Debug => .. )
+
+my $inet6class = Net::NNTP->can_inet6;
+plan skip_all => "no IPv6 support found in Net::NNTP" if ! $inet6class;
+
+plan skip_all => "fork not supported on this platform"
+ unless $Config::Config{d_fork} || $Config::Config{d_pseudofork} ||
+ (($^O eq 'MSWin32' || $^O eq 'NetWare') and
+ $Config::Config{useithreads} and
+ $Config::Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/);
+
+my $srv = $inet6class->new(
+ LocalAddr => '::1',
+ Listen => 10
+);
+plan skip_all => "cannot create listener on ::1: $!" if ! $srv;
+my $host = $srv->sockhost;
+my $port = $srv->sockport;
+diag("server on $host port $port");
+
+plan tests => 1;
+
+defined( my $pid = fork()) or die "fork failed: $!";
+exit(nntp_server()) if ! $pid;
+
+my $cl = Net::NNTP->new(Host => $host, Port => $port,, Debug => $debug);
+diag("created Net::NNTP object");
+if (!$cl) {
+ fail("IPv6 NNTP connect failed");
+} else {
+ $cl->quit;
+ pass("IPv6 success");
+}
+wait;
+
+sub nntp_server {
+ my $ssl = shift;
+ my $cl = $srv->accept or die "accept failed: $!";
+ print $cl "200 nntp.example.com\r\n";
+ while (<$cl>) {
+ my ($cmd,$arg) = m{^(\S+)(?: +(.*))?\r\n} or die $_;
+ $cmd = uc($cmd);
+ if ($cmd eq 'QUIT' ) {
+ print $cl "205 bye\r\n";
+ last;
+ } elsif ( $cmd eq 'MODE' ) {
+ print $cl "201 Posting denied\r\n";
+ } else {
+ diag("received unknown command: $cmd");
+ print "500 unknown cmd\r\n";
+ }
+ }
+ diag("NNTP dialog done");
+}
@@ -0,0 +1,131 @@
+#!perl
+
+use 5.008001;
+
+use strict;
+use warnings;
+
+use Config;
+use File::Temp 'tempfile';
+use Net::NNTP;
+use Test::More;
+
+my $debug = 0; # Net::NNTP Debug => ..
+
+my $parent = 0;
+
+plan skip_all => "no SSL support found in Net::NNTP" if ! Net::NNTP->can_ssl;
+
+plan skip_all => "fork not supported on this platform"
+ unless $Config::Config{d_fork} || $Config::Config{d_pseudofork} ||
+ (($^O eq 'MSWin32' || $^O eq 'NetWare') and
+ $Config::Config{useithreads} and
+ $Config::Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/);
+
+plan skip_all => "incomplete or version of IO::Socket::SSL"
+ if ! eval { require IO::Socket::SSL::Utils };
+
+my $srv = IO::Socket::INET->new(
+ LocalAddr => '127.0.0.1',
+ Listen => 10
+);
+plan skip_all => "cannot create listener on localhost: $!" if ! $srv;
+my $host = $srv->sockhost;
+my $port = $srv->sockport;
+
+plan tests => 2;
+
+my ($ca,$key) = IO::Socket::SSL::Utils::CERT_create( CA => 1 );
+my ($fh,$cafile) = tempfile();
+print $fh IO::Socket::SSL::Utils::PEM_cert2string($ca);
+close($fh);
+
+$parent = $$;
+END { unlink($cafile) if $$ == $parent }
+
+my ($cert) = IO::Socket::SSL::Utils::CERT_create(
+ subject => { CN => 'nntp.example.com' },
+ issuer_cert => $ca, issuer_key => $key,
+ key => $key
+);
+
+test(1); # direct ssl
+test(0); # starttls
+
+
+sub test {
+ my $ssl = shift;
+ defined( my $pid = fork()) or die "fork failed: $!";
+ exit(nntp_server($ssl)) if ! $pid;
+ nntp_client($ssl);
+ wait;
+}
+
+
+sub nntp_client {
+ my $ssl = shift;
+ my %sslopt = (
+ SSL_verifycn_name => 'nntp.example.com',
+ SSL_ca_file => $cafile
+ );
+ $sslopt{SSL} = 1 if $ssl;
+ my $cl = Net::NNTP->new(
+ Host => $host,
+ Port => $port,
+ Debug => $debug,
+ %sslopt,
+ );
+ diag("created Net::NNTP object");
+ if (!$cl) {
+ fail( ($ssl ? "SSL ":"" )."NNTP connect failed");
+ } elsif ($ssl) {
+ $cl->quit;
+ pass("SSL NNTP connect success");
+ } elsif ( ! $cl->starttls ) {
+ no warnings 'once';
+ fail("starttls failed: $IO::Socket::SSL::SSL_ERROR");
+ } else {
+ $cl->quit;
+ pass("starttls success");
+ }
+}
+
+sub nntp_server {
+ my $ssl = shift;
+ my $cl = $srv->accept or die "accept failed: $!";
+ my %sslargs = (
+ SSL_server => 1,
+ SSL_cert => $cert,
+ SSL_key => $key,
+ );
+ if ( $ssl ) {
+ if ( ! IO::Socket::SSL->start_SSL($cl, %sslargs)) {
+ diag("initial ssl handshake with client failed");
+ return;
+ }
+ }
+
+ print $cl "200 nntp.example.com\r\n";
+ while (<$cl>) {
+ my ($cmd,$arg) = m{^(\S+)(?: +(.*))?\r\n} or die $_;
+ $cmd = uc($cmd);
+ if ($cmd eq 'QUIT' ) {
+ print $cl "205 bye\r\n";
+ last;
+ } elsif ( $cmd eq 'MODE' ) {
+ print $cl "201 Posting denied\r\n";
+ } elsif ( ! $ssl and $cmd eq 'STARTTLS' ) {
+ print $cl "382 Continue with TLS negotiation\r\n";
+ if ( ! IO::Socket::SSL->start_SSL($cl, %sslargs)) {
+ diag("initial ssl handshake with client failed");
+ return;
+ }
+ $ssl = 1;
+ } else {
+ diag("received unknown command: $cmd");
+ print "500 unknown cmd\r\n";
+ }
+ }
+
+ diag("NNTP dialog done");
+}
@@ -0,0 +1,49 @@
+#!perl
+#===============================================================================
+#
+# t/pod.t
+#
+# DESCRIPTION
+# Test script to check POD.
+#
+# COPYRIGHT
+# Copyright (C) 2014 Steve Hay. All rights reserved.
+#
+# LICENCE
+# You may distribute under the terms of either the GNU General Public License
+# or the Artistic License, as specified in the LICENCE file.
+#
+#===============================================================================
+
+use 5.008001;
+
+use strict;
+use warnings;
+
+use Test::More;
+
+#===============================================================================
+# MAIN PROGRAM
+#===============================================================================
+
+MAIN: {
+ plan skip_all => 'Author testing only' unless $ENV{AUTHOR_TESTING};
+
+ my $ok = eval {
+ require Test::Pod;
+ Test::Pod->import();
+ 1;
+ };
+
+ if (not $ok) {
+ plan skip_all => 'Test::Pod required to test POD';
+ }
+ elsif ($Test::Pod::VERSION < 1.00) {
+ plan skip_all => 'Test::Pod 1.00 or higher required to test POD';
+ }
+ else {
+ all_pod_files_ok();
+ }
+}
+
+#===============================================================================
@@ -0,0 +1,77 @@
+#!perl
+#===============================================================================
+#
+# t/pod_coverage.t
+#
+# DESCRIPTION
+# Test script to check POD coverage.
+#
+# COPYRIGHT
+# Copyright (C) 2014 Steve Hay. All rights reserved.
+#
+# LICENCE
+# You may distribute under the terms of either the GNU General Public License
+# or the Artistic License, as specified in the LICENCE file.
+#
+#===============================================================================
+
+use 5.008001;
+
+use strict;
+use warnings;
+
+use Test::More;
+
+#===============================================================================
+# MAIN PROGRAM
+#===============================================================================
+
+MAIN: {
+ plan skip_all => 'Author testing only' unless $ENV{AUTHOR_TESTING};
+
+ my $ok = eval {
+ require Test::Pod::Coverage;
+ Test::Pod::Coverage->import();
+ 1;
+ };
+
+ if (not $ok) {
+ plan skip_all => 'Test::Pod::Coverage required to test POD coverage';
+ }
+ elsif ($Test::Pod::Coverage::VERSION < 0.08) {
+ plan skip_all => 'Test::Pod::Coverage 0.08 or higher required to test POD coverage';
+ }
+ else {
+ plan tests => 12;
+ my $params = { coverage_class => qw(Pod::Coverage::CountParents) };
+ pod_coverage_ok('Net::Cmd', {
+ %$params,
+ also_private => [qw(is_utf8 toascii toebcdic set_status)]
+ });
+ pod_coverage_ok('Net::Config', {
+ %$params,
+ also_private => [qw(is_external)]
+ });
+ pod_coverage_ok('Net::Domain', $params);
+ pod_coverage_ok('Net::FTP', {
+ %$params,
+ also_private => [qw(authorise lsl ebcdic byte cmd)]
+ });
+ pod_coverage_ok('Net::Netrc', $params);
+ pod_coverage_ok('Net::NNTP', $params);
+ pod_coverage_ok('Net::POP3', $params);
+ pod_coverage_ok('Net::SMTP', {
+ %$params,
+ also_private => [qw(datafh supports)]
+ });
+ pod_coverage_ok('Net::Time', $params);
+ pod_coverage_ok('Net::FTP::A', $params);
+ pod_coverage_ok('Net::FTP::dataconn', {
+ %$params,
+ also_private => [qw(can_read can_write cmd reading)]
+ });
+ pod_coverage_ok('Net::FTP::I', $params);
+ }
+}
+
+#===============================================================================
@@ -0,0 +1,66 @@
+#!perl
+
+use 5.008001;
+
+use strict;
+use warnings;
+
+use Config;
+use File::Temp 'tempfile';
+use Net::POP3;
+use Test::More;
+
+my $debug = 0; # Net::POP3->new( Debug => .. )
+
+my $inet6class = Net::POP3->can_inet6;
+plan skip_all => "no IPv6 support found in Net::POP3" if ! $inet6class;
+
+plan skip_all => "fork not supported on this platform"
+ unless $Config::Config{d_fork} || $Config::Config{d_pseudofork} ||
+ (($^O eq 'MSWin32' || $^O eq 'NetWare') and
+ $Config::Config{useithreads} and
+ $Config::Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/);
+
+my $srv = $inet6class->new(
+ LocalAddr => '::1',
+ Listen => 10
+);
+plan skip_all => "cannot create listener on ::1: $!" if ! $srv;
+my $saddr = "[".$srv->sockhost."]".':'.$srv->sockport;
+diag("server on $saddr");
+
+plan tests => 1;
+
+defined( my $pid = fork()) or die "fork failed: $!";
+exit(pop3_server()) if ! $pid;
+
+my $cl = Net::POP3->new($saddr, Debug => $debug);
+diag("created Net::POP3 object");
+if (!$cl) {
+ fail("IPv6 POP3 connect failed");
+} else {
+ $cl->quit;
+ pass("IPv6 success");
+}
+wait;
+
+sub pop3_server {
+ my $cl = $srv->accept or die "accept failed: $!";
+ print $cl "+OK localhost ready\r\n";
+ while (<$cl>) {
+ my ($cmd,$arg) = m{^(\S+)(?: +(.*))?\r\n} or die $_;
+ $cmd = uc($cmd);
+ if ($cmd eq 'QUIT' ) {
+ print $cl "+OK bye\r\n";
+ last;
+ } elsif ( $cmd eq 'CAPA' ) {
+ print $cl "+OK\r\n".
+ ".\r\n";
+ } else {
+ diag("received unknown command: $cmd");
+ print "-ERR unknown cmd\r\n";
+ }
+ }
+
+ diag("POP3 dialog done");
+}
@@ -0,0 +1,131 @@
+#!perl
+
+use 5.008001;
+
+use strict;
+use warnings;
+
+use Config;
+use File::Temp 'tempfile';
+use Net::POP3;
+use Test::More;
+
+my $debug = 0; # Net::POP3 Debug => ..
+
+my $parent = 0;
+
+plan skip_all => "no SSL support found in Net::POP3" if ! Net::POP3->can_ssl;
+
+plan skip_all => "fork not supported on this platform"
+ unless $Config::Config{d_fork} || $Config::Config{d_pseudofork} ||
+ (($^O eq 'MSWin32' || $^O eq 'NetWare') and
+ $Config::Config{useithreads} and
+ $Config::Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/);
+
+plan skip_all => "incomplete or to old version of IO::Socket::SSL" if ! eval {
+ require IO::Socket::SSL
+ && IO::Socket::SSL->VERSION(1.999)
+ && require IO::Socket::SSL::Utils
+ && defined &IO::Socket::SSL::Utils::CERT_create;
+};
+
+my $srv = IO::Socket::INET->new(
+ LocalAddr => '127.0.0.1',
+ Listen => 10
+);
+plan skip_all => "cannot create listener on localhost: $!" if ! $srv;
+my $saddr = $srv->sockhost.':'.$srv->sockport;
+
+plan tests => 2;
+
+my ($ca,$key) = IO::Socket::SSL::Utils::CERT_create( CA => 1 );
+my ($fh,$cafile) = tempfile();
+print $fh IO::Socket::SSL::Utils::PEM_cert2string($ca);
+close($fh);
+
+$parent = $$;
+END { unlink($cafile) if $$ == $parent }
+
+my ($cert) = IO::Socket::SSL::Utils::CERT_create(
+ subject => { CN => 'pop3.example.com' },
+ issuer_cert => $ca, issuer_key => $key,
+ key => $key
+);
+
+test(1); # direct ssl
+test(0); # starttls
+
+
+sub test {
+ my $ssl = shift;
+ defined( my $pid = fork()) or die "fork failed: $!";
+ exit(pop3_server($ssl)) if ! $pid;
+ pop3_client($ssl);
+ wait;
+}
+
+
+sub pop3_client {
+ my $ssl = shift;
+ my %sslopt = (
+ SSL_verifycn_name => 'pop3.example.com',
+ SSL_ca_file => $cafile
+ );
+ $sslopt{SSL} = 1 if $ssl;
+ my $cl = Net::POP3->new($saddr, %sslopt, Debug => $debug);
+ diag("created Net::POP3 object");
+ if (!$cl) {
+ fail( ($ssl ? "SSL ":"" )."POP3 connect failed");
+ } elsif ($ssl) {
+ $cl->quit;
+ pass("SSL POP3 connect success");
+ } elsif ( ! $cl->starttls ) {
+ no warnings 'once';
+ fail("starttls failed: $IO::Socket::SSL::SSL_ERROR");
+ } else {
+ $cl->quit;
+ pass("starttls success");
+ }
+}
+
+sub pop3_server {
+ my $ssl = shift;
+ my $cl = $srv->accept or die "accept failed: $!";
+ my %sslargs = (
+ SSL_server => 1,
+ SSL_cert => $cert,
+ SSL_key => $key,
+ );
+ if ( $ssl ) {
+ if ( ! IO::Socket::SSL->start_SSL($cl, %sslargs)) {
+ diag("initial ssl handshake with client failed");
+ return;
+ }
+ }
+
+ print $cl "+OK localhost ready\r\n";
+ while (<$cl>) {
+ my ($cmd,$arg) = m{^(\S+)(?: +(.*))?\r\n} or die $_;
+ $cmd = uc($cmd);
+ if ($cmd eq 'QUIT' ) {
+ print $cl "+OK bye\r\n";
+ last;
+ } elsif ( $cmd eq 'CAPA' ) {
+ print $cl "+OK\r\n".
+ ( $ssl ? "" : "STLS\r\n" ).
+ ".\r\n";
+ } elsif ( ! $ssl and $cmd eq 'STLS' ) {
+ print $cl "+OK starting ssl\r\n";
+ if ( ! IO::Socket::SSL->start_SSL($cl, %sslargs)) {
+ diag("initial ssl handshake with client failed");
+ return;
+ }
+ $ssl = 1;
+ } else {
+ diag("received unknown command: $cmd");
+ print "-ERR unknown cmd\r\n";
+ }
+ }
+
+ diag("POP3 dialog done");
+}
@@ -1,14 +1,15 @@
-#!./perl -w
+#!perl
+
+use 5.008001;
+
+use strict;
+use warnings;
BEGIN {
- unless (-d 'blib') {
- chdir 't' if -d 't';
- @INC = '../lib';
- }
- if (!eval "require Socket") {
+ if (!eval { require Socket; 1 }) {
print "1..0 # no Socket\n"; exit 0;
}
- if (ord('A') == 193 && !eval "require Convert::EBCDIC") {
+ if (ord('A') == 193 && !eval { require Convert::EBCDIC; 1 }) {
print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0;
}
}
@@ -1,14 +1,15 @@
-#!./perl -w
+#!perl
+
+use 5.008001;
+
+use strict;
+use warnings;
BEGIN {
- unless (-d 'blib') {
- chdir 't' if -d 't';
- @INC = '../lib';
- }
- if (!eval "require Socket") {
+ if (!eval { require Socket; 1 }) {
print "1..0 # no Socket\n"; exit 0;
}
- if (ord('A') == 193 && !eval "require Convert::EBCDIC") {
+ if (ord('A') == 193 && eval { require Convert::EBCDIC; 1 }) {
print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0;
}
}
@@ -25,7 +26,7 @@ print "1..3\n";
my $i = 1;
-$smtp = Net::SMTP->new(Debug => 0)
+my $smtp = Net::SMTP->new(Debug => 0)
or (print("not ok 1\n"), exit);
print "ok 1\n";
@@ -0,0 +1,68 @@
+#!perl
+
+use 5.008001;
+
+use strict;
+use warnings;
+
+use Config;
+use File::Temp 'tempfile';
+use Net::SMTP;
+use Test::More;
+
+my $debug = 0; # Net::SMTP->new( Debug => .. )
+
+my $inet6class = Net::SMTP->can_inet6;
+plan skip_all => "no IPv6 support found in Net::SMTP" if ! $inet6class;
+
+plan skip_all => "fork not supported on this platform"
+ unless $Config::Config{d_fork} || $Config::Config{d_pseudofork} ||
+ (($^O eq 'MSWin32' || $^O eq 'NetWare') and
+ $Config::Config{useithreads} and
+ $Config::Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/);
+
+my $srv = $inet6class->new(
+ LocalAddr => '::1',
+ Listen => 10
+);
+plan skip_all => "cannot create listener on ::1: $!" if ! $srv;
+my $saddr = "[".$srv->sockhost."]".':'.$srv->sockport;
+diag("server on $saddr");
+
+plan tests => 1;
+
+defined( my $pid = fork()) or die "fork failed: $!";
+exit(smtp_server()) if ! $pid;
+
+my $cl = Net::SMTP->new($saddr, Debug => $debug);
+diag("created Net::SMTP object");
+if (!$cl) {
+ fail("IPv6 SMTP connect failed");
+} else {
+ $cl->quit;
+ pass("IPv6 success");
+}
+wait;
+
+sub smtp_server {
+ my $cl = $srv->accept or die "accept failed: $!";
+ print $cl "220 welcome\r\n";
+ while (<$cl>) {
+ my ($cmd,$arg) = m{^(\S+)(?: +(.*))?\r\n} or die $_;
+ $cmd = uc($cmd);
+ if ($cmd eq 'QUIT' ) {
+ print $cl "250 bye\r\n";
+ last;
+ } elsif ( $cmd eq 'HELO' ) {
+ print $cl "250 localhost\r\n";
+ } elsif ( $cmd eq 'EHLO' ) {
+ print $cl "250-localhost\r\n".
+ "250 HELP\r\n";
+ } else {
+ diag("received unknown command: $cmd");
+ print "500 unknown cmd\r\n";
+ }
+ }
+
+ diag("SMTP dialog done");
+}
@@ -0,0 +1,133 @@
+#!perl
+
+use 5.008001;
+
+use strict;
+use warnings;
+
+use Config;
+use File::Temp 'tempfile';
+use Net::SMTP;
+use Test::More;
+
+my $debug = 0; # Net::SMTP Debug => ..
+
+my $parent = 0;
+
+plan skip_all => "no SSL support found in Net::SMTP" if ! Net::SMTP->can_ssl;
+
+plan skip_all => "fork not supported on this platform"
+ unless $Config::Config{d_fork} || $Config::Config{d_pseudofork} ||
+ (($^O eq 'MSWin32' || $^O eq 'NetWare') and
+ $Config::Config{useithreads} and
+ $Config::Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/);
+
+plan skip_all => "incomplete or to old version of IO::Socket::SSL" if ! eval {
+ require IO::Socket::SSL
+ && IO::Socket::SSL->VERSION(1.999)
+ && require IO::Socket::SSL::Utils
+ && defined &IO::Socket::SSL::Utils::CERT_create;
+};
+
+my $srv = IO::Socket::INET->new(
+ LocalAddr => '127.0.0.1',
+ Listen => 10
+);
+plan skip_all => "cannot create listener on localhost: $!" if ! $srv;
+my $saddr = $srv->sockhost.':'.$srv->sockport;
+
+plan tests => 2;
+
+my ($ca,$key) = IO::Socket::SSL::Utils::CERT_create( CA => 1 );
+my ($fh,$cafile) = tempfile();
+print $fh IO::Socket::SSL::Utils::PEM_cert2string($ca);
+close($fh);
+
+$parent = $$;
+END { unlink($cafile) if $$ == $parent }
+
+my ($cert) = IO::Socket::SSL::Utils::CERT_create(
+ subject => { CN => 'smtp.example.com' },
+ issuer_cert => $ca, issuer_key => $key,
+ key => $key
+);
+
+test(1); # direct ssl
+test(0); # starttls
+
+
+sub test {
+ my $ssl = shift;
+ defined( my $pid = fork()) or die "fork failed: $!";
+ exit(smtp_server($ssl)) if ! $pid;
+ smtp_client($ssl);
+ wait;
+}
+
+
+sub smtp_client {
+ my $ssl = shift;
+ my %sslopt = (
+ SSL_verifycn_name => 'smtp.example.com',
+ SSL_ca_file => $cafile
+ );
+ $sslopt{SSL} = 1 if $ssl;
+ my $cl = Net::SMTP->new($saddr, %sslopt, Debug => $debug);
+ diag("created Net::SMTP object");
+ if (!$cl) {
+ fail( ($ssl ? "SSL ":"" )."SMTP connect failed");
+ } elsif ($ssl) {
+ $cl->quit;
+ pass("SSL SMTP connect success");
+ } elsif ( ! $cl->starttls ) {
+ no warnings 'once';
+ fail("starttls failed: $IO::Socket::SSL::SSL_ERROR");
+ } else {
+ $cl->quit;
+ pass("starttls success");
+ }
+}
+
+sub smtp_server {
+ my $ssl = shift;
+ my $cl = $srv->accept or die "accept failed: $!";
+ my %sslargs = (
+ SSL_server => 1,
+ SSL_cert => $cert,
+ SSL_key => $key,
+ );
+ if ( $ssl ) {
+ if ( ! IO::Socket::SSL->start_SSL($cl, %sslargs)) {
+ diag("initial ssl handshake with client failed");
+ return;
+ }
+ }
+
+ print $cl "220 welcome\r\n";
+ while (<$cl>) {
+ my ($cmd,$arg) = m{^(\S+)(?: +(.*))?\r\n} or die $_;
+ $cmd = uc($cmd);
+ if ($cmd eq 'QUIT' ) {
+ print $cl "250 bye\r\n";
+ last;
+ } elsif ( $cmd eq 'HELO' ) {
+ print $cl "250 localhost\r\n";
+ } elsif ( $cmd eq 'EHLO' ) {
+ print $cl "250-localhost\r\n".
+ ( $ssl ? "" : "250-STARTTLS\r\n" ).
+ "250 HELP\r\n";
+ } elsif ( ! $ssl and $cmd eq 'STARTTLS' ) {
+ print $cl "250 starting ssl\r\n";
+ if ( ! IO::Socket::SSL->start_SSL($cl, %sslargs)) {
+ diag("initial ssl handshake with client failed");
+ return;
+ }
+ $ssl = 1;
+ } else {
+ diag("received unknown command: $cmd");
+ print "500 unknown cmd\r\n";
+ }
+ }
+
+ diag("SMTP dialog done");
+}
@@ -1,14 +1,15 @@
-#!./perl -w
+#!perl
+
+use 5.008001;
+
+use strict;
+use warnings;
BEGIN {
- if ($ENV{PERL_CORE}) {
- chdir 't' if -d 't';
- @INC = '../lib';
- }
- if (!eval "require Socket") {
+ if (!eval { require Socket; 1 }) {
print "1..0 # no Socket\n"; exit 0;
}
- if (ord('A') == 193 && !eval "require Convert::EBCDIC") {
+ if (ord('A') == 193 && !eval { require Convert::EBCDIC; 1 }) {
print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0;
}
$INC{'IO/Socket.pm'} = 1;