#!/usr/local/bin/perl

use Config;
use File::Basename qw(basename dirname);
use Cwd;

# List explicitly here the variables you want Configure to
# generate.  Metaconfig only looks for shell variables, so you
# have to mention them as if they were shell variables, not
# %Config entries.  Thus you write
#  $startperl
# to ensure Configure will look for $Config{startperl}.
# Wanted:  $archlibexp

# This forces PL files to create target in same directory as PL file.
# This is so that make depend always knows where to find PL derivatives.
$origdir = cwd;
chdir dirname($0);
$file = basename($0, '.PL');
$file .= '.com' if $^O eq 'VMS';
$newname = ($ARGV[0]) ? $ARGV[0] : $file;

# Check, should it be private version
my $private = (-f '/ncc/registries/zz.example') ? 1 : 0;

open OUT,">$file" or die "Can't create $file: $!";

print "Extracting $file (with variable substitutions)\n";

# In this section, perl variables will be expanded during extraction.
# You can use $Config{...} to use Configure variables.

# Put into the file perl executable path
print OUT $Config{startperl};
# For public version add blib to included paths
print OUT " -Iblib/lib" unless($private);
print OUT "\n";

print OUT <<"!GROK!THIS!";
    eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
	if \$running_under_some_shell;

# Copyright (c) 1998,1999,2000,2001,2002			RIPE NCC
#
# All Rights Reserved
#
# Permission to use, copy, modify, and distribute this software and its
# documentation for any purpose and without fee is hereby granted,
# provided that the above copyright notice appear in all copies and that
# both that copyright notice and this permission notice appear in
# supporting documentation, and that the name of the author not be
# used in advertising or publicity pertaining to distribution of the
# software without specific, written prior permission.
#
# THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
# ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS; IN NO EVENT SHALL
# AUTHOR BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY
# DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN
# AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
#------------------------------------------------------------------------------
# Module Header
# Filename          : asused.pl
# Purpose           : Check Allocation, Assignments, in reg and RIPE Whois DB
#                     functional replacement for other existing tools
# Author            : Antony Antony <antony\@ripe.net>
#		      Timur Bakeyev <timur\@ripe.net>
# Date              : 199901, 200001
# Description       :  
# Language Version  : Perl 5.00404, 5.00502 & 5.6.0
# OSs Tested        : BSDI 3.1 
# Command Line      : See asused3 --help
# Input Files       : reg files red using perl module regread
# Output Files      : -
# External Programs : -
# Comments          : access to RIPE Whois database 2.1 or compaitable        
#------------------------------------------------------------------------------
use strict;
# Global Variables
use vars qw(\$VERSION \$DEBUG \$PRIVATE);
# Command line options
use vars qw(%opt);

# Is this RIPE NCC private version
\$PRIVATE = $private;
!GROK!THIS!

# In the following, perl variables are not expanded during extraction.
print OUT <<'!NO!SUBS!';

# Program version
$VERSION = '3.72';

# Give extra debugging information
$DEBUG = 0;

use Getopt::Long;
use Carp;
# RIPE NCC Site Modules
use ipv4pack; # ip address manipulation
# connect to RIPE whois server
use RipeWhois; 
# get inetnum using -F 
use Net::RIPEWhois::in qw($INVALID_DATE $MULTIPLE_INETNUM); 
# module which does most of the asused.
# this script is calls these modules and print output
use Reg::Asused;
# This modules are not used in public version
if($PRIVATE) {
    # Use private modules    
    # read reg data 
    eval('use regread;');
    die("Module: $@") if($@);
    # to lookup registry name from ip range.
    eval('use ip2reg;');
    die("Module: $@") if($@);
    # checking Approval of read reg data for asused
    eval('use Reg::Approved;');
    die("Module: $@") if($@);
    # For network approval
    eval('use Reg::ApproveNa qw($NO_REGID_FOUND $REGID_MISMATCH);');
    die("Module: $@") if($@);
}

# Location of the configuration files
my $configFile = '/usr/local/etc/asused.conf';
# That should be in $HOME
my $rcFile = '.asusedrc';

my $NO_ALLOC_INDB 	= 201;   # no allocation found in DB
my $NO_ALLOC_INREG	= 217;   # no allocation to be checked by asused 

my $NO_REGID_FOUND	= 218; 
my $REGID_MISMATCH	= 219;

