1# Convert::BER.pm 2# 3# Copyright (c) 1995-1999 Graham Barr <gbarr@pobox.com>. All rights reserved. 4# This program is free software; you can redistribute it and/or 5# modify it under the same terms as Perl itself. 6 7package Convert::BER; 8 9use vars qw($VERSION @ISA); 10use Exporter (); 11use strict; 12use vars qw($VERSION @ISA @EXPORT_OK); 13 14BEGIN { 15 if ($] >= 5.006) { 16 require bytes; 'bytes'->import; 17 } 18 19 $VERSION = "1.32"; 20 21 @ISA = qw(Exporter); 22 23 @EXPORT_OK = qw( 24 BER_BOOLEAN 25 BER_INTEGER 26 BER_BIT_STR 27 BER_OCTET_STR 28 BER_NULL 29 BER_OBJECT_ID 30 BER_REAL 31 BER_SEQUENCE 32 BER_SET 33 34 BER_UNIVERSAL 35 BER_APPLICATION 36 BER_CONTEXT 37 BER_PRIVATE 38 39 BER_PRIMITIVE 40 BER_CONSTRUCTOR 41 42 BER_LONG_LEN 43 BER_EXTENSION_ID 44 BER_BIT 45 46 ber_tag 47 ); 48 49 # 5.003 does not have UNIVERSAL::can 50 unless(defined &UNIVERSAL::can) { 51 *UNIVERSAL::can = sub { 52 my($obj,$meth) = @_; 53 my $pkg = ref($obj) || $obj; 54 my @pkg = ($pkg); 55 my %done; 56 while(@pkg) { 57 $pkg = shift @pkg; 58 next if exists $done{$pkg}; 59 $done{$pkg} = 1; 60 61 no strict 'refs'; 62 63 unshift @pkg,@{$pkg . "::ISA"} 64 if(@{$pkg . "::ISA"}); 65 return \&{$pkg . "::" . $meth} 66 if defined(&{$pkg . "::" . $meth}); 67 } 68 undef; 69 } 70 } 71} 72 73## 74## Constants 75## 76 77sub BER_BOOLEAN () { 0x01 } 78sub BER_INTEGER () { 0x02 } 79sub BER_BIT_STR () { 0x03 } 80sub BER_OCTET_STR () { 0x04 } 81sub BER_NULL () { 0x05 } 82sub BER_OBJECT_ID () { 0x06 } 83sub BER_REAL () { 0x09 } 84sub BER_ENUMERATED () { 0x0A } 85sub BER_SEQUENCE () { 0x10 } 86sub BER_SET () { 0x11 } 87sub BER_PRINT_STR () { 0x13 } 88sub BER_IA5_STR () { 0x16 } 89sub BER_UTC_TIME () { 0x17 } 90sub BER_GENERAL_TIME () { 0x18 } 91 92sub BER_UNIVERSAL () { 0x00 } 93sub BER_APPLICATION () { 0x40 } 94sub BER_CONTEXT () { 0x80 } 95sub BER_PRIVATE () { 0xC0 } 96 97sub BER_PRIMITIVE () { 0x00 } 98sub BER_CONSTRUCTOR () { 0x20 } 99 100sub BER_LONG_LEN () { 0x80 } 101sub BER_EXTENSION_ID () { 0x1F } 102sub BER_BIT () { 0x80 } 103 104# This module is used a lot so performance matters. For that reason it 105# is implemented as an ARRAY instead of a HASH. 106# inlined constants for array indices 107 108sub _BUFFER () { 0 } 109sub _POS () { 1 } 110sub _INDEX () { 2 } 111sub _ERROR () { 3 } 112sub _PEER () { 4 } 113 114sub _PACKAGE () { 0 } 115sub _TAG () { 1 } 116sub _PACK () { 2 } 117sub _PACK_ARRAY () { 3 } 118sub _UNPACK () { 4 } 119sub _UNPACK_ARRAY () { 5 } 120 121{ 122 Convert::BER->define( 123 ## 124 ## Syntax operator 125 ## 126 127 [ BER => undef, undef ], 128 [ ANY => undef, undef ], 129 [ CONSTRUCTED => undef, undef ], 130 [ OPTIONAL => undef, undef ], 131 [ CHOICE => undef, undef ], 132 133 ## 134 ## Primitive operators 135 ## 136 137 [ BOOLEAN => undef, BER_UNIVERSAL | BER_PRIMITIVE | BER_BOOLEAN ], 138 [ INTEGER => undef, BER_UNIVERSAL | BER_PRIMITIVE | BER_INTEGER ], 139 [ STRING => undef, BER_UNIVERSAL | BER_PRIMITIVE | BER_OCTET_STR ], 140 [ NULL => undef, BER_UNIVERSAL | BER_PRIMITIVE | BER_NULL ], 141 [ OBJECT_ID => undef, BER_UNIVERSAL | BER_PRIMITIVE | BER_OBJECT_ID ], 142 [ BIT_STRING => undef, BER_UNIVERSAL | BER_PRIMITIVE | BER_BIT_STR ], 143 [ BIT_STRING8 => undef, BER_UNIVERSAL | BER_PRIMITIVE | BER_BIT_STR ], 144 [ REAL => undef, BER_UNIVERSAL | BER_PRIMITIVE | BER_REAL ], 145 146 [ SEQUENCE => undef, BER_UNIVERSAL | BER_CONSTRUCTOR | BER_SEQUENCE ], 147 [ SEQUENCE_OF => undef, BER_UNIVERSAL | BER_CONSTRUCTOR | BER_SEQUENCE ], 148 ); 149 150 ## 151 ## These variables will be defined by the above ->define() call 152 ## 153 154 use vars qw($INTEGER $SEQUENCE $STRING $SEQUENCE_OF); 155 156 Convert::BER->define( 157 ## 158 ## Sub-classed primitive operators 159 ## 160 161 [ ENUM => $INTEGER, BER_UNIVERSAL | BER_PRIMITIVE | BER_ENUMERATED ], 162 [ SET => $SEQUENCE, BER_UNIVERSAL | BER_CONSTRUCTOR | BER_SET ], 163 [ SET_OF => $SEQUENCE_OF, BER_UNIVERSAL | BER_CONSTRUCTOR | BER_SET ], 164 165 [ ObjectDescriptor => $STRING, BER_UNIVERSAL | 7], 166 [ UTF8String => $STRING, BER_UNIVERSAL | 12], 167 [ NumericString => $STRING, BER_UNIVERSAL | 18], 168 [ PrintableString => $STRING, BER_UNIVERSAL | 19], 169 [ TeletexString => $STRING, BER_UNIVERSAL | 20], 170 [ T61String => $STRING, BER_UNIVERSAL | 20], 171 [ VideotexString => $STRING, BER_UNIVERSAL | 21], 172 [ IA5String => $STRING, BER_UNIVERSAL | 22], 173 [ GraphicString => $STRING, BER_UNIVERSAL | 25], 174 [ VisibleString => $STRING, BER_UNIVERSAL | 26], 175 [ ISO646String => $STRING, BER_UNIVERSAL | 26], 176 [ GeneralString => $STRING, BER_UNIVERSAL | 27], 177 [ UTCTime => $STRING, BER_UNIVERSAL | 23], 178 [ GeneralizedTime => $STRING, BER_UNIVERSAL | 24], 179 ); 180 181 Convert::BER->define( 182 [ '_Time_generic' => $STRING, undef ], 183 [ TimeUZ => '_Time_generic', BER_UNIVERSAL | 23], 184 [ TimeUL => '_Time_generic', BER_UNIVERSAL | 23], 185 186 [ TimeGZ => '_Time_generic', BER_UNIVERSAL | 24], 187 [ TimeGL => '_Time_generic', BER_UNIVERSAL | 24], 188 ); 189} 190 191# only load Carp when needed 192 193sub croak { 194 require Carp; 195 goto &Carp::croak; 196} 197 198## 199## define: 200## does all the hard work of dynamically building the BER class 201## and BER-type classes 202## 203 204sub define { 205 my $pkg = shift; 206 207 no strict 'refs'; # we do some naughty stuff here :-) 208 209 $pkg = ref($pkg) || $pkg; 210 211 while(@_) { 212 my($name,$isa,$tag) = @{ $_[0] }; shift; 213 my $subpkg = $pkg . "::" . $name; 214 215 croak("Bad tag name '$name'") 216 if($name =~ /\A(?:DESTROY|VERSION)\Z/); 217 218 if(defined $isa) { 219 my $isapkg = $pkg->can('_' . $isa) or 220 croak "Unknown BER tag type '$isa'"; 221 222 @{$subpkg . "::ISA"} = ( &{$isapkg}()->[ _PACKAGE ] ) 223 unless @{$subpkg . "::ISA"}; 224 225 $tag = $subpkg->tag 226 unless defined $tag; 227 } 228 229 if(defined &{$subpkg . "::tag"}) { 230 croak "tags for '$name' do not match " 231 unless $subpkg->tag == $tag; 232 } 233 else { 234 *{$subpkg . "::tag"} = sub { $tag }; 235 } 236 237 push(@{$pkg . "::EXPORT_OK"}, '$' . $name, $name); 238 239 *{$pkg . "::" . $name} = \$name; 240 241 my @data = ( $subpkg, $subpkg->tag, 242 map { $subpkg->can($_) } 243 qw(pack pack_array unpack unpack_array) 244 ); 245 246 { 247 my $const = $tag; 248 *{$pkg . "::" . $name} = sub () { $const } 249 unless defined &{$pkg . "::" . $name}; 250 } 251 252 *{$pkg . "::_" . $name} = sub { \@data }; 253 } 254} 255 256# Now we have done the naughty stuff, make sure we do no more 257use strict; 258 259sub ber_tag { 260 my($t,$e) = @_; 261 $e ||= 0; # unsigned; 262 263 if($e < 30) { 264 return (($t & 0xe0) | $e); 265 } 266 267 $t = ($t | 0x1f) & 0xff; 268 if ($e & 0xffe00000) { 269 die "Too big"; 270 } 271 my @t = (); 272 273 push(@t, ($b >> 14) | 0x80) 274 if ($b = ($e & 0x001fc000)); 275 276 push(@t, ($b >> 7) | 0x80) 277 if ($b = ($e & 0xffffff80)); 278 279 unpack("V",pack("C4",$t,@t,$e & 0x7f,0,0)); 280} 281 282sub new { 283 my $package = shift; 284 my $class = ref($package) || $package; 285 286 my $self = bless [ 287 @_ == 1 ? shift : "", 288 0, 289 ref($package) ? $package->[ Convert::BER::_INDEX() ] : [], 290 ], $class; 291 292 @_ ? $self->encode(@_) : $self; 293} 294 295## 296## Some basic subs for packing/unpacking data 297## These methods would be called by the BER-type classes 298## 299 300sub num_length { 301 return 1 if ( ($_[0] & 0xff) == $_[0]); 302 return 2 if ( ($_[0] & 0xffff) == $_[0]); 303 return 3 if ( ($_[0] & 0xffffff) == $_[0]); 304 return 4; 305} 306 307sub pos { 308 my $ber = shift; 309 @_ ? ($ber->[ Convert::BER::_POS() ] = shift) 310 : $ber->[ Convert::BER::_POS() ]; 311} 312 313sub pack { 314 my $ber = shift; 315 $ber->[ Convert::BER::_BUFFER() ] .= $_[0]; 316 1; 317} 318 319sub unpack { 320 my($ber,$len) = @_; 321 my $pos = $ber->[ Convert::BER::_POS() ]; 322 my $npos = $pos + $len; 323 324 die "Buffer empty" 325 if ($npos > CORE::length($ber->[ Convert::BER::_BUFFER() ])); 326 327 $ber->[ Convert::BER::_POS() ] = $npos; 328 329 substr($ber->[ Convert::BER::_BUFFER() ],$pos,$len); 330} 331 332sub pack_tag { 333 my($ber,$tag) = @_; 334 335 # small tag number are more common, so check $tag size in reverse order 336 unless(($tag & 0x1f) == 0x1f) { 337 $ber->[ Convert::BER::_BUFFER() ] .= chr( $tag ); 338 return 1; 339 } 340 341 unless($tag & ~0x7fff) { 342 $ber->[ Convert::BER::_BUFFER() ] .= CORE::pack("v",$tag); 343 return 2; 344 } 345 346 unless($tag & ~0x7fffff) { 347 $ber->[ Convert::BER::_BUFFER() ] .= CORE::pack("vc",$tag, ($tag >> 16)); 348 return 3; 349 } 350 351 $ber->[ Convert::BER::_BUFFER() ] .= CORE::pack("V",$tag); 352 return 4; 353} 354 355sub unpack_tag { 356 my($ber,$expect) = @_; 357 my $pos = $ber->[ Convert::BER::_POS() ]; 358 my $len = CORE::length($ber->[ Convert::BER::_BUFFER() ]); 359 360 die "Buffer empty" 361 if($pos >= $len); 362 363 my $tag = CORE::unpack("C",substr($ber->[ Convert::BER::_BUFFER() ],$pos++,1 364)); 365 366 if(($tag & 0x1f) == 0x1f) { 367 my $b; 368 my $s = 8; 369 370 do { 371 die "Buffer empty" 372 if($pos >= $len); 373 $b = CORE::unpack("C",substr($ber->[ Convert::BER::_BUFFER() ],$pos++,1)); 374 $tag |= $b << $s; 375 $s += 8; 376 } while($b & 0x80); 377 } 378 379 die sprintf("Expecting tag 0x%x, found 0x%x",$expect,$tag) 380 if(defined($expect) && ($tag != $expect)); 381 382 $ber->[ Convert::BER::_POS() ] = $pos; 383 384 $tag 385} 386 387sub pack_length { 388 my($ber,$len) = @_; 389 390 if($len & ~0x7f) { 391 my $lenlen = num_length($len); 392 393 $ber->[ Convert::BER::_BUFFER() ] .= CORE::pack("C", $lenlen | 0x80) . substr(CORE::pack("N",$len), 0 - $lenlen); 394 395 return $lenlen + 1; 396 } 397 398 $ber->[ Convert::BER::_BUFFER() ] .= CORE::pack("C", $len); 399 return 1; 400} 401 402 403 404sub unpack_length { 405 my $ber = shift; 406 my $pos = $ber->[ Convert::BER::_POS() ]; 407 408 die "Buffer empty" 409 if($pos >= CORE::length($ber->[ Convert::BER::_BUFFER() ])); 410 411 my $len = CORE::unpack("C", substr($ber->[ Convert::BER::_BUFFER() ],$pos++,1)); 412 413 if($len & 0x80) { 414 my $buf; 415 416 $len &= 0x7f; 417 418 die "Buffer empty" 419 if(($pos+$len) > CORE::length($ber->[ Convert::BER::_BUFFER() ])); 420 421 my $tmp = "\0" x (4 - $len) . substr($ber->[ Convert::BER::_BUFFER() ],$pos,$len); 422 423 $pos += $len; 424 425 $len = $len ? CORE::unpack("N",$tmp) : -1; 426 } 427 428 $ber->[ Convert::BER::_POS() ] = $pos; 429 430 $len; 431} 432 433## 434## User interface (public) method 435## 436 437sub error { 438 my $ber = shift; 439 $ber->[ Convert::BER::_ERROR() ]; 440} 441 442 443sub tag { 444 my $ber = shift; 445 my $pos = $ber->[ Convert::BER::_POS() ]; 446 my $tag = eval { 447 local($SIG{'__DIE__'}); 448 unpack_tag($ber) 449 } or return undef; 450 $ber->[ Convert::BER::_POS() ] = $pos; 451 $tag; 452} 453 454sub length { 455 my $ber = shift; 456 457 CORE::length($ber->[ Convert::BER::_BUFFER() ]); 458} 459 460sub buffer { 461 my $ber = shift; 462 if(@_) { 463 $ber->[ Convert::BER::_POS() ] = 0; 464 $ber->[ Convert::BER::_BUFFER() ] = "" . shift; 465 } 466 $ber->[ Convert::BER::_BUFFER() ]; 467} 468 469## 470## just for debug :-) 471## 472 473sub _hexdump { 474 my($fmt,$pos) = @_[1,2]; # Don't copy buffer 475 476 $pos ||= 0; 477 478 my $offset = 0; 479 my $cnt = 1 << 4; 480 my $len = CORE::length($_[0]); 481 my $linefmt = ("%02X " x $cnt) . "%s\n"; 482 483 print "\n"; 484 485 while ($offset < $len) { 486 my $data = substr($_[0],$offset,$cnt); 487 my @y = CORE::unpack("C*",$data); 488 489 printf $fmt,$pos if $fmt; 490 491 # On the last time through replace '%02X ' with '__ ' for the 492 # missing values 493 substr($linefmt, 5*@y,5*($cnt-@y)) = "__ " x ($cnt - @y) 494 if @y != $cnt; 495 496 # Change non-printable chars to '.' 497 $data =~ s/[\x00-\x1f\x7f-\xff]/./sg; 498 printf $linefmt, @y,$data; 499 500 $offset += $cnt; 501 $pos += $cnt; 502 } 503} 504 505my %type = ( 506 split(/[\t\n]\s*/, 507 q(10 SEQUENCE 508 01 BOOLEAN 509 0A ENUM 510 11 SET 511 02 INTEGER 512 03 BIT STRING 513 C0 PRIVATE [%d] 514 04 STRING 515 40 APPLICATION [%d] 516 05 NULL 517 06 OBJECT ID 518 80 CONTEXT [%d] 519 ) 520 ) 521); 522 523sub dump { 524 my $ber = shift; 525 my $fh = @_ ? shift : \*STDERR; 526 527 my $ofh = select($fh); 528 529 my $pos = 0; 530 my $indent = ""; 531 my @seqend = (); 532 my $length = CORE::length($ber->[ Convert::BER::_BUFFER() ]); 533 my $fmt = $length > 0xffff ? "%08X" : "%04X"; 534 535 local $ber->[ Convert::BER::_POS() ]; 536 537 $ber->[ Convert::BER::_POS() ] = 0; 538 539 while(1) { 540 while (@seqend && $ber->[ Convert::BER::_POS() ] >= $seqend[0]) { 541 $indent = substr($indent,2); 542 shift @seqend; 543 printf "$fmt : %s}\n",$ber->[ Convert::BER::_POS() ],$indent; 544 } 545 last unless $ber->[ Convert::BER::_POS() ] < $length; 546 547 my $start = $ber->[ Convert::BER::_POS() ]; 548 my $tag = unpack_tag($ber); 549 my $pos = $ber->[ Convert::BER::_POS() ]; 550 my $len = Convert::BER::unpack_length($ber); 551 552 if($tag == 0 && $len == 0) { 553 $seqend[0] = 0; 554 redo; 555 } 556 printf $fmt. " %02X %4d: %s",$start,$tag,$len,$indent; 557 558 my $label = $type{sprintf("%02X",$tag & ~0x20)} 559 || $type{sprintf("%02X",$tag & 0xC0)} 560 || "UNIVERSAL [%d]"; 561 562 if (($tag & 0x1f) == 0x1f) { 563 my $k = $tag >> 8; 564 my $j = 0; 565 while($k) { 566 $j = ($j << 7) | ($k & 0x7f); 567 $k >>= 8; 568 } 569 my $l = $label; 570 $l =~ s/%d/0x%x/; 571 printf $l, $j; 572 } 573 else { 574 printf $label, $tag & ~0xE0; 575 } 576 577 if ($tag & BER_CONSTRUCTOR) { 578 print " {\n"; 579 if($len < 0) { 580 unshift(@seqend, ~(1<<31)); 581 } 582 else { 583 unshift(@seqend, $ber->[ Convert::BER::_POS() ] + $len); 584 } 585 $indent .= " "; 586 next; 587 } 588 589 $ber->[ Convert::BER::_POS() ] = $pos; 590 my $tmp; 591 592 for ($label) { # switch 593 /^INTEGER/ && do { 594 Convert::BER::INTEGER->unpack($ber,\$tmp); 595 printf " = %d\n",$tmp; 596 last; 597 }; 598 599 /^ENUM/ && do { 600 Convert::BER::ENUM->unpack($ber,\$tmp); 601 printf " = %d\n",$tmp; 602 last; 603 }; 604 605 /^BOOLEAN/ && do { 606 Convert::BER::BOOLEAN->unpack($ber,\$tmp); 607 printf " = %s\n",$tmp ? 'TRUE' : 'FALSE'; 608 last; 609 }; 610 611 /^OBJECT ID/ && do { 612 Convert::BER::OBJECT_ID->unpack($ber,\$tmp); 613 printf " = %s\n",$tmp; 614 last; 615 }; 616 617 /^NULL/ && do { 618 $ber->[ Convert::BER::_POS() ] = $pos+1; 619 print "\n"; 620 last; 621 }; 622 623 /^STRING/ && do { 624 Convert::BER::STRING->unpack($ber,\$tmp); 625 if ($tmp =~ /[\x00-\x1f\x7f-\xff]/s) { 626 _hexdump($tmp,$fmt . " : ".$indent, $pos); 627 } 628 else { 629 printf " = '%s'\n",$tmp; 630 } 631 last; 632 }; 633 634 /^BIT STRING/ && do { 635 Convert::BER::BIT_STRING->unpack($ber,\$tmp); 636 print " = ",$tmp,"\n"; 637 last; 638 }; 639 640 # default -- dump hex data 641 Convert::BER::STRING->unpack($ber,\$tmp); 642 _hexdump($tmp,$fmt . " : ".$indent, $pos); 643 } 644 } 645 646 select($ofh); 647} 648 649sub hexdump { 650 my $ber = shift; 651 my $fh = @_ ? shift : \*STDERR; 652 my $ofh = select($fh); 653 _hexdump($ber->[ Convert::BER::_BUFFER() ]); 654 print "\n"; 655 select($ofh); 656} 657 658## 659## And now the real guts of it, the encoding and decoding routines 660## 661 662sub encode { 663 my $ber = shift; 664 local($SIG{'__DIE__'}); 665 666 $ber->[ Convert::BER::_INDEX() ] = []; 667 668 return $ber 669 if eval { Convert::BER::_encode($ber,\@_) }; 670 671 $ber->[ Convert::BER::_ERROR() ] = $@; 672 673 undef; 674} 675 676sub _encode { 677 my $ber = shift; 678 my $desc = shift; 679 my $i = 0; 680 681 while($i < @$desc ) { 682 my $type = $desc->[$i++]; 683 my $arg = $desc->[$i++]; 684 my $tag = undef; 685 686 ($type,$tag) = @$type 687 if(ref($type) eq 'ARRAY'); 688 689 my $can = $ber->can('_' . $type); 690 691 die "Unknown element '$type'" 692 unless $can; 693 694 my $data = &$can(); 695 my $pkg = $data->[ Convert::BER::_PACKAGE() ]; 696 697 $tag = $data->[ Convert::BER::_TAG() ] 698 unless defined $tag; 699 700 $arg = &{$arg}(@{$ber->[ Convert::BER::_INDEX() ]}) 701 if(ref($arg) eq 'CODE'); 702 703 if(ref($arg) eq 'ARRAY') { 704 if($can = $data->[Convert::BER::_PACK_ARRAY() ]) { 705 pack_tag($ber,$tag) 706 if defined $tag; 707 708 &{$can}($pkg,$ber,$arg); 709 } 710 else { 711 my $a; 712 foreach $a (@$arg) { 713 pack_tag($ber,$tag) 714 if defined $tag; 715 716 &{$data->[Convert::BER::_PACK() ]}($pkg,$ber,$a); 717 } 718 } 719 } 720 else { 721 pack_tag($ber,$tag) 722 if defined $tag; 723 &{$data->[Convert::BER::_PACK() ]}($pkg,$ber,$arg); 724 } 725 } 726 727 1; 728} 729 730sub decode { 731 my $ber = shift; 732 my $pos = $ber->[ Convert::BER::_POS() ]; 733 local($SIG{'__DIE__'}); 734 735 $ber->[ Convert::BER::_INDEX() ] = []; 736 737 return $ber 738 if eval { Convert::BER::_decode($ber,\@_) }; 739 740 $ber->[ Convert::BER::_ERROR() ] = $@; 741 $ber->[ Convert::BER::_POS() ] = $pos; 742 743 undef; 744} 745 746sub _decode { 747 my $ber = shift; 748 my $desc = shift; 749 my $i = 0; 750 751 my $argc; 752 753TAG: 754 for($argc = @$desc ; $argc > 0 ; $argc -= 2) { 755 my $type = $desc->[$i++]; 756 my $arg = $desc->[$i++]; 757 my $tag = undef; 758 759 ($type,$tag) = @$type 760 if(ref($type) eq 'ARRAY'); 761 762 my $can = $ber->can('_' . $type); 763 764 die "Unknown element '$type'" 765 unless $can; 766 767 my $data = &$can(); 768 my $pkg = $data->[ Convert::BER::_PACKAGE() ]; 769 770 $tag = $data->[ Convert::BER::_TAG() ] 771 unless defined $tag; 772 773 $arg = &{$arg}(@{$ber->[ Convert::BER::_INDEX() ]}) 774 if(ref($arg) eq 'CODE'); 775 776 if(ref($arg) eq 'ARRAY') { 777 if($data->[ Convert::BER::_UNPACK_ARRAY() ]) { 778 779 unpack_tag($ber,$tag) 780 if(defined $tag); 781 782 &{$data->[ Convert::BER::_UNPACK_ARRAY() ]}($pkg,$ber,$arg); 783 } 784 else { 785 @$arg = (); 786 while(CORE::length($ber->[ Convert::BER::_BUFFER() ]) > $ber->[ Convert::BER::_POS() ]) { 787 if(defined $tag) { 788 next TAG 789 unless eval { unpack_tag($ber,$tag) }; 790 } 791 792 push @$arg, undef; 793 &{$data->[ Convert::BER::_UNPACK() ]}($pkg,$ber,\$arg->[-1]); 794 } 795 } 796 } 797 else { 798 eval { 799 unpack_tag($ber,$tag) 800 if(defined $tag); 801 802 &{$data->[ Convert::BER::_UNPACK() ]}($pkg,$ber,$arg); 803 1; 804 } or ($$arg = undef, die); 805 } 806 } 807 808 1; 809} 810 811## 812## a couple of routines to interface to a file descriptor. 813## 814 815sub read { 816 my $ber = shift; 817 my $io = shift; 818 my $indef = shift; 819 820 # We need to read one packet, and exactly only one packet. 821 # So we have to read the first few bytes one at a time, until 822 # we have enough to decode a tage and a length. We then know 823 # how many more bytes to read 824 825 $ber = $ber->new unless ref($ber); 826 $ber->[ _BUFFER() ] = "" unless $indef; 827 828 my $pos = CORE::length($ber->[ _BUFFER() ]); 829 my $start = $pos; 830 831 # The first byte is the tag 832 sysread($io,$ber->[ _BUFFER() ],1,$pos++) or 833 goto READ_ERR; 834 835# print STDERR "-"x80,"\n"; 836# print STDERR CORE::unpack("H*",$ber->[ _BUFFER() ]),"\n"; 837 838 my $ch = ord(substr($ber->[ _BUFFER() ],-1)); 839 840 # Tag may be multi-byte 841 if(($ch & 0x1f) == 0x1f) { 842 do { 843 sysread($io, $ber->[ _BUFFER() ], 1, $pos++) or 844 goto READ_ERR; 845 846 $ch = ord(substr($ber->[ _BUFFER() ],-1)); 847 848 } while($ch & 0x80); 849 } 850 851# print STDERR CORE::unpack("H*",$ber->[ _BUFFER() ]),"\n"; 852 853 # The next byte will be the first byte of the length 854 sysread($io, $ber->[ _BUFFER() ], 1, $pos++) or 855 goto READ_ERR; 856 857# print STDERR CORE::unpack("H*",$ber->[ _BUFFER() ]),"\n"; 858 859 $ch = ord(substr($ber->[ _BUFFER() ],-1)); 860# print STDERR CORE::unpack("H*",substr($ber->[ _BUFFER() ],-1))," $ch\n"; 861 862 # May be a multi-byte length 863 if($ch & 0x80) { 864 my $len = $ch & 0x7f; 865 unless ($len) { 866# print STDERR CORE::unpack("H*",$ber->[ _BUFFER() ]),"\n"; 867 # OK we have an indefinate length 868 while(1) { 869 Convert::BER::read($ber,$io,1); 870 my $p = CORE::length($ber->[ _BUFFER() ]); 871 if(($p - $pos) == 2 && substr($ber->[ _BUFFER() ],-2) eq "\0\0") { 872# print STDERR CORE::unpack("H*",$ber->[ _BUFFER() ]),"\n","-"x80,"\n"; 873 return $ber; 874 } 875 $pos = $p; 876 } 877 } 878 while($len) { 879 my $n = sysread($io, $ber->[ _BUFFER() ], $len, $pos) or 880 goto READ_ERR; 881 $len -= $n; 882 $pos += $n; 883 } 884 } 885 886# print STDERR CORE::unpack("H*",$ber->[ _BUFFER() ]),"\n"; 887 888 # We can now unpack a tage and a length to determine how many more 889 # bytes to read 890 891 $ber->[ _POS() ] = $start; 892 unpack_tag($ber); 893 my $len = unpack_length($ber); 894 895 while($len > 0) { 896 my $got; 897 898 goto READ_ERR 899 unless( $got = sysread($io, $ber->[ _BUFFER() ],$len,CORE::length($ber->[ _BUFFER() ])) ); 900 901 $len -= $got; 902 } 903 904 # Reset pos back to the beginning. 905 $ber->[ _POS() ] = 0; 906 907# print STDERR CORE::unpack("H*",$ber->[ _BUFFER() ]),"\n"; 908 return $ber; 909 910READ_ERR: 911 $@ = "I/O Error $! " . CORE::unpack("H*",$ber->[ _BUFFER() ]); 912 return undef; 913} 914 915sub write { 916 my $ber = shift; 917 my $io = shift; 918 local($SIG{'__DIE__'}); 919 920 my $togo = CORE::length($ber->[ _BUFFER() ]); 921 my $pos = 0; 922 923 while($togo) { 924 my $len; 925 926 unless ($len = syswrite($io, $ber->[ _BUFFER() ],$togo,$pos)) { 927 $@ = "I/O Error $!"; 928 return; 929 } 930 931 $togo -= $len; 932 $pos += $len; 933 } 934 935 1; 936} 937 938sub send { 939 my $ber = shift; 940 my $sock = shift; 941 942 local($SIG{'__DIE__'}); 943 944 eval { 945 # Enable reporting a 'Broken pipe' error rather than dying. 946 local ($SIG{PIPE}) = "IGNORE"; 947 948 @_ ? send($sock,$ber->[ _BUFFER() ],0,$_[0]) 949 : send($sock,$ber->[ _BUFFER() ],0); 950 } or die "I/O Error: $!"; 951} 952 953sub recv { 954 my $ber = shift; 955 my $sock = shift; 956 957 require Socket; # for Socket::MSG_PEEK 958 959 local $SIG{'__DIE__'}; 960 961 $ber = $ber->new unless ref($ber); 962 $ber->[ _BUFFER() ] = ""; 963 964 # We do not know the size of the datagram, so we have to PEEK --GMB 965 # is there an easier way to determine the packet size ?? 966 967 my $n = 128; 968 die "I/O Error: $!" 969 unless ((defined recv($sock,$ber->[ _BUFFER() ],$n,Socket::MSG_PEEK())) 970 and not $!); 971 972 # PEEK until we have the complete tag and length of the BER 973 # packet. Use the length to determine how much data to read from 974 # the socket. This is an attempt to ensure that we read the 975 # entire packet and that we don't read into the next packet, if 976 # there is one. 977 978 my $len; 979 980 # Keep reading until we've read enough of the packet to unpack 981 # the BER length field. 982 for(;;) { 983 984 # If we can decode a tag and length we can detemine the length 985 986 if(defined($len = eval { 987 $ber->[ _POS() ] = 0; 988 unpack_tag($ber); 989 unpack_length($ber) 990 + $ber->[ _POS() ]; 991 }) 992 # unpack_length will return -1 for unknown length 993 && $len >= $ber->[ _POS() ]) { 994 995 $n = $len; 996 last; 997 } 998 999 # peek some more 1000 $n <<= 1; 1001 die "I/O Error: $!" 1002 unless ((defined recv($sock,$ber->[ _BUFFER() ],$n,Socket::MSG_PEEK())) 1003 and not $!); 1004 } 1005 1006 # now we know the size, get it again but without MSG_PEEK 1007 # this will cause the kernel to remove the datagram from it's queue 1008 1009 # If the data on the socket doesn't correspond to a valid BER 1010 # object, the loop above could have read something it thought was 1011 # the length and this loop could then block waiting for that many 1012 # bytes, which will never arrive. What do you do about something 1013 # like that? 1014 1015 $ber->[ _POS() ] = 0; 1016 $ber->[ _BUFFER() ] = ""; 1017 my ($read, $tmp); 1018 $read = 0; 1019 while ($read < $n) { 1020 $ber->[ _PEER() ] = recv($sock, $tmp, $n - $read, 0); 1021 die "I/O Error: $!" 1022 unless ((defined ( $ber->[ _PEER() ] ) and not $!)); 1023 1024 $read += CORE::length($tmp); 1025 $ber->[ _BUFFER() ] .= $tmp; 1026 } 1027 $ber; 1028} 1029 1030## 1031## The primitive packages 1032## 1033 1034package Convert::BER::BER; 1035 1036sub pack { 1037 my($self,$ber,$arg) = @_; 1038 1039 $ber->[ Convert::BER::_BUFFER() ] .= $arg->[ Convert::BER::_BUFFER() ] 1040 if ref($arg); 1041 1042 1; 1043} 1044 1045sub unpack { 1046 my($self,$ber,$arg) = @_; 1047 1048 my $len = CORE::length($ber->[ Convert::BER::_BUFFER() ]) - $ber->[ Convert::BER::_POS() ]; 1049 1050 $$arg = $ber->new(Convert::BER::unpack($ber,$len)); 1051 1052 1; 1053} 1054 1055package Convert::BER::ANY; 1056 1057sub pack { 1058 my($self,$ber,$arg) = @_; 1059 1060 $ber->[ Convert::BER::_BUFFER() ] .= $arg->[ Convert::BER::_BUFFER() ]; 1061 1062 1; 1063} 1064 1065sub unpack { 1066 my($self,$ber,$arg) = @_; 1067 1068 my $pos = $ber->[ Convert::BER::_POS() ]; 1069 my $tag = Convert::BER::unpack_tag($ber); 1070 my $len = Convert::BER::unpack_length($ber) + $ber->[ Convert::BER::_POS() ] - $pos; 1071 $ber->[ Convert::BER::_POS() ] = $pos; 1072 1073 $$arg = $ber->new(Convert::BER::unpack($ber,$len)); 1074 1075 1; 1076} 1077 1078## 1079## 1080## 1081 1082package Convert::BER::BOOLEAN; 1083 1084sub pack { 1085 my($self,$ber,$arg) = @_; 1086 1087 Convert::BER::pack_length($ber,1); 1088 $ber->[ Convert::BER::_BUFFER() ] .= CORE::pack("c", $arg ? 0xff : 0x00); 1089 1090 1; 1091} 1092 1093sub unpack { 1094 my($self,$ber,$arg) = @_; 1095 1096 my $len = Convert::BER::unpack_length($ber); 1097 1098 $$arg = CORE::unpack("c", Convert::BER::unpack($ber,$len)) ? 1 : 0; 1099 1100 1; 1101} 1102 1103## 1104## 1105## 1106 1107package Convert::BER::INTEGER; 1108 1109## 1110## Math::BigInt support 1111## 1112 1113sub pack_bigint { 1114 my($self,$ber,$arg) = @_; 1115 1116 require Math::BigInt; 1117 1118 my $neg = ($arg < 0) ? 1 : 0; 1119 my @octet = (); 1120 my $num = new Math::BigInt(abs($arg)); 1121 1122 $num -= 1 if $neg; 1123 while($num > 0) { 1124 my($i,$y) = $num->bdiv(256); 1125 $num = new Math::BigInt($i); 1126 $y = $y ^ 0xff if $neg; 1127 unshift(@octet,$y); 1128 } 1129 @octet = (0) unless @octet; 1130 1131 my $msb = ($octet[0] & 0x80) ? 1 : 0; 1132 1133 unshift(@octet,$neg ? 0xff : 0x00) 1134 if($neg != $msb); 1135 1136 Convert::BER::pack_length($ber, scalar @octet); 1137 1138 $ber->[ Convert::BER::_BUFFER() ] .= CORE::pack("C*",@octet); 1139 1140 1; 1141} 1142 1143sub unpack_bigint { 1144 my($self,$ber,$arg) = @_; 1145 1146 require Math::BigInt; 1147 1148 my $len = Convert::BER::unpack_length($ber); 1149 my @octet = CORE::unpack("C*",Convert::BER::unpack($ber,$len)); 1150 my $neg = ($octet[0] & 0x80) ? 1 : 0; 1151 my $val = $$arg = 0; 1152 1153 while(@octet) { 1154 my $oct = shift @octet; 1155 $oct = $oct ^ 0xff 1156 if $neg; 1157 $val *= (1<<8); 1158 $val += $oct; 1159 } 1160 1161 $val = -1 - $val 1162 if $neg; 1163 1164 1; 1165} 1166 1167## 1168## Math::BigInteger support 1169## 1170 1171sub pack_biginteger { 1172 my($self,$ber,$arg) = @_; 1173 1174 my($len,$data); 1175 my $offset = 0; 1176 1177 require Math::BigInteger; 1178 # save has no concept of +/- 1179 my $v = $arg->cmp(new Math::BigInteger(0)); 1180 1181 if($v) { 1182 if($v < 0) { 1183 my $b = $arg->bits + 8; 1184 $b -= $b % 8; 1185 my $tmp = new Math::BigInteger(1); 1186 $tmp->lshift(new Math::BigInteger(1), $b); 1187 $arg = $tmp + $arg; 1188 } 1189 1190 $data = $arg->save; 1191 $len = CORE::length($data); 1192 1193 my $c = ord(substr($data,0,1)); 1194 1195 if($c == 0) { 1196 for( ; $len > 1 ; $len--, $offset++) { 1197 my $ch = ord(substr($data,$offset,1)); 1198 if($ch & 0xff) { 1199 if($ch & 0x80) { 1200 $len++; 1201 $offset--; 1202 } 1203 last; 1204 } 1205 } 1206 } 1207 elsif($c == 0xff) { 1208 for( ; $len > 1 ; $len--, $offset++) { 1209 my $ch = ord(substr($data,$offset,1)); 1210 unless($ch == 0xff) { 1211 unless($ch & 0x80) { 1212 $len++; 1213 $offset--; 1214 } 1215 last; 1216 } 1217 } 1218 } 1219 } 1220 else { 1221 $len = 1; 1222 $data = CORE::pack("C",0); 1223 } 1224 1225 Convert::BER::pack_length($ber,$len); 1226 $ber->[ Convert::BER::_BUFFER() ] .= substr($data,$offset); 1227 1228 return 1; 1229} 1230 1231sub unpack_biginteger { 1232 my($self,$ber,$arg) = @_; 1233 1234 require Math::BigInteger; 1235 1236 my $len = Convert::BER::unpack_length($ber); 1237 my $data = Convert::BER::unpack($ber,$len); 1238 my $int = restore Math::BigInteger $data; 1239 1240 # restore has no concept of +/- 1241 if(ord(substr($data,0,1)) & 0x80) { 1242 my $tmp = new Math::BigInteger; 1243 $tmp->lshift(new Math::BigInteger(1), $len * 8); 1244 $tmp = new Math::BigInteger(0) - $tmp; 1245 $int = $tmp + $int; 1246 } 1247 $$arg = $int; 1248 1249 return 1; 1250} 1251 1252## 1253## 1254## 1255 1256sub pack { 1257 my($self,$ber,$arg) = @_; 1258 1259 if(ref $arg) { 1260 goto &pack_bigint 1261 if UNIVERSAL::isa($arg,'Math::BigInt'); 1262 1263 goto &pack_biginteger 1264 if UNIVERSAL::isa($arg,'Math::BigInteger'); 1265 } 1266 1267 my $neg = ($arg < 0) ? 1 : 0; 1268 1269 my $len = Convert::BER::num_length($neg ? ~ $arg : $arg); 1270 1271 my $msb = $arg & (0x80 << (($len - 1) * 8)); 1272 1273 $len++ 1274 if(($msb && not($neg)) || ($neg && not($msb))); 1275 Convert::BER::pack_length($ber,$len); 1276 $ber->[ Convert::BER::_BUFFER() ] .= substr(CORE::pack("N",$arg), 0 - $len); 1277 1278 1; 1279} 1280 1281sub unpack { 1282 my($self,$ber,$arg) = @_; 1283 1284 if( ref($arg) && ref($$arg) ) { 1285 goto &unpack_bigint 1286 if UNIVERSAL::isa($$arg,'Math::BigInt'); 1287 1288 goto &unpack_biginteger 1289 if UNIVERSAL::isa($$arg,'Math::BigInteger'); 1290 } 1291 1292 my $len = Convert::BER::unpack_length($ber); 1293 my $tmp = "\0" x (4 - $len) . Convert::BER::unpack($ber,$len); 1294 my $val = CORE::unpack("N",$tmp); 1295 1296 $val -= 0x1 << ($len * 8) 1297 if($val & (0x1 << (($len * 8) - 1))); 1298 1299 $$arg = $val; 1300 1301 1; 1302} 1303 1304## 1305## 1306## 1307 1308package Convert::BER::NULL; 1309 1310sub pack { 1311 my($self,$ber,$arg) = @_; 1312 1313 Convert::BER::pack_length($ber,0); 1314} 1315 1316sub unpack { 1317 my($self,$ber,$arg) = @_; 1318 1319 Convert::BER::unpack_length($ber); 1320 1321 $$arg = 1; 1322} 1323 1324## 1325## 1326## 1327 1328package Convert::BER::STRING; 1329 1330sub pack { 1331 my($self,$ber,$arg) = @_; 1332 1333 Convert::BER::pack_length($ber,CORE::length($arg)); 1334 $ber->[ Convert::BER::_BUFFER() ] .= $arg; 1335} 1336 1337sub unpack { 1338 my($self,$ber,$arg) = @_; 1339 1340 my $len = Convert::BER::unpack_length($ber); 1341 $$arg = Convert::BER::unpack($ber,$len); 1342 1343 1; 1344} 1345 1346## 1347## 1348## 1349 1350package Convert::BER::SEQUENCE; 1351 1352sub pack { 1353 my($self,$ber,$arg) = @_; 1354 1355 Convert::BER::pack_length($ber,CORE::length($arg->[ Convert::BER::_BUFFER() ])); 1356 $ber->[ Convert::BER::_BUFFER() ] .= $arg->[ Convert::BER::_BUFFER() ]; 1357 1358 1; 1359} 1360 1361sub unpack { 1362 my($self,$ber,$arg) = @_; 1363 1364 my $len = Convert::BER::unpack_length($ber); 1365 $$arg = $ber->new(Convert::BER::unpack($ber,$len)); 1366 1367 1; 1368} 1369 1370sub pack_array { 1371 my($self,$ber,$arg) = @_; 1372 1373 my $ber2 = $ber->new; 1374 1375 return undef 1376 unless defined($ber2->_encode($arg)); 1377 1378 Convert::BER::pack_length($ber,CORE::length($ber2->[ Convert::BER::_BUFFER() ])); 1379 $ber->[ Convert::BER::_BUFFER() ] .= $ber2->[ Convert::BER::_BUFFER() ]; 1380 1381 1; 1382} 1383 1384sub unpack_array { 1385 my($self,$ber,$arg) = @_; 1386 1387 my $ber2; 1388 1389 $self->unpack($ber,\$ber2); 1390 1391 $ber2->_decode($arg); 1392 1393 die "Sequence buffer not empty" 1394 if CORE::length($ber2->[ Convert::BER::_BUFFER() ]) != $ber2->[ Convert::BER::_POS() ]; 1395 1396 1; 1397} 1398 1399## 1400## 1401## 1402 1403package Convert::BER::OBJECT_ID; 1404 1405sub pack { 1406 my($self,$ber,$arg) = @_; 1407 my @data = ($arg =~ /(\d+)/g); 1408 1409 if(@data < 2) { 1410 @data = (0); 1411 } 1412 else { 1413 my $first = $data[1] + ($data[0] * 40); 1414 splice(@data,0,2,$first); 1415 } 1416 1417 @data = map { 1418 my @d = ($_); 1419 if($_ >= 0x80) { 1420 @d = (); 1421 my $v = 0 | $_; # unsigned 1422 while($v) { 1423 unshift(@d, 0x80 | ($v & 0x7f)); 1424 $v >>= 7; 1425 } 1426 $d[-1] &= 0x7f; 1427 } 1428 @d; 1429 } @data; 1430 1431 my $data = CORE::pack("C*", @data); 1432 1433 Convert::BER::pack_length($ber,CORE::length($data)); 1434 $ber->[ Convert::BER::_BUFFER() ] .= $data; 1435 1436 1; 1437} 1438 1439sub unpack { 1440 my($self,$ber,$arg) = @_; 1441 1442 my $len = Convert::BER::unpack_length($ber); 1443 my @ch = CORE::unpack("C*",Convert::BER::unpack($ber,$len)); 1444 my @data = (); 1445 my $val = 0; 1446 while(@ch) { 1447 my $ch = shift @ch; 1448 $val = ($val << 7) | ($ch & 0x7f); 1449 unless($ch & 0x80) { 1450 push @data, $val; 1451 $val = 0; 1452 } 1453 } 1454 if(@data) { 1455 my $first = shift @data; 1456 unshift @data, $first % 40; 1457 unshift @data, int($first / 40); 1458# unshift @data, ""; 1459 } 1460 $$arg = join(".",@data); 1461 1; 1462} 1463 1464## 1465## 1466## 1467 1468package Convert::BER::CONSTRUCTED; 1469 1470BEGIN { 1471 # Cannot call import here as Convert::BER has not been initialized 1472 *BER_CONSTRUCTOR = *Convert::BER::BER_CONSTRUCTOR 1473} 1474 1475sub pack { 1476 my($self,$ber,$arg) = @_; 1477 1478 Convert::BER::pack_tag($ber,$arg->tag | BER_CONSTRUCTOR); 1479 Convert::BER::pack_length($ber,CORE::length($arg->[ Convert::BER::_BUFFER() ])); 1480 $ber->[ Convert::BER::_BUFFER() ] .= $arg->[ Convert::BER::_BUFFER() ]; 1481 1482 1; 1483} 1484 1485sub unpack { 1486 my($self,$ber,$arg) = @_; 1487 my $tag = Convert::BER::unpack_tag($ber); 1488 1489 die "Not constructed" 1490 unless $tag & BER_CONSTRUCTOR; 1491 1492 my $len = Convert::BER::unpack_length($ber); 1493 my $buf = $ber->new( Convert::BER::unpack($ber,$len)); 1494 1495 die &{$ber}(0,"Bad construction") 1496 unless( ($buf->tag | BER_CONSTRUCTOR) == $tag); 1497 1498 $$arg = $buf; 1499 1500 1; 1501} 1502 1503sub pack_array { 1504 my($self,$ber,$arg) = @_; 1505 1506 $self->_encode($arg); 1507} 1508 1509sub unpack_array { 1510 my($self,$ber,$arg) = @_; 1511 1512 my $ber2; 1513 1514 $self->unpack($ber,\$ber2); 1515 1516 $ber2->_decode($arg); 1517} 1518 1519## 1520## 1521## 1522 1523package Convert::BER::OPTIONAL; 1524 1525# optional elements 1526# allows skipping in the encode if it comes across structures like 1527# OPTIONAL => [ BOOLEAN => undef ] 1528# or more realistically 1529# my $foo = undef; 1530# $foo = 1 if (arg->{'allowed'}; 1531# $ber->encode(SEQUENCE => [ 1532# STRING => $name, 1533# OPTIONAL => [ BOOLEAN => $foo ] 1534# ]); 1535 1536sub pack_array { 1537 my($self,$ber,$arg) = @_; 1538 my $a; 1539 my @newarg; 1540 foreach $a (@$arg) { 1541 return unless defined $a; 1542 my $c = ref($a) eq "CODE" 1543 ? &{$a}(@{$ber->[ Convert::BER::_INDEX() ]}) 1544 : $a; 1545 return unless defined $c; 1546 push @newarg, $c; 1547 } 1548 1549 shift @newarg if (@newarg & 1); 1550 1551 Convert::BER::_encode($ber,\@newarg); 1552} 1553 1554sub unpack_array { 1555 my($self,$ber,$arg) = @_; 1556 my($yes,$ref); 1557 my $pos = $ber->[ Convert::BER::_POS() ]; 1558 1559 if(@$arg & 1) { 1560 $ref = [ @$arg ]; 1561 $yes = shift @$ref; 1562 } 1563 else { 1564 $ref = $arg; 1565 } 1566 1567 if (eval { Convert::BER::_decode($ber,$ref) }) { 1568 $$yes = 1 if ref($yes); 1569 } 1570 else { 1571 $$yes = undef if ref($yes); 1572 $ber->[ Convert::BER::_POS() ] = $pos; 1573 } 1574 1575 1; 1576} 1577 1578## 1579## 1580## 1581 1582package Convert::BER::SEQUENCE_OF; 1583 1584sub pack_array { 1585 my($self,$ber,$arg) = @_; 1586 my($n,@desc) = @$arg; 1587 my $i; 1588 1589 $n = &{$n}(@{$ber->[ Convert::BER::_INDEX() ]}) 1590 if ref($n) eq 'CODE'; 1591 1592 push(@{$ber->[ Convert::BER::_INDEX() ]},0); 1593 1594 my $b = $ber->new; 1595 1596 if(ref($n) eq 'HASH') { 1597 my $v; 1598 foreach $v (keys %$n) { 1599 $ber->[ Convert::BER::_INDEX() ][-1] = $v; 1600 $b->_encode(\@desc); 1601 } 1602 } 1603 elsif(ref($n) eq 'ARRAY') { 1604 my $v; 1605 foreach $v (@$n) { 1606 $ber->[ Convert::BER::_INDEX() ][-1] = $v; 1607 $b->_encode(\@desc); 1608 } 1609 } 1610 else { 1611 while($n--) { 1612 $b->_encode(\@desc); 1613 $ber->[ Convert::BER::_INDEX() ][-1] += 1; 1614 } 1615 } 1616 1617 pop @{$ber->[ Convert::BER::_INDEX() ]}; 1618 1619 Convert::BER::pack_length($ber,CORE::length($b->[ Convert::BER::_BUFFER() ])); 1620 $ber->[ Convert::BER::_BUFFER() ] .= $b->[ Convert::BER::_BUFFER() ]; 1621 1622 1; 1623} 1624 1625sub unpack_array { 1626 my($self,$ber,$arg) = @_; 1627 my($nref,@desc) = @$arg; 1628 1629 push(@{$ber->[ Convert::BER::_INDEX() ]},0); 1630 1631 my $len = Convert::BER::unpack_length($ber); 1632 my $b = $ber->new(Convert::BER::unpack($ber,$len)); 1633 my $pos = $ber->[ Convert::BER::_POS() ]; 1634 my $n; 1635 1636 while(CORE::length($b->[ Convert::BER::_BUFFER() ]) > $b->[ Convert::BER::_POS() ]) { 1637 $b->_decode(\@desc); 1638 $ber->[ Convert::BER::_INDEX() ][-1] += 1; 1639 } 1640 1641 $$nref = pop @{$ber->[ Convert::BER::_INDEX() ]}; 1642 1; 1643} 1644 1645## 1646## 1647## 1648 1649package Convert::BER::BIT_STRING; 1650 1651sub pack { 1652 my($self,$ber,$arg) = @_; 1653 1654 my $less = (8 - (CORE::length($arg) & 7)) & 7; 1655 $arg .= "0" x $less if $less; 1656 my $data = CORE::pack("B*",$arg); 1657 Convert::BER::pack_length($ber,CORE::length($data)+1); 1658 $ber->[ Convert::BER::_BUFFER() ] .= chr($less) . $data; 1659} 1660 1661sub unpack { 1662 my($self,$ber,$arg) = @_; 1663 1664 my $len = Convert::BER::unpack_length($ber); 1665 my $data = Convert::BER::unpack($ber,$len); 1666 my $less; 1667 ($less,$data) = CORE::unpack("C B*",$data,); 1668 $less = ord($less) & 7; 1669 substr($data,-$less) = '' if $less; 1670 $$arg = $data; 1671 1; 1672} 1673 1674## 1675## 1676## 1677 1678package Convert::BER::BIT_STRING8; 1679 1680sub pack { 1681 my($self,$ber,$arg) = @_; 1682 1683 Convert::BER::pack_length($ber,CORE::length($arg)+1); 1684 $ber->[ Convert::BER::_BUFFER() ] .= chr(0) . $arg; 1685} 1686 1687sub unpack { 1688 my($self,$ber,$arg) = @_; 1689 1690 my $len = Convert::BER::unpack_length($ber); 1691 my $less = Convert::BER::unpack($ber,1); 1692 my $data = $len > 1 ? Convert::BER::unpack($ber,$len-1) : ""; 1693 $$arg = $data; 1694 1; 1695} 1696 1697## 1698## 1699## 1700 1701package Convert::BER::REAL; 1702 1703sub pack { 1704 my($self,$ber,$arg) = @_; 1705 require POSIX; 1706 my $data = ""; 1707 1708 if($arg) { 1709 my $s = 128; 1710 if($arg < 0) { 1711 $s |= 64; 1712 $arg = -$arg; 1713 } 1714 my @e = (); 1715 my @m = (); 1716 my($v,$e) = POSIX::frexp($arg); 1717 $e -= 53; 1718 my $ae = abs($e); 1719 1720 if($ae < 0x80) { 1721 @e = ($e & 0xff); 1722 } 1723 elsif($ae < 0x8000) { 1724 @e = map { $_ & 0xff } ($e>>8,$e); 1725 $s |= 1; 1726 } 1727 elsif($ae < 0x800000) { 1728 @e = map { $_ & 0xff } ($e>>16,$e>>8,$e); 1729 $s |= 2; 1730 } 1731 else { 1732 @e = (4, map { $_ & 0xff } ($e>>24,$e>>16,$e>>8,$e)); 1733 $s |= 3; 1734 } 1735 1736 $v = POSIX::ldexp($v,5); 1737 my $f = POSIX::floor($v); 1738 my $i = int($f); 1739 @m = ($i & 0xff); 1740 $v -= $f; 1741 for (1..2) { 1742 $v = POSIX::ldexp($v,24); 1743 $f = POSIX::floor($v); 1744 $i = int($f); 1745 push @m, ($i >> 16) & 0xff, ($i >> 8) & 0xff, $i & 0xff; 1746 $v -= $f; 1747 } 1748 $data = pack("C*",$s,@e,@m); 1749 } 1750 my $len = length($data); 1751 Convert::BER::pack_length($ber,$len); 1752 Convert::BER::pack($ber,$data) if $len; 1753} 1754 1755my @base = (1,3,4,4); 1756 1757sub unpack { 1758 my($self,$ber,$arg) = @_; 1759 1760 my $len = Convert::BER::unpack_length($ber); 1761 unless($len) { 1762 $$arg = undef; 1763 return 1; 1764 } 1765 my $data = Convert::BER::unpack($ber,$len); 1766 my $byte = unpack("C*",$data); 1767 1768 if($byte & 0x80) { 1769 $data = reverse $data; 1770 chop($data); 1771 require POSIX; # The sins for using REAL 1772 my $base = $base[($byte & 0x30) >> 4]; 1773 my $scale = $base & 0xC; 1774 my $elen = $byte & 0x3; 1775 1776 $elen = ord(chop($data)) - 1 if $elen == 3; 1777 1778 die "Bad REAL encoding" unless $elen >= 0 && $elen <= 3; 1779 1780 my $exp = ord chop($data); 1781 $exp = -256 + $exp if $exp > 127; 1782 1783 while ($elen--) { 1784 $exp *= 256; 1785 $exp += ord chop($data); 1786 } 1787 1788 $exp = $exp * $base + $scale; 1789 1790 my $v = 0; 1791 while(length($data)) { 1792 $v = POSIX::ldexp($v,8) + ord chop($data); 1793 } 1794 1795 $v = POSIX::ldexp($v,$exp) if $exp; 1796 $v = -1 * $v if $byte & 0x40; # negative 1797 1798 $$arg = $v; 1799 } 1800 elsif($byte & 0x40) { 1801 require POSIX; 1802 $$arg = POSIX::HUGE_VAL() * (($byte & 1) ? -1 : 1); 1803 } 1804 elsif(substr($data,1) =~ /^\s*([-+]?)0*(\d+(?:\.\d+(?:[Ee][-+]?\d+)?)?)\s*$/) { 1805 $$arg = eval "$1$2"; 1806 } 1807 else { 1808 $$arg = undef; 1809 } 1810 1; 1811} 1812 1813## 1814## 1815## 1816 1817package Convert::BER::_Time_generic; 1818 1819sub pack { 1820 my($self,$ber,$arg) = @_; 1821 1822 my $islocal = $self->isa('Convert::BER::TimeUL') 1823 || $self->isa('Convert::BER::TimeGL'); 1824 my $isgen = $self->isa('Convert::BER::TimeGL') 1825 || $self->isa('Convert::BER::TimeGZ'); 1826 my @time = $islocal ? localtime($arg) : gmtime($arg); 1827 my $off = 'Z'; 1828 1829 if($islocal) { 1830 my @g = gmtime($arg); 1831 my $v = ($time[1] - $g[1]) + ($time[2] - $g[2]) * 60; 1832 my $d = $time[7] - $g[7]; 1833 if($d == 1 || $d < -1) { 1834 $v += 1440; 1835 } 1836 elsif($d > 1) { 1837 $v -= 1440; 1838 } 1839 $off = sprintf("%+03d%02d",$v / 60, abs($v % 60)); 1840 } 1841 1842 $time[4] += 1; 1843 $time[5] = $isgen ? $time[5] + 1900 : $time[5] % 100; 1844 my $str = sprintf("%02d"x6, @time[5,4,3,2,1,0]); 1845 if($isgen) { 1846 my $split = $arg - int($arg); 1847 $str .= sprintf(".%03d", int($split * 1000)) if($split); 1848 } 1849 Convert::BER::STRING::pack($self,$ber,$str . $off); 1850} 1851 1852sub unpack { 1853 my($self,$ber,$arg) = @_; 1854 my $str; 1855 if(Convert::BER::STRING::unpack($self,$ber,\$str)) { 1856 my $isgen = $self->isa('Convert::BER::TimeGL') 1857 || $self->isa('Convert::BER::TimeGZ'); 1858 my $n = $isgen ? 4 : 2; 1859 my ($Y,$M,$D,$h,$m,$s,$z) = $str =~ /^ 1860 (\d{$n}) 1861 (\d\d) 1862 (\d\d) 1863 (\d\d) 1864 (\d\d) 1865 ((?:\d\d(?:\.\d+)?)?) 1866 (Z|[-+]\d{4}) 1867 $/x or die "Bad Time string '$str'"; 1868 my $offset = 0; 1869 if($z ne 'Z') { 1870 use integer; 1871 $offset = ((($z / 100) * 60) + ($z % 100)) * 60; 1872 } 1873 if($s > int($s)) { # fraction of a seccond 1874 $offset -= ($s - int($s)); 1875 } 1876 $M -= 1; 1877 if($isgen) { # GeneralizedTime uses 4-digit years 1878 $Y -= 1900; 1879 } 1880 elsif($Y <= 50) { # ASN.1 UTCTime 1881 $Y += 100; # specifies <=50 = 2000..2050, >50 = 1951..1999 1882 } 1883 require Time::Local; 1884 $$arg = Time::Local::timegm(int($s),$m,$h,$D,$M,$Y) - $offset; 1885 } 1886} 1887 1888package Convert::BER::CHOICE; 1889 1890sub pack_array { 1891 my($self,$ber,$arg) = @_; 1892 my $n = $arg->[0]; 1893 1894 if(defined($n)) { 1895 my $i = ($n * 2) + 2; 1896 die "Bad CHOICE index $n" if $n < 0 || $i > @$arg; 1897 $ber->_encode([$arg->[$i-1], $arg->[$i]]); 1898 } 1899 1; 1900} 1901 1902sub unpack_array { 1903 my($self,$ber,$arg) = @_; 1904 my($i,$m,$err); 1905 1906 $m = @$arg; 1907 my $want = Convert::BER::tag($ber); 1908 1909 for($i = 1 ; $i < $m ; $i += 2) { 1910 my $tag; 1911 my $type = $arg->[$i]; 1912 1913 ($type,$tag) = @$type 1914 if(ref($type) eq 'ARRAY'); 1915 1916 my $can = UNIVERSAL::can($ber,'_' . $type); 1917 1918 die "Unknown element '$type'" 1919 unless $can; 1920 1921 my $data = &$can(); 1922 1923 $tag = $data->[ Convert::BER::_TAG() ] 1924 unless defined $tag; 1925 1926 next unless $tag == $want; 1927 1928 if ( eval { Convert::BER::_decode($ber,[@{$arg}[$i,$i+1]]) }) { 1929 my $choice = $arg->[0]; 1930 $$choice = ($i - 1) >> 1; 1931 return 1; 1932 } 1933 $err = $@ if $@; 1934 } 1935 die ($err || sprintf("Cannot decode CHOICE, found tag 0x%X\n",$want)); 1936} 1937 19381; 1939