File Coverage

blib/lib/Convert/BER.pm

Criterion	Covered	Total	%
statement	443	888	49.8
branch	131	382	34.2
condition	18	72	25.0
subroutine	51	81	62.9
pod	14	24	58.3
total	657	1447	45.4

# Convert::BER.pm
#
# Copyright (c) 1995-1999 Graham Barr . All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.

package Convert::BER;

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

BEGIN {
    if ($] >= 5.006) {
	require bytes; 'bytes'->import;
    }

    $VERSION = "1.32";

    @ISA = qw(Exporter);

    @EXPORT_OK = qw(
	BER_BOOLEAN
	BER_INTEGER
	BER_BIT_STR
	BER_OCTET_STR
	BER_NULL
	BER_OBJECT_ID
	BER_REAL
	BER_SEQUENCE
	BER_SET

	BER_UNIVERSAL
	BER_APPLICATION
	BER_CONTEXT
	BER_PRIVATE

	BER_PRIMITIVE
	BER_CONSTRUCTOR

	BER_LONG_LEN
	BER_EXTENSION_ID
	BER_BIT

	ber_tag
    );

    # 5.003 does not have UNIVERSAL::can
    unless(defined &UNIVERSAL::can) {
        *UNIVERSAL::can = sub {
            my($obj,$meth) = @_;
            my $pkg = ref($obj) || $obj;
            my @pkg = ($pkg);
            my %done;
            while(@pkg) {
                $pkg = shift @pkg;
                next if exists $done{$pkg};
                $done{$pkg} = 1;

                no strict 'refs';

                unshift @pkg,@{$pkg . "::ISA"}
                    if(@{$pkg . "::ISA"});
                return \&{$pkg . "::" . $meth}
                    if defined(&{$pkg . "::" . $meth});
            }
            undef;
        }
    }
}

##
## Constants
##

sub BER_BOOLEAN 	() { 0x01 }
sub BER_INTEGER 	() { 0x02 }
sub BER_BIT_STR 	() { 0x03 }
sub BER_OCTET_STR 	() { 0x04 }
sub BER_NULL 		() { 0x05 }
sub BER_OBJECT_ID 	() { 0x06 }
sub BER_REAL 		() { 0x09 }
sub BER_ENUMERATED	() { 0x0A }
sub BER_SEQUENCE 	() { 0x10 }
sub BER_SET 		() { 0x11 }
sub BER_PRINT_STR	() { 0x13 }
sub BER_IA5_STR		() { 0x16 }
sub BER_UTC_TIME	() { 0x17 }
sub BER_GENERAL_TIME	() { 0x18 }

sub BER_UNIVERSAL 	() { 0x00 }
sub BER_APPLICATION 	() { 0x40 }
sub BER_CONTEXT 	() { 0x80 }
sub BER_PRIVATE		() { 0xC0 }

sub BER_PRIMITIVE	() { 0x00 }
sub BER_CONSTRUCTOR	() { 0x20 }

sub BER_LONG_LEN	() { 0x80 }
sub BER_EXTENSION_ID	() { 0x1F }
sub BER_BIT 		() { 0x80 }

# This module is used a lot so performance matters. For that reason it
# is implemented as an ARRAY instead of a HASH.
# inlined constants for array indices

sub _BUFFER () { 0 }
sub _POS    () { 1 }
sub _INDEX  () { 2 }
sub _ERROR  () { 3 }
sub _PEER   () { 4 }

sub _PACKAGE      () { 0 }
sub _TAG          () { 1 }
sub _PACK         () { 2 }
sub _PACK_ARRAY   () { 3 }
sub _UNPACK       () { 4 }
sub _UNPACK_ARRAY () { 5 }

{
  Convert::BER->define(
    ##
    ## Syntax operator
    ##

    [ BER          => undef, undef ],
    [ ANY          => undef, undef ],
    [ CONSTRUCTED  => undef, undef ],
    [ OPTIONAL     => undef, undef ],
    [ CHOICE       => undef, undef ],

    ##
    ## Primitive operators
    ##

    [ BOOLEAN     => undef, BER_UNIVERSAL | BER_PRIMITIVE   | BER_BOOLEAN    ],
    [ INTEGER     => undef, BER_UNIVERSAL | BER_PRIMITIVE   | BER_INTEGER    ],
    [ STRING      => undef, BER_UNIVERSAL | BER_PRIMITIVE   | BER_OCTET_STR  ],
    [ NULL        => undef, BER_UNIVERSAL | BER_PRIMITIVE   | BER_NULL	     ],
    [ OBJECT_ID   => undef, BER_UNIVERSAL | BER_PRIMITIVE   | BER_OBJECT_ID  ],
    [ BIT_STRING  => undef, BER_UNIVERSAL | BER_PRIMITIVE   | BER_BIT_STR    ],
    [ BIT_STRING8 => undef, BER_UNIVERSAL | BER_PRIMITIVE   | BER_BIT_STR    ],
    [ REAL	  => undef, BER_UNIVERSAL | BER_PRIMITIVE   | BER_REAL       ],

    [ SEQUENCE    => undef, BER_UNIVERSAL | BER_CONSTRUCTOR | BER_SEQUENCE   ],
    [ SEQUENCE_OF => undef, BER_UNIVERSAL | BER_CONSTRUCTOR | BER_SEQUENCE   ],
  );

  ##
  ## These variables will be defined by the above ->define() call
  ##

  use vars qw($INTEGER $SEQUENCE $STRING $SEQUENCE_OF);

  Convert::BER->define(
    ##
    ## Sub-classed primitive operators
    ##

    [ ENUM   => $INTEGER,     BER_UNIVERSAL | BER_PRIMITIVE   | BER_ENUMERATED ],
    [ SET    => $SEQUENCE,    BER_UNIVERSAL | BER_CONSTRUCTOR | BER_SET        ],
    [ SET_OF => $SEQUENCE_OF, BER_UNIVERSAL | BER_CONSTRUCTOR | BER_SET        ],

    [ ObjectDescriptor => $STRING, BER_UNIVERSAL |  7],
    [ UTF8String       => $STRING, BER_UNIVERSAL | 12],
    [ NumericString    => $STRING, BER_UNIVERSAL | 18],
    [ PrintableString  => $STRING, BER_UNIVERSAL | 19],
    [ TeletexString    => $STRING, BER_UNIVERSAL | 20],
    [ T61String        => $STRING, BER_UNIVERSAL | 20],
    [ VideotexString   => $STRING, BER_UNIVERSAL | 21],
    [ IA5String        => $STRING, BER_UNIVERSAL | 22],
    [ GraphicString    => $STRING, BER_UNIVERSAL | 25],
    [ VisibleString    => $STRING, BER_UNIVERSAL | 26],
    [ ISO646String     => $STRING, BER_UNIVERSAL | 26],
    [ GeneralString    => $STRING, BER_UNIVERSAL | 27],
    [ UTCTime          => $STRING, BER_UNIVERSAL | 23],
    [ GeneralizedTime  => $STRING, BER_UNIVERSAL | 24],
  );

  Convert::BER->define(
    [ '_Time_generic' => $STRING, undef ],
    [ TimeUZ  => '_Time_generic', BER_UNIVERSAL | 23],
    [ TimeUL  => '_Time_generic', BER_UNIVERSAL | 23],

    [ TimeGZ  => '_Time_generic', BER_UNIVERSAL | 24],
    [ TimeGL  => '_Time_generic', BER_UNIVERSAL | 24],
  );
}

