File Coverage

blib/lib/Convert/ASN1/_decode.pm
Criterion Covered Total %
statement 185 247 74.9
branch 112 200 56.0
condition 32 86 37.2
subroutine 18 19 94.7
pod n/a
total 347 552 62.9


line stmt bran cond sub pod time code
1             # Copyright (c) 2000-2005 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             BEGIN {
8 15     15   269   local $SIG{__DIE__};
9 15 50       269   eval { require bytes and 'bytes'->import };
  15         389  
10             }
11              
12             # These are the subs that do the decode, they are called with
13             # 0 1 2 3 4
14             # $optn, $op, $stash, $var, $buf
15             # The order must be the same as the op definitions above
16              
17             my @decode = (
18               sub { die "internal error\n" },
19               \&_dec_boolean,
20               \&_dec_integer,
21               \&_dec_bitstring,
22               \&_dec_string,
23               \&_dec_null,
24               \&_dec_object_id,
25               \&_dec_real,
26               \&_dec_sequence,
27               \&_dec_set,
28               \&_dec_time,
29               \&_dec_time,
30               \&_dec_utf8,
31               undef, # ANY
32               undef, # CHOICE
33               \&_dec_object_id,
34               \&_dec_bcd,
35             );
36              
37             my @ctr;
38             @ctr[opBITSTR, opSTRING, opUTF8] = (\&_ctr_bitstring,\&_ctr_string,\&_ctr_string);
39              
40              
41             sub _decode {
42 127     127   1376   my ($optn, $ops, $stash, $pos, $end, $seqof, $larr) = @_;
43 127         1089   my $idx = 0;
44              
45             # we try not to copy the input buffer at any time
46 127         1845   foreach my $buf ($_[-1]) {
47 127         1213     OP:
48 127         1487     foreach my $op (@{$ops}) {
49 149         1663       my $var = $op->[cVAR];
50              
51 149 100       1785       if (length $op->[cTAG]) {
52              
53             TAGLOOP: {
54 142         1197 my($tag,$len,$npos,$indef) = _decode_tl($buf,$pos,$end,$larr)
55 161 100       4240 or do {
56 1 50 33     22 next OP if $pos==$end and ($seqof || defined $op->[cOPT]);
      33        
57 0         0 die "decode error";
58             };
59              
60 160 100       1928 if ($tag eq $op->[cTAG]) {
61              
62 156 50       2969 &{$decode[$op->[cTYPE]]}(
  156 100       2020  
    100          
63             $optn,
64             $op,
65             $stash,
66             # We send 1 if there is not var as if there is the decode
67             # should be getting undef. So if it does not get undef
68             # it knows it has no variable
69             ($seqof ? $seqof->[$idx++] : defined($var) ? $stash->{$var} : ref($stash) eq 'SCALAR' ? $$stash : 1),
70             $buf,$npos,$len, $larr
71             );
72              
73 156         1693 $pos = $npos+$len+$indef;
74              
75 156 100 100     1774 redo TAGLOOP if $seqof && $pos < $end;
76 137         2573 next OP;
77             }
78              
79 4 100 66     78 if ($tag eq ($op->[cTAG] | chr(ASN_CONSTRUCTOR))
80             and my $ctr = $ctr[$op->[cTYPE]])
81             {
82 1         25 _decode(
83             $optn,
84             [$op],
85             undef,
86             $npos,
87             $npos+$len,
88             (\my @ctrlist),
89             $larr,
90             $buf,
91             );
92              
93 1         10 ($seqof ? $seqof->[$idx++] : defined($var) ? $stash->{$var} : ref($stash) eq 'SCALAR' ? $$stash : undef)
94 1 0       11 = &{$ctr}(@ctrlist);
    50          
    50          
95 1         9 $pos = $npos+$len+$indef;
96              
97 1 50 33     12 redo TAGLOOP if $seqof && $pos < $end;
98 1         14 next OP;
99              
100             }
101              
102 3 50 33     83 if ($seqof || defined $op->[cOPT]) {
103 3         30 next OP;
104             }
105              
106 0         0 die "decode error " . unpack("H*",$tag) ."<=>" . unpack("H*",$op->[cTAG]), " ",$pos," ",$op->[cTYPE]," ",$op->[cVAR];
107                     }
108                   }
109                   else { # opTag length is zero, so it must be an ANY or CHOICE
110            
111 7 100       74 if ($op->[cTYPE] == opANY) {
112              
113             ANYLOOP: {
114              
115 2         16 my($tag,$len,$npos,$indef) = _decode_tl($buf,$pos,$end,$larr)
116 2 50       21 or do {
117 0 0 0     0 next OP if $pos==$end and ($seqof || defined $op->[cOPT]);
      0        
118 0         0 die "decode error";
119             };
120              
121 2         20 $len += $npos-$pos;
122              
123 2 50       21              if ($op->[cDEFINE]) {
124 2   33     31                 $handler = $optn->{oidtable} && $optn->{oidtable}{$stash->{$op->[cDEFINE]}};
125 2   33     21                 $handler ||= $optn->{handlers}{$op->[cVAR]}{$stash->{$op->[cDEFINE]}};
126                          }
127              
128 2 50       32 ($seqof ? $seqof->[$idx++] : ref($stash) eq 'SCALAR' ? $$stash : $stash->{$var})
    50          
    50          
129             = $handler ? $handler->decode(substr($buf,$pos,$len)) : substr($buf,$pos,$len);
130              
131 2         18 $pos += $len + $indef;
132              
133 2 50 33     28 redo ANYLOOP if $seqof && $pos < $end;
134             }
135             }
136             else {
137              
138             CHOICELOOP: {
139 5         41 my($tag,$len,$npos,$indef) = _decode_tl($buf,$pos,$end,$larr)
140 7 50       75 or do {
141 0 0 0     0 next OP if $pos==$end and ($seqof || defined $op->[cOPT]);
      0        
142 0         0 die "decode error";
143             };
144 7         64 foreach my $cop (@{$op->[cCHILD]}) {
  7         70  
145              
146 10 100       103 if ($tag eq $cop->[cTAG]) {
147              
148 5 50       69 my $nstash = $seqof
    100          
    100          
149             ? ($seqof->[$idx++]={})
150             : defined($var)
151             ? ($stash->{$var}={})
152             : ref($stash) eq 'SCALAR'
153             ? ($$stash={}) : $stash;
154              
155 5 50       84 &{$decode[$cop->[cTYPE]]}(
  5         57  
156             $optn,
157             $cop,
158             $nstash,
159             ($cop->[cVAR] ? $nstash->{$cop->[cVAR]} : undef),
160             $buf,$npos,$len,$larr,
161             );
162              
163 5         47 $pos = $npos+$len+$indef;
164              
165 5 100 66     63 redo CHOICELOOP if $seqof && $pos < $end;
166 4         52 next OP;
167             }
168              
169 5 100       66 unless (length $cop->[cTAG]) {
170 2 50       18 eval {
171 2         46 _decode(
172             $optn,
173             [$cop],
174             (\my %tmp_stash),
175             $pos,
176             $npos+$len+$indef,
177             undef,
178             $larr,
179             $buf,
180             );
181              
182 2 0       26 my $nstash = $seqof
    0          
    50          
183             ? ($seqof->[$idx++]={})
184             : defined($var)
185             ? ($stash->{$var}={})
186             : ref($stash) eq 'SCALAR'
187             ? ($$stash={}) : $stash;
188              
189 2         24 @{$nstash}{keys %tmp_stash} = values %tmp_stash;
  2         27  
190              
191             } or next;
192              
193 2         20 $pos = $npos+$len+$indef;
194              
195 2 100 66     29 redo CHOICELOOP if $seqof && $pos < $end;
196 1         14 next OP;
197             }
198              
199 3 50 33     42 if ($tag eq ($cop->[cTAG] | chr(ASN_CONSTRUCTOR))
200             and my $ctr = $ctr[$cop->[cTYPE]])
201             {
202 0 0       0 my $nstash = $seqof
    0          
    0          
203             ? ($seqof->[$idx++]={})
204             : defined($var)
205             ? ($stash->{$var}={})
206             : ref($stash) eq 'SCALAR'
207             ? ($$stash={}) : $stash;
208              
209 0         0 _decode(
210             $optn,
211             [$cop],
212             undef,
213             $npos,
214             $npos+$len,
215             (\my @ctrlist),
216             $larr,
217             $buf,
218             );
219              
220 0         0 $nstash->{$cop->[cVAR]} = &{$ctr}(@ctrlist);
  0         0  
221 0         0 $pos = $npos+$len+$indef;
222              
223 0 0 0     0 redo CHOICELOOP if $seqof && $pos < $end;
224 0         0 next OP;
225             }
226             }
227             }
228 0 0       0 die "decode error" unless $op->[cOPT];
229             }
230                   }
231                 }
232               }
233 127 50       2290   die "decode error $pos $end" unless $pos == $end;
234             }
235              
236              
237             sub _dec_boolean {
238             # 0 1 2 3 4 5 6
239             # $optn, $op, $stash, $var, $buf, $pos, $len
240              
241 11 100   11   147   $_[3] = ord(substr($_[4],$_[5],1)) ? 1 : 0;
242 11         97   1;
243             }
244              
245              
246             sub _dec_integer {
247             # 0 1 2 3 4 5 6
248             # $optn, $op, $stash, $var, $buf, $pos, $len
249              
250 57     57   737   my $buf = substr($_[4],$_[5],$_[6]);
251 57 100       585   my $tmp = ord($buf) & 0x80 ? chr(255) : chr(0);
252 57 100       980   if ($_[6] > 4) {
253 11   50     177       $_[3] = os2ip($tmp x (4-$_[6]) . $buf, $_[0]->{decode_bigint} || 'Math::BigInt');
254               } else {
255             # N unpacks an unsigned value
256 46         1149       $_[3] = unpack("l",pack("l",unpack("N", $tmp x (4-$_[6]) . $buf)));
257               }
258 57         5660   1;
259             }
260              
261              
262             sub _dec_bitstring {
263             # 0 1 2 3 4 5 6
264             # $optn, $op, $stash, $var, $buf, $pos, $len
265              
266 4     4   105   $_[3] = [ substr($_[4],$_[5]+1,$_[6]-1), ($_[6]-1)*8-ord(substr($_[4],$_[5],1)) ];
267 4         38   1;
268             }
269              
270              
271             sub _dec_string {
272             # 0 1 2 3 4 5 6
273             # $optn, $op, $stash, $var, $buf, $pos, $len
274              
275 37     37   504   $_[3] = substr($_[4],$_[5],$_[6]);
276 37         411   1;
277             }
278              
279              
280             sub _dec_null {
281             # 0 1 2 3 4 5 6
282             # $optn, $op, $stash, $var, $buf, $pos, $len
283              
284 2     2   24   $_[3] = 1;
285 2         19   1;
286             }
287              
288              
289             sub _dec_object_id {
290             # 0 1 2 3 4 5 6
291             # $optn, $op, $stash, $var, $buf, $pos, $len
292              
293 8     8   2607   my @data = unpack("w*",substr($_[4],$_[5],$_[6]));
294 8 100 66     129   splice(@data,0,1,int($data[0]/40),$data[0] % 40)
295                 if $_[1]->[cTYPE] == opOBJID and @data > 1;
296 8         124   $_[3] = join(".", @data);
297 8         76   1;
298             }
299              
300              
301             my @_dec_real_base = (2,8,16);
302              
303             sub _dec_real {
304             # 0 1 2 3 4 5 6
305             # $optn, $op, $stash, $var, $buf, $pos, $len
306              
307 7 100   7   74   $_[3] = 0.0, return unless $_[6];
308              
309 6         60   my $first = ord(substr($_[4],$_[