1# -*- perl -*-
2
3# Copyright (c) 2007 by Jeff Weisberg
4# Author: Jeff Weisberg <jaw+pause @ tcp4me.com>
5# Created: 2007-Jan-28 16:03 (EST)
6# Function: BER encoding/decoding (also: CER and DER)
7#
8# $Id: BER.pm,v 1.11 2008/05/31 18:43:11 jaw Exp $
9
10# references: ITU-T x.680 07/2002  -  ASN.1
11# references: ITU-T x.690 07/2002  -  BER
12
13package Encoding::BER;
14use vars qw($VERSION);
15$VERSION = '1.02';
16use Carp;
17use strict;
18# loaded on demand if needed:
19#   POSIX
20# used if already loaded:
21#   Math::BigInt
22
23=head1 NAME
24
25Encoding::BER - Perl module for encoding/decoding data using ASN.1 Basic Encoding Rules (BER)
26
27=head1 SYNOPSIS
28
29  use Encoding::BER;
30  my $enc = Encoding::BER->new();
31  my $ber = $enc->encode( $data );
32  my $xyz = $enc->decode( $ber );
33
34=head1 DESCRIPTION
35
36Unlike many other BER encoder/decoders, this module uses tree structured data
37as the interface to/from the encoder/decoder.
38
39The decoder does not require any form of template or description of the
40data to be decoded. Given arbitrary BER encoded data, the decoder produces
41a tree shaped perl data structure from it.
42
43The encoder takes a perl data structure and produces a BER encoding from it.
44
45=head1 METHODS
46
47=over 4
48
49=cut
50    ;
51
52################################################################
53
54my %CLASS =
55(
56 universal	=> { v => 0,	},
57 application	=> { v => 0x40, },
58 context	=> { v => 0x80, },
59 private	=> { v => 0xC0, },
60 );
61
62my %TYPE =
63(
64 primitive	=> { v => 0,	},
65 constructed	=> { v => 0x20, },
66 );
67
68my %TAG =
69(
70 universal => {
71     content_end       => { v => 0,     },
72     boolean           => { v => 1,     e => \&encode_bool,   d => \&decode_bool   },
73     integer           => { v => 2,     e => \&encode_int,    d => \&decode_int    },
74     bit_string	       => { v => 3,     e => \&encode_bits,   d => \&decode_bits,   dc => \&reass_string, rule => 1 },
75     octet_string      => { v => 4,     e => \&encode_string, d => \&decode_string, dc => \&reass_string, rule => 1 },
76     null              => { v => 5,     e => \&encode_null,   d => \&decode_null   },
77     oid	       => { v => 6,     e => \&encode_oid,    d => \&decode_oid    },
78     object_descriptor => { v => 7,     implicit => 'octet_string' },
79     external	       => { v => 8,     type => ['constructed']    },
80     real      	       => { v => 9,     e => \&encode_real,   d => \&decode_real   },
81     enumerated        => { v => 0xA,   implicit => 'integer'      },
82     embedded_pdv      => { v => 0xB,   e => \&encode_string, d => \&decode_string, dc => \&reass_string },
83     utf8_string       => { v => 0xC,   implicit => 'octet_string' },
84     relative_oid      => { v => 0xD,   e => \&encode_roid,   d => \&decode_roid   },
85     # reserved
86     # reserved
87     sequence	       => { v => 0x10,  type => ['constructed'] },
88     set               => { v => 0x11,  type => ['constructed'] },
89     numeric_string    => { v => 0x12,  implicit => 'octet_string' },
90     printable_string  => { v => 0x13,  implicit => 'octet_string' },
91     teletex_string    => { v => 0x14,  implicit => 'octet_string' },
92     videotex_string   => { v => 0x15,  implicit => 'octet_string' },
93     ia5_string        => { v => 0x16,  implicit => 'octet_string' },
94     universal_time    => { v => 0x17,  implicit => 'octet_string' },
95     generalized_time  => { v => 0x18,  implicit => 'octet_string' },
96     graphic_string    => { v => 0x19,  implicit => 'octet_string' },
97     visible_string    => { v => 0x1a,  implicit => 'octet_string' },
98     general_string    => { v => 0x1b,  implicit => 'octet_string' },
99     universal_string  => { v => 0x1c,  implicit => 'octet_string' },
100     character_string  => { v => 0x1d,  implicit => 'octet_string' },
101     bmp_string        => { v => 0x1e,  implicit => 'octet_string' },
102 },
103
104 private => {
105     # extra.
106     # no, the encode/decode functions are not mixed up.
107     # yes, this module handles large tag-numbers.
108     integer32	       => { v => 0xFFF0, type => ['private'], e => \&encode_uint32, d => \&decode_int   },
109     unsigned_int      => { v => 0xFFF1, type => ['private'], e => \&encode_uint,   d => \&decode_uint  },
110     unsigned_int32    => { v => 0xFFF2, type => ['private'], e => \&encode_uint32, d => \&decode_uint  },
111 },
112);
113
114# synonyms
115my %AKATAG =
116(
117 bool				=> 'boolean',
118 int				=> 'integer',
119 string				=> 'octet_string',
120 object_identifier		=> 'oid',
121 relative_object_identifier	=> 'relative_oid',
122 roid				=> 'relative_oid',
123 float				=> 'real',
124 enum				=> 'enumerated',
125 sequence_of			=> 'sequence',
126 set_of				=> 'set',
127 t61_string			=> 'teletex_string',
128 iso646_string			=> 'visible_string',
129 int32				=> 'integer32',
130 unsigned_integer		=> 'unsigned_int',
131 uint				=> 'unsigned_int',
132 uint32				=> 'unsigned_int32',
133 # ...
134);
135
136# insert name into above data
137my %ALLTAG;
138my %REVTAG;
139
140# insert name + class into above data
141# build reverse map, etc.
142init_tag_lookups( \%TAG, \%ALLTAG, \%REVTAG );
143
144my %REVCLASS = map {
145    ( $CLASS{$_}{v} => $_ )
146} keys %CLASS;
147
148my %REVTYPE = map {
149    ( $TYPE{$_}{v} => $_ )
150} keys %TYPE;
151
152################################################################
153
154=item new(option => value, ...)
155
156constructor.
157
158    example:
159    my $enc = Encoding::BER->new( error => sub{ die "$_[1]\n" } );
160
161the following options are available:
162
163=over 4
164
165=item error
166
167coderef called if there is an error. will be called with 2 parameters,
168the Encoding::BER object, and the error message.
169
170    # example: die on error
171    error => sub{ die "oops! $_[1]\n" }
172
173=item warn
174
175coderef called if there is something to warn about. will be called with 2 parameters,
176the Encoding::BER object, and the error message.
177
178    # example: warn for warnings
179    warn => sub{ warn "how odd! $_[1]\n" }
180
181
182=item decoded_callback
183
184coderef called for every element decoded. will be called with 2 parameters,
185the Encoding::BER object, and the decoded data. [see DECODED DATA]
186
187    # example: bless decoded results into a useful class
188    decoded_callback => sub{ bless $_[1], MyBER::Result }
189
190=item debug
191
192boolean. if true, large amounts of useless gibberish will be sent to stderr regarding
193the encoding or decoding process.
194
195    # example: enable gibberish output
196    debug => 1
197
198=back
199
200=cut
201    ;
202
203sub new {
204    my $cl = shift;
205    my $me = bless { @_ }, $cl;
206
207    $me;
208}
209
210sub error {
211    my $me  = shift;
212    my $msg = shift;
213
214    if( my $f = $me->{error} ){
215	$f->($me, $msg);
216    }else{
217	croak ((ref $me) . ": $msg\n");
218    }
219    undef;
220}
221
222sub warn {
223    my $me  = shift;
224    my $msg = shift;
225
226    if( my $f = $me->{warn} ){
227	$f->($me, $msg);
228    }else{
229	carp ((ref $me) . ": $msg\n");
230    }
231    undef;
232}
233
234sub debug {
235    my $me  = shift;
236    my $msg = shift;
237
238    return unless $me->{debug};
239    print STDERR "  " x $me->{level}, $msg, "\n";
240    undef;
241}
242
243################################################################
244
245sub add_tag_hash {
246    my $me    = shift;
247    my $class = shift;
248    my $type  = shift;
249    my $name  = shift;
250    my $num   = shift;
251    my $data  = shift;
252
253    return $me->error("invalid class: $class") unless $CLASS{$class};
254    return $me->error("invalid type: $type")   unless $TYPE{$type};
255
256    $data->{type} = [$class, $type];
257    $data->{v}    = $num;
258    $data->{n}    = $name;
259
260    # install forward + reverse mappings
261    $me->{tags}{$name} = $data;
262    $me->{revtags}{$class}{$num} = $name;
263
264    $me;
265}
266
267=item add_implicit_tag(class, type, tag-name, tag-number, base-tag)
268
269add a new tag similar to another tag. class should be one of C<universal>,
270C<application>, C<context>, or C<private>. type should be either C<primitive>
271or C<contructed>. tag-name should specify the name of the new tag.
272tag-number should be the numeric tag number. base-tag should specify the
273name of the tag this is equivalent to.
274
275    example: add a tagged integer
276    in ASN.1: width-index ::= [context 42] implicit integer
277
278    $ber->add_implicit_tag('context', 'primitive', 'width-index', 42, 'integer');
279
280=cut
281    ;
282
283sub add_implicit_tag {
284    my $me    = shift;
285    my $class = shift;
286    my $type  = shift;
287    my $name  = shift;
288    my $num   = shift;
289    my $base  = shift;
290
291    return $me->error("unknown base tag name: $base")
292	unless $me->tag_data_byname($base);
293
294    $me->add_tag_hash($class, $type, $name, $num, {
295	implicit => $base,
296    });
297}
298
299sub add_tag {
300    my $me    = shift;
301    my $class = shift;
302    my $type  = shift;
303    my $name  = shift;
304    my $num   = shift;
305    # possibly optional:
306    my $encf  = shift;
307    my $decf  = shift;
308    my $encfc = shift;
309    my $decfc = shift;
310
311    $me->add_tag_hash($class, $type, $name, $num, {
312	e  => $encf,
313	d  => $decf,
314	ec => $encfc,
315	dc => $decfc,
316    });
317}
318
319sub init_tag_lookups {
320    my $TAG = shift;
321    my $ALL = shift;
322    my $REV = shift;
323
324    for my $class (keys %$TAG){
325	for my $name (keys %{$TAG->{$class}}){
326	    $TAG->{$class}{$name}{n} = $name;
327	    $ALL->{$name} = $TAG->{$class}{$name};
328	}
329	my %d = map {
330	    ($TAG->{$class}{$_}{v} => $_)
331	    } keys %{$TAG->{$class}};
332	$REV->{$class} = \%d;
333    }
334}
335
336################################################################
337
338=item encode( data )
339
340BER encode the provided data. [see: ENCODING DATA]
341
342  example:
343  my $ber = $enc->encode( [0, 'public', [7.3, 0, 0, ['foo', 'bar']]] );
344
345=cut
346    ;
347
348sub encode {
349    my $me   = shift;
350    my $data = shift;
351    my $levl = shift;
352
353    $me->{level} = $levl || 0;
354    $data = $me->canonicalize($data) if $me->{acanonical} || !$me->behaves_like_a_hash($data);
355
356    # include pre-encoded data as is
357    if( $data->{type} eq 'BER_preencoded' ){
358	return $data->{value};
359    }
360
361    $data = $me->rule_check_and_apply($data) || $data;
362    my($typeval, $tagnum, $encfnc) = $me->ident_data_and_efunc($data->{type});
363    my $value;
364
365    if( $typeval & 0x20 ){
366	$me->debug( "encode constructed ($typeval/$tagnum) [" );
367	# constructed - recurse
368	my @vs = ref($data->{value}) ? @{$data->{value}} : $data->{value};
369	for my $e (@vs){
370	    $value .= $me->encode( $e, $me->{level} + 1 );
371	}
372	$me->{level} = $levl || 0;
373	$me->debug("]");
374    }else{
375	$me->debug( "encode primitive ($typeval/$tagnum)" );
376
377	unless( $encfnc ){
378	    # try to guess encoding
379	    my @t = ref($data->{type}) ? @{$data->{type}} : $data->{type};
380	    $me->warn("do not know how to encode identifier [@t] ($typeval/$tagnum)");
381	    $encfnc = \&encode_unknown;
382	}
383	$value = $encfnc->($me, $data);
384    }
385
386    my $defp = $me->use_definite_form($typeval, $data);
387    my $leng = $me->encode_length(length($value));
388
389    my $res;
390    if( $defp && defined($leng) ){
391	$me->debug("encode definite form");
392	$res = $me->encode_ident($typeval, $tagnum) . $leng . $value;
393    }else{
394	$me->debug("encode indefinite form");
395	$res = $me->encode_ident($typeval, $tagnum) . "\x80" . $value . "\x00\x00";
396	# x.690:                                      8.3.6.1           8.1.5
397    }
398
399    $data->{dlen} = length($value);
400    $data->{tlen} = length($res);
401
402    $res;
403}
404
405sub encode_null {
406    my $me = shift;
407    $me->debug('encode null');
408    '';
409}
410
411sub encode_unknown {
412    my $me   = shift;
413    my $data = shift;
414
415    $me->debug('encode unknown');
416    '' . $data->{value};
417}
418
419sub encode_string {
420    my $me   = shift;
421    my $data = shift;
422
423    # CER splitting of long strings is handled in CER subclass
424    $me->debug('encode string');
425    '' . $data->{value};
426}
427
428sub encode_bits {
429    my $me   = shift;
430    my $data = shift;
431
432    # x.690 8.6
433    $me->debug('encode bitstring');
434    "\0" . $data->{value};
435
436}
437
438sub encode_bool {
439    my $me   = shift;
440    my $data = shift;
441
442    # x.690 11.1
443    $me->debug('encode boolean');
444    $data->{value} ? "\xFF" : "\x0";
445}
446
447sub encode_int {
448    my $me   = shift;
449    my $data = shift;
450    my $val  = $data->{value};
451
452    my @i;
453    my $big;
454
455    if( _have_math_bigint() ){
456	# value is a bigint or a long string
457	$big = 1 if (ref $val && $val->can('as_hex')) || length($val) > 8;
458    }
459
460    if( $big ){
461	my $x = Math::BigInt->new($val);
462	$me->debug("bigint $val => $x");
463	my $sign = $x->is_neg() ? 0xff : 0;
464	if( $sign ){
465	    # NB: in 2s comp: -X = ~(X-1) = ~X+1
466	    $x = $x->bneg()->bsub(1)->as_hex();
467	    $x =~ s/^0x//;
468	    $x = '0'.$x if length($x) & 1;
469	    @i = map{ ~$_ & 0xff } unpack('C*', pack('H*', $x));
470	    unshift @i, 0xff unless $i[0] & 0x80;
471	}else{
472	    $x = $x->as_hex();
473	    $x =~ s/^0x//;
474	    $x = '0'.$x if length($x) & 1;
475	    @i = unpack('C*', pack('H*', $x));
476	    unshift @i, 0 if $i[0] & 0x80;
477	}
478	$me->debug("encode big int [@i]");
479    }else{
480	my $sign = ($val < 0) ? 0xff : 0;
481	while(1){
482	    unshift @i, $val & 0xFF;
483	    last if $val >= -128 && $val < 128;
484	    # NB: >>= does not preserve sign.
485	    $val = int(($val - $sign)/256);
486	}
487	$me->debug("encode int [@i]");
488    }
489    pack('C*', @i);
490}
491
492sub encode_uint {
493    my $me   = shift;
494    my $data = shift;
495    my $val  = $data->{value};
496
497    my @i;
498    my $big;
499
500    if( _have_math_bigint() ){
501	# value is a bigint or a long string
502	$big = 1 if (ref $val && $val->can('bcmp')) || length($val) > 8;
503    }
504
505    if( $big ){
506	my $x = Math::BigInt->new($val)->as_hex();
507	$x =~ s/^0x//;
508	$x = '0' . $x if length($x) & 1;
509	$me->debug("encode big unsigned int");
510	pack('H*', $x);
511    }else{
512	while($val){
513	    unshift @i, $val & 0xFF;
514	    $val >>= 8;
515	}
516	$me->debug("encode unsigned int [@i]");
517	pack('C*', @i);
518    }
519}
520
521
522sub encode_uint32 {
523    my $me   = shift;
524    my $data = shift;
525    my $val  = $data->{value};
526
527    # signed or unsigned. -1 == 0xffffffff
528    $me->debug("encode unsigned int32");
529    pack('N', $val);
530}
531
532sub encode_real {
533    my $me   = shift;
534    my $data = shift;
535    my $val  = $data->{value};
536
537    return '' unless $val;		# x.690 8.5.2
538    return "\x40" if $val eq 'inf';	# x.690 8.5.8
539    return "\x41" if $val eq '-inf';	# x.690 8.5.8
540
541    # POSIX required. available?
542    eval {
543	require POSIX;
544    };
545    return $me->error("POSIX not available. cannot encode type real")
546	unless defined &POSIX::frexp;
547
548    my $sign = 0;
549    my($mant, $exp) = POSIX::frexp($val);
550    if( $mant < 0 ){
551	$sign = 1;
552	$mant = - $mant;
553    }
554
555    #$me->debug("encode real: $mant ^ $exp");
556
557    # go byte-by-byte
558    my @mant;
559    while($mant > 0){
560	my($frac, $int) = POSIX::modf(POSIX::ldexp($mant, 8));
561	push @mant, $int;
562	$mant = $frac;
563	$exp -= 8;
564	# $me->debug("encode real: [@mant] ^ $exp");
565    }
566    #$me->debug("encode real: [@mant] ^ $exp");
567
568    if( $data->{flavor} || $me->{flavor} ){
569	# x.690 8.5.6.5, 11.3.1 - CER + DER require N has a 1 in the lsb
570	# normalize
571	while( ! ($mant[-1] & 1) ){
572	    # shift right
573	    my $c = 0;
574	    for (@mant){
575		my $l = $_ & 1;
576		$_ = ($_>>1) | ($c?0x80:0);
577		$c = $l;
578	    }
579	    $exp ++;
580	}
581	#$me->debug("encode real normalized: [@mant] ^ $exp");
582    }
583
584    # encode exp
585    my @exp;
586    my $exps = ($exp < 0) ? 0xff : 0;
587    while(1){
588	unshift @exp, $exp & 0xFF;
589	last if $exp >= -128 && $exp < 128;
590	# >>= does not preserve sign.
591	$exp = int(($exp - $exps)/256);
592    }
593
594    $me->debug("encode real: [@mant] ^ [@exp]");
595
596    my $first = 0x80 | ($sign ? 0x40 : 0);
597
598    if(@exp == 2){
599	$first |= 1;
600    }
601    if(@exp == 3){
602	$first |= 2;
603    }
604    if(@exp > 3){
605	# should not happen using ieee-754 doubles
606	$first |= 3;
607	unshift @exp, scalar(@exp);
608    }
609
610    pack('C*', $first, @exp, @mant);
611}
612
613sub encode_oid {
614    my $me   = shift;
615    my $data = shift;
616    my $val  = $data->{value};
617    # "1.3.6.1.2.0" | [1, 3, 6, 1, 2, 0]
618
619    # x.690 8.19
620    my @o = ref($val) ? @$val : (split /\./, $val);
621    shift @o if $o[0] eq ''; # remove empty in case specified with leading .
622
623    if( @o > 1 ){
624	# x.690 8.19.4
625	my $o = shift @o;
626	$o[0] += $o * 40;
627    }
628
629    $me->debug("encode oid [@o]");
630    pack('w*', @o);
631}
632
633sub encode_roid {
634    my $me   = shift;
635    my $data = shift;
636    my $val  = $data->{value};
637    # "1.3.6.1.2.0" | [1, 3, 6, 1, 2, 0]
638
639    # x.690 8.20
640    my @o = ref($val) ? @$val : (split /\./, $val);
641    shift @o if $o[0] eq ''; # remove empty in case specified with leading .
642    # no special encoding of 1st 2
643
644    $me->debug("encode relative-oid [@o]");
645    pack('w*', @o);
646}
647
648
649################################################################
650
651sub encode_ident {
652    my $me   = shift;
653    my $type = shift;
654    my $tnum = shift;
655
656    if( $tnum < 31 ){
657	return pack('C', $type|$tnum);
658    }
659    $type |= 0x1f;
660    pack('Cw', $type, $tnum);
661}
662
663sub encode_length {
664    my $me  = shift;
665    my $len = shift;
666
667    return pack('C', $len)        if $len < 128;	# x.690 8.1.3.4
668    return pack('CC', 0x81, $len) if $len < 1<<8;	# x.690 8.1.3.5
669    return pack('Cn', 0x82, $len) if $len < 1<<12;
670    return pack('CCn',0x83, ($len>>16), ($len&0xFFFF)) if $len < 1<<16;
671    return pack('CN', 0x84, $len) if $len <= 0xFFFFFFFF;
672
673    # items larger than above will be encoded in indefinite form
674    return;
675}
676
677# override me in subclass
678sub rule_check_and_apply {
679    my $me   = shift;
680    my $data = shift;
681
682    undef;
683}
684
685# convert DWIM values => canonical form
686sub canonicalize {
687    my $me   = shift;
688    my $data = shift;
689
690    # arrayref | int | float | string | undef
691
692    unless( defined $data ){
693	return {
694	    type	=> 'null',
695	    value	=> undef,
696	};
697    }
698
699    if( $me->behaves_like_an_array($data) ){
700	return {
701	    type	=> 'sequence',
702	    value	=> $data,
703	};
704    }
705
706    if( $me->behaves_like_a_hash($data) ){
707	return {
708	    type	=> ['application', 'constructed', 3],
709	    value	=> [ %$data ],
710	};
711    }
712
713    if( $me->smells_like_a_number($data) ){
714	return {
715	    type	=> ( int($data) == $data ? 'integer' : 'real'),
716	    value	=> $data,
717	};
718    }
719
720    # call it a string
721    return {
722	type	=> 'octet_string',
723	value	=> $data,
724    };
725}
726
727# tags added via add_tag method
728sub app_tag_data_byname {
729    my $me    = shift;
730    my $name  = shift;
731
732    $me->{tags}{$name};
733}
734
735# override me in subclass
736sub subclass_tag_data_byname {
737    my $me    = shift;
738    my $name  = shift;
739
740    undef;
741}
742
743# from the table up top
744sub univ_tag_data_byname {
745    my $me    = shift;
746    my $name  = shift;
747
748    $ALLTAG{$name} || ($AKATAG{$name} && $ALLTAG{$AKATAG{$name}});
749}
750
751sub tag_data_byname {
752    my $me    = shift;
753    my $name  = shift;
754
755    my $th;
756    # application specific tag name
757    $th = $me->app_tag_data_byname($name);
758
759    # subclass specific tag name
760    $th = $me->subclass_tag_data_byname($name) unless $th;
761
762    # universal tag name
763    $th = $me->univ_tag_data_byname($name) unless $th;
764
765    $th;
766}
767
768sub class_and_type_from_speclist {
769    my $me = shift;
770    my($class, $type);
771    for my $t (@_){
772	if( $CLASS{$t} ){ $class = $t; next }
773	if( $TYPE{$t}  ){ $type  = $t; next }
774	$me->error("unknown type specification [$t] not a class or type");
775    }
776    ($class, $type);
777}
778
779sub ident_data_and_efunc {
780    my $me   = shift;
781    my $typd = shift;
782    my $func = shift;
783
784    $func ||= 'e';
785    my @t = ref($typd) ? @$typd : ($typd);
786
787    # type: name | [class, type, name] | [class, type, num]
788    # if name resolves, specified class+type for validation only
789
790    my $tname = pop @t;
791    if( $me->smells_like_a_number($tname) ){
792	my($class, $type) = $me->class_and_type_from_speclist( @t );
793	$class ||= 'universal';
794	$type  ||= 'primitive';
795	my $tv = $CLASS{$class}{v} | $TYPE{$type}{v};
796	my $tm = $tname + 0;
797	$me->debug("numeric specification [@t $tname] resolved to [$class $type $tm]");
798	return ( $tv, $tm, undef );
799    }
800
801    my $th = $me->tag_data_byname($tname);
802
803    unless( $th ){
804	$me->error("unknown type [$tname]");
805    }
806    unless( ref $th ){
807	$me->error("programmer botch. tag data should be hashref: [$tname] => $th");
808	$th = undef;
809    }
810
811    my( $class, $type, $rclass, $rtype, $tnum, $encf );
812
813    # parse request
814    ($rclass, $rtype) = $me->class_and_type_from_speclist( @t );
815    # parse spec
816    if( my $ts = $th->{type} ){
817	($class,  $type) = $me->class_and_type_from_speclist( @$ts );
818    }
819
820    # use these values for identifier-value
821    $class ||= 'universal';
822    $type  = $rtype || $type || 'primitive';
823    $tnum  = $th->{v};
824
825    $me->debug("specificication [@t $tname] resolved to [$class $type $tname($tnum)]");
826    # warn if mismatched
827    $me->warn("specificication [$rclass $tname] resolved to [$class $tname]")
828	if $rclass && $rclass ne $class;
829
830    # indirect via implicit to find encoding func
831    $encf = $th->{$func};
832    if( my $impl = $th->{implicit} ){
833	# only one level of indirection
834	$th = $me->tag_data_byname($impl);
835
836	if( ref $th ){
837	    $me->debug("specificication [$class $type $tname($tnum)] is implictly $impl ");
838	    $encf ||= $th->{$func};
839	}else{
840	    $me->error("programmer botch. implicit indirect not found: [$class $tname] => $impl");
841	}
842    }
843
844    my $tv = $CLASS{$class}{v} | $TYPE{$type}{v};
845    return( $tv, $tnum, $encf );
846}
847
848sub use_definite_form {
849    my $me   = shift;
850    my $type = shift;
851    my $data = shift;
852
853    return 1 unless $type & 0x20;		# x.690 8.1.3.2 - primitive - always definite
854
855    my $fl = $data->{flavor} || $me->{flavor};
856    return 1 unless $fl;
857    return 1 if $fl eq 'DER';			# x.690 10.1 - DER - always definite
858    return 0 if $fl eq 'CER';			# x.690 9.1  - CER + constructed - indefinite
859    1;						# otherwise, prefer definite
860}
861
862################################################################
863
864sub behaves_like_an_array {
865    my $me = shift;
866    my $d  = shift;
867
868    return unless ref $d;
869    return UNIVERSAL::isa($d, 'ARRAY');
870}
871
872sub behaves_like_a_hash {
873    my $me = shift;
874    my $d  = shift;
875
876    return unless ref $d;
877
878    # treat as if it is a number
879    return if UNIVERSAL::isa($d, 'Math::BigInt');
880    return UNIVERSAL::isa($d, 'HASH');
881}
882
883sub smells_like_a_number {
884    my $me = shift;
885    my $d  = shift;
886
887    return 1 if ref $d && UNIVERSAL::isa($d, 'Math::BigInt');
888    # NB: 5.00503 does not have 'no warnings';
889    local $^W = 0;
890    return ($d + 0 eq $d);
891}
892
893################################################################
894
895=item decode( ber )
896
897Decode the provided BER encoded data. returns a perl data structure.
898[see: DECODED DATA]
899
900  example:
901  my $data = $enc->decode( $ber );
902
903=cut
904    ;
905
906sub decode {
907    my $me   = shift;
908    my $data = shift;
909
910    $me->{level} = 0;
911    my($v, $l) = $me->decode_item($data, 0);
912    $v;
913}
914
915sub decode_items {
916    my $me   = shift;
917    my $data = shift;
918    my $eocp = shift;
919    my $levl = shift;
920    my @v;
921    my $tlen = 0;
922
923    $me->{level} = $levl;
924    $me->debug("decode items[");
925    while($data){
926	my($val, $len) = $me->decode_item($data, $levl+1);
927	$tlen += $len;
928	unless( $val && defined $val->{type} ){
929	    # end-of-content
930	    $me->debug('end of content');
931	    last if $eocp;
932	}
933
934	push @v, $val;
935	$data = substr($data, $len);
936    }
937
938    $me->{level} = $levl;
939    $me->debug(']');
940    return (\@v, $tlen);
941}
942
943sub decode_item {
944    my $me   = shift;
945    my $data = shift;
946    my $levl = shift;
947
948    # hexdump($data, 'di:');
949    $me->{level} = $levl;
950    my($typval, $typlen, $typmore)         = $me->decode_ident($data);
951    my($typdat, $decfnc, $pretty, $tagnum) = $me->ident_descr_and_dfuncs($typval, $typmore);
952    my($datlen, $lenlen)                   = $me->decode_length(substr($data,$typlen));
953    my $havlen = length($data);
954    my $tlen   = $typlen + $lenlen + ($datlen || 0);
955    my $doff   = $typlen + $lenlen;
956    my $result;
957
958    $me->error("corrupt data? data appears truncated")
959	if $havlen < $tlen;
960
961    if( $typval & 0x20 ){
962	# constructed
963	my $vals;
964
965	if( defined $datlen ){
966	    # definite
967	    $me->debug("decode item: constructed definite [@$typdat($tagnum)]");
968	    my($v, $t) = $me->decode_items( substr($data, $doff, $datlen), 0, $levl);
969	    $me->{level} = $levl;
970	    $me->warn("corrupt data? item len != data len ($t, $datlen)")
971		unless $t == $datlen;
972	    $vals = $v;
973	}else{
974	    # indefinite
975	    $me->debug("decode item: constructed indefinite [@$typdat($tagnum)]");
976	    my($v, $t) = $me->decode_items( substr($data, $doff), 1, $levl );
977	    $me->{level} = $levl;
978	    $tlen += $t;
979	    $tlen += 2; # eoc
980	    $vals = $v;
981	}
982	if( $decfnc ){
983	    # constructed decode func: reassemble
984	    $result = $decfnc->( $me, $vals, $typdat );
985	}else{
986	    $result = {
987		value   => $vals,
988	    };
989	}
990    }else{
991	# primitive
992	my $ndat;
993	if( defined $datlen ){
994	    # definite
995	    $me->debug("decode item: primitive definite [@$typdat($tagnum)]");
996	    $ndat = substr($data, $doff, $datlen);
997	}else{
998	    # indefinite encoding of a primitive is a violation of x.690 8.1.3.2(a)
999	    # warn + parse it anyway
1000	    $me->debug("decode item: primitive indefinite [@$typdat($tagnum)]");
1001	    $me->warn("protocol violation - indefinite encoding of primitive. see x.690 8.1.3.2(a)");
1002	    my $i = index($data, "\0\0", $doff);
1003	    if( $i == -1 ){
1004		# invalid encoding.
1005		# no eoc found.
1006		# go back to protocol school.
1007		$me->error("corrupt data - content terminator not found. see x.690 8.1.3.6, 8.1.5, et al. ");
1008		return (undef, $tlen);
1009	    }
1010	    my $dl = $i - $doff;
1011	    $tlen += $dl;
1012	    $tlen += 2; # eoc
1013	    $ndat = substr($data, $doff, $dl);
1014	}
1015
1016	unless( $typval || $typmore ){
1017	    # universal-primitive-tag(0) => end-of-content
1018	    return ( { }, $tlen );
1019	}
1020
1021	# decode it
1022	$decfnc ||= \&decode_unknown;
1023	my $val = $decfnc->( $me, $ndat, $typdat );
1024
1025	# format value in a special pretty way?
1026	if( $pretty ){
1027	    $val = $pretty->( $me, $val ) || $val;
1028	}
1029	$result = $val;
1030    }
1031
1032    $result->{type}     = $typdat;
1033    $result->{tagnum}   = $tagnum;
1034    $result->{identval} = $typval;
1035
1036    if( my $c = $me->{decoded_callback} ){
1037	$result = $c->( $me, $result ) || $result;  # make sure the brain hasn't fallen out
1038    }
1039    return( $result, $tlen );
1040}
1041
1042sub app_tag_data_bynumber {
1043    my $me    = shift;
1044    my $class = shift;
1045    my $tnum  = shift;
1046
1047    my $name = $me->{revtags}{$class}{$tnum};
1048    return unless $name;
1049
1050    $me->{tags}{$name};
1051}
1052
1053# override me in subclass
1054sub subclass_tag_data_bynumber {
1055    my $me    = shift;
1056    my $class = shift;
1057    my $tnum  = shift;
1058
1059    undef;
1060}
1061
1062sub univ_tag_data_bynumber {
1063    my $me    = shift;
1064    my $class = shift;
1065    my $tnum  = shift;
1066
1067    $TAG{$class}{ $REVTAG{$class}{$tnum} };
1068}
1069
1070sub tag_data_bynumber {
1071    my $me    = shift;
1072    my $class = shift;
1073    my $tnum  = shift;
1074
1075    my $th;
1076    # application specific tag name
1077    $th = $me->app_tag_data_bynumber($class, $tnum);
1078
1079    # subclass specific tag name
1080    $th = $me->subclass_tag_data_bynumber($class, $tnum) unless $th;
1081
1082    # from universal
1083    $th = $me->univ_tag_data_bynumber($class, $tnum) unless $th;
1084
1085    $th;
1086}
1087
1088sub ident_descr_and_dfuncs {
1089    my $me   = shift;
1090    my $tval = shift;
1091    my $more = shift;
1092
1093    my $tag = $more || ($tval & 0x1f) || 0;
1094    my $cl  = $tval & 0xC0;
1095    my $ty  = $tval & 0x20;
1096    my $class  = $REVCLASS{$cl};
1097    my $pctyp  = $REVTYPE{$ty};
1098
1099    my( $th, $tn, $tf, $tp );
1100
1101    $th = $me->tag_data_bynumber($class, $tag);
1102
1103    if( ref $th ){
1104	$tn = $th->{n};
1105	$tp = $th->{pretty};
1106
1107	if( my $impl = $th->{implicit} ){
1108	    # indirect. we support only one level.
1109	    my $h = $me->tag_data_byname($impl);
1110	    if( ref $h ){
1111		$th = $h;
1112	    }else{
1113		$me->error("programmer botch. implicit indirect not found: $class/$tn => $impl");
1114	    }
1115	}
1116	# primitive decode func or constructed decode func?
1117	$tp ||= $th->{pretty};
1118	$tf   = $ty ? $th->{dc} : $th->{d};
1119    }elsif( $th ){
1120	$me->error("programmer botch. tag data should be hashref: $class/$tag => $th");
1121    }else{
1122        $me->warn("unknown type [$class $tag]");
1123    }
1124
1125    $tn = $tag unless defined $tn;
1126
1127    $me->debug("identifier $tval/$tag resolved to [$class $pctyp $tn]");
1128    # [class, type, tagname], decodefunc, tagnumber
1129    ([$class, $pctyp, $tn], $tf, $tp, $tag);
1130}
1131
1132sub decode_length {
1133    my $me   = shift;
1134    my $data = shift;
1135
1136    my($l1) = unpack('C', $data);
1137
1138    unless( $l1 & 0x80 ){
1139	# x.690 8.1.3.4 - short form
1140	return ($l1, 1);
1141    }
1142    if( $l1 == 0x80 ){
1143	# x.690 8.1.3.6 - indefinite form
1144	return (undef, 1);
1145    }
1146
1147    # x.690 8.1.3.5 - long form
1148    my $llen = $l1 & 0x7f;
1149    my @l = unpack("C$llen", substr($data, 1));
1150
1151    my $len = 0;
1152    for my $l (@l){
1153	$len <<= 8;
1154	$len += $l;
1155    }
1156
1157    ($len, $llen + 1);
1158}
1159
1160sub decode_ident {
1161    my $me   = shift;
1162    my $data = shift;
1163
1164    my($tag) = unpack('C', $data);
1165    return ($tag, 1) unless ($tag & 0x1f) == 0x1f;	# x.690 8.1.2.3
1166
1167    # x.690 8.1.2.4 - tag numbers > 30
1168    my $i = 1;
1169    $tag &= ~0x1f;
1170    my $more = 0;
1171    while(1){
1172	my $c = unpack('C', substr($data,$i++,1));
1173	$more <<= 7;
1174	$more |= ($c & 0x7f);
1175	last unless $c & 0x80;
1176    }
1177
1178    ($tag, $i, $more);
1179}
1180
1181sub decode_bool {
1182    my $me   = shift;
1183    my $data = shift;
1184    my $type = shift;
1185
1186    my $v = unpack('C', $data);
1187
1188    {
1189	value => $v,
1190    };
1191}
1192
1193sub decode_null {
1194    my $me   = shift;
1195    my $data = shift;
1196    my $type = shift;
1197
1198    {
1199	value => undef,
1200    };
1201}
1202
1203# reassemble constructed string
1204sub reass_string {
1205    my $me   = shift;
1206    my $vals = shift;
1207    my $type = shift;
1208
1209    my $val = '';
1210    for my $v (@$vals){
1211	$val .= $v->{value};
1212    };
1213
1214    $me->debug('reassemble constructed string');
1215    return {
1216	type  => [ $type->[0], 'primitive', $type->[2] ],
1217	value => $val,
1218    };
1219
1220}
1221
1222sub decode_string {
1223    my $me   = shift;
1224    my $data = shift;
1225    my $type = shift;
1226
1227    {
1228	value => $data,
1229    };
1230}
1231
1232sub decode_bits {
1233    my $me   = shift;
1234    my $data = shift;
1235    my $type = shift;
1236
1237    my $pad = unpack('C', $data);
1238    # QQQ - remove padding?
1239
1240    $data = substr($data, 1);
1241
1242    {
1243	value => $data,
1244    };
1245}
1246
1247sub decode_int {
1248    my $me   = shift;
1249    my $data = shift;
1250    my $type = shift;
1251
1252    my $val = $me->part_decode_int($data, 1);
1253    $me->debug("decode integer: $val");
1254    {
1255	value => $val,
1256    };
1257}
1258
1259sub decode_uint {
1260    my $me   = shift;
1261    my $data = shift;
1262    my $type = shift;
1263
1264    my $val = $me->part_decode_int($data, 0);
1265    $me->debug("decode unsigned integer: $val");
1266    {
1267	value => $val,
1268    };
1269}
1270
1271sub part_decode_int {
1272    my $me   = shift;
1273    my $data = shift;
1274    my $sgnd = shift;
1275
1276    my $val;
1277    my $big;
1278    $big = 1 if _have_math_bigint() && length($data) > 4;
1279
1280    if( $big ){
1281	my $sign = unpack('c', $data) < 0;
1282	if( $sgnd && $sign ){
1283	    # make negative
1284	    $val = Math::BigInt->new('0x' . unpack('H*', pack('C*', map {~$_ & 0xff} unpack('C*', $data))));
1285	    $val->bneg()->bsub(1);
1286	}else{
1287	    $val = Math::BigInt->new('0x' . unpack('H*', $data));
1288	}
1289
1290    }else{
1291	$val  = unpack(($sgnd ? 'c' : 'C'),  $data);
1292	my @o    = unpack('C*', $data);
1293	shift @o;
1294	for my $i (@o){
1295	    $val *= 256;
1296	    $val += $i;
1297	}
1298    }
1299
1300    $val;
1301}
1302
1303sub decode_real {
1304    my $me   = shift;
1305    my $data = shift;
1306    my $type = shift;
1307
1308    $me->debug('decode real');
1309    return { value => 0.0 } unless $data;
1310
1311    # POSIX required. available?
1312    eval {
1313	require POSIX;
1314    };
1315    return $me->error("POSIX not available. cannot decode type real")
1316	unless defined &POSIX::frexp;
1317
1318    my $first = unpack('C', $data);
1319    return { value => POSIX::HUGE_VAL()   } if $first == 0x40;
1320    return { value => - POSIX::HUGE_VAL() } if $first == 0x41;
1321
1322    if( $first & 0x80 ){
1323	# binary encoding
1324	my $sign = ($first & 0x40) ? -1 : 1;
1325	my $base = ($first & 0x30) >> 4;
1326	my $scal = [0, 1, -2, -1]->[($first & 0x0C) >> 2];
1327	my $expl = ($first & 0x03) + 1;
1328
1329	$data = substr($data, 1);
1330
1331	if( $expl == 4 ){
1332	    $expl = unpack('C', $data);
1333	    $data = substr($data, 1);
1334	}
1335
1336	my $exp  = $me->part_decode_int( substr($data, 0, $expl), 1 );
1337	$data = substr($data, $expl);
1338	my @mant = unpack('C*', $data);
1339	$me->debug("decode real: [@mant] $exp");
1340
1341	# apply scale factor
1342	$exp *= 3 if $base == 1;
1343	$exp *= 4 if $base == 2;
1344	$me->error('corrupt data: invalid base for real') if $base == 3;
1345	$exp += $scal;
1346
1347	# put it together
1348	my $val = 0;
1349	$exp += (@mant - 1) * 8;
1350	for my $m (@mant){
1351	    $val += POSIX::ldexp($m, $exp);
1352	    # $me->debug("decode real: $val ($m, $exp)");
1353	    $exp -= 8;
1354	}
1355	$val *= $sign;
1356
1357	$me->debug("decode real: => $val");
1358	return { value => $val };
1359    }else{
1360	# decimal encoding
1361	# x.690 8.5.7 - see iso-6093
1362	$me->debug('decode real decimal');
1363	$data = substr($data, 1);
1364	$data =~ s/^([+-]?)0+/$1/;	# remove leading 0s
1365	$data =~ s/\s//g;		# remove spaces
1366	$data += 0;			# make number
1367
1368	return { value => $data };
1369    }
1370
1371}
1372
1373sub decode_oid {
1374    my $me   = shift;
1375    my $data = shift;
1376    my $type = shift;
1377
1378    my @o = unpack('w*', $data);
1379
1380    if( $o[0] < 40 ){
1381	unshift @o, 0;
1382    }elsif( $o[0] < 80 ){
1383	$o[0] -= 40;
1384	unshift @o, 1;
1385    }else{
1386	$o[0] -= 80;
1387	unshift @o, 2;
1388    }
1389
1390    my $val = join('.', @o);
1391    $me->debug("decode oid: $val");
1392
1393    {
1394	value => $val,
1395    };
1396}
1397
1398sub decode_roid {
1399    my $me   = shift;
1400    my $data = shift;
1401    my $type = shift;
1402
1403    my @o = unpack('w*', $data);
1404
1405    my $val = join('.', @o);
1406    $me->debug("decode relative-oid: $val");
1407
1408    {
1409	value => $val,
1410    };
1411}
1412
1413sub decode_unknown {
1414    my $me   = shift;
1415    my $data = shift;
1416    my $type = shift;
1417
1418    $me->debug("decode unknown");
1419    {
1420	value => $data,
1421    };
1422}
1423
1424sub _have_math_bigint {
1425
1426    return unless defined &Math::BigInt::new;
1427    return unless defined &Math::BigInt::is_neg;
1428
1429    1;
1430}
1431
1432################################################################
1433
1434sub hexdump {
1435    my $b   = shift;
1436    my $tag = shift;
1437    my( $l, $t );
1438
1439    print STDERR "$tag:\n" if $tag;
1440    while( $b ){
1441	$t = $l = substr($b, 0, 16, '');
1442	$l =~ s/(.)/sprintf('%0.2X ',ord($1))/ges;
1443	$l =~ s/(.{24})/$1 /;
1444	$t =~ s/[[:^print:]]/./gs;
1445	my $p = ' ' x (49 - (length $l));
1446	print STDERR "    $l  $p$t\n";
1447    }
1448}
1449
1450sub import {
1451    my $pkg    = shift;
1452    my $caller = caller;
1453
1454    for my $f (@_){
1455	no strict;
1456	my $fnc = $pkg->can($f);
1457	next unless $fnc;
1458	*{$caller . '::' . $f} = $fnc;
1459    }
1460}
1461
1462=back
1463
1464=head1 ENCODING DATA
1465
1466You can give data to the encoder in either of two ways (or mix and match).
1467
1468You can specify simple values directly, and the module will guess the
1469correct tags to use. Things that look like integers will be encoded as
1470C<integer>, things that look like floating-point numbers will be encoded
1471as C<real>, things that look like strings, will be encoded as C<octet_string>.
1472Arrayrefs will be encoded as C<sequence>.
1473
1474  example:
1475  $enc->encode( [0, 1.2, "foobar", [ "baz", 37.94 ]] );
1476
1477Alternatively, you can explicity specify the type using a hashref
1478containing C<type> and C<value> keys.
1479
1480  example:
1481  $enc->encode( { type  => 'sequence',
1482                  value => [
1483                             { type  => 'integer',
1484                               value => 37 } ] } );
1485
1486The type may be specfied as either a string containg the tag-name, or
1487as an arryref containing the class, type, and tag-name.
1488
1489  example:
1490  type => 'octet_string'
1491  type => ['universal', 'primitive', 'octet_string']
1492
1493Note: using the second form above, you can create wacky encodings
1494that no one will be able to decode.
1495
1496The value should be a scalar value for primitive types, and an
1497arrayref for constructed types.
1498
1499  example:
1500  { type => 'octet_string', value => 'foobar' }
1501  { type => 'set', value => [ 1, 2, 3 ] }
1502
1503  { type  => ['universal', 'constructed', 'octet_string'],
1504    value => [ 'foo', 'bar' ] }
1505
1506=head1 DECODED DATA
1507
1508The values returned from decoding will be similar to the way data to
1509be encoded is specified, in the full long form. Additionally, the hashref
1510will contain: C<identval> the numeric value representing the class+type+tag
1511and C<tagnum> the numeric tag number.
1512
1513  example:
1514  a string might be returned as:
1515  { type     => ['universal', 'primitive', 'octet_string'],
1516    identval => 4,
1517    tagnum   => 4,
1518    value    => 'foobar',
1519  }
1520
1521
1522=head1 TAG NAMES
1523
1524The following are recognized as valid names of tags:
1525
1526    bit_string bmp_string bool boolean character_string embedded_pdv
1527    enum enumerated external float general_string generalized_time
1528    graphic_string ia5_string int int32 integer integer32 iso646_string
1529    null numeric_string object_descriptor object_identifier octet_string
1530    oid printable_string real relative_object_identifier relative_oid
1531    roid sequence sequence_of set set_of string t61_string teletex_string
1532    uint uint32 universal_string universal_time unsigned_int unsigned_int32
1533    unsigned_integer utf8_string videotex_string visible_string
1534
1535=head1 Math::BigInt
1536
1537If you have Math::BigInt, it can be used for large integers. If you want it used,
1538you must load it yourself:
1539
1540    use Math::BigInt;
1541    use Encoding::BER;
1542
1543It can be used for both encoding and decoding. The encoder can be handed either
1544a Math::BigInt object, or a "big string of digits" marked as an integer:
1545
1546    use math::BigInt;
1547
1548    my $x = Math::BigInt->new( '12345678901234567890' );
1549    $enc->encode( $x )
1550
1551    $enc->encode( { type => 'integer', '12345678901234567890' } );
1552
1553During decoding, a Math::BigInt object will be created if the value "looks big".
1554
1555
1556=head1 EXPORTS
1557
1558By default, this module exports nothing. This can be overridden by specifying
1559something else:
1560
1561    use Encoding::BER ('import', 'hexdump');
1562
1563=head1 LIMITATIONS
1564
1565If your application uses the same tag-number for more than one type of implicitly
1566tagged primitive, the decoder will not be able to distinguish between them, and will
1567not be able to decode them both correctly. eg:
1568
1569    width ::= [context 12] implicit integer
1570    girth ::= [context 12] implicit real
1571
1572If you specify data to be encoded using the "short form", the module may
1573guess the type differently than you expect. If it matters, be explicit.
1574
1575This module does not do data validation. It will happily let you encode
1576a non-ascii string as a C<ia5_string>, etc.
1577
1578
1579=head1 PREREQUISITES
1580
1581If you wish to use C<real>s, the POSIX module is required. It will be loaded
1582automatically, if needed.
1583
1584Familiarity with ASN.1 and BER encoding is probably required to take
1585advantage of this module.
1586
1587=head1 SEE ALSO
1588
1589    Yellowstone National Park
1590    Encoding::BER::CER, Encoding::BER::DER
1591    Encoding::BER::SNMP, Encoding::BER::Dumper
1592    ITU-T x.690
1593
1594=head1 AUTHOR
1595
1596    Jeff Weisberg - http://www.tcp4me.com
1597
1598=cut
1599    ;
1600
1601################################################################
16021;
1603
1604