Added Net::LDAP to the distribution for easier installs.
This commit is contained in:
JT Smith
parent
f51b335d74
commit
223c014813
47 changed files with 15060 additions and 2 deletions
372
lib/Convert/ASN1.pm
Normal file
372
lib/Convert/ASN1.pm
Normal file
|
|
@ -0,0 +1,372 @@
|
|||
# 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$
|
||||
|
||||
use 5.004;
|
||||
use strict;
|
||||
use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS @opParts @opName $AUTOLOAD);
|
||||
use Exporter;
|
||||
|
||||
BEGIN {
|
||||
@ISA = qw(Exporter);
|
||||
$VERSION = '0.15';
|
||||
|
||||
%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
|
||||
);
|
||||
|
||||
@opName = qw(
|
||||
opUNKNOWN opBOOLEAN opINTEGER opBITSTR opSTRING opNULL opOBJID opREAL
|
||||
opSEQUENCE opSET opUTIME opGTIME opUTF8 opANY opCHOICE opROID
|
||||
);
|
||||
|
||||
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 = @_;
|
||||
|
||||
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 = Convert::ASN1::parser::parse($asn);
|
||||
|
||||
unless ($tree) {
|
||||
$self->{error} = $@;
|
||||
return;
|
||||
}
|
||||
|
||||
$self->{tree} = _pack_struct($tree);
|
||||
$self->{script} = (values %$tree)[0];
|
||||
$self;
|
||||
}
|
||||
|
||||
# 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 correclty 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;
|
||||
my $stash = {};
|
||||
|
||||
local $SIG{__DIE__};
|
||||
eval { _decode($self->{options}, $self->{script}, $stash, 0, length $_[0], undef, [], $_[0]); $stash }
|
||||
or do {
|
||||
$self->{'error'} = $@;
|
||||
undef;
|
||||
};
|
||||
}
|
||||
|
||||
|
||||
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;
|
||||
443
lib/Convert/ASN1.pod
Normal file
443
lib/Convert/ASN1.pod
Normal file
|
|
@ -0,0 +1,443 @@
|
|||
=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
|
||||
|
||||
Contructor, creates a new object.
|
||||
|
||||
=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', 'der', 'per'. I<Currently not used>
|
||||
|
||||
=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.
|
||||
|
||||
=back
|
||||
|
||||
=head2 prepare ( ASN )
|
||||
|
||||
Compile the given ASN.1 descripton. The syntax used is very close to ASN.1, but has
|
||||
a few differnces. 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.
|
||||
|
||||
=head2 find ( MACRO )
|
||||
|
||||
Find a macro froma 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.
|
||||
|
||||
=head1 EXPORTS
|
||||
|
||||
As well as providing an object interface for encoding/decoding PDUs Convert::ASN1
|
||||
also provides the follow 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 reccomended 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 it's 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
|
||||
|
||||
=item asn_decode_tag
|
||||
|
||||
=item asn_encode_tag
|
||||
|
||||
=item asn_decode_length
|
||||
|
||||
=item asn_encode_length
|
||||
|
||||
=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
|
||||
|
||||
=item asn_hexdump
|
||||
|
||||
=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_dumphex
|
||||
|
||||
=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 *
|
||||
|
||||
Indefinite length encoding
|
||||
|
||||
=item *
|
||||
|
||||
XS implementation.
|
||||
|
||||
=item *
|
||||
|
||||
More documentation.
|
||||
|
||||
=item *
|
||||
|
||||
More tests.
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Graham Barr <gbarr@pobox.xom>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
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.
|
||||
|
||||
=cut
|
||||
|
||||
228
lib/Convert/ASN1/Debug.pm
Normal file
228
lib/Convert/ASN1/Debug.pm
Normal file
|
|
@ -0,0 +1,228 @@
|
|||
# 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$
|
||||
|
||||
##
|
||||
## 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[opTYPE] = $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;
|
||||
|
||||
261
lib/Convert/ASN1/IO.pm
Normal file
261
lib/Convert/ASN1/IO.pm
Normal file
|
|
@ -0,0 +1,261 @@
|
|||
# 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$
|
||||
|
||||
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
|
||||
|
||||
my $pos = 0;
|
||||
my $need = 0;
|
||||
if ($_[2]) {
|
||||
if ($_[2] > length $_[1]) {
|
||||
require Carp;
|
||||
Carp::carp("Offset beyond end of buffer");
|
||||
return;
|
||||
}
|
||||
substr($_[1],$_[2]) = '';
|
||||
}
|
||||
else {
|
||||
$_[1] = '';
|
||||
}
|
||||
my $depth = 0;
|
||||
my $ch;
|
||||
my $n;
|
||||
|
||||
while(($n = $need - length $_[1]) > 0) {
|
||||
sysread($_[0],$_[1],$n,length $_[1]) or
|
||||
goto READ_ERR;
|
||||
}
|
||||
|
||||
while(1) {
|
||||
$need = $pos + 2;
|
||||
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) {
|
||||
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) {
|
||||
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) {
|
||||
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;
|
||||
}
|
||||
|
||||
$need = $pos + 2*$depth;
|
||||
|
||||
while(($n = $need - length $_[1]) > 0) {
|
||||
sysread($_[0],$_[1],$n,length $_[1]) or
|
||||
goto READ_ERR;
|
||||
}
|
||||
last unless $depth;
|
||||
}
|
||||
|
||||
return length $_[1];
|
||||
|
||||
READ_ERR:
|
||||
$@ = "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;
|
||||
613
lib/Convert/ASN1/_decode.pm
Normal file
613
lib/Convert/ASN1/_decode.pm
Normal file
|
|
@ -0,0 +1,613 @@
|
|||
# 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$
|
||||
|
||||
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,
|
||||
);
|
||||
|
||||
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} : 1),
|
||||
$buf,$npos,$len, $indef ? $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),
|
||||
$indef ? $larr : [],
|
||||
$buf,
|
||||
);
|
||||
|
||||
($seqof ? $seqof->[$idx++] : defined($var) ? $stash->{$var} : undef)
|
||||
= &{$ctr}(@ctrlist);
|
||||
$pos = $npos+$len+$indef;
|
||||
|
||||
redo TAGLOOP if $seqof && $pos < $end;
|
||||
next OP;
|
||||
|
||||
}
|
||||
|
||||
if ($seqof || defined $op->[cOPT]) {
|
||||
unshift @$larr, $len if $indef;
|
||||
next OP;
|
||||
}
|
||||
|
||||
die "decode error " . unpack("H*",$tag) ."<=>" . unpack("H*",$op->[cTAG]);
|
||||
}
|
||||
}
|
||||
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;
|
||||
|
||||
($seqof ? $seqof->[$idx++] : $stash->{$var})
|
||||
= 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}={}) : $stash;
|
||||
|
||||
&{$decode[$cop->[cTYPE]]}(
|
||||
$optn,
|
||||
$cop,
|
||||
$nstash,
|
||||
$nstash->{$cop->[cVAR]},
|
||||
$buf,$npos,$len,$indef ? $larr : []
|
||||
);
|
||||
|
||||
$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}={}) : $stash;
|
||||
|
||||
_decode(
|
||||
$optn,
|
||||
[$cop],
|
||||
undef,
|
||||
$npos,
|
||||
$npos+$len,
|
||||
(\my @ctrlist),
|
||||
$indef ? $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] = 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]));
|
||||
splice(@data,0,1,int($data[0]/40),$data[0] % 40)
|
||||
if $_[1]->[cTYPE] == opOBJID and $data[0];
|
||||
$_[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,$indef ? $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),
|
||||
$indef ? $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,$indef ? $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),
|
||||
$indef ? $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) {
|
||||
$_[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 {
|
||||
local $SIG{__DIE__};
|
||||
eval { require bytes } and 'bytes'->unimport;
|
||||
eval { require utf8 } and 'utf8'->import;
|
||||
}
|
||||
|
||||
$_[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 (@$larr) {
|
||||
_scan_indef($_[0],$pos,$end,$larr) or return;
|
||||
}
|
||||
$indef = 2;
|
||||
$len = shift @$larr;
|
||||
}
|
||||
}
|
||||
|
||||
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];
|
||||
@$larr = ();
|
||||
my @depth = ( $pos );
|
||||
|
||||
while(@depth) {
|
||||
return if $pos+2 > $end;
|
||||
|
||||
if (substr($_[0],$pos,2) eq "\0\0") {
|
||||
my $end = $pos;
|
||||
my $start = shift @depth;
|
||||
unshift @$larr, $end-$start;
|
||||
$pos += 2;
|
||||
next;
|
||||
}
|
||||
|
||||
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) {
|
||||
if ($len &= 0x7f) {
|
||||
return if $pos+$len > $end ;
|
||||
|
||||
$pos += $len + unpack("N", "\0" x (4 - $len) . substr($_[0],$pos,$len));
|
||||
}
|
||||
else {
|
||||
unshift @depth, $pos;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$pos += $len;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
}
|
||||
|
||||
sub _ctr_string { join '', @_ }
|
||||
|
||||
sub _ctr_bitstring {
|
||||
[ join('', map { $_->[0] } @_), $_[-1]->[1] ]
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
364
lib/Convert/ASN1/_encode.pm
Normal file
364
lib/Convert/ASN1/_encode.pm
Normal file
|
|
@ -0,0 +1,364 @@
|
|||
# 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$
|
||||
|
||||
BEGIN {
|
||||
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,
|
||||
);
|
||||
|
||||
|
||||
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,
|
||||
$stash,
|
||||
defined($var) ? $stash->{$var} : undef,
|
||||
$_[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
|
||||
|
||||
if (ref($_[3])) {
|
||||
my $less = (8 - ($_[3]->[1] & 7)) & 7;
|
||||
my $len = ($_[3]->[1] + 7)/8;
|
||||
$_[4] .= asn_encode_length(1+$len);
|
||||
$_[4] .= chr($less);
|
||||
$_[4] .= substr($_[3]->[0], 0, $len);
|
||||
if ($less && $len) {
|
||||
substr($_[4],-1) &= chr(0xff << $less);
|
||||
}
|
||||
}
|
||||
else {
|
||||
$_[4] .= asn_encode_length(1+length $_[3]);
|
||||
$_[4] .= chr(0);
|
||||
$_[4] .= $_[3];
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub _enc_string {
|
||||
# 0 1 2 3 4 5 6
|
||||
# $optn, $op, $stash, $var, $buf, $loop, $path
|
||||
|
||||
$_[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
|
||||
|
||||
$_[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
|
||||
|
||||
$_[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 = $op->[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]}));
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
910
lib/Convert/ASN1/parser.pm
Normal file
910
lib/Convert/ASN1/parser.pm
Normal file
|
|
@ -0,0 +1,910 @@
|
|||
# 1 "y.tab.pl"
|
||||
#$yysccsid = "@(#)yaccpar 1.8 (Berkeley) 01/20/91 (Perl 2.0 12/31/92)";
|
||||
|
||||
# 20 "parser.y"
|
||||
|
||||
;# 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::parser;
|
||||
|
||||
;# $Id$
|
||||
|
||||
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 ],
|
||||
|
||||
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;
|
||||
}
|
||||
|
||||
# 74 "y.tab.pl"
|
||||
|
||||
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 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, 17, 17, 17, 17, 17, 11, 15, 15, 18,
|
||||
18, 18, 19, 1, 1, 20, 20, 20, 22, 22,
|
||||
22, 22, 21, 21, 21, 23, 23, 4, 4, 5,
|
||||
5, 5, 16, 16, 24, 7, 7,
|
||||
);
|
||||
my @yylen = ( 2,
|
||||
1, 1, 3, 4, 4, 1, 1, 1, 1, 1,
|
||||
3, 1, 1, 5, 1, 1, 1, 4, 4, 4,
|
||||
4, 1, 1, 1, 1, 1, 1, 1, 2, 1,
|
||||
3, 3, 4, 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, 49, 0, 0, 1, 0, 0, 44, 0, 36,
|
||||
0, 0, 0, 0, 52, 51, 0, 0, 0, 3,
|
||||
0, 6, 0, 11, 0, 0, 0, 0, 45, 0,
|
||||
37, 38, 0, 22, 0, 0, 25, 0, 42, 40,
|
||||
0, 41, 0, 27, 43, 4, 0, 0, 0, 0,
|
||||
7, 8, 9, 10, 0, 47, 39, 0, 0, 0,
|
||||
0, 0, 0, 30, 57, 5, 0, 0, 53, 0,
|
||||
18, 19, 0, 20, 0, 0, 55, 21, 0, 0,
|
||||
0, 32, 31, 54, 0, 0, 17, 15, 16, 14,
|
||||
33,
|
||||
);
|
||||
my @yydgoto = ( 4,
|
||||
5, 6, 20, 7, 17, 50, 66, 8, 51, 52,
|
||||
53, 54, 43, 90, 62, 68, 44, 63, 64, 9,
|
||||
10, 45, 57, 69,
|
||||
);
|
||||
my @yysindex = ( 53,
|
||||
5, 0, -1, 0, 0, 12, 96, 0, 30, 0,
|
||||
7, 96, 14, 4, 0, 0, 41, 70, 70, 0,
|
||||
96, 0, 92, 0, 7, 17, 20, 43, 0, 33,
|
||||
0, 0, 92, 0, 17, 20, 0, 82, 0, 0,
|
||||
64, 0, 93, 0, 0, 0, 70, 70, 75, 91,
|
||||
0, 0, 0, 0, 110, 0, 0, 33, 106, 117,
|
||||
33, 131, 62, 0, 0, 0, 128, 95, 0, 96,
|
||||
0, 0, 96, 0, 75, 75, 0, 0, 110, 97,
|
||||
92, 0, 0, 0, 17, 20, 0, 0, 0, 0,
|
||||
0,
|
||||
);
|
||||
my @yyrindex = ( 127,
|
||||
78, 0, 0, 0, 0, 133, 85, 0, 21, 0,
|
||||
78, 111, 0, 0, 0, 0, 0, 127, 118, 0,
|
||||
111, 0, 0, 0, 78, 0, 0, 0, 0, 78,
|
||||
0, 0, 0, 0, 11, 25, 0, 38, 0, 0,
|
||||
57, 0, 0, 0, 0, 0, 127, 127, 0, 119,
|
||||
0, 0, 0, 0, 0, 0, 0, 78, 0, 0,
|
||||
78, 0, 134, 0, 0, 0, 0, 0, 0, 111,
|
||||
0, 0, 111, 0, 0, 135, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 40, 66, 0, 0, 0, 0,
|
||||
0,
|
||||
);
|
||||
my @yygindex = ( 0,
|
||||
89, 0, 123, 3, -11, 68, 0, -9, -17, -20,
|
||||
-15, 121, 0, 0, 0, 0, 0, 0, 63, 0,
|
||||
122, 0, 0, 71,
|
||||
);
|
||||
sub constYYTABLESIZE () { 150 }
|
||||
my @yytable = ( 29,
|
||||
23, 22, 40, 12, 13, 39, 2, 41, 2, 33,
|
||||
23, 23, 14, 21, 24, 22, 12, 25, 11, 23,
|
||||
34, 23, 23, 3, 24, 24, 47, 21, 23, 48,
|
||||
13, 34, 12, 24, 2, 24, 24, 26, 26, 23,
|
||||
23, 18, 24, 26, 27, 28, 26, 19, 26, 26,
|
||||
23, 23, 49, 1, 2, 26, 46, 23, 80, 88,
|
||||
70, 81, 87, 73, 89, 24, 24, 46, 46, 3,
|
||||
30, 2, 56, 75, 46, 61, 24, 24, 48, 76,
|
||||
48, 48, 48, 24, 48, 48, 3, 50, 50, 50,
|
||||
48, 55, 34, 48, 35, 36, 28, 34, 58, 85,
|
||||
86, 28, 15, 16, 37, 78, 79, 38, 65, 37,
|
||||
67, 50, 38, 50, 50, 50, 71, 35, 56, 56,
|
||||
48, 48, 48, 50, 48, 48, 50, 72, 35, 48,
|
||||
48, 48, 2, 48, 48, 59, 60, 82, 83, 31,
|
||||
32, 74, 77, 42, 28, 29, 0, 46, 91, 84,
|
||||
);
|
||||
my @yycheck = ( 17,
|
||||
12, 11, 23, 1, 6, 23, 2, 23, 2, 21,
|
||||
0, 1, 1, 11, 1, 25, 6, 14, 14, 9,
|
||||
0, 11, 12, 17, 0, 1, 10, 25, 18, 10,
|
||||
6, 11, 30, 9, 2, 11, 12, 0, 1, 0,
|
||||
1, 12, 18, 3, 4, 5, 9, 18, 11, 12,
|
||||
11, 12, 10, 1, 2, 18, 0, 18, 70, 80,
|
||||
58, 73, 80, 61, 80, 0, 1, 11, 12, 17,
|
||||
1, 2, 9, 12, 18, 1, 11, 12, 1, 18,
|
||||
3, 4, 5, 18, 7, 8, 17, 3, 4, 5,
|
||||
13, 10, 1, 16, 3, 4, 5, 1, 6, 3,
|
||||
4, 5, 7, 8, 13, 11, 12, 16, 18, 13,
|
||||
1, 1, 16, 3, 4, 5, 11, 0, 0, 1,
|
||||
3, 4, 5, 13, 7, 8, 16, 11, 11, 3,
|
||||
4, 5, 0, 7, 8, 47, 48, 75, 76, 18,
|
||||
19, 11, 15, 23, 11, 11, -1, 25, 81, 79,
|
||||
);
|
||||
sub constYYFINAL () { 4 }
|
||||
|
||||
|
||||
|
||||
sub constYYMAXTOKEN () { 18 }
|
||||
# 262 "y.tab.pl"
|
||||
|
||||
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 &&
|
||||
$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;
|
||||
# 313 "y.tab.pl"
|
||||
|
||||
$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; }
|
||||
# 352 "y.tab.pl"
|
||||
|
||||
}
|
||||
if (($yyn = $yysindex[$yystate]) && ($yyn += $yychar) >= 0 &&
|
||||
$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 &&
|
||||
$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: {
|
||||
# 94 "parser.y"
|
||||
|
||||
{ $yyval = { '' => $yyvs[$yyvsp-0] };
|
||||
last switch;
|
||||
} }
|
||||
State3: {
|
||||
# 99 "parser.y"
|
||||
|
||||
{
|
||||
$yyval = { $yyvs[$yyvsp-2], [$yyvs[$yyvsp-0]] };
|
||||
|
||||
last switch;
|
||||
} }
|
||||
State4: {
|
||||
# 103 "parser.y"
|
||||
|
||||
{
|
||||
$yyval=$yyvs[$yyvsp-3];
|
||||
$yyval->{$yyvs[$yyvsp-2]} = [$yyvs[$yyvsp-0]];
|
||||
|
||||
last switch;
|
||||
} }
|
||||
State5: {
|
||||
# 110 "parser.y"
|
||||
|
||||
{
|
||||
$yyvs[$yyvsp-1]->[cTAG] = $yyvs[$yyvsp-3];
|
||||
$yyval = $yyvs[$yyvsp-2] ? explicit($yyvs[$yyvsp-1]) : $yyvs[$yyvsp-1];
|
||||
|
||||
last switch;
|
||||
} }
|
||||
State11: {
|
||||
# 124 "parser.y"
|
||||
|
||||
{
|
||||
@{$yyval = []}[cTYPE,cCHILD] = ('COMPONENTS', $yyvs[$yyvsp-0]);
|
||||
|
||||
last switch;
|
||||
} }
|
||||
State14: {
|
||||
# 134 "parser.y"
|
||||
|
||||
{
|
||||
$yyvs[$yyvsp-0]->[cTAG] = $yyvs[$yyvsp-2];
|
||||
@{$yyval = []}[cTYPE,cCHILD,cLOOP] = ($yyvs[$yyvsp-4], [$yyvs[$yyvsp-0]], 1);
|
||||
$yyval = explicit($yyval) if $yyvs[$yyvsp-1];
|
||||
|
||||
last switch;
|
||||
} }
|
||||
State18: {
|
||||
# 147 "parser.y"
|
||||
|
||||
{
|
||||
@{$yyval = []}[cTYPE,cCHILD] = ('SEQUENCE', $yyvs[$yyvsp-1]);
|
||||
|
||||
last switch;
|
||||
} }
|
||||
State19: {
|
||||
# 151 "parser.y"
|
||||
|
||||
{
|
||||
@{$yyval = []}[cTYPE,cCHILD] = ('SET', $yyvs[$yyvsp-1]);
|
||||
|
||||
last switch;
|
||||
} }
|
||||
State20: {
|
||||
# 155 "parser.y"
|
||||
|
||||
{
|
||||
@{$yyval = []}[cTYPE,cCHILD] = ('CHOICE', $yyvs[$yyvsp-1]);
|
||||
|
||||
last switch;
|
||||
} }
|
||||
State21: {
|
||||
# 161 "parser.y"
|
||||
|
||||
{
|
||||
@{$yyval = []}[cTYPE] = ('ENUM');
|
||||
|
||||
last switch;
|
||||
} }
|
||||
State27: {
|
||||
# 174 "parser.y"
|
||||
|
||||
{
|
||||
@{$yyval = []}[cTYPE] = ($yyvs[$yyvsp-0]);
|
||||
|
||||
last switch;
|
||||
} }
|
||||
State28: {
|
||||
# 179 "parser.y"
|
||||
|
||||
{ $yyval = $yyvs[$yyvsp-0];
|
||||
last switch;
|
||||
} }
|
||||
State29: {
|
||||
# 180 "parser.y"
|
||||
|
||||
{ $yyval = $yyvs[$yyvsp-1];
|
||||
last switch;
|
||||
} }
|
||||
State30: {
|
||||
# 184 "parser.y"
|
||||
|
||||
{
|
||||
$yyval = [ $yyvs[$yyvsp-0] ];
|
||||
|
||||
last switch;
|
||||
} }
|
||||
State31: {
|
||||
# 188 "parser.y"
|
||||
|
||||
{
|
||||
push @{$yyval=$yyvs[$yyvsp-2]}, $yyvs[$yyvsp-0];
|
||||
|
||||
last switch;
|
||||
} }
|
||||
State32: {
|
||||
# 192 "parser.y"
|
||||
|
||||
{
|
||||
push @{$yyval=$yyvs[$yyvsp-2]}, $yyvs[$yyvsp-0];
|
||||
|
||||
last switch;
|
||||
} }
|
||||
State33: {
|
||||
# 198 "parser.y"
|
||||
|
||||
{
|
||||
@{$yyval=$yyvs[$yyvsp-0]}[cVAR,cTAG] = ($yyvs[$yyvsp-3],$yyvs[$yyvsp-2]);
|
||||
$yyval = explicit($yyval) if $yyvs[$yyvsp-1];
|
||||
|
||||
last switch;
|
||||
} }
|
||||
State34: {
|
||||
# 205 "parser.y"
|
||||
|
||||
{ $yyval = $yyvs[$yyvsp-0];
|
||||
last switch;
|
||||
} }
|
||||
State35: {
|
||||
# 206 "parser.y"
|
||||
|
||||
{ $yyval = $yyvs[$yyvsp-1];
|
||||
last switch;
|
||||
} }
|
||||
State36: {
|
||||
# 210 "parser.y"
|
||||
|
||||
{
|
||||
$yyval = [ $yyvs[$yyvsp-0] ];
|
||||
|
||||
last switch;
|
||||
} }
|
||||
State37: {
|
||||
# 214 "parser.y"
|
||||
|
||||
{
|
||||
push @{$yyval=$yyvs[$yyvsp-2]}, $yyvs[$yyvsp-0];
|
||||
|
||||
last switch;
|
||||
} }
|
||||
State38: {
|
||||
# 218 "parser.y"
|
||||
|
||||
{
|
||||
push @{$yyval=$yyvs[$yyvsp-2]}, $yyvs[$yyvsp-0];
|
||||
|
||||
last switch;
|
||||
} }
|
||||
State39: {
|
||||
# 224 "parser.y"
|
||||
|
||||
{
|
||||
@{$yyval=$yyvs[$yyvsp-1]}[cOPT] = ($yyvs[$yyvsp-0]);
|
||||
|
||||
last switch;
|
||||
} }
|
||||
State43: {
|
||||
# 233 "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;
|
||||
} }
|
||||
State45: {
|
||||
# 240 "parser.y"
|
||||
|
||||
{
|
||||
@{$yyval=$yyvs[$yyvsp-0]}[cTAG] = ($yyvs[$yyvsp-2]);
|
||||
$yyval = explicit($yyval) if $yyvs[$yyvsp-1];
|
||||
|
||||
last switch;
|
||||
} }
|
||||
State46: {
|
||||
# 246 "parser.y"
|
||||
|
||||
{ $yyval = undef;
|
||||
last switch;
|
||||
} }
|
||||
State47: {
|
||||
# 247 "parser.y"
|
||||
|
||||
{ $yyval = 1;
|
||||
last switch;
|
||||
} }
|
||||
State48: {
|
||||
# 251 "parser.y"
|
||||
|
||||
{ $yyval = undef;
|
||||
last switch;
|
||||
} }
|
||||
State50: {
|
||||
# 255 "parser.y"
|
||||
|
||||
{ $yyval = undef;
|
||||
last switch;
|
||||
} }
|
||||
State51: {
|
||||
# 256 "parser.y"
|
||||
|
||||
{ $yyval = 1;
|
||||
last switch;
|
||||
} }
|
||||
State52: {
|
||||
# 257 "parser.y"
|
||||
|
||||
{ $yyval = 0;
|
||||
last switch;
|
||||
} }
|
||||
State53: {
|
||||
# 260 "parser.y"
|
||||
|
||||
{
|
||||
last switch;
|
||||
} }
|
||||
State54: {
|
||||
# 261 "parser.y"
|
||||
|
||||
{
|
||||
last switch;
|
||||
} }
|
||||
State55: {
|
||||
# 264 "parser.y"
|
||||
|
||||
{
|
||||
last switch;
|
||||
} }
|
||||
State56: {
|
||||
# 267 "parser.y"
|
||||
|
||||
{
|
||||
last switch;
|
||||
} }
|
||||
State57: {
|
||||
# 268 "parser.y"
|
||||
|
||||
{
|
||||
last switch;
|
||||
} }
|
||||
# 615 "y.tab.pl"
|
||||
|
||||
} # 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; }
|
||||
# 641 "y.tab.pl"
|
||||
|
||||
}
|
||||
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
|
||||
# 272 "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(),
|
||||
);
|
||||
|
||||
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
|
||||
$op = explicit($op) if $op->[cTYPE] == opCHOICE && defined($op->[cTAG]) && length($op->[cTAG]);
|
||||
|
||||
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
|
||||
;#}
|
||||
}
|
||||
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+)
|
||||
|
|
||||
\[\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;
|
||||
|
||||
# 947 "y.tab.pl"
|
||||
|
||||
%yystate = ('State20','','State21','','State43','','State27','','State28',
|
||||
'','State45','','State29','','State46','','State47','','State48','',
|
||||
'State1','','State3','','State4','','State5','','State11','','State14','',
|
||||
'State30','','State31','','State32','','State33','','State18','','State34',
|
||||
'','State50','','State19','','State35','','State51','','State36','',
|
||||
'State52','','State37','','State53','','State38','','State54','','State39',
|
||||
'','State55','','State56','','State57','');
|
||||
|
||||
1;
|
||||
Loading…
Add table
Add a link
Reference in a new issue