[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    local $SIG{__DIE__};
   9    eval { require bytes and 'bytes'->import };
  10  }
  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  
  17  my @decode = (
  18    sub { die "internal error\n" },
  19    \&_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  
  37  my @ctr;
  38  @ctr[opBITSTR, opSTRING, opUTF8] = (\&_ctr_bitstring,\&_ctr_string,\&_ctr_string);
  39  
  40  
  41  sub _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  
 237  sub _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  
 246  sub _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  
 262  sub _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  
 271  sub _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  
 280  sub _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  
 289  sub _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  
 310  my @_dec_real_base = (2,8,16);
 311  
 312  sub _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  
 361  sub _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  
 384  sub _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  
 403  SET_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  
 509  my %_dec_time_opt = ( unixtime => 0, withzone => 1, raw => 2);
 510  
 511  sub _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  
 546  sub _dec_utf8 {
 547  # 0      1    2       3     4     5     6
 548  # $optn, $op, $stash, $var, $buf, $pos, $len
 549  
 550    BEGIN {
 551      unless (CHECK_UTF8) {
 552        local $SIG{__DIE__};
 553        eval { require bytes } and 'bytes'->unimport;
 554        eval { require utf8  } and 'utf8'->import;
 555      }
 556    }
 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  
 569  sub _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  
 613  sub _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  
 661  sub _ctr_string { join '', @_ }
 662  
 663  sub _ctr_bitstring {
 664    [ join('', map { $_->[0] } @_), $_[-1]->[1] ]
 665  }
 666  
 667  sub _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  }
 674  1;
 675