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