Initial Commit
This commit is contained in:
Riley Schneider
734
database/perl/vendor/lib/Convert/ASN1/_decode.pm
vendored
Normal file
734
database/perl/vendor/lib/Convert/ASN1/_decode.pm
vendored
Normal file
@@ -0,0 +1,734 @@
|
||||
# Copyright (c) 2000-2005 Graham Barr <gbarr@pobox.com>. All rights reserved.
|
||||
# This program is free software; you can redistribute it and/or
|
||||
# modify it under the same terms as Perl itself.
|
||||
|
||||
package Convert::ASN1;
|
||||
{
|
||||
$Convert::ASN1::VERSION = '0.27';
|
||||
}
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
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_explicit,
|
||||
\&_dec_set,
|
||||
\&_dec_time,
|
||||
\&_dec_time,
|
||||
\&_dec_utf8,
|
||||
undef, # ANY
|
||||
undef, # CHOICE
|
||||
\&_dec_object_id,
|
||||
\&_dec_bcd,
|
||||
);
|
||||
|
||||
my @ctr;
|
||||
@ctr[opBITSTR, opSTRING, opUTF8] = (\&_ctr_bitstring,\&_ctr_string,\&_ctr_string);
|
||||
|
||||
|
||||
sub _decode {
|
||||
my ($optn, $ops, $stash, $pos, $end, $seqof, $larr) = @_;
|
||||
my $idx = 0;
|
||||
|
||||
# we try not to copy the input buffer at any time
|
||||
foreach my $buf ($_[-1]) {
|
||||
OP:
|
||||
foreach my $op (@{$ops}) {
|
||||
my $var = $op->[cVAR];
|
||||
|
||||
if (length $op->[cTAG]) {
|
||||
|
||||
TAGLOOP: {
|
||||
my($tag,$len,$npos,$indef) = _decode_tl($buf,$pos,$end,$larr)
|
||||
or do {
|
||||
next OP if $pos==$end and ($seqof || defined $op->[cEXT]);
|
||||
die "decode error";
|
||||
};
|
||||
|
||||
if ($tag eq $op->[cTAG]) {
|
||||
|
||||
&{$decode[$op->[cTYPE]]}(
|
||||
$optn,
|
||||
$op,
|
||||
$stash,
|
||||
# We send 1 if there is not var as if there is the decode
|
||||
# should be getting undef. So if it does not get undef
|
||||
# it knows it has no variable
|
||||
($seqof ? $seqof->[$idx++] : defined($var) ? $stash->{$var} : ref($stash) eq 'SCALAR' ? $$stash : 1),
|
||||
$buf,$npos,$len, $larr
|
||||
);
|
||||
|
||||
$pos = $npos+$len+$indef;
|
||||
|
||||
redo TAGLOOP if $seqof && $pos < $end;
|
||||
next OP;
|
||||
}
|
||||
|
||||
if ($tag eq ($op->[cTAG] | pack("C",ASN_CONSTRUCTOR))
|
||||
and my $ctr = $ctr[$op->[cTYPE]])
|
||||
{
|
||||
_decode(
|
||||
$optn,
|
||||
[$op],
|
||||
undef,
|
||||
$npos,
|
||||
$npos+$len,
|
||||
(\my @ctrlist),
|
||||
$larr,
|
||||
$buf,
|
||||
);
|
||||
|
||||
($seqof ? $seqof->[$idx++] : defined($var) ? $stash->{$var} : ref($stash) eq 'SCALAR' ? $$stash : undef)
|
||||
= &{$ctr}(@ctrlist);
|
||||
$pos = $npos+$len+$indef;
|
||||
|
||||
redo TAGLOOP if $seqof && $pos < $end;
|
||||
next OP;
|
||||
|
||||
}
|
||||
|
||||
if ($seqof || defined $op->[cEXT]) {
|
||||
next OP;
|
||||
}
|
||||
|
||||
die "decode error " . unpack("H*",$tag) ."<=>" . unpack("H*",$op->[cTAG]), " ",$pos," ",$op->[cTYPE]," ",$op->[cVAR]||'';
|
||||
}
|
||||
}
|
||||
else { # opTag length is zero, so it must be an ANY, CHOICE or EXTENSIONS
|
||||
|
||||
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->[cEXT]);
|
||||
die "decode error";
|
||||
};
|
||||
|
||||
$len += $npos - $pos + $indef;
|
||||
|
||||
my $handler;
|
||||
if ($op->[cDEFINE]) {
|
||||
$handler = $optn->{oidtable} && $optn->{oidtable}{$stash->{$op->[cDEFINE]}};
|
||||
$handler ||= $optn->{handlers}{$op->[cVAR]}{$stash->{$op->[cDEFINE]}};
|
||||
}
|
||||
|
||||
($seqof ? $seqof->[$idx++] : ref($stash) eq 'SCALAR' ? $$stash : $stash->{$var})
|
||||
= $handler ? $handler->decode(substr($buf,$pos,$len)) : substr($buf,$pos,$len);
|
||||
|
||||
$pos += $len;
|
||||
|
||||
redo ANYLOOP if $seqof && $pos < $end;
|
||||
}
|
||||
}
|
||||
elsif ($op->[cTYPE] == opCHOICE) {
|
||||
|
||||
CHOICELOOP: {
|
||||
my($tag,$len,$npos,$indef) = _decode_tl($buf,$pos,$end,$larr)
|
||||
or do {
|
||||
next OP if $pos==$end and ($seqof || defined $op->[cEXT]);
|
||||
die "decode error";
|
||||
};
|
||||
my $extensions;
|
||||
foreach my $cop (@{$op->[cCHILD]}) {
|
||||
|
||||
if ($tag eq $cop->[cTAG]) {
|
||||
|
||||
my $nstash = $seqof
|
||||
? ($seqof->[$idx++]={})
|
||||
: defined($var)
|
||||
? ($stash->{$var}={})
|
||||
: ref($stash) eq 'SCALAR'
|
||||
? ($$stash={}) : $stash;
|
||||
|
||||
&{$decode[$cop->[cTYPE]]}(
|
||||
$optn,
|
||||
$cop,
|
||||
$nstash,
|
||||
($cop->[cVAR] ? $nstash->{$cop->[cVAR]} : undef),
|
||||
$buf,$npos,$len,$larr,
|
||||
);
|
||||
|
||||
$pos = $npos+$len+$indef;
|
||||
|
||||
redo CHOICELOOP if $seqof && $pos < $end;
|
||||
next OP;
|
||||
}
|
||||
|
||||
if ($cop->[cTYPE] == opEXTENSIONS) {
|
||||
$extensions = 1;
|
||||
next;
|
||||
}
|
||||
|
||||
unless (length $cop->[cTAG]) {
|
||||
eval {
|
||||
_decode(
|
||||
$optn,
|
||||
[$cop],
|
||||
(\my %tmp_stash),
|
||||
$pos,
|
||||
$npos+$len+$indef,
|
||||
undef,
|
||||
$larr,
|
||||
$buf,
|
||||
);
|
||||
|
||||
my $nstash = $seqof
|
||||
? ($seqof->[$idx++]={})
|
||||
: defined($var)
|
||||
? ($stash->{$var}={})
|
||||
: ref($stash) eq 'SCALAR'
|
||||
? ($$stash={}) : $stash;
|
||||
|
||||
@{$nstash}{keys %tmp_stash} = values %tmp_stash;
|
||||
|
||||
} or next;
|
||||
|
||||
$pos = $npos+$len+$indef;
|
||||
|
||||
redo CHOICELOOP if $seqof && $pos < $end;
|
||||
next OP;
|
||||
}
|
||||
|
||||
if ($tag eq ($cop->[cTAG] | pack("C",ASN_CONSTRUCTOR))
|
||||
and my $ctr = $ctr[$cop->[cTYPE]])
|
||||
{
|
||||
my $nstash = $seqof
|
||||
? ($seqof->[$idx++]={})
|
||||
: defined($var)
|
||||
? ($stash->{$var}={})
|
||||
: ref($stash) eq 'SCALAR'
|
||||
? ($$stash={}) : $stash;
|
||||
|
||||
_decode(
|
||||
$optn,
|
||||
[$cop],
|
||||
undef,
|
||||
$npos,
|
||||
$npos+$len,
|
||||
(\my @ctrlist),
|
||||
$larr,
|
||||
$buf,
|
||||
);
|
||||
|
||||
$nstash->{$cop->[cVAR]} = &{$ctr}(@ctrlist);
|
||||
$pos = $npos+$len+$indef;
|
||||
|
||||
redo CHOICELOOP if $seqof && $pos < $end;
|
||||
next OP;
|
||||
}
|
||||
}
|
||||
|
||||
if ($pos < $end && $extensions) {
|
||||
$pos = $npos+$len+$indef;
|
||||
|
||||
redo CHOICELOOP if $seqof && $pos < $end;
|
||||
next OP;
|
||||
}
|
||||
}
|
||||
die "decode error" unless $op->[cEXT];
|
||||
}
|
||||
elsif ($op->[cTYPE] == opEXTENSIONS) {
|
||||
$pos = $end; # Skip over the rest
|
||||
}
|
||||
else {
|
||||
die "this point should never be reached";
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
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] = unpack("C",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 = unpack("C",$buf) & 0x80 ? pack("C",255) : pack("C",0);
|
||||
if ($_[6] > 4) {
|
||||
$_[3] = os2ip($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-unpack("C",substr($_[4],$_[5],1)) ];
|
||||
1;
|
||||
}
|
||||
|
||||
|
||||
sub _dec_string {
|
||||
# 0 1 2 3 4 5 6
|
||||
# $optn, $op, $stash, $var, $buf, $pos, $len
|
||||
|
||||
$_[3] = substr($_[4],$_[5],$_[6]);
|
||||
1;
|
||||
}
|
||||
|
||||
|
||||
sub _dec_null {
|
||||
# 0 1 2 3 4 5 6
|
||||
# $optn, $op, $stash, $var, $buf, $pos, $len
|
||||
|
||||
$_[3] = exists($_[0]->{decode_null}) ? $_[0]->{decode_null} : 1;
|
||||
1;
|
||||
}
|
||||
|
||||
|
||||
sub _dec_object_id {
|
||||
# 0 1 2 3 4 5 6
|
||||
# $optn, $op, $stash, $var, $buf, $pos, $len
|
||||
|
||||
my @data = unpack("w*",substr($_[4],$_[5],$_[6]));
|
||||
if ($_[1]->[cTYPE] == opOBJID and @data > 1) {
|
||||
if ($data[0] < 40) {
|
||||
splice(@data, 0, 1, 0, $data[0]);
|
||||
}
|
||||
elsif ($data[0] < 80) {
|
||||
splice(@data, 0, 1, 1, $data[0] - 40);
|
||||
}
|
||||
else {
|
||||
splice(@data, 0, 1, 2, $data[0] - 80);
|
||||
}
|
||||
}
|
||||
$_[3] = join(".", @data);
|
||||
1;
|
||||
}
|
||||
|
||||
|
||||
my @_dec_real_base = (2,8,16);
|
||||
|
||||
sub _dec_real {
|
||||
# 0 1 2 3 4 5 6
|
||||
# $optn, $op, $stash, $var, $buf, $pos, $len
|
||||
|
||||
$_[3] = 0.0, return unless $_[6];
|
||||
|
||||
my $first = unpack("C",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 = unpack("C",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_explicit {
|
||||
# 0 1 2 3 4 5 6 7
|
||||
# $optn, $op, $stash, $var, $buf, $pos, $len, $larr
|
||||
|
||||
local $_[1][cCHILD][0][cVAR] = $_[1][cVAR] unless $_[1][cCHILD][0][cVAR];
|
||||
|
||||
_decode(
|
||||
$_[0], #optn
|
||||
$_[1]->[cCHILD], #ops
|
||||
$_[2], #stash
|
||||
$_[5], #pos
|
||||
$_[5]+$_[6], #end
|
||||
undef, #loop
|
||||
$_[7],
|
||||
$_[4], #buf
|
||||
);
|
||||
1;
|
||||
}
|
||||
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;
|
||||
my $extensions;
|
||||
|
||||
while ($pos < $end) {
|
||||
my($tag,$len,$npos,$indef) = _decode_tl($_[4],$pos,$end,$larr)
|
||||
or die "decode error";
|
||||
|
||||
my ($idx, $any, $done) = (-1);
|
||||
|
||||
SET_OP:
|
||||
foreach my $op (@$ch) {
|
||||
$idx++;
|
||||
if (length($op->[cTAG])) {
|
||||
if ($tag eq $op->[cTAG]) {
|
||||
my $var = $op->[cVAR];
|
||||
&{$decode[$op->[cTYPE]]}(
|
||||
$optn,
|
||||
$op,
|
||||
$stash,
|
||||
# We send 1 if there is not var as if there is the decode
|
||||
# should be getting undef. So if it does not get undef
|
||||
# it knows it has no variable
|
||||
(defined($var) ? $stash->{$var} : 1),
|
||||
$_[4],$npos,$len,$larr,
|
||||
);
|
||||
$done = $idx;
|
||||
last SET_OP;
|
||||
}
|
||||
if ($tag eq ($op->[cTAG] | pack("C",ASN_CONSTRUCTOR))
|
||||
and my $ctr = $ctr[$op->[cTYPE]])
|
||||
{
|
||||
_decode(
|
||||
$optn,
|
||||
[$op],
|
||||
undef,
|
||||
$npos,
|
||||
$npos+$len,
|
||||
(\my @ctrlist),
|
||||
$larr,
|
||||
$_[4],
|
||||
);
|
||||
|
||||
$stash->{$op->[cVAR]} = &{$ctr}(@ctrlist)
|
||||
if defined $op->[cVAR];
|
||||
$done = $idx;
|
||||
last SET_OP;
|
||||
}
|
||||
next SET_OP;
|
||||
}
|
||||
elsif ($op->[cTYPE] == opANY) {
|
||||
$any = $idx;
|
||||
}
|
||||
elsif ($op->[cTYPE] == opCHOICE) {
|
||||
my $var = $op->[cVAR];
|
||||
foreach my $cop (@{$op->[cCHILD]}) {
|
||||
if ($tag eq $cop->[cTAG]) {
|
||||
my $nstash = defined($var) ? ($stash->{$var}={}) : $stash;
|
||||
|
||||
&{$decode[$cop->[cTYPE]]}(
|
||||
$optn,
|
||||
$cop,
|
||||
$nstash,
|
||||
$nstash->{$cop->[cVAR]},
|
||||
$_[4],$npos,$len,$larr,
|
||||
);
|
||||
$done = $idx;
|
||||
last SET_OP;
|
||||
}
|
||||
if ($tag eq ($cop->[cTAG] | pack("C",ASN_CONSTRUCTOR))
|
||||
and my $ctr = $ctr[$cop->[cTYPE]])
|
||||
{
|
||||
my $nstash = defined($var) ? ($stash->{$var}={}) : $stash;
|
||||
|
||||
_decode(
|
||||
$optn,
|
||||
[$cop],
|
||||
undef,
|
||||
$npos,
|
||||
$npos+$len,
|
||||
(\my @ctrlist),
|
||||
$larr,
|
||||
$_[4],
|
||||
);
|
||||
|
||||
$nstash->{$cop->[cVAR]} = &{$ctr}(@ctrlist);
|
||||
$done = $idx;
|
||||
last SET_OP;
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif ($op->[cTYPE] == opEXTENSIONS) {
|
||||
$extensions = $idx;
|
||||
}
|
||||
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;
|
||||
}
|
||||
|
||||
if( !defined($done) && defined($extensions) ) {
|
||||
$done = $extensions;
|
||||
}
|
||||
|
||||
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][cEXT] or $ch->[$idx][cTYPE] == opEXTENSIONS;
|
||||
}
|
||||
|
||||
1;
|
||||
}
|
||||
|
||||
|
||||
my %_dec_time_opt = ( unixtime => 0, withzone => 1, raw => 2);
|
||||
|
||||
sub _dec_time {
|
||||
# 0 1 2 3 4 5 6
|
||||
# $optn, $op, $stash, $var, $buf, $pos, $len
|
||||
|
||||
my $mode = $_dec_time_opt{$_[0]->{'decode_time'} || ''} || 0;
|
||||
|
||||
if ($mode == 2 or $_[6] == 0) {
|
||||
$_[3] = substr($_[4],$_[5],$_[6]);
|
||||
return;
|
||||
}
|
||||
|
||||
my @bits = (substr($_[4],$_[5],$_[6])
|
||||
=~ /^((?:\d\d)?\d\d)(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)((?:\.\d{1,3})?)(([-+])(\d\d)(\d\d)|Z)/)
|
||||
or die "bad time format";
|
||||
|
||||
if ($bits[0] < 100) {
|
||||
$bits[0] += 100 if $bits[0] < 50;
|
||||
}
|
||||
else {
|
||||
$bits[0] -= 1900;
|
||||
}
|
||||
$bits[1] -= 1;
|
||||
require Time::Local;
|
||||
my $time = Time::Local::timegm(@bits[5,4,3,2,1,0]);
|
||||
$time += $bits[6] if length $bits[6];
|
||||
my $offset = 0;
|
||||
if ($bits[7] ne 'Z') {
|
||||
$offset = $bits[9] * 3600 + $bits[10] * 60;
|
||||
$offset = -$offset if $bits[8] eq '-';
|
||||
$time -= $offset;
|
||||
}
|
||||
$_[3] = $mode ? [$time,$offset] : $time;
|
||||
}
|
||||
|
||||
|
||||
sub _dec_utf8 {
|
||||
# 0 1 2 3 4 5 6
|
||||
# $optn, $op, $stash, $var, $buf, $pos, $len
|
||||
|
||||
BEGIN {
|
||||
unless (CHECK_UTF8) {
|
||||
local $SIG{__DIE__};
|
||||
eval { require bytes } and 'bytes'->unimport;
|
||||
eval { require utf8 } and 'utf8'->import;
|
||||
}
|
||||
}
|
||||
|
||||
if (CHECK_UTF8) {
|
||||
$_[3] = Encode::decode('utf8', substr($_[4],$_[5],$_[6]));
|
||||
}
|
||||
else {
|
||||
$_[3] = (substr($_[4],$_[5],$_[6]) =~ /(.*)/s)[0];
|
||||
}
|
||||
|
||||
1;
|
||||
}
|
||||
|
||||
|
||||
sub _decode_tl {
|
||||
my($pos,$end,$larr) = @_[1,2,3];
|
||||
|
||||
return if $pos >= $end;
|
||||
|
||||
my $indef = 0;
|
||||
|
||||
my $tag = substr($_[0], $pos++, 1);
|
||||
|
||||
if((unpack("C",$tag) & 0x1f) == 0x1f) {
|
||||
my $b;
|
||||
my $n=1;
|
||||
do {
|
||||
return if $pos >= $end;
|
||||
$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 ;
|
||||
|
||||
my $padding = $len < 4 ? "\0" x (4 - $len) : "";
|
||||
($len,$pos) = (unpack("N", $padding . substr($_[0],$pos,$len)), $pos+$len);
|
||||
}
|
||||
else {
|
||||
unless (exists $larr->{$pos}) {
|
||||
_scan_indef($_[0],$pos,$end,$larr) or return;
|
||||
}
|
||||
$indef = 2;
|
||||
$len = $larr->{$pos};
|
||||
}
|
||||
}
|
||||
|
||||
return if $pos+$len+$indef > $end;
|
||||
|
||||
# return the tag, the length of the data, the position of the data
|
||||
# and the number of extra bytes for indefinate encoding
|
||||
|
||||
($tag, $len, $pos, $indef);
|
||||
}
|
||||
|
||||
sub _scan_indef {
|
||||
my($pos,$end,$larr) = @_[1,2,3];
|
||||
my @depth = ( $pos );
|
||||
|
||||
while(@depth) {
|
||||
return if $pos+2 > $end;
|
||||
|
||||
if (substr($_[0],$pos,2) eq "\0\0") {
|
||||
my $end = $pos;
|
||||
my $stref = shift @depth;
|
||||
# replace pos with length = end - pos
|
||||
$larr->{$stref} = $end - $stref;
|
||||
$pos += 2;
|
||||
next;
|
||||
}
|
||||
|
||||
my $tag = substr($_[0], $pos++, 1);
|
||||
|
||||
if((unpack("C",$tag) & 0x1f) == 0x1f) {
|
||||
my $b;
|
||||
do {
|
||||
$tag .= substr($_[0],$pos++,1);
|
||||
$b = ord substr($tag,-1);
|
||||
} while($b & 0x80);
|
||||
}
|
||||
return if $pos >= $end;
|
||||
|
||||
my $len = ord substr($_[0],$pos++,1);
|
||||
|
||||
if($len & 0x80) {
|
||||
if ($len &= 0x7f) {
|
||||
return if $pos+$len > $end ;
|
||||
|
||||
my $padding = $len < 4 ? "\0" x (4 - $len) : "";
|
||||
$pos += $len + unpack("N", $padding . substr($_[0],$pos,$len));
|
||||
}
|
||||
else {
|
||||
# reserve another list element
|
||||
unshift @depth, $pos;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$pos += $len;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
}
|
||||
|
||||
sub _ctr_string { join '', @_ }
|
||||
|
||||
sub _ctr_bitstring {
|
||||
[ join('', map { $_->[0] } @_), $_[-1]->[1] ]
|
||||
}
|
||||
|
||||
sub _dec_bcd {
|
||||
# 0 1 2 3 4 5 6
|
||||
# $optn, $op, $stash, $var, $buf, $pos, $len
|
||||
|
||||
($_[3] = unpack("H*", substr($_[4],$_[5],$_[6]))) =~ s/[fF]$//;
|
||||
1;
|
||||
}
|
||||
1;
|
||||
|
||||
Reference in New Issue
Block a user