lib/Net/netent.pm

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