ber.pm

主要用于监控网络流量并动态产生可视化结果

### -*- mode: Perl -*-
######################################################################
### BER (Basic Encoding Rules) encoding and decoding.
######################################################################
### This module implements encoding and decoding of ASN.1-based data
### structures using the Basic Encoding Rules (BER).  Only the subset
### necessary for SNMP is implemented.
######################################################################
### Created by:  Simon Leinen  <[e-mail]>
###
### Contributions and fixes by:
###
### Andrzej Tobola <[e-mail]>:  Added long String decode
### Tobias Oetiker <[e-mail]>:  Added 5 Byte Integer decode ...
### Dave Rand <[e-mail]>:  Added SysUpTime decode
### Philippe Simonet <[e-mail]>:  Support larger subids
### Yufang HU <[e-mail]>:  Support even larger subids
### Mike Mitchell <[e-mail]>: New generalized encode_int()
### Mike Diehn <[e-mail]>: encode_ip_address()
######################################################################

package BER;

require 5.002;

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

$VERSION = '0.66';

@ISA = qw(Exporter);

@EXPORT = qw(context_flag constructor_flag
	     encode_int encode_int_0 encode_null encode_oid
	     encode_sequence encode_tagged_sequence
	     encode_string encode_ip_address encode_timeticks
	     decode_sequence decode_by_template
	     pretty_print hex_string hex_string_of_type
	     encoded_oid_prefix_p errmsg);

### Prototypes
sub encode_header ($$);
sub encode_int_0 ();
sub encode_int ($);
sub encode_oid (@);
sub encode_null ();
sub encode_sequence (@);
sub encode_tagged_sequence ($@);
sub encode_string ($);
sub encode_ip_address ($);
sub encode_timeticks ($);
sub pretty_print ($);
sub pretty_using_decoder ($$);
sub pretty_string ($);
sub pretty_intlike ($);
sub pretty_unsignedlike ($);
sub pretty_oid ($);
sub pretty_uptime ($);
sub pretty_uptime_value ($);
sub pretty_ip_address ($);
sub hex_string ($);
sub hex_string_of_type ($$);
sub decode_oid ($);
sub decode_by_template;
sub decode_by_template_2;
sub decode_sequence ($);
sub decode_int ($);
sub decode_intlike ($);
sub decode_unsignedlike ($);
sub decode_intlike_s ($$);
sub decode_string ($);
sub decode_length ($);
sub encoded_oid_prefix_p ($$);
sub decode_subid ($$$);
sub error (@);
sub template_error ($$$);

sub version () { $VERSION; }

### Flags for different types of tags

sub universal_flag	{ 0x00 }
sub application_flag	{ 0x40 }
sub context_flag	{ 0x80 }
sub private_flag	{ 0xc0 }

sub primitive_flag	{ 0x00 }
sub constructor_flag	{ 0x20 }

### Universal tags

sub boolean_tag		{ 0x01 }
sub int_tag		{ 0x02 }
sub bit_string_tag	{ 0x03 }
sub octet_string_tag	{ 0x04 }
sub null_tag		{ 0x05 }
sub object_id_tag	{ 0x06 }
sub sequence_tag	{ 0x10 }
sub set_tag		{ 0x11 }
sub uptime_tag		{ 0x43 }

### Flag for length octet announcing multi-byte length field

sub long_length		{ 0x80 }

### SNMP specific tags

sub snmp_ip_address_tag		{ 0x00 | application_flag }
sub snmp_counter32_tag		{ 0x01 | application_flag }
sub snmp_gauge32_tag		{ 0x02 | application_flag }
sub snmp_timeticks_tag		{ 0x03 | application_flag }
sub snmp_opaque_tag		{ 0x04 | application_flag }
sub snmp_nsap_address_tag	{ 0x05 | application_flag }
sub snmp_counter64_tag		{ 0x06 | application_flag }
sub snmp_uinteger32_tag		{ 0x07 | application_flag }

#### Encoding

