1# Copyright (c) 2000-2002 Graham Barr <gbarr@pobox.com>. All rights reserved. 2# This program is free software; you can redistribute it and/or 3# modify it under the same terms as Perl itself. 4 5package Convert::ASN1; 6$Convert::ASN1::VERSION = '0.33'; 7use 5.004; 8use strict; 9use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS @opParts @opName $AUTOLOAD); 10use Exporter; 11 12use constant CHECK_UTF8 => $] > 5.007; 13 14BEGIN { 15 local $SIG{__DIE__}; 16 eval { require bytes and 'bytes'->import }; 17 18 if (CHECK_UTF8) { 19 require Encode; 20 require utf8; 21 } 22 23 @ISA = qw(Exporter); 24 25 %EXPORT_TAGS = ( 26 io => [qw(asn_recv asn_send asn_read asn_write asn_get asn_ready)], 27 28 debug => [qw(asn_dump asn_hexdump)], 29 30 const => [qw(ASN_BOOLEAN ASN_INTEGER ASN_BIT_STR ASN_OCTET_STR 31 ASN_NULL ASN_OBJECT_ID ASN_REAL ASN_ENUMERATED 32 ASN_SEQUENCE ASN_SET ASN_PRINT_STR ASN_IA5_STR 33 ASN_UTC_TIME ASN_GENERAL_TIME ASN_RELATIVE_OID 34 ASN_UNIVERSAL ASN_APPLICATION ASN_CONTEXT ASN_PRIVATE 35 ASN_PRIMITIVE ASN_CONSTRUCTOR ASN_LONG_LEN ASN_EXTENSION_ID ASN_BIT)], 36 37 tag => [qw(asn_tag asn_decode_tag2 asn_decode_tag asn_encode_tag asn_decode_length asn_encode_length)] 38 ); 39 40 @EXPORT_OK = map { @$_ } values %EXPORT_TAGS; 41 $EXPORT_TAGS{all} = \@EXPORT_OK; 42 43 @opParts = qw( 44 cTAG cTYPE cVAR cLOOP cOPT cEXT cCHILD cDEFINE 45 ); 46 47 @opName = qw( 48 opUNKNOWN opBOOLEAN opINTEGER opBITSTR opSTRING opNULL opOBJID opREAL 49 opSEQUENCE opEXPLICIT opSET opUTIME opGTIME opUTF8 opANY opCHOICE opROID opBCD 50 opEXTENSIONS 51 ); 52 53 foreach my $l (\@opParts, \@opName) { 54 my $i = 0; 55 foreach my $name (@$l) { 56 my $j = $i++; 57 no strict 'refs'; 58 *{__PACKAGE__ . '::' . $name} = sub () { $j } 59 } 60 } 61} 62 63sub _internal_syms { 64 my $pkg = caller; 65 no strict 'refs'; 66 for my $sub (@opParts,@opName,'dump_op') { 67 *{$pkg . '::' . $sub} = \&{__PACKAGE__ . '::' . $sub}; 68 } 69} 70 71sub ASN_BOOLEAN () { 0x01 } 72sub ASN_INTEGER () { 0x02 } 73sub ASN_BIT_STR () { 0x03 } 74sub ASN_OCTET_STR () { 0x04 } 75sub ASN_NULL () { 0x05 } 76sub ASN_OBJECT_ID () { 0x06 } 77sub ASN_REAL () { 0x09 } 78sub ASN_ENUMERATED () { 0x0A } 79sub ASN_RELATIVE_OID () { 0x0D } 80sub ASN_SEQUENCE () { 0x10 } 81sub ASN_SET () { 0x11 } 82sub ASN_PRINT_STR () { 0x13 } 83sub ASN_IA5_STR () { 0x16 } 84sub ASN_UTC_TIME () { 0x17 } 85sub ASN_GENERAL_TIME () { 0x18 } 86 87sub ASN_UNIVERSAL () { 0x00 } 88sub ASN_APPLICATION () { 0x40 } 89sub ASN_CONTEXT () { 0x80 } 90sub ASN_PRIVATE () { 0xC0 } 91 92sub ASN_PRIMITIVE () { 0x00 } 93sub ASN_CONSTRUCTOR () { 0x20 } 94 95sub ASN_LONG_LEN () { 0x80 } 96sub ASN_EXTENSION_ID () { 0x1F } 97sub ASN_BIT () { 0x80 } 98 99 100sub new { 101 my $pkg = shift; 102 my $self = bless {}, $pkg; 103 104 $self->configure(@_); 105 $self; 106} 107 108 109sub configure { 110 my $self = shift; 111 my %opt = @_; 112 113 $self->{options}{encoding} = uc($opt{encoding} || 'BER'); 114 115 unless ($self->{options}{encoding} =~ /^[BD]ER$/) { 116 require Carp; 117 Carp::croak("Unsupported encoding format '$opt{encoding}'"); 118 } 119 120 # IMPLICIT as default for backwards compatibility, even though it's wrong. 121 $self->{options}{tagdefault} = uc($opt{tagdefault} || 'IMPLICIT'); 122 123 unless ($self->{options}{tagdefault} =~ /^(?:EXPLICIT|IMPLICIT)$/) { 124 require Carp; 125 Carp::croak("Default tagging must be EXPLICIT/IMPLICIT. Not $opt{tagdefault}"); 126 } 127 128 129 for my $type (qw(encode decode)) { 130 if (exists $opt{$type}) { 131 while(my($what,$value) = each %{$opt{$type}}) { 132 $self->{options}{"${type}_${what}"} = $value; 133 } 134 } 135 } 136} 137 138 139 140sub find { 141 my $self = shift; 142 my $what = shift; 143 return unless exists $self->{tree}{$what}; 144 my %new = %$self; 145 $new{script} = $new{tree}->{$what}; 146 bless \%new, ref($self); 147} 148 149 150sub prepare { 151 my $self = shift; 152 my $asn = shift; 153 154 $self = $self->new unless ref($self); 155 my $tree; 156 if( ref($asn) eq 'GLOB' ){ 157 local $/ = undef; 158 my $txt = <$asn>; 159 $tree = Convert::ASN1::parser::parse($txt,$self->{options}{tagdefault}); 160 } else { 161 $tree = Convert::ASN1::parser::parse($asn,$self->{options}{tagdefault}); 162 } 163 164 unless ($tree) { 165 $self->{error} = $@; 166 return; 167 ### If $self has been set to a new object, not returning 168 ### this object here will destroy the object, so the caller 169 ### won't be able to get at the error. 170 } 171 172 $self->{tree} = _pack_struct($tree); 173 $self->{script} = (values %$tree)[0]; 174 $self; 175} 176 177sub prepare_file { 178 my $self = shift; 179 my $asnp = shift; 180 181 local *ASN; 182 open( ASN, $asnp ) 183 or do{ $self->{error} = $@; return; }; 184 my $ret = $self->prepare( \*ASN ); 185 close( ASN ); 186 $ret; 187} 188 189sub registeroid { 190 my $self = shift; 191 my $oid = shift; 192 my $handler = shift; 193 194 $self->{options}{oidtable}{$oid}=$handler; 195 $self->{oidtable}{$oid}=$handler; 196} 197 198sub registertype { 199 my $self = shift; 200 my $def = shift; 201 my $type = shift; 202 my $handler = shift; 203 204 $self->{options}{handlers}{$def}{$type}=$handler; 205} 206 207# In XS the will convert the tree between perl and C structs 208 209sub _pack_struct { $_[0] } 210sub _unpack_struct { $_[0] } 211 212## 213## Encoding 214## 215 216sub encode { 217 my $self = shift; 218 my $stash = @_ == 1 ? shift : { @_ }; 219 my $buf = ''; 220 local $SIG{__DIE__}; 221 eval { _encode($self->{options}, $self->{script}, $stash, [], $buf) } 222 or do { $self->{error} = $@; undef } 223} 224 225 226 227# Encode tag value for encoding. 228# We assume that the tag has been correctly generated with asn_tag() 229 230sub asn_encode_tag { 231 $_[0] >> 8 232 ? $_[0] & 0x8000 233 ? $_[0] & 0x800000 234 ? pack("V",$_[0]) 235 : substr(pack("V",$_[0]),0,3) 236 : pack("v", $_[0]) 237 : pack("C",$_[0]); 238} 239 240 241# Encode a length. If < 0x80 then encode as a byte. Otherwise encode 242# 0x80 | num_bytes followed by the bytes for the number. top end 243# bytes of all zeros are not encoded 244 245sub asn_encode_length { 246 247 if($_[0] >> 7) { 248 my $lenlen = &num_length; 249 250 return pack("Ca*", $lenlen | 0x80, substr(pack("N",$_[0]), -$lenlen)); 251 } 252 253 return pack("C", $_[0]); 254} 255 256 257## 258## Decoding 259## 260 261sub decode { 262 my $self = shift; 263 my $ret; 264 265 local $SIG{__DIE__}; 266 eval { 267 my (%stash, $result); 268 my $script = $self->{script}; 269 my $stash = \$result; 270 271 while ($script) { 272 my $child = $script->[0] or last; 273 if (@$script > 1 or defined $child->[cVAR]) { 274 $result = $stash = \%stash; 275 last; 276 } 277 last if $child->[cTYPE] == opCHOICE or $child->[cLOOP]; 278 $script = $child->[cCHILD]; 279 } 280 281 _decode( 282 $self->{options}, 283 $self->{script}, 284 $stash, 285 0, 286 length $_[0], 287 undef, 288 {}, 289 $_[0]); 290 291 $ret = $result; 292 1; 293 } or $self->{'error'} = $@ || 'Unknown error'; 294 295 $ret; 296} 297 298 299sub asn_decode_length { 300 return unless length $_[0]; 301 302 my $len = unpack("C",$_[0]); 303 304 if($len & 0x80) { 305 $len &= 0x7f or return (1,-1); 306 307 return if $len >= length $_[0]; 308 309 return (1+$len, unpack("N", "\0" x (4 - $len) . substr($_[0],1,$len))); 310 } 311 return (1, $len); 312} 313 314 315sub asn_decode_tag { 316 return unless length $_[0]; 317 318 my $tag = unpack("C", $_[0]); 319 my $n = 1; 320 321 if(($tag & 0x1f) == 0x1f) { 322 my $b; 323 do { 324 return if $n >= length $_[0]; 325 $b = unpack("C",substr($_[0],$n,1)); 326 $tag |= $b << (8 * $n++); 327 } while($b & 0x80); 328 } 329 ($n, $tag); 330} 331 332 333sub asn_decode_tag2 { 334 return unless length $_[0]; 335 336 my $tag = unpack("C",$_[0]); 337 my $num = $tag & 0x1f; 338 my $len = 1; 339 340 if($num == 0x1f) { 341 $num = 0; 342 my $b; 343 do { 344 return if $len >= length $_[0]; 345 $b = unpack("C",substr($_[0],$len++,1)); 346 $num = ($num << 7) + ($b & 0x7f); 347 } while($b & 0x80); 348 } 349 ($len, $tag, $num); 350} 351 352 353## 354## Utilities 355## 356 357# How many bytes are needed to encode a number 358 359sub num_length { 360 $_[0] >> 8 361 ? $_[0] >> 16 362 ? $_[0] >> 24 363 ? 4 364 : 3 365 : 2 366 : 1 367} 368 369# Convert from a bigint to an octet string 370 371sub i2osp { 372 my($num, $biclass) = @_; 373 eval "use $biclass"; 374 $num = $biclass->new($num); 375 my $neg = $num < 0 376 and $num = abs($num+1); 377 my $base = $biclass->new(256); 378 my $result = ''; 379 while($num != 0) { 380 my $r = $num % $base; 381 $num = ($num-$r) / $base; 382 $result .= pack("C",$r); 383 } 384 $result ^= pack("C",255) x length($result) if $neg; 385 return scalar reverse $result; 386} 387 388# Convert from an octet string to a bigint 389 390sub os2ip { 391 my($os, $biclass) = @_; 392 eval "require $biclass"; 393 my $base = $biclass->new(256); 394 my $result = $biclass->new(0); 395 my $neg = unpack("C",$os) >= 0x80 396 and $os ^= pack("C",255) x length($os); 397 for (unpack("C*",$os)) { 398 $result = ($result * $base) + $_; 399 } 400 return $neg ? ($result + 1) * -1 : $result; 401} 402 403# Given a class and a tag, calculate an integer which when encoded 404# will become the tag. This means that the class bits are always 405# in the bottom byte, so are the tag bits if tag < 30. Otherwise 406# the tag is in the upper 3 bytes. The upper bytes are encoded 407# with bit8 representing that there is another byte. This 408# means the max tag we can do is 0x1fffff 409 410sub asn_tag { 411 my($class,$value) = @_; 412 413 die sprintf "Bad tag class 0x%x",$class 414 if $class & ~0xe0; 415 416 unless ($value & ~0x1f or $value == 0x1f) { 417 return (($class & 0xe0) | $value); 418 } 419 420 die sprintf "Tag value 0x%08x too big\n",$value 421 if $value & 0xffe00000; 422 423 $class = ($class | 0x1f) & 0xff; 424 425 my @t = ($value & 0x7f); 426 unshift @t, (0x80 | ($value & 0x7f)) while $value >>= 7; 427 unpack("V",pack("C4",$class,@t,0,0)); 428} 429 430 431BEGIN { 432 # When we have XS &_encode will be defined by the XS code 433 # so will all the subs in these required packages 434 unless (defined &_encode) { 435 require Convert::ASN1::_decode; 436 require Convert::ASN1::_encode; 437 require Convert::ASN1::IO; 438 } 439 440 require Convert::ASN1::parser; 441} 442 443sub AUTOLOAD { 444 require Convert::ASN1::Debug if $AUTOLOAD =~ /dump/; 445 goto &{$AUTOLOAD} if defined &{$AUTOLOAD}; 446 require Carp; 447 my $pkg = ref($_[0]) || ($_[0] =~ /^[\w\d]+(?:::[\w\d]+)*$/)[0]; 448 if ($pkg and UNIVERSAL::isa($pkg, __PACKAGE__)) { # guess it was a method call 449 $AUTOLOAD =~ s/.*:://; 450 Carp::croak(sprintf q{Can't locate object method "%s" via package "%s"},$AUTOLOAD,$pkg); 451 } 452 else { 453 Carp::croak(sprintf q{Undefined subroutine &%s called}, $AUTOLOAD); 454 } 455} 456 457sub DESTROY {} 458 459sub error { $_[0]->{error} } 4601; 461