File Coverage

blib/lib/Convert/ASN1.pm
Criterion Covered Total %
statement 157 241 65.1
branch 51 80 63.8
condition 7 14 50.0
subroutine 29 33 87.9
pod 13 19 68.4
total 257 387 66.4


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