File Coverage

blib/lib/Convert/ASN1/_decode.pm
Criterion Covered Total %
statement 229 281 81.4
branch 155 234 66.2
condition 48 98 48.9
subroutine 21 22 95.4
pod n/a
total 453 635 71.3


line stmt bran cond sub pod time code
1             # Copyright (c) 2000-2005 Graham Barr . 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             $Convert::ASN1::VERSION = '0.32'; # TRIAL
7 23     23   149 use strict;
  23         44  
  23         703  
8 23     23   115 use warnings;
  23         42  
  23         1152  
9              
10             BEGIN {
11 23     23   120 local $SIG{__DIE__};
12 23 50       46 eval { require bytes and 'bytes'->import };
  23         196  
13             }
14              
15             # These are the subs that do the decode, they are called with
16             # 0 1 2 3 4
17             # $optn, $op, $stash, $var, $buf
18             # The order must be the same as the op definitions above
19              
20             my @decode = (
21             sub { die "internal error\n" },
22             \&_dec_boolean,
23             \&_dec_integer,
24             \&_dec_bitstring,
25             \&_dec_string,
26             \&_dec_null,
27             \&_dec_object_id,
28             \&_dec_real,
29             \&_dec_sequence,
30             \&_dec_explicit,
31             \&_dec_set,
32             \&_dec_time,
33             \&_dec_time,
34             \&_dec_utf8,
35             undef, # ANY
36             undef, # CHOICE
37             \&_dec_object_id,
38             \&_dec_bcd,
39             );
40              
41             my @ctr;
42             @ctr[opBITSTR, opSTRING, opUTF8] = (\&_ctr_bitstring,\&_ctr_string,\&_ctr_string);
43              
44              
45             sub _decode {
46 516     516   1169 my ($optn, $ops, $stash, $pos, $end, $seqof, $larr) = @_;
47 516         723 my $idx = 0;
48              
49             # we try not to copy the input buffer at any time
50 516         820 foreach my $buf ($_[-1]) {
51             OP:
52 516         633 foreach my $op (@{$ops}) {
  516         849  
53 898         1335 my $var = $op->[cVAR];
54              
55 898 100       1367 if (length $op->[cTAG]) {
56              
57             TAGLOOP: {
58 724         806 my($tag,$len,$npos,$indef) = _decode_tl($buf,$pos,$end,$larr)
59 843 100       1393 or do {
60 25 50 33     110 next OP if $pos==$end and ($seqof || defined $op->[cEXT]);
      66        
61 2         21 die "decode error";
62             };
63              
64 818 100       1585 if ($tag eq $op->[cTAG]) {
65              
66 752         1744 &{$decode[$op->[cTYPE]]}(
67             $optn,
68             $op,
69             $stash,
70             # We send 1 if there is not var as if there is the decode
71             # should be getting undef. So if it does not get undef
72             # it knows it has no variable
73 752 100       1862 ($seqof ? $seqof->[$idx++] : defined($var) ? $stash->{$var} : ref($stash) eq 'SCALAR' ? $$stash : 1),
    100          
    100          
74             $buf,$npos,$len, $larr
75             );
76              
77 752         1188 $pos = $npos+$len+$indef;
78              
79 752 100 100     1558 redo TAGLOOP if $seqof && $pos < $end;
80 633         1191 next OP;
81             }
82              
83 66 100 66     158 if ($tag eq ($op->[cTAG] | pack("C",ASN_CONSTRUCTOR))
84             and my $ctr = $ctr[$op->[cTYPE]])
85             {
86 1         16 _decode(
87             $optn,
88             [$op],
89             undef,
90             $npos,
91             $npos+$len,
92             (\my @ctrlist),
93             $larr,
94             $buf,
95             );
96              
97             ($seqof
98             ? $seqof->[$idx++] # = &{$ctr}(@ctrlist);
99             : defined($var)
100             ? $stash->{$var} # = &{$ctr}(@ctrlist);
101             : ref($stash) eq 'SCALAR'
102             ? $$stash # = &{$ctr}(@ctrlist);
103             : my $any ) # = &{$ctr}(@ctrlist) FIX #43
104 1 0       2 = &{$ctr}(@ctrlist);
  1 50       2  
    50          
105              
106 1         3 $pos = $npos+$len+$indef;
107              
108 1 50 33     3 redo TAGLOOP if $seqof && $pos < $end;
109 1         2 next OP;
110              
111             }
112              
113 65 50 33     175 if ($seqof || defined $op->[cEXT]) {
114 65         103 next OP;
115             }
116              
117 0   0     0 die "decode error " . unpack("H*",$tag) ."<=>" . unpack("H*",$op->[cTAG]), " ",$pos," ",$op->[cTYPE]," ",$op->[cVAR]||'';
118             }
119             }
120             else { # opTag length is zero, so it must be an ANY, CHOICE or EXTENSIONS
121            
122 174 100       327 if ($op->[cTYPE] == opANY) {
    100          
    50          
123              
124             ANYLOOP: {
125              
126 33         41 my($tag,$len,$npos,$indef) = _decode_tl($buf,$pos,$end,$larr)
127 34 100       58 or do {
128 2 50 33     15 next OP if $pos==$end and ($seqof || defined $op->[cEXT]);
      33        
129 0         0 die "decode error";
130             };
131              
132 32         56 $len += $npos - $pos + $indef;
133              
134 32         42 my $handler;
135 32 100       55 if ($op->[cDEFINE]) {
136 2   33     12 $handler = $optn->{oidtable} && $optn->{oidtable}{$stash->{$op->[cDEFINE]}};
137 2   33     5 $handler ||= $optn->{handlers}{$op->[cVAR]}{$stash->{$op->[cDEFINE]}};
138             }
139              
140 32 100       147 ($seqof ? $seqof->[$idx++] : ref($stash) eq 'SCALAR' ? $$stash : $stash->{$var})
    100          
    100          
141             = $handler ? $handler->decode(substr($buf,$pos,$len)) : substr($buf,$pos,$len);
142              
143 32         47 $pos += $len;
144              
145 32 100 100     89 redo ANYLOOP if $seqof && $pos < $end;
146             }
147             }
148             elsif ($op->[cTYPE] == opCHOICE) {
149              
150             CHOICELOOP: {
151 137         155 my($tag,$len,$npos,$indef) = _decode_tl($buf,$pos,$end,$larr)
152 140 50       223 or do {
153 0 0 0     0 next OP if $pos==$end and ($seqof || defined $op->[cEXT]);
      0        
154 0         0 die "decode error";
155             };
156 140         211 my $extensions;
157 140         176 foreach my $cop (@{$op->[cCHILD]}) {
  140         241  
158              
159 273 100       450 if ($tag eq $cop->[cTAG]) {
160              
161             my $nstash = $seqof
162             ? ($seqof->[$idx++]={})
163             : defined($var)
164 137 100       331 ? ($stash->{$var}={})
    100          
    100          
165             : ref($stash) eq 'SCALAR'
166             ? ($$stash={}) : $stash;
167              
168 137         314 &{$decode[$cop->[cTYPE]]}(
169             $optn,
170             $cop,
171             $nstash,
172 137 50       345 ($cop->[cVAR] ? $nstash->{$cop->[cVAR]} : undef),
173             $buf,$npos,$len,$larr,
174             );
175              
176 137         223 $pos = $npos+$len+$indef;
177              
178 137 100 100     250 redo CHOICELOOP if $seqof && $pos < $end;
179 135         273 next OP;
180             }
181              
182 136 100       198 if ($cop->[cTYPE] == opEXTENSIONS) {
183 2         4 $extensions = 1;
184 2         4 next;
185             }
186              
187 134 100       203 unless (length $cop->[cTAG]) {
188 2 50       3 eval {
189 2         23 _decode(
190             $optn,
191             [$cop],
192             (\my %tmp_stash),
193             $pos,
194             $npos+$len+$indef,
195             undef,
196             $larr,
197             $buf,
198             );
199              
200             my $nstash = $seqof
201             ? ($seqof->[$idx++]={})
202             : defined($var)
203 2 0       6 ? ($stash->{$var}={})
    0          
    50          
204             : ref($stash) eq 'SCALAR'
205             ? ($$stash={}) : $stash;
206              
207 2         5 @{$nstash}{keys %tmp_stash} = values %tmp_stash;
  2         8  
208              
209             } or next;
210              
211 2         3 $pos = $npos+$len+$indef;
212              
213 2 100 66     9 redo CHOICELOOP if $seqof && $pos < $end;
214 1         2 next OP;
215             }
216              
217 132 50 33     258 if ($tag eq ($cop->[cTAG] | pack("C",ASN_CONSTRUCTOR))
218             and my $ctr = $ctr[$cop->[cTYPE]])
219             {
220             my $nstash = $seqof
221             ? ($seqof->[$idx++]={})
222             : defined($var)
223 0 0       0 ? ($stash->{$var}={})
    0          
    0          
224             : ref($stash) eq 'SCALAR'
225             ? ($$stash={}) : $stash;
226              
227 0         0 _decode(
228             $optn,
229             [$cop],
230             undef,
231             $npos,
232             $npos+$len,
233             (\my @ctrlist),
234             $larr,
235             $buf,
236             );
237              
238 0         0 $nstash->{$cop->[cVAR]} = &{$ctr}(@ctrlist);
  0         0  
239 0         0 $pos = $npos+$len+$indef;
240              
241 0 0 0     0 redo CHOICELOOP if $seqof && $pos < $end;
242 0         0 next OP;
243             }
244             }
245              
246 1 50 33     7 if ($pos < $end && $extensions) {
247 1         2 $pos = $npos+$len+$indef;
248              
249 1 50 33     20 redo CHOICELOOP if $seqof && $pos < $end;
250 1         4 next OP;
251             }
252             }
253 0 0       0 die "decode error" unless $op->[cEXT];
254             }
255             elsif ($op->[cTYPE] == opEXTENSIONS) {
256 4         10 $pos = $end; # Skip over the rest
257             }
258             else {
259 0         0 die "this point should never be reached";
260             }
261             }
262             }
263             }
264 514 100       1089 die "decode error $pos $end" unless $pos == $end;
265             }
266              
267              
268             sub _dec_boolean {
269             # 0 1 2 3 4 5 6
270             # $optn, $op, $stash, $var, $buf, $pos, $len
271              
272 26 100   26   153 $_[3] = unpack("C",substr($_[4],$_[5],1)) ? 1 : 0;
273 26         50 1;
274             }
275              
276              
277             sub _dec_integer {
278             # 0 1 2 3 4 5 6
279             # $optn, $op, $stash, $var, $buf, $pos, $len
280              
281 89     89   190 my $buf = substr($_[4],$_[5],$_[6]);
282 89 100       302 my $tmp = unpack("C",$buf) & 0x80 ? pack("C",255) : pack("C",0);
283 89 100       215 if ($_[6] > 4) {
284 16   100     104 $_[3] = os2ip($buf, $_[0]->{decode_bigint} || 'Math::BigInt');
285             } else {
286             # N unpacks an unsigned value
287 73         485 $_[3] = unpack("l",pack("l",unpack("N", $tmp x (4-$_[6]) . $buf)));
288             }
289 89         1685 1;
290             }
291              
292              
293             sub _dec_bitstring {
294             # 0 1 2 3 4 5 6
295             # $optn, $op, $stash, $var, $buf, $pos, $len
296              
297 22     22   91 $_[3] = [ substr($_[4],$_[5]+1,$_[6]-1), ($_[6]-1)*8-unpack("C",substr($_[4],$_[5],1)) ];
298 22         33 1;
299             }
300              
301              
302             sub _dec_string {
303             # 0 1 2 3 4 5 6
304             # $optn, $op, $stash, $var, $buf, $pos, $len
305              
306 187     187   473 $_[3] = substr($_[4],$_[5],$_[6]);
307 187         267 1;
308             }
309              
310              
311             sub _dec_null {
312             # 0 1 2 3 4 5 6
313             # $optn, $op, $stash, $var, $buf, $pos, $len
314              
315 2 50   2   16 $_[3] = exists($_[0]->{decode_null}) ? $_[0]->{decode_null} : 1;
316 2         5 1;
317             }
318              
319              
320             sub _dec_object_id {
321             # 0 1 2 3 4 5 6
322             # $optn, $op, $stash, $var, $buf, $pos, $len
323              
324 162     162   359 my @data = unpack("w*",substr($_[4],$_[5],$_[6]));
325 162 100 66     500 if ($_[1]->[cTYPE] == opOBJID and @data > 1) {
326 159 100       314 if ($data[0] < 40) {
    100          
327 4         9 splice(@data, 0, 1, 0, $data[0]);
328             }
329             elsif ($data[0] < 80) {
330 36         72 splice(@data, 0, 1, 1, $data[0] - 40);
331             }
332             else {
333 119         197 splice(@data, 0, 1, 2, $data[0] - 80);
334             }
335             }
336 162         557 $_[3] = join(".", @data);
337 162         261 1;
338             }
339              
340              
341             my @_dec_real_base = (2,8,16);
342              
343             sub _dec_real {
344             # 0 1 2 3 4 5 6
345             # $optn, $op, $stash, $var, $buf, $pos, $len
346              
347 7 100   7   21 $_[3] = 0.0, return unless $_[6];
348              
349 6         16 my $first = unpack("C",substr($_[4],$_[5],1));
350 6 100       19 if ($first & 0x80) {
    50          
    0          
351             # A real number
352              
353 4         19 require POSIX;
354              
355 4         9 my $exp;
356 4         9 my $expLen = $first & 0x3;
357 4         10 my $estart = $_[5]+1;
358              
359 4 50       10 if($expLen == 3) {
360 0         0 $estart++;
361 0         0 $expLen = unpack("C",substr($_[4],$_[5]+1,1));
362             }
363             else {
364 4         9 $expLen++;
365             }
366 4         14 _dec_integer(undef, undef, undef, $exp, $_[4],$estart,$expLen);
367              
368 4         6 my $mant = 0.0;
369 4         25 for (reverse unpack("C*",substr($_[4],$estart+$expLen,$_[6]-1-$expLen))) {
370 5         19 $exp +=8, $mant = (($mant+$_) / 256) ;
371             }
372              
373 4         13 $mant *= 1 << (($first >> 2) & 0x3);
374 4 100       13 $mant = - $mant if $first & 0x40;
375              
376 4         69 $_[3] = $mant * POSIX::pow($_dec_real_base[($first >> 4) & 0x3], $exp);
377 4         586 return;
378             }
379             elsif($first & 0x40) {
380 2 100       9 $_[3] = POSIX::HUGE_VAL(),return if $first == 0x40;
381 1 50       8 $_[3] = - POSIX::HUGE_VAL(),return if $first == 0x41;
382             }
383             elsif(substr($_[4],$_[5],$_[6]) =~ /^.([-+]?)0*(\d+(?:\.\d+(?:[Ee][-+]?\d+)?)?)$/s) {
384 0         0 $_[3] = eval "$1$2";
385 0         0 return;
386             }
387              
388 0         0 die "REAL decode error\n";
389             }
390              
391              
392             sub _dec_explicit {
393             # 0 1 2 3 4 5 6 7
394             # $optn, $op, $stash, $var, $buf, $pos, $len, $larr
395              
396 20 100   20   48 local $_[1][cCHILD][0][cVAR] = $_[1][cVAR] unless $_[1][cCHILD][0][cVAR];
397              
398 20         108 _decode(
399             $_[0], #optn
400             $_[1]->[cCHILD], #ops
401             $_[2], #stash
402             $_[5], #pos
403             $_[5]+$_[6], #end
404             undef, #loop
405             $_[7],
406             $_[4], #buf
407             );
408 20         30 1;
409             }
410             sub _dec_sequence {
411             # 0 1 2 3 4 5 6 7
412             # $optn, $op, $stash, $var, $buf, $pos, $len, $larr
413              
414 361 50   361   612 if (defined( my $ch = $_[1]->[cCHILD])) {
415 361 100 100     2121 _decode(
      100        
416             $_[0], #optn
417             $ch, #ops
418             (defined($_[3]) || $_[1]->[cLOOP]) ? $_[2] : ($_[3]= {}), #stash
419             $_[5], #pos
420             $_[5]+$_[6], #end
421             $_[1]->[cLOOP] && ($_[3]=[]), #loop
422             $_[7],
423             $_[4], #buf
424             );
425             }
426             else {
427 0         0 $_[3] = substr($_[4],$_[5],$_[6]);
428             }
429 361         468 1;
430             }
431              
432              
433             sub _dec_set {
434             # 0 1 2 3 4 5 6 7
435             # $optn, $op, $stash, $var, $buf, $pos, $len, $larr
436              
437             # decode SET OF the same as SEQUENCE OF
438 8     8   13 my $ch = $_[1]->[cCHILD];
439 8 50 33     39 goto &_dec_sequence if $_[1]->[cLOOP] or !defined($ch);
440              
441 8         23 my ($optn, $pos, $larr) = @_[0,5,7];
442 8 50       19 my $stash = defined($_[3]) ? $_[2] : ($_[3]={});
443 8         13 my $end = $pos + $_[6];
444 8         14 my @done;
445             my $extensions;
446              
447 8         21 while ($pos < $end) {
448 26 50       52 my($tag,$len,$npos,$indef) = _decode_tl($_[4],$pos,$end,$larr)
449             or die "decode error";
450              
451 26         54 my ($idx, $any, $done) = (-1);
452              
453             SET_OP:
454 26         69 foreach my $op (@$ch) {
455 69         90 $idx++;
456 69 100       153 if (length($op->[cTAG])) {
    50          
    50          
    50          
457 55 100       105 if ($tag eq $op->[cTAG]) {
458 25         43 my $var = $op->[cVAR];
459 25         81 &{$decode[$op->[cTYPE]]}(
460             $optn,
461             $op,
462             $stash,
463             # We send 1 if there is not var as if there is the decode
464             # should be getting undef. So if it does not get undef
465             # it knows it has no variable
466 25 50       75 (defined($var) ? $stash->{$var} : 1),
467             $_[4],$npos,$len,$larr,
468             );
469 25         45 $done = $idx;
470 25         42 last SET_OP;
471             }
472 30 50 33     72 if ($tag eq ($op->[cTAG] | pack("C",ASN_CONSTRUCTOR))
473             and my $ctr = $ctr[$op->[cTYPE]])
474             {
475 0         0 _decode(
476             $optn,
477             [$op],
478             undef,
479             $npos,
480             $npos+$len,
481             (\my @ctrlist),
482             $larr,
483             $_[4],
484             );
485              
486 0 0       0 $stash->{$op->[cVAR]} = &{$ctr}(@ctrlist)
  0         0  
487             if defined $op->[cVAR];
488 0         0 $done = $idx;
489 0         0 last SET_OP;
490             }
491 30         48 next SET_OP;
492             }
493             elsif ($op->[cTYPE] == opANY) {
494 0         0 $any = $idx;
495             }
496             elsif ($op->[cTYPE] == opCHOICE) {
497 0         0 my $var = $op->[cVAR];
498 0         0 foreach my $cop (@{$op->[cCHILD]}) {
  0         0  
499 0 0       0 if ($tag eq $cop->[cTAG]) {
500 0 0       0 my $nstash = defined($var) ? ($stash->{$var}={}) : $stash;
501              
502 0         0 &{$decode[$cop->[cTYPE]]}(
503             $optn,
504             $cop,
505             $nstash,
506 0         0 $nstash->{$cop->[cVAR]},
507             $_[4],$npos,$len,$larr,
508             );
509 0         0 $done = $idx;
510 0         0 last SET_OP;
511             }
512 0 0 0     0 if ($tag eq ($cop->[cTAG] | pack("C",ASN_CONSTRUCTOR))
513             and my $ctr = $ctr[$cop->[cTYPE]])
514             {
515 0 0       0 my $nstash = defined($var) ? ($stash->{$var}={}) : $stash;
516              
517 0         0 _decode(
518             $optn,
519             [$cop],
520             undef,
521             $npos,
522             $npos+$len,
523             (\my @ctrlist),
524             $larr,
525             $_[4],
526             );
527              
528 0         0 $nstash->{$cop->[cVAR]} = &{$ctr}(@ctrlist);
  0         0  
529 0         0 $done = $idx;
530 0         0 last SET_OP;
531             }
532             }
533             }
534             elsif ($op->[cTYPE] == opEXTENSIONS) {
535 14         23 $extensions = $idx;
536             }
537             else {
538 0         0 die "internal error";
539             }
540             }
541              
542 26 50 66     63 if (!defined($done) and defined($any)) {
543 0         0 my $var = $ch->[$any][cVAR];
544 0 0       0 $stash->{$var} = substr($_[4],$pos,$len+$npos-$pos) if defined $var;
545 0         0 $done = $any;
546             }
547              
548 26 100 66     69 if( !defined($done) && defined($extensions) ) {
549 1         2 $done = $extensions;
550             }
551              
552 26 50 33     104 die "decode error" if !defined($done) or $done[$done]++;
553              
554 26         64 $pos = $npos + $len + $indef;
555             }
556              
557 8 50       19 die "decode error" unless $end == $pos;
558              
559 8         13 foreach my $idx (0..$#{$ch}) {
  8         26  
560 30 50 100     86 die "decode error" unless $done[$idx] or $ch->[$idx][cEXT] or $ch->[$idx][cTYPE] == opEXTENSIONS;
      66        
561             }
562              
563 8         20 1;
564             }
565              
566              
567             my %_dec_time_opt = ( unixtime => 0, withzone => 1, raw => 2);
568              
569             sub _dec_time {
570             # 0 1 2 3 4 5 6
571             # $optn, $op, $stash, $var, $buf, $pos, $len
572              
573 24   50 24   103 my $mode = $_dec_time_opt{$_[0]->{'decode_time'} || ''} || 0;
574              
575 24 50 33     69 if ($mode == 2 or $_[6] == 0) {
576 0         0 $_[3] = substr($_[4],$_[5],$_[6]);
577 0         0 return;
578             }
579              
580 24 50       202 my @bits = (substr($_[4],$_[5],$_[6])
581             =~ /^((?:\d\d)?\d\d)(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)((?:\.\d{1,3})?)(([-+])(\d\d)(\d\d)|Z)/)
582             or die "bad time format";
583              
584 24 100       66 if ($bits[0] < 100) {
585 19 100       42 $bits[0] += 100 if $bits[0] < 50;
586             }
587             else {
588 5         45 $bits[0] -= 1900;
589             }
590 24         45 $bits[1] -= 1;
591 24         1089 require Time::Local;
592 24         4183 my $time = Time::Local::timegm(@bits[5,4,3,2,1,0]);
593 24 100       668 $time += $bits[6] if length $bits[6];
594 24         34 my $offset = 0;
595 24 100       46 if ($bits[7] ne 'Z') {
596 5         10 $offset = $bits[9] * 3600 + $bits[10] * 60;
597 5 100       13 $offset = -$offset if $bits[8] eq '-';
598 5         9 $time -= $offset;
599             }
600 24 50       91 $_[3] = $mode ? [$time,$offset] : $time;
601             }
602              
603              
604             sub _dec_utf8 {
605             # 0 1 2 3 4 5 6
606             # $optn, $op, $stash, $var, $buf, $pos, $len
607              
608             BEGIN {
609 23     23   98780 unless (CHECK_UTF8) {
610             local $SIG{__DIE__};
611             eval { require bytes } and 'bytes'->unimport;
612             eval { require utf8 } and 'utf8'->import;
613             }
614             }
615              
616 2     2   2 if (CHECK_UTF8) {
617 2         10 $_[3] = Encode::decode('utf8', substr($_[4],$_[5],$_[6]));
618             }
619             else {
620             $_[3] = (substr($_[4],$_[5],$_[6]) =~ /(.*)/s)[0];
621             }
622              
623 2         121 1;
624             }
625              
626              
627             sub _decode_tl {
628 1043     1043   1796 my($pos,$end,$larr) = @_[1,2,3];
629              
630 1043 100       1751 return if $pos >= $end;
631              
632 1018         1264 my $indef = 0;
633              
634 1018         1549 my $tag = substr($_[0], $pos++, 1);
635              
636 1018 100       2212 if((unpack("C",$tag) & 0x1f) == 0x1f) {
637 1         1 my $b;
638 1         2 my $n=1;
639 1         1 do {
640 5 100       12 return if $pos >= $end;
641 4         10 $tag .= substr($_[0],$pos++,1);
642 4         8 $b = ord substr($tag,-1);
643             } while($b & 0x80);
644             }
645 1017 50       1748 return if $pos >= $end;
646              
647 1017         1438 my $len = ord substr($_[0],$pos++,1);
648              
649 1017 100       1638 if($len & 0x80) {
650 112         132 $len &= 0x7f;
651              
652 112 100       157 if ($len) {
653 102 50       149 return if $pos+$len > $end ;
654              
655 102 50       174 my $padding = $len < 4 ? "\0" x (4 - $len) : "";
656 102         218 ($len,$pos) = (unpack("N", $padding . substr($_[0],$pos,$len)), $pos+$len);
657             }
658             else {
659 10 100       44 unless (exists $larr->{$pos}) {
660 5 100       19 _scan_indef($_[0],$pos,$end,$larr) or return;
661             }
662 9         13 $indef = 2;
663 9         15 $len = $larr->{$pos};
664             }
665             }
666              
667 1016 50       1861 return if $pos+$len+$indef > $end;
668              
669             # return the tag, the length of the data, the position of the data
670             # and the number of extra bytes for indefinite encoding
671              
672 1016         2940 ($tag, $len, $pos, $indef);
673             }
674              
675             sub _scan_indef {
676 5     5   21 my($pos,$end,$larr) = @_[1,2,3];
677 5         12 my @depth = ( $pos );
678              
679 5         14 while(@depth) {
680 27 50       52 return if $pos+2 > $end;
681              
682 27 100       71 if (substr($_[0],$pos,2) eq "\0\0") {
683 10         13 my $end = $pos;
684 10         15 my $stref = shift @depth;
685             # replace pos with length = end - pos
686 10         21 $larr->{$stref} = $end - $stref;
687 10         18 $pos += 2;
688 10         19 next;
689             }
690 17 50       33 return if $pos >= $end;
691              
692 17         32 my $tag = substr($_[0], $pos++, 1);
693              
694 17 100       46 if((unpack("C",$tag) & 0x1f) == 0x1f) {
695 1         2 my $b;
696 1         7 do {
697 3 100       10 return if $pos >= $end;
698 2         3 $tag .= substr($_[0],$pos++,1);
699 2         6 $b = ord substr($tag,-1);
700             } while($b & 0x80);
701             }
702 16 50       54 return if $pos >= $end;
703              
704 16         48 my $len = ord substr($_[0],$pos++,1);
705              
706 16 100       33 if($len & 0x80) {
707 6 50       10 if ($len &= 0x7f) {
708 0 0       0 return if $pos+$len > $end ;
709              
710 0 0       0 my $padding = $len < 4 ? "\0" x (4 - $len) : "";
711 0         0 $pos += $len + unpack("N", $padding . substr($_[0],$pos,$len));
712             }
713             else {
714             # reserve another list element
715 6         14 unshift @depth, $pos;
716             }
717             }
718             else {
719 10         32 $pos += $len;
720             }
721             }
722              
723 4         12 1;
724             }
725              
726 1     1   6 sub _ctr_string { join '', @_ }
727              
728             sub _ctr_bitstring {
729 0     0   0 [ join('', map { $_->[0] } @_), $_[-1]->[1] ]
  0         0  
730             }
731              
732             sub _dec_bcd {
733             # 0 1 2 3 4 5 6
734             # $optn, $op, $stash, $var, $buf, $pos, $len
735              
736 8     8   51 ($_[3] = unpack("H*", substr($_[4],$_[5],$_[6]))) =~ s/[fF]$//;
737 8         16 1;
738             }
739             1;
740