summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl.straw/lib/Convert
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl.straw/lib/Convert')
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Convert/ASCII/Armor.pm37
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Convert/ASCII/Armour.pm247
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Convert/ASN1.pm444
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Convert/ASN1.pod480
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Convert/ASN1/Debug.pm226
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Convert/ASN1/IO.pm261
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Convert/ASN1/_decode.pm675
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Convert/ASN1/_encode.pm406
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Convert/ASN1/parser.pm916
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Convert/PEM.pm472
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Convert/PEM/CBC.pm227
11 files changed, 4391 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl.straw/lib/Convert/ASCII/Armor.pm b/Master/tlpkg/tlperl.straw/lib/Convert/ASCII/Armor.pm
new file mode 100755
index 00000000000..8e78bff3238
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Convert/ASCII/Armor.pm
@@ -0,0 +1,37 @@
+#!/usr/bin/perl -sw
+##
+##
+##
+## Copyright (c) 2001, Vipul Ved Prakash. All rights reserved.
+## This code is free software; you can redistribute it and/or modify
+## it under the same terms as Perl itself.
+##
+## $Id: Armor.pm,v 1.1 2001/03/19 23:15:09 vipul Exp $
+
+package Convert::ASCII::Armor;
+use lib "../../../lib";
+use Convert::ASCII::Armour;
+use vars qw(@ISA);
+@ISA = qw(Convert::ASCII::Armour);
+
+1;
+
+=head1 NAME
+
+Convert::ASCII::Armor - Convert binary octets into ASCII armoured messages.
+
+=head1 SYNOPSIS
+
+See SYNOPSIS in Convert::ASCII::Armour.
+
+=head1 DESCRIPTION
+
+Empty subclass of Convert::ASCII::Armour for American English speakers.
+
+=head1 AUTHOR
+
+Vipul Ved Prakash, E<lt>mail@vipul.netE<gt>
+
+=cut
+
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Convert/ASCII/Armour.pm b/Master/tlpkg/tlperl.straw/lib/Convert/ASCII/Armour.pm
new file mode 100755
index 00000000000..b941ec11783
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Convert/ASCII/Armour.pm
@@ -0,0 +1,247 @@
+#!/usr/bin/perl -sw
+##
+## Convert::ASCII::Armour
+##
+## Copyright (c) 2001, Vipul Ved Prakash. All rights reserved.
+## This code is free software; you can redistribute it and/or modify
+## it under the same terms as Perl itself.
+##
+## $Id: Armour.pm,v 1.4 2001/03/19 23:15:09 vipul Exp $
+
+package Convert::ASCII::Armour;
+use strict;
+use Digest::MD5 qw(md5);
+use MIME::Base64;
+use Compress::Zlib qw(compress uncompress);
+use vars qw($VERSION);
+
+($VERSION) = '$Revision: 1.4 $' =~ /\s(\d+\.\d+)\s/;
+
+
+sub new {
+ return bless {}, shift;
+}
+
+
+sub error {
+ my ($self, $errstr) = @_;
+ $$self{errstr} = "$errstr\n";
+ return;
+}
+
+
+sub errstr {
+ my $self = shift;
+ return $$self{errstr};
+}
+
+
+sub armour {
+
+ my ($self, %params) = @_;
+
+ my $compress = $params{Compress} ? "COMPRESSED " : "";
+ return undef unless $params{Content};
+ $params{Object} = "UNKNOWN $compress DATA" unless $params{Object};
+
+ my $head = "-"x5 . "BEGIN $compress$params{Object}" . "-"x5;
+ my $tail = "-"x5 . "END $compress$params{Object}" . "-"x5;
+
+ my $content = $self->encode_content (%{$params{Content}});
+ $content = compress($content) if $compress;
+ my $checksum = encode_base64 (md5 ($content));
+ my $econtent = encode_base64 ($content);
+
+ my $eheaders = "";
+ for my $key (keys %{$params{Headers}}) {
+ $eheaders .= "$key: $params{Headers}->{$key}\n";
+ }
+
+ my $message = "$head\n$eheaders\n$econtent=$checksum$tail\n";
+ return $message;
+
+}
+
+
+sub unarmour {
+ my ($self, $message) = @_;
+
+ my ($head, $object, $headers, $content, $tail) = $message =~
+ m:(-----BEGIN ([^\n\-]+)-----)\n(.*?\n\n)?(.+)(-----END .*?-----)$:s
+ or return $self->error ("Breached Armour.");
+
+ my ($compress, $obj) = $object =~ /^(COMPRESSED )(.*)$/;
+ $object = $obj if $obj;
+ $content =~ s:=([^\n]+)$::s or return $self->error ("Breached Armour.");
+ my $checksum = $1; $content = decode_base64 ($content);
+ my $ncheck = encode_base64 (md5 ($content)); $ncheck =~ s/\n//;
+ return $self->error ("Checksum Failed.") unless $ncheck eq $checksum;
+ $content = uncompress ($content) if $compress;
+ my $dcontent = $self->decode_content ($content) || return;
+
+ my $dheaders;
+ if ($headers) {
+ my @pairs = split /\n/, $headers;
+ for (@pairs) {
+ my ($key, $value) = split /: /, $_, 2;
+ $$dheaders{$key} = $value if $key;
+ }
+ }
+
+ my %return = ( Content => $dcontent,
+ Object => $object,
+ Headers => $dheaders );
+
+ return \%return;
+
+}
+
+
+sub encode_content {
+ my ($self, %data) = @_;
+ my $encoded = "";
+
+ for my $key (keys %data) {
+ $encoded .= length ($key) . chr(0) . length ($data{$key}) .
+ chr(0) . "$key$data{$key}";
+ }
+
+ return $encoded;
+}
+
+
+sub decode_content {
+ my ($self, $content) = @_;
+ my %data;
+
+ while ($content) {
+ $content =~ s/^(\d+)\x00(\d+)\x00// ||
+ return $self->error ("Inconsistent content.");
+ my $keylen = $1; my $valuelen = $2;
+ my $key = substr $content, 0, $keylen;
+ my $value = substr $content, $keylen, $valuelen;
+ substr ($content, 0, $keylen + $valuelen) = "";
+ $data{$key} = $value;
+ }
+
+ return \%data;
+}
+
+
+sub armor { armour (@_) }
+sub unarmor { unarmour (@_) }
+
+
+1;
+
+
+=head1 NAME
+
+Convert::ASCII::Armour - Convert binary octets into ASCII armoured messages.
+
+=head1 SYNOPSIS
+
+ my $converter = new Convert::ASCII::Armour;
+
+ my $message = $converter->armour(
+ Object => "FOO RECORD",
+ Headers => {
+ Table => "FooBar",
+ Version => "1.23",
+ },
+ Content => {
+ Key => "0x8738FA7382",
+ Name => "Zoya Hall",
+ Pic => "....", # gif
+ },
+ Compress => 1,
+ );
+
+ print $message;
+
+
+ -----BEGIN COMPRESSED FOO RECORD-----
+ Version: 1.23
+ Table: FooBar
+
+ eJwzZzA0Z/BNLS5OTE8NycgsVgCiRIVciIAJg6EJg0tiSaqhsYJvYlFy...
+ XnpOZl5qYlJySmpaekZmVnZObl5+QWFRcUlpWXlFZRWXAk7g6OTs4urm...
+ Fh4VGaWAR5ehkbGJqZm5hSUeNXWKDsoGcWpaGpq68bba0dWxtTVmDOYM...
+ NzuZ
+ =MxpZvjkrv5XyhkVCuXmsBQ==
+ -----END COMPRESSED FOO RECORD-----
+
+
+ my $decoded = $converter->unarmour( $message )
+ || die $converter->errstr();
+
+
+=head1 DESCRIPTION
+
+This module converts hashes of binary octets into ASCII messages suitable
+for transfer over 6-bit clean transport channels. The encoded ASCII
+resembles PGP's armoured messages, but are in no way compatible with PGP.
+
+=head1 METHODS
+
+=head2 B<new()>
+
+Constructor.
+
+=head2 B<armour()>
+
+Converts a hash of binary octets into an ASCII encoded message. The
+encoded message has 4 parts: head and tail strings that act as identifiers
+and delimiters, a cluster of headers at top of the message, Base64 encoded
+message body and a Base64 encoded MD5 digest of the message body. armour()
+takes a hash as argument with following keys:
+
+=over 4
+
+=item B<Object>
+
+An identification string embedded in head and tail strings.
+
+=item B<Content>
+
+Content is a hashref that contains the binary octets to be encoded. This
+hash is serialized, compressed (if specified) and encoded into ASCII with
+MIME::Base64. The result is the body of the encoded message.
+
+=item B<Headers>
+
+Headers is a hashref that contains ASCII headers that are placed at top of
+the encoded message. Headers are encoded as RFC822 headers.
+
+=item B<Compress>
+
+A boolean parameter that forces armour() to compress the message body.
+
+=back
+
+=head2 B<unarmour()>
+
+Decodes an armoured ASCII message into the hash provided as argument
+to armour(). The hash contains Content, Object, and Headers.
+unarmour() performs several consistency checks and returns a non-true
+value on failure.
+
+=head2 B<errstr()>
+
+Returns the error message set by unarmour() on failure.
+
+=head1 AUTHOR
+
+Vipul Ved Prakash, E<lt>mail@vipul.netE<gt>
+
+=head1 LICENSE
+
+Copyright (c) 2001, Vipul Ved Prakash. All rights reserved. This code is
+free software; you can redistribute it and/or modify it under the same
+terms as Perl itself.
+
+=head1 SEE ALSO
+
+MIME::Base64(3), Compress::Zlib(3), Digest::MD5(3)
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Convert/ASN1.pm b/Master/tlpkg/tlperl.straw/lib/Convert/ASN1.pm
new file mode 100755
index 00000000000..71a599dbd1b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Convert/ASN1.pm
@@ -0,0 +1,444 @@
+# Copyright (c) 2000-2002 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;
+
+# $Id: ASN1.pm,v 1.29 2003/10/08 14:29:17 gbarr Exp $
+
+use 5.004;
+use strict;
+use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS @opParts @opName $AUTOLOAD);
+use Exporter;
+
+use constant CHECK_UTF8 => $] > 5.007;
+
+BEGIN {
+ local $SIG{__DIE__};
+ eval { require bytes and 'bytes'->import };
+
+ if (CHECK_UTF8) {
+ require Encode;
+ require utf8;
+ }
+
+ @ISA = qw(Exporter);
+ $VERSION = "0.22";
+
+ %EXPORT_TAGS = (
+ io => [qw(asn_recv asn_send asn_read asn_write asn_get asn_ready)],
+
+ debug => [qw(asn_dump asn_hexdump)],
+
+ const => [qw(ASN_BOOLEAN ASN_INTEGER ASN_BIT_STR ASN_OCTET_STR
+ ASN_NULL ASN_OBJECT_ID ASN_REAL ASN_ENUMERATED
+ ASN_SEQUENCE ASN_SET ASN_PRINT_STR ASN_IA5_STR
+ ASN_UTC_TIME ASN_GENERAL_TIME ASN_RELATIVE_OID
+ ASN_UNIVERSAL ASN_APPLICATION ASN_CONTEXT ASN_PRIVATE
+ ASN_PRIMITIVE ASN_CONSTRUCTOR ASN_LONG_LEN ASN_EXTENSION_ID ASN_BIT)],
+
+ tag => [qw(asn_tag asn_decode_tag2 asn_decode_tag asn_encode_tag asn_decode_length asn_encode_length)]
+ );
+
+ @EXPORT_OK = map { @$_ } values %EXPORT_TAGS;
+ $EXPORT_TAGS{all} = \@EXPORT_OK;
+
+ @opParts = qw(
+ cTAG cTYPE cVAR cLOOP cOPT cCHILD cDEFINE
+ );
+
+ @opName = qw(
+ opUNKNOWN opBOOLEAN opINTEGER opBITSTR opSTRING opNULL opOBJID opREAL
+ opSEQUENCE opSET opUTIME opGTIME opUTF8 opANY opCHOICE opROID opBCD
+ );
+
+ foreach my $l (\@opParts, \@opName) {
+ my $i = 0;
+ foreach my $name (@$l) {
+ my $j = $i++;
+ no strict 'refs';
+ *{__PACKAGE__ . '::' . $name} = sub () { $j }
+ }
+ }
+}
+
+sub _internal_syms {
+ my $pkg = caller;
+ no strict 'refs';
+ for my $sub (@opParts,@opName,'dump_op') {
+ *{$pkg . '::' . $sub} = \&{__PACKAGE__ . '::' . $sub};
+ }
+}
+
+sub ASN_BOOLEAN () { 0x01 }
+sub ASN_INTEGER () { 0x02 }
+sub ASN_BIT_STR () { 0x03 }
+sub ASN_OCTET_STR () { 0x04 }
+sub ASN_NULL () { 0x05 }
+sub ASN_OBJECT_ID () { 0x06 }
+sub ASN_REAL () { 0x09 }
+sub ASN_ENUMERATED () { 0x0A }
+sub ASN_RELATIVE_OID () { 0x0D }
+sub ASN_SEQUENCE () { 0x10 }
+sub ASN_SET () { 0x11 }
+sub ASN_PRINT_STR () { 0x13 }
+sub ASN_IA5_STR () { 0x16 }
+sub ASN_UTC_TIME () { 0x17 }
+sub ASN_GENERAL_TIME () { 0x18 }
+
+sub ASN_UNIVERSAL () { 0x00 }
+sub ASN_APPLICATION () { 0x40 }
+sub ASN_CONTEXT () { 0x80 }
+sub ASN_PRIVATE () { 0xC0 }
+
+sub ASN_PRIMITIVE () { 0x00 }
+sub ASN_CONSTRUCTOR () { 0x20 }
+
+sub ASN_LONG_LEN () { 0x80 }
+sub ASN_EXTENSION_ID () { 0x1F }
+sub ASN_BIT () { 0x80 }
+
+
+sub new {
+ my $pkg = shift;
+ my $self = bless {}, $pkg;
+
+ $self->configure(@_);
+ $self;
+}
+
+
+sub configure {
+ my $self = shift;
+ my %opt = @_;
+
+ $self->{options}{encoding} = uc($opt{encoding} || 'BER');
+
+ unless ($self->{options}{encoding} =~ /^[BD]ER$/) {
+ require Carp;
+ Carp::croak("Unsupported encoding format '$opt{encoding}'");
+ }
+
+ for my $type (qw(encode decode)) {
+ if (exists $opt{$type}) {
+ while(my($what,$value) = each %{$opt{$type}}) {
+ $self->{options}{"${type}_${what}"} = $value;
+ }
+ }
+ }
+}
+
+
+
+sub find {
+ my $self = shift;
+ my $what = shift;
+ return unless exists $self->{tree}{$what};
+ my %new = %$self;
+ $new{script} = $new{tree}->{$what};
+ bless \%new, ref($self);
+}
+
+
+sub prepare {
+ my $self = shift;
+ my $asn = shift;
+
+ $self = $self->new unless ref($self);
+ my $tree;
+ if( ref($asn) eq 'GLOB' ){
+ local $/ = undef;
+ my $txt = <$asn>;
+ $tree = Convert::ASN1::parser::parse($txt);
+ } else {
+ $tree = Convert::ASN1::parser::parse($asn);
+ }
+
+ unless ($tree) {
+ $self->{error} = $@;
+ return;
+ ### If $self has been set to a new object, not returning
+ ### this object here will destroy the object, so the caller
+ ### won't be able to get at the error.
+ }
+
+ $self->{tree} = _pack_struct($tree);
+ $self->{script} = (values %$tree)[0];
+ $self;
+}
+
+sub prepare_file {
+ my $self = shift;
+ my $asnp = shift;
+
+ local *ASN;
+ open( ASN, $asnp )
+ or do{ $self->{error} = $@; return; };
+ my $ret = $self->prepare( \*ASN );
+ close( ASN );
+ $ret;
+}
+
+sub registeroid {
+ my $self = shift;
+ my $oid = shift;
+ my $handler = shift;
+
+ $self->{options}{oidtable}{$oid}=$handler;
+ $self->{oidtable}{$oid}=$handler;
+}
+
+sub registertype {
+ my $self = shift;
+ my $def = shift;
+ my $type = shift;
+ my $handler = shift;
+
+ $self->{options}{handlers}{$def}{$type}=$handler;
+}
+
+# In XS the will convert the tree between perl and C structs
+
+sub _pack_struct { $_[0] }
+sub _unpack_struct { $_[0] }
+
+##
+## Encoding
+##
+
+sub encode {
+ my $self = shift;
+ my $stash = @_ == 1 ? shift : { @_ };
+ my $buf = '';
+ local $SIG{__DIE__};
+ eval { _encode($self->{options}, $self->{script}, $stash, [], $buf) }
+ or do { $self->{error} = $@; undef }
+}
+
+
+
+# Encode tag value for encoding.
+# We assume that the tag has been correctly generated with asn_tag()
+
+sub asn_encode_tag {
+ $_[0] >> 8
+ ? $_[0] & 0x8000
+ ? $_[0] & 0x800000
+ ? pack("V",$_[0])
+ : substr(pack("V",$_[0]),0,3)
+ : pack("v", $_[0])
+ : chr($_[0]);
+}
+
+
+# Encode a length. If < 0x80 then encode as a byte. Otherwise encode
+# 0x80 | num_bytes followed by the bytes for the number. top end
+# bytes of all zeros are not encoded
+
+sub asn_encode_length {
+
+ if($_[0] >> 7) {
+ my $lenlen = &num_length;
+
+ return pack("Ca*", $lenlen | 0x80, substr(pack("N",$_[0]), -$lenlen));
+ }
+
+ return pack("C", $_[0]);
+}
+
+
+##
+## Decoding
+##
+
+sub decode {
+ my $self = shift;
+
+ local $SIG{__DIE__};
+ my $ret = eval {
+ my (%stash, $result);
+ my $script = $self->{script};
+ my $stash = (1 == @$script && !$self->{script}[0][cVAR]) ? \$result : ($result=\%stash);
+
+ _decode(
+ $self->{options},
+ $script,
+ $stash,
+ 0,
+ length $_[0],
+ undef,
+ {},
+ $_[0]);
+
+ $result;
+ };
+ if ($@) {
+ $self->{'error'} = $@;
+ return undef;
+ }
+ $ret;
+}
+
+
+sub asn_decode_length {
+ return unless length $_[0];
+
+ my $len = ord substr($_[0],0,1);
+
+ if($len & 0x80) {
+ $len &= 0x7f or return (1,-1);
+
+ return if $len >= length $_[0];
+
+ return (1+$len, unpack("N", "\0" x (4 - $len) . substr($_[0],1,$len)));
+ }
+ return (1, $len);
+}
+
+
+sub asn_decode_tag {
+ return unless length $_[0];
+
+ my $tag = ord $_[0];
+ my $n = 1;
+
+ if(($tag & 0x1f) == 0x1f) {
+ my $b;
+ do {
+ return if $n >= length $_[0];
+ $b = ord substr($_[0],$n,1);
+ $tag |= $b << (8 * $n++);
+ } while($b & 0x80);
+ }
+ ($n, $tag);
+}
+
+
+sub asn_decode_tag2 {
+ return unless length $_[0];
+
+ my $tag = ord $_[0];
+ my $num = $tag & 0x1f;
+ my $len = 1;
+
+ if($num == 0x1f) {
+ $num = 0;
+ my $b;
+ do {
+ return if $len >= length $_[0];
+ $b = ord substr($_[0],$len++,1);
+ $num = ($num << 7) + ($b & 0x7f);
+ } while($b & 0x80);
+ }
+ ($len, $tag, $num);
+}
+
+
+##
+## Utilities
+##
+
+# How many bytes are needed to encode a number
+
+sub num_length {
+ $_[0] >> 8
+ ? $_[0] >> 16
+ ? $_[0] >> 24
+ ? 4
+ : 3
+ : 2
+ : 1
+}
+
+# Convert from a bigint to an octet string
+
+sub i2osp {
+ my($num, $biclass) = @_;
+ eval "use $biclass";
+ $num = $biclass->new($num);
+ my $neg = $num < 0
+ and $num = abs($num+1);
+ my $base = $biclass->new(256);
+ my $result = '';
+ while($num != 0) {
+ my $r = $num % $base;
+ $num = ($num-$r) / $base;
+ $result .= chr($r);
+ }
+ $result ^= chr(255) x length($result) if $neg;
+ return scalar reverse $result;
+}
+
+# Convert from an octet string to a bigint
+
+sub os2ip {
+ my($os, $biclass) = @_;
+ eval "require $biclass";
+ my $base = $biclass->new(256);
+ my $result = $biclass->new(0);
+ my $neg = ord($os) >= 0x80
+ and $os ^= chr(255) x length($os);
+ for (unpack("C*",$os)) {
+ $result = ($result * $base) + $_;
+ }
+ return $neg ? ($result + 1) * -1 : $result;
+}
+
+# Given a class and a tag, calculate an integer which when encoded
+# will become the tag. This means that the class bits are always
+# in the bottom byte, so are the tag bits if tag < 30. Otherwise
+# the tag is in the upper 3 bytes. The upper bytes are encoded
+# with bit8 representing that there is another byte. This
+# means the max tag we can do is 0x1fffff
+
+sub asn_tag {
+ my($class,$value) = @_;
+
+ die sprintf "Bad tag class 0x%x",$class
+ if $class & ~0xe0;
+
+ unless ($value & ~0x1f or $value == 0x1f) {
+ return (($class & 0xe0) | $value);
+ }
+
+ die sprintf "Tag value 0x%08x too big\n",$value
+ if $value & 0xffe00000;
+
+ $class = ($class | 0x1f) & 0xff;
+
+ my @t = ($value & 0x7f);
+ unshift @t, (0x80 | ($value & 0x7f)) while $value >>= 7;
+ unpack("V",pack("C4",$class,@t,0,0));
+}
+
+
+BEGIN {
+ # When we have XS &_encode will be defined by the XS code
+ # so will all the subs in these required packages
+ unless (defined &_encode) {
+ require Convert::ASN1::_decode;
+ require Convert::ASN1::_encode;
+ require Convert::ASN1::IO;
+ }
+
+ require Convert::ASN1::parser;
+}
+
+sub AUTOLOAD {
+ require Convert::ASN1::Debug if $AUTOLOAD =~ /dump/;
+ goto &{$AUTOLOAD} if defined &{$AUTOLOAD};
+ require Carp;
+ my $pkg = ref($_[0]) || ($_[0] =~ /^[\w\d]+(?:::[\w\d]+)*$/)[0];
+ if ($pkg and UNIVERSAL::isa($pkg, __PACKAGE__)) { # guess it was a method call
+ $AUTOLOAD =~ s/.*:://;
+ Carp::croak(sprintf q{Can't locate object method "%s" via package "%s"},$AUTOLOAD,$pkg);
+ }
+ else {
+ Carp::croak(sprintf q{Undefined subroutine &%s called}, $AUTOLOAD);
+ }
+}
+
+sub DESTROY {}
+
+sub error { $_[0]->{error} }
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Convert/ASN1.pod b/Master/tlpkg/tlperl.straw/lib/Convert/ASN1.pod
new file mode 100755
index 00000000000..b31395b334e
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Convert/ASN1.pod
@@ -0,0 +1,480 @@
+=head1 NAME
+
+Convert::ASN1 - ASN.1 Encode/Decode library
+
+=head1 SYNOPSYS
+
+ use Convert::ASN1;
+
+ $asn = Convert::ASN1->new;
+ $asn->prepare(q<
+
+ [APPLICATION 7] SEQUENCE {
+ int INTEGER,
+ str OCTET STRING
+ }
+
+ >);
+
+ $pdu = $asn->encode( int => 7, str => "string");
+
+ $out = $asn->decode($pdu);
+ print $out->{int}," ",$out->{str},"\n";
+
+ use Convert::ASN1 qw(:io);
+
+ $peer = asn_recv($sock,$buffer,0);
+ $nbytes = asn_read($fh, $buffer);
+ $nbytes = asn_send($sock, $buffer, $peer);
+ $nbytes = asn_send($sock, $buffer);
+ $nbytes = asn_write($fh, $buffer);
+ $buffer = asn_get($fh);
+ $yes = asn_ready($fh)
+
+=head1 DESCRIPTION
+
+Convert::ASN1 encodes and decodes ASN.1 data structures using BER/DER
+rules.
+
+=head1 METHODS
+
+=head2 new ( [OPTIONS] )
+
+Contructor, creates a new object.
+
+If given, B<OPTIONS> are the same ones as for L</"configure ( OPTIONS )"> below.
+
+=head2 error ()
+
+Returns the last error.
+
+=head2 configure ( OPTIONS )
+
+Configure options to control how Convert::ASN1 will perform various tasks.
+Options are passed as name-value pairs.
+
+=over 4
+
+=item encode
+
+Reference to a hash which contains various encode options.
+
+=item decode
+
+Reference to a hash which contains various decode options.
+
+=item encoding
+
+One of 'BER' or 'DER'. The default is 'BER'
+
+=back
+
+Encode options
+
+=over 4
+
+=item real
+
+Which encoding to use for real's. One of 'binary', 'nr1', 'nr2', 'nr3'
+
+=item time
+
+This controls how UTCTime and GeneralizedTime elements are encoded. The default
+is C<withzone>.
+
+=over 4
+
+=item utctime
+
+The value passed will be encoded without a zone, ie a UTC value.
+
+=item withzone
+
+The value will be encoded with a zone. By default it will be encoded
+using the local time offset. The offset may be set using the C<timezone>
+configure option.
+
+=item raw
+
+The value passed should already be in the correct format and will be copied
+into the PDU as-is.
+
+=back
+
+=item timezone
+
+By default UTCTime and GeneralizedTime will be encoded using the local
+time offset from UTC. This will over-ride that. It is an offset from UTC
+in seconds. This option can be overriden by passing a reference to a
+list of two values as the time value. The list should contain the time
+value and the offset from UTC in seconds.
+
+=item bigint
+
+If during encoding an value greater than 32 bits is discovered and
+is not already a big integer object, then the value will first be
+converted into a big integer object. This option controls the big
+integer class into which the objects will be blessed. The default
+is to use Math::BigInt
+
+=back
+
+Decode options
+
+=over 4
+
+=item time
+
+This controls how a UTCTime or a GeneralizedTime element will be decoded. The default
+is C<utctime>.
+
+=over 4
+
+=item utctime
+
+The value returned will be a time value as returned by the C<time> function.
+
+=item withzone
+
+The value returned will be a reference to an array of two values. The first is the
+same as with C<utctime>, the second is the timezone offset, in seconds, that was
+used in the encoding.
+
+=item raw
+
+The value returned will be the raw encoding as extracted from the PDU.
+
+=back
+
+=item bigint
+
+If during decoding any big integers are discovered (integers greater
+than 32 bits), they will be decoded into big integer objects. This option
+controls the big integer class into which the objects will be blessed.
+The default is to use Math::BigInt.
+
+=item null
+
+The value to decode ASN.1 NULL types into.
+If not set, it defaults to C<1>.
+
+=back
+
+=head2 prepare ( ASN )
+
+Compile the given ASN.1 descripton which can be passed as a string
+or as a filehandle. The syntax used is very close to ASN.1, but has
+a few differences. If the ASN decribes only one macro then encode/decode can be
+called on this object. If ASN describes more than one ASN.1 macro then C<find>
+must be called. The method returns undef on error.
+
+=head2 prepare_file ( ASNPATH )
+
+Compile the ASN.1 description to be read from the specified pathname.
+
+=head2 find ( MACRO )
+
+Find a macro from a prepared ASN.1 description. Returns an object which can
+be used for encode/decode.
+
+=head2 encode ( VARIABLES )
+
+Encode a PDU. Top-level variable are passed as name-value pairs, or as a reference
+to a hash containing them. Returns the encoded PDU, or undef on error.
+
+=head2 decode ( PDU )
+
+Decode the PDU, returns a reference to a hash containg the values for the PDU. Returns
+undef if there was an error.
+
+=head2 registeroid ( OID, HANDLER )
+
+Register a handler for all ASN.1 elements
+that are C<DEFINED BY> the given OID.
+
+B<HANDLER> must be a Convert::ASN1 object, e.g. as returned by L</"find ( MACRO )">.
+
+=head2 registertype ( NAME, OID, HANDLER )
+
+Register a handler for all ASN.1 elements named C<NAME>,
+that are C<DEFINED BY> the given OID.
+
+B<HANDLER> must be a Convert::ASN1 object, e.g. as returned by L</"find ( MACRO )">.
+
+=head1 EXPORTS
+
+As well as providing an object interface for encoding/decoding PDUs Convert::ASN1
+also provides the following functions.
+
+=head2 IO Functions
+
+=over 4
+
+=item asn_recv ( SOCK, BUFFER, FLAGS )
+
+Will read a single element from the socket SOCK into BUFFER. FLAGS may
+be MSG_PEEK as exported by C<Socket>. Returns the address of the sender,
+or undef if there was an error. Some systems do not support the return
+of the peer address when the socket is a connected socket, in these
+cases the empty string will be returned. This is the same behaviour
+as the C<recv> function in perl itself.
+
+It is recommended that if the socket is of type SOCK_DGRAM then C<recv>
+be called directly instead of calling C<asn_recv>.
+
+=item asn_read ( FH, BUFFER, OFFSET )
+
+=item asn_read ( FH, BUFFER )
+
+Will read a single element from the filehandle FH into BUFFER. Returns the
+number of bytes read if a complete element was read, -1 if an incomplete
+element was read or undef if there was an error. If OFFSET is specified
+then it is assumed that BUFFER already contains an incomplete element
+and new data will be appended starting at OFFSET.
+
+If FH is a socket the asn_recv is used to read the element, so the same
+restiction applies if FH is a socket of type SOCK_DGRAM.
+
+=item asn_send ( SOCK, BUFFER, FLAGS, TO )
+
+=item asn_send ( SOCK, BUFFER, FLAGS )
+
+Identical to calling C<send>, see L<perlfunc>
+
+=item asn_write ( FH, BUFFER )
+
+Identical to calling C<syswrite> with 2 arguments, see L<perlfunc>
+
+=item asn_get ( FH )
+
+C<asn_get> provides buffered IO. Because it needs a buffer FH must be a GLOB
+or a reference to a GLOB. C<asn_get> will use two entries in the hash element
+of the GLOB to use as its buffer:
+
+ asn_buffer - input buffer
+ asn_need - number of bytes needed for the next element, if known
+
+Returns an element or undef if there was an error.
+
+=item asn_ready ( FH )
+
+C<asn_ready> works with C<asn_get>. It will return true if C<asn_get> has already
+read enough data into the buffer to return a complete element.
+
+=back
+
+=head2 Encode/Decode Functions
+
+=over 4
+
+=item asn_tag ( CLASS, VALUE )
+
+Given B<CLASS> and a B<VALUE>, calculate an integer which when encoded
+will become the tag.
+
+=item asn_decode_tag ( TAG )
+
+Decode the given ASN.1 encoded C<TAG>.
+
+=item asn_encode_tag ( TAG )
+
+Encode B<TAG> value for encoding.
+We assume that the tag has been correctly generated with L</"asn_tag ( CLASS, VALUE )">.
+
+=item asn_decode_length ( LEN )
+
+Decode the given ASN.1 decoded C<LEN>.
+
+=item asn_encode_length ( LEN )
+
+Encode the given C<LEN> to its ASN.1 encoding.
+
+=back
+
+=head2 Constants
+
+=over 4
+
+=item ASN_BIT_STR
+
+=item ASN_BOOLEAN
+
+=item ASN_ENUMERATED
+
+=item ASN_GENERAL_TIME
+
+=item ASN_IA5_STR
+
+=item ASN_INTEGER
+
+=item ASN_NULL
+
+=item ASN_OBJECT_ID
+
+=item ASN_OCTET_STR
+
+=item ASN_PRINT_STR
+
+=item ASN_REAL
+
+=item ASN_SEQUENCE
+
+=item ASN_SET
+
+=item ASN_UTC_TIME
+
+=item ASN_APPLICATION
+
+=item ASN_CONTEXT
+
+=item ASN_PRIVATE
+
+=item ASN_UNIVERSAL
+
+=item ASN_PRIMITIVE
+
+=item ASN_CONSTRUCTOR
+
+=item ASN_LONG_LEN
+
+=item ASN_EXTENSION_ID
+
+=item ASN_BIT
+
+=back
+
+=head2 Debug Functions
+
+=over 4
+
+=item asn_dump ( [FH,] BUFFER )
+
+Try to decode the given buffer as ASN.1 structure and dump it to the
+given file handle, or C<STDERR> if the handle is not given.
+
+=item asn_hexdump ( FH, BUFFER )
+
+=back
+
+=head1 EXPORT TAGS
+
+=over 4
+
+=item :all
+
+All exported functions
+
+=item :const
+
+ASN_BOOLEAN, ASN_INTEGER, ASN_BIT_STR, ASN_OCTET_STR,
+ASN_NULL, ASN_OBJECT_ID, ASN_REAL, ASN_ENUMERATED,
+ASN_SEQUENCE, ASN_SET, ASN_PRINT_STR, ASN_IA5_STR,
+ASN_UTC_TIME, ASN_GENERAL_TIME,
+ASN_UNIVERSAL, ASN_APPLICATION, ASN_CONTEXT, ASN_PRIVATE,
+ASN_PRIMITIVE, ASN_CONSTRUCTOR, ASN_LONG_LEN, ASN_EXTENSION_ID, ASN_BIT
+
+=item :debug
+
+asn_dump, asn_hexdump
+
+=item :io
+
+asn_recv, asn_send, asn_read, asn_write, asn_get, asn_ready
+
+=item :tag
+
+asn_tag, asn_decode_tag, asn_encode_tag, asn_decode_length, asn_encode_length
+
+=back
+
+=head1 MAPPING ASN.1 TO PERL
+
+Every element in the ASN.1 definition has a name, in perl a hash is used
+with these names as an index and the element value as the hash value.
+
+ # ASN.1
+ int INTEGER,
+ str OCTET STRING
+
+ # Perl
+ { int => 5, str => "text" }
+
+
+In the case of a SEQUENCE, SET or CHOICE then the value in the namespace will
+be a hash reference which will be the namespce for the elements with
+that element.
+
+ # ASN.1
+ int INTEGER,
+ seq SEQUENCE {
+ str OCTET STRING,
+ bool BOOLEAN
+ }
+
+ # Perl
+ { int => 5, seq => { str => "text", bool => 1}}
+
+If the element is a SEQUENCE OF, or SET OF, then the value in the namespace
+will be an array reference. The elements in the array will be of
+the type expected by the type following the OF. For example
+with "SEQUENCE OF STRING" the array would contain strings. With
+"SEQUENCE OF SEQUENCE { ... }" the array will contain hash references
+which will be used as namespaces
+
+ # ASN.1
+ int INTEGER,
+ str SEQUENCE OF OCTET STRING
+
+ # Perl
+ { int => 5, str => [ "text1", "text2"]}
+
+ # ASN.1
+ int INTEGER,
+ str SEQUENCE OF SEQUENCE {
+ type OCTET STRING,
+ value INTEGER
+ }
+
+ # Perl
+ { int => 5, str => [
+ { type => "abc", value => 4 },
+ { type => "def", value => -1 },
+ ]}
+
+=head2 Exceptions
+
+There are some exceptions where Convert::ASN1 does not require an element to be named.
+These are SEQUENCE {...}, SET {...} and CHOICE. In each case if the element is not
+given a name then the elements inside the {...} will share the same namespace as
+the elements outside of the {...}.
+
+=head1 TODO
+
+=over 4
+
+=item *
+
+XS implementation.
+
+=item *
+
+More documentation.
+
+=item *
+
+More tests.
+
+=back
+
+=head1 AUTHOR
+
+Graham Barr <gbarr@pobox.com>, Report bugs via <bug-Convert-ASN1@rt.cpan.org>
+
+=head1 COPYRIGHT
+
+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.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl.straw/lib/Convert/ASN1/Debug.pm b/Master/tlpkg/tlperl.straw/lib/Convert/ASN1/Debug.pm
new file mode 100755
index 00000000000..b9af2568a71
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/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/tlperl.straw/lib/Convert/ASN1/IO.pm b/Master/tlpkg/tlperl.straw/lib/Convert/ASN1/IO.pm
new file mode 100755
index 00000000000..e3dac3ee850
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/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/tlperl.straw/lib/Convert/ASN1/_decode.pm b/Master/tlpkg/tlperl.straw/lib/Convert/ASN1/_decode.pm
new file mode 100755
index 00000000000..944dd00e84d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/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/tlperl.straw/lib/Convert/ASN1/_encode.pm b/Master/tlpkg/tlperl.straw/lib/Convert/ASN1/_encode.pm
new file mode 100755
index 00000000000..7aba3cd1b16
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/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/tlperl.straw/lib/Convert/ASN1/parser.pm b/Master/tlpkg/tlperl.straw/lib/Convert/ASN1/parser.pm
new file mode 100755
index 00000000000..36d07c53004
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/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;
diff --git a/Master/tlpkg/tlperl.straw/lib/Convert/PEM.pm b/Master/tlpkg/tlperl.straw/lib/Convert/PEM.pm
new file mode 100755
index 00000000000..f6668bf3d87
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Convert/PEM.pm
@@ -0,0 +1,472 @@
+# $Id: PEM.pm 1829 2005-05-25 21:51:40Z btrott $
+
+package Convert::PEM;
+use strict;
+use base qw( Class::ErrorHandler );
+
+use MIME::Base64;
+use Digest::MD5 qw( md5 );
+use Convert::ASN1;
+use Carp qw( croak );
+use Convert::PEM::CBC;
+
+use vars qw( $VERSION );
+$VERSION = '0.07';
+
+sub new {
+ my $class = shift;
+ my $pem = bless { }, $class;
+ $pem->init(@_);
+}
+
+sub init {
+ my $pem = shift;
+ my %param = @_;
+ unless (exists $param{ASN} && exists $param{Name}) {
+ return (ref $pem)->error("init: Name and ASN are required");
+ }
+ else {
+ $pem->{ASN} = $param{ASN};
+ $pem->{Name} = $param{Name};
+ }
+ $pem->{Macro} = $param{Macro};
+ my $asn = $pem->{_asn} = Convert::ASN1->new;
+ $asn->prepare( $pem->{ASN} ) or
+ return (ref $pem)->error("ASN prepare failed: $asn->{error}");
+ $pem;
+}
+
+sub asn { $_[0]->{_asn} }
+sub ASN { $_[0]->{ASN} }
+sub name { $_[0]->{Name} }
+
+sub read {
+ my $pem = shift;
+ my %param = @_;
+
+ my $blob;
+ local *FH;
+ my $fname = delete $param{Filename};
+ open FH, $fname or
+ return $pem->error("Can't open $fname: $!");
+ $blob = do { local $/; <FH> };
+ close FH;
+
+ $param{Content} = $blob;
+ $pem->decode(%param);
+}
+
+sub write {
+ my $pem = shift;
+ my %param = @_;
+
+ my $fname = delete $param{Filename} or
+ return $pem->error("write: Filename is required");
+ my $blob = $pem->encode(%param);
+
+ local *FH;
+ open FH, ">$fname" or
+ return $pem->error("Can't open $fname: $!");
+ print FH $blob;
+ close FH;
+ $blob;
+}
+
+sub decode {
+ my $pem = shift;
+ my %param = @_;
+ my $blob = $param{Content} or
+ return $pem->error("'Content' is required");
+ chomp $blob;
+
+ my $dec = $pem->explode($blob) or return;
+ my $name = $param{Name} || $pem->name;
+ return $pem->error("Object $dec->{Object} does not match " . $name)
+ unless $dec->{Object} eq $name;
+
+ my $head = $dec->{Headers};
+ my $buf = $dec->{Content};
+ my %headers = map { $_->[0] => $_->[1] } @$head;
+ if (%headers && $headers{'Proc-Type'} eq '4,ENCRYPTED') {
+ $buf = $pem->decrypt( Ciphertext => $buf,
+ Info => $headers{'DEK-Info'},
+ Password => $param{Password} )
+ or return;
+ }
+
+ my $asn = $pem->asn;
+ if (my $macro = ($param{Macro} || $pem->{Macro})) {
+ $asn = $asn->find($macro) or
+ return $pem->error("Can't find Macro $macro");
+ }
+ my $obj = $asn->decode($buf) or
+ return $pem->error("ASN decode failed: $asn->{error}");
+
+ $obj;
+}
+
+sub encode {
+ my $pem = shift;
+ my %param = @_;
+
+ my $asn = $pem->asn;
+ if (my $macro = ($param{Macro} || $pem->{Macro})) {
+ $asn = $asn->find($macro) or
+ return $pem->error("Can't find Macro $macro");
+ }
+ my $buf = $asn->encode( $param{Content} ) or
+ return $pem->error("ASN encode failed: $asn->{error}");
+
+ my(@headers);
+ if ($param{Password}) {
+ my($info);
+ ($buf, $info) = $pem->encrypt( Plaintext => $buf,
+ Password => $param{Password} )
+ or return;
+ push @headers, [ 'Proc-Type' => '4,ENCRYPTED' ];
+ push @headers, [ 'DEK-Info' => $info ];
+ }
+
+ $pem->implode( Object => $param{Name} || $pem->name,
+ Headers => \@headers,
+ Content => $buf );
+}
+
+sub explode {
+ my $pem = shift;
+ my($message) = @_;
+ my($head, $object, $headers, $content, $tail) = $message =~
+ m:(-----BEGIN ([^\n\-]+)-----)\n(.*?\n\n)?(.+)(-----END .*?-----)$:s;
+ my $buf = decode_base64($content);
+
+ my @headers;
+ if ($headers) {
+ for my $h ( split /\n/, $headers ) {
+ my($k, $v) = split /:\s*/, $h, 2;
+ push @headers, [ $k => $v ] if $k;
+ }
+ }
+
+ { Content => $buf,
+ Object => $object,
+ Headers => \@headers }
+}
+
+sub implode {
+ my $pem = shift;
+ my %param = @_;
+ my $head = "-----BEGIN $param{Object}-----";
+ my $tail = "-----END $param{Object}-----";
+ my $content = encode_base64( $param{Content}, '' );
+ $content =~ s!(.{1,64})!$1\n!g;
+ my $headers = join '',
+ map { "$_->[0]: $_->[1]\n" }
+ @{ $param{Headers} };
+ $headers .= "\n" if $headers;
+ "$head\n$headers$content$tail\n";
+}
+
+use vars qw( %CTYPES );
+%CTYPES = ('DES-EDE3-CBC' => 'Crypt::DES_EDE3');
+
+sub decrypt {
+ my $pem = shift;
+ my %param = @_;
+ my $passphrase = $param{Password} || "";
+ my($ctype, $iv) = split /,/, $param{Info};
+ my $cmod = $CTYPES{$ctype} or
+ return $pem->error("Unrecognized cipher: '$ctype'");
+ $iv = pack "H*", $iv;
+ my $cbc = Convert::PEM::CBC->new(
+ Passphrase => $passphrase,
+ Cipher => $cmod,
+ IV => $iv );
+ my $buf = $cbc->decrypt($param{Ciphertext}) or
+ return $pem->error("Decryption failed: " . $cbc->errstr);
+ $buf;
+}
+
+sub encrypt {
+ my $pem = shift;
+ my %param = @_;
+ $param{Password} or return $param{Plaintext};
+ my $ctype = $param{Cipher} || 'DES-EDE3-CBC';
+ my $cmod = $CTYPES{$ctype} or
+ return $pem->error("Unrecognized cipher: '$ctype'");
+ my $cbc = Convert::PEM::CBC->new(
+ Passphrase => $param{Password},
+ Cipher => $cmod );
+ my $iv = uc join '', unpack "H*", $cbc->iv;
+ my $buf = $cbc->encrypt($param{Plaintext}) or
+ return $pem->error("Encryption failed: " . $cbc->errstr);
+ ($buf, "$ctype,$iv");
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Convert::PEM - Read/write encrypted ASN.1 PEM files
+
+=head1 SYNOPSIS
+
+ use Convert::PEM;
+ my $pem = Convert::PEM->new(
+ Name => "DSA PRIVATE KEY",
+ ASN => qq(
+ DSAPrivateKey SEQUENCE {
+ version INTEGER,
+ p INTEGER,
+ q INTEGER,
+ g INTEGER,
+ pub_key INTEGER,
+ priv_key INTEGER
+ }
+ ));
+
+ my $pkey = $pem->read(
+ Filename => $keyfile,
+ Password => $pwd
+ );
+
+ $pem->write(
+ Content => $pkey,
+ Password => $pwd,
+ Filename => $keyfile
+ );
+
+=head1 DESCRIPTION
+
+I<Convert::PEM> reads and writes PEM files containing ASN.1-encoded
+objects. The files can optionally be encrypted using a symmetric
+cipher algorithm, such as 3DES. An unencrypted PEM file might look
+something like this:
+
+ -----BEGIN DH PARAMETERS-----
+ MB4CGQDUoLoCULb9LsYm5+/WN992xxbiLQlEuIsCAQM=
+ -----END DH PARAMETERS-----
+
+The string beginning C<MB4C...> is the Base64-encoded, ASN.1-encoded
+"object."
+
+An encrypted file would have headers describing the type of
+encryption used, and the initialization vector:
+
+ -----BEGIN DH PARAMETERS-----
+ Proc-Type: 4,ENCRYPTED
+ DEK-Info: DES-EDE3-CBC,C814158661DC1449
+
+ AFAZFbnQNrGjZJ/ZemdVSoZa3HWujxZuvBHzHNoesxeyqqidFvnydA==
+ -----END DH PARAMETERS-----
+
+The two headers (C<Proc-Type> and C<DEK-Info>) indicate information
+about the type of encryption used, and the string starting with
+C<AFAZ...> is the Base64-encoded, encrypted, ASN.1-encoded
+contents of this "object."
+
+The initialization vector (C<C814158661DC1449>) is chosen randomly.
+
+=head1 USAGE
+
+=head2 $pem = Convert::PEM->new( %arg )
+
+Constructs a new I<Convert::PEM> object designed to read/write an
+object of a specific type (given in I<%arg>, see below). Returns the
+new object on success, C<undef> on failure (see I<ERROR HANDLING> for
+details).
+
+I<%arg> can contain:
+
+=over 4
+
+=item * Name
+
+The name of the object; when decoding a PEM-encoded stream, the name
+in the encoding will be checked against the value of I<Name>.
+Similarly, when encoding an object, the value of I<Name> will be used
+as the name of the object in the PEM-encoded content. For example, given
+the string C<FOO BAR>, the output from I<encode> will start with a
+header like:
+
+ -----BEGIN FOO BAR-----
+
+I<Name> is a required argument.
+
+=item * ASN
+
+An ASN.1 description of the content to be either encoded or decoded.
+
+I<ASN> is a required argument.
+
+=item * Macro
+
+If your ASN.1 description (in the I<ASN> parameter) includes more than
+one ASN.1 macro definition, you will want to use the I<Macro> parameter
+to specify which definition to use when encoding/decoding objects.
+For example, if your ASN.1 description looks like this:
+
+ Foo ::= SEQUENCE {
+ x INTEGER,
+ bar Bar
+ }
+
+ Bar ::= INTEGER
+
+If you want to encode/decode a C<Foo> object, you will need to tell
+I<Convert::PEM> to use the C<Foo> macro definition by using the I<Macro>
+parameter and setting the value to C<Foo>.
+
+I<Macro> is an optional argument.
+
+=back
+
+=head2 $obj = $pem->decode(%args)
+
+Decodes, and, optionally, decrypts a PEM file, returning the
+object as decoded by I<Convert::ASN1>. The difference between this
+method and I<read> is that I<read> reads the contents of a PEM file
+on disk; this method expects you to pass the PEM contents as an
+argument.
+
+If an error occurs while reading the file or decrypting/decoding
+the contents, the function returns I<undef>, and you should check
+the error message using the I<errstr> method (below).
+
+I<%args> can contain:
+
+=over 4
+
+=item * Content
+
+The PEM contents.
+
+=item * Password
+
+The password with which the file contents were encrypted.
+
+If the file is encrypted, this is a mandatory argument (well, it's
+not strictly mandatory, but decryption isn't going to work without
+it). Otherwise it's not necessary.
+
+=back
+
+=head2 $blob = $pem->encode(%args)
+
+Constructs the contents for the PEM file from an object: ASN.1-encodes
+the object, optionally encrypts those contents.
+
+Returns I<undef> on failure (encryption failure, file-writing failure,
+etc.); in this case you should check the error message using the
+I<errstr> method (below). On success returns the constructed PEM string.
+
+I<%args> can contain:
+
+=over 4
+
+=item * Content
+
+A hash reference that will be passed to I<Convert::ASN1::encode>,
+and which should correspond to the ASN.1 description you gave to the
+I<new> method. The hash reference should have the exact same format
+as that returned from the I<read> method.
+
+This argument is mandatory.
+
+=item * Password
+
+A password used to encrypt the contents of the PEM file. This is an
+optional argument; if not provided the contents will be unencrypted.
+
+=back
+
+=head2 $obj = $pem->read(%args)
+
+Reads, decodes, and, optionally, decrypts a PEM file, returning
+the object as decoded by I<Convert::ASN1>. This is implemented
+as a wrapper around I<decode>, with the bonus of reading the PEM
+file from disk for you.
+
+If an error occurs while reading the file or decrypting/decoding
+the contents, the function returns I<undef>, and you should check
+the error message using the I<errstr> method (below).
+
+In addition to the arguments that can be passed to the I<decode>
+method (minus the I<Content> method), I<%args> can contain:
+
+=over 4
+
+=item * Filename
+
+The location of the PEM file that you wish to read.
+
+=back
+
+=head2 $pem->write(%args)
+
+Constructs the contents for the PEM file from an object: ASN.1-encodes
+the object, optionally encrypts those contents; then writes the file
+to disk. This is implemented as a wrapper around I<encode>, with the
+bonus of writing the file to disk for you.
+
+Returns I<undef> on failure (encryption failure, file-writing failure,
+etc.); in this case you should check the error message using the
+I<errstr> method (below). On success returns the constructed PEM string.
+
+In addition to the arguments for I<encode>, I<%args> can contain:
+
+=over 4
+
+=item * Filename
+
+The location on disk where you'd like the PEM file written.
+
+=back
+
+=head2 $pem->errstr
+
+Returns the value of the last error that occurred. This should only
+be considered meaningful when you've received I<undef> from one of
+the functions above; in all other cases its relevance is undefined.
+
+=head2 $pem->asn
+
+Returns the I<Convert::ASN1> object used internally to decode and
+encode ASN.1 representations. This is useful when you wish to
+interact directly with that object; for example, if you need to
+call I<configure> on that object to set the type of big-integer
+class to be used when decoding/encoding big integers:
+
+ $pem->asn->configure( decode => { bigint => 'Math::Pari' },
+ encode => { bigint => 'Math::Pari' } );
+
+=head1 ERROR HANDLING
+
+If an error occurs in any of the above methods, the method will return
+C<undef>. You should then call the method I<errstr> to determine the
+source of the error:
+
+ $pem->errstr
+
+In the case that you do not yet have a I<Convert::PEM> object (that is,
+if an error occurs while creating a I<Convert::PEM> object), the error
+can be obtained as a class method:
+
+ Convert::PEM->errstr
+
+For example, if you try to decode an encrypted object, and you do not
+give a passphrase to decrypt the object:
+
+ my $obj = $pem->read( Filename => "encrypted.pem" )
+ or die "Decryption failed: ", $pem->errstr;
+
+=head1 AUTHOR & COPYRIGHTS
+
+Benjamin Trott, ben@rhumba.pair.com
+
+Except where otherwise noted, Convert::PEM is Copyright 2001
+Benjamin Trott. All rights reserved. Convert::PEM is free
+software; you may redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/Convert/PEM/CBC.pm b/Master/tlpkg/tlperl.straw/lib/Convert/PEM/CBC.pm
new file mode 100755
index 00000000000..971a272151a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Convert/PEM/CBC.pm
@@ -0,0 +1,227 @@
+# $Id: CBC.pm 1829 2005-05-25 21:51:40Z btrott $
+
+package Convert::PEM::CBC;
+use strict;
+
+use Carp qw( croak );
+use Digest::MD5 qw( md5 );
+use base qw( Class::ErrorHandler );
+
+sub new {
+ my $class = shift;
+ my $cbc = bless { }, $class;
+ $cbc->init(@_);
+}
+
+sub init {
+ my $cbc = shift;
+ my %param = @_;
+ $cbc->{iv} = exists $param{IV} ? $param{IV} :
+ pack("C*", map { rand 255 } 1..8);
+ croak "init: Cipher is required"
+ unless my $cipher = $param{Cipher};
+ if (ref($cipher)) {
+ $cbc->{cipher} = $cipher;
+ }
+ else {
+ eval "use $cipher;";
+ croak "Loading '$cipher' failed: $@" if $@;
+ my $key = $param{Key};
+ if (!$key && exists $param{Passphrase}) {
+ $key = bytes_to_key($param{Passphrase}, $cbc->{iv},
+ \&md5, $cipher->keysize);
+ }
+ croak "init: either Key or Passphrase required"
+ unless $key;
+ $cbc->{cipher} = $cipher->new($key);
+ }
+ $cbc;
+}
+
+sub iv { $_[0]->{iv} }
+
+sub encrypt {
+ my $cbc = shift;
+ my($text) = @_;
+ my $cipher = $cbc->{cipher};
+ my $bs = $cipher->blocksize;
+ my @blocks = $text =~ /(.{1,$bs})/ogs;
+ my $last = pop @blocks if length($blocks[-1]) < $bs;
+ my $iv = $cbc->{iv};
+ my $buf = '';
+ for my $block (@blocks) {
+ $buf .= $iv = $cipher->encrypt($iv ^ $block);
+ }
+ $last = pack("C*", ($bs) x $bs) unless $last && length $last;
+ if (length $last) {
+ $last .= pack("C*", ($bs-length($last)) x ($bs-length($last)))
+ if length($last) < $bs;
+ $buf .= $iv = $cipher->encrypt($iv ^ $last);
+ }
+ $cbc->{iv} = $iv;
+ $buf;
+}
+
+sub decrypt {
+ my $cbc = shift;
+ my($text) = @_;
+ my $cipher = $cbc->{cipher};
+ my $bs = $cipher->blocksize;
+ my @blocks = $text =~ /(.{1,$bs})/ogs;
+ my $last = length($blocks[-1]) < $bs ?
+ join '', splice(@blocks, -2) : pop @blocks;
+ my $iv = $cbc->{iv};
+ my $buf = '';
+ for my $block (@blocks) {
+ $buf .= $iv ^ $cipher->decrypt($block);
+ $iv = $block;
+ }
+ $last = pack "a$bs", $last;
+ if (length($last)) {
+ my $tmp = $iv ^ $cipher->decrypt($last);
+ $iv = $last;
+ $last = $tmp;
+ my $cut = ord substr $last, -1;
+ return $cbc->error("Bad key/passphrase")
+ if $cut > $bs;
+ substr($last, -$cut) = '';
+ $buf .= $last;
+ }
+ $cbc->{iv} = $iv;
+ $buf;
+}
+
+sub bytes_to_key {
+ my($key, $salt, $md, $ks) = @_;
+ my $ckey = $md->($key, $salt);
+ while (length($ckey) < $ks) {
+ $ckey .= $md->($ckey, $key, $salt);
+ }
+ substr $ckey, 0, $ks;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Convert::PEM::CBC - Cipher Block Chaining Mode implementation
+
+=head1 SYNOPSIS
+
+ use Convert::PEM::CBC;
+ my $cbc = Convert::PEM::CBC->new(
+ Cipher => 'Crypt::DES_EDE3',
+ Passphrase => 'foo'
+ );
+
+ $cbc->encrypt($plaintext);
+
+=head1 DESCRIPTION
+
+I<Convert::PEM::CBC> implements the CBC (Cipher Block Chaining)
+mode for encryption/decryption ciphers; the CBC is designed for
+compatability with OpenSSL and may not be compatible with other
+implementations (such as SSH).
+
+=head1 USAGE
+
+=head2 $cbc = Convert::PEM::CBC->new(%args)
+
+Creates a new I<Convert::PEM::CBC> object and initializes it.
+Returns the new object.
+
+I<%args> can contain:
+
+=over 4
+
+=item * Cipher
+
+Either the name of an encryption cipher class (eg. I<Crypt::DES>),
+or an object already blessed into such a class. The class must
+support the I<keysize>, I<blocksize>, I<encrypt>, and I<decrypt>
+methods. If the value is a blessed object, it is assumed that the
+object has already been initialized with a key.
+
+This argument is mandatory.
+
+=item * Passphrase
+
+A passphrase to encrypt/decrypt the content. This is different in
+implementation from a key (I<Key>), because it is assumed that a
+passphrase comes directly from a user, and must be munged into the
+correct form for a key. This "munging" is done by repeatedly
+computing an MD5 hash of the passphrase, the IV, and the existing
+hash, until the generated key is longer than the keysize for the
+cipher (I<Cipher>).
+
+Because of this "munging", this argument can be any length (even
+an empty string).
+
+If you give the I<Cipher> argument an object, this argument is
+ignored. If the I<Cipher> argument is a cipher class, either this
+argument or I<Key> must be provided.
+
+=item * Key
+
+A raw key, to be passed directly to the new cipher object. Because
+this is passed directly to the cipher itself, the length of the
+key must be equal to or greater than the keysize for the I<Cipher>.
+
+As with the I<Passphrase> argument, if you give the I<Cipher>
+argument an already-constructed cipher object, this argument is
+ignored. If the I<Cipher> argument is a cipher class, either this
+argument or I<Passphrase> must be provided.
+
+=item * IV
+
+The initialization vector for CBC mode.
+
+This argument is optional; if not provided, a random IV will be
+generated. Obviously, if you're decrypting data, you should provide
+this argument, because your IV should match the IV used to encrypt
+the data.
+
+=back
+
+=head2 $cbc->encrypt($plaintext)
+
+Encrypts the plaintext I<$plaintext> using the underlying cipher
+implementation in CBC mode, and returns the ciphertext.
+
+If any errors occur, returns I<undef>, and you should check the
+I<errstr> method to find out what went wrong.
+
+=head2 $cbc->decrypt($ciphertext)
+
+Decrypts the ciphertext I<$ciphertext> using the underlying
+cipher implementation in CBC mode, and returns the plaintext.
+
+If any errors occur, returns I<undef>, and you should check the
+I<errstr> method to find out what went wrong.
+
+=head2 $cbc->iv
+
+Returns the current initialization vector. One use for this might be
+to grab the initial value of the IV if it's created randomly (ie.
+you haven't provided an I<IV> argument to I<new>):
+
+ my $cbc = Convert::PEM::CBC->new( Cipher => $cipher );
+ my $iv = $cbc->iv; ## Generated randomly in 'new'.
+
+I<Convert::PEM> uses this to write the IV to the PEM file when
+encrypting, so that it can be known when trying to decrypt the
+file.
+
+=head2 $cbc->errstr
+
+Returns the value of the last error that occurred. This should only
+be considered meaningful when you've received I<undef> from one of
+the functions above; in all other cases its relevance is undefined.
+
+=head1 AUTHOR & COPYRIGHTS
+
+Please see the Convert::PEM manpage for author, copyright, and
+license information.
+
+=cut