# MAIN
    # Get allocated prefixes and initialize internal data
    my $prefix = initAsused(\%opt);
    # This is to validate a network or inetnum with --valid
    if($opt{'valid'}) {
	# Do the network approval
        my $whois = new RipeWhois('Host' => $opt{'host'},
				  'Port' => $opt{'port'},
				  'KeepAlive' => 1,
				  'FormatMode' => 1);

	$whois || FatalError("Failed to create RipeWhois object!");

	my $ana = new Reg::ApproveNa('Whois' => $whois, 'Regid' => $opt{'regid'})
		|| FatalError("Failed to create ApproveNa object!");
	# Approve netname
        my($network, $ret) = $ana->approveNa($opt{'valid'});
	# Check errors
	my($errNo, $errStr) = $ana->error();
	# Exit if there are errors
	FatalError($errStr, $errNo) if($errNo);
	# Print results of approval
        print $ret;
    }
    # we really don't care about validity of regid - doit() will check it

    # if it was a prefix...
    elsif ($prefix) {
        my $range;       
        #if no regid on command line try to get it from i2r
        unless($opt{'regid'}) {
            my($err, $update);
	    # To map IP range to regid
	    my $i2r = new ip2reg;
            
            ($err, $update, $opt{'regid'}) = $i2r->getRegName($prefix->{'list'}[0], 1);
            if($err) {
                # on error getting regid terminate the script
                FatalError(sprintf("%s %s %s", $err, $prefix->{'list'}[0], $update));
            }
        }
        # Have regid 
        # proced with ranges
        process($opt{'regid'}, %{$prefix}); # rest of the work done in this function
    }
    # with regid as command line option
    else {
        foreach my $regid (@ARGV) {
            process($regid); # rest of the work done in this function          
        }     
    }
    exit 0; # on success;

# MAINEND

#------------------------------------------------------------------------------
# Purpose           : process with regid or prefix 
# Side Effects      : 
# Comments          : still, I think, it's better to check regid directly...
# IN                : scalar regid, hash of prefixes 
# OUT               : return undef on sucess, exit with exit code on errors

sub process {
    my($regid,    # regid
       %regAlloc  # hash of prefix to query  
       ) = @_;
    
    
    # if $regid is invalid - don't bother to deal with it
    if($PRIVATE) {
	local($^W) = 0; # Bad hack around not safe regread
	FatalError("No such registry $regid", $NO_REGID_FOUND)
	    unless($regid && readreg($regid));
    }

    # Create all necessary objects
    # Object to deal with whois server
    my $whois = new RipeWhois('Host' => $opt{'host'},
			      'Port' => $opt{'port'},
			      'KeepAlive' => 1,
			      'FormatMode' => 1);
    
    $whois || FatalError("Failed to create RipeWhois object!");
    # Objects to store i-num objects form whois DB
    my $alloc = new Net::RIPEWhois::in('Whois' => $whois) 
	    || FatalError("Failed to create Allocations object!");
    my $assign = new Net::RIPEWhois::in('Whois' => $whois) 
    	    || FatalError("Failed to create Assignments object!");
    # Object to store internal asused data
    my $asu = new Reg::Asused('Whois' => $whois)
	    || FatalError("Failed to create Asused object!");
    
    # Returned error
    my($errNo, $errStr);
    
    # Set regid as netname
    $alloc->validNa($regid);  
    
    # XXX: Only for private version
    ###########################################################################
    my $app;

    if($PRIVATE) {
	# read reg file
	$app = new Reg::Approved('Whois' => $whois, 'Regid' => $regid)
		|| FatalError("Failed to create Approved object!", $REGID_MISMATCH);
	
	# if we didn't get get allocations with the call...
	%regAlloc = $app->getRegAllocs() unless(%regAlloc);
	
	# check any allocations found in reg
	FatalError("No allocations from reg", $NO_ALLOC_INREG) unless(%regAlloc);
	# print data from reg files
	$app->pRegData();
	# check any allocations found in reg
	FatalError("No allocations from reg", $NO_ALLOC_INREG) unless(@{$regAlloc{'list'}});
    }
    ###########################################################################

    # Get Allocations from whois
    ($errNo, $errStr) = $asu->getDBAlloc($alloc, \%regAlloc);

    # Exit, if getDBAlloc failed
    FatalError($errStr, $errNo) if(defined($errNo));

    # Exit, if nothing was found in whois DB 
    FatalError("No objects were found in whois DB!", $NO_ALLOC_INDB) unless(@{$alloc->{'dbAlloc'}});
    
    # Get Assignments from whois DB
    ($errNo, $errStr) = $asu->getAssign($alloc, $assign); 

    # Exit, if getAssign failed
    FatalError($errStr, $errNo) if(defined($errNo)); # exit with error 

    # Print no of allocations to process
    pAllocData($alloc, \%regAlloc);

    # Print summary of alloations & assignments
    pAllocResults($alloc, $asu);

    # Print information about overlaps
    pOverlap($alloc, $asu) if($opt{'overlap'});
    
    # Print assignments details
    if($opt{'status'} || $opt{'assign'} || $opt{'free'}) {
	pStatus($alloc, $asu);
    }
    
    # XXX: Only for private version
    ###########################################################################
    if($PRIVATE) {
	my $output = '';
	# if assignments has invalid date stop approval check
	if($opt{'aw'} || $opt{'approval'}) {
	    FatalError("Assignments have invalid dates. Can\'t proceed with --aw or --approval", $INVALID_DATE)
		if($asu->{'invaliddate'});
	    # --aw | approval
    	    $output .= $app->doApproval($assign);
	}
	$output .= $app->doSubAllocs($assign);
	if($app->{'warning'}) {
	    print "There are WARNINGS:\n";
	    foreach my $warn (@{$app->{'warning'}}) {
		print "\t$warn";
	    }
	    print "\n";
	}
	print $output;
    }
    ###########################################################################

    return; # on success
}

