simple BER decoding

[Kragen Sitaker]

I implemented this BER decoder in order to help me understand SNMP
packets and debug an SNMP implementation I've been working on.
Itself, it's too slow to be useful in the implementation, but it's
great as a debugging tool.  Feed it e.g. SNMP packets.

It is guaranteed to break on BER-encoded things beyond what I tested
it with.

use strict;
package BERdecode;
use SNMP;

# debugging tool for dumping BER-encoded SNMP packets

sub unpack_number {
  my ($bytes) = @_;
  # XXX only handles up to 32 bits
  # XXX mishandles negative numbers represented briefly
  return unpack "N",  "\0" x (4 - length($bytes)) . $bytes;
}

sub decode {
  my ($value) = @_;
  return () if $value eq '';
  my ($type, $len, $other) = unpack "aCa*", $value;
  if ($len & 0x80) {
      $len &= ~0x80;
      (my $rawlen, $other) = unpack "a[$len]a*", $other;
      $len = unpack_number($rawlen);
  }
  my ($contents, $remainder) = unpack "a[$len]a*", $other;
  warn sprintf "inconsistent length: %d != %d", $len, length($contents) if $len > 
length($contents);
  my $rv;
  if (($type & "\x20") ne "\0") {
    my @items;
    my $item;
    while ($contents ne '') {
      ($item, $contents) = decode($contents);
      push @items, $item;
    }
    $rv = {$type => [EMAIL PROTECTED];
  } elsif ($type eq SNMP::OCTET_STRING) {
    $rv = {$type => $contents};
  } elsif ($type eq SNMP::INTEGER) {
    $rv = unpack_number($contents);
  } elsif ($type eq SNMP::OBJECT_IDENTIFIER) {
    my @nums = unpack 'w*', $contents;
    $rv = join '.', '', int($nums[0] / 40), $nums[0] % 40, @nums[1..$#nums];
  } elsif ($type eq SNMP::NULL) {
    $rv = undef;
  } else {
    $rv = substr($value, 0, 2) . $contents;
  }
  return ($rv, $remainder);
}

1;
__END__

OCTET_STRING, INTEGER, NULL, and OBJECT_IDENTIFIER are constants
defined as follows:
use constant INTEGER => "\x02";
use constant OCTET_STRING => "\x04";
use constant NULL => "\x05";
use constant OBJECT_IDENTIFIER => "\x06";