# only load Carp when needed

sub croak {
    require Carp;
    goto &Carp::croak;
}

##
## define:
##	does all the hard work of dynamically building the BER class
##	and BER-type classes
##

sub define {
    my $pkg = shift;

    no strict 'refs'; # we do some naughty stuff here :-)

    $pkg = ref($pkg) || $pkg;

    while(@_) {
	my($name,$isa,$tag) = @{ $_[0] }; shift;
	my $subpkg = $pkg . "::" . $name;

	croak("Bad tag name '$name'")
		if($name =~ /\A(?:DESTROY|VERSION)\Z/);

	if(defined $isa) {
	    my $isapkg = $pkg->can('_' . $isa) or
		croak "Unknown BER tag type '$isa'";

	    @{$subpkg . "::ISA"} = ( &{$isapkg}()->[ _PACKAGE ] )
		unless @{$subpkg . "::ISA"};

	    $tag = $subpkg->tag
		unless defined $tag;
	}

	if(defined &{$subpkg . "::tag"}) {
	    croak "tags for '$name' do not match "
		unless $subpkg->tag == $tag;
	}
	else {
	    *{$subpkg . "::tag"} = sub { $tag };
	}

	push(@{$pkg . "::EXPORT_OK"}, '$' . $name, $name);

	*{$pkg . "::"  . $name} = \$name;

	my @data = ( $subpkg, $subpkg->tag,
		     map { $subpkg->can($_) }
		         qw(pack pack_array unpack unpack_array)
		   );

	{
	    my $const = $tag;
	    *{$pkg . "::" . $name} = sub () { $const }
		unless defined &{$pkg . "::" . $name};
	}

	*{$pkg . "::_" . $name} = sub { \@data };
    }
}

# Now we have done the naughty stuff, make sure we do no more
use strict;

sub ber_tag {
  my($t,$e) = @_;
  $e ||= 0; # unsigned;

  if($e < 30) {
    return (($t & 0xe0) | $e);
  }

  $t = ($t | 0x1f) & 0xff;
  if ($e & 0xffe00000) {
    die "Too big";
  }
  my @t = ();

  push(@t, ($b >> 14) | 0x80)
    if ($b = ($e & 0x001fc000));

  push(@t, ($b >> 7) | 0x80)
    if ($b = ($e & 0xffffff80));

  unpack("V",pack("C4",$t,@t,$e & 0x7f,0,0));
}

sub new {
    my $package = shift;
    my $class = ref($package) || $package;

    my $self = bless [
	@_ == 1 ? shift : "",
	0,
	ref($package) ? $package->[ Convert::BER::_INDEX() ] : [],
    ], $class;

    @_ ? $self->encode(@_) : $self;
}

##
## Some basic subs for packing/unpacking data
## These methods would be called by the BER-type classes
##

sub num_length {
    return 1 if ( ($_[0] &     0xff) == $_[0]);
    return 2 if ( ($_[0] &   0xffff) == $_[0]);
    return 3 if ( ($_[0] & 0xffffff) == $_[0]);
    return 4;
}

sub pos {
    my $ber = shift;
    @_ ? ($ber->[ Convert::BER::_POS() ] = shift)
       : $ber->[ Convert::BER::_POS() ];
}

sub pack {
    my $ber = shift;
    $ber->[ Convert::BER::_BUFFER() ] .= $_[0];
    1;
}

sub unpack {
    my($ber,$len) = @_;
    my $pos = $ber->[ Convert::BER::_POS() ];
    my $npos = $pos + $len;

    die "Buffer empty"
	if ($npos > CORE::length($ber->[ Convert::BER::_BUFFER() ]));

    $ber->[ Convert::BER::_POS() ] = $npos;

    substr($ber->[ Convert::BER::_BUFFER() ],$pos,$len);
}

sub pack_tag {
    my($ber,$tag) = @_;

    # small tag number are more common, so check $tag size in reverse order
    unless(($tag & 0x1f) == 0x1f) {
	$ber->[ Convert::BER::_BUFFER() ] .= chr( $tag );
        return 1;
    }

    unless($tag & ~0x7fff) {
        $ber->[ Convert::BER::_BUFFER() ] .= CORE::pack("v",$tag);
	return 2;
    }

    unless($tag & ~0x7fffff) {
        $ber->[ Convert::BER::_BUFFER() ] .= CORE::pack("vc",$tag, ($tag >> 16));
	return 3;
    }

    $ber->[ Convert::BER::_BUFFER() ] .= CORE::pack("V",$tag);
    return 4;
}

sub unpack_tag {
    my($ber,$expect) = @_;
    my $pos = $ber->[ Convert::BER::_POS() ];
    my $len = CORE::length($ber->[ Convert::BER::_BUFFER() ]);

    die "Buffer empty"
        if($pos >= $len);

    my $tag = CORE::unpack("C",substr($ber->[ Convert::BER::_BUFFER() ],$pos++,1
));

    if(($tag & 0x1f) == 0x1f) {
        my $b;
        my $s = 8;

        do {
            die "Buffer empty"
                if($pos >= $len);
            $b = CORE::unpack("C",substr($ber->[ Convert::BER::_BUFFER() ],$pos++,1));
            $tag |= $b << $s;
            $s += 8;
        } while($b & 0x80);
    }

    die sprintf("Expecting tag 0x%x, found 0x%x",$expect,$tag)
        if(defined($expect) && ($tag != $expect));

    $ber->[ Convert::BER::_POS() ] = $pos;

    $tag
}

sub pack_length {
    my($ber,$len) = @_;

    if($len & ~0x7f) {
	my $lenlen = num_length($len);

	$ber->[ Convert::BER::_BUFFER() ] .= CORE::pack("C", $lenlen | 0x80) . substr(CORE::pack("N",$len), 0 - $lenlen);

	return $lenlen + 1;
    }

    $ber->[ Convert::BER::_BUFFER() ] .= CORE::pack("C", $len);
    return 1;
}