#------------------------------------------------------------------------------
# Purpose           :  Parse command line and init internal structures
# Side Effects      : 
# Comments          : 
# IN                : 
# OUT               : 

sub initAsused {
    my($opt) = @_;
    
    my $prefix;
    
    $| = 1; # Flush output immediately after printing

    # Debug flag
    $DEBUG = $ENV{'DEBUG_ASUSED'} if(defined($ENV{'DEBUG_ASUSED'}));

    # Read and check command line options
    initOptions($opt);

    # Get allocated prefixes
    if($PRIVATE) {
	# Some arguments were left
	if(@ARGV) {
	    # Conver everything to one string
	    my $args = join(' ', @ARGV);
	    # put back replaced '-'
	    $args =~ s/#-#/-/g;
	    
	    if($opt{'valid'}) {
		# put back taken by --valid argument
		$args = "$opt{'valid'} $args";
		# Try to extract range o prefix from the $args
		if($args =~ /^\s*((?:\d+(?:\.\d+){3}\s*-\s*\d+(?:\.\d+){3})|(?:\d+(?:\.\d+){0,3}(?:\/\d+)?))\s*(.*)$/) {
		    # If there is something left - complain
		    if($2) {
			print "ERROR: Extra parameters '$2' passed to --valid\n";
			printUsage();
		    }
		    # Save extracted range/prefix
		    $opt{'valid'} = $1;
		}
		else {
		    print "ERROR: Parameters '$args' to --valid are not range/prefix\n";
		    printUsage();
		}
		return; # exit
	    }
	    
	    # In all othe cases we expect to get regid or range/prefix
	    # Look if $ARGV[0] is regid or not 
	    if(defined($ARGV[0]) && ($ARGV[0] =~ /^[a-z][a-z]\.\S+$/)) {
    		# if first argument is regid rest should also be
    		my @not_regid = grep { !/^[a-z][a-z]\.\S+$/ } @ARGV;
		
		if(@not_regid) {
		    print "ERROR: Not regid(s) '", join(' ', @not_regid), "'\n";
		    printUsage();
    		}
		return; # exit
	    }
	    # $ARGV[0] is not reg, it may be an IP range.
	    else {
		# hash of allocations
		my %allocs;
		
    		while ($args =~ /(?:^|\s+)(\d+(?:\.\d+){3}\s*-\s*\d+(?:\.\d+){3})|(\d+(?:\.\d+){0,3}(?:\/\d+)?)/g) {
		    # Keep results. Only one of the values is defined
		    my($rng, $pfx) = ($1, $2);
		    
		    # Convert range to prefix
		    if($rng) {
			# Normalize range
			my($range, $err) = normalizerange($rng);
			if($err != $O_OK) {
			    FatalError("Invalid IP range '$rng', error $err", $err);
			}
			my @prefixes = range2prefixes($range);
			$pfx = shift(@prefixes) if(@prefixes);
		    }
		    # if we have defined prefix store it
        	    $allocs{$pfx}{'reg'} = $pfx if($pfx);
    		} 
    		
		# If any allocation were found, store them
		if(%allocs) {
		    $allocs{'list'} = [keys(%allocs)];
		}
		else {
        	    # no valid input
		    print "ERROR: invalid parameters '$args'\n";
		    printUsage();
		}
	    # Keep reference to hash with registry allocations
	    $prefix = \%allocs;
    	    } # not regid
	} # @ARGV
	elsif(!$opt{'valid'}) {
	    print "ERROR: should specify regid or range\n";
	    printUsage();
	} # No @ARGV
    } # $PRIVATE
    else {
	$prefix = readConfig();
    }
    
    return $prefix;
}

#------------------------------------------------------------------------------
# Purpose           : Reads config file(s)
# Side Effects      : Sets up external global variables $REGID and @ALLOC
# Comments          : Expects to find config file on a location:
#			specified on a command line;
#			in a current directory($configFile);
#			in a $HOME/$rcFile;
#		      This is for useonly with public version
# IN                : None
# OUT               : Reference to the hash of prefixes

