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