File Coverage

blib/lib/Convert/ASN1/_encode.pm
Criterion Covered Total %
statement 154 178 86.5
branch 81 94 86.2
condition 15 22 68.2
subroutine 15 15 100.0
pod n/a
total 265 309 85.8


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