1# -*- perl -*- 2 3# Copyright (c) 2007 by Jeff Weisberg 4# Author: Jeff Weisberg <jaw+pause @ tcp4me.com> 5# Created: 2007-Jan-28 16:03 (EST) 6# Function: BER encoding/decoding (also: CER and DER) 7# 8# $Id: BER.pm,v 1.11 2008/05/31 18:43:11 jaw Exp $ 9 10# references: ITU-T x.680 07/2002 - ASN.1 11# references: ITU-T x.690 07/2002 - BER 12 13package Encoding::BER; 14use vars qw($VERSION); 15$VERSION = '1.02'; 16use Carp; 17use strict; 18# loaded on demand if needed: 19# POSIX 20# used if already loaded: 21# Math::BigInt 22 23=head1 NAME 24 25Encoding::BER - Perl module for encoding/decoding data using ASN.1 Basic Encoding Rules (BER) 26 27=head1 SYNOPSIS 28 29 use Encoding::BER; 30 my $enc = Encoding::BER->new(); 31 my $ber = $enc->encode( $data ); 32 my $xyz = $enc->decode( $ber ); 33 34=head1 DESCRIPTION 35 36Unlike many other BER encoder/decoders, this module uses tree structured data 37as the interface to/from the encoder/decoder. 38 39The decoder does not require any form of template or description of the 40data to be decoded. Given arbitrary BER encoded data, the decoder produces 41a tree shaped perl data structure from it. 42 43The encoder takes a perl data structure and produces a BER encoding from it. 44 45=head1 METHODS 46 47=over 4 48 49=cut 50 ; 51 52################################################################ 53 54my %CLASS = 55( 56 universal => { v => 0, }, 57 application => { v => 0x40, }, 58 context => { v => 0x80, }, 59 private => { v => 0xC0, }, 60 ); 61 62my %TYPE = 63( 64 primitive => { v => 0, }, 65 constructed => { v => 0x20, }, 66 ); 67 68my %TAG = 69( 70 universal => { 71 content_end => { v => 0, }, 72 boolean => { v => 1, e => \&encode_bool, d => \&decode_bool }, 73 integer => { v => 2, e => \&encode_int, d => \&decode_int }, 74 bit_string => { v => 3, e => \&encode_bits, d => \&decode_bits, dc => \&reass_string, rule => 1 }, 75 octet_string => { v => 4, e => \&encode_string, d => \&decode_string, dc => \&reass_string, rule => 1 }, 76 null => { v => 5, e => \&encode_null, d => \&decode_null }, 77 oid => { v => 6, e => \&encode_oid, d => \&decode_oid }, 78 object_descriptor => { v => 7, implicit => 'octet_string' }, 79 external => { v => 8, type => ['constructed'] }, 80 real => { v => 9, e => \&encode_real, d => \&decode_real }, 81 enumerated => { v => 0xA, implicit => 'integer' }, 82 embedded_pdv => { v => 0xB, e => \&encode_string, d => \&decode_string, dc => \&reass_string }, 83 utf8_string => { v => 0xC, implicit => 'octet_string' }, 84 relative_oid => { v => 0xD, e => \&encode_roid, d => \&decode_roid }, 85 # reserved 86 # reserved 87 sequence => { v => 0x10, type => ['constructed'] }, 88 set => { v => 0x11, type => ['constructed'] }, 89 numeric_string => { v => 0x12, implicit => 'octet_string' }, 90 printable_string => { v => 0x13, implicit => 'octet_string' }, 91 teletex_string => { v => 0x14, implicit => 'octet_string' }, 92 videotex_string => { v => 0x15, implicit => 'octet_string' }, 93 ia5_string => { v => 0x16, implicit => 'octet_string' }, 94 universal_time => { v => 0x17, implicit => 'octet_string' }, 95 generalized_time => { v => 0x18, implicit => 'octet_string' }, 96 graphic_string => { v => 0x19, implicit => 'octet_string' }, 97 visible_string => { v => 0x1a, implicit => 'octet_string' }, 98 general_string => { v => 0x1b, implicit => 'octet_string' }, 99 universal_string => { v => 0x1c, implicit => 'octet_string' }, 100 character_string => { v => 0x1d, implicit => 'octet_string' }, 101 bmp_string => { v => 0x1e, implicit => 'octet_string' }, 102 }, 103 104 private => { 105 # extra. 106 # no, the encode/decode functions are not mixed up. 107 # yes, this module handles large tag-numbers. 108 integer32 => { v => 0xFFF0, type => ['private'], e => \&encode_uint32, d => \&decode_int }, 109 unsigned_int => { v => 0xFFF1, type => ['private'], e => \&encode_uint, d => \&decode_uint }, 110 unsigned_int32 => { v => 0xFFF2, type => ['private'], e => \&encode_uint32, d => \&decode_uint }, 111 }, 112); 113 114# synonyms 115my %AKATAG = 116( 117 bool => 'boolean', 118 int => 'integer', 119 string => 'octet_string', 120 object_identifier => 'oid', 121 relative_object_identifier => 'relative_oid', 122 roid => 'relative_oid', 123 float => 'real', 124 enum => 'enumerated', 125 sequence_of => 'sequence', 126 set_of => 'set', 127 t61_string => 'teletex_string', 128 iso646_string => 'visible_string', 129 int32 => 'integer32', 130 unsigned_integer => 'unsigned_int', 131 uint => 'unsigned_int', 132 uint32 => 'unsigned_int32', 133 # ... 134); 135 136# insert name into above data 137my %ALLTAG; 138my %REVTAG; 139 140# insert name + class into above data 141# build reverse map, etc. 142init_tag_lookups( \%TAG, \%ALLTAG, \%REVTAG ); 143 144my %REVCLASS = map { 145 ( $CLASS{$_}{v} => $_ ) 146} keys %CLASS; 147 148my %REVTYPE = map { 149 ( $TYPE{$_}{v} => $_ ) 150} keys %TYPE; 151 152################################################################ 153 154=item new(option => value, ...) 155 156constructor. 157 158 example: 159 my $enc = Encoding::BER->new( error => sub{ die "$_[1]\n" } ); 160 161the following options are available: 162 163=over 4 164 165=item error 166 167coderef called if there is an error. will be called with 2 parameters, 168the Encoding::BER object, and the error message. 169 170 # example: die on error 171 error => sub{ die "oops! $_[1]\n" } 172 173=item warn 174 175coderef called if there is something to warn about. will be called with 2 parameters, 176the Encoding::BER object, and the error message. 177 178 # example: warn for warnings 179 warn => sub{ warn "how odd! $_[1]\n" } 180 181 182=item decoded_callback 183 184coderef called for every element decoded. will be called with 2 parameters, 185the Encoding::BER object, and the decoded data. [see DECODED DATA] 186 187 # example: bless decoded results into a useful class 188 decoded_callback => sub{ bless $_[1], MyBER::Result } 189 190=item debug 191 192boolean. if true, large amounts of useless gibberish will be sent to stderr regarding 193the encoding or decoding process. 194 195 # example: enable gibberish output 196 debug => 1 197 198=back 199 200=cut 201 ; 202 203sub new { 204 my $cl = shift; 205 my $me = bless { @_ }, $cl; 206 207 $me; 208} 209 210sub error { 211 my $me = shift; 212 my $msg = shift; 213 214 if( my $f = $me->{error} ){ 215 $f->($me, $msg); 216 }else{ 217 croak ((ref $me) . ": $msg\n"); 218 } 219 undef; 220} 221 222sub warn { 223 my $me = shift; 224 my $msg = shift; 225 226 if( my $f = $me->{warn} ){ 227 $f->($me, $msg); 228 }else{ 229 carp ((ref $me) . ": $msg\n"); 230 } 231 undef; 232} 233 234sub debug { 235 my $me = shift; 236 my $msg = shift; 237 238 return unless $me->{debug}; 239 print STDERR " " x $me->{level}, $msg, "\n"; 240 undef; 241} 242 243################################################################ 244 245sub add_tag_hash { 246 my $me = shift; 247 my $class = shift; 248 my $type = shift; 249 my $name = shift; 250 my $num = shift; 251 my $data = shift; 252 253 return $me->error("invalid class: $class") unless $CLASS{$class}; 254 return $me->error("invalid type: $type") unless $TYPE{$type}; 255 256 $data->{type} = [$class, $type]; 257 $data->{v} = $num; 258 $data->{n} = $name; 259 260 # install forward + reverse mappings 261 $me->{tags}{$name} = $data; 262 $me->{revtags}{$class}{$num} = $name; 263 264 $me; 265} 266 267=item add_implicit_tag(class, type, tag-name, tag-number, base-tag) 268 269add a new tag similar to another tag. class should be one of C<universal>, 270C<application>, C<context>, or C<private>. type should be either C<primitive> 271or C<contructed>. tag-name should specify the name of the new tag. 272tag-number should be the numeric tag number. base-tag should specify the 273name of the tag this is equivalent to. 274 275 example: add a tagged integer 276 in ASN.1: width-index ::= [context 42] implicit integer 277 278 $ber->add_implicit_tag('context', 'primitive', 'width-index', 42, 'integer'); 279 280=cut 281 ; 282 283sub add_implicit_tag { 284 my $me = shift; 285 my $class = shift; 286 my $type = shift; 287 my $name = shift; 288 my $num = shift; 289 my $base = shift; 290 291 return $me->error("unknown base tag name: $base") 292 unless $me->tag_data_byname($base); 293 294 $me->add_tag_hash($class, $type, $name, $num, { 295 implicit => $base, 296 }); 297} 298 299sub add_tag { 300 my $me = shift; 301 my $class = shift; 302 my $type = shift; 303 my $name = shift; 304 my $num = shift; 305 # possibly optional: 306 my $encf = shift; 307 my $decf = shift; 308 my $encfc = shift; 309 my $decfc = shift; 310 311 $me->add_tag_hash($class, $type, $name, $num, { 312 e => $encf, 313 d => $decf, 314 ec => $encfc, 315 dc => $decfc, 316 }); 317} 318 319sub init_tag_lookups { 320 my $TAG = shift; 321 my $ALL = shift; 322 my $REV = shift; 323 324 for my $class (keys %$TAG){ 325 for my $name (keys %{$TAG->{$class}}){ 326 $TAG->{$class}{$name}{n} = $name; 327 $ALL->{$name} = $TAG->{$class}{$name}; 328 } 329 my %d = map { 330 ($TAG->{$class}{$_}{v} => $_) 331 } keys %{$TAG->{$class}}; 332 $REV->{$class} = \%d; 333 } 334} 335 336################################################################ 337 338=item encode( data ) 339 340BER encode the provided data. [see: ENCODING DATA] 341 342 example: 343 my $ber = $enc->encode( [0, 'public', [7.3, 0, 0, ['foo', 'bar']]] ); 344 345=cut 346 ; 347 348sub encode { 349 my $me = shift; 350 my $data = shift; 351 my $levl = shift; 352 353 $me->{level} = $levl || 0; 354 $data = $me->canonicalize($data) if $me->{acanonical} || !$me->behaves_like_a_hash($data); 355 356 # include pre-encoded data as is 357 if( $data->{type} eq 'BER_preencoded' ){ 358 return $data->{value}; 359 } 360 361 $data = $me->rule_check_and_apply($data) || $data; 362 my($typeval, $tagnum, $encfnc) = $me->ident_data_and_efunc($data->{type}); 363 my $value; 364 365 if( $typeval & 0x20 ){ 366 $me->debug( "encode constructed ($typeval/$tagnum) [" ); 367 # constructed - recurse 368 my @vs = ref($data->{value}) ? @{$data->{value}} : $data->{value}; 369 for my $e (@vs){ 370 $value .= $me->encode( $e, $me->{level} + 1 ); 371 } 372 $me->{level} = $levl || 0; 373 $me->debug("]"); 374 }else{ 375 $me->debug( "encode primitive ($typeval/$tagnum)" ); 376 377 unless( $encfnc ){ 378 # try to guess encoding 379 my @t = ref($data->{type}) ? @{$data->{type}} : $data->{type}; 380 $me->warn("do not know how to encode identifier [@t] ($typeval/$tagnum)"); 381 $encfnc = \&encode_unknown; 382 } 383 $value = $encfnc->($me, $data); 384 } 385 386 my $defp = $me->use_definite_form($typeval, $data); 387 my $leng = $me->encode_length(length($value)); 388 389 my $res; 390 if( $defp && defined($leng) ){ 391 $me->debug("encode definite form"); 392 $res = $me->encode_ident($typeval, $tagnum) . $leng . $value; 393 }else{ 394 $me->debug("encode indefinite form"); 395 $res = $me->encode_ident($typeval, $tagnum) . "\x80" . $value . "\x00\x00"; 396 # x.690: 8.3.6.1 8.1.5 397 } 398 399 $data->{dlen} = length($value); 400 $data->{tlen} = length($res); 401 402 $res; 403} 404 405sub encode_null { 406 my $me = shift; 407 $me->debug('encode null'); 408 ''; 409} 410 411sub encode_unknown { 412 my $me = shift; 413 my $data = shift; 414 415 $me->debug('encode unknown'); 416 '' . $data->{value}; 417} 418 419sub encode_string { 420 my $me = shift; 421 my $data = shift; 422 423 # CER splitting of long strings is handled in CER subclass 424 $me->debug('encode string'); 425 '' . $data->{value}; 426} 427 428sub encode_bits { 429 my $me = shift; 430 my $data = shift; 431 432 # x.690 8.6 433 $me->debug('encode bitstring'); 434 "\0" . $data->{value}; 435 436} 437 438sub encode_bool { 439 my $me = shift; 440 my $data = shift; 441 442 # x.690 11.1 443 $me->debug('encode boolean'); 444 $data->{value} ? "\xFF" : "\x0"; 445} 446 447sub encode_int { 448 my $me = shift; 449 my $data = shift; 450 my $val = $data->{value}; 451 452 my @i; 453 my $big; 454 455 if( _have_math_bigint() ){ 456 # value is a bigint or a long string 457 $big = 1 if (ref $val && $val->can('as_hex')) || length($val) > 8; 458 } 459 460 if( $big ){ 461 my $x = Math::BigInt->new($val); 462 $me->debug("bigint $val => $x"); 463 my $sign = $x->is_neg() ? 0xff : 0; 464 if( $sign ){ 465 # NB: in 2s comp: -X = ~(X-1) = ~X+1 466 $x = $x->bneg()->bsub(1)->as_hex(); 467 $x =~ s/^0x//; 468 $x = '0'.$x if length($x) & 1; 469 @i = map{ ~$_ & 0xff } unpack('C*', pack('H*', $x)); 470 unshift @i, 0xff unless $i[0] & 0x80; 471 }else{ 472 $x = $x->as_hex(); 473 $x =~ s/^0x//; 474 $x = '0'.$x if length($x) & 1; 475 @i = unpack('C*', pack('H*', $x)); 476 unshift @i, 0 if $i[0] & 0x80; 477 } 478 $me->debug("encode big int [@i]"); 479 }else{ 480 my $sign = ($val < 0) ? 0xff : 0; 481 while(1){ 482 unshift @i, $val & 0xFF; 483 last if $val >= -128 && $val < 128; 484 # NB: >>= does not preserve sign. 485 $val = int(($val - $sign)/256); 486 } 487 $me->debug("encode int [@i]"); 488 } 489 pack('C*', @i); 490} 491 492sub encode_uint { 493 my $me = shift; 494 my $data = shift; 495 my $val = $data->{value}; 496 497 my @i; 498 my $big; 499 500 if( _have_math_bigint() ){ 501 # value is a bigint or a long string 502 $big = 1 if (ref $val && $val->can('bcmp')) || length($val) > 8; 503 } 504 505 if( $big ){ 506 my $x = Math::BigInt->new($val)->as_hex(); 507 $x =~ s/^0x//; 508 $x = '0' . $x if length($x) & 1; 509 $me->debug("encode big unsigned int"); 510 pack('H*', $x); 511 }else{ 512 while($val){ 513 unshift @i, $val & 0xFF; 514 $val >>= 8; 515 } 516 $me->debug("encode unsigned int [@i]"); 517 pack('C*', @i); 518 } 519} 520 521 522sub encode_uint32 { 523 my $me = shift; 524 my $data = shift; 525 my $val = $data->{value}; 526 527 # signed or unsigned. -1 == 0xffffffff 528 $me->debug("encode unsigned int32"); 529 pack('N', $val); 530} 531 532sub encode_real { 533 my $me = shift; 534 my $data = shift; 535 my $val = $data->{value}; 536 537 return '' unless $val; # x.690 8.5.2 538 return "\x40" if $val eq 'inf'; # x.690 8.5.8 539 return "\x41" if $val eq '-inf'; # x.690 8.5.8 540 541 # POSIX required. available? 542 eval { 543 require POSIX; 544 }; 545 return $me->error("POSIX not available. cannot encode type real") 546 unless defined &POSIX::frexp; 547 548 my $sign = 0; 549 my($mant, $exp) = POSIX::frexp($val); 550 if( $mant < 0 ){ 551 $sign = 1; 552 $mant = - $mant; 553 } 554 555 #$me->debug("encode real: $mant ^ $exp"); 556 557 # go byte-by-byte 558 my @mant; 559 while($mant > 0){ 560 my($frac, $int) = POSIX::modf(POSIX::ldexp($mant, 8)); 561 push @mant, $int; 562 $mant = $frac; 563 $exp -= 8; 564 # $me->debug("encode real: [@mant] ^ $exp"); 565 } 566 #$me->debug("encode real: [@mant] ^ $exp"); 567 568 if( $data->{flavor} || $me->{flavor} ){ 569 # x.690 8.5.6.5, 11.3.1 - CER + DER require N has a 1 in the lsb 570 # normalize 571 while( ! ($mant[-1] & 1) ){ 572 # shift right 573 my $c = 0; 574 for (@mant){ 575 my $l = $_ & 1; 576 $_ = ($_>>1) | ($c?0x80:0); 577 $c = $l; 578 } 579 $exp ++; 580 } 581 #$me->debug("encode real normalized: [@mant] ^ $exp"); 582 } 583 584 # encode exp 585 my @exp; 586 my $exps = ($exp < 0) ? 0xff : 0; 587 while(1){ 588 unshift @exp, $exp & 0xFF; 589 last if $exp >= -128 && $exp < 128; 590 # >>= does not preserve sign. 591 $exp = int(($exp - $exps)/256); 592 } 593 594 $me->debug("encode real: [@mant] ^ [@exp]"); 595 596 my $first = 0x80 | ($sign ? 0x40 : 0); 597 598 if(@exp == 2){ 599 $first |= 1; 600 } 601 if(@exp == 3){ 602 $first |= 2; 603 } 604 if(@exp > 3){ 605 # should not happen using ieee-754 doubles 606 $first |= 3; 607 unshift @exp, scalar(@exp); 608 } 609 610 pack('C*', $first, @exp, @mant); 611} 612 613sub encode_oid { 614 my $me = shift; 615 my $data = shift; 616 my $val = $data->{value}; 617 # "1.3.6.1.2.0" | [1, 3, 6, 1, 2, 0] 618 619 # x.690 8.19 620 my @o = ref($val) ? @$val : (split /\./, $val); 621 shift @o if $o[0] eq ''; # remove empty in case specified with leading . 622 623 if( @o > 1 ){ 624 # x.690 8.19.4 625 my $o = shift @o; 626 $o[0] += $o * 40; 627 } 628 629 $me->debug("encode oid [@o]"); 630 pack('w*', @o); 631} 632 633sub encode_roid { 634 my $me = shift; 635 my $data = shift; 636 my $val = $data->{value}; 637 # "1.3.6.1.2.0" | [1, 3, 6, 1, 2, 0] 638 639 # x.690 8.20 640 my @o = ref($val) ? @$val : (split /\./, $val); 641 shift @o if $o[0] eq ''; # remove empty in case specified with leading . 642 # no special encoding of 1st 2 643 644 $me->debug("encode relative-oid [@o]"); 645 pack('w*', @o); 646} 647 648 649################################################################ 650 651sub encode_ident { 652 my $me = shift; 653 my $type = shift; 654 my $tnum = shift; 655 656 if( $tnum < 31 ){ 657 return pack('C', $type|$tnum); 658 } 659 $type |= 0x1f; 660 pack('Cw', $type, $tnum); 661} 662 663sub encode_length { 664 my $me = shift; 665 my $len = shift; 666 667 return pack('C', $len) if $len < 128; # x.690 8.1.3.4 668 return pack('CC', 0x81, $len) if $len < 1<<8; # x.690 8.1.3.5 669 return pack('Cn', 0x82, $len) if $len < 1<<12; 670 return pack('CCn',0x83, ($len>>16), ($len&0xFFFF)) if $len < 1<<16; 671 return pack('CN', 0x84, $len) if $len <= 0xFFFFFFFF; 672 673 # items larger than above will be encoded in indefinite form 674 return; 675} 676 677# override me in subclass 678sub rule_check_and_apply { 679 my $me = shift; 680 my $data = shift; 681 682 undef; 683} 684 685# convert DWIM values => canonical form 686sub canonicalize { 687 my $me = shift; 688 my $data = shift; 689 690 # arrayref | int | float | string | undef 691 692 unless( defined $data ){ 693 return { 694 type => 'null', 695 value => undef, 696 }; 697 } 698 699 if( $me->behaves_like_an_array($data) ){ 700 return { 701 type => 'sequence', 702 value => $data, 703 }; 704 } 705 706 if( $me->behaves_like_a_hash($data) ){ 707 return { 708 type => ['application', 'constructed', 3], 709 value => [ %$data ], 710 }; 711 } 712 713 if( $me->smells_like_a_number($data) ){ 714 return { 715 type => ( int($data) == $data ? 'integer' : 'real'), 716 value => $data, 717 }; 718 } 719 720 # call it a string 721 return { 722 type => 'octet_string', 723 value => $data, 724 }; 725} 726 727# tags added via add_tag method 728sub app_tag_data_byname { 729 my $me = shift; 730 my $name = shift; 731 732 $me->{tags}{$name}; 733} 734 735# override me in subclass 736sub subclass_tag_data_byname { 737 my $me = shift; 738 my $name = shift; 739 740 undef; 741} 742 743# from the table up top 744sub univ_tag_data_byname { 745 my $me = shift; 746 my $name = shift; 747 748 $ALLTAG{$name} || ($AKATAG{$name} && $ALLTAG{$AKATAG{$name}}); 749} 750 751sub tag_data_byname { 752 my $me = shift; 753 my $name = shift; 754 755 my $th; 756 # application specific tag name 757 $th = $me->app_tag_data_byname($name); 758 759 # subclass specific tag name 760 $th = $me->subclass_tag_data_byname($name) unless $th; 761 762 # universal tag name 763 $th = $me->univ_tag_data_byname($name) unless $th; 764 765 $th; 766} 767 768sub class_and_type_from_speclist { 769 my $me = shift; 770 my($class, $type); 771 for my $t (@_){ 772 if( $CLASS{$t} ){ $class = $t; next } 773 if( $TYPE{$t} ){ $type = $t; next } 774 $me->error("unknown type specification [$t] not a class or type"); 775 } 776 ($class, $type); 777} 778 779sub ident_data_and_efunc { 780 my $me = shift; 781 my $typd = shift; 782 my $func = shift; 783 784 $func ||= 'e'; 785 my @t = ref($typd) ? @$typd : ($typd); 786 787 # type: name | [class, type, name] | [class, type, num] 788 # if name resolves, specified class+type for validation only 789 790 my $tname = pop @t; 791 if( $me->smells_like_a_number($tname) ){ 792 my($class, $type) = $me->class_and_type_from_speclist( @t ); 793 $class ||= 'universal'; 794 $type ||= 'primitive'; 795 my $tv = $CLASS{$class}{v} | $TYPE{$type}{v}; 796 my $tm = $tname + 0; 797 $me->debug("numeric specification [@t $tname] resolved to [$class $type $tm]"); 798 return ( $tv, $tm, undef ); 799 } 800 801 my $th = $me->tag_data_byname($tname); 802 803 unless( $th ){ 804 $me->error("unknown type [$tname]"); 805 } 806 unless( ref $th ){ 807 $me->error("programmer botch. tag data should be hashref: [$tname] => $th"); 808 $th = undef; 809 } 810 811 my( $class, $type, $rclass, $rtype, $tnum, $encf ); 812 813 # parse request 814 ($rclass, $rtype) = $me->class_and_type_from_speclist( @t ); 815 # parse spec 816 if( my $ts = $th->{type} ){ 817 ($class, $type) = $me->class_and_type_from_speclist( @$ts ); 818 } 819 820 # use these values for identifier-value 821 $class ||= 'universal'; 822 $type = $rtype || $type || 'primitive'; 823 $tnum = $th->{v}; 824 825 $me->debug("specificication [@t $tname] resolved to [$class $type $tname($tnum)]"); 826 # warn if mismatched 827 $me->warn("specificication [$rclass $tname] resolved to [$class $tname]") 828 if $rclass && $rclass ne $class; 829 830 # indirect via implicit to find encoding func 831 $encf = $th->{$func}; 832 if( my $impl = $th->{implicit} ){ 833 # only one level of indirection 834 $th = $me->tag_data_byname($impl); 835 836 if( ref $th ){ 837 $me->debug("specificication [$class $type $tname($tnum)] is implictly $impl "); 838 $encf ||= $th->{$func}; 839 }else{ 840 $me->error("programmer botch. implicit indirect not found: [$class $tname] => $impl"); 841 } 842 } 843 844 my $tv = $CLASS{$class}{v} | $TYPE{$type}{v}; 845 return( $tv, $tnum, $encf ); 846} 847 848sub use_definite_form { 849 my $me = shift; 850 my $type = shift; 851 my $data = shift; 852 853 return 1 unless $type & 0x20; # x.690 8.1.3.2 - primitive - always definite 854 855 my $fl = $data->{flavor} || $me->{flavor}; 856 return 1 unless $fl; 857 return 1 if $fl eq 'DER'; # x.690 10.1 - DER - always definite 858 return 0 if $fl eq 'CER'; # x.690 9.1 - CER + constructed - indefinite 859 1; # otherwise, prefer definite 860} 861 862################################################################ 863 864sub behaves_like_an_array { 865 my $me = shift; 866 my $d = shift; 867 868 return unless ref $d; 869 return UNIVERSAL::isa($d, 'ARRAY'); 870} 871 872sub behaves_like_a_hash { 873 my $me = shift; 874 my $d = shift; 875 876 return unless ref $d; 877 878 # treat as if it is a number 879 return if UNIVERSAL::isa($d, 'Math::BigInt'); 880 return UNIVERSAL::isa($d, 'HASH'); 881} 882 883sub smells_like_a_number { 884 my $me = shift; 885 my $d = shift; 886 887 return 1 if ref $d && UNIVERSAL::isa($d, 'Math::BigInt'); 888 # NB: 5.00503 does not have 'no warnings'; 889 local $^W = 0; 890 return ($d + 0 eq $d); 891} 892 893################################################################ 894 895=item decode( ber ) 896 897Decode the provided BER encoded data. returns a perl data structure. 898[see: DECODED DATA] 899 900 example: 901 my $data = $enc->decode( $ber ); 902 903=cut 904 ; 905 906sub decode { 907 my $me = shift; 908 my $data = shift; 909 910 $me->{level} = 0; 911 my($v, $l) = $me->decode_item($data, 0); 912 $v; 913} 914 915sub decode_items { 916 my $me = shift; 917 my $data = shift; 918 my $eocp = shift; 919 my $levl = shift; 920 my @v; 921 my $tlen = 0; 922 923 $me->{level} = $levl; 924 $me->debug("decode items["); 925 while($data){ 926 my($val, $len) = $me->decode_item($data, $levl+1); 927 $tlen += $len; 928 unless( $val && defined $val->{type} ){ 929 # end-of-content 930 $me->debug('end of content'); 931 last if $eocp; 932 } 933 934 push @v, $val; 935 $data = substr($data, $len); 936 } 937 938 $me->{level} = $levl; 939 $me->debug(']'); 940 return (\@v, $tlen); 941} 942 943sub decode_item { 944 my $me = shift; 945 my $data = shift; 946 my $levl = shift; 947 948 # hexdump($data, 'di:'); 949 $me->{level} = $levl; 950 my($typval, $typlen, $typmore) = $me->decode_ident($data); 951 my($typdat, $decfnc, $pretty, $tagnum) = $me->ident_descr_and_dfuncs($typval, $typmore); 952 my($datlen, $lenlen) = $me->decode_length(substr($data,$typlen)); 953 my $havlen = length($data); 954 my $tlen = $typlen + $lenlen + ($datlen || 0); 955 my $doff = $typlen + $lenlen; 956 my $result; 957 958 $me->error("corrupt data? data appears truncated") 959 if $havlen < $tlen; 960 961 if( $typval & 0x20 ){ 962 # constructed 963 my $vals; 964 965 if( defined $datlen ){ 966 # definite 967 $me->debug("decode item: constructed definite [@$typdat($tagnum)]"); 968 my($v, $t) = $me->decode_items( substr($data, $doff, $datlen), 0, $levl); 969 $me->{level} = $levl; 970 $me->warn("corrupt data? item len != data len ($t, $datlen)") 971 unless $t == $datlen; 972 $vals = $v; 973 }else{ 974 # indefinite 975 $me->debug("decode item: constructed indefinite [@$typdat($tagnum)]"); 976 my($v, $t) = $me->decode_items( substr($data, $doff), 1, $levl ); 977 $me->{level} = $levl; 978 $tlen += $t; 979 $tlen += 2; # eoc 980 $vals = $v; 981 } 982 if( $decfnc ){ 983 # constructed decode func: reassemble 984 $result = $decfnc->( $me, $vals, $typdat ); 985 }else{ 986 $result = { 987 value => $vals, 988 }; 989 } 990 }else{ 991 # primitive 992 my $ndat; 993 if( defined $datlen ){ 994 # definite 995 $me->debug("decode item: primitive definite [@$typdat($tagnum)]"); 996 $ndat = substr($data, $doff, $datlen); 997 }else{ 998 # indefinite encoding of a primitive is a violation of x.690 8.1.3.2(a) 999 # warn + parse it anyway 1000 $me->debug("decode item: primitive indefinite [@$typdat($tagnum)]"); 1001 $me->warn("protocol violation - indefinite encoding of primitive. see x.690 8.1.3.2(a)"); 1002 my $i = index($data, "\0\0", $doff); 1003 if( $i == -1 ){ 1004 # invalid encoding. 1005 # no eoc found. 1006 # go back to protocol school. 1007 $me->error("corrupt data - content terminator not found. see x.690 8.1.3.6, 8.1.5, et al. "); 1008 return (undef, $tlen); 1009 } 1010 my $dl = $i - $doff; 1011 $tlen += $dl; 1012 $tlen += 2; # eoc 1013 $ndat = substr($data, $doff, $dl); 1014 } 1015 1016 unless( $typval || $typmore ){ 1017 # universal-primitive-tag(0) => end-of-content 1018 return ( { }, $tlen ); 1019 } 1020 1021 # decode it 1022 $decfnc ||= \&decode_unknown; 1023 my $val = $decfnc->( $me, $ndat, $typdat ); 1024 1025 # format value in a special pretty way? 1026 if( $pretty ){ 1027 $val = $pretty->( $me, $val ) || $val; 1028 } 1029 $result = $val; 1030 } 1031 1032 $result->{type} = $typdat; 1033 $result->{tagnum} = $tagnum; 1034 $result->{identval} = $typval; 1035 1036 if( my $c = $me->{decoded_callback} ){ 1037 $result = $c->( $me, $result ) || $result; # make sure the brain hasn't fallen out 1038 } 1039 return( $result, $tlen ); 1040} 1041 1042sub app_tag_data_bynumber { 1043 my $me = shift; 1044 my $class = shift; 1045 my $tnum = shift; 1046 1047 my $name = $me->{revtags}{$class}{$tnum}; 1048 return unless $name; 1049 1050 $me->{tags}{$name}; 1051} 1052 1053# override me in subclass 1054sub subclass_tag_data_bynumber { 1055 my $me = shift; 1056 my $class = shift; 1057 my $tnum = shift; 1058 1059 undef; 1060} 1061 1062sub univ_tag_data_bynumber { 1063 my $me = shift; 1064 my $class = shift; 1065 my $tnum = shift; 1066 1067 $TAG{$class}{ $REVTAG{$class}{$tnum} }; 1068} 1069 1070sub tag_data_bynumber { 1071 my $me = shift; 1072 my $class = shift; 1073 my $tnum = shift; 1074 1075 my $th; 1076 # application specific tag name 1077 $th = $me->app_tag_data_bynumber($class, $tnum); 1078 1079 # subclass specific tag name 1080 $th = $me->subclass_tag_data_bynumber($class, $tnum) unless $th; 1081 1082 # from universal 1083 $th = $me->univ_tag_data_bynumber($class, $tnum) unless $th; 1084 1085 $th; 1086} 1087 1088sub ident_descr_and_dfuncs { 1089 my $me = shift; 1090 my $tval = shift; 1091 my $more = shift; 1092 1093 my $tag = $more || ($tval & 0x1f) || 0; 1094 my $cl = $tval & 0xC0; 1095 my $ty = $tval & 0x20; 1096 my $class = $REVCLASS{$cl}; 1097 my $pctyp = $REVTYPE{$ty}; 1098 1099 my( $th, $tn, $tf, $tp ); 1100 1101 $th = $me->tag_data_bynumber($class, $tag); 1102 1103 if( ref $th ){ 1104 $tn = $th->{n}; 1105 $tp = $th->{pretty}; 1106 1107 if( my $impl = $th->{implicit} ){ 1108 # indirect. we support only one level. 1109 my $h = $me->tag_data_byname($impl); 1110 if( ref $h ){ 1111 $th = $h; 1112 }else{ 1113 $me->error("programmer botch. implicit indirect not found: $class/$tn => $impl"); 1114 } 1115 } 1116 # primitive decode func or constructed decode func? 1117 $tp ||= $th->{pretty}; 1118 $tf = $ty ? $th->{dc} : $th->{d}; 1119 }elsif( $th ){ 1120 $me->error("programmer botch. tag data should be hashref: $class/$tag => $th"); 1121 }else{ 1122 $me->warn("unknown type [$class $tag]"); 1123 } 1124 1125 $tn = $tag unless defined $tn; 1126 1127 $me->debug("identifier $tval/$tag resolved to [$class $pctyp $tn]"); 1128 # [class, type, tagname], decodefunc, tagnumber 1129 ([$class, $pctyp, $tn], $tf, $tp, $tag); 1130} 1131 1132sub decode_length { 1133 my $me = shift; 1134 my $data = shift; 1135 1136 my($l1) = unpack('C', $data); 1137 1138 unless( $l1 & 0x80 ){ 1139 # x.690 8.1.3.4 - short form 1140 return ($l1, 1); 1141 } 1142 if( $l1 == 0x80 ){ 1143 # x.690 8.1.3.6 - indefinite form 1144 return (undef, 1); 1145 } 1146 1147 # x.690 8.1.3.5 - long form 1148 my $llen = $l1 & 0x7f; 1149 my @l = unpack("C$llen", substr($data, 1)); 1150 1151 my $len = 0; 1152 for my $l (@l){ 1153 $len <<= 8; 1154 $len += $l; 1155 } 1156 1157 ($len, $llen + 1); 1158} 1159 1160sub decode_ident { 1161 my $me = shift; 1162 my $data = shift; 1163 1164 my($tag) = unpack('C', $data); 1165 return ($tag, 1) unless ($tag & 0x1f) == 0x1f; # x.690 8.1.2.3 1166 1167 # x.690 8.1.2.4 - tag numbers > 30 1168 my $i = 1; 1169 $tag &= ~0x1f; 1170 my $more = 0; 1171 while(1){ 1172 my $c = unpack('C', substr($data,$i++,1)); 1173 $more <<= 7; 1174 $more |= ($c & 0x7f); 1175 last unless $c & 0x80; 1176 } 1177 1178 ($tag, $i, $more); 1179} 1180 1181sub decode_bool { 1182 my $me = shift; 1183 my $data = shift; 1184 my $type = shift; 1185 1186 my $v = unpack('C', $data); 1187 1188 { 1189 value => $v, 1190 }; 1191} 1192 1193sub decode_null { 1194 my $me = shift; 1195 my $data = shift; 1196 my $type = shift; 1197 1198 { 1199 value => undef, 1200 }; 1201} 1202 1203# reassemble constructed string 1204sub reass_string { 1205 my $me = shift; 1206 my $vals = shift; 1207 my $type = shift; 1208 1209 my $val = ''; 1210 for my $v (@$vals){ 1211 $val .= $v->{value}; 1212 }; 1213 1214 $me->debug('reassemble constructed string'); 1215 return { 1216 type => [ $type->[0], 'primitive', $type->[2] ], 1217 value => $val, 1218 }; 1219 1220} 1221 1222sub decode_string { 1223 my $me = shift; 1224 my $data = shift; 1225 my $type = shift; 1226 1227 { 1228 value => $data, 1229 }; 1230} 1231 1232sub decode_bits { 1233 my $me = shift; 1234 my $data = shift; 1235 my $type = shift; 1236 1237 my $pad = unpack('C', $data); 1238 # QQQ - remove padding? 1239 1240 $data = substr($data, 1); 1241 1242 { 1243 value => $data, 1244 }; 1245} 1246 1247sub decode_int { 1248 my $me = shift; 1249 my $data = shift; 1250 my $type = shift; 1251 1252 my $val = $me->part_decode_int($data, 1); 1253 $me->debug("decode integer: $val"); 1254 { 1255 value => $val, 1256 }; 1257} 1258 1259sub decode_uint { 1260 my $me = shift; 1261 my $data = shift; 1262 my $type = shift; 1263 1264 my $val = $me->part_decode_int($data, 0); 1265 $me->debug("decode unsigned integer: $val"); 1266 { 1267 value => $val, 1268 }; 1269} 1270 1271sub part_decode_int { 1272 my $me = shift; 1273 my $data = shift; 1274 my $sgnd = shift; 1275 1276 my $val; 1277 my $big; 1278 $big = 1 if _have_math_bigint() && length($data) > 4; 1279 1280 if( $big ){ 1281 my $sign = unpack('c', $data) < 0; 1282 if( $sgnd && $sign ){ 1283 # make negative 1284 $val = Math::BigInt->new('0x' . unpack('H*', pack('C*', map {~$_ & 0xff} unpack('C*', $data)))); 1285 $val->bneg()->bsub(1); 1286 }else{ 1287 $val = Math::BigInt->new('0x' . unpack('H*', $data)); 1288 } 1289 1290 }else{ 1291 $val = unpack(($sgnd ? 'c' : 'C'), $data); 1292 my @o = unpack('C*', $data); 1293 shift @o; 1294 for my $i (@o){ 1295 $val *= 256; 1296 $val += $i; 1297 } 1298 } 1299 1300 $val; 1301} 1302 1303sub decode_real { 1304 my $me = shift; 1305 my $data = shift; 1306 my $type = shift; 1307 1308 $me->debug('decode real'); 1309 return { value => 0.0 } unless $data; 1310 1311 # POSIX required. available? 1312 eval { 1313 require POSIX; 1314 }; 1315 return $me->error("POSIX not available. cannot decode type real") 1316 unless defined &POSIX::frexp; 1317 1318 my $first = unpack('C', $data); 1319 return { value => POSIX::HUGE_VAL() } if $first == 0x40; 1320 return { value => - POSIX::HUGE_VAL() } if $first == 0x41; 1321 1322 if( $first & 0x80 ){ 1323 # binary encoding 1324 my $sign = ($first & 0x40) ? -1 : 1; 1325 my $base = ($first & 0x30) >> 4; 1326 my $scal = [0, 1, -2, -1]->[($first & 0x0C) >> 2]; 1327 my $expl = ($first & 0x03) + 1; 1328 1329 $data = substr($data, 1); 1330 1331 if( $expl == 4 ){ 1332 $expl = unpack('C', $data); 1333 $data = substr($data, 1); 1334 } 1335 1336 my $exp = $me->part_decode_int( substr($data, 0, $expl), 1 ); 1337 $data = substr($data, $expl); 1338 my @mant = unpack('C*', $data); 1339 $me->debug("decode real: [@mant] $exp"); 1340 1341 # apply scale factor 1342 $exp *= 3 if $base == 1; 1343 $exp *= 4 if $base == 2; 1344 $me->error('corrupt data: invalid base for real') if $base == 3; 1345 $exp += $scal; 1346 1347 # put it together 1348 my $val = 0; 1349 $exp += (@mant - 1) * 8; 1350 for my $m (@mant){ 1351 $val += POSIX::ldexp($m, $exp); 1352 # $me->debug("decode real: $val ($m, $exp)"); 1353 $exp -= 8; 1354 } 1355 $val *= $sign; 1356 1357 $me->debug("decode real: => $val"); 1358 return { value => $val }; 1359 }else{ 1360 # decimal encoding 1361 # x.690 8.5.7 - see iso-6093 1362 $me->debug('decode real decimal'); 1363 $data = substr($data, 1); 1364 $data =~ s/^([+-]?)0+/$1/; # remove leading 0s 1365 $data =~ s/\s//g; # remove spaces 1366 $data += 0; # make number 1367 1368 return { value => $data }; 1369 } 1370 1371} 1372 1373sub decode_oid { 1374 my $me = shift; 1375 my $data = shift; 1376 my $type = shift; 1377 1378 my @o = unpack('w*', $data); 1379 1380 if( $o[0] < 40 ){ 1381 unshift @o, 0; 1382 }elsif( $o[0] < 80 ){ 1383 $o[0] -= 40; 1384 unshift @o, 1; 1385 }else{ 1386 $o[0] -= 80; 1387 unshift @o, 2; 1388 } 1389 1390 my $val = join('.', @o); 1391 $me->debug("decode oid: $val"); 1392 1393 { 1394 value => $val, 1395 }; 1396} 1397 1398sub decode_roid { 1399 my $me = shift; 1400 my $data = shift; 1401 my $type = shift; 1402 1403 my @o = unpack('w*', $data); 1404 1405 my $val = join('.', @o); 1406 $me->debug("decode relative-oid: $val"); 1407 1408 { 1409 value => $val, 1410 }; 1411} 1412 1413sub decode_unknown { 1414 my $me = shift; 1415 my $data = shift; 1416 my $type = shift; 1417 1418 $me->debug("decode unknown"); 1419 { 1420 value => $data, 1421 }; 1422} 1423 1424sub _have_math_bigint { 1425 1426 return unless defined &Math::BigInt::new; 1427 return unless defined &Math::BigInt::is_neg; 1428 1429 1; 1430} 1431 1432################################################################ 1433 1434sub hexdump { 1435 my $b = shift; 1436 my $tag = shift; 1437 my( $l, $t ); 1438 1439 print STDERR "$tag:\n" if $tag; 1440 while( $b ){ 1441 $t = $l = substr($b, 0, 16, ''); 1442 $l =~ s/(.)/sprintf('%0.2X ',ord($1))/ges; 1443 $l =~ s/(.{24})/$1 /; 1444 $t =~ s/[[:^print:]]/./gs; 1445 my $p = ' ' x (49 - (length $l)); 1446 print STDERR " $l $p$t\n"; 1447 } 1448} 1449 1450sub import { 1451 my $pkg = shift; 1452 my $caller = caller; 1453 1454 for my $f (@_){ 1455 no strict; 1456 my $fnc = $pkg->can($f); 1457 next unless $fnc; 1458 *{$caller . '::' . $f} = $fnc; 1459 } 1460} 1461 1462=back 1463 1464=head1 ENCODING DATA 1465 1466You can give data to the encoder in either of two ways (or mix and match). 1467 1468You can specify simple values directly, and the module will guess the 1469correct tags to use. Things that look like integers will be encoded as 1470C<integer>, things that look like floating-point numbers will be encoded 1471as C<real>, things that look like strings, will be encoded as C<octet_string>. 1472Arrayrefs will be encoded as C<sequence>. 1473 1474 example: 1475 $enc->encode( [0, 1.2, "foobar", [ "baz", 37.94 ]] ); 1476 1477Alternatively, you can explicity specify the type using a hashref 1478containing C<type> and C<value> keys. 1479 1480 example: 1481 $enc->encode( { type => 'sequence', 1482 value => [ 1483 { type => 'integer', 1484 value => 37 } ] } ); 1485 1486The type may be specfied as either a string containg the tag-name, or 1487as an arryref containing the class, type, and tag-name. 1488 1489 example: 1490 type => 'octet_string' 1491 type => ['universal', 'primitive', 'octet_string'] 1492 1493Note: using the second form above, you can create wacky encodings 1494that no one will be able to decode. 1495 1496The value should be a scalar value for primitive types, and an 1497arrayref for constructed types. 1498 1499 example: 1500 { type => 'octet_string', value => 'foobar' } 1501 { type => 'set', value => [ 1, 2, 3 ] } 1502 1503 { type => ['universal', 'constructed', 'octet_string'], 1504 value => [ 'foo', 'bar' ] } 1505 1506=head1 DECODED DATA 1507 1508The values returned from decoding will be similar to the way data to 1509be encoded is specified, in the full long form. Additionally, the hashref 1510will contain: C<identval> the numeric value representing the class+type+tag 1511and C<tagnum> the numeric tag number. 1512 1513 example: 1514 a string might be returned as: 1515 { type => ['universal', 'primitive', 'octet_string'], 1516 identval => 4, 1517 tagnum => 4, 1518 value => 'foobar', 1519 } 1520 1521 1522=head1 TAG NAMES 1523 1524The following are recognized as valid names of tags: 1525 1526 bit_string bmp_string bool boolean character_string embedded_pdv 1527 enum enumerated external float general_string generalized_time 1528 graphic_string ia5_string int int32 integer integer32 iso646_string 1529 null numeric_string object_descriptor object_identifier octet_string 1530 oid printable_string real relative_object_identifier relative_oid 1531 roid sequence sequence_of set set_of string t61_string teletex_string 1532 uint uint32 universal_string universal_time unsigned_int unsigned_int32 1533 unsigned_integer utf8_string videotex_string visible_string 1534 1535=head1 Math::BigInt 1536 1537If you have Math::BigInt, it can be used for large integers. If you want it used, 1538you must load it yourself: 1539 1540 use Math::BigInt; 1541 use Encoding::BER; 1542 1543It can be used for both encoding and decoding. The encoder can be handed either 1544a Math::BigInt object, or a "big string of digits" marked as an integer: 1545 1546 use math::BigInt; 1547 1548 my $x = Math::BigInt->new( '12345678901234567890' ); 1549 $enc->encode( $x ) 1550 1551 $enc->encode( { type => 'integer', '12345678901234567890' } ); 1552 1553During decoding, a Math::BigInt object will be created if the value "looks big". 1554 1555 1556=head1 EXPORTS 1557 1558By default, this module exports nothing. This can be overridden by specifying 1559something else: 1560 1561 use Encoding::BER ('import', 'hexdump'); 1562 1563=head1 LIMITATIONS 1564 1565If your application uses the same tag-number for more than one type of implicitly 1566tagged primitive, the decoder will not be able to distinguish between them, and will 1567not be able to decode them both correctly. eg: 1568 1569 width ::= [context 12] implicit integer 1570 girth ::= [context 12] implicit real 1571 1572If you specify data to be encoded using the "short form", the module may 1573guess the type differently than you expect. If it matters, be explicit. 1574 1575This module does not do data validation. It will happily let you encode 1576a non-ascii string as a C<ia5_string>, etc. 1577 1578 1579=head1 PREREQUISITES 1580 1581If you wish to use C<real>s, the POSIX module is required. It will be loaded 1582automatically, if needed. 1583 1584Familiarity with ASN.1 and BER encoding is probably required to take 1585advantage of this module. 1586 1587=head1 SEE ALSO 1588 1589 Yellowstone National Park 1590 Encoding::BER::CER, Encoding::BER::DER 1591 Encoding::BER::SNMP, Encoding::BER::Dumper 1592 ITU-T x.690 1593 1594=head1 AUTHOR 1595 1596 Jeff Weisberg - http://www.tcp4me.com 1597 1598=cut 1599 ; 1600 1601################################################################ 16021; 1603 1604