### -*- 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  <simon@switch.ch>###### Contributions and fixes by:###### Andrzej Tobola <san@iem.pw.edu.pl>:  Added long String decode### Tobias Oetiker <oetiker@ee.ethz.ch>:  Added 5 Byte Integer decode ...### Dave Rand <dlr@Bungi.com>:  Added SysUpTime decode### Philippe Simonet <sip00@vg.swissptt.ch>:  Support larger subids### Yufang HU <yhu@casc.com>:  Support even larger subids### Mike Mitchell <mcm@unx.sas.com>: New generalized encode_int()### Mike Diehn <mdiehn@mindspring.net>: 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);### Prototypessub 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 tagssub universal_flag	{ 0x00 }sub application_flag	{ 0x40 }sub context_flag	{ 0x80 }sub private_flag	{ 0xc0 }sub primitive_flag	{ 0x00 }sub constructor_flag	{ 0x20 }### Universal tagssub 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 fieldsub long_length		{ 0x80 }### SNMP specific tagssub 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 }#### Encodingsub 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);}#### Decodingsub 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));