diff options
Diffstat (limited to 'Master/tlpkg/tlperl0/lib/Convert/ASN1/_decode.pm')
-rwxr-xr-x | Master/tlpkg/tlperl0/lib/Convert/ASN1/_decode.pm | 675 |
1 files changed, 675 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl0/lib/Convert/ASN1/_decode.pm b/Master/tlpkg/tlperl0/lib/Convert/ASN1/_decode.pm new file mode 100755 index 00000000000..944dd00e84d --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Convert/ASN1/_decode.pm @@ -0,0 +1,675 @@ +# Copyright (c) 2000-2005 Graham Barr <gbarr@pobox.com>. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package Convert::ASN1; + +BEGIN { + local $SIG{__DIE__}; + eval { require bytes and 'bytes'->import }; +} + +# These are the subs that do the decode, they are called with +# 0 1 2 3 4 +# $optn, $op, $stash, $var, $buf +# The order must be the same as the op definitions above + +my @decode = ( + sub { die "internal error\n" }, + \&_dec_boolean, + \&_dec_integer, + \&_dec_bitstring, + \&_dec_string, + \&_dec_null, + \&_dec_object_id, + \&_dec_real, + \&_dec_sequence, + \&_dec_set, + \&_dec_time, + \&_dec_time, + \&_dec_utf8, + undef, # ANY + undef, # CHOICE + \&_dec_object_id, + \&_dec_bcd, +); + +my @ctr; +@ctr[opBITSTR, opSTRING, opUTF8] = (\&_ctr_bitstring,\&_ctr_string,\&_ctr_string); + + +sub _decode { + my ($optn, $ops, $stash, $pos, $end, $seqof, $larr) = @_; + my $idx = 0; + + # we try not to copy the input buffer at any time + foreach my $buf ($_[-1]) { + OP: + foreach my $op (@{$ops}) { + my $var = $op->[cVAR]; + + if (length $op->[cTAG]) { + + TAGLOOP: { + my($tag,$len,$npos,$indef) = _decode_tl($buf,$pos,$end,$larr) + or do { + next OP if $pos==$end and ($seqof || defined $op->[cOPT]); + die "decode error"; + }; + + if ($tag eq $op->[cTAG]) { + + &{$decode[$op->[cTYPE]]}( + $optn, + $op, + $stash, + # We send 1 if there is not var as if there is the decode + # should be getting undef. So if it does not get undef + # it knows it has no variable + ($seqof ? $seqof->[$idx++] : defined($var) ? $stash->{$var} : ref($stash) eq 'SCALAR' ? $$stash : 1), + $buf,$npos,$len, $larr + ); + + $pos = $npos+$len+$indef; + + redo TAGLOOP if $seqof && $pos < $end; + next OP; + } + + if ($tag eq ($op->[cTAG] | chr(ASN_CONSTRUCTOR)) + and my $ctr = $ctr[$op->[cTYPE]]) + { + _decode( + $optn, + [$op], + undef, + $npos, + $npos+$len, + (\my @ctrlist), + $larr, + $buf, + ); + + ($seqof ? $seqof->[$idx++] : defined($var) ? $stash->{$var} : ref($stash) eq 'SCALAR' ? $$stash : undef) + = &{$ctr}(@ctrlist); + $pos = $npos+$len+$indef; + + redo TAGLOOP if $seqof && $pos < $end; + next OP; + + } + + if ($seqof || defined $op->[cOPT]) { + next OP; + } + + die "decode error " . unpack("H*",$tag) ."<=>" . unpack("H*",$op->[cTAG]), " ",$pos," ",$op->[cTYPE]," ",$op->[cVAR]||''; + } + } + else { # opTag length is zero, so it must be an ANY or CHOICE + + if ($op->[cTYPE] == opANY) { + + ANYLOOP: { + + my($tag,$len,$npos,$indef) = _decode_tl($buf,$pos,$end,$larr) + or do { + next OP if $pos==$end and ($seqof || defined $op->[cOPT]); + die "decode error"; + }; + + $len += $npos-$pos; + + if ($op->[cDEFINE]) { + $handler = $optn->{oidtable} && $optn->{oidtable}{$stash->{$op->[cDEFINE]}}; + $handler ||= $optn->{handlers}{$op->[cVAR]}{$stash->{$op->[cDEFINE]}}; + } + + ($seqof ? $seqof->[$idx++] : ref($stash) eq 'SCALAR' ? $$stash : $stash->{$var}) + = $handler ? $handler->decode(substr($buf,$pos,$len)) : substr($buf,$pos,$len); + + $pos += $len + $indef; + + redo ANYLOOP if $seqof && $pos < $end; + } + } + else { + + CHOICELOOP: { + my($tag,$len,$npos,$indef) = _decode_tl($buf,$pos,$end,$larr) + or do { + next OP if $pos==$end and ($seqof || defined $op->[cOPT]); + die "decode error"; + }; + foreach my $cop (@{$op->[cCHILD]}) { + + if ($tag eq $cop->[cTAG]) { + + my $nstash = $seqof + ? ($seqof->[$idx++]={}) + : defined($var) + ? ($stash->{$var}={}) + : ref($stash) eq 'SCALAR' + ? ($$stash={}) : $stash; + + &{$decode[$cop->[cTYPE]]}( + $optn, + $cop, + $nstash, + ($cop->[cVAR] ? $nstash->{$cop->[cVAR]} : undef), + $buf,$npos,$len,$larr, + ); + + $pos = $npos+$len+$indef; + + redo CHOICELOOP if $seqof && $pos < $end; + next OP; + } + + unless (length $cop->[cTAG]) { + eval { + _decode( + $optn, + [$cop], + (\my %tmp_stash), + $pos, + $npos+$len+$indef, + undef, + $larr, + $buf, + ); + + my $nstash = $seqof + ? ($seqof->[$idx++]={}) + : defined($var) + ? ($stash->{$var}={}) + : ref($stash) eq 'SCALAR' + ? ($$stash={}) : $stash; + + @{$nstash}{keys %tmp_stash} = values %tmp_stash; + + } or next; + + $pos = $npos+$len+$indef; + + redo CHOICELOOP if $seqof && $pos < $end; + next OP; + } + + if ($tag eq ($cop->[cTAG] | chr(ASN_CONSTRUCTOR)) + and my $ctr = $ctr[$cop->[cTYPE]]) + { + my $nstash = $seqof + ? ($seqof->[$idx++]={}) + : defined($var) + ? ($stash->{$var}={}) + : ref($stash) eq 'SCALAR' + ? ($$stash={}) : $stash; + + _decode( + $optn, + [$cop], + undef, + $npos, + $npos+$len, + (\my @ctrlist), + $larr, + $buf, + ); + + $nstash->{$cop->[cVAR]} = &{$ctr}(@ctrlist); + $pos = $npos+$len+$indef; + + redo CHOICELOOP if $seqof && $pos < $end; + next OP; + } + } + } + die "decode error" unless $op->[cOPT]; + } + } + } + } + die "decode error $pos $end" unless $pos == $end; +} + + +sub _dec_boolean { +# 0 1 2 3 4 5 6 +# $optn, $op, $stash, $var, $buf, $pos, $len + + $_[3] = ord(substr($_[4],$_[5],1)) ? 1 : 0; + 1; +} + + +sub _dec_integer { +# 0 1 2 3 4 5 6 +# $optn, $op, $stash, $var, $buf, $pos, $len + + my $buf = substr($_[4],$_[5],$_[6]); + my $tmp = ord($buf) & 0x80 ? chr(255) : chr(0); + if ($_[6] > 4) { + $_[3] = os2ip($tmp x (4-$_[6]) . $buf, $_[0]->{decode_bigint} || 'Math::BigInt'); + } else { + # N unpacks an unsigned value + $_[3] = unpack("l",pack("l",unpack("N", $tmp x (4-$_[6]) . $buf))); + } + 1; +} + + +sub _dec_bitstring { +# 0 1 2 3 4 5 6 +# $optn, $op, $stash, $var, $buf, $pos, $len + + $_[3] = [ substr($_[4],$_[5]+1,$_[6]-1), ($_[6]-1)*8-ord(substr($_[4],$_[5],1)) ]; + 1; +} + + +sub _dec_string { +# 0 1 2 3 4 5 6 +# $optn, $op, $stash, $var, $buf, $pos, $len + + $_[3] = substr($_[4],$_[5],$_[6]); + 1; +} + + +sub _dec_null { +# 0 1 2 3 4 5 6 +# $optn, $op, $stash, $var, $buf, $pos, $len + + $_[3] = exists($_[0]->{decode_null}) ? $_[0]->{decode_null} : 1; + 1; +} + + +sub _dec_object_id { +# 0 1 2 3 4 5 6 +# $optn, $op, $stash, $var, $buf, $pos, $len + + my @data = unpack("w*",substr($_[4],$_[5],$_[6])); + if ($_[1]->[cTYPE] == opOBJID and @data > 1) { + if ($data[0] < 40) { + splice(@data, 0, 1, 0, $data[0]); + } + elsif ($data[0] < 80) { + splice(@data, 0, 1, 1, $data[0] - 40); + } + else { + splice(@data, 0, 1, 2, $data[0] - 80); + } + } + $_[3] = join(".", @data); + 1; +} + + +my @_dec_real_base = (2,8,16); + +sub _dec_real { +# 0 1 2 3 4 5 6 +# $optn, $op, $stash, $var, $buf, $pos, $len + + $_[3] = 0.0, return unless $_[6]; + + my $first = ord(substr($_[4],$_[5],1)); + if ($first & 0x80) { + # A real number + + require POSIX; + + my $exp; + my $expLen = $first & 0x3; + my $estart = $_[5]+1; + + if($expLen == 3) { + $estart++; + $expLen = ord(substr($_[4],$_[5]+1,1)); + } + else { + $expLen++; + } + _dec_integer(undef, undef, undef, $exp, $_[4],$estart,$expLen); + + my $mant = 0.0; + for (reverse unpack("C*",substr($_[4],$estart+$expLen,$_[6]-1-$expLen))) { + $exp +=8, $mant = (($mant+$_) / 256) ; + } + + $mant *= 1 << (($first >> 2) & 0x3); + $mant = - $mant if $first & 0x40; + + $_[3] = $mant * POSIX::pow($_dec_real_base[($first >> 4) & 0x3], $exp); + return; + } + elsif($first & 0x40) { + $_[3] = POSIX::HUGE_VAL(),return if $first == 0x40; + $_[3] = - POSIX::HUGE_VAL(),return if $first == 0x41; + } + elsif(substr($_[4],$_[5],$_[6]) =~ /^.([-+]?)0*(\d+(?:\.\d+(?:[Ee][-+]?\d+)?)?)$/s) { + $_[3] = eval "$1$2"; + return; + } + + die "REAL decode error\n"; +} + + +sub _dec_sequence { +# 0 1 2 3 4 5 6 7 +# $optn, $op, $stash, $var, $buf, $pos, $len, $larr + + if (defined( my $ch = $_[1]->[cCHILD])) { + _decode( + $_[0], #optn + $ch, #ops + (defined($_[3]) || $_[1]->[cLOOP]) ? $_[2] : ($_[3]= {}), #stash + $_[5], #pos + $_[5]+$_[6], #end + $_[1]->[cLOOP] && ($_[3]=[]), #loop + $_[7], + $_[4], #buf + ); + } + else { + $_[3] = substr($_[4],$_[5],$_[6]); + } + 1; +} + + +sub _dec_set { +# 0 1 2 3 4 5 6 7 +# $optn, $op, $stash, $var, $buf, $pos, $len, $larr + + # decode SET OF the same as SEQUENCE OF + my $ch = $_[1]->[cCHILD]; + goto &_dec_sequence if $_[1]->[cLOOP] or !defined($ch); + + my ($optn, $pos, $larr) = @_[0,5,7]; + my $stash = defined($_[3]) ? $_[2] : ($_[3]={}); + my $end = $pos + $_[6]; + my @done; + + while ($pos < $end) { + my($tag,$len,$npos,$indef) = _decode_tl($_[4],$pos,$end,$larr) + or die "decode error"; + + my ($idx, $any, $done) = (-1); + +SET_OP: + foreach my $op (@$ch) { + $idx++; + if (length($op->[cTAG])) { + if ($tag eq $op->[cTAG]) { + my $var = $op->[cVAR]; + &{$decode[$op->[cTYPE]]}( + $optn, + $op, + $stash, + # We send 1 if there is not var as if there is the decode + # should be getting undef. So if it does not get undef + # it knows it has no variable + (defined($var) ? $stash->{$var} : 1), + $_[4],$npos,$len,$larr, + ); + $done = $idx; + last SET_OP; + } + if ($tag eq ($op->[cTAG] | chr(ASN_CONSTRUCTOR)) + and my $ctr = $ctr[$op->[cTYPE]]) + { + _decode( + $optn, + [$op], + undef, + $npos, + $npos+$len, + (\my @ctrlist), + $larr, + $_[4], + ); + + $stash->{$op->[cVAR]} = &{$ctr}(@ctrlist) + if defined $op->[cVAR]; + $done = $idx; + last SET_OP; + } + next SET_OP; + } + elsif ($op->[cTYPE] == opANY) { + $any = $idx; + } + elsif ($op->[cTYPE] == opCHOICE) { + foreach my $cop (@{$op->[cCHILD]}) { + if ($tag eq $cop->[cTAG]) { + my $nstash = defined($var) ? ($stash->{$var}={}) : $stash; + + &{$decode[$cop->[cTYPE]]}( + $optn, + $cop, + $nstash, + $nstash->{$cop->[cVAR]}, + $_[4],$npos,$len,$larr, + ); + $done = $idx; + last SET_OP; + } + if ($tag eq ($cop->[cTAG] | chr(ASN_CONSTRUCTOR)) + and my $ctr = $ctr[$cop->[cTYPE]]) + { + my $nstash = defined($var) ? ($stash->{$var}={}) : $stash; + + _decode( + $optn, + [$cop], + undef, + $npos, + $npos+$len, + (\my @ctrlist), + $larr, + $_[4], + ); + + $nstash->{$cop->[cVAR]} = &{$ctr}(@ctrlist); + $done = $idx; + last SET_OP; + } + } + } + else { + die "internal error"; + } + } + + if (!defined($done) and defined($any)) { + my $var = $ch->[$any][cVAR]; + $stash->{$var} = substr($_[4],$pos,$len+$npos-$pos) if defined $var; + $done = $any; + } + + die "decode error" if !defined($done) or $done[$done]++; + + $pos = $npos + $len + $indef; + } + + die "decode error" unless $end == $pos; + + foreach my $idx (0..$#{$ch}) { + die "decode error" unless $done[$idx] or $ch->[$idx][cOPT]; + } + + 1; +} + + +my %_dec_time_opt = ( unixtime => 0, withzone => 1, raw => 2); + +sub _dec_time { +# 0 1 2 3 4 5 6 +# $optn, $op, $stash, $var, $buf, $pos, $len + + my $mode = $_dec_time_opt{$_[0]->{'decode_time'} || ''} || 0; + + if ($mode == 2 or $_[6] == 0) { + $_[3] = substr($_[4],$_[5],$_[6]); + return; + } + + my @bits = (substr($_[4],$_[5],$_[6]) + =~ /^((?:\d\d)?\d\d)(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)((?:\.\d{1,3})?)(([-+])(\d\d)(\d\d)|Z)/) + or die "bad time format"; + + if ($bits[0] < 100) { + $bits[0] += 100 if $bits[0] < 50; + } + else { + $bits[0] -= 1900; + } + $bits[1] -= 1; + require Time::Local; + my $time = Time::Local::timegm(@bits[5,4,3,2,1,0]); + $time += $bits[6] if length $bits[6]; + my $offset = 0; + if ($bits[7] ne 'Z') { + $offset = $bits[9] * 3600 + $bits[10] * 60; + $offset = -$offset if $bits[8] eq '-'; + $time -= $offset; + } + $_[3] = $mode ? [$time,$offset] : $time; +} + + +sub _dec_utf8 { +# 0 1 2 3 4 5 6 +# $optn, $op, $stash, $var, $buf, $pos, $len + + BEGIN { + unless (CHECK_UTF8) { + local $SIG{__DIE__}; + eval { require bytes } and 'bytes'->unimport; + eval { require utf8 } and 'utf8'->import; + } + } + + if (CHECK_UTF8) { + $_[3] = Encode::decode('utf8', substr($_[4],$_[5],$_[6])); + } + else { + $_[3] = (substr($_[4],$_[5],$_[6]) =~ /(.*)/s)[0]; + } + + 1; +} + + +sub _decode_tl { + my($pos,$end,$larr) = @_[1,2,3]; + + my $indef = 0; + + my $tag = substr($_[0], $pos++, 1); + + if((ord($tag) & 0x1f) == 0x1f) { + my $b; + my $n=1; + do { + $tag .= substr($_[0],$pos++,1); + $b = ord substr($tag,-1); + } while($b & 0x80); + } + return if $pos >= $end; + + my $len = ord substr($_[0],$pos++,1); + + if($len & 0x80) { + $len &= 0x7f; + + if ($len) { + return if $pos+$len > $end ; + + ($len,$pos) = (unpack("N", "\0" x (4 - $len) . substr($_[0],$pos,$len)), $pos+$len); + } + else { + unless (exists $larr->{$pos}) { + _scan_indef($_[0],$pos,$end,$larr) or return; + } + $indef = 2; + $len = $larr->{$pos}; + } + } + + return if $pos+$len+$indef > $end; + + # return the tag, the length of the data, the position of the data + # and the number of extra bytes for indefinate encoding + + ($tag, $len, $pos, $indef); +} + +sub _scan_indef { + my($pos,$end,$larr) = @_[1,2,3]; + my @depth = ( $pos ); + + while(@depth) { + return if $pos+2 > $end; + + if (substr($_[0],$pos,2) eq "\0\0") { + my $end = $pos; + my $stref = shift @depth; + # replace pos with length = end - pos + $larr->{$stref} = $end - $stref; + $pos += 2; + next; + } + + my $tag = substr($_[0], $pos++, 1); + + if((ord($tag) & 0x1f) == 0x1f) { + my $b; + do { + $tag .= substr($_[0],$pos++,1); + $b = ord substr($tag,-1); + } while($b & 0x80); + } + return if $pos >= $end; + + my $len = ord substr($_[0],$pos++,1); + + if($len & 0x80) { + if ($len &= 0x7f) { + return if $pos+$len > $end ; + + $pos += $len + unpack("N", "\0" x (4 - $len) . substr($_[0],$pos,$len)); + } + else { + # reserve another list element + unshift @depth, $pos; + } + } + else { + $pos += $len; + } + } + + 1; +} + +sub _ctr_string { join '', @_ } + +sub _ctr_bitstring { + [ join('', map { $_->[0] } @_), $_[-1]->[1] ] +} + +sub _dec_bcd { +# 0 1 2 3 4 5 6 +# $optn, $op, $stash, $var, $buf, $pos, $len + + ($_[3] = unpack("H*", substr($_[4],$_[5],$_[6]))) =~ s/[fF]$//; + 1; +} +1; + |