1# Copyright (c) 2000-2002 Graham Barr <gbarr@pobox.com>. All rights reserved.
2# This program is free software; you can redistribute it and/or
3# modify it under the same terms as Perl itself.
4
5package Convert::ASN1;
6$Convert::ASN1::VERSION = '0.33';
7use 5.004;
8use strict;
9use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS @opParts @opName $AUTOLOAD);
10use Exporter;
11
12use constant CHECK_UTF8 => $] > 5.007;
13
14BEGIN {
15  local $SIG{__DIE__};
16  eval { require bytes and 'bytes'->import };
17
18  if (CHECK_UTF8) {
19    require Encode;
20    require utf8;
21  }
22
23  @ISA = qw(Exporter);
24
25  %EXPORT_TAGS = (
26    io    => [qw(asn_recv asn_send asn_read asn_write asn_get asn_ready)],
27
28    debug => [qw(asn_dump asn_hexdump)],
29
30    const => [qw(ASN_BOOLEAN     ASN_INTEGER      ASN_BIT_STR      ASN_OCTET_STR
31		 ASN_NULL        ASN_OBJECT_ID    ASN_REAL         ASN_ENUMERATED
32		 ASN_SEQUENCE    ASN_SET          ASN_PRINT_STR    ASN_IA5_STR
33		 ASN_UTC_TIME    ASN_GENERAL_TIME ASN_RELATIVE_OID
34		 ASN_UNIVERSAL   ASN_APPLICATION  ASN_CONTEXT      ASN_PRIVATE
35		 ASN_PRIMITIVE   ASN_CONSTRUCTOR  ASN_LONG_LEN     ASN_EXTENSION_ID ASN_BIT)],
36
37    tag   => [qw(asn_tag asn_decode_tag2 asn_decode_tag asn_encode_tag asn_decode_length asn_encode_length)]
38  );
39
40  @EXPORT_OK = map { @$_ } values %EXPORT_TAGS;
41  $EXPORT_TAGS{all} = \@EXPORT_OK;
42
43  @opParts = qw(
44    cTAG cTYPE cVAR cLOOP cOPT cEXT cCHILD cDEFINE
45  );
46
47  @opName = qw(
48    opUNKNOWN opBOOLEAN opINTEGER opBITSTR opSTRING opNULL opOBJID opREAL
49    opSEQUENCE opEXPLICIT opSET opUTIME opGTIME opUTF8 opANY opCHOICE opROID opBCD
50    opEXTENSIONS
51  );
52
53  foreach my $l (\@opParts, \@opName) {
54    my $i = 0;
55    foreach my $name (@$l) {
56      my $j = $i++;
57      no strict 'refs';
58      *{__PACKAGE__ . '::' . $name} = sub () { $j }
59    }
60  }
61}
62
63sub _internal_syms {
64  my $pkg = caller;
65  no strict 'refs';
66  for my $sub (@opParts,@opName,'dump_op') {
67    *{$pkg . '::' . $sub} = \&{__PACKAGE__ . '::' . $sub};
68  }
69}
70
71sub ASN_BOOLEAN 	() { 0x01 }
72sub ASN_INTEGER 	() { 0x02 }
73sub ASN_BIT_STR 	() { 0x03 }
74sub ASN_OCTET_STR 	() { 0x04 }
75sub ASN_NULL 		() { 0x05 }
76sub ASN_OBJECT_ID 	() { 0x06 }
77sub ASN_REAL 		() { 0x09 }
78sub ASN_ENUMERATED	() { 0x0A }
79sub ASN_RELATIVE_OID	() { 0x0D }
80sub ASN_SEQUENCE 	() { 0x10 }
81sub ASN_SET 		() { 0x11 }
82sub ASN_PRINT_STR	() { 0x13 }
83sub ASN_IA5_STR		() { 0x16 }
84sub ASN_UTC_TIME	() { 0x17 }
85sub ASN_GENERAL_TIME	() { 0x18 }
86
87sub ASN_UNIVERSAL 	() { 0x00 }
88sub ASN_APPLICATION 	() { 0x40 }
89sub ASN_CONTEXT 	() { 0x80 }
90sub ASN_PRIVATE		() { 0xC0 }
91
92sub ASN_PRIMITIVE	() { 0x00 }
93sub ASN_CONSTRUCTOR	() { 0x20 }
94
95sub ASN_LONG_LEN	() { 0x80 }
96sub ASN_EXTENSION_ID	() { 0x1F }
97sub ASN_BIT 		() { 0x80 }
98
99
100sub new {
101  my $pkg = shift;
102  my $self = bless {}, $pkg;
103
104  $self->configure(@_);
105  $self;
106}
107
108
109sub configure {
110  my $self = shift;
111  my %opt = @_;
112
113  $self->{options}{encoding} = uc($opt{encoding} || 'BER');
114
115  unless ($self->{options}{encoding} =~ /^[BD]ER$/) {
116    require Carp;
117    Carp::croak("Unsupported encoding format '$opt{encoding}'");
118  }
119
120  # IMPLICIT as default for backwards compatibility, even though it's wrong.
121  $self->{options}{tagdefault} = uc($opt{tagdefault} || 'IMPLICIT');
122
123  unless ($self->{options}{tagdefault} =~ /^(?:EXPLICIT|IMPLICIT)$/) {
124    require Carp;
125    Carp::croak("Default tagging must be EXPLICIT/IMPLICIT. Not $opt{tagdefault}");
126  }
127
128
129  for my $type (qw(encode decode)) {
130    if (exists $opt{$type}) {
131      while(my($what,$value) = each %{$opt{$type}}) {
132	$self->{options}{"${type}_${what}"} = $value;
133      }
134    }
135  }
136}
137
138
139
140sub find {
141  my $self = shift;
142  my $what = shift;
143  return unless exists $self->{tree}{$what};
144  my %new = %$self;
145  $new{script} = $new{tree}->{$what};
146  bless \%new, ref($self);
147}
148
149
150sub prepare {
151  my $self = shift;
152  my $asn  = shift;
153
154  $self = $self->new unless ref($self);
155  my $tree;
156  if( ref($asn) eq 'GLOB' ){
157    local $/ = undef;
158    my $txt = <$asn>;
159    $tree = Convert::ASN1::parser::parse($txt,$self->{options}{tagdefault});
160  } else {
161    $tree = Convert::ASN1::parser::parse($asn,$self->{options}{tagdefault});
162  }
163
164  unless ($tree) {
165    $self->{error} = $@;
166    return;
167    ### If $self has been set to a new object, not returning
168    ### this object here will destroy the object, so the caller
169    ### won't be able to get at the error.
170  }
171
172  $self->{tree} = _pack_struct($tree);
173  $self->{script} = (values %$tree)[0];
174  $self;
175}
176
177sub prepare_file {
178  my $self = shift;
179  my $asnp = shift;
180
181  local *ASN;
182  open( ASN, $asnp )
183      or do{ $self->{error} = $@; return; };
184  my $ret = $self->prepare( \*ASN );
185  close( ASN );
186  $ret;
187}
188
189sub registeroid {
190  my $self = shift;
191  my $oid  = shift;
192  my $handler = shift;
193
194  $self->{options}{oidtable}{$oid}=$handler;
195  $self->{oidtable}{$oid}=$handler;
196}
197
198sub registertype {
199   my $self = shift;
200   my $def = shift;
201   my $type = shift;
202   my $handler = shift;
203
204   $self->{options}{handlers}{$def}{$type}=$handler;
205}
206
207# In XS the will convert the tree between perl and C structs
208
209sub _pack_struct { $_[0] }
210sub _unpack_struct { $_[0] }
211
212##
213## Encoding
214##
215
216sub encode {
217  my $self  = shift;
218  my $stash = @_ == 1 ? shift : { @_ };
219  my $buf = '';
220  local $SIG{__DIE__};
221  eval { _encode($self->{options}, $self->{script}, $stash, [], $buf) }
222    or do { $self->{error} = $@; undef }
223}
224
225
226
227# Encode tag value for encoding.
228# We assume that the tag has been correctly generated with asn_tag()
229
230sub asn_encode_tag {
231  $_[0] >> 8
232    ? $_[0] & 0x8000
233      ? $_[0] & 0x800000
234	? pack("V",$_[0])
235	: substr(pack("V",$_[0]),0,3)
236      : pack("v", $_[0])
237    : pack("C",$_[0]);
238}
239
240
241# Encode a length. If < 0x80 then encode as a byte. Otherwise encode
242# 0x80 | num_bytes followed by the bytes for the number. top end
243# bytes of all zeros are not encoded
244
245sub asn_encode_length {
246
247  if($_[0] >> 7) {
248    my $lenlen = &num_length;
249
250    return pack("Ca*", $lenlen | 0x80,  substr(pack("N",$_[0]), -$lenlen));
251  }
252
253  return pack("C", $_[0]);
254}
255
256
257##
258## Decoding
259##
260
261sub decode {
262  my $self  = shift;
263  my $ret;
264
265  local $SIG{__DIE__};
266  eval {
267    my (%stash, $result);
268    my $script = $self->{script};
269    my $stash = \$result;
270
271    while ($script) {
272      my $child = $script->[0] or last;
273      if (@$script > 1 or defined $child->[cVAR]) {
274        $result = $stash = \%stash;
275        last;
276      }
277      last if $child->[cTYPE] == opCHOICE or $child->[cLOOP];
278      $script = $child->[cCHILD];
279    }
280
281    _decode(
282	$self->{options},
283	$self->{script},
284	$stash,
285	0,
286	length $_[0],
287	undef,
288	{},
289	$_[0]);
290
291    $ret = $result;
292    1;
293  } or $self->{'error'} = $@ || 'Unknown error';
294
295  $ret;
296}
297
298
299sub asn_decode_length {
300  return unless length $_[0];
301
302  my $len = unpack("C",$_[0]);
303
304  if($len & 0x80) {
305    $len &= 0x7f or return (1,-1);
306
307    return if $len >= length $_[0];
308
309    return (1+$len, unpack("N", "\0" x (4 - $len) . substr($_[0],1,$len)));
310  }
311  return (1, $len);
312}
313
314
315sub asn_decode_tag {
316  return unless length $_[0];
317
318  my $tag = unpack("C", $_[0]);
319  my $n = 1;
320
321  if(($tag & 0x1f) == 0x1f) {
322    my $b;
323    do {
324      return if $n >= length $_[0];
325      $b = unpack("C",substr($_[0],$n,1));
326      $tag |= $b << (8 * $n++);
327    } while($b & 0x80);
328  }
329  ($n, $tag);
330}
331
332
333sub asn_decode_tag2 {
334  return unless length $_[0];
335
336  my $tag = unpack("C",$_[0]);
337  my $num = $tag & 0x1f;
338  my $len = 1;
339
340  if($num == 0x1f) {
341    $num = 0;
342    my $b;
343    do {
344      return if $len >= length $_[0];
345      $b = unpack("C",substr($_[0],$len++,1));
346      $num = ($num << 7) + ($b & 0x7f);
347    } while($b & 0x80);
348  }
349  ($len, $tag, $num);
350}
351
352
353##
354## Utilities
355##
356
357# How many bytes are needed to encode a number
358
359sub num_length {
360  $_[0] >> 8
361    ? $_[0] >> 16
362      ? $_[0] >> 24
363	? 4
364	: 3
365      : 2
366    : 1
367}
368
369# Convert from a bigint to an octet string
370
371sub i2osp {
372    my($num, $biclass) = @_;
373    eval "use $biclass";
374    $num = $biclass->new($num);
375    my $neg = $num < 0
376      and $num = abs($num+1);
377    my $base = $biclass->new(256);
378    my $result = '';
379    while($num != 0) {
380        my $r = $num % $base;
381        $num = ($num-$r) / $base;
382        $result .= pack("C",$r);
383    }
384    $result ^= pack("C",255) x length($result) if $neg;
385    return scalar reverse $result;
386}
387
388# Convert from an octet string to a bigint
389
390sub os2ip {
391    my($os, $biclass) = @_;
392    eval "require $biclass";
393    my $base = $biclass->new(256);
394    my $result = $biclass->new(0);
395    my $neg = unpack("C",$os) >= 0x80
396      and $os ^= pack("C",255) x length($os);
397    for (unpack("C*",$os)) {
398      $result = ($result * $base) + $_;
399    }
400    return $neg ? ($result + 1) * -1 : $result;
401}
402
403# Given a class and a tag, calculate an integer which when encoded
404# will become the tag. This means that the class bits are always
405# in the bottom byte, so are the tag bits if tag < 30. Otherwise
406# the tag is in the upper 3 bytes. The upper bytes are encoded
407# with bit8 representing that there is another byte. This
408# means the max tag we can do is 0x1fffff
409
410sub asn_tag {
411  my($class,$value) = @_;
412
413  die sprintf "Bad tag class 0x%x",$class
414    if $class & ~0xe0;
415
416  unless ($value & ~0x1f or $value == 0x1f) {
417    return (($class & 0xe0) | $value);
418  }
419
420  die sprintf "Tag value 0x%08x too big\n",$value
421    if $value & 0xffe00000;
422
423  $class = ($class | 0x1f) & 0xff;
424
425  my @t = ($value & 0x7f);
426  unshift @t, (0x80 | ($value & 0x7f)) while $value >>= 7;
427  unpack("V",pack("C4",$class,@t,0,0));
428}
429
430
431BEGIN {
432  # When we have XS &_encode will be defined by the XS code
433  # so will all the subs in these required packages
434  unless (defined &_encode) {
435    require Convert::ASN1::_decode;
436    require Convert::ASN1::_encode;
437    require Convert::ASN1::IO;
438  }
439
440  require Convert::ASN1::parser;
441}
442
443sub AUTOLOAD {
444  require Convert::ASN1::Debug if $AUTOLOAD =~ /dump/;
445  goto &{$AUTOLOAD} if defined &{$AUTOLOAD};
446  require Carp;
447  my $pkg = ref($_[0]) || ($_[0] =~ /^[\w\d]+(?:::[\w\d]+)*$/)[0];
448  if ($pkg and UNIVERSAL::isa($pkg, __PACKAGE__)) { # guess it was a method call
449    $AUTOLOAD =~ s/.*:://;
450    Carp::croak(sprintf q{Can't locate object method "%s" via package "%s"},$AUTOLOAD,$pkg);
451  }
452  else {
453    Carp::croak(sprintf q{Undefined subroutine &%s called}, $AUTOLOAD);
454  }
455}
456
457sub DESTROY {}
458
459sub error { $_[0]->{error} }
4601;
461