Initial Commit
This commit is contained in:
Riley Schneider
463
database/perl/vendor/lib/Convert/ASN1.pm
vendored
Normal file
463
database/perl/vendor/lib/Convert/ASN1.pm
vendored
Normal file
@@ -0,0 +1,463 @@
|
||||
# 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;
|
||||
{
|
||||
$Convert::ASN1::VERSION = '0.27';
|
||||
}
|
||||
|
||||
use 5.004;
|
||||
use strict;
|
||||
use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS @opParts @opName $AUTOLOAD);
|
||||
use Exporter;
|
||||
|
||||
use constant CHECK_UTF8 => $] > 5.007;
|
||||
|
||||
BEGIN {
|
||||
local $SIG{__DIE__};
|
||||
eval { require bytes and 'bytes'->import };
|
||||
|
||||
if (CHECK_UTF8) {
|
||||
require Encode;
|
||||
require utf8;
|
||||
}
|
||||
|
||||
@ISA = qw(Exporter);
|
||||
|
||||
%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 cEXT cCHILD cDEFINE
|
||||
);
|
||||
|
||||
@opName = qw(
|
||||
opUNKNOWN opBOOLEAN opINTEGER opBITSTR opSTRING opNULL opOBJID opREAL
|
||||
opSEQUENCE opEXPLICIT opSET opUTIME opGTIME opUTF8 opANY opCHOICE opROID opBCD
|
||||
opEXTENSIONS
|
||||
);
|
||||
|
||||
foreach my $l (\@opParts, \@opName) {
|
||||
my $i = 0;
|
||||
foreach my $name (@$l) {
|
||||
my $j = $i++;
|
||||
no strict 'refs';
|
||||
*{__PACKAGE__ . '::' . $name} = sub () { $j }
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub _internal_syms {
|
||||
my $pkg = caller;
|
||||
no strict 'refs';
|
||||
for my $sub (@opParts,@opName,'dump_op') {
|
||||
*{$pkg . '::' . $sub} = \&{__PACKAGE__ . '::' . $sub};
|
||||
}
|
||||
}
|
||||
|
||||
sub ASN_BOOLEAN () { 0x01 }
|
||||
sub ASN_INTEGER () { 0x02 }
|
||||
sub ASN_BIT_STR () { 0x03 }
|
||||
sub ASN_OCTET_STR () { 0x04 }
|
||||
sub ASN_NULL () { 0x05 }
|
||||
sub ASN_OBJECT_ID () { 0x06 }
|
||||
sub ASN_REAL () { 0x09 }
|
||||
sub ASN_ENUMERATED () { 0x0A }
|
||||
sub ASN_RELATIVE_OID () { 0x0D }
|
||||
sub ASN_SEQUENCE () { 0x10 }
|
||||
sub ASN_SET () { 0x11 }
|
||||
sub ASN_PRINT_STR () { 0x13 }
|
||||
sub ASN_IA5_STR () { 0x16 }
|
||||
sub ASN_UTC_TIME () { 0x17 }
|
||||
sub ASN_GENERAL_TIME () { 0x18 }
|
||||
|
||||
sub ASN_UNIVERSAL () { 0x00 }
|
||||
sub ASN_APPLICATION () { 0x40 }
|
||||
sub ASN_CONTEXT () { 0x80 }
|
||||
sub ASN_PRIVATE () { 0xC0 }
|
||||
|
||||
sub ASN_PRIMITIVE () { 0x00 }
|
||||
sub ASN_CONSTRUCTOR () { 0x20 }
|
||||
|
||||
sub ASN_LONG_LEN () { 0x80 }
|
||||
sub ASN_EXTENSION_ID () { 0x1F }
|
||||
sub ASN_BIT () { 0x80 }
|
||||
|
||||
|
||||
sub new {
|
||||
my $pkg = shift;
|
||||
my $self = bless {}, $pkg;
|
||||
|
||||
$self->configure(@_);
|
||||
$self;
|
||||
}
|
||||
|
||||
|
||||
sub configure {
|
||||
my $self = shift;
|
||||
my %opt = @_;
|
||||
|
||||
$self->{options}{encoding} = uc($opt{encoding} || 'BER');
|
||||
|
||||
unless ($self->{options}{encoding} =~ /^[BD]ER$/) {
|
||||
require Carp;
|
||||
Carp::croak("Unsupported encoding format '$opt{encoding}'");
|
||||
}
|
||||
|
||||
# IMPLICIT as defalt for backwards compatibility, even though it's wrong.
|
||||
$self->{options}{tagdefault} = uc($opt{tagdefault} || 'IMPLICIT');
|
||||
|
||||
unless ($self->{options}{tagdefault} =~ /^(?:EXPLICIT|IMPLICIT)$/) {
|
||||
require Carp;
|
||||
Carp::croak("Default tagging must be EXPLICIT/IMPLICIT. Not $opt{tagdefault}");
|
||||
}
|
||||
|
||||
|
||||
for my $type (qw(encode decode)) {
|
||||
if (exists $opt{$type}) {
|
||||
while(my($what,$value) = each %{$opt{$type}}) {
|
||||
$self->{options}{"${type}_${what}"} = $value;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub find {
|
||||
my $self = shift;
|
||||
my $what = shift;
|
||||
return unless exists $self->{tree}{$what};
|
||||
my %new = %$self;
|
||||
$new{script} = $new{tree}->{$what};
|
||||
bless \%new, ref($self);
|
||||
}
|
||||
|
||||
|
||||
sub prepare {
|
||||
my $self = shift;
|
||||
my $asn = shift;
|
||||
|
||||
$self = $self->new unless ref($self);
|
||||
my $tree;
|
||||
if( ref($asn) eq 'GLOB' ){
|
||||
local $/ = undef;
|
||||
my $txt = <$asn>;
|
||||
$tree = Convert::ASN1::parser::parse($txt,$self->{options}{tagdefault});
|
||||
} else {
|
||||
$tree = Convert::ASN1::parser::parse($asn,$self->{options}{tagdefault});
|
||||
}
|
||||
|
||||
unless ($tree) {
|
||||
$self->{error} = $@;
|
||||
return;
|
||||
### If $self has been set to a new object, not returning
|
||||
### this object here will destroy the object, so the caller
|
||||
### won't be able to get at the error.
|
||||
}
|
||||
|
||||
$self->{tree} = _pack_struct($tree);
|
||||
$self->{script} = (values %$tree)[0];
|
||||
$self;
|
||||
}
|
||||
|
||||
sub prepare_file {
|
||||
my $self = shift;
|
||||
my $asnp = shift;
|
||||
|
||||
local *ASN;
|
||||
open( ASN, $asnp )
|
||||
or do{ $self->{error} = $@; return; };
|
||||
my $ret = $self->prepare( \*ASN );
|
||||
close( ASN );
|
||||
$ret;
|
||||
}
|
||||
|
||||
sub registeroid {
|
||||
my $self = shift;
|
||||
my $oid = shift;
|
||||
my $handler = shift;
|
||||
|
||||
$self->{options}{oidtable}{$oid}=$handler;
|
||||
$self->{oidtable}{$oid}=$handler;
|
||||
}
|
||||
|
||||
sub registertype {
|
||||
my $self = shift;
|
||||
my $def = shift;
|
||||
my $type = shift;
|
||||
my $handler = shift;
|
||||
|
||||
$self->{options}{handlers}{$def}{$type}=$handler;
|
||||
}
|
||||
|
||||
# In XS the will convert the tree between perl and C structs
|
||||
|
||||
sub _pack_struct { $_[0] }
|
||||
sub _unpack_struct { $_[0] }
|
||||
|
||||
##
|
||||
## Encoding
|
||||
##
|
||||
|
||||
sub encode {
|
||||
my $self = shift;
|
||||
my $stash = @_ == 1 ? shift : { @_ };
|
||||
my $buf = '';
|
||||
local $SIG{__DIE__};
|
||||
eval { _encode($self->{options}, $self->{script}, $stash, [], $buf) }
|
||||
or do { $self->{error} = $@; undef }
|
||||
}
|
||||
|
||||
|
||||
|
||||
# Encode tag value for encoding.
|
||||
# We assume that the tag has been correctly generated with asn_tag()
|
||||
|
||||
sub asn_encode_tag {
|
||||
$_[0] >> 8
|
||||
? $_[0] & 0x8000
|
||||
? $_[0] & 0x800000
|
||||
? pack("V",$_[0])
|
||||
: substr(pack("V",$_[0]),0,3)
|
||||
: pack("v", $_[0])
|
||||
: pack("C",$_[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 $ret;
|
||||
|
||||
local $SIG{__DIE__};
|
||||
eval {
|
||||
my (%stash, $result);
|
||||
my $script = $self->{script};
|
||||
my $stash = \$result;
|
||||
|
||||
while ($script) {
|
||||
my $child = $script->[0] or last;
|
||||
if (@$script > 1 or defined $child->[cVAR]) {
|
||||
$result = $stash = \%stash;
|
||||
last;
|
||||
}
|
||||
last if $child->[cTYPE] == opCHOICE or $child->[cLOOP];
|
||||
$script = $child->[cCHILD];
|
||||
}
|
||||
|
||||
_decode(
|
||||
$self->{options},
|
||||
$self->{script},
|
||||
$stash,
|
||||
0,
|
||||
length $_[0],
|
||||
undef,
|
||||
{},
|
||||
$_[0]);
|
||||
|
||||
$ret = $result;
|
||||
1;
|
||||
} or $self->{'error'} = $@ || 'Unknown error';
|
||||
|
||||
$ret;
|
||||
}
|
||||
|
||||
|
||||
sub asn_decode_length {
|
||||
return unless length $_[0];
|
||||
|
||||
my $len = unpack("C",$_[0]);
|
||||
|
||||
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 = unpack("C", $_[0]);
|
||||
my $n = 1;
|
||||
|
||||
if(($tag & 0x1f) == 0x1f) {
|
||||
my $b;
|
||||
do {
|
||||
return if $n >= length $_[0];
|
||||
$b = unpack("C",substr($_[0],$n,1));
|
||||
$tag |= $b << (8 * $n++);
|
||||
} while($b & 0x80);
|
||||
}
|
||||
($n, $tag);
|
||||
}
|
||||
|
||||
|
||||
sub asn_decode_tag2 {
|
||||
return unless length $_[0];
|
||||
|
||||
my $tag = unpack("C",$_[0]);
|
||||
my $num = $tag & 0x1f;
|
||||
my $len = 1;
|
||||
|
||||
if($num == 0x1f) {
|
||||
$num = 0;
|
||||
my $b;
|
||||
do {
|
||||
return if $len >= length $_[0];
|
||||
$b = unpack("C",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 .= pack("C",$r);
|
||||
}
|
||||
$result ^= pack("C",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 = unpack("C",$os) >= 0x80
|
||||
and $os ^= pack("C",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;
|
||||
Reference in New Issue
Block a user