parser.y | searchcode

/opensource.apple.com/source/CPANInternal/CPANInternal-105/Convert-ASN1/parser.y

#
Happy | 603 lines | 515 code | 88 blank | 0 comment | 0 complexity | 3507a60d3d497728697892a1aecab031 MD5 | raw file
Possible License(s): MPL-2.0-no-copyleft-exception, GPL-2.0, BSD-3-Clause, GPL-3.0, MPL-2.0, LGPL-2.0, LGPL-2.1, CC-BY-SA-3.0, IPL-1.0, ISC, AGPL-1.0, AGPL-3.0, JSON, Apache-2.0, 0BSD

<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
    "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
<head>
<title>parser.y</title>
<style type="text/css">
.enscript-comment { font-style: italic; color: rgb(178,34,34); }
.enscript-function-name { font-weight: bold; color: rgb(0,0,255); }
.enscript-variable-name { font-weight: bold; color: rgb(184,134,11); }
.enscript-keyword { font-weight: bold; color: rgb(160,32,240); }
.enscript-reference { font-weight: bold; color: rgb(95,158,160); }
.enscript-string { font-weight: bold; color: rgb(188,143,143); }
.enscript-builtin { font-weight: bold; color: rgb(218,112,214); }
.enscript-type { font-weight: bold; color: rgb(34,139,34); }
.enscript-highlight { text-decoration: underline; color: 0; }
</style>
</head>
<body id="top">
<h1 style="margin:8px;" id="f1">parser.y&nbsp;&nbsp;&nbsp;<span style="font-weight: normal; font-size: 0.5em;">[<a href="?txt">plain text</a>]</span></h1>
<hr/>
<div></div>
<pre>
%token WORD 1
%token CLASS 2
%token SEQUENCE 3
%token SET 4
%token CHOICE 5
%token OF 6
%token IMPLICIT 7
%token EXPLICIT 8
%token OPTIONAL 9
%token LBRACE 10
%token RBRACE 11
%token COMMA 12
%token ANY 13
%token ASSIGN 14
%token NUMBER 15
%token ENUM 16
%token COMPONENTS 17
%token POSTRBRACE 18
%token DEFINED 19
%token BY 20