sub encode_header ($$) {
    my ($type,$length) = @_;
    return pack ("C C", $type, $length) if $length < 128;
    return pack ("C C C", $type, long_length | 1, $length) if $length < 256;
    return pack ("C C n", $type, long_length | 2, $length) if $length < 65536;
    return error ("Cannot encode length $length yet");
}

sub encode_int_0 () {
    return pack ("C C C", 2, 1, 0);
}

sub encode_int ($) {
    return encode_intlike ($_[0], int_tag);
}

sub encode_intlike ($$) {
    my ($int, $tag)=@_;
    my ($sign, $val, @vals);

    $sign = ($int >= 0) ? 0 : 0xff;
    for(;;) {
        $val = $int & 0xff;
        unshift(@vals, $val);
        return encode_header ($tag, $#vals + 1).pack ("C*", @vals)
            if ($int >= -128 && $int < 128);
        $int -= $sign;
        $int = int($int / 256);
    }
}

sub encode_oid (@) {
    my @oid = @_;
    my ($result,$subid);

    $result = '';
    ## Ignore leading empty sub-ID.  The favourite reason for
    ## those to occur is that people cut&paste numeric OIDs from
    ## CMU/UCD SNMP including the leading dot.
    shift @oid if $oid[0] eq '';

    return error ("Object ID too short: ", join('.',@oid))
	if $#oid <= 1;
    ## The first two subids in an Object ID are encoded as a single
    ## byte in BER, according to a funny convention.  This poses
    ## restrictions on the ranges of those subids.  In the past, I
    ## didn't check for those.  But since so many people try to use
    ## OIDs in CMU/UCD SNMP's format and leave out the mib-2 or
    ## enterprises prefix, I introduced this check to catch those
    ## errors.
    ##
    return error ("first subid too big in Object ID ", join('.',@oid))
	if $oid[0] > 2;
    $result = shift (@oid) * 40;
    $result += shift @oid;
    return error ("second subid too big in Object ID ", join('.',@oid))
	if $result > 255;
    $result = pack ("C", $result);
    foreach $subid (@oid) {
	if ( ($subid>=0) && ($subid<128) ){ #7 bits long subid 
	    $result .= pack ("C", $subid);
	} elsif ( ($subid>=128) && ($subid<16384) ){ #14 bits long subid
	    $result .= pack ("CC", 0x80 | $subid >> 7, $subid & 0x7f);
	} 
	elsif ( ($subid>=16384) && ($subid<2097152) ) {#21 bits long subid
	    $result .= pack ("CCC",
			     0x80 | (($subid>>14) & 0x7f), 
			     0x80 | (($subid>>7) & 0x7f),
			     $subid & 0x7f); 
	} elsif ( ($subid>=2097152) && ($subid<268435456) ){ #28 bits long subid
	    $result .= pack ("CCCC", 
			     0x80 | (($subid>>21) & 0x7f),
			     0x80 | (($subid>>14) & 0x7f),
			     0x80 | (($subid>>7) & 0x7f),
			     $subid & 0x7f);
	} elsif ( ($subid>=268435456) && ($subid<2147483648) ){ #31 bits long subid
	    $result .= pack ("CCCCC", 
			     0x80 | (($subid>>28) & 0x0f), #mask the bits beyond 32 
			     0x80 | (($subid>>21) & 0x7f),
			     0x80 | (($subid>>14) & 0x7f),
			     0x80 | (($subid>>7) & 0x7f),
			     $subid & 0x7f);
	} elsif ( ($subid>=-2147483648) && ($subid<0) ) { #32 bits long subid
	    $result .= pack ("CCCCC", 
			     0x80 | (($subid>>28) & 0x0f), #mask the bits beyond 32 
			     0x80 | (($subid>>21) & 0x7f),
			     0x80 | (($subid>>14) & 0x7f),
			     0x80 | (($subid>>7) & 0x7f),
			     $subid & 0x7f);
	} else {
	    return error ("Cannot encode subid $subid");
	}
    }
    encode_header (object_id_tag, length $result).$result;
}

sub encode_null () { encode_header (null_tag, 0); }
sub encode_sequence (@) { encode_tagged_sequence (sequence_tag, @_); }

sub encode_tagged_sequence ($@) {
    my ($tag,$result);

    $tag = shift @_;
    $result = join '',@_;
    return encode_header ($tag | constructor_flag, length $result).$result;
}

sub encode_string ($) {
    my ($string)=@_;
    return encode_header (octet_string_tag, length $string).$string;
}

sub encode_ip_address ($) {
    my ($addr)=@_;
    my @octets;

    if (length $addr == 4) {
      ## Four bytes... let's suppose that this is a binary IP address
      ## in network byte order.
      return encode_header (snmp_ip_address_tag, length $addr).$addr;
    } elsif (@octets = ($addr =~ /^([0-9]+)\.([0-9]+)\.([0-9]+)\.([0-9]+)$/)) {
      return encode_ip_address (pack ("CCCC", @octets));
    } else {
      return error ("IP address must be four bytes long or a dotted-quad");
    }
}

sub encode_timeticks ($) {
  my ($tt) = @_;
  return BER::encode_intlike ($tt, BER::snmp_timeticks_tag);
}

#### Decoding

sub pretty_print ($) {
    my ($packet) = @_;
    my ($type,$rest);
    my $result = ord (substr ($packet, 0, 1));
    return pretty_intlike ($packet)
	if $result == int_tag;
    return pretty_unsignedlike ($packet)
	if $result == snmp_counter32_tag
	    || $result == snmp_gauge32_tag
	    || $result == snmp_counter64_tag;
    return pretty_string ($packet) if $result == octet_string_tag;
    return pretty_oid ($packet) if $result == object_id_tag;
    return pretty_uptime ($packet) if $result == uptime_tag;
    return pretty_ip_address ($packet) if $result == snmp_ip_address_tag;
    return "(null)" if $result == null_tag;
    return sprintf("#<unprintable BER type 0x%x>", $result);
}

sub pretty_using_decoder ($$) {
    my ($decoder, $packet) = @_;
    my ($decoded,$rest);
    ($decoded,$rest) = &$decoder ($packet);
    return error ("Junk after object") unless $rest eq '';
    return $decoded;
}

sub pretty_string ($) {
    pretty_using_decoder (\&decode_string, $_[0]);
}

sub pretty_intlike ($) {
    my $decoded = pretty_using_decoder (\&decode_intlike, $_[0]);
    $decoded;
}

sub pretty_unsignedlike ($) {
    return pretty_using_decoder (\&decode_unsignedlike, $_[0]);
}

sub pretty_oid ($) {
    my ($oid) = shift;
    my ($result,$subid,$next);
    my (@oid);
    $result = ord (substr ($oid, 0, 1));
    return error ("Object ID expected") unless $result == object_id_tag;
    ($result, $oid) = decode_length (substr ($oid, 1));
    return error ("inconsistent length in OID") unless $result == length $oid;
    @oid = ();
    $subid = ord (substr ($oid, 0, 1));
    push @oid, int ($subid / 40);
    push @oid, $subid % 40;
    $oid = substr ($oid, 1);
    while ($oid ne '') {
	$subid = ord (substr ($oid, 0, 1));
	if ($subid < 128) {
	    $oid = substr ($oid, 1);
	    push @oid, $subid;
	} else {
	    $next = $subid;
	    $subid = 0;
	    while ($next >= 128) {
		$subid = ($subid << 7) + ($next & 0x7f);
		$oid = substr ($oid, 1);
		$next = ord (substr ($oid, 0, 1));
	    }
	    $subid = ($subid << 7) + $next;
	    $oid = substr ($oid, 1);
	    push @oid, $subid;
	}
    }
    join ('.', @oid);
}

sub pretty_uptime ($) {
    my ($packet,$uptime);

    ($uptime,$packet) = &decode_unsignedlike (@_);
    pretty_uptime_value ($uptime);
}

sub pretty_uptime_value ($) {
    my ($uptime) = @_;
    my ($seconds,$minutes,$hours,$days,$result);
    ## We divide the uptime by hundred since we're not interested in
    ## sub-second precision.
    $uptime = int ($uptime / 100);

    $days = int ($uptime / (60 * 60 * 24));