%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

%token EXTENSION_MARKER 21

%{

# Copyright (c) 2000-2005 Graham Barr <gbarr@pobox.com>. 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->_internal_syms }

my $yydebug=0;

my %yystate;

my %base_type = (

  BOOLEAN	    => [ asn_encode_tag(ASN_BOOLEAN),		opBOOLEAN ],

  INTEGER	    => [ asn_encode_tag(ASN_INTEGER),		opINTEGER ],

  BIT_STRING	    => [ asn_encode_tag(ASN_BIT_STR),		opBITSTR  ],

  OCTET_STRING	    => [ asn_encode_tag(ASN_OCTET_STR),		opSTRING  ],

  STRING	    => [ asn_encode_tag(ASN_OCTET_STR),		opSTRING  ],

  NULL 		    => [ asn_encode_tag(ASN_NULL),		opNULL    ],

  OBJECT_IDENTIFIER => [ asn_encode_tag(ASN_OBJECT_ID),		opOBJID   ],

  REAL		    => [ asn_encode_tag(ASN_REAL),		opREAL    ],

  ENUMERATED	    => [ asn_encode_tag(ASN_ENUMERATED),	opINTEGER ],

  ENUM		    => [ asn_encode_tag(ASN_ENUMERATED),	opINTEGER ],

  'RELATIVE-OID'    => [ asn_encode_tag(ASN_RELATIVE_OID),	opROID	  ],

  SEQUENCE	    => [ asn_encode_tag(ASN_SEQUENCE | ASN_CONSTRUCTOR), opSEQUENCE ],

  EXPLICIT	    => [ asn_encode_tag(ASN_SEQUENCE | ASN_CONSTRUCTOR), opEXPLICIT ],

  SET               => [ asn_encode_tag(ASN_SET      | ASN_CONSTRUCTOR), opSET ],

  ObjectDescriptor  => [ asn_encode_tag(ASN_UNIVERSAL |  7), opSTRING ],

  UTF8String        => [ asn_encode_tag(ASN_UNIVERSAL | 12), opUTF8 ],

  NumericString     => [ asn_encode_tag(ASN_UNIVERSAL | 18), opSTRING ],

  PrintableString   => [ asn_encode_tag(ASN_UNIVERSAL | 19), opSTRING ],

  TeletexString     => [ asn_encode_tag(ASN_UNIVERSAL | 20), opSTRING ],

  T61String         => [ asn_encode_tag(ASN_UNIVERSAL | 20), opSTRING ],

  VideotexString    => [ asn_encode_tag(ASN_UNIVERSAL | 21), opSTRING ],

  IA5String         => [ asn_encode_tag(ASN_UNIVERSAL | 22), opSTRING ],

  UTCTime           => [ asn_encode_tag(ASN_UNIVERSAL | 23), opUTIME ],

  GeneralizedTime   => [ asn_encode_tag(ASN_UNIVERSAL | 24), opGTIME ],

  GraphicString     => [ asn_encode_tag(ASN_UNIVERSAL | 25), opSTRING ],

  VisibleString     => [ asn_encode_tag(ASN_UNIVERSAL | 26), opSTRING ],

  ISO646String      => [ asn_encode_tag(ASN_UNIVERSAL | 26), opSTRING ],

  GeneralString     => [ asn_encode_tag(ASN_UNIVERSAL | 27), opSTRING ],

  CharacterString   => [ asn_encode_tag(ASN_UNIVERSAL | 28), opSTRING ],

  UniversalString   => [ asn_encode_tag(ASN_UNIVERSAL | 28), opSTRING ],

  BMPString         => [ asn_encode_tag(ASN_UNIVERSAL | 30), opSTRING ],

  BCDString         => [ asn_encode_tag(ASN_OCTET_STR), opBCD ],

  CHOICE => [ '', opCHOICE ],

  ANY    => [ '', opANY ],

  EXTENSION_MARKER => [ '', opEXTENSIONS ],

);

my $tagdefault = 1; # 0:IMPLICIT , 1:EXPLICIT default

# args: class,plicit

sub need_explicit {

  (defined($_[0]) && (defined($_[1])?$_[1]:$tagdefault));

}

# Given an OP, wrap it in a SEQUENCE

sub explicit {

  my $op = shift;

  my @seq = @$op;

  @seq[cTYPE,cCHILD,cVAR,cLOOP] = ('EXPLICIT',[$op],undef,undef);

  @{$op}[cTAG,cOPT] = ();

  \@seq;

}

%}

%%

