← 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:11:26 2013

Filename/usr/share/perl5/Convert/ASN1/_encode.pm
StatementsExecuted 4 statements in 2.05ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11115µs15µsConvert::ASN1::::BEGIN@7.11Convert::ASN1::BEGIN@7.11
0000s0sConvert::ASN1::::__ANON__[:20]Convert::ASN1::__ANON__[:20]
0000s0sConvert::ASN1::::_enc_anyConvert::ASN1::_enc_any
0000s0sConvert::ASN1::::_enc_bcdConvert::ASN1::_enc_bcd
0000s0sConvert::ASN1::::_enc_bitstringConvert::ASN1::_enc_bitstring
0000s0sConvert::ASN1::::_enc_booleanConvert::ASN1::_enc_boolean
0000s0sConvert::ASN1::::_enc_choiceConvert::ASN1::_enc_choice
0000s0sConvert::ASN1::::_enc_integerConvert::ASN1::_enc_integer
0000s0sConvert::ASN1::::_enc_nullConvert::ASN1::_enc_null
0000s0sConvert::ASN1::::_enc_object_idConvert::ASN1::_enc_object_id
0000s0sConvert::ASN1::::_enc_realConvert::ASN1::_enc_real
0000s0sConvert::ASN1::::_enc_sequenceConvert::ASN1::_enc_sequence
0000s0sConvert::ASN1::::_enc_stringConvert::ASN1::_enc_string
0000s0sConvert::ASN1::::_enc_timeConvert::ASN1::_enc_time
0000s0sConvert::ASN1::::_enc_utf8Convert::ASN1::_enc_utf8
0000s0sConvert::ASN1::::_encodeConvert::ASN1::_encode
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 15µs within Convert::ASN1::BEGIN@7.11 which was called: # once (15µs+0s) by Convert::ASN1::BEGIN@415 at line 12
BEGIN {
818µs unless (CHECK_UTF8) {
9 local $SIG{__DIE__};
10 eval { require bytes } and 'bytes'->import
11 }
1212.02ms115µs}
# spent 15µs making 1 call to Convert::ASN1::BEGIN@7.11
13
14# These are the subs which do the encoding, they are called with
15# 0 1 2 3 4 5
16# $opt, $op, $stash, $var, $buf, $loop
17# The order in the array must match the op definitions above
18
19my @encode = (
20 sub { die "internal error\n" },
21110µs \&_enc_boolean,
22 \&_enc_integer,
23 \&_enc_bitstring,
24 \&_enc_string,
25 \&_enc_null,
26 \&_enc_object_id,
27 \&_enc_real,
28 \&_enc_sequence,
29 \&_enc_sequence, # SET is the same encoding as sequence
30 \&_enc_time,
31 \&_enc_time,
32 \&_enc_utf8,
33 \&_enc_any,
34 \&_enc_choice,
35 \&_enc_object_id,
36 \&_enc_bcd,
37);
38
39
40sub _encode {
41 my ($optn, $ops, $stash, $path) = @_;
42 my $var;
43
44 foreach my $op (@{$ops}) {
45 if (defined(my $opt = $op->[cOPT])) {
46 next unless defined $stash->{$opt};
47 }
48 if (defined($var = $op->[cVAR])) {
49 push @$path, $var;
50 require Carp, Carp::croak(join(".", @$path)," is undefined") unless defined $stash->{$var};
51 }
52 $_[4] .= $op->[cTAG];
53
54 &{$encode[$op->[cTYPE]]}(
55 $optn,
56 $op,
57 (UNIVERSAL::isa($stash, 'HASH')
58 ? ($stash, defined($var) ? $stash->{$var} : undef)
59 : ({}, $stash)),
60 $_[4],
61 $op->[cLOOP],
62 $path,
63 );
64
65 pop @$path if defined $var;
66 }
67
68 $_[4];
69}
70
71
72sub _enc_boolean {
73# 0 1 2 3 4 5 6
74# $optn, $op, $stash, $var, $buf, $loop, $path
75
76 $_[4] .= pack("CC",1, $_[3] ? 0xff : 0);
77}
78
79
80sub _enc_integer {
81# 0 1 2 3 4 5 6
82# $optn, $op, $stash, $var, $buf, $loop, $path
83 if (abs($_[3]) >= 2**31) {
84 my $os = i2osp($_[3], ref($_[3]) || $_[0]->{encode_bigint} || 'Math::BigInt');
85 my $len = length $os;
86 my $msb = (vec($os, 0, 8) & 0x80) ? 0 : 255;
87 $len++, $os = chr($msb) . $os if $msb xor $_[3] > 0;
88 $_[4] .= asn_encode_length($len);
89 $_[4] .= $os;
90 }
91 else {
92 my $val = int($_[3]);
93 my $neg = ($val < 0);
94 my $len = num_length($neg ? ~$val : $val);
95 my $msb = $val & (0x80 << (($len - 1) * 8));
96
97 $len++ if $neg ? !$msb : $msb;
98
99 $_[4] .= asn_encode_length($len);
100 $_[4] .= substr(pack("N",$val), -$len);
101 }
102}
103
104
105sub _enc_bitstring {
106# 0 1 2 3 4 5 6
107# $optn, $op, $stash, $var, $buf, $loop, $path
108 my $vref = ref($_[3]) ? \($_[3]->[0]) : \$_[3];
109
110 if (CHECK_UTF8 and Encode::is_utf8($$vref)) {
111 utf8::encode(my $tmp = $$vref);
112 $vref = \$tmp;
113 }
114
115 if (ref($_[3])) {
116 my $less = (8 - ($_[3]->[1] & 7)) & 7;
117 my $len = ($_[3]->[1] + 7) >> 3;
118 $_[4] .= asn_encode_length(1+$len);
119 $_[4] .= chr($less);
120 $_[4] .= substr($$vref, 0, $len);
121 if ($less && $len) {
122 substr($_[4],-1) &= chr((0xff << $less) & 0xff);
123 }
124 }
125 else {
126 $_[4] .= asn_encode_length(1+length $$vref);
127 $_[4] .= chr(0);
128 $_[4] .= $$vref;
129 }
130}
131
132
133sub _enc_string {
134# 0 1 2 3 4 5 6
135# $optn, $op, $stash, $var, $buf, $loop, $path
136
137 if (CHECK_UTF8 and Encode::is_utf8($_[3])) {
138 utf8::encode(my $tmp = $_[3]);
139 $_[4] .= asn_encode_length(length $tmp);
140 $_[4] .= $tmp;
141 }
142 else {
143 $_[4] .= asn_encode_length(length $_[3]);
144 $_[4] .= $_[3];
145 }
146}
147
148
149sub _enc_null {
150# 0 1 2 3 4 5 6
151# $optn, $op, $stash, $var, $buf, $loop, $path
152
153 $_[4] .= chr(0);
154}
155
156
157sub _enc_object_id {
158# 0 1 2 3 4 5 6
159# $optn, $op, $stash, $var, $buf, $loop, $path
160
161 my @data = ($_[3] =~ /(\d+)/g);
162
163 if ($_[1]->[cTYPE] == opOBJID) {
164 if(@data < 2) {
165 @data = (0);
166 }
167 else {
168 my $first = $data[1] + ($data[0] * 40);
169 splice(@data,0,2,$first);
170 }
171 }
172
173 my $l = length $_[4];
174 $_[4] .= pack("cw*", 0, @data);
175 substr($_[4],$l,1) = asn_encode_length(length($_[4]) - $l - 1);
176}
177
178
179sub _enc_real {
180# 0 1 2 3 4 5 6
181# $optn, $op, $stash, $var, $buf, $loop, $path
182
183 # Zero
184 unless ($_[3]) {
185 $_[4] .= chr(0);
186 return;
187 }
188
189 require POSIX;
190
191 # +oo (well we use HUGE_VAL as Infinity is not avaliable to perl)
192 if ($_[3] >= POSIX::HUGE_VAL()) {
193 $_[4] .= pack("C*",0x01,0x40);
194 return;
195 }
196
197 # -oo (well we use HUGE_VAL as Infinity is not avaliable to perl)
198 if ($_[3] <= - POSIX::HUGE_VAL()) {
199 $_[4] .= pack("C*",0x01,0x41);
200 return;
201 }
202
203 if (exists $_[0]->{'encode_real'} && $_[0]->{'encode_real'} ne 'binary') {
204 my $tmp = sprintf("%g",$_[3]);
205 $_[4] .= asn_encode_length(1+length $tmp);
206 $_[4] .= chr(1); # NR1?
207 $_[4] .= $tmp;
208 return;
209 }
210
211 # We have a real number.
212 my $first = 0x80;
213 my($mantissa, $exponent) = POSIX::frexp($_[3]);
214
215 if ($mantissa < 0.0) {
216 $mantissa = -$mantissa;
217 $first |= 0x40;
218 }
219 my($eMant,$eExp);
220
221 while($mantissa > 0.0) {
222 ($mantissa, my $int) = POSIX::modf($mantissa * (1<<8));
223 $eMant .= chr($int);
224 }
225 $exponent -= 8 * length $eMant;
226
227 _enc_integer(undef, undef, undef, $exponent, $eExp);
228
229 # $eExp will br prefixed by a length byte
230
231 if (5 > length $eExp) {
232 $eExp =~ s/\A.//s;
233 $first |= length($eExp)-1;
234 }
235 else {
236 $first |= 0x3;
237 }
238
239 $_[4] .= asn_encode_length(1 + length($eMant) + length($eExp));
240 $_[4] .= chr($first);
241 $_[4] .= $eExp;
242 $_[4] .= $eMant;
243}
244
245
246sub _enc_sequence {
247# 0 1 2 3 4 5 6
248# $optn, $op, $stash, $var, $buf, $loop, $path
249
250 if (my $ops = $_[1]->[cCHILD]) {
251 my $l = length $_[4];
252 $_[4] .= "\0\0"; # guess
253 if (defined $_[5]) {
254 my $op = $ops->[0]; # there should only be one
255 my $enc = $encode[$op->[cTYPE]];
256 my $tag = $op->[cTAG];
257 my $loop = $op->[cLOOP];
258
259 push @{$_[6]}, -1;
260
261 foreach my $var (@{$_[3]}) {
262 $_[6]->[-1]++;
263 $_[4] .= $tag;
264
265 &{$enc}(
266 $_[0], # $optn
267 $op, # $op
268 $_[2], # $stash
269 $var, # $var
270 $_[4], # $buf
271 $loop, # $loop
272 $_[6], # $path
273 );
274 }
275 pop @{$_[6]};
276 }
277 else {
278 _encode($_[0],$_[1]->[cCHILD], defined($_[3]) ? $_[3] : $_[2], $_[6], $_[4]);
279 }
280 substr($_[4],$l,2) = asn_encode_length(length($_[4]) - $l - 2);
281 }
282 else {
283 $_[4] .= asn_encode_length(length $_[3]);
284 $_[4] .= $_[3];
285 }
286}
287
288
28913µsmy %_enc_time_opt = ( utctime => 1, withzone => 0, raw => 2);
290
291sub _enc_time {
292# 0 1 2 3 4 5 6
293# $optn, $op, $stash, $var, $buf, $loop, $path
294
295 my $mode = $_enc_time_opt{$_[0]->{'encode_time'} || ''} || 0;
296
297 if ($mode == 2) {
298 $_[4] .= asn_encode_length(length $_[3]);
299 $_[4] .= $_[3];
300 return;
301 }
302
303 my @time;
304 my $offset;
305 my $isgen = $_[1]->[cTYPE] == opGTIME;
306
307 if (ref($_[3])) {
308 $offset = int($_[3]->[1] / 60);
309 $time = $_[3]->[0] + $_[3]->[1];
310 }
311 elsif ($mode == 0) {
312 if (exists $_[0]->{'encode_timezone'}) {
313 $offset = int($_[0]->{'encode_timezone'} / 60);
314 $time = $_[3] + $_[0]->{'encode_timezone'};
315 }
316 else {
317 @time = localtime($_[3]);
318 my @g = gmtime($_[3]);
319
320 $offset = ($time[1] - $g[1]) + ($time[2] - $g[2]) * 60;
321 $time = $_[3] + $offset*60;
322 }
323 }
324 else {
325 $time = $_[3];
326 }
327 @time = gmtime($time);
328 $time[4] += 1;
329 $time[5] = $isgen ? ($time[5] + 1900) : ($time[5] % 100);
330
331 my $tmp = sprintf("%02d"x6, @time[5,4,3,2,1,0]);
332 if ($isgen) {
333 my $sp = sprintf("%.03f",$time);
334 $tmp .= substr($sp,-4) unless $sp =~ /\.000$/;
335 }
336 $tmp .= $offset ? sprintf("%+03d%02d",$offset / 60, abs($offset % 60)) : 'Z';
337 $_[4] .= asn_encode_length(length $tmp);
338 $_[4] .= $tmp;
339}
340
341
342sub _enc_utf8 {
343# 0 1 2 3 4 5 6
344# $optn, $op, $stash, $var, $buf, $loop, $path
345
346 if (CHECK_UTF8) {
347 my $tmp = $_[3];
348 utf8::upgrade($tmp) unless Encode::is_utf8($tmp);
349 utf8::encode($tmp);
350 $_[4] .= asn_encode_length(length $tmp);
351 $_[4] .= $tmp;
352 }
353 else {
354 $_[4] .= asn_encode_length(length $_[3]);
355 $_[4] .= $_[3];
356 }
357}
358
359
360sub _enc_any {
361# 0 1 2 3 4 5 6
362# $optn, $op, $stash, $var, $buf, $loop, $path
363
364 my $handler;
365 if ($_[1]->[cDEFINE] && $_[2]->{$_[1]->[cDEFINE]}) {
366 $handler=$_[0]->{oidtable}{$_[2]->{$_[1]->[cDEFINE]}};
367 $handler=$_[0]->{handlers}{$_[1]->[cVAR]}{$_[2]->{$_[1]->[cDEFINE]}} unless $handler;
368 }
369 if ($handler) {
370 $_[4] .= $handler->encode($_[3]);
371 } else {
372 $_[4] .= $_[3];
373 }
374}
375
376
377sub _enc_choice {
378# 0 1 2 3 4 5 6
379# $optn, $op, $stash, $var, $buf, $loop, $path
380
381 my $stash = defined($_[3]) ? $_[3] : $_[2];
382 for my $op (@{$_[1]->[cCHILD]}) {
383 my $var = defined $op->[cVAR] ? $op->[cVAR] : $op->[cCHILD]->[0]->[cVAR];
384
385 if (exists $stash->{$var}) {
386 push @{$_[6]}, $var;
387 _encode($_[0],[$op], $stash, $_[6], $_[4]);
388 pop @{$_[6]};
389 return;
390 }
391 }
392 require Carp;
393 Carp::croak("No value found for CHOICE " . join(".", @{$_[6]}));
394}
395
396
397sub _enc_bcd {
398# 0 1 2 3 4 5 6
399# $optn, $op, $stash, $var, $buf, $loop, $path
400 my $str = ("$_[3]" =~ /^(\d+)/) ? $1 : "";
401 $str .= "F" if length($str) & 1;
402 $_[4] .= asn_encode_length(length($str) / 2);
403 $_[4] .= pack("H*", $str);
404}
405111µs1;
406
Report produced by the NYTProf 4.04 Perl profiler, developed by Tim Bunce and Adam Kaplan.