diff options
Diffstat (limited to 'contrib/perl5/lib/Net')
| -rw-r--r-- | contrib/perl5/lib/Net/Ping.pm | 559 | ||||
| -rw-r--r-- | contrib/perl5/lib/Net/hostent.pm | 150 | ||||
| -rw-r--r-- | contrib/perl5/lib/Net/netent.pm | 168 | ||||
| -rw-r--r-- | contrib/perl5/lib/Net/protoent.pm | 96 | ||||
| -rw-r--r-- | contrib/perl5/lib/Net/servent.pm | 112 |
5 files changed, 0 insertions, 1085 deletions
diff --git a/contrib/perl5/lib/Net/Ping.pm b/contrib/perl5/lib/Net/Ping.pm deleted file mode 100644 index a2846fe..0000000 --- a/contrib/perl5/lib/Net/Ping.pm +++ /dev/null @@ -1,559 +0,0 @@ -package Net::Ping; - -# Author: mose@ccsn.edu (Russell Mosemann) -# -# Authors of the original pingecho(): -# karrer@bernina.ethz.ch (Andreas Karrer) -# Paul.Marquess@btinternet.com (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. - -use 5.005_64; -require Exporter; - -use strict; -our(@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 = int($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)) << 8) 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) - or last; # For example an unreachable host will make recv() fail. - ($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. The "udp" protocol is the default. Note that a live remote host -may still fail to be pingable by one or more of these protocols. For -example, www.microsoft.com is generally alive but not pingable. - -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. - -It should be borne in mind that, for both tcp and udp ping, a host -will be reported as unreachable if it is not running the -appropriate echo service. For Unix-like systems see L<inetd(8)> for -more information. - -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 deleted file mode 100644 index 6cfde72..0000000 --- a/contrib/perl5/lib/Net/hostent.pm +++ /dev/null @@ -1,150 +0,0 @@ -package Net::hostent; -use strict; - -use 5.005_64; -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::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() 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 diff --git a/contrib/perl5/lib/Net/netent.pm b/contrib/perl5/lib/Net/netent.pm deleted file mode 100644 index b21cd04..0000000 --- a/contrib/perl5/lib/Net/netent.pm +++ /dev/null @@ -1,168 +0,0 @@ -package Net::netent; -use strict; - -use 5.005_64; -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 diff --git a/contrib/perl5/lib/Net/protoent.pm b/contrib/perl5/lib/Net/protoent.pm deleted file mode 100644 index 00a76af..0000000 --- a/contrib/perl5/lib/Net/protoent.pm +++ /dev/null @@ -1,96 +0,0 @@ -package Net::protoent; -use strict; - -use 5.005_64; -our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); -BEGIN { - use Exporter (); - @EXPORT = qw(getprotobyname getprotobynumber getprotoent); - @EXPORT_OK = qw( $p_name @p_aliases $p_proto getproto ); - %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(). -This function is not exported by default. - -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 deleted file mode 100644 index c892af0..0000000 --- a/contrib/perl5/lib/Net/servent.pm +++ /dev/null @@ -1,112 +0,0 @@ -package Net::servent; -use strict; - -use 5.005_64; -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<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 |
