summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl0/lib/Convert/ASN1
diff options
context:
space:
mode:
authorSiep Kroonenberg <siepo@cybercomm.nl>2011-02-17 12:20:49 +0000
committerSiep Kroonenberg <siepo@cybercomm.nl>2011-02-17 12:20:49 +0000
commit316ee97c621496b0fe3267f57cce81bee44ca1e6 (patch)
treecb2cab1192b4f58a7971af19b213e980bceda4b4 /Master/tlpkg/tlperl0/lib/Convert/ASN1
parentcd0f87b5d39480d85ad9bd4ee37f520f75bed560 (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-xMaster/tlpkg/tlperl0/lib/Convert/ASN1/Debug.pm226
-rwxr-xr-xMaster/tlpkg/tlperl0/lib/Convert/ASN1/IO.pm261
-rwxr-xr-xMaster/tlpkg/tlperl0/lib/Convert/ASN1/_decode.pm675
-rwxr-xr-xMaster/tlpkg/tlperl0/lib/Convert/ASN1/_encode.pm406
-rwxr-xr-xMaster/tlpkg/tlperl0/lib/Convert/ASN1/parser.pm916
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;