diff options
Diffstat (limited to 'contrib/perl5/lib/Net')
| -rw-r--r-- | contrib/perl5/lib/Net/Ping.pm | 550 | ||||
| -rw-r--r-- | contrib/perl5/lib/Net/hostent.pm | 149 | ||||
| -rw-r--r-- | contrib/perl5/lib/Net/netent.pm | 167 | ||||
| -rw-r--r-- | contrib/perl5/lib/Net/protoent.pm | 94 | ||||
| -rw-r--r-- | contrib/perl5/lib/Net/servent.pm | 111 |
5 files changed, 1071 insertions, 0 deletions
diff --git a/contrib/perl5/lib/Net/Ping.pm b/contrib/perl5/lib/Net/Ping.pm new file mode 100644 index 0000000..495b82f --- /dev/null +++ b/contrib/perl5/lib/Net/Ping.pm @@ -0,0 +1,550 @@ +package Net::Ping; + +# Author: mose@ccsn.edu (Russell Mosemann) +# +# Authors of the original pingecho(): +# karrer@bernina.ethz.ch (Andreas Karrer) +# pmarquess@bfsec.bt.co.uk (Paul Marquess) +# +# Copyright (c) 1996 Russell Mosemann. All rights reserved. This +# program is free software; you may redistribute it and/or modify it +# under the same terms as Perl itself. + +require 5.002; +require Exporter; + +use strict; +use vars qw(@ISA @EXPORT $VERSION + $def_timeout $def_proto $max_datasize); +use FileHandle; +use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW PF_INET + inet_aton sockaddr_in ); +use Carp; + +@ISA = qw(Exporter); +@EXPORT = qw(pingecho); +$VERSION = 2.02; + +# Constants + +$def_timeout = 5; # Default timeout to wait for a reply +$def_proto = "udp"; # Default protocol to use for pinging +$max_datasize = 1024; # Maximum data bytes in a packet + +# Description: The pingecho() subroutine is provided for backward +# compatibility with the original Net::Ping. It accepts a host +# name/IP and an optional timeout in seconds. Create a tcp ping +# object and try pinging the host. The result of the ping is returned. + +sub pingecho +{ + my ($host, # Name or IP number of host to ping + $timeout # Optional timeout in seconds + ) = @_; + my ($p); # A ping object + + $p = Net::Ping->new("tcp", $timeout); + $p->ping($host); # Going out of scope closes the connection +} + +# Description: The new() method creates a new ping object. Optional +# parameters may be specified for the protocol to use, the timeout in +# seconds and the size in bytes of additional data which should be +# included in the packet. +# After the optional parameters are checked, the data is constructed +# and a socket is opened if appropriate. The object is returned. + +sub new +{ + my ($this, + $proto, # Optional protocol to use for pinging + $timeout, # Optional timeout in seconds + $data_size # Optional additional bytes of data + ) = @_; + my $class = ref($this) || $this; + my $self = {}; + my ($cnt, # Count through data bytes + $min_datasize # Minimum data bytes required + ); + + bless($self, $class); + + $proto = $def_proto unless $proto; # Determine the protocol + croak("Protocol for ping must be \"tcp\", \"udp\" or \"icmp\"") + unless $proto =~ m/^(tcp|udp|icmp)$/; + $self->{"proto"} = $proto; + + $timeout = $def_timeout unless $timeout; # Determine the timeout + croak("Default timeout for ping must be greater than 0 seconds") + if $timeout <= 0; + $self->{"timeout"} = $timeout; + + $min_datasize = ($proto eq "udp") ? 1 : 0; # Determine data size + $data_size = $min_datasize unless defined($data_size) && $proto ne "tcp"; + croak("Data for ping must be from $min_datasize to $max_datasize bytes") + if ($data_size < $min_datasize) || ($data_size > $max_datasize); + $data_size-- if $self->{"proto"} eq "udp"; # We provide the first byte + $self->{"data_size"} = $data_size; + + $self->{"data"} = ""; # Construct data bytes + for ($cnt = 0; $cnt < $self->{"data_size"}; $cnt++) + { + $self->{"data"} .= chr($cnt % 256); + } + + $self->{"seq"} = 0; # For counting packets + if ($self->{"proto"} eq "udp") # Open a socket + { + $self->{"proto_num"} = (getprotobyname('udp'))[2] || + croak("Can't udp protocol by name"); + $self->{"port_num"} = (getservbyname('echo', 'udp'))[2] || + croak("Can't get udp echo port by name"); + $self->{"fh"} = FileHandle->new(); + socket($self->{"fh"}, &PF_INET(), &SOCK_DGRAM(), + $self->{"proto_num"}) || + croak("udp socket error - $!"); + } + elsif ($self->{"proto"} eq "icmp") + { + croak("icmp ping requires root privilege") if ($> and $^O ne 'VMS'); + $self->{"proto_num"} = (getprotobyname('icmp'))[2] || + croak("Can't get icmp protocol by name"); + $self->{"pid"} = $$ & 0xffff; # Save lower 16 bits of pid + $self->{"fh"} = FileHandle->new(); + socket($self->{"fh"}, &PF_INET(), &SOCK_RAW(), $self->{"proto_num"}) || + croak("icmp socket error - $!"); + } + elsif ($self->{"proto"} eq "tcp") # Just a file handle for now + { + $self->{"proto_num"} = (getprotobyname('tcp'))[2] || + croak("Can't get tcp protocol by name"); + $self->{"port_num"} = (getservbyname('echo', 'tcp'))[2] || + croak("Can't get tcp echo port by name"); + $self->{"fh"} = FileHandle->new(); + } + + + return($self); +} + +# Description: Ping a host name or IP number with an optional timeout. +# First lookup the host, and return undef if it is not found. Otherwise +# perform the specific ping method based on the protocol. Return the +# result of the ping. + +sub ping +{ + my ($self, + $host, # Name or IP number of host to ping + $timeout # Seconds after which ping times out + ) = @_; + my ($ip, # Packed IP number of $host + $ret # The return value + ); + + croak("Usage: \$p->ping(\$host [, \$timeout])") unless @_ == 2 || @_ == 3; + $timeout = $self->{"timeout"} unless $timeout; + croak("Timeout must be greater than 0 seconds") if $timeout <= 0; + + $ip = inet_aton($host); + return(undef) unless defined($ip); # Does host exist? + + if ($self->{"proto"} eq "udp") + { + $ret = $self->ping_udp($ip, $timeout); + } + elsif ($self->{"proto"} eq "icmp") + { + $ret = $self->ping_icmp($ip, $timeout); + } + elsif ($self->{"proto"} eq "tcp") + { + $ret = $self->ping_tcp($ip, $timeout); + } + else + { + croak("Unknown protocol \"$self->{proto}\" in ping()"); + } + return($ret); +} + +sub ping_icmp +{ + my ($self, + $ip, # Packed IP number of the host + $timeout # Seconds after which ping times out + ) = @_; + + my $ICMP_ECHOREPLY = 0; # ICMP packet types + my $ICMP_ECHO = 8; + my $icmp_struct = "C2 S3 A"; # Structure of a minimal ICMP packet + my $subcode = 0; # No ICMP subcode for ECHO and ECHOREPLY + my $flags = 0; # No special flags when opening a socket + my $port = 0; # No port with ICMP + + my ($saddr, # sockaddr_in with port and ip + $checksum, # Checksum of ICMP packet + $msg, # ICMP packet to send + $len_msg, # Length of $msg + $rbits, # Read bits, filehandles for reading + $nfound, # Number of ready filehandles found + $finish_time, # Time ping should be finished + $done, # set to 1 when we are done + $ret, # Return value + $recv_msg, # Received message including IP header + $from_saddr, # sockaddr_in of sender + $from_port, # Port packet was sent from + $from_ip, # Packed IP of sender + $from_type, # ICMP type + $from_subcode, # ICMP subcode + $from_chk, # ICMP packet checksum + $from_pid, # ICMP packet id + $from_seq, # ICMP packet sequence + $from_msg # ICMP message + ); + + $self->{"seq"} = ($self->{"seq"} + 1) % 65536; # Increment sequence + $checksum = 0; # No checksum for starters + $msg = pack($icmp_struct . $self->{"data_size"}, $ICMP_ECHO, $subcode, + $checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"}); + $checksum = Net::Ping->checksum($msg); + $msg = pack($icmp_struct . $self->{"data_size"}, $ICMP_ECHO, $subcode, + $checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"}); + $len_msg = length($msg); + $saddr = sockaddr_in($port, $ip); + send($self->{"fh"}, $msg, $flags, $saddr); # Send the message + + $rbits = ""; + vec($rbits, $self->{"fh"}->fileno(), 1) = 1; + $ret = 0; + $done = 0; + $finish_time = time() + $timeout; # Must be done by this time + while (!$done && $timeout > 0) # Keep trying if we have time + { + $nfound = select($rbits, undef, undef, $timeout); # Wait for packet + $timeout = $finish_time - time(); # Get remaining time + if (!defined($nfound)) # Hmm, a strange error + { + $ret = undef; + $done = 1; + } + elsif ($nfound) # Got a packet from somewhere + { + $recv_msg = ""; + $from_saddr = recv($self->{"fh"}, $recv_msg, 1500, $flags); + ($from_port, $from_ip) = sockaddr_in($from_saddr); + ($from_type, $from_subcode, $from_chk, + $from_pid, $from_seq, $from_msg) = + unpack($icmp_struct . $self->{"data_size"}, + substr($recv_msg, length($recv_msg) - $len_msg, + $len_msg)); + if (($from_type == $ICMP_ECHOREPLY) && + ($from_ip eq $ip) && + ($from_pid == $self->{"pid"}) && # Does the packet check out? + ($from_seq == $self->{"seq"})) + { + $ret = 1; # It's a winner + $done = 1; + } + } + else # Oops, timed out + { + $done = 1; + } + } + return($ret) +} + +# Description: Do a checksum on the message. Basically sum all of +# the short words and fold the high order bits into the low order bits. + +sub checksum +{ + my ($class, + $msg # The message to checksum + ) = @_; + my ($len_msg, # Length of the message + $num_short, # The number of short words in the message + $short, # One short word + $chk # The checksum + ); + + $len_msg = length($msg); + $num_short = $len_msg / 2; + $chk = 0; + foreach $short (unpack("S$num_short", $msg)) + { + $chk += $short; + } # Add the odd byte in + $chk += unpack("C", substr($msg, $len_msg - 1, 1)) if $len_msg % 2; + $chk = ($chk >> 16) + ($chk & 0xffff); # Fold high into low + return(~(($chk >> 16) + $chk) & 0xffff); # Again and complement +} + +# Description: Perform a tcp echo ping. Since a tcp connection is +# host specific, we have to open and close each connection here. We +# can't just leave a socket open. Because of the robust nature of +# tcp, it will take a while before it gives up trying to establish a +# connection. Therefore, we have to set the alarm to break out of the +# connection sooner if the timeout expires. No data bytes are actually +# sent since the successful establishment of a connection is proof +# enough of the reachability of the remote host. Also, tcp is +# expensive and doesn't need our help to add to the overhead. + +sub ping_tcp +{ + my ($self, + $ip, # Packed IP number of the host + $timeout # Seconds after which ping times out + ) = @_; + my ($saddr, # sockaddr_in with port and ip + $ret # The return value + ); + + socket($self->{"fh"}, &PF_INET(), &SOCK_STREAM(), $self->{"proto_num"}) || + croak("tcp socket error - $!"); + $saddr = sockaddr_in($self->{"port_num"}, $ip); + + $SIG{'ALRM'} = sub { die }; + alarm($timeout); # Interrupt connect() if we have to + + $ret = 0; # Default to unreachable + eval <<'EOM' ; + return unless connect($self->{"fh"}, $saddr); + $ret = 1; +EOM + alarm(0); + $self->{"fh"}->close(); + return($ret); +} + +# Description: Perform a udp echo ping. Construct a message of +# at least the one-byte sequence number and any additional data bytes. +# Send the message out and wait for a message to come back. If we +# get a message, make sure all of its parts match. If they do, we are +# done. Otherwise go back and wait for the message until we run out +# of time. Return the result of our efforts. + +sub ping_udp +{ + my ($self, + $ip, # Packed IP number of the host + $timeout # Seconds after which ping times out + ) = @_; + + my $flags = 0; # Nothing special on open + + my ($saddr, # sockaddr_in with port and ip + $ret, # The return value + $msg, # Message to be echoed + $finish_time, # Time ping should be finished + $done, # Set to 1 when we are done pinging + $rbits, # Read bits, filehandles for reading + $nfound, # Number of ready filehandles found + $from_saddr, # sockaddr_in of sender + $from_msg, # Characters echoed by $host + $from_port, # Port message was echoed from + $from_ip # Packed IP number of sender + ); + + $saddr = sockaddr_in($self->{"port_num"}, $ip); + $self->{"seq"} = ($self->{"seq"} + 1) % 256; # Increment sequence + $msg = chr($self->{"seq"}) . $self->{"data"}; # Add data if any + send($self->{"fh"}, $msg, $flags, $saddr); # Send it + + $rbits = ""; + vec($rbits, $self->{"fh"}->fileno(), 1) = 1; + $ret = 0; # Default to unreachable + $done = 0; + $finish_time = time() + $timeout; # Ping needs to be done by then + while (!$done && $timeout > 0) + { + $nfound = select($rbits, undef, undef, $timeout); # Wait for response + $timeout = $finish_time - time(); # Get remaining time + + if (!defined($nfound)) # Hmm, a strange error + { + $ret = undef; + $done = 1; + } + elsif ($nfound) # A packet is waiting + { + $from_msg = ""; + $from_saddr = recv($self->{"fh"}, $from_msg, 1500, $flags); + ($from_port, $from_ip) = sockaddr_in($from_saddr); + if (($from_ip eq $ip) && # Does the packet check out? + ($from_port == $self->{"port_num"}) && + ($from_msg eq $msg)) + { + $ret = 1; # It's a winner + $done = 1; + } + } + else # Oops, timed out + { + $done = 1; + } + } + return($ret); +} + +# Description: Close the connection unless we are using the tcp +# protocol, since it will already be closed. + +sub close +{ + my ($self) = @_; + + $self->{"fh"}->close() unless $self->{"proto"} eq "tcp"; +} + + +1; +__END__ + +=head1 NAME + +Net::Ping - check a remote host for reachability + +=head1 SYNOPSIS + + use Net::Ping; + + $p = Net::Ping->new(); + print "$host is alive.\n" if $p->ping($host); + $p->close(); + + $p = Net::Ping->new("icmp"); + foreach $host (@host_array) + { + print "$host is "; + print "NOT " unless $p->ping($host, 2); + print "reachable.\n"; + sleep(1); + } + $p->close(); + + $p = Net::Ping->new("tcp", 2); + while ($stop_time > time()) + { + print "$host not reachable ", scalar(localtime()), "\n" + unless $p->ping($host); + sleep(300); + } + undef($p); + + # For backward compatibility + print "$host is alive.\n" if pingecho($host); + +=head1 DESCRIPTION + +This module contains methods to test the reachability of remote +hosts on a network. A ping object is first created with optional +parameters, a variable number of hosts may be pinged multiple +times and then the connection is closed. + +You may choose one of three different protocols to use for the ping. +With the "tcp" protocol the ping() method attempts to establish a +connection to the remote host's echo port. If the connection is +successfully established, the remote host is considered reachable. No +data is actually echoed. This protocol does not require any special +privileges but has higher overhead than the other two protocols. + +Specifying the "udp" protocol causes the ping() method to send a udp +packet to the remote host's echo port. If the echoed packet is +received from the remote host and the received packet contains the +same data as the packet that was sent, the remote host is considered +reachable. This protocol does not require any special privileges. + +If the "icmp" protocol is specified, the ping() method sends an icmp +echo message to the remote host, which is what the UNIX ping program +does. If the echoed message is received from the remote host and +the echoed information is correct, the remote host is considered +reachable. Specifying the "icmp" protocol requires that the program +be run as root or that the program be setuid to root. + +=head2 Functions + +=over 4 + +=item Net::Ping->new([$proto [, $def_timeout [, $bytes]]]); + +Create a new ping object. All of the parameters are optional. $proto +specifies the protocol to use when doing a ping. The current choices +are "tcp", "udp" or "icmp". The default is "udp". + +If a default timeout ($def_timeout) in seconds is provided, it is used +when a timeout is not given to the ping() method (below). The timeout +must be greater than 0 and the default, if not specified, is 5 seconds. + +If the number of data bytes ($bytes) is given, that many data bytes +are included in the ping packet sent to the remote host. The number of +data bytes is ignored if the protocol is "tcp". The minimum (and +default) number of data bytes is 1 if the protocol is "udp" and 0 +otherwise. The maximum number of data bytes that can be specified is +1024. + +=item $p->ping($host [, $timeout]); + +Ping the remote host and wait for a response. $host can be either the +hostname or the IP number of the remote host. The optional timeout +must be greater than 0 seconds and defaults to whatever was specified +when the ping object was created. If the hostname cannot be found or +there is a problem with the IP number, undef is returned. Otherwise, +1 is returned if the host is reachable and 0 if it is not. For all +practical purposes, undef and 0 and can be treated as the same case. + +=item $p->close(); + +Close the network connection for this ping object. The network +connection is also closed by "undef $p". The network connection is +automatically closed if the ping object goes out of scope (e.g. $p is +local to a subroutine and you leave the subroutine). + +=item pingecho($host [, $timeout]); + +To provide backward compatibility with the previous version of +Net::Ping, a pingecho() subroutine is available with the same +functionality as before. pingecho() uses the tcp protocol. The +return values and parameters are the same as described for the ping() +method. This subroutine is obsolete and may be removed in a future +version of Net::Ping. + +=back + +=head1 WARNING + +pingecho() or a ping object with the tcp protocol use alarm() to +implement the timeout. So, don't use alarm() in your program while +you are using pingecho() or a ping object with the tcp protocol. The +udp and icmp protocols do not use alarm() to implement the timeout. + +=head1 NOTES + +There will be less network overhead (and some efficiency in your +program) if you specify either the udp or the icmp protocol. The tcp +protocol will generate 2.5 times or more traffic for each ping than +either udp or icmp. If many hosts are pinged frequently, you may wish +to implement a small wait (e.g. 25ms or more) between each ping to +avoid flooding your network with packets. + +The icmp protocol requires that the program be run as root or that it +be setuid to root. The tcp and udp protocols do not require special +privileges, but not all network devices implement the echo protocol +for tcp or udp. + +Local hosts should normally respond to pings within milliseconds. +However, on a very congested network it may take up to 3 seconds or +longer to receive an echo packet from the remote host. If the timeout +is set too low under these conditions, it will appear that the remote +host is not reachable (which is almost the truth). + +Reachability doesn't necessarily mean that the remote host is actually +functioning beyond its ability to echo packets. + +Because of a lack of anything better, this module uses its own +routines to pack and unpack ICMP packets. It would be better for a +separate module to be written which understands all of the different +kinds of ICMP packets. + +=cut diff --git a/contrib/perl5/lib/Net/hostent.pm b/contrib/perl5/lib/Net/hostent.pm new file mode 100644 index 0000000..96b090d --- /dev/null +++ b/contrib/perl5/lib/Net/hostent.pm @@ -0,0 +1,149 @@ +package Net::hostent; +use strict; + +BEGIN { + use Exporter (); + use vars qw(@EXPORT @EXPORT_OK %EXPORT_TAGS); + @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::hostnet; + +=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() funtion is a simple front-end that forwards a numeric +argument to gethostbyaddr() by way of Socket::inet_aton, and the rest +to gethostbyname(). + +To access this functionality without the core overrides, +pass the C<use> an empty import list, and then access +function functions with their full qualified names. +On the other hand, the built-ins are still available +via the C<CORE::> pseudo-package. + +=head1 EXAMPLES + + use Net::hostent; + use Socket; + + @ARGV = ('netscape.com') unless @ARGV; + + for $host ( @ARGV ) { + + unless ($h = gethost($host)) { + warn "$0: no such host: $host\n"; + next; + } + + printf "\n%s is %s%s\n", + $host, + lc($h->name) eq lc($host) ? "" : "*really* ", + $h->name; + + print "\taliases are ", join(", ", @{$h->aliases}), "\n" + if @{$h->aliases}; + + if ( @{$h->addr_list} > 1 ) { + my $i; + for $addr ( @{$h->addr_list} ) { + printf "\taddr #%d is [%s]\n", $i++, inet_ntoa($addr); + } + } else { + printf "\taddress is [%s]\n", inet_ntoa($h->addr); + } + + if ($h = gethostbyaddr($h->addr)) { + if (lc($h->name) ne lc($host)) { + printf "\tThat addr reverses to host %s!\n", $h->name; + $host = $h->name; + redo; + } + } + } + +=head1 NOTE + +While this class is currently implemented using the Class::Struct +module to build a struct-like class, you shouldn't rely upon this. + +=head1 AUTHOR + +Tom Christiansen diff --git a/contrib/perl5/lib/Net/netent.pm b/contrib/perl5/lib/Net/netent.pm new file mode 100644 index 0000000..b82447c --- /dev/null +++ b/contrib/perl5/lib/Net/netent.pm @@ -0,0 +1,167 @@ +package Net::netent; +use strict; + +BEGIN { + use Exporter (); + use vars qw(@EXPORT @EXPORT_OK %EXPORT_TAGS); + @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() funtion is a simple front-end that forwards a numeric +argument to getnetbyaddr(), and the rest +to getnetbyname(). + +To access this functionality without the core overrides, +pass the C<use> an empty import list, and then access +function functions with their full qualified names. +On the other hand, the built-ins are still available +via the C<CORE::> pseudo-package. + +=head1 EXAMPLES + +The getnet() functions do this in the Perl core: + + sv_setiv(sv, (I32)nent->n_net); + +The gethost() functions do this in the Perl core: + + sv_setpvn(sv, hent->h_addr, len); + +That means that the address comes back in binary for the +host functions, and as a regular perl integer for the net ones. +This seems a bug, but here's how to deal with it: + + use strict; + use Socket; + use Net::netent; + + @ARGV = ('loopback') unless @ARGV; + + my($n, $net); + + for $net ( @ARGV ) { + + unless ($n = getnetbyname($net)) { + warn "$0: no such net: $net\n"; + next; + } + + printf "\n%s is %s%s\n", + $net, + lc($n->name) eq lc($net) ? "" : "*really* ", + $n->name; + + print "\taliases are ", join(", ", @{$n->aliases}), "\n" + if @{$n->aliases}; + + # this is stupid; first, why is this not in binary? + # second, why am i going through these convolutions + # to make it looks right + { + my @a = unpack("C4", pack("N", $n->net)); + shift @a while @a && $a[0] == 0; + printf "\taddr is %s [%d.%d.%d.%d]\n", $n->net, @a; + } + + if ($n = getnetbyaddr($n->net)) { + if (lc($n->name) ne lc($net)) { + printf "\tThat addr reverses to net %s!\n", $n->name; + $net = $n->name; + redo; + } + } + } + +=head1 NOTE + +While this class is currently implemented using the Class::Struct +module to build a struct-like class, you shouldn't rely upon this. + +=head1 AUTHOR + +Tom Christiansen diff --git a/contrib/perl5/lib/Net/protoent.pm b/contrib/perl5/lib/Net/protoent.pm new file mode 100644 index 0000000..737ff5a --- /dev/null +++ b/contrib/perl5/lib/Net/protoent.pm @@ -0,0 +1,94 @@ +package Net::protoent; +use strict; + +BEGIN { + use Exporter (); + use vars qw(@EXPORT @EXPORT_OK %EXPORT_TAGS); + @EXPORT = qw(getprotobyname getprotobynumber getprotoent); + @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 diff --git a/contrib/perl5/lib/Net/servent.pm b/contrib/perl5/lib/Net/servent.pm new file mode 100644 index 0000000..fb85dd0 --- /dev/null +++ b/contrib/perl5/lib/Net/servent.pm @@ -0,0 +1,111 @@ +package Net::servent; +use strict; + +BEGIN { + use Exporter (); + use vars qw(@EXPORT @EXPORT_OK %EXPORT_TAGS); + @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<n_>. 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 |
