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