asused 3.72-12 / usr / share / perl5 / RipeWhois / FormatMode.pm

# Copyright (c) 2000                    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          : FormatMode.pm
# Purpose           : Filter objects in RIPE Whois v3 format and make them look
#		      like v2 format.
# Author            : Timur Bakeyev <timur@ripe.net>
# Date              : 04042001
# Description       : Filter to get rid of some RPSL extended syntax
# Language Version  : Perl5
# OSs Tested        : BSD/OS 3.1
# Command Line      : None
# Input Files       : None
# Output Files      : None
# External Programs : None
# Problems          : None known
# To Do             : None
# Comments          : This module provided only to ease the transition to the
#		      RIPE Whois v3
# $Id: FormatMode.pm,v 1.5 2001/10/10 15:23:31 timur Exp $
#------------------------------------------------------------------------------
package RipeWhois::FormatMode;

use strict;
use vars qw($VERSION @ISA);

require Exporter;

@ISA = qw(Exporter);

$VERSION = '1.03';

# Mapping from short form of attrributes to normal
my %shortattr = (
	'*ac'	=> 'admin-c',	'*aa'	=> 'as-name',	'*ad'	=> 'address',	'*ag'	=> 'aggr-mtd',
	'*ab'	=> 'aggr-bndry','*ah'	=> 'author',	'*an'	=> 'aut-num',	'*as'	=> 'as-set',
	'*at'	=> 'auth',	'*az'	=> 'alias',	'*ce'	=> 'certif',	'*ch'	=> 'changed',
	'*cy'	=> 'country',	'*cn'	=> 'cross-nfy',	'*co'	=> 'components','*ct'	=> 'cross-mnt',
	'*da'	=> 'dom-name',	'*de'	=> 'descr',	'*df'	=> 'default',	'*dc'	=> 'dictionary',
	'*di'	=> 'dom-net',	'*dn'	=> 'domain',	'*dt'	=> 'upd-to',	'*ec'	=> 'export-comps',
	'*en'	=> 'encapsulation','*em'=> 'e-mail',	'*ex'	=> 'export',	'*fi'	=> 'filter',
	'*fp'	=> 'fingerpr',	'*fs'	=> 'filter-set','*fx'	=> 'fax-no',	'*ho'	=> 'holes',
	'*if'	=> 'ifaddr',	'*ij'	=> 'inject',	'*in'	=> 'inetnum',	'*i6'	=> 'inet6num',
	'*ip'	=> 'import',	'*ir'	=> 'inet-rtr',	'*is'	=> 'rtr-set',	'*kc'	=> 'key-cert',
	'*la'	=> 'local-as',	'*li'	=> 'limerick',	'*mh'	=> 'method',	'*mb'	=> 'mnt-by',
	'*ml'	=> 'mnt-lower',	'*mo'	=> 'member-of',	'*mr'	=> 'mbrs-by-ref','*ms'	=> 'members',
	'*mt'	=> 'mntner',	'*mn'	=> 'mnt-nfy',	'*na'	=> 'netname',	'*nh'	=> 'nic-hdl',
	'*ns'	=> 'nserver',	'*ny'	=> 'notify',	'*or'	=> 'origin',	'*ow'	=> 'owner',
	'*pe'	=> 'peer',	'*pg'	=> 'peering',	'*ph'	=> 'phone',	'*pl'	=> 'protocol',
	'*pn'	=> 'person',	'*ps'	=> 'peering-set','*rf'	=> 'refer',	'*rm'	=> 'remarks',
	'*ro'	=> 'role',	'*rp'	=> 'rp-attribute','*rs'	=> 'route-set',	'*rt'	=> 'route',
	'*rz'	=> 'rev-srv',	'*sd'	=> 'sub-dom',	'*so'	=> 'source',	'*st'	=> 'status',
	'*tb'	=> 'trouble',	'*td'	=> 'typedef',	'*tc'	=> 'tech-c',	'*tx'	=> 'text',
	'*wd'	=> 'withdrawn',	'*zc'	=> 'zone-c',
);

