← Index
NYTProf Performance Profile   « block view • line view • sub view »
For /usr/share/koha/opac/cgi-bin/opac/opac-search.pl
  Run on Tue Oct 15 17:10:45 2013
Reported on Tue Oct 15 17:12:03 2013

Filename/usr/share/perl5/Convert/ASN1/_decode.pm
StatementsExecuted 10 statements in 3.55ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11152µs59µsConvert::ASN1::::BEGIN@7Convert::ASN1::BEGIN@7
11114µs14µsConvert::ASN1::::BEGIN@550Convert::ASN1::BEGIN@550
0000s0sConvert::ASN1::::__ANON__[:18]Convert::ASN1::__ANON__[:18]
0000s0sConvert::ASN1::::_ctr_bitstringConvert::ASN1::_ctr_bitstring
0000s0sConvert::ASN1::::_ctr_stringConvert::ASN1::_ctr_string
0000s0sConvert::ASN1::::_dec_bcdConvert::ASN1::_dec_bcd
0000s0sConvert::ASN1::::_dec_bitstringConvert::ASN1::_dec_bitstring
0000s0sConvert::ASN1::::_dec_booleanConvert::ASN1::_dec_boolean
0000s0sConvert::ASN1::::_dec_integerConvert::ASN1::_dec_integer
0000s0sConvert::ASN1::::_dec_nullConvert::ASN1::_dec_null
0000s0sConvert::ASN1::::_dec_object_idConvert::ASN1::_dec_object_id
0000s0sConvert::ASN1::::_dec_realConvert::ASN1::_dec_real
0000s0sConvert::ASN1::::_dec_sequenceConvert::ASN1::_dec_sequence
0000s0sConvert::ASN1::::_dec_setConvert::ASN1::_dec_set
0000s0sConvert::ASN1::::_dec_stringConvert::ASN1::_dec_string
0000s0sConvert::ASN1::::_dec_timeConvert::ASN1::_dec_time
0000s0sConvert::ASN1::::_dec_utf8Convert::ASN1::_dec_utf8
0000s0sConvert::ASN1::::_decodeConvert::ASN1::_decode
0000s0sConvert::ASN1::::_decode_tlConvert::ASN1::_decode_tl
0000s0sConvert::ASN1::::_scan_indefConvert::ASN1::_scan_indef
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 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
5package Convert::ASN1;
6
7
# spent 59µs (52+7) within Convert::ASN1::BEGIN@7 which was called: # once (52µs+7µs) by Convert::ASN1::BEGIN@415 at line 10
BEGIN {
8216µs local $SIG{__DIE__};
9110µs17µs eval { require bytes and 'bytes'->import };
# spent 7µs making 1 call to bytes::import
1012.78ms159µs}
# spent 59µs making 1 call to Convert::ASN1::BEGIN@7
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
17my @decode = (
18 sub { die "internal error\n" },
1919µs \&_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
371200nsmy @ctr;
3812µs@ctr[opBITSTR, opSTRING, opUTF8] = (\&_ctr_bitstring,\&_ctr_string,\&_ctr_string);
39
40
41sub _decode {
42 my ($optn, $ops, $stash, $pos, $end, $seqof, $larr) = @_;
43 my $idx = 0;
44
45 # we try not to copy the input buffer at any time
46 foreach my $buf ($_[-1]) {
47 OP:
48 foreach my $op (@{$ops}) {
49 my $var = $op->[cVAR];
50
51 if (length $op->[cTAG]) {
52
53 TAGLOOP: {
54 my($tag,$len,$npos,$indef) = _decode_tl($buf,$pos,$end,$larr)
55 or do {
56 next OP if $pos==$end and ($seqof || defined $op->[cOPT]);
57 die "decode error";
58 };
59
60 if ($tag eq $op->[cTAG]) {
61
62 &{$decode[$op->[cTYPE]]}(
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 $pos = $npos+$len+$indef;
74
75 redo TAGLOOP if $seqof && $pos < $end;
76 next OP;
77 }
78
79 if ($tag eq ($op->[cTAG] | chr(ASN_CONSTRUCTOR))
80 and my $ctr = $ctr[$op->[cTYPE]])
81 {
82 _decode(
83 $optn,
84 [$op],
85 undef,
86 $npos,
87 $npos+$len,
88 (\my @ctrlist),
89 $larr,
90 $buf,
91 );
92
93 ($seqof ? $seqof->[$idx++] : defined($var) ? $stash->{$var} : ref($stash) eq 'SCALAR' ? $$stash : undef)
94 = &{$ctr}(@ctrlist);
95 $pos = $npos+$len+$indef;
96
97 redo TAGLOOP if $seqof && $pos < $end;
98 next OP;
99
100 }
101
102 if ($seqof || defined $op->[cOPT]) {
103 next OP;
104 }
105
106 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 if ($op->[cTYPE] == opANY) {
112
113 ANYLOOP: {
114
115 my($tag,$len,$npos,$indef) = _decode_tl($buf,$pos,$end,$larr)
116 or do {
117 next OP if $pos==$end and ($seqof || defined $op->[cOPT]);
118 die "decode error";
119 };
120
121 $len += $npos-$pos;
122
123 if ($op->[cDEFINE]) {
124 $handler = $optn->{oidtable} && $optn->{oidtable}{$stash->{$op->[cDEFINE]}};
125 $handler ||= $optn->{handlers}{$op->[cVAR]}{$stash->{$op->[cDEFINE]}};
126 }
127
128 ($seqof ? $seqof->[$idx++] : ref($stash) eq 'SCALAR' ? $$stash : $stash->{$var})
129 = $handler ? $handler->decode(substr($buf,$pos,$len)) : substr($buf,$pos,$len);
130
131 $pos += $len + $indef;
132
133 redo ANYLOOP if $seqof && $pos < $end;
134 }
135 }
136 else {
137
138 CHOICELOOP: {
139 my($tag,$len,$npos,$indef) = _decode_tl($buf,$pos,$end,$larr)
140 or do {
141 next OP if $pos==$end and ($seqof || defined $op->[cOPT]);
142 die "decode error";
143 };
144 foreach my $cop (@{$op->[cCHILD]}) {
145
146 if ($tag eq $cop->[cTAG]) {
147
148 my $nstash = $seqof
149 ? ($seqof->[$idx++]={})
150 : defined($var)
151 ? ($stash->{$var}={})
152 : ref($stash) eq 'SCALAR'
153 ? ($$stash={}) : $stash;
154
155 &{$decode[$cop->[cTYPE]]}(
156 $optn,
157 $cop,
158 $nstash,
159 ($cop->[cVAR] ? $nstash->{$cop->[cVAR]} : undef),
160 $buf,$npos,$len,$larr,
161 );
162
163 $pos = $npos+$len+$indef;
164
165 redo CHOICELOOP if $seqof && $pos < $end;
166 next OP;
167 }
168
169 unless (length $cop->[cTAG]) {
170 eval {
171 _decode(
172 $optn,
173 [$cop],
174 (\my %tmp_stash),
175 $pos,
176 $npos+$len+$indef,
177 undef,
178 $larr,
179 $buf,
180 );
181
182 my $nstash = $seqof
183 ? ($seqof->[$idx++]={})
184 : defined($var)
185 ? ($stash->{$var}={})
186 : ref($stash) eq 'SCALAR'
187 ? ($$stash={}) : $stash;
188
189 @{$nstash}{keys %tmp_stash} = values %tmp_stash;
190
191 } or next;
192
193 $pos = $npos+$len+$indef;
194
195 redo CHOICELOOP if $seqof && $pos < $end;
196 next OP;
197 }
198
199 if ($tag eq ($cop->[cTAG] | chr(ASN_CONSTRUCTOR))
200 and my $ctr = $ctr[$cop->[cTYPE]])
201 {
202 my $nstash = $seqof
203 ? ($seqof->[$idx++]={})
204 : defined($var)
205 ? ($stash->{$var}={})
206 : ref($stash) eq 'SCALAR'
207 ? ($$stash={}) : $stash;
208
209 _decode(
210 $optn,
211 [$cop],
212 undef,
213 $npos,
214 $npos+$len,
215 (\my @ctrlist),
216 $larr,
217 $buf,
218 );
219
220 $nstash->{$cop->[cVAR]} = &{$ctr}(@ctrlist);
221 $pos = $npos+$len+$indef;
222
223 redo CHOICELOOP if $seqof && $pos < $end;
224 next OP;
225 }
226 }
227 }
228 die "decode error" unless $op->[cOPT];
229 }
230 }
231 }
232 }
233 die "decode error $pos $end" unless $pos == $end;
234}
235
236
237sub _dec_boolean {
238# 0 1 2 3 4 5 6
239# $optn, $op, $stash, $var, $buf, $pos, $len
240
241 $_[3] = ord(substr($_[4],$_[5],1)) ? 1 : 0;
242 1;
243}
244
245
246sub _dec_integer {
247# 0 1 2 3 4 5 6
248# $optn, $op, $stash, $var, $buf, $pos, $len
249
250 my $buf = substr($_[4],$_[5],$_[6]);
251 my $tmp = ord($buf) & 0x80 ? chr(255) : chr(0);
252 if ($_[6] > 4) {
253 $_[3] = os2ip($tmp x (4-$_[6]) . $buf, $_[0]->{decode_bigint} || 'Math::BigInt');
254 } else {
255 # N unpacks an unsigned value
256 $_[3] = unpack("l",pack("l",unpack("N", $tmp x (4-$_[6]) . $buf)));
257 }
258 1;
259}
260
261
262sub _dec_bitstring {
263# 0 1 2 3 4 5 6
264# $optn, $op, $stash, $var, $buf, $pos, $len
265
266 $_[3] = [ substr($_[4],$_[5]+1,$_[6]-1), ($_[6]-1)*8-ord(substr($_[4],$_[5],1)) ];
267 1;
268}
269
270
271sub _dec_string {
272# 0 1 2 3 4 5 6
273# $optn, $op, $stash, $var, $buf, $pos, $len
274
275 $_[3] = substr($_[4],$_[5],$_[6]);
276 1;
277}
278
279
280sub _dec_null {
281# 0 1 2 3 4 5 6
282# $optn, $op, $stash, $var, $buf, $pos, $len
283
284 $_[3] = exists($_[0]->{decode_null}) ? $_[0]->{decode_null} : 1;
285 1;
286}
287
288
289sub _dec_object_id {
290# 0 1 2 3 4 5 6
291# $optn, $op, $stash, $var, $buf, $pos, $len
292
293 my @data = unpack("w*",substr($_[4],$_[5],$_[6]));
294 if ($_[1]->[cTYPE] == opOBJID and @data > 1) {
295 if ($data[0] < 40) {
296 splice(@data, 0, 1, 0, $data[0]);
297 }
298 elsif ($data[0] < 80) {
299 splice(@data, 0, 1, 1, $data[0] - 40);
300 }
301 else {
302 splice(@data, 0, 1, 2, $data[0] - 80);
303 }
304 }
305 $_[3] = join(".", @data);
306 1;
307}
308
309
3101700nsmy @_dec_real_base = (2,8,16);
311
312sub _dec_real {
313# 0 1 2 3 4 5 6
314# $optn, $op, $stash, $var, $buf, $pos, $len
315
316 $_[3] = 0.0, return unless $_[6];
317
318 my $first = ord(substr($_[4],$_[5],1));
319 if ($first & 0x80) {
320 # A real number
321
322 require POSIX;
323
324 my $exp;
325 my $expLen = $first & 0x3;
326 my $estart = $_[5]+1;
327
328 if($expLen == 3) {
329 $estart++;
330 $expLen = ord(substr($_[4],$_[5]+1,1));
331 }
332 else {
333 $expLen++;
334 }
335 _dec_integer(undef, undef, undef, $exp, $_[4],$estart,$expLen);
336
337 my $mant = 0.0;
338 for (reverse unpack("C*",substr($_[4],$estart+$expLen,$_[6]-1-$expLen))) {
339 $exp +=8, $mant = (($mant+$_) / 256) ;
340 }
341
342 $mant *= 1 << (($first >> 2) & 0x3);
343 $mant = - $mant if $first & 0x40;
344
345 $_[3] = $mant * POSIX::pow($_dec_real_base[($first >> 4) & 0x3], $exp);
346 return;
347 }
348 elsif($first & 0x40) {
349 $_[3] = POSIX::HUGE_VAL(),return if $first == 0x40;
350 $_[3] = - POSIX::HUGE_VAL(),return if $first == 0x41;
351 }
352 elsif(substr($_[4],$_[5],$_[6]) =~ /^.([-+]?)0*(\d+(?:\.\d+(?:[Ee][-+]?\d+)?)?)$/s) {
353 $_[3] = eval "$1$2";
354 return;
355 }
356
357 die "REAL decode error\n";
358}
359
360
361sub _dec_sequence {
362# 0 1 2 3 4 5 6 7
363# $optn, $op, $stash, $var, $buf, $pos, $len, $larr
364
365 if (defined( my $ch = $_[1]->[cCHILD])) {
366 _decode(
367 $_[0], #optn
368 $ch, #ops
369 (defined($_[3]) || $_[1]->[cLOOP]) ? $_[2] : ($_[3]= {}), #stash
370 $_[5], #pos
371 $_[5]+$_[6], #end
372 $_[1]->[cLOOP] && ($_[3]=[]), #loop
373 $_[7],
374 $_[4], #buf
375 );
376 }
377 else {
378 $_[3] = substr($_[4],$_[5],$_[6]);
379 }
380 1;
381}
382
383
384sub _dec_set {
385# 0 1 2 3 4 5 6 7
386# $optn, $op, $stash, $var, $buf, $pos, $len, $larr
387
388 # decode SET OF the same as SEQUENCE OF
389 my $ch = $_[1]->[cCHILD];
390 goto &_dec_sequence if $_[1]->[cLOOP] or !defined($ch);
391
392 my ($optn, $pos, $larr) = @_[0,5,7];
393 my $stash = defined($_[3]) ? $_[2] : ($_[3]={});
394 my $end = $pos + $_[6];
395 my @done;
396
397 while ($pos < $end) {
398 my($tag,$len,$npos,$indef) = _decode_tl($_[4],$pos,$end,$larr)
399 or die "decode error";
400
401 my ($idx, $any, $done) = (-1);
402
403SET_OP:
404 foreach my $op (@$ch) {
405 $idx++;
406 if (length($op->[cTAG])) {
407 if ($tag eq $op->[cTAG]) {
408 my $var = $op->[cVAR];
409 &{$decode[$op->[cTYPE]]}(
410 $optn,
411 $op,
412 $stash,
413 # We send 1 if there is not var as if there is the decode
414 # should be getting undef. So if it does not get undef
415 # it knows it has no variable
416 (defined($var) ? $stash->{$var} : 1),
417 $_[4],$npos,$len,$larr,
418 );
419 $done = $idx;
420 last SET_OP;
421 }
422 if ($tag eq ($op->[cTAG] | chr(ASN_CONSTRUCTOR))
423 and my $ctr = $ctr[$op->[cTYPE]])
424 {
425 _decode(
426 $optn,
427 [$op],
428 undef,
429 $npos,
430 $npos+$len,
431 (\my @ctrlist),
432 $larr,
433 $_[4],
434 );
435
436 $stash->{$op->[cVAR]} = &{$ctr}(@ctrlist)
437 if defined $op->[cVAR];
438 $done = $idx;
439 last SET_OP;
440 }
441 next SET_OP;
442 }
443 elsif ($op->[cTYPE] == opANY) {
444 $any = $idx;
445 }
446 elsif ($op->[cTYPE] == opCHOICE) {
447 foreach my $cop (@{$op->[cCHILD]}) {
448 if ($tag eq $cop->[cTAG]) {
449 my $nstash = defined($var) ? ($stash->{$var}={}) : $stash;
450
451 &{$decode[$cop->[cTYPE]]}(
452 $optn,
453 $cop,
454 $nstash,
455 $nstash->{$cop->[cVAR]},
456 $_[4],$npos,$len,$larr,
457 );
458 $done = $idx;
459 last SET_OP;
460 }
461 if ($tag eq ($cop->[cTAG] | chr(ASN_CONSTRUCTOR))
462 and my $ctr = $ctr[$cop->[cTYPE]])
463 {
464 my $nstash = defined($var) ? ($stash->{$var}={}) : $stash;
465
466 _decode(
467 $optn,
468 [$cop],
469 undef,
470 $npos,
471 $npos+$len,
472 (\my @ctrlist),
473 $larr,
474 $_[4],
475 );
476
477 $nstash->{$cop->[cVAR]} = &{$ctr}(@ctrlist);
478 $done = $idx;
479 last SET_OP;
480 }
481 }
482 }
483 else {
484 die "internal error";
485 }
486 }
487
488 if (!defined($done) and defined($any)) {
489 my $var = $ch->[$any][cVAR];
490 $stash->{$var} = substr($_[4],$pos,$len+$npos-$pos) if defined $var;
491 $done = $any;
492 }
493
494 die "decode error" if !defined($done) or $done[$done]++;
495
496 $pos = $npos + $len + $indef;
497 }
498
499 die "decode error" unless $end == $pos;
500
501 foreach my $idx (0..$#{$ch}) {
502 die "decode error" unless $done[$idx] or $ch->[$idx][cOPT];
503 }
504
505 1;
506}
507
508
50915µsmy %_dec_time_opt = ( unixtime => 0, withzone => 1, raw => 2);
510
511sub _dec_time {
512# 0 1 2 3 4 5 6
513# $optn, $op, $stash, $var, $buf, $pos, $len
514
515 my $mode = $_dec_time_opt{$_[0]->{'decode_time'} || ''} || 0;
516
517 if ($mode == 2 or $_[6] == 0) {
518 $_[3] = substr($_[4],$_[5],$_[6]);
519 return;
520 }
521
522 my @bits = (substr($_[4],$_[5],$_[6])
523 =~ /^((?:\d\d)?\d\d)(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)((?:\.\d{1,3})?)(([-+])(\d\d)(\d\d)|Z)/)
524 or die "bad time format";
525
526 if ($bits[0] < 100) {
527 $bits[0] += 100 if $bits[0] < 50;
528 }
529 else {
530 $bits[0] -= 1900;
531 }
532 $bits[1] -= 1;
533 require Time::Local;
534 my $time = Time::Local::timegm(@bits[5,4,3,2,1,0]);
535 $time += $bits[6] if length $bits[6];
536 my $offset = 0;
537 if ($bits[7] ne 'Z') {
538 $offset = $bits[9] * 3600 + $bits[10] * 60;
539 $offset = -$offset if $bits[8] eq '-';
540 $time -= $offset;
541 }
542 $_[3] = $mode ? [$time,$offset] : $time;
543}
544
545
546sub _dec_utf8 {
547# 0 1 2 3 4 5 6
548# $optn, $op, $stash, $var, $buf, $pos, $len
549
550
# spent 14µs within Convert::ASN1::BEGIN@550 which was called: # once (14µs+0s) by Convert::ASN1::BEGIN@415 at line 556
BEGIN {
551117µs unless (CHECK_UTF8) {
552 local $SIG{__DIE__};
553 eval { require bytes } and 'bytes'->unimport;
554 eval { require utf8 } and 'utf8'->import;
555 }
5561694µs114µs }
# spent 14µs making 1 call to Convert::ASN1::BEGIN@550
557
558 if (CHECK_UTF8) {
559 $_[3] = Encode::decode('utf8', substr($_[4],$_[5],$_[6]));
560 }
561 else {
562 $_[3] = (substr($_[4],$_[5],$_[6]) =~ /(.*)/s)[0];
563 }
564
565 1;
566}
567
568
569sub _decode_tl {
570 my($pos,$end,$larr) = @_[1,2,3];
571
572 my $indef = 0;
573
574 my $tag = substr($_[0], $pos++, 1);
575
576 if((ord($tag) & 0x1f) == 0x1f) {
577 my $b;
578 my $n=1;
579 do {
580 $tag .= substr($_[0],$pos++,1);
581 $b = ord substr($tag,-1);
582 } while($b & 0x80);
583 }
584 return if $pos >= $end;
585
586 my $len = ord substr($_[0],$pos++,1);
587
588 if($len & 0x80) {
589 $len &= 0x7f;
590
591 if ($len) {
592 return if $pos+$len > $end ;
593
594 ($len,$pos) = (unpack("N", "\0" x (4 - $len) . substr($_[0],$pos,$len)), $pos+$len);
595 }
596 else {
597 unless (exists $larr->{$pos}) {
598 _scan_indef($_[0],$pos,$end,$larr) or return;
599 }
600 $indef = 2;
601 $len = $larr->{$pos};
602 }
603 }
604
605 return if $pos+$len+$indef > $end;
606
607 # return the tag, the length of the data, the position of the data
608 # and the number of extra bytes for indefinate encoding
609
610 ($tag, $len, $pos, $indef);
611}
612
613sub _scan_indef {
614 my($pos,$end,$larr) = @_[1,2,3];
615 my @depth = ( $pos );
616
617 while(@depth) {
618 return if $pos+2 > $end;
619
620 if (substr($_[0],$pos,2) eq "\0\0") {
621 my $end = $pos;
622 my $stref = shift @depth;
623 # replace pos with length = end - pos
624 $larr->{$stref} = $end - $stref;
625 $pos += 2;
626 next;
627 }
628
629 my $tag = substr($_[0], $pos++, 1);
630
631 if((ord($tag) & 0x1f) == 0x1f) {
632 my $b;
633 do {
634 $tag .= substr($_[0],$pos++,1);
635 $b = ord substr($tag,-1);
636 } while($b & 0x80);
637 }
638 return if $pos >= $end;
639
640 my $len = ord substr($_[0],$pos++,1);
641
642 if($len & 0x80) {
643 if ($len &= 0x7f) {
644 return if $pos+$len > $end ;
645
646 $pos += $len + unpack("N", "\0" x (4 - $len) . substr($_[0],$pos,$len));
647 }
648 else {
649 # reserve another list element
650 unshift @depth, $pos;
651 }
652 }
653 else {
654 $pos += $len;
655 }
656 }
657
658 1;
659}
660
661sub _ctr_string { join '', @_ }
662
663sub _ctr_bitstring {
664 [ join('', map { $_->[0] } @_), $_[-1]->[1] ]
665}
666
667sub _dec_bcd {
668# 0 1 2 3 4 5 6
669# $optn, $op, $stash, $var, $buf, $pos, $len
670
671 ($_[3] = unpack("H*", substr($_[4],$_[5],$_[6]))) =~ s/[fF]$//;
672 1;
673}
674115µs1;
675
Report produced by the NYTProf 4.04 Perl profiler, developed by Tim Bunce and Adam Kaplan.