├── Changes ├── lib └── Net │ ├── FTP │ ├── E.pm │ ├── L.pm │ ├── I.pm │ ├── A.pm │ └── dataconn.pm │ ├── Time.pm │ ├── Netrc.pm │ ├── Config.pm │ ├── Domain.pm │ ├── libnetFAQ.pod │ └── Cmd.pm ├── .gitignore ├── MANIFEST.SKIP ├── demos ├── time ├── pop3 ├── ftp ├── nntp ├── smtp.self └── nntp.mirror ├── t ├── smtp.t ├── require.t ├── nntp.t ├── changes.t ├── critic.t ├── pod.t ├── external │ ├── smtp-ssl.t │ ├── pop3-ssl.t │ └── ftp-ssl.t ├── hostname.t ├── ftp.t ├── pop3_ipv6.t ├── nntp_ipv6.t ├── smtp_ipv6.t ├── config.t ├── datasend.t ├── pod_coverage.t ├── pop3_ssl.t ├── nntp_ssl.t ├── smtp_ssl.t ├── time.t └── netrc.t ├── LICENCE ├── INSTALL ├── README ├── MANIFEST ├── Artistic ├── Makefile.PL ├── Copying └── Configure /Changes: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/steve-m-hay/perl-libnet/HEAD/Changes -------------------------------------------------------------------------------- /lib/Net/FTP/E.pm: -------------------------------------------------------------------------------- 1 | package Net::FTP::E; 2 | 3 | use 5.008001; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | use Net::FTP::I; 9 | 10 | our @ISA = qw(Net::FTP::I); 11 | our $VERSION = "3.16"; 12 | 13 | 1; 14 | -------------------------------------------------------------------------------- /lib/Net/FTP/L.pm: -------------------------------------------------------------------------------- 1 | package Net::FTP::L; 2 | 3 | use 5.008001; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | use Net::FTP::I; 9 | 10 | our @ISA = qw(Net::FTP::I); 11 | our $VERSION = "3.16"; 12 | 13 | 1; 14 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Files generated by Makefile.PL 2 | libnet.cfg 3 | Makefile 4 | MYMETA.json 5 | MYMETA.yml 6 | 7 | # Files generated by *make 8 | blib/ 9 | pm_to_blib 10 | 11 | # Files generated by *make clean 12 | Makefile.old 13 | 14 | # Files generated by *make dist 15 | libnet-*.tar.gz 16 | -------------------------------------------------------------------------------- /MANIFEST.SKIP: -------------------------------------------------------------------------------- 1 | # Source control system files 2 | ^\.git/ 3 | ^\.gitignore$ 4 | 5 | # Files generated by Makefile.PL 6 | ^libnet.cfg$ 7 | ^Makefile$ 8 | ^MYMETA\.json$ 9 | ^MYMETA\.yml$ 10 | 11 | # Files generated by *make 12 | ^blib/ 13 | ^pm_to_blib$ 14 | 15 | # Files generated by *make clean 16 | ^Makefile\.old$ 17 | 18 | # Files generated by *make dist 19 | ^libnet-\d\.\d\d\.tar\.gz$ 20 | -------------------------------------------------------------------------------- /demos/time: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use 5.008001; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | use blib; 9 | use Net::Time qw(inet_time inet_daytime); 10 | 11 | print inet_daytime('localhost'); 12 | print inet_daytime('localhost','tcp'); 13 | print inet_daytime('localhost','udp'); 14 | 15 | print inet_time('localhost'),"\n"; 16 | print inet_time('localhost','tcp'),"\n"; 17 | print inet_time('localhost','udp'),"\n"; 18 | 19 | -------------------------------------------------------------------------------- /demos/pop3: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use 5.008001; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | use blib; 9 | use Getopt::Long; 10 | use Net::POP3; 11 | 12 | our $opt_debug = 0; 13 | our $opt_user = undef; 14 | 15 | GetOptions(qw(debug user=s)); 16 | 17 | my $pop = Net::POP3->new('backup3', Debug => $opt_debug ? 6 : 0); 18 | 19 | my $user = $opt_user || $ENV{USER} || $ENV{LOGNAME}; 20 | 21 | my $count = $pop->login($user); 22 | 23 | if($count) 24 | { 25 | my $m = $pop->get(1); 26 | print @$m if $m; 27 | } 28 | 29 | $pop->quit; 30 | -------------------------------------------------------------------------------- /demos/ftp: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use 5.008001; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | use blib; 9 | use Getopt::Long; 10 | use Net::FTP; 11 | 12 | our $opt_debug = undef; 13 | our $opt_firewall = undef; 14 | 15 | GetOptions(qw(debug firewall=s)); 16 | 17 | my @firewall = defined $opt_firewall ? (Firewall => $opt_firewall) : (); 18 | 19 | foreach my $host (@ARGV) 20 | { 21 | my $ftp = Net::FTP->new($host, @firewall, Debug => $opt_debug ? 1 : 0); 22 | $ftp->login(); 23 | print $ftp->pwd,"\n"; 24 | $ftp->quit; 25 | } 26 | 27 | -------------------------------------------------------------------------------- /demos/nntp: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use 5.008001; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | use blib; 9 | use Getopt::Long; 10 | use Net::NNTP; 11 | 12 | our $opt_debug = undef; 13 | 14 | GetOptions(qw(debug)); 15 | 16 | my @groups = @ARGV; 17 | 18 | my $nntp = Net::NNTP->new('news', Debug => $opt_debug ? 1 : 0); 19 | 20 | my $subs; 21 | if($subs = $nntp->newsgroups) 22 | { 23 | print join("\n",(keys %$subs)[0 .. 10]),"\n"; 24 | } 25 | else 26 | { 27 | warn $nntp->message; 28 | } 29 | 30 | foreach my $group (@groups) 31 | { 32 | my $news = $nntp->newnews(time - 3600, lc $group); 33 | 34 | if(ref($news) && scalar(@$news)) 35 | { 36 | print @{$news}[0..3],"\n" 37 | if $news = $nntp->article($news->[-1]); 38 | 39 | warn $nntp->message 40 | unless $news; 41 | } 42 | } 43 | 44 | $nntp->quit; 45 | 46 | 47 | -------------------------------------------------------------------------------- /t/smtp.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use 5.008001; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | BEGIN { 9 | if (!eval { require Socket }) { 10 | print "1..0 # Skip: no Socket\n"; exit 0; 11 | } 12 | if (ord('A') == 193 && !eval { require Convert::EBCDIC }) { 13 | print "1..0 # Skip: EBCDIC but no Convert::EBCDIC\n"; exit 0; 14 | } 15 | } 16 | 17 | use Net::Config; 18 | use Net::SMTP; 19 | 20 | unless(@{$NetConfig{smtp_hosts}}) { 21 | print "1..0 # Skip: no smtp_hosts defined in config\n"; 22 | exit 0; 23 | } 24 | 25 | unless($NetConfig{test_hosts}) { 26 | print "1..0 # Skip: test_hosts not enabled in config\n"; 27 | exit 0; 28 | } 29 | 30 | print "1..3\n"; 31 | 32 | my $i = 1; 33 | 34 | my $smtp = Net::SMTP->new(Debug => 0) 35 | or (print("not ok 1\n"), exit); 36 | 37 | print "ok 1\n"; 38 | 39 | $smtp->domain or print "not "; 40 | print "ok 2\n"; 41 | 42 | $smtp->quit or print "not "; 43 | print "ok 3\n"; 44 | 45 | -------------------------------------------------------------------------------- /t/require.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use 5.008001; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | BEGIN { 9 | if (!eval { require Socket }) { 10 | print "1..0 # Skip: no Socket\n"; exit 0; 11 | } 12 | if (ord('A') == 193 && !eval { require Convert::EBCDIC }) { 13 | print "1..0 # Skip: EBCDIC but no Convert::EBCDIC\n"; exit 0; 14 | } 15 | } 16 | 17 | print "1..9\n"; 18 | my $i = 1; 19 | eval { require Net::Config; } || print "not "; print "ok ",$i++,"\n"; 20 | eval { require Net::Domain; } || print "not "; print "ok ",$i++,"\n"; 21 | eval { require Net::Cmd; } || print "not "; print "ok ",$i++,"\n"; 22 | eval { require Net::Netrc; } || print "not "; print "ok ",$i++,"\n"; 23 | eval { require Net::FTP; } || print "not "; print "ok ",$i++,"\n"; 24 | eval { require Net::SMTP; } || print "not "; print "ok ",$i++,"\n"; 25 | eval { require Net::NNTP; } || print "not "; print "ok ",$i++,"\n"; 26 | eval { require Net::POP3; } || print "not "; print "ok ",$i++,"\n"; 27 | eval { require Net::Time; } || print "not "; print "ok ",$i++,"\n"; 28 | 29 | 30 | -------------------------------------------------------------------------------- /LICENCE: -------------------------------------------------------------------------------- 1 | This distribution is free software; you can redistribute it and/or modify it 2 | under the terms of either: 3 | 4 | a) the GNU General Public License as published by the Free Software Foundation; 5 | either version 1, or (at your option) any later version; or 6 | 7 | b) the "Artistic License" which comes with this distribution. 8 | 9 | This distribution is distributed in the hope that it will be useful, but WITHOUT 10 | ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS 11 | FOR A PARTICULAR PURPOSE. See either the GNU General Public License or the 12 | Artistic License for more details. 13 | 14 | You should have received a copy of the GNU General Public License along with 15 | this distribution in the file named "Copying". If not, write to the Free 16 | Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 17 | 02110-1301, USA or visit their web page on the internet at 18 | https://www.gnu.org/copyleft/gpl.html or the Perl web page at 19 | https://dev.perl.org/licenses/gpl1.html. 20 | 21 | You should also have received a copy of the Artistic License with this 22 | distribution, in the file named "Artistic". If not, visit the Perl web page on 23 | the internet at https://dev.perl.org/licenses/artistic.html. 24 | -------------------------------------------------------------------------------- /t/nntp.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use 5.008001; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | BEGIN { 9 | if (!eval { require Socket }) { 10 | print "1..0 # Skip: no Socket\n"; exit 0; 11 | } 12 | if (ord('A') == 193 && !eval { require Convert::EBCDIC }) { 13 | print "1..0 # Skip: EBCDIC but no Convert::EBCDIC\n"; exit 0; 14 | } 15 | } 16 | 17 | use Net::Config; 18 | use Net::NNTP; 19 | use Net::Cmd qw(CMD_REJECT); 20 | 21 | unless(@{$NetConfig{nntp_hosts}}) { 22 | print "1..0 # Skip: no nntp_hosts defined in config\n"; 23 | exit; 24 | } 25 | 26 | unless($NetConfig{test_hosts}) { 27 | print "1..0 # Skip: test_hosts not enabled in config\n"; 28 | exit; 29 | } 30 | 31 | print "1..4\n"; 32 | 33 | my $i = 1; 34 | 35 | my $nntp = Net::NNTP->new(Debug => 0) 36 | or (print("not ok 1\n"), exit); 37 | 38 | print "ok 1\n"; 39 | 40 | my @grp; 41 | foreach my $grp (qw(test alt.test control news.announce.newusers)) { 42 | @grp = $nntp->group($grp); 43 | last if @grp; 44 | } 45 | 46 | if($nntp->status == CMD_REJECT) { 47 | # Command was rejected, probably because we need authinfo 48 | map { print "ok ",$_,"\n" } 2,3,4; 49 | exit; 50 | } 51 | 52 | print "not " unless @grp; 53 | print "ok 2\n"; 54 | 55 | 56 | if(@grp && $grp[2] > $grp[1]) { 57 | $nntp->head($grp[1]) or print "not "; 58 | } 59 | print "ok 3\n"; 60 | 61 | if(@grp) { 62 | $nntp->quit or print "not "; 63 | } 64 | print "ok 4\n"; 65 | 66 | -------------------------------------------------------------------------------- /t/changes.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | #=============================================================================== 3 | # 4 | # t/changes.t 5 | # 6 | # DESCRIPTION 7 | # Test script to check CPAN::Changes conformance. 8 | # 9 | # COPYRIGHT 10 | # Copyright (C) 2014 Steve Hay. All rights reserved. 11 | # 12 | # LICENCE 13 | # This script is free software; you can redistribute it and/or modify it under 14 | # the same terms as Perl itself, i.e. under the terms of either the GNU 15 | # General Public License or the Artistic License, as specified in the LICENCE 16 | # file. 17 | # 18 | #=============================================================================== 19 | 20 | use 5.008001; 21 | 22 | use strict; 23 | use warnings; 24 | 25 | use Test::More; 26 | 27 | #=============================================================================== 28 | # MAIN PROGRAM 29 | #=============================================================================== 30 | 31 | MAIN: { 32 | plan skip_all => 'Author testing only' unless $ENV{AUTHOR_TESTING}; 33 | 34 | my $ok = eval { 35 | require Test::CPAN::Changes; 36 | Test::CPAN::Changes->import(); 37 | 1; 38 | }; 39 | 40 | if (not $ok) { 41 | plan skip_all => 'Test::CPAN::Changes required to test Changes'; 42 | } 43 | else { 44 | changes_ok(); 45 | } 46 | } 47 | 48 | #=============================================================================== 49 | -------------------------------------------------------------------------------- /t/critic.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | #=============================================================================== 3 | # 4 | # t/critic.t 5 | # 6 | # DESCRIPTION 7 | # Test script to check Perl::Critic conformance. 8 | # 9 | # COPYRIGHT 10 | # Copyright (C) 2014 Steve Hay. All rights reserved. 11 | # 12 | # LICENCE 13 | # This script is free software; you can redistribute it and/or modify it under 14 | # the same terms as Perl itself, i.e. under the terms of either the GNU 15 | # General Public License or the Artistic License, as specified in the LICENCE 16 | # file. 17 | # 18 | #=============================================================================== 19 | 20 | use 5.008001; 21 | 22 | use strict; 23 | use warnings; 24 | 25 | use Test::More; 26 | 27 | #=============================================================================== 28 | # MAIN PROGRAM 29 | #=============================================================================== 30 | 31 | MAIN: { 32 | plan skip_all => 'Author testing only' unless $ENV{AUTHOR_TESTING}; 33 | 34 | my $ok = eval { 35 | require Test::Perl::Critic; 36 | Test::Perl::Critic->import(-profile => ''); 37 | 1; 38 | }; 39 | 40 | if (not $ok) { 41 | plan skip_all => 'Test::Perl::Critic required to test with Perl::Critic'; 42 | } 43 | else { 44 | all_critic_ok('.'); 45 | } 46 | } 47 | 48 | #=============================================================================== 49 | -------------------------------------------------------------------------------- /t/pod.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | #=============================================================================== 3 | # 4 | # t/pod.t 5 | # 6 | # DESCRIPTION 7 | # Test script to check POD. 8 | # 9 | # COPYRIGHT 10 | # Copyright (C) 2014 Steve Hay. All rights reserved. 11 | # 12 | # LICENCE 13 | # This script is free software; you can redistribute it and/or modify it under 14 | # the same terms as Perl itself, i.e. under the terms of either the GNU 15 | # General Public License or the Artistic License, as specified in the LICENCE 16 | # file. 17 | # 18 | #=============================================================================== 19 | 20 | use 5.008001; 21 | 22 | use strict; 23 | use warnings; 24 | 25 | use Test::More; 26 | 27 | #=============================================================================== 28 | # MAIN PROGRAM 29 | #=============================================================================== 30 | 31 | MAIN: { 32 | plan skip_all => 'Author testing only' unless $ENV{AUTHOR_TESTING}; 33 | 34 | my $ok = eval { 35 | require Test::Pod; 36 | Test::Pod->import(); 37 | 1; 38 | }; 39 | 40 | if (not $ok) { 41 | plan skip_all => 'Test::Pod required to test POD'; 42 | } 43 | elsif ($Test::Pod::VERSION < 1.00) { 44 | plan skip_all => 'Test::Pod 1.00 or higher required to test POD'; 45 | } 46 | else { 47 | all_pod_files_ok(); 48 | } 49 | } 50 | 51 | #=============================================================================== 52 | -------------------------------------------------------------------------------- /INSTALL: -------------------------------------------------------------------------------- 1 | PREREQUISITES 2 | 3 | Perl 4 | 5 | Perl version 5.8.1 or later. 6 | The latest version of Perl is available from https://www.perl.com/. 7 | 8 | Perl Modules 9 | 10 | There are no non-standard Perl modules required by this module. 11 | 12 | INSTALLATION 13 | 14 | To install this module, cd to the directory that contains this INSTALL file 15 | and type the following: 16 | 17 | perl Makefile.PL 18 | make 19 | make test 20 | make install 21 | 22 | Normally when Makefile.PL is run it will run Configure which will ask some 23 | questions about your system. The results of these questions will be stored 24 | in a file called libnet.cfg which will be installed alongside the other perl 25 | modules in this distribution. Makefile.PL will run Configure in an 26 | interactive mode unless these exists a file called libnet.cfg in the build 27 | directory or Makefile.PL itself is being run non-interactively or via cpan, 28 | cpanp or cpanm. 29 | 30 | If you are on a system which cannot run this script you can create an empty 31 | file to make Makefile.PL skip running Configure. If you want to keep your 32 | existing settings and not run interactivly then simply run: 33 | 34 | perl Configure -d 35 | 36 | before running Makefile.PL. 37 | 38 | Use the appropriate program name instead of "make" in the above commands if 39 | your perl was built with a different make program. To determine which make 40 | program was used to build your perl type the following: 41 | 42 | perl -V:make 43 | -------------------------------------------------------------------------------- /t/external/smtp-ssl.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use 5.008001; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | use Net::SMTP; 9 | use Test::More; 10 | 11 | my $host = 'mail.gmx.net'; 12 | my $debug = 0; 13 | 14 | plan skip_all => "no SSL support" if ! Net::SMTP->can_ssl; 15 | { 16 | no warnings 'once'; 17 | plan skip_all => "no verified SSL connection to $host:465 - $@" if ! eval { 18 | IO::Socket::SSL->new("$host:465") 19 | || die($IO::Socket::SSL::SSL_ERROR||$!); 20 | }; 21 | } 22 | 23 | plan tests => 2; 24 | 25 | SKIP: { 26 | diag( "connect inet to $host:25" ); 27 | skip "no inet connect to $host:25",1 if ! IO::Socket::INET->new("$host:25"); 28 | my $smtp = Net::SMTP->new($host, Debug => $debug) 29 | or skip "normal SMTP failed: $@",1; 30 | skip "no STARTTLS support",1 if $smtp->message !~/STARTTLS/; 31 | 32 | if (!$smtp->starttls) { 33 | fail("starttls failed: ".$smtp->code." $@") 34 | } else { 35 | # we now should have access to SSL stuff 36 | my $cipher = eval { $smtp->get_cipher }; 37 | if (!$cipher) { 38 | fail("after starttls: not an SSL object"); 39 | } elsif ( $smtp->quit ) { 40 | pass("starttls + quit ok, cipher=$cipher"); 41 | } else { 42 | fail("quit after starttls failed: ".$smtp->code); 43 | } 44 | } 45 | } 46 | 47 | 48 | my $smtp = Net::SMTP->new($host, SSL => 1, Debug => $debug); 49 | # we now should have access to SSL stuff 50 | my $cipher = eval { $smtp->get_cipher }; 51 | if (!$cipher) { 52 | fail("after ssl connect: not an SSL object"); 53 | } elsif ( $smtp->quit ) { 54 | pass("ssl connect ok, cipher=$cipher"); 55 | } else { 56 | fail("quit after direct ssl failed: ".$smtp->code); 57 | } 58 | -------------------------------------------------------------------------------- /demos/smtp.self: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use 5.008001; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | use blib; 9 | use Getopt::Long; 10 | use Net::SMTP; 11 | 12 | =head1 NAME 13 | 14 | smtp.self - mail a message via smtp 15 | 16 | =head1 DESCRIPTION 17 | 18 | C will attempt to send a message to a given user 19 | 20 | =head1 OPTIONS 21 | 22 | =over 4 23 | 24 | =item -debug 25 | 26 | Enabe the output of dubug information 27 | 28 | =item -help 29 | 30 | Display this help text and quit 31 | 32 | =item -user USERNAME 33 | 34 | Send the message to C 35 | 36 | =back 37 | 38 | =head1 EXAMPLE 39 | 40 | demos/smtp.self -user foo.bar 41 | 42 | demos/smtp.self -debug -user Graham.Barr 43 | 44 | =cut 45 | 46 | our $opt_debug = undef; 47 | our $opt_user = undef; 48 | our $opt_help = undef; 49 | GetOptions(qw(debug user=s help)); 50 | exec("pod2text $0") 51 | if defined $opt_help; 52 | 53 | Net::SMTP->debug(1) if $opt_debug; 54 | 55 | my $smtp = Net::SMTP->new("mailhost"); 56 | 57 | my $user = $opt_user || $ENV{USER} || $ENV{LOGNAME}; 58 | 59 | $smtp->mail($user) && $smtp->to($user); 60 | $smtp->reset; 61 | 62 | if($smtp->mail($user) && $smtp->to($user)) 63 | { 64 | $smtp->data(); 65 | 66 | my @data; 67 | map { s/-USER-/$user/g } @data=; ## no critic (ControlStructures::ProhibitMutatingListFunctions) 68 | 69 | $smtp->datasend(@data); 70 | $smtp->dataend; 71 | } 72 | else 73 | { 74 | warn $smtp->message; 75 | } 76 | 77 | $smtp->quit; 78 | 79 | __DATA__ 80 | To: <-USER-> 81 | Subject: A test message 82 | 83 | The message was sent directly via SMTP using Net::SMTP 84 | . 85 | The message was sent directly via SMTP using Net::SMTP 86 | -------------------------------------------------------------------------------- /t/external/pop3-ssl.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use 5.008001; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | use Net::POP3; 9 | use Test::More; 10 | 11 | my $host = 'pop.gmx.net'; 12 | my $debug = 0; 13 | 14 | plan skip_all => "no SSL support" if ! Net::POP3->can_ssl; 15 | { 16 | no warnings 'once'; 17 | plan skip_all => "no verified SSL connection to $host:995 - $@" if ! eval { 18 | IO::Socket::SSL->new(PeerAddr => "$host:995", Timeout => 10) 19 | || die($IO::Socket::SSL::SSL_ERROR||$!); 20 | }; 21 | } 22 | 23 | plan tests => 2; 24 | 25 | SKIP: { 26 | diag( "connect inet to $host:110" ); 27 | skip "no inet connect to $host:110",1 28 | if ! IO::Socket::INET->new(PeerAddr => "$host:110", Timeout => 10); 29 | my $pop3 = Net::POP3->new($host, Debug => $debug, Timeout => 10) 30 | or skip "normal POP3 failed: $@",1; 31 | skip "no STARTTLS support",1 if $pop3->message !~/STARTTLS/; 32 | 33 | if (!$pop3->starttls) { 34 | fail("starttls failed: ".$pop3->code." $@") 35 | } else { 36 | # we now should have access to SSL stuff 37 | my $cipher = eval { $pop3->get_cipher }; 38 | if (!$cipher) { 39 | fail("after starttls: not an SSL object"); 40 | } elsif ( $pop3->quit ) { 41 | pass("starttls + quit ok, cipher=$cipher"); 42 | } else { 43 | fail("quit after starttls failed: ".$pop3->code); 44 | } 45 | } 46 | } 47 | 48 | 49 | my $pop3 = Net::POP3->new($host, SSL => 1, Timeout => 10, Debug => $debug); 50 | # we now should have access to SSL stuff 51 | my $cipher = eval { $pop3->get_cipher }; 52 | if (!$cipher) { 53 | fail("after ssl connect: not an SSL object"); 54 | } elsif ( $pop3->quit ) { 55 | pass("ssl connect ok, cipher=$cipher"); 56 | } else { 57 | fail("quit after direct ssl failed: ".$pop3->code); 58 | } 59 | -------------------------------------------------------------------------------- /t/hostname.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use 5.008001; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | BEGIN { 9 | if (!eval { require Socket }) { 10 | print "1..0 # Skip: no Socket\n"; exit 0; 11 | } 12 | if (ord('A') == 193 && !eval { require Convert::EBCDIC }) { 13 | print "1..0 # Skip: EBCDIC but no Convert::EBCDIC\n"; exit 0; 14 | } 15 | } 16 | 17 | use Net::Domain qw(hostname domainname hostdomain hostfqdn); 18 | use Net::Config; 19 | 20 | unless($NetConfig{test_hosts}) { 21 | print "1..0 # Skip: test_hosts not enabled in config\n"; 22 | exit 0; 23 | } 24 | 25 | print "1..5\n"; 26 | 27 | my $domain = domainname(); 28 | 29 | if(defined $domain && $domain ne "") { 30 | print "ok 1 - defined, non-empty domainname\n"; 31 | } 32 | elsif (not defined $domain) { 33 | print "ok 1 # SKIP domain not fully defined\n"; 34 | } 35 | else { 36 | print "not ok 1\n"; 37 | } 38 | 39 | # This checks thats hostanme does not overwrite $_ 40 | my @domain = qw(foo.example.com bar.example.jp); 41 | my @copy = @domain; 42 | 43 | my @dummy = grep { defined hostname() and hostname() eq $_ } @domain; 44 | 45 | ($domain[0] && $domain[0] eq $copy[0]) 46 | ? print "ok 2\n" 47 | : print "not ok 2\n"; 48 | 49 | @dummy = grep { defined hostdomain() and hostdomain() eq $_ } @domain; 50 | 51 | ($domain[0] && $domain[0] eq $copy[0]) 52 | ? print "ok 3\n" 53 | : print "not ok 3\n"; 54 | 55 | my $name = hostname(); 56 | $domain = hostdomain(); 57 | if(defined $domain && defined $name && $name ne "" && $domain ne "") { 58 | hostfqdn() eq $name . "." . $domain ? print "ok 4\n" : print "not ok 4\n"; 59 | domainname() eq $name . "." . $domain ? print "ok 5\n" : print "not ok 5\n";} else { 60 | print "ok 4 # SKIP domain not fully defined\n"; 61 | print "ok 5 # SKIP domain not fully defined\n"; 62 | } 63 | -------------------------------------------------------------------------------- /t/ftp.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use 5.008001; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | BEGIN { 9 | if (!eval { require Socket }) { 10 | print "1..0 # Skip: no Socket\n"; exit 0; 11 | } 12 | if (ord('A') == 193 && !eval { require Convert::EBCDIC }) { 13 | print "1..0 # Skip: EBCDIC but no Convert::EBCDIC\n"; exit 0; 14 | } 15 | } 16 | 17 | use Net::Config; 18 | use Net::FTP; 19 | 20 | unless(defined($NetConfig{ftp_testhost})) { 21 | print "1..0 # Skip: no ftp_testhost defined in config\n"; 22 | exit 0; 23 | } 24 | 25 | unless($NetConfig{test_hosts}) { 26 | print "1..0 # Skip: test_hosts not enabled in config\n"; 27 | exit 0; 28 | } 29 | 30 | my $t = 1; 31 | print "1..7\n"; 32 | 33 | my $ftp = Net::FTP->new($NetConfig{ftp_testhost}) 34 | or (print("not ok 1\n"), exit); 35 | 36 | printf "ok %d\n",$t++; 37 | 38 | $ftp->login('anonymous') or die($ftp->message . "\n"); 39 | printf "ok %d\n",$t++; 40 | 41 | $ftp->pwd or do { 42 | print STDERR $ftp->message,"\n"; 43 | print "not "; 44 | }; 45 | 46 | printf "ok %d\n",$t++; 47 | 48 | $ftp->cwd('/pub') or do { 49 | print STDERR $ftp->message,"\n"; 50 | print "not "; 51 | }; 52 | 53 | my $data; 54 | if ($data = $ftp->stor('libnet.tst')) { 55 | my $text = "abc\ndef\nqwe\n"; 56 | printf "ok %d\n",$t++; 57 | $data->write($text,length $text); 58 | $data->close; 59 | $data = $ftp->retr('libnet.tst'); 60 | my $buf; 61 | $data->read($buf,length $text); 62 | $data->close; 63 | print "not " unless $text eq $buf; 64 | printf "ok %d\n",$t++; 65 | $ftp->delete('libnet.tst') or print "not "; 66 | printf "ok %d\n",$t++; 67 | 68 | } 69 | else { 70 | print "# ",$ftp->message,"\n"; 71 | printf "ok %d\n",$t++; 72 | printf "ok %d\n",$t++; 73 | printf "ok %d\n",$t++; 74 | } 75 | 76 | $ftp->quit or do { 77 | print STDERR $ftp->message,"\n"; 78 | print "not "; 79 | }; 80 | 81 | printf "ok %d\n",$t++; 82 | -------------------------------------------------------------------------------- /lib/Net/FTP/I.pm: -------------------------------------------------------------------------------- 1 | ## 2 | ## Package to read/write on BINARY data connections 3 | ## 4 | 5 | package Net::FTP::I; 6 | 7 | use 5.008001; 8 | 9 | use strict; 10 | use warnings; 11 | 12 | use Carp; 13 | use Net::FTP::dataconn; 14 | 15 | our @ISA = qw(Net::FTP::dataconn); 16 | our $VERSION = "3.16"; 17 | 18 | our $buf; 19 | 20 | sub read { 21 | my $data = shift; 22 | local *buf = \$_[0]; 23 | shift; 24 | my $size = shift || croak 'read($buf,$size,[$timeout])'; 25 | my $timeout = @_ ? shift: $data->timeout; 26 | 27 | my $n; 28 | 29 | if ($size > length ${*$data} and !${*$data}{'net_ftp_eof'}) { 30 | $data->can_read($timeout) 31 | or croak "Timeout"; 32 | 33 | my $blksize = ${*$data}{'net_ftp_blksize'}; 34 | $blksize = $size if $size > $blksize; 35 | 36 | unless ($n = sysread($data, ${*$data}, $blksize, length ${*$data})) { 37 | return unless defined $n; 38 | ${*$data}{'net_ftp_eof'} = 1; 39 | } 40 | } 41 | 42 | $buf = substr(${*$data}, 0, $size); 43 | 44 | $n = length($buf); 45 | 46 | substr(${*$data}, 0, $n) = ''; 47 | 48 | ${*$data}{'net_ftp_bytesread'} += $n; 49 | 50 | $n; 51 | } 52 | 53 | 54 | sub write { 55 | my $data = shift; 56 | local *buf = \$_[0]; 57 | shift; 58 | my $size = shift || croak 'write($buf,$size,[$timeout])'; 59 | my $timeout = @_ ? shift: $data->timeout; 60 | 61 | # If the remote server has closed the connection we will be signal'd 62 | # when we write. This can happen if the disk on the remote server fills up 63 | 64 | local $SIG{PIPE} = 'IGNORE' 65 | unless ($SIG{PIPE} || '') eq 'IGNORE' 66 | or $^O eq 'MacOS'; 67 | my $sent = $size; 68 | my $off = 0; 69 | 70 | my $blksize = ${*$data}{'net_ftp_blksize'}; 71 | while ($sent > 0) { 72 | $data->can_write($timeout) 73 | or croak "Timeout"; 74 | 75 | my $n = syswrite($data, $buf, $sent > $blksize ? $blksize : $sent, $off); 76 | return unless defined($n); 77 | $sent -= $n; 78 | $off += $n; 79 | } 80 | 81 | $size; 82 | } 83 | 84 | 1; 85 | -------------------------------------------------------------------------------- /t/pop3_ipv6.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use 5.008001; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | use Test::More; 9 | 10 | BEGIN { 11 | if (!eval { require Socket }) { 12 | plan skip_all => "no Socket"; 13 | } 14 | elsif (ord('A') == 193 && !eval { require Convert::EBCDIC }) { 15 | plan skip_all => "EBCDIC but no Convert::EBCDIC"; 16 | } 17 | } 18 | 19 | use Config; 20 | use File::Temp 'tempfile'; 21 | use Net::POP3; 22 | 23 | my $debug = 0; # Net::POP3->new( Debug => .. ) 24 | 25 | my $inet6class = Net::POP3->can_inet6; 26 | plan skip_all => "no IPv6 support found in Net::POP3" if ! $inet6class; 27 | 28 | plan skip_all => "fork not supported on this platform" 29 | unless $Config::Config{d_fork} || $Config::Config{d_pseudofork} || 30 | (($^O eq 'MSWin32' || $^O eq 'NetWare') and 31 | $Config::Config{useithreads} and 32 | $Config::Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/); 33 | 34 | my $srv = $inet6class->new( 35 | LocalAddr => '::1', 36 | Listen => 10 37 | ); 38 | plan skip_all => "cannot create listener on ::1: $!" if ! $srv; 39 | my $saddr = "[".$srv->sockhost."]".':'.$srv->sockport; 40 | note("server on $saddr"); 41 | 42 | plan tests => 1; 43 | 44 | defined( my $pid = fork()) or die "fork failed: $!"; 45 | exit(pop3_server()) if ! $pid; 46 | 47 | my $cl = Net::POP3->new($saddr, Debug => $debug); 48 | note("created Net::POP3 object"); 49 | if (!$cl) { 50 | fail("IPv6 POP3 connect failed"); 51 | } else { 52 | $cl->quit; 53 | pass("IPv6 success"); 54 | } 55 | wait; 56 | 57 | sub pop3_server { 58 | my $cl = $srv->accept or die "accept failed: $!"; 59 | print $cl "+OK localhost ready\r\n"; 60 | while (<$cl>) { 61 | my ($cmd,$arg) = m{^(\S+)(?: +(.*))?\r\n} or die $_; 62 | $cmd = uc($cmd); 63 | if ($cmd eq 'QUIT' ) { 64 | print $cl "+OK bye\r\n"; 65 | last; 66 | } elsif ( $cmd eq 'CAPA' ) { 67 | print $cl "+OK\r\n". 68 | ".\r\n"; 69 | } else { 70 | diag("received unknown command: $cmd"); 71 | print "-ERR unknown cmd\r\n"; 72 | } 73 | } 74 | 75 | note("POP3 dialog done"); 76 | return 0; 77 | } 78 | -------------------------------------------------------------------------------- /t/nntp_ipv6.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use 5.008001; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | use Test::More; 9 | 10 | BEGIN { 11 | if (!eval { require Socket }) { 12 | plan skip_all => "no Socket"; 13 | } 14 | elsif (ord('A') == 193 && !eval { require Convert::EBCDIC }) { 15 | plan skip_all => "EBCDIC but no Convert::EBCDIC"; 16 | } 17 | } 18 | 19 | use Config; 20 | use File::Temp 'tempfile'; 21 | use Net::NNTP; 22 | 23 | my $debug = 0; # Net::NNTP->new( Debug => .. ) 24 | 25 | my $inet6class = Net::NNTP->can_inet6; 26 | plan skip_all => "no IPv6 support found in Net::NNTP" if ! $inet6class; 27 | 28 | plan skip_all => "fork not supported on this platform" 29 | unless $Config::Config{d_fork} || $Config::Config{d_pseudofork} || 30 | (($^O eq 'MSWin32' || $^O eq 'NetWare') and 31 | $Config::Config{useithreads} and 32 | $Config::Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/); 33 | 34 | my $srv = $inet6class->new( 35 | LocalAddr => '::1', 36 | Listen => 10 37 | ); 38 | plan skip_all => "cannot create listener on ::1: $!" if ! $srv; 39 | my $host = $srv->sockhost; 40 | my $port = $srv->sockport; 41 | note("server on $host port $port"); 42 | 43 | plan tests => 1; 44 | 45 | defined( my $pid = fork()) or die "fork failed: $!"; 46 | exit(nntp_server()) if ! $pid; 47 | 48 | my $cl = Net::NNTP->new(Host => $host, Port => $port,, Debug => $debug); 49 | note("created Net::NNTP object"); 50 | if (!$cl) { 51 | fail("IPv6 NNTP connect failed"); 52 | } else { 53 | $cl->quit; 54 | pass("IPv6 success"); 55 | } 56 | wait; 57 | 58 | sub nntp_server { 59 | my $ssl = shift; 60 | my $cl = $srv->accept or die "accept failed: $!"; 61 | print $cl "200 nntp.example.com\r\n"; 62 | while (<$cl>) { 63 | my ($cmd,$arg) = m{^(\S+)(?: +(.*))?\r\n} or die $_; 64 | $cmd = uc($cmd); 65 | if ($cmd eq 'QUIT' ) { 66 | print $cl "205 bye\r\n"; 67 | last; 68 | } elsif ( $cmd eq 'MODE' ) { 69 | print $cl "201 Posting denied\r\n"; 70 | } else { 71 | diag("received unknown command: $cmd"); 72 | print "500 unknown cmd\r\n"; 73 | } 74 | } 75 | note("NNTP dialog done"); 76 | return 0; 77 | } 78 | -------------------------------------------------------------------------------- /t/smtp_ipv6.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use 5.008001; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | use Test::More; 9 | 10 | BEGIN { 11 | if (!eval { require Socket }) { 12 | plan skip_all => "no Socket"; 13 | } 14 | elsif (ord('A') == 193 && !eval { require Convert::EBCDIC }) { 15 | plan skip_all => "EBCDIC but no Convert::EBCDIC"; 16 | } 17 | } 18 | 19 | use Config; 20 | use File::Temp 'tempfile'; 21 | use Net::SMTP; 22 | 23 | my $debug = 0; # Net::SMTP->new( Debug => .. ) 24 | 25 | my $inet6class = Net::SMTP->can_inet6; 26 | plan skip_all => "no IPv6 support found in Net::SMTP" if ! $inet6class; 27 | 28 | plan skip_all => "fork not supported on this platform" 29 | unless $Config::Config{d_fork} || $Config::Config{d_pseudofork} || 30 | (($^O eq 'MSWin32' || $^O eq 'NetWare') and 31 | $Config::Config{useithreads} and 32 | $Config::Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/); 33 | 34 | my $srv = $inet6class->new( 35 | LocalAddr => '::1', 36 | Listen => 10 37 | ); 38 | plan skip_all => "cannot create listener on ::1: $!" if ! $srv; 39 | my $saddr = "[".$srv->sockhost."]".':'.$srv->sockport; 40 | note("server on $saddr"); 41 | 42 | plan tests => 1; 43 | 44 | defined( my $pid = fork()) or die "fork failed: $!"; 45 | exit(smtp_server()) if ! $pid; 46 | 47 | my $cl = Net::SMTP->new($saddr, Debug => $debug); 48 | note("created Net::SMTP object"); 49 | if (!$cl) { 50 | fail("IPv6 SMTP connect failed"); 51 | } else { 52 | $cl->quit; 53 | pass("IPv6 success"); 54 | } 55 | wait; 56 | 57 | sub smtp_server { 58 | my $cl = $srv->accept or die "accept failed: $!"; 59 | print $cl "220 welcome\r\n"; 60 | while (<$cl>) { 61 | my ($cmd,$arg) = m{^(\S+)(?: +(.*))?\r\n} or die $_; 62 | $cmd = uc($cmd); 63 | if ($cmd eq 'QUIT' ) { 64 | print $cl "250 bye\r\n"; 65 | last; 66 | } elsif ( $cmd eq 'HELO' ) { 67 | print $cl "250 localhost\r\n"; 68 | } elsif ( $cmd eq 'EHLO' ) { 69 | print $cl "250-localhost\r\n". 70 | "250 HELP\r\n"; 71 | } else { 72 | diag("received unknown command: $cmd"); 73 | print "500 unknown cmd\r\n"; 74 | } 75 | } 76 | 77 | note("SMTP dialog done"); 78 | return 0; 79 | } 80 | -------------------------------------------------------------------------------- /t/config.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use 5.008001; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | use Test::More; 9 | 10 | BEGIN { 11 | if (!eval { require Socket }) { 12 | plan skip_all => "no Socket"; 13 | } 14 | elsif (ord('A') == 193 && !eval { require Convert::EBCDIC }) { 15 | plan skip_all => "EBCDIC but no Convert::EBCDIC"; 16 | } 17 | else { 18 | plan tests => 10; 19 | } 20 | 21 | undef *{Socket::inet_aton}; 22 | undef *{Socket::inet_ntoa}; 23 | $INC{'Socket.pm'} = 1; 24 | } 25 | 26 | package Socket; 27 | 28 | sub import { 29 | my $pkg = caller(); 30 | no strict 'refs'; ## no critic (TestingAndDebugging::ProhibitNoStrict) 31 | *{ $pkg . '::inet_aton' } = \&inet_aton; 32 | *{ $pkg . '::inet_ntoa' } = \&inet_ntoa; 33 | } 34 | 35 | my $fail = 0; 36 | my %names; 37 | 38 | sub set_fail { 39 | $fail = shift; 40 | } 41 | 42 | sub inet_aton { 43 | return if $fail; 44 | my $num = unpack('N', pack('C*', split(/\./, $_[0]))); 45 | $names{$num} = $_[0]; 46 | return $num; 47 | } 48 | 49 | sub inet_ntoa { 50 | return if $fail; 51 | return $names{$_[0]}; 52 | } 53 | 54 | 55 | package main; 56 | 57 | use Net::Config; 58 | ok( exists $INC{'Net/Config.pm'}, 'Net::Config should have been used' ); 59 | ok( keys %NetConfig, '%NetConfig should be imported' ); 60 | 61 | Socket::set_fail(1); 62 | undef $NetConfig{'ftp_firewall'}; 63 | is( Net::Config->requires_firewall(), 0, 64 | 'requires_firewall() should return 0 without ftp_firewall defined' ); 65 | 66 | $NetConfig{'ftp_firewall'} = 1; 67 | is( Net::Config->requires_firewall('a.host.not.there'), -1, 68 | '... should return -1 without a valid hostname' ); 69 | 70 | Socket::set_fail(0); 71 | delete $NetConfig{'local_netmask'}; 72 | is( Net::Config->requires_firewall('127.0.0.1'), 0, 73 | '... should return 0 without local_netmask defined' ); 74 | 75 | $NetConfig{'local_netmask'} = '127.0.0.1/24'; 76 | is( Net::Config->requires_firewall('127.0.0.1'), 0, 77 | '... should return false if host is within netmask' ); 78 | is( Net::Config->requires_firewall('192.168.10.0'), 1, 79 | '... should return true if host is outside netmask' ); 80 | 81 | # now try more netmasks 82 | $NetConfig{'local_netmask'} = [ '127.0.0.1/24', '10.0.0.0/8' ]; 83 | is( Net::Config->requires_firewall('10.10.255.254'), 0, 84 | '... should find success with mutiple local netmasks' ); 85 | is( Net::Config->requires_firewall('192.168.10.0'), 1, 86 | '... should handle failure with multiple local netmasks' ); 87 | 88 | is( \&Net::Config::is_external, \&Net::Config::requires_firewall, 89 | 'is_external() should be an alias for requires_firewall()' ); 90 | -------------------------------------------------------------------------------- /t/datasend.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use 5.008001; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | use Test::More; 9 | 10 | BEGIN { 11 | if (!eval { require Socket }) { 12 | plan skip_all => "no Socket"; 13 | } 14 | elsif (ord('A') == 193 && !eval { require Convert::EBCDIC }) { 15 | plan skip_all => "EBCDIC but no Convert::EBCDIC"; 16 | } 17 | else { 18 | plan tests => 54; 19 | } 20 | } 21 | 22 | BEGIN { 23 | package Foo; 24 | 25 | use IO::File; 26 | use Net::Cmd; 27 | our @ISA = qw(Net::Cmd IO::File); 28 | 29 | sub timeout { 0 } 30 | 31 | sub new { 32 | my $fh = shift->new_tmpfile; 33 | binmode($fh); 34 | $fh; 35 | } 36 | 37 | sub output { 38 | my $self = shift; 39 | seek($self,0,0); 40 | local $/ = undef; 41 | scalar(<$self>); 42 | } 43 | 44 | sub response { 45 | return Net::Cmd::CMD_OK; 46 | } 47 | } 48 | 49 | sub check { 50 | my $expect = pop; 51 | my $cmd = Foo->new; 52 | ok($cmd->datasend, 'datasend') unless @_; 53 | foreach my $line (@_) { 54 | ok($cmd->datasend($line), 'datasend'); 55 | } 56 | ok($cmd->dataend, 'dataend'); 57 | is( 58 | unpack("H*",$cmd->output), 59 | unpack("H*",$expect) 60 | ); 61 | } 62 | 63 | my $cmd; 64 | 65 | check( 66 | # nothing 67 | 68 | ".\015\012" 69 | ); 70 | 71 | check( 72 | "a", 73 | 74 | "a\015\012.\015\012", 75 | ); 76 | 77 | check( 78 | "a\r", 79 | 80 | "a\015\015\012.\015\012", 81 | ); 82 | 83 | check( 84 | "a\rb", 85 | 86 | "a\015b\015\012.\015\012", 87 | ); 88 | 89 | check( 90 | "a\rb\n", 91 | 92 | "a\015b\015\012.\015\012", 93 | ); 94 | 95 | check( 96 | "a\rb\n\n", 97 | 98 | "a\015b\015\012\015\012.\015\012", 99 | ); 100 | 101 | check( 102 | "a\r", 103 | "\nb", 104 | 105 | "a\015\012b\015\012.\015\012", 106 | ); 107 | 108 | check( 109 | "a\r", 110 | "\nb\n", 111 | 112 | "a\015\012b\015\012.\015\012", 113 | ); 114 | 115 | check( 116 | "a\r", 117 | "\nb\r\n", 118 | 119 | "a\015\012b\015\012.\015\012", 120 | ); 121 | 122 | check( 123 | "a\r", 124 | "\nb\r\n\n", 125 | 126 | "a\015\012b\015\012\015\012.\015\012", 127 | ); 128 | 129 | check( 130 | "a\n.b\n", 131 | 132 | "a\015\012..b\015\012.\015\012", 133 | ); 134 | 135 | check( 136 | ".a\n.b\n", 137 | 138 | "..a\015\012..b\015\012.\015\012", 139 | ); 140 | 141 | check( 142 | ".a\n", 143 | ".b\n", 144 | 145 | "..a\015\012..b\015\012.\015\012", 146 | ); 147 | 148 | check( 149 | ".a", 150 | ".b\n", 151 | 152 | "..a.b\015\012.\015\012", 153 | ); 154 | 155 | check( 156 | "a\n.", 157 | 158 | "a\015\012..\015\012.\015\012", 159 | ); 160 | 161 | # Test that datasend() plays nicely with bytes in an upgraded string, 162 | # even though the input should really be encode()d already. 163 | check( 164 | substr("\x{100}", 0, 0) . "\x{e9}", 165 | 166 | "\x{e9}\015\012.\015\012" 167 | ); 168 | -------------------------------------------------------------------------------- /lib/Net/FTP/A.pm: -------------------------------------------------------------------------------- 1 | ## 2 | ## Package to read/write on ASCII data connections 3 | ## 4 | 5 | package Net::FTP::A; 6 | 7 | use 5.008001; 8 | 9 | use strict; 10 | use warnings; 11 | 12 | use Carp; 13 | use Net::FTP::dataconn; 14 | 15 | our @ISA = qw(Net::FTP::dataconn); 16 | our $VERSION = "3.16"; 17 | 18 | our $buf; 19 | 20 | sub read { 21 | my $data = shift; 22 | local *buf = \$_[0]; 23 | shift; 24 | my $size = shift || croak 'read($buf,$size,[$offset])'; 25 | my $timeout = @_ ? shift: $data->timeout; 26 | 27 | if (length(${*$data}) < $size && !${*$data}{'net_ftp_eof'}) { 28 | my $blksize = ${*$data}{'net_ftp_blksize'}; 29 | $blksize = $size if $size > $blksize; 30 | 31 | my $l = 0; 32 | my $n; 33 | 34 | READ: 35 | { 36 | my $readbuf = defined(${*$data}{'net_ftp_cr'}) ? "\015" : ''; 37 | 38 | $data->can_read($timeout) 39 | or croak "Timeout"; 40 | 41 | if ($n = sysread($data, $readbuf, $blksize, length $readbuf)) { 42 | ${*$data}{'net_ftp_bytesread'} += $n; 43 | ${*$data}{'net_ftp_cr'} = 44 | substr($readbuf, -1) eq "\015" 45 | ? chop($readbuf) 46 | : undef; 47 | } 48 | else { 49 | return 50 | unless defined $n; 51 | 52 | ${*$data}{'net_ftp_eof'} = 1; 53 | } 54 | 55 | $readbuf =~ s/\015\012/\n/sgo; 56 | ${*$data} .= $readbuf; 57 | 58 | unless (length(${*$data})) { 59 | 60 | redo READ 61 | if ($n > 0); 62 | 63 | $size = length(${*$data}) 64 | if ($n == 0); 65 | } 66 | } 67 | } 68 | 69 | $buf = substr(${*$data}, 0, $size); 70 | substr(${*$data}, 0, $size) = ''; 71 | 72 | length $buf; 73 | } 74 | 75 | 76 | sub write { 77 | my $data = shift; 78 | local *buf = \$_[0]; 79 | shift; 80 | my $size = shift || croak 'write($buf,$size,[$timeout])'; 81 | my $timeout = @_ ? shift: $data->timeout; 82 | 83 | my $nr = (my $tmp = substr($buf, 0, $size)) =~ tr/\r\n/\015\012/; 84 | $tmp =~ s/(?can_write($timeout) 103 | or croak "Timeout"; 104 | 105 | $off += $wrote; 106 | $wrote = syswrite($data, substr($tmp, $off), $len > $blksize ? $blksize : $len); 107 | return 108 | unless defined($wrote); 109 | $len -= $wrote; 110 | } 111 | 112 | $size; 113 | } 114 | 115 | 1; 116 | -------------------------------------------------------------------------------- /t/pod_coverage.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | #=============================================================================== 3 | # 4 | # t/pod_coverage.t 5 | # 6 | # DESCRIPTION 7 | # Test script to check POD coverage. 8 | # 9 | # COPYRIGHT 10 | # Copyright (C) 2014, 2015, 2020 Steve Hay. All rights reserved. 11 | # 12 | # LICENCE 13 | # This script is free software; you can redistribute it and/or modify it under 14 | # the same terms as Perl itself, i.e. under the terms of either the GNU 15 | # General Public License or the Artistic License, as specified in the LICENCE 16 | # file. 17 | # 18 | #=============================================================================== 19 | 20 | use 5.008001; 21 | 22 | use strict; 23 | use warnings; 24 | 25 | use Test::More; 26 | 27 | #=============================================================================== 28 | # MAIN PROGRAM 29 | #=============================================================================== 30 | 31 | MAIN: { 32 | plan skip_all => 'Author testing only' unless $ENV{AUTHOR_TESTING}; 33 | 34 | my $ok = eval { 35 | require Test::Pod::Coverage; 36 | Test::Pod::Coverage->import(); 37 | 1; 38 | }; 39 | 40 | if (not $ok) { 41 | plan skip_all => 'Test::Pod::Coverage required to test POD coverage'; 42 | } 43 | elsif ($Test::Pod::Coverage::VERSION < 0.08) { 44 | plan skip_all => 'Test::Pod::Coverage 0.08 or higher required to test POD coverage'; 45 | } 46 | elsif (!eval { require Socket }) { 47 | plan skip_all => 'no Socket'; 48 | } 49 | elsif (ord('A') == 193 && !eval { require Convert::EBCDIC }) { 50 | plan skip_all => 'EBCDIC but no Convert::EBCDIC'; 51 | } 52 | else { 53 | plan tests => 12; 54 | my $params = { coverage_class => qw(Pod::Coverage::CountParents) }; 55 | pod_coverage_ok('Net::Cmd', { 56 | %$params, 57 | also_private => [qw(toascii toebcdic set_status)] 58 | }); 59 | pod_coverage_ok('Net::Config', { 60 | %$params, 61 | also_private => [qw(is_external)] 62 | }); 63 | pod_coverage_ok('Net::Domain', $params); 64 | pod_coverage_ok('Net::FTP', { 65 | %$params, 66 | also_private => [qw(authorise lsl ebcdic byte cmd)] 67 | }); 68 | pod_coverage_ok('Net::Netrc', $params); 69 | pod_coverage_ok('Net::NNTP', $params); 70 | pod_coverage_ok('Net::POP3', $params); 71 | pod_coverage_ok('Net::SMTP', { 72 | %$params, 73 | also_private => [qw(datafh supports)] 74 | }); 75 | pod_coverage_ok('Net::Time', $params); 76 | pod_coverage_ok('Net::FTP::A', $params); 77 | pod_coverage_ok('Net::FTP::dataconn', { 78 | %$params, 79 | also_private => [qw(can_read can_write cmd reading)] 80 | }); 81 | pod_coverage_ok('Net::FTP::I', $params); 82 | } 83 | } 84 | 85 | #=============================================================================== 86 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | NAME 2 | 3 | libnet - Simple API to the client side of various internet protocols 4 | 5 | DESCRIPTION 6 | 7 | libnet is a collection of Perl modules which provides a simple and 8 | consistent programming interface (API) to the client side of various 9 | protocols used in the internet community. 10 | 11 | For details of each protocol please refer to the RFC. RFCs can be found in 12 | various places on the web, for a starting point look at: 13 | 14 | https://www.rfc-editor.org/ 15 | 16 | The RFCs implemented in this distribution are: 17 | 18 | Net::FTP RFC959 File Transfer Protocol 19 | Net::NNTP RFC977 Network News Transfer Protocol 20 | Net::POP3 RFC1939 Post Office Protocol 3 21 | Net::SMTP RFC821 Simple Mail Transfer Protocol 22 | Net::Time RFC867 Daytime Protocol 23 | Net::Time RFC868 Time Protocol 24 | 25 | EXAMPLES 26 | 27 | The demos directory does contain a few demo scripts. These should be run 28 | from the top directory like: 29 | 30 | demos/smtp.self -user my-email-address -debug 31 | 32 | However, I do not guarantee these scripts to work. 33 | 34 | FEEDBACK 35 | 36 | Patches, bug reports, suggestions or any other feedback is welcome. 37 | 38 | Patches can be sent as GitHub pull requests at 39 | . 40 | 41 | Bug reports and suggestions can be made on the CPAN Request Tracker at 42 | . 43 | 44 | (Most of the modules in this library have an option to output a debug 45 | transcript to STDERR. When reporting bugs/problems please, if possible, 46 | include a transcript of a run.) 47 | 48 | Currently active requests on the CPAN Request Tracker can be viewed at 49 | . 50 | 51 | Please test this distribution. See CPAN Testers at 52 | for details of how to get involved. 53 | 54 | Previous test results on CPAN Testers can be viewed at 55 | and 56 | . 57 | 58 | AVAILABILITY 59 | 60 | The latest version of this module is available from CPAN (see "CPAN" in 61 | perlmodlib for details) at 62 | 63 | or 64 | 65 | or 66 | 67 | . 68 | 69 | The latest source code is available from GitHub at 70 | . 71 | 72 | INSTALLATION 73 | 74 | See the INSTALL file. 75 | 76 | COPYRIGHT 77 | 78 | Copyright (C) 1996-2007 Graham Barr. All rights reserved. 79 | Copyright (C) 2013-2017, 2020-2023 Steve Hay. All rights reserved. 80 | 81 | LICENCE 82 | 83 | This distribution is free software; you can redistribute it and/or modify it 84 | under the same terms as Perl itself, i.e. under the terms of either the GNU 85 | General Public License or the Artistic License, as specified in the LICENCE 86 | file. 87 | -------------------------------------------------------------------------------- /MANIFEST: -------------------------------------------------------------------------------- 1 | Artistic The "Artistic License" 2 | Changes Differences from previous version 3 | Configure Configuration script 4 | Copying The GNU General Public License 5 | demos/ftp Demo script for Net::FTP 6 | demos/nntp Demo script for Net::NNTP 7 | demos/nntp.mirror Demo script for Net::NNTP 8 | demos/pop3 Demo script for Net::POP3 9 | demos/smtp.self Demo script for Net::SMTP 10 | demos/time Demo script for Net::Time 11 | INSTALL Detailed installation instructions 12 | lib/Net/Cmd.pm Net::Cmd Perl module 13 | lib/Net/Config.pm Net::Config Perl module 14 | lib/Net/Domain.pm Net::Domain Perl module 15 | lib/Net/FTP.pm Net::FTP Perl module 16 | lib/Net/FTP/A.pm Net::FTP::A Perl module 17 | lib/Net/FTP/dataconn.pm Net::FTP::dataconn Perl module 18 | lib/Net/FTP/E.pm Net::FTP::E Perl module 19 | lib/Net/FTP/I.pm Net::FTP::I Perl module 20 | lib/Net/FTP/L.pm Net::FTP::L Perl module 21 | lib/Net/libnetFAQ.pod Frequently Asked Questions 22 | lib/Net/Netrc.pm Net::Netrc Perl module 23 | lib/Net/NNTP.pm Net::NNTP Perl module 24 | lib/Net/POP3.pm Net::POP3 Perl module 25 | lib/Net/SMTP.pm Net::SMTP Perl module 26 | lib/Net/Time.pm Net::Time Perl module 27 | LICENCE The Licence 28 | Makefile.PL Makefile writer 29 | MANIFEST This list of files 30 | MANIFEST.SKIP Manifest skip specs 31 | README The Instructions 32 | t/changes.t See if Changes file format is OK 33 | t/config.t Test script 34 | t/critic.t See if coding style is OK 35 | t/datasend.t Test script 36 | t/external/ftp-ssl.t Test script 37 | t/external/pop3-ssl.t Test script 38 | t/external/smtp-ssl.t Test script 39 | t/ftp.t Test script 40 | t/hostname.t Test script 41 | t/netrc.t Test script 42 | t/nntp.t Test script 43 | t/nntp_ipv6.t Test script 44 | t/nntp_ssl.t Test script 45 | t/pod.t See if POD is OK 46 | t/pod_coverage.t See if POD coverage is OK 47 | t/pop3_ipv6.t Test script 48 | t/pop3_ssl.t Test script 49 | t/require.t Test script 50 | t/smtp.t Test script 51 | t/smtp_ipv6.t Test script 52 | t/smtp_ssl.t Test script 53 | t/time.t Test script 54 | -------------------------------------------------------------------------------- /t/pop3_ssl.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use 5.008001; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | use Test::More; 9 | 10 | BEGIN { 11 | if (!eval { require Socket }) { 12 | plan skip_all => "no Socket"; 13 | } 14 | elsif (ord('A') == 193 && !eval { require Convert::EBCDIC }) { 15 | plan skip_all => "EBCDIC but no Convert::EBCDIC"; 16 | } 17 | } 18 | 19 | use Config; 20 | use File::Temp 'tempfile'; 21 | use Net::POP3; 22 | 23 | my $debug = 0; # Net::POP3 Debug => .. 24 | 25 | my $parent = 0; 26 | 27 | plan skip_all => "no SSL support found in Net::POP3" if ! Net::POP3->can_ssl; 28 | 29 | plan skip_all => "fork not supported on this platform" 30 | unless $Config::Config{d_fork} || $Config::Config{d_pseudofork} || 31 | (($^O eq 'MSWin32' || $^O eq 'NetWare') and 32 | $Config::Config{useithreads} and 33 | $Config::Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/); 34 | 35 | my $srv = IO::Socket::INET->new( 36 | LocalAddr => '127.0.0.1', 37 | Listen => 10 38 | ); 39 | plan skip_all => "cannot create listener on localhost: $!" if ! $srv; 40 | my $saddr = $srv->sockhost.':'.$srv->sockport; 41 | 42 | plan tests => 2; 43 | 44 | require IO::Socket::SSL::Utils; 45 | my ($ca,$key) = IO::Socket::SSL::Utils::CERT_create( CA => 1 ); 46 | my ($fh,$cafile) = tempfile(); 47 | print $fh IO::Socket::SSL::Utils::PEM_cert2string($ca); 48 | close($fh); 49 | 50 | $parent = $$; 51 | END { unlink($cafile) if $$ == $parent } 52 | 53 | my ($cert) = IO::Socket::SSL::Utils::CERT_create( 54 | subject => { CN => 'pop3.example.com' }, 55 | issuer_cert => $ca, issuer_key => $key, 56 | key => $key 57 | ); 58 | 59 | test(1); # direct ssl 60 | test(0); # starttls 61 | 62 | 63 | sub test { 64 | my $ssl = shift; 65 | defined( my $pid = fork()) or die "fork failed: $!"; 66 | exit(pop3_server($ssl)) if ! $pid; 67 | pop3_client($ssl); 68 | wait; 69 | } 70 | 71 | 72 | sub pop3_client { 73 | my $ssl = shift; 74 | my %sslopt = ( 75 | SSL_verifycn_name => 'pop3.example.com', 76 | SSL_ca_file => $cafile 77 | ); 78 | $sslopt{SSL} = 1 if $ssl; 79 | my $cl = Net::POP3->new($saddr, %sslopt, Debug => $debug); 80 | note("created Net::POP3 object"); 81 | if (!$cl) { 82 | fail( ($ssl ? "SSL ":"" )."POP3 connect failed"); 83 | } elsif ($ssl) { 84 | $cl->quit; 85 | pass("SSL POP3 connect success"); 86 | } elsif ( ! $cl->starttls ) { 87 | no warnings 'once'; 88 | fail("starttls failed: $IO::Socket::SSL::SSL_ERROR"); 89 | } else { 90 | $cl->quit; 91 | pass("starttls success"); 92 | } 93 | } 94 | 95 | sub pop3_server { 96 | my $ssl = shift; 97 | my $cl = $srv->accept or die "accept failed: $!"; 98 | my %sslargs = ( 99 | SSL_server => 1, 100 | SSL_cert => $cert, 101 | SSL_key => $key, 102 | ); 103 | if ( $ssl ) { 104 | if ( ! IO::Socket::SSL->start_SSL($cl, %sslargs)) { 105 | diag("initial ssl handshake with client failed"); 106 | return; 107 | } 108 | } 109 | 110 | print $cl "+OK localhost ready\r\n"; 111 | while (<$cl>) { 112 | my ($cmd,$arg) = m{^(\S+)(?: +(.*))?\r\n} or die $_; 113 | $cmd = uc($cmd); 114 | if ($cmd eq 'QUIT' ) { 115 | print $cl "+OK bye\r\n"; 116 | last; 117 | } elsif ( $cmd eq 'CAPA' ) { 118 | print $cl "+OK\r\n". 119 | ( $ssl ? "" : "STLS\r\n" ). 120 | ".\r\n"; 121 | } elsif ( ! $ssl and $cmd eq 'STLS' ) { 122 | print $cl "+OK starting ssl\r\n"; 123 | if ( ! IO::Socket::SSL->start_SSL($cl, %sslargs)) { 124 | diag("initial ssl handshake with client failed"); 125 | return; 126 | } 127 | $ssl = 1; 128 | } else { 129 | diag("received unknown command: $cmd"); 130 | print "-ERR unknown cmd\r\n"; 131 | } 132 | } 133 | 134 | note("POP3 dialog done"); 135 | } 136 | -------------------------------------------------------------------------------- /t/nntp_ssl.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use 5.008001; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | use Test::More; 9 | 10 | BEGIN { 11 | if (!eval { require Socket }) { 12 | plan skip_all => "no Socket"; 13 | } 14 | elsif (ord('A') == 193 && !eval { require Convert::EBCDIC }) { 15 | plan skip_all => "EBCDIC but no Convert::EBCDIC"; 16 | } 17 | } 18 | 19 | use Config; 20 | use File::Temp 'tempfile'; 21 | use Net::NNTP; 22 | 23 | my $debug = 0; # Net::NNTP Debug => .. 24 | 25 | my $parent = 0; 26 | 27 | plan skip_all => "no SSL support found in Net::NNTP" if ! Net::NNTP->can_ssl; 28 | 29 | plan skip_all => "fork not supported on this platform" 30 | unless $Config::Config{d_fork} || $Config::Config{d_pseudofork} || 31 | (($^O eq 'MSWin32' || $^O eq 'NetWare') and 32 | $Config::Config{useithreads} and 33 | $Config::Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/); 34 | 35 | my $srv = IO::Socket::INET->new( 36 | LocalAddr => '127.0.0.1', 37 | Listen => 10 38 | ); 39 | plan skip_all => "cannot create listener on localhost: $!" if ! $srv; 40 | my $host = $srv->sockhost; 41 | my $port = $srv->sockport; 42 | 43 | plan tests => 2; 44 | 45 | require IO::Socket::SSL::Utils; 46 | my ($ca,$key) = IO::Socket::SSL::Utils::CERT_create( CA => 1 ); 47 | my ($fh,$cafile) = tempfile(); 48 | print $fh IO::Socket::SSL::Utils::PEM_cert2string($ca); 49 | close($fh); 50 | 51 | $parent = $$; 52 | END { unlink($cafile) if $$ == $parent } 53 | 54 | my ($cert) = IO::Socket::SSL::Utils::CERT_create( 55 | subject => { CN => 'nntp.example.com' }, 56 | issuer_cert => $ca, issuer_key => $key, 57 | key => $key 58 | ); 59 | 60 | test(1); # direct ssl 61 | test(0); # starttls 62 | 63 | 64 | sub test { 65 | my $ssl = shift; 66 | defined( my $pid = fork()) or die "fork failed: $!"; 67 | exit(nntp_server($ssl)) if ! $pid; 68 | nntp_client($ssl); 69 | wait; 70 | } 71 | 72 | 73 | sub nntp_client { 74 | my $ssl = shift; 75 | my %sslopt = ( 76 | SSL_verifycn_name => 'nntp.example.com', 77 | SSL_ca_file => $cafile 78 | ); 79 | $sslopt{SSL} = 1 if $ssl; 80 | my $cl = Net::NNTP->new( 81 | Host => $host, 82 | Port => $port, 83 | Debug => $debug, 84 | %sslopt, 85 | ); 86 | note("created Net::NNTP object"); 87 | if (!$cl) { 88 | fail( ($ssl ? "SSL ":"" )."NNTP connect failed"); 89 | } elsif ($ssl) { 90 | $cl->quit; 91 | pass("SSL NNTP connect success"); 92 | } elsif ( ! $cl->starttls ) { 93 | no warnings 'once'; 94 | fail("starttls failed: $IO::Socket::SSL::SSL_ERROR"); 95 | } else { 96 | $cl->quit; 97 | pass("starttls success"); 98 | } 99 | } 100 | 101 | sub nntp_server { 102 | my $ssl = shift; 103 | my $cl = $srv->accept or die "accept failed: $!"; 104 | my %sslargs = ( 105 | SSL_server => 1, 106 | SSL_cert => $cert, 107 | SSL_key => $key, 108 | ); 109 | if ( $ssl ) { 110 | if ( ! IO::Socket::SSL->start_SSL($cl, %sslargs)) { 111 | diag("initial ssl handshake with client failed"); 112 | return; 113 | } 114 | } 115 | 116 | print $cl "200 nntp.example.com\r\n"; 117 | while (<$cl>) { 118 | my ($cmd,$arg) = m{^(\S+)(?: +(.*))?\r\n} or die $_; 119 | $cmd = uc($cmd); 120 | if ($cmd eq 'QUIT' ) { 121 | print $cl "205 bye\r\n"; 122 | last; 123 | } elsif ( $cmd eq 'MODE' ) { 124 | print $cl "201 Posting denied\r\n"; 125 | } elsif ( ! $ssl and $cmd eq 'STARTTLS' ) { 126 | print $cl "382 Continue with TLS negotiation\r\n"; 127 | if ( ! IO::Socket::SSL->start_SSL($cl, %sslargs)) { 128 | diag("initial ssl handshake with client failed"); 129 | return; 130 | } 131 | $ssl = 1; 132 | } else { 133 | diag("received unknown command: $cmd"); 134 | print "500 unknown cmd\r\n"; 135 | } 136 | } 137 | 138 | note("NNTP dialog done"); 139 | } 140 | -------------------------------------------------------------------------------- /t/smtp_ssl.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use 5.008001; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | use Test::More; 9 | 10 | BEGIN { 11 | if (!eval { require Socket }) { 12 | plan skip_all => "no Socket"; 13 | } 14 | elsif (ord('A') == 193 && !eval { require Convert::EBCDIC }) { 15 | plan skip_all => "EBCDIC but no Convert::EBCDIC"; 16 | } 17 | } 18 | 19 | use Config; 20 | use File::Temp 'tempfile'; 21 | use Net::SMTP; 22 | 23 | my $debug = 0; # Net::SMTP Debug => .. 24 | 25 | my $parent = 0; 26 | 27 | plan skip_all => "no SSL support found in Net::SMTP" if ! Net::SMTP->can_ssl; 28 | 29 | plan skip_all => "fork not supported on this platform" 30 | unless $Config::Config{d_fork} || $Config::Config{d_pseudofork} || 31 | (($^O eq 'MSWin32' || $^O eq 'NetWare') and 32 | $Config::Config{useithreads} and 33 | $Config::Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/); 34 | 35 | my $srv = IO::Socket::INET->new( 36 | LocalAddr => '127.0.0.1', 37 | Listen => 10 38 | ); 39 | plan skip_all => "cannot create listener on localhost: $!" if ! $srv; 40 | my $saddr = $srv->sockhost.':'.$srv->sockport; 41 | 42 | plan tests => 2; 43 | 44 | require IO::Socket::SSL::Utils; 45 | my ($ca,$key) = IO::Socket::SSL::Utils::CERT_create( CA => 1 ); 46 | my ($fh,$cafile) = tempfile(); 47 | print $fh IO::Socket::SSL::Utils::PEM_cert2string($ca); 48 | close($fh); 49 | 50 | $parent = $$; 51 | END { unlink($cafile) if $$ == $parent } 52 | 53 | my ($cert) = IO::Socket::SSL::Utils::CERT_create( 54 | subject => { CN => 'smtp.example.com' }, 55 | issuer_cert => $ca, issuer_key => $key, 56 | key => $key 57 | ); 58 | 59 | test(1); # direct ssl 60 | test(0); # starttls 61 | 62 | 63 | sub test { 64 | my $ssl = shift; 65 | defined( my $pid = fork()) or die "fork failed: $!"; 66 | exit(smtp_server($ssl)) if ! $pid; 67 | smtp_client($ssl); 68 | wait; 69 | } 70 | 71 | 72 | sub smtp_client { 73 | my $ssl = shift; 74 | my %sslopt = ( 75 | SSL_verifycn_name => 'smtp.example.com', 76 | SSL_ca_file => $cafile 77 | ); 78 | $sslopt{SSL} = 1 if $ssl; 79 | my $cl = Net::SMTP->new($saddr, %sslopt, Debug => $debug); 80 | note("created Net::SMTP object"); 81 | if (!$cl) { 82 | fail( ($ssl ? "SSL ":"" )."SMTP connect failed"); 83 | } elsif ($ssl) { 84 | $cl->quit; 85 | pass("SSL SMTP connect success"); 86 | } elsif ( ! $cl->starttls ) { 87 | no warnings 'once'; 88 | fail("starttls failed: $IO::Socket::SSL::SSL_ERROR"); 89 | } else { 90 | $cl->quit; 91 | pass("starttls success"); 92 | } 93 | } 94 | 95 | sub smtp_server { 96 | my $ssl = shift; 97 | my $cl = $srv->accept or die "accept failed: $!"; 98 | my %sslargs = ( 99 | SSL_server => 1, 100 | SSL_cert => $cert, 101 | SSL_key => $key, 102 | ); 103 | if ( $ssl ) { 104 | if ( ! IO::Socket::SSL->start_SSL($cl, %sslargs)) { 105 | diag("initial ssl handshake with client failed"); 106 | return; 107 | } 108 | } 109 | 110 | print $cl "220 welcome\r\n"; 111 | while (<$cl>) { 112 | my ($cmd,$arg) = m{^(\S+)(?: +(.*))?\r\n} or die $_; 113 | $cmd = uc($cmd); 114 | if ($cmd eq 'QUIT' ) { 115 | print $cl "250 bye\r\n"; 116 | last; 117 | } elsif ( $cmd eq 'HELO' ) { 118 | print $cl "250 localhost\r\n"; 119 | } elsif ( $cmd eq 'EHLO' ) { 120 | print $cl "250-localhost\r\n". 121 | ( $ssl ? "" : "250-STARTTLS\r\n" ). 122 | "250 HELP\r\n"; 123 | } elsif ( ! $ssl and $cmd eq 'STARTTLS' ) { 124 | print $cl "250 starting ssl\r\n"; 125 | if ( ! IO::Socket::SSL->start_SSL($cl, %sslargs)) { 126 | diag("initial ssl handshake with client failed"); 127 | return; 128 | } 129 | $ssl = 1; 130 | } else { 131 | diag("received unknown command: $cmd"); 132 | print "500 unknown cmd\r\n"; 133 | } 134 | } 135 | 136 | note("SMTP dialog done"); 137 | } 138 | -------------------------------------------------------------------------------- /demos/nntp.mirror: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | ### Subject: Re: Fuller example of Net::NNTP? 4 | ### Date: Tue, 4 Feb 1997 10:37:58 -0800 5 | ### From: "Paul E. Hoffman" 6 | ### To: Graham Barr 7 | ### 8 | ### Thanks for your reply. After looking at the examples, I realized that 9 | ### you're not doing what I want, which is to store the messages on the local 10 | ### hard disk with the same message number as what was on the remote. So, I 11 | ### rolled my own program, although I haven't finished it yet (I have a hook 12 | ### for expiring, but haven't done it yet). 13 | ### 14 | ### You are welcome to use this in the Net:: distribution if you think it is 15 | ### useful. 16 | ### 17 | ### NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE 18 | ### 19 | ### This script is included as-is, I give no guarantee that it will 20 | ### work on every system 21 | ### 22 | 23 | use 5.008001; 24 | 25 | use strict; 26 | use warnings; 27 | 28 | use Net::NNTP; 29 | 30 | my $BaseDir = '/usr/usenet'; 31 | chdir($BaseDir) or die "Could not cd to $BaseDir\n"; 32 | 33 | # Format of grouplist is: 34 | # groupnameexpirationdays 35 | # expirationdays is the number of days to leave the articles around; 36 | # set it to 0 if you want the articles to stay forever 37 | # If the groupname starts with a #, it is skipped 38 | my $GroupList; 39 | open($GroupList, '<', 'grouplist.txt') or die "Could not open grouplist.txt\n"; 40 | my @Groups; 41 | while(<$GroupList>) { 42 | my $Line = $_; chomp($Line); 43 | if($Line eq '') { next }; # Skip blank lines 44 | if(substr($Line, 0, 1) eq '#') { next }; # Skip comments 45 | push(@Groups, $Line) 46 | } 47 | close $GroupList; 48 | 49 | my $NntpPtr = Net::NNTP->new('news.server.com'); 50 | 51 | foreach my $GroupLine (@Groups) { 52 | my($GroupName, $GroupExp) = split(/\s/, $GroupLine, 2); 53 | # Process the expiration first (still to be done...) 54 | 55 | # See if this is a new group 56 | unless(-e "$BaseDir/$GroupName") { 57 | unless(mkdir("$BaseDir/$GroupName", 0755)) 58 | { die "Could not make $BaseDir/$GroupName\n" } 59 | } 60 | chdir("$BaseDir/$GroupName") or die "Couldn't chdir to $GroupName\n"; 61 | # Find the last article in the directory 62 | my @AllInDir = glob('*'); my @RevSortedAllInDir = reverse(sort(@AllInDir)); 63 | my $LenArr = @RevSortedAllInDir; 64 | my $NumLastInDir; 65 | if($LenArr > 0) { $NumLastInDir = $RevSortedAllInDir[0] } 66 | else { $NumLastInDir = 0 } 67 | my($NumArt, $NumFirst, $NumLast, $XGroupName) = 68 | $NntpPtr->group($GroupName); 69 | 70 | if($NumLast == $NumLastInDir) { next } # No new articles 71 | if($NumLast < $NumLastInDir) 72 | { die "In $GroupName, the last number was $NumLast, but the " . 73 | " last number in the directory was $NumLastInDir\n" } 74 | # Figure out which article to start from 75 | my $GetArtNum; 76 | if($NumLastInDir == 0) { $GetArtNum = $NumFirst } 77 | else { $GetArtNum = $NumLastInDir + 1 } 78 | 79 | # Now read each of the new articles 80 | while(1) { # Loop until "last" is called 81 | my $ArtRef = $NntpPtr->article($GetArtNum); 82 | my @ArtArr = @$ArtRef; my $ArtArrLen = @ArtArr; 83 | if($ArtArrLen > 0 ) { # Skip article numbers that had 0 len 84 | my $Out; 85 | open($Out, '>', $GetArtNum) or 86 | die "Could not create $GroupName/$GetArtNum\n"; 87 | print $Out @$ArtRef; close($Out); 88 | } 89 | 90 | # Check if we're at the end 91 | if($GetArtNum == $NumLast) { last } 92 | $GetArtNum += 1; # Increment the article number to get 93 | } 94 | } 95 | 96 | $NntpPtr->quit; 97 | exit; 98 | -------------------------------------------------------------------------------- /t/time.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use 5.008001; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | use Test::More; 9 | 10 | BEGIN { 11 | if (!eval { require Socket }) { 12 | plan skip_all => "no Socket"; 13 | } 14 | elsif (ord('A') == 193 && !eval { require Convert::EBCDIC }) { 15 | plan skip_all => "EBCDIC but no Convert::EBCDIC"; 16 | } 17 | else { 18 | plan tests => 12; 19 | } 20 | 21 | $INC{'IO/Socket.pm'} = 1; 22 | $INC{'IO/Select.pm'} = 1; 23 | $INC{'IO/Socket/INET.pm'} = 1; 24 | } 25 | 26 | # cannot use(), otherwise it will use IO::Socket and IO::Select 27 | eval{ require Net::Time; }; 28 | ok( !$@, 'should be able to require() Net::Time safely' ); 29 | ok( exists $INC{'Net/Time.pm'}, 'should be able to use Net::Time' ); 30 | 31 | # force the socket to fail 32 | make_fail('IO::Socket::INET', 'new'); 33 | my $badsock = Net::Time::_socket('foo', 1, 'bar', 'baz'); 34 | is( $badsock, undef, '_socket() should fail if Socket creation fails' ); 35 | 36 | # if socket is created with protocol UDP (default), it will send a newline 37 | my $sock = Net::Time::_socket('foo', 2, 'bar'); 38 | ok( $sock->isa('IO::Socket::INET'), 'should be an IO::Socket::INET object' ); 39 | is( $sock->{sent}, "\n", 'should send \n with UDP protocol set' ); 40 | is( $sock->{timeout}, 120, 'timeout should default to 120' ); 41 | 42 | # now try it with a custom timeout and a different protocol 43 | $sock = Net::Time::_socket('foo', 3, 'bar', 'tcp', 11); 44 | ok( $sock->isa('IO::Socket::INET'), 'should be an IO::Socket::INET object' ); 45 | is( $sock->{sent}, undef, '_socket() should send nothing unless UDP protocol' ); 46 | is( $sock->{PeerAddr}, 'bar', '_socket() should set PeerAddr in socket' ); 47 | is( $sock->{timeout}, 11, '_socket() should respect custom timeout value' ); 48 | 49 | # inet_daytime 50 | # check for correct args (daytime, 13) 51 | IO::Socket::INET::set_message('z'); 52 | is( Net::Time::inet_daytime('bob'), 'z', 'inet_daytime() should receive data' ); 53 | 54 | # magic numbers defined in Net::Time 55 | my $offset = $^O eq 'MacOS' ? 56 | (4 * 31536000) : (70 * 31536000 + 17 * 86400); 57 | 58 | # check for correct args (time, 13) 59 | # pretend it is only six seconds since the offset, create a fake message 60 | # inet_time 61 | IO::Socket::INET::set_message(pack("N", $offset + 6)); 62 | is( Net::Time::inet_time('foo'), 6, 63 | 'inet_time() should calculate time since offset for time()' ); 64 | 65 | 66 | my %fail; 67 | 68 | sub make_fail { 69 | my ($pack, $func, $num) = @_; 70 | $num = 1 unless defined $num; 71 | 72 | $fail{$pack}{$func} = $num; 73 | } 74 | 75 | package IO::Socket::INET; 76 | 77 | $fail{'IO::Socket::INET'} = { 78 | new => 0, 79 | 'send' => 0, 80 | }; 81 | 82 | sub new { 83 | my $class = shift; 84 | return if $fail{$class}{new} and $fail{$class}{new}--; 85 | bless( { @_ }, $class ); 86 | } 87 | 88 | sub send { 89 | my $self = shift; 90 | my $class = ref($self); 91 | return if $fail{$class}{'send'} and $fail{$class}{'send'}--; 92 | $self->{sent} .= shift; 93 | } 94 | 95 | my $msg; 96 | sub set_message { 97 | if (ref($_[0])) { 98 | $_[0]->{msg} = $_[1]; 99 | } else { 100 | $msg = shift; 101 | } 102 | } 103 | 104 | sub do_recv { 105 | my ($len, $msg) = @_[1,2]; 106 | $_[0] .= substr($msg, 0, $len); 107 | } 108 | 109 | sub recv { 110 | my ($self, $buf, $length, $flags) = @_; 111 | my $message = exists $self->{msg} ? 112 | $self->{msg} : $msg; 113 | 114 | if (defined($message)) { 115 | do_recv($_[1], $length, $message); 116 | } 117 | 1; 118 | } 119 | 120 | package IO::Select; 121 | 122 | sub new { 123 | my $class = shift; 124 | return if defined $fail{$class}{new} and $fail{$class}{new}--; 125 | bless({sock => shift}, $class); 126 | } 127 | 128 | sub can_read { 129 | my ($self, $timeout) = @_; 130 | my $class = ref($self); 131 | return if defined $fail{$class}{can_read} and $fail{class}{can_read}--; 132 | $self->{sock}{timeout} = $timeout; 133 | 1; 134 | } 135 | 136 | 1; 137 | -------------------------------------------------------------------------------- /t/netrc.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use 5.008001; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | use Test::More; 9 | 10 | BEGIN { 11 | if (!eval { require Socket }) { 12 | plan skip_all => "no Socket"; 13 | } 14 | elsif (ord('A') == 193 && !eval { require Convert::EBCDIC }) { 15 | plan skip_all => "EBCDIC but no Convert::EBCDIC"; 16 | } 17 | else { 18 | plan tests => 20; 19 | } 20 | } 21 | 22 | use Cwd; 23 | 24 | # for testing _readrc 25 | $ENV{HOME} = Cwd::cwd(); 26 | 27 | # avoid "used only once" warning 28 | local (*CORE::GLOBAL::getpwuid, *CORE::GLOBAL::stat); 29 | 30 | *CORE::GLOBAL::getpwuid = sub ($) { 31 | ((undef) x 7, Cwd::cwd()); 32 | }; 33 | 34 | # for testing _readrc 35 | my @stat; 36 | *CORE::GLOBAL::stat = sub (*) { 37 | return @stat; 38 | }; 39 | 40 | # for testing _readrc 41 | $INC{'FileHandle.pm'} = 1; 42 | 43 | # now that the tricks are out of the way... 44 | eval { require Net::Netrc; }; 45 | ok( !$@, 'should be able to require() Net::Netrc safely' ); 46 | ok( exists $INC{'Net/Netrc.pm'}, 'should be able to use Net::Netrc' ); 47 | $Net::Netrc::TESTING=$Net::Netrc::TESTING=1; 48 | 49 | SKIP: { 50 | skip('incompatible stat() handling for OS', 4), next SKIP 51 | if $^O =~ /os2|win32|macos|cygwin/i; 52 | 53 | my $warn; 54 | local $SIG{__WARN__} = sub { 55 | $warn = shift; 56 | }; 57 | 58 | # add write access for group/other 59 | $stat[2] = 077; ## no critic (ValuesAndExpressions::ProhibitLeadingZeros) 60 | ok( !defined(Net::Netrc->_readrc()), 61 | '_readrc() should not read world-writable file' ); 62 | ok( scalar($warn =~ /^Bad permissions:/), 63 | '... and should warn about it' ); 64 | 65 | # the owner field should still not match 66 | $stat[2] = 0; 67 | 68 | if ($<) { 69 | ok( !defined(Net::Netrc->_readrc()), 70 | '_readrc() should not read file owned by someone else' ); 71 | ok( scalar($warn =~ /^Not owner:/), 72 | '... and should warn about it' ); 73 | } else { 74 | skip("testing as root",2); 75 | } 76 | } 77 | 78 | # this field must now match, to avoid the last-tested warning 79 | $stat[4] = $<; 80 | 81 | # this curious mix of spaces and quotes tests a regex at line 79 (version 2.11) 82 | FileHandle::set_lines(split(/\n/, <_readrc(), 1, '_readrc() should succeed now' ); 97 | 98 | # on 'foo', the login is 'nigol' 99 | is( Net::Netrc->lookup('foo')->{login}, 'nigol', 100 | 'lookup() should find value by host name' ); 101 | 102 | # on 'foo' with login 'l2', the password is 'p2' 103 | is( Net::Netrc->lookup('foo', 'l2')->{password}, 'p2', 104 | 'lookup() should find value by hostname and login name' ); 105 | 106 | # the default password is 'p3', as later declarations have priority 107 | is( Net::Netrc->lookup()->{password}, 'p3', 108 | 'lookup() should find default value' ); 109 | 110 | # lookup() ignores the login parameter when using default data 111 | is( Net::Netrc->lookup('default', 'baz')->{password}, 'p3', 112 | 'lookup() should ignore passed login when searching default' ); 113 | 114 | # lookup() goes to default data if hostname cannot be found in config data 115 | is( Net::Netrc->lookup('abadname')->{login}, 'baz', 116 | 'lookup() should use default for unknown machine name' ); 117 | 118 | # now test these accessors 119 | my $instance = bless({}, 'Net::Netrc'); 120 | for my $accessor (qw( login account password )) { 121 | is( $instance->$accessor(), undef, 122 | "$accessor() should return undef if $accessor is not set" ); 123 | $instance->{$accessor} = $accessor; 124 | is( $instance->$accessor(), $accessor, 125 | "$accessor() should return value when $accessor is set" ); 126 | } 127 | 128 | # and the three-for-one accessor 129 | is( scalar( () = $instance->lpa()), 3, 130 | 'lpa() should return login, password, account'); 131 | is( join(' ', $instance->lpa), 'login password account', 132 | 'lpa() should return appropriate values for l, p, and a' ); 133 | 134 | package FileHandle; 135 | 136 | sub new { 137 | tie *FH, 'FileHandle', @_; 138 | bless \*FH, $_[0]; 139 | } 140 | 141 | sub TIEHANDLE { 142 | my ($class, $file, $mode) = @_[0,2,3]; 143 | bless({ file => $file, mode => $mode }, $class); 144 | } 145 | 146 | my @lines; 147 | sub set_lines { 148 | @lines = @_; 149 | } 150 | 151 | sub READLINE { 152 | shift @lines; 153 | } 154 | 155 | sub close { 1 } 156 | 157 | -------------------------------------------------------------------------------- /lib/Net/Time.pm: -------------------------------------------------------------------------------- 1 | # Net::Time.pm 2 | # 3 | # Copyright (C) 1995-2004 Graham Barr. All rights reserved. 4 | # Copyright (C) 2014, 2020 Steve Hay. All rights reserved. 5 | # This module is free software; you can redistribute it and/or modify it under 6 | # the same terms as Perl itself, i.e. under the terms of either the GNU General 7 | # Public License or the Artistic License, as specified in the F file. 8 | 9 | package Net::Time; 10 | 11 | use 5.008001; 12 | 13 | use strict; 14 | use warnings; 15 | 16 | use Carp; 17 | use Exporter; 18 | use IO::Select; 19 | use IO::Socket; 20 | use Net::Config; 21 | 22 | our @ISA = qw(Exporter); 23 | our @EXPORT_OK = qw(inet_time inet_daytime); 24 | 25 | our $VERSION = "3.16"; 26 | 27 | our $TIMEOUT = 120; 28 | 29 | sub _socket { 30 | my ($pname, $pnum, $host, $proto, $timeout) = @_; 31 | 32 | $proto ||= 'udp'; 33 | 34 | my $port = (getservbyname($pname, $proto))[2] || $pnum; 35 | 36 | my $hosts = defined $host ? [$host] : $NetConfig{$pname . '_hosts'}; 37 | 38 | my $me; 39 | 40 | foreach my $addr (@$hosts) { 41 | $me = IO::Socket::INET->new( 42 | PeerAddr => $addr, 43 | PeerPort => $port, 44 | Proto => $proto 45 | ) 46 | and last; 47 | } 48 | 49 | return unless $me; 50 | 51 | $me->send("\n") 52 | if $proto eq 'udp'; 53 | 54 | $timeout = $TIMEOUT 55 | unless defined $timeout; 56 | 57 | IO::Select->new($me)->can_read($timeout) 58 | ? $me 59 | : undef; 60 | } 61 | 62 | 63 | sub inet_time { 64 | my $s = _socket('time', 37, @_) || return; 65 | my $buf = ''; 66 | my $offset = 0 | 0; 67 | 68 | return 69 | unless defined $s->recv($buf, length(pack("N", 0))); 70 | 71 | # unpack, we | 0 to ensure we have an unsigned 72 | my $time = (unpack("N", $buf))[0] | 0; 73 | 74 | # the time protocol return time in seconds since 1900, convert 75 | # it to a the required format 76 | 77 | if ($^O eq "MacOS") { 78 | 79 | # MacOS return seconds since 1904, 1900 was not a leap year. 80 | $offset = (4 * 31536000) | 0; 81 | } 82 | else { 83 | 84 | # otherwise return seconds since 1972, there were 17 leap years between 85 | # 1900 and 1972 86 | $offset = (70 * 31536000 + 17 * 86400) | 0; 87 | } 88 | 89 | $time - $offset; 90 | } 91 | 92 | 93 | sub inet_daytime { 94 | my $s = _socket('daytime', 13, @_) || return; 95 | my $buf = ''; 96 | 97 | defined($s->recv($buf, 1024)) 98 | ? $buf 99 | : undef; 100 | } 101 | 102 | 1; 103 | 104 | __END__ 105 | 106 | =head1 NAME 107 | 108 | Net::Time - time and daytime network client interface 109 | 110 | =head1 SYNOPSIS 111 | 112 | use Net::Time qw(inet_time inet_daytime); 113 | 114 | print inet_time(); # use default host from Net::Config 115 | print inet_time('localhost'); 116 | print inet_time('localhost', 'tcp'); 117 | 118 | print inet_daytime(); # use default host from Net::Config 119 | print inet_daytime('localhost'); 120 | print inet_daytime('localhost', 'tcp'); 121 | 122 | =head1 DESCRIPTION 123 | 124 | C provides subroutines that obtain the time on a remote machine. 125 | 126 | =head2 Functions 127 | 128 | =over 4 129 | 130 | =item C 131 | 132 | Obtain the time on C<$host>, or some default host if C<$host> is not given 133 | or not defined, using the protocol as defined in RFC868. The optional 134 | argument C<$protocol> should define the protocol to use, either C or 135 | C. The result will be a time value in the same units as returned 136 | by time() or I upon failure. 137 | 138 | =item C 139 | 140 | Obtain the time on C<$host>, or some default host if C<$host> is not given 141 | or not defined, using the protocol as defined in RFC867. The optional 142 | argument C<$protocol> should define the protocol to use, either C or 143 | C. The result will be an ASCII string or I upon failure. 144 | 145 | =back 146 | 147 | =head1 EXPORTS 148 | 149 | The following symbols are, or can be, exported by this module: 150 | 151 | =over 4 152 | 153 | =item Default Exports 154 | 155 | I. 156 | 157 | =item Optional Exports 158 | 159 | C, 160 | C. 161 | 162 | =item Export Tags 163 | 164 | I. 165 | 166 | =back 167 | 168 | =head1 KNOWN BUGS 169 | 170 | I. 171 | 172 | =head1 AUTHOR 173 | 174 | Graham Barr ELE. 175 | 176 | Steve Hay ELE is now maintaining 177 | libnet as of version 1.22_02. 178 | 179 | =head1 COPYRIGHT 180 | 181 | Copyright (C) 1995-2004 Graham Barr. All rights reserved. 182 | 183 | Copyright (C) 2014, 2020 Steve Hay. All rights reserved. 184 | 185 | =head1 LICENCE 186 | 187 | This module is free software; you can redistribute it and/or modify it under the 188 | same terms as Perl itself, i.e. under the terms of either the GNU General Public 189 | License or the Artistic License, as specified in the F file. 190 | 191 | =head1 VERSION 192 | 193 | Version 3.16 194 | 195 | =head1 DATE 196 | 197 | TODO 198 | 199 | =head1 HISTORY 200 | 201 | See the F file. 202 | 203 | =cut 204 | -------------------------------------------------------------------------------- /lib/Net/FTP/dataconn.pm: -------------------------------------------------------------------------------- 1 | ## 2 | ## Generic data connection package 3 | ## 4 | 5 | package Net::FTP::dataconn; 6 | 7 | use 5.008001; 8 | 9 | use strict; 10 | use warnings; 11 | 12 | use Carp; 13 | use Errno; 14 | use Net::Cmd; 15 | 16 | our $VERSION = '3.16'; 17 | 18 | $Net::FTP::IOCLASS or die "please load Net::FTP before Net::FTP::dataconn"; 19 | our @ISA = $Net::FTP::IOCLASS; 20 | 21 | sub reading { 22 | my $data = shift; 23 | ${*$data}{'net_ftp_bytesread'} = 0; 24 | } 25 | 26 | 27 | sub abort { 28 | my $data = shift; 29 | my $ftp = ${*$data}{'net_ftp_cmd'}; 30 | 31 | # no need to abort if we have finished the xfer 32 | return $data->close 33 | if ${*$data}{'net_ftp_eof'}; 34 | 35 | # for some reason if we continuously open RETR connections and not 36 | # read a single byte, then abort them after a while the server will 37 | # close our connection, this prevents the unexpected EOF on the 38 | # command channel -- GMB 39 | if (exists ${*$data}{'net_ftp_bytesread'} 40 | && (${*$data}{'net_ftp_bytesread'} == 0)) 41 | { 42 | my $buf = ""; 43 | my $timeout = $data->timeout; 44 | $data->can_read($timeout) && sysread($data, $buf, 1); 45 | } 46 | 47 | ${*$data}{'net_ftp_eof'} = 1; # fake 48 | 49 | $ftp->abort; # this will close me 50 | } 51 | 52 | 53 | sub _close { 54 | my $data = shift; 55 | my $ftp = ${*$data}{'net_ftp_cmd'}; 56 | 57 | $data->SUPER::close(); 58 | 59 | delete ${*$ftp}{'net_ftp_dataconn'} 60 | if defined $ftp 61 | && exists ${*$ftp}{'net_ftp_dataconn'} 62 | && $data == ${*$ftp}{'net_ftp_dataconn'}; 63 | } 64 | 65 | 66 | sub close { 67 | my $data = shift; 68 | my $ftp = ${*$data}{'net_ftp_cmd'}; 69 | 70 | if (exists ${*$data}{'net_ftp_bytesread'} && !${*$data}{'net_ftp_eof'}) { 71 | my $junk; 72 | eval { local($SIG{__DIE__}); $data->read($junk, 1, 0) }; 73 | return $data->abort unless ${*$data}{'net_ftp_eof'}; 74 | } 75 | 76 | $data->_close; 77 | 78 | return unless defined $ftp; 79 | 80 | $ftp->response() == CMD_OK 81 | && $ftp->message =~ /unique file name:\s*(\S*)\s*\)/ 82 | && (${*$ftp}{'net_ftp_unique'} = $1); 83 | 84 | $ftp->status == CMD_OK; 85 | } 86 | 87 | 88 | sub _select { 89 | my ($data, $timeout, $do_read) = @_; 90 | my ($rin, $rout, $win, $wout, $tout, $nfound); 91 | 92 | vec($rin = '', fileno($data), 1) = 1; 93 | 94 | ($win, $rin) = ($rin, $win) unless $do_read; 95 | 96 | while (1) { 97 | $nfound = select($rout = $rin, $wout = $win, undef, $tout = $timeout); 98 | 99 | last if $nfound >= 0; 100 | 101 | croak "select: $!" 102 | unless $!{EINTR}; 103 | } 104 | 105 | $nfound; 106 | } 107 | 108 | 109 | sub can_read { 110 | _select(@_[0, 1], 1); 111 | } 112 | 113 | 114 | sub can_write { 115 | _select(@_[0, 1], 0); 116 | } 117 | 118 | 119 | sub cmd { 120 | my $ftp = shift; 121 | 122 | ${*$ftp}{'net_ftp_cmd'}; 123 | } 124 | 125 | 126 | sub bytes_read { 127 | my $ftp = shift; 128 | 129 | ${*$ftp}{'net_ftp_bytesread'} || 0; 130 | } 131 | 132 | 1; 133 | 134 | __END__ 135 | 136 | =head1 NAME 137 | 138 | Net::FTP::dataconn - FTP Client data connection class 139 | 140 | =head1 SYNOPSIS 141 | 142 | # Perform IO operations on an FTP client data connection object: 143 | 144 | $num_bytes_read = $obj->read($buffer, $size); 145 | $num_bytes_read = $obj->read($buffer, $size, $timeout); 146 | 147 | $num_bytes_written = $obj->write($buffer, $size); 148 | $num_bytes_written = $obj->write($buffer, $size, $timeout); 149 | 150 | $num_bytes_read_so_far = $obj->bytes_read(); 151 | 152 | $obj->abort(); 153 | 154 | $closed_successfully = $obj->close(); 155 | 156 | =head1 DESCRIPTION 157 | 158 | Some of the methods defined in C return an object which will 159 | be derived from this class. The dataconn class itself is derived from 160 | the C class, so any normal IO operations can be performed. 161 | However the following methods are defined in the dataconn class and IO should 162 | be performed using these. 163 | 164 | =over 4 165 | 166 | =item C 167 | 168 | Read C<$size> bytes of data from the server and place it into C<$buffer>, also 169 | performing any translation necessary. C<$timeout> is optional, if not 170 | given, the timeout value from the command connection will be used. 171 | 172 | Returns the number of bytes read before any translation. 173 | 174 | =item C 175 | 176 | Write C<$size> bytes of data from C<$buffer> to the server, also 177 | performing any translation necessary. C<$timeout> is optional, if not 178 | given, the timeout value from the command connection will be used. 179 | 180 | Returns the number of bytes written before any translation. 181 | 182 | =item C 183 | 184 | Returns the number of bytes read so far. 185 | 186 | =item C 187 | 188 | Abort the current data transfer. 189 | 190 | =item C 191 | 192 | Close the data connection and get a response from the FTP server. Returns 193 | I if the connection was closed successfully and the first digit of 194 | the response from the server was a '2'. 195 | 196 | =back 197 | 198 | =head1 EXPORTS 199 | 200 | I. 201 | 202 | =head1 KNOWN BUGS 203 | 204 | I. 205 | 206 | =head1 AUTHOR 207 | 208 | Graham Barr ELE. 209 | 210 | Steve Hay ELE is now maintaining 211 | libnet as of version 1.22_02. 212 | 213 | =head1 COPYRIGHT 214 | 215 | Copyright (C) 1997-2010 Graham Barr. All rights reserved. 216 | 217 | Copyright (C) 2013-2014, 2020 Steve Hay. All rights reserved. 218 | 219 | =head1 LICENCE 220 | 221 | This module is free software; you can redistribute it and/or modify it under the 222 | same terms as Perl itself, i.e. under the terms of either the GNU General Public 223 | License or the Artistic License, as specified in the F file. 224 | 225 | =head1 VERSION 226 | 227 | Version 3.16 228 | 229 | =head1 DATE 230 | 231 | TODO 232 | 233 | =head1 HISTORY 234 | 235 | See the F file. 236 | 237 | =cut 238 | -------------------------------------------------------------------------------- /Artistic: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | The "Artistic License" 6 | 7 | Preamble 8 | 9 | The intent of this document is to state the conditions under which a 10 | Package may be copied, such that the Copyright Holder maintains some 11 | semblance of artistic control over the development of the package, 12 | while giving the users of the package the right to use and distribute 13 | the Package in a more-or-less customary fashion, plus the right to make 14 | reasonable modifications. 15 | 16 | Definitions: 17 | 18 | "Package" refers to the collection of files distributed by the 19 | Copyright Holder, and derivatives of that collection of files 20 | created through textual modification. 21 | 22 | "Standard Version" refers to such a Package if it has not been 23 | modified, or has been modified in accordance with the wishes 24 | of the Copyright Holder as specified below. 25 | 26 | "Copyright Holder" is whoever is named in the copyright or 27 | copyrights for the package. 28 | 29 | "You" is you, if you're thinking about copying or distributing 30 | this Package. 31 | 32 | "Reasonable copying fee" is whatever you can justify on the 33 | basis of media cost, duplication charges, time of people involved, 34 | and so on. (You will not be required to justify it to the 35 | Copyright Holder, but only to the computing community at large 36 | as a market that must bear the fee.) 37 | 38 | "Freely Available" means that no fee is charged for the item 39 | itself, though there may be fees involved in handling the item. 40 | It also means that recipients of the item may redistribute it 41 | under the same conditions they received it. 42 | 43 | 1. You may make and give away verbatim copies of the source form of the 44 | Standard Version of this Package without restriction, provided that you 45 | duplicate all of the original copyright notices and associated disclaimers. 46 | 47 | 2. You may apply bug fixes, portability fixes and other modifications 48 | derived from the Public Domain or from the Copyright Holder. A Package 49 | modified in such a way shall still be considered the Standard Version. 50 | 51 | 3. You may otherwise modify your copy of this Package in any way, provided 52 | that you insert a prominent notice in each changed file stating how and 53 | when you changed that file, and provided that you do at least ONE of the 54 | following: 55 | 56 | a) place your modifications in the Public Domain or otherwise make them 57 | Freely Available, such as by posting said modifications to Usenet or 58 | an equivalent medium, or placing the modifications on a major archive 59 | site such as uunet.uu.net, or by allowing the Copyright Holder to include 60 | your modifications in the Standard Version of the Package. 61 | 62 | b) use the modified Package only within your corporation or organization. 63 | 64 | c) rename any non-standard executables so the names do not conflict 65 | with standard executables, which must also be provided, and provide 66 | a separate manual page for each non-standard executable that clearly 67 | documents how it differs from the Standard Version. 68 | 69 | d) make other distribution arrangements with the Copyright Holder. 70 | 71 | 4. You may distribute the programs of this Package in object code or 72 | executable form, provided that you do at least ONE of the following: 73 | 74 | a) distribute a Standard Version of the executables and library files, 75 | together with instructions (in the manual page or equivalent) on where 76 | to get the Standard Version. 77 | 78 | b) accompany the distribution with the machine-readable source of 79 | the Package with your modifications. 80 | 81 | c) give non-standard executables non-standard names, and clearly 82 | document the differences in manual pages (or equivalent), together 83 | with instructions on where to get the Standard Version. 84 | 85 | d) make other distribution arrangements with the Copyright Holder. 86 | 87 | 5. You may charge a reasonable copying fee for any distribution of this 88 | Package. You may charge any fee you choose for support of this 89 | Package. You may not charge a fee for this Package itself. However, 90 | you may distribute this Package in aggregate with other (possibly 91 | commercial) programs as part of a larger (possibly commercial) software 92 | distribution provided that you do not advertise this Package as a 93 | product of your own. You may embed this Package's interpreter within 94 | an executable of yours (by linking); this shall be construed as a mere 95 | form of aggregation, provided that the complete Standard Version of the 96 | interpreter is so embedded. 97 | 98 | 6. The scripts and library files supplied as input to or produced as 99 | output from the programs of this Package do not automatically fall 100 | under the copyright of this Package, but belong to whoever generated 101 | them, and may be sold commercially, and may be aggregated with this 102 | Package. If such scripts or library files are aggregated with this 103 | Package via the so-called "undump" or "unexec" methods of producing a 104 | binary executable image, then distribution of such an image shall 105 | neither be construed as a distribution of this Package nor shall it 106 | fall under the restrictions of Paragraphs 3 and 4, provided that you do 107 | not represent such an executable image as a Standard Version of this 108 | Package. 109 | 110 | 7. C subroutines (or comparably compiled subroutines in other 111 | languages) supplied by you and linked into this Package in order to 112 | emulate subroutines and variables of the language defined by this 113 | Package shall not be considered part of this Package, but are the 114 | equivalent of input as in Paragraph 6, provided these subroutines do 115 | not change the language in any way that would cause it to fail the 116 | regression tests for the language. 117 | 118 | 8. Aggregation of this Package with a commercial distribution is always 119 | permitted provided that the use of this Package is embedded; that is, 120 | when no overt attempt is made to make this Package's interfaces visible 121 | to the end user of the commercial distribution. Such use shall not be 122 | construed as a distribution of this Package. 123 | 124 | 9. The name of the Copyright Holder may not be used to endorse or promote 125 | products derived from this software without specific prior written permission. 126 | 127 | 10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR 128 | IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED 129 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. 130 | 131 | The End 132 | -------------------------------------------------------------------------------- /t/external/ftp-ssl.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use 5.008001; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | use Net::FTP; 9 | use Test::More; 10 | use File::Temp; 11 | use IO::Socket::INET; 12 | 13 | my $server = 'test.rebex.net'; 14 | my $debug = 0; 15 | 16 | plan skip_all => "no SSL support" if ! Net::FTP->can_ssl; 17 | require IO::Socket::SSL; 18 | 19 | 20 | # first try to connect w/o ftp 21 | # plain 22 | diag( "connect inet to $server:21" ); 23 | IO::Socket::INET->new( "$server:21" ) or do { 24 | plan skip_all => "$server:21 not reachable"; 25 | }; 26 | 27 | # ssl to the right host 28 | diag( "connect inet to $server:990" ); 29 | my $sock = IO::Socket::INET->new( "$server:990") or do { 30 | plan skip_all => "$server:990 not reachable"; 31 | }; 32 | 33 | # now we need CAs 34 | my $cafh = File::Temp->new( UNLINK => 0, SUFFIX => '.crt' ); 35 | my %sslargs = ( SSL_ca_file => $cafh->filename ); 36 | print $cafh ; 37 | close($cafh); 38 | 39 | diag( "upgrade to ssl $server:990" ); 40 | IO::Socket::SSL->start_SSL($sock, 41 | SSL_verify_mode => 1, 42 | SSL_verifycn_name => $server, 43 | SSL_verifycn_scheme => 'ftp', 44 | %sslargs, 45 | ) or do { 46 | plan skip_all => "$server:990 not upgradable to SSL: ". 47 | $IO::Socket::SSL::SSL_ERROR; 48 | }; 49 | 50 | plan tests => 9; 51 | 52 | # first direct SSL 53 | diag( "connect ftp over ssl to $server" ); 54 | my $ftp = Net::FTP->new($server, 55 | SSL => 1, 56 | %sslargs, 57 | Debug => $debug, 58 | Passive => 1, 59 | ); 60 | ok($ftp,"ftp ssl connect $server"); 61 | $ftp->login("anonymous",'net-sslglue-ftp@test.perl') 62 | or die "login to $server failed"; 63 | diag("logged in"); 64 | # check that we can talk on connection 65 | ok(~~$ftp->ls,"directory listing protected"); 66 | $ftp->prot('C'); 67 | ok(~~$ftp->ls,"directory listing clear"); 68 | 69 | # then TLS upgrade inside plain connection 70 | $ftp = Net::FTP->new($server, 71 | Passive => 1, 72 | Debug => $debug, 73 | %sslargs 74 | ); 75 | ok($ftp,"ftp plain connect $server"); 76 | my $ok = $ftp->starttls; 77 | ok($ok,"ssl upgrade"); 78 | $ftp->login("anonymous",'net-sslglue-ftp@test.perl') 79 | or die "login to $server failed"; 80 | diag("logged in"); 81 | # check that we can talk on connection 82 | ok(~~$ftp->ls,"directory listing protected"); 83 | $ftp->prot('C'); 84 | ok(~~$ftp->ls,"directory listing clear"); 85 | $ok = $ftp->stoptls; 86 | ok($ok,"ssl downgrade"); 87 | ok(~~$ftp->ls,"directory listing after downgrade"); 88 | 89 | 90 | __DATA__ 91 | # Subject: C=IL, O=StartCom Ltd., OU=Secure Digital Certificate Signing, CN=StartCom Class 2 Primary Intermediate Server CA 92 | # Issuer: C=IL, O=StartCom Ltd., OU=Secure Digital Certificate Signing, CN=StartCom Certification Authority 93 | -----BEGIN CERTIFICATE----- 94 | MIIGNDCCBBygAwIBAgIBGjANBgkqhkiG9w0BAQUFADB9MQswCQYDVQQGEwJJTDEW 95 | MBQGA1UEChMNU3RhcnRDb20gTHRkLjErMCkGA1UECxMiU2VjdXJlIERpZ2l0YWwg 96 | Q2VydGlmaWNhdGUgU2lnbmluZzEpMCcGA1UEAxMgU3RhcnRDb20gQ2VydGlmaWNh 97 | dGlvbiBBdXRob3JpdHkwHhcNMDcxMDI0MjA1NzA5WhcNMTcxMDI0MjA1NzA5WjCB 98 | jDELMAkGA1UEBhMCSUwxFjAUBgNVBAoTDVN0YXJ0Q29tIEx0ZC4xKzApBgNVBAsT 99 | IlNlY3VyZSBEaWdpdGFsIENlcnRpZmljYXRlIFNpZ25pbmcxODA2BgNVBAMTL1N0 100 | YXJ0Q29tIENsYXNzIDIgUHJpbWFyeSBJbnRlcm1lZGlhdGUgU2VydmVyIENBMIIB 101 | IjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEA4k85L6GMmoWtCA4IPlfyiAEh 102 | G5SpbOK426oZGEY6UqH1D/RujOqWjJaHeRNAUS8i8gyLhw9l33F0NENVsTUJm9m8 103 | H/rrQtCXQHK3Q5Y9upadXVACHJuRjZzArNe7LxfXyz6CnXPrB0KSss1ks3RVG7RL 104 | hiEs93iHMuAW5Nq9TJXqpAp+tgoNLorPVavD5d1Bik7mb2VsskDPF125w2oLJxGE 105 | d2H2wnztwI14FBiZgZl1Y7foU9O6YekO+qIw80aiuckfbIBaQKwn7UhHM7BUxkYa 106 | 8zVhwQIpkFR+ZE3EMFICgtffziFuGJHXuKuMJxe18KMBL47SLoc6PbQpZ4rEAwID 107 | AQABo4IBrTCCAakwDwYDVR0TAQH/BAUwAwEB/zAOBgNVHQ8BAf8EBAMCAQYwHQYD 108 | VR0OBBYEFBHbI0X9VMxqcW+EigPXvvcBLyaGMB8GA1UdIwQYMBaAFE4L7xqkQFul 109 | F2mHMMo0aEPQQa7yMGYGCCsGAQUFBwEBBFowWDAnBggrBgEFBQcwAYYbaHR0cDov 110 | L29jc3Auc3RhcnRzc2wuY29tL2NhMC0GCCsGAQUFBzAChiFodHRwOi8vd3d3LnN0 111 | YXJ0c3NsLmNvbS9zZnNjYS5jcnQwWwYDVR0fBFQwUjAnoCWgI4YhaHR0cDovL3d3 112 | dy5zdGFydHNzbC5jb20vc2ZzY2EuY3JsMCegJaAjhiFodHRwOi8vY3JsLnN0YXJ0 113 | c3NsLmNvbS9zZnNjYS5jcmwwgYAGA1UdIAR5MHcwdQYLKwYBBAGBtTcBAgEwZjAu 114 | BggrBgEFBQcCARYiaHR0cDovL3d3dy5zdGFydHNzbC5jb20vcG9saWN5LnBkZjA0 115 | BggrBgEFBQcCARYoaHR0cDovL3d3dy5zdGFydHNzbC5jb20vaW50ZXJtZWRpYXRl 116 | LnBkZjANBgkqhkiG9w0BAQUFAAOCAgEAnQfh7pB2MWcWRXCMy4SLS1doRKWJwfJ+ 117 | yyiL9edwd9W29AshYKWhdHMkIoDW2LqNomJdCTVCKfs5Y0ULpLA4Gmj0lRPM4EOU 118 | 7Os5GuxXKdmZbfWEzY5zrsncavqenRZkkwjHHMKJVJ53gJD2uSl26xNnSFn4Ljox 119 | uMnTiOVfTtIZPUOO15L/zzi24VuKUx3OrLR2L9j3QGPV7mnzRX2gYsFhw3XtsntN 120 | rCEnME5ZRmqTF8rIOS0Bc2Vb6UGbERecyMhK76F2YC2uk/8M1TMTn08Tzt2G8fz4 121 | NVQVqFvnhX76Nwn/i7gxSZ4Nbt600hItuO3Iw/G2QqBMl3nf/sOjn6H0bSyEd6Si 122 | BeEX/zHdmvO4esNSwhERt1Axin/M51qJzPeGmmGSTy+UtpjHeOBiS0N9PN7WmrQQ 123 | oUCcSyrcuNDUnv3xhHgbDlePaVRCaHvqoO91DweijHOZq1X1BwnSrzgDapADDC+P 124 | 4uhDwjHpb62H5Y29TiyJS1HmnExUdsASgVOb7KD8LJzaGJVuHjgmQid4YAjff20y 125 | 6NjAbx/rJnWfk/x7G/41kNxTowemP4NVCitOYoIlzmYwXSzg+RkbdbmdmFamgyd6 126 | 0Y+NWZP8P3PXLrQsldiL98l+x/ydrHIEH9LMF/TtNGCbnkqXBP7dcg5XVFEGcE3v 127 | qhykguAzx/Q= 128 | -----END CERTIFICATE----- 129 | # Subject: C=IL, O=StartCom Ltd., OU=Secure Digital Certificate Signing, CN=StartCom Certification Authority 130 | # Issuer: C=IL, O=StartCom Ltd., OU=Secure Digital Certificate Signing, CN=StartCom Certification Authority 131 | -----BEGIN CERTIFICATE----- 132 | MIIHhzCCBW+gAwIBAgIBLTANBgkqhkiG9w0BAQsFADB9MQswCQYDVQQGEwJJTDEW 133 | MBQGA1UEChMNU3RhcnRDb20gTHRkLjErMCkGA1UECxMiU2VjdXJlIERpZ2l0YWwg 134 | Q2VydGlmaWNhdGUgU2lnbmluZzEpMCcGA1UEAxMgU3RhcnRDb20gQ2VydGlmaWNh 135 | dGlvbiBBdXRob3JpdHkwHhcNMDYwOTE3MTk0NjM3WhcNMzYwOTE3MTk0NjM2WjB9 136 | MQswCQYDVQQGEwJJTDEWMBQGA1UEChMNU3RhcnRDb20gTHRkLjErMCkGA1UECxMi 137 | U2VjdXJlIERpZ2l0YWwgQ2VydGlmaWNhdGUgU2lnbmluZzEpMCcGA1UEAxMgU3Rh 138 | cnRDb20gQ2VydGlmaWNhdGlvbiBBdXRob3JpdHkwggIiMA0GCSqGSIb3DQEBAQUA 139 | A4ICDwAwggIKAoICAQDBiNsJvGxGfHiflXu1M5DycmLWwTYgIiRezul38kMKogZk 140 | pMyONvg45iPwbm2xPN1yo4UcodM9tDMr0y+v/uqwQVlntsQGfQqedIXWeUyAN3rf 141 | OQVSWff0G0ZDpNKFhdLDcfN1YjS6LIp/Ho/u7TTQEceWzVI9ujPW3U3eCztKS5/C 142 | Ji/6tRYccjV3yjxd5srhJosaNnZcAdt0FCX+7bWgiA/deMotHweXMAEtcnn6RtYT 143 | Kqi5pquDSR3l8u/d5AGOGAqPY1MWhWKpDhk6zLVmpsJrdAfkK+F2PrRt2PZE4XNi 144 | HzvEvqBTViVsUQn3qqvKv3b9bZvzndu/PWa8DFaqr5hIlTpL36dYUNk4dalb6kMM 145 | Av+Z6+hsTXBbKWWc3apdzK8BMewM69KN6Oqce+Zu9ydmDBpI125C4z/eIT574Q1w 146 | +2OqqGwaVLRcJXrJosmLFqa7LH4XXgVNWG4SHQHuEhANxjJ/GP/89PrNbpHoNkm+ 147 | Gkhpi8KWTRoSsmkXwQqQ1vp5Iki/untp+HDH+no32NgN0nZPV/+Qt+OR0t3vwmC3 148 | Zzrd/qqc8NSLf3Iizsafl7b4r4qgEKjZ+xjGtrVcUjyJthkqcwEKDwOzEmDyei+B 149 | 26Nu/yYwl/WL3YlXtq09s68rxbd2AvCl1iuahhQqcvbjM4xdCUsT37uMdBNSSwID 150 | AQABo4ICEDCCAgwwDwYDVR0TAQH/BAUwAwEB/zAOBgNVHQ8BAf8EBAMCAQYwHQYD 151 | VR0OBBYEFE4L7xqkQFulF2mHMMo0aEPQQa7yMB8GA1UdIwQYMBaAFE4L7xqkQFul 152 | F2mHMMo0aEPQQa7yMIIBWgYDVR0gBIIBUTCCAU0wggFJBgsrBgEEAYG1NwEBATCC 153 | ATgwLgYIKwYBBQUHAgEWImh0dHA6Ly93d3cuc3RhcnRzc2wuY29tL3BvbGljeS5w 154 | ZGYwNAYIKwYBBQUHAgEWKGh0dHA6Ly93d3cuc3RhcnRzc2wuY29tL2ludGVybWVk 155 | aWF0ZS5wZGYwgc8GCCsGAQUFBwICMIHCMCcWIFN0YXJ0IENvbW1lcmNpYWwgKFN0 156 | YXJ0Q29tKSBMdGQuMAMCAQEagZZMaW1pdGVkIExpYWJpbGl0eSwgcmVhZCB0aGUg 157 | c2VjdGlvbiAqTGVnYWwgTGltaXRhdGlvbnMqIG9mIHRoZSBTdGFydENvbSBDZXJ0 158 | aWZpY2F0aW9uIEF1dGhvcml0eSBQb2xpY3kgYXZhaWxhYmxlIGF0IGh0dHA6Ly93 159 | d3cuc3RhcnRzc2wuY29tL3BvbGljeS5wZGYwEQYJYIZIAYb4QgEBBAQDAgAHMDgG 160 | CWCGSAGG+EIBDQQrFilTdGFydENvbSBGcmVlIFNTTCBDZXJ0aWZpY2F0aW9uIEF1 161 | dGhvcml0eTANBgkqhkiG9w0BAQsFAAOCAgEAjo/n3JR5fPGFf59Jb2vKXfuM/gTF 162 | wWLRfUKKvFO3lANmMD+x5wqnUCBVJX92ehQN6wQOQOY+2IirByeDqXWmN3PH/UvS 163 | Ta0XQMhGvjt/UfzDtgUx3M2FIk5xt/JxXrAaxrqTi3iSSoX4eA+D/i+tLPfkpLst 164 | 0OcNOrg+zvZ49q5HJMqjNTbOx8aHmNrs++myziebiMMEofYLWWivydsQD032ZGNc 165 | pRJvkrKTlMeIFw6Ttn5ii5B/q06f/ON1FE8qMt9bDeD1e5MNq6HPh+GlBEXoPBKl 166 | CcWw0bdT82AUuoVpaiF8H3VhFyAXe2w7QSlc4axa0c2Mm+tgHRns9+Ww2vl5GKVF 167 | P0lDV9LdJNUso/2RjSe15esUBppMeyG7Oq0wBhjA2MFrLH9ZXF2RsXAiV+uKa0hK 168 | 1Q8p7MZAwC+ITGgBF3f0JBlPvfrhsiAhS90a2Cl9qrjeVOwhVYBsHvUwyKMQ5bLm 169 | KhQxw4UtjJixhlpPiVktucf3HMiKf8CdBUrmQk9io20ppB+Fq9vlgcitKj1MXVuE 170 | JnHEhV5xJMqlG2zYYdMa4FTbzrqpMrUi9nNBCV24F10OD5mQ1kfabwo6YigUZ4LZ 171 | 8dCAWZvLMdibD4x3TrVoivJs9iQOLWxwxXPR3hTQcY+203sC9uO41Alua551hDnm 172 | fyWl8kgAwKQB2j8= 173 | -----END CERTIFICATE----- 174 | -------------------------------------------------------------------------------- /Makefile.PL: -------------------------------------------------------------------------------- 1 | #!perl 2 | #=============================================================================== 3 | # 4 | # Makefile.PL 5 | # 6 | # DESCRIPTION 7 | # Makefile creation script. 8 | # 9 | # COPYRIGHT 10 | # Copyright (C) 2014-2015, 2020 Steve Hay. All rights reserved. 11 | # 12 | # LICENCE 13 | # This script is free software; you can redistribute it and/or modify it under 14 | # the same terms as Perl itself, i.e. under the terms of either the GNU 15 | # General Public License or the Artistic License, as specified in the LICENCE 16 | # file. 17 | # 18 | #=============================================================================== 19 | 20 | use 5.008001; 21 | 22 | use strict; 23 | use warnings; 24 | 25 | use ExtUtils::MakeMaker 6.64; 26 | use ExtUtils::MakeMaker qw(WriteMakefile); 27 | 28 | ## no critic (Subroutines::ProhibitSubroutinePrototypes) 29 | 30 | sub running_under_cpan(); 31 | 32 | #=============================================================================== 33 | # INITIALIZATION 34 | #=============================================================================== 35 | 36 | our($CfgFile, $CfgPath); 37 | 38 | BEGIN { 39 | $CfgFile = 'libnet.cfg'; 40 | $CfgPath = "Net/$CfgFile"; 41 | } 42 | 43 | #=============================================================================== 44 | # MAIN PROGRAM 45 | #=============================================================================== 46 | 47 | MAIN: { 48 | my %prereq_pms = (); 49 | $prereq_pms{'Convert::EBCDIC'} = '0.06' if $^O eq 'os390'; 50 | 51 | my $xt = 'n'; 52 | if (not running_under_cpan() and not $ENV{PERL_CORE}) { 53 | $xt = prompt("Should I do external tests?\n" . 54 | "These tests will fail if there is no internet" . 55 | " connection or if a firewall\n" . 56 | "blocks or modifies some traffic.\n" . 57 | "[y/N]", 'n'); 58 | } 59 | 60 | my $tests = 't/*.t'; 61 | $tests .= ' t/external/*.t' if $xt =~ m/^y/io; 62 | 63 | WriteMakefile( 64 | NAME => 'Net', 65 | DISTNAME => 'libnet', 66 | ABSTRACT => 'Collection of network protocol modules', 67 | AUTHOR => 'Graham Barr , Steve Hay ', 68 | LICENSE => 'perl_5', 69 | VERSION => '3.16', 70 | 71 | META_MERGE => { 72 | 'meta-spec' => { 73 | version => 2 74 | }, 75 | 76 | resources => { 77 | repository => { 78 | type => 'git', 79 | web => 'https://github.com/steve-m-hay/perl-libnet' 80 | } 81 | }, 82 | 83 | optional_features => { 84 | APOP => { 85 | description => 'APOP support', 86 | prereqs => { 87 | runtime => { 88 | requires => { 89 | 'Digest::MD5' => '0' 90 | } 91 | } 92 | } 93 | }, 94 | 95 | AUTH => { 96 | description => 'AUTH support', 97 | prereqs => { 98 | runtime => { 99 | requires => { 100 | 'Authen::SASL' => '0', 101 | 'MIME::Base64' => '0' 102 | } 103 | } 104 | } 105 | }, 106 | 107 | SSL => { 108 | description => 'SSL support', 109 | prereqs => { 110 | runtime => { 111 | requires => { 112 | 'IO::Socket::SSL' => '2.007' 113 | } 114 | } 115 | } 116 | }, 117 | 118 | IPv6 => { 119 | description => 'IPv6 support', 120 | prereqs => { 121 | runtime => { 122 | requires => { 123 | 'IO::Socket::IP' => '0.25' 124 | # or IO::Socket::INET6 2.62 125 | } 126 | } 127 | } 128 | }, 129 | 130 | changestest => { 131 | description => 'Changes testing', 132 | prereqs => { 133 | test => { 134 | requires => { 135 | 'Test::CPAN::Changes' => '0' 136 | } 137 | } 138 | } 139 | }, 140 | 141 | critictest => { 142 | description => 'Perl::Critic testing', 143 | prereqs => { 144 | test => { 145 | requires => { 146 | 'Test::Perl::Critic' => '0' 147 | } 148 | } 149 | } 150 | }, 151 | 152 | podtest => { 153 | description => 'POD testing', 154 | prereqs => { 155 | test => { 156 | requires => { 157 | 'Test::Pod' => '1.00' 158 | } 159 | } 160 | } 161 | }, 162 | 163 | podcoveragetest => { 164 | description => 'POD coverage testing', 165 | prereqs => { 166 | test => { 167 | requires => { 168 | 'Test::Pod::Coverage' => '0.08' 169 | } 170 | } 171 | } 172 | } 173 | } 174 | }, 175 | 176 | MIN_PERL_VERSION => '5.008001', 177 | 178 | CONFIGURE_REQUIRES => { 179 | 'ExtUtils::MakeMaker' => '6.64', 180 | 'Getopt::Std' => '0', 181 | 'IO::File' => '0', 182 | 'perl' => '5.008001', 183 | 'strict' => '0', 184 | 'vars' => '0', 185 | 'warnings' => '0' 186 | }, 187 | 188 | TEST_REQUIRES => { 189 | 'Config' => '0', 190 | 'Cwd' => '0' 191 | }, 192 | 193 | PREREQ_PM => { 194 | %prereq_pms, 195 | 'Carp' => '0', 196 | 'Errno' => '0', 197 | 'Exporter' => '0', 198 | 'Fcntl' => '0', 199 | 'File::Basename' => '0', 200 | 'FileHandle' => '0', 201 | 'IO::Select' => '0', 202 | 'IO::Socket' => '1.05', 203 | 'POSIX' => '0', 204 | 'Socket' => '2.016', 205 | 'Symbol' => '0', 206 | 'Time::Local' => '0', 207 | 'constant' => '0', 208 | 'strict' => '0', 209 | 'utf8' => '0', 210 | 'vars' => '0' 211 | }, 212 | 213 | INSTALLDIRS => ($] < 5.011 ? 'perl' : 'site'), 214 | 215 | realclean => { 216 | FILES => $CfgFile 217 | }, 218 | 219 | test => { 220 | TESTS => $tests 221 | }, 222 | 223 | dist => { 224 | PREOP => 'find $(DISTVNAME) -type d -print|xargs chmod 0755 && ' . 225 | 'find $(DISTVNAME) -type f -print|xargs chmod 0644', 226 | TO_UNIX => 'find $(DISTVNAME) -type f -print|xargs dos2unix' 227 | } 228 | ); 229 | } 230 | 231 | #=============================================================================== 232 | # MAKEMAKER OVERRIDES 233 | #=============================================================================== 234 | 235 | sub MY::post_initialize { 236 | my $self = shift; 237 | 238 | return '' if $self->{PERL_CORE}; 239 | 240 | if (not -f $CfgFile) { 241 | my @args = qw(Configure); 242 | push @args, '-d' if $ENV{PERL5_CPAN_IS_RUNNING} || 243 | $ENV{PERL5_CPANPLUS_IS_RUNNING} || 244 | $ENV{PERL5_CPANM_IS_RUNNING}; 245 | system(($^O eq 'VMS' ? 'mcr ': ()), $^X, @args) 246 | } 247 | 248 | $self->{PM}{$CfgFile} = $self->catfile('$(INST_LIBDIR)',$CfgPath); 249 | 250 | return ''; 251 | } 252 | 253 | #=============================================================================== 254 | # SUBROUTINES 255 | #=============================================================================== 256 | 257 | sub running_under_cpan() { 258 | return $ENV{PERL5_CPAN_IS_RUNNING} || # cpan 259 | $ENV{PERL5_CPANPLUS_IS_RUNNING} || # cpanp 260 | $ENV{PERL5_CPANM_IS_RUNNING}; # cpanm 261 | } 262 | 263 | #=============================================================================== 264 | -------------------------------------------------------------------------------- /lib/Net/Netrc.pm: -------------------------------------------------------------------------------- 1 | # Net::Netrc.pm 2 | # 3 | # Copyright (C) 1995-1998 Graham Barr. All rights reserved. 4 | # Copyright (C) 2013-2014, 2020 Steve Hay. All rights reserved. 5 | # This module is free software; you can redistribute it and/or modify it under 6 | # the same terms as Perl itself, i.e. under the terms of either the GNU General 7 | # Public License or the Artistic License, as specified in the F file. 8 | 9 | package Net::Netrc; 10 | 11 | use 5.008001; 12 | 13 | use strict; 14 | use warnings; 15 | 16 | use Carp; 17 | use FileHandle; 18 | 19 | our $VERSION = "3.16"; 20 | 21 | our $TESTING; 22 | 23 | my %netrc = (); 24 | 25 | sub _readrc { 26 | my($class, $host) = @_; 27 | my ($home, $file); 28 | 29 | if ($^O eq "MacOS") { 30 | $home = $ENV{HOME} || `pwd`; 31 | chomp($home); 32 | $file = ($home =~ /:$/ ? $home . "netrc" : $home . ":netrc"); 33 | } 34 | else { 35 | 36 | # Some OS's don't have "getpwuid", so we default to $ENV{HOME} 37 | $home = eval { (getpwuid($>))[7] } || $ENV{HOME}; 38 | $home ||= $ENV{HOMEDRIVE} . ($ENV{HOMEPATH} || '') if defined $ENV{HOMEDRIVE}; 39 | if (-e $home . "/.netrc") { 40 | $file = $home . "/.netrc"; 41 | } 42 | elsif (-e $home . "/_netrc") { 43 | $file = $home . "/_netrc"; 44 | } 45 | else { 46 | return unless $TESTING; 47 | } 48 | } 49 | 50 | my ($login, $pass, $acct) = (undef, undef, undef); 51 | my $fh; 52 | local $_; 53 | 54 | $netrc{default} = undef; 55 | 56 | # OS/2 and Win32 do not handle stat in a way compatible with this check :-( 57 | unless ($^O eq 'os2' 58 | || $^O eq 'MSWin32' 59 | || $^O eq 'MacOS' 60 | || $^O =~ /^cygwin/) 61 | { 62 | my @stat = stat($file); 63 | 64 | if (@stat) { 65 | if ($stat[2] & 077) { ## no critic (ValuesAndExpressions::ProhibitLeadingZeros) 66 | carp "Bad permissions: $file"; 67 | return; 68 | } 69 | if ($stat[4] != $<) { 70 | carp "Not owner: $file"; 71 | return; 72 | } 73 | } 74 | } 75 | 76 | if ($fh = FileHandle->new($file, "r")) { 77 | my ($mach, $macdef, $tok, @tok) = (0, 0); 78 | 79 | while (<$fh>) { 80 | undef $macdef if /\A\n\Z/; 81 | 82 | if ($macdef) { 83 | push(@$macdef, $_); 84 | next; 85 | } 86 | 87 | s/^\s*//; 88 | chomp; 89 | 90 | while (length && s/^("((?:[^"]+|\\.)*)"|((?:[^\\\s]+|\\.)*))\s*//) { 91 | (my $tok = $+) =~ s/\\(.)/$1/g; 92 | push(@tok, $tok); 93 | } 94 | 95 | TOKEN: 96 | while (@tok) { 97 | if ($tok[0] eq "default") { 98 | shift(@tok); 99 | $mach = bless {}, $class; 100 | $netrc{default} = [$mach]; 101 | 102 | next TOKEN; 103 | } 104 | 105 | last TOKEN 106 | unless @tok > 1; 107 | 108 | $tok = shift(@tok); 109 | 110 | if ($tok eq "machine") { 111 | my $host = shift @tok; 112 | $mach = bless {machine => $host}, $class; 113 | 114 | $netrc{$host} = [] 115 | unless exists($netrc{$host}); 116 | push(@{$netrc{$host}}, $mach); 117 | } 118 | elsif ($tok =~ /^(login|password|account)$/) { 119 | next TOKEN unless $mach; 120 | my $value = shift @tok; 121 | 122 | # Following line added by rmerrell to remove '/' escape char in .netrc 123 | $value =~ s/\/\\/\\/g; 124 | $mach->{$1} = $value; 125 | } 126 | elsif ($tok eq "macdef") { 127 | next TOKEN unless $mach; 128 | my $value = shift @tok; 129 | $mach->{macdef} = {} 130 | unless exists $mach->{macdef}; 131 | $macdef = $mach->{machdef}{$value} = []; 132 | } 133 | } 134 | } 135 | $fh->close(); 136 | } 137 | } 138 | 139 | 140 | sub lookup { 141 | my ($class, $mach, $login) = @_; 142 | 143 | $class->_readrc() 144 | unless exists $netrc{default}; 145 | 146 | $mach ||= 'default'; 147 | undef $login 148 | if $mach eq 'default'; 149 | 150 | if (exists $netrc{$mach}) { 151 | if (defined $login) { 152 | foreach my $m (@{$netrc{$mach}}) { 153 | return $m 154 | if (exists $m->{login} && $m->{login} eq $login); 155 | } 156 | return; 157 | } 158 | return $netrc{$mach}->[0]; 159 | } 160 | 161 | return $netrc{default}->[0] 162 | if defined $netrc{default}; 163 | 164 | return; 165 | } 166 | 167 | 168 | sub login { 169 | my $me = shift; 170 | 171 | exists $me->{login} 172 | ? $me->{login} 173 | : undef; 174 | } 175 | 176 | 177 | sub account { 178 | my $me = shift; 179 | 180 | exists $me->{account} 181 | ? $me->{account} 182 | : undef; 183 | } 184 | 185 | 186 | sub password { 187 | my $me = shift; 188 | 189 | exists $me->{password} 190 | ? $me->{password} 191 | : undef; 192 | } 193 | 194 | 195 | sub lpa { 196 | my $me = shift; 197 | ($me->login, $me->password, $me->account); 198 | } 199 | 200 | 1; 201 | 202 | __END__ 203 | 204 | =head1 NAME 205 | 206 | Net::Netrc - OO interface to users netrc file 207 | 208 | =head1 SYNOPSIS 209 | 210 | use Net::Netrc; 211 | 212 | $mach = Net::Netrc->lookup('some.machine'); 213 | $login = $mach->login; 214 | ($login, $password, $account) = $mach->lpa; 215 | 216 | =head1 DESCRIPTION 217 | 218 | C is a class implementing a simple interface to the .netrc file 219 | used as by the ftp program. 220 | 221 | C also implements security checks just like the ftp program, 222 | these checks are, first that the .netrc file must be owned by the user and 223 | second the ownership permissions should be such that only the owner has 224 | read and write access. If these conditions are not met then a warning is 225 | output and the .netrc file is not read. 226 | 227 | =head2 The F<.netrc> File 228 | 229 | The .netrc file contains login and initialization information used by the 230 | auto-login process. It resides in the user's home directory. The following 231 | tokens are recognized; they may be separated by spaces, tabs, or new-lines: 232 | 233 | =over 4 234 | 235 | =item machine name 236 | 237 | Identify a remote machine name. The auto-login process searches 238 | the .netrc file for a machine token that matches the remote machine 239 | specified. Once a match is made, the subsequent .netrc tokens 240 | are processed, stopping when the end of file is reached or an- 241 | other machine or a default token is encountered. 242 | 243 | =item default 244 | 245 | This is the same as machine name except that default matches 246 | any name. There can be only one default token, and it must be 247 | after all machine tokens. This is normally used as: 248 | 249 | default login anonymous password user@site 250 | 251 | thereby giving the user automatic anonymous login to machines 252 | not specified in .netrc. 253 | 254 | =item login name 255 | 256 | Identify a user on the remote machine. If this token is present, 257 | the auto-login process will initiate a login using the 258 | specified name. 259 | 260 | =item password string 261 | 262 | Supply a password. If this token is present, the auto-login 263 | process will supply the specified string if the remote server 264 | requires a password as part of the login process. 265 | 266 | =item account string 267 | 268 | Supply an additional account password. If this token is present, 269 | the auto-login process will supply the specified string 270 | if the remote server requires an additional account password. 271 | 272 | =item macdef name 273 | 274 | Define a macro. C only parses this field to be compatible 275 | with I. 276 | 277 | =back 278 | 279 | =head2 Class Methods 280 | 281 | The constructor for a C object is not called new as it does not 282 | really create a new object. But instead is called C as this is 283 | essentially what it does. 284 | 285 | =over 4 286 | 287 | =item C 288 | 289 | Lookup and return a reference to the entry for C<$machine>. If C<$login> is given 290 | then the entry returned will have the given login. If C<$login> is not given then 291 | the first entry in the .netrc file for C<$machine> will be returned. 292 | 293 | If a matching entry cannot be found, and a default entry exists, then a 294 | reference to the default entry is returned. 295 | 296 | If there is no matching entry found and there is no default defined, or 297 | no .netrc file is found, then C is returned. 298 | 299 | =back 300 | 301 | =head2 Object Methods 302 | 303 | =over 4 304 | 305 | =item C 306 | 307 | Return the login id for the netrc entry 308 | 309 | =item C 310 | 311 | Return the password for the netrc entry 312 | 313 | =item C 314 | 315 | Return the account information for the netrc entry 316 | 317 | =item C 318 | 319 | Return a list of login, password and account information for the netrc entry 320 | 321 | =back 322 | 323 | =head1 EXPORTS 324 | 325 | I. 326 | 327 | =head1 KNOWN BUGS 328 | 329 | See L. 330 | 331 | =head1 SEE ALSO 332 | 333 | L. 334 | 335 | =head1 AUTHOR 336 | 337 | Graham Barr ELE. 338 | 339 | Steve Hay ELE is now maintaining 340 | libnet as of version 1.22_02. 341 | 342 | =head1 COPYRIGHT 343 | 344 | Copyright (C) 1995-1998 Graham Barr. All rights reserved. 345 | 346 | Copyright (C) 2013-2014, 2020 Steve Hay. All rights reserved. 347 | 348 | =head1 LICENCE 349 | 350 | This module is free software; you can redistribute it and/or modify it under the 351 | same terms as Perl itself, i.e. under the terms of either the GNU General Public 352 | License or the Artistic License, as specified in the F file. 353 | 354 | =head1 VERSION 355 | 356 | Version 3.16 357 | 358 | =head1 DATE 359 | 360 | TODO 361 | 362 | =head1 HISTORY 363 | 364 | See the F file. 365 | 366 | =cut 367 | -------------------------------------------------------------------------------- /lib/Net/Config.pm: -------------------------------------------------------------------------------- 1 | # Net::Config.pm 2 | # 3 | # Copyright (C) 2000 Graham Barr. All rights reserved. 4 | # Copyright (C) 2013-2014, 2016, 2020 Steve Hay. All rights reserved. 5 | # This module is free software; you can redistribute it and/or modify it under 6 | # the same terms as Perl itself, i.e. under the terms of either the GNU General 7 | # Public License or the Artistic License, as specified in the F file. 8 | 9 | package Net::Config; 10 | 11 | use 5.008001; 12 | 13 | use strict; 14 | use warnings; 15 | 16 | use Exporter; 17 | use Socket qw(inet_aton inet_ntoa); 18 | 19 | our @EXPORT = qw(%NetConfig); 20 | our @ISA = qw(Net::LocalCfg Exporter); 21 | our $VERSION = "3.16"; 22 | 23 | our($CONFIGURE, $LIBNET_CFG); 24 | 25 | eval { 26 | local @INC = @INC; 27 | pop @INC if $INC[-1] eq '.'; 28 | local $SIG{__DIE__}; 29 | require Net::LocalCfg; 30 | }; 31 | 32 | our %NetConfig = ( 33 | nntp_hosts => [], 34 | snpp_hosts => [], 35 | pop3_hosts => [], 36 | smtp_hosts => [], 37 | ph_hosts => [], 38 | daytime_hosts => [], 39 | time_hosts => [], 40 | inet_domain => undef, 41 | ftp_firewall => undef, 42 | ftp_ext_passive => 1, 43 | ftp_int_passive => 1, 44 | test_hosts => 1, 45 | test_exist => 1, 46 | ); 47 | 48 | # 49 | # Try to get as much configuration info as possible from InternetConfig 50 | # 51 | { 52 | ## no critic (BuiltinFunctions::ProhibitStringyEval) 53 | $^O eq 'MacOS' and eval < [ \$InternetConfig{ kICNNTPHost() } ], 59 | pop3_hosts => [ \$InternetConfig{ kICMailAccount() } =~ /\@(.*)/ ], 60 | smtp_hosts => [ \$InternetConfig{ kICSMTPHost() } ], 61 | ftp_testhost => \$InternetConfig{ kICFTPHost() } ? \$InternetConfig{ kICFTPHost()} : undef, 62 | ph_hosts => [ \$InternetConfig{ kICPhHost() } ], 63 | ftp_ext_passive => \$InternetConfig{"646F676F\xA5UsePassiveMode"} || 0, 64 | ftp_int_passive => \$InternetConfig{"646F676F\xA5UsePassiveMode"} || 0, 65 | socks_hosts => 66 | \$InternetConfig{ kICUseSocks() } ? [ \$InternetConfig{ kICSocksHost() } ] : [], 67 | ftp_firewall => 68 | \$InternetConfig{ kICUseFTPProxy() } ? [ \$InternetConfig{ kICFTPProxyHost() } ] : [], 69 | ); 70 | \@NetConfig{keys %nc} = values %nc; 71 | } 72 | TRY_INTERNET_CONFIG 73 | } 74 | 75 | my $file = __FILE__; 76 | my $ref; 77 | $file =~ s/Config.pm/libnet.cfg/; 78 | if (-f $file) { 79 | $ref = eval { local $SIG{__DIE__}; do $file }; 80 | if (ref($ref) eq 'HASH') { 81 | %NetConfig = (%NetConfig, %{$ref}); 82 | $LIBNET_CFG = $file; 83 | } 84 | } 85 | if ($< == $> and !$CONFIGURE) { 86 | my $home = eval { local $SIG{__DIE__}; (getpwuid($>))[7] } || $ENV{HOME}; 87 | $home ||= $ENV{HOMEDRIVE} . ($ENV{HOMEPATH} || '') if defined $ENV{HOMEDRIVE}; 88 | if (defined $home) { 89 | $file = $home . "/.libnetrc"; 90 | $ref = eval { local $SIG{__DIE__}; do $file } if -f $file; 91 | %NetConfig = (%NetConfig, %{$ref}) 92 | if ref($ref) eq 'HASH'; 93 | } 94 | } 95 | my ($k, $v); 96 | while (($k, $v) = each %NetConfig) { 97 | $NetConfig{$k} = [$v] 98 | if ($k =~ /_hosts$/ and $k ne "test_hosts" and defined($v) and !ref($v)); 99 | } 100 | 101 | # Take a hostname and determine if it is inside the firewall 102 | 103 | 104 | sub requires_firewall { 105 | shift; # ignore package 106 | my $host = shift; 107 | 108 | return 0 unless defined $NetConfig{'ftp_firewall'}; 109 | 110 | $host = inet_aton($host) or return -1; 111 | $host = inet_ntoa($host); 112 | 113 | if (exists $NetConfig{'local_netmask'}) { 114 | my $quad = unpack("N", pack("C*", split(/\./, $host))); 115 | my $list = $NetConfig{'local_netmask'}; 116 | $list = [$list] unless ref($list); 117 | foreach (@$list) { 118 | my ($net, $bits) = (m#^(\d+\.\d+\.\d+\.\d+)/(\d+)$#) or next; 119 | my $mask = ~0 << (32 - $bits); 120 | my $addr = unpack("N", pack("C*", split(/\./, $net))); 121 | 122 | return 0 if (($addr & $mask) == ($quad & $mask)); 123 | } 124 | return 1; 125 | } 126 | 127 | return 0; 128 | } 129 | 130 | *is_external = \&requires_firewall; 131 | 132 | 1; 133 | 134 | __END__ 135 | 136 | =head1 NAME 137 | 138 | Net::Config - Local configuration data for libnet 139 | 140 | =head1 SYNOPSIS 141 | 142 | use Net::Config qw(%NetConfig); 143 | 144 | =head1 DESCRIPTION 145 | 146 | C holds configuration data for the modules in the libnet 147 | distribution. During installation you will be asked for these values. 148 | 149 | The configuration data is held globally in a file in the perl installation 150 | tree, but a user may override any of these values by providing their own. This 151 | can be done by having a C<.libnetrc> file in their home directory. This file 152 | should return a reference to a HASH containing the keys described below. 153 | For example 154 | 155 | # .libnetrc 156 | { 157 | nntp_hosts => [ "my_preferred_host" ], 158 | ph_hosts => [ "my_ph_server" ], 159 | } 160 | __END__ 161 | 162 | =head2 Class Methods 163 | 164 | C defines the following methods. They are methods as they are 165 | invoked as class methods. This is because C inherits from 166 | C so you can override these methods if you want. 167 | 168 | =over 4 169 | 170 | =item C 171 | 172 | Attempts to determine if a given host is outside your firewall. Possible 173 | return values are. 174 | 175 | -1 Cannot lookup hostname 176 | 0 Host is inside firewall (or there is no ftp_firewall entry) 177 | 1 Host is outside the firewall 178 | 179 | This is done by using hostname lookup and the C entry in 180 | the configuration data. 181 | 182 | =back 183 | 184 | =head2 NetConfig Values 185 | 186 | =over 4 187 | 188 | =item nntp_hosts 189 | 190 | =item snpp_hosts 191 | 192 | =item pop3_hosts 193 | 194 | =item smtp_hosts 195 | 196 | =item ph_hosts 197 | 198 | =item daytime_hosts 199 | 200 | =item time_hosts 201 | 202 | Each is a reference to an array of hostnames (in order of preference), 203 | which should be used for the given protocol 204 | 205 | =item inet_domain 206 | 207 | Your internet domain name 208 | 209 | =item ftp_firewall 210 | 211 | If you have an FTP proxy firewall (B an HTTP or SOCKS firewall) 212 | then this value should be set to the firewall hostname. If your firewall 213 | does not listen to port 21, then this value should be set to 214 | C<"hostname:port"> (eg C<"hostname:99">) 215 | 216 | =item ftp_firewall_type 217 | 218 | There are many different ftp firewall products available. But unfortunately 219 | there is no standard for how to traverse a firewall. The list below shows the 220 | sequence of commands that Net::FTP will use 221 | 222 | user Username for remote host 223 | pass Password for remote host 224 | fwuser Username for firewall 225 | fwpass Password for firewall 226 | remote.host The hostname of the remote ftp server 227 | 228 | =over 4 229 | 230 | =item 0Z<> 231 | 232 | There is no firewall 233 | 234 | =item 1Z<> 235 | 236 | USER user@remote.host 237 | PASS pass 238 | 239 | =item 2Z<> 240 | 241 | USER fwuser 242 | PASS fwpass 243 | USER user@remote.host 244 | PASS pass 245 | 246 | =item 3Z<> 247 | 248 | USER fwuser 249 | PASS fwpass 250 | SITE remote.site 251 | USER user 252 | PASS pass 253 | 254 | =item 4Z<> 255 | 256 | USER fwuser 257 | PASS fwpass 258 | OPEN remote.site 259 | USER user 260 | PASS pass 261 | 262 | =item 5Z<> 263 | 264 | USER user@fwuser@remote.site 265 | PASS pass@fwpass 266 | 267 | =item 6Z<> 268 | 269 | USER fwuser@remote.site 270 | PASS fwpass 271 | USER user 272 | PASS pass 273 | 274 | =item 7Z<> 275 | 276 | USER user@remote.host 277 | PASS pass 278 | AUTH fwuser 279 | RESP fwpass 280 | 281 | =back 282 | 283 | =item ftp_ext_passive 284 | 285 | =item ftp_int_passive 286 | 287 | FTP servers can work in passive or active mode. Active mode is when 288 | you want to transfer data you have to tell the server the address and 289 | port to connect to. Passive mode is when the server provide the 290 | address and port and you establish the connection. 291 | 292 | With some firewalls active mode does not work as the server cannot 293 | connect to your machine (because you are behind a firewall) and the firewall 294 | does not re-write the command. In this case you should set C 295 | to a I value. 296 | 297 | Some servers are configured to only work in passive mode. If you have 298 | one of these you can force C to always transfer in passive 299 | mode; when not going via a firewall, by setting C to 300 | a I value. 301 | 302 | =item local_netmask 303 | 304 | A reference to a list of netmask strings in the form C<"134.99.4.0/24">. 305 | These are used by the C function to determine if a given 306 | host is inside or outside your firewall. 307 | 308 | =back 309 | 310 | The following entries are used during installation & testing on the 311 | libnet package 312 | 313 | =over 4 314 | 315 | =item test_hosts 316 | 317 | If true then C may attempt to connect to hosts given in the 318 | configuration. 319 | 320 | =item test_exists 321 | 322 | If true then C will check each hostname given that it exists 323 | 324 | =back 325 | 326 | =head1 EXPORTS 327 | 328 | The following symbols are, or can be, exported by this module: 329 | 330 | =over 4 331 | 332 | =item Default Exports 333 | 334 | C<%NetConfig>. 335 | 336 | =item Optional Exports 337 | 338 | I. 339 | 340 | =item Export Tags 341 | 342 | I. 343 | 344 | =back 345 | 346 | =head1 KNOWN BUGS 347 | 348 | I. 349 | 350 | =head1 AUTHOR 351 | 352 | Graham Barr ELE. 353 | 354 | Steve Hay ELE is now maintaining 355 | libnet as of version 1.22_02. 356 | 357 | =head1 COPYRIGHT 358 | 359 | Copyright (C) 2000 Graham Barr. All rights reserved. 360 | 361 | Copyright (C) 2013-2014, 2016, 2020 Steve Hay. All rights reserved. 362 | 363 | =head1 LICENCE 364 | 365 | This module is free software; you can redistribute it and/or modify it under the 366 | same terms as Perl itself, i.e. under the terms of either the GNU General Public 367 | License or the Artistic License, as specified in the F file. 368 | 369 | =head1 VERSION 370 | 371 | Version 3.16 372 | 373 | =head1 DATE 374 | 375 | TODO 376 | 377 | =head1 HISTORY 378 | 379 | See the F file. 380 | 381 | =cut 382 | -------------------------------------------------------------------------------- /lib/Net/Domain.pm: -------------------------------------------------------------------------------- 1 | # Net::Domain.pm 2 | # 3 | # Copyright (C) 1995-1998 Graham Barr. All rights reserved. 4 | # Copyright (C) 2013-2014, 2020 Steve Hay. All rights reserved. 5 | # This module is free software; you can redistribute it and/or modify it under 6 | # the same terms as Perl itself, i.e. under the terms of either the GNU General 7 | # Public License or the Artistic License, as specified in the F file. 8 | 9 | package Net::Domain; 10 | 11 | use 5.008001; 12 | 13 | use strict; 14 | use warnings; 15 | 16 | use Carp; 17 | use Exporter; 18 | use Net::Config; 19 | 20 | our @ISA = qw(Exporter); 21 | our @EXPORT_OK = qw(hostname hostdomain hostfqdn domainname); 22 | our $VERSION = "3.16"; 23 | 24 | my ($host, $domain, $fqdn) = (undef, undef, undef); 25 | 26 | # Try every conceivable way to get hostname. 27 | 28 | 29 | sub _hostname { 30 | 31 | # we already know it 32 | return $host 33 | if (defined $host); 34 | 35 | if ($^O eq 'MSWin32') { 36 | require Socket; 37 | my ($name, $alias, $type, $len, @addr) = gethostbyname($ENV{'COMPUTERNAME'} || 'localhost'); 38 | while (@addr) { 39 | my $a = shift(@addr); 40 | $host = gethostbyaddr($a, Socket::AF_INET()); 41 | last if defined $host; 42 | } 43 | if (defined($host) && index($host, '.') > 0) { 44 | $fqdn = $host; 45 | ($host, $domain) = $fqdn =~ /^([^.]+)\.(.*)$/; 46 | } 47 | return $host; 48 | } 49 | elsif ($^O eq 'MacOS') { 50 | chomp($host = `hostname`); 51 | } 52 | elsif ($^O eq 'VMS') { ## multiple varieties of net s/w makes this hard 53 | $host = $ENV{'UCX$INET_HOST'} if defined($ENV{'UCX$INET_HOST'}); 54 | $host = $ENV{'MULTINET_HOST_NAME'} if defined($ENV{'MULTINET_HOST_NAME'}); 55 | if (index($host, '.') > 0) { 56 | $fqdn = $host; 57 | ($host, $domain) = $fqdn =~ /^([^.]+)\.(.*)$/; 58 | } 59 | return $host; 60 | } 61 | else { 62 | local $SIG{'__DIE__'}; 63 | 64 | # syscall is preferred since it avoids tainting problems 65 | eval { 66 | my $tmp = "\0" x 256; ## preload scalar 67 | eval { 68 | package main; 69 | require "syscall.ph"; ## no critic (Modules::RequireBarewordIncludes) 70 | defined(&main::SYS_gethostname); 71 | } 72 | || eval { 73 | package main; 74 | require "sys/syscall.ph"; ## no critic (Modules::RequireBarewordIncludes) 75 | defined(&main::SYS_gethostname); 76 | } 77 | and $host = 78 | (syscall(&main::SYS_gethostname, $tmp, 256) == 0) 79 | ? $tmp 80 | : undef; 81 | } 82 | 83 | # POSIX 84 | || eval { 85 | require POSIX; 86 | $host = (POSIX::uname())[1]; 87 | } 88 | 89 | # trusty old hostname command 90 | || eval { 91 | chop($host = `(hostname) 2>/dev/null`); # BSD'ish 92 | } 93 | 94 | # sysV/POSIX uname command (may truncate) 95 | || eval { 96 | chop($host = `uname -n 2>/dev/null`); ## SYSV'ish && POSIX'ish 97 | } 98 | 99 | # Apollo pre-SR10 100 | || eval { $host = (split(/[:. ]/, `/com/host`, 6))[0]; } 101 | 102 | || eval { $host = ""; }; 103 | } 104 | 105 | # remove garbage 106 | $host =~ s/[\0\r\n]+//go; 107 | $host =~ s/(\A\.+|\.+\Z)//go; 108 | $host =~ s/\.\.+/\./go; 109 | 110 | $host; 111 | } 112 | 113 | 114 | sub _hostdomain { 115 | 116 | # we already know it 117 | return $domain 118 | if (defined $domain); 119 | 120 | local $SIG{'__DIE__'}; 121 | 122 | return $domain = $NetConfig{'inet_domain'} 123 | if defined $NetConfig{'inet_domain'}; 124 | 125 | # try looking in /etc/resolv.conf 126 | # putting this here and assuming that it is correct, eliminates 127 | # calls to gethostbyname, and therefore DNS lookups. This helps 128 | # those on dialup systems. 129 | 130 | local ($_); 131 | 132 | if (open(my $res, '<', "/etc/resolv.conf")) { 133 | while (<$res>) { 134 | $domain = $1 135 | if (/\A\s*(?:domain|search)\s+(\S+)/); 136 | } 137 | close($res); 138 | 139 | return $domain 140 | if (defined $domain); 141 | } 142 | 143 | # just try hostname and system calls 144 | 145 | my $host = _hostname(); 146 | my (@hosts); 147 | 148 | @hosts = ($host, "localhost"); 149 | 150 | unless (defined($host) && $host =~ /\./) { 151 | my $dom = undef; 152 | eval { 153 | my $tmp = "\0" x 256; ## preload scalar 154 | eval { 155 | package main; 156 | require "syscall.ph"; ## no critic (Modules::RequireBarewordIncludes) 157 | } 158 | || eval { 159 | package main; 160 | require "sys/syscall.ph"; ## no critic (Modules::RequireBarewordIncludes) 161 | } 162 | and $dom = 163 | (syscall(&main::SYS_getdomainname, $tmp, 256) == 0) 164 | ? $tmp 165 | : undef; 166 | }; 167 | 168 | if ($^O eq 'VMS') { 169 | $dom ||= $ENV{'TCPIP$INET_DOMAIN'} 170 | || $ENV{'UCX$INET_DOMAIN'}; 171 | } 172 | 173 | chop($dom = `domainname 2>/dev/null`) 174 | unless (defined $dom || $^O =~ /^(?:cygwin|MSWin32|android)/); 175 | 176 | if (defined $dom) { 177 | my @h = (); 178 | $dom =~ s/^\.+//; 179 | while (length($dom)) { 180 | push(@h, "$host.$dom"); 181 | $dom =~ s/^[^.]+.+// or last; 182 | } 183 | unshift(@hosts, @h); 184 | } 185 | } 186 | 187 | # Attempt to locate FQDN 188 | 189 | foreach (grep { defined $_ } @hosts) { 190 | my @info = gethostbyname($_); 191 | 192 | next unless @info; 193 | 194 | # look at real name & aliases 195 | foreach my $site ($info[0], split(/ /, $info[1])) { 196 | if (rindex($site, ".") > 0) { 197 | 198 | # Extract domain from FQDN 199 | 200 | ($domain = $site) =~ s/\A[^.]+\.//; 201 | return $domain; 202 | } 203 | } 204 | } 205 | 206 | # Look for environment variable 207 | 208 | $domain ||= $ENV{LOCALDOMAIN} || $ENV{DOMAIN}; 209 | 210 | if (defined $domain) { 211 | $domain =~ s/[\r\n\0]+//g; 212 | $domain =~ s/(\A\.+|\.+\Z)//g; 213 | $domain =~ s/\.\.+/\./g; 214 | } 215 | 216 | $domain; 217 | } 218 | 219 | 220 | sub domainname { 221 | 222 | return $fqdn 223 | if (defined $fqdn); 224 | 225 | _hostname(); 226 | 227 | # *.local names are special on darwin. If we call gethostbyname below, it 228 | # may hang while waiting for another, non-existent computer to respond. 229 | if($^O eq 'darwin' && $host =~ /\.local$/) { 230 | return $host; 231 | } 232 | 233 | _hostdomain(); 234 | 235 | # Assumption: If the host name does not contain a period 236 | # and the domain name does, then assume that they are correct 237 | # this helps to eliminate calls to gethostbyname, and therefore 238 | # eliminate DNS lookups 239 | 240 | return $fqdn = $host . "." . $domain 241 | if (defined $host 242 | and defined $domain 243 | and $host !~ /\./ 244 | and $domain =~ /\./); 245 | 246 | # For hosts that have no name, just an IP address 247 | return $fqdn = $host if defined $host and $host =~ /^\d+(\.\d+){3}$/; 248 | 249 | my @host = defined $host ? split(/\./, $host) : ('localhost'); 250 | my @domain = defined $domain ? split(/\./, $domain) : (); 251 | my @fqdn = (); 252 | 253 | # Determine from @host & @domain the FQDN 254 | 255 | my @d = @domain; 256 | 257 | LOOP: 258 | while (1) { 259 | my @h = @host; 260 | while (@h) { 261 | my $tmp = join(".", @h, @d); 262 | if ((gethostbyname($tmp))[0]) { 263 | @fqdn = (@h, @d); 264 | $fqdn = $tmp; 265 | last LOOP; 266 | } 267 | pop @h; 268 | } 269 | last unless shift @d; 270 | } 271 | 272 | if (@fqdn) { 273 | $host = shift @fqdn; 274 | until ((gethostbyname($host))[0]) { 275 | $host .= "." . shift @fqdn; 276 | } 277 | $domain = join(".", @fqdn); 278 | } 279 | else { 280 | undef $host; 281 | undef $domain; 282 | undef $fqdn; 283 | } 284 | 285 | $fqdn; 286 | } 287 | 288 | 289 | sub hostfqdn { domainname() } 290 | 291 | 292 | sub hostname { 293 | domainname() 294 | unless (defined $host); 295 | return $host; 296 | } 297 | 298 | 299 | sub hostdomain { 300 | domainname() 301 | unless (defined $domain); 302 | return $domain; 303 | } 304 | 305 | 1; # Keep require happy 306 | 307 | __END__ 308 | 309 | =head1 NAME 310 | 311 | Net::Domain - Attempt to evaluate the current host's internet name and domain 312 | 313 | =head1 SYNOPSIS 314 | 315 | use Net::Domain qw(hostname hostfqdn hostdomain domainname); 316 | 317 | =head1 DESCRIPTION 318 | 319 | Using various methods B to find the Fully Qualified Domain Name (FQDN) 320 | of the current host. From this determine the host-name and the host-domain. 321 | 322 | Each of the functions will return I if the FQDN cannot be determined. 323 | 324 | =head2 Functions 325 | 326 | =over 4 327 | 328 | =item C 329 | 330 | Identify and return the FQDN of the current host. 331 | 332 | =item C 333 | 334 | An alias for hostfqdn(). 335 | 336 | =item C 337 | 338 | Returns the smallest part of the FQDN which can be used to identify the host. 339 | 340 | =item C 341 | 342 | Returns the remainder of the FQDN after the I has been removed. 343 | 344 | =back 345 | 346 | =head1 EXPORTS 347 | 348 | The following symbols are, or can be, exported by this module: 349 | 350 | =over 4 351 | 352 | =item Default Exports 353 | 354 | I. 355 | 356 | =item Optional Exports 357 | 358 | C, 359 | C, 360 | C, 361 | C. 362 | 363 | =item Export Tags 364 | 365 | I. 366 | 367 | =back 368 | 369 | 370 | =head1 KNOWN BUGS 371 | 372 | See L. 373 | 374 | =head1 AUTHOR 375 | 376 | Graham Barr ELE. 377 | 378 | Adapted from Sys::Hostname by David Sundstrom 379 | ELE. 380 | 381 | Steve Hay ELE is now maintaining 382 | libnet as of version 1.22_02. 383 | 384 | =head1 COPYRIGHT 385 | 386 | Copyright (C) 1995-1998 Graham Barr. All rights reserved. 387 | 388 | Copyright (C) 2013-2014, 2020 Steve Hay. All rights reserved. 389 | 390 | =head1 LICENCE 391 | 392 | This module is free software; you can redistribute it and/or modify it under the 393 | same terms as Perl itself, i.e. under the terms of either the GNU General Public 394 | License or the Artistic License, as specified in the F file. 395 | 396 | =head1 VERSION 397 | 398 | Version 3.16 399 | 400 | =head1 DATE 401 | 402 | TODO 403 | 404 | =head1 HISTORY 405 | 406 | See the F file. 407 | 408 | =cut 409 | -------------------------------------------------------------------------------- /lib/Net/libnetFAQ.pod: -------------------------------------------------------------------------------- 1 | =head1 NAME 2 | 3 | libnetFAQ - libnet Frequently Asked Questions 4 | 5 | =head1 DESCRIPTION 6 | 7 | =head2 Where to get this document 8 | 9 | This document is distributed with the libnet distribution, and is also 10 | available on the libnet web page at 11 | 12 | L 13 | 14 | =head2 How to contribute to this document 15 | 16 | You may report corrections, additions, and suggestions on the 17 | CPAN Request Tracker at 18 | 19 | L 20 | 21 | =head1 Author and Copyright Information 22 | 23 | Copyright (C) 1997-1998 Graham Barr. All rights reserved. 24 | This document is free; you can redistribute it and/or modify it under 25 | the same terms as Perl itself, i.e. under the terms of either the GNU 26 | General Public License or the Artistic License, as specified in the 27 | F file. 28 | 29 | Steve Hay ELE is now maintaining 30 | libnet as of version 1.22_02. 31 | 32 | =head2 Disclaimer 33 | 34 | This information is offered in good faith and in the hope that it may 35 | be of use, but is not guaranteed to be correct, up to date, or suitable 36 | for any particular purpose whatsoever. The authors accept no liability 37 | in respect of this information or its use. 38 | 39 | 40 | =head1 Obtaining and installing libnet 41 | 42 | =head2 What is libnet ? 43 | 44 | libnet is a collection of perl5 modules which all related to network 45 | programming. The majority of the modules available provided the 46 | client side of popular server-client protocols that are used in 47 | the internet community. 48 | 49 | =head2 Which version of perl do I need ? 50 | 51 | This version of libnet requires Perl 5.8.1 or higher. 52 | 53 | =head2 What other modules do I need ? 54 | 55 | No non-core modules are required for normal use, except on os390, 56 | which requires Convert::EBCDIC. 57 | 58 | Authen::SASL is required for AUTH support. 59 | 60 | IO::Socket::SSL version 2.007 or higher is required for SSL support. 61 | 62 | IO::Socket::IP version 0.25 or IO::Socket::INET6 version 2.62 is 63 | required for IPv6 support. 64 | 65 | =head2 What machines support libnet ? 66 | 67 | libnet itself is an entirely perl-code distribution so it should work 68 | on any machine that perl runs on. 69 | 70 | =head2 Where can I get the latest libnet release 71 | 72 | The latest libnet release is always on CPAN, you will find it 73 | in 74 | 75 | L 76 | 77 | =head1 Using Net::FTP 78 | 79 | =head2 How do I download files from an FTP server ? 80 | 81 | An example taken from an article posted to comp.lang.perl.misc 82 | 83 | #!/your/path/to/perl 84 | 85 | # a module making life easier 86 | 87 | use Net::FTP; 88 | 89 | # for debugging: $ftp = Net::FTP->new('site','Debug',10); 90 | # open a connection and log in! 91 | 92 | $ftp = Net::FTP->new('target_site.somewhere.xxx'); 93 | $ftp->login('username','password'); 94 | 95 | # set transfer mode to binary 96 | 97 | $ftp->binary(); 98 | 99 | # change the directory on the ftp site 100 | 101 | $ftp->cwd('/some/path/to/somewhere/'); 102 | 103 | foreach $name ('file1', 'file2', 'file3') { 104 | 105 | # get's arguments are in the following order: 106 | # ftp server's filename 107 | # filename to save the transfer to on the local machine 108 | # can be simply used as get($name) if you want the same name 109 | 110 | $ftp->get($name,$name); 111 | } 112 | 113 | # ftp done! 114 | 115 | $ftp->quit; 116 | 117 | =head2 How do I transfer files in binary mode ? 118 | 119 | To transfer files without translation Net::FTP provides 120 | the C method 121 | 122 | $ftp->binary; 123 | 124 | =head2 How can I get the size of a file on a remote FTP server ? 125 | 126 | =head2 How can I get the modification time of a file on a remote FTP server ? 127 | 128 | =head2 How can I change the permissions of a file on a remote server ? 129 | 130 | The FTP protocol does not have a command for changing the permissions 131 | of a file on the remote server. But some ftp servers may allow a chmod 132 | command to be issued via a SITE command, eg 133 | 134 | $ftp->quot('site chmod 0777',$filename); 135 | 136 | But this is not guaranteed to work. 137 | 138 | =head2 Can I do a reget operation like the ftp command ? 139 | 140 | =head2 How do I get a directory listing from an FTP server ? 141 | 142 | =head2 Changing directory to "" does not fail ? 143 | 144 | Passing an argument of "" to ->cwd() has the same affect of calling ->cwd() 145 | without any arguments. Turn on Debug (I) and you will see what is 146 | happening 147 | 148 | $ftp = Net::FTP->new($host, Debug => 1); 149 | $ftp->login; 150 | $ftp->cwd(""); 151 | 152 | gives 153 | 154 | Net::FTP=GLOB(0x82196d8)>>> CWD / 155 | Net::FTP=GLOB(0x82196d8)<<< 250 CWD command successful. 156 | 157 | =head2 I am behind a SOCKS firewall, but the Firewall option does not work ? 158 | 159 | The Firewall option is only for support of one type of firewall. The type 160 | supported is an ftp proxy. 161 | 162 | To use Net::FTP, or any other module in the libnet distribution, 163 | through a SOCKS firewall you must create a socks-ified perl executable 164 | by compiling perl with the socks library. 165 | 166 | =head2 I am behind an FTP proxy firewall, but cannot access machines outside ? 167 | 168 | Net::FTP implements the most popular ftp proxy firewall approach. The scheme 169 | implemented is that where you log in to the firewall with C 170 | 171 | I have heard of one other type of firewall which requires a login to the 172 | firewall with an account, then a second login with C. You can 173 | still use Net::FTP to traverse these firewalls, but a more manual approach 174 | must be taken, eg 175 | 176 | $ftp = Net::FTP->new($firewall) or die $@; 177 | $ftp->login($firewall_user, $firewall_passwd) or die $ftp->message; 178 | $ftp->login($ext_user . '@' . $ext_host, $ext_passwd) or die $ftp->message. 179 | 180 | =head2 My ftp proxy firewall does not listen on port 21 181 | 182 | FTP servers usually listen on the same port number, port 21, as any other 183 | FTP server. But there is no reason why this has to be the case. 184 | 185 | If you pass a port number to Net::FTP then it assumes this is the port 186 | number of the final destination. By default Net::FTP will always try 187 | to connect to the firewall on port 21. 188 | 189 | Net::FTP uses IO::Socket to open the connection and IO::Socket allows 190 | the port number to be specified as part of the hostname. So this problem 191 | can be resolved by either passing a Firewall option like C<"hostname:1234"> 192 | or by setting the C option in Net::Config to be a string 193 | in the same form. 194 | 195 | =head2 Is it possible to change the file permissions of a file on an FTP server ? 196 | 197 | The answer to this is "maybe". The FTP protocol does not specify a command to change 198 | file permissions on a remote host. However many servers do allow you to run the 199 | chmod command via the C command. This can be done with 200 | 201 | $ftp->site('chmod','0775',$file); 202 | 203 | =head2 I have seen scripts call a method message, but cannot find it documented ? 204 | 205 | Net::FTP, like several other packages in libnet, inherits from Net::Cmd, so 206 | all the methods described in Net::Cmd are also available on Net::FTP 207 | objects. 208 | 209 | =head2 Why does Net::FTP not implement mput and mget methods 210 | 211 | The quick answer is because they are easy to implement yourself. The long 212 | answer is that to write these in such a way that multiple platforms are 213 | supported correctly would just require too much code. Below are 214 | some examples how you can implement these yourself. 215 | 216 | sub mput { 217 | my($ftp,$pattern) = @_; 218 | foreach my $file (glob($pattern)) { 219 | $ftp->put($file) or warn $ftp->message; 220 | } 221 | } 222 | 223 | sub mget { 224 | my($ftp,$pattern) = @_; 225 | foreach my $file ($ftp->ls($pattern)) { 226 | $ftp->get($file) or warn $ftp->message; 227 | } 228 | } 229 | 230 | 231 | =head1 Using Net::SMTP 232 | 233 | =head2 Why can't the part of an Email address after the @ be used as the hostname ? 234 | 235 | The part of an Email address which follows the @ is not necessarily a hostname, 236 | it is a mail domain. To find the name of a host to connect for a mail domain 237 | you need to do a DNS MX lookup 238 | 239 | =head2 Why does Net::SMTP not do DNS MX lookups ? 240 | 241 | Net::SMTP implements the SMTP protocol. The DNS MX lookup is not part 242 | of this protocol. 243 | 244 | =head2 The verify method always returns true ? 245 | 246 | Well it may seem that way, but it does not. The verify method returns true 247 | if the command succeeded. If you pass verify an address which the 248 | server would normally have to forward to another machine, the command 249 | will succeed with something like 250 | 251 | 252 Couldn't verify but will attempt delivery anyway 252 | 253 | This command will fail only if you pass it an address in a domain 254 | the server directly delivers for, and that address does not exist. 255 | 256 | =head1 Debugging scripts 257 | 258 | =head2 How can I debug my scripts that use Net::* modules ? 259 | 260 | Most of the libnet client classes allow options to be passed to the 261 | constructor, in most cases one option is called C. Passing 262 | this option with a non-zero value will turn on a protocol trace, which 263 | will be sent to STDERR. This trace can be useful to see what commands 264 | are being sent to the remote server and what responses are being 265 | received back. 266 | 267 | #!/your/path/to/perl 268 | 269 | use Net::FTP; 270 | 271 | my $ftp = new Net::FTP($host, Debug => 1); 272 | $ftp->login('gbarr','password'); 273 | $ftp->quit; 274 | 275 | this script would output something like 276 | 277 | Net::FTP: Net::FTP(2.22) 278 | Net::FTP: Exporter 279 | Net::FTP: Net::Cmd(2.0801) 280 | Net::FTP: IO::Socket::INET 281 | Net::FTP: IO::Socket(1.1603) 282 | Net::FTP: IO::Handle(1.1504) 283 | 284 | Net::FTP=GLOB(0x8152974)<<< 220 imagine FTP server (Version wu-2.4(5) Tue Jul 29 11:17:18 CDT 1997) ready. 285 | Net::FTP=GLOB(0x8152974)>>> user gbarr 286 | Net::FTP=GLOB(0x8152974)<<< 331 Password required for gbarr. 287 | Net::FTP=GLOB(0x8152974)>>> PASS .... 288 | Net::FTP=GLOB(0x8152974)<<< 230 User gbarr logged in. Access restrictions apply. 289 | Net::FTP=GLOB(0x8152974)>>> QUIT 290 | Net::FTP=GLOB(0x8152974)<<< 221 Goodbye. 291 | 292 | The first few lines tell you the modules that Net::FTP uses and their versions, 293 | this is useful data to me when a user reports a bug. The last seven lines 294 | show the communication with the server. Each line has three parts. The first 295 | part is the object itself, this is useful for separating the output 296 | if you are using multiple objects. The second part is either C<<<<<> to 297 | show data coming from the server or C<>>>>> to show data 298 | going to the server. The remainder of the line is the command 299 | being sent or response being received. 300 | 301 | =head1 AUTHOR AND COPYRIGHT 302 | 303 | Copyright (C) 1997-1998 Graham Barr. All rights reserved. 304 | -------------------------------------------------------------------------------- /Copying: -------------------------------------------------------------------------------- 1 | 2 | GNU GENERAL PUBLIC LICENSE 3 | Version 1, February 1989 4 | 5 | Copyright (C) 1989 Free Software Foundation, Inc. 6 | 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 7 | 8 | Everyone is permitted to copy and distribute verbatim copies 9 | of this license document, but changing it is not allowed. 10 | 11 | Preamble 12 | 13 | The license agreements of most software companies try to keep users 14 | at the mercy of those companies. By contrast, our General Public 15 | License is intended to guarantee your freedom to share and change free 16 | software--to make sure the software is free for all its users. The 17 | General Public License applies to the Free Software Foundation's 18 | software and to any other program whose authors commit to using it. 19 | You can use it for your programs, too. 20 | 21 | When we speak of free software, we are referring to freedom, not 22 | price. Specifically, the General Public License is designed to make 23 | sure that you have the freedom to give away or sell copies of free 24 | software, that you receive source code or can get it if you want it, 25 | that you can change the software or use pieces of it in new free 26 | programs; and that you know you can do these things. 27 | 28 | To protect your rights, we need to make restrictions that forbid 29 | anyone to deny you these rights or to ask you to surrender the rights. 30 | These restrictions translate to certain responsibilities for you if you 31 | distribute copies of the software, or if you modify it. 32 | 33 | For example, if you distribute copies of a such a program, whether 34 | gratis or for a fee, you must give the recipients all the rights that 35 | you have. You must make sure that they, too, receive or can get the 36 | source code. And you must tell them their rights. 37 | 38 | We protect your rights with two steps: (1) copyright the software, and 39 | (2) offer you this license which gives you legal permission to copy, 40 | distribute and/or modify the software. 41 | 42 | Also, for each author's protection and ours, we want to make certain 43 | that everyone understands that there is no warranty for this free 44 | software. If the software is modified by someone else and passed on, we 45 | want its recipients to know that what they have is not the original, so 46 | that any problems introduced by others will not reflect on the original 47 | authors' reputations. 48 | 49 | The precise terms and conditions for copying, distribution and 50 | modification follow. 51 | 52 | GNU GENERAL PUBLIC LICENSE 53 | TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 54 | 55 | 0. This License Agreement applies to any program or other work which 56 | contains a notice placed by the copyright holder saying it may be 57 | distributed under the terms of this General Public License. The 58 | "Program", below, refers to any such program or work, and a "work based 59 | on the Program" means either the Program or any work containing the 60 | Program or a portion of it, either verbatim or with modifications. Each 61 | licensee is addressed as "you". 62 | 63 | 1. You may copy and distribute verbatim copies of the Program's source 64 | code as you receive it, in any medium, provided that you conspicuously and 65 | appropriately publish on each copy an appropriate copyright notice and 66 | disclaimer of warranty; keep intact all the notices that refer to this 67 | General Public License and to the absence of any warranty; and give any 68 | other recipients of the Program a copy of this General Public License 69 | along with the Program. You may charge a fee for the physical act of 70 | transferring a copy. 71 | 72 | 2. You may modify your copy or copies of the Program or any portion of 73 | it, and copy and distribute such modifications under the terms of Paragraph 74 | 1 above, provided that you also do the following: 75 | 76 | a) cause the modified files to carry prominent notices stating that 77 | you changed the files and the date of any change; and 78 | 79 | b) cause the whole of any work that you distribute or publish, that 80 | in whole or in part contains the Program or any part thereof, either 81 | with or without modifications, to be licensed at no charge to all 82 | third parties under the terms of this General Public License (except 83 | that you may choose to grant warranty protection to some or all 84 | third parties, at your option). 85 | 86 | c) If the modified program normally reads commands interactively when 87 | run, you must cause it, when started running for such interactive use 88 | in the simplest and most usual way, to print or display an 89 | announcement including an appropriate copyright notice and a notice 90 | that there is no warranty (or else, saying that you provide a 91 | warranty) and that users may redistribute the program under these 92 | conditions, and telling the user how to view a copy of this General 93 | Public License. 94 | 95 | d) You may charge a fee for the physical act of transferring a 96 | copy, and you may at your option offer warranty protection in 97 | exchange for a fee. 98 | 99 | Mere aggregation of another independent work with the Program (or its 100 | derivative) on a volume of a storage or distribution medium does not bring 101 | the other work under the scope of these terms. 102 | 103 | 3. You may copy and distribute the Program (or a portion or derivative of 104 | it, under Paragraph 2) in object code or executable form under the terms of 105 | Paragraphs 1 and 2 above provided that you also do one of the following: 106 | 107 | a) accompany it with the complete corresponding machine-readable 108 | source code, which must be distributed under the terms of 109 | Paragraphs 1 and 2 above; or, 110 | 111 | b) accompany it with a written offer, valid for at least three 112 | years, to give any third party free (except for a nominal charge 113 | for the cost of distribution) a complete machine-readable copy of the 114 | corresponding source code, to be distributed under the terms of 115 | Paragraphs 1 and 2 above; or, 116 | 117 | c) accompany it with the information you received as to where the 118 | corresponding source code may be obtained. (This alternative is 119 | allowed only for noncommercial distribution and only if you 120 | received the program in object code or executable form alone.) 121 | 122 | Source code for a work means the preferred form of the work for making 123 | modifications to it. For an executable file, complete source code means 124 | all the source code for all modules it contains; but, as a special 125 | exception, it need not include source code for modules which are standard 126 | libraries that accompany the operating system on which the executable 127 | file runs, or for standard header files or definitions files that 128 | accompany that operating system. 129 | 130 | 4. You may not copy, modify, sublicense, distribute or transfer the 131 | Program except as expressly provided under this General Public License. 132 | Any attempt otherwise to copy, modify, sublicense, distribute or transfer 133 | the Program is void, and will automatically terminate your rights to use 134 | the Program under this License. However, parties who have received 135 | copies, or rights to use copies, from you under this General Public 136 | License will not have their licenses terminated so long as such parties 137 | remain in full compliance. 138 | 139 | 5. By copying, distributing or modifying the Program (or any work based 140 | on the Program) you indicate your acceptance of this license to do so, 141 | and all its terms and conditions. 142 | 143 | 6. Each time you redistribute the Program (or any work based on the 144 | Program), the recipient automatically receives a license from the original 145 | licensor to copy, distribute or modify the Program subject to these 146 | terms and conditions. You may not impose any further restrictions on the 147 | recipients' exercise of the rights granted herein. 148 | 149 | 7. The Free Software Foundation may publish revised and/or new versions 150 | of the General Public License from time to time. Such new versions will 151 | be similar in spirit to the present version, but may differ in detail to 152 | address new problems or concerns. 153 | 154 | Each version is given a distinguishing version number. If the Program 155 | specifies a version number of the license which applies to it and "any 156 | later version", you have the option of following the terms and conditions 157 | either of that version or of any later version published by the Free 158 | Software Foundation. If the Program does not specify a version number of 159 | the license, you may choose any version ever published by the Free Software 160 | Foundation. 161 | 162 | 8. If you wish to incorporate parts of the Program into other free 163 | programs whose distribution conditions are different, write to the author 164 | to ask for permission. For software which is copyrighted by the Free 165 | Software Foundation, write to the Free Software Foundation; we sometimes 166 | make exceptions for this. Our decision will be guided by the two goals 167 | of preserving the free status of all derivatives of our free software and 168 | of promoting the sharing and reuse of software generally. 169 | 170 | NO WARRANTY 171 | 172 | 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY 173 | FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN 174 | OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES 175 | PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED 176 | OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 177 | MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS 178 | TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE 179 | PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, 180 | REPAIR OR CORRECTION. 181 | 182 | 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 183 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR 184 | REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, 185 | INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING 186 | OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED 187 | TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY 188 | YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER 189 | PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE 190 | POSSIBILITY OF SUCH DAMAGES. 191 | 192 | END OF TERMS AND CONDITIONS 193 | 194 | Appendix: How to Apply These Terms to Your New Programs 195 | 196 | If you develop a new program, and you want it to be of the greatest 197 | possible use to humanity, the best way to achieve this is to make it 198 | free software which everyone can redistribute and change under these 199 | terms. 200 | 201 | To do so, attach the following notices to the program. It is safest to 202 | attach them to the start of each source file to most effectively convey 203 | the exclusion of warranty; and each file should have at least the 204 | "copyright" line and a pointer to where the full notice is found. 205 | 206 | 207 | Copyright (C) 19yy 208 | 209 | This program is free software; you can redistribute it and/or modify 210 | it under the terms of the GNU General Public License as published by 211 | the Free Software Foundation; either version 1, or (at your option) 212 | any later version. 213 | 214 | This program is distributed in the hope that it will be useful, 215 | but WITHOUT ANY WARRANTY; without even the implied warranty of 216 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 217 | GNU General Public License for more details. 218 | 219 | You should have received a copy of the GNU General Public License 220 | along with this program; if not, write to the Free Software 221 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA 222 | 223 | 224 | Also add information on how to contact you by electronic and paper mail. 225 | 226 | If the program is interactive, make it output a short notice like this 227 | when it starts in an interactive mode: 228 | 229 | Gnomovision version 69, Copyright (C) 19xx name of author 230 | Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. 231 | This is free software, and you are welcome to redistribute it 232 | under certain conditions; type `show c' for details. 233 | 234 | The hypothetical commands `show w' and `show c' should show the 235 | appropriate parts of the General Public License. Of course, the 236 | commands you use may be called something other than `show w' and `show 237 | c'; they could even be mouse-clicks or menu items--whatever suits your 238 | program. 239 | 240 | You should also get your employer (if you work as a programmer) or your 241 | school, if any, to sign a "copyright disclaimer" for the program, if 242 | necessary. Here a sample; alter the names: 243 | 244 | Yoyodyne, Inc., hereby disclaims all copyright interest in the 245 | program `Gnomovision' (a program to direct compilers to make passes 246 | at assemblers) written by James Hacker. 247 | 248 | , 1 April 1989 249 | Ty Coon, President of Vice 250 | 251 | That's all there is to it! 252 | -------------------------------------------------------------------------------- /Configure: -------------------------------------------------------------------------------- 1 | #!perl 2 | # 3 | # $Id: Configure,v 1.8 1997/03/04 09:22:32 gbarr Exp $ 4 | 5 | use 5.008001; 6 | 7 | use strict; 8 | use warnings; 9 | 10 | use ExtUtils::MakeMaker qw(prompt); 11 | use Getopt::Std; 12 | use IO::File; 13 | 14 | ## no critic (Subroutines::ProhibitSubroutinePrototypes) 15 | 16 | our($opt_d, $opt_o); 17 | 18 | ## 19 | ## 20 | ## 21 | 22 | my %cfg = (); 23 | my @cfg = (); 24 | 25 | my($libnet_cfg,$msg,$ans,$def,$have_old); 26 | 27 | ## 28 | ## 29 | ## 30 | 31 | sub valid_host 32 | { 33 | my $h = shift; 34 | 35 | defined($h) && (($cfg{'test_exist'} == 0) || gethostbyname($h)); 36 | } 37 | 38 | ## 39 | ## 40 | ## 41 | 42 | sub test_hostnames (\@) 43 | { 44 | my $hlist = shift; 45 | my @h = (); 46 | my $err = 0; 47 | 48 | foreach my $host (@$hlist) 49 | { 50 | if(valid_host($host)) 51 | { 52 | push(@h, $host); 53 | next; 54 | } 55 | warn "Bad hostname: '$host'\n"; 56 | $err++; 57 | } 58 | @$hlist = @h; 59 | $err ? join(" ",@h) : undef; 60 | } 61 | 62 | ## 63 | ## 64 | ## 65 | 66 | sub Prompt 67 | { 68 | my($prompt,$def) = @_; 69 | 70 | $def = "" unless defined $def; 71 | 72 | chomp($prompt); 73 | 74 | if($opt_d) 75 | { 76 | print $prompt,," [",$def,"]\n"; 77 | return $def; 78 | } 79 | prompt($prompt,$def); 80 | } 81 | 82 | ## 83 | ## 84 | ## 85 | 86 | sub get_host_list 87 | { 88 | my($prompt,$def) = @_; 89 | 90 | $def = join(" ",@$def) if ref($def); 91 | 92 | my @hosts; 93 | 94 | do 95 | { 96 | my $ans = Prompt($prompt,$def); 97 | 98 | $ans =~ s/(\A\s+|\s+\Z)//g; 99 | 100 | @hosts = split(/\s+/, $ans); 101 | } 102 | while(@hosts && defined($def = test_hostnames(@hosts))); 103 | 104 | \@hosts; 105 | } 106 | 107 | ## 108 | ## 109 | ## 110 | 111 | sub get_hostname 112 | { 113 | my($prompt,$def) = @_; 114 | 115 | my $host; 116 | 117 | while(1) 118 | { 119 | my $ans = Prompt($prompt,$def); 120 | $host = ($ans =~ /(\S*)/)[0]; 121 | last 122 | if(!length($host) || valid_host($host)); 123 | 124 | $def ="" 125 | if $def eq $host; 126 | 127 | print <<"EDQ"; 128 | 129 | *** ERROR: 130 | Hostname `$host' does not seem to exist, please enter again 131 | or a single space to clear any default 132 | 133 | EDQ 134 | } 135 | 136 | length $host 137 | ? $host 138 | : undef; 139 | } 140 | 141 | ## 142 | ## 143 | ## 144 | 145 | sub get_bool ($$) 146 | { 147 | my($prompt,$def) = @_; 148 | 149 | chomp($prompt); 150 | 151 | my $val = Prompt($prompt,$def ? "yes" : "no"); 152 | 153 | $val =~ /^y/i ? 1 : 0; 154 | } 155 | 156 | ## 157 | ## 158 | ## 159 | 160 | sub get_netmask ($$) 161 | { 162 | my($prompt,$def) = @_; 163 | 164 | chomp($prompt); 165 | 166 | my %list; 167 | @list{@$def} = (); 168 | 169 | MASK: 170 | while(1) { 171 | my $bad = 0; 172 | my $ans = Prompt($prompt) or last; 173 | 174 | if($ans eq '*') { 175 | %list = (); 176 | next; 177 | } 178 | 179 | if($ans eq '=') { 180 | print "\n",( %list ? join("\n", sort keys %list) : 'none'),"\n\n"; 181 | next; 182 | } 183 | 184 | unless ($ans =~ m{^\s*(?:(-?\s*)(\d+(?:\.\d+){0,3})/(\d+))}) { 185 | warn "Bad netmask '$ans'\n"; 186 | next; 187 | } 188 | 189 | my($remove,$bits,@ip) = ($1,$3,split(/\./, $2),0,0,0); 190 | if ( $ip[0] < 1 || $bits < 1 || $bits > 32) { 191 | warn "Bad netmask '$ans'\n"; 192 | next MASK; 193 | } 194 | foreach my $byte (@ip) { 195 | if ( $byte > 255 ) { 196 | warn "Bad netmask '$ans'\n"; 197 | next MASK; 198 | } 199 | } 200 | 201 | my $mask = sprintf("%d.%d.%d.%d/%d",@ip[0..3],$bits); 202 | 203 | if ($remove) { 204 | delete $list{$mask}; 205 | } 206 | else { 207 | $list{$mask} = 1; 208 | } 209 | 210 | } 211 | 212 | [ keys %list ]; 213 | } 214 | 215 | ## 216 | ## 217 | ## 218 | 219 | sub default_hostname 220 | { 221 | my @host; 222 | 223 | foreach my $host (@_) 224 | { 225 | if(defined($host) && valid_host($host)) 226 | { 227 | return $host 228 | unless wantarray; 229 | push(@host,$host); 230 | } 231 | } 232 | 233 | return wantarray ? @host : undef; 234 | } 235 | 236 | ## 237 | ## 238 | ## 239 | 240 | getopts('do:'); 241 | 242 | $libnet_cfg = "libnet.cfg" 243 | unless(defined($libnet_cfg = $opt_o)); 244 | 245 | my %oldcfg = (); 246 | 247 | { 248 | no warnings 'once'; 249 | $Net::Config::CONFIGURE = 1; # Suppress load of user overrides 250 | } 251 | if( -f $libnet_cfg ) 252 | { 253 | %oldcfg = ( %{ do $libnet_cfg } ); 254 | } 255 | elsif (eval { require Net::Config }) 256 | { 257 | $have_old = 1; 258 | no warnings 'once'; 259 | %oldcfg = %Net::Config::NetConfig; 260 | } 261 | 262 | map { $cfg{lc $_} = $cfg{$_}; delete $cfg{$_} if /[A-Z]/ } keys %cfg; 263 | 264 | $oldcfg{'test_exist'} = 1 unless exists $oldcfg{'test_exist'}; 265 | $oldcfg{'test_hosts'} = 1 unless exists $oldcfg{'test_hosts'}; 266 | 267 | #--------------------------------------------------------------------------- 268 | 269 | if($have_old && !$opt_d) 270 | { 271 | $msg = <. To accept the 317 | default, hit 318 | 319 | EDQ 320 | 321 | $msg = 'Enter a list of available NNTP hosts :'; 322 | 323 | $def = $oldcfg{'nntp_hosts'} || 324 | [ default_hostname($ENV{NNTPSERVER},$ENV{NEWSHOST},'news') ]; 325 | 326 | $cfg{'nntp_hosts'} = get_host_list($msg,$def); 327 | 328 | #--------------------------------------------------------------------------- 329 | 330 | $msg = 'Enter a list of available SMTP hosts :'; 331 | 332 | $def = $oldcfg{'smtp_hosts'} || 333 | [ default_hostname(split(/:/,$ENV{SMTPHOSTS} || ""), 'mailhost') ]; 334 | 335 | $cfg{'smtp_hosts'} = get_host_list($msg,$def); 336 | 337 | #--------------------------------------------------------------------------- 338 | 339 | $msg = 'Enter a list of available POP3 hosts :'; 340 | 341 | $def = $oldcfg{'pop3_hosts'} || []; 342 | 343 | $cfg{'pop3_hosts'} = get_host_list($msg,$def); 344 | 345 | #--------------------------------------------------------------------------- 346 | 347 | $msg = 'Enter a list of available SNPP hosts :'; 348 | 349 | $def = $oldcfg{'snpp_hosts'} || []; 350 | 351 | $cfg{'snpp_hosts'} = get_host_list($msg,$def); 352 | 353 | #--------------------------------------------------------------------------- 354 | 355 | $msg = 'Enter a list of available PH Hosts :' ; 356 | 357 | $def = $oldcfg{'ph_hosts'} || 358 | [ default_hostname('dirserv') ]; 359 | 360 | $cfg{'ph_hosts'} = get_host_list($msg,$def); 361 | 362 | #--------------------------------------------------------------------------- 363 | 364 | $msg = 'Enter a list of available TIME Hosts :' ; 365 | 366 | $def = $oldcfg{'time_hosts'} || []; 367 | 368 | $cfg{'time_hosts'} = get_host_list($msg,$def); 369 | 370 | #--------------------------------------------------------------------------- 371 | 372 | $msg = 'Enter a list of available DAYTIME Hosts :' ; 373 | 374 | $def = $oldcfg{'daytime_hosts'} || $oldcfg{'time_hosts'}; 375 | 376 | $cfg{'daytime_hosts'} = get_host_list($msg,$def); 377 | 378 | #--------------------------------------------------------------------------- 379 | 380 | $msg = < external user & password 396 | fwuser/fwpass => firewall user & password 397 | 398 | 0) None 399 | 1) ----------------------- 400 | USER user@remote.host 401 | PASS pass 402 | 2) ----------------------- 403 | USER fwuser 404 | PASS fwpass 405 | USER user@remote.host 406 | PASS pass 407 | 3) ----------------------- 408 | USER fwuser 409 | PASS fwpass 410 | SITE remote.site 411 | USER user 412 | PASS pass 413 | 4) ----------------------- 414 | USER fwuser 415 | PASS fwpass 416 | OPEN remote.site 417 | USER user 418 | PASS pass 419 | 5) ----------------------- 420 | USER user@fwuser@remote.site 421 | PASS pass@fwpass 422 | 6) ----------------------- 423 | USER fwuser@remote.site 424 | PASS fwpass 425 | USER user 426 | PASS pass 427 | 7) ----------------------- 428 | USER user@remote.host 429 | PASS pass 430 | AUTH fwuser 431 | RESP fwpass 432 | 433 | Choice: 434 | EDQ 435 | $def = exists $oldcfg{'ftp_firewall_type'} ? $oldcfg{'ftp_firewall_type'} : 1; 436 | $ans = Prompt($msg,$def); 437 | $cfg{'ftp_firewall_type'} = 0+$ans; 438 | $def = $oldcfg{'ftp_firewall'} || $ENV{FTP_FIREWALL}; 439 | 440 | $cfg{'ftp_firewall'} = get_hostname("FTP proxy hostname :", $def); 441 | } 442 | else { 443 | delete $cfg{'ftp_firewall'}; 444 | } 445 | 446 | 447 | #--------------------------------------------------------------------------- 448 | 449 | if (defined $cfg{'ftp_firewall'}) 450 | { 451 | print <new($libnet_cfg, "w") or 572 | die "Cannot create `$libnet_cfg': $!"; 573 | 574 | print "Writing $libnet_cfg\n"; 575 | 576 | print $fh "{\n"; 577 | 578 | foreach my $key (sort keys %cfg) { 579 | my $val = $cfg{$key}; 580 | if(!defined($val)) { 581 | $val = "undef"; 582 | } 583 | elsif(ref($val)) { 584 | $val = '[' . join(",", 585 | map { 586 | my $v = "undef"; 587 | if(defined $_) { 588 | ($v = $_) =~ s/'/\'/sog; 589 | $v = "'" . $v . "'"; 590 | } 591 | $v; 592 | } @$val ) . ']'; 593 | } 594 | else { 595 | $val =~ s/'/\'/sog; 596 | $val = "'" . $val . "'" if $val =~ /\D/; 597 | } 598 | print $fh "\t'",$key,"' => ",$val,",\n"; 599 | } 600 | 601 | print $fh "}\n"; 602 | 603 | $fh->close; 604 | 605 | ############################################################################ 606 | ############################################################################ 607 | 608 | exit 0; 609 | -------------------------------------------------------------------------------- /lib/Net/Cmd.pm: -------------------------------------------------------------------------------- 1 | # Net::Cmd.pm 2 | # 3 | # Copyright (C) 1995-2006 Graham Barr. All rights reserved. 4 | # Copyright (C) 2013-2016, 2020, 2022 Steve Hay. All rights reserved. 5 | # This module is free software; you can redistribute it and/or modify it under 6 | # the same terms as Perl itself, i.e. under the terms of either the GNU General 7 | # Public License or the Artistic License, as specified in the F file. 8 | 9 | package Net::Cmd; 10 | 11 | use 5.008001; 12 | 13 | use strict; 14 | use warnings; 15 | 16 | use Carp; 17 | use Exporter; 18 | use Symbol 'gensym'; 19 | use Errno 'EINTR'; 20 | 21 | BEGIN { 22 | if (ord "A" == 193) { 23 | require Convert::EBCDIC; 24 | 25 | # Convert::EBCDIC->import; 26 | } 27 | } 28 | 29 | our $VERSION = "3.16"; 30 | our @ISA = qw(Exporter); 31 | our @EXPORT = qw(CMD_INFO CMD_OK CMD_MORE CMD_REJECT CMD_ERROR CMD_PENDING); 32 | 33 | use constant CMD_INFO => 1; 34 | use constant CMD_OK => 2; 35 | use constant CMD_MORE => 3; 36 | use constant CMD_REJECT => 4; 37 | use constant CMD_ERROR => 5; 38 | use constant CMD_PENDING => 0; 39 | 40 | use constant DEF_REPLY_CODE => 421; 41 | 42 | my %debug = (); 43 | 44 | my $tr = ord "A" == 193 ? Convert::EBCDIC->new() : undef; 45 | 46 | sub toebcdic { 47 | my $cmd = shift; 48 | 49 | unless (exists ${*$cmd}{'net_cmd_asciipeer'}) { 50 | my $string = $_[0]; 51 | my $ebcdicstr = $tr->toebcdic($string); 52 | ${*$cmd}{'net_cmd_asciipeer'} = $string !~ /^\d+/ && $ebcdicstr =~ /^\d+/; 53 | } 54 | 55 | ${*$cmd}{'net_cmd_asciipeer'} 56 | ? $tr->toebcdic($_[0]) 57 | : $_[0]; 58 | } 59 | 60 | 61 | sub toascii { 62 | my $cmd = shift; 63 | ${*$cmd}{'net_cmd_asciipeer'} 64 | ? $tr->toascii($_[0]) 65 | : $_[0]; 66 | } 67 | 68 | 69 | sub _print_isa { 70 | no strict 'refs'; ## no critic (TestingAndDebugging::ProhibitNoStrict) 71 | 72 | my $pkg = shift; 73 | my $cmd = $pkg; 74 | 75 | $debug{$pkg} ||= 0; 76 | 77 | my %done = (); 78 | my @do = ($pkg); 79 | my %spc = ($pkg, ""); 80 | 81 | while ($pkg = shift @do) { 82 | next if defined $done{$pkg}; 83 | 84 | $done{$pkg} = 1; 85 | 86 | my $v = 87 | defined ${"${pkg}::VERSION"} 88 | ? "(" . ${"${pkg}::VERSION"} . ")" 89 | : ""; 90 | 91 | my $spc = $spc{$pkg}; 92 | $cmd->debug_print(1, "${spc}${pkg}${v}\n"); 93 | 94 | if (@{"${pkg}::ISA"}) { 95 | @spc{@{"${pkg}::ISA"}} = (" " . $spc{$pkg}) x @{"${pkg}::ISA"}; 96 | unshift(@do, @{"${pkg}::ISA"}); 97 | } 98 | } 99 | } 100 | 101 | 102 | sub debug { 103 | @_ == 1 or @_ == 2 or croak 'usage: $obj->debug([$level])'; 104 | 105 | my ($cmd, $level) = @_; 106 | my $pkg = ref($cmd) || $cmd; 107 | my $oldval = 0; 108 | 109 | if (ref($cmd)) { 110 | $oldval = ${*$cmd}{'net_cmd_debug'} || 0; 111 | } 112 | else { 113 | $oldval = $debug{$pkg} || 0; 114 | } 115 | 116 | return $oldval 117 | unless @_ == 2; 118 | 119 | $level = $debug{$pkg} || 0 120 | unless defined $level; 121 | 122 | _print_isa($pkg) 123 | if ($level && !exists $debug{$pkg}); 124 | 125 | if (ref($cmd)) { 126 | ${*$cmd}{'net_cmd_debug'} = $level; 127 | } 128 | else { 129 | $debug{$pkg} = $level; 130 | } 131 | 132 | $oldval; 133 | } 134 | 135 | 136 | sub message { 137 | @_ == 1 or croak 'usage: $obj->message()'; 138 | 139 | my $cmd = shift; 140 | 141 | wantarray 142 | ? @{${*$cmd}{'net_cmd_resp'}} 143 | : join("", @{${*$cmd}{'net_cmd_resp'}}); 144 | } 145 | 146 | 147 | sub debug_text { $_[2] } 148 | 149 | 150 | sub debug_print { 151 | my ($cmd, $out, $text) = @_; 152 | print STDERR $cmd, ($out ? '>>> ' : '<<< '), $cmd->debug_text($out, $text); 153 | } 154 | 155 | 156 | sub code { 157 | @_ == 1 or croak 'usage: $obj->code()'; 158 | 159 | my $cmd = shift; 160 | 161 | ${*$cmd}{'net_cmd_code'} = $cmd->DEF_REPLY_CODE 162 | unless exists ${*$cmd}{'net_cmd_code'}; 163 | 164 | ${*$cmd}{'net_cmd_code'}; 165 | } 166 | 167 | 168 | sub status { 169 | @_ == 1 or croak 'usage: $obj->status()'; 170 | 171 | my $cmd = shift; 172 | 173 | substr(${*$cmd}{'net_cmd_code'}, 0, 1); 174 | } 175 | 176 | 177 | sub set_status { 178 | @_ == 3 or croak 'usage: $obj->set_status($code, $resp)'; 179 | 180 | my $cmd = shift; 181 | my ($code, $resp) = @_; 182 | 183 | $resp = defined $resp ? [$resp] : [] 184 | unless ref($resp); 185 | 186 | (${*$cmd}{'net_cmd_code'}, ${*$cmd}{'net_cmd_resp'}) = ($code, $resp); 187 | 188 | 1; 189 | } 190 | 191 | sub _syswrite_with_timeout { 192 | my $cmd = shift; 193 | my $line = shift; 194 | 195 | my $len = length($line); 196 | my $offset = 0; 197 | my $win = ""; 198 | vec($win, fileno($cmd), 1) = 1; 199 | my $timeout = $cmd->timeout || undef; 200 | my $initial = time; 201 | my $pending = $timeout; 202 | 203 | local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS'; 204 | 205 | while ($len) { 206 | my $wout; 207 | my $nfound = select(undef, $wout = $win, undef, $pending); 208 | if ((defined $nfound and $nfound > 0) or -f $cmd) # -f for testing on win32 209 | { 210 | my $w = syswrite($cmd, $line, $len, $offset); 211 | if (! defined($w) ) { 212 | my $err = $!; 213 | $cmd->close; 214 | $cmd->_set_status_closed($err); 215 | return; 216 | } 217 | $len -= $w; 218 | $offset += $w; 219 | } 220 | elsif ($nfound == -1) { 221 | if ( $! == EINTR ) { 222 | if ( defined($timeout) ) { 223 | redo if ($pending = $timeout - ( time - $initial ) ) > 0; 224 | $cmd->_set_status_timeout; 225 | return; 226 | } 227 | redo; 228 | } 229 | my $err = $!; 230 | $cmd->close; 231 | $cmd->_set_status_closed($err); 232 | return; 233 | } 234 | else { 235 | $cmd->_set_status_timeout; 236 | return; 237 | } 238 | } 239 | 240 | return 1; 241 | } 242 | 243 | sub _set_status_timeout { 244 | my $cmd = shift; 245 | my $pkg = ref($cmd) || $cmd; 246 | 247 | $cmd->set_status($cmd->DEF_REPLY_CODE, "[$pkg] Timeout"); 248 | carp(ref($cmd) . ": " . (caller(1))[3] . "(): timeout") if $cmd->debug; 249 | } 250 | 251 | sub _set_status_closed { 252 | my $cmd = shift; 253 | my $err = shift; 254 | my $pkg = ref($cmd) || $cmd; 255 | 256 | $cmd->set_status($cmd->DEF_REPLY_CODE, "[$pkg] Connection closed"); 257 | carp(ref($cmd) . ": " . (caller(1))[3] 258 | . "(): unexpected EOF on command channel: $err") if $cmd->debug; 259 | } 260 | 261 | sub _is_closed { 262 | my $cmd = shift; 263 | if (!defined fileno($cmd)) { 264 | $cmd->_set_status_closed($!); 265 | return 1; 266 | } 267 | return 0; 268 | } 269 | 270 | sub command { 271 | my $cmd = shift; 272 | 273 | return $cmd 274 | if $cmd->_is_closed; 275 | 276 | $cmd->dataend() 277 | if (exists ${*$cmd}{'net_cmd_last_ch'}); 278 | 279 | if (scalar(@_)) { 280 | my $str = join( 281 | " ", 282 | map { 283 | /\n/ 284 | ? do { my $n = $_; $n =~ tr/\n/ /; $n } 285 | : $_; 286 | } @_ 287 | ); 288 | $str = $cmd->toascii($str) if $tr; 289 | $str .= "\015\012"; 290 | 291 | $cmd->debug_print(1, $str) 292 | if ($cmd->debug); 293 | 294 | # though documented to return undef on failure, the legacy behavior 295 | # was to return $cmd even on failure, so this odd construct does that 296 | $cmd->_syswrite_with_timeout($str) 297 | or return $cmd; 298 | } 299 | 300 | $cmd; 301 | } 302 | 303 | 304 | sub ok { 305 | @_ == 1 or croak 'usage: $obj->ok()'; 306 | 307 | my $code = $_[0]->code; 308 | 0 < $code && $code < 400; 309 | } 310 | 311 | 312 | sub unsupported { 313 | my $cmd = shift; 314 | 315 | $cmd->set_status(580, 'Unsupported command'); 316 | 317 | 0; 318 | } 319 | 320 | 321 | sub getline { 322 | my $cmd = shift; 323 | 324 | ${*$cmd}{'net_cmd_lines'} ||= []; 325 | 326 | return shift @{${*$cmd}{'net_cmd_lines'}} 327 | if scalar(@{${*$cmd}{'net_cmd_lines'}}); 328 | 329 | my $partial = defined(${*$cmd}{'net_cmd_partial'}) ? ${*$cmd}{'net_cmd_partial'} : ""; 330 | 331 | return 332 | if $cmd->_is_closed; 333 | 334 | my $fd = fileno($cmd); 335 | my $rin = ""; 336 | vec($rin, $fd, 1) = 1; 337 | 338 | my $buf; 339 | 340 | until (scalar(@{${*$cmd}{'net_cmd_lines'}})) { 341 | my $timeout = $cmd->timeout || undef; 342 | my $rout; 343 | 344 | my $select_ret = select($rout = $rin, undef, undef, $timeout); 345 | if ($select_ret > 0) { 346 | unless (sysread($cmd, $buf = "", 1024)) { 347 | my $err = $!; 348 | $cmd->close; 349 | $cmd->_set_status_closed($err); 350 | return; 351 | } 352 | 353 | substr($buf, 0, 0) = $partial; ## prepend from last sysread 354 | 355 | my @buf = split(/\015?\012/, $buf, -1); ## break into lines 356 | 357 | $partial = pop @buf; 358 | 359 | push(@{${*$cmd}{'net_cmd_lines'}}, map {"$_\n"} @buf); 360 | 361 | } 362 | else { 363 | $cmd->_set_status_timeout; 364 | return; 365 | } 366 | } 367 | 368 | ${*$cmd}{'net_cmd_partial'} = $partial; 369 | 370 | if ($tr) { 371 | foreach my $ln (@{${*$cmd}{'net_cmd_lines'}}) { 372 | $ln = $cmd->toebcdic($ln); 373 | } 374 | } 375 | 376 | shift @{${*$cmd}{'net_cmd_lines'}}; 377 | } 378 | 379 | 380 | sub ungetline { 381 | my ($cmd, $str) = @_; 382 | 383 | ${*$cmd}{'net_cmd_lines'} ||= []; 384 | unshift(@{${*$cmd}{'net_cmd_lines'}}, $str); 385 | } 386 | 387 | 388 | sub parse_response { 389 | return () 390 | unless $_[1] =~ s/^(\d\d\d)(.?)//o; 391 | ($1, $2 eq "-"); 392 | } 393 | 394 | 395 | sub response { 396 | my $cmd = shift; 397 | my ($code, $more) = (undef) x 2; 398 | 399 | $cmd->set_status($cmd->DEF_REPLY_CODE, undef); # initialize the response 400 | 401 | while (1) { 402 | my $str = $cmd->getline(); 403 | 404 | return CMD_ERROR 405 | unless defined($str); 406 | 407 | $cmd->debug_print(0, $str) 408 | if ($cmd->debug); 409 | 410 | ($code, $more) = $cmd->parse_response($str); 411 | unless (defined $code) { 412 | carp("$cmd: response(): parse error in '$str'") if ($cmd->debug); 413 | $cmd->ungetline($str); 414 | $@ = $str; # $@ used as tunneling hack 415 | return CMD_ERROR; 416 | } 417 | 418 | ${*$cmd}{'net_cmd_code'} = $code; 419 | 420 | push(@{${*$cmd}{'net_cmd_resp'}}, $str); 421 | 422 | last unless ($more); 423 | } 424 | 425 | return unless defined $code; 426 | substr($code, 0, 1); 427 | } 428 | 429 | 430 | sub read_until_dot { 431 | my $cmd = shift; 432 | my $fh = shift; 433 | my $arr = []; 434 | 435 | while (1) { 436 | my $str = $cmd->getline() or return; 437 | 438 | $cmd->debug_print(0, $str) 439 | if ($cmd->debug & 4); 440 | 441 | last if ($str =~ /^\.\r?\n/o); 442 | 443 | $str =~ s/^\.\././o; 444 | 445 | if (defined $fh) { 446 | print $fh $str; 447 | } 448 | else { 449 | push(@$arr, $str); 450 | } 451 | } 452 | 453 | $arr; 454 | } 455 | 456 | 457 | sub datasend { 458 | my $cmd = shift; 459 | my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_; 460 | my $line = join("", @$arr); 461 | 462 | # Perls < 5.10.1 (with the exception of 5.8.9) have a performance problem with 463 | # the substitutions below when dealing with strings stored internally in 464 | # UTF-8, so downgrade them (if possible). 465 | # Data passed to datasend() should be encoded to octets upstream already so 466 | # shouldn't even have the UTF-8 flag on to start with, but if it so happens 467 | # that the octets are stored in an upgraded string (as can sometimes occur) 468 | # then they would still downgrade without fail anyway. 469 | # Only Unicode codepoints > 0xFF stored in an upgraded string will fail to 470 | # downgrade. We fail silently in that case, and a "Wide character in print" 471 | # warning will be emitted later by syswrite(). 472 | utf8::downgrade($line, 1) if $] < 5.010001 && $] != 5.008009; 473 | 474 | return 0 475 | if $cmd->_is_closed; 476 | 477 | my $last_ch = ${*$cmd}{'net_cmd_last_ch'}; 478 | 479 | # We have not send anything yet, so last_ch = "\012" means we are at the start of a line 480 | $last_ch = ${*$cmd}{'net_cmd_last_ch'} = "\012" unless defined $last_ch; 481 | 482 | return 1 unless length $line; 483 | 484 | if ($cmd->debug) { 485 | foreach my $b (split(/\n/, $line)) { 486 | $cmd->debug_print(1, "$b\n"); 487 | } 488 | } 489 | 490 | $line =~ tr/\r\n/\015\012/ unless "\r" eq "\015"; 491 | 492 | my $first_ch = ''; 493 | 494 | if ($last_ch eq "\015") { 495 | # Remove \012 so it does not get prefixed with another \015 below 496 | # and escape the . if there is one following it because the fixup 497 | # below will not find it 498 | $first_ch = "\012" if $line =~ s/^\012(\.?)/$1$1/; 499 | } 500 | elsif ($last_ch eq "\012") { 501 | # Fixup below will not find the . as the first character of the buffer 502 | $first_ch = "." if $line =~ /^\./; 503 | } 504 | 505 | $line =~ s/\015?\012(\.?)/\015\012$1$1/sg; 506 | 507 | substr($line, 0, 0) = $first_ch; 508 | 509 | ${*$cmd}{'net_cmd_last_ch'} = substr($line, -1, 1); 510 | 511 | $cmd->_syswrite_with_timeout($line) 512 | or return; 513 | 514 | 1; 515 | } 516 | 517 | 518 | sub rawdatasend { 519 | my $cmd = shift; 520 | my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_; 521 | my $line = join("", @$arr); 522 | 523 | return 0 524 | if $cmd->_is_closed; 525 | 526 | return 1 527 | unless length($line); 528 | 529 | if ($cmd->debug) { 530 | my $b = "$cmd>>> "; 531 | print STDERR $b, join("\n$b", split(/\n/, $line)), "\n"; 532 | } 533 | 534 | $cmd->_syswrite_with_timeout($line) 535 | or return; 536 | 537 | 1; 538 | } 539 | 540 | 541 | sub dataend { 542 | my $cmd = shift; 543 | 544 | return 0 545 | if $cmd->_is_closed; 546 | 547 | my $ch = ${*$cmd}{'net_cmd_last_ch'}; 548 | my $tosend; 549 | 550 | if (!defined $ch) { 551 | return 1; 552 | } 553 | elsif ($ch ne "\012") { 554 | $tosend = "\015\012"; 555 | } 556 | 557 | $tosend .= ".\015\012"; 558 | 559 | $cmd->debug_print(1, ".\n") 560 | if ($cmd->debug); 561 | 562 | $cmd->_syswrite_with_timeout($tosend) 563 | or return 0; 564 | 565 | delete ${*$cmd}{'net_cmd_last_ch'}; 566 | 567 | $cmd->response() == CMD_OK; 568 | } 569 | 570 | # read and write to tied filehandle 571 | sub tied_fh { 572 | my $cmd = shift; 573 | ${*$cmd}{'net_cmd_readbuf'} = ''; 574 | my $fh = gensym(); 575 | tie *$fh, ref($cmd), $cmd; 576 | return $fh; 577 | } 578 | 579 | # tie to myself 580 | sub TIEHANDLE { 581 | my $class = shift; 582 | my $cmd = shift; 583 | return $cmd; 584 | } 585 | 586 | # Tied filehandle read. Reads requested data length, returning 587 | # end-of-file when the dot is encountered. 588 | sub READ { 589 | my $cmd = shift; 590 | my ($len, $offset) = @_[1, 2]; 591 | return unless exists ${*$cmd}{'net_cmd_readbuf'}; 592 | my $done = 0; 593 | while (!$done and length(${*$cmd}{'net_cmd_readbuf'}) < $len) { 594 | ${*$cmd}{'net_cmd_readbuf'} .= $cmd->getline() or return; 595 | $done++ if ${*$cmd}{'net_cmd_readbuf'} =~ s/^\.\r?\n\Z//m; 596 | } 597 | 598 | $_[0] = ''; 599 | substr($_[0], $offset + 0) = substr(${*$cmd}{'net_cmd_readbuf'}, 0, $len); 600 | substr(${*$cmd}{'net_cmd_readbuf'}, 0, $len) = ''; 601 | delete ${*$cmd}{'net_cmd_readbuf'} if $done; 602 | 603 | return length $_[0]; 604 | } 605 | 606 | 607 | sub READLINE { 608 | my $cmd = shift; 609 | 610 | # in this context, we use the presence of readbuf to 611 | # indicate that we have not yet reached the eof 612 | return unless exists ${*$cmd}{'net_cmd_readbuf'}; 613 | my $line = $cmd->getline; 614 | return if $line =~ /^\.\r?\n/; 615 | $line; 616 | } 617 | 618 | 619 | sub PRINT { 620 | my $cmd = shift; 621 | my ($buf, $len, $offset) = @_; 622 | $len ||= length($buf); 623 | $offset += 0; 624 | return unless $cmd->datasend(substr($buf, $offset, $len)); 625 | ${*$cmd}{'net_cmd_sending'}++; # flag that we should call dataend() 626 | return $len; 627 | } 628 | 629 | 630 | sub CLOSE { 631 | my $cmd = shift; 632 | my $r = exists(${*$cmd}{'net_cmd_sending'}) ? $cmd->dataend : 1; 633 | delete ${*$cmd}{'net_cmd_readbuf'}; 634 | delete ${*$cmd}{'net_cmd_sending'}; 635 | $r; 636 | } 637 | 638 | 1; 639 | 640 | __END__ 641 | 642 | 643 | =head1 NAME 644 | 645 | Net::Cmd - Network Command class (as used by FTP, SMTP etc) 646 | 647 | =head1 SYNOPSIS 648 | 649 | use Net::Cmd; 650 | 651 | @ISA = qw(Net::Cmd); 652 | 653 | =head1 DESCRIPTION 654 | 655 | C is a collection of methods that can be inherited by a sub-class 656 | of C. These methods implement the functionality required for a 657 | command based protocol, for example FTP and SMTP. 658 | 659 | If your sub-class does not also derive from C or similar (e.g. 660 | C, C or C) then you must 661 | provide the following methods by other means yourself: C and 662 | C. 663 | 664 | =head2 Public Methods 665 | 666 | These methods provide a user interface to the C object. 667 | 668 | =over 4 669 | 670 | =item C 671 | 672 | Set the level of debug information for this object. If C<$level> is not given 673 | then the current state is returned. Otherwise the state is changed to 674 | C<$level> and the previous state returned. 675 | 676 | Different packages 677 | may implement different levels of debug but a non-zero value results in 678 | copies of all commands and responses also being sent to STDERR. 679 | 680 | If C<$level> is C then the debug level will be set to the default 681 | debug level for the class. 682 | 683 | This method can also be called as a I method to set/get the default 684 | debug level for a given class. 685 | 686 | =item C 687 | 688 | Returns the text message returned from the last command. In a scalar 689 | context it returns a single string, in a list context it will return 690 | each line as a separate element. (See L below.) 691 | 692 | =item C 693 | 694 | Returns the 3-digit code from the last command. If a command is pending 695 | then the value 0 is returned. (See L below.) 696 | 697 | =item C 698 | 699 | Returns non-zero if the last code value was greater than zero and 700 | less than 400. This holds true for most command servers. Servers 701 | where this does not hold may override this method. 702 | 703 | =item C 704 | 705 | Returns the most significant digit of the current status code. If a command 706 | is pending then C is returned. 707 | 708 | =item C 709 | 710 | Send data to the remote server, converting LF to CRLF. Any line starting 711 | with a '.' will be prefixed with another '.'. 712 | C<$data> may be an array or a reference to an array. 713 | The C<$data> passed in must be encoded by the caller to octets of whatever 714 | encoding is required, e.g. by using the Encode module's C function. 715 | 716 | =item C 717 | 718 | End the sending of data to the remote server. This is done by ensuring that 719 | the data already sent ends with CRLF then sending '.CRLF' to end the 720 | transmission. Once this data has been sent C calls C and 721 | returns true if C returns CMD_OK. 722 | 723 | =back 724 | 725 | =head2 Protected Methods 726 | 727 | These methods are not intended to be called by the user, but used or 728 | over-ridden by a sub-class of C 729 | 730 | =over 4 731 | 732 | =item C 733 | 734 | Print debugging information. C<$dir> denotes the direction I being 735 | data being sent to the server. Calls C before printing to 736 | STDERR. 737 | 738 | =item C 739 | 740 | This method is called to print debugging information. C<$text> is 741 | the text being sent. The method should return the text to be printed. 742 | 743 | This is primarily meant for the use of modules such as FTP where passwords 744 | are sent, but we do not want to display them in the debugging information. 745 | 746 | =item C 747 | 748 | Send a command to the command server. All arguments are first joined with 749 | a space character and CRLF is appended, this string is then sent to the 750 | command server. 751 | 752 | Returns undef upon failure. 753 | 754 | =item C 755 | 756 | Sets the status code to 580 and the response text to 'Unsupported command'. 757 | Returns zero. 758 | 759 | =item C 760 | 761 | Obtain a response from the server. Upon success the most significant digit 762 | of the status code is returned. Upon failure, timeout etc., I is 763 | returned. 764 | 765 | =item C 766 | 767 | This method is called by C as a method with one argument. It should 768 | return an array of 2 values, the 3-digit status code and a flag which is true 769 | when this is part of a multi-line response and this line is not the last. 770 | 771 | =item C 772 | 773 | Retrieve one line, delimited by CRLF, from the remote server. Returns I 774 | upon failure. 775 | 776 | B: If you do use this method for any reason, please remember to add 777 | some C calls into your method. 778 | 779 | =item C 780 | 781 | Unget a line of text from the server. 782 | 783 | =item C 784 | 785 | Send data to the remote server without performing any conversions. C<$data> 786 | is a scalar. 787 | As with C, the C<$data> passed in must be encoded by the caller 788 | to octets of whatever encoding is required, e.g. by using the Encode module's 789 | C function. 790 | 791 | =item C 792 | 793 | Read data from the remote server until a line consisting of a single '.'. 794 | Any lines starting with '..' will have one of the '.'s removed. 795 | 796 | Returns a reference to a list containing the lines, or I upon failure. 797 | 798 | =item C 799 | 800 | Returns a filehandle tied to the Net::Cmd object. After issuing a 801 | command, you may read from this filehandle using read() or <>. The 802 | filehandle will return EOF when the final dot is encountered. 803 | Similarly, you may write to the filehandle in order to send data to 804 | the server after issuing a command that expects data to be written. 805 | 806 | See the Net::POP3 and Net::SMTP modules for examples of this. 807 | 808 | =back 809 | 810 | =head2 Pseudo Responses 811 | 812 | Normally the values returned by C and C are 813 | obtained from the remote server, but in a few circumstances, as 814 | detailed below, C will return values that it sets. You 815 | can alter this behavior by overriding DEF_REPLY_CODE() to specify 816 | a different default reply code, or overriding one of the specific 817 | error handling methods below. 818 | 819 | =over 4 820 | 821 | =item Initial value 822 | 823 | Before any command has executed or if an unexpected error occurs 824 | C will return "421" (temporary connection failure) and 825 | C will return undef. 826 | 827 | =item Connection closed 828 | 829 | If the underlying C is closed, or if there are 830 | any read or write failures, the file handle will be forced closed, 831 | and C will return "421" (temporary connection failure) 832 | and C will return "[$pkg] Connection closed" 833 | (where $pkg is the name of the class that subclassed C). 834 | The _set_status_closed() method can be overridden to set a different 835 | message (by calling set_status()) or otherwise trap this error. 836 | 837 | =item Timeout 838 | 839 | If there is a read or write timeout C will return "421" 840 | (temporary connection failure) and C will return 841 | "[$pkg] Timeout" (where $pkg is the name of the class 842 | that subclassed C). The _set_status_timeout() method 843 | can be overridden to set a different message (by calling set_status()) 844 | or otherwise trap this error. 845 | 846 | =back 847 | 848 | =head1 EXPORTS 849 | 850 | The following symbols are, or can be, exported by this module: 851 | 852 | =over 4 853 | 854 | =item Default Exports 855 | 856 | C, 857 | C, 858 | C, 859 | C, 860 | C, 861 | C. 862 | 863 | (These correspond to possible results of C and C.) 864 | 865 | =item Optional Exports 866 | 867 | I. 868 | 869 | =item Export Tags 870 | 871 | I. 872 | 873 | =back 874 | 875 | =head1 KNOWN BUGS 876 | 877 | See L. 878 | 879 | =head1 AUTHOR 880 | 881 | Graham Barr ELE. 882 | 883 | Steve Hay ELE is now maintaining 884 | libnet as of version 1.22_02. 885 | 886 | =head1 COPYRIGHT 887 | 888 | Copyright (C) 1995-2006 Graham Barr. All rights reserved. 889 | 890 | Copyright (C) 2013-2016, 2020, 2022 Steve Hay. All rights reserved. 891 | 892 | =head1 LICENCE 893 | 894 | This module is free software; you can redistribute it and/or modify it under the 895 | same terms as Perl itself, i.e. under the terms of either the GNU General Public 896 | License or the Artistic License, as specified in the F file. 897 | 898 | =head1 VERSION 899 | 900 | Version 3.16 901 | 902 | =head1 DATE 903 | 904 | TODO 905 | 906 | =head1 HISTORY 907 | 908 | See the F file. 909 | 910 | =cut 911 | --------------------------------------------------------------------------------