lib/Net/netent.pm

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