dslinux/user/perl/lib/Net Changes.libnet Cmd.pm Config.eg Config.pm Domain.pm FTP.pm Hostname.eg NNTP.pm Netrc.pm POP3.pm Ping.pm README.libnet SMTP.pm Time.pm hostent.pm hostent.t libnetFAQ.pod netent.pm netent.t protoent.pm protoent.t servent.pm servent.t
cayenne
dslinux_cayenne at user.in-berlin.de
Mon Dec 4 18:00:52 CET 2006
Update of /cvsroot/dslinux/dslinux/user/perl/lib/Net
In directory antilope:/tmp/cvs-serv17422/lib/Net
Added Files:
Changes.libnet Cmd.pm Config.eg Config.pm Domain.pm FTP.pm
Hostname.eg NNTP.pm Netrc.pm POP3.pm Ping.pm README.libnet
SMTP.pm Time.pm hostent.pm hostent.t libnetFAQ.pod netent.pm
netent.t protoent.pm protoent.t servent.pm servent.t
Log Message:
Adding fresh perl source to HEAD to branch from
--- NEW FILE: protoent.pm ---
package Net::protoent;
use strict;
use 5.006_001;
our $VERSION = '1.00';
our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
BEGIN {
use Exporter ();
@EXPORT = qw(getprotobyname getprotobynumber getprotoent getproto);
@EXPORT_OK = qw( $p_name @p_aliases $p_proto );
%EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] );
}
use vars @EXPORT_OK;
# Class::Struct forbids use of @ISA
sub import { goto &Exporter::import }
use Class::Struct qw(struct);
struct 'Net::protoent' => [
name => '$',
aliases => '@',
proto => '$',
];
sub populate (@) {
return unless @_;
my $pob = new();
$p_name = $pob->[0] = $_[0];
@p_aliases = @{ $pob->[1] } = split ' ', $_[1];
$p_proto = $pob->[2] = $_[2];
return $pob;
}
sub getprotoent ( ) { populate(CORE::getprotoent()) }
sub getprotobyname ($) { populate(CORE::getprotobyname(shift)) }
sub getprotobynumber ($) { populate(CORE::getprotobynumber(shift)) }
sub getproto ($;$) {
no strict 'refs';
return &{'getprotoby' . ($_[0]=~/^\d+$/ ? 'number' : 'name')}(@_);
}
1;
__END__
=head1 NAME
Net::protoent - by-name interface to Perl's built-in getproto*() functions
=head1 SYNOPSIS
use Net::protoent;
$p = getprotobyname(shift || 'tcp') || die "no proto";
printf "proto for %s is %d, aliases are %s\n",
$p->name, $p->proto, "@{$p->aliases}";
use Net::protoent qw(:FIELDS);
getprotobyname(shift || 'tcp') || die "no proto";
print "proto for $p_name is $p_proto, aliases are @p_aliases\n";
=head1 DESCRIPTION
This module's default exports override the core getprotoent(),
getprotobyname(), and getnetbyport() functions, replacing them with
versions that return "Net::protoent" objects. They take default
second arguments of "tcp". This object has methods that return the
similarly named structure field name from the C's protoent structure
from F<netdb.h>; namely name, aliases, and proto. The aliases method
returns an array reference, the rest scalars.
You may also import all the structure fields directly into your namespace
as regular variables using the :FIELDS import tag. (Note that this still
overrides your core functions.) Access these fields as variables named
with a preceding C<p_>. Thus, C<$proto_obj-E<gt>name()> corresponds to
$p_name if you import the fields. Array references are available as
regular array variables, so for example C<@{ $proto_obj-E<gt>aliases()
}> would be simply @p_aliases.
The getproto() function is a simple front-end that forwards a numeric
argument to getprotobyport(), and the rest to getprotobyname().
To access this functionality without the core overrides,
pass the C<use> an empty import list, and then access
function functions with their full qualified names.
On the other hand, the built-ins are still available
via the C<CORE::> pseudo-package.
=head1 NOTE
While this class is currently implemented using the Class::Struct
module to build a struct-like class, you shouldn't rely upon this.
=head1 AUTHOR
Tom Christiansen
--- NEW FILE: Domain.pm ---
# Net::Domain.pm
#
# Copyright (c) 1995-1998 Graham Barr <gbarr at pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package Net::Domain;
require Exporter;
use Carp;
use strict;
use vars qw($VERSION @ISA @EXPORT_OK);
use Net::Config;
@ISA = qw(Exporter);
@EXPORT_OK = qw(hostname hostdomain hostfqdn domainname);
$VERSION = "2.19"; # $Id: Domain.pm,v 1.1 2006-12-04 17:00:49 dslinux_cayenne Exp $
my($host,$domain,$fqdn) = (undef,undef,undef);
# Try every conceivable way to get hostname.
sub _hostname {
# we already know it
return $host
if(defined $host);
if ($^O eq 'MSWin32') {
require Socket;
my ($name,$alias,$type,$len, at addr) = gethostbyname($ENV{'COMPUTERNAME'}||'localhost');
while (@addr)
{
my $a = shift(@addr);
$host = gethostbyaddr($a,Socket::AF_INET());
last if defined $host;
}
if (defined($host) && index($host,'.') > 0) {
$fqdn = $host;
($host,$domain) = $fqdn =~ /^([^\.]+)\.(.*)$/;
}
return $host;
}
elsif ($^O eq 'MacOS') {
chomp ($host = `hostname`);
}
elsif ($^O eq 'VMS') { ## multiple varieties of net s/w makes this hard
$host = $ENV{'UCX$INET_HOST'} if defined($ENV{'UCX$INET_HOST'});
$host = $ENV{'MULTINET_HOST_NAME'} if defined($ENV{'MULTINET_HOST_NAME'});
if (index($host,'.') > 0) {
$fqdn = $host;
($host,$domain) = $fqdn =~ /^([^\.]+)\.(.*)$/;
}
return $host;
}
else {
local $SIG{'__DIE__'};
# syscall is preferred since it avoids tainting problems
eval {
my $tmp = "\0" x 256; ## preload scalar
eval {
package main;
require "syscall.ph";
defined(&main::SYS_gethostname);
}
|| eval {
package main;
require "sys/syscall.ph";
defined(&main::SYS_gethostname);
}
and $host = (syscall(&main::SYS_gethostname, $tmp, 256) == 0)
? $tmp
: undef;
}
# POSIX
|| eval {
require POSIX;
$host = (POSIX::uname())[1];
}
# trusty old hostname command
|| eval {
chop($host = `(hostname) 2>/dev/null`); # BSD'ish
}
# sysV/POSIX uname command (may truncate)
|| eval {
chop($host = `uname -n 2>/dev/null`); ## SYSV'ish && POSIX'ish
}
# Apollo pre-SR10
|| eval {
$host = (split(/[:\. ]/,`/com/host`,6))[0];
}
|| eval {
$host = "";
};
}
# remove garbage
$host =~ s/[\0\r\n]+//go;
$host =~ s/(\A\.+|\.+\Z)//go;
$host =~ s/\.\.+/\./go;
$host;
}
sub _hostdomain {
# we already know it
return $domain
if(defined $domain);
local $SIG{'__DIE__'};
return $domain = $NetConfig{'inet_domain'}
if defined $NetConfig{'inet_domain'};
# try looking in /etc/resolv.conf
# putting this here and assuming that it is correct, eliminates
# calls to gethostbyname, and therefore DNS lookups. This helps
# those on dialup systems.
local *RES;
local($_);
if(open(RES,"/etc/resolv.conf")) {
while(<RES>) {
$domain = $1
if(/\A\s*(?:domain|search)\s+(\S+)/);
}
close(RES);
return $domain
if(defined $domain);
}
# just try hostname and system calls
my $host = _hostname();
my(@hosts);
@hosts = ($host,"localhost");
unless (defined($host) && $host =~ /\./) {
my $dom = undef;
eval {
my $tmp = "\0" x 256; ## preload scalar
eval {
package main;
require "syscall.ph";
}
|| eval {
package main;
require "sys/syscall.ph";
}
and $dom = (syscall(&main::SYS_getdomainname, $tmp, 256) == 0)
? $tmp
: undef;
};
if ( $^O eq 'VMS' ) {
$dom ||= $ENV{'TCPIP$INET_DOMAIN'}
|| $ENV{'UCX$INET_DOMAIN'};
}
chop($dom = `domainname 2>/dev/null`)
unless(defined $dom || $^O =~ /^(?:cygwin|MSWin32)/);
if(defined $dom) {
my @h = ();
$dom =~ s/^\.+//;
while(length($dom)) {
push(@h, "$host.$dom");
$dom =~ s/^[^.]+.+// or last;
}
unshift(@hosts, at h);
}
}
# Attempt to locate FQDN
foreach (grep {defined $_} @hosts) {
my @info = gethostbyname($_);
next unless @info;
# look at real name & aliases
my $site;
foreach $site ($info[0], split(/ /,$info[1])) {
if(rindex($site,".") > 0) {
# Extract domain from FQDN
($domain = $site) =~ s/\A[^\.]+\.//;
return $domain;
}
}
}
# Look for environment variable
$domain ||= $ENV{LOCALDOMAIN} || $ENV{DOMAIN};
if(defined $domain) {
$domain =~ s/[\r\n\0]+//g;
$domain =~ s/(\A\.+|\.+\Z)//g;
$domain =~ s/\.\.+/\./g;
}
$domain;
}
sub domainname {
return $fqdn
if(defined $fqdn);
_hostname();
_hostdomain();
# Assumption: If the host name does not contain a period
# and the domain name does, then assume that they are correct
# this helps to eliminate calls to gethostbyname, and therefore
# eleminate DNS lookups
return $fqdn = $host . "." . $domain
if(defined $host and defined $domain
and $host !~ /\./ and $domain =~ /\./);
# For hosts that have no name, just an IP address
return $fqdn = $host if defined $host and $host =~ /^\d+(\.\d+){3}$/;
my @host = defined $host ? split(/\./, $host) : ('localhost');
my @domain = defined $domain ? split(/\./, $domain) : ();
my @fqdn = ();
# Determine from @host & @domain the FQDN
my @d = @domain;
LOOP:
while(1) {
my @h = @host;
while(@h) {
my $tmp = join(".", at h, at d);
if((gethostbyname($tmp))[0]) {
@fqdn = (@h, at d);
$fqdn = $tmp;
last LOOP;
}
pop @h;
}
last unless shift @d;
}
if(@fqdn) {
$host = shift @fqdn;
until((gethostbyname($host))[0]) {
$host .= "." . shift @fqdn;
}
$domain = join(".", @fqdn);
}
else {
undef $host;
undef $domain;
undef $fqdn;
}
$fqdn;
}
sub hostfqdn { domainname() }
sub hostname {
domainname()
unless(defined $host);
return $host;
}
sub hostdomain {
domainname()
unless(defined $domain);
return $domain;
}
1; # Keep require happy
__END__
=head1 NAME
Net::Domain - Attempt to evaluate the current host's internet name and domain
=head1 SYNOPSIS
use Net::Domain qw(hostname hostfqdn hostdomain);
=head1 DESCRIPTION
Using various methods B<attempt> to find the Fully Qualified Domain Name (FQDN)
of the current host. From this determine the host-name and the host-domain.
Each of the functions will return I<undef> if the FQDN cannot be determined.
=over 4
=item hostfqdn ()
Identify and return the FQDN of the current host.
=item hostname ()
Returns the smallest part of the FQDN which can be used to identify the host.
=item hostdomain ()
Returns the remainder of the FQDN after the I<hostname> has been removed.
=back
=head1 AUTHOR
Graham Barr <gbarr at pobox.com>.
Adapted from Sys::Hostname by David Sundstrom <sunds at asictest.sc.ti.com>
=head1 COPYRIGHT
Copyright (c) 1995-1998 Graham Barr. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=for html <hr>
I<$Id: Domain.pm,v 1.1 2006-12-04 17:00:49 dslinux_cayenne Exp $>
=cut
--- NEW FILE: NNTP.pm ---
# Net::NNTP.pm
#
# Copyright (c) 1995-1997 Graham Barr <gbarr at pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package Net::NNTP;
use strict;
use vars qw(@ISA $VERSION $debug);
use IO::Socket;
use Net::Cmd;
use Carp;
use Time::Local;
use Net::Config;
$VERSION = "2.23";
@ISA = qw(Net::Cmd IO::Socket::INET);
[...1106 lines suppressed...]
=head1 SEE ALSO
L<Net::Cmd>
=head1 AUTHOR
Graham Barr <gbarr at pobox.com>
=head1 COPYRIGHT
Copyright (c) 1995-1997 Graham Barr. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=for html <hr>
I<$Id: NNTP.pm,v 1.1 2006-12-04 17:00:49 dslinux_cayenne Exp $>
=cut
--- NEW FILE: servent.pm ---
package Net::servent;
use strict;
use 5.006_001;
our $VERSION = '1.01';
our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
BEGIN {
use Exporter ();
@EXPORT = qw(getservbyname getservbyport getservent getserv);
@EXPORT_OK = qw( $s_name @s_aliases $s_port $s_proto );
%EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] );
}
use vars @EXPORT_OK;
# Class::Struct forbids use of @ISA
sub import { goto &Exporter::import }
use Class::Struct qw(struct);
struct 'Net::servent' => [
name => '$',
aliases => '@',
port => '$',
proto => '$',
];
sub populate (@) {
return unless @_;
my $sob = new();
$s_name = $sob->[0] = $_[0];
@s_aliases = @{ $sob->[1] } = split ' ', $_[1];
$s_port = $sob->[2] = $_[2];
$s_proto = $sob->[3] = $_[3];
return $sob;
}
sub getservent ( ) { populate(CORE::getservent()) }
sub getservbyname ($;$) { populate(CORE::getservbyname(shift,shift||'tcp')) }
sub getservbyport ($;$) { populate(CORE::getservbyport(shift,shift||'tcp')) }
sub getserv ($;$) {
no strict 'refs';
return &{'getservby' . ($_[0]=~/^\d+$/ ? 'port' : 'name')}(@_);
}
1;
__END__
=head1 NAME
Net::servent - by-name interface to Perl's built-in getserv*() functions
=head1 SYNOPSIS
use Net::servent;
$s = getservbyname(shift || 'ftp') || die "no service";
printf "port for %s is %s, aliases are %s\n",
$s->name, $s->port, "@{$s->aliases}";
use Net::servent qw(:FIELDS);
getservbyname(shift || 'ftp') || die "no service";
print "port for $s_name is $s_port, aliases are @s_aliases\n";
=head1 DESCRIPTION
This module's default exports override the core getservent(),
getservbyname(), and
getnetbyport() functions, replacing them with versions that return
"Net::servent" objects. They take default second arguments of "tcp". This object has methods that return the similarly
named structure field name from the C's servent structure from F<netdb.h>;
namely name, aliases, port, and proto. The aliases
method returns an array reference, the rest scalars.
You may also import all the structure fields directly into your namespace
as regular variables using the :FIELDS import tag. (Note that this still
overrides your core functions.) Access these fields as variables named
with a preceding C<s_>. Thus, C<$serv_obj-E<gt>name()> corresponds to
$s_name if you import the fields. Array references are available as
regular array variables, so for example C<@{ $serv_obj-E<gt>aliases()}>
would be simply @s_aliases.
The getserv() function is a simple front-end that forwards a numeric
argument to getservbyport(), and the rest to getservbyname().
To access this functionality without the core overrides,
pass the C<use> an empty import list, and then access
function functions with their full qualified names.
On the other hand, the built-ins are still available
via the C<CORE::> pseudo-package.
=head1 EXAMPLES
use Net::servent qw(:FIELDS);
while (@ARGV) {
my ($service, $proto) = ((split m!/!, shift), 'tcp');
my $valet = getserv($service, $proto);
unless ($valet) {
warn "$0: No service: $service/$proto\n"
next;
}
printf "service $service/$proto is port %d\n", $valet->port;
print "alias are @s_aliases\n" if @s_aliases;
}
=head1 NOTE
While this class is currently implemented using the Class::Struct
module to build a struct-like class, you shouldn't rely upon this.
=head1 AUTHOR
Tom Christiansen
--- NEW FILE: Config.pm ---
# Net::Config.pm
#
# Copyright (c) 2000 Graham Barr <gbarr at pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package Net::Config;
require Exporter;
use vars qw(@ISA @EXPORT %NetConfig $VERSION $CONFIGURE $LIBNET_CFG);
use Socket qw(inet_aton inet_ntoa);
use strict;
@EXPORT = qw(%NetConfig);
@ISA = qw(Net::LocalCfg Exporter);
$VERSION = "1.10"; # $Id: Config.pm,v 1.1 2006-12-04 17:00:49 dslinux_cayenne Exp $
eval { local $SIG{__DIE__}; require Net::LocalCfg };
%NetConfig = (
nntp_hosts => [],
snpp_hosts => [],
pop3_hosts => [],
smtp_hosts => [],
ph_hosts => [],
daytime_hosts => [],
time_hosts => [],
inet_domain => undef,
ftp_firewall => undef,
ftp_ext_passive => 0,
ftp_int_passive => 0,
test_hosts => 1,
test_exist => 1,
);
#
# Try to get as much configuration info as possible from InternetConfig
#
$^O eq 'MacOS' and eval <<TRY_INTERNET_CONFIG;
use Mac::InternetConfig;
{
my %nc = (
nntp_hosts => [ \$InternetConfig{ kICNNTPHost() } ],
pop3_hosts => [ \$InternetConfig{ kICMailAccount() } =~ /\@(.*)/ ],
smtp_hosts => [ \$InternetConfig{ kICSMTPHost() } ],
ftp_testhost => \$InternetConfig{ kICFTPHost() } ? \$InternetConfig{ kICFTPHost()} : undef,
ph_hosts => [ \$InternetConfig{ kICPhHost() } ],
ftp_ext_passive => \$InternetConfig{"646F676F\xA5UsePassiveMode"} || 0,
ftp_int_passive => \$InternetConfig{"646F676F\xA5UsePassiveMode"} || 0,
socks_hosts =>
\$InternetConfig{ kICUseSocks() } ? [ \$InternetConfig{ kICSocksHost() } ] : [],
ftp_firewall =>
\$InternetConfig{ kICUseFTPProxy() } ? [ \$InternetConfig{ kICFTPProxyHost() } ] : [],
);
\@NetConfig{keys %nc} = values %nc;
}
TRY_INTERNET_CONFIG
my $file = __FILE__;
my $ref;
$file =~ s/Config.pm/libnet.cfg/;
if ( -f $file ) {
$ref = eval { local $SIG{__DIE__}; do $file };
if (ref($ref) eq 'HASH') {
%NetConfig = (%NetConfig, %{ $ref });
$LIBNET_CFG = $file;
}
}
if ($< == $> and !$CONFIGURE) {
my $home = eval { local $SIG{__DIE__}; (getpwuid($>))[7] } || $ENV{HOME};
$home ||= $ENV{HOMEDRIVE} . ($ENV{HOMEPATH}||'') if defined $ENV{HOMEDRIVE};
if (defined $home) {
$file = $home . "/.libnetrc";
$ref = eval { local $SIG{__DIE__}; do $file } if -f $file;
%NetConfig = (%NetConfig, %{ $ref })
if ref($ref) eq 'HASH';
}
}
my ($k,$v);
while(($k,$v) = each %NetConfig) {
$NetConfig{$k} = [ $v ]
if($k =~ /_hosts$/ and $k ne "test_hosts" and defined($v) and !ref($v));
}
# Take a hostname and determine if it is inside the firewall
sub requires_firewall {
shift; # ignore package
my $host = shift;
return 0 unless defined $NetConfig{'ftp_firewall'};
$host = inet_aton($host) or return -1;
$host = inet_ntoa($host);
if(exists $NetConfig{'local_netmask'}) {
my $quad = unpack("N",pack("C*",split(/\./,$host)));
my $list = $NetConfig{'local_netmask'};
$list = [$list] unless ref($list);
foreach (@$list) {
my($net,$bits) = (m#^(\d+\.\d+\.\d+\.\d+)/(\d+)$#) or next;
my $mask = ~0 << (32 - $bits);
my $addr = unpack("N",pack("C*",split(/\./,$net)));
return 0 if (($addr & $mask) == ($quad & $mask));
}
return 1;
}
return 0;
}
use vars qw(*is_external);
*is_external = \&requires_firewall;
1;
__END__
=head1 NAME
Net::Config - Local configuration data for libnet
=head1 SYNOPSYS
use Net::Config qw(%NetConfig);
=head1 DESCRIPTION
C<Net::Config> holds configuration data for the modules in the libnet
distribuion. During installation you will be asked for these values.
The configuration data is held globally in a file in the perl installation
tree, but a user may override any of these values by providing their own. This
can be done by having a C<.libnetrc> file in their home directory. This file
should return a reference to a HASH containing the keys described below.
For example
# .libnetrc
{
nntp_hosts => [ "my_prefered_host" ],
ph_hosts => [ "my_ph_server" ],
}
__END__
=head1 METHODS
C<Net::Config> defines the following methods. They are methods as they are
invoked as class methods. This is because C<Net::Config> inherits from
C<Net::LocalCfg> so you can override these methods if you want.
=over 4
=item requires_firewall HOST
Attempts to determine if a given host is outside your firewall. Possible
return values are.
-1 Cannot lookup hostname
0 Host is inside firewall (or there is no ftp_firewall entry)
1 Host is outside the firewall
This is done by using hostname lookup and the C<local_netmask> entry in
the configuration data.
=back
=head1 NetConfig VALUES
=over 4
=item nntp_hosts
=item snpp_hosts
=item pop3_hosts
=item smtp_hosts
=item ph_hosts
=item daytime_hosts
=item time_hosts
Each is a reference to an array of hostnames (in order of preference),
which should be used for the given protocol
=item inet_domain
Your internet domain name
=item ftp_firewall
If you have an FTP proxy firewall (B<NOT> an HTTP or SOCKS firewall)
then this value should be set to the firewall hostname. If your firewall
does not listen to port 21, then this value should be set to
C<"hostname:port"> (eg C<"hostname:99">)
=item ftp_firewall_type
There are many different ftp firewall products available. But unfortunately
there is no standard for how to traverse a firewall. The list below shows the
sequence of commands that Net::FTP will use
user Username for remote host
pass Password for remote host
fwuser Username for firewall
fwpass Password for firewall
remote.host The hostname of the remote ftp server
=over 4
=item 0
There is no firewall
=item 1
USER user at remote.host
PASS pass
=item 2
USER fwuser
PASS fwpass
USER user at remote.host
PASS pass
=item 3
USER fwuser
PASS fwpass
SITE remote.site
USER user
PASS pass
=item 4
USER fwuser
PASS fwpass
OPEN remote.site
USER user
PASS pass
=item 5
USER user at fwuser@remote.site
PASS pass at fwpass
=item 6
USER fwuser at remote.site
PASS fwpass
USER user
PASS pass
=item 7
USER user at remote.host
PASS pass
AUTH fwuser
RESP fwpass
=back
=item ftp_ext_passive
=item ftp_int_pasive
FTP servers normally work on a non-passive mode. That is when you want to
transfer data you have to tell the server the address and port to
connect to.
With some firewalls this does not work as the server cannot
connect to your machine (because you are behind a firewall) and the firewall
does not re-write the command. In this case you should set C<ftp_ext_passive>
to a I<true> value.
Some servers are configured to only work in passive mode. If you have
one of these you can force C<Net::FTP> to always transfer in passive
mode; when not going via a firewall, by setting C<ftp_int_passive> to
a I<true> value.
=item local_netmask
A reference to a list of netmask strings in the form C<"134.99.4.0/24">.
These are used by the C<requires_firewall> function to determine if a given
host is inside or outside your firewall.
=back
The following entries are used during installation & testing on the
libnet package
=over 4
=item test_hosts
If true then C<make test> may attempt to connect to hosts given in the
configuration.
=item test_exists
If true then C<Configure> will check each hostname given that it exists
=back
=for html <hr>
I<$Id: Config.pm,v 1.1 2006-12-04 17:00:49 dslinux_cayenne Exp $>
=cut
--- NEW FILE: POP3.pm ---
# Net::POP3.pm
#
# Copyright (c) 1995-2004 Graham Barr <gbarr at pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package Net::POP3;
use strict;
use IO::Socket;
use vars qw(@ISA $VERSION $debug);
use Net::Cmd;
use Carp;
use Net::Config;
$VERSION = "2.28";
@ISA = qw(Net::Cmd IO::Socket::INET);
sub new
{
my $self = shift;
my $type = ref($self) || $self;
my ($host,%arg);
if (@_ % 2) {
$host = shift ;
%arg = @_;
} else {
%arg = @_;
$host=delete $arg{Host};
}
my $hosts = defined $host ? [ $host ] : $NetConfig{pop3_hosts};
my $obj;
my @localport = exists $arg{ResvPort} ? ( LocalPort => $arg{ResvPort} ): ();
my $h;
foreach $h (@{$hosts})
{
$obj = $type->SUPER::new(PeerAddr => ($host = $h),
PeerPort => $arg{Port} || 'pop3(110)',
Proto => 'tcp',
@localport,
Timeout => defined $arg{Timeout}
? $arg{Timeout}
: 120
) and last;
}
return undef
unless defined $obj;
${*$obj}{'net_pop3_host'} = $host;
$obj->autoflush(1);
$obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
unless ($obj->response() == CMD_OK)
{
$obj->close();
return undef;
}
${*$obj}{'net_pop3_banner'} = $obj->message;
$obj;
}
sub host {
my $me = shift;
${*$me}{'net_pop3_host'};
}
##
## We don't want people sending me their passwords when they report problems
## now do we :-)
##
sub debug_text { $_[2] =~ /^(pass|rpop)/i ? "$1 ....\n" : $_[2]; }
sub login
{
@_ >= 1 && @_ <= 3 or croak 'usage: $pop3->login( USER, PASS )';
my($me,$user,$pass) = @_;
if (@_ <= 2) {
($user, $pass) = $me->_lookup_credentials($user);
}
$me->user($user) and
$me->pass($pass);
}
sub apop
{
@_ >= 1 && @_ <= 3 or croak 'usage: $pop3->apop( USER, PASS )';
my($me,$user,$pass) = @_;
my $banner;
my $md;
if (eval { local $SIG{__DIE__}; require Digest::MD5 }) {
$md = Digest::MD5->new();
} elsif (eval { local $SIG{__DIE__}; require MD5 }) {
$md = MD5->new();
} else {
carp "You need to install Digest::MD5 or MD5 to use the APOP command";
return undef;
}
return undef
unless ( $banner = (${*$me}{'net_pop3_banner'} =~ /(<.*>)/)[0] );
if (@_ <= 2) {
($user, $pass) = $me->_lookup_credentials($user);
}
$md->add($banner,$pass);
return undef
unless($me->_APOP($user,$md->hexdigest));
$me->_get_mailbox_count();
}
sub user
{
@_ == 2 or croak 'usage: $pop3->user( USER )';
$_[0]->_USER($_[1]) ? 1 : undef;
}
sub pass
{
@_ == 2 or croak 'usage: $pop3->pass( PASS )';
my($me,$pass) = @_;
return undef
unless($me->_PASS($pass));
$me->_get_mailbox_count();
}
sub reset
{
@_ == 1 or croak 'usage: $obj->reset()';
my $me = shift;
return 0
unless($me->_RSET);
if(defined ${*$me}{'net_pop3_mail'})
{
local $_;
foreach (@{${*$me}{'net_pop3_mail'}})
{
delete $_->{'net_pop3_deleted'};
}
}
}
sub last
{
@_ == 1 or croak 'usage: $obj->last()';
return undef
unless $_[0]->_LAST && $_[0]->message =~ /(\d+)/;
return $1;
}
sub top
{
@_ == 2 || @_ == 3 or croak 'usage: $pop3->top( MSGNUM [, NUMLINES ])';
my $me = shift;
return undef
unless $me->_TOP($_[0], $_[1] || 0);
$me->read_until_dot;
}
sub popstat
{
@_ == 1 or croak 'usage: $pop3->popstat()';
my $me = shift;
return ()
unless $me->_STAT && $me->message =~ /(\d+)\D+(\d+)/;
($1 || 0, $2 || 0);
}
sub list
{
@_ == 1 || @_ == 2 or croak 'usage: $pop3->list( [ MSGNUM ] )';
my $me = shift;
return undef
unless $me->_LIST(@_);
if(@_)
{
$me->message =~ /\d+\D+(\d+)/;
return $1 || undef;
}
my $info = $me->read_until_dot
or return undef;
my %hash = map { (/(\d+)\D+(\d+)/) } @$info;
return \%hash;
}
sub get
{
@_ == 2 or @_ == 3 or croak 'usage: $pop3->get( MSGNUM [, FH ])';
my $me = shift;
return undef
unless $me->_RETR(shift);
$me->read_until_dot(@_);
}
sub getfh
{
@_ == 2 or croak 'usage: $pop3->getfh( MSGNUM )';
my $me = shift;
return unless $me->_RETR(shift);
return $me->tied_fh;
}
sub delete
{
@_ == 2 or croak 'usage: $pop3->delete( MSGNUM )';
my $me = shift;
return 0 unless $me->_DELE(@_);
${*$me}{'net_pop3_deleted'} = 1;
}
sub uidl
{
@_ == 1 || @_ == 2 or croak 'usage: $pop3->uidl( [ MSGNUM ] )';
my $me = shift;
my $uidl;
$me->_UIDL(@_) or
return undef;
if(@_)
{
$uidl = ($me->message =~ /\d+\s+([\041-\176]+)/)[0];
}
else
{
my $ref = $me->read_until_dot
or return undef;
my $ln;
$uidl = {};
foreach $ln (@$ref) {
my($msg,$uid) = $ln =~ /^\s*(\d+)\s+([\041-\176]+)/;
$uidl->{$msg} = $uid;
}
}
return $uidl;
}
sub ping
{
@_ == 2 or croak 'usage: $pop3->ping( USER )';
my $me = shift;
return () unless $me->_PING(@_) && $me->message =~ /(\d+)\D+(\d+)/;
($1 || 0, $2 || 0);
}
sub _lookup_credentials
{
my ($me, $user) = @_;
require Net::Netrc;
$user ||= eval { local $SIG{__DIE__}; (getpwuid($>))[0] } ||
$ENV{NAME} || $ENV{USER} || $ENV{LOGNAME};
my $m = Net::Netrc->lookup(${*$me}{'net_pop3_host'},$user);
$m ||= Net::Netrc->lookup(${*$me}{'net_pop3_host'});
my $pass = $m ? $m->password || ""
: "";
($user, $pass);
}
sub _get_mailbox_count
{
my ($me) = @_;
my $ret = ${*$me}{'net_pop3_count'} = ($me->message =~ /(\d+)\s+message/io)
? $1 : ($me->popstat)[0];
$ret ? $ret : "0E0";
}
sub _STAT { shift->command('STAT')->response() == CMD_OK }
sub _LIST { shift->command('LIST', at _)->response() == CMD_OK }
sub _RETR { shift->command('RETR',$_[0])->response() == CMD_OK }
sub _DELE { shift->command('DELE',$_[0])->response() == CMD_OK }
sub _NOOP { shift->command('NOOP')->response() == CMD_OK }
sub _RSET { shift->command('RSET')->response() == CMD_OK }
sub _QUIT { shift->command('QUIT')->response() == CMD_OK }
sub _TOP { shift->command('TOP', @_)->response() == CMD_OK }
sub _UIDL { shift->command('UIDL', at _)->response() == CMD_OK }
sub _USER { shift->command('USER',$_[0])->response() == CMD_OK }
sub _PASS { shift->command('PASS',$_[0])->response() == CMD_OK }
sub _APOP { shift->command('APOP', at _)->response() == CMD_OK }
sub _PING { shift->command('PING',$_[0])->response() == CMD_OK }
sub _RPOP { shift->command('RPOP',$_[0])->response() == CMD_OK }
sub _LAST { shift->command('LAST')->response() == CMD_OK }
sub _CAPA { shift->command('CAPA')->response() == CMD_OK }
sub quit
{
my $me = shift;
$me->_QUIT;
$me->close;
}
sub DESTROY
{
my $me = shift;
if(defined fileno($me) and ${*$me}{'net_pop3_deleted'})
{
$me->reset;
$me->quit;
}
}
##
## POP3 has weird responses, so we emulate them to look the same :-)
##
sub response {
my $cmd = shift;
my $str = $cmd->getline() or return undef;
my $code = "500";
$cmd->debug_print(0, $str)
if ($cmd->debug);
if ($str =~ s/^\+OK\s*//io) {
$code = "200";
}
elsif ($str =~ s/^\+\s*//io) {
$code = "300";
}
else {
$str =~ s/^-ERR\s*//io;
}
${*$cmd}{'net_cmd_resp'} = [$str];
${*$cmd}{'net_cmd_code'} = $code;
substr($code, 0, 1);
}
sub capa {
my $this = shift;
my ($capa, %capabilities);
# Fake a capability here
$capabilities{APOP} = '' if ($this->banner() =~ /<.*>/);
return \%capabilities unless $this->_CAPA();
$capa = $this->read_until_dot();
%capabilities = map { /^\s*(\S+)\s*(.*)/ } @$capa;
$capabilities{APOP} = '' if ($this->banner() =~ /<.*>/);
return ${*$this}{'net_pop3e_capabilities'} = \%capabilities;
}
sub capabilities {
my $this = shift;
${*$this}{'net_pop3e_capabilities'} || $this->capa;
}
sub auth {
my ($self, $username, $password) = @_;
eval {
require MIME::Base64;
require Authen::SASL;
} or $self->set_status(500,["Need MIME::Base64 and Authen::SASL todo auth"]), return 0;
my $capa = $self->capa;
my $mechanisms = $capa->{SASL} || 'CRAM-MD5';
my $sasl;
if (ref($username) and UNIVERSAL::isa($username,'Authen::SASL')) {
$sasl = $username;
$sasl->mechanism($mechanisms);
}
else {
die "auth(username, password)" if not length $username;
$sasl = Authen::SASL->new(mechanism=> $mechanisms,
callback => { user => $username,
pass => $password,
authname => $username,
});
}
# We should probably allow the user to pass the host, but I don't
# currently know and SASL mechanisms that are used by smtp that need it
my $client = $sasl->client_new('pop3',${*$self}{'net_pop3_host'},0);
my $str = $client->client_start;
# We dont support sasl mechanisms that encrypt the socket traffic.
# todo that we would really need to change the ISA hierarchy
# so we dont inherit from IO::Socket, but instead hold it in an attribute
my @cmd = ("AUTH", $client->mechanism);
my $code;
push @cmd, MIME::Base64::encode_base64($str,'')
if defined $str and length $str;
while (($code = $self->command(@cmd)->response()) == CMD_MORE) {
@cmd = (MIME::Base64::encode_base64(
$client->client_step(
MIME::Base64::decode_base64(
($self->message)[0]
)
), ''
));
}
$code == CMD_OK;
}
sub banner {
my $this = shift;
return ${*$this}{'net_pop3_banner'};
}
1;
__END__
=head1 NAME
Net::POP3 - Post Office Protocol 3 Client class (RFC1939)
=head1 SYNOPSIS
use Net::POP3;
# Constructors
$pop = Net::POP3->new('pop3host');
$pop = Net::POP3->new('pop3host', Timeout => 60);
if ($pop->login($username, $password) > 0) {
my $msgnums = $pop->list; # hashref of msgnum => size
foreach my $msgnum (keys %$msgnums) {
my $msg = $pop->get($msgnum);
print @$msg;
$pop->delete($msgnum);
}
}
$pop->quit;
=head1 DESCRIPTION
This module implements a client interface to the POP3 protocol, enabling
a perl5 application to talk to POP3 servers. This documentation assumes
that you are familiar with the POP3 protocol described in RFC1939.
A new Net::POP3 object must be created with the I<new> method. Once
this has been done, all POP3 commands are accessed via method calls
on the object.
=head1 CONSTRUCTOR
=over 4
=item new ( [ HOST ] [, OPTIONS ] 0
This is the constructor for a new Net::POP3 object. C<HOST> is the
name of the remote host to which an POP3 connection is required.
C<HOST> is optional. If C<HOST> is not given then it may instead be
passed as the C<Host> option described below. If neither is given then
the C<POP3_Hosts> specified in C<Net::Config> will be used.
C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
Possible options are:
B<Host> - POP3 host to connect to. It may be a single scalar, as defined for
the C<PeerAddr> option in L<IO::Socket::INET>, or a reference to
an array with hosts to try in turn. The L</host> method will return the value
which was used to connect to the host.
B<ResvPort> - If given then the socket for the C<Net::POP3> object
will be bound to the local port given using C<bind> when the socket is
created.
B<Timeout> - Maximum time, in seconds, to wait for a response from the
POP3 server (default: 120)
B<Debug> - Enable debugging information
=back
=head1 METHODS
Unless otherwise stated all methods return either a I<true> or I<false>
value, with I<true> meaning that the operation was a success. When a method
states that it returns a value, failure will be returned as I<undef> or an
empty list.
=over 4
=item auth ( USERNAME, PASSWORD )
Attempt SASL authentication.
=item user ( USER )
Send the USER command.
=item pass ( PASS )
Send the PASS command. Returns the number of messages in the mailbox.
=item login ( [ USER [, PASS ]] )
Send both the USER and PASS commands. If C<PASS> is not given the
C<Net::POP3> uses C<Net::Netrc> to lookup the password using the host
and username. If the username is not specified then the current user name
will be used.
Returns the number of messages in the mailbox. However if there are no
messages on the server the string C<"0E0"> will be returned. This is
will give a true value in a boolean context, but zero in a numeric context.
If there was an error authenticating the user then I<undef> will be returned.
=item apop ( [ USER [, PASS ]] )
Authenticate with the server identifying as C<USER> with password C<PASS>.
Similar to L</login>, but the password is not sent in clear text.
To use this method you must have the Digest::MD5 or the MD5 module installed,
otherwise this method will return I<undef>.
=item banner ()
Return the sever's connection banner
=item capa ()
Return a reference to a hash of the capabilties of the server. APOP
is added as a pseudo capability. Note that I've been unable to
find a list of the standard capability values, and some appear to
be multi-word and some are not. We make an attempt at intelligently
parsing them, but it may not be correct.
=item capabilities ()
Just like capa, but only uses a cache from the last time we asked
the server, so as to avoid asking more than once.
=item top ( MSGNUM [, NUMLINES ] )
Get the header and the first C<NUMLINES> of the body for the message
C<MSGNUM>. Returns a reference to an array which contains the lines of text
read from the server.
=item list ( [ MSGNUM ] )
If called with an argument the C<list> returns the size of the message
in octets.
If called without arguments a reference to a hash is returned. The
keys will be the C<MSGNUM>'s of all undeleted messages and the values will
be their size in octets.
=item get ( MSGNUM [, FH ] )
Get the message C<MSGNUM> from the remote mailbox. If C<FH> is not given
then get returns a reference to an array which contains the lines of
text read from the server. If C<FH> is given then the lines returned
from the server are printed to the filehandle C<FH>.
=item getfh ( MSGNUM )
As per get(), but returns a tied filehandle. Reading from this
filehandle returns the requested message. The filehandle will return
EOF at the end of the message and should not be reused.
=item last ()
Returns the highest C<MSGNUM> of all the messages accessed.
=item popstat ()
Returns a list of two elements. These are the number of undeleted
elements and the size of the mbox in octets.
=item ping ( USER )
Returns a list of two elements. These are the number of new messages
and the total number of messages for C<USER>.
=item uidl ( [ MSGNUM ] )
Returns a unique identifier for C<MSGNUM> if given. If C<MSGNUM> is not
given C<uidl> returns a reference to a hash where the keys are the
message numbers and the values are the unique identifiers.
=item delete ( MSGNUM )
Mark message C<MSGNUM> to be deleted from the remote mailbox. All messages
that are marked to be deleted will be removed from the remote mailbox
when the server connection closed.
=item reset ()
Reset the status of the remote POP3 server. This includes reseting the
status of all messages to not be deleted.
=item quit ()
Quit and close the connection to the remote POP3 server. Any messages marked
as deleted will be deleted from the remote mailbox.
=back
=head1 NOTES
If a C<Net::POP3> object goes out of scope before C<quit> method is called
then the C<reset> method will called before the connection is closed. This
means that any messages marked to be deleted will not be.
=head1 SEE ALSO
L<Net::Netrc>,
L<Net::Cmd>
=head1 AUTHOR
Graham Barr <gbarr at pobox.com>
=head1 COPYRIGHT
Copyright (c) 1995-2003 Graham Barr. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
--- NEW FILE: Ping.pm ---
package Net::Ping;
require 5.002;
require Exporter;
use strict;
use vars qw(@ISA @EXPORT $VERSION
$def_timeout $def_proto $def_factor
$max_datasize $pingstring $hires $source_verify $syn_forking);
use Fcntl qw( F_GETFL F_SETFL O_NONBLOCK );
use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW PF_INET SOL_SOCKET SO_ERROR
inet_aton inet_ntoa sockaddr_in );
use POSIX qw( ENOTCONN ECONNREFUSED ECONNRESET EINPROGRESS EWOULDBLOCK EAGAIN WNOHANG );
use FileHandle;
use Carp;
@ISA = qw(Exporter);
@EXPORT = qw(pingecho);
$VERSION = "2.31";
[...1705 lines suppressed...]
Original pingecho():
karrer at bernina.ethz.ch (Andreas Karrer)
pmarquess at bfsec.bt.co.uk (Paul Marquess)
Original Net::Ping author:
mose at ns.ccsn.edu (Russell Mosemann)
=head1 COPYRIGHT
Copyright (c) 2002-2003, Rob Brown. All rights reserved.
Copyright (c) 2001, Colin McMillen. All rights reserved.
This program is free software; you may redistribute it and/or
modify it under the same terms as Perl itself.
$Id: Ping.pm,v 1.2 2006-12-04 17:00:49 dslinux_cayenne Exp $
=cut
--- NEW FILE: libnetFAQ.pod ---
=head1 NAME
libnetFAQ - libnet Frequently Asked Questions
=head1 DESCRIPTION
=head2 Where to get this document
This document is distributed with the libnet distribution, and is also
available on the libnet web page at
http://search.cpan.org/~gbarr/libnet/
=head2 How to contribute to this document
You may mail corrections, additions, and suggestions to me
gbarr at pobox.com.
=head1 Author and Copyright Information
Copyright (c) 1997-1998 Graham Barr. All rights reserved.
This document is free; you can redistribute it and/or modify it
under the terms of the Artistic License.
=head2 Disclaimer
This information is offered in good faith and in the hope that it may
be of use, but is not guaranteed to be correct, up to date, or suitable
for any particular purpose whatsoever. The authors accept no liability
in respect of this information or its use.
=head1 Obtaining and installing libnet
=head2 What is libnet ?
libnet is a collection of perl5 modules which all related to network
programming. The majority of the modules available provided the
client side of popular server-client protocols that are used in
the internet community.
=head2 Which version of perl do I need ?
libnet has been know to work with versions of perl from 5.002 onwards. However
if your release of perl is prior to perl5.004 then you will need to
obtain and install the IO distribution from CPAN. If you have perl5.004
or later then you will have the IO modules in your installation already,
but CPAN may contain updates.
=head2 What other modules do I need ?
The only modules you will need installed are the modules from the IO
distribution. If you have perl5.004 or later you will already have
these modules.
=head2 What machines support libnet ?
libnet itself is an entirely perl-code distribution so it should work
on any machine that perl runs on. However IO may not work
with some machines and earlier releases of perl. But this
should not be the case with perl version 5.004 or later.
=head2 Where can I get the latest libnet release
The latest libnet release is always on CPAN, you will find it
in
http://www.cpan.org/modules/by-module/Net/
The latest release and information is also available on the libnet web page
at
http://search.cpan.org/~gbarr/libnet/
=head1 Using Net::FTP
=head2 How do I download files from an FTP server ?
An example taken from an article posted to comp.lang.perl.misc
#!/your/path/to/perl
# a module making life easier
use Net::FTP;
# for debuging: $ftp = Net::FTP->new('site','Debug',10);
# open a connection and log in!
$ftp = Net::FTP->new('target_site.somewhere.xxx');
$ftp->login('username','password');
# set transfer mode to binary
$ftp->binary();
# change the directory on the ftp site
$ftp->cwd('/some/path/to/somewhere/');
foreach $name ('file1', 'file2', 'file3') {
# get's arguments are in the following order:
# ftp server's filename
# filename to save the transfer to on the local machine
# can be simply used as get($name) if you want the same name
$ftp->get($name,$name);
}
# ftp done!
$ftp->quit;
=head2 How do I transfer files in binary mode ?
To transfer files without <LF><CR> translation Net::FTP provides
the C<binary> method
$ftp->binary;
=head2 How can I get the size of a file on a remote FTP server ?
=head2 How can I get the modification time of a file on a remote FTP server ?
=head2 How can I change the permissions of a file on a remote server ?
The FTP protocol does not have a command for changing the permissions
of a file on the remote server. But some ftp servers may allow a chmod
command to be issued via a SITE command, eg
$ftp->quot('site chmod 0777',$filename);
But this is not guaranteed to work.
=head2 Can I do a reget operation like the ftp command ?
=head2 How do I get a directory listing from an FTP server ?
=head2 Changing directory to "" does not fail ?
Passing an argument of "" to ->cwd() has the same affect of calling ->cwd()
without any arguments. Turn on Debug (I<See below>) and you will see what is
happening
$ftp = Net::FTP->new($host, Debug => 1);
$ftp->login;
$ftp->cwd("");
gives
Net::FTP=GLOB(0x82196d8)>>> CWD /
Net::FTP=GLOB(0x82196d8)<<< 250 CWD command successful.
=head2 I am behind a SOCKS firewall, but the Firewall option does not work ?
The Firewall option is only for support of one type of firewall. The type
supported is an ftp proxy.
To use Net::FTP, or any other module in the libnet distribution,
through a SOCKS firewall you must create a socks-ified perl executable
by compiling perl with the socks library.
=head2 I am behind an FTP proxy firewall, but cannot access machines outside ?
Net::FTP implements the most popular ftp proxy firewall approach. The scheme
implemented is that where you log in to the firewall with C<user at hostname>
I have heard of one other type of firewall which requires a login to the
firewall with an account, then a second login with C<user at hostname>. You can
still use Net::FTP to traverse these firewalls, but a more manual approach
must be taken, eg
$ftp = Net::FTP->new($firewall) or die $@;
$ftp->login($firewall_user, $firewall_passwd) or die $ftp->message;
$ftp->login($ext_user . '@' . $ext_host, $ext_passwd) or die $ftp->message.
=head2 My ftp proxy firewall does not listen on port 21
FTP servers usually listen on the same port number, port 21, as any other
FTP server. But there is no reason why this has to be the case.
If you pass a port number to Net::FTP then it assumes this is the port
number of the final destination. By default Net::FTP will always try
to connect to the firewall on port 21.
Net::FTP uses IO::Socket to open the connection and IO::Socket allows
the port number to be specified as part of the hostname. So this problem
can be resolved by either passing a Firewall option like C<"hostname:1234">
or by setting the C<ftp_firewall> option in Net::Config to be a string
in in the same form.
=head2 Is it possible to change the file permissions of a file on an FTP server ?
The answer to this is "maybe". The FTP protocol does not specify a command to change
file permissions on a remote host. However many servers do allow you to run the
chmod command via the C<SITE> command. This can be done with
$ftp->site('chmod','0775',$file);
=head2 I have seen scripts call a method message, but cannot find it documented ?
Net::FTP, like several other packages in libnet, inherits from Net::Cmd, so
all the methods described in Net::Cmd are also available on Net::FTP
objects.
=head2 Why does Net::FTP not implement mput and mget methods
The quick answer is because they are easy to implement yourself. The long
answer is that to write these in such a way that multiple platforms are
supported correctly would just require too much code. Below are
some examples how you can implement these yourself.
sub mput {
my($ftp,$pattern) = @_;
foreach my $file (glob($pattern)) {
$ftp->put($file) or warn $ftp->message;
}
}
sub mget {
my($ftp,$pattern) = @_;
foreach my $file ($ftp->ls($pattern)) {
$ftp->get($file) or warn $ftp->message;
}
}
=head1 Using Net::SMTP
=head2 Why can't the part of an Email address after the @ be used as the hostname ?
The part of an Email address which follows the @ is not necessarily a hostname,
it is a mail domain. To find the name of a host to connect for a mail domain
you need to do a DNS MX lookup
=head2 Why does Net::SMTP not do DNS MX lookups ?
Net::SMTP implements the SMTP protocol. The DNS MX lookup is not part
of this protocol.
=head2 The verify method always returns true ?
Well it may seem that way, but it does not. The verify method returns true
if the command succeeded. If you pass verify an address which the
server would normally have to forward to another machine, the command
will succeed with something like
252 Couldn't verify <someone at there> but will attempt delivery anyway
This command will fail only if you pass it an address in a domain
the server directly delivers for, and that address does not exist.
=head1 Debugging scripts
=head2 How can I debug my scripts that use Net::* modules ?
Most of the libnet client classes allow options to be passed to the
constructor, in most cases one option is called C<Debug>. Passing
this option with a non-zero value will turn on a protocol trace, which
will be sent to STDERR. This trace can be useful to see what commands
are being sent to the remote server and what responses are being
received back.
#!/your/path/to/perl
use Net::FTP;
my $ftp = new Net::FTP($host, Debug => 1);
$ftp->login('gbarr','password');
$ftp->quit;
this script would output something like
Net::FTP: Net::FTP(2.22)
Net::FTP: Exporter
Net::FTP: Net::Cmd(2.0801)
Net::FTP: IO::Socket::INET
Net::FTP: IO::Socket(1.1603)
Net::FTP: IO::Handle(1.1504)
Net::FTP=GLOB(0x8152974)<<< 220 imagine FTP server (Version wu-2.4(5) Tue Jul 29 11:17:18 CDT 1997) ready.
Net::FTP=GLOB(0x8152974)>>> user gbarr
Net::FTP=GLOB(0x8152974)<<< 331 Password required for gbarr.
Net::FTP=GLOB(0x8152974)>>> PASS ....
Net::FTP=GLOB(0x8152974)<<< 230 User gbarr logged in. Access restrictions apply.
Net::FTP=GLOB(0x8152974)>>> QUIT
Net::FTP=GLOB(0x8152974)<<< 221 Goodbye.
The first few lines tell you the modules that Net::FTP uses and their versions,
this is useful data to me when a user reports a bug. The last seven lines
show the communication with the server. Each line has three parts. The first
part is the object itself, this is useful for separating the output
if you are using multiple objects. The second part is either C<<<<<> to
show data coming from the server or C<>>>>> to show data
going to the server. The remainder of the line is the command
being sent or response being received.
=head1 AUTHOR AND COPYRIGHT
Copyright (c) 1997 Graham Barr.
All rights reserved.
=for html <hr>
I<$Id: libnetFAQ.pod,v 1.1 2006-12-04 17:00:50 dslinux_cayenne Exp $>
--- NEW FILE: SMTP.pm ---
# Net::SMTP.pm
#
# Copyright (c) 1995-2004 Graham Barr <gbarr at pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package Net::SMTP;
require 5.001;
use strict;
use vars qw($VERSION @ISA);
use Socket 1.3;
use Carp;
use IO::Socket;
use Net::Cmd;
use Net::Config;
$VERSION = "2.29";
@ISA = qw(Net::Cmd IO::Socket::INET);
sub new
{
my $self = shift;
my $type = ref($self) || $self;
my ($host,%arg);
if (@_ % 2) {
$host = shift ;
%arg = @_;
} else {
%arg = @_;
$host=delete $arg{Host};
}
my $hosts = defined $host ? $host : $NetConfig{smtp_hosts};
my $obj;
my $h;
foreach $h (@{ref($hosts) ? $hosts : [ $hosts ]})
{
$obj = $type->SUPER::new(PeerAddr => ($host = $h),
PeerPort => $arg{Port} || 'smtp(25)',
LocalAddr => $arg{LocalAddr},
LocalPort => $arg{LocalPort},
Proto => 'tcp',
Timeout => defined $arg{Timeout}
? $arg{Timeout}
: 120
) and last;
}
return undef
unless defined $obj;
$obj->autoflush(1);
$obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
unless ($obj->response() == CMD_OK)
{
$obj->close();
return undef;
}
${*$obj}{'net_smtp_exact_addr'} = $arg{ExactAddresses};
${*$obj}{'net_smtp_host'} = $host;
(${*$obj}{'net_smtp_banner'}) = $obj->message;
(${*$obj}{'net_smtp_domain'}) = $obj->message =~ /\A\s*(\S+)/;
unless($obj->hello($arg{Hello} || ""))
{
$obj->close();
return undef;
}
$obj;
}
sub host {
my $me = shift;
${*$me}{'net_smtp_host'};
}
##
## User interface methods
##
sub banner
{
my $me = shift;
return ${*$me}{'net_smtp_banner'} || undef;
}
sub domain
{
my $me = shift;
return ${*$me}{'net_smtp_domain'} || undef;
}
sub etrn {
my $self = shift;
defined($self->supports('ETRN',500,["Command unknown: 'ETRN'"])) &&
$self->_ETRN(@_);
}
sub auth {
my ($self, $username, $password) = @_;
eval {
require MIME::Base64;
require Authen::SASL;
} or $self->set_status(500,["Need MIME::Base64 and Authen::SASL todo auth"]), return 0;
my $mechanisms = $self->supports('AUTH',500,["Command unknown: 'AUTH'"]);
return unless defined $mechanisms;
my $sasl;
if (ref($username) and UNIVERSAL::isa($username,'Authen::SASL')) {
$sasl = $username;
$sasl->mechanism($mechanisms);
}
else {
die "auth(username, password)" if not length $username;
$sasl = Authen::SASL->new(mechanism=> $mechanisms,
callback => { user => $username,
pass => $password,
authname => $username,
});
}
# We should probably allow the user to pass the host, but I don't
# currently know and SASL mechanisms that are used by smtp that need it
my $client = $sasl->client_new('smtp',${*$self}{'net_smtp_host'},0);
my $str = $client->client_start;
# We dont support sasl mechanisms that encrypt the socket traffic.
# todo that we would really need to change the ISA hierarchy
# so we dont inherit from IO::Socket, but instead hold it in an attribute
my @cmd = ("AUTH", $client->mechanism);
my $code;
push @cmd, MIME::Base64::encode_base64($str,'')
if defined $str and length $str;
while (($code = $self->command(@cmd)->response()) == CMD_MORE) {
@cmd = (MIME::Base64::encode_base64(
$client->client_step(
MIME::Base64::decode_base64(
($self->message)[0]
)
), ''
));
}
$code == CMD_OK;
}
sub hello
{
my $me = shift;
my $domain = shift || "localhost.localdomain";
my $ok = $me->_EHLO($domain);
my @msg = $me->message;
if($ok)
{
my $h = ${*$me}{'net_smtp_esmtp'} = {};
my $ln;
foreach $ln (@msg) {
$h->{uc $1} = $2
if $ln =~ /(\w+)\b[= \t]*([^\n]*)/;
}
}
elsif($me->status == CMD_ERROR)
{
@msg = $me->message
if $ok = $me->_HELO($domain);
}
return undef unless $ok;
$msg[0] =~ /\A\s*(\S+)/;
return ($1 || " ");
}
sub supports {
my $self = shift;
my $cmd = uc shift;
return ${*$self}{'net_smtp_esmtp'}->{$cmd}
if exists ${*$self}{'net_smtp_esmtp'}->{$cmd};
$self->set_status(@_)
if @_;
return;
}
sub _addr {
my $self = shift;
my $addr = shift;
$addr = "" unless defined $addr;
if (${*$self}{'net_smtp_exact_addr'}) {
return $1 if $addr =~ /^\s*(<.*>)\s*$/s;
}
else {
return $1 if $addr =~ /(<[^>]*>)/;
$addr =~ s/^\s+|\s+$//sg;
}
"<$addr>";
}
sub mail
{
my $me = shift;
my $addr = _addr($me, shift);
my $opts = "";
if(@_)
{
my %opt = @_;
my($k,$v);
if(exists ${*$me}{'net_smtp_esmtp'})
{
my $esmtp = ${*$me}{'net_smtp_esmtp'};
if(defined($v = delete $opt{Size}))
{
if(exists $esmtp->{SIZE})
{
$opts .= sprintf " SIZE=%d", $v + 0
}
else
{
carp 'Net::SMTP::mail: SIZE option not supported by host';
}
}
if(defined($v = delete $opt{Return}))
{
if(exists $esmtp->{DSN})
{
$opts .= " RET=" . ((uc($v) eq "FULL") ? "FULL" : "HDRS");
}
else
{
carp 'Net::SMTP::mail: DSN option not supported by host';
}
}
if(defined($v = delete $opt{Bits}))
{
if($v eq "8")
{
if(exists $esmtp->{'8BITMIME'})
{
$opts .= " BODY=8BITMIME";
}
else
{
carp 'Net::SMTP::mail: 8BITMIME option not supported by host';
}
}
elsif($v eq "binary")
{
if(exists $esmtp->{'BINARYMIME'} && exists $esmtp->{'CHUNKING'})
{
$opts .= " BODY=BINARYMIME";
${*$me}{'net_smtp_chunking'} = 1;
}
else
{
carp 'Net::SMTP::mail: BINARYMIME option not supported by host';
}
}
elsif(exists $esmtp->{'8BITMIME'} or exists $esmtp->{'BINARYMIME'})
{
$opts .= " BODY=7BIT";
}
else
{
carp 'Net::SMTP::mail: 8BITMIME and BINARYMIME options not supported by host';
}
}
if(defined($v = delete $opt{Transaction}))
{
if(exists $esmtp->{CHECKPOINT})
{
$opts .= " TRANSID=" . _addr($me, $v);
}
else
{
carp 'Net::SMTP::mail: CHECKPOINT option not supported by host';
}
}
if(defined($v = delete $opt{Envelope}))
{
if(exists $esmtp->{DSN})
{
$v =~ s/([^\041-\176]|=|\+)/sprintf "+%02x", ord($1)/sge;
$opts .= " ENVID=$v"
}
else
{
carp 'Net::SMTP::mail: DSN option not supported by host';
}
}
if(defined($v = delete $opt{XVERP}))
{
if(exists $esmtp->{'XVERP'})
{
$opts .= " XVERP"
}
else
{
carp 'Net::SMTP::mail: XVERP option not supported by host';
}
}
carp 'Net::SMTP::recipient: unknown option(s) '
. join(" ", keys %opt)
. ' - ignored'
if scalar keys %opt;
}
else
{
carp 'Net::SMTP::mail: ESMTP not supported by host - options discarded :-(';
}
}
$me->_MAIL("FROM:".$addr.$opts);
}
sub send { my $me = shift; $me->_SEND("FROM:" . _addr($me, $_[0])) }
sub send_or_mail { my $me = shift; $me->_SOML("FROM:" . _addr($me, $_[0])) }
sub send_and_mail { my $me = shift; $me->_SAML("FROM:" . _addr($me, $_[0])) }
sub reset
{
my $me = shift;
$me->dataend()
if(exists ${*$me}{'net_smtp_lastch'});
$me->_RSET();
}
sub recipient
{
my $smtp = shift;
my $opts = "";
my $skip_bad = 0;
if(@_ && ref($_[-1]))
{
my %opt = %{pop(@_)};
my $v;
$skip_bad = delete $opt{'SkipBad'};
if(exists ${*$smtp}{'net_smtp_esmtp'})
{
my $esmtp = ${*$smtp}{'net_smtp_esmtp'};
if(defined($v = delete $opt{Notify}))
{
if(exists $esmtp->{DSN})
{
$opts .= " NOTIFY=" . join(",",map { uc $_ } @$v)
}
else
{
carp 'Net::SMTP::recipient: DSN option not supported by host';
}
}
carp 'Net::SMTP::recipient: unknown option(s) '
. join(" ", keys %opt)
. ' - ignored'
if scalar keys %opt;
}
elsif(%opt)
{
carp 'Net::SMTP::recipient: ESMTP not supported by host - options discarded :-(';
}
}
my @ok;
my $addr;
foreach $addr (@_)
{
if($smtp->_RCPT("TO:" . _addr($smtp, $addr) . $opts)) {
push(@ok,$addr) if $skip_bad;
}
elsif(!$skip_bad) {
return 0;
}
}
return $skip_bad ? @ok : 1;
}
BEGIN {
*to = \&recipient;
*cc = \&recipient;
*bcc = \&recipient;
}
sub data
{
my $me = shift;
if(exists ${*$me}{'net_smtp_chunking'})
{
carp 'Net::SMTP::data: CHUNKING extension in use, must call bdat instead';
}
else
{
my $ok = $me->_DATA() && $me->datasend(@_);
$ok && @_ ? $me->dataend
: $ok;
}
}
sub bdat
{
my $me = shift;
if(exists ${*$me}{'net_smtp_chunking'})
{
my $data = shift;
$me->_BDAT(length $data) && $me->rawdatasend($data) &&
$me->response() == CMD_OK;
}
else
{
carp 'Net::SMTP::bdat: CHUNKING extension is not in use, call data instead';
}
}
sub bdatlast
{
my $me = shift;
if(exists ${*$me}{'net_smtp_chunking'})
{
my $data = shift;
$me->_BDAT(length $data, "LAST") && $me->rawdatasend($data) &&
$me->response() == CMD_OK;
}
else
{
carp 'Net::SMTP::bdat: CHUNKING extension is not in use, call data instead';
}
}
sub datafh {
my $me = shift;
return unless $me->_DATA();
return $me->tied_fh;
}
sub expand
{
my $me = shift;
$me->_EXPN(@_) ? ($me->message)
: ();
}
sub verify { shift->_VRFY(@_) }
sub help
{
my $me = shift;
$me->_HELP(@_) ? scalar $me->message
: undef;
}
sub quit
{
my $me = shift;
$me->_QUIT;
$me->close;
}
sub DESTROY
{
# ignore
}
##
## RFC821 commands
##
sub _EHLO { shift->command("EHLO", @_)->response() == CMD_OK }
sub _HELO { shift->command("HELO", @_)->response() == CMD_OK }
sub _MAIL { shift->command("MAIL", @_)->response() == CMD_OK }
sub _RCPT { shift->command("RCPT", @_)->response() == CMD_OK }
sub _SEND { shift->command("SEND", @_)->response() == CMD_OK }
sub _SAML { shift->command("SAML", @_)->response() == CMD_OK }
sub _SOML { shift->command("SOML", @_)->response() == CMD_OK }
sub _VRFY { shift->command("VRFY", @_)->response() == CMD_OK }
sub _EXPN { shift->command("EXPN", @_)->response() == CMD_OK }
sub _HELP { shift->command("HELP", @_)->response() == CMD_OK }
sub _RSET { shift->command("RSET")->response() == CMD_OK }
sub _NOOP { shift->command("NOOP")->response() == CMD_OK }
sub _QUIT { shift->command("QUIT")->response() == CMD_OK }
sub _DATA { shift->command("DATA")->response() == CMD_MORE }
sub _BDAT { shift->command("BDAT", @_) }
sub _TURN { shift->unsupported(@_); }
sub _ETRN { shift->command("ETRN", @_)->response() == CMD_OK }
sub _AUTH { shift->command("AUTH", @_)->response() == CMD_OK }
1;
__END__
=head1 NAME
Net::SMTP - Simple Mail Transfer Protocol Client
=head1 SYNOPSIS
use Net::SMTP;
# Constructors
$smtp = Net::SMTP->new('mailhost');
$smtp = Net::SMTP->new('mailhost', Timeout => 60);
=head1 DESCRIPTION
This module implements a client interface to the SMTP and ESMTP
protocol, enabling a perl5 application to talk to SMTP servers. This
documentation assumes that you are familiar with the concepts of the
SMTP protocol described in RFC821.
A new Net::SMTP object must be created with the I<new> method. Once
this has been done, all SMTP commands are accessed through this object.
The Net::SMTP class is a subclass of Net::Cmd and IO::Socket::INET.
=head1 EXAMPLES
This example prints the mail domain name of the SMTP server known as mailhost:
#!/usr/local/bin/perl -w
use Net::SMTP;
$smtp = Net::SMTP->new('mailhost');
print $smtp->domain,"\n";
$smtp->quit;
This example sends a small message to the postmaster at the SMTP server
known as mailhost:
#!/usr/local/bin/perl -w
use Net::SMTP;
$smtp = Net::SMTP->new('mailhost');
$smtp->mail($ENV{USER});
$smtp->to('postmaster');
$smtp->data();
$smtp->datasend("To: postmaster\n");
$smtp->datasend("\n");
$smtp->datasend("A simple test message\n");
$smtp->dataend();
$smtp->quit;
=head1 CONSTRUCTOR
=over 4
=item new ( [ HOST ] [, OPTIONS ] )
This is the constructor for a new Net::SMTP object. C<HOST> is the
name of the remote host to which an SMTP connection is required.
C<HOST> is optional. If C<HOST> is not given then it may instead be
passed as the C<Host> option described below. If neither is given then
the C<SMTP_Hosts> specified in C<Net::Config> will be used.
C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
Possible options are:
B<Hello> - SMTP requires that you identify yourself. This option
specifies a string to pass as your mail domain. If not given localhost.localdomain
will be used.
B<Host> - SMTP host to connect to. It may be a single scalar, as defined for
the C<PeerAddr> option in L<IO::Socket::INET>, or a reference to
an array with hosts to try in turn. The L</host> method will return the value
which was used to connect to the host.
B<LocalAddr> and B<LocalPort> - These parameters are passed directly
to IO::Socket to allow binding the socket to a local port.
B<Timeout> - Maximum time, in seconds, to wait for a response from the
SMTP server (default: 120)
B<ExactAddresses> - If true the all ADDRESS arguments must be as
defined by C<addr-spec> in RFC2822. If not given, or false, then
Net::SMTP will attempt to extract the address from the value passed.
B<Debug> - Enable debugging information
Example:
$smtp = Net::SMTP->new('mailhost',
Hello => 'my.mail.domain'
Timeout => 30,
Debug => 1,
);
# the same
$smtp = Net::SMTP->new(
Host => 'mailhost',
Hello => 'my.mail.domain'
Timeout => 30,
Debug => 1,
);
# Connect to the default server from Net::config
$smtp = Net::SMTP->new(
Hello => 'my.mail.domain'
Timeout => 30,
);
=back
=head1 METHODS
Unless otherwise stated all methods return either a I<true> or I<false>
value, with I<true> meaning that the operation was a success. When a method
states that it returns a value, failure will be returned as I<undef> or an
empty list.
=over 4
=item banner ()
Returns the banner message which the server replied with when the
initial connection was made.
=item domain ()
Returns the domain that the remote SMTP server identified itself as during
connection.
=item hello ( DOMAIN )
Tell the remote server the mail domain which you are in using the EHLO
command (or HELO if EHLO fails). Since this method is invoked
automatically when the Net::SMTP object is constructed the user should
normally not have to call it manually.
=item host ()
Returns the value used by the constructor, and passed to IO::Socket::INET,
to connect to the host.
=item etrn ( DOMAIN )
Request a queue run for the DOMAIN given.
=item auth ( USERNAME, PASSWORD )
Attempt SASL authentication.
=item mail ( ADDRESS [, OPTIONS] )
=item send ( ADDRESS )
=item send_or_mail ( ADDRESS )
=item send_and_mail ( ADDRESS )
Send the appropriate command to the server MAIL, SEND, SOML or SAML. C<ADDRESS>
is the address of the sender. This initiates the sending of a message. The
method C<recipient> should be called for each address that the message is to
be sent to.
The C<mail> method can some additional ESMTP OPTIONS which is passed
in hash like fashion, using key and value pairs. Possible options are:
Size => <bytes>
Return => "FULL" | "HDRS"
Bits => "7" | "8" | "binary"
Transaction => <ADDRESS>
Envelope => <ENVID>
XVERP => 1
The C<Return> and C<Envelope> parameters are used for DSN (Delivery
Status Notification).
=item reset ()
Reset the status of the server. This may be called after a message has been
initiated, but before any data has been sent, to cancel the sending of the
message.
=item recipient ( ADDRESS [, ADDRESS, [...]] [, OPTIONS ] )
Notify the server that the current message should be sent to all of the
addresses given. Each address is sent as a separate command to the server.
Should the sending of any address result in a failure then the process is
aborted and a I<false> value is returned. It is up to the user to call
C<reset> if they so desire.
The C<recipient> method can also pass additional case-sensitive OPTIONS as an
anonymous hash using key and value pairs. Possible options are:
Notify => ['NEVER'] or ['SUCCESS','FAILURE','DELAY'] (see below)
SkipBad => 1 (to ignore bad addresses)
If C<SkipBad> is true the C<recipient> will not return an error when a bad
address is encountered and it will return an array of addresses that did
succeed.
$smtp->recipient($recipient1,$recipient2); # Good
$smtp->recipient($recipient1,$recipient2, { SkipBad => 1 }); # Good
$smtp->recipient($recipient1,$recipient2, { Notify => ['FAILURE','DELAY'], SkipBad => 1 }); # Good
@goodrecips=$smtp->recipient(@recipients, { Notify => ['FAILURE'], SkipBad => 1 }); # Good
$smtp->recipient("$recipient,$recipient2"); # BAD
Notify is used to request Delivery Status Notifications (DSNs), but your
SMTP/ESMTP service may not respect this request depending upon its version and
your site's SMTP configuration.
Leaving out the Notify option usually defaults an SMTP service to its default
behavior equivalent to ['FAILURE'] notifications only, but again this may be
dependent upon your site's SMTP configuration.
The NEVER keyword must appear by itself if used within the Notify option and "requests
that a DSN not be returned to the sender under any conditions."
{Notify => ['NEVER']}
$smtp->recipient(@recipients, { Notify => ['NEVER'], SkipBad => 1 }); # Good
You may use any combination of these three values 'SUCCESS','FAILURE','DELAY' in
the anonymous array reference as defined by RFC3461 (see http://rfc.net/rfc3461.html
for more information. Note: quotations in this topic from same.).
A Notify parameter of 'SUCCESS' or 'FAILURE' "requests that a DSN be issued on
successful delivery or delivery failure, respectively."
A Notify parameter of 'DELAY' "indicates the sender's willingness to receive
delayed DSNs. Delayed DSNs may be issued if delivery of a message has been
delayed for an unusual amount of time (as determined by the Message Transfer
Agent (MTA) at which the message is delayed), but the final delivery status
(whether successful or failure) cannot be determined. The absence of the DELAY
keyword in a NOTIFY parameter requests that a "delayed" DSN NOT be issued under
any conditions."
{Notify => ['SUCCESS','FAILURE','DELAY']}
$smtp->recipient(@recipients, { Notify => ['FAILURE','DELAY'], SkipBad => 1 }); # Good
=item to ( ADDRESS [, ADDRESS [...]] )
=item cc ( ADDRESS [, ADDRESS [...]] )
=item bcc ( ADDRESS [, ADDRESS [...]] )
Synonyms for C<recipient>.
=item data ( [ DATA ] )
Initiate the sending of the data from the current message.
C<DATA> may be a reference to a list or a list. If specified the contents
of C<DATA> and a termination string C<".\r\n"> is sent to the server. And the
result will be true if the data was accepted.
If C<DATA> is not specified then the result will indicate that the server
wishes the data to be sent. The data must then be sent using the C<datasend>
and C<dataend> methods described in L<Net::Cmd>.
=item expand ( ADDRESS )
Request the server to expand the given address Returns an array
which contains the text read from the server.
=item verify ( ADDRESS )
Verify that C<ADDRESS> is a legitimate mailing address.
Most sites usually disable this feature in their SMTP service configuration.
Use "Debug => 1" option under new() to see if disabled.
=item help ( [ $subject ] )
Request help text from the server. Returns the text or undef upon failure
=item quit ()
Send the QUIT command to the remote SMTP server and close the socket connection.
=back
=head1 ADDRESSES
Net::SMTP attempts to DWIM with addresses that are passed. For
example an application might extract The From: line from an email
and pass that to mail(). While this may work, it is not reccomended.
The application should really use a module like L<Mail::Address>
to extract the mail address and pass that.
If C<ExactAddresses> is passed to the contructor, then addresses
should be a valid rfc2821-quoted address, although Net::SMTP will
accept accept the address surrounded by angle brackets.
funny user at domain WRONG
"funny user"@domain RIGHT, recommended
<"funny user"@domain> OK
=head1 SEE ALSO
L<Net::Cmd>
=head1 AUTHOR
Graham Barr <gbarr at pobox.com>
=head1 COPYRIGHT
Copyright (c) 1995-2004 Graham Barr. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
--- NEW FILE: servent.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
BEGIN {
our $hasse;
eval { my @n = getservbyname "echo", "tcp" };
$hasse = 1 unless $@ && $@ =~ /unimplemented|unsupported/i;
unless ($hasse) { print "1..0 # Skip: no getservbyname\n"; exit 0 }
use Config;
$hasse = 0 unless $Config{'i_netdb'} eq 'define';
unless ($hasse) { print "1..0 # Skip: no netdb.h\n"; exit 0 }
}
BEGIN {
our @servent = getservbyname "echo", "tcp"; # This is the function getservbyname.
unless (@servent) { print "1..0 # Skip: no echo service\n"; exit 0 }
}
print "1..3\n";
use Net::servent;
print "ok 1\n";
my $servent = getservbyname "echo", "tcp"; # This is the OO getservbyname.
print "not " unless $servent->name eq $servent[0];
print "ok 2\n";
print "not " unless $servent->port == $servent[2];
print "ok 3\n";
# Testing pretty much anything else is unportable.
--- NEW FILE: FTP.pm ---
# Net::FTP.pm
#
# Copyright (c) 1995-2004 Graham Barr <gbarr at pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# Documentation (at end) improved 1996 by Nathan Torkington <gnat at frii.com>.
package Net::FTP;
require 5.001;
use strict;
use vars qw(@ISA $VERSION);
use Carp;
use Socket 1.3;
use IO::Socket;
use Time::Local;
[...1751 lines suppressed...]
the FTP protocol in a non-interactive manner.
=back
=head1 CREDITS
Henry Gabryjelski <henryg at WPI.EDU> - for the suggestion of creating directories
recursively.
Nathan Torkington <gnat at frii.com> - for some input on the documentation.
Roderick Schertler <roderick at gate.net> - for various inputs
=head1 COPYRIGHT
Copyright (c) 1995-2004 Graham Barr. All rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut
--- NEW FILE: README.libnet ---
libnet is a collection of Perl modules which provides a simple
and consistent programming interface (API) to the client side
of various protocols used in the internet community.
For details of each protocol please refer to the RFC. RFC's
can be found a various places on the WEB, for a starting
point look at:
http://www.yahoo.com/Computers_and_Internet/Standards/RFCs/
The RFC implemented in this distribution are
Net::FTP RFC959 File Transfer Protocol
Net::SMTP RFC821 Simple Mail Transfer Protocol
Net::Time RFC867 Daytime Protocol
Net::Time RFC868 Time Protocol
Net::NNTP RFC977 Network News Transfer Protocol
Net::POP3 RFC1939 Post Office Protocol 3
AVAILABILITY
The latest version of libnet is available from the Comprehensive Perl
Archive Network (CPAN). To find a CPAN site near you see:
http://search.cpan.org/~gbarr/libnet/
The subversion source repository can be browsed at
http://svn.mutatus.co.uk/browse/libnet/
If you have a subversion client, then you can checkout the latest code with
svn co http://svn.mutatus.co.uk/repos/libnet/trunk libnet
INSTALLATION
In order to use this package you will need Perl version 5.002 or
better. You install libnet, as you would install any perl module
library, by running these commands:
perl Makefile.PL
make
make test
make install
If you want to install a private copy of libnet in your home
directory, then you should try to produce the initial Makefile with
something like this command:
perl Makefile.PL PREFIX=~/perl
The Makefile.PL program will start out by checking your perl
installation for a few packages that are recommended to be installed
together with libnet. These packages should be available on CPAN
(described above).
CONFIGURE
Normally when perl Makefile.PL is run it will run Configure which will
ask some questions about your system. The results of these questions
will be stored in a file called libnet.cfg which will be installed
alongside the other perl modules in this distribution. The Makefile.PL
will run Configure in an interactive mode unless these exists a file
called libnet.cfg in the build directory.
If you are on a system which cannot run this script you can create an
empty file to make Makefile.PL skip running Configure. If you want to
keep your existing settings and not run interactivly the simple run
Configure -d
before running the Makefile.PL.
DOCUMENTATION
See ChangeLog for recent changes. POD style documentation is included
in all modules and scripts. These are normally converted to manual
pages and installed as part of the "make install" process. You should
also be able to use the 'perldoc' utility to extract documentation from
the module files directly.
DEMOS
The demos directory does contain a few demo scripts. These should be
run from the top directory like
demos/smtp.self -user my-email-address -debug
However I do not guarantee these scripts to work.
SUPPORT
Questions about how to use this library should be directed to the
comp.lang.perl.modules USENET Newsgroup. Bug reports and suggestions
for improvements can be sent to me at <gbarr at pobox.com>.
Most of the modules in this library have an option to output a debug
transcript to STDERR. When reporting bugs/problems please, if possible,
include a transcript of a run.
COPYRIGHT
© 1996-2004 Graham Barr. All rights reserved.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
Share and Enjoy!
--- NEW FILE: protoent.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
BEGIN {
our $haspe;
eval { my @n = getprotobyname "tcp" };
$haspe = 1 unless $@ && $@ =~ /unimplemented|unsupported/i;
unless ($haspe) { print "1..0 # Skip: no getprotobyname\n"; exit 0 }
use Config;
$haspe = 0 unless $Config{'i_netdb'} eq 'define';
unless ($haspe) { print "1..0 # Skip: no netdb.h\n"; exit 0 }
}
BEGIN {
our @protoent = getprotobyname "tcp"; # This is the function getprotobyname.
unless (@protoent) { print "1..0 # Skip: no tcp protocol\n"; exit 0 }
}
print "1..3\n";
use Net::protoent;
print "ok 1\n";
my $protoent = getprotobyname "tcp"; # This is the OO getprotobyname.
print "not " unless $protoent->name eq $protoent[0];
print "ok 2\n";
print "not " unless $protoent->proto == $protoent[2];
print "ok 3\n";
# Testing pretty much anything else is unportable.
--- NEW FILE: Time.pm ---
# Net::Time.pm
#
# Copyright (c) 1995-2004 Graham Barr <gbarr at pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package Net::Time;
use strict;
use vars qw($VERSION @ISA @EXPORT_OK $TIMEOUT);
use Carp;
use IO::Socket;
require Exporter;
use Net::Config;
use IO::Select;
@ISA = qw(Exporter);
@EXPORT_OK = qw(inet_time inet_daytime);
$VERSION = "2.10";
$TIMEOUT = 120;
sub _socket
{
my($pname,$pnum,$host,$proto,$timeout) = @_;
$proto ||= 'udp';
my $port = (getservbyname($pname, $proto))[2] || $pnum;
my $hosts = defined $host ? [ $host ] : $NetConfig{$pname . '_hosts'};
my $me;
foreach $host (@$hosts)
{
$me = IO::Socket::INET->new(PeerAddr => $host,
PeerPort => $port,
Proto => $proto
) and last;
}
return unless $me;
$me->send("\n")
if $proto eq 'udp';
$timeout = $TIMEOUT
unless defined $timeout;
IO::Select->new($me)->can_read($timeout)
? $me
: undef;
}
sub inet_time
{
my $s = _socket('time',37, at _) || return undef;
my $buf = '';
my $offset = 0 | 0;
return undef
unless defined $s->recv($buf, length(pack("N",0)));
# unpack, we | 0 to ensure we have an unsigned
my $time = (unpack("N",$buf))[0] | 0;
# the time protocol return time in seconds since 1900, convert
# it to a the required format
if($^O eq "MacOS") {
# MacOS return seconds since 1904, 1900 was not a leap year.
$offset = (4 * 31536000) | 0;
}
else {
# otherwise return seconds since 1972, there were 17 leap years between
# 1900 and 1972
$offset = (70 * 31536000 + 17 * 86400) | 0;
}
$time - $offset;
}
sub inet_daytime
{
my $s = _socket('daytime',13, at _) || return undef;
my $buf = '';
defined($s->recv($buf, 1024)) ? $buf
: undef;
}
1;
__END__
=head1 NAME
Net::Time - time and daytime network client interface
=head1 SYNOPSIS
use Net::Time qw(inet_time inet_daytime);
print inet_time(); # use default host from Net::Config
print inet_time('localhost');
print inet_time('localhost', 'tcp');
print inet_daytime(); # use default host from Net::Config
print inet_daytime('localhost');
print inet_daytime('localhost', 'tcp');
=head1 DESCRIPTION
C<Net::Time> provides subroutines that obtain the time on a remote machine.
=over 4
=item inet_time ( [HOST [, PROTOCOL [, TIMEOUT]]])
Obtain the time on C<HOST>, or some default host if C<HOST> is not given
or not defined, using the protocol as defined in RFC868. The optional
argument C<PROTOCOL> should define the protocol to use, either C<tcp> or
C<udp>. The result will be a time value in the same units as returned
by time() or I<undef> upon failure.
=item inet_daytime ( [HOST [, PROTOCOL [, TIMEOUT]]])
Obtain the time on C<HOST>, or some default host if C<HOST> is not given
or not defined, using the protocol as defined in RFC867. The optional
argument C<PROTOCOL> should define the protocol to use, either C<tcp> or
C<udp>. The result will be an ASCII string or I<undef> upon failure.
=back
=head1 AUTHOR
Graham Barr <gbarr at pobox.com>
=head1 COPYRIGHT
Copyright (c) 1995-2004 Graham Barr. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
--- NEW FILE: netent.pm ---
package Net::netent;
use strict;
use 5.006_001;
our $VERSION = '1.00';
our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
BEGIN {
use Exporter ();
@EXPORT = qw(getnetbyname getnetbyaddr getnet);
@EXPORT_OK = qw(
$n_name @n_aliases
$n_addrtype $n_net
);
%EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] );
}
use vars @EXPORT_OK;
# Class::Struct forbids use of @ISA
sub import { goto &Exporter::import }
use Class::Struct qw(struct);
struct 'Net::netent' => [
name => '$',
aliases => '@',
addrtype => '$',
net => '$',
];
sub populate (@) {
return unless @_;
my $nob = new();
$n_name = $nob->[0] = $_[0];
@n_aliases = @{ $nob->[1] } = split ' ', $_[1];
$n_addrtype = $nob->[2] = $_[2];
$n_net = $nob->[3] = $_[3];
return $nob;
}
sub getnetbyname ($) { populate(CORE::getnetbyname(shift)) }
sub getnetbyaddr ($;$) {
my ($net, $addrtype);
$net = shift;
require Socket if @_;
$addrtype = @_ ? shift : Socket::AF_INET();
populate(CORE::getnetbyaddr($net, $addrtype))
}
sub getnet($) {
if ($_[0] =~ /^\d+(?:\.\d+(?:\.\d+(?:\.\d+)?)?)?$/) {
require Socket;
&getnetbyaddr(Socket::inet_aton(shift));
} else {
&getnetbyname;
}
}
1;
__END__
=head1 NAME
Net::netent - by-name interface to Perl's built-in getnet*() functions
=head1 SYNOPSIS
use Net::netent qw(:FIELDS);
getnetbyname("loopback") or die "bad net";
printf "%s is %08X\n", $n_name, $n_net;
use Net::netent;
$n = getnetbyname("loopback") or die "bad net";
{ # there's gotta be a better way, eh?
@bytes = unpack("C4", pack("N", $n->net));
shift @bytes while @bytes && $bytes[0] == 0;
}
printf "%s is %08X [%d.%d.%d.%d]\n", $n->name, $n->net, @bytes;
=head1 DESCRIPTION
This module's default exports override the core getnetbyname() and
getnetbyaddr() functions, replacing them with versions that return
"Net::netent" objects. This object has methods that return the similarly
named structure field name from the C's netent structure from F<netdb.h>;
namely name, aliases, addrtype, and net. The aliases
method returns an array reference, the rest scalars.
You may also import all the structure fields directly into your namespace
as regular variables using the :FIELDS import tag. (Note that this still
overrides your core functions.) Access these fields as variables named
with a preceding C<n_>. Thus, C<$net_obj-E<gt>name()> corresponds to
$n_name if you import the fields. Array references are available as
regular array variables, so for example C<@{ $net_obj-E<gt>aliases()
}> would be simply @n_aliases.
The getnet() function is a simple front-end that forwards a numeric
argument to getnetbyaddr(), and the rest
to getnetbyname().
To access this functionality without the core overrides,
pass the C<use> an empty import list, and then access
function functions with their full qualified names.
On the other hand, the built-ins are still available
via the C<CORE::> pseudo-package.
=head1 EXAMPLES
The getnet() functions do this in the Perl core:
sv_setiv(sv, (I32)nent->n_net);
The gethost() functions do this in the Perl core:
sv_setpvn(sv, hent->h_addr, len);
That means that the address comes back in binary for the
host functions, and as a regular perl integer for the net ones.
This seems a bug, but here's how to deal with it:
use strict;
use Socket;
use Net::netent;
@ARGV = ('loopback') unless @ARGV;
my($n, $net);
for $net ( @ARGV ) {
unless ($n = getnetbyname($net)) {
warn "$0: no such net: $net\n";
next;
}
printf "\n%s is %s%s\n",
$net,
lc($n->name) eq lc($net) ? "" : "*really* ",
$n->name;
print "\taliases are ", join(", ", @{$n->aliases}), "\n"
if @{$n->aliases};
# this is stupid; first, why is this not in binary?
# second, why am i going through these convolutions
# to make it looks right
{
my @a = unpack("C4", pack("N", $n->net));
shift @a while @a && $a[0] == 0;
printf "\taddr is %s [%d.%d.%d.%d]\n", $n->net, @a;
}
if ($n = getnetbyaddr($n->net)) {
if (lc($n->name) ne lc($net)) {
printf "\tThat addr reverses to net %s!\n", $n->name;
$net = $n->name;
redo;
}
}
}
=head1 NOTE
While this class is currently implemented using the Class::Struct
module to build a struct-like class, you shouldn't rely upon this.
=head1 AUTHOR
Tom Christiansen
--- NEW FILE: Netrc.pm ---
# Net::Netrc.pm
#
# Copyright (c) 1995-1998 Graham Barr <gbarr at pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package Net::Netrc;
use Carp;
use strict;
use FileHandle;
use vars qw($VERSION);
$VERSION = "2.12"; # $Id: Netrc.pm,v 1.1 2006-12-04 17:00:49 dslinux_cayenne Exp $
my %netrc = ();
sub _readrc
{
my $host = shift;
my($home,$file);
if($^O eq "MacOS") {
$home = $ENV{HOME} || `pwd`;
chomp($home);
$file = ($home =~ /:$/ ? $home . "netrc" : $home . ":netrc");
} else {
# Some OS's don't have `getpwuid', so we default to $ENV{HOME}
$home = eval { (getpwuid($>))[7] } || $ENV{HOME};
$home ||= $ENV{HOMEDRIVE} . ($ENV{HOMEPATH}||'') if defined $ENV{HOMEDRIVE};
$file = $home . "/.netrc";
}
my($login,$pass,$acct) = (undef,undef,undef);
my $fh;
local $_;
$netrc{default} = undef;
# OS/2 and Win32 do not handle stat in a way compatable with this check :-(
unless($^O eq 'os2'
|| $^O eq 'MSWin32'
|| $^O eq 'MacOS'
|| $^O =~ /^cygwin/)
{
my @stat = stat($file);
if(@stat)
{
if($stat[2] & 077)
{
carp "Bad permissions: $file";
return;
}
if($stat[4] != $<)
{
carp "Not owner: $file";
return;
}
}
}
if($fh = FileHandle->new($file,"r"))
{
my($mach,$macdef,$tok, at tok) = (0,0);
while(<$fh>)
{
undef $macdef if /\A\n\Z/;
if($macdef)
{
push(@$macdef,$_);
next;
}
s/^\s*//;
chomp;
while(length && s/^("((?:[^"]+|\\.)*)"|((?:[^\\\s]+|\\.)*))\s*//) {
(my $tok = $+) =~ s/\\(.)/$1/g;
push(@tok, $tok);
}
TOKEN:
while(@tok)
{
if($tok[0] eq "default")
{
shift(@tok);
$mach = bless {};
$netrc{default} = [$mach];
next TOKEN;
}
last TOKEN
unless @tok > 1;
$tok = shift(@tok);
if($tok eq "machine")
{
my $host = shift @tok;
$mach = bless {machine => $host};
$netrc{$host} = []
unless exists($netrc{$host});
push(@{$netrc{$host}}, $mach);
}
elsif($tok =~ /^(login|password|account)$/)
{
next TOKEN unless $mach;
my $value = shift @tok;
# Following line added by rmerrell to remove '/' escape char in .netrc
$value =~ s/\/\\/\\/g;
$mach->{$1} = $value;
}
elsif($tok eq "macdef")
{
next TOKEN unless $mach;
my $value = shift @tok;
$mach->{macdef} = {}
unless exists $mach->{macdef};
$macdef = $mach->{machdef}{$value} = [];
}
}
}
$fh->close();
}
}
sub lookup
{
my($pkg,$mach,$login) = @_;
_readrc()
unless exists $netrc{default};
$mach ||= 'default';
undef $login
if $mach eq 'default';
if(exists $netrc{$mach})
{
if(defined $login)
{
my $m;
foreach $m (@{$netrc{$mach}})
{
return $m
if(exists $m->{login} && $m->{login} eq $login);
}
return undef;
}
return $netrc{$mach}->[0]
}
return $netrc{default}->[0]
if defined $netrc{default};
return undef;
}
sub login
{
my $me = shift;
exists $me->{login}
? $me->{login}
: undef;
}
sub account
{
my $me = shift;
exists $me->{account}
? $me->{account}
: undef;
}
sub password
{
my $me = shift;
exists $me->{password}
? $me->{password}
: undef;
}
sub lpa
{
my $me = shift;
($me->login, $me->password, $me->account);
}
1;
__END__
=head1 NAME
Net::Netrc - OO interface to users netrc file
=head1 SYNOPSIS
use Net::Netrc;
$mach = Net::Netrc->lookup('some.machine');
$login = $mach->login;
($login, $password, $account) = $mach->lpa;
=head1 DESCRIPTION
C<Net::Netrc> is a class implementing a simple interface to the .netrc file
used as by the ftp program.
C<Net::Netrc> also implements security checks just like the ftp program,
these checks are, first that the .netrc file must be owned by the user and
second the ownership permissions should be such that only the owner has
read and write access. If these conditions are not met then a warning is
output and the .netrc file is not read.
=head1 THE .netrc FILE
The .netrc file contains login and initialization information used by the
auto-login process. It resides in the user's home directory. The following
tokens are recognized; they may be separated by spaces, tabs, or new-lines:
=over 4
=item machine name
Identify a remote machine name. The auto-login process searches
the .netrc file for a machine token that matches the remote machine
specified. Once a match is made, the subsequent .netrc tokens
are processed, stopping when the end of file is reached or an-
other machine or a default token is encountered.
=item default
This is the same as machine name except that default matches
any name. There can be only one default token, and it must be
after all machine tokens. This is normally used as:
default login anonymous password user at site
thereby giving the user automatic anonymous login to machines
not specified in .netrc.
=item login name
Identify a user on the remote machine. If this token is present,
the auto-login process will initiate a login using the
specified name.
=item password string
Supply a password. If this token is present, the auto-login
process will supply the specified string if the remote server
requires a password as part of the login process.
=item account string
Supply an additional account password. If this token is present,
the auto-login process will supply the specified string
if the remote server requires an additional account password.
=item macdef name
Define a macro. C<Net::Netrc> only parses this field to be compatible
with I<ftp>.
=back
=head1 CONSTRUCTOR
The constructor for a C<Net::Netrc> object is not called new as it does not
really create a new object. But instead is called C<lookup> as this is
essentially what it does.
=over 4
=item lookup ( MACHINE [, LOGIN ])
Lookup and return a reference to the entry for C<MACHINE>. If C<LOGIN> is given
then the entry returned will have the given login. If C<LOGIN> is not given then
the first entry in the .netrc file for C<MACHINE> will be returned.
If a matching entry cannot be found, and a default entry exists, then a
reference to the default entry is returned.
If there is no matching entry found and there is no default defined, or
no .netrc file is found, then C<undef> is returned.
=back
=head1 METHODS
=over 4
=item login ()
Return the login id for the netrc entry
=item password ()
Return the password for the netrc entry
=item account ()
Return the account information for the netrc entry
=item lpa ()
Return a list of login, password and account information fir the netrc entry
=back
=head1 AUTHOR
Graham Barr <gbarr at pobox.com>
=head1 SEE ALSO
L<Net::Netrc>
L<Net::Cmd>
=head1 COPYRIGHT
Copyright (c) 1995-1998 Graham Barr. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=for html <hr>
$Id: Netrc.pm,v 1.1 2006-12-04 17:00:49 dslinux_cayenne Exp $
=cut
--- NEW FILE: Hostname.eg ---
# This is an example Hostname.pm.
package Sys::Hostname;
use Net::Domain qw(hostname);
use Carp;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(hostname);
carp "deprecated package 'Sys::Hostname', use Net::Domain" if $^W;
1;
--- NEW FILE: Cmd.pm ---
# Net::Cmd.pm $Id: Cmd.pm,v 1.1 2006-12-04 17:00:49 dslinux_cayenne Exp $
#
# Copyright (c) 1995-1997 Graham Barr <gbarr at pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package Net::Cmd;
require 5.001;
require Exporter;
use strict;
use vars qw(@ISA @EXPORT $VERSION);
use Carp;
use Symbol 'gensym';
BEGIN {
if ($^O eq 'os390') {
require Convert::EBCDIC;
# Convert::EBCDIC->import;
}
}
$VERSION = "2.26";
@ISA = qw(Exporter);
@EXPORT = qw(CMD_INFO CMD_OK CMD_MORE CMD_REJECT CMD_ERROR CMD_PENDING);
sub CMD_INFO { 1 }
sub CMD_OK { 2 }
sub CMD_MORE { 3 }
sub CMD_REJECT { 4 }
sub CMD_ERROR { 5 }
sub CMD_PENDING { 0 }
my %debug = ();
my $tr = $^O eq 'os390' ? Convert::EBCDIC->new() : undef;
sub toebcdic
{
my $cmd = shift;
unless (exists ${*$cmd}{'net_cmd_asciipeer'})
{
my $string = $_[0];
my $ebcdicstr = $tr->toebcdic($string);
${*$cmd}{'net_cmd_asciipeer'} = $string !~ /^\d+/ && $ebcdicstr =~ /^\d+/;
}
${*$cmd}{'net_cmd_asciipeer'}
? $tr->toebcdic($_[0])
: $_[0];
}
sub toascii
{
my $cmd = shift;
${*$cmd}{'net_cmd_asciipeer'}
? $tr->toascii($_[0])
: $_[0];
}
sub _print_isa
{
no strict qw(refs);
my $pkg = shift;
my $cmd = $pkg;
$debug{$pkg} ||= 0;
my %done = ();
my @do = ($pkg);
my %spc = ( $pkg , "");
while ($pkg = shift @do)
{
next if defined $done{$pkg};
$done{$pkg} = 1;
my $v = defined ${"${pkg}::VERSION"}
? "(" . ${"${pkg}::VERSION"} . ")"
: "";
my $spc = $spc{$pkg};
$cmd->debug_print(1,"${spc}${pkg}${v}\n");
if(@{"${pkg}::ISA"})
{
@spc{@{"${pkg}::ISA"}} = (" " . $spc{$pkg}) x @{"${pkg}::ISA"};
unshift(@do, @{"${pkg}::ISA"});
}
}
}
sub debug
{
@_ == 1 or @_ == 2 or croak 'usage: $obj->debug([LEVEL])';
my($cmd,$level) = @_;
my $pkg = ref($cmd) || $cmd;
my $oldval = 0;
if(ref($cmd))
{
$oldval = ${*$cmd}{'net_cmd_debug'} || 0;
}
else
{
$oldval = $debug{$pkg} || 0;
}
return $oldval
unless @_ == 2;
$level = $debug{$pkg} || 0
unless defined $level;
_print_isa($pkg)
if($level && !exists $debug{$pkg});
if(ref($cmd))
{
${*$cmd}{'net_cmd_debug'} = $level;
}
else
{
$debug{$pkg} = $level;
}
$oldval;
}
sub message
{
@_ == 1 or croak 'usage: $obj->message()';
my $cmd = shift;
wantarray ? @{${*$cmd}{'net_cmd_resp'}}
: join("", @{${*$cmd}{'net_cmd_resp'}});
}
sub debug_text { $_[2] }
sub debug_print
{
my($cmd,$out,$text) = @_;
print STDERR $cmd,($out ? '>>> ' : '<<< '), $cmd->debug_text($out,$text);
}
sub code
{
@_ == 1 or croak 'usage: $obj->code()';
my $cmd = shift;
${*$cmd}{'net_cmd_code'} = "000"
unless exists ${*$cmd}{'net_cmd_code'};
${*$cmd}{'net_cmd_code'};
}
sub status
{
@_ == 1 or croak 'usage: $obj->status()';
my $cmd = shift;
substr(${*$cmd}{'net_cmd_code'},0,1);
}
sub set_status
{
@_ == 3 or croak 'usage: $obj->set_status(CODE, MESSAGE)';
my $cmd = shift;
my($code,$resp) = @_;
$resp = [ $resp ]
unless ref($resp);
(${*$cmd}{'net_cmd_code'},${*$cmd}{'net_cmd_resp'}) = ($code, $resp);
1;
}
sub command
{
my $cmd = shift;
unless (defined fileno($cmd))
{
$cmd->set_status("599", "Connection closed");
return $cmd;
}
$cmd->dataend()
if(exists ${*$cmd}{'net_cmd_last_ch'});
if (scalar(@_))
{
local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
my $str = join(" ", map { /\n/ ? do { my $n = $_; $n =~ tr/\n/ /; $n } : $_; } @_);
$str = $cmd->toascii($str) if $tr;
$str .= "\015\012";
my $len = length $str;
my $swlen;
$cmd->close
unless (defined($swlen = syswrite($cmd,$str,$len)) && $swlen == $len);
$cmd->debug_print(1,$str)
if($cmd->debug);
${*$cmd}{'net_cmd_resp'} = []; # the response
${*$cmd}{'net_cmd_code'} = "000"; # Made this one up :-)
}
$cmd;
}
sub ok
{
@_ == 1 or croak 'usage: $obj->ok()';
my $code = $_[0]->code;
0 < $code && $code < 400;
}
sub unsupported
{
my $cmd = shift;
${*$cmd}{'net_cmd_resp'} = [ 'Unsupported command' ];
${*$cmd}{'net_cmd_code'} = 580;
0;
}
sub getline
{
my $cmd = shift;
${*$cmd}{'net_cmd_lines'} ||= [];
return shift @{${*$cmd}{'net_cmd_lines'}}
if scalar(@{${*$cmd}{'net_cmd_lines'}});
my $partial = defined(${*$cmd}{'net_cmd_partial'})
? ${*$cmd}{'net_cmd_partial'} : "";
my $fd = fileno($cmd);
return undef
unless defined $fd;
my $rin = "";
vec($rin,$fd,1) = 1;
my $buf;
until(scalar(@{${*$cmd}{'net_cmd_lines'}}))
{
my $timeout = $cmd->timeout || undef;
my $rout;
if (select($rout=$rin, undef, undef, $timeout))
{
unless (sysread($cmd, $buf="", 1024))
{
carp(ref($cmd) . ": Unexpected EOF on command channel")
if $cmd->debug;
$cmd->close;
return undef;
}
substr($buf,0,0) = $partial; ## prepend from last sysread
my @buf = split(/\015?\012/, $buf, -1); ## break into lines
$partial = pop @buf;
push(@{${*$cmd}{'net_cmd_lines'}}, map { "$_\n" } @buf);
}
else
{
carp("$cmd: Timeout") if($cmd->debug);
return undef;
}
}
${*$cmd}{'net_cmd_partial'} = $partial;
if ($tr)
{
foreach my $ln (@{${*$cmd}{'net_cmd_lines'}})
{
$ln = $cmd->toebcdic($ln);
}
}
shift @{${*$cmd}{'net_cmd_lines'}};
}
sub ungetline
{
my($cmd,$str) = @_;
${*$cmd}{'net_cmd_lines'} ||= [];
unshift(@{${*$cmd}{'net_cmd_lines'}}, $str);
}
sub parse_response
{
return ()
unless $_[1] =~ s/^(\d\d\d)(.?)//o;
($1, $2 eq "-");
}
sub response
{
my $cmd = shift;
my($code,$more) = (undef) x 2;
${*$cmd}{'net_cmd_resp'} ||= [];
while(1)
{
my $str = $cmd->getline();
return CMD_ERROR
unless defined($str);
$cmd->debug_print(0,$str)
if ($cmd->debug);
($code,$more) = $cmd->parse_response($str);
unless(defined $code)
{
$cmd->ungetline($str);
last;
}
${*$cmd}{'net_cmd_code'} = $code;
push(@{${*$cmd}{'net_cmd_resp'}},$str);
last unless($more);
}
substr($code,0,1);
}
sub read_until_dot
{
my $cmd = shift;
my $fh = shift;
my $arr = [];
while(1)
{
my $str = $cmd->getline() or return undef;
$cmd->debug_print(0,$str)
if ($cmd->debug & 4);
last if($str =~ /^\.\r?\n/o);
$str =~ s/^\.\././o;
if (defined $fh)
{
print $fh $str;
}
else
{
push(@$arr,$str);
}
}
$arr;
}
sub datasend
{
my $cmd = shift;
my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_;
my $line = join("" ,@$arr);
return 0 unless defined(fileno($cmd));
my $last_ch = ${*$cmd}{'net_cmd_last_ch'};
$last_ch = ${*$cmd}{'net_cmd_last_ch'} = "\012" unless defined $last_ch;
return 1 unless length $line;
if($cmd->debug) {
foreach my $b (split(/\n/,$line)) {
$cmd->debug_print(1, "$b\n");
}
}
$line =~ tr/\r\n/\015\012/ unless "\r" eq "\015";
my $first_ch = '';
if ($last_ch eq "\015") {
$first_ch = "\012" if $line =~ s/^\012//;
}
elsif ($last_ch eq "\012") {
$first_ch = "." if $line =~ /^\./;
}
$line =~ s/\015?\012(\.?)/\015\012$1$1/sg;
substr($line,0,0) = $first_ch;
${*$cmd}{'net_cmd_last_ch'} = substr($line,-1,1);
my $len = length($line);
my $offset = 0;
my $win = "";
vec($win,fileno($cmd),1) = 1;
my $timeout = $cmd->timeout || undef;
local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
while($len)
{
my $wout;
if (select(undef,$wout=$win, undef, $timeout) > 0 or -f $cmd) # -f for testing on win32
{
my $w = syswrite($cmd, $line, $len, $offset);
unless (defined($w))
{
carp("$cmd: $!") if $cmd->debug;
return undef;
}
$len -= $w;
$offset += $w;
}
else
{
carp("$cmd: Timeout") if($cmd->debug);
return undef;
}
}
1;
}
sub rawdatasend
{
my $cmd = shift;
my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_;
my $line = join("" ,@$arr);
return 0 unless defined(fileno($cmd));
return 1
unless length($line);
if($cmd->debug)
{
my $b = "$cmd>>> ";
print STDERR $b,join("\n$b",split(/\n/,$line)),"\n";
}
my $len = length($line);
my $offset = 0;
my $win = "";
vec($win,fileno($cmd),1) = 1;
my $timeout = $cmd->timeout || undef;
local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
while($len)
{
my $wout;
if (select(undef,$wout=$win, undef, $timeout) > 0)
{
my $w = syswrite($cmd, $line, $len, $offset);
unless (defined($w))
{
carp("$cmd: $!") if $cmd->debug;
return undef;
}
$len -= $w;
$offset += $w;
}
else
{
carp("$cmd: Timeout") if($cmd->debug);
return undef;
}
}
1;
}
sub dataend
{
my $cmd = shift;
return 0 unless defined(fileno($cmd));
my $ch = ${*$cmd}{'net_cmd_last_ch'};
my $tosend;
if (!defined $ch) {
return 1;
}
elsif ($ch ne "\012") {
$tosend = "\015\012";
}
$tosend .= ".\015\012";
local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
$cmd->debug_print(1, ".\n")
if($cmd->debug);
syswrite($cmd,$tosend, length $tosend);
delete ${*$cmd}{'net_cmd_last_ch'};
$cmd->response() == CMD_OK;
}
# read and write to tied filehandle
sub tied_fh {
my $cmd = shift;
${*$cmd}{'net_cmd_readbuf'} = '';
my $fh = gensym();
tie *$fh,ref($cmd),$cmd;
return $fh;
}
# tie to myself
sub TIEHANDLE {
my $class = shift;
my $cmd = shift;
return $cmd;
}
# Tied filehandle read. Reads requested data length, returning
# end-of-file when the dot is encountered.
sub READ {
my $cmd = shift;
my ($len,$offset) = @_[1,2];
return unless exists ${*$cmd}{'net_cmd_readbuf'};
my $done = 0;
while (!$done and length(${*$cmd}{'net_cmd_readbuf'}) < $len) {
${*$cmd}{'net_cmd_readbuf'} .= $cmd->getline() or return;
$done++ if ${*$cmd}{'net_cmd_readbuf'} =~ s/^\.\r?\n\Z//m;
}
$_[0] = '';
substr($_[0],$offset+0) = substr(${*$cmd}{'net_cmd_readbuf'},0,$len);
substr(${*$cmd}{'net_cmd_readbuf'},0,$len) = '';
delete ${*$cmd}{'net_cmd_readbuf'} if $done;
return length $_[0];
}
sub READLINE {
my $cmd = shift;
# in this context, we use the presence of readbuf to
# indicate that we have not yet reached the eof
return unless exists ${*$cmd}{'net_cmd_readbuf'};
my $line = $cmd->getline;
return if $line =~ /^\.\r?\n/;
$line;
}
sub PRINT {
my $cmd = shift;
my ($buf,$len,$offset) = @_;
$len ||= length ($buf);
$offset += 0;
return unless $cmd->datasend(substr($buf,$offset,$len));
${*$cmd}{'net_cmd_sending'}++; # flag that we should call dataend()
return $len;
}
sub CLOSE {
my $cmd = shift;
my $r = exists(${*$cmd}{'net_cmd_sending'}) ? $cmd->dataend : 1;
delete ${*$cmd}{'net_cmd_readbuf'};
delete ${*$cmd}{'net_cmd_sending'};
$r;
}
1;
__END__
=head1 NAME
Net::Cmd - Network Command class (as used by FTP, SMTP etc)
=head1 SYNOPSIS
use Net::Cmd;
@ISA = qw(Net::Cmd);
=head1 DESCRIPTION
C<Net::Cmd> is a collection of methods that can be inherited by a sub class
of C<IO::Handle>. These methods implement the functionality required for a
command based protocol, for example FTP and SMTP.
=head1 USER METHODS
These methods provide a user interface to the C<Net::Cmd> object.
=over 4
=item debug ( VALUE )
Set the level of debug information for this object. If C<VALUE> is not given
then the current state is returned. Otherwise the state is changed to
C<VALUE> and the previous state returned.
Different packages
may implement different levels of debug but a non-zero value results in
copies of all commands and responses also being sent to STDERR.
If C<VALUE> is C<undef> then the debug level will be set to the default
debug level for the class.
This method can also be called as a I<static> method to set/get the default
debug level for a given class.
=item message ()
Returns the text message returned from the last command
=item code ()
Returns the 3-digit code from the last command. If a command is pending
then the value 0 is returned
=item ok ()
Returns non-zero if the last code value was greater than zero and
less than 400. This holds true for most command servers. Servers
where this does not hold may override this method.
=item status ()
Returns the most significant digit of the current status code. If a command
is pending then C<CMD_PENDING> is returned.
=item datasend ( DATA )
Send data to the remote server, converting LF to CRLF. Any line starting
with a '.' will be prefixed with another '.'.
C<DATA> may be an array or a reference to an array.
=item dataend ()
End the sending of data to the remote server. This is done by ensuring that
the data already sent ends with CRLF then sending '.CRLF' to end the
transmission. Once this data has been sent C<dataend> calls C<response> and
returns true if C<response> returns CMD_OK.
=back
=head1 CLASS METHODS
These methods are not intended to be called by the user, but used or
over-ridden by a sub-class of C<Net::Cmd>
=over 4
=item debug_print ( DIR, TEXT )
Print debugging information. C<DIR> denotes the direction I<true> being
data being sent to the server. Calls C<debug_text> before printing to
STDERR.
=item debug_text ( TEXT )
This method is called to print debugging information. TEXT is
the text being sent. The method should return the text to be printed
This is primarily meant for the use of modules such as FTP where passwords
are sent, but we do not want to display them in the debugging information.
=item command ( CMD [, ARGS, ... ])
Send a command to the command server. All arguments a first joined with
a space character and CRLF is appended, this string is then sent to the
command server.
Returns undef upon failure
=item unsupported ()
Sets the status code to 580 and the response text to 'Unsupported command'.
Returns zero.
=item response ()
Obtain a response from the server. Upon success the most significant digit
of the status code is returned. Upon failure, timeout etc., I<undef> is
returned.
=item parse_response ( TEXT )
This method is called by C<response> as a method with one argument. It should
return an array of 2 values, the 3-digit status code and a flag which is true
when this is part of a multi-line response and this line is not the list.
=item getline ()
Retrieve one line, delimited by CRLF, from the remote server. Returns I<undef>
upon failure.
B<NOTE>: If you do use this method for any reason, please remember to add
some C<debug_print> calls into your method.
=item ungetline ( TEXT )
Unget a line of text from the server.
=item rawdatasend ( DATA )
Send data to the remote server without performing any conversions. C<DATA>
is a scalar.
=item read_until_dot ()
Read data from the remote server until a line consisting of a single '.'.
Any lines starting with '..' will have one of the '.'s removed.
Returns a reference to a list containing the lines, or I<undef> upon failure.
=item tied_fh ()
Returns a filehandle tied to the Net::Cmd object. After issuing a
command, you may read from this filehandle using read() or <>. The
filehandle will return EOF when the final dot is encountered.
Similarly, you may write to the filehandle in order to send data to
the server after issuing a commmand that expects data to be written.
See the Net::POP3 and Net::SMTP modules for examples of this.
=back
=head1 EXPORTS
C<Net::Cmd> exports six subroutines, five of these, C<CMD_INFO>, C<CMD_OK>,
C<CMD_MORE>, C<CMD_REJECT> and C<CMD_ERROR>, correspond to possible results
of C<response> and C<status>. The sixth is C<CMD_PENDING>.
=head1 AUTHOR
Graham Barr <gbarr at pobox.com>
=head1 COPYRIGHT
Copyright (c) 1995-1997 Graham Barr. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=for html <hr>
I<$Id: Cmd.pm,v 1.1 2006-12-04 17:00:49 dslinux_cayenne Exp $>
=cut
--- NEW FILE: Config.eg ---
package Net::Config;
require Exporter;
use vars qw(@ISA @EXPORT %NetConfig);
use strict;
@EXPORT = qw(%NetConfig);
@ISA = qw(Exporter);
# WARNING WARNING WARNING WARNING WARNING WARNING WARNING
# WARNING WARNING WARNING WARNING WARNING WARNING WARNING
#
# Below this line is auto-generated, *ANY* changes will be lost
%NetConfig = (
# the followinf parameters are all lists of hosts for the
# respective protocols.
nntp_hosts => [],
snpp_hosts => [],
pop3_hosts => [],
smtp_hosts => [],
ph_hosts => [],
daytime_hosts => [],
time_hosts => [],
# your internet domain
inet_domain => undef,
# If you have an ftp proxy firewall (not an http firewall)
# then set this to the name of the firewall
ftp_firewall => undef,
# set if all connections done via the firewall should use
# passive data connections
ftp_ext_passive => 0,
# set if all connections not done via the firewall should use
# passive data connections
ftp_int_passive => 0,
# If set the make test will attempt to connect to the hosts above
test_hosts => 0,
# Used during Configure (which you are not using) to do
# DNS lookups to ensure hosts exist
test_exist => 0,
);
1;
--- NEW FILE: Changes.libnet ---
libnet 1.19 -- Wed Jun 30 14:53:48 BST 2004
Bug Fixes
* Fixed datasend test to work on Win32 platform
* Fixed Authen::SASL checking in SMTP.pm and POP3.pm
* Fixed bug that a restarted get with Net::FTP did not append to local file
libnet 1.18 -- Mon Mar 22 16:19:01 GMT 2004
Bug Fixes
* Fixed bug in CRLF translation in Net::Cmd datasend/dataend methods
* Fixed bug in converting numbers returned by PASV command into a
packed IP address
* Fixed bug that caused Net::FTP->get to truncate the local file after
the restart method had been called
* Fixed bug in Net::FTP-.rmdir when the server returned . and .. in
the contents of a directory
* Fixed bug in POP3 that was sending unnecessary RSETs
Enhancements
* Added support for POP3 CAPA command
* Added support for XVERP to Net::SMTP
* Added Net::POP3->banner method to return the banner received from
the server during connect
* Added Net::POP3->auth method for performing authentication using
SASL, requires Authen::SASL
* Added Host option to ->new constructor of FTP, NNTP, SMTP and POP3
which can be used instead of passing the host as the first argument
* Added ->host method to FTP, NNTP, SMTP and POP3 to return the host
string used for the connect. This is useful to determine which host
was connected to when multiple hosts are specified
* Added support for more non-standard responses to Net::FTP->size
* Updated POD for Net::SMTP wrt. not passing a Hello parameter to the
constructor. (Jeff Macdonald)
ChangeLogs for releases prior to 1.18 may be found at
http://svn.mutatus.co.uk/browse/libnet/tags/libnet-1.17/ChangeLog
--- NEW FILE: netent.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
BEGIN {
our $hasne;
eval { my @n = getnetbyname "loopback" };
$hasne = 1 unless $@ && $@ =~ /unimplemented|unsupported/i;
unless ($hasne) { print "1..0 # Skip: no getnetbyname\n"; exit 0 }
use Config;
$hasne = 0 unless $Config{'i_netdb'} eq 'define';
unless ($hasne) { print "1..0 # Skip: no netdb.h\n"; exit 0 }
}
BEGIN {
our @netent = getnetbyname "loopback"; # This is the function getnetbyname.
unless (@netent) { print "1..0 # Skip: no loopback net\n"; exit 0 }
}
print "1..2\n";
use Net::netent;
print "ok 1\n";
my $netent = getnetbyname "loopback"; # This is the OO getnetbyname.
print "not " unless $netent->name eq $netent[0];
print "ok 2\n";
# Testing pretty much anything else is unportable;
# e.g. the canonical name of the "loopback" net may be "loop".
--- NEW FILE: hostent.t ---
#!./perl -w
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
use Test::More;
BEGIN {
require Config; import Config;
if ($Config{'extensions'} !~ /\bSocket\b/ &&
!(($^O eq 'VMS') && $Config{d_socket}))
{
plan skip_all => "Test uses Socket, Socket not built";
}
if ($^O eq 'MacOS' || ($^O eq 'irix' && $Config{osvers} == 5)) {
plan skip_all => "Test relies on resolution of localhost, fails on $^O ($Config{osvers})";
}
}
use Test::More tests => 7;
BEGIN { use_ok 'Net::hostent' }
# Remind me to add this to Test::More.
sub DIE {
print "# @_\n";
exit 1;
}
# test basic resolution of localhost <-> 127.0.0.1
use Socket;
my $h = gethost('localhost');
ok(defined $h, "gethost('localhost')") ||
DIE("Can't continue without working gethost: $!");
is( inet_ntoa($h->addr), "127.0.0.1", 'addr from gethost' );
my $i = gethostbyaddr(inet_aton("127.0.0.1"));
ok(defined $i, "gethostbyaddr('127.0.0.1')") ||
DIE("Can't continue without working gethostbyaddr: $!");
is( inet_ntoa($i->addr), "127.0.0.1", 'addr from gethostbyaddr' );
# need to skip the name comparisons on Win32 because windows will
# return the name of the machine instead of "localhost" when resolving
# 127.0.0.1 or even "localhost"
# - VMS returns "LOCALHOST" under tcp/ip services V4.1 ECO 2, possibly others
# - OS/390 returns localhost.YADDA.YADDA
SKIP: {
skip "Windows will return the machine name instead of 'localhost'", 2
if $^O eq 'MSWin32' or $^O eq 'NetWare' or $^O eq 'cygwin';
print "# name = " . $h->name . ", aliases = " . join (",", @{$h->aliases}) . "\n";
my $in_alias;
unless ($h->name =~ /^localhost(?:\..+)?$/i) {
foreach (@{$h->aliases}) {
if (/^localhost(?:\..+)?$/i) {
$in_alias = 1;
last;
}
}
ok( $in_alias );
} else {
ok( 1 );
}
if ($in_alias) {
# If we found it in the aliases before, expect to find it there again.
foreach (@{$h->aliases}) {
if (/^localhost(?:\..+)?$/i) {
# This time, clear the flag if we see "localhost"
undef $in_alias;
last;
}
}
}
if( $in_alias ) {
like( $i->name, qr/^localhost(?:\..+)?$/i );
}
else {
ok( !$in_alias );
print "# " . $h->name . " " . join (",", @{$h->aliases}) . "\n";
}
}
--- NEW FILE: hostent.pm ---
package Net::hostent;
use strict;
use 5.006_001;
our $VERSION = '1.01';
our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
BEGIN {
use Exporter ();
@EXPORT = qw(gethostbyname gethostbyaddr gethost);
@EXPORT_OK = qw(
$h_name @h_aliases
$h_addrtype $h_length
@h_addr_list $h_addr
);
%EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] );
}
use vars @EXPORT_OK;
# Class::Struct forbids use of @ISA
sub import { goto &Exporter::import }
use Class::Struct qw(struct);
struct 'Net::hostent' => [
name => '$',
aliases => '@',
addrtype => '$',
'length' => '$',
addr_list => '@',
];
sub addr { shift->addr_list->[0] }
sub populate (@) {
return unless @_;
my $hob = new();
$h_name = $hob->[0] = $_[0];
@h_aliases = @{ $hob->[1] } = split ' ', $_[1];
$h_addrtype = $hob->[2] = $_[2];
$h_length = $hob->[3] = $_[3];
$h_addr = $_[4];
@h_addr_list = @{ $hob->[4] } = @_[ (4 .. $#_) ];
return $hob;
}
sub gethostbyname ($) { populate(CORE::gethostbyname(shift)) }
sub gethostbyaddr ($;$) {
my ($addr, $addrtype);
$addr = shift;
require Socket unless @_;
$addrtype = @_ ? shift : Socket::AF_INET();
populate(CORE::gethostbyaddr($addr, $addrtype))
}
sub gethost($) {
if ($_[0] =~ /^\d+(?:\.\d+(?:\.\d+(?:\.\d+)?)?)?$/) {
require Socket;
&gethostbyaddr(Socket::inet_aton(shift));
} else {
&gethostbyname;
}
}
1;
__END__
=head1 NAME
Net::hostent - by-name interface to Perl's built-in gethost*() functions
=head1 SYNOPSIS
use Net::hostent;
=head1 DESCRIPTION
This module's default exports override the core gethostbyname() and
gethostbyaddr() functions, replacing them with versions that return
"Net::hostent" objects. This object has methods that return the similarly
named structure field name from the C's hostent structure from F<netdb.h>;
namely name, aliases, addrtype, length, and addr_list. The aliases and
addr_list methods return array reference, the rest scalars. The addr
method is equivalent to the zeroth element in the addr_list array
reference.
You may also import all the structure fields directly into your namespace
as regular variables using the :FIELDS import tag. (Note that this still
overrides your core functions.) Access these fields as variables named
with a preceding C<h_>. Thus, C<$host_obj-E<gt>name()> corresponds to
$h_name if you import the fields. Array references are available as
regular array variables, so for example C<@{ $host_obj-E<gt>aliases()
}> would be simply @h_aliases.
The gethost() function is a simple front-end that forwards a numeric
argument to gethostbyaddr() by way of Socket::inet_aton, and the rest
to gethostbyname().
To access this functionality without the core overrides,
pass the C<use> an empty import list, and then access
function functions with their full qualified names.
On the other hand, the built-ins are still available
via the C<CORE::> pseudo-package.
=head1 EXAMPLES
use Net::hostent;
use Socket;
@ARGV = ('netscape.com') unless @ARGV;
for $host ( @ARGV ) {
unless ($h = gethost($host)) {
warn "$0: no such host: $host\n";
next;
}
printf "\n%s is %s%s\n",
$host,
lc($h->name) eq lc($host) ? "" : "*really* ",
$h->name;
print "\taliases are ", join(", ", @{$h->aliases}), "\n"
if @{$h->aliases};
if ( @{$h->addr_list} > 1 ) {
my $i;
for $addr ( @{$h->addr_list} ) {
printf "\taddr #%d is [%s]\n", $i++, inet_ntoa($addr);
}
} else {
printf "\taddress is [%s]\n", inet_ntoa($h->addr);
}
if ($h = gethostbyaddr($h->addr)) {
if (lc($h->name) ne lc($host)) {
printf "\tThat addr reverses to host %s!\n", $h->name;
$host = $h->name;
redo;
}
}
}
=head1 NOTE
While this class is currently implemented using the Class::Struct
module to build a struct-like class, you shouldn't rely upon this.
=head1 AUTHOR
Tom Christiansen
More information about the dslinux-commit
mailing list