%{
# Copyright (c) 2000-2005 Graham Barr &lt;<a href="mailto:gbarr@pobox.com">gbarr@pobox.com</a>&gt;. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.

package Convert::ASN1::parser;

use strict;
use Convert::ASN1 qw(:all);
use vars qw(
  $asn $yychar $yyerrflag $yynerrs $yyn @yyss
  $yyssp $yystate @yyvs $yyvsp $yylval $yys $yym $yyval
);

BEGIN { Convert::ASN1-&gt;_internal_syms }

my $yydebug=0;
my %yystate;

my %base_type = (
  BOOLEAN	    =&gt; [ asn_encode_tag(ASN_BOOLEAN),		opBOOLEAN ],
  INTEGER	    =&gt; [ asn_encode_tag(ASN_INTEGER),		opINTEGER ],
  BIT_STRING	    =&gt; [ asn_encode_tag(ASN_BIT_STR),		opBITSTR  ],
  OCTET_STRING	    =&gt; [ asn_encode_tag(ASN_OCTET_STR),		opSTRING  ],
  STRING	    =&gt; [ asn_encode_tag(ASN_OCTET_STR),		opSTRING  ],
  NULL 		    =&gt; [ asn_encode_tag(ASN_NULL),		opNULL    ],
  OBJECT_IDENTIFIER =&gt; [ asn_encode_tag(ASN_OBJECT_ID),		opOBJID   ],
  REAL		    =&gt; [ asn_encode_tag(ASN_REAL),		opREAL    ],
  ENUMERATED	    =&gt; [ asn_encode_tag(ASN_ENUMERATED),	opINTEGER ],
  ENUM		    =&gt; [ asn_encode_tag(ASN_ENUMERATED),	opINTEGER ],
  'RELATIVE-OID'    =&gt; [ asn_encode_tag(ASN_RELATIVE_OID),	opROID	  ],

  SEQUENCE	    =&gt; [ asn_encode_tag(ASN_SEQUENCE | ASN_CONSTRUCTOR), opSEQUENCE ],
  SET               =&gt; [ asn_encode_tag(ASN_SET      | ASN_CONSTRUCTOR), opSET ],

  ObjectDescriptor  =&gt; [ asn_encode_tag(ASN_UNIVERSAL |  7), opSTRING ],
  UTF8String        =&gt; [ asn_encode_tag(ASN_UNIVERSAL | 12), opUTF8 ],
  NumericString     =&gt; [ asn_encode_tag(ASN_UNIVERSAL | 18), opSTRING ],
  PrintableString   =&gt; [ asn_encode_tag(ASN_UNIVERSAL | 19), opSTRING ],
  TeletexString     =&gt; [ asn_encode_tag(ASN_UNIVERSAL | 20), opSTRING ],
  T61String         =&gt; [ asn_encode_tag(ASN_UNIVERSAL | 20), opSTRING ],
  VideotexString    =&gt; [ asn_encode_tag(ASN_UNIVERSAL | 21), opSTRING ],
  IA5String         =&gt; [ asn_encode_tag(ASN_UNIVERSAL | 22), opSTRING ],
  UTCTime           =&gt; [ asn_encode_tag(ASN_UNIVERSAL | 23), opUTIME ],
  GeneralizedTime   =&gt; [ asn_encode_tag(ASN_UNIVERSAL | 24), opGTIME ],
  GraphicString     =&gt; [ asn_encode_tag(ASN_UNIVERSAL | 25), opSTRING ],
  VisibleString     =&gt; [ asn_encode_tag(ASN_UNIVERSAL | 26), opSTRING ],
  ISO646String      =&gt; [ asn_encode_tag(ASN_UNIVERSAL | 26), opSTRING ],
  GeneralString     =&gt; [ asn_encode_tag(ASN_UNIVERSAL | 27), opSTRING ],
  CharacterString   =&gt; [ asn_encode_tag(ASN_UNIVERSAL | 28), opSTRING ],
  UniversalString   =&gt; [ asn_encode_tag(ASN_UNIVERSAL | 28), opSTRING ],
  BMPString         =&gt; [ asn_encode_tag(ASN_UNIVERSAL | 30), opSTRING ],
  BCDString         =&gt; [ asn_encode_tag(ASN_OCTET_STR), opBCD ],

  CHOICE =&gt; [ '', opCHOICE ],
  ANY    =&gt; [ '', opANY ],
);

# Given an OP, wrap it in a SEQUENCE

sub explicit {
  my $op = shift;
  my @seq = @$op;

  @seq[cTYPE,cCHILD,cVAR,cLOOP] = ('SEQUENCE',[$op],undef,undef);
  @{$op}[cTAG,cOPT] = ();

  \@seq;
}

%}

%%

top	: slist		{ $$ = { '' =&gt; $1 }; }
	| module
	;

module  : WORD ASSIGN aitem
		{
		  $$ = { $1, [$3] };
		}
	| module WORD ASSIGN aitem
		{
		  $$=$1;
		  $$-&gt;{$2} = [$4];
		}
	;

aitem	: class plicit anyelem postrb
		{
		  $3-&gt;[cTAG] = $1;
		  $$ = $2 ? explicit($3) : $3;
		}
	| celem
	;

anyelem : onelem
	| eelem
	| oelem
	| selem
	;

celem	: COMPONENTS OF WORD
		{
		  @{$$ = []}[cTYPE,cCHILD] = ('COMPONENTS', $3);
		}
	;

seqset	: SEQUENCE
	| SET
	;

selem	: seqset OF class plicit sselem optional
		{
		  $5-&gt;[cTAG] = $3;
		  @{$$ = []}[cTYPE,cCHILD,cLOOP,cOPT] = ($1, [$5], 1, $6);
		  $$ = explicit($$) if $4;
		}
	;

sselem	: eelem
	| oelem
	| onelem
	;

onelem	: SEQUENCE LBRACE slist RBRACE
		{
		  @{$$ = []}[cTYPE,cCHILD] = ('SEQUENCE', $3);
		}
	| SET      LBRACE slist RBRACE
		{
		  @{$$ = []}[cTYPE,cCHILD] = ('SET', $3);
		}
	| CHOICE   LBRACE nlist RBRACE
		{
		  @{$$ = []}[cTYPE,cCHILD] = ('CHOICE', $3);
		}
	;

eelem   : ENUM LBRACE elist RBRACE
		{
		  @{$$ = []}[cTYPE] = ('ENUM');
		}
	;