sub readConfig {
    # List of possible config files
    my @config;		
    # We prefer config file, supplied in a command line
    push(@config, $opt{'config'}) if(defined($opt{'config'}));
    # If there is a config in a current directory, pick it
    push(@config, $configFile);
    # As a last resort, check config in a user's home dir
    push(@config, "$ENV{'HOME'}/$rcFile") if(defined($ENV{'HOME'}));
    
    # We use first available config file
    foreach my $file (@config) {
	if(open(CONF, $file)) {
	    my $name;	# Config variable 
	    my $value;	# Config value
	    my %prefix; # List of all allocations for the registry
	    
	    while(<CONF>) {
		 chomp;                  # no newline
		 s/#.*//;                # no comments
		 s/^\s+//;               # no leading white
		 s/\s+$//;               # no trailing white
		 next unless length;     # anything left?
	    
		if(($name, $value)=m%(\w+)\s*=\s*(.+)%) {
		    # Take RegID
		    if($name eq 'REGID') {
			# Inject regid to the command arguments list
			$opt{'regid'} = $value if($value);
		    }
		    # Collect all allocation lines
		    elsif($name eq 'ALLOC') {
			# Keep allocations
			$prefix{$value}{'reg'} = $value if($value);
		    }
		    # What is this?
		    else {
			FatalError("$file: $.: Unrecognized pair \"$name=$value\"");
		    }
		}
		# What is this?
		else {
		    FatalError("$file: $.: Unrecognized line \"$_\"");
		}
	    }
	    close(CONF);
	    # We didn't find RegID in the config
	    FatalError("There is no 'REGID' line in the config file '$file'") unless($opt{'regid'});
	    # We didn't find Allocation(s) in the config
	    FatalError("There is no 'ALLOC' line(s) in the config file '$file'") unless(%prefix);
	    # Keep the list of all allocations
            $prefix{'list'} = [sort(keys(%prefix))] if(%prefix);
	    # Everything is ok, return reference to the hash of prefixes
	    return(\%prefix);
	}
    }
    # We scaned all possible config locations but didn't find anything
    FatalError("No config file was found! Please, supply one!");
}

#-----------------------------------------------------------------------------
# Purpose           : Initialise command line options
# Side Effects      : 
# Comments          : 
# in                : hash of command line switches %opt
# out               : hash of prefixes from argv or undef

sub initOptions { 
    my($opt) = @_; 		# hash of command line switches

    printf("Output from %s() function\n", (caller(0))[3]) if($DEBUG);

    # Command line options
    my @options = (
	'host=s',	# Hostname of the whois server
	'port=s',	# Port name of the whois server
	
	'assign',	# List all assignments and free addresses
	'free',		# List of free address space only
	'status',	# List broken assignments
	'pipa',		# Give extended PA/PI status
	'infra',	# Show infrastructual assignments
	'cidr',		# Express assignment size in CIDR
	
	'overlap',	# List overlaps
	'summary',	# Give only summary, instead of full list
	'all',		# List overlaps and status
	
	'debug',	# Debug mode TBD
	
	'config=s',	# Alternative config file
	'version',	# Program version
	'help'		# Help screen
	);

    # Add several flags for the private version of the program
    if($PRIVATE) {
	# regid  
	push(@options, 'regid=s');
	# invalid nw
	push(@options, 'aw');
	# invalid & invalid nw
	push(@options, 'approval');
	# for testing dump the event table of approval
	push(@options, 'na=s');
	# netname or range
	push(@options, 'valid=s');
    }
    
    # Get the command line switches
    printUsage() unless(@ARGV);
    # Convert any standalone '-' into '#-#'
    # XXX: A hack to prevent treating standalone '-' as a parameter
    map { s/^-$/#-#/; } @ARGV;
    
    # Read options
    printUsage() unless(GetOptions($opt, @options));
    # Let us start with help;
    printUsage() if($opt{'help'});

    # Print version
    if($opt->{'version'}) {
        print "Version $VERSION\n";
        exit 0;
    }
    
    # Validate the switchs
    optConflicts($opt);

    # all is synonym for --overlap --status --aw
    # summary treated same as all & status don't print details
    if($opt->{'all'} || $opt->{'summary'}) {
        $opt->{'status'} = 1;
        $opt->{'overlap'} = 1;
    }

    $opt->{'aw'} = 1 if($opt->{'all'} && $PRIVATE);

    $opt->{'assign'} = 1 if(defined($opt->{'pipa'}));
    $opt->{'free'} = 1 if(defined($opt->{'assign'}));
    
}
#-----------------------------------------------------------------------------
# Purpose           : check option conflicts
# Side Effects      : 
# Comments          : 
# in                : undef
# out               : on sucess return undef on error print  usage  & exit.

#Option dependency and conflict matrix
#1 when the switch is set to one
#0 Conflict
#x don't care
#- one of them should be present.
#--help take the highest priority
#host and port has no dependecies


#please read this part of the code with more than 120 chars witdh.

#         all approval assign  aw column overlap  regid size  sum status valid 
#all       1      0      0      0   0       0      x     x     0     0      0  
#approval         1      x      0   0       x      x     x     0     x      0  
#assign                  1      x   0       x      x     x     0     0      0  
#aw                             1   0       x      x     x     0     x      0  
#column                             1       0      0     0     0     0      0  
#overlap                                    1      x     x     0     x      0  
#regid                                             1     x     x     x      x  
#size                                                    1     x     -      0  
#summary                                                       1     0      0  
#status                                                              1      0  
#valid                                                                      1  

#na  no conflict.                                                         

sub optConflicts {
    my($opt) = @_;  #command line options hash 
    my %optConflict = ( 'all'     => ['assign',  'approval', 'aw', 'overlap',
				      'size', 'summary','status', 'valid'],
                        'approval'=> ['aw', 'column', 'summary', 'valid'],
                        'assign'  => ['column', 'status', 'summary', 'valid'],
			'free'	  => ['contacts','valid'],
                        'aw'      => ['column','summary', 'valid'],
                        'overlap' => ['summary', 'valid'],
                        'regid'   => [''],
			'cidr'    => [''],
                        'size'    => ['valid'],
                        'summary' => ['status'],
                        'status'  => ['valid', 'pipa'],
                        'contacts'=> ['duplicates'],
			'pipa'    => ['status', 'infra'],
			'infra'   => ['status', 'pipa'],
                );
    
    my $errStr; # Error msg
    foreach my $option (sort(keys(%{$opt}))) {
        foreach my $invalidOpt (@{$optConflict{$option}}) {
            if($opt{$invalidOpt}) {
               $errStr .=  "ERROR: Invalid options combination $option and $invalidOpt\n";
	    }
	}
    }
    
    if($errStr) { 
        print "\n$errStr\n";
        printUsage();
    }
    return;  
}

#------------------------------------------------------------------------------
# Purpose           : function to gracefully terminate the program 
# Side Effects      : 
# Comments          :
# IN                : exit code, exit message
# OUT               : script exit's from this sub.

sub FatalError {

    my($message,	# Error message
       $exitcode	# Exit code, if any..
       ) = @_;
    
    print STDERR "FATAL: $message\n\n" if($message);
    $!= $exitcode if($exitcode);
    
    exit($exitcode || 255);
}

#-----------------------------------------------------------------------------
# Purpose           : print usage and exit the program exit 1
# Side Effects      : 
# Comments          : checks only option conflicts
# in                : 
# out               : on sucess return undef on error printing the usage exit.

sub printUsage {
    # Get executable filename
    my $program = $0;
    # Strip down directory component
    $program =~ s%.*/(.+)%$1%;
    
    if($PRIVATE) {
	print <<PRIV;
 Usage: $program

 $program [--all] [--aw | --approval] [--overlap] [--status | --assign [--pipa|--infra]] regid
 $program [--all] [--overlap] [--free] [--regid regid] [--status | --assign [--pipa|--infra]] (range..)
 $program [--regid regid] [--valid] range | netname
 
 regid  is a registry ID as in reg database.
 range is a network range in a form A.B.C.D/nn or A.B.C.D - W.X.Y.Z
PRIV
    }
    else {
	print <<PUB;
 Usage: $program

 $program [--all] [--overlap] [--status | --assign [--pipa|--infra]]
PUB
    }

    print <<USAGE;

    Where options are:
    
    --host host	      Specify alternative whois server, if not whois.ripe.net
    --port port	      Specify alternative whois port number, if not 43
    
    --assign	      List all assignments and does --free
    --free	      List free address space
    --status	      List assignments with invalid status only
    --pipa	      In addition show PI/PA status
    --infra	      In addition show infrastructure assignments
    --cidr            Show assignment size in CIDR notation   
    
    --overlap	      List overlaps in assignments
    
    --summary	      Show overlapping and status summary
USAGE

    if($PRIVATE) {
	print <<PRIV;
    --all	      Show combination of -aw, --overlap and --status
    
    --regid	      Specify regid, if it can not be guessed
    
    --aw	      Validate networks in allocations and print invalid
    --approval	      Validate networks in allocations and print all of them
    --na netname      Show events table for given netname with --aw or --approval

    --valid netname   Validate given netname or IP range
PRIV
    }
    else {
	print <<PUB;
    --all	      Show combination of --overlap and --status

    --config file     Location of the alternative config file

PUB
    }
    
	print <<USAGE;    
    
    --debug	      Print also debug information
    --version	      Prints version of the program
    --help	      This help screen

    --assign and --status are mutually exclusive
    --pipa and --infra are mutually exclusive
    
USAGE

    if($PRIVATE) {
	print <<PRIV;
    --aw and --approval are mutually exclusive
    
    "*" in approval's output indicates usage of the same AW
    "#" in approval's output indicates INFRA-AW assignment
PRIV
    }
    print "\n";
    exit(1);
}

#------------------------------------------------------------------------------
# Purpose           : print allocations located in db
# Side Effects      : 
# Comments          :
# IN                : ref to Reg::Approved, ref to hash regAllocs 
# OUT               : undef 

sub pAllocData {

    my(
      $alloc,	  # Net::RIPEWhois::in,
      $regAllocs  # ref to hash regAllocs  
      ) = @_;

    printf("Output from %s() function\n", (caller(0))[3]) if($DEBUG);
    
    printf("Allocation(s) Located in RIPE whois DB %d\n", scalar(@{$alloc->{'dbAlloc'}}));

    # errors in locating allocations in DB
    foreach my $rAlloc (@{$regAllocs->{'list'}}) {
	# This filled in Asused.pm
	if($regAllocs->{$rAlloc}{'error'}) {
	    printf STDERR "ERROR: $rAlloc\n\t%s\n", $regAllocs->{$rAlloc}{'error'};
	}
    }
    return;
}

#------------------------------------------------------------------------------
# Purpose           : print summary of allocations
# Side Effects      :  
# Comments          :
# IN                : ref #Net::RIPEWhois::in, ref to Reg::Asused
# OUT               : undef
 
sub pAllocResults {
    my($alloc, # Net::RIPEWhois::in,  
       $asu    # Reg::Asused
       ) = @_;
  
    printf("Output from %s() function\n", (caller(0))[3]) if($DEBUG);
    
    #all variables in this my def means totals of the same
    
    my ($allocSize,  # sum of all allocations
        $usage ,     # sum of all assignments
	$infra,      # infrastructual usage
        $uOverlap,   # usage with overlap
        $cOverlap,   # count of overlap assignments 
        $cClassfull, # count of classfull assignments
        $free,       
        $pFree,      # % free
        $noOfAssigns,# no of assignments
        $sWarning     
        );
            
    #print header if any allocations
    if (@{$alloc->{'dbAlloc'}}) {
        my $allocWarning;
        printf("\nDetail of allocation(s) \n\n");
        printf("%s\n", "-" x 78);

        printf("%-15s %-30s ", '  Reg file Alloc', '   Database Allocation')
            unless($opt{'regid'});

        printf("%-15s %-30s ", ' Range ', '   Database Allocation')
            if($opt{'regid'});

        printf("         %-s\n", 'a s s i g n e d');
        printf("%s  %-6s %-6s %-5s %s\n", ' ' x 51, '%', 'No.', 'free', 
                'total');
        printf ("%s\n", "-" x 78);
    }
    
    foreach my $tAlloc (@{$alloc->{'dbAlloc'}}) {
        
        $allocSize += $alloc->{$tAlloc}{'size'}; 
        $usage += $asu->{$tAlloc}{'usage'};
        $infra += $asu->{$tAlloc}{'infra'};
        # $pUsage 
        $uOverlap += $asu->{$tAlloc}{'uOverlap'};
        $cOverlap += $asu->{$tAlloc}{'cOverlap'};
        $cClassfull += $asu->{$tAlloc}{'cClassfull'};
        $noOfAssigns += $asu->{$tAlloc}{'noOfAssigns'};
      
               
        for (my $i = 0; $i < $#{$alloc->{$tAlloc}{'query'}}; $i++) {
            printf ("%-15s \n", $alloc->{$tAlloc}{'query'}[$i]); 
        }
        printf ("%-15s ",$alloc->{$tAlloc}{'query'}[$#{$alloc->{$tAlloc}{'query'}}]); 
        printf ("%-33s ", $tAlloc);
        printf ("%5.1f%% ", $asu->{$tAlloc}{'usage'} * 100 / $alloc->{$tAlloc}{'size'});
        printf ("%7d " , $asu->{$tAlloc}{'usage'});
        printf ("%6d " , $alloc->{$tAlloc}{'size'} - $asu->{$tAlloc}{'usage'});
        printf ("%6d\n" , $alloc->{$tAlloc}{'size'});       
      
        #Look for warnings 

        #check for source == RIPE
        unless ($alloc->{$tAlloc}{'so'} =~ /^RIPE\s*$/) {
            $sWarning .= sprintf("%s allocation without source RIPE %s mnt\n",
                                 $tAlloc, $alloc->{$tAlloc}{'so'});
        }
	
	# Check status of the allocation, should be 'ALLOCATED type'
	if($alloc->{$tAlloc}{'st'} =~ /^ALLOCATED\s+(\w{2})\w*/) {
	    # Save first 2 letters of the type for farther output
	    $alloc->{$tAlloc}{'status'} = uc($1);
	}
	else {
            $sWarning .= sprintf("%s unknown status '%s'\n",
                                  $tAlloc, $alloc->{$tAlloc}{'st'});
	    # Indicate unknown allocation type
	    $alloc->{$tAlloc}{'status'} = '--';
	}
        
        #mnt-lower type
	if(@{$alloc->{$tAlloc}{'ml'}}){
	    foreach my $mnt (@{$alloc->{$tAlloc}{'ml'}}) {
		# Shouldn't be any RIPE maintainers
		if($mnt =~ /RIPE-NCC(?:\-\S+)?-MNT/i) {
		    # Registry haven't paid
		    if($mnt =~ /RIPE-NCC-HM-MNT/i) {
            		$sWarning .= sprintf("%s has mnt-lower %s. Didn't pay?\n", $tAlloc, $mnt);
		    }
		    # Anything else with RIPE
		    else {
            		$sWarning .= sprintf("%s has RIPE NCC mnt-lower %s.\n", $tAlloc, $mnt);
		    }
        	}
	    }
        }
	else {
	    $sWarning .= sprintf("%s doesn't have mnt-lower attribute.\n", $tAlloc);
	}
	
        #any warning generated from whois
	foreach my $wrn (@{$alloc->{$tAlloc}{'warning'}}) {
	    $sWarning .= sprintf("%s %s\n", $tAlloc, $wrn);
        }
    }
    
    printf ("%s\n", "-" x 78) if(@{$alloc->{'dbAlloc'}});
    
    printf("\n");
    
    if($opt{'regid'}) {
	printf("Total number of addresses in all allocation(s)  ");
    }
    else {
	printf("Total number of addresses in allocation         ");
    }
    
    printf("         %7d\n", $allocSize);

    if($opt{'regid'}) {
	printf("Total assigned addresses in all allocation(s)   ");
    }
    else {
	printf("Total assigned addresses in allocation:         ");
    }
    
    printf("%7.1f%% %7d\n", ($usage * 100 / $allocSize), $usage);

    if($opt{'regid'}) {
	printf("Total assigned for infrastructure in alloc(s)   ");
    }
    else {
	printf("Total assigned for infrastructure in alloc:     ");
    }
    
    printf("%7.1f%% %7d\n", ($infra * 100 / $allocSize), $infra);
    
    if($opt{'regid'}) {
	printf("Total unused addresses in all allocation(s)     ");
    }
    else {
	printf("Total unused addresses in allocation:           ");
    }
    
    # XXX: allocSize == 0?
    printf("%7.1f%% %7d\n", ($allocSize - $usage) * 100 / $allocSize, ($allocSize - $usage));

    #if usage  is zero can't calculate /$usage
    if ($usage) {
        printf("Total overlap(s)                          %5d %7.1f%% %7d\n",
                $cOverlap, ($uOverlap - $usage) * 100 / $usage, ($uOverlap - $usage));
    }
    
    # Put an additional warning if overlaps
    if($cOverlap) {
	$sWarning .= sprintf("There are OVERLAPPING ASSIGNMENTS. Check with --overlap\n");
    }
    
    # Just to separate output
    printf("\n");
    printf("No of Assignment(s)                                      %7d\n", 
	    $noOfAssigns);
    printf("No of assignment(s) of size /20 - /24           %7.1f%% %7d\n",
	    ($noOfAssigns) ? $cClassfull * 100 / $noOfAssigns : 0,
	     $cClassfull);

    if ($sWarning) {
        print ("\nPlease check the following WARNINGS:\n");
        print ("$sWarning");
    }
    else {
        print "No WARNINGS found\n";
    }
    
    return;
}


#------------------------------------------------------------------------------
# Purpose           : print overlap information
# Side Effects      : 
# Comments          :
# IN                : allocation ref to Net::RIPEWhois::in, ref to Reg::Asused
# OUT               : undef

sub pOverlap {
    my (
	$alloc,  # allocation ref to Net::RIPEWhois::in
        $asu     # ref to Reg::Asused
       )  = @_;
  
    printf("Output from %s() function\n", (caller(0))[3]) if($DEBUG);

    my $sSummary; # summary string 

    my $overlapFlag = 1; # flag to pring the heading once

    foreach my $tAlloc (@{$alloc->{'dbAlloc'}}) {
        
        #print details 
        unless($opt{'summary'}) {
            # header of overlapping info
            if($asu->{$tAlloc}{'sOverlap'} and $overlapFlag) {
                printf("\nList of overlapping objects\n");
                printf("          %-33s %-12s %s\n", 'inetnum', 'date', 'netname');
                printf("%s\n", "-" x 78);
                $overlapFlag = 0;
            }
	    # Details about overlaps
            printf("%s", $asu->{$tAlloc}{'sOverlap'});
        }

        $sSummary .= sprintf("%-33s", $tAlloc);
      
        if($asu->{$tAlloc}{'noOfAssigns'}) {
            $sSummary .= sprintf("%10.1f", 
                                 ($asu->{$tAlloc}{'cOverlap'}  * 100 /
                                  $asu->{$tAlloc}{'noOfAssigns'}));
        }
        else {
            $sSummary .= sprintf("%10.1f", 0);
        }

        $sSummary .= sprintf("%8d     %6d    ", $asu->{$tAlloc}{'cOverlap'},
                                 $asu->{$tAlloc}{'noOfAssigns'});
        
        $sSummary .= sprintf(" %8d\n",  $alloc->{$tAlloc}{'created'});
    }

    # print summary 
    if($sSummary) {
        printf("\nSummary of overlaps per allocation:\n");
        printf("%s\n", "-" x 78);
        printf("%-33s %11s %8s %13s %s\n", 'Database Allocation', '% of overlps', 
            				  'Overlaps', 'No. of assign', 'Date');
        printf("%s\n", "-" x 78);
        printf("%s", $sSummary);
        printf("%s\n", "-" x 78);
    }
    # no overlap summary to print
    else {
        printf "No overlaps\n";
    }
    
    return;

}

#------------------------------------------------------------------------------
# Purpose           : print assignments status information
# Side Effects      : 
# Comments          :
# IN                : ref to allocation Net::RIPEWhois::in, ref to Reg::Asused 
# OUT               : undef

sub pStatus {
    my($alloc,  #ref to allocation
       $asu     #ref to Reg::Asused
       ) = @_;
 
    printf("Output from %s() function\n", (caller(0))[3]) if($DEBUG);

    #all variables in this my def means  totals of the same for all allocations

    my($noOfAssigns,  # number of assignments 
       $paStCount,    # number of assignments with status ASSIGNED PA
       $piStCount,    # number of assignments with status ASSIGNED PI
       $missStCount,  # number of assignments with missing status value
       $otherStCount, # number of assignments with any other status
       $sWarning,     # salar of formatted output of warnings
       $sSummary,     # scalar summary
       $sInfra,       # infra-aw assignments
       $sFree,        # scalar free formatted output
       $free,         # no of free IP addresses
      );
    
    my $statusFlag = 1;  # flag to print header info

    foreach my $tAlloc (@{$alloc->{'dbAlloc'}}) {

        unless($opt{'summary'}) {
	    if($opt{'status'} || $opt{'assign'}) {
		# print heading if it exists & not printed previously
        	if($asu->{$tAlloc}{'sStatus'} and $statusFlag) {
		    if($opt{'status'}) {
			print "\nAssignments with incorrect status value\n";
            	    }
		    elsif($opt{'assign'}) {
			print "\nAll assignments\n";
		    }
		    
            	    printf("%s\n", "-" x 78);
            	    printf('%-32s %5s  %7s  ', 'Database Allocation', 'size', 'date');
		    
		    if(defined($opt{'pipa'})) {
			printf("%2s  ", 'st');
		    }
		    elsif(defined($opt{'infra'})) {
			printf("%3s  ", 'inf');
		    }
		    
            	    printf("%-15s ", 'netname');
            	    printf("%-6s", 'status') if(defined($opt{'status'}));
            	    printf("\n");
            	    
            	    printf("%s\n", "-" x 78);
        	    $statusFlag = 0;
		}
	    # Details about assignments
    	    printf("%s", $asu->{$tAlloc}{'sStatus'});
	    }
        }
	
	# infra
	$sInfra = $asu->{$tAlloc}{'sInfra'} if($asu->{$tAlloc}{'sInfra'});

        # free space
        $sFree .= $asu->{$tAlloc}{'sFree'} if($asu->{$tAlloc}{'sFree'});
        $free  += $asu->{$tAlloc}{'free'};
	
        # status summary
        $sSummary .= sprintf ("%-33s  %3s  %5d %5d %5d", $tAlloc,
			      $alloc->{$tAlloc}{'status'},
                              $asu->{$tAlloc}{'noOfAssigns'},
                              $asu->{$tAlloc}{'paStCount'}, 
                              $asu->{$tAlloc}{'piStCount'});
            
        $sSummary .= sprintf (" %5d %5d", $asu->{$tAlloc}{'missStCount'},
				$asu->{$tAlloc}{'otherStCount'});
	
        $sSummary .= sprintf(" %8d\n",  $alloc->{$tAlloc}{'created'});
        
        # Print warnings asu if there any
	$sWarning .= $asu->{$tAlloc}{'warning'} if($asu->{$tAlloc}{'warning'});

        # numbers
        $noOfAssigns  += $asu->{$tAlloc}{'noOfAssigns'};
        $paStCount    += $asu->{$tAlloc}{'paStCount'};
        $piStCount    += $asu->{$tAlloc}{'piStCount'};
        $missStCount  += $asu->{$tAlloc}{'missStCount'};
        $otherStCount += $asu->{$tAlloc}{'otherStCount'};
    }   
      
    # print warnings if any
    unless($opt{'summary'}) {
        if($sWarning) {
            printf "\nPay attention on this WARNINGS:\n";
            printf $sWarning;
        }
    }
    
    # Infrastructure assignments
    if($opt{'infra'}) {
	if($sInfra) {
    	    printf("\nInfrastructure assignemts:\n");
	    printf("%s\n", "-" x 78);
	    printf('%-32s %5s  %7s  ', 'Database Allocation', 'size', 'date');
	    printf("%2s  ", 'st') if(defined($opt{'pipa'}));
	    printf("%-15s ", 'netname');
	    printf("%-6s", 'status') if(defined($opt{'status'}));
	    printf("\n");
            printf("%s\n", "-" x 78);
	    printf("%s", $sInfra);
            printf("%s\n", "-" x 78);
	    
	}
    }
    
    # List free address space
    if($opt{'free'}) {
        # free space
        if($sFree) {
            printf("\nFree Address Space\n");
            printf("%s\n", "-" x 78);
            printf("%-33s %6s\n", "Address range", " size");
            printf("%s\n", "-" x 78);
            printf("%s\n", $sFree);
            printf("%s\n", "-" x 78);
            printf("%-33s %6d\n", 'Total', $free);
        }
	else {
	    printf("\nNo Free Address Space\n");
	}
    }
    
    # Give summary information
    if($opt{'status'} || $opt{'assign'}) {
	#print summary
	if($sSummary) {
	    printf("\nSummary of statuses per allocation:\n"); 
	    printf("%s\n", "-" x 78);
	    printf("%-33s  %3s %-7s %5s %5s", 'Database Allocation', 'st', '#assign', 'PA ', 'PI ');
	    printf(" %5s %5s %6s\n", 'miss ', 'other', 'date ');
	    printf("%s\n", "-" x 78);
	    printf("%s", $sSummary);
	    printf("%s\n", "-" x 78);
	}
	else {
	    printf "\nNo allocations yet\n";
	}
    }

  return;
}
!NO!SUBS!

close OUT or die "Can't close $file: $!";
chmod 0755, $file or die "Can't reset permissions for $file: $!\n";

rename($file, $newname) unless($newname eq $file);

exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
chdir $origdir;