diff options
author | Siep Kroonenberg <siepo@cybercomm.nl> | 2011-02-17 12:20:49 +0000 |
---|---|---|
committer | Siep Kroonenberg <siepo@cybercomm.nl> | 2011-02-17 12:20:49 +0000 |
commit | 316ee97c621496b0fe3267f57cce81bee44ca1e6 (patch) | |
tree | cb2cab1192b4f58a7971af19b213e980bceda4b4 /Master/tlpkg/tlperl0/lib/Convert/ASN1 | |
parent | cd0f87b5d39480d85ad9bd4ee37f520f75bed560 (diff) |
Moving old tlperl prior to committing new one
git-svn-id: svn://tug.org/texlive/trunk@21422 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl0/lib/Convert/ASN1')
-rwxr-xr-x | Master/tlpkg/tlperl0/lib/Convert/ASN1/Debug.pm | 226 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl0/lib/Convert/ASN1/IO.pm | 261 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl0/lib/Convert/ASN1/_decode.pm | 675 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl0/lib/Convert/ASN1/_encode.pm | 406 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl0/lib/Convert/ASN1/parser.pm | 916 |
5 files changed, 2484 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl0/lib/Convert/ASN1/Debug.pm b/Master/tlpkg/tlperl0/lib/Convert/ASN1/Debug.pm new file mode 100755 index 00000000000..b9af2568a71 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Convert/ASN1/Debug.pm @@ -0,0 +1,226 @@ +# 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; + +## +## just for debug :-) +## + +sub _hexdump { + my($fmt,$pos) = @_[1,2]; # Don't copy buffer + + $pos ||= 0; + + my $offset = 0; + my $cnt = 1 << 4; + my $len = length($_[0]); + my $linefmt = ("%02X " x $cnt) . "%s\n"; + + print "\n"; + + while ($offset < $len) { + my $data = substr($_[0],$offset,$cnt); + my @y = unpack("C*",$data); + + printf $fmt,$pos if $fmt; + + # On the last time through replace '%02X ' with '__ ' for the + # missing values + substr($linefmt, 5*@y,5*($cnt-@y)) = "__ " x ($cnt - @y) + if @y != $cnt; + + # Change non-printable chars to '.' + $data =~ s/[\x00-\x1f\x7f-\xff]/./sg; + printf $linefmt, @y,$data; + + $offset += $cnt; + $pos += $cnt; + } +} + +my %type = ( + split(/[\t\n]\s*/, + q(10 SEQUENCE + 01 BOOLEAN + 0A ENUM + 0D RELATIVE-OID + 11 SET + 02 INTEGER + 03 BIT STRING + C0 [PRIVATE %d] + 04 STRING + 40 [APPLICATION %d] + 05 NULL + 06 OBJECT ID + 80 [CONTEXT %d] + ) + ) +); + +BEGIN { undef &asn_dump } +sub asn_dump { + my $fh = @_>1 ? shift : \*STDERR; + + my $ofh = select($fh); + + my $pos = 0; + my $indent = ""; + my @seqend = (); + my $length = length($_[0]); + my $fmt = $length > 0xffff ? "%08X" : "%04X"; + + while(1) { + while (@seqend && $pos >= $seqend[0]) { + $indent = substr($indent,2); + warn "Bad sequence length " unless $pos == shift @seqend; + printf "$fmt : %s}\n",$pos,$indent; + } + last unless $pos < $length; + + my $start = $pos; + my($tb,$tag,$tnum) = asn_decode_tag2(substr($_[0],$pos,10)); + $pos += $tb; + my($lb,$len) = asn_decode_length(substr($_[0],$pos,10)); + $pos += $lb; + + if($tag == 0 && $len == 0) { + $seqend[0] = $pos; + redo; + } + printf $fmt. " %4d: %s",$start,$len,$indent; + + my $label = $type{sprintf("%02X",$tag & ~0x20)} + || $type{sprintf("%02X",$tag & 0xC0)} + || "[UNIVERSAL %d]"; + printf $label, $tnum; + + if ($tag & ASN_CONSTRUCTOR) { + print " {\n"; + if($len < 0) { + unshift(@seqend, length $_[0]); + } + else { + unshift(@seqend, $pos + $len); + } + $indent .= " "; + next; + } + + my $tmp; + + for ($label) { # switch + /^(INTEGER|ENUM)/ && do { + Convert::ASN1::_dec_integer({},[],{},$tmp,$_[0],$pos,$len); + printf " = %d\n",$tmp; + last; + }; + + /^BOOLEAN/ && do { + Convert::ASN1::_dec_boolean({},[],{},$tmp,$_[0],$pos,$len); + printf " = %s\n",$tmp ? 'TRUE' : 'FALSE'; + last; + }; + + /^(?:(OBJECT ID)|(RELATIVE-OID))/ && do { + my @op; $op[cTYPE] = $1 ? opOBJID : opROID; + Convert::ASN1::_dec_object_id({},\@op,{},$tmp,$_[0],$pos,$len); + printf " = %s\n",$tmp; + last; + }; + + /^NULL/ && do { + print "\n"; + last; + }; + + /^STRING/ && do { + Convert::ASN1::_dec_string({},[],{},$tmp,$_[0],$pos,$len); + if ($tmp =~ /[\x00-\x1f\x7f-\xff]/s) { + _hexdump($tmp,$fmt . " : ".$indent, $pos); + } + else { + printf " = '%s'\n",$tmp; + } + last; + }; + +# /^BIT STRING/ && do { +# Convert::BER::BIT_STRING->unpack($ber,\$tmp); +# print " = ",$tmp,"\n"; +# last; +# }; + + # default -- dump hex data + _hexdump(substr($_[0],$pos,$len),$fmt . " : ".$indent, $pos); + } + $pos += $len; + } + + select($ofh); +} + +BEGIN { undef &asn_hexdump } +sub asn_hexdump { + my $fh = @_>1 ? shift : \*STDERR; + my $ofh = select($fh); + + _hexdump($_[0]); + print "\n"; + select($ofh); +} + +BEGIN { undef &dump } +sub dump { + my $self = shift; + + for (@{$self->{script}}) { + dump_op($_,"",{},1); + } +} + +BEGIN { undef &dump_all } +sub dump_all { + my $self = shift; + + while(my($k,$v) = each %{$self->{tree}}) { + print STDERR "$k:\n"; + for (@$v) { + dump_op($_,"",{},1); + } + } +} + + +BEGIN { undef &dump_op } +sub dump_op { + my($op,$indent,$done,$line) = @_; + $indent ||= ""; + printf STDERR "%3d: ",$line; + if ($done->{$op}) { + print STDERR " $indent=",$done->{$op},"\n"; + return ++$line; + } + $done->{$op} = $line++; + print STDERR $indent,"[ '",unpack("H*",$op->[cTAG]),"', "; + print STDERR $op->[cTYPE] =~ /\D/ ? $op->[cTYPE] : $opName[$op->[cTYPE]]; + print STDERR ", ",defined($op->[cVAR]) ? $op->[cVAR] : "_"; + print STDERR ", ",defined($op->[cLOOP]) ? $op->[cLOOP] : "_"; + print STDERR ", ",defined($op->[cOPT]) ? $op->[cOPT] : "_"; + print STDERR "]"; + if ($op->[cCHILD]) { + print STDERR " ",scalar @{$op->[cCHILD]},"\n"; + for (@{$op->[cCHILD]}) { + $line = dump_op($_,$indent . " ",$done,$line); + } + } + else { + print STDERR "\n"; + } + print STDERR "\n" unless length $indent; + $line; +} + +1; + diff --git a/Master/tlpkg/tlperl0/lib/Convert/ASN1/IO.pm b/Master/tlpkg/tlperl0/lib/Convert/ASN1/IO.pm new file mode 100755 index 00000000000..e3dac3ee850 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Convert/ASN1/IO.pm @@ -0,0 +1,261 @@ +# 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; + +use strict; +use Socket; + +BEGIN { + local $SIG{__DIE__}; + eval { require bytes } and 'bytes'->import +} + +sub asn_recv { # $socket, $buffer, $flags + + my $peer; + my $buf; + my $n = 128; + my $pos = 0; + my $depth = 0; + my $len = 0; + my($tmp,$tb,$lb); + + MORE: + for( + $peer = recv($_[0],$buf,$n,MSG_PEEK); + defined $peer; + $peer = recv($_[0],$buf,$n<<=1,MSG_PEEK) + ) { + + if ($depth) { # Are we searching of "\0\0" + + unless (2+$pos <= length $buf) { + next MORE if $n == length $buf; + last MORE; + } + + if(substr($buf,$pos,2) eq "\0\0") { + unless (--$depth) { + $len = $pos + 2; + last MORE; + } + } + } + + # If we can decode a tag and length we can detemine the length + ($tb,$tmp) = asn_decode_tag(substr($buf,$pos)); + unless ($tb || $pos+$tb < length $buf) { + next MORE if $n == length $buf; + last MORE; + } + + if (ord(substr($buf,$pos+$tb,1)) == 0x80) { + # indefinite length, grrr! + $depth++; + $pos += $tb + 1; + redo MORE; + } + + ($lb,$len) = asn_decode_length(substr($buf,$pos+$tb)); + + if ($lb) { + if ($depth) { + $pos += $tb + $lb + $len; + redo MORE; + } + else { + $len += $tb + $lb + $pos; + last MORE; + } + } + } + + if (defined $peer) { + if ($len > length $buf) { + # Check we can read the whole element + goto error + unless defined($peer = recv($_[0],$buf,$len,MSG_PEEK)); + + if ($len > length $buf) { + # Cannot get whole element + $_[1]=''; + return $peer; + } + } + elsif ($len == 0) { + $_[1] = ''; + return $peer; + } + + if ($_[2] & MSG_PEEK) { + $_[1] = substr($buf,0,$len); + } + elsif (!defined($peer = recv($_[0],$_[1],$len,0))) { + goto error; + } + + return $peer; + } + +error: + $_[1] = undef; +} + +sub asn_read { # $fh, $buffer, $offset + + # We need to read one packet, and exactly only one packet. + # So we have to read the first few bytes one at a time, until + # we have enough to decode a tag and a length. We then know + # how many more bytes to read + + if ($_[2]) { + if ($_[2] > length $_[1]) { + require Carp; + Carp::carp("Offset beyond end of buffer"); + return; + } + substr($_[1],$_[2]) = ''; + } + else { + $_[1] = ''; + } + + my $pos = 0; + my $need = 0; + my $depth = 0; + my $ch; + my $n; + my $e; + + + while(1) { + $need = ($pos + ($depth * 2)) || 2; + + while(($n = $need - length $_[1]) > 0) { + $e = sysread($_[0],$_[1],$n,length $_[1]) or + goto READ_ERR; + } + + my $tch = ord(substr($_[1],$pos++,1)); + # Tag may be multi-byte + if(($tch & 0x1f) == 0x1f) { + my $ch; + do { + $need++; + while(($n = $need - length $_[1]) > 0) { + $e = sysread($_[0],$_[1],$n,length $_[1]) or + goto READ_ERR; + } + $ch = ord(substr($_[1],$pos++,1)); + } while($ch & 0x80); + } + + $need = $pos + 1; + + while(($n = $need - length $_[1]) > 0) { + $e = sysread($_[0],$_[1],$n,length $_[1]) or + goto READ_ERR; + } + + my $len = ord(substr($_[1],$pos++,1)); + + if($len & 0x80) { + unless ($len &= 0x7f) { + $depth++; + next; + } + $need = $pos + $len; + + while(($n = $need - length $_[1]) > 0) { + $e = sysread($_[0],$_[1],$n,length $_[1]) or + goto READ_ERR; + } + + $pos += $len + unpack("N", "\0" x (4 - $len) . substr($_[1],$pos,$len)); + } + elsif (!$len && !$tch) { + die "Bad ASN PDU" unless $depth; + unless (--$depth) { + last; + } + } + else { + $pos += $len; + } + + last unless $depth; + } + + while(($n = $pos - length $_[1]) > 0) { + $e = sysread($_[0],$_[1],$n,length $_[1]) or + goto READ_ERR; + } + + return length $_[1]; + +READ_ERR: + $@ = defined($e) ? "Unexpected EOF" : "I/O Error $!"; # . CORE::unpack("H*",$_[1]); + return undef; +} + +sub asn_send { # $sock, $buffer, $flags, $to + + @_ == 4 + ? send($_[0],$_[1],$_[2],$_[3]) + : send($_[0],$_[1],$_[2]); +} + +sub asn_write { # $sock, $buffer + + syswrite($_[0],$_[1], length $_[1]); +} + +sub asn_get { # $fh + + my $fh = ref($_[0]) ? $_[0] : \($_[0]); + my $href = \%{*$fh}; + + $href->{'asn_buffer'} = '' unless exists $href->{'asn_buffer'}; + + my $need = delete $href->{'asn_need'} || 0; + while(1) { + next if $need; + my($tb,$tag) = asn_decode_tag($href->{'asn_buffer'}) or next; + my($lb,$len) = asn_decode_length(substr($href->{'asn_buffer'},$tb,8)) or next; + $need = $tb + $lb + $len; + } + continue { + if ($need && $need <= length $href->{'asn_buffer'}) { + my $ret = substr($href->{'asn_buffer'},0,$need); + substr($href->{'asn_buffer'},0,$need) = ''; + return $ret; + } + + my $get = $need > 1024 ? $need : 1024; + + sysread($_[0], $href->{'asn_buffer'}, $get, length $href->{'asn_buffer'}) + or return undef; + } +} + +sub asn_ready { # $fh + + my $fh = ref($_[0]) ? $_[0] : \($_[0]); + my $href = \%{*$fh}; + + return 0 unless exists $href->{'asn_buffer'}; + + return $href->{'asn_need'} <= length $href->{'asn_buffer'} + if exists $href->{'asn_need'}; + + my($tb,$tag) = asn_decode_tag($href->{'asn_buffer'}) or return 0; + my($lb,$len) = asn_decode_length(substr($href->{'asn_buffer'},$tb,8)) or return 0; + + $href->{'asn_need'} = $tb + $lb + $len; + + $href->{'asn_need'} <= length $href->{'asn_buffer'}; +} + +1; 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; + diff --git a/Master/tlpkg/tlperl0/lib/Convert/ASN1/_encode.pm b/Master/tlpkg/tlperl0/lib/Convert/ASN1/_encode.pm new file mode 100755 index 00000000000..7aba3cd1b16 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Convert/ASN1/_encode.pm @@ -0,0 +1,406 @@ +# 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 { + unless (CHECK_UTF8) { + local $SIG{__DIE__}; + eval { require bytes } and 'bytes'->import + } +} + +# These are the subs which do the encoding, they are called with +# 0 1 2 3 4 5 +# $opt, $op, $stash, $var, $buf, $loop +# The order in the array must match the op definitions above + +my @encode = ( + sub { die "internal error\n" }, + \&_enc_boolean, + \&_enc_integer, + \&_enc_bitstring, + \&_enc_string, + \&_enc_null, + \&_enc_object_id, + \&_enc_real, + \&_enc_sequence, + \&_enc_sequence, # SET is the same encoding as sequence + \&_enc_time, + \&_enc_time, + \&_enc_utf8, + \&_enc_any, + \&_enc_choice, + \&_enc_object_id, + \&_enc_bcd, +); + + +sub _encode { + my ($optn, $ops, $stash, $path) = @_; + my $var; + + foreach my $op (@{$ops}) { + if (defined(my $opt = $op->[cOPT])) { + next unless defined $stash->{$opt}; + } + if (defined($var = $op->[cVAR])) { + push @$path, $var; + require Carp, Carp::croak(join(".", @$path)," is undefined") unless defined $stash->{$var}; + } + $_[4] .= $op->[cTAG]; + + &{$encode[$op->[cTYPE]]}( + $optn, + $op, + (UNIVERSAL::isa($stash, 'HASH') + ? ($stash, defined($var) ? $stash->{$var} : undef) + : ({}, $stash)), + $_[4], + $op->[cLOOP], + $path, + ); + + pop @$path if defined $var; + } + + $_[4]; +} + + +sub _enc_boolean { +# 0 1 2 3 4 5 6 +# $optn, $op, $stash, $var, $buf, $loop, $path + + $_[4] .= pack("CC",1, $_[3] ? 0xff : 0); +} + + +sub _enc_integer { +# 0 1 2 3 4 5 6 +# $optn, $op, $stash, $var, $buf, $loop, $path + if (abs($_[3]) >= 2**31) { + my $os = i2osp($_[3], ref($_[3]) || $_[0]->{encode_bigint} || 'Math::BigInt'); + my $len = length $os; + my $msb = (vec($os, 0, 8) & 0x80) ? 0 : 255; + $len++, $os = chr($msb) . $os if $msb xor $_[3] > 0; + $_[4] .= asn_encode_length($len); + $_[4] .= $os; + } + else { + my $val = int($_[3]); + my $neg = ($val < 0); + my $len = num_length($neg ? ~$val : $val); + my $msb = $val & (0x80 << (($len - 1) * 8)); + + $len++ if $neg ? !$msb : $msb; + + $_[4] .= asn_encode_length($len); + $_[4] .= substr(pack("N",$val), -$len); + } +} + + +sub _enc_bitstring { +# 0 1 2 3 4 5 6 +# $optn, $op, $stash, $var, $buf, $loop, $path + my $vref = ref($_[3]) ? \($_[3]->[0]) : \$_[3]; + + if (CHECK_UTF8 and Encode::is_utf8($$vref)) { + utf8::encode(my $tmp = $$vref); + $vref = \$tmp; + } + + if (ref($_[3])) { + my $less = (8 - ($_[3]->[1] & 7)) & 7; + my $len = ($_[3]->[1] + 7) >> 3; + $_[4] .= asn_encode_length(1+$len); + $_[4] .= chr($less); + $_[4] .= substr($$vref, 0, $len); + if ($less && $len) { + substr($_[4],-1) &= chr((0xff << $less) & 0xff); + } + } + else { + $_[4] .= asn_encode_length(1+length $$vref); + $_[4] .= chr(0); + $_[4] .= $$vref; + } +} + + +sub _enc_string { +# 0 1 2 3 4 5 6 +# $optn, $op, $stash, $var, $buf, $loop, $path + + if (CHECK_UTF8 and Encode::is_utf8($_[3])) { + utf8::encode(my $tmp = $_[3]); + $_[4] .= asn_encode_length(length $tmp); + $_[4] .= $tmp; + } + else { + $_[4] .= asn_encode_length(length $_[3]); + $_[4] .= $_[3]; + } +} + + +sub _enc_null { +# 0 1 2 3 4 5 6 +# $optn, $op, $stash, $var, $buf, $loop, $path + + $_[4] .= chr(0); +} + + +sub _enc_object_id { +# 0 1 2 3 4 5 6 +# $optn, $op, $stash, $var, $buf, $loop, $path + + my @data = ($_[3] =~ /(\d+)/g); + + if ($_[1]->[cTYPE] == opOBJID) { + if(@data < 2) { + @data = (0); + } + else { + my $first = $data[1] + ($data[0] * 40); + splice(@data,0,2,$first); + } + } + + my $l = length $_[4]; + $_[4] .= pack("cw*", 0, @data); + substr($_[4],$l,1) = asn_encode_length(length($_[4]) - $l - 1); +} + + +sub _enc_real { +# 0 1 2 3 4 5 6 +# $optn, $op, $stash, $var, $buf, $loop, $path + + # Zero + unless ($_[3]) { + $_[4] .= chr(0); + return; + } + + require POSIX; + + # +oo (well we use HUGE_VAL as Infinity is not avaliable to perl) + if ($_[3] >= POSIX::HUGE_VAL()) { + $_[4] .= pack("C*",0x01,0x40); + return; + } + + # -oo (well we use HUGE_VAL as Infinity is not avaliable to perl) + if ($_[3] <= - POSIX::HUGE_VAL()) { + $_[4] .= pack("C*",0x01,0x41); + return; + } + + if (exists $_[0]->{'encode_real'} && $_[0]->{'encode_real'} ne 'binary') { + my $tmp = sprintf("%g",$_[3]); + $_[4] .= asn_encode_length(1+length $tmp); + $_[4] .= chr(1); # NR1? + $_[4] .= $tmp; + return; + } + + # We have a real number. + my $first = 0x80; + my($mantissa, $exponent) = POSIX::frexp($_[3]); + + if ($mantissa < 0.0) { + $mantissa = -$mantissa; + $first |= 0x40; + } + my($eMant,$eExp); + + while($mantissa > 0.0) { + ($mantissa, my $int) = POSIX::modf($mantissa * (1<<8)); + $eMant .= chr($int); + } + $exponent -= 8 * length $eMant; + + _enc_integer(undef, undef, undef, $exponent, $eExp); + + # $eExp will br prefixed by a length byte + + if (5 > length $eExp) { + $eExp =~ s/\A.//s; + $first |= length($eExp)-1; + } + else { + $first |= 0x3; + } + + $_[4] .= asn_encode_length(1 + length($eMant) + length($eExp)); + $_[4] .= chr($first); + $_[4] .= $eExp; + $_[4] .= $eMant; +} + + +sub _enc_sequence { +# 0 1 2 3 4 5 6 +# $optn, $op, $stash, $var, $buf, $loop, $path + + if (my $ops = $_[1]->[cCHILD]) { + my $l = length $_[4]; + $_[4] .= "\0\0"; # guess + if (defined $_[5]) { + my $op = $ops->[0]; # there should only be one + my $enc = $encode[$op->[cTYPE]]; + my $tag = $op->[cTAG]; + my $loop = $op->[cLOOP]; + + push @{$_[6]}, -1; + + foreach my $var (@{$_[3]}) { + $_[6]->[-1]++; + $_[4] .= $tag; + + &{$enc}( + $_[0], # $optn + $op, # $op + $_[2], # $stash + $var, # $var + $_[4], # $buf + $loop, # $loop + $_[6], # $path + ); + } + pop @{$_[6]}; + } + else { + _encode($_[0],$_[1]->[cCHILD], defined($_[3]) ? $_[3] : $_[2], $_[6], $_[4]); + } + substr($_[4],$l,2) = asn_encode_length(length($_[4]) - $l - 2); + } + else { + $_[4] .= asn_encode_length(length $_[3]); + $_[4] .= $_[3]; + } +} + + +my %_enc_time_opt = ( utctime => 1, withzone => 0, raw => 2); + +sub _enc_time { +# 0 1 2 3 4 5 6 +# $optn, $op, $stash, $var, $buf, $loop, $path + + my $mode = $_enc_time_opt{$_[0]->{'encode_time'} || ''} || 0; + + if ($mode == 2) { + $_[4] .= asn_encode_length(length $_[3]); + $_[4] .= $_[3]; + return; + } + + my @time; + my $offset; + my $isgen = $_[1]->[cTYPE] == opGTIME; + + if (ref($_[3])) { + $offset = int($_[3]->[1] / 60); + $time = $_[3]->[0] + $_[3]->[1]; + } + elsif ($mode == 0) { + if (exists $_[0]->{'encode_timezone'}) { + $offset = int($_[0]->{'encode_timezone'} / 60); + $time = $_[3] + $_[0]->{'encode_timezone'}; + } + else { + @time = localtime($_[3]); + my @g = gmtime($_[3]); + + $offset = ($time[1] - $g[1]) + ($time[2] - $g[2]) * 60; + $time = $_[3] + $offset*60; + } + } + else { + $time = $_[3]; + } + @time = gmtime($time); + $time[4] += 1; + $time[5] = $isgen ? ($time[5] + 1900) : ($time[5] % 100); + + my $tmp = sprintf("%02d"x6, @time[5,4,3,2,1,0]); + if ($isgen) { + my $sp = sprintf("%.03f",$time); + $tmp .= substr($sp,-4) unless $sp =~ /\.000$/; + } + $tmp .= $offset ? sprintf("%+03d%02d",$offset / 60, abs($offset % 60)) : 'Z'; + $_[4] .= asn_encode_length(length $tmp); + $_[4] .= $tmp; +} + + +sub _enc_utf8 { +# 0 1 2 3 4 5 6 +# $optn, $op, $stash, $var, $buf, $loop, $path + + if (CHECK_UTF8) { + my $tmp = $_[3]; + utf8::upgrade($tmp) unless Encode::is_utf8($tmp); + utf8::encode($tmp); + $_[4] .= asn_encode_length(length $tmp); + $_[4] .= $tmp; + } + else { + $_[4] .= asn_encode_length(length $_[3]); + $_[4] .= $_[3]; + } +} + + +sub _enc_any { +# 0 1 2 3 4 5 6 +# $optn, $op, $stash, $var, $buf, $loop, $path + + my $handler; + if ($_[1]->[cDEFINE] && $_[2]->{$_[1]->[cDEFINE]}) { + $handler=$_[0]->{oidtable}{$_[2]->{$_[1]->[cDEFINE]}}; + $handler=$_[0]->{handlers}{$_[1]->[cVAR]}{$_[2]->{$_[1]->[cDEFINE]}} unless $handler; + } + if ($handler) { + $_[4] .= $handler->encode($_[3]); + } else { + $_[4] .= $_[3]; + } +} + + +sub _enc_choice { +# 0 1 2 3 4 5 6 +# $optn, $op, $stash, $var, $buf, $loop, $path + + my $stash = defined($_[3]) ? $_[3] : $_[2]; + for my $op (@{$_[1]->[cCHILD]}) { + my $var = defined $op->[cVAR] ? $op->[cVAR] : $op->[cCHILD]->[0]->[cVAR]; + + if (exists $stash->{$var}) { + push @{$_[6]}, $var; + _encode($_[0],[$op], $stash, $_[6], $_[4]); + pop @{$_[6]}; + return; + } + } + require Carp; + Carp::croak("No value found for CHOICE " . join(".", @{$_[6]})); +} + + +sub _enc_bcd { +# 0 1 2 3 4 5 6 +# $optn, $op, $stash, $var, $buf, $loop, $path + my $str = ("$_[3]" =~ /^(\d+)/) ? $1 : ""; + $str .= "F" if length($str) & 1; + $_[4] .= asn_encode_length(length($str) / 2); + $_[4] .= pack("H*", $str); +} +1; + diff --git a/Master/tlpkg/tlperl0/lib/Convert/ASN1/parser.pm b/Master/tlpkg/tlperl0/lib/Convert/ASN1/parser.pm new file mode 100755 index 00000000000..36d07c53004 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Convert/ASN1/parser.pm @@ -0,0 +1,916 @@ +#$yysccsid = "@(#)yaccpar 1.8 (Berkeley) 01/20/91 (Perl 2.0 12/31/92)"; +# 23 "parser.y" +;# 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::parser; + +use strict; +use Convert::ASN1 qw(:all); +use vars qw( + $asn $yychar $yyerrflag $yynerrs $yyn @yyss + $yyssp $yystate @yyvs $yyvsp $yylval $yys $yym $yyval +); + +BEGIN { Convert::ASN1->_internal_syms } + +my $yydebug=0; +my %yystate; + +my %base_type = ( + BOOLEAN => [ asn_encode_tag(ASN_BOOLEAN), opBOOLEAN ], + INTEGER => [ asn_encode_tag(ASN_INTEGER), opINTEGER ], + BIT_STRING => [ asn_encode_tag(ASN_BIT_STR), opBITSTR ], + OCTET_STRING => [ asn_encode_tag(ASN_OCTET_STR), opSTRING ], + STRING => [ asn_encode_tag(ASN_OCTET_STR), opSTRING ], + NULL => [ asn_encode_tag(ASN_NULL), opNULL ], + OBJECT_IDENTIFIER => [ asn_encode_tag(ASN_OBJECT_ID), opOBJID ], + REAL => [ asn_encode_tag(ASN_REAL), opREAL ], + ENUMERATED => [ asn_encode_tag(ASN_ENUMERATED), opINTEGER ], + ENUM => [ asn_encode_tag(ASN_ENUMERATED), opINTEGER ], + 'RELATIVE-OID' => [ asn_encode_tag(ASN_RELATIVE_OID), opROID ], + + SEQUENCE => [ asn_encode_tag(ASN_SEQUENCE | ASN_CONSTRUCTOR), opSEQUENCE ], + SET => [ asn_encode_tag(ASN_SET | ASN_CONSTRUCTOR), opSET ], + + ObjectDescriptor => [ asn_encode_tag(ASN_UNIVERSAL | 7), opSTRING ], + UTF8String => [ asn_encode_tag(ASN_UNIVERSAL | 12), opUTF8 ], + NumericString => [ asn_encode_tag(ASN_UNIVERSAL | 18), opSTRING ], + PrintableString => [ asn_encode_tag(ASN_UNIVERSAL | 19), opSTRING ], + TeletexString => [ asn_encode_tag(ASN_UNIVERSAL | 20), opSTRING ], + T61String => [ asn_encode_tag(ASN_UNIVERSAL | 20), opSTRING ], + VideotexString => [ asn_encode_tag(ASN_UNIVERSAL | 21), opSTRING ], + IA5String => [ asn_encode_tag(ASN_UNIVERSAL | 22), opSTRING ], + UTCTime => [ asn_encode_tag(ASN_UNIVERSAL | 23), opUTIME ], + GeneralizedTime => [ asn_encode_tag(ASN_UNIVERSAL | 24), opGTIME ], + GraphicString => [ asn_encode_tag(ASN_UNIVERSAL | 25), opSTRING ], + VisibleString => [ asn_encode_tag(ASN_UNIVERSAL | 26), opSTRING ], + ISO646String => [ asn_encode_tag(ASN_UNIVERSAL | 26), opSTRING ], + GeneralString => [ asn_encode_tag(ASN_UNIVERSAL | 27), opSTRING ], + CharacterString => [ asn_encode_tag(ASN_UNIVERSAL | 28), opSTRING ], + UniversalString => [ asn_encode_tag(ASN_UNIVERSAL | 28), opSTRING ], + BMPString => [ asn_encode_tag(ASN_UNIVERSAL | 30), opSTRING ], + BCDString => [ asn_encode_tag(ASN_OCTET_STR), opBCD ], + + CHOICE => [ '', opCHOICE ], + ANY => [ '', opANY ], +); + +;# Given an OP, wrap it in a SEQUENCE + +sub explicit { + my $op = shift; + my @seq = @$op; + + @seq[cTYPE,cCHILD,cVAR,cLOOP] = ('SEQUENCE',[$op],undef,undef); + @{$op}[cTAG,cOPT] = (); + + \@seq; +} + +sub constWORD () { 1 } +sub constCLASS () { 2 } +sub constSEQUENCE () { 3 } +sub constSET () { 4 } +sub constCHOICE () { 5 } +sub constOF () { 6 } +sub constIMPLICIT () { 7 } +sub constEXPLICIT () { 8 } +sub constOPTIONAL () { 9 } +sub constLBRACE () { 10 } +sub constRBRACE () { 11 } +sub constCOMMA () { 12 } +sub constANY () { 13 } +sub constASSIGN () { 14 } +sub constNUMBER () { 15 } +sub constENUM () { 16 } +sub constCOMPONENTS () { 17 } +sub constPOSTRBRACE () { 18 } +sub constDEFINED () { 19 } +sub constBY () { 20 } +sub constYYERRCODE () { 256 } +my @yylhs = ( -1, + 0, 0, 2, 2, 3, 3, 6, 6, 6, 6, + 8, 13, 13, 12, 14, 14, 14, 9, 9, 9, + 10, 18, 18, 18, 18, 18, 19, 19, 11, 16, + 16, 20, 20, 20, 21, 1, 1, 1, 22, 22, + 22, 24, 24, 24, 24, 23, 23, 23, 15, 15, + 4, 4, 5, 5, 5, 17, 17, 25, 7, 7, +); +my @yylen = ( 2, + 1, 1, 3, 4, 4, 1, 1, 1, 1, 1, + 3, 1, 1, 6, 1, 1, 1, 4, 4, 4, + 4, 1, 1, 1, 2, 1, 0, 3, 1, 1, + 2, 1, 3, 3, 4, 0, 1, 2, 1, 3, + 3, 2, 1, 1, 1, 4, 1, 3, 0, 1, + 0, 1, 0, 1, 1, 1, 3, 2, 0, 1, +); +my @yydefred = ( 0, + 0, 52, 0, 0, 1, 0, 0, 47, 0, 39, + 0, 0, 0, 0, 55, 54, 0, 0, 0, 3, + 0, 6, 0, 11, 0, 0, 0, 0, 48, 0, + 40, 41, 0, 22, 0, 0, 0, 0, 45, 43, + 0, 44, 0, 29, 46, 4, 0, 0, 0, 0, + 7, 8, 9, 10, 0, 25, 0, 50, 42, 0, + 0, 0, 0, 0, 0, 32, 60, 5, 0, 0, + 0, 56, 0, 18, 19, 0, 20, 0, 0, 28, + 58, 21, 0, 0, 0, 34, 33, 57, 0, 0, + 17, 15, 16, 0, 35, 14, +); +my @yydgoto = ( 4, + 5, 6, 20, 7, 17, 50, 68, 8, 51, 52, + 53, 54, 43, 94, 59, 64, 71, 44, 56, 65, + 66, 9, 10, 45, 72, +); +my @yysindex = ( 7, + 9, 0, 12, 0, 0, 19, 51, 0, 34, 0, + 75, 51, 31, -1, 0, 0, 90, 55, 55, 0, + 51, 0, 114, 0, 75, 26, 53, 61, 0, 77, + 0, 0, 114, 0, 26, 53, 64, 76, 0, 0, + 89, 0, 96, 0, 0, 0, 55, 55, 111, 103, + 0, 0, 0, 0, 94, 0, 130, 0, 0, 77, + 122, 128, 77, 141, 78, 0, 0, 0, 155, 147, + 33, 0, 51, 0, 0, 51, 0, 111, 111, 0, + 0, 0, 130, 119, 114, 0, 0, 0, 26, 53, + 0, 0, 0, 89, 0, 0, +); +my @yyrindex = ( 150, + 100, 0, 0, 0, 0, 166, 106, 0, 39, 0, + 100, 133, 0, 0, 0, 0, 0, 165, 140, 0, + 133, 0, 0, 0, 100, 0, 0, 0, 0, 100, + 0, 0, 0, 0, 16, 29, 42, 69, 0, 0, + 37, 0, 0, 0, 0, 0, 156, 156, 0, 125, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 100, + 0, 0, 100, 0, 154, 0, 0, 0, 0, 0, + 0, 0, 133, 0, 0, 133, 0, 0, 160, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 73, 88, + 0, 0, 0, 3, 0, 0, +); +my @yygindex = ( 0, + 28, 0, 149, 1, -11, 91, 0, 8, -17, -18, + -16, 152, 0, 0, 83, 0, 0, 0, 0, 0, + 50, 0, 123, 0, 95, +); +sub constYYTABLESIZE () { 178 } +my @yytable = ( 29, + 23, 12, 49, 49, 40, 39, 41, 1, 2, 33, + 2, 21, 25, 49, 49, 23, 23, 13, 22, 14, + 49, 12, 11, 3, 23, 21, 23, 23, 24, 24, + 12, 24, 22, 23, 13, 47, 49, 24, 37, 24, + 24, 27, 27, 82, 83, 18, 24, 49, 49, 37, + 27, 19, 27, 27, 49, 30, 2, 15, 16, 27, + 73, 84, 48, 76, 85, 92, 91, 93, 26, 26, + 49, 3, 23, 23, 61, 62, 2, 26, 2, 26, + 26, 23, 55, 23, 23, 57, 26, 24, 24, 78, + 23, 3, 26, 27, 28, 79, 24, 58, 24, 24, + 51, 60, 51, 51, 51, 24, 51, 51, 53, 53, + 53, 63, 51, 69, 34, 51, 35, 36, 28, 34, + 67, 89, 90, 28, 59, 59, 37, 86, 87, 38, + 70, 37, 74, 53, 38, 53, 53, 53, 75, 38, + 31, 32, 51, 51, 51, 53, 51, 51, 53, 36, + 38, 77, 51, 51, 51, 80, 51, 51, 51, 51, + 51, 81, 51, 51, 30, 2, 36, 51, 51, 51, + 31, 51, 51, 46, 42, 95, 96, 88, +); +my @yycheck = ( 17, + 12, 1, 0, 1, 23, 23, 23, 1, 2, 21, + 2, 11, 14, 11, 12, 0, 1, 6, 11, 1, + 18, 6, 14, 17, 9, 25, 11, 12, 0, 1, + 30, 1, 25, 18, 6, 10, 0, 9, 0, 11, + 12, 0, 1, 11, 12, 12, 18, 11, 12, 11, + 9, 18, 11, 12, 18, 1, 2, 7, 8, 18, + 60, 73, 10, 63, 76, 84, 84, 84, 0, 1, + 10, 17, 0, 1, 47, 48, 2, 9, 2, 11, + 12, 9, 19, 11, 12, 10, 18, 0, 1, 12, + 18, 17, 3, 4, 5, 18, 9, 9, 11, 12, + 1, 6, 3, 4, 5, 18, 7, 8, 3, 4, + 5, 1, 13, 20, 1, 16, 3, 4, 5, 1, + 18, 3, 4, 5, 0, 1, 13, 78, 79, 16, + 1, 13, 11, 1, 16, 3, 4, 5, 11, 0, + 18, 19, 3, 4, 5, 13, 7, 8, 16, 0, + 11, 11, 3, 4, 5, 1, 7, 8, 3, 4, + 5, 15, 7, 8, 11, 0, 11, 3, 4, 5, + 11, 7, 8, 25, 23, 85, 94, 83, +); +sub constYYFINAL () { 4 } + + + +sub constYYMAXTOKEN () { 20 } +sub yyclearin { $yychar = -1; } +sub yyerrok { $yyerrflag = 0; } +sub YYERROR { ++$yynerrs; &yy_err_recover; } +sub yy_err_recover +{ + if ($yyerrflag < 3) + { + $yyerrflag = 3; + while (1) + { + if (($yyn = $yysindex[$yyss[$yyssp]]) && + ($yyn += constYYERRCODE()) >= 0 && + $yyn <= $#yycheck && $yycheck[$yyn] == constYYERRCODE()) + { + + + + + $yyss[++$yyssp] = $yystate = $yytable[$yyn]; + $yyvs[++$yyvsp] = $yylval; + next yyloop; + } + else + { + + + + + return(1) if $yyssp <= 0; + --$yyssp; + --$yyvsp; + } + } + } + else + { + return (1) if $yychar == 0; + $yychar = -1; + next yyloop; + } +0; +} # yy_err_recover + +sub yyparse +{ + + if ($yys = $ENV{'YYDEBUG'}) + { + $yydebug = int($1) if $yys =~ /^(\d)/; + } + + + $yynerrs = 0; + $yyerrflag = 0; + $yychar = (-1); + + $yyssp = 0; + $yyvsp = 0; + $yyss[$yyssp] = $yystate = 0; + +yyloop: while(1) + { + yyreduce: { + last yyreduce if ($yyn = $yydefred[$yystate]); + if ($yychar < 0) + { + if (($yychar = &yylex) < 0) { $yychar = 0; } + } + if (($yyn = $yysindex[$yystate]) && ($yyn += $yychar) >= 0 && + $yyn <= $#yycheck && $yycheck[$yyn] == $yychar) + { + + + + + $yyss[++$yyssp] = $yystate = $yytable[$yyn]; + $yyvs[++$yyvsp] = $yylval; + $yychar = (-1); + --$yyerrflag if $yyerrflag > 0; + next yyloop; + } + if (($yyn = $yyrindex[$yystate]) && ($yyn += $yychar) >= 0 && + $yyn <= $#yycheck && $yycheck[$yyn] == $yychar) + { + $yyn = $yytable[$yyn]; + last yyreduce; + } + if (! $yyerrflag) { + &yyerror('syntax error'); + ++$yynerrs; + } + return undef if &yy_err_recover; + } # yyreduce + + + + + $yym = $yylen[$yyn]; + $yyval = $yyvs[$yyvsp+1-$yym]; + switch: + { +my $label = "State$yyn"; +goto $label if exists $yystate{$label}; +last switch; +State1: { +# 96 "parser.y" +{ $yyval = { '' => $yyvs[$yyvsp-0] }; +last switch; +} } +State3: { +# 101 "parser.y" +{ + $yyval = { $yyvs[$yyvsp-2], [$yyvs[$yyvsp-0]] }; + +last switch; +} } +State4: { +# 105 "parser.y" +{ + $yyval=$yyvs[$yyvsp-3]; + $yyval->{$yyvs[$yyvsp-2]} = [$yyvs[$yyvsp-0]]; + +last switch; +} } +State5: { +# 112 "parser.y" +{ + $yyvs[$yyvsp-1]->[cTAG] = $yyvs[$yyvsp-3]; + $yyval = $yyvs[$yyvsp-2] ? explicit($yyvs[$yyvsp-1]) : $yyvs[$yyvsp-1]; + +last switch; +} } +State11: { +# 126 "parser.y" +{ + @{$yyval = []}[cTYPE,cCHILD] = ('COMPONENTS', $yyvs[$yyvsp-0]); + +last switch; +} } +State14: { +# 136 "parser.y" +{ + $yyvs[$yyvsp-1]->[cTAG] = $yyvs[$yyvsp-3]; + @{$yyval = []}[cTYPE,cCHILD,cLOOP,cOPT] = ($yyvs[$yyvsp-5], [$yyvs[$yyvsp-1]], 1, $yyvs[$yyvsp-0]); + $yyval = explicit($yyval) if $yyvs[$yyvsp-2]; + +last switch; +} } +State18: { +# 149 "parser.y" +{ + @{$yyval = []}[cTYPE,cCHILD] = ('SEQUENCE', $yyvs[$yyvsp-1]); + +last switch; +} } +State19: { +# 153 "parser.y" +{ + @{$yyval = []}[cTYPE,cCHILD] = ('SET', $yyvs[$yyvsp-1]); + +last switch; +} } +State20: { +# 157 "parser.y" +{ + @{$yyval = []}[cTYPE,cCHILD] = ('CHOICE', $yyvs[$yyvsp-1]); + +last switch; +} } +State21: { +# 163 "parser.y" +{ + @{$yyval = []}[cTYPE] = ('ENUM'); + +last switch; +} } +State22: { +# 168 "parser.y" +{ @{$yyval = []}[cTYPE] = $yyvs[$yyvsp-0]; +last switch; +} } +State23: { +# 169 "parser.y" +{ @{$yyval = []}[cTYPE] = $yyvs[$yyvsp-0]; +last switch; +} } +State24: { +# 170 "parser.y" +{ @{$yyval = []}[cTYPE] = $yyvs[$yyvsp-0]; +last switch; +} } +State25: { +# 172 "parser.y" +{ + @{$yyval = []}[cTYPE,cCHILD,cDEFINE] = ('ANY',undef,$yyvs[$yyvsp-0]); + +last switch; +} } +State26: { +# 175 "parser.y" +{ @{$yyval = []}[cTYPE] = $yyvs[$yyvsp-0]; +last switch; +} } +State27: { +# 178 "parser.y" +{ $yyval=undef; +last switch; +} } +State28: { +# 179 "parser.y" +{ $yyval=$yyvs[$yyvsp-0]; +last switch; +} } +State30: { +# 185 "parser.y" +{ $yyval = $yyvs[$yyvsp-0]; +last switch; +} } +State31: { +# 186 "parser.y" +{ $yyval = $yyvs[$yyvsp-1]; +last switch; +} } +State32: { +# 190 "parser.y" +{ + $yyval = [ $yyvs[$yyvsp-0] ]; + +last switch; +} } +State33: { +# 194 "parser.y" +{ + push @{$yyval=$yyvs[$yyvsp-2]}, $yyvs[$yyvsp-0]; + +last switch; +} } +State34: { +# 198 "parser.y" +{ + push @{$yyval=$yyvs[$yyvsp-2]}, $yyvs[$yyvsp-0]; + +last switch; +} } +State35: { +# 204 "parser.y" +{ + @{$yyval=$yyvs[$yyvsp-0]}[cVAR,cTAG] = ($yyvs[$yyvsp-3],$yyvs[$yyvsp-2]); + $yyval = explicit($yyval) if $yyvs[$yyvsp-1]; + +last switch; +} } +State36: { +# 211 "parser.y" +{ $yyval = []; +last switch; +} } +State37: { +# 212 "parser.y" +{ $yyval = $yyvs[$yyvsp-0]; +last switch; +} } +State38: { +# 213 "parser.y" +{ $yyval = $yyvs[$yyvsp-1]; +last switch; +} } +State39: { +# 217 "parser.y" +{ + $yyval = [ $yyvs[$yyvsp-0] ]; + +last switch; +} } +State40: { +# 221 "parser.y" +{ + push @{$yyval=$yyvs[$yyvsp-2]}, $yyvs[$yyvsp-0]; + +last switch; +} } +State41: { +# 225 "parser.y" +{ + push @{$yyval=$yyvs[$yyvsp-2]}, $yyvs[$yyvsp-0]; + +last switch; +} } +State42: { +# 231 "parser.y" +{ + @{$yyval=$yyvs[$yyvsp-1]}[cOPT] = ($yyvs[$yyvsp-0]); + +last switch; +} } +State46: { +# 240 "parser.y" +{ + @{$yyval=$yyvs[$yyvsp-0]}[cVAR,cTAG] = ($yyvs[$yyvsp-3],$yyvs[$yyvsp-2]); + $yyval->[cOPT] = $yyvs[$yyvsp-3] if $yyval->[cOPT]; + $yyval = explicit($yyval) if $yyvs[$yyvsp-1]; + +last switch; +} } +State48: { +# 247 "parser.y" +{ + @{$yyval=$yyvs[$yyvsp-0]}[cTAG] = ($yyvs[$yyvsp-2]); + $yyval = explicit($yyval) if $yyvs[$yyvsp-1]; + +last switch; +} } +State49: { +# 253 "parser.y" +{ $yyval = undef; +last switch; +} } +State50: { +# 254 "parser.y" +{ $yyval = 1; +last switch; +} } +State51: { +# 258 "parser.y" +{ $yyval = undef; +last switch; +} } +State53: { +# 262 "parser.y" +{ $yyval = undef; +last switch; +} } +State54: { +# 263 "parser.y" +{ $yyval = 1; +last switch; +} } +State55: { +# 264 "parser.y" +{ $yyval = 0; +last switch; +} } +State56: { +# 267 "parser.y" +{ +last switch; +} } +State57: { +# 268 "parser.y" +{ +last switch; +} } +State58: { +# 271 "parser.y" +{ +last switch; +} } +State59: { +# 274 "parser.y" +{ +last switch; +} } +State60: { +# 275 "parser.y" +{ +last switch; +} } + } # switch + $yyssp -= $yym; + $yystate = $yyss[$yyssp]; + $yyvsp -= $yym; + $yym = $yylhs[$yyn]; + if ($yystate == 0 && $yym == 0) + { + + + + + $yystate = constYYFINAL(); + $yyss[++$yyssp] = constYYFINAL(); + $yyvs[++$yyvsp] = $yyval; + if ($yychar < 0) + { + if (($yychar = &yylex) < 0) { $yychar = 0; } + } + return $yyvs[$yyvsp] if $yychar == 0; + next yyloop; + } + if (($yyn = $yygindex[$yym]) && ($yyn += $yystate) >= 0 && + $yyn <= $#yycheck && $yycheck[$yyn] == $yystate) + { + $yystate = $yytable[$yyn]; + } else { + $yystate = $yydgoto[$yym]; + } + + + + + $yyss[++$yyssp] = $yystate; + $yyvs[++$yyvsp] = $yyval; + } # yyloop +} # yyparse +# 279 "parser.y" + +my %reserved = ( + 'OPTIONAL' => constOPTIONAL(), + 'CHOICE' => constCHOICE(), + 'OF' => constOF(), + 'IMPLICIT' => constIMPLICIT(), + 'EXPLICIT' => constEXPLICIT(), + 'SEQUENCE' => constSEQUENCE(), + 'SET' => constSET(), + 'ANY' => constANY(), + 'ENUM' => constENUM(), + 'ENUMERATED' => constENUM(), + 'COMPONENTS' => constCOMPONENTS(), + '{' => constLBRACE(), + '}' => constRBRACE(), + ',' => constCOMMA(), + '::=' => constASSIGN(), + 'DEFINED' => constDEFINED(), + 'BY' => constBY() +); + +my $reserved = join("|", reverse sort grep { /\w/ } keys %reserved); + +my %tag_class = ( + APPLICATION => ASN_APPLICATION, + UNIVERSAL => ASN_UNIVERSAL, + PRIVATE => ASN_PRIVATE, + CONTEXT => ASN_CONTEXT, + '' => ASN_CONTEXT # if not specified, its CONTEXT +); + +;## +;## This is NOT thread safe !!!!!! +;## + +my $pos; +my $last_pos; +my @stacked; + +sub parse { + local(*asn) = \($_[0]); + ($pos,$last_pos,@stacked) = (); + + eval { + local $SIG{__DIE__}; + compile(verify(yyparse())); + } +} + +sub compile_one { + my $tree = shift; + my $ops = shift; + my $name = shift; + foreach my $op (@$ops) { + next unless ref($op) eq 'ARRAY'; + bless $op; + my $type = $op->[cTYPE]; + if (exists $base_type{$type}) { + $op->[cTYPE] = $base_type{$type}->[1]; + $op->[cTAG] = defined($op->[cTAG]) ? asn_encode_tag($op->[cTAG]): $base_type{$type}->[0]; + } + else { + die "Unknown type '$type'\n" unless exists $tree->{$type}; + my $ref = compile_one( + $tree, + $tree->{$type}, + defined($op->[cVAR]) ? $name . "." . $op->[cVAR] : $name + ); + if (defined($op->[cTAG]) && $ref->[0][cTYPE] == opCHOICE) { + @{$op}[cTYPE,cCHILD] = (opSEQUENCE,$ref); + } + else { + @{$op}[cTYPE,cCHILD,cLOOP] = @{$ref->[0]}[cTYPE,cCHILD,cLOOP]; + } + $op->[cTAG] = defined($op->[cTAG]) ? asn_encode_tag($op->[cTAG]): $ref->[0][cTAG]; + } + $op->[cTAG] |= chr(ASN_CONSTRUCTOR) + if length $op->[cTAG] && ($op->[cTYPE] == opSET || $op->[cTYPE] == opSEQUENCE); + + if ($op->[cCHILD]) { + ;# If we have children we are one of + ;# opSET opSEQUENCE opCHOICE + + compile_one($tree, $op->[cCHILD], defined($op->[cVAR]) ? $name . "." . $op->[cVAR] : $name); + + ;# If a CHOICE is given a tag, then it must be EXPLICIT + if ($op->[cTYPE] == opCHOICE && defined($op->[cTAG]) && length($op->[cTAG])) { + $op = bless explicit($op); + $op->[cTYPE] = opSEQUENCE; + } + + if ( @{$op->[cCHILD]} > 1) { + ;#if ($op->[cTYPE] != opSEQUENCE) { + ;# Here we need to flatten CHOICEs and check that SET and CHOICE + ;# do not contain duplicate tags + ;#} + if ($op->[cTYPE] == opSET) { + ;# In case we do CER encoding we order the SET elements by thier tags + my @tags = map { + length($_->[cTAG]) + ? $_->[cTAG] + : $_->[cTYPE] == opCHOICE + ? (sort map { $_->[cTAG] } $_->[cCHILD])[0] + : '' + } @{$op->[cCHILD]}; + @{$op->[cCHILD]} = @{$op->[cCHILD]}[sort { $tags[$a] cmp $tags[$b] } 0..$#tags]; + } + } + else { + ;# A SET of one element can be treated the same as a SEQUENCE + $op->[cTYPE] = opSEQUENCE if $op->[cTYPE] == opSET; + } + } + } + $ops; +} + +sub compile { + my $tree = shift; + + ;# The tree should be valid enough to be able to + ;# - resolve references + ;# - encode tags + ;# - verify CHOICEs do not contain duplicate tags + + ;# once references have been resolved, and also due to + ;# flattening of COMPONENTS, it is possible for an op + ;# to appear in multiple places. So once an op is + ;# compiled we bless it. This ensure we dont try to + ;# compile it again. + + while(my($k,$v) = each %$tree) { + compile_one($tree,$v,$k); + } + + $tree; +} + +sub verify { + my $tree = shift or return; + my $err = ""; + + ;# Well it parsed correctly, now we + ;# - check references exist + ;# - flatten COMPONENTS OF (checking for loops) + ;# - check for duplicate var names + + while(my($name,$ops) = each %$tree) { + my $stash = {}; + my @scope = (); + my $path = ""; + my $idx = 0; + + while($ops) { + if ($idx < @$ops) { + my $op = $ops->[$idx++]; + my $var; + if (defined ($var = $op->[cVAR])) { + + $err .= "$name: $path.$var used multiple times\n" + if $stash->{$var}++; + + } + if (defined $op->[cCHILD]) { + if (ref $op->[cCHILD]) { + push @scope, [$stash, $path, $ops, $idx]; + if (defined $var) { + $stash = {}; + $path .= "." . $var; + } + $idx = 0; + $ops = $op->[cCHILD]; + } + elsif ($op->[cTYPE] eq 'COMPONENTS') { + splice(@$ops,--$idx,1,expand_ops($tree, $op->[cCHILD])); + } + else { + die "Internal error\n"; + } + } + } + else { + my $s = pop @scope + or last; + ($stash,$path,$ops,$idx) = @$s; + } + } + } + die $err if length $err; + $tree; +} + +sub expand_ops { + my $tree = shift; + my $want = shift; + my $seen = shift || { }; + + die "COMPONENTS OF loop $want\n" if $seen->{$want}++; + die "Undefined macro $want\n" unless exists $tree->{$want}; + my $ops = $tree->{$want}; + die "Bad macro for COMPUNENTS OF '$want'\n" + unless @$ops == 1 + && ($ops->[0][cTYPE] eq 'SEQUENCE' || $ops->[0][cTYPE] eq 'SET') + && ref $ops->[0][cCHILD]; + $ops = $ops->[0][cCHILD]; + for(my $idx = 0 ; $idx < @$ops ; ) { + my $op = $ops->[$idx++]; + if ($op->[cTYPE] eq 'COMPONENTS') { + splice(@$ops,--$idx,1,expand_ops($tree, $op->[cCHILD], $seen)); + } + } + + @$ops; +} + +sub _yylex { + my $ret = &_yylex; + warn $ret; + $ret; +} + +sub yylex { + return shift @stacked if @stacked; + + while ($asn =~ /\G(?: + (\s+|--[^\n]*) + | + ([,{}]|::=) + | + ($reserved)\b + | + ( + (?:OCTET|BIT)\s+STRING + | + OBJECT\s+IDENTIFIER + | + RELATIVE-OID + )\b + | + (\w+(?:-\w+)*) + | + \[\s* + ( + (?:(?:APPLICATION|PRIVATE|UNIVERSAL|CONTEXT)\s+)? + \d+ + ) + \s*\] + | + \((\d+)\) + )/sxgo + ) { + + ($last_pos,$pos) = ($pos,pos($asn)); + + next if defined $1; # comment or whitespace + + if (defined $2 or defined $3) { + # A comma is not required after a '}' so to aid the + # parser we insert a fake token after any '}' + push @stacked, constPOSTRBRACE() if defined $2 and $+ eq '}'; + + return $reserved{$yylval = $+}; + } + + if (defined $4) { + ($yylval = $+) =~ s/\s+/_/g; + return constWORD(); + } + + if (defined $5) { + $yylval = $+; + return constWORD(); + } + + if (defined $6) { + my($class,$num) = ($+ =~ /^([A-Z]*)\s*(\d+)$/); + $yylval = asn_tag($tag_class{$class}, $num); + return constCLASS(); + } + + if (defined $7) { + $yylval = $+; + return constNUMBER(); + } + + die "Internal error\n"; + + } + + die "Parse error before ",substr($asn,$pos,40),"\n" + unless $pos == length($asn); + + 0 +} + +sub yyerror { + die @_," ",substr($asn,$last_pos,40),"\n"; +} + +1; + +%yystate = ('State51','','State34','','State11','','State33','','State24', +'','State40','','State31','','State37','','State23','','State22','', +'State21','','State57','','State39','','State56','','State20','','State25', +'','State38','','State14','','State19','','State46','','State5','', +'State53','','State26','','State27','','State50','','State36','','State4', +'','State3','','State32','','State49','','State30','','State35','', +'State48','','State55','','State42','','State28','','State58','','State41', +'','State18','','State59','','State1','','State54','','State60', +''); + +1; |