oqapi/webgui
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Added Net::LDAP to the distribution for easier installs.

Browse source
This commit is contained in:
JT Smith 2002-11-25 07:43:41 +00:00
parent f51b335d74
commit 223c014813
47 changed files with 15060 additions and 2 deletions
Download patch file Download diff file Expand all files Collapse all files

228
lib/Convert/ASN1/Debug.pm Normal file
View 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
View 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
View 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
View 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
View 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;