464 lines
10 KiB
Perl
464 lines
10 KiB
Perl
# 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;
|