lib/Net/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
Revision:	1.1
Committed:	Thu Jun 30 14:27:14 2005 UTC (21 years, 4 months ago) by root
Branch:	MAIN
CVS Tags:	PERL-5-8-7, HEAD
Branch point for:	PERL
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	package Net::netent;
2			use strict;
3
4			use 5.006_001;
5			our $VERSION = '1.00';
6			our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
7			BEGIN {
8			use Exporter ();
9			@EXPORT = qw(getnetbyname getnetbyaddr getnet);
10			@EXPORT_OK = qw(
11			$n_name @n_aliases
12			$n_addrtype $n_net
13			);
14			%EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] );
15			}
16			use vars @EXPORT_OK;
17
18			# Class::Struct forbids use of @ISA
19			sub import { goto &Exporter::import }
20
21			use Class::Struct qw(struct);
22			struct 'Net::netent' => [
23			name => '$',
24			aliases => '@',
25			addrtype => '$',
26			net => '$',
27			];
28
29			sub populate (@) {
30			return unless @_;
31			my $nob = new();
32			$n_name = $nob->[0] = $_[0];
33			@n_aliases = @{ $nob->[1] } = split ' ', $_[1];
34			$n_addrtype = $nob->[2] = $_[2];
35			$n_net = $nob->[3] = $_[3];
36			return $nob;
37			}
38
39			sub getnetbyname ($) { populate(CORE::getnetbyname(shift)) }
40
41			sub getnetbyaddr ($;$) {
42			my ($net, $addrtype);
43			$net = shift;
44			require Socket if @_;
45			$addrtype = @_ ? shift : Socket::AF_INET();
46			populate(CORE::getnetbyaddr($net, $addrtype))
47			}
48
49			sub getnet($) {
50			if ($_[0] =~ /^\d+(?:\.\d+(?:\.\d+(?:\.\d+)?)?)?$/) {
51			require Socket;
52			&getnetbyaddr(Socket::inet_aton(shift));
53			} else {
54			&getnetbyname;
55			}
56			}
57
58			1;
59			__END__
60
61			=head1 NAME
62
63			Net::netent - by-name interface to Perl's built-in getnet*() functions
64
65			=head1 SYNOPSIS
66
67			use Net::netent qw(:FIELDS);
68			getnetbyname("loopback") or die "bad net";
69			printf "%s is %08X\n", $n_name, $n_net;
70
71			use Net::netent;
72
73			$n = getnetbyname("loopback") or die "bad net";
74			{ # there's gotta be a better way, eh?
75			@bytes = unpack("C4", pack("N", $n->net));
76			shift @bytes while @bytes && $bytes[0] == 0;
77			}
78			printf "%s is %08X [%d.%d.%d.%d]\n", $n->name, $n->net, @bytes;
79
80			=head1 DESCRIPTION
81
82			This module's default exports override the core getnetbyname() and
83			getnetbyaddr() functions, replacing them with versions that return
84			"Net::netent" objects. This object has methods that return the similarly
85			named structure field name from the C's netent structure from F<netdb.h>;
86			namely name, aliases, addrtype, and net. The aliases
87			method returns an array reference, the rest scalars.
88
89			You may also import all the structure fields directly into your namespace
90			as regular variables using the :FIELDS import tag. (Note that this still
91			overrides your core functions.) Access these fields as variables named
92			with a preceding C<n_>. Thus, C<$net_obj-E<gt>name()> corresponds to
93			$n_name if you import the fields. Array references are available as
94			regular array variables, so for example C<@{ $net_obj-E<gt>aliases()
95			}> would be simply @n_aliases.
96
97			The getnet() function is a simple front-end that forwards a numeric
98			argument to getnetbyaddr(), and the rest
99			to getnetbyname().
100
101			To access this functionality without the core overrides,
102			pass the C<use> an empty import list, and then access
103			function functions with their full qualified names.
104			On the other hand, the built-ins are still available
105			via the C<CORE::> pseudo-package.
106
107			=head1 EXAMPLES
108
109			The getnet() functions do this in the Perl core:
110
111			sv_setiv(sv, (I32)nent->n_net);
112
113			The gethost() functions do this in the Perl core:
114
115			sv_setpvn(sv, hent->h_addr, len);
116
117			That means that the address comes back in binary for the
118			host functions, and as a regular perl integer for the net ones.
119			This seems a bug, but here's how to deal with it:
120
121			use strict;
122			use Socket;
123			use Net::netent;
124
125			@ARGV = ('loopback') unless @ARGV;
126
127			my($n, $net);
128
129			for $net ( @ARGV ) {
130
131			unless ($n = getnetbyname($net)) {
132			warn "$0: no such net: $net\n";
133			next;
134			}
135
136			printf "\n%s is %s%s\n",
137			$net,
138			lc($n->name) eq lc($net) ? "" : "really ",
139			$n->name;
140
141			print "\taliases are ", join(", ", @{$n->aliases}), "\n"
142			if @{$n->aliases};
143
144			# this is stupid; first, why is this not in binary?
145			# second, why am i going through these convolutions
146			# to make it looks right
147			{
148			my @a = unpack("C4", pack("N", $n->net));
149			shift @a while @a && $a[0] == 0;
150			printf "\taddr is %s [%d.%d.%d.%d]\n", $n->net, @a;
151			}
152
153			if ($n = getnetbyaddr($n->net)) {
154			if (lc($n->name) ne lc($net)) {
155			printf "\tThat addr reverses to net %s!\n", $n->name;
156			$net = $n->name;
157			redo;
158			}
159			}
160			}
161
162			=head1 NOTE
163
164			While this class is currently implemented using the Class::Struct
165			module to build a struct-like class, you shouldn't rely upon this.
166
167			=head1 AUTHOR
168
169			Tom Christiansen