1 %token WORD 1 2 %token CLASS 2 3 %token SEQUENCE 3 4 %token SET 4 5 %token CHOICE 5 6 %token OF 6 7 %token IMPLICIT 7 8 %token EXPLICIT 8 9 %token OPTIONAL 9 10 %token LBRACE 10 11 %token RBRACE 11 12 %token COMMA 12 13 %token ANY 13 14 %token ASSIGN 14 15 %token NUMBER 15 16 %token ENUM 16 17 %token COMPONENTS 17 18 %token POSTRBRACE 18 19 %token DEFINED 19 20 %token BY 20 21 %token EXTENSION_MARKER 21 22 23 %{ 24 # Copyright (c) 2000-2005 Graham Barr <gbarr@pobox.com>. All rights reserved. 25 # This program is free software; you can redistribute it and/or 26 # modify it under the same terms as Perl itself. 27 28 package Convert::ASN1::parser; 29 30 use strict; 31 use Convert::ASN1 qw(:all); 32 use vars qw( 33 $asn $yychar $yyerrflag $yynerrs $yyn @yyss 34 $yyssp $yystate @yyvs $yyvsp $yylval $yys $yym $yyval 35 ); 36 37 BEGIN { Convert::ASN1->_internal_syms } 38 39 my $yydebug=0; 40 my %yystate; 41 42 my %base_type = ( 43 BOOLEAN => [ asn_encode_tag(ASN_BOOLEAN), opBOOLEAN ], 44 INTEGER => [ asn_encode_tag(ASN_INTEGER), opINTEGER ], 45 BIT_STRING => [ asn_encode_tag(ASN_BIT_STR), opBITSTR ], 46 OCTET_STRING => [ asn_encode_tag(ASN_OCTET_STR), opSTRING ], 47 STRING => [ asn_encode_tag(ASN_OCTET_STR), opSTRING ], 48 NULL => [ asn_encode_tag(ASN_NULL), opNULL ], 49 OBJECT_IDENTIFIER => [ asn_encode_tag(ASN_OBJECT_ID), opOBJID ], 50 REAL => [ asn_encode_tag(ASN_REAL), opREAL ], 51 ENUMERATED => [ asn_encode_tag(ASN_ENUMERATED), opINTEGER ], 52 ENUM => [ asn_encode_tag(ASN_ENUMERATED), opINTEGER ], 53 'RELATIVE-OID' => [ asn_encode_tag(ASN_RELATIVE_OID), opROID ], 54 55 SEQUENCE => [ asn_encode_tag(ASN_SEQUENCE | ASN_CONSTRUCTOR), opSEQUENCE ], 56 EXPLICIT => [ asn_encode_tag(ASN_SEQUENCE | ASN_CONSTRUCTOR), opEXPLICIT ], 57 SET => [ asn_encode_tag(ASN_SET | ASN_CONSTRUCTOR), opSET ], 58 59 ObjectDescriptor => [ asn_encode_tag(ASN_UNIVERSAL | 7), opSTRING ], 60 UTF8String => [ asn_encode_tag(ASN_UNIVERSAL | 12), opUTF8 ], 61 NumericString => [ asn_encode_tag(ASN_UNIVERSAL | 18), opSTRING ], 62 PrintableString => [ asn_encode_tag(ASN_UNIVERSAL | 19), opSTRING ], 63 TeletexString => [ asn_encode_tag(ASN_UNIVERSAL | 20), opSTRING ], 64 T61String => [ asn_encode_tag(ASN_UNIVERSAL | 20), opSTRING ], 65 VideotexString => [ asn_encode_tag(ASN_UNIVERSAL | 21), opSTRING ], 66 IA5String => [ asn_encode_tag(ASN_UNIVERSAL | 22), opSTRING ], 67 UTCTime => [ asn_encode_tag(ASN_UNIVERSAL | 23), opUTIME ], 68 GeneralizedTime => [ asn_encode_tag(ASN_UNIVERSAL | 24), opGTIME ], 69 GraphicString => [ asn_encode_tag(ASN_UNIVERSAL | 25), opSTRING ], 70 VisibleString => [ asn_encode_tag(ASN_UNIVERSAL | 26), opSTRING ], 71 ISO646String => [ asn_encode_tag(ASN_UNIVERSAL | 26), opSTRING ], 72 GeneralString => [ asn_encode_tag(ASN_UNIVERSAL | 27), opSTRING ], 73 CharacterString => [ asn_encode_tag(ASN_UNIVERSAL | 28), opSTRING ], 74 UniversalString => [ asn_encode_tag(ASN_UNIVERSAL | 28), opSTRING ], 75 BMPString => [ asn_encode_tag(ASN_UNIVERSAL | 30), opSTRING ], 76 BCDString => [ asn_encode_tag(ASN_OCTET_STR), opBCD ], 77 78 CHOICE => [ '', opCHOICE ], 79 ANY => [ '', opANY ], 80 81 EXTENSION_MARKER => [ '', opEXTENSIONS ], 82 ); 83 84 my $tagdefault = 1; # 0:IMPLICIT , 1:EXPLICIT default 85 86 # args: class,plicit 87 sub need_explicit { 88 (defined($_[0]) && (defined($_[1])?$_[1]:$tagdefault)); 89 } 90 91 # Given an OP, wrap it in a SEQUENCE 92 93 sub explicit { 94 my $op = shift; 95 my @seq = @$op; 96 97 @seq[cTYPE,cCHILD,cVAR,cLOOP] = ('EXPLICIT',[$op],undef,undef); 98 @{$op}[cTAG,cOPT] = (); 99 100 \@seq; 101 } 102 103 %} 104 105 %% 106 107 top : slist { $$ = { '' => $1 }; } 108 | module 109 ; 110 111 module : WORD ASSIGN aitem 112 { 113 $$ = { $1, [$3] }; 114 } 115 | module WORD ASSIGN aitem 116 { 117 $$=$1; 118 $$->{$2} = [$4]; 119 } 120 ; 121 122 aitem : class plicit anyelem postrb 123 { 124 $3->[cTAG] = $1; 125 $$ = need_explicit($1,$2) ? explicit($3) : $3; 126 } 127 | celem 128 ; 129 130 anyelem : onelem 131 | eelem 132 | oelem 133 | selem 134 ; 135 136 celem : COMPONENTS OF WORD 137 { 138 @{$$ = []}[cTYPE,cCHILD] = ('COMPONENTS', $3); 139 } 140 ; 141 142 seqset : SEQUENCE 143 | SET 144 ; 145 146 selem : seqset OF class plicit sselem optional 147 { 148 $5->[cTAG] = $3; 149 @{$$ = []}[cTYPE,cCHILD,cLOOP,cOPT] = ($1, [$5], 1, $6); 150 $$ = explicit($$) if need_explicit($3,$4); 151 } 152 ; 153 154 sselem : eelem 155 | oelem 156 | onelem 157 ; 158 159 onelem : SEQUENCE LBRACE slist RBRACE 160 { 161 @{$$ = []}[cTYPE,cCHILD] = ('SEQUENCE', $3); 162 } 163 | SET LBRACE slist RBRACE 164 { 165 @{$$ = []}[cTYPE,cCHILD] = ('SET', $3); 166 } 167 | CHOICE LBRACE nlist RBRACE 168 { 169 @{$$ = []}[cTYPE,cCHILD] = ('CHOICE', $3); 170 } 171 ; 172 173 eelem : ENUM LBRACE elist RBRACE 174 { 175 @{$$ = []}[cTYPE] = ('ENUM'); 176 } 177 ; 178 179 oielem : WORD { @{$$ = []}[cTYPE] = $1; } 180 | SEQUENCE { @{$$ = []}[cTYPE] = $1; } 181 | SET { @{$$ = []}[cTYPE] = $1; } 182 | ANY defined 183 { 184 @{$$ = []}[cTYPE,cCHILD,cDEFINE] = ('ANY',undef,$2); 185 } 186 | ENUM { @{$$ = []}[cTYPE] = $1; } 187 ; 188 189 defined : { $$=undef; } 190 | DEFINED BY WORD { $$=$3; } 191 ; 192 193 oelem : oielem 194 ; 195 196 nlist : nlist1 { $$ = $1; } 197 | nlist1 POSTRBRACE { $$ = $1; } 198 ; 199 200 nlist1 : nitem 201 { 202 $$ = [ $1 ]; 203 } 204 | nlist1 POSTRBRACE nitem 205 { 206 push @{$$=$1}, $3; 207 } 208 | nlist1 COMMA nitem 209 { 210 push @{$$=$1}, $3; 211 } 212 ; 213 214 nitem : WORD class plicit anyelem 215 { 216 @{$$=$4}[cVAR,cTAG] = ($1,$2); 217 $$ = explicit($$) if need_explicit($2,$3); 218 } 219 | EXTENSION_MARKER 220 { 221 @{$$=[]}[cTYPE] = 'EXTENSION_MARKER'; 222 } 223 ; 224 225 226 slist : { $$ = []; } 227 | slist1 228 { 229 my $extension = 0; 230 $$ = []; 231 for my $i (@{$1}) { 232 $extension = 1 if $i->[cTYPE] eq 'EXTENSION_MARKER'; 233 $i->[cEXT] = $i->[cOPT]; 234 $i->[cEXT] = 1 if $extension; 235 push @{$$}, $i unless $i->[cTYPE] eq 'EXTENSION_MARKER'; 236 } 237 my $e = []; $e->[cTYPE] = 'EXTENSION_MARKER'; 238 push @{$$}, $e if $extension; 239 } 240 | slist1 POSTRBRACE 241 { 242 my $extension = 0; 243 $$ = []; 244 for my $i (@{$1}) { 245 $extension = 1 if $i->[cTYPE] eq 'EXTENSION_MARKER'; 246 $i->[cEXT] = $i->[cOPT]; 247 $i->[cEXT] = 1 if $extension; 248 push @{$$}, $i unless $i->[cTYPE] eq 'EXTENSION_MARKER'; 249 } 250 my $e = []; $e->[cTYPE] = 'EXTENSION_MARKER'; 251 push @{$$}, $e if $extension; 252 } 253 ; 254 255 slist1 : sitem 256 { 257 $$ = [ $1 ]; 258 } 259 | slist1 COMMA sitem 260 { 261 push @{$$=$1}, $3; 262 } 263 | slist1 POSTRBRACE sitem 264 { 265 push @{$$=$1}, $3; 266 } 267 ; 268 269 snitem : oelem optional 270 { 271 @{$$=$1}[cOPT] = ($2); 272 } 273 | eelem 274 | selem 275 | onelem 276 ; 277 278 sitem : WORD class plicit snitem 279 { 280 @{$$=$4}[cVAR,cTAG] = ($1,$2); 281 $$->[cOPT] = $1 if $$->[cOPT]; 282 $$ = explicit($$) if need_explicit($2,$3); 283 } 284 | celem 285 | class plicit onelem 286 { 287 @{$$=$3}[cTAG] = ($1); 288 $$ = explicit($$) if need_explicit($1,$2); 289 } 290 | EXTENSION_MARKER 291 { 292 @{$$=[]}[cTYPE] = 'EXTENSION_MARKER'; 293 } 294 ; 295 296 optional : { $$ = undef; } 297 | OPTIONAL { $$ = 1; } 298 ; 299 300 301 class : { $$ = undef; } 302 | CLASS 303 ; 304 305 plicit : { $$ = undef; } 306 | EXPLICIT { $$ = 1; } 307 | IMPLICIT { $$ = 0; } 308 ; 309 310 elist : eitem {} 311 | elist COMMA eitem {} 312 ; 313 314 eitem : WORD NUMBER {} 315 ; 316 317 postrb : {} 318 | POSTRBRACE {} 319 ; 320 321 %% 322 323 my %reserved = ( 324 'OPTIONAL' => $OPTIONAL, 325 'CHOICE' => $CHOICE, 326 'OF' => $OF, 327 'IMPLICIT' => $IMPLICIT, 328 'EXPLICIT' => $EXPLICIT, 329 'SEQUENCE' => $SEQUENCE, 330 'SET' => $SET, 331 'ANY' => $ANY, 332 'ENUM' => $ENUM, 333 'ENUMERATED' => $ENUM, 334 'COMPONENTS' => $COMPONENTS, 335 '{' => $LBRACE, 336 '}' => $RBRACE, 337 ',' => $COMMA, 338 '::=' => $ASSIGN, 339 'DEFINED' => $DEFINED, 340 'BY' => $BY 341 ); 342 343 my $reserved = join("|", reverse sort grep { /\w/ } keys %reserved); 344 345 my %tag_class = ( 346 APPLICATION => ASN_APPLICATION, 347 UNIVERSAL => ASN_UNIVERSAL, 348 PRIVATE => ASN_PRIVATE, 349 CONTEXT => ASN_CONTEXT, 350 '' => ASN_CONTEXT # if not specified, its CONTEXT 351 ); 352 353 ;## 354 ;## This is NOT thread safe !!!!!! 355 ;## 356 357 my $pos; 358 my $last_pos; 359 my @stacked; 360 361 sub parse { 362 local(*asn) = \($_[0]); 363 $tagdefault = $_[1] eq 'EXPLICIT' ? 1 : 0; 364 ($pos,$last_pos,@stacked) = (); 365 366 eval { 367 local $SIG{__DIE__}; 368 compile(verify(yyparse())); 369 } 370 } 371 372 sub compile_one { 373 my $tree = shift; 374 my $ops = shift; 375 my $name = shift; 376 foreach my $op (@$ops) { 377 next unless ref($op) eq 'ARRAY'; 378 bless $op; 379 my $type = $op->[cTYPE]; 380 if (exists $base_type{$type}) { 381 $op->[cTYPE] = $base_type{$type}->[1]; 382 $op->[cTAG] = defined($op->[cTAG]) ? asn_encode_tag($op->[cTAG]): $base_type{$type}->[0]; 383 } 384 else { 385 die "Unknown type '$type'\n" unless exists $tree->{$type}; 386 my $ref = compile_one( 387 $tree, 388 $tree->{$type}, 389 defined($op->[cVAR]) ? $name . "." . $op->[cVAR] : $name 390 ); 391 if (defined($op->[cTAG]) && $ref->[0][cTYPE] == opCHOICE) { 392 @{$op}[cTYPE,cCHILD] = (opSEQUENCE,$ref); 393 } 394 else { 395 @{$op}[cTYPE,cCHILD,cLOOP] = @{$ref->[0]}[cTYPE,cCHILD,cLOOP]; 396 } 397 $op->[cTAG] = defined($op->[cTAG]) ? asn_encode_tag($op->[cTAG]): $ref->[0][cTAG]; 398 } 399 $op->[cTAG] |= pack("C",ASN_CONSTRUCTOR) 400 if length $op->[cTAG] && ($op->[cTYPE] == opSET || $op->[cTYPE] == opEXPLICIT || $op->[cTYPE] == opSEQUENCE); 401 402 if ($op->[cCHILD]) { 403 ;# If we have children we are one of 404 ;# opSET opSEQUENCE opCHOICE opEXPLICIT 405 406 compile_one($tree, $op->[cCHILD], defined($op->[cVAR]) ? $name . "." . $op->[cVAR] : $name); 407 408 ;# If a CHOICE is given a tag, then it must be EXPLICIT 409 if ($op->[cTYPE] == opCHOICE && defined($op->[cTAG]) && length($op->[cTAG])) { 410 $op = bless explicit($op); 411 $op->[cTYPE] = opSEQUENCE; 412 } 413 414 if ( @{$op->[cCHILD]} > 1) { 415 ;#if ($op->[cTYPE] != opSEQUENCE) { 416 ;# Here we need to flatten CHOICEs and check that SET and CHOICE 417 ;# do not contain duplicate tags 418 ;#} 419 if ($op->[cTYPE] == opSET) { 420 ;# In case we do CER encoding we order the SET elements by thier tags 421 my @tags = map { 422 length($_->[cTAG]) 423 ? $_->[cTAG] 424 : $_->[cTYPE] == opCHOICE 425 ? (sort map { $_->[cTAG] } $_->[cCHILD])[0] 426 : '' 427 } @{$op->[cCHILD]}; 428 @{$op->[cCHILD]} = @{$op->[cCHILD]}[sort { $tags[$a] cmp $tags[$b] } 0..$#tags]; 429 } 430 } 431 else { 432 ;# A SET of one element can be treated the same as a SEQUENCE 433 $op->[cTYPE] = opSEQUENCE if $op->[cTYPE] == opSET; 434 } 435 } 436 } 437 $ops; 438 } 439 440 sub compile { 441 my $tree = shift; 442 443 ;# The tree should be valid enough to be able to 444 ;# - resolve references 445 ;# - encode tags 446 ;# - verify CHOICEs do not contain duplicate tags 447 448 ;# once references have been resolved, and also due to 449 ;# flattening of COMPONENTS, it is possible for an op 450 ;# to appear in multiple places. So once an op is 451 ;# compiled we bless it. This ensure we dont try to 452 ;# compile it again. 453 454 while(my($k,$v) = each %$tree) { 455 compile_one($tree,$v,$k); 456 } 457 458 $tree; 459 } 460 461 sub verify { 462 my $tree = shift or return; 463 my $err = ""; 464 465 ;# Well it parsed correctly, now we 466 ;# - check references exist 467 ;# - flatten COMPONENTS OF (checking for loops) 468 ;# - check for duplicate var names 469 470 while(my($name,$ops) = each %$tree) { 471 my $stash = {}; 472 my @scope = (); 473 my $path = ""; 474 my $idx = 0; 475 476 while($ops) { 477 if ($idx < @$ops) { 478 my $op = $ops->[$idx++]; 479 my $var; 480 if (defined ($var = $op->[cVAR])) { 481 482 $err .= "$name: $path.$var used multiple times\n" 483 if $stash->{$var}++; 484 485 } 486 if (defined $op->[cCHILD]) { 487 if (ref $op->[cCHILD]) { 488 push @scope, [$stash, $path, $ops, $idx]; 489 if (defined $var) { 490 $stash = {}; 491 $path .= "." . $var; 492 } 493 $idx = 0; 494 $ops = $op->[cCHILD]; 495 } 496 elsif ($op->[cTYPE] eq 'COMPONENTS') { 497 splice(@$ops,--$idx,1,expand_ops($tree, $op->[cCHILD])); 498 } 499 else { 500 die "Internal error\n"; 501 } 502 } 503 } 504 else { 505 my $s = pop @scope 506 or last; 507 ($stash,$path,$ops,$idx) = @$s; 508 } 509 } 510 } 511 die $err if length $err; 512 $tree; 513 } 514 515 sub expand_ops { 516 my $tree = shift; 517 my $want = shift; 518 my $seen = shift || { }; 519 520 die "COMPONENTS OF loop $want\n" if $seen->{$want}++; 521 die "Undefined macro $want\n" unless exists $tree->{$want}; 522 my $ops = $tree->{$want}; 523 die "Bad macro for COMPUNENTS OF '$want'\n" 524 unless @$ops == 1 525 && ($ops->[0][cTYPE] eq 'SEQUENCE' || $ops->[0][cTYPE] eq 'SET') 526 && ref $ops->[0][cCHILD]; 527 $ops = $ops->[0][cCHILD]; 528 for(my $idx = 0 ; $idx < @$ops ; ) { 529 my $op = $ops->[$idx++]; 530 if ($op->[cTYPE] eq 'COMPONENTS') { 531 splice(@$ops,--$idx,1,expand_ops($tree, $op->[cCHILD], $seen)); 532 } 533 } 534 535 @$ops; 536 } 537 538 sub _yylex { 539 my $ret = &_yylex; 540 warn $ret; 541 $ret; 542 } 543 544 sub yylex { 545 return shift @stacked if @stacked; 546 547 while ($asn =~ /\G(?: 548 (\s+|--[^\n]*) 549 | 550 ([,{}]|::=) 551 | 552 ($reserved)\b 553 | 554 ( 555 (?:OCTET|BIT)\s+STRING 556 | 557 OBJECT\s+IDENTIFIER 558 | 559 RELATIVE-OID 560 )\b 561 | 562 (\w+(?:-\w+)*) 563 | 564 \[\s* 565 ( 566 (?:(?:APPLICATION|PRIVATE|UNIVERSAL|CONTEXT)\s+)? 567 \d+ 568 ) 569 \s*\] 570 | 571 \((\d+)\) 572 | 573 (\.\.\.) 574 )/sxgo 575 ) { 576 577 ($last_pos,$pos) = ($pos,pos($asn)); 578 579 next if defined $1; # comment or whitespace 580 581 if (defined $2 or defined $3) { 582 my $ret = $+; 583 584 # A comma is not required after a '}' so to aid the 585 # parser we insert a fake token after any '}' 586 if ($ret eq '}') { 587 my $p = pos($asn); 588 my @tmp = @stacked; 589 @stacked = (); 590 pos($asn) = $p if yylex() != $COMMA; # swallow it 591 @stacked = (@tmp, $POSTRBRACE); 592 } 593 594 return $reserved{$yylval = $ret}; 595 } 596 597 if (defined $4) { 598 ($yylval = $+) =~ s/\s+/_/g; 599 return $WORD; 600 } 601 602 if (defined $5) { 603 $yylval = $+; 604 return $WORD; 605 } 606 607 if (defined $6) { 608 my($class,$num) = ($+ =~ /^([A-Z]*)\s*(\d+)$/); 609 $yylval = asn_tag($tag_class{$class}, $num); 610 return $CLASS; 611 } 612 613 if (defined $7) { 614 $yylval = $+; 615 return $NUMBER; 616 } 617 618 if (defined $8) { 619 return $EXTENSION_MARKER; 620 } 621 622 die "Internal error\n"; 623 624 } 625 626 die "Parse error before ",substr($asn,$pos,40),"\n" 627 unless $pos == length($asn); 628 629 0 630 } 631 632 sub yyerror { 633 die @_," ",substr($asn,$last_pos,40),"\n"; 634 } 635 636 1; 637 638