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