"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tlperl/lib/Net/netent.pm" (10 Mar 2019, 4515 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    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