top	: slist		{ $$ = { '' => $1 }; }

	| module

	;

module  : WORD ASSIGN aitem

		{

		  $$ = { $1, [$3] };

		}

	| module WORD ASSIGN aitem

		{

		  $$=$1;

		  $$->{$2} = [$4];

		}

	;

aitem	: class plicit anyelem postrb

		{

		  $3->[cTAG] = $1;

		  $$ = need_explicit($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->[cTAG] = $3;

		  @{$$ = []}[cTYPE,cCHILD,cLOOP,cOPT] = ($1, [$5], 1, $6);

		  $$ = explicit($$) if need_explicit($3,$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 need_explicit($2,$3);

		}

	| EXTENSION_MARKER

		{

		    @{$$=[]}[cTYPE] = 'EXTENSION_MARKER';

		}

	;

slist	:                       { $$ = []; }

        | slist1

		{

		  my $extension = 0;

		  $$ = [];

		  for my $i (@{$1}) {

		    $extension = 1 if $i->[cTYPE] eq 'EXTENSION_MARKER';

		    $i->[cEXT] = $i->[cOPT];

		    $i->[cEXT] = 1 if $extension;

		    push @{$$}, $i unless $i->[cTYPE] eq 'EXTENSION_MARKER';

		  }

		  my $e = []; $e->[cTYPE] = 'EXTENSION_MARKER';

		  push @{$$}, $e if $extension;

		}

	| slist1 POSTRBRACE

		{

		  my $extension = 0;

		  $$ = [];

		  for my $i (@{$1}) {

		    $extension = 1 if $i->[cTYPE] eq 'EXTENSION_MARKER';

		    $i->[cEXT] = $i->[cOPT];

		    $i->[cEXT] = 1 if $extension;

		    push @{$$}, $i unless $i->[cTYPE] eq 'EXTENSION_MARKER';

		  }

		  my $e = []; $e->[cTYPE] = 'EXTENSION_MARKER';

		  push @{$$}, $e if $extension;

		}

	;

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);

		  $$->[cOPT] = $1 if $$->[cOPT];

		  $$ = explicit($$) if need_explicit($2,$3);

		}

	| celem

	| class plicit onelem

		{

		  @{$$=$3}[cTAG] = ($1);

		  $$ = explicit($$) if need_explicit($1,$2);

		}

	| EXTENSION_MARKER

		{

		    @{$$=[]}[cTYPE] = 'EXTENSION_MARKER';

		}

	;

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' 	=> $OPTIONAL,

  'CHOICE' 	=> $CHOICE,

  'OF' 		=> $OF,

  'IMPLICIT' 	=> $IMPLICIT,

  'EXPLICIT' 	=> $EXPLICIT,

  'SEQUENCE'    => $SEQUENCE,

  'SET'         => $SET,

  'ANY'         => $ANY,

  'ENUM'        => $ENUM,

  'ENUMERATED'  => $ENUM,

  'COMPONENTS'  => $COMPONENTS,

  '{'		=> $LBRACE,

  '}'		=> $RBRACE,

  ','		=> $COMMA,

  '::='         => $ASSIGN,

  'DEFINED'     => $DEFINED,

  'BY'		=> $BY

);

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

my %tag_class = (

  APPLICATION => ASN_APPLICATION,

  UNIVERSAL   => ASN_UNIVERSAL,

  PRIVATE     => ASN_PRIVATE,

  CONTEXT     => ASN_CONTEXT,

  ''	      => ASN_CONTEXT # if not specified, its CONTEXT

);

;##

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

;##

my $pos;

my $last_pos;

my @stacked;

