lib/Net/netent.pm

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