#!/usr/bin/perl
#
# build_codes.pl
# version 1.01 5-7-02, Michael@bizsystems.com
#
# This software is copyright and GPL'd. See the notice in the
# README file for details
#
#  DO NOT RUN THIS SCRIPT IN THIS DIRECTORY
#  IT IS RUN AUTOMATICALLY BY Makefile.PL

die q|DO NOT RUN THIS SCRIPT MANUALLY, IT
IS RUN AUTOMATICALLY BY 'make'
| unless &{$_=sub{(caller)[1]}} eq 'IANA/build_codes.pl';

die "Could not find IANA/protocols"
	unless open(P,'IANA/protocols');

unless (open(I,'IANA/icmp')) {
  close P;
  die "Could not find IANA/icmp";
}

unless (open(C,'>Codes.pm')) {
  close P;
  close I;
  die "Could not create Codes.pm";
}

my $date = scalar localtime(time);

print "Building module 'Codes.pm'\n";

print C <<EOF;
#
# DO NOT EDIT THIS FILE, CHANGES WILL BE LOST
#
# Created by Makefile.PL 
# (IANA/build_codes.pl)
# from	IANA/protocols
# and	IANA/icmp
# $date
#
EOF

print C <<'EOF';
package LaBrea::Codes;
use strict;
use vars qw($VERSION @ISA @EXPORT_OK %prot %pnum %icmp %inum );

$VERSION = do { my @r = (q$Revision: 0.01 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };

require Exporter;
@ISA = qw(Exporter);
@EXPORT_OK = qw(
	protocol
	icmp
);

=head1 NAME

  LaBrea::Tarpit::Codes

=head1 SYNOPSIS

  use LaBrea::Tarpit::Codes qw (
	protocol
	icmp
	numeric
  );

  $text	  = protocol(number);
  $number = protocol(text);
  $text   = icmp(number);
  $number = icmp(text);
  $rv	  = numeric(scalar);

=head1 DESCRIPTION

This module is built by B<Makefile.PL> from the text files 
in the IANA subdirectory (copied from the IANA web site).

Do not edit the Codes.pm file, changes will be lost.

=over 4

=item $rv = protocol($x);

  Returns the upper case text name of a protocol
  number or the protocol number of a text name.

  i.e.  'TCP' = protocol(6);
	  6   = protocol('Tcp');
	  (not case sensitive)

  return -1 or 'unknown' if lookup value 
  is not present in table

=cut
  
sub protocol { 
    if (numeric($_[0])) {	# seeking numeric
	my $v = uc $_[0];
	return (exists $pnum{$v}) ? $pnum{$v} : -1;
    } else {			# seeking text
	return (exists $prot{$_[0]}) ? $prot{$_[0]} : 'unknown';
    }
}

=item $rv = icmp($x);

  Returns the upper case text name of an icmp
  number or the icmp number of the text name.

  i.e.	'ECHO' = icmp(8);
	   8   = icmp('EcHo');
	   (not case sensitive)

  return -1 or 'unknown' if lookup value 
  is not present in table

=cut

sub icmp {
    if (numeric($_[0])) {	# seeking numeric
	my $v = uc $_[0];
	return (exists $inum{$v}) ? $inum{$v} : -1;
    } else {			# seeking text
	return (exists $icmp{$_[0]}) ? $icmp{$_[0]} : 'unknown';
    }
}

=item $rv = numeric(scalar);

  Return true if the scalar is a number 
  0,-n,+n
    else
  returns false

=back

=cut

sub numeric {
  return ($_[0] =~ /[^\d\-]/) ? 1:0;
}

%prot = (
EOF

# make protocol hash

my $off = 2;
while (<P>) {
  chop;
  if (	$_ !~ /IANA\]$/ &&
	$_ =~ /\s+(\d+)\s+([^\s]+)\s+(.*)/ ) {
    my $line = qq|\t$1\t=> '| . (uc $2) ."',";
    $line .= "\t" if length($2) < $off;
    $line .= "\t# $3\n";
    print C $line;
  } else {
    print C "#\t$_\n";
  }
}
close P;
print C <<'EOF';
);
%pnum = reverse %prot;
%icmp = (
EOF

# make ICMP hash

while (<I>) {
  chop;
  if (	$_ =~ /\[RFC\d+\]$/ &&  
	$_ =~ /\s+(\d+)\s+(.*)/ ) {
    @_ = split('\s\s+',$2);
    my $line = qq|\t$1\t=> '| . (uc $_[0]) . q|',|;
    $_ = length($_[0]);
    if ( $_ < $off ) {
	$line .= "\t\t\t\t";
    } elsif ( $_ < $off +8 ) {
	$line .= "\t\t\t";
    } elsif ( $_ < $off +16 ) {
	$line .= "\t\t";
    } elsif ( $_ < $off +24 ) {
	$line .= "\t";
    }
    $line .= "\t# $_[1]\n";
    print C $line;
  } else {
    print C "#\t$_\n";
  }
}
close I;

print C <<'EOF';
);
%inum = reverse %icmp;

1;
__END__

=head1 EXPORT

  None by default.

=head1 COPYRIGHT

Copyright 2002, Michael Robinton & BizSystems
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or 
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of 
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the  
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

=head1 AUTHOR

Michael Robinton, michael@bizsystems.com

=head1 SEE ALSO

perl(1), LaBrea::Tarpit(3), LaBrea::Tarpit::Get(3), LaBrea::Tarpit::Report(3),
LaBrea::Tarpit::Util(3), LaBrea::Tarpit::DShield(3)

EOF

close C;