[Summary view] [Print] [Text view]

   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    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    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  
  72  sub _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  
  80  sub _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  
 105  sub _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  
 133  sub _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  
 149  sub _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  
 157  sub _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  
 179  sub _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  
 246  sub _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  
 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    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  
 342  sub _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  
 360  sub _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  
 377  sub _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  
 397  sub _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  }
 405  1;
 406