# Hash of hashes, which contains the order of the fields for the
# most common RIPE Whois objects.
my %class = (
    'aut-num'	=> {
	'aut-num'	=> 1,
        'as-name'	=> 2,
	'descr'		=> 3,
        'as-in'		=> 4,
	'as-out'	=> 5,
        'cross-nfy'	=> 6,
	'cross-mnt'	=> 7,
        'interas-in' 	=> 8,
	'interas-out' 	=> 9,
        'as-exclude' 	=> 10,
	'default'	=> 11,
        'guardian'	=> 12,
	'admin-c'	=> 13,
        'tech-c'	=> 14,
	'remarks'	=> 15,
        'notify'	=> 16,
	'mnt-by'	=> 17,
        'changed'	=> 18,
	'source'	=> 19
    },

    'inetnum'	=> {
        'inetnum'	=> 1,
	'netname'	=> 2,
        'descr'		=> 3,
	'country'	=> 4,
        'admin-c'	=> 5,
	'tech-c'	=> 6,
        'rev-srv'	=> 7,
	'status'	=> 8,
        'remarks'	=> 9,
	'notify'	=> 10,
        'mnt-by'	=> 11,
	'mnt-lower'	=> 12,
        'changed'	=> 13,
	'source'	=> 14
    },

    'person'	=> {
	'person'	=> 1,
	'address'	=> 2,
	'phone'		=> 3,
	'fax-no'	=> 4,
	'e-mail'	=> 5,
        'nic-hdl'	=> 6,
	'remarks'	=> 7,
        'notify'	=> 8,
	'mnt-by'	=> 9,
        'changed'	=> 10,
	'source'	=> 11
    },

    'role'	=> {
	'role'		=> 1,
	'address'	=> 2,
        'phone'		=> 3,
	'fax-no'	=> 4,
        'e-mail'	=> 5,
	'trouble'	=> 6,
        'admin-c'	=> 7,
	'tech-c'	=> 8,
        'nic-hdl'	=> 9,
	'remarks'	=> 10,
        'notify'	=> 11,
	'mnt-by'	=> 12,
        'changed'	=> 13,
	'source'	=> 14
    }
);


####################################################################
#  DESCRIPTION: Return a reference to the hash of weights for the
#		specified object class or nothing if it is unknown
#        INPUT: Class name
#       OUTPUT: Reference to the hash with weights or undef
####################################################################
sub short2long {
    my($short) = @_;
    # Nothing was passed
    return unless($short);
    # Translate
    my $long = $shortattr{$short};
    # Return the result, if any or original
    return ($long) ? $long : $short;
}

####################################################################
#  DESCRIPTION: Return a reference to the hash of weights for the
#		specified object class or nothing if it is unknown
#        INPUT: Class name
#       OUTPUT: Reference to the hash with weights or undef
####################################################################

sub sort_order {
    my($class) = @_;

    # Return nothing if nothing was passed
    return unless($class);
    # Return the list of weights, corresponding to the
    # class, or nothing, if we don't know about it
    return $class{$class};
}

####################################################################
#  DESCRIPTION: Sorts the passed array according to weights, that
#		correspond to the specified class
#        INPUT: Class name; list of the fields
#       OUTPUT: Sorted list of the fields
# SIDE EFFECTS: Unknown fields are going to the bottom of the list
####################################################################

sub sort_by_field {
    my($class, $hash) = @_;

    # Get the order of the fields for the class
    my $type = sort_order($class);
    # Get the list of the fields
    my @keys = keys(%{$hash});
    # Return immedeately, if there is no defined sorting order.
    return @keys unless($type && (ref($type) eq 'HASH'));

    # Sort the list of key fields according to the predefined
    # order.
    my @list = sort {
	# Convert short form of the field into long one
	my $alpha = short2long($a);
	my $beta = short2long($b);
	# Assign to unknown fields huge weight, so they
	# will go to the bottom of the list
	my $t_alpha = defined($type->{$alpha}) ? $type->{$alpha} : 1000;
	my $t_beta = defined($type->{$beta}) ? $type->{$beta} : 1000;
	# Compare two weights
	$t_alpha <=> $t_beta;

    } @keys;
    # Return the result
    return @list;
}

####################################################################
#  DESCRIPTION: Filter the output of the RIPE Whois v3 to make it look
#		like v2 output, with some exceptions
#        INPUT: Object to filter; bool flag, do we need sorting as well
#       OUTPUT: Filtered object
# SIDE EFFECTS: None
####################################################################

sub Filter {
    my($obj, $need_sorting) = @_;

    # Strip comments
    $obj =~ s/\s*#.*$//mg;
    # Assemble the lines
    $obj =~ s/\n[ \t\+]\s*/ /mg;
    # Zap spaces and tabs
    $obj =~ s/[ \t]+/ /mg;

    # Return, if sorting is not required
    return $obj unless($need_sorting);

    # We need to sort fields as well
    my %obj = ();
    my @obj = ();

    my($key_field, $key, $value);
    # Split object into lines
    foreach my $line (split(/\n/, $obj)) {
	# Plain field/value pair
	if($line =~ /^(\S+):\s*(.*)$/) {
	    ($key, $value) = ($1, $2);
	    # Key field is always the first in the object
	    # If it is in -F form - expand it
	    $key_field = short2long($key) unless($key_field);
	    # Store the values of the field in an array
	    push(@{$obj{$key}}, $value);
	}
    }
    # Return unsorted object, if we don't know the sorting order
    return $obj unless(sort_order($key_field));

    # Sort the fields acording to the RIPE DB v2
    foreach my $field (sort_by_field($key_field, \%obj)) {
	foreach my $line (@{$obj{$field}}) {
	    push(@obj, sprintf("%-14s%s", "$field:", $line));
	}
    }
    # Merge the list back into the scalar
    $obj = join("\n", @obj);
    # Return sorted list of the fields
    return $obj;
}

1;