sub parse {

  local(*asn) = \($_[0]);

  $tagdefault = $_[1] eq 'EXPLICIT' ? 1 : 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->[cTYPE];

    if (exists $base_type{$type}) {

      $op->[cTYPE] = $base_type{$type}->[1];

      $op->[cTAG] = defined($op->[cTAG]) ? asn_encode_tag($op->[cTAG]): $base_type{$type}->[0];

    }

    else {

      die "Unknown type '$type'\n" unless exists $tree->{$type};

      my $ref = compile_one(

		  $tree,

		  $tree->{$type},

		  defined($op->[cVAR]) ? $name . "." . $op->[cVAR] : $name

		);

      if (defined($op->[cTAG]) && $ref->[0][cTYPE] == opCHOICE) {

        @{$op}[cTYPE,cCHILD] = (opSEQUENCE,$ref);

      }

      else {

        @{$op}[cTYPE,cCHILD,cLOOP] = @{$ref->[0]}[cTYPE,cCHILD,cLOOP];

      }

      $op->[cTAG] = defined($op->[cTAG]) ? asn_encode_tag($op->[cTAG]): $ref->[0][cTAG];

    }

    $op->[cTAG] |= pack("C",ASN_CONSTRUCTOR)

      if length $op->[cTAG] && ($op->[cTYPE] == opSET || $op->[cTYPE] == opEXPLICIT || $op->[cTYPE] == opSEQUENCE);

    if ($op->[cCHILD]) {

      ;# If we have children we are one of

      ;#  opSET opSEQUENCE opCHOICE opEXPLICIT

      compile_one($tree, $op->[cCHILD], defined($op->[cVAR]) ? $name . "." . $op->[cVAR] : $name);

      ;# If a CHOICE is given a tag, then it must be EXPLICIT

      if ($op->[cTYPE] == opCHOICE && defined($op->[cTAG]) && length($op->[cTAG])) {

	$op = bless explicit($op);

	$op->[cTYPE] = opSEQUENCE;

      }

      if ( @{$op->[cCHILD]} > 1) {

        ;#if ($op->[cTYPE] != opSEQUENCE) {

        ;# Here we need to flatten CHOICEs and check that SET and CHOICE

        ;# do not contain duplicate tags

        ;#}

	if ($op->[cTYPE] == opSET) {

	  ;# In case we do CER encoding we order the SET elements by thier tags

	  my @tags = map { 

	    length($_->[cTAG])

		? $_->[cTAG]

		: $_->[cTYPE] == opCHOICE

			? (sort map { $_->[cTAG] } $_->[cCHILD])[0]

			: ''

	  } @{$op->[cCHILD]};

	  @{$op->[cCHILD]} = @{$op->[cCHILD]}[sort { $tags[$a] cmp $tags[$b] } 0..$#tags];

	}

      }

      else {

	;# A SET of one element can be treated the same as a SEQUENCE

	$op->[cTYPE] = opSEQUENCE if $op->[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 = "";

  ;# 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 = "";

    my $idx = 0;

    while($ops) {

      if ($idx < @$ops) {

	my $op = $ops->[$idx++];

	my $var;

	if (defined ($var = $op->[cVAR])) {

	  $err .= "$name: $path.$var used multiple times\n"

	    if $stash->{$var}++;

	}

	if (defined $op->[cCHILD]) {

	  if (ref $op->[cCHILD]) {

	    push @scope, [$stash, $path, $ops, $idx];

	    if (defined $var) {

	      $stash = {};

	      $path .= "." . $var;

	    }

	    $idx = 0;

	    $ops = $op->[cCHILD];

	  }

	  elsif ($op->[cTYPE] eq 'COMPONENTS') {

	    splice(@$ops,--$idx,1,expand_ops($tree, $op->[cCHILD]));

	  }

          else {

	    die "Internal error\n";

          }

	}

      }

      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 "COMPONENTS OF loop $want\n" if $seen->{$want}++;

  die "Undefined macro $want\n" unless exists $tree->{$want};

  my $ops = $tree->{$want};

  die "Bad macro for COMPUNENTS OF '$want'\n"

    unless @$ops == 1

        && ($ops->[0][cTYPE] eq 'SEQUENCE' || $ops->[0][cTYPE] eq 'SET')

        && ref $ops->[0][cCHILD];

  $ops = $ops->[0][cCHILD];

  for(my $idx = 0 ; $idx < @$ops ; ) {

    my $op = $ops->[$idx++];

    if ($op->[cTYPE] eq 'COMPONENTS') {

      splice(@$ops,--$idx,1,expand_ops($tree, $op->[cCHILD], $seen));

    }

  }

  @$ops;

}

sub _yylex {

  my $ret = &_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) {

      my $ret = $+;

      # A comma is not required after a '}' so to aid the

      # parser we insert a fake token after any '}'

      if ($ret eq '}') {

        my $p   = pos($asn);

        my @tmp = @stacked;

        @stacked = ();

        pos($asn) = $p if yylex() != $COMMA;    # swallow it

        @stacked = (@tmp, $POSTRBRACE);

      }

      return $reserved{$yylval = $ret};

    }

    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;

    }

    if (defined $8) {

      return $EXTENSION_MARKER;

    }

    die "Internal error\n";

  }

  die "Parse error before ",substr($asn,$pos,40),"\n"

    unless $pos == length($asn);

  0

}

sub yyerror {

  die @_," ",substr($asn,$last_pos,40),"\n";

}

1;