sub unpack_length {
    my $ber = shift;
    my $pos = $ber->[ Convert::BER::_POS() ];

    die "Buffer empty"
	if($pos >= CORE::length($ber->[ Convert::BER::_BUFFER() ]));

    my $len = CORE::unpack("C", substr($ber->[ Convert::BER::_BUFFER() ],$pos++,1));

    if($len & 0x80) {
	my $buf;

	$len &= 0x7f;

	die "Buffer empty"
	    if(($pos+$len) > CORE::length($ber->[ Convert::BER::_BUFFER() ]));

	my $tmp = "\0" x (4 - $len) . substr($ber->[ Convert::BER::_BUFFER() ],$pos,$len);

	$pos += $len;

	$len = $len ? CORE::unpack("N",$tmp) : -1;
    }

    $ber->[ Convert::BER::_POS() ] = $pos;

    $len;
}

##
## User interface (public) method
##

sub error {
    my $ber = shift;
    $ber->[ Convert::BER::_ERROR() ];
}


sub tag {
    my $ber = shift;
    my $pos = $ber->[ Convert::BER::_POS() ];
    my $tag = eval {
	local($SIG{'__DIE__'});
	unpack_tag($ber)
    } or return undef;
    $ber->[ Convert::BER::_POS() ] = $pos;
    $tag;
}

sub length {
    my $ber = shift;

    CORE::length($ber->[ Convert::BER::_BUFFER() ]);
}

sub buffer {
    my $ber = shift;
    if(@_) {
	$ber->[ Convert::BER::_POS() ] = 0;
	$ber->[ Convert::BER::_BUFFER() ] = "" . shift;
    }
    $ber->[ Convert::BER::_BUFFER() ];
}

##
## just for debug :-)
##

sub _hexdump {
  my($fmt,$pos) = @_[1,2]; # Don't copy buffer

  $pos ||= 0;

  my $offset  = 0;
  my $cnt     = 1 << 4;
  my $len     = CORE::length($_[0]);
  my $linefmt = ("%02X " x $cnt) . "%s\n";

  print "\n";

  while ($offset < $len) {
    my $data = substr($_[0],$offset,$cnt);
    my @y = CORE::unpack("C*",$data);

    printf $fmt,$pos if $fmt;

    # On the last time through replace '%02X ' with '__ ' for the
    # missing values
    substr($linefmt, 5*@y,5*($cnt-@y)) = "__ " x ($cnt - @y)
	if @y != $cnt;

    # Change non-printable chars to '.'
    $data =~ s/[\x00-\x1f\x7f-\xff]/./sg;
    printf $linefmt, @y,$data;

    $offset += $cnt;
    $pos += $cnt;
  }
}

my %type = (
  split(/[\t\n]\s*/,
    q(10	SEQUENCE
      01	BOOLEAN
      0A	ENUM
      11	SET
      02	INTEGER
      03	BIT STRING
      C0	PRIVATE [%d]
      04	STRING
      40	APPLICATION [%d]
      05	NULL
      06	OBJECT ID
      80	CONTEXT [%d]
    )
  )
);

sub dump {
  my $ber = shift;
  my $fh = @_ ? shift : \*STDERR;

  my $ofh = select($fh);

  my $pos = 0;
  my $indent = "";
  my @seqend = ();
  my $length = CORE::length($ber->[ Convert::BER::_BUFFER() ]);
  my $fmt = $length > 0xffff ? "%08X" : "%04X";

  local $ber->[ Convert::BER::_POS() ];

  $ber->[ Convert::BER::_POS() ] = 0;

  while(1) {
    while (@seqend && $ber->[ Convert::BER::_POS() ] >= $seqend[0]) {
      $indent = substr($indent,2);
      shift @seqend;
      printf "$fmt        : %s}\n",$ber->[ Convert::BER::_POS() ],$indent;
    }
    last unless $ber->[ Convert::BER::_POS() ] < $length;

    my $start = $ber->[ Convert::BER::_POS() ];
    my $tag = unpack_tag($ber);
    my $pos = $ber->[ Convert::BER::_POS() ];
    my $len = Convert::BER::unpack_length($ber);

    if($tag == 0 && $len == 0) {
      $seqend[0] = 0;
      redo;
    }
    printf $fmt. " %02X %4d: %s",$start,$tag,$len,$indent;

    my $label = $type{sprintf("%02X",$tag & ~0x20)}
		|| $type{sprintf("%02X",$tag & 0xC0)}
		|| "UNIVERSAL [%d]";

    if (($tag & 0x1f) == 0x1f) {
      my $k = $tag >> 8;
      my $j = 0;
      while($k) {
        $j = ($j << 7) | ($k & 0x7f);
       $k >>= 8;
      }
      my $l = $label;
      $l =~ s/%d/0x%x/;
      printf $l, $j;
    }
    else {
      printf $label, $tag & ~0xE0;
    }

    if ($tag & BER_CONSTRUCTOR) {
      print " {\n";
      if($len < 0) {
          unshift(@seqend, ~(1<<31));
      }
      else {
          unshift(@seqend, $ber->[ Convert::BER::_POS() ] + $len);
      }
      $indent .= "  ";
      next;
    }

    $ber->[ Convert::BER::_POS() ] = $pos;
    my $tmp;

    for ($label) { # switch
      /^INTEGER/ && do {
	Convert::BER::INTEGER->unpack($ber,\$tmp);
	printf " = %d\n",$tmp;
        last;
      };

      /^ENUM/ && do {
	Convert::BER::ENUM->unpack($ber,\$tmp);
	printf " = %d\n",$tmp;
        last;
      };

      /^BOOLEAN/ && do {
	Convert::BER::BOOLEAN->unpack($ber,\$tmp);
	printf " = %s\n",$tmp ? 'TRUE' : 'FALSE';
        last;
      };

      /^OBJECT ID/ && do {
	Convert::BER::OBJECT_ID->unpack($ber,\$tmp);
	printf " = %s\n",$tmp;
        last;
      };

      /^NULL/ && do {
        $ber->[ Convert::BER::_POS() ] = $pos+1;
	print "\n";
        last;
      };

      /^STRING/ && do {
	Convert::BER::STRING->unpack($ber,\$tmp);
	if ($tmp =~ /[\x00-\x1f\x7f-\xff]/s) {
  	  _hexdump($tmp,$fmt . "        :   ".$indent, $pos);
	}
	else {
	  printf " = '%s'\n",$tmp;
	}
        last;
      };

      /^BIT STRING/ && do {
	Convert::BER::BIT_STRING->unpack($ber,\$tmp);
	print " = ",$tmp,"\n";
        last;
      };

      # default -- dump hex data
      Convert::BER::STRING->unpack($ber,\$tmp);
      _hexdump($tmp,$fmt . "        :   ".$indent, $pos);
    }
  }

  select($ofh);
}

sub hexdump {
    my $ber = shift;
    my $fh = @_ ? shift : \*STDERR;
    my $ofh = select($fh);
    _hexdump($ber->[ Convert::BER::_BUFFER() ]);
    print "\n";
    select($ofh);
}

##
## And now the real guts of it, the encoding and decoding routines
##

sub encode {
    my $ber = shift;
    local($SIG{'__DIE__'});

    $ber->[ Convert::BER::_INDEX() ] = [];

    return $ber
	if eval { Convert::BER::_encode($ber,\@_) };

    $ber->[ Convert::BER::_ERROR() ] = $@;

    undef;
}

sub _encode {
    my $ber = shift;
    my $desc = shift;
    my $i = 0;

    while($i < @$desc ) {
	my $type = $desc->[$i++];
	my $arg  = $desc->[$i++];
	my $tag  = undef;

	($type,$tag) = @$type
	    if(ref($type) eq 'ARRAY');

	my $can = $ber->can('_' . $type);

	die "Unknown element '$type'"
	    unless $can;

	my $data = &$can();
        my $pkg = $data->[ Convert::BER::_PACKAGE() ];

	$tag = $data->[ Convert::BER::_TAG() ]
	    unless defined $tag;

	$arg = &{$arg}(@{$ber->[ Convert::BER::_INDEX() ]})
	    if(ref($arg) eq 'CODE');

	if(ref($arg) eq 'ARRAY') {
	    if($can = $data->[Convert::BER::_PACK_ARRAY() ]) {
		pack_tag($ber,$tag)
		    if defined $tag;

		&{$can}($pkg,$ber,$arg);
	    }
	    else {
		my $a;
		foreach $a (@$arg) {
		    pack_tag($ber,$tag)
			if defined $tag;

		    &{$data->[Convert::BER::_PACK() ]}($pkg,$ber,$a);
		}
	    }
	}
	else {
	    pack_tag($ber,$tag)
		if defined $tag;
	    &{$data->[Convert::BER::_PACK() ]}($pkg,$ber,$arg);
	}
    }

    1;
}

sub decode {
    my $ber = shift;
    my $pos = $ber->[ Convert::BER::_POS() ];
    local($SIG{'__DIE__'});

    $ber->[ Convert::BER::_INDEX() ] = [];

    return $ber
	if eval { Convert::BER::_decode($ber,\@_) };

    $ber->[ Convert::BER::_ERROR() ] = $@;
    $ber->[ Convert::BER::_POS() ]   = $pos;

    undef;
}

sub _decode {
    my $ber = shift;
    my $desc = shift;
    my $i = 0;

    my $argc;

TAG:
    for($argc = @$desc ; $argc > 0 ; $argc -= 2) {
	my $type = $desc->[$i++];
	my $arg  = $desc->[$i++];
	my $tag  = undef;

	($type,$tag) = @$type
	    if(ref($type) eq 'ARRAY');

	my $can = $ber->can('_' . $type);

	die "Unknown element '$type'"
	    unless $can;

	my $data = &$can();
	my $pkg  = $data->[ Convert::BER::_PACKAGE() ];

	$tag = $data->[ Convert::BER::_TAG() ]
	    unless defined $tag;

	$arg = &{$arg}(@{$ber->[ Convert::BER::_INDEX() ]})
	    if(ref($arg) eq 'CODE');

	if(ref($arg) eq 'ARRAY') {
	    if($data->[ Convert::BER::_UNPACK_ARRAY() ]) {

		unpack_tag($ber,$tag)
		    if(defined $tag);

		&{$data->[ Convert::BER::_UNPACK_ARRAY() ]}($pkg,$ber,$arg);
	    }
	    else {
		@$arg = ();
		while(CORE::length($ber->[ Convert::BER::_BUFFER() ]) > $ber->[ Convert::BER::_POS() ]) {
		    if(defined $tag) {
			next TAG
			    unless eval { unpack_tag($ber,$tag) };
		    }

		    push @$arg, undef;
		    &{$data->[ Convert::BER::_UNPACK() ]}($pkg,$ber,\$arg->[-1]);
		}
	    }
	}
	else {
	    eval {
		unpack_tag($ber,$tag)
		    if(defined $tag);

		&{$data->[ Convert::BER::_UNPACK() ]}($pkg,$ber,$arg);
		1;
	    } or ($$arg = undef, die);
	}
    }

   1;
}

##
## a couple of routines to interface to a file descriptor.
##

sub read {
    my $ber = shift;
    my $io  = shift;
    my $indef = shift;

    # We need to read one packet, and exactly only one packet.
    # So we have to read the first few bytes one at a time, until
    # we have enough to decode a tage and a length. We then know
    # how many more bytes to read

    $ber = $ber->new unless ref($ber);
    $ber->[ _BUFFER() ] = "" unless $indef;

    my $pos = CORE::length($ber->[ _BUFFER() ]);
    my $start = $pos;

    # The first byte is the tag
    sysread($io,$ber->[ _BUFFER() ],1,$pos++) or
	goto READ_ERR;

#    print STDERR "-"x80,"\n";
#    print STDERR CORE::unpack("H*",$ber->[ _BUFFER() ]),"\n";

    my $ch = ord(substr($ber->[ _BUFFER() ],-1));

    # Tag may be multi-byte
    if(($ch & 0x1f) == 0x1f) {
	do {
	    sysread($io, $ber->[ _BUFFER() ], 1, $pos++) or
		goto READ_ERR;

	    $ch = ord(substr($ber->[ _BUFFER() ],-1));

	} while($ch & 0x80);
    }

#    print STDERR CORE::unpack("H*",$ber->[ _BUFFER() ]),"\n";

    # The next byte will be the first byte of the length
    sysread($io, $ber->[ _BUFFER() ], 1, $pos++) or
	goto READ_ERR;

#    print STDERR CORE::unpack("H*",$ber->[ _BUFFER() ]),"\n";

    $ch = ord(substr($ber->[ _BUFFER() ],-1));
#    print STDERR CORE::unpack("H*",substr($ber->[ _BUFFER() ],-1))," $ch\n";

    # May be a multi-byte length
    if($ch & 0x80) {
	my $len = $ch & 0x7f;
	unless ($len) {
#    print STDERR CORE::unpack("H*",$ber->[ _BUFFER() ]),"\n";
	    # OK we have an indefinate length
	    while(1) {
		Convert::BER::read($ber,$io,1);
		my $p = CORE::length($ber->[ _BUFFER() ]);
		if(($p - $pos) == 2 && substr($ber->[ _BUFFER() ],-2) eq "\0\0") {
#    print STDERR CORE::unpack("H*",$ber->[ _BUFFER() ]),"\n","-"x80,"\n";
		    return $ber;
		}
		$pos = $p;
	    }
	}
	while($len) {
	    my $n = sysread($io, $ber->[ _BUFFER() ], $len, $pos) or
		goto READ_ERR;
	    $len -= $n;
	    $pos += $n;
	}
    }

#    print STDERR CORE::unpack("H*",$ber->[ _BUFFER() ]),"\n";

    # We can now unpack a tage and a length to determine how many more
    # bytes to read

    $ber->[ _POS() ] = $start;
    unpack_tag($ber);
    my $len = unpack_length($ber);

    while($len > 0) {
	my $got;

	goto READ_ERR
	    unless( $got = sysread($io, $ber->[ _BUFFER() ],$len,CORE::length($ber->[ _BUFFER() ])) );

	$len -= $got;
    }

    # Reset pos back to the beginning.
    $ber->[ _POS() ] = 0;

#    print STDERR CORE::unpack("H*",$ber->[ _BUFFER() ]),"\n";
    return $ber;

READ_ERR:
    $@ = "I/O Error $! " . CORE::unpack("H*",$ber->[ _BUFFER() ]);
    return undef;
}

sub write {
    my $ber = shift;
    my $io = shift;
    local($SIG{'__DIE__'});

    my $togo = CORE::length($ber->[ _BUFFER() ]);
    my $pos = 0;

    while($togo) {
	my $len;

	unless ($len = syswrite($io, $ber->[ _BUFFER() ],$togo,$pos)) {
	    $@ = "I/O Error $!";
	    return;
	}

	$togo -= $len;
	$pos += $len;
    }

    1;
}

sub send {
    my $ber = shift;
    my $sock = shift;

    local($SIG{'__DIE__'});

    eval {
	# Enable reporting a 'Broken pipe' error rather than dying.
	local ($SIG{PIPE}) = "IGNORE";

	@_ ? send($sock,$ber->[ _BUFFER() ],0,$_[0])
           : send($sock,$ber->[ _BUFFER() ],0);
    } or die "I/O Error: $!";
}

sub recv {
    my $ber = shift;
    my $sock = shift;

    require Socket; # for Socket::MSG_PEEK

    local $SIG{'__DIE__'};

    $ber = $ber->new unless ref($ber);
    $ber->[ _BUFFER() ] = "";

    # We do not know the size of the datagram, so we have to PEEK --GMB
    # is there an easier way to determine the packet size ??

    my $n = 128;
    die "I/O Error: $!"
	unless ((defined recv($sock,$ber->[ _BUFFER() ],$n,Socket::MSG_PEEK()))
		and not $!);

    # PEEK until we have the complete tag and length of the BER
    # packet. Use the length to determine how much data to read from
    # the socket. This is an attempt to ensure that we read the
    # entire packet and that we don't read into the next packet, if
    # there is one.

    my $len;

    # Keep reading until we've read enough of the packet to unpack
    # the BER length field.
    for(;;) {

	# If we can decode a tag and length we can detemine the length

	if(defined($len = eval {
	    $ber->[ _POS() ] = 0;
	    unpack_tag($ber);
	    unpack_length($ber)
		+ $ber->[ _POS() ];
  	         })
	   # unpack_length will return -1 for unknown length
	   && $len >= $ber->[ _POS() ]) {

	    $n = $len;
	    last;
	}

	# peek some more
	$n <<= 1;
	die "I/O Error: $!"
	    unless ((defined recv($sock,$ber->[ _BUFFER() ],$n,Socket::MSG_PEEK()))
		    and not $!);
    }

    # now we know the size, get it again but without MSG_PEEK
    # this will cause the kernel to remove the datagram from it's queue

    # If the data on the socket doesn't correspond to a valid BER
    # object, the loop above could have read something it thought was
    # the length and this loop could then block waiting for that many
    # bytes, which will never arrive. What do you do about something
    # like that?

    $ber->[ _POS() ] = 0;
    $ber->[ _BUFFER() ] = "";
    my ($read, $tmp);
    $read = 0;
    while ($read < $n) {
	$ber->[ _PEER() ] = recv($sock, $tmp, $n - $read, 0);
	die "I/O Error: $!"
	    unless ((defined ( $ber->[ _PEER() ] ) and not $!));

	$read += CORE::length($tmp);
	$ber->[ _BUFFER() ] .= $tmp;
    }
    $ber;
}

##
## The primitive packages
##

package Convert::BER::BER;

sub pack {
    my($self,$ber,$arg) = @_;

    $ber->[ Convert::BER::_BUFFER() ] .= $arg->[ Convert::BER::_BUFFER() ]
	if ref($arg);

    1;
}

sub unpack {
    my($self,$ber,$arg) = @_;

    my $len = CORE::length($ber->[ Convert::BER::_BUFFER() ]) - $ber->[ Convert::BER::_POS() ];

    $$arg = $ber->new(Convert::BER::unpack($ber,$len));

    1;
}

package Convert::BER::ANY;

sub pack {
    my($self,$ber,$arg) = @_;

    $ber->[ Convert::BER::_BUFFER() ] .= $arg->[ Convert::BER::_BUFFER() ];

    1;
}

sub unpack {
    my($self,$ber,$arg) = @_;

    my $pos = $ber->[ Convert::BER::_POS() ];
    my $tag = Convert::BER::unpack_tag($ber);
    my $len = Convert::BER::unpack_length($ber) + $ber->[ Convert::BER::_POS() ] - $pos;
    $ber->[ Convert::BER::_POS() ] = $pos;

    $$arg = $ber->new(Convert::BER::unpack($ber,$len));

    1;
}

##
##
##

package Convert::BER::BOOLEAN;

sub pack {
    my($self,$ber,$arg) = @_;

    Convert::BER::pack_length($ber,1);
    $ber->[ Convert::BER::_BUFFER() ] .= CORE::pack("c", $arg ? 0xff : 0x00);

    1;
}

sub unpack {
    my($self,$ber,$arg) = @_;

    my $len = Convert::BER::unpack_length($ber);

    $$arg = CORE::unpack("c", Convert::BER::unpack($ber,$len)) ? 1 : 0;

    1;
}

##
##
##

package Convert::BER::INTEGER;

##
## Math::BigInt support
##

sub pack_bigint {
    my($self,$ber,$arg) = @_;

    require Math::BigInt;

    my $neg = ($arg < 0) ? 1 : 0;
    my @octet = ();
    my $num = new Math::BigInt(abs($arg));

    $num -= 1 if $neg;
    while($num > 0) {
	my($i,$y) = $num->bdiv(256);
	$num = new Math::BigInt($i);
	$y = $y ^ 0xff if $neg;
	unshift(@octet,$y);
    }
    @octet = (0) unless @octet;

    my $msb = ($octet[0] & 0x80) ? 1 : 0;

    unshift(@octet,$neg ? 0xff : 0x00)
	if($neg != $msb);

    Convert::BER::pack_length($ber, scalar @octet);

    $ber->[ Convert::BER::_BUFFER() ] .= CORE::pack("C*",@octet);

    1;
}

sub unpack_bigint {
    my($self,$ber,$arg) = @_;

    require Math::BigInt;

    my $len = Convert::BER::unpack_length($ber);
    my @octet = CORE::unpack("C*",Convert::BER::unpack($ber,$len));
    my $neg = ($octet[0] & 0x80) ? 1 : 0;
    my $val = $$arg = 0;

    while(@octet) {
	my $oct = shift @octet;
	$oct = $oct ^ 0xff
	    if $neg;
	$val *= (1<<8);
	$val += $oct;
    }

    $val = -1 - $val
	if $neg;

    1;
}

##
## Math::BigInteger support
##

sub pack_biginteger {
    my($self,$ber,$arg) = @_;

    my($len,$data);
    my $offset = 0;

    require Math::BigInteger;
    # save has no concept of +/-
    my $v = $arg->cmp(new Math::BigInteger(0));

    if($v) {
	if($v < 0) {
	    my $b = $arg->bits + 8;
	    $b -= $b % 8;
	    my $tmp = new Math::BigInteger(1);
	    $tmp->lshift(new Math::BigInteger(1), $b);
	    $arg = $tmp + $arg;
	}

	$data = $arg->save;
	$len = CORE::length($data);

	my $c = ord(substr($data,0,1));

	if($c == 0) {
	    for( ; $len > 1 ; $len--, $offset++) {
		my $ch = ord(substr($data,$offset,1));
		if($ch & 0xff) {
		    if($ch & 0x80) {
			$len++;
			$offset--;
		    }
		    last;
		}
	    }
	}
	elsif($c == 0xff) {
	    for( ; $len > 1 ; $len--, $offset++) {
		my $ch = ord(substr($data,$offset,1));
		unless($ch == 0xff) {
		    unless($ch & 0x80) {
			$len++;
			$offset--;
		    }
		    last;
		}
	    }
	}
    }
    else {
	$len = 1;
	$data = CORE::pack("C",0);
    }

    Convert::BER::pack_length($ber,$len);
    $ber->[ Convert::BER::_BUFFER() ] .= substr($data,$offset);

    return 1;
}

sub unpack_biginteger {
    my($self,$ber,$arg) = @_;

    require Math::BigInteger;

    my $len = Convert::BER::unpack_length($ber);
    my $data = Convert::BER::unpack($ber,$len);
    my $int = restore Math::BigInteger $data;

    # restore has no concept of +/-
    if(ord(substr($data,0,1)) & 0x80) {
	my $tmp = new Math::BigInteger;
	$tmp->lshift(new Math::BigInteger(1), $len * 8);
	$tmp = new Math::BigInteger(0) - $tmp;
	$int = $tmp + $int;
    }
    $$arg = $int;

    return 1;
}

##
##
##

sub pack {
    my($self,$ber,$arg) = @_;

    if(ref $arg) {
	goto &pack_bigint
	    if UNIVERSAL::isa($arg,'Math::BigInt');

	goto &pack_biginteger
	    if UNIVERSAL::isa($arg,'Math::BigInteger');
    }

    my $neg = ($arg < 0) ? 1 : 0;

    my $len = Convert::BER::num_length($neg ? ~ $arg : $arg);

    my $msb = $arg & (0x80 << (($len - 1) * 8));

    $len++
	if(($msb && not($neg)) || ($neg && not($msb)));
    Convert::BER::pack_length($ber,$len);
    $ber->[ Convert::BER::_BUFFER() ] .= substr(CORE::pack("N",$arg), 0 - $len);

    1;
}

sub unpack {
    my($self,$ber,$arg) = @_;

    if( ref($arg) && ref($$arg) ) {
	goto &unpack_bigint
	    if UNIVERSAL::isa($$arg,'Math::BigInt');

	goto &unpack_biginteger
	    if UNIVERSAL::isa($$arg,'Math::BigInteger');
    }

    my $len = Convert::BER::unpack_length($ber);
    my $tmp = "\0" x (4 - $len) . Convert::BER::unpack($ber,$len);
    my $val = CORE::unpack("N",$tmp);

    $val -=  0x1 << ($len * 8)
	if($val & (0x1 << (($len * 8) - 1)));

    $$arg = $val;

    1;
}

##
##
##

package Convert::BER::NULL;

sub pack {
    my($self,$ber,$arg) = @_;

    Convert::BER::pack_length($ber,0);
}

sub unpack {
    my($self,$ber,$arg) = @_;

    Convert::BER::unpack_length($ber);

    $$arg = 1;
}

##
##
##

package Convert::BER::STRING;

sub pack {
    my($self,$ber,$arg) = @_;

    Convert::BER::pack_length($ber,CORE::length($arg));
    $ber->[ Convert::BER::_BUFFER() ] .= $arg;
}

sub unpack {
    my($self,$ber,$arg) = @_;

    my $len = Convert::BER::unpack_length($ber);
    $$arg = Convert::BER::unpack($ber,$len);

    1;
}

##
##
##

package Convert::BER::SEQUENCE;

sub pack {
    my($self,$ber,$arg) = @_;

    Convert::BER::pack_length($ber,CORE::length($arg->[ Convert::BER::_BUFFER() ]));
    $ber->[ Convert::BER::_BUFFER() ] .= $arg->[ Convert::BER::_BUFFER() ];

    1;
}

sub unpack {
    my($self,$ber,$arg) = @_;

    my $len = Convert::BER::unpack_length($ber);
    $$arg = $ber->new(Convert::BER::unpack($ber,$len));

    1;
}

sub pack_array {
    my($self,$ber,$arg) = @_;

    my $ber2 = $ber->new;

    return undef
	unless defined($ber2->_encode($arg));

    Convert::BER::pack_length($ber,CORE::length($ber2->[ Convert::BER::_BUFFER() ]));
    $ber->[ Convert::BER::_BUFFER() ] .= $ber2->[ Convert::BER::_BUFFER() ];

    1;
}

sub unpack_array {
    my($self,$ber,$arg) = @_;

    my $ber2;

    $self->unpack($ber,\$ber2);

    $ber2->_decode($arg);

    die "Sequence buffer not empty"
	if CORE::length($ber2->[ Convert::BER::_BUFFER() ]) != $ber2->[ Convert::BER::_POS() ];

    1;
}

##
##
##

package Convert::BER::OBJECT_ID;

sub pack {
    my($self,$ber,$arg) = @_;
    my @data = ($arg =~ /(\d+)/g);

    if(@data < 2) {
	@data = (0);
    }
    else {
	my $first = $data[1] + ($data[0] * 40);
	splice(@data,0,2,$first);
    }

    @data = map {
	my @d = ($_);
	if($_ >= 0x80) {
	    @d = ();
	    my $v = 0 | $_; # unsigned
	    while($v) {
		unshift(@d, 0x80 | ($v & 0x7f));
		$v >>= 7;
	    }
	    $d[-1] &= 0x7f;
	}
	@d;
    } @data;

    my $data = CORE::pack("C*", @data);

    Convert::BER::pack_length($ber,CORE::length($data));
    $ber->[ Convert::BER::_BUFFER() ] .=  $data;

    1;
}

sub unpack {
    my($self,$ber,$arg) = @_;

    my $len = Convert::BER::unpack_length($ber);
    my @ch = CORE::unpack("C*",Convert::BER::unpack($ber,$len));
    my @data = ();
    my $val = 0;
    while(@ch) {
	my $ch = shift @ch;
	$val = ($val << 7) | ($ch & 0x7f);
	unless($ch & 0x80) {
	    push @data, $val;
	    $val = 0;
	}
    }
    if(@data) {
	my $first = shift @data;
	unshift @data, $first % 40;
	unshift @data, int($first / 40);
#	unshift @data, "";
    }
    $$arg = join(".",@data);
    1;
}

##
##
##

package Convert::BER::CONSTRUCTED;

BEGIN {
    # Cannot call import here as Convert::BER has not been initialized
    *BER_CONSTRUCTOR = *Convert::BER::BER_CONSTRUCTOR
}

sub pack {
    my($self,$ber,$arg) = @_;

    Convert::BER::pack_tag($ber,$arg->tag | BER_CONSTRUCTOR);
    Convert::BER::pack_length($ber,CORE::length($arg->[ Convert::BER::_BUFFER() ]));
    $ber->[ Convert::BER::_BUFFER() ] .= $arg->[ Convert::BER::_BUFFER() ];

    1;
}

sub unpack {
    my($self,$ber,$arg) = @_;
    my $tag = Convert::BER::unpack_tag($ber);

    die "Not constructed"
	unless $tag & BER_CONSTRUCTOR;

    my $len = Convert::BER::unpack_length($ber);
    my $buf = $ber->new( Convert::BER::unpack($ber,$len));

    die &{$ber}(0,"Bad construction")
	unless( ($buf->tag | BER_CONSTRUCTOR) == $tag);

    $$arg = $buf;

    1;
}

sub pack_array {
    my($self,$ber,$arg) = @_;

    $self->_encode($arg);
}

sub unpack_array {
    my($self,$ber,$arg) = @_;

    my $ber2;

    $self->unpack($ber,\$ber2);

    $ber2->_decode($arg);
}

##
##
##

package Convert::BER::OPTIONAL;

# optional elements
# allows skipping in the encode if it comes across structures like
#   OPTIONAL => [ BOOLEAN => undef ]
# or more realistically
#   my $foo = undef;
#   $foo = 1 if (arg->{'allowed'};
#   $ber->encode(SEQUENCE => [
#                    STRING => $name,
#                    OPTIONAL => [ BOOLEAN => $foo ]
#                 ]);

sub pack_array {
    my($self,$ber,$arg) = @_;
    my $a;
    my @newarg;
    foreach $a (@$arg) {
        return unless defined $a;
        my $c = ref($a) eq "CODE"
                        ? &{$a}(@{$ber->[ Convert::BER::_INDEX() ]})
                        : $a;
        return unless defined $c;
        push @newarg, $c;
    }

    shift @newarg if (@newarg & 1);

    Convert::BER::_encode($ber,\@newarg);
}

sub unpack_array {
    my($self,$ber,$arg) = @_;
    my($yes,$ref);
    my $pos = $ber->[ Convert::BER::_POS() ];

    if(@$arg & 1) {
	$ref = [ @$arg ];
	$yes = shift @$ref;
    }
    else {
        $ref = $arg;
    }

    if (eval { Convert::BER::_decode($ber,$ref) }) {
	$$yes = 1 if ref($yes);
    }
    else {
	$$yes = undef if ref($yes);
	$ber->[ Convert::BER::_POS() ] = $pos;
    }

    1;
}

##
##
##

package Convert::BER::SEQUENCE_OF;

sub pack_array {
    my($self,$ber,$arg) = @_;
    my($n,@desc) = @$arg;
    my $i;

    $n = &{$n}(@{$ber->[ Convert::BER::_INDEX() ]})
	if ref($n) eq 'CODE';

    push(@{$ber->[ Convert::BER::_INDEX() ]},0);

    my $b = $ber->new;

    if(ref($n) eq 'HASH') {
	my $v;
	foreach $v (keys %$n) {
	    $ber->[ Convert::BER::_INDEX() ][-1] = $v;
	    $b->_encode(\@desc);
	}
    }
    elsif(ref($n) eq 'ARRAY') {
	my $v;
	foreach $v (@$n) {
	    $ber->[ Convert::BER::_INDEX() ][-1] = $v;
	    $b->_encode(\@desc);
	}
    }
    else {
	while($n--) {
	    $b->_encode(\@desc);
	    $ber->[ Convert::BER::_INDEX() ][-1] += 1;
	}
    }

    pop @{$ber->[ Convert::BER::_INDEX() ]};

    Convert::BER::pack_length($ber,CORE::length($b->[ Convert::BER::_BUFFER() ]));
    $ber->[ Convert::BER::_BUFFER() ] .= $b->[ Convert::BER::_BUFFER() ];

    1;
}

sub unpack_array {
    my($self,$ber,$arg) = @_;
    my($nref,@desc) = @$arg;

    push(@{$ber->[ Convert::BER::_INDEX() ]},0);

    my $len = Convert::BER::unpack_length($ber);
    my $b   = $ber->new(Convert::BER::unpack($ber,$len));
    my $pos = $ber->[ Convert::BER::_POS() ];
    my $n;

    while(CORE::length($b->[ Convert::BER::_BUFFER() ]) > $b->[ Convert::BER::_POS() ]) {
	$b->_decode(\@desc);
	$ber->[ Convert::BER::_INDEX() ][-1] += 1;
    }

    $$nref = pop @{$ber->[ Convert::BER::_INDEX() ]};
    1;
}

##
##
##

package Convert::BER::BIT_STRING;

sub pack {
    my($self,$ber,$arg) = @_;

    my $less = (8 - (CORE::length($arg) & 7)) & 7;
    $arg .= "0" x $less if $less;
    my $data = CORE::pack("B*",$arg);
    Convert::BER::pack_length($ber,CORE::length($data)+1);
    $ber->[ Convert::BER::_BUFFER() ] .= chr($less) . $data;
}

sub unpack {
    my($self,$ber,$arg) = @_;

    my $len  = Convert::BER::unpack_length($ber);
    my $data = Convert::BER::unpack($ber,$len);
    my $less;
    ($less,$data) = CORE::unpack("C B*",$data,);
    $less = ord($less) & 7;
    substr($data,-$less) = '' if $less;
    $$arg = $data;
    1;
}

##
##
##

package Convert::BER::BIT_STRING8;

sub pack {
    my($self,$ber,$arg) = @_;

    Convert::BER::pack_length($ber,CORE::length($arg)+1);
    $ber->[ Convert::BER::_BUFFER() ] .= chr(0) . $arg;
}

sub unpack {
    my($self,$ber,$arg) = @_;

    my $len  = Convert::BER::unpack_length($ber);
    my $less = Convert::BER::unpack($ber,1);
    my $data = $len > 1 ? Convert::BER::unpack($ber,$len-1) : "";
    $$arg = $data;
    1;
}

##
##
##

package Convert::BER::REAL;

sub pack {
  my($self,$ber,$arg) = @_;
  require POSIX;
  my $data = "";

  if($arg) {
    my $s = 128;
    if($arg < 0) {
      $s |= 64;
      $arg = -$arg;
    }
    my @e = ();
    my @m = ();
    my($v,$e) = POSIX::frexp($arg);
    $e -= 53;
    my $ae = abs($e);

    if($ae < 0x80) {
      @e = ($e & 0xff);
    }
    elsif($ae < 0x8000) {
      @e = map { $_ & 0xff } ($e>>8,$e);
      $s |= 1;
    }
    elsif($ae < 0x800000) {
      @e = map { $_ & 0xff } ($e>>16,$e>>8,$e);
      $s |= 2;
    }
    else {
      @e = (4, map { $_ & 0xff } ($e>>24,$e>>16,$e>>8,$e));
      $s |= 3;
    }

    $v = POSIX::ldexp($v,5);
    my $f = POSIX::floor($v);
    my $i = int($f);
    @m = ($i & 0xff);
    $v -= $f;
    for (1..2) {
      $v = POSIX::ldexp($v,24);
      $f = POSIX::floor($v);
      $i = int($f);
      push @m, ($i >> 16) & 0xff, ($i >> 8) & 0xff, $i & 0xff;
      $v -= $f;
    }
    $data = pack("C*",$s,@e,@m);
  }
  my $len = length($data);
  Convert::BER::pack_length($ber,$len);
  Convert::BER::pack($ber,$data) if $len;
}

my @base = (1,3,4,4);

sub unpack {
  my($self,$ber,$arg) = @_;

  my $len = Convert::BER::unpack_length($ber);
  unless($len) {
    $$arg = undef;
    return 1;
  }
  my $data = Convert::BER::unpack($ber,$len);
  my $byte = unpack("C*",$data);

  if($byte & 0x80) {
    $data = reverse $data;
    chop($data);
    require POSIX; # The sins for using REAL
    my $base = $base[($byte & 0x30) >> 4];
    my $scale = $base & 0xC;
    my $elen = $byte & 0x3;

    $elen = ord(chop($data)) - 1 if $elen == 3;

    die "Bad REAL encoding" unless $elen >= 0 && $elen <= 3;

    my $exp = ord chop($data);
    $exp = -256 + $exp if $exp > 127;

    while ($elen--) {
      $exp *= 256;
      $exp += ord chop($data);
    }

    $exp = $exp * $base + $scale;

    my $v = 0;
    while(length($data)) {
      $v = POSIX::ldexp($v,8) + ord chop($data);
    }

    $v = POSIX::ldexp($v,$exp) if $exp;
    $v = -1 * $v if $byte & 0x40; # negative

    $$arg = $v;
  }
  elsif($byte & 0x40) {
    require POSIX;
    $$arg = POSIX::HUGE_VAL() * (($byte & 1) ? -1 : 1);
  }
  elsif(substr($data,1) =~ /^\s*([-+]?)0*(\d+(?:\.\d+(?:[Ee][-+]?\d+)?)?)\s*$/) {
    $$arg = eval "$1$2";
  }
  else {
    $$arg = undef;
  }
  1;
}

##
##
##

package Convert::BER::_Time_generic;

sub pack {
    my($self,$ber,$arg) = @_;

    my $islocal = $self->isa('Convert::BER::TimeUL')
		|| $self->isa('Convert::BER::TimeGL');
    my $isgen = $self->isa('Convert::BER::TimeGL')
		|| $self->isa('Convert::BER::TimeGZ');
    my @time = $islocal ? localtime($arg) : gmtime($arg);
    my $off = 'Z';

    if($islocal) {
      my @g = gmtime($arg);
      my $v = ($time[1] - $g[1]) + ($time[2] - $g[2]) * 60;
      my $d = $time[7] - $g[7];
      if($d == 1 || $d < -1) {
	$v += 1440;
      }
      elsif($d > 1) {
	$v -= 1440;
      }
      $off = sprintf("%+03d%02d",$v / 60, abs($v % 60));
    }

    $time[4] += 1;
    $time[5] = $isgen ? $time[5] + 1900 : $time[5] % 100;
    my $str = sprintf("%02d"x6, @time[5,4,3,2,1,0]);
    if($isgen) {
      my $split = $arg - int($arg);
      $str .= sprintf(".%03d", int($split * 1000)) if($split);
    }
    Convert::BER::STRING::pack($self,$ber,$str . $off);
}

sub unpack {
    my($self,$ber,$arg) = @_;
    my $str;
    if(Convert::BER::STRING::unpack($self,$ber,\$str)) {
      my $isgen = $self->isa('Convert::BER::TimeGL')
		|| $self->isa('Convert::BER::TimeGZ');
      my $n = $isgen ? 4 : 2;
      my ($Y,$M,$D,$h,$m,$s,$z) = $str =~ /^
        (\d{$n})
	(\d\d)
	(\d\d)
	(\d\d)
	(\d\d)
	((?:\d\d(?:\.\d+)?)?)
	(Z|[-+]\d{4})
      $/x or die "Bad Time string '$str'";
      my $offset = 0;
      if($z ne 'Z') {
        use integer;
	$offset = ((($z / 100) * 60) + ($z % 100)) * 60;
      }
      if($s > int($s)) { # fraction of a seccond
        $offset -= ($s - int($s));
      }
      $M -= 1;
      if($isgen) {	# GeneralizedTime uses 4-digit years
	$Y -= 1900;
      }
      elsif($Y <= 50) {	# ASN.1 UTCTime
	$Y += 100;	# specifies <=50 = 2000..2050, >50 = 1951..1999
      }
      require Time::Local;
      $$arg = Time::Local::timegm(int($s),$m,$h,$D,$M,$Y) - $offset;
    }
}

package Convert::BER::CHOICE;

sub pack_array {
    my($self,$ber,$arg) = @_;
    my $n = $arg->[0];

    if(defined($n)) {
	my $i = ($n * 2) + 2;
	die "Bad CHOICE index $n" if $n < 0 || $i > @$arg;
	$ber->_encode([$arg->[$i-1], $arg->[$i]]);
    }
    1;
}

sub unpack_array {
    my($self,$ber,$arg) = @_;
    my($i,$m,$err);

    $m = @$arg;
    my $want = Convert::BER::tag($ber);

    for($i = 1 ; $i < $m ; $i += 2) {
      my $tag;
      my $type = $arg->[$i];

      ($type,$tag) = @$type
	  if(ref($type) eq 'ARRAY');

      my $can = UNIVERSAL::can($ber,'_' . $type);

      die "Unknown element '$type'"
	  unless $can;

      my $data = &$can();

      $tag = $data->[ Convert::BER::_TAG() ]
	  unless defined $tag;

      next unless $tag == $want;

      if ( eval { Convert::BER::_decode($ber,[@{$arg}[$i,$i+1]]) }) {
	my $choice = $arg->[0];
	$$choice = ($i - 1) >> 1;
	return 1;
      }
      $err = $@ if $@;
    }
    die ($err || sprintf("Cannot decode CHOICE, found tag 0x%X\n",$want));
}

1;