diff options
Diffstat (limited to 'Master/tlpkg/tlperl.straw/lib/Convert')
-rwxr-xr-x | Master/tlpkg/tlperl.straw/lib/Convert/ASCII/Armor.pm | 37 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl.straw/lib/Convert/ASCII/Armour.pm | 247 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl.straw/lib/Convert/ASN1.pm | 444 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl.straw/lib/Convert/ASN1.pod | 480 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl.straw/lib/Convert/ASN1/Debug.pm | 226 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl.straw/lib/Convert/ASN1/IO.pm | 261 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl.straw/lib/Convert/ASN1/_decode.pm | 675 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl.straw/lib/Convert/ASN1/_encode.pm | 406 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl.straw/lib/Convert/ASN1/parser.pm | 916 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl.straw/lib/Convert/PEM.pm | 472 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl.straw/lib/Convert/PEM/CBC.pm | 227 |
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 |