1# Convert::BER.pm
2#
3# Copyright (c) 1995-1999 Graham Barr <gbarr@pobox.com>. All rights reserved.
4# This program is free software; you can redistribute it and/or
5# modify it under the same terms as Perl itself.
6
7package Convert::BER;
8
9use vars qw($VERSION @ISA);
10use Exporter ();
11use strict;
12use vars qw($VERSION @ISA @EXPORT_OK);
13
14BEGIN {
15    if ($] >= 5.006) {
16	require bytes; 'bytes'->import;
17    }
18
19    $VERSION = "1.32";
20
21    @ISA = qw(Exporter);
22
23    @EXPORT_OK = qw(
24	BER_BOOLEAN
25	BER_INTEGER
26	BER_BIT_STR
27	BER_OCTET_STR
28	BER_NULL
29	BER_OBJECT_ID
30	BER_REAL
31	BER_SEQUENCE
32	BER_SET
33
34	BER_UNIVERSAL
35	BER_APPLICATION
36	BER_CONTEXT
37	BER_PRIVATE
38
39	BER_PRIMITIVE
40	BER_CONSTRUCTOR
41
42	BER_LONG_LEN
43	BER_EXTENSION_ID
44	BER_BIT
45
46	ber_tag
47    );
48
49    # 5.003 does not have UNIVERSAL::can
50    unless(defined &UNIVERSAL::can) {
51        *UNIVERSAL::can = sub {
52            my($obj,$meth) = @_;
53            my $pkg = ref($obj) || $obj;
54            my @pkg = ($pkg);
55            my %done;
56            while(@pkg) {
57                $pkg = shift @pkg;
58                next if exists $done{$pkg};
59                $done{$pkg} = 1;
60
61                no strict 'refs';
62
63                unshift @pkg,@{$pkg . "::ISA"}
64                    if(@{$pkg . "::ISA"});
65                return \&{$pkg . "::" . $meth}
66                    if defined(&{$pkg . "::" . $meth});
67            }
68            undef;
69        }
70    }
71}
72
73##
74## Constants
75##
76
77sub BER_BOOLEAN 	() { 0x01 }
78sub BER_INTEGER 	() { 0x02 }
79sub BER_BIT_STR 	() { 0x03 }
80sub BER_OCTET_STR 	() { 0x04 }
81sub BER_NULL 		() { 0x05 }
82sub BER_OBJECT_ID 	() { 0x06 }
83sub BER_REAL 		() { 0x09 }
84sub BER_ENUMERATED	() { 0x0A }
85sub BER_SEQUENCE 	() { 0x10 }
86sub BER_SET 		() { 0x11 }
87sub BER_PRINT_STR	() { 0x13 }
88sub BER_IA5_STR		() { 0x16 }
89sub BER_UTC_TIME	() { 0x17 }
90sub BER_GENERAL_TIME	() { 0x18 }
91
92sub BER_UNIVERSAL 	() { 0x00 }
93sub BER_APPLICATION 	() { 0x40 }
94sub BER_CONTEXT 	() { 0x80 }
95sub BER_PRIVATE		() { 0xC0 }
96
97sub BER_PRIMITIVE	() { 0x00 }
98sub BER_CONSTRUCTOR	() { 0x20 }
99
100sub BER_LONG_LEN	() { 0x80 }
101sub BER_EXTENSION_ID	() { 0x1F }
102sub BER_BIT 		() { 0x80 }
103
104# This module is used a lot so performance matters. For that reason it
105# is implemented as an ARRAY instead of a HASH.
106# inlined constants for array indices
107
108sub _BUFFER () { 0 }
109sub _POS    () { 1 }
110sub _INDEX  () { 2 }
111sub _ERROR  () { 3 }
112sub _PEER   () { 4 }
113
114sub _PACKAGE      () { 0 }
115sub _TAG          () { 1 }
116sub _PACK         () { 2 }
117sub _PACK_ARRAY   () { 3 }
118sub _UNPACK       () { 4 }
119sub _UNPACK_ARRAY () { 5 }
120
121{
122  Convert::BER->define(
123    ##
124    ## Syntax operator
125    ##
126
127    [ BER          => undef, undef ],
128    [ ANY          => undef, undef ],
129    [ CONSTRUCTED  => undef, undef ],
130    [ OPTIONAL     => undef, undef ],
131    [ CHOICE       => undef, undef ],
132
133    ##
134    ## Primitive operators
135    ##
136
137    [ BOOLEAN     => undef, BER_UNIVERSAL | BER_PRIMITIVE   | BER_BOOLEAN    ],
138    [ INTEGER     => undef, BER_UNIVERSAL | BER_PRIMITIVE   | BER_INTEGER    ],
139    [ STRING      => undef, BER_UNIVERSAL | BER_PRIMITIVE   | BER_OCTET_STR  ],
140    [ NULL        => undef, BER_UNIVERSAL | BER_PRIMITIVE   | BER_NULL	     ],
141    [ OBJECT_ID   => undef, BER_UNIVERSAL | BER_PRIMITIVE   | BER_OBJECT_ID  ],
142    [ BIT_STRING  => undef, BER_UNIVERSAL | BER_PRIMITIVE   | BER_BIT_STR    ],
143    [ BIT_STRING8 => undef, BER_UNIVERSAL | BER_PRIMITIVE   | BER_BIT_STR    ],
144    [ REAL	  => undef, BER_UNIVERSAL | BER_PRIMITIVE   | BER_REAL       ],
145
146    [ SEQUENCE    => undef, BER_UNIVERSAL | BER_CONSTRUCTOR | BER_SEQUENCE   ],
147    [ SEQUENCE_OF => undef, BER_UNIVERSAL | BER_CONSTRUCTOR | BER_SEQUENCE   ],
148  );
149
150  ##
151  ## These variables will be defined by the above ->define() call
152  ##
153
154  use vars qw($INTEGER $SEQUENCE $STRING $SEQUENCE_OF);
155
156  Convert::BER->define(
157    ##
158    ## Sub-classed primitive operators
159    ##
160
161    [ ENUM   => $INTEGER,     BER_UNIVERSAL | BER_PRIMITIVE   | BER_ENUMERATED ],
162    [ SET    => $SEQUENCE,    BER_UNIVERSAL | BER_CONSTRUCTOR | BER_SET        ],
163    [ SET_OF => $SEQUENCE_OF, BER_UNIVERSAL | BER_CONSTRUCTOR | BER_SET        ],
164
165    [ ObjectDescriptor => $STRING, BER_UNIVERSAL |  7],
166    [ UTF8String       => $STRING, BER_UNIVERSAL | 12],
167    [ NumericString    => $STRING, BER_UNIVERSAL | 18],
168    [ PrintableString  => $STRING, BER_UNIVERSAL | 19],
169    [ TeletexString    => $STRING, BER_UNIVERSAL | 20],
170    [ T61String        => $STRING, BER_UNIVERSAL | 20],
171    [ VideotexString   => $STRING, BER_UNIVERSAL | 21],
172    [ IA5String        => $STRING, BER_UNIVERSAL | 22],
173    [ GraphicString    => $STRING, BER_UNIVERSAL | 25],
174    [ VisibleString    => $STRING, BER_UNIVERSAL | 26],
175    [ ISO646String     => $STRING, BER_UNIVERSAL | 26],
176    [ GeneralString    => $STRING, BER_UNIVERSAL | 27],
177    [ UTCTime          => $STRING, BER_UNIVERSAL | 23],
178    [ GeneralizedTime  => $STRING, BER_UNIVERSAL | 24],
179  );
180
181  Convert::BER->define(
182    [ '_Time_generic' => $STRING, undef ],
183    [ TimeUZ  => '_Time_generic', BER_UNIVERSAL | 23],
184    [ TimeUL  => '_Time_generic', BER_UNIVERSAL | 23],
185
186    [ TimeGZ  => '_Time_generic', BER_UNIVERSAL | 24],
187    [ TimeGL  => '_Time_generic', BER_UNIVERSAL | 24],
188  );
189}
190
191# only load Carp when needed
192
193sub croak {
194    require Carp;
195    goto &Carp::croak;
196}
197
198##
199## define:
200##	does all the hard work of dynamically building the BER class
201##	and BER-type classes
202##
203
204sub define {
205    my $pkg = shift;
206
207    no strict 'refs'; # we do some naughty stuff here :-)
208
209    $pkg = ref($pkg) || $pkg;
210
211    while(@_) {
212	my($name,$isa,$tag) = @{ $_[0] }; shift;
213	my $subpkg = $pkg . "::" . $name;
214
215	croak("Bad tag name '$name'")
216		if($name =~ /\A(?:DESTROY|VERSION)\Z/);
217
218	if(defined $isa) {
219	    my $isapkg = $pkg->can('_' . $isa) or
220		croak "Unknown BER tag type '$isa'";
221
222	    @{$subpkg . "::ISA"} = ( &{$isapkg}()->[ _PACKAGE ] )
223		unless @{$subpkg . "::ISA"};
224
225	    $tag = $subpkg->tag
226		unless defined $tag;
227	}
228
229	if(defined &{$subpkg . "::tag"}) {
230	    croak "tags for '$name' do not match "
231		unless $subpkg->tag == $tag;
232	}
233	else {
234	    *{$subpkg . "::tag"} = sub { $tag };
235	}
236
237	push(@{$pkg . "::EXPORT_OK"}, '$' . $name, $name);
238
239	*{$pkg . "::"  . $name} = \$name;
240
241	my @data = ( $subpkg, $subpkg->tag,
242		     map { $subpkg->can($_) }
243		         qw(pack pack_array unpack unpack_array)
244		   );
245
246	{
247	    my $const = $tag;
248	    *{$pkg . "::" . $name} = sub () { $const }
249		unless defined &{$pkg . "::" . $name};
250	}
251
252	*{$pkg . "::_" . $name} = sub { \@data };
253    }
254}
255
256# Now we have done the naughty stuff, make sure we do no more
257use strict;
258
259sub ber_tag {
260  my($t,$e) = @_;
261  $e ||= 0; # unsigned;
262
263  if($e < 30) {
264    return (($t & 0xe0) | $e);
265  }
266
267  $t = ($t | 0x1f) & 0xff;
268  if ($e & 0xffe00000) {
269    die "Too big";
270  }
271  my @t = ();
272
273  push(@t, ($b >> 14) | 0x80)
274    if ($b = ($e & 0x001fc000));
275
276  push(@t, ($b >> 7) | 0x80)
277    if ($b = ($e & 0xffffff80));
278
279  unpack("V",pack("C4",$t,@t,$e & 0x7f,0,0));
280}
281
282sub new {
283    my $package = shift;
284    my $class = ref($package) || $package;
285
286    my $self = bless [
287	@_ == 1 ? shift : "",
288	0,
289	ref($package) ? $package->[ Convert::BER::_INDEX() ] : [],
290    ], $class;
291
292    @_ ? $self->encode(@_) : $self;
293}
294
295##
296## Some basic subs for packing/unpacking data
297## These methods would be called by the BER-type classes
298##
299
300sub num_length {
301    return 1 if ( ($_[0] &     0xff) == $_[0]);
302    return 2 if ( ($_[0] &   0xffff) == $_[0]);
303    return 3 if ( ($_[0] & 0xffffff) == $_[0]);
304    return 4;
305}
306
307sub pos {
308    my $ber = shift;
309    @_ ? ($ber->[ Convert::BER::_POS() ] = shift)
310       : $ber->[ Convert::BER::_POS() ];
311}
312
313sub pack {
314    my $ber = shift;
315    $ber->[ Convert::BER::_BUFFER() ] .= $_[0];
316    1;
317}
318
319sub unpack {
320    my($ber,$len) = @_;
321    my $pos = $ber->[ Convert::BER::_POS() ];
322    my $npos = $pos + $len;
323
324    die "Buffer empty"
325	if ($npos > CORE::length($ber->[ Convert::BER::_BUFFER() ]));
326
327    $ber->[ Convert::BER::_POS() ] = $npos;
328
329    substr($ber->[ Convert::BER::_BUFFER() ],$pos,$len);
330}
331
332sub pack_tag {
333    my($ber,$tag) = @_;
334
335    # small tag number are more common, so check $tag size in reverse order
336    unless(($tag & 0x1f) == 0x1f) {
337	$ber->[ Convert::BER::_BUFFER() ] .= chr( $tag );
338        return 1;
339    }
340
341    unless($tag & ~0x7fff) {
342        $ber->[ Convert::BER::_BUFFER() ] .= CORE::pack("v",$tag);
343	return 2;
344    }
345
346    unless($tag & ~0x7fffff) {
347        $ber->[ Convert::BER::_BUFFER() ] .= CORE::pack("vc",$tag, ($tag >> 16));
348	return 3;
349    }
350
351    $ber->[ Convert::BER::_BUFFER() ] .= CORE::pack("V",$tag);
352    return 4;
353}
354
355sub unpack_tag {
356    my($ber,$expect) = @_;
357    my $pos = $ber->[ Convert::BER::_POS() ];
358    my $len = CORE::length($ber->[ Convert::BER::_BUFFER() ]);
359
360    die "Buffer empty"
361        if($pos >= $len);
362
363    my $tag = CORE::unpack("C",substr($ber->[ Convert::BER::_BUFFER() ],$pos++,1
364));
365
366    if(($tag & 0x1f) == 0x1f) {
367        my $b;
368        my $s = 8;
369
370        do {
371            die "Buffer empty"
372                if($pos >= $len);
373            $b = CORE::unpack("C",substr($ber->[ Convert::BER::_BUFFER() ],$pos++,1));
374            $tag |= $b << $s;
375            $s += 8;
376        } while($b & 0x80);
377    }
378
379    die sprintf("Expecting tag 0x%x, found 0x%x",$expect,$tag)
380        if(defined($expect) && ($tag != $expect));
381
382    $ber->[ Convert::BER::_POS() ] = $pos;
383
384    $tag
385}
386
387sub pack_length {
388    my($ber,$len) = @_;
389
390    if($len & ~0x7f) {
391	my $lenlen = num_length($len);
392
393	$ber->[ Convert::BER::_BUFFER() ] .= CORE::pack("C", $lenlen | 0x80) . substr(CORE::pack("N",$len), 0 - $lenlen);
394
395	return $lenlen + 1;
396    }
397
398    $ber->[ Convert::BER::_BUFFER() ] .= CORE::pack("C", $len);
399    return 1;
400}
401
402
403
404sub unpack_length {
405    my $ber = shift;
406    my $pos = $ber->[ Convert::BER::_POS() ];
407
408    die "Buffer empty"
409	if($pos >= CORE::length($ber->[ Convert::BER::_BUFFER() ]));
410
411    my $len = CORE::unpack("C", substr($ber->[ Convert::BER::_BUFFER() ],$pos++,1));
412
413    if($len & 0x80) {
414	my $buf;
415
416	$len &= 0x7f;
417
418	die "Buffer empty"
419	    if(($pos+$len) > CORE::length($ber->[ Convert::BER::_BUFFER() ]));
420
421	my $tmp = "\0" x (4 - $len) . substr($ber->[ Convert::BER::_BUFFER() ],$pos,$len);
422
423	$pos += $len;
424
425	$len = $len ? CORE::unpack("N",$tmp) : -1;
426    }
427
428    $ber->[ Convert::BER::_POS() ] = $pos;
429
430    $len;
431}
432
433##
434## User interface (public) method
435##
436
437sub error {
438    my $ber = shift;
439    $ber->[ Convert::BER::_ERROR() ];
440}
441
442
443sub tag {
444    my $ber = shift;
445    my $pos = $ber->[ Convert::BER::_POS() ];
446    my $tag = eval {
447	local($SIG{'__DIE__'});
448	unpack_tag($ber)
449    } or return undef;
450    $ber->[ Convert::BER::_POS() ] = $pos;
451    $tag;
452}
453
454sub length {
455    my $ber = shift;
456
457    CORE::length($ber->[ Convert::BER::_BUFFER() ]);
458}
459
460sub buffer {
461    my $ber = shift;
462    if(@_) {
463	$ber->[ Convert::BER::_POS() ] = 0;
464	$ber->[ Convert::BER::_BUFFER() ] = "" . shift;
465    }
466    $ber->[ Convert::BER::_BUFFER() ];
467}
468
469##
470## just for debug :-)
471##
472
473sub _hexdump {
474  my($fmt,$pos) = @_[1,2]; # Don't copy buffer
475
476  $pos ||= 0;
477
478  my $offset  = 0;
479  my $cnt     = 1 << 4;
480  my $len     = CORE::length($_[0]);
481  my $linefmt = ("%02X " x $cnt) . "%s\n";
482
483  print "\n";
484
485  while ($offset < $len) {
486    my $data = substr($_[0],$offset,$cnt);
487    my @y = CORE::unpack("C*",$data);
488
489    printf $fmt,$pos if $fmt;
490
491    # On the last time through replace '%02X ' with '__ ' for the
492    # missing values
493    substr($linefmt, 5*@y,5*($cnt-@y)) = "__ " x ($cnt - @y)
494	if @y != $cnt;
495
496    # Change non-printable chars to '.'
497    $data =~ s/[\x00-\x1f\x7f-\xff]/./sg;
498    printf $linefmt, @y,$data;
499
500    $offset += $cnt;
501    $pos += $cnt;
502  }
503}
504
505my %type = (
506  split(/[\t\n]\s*/,
507    q(10	SEQUENCE
508      01	BOOLEAN
509      0A	ENUM
510      11	SET
511      02	INTEGER
512      03	BIT STRING
513      C0	PRIVATE [%d]
514      04	STRING
515      40	APPLICATION [%d]
516      05	NULL
517      06	OBJECT ID
518      80	CONTEXT [%d]
519    )
520  )
521);
522
523sub dump {
524  my $ber = shift;
525  my $fh = @_ ? shift : \*STDERR;
526
527  my $ofh = select($fh);
528
529  my $pos = 0;
530  my $indent = "";
531  my @seqend = ();
532  my $length = CORE::length($ber->[ Convert::BER::_BUFFER() ]);
533  my $fmt = $length > 0xffff ? "%08X" : "%04X";
534
535  local $ber->[ Convert::BER::_POS() ];
536
537  $ber->[ Convert::BER::_POS() ] = 0;
538
539  while(1) {
540    while (@seqend && $ber->[ Convert::BER::_POS() ] >= $seqend[0]) {
541      $indent = substr($indent,2);
542      shift @seqend;
543      printf "$fmt        : %s}\n",$ber->[ Convert::BER::_POS() ],$indent;
544    }
545    last unless $ber->[ Convert::BER::_POS() ] < $length;
546
547    my $start = $ber->[ Convert::BER::_POS() ];
548    my $tag = unpack_tag($ber);
549    my $pos = $ber->[ Convert::BER::_POS() ];
550    my $len = Convert::BER::unpack_length($ber);
551
552    if($tag == 0 && $len == 0) {
553      $seqend[0] = 0;
554      redo;
555    }
556    printf $fmt. " %02X %4d: %s",$start,$tag,$len,$indent;
557
558    my $label = $type{sprintf("%02X",$tag & ~0x20)}
559		|| $type{sprintf("%02X",$tag & 0xC0)}
560		|| "UNIVERSAL [%d]";
561
562    if (($tag & 0x1f) == 0x1f) {
563      my $k = $tag >> 8;
564      my $j = 0;
565      while($k) {
566        $j = ($j << 7) | ($k & 0x7f);
567       $k >>= 8;
568      }
569      my $l = $label;
570      $l =~ s/%d/0x%x/;
571      printf $l, $j;
572    }
573    else {
574      printf $label, $tag & ~0xE0;
575    }
576
577    if ($tag & BER_CONSTRUCTOR) {
578      print " {\n";
579      if($len < 0) {
580          unshift(@seqend, ~(1<<31));
581      }
582      else {
583          unshift(@seqend, $ber->[ Convert::BER::_POS() ] + $len);
584      }
585      $indent .= "  ";
586      next;
587    }
588
589    $ber->[ Convert::BER::_POS() ] = $pos;
590    my $tmp;
591
592    for ($label) { # switch
593      /^INTEGER/ && do {
594	Convert::BER::INTEGER->unpack($ber,\$tmp);
595	printf " = %d\n",$tmp;
596        last;
597      };
598
599      /^ENUM/ && do {
600	Convert::BER::ENUM->unpack($ber,\$tmp);
601	printf " = %d\n",$tmp;
602        last;
603      };
604
605      /^BOOLEAN/ && do {
606	Convert::BER::BOOLEAN->unpack($ber,\$tmp);
607	printf " = %s\n",$tmp ? 'TRUE' : 'FALSE';
608        last;
609      };
610
611      /^OBJECT ID/ && do {
612	Convert::BER::OBJECT_ID->unpack($ber,\$tmp);
613	printf " = %s\n",$tmp;
614        last;
615      };
616
617      /^NULL/ && do {
618        $ber->[ Convert::BER::_POS() ] = $pos+1;
619	print "\n";
620        last;
621      };
622
623      /^STRING/ && do {
624	Convert::BER::STRING->unpack($ber,\$tmp);
625	if ($tmp =~ /[\x00-\x1f\x7f-\xff]/s) {
626  	  _hexdump($tmp,$fmt . "        :   ".$indent, $pos);
627	}
628	else {
629	  printf " = '%s'\n",$tmp;
630	}
631        last;
632      };
633
634      /^BIT STRING/ && do {
635	Convert::BER::BIT_STRING->unpack($ber,\$tmp);
636	print " = ",$tmp,"\n";
637        last;
638      };
639
640      # default -- dump hex data
641      Convert::BER::STRING->unpack($ber,\$tmp);
642      _hexdump($tmp,$fmt . "        :   ".$indent, $pos);
643    }
644  }
645
646  select($ofh);
647}
648
649sub hexdump {
650    my $ber = shift;
651    my $fh = @_ ? shift : \*STDERR;
652    my $ofh = select($fh);
653    _hexdump($ber->[ Convert::BER::_BUFFER() ]);
654    print "\n";
655    select($ofh);
656}
657
658##
659## And now the real guts of it, the encoding and decoding routines
660##
661
662sub encode {
663    my $ber = shift;
664    local($SIG{'__DIE__'});
665
666    $ber->[ Convert::BER::_INDEX() ] = [];
667
668    return $ber
669	if eval { Convert::BER::_encode($ber,\@_) };
670
671    $ber->[ Convert::BER::_ERROR() ] = $@;
672
673    undef;
674}
675
676sub _encode {
677    my $ber = shift;
678    my $desc = shift;
679    my $i = 0;
680
681    while($i < @$desc ) {
682	my $type = $desc->[$i++];
683	my $arg  = $desc->[$i++];
684	my $tag  = undef;
685
686	($type,$tag) = @$type
687	    if(ref($type) eq 'ARRAY');
688
689	my $can = $ber->can('_' . $type);
690
691	die "Unknown element '$type'"
692	    unless $can;
693
694	my $data = &$can();
695        my $pkg = $data->[ Convert::BER::_PACKAGE() ];
696
697	$tag = $data->[ Convert::BER::_TAG() ]
698	    unless defined $tag;
699
700	$arg = &{$arg}(@{$ber->[ Convert::BER::_INDEX() ]})
701	    if(ref($arg) eq 'CODE');
702
703	if(ref($arg) eq 'ARRAY') {
704	    if($can = $data->[Convert::BER::_PACK_ARRAY() ]) {
705		pack_tag($ber,$tag)
706		    if defined $tag;
707
708		&{$can}($pkg,$ber,$arg);
709	    }
710	    else {
711		my $a;
712		foreach $a (@$arg) {
713		    pack_tag($ber,$tag)
714			if defined $tag;
715
716		    &{$data->[Convert::BER::_PACK() ]}($pkg,$ber,$a);
717		}
718	    }
719	}
720	else {
721	    pack_tag($ber,$tag)
722		if defined $tag;
723	    &{$data->[Convert::BER::_PACK() ]}($pkg,$ber,$arg);
724	}
725    }
726
727    1;
728}
729
730sub decode {
731    my $ber = shift;
732    my $pos = $ber->[ Convert::BER::_POS() ];
733    local($SIG{'__DIE__'});
734
735    $ber->[ Convert::BER::_INDEX() ] = [];
736
737    return $ber
738	if eval { Convert::BER::_decode($ber,\@_) };
739
740    $ber->[ Convert::BER::_ERROR() ] = $@;
741    $ber->[ Convert::BER::_POS() ]   = $pos;
742
743    undef;
744}
745
746sub _decode {
747    my $ber = shift;
748    my $desc = shift;
749    my $i = 0;
750
751    my $argc;
752
753TAG:
754    for($argc = @$desc ; $argc > 0 ; $argc -= 2) {
755	my $type = $desc->[$i++];
756	my $arg  = $desc->[$i++];
757	my $tag  = undef;
758
759	($type,$tag) = @$type
760	    if(ref($type) eq 'ARRAY');
761
762	my $can = $ber->can('_' . $type);
763
764	die "Unknown element '$type'"
765	    unless $can;
766
767	my $data = &$can();
768	my $pkg  = $data->[ Convert::BER::_PACKAGE() ];
769
770	$tag = $data->[ Convert::BER::_TAG() ]
771	    unless defined $tag;
772
773	$arg = &{$arg}(@{$ber->[ Convert::BER::_INDEX() ]})
774	    if(ref($arg) eq 'CODE');
775
776	if(ref($arg) eq 'ARRAY') {
777	    if($data->[ Convert::BER::_UNPACK_ARRAY() ]) {
778
779		unpack_tag($ber,$tag)
780		    if(defined $tag);
781
782		&{$data->[ Convert::BER::_UNPACK_ARRAY() ]}($pkg,$ber,$arg);
783	    }
784	    else {
785		@$arg = ();
786		while(CORE::length($ber->[ Convert::BER::_BUFFER() ]) > $ber->[ Convert::BER::_POS() ]) {
787		    if(defined $tag) {
788			next TAG
789			    unless eval { unpack_tag($ber,$tag) };
790		    }
791
792		    push @$arg, undef;
793		    &{$data->[ Convert::BER::_UNPACK() ]}($pkg,$ber,\$arg->[-1]);
794		}
795	    }
796	}
797	else {
798	    eval {
799		unpack_tag($ber,$tag)
800		    if(defined $tag);
801
802		&{$data->[ Convert::BER::_UNPACK() ]}($pkg,$ber,$arg);
803		1;
804	    } or ($$arg = undef, die);
805	}
806    }
807
808   1;
809}
810
811##
812## a couple of routines to interface to a file descriptor.
813##
814
815sub read {
816    my $ber = shift;
817    my $io  = shift;
818    my $indef = shift;
819
820    # We need to read one packet, and exactly only one packet.
821    # So we have to read the first few bytes one at a time, until
822    # we have enough to decode a tage and a length. We then know
823    # how many more bytes to read
824
825    $ber = $ber->new unless ref($ber);
826    $ber->[ _BUFFER() ] = "" unless $indef;
827
828    my $pos = CORE::length($ber->[ _BUFFER() ]);
829    my $start = $pos;
830
831    # The first byte is the tag
832    sysread($io,$ber->[ _BUFFER() ],1,$pos++) or
833	goto READ_ERR;
834
835#    print STDERR "-"x80,"\n";
836#    print STDERR CORE::unpack("H*",$ber->[ _BUFFER() ]),"\n";
837
838    my $ch = ord(substr($ber->[ _BUFFER() ],-1));
839
840    # Tag may be multi-byte
841    if(($ch & 0x1f) == 0x1f) {
842	do {
843	    sysread($io, $ber->[ _BUFFER() ], 1, $pos++) or
844		goto READ_ERR;
845
846	    $ch = ord(substr($ber->[ _BUFFER() ],-1));
847
848	} while($ch & 0x80);
849    }
850
851#    print STDERR CORE::unpack("H*",$ber->[ _BUFFER() ]),"\n";
852
853    # The next byte will be the first byte of the length
854    sysread($io, $ber->[ _BUFFER() ], 1, $pos++) or
855	goto READ_ERR;
856
857#    print STDERR CORE::unpack("H*",$ber->[ _BUFFER() ]),"\n";
858
859    $ch = ord(substr($ber->[ _BUFFER() ],-1));
860#    print STDERR CORE::unpack("H*",substr($ber->[ _BUFFER() ],-1))," $ch\n";
861
862    # May be a multi-byte length
863    if($ch & 0x80) {
864	my $len = $ch & 0x7f;
865	unless ($len) {
866#    print STDERR CORE::unpack("H*",$ber->[ _BUFFER() ]),"\n";
867	    # OK we have an indefinate length
868	    while(1) {
869		Convert::BER::read($ber,$io,1);
870		my $p = CORE::length($ber->[ _BUFFER() ]);
871		if(($p - $pos) == 2 && substr($ber->[ _BUFFER() ],-2) eq "\0\0") {
872#    print STDERR CORE::unpack("H*",$ber->[ _BUFFER() ]),"\n","-"x80,"\n";
873		    return $ber;
874		}
875		$pos = $p;
876	    }
877	}
878	while($len) {
879	    my $n = sysread($io, $ber->[ _BUFFER() ], $len, $pos) or
880		goto READ_ERR;
881	    $len -= $n;
882	    $pos += $n;
883	}
884    }
885
886#    print STDERR CORE::unpack("H*",$ber->[ _BUFFER() ]),"\n";
887
888    # We can now unpack a tage and a length to determine how many more
889    # bytes to read
890
891    $ber->[ _POS() ] = $start;
892    unpack_tag($ber);
893    my $len = unpack_length($ber);
894
895    while($len > 0) {
896	my $got;
897
898	goto READ_ERR
899	    unless( $got = sysread($io, $ber->[ _BUFFER() ],$len,CORE::length($ber->[ _BUFFER() ])) );
900
901	$len -= $got;
902    }
903
904    # Reset pos back to the beginning.
905    $ber->[ _POS() ] = 0;
906
907#    print STDERR CORE::unpack("H*",$ber->[ _BUFFER() ]),"\n";
908    return $ber;
909
910READ_ERR:
911    $@ = "I/O Error $! " . CORE::unpack("H*",$ber->[ _BUFFER() ]);
912    return undef;
913}
914
915sub write {
916    my $ber = shift;
917    my $io = shift;
918    local($SIG{'__DIE__'});
919
920    my $togo = CORE::length($ber->[ _BUFFER() ]);
921    my $pos = 0;
922
923    while($togo) {
924	my $len;
925
926	unless ($len = syswrite($io, $ber->[ _BUFFER() ],$togo,$pos)) {
927	    $@ = "I/O Error $!";
928	    return;
929	}
930
931	$togo -= $len;
932	$pos += $len;
933    }
934
935    1;
936}
937
938sub send {
939    my $ber = shift;
940    my $sock = shift;
941
942    local($SIG{'__DIE__'});
943
944    eval {
945	# Enable reporting a 'Broken pipe' error rather than dying.
946	local ($SIG{PIPE}) = "IGNORE";
947
948	@_ ? send($sock,$ber->[ _BUFFER() ],0,$_[0])
949           : send($sock,$ber->[ _BUFFER() ],0);
950    } or die "I/O Error: $!";
951}
952
953sub recv {
954    my $ber = shift;
955    my $sock = shift;
956
957    require Socket; # for Socket::MSG_PEEK
958
959    local $SIG{'__DIE__'};
960
961    $ber = $ber->new unless ref($ber);
962    $ber->[ _BUFFER() ] = "";
963
964    # We do not know the size of the datagram, so we have to PEEK --GMB
965    # is there an easier way to determine the packet size ??
966
967    my $n = 128;
968    die "I/O Error: $!"
969	unless ((defined recv($sock,$ber->[ _BUFFER() ],$n,Socket::MSG_PEEK()))
970		and not $!);
971
972    # PEEK until we have the complete tag and length of the BER
973    # packet. Use the length to determine how much data to read from
974    # the socket. This is an attempt to ensure that we read the
975    # entire packet and that we don't read into the next packet, if
976    # there is one.
977
978    my $len;
979
980    # Keep reading until we've read enough of the packet to unpack
981    # the BER length field.
982    for(;;) {
983
984	# If we can decode a tag and length we can detemine the length
985
986	if(defined($len = eval {
987	    $ber->[ _POS() ] = 0;
988	    unpack_tag($ber);
989	    unpack_length($ber)
990		+ $ber->[ _POS() ];
991  	         })
992	   # unpack_length will return -1 for unknown length
993	   && $len >= $ber->[ _POS() ]) {
994
995	    $n = $len;
996	    last;
997	}
998
999	# peek some more
1000	$n <<= 1;
1001	die "I/O Error: $!"
1002	    unless ((defined recv($sock,$ber->[ _BUFFER() ],$n,Socket::MSG_PEEK()))
1003		    and not $!);
1004    }
1005
1006    # now we know the size, get it again but without MSG_PEEK
1007    # this will cause the kernel to remove the datagram from it's queue
1008
1009    # If the data on the socket doesn't correspond to a valid BER
1010    # object, the loop above could have read something it thought was
1011    # the length and this loop could then block waiting for that many
1012    # bytes, which will never arrive. What do you do about something
1013    # like that?
1014
1015    $ber->[ _POS() ] = 0;
1016    $ber->[ _BUFFER() ] = "";
1017    my ($read, $tmp);
1018    $read = 0;
1019    while ($read < $n) {
1020	$ber->[ _PEER() ] = recv($sock, $tmp, $n - $read, 0);
1021	die "I/O Error: $!"
1022	    unless ((defined ( $ber->[ _PEER() ] ) and not $!));
1023
1024	$read += CORE::length($tmp);
1025	$ber->[ _BUFFER() ] .= $tmp;
1026    }
1027    $ber;
1028}
1029
1030##
1031## The primitive packages
1032##
1033
1034package Convert::BER::BER;
1035
1036sub pack {
1037    my($self,$ber,$arg) = @_;
1038
1039    $ber->[ Convert::BER::_BUFFER() ] .= $arg->[ Convert::BER::_BUFFER() ]
1040	if ref($arg);
1041
1042    1;
1043}
1044
1045sub unpack {
1046    my($self,$ber,$arg) = @_;
1047
1048    my $len = CORE::length($ber->[ Convert::BER::_BUFFER() ]) - $ber->[ Convert::BER::_POS() ];
1049
1050    $$arg = $ber->new(Convert::BER::unpack($ber,$len));
1051
1052    1;
1053}
1054
1055package Convert::BER::ANY;
1056
1057sub pack {
1058    my($self,$ber,$arg) = @_;
1059
1060    $ber->[ Convert::BER::_BUFFER() ] .= $arg->[ Convert::BER::_BUFFER() ];
1061
1062    1;
1063}
1064
1065sub unpack {
1066    my($self,$ber,$arg) = @_;
1067
1068    my $pos = $ber->[ Convert::BER::_POS() ];
1069    my $tag = Convert::BER::unpack_tag($ber);
1070    my $len = Convert::BER::unpack_length($ber) + $ber->[ Convert::BER::_POS() ] - $pos;
1071    $ber->[ Convert::BER::_POS() ] = $pos;
1072
1073    $$arg = $ber->new(Convert::BER::unpack($ber,$len));
1074
1075    1;
1076}
1077
1078##
1079##
1080##
1081
1082package Convert::BER::BOOLEAN;
1083
1084sub pack {
1085    my($self,$ber,$arg) = @_;
1086
1087    Convert::BER::pack_length($ber,1);
1088    $ber->[ Convert::BER::_BUFFER() ] .= CORE::pack("c", $arg ? 0xff : 0x00);
1089
1090    1;
1091}
1092
1093sub unpack {
1094    my($self,$ber,$arg) = @_;
1095
1096    my $len = Convert::BER::unpack_length($ber);
1097
1098    $$arg = CORE::unpack("c", Convert::BER::unpack($ber,$len)) ? 1 : 0;
1099
1100    1;
1101}
1102
1103##
1104##
1105##
1106
1107package Convert::BER::INTEGER;
1108
1109##
1110## Math::BigInt support
1111##
1112
1113sub pack_bigint {
1114    my($self,$ber,$arg) = @_;
1115
1116    require Math::BigInt;
1117
1118    my $neg = ($arg < 0) ? 1 : 0;
1119    my @octet = ();
1120    my $num = new Math::BigInt(abs($arg));
1121
1122    $num -= 1 if $neg;
1123    while($num > 0) {
1124	my($i,$y) = $num->bdiv(256);
1125	$num = new Math::BigInt($i);
1126	$y = $y ^ 0xff if $neg;
1127	unshift(@octet,$y);
1128    }
1129    @octet = (0) unless @octet;
1130
1131    my $msb = ($octet[0] & 0x80) ? 1 : 0;
1132
1133    unshift(@octet,$neg ? 0xff : 0x00)
1134	if($neg != $msb);
1135
1136    Convert::BER::pack_length($ber, scalar @octet);
1137
1138    $ber->[ Convert::BER::_BUFFER() ] .= CORE::pack("C*",@octet);
1139
1140    1;
1141}
1142
1143sub unpack_bigint {
1144    my($self,$ber,$arg) = @_;
1145
1146    require Math::BigInt;
1147
1148    my $len = Convert::BER::unpack_length($ber);
1149    my @octet = CORE::unpack("C*",Convert::BER::unpack($ber,$len));
1150    my $neg = ($octet[0] & 0x80) ? 1 : 0;
1151    my $val = $$arg = 0;
1152
1153    while(@octet) {
1154	my $oct = shift @octet;
1155	$oct = $oct ^ 0xff
1156	    if $neg;
1157	$val *= (1<<8);
1158	$val += $oct;
1159    }
1160
1161    $val = -1 - $val
1162	if $neg;
1163
1164    1;
1165}
1166
1167##
1168## Math::BigInteger support
1169##
1170
1171sub pack_biginteger {
1172    my($self,$ber,$arg) = @_;
1173
1174    my($len,$data);
1175    my $offset = 0;
1176
1177    require Math::BigInteger;
1178    # save has no concept of +/-
1179    my $v = $arg->cmp(new Math::BigInteger(0));
1180
1181    if($v) {
1182	if($v < 0) {
1183	    my $b = $arg->bits + 8;
1184	    $b -= $b % 8;
1185	    my $tmp = new Math::BigInteger(1);
1186	    $tmp->lshift(new Math::BigInteger(1), $b);
1187	    $arg = $tmp + $arg;
1188	}
1189
1190	$data = $arg->save;
1191	$len = CORE::length($data);
1192
1193	my $c = ord(substr($data,0,1));
1194
1195	if($c == 0) {
1196	    for( ; $len > 1 ; $len--, $offset++) {
1197		my $ch = ord(substr($data,$offset,1));
1198		if($ch & 0xff) {
1199		    if($ch & 0x80) {
1200			$len++;
1201			$offset--;
1202		    }
1203		    last;
1204		}
1205	    }
1206	}
1207	elsif($c == 0xff) {
1208	    for( ; $len > 1 ; $len--, $offset++) {
1209		my $ch = ord(substr($data,$offset,1));
1210		unless($ch == 0xff) {
1211		    unless($ch & 0x80) {
1212			$len++;
1213			$offset--;
1214		    }
1215		    last;
1216		}
1217	    }
1218	}
1219    }
1220    else {
1221	$len = 1;
1222	$data = CORE::pack("C",0);
1223    }
1224
1225    Convert::BER::pack_length($ber,$len);
1226    $ber->[ Convert::BER::_BUFFER() ] .= substr($data,$offset);
1227
1228    return 1;
1229}
1230
1231sub unpack_biginteger {
1232    my($self,$ber,$arg) = @_;
1233
1234    require Math::BigInteger;
1235
1236    my $len = Convert::BER::unpack_length($ber);
1237    my $data = Convert::BER::unpack($ber,$len);
1238    my $int = restore Math::BigInteger $data;
1239
1240    # restore has no concept of +/-
1241    if(ord(substr($data,0,1)) & 0x80) {
1242	my $tmp = new Math::BigInteger;
1243	$tmp->lshift(new Math::BigInteger(1), $len * 8);
1244	$tmp = new Math::BigInteger(0) - $tmp;
1245	$int = $tmp + $int;
1246    }
1247    $$arg = $int;
1248
1249    return 1;
1250}
1251
1252##
1253##
1254##
1255
1256sub pack {
1257    my($self,$ber,$arg) = @_;
1258
1259    if(ref $arg) {
1260	goto &pack_bigint
1261	    if UNIVERSAL::isa($arg,'Math::BigInt');
1262
1263	goto &pack_biginteger
1264	    if UNIVERSAL::isa($arg,'Math::BigInteger');
1265    }
1266
1267    my $neg = ($arg < 0) ? 1 : 0;
1268
1269    my $len = Convert::BER::num_length($neg ? ~ $arg : $arg);
1270
1271    my $msb = $arg & (0x80 << (($len - 1) * 8));
1272
1273    $len++
1274	if(($msb && not($neg)) || ($neg && not($msb)));
1275    Convert::BER::pack_length($ber,$len);
1276    $ber->[ Convert::BER::_BUFFER() ] .= substr(CORE::pack("N",$arg), 0 - $len);
1277
1278    1;
1279}
1280
1281sub unpack {
1282    my($self,$ber,$arg) = @_;
1283
1284    if( ref($arg) && ref($$arg) ) {
1285	goto &unpack_bigint
1286	    if UNIVERSAL::isa($$arg,'Math::BigInt');
1287
1288	goto &unpack_biginteger
1289	    if UNIVERSAL::isa($$arg,'Math::BigInteger');
1290    }
1291
1292    my $len = Convert::BER::unpack_length($ber);
1293    my $tmp = "\0" x (4 - $len) . Convert::BER::unpack($ber,$len);
1294    my $val = CORE::unpack("N",$tmp);
1295
1296    $val -=  0x1 << ($len * 8)
1297	if($val & (0x1 << (($len * 8) - 1)));
1298
1299    $$arg = $val;
1300
1301    1;
1302}
1303
1304##
1305##
1306##
1307
1308package Convert::BER::NULL;
1309
1310sub pack {
1311    my($self,$ber,$arg) = @_;
1312
1313    Convert::BER::pack_length($ber,0);
1314}
1315
1316sub unpack {
1317    my($self,$ber,$arg) = @_;
1318
1319    Convert::BER::unpack_length($ber);
1320
1321    $$arg = 1;
1322}
1323
1324##
1325##
1326##
1327
1328package Convert::BER::STRING;
1329
1330sub pack {
1331    my($self,$ber,$arg) = @_;
1332
1333    Convert::BER::pack_length($ber,CORE::length($arg));
1334    $ber->[ Convert::BER::_BUFFER() ] .= $arg;
1335}
1336
1337sub unpack {
1338    my($self,$ber,$arg) = @_;
1339
1340    my $len = Convert::BER::unpack_length($ber);
1341    $$arg = Convert::BER::unpack($ber,$len);
1342
1343    1;
1344}
1345
1346##
1347##
1348##
1349
1350package Convert::BER::SEQUENCE;
1351
1352sub pack {
1353    my($self,$ber,$arg) = @_;
1354
1355    Convert::BER::pack_length($ber,CORE::length($arg->[ Convert::BER::_BUFFER() ]));
1356    $ber->[ Convert::BER::_BUFFER() ] .= $arg->[ Convert::BER::_BUFFER() ];
1357
1358    1;
1359}
1360
1361sub unpack {
1362    my($self,$ber,$arg) = @_;
1363
1364    my $len = Convert::BER::unpack_length($ber);
1365    $$arg = $ber->new(Convert::BER::unpack($ber,$len));
1366
1367    1;
1368}
1369
1370sub pack_array {
1371    my($self,$ber,$arg) = @_;
1372
1373    my $ber2 = $ber->new;
1374
1375    return undef
1376	unless defined($ber2->_encode($arg));
1377
1378    Convert::BER::pack_length($ber,CORE::length($ber2->[ Convert::BER::_BUFFER() ]));
1379    $ber->[ Convert::BER::_BUFFER() ] .= $ber2->[ Convert::BER::_BUFFER() ];
1380
1381    1;
1382}
1383
1384sub unpack_array {
1385    my($self,$ber,$arg) = @_;
1386
1387    my $ber2;
1388
1389    $self->unpack($ber,\$ber2);
1390
1391    $ber2->_decode($arg);
1392
1393    die "Sequence buffer not empty"
1394	if CORE::length($ber2->[ Convert::BER::_BUFFER() ]) != $ber2->[ Convert::BER::_POS() ];
1395
1396    1;
1397}
1398
1399##
1400##
1401##
1402
1403package Convert::BER::OBJECT_ID;
1404
1405sub pack {
1406    my($self,$ber,$arg) = @_;
1407    my @data = ($arg =~ /(\d+)/g);
1408
1409    if(@data < 2) {
1410	@data = (0);
1411    }
1412    else {
1413	my $first = $data[1] + ($data[0] * 40);
1414	splice(@data,0,2,$first);
1415    }
1416
1417    @data = map {
1418	my @d = ($_);
1419	if($_ >= 0x80) {
1420	    @d = ();
1421	    my $v = 0 | $_; # unsigned
1422	    while($v) {
1423		unshift(@d, 0x80 | ($v & 0x7f));
1424		$v >>= 7;
1425	    }
1426	    $d[-1] &= 0x7f;
1427	}
1428	@d;
1429    } @data;
1430
1431    my $data = CORE::pack("C*", @data);
1432
1433    Convert::BER::pack_length($ber,CORE::length($data));
1434    $ber->[ Convert::BER::_BUFFER() ] .=  $data;
1435
1436    1;
1437}
1438
1439sub unpack {
1440    my($self,$ber,$arg) = @_;
1441
1442    my $len = Convert::BER::unpack_length($ber);
1443    my @ch = CORE::unpack("C*",Convert::BER::unpack($ber,$len));
1444    my @data = ();
1445    my $val = 0;
1446    while(@ch) {
1447	my $ch = shift @ch;
1448	$val = ($val << 7) | ($ch & 0x7f);
1449	unless($ch & 0x80) {
1450	    push @data, $val;
1451	    $val = 0;
1452	}
1453    }
1454    if(@data) {
1455	my $first = shift @data;
1456	unshift @data, $first % 40;
1457	unshift @data, int($first / 40);
1458#	unshift @data, "";
1459    }
1460    $$arg = join(".",@data);
1461    1;
1462}
1463
1464##
1465##
1466##
1467
1468package Convert::BER::CONSTRUCTED;
1469
1470BEGIN {
1471    # Cannot call import here as Convert::BER has not been initialized
1472    *BER_CONSTRUCTOR = *Convert::BER::BER_CONSTRUCTOR
1473}
1474
1475sub pack {
1476    my($self,$ber,$arg) = @_;
1477
1478    Convert::BER::pack_tag($ber,$arg->tag | BER_CONSTRUCTOR);
1479    Convert::BER::pack_length($ber,CORE::length($arg->[ Convert::BER::_BUFFER() ]));
1480    $ber->[ Convert::BER::_BUFFER() ] .= $arg->[ Convert::BER::_BUFFER() ];
1481
1482    1;
1483}
1484
1485sub unpack {
1486    my($self,$ber,$arg) = @_;
1487    my $tag = Convert::BER::unpack_tag($ber);
1488
1489    die "Not constructed"
1490	unless $tag & BER_CONSTRUCTOR;
1491
1492    my $len = Convert::BER::unpack_length($ber);
1493    my $buf = $ber->new( Convert::BER::unpack($ber,$len));
1494
1495    die &{$ber}(0,"Bad construction")
1496	unless( ($buf->tag | BER_CONSTRUCTOR) == $tag);
1497
1498    $$arg = $buf;
1499
1500    1;
1501}
1502
1503sub pack_array {
1504    my($self,$ber,$arg) = @_;
1505
1506    $self->_encode($arg);
1507}
1508
1509sub unpack_array {
1510    my($self,$ber,$arg) = @_;
1511
1512    my $ber2;
1513
1514    $self->unpack($ber,\$ber2);
1515
1516    $ber2->_decode($arg);
1517}
1518
1519##
1520##
1521##
1522
1523package Convert::BER::OPTIONAL;
1524
1525# optional elements
1526# allows skipping in the encode if it comes across structures like
1527#   OPTIONAL => [ BOOLEAN => undef ]
1528# or more realistically
1529#   my $foo = undef;
1530#   $foo = 1 if (arg->{'allowed'};
1531#   $ber->encode(SEQUENCE => [
1532#                    STRING => $name,
1533#                    OPTIONAL => [ BOOLEAN => $foo ]
1534#                 ]);
1535
1536sub pack_array {
1537    my($self,$ber,$arg) = @_;
1538    my $a;
1539    my @newarg;
1540    foreach $a (@$arg) {
1541        return unless defined $a;
1542        my $c = ref($a) eq "CODE"
1543                        ? &{$a}(@{$ber->[ Convert::BER::_INDEX() ]})
1544                        : $a;
1545        return unless defined $c;
1546        push @newarg, $c;
1547    }
1548
1549    shift @newarg if (@newarg & 1);
1550
1551    Convert::BER::_encode($ber,\@newarg);
1552}
1553
1554sub unpack_array {
1555    my($self,$ber,$arg) = @_;
1556    my($yes,$ref);
1557    my $pos = $ber->[ Convert::BER::_POS() ];
1558
1559    if(@$arg & 1) {
1560	$ref = [ @$arg ];
1561	$yes = shift @$ref;
1562    }
1563    else {
1564        $ref = $arg;
1565    }
1566
1567    if (eval { Convert::BER::_decode($ber,$ref) }) {
1568	$$yes = 1 if ref($yes);
1569    }
1570    else {
1571	$$yes = undef if ref($yes);
1572	$ber->[ Convert::BER::_POS() ] = $pos;
1573    }
1574
1575    1;
1576}
1577
1578##
1579##
1580##
1581
1582package Convert::BER::SEQUENCE_OF;
1583
1584sub pack_array {
1585    my($self,$ber,$arg) = @_;
1586    my($n,@desc) = @$arg;
1587    my $i;
1588
1589    $n = &{$n}(@{$ber->[ Convert::BER::_INDEX() ]})
1590	if ref($n) eq 'CODE';
1591
1592    push(@{$ber->[ Convert::BER::_INDEX() ]},0);
1593
1594    my $b = $ber->new;
1595
1596    if(ref($n) eq 'HASH') {
1597	my $v;
1598	foreach $v (keys %$n) {
1599	    $ber->[ Convert::BER::_INDEX() ][-1] = $v;
1600	    $b->_encode(\@desc);
1601	}
1602    }
1603    elsif(ref($n) eq 'ARRAY') {
1604	my $v;
1605	foreach $v (@$n) {
1606	    $ber->[ Convert::BER::_INDEX() ][-1] = $v;
1607	    $b->_encode(\@desc);
1608	}
1609    }
1610    else {
1611	while($n--) {
1612	    $b->_encode(\@desc);
1613	    $ber->[ Convert::BER::_INDEX() ][-1] += 1;
1614	}
1615    }
1616
1617    pop @{$ber->[ Convert::BER::_INDEX() ]};
1618
1619    Convert::BER::pack_length($ber,CORE::length($b->[ Convert::BER::_BUFFER() ]));
1620    $ber->[ Convert::BER::_BUFFER() ] .= $b->[ Convert::BER::_BUFFER() ];
1621
1622    1;
1623}
1624
1625sub unpack_array {
1626    my($self,$ber,$arg) = @_;
1627    my($nref,@desc) = @$arg;
1628
1629    push(@{$ber->[ Convert::BER::_INDEX() ]},0);
1630
1631    my $len = Convert::BER::unpack_length($ber);
1632    my $b   = $ber->new(Convert::BER::unpack($ber,$len));
1633    my $pos = $ber->[ Convert::BER::_POS() ];
1634    my $n;
1635
1636    while(CORE::length($b->[ Convert::BER::_BUFFER() ]) > $b->[ Convert::BER::_POS() ]) {
1637	$b->_decode(\@desc);
1638	$ber->[ Convert::BER::_INDEX() ][-1] += 1;
1639    }
1640
1641    $$nref = pop @{$ber->[ Convert::BER::_INDEX() ]};
1642    1;
1643}
1644
1645##
1646##
1647##
1648
1649package Convert::BER::BIT_STRING;
1650
1651sub pack {
1652    my($self,$ber,$arg) = @_;
1653
1654    my $less = (8 - (CORE::length($arg) & 7)) & 7;
1655    $arg .= "0" x $less if $less;
1656    my $data = CORE::pack("B*",$arg);
1657    Convert::BER::pack_length($ber,CORE::length($data)+1);
1658    $ber->[ Convert::BER::_BUFFER() ] .= chr($less) . $data;
1659}
1660
1661sub unpack {
1662    my($self,$ber,$arg) = @_;
1663
1664    my $len  = Convert::BER::unpack_length($ber);
1665    my $data = Convert::BER::unpack($ber,$len);
1666    my $less;
1667    ($less,$data) = CORE::unpack("C B*",$data,);
1668    $less = ord($less) & 7;
1669    substr($data,-$less) = '' if $less;
1670    $$arg = $data;
1671    1;
1672}
1673
1674##
1675##
1676##
1677
1678package Convert::BER::BIT_STRING8;
1679
1680sub pack {
1681    my($self,$ber,$arg) = @_;
1682
1683    Convert::BER::pack_length($ber,CORE::length($arg)+1);
1684    $ber->[ Convert::BER::_BUFFER() ] .= chr(0) . $arg;
1685}
1686
1687sub unpack {
1688    my($self,$ber,$arg) = @_;
1689
1690    my $len  = Convert::BER::unpack_length($ber);
1691    my $less = Convert::BER::unpack($ber,1);
1692    my $data = $len > 1 ? Convert::BER::unpack($ber,$len-1) : "";
1693    $$arg = $data;
1694    1;
1695}
1696
1697##
1698##
1699##
1700
1701package Convert::BER::REAL;
1702
1703sub pack {
1704  my($self,$ber,$arg) = @_;
1705  require POSIX;
1706  my $data = "";
1707
1708  if($arg) {
1709    my $s = 128;
1710    if($arg < 0) {
1711      $s |= 64;
1712      $arg = -$arg;
1713    }
1714    my @e = ();
1715    my @m = ();
1716    my($v,$e) = POSIX::frexp($arg);
1717    $e -= 53;
1718    my $ae = abs($e);
1719
1720    if($ae < 0x80) {
1721      @e = ($e & 0xff);
1722    }
1723    elsif($ae < 0x8000) {
1724      @e = map { $_ & 0xff } ($e>>8,$e);
1725      $s |= 1;
1726    }
1727    elsif($ae < 0x800000) {
1728      @e = map { $_ & 0xff } ($e>>16,$e>>8,$e);
1729      $s |= 2;
1730    }
1731    else {
1732      @e = (4, map { $_ & 0xff } ($e>>24,$e>>16,$e>>8,$e));
1733      $s |= 3;
1734    }
1735
1736    $v = POSIX::ldexp($v,5);
1737    my $f = POSIX::floor($v);
1738    my $i = int($f);
1739    @m = ($i & 0xff);
1740    $v -= $f;
1741    for (1..2) {
1742      $v = POSIX::ldexp($v,24);
1743      $f = POSIX::floor($v);
1744      $i = int($f);
1745      push @m, ($i >> 16) & 0xff, ($i >> 8) & 0xff, $i & 0xff;
1746      $v -= $f;
1747    }
1748    $data = pack("C*",$s,@e,@m);
1749  }
1750  my $len = length($data);
1751  Convert::BER::pack_length($ber,$len);
1752  Convert::BER::pack($ber,$data) if $len;
1753}
1754
1755my @base = (1,3,4,4);
1756
1757sub unpack {
1758  my($self,$ber,$arg) = @_;
1759
1760  my $len = Convert::BER::unpack_length($ber);
1761  unless($len) {
1762    $$arg = undef;
1763    return 1;
1764  }
1765  my $data = Convert::BER::unpack($ber,$len);
1766  my $byte = unpack("C*",$data);
1767
1768  if($byte & 0x80) {
1769    $data = reverse $data;
1770    chop($data);
1771    require POSIX; # The sins for using REAL
1772    my $base = $base[($byte & 0x30) >> 4];
1773    my $scale = $base & 0xC;
1774    my $elen = $byte & 0x3;
1775
1776    $elen = ord(chop($data)) - 1 if $elen == 3;
1777
1778    die "Bad REAL encoding" unless $elen >= 0 && $elen <= 3;
1779
1780    my $exp = ord chop($data);
1781    $exp = -256 + $exp if $exp > 127;
1782
1783    while ($elen--) {
1784      $exp *= 256;
1785      $exp += ord chop($data);
1786    }
1787
1788    $exp = $exp * $base + $scale;
1789
1790    my $v = 0;
1791    while(length($data)) {
1792      $v = POSIX::ldexp($v,8) + ord chop($data);
1793    }
1794
1795    $v = POSIX::ldexp($v,$exp) if $exp;
1796    $v = -1 * $v if $byte & 0x40; # negative
1797
1798    $$arg = $v;
1799  }
1800  elsif($byte & 0x40) {
1801    require POSIX;
1802    $$arg = POSIX::HUGE_VAL() * (($byte & 1) ? -1 : 1);
1803  }
1804  elsif(substr($data,1) =~ /^\s*([-+]?)0*(\d+(?:\.\d+(?:[Ee][-+]?\d+)?)?)\s*$/) {
1805    $$arg = eval "$1$2";
1806  }
1807  else {
1808    $$arg = undef;
1809  }
1810  1;
1811}
1812
1813##
1814##
1815##
1816
1817package Convert::BER::_Time_generic;
1818
1819sub pack {
1820    my($self,$ber,$arg) = @_;
1821
1822    my $islocal = $self->isa('Convert::BER::TimeUL')
1823		|| $self->isa('Convert::BER::TimeGL');
1824    my $isgen = $self->isa('Convert::BER::TimeGL')
1825		|| $self->isa('Convert::BER::TimeGZ');
1826    my @time = $islocal ? localtime($arg) : gmtime($arg);
1827    my $off = 'Z';
1828
1829    if($islocal) {
1830      my @g = gmtime($arg);
1831      my $v = ($time[1] - $g[1]) + ($time[2] - $g[2]) * 60;
1832      my $d = $time[7] - $g[7];
1833      if($d == 1 || $d < -1) {
1834	$v += 1440;
1835      }
1836      elsif($d > 1) {
1837	$v -= 1440;
1838      }
1839      $off = sprintf("%+03d%02d",$v / 60, abs($v % 60));
1840    }
1841
1842    $time[4] += 1;
1843    $time[5] = $isgen ? $time[5] + 1900 : $time[5] % 100;
1844    my $str = sprintf("%02d"x6, @time[5,4,3,2,1,0]);
1845    if($isgen) {
1846      my $split = $arg - int($arg);
1847      $str .= sprintf(".%03d", int($split * 1000)) if($split);
1848    }
1849    Convert::BER::STRING::pack($self,$ber,$str . $off);
1850}
1851
1852sub unpack {
1853    my($self,$ber,$arg) = @_;
1854    my $str;
1855    if(Convert::BER::STRING::unpack($self,$ber,\$str)) {
1856      my $isgen = $self->isa('Convert::BER::TimeGL')
1857		|| $self->isa('Convert::BER::TimeGZ');
1858      my $n = $isgen ? 4 : 2;
1859      my ($Y,$M,$D,$h,$m,$s,$z) = $str =~ /^
1860        (\d{$n})
1861	(\d\d)
1862	(\d\d)
1863	(\d\d)
1864	(\d\d)
1865	((?:\d\d(?:\.\d+)?)?)
1866	(Z|[-+]\d{4})
1867      $/x or die "Bad Time string '$str'";
1868      my $offset = 0;
1869      if($z ne 'Z') {
1870        use integer;
1871	$offset = ((($z / 100) * 60) + ($z % 100)) * 60;
1872      }
1873      if($s > int($s)) { # fraction of a seccond
1874        $offset -= ($s - int($s));
1875      }
1876      $M -= 1;
1877      if($isgen) {	# GeneralizedTime uses 4-digit years
1878	$Y -= 1900;
1879      }
1880      elsif($Y <= 50) {	# ASN.1 UTCTime
1881	$Y += 100;	# specifies <=50 = 2000..2050, >50 = 1951..1999
1882      }
1883      require Time::Local;
1884      $$arg = Time::Local::timegm(int($s),$m,$h,$D,$M,$Y) - $offset;
1885    }
1886}
1887
1888package Convert::BER::CHOICE;
1889
1890sub pack_array {
1891    my($self,$ber,$arg) = @_;
1892    my $n = $arg->[0];
1893
1894    if(defined($n)) {
1895	my $i = ($n * 2) + 2;
1896	die "Bad CHOICE index $n" if $n < 0 || $i > @$arg;
1897	$ber->_encode([$arg->[$i-1], $arg->[$i]]);
1898    }
1899    1;
1900}
1901
1902sub unpack_array {
1903    my($self,$ber,$arg) = @_;
1904    my($i,$m,$err);
1905
1906    $m = @$arg;
1907    my $want = Convert::BER::tag($ber);
1908
1909    for($i = 1 ; $i < $m ; $i += 2) {
1910      my $tag;
1911      my $type = $arg->[$i];
1912
1913      ($type,$tag) = @$type
1914	  if(ref($type) eq 'ARRAY');
1915
1916      my $can = UNIVERSAL::can($ber,'_' . $type);
1917
1918      die "Unknown element '$type'"
1919	  unless $can;
1920
1921      my $data = &$can();
1922
1923      $tag = $data->[ Convert::BER::_TAG() ]
1924	  unless defined $tag;
1925
1926      next unless $tag == $want;
1927
1928      if ( eval { Convert::BER::_decode($ber,[@{$arg}[$i,$i+1]]) }) {
1929	my $choice = $arg->[0];
1930	$$choice = ($i - 1) >> 1;
1931	return 1;
1932      }
1933      $err = $@ if $@;
1934    }
1935    die ($err || sprintf("Cannot decode CHOICE, found tag 0x%X\n",$want));
1936}
1937
19381;
1939