oielem	: WORD					{ @{$$ = []}[cTYPE] = $1; }
	| SEQUENCE				{ @{$$ = []}[cTYPE] = $1; }
	| SET					{ @{$$ = []}[cTYPE] = $1; }
	| ANY defined
		{
		  @{$$ = []}[cTYPE,cCHILD,cDEFINE] = ('ANY',undef,$2);
		}
	| ENUM					{ @{$$ = []}[cTYPE] = $1; }
	;

defined :			{ $$=undef; }
	| DEFINED BY WORD	{ $$=$3; }
	;	

oelem	: oielem 
	;

nlist	: nlist1		{ $$ = $1; }
	| nlist1 POSTRBRACE	{ $$ = $1; }
	;

nlist1	: nitem
		{
		  $$ = [ $1 ];
		}
	| nlist1 POSTRBRACE nitem
		{
		  push @{$$=$1}, $3;
		}
	| nlist1 COMMA nitem
		{
		  push @{$$=$1}, $3;
		}
	;

nitem	: WORD class plicit anyelem
		{
		  @{$$=$4}[cVAR,cTAG] = ($1,$2);
		  $$ = explicit($$) if $3;
		}
	;


slist	: slist1		{ $$ = $1; }
	| slist1 POSTRBRACE	{ $$ = $1; }
	;

slist1	: sitem
		{
		  $$ = [ $1 ];
		}
	| slist1 COMMA sitem
		{
		  push @{$$=$1}, $3;
		}
	| slist1 POSTRBRACE sitem
		{
		  push @{$$=$1}, $3;
		}
	;

snitem	: oelem optional
		{
		  @{$$=$1}[cOPT] = ($2);
		}
	| eelem
	| selem
	| onelem
	;

sitem	: WORD class plicit snitem 
		{
		  @{$$=$4}[cVAR,cTAG] = ($1,$2);
		  $$-&gt;[cOPT] = $1 if $$-&gt;[cOPT];
		  $$ = explicit($$) if $3;
		}
	| celem
	| class plicit onelem
		{
		  @{$$=$3}[cTAG] = ($1);
		  $$ = explicit($$) if $2;
		}
	;

optional :			{ $$ = undef; }
	 | OPTIONAL		{ $$ = 1;     }
	 ;


class	:			{ $$ = undef; }
	| CLASS
	;

plicit	:			{ $$ = undef; }
	| EXPLICIT		{ $$ = 1;     }
	| IMPLICIT		{ $$ = 0;     }
	;

elist	: eitem			{}
	| elist COMMA eitem	{}
	;

eitem	: WORD NUMBER		{}
	;

postrb	:			{}
	| POSTRBRACE		{}
	;

%%

my %reserved = (
  'OPTIONAL' 	=&gt; $OPTIONAL,
  'CHOICE' 	=&gt; $CHOICE,
  'OF' 		=&gt; $OF,
  'IMPLICIT' 	=&gt; $IMPLICIT,
  'EXPLICIT' 	=&gt; $EXPLICIT,
  'SEQUENCE'    =&gt; $SEQUENCE,
  'SET'         =&gt; $SET,
  'ANY'         =&gt; $ANY,
  'ENUM'        =&gt; $ENUM,
  'ENUMERATED'  =&gt; $ENUM,
  'COMPONENTS'  =&gt; $COMPONENTS,
  '{'		=&gt; $LBRACE,
  '}'		=&gt; $RBRACE,
  ','		=&gt; $COMMA,
  '::='         =&gt; $ASSIGN,
  'DEFINED'     =&gt; $DEFINED,
  'BY'		=&gt; $BY
);

my $reserved = join(&quot;|&quot;, reverse sort grep { /\w/ } keys %reserved);

my %tag_class = (
  APPLICATION =&gt; ASN_APPLICATION,
  UNIVERSAL   =&gt; ASN_UNIVERSAL,
  PRIVATE     =&gt; ASN_PRIVATE,
  CONTEXT     =&gt; ASN_CONTEXT,
  ''	      =&gt; ASN_CONTEXT # if not specified, its CONTEXT
);

;##
;## This is NOT thread safe !!!!!!
;##

my $pos;
my $last_pos;
my @stacked;

sub parse {
  local(*asn) = \($_[0]);
  ($pos,$last_pos,@stacked) = ();

  eval {
    local $SIG{__DIE__};
    compile(verify(yyparse()));
  }
}

sub compile_one {
  my $tree = shift;
  my $ops = shift;
  my $name = shift;
  foreach my $op (@$ops) {
    next unless ref($op) eq 'ARRAY';
    bless $op;
    my $type = $op-&gt;[cTYPE];
    if (exists $base_type{$type}) {
      $op-&gt;[cTYPE] = $base_type{$type}-&gt;[1];
      $op-&gt;[cTAG] = defined($op-&gt;[cTAG]) ? asn_encode_tag($op-&gt;[cTAG]): $base_type{$type}-&gt;[0];
    }
    else {
      die &quot;Unknown type '$type'\n&quot; unless exists $tree-&gt;{$type};
      my $ref = compile_one(
		  $tree,
		  $tree-&gt;{$type},
		  defined($op-&gt;[cVAR]) ? $name . &quot;.&quot; . $op-&gt;[cVAR] : $name
		);
      if (defined($op-&gt;[cTAG]) &amp;&amp; $ref-&gt;[0][cTYPE] == opCHOICE) {
        @{$op}[cTYPE,cCHILD] = (opSEQUENCE,$ref);
      }
      else {
        @{$op}[cTYPE,cCHILD,cLOOP] = @{$ref-&gt;[0]}[cTYPE,cCHILD,cLOOP];
      }
      $op-&gt;[cTAG] = defined($op-&gt;[cTAG]) ? asn_encode_tag($op-&gt;[cTAG]): $ref-&gt;[0][cTAG];
    }
    $op-&gt;[cTAG] |= chr(ASN_CONSTRUCTOR)
      if length $op-&gt;[cTAG] &amp;&amp; ($op-&gt;[cTYPE] == opSET || $op-&gt;[cTYPE] == opSEQUENCE);

    if ($op-&gt;[cCHILD]) {
      ;# If we have children we are one of
      ;#  opSET opSEQUENCE opCHOICE

      compile_one($tree, $op-&gt;[cCHILD], defined($op-&gt;[cVAR]) ? $name . &quot;.&quot; . $op-&gt;[cVAR] : $name);

      ;# If a CHOICE is given a tag, then it must be EXPLICIT
      if ($op-&gt;[cTYPE] == opCHOICE &amp;&amp; defined($op-&gt;[cTAG]) &amp;&amp; length($op-&gt;[cTAG])) {
	$op = bless explicit($op);
	$op-&gt;[cTYPE] = opSEQUENCE;
      }

      if ( @{$op-&gt;[cCHILD]} &gt; 1) {
        ;#if ($op-&gt;[cTYPE] != opSEQUENCE) {
        ;# Here we need to flatten CHOICEs and check that SET and CHOICE
        ;# do not contain duplicate tags
        ;#}
	if ($op-&gt;[cTYPE] == opSET) {
	  ;# In case we do CER encoding we order the SET elements by thier tags
	  my @tags = map { 
	    length($_-&gt;[cTAG])
		? $_-&gt;[cTAG]
		: $_-&gt;[cTYPE] == opCHOICE
			? (sort map { $_-&gt;[cTAG] } $_-&gt;[cCHILD])[0]
			: ''
	  } @{$op-&gt;[cCHILD]};
	  @{$op-&gt;[cCHILD]} = @{$op-&gt;[cCHILD]}[sort { $tags[$a] cmp $tags[$b] } 0..$#tags];
	}
      }
      else {
	;# A SET of one element can be treated the same as a SEQUENCE
	$op-&gt;[cTYPE] = opSEQUENCE if $op-&gt;[cTYPE] == opSET;
      }
    }
  }
  $ops;
}

sub compile {
  my $tree = shift;

  ;# The tree should be valid enough to be able to
  ;#  - resolve references
  ;#  - encode tags
  ;#  - verify CHOICEs do not contain duplicate tags

  ;# once references have been resolved, and also due to
  ;# flattening of COMPONENTS, it is possible for an op
  ;# to appear in multiple places. So once an op is
  ;# compiled we bless it. This ensure we dont try to
  ;# compile it again.

  while(my($k,$v) = each %$tree) {
    compile_one($tree,$v,$k);
  }

  $tree;
}

sub verify {
  my $tree = shift or return;
  my $err = &quot;&quot;;

  ;# Well it parsed correctly, now we
  ;#  - check references exist
  ;#  - flatten COMPONENTS OF (checking for loops)
  ;#  - check for duplicate var names

  while(my($name,$ops) = each %$tree) {
    my $stash = {};
    my @scope = ();
    my $path = &quot;&quot;;
    my $idx = 0;

    while($ops) {
      if ($idx &lt; @$ops) {
	my $op = $ops-&gt;[$idx++];
	my $var;
	if (defined ($var = $op-&gt;[cVAR])) {
	  
	  $err .= &quot;$name: $path.$var used multiple times\n&quot;
	    if $stash-&gt;{$var}++;

	}
	if (defined $op-&gt;[cCHILD]) {
	  if (ref $op-&gt;[cCHILD]) {
	    push @scope, [$stash, $path, $ops, $idx];
	    if (defined $var) {
	      $stash = {};
	      $path .= &quot;.&quot; . $var;
	    }
	    $idx = 0;
	    $ops = $op-&gt;[cCHILD];
	  }
	  elsif ($op-&gt;[cTYPE] eq 'COMPONENTS') {
	    splice(@$ops,--$idx,1,expand_ops($tree, $op-&gt;[cCHILD]));
	  }
          else {
	    die &quot;Internal error\n&quot;;
          }
	}
      }
      else {
	my $s = pop @scope
	  or last;
	($stash,$path,$ops,$idx) = @$s;
      }
    }
  }
  die $err if length $err;
  $tree;
}

sub expand_ops {
  my $tree = shift;
  my $want = shift;
  my $seen = shift || { };
  
  die &quot;COMPONENTS OF loop $want\n&quot; if $seen-&gt;{$want}++;
  die &quot;Undefined macro $want\n&quot; unless exists $tree-&gt;{$want};
  my $ops = $tree-&gt;{$want};
  die &quot;Bad macro for COMPUNENTS OF '$want'\n&quot;
    unless @$ops == 1
        &amp;&amp; ($ops-&gt;[0][cTYPE] eq 'SEQUENCE' || $ops-&gt;[0][cTYPE] eq 'SET')
        &amp;&amp; ref $ops-&gt;[0][cCHILD];
  $ops = $ops-&gt;[0][cCHILD];
  for(my $idx = 0 ; $idx &lt; @$ops ; ) {
    my $op = $ops-&gt;[$idx++];
    if ($op-&gt;[cTYPE] eq 'COMPONENTS') {
      splice(@$ops,--$idx,1,expand_ops($tree, $op-&gt;[cCHILD], $seen));
    }
  }

  @$ops;
}

sub _yylex {
  my $ret = &amp;_yylex;
  warn $ret;
  $ret;
}

sub yylex {
  return shift @stacked if @stacked;

  while ($asn =~ /\G(?:
	  (\s+|--[^\n]*)
	|
	  ([,{}]|::=)
	|
	  ($reserved)\b
	|
	  (
	    (?:OCTET|BIT)\s+STRING
	   |
	    OBJECT\s+IDENTIFIER
	   |
	    RELATIVE-OID
	  )\b
	|
	  (\w+(?:-\w+)*)
	|
	    \[\s*
	  (
	   (?:(?:APPLICATION|PRIVATE|UNIVERSAL|CONTEXT)\s+)?
	   \d+
          )
	    \s*\]
	|
	  \((\d+)\)
	)/sxgo
  ) {

    ($last_pos,$pos) = ($pos,pos($asn));

    next if defined $1; # comment or whitespace

    if (defined $2 or defined $3) {
      # A comma is not required after a '}' so to aid the
      # parser we insert a fake token after any '}'
      push @stacked, $POSTRBRACE if defined $2 and $+ eq '}';

      return $reserved{$yylval = $+};
    }

    if (defined $4) {
      ($yylval = $+) =~ s/\s+/_/g;
      return $WORD;
    }

    if (defined $5) {
      $yylval = $+;
      return $WORD;
    }

    if (defined $6) {
      my($class,$num) = ($+ =~ /^([A-Z]*)\s*(\d+)$/);
      $yylval = asn_tag($tag_class{$class}, $num); 
      return $CLASS;
    }

    if (defined $7) {
      $yylval = $+;
      return $NUMBER;
    }

    die &quot;Internal error\n&quot;;

  }

  die &quot;Parse error before &quot;,substr($asn,$pos,40),&quot;\n&quot;
    unless $pos == length($asn);

  0
}

sub yyerror {
  die @_,&quot; &quot;,substr($asn,$last_pos,40),&quot;\n&quot;;
}

1;

</pre>
<hr />
</body></html>