diff options
Diffstat (limited to 'lib/dialyzer/test/r9c_SUITE_data/src/asn1')
33 files changed, 37504 insertions, 0 deletions
diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/Makefile b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/Makefile new file mode 100644 index 0000000000..9dba643327 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/Makefile @@ -0,0 +1,142 @@ +# +# Copyright (C) 1997, Ericsson Telecommunications +# Author: Kenneth Lundin +# +include $(ERL_TOP)/make/target.mk +include $(ERL_TOP)/make/$(TARGET)/otp.mk + +# ---------------------------------------------------- +# Application version +# ---------------------------------------------------- +include ../vsn.mk +VSN=$(ASN1_VSN) + +# ---------------------------------------------------- +# Release directory specification +# ---------------------------------------------------- +RELSYSDIR = $(RELEASE_PATH)/lib/asn1-$(VSN) + + + + +# +# Common Macros +# +# PARSER_SRC = \ +# asn1ct_parser.yrl + +# PARSER_MODULE=$(PARSER_SRC:%.yrl=%) + +EBIN = ../ebin +CT_MODULES= \ + asn1ct \ + asn1ct_check \ + asn1_db \ + asn1ct_pretty_format \ + asn1ct_gen \ + asn1ct_gen_per \ + asn1ct_gen_per_rt2ct \ + asn1ct_name \ + asn1ct_constructed_per \ + asn1ct_constructed_ber \ + asn1ct_gen_ber \ + asn1ct_constructed_ber_bin_v2 \ + asn1ct_gen_ber_bin_v2 \ + asn1ct_value \ + asn1ct_tok \ + asn1ct_parser2 + +RT_MODULES= \ + asn1rt \ + asn1rt_per \ + asn1rt_per_bin \ + asn1rt_per_v1 \ + asn1rt_ber_bin \ + asn1rt_ber_bin_v2 \ + asn1rt_per_bin_rt2ct \ + asn1rt_driver_handler \ + asn1rt_check + +# asn1rt_ber_v1 \ +# asn1rt_ber \ +# the rt module to use is defined in asn1_records.hrl +# and must be updated when an incompatible change is done in the rt modules + + +MODULES= $(CT_MODULES) $(RT_MODULES) + +ERL_FILES = $(MODULES:%=%.erl) + +TARGET_FILES = $(MODULES:%=$(EBIN)/%.$(EMULATOR)) + +GENERATED_PARSER = $(PARSER_MODULE:%=%.erl) + +# internal hrl file +HRL_FILES = asn1_records.hrl + +APP_FILE = asn1.app +APPUP_FILE = asn1.appup + +APP_SRC = $(APP_FILE).src +APP_TARGET = $(EBIN)/$(APP_FILE) + +APPUP_SRC = $(APPUP_FILE).src +APPUP_TARGET = $(EBIN)/$(APPUP_FILE) + +EXAMPLES = \ + ../examples/P-Record.asn + +# ---------------------------------------------------- +# FLAGS +# ---------------------------------------------------- +ERL_FLAGS += +ERL_COMPILE_FLAGS += \ + -I$(ERL_TOP)/lib/stdlib \ + +warn_unused_vars +YRL_FLAGS = +# ---------------------------------------------------- +# Targets +# ---------------------------------------------------- + +debug opt: $(TARGET_FILES) $(APP_TARGET) $(APPUP_TARGET) + + +clean: + rm -f $(TARGET_FILES) $(APP_TARGET) $(APPUP_TARGET) $(GENERATED_PARSER) + rm -f core *~ + +docs: + + +# ---------------------------------------------------- +# Special Build Targets +# ---------------------------------------------------- + +$(EBIN)/asn1ct.$(EMULATOR):asn1ct.erl + $(ERLC) -b$(EMULATOR) -o$(EBIN) $(ERL_COMPILE_FLAGS) -Dvsn=\"$(VSN)\" $< + +$(APP_TARGET): $(APP_SRC) ../vsn.mk + sed -e 's;%VSN%;$(VSN);' $< > $@ + +$(APPUP_TARGET): $(APPUP_SRC) ../vsn.mk + sed -e 's;%VSN%;$(VSN);' $< > $@ + + +# ---------------------------------------------------- +# Release Target +# ---------------------------------------------------- +include $(ERL_TOP)/make/otp_release_targets.mk + +release_spec: opt + $(INSTALL_DIR) $(RELSYSDIR)/ebin + $(INSTALL_DATA) $(TARGET_FILES) $(APP_TARGET) $(APPUP_TARGET) $(RELSYSDIR)/ebin + $(INSTALL_DIR) $(RELSYSDIR)/src + $(INSTALL_DATA) $(PARSER_SRC) $(ERL_FILES) $(HRL_FILES) $(APP_SRC) $(APPUP_SRC) $(RELSYSDIR)/src + $(INSTALL_DIR) $(RELSYSDIR)/examples + $(INSTALL_DATA) $(EXAMPLES) $(RELSYSDIR)/examples + +# there are no include files to be used by the user +#$(INSTALL_DIR) $(RELSYSDIR)/include +#$(INSTALL_DATA) $(HRL_FILES) $(RELSYSDIR)/include + +release_docs_spec: diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/Restrictions.txt b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/Restrictions.txt new file mode 100644 index 0000000000..d1d1855dc9 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/Restrictions.txt @@ -0,0 +1,55 @@ +The following restrictions apply to this implementation of the ASN.1 compiler: + +Supported encoding rules are: +BER +PER (aligned) + +PER (unaligned) IS NOT SUPPORTED + +Supported types are: + +INTEGER +BOOLEAN +ENUMERATION +SEQUENCE +SEQUENCE OF +SET +SET OF +CHOICE +OBJECT IDENTIFIER +RestrictedCharacterStringTypes +UnrestrictedCharacterStringTypes + + +NOT SUPPORTED types are: +ANY IS (IS NOT IN THE STANDARD ANY MORE) +ANY DEFINED BY (IS NOT IN THE STANDARD ANY MORE) +EXTERNAL +EMBEDDED-PDV +REAL + +The support for value definitions in the ASN.1 notation is very limited. + +The support for constraints is limited to: +SizeConstraint SIZE(X) +SingleValue (1) +ValueRange (X..Y) +PermittedAlpabet FROM + +The only supported value-notation for SEQUENCE and SET in Erlang is +the record variant. +The list notation with named components used by the old ASN.1 compiler +was supported in the first versions of this compiler both are no longer +supported. + +The decode functions always return a symbolic value if they can. + + +Files with ASN.1 source must have a suffix .asn1 the suffix .py used by the +old ASN.1 compiler is supported in this version but will not be supported in the future. + +Generated files: +X.asn1db % the intermediate format of a compiled ASN.1 module +X.hrl % generated Erlang include file for module X +X.erl % generated Erlang module with encode decode functions for + % ASN.1 module X diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1.app.src b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1.app.src new file mode 100644 index 0000000000..2ec06ff4db --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1.app.src @@ -0,0 +1,20 @@ +{application, asn1, + [{description, "The Erlang ASN1 compiler version %VSN%"}, + {vsn, "%VSN%"}, + {modules, [ + asn1rt, + asn1rt_per, + asn1rt_per_v1, + asn1rt_per_bin, + asn1rt_per_bin_rt2ct, + asn1rt_ber_bin, + asn1rt_ber_bin_v2, + asn1rt_check, + asn1rt_driver_handler + ]}, + {registered, [ + asn1_driver_owner + ]}, + {env, []}, + {applications, [kernel, stdlib]} + ]}. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1.appup.src b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1.appup.src new file mode 100644 index 0000000000..55ef53994a --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1.appup.src @@ -0,0 +1,162 @@ +{"%VSN%", + [ + {"1.3", + [ + {load_module, asn1rt_per_v1, soft_purge, soft_purge, []}, + {load_module, asn1rt_ber_bin, soft_purge, soft_purge, []}, + {load_module, asn1rt, soft_purge, soft_purge, []}, + {add_module, asn1rt_per_bin}, + {add_module, asn1rt_check} + {add_module, asn1rt_per_bin_rt2ct}, + {add_module, asn1rt_ber_bin_v2}, + {add_module, asn1rt_driver_handler} + {remove, {asn1rt_ber_v1, soft_purge, soft_purge}}, + ] + }, + {"1.3.1", + [ + {load_module, asn1rt_per_v1, soft_purge, soft_purge, []}, + {load_module, asn1rt_ber_bin, soft_purge, soft_purge, []}, + {load_module, asn1rt, soft_purge, soft_purge, []}, + {add_module, asn1rt_per_bin}, + {add_module, asn1rt_check} + {add_module, asn1rt_per_bin_rt2ct}, + {add_module, asn1rt_ber_bin_v2}, + {add_module, asn1rt_driver_handler} + {remove, {asn1rt_ber_v1, soft_purge, soft_purge}}, + ] + }, + {"1.3.1.1", + [ + {load_module, asn1rt_per_v1, soft_purge, soft_purge, []}, + {load_module, asn1rt_ber_bin, soft_purge, soft_purge, []}, + {load_module, asn1rt, soft_purge, soft_purge, []}, + {add_module, asn1rt_per_bin}, + {add_module, asn1rt_check} + {add_module, asn1rt_per_bin_rt2ct}, + {add_module, asn1rt_ber_bin_v2}, + {add_module, asn1rt_driver_handler} + {remove, {asn1rt_ber_v1, soft_purge, soft_purge}}, + ] + }, + {"1.3.2", + [ + {load_module, asn1rt_per_v1, soft_purge, soft_purge, []}, + {load_module, asn1rt_ber_bin, soft_purge, soft_purge, []}, + {load_module, asn1rt, soft_purge, soft_purge, []}, + {load_module, asn1rt_per_bin, soft_purge, soft_purge, []}, + {load_module, asn1rt_check, soft_purge, soft_purge, []}, + {add_module, asn1rt_per_bin_rt2ct}, + {add_module, asn1rt_ber_bin_v2}, + {add_module, asn1rt_driver_handler} + {remove, {asn1rt_ber_v1, soft_purge, soft_purge}}, + ] + }, + {"1.3.3", + [ + {load_module, asn1rt_per_v1, soft_purge, soft_purge, []}, + {load_module, asn1rt_ber_bin, soft_purge, soft_purge, []}, + {load_module, asn1rt, soft_purge, soft_purge, []}, + {load_module, asn1rt_per_bin, soft_purge, soft_purge, []}, + {load_module, asn1rt_check, soft_purge, soft_purge, []}, + {load_module, asn1rt_per_bin_rt2ct, soft_purge, soft_purge, []}, + {add_module, asn1rt_ber_bin_v2}, + {add_module, asn1rt_driver_handler} + {remove, {asn1rt_ber_v1, soft_purge, soft_purge}}, + ] + }, + {"1.3.3.1", + [ + {load_module, asn1rt_per_v1, soft_purge, soft_purge, []}, + {load_module, asn1rt_ber_bin, soft_purge, soft_purge, []}, + {load_module, asn1rt, soft_purge, soft_purge, []}, + {load_module, asn1rt_per_bin, soft_purge, soft_purge, []}, + {load_module, asn1rt_check, soft_purge, soft_purge, []}, + {load_module, asn1rt_per_bin_rt2ct, soft_purge, soft_purge, []}, + {add_module, asn1rt_ber_bin_v2}, + {add_module, asn1rt_driver_handler} + {remove, {asn1rt_ber_v1, soft_purge, soft_purge}}, + ] + } + ], + [ + {"1.3", + [ + {load_module, asn1rt_per_v1, soft_purge, soft_purge, []}, + {load_module, asn1rt_ber_bin, soft_purge, soft_purge, []}, + {load_module, asn1rt, soft_purge, soft_purge, []}, + {add_module, asn1rt_ber_v1}, + {remove, {asn1rt_per_bin, soft_purge, soft_purge}}, + {remove, {asn1rt_check, soft_purge, soft_purge}} + {remove, {asn1rt_per_bin_rt2ct, soft_purge, soft_purge}}, + {remove, {asn1rt_ber_bin_v2, soft_purge, soft_purge}}, + {remove, {asn1rt_driver_handler, soft_purge, soft_purge}} + ] + }, + {"1.3.1", + [ + {load_module, asn1rt_per_v1, soft_purge, soft_purge, []}, + {load_module, asn1rt_ber_bin, soft_purge, soft_purge, []}, + {load_module, asn1rt, soft_purge, soft_purge, []}, + {add_module, asn1rt_ber_v1}, + {remove, {asn1rt_per_bin, soft_purge, soft_purge}}, + {remove, {asn1rt_check, soft_purge, soft_purge}} + {remove, {asn1rt_per_bin_rt2ct, soft_purge, soft_purge}}, + {remove, {asn1rt_ber_bin_v2, soft_purge, soft_purge}}, + {remove, {asn1rt_driver_handler, soft_purge, soft_purge}} + ] + }, + {"1.3.1.1", + [ + {load_module, asn1rt_per_v1, soft_purge, soft_purge, []}, + {load_module, asn1rt_ber_bin, soft_purge, soft_purge, []}, + {load_module, asn1rt, soft_purge, soft_purge, []}, + {add_module, asn1rt_ber_v1}, + {remove, {asn1rt_per_bin, soft_purge, soft_purge}}, + {remove, {asn1rt_check, soft_purge, soft_purge}} + {remove, {asn1rt_per_bin_rt2ct, soft_purge, soft_purge}}, + {remove, {asn1rt_ber_bin_v2, soft_purge, soft_purge}}, + {remove, {asn1rt_driver_handler, soft_purge, soft_purge}} + ] + }, + {"1.3.2", + [ + {load_module, asn1rt_per_v1, soft_purge, soft_purge, []}, + {load_module, asn1rt_ber_bin, soft_purge, soft_purge, []}, + {load_module, asn1rt, soft_purge, soft_purge, []}, + {load_module, asn1rt_per_bin, soft_purge, soft_purge, []}, + {load_module, asn1rt_check, soft_purge, soft_purge, []}, + {add_module, asn1rt_ber_v1}, + {remove, {asn1rt_per_bin_rt2ct, soft_purge, soft_purge}}, + {remove, {asn1rt_ber_bin_v2, soft_purge, soft_purge}}, + {remove, {asn1rt_driver_handler, soft_purge, soft_purge}} + ] + }, + {"1.3.3", + [ + {load_module, asn1rt_per_v1, soft_purge, soft_purge, []}, + {load_module, asn1rt_ber_bin, soft_purge, soft_purge, []}, + {load_module, asn1rt, soft_purge, soft_purge, []}, + {load_module, asn1rt_per_bin, soft_purge, soft_purge, []}, + {load_module, asn1rt_check, soft_purge, soft_purge, []}, + {load_module, asn1rt_per_bin_rt2ct, soft_purge, soft_purge, []}, + {add_module, asn1rt_ber_v1}, + {remove, {asn1rt_ber_bin_v2, soft_purge, soft_purge}}, + {remove, {asn1rt_driver_handler, soft_purge, soft_purge}} + ] + }, + {"1.3.3.1", + [ + {load_module, asn1rt_per_v1, soft_purge, soft_purge, []}, + {load_module, asn1rt_ber_bin, soft_purge, soft_purge, []}, + {load_module, asn1rt, soft_purge, soft_purge, []}, + {load_module, asn1rt_per_bin, soft_purge, soft_purge, []}, + {load_module, asn1rt_check, soft_purge, soft_purge, []}, + {load_module, asn1rt_per_bin_rt2ct, soft_purge, soft_purge, []}, + {add_module, asn1rt_ber_v1}, + {remove, {asn1rt_ber_bin_v2, soft_purge, soft_purge}}, + {remove, {asn1rt_driver_handler, soft_purge, soft_purge}} + ] + } + + ]}. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1_db.erl b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1_db.erl new file mode 100644 index 0000000000..d5ddb9582b --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1_db.erl @@ -0,0 +1,160 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: asn1_db.erl,v 1.1 2008/12/17 09:53:29 mikpe Exp $ +%% +-module(asn1_db). +%-compile(export_all). +-export([dbnew/1,dbsave/2,dbload/1,dbput/3,dbget/2,dbget_all/1]). +-export([dbget_all_mod/1,dbstop/0,dbclear/0,dberase_module/1,dbstart/1,stop_server/1]). +%% internal exports +-export([dbloop0/1,dbloop/2]). + +%% Db stuff +dbstart(Includes) -> + start_server(asn1db, asn1_db, dbloop0, [Includes]). + +dbloop0(Includes) -> + dbloop(Includes, ets:new(asn1, [set,named_table])). + +opentab(Tab,Mod,[]) -> + opentab(Tab,Mod,["."]); +opentab(Tab,Mod,Includes) -> + Base = lists:concat([Mod,".asn1db"]), + opentab2(Tab,Base,Mod,Includes,ok). + +opentab2(_Tab,_Base,_Mod,[],Error) -> + Error; +opentab2(Tab,Base,Mod,[Ih|It],_Error) -> + File = filename:join(Ih,Base), + case ets:file2tab(File) of + {ok,Modtab} -> + ets:insert(Tab,{Mod, Modtab}), + {ok,Modtab}; + NewErr -> + opentab2(Tab,Base,Mod,It,NewErr) + end. + + +dbloop(Includes, Tab) -> + receive + {From,{set, Mod, K2, V}} -> + [{_,Modtab}] = ets:lookup(Tab,Mod), + ets:insert(Modtab,{K2, V}), + From ! {asn1db, ok}, + dbloop(Includes, Tab); + {From, {get, Mod, K2}} -> + Result = case ets:lookup(Tab,Mod) of + [] -> + opentab(Tab,Mod,Includes); + [{_,Modtab}] -> {ok,Modtab} + end, + case Result of + {ok,Newtab} -> + From ! {asn1db, lookup(Newtab, K2)}; + _Error -> + From ! {asn1db, undefined} + end, + dbloop(Includes, Tab); + {From, {all_mod, Mod}} -> + [{_,Modtab}] = ets:lookup(Tab,Mod), + From ! {asn1db, ets:tab2list(Modtab)}, + dbloop(Includes, Tab); + {From, {delete_mod, Mod}} -> + [{_,Modtab}] = ets:lookup(Tab,Mod), + ets:delete(Modtab), + ets:delete(Tab,Mod), + From ! {asn1db, ok}, + dbloop(Includes, Tab); + {From, {save, OutFile,Mod}} -> + [{_,Mtab}] = ets:lookup(Tab,Mod), + {From ! {asn1db, ets:tab2file(Mtab,OutFile)}}, + dbloop(Includes,Tab); + {From, {load, Mod}} -> + Result = case ets:lookup(Tab,Mod) of + [] -> + opentab(Tab,Mod,Includes); + [{_,Modtab}] -> {ok,Modtab} + end, + {From, {asn1db,Result}}, + dbloop(Includes,Tab); + {From, {new, Mod}} -> + case ets:lookup(Tab,Mod) of + [{_,Modtab}] -> + ets:delete(Modtab); + _ -> + true + end, + Tabname = list_to_atom(lists:concat(["asn1_",Mod])), + ets:new(Tabname, [set,named_table]), + ets:insert(Tab,{Mod,Tabname}), + From ! {asn1db, ok}, + dbloop(Includes,Tab); + {From, stop} -> + From ! {asn1db, ok}; %% nothing to store + {From, clear} -> + ModTabList = [Mt||{_,Mt} <- ets:tab2list(Tab)], + lists:foreach(fun(T) -> ets:delete(T) end,ModTabList), + ets:delete(Tab), + From ! {asn1db, cleared}, + dbloop(Includes, ets:new(asn1, [set])) + end. + + +%%all(Tab, K) -> +%% pickup(K, ets:match(Tab, {{K, '$1'}, '$2'})). +%%pickup(K, []) -> []; +%%pickup(K, [[V1,V2] |T]) -> +%% [{{K,V1},V2} | pickup(K, T)]. + +lookup(Tab, K) -> + case ets:lookup(Tab, K) of + [] -> undefined; + [{K,V}] -> V + end. + + +dbnew(Module) -> req({new,Module}). +dbsave(OutFile,Module) -> req({save,OutFile,Module}). +dbload(Module) -> req({load,Module}). + +dbput(Module,K,V) -> req({set, Module, K, V}). +dbget(Module,K) -> req({get, Module, K}). +dbget_all(K) -> req({get_all, K}). +dbget_all_mod(Mod) -> req({all_mod,Mod}). +dbstop() -> stop_server(asn1db). +dbclear() -> req(clear). +dberase_module({module,M})-> + req({delete_mod, M}). + +req(R) -> + asn1db ! {self(), R}, + receive {asn1db, Reply} -> Reply end. + +stop_server(Name) -> + stop_server(Name, whereis(Name)). +stop_server(_, undefined) -> stopped; +stop_server(Name, _Pid) -> + Name ! {self(), stop}, + receive {Name, _} -> stopped end. + + +start_server(Name,Mod,Fun,Args) -> + case whereis(Name) of + undefined -> + register(Name, spawn(Mod,Fun, Args)); + _Pid -> + already_started + end. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1_records.hrl b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1_records.hrl new file mode 100644 index 0000000000..6ba4877523 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1_records.hrl @@ -0,0 +1,96 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: asn1_records.hrl,v 1.1 2008/12/17 09:53:29 mikpe Exp $ +%% +-define('RT_BER',"asn1rt_ber_v1"). +-define('RT_BER_BIN',"asn1rt_ber_bin"). +-define('RT_PER',"asn1rt_per_v1"). +%% change to this when we have this module -define('RT_PER_BIN',"asn1rt_per_bin"). +-define('RT_PER_BIN',"asn1rt_per_bin"). + +-record(module,{pos,name,defid,tagdefault='EXPLICIT',exports={exports,[]},imports={imports,[]}, extensiondefault=empty,typeorval}). + +-record('SEQUENCE',{pname=false,tablecinf=false,components=[]}). +-record('SET',{pname=false,sorted=false,tablecinf=false,components=[]}). +-record('ComponentType',{pos,name,typespec,prop,tags}). +-record('ObjectClassFieldType',{classname,class,fieldname,type}). + +-record(typedef,{checked=false,pos,name,typespec}). +-record(classdef,{checked=false,pos,name,typespec}). +-record(valuedef,{checked=false,pos,name,type,value}). +-record(ptypedef,{checked=false,pos,name,args,typespec}). +-record(pvaluedef,{checked=false,pos,name,args,type,value}). +-record(pvaluesetdef,{checked=false,pos,name,args,type,valueset}). +-record(pobjectdef,{checked=false,pos,name,args,class,def}). +-record(pobjectsetdef,{checked=false,pos,name,args,class,def}). + +-record(typereference,{pos,val}). +-record(identifier,{pos,val}). +-record(constraint,{c,e}). +-record('Constraint',{'SingleValue'=no,'SizeConstraint'=no,'ValueRange'=no,'PermittedAlphabet'=no, + 'ContainedSubtype'=no, 'TypeConstraint'=no,'InnerSubtyping'=no,e=no,'Other'=no}). +-record(simpletableattributes,{objectsetname,c_name,c_index,usedclassfield, + uniqueclassfield,valueindex}). +-record(type,{tag=[],def,constraint=[],tablecinf=[],inlined=no}). + +-record(objectclass,{fields=[],syntax}). +-record('Object',{classname,gen=true,def}). +-record('ObjectSet',{class,gen=true,uniquefname,set}). + +-record(tag,{class,number,type,form=32}). % form = ?CONSTRUCTED +% This record holds information about allowed constraint types per type +-record(cmap,{single_value=no,contained_subtype=no,value_range=no, + size=no,permitted_alphabet=no,type_constraint=no, + inner_subtyping=no}). + + +-record('EXTENSIONMARK',{pos,val}). + +% each IMPORT contains a list of 'SymbolsFromModule' +-record('SymbolsFromModule',{symbols,module,objid}). + +% Externaltypereference -> modulename '.' typename +-record('Externaltypereference',{pos,module,type}). +% Externalvaluereference -> modulename '.' typename +-record('Externalvaluereference',{pos,module,value}). + +-record(state,{module,mname,type,tname,value,vname,erule,parameters=[], + inputmodules,abscomppath=[],recordtopname=[],options}). + +%% state record used by backend at partial decode +%% active is set to 'yes' when a partial decode function is generated. +%% prefix is set to 'dec-inc-' or 'dec-partial-' is for +%% incomplete partial decode or partial decode respectively +%% inc_tag_pattern holds the tags of the significant types/components +%% for incomplete partial decode. +%% tag_pattern holds the tags for partial decode. +%% inc_type_pattern and type_pattern holds the names of the +%% significant types/components. +%% func_name holds the name of the function for the toptype. +%% namelist holds the list of names of types/components that still +%% haven't been generated. +%% tobe_refed_funcs is a list of tuples {function names +%% (Types),namelist of incomplete decode spec}, with function names +%% that are referenced within other generated partial incomplete +%% decode functions. They shall be generated as partial incomplete +%% decode functions. + +%% gen_refed_funcs is as list of function names. Unlike +%% tobe_refed_funcs these have been generated. +-record(gen_state,{active=false,prefix,inc_tag_pattern, + tag_pattern,inc_type_pattern, + type_pattern,func_name,namelist, + tobe_refed_funcs=[],gen_refed_funcs=[]}). diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct.erl b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct.erl new file mode 100644 index 0000000000..fd36f1657e --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct.erl @@ -0,0 +1,1904 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: asn1ct.erl,v 1.1 2008/12/17 09:53:29 mikpe Exp $ +%% +-module(asn1ct). + +%% Compile Time functions for ASN.1 (e.g ASN.1 compiler). + +%%-compile(export_all). +%% Public exports +-export([compile/1, compile/2]). +-export([start/0, start/1, stop/0]). +-export([encode/2, encode/3, decode/3]). +-export([test/1, test/2, test/3, value/2]). +%% Application internal exports +-export([compile_asn/3,compile_asn1/3,compile_py/3,compile/3,value/1,vsn/0, + create_ets_table/2,get_name_of_def/1,get_pos_of_def/1]). +-export([read_config_data/1,get_gen_state_field/1,get_gen_state/0, + partial_inc_dec_toptype/1,save_gen_state/1,update_gen_state/2, + get_tobe_refed_func/1,reset_gen_state/0,is_function_generated/1, + generated_refed_func/1,next_refed_func/0,pop_namelist/0, + next_namelist_el/0,update_namelist/1,step_in_constructed/0, + add_tobe_refed_func/1,add_generated_refed_func/1]). + +-include("asn1_records.hrl"). +-include_lib("stdlib/include/erl_compile.hrl"). + +-import(asn1ct_gen_ber_bin_v2,[encode_tag_val/3,decode_class/1]). + +-define(unique_names,0). +-define(dupl_uniquedefs,1). +-define(dupl_equaldefs,2). +-define(dupl_eqdefs_uniquedefs,?dupl_equaldefs bor ?dupl_uniquedefs). + +-define(CONSTRUCTED, 2#00100000). + +%% macros used for partial decode commands +-define(CHOOSEN,choosen). +-define(SKIP,skip). +-define(SKIP_OPTIONAL,skip_optional). + +%% macros used for partial incomplete decode commands +-define(MANDATORY,mandatory). +-define(DEFAULT,default). +-define(OPTIONAL,opt). +-define(PARTS,parts). +-define(UNDECODED,undec). +-define(ALTERNATIVE,alt). +-define(ALTERNATIVE_UNDECODED,alt_undec). +-define(ALTERNATIVE_PARTS,alt_parts). +%-define(BINARY,bin). + +%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% This is the interface to the compiler +%% +%% + + +compile(File) -> + compile(File,[]). + +compile(File,Options) when list(Options) -> + Options1 = + case {lists:member(optimize,Options),lists:member(ber_bin,Options)} of + {true,true} -> + [ber_bin_v2|Options--[ber_bin]]; + _ -> Options + end, + case (catch input_file_type(File)) of + {single_file,PrefixedFile} -> + (catch compile1(PrefixedFile,Options1)); + {multiple_files_file,SetBase,FileName} -> + FileList = get_file_list(FileName), + (catch compile_set(SetBase,filename:dirname(FileName), + FileList,Options1)); + Err = {input_file_error,_Reason} -> + {error,Err} + end. + + +compile1(File,Options) when list(Options) -> + io:format("Erlang ASN.1 version ~p compiling ~p ~n",[?vsn,File]), + io:format("Compiler Options: ~p~n",[Options]), + Ext = filename:extension(File), + Base = filename:basename(File,Ext), + OutFile = outfile(Base,"",Options), + DbFile = outfile(Base,"asn1db",Options), + Includes = [I || {i,I} <- Options], + EncodingRule = get_rule(Options), + create_ets_table(asn1_functab,[named_table]), + Continue1 = scan({true,true},File,Options), + Continue2 = parse(Continue1,File,Options), + Continue3 = check(Continue2,File,OutFile,Includes,EncodingRule, + DbFile,Options,[]), + Continue4 = generate(Continue3,OutFile,EncodingRule,Options), + delete_tables([asn1_functab]), + compile_erl(Continue4,OutFile,Options). + +%%****************************************************************************%% +%% functions dealing with compiling of several input files to one output file %% +%%****************************************************************************%% +compile_set(SetBase,DirName,Files,Options) when list(hd(Files)),list(Options) -> + %% case when there are several input files in a list + io:format("Erlang ASN.1 version ~p compiling ~p ~n",[?vsn,Files]), + io:format("Compiler Options: ~p~n",[Options]), + OutFile = outfile(SetBase,"",Options), + DbFile = outfile(SetBase,"asn1db",Options), + Includes = [I || {i,I} <- Options], + EncodingRule = get_rule(Options), + create_ets_table(asn1_functab,[named_table]), + ScanRes = scan_set(DirName,Files,Options), + ParseRes = parse_set(ScanRes,Options), + Result = + case [X||X <- ParseRes,element(1,X)==true] of + [] -> %% all were false, time to quit + lists:map(fun(X)->element(2,X) end,ParseRes); + ParseRes -> %% all were true, continue with check + InputModules = + lists:map( + fun(F)-> + E = filename:extension(F), + B = filename:basename(F,E), + if + list(B) -> list_to_atom(B); + true -> B + end + end, + Files), + check_set(ParseRes,SetBase,OutFile,Includes, + EncodingRule,DbFile,Options,InputModules); + Other -> + {error,{'unexpected error in scan/parse phase', + lists:map(fun(X)->element(3,X) end,Other)}} + end, + delete_tables([asn1_functab]), + Result. + +check_set(ParseRes,SetBase,OutFile,Includes,EncRule,DbFile, + Options,InputModules) -> + lists:foreach(fun({_T,M,File})-> + cmp(M#module.name,File) + end, + ParseRes), + MergedModule = merge_modules(ParseRes,SetBase), + SetM = MergedModule#module{name=SetBase}, + Continue1 = check({true,SetM},SetBase,OutFile,Includes,EncRule,DbFile, + Options,InputModules), + Continue2 = generate(Continue1,OutFile,EncRule,Options), + + delete_tables([renamed_defs,original_imports,automatic_tags]), + + compile_erl(Continue2,OutFile,Options). + +%% merge_modules/2 -> returns a module record where the typeorval lists are merged, +%% the exports lists are merged, the imports lists are merged when the +%% elements come from other modules than the merge set, the tagdefault +%% field gets the shared value if all modules have same tagging scheme, +%% otherwise a tagging_error exception is thrown, +%% the extensiondefault ...(not handled yet). +merge_modules(ParseRes,CommonName) -> + ModuleList = lists:map(fun(X)->element(2,X) end,ParseRes), + NewModuleList = remove_name_collisions(ModuleList), + case ets:info(renamed_defs,size) of + 0 -> ets:delete(renamed_defs); + _ -> ok + end, + save_imports(NewModuleList), +% io:format("~p~n~p~n~p~n~n",[ets:lookup(original_imports,'M1'),ets:lookup(original_imports,'M2'),ets:tab2list(original_imports)]), + TypeOrVal = lists:append(lists:map(fun(X)->X#module.typeorval end, + NewModuleList)), + InputMNameList = lists:map(fun(X)->X#module.name end, + NewModuleList), + CExports = common_exports(NewModuleList), + + ImportsModuleNameList = lists:map(fun(X)-> + {X#module.imports, + X#module.name} end, + NewModuleList), + %% ImportsModuleNameList: [{Imports,ModuleName},...] + %% Imports is a tuple {imports,[#'SymbolsFromModule'{},...]} + CImports = common_imports(ImportsModuleNameList,InputMNameList), + TagDefault = check_tagdefault(NewModuleList), + #module{name=CommonName,tagdefault=TagDefault,exports=CExports, + imports=CImports,typeorval=TypeOrVal}. + +%% causes an exit if duplicate definition names exist in a module +remove_name_collisions(Modules) -> + create_ets_table(renamed_defs,[named_table]), + %% Name duplicates in the same module is not allowed. + lists:foreach(fun exit_if_nameduplicate/1,Modules), + %% Then remove duplicates in different modules and return the + %% new list of modules. + remove_name_collisions2(Modules,[]). + +%% For each definition in the first module in module list, find +%% all definitons with same name and rename both definitions in +%% the first module and in rest of modules +remove_name_collisions2([M|Ms],Acc) -> + TypeOrVal = M#module.typeorval, + MName = M#module.name, + %% Test each name in TypeOrVal on all modules in Ms + {NewM,NewMs} = remove_name_collisions2(MName,TypeOrVal,Ms,[]), + remove_name_collisions2(NewMs,[M#module{typeorval=NewM}|Acc]); +remove_name_collisions2([],Acc) -> + finished_warn_prints(), + Acc. + +%% For each definition in list of defs find definitions in (rest of) +%% modules that have same name. If duplicate was found rename def. +%% Test each name in [T|Ts] on all modules in Ms +remove_name_collisions2(ModName,[T|Ts],Ms,Acc) -> + Name = get_name_of_def(T), + case discover_dupl_in_mods(Name,T,Ms,[],?unique_names) of + {_,?unique_names} -> % there was no name collision + remove_name_collisions2(ModName,Ts,Ms,[T|Acc]); + {NewMs,?dupl_uniquedefs} -> % renamed defs in NewMs + %% rename T + NewT = set_name_of_def(ModName,Name,T), %rename def + warn_renamed_def(ModName,get_name_of_def(NewT),Name), + ets:insert(renamed_defs,{get_name_of_def(NewT),Name,ModName}), + remove_name_collisions2(ModName,Ts,NewMs,[NewT|Acc]); + {NewMs,?dupl_equaldefs} -> % name duplicates, but identical defs + %% keep name of T + warn_kept_def(ModName,Name), + remove_name_collisions2(ModName,Ts,NewMs,[T|Acc]); + {NewMs,?dupl_eqdefs_uniquedefs} -> + %% keep name of T, renamed defs in NewMs + warn_kept_def(ModName,Name), + remove_name_collisions2(ModName,Ts,NewMs,[T|Acc]) + end; +remove_name_collisions2(_,[],Ms,Acc) -> + {Acc,Ms}. + +%% Name is the name of a definition. If a definition with the same name +%% is found in the modules Ms the definition will be renamed and returned. +discover_dupl_in_mods(Name,Def,[M=#module{name=N,typeorval=TorV}|Ms], + Acc,AnyRenamed) -> + Fun = fun(T,RenamedOrDupl)-> + case {get_name_of_def(T),compare_defs(Def,T)} of + {Name,not_equal} -> + %% rename def + NewT=set_name_of_def(N,Name,T), + warn_renamed_def(N,get_name_of_def(NewT),Name), + ets:insert(renamed_defs,{get_name_of_def(NewT), + Name,N}), + {NewT,?dupl_uniquedefs bor RenamedOrDupl}; + {Name,equal} -> + %% delete def + warn_deleted_def(N,Name), + {[],?dupl_equaldefs bor RenamedOrDupl}; + _ -> + {T,RenamedOrDupl} + end + end, + {NewTorV,NewAnyRenamed} = lists:mapfoldl(Fun,AnyRenamed,TorV), + %% have to flatten the NewTorV to remove any empty list elements + discover_dupl_in_mods(Name,Def,Ms, + [M#module{typeorval=lists:flatten(NewTorV)}|Acc], + NewAnyRenamed); +discover_dupl_in_mods(_,_,[],Acc,AnyRenamed) -> + {Acc,AnyRenamed}. + +warn_renamed_def(ModName,NewName,OldName) -> + maybe_first_warn_print(), + io:format("NOTICE: The ASN.1 definition in module ~p with name ~p has been renamed in generated module. New name is ~p.~n",[ModName,OldName,NewName]). + +warn_deleted_def(ModName,DefName) -> + maybe_first_warn_print(), + io:format("NOTICE: The ASN.1 definition in module ~p with name ~p has been deleted in generated module.~n",[ModName,DefName]). + +warn_kept_def(ModName,DefName) -> + maybe_first_warn_print(), + io:format("NOTICE: The ASN.1 definition in module ~p with name ~p has kept its name due to equal definition as duplicate.~n",[ModName,DefName]). + +maybe_first_warn_print() -> + case get(warn_duplicate_defs) of + undefined -> + put(warn_duplicate_defs,true), + io:format("~nDue to multiple occurrences of a definition name in " + "multi-file compiled files:~n"); + _ -> + ok + end. +finished_warn_prints() -> + put(warn_duplicate_defs,undefined). + + +exit_if_nameduplicate(#module{typeorval=TorV}) -> + exit_if_nameduplicate(TorV); +exit_if_nameduplicate([]) -> + ok; +exit_if_nameduplicate([Def|Rest]) -> + Name=get_name_of_def(Def), + exit_if_nameduplicate2(Name,Rest), + exit_if_nameduplicate(Rest). + +exit_if_nameduplicate2(Name,Rest) -> + Pred=fun(Def)-> + case get_name_of_def(Def) of + Name -> true; + _ -> false + end + end, + case lists:any(Pred,Rest) of + true -> + throw({error,{"more than one definition with same name",Name}}); + _ -> + ok + end. + +compare_defs(D1,D2) -> + compare_defs2(unset_pos(D1),unset_pos(D2)). +compare_defs2(D,D) -> + equal; +compare_defs2(_,_) -> + not_equal. + +unset_pos(Def) when record(Def,typedef) -> + Def#typedef{pos=undefined}; +unset_pos(Def) when record(Def,classdef) -> + Def#classdef{pos=undefined}; +unset_pos(Def) when record(Def,valuedef) -> + Def#valuedef{pos=undefined}; +unset_pos(Def) when record(Def,ptypedef) -> + Def#ptypedef{pos=undefined}; +unset_pos(Def) when record(Def,pvaluedef) -> + Def#pvaluedef{pos=undefined}; +unset_pos(Def) when record(Def,pvaluesetdef) -> + Def#pvaluesetdef{pos=undefined}; +unset_pos(Def) when record(Def,pobjectdef) -> + Def#pobjectdef{pos=undefined}; +unset_pos(Def) when record(Def,pobjectsetdef) -> + Def#pobjectsetdef{pos=undefined}. + +get_pos_of_def(#typedef{pos=Pos}) -> + Pos; +get_pos_of_def(#classdef{pos=Pos}) -> + Pos; +get_pos_of_def(#valuedef{pos=Pos}) -> + Pos; +get_pos_of_def(#ptypedef{pos=Pos}) -> + Pos; +get_pos_of_def(#pvaluedef{pos=Pos}) -> + Pos; +get_pos_of_def(#pvaluesetdef{pos=Pos}) -> + Pos; +get_pos_of_def(#pobjectdef{pos=Pos}) -> + Pos; +get_pos_of_def(#pobjectsetdef{pos=Pos}) -> + Pos. + + +get_name_of_def(#typedef{name=Name}) -> + Name; +get_name_of_def(#classdef{name=Name}) -> + Name; +get_name_of_def(#valuedef{name=Name}) -> + Name; +get_name_of_def(#ptypedef{name=Name}) -> + Name; +get_name_of_def(#pvaluedef{name=Name}) -> + Name; +get_name_of_def(#pvaluesetdef{name=Name}) -> + Name; +get_name_of_def(#pobjectdef{name=Name}) -> + Name; +get_name_of_def(#pobjectsetdef{name=Name}) -> + Name. + +set_name_of_def(ModName,Name,OldDef) -> + NewName = list_to_atom(lists:concat([Name,ModName])), + case OldDef of + #typedef{} -> OldDef#typedef{name=NewName}; + #classdef{} -> OldDef#classdef{name=NewName}; + #valuedef{} -> OldDef#valuedef{name=NewName}; + #ptypedef{} -> OldDef#ptypedef{name=NewName}; + #pvaluedef{} -> OldDef#pvaluedef{name=NewName}; + #pvaluesetdef{} -> OldDef#pvaluesetdef{name=NewName}; + #pobjectdef{} -> OldDef#pobjectdef{name=NewName}; + #pobjectsetdef{} -> OldDef#pobjectsetdef{name=NewName} + end. + +save_imports(ModuleList)-> + Fun = fun(M) -> + case M#module.imports of + {_,[]} -> []; + {_,I} -> + {M#module.name,I} + end + end, + ImportsList = lists:map(Fun,ModuleList), + case lists:flatten(ImportsList) of + [] -> + ok; + ImportsList2 -> + create_ets_table(original_imports,[named_table]), + ets:insert(original_imports,ImportsList2) + end. + + +common_exports(ModuleList) -> + %% if all modules exports 'all' then export 'all', + %% otherwise export each typeorval name + case lists:filter(fun(X)-> + element(2,X#module.exports) /= all + end, + ModuleList) of + []-> + {exports,all}; + ModsWithExpList -> + CExports1 = + lists:append(lists:map(fun(X)->element(2,X#module.exports) end, + ModsWithExpList)), + CExports2 = export_all(lists:subtract(ModuleList,ModsWithExpList)), + {exports,CExports1++CExports2} + end. + +export_all([])->[]; +export_all(ModuleList) -> + ExpList = + lists:map( + fun(M)-> + TorVL=M#module.typeorval, + MName = M#module.name, + lists:map( + fun(Def)-> + case Def of + T when record(T,typedef)-> + #'Externaltypereference'{pos=0, + module=MName, + type=T#typedef.name}; + V when record(V,valuedef) -> + #'Externalvaluereference'{pos=0, + module=MName, + value=V#valuedef.name}; + C when record(C,classdef) -> + #'Externaltypereference'{pos=0, + module=MName, + type=C#classdef.name}; + P when record(P,ptypedef) -> + #'Externaltypereference'{pos=0, + module=MName, + type=P#ptypedef.name}; + PV when record(PV,pvaluesetdef) -> + #'Externaltypereference'{pos=0, + module=MName, + type=PV#pvaluesetdef.name}; + PO when record(PO,pobjectdef) -> + #'Externalvaluereference'{pos=0, + module=MName, + value=PO#pobjectdef.name} + end + end, + TorVL) + end, + ModuleList), + lists:append(ExpList). + +%% common_imports/2 +%% IList is a list of tuples, {Imports,MName}, where Imports is the imports of +%% the module with name MName. +%% InputMNameL holds the names of all merged modules. +%% Returns an import tuple with a list of imports that are external the merged +%% set of modules. +common_imports(IList,InputMNameL) -> + SetExternalImportsList = remove_in_set_imports(IList,InputMNameL,[]), + {imports,remove_import_doubles(SetExternalImportsList)}. + +check_tagdefault(ModList) -> + case have_same_tagdefault(ModList) of + {true,TagDefault} -> TagDefault; + {false,TagDefault} -> + create_ets_table(automatic_tags,[named_table]), + save_automatic_tagged_types(ModList), + TagDefault + end. + +have_same_tagdefault([#module{tagdefault=T}|Ms]) -> + have_same_tagdefault(Ms,{true,T}). + +have_same_tagdefault([],TagDefault) -> + TagDefault; +have_same_tagdefault([#module{tagdefault=T}|Ms],TDefault={_,T}) -> + have_same_tagdefault(Ms,TDefault); +have_same_tagdefault([#module{tagdefault=T1}|Ms],{_,T2}) -> + have_same_tagdefault(Ms,{false,rank_tagdef([T1,T2])}). + +rank_tagdef(L) -> + case lists:member('EXPLICIT',L) of + true -> 'EXPLICIT'; + _ -> 'IMPLICIT' + end. + +save_automatic_tagged_types([])-> + done; +save_automatic_tagged_types([#module{tagdefault='AUTOMATIC', + typeorval=TorV}|Ms]) -> + Fun = + fun(T) -> + ets:insert(automatic_tags,{get_name_of_def(T)}) + end, + lists:foreach(Fun,TorV), + save_automatic_tagged_types(Ms); +save_automatic_tagged_types([_M|Ms]) -> + save_automatic_tagged_types(Ms). + +%% remove_in_set_imports/3 : +%% input: list with tuples of each module's imports and module name +%% respectively. +%% output: one list with same format but each occured import from a +%% module in the input set (IMNameL) is removed. +remove_in_set_imports([{{imports,ImpL},_ModName}|Rest],InputMNameL,Acc) -> + NewImpL = remove_in_set_imports1(ImpL,InputMNameL,[]), + remove_in_set_imports(Rest,InputMNameL,NewImpL++Acc); +remove_in_set_imports([],_,Acc) -> + lists:reverse(Acc). + +remove_in_set_imports1([I|Is],InputMNameL,Acc) -> + case I#'SymbolsFromModule'.module of + #'Externaltypereference'{type=MName} -> + case lists:member(MName,InputMNameL) of + true -> + remove_in_set_imports1(Is,InputMNameL,Acc); + false -> + remove_in_set_imports1(Is,InputMNameL,[I|Acc]) + end; + _ -> + remove_in_set_imports1(Is,InputMNameL,[I|Acc]) + end; +remove_in_set_imports1([],_,Acc) -> + lists:reverse(Acc). + +remove_import_doubles([]) -> + []; +%% If several modules in the merge set imports symbols from +%% the same external module it might be doubled. +%% ImportList has #'SymbolsFromModule' elements +remove_import_doubles(ImportList) -> + MergedImportList = + merge_symbols_from_module(ImportList,[]), +%% io:format("MergedImportList: ~p~n",[MergedImportList]), + delete_double_of_symbol(MergedImportList,[]). + +merge_symbols_from_module([Imp|Imps],Acc) -> + #'Externaltypereference'{type=ModName} = Imp#'SymbolsFromModule'.module, + IfromModName = + lists:filter( + fun(I)-> + case I#'SymbolsFromModule'.module of + #'Externaltypereference'{type=ModName} -> + true; + #'Externalvaluereference'{value=ModName} -> + true; + _ -> false + end + end, + Imps), + NewImps = lists:subtract(Imps,IfromModName), +%% io:format("Imp: ~p~nIfromModName: ~p~n",[Imp,IfromModName]), + NewImp = + Imp#'SymbolsFromModule'{ + symbols = lists:append( + lists:map(fun(SL)-> + SL#'SymbolsFromModule'.symbols + end,[Imp|IfromModName]))}, + merge_symbols_from_module(NewImps,[NewImp|Acc]); +merge_symbols_from_module([],Acc) -> + lists:reverse(Acc). + +delete_double_of_symbol([I|Is],Acc) -> + SymL=I#'SymbolsFromModule'.symbols, + NewSymL = delete_double_of_symbol1(SymL,[]), + delete_double_of_symbol(Is,[I#'SymbolsFromModule'{symbols=NewSymL}|Acc]); +delete_double_of_symbol([],Acc) -> + Acc. + +delete_double_of_symbol1([TRef=#'Externaltypereference'{type=TrefName}|Rest],Acc)-> + NewRest = + lists:filter(fun(S)-> + case S of + #'Externaltypereference'{type=TrefName}-> + false; + _ -> true + end + end, + Rest), + delete_double_of_symbol1(NewRest,[TRef|Acc]); +delete_double_of_symbol1([VRef=#'Externalvaluereference'{value=VName}|Rest],Acc) -> + NewRest = + lists:filter(fun(S)-> + case S of + #'Externalvaluereference'{value=VName}-> + false; + _ -> true + end + end, + Rest), + delete_double_of_symbol1(NewRest,[VRef|Acc]); +delete_double_of_symbol1([TRef={#'Externaltypereference'{type=MRef}, + #'Externaltypereference'{type=TRef}}|Rest], + Acc)-> + NewRest = + lists:filter( + fun(S)-> + case S of + {#'Externaltypereference'{type=MRef}, + #'Externaltypereference'{type=TRef}}-> + false; + _ -> true + end + end, + Rest), + delete_double_of_symbol1(NewRest,[TRef|Acc]); +delete_double_of_symbol1([],Acc) -> + Acc. + + +scan_set(DirName,Files,Options) -> + lists:map( + fun(F)-> + case scan({true,true},filename:join([DirName,F]),Options) of + {false,{error,Reason}} -> + throw({error,{'scan error in file:',F,Reason}}); + {TrueOrFalse,Res} -> + {TrueOrFalse,Res,F} + end + end, + Files). + +parse_set(ScanRes,Options) -> + lists:map( + fun({TorF,Toks,F})-> + case parse({TorF,Toks},F,Options) of + {false,{error,Reason}} -> + throw({error,{'parse error in file:',F,Reason}}); + {TrueOrFalse,Res} -> + {TrueOrFalse,Res,F} + end + end, + ScanRes). + + +%%*********************************** + + +scan({true,_}, File,Options) -> + case asn1ct_tok:file(File) of + {error,Reason} -> + io:format("~p~n",[Reason]), + {false,{error,Reason}}; + Tokens -> + case lists:member(ss,Options) of + true -> % we terminate after scan + {false,Tokens}; + false -> % continue with next pass + {true,Tokens} + end + end; +scan({false,Result},_,_) -> + Result. + + +parse({true,Tokens},File,Options) -> + %Presult = asn1ct_parser2:parse(Tokens), + %%case lists:member(p1,Options) of + %% true -> + %% asn1ct_parser:parse(Tokens); + %% _ -> + %% asn1ct_parser2:parse(Tokens) + %% end, + case catch asn1ct_parser2:parse(Tokens) of + {error,{{Line,_Mod,Message},_TokTup}} -> + if + integer(Line) -> + BaseName = filename:basename(File), + io:format("syntax error at line ~p in module ~s:~n", + [Line,BaseName]); + true -> + io:format("syntax error in module ~p:~n",[File]) + end, + print_error_message(Message), + {false,{error,Message}}; + {error,{Line,_Mod,[Message,Token]}} -> + io:format("syntax error: ~p ~p at line ~p~n", + [Message,Token,Line]), + {false,{error,{Line,[Message,Token]}}}; + {ok,M} -> + case lists:member(sp,Options) of + true -> % terminate after parse + {false,M}; + false -> % continue with next pass + {true,M} + end; + OtherError -> + io:format("~p~n",[OtherError]) + end; +parse({false,Tokens},_,_) -> + {false,Tokens}. + +check({true,M},File,OutFile,Includes,EncodingRule,DbFile,Options,InputMods) -> + cmp(M#module.name,File), + start(["."|Includes]), + case asn1ct_check:storeindb(M) of + ok -> + Module = asn1_db:dbget(M#module.name,'MODULE'), + State = #state{mname=Module#module.name, + module=Module#module{typeorval=[]}, + erule=EncodingRule, + inputmodules=InputMods, + options=Options}, + Check = asn1ct_check:check(State,Module#module.typeorval), + case {Check,lists:member(abs,Options)} of + {{error,Reason},_} -> + {false,{error,Reason}}; + {{ok,NewTypeOrVal,_},true} -> + NewM = Module#module{typeorval=NewTypeOrVal}, + asn1_db:dbput(NewM#module.name,'MODULE',NewM), + pretty2(M#module.name,lists:concat([OutFile,".abs"])), + {false,ok}; + {{ok,NewTypeOrVal,GenTypeOrVal},_} -> + NewM = Module#module{typeorval=NewTypeOrVal}, + asn1_db:dbput(NewM#module.name,'MODULE',NewM), + asn1_db:dbsave(DbFile,M#module.name), + io:format("--~p--~n",[{generated,DbFile}]), + {true,{M,NewM,GenTypeOrVal}} + end + end; +check({false,M},_,_,_,_,_,_,_) -> + {false,M}. + +generate({true,{M,_Module,GenTOrV}},OutFile,EncodingRule,Options) -> + debug_on(Options), + case lists:member(compact_bit_string,Options) of + true -> put(compact_bit_string,true); + _ -> ok + end, + put(encoding_options,Options), + create_ets_table(check_functions,[named_table]), + + %% create decoding function names and taglists for partial decode + %% For the time being leave errors unnoticed !!!!!!!!! +% io:format("Options: ~p~n",[Options]), + case catch specialized_decode_prepare(EncodingRule,M,GenTOrV,Options) of + {error, enoent} -> ok; + {error, Reason} -> io:format("WARNING: Error in configuration" + "file: ~n~p~n",[Reason]); + {'EXIT',Reason} -> io:format("WARNING: Internal error when " + "analyzing configuration" + "file: ~n~p~n",[Reason]); + _ -> ok + end, + + asn1ct_gen:pgen(OutFile,EncodingRule,M#module.name,GenTOrV), + debug_off(Options), + put(compact_bit_string,false), + erase(encoding_options), + erase(tlv_format), % used in ber_bin, optimize + erase(class_default_type),% used in ber_bin, optimize + ets:delete(check_functions), + case lists:member(sg,Options) of + true -> % terminate here , with .erl file generated + {false,true}; + false -> + {true,true} + end; +generate({false,M},_,_,_) -> + {false,M}. + +compile_erl({true,_},OutFile,Options) -> + erl_compile(OutFile,Options); +compile_erl({false,true},_,_) -> + ok; +compile_erl({false,Result},_,_) -> + Result. + +input_file_type([]) -> + {empty_name,[]}; +input_file_type(File) -> + case filename:extension(File) of + [] -> + case file:read_file_info(lists:concat([File,".asn1"])) of + {ok,_FileInfo} -> + {single_file, lists:concat([File,".asn1"])}; + _Error -> + case file:read_file_info(lists:concat([File,".asn"])) of + {ok,_FileInfo} -> + {single_file, lists:concat([File,".asn"])}; + _Error -> + {single_file, lists:concat([File,".py"])} + end + end; + ".asn1config" -> + case read_config_file(File,asn1_module) of + {ok,Asn1Module} -> + put(asn1_config_file,File), + input_file_type(Asn1Module); + Error -> + Error + end; + Asn1PFix -> + Base = filename:basename(File,Asn1PFix), + case filename:extension(Base) of + [] -> + {single_file,File}; + SetPFix when (SetPFix == ".set") -> + {multiple_files_file, + filename:basename(Base,SetPFix), + File}; + _Error -> + throw({input_file_error,{'Bad input file',File}}) + end + end. + +get_file_list(File) -> + case file:open(File, [read]) of + {error,Reason} -> + {error,{File,file:format_error(Reason)}}; + {ok,Stream} -> + get_file_list1(Stream,[]) + end. + +get_file_list1(Stream,Acc) -> + Ret = io:get_line(Stream,''), + case Ret of + eof -> + file:close(Stream), + lists:reverse(Acc); + FileName -> + PrefixedNameList = + case (catch input_file_type(lists:delete($\n,FileName))) of + {empty_name,[]} -> []; + {single_file,Name} -> [Name]; + {multiple_files_file,Name} -> + get_file_list(Name); + Err = {input_file_error,_Reason} -> + throw(Err) + end, + get_file_list1(Stream,PrefixedNameList++Acc) + end. + +get_rule(Options) -> + case [Rule ||Rule <-[per,ber,ber_bin,ber_bin_v2,per_bin], + Opt <- Options, + Rule==Opt] of + [Rule] -> + Rule; + [Rule|_] -> + Rule; + [] -> + ber + end. + +erl_compile(OutFile,Options) -> +% io:format("Options:~n~p~n",[Options]), + case lists:member(noobj,Options) of + true -> + ok; + _ -> + ErlOptions = remove_asn_flags(Options), + case c:c(OutFile,ErlOptions) of + {ok,_Module} -> + ok; + _ -> + {error,'no_compilation'} + end + end. + +remove_asn_flags(Options) -> + [X || X <- Options, + X /= get_rule(Options), + X /= optimize, + X /= compact_bit_string, + X /= debug, + X /= keyed_list]. + +debug_on(Options) -> + case lists:member(debug,Options) of + true -> + put(asndebug,true); + _ -> + true + end, + case lists:member(keyed_list,Options) of + true -> + put(asn_keyed_list,true); + _ -> + true + end. + + +debug_off(_Options) -> + erase(asndebug), + erase(asn_keyed_list). + + +outfile(Base, Ext, Opts) when atom(Ext) -> + outfile(Base, atom_to_list(Ext), Opts); +outfile(Base, Ext, Opts) -> + Obase = case lists:keysearch(outdir, 1, Opts) of + {value, {outdir, Odir}} -> filename:join(Odir, Base); + _NotFound -> Base % Not found or bad format + end, + case Ext of + [] -> + Obase; + _ -> + Obase++"."++Ext + end. + +%% compile(AbsFileName, Options) +%% Compile entry point for erl_compile. + +compile_asn(File,OutFile,Options) -> + compile(lists:concat([File,".asn"]),OutFile,Options). + +compile_asn1(File,OutFile,Options) -> + compile(lists:concat([File,".asn1"]),OutFile,Options). + +compile_py(File,OutFile,Options) -> + compile(lists:concat([File,".py"]),OutFile,Options). + +compile(File, _OutFile, Options) -> + case catch compile(File, make_erl_options(Options)) of + Exit = {'EXIT',_Reason} -> + io:format("~p~n~s~n",[Exit,"error"]), + error; + {error,_Reason} -> + %% case occurs due to error in asn1ct_parser2,asn1ct_check +%% io:format("~p~n",[_Reason]), +%% io:format("~p~n~s~n",[_Reason,"error"]), + error; + ok -> + io:format("ok~n"), + ok; + ParseRes when tuple(ParseRes) -> + io:format("~p~n",[ParseRes]), + ok; + ScanRes when list(ScanRes) -> + io:format("~p~n",[ScanRes]), + ok; + Unknown -> + io:format("~p~n~s~n",[Unknown,"error"]), + error + end. + +%% Converts generic compiler options to specific options. + +make_erl_options(Opts) -> + + %% This way of extracting will work even if the record passed + %% has more fields than known during compilation. + + Includes = Opts#options.includes, + Defines = Opts#options.defines, + Outdir = Opts#options.outdir, +%% Warning = Opts#options.warning, + Verbose = Opts#options.verbose, + Specific = Opts#options.specific, + Optimize = Opts#options.optimize, + OutputType = Opts#options.output_type, + Cwd = Opts#options.cwd, + + Options = + case Verbose of + true -> [verbose]; + false -> [] + end ++ +%%% case Warning of +%%% 0 -> []; +%%% _ -> [report_warnings] +%%% end ++ + [] ++ + case Optimize of + 1 -> [optimize]; + 999 -> []; + _ -> [{optimize,Optimize}] + end ++ + lists:map( + fun ({Name, Value}) -> + {d, Name, Value}; + (Name) -> + {d, Name} + end, + Defines) ++ + case OutputType of + undefined -> [ber]; % temporary default (ber when it's ready) + ber -> [ber]; + ber_bin -> [ber_bin]; + ber_bin_v2 -> [ber_bin_v2]; + per -> [per]; + per_bin -> [per_bin] + end, + + Options++[report_errors, {cwd, Cwd}, {outdir, Outdir}| + lists:map(fun(Dir) -> {i, Dir} end, Includes)]++Specific. + +pretty2(Module,AbsFile) -> + start(), + {ok,F} = file:open(AbsFile, [write]), + M = asn1_db:dbget(Module,'MODULE'), + io:format(F,"%%%%%%%%%%%%%%%%%%% ~p %%%%%%%%%%%%%%%%%%%~n",[Module]), + io:format(F,"~s\n",[asn1ct_pretty_format:term(M#module.defid)]), + io:format(F,"~s\n",[asn1ct_pretty_format:term(M#module.tagdefault)]), + io:format(F,"~s\n",[asn1ct_pretty_format:term(M#module.exports)]), + io:format(F,"~s\n",[asn1ct_pretty_format:term(M#module.imports)]), + io:format(F,"~s\n\n",[asn1ct_pretty_format:term(M#module.extensiondefault)]), + + {Types,Values,ParameterizedTypes,Classes,Objects,ObjectSets} = M#module.typeorval, + io:format(F,"%%%%%%%%%%%%%%%%%%% TYPES in ~p %%%%%%%%%%%%%%%%%%%~n",[Module]), + lists:foreach(fun(T)-> io:format(F,"~s\n", + [asn1ct_pretty_format:term(asn1_db:dbget(Module,T))]) + end,Types), + io:format(F,"%%%%%%%%%%%%%%%%%%% VALUES in ~p %%%%%%%%%%%%%%%%%%%~n",[Module]), + lists:foreach(fun(T)-> io:format(F,"~s\n", + [asn1ct_pretty_format:term(asn1_db:dbget(Module,T))]) + end,Values), + io:format(F,"%%%%%%%%%%%%%%%%%%% Parameterized Types in ~p %%%%%%%%%%%%%%%%%%%~n",[Module]), + lists:foreach(fun(T)-> io:format(F,"~s\n", + [asn1ct_pretty_format:term(asn1_db:dbget(Module,T))]) + end,ParameterizedTypes), + io:format(F,"%%%%%%%%%%%%%%%%%%% Classes in ~p %%%%%%%%%%%%%%%%%%%~n",[Module]), + lists:foreach(fun(T)-> io:format(F,"~s\n", + [asn1ct_pretty_format:term(asn1_db:dbget(Module,T))]) + end,Classes), + io:format(F,"%%%%%%%%%%%%%%%%%%% Objects in ~p %%%%%%%%%%%%%%%%%%%~n",[Module]), + lists:foreach(fun(T)-> io:format(F,"~s\n", + [asn1ct_pretty_format:term(asn1_db:dbget(Module,T))]) + end,Objects), + io:format(F,"%%%%%%%%%%%%%%%%%%% Object Sets in ~p %%%%%%%%%%%%%%%%%%%~n",[Module]), + lists:foreach(fun(T)-> io:format(F,"~s\n", + [asn1ct_pretty_format:term(asn1_db:dbget(Module,T))]) + end,ObjectSets). +start() -> + Includes = ["."], + start(Includes). + + +start(Includes) when list(Includes) -> + asn1_db:dbstart(Includes). + +stop() -> + save(), + asn1_db:stop_server(ns), + asn1_db:stop_server(rand), + stopped. + +save() -> + asn1_db:dbstop(). + +%%clear() -> +%% asn1_db:dbclear(). + +encode(Module,Term) -> + asn1rt:encode(Module,Term). + +encode(Module,Type,Term) when list(Module) -> + asn1rt:encode(list_to_atom(Module),Type,Term); +encode(Module,Type,Term) -> + asn1rt:encode(Module,Type,Term). + +decode(Module,Type,Bytes) when list(Module) -> + asn1rt:decode(list_to_atom(Module),Type,Bytes); +decode(Module,Type,Bytes) -> + asn1rt:decode(Module,Type,Bytes). + + +test(Module) -> + start(), + M = asn1_db:dbget(Module,'MODULE'), + {Types,_Values,_Ptypes,_Classes,_Objects,_ObjectSets} = M#module.typeorval, + test_each(Module,Types). + +test_each(Module,[Type | Rest]) -> + case test(Module,Type) of + {ok,_Result} -> + test_each(Module,Rest); + Error -> + Error + end; +test_each(_,[]) -> + ok. + +test(Module,Type) -> + io:format("~p:~p~n",[Module,Type]), + case (catch value(Module,Type)) of + {ok,Val} -> + %% io:format("asn1ct:test/2: ~w~n",[Val]), + test(Module,Type,Val); + {'EXIT',Reason} -> + {error,{asn1,{value,Reason}}} + end. + + +test(Module,Type,Value) -> + case catch encode(Module,Type,Value) of + {ok,Bytes} -> + %% io:format("test 1: ~p~n",[{Bytes}]), + M = if + list(Module) -> + list_to_atom(Module); + true -> + Module + end, + NewBytes = + case M:encoding_rule() of + ber -> + lists:flatten(Bytes); + ber_bin when binary(Bytes) -> + Bytes; + ber_bin -> + list_to_binary(Bytes); + ber_bin_v2 when binary(Bytes) -> + Bytes; + ber_bin_v2 -> + list_to_binary(Bytes); + per -> + lists:flatten(Bytes); + per_bin when binary(Bytes) -> + Bytes; + per_bin -> + list_to_binary(Bytes) + end, + case decode(Module,Type,NewBytes) of + {ok,Value} -> + {ok,{Module,Type,Value}}; + {ok,Res} -> + {error,{asn1,{encode_decode_mismatch, + {{Module,Type,Value},Res}}}}; + Error -> + {error,{asn1,{{decode, + {Module,Type,Value},Error}}}} + end; + Error -> + {error,{asn1,{encode,{{Module,Type,Value},Error}}}} + end. + +value(Module) -> + start(), + M = asn1_db:dbget(Module,'MODULE'), + {Types,_Values,_Ptypes,_Classes,_Objects,_ObjectSets} = M#module.typeorval, + lists:map(fun(A) ->value(Module,A) end,Types). + +value(Module,Type) -> + start(), + case catch asn1ct_value:get_type(Module,Type,no) of + {error,Reason} -> + {error,Reason}; + {'EXIT',Reason} -> + {error,Reason}; + Result -> + {ok,Result} + end. + +cmp(Module,InFile) -> + Base = filename:basename(InFile), + Dir = filename:dirname(InFile), + Ext = filename:extension(Base), + Finfo = file:read_file_info(InFile), + Minfo = file:read_file_info(filename:join(Dir,lists:concat([Module,Ext]))), + case Finfo of + Minfo -> + ok; + _ -> + io:format("asn1error: Modulename and filename must be equal~n",[]), + throw(error) + end. + +vsn() -> + ?vsn. + +print_error_message([got,H|T]) when list(H) -> + io:format(" got:"), + print_listing(H,"and"), + print_error_message(T); +print_error_message([expected,H|T]) when list(H) -> + io:format(" expected one of:"), + print_listing(H,"or"), + print_error_message(T); +print_error_message([H|T]) -> + io:format(" ~p",[H]), + print_error_message(T); +print_error_message([]) -> + io:format("~n"). + +print_listing([H1,H2|[]],AndOr) -> + io:format(" ~p ~s ~p",[H1,AndOr,H2]); +print_listing([H1,H2|T],AndOr) -> + io:format(" ~p,",[H1]), + print_listing([H2|T],AndOr); +print_listing([H],_AndOr) -> + io:format(" ~p",[H]); +print_listing([],_) -> + ok. + + +%% functions to administer ets tables + +%% Always creates a new table +create_ets_table(Name,Options) when atom(Name) -> + case ets:info(Name) of + undefined -> + ets:new(Name,Options); + _ -> + ets:delete(Name), + ets:new(Name,Options) + end. + +%% Creates a new ets table only if no table exists +create_if_no_table(Name,Options) -> + case ets:info(Name) of + undefined -> + %% create a new table + create_ets_table(Name,Options); + _ -> ok + end. + + +delete_tables([Table|Ts]) -> + case ets:info(Table) of + undefined -> ok; + _ -> ets:delete(Table) + end, + delete_tables(Ts); +delete_tables([]) -> + ok. + + +specialized_decode_prepare(Erule,M,TsAndVs,Options) -> +% Asn1confMember = +% fun([{asn1config,File}|_],_) -> +% {true,File}; +% ([],_) -> false; +% ([_H|T],Fun) -> +% Fun(T,Fun) +% end, +% case Asn1confMember(Options,Asn1confMember) of +% {true,File} -> + case lists:member(asn1config,Options) of + true -> + partial_decode_prepare(Erule,M,TsAndVs,Options); + _ -> + ok + end. +%% Reads the configuration file if it exists and stores information +%% about partial decode and incomplete decode +partial_decode_prepare(ber_bin_v2,M,TsAndVs,Options) when tuple(TsAndVs) -> + %% read configure file +% Types = element(1,TsAndVs), + CfgList = read_config_file(M#module.name), + SelectedDecode = get_config_info(CfgList,partial_decode), + ExclusiveDecode = get_config_info(CfgList,exclusive_decode), + CommandList = + create_partial_decode_gen_info(M#module.name,SelectedDecode), +% io:format("partial_decode = ~p~n",[CommandList]), + + save_config(partial_decode,CommandList), + CommandList2 = + create_partial_inc_decode_gen_info(M#module.name,ExclusiveDecode), +% io:format("partial_incomplete_decode = ~p~n",[CommandList2]), + Part_inc_tlv_tags = tag_format(ber_bin_v2,Options,CommandList2), +% io:format("partial_incomplete_decode: tlv_tags = ~p~n",[Part_inc_tlv_tags]), + save_config(partial_incomplete_decode,Part_inc_tlv_tags), + save_gen_state(ExclusiveDecode,Part_inc_tlv_tags); +partial_decode_prepare(_,_,_,_) -> + ok. + + + +%% create_partial_inc_decode_gen_info/2 +%% +%% Creats a list of tags out of the information in TypeNameList that +%% tells which value will be incomplete decoded, i.e. each end +%% component/type in TypeNameList. The significant types/components in +%% the path from the toptype must be specified in the +%% TypeNameList. Significant elements are all constructed types that +%% branches the path to the leaf and the leaf it selfs. +%% +%% Returns a list of elements, where an element may be one of +%% mandatory|[opt,Tag]|[bin,Tag]. mandatory correspond to a mandatory +%% element that shall be decoded as usual. [opt,Tag] matches an +%% OPTIONAL or DEFAULT element that shall be decoded as +%% usual. [bin,Tag] corresponds to an element, mandatory, OPTIONAL or +%% DEFAULT, that shall be left encoded (incomplete decoded). +create_partial_inc_decode_gen_info(ModName,{Mod,[{Name,L}|Ls]}) when list(L) -> + TopTypeName = partial_inc_dec_toptype(L), + [{Name,TopTypeName, + create_partial_inc_decode_gen_info1(ModName,TopTypeName,{Mod,L})}| + create_partial_inc_decode_gen_info(ModName,{Mod,Ls})]; +create_partial_inc_decode_gen_info(_,{_,[]}) -> + []; +create_partial_inc_decode_gen_info(_,[]) -> + []. + +create_partial_inc_decode_gen_info1(ModName,TopTypeName,{ModName, + [_TopType|Rest]}) -> + case asn1_db:dbget(ModName,TopTypeName) of + #typedef{typespec=TS} -> + TagCommand = get_tag_command(TS,?MANDATORY,mandatory), + create_pdec_inc_command(ModName,get_components(TS#type.def), + Rest,[TagCommand]); + _ -> + throw({error,{"wrong type list in asn1 config file", + TopTypeName}}) + end; +create_partial_inc_decode_gen_info1(M1,_,{M2,_}) when M1 /= M2 -> + throw({error,{"wrong module name in asn1 config file", + M2}}); +create_partial_inc_decode_gen_info1(_,_,TNL) -> + throw({error,{"wrong type list in asn1 config file", + TNL}}). + +%% +%% Only when there is a 'ComponentType' the config data C1 may be a +%% list, where the incomplete decode is branched. So, C1 may be a +%% list, a "binary tuple", a "parts tuple" or an atom. The second +%% element of a binary tuple and a parts tuple is an atom. +create_pdec_inc_command(_ModName,_,[],Acc) -> + lists:reverse(Acc); +create_pdec_inc_command(ModName,{Comps1,Comps2},TNL,Acc) + when list(Comps1),list(Comps2) -> + create_pdec_inc_command(ModName,Comps1 ++ Comps2,TNL,Acc); +create_pdec_inc_command(ModN,Clist,[CL|_Rest],Acc) when list(CL) -> + create_pdec_inc_command(ModN,Clist,CL,Acc); +create_pdec_inc_command(ModName, + CList=[#'ComponentType'{name=Name,typespec=TS, + prop=Prop}|Comps], + TNL=[C1|Cs],Acc) -> + case C1 of +% Name -> +% %% In this case C1 is an atom +% TagCommand = get_tag_command(TS,?MANDATORY,Prop), +% create_pdec_inc_command(ModName,get_components(TS#type.def),Cs,[TagCommand|Acc]); + {Name,undecoded} -> + TagCommand = get_tag_command(TS,?UNDECODED,Prop), + create_pdec_inc_command(ModName,Comps,Cs,[TagCommand|Acc]); + {Name,parts} -> + TagCommand = get_tag_command(TS,?PARTS,Prop), + create_pdec_inc_command(ModName,Comps,Cs,[TagCommand|Acc]); + L when list(L) -> + %% This case is only possible as the first element after + %% the top type element, when top type is SEGUENCE or SET. + %% Follow each element in L. Must note every tag on the + %% way until the last command is reached, but it ought to + %% be enough to have a "complete" or "complete optional" + %% command for each component that is not specified in the + %% config file. Then in the TLV decode the components with + %% a "complete" command will be decoded by an ordinary TLV + %% decode. + create_pdec_inc_command(ModName,CList,L,Acc); + {Name,RestPartsList} when list(RestPartsList) -> + %% Same as previous, but this may occur at any place in + %% the structure. The previous is only possible as the + %% second element. + case get_tag_command(TS,?MANDATORY,Prop) of + ?MANDATORY -> + InnerDirectives= + create_pdec_inc_command(ModName,TS#type.def, + RestPartsList,[]), + create_pdec_inc_command(ModName,Comps,Cs, + [[?MANDATORY,InnerDirectives]|Acc]); +% create_pdec_inc_command(ModName,Comps,Cs, +% [InnerDirectives,?MANDATORY|Acc]); + [Opt,EncTag] -> + InnerDirectives = + create_pdec_inc_command(ModName,TS#type.def, + RestPartsList,[]), + create_pdec_inc_command(ModName,Comps,Cs, + [[Opt,EncTag,InnerDirectives]|Acc]) + end; +% create_pdec_inc_command(ModName,CList,RestPartsList,Acc); +%% create_pdec_inc_command(ModName,TS#type.def,RestPartsList,Acc); + _ -> %% this component may not be in the config list + TagCommand = get_tag_command(TS,?MANDATORY,Prop), + create_pdec_inc_command(ModName,Comps,TNL,[TagCommand|Acc]) + end; +create_pdec_inc_command(ModName, + {'CHOICE',[#'ComponentType'{name=C1, + typespec=TS, + prop=Prop}|Comps]}, + [{C1,Directive}|Rest],Acc) -> + case Directive of + List when list(List) -> + [Command,Tag] = get_tag_command(TS,?ALTERNATIVE,Prop), + CompAcc = create_pdec_inc_command(ModName,TS#type.def,List,[]), + create_pdec_inc_command(ModName,{'CHOICE',Comps},Rest, + [[Command,Tag,CompAcc]|Acc]); + undecoded -> + TagCommand = get_tag_command(TS,?ALTERNATIVE_UNDECODED,Prop), + create_pdec_inc_command(ModName,{'CHOICE',Comps},Rest, + [TagCommand|Acc]); + parts -> + TagCommand = get_tag_command(TS,?ALTERNATIVE_PARTS,Prop), + create_pdec_inc_command(ModName,{'CHOICE',Comps},Rest, + [TagCommand|Acc]) + end; +create_pdec_inc_command(ModName, + {'CHOICE',[#'ComponentType'{typespec=TS, + prop=Prop}|Comps]}, + TNL,Acc) -> + TagCommand = get_tag_command(TS,?ALTERNATIVE,Prop), + create_pdec_inc_command(ModName,{'CHOICE',Comps},TNL,[TagCommand|Acc]); +create_pdec_inc_command(M,{'CHOICE',{Cs1,Cs2}},TNL,Acc) + when list(Cs1),list(Cs2) -> + create_pdec_inc_command(M,{'CHOICE',Cs1 ++ Cs2},TNL,Acc); +create_pdec_inc_command(ModName,#'Externaltypereference'{module=M,type=Name}, + TNL,Acc) -> + #type{def=Def} = get_referenced_type(M,Name), + create_pdec_inc_command(ModName,get_components(Def),TNL,Acc); +create_pdec_inc_command(_,_,TNL,_) -> + throw({error,{"unexpected error when creating partial " + "decode command",TNL}}). + +partial_inc_dec_toptype([T|_]) when atom(T) -> + T; +partial_inc_dec_toptype([{T,_}|_]) when atom(T) -> + T; +partial_inc_dec_toptype([L|_]) when list(L) -> + partial_inc_dec_toptype(L); +partial_inc_dec_toptype(_) -> + throw({error,{"no top type found for partial incomplete decode"}}). + + +%% Creats a list of tags out of the information in TypeList and Types +%% that tells which value will be decoded. Each constructed type that +%% is in the TypeList will get a "choosen" command. Only the last +%% type/component in the TypeList may be a primitive type. Components +%% "on the way" to the final element may get the "skip" or the +%% "skip_optional" command. +%% CommandList = [Elements] +%% Elements = {choosen,Tag}|{skip_optional,Tag}|skip +%% Tag is a binary with the tag BER encoded. +create_partial_decode_gen_info(ModName,{{_,ModName},TypeList}) -> + case TypeList of + [TopType|Rest] -> + case asn1_db:dbget(ModName,TopType) of + #typedef{typespec=TS} -> + TagCommand = get_tag_command(TS,?CHOOSEN), + create_pdec_command(ModName,get_components(TS#type.def), + Rest,[TagCommand]); + _ -> + throw({error,{"wrong type list in asn1 config file", + TypeList}}) + end; + _ -> + [] + end; +create_partial_decode_gen_info(_,[]) -> + []; +create_partial_decode_gen_info(_M1,{{_,M2},_}) -> + throw({error,{"wrong module name in asn1 config file", + M2}}). + +%% create_pdec_command/4 for each name (type or component) in the +%% third argument, TypeNameList, a command is created. The command has +%% information whether the component/type shall be skipped, looked +%% into or returned. The list of commands is returned. +create_pdec_command(_ModName,_,[],Acc) -> + lists:reverse(Acc); +create_pdec_command(ModName,[#'ComponentType'{name=C1,typespec=TS}|_Comps], + [C1|Cs],Acc) -> + %% this component is a constructed type or the last in the + %% TypeNameList otherwise the config spec is wrong + TagCommand = get_tag_command(TS,?CHOOSEN), + create_pdec_command(ModName,get_components(TS#type.def), + Cs,[TagCommand|Acc]); +create_pdec_command(ModName,[#'ComponentType'{typespec=TS, + prop=Prop}|Comps], + [C2|Cs],Acc) -> + TagCommand = + case Prop of + mandatory -> + get_tag_command(TS,?SKIP); + _ -> + get_tag_command(TS,?SKIP_OPTIONAL) + end, + create_pdec_command(ModName,Comps,[C2|Cs],[TagCommand|Acc]); +create_pdec_command(ModName,{'CHOICE',[Comp=#'ComponentType'{name=C1}|_]},TNL=[C1|_Cs],Acc) -> + create_pdec_command(ModName,[Comp],TNL,Acc); +create_pdec_command(ModName,{'CHOICE',[#'ComponentType'{}|Comps]},TNL,Acc) -> + create_pdec_command(ModName,{'CHOICE',Comps},TNL,Acc); +create_pdec_command(ModName,#'Externaltypereference'{module=M,type=C1}, + TypeNameList,Acc) -> + case get_referenced_type(M,C1) of + #type{def=Def} -> + create_pdec_command(ModName,get_components(Def),TypeNameList, + Acc); + Err -> + throw({error,{"unexpected result when fetching " + "referenced element",Err}}) + end; +create_pdec_command(ModName,TS=#type{def=Def},[C1|Cs],Acc) -> + %% This case when we got the "components" of a SEQUENCE/SET OF + case C1 of + [1] -> + %% A list with an integer is the only valid option in a 'S + %% OF', the other valid option would be an empty + %% TypeNameList saying that the entire 'S OF' will be + %% decoded. + TagCommand = get_tag_command(TS,?CHOOSEN), + create_pdec_command(ModName,Def,Cs,[TagCommand|Acc]); + [N] when integer(N) -> + TagCommand = get_tag_command(TS,?SKIP), + create_pdec_command(ModName,Def,[[N-1]|Cs],[TagCommand|Acc]); + Err -> + throw({error,{"unexpected error when creating partial " + "decode command",Err}}) + end; +create_pdec_command(_,_,TNL,_) -> + throw({error,{"unexpected error when creating partial " + "decode command",TNL}}). + +% get_components({'CHOICE',Components}) -> +% Components; +get_components(#'SEQUENCE'{components=Components}) -> + Components; +get_components(#'SET'{components=Components}) -> + Components; +get_components({'SEQUENCE OF',Components}) -> + Components; +get_components({'SET OF',Components}) -> + Components; +get_components(Def) -> + Def. + +%% get_tag_command(Type,Command) + +%% Type is the type that has information about the tag Command tells +%% what to do with the encoded value with the tag of Type when +%% decoding. +get_tag_command(#type{tag=[]},_) -> + []; +get_tag_command(#type{tag=[_Tag]},?SKIP) -> + ?SKIP; +get_tag_command(#type{tag=[Tag]},Command) -> + %% encode the tag according to BER + [Command,encode_tag_val(decode_class(Tag#tag.class),Tag#tag.form, + Tag#tag.number)]; +get_tag_command(T=#type{tag=[Tag|Tags]},Command) -> + [get_tag_command(T#type{tag=Tag},Command)| + get_tag_command(T#type{tag=Tags},Command)]. + +%% get_tag_command/3 used by create_pdec_inc_command +get_tag_command(#type{tag=[]},_,_) -> + []; +get_tag_command(#type{tag=[Tag]},?MANDATORY,Prop) -> + case Prop of + mandatory -> + ?MANDATORY; + {'DEFAULT',_} -> + [?DEFAULT,encode_tag_val(decode_class(Tag#tag.class), + Tag#tag.form,Tag#tag.number)]; + _ -> [?OPTIONAL,encode_tag_val(decode_class(Tag#tag.class), + Tag#tag.form,Tag#tag.number)] + end; +get_tag_command(#type{tag=[Tag]},Command,_) -> + [Command,encode_tag_val(decode_class(Tag#tag.class),Tag#tag.form, + Tag#tag.number)]. + + +get_referenced_type(M,Name) -> + case asn1_db:dbget(M,Name) of + #typedef{typespec=TS} -> + case TS of + #type{def=#'Externaltypereference'{module=M2,type=Name2}} -> + %% The tags have already been taken care of in the + %% first reference where they were gathered in a + %% list of tags. + get_referenced_type(M2,Name2); + #type{} -> TS; + _ -> + throw({error,{"unexpected element when" + " fetching referenced type",TS}}) + end; + T -> + throw({error,{"unexpected element when fetching " + "referenced type",T}}) + end. + +tag_format(EncRule,_Options,CommandList) -> + case EncRule of + ber_bin_v2 -> + tlv_tags(CommandList); + _ -> + CommandList + end. + +tlv_tags([]) -> + []; +tlv_tags([mandatory|Rest]) -> + [mandatory|tlv_tags(Rest)]; +tlv_tags([[Command,Tag]|Rest]) when atom(Command),binary(Tag) -> + [[Command,tlv_tag(Tag)]|tlv_tags(Rest)]; +tlv_tags([[Command,Directives]|Rest]) when atom(Command),list(Directives) -> + [[Command,tlv_tags(Directives)]|tlv_tags(Rest)]; +%% remove all empty lists +tlv_tags([[]|Rest]) -> + tlv_tags(Rest); +tlv_tags([{Name,TopType,L1}|Rest]) when list(L1),atom(TopType) -> + [{Name,TopType,tlv_tags(L1)}|tlv_tags(Rest)]; +tlv_tags([[Command,Tag,L1]|Rest]) when list(L1),binary(Tag) -> + [[Command,tlv_tag(Tag),tlv_tags(L1)]|tlv_tags(Rest)]; +tlv_tags([L=[L1|_]|Rest]) when list(L1) -> + [tlv_tags(L)|tlv_tags(Rest)]. + +tlv_tag(<<Cl:2,_:1,TagNo:5>>) when TagNo < 31 -> + (Cl bsl 16) + TagNo; +tlv_tag(<<Cl:2,_:1,31:5,0:1,TagNo:7>>) -> + (Cl bsl 16) + TagNo; +tlv_tag(<<Cl:2,_:1,31:5,Buffer/binary>>) -> + TagNo = tlv_tag1(Buffer,0), + (Cl bsl 16) + TagNo. +tlv_tag1(<<0:1,PartialTag:7>>,Acc) -> + (Acc bsl 7) bor PartialTag; +tlv_tag1(<<1:1,PartialTag:7,Buffer/binary>>,Acc) -> + tlv_tag1(Buffer,(Acc bsl 7) bor PartialTag). + +%% reads the content from the configuration file and returns the +%% selected part choosen by InfoType. Assumes that the config file +%% content is an Erlang term. +read_config_file(ModuleName,InfoType) when atom(InfoType) -> + CfgList = read_config_file(ModuleName), + get_config_info(CfgList,InfoType). + + +read_config_file(ModuleName) -> + case file:consult(lists:concat([ModuleName,'.asn1config'])) of +% case file:consult(ModuleName) of + {ok,CfgList} -> + CfgList; + {error,enoent} -> + Options = get(encoding_options), + Includes = [I || {i,I} <- Options], + read_config_file1(ModuleName,Includes); + {error,Reason} -> + file:format_error(Reason), + throw({error,{"error reading asn1 config file",Reason}}) + end. +read_config_file1(ModuleName,[]) -> + case filename:extension(ModuleName) of + ".asn1config" -> + throw({error,enoent}); + _ -> + read_config_file(lists:concat([ModuleName,".asn1config"])) + end; +read_config_file1(ModuleName,[H|T]) -> +% File = filename:join([H,lists:concat([ModuleName,'.asn1config'])]), + File = filename:join([H,ModuleName]), + case file:consult(File) of + {ok,CfgList} -> + CfgList; + {error,enoent} -> + read_config_file1(ModuleName,T); + {error,Reason} -> + file:format_error(Reason), + throw({error,{"error reading asn1 config file",Reason}}) + end. + +get_config_info(CfgList,InfoType) -> + case InfoType of + all -> + CfgList; + _ -> + case lists:keysearch(InfoType,1,CfgList) of + {value,{InfoType,Value}} -> + Value; + false -> + [] + end + end. + +%% save_config/2 saves the Info with the key Key +%% Before saving anything check if a table exists +save_config(Key,Info) -> + create_if_no_table(asn1_general,[named_table]), + ets:insert(asn1_general,{{asn1_config,Key},Info}). + +read_config_data(Key) -> + case ets:info(asn1_general) of + undefined -> undefined; + _ -> + case ets:lookup(asn1_general,{asn1_config,Key}) of + [{_,Data}] -> Data; + Err -> + io:format("strange data from config file ~w~n",[Err]), + Err + end + end. + + +%% +%% Functions to manipulate the gen_state record saved in the +%% asn1_general ets table. +%% + +%% saves input data in a new gen_state record +save_gen_state({_,ConfList},PartIncTlvTagList) -> + %ConfList=[{FunctionName,PatternList}|Rest] + StateRec = #gen_state{inc_tag_pattern=PartIncTlvTagList, + inc_type_pattern=ConfList}, + save_config(gen_state,StateRec); +save_gen_state(_,_) -> +%% ok. + save_config(gen_state,#gen_state{}). + +save_gen_state(GenState) when record(GenState,gen_state) -> + save_config(gen_state,GenState). + + +%% get_gen_state_field returns undefined if no gen_state exists or if +%% Field is undefined or the data at the field. +get_gen_state_field(Field) -> + case read_config_data(gen_state) of + undefined -> + undefined; + GenState -> + get_gen_state_field(GenState,Field) + end. +get_gen_state_field(#gen_state{active=Active},active) -> + Active; +get_gen_state_field(_,active) -> + false; +get_gen_state_field(GS,prefix) -> + GS#gen_state.prefix; +get_gen_state_field(GS,inc_tag_pattern) -> + GS#gen_state.inc_tag_pattern; +get_gen_state_field(GS,tag_pattern) -> + GS#gen_state.tag_pattern; +get_gen_state_field(GS,inc_type_pattern) -> + GS#gen_state.inc_type_pattern; +get_gen_state_field(GS,type_pattern) -> + GS#gen_state.type_pattern; +get_gen_state_field(GS,func_name) -> + GS#gen_state.func_name; +get_gen_state_field(GS,namelist) -> + GS#gen_state.namelist; +get_gen_state_field(GS,tobe_refed_funcs) -> + GS#gen_state.tobe_refed_funcs; +get_gen_state_field(GS,gen_refed_funcs) -> + GS#gen_state.gen_refed_funcs. + + +get_gen_state() -> + read_config_data(gen_state). + + +update_gen_state(Field,Data) -> + case get_gen_state() of + State when record(State,gen_state) -> + update_gen_state(Field,State,Data); + _ -> + exit({error,{asn1,{internal, + "tried to update nonexistent gen_state",Field,Data}}}) + end. +update_gen_state(active,State,Data) -> + save_gen_state(State#gen_state{active=Data}); +update_gen_state(prefix,State,Data) -> + save_gen_state(State#gen_state{prefix=Data}); +update_gen_state(inc_tag_pattern,State,Data) -> + save_gen_state(State#gen_state{inc_tag_pattern=Data}); +update_gen_state(tag_pattern,State,Data) -> + save_gen_state(State#gen_state{tag_pattern=Data}); +update_gen_state(inc_type_pattern,State,Data) -> + save_gen_state(State#gen_state{inc_type_pattern=Data}); +update_gen_state(type_pattern,State,Data) -> + save_gen_state(State#gen_state{type_pattern=Data}); +update_gen_state(func_name,State,Data) -> + save_gen_state(State#gen_state{func_name=Data}); +update_gen_state(namelist,State,Data) -> +% SData = +% case Data of +% [D] when list(D) -> D; +% _ -> Data +% end, + save_gen_state(State#gen_state{namelist=Data}); +update_gen_state(tobe_refed_funcs,State,Data) -> + save_gen_state(State#gen_state{tobe_refed_funcs=Data}); +update_gen_state(gen_refed_funcs,State,Data) -> + save_gen_state(State#gen_state{gen_refed_funcs=Data}). + +update_namelist(Name) -> + case get_gen_state_field(namelist) of + [Name,Rest] -> update_gen_state(namelist,Rest); + [Name|Rest] -> update_gen_state(namelist,Rest); + [{Name,List}] when list(List) -> update_gen_state(namelist,List); + [{Name,Atom}|Rest] when atom(Atom) -> update_gen_state(namelist,Rest); + Other -> Other + end. + +pop_namelist() -> + DeepTail = %% removes next element in order + fun([[{_,A}]|T],_Fun) when atom(A) -> T; + ([{_N,L}|T],_Fun) when list(L) -> [L|T]; + ([[]|T],Fun) -> Fun(T,Fun); + ([L1|L2],Fun) when list(L1) -> + case lists:flatten(L1) of + [] -> Fun([L2],Fun); + _ -> [Fun(L1,Fun)|L2] + end; + ([_H|T],_Fun) -> T + end, + {Pop,NewNL} = + case get_gen_state_field(namelist) of + [] -> {[],[]}; + L -> + {next_namelist_el(L), + DeepTail(L,DeepTail)} + end, + update_gen_state(namelist,NewNL), + Pop. + +%% next_namelist_el fetches the next type/component name in turn in +%% the namelist, without changing the namelist. +next_namelist_el() -> + case get_gen_state_field(namelist) of + undefined -> undefined; + L when list(L) -> next_namelist_el(L) + end. + +next_namelist_el([]) -> + []; +next_namelist_el([L]) when list(L) -> + next_namelist_el(L); +next_namelist_el([H|_]) when atom(H) -> + H; +next_namelist_el([L|T]) when list(L) -> + case next_namelist_el(L) of + [] -> + next_namelist_el([T]); + R -> + R + end; +next_namelist_el([H={_,A}|_]) when atom(A) -> + H. + +%% removes a bracket from the namelist +step_in_constructed() -> + case get_gen_state_field(namelist) of + [L] when list(L) -> + update_gen_state(namelist,L); + _ -> ok + end. + +is_function_generated(Name) -> + case get_gen_state_field(gen_refed_funcs) of + L when list(L) -> + lists:member(Name,L); + _ -> + false + end. + +get_tobe_refed_func(Name) -> + case get_gen_state_field(tobe_refed_funcs) of + L when list(L) -> + case lists:keysearch(Name,1,L) of + {_,Element} -> + Element; + _ -> + undefined + end; + _ -> + undefined + end. + +add_tobe_refed_func(Data) -> + L = get_gen_state_field(tobe_refed_funcs), + update_gen_state(tobe_refed_funcs,[Data|L]). + +%% moves Name from the to be list to the generated list. +generated_refed_func(Name) -> + L = get_gen_state_field(tobe_refed_funcs), + NewL = lists:keydelete(Name,1,L), + update_gen_state(tobe_refed_funcs,NewL), + L2 = get_gen_state_field(gen_refed_funcs), + update_gen_state(gen_refed_funcs,[Name|L2]). + +add_generated_refed_func(Data) -> + L = get_gen_state_field(gen_refed_funcs), + update_gen_state(gen_refed_funcs,[Data|L]). + + +next_refed_func() -> + case get_gen_state_field(tobe_refed_funcs) of + [] -> + []; + [H|T] -> + update_gen_state(tobe_refed_funcs,T), + H + end. + +reset_gen_state() -> + save_gen_state(#gen_state{}). diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_check.erl b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_check.erl new file mode 100644 index 0000000000..2f0ada122e --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_check.erl @@ -0,0 +1,5566 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: asn1ct_check.erl,v 1.1 2008/12/17 09:53:29 mikpe Exp $ +%% +-module(asn1ct_check). + +%% Main Module for ASN.1 compile time functions + +%-compile(export_all). +-export([check/2,storeindb/1]). +-include("asn1_records.hrl"). +%%% The tag-number for universal types +-define(N_BOOLEAN, 1). +-define(N_INTEGER, 2). +-define(N_BIT_STRING, 3). +-define(N_OCTET_STRING, 4). +-define(N_NULL, 5). +-define(N_OBJECT_IDENTIFIER, 6). +-define(N_OBJECT_DESCRIPTOR, 7). +-define(N_EXTERNAL, 8). % constructed +-define(N_INSTANCE_OF,8). +-define(N_REAL, 9). +-define(N_ENUMERATED, 10). +-define(N_EMBEDDED_PDV, 11). % constructed +-define(N_SEQUENCE, 16). +-define(N_SET, 17). +-define(N_NumericString, 18). +-define(N_PrintableString, 19). +-define(N_TeletexString, 20). +-define(N_VideotexString, 21). +-define(N_IA5String, 22). +-define(N_UTCTime, 23). +-define(N_GeneralizedTime, 24). +-define(N_GraphicString, 25). +-define(N_VisibleString, 26). +-define(N_GeneralString, 27). +-define(N_UniversalString, 28). +-define(N_CHARACTER_STRING, 29). % constructed +-define(N_BMPString, 30). + +-define(TAG_PRIMITIVE(Num), + case S#state.erule of + ber_bin_v2 -> + #tag{class='UNIVERSAL',number=Num,type='IMPLICIT',form=0}; + _ -> [] + end). +-define(TAG_CONSTRUCTED(Num), + case S#state.erule of + ber_bin_v2 -> + #tag{class='UNIVERSAL',number=Num,type='IMPLICIT',form=32}; + _ -> [] + end). + +-record(newt,{type=unchanged,tag=unchanged,constraint=unchanged,inlined=no}). % used in check_type to update type and tag +-record(newv,{type=unchanged,value=unchanged}). % used in check_value to update type and value + +check(S,{Types,Values,ParameterizedTypes,Classes,Objects,ObjectSets}) -> + %%Predicates used to filter errors + TupleIs = fun({T,_},T) -> true; + (_,_) -> false + end, + IsClass = fun(X) -> TupleIs(X,asn1_class) end, + IsObjSet = fun(X) -> TupleIs(X,objectsetdef) end, + IsPObjSet = fun(X) -> TupleIs(X,pobjectsetdef) end, + IsObject = fun(X) -> TupleIs(X,objectdef) end, + IsValueSet = fun(X) -> TupleIs(X,valueset) end, + Element2 = fun(X) -> element(2,X) end, + + _Perror = checkp(S,ParameterizedTypes,[]), % must do this before the templates are used + Terror = checkt(S,Types,[]), + + %% get parameterized object sets sent to checkt/3 + %% and update Terror + + {PObjSetNames1,Terror2} = filter_errors(IsPObjSet,Terror), + + Verror = checkv(S,Values ++ ObjectSets,[]), %value sets may be parsed as object sets + + %% get information object classes wrongly sent to checkt/3 + %% and update Terror2 + + {AddClasses,Terror3} = filter_errors(IsClass,Terror2), + + NewClasses = Classes++AddClasses, + + Cerror = checkc(S,NewClasses,[]), + + %% get object sets incorrectly sent to checkv/3 + %% and update Verror + + {ObjSetNames,Verror2} = filter_errors(IsObjSet,Verror), + + %% get parameterized object sets incorrectly sent to checkv/3 + %% and update Verror2 + + {PObjSetNames,Verror3} = filter_errors(IsPObjSet,Verror2), + + %% get objects incorrectly sent to checkv/3 + %% and update Verror3 + + {ObjectNames,Verror4} = filter_errors(IsObject,Verror3), + + NewObjects = Objects++ObjectNames, + NewObjectSets = ObjSetNames ++ PObjSetNames ++ PObjSetNames1, + + %% get value sets + %% and update Verror4 + + {ValueSetNames,Verror5} = filter_errors(IsValueSet,Verror4), + + asn1ct:create_ets_table(inlined_objects,[named_table]), + {Oerror,ExclO,ExclOS} = checko(S,NewObjects ++ + NewObjectSets, + [],[],[]), + InlinedObjTuples = ets:tab2list(inlined_objects), + InlinedObjects = lists:map(Element2,InlinedObjTuples), + ets:delete(inlined_objects), + + Exporterror = check_exports(S,S#state.module), + case {Terror3,Verror5,Cerror,Oerror,Exporterror} of + {[],[],[],[],[]} -> + ContextSwitchTs = context_switch_in_spec(), + InstanceOf = instance_of_in_spec(), + NewTypes = lists:subtract(Types,AddClasses) ++ ContextSwitchTs + ++ InstanceOf, + NewValues = lists:subtract(Values,PObjSetNames++ObjectNames++ + ValueSetNames), + {ok, + {NewTypes,NewValues,ParameterizedTypes, + NewClasses,NewObjects,NewObjectSets}, + {NewTypes,NewValues,ParameterizedTypes,NewClasses, + lists:subtract(NewObjects,ExclO)++InlinedObjects, + lists:subtract(NewObjectSets,ExclOS)}}; + _ ->{error,{asn1,lists:flatten([Terror3,Verror5,Cerror, + Oerror,Exporterror])}} + end. + +context_switch_in_spec() -> + L = [{external,'EXTERNAL'}, + {embedded_pdv,'EMBEDDED PDV'}, + {character_string,'CHARACTER STRING'}], + F = fun({T,TName},Acc) -> + case get(T) of + generate -> erase(T), + [TName|Acc]; + _ -> Acc + end + end, + lists:foldl(F,[],L). + +instance_of_in_spec() -> + case get(instance_of) of + generate -> + erase(instance_of), + ['INSTANCE OF']; + _ -> + [] + end. + +filter_errors(Pred,ErrorList) -> + Element2 = fun(X) -> element(2,X) end, + RemovedTupleElements = lists:filter(Pred,ErrorList), + RemovedNames = lists:map(Element2,RemovedTupleElements), + %% remove value set name tuples from Verror + RestErrors = lists:subtract(ErrorList,RemovedTupleElements), + {RemovedNames,RestErrors}. + + +check_exports(S,Module = #module{}) -> + case Module#module.exports of + {exports,[]} -> + []; + {exports,all} -> + []; + {exports,ExportList} when list(ExportList) -> + IsNotDefined = + fun(X) -> + case catch get_referenced_type(S,X) of + {error,{asn1,_}} -> + true; + _ -> false + end + end, + case lists:filter(IsNotDefined,ExportList) of + [] -> + []; + NoDefExp -> + GetName = + fun(T = #'Externaltypereference'{type=N})-> + %%{exported,undefined,entity,N} + NewS=S#state{type=T,tname=N}, + error({export,"exported undefined entity",NewS}) + end, + lists:map(GetName,NoDefExp) + end + end. + +checkt(S,[Name|T],Acc) -> + %%io:format("check_typedef:~p~n",[Name]), + Result = + case asn1_db:dbget(S#state.mname,Name) of + undefined -> + error({type,{internal_error,'???'},S}); + Type when record(Type,typedef) -> + NewS = S#state{type=Type,tname=Name}, + case catch(check_type(NewS,Type,Type#typedef.typespec)) of + {error,Reason} -> + error({type,Reason,NewS}); + {'EXIT',Reason} -> + error({type,{internal_error,Reason},NewS}); + {asn1_class,_ClassDef} -> + {asn1_class,Name}; + pobjectsetdef -> + {pobjectsetdef,Name}; + pvalueset -> + {pvalueset,Name}; + Ts -> + case Type#typedef.checked of + true -> % already checked and updated + ok; + _ -> + NewTypeDef = Type#typedef{checked=true,typespec = Ts}, + %io:format("checkt:dbput:~p, ~p~n",[S#state.mname,NewTypeDef#typedef.name]), + asn1_db:dbput(NewS#state.mname,Name,NewTypeDef), % update the type + ok + end + end + end, + case Result of + ok -> + checkt(S,T,Acc); + _ -> + checkt(S,T,[Result|Acc]) + end; +checkt(S,[],Acc) -> + case check_contextswitchingtypes(S,[]) of + [] -> + lists:reverse(Acc); + L -> + checkt(S,L,Acc) + end. + +check_contextswitchingtypes(S,Acc) -> + CSTList=[{external,'EXTERNAL'}, + {embedded_pdv,'EMBEDDED PDV'}, + {character_string,'CHARACTER STRING'}], + check_contextswitchingtypes(S,CSTList,Acc). + +check_contextswitchingtypes(S,[{T,TName}|Ts],Acc) -> + case get(T) of + unchecked -> + put(T,generate), + check_contextswitchingtypes(S,Ts,[TName|Acc]); + _ -> + check_contextswitchingtypes(S,Ts,Acc) + end; +check_contextswitchingtypes(_,[],Acc) -> + Acc. + +checkv(S,[Name|T],Acc) -> + %%io:format("check_valuedef:~p~n",[Name]), + Result = case asn1_db:dbget(S#state.mname,Name) of + undefined -> error({value,{internal_error,'???'},S}); + Value when record(Value,valuedef); + record(Value,typedef); %Value set may be parsed as object set. + record(Value,pvaluedef); + record(Value,pvaluesetdef) -> + NewS = S#state{value=Value}, + case catch(check_value(NewS,Value)) of + {error,Reason} -> + error({value,Reason,NewS}); + {'EXIT',Reason} -> + error({value,{internal_error,Reason},NewS}); + {pobjectsetdef} -> + {pobjectsetdef,Name}; + {objectsetdef} -> + {objectsetdef,Name}; + {objectdef} -> + %% this is an object, save as typedef + #valuedef{checked=C,pos=Pos,name=N,type=Type, + value=Def}=Value, +% Currmod = S#state.mname, +% #type{def= +% #'Externaltypereference'{module=Mod, +% type=CName}} = Type, + ClassName = + Type#type.def, +% case Mod of +% Currmod -> +% {objectclassname,CName}; +% _ -> +% {objectclassname,Mod,CName} +% end, + NewSpec = #'Object'{classname=ClassName, + def=Def}, + NewDef = #typedef{checked=C,pos=Pos,name=N, + typespec=NewSpec}, + asn1_db:dbput(NewS#state.mname,Name,NewDef), + {objectdef,Name}; + {valueset,VSet} -> + Pos = asn1ct:get_pos_of_def(Value), + CheckedVSDef = #typedef{checked=true,pos=Pos, + name=Name,typespec=VSet}, + asn1_db:dbput(NewS#state.mname,Name,CheckedVSDef), + {valueset,Name}; + V -> + %% update the valuedef + asn1_db:dbput(NewS#state.mname,Name,V), + ok + end + end, + case Result of + ok -> + checkv(S,T,Acc); + _ -> + checkv(S,T,[Result|Acc]) + end; +checkv(_S,[],Acc) -> + lists:reverse(Acc). + + +checkp(S,[Name|T],Acc) -> + %io:format("check_ptypedef:~p~n",[Name]), + Result = case asn1_db:dbget(S#state.mname,Name) of + undefined -> + error({type,{internal_error,'???'},S}); + Type when record(Type,ptypedef) -> + NewS = S#state{type=Type,tname=Name}, + case catch(check_ptype(NewS,Type,Type#ptypedef.typespec)) of + {error,Reason} -> + error({type,Reason,NewS}); + {'EXIT',Reason} -> + error({type,{internal_error,Reason},NewS}); + {asn1_class,_ClassDef} -> + {asn1_class,Name}; + Ts -> + NewType = Type#ptypedef{checked=true,typespec = Ts}, + asn1_db:dbput(NewS#state.mname,Name,NewType), % update the type + ok + end + end, + case Result of + ok -> + checkp(S,T,Acc); + _ -> + checkp(S,T,[Result|Acc]) + end; +checkp(_S,[],Acc) -> + lists:reverse(Acc). + + + + +checkc(S,[Name|Cs],Acc) -> + Result = + case asn1_db:dbget(S#state.mname,Name) of + undefined -> + error({class,{internal_error,'???'},S}); + Class -> + ClassSpec = if + record(Class,classdef) -> + Class#classdef.typespec; + record(Class,typedef) -> + Class#typedef.typespec + end, + NewS = S#state{type=Class,tname=Name}, + case catch(check_class(NewS,ClassSpec)) of + {error,Reason} -> + error({class,Reason,NewS}); + {'EXIT',Reason} -> + error({class,{internal_error,Reason},NewS}); + C -> + %% update the classdef + NewClass = + if + record(Class,classdef) -> + Class#classdef{checked=true,typespec=C}; + record(Class,typedef) -> + #classdef{checked=true,name=Name,typespec=C} + end, + asn1_db:dbput(NewS#state.mname,Name,NewClass), + ok + end + end, + case Result of + ok -> + checkc(S,Cs,Acc); + _ -> + checkc(S,Cs,[Result|Acc]) + end; +checkc(_S,[],Acc) -> +%% include_default_class(S#state.mname), + lists:reverse(Acc). + +checko(S,[Name|Os],Acc,ExclO,ExclOS) -> + Result = + case asn1_db:dbget(S#state.mname,Name) of + undefined -> + error({type,{internal_error,'???'},S}); + Object when record(Object,typedef) -> + NewS = S#state{type=Object,tname=Name}, + case catch(check_object(NewS,Object,Object#typedef.typespec)) of + {error,Reason} -> + error({type,Reason,NewS}); + {'EXIT',Reason} -> + error({type,{internal_error,Reason},NewS}); + {asn1,Reason} -> + error({type,Reason,NewS}); + O -> + NewObj = Object#typedef{checked=true,typespec=O}, + asn1_db:dbput(NewS#state.mname,Name,NewObj), + if + record(O,'Object') -> + case O#'Object'.gen of + true -> + {ok,ExclO,ExclOS}; + false -> + {ok,[Name|ExclO],ExclOS} + end; + record(O,'ObjectSet') -> + case O#'ObjectSet'.gen of + true -> + {ok,ExclO,ExclOS}; + false -> + {ok,ExclO,[Name|ExclOS]} + end + end + end; + PObject when record(PObject,pobjectdef) -> + NewS = S#state{type=PObject,tname=Name}, + case (catch check_pobject(NewS,PObject)) of + {error,Reason} -> + error({type,Reason,NewS}); + {'EXIT',Reason} -> + error({type,{internal_error,Reason},NewS}); + {asn1,Reason} -> + error({type,Reason,NewS}); + PO -> + NewPObj = PObject#pobjectdef{def=PO}, + asn1_db:dbput(NewS#state.mname,Name,NewPObj), + {ok,[Name|ExclO],ExclOS} + end; + PObjSet when record(PObjSet,pvaluesetdef) -> + %% this is a parameterized object set. Might be a parameterized + %% value set, couldn't it? + NewS = S#state{type=PObjSet,tname=Name}, + case (catch check_pobjectset(NewS,PObjSet)) of + {error,Reason} -> + error({type,Reason,NewS}); + {'EXIT',Reason} -> + error({type,{internal_error,Reason},NewS}); + {asn1,Reason} -> + error({type,Reason,NewS}); + POS -> + %%NewPObjSet = PObjSet#pvaluesetdef{valueset=POS}, + asn1_db:dbput(NewS#state.mname,Name,POS), + {ok,ExclO,[Name|ExclOS]} + end + end, + case Result of + {ok,NewExclO,NewExclOS} -> + checko(S,Os,Acc,NewExclO,NewExclOS); + _ -> + checko(S,Os,[Result|Acc],ExclO,ExclOS) + end; +checko(_S,[],Acc,ExclO,ExclOS) -> + {lists:reverse(Acc),lists:reverse(ExclO),lists:reverse(ExclOS)}. + +check_class(S,CDef=#classdef{checked=Ch,name=Name,typespec=TS}) -> + case Ch of + true -> TS; + idle -> TS; + _ -> + NewCDef = CDef#classdef{checked=idle}, + asn1_db:dbput(S#state.mname,Name,NewCDef), + CheckedTS = check_class(S,TS), + asn1_db:dbput(S#state.mname,Name, + NewCDef#classdef{checked=true, + typespec=CheckedTS}), + CheckedTS + end; +check_class(S = #state{mname=M,tname=T},ClassSpec) + when record(ClassSpec,type) -> + Def = ClassSpec#type.def, + case Def of + #'Externaltypereference'{module=M,type=T} -> + #objectclass{fields=Def}; % in case of recursive definitions + Tref when record(Tref,'Externaltypereference') -> + {_,RefType} = get_referenced_type(S,Tref), +% case RefType of +% RefClass when record(RefClass,classdef) -> +% check_class(S,RefClass#classdef.typespec) +% end + case is_class(S,RefType) of + true -> + check_class(S,get_class_def(S,RefType)); + _ -> + error({class,{internal_error,RefType},S}) + end + end; +% check_class(S,{objectclassname,ModuleName,ClassName}) when atom(ModuleName),atom(ClassName) -> +% 'fix this'; +check_class(S,C) when record(C,objectclass) -> + NewFieldSpec = check_class_fields(S,C#objectclass.fields), + C#objectclass{fields=NewFieldSpec}; +%check_class(S,{objectclassname,ClassName}) -> +check_class(S,ClassName) -> + {_,Def} = get_referenced_type(S,ClassName), + case Def of + ClassDef when record(ClassDef,classdef) -> + case ClassDef#classdef.checked of + true -> + ClassDef#classdef.typespec; + idle -> + ClassDef#classdef.typespec; + false -> + check_class(S,ClassDef#classdef.typespec) + end; + TypeDef when record(TypeDef,typedef) -> + %% this case may occur when a definition is a reference + %% to a class definition. + case TypeDef#typedef.typespec of + #type{def=Ext} when record(Ext,'Externaltypereference') -> + check_class(S,Ext) + end + end; +check_class(_S,{poc,_ObjSet,_Params}) -> + 'fix this later'. + +check_class_fields(S,Fields) -> + check_class_fields(S,Fields,[]). + +check_class_fields(S,[F|Fields],Acc) -> + NewField = + case element(1,F) of + fixedtypevaluefield -> + {_,Name,Type,Unique,OSpec} = F, + RefType = check_type(S,#typedef{typespec=Type},Type), + {fixedtypevaluefield,Name,RefType,Unique,OSpec}; + object_or_fixedtypevalue_field -> + {_,Name,Type,Unique,OSpec} = F, + Cat = + case asn1ct_gen:type(asn1ct_gen:get_inner(Type#type.def)) of + Def when record(Def,typereference); + record(Def,'Externaltypereference') -> + {_,D} = get_referenced_type(S,Def), + D; + {undefined,user} -> + %% neither of {primitive,bif} or {constructed,bif} +%% {_,D} = get_referenced_type(S,#typereference{val=Type#type.def}), + {_,D} = get_referenced_type(S,#'Externaltypereference'{module=S#state.mname,type=Type#type.def}), + D; + _ -> + Type + end, + case Cat of + Class when record(Class,classdef) -> + {objectfield,Name,Type,Unique,OSpec}; + _ -> + RefType = check_type(S,#typedef{typespec=Type},Type), + {fixedtypevaluefield,Name,RefType,Unique,OSpec} + end; + objectset_or_fixedtypevalueset_field -> + {_,Name,Type,OSpec} = F, +%% RefType = check_type(S,#typedef{typespec=Type},Type), + RefType = + case (catch check_type(S,#typedef{typespec=Type},Type)) of + {asn1_class,_ClassDef} -> + case if_current_checked_type(S,Type) of + true -> + Type#type.def; + _ -> + check_class(S,Type) + end; + CheckedType when record(CheckedType,type) -> + CheckedType; + _ -> + error({class,"internal error, check_class_fields",S}) + end, + if + record(RefType,'Externaltypereference') -> + {objectsetfield,Name,Type,OSpec}; + record(RefType,classdef) -> + {objectsetfield,Name,Type,OSpec}; + record(RefType,objectclass) -> + {objectsetfield,Name,Type,OSpec}; + true -> + {fixedtypevaluesetfield,Name,RefType,OSpec} + end; + typefield -> + case F of + {TF,Name,{'DEFAULT',Type}} -> + {TF,Name,{'DEFAULT',check_type(S,#typedef{typespec=Type},Type)}}; + _ -> F + end; + _ -> F + end, + check_class_fields(S,Fields,[NewField|Acc]); +check_class_fields(_S,[],Acc) -> + lists:reverse(Acc). + +if_current_checked_type(S,#type{def=Def}) -> + CurrentCheckedName = S#state.tname, + MergedModules = S#state.inputmodules, + % CurrentCheckedModule = S#state.mname, + case Def of + #'Externaltypereference'{module=CurrentCheckedName, + type=CurrentCheckedName} -> + true; + #'Externaltypereference'{module=ModuleName, + type=CurrentCheckedName} -> + case MergedModules of + undefined -> + false; + _ -> + lists:member(ModuleName,MergedModules) + end; + _ -> + false + end. + + + +check_pobject(_S,PObject) when record(PObject,pobjectdef) -> + Def = PObject#pobjectdef.def, + Def. + + +check_pobjectset(S,PObjSet) -> + #pvaluesetdef{pos=Pos,name=Name,args=Args,type=Type, + valueset=ValueSet}=PObjSet, + {Mod,Def} = get_referenced_type(S,Type#type.def), + case Def of + #classdef{} -> + ClassName = #'Externaltypereference'{module=Mod, + type=Def#classdef.name}, + {valueset,Set} = ValueSet, +% ObjectSet = #'ObjectSet'{class={objectclassname,ClassName}, + ObjectSet = #'ObjectSet'{class=ClassName, + set=Set}, + #pobjectsetdef{pos=Pos,name=Name,args=Args,class=Type#type.def, + def=ObjectSet}; + _ -> + PObjSet + end. + +check_object(_S,ObjDef,ObjSpec) when (ObjDef#typedef.checked == true) -> + ObjSpec; +check_object(S,_ObjDef,#'Object'{classname=ClassRef,def=ObjectDef}) -> + {_,_ClassDef} = get_referenced_type(S,ClassRef), + NewClassRef = check_externaltypereference(S,ClassRef), + ClassDef = + case _ClassDef#classdef.checked of + false -> + #classdef{checked=true, + typespec=check_class(S,_ClassDef#classdef.typespec)}; + _ -> + _ClassDef + end, + NewObj = + case ObjectDef of + Def when tuple(Def), (element(1,Def)==object) -> + NewSettingList = check_objectdefn(S,Def,ClassDef), + #'Object'{def=NewSettingList}; +% Def when tuple(Def), (element(1,Def)=='ObjectFromObject') -> +% fixa; + {po,{object,DefObj},ArgsList} -> + {_,Object} = get_referenced_type(S,DefObj),%DefObj is a + %%#'Externalvaluereference' or a #'Externaltypereference' + %% Maybe this call should be catched and in case of an exception + %% an nonallocated parameterized object should be returned. + instantiate_po(S,ClassDef,Object,ArgsList); + #'Externalvaluereference'{} -> + {_,Object} = get_referenced_type(S,ObjectDef), + check_object(S,Object,Object#typedef.typespec); + _ -> + exit({error,{no_object,ObjectDef},S}) + end, + Gen = gen_incl(S,NewObj#'Object'.def, + (ClassDef#classdef.typespec)#objectclass.fields), + NewObj#'Object'{classname=NewClassRef,gen=Gen}; + +%%check_object(S,ObjSetDef,ObjSet=#type{def={pt,ObjSetRef,Args}}) -> + %% A parameterized + +check_object(S, + _ObjSetDef, + ObjSet=#'ObjectSet'{class=ClassRef}) -> + {_,ClassDef} = get_referenced_type(S,ClassRef), + NewClassRef = check_externaltypereference(S,ClassRef), + UniqueFieldName = + case (catch get_unique_fieldname(ClassDef)) of + {error,'__undefined_'} -> {unique,undefined}; + {asn1,Msg,_} -> error({class,Msg,S}); + Other -> Other + end, + NewObjSet= + case ObjSet#'ObjectSet'.set of + {'SingleValue',Set} when list(Set) -> + CheckedSet = check_object_list(S,NewClassRef,Set), + NewSet = get_unique_valuelist(S,CheckedSet,UniqueFieldName), + ObjSet#'ObjectSet'{uniquefname=UniqueFieldName, + set=NewSet}; + {'SingleValue',{definedvalue,ObjName}} -> + {_,ObjDef} = get_referenced_type(S,#identifier{val=ObjName}), + #'Object'{def=CheckedObj} = + check_object(S,ObjDef,ObjDef#typedef.typespec), + NewSet = get_unique_valuelist(S,[{ObjDef#typedef.name, + CheckedObj}], + UniqueFieldName), + ObjSet#'ObjectSet'{uniquefname=UniqueFieldName, + set=NewSet}; + {'SingleValue',#'Externalvaluereference'{value=ObjName}} -> + {_,ObjDef} = get_referenced_type(S,#identifier{val=ObjName}), + #'Object'{def=CheckedObj} = + check_object(S,ObjDef,ObjDef#typedef.typespec), + NewSet = get_unique_valuelist(S,[{ObjDef#typedef.name, + CheckedObj}], + UniqueFieldName), + ObjSet#'ObjectSet'{uniquefname=UniqueFieldName, + set=NewSet}; + ['EXTENSIONMARK'] -> + ObjSet#'ObjectSet'{uniquefname=UniqueFieldName, + set=['EXTENSIONMARK']}; + Set when list(Set) -> + CheckedSet = check_object_list(S,NewClassRef,Set), + NewSet = get_unique_valuelist(S,CheckedSet,UniqueFieldName), + ObjSet#'ObjectSet'{uniquefname=UniqueFieldName, + set=NewSet}; + {Set,Ext} when list(Set) -> + CheckedSet = check_object_list(S,NewClassRef,Set++Ext), + NewSet = get_unique_valuelist(S,CheckedSet,UniqueFieldName), + ObjSet#'ObjectSet'{uniquefname=UniqueFieldName, + set=NewSet++['EXTENSIONMARK']}; + {{'SingleValue',Set},Ext} -> + CheckedSet = check_object_list(S,NewClassRef, + merge_sets(Set,Ext)), + NewSet = get_unique_valuelist(S,CheckedSet,UniqueFieldName), + ObjSet#'ObjectSet'{uniquefname=UniqueFieldName, + set=NewSet++['EXTENSIONMARK']}; + {Type,{'EXCEPT',Exclusion}} when record(Type,type) -> + {_,TDef} = get_referenced_type(S,Type#type.def), + OS = TDef#typedef.typespec, + NewSet = reduce_objectset(OS#'ObjectSet'.set,Exclusion), + NewOS = OS#'ObjectSet'{set=NewSet}, + check_object(S,TDef#typedef{typespec=NewOS}, + NewOS); + #type{def={pt,DefinedObjSet,ParamList}} -> + {_,PObjSetDef} = get_referenced_type(S,DefinedObjSet), + instantiate_pos(S,ClassDef,PObjSetDef,ParamList); + {ObjDef={object,definedsyntax,_ObjFields},_Ext} -> + CheckedSet = check_object_list(S,NewClassRef,[ObjDef]), + NewSet = get_unique_valuelist(S,CheckedSet,UniqueFieldName), + ObjSet#'ObjectSet'{uniquefname=UniqueFieldName, + set=NewSet++['EXTENSIONMARK']} + end, + Gen = gen_incl_set(S,NewObjSet#'ObjectSet'.set, + ClassDef), + NewObjSet#'ObjectSet'{class=NewClassRef,gen=Gen}. + + +merge_sets(Set,Ext) when list(Set),list(Ext) -> + Set ++ Ext; +merge_sets(Set,Ext) when list(Ext) -> + [Set|Ext]; +merge_sets(Set,{'SingleValue',Ext}) when list(Set) -> + Set ++ [Ext]; +merge_sets(Set,{'SingleValue',Ext}) -> + [Set] ++ [Ext]. + +reduce_objectset(ObjectSet,Exclusion) -> + case Exclusion of + {'SingleValue',#'Externalvaluereference'{value=Name}} -> + case lists:keysearch(Name,1,ObjectSet) of + {value,El} -> + lists:subtract(ObjectSet,[El]); + _ -> + ObjectSet + end + end. + +%% Checks a list of objects or object sets and returns a list of selected +%% information for the code generation. +check_object_list(S,ClassRef,ObjectList) -> + check_object_list(S,ClassRef,ObjectList,[]). + +check_object_list(S,ClassRef,[ObjOrSet|Objs],Acc) -> + case ObjOrSet of + ObjDef when tuple(ObjDef),(element(1,ObjDef)==object) -> + Def = + check_object(S,#typedef{typespec=ObjDef}, +% #'Object'{classname={objectclassname,ClassRef}, + #'Object'{classname=ClassRef, + def=ObjDef}), + check_object_list(S,ClassRef,Objs,[{no_name,Def#'Object'.def}|Acc]); + {'SingleValue',{definedvalue,ObjName}} -> + {_,ObjectDef} = get_referenced_type(S,#identifier{val=ObjName}), + #'Object'{def=Def} = check_object(S,ObjectDef,ObjectDef#typedef.typespec), + check_object_list(S,ClassRef,Objs,[{ObjectDef#typedef.name,Def}|Acc]); + {'SingleValue',Ref = #'Externalvaluereference'{}} -> + {_,ObjectDef} = get_referenced_type(S,Ref), + #'Object'{def=Def} = check_object(S,ObjectDef,ObjectDef#typedef.typespec), + check_object_list(S,ClassRef,Objs,[{ObjectDef#typedef.name,Def}|Acc]); + ObjRef when record(ObjRef,'Externalvaluereference') -> + {_,ObjectDef} = get_referenced_type(S,ObjRef), + #'Object'{def=Def} = check_object(S,ObjectDef,ObjectDef#typedef.typespec), + check_object_list(S,ClassRef,Objs, +%% [{ObjRef#'Externalvaluereference'.value,Def}|Acc]); + [{ObjectDef#typedef.name,Def}|Acc]); + {'ValueFromObject',{_,Object},FieldName} -> + {_,Def} = get_referenced_type(S,Object), +%% TypeOrVal = get_fieldname_element(S,Def,FieldName);%% this must result in an object set + TypeDef = get_fieldname_element(S,Def,FieldName), + (TypeDef#typedef.typespec)#'ObjectSet'.set; + ObjSet when record(ObjSet,type) -> + ObjSetDef = + case ObjSet#type.def of + Ref when record(Ref,typereference); + record(Ref,'Externaltypereference') -> + {_,D} = get_referenced_type(S,ObjSet#type.def), + D; + Other -> + throw({asn1_error,{'unknown objecset',Other,S}}) + end, + #'ObjectSet'{set=ObjectsInSet} = + check_object(S,ObjSetDef,ObjSetDef#typedef.typespec), + AccList = transform_set_to_object_list(ObjectsInSet,[]), + check_object_list(S,ClassRef,Objs,AccList++Acc); + union -> + check_object_list(S,ClassRef,Objs,Acc); + Other -> + exit({error,{'unknown object',Other},S}) + end; +%% Finally reverse the accumulated list and if there are any extension +%% marks in the object set put one indicator of that in the end of the +%% list. +check_object_list(_,_,[],Acc) -> + lists:reverse(Acc). +%% case lists:member('EXTENSIONMARK',RevAcc) of +%% true -> +%% ExclRevAcc = lists:filter(fun(X)->X /= 'EXTENSIONMARK' end, +%% RevAcc), +%% ExclRevAcc ++ ['EXTENSIONMARK']; +%% false -> +%% RevAcc +%% end. + + +%% get_fieldname_element/3 +%% gets the type/value/object/... of the referenced element in FieldName +%% FieldName is a list and may have more than one element. +%% Each element in FieldName can be either {typefieldreference,AnyFieldName} +%% or {valuefieldreference,AnyFieldName} +%% Def is the def of the first object referenced by FieldName +get_fieldname_element(S,Def,[{_RefType,FieldName}]) when record(Def,typedef) -> + {_,_,ObjComps} = (Def#typedef.typespec)#'Object'.def, + case lists:keysearch(FieldName,1,ObjComps) of + {value,{_,TDef}} when record(TDef,typedef) -> + %% ORec = TDef#typedef.typespec, %% XXX This must be made general +% case TDef#typedef.typespec of +% ObjSetRec when record(ObjSetRec,'ObjectSet') -> +% ObjSet = ObjSetRec#'ObjectSet'.set; +% ObjRec when record(ObjRec,'Object') -> +% %% now get the field in ObjRec that RestFName points out +% %ObjRec +% TDef +% end; + TDef; + {value,{_,VDef}} when record(VDef,valuedef) -> + check_value(S,VDef); + _ -> + throw({assigned_object_error,"not_assigned_object",S}) + end; +get_fieldname_element(_S,Def,[{_RefType,_FieldName}|_RestFName]) + when record(Def,typedef) -> + ok. + +transform_set_to_object_list([{Name,_UVal,Fields}|Objs],Acc) -> + transform_set_to_object_list(Objs,[{Name,{object,generatesyntax,Fields}}|Acc]); +transform_set_to_object_list(['EXTENSIONMARK'|Objs],Acc) -> +%% transform_set_to_object_list(Objs,['EXTENSIONMARK'|Acc]); + transform_set_to_object_list(Objs,Acc); +transform_set_to_object_list([],Acc) -> + Acc. + +get_unique_valuelist(_S,ObjSet,{unique,undefined}) -> % no unique field in object + lists:map(fun({N,{_,_,F}})->{N,F}; + (V={_,_,_}) ->V end, ObjSet); +get_unique_valuelist(S,ObjSet,UFN) -> + get_unique_vlist(S,ObjSet,UFN,[]). + +get_unique_vlist(S,[],_,Acc) -> + case catch check_uniqueness(Acc) of + {asn1_error,_} -> +% exit({error,Reason,S}); + error({'ObjectSet',"not unique objects in object set",S}); + true -> + lists:reverse(Acc) + end; +get_unique_vlist(S,[{ObjName,Obj}|Rest],UniqueFieldName,Acc) -> + {_,_,Fields} = Obj, + VDef = get_unique_value(S,Fields,UniqueFieldName), + get_unique_vlist(S,Rest,UniqueFieldName, + [{ObjName,VDef#valuedef.value,Fields}|Acc]); +get_unique_vlist(S,[V={_,_,_}|Rest],UniqueFieldName,Acc) -> + get_unique_vlist(S,Rest,UniqueFieldName,[V|Acc]). + +get_unique_value(S,Fields,UniqueFieldName) -> + Module = S#state.mname, + case lists:keysearch(UniqueFieldName,1,Fields) of + {value,Field} -> + case element(2,Field) of + VDef when record(VDef,valuedef) -> + VDef; + {definedvalue,ValName} -> + ValueDef = asn1_db:dbget(Module,ValName), + case ValueDef of + VDef when record(VDef,valuedef) -> + ValueDef; + undefined -> + #valuedef{value=ValName} + end; + {'ValueFromObject',Object,Name} -> + case Object of + {object,Ext} when record(Ext,'Externaltypereference') -> + OtherModule = Ext#'Externaltypereference'.module, + ExtObjName = Ext#'Externaltypereference'.type, + ObjDef = asn1_db:dbget(OtherModule,ExtObjName), + ObjSpec = ObjDef#typedef.typespec, + get_unique_value(OtherModule,element(3,ObjSpec),Name); + {object,{_,_,ObjName}} -> + ObjDef = asn1_db:dbget(Module,ObjName), + ObjSpec = ObjDef#typedef.typespec, + get_unique_value(Module,element(3,ObjSpec),Name); + {po,Object,_Params} -> + exit({error,{'parameterized object not implemented yet', + Object},S}) + end; + Value when atom(Value);number(Value) -> + #valuedef{value=Value}; + {'CHOICE',{_,Value}} when atom(Value);number(Value) -> + #valuedef{value=Value} + end; + false -> + exit({error,{'no unique value',Fields,UniqueFieldName},S}) +%% io:format("WARNING: no unique value in object"), +%% exit(uniqueFieldName) + end. + +check_uniqueness(NameValueList) -> + check_uniqueness1(lists:keysort(2,NameValueList)). + +check_uniqueness1([]) -> + true; +check_uniqueness1([_]) -> + true; +check_uniqueness1([{_,N,_},{_,N,_}|_Rest]) -> + throw({asn1_error,{'objects in set must have unique values in UNIQUE fields',N}}); +check_uniqueness1([_|Rest]) -> + check_uniqueness1(Rest). + +%% instantiate_po/4 +%% ClassDef is the class of Object, +%% Object is the Parameterized object, which is referenced, +%% ArgsList is the list of actual parameters +%% returns an #'Object' record. +instantiate_po(S,_ClassDef,Object,ArgsList) when record(Object,pobjectdef) -> + FormalParams = get_pt_args(Object), + MatchedArgs = match_args(FormalParams,ArgsList,[]), + NewS = S#state{type=Object,parameters=MatchedArgs}, + check_object(NewS,Object,#'Object'{classname=Object#pobjectdef.class, + def=Object#pobjectdef.def}). + +%% instantiate_pos/4 +%% ClassDef is the class of ObjectSetDef, +%% ObjectSetDef is the Parameterized object set, which is referenced +%% on the right side of the assignment, +%% ArgsList is the list of actual parameters, i.e. real objects +instantiate_pos(S,ClassDef,ObjectSetDef,ArgsList) -> + ClassName = ClassDef#classdef.name, + FormalParams = get_pt_args(ObjectSetDef), + Set = case get_pt_spec(ObjectSetDef) of + {valueset,_Set} -> _Set; + _Set -> _Set + end, + MatchedArgs = match_args(FormalParams,ArgsList,[]), + NewS = S#state{type=ObjectSetDef,parameters=MatchedArgs}, + check_object(NewS,ObjectSetDef, + #'ObjectSet'{class=name2Extref(S#state.mname,ClassName), + set=Set}). + + +%% gen_incl -> boolean() +%% If object with Fields has any of the corresponding class' typefields +%% then return value is true otherwise it is false. +%% If an object lacks a typefield but the class has a type field that +%% is OPTIONAL then we want gen to be true +gen_incl(S,{_,_,Fields},CFields)-> + gen_incl1(S,Fields,CFields). + +gen_incl1(_,_,[]) -> + false; +gen_incl1(S,Fields,[C|CFields]) -> + case element(1,C) of + typefield -> +% case lists:keymember(element(2,C),1,Fields) of +% true -> +% true; +% false -> +% gen_incl1(S,Fields,CFields) +% end; + true; %% should check that field is OPTIONAL or DEFUALT if + %% the object lacks this field + objectfield -> + case lists:keysearch(element(2,C),1,Fields) of + {value,Field} -> + Type = element(3,C), + {_,ClassDef} = get_referenced_type(S,Type#type.def), +% {_,ClassFields,_} = ClassDef#classdef.typespec, + #objectclass{fields=ClassFields} = + ClassDef#classdef.typespec, + ObjTDef = element(2,Field), + case gen_incl(S,(ObjTDef#typedef.typespec)#'Object'.def, + ClassFields) of + true -> + true; + _ -> + gen_incl1(S,Fields,CFields) + end; + _ -> + gen_incl1(S,Fields,CFields) + end; + _ -> + gen_incl1(S,Fields,CFields) + end. + +%% first if no unique field in the class return false.(don't generate code) +gen_incl_set(S,Fields,ClassDef) -> + case catch get_unique_fieldname(ClassDef) of + Tuple when tuple(Tuple) -> + false; + _ -> + gen_incl_set1(S,Fields, + (ClassDef#classdef.typespec)#objectclass.fields) + end. + +%% if any of the existing or potentially existing objects has a typefield +%% then return true. +gen_incl_set1(_,[],_CFields)-> + false; +gen_incl_set1(_,['EXTENSIONMARK'],_) -> + true; +%% Fields are the fields of an object in the object set. +%% CFields are the fields of the class of the object set. +gen_incl_set1(S,[Object|Rest],CFields)-> + Fields = element(size(Object),Object), + case gen_incl1(S,Fields,CFields) of + true -> + true; + false -> + gen_incl_set1(S,Rest,CFields) + end. + +check_objectdefn(S,Def,CDef) when record(CDef,classdef) -> + WithSyntax = (CDef#classdef.typespec)#objectclass.syntax, + ClassFields = (CDef#classdef.typespec)#objectclass.fields, + case Def of + {object,defaultsyntax,Fields} -> + check_defaultfields(S,Fields,ClassFields); + {object,definedsyntax,Fields} -> + {_,WSSpec} = WithSyntax, + NewFields = + case catch( convert_definedsyntax(S,Fields,WSSpec, + ClassFields,[])) of + {asn1,{_ErrorType,ObjToken,ClassToken}} -> + throw({asn1,{'match error in object',ObjToken, + 'found in object',ClassToken,'found in class'}}); + Err={asn1,_} -> throw(Err); + Err={'EXIT',_} -> throw(Err); + DefaultFields when list(DefaultFields) -> + DefaultFields + end, + {object,defaultsyntax,NewFields}; + {object,_ObjectId} -> % This is a DefinedObject + fixa; + Other -> + exit({error,{objectdefn,Other}}) + end. + +check_defaultfields(S,Fields,ClassFields) -> + check_defaultfields(S,Fields,ClassFields,[]). + +check_defaultfields(_S,[],_ClassFields,Acc) -> + {object,defaultsyntax,lists:reverse(Acc)}; +check_defaultfields(S,[{FName,Spec}|Fields],ClassFields,Acc) -> + case lists:keysearch(FName,2,ClassFields) of + {value,CField} -> + NewField = convert_to_defaultfield(S,FName,Spec,CField), + check_defaultfields(S,Fields,ClassFields,[NewField|Acc]); + _ -> + throw({error,{asn1,{'unvalid field in object',FName}}}) + end. +%% {object,defaultsyntax,Fields}. + +convert_definedsyntax(_S,[],[],_ClassFields,Acc) -> + lists:reverse(Acc); +convert_definedsyntax(S,Fields,WithSyntax,ClassFields,Acc) -> + case match_field(S,Fields,WithSyntax,ClassFields) of + {MatchedField,RestFields,RestWS} -> + if + list(MatchedField) -> + convert_definedsyntax(S,RestFields,RestWS,ClassFields, + lists:append(MatchedField,Acc)); + true -> + convert_definedsyntax(S,RestFields,RestWS,ClassFields, + [MatchedField|Acc]) + end +%% throw({error,{asn1,{'unvalid syntax in object',WorS}}}) + end. + +match_field(S,Fields,WithSyntax,ClassFields) -> + match_field(S,Fields,WithSyntax,ClassFields,[]). + +match_field(S,Fields,[W|Ws],ClassFields,Acc) when list(W) -> + case catch(match_optional_field(S,Fields,W,ClassFields,[])) of + {'EXIT',_} -> + match_field(Fields,Ws,ClassFields,Acc); %% add S +%% {[Result],RestFields} -> +%% {Result,RestFields,Ws}; + {Result,RestFields} when list(Result) -> + {Result,RestFields,Ws}; + _ -> + match_field(S,Fields,Ws,ClassFields,Acc) + end; +match_field(S,Fields,WithSyntax,ClassFields,_Acc) -> + match_mandatory_field(S,Fields,WithSyntax,ClassFields,[]). + +match_optional_field(_S,RestFields,[],_,Ret) -> + {Ret,RestFields}; +%% An additional optional field within an optional field +match_optional_field(S,Fields,[W|Ws],ClassFields,Ret) when list(W) -> + case catch match_optional_field(S,Fields,W,ClassFields,[]) of + {'EXIT',_} -> + {Ret,Fields}; + {asn1,{optional_matcherror,_,_}} -> + {Ret,Fields}; + {OptionalField,RestFields} -> + match_optional_field(S,RestFields,Ws,ClassFields, + lists:append(OptionalField,Ret)) + end; +%% identify and skip word +%match_optional_field(S,[#'Externaltypereference'{type=WorS}|Rest], +match_optional_field(S,[{_,_,WorS}|Rest], + [WorS|Ws],ClassFields,Ret) -> + match_optional_field(S,Rest,Ws,ClassFields,Ret); +match_optional_field(S,[],_,ClassFields,Ret) -> + match_optional_field(S,[],[],ClassFields,Ret); +%% identify and skip comma +match_optional_field(S,[{WorS,_}|Rest],[{WorS,_}|Ws],ClassFields,Ret) -> + match_optional_field(S,Rest,Ws,ClassFields,Ret); +%% identify and save field data +match_optional_field(S,[Setting|Rest],[{_,W}|Ws],ClassFields,Ret) -> + WorS = + case Setting of + Type when record(Type,type) -> Type; +%% #'Externalvaluereference'{value=WordOrSetting} -> WordOrSetting; + {'ValueFromObject',_,_} -> Setting; + {object,_,_} -> Setting; + {_,_,WordOrSetting} -> WordOrSetting; +%% Atom when atom(Atom) -> Atom + Other -> Other + end, + case lists:keysearch(W,2,ClassFields) of + false -> + throw({asn1,{optional_matcherror,WorS,W}}); + {value,CField} -> + NewField = convert_to_defaultfield(S,W,WorS,CField), + match_optional_field(S,Rest,Ws,ClassFields,[NewField|Ret]) + end; +match_optional_field(_S,[WorS|_Rest],[W|_Ws],_ClassFields,_Ret) -> + throw({asn1,{optional_matcherror,WorS,W}}). + +match_mandatory_field(_S,[],[],_,[Acc]) -> + {Acc,[],[]}; +match_mandatory_field(_S,[],[],_,Acc) -> + {Acc,[],[]}; +match_mandatory_field(S,[],[H|T],CF,Acc) when list(H) -> + match_mandatory_field(S,[],T,CF,Acc); +match_mandatory_field(_S,[],WithSyntax,_,_Acc) -> + throw({asn1,{mandatory_matcherror,[],WithSyntax}}); +%match_mandatory_field(_S,Fields,WithSyntax=[W|_Ws],_ClassFields,[Acc]) when list(W) -> +match_mandatory_field(_S,Fields,WithSyntax=[W|_Ws],_ClassFields,Acc) when list(W), length(Acc) >= 1 -> + {Acc,Fields,WithSyntax}; +%% identify and skip word +match_mandatory_field(S,[{_,_,WorS}|Rest], + [WorS|Ws],ClassFields,Acc) -> + match_mandatory_field(S,Rest,Ws,ClassFields,Acc); +%% identify and skip comma +match_mandatory_field(S,[{WorS,_}|Rest],[{WorS,_}|Ws],ClassFields,Ret) -> + match_mandatory_field(S,Rest,Ws,ClassFields,Ret); +%% identify and save field data +match_mandatory_field(S,[Setting|Rest],[{_,W}|Ws],ClassFields,Acc) -> + WorS = + case Setting of +%% Atom when atom(Atom) -> Atom; +%% #'Externalvaluereference'{value=WordOrSetting} -> WordOrSetting; + {object,_,_} -> Setting; + {_,_,WordOrSetting} -> WordOrSetting; + Type when record(Type,type) -> Type; + Other -> Other + end, + case lists:keysearch(W,2,ClassFields) of + false -> + throw({asn1,{mandatory_matcherror,WorS,W}}); + {value,CField} -> + NewField = convert_to_defaultfield(S,W,WorS,CField), + match_mandatory_field(S,Rest,Ws,ClassFields,[NewField|Acc]) + end; + +match_mandatory_field(_S,[WorS|_Rest],[W|_Ws],_ClassFields,_Acc) -> + throw({asn1,{mandatory_matcherror,WorS,W}}). + +%% Converts a field of an object from defined syntax to default syntax +convert_to_defaultfield(S,ObjFieldName,ObjFieldSetting,CField)-> + CurrMod = S#state.mname, + case element(1,CField) of + typefield -> + TypeDef= + case ObjFieldSetting of + TypeRec when record(TypeRec,type) -> TypeRec#type.def; + TDef when record(TDef,typedef) -> + TDef#typedef{typespec=check_type(S,TDef, + TDef#typedef.typespec)}; + _ -> ObjFieldSetting + end, + Type = + if + record(TypeDef,typedef) -> TypeDef; + true -> + case asn1ct_gen:type(asn1ct_gen:get_inner(TypeDef)) of + ERef = #'Externaltypereference'{module=CurrMod} -> + {_,T} = get_referenced_type(S,ERef), + T#typedef{checked=true, + typespec=check_type(S,T, + T#typedef.typespec)}; + ERef = #'Externaltypereference'{module=ExtMod} -> + {_,T} = get_referenced_type(S,ERef), + #typedef{name=Name} = T, + check_type(S,T,T#typedef.typespec), + #typedef{checked=true, + name={ExtMod,Name}, + typespec=ERef}; + Bif when Bif=={primitive,bif};Bif=={constructed,bif} -> + T = check_type(S,#typedef{typespec=ObjFieldSetting}, + ObjFieldSetting), + #typedef{checked=true,name=Bif,typespec=T}; + _ -> + {Mod,T} = + %% get_referenced_type(S,#typereference{val=ObjFieldSetting}), + get_referenced_type(S,#'Externaltypereference'{module=S#state.mname,type=ObjFieldSetting}), + case Mod of + CurrMod -> + T; + ExtMod -> + #typedef{name=Name} = T, + T#typedef{name={ExtMod,Name}} + end + end + end, + {ObjFieldName,Type}; + fixedtypevaluefield -> + case ObjFieldName of + Val when atom(Val) -> + %% ObjFieldSetting can be a value,an objectidentifiervalue, + %% an element in an enumeration or namednumberlist etc. + ValRef = + case ObjFieldSetting of + #'Externalvaluereference'{} -> ObjFieldSetting; + {'ValueFromObject',{_,ObjRef},FieldName} -> + {_,Object} = get_referenced_type(S,ObjRef), + ChObject = check_object(S,Object, + Object#typedef.typespec), + get_fieldname_element(S,Object#typedef{typespec=ChObject}, + FieldName); + #valuedef{} -> + ObjFieldSetting; + _ -> + #identifier{val=ObjFieldSetting} + end, + case ValRef of + #valuedef{} -> + {ObjFieldName,check_value(S,ValRef)}; + _ -> + ValDef = + case catch get_referenced_type(S,ValRef) of + {error,_} -> + check_value(S,#valuedef{name=Val, + type=element(3,CField), + value=ObjFieldSetting}); + {_,VDef} when record(VDef,valuedef) -> + check_value(S,VDef);%% XXX + {_,VDef} -> + check_value(S,#valuedef{name=Val, + type=element(3,CField), + value=VDef}) + end, + {ObjFieldName,ValDef} + end; + Val -> + {ObjFieldName,Val} + end; + fixedtypevaluesetfield -> + {ObjFieldName,ObjFieldSetting}; + objectfield -> + ObjectSpec = + case ObjFieldSetting of + Ref when record(Ref,typereference);record(Ref,identifier); + record(Ref,'Externaltypereference'); + record(Ref,'Externalvaluereference') -> + {_,R} = get_referenced_type(S,ObjFieldSetting), + R; + {'ValueFromObject',{_,ObjRef},FieldName} -> + %% This is an ObjectFromObject + {_,Object} = get_referenced_type(S,ObjRef), + ChObject = check_object(S,Object, + Object#typedef.typespec), + _ObjFromObj= + get_fieldname_element(S,Object#typedef{ + typespec=ChObject}, + FieldName); + %%ClassName = ObjFromObj#'Object'.classname, + %%#typedef{name=, + %% typespec= + %% ObjFromObj#'Object'{classname= + %% {objectclassname,ClassName}}}; + {object,_,_} -> + %% An object defined inlined in another object + #type{def=Ref} = element(3,CField), +% CRef = case Ref of +% #'Externaltypereference'{module=CurrMod, +% type=CName} -> +% CName; +% #'Externaltypereference'{module=ExtMod, +% type=CName} -> +% {ExtMod,CName} +% end, + InlinedObjName= + list_to_atom(lists:concat([S#state.tname]++ + ['_',ObjFieldName])), +% ObjSpec = #'Object'{classname={objectclassname,CRef}, + ObjSpec = #'Object'{classname=Ref, + def=ObjFieldSetting}, + CheckedObj= + check_object(S,#typedef{typespec=ObjSpec},ObjSpec), + InlObj = #typedef{checked=true,name=InlinedObjName, + typespec=CheckedObj}, + asn1ct_gen:insert_once(inlined_objects,{InlinedObjName, + InlinedObjName}), + asn1_db:dbput(S#state.mname,InlinedObjName,InlObj), + InlObj; + #type{def=Eref} when record(Eref,'Externaltypereference') -> + {_,R} = get_referenced_type(S,Eref), + R; + _ -> +%% {_,R} = get_referenced_type(S,#typereference{val=ObjFieldSetting}), + {_,R} = get_referenced_type(S,#'Externaltypereference'{module=S#state.mname,type=ObjFieldSetting}), + R + end, + {ObjFieldName, + ObjectSpec#typedef{checked=true, + typespec=check_object(S,ObjectSpec, + ObjectSpec#typedef.typespec)}}; + variabletypevaluefield -> + {ObjFieldName,ObjFieldSetting}; + variabletypevaluesetfield -> + {ObjFieldName,ObjFieldSetting}; + objectsetfield -> + {_,ObjSetSpec} = + case ObjFieldSetting of + Ref when record(Ref,'Externaltypereference'); + record(Ref,'Externalvaluereference') -> + get_referenced_type(S,ObjFieldSetting); + ObjectList when list(ObjectList) -> + %% an objctset defined in the object,though maybe + %% parsed as a SequenceOfValue + %% The ObjectList may be a list of references to + %% objects, a ValueFromObject + {_,_,Type,_} = CField, + ClassDef = Type#type.def, + case ClassDef#'Externaltypereference'.module of + CurrMod -> + ClassDef#'Externaltypereference'.type; + ExtMod -> + {ExtMod, + ClassDef#'Externaltypereference'.type} + end, + {no_name, + #typedef{typespec= + #'ObjectSet'{class= +% {objectclassname,ClassRef}, + ClassDef, + set=ObjectList}}}; + ObjectSet={'SingleValue',_} -> + %% a Union of defined objects + {_,_,Type,_} = CField, + ClassDef = Type#type.def, +% ClassRef = +% case ClassDef#'Externaltypereference'.module of +% CurrMod -> +% ClassDef#'Externaltypereference'.type; +% ExtMod -> +% {ExtMod, +% ClassDef#'Externaltypereference'.type} +% end, + {no_name, +% #typedef{typespec=#'ObjectSet'{class={objectclassname,ClassRef}, + #typedef{typespec=#'ObjectSet'{class=ClassDef, + set=ObjectSet}}}; + {object,_,[#type{def={'TypeFromObject', + {object,RefedObj}, + FieldName}}]} -> + %% This case occurs when an ObjectSetFromObjects + %% production is used + {M,Def} = get_referenced_type(S,RefedObj), + {M,get_fieldname_element(S,Def,FieldName)}; + #type{def=Eref} when + record(Eref,'Externaltypereference') -> + get_referenced_type(S,Eref); + _ -> +%% get_referenced_type(S,#typereference{val=ObjFieldSetting}) + get_referenced_type(S,#'Externaltypereference'{module=S#state.mname,type=ObjFieldSetting}) + end, + {ObjFieldName, + ObjSetSpec#typedef{checked=true, + typespec=check_object(S,ObjSetSpec, + ObjSetSpec#typedef.typespec)}} + end. + +check_value(OldS,V) when record(V,pvaluesetdef) -> + #pvaluesetdef{checked=Checked,type=Type} = V, + case Checked of + true -> V; + {error,_} -> V; + false -> + case get_referenced_type(OldS,Type#type.def) of + {_,Class} when record(Class,classdef) -> + throw({pobjectsetdef}); + _ -> continue + end + end; +check_value(_OldS,V) when record(V,pvaluedef) -> + %% Fix this case later + V; +check_value(OldS,V) when record(V,typedef) -> + %% This case when a value set has been parsed as an object set. + %% It may be a value set + #typedef{typespec=TS} = V, + case TS of + #'ObjectSet'{class=ClassRef} -> + {_,TSDef} = get_referenced_type(OldS,ClassRef), + %%IsObjectSet(TSDef); + case TSDef of + #classdef{} -> throw({objectsetdef}); + #typedef{typespec=#type{def=Eref}} when + record(Eref,'Externaltypereference') -> + %% This case if the class reference is a defined + %% reference to class + check_value(OldS,V#typedef{typespec=TS#'ObjectSet'{class=Eref}}); + #typedef{} -> + % an ordinary value set with a type in #typedef.typespec + ValueSet = TS#'ObjectSet'.set, + Type=check_type(OldS,TSDef,TSDef#typedef.typespec), + Value = check_value(OldS,#valuedef{type=Type, + value=ValueSet}), + {valueset,Type#type{constraint=Value#valuedef.value}} + end; + _ -> + throw({objectsetdef}) + end; +check_value(S,#valuedef{pos=Pos,name=Name,type=Type, + value={valueset,Constr}}) -> + NewType = Type#type{constraint=[Constr]}, + {valueset, + check_type(S,#typedef{pos=Pos,name=Name,typespec=NewType},NewType)}; +check_value(OldS=#state{recordtopname=TopName},V) when record(V,valuedef) -> + #valuedef{name=Name,checked=Checked,type=Vtype,value=Value} = V, + case Checked of + true -> + V; + {error,_} -> + V; + false -> + Def = Vtype#type.def, + Constr = Vtype#type.constraint, + S = OldS#state{type=Vtype,tname=Def,value=V,vname=Name}, + NewDef = + case Def of + Ext when record(Ext,'Externaltypereference') -> + RecName = Ext#'Externaltypereference'.type, + {_,Type} = get_referenced_type(S,Ext), + %% If V isn't a value but an object Type is a #classdef{} + case Type of + #classdef{} -> + throw({objectdef}); + #typedef{} -> + case is_contextswitchtype(Type) of + true -> + #valuedef{value=CheckedVal}= + check_value(S,V#valuedef{type=Type#typedef.typespec}), + #newv{value=CheckedVal}; + _ -> + #valuedef{value=CheckedVal}= + check_value(S#state{recordtopname=[RecName|TopName]}, + V#valuedef{type=Type#typedef.typespec}), + #newv{value=CheckedVal} + end + end; + 'ANY' -> + throw({error,{asn1,{'cant check value of type',Def}}}); + 'INTEGER' -> + validate_integer(S,Value,[],Constr), + #newv{value=normalize_value(S,Vtype,Value,[])}; + {'INTEGER',NamedNumberList} -> + validate_integer(S,Value,NamedNumberList,Constr), + #newv{value=normalize_value(S,Vtype,Value,[])}; + {'BIT STRING',NamedNumberList} -> + validate_bitstring(S,Value,NamedNumberList,Constr), + #newv{value=normalize_value(S,Vtype,Value,[])}; + 'NULL' -> + validate_null(S,Value,Constr), + #newv{}; + 'OBJECT IDENTIFIER' -> + validate_objectidentifier(S,Value,Constr), + #newv{value = normalize_value(S,Vtype,Value,[])}; + 'ObjectDescriptor' -> + validate_objectdescriptor(S,Value,Constr), + #newv{value=normalize_value(S,Vtype,Value,[])}; + {'ENUMERATED',NamedNumberList} -> + validate_enumerated(S,Value,NamedNumberList,Constr), + #newv{value=normalize_value(S,Vtype,Value,[])}; + 'BOOLEAN'-> + validate_boolean(S,Value,Constr), + #newv{value=normalize_value(S,Vtype,Value,[])}; + 'OCTET STRING' -> + validate_octetstring(S,Value,Constr), + #newv{value=normalize_value(S,Vtype,Value,[])}; + 'NumericString' -> + validate_restrictedstring(S,Value,Def,Constr), + #newv{value=normalize_value(S,Vtype,Value,[])}; + 'TeletexString' -> + validate_restrictedstring(S,Value,Def,Constr), + #newv{value=normalize_value(S,Vtype,Value,[])}; + 'VideotexString' -> + validate_restrictedstring(S,Value,Def,Constr), + #newv{value=normalize_value(S,Vtype,Value,[])}; + 'UTCTime' -> + #newv{value=normalize_value(S,Vtype,Value,[])}; +% exit({'cant check value of type' ,Def}); + 'GeneralizedTime' -> + #newv{value=normalize_value(S,Vtype,Value,[])}; +% exit({'cant check value of type' ,Def}); + 'GraphicString' -> + validate_restrictedstring(S,Value,Def,Constr), + #newv{value=normalize_value(S,Vtype,Value,[])}; + 'VisibleString' -> + validate_restrictedstring(S,Value,Def,Constr), + #newv{value=normalize_value(S,Vtype,Value,[])}; + 'GeneralString' -> + validate_restrictedstring(S,Value,Def,Constr), + #newv{value=normalize_value(S,Vtype,Value,[])}; + 'PrintableString' -> + validate_restrictedstring(S,Value,Def,Constr), + #newv{value=normalize_value(S,Vtype,Value,[])}; + 'IA5String' -> + validate_restrictedstring(S,Value,Def,Constr), + #newv{value=normalize_value(S,Vtype,Value,[])}; + 'BMPString' -> + validate_restrictedstring(S,Value,Def,Constr), + #newv{value=normalize_value(S,Vtype,Value,[])}; +%% 'UniversalString' -> %added 6/12 -00 +%% #newv{value=validate_restrictedstring(S,Value,Def,Constr)}; + Seq when record(Seq,'SEQUENCE') -> + SeqVal = validate_sequence(S,Value, + Seq#'SEQUENCE'.components, + Constr), + #newv{value=normalize_value(S,Vtype,SeqVal,TopName)}; + {'SEQUENCE OF',Components} -> + validate_sequenceof(S,Value,Components,Constr), + #newv{value=normalize_value(S,Vtype,Value,TopName)}; + {'CHOICE',Components} -> + validate_choice(S,Value,Components,Constr), + #newv{value=normalize_value(S,Vtype,Value,TopName)}; + Set when record(Set,'SET') -> + validate_set(S,Value,Set#'SET'.components, + Constr), + #newv{value=normalize_value(S,Vtype,Value,TopName)}; + {'SET OF',Components} -> + validate_setof(S,Value,Components,Constr), + #newv{value=normalize_value(S,Vtype,Value,TopName)}; + Other -> + exit({'cant check value of type' ,Other}) + end, + case NewDef#newv.value of + unchanged -> + V#valuedef{checked=true,value=Value}; + ok -> + V#valuedef{checked=true,value=Value}; + {error,Reason} -> + V#valuedef{checked={error,Reason},value=Value}; + _V -> + V#valuedef{checked=true,value=_V} + end + end. + +is_contextswitchtype(#typedef{name='EXTERNAL'})-> + true; +is_contextswitchtype(#typedef{name='EMBEDDED PDV'}) -> + true; +is_contextswitchtype(#typedef{name='CHARACTER STRING'}) -> + true; +is_contextswitchtype(_) -> + false. + +% validate_integer(S,{identifier,Pos,Id},NamedNumberList,Constr) -> +% case lists:keysearch(Id,1,NamedNumberList) of +% {value,_} -> ok; +% false -> error({value,"unknown NamedNumber",S}) +% end; +%% This case occurs when there is a valuereference +validate_integer(S=#state{mname=M}, + #'Externalvaluereference'{module=M,value=Id}, + NamedNumberList,_Constr) -> + case lists:keysearch(Id,1,NamedNumberList) of + {value,_} -> ok; + false -> error({value,"unknown NamedNumber",S}) + end; +validate_integer(S,Id,NamedNumberList,_Constr) when atom(Id) -> + case lists:keysearch(Id,1,NamedNumberList) of + {value,_} -> ok; + false -> error({value,"unknown NamedNumber",S}) + end; +validate_integer(_S,Value,_NamedNumberList,Constr) when integer(Value) -> + check_integer_range(Value,Constr). + +check_integer_range(Int,Constr) when list(Constr) -> + NewConstr = [X || #constraint{c=X} <- Constr], + check_constr(Int,NewConstr); + +check_integer_range(_Int,_Constr) -> + %%io:format("~p~n",[Constr]), + ok. + +check_constr(Int,[{'ValueRange',Lb,Ub}|T]) when Int >= Lb, Int =< Ub -> + check_constr(Int,T); +check_constr(_Int,[]) -> + ok. + +validate_bitstring(_S,_Value,_NamedNumberList,_Constr) -> + ok. + +validate_null(_S,'NULL',_Constr) -> + ok. + +%%------------ +%% This can be removed when the old parser is removed +%% The function removes 'space' atoms from the list + +is_space_list([H],Acc) -> + lists:reverse([H|Acc]); +is_space_list([H,space|T],Acc) -> + is_space_list(T,[H|Acc]); +is_space_list([],Acc) -> + lists:reverse(Acc); +is_space_list([H|T],Acc) -> + is_space_list(T,[H|Acc]). + +validate_objectidentifier(S,L,_) -> + case is_space_list(L,[]) of + NewL when list(NewL) -> + case validate_objectidentifier1(S,NewL) of + NewL2 when list(NewL2) -> + list_to_tuple(NewL2); + Other -> Other + end; + {error,_} -> + error({value, "illegal OBJECT IDENTIFIER", S}) + end. + +validate_objectidentifier1(S, [Id|T]) when record(Id,'Externalvaluereference') -> + case catch get_referenced_type(S,Id) of + {_,V} when record(V,valuedef) -> + case check_value(S,V) of + #valuedef{type=#type{def='OBJECT IDENTIFIER'}, + checked=true,value=Value} when tuple(Value) -> + validate_objectid(S, T, lists:reverse(tuple_to_list(Value))); + _ -> + error({value, "illegal OBJECT IDENTIFIER", S}) + end; + _ -> + validate_objectid(S, [Id|T], []) + end; +validate_objectidentifier1(S,V) -> + validate_objectid(S,V,[]). + +validate_objectid(_, [], Acc) -> + lists:reverse(Acc); +validate_objectid(S, [Value|Vrest], Acc) when integer(Value) -> + validate_objectid(S, Vrest, [Value|Acc]); +validate_objectid(S, [{'NamedNumber',_Name,Value}|Vrest], Acc) + when integer(Value) -> + validate_objectid(S, Vrest, [Value|Acc]); +validate_objectid(S, [Id|Vrest], Acc) + when record(Id,'Externalvaluereference') -> + case catch get_referenced_type(S, Id) of + {_,V} when record(V,valuedef) -> + case check_value(S, V) of + #valuedef{checked=true,value=Value} when integer(Value) -> + validate_objectid(S, Vrest, [Value|Acc]); + _ -> + error({value, "illegal OBJECT IDENTIFIER", S}) + end; + _ -> + case reserved_objectid(Id#'Externalvaluereference'.value, Acc) of + Value when integer(Value) -> + validate_objectid(S, Vrest, [Value|Acc]); + false -> + error({value, "illegal OBJECT IDENTIFIER", S}) + end + end; +validate_objectid(S, [{Atom,Value}],[]) when atom(Atom),integer(Value) -> + %% this case when an OBJECT IDENTIFIER value has been parsed as a + %% SEQUENCE value + Rec = #'Externalvaluereference'{module=S#state.mname, + value=Atom}, + validate_objectidentifier1(S,[Rec,Value]); +validate_objectid(S, [{Atom,EVRef}],[]) + when atom(Atom),record(EVRef,'Externalvaluereference') -> + %% this case when an OBJECT IDENTIFIER value has been parsed as a + %% SEQUENCE value OTP-4354 + Rec = #'Externalvaluereference'{module=S#state.mname, + value=Atom}, + validate_objectidentifier1(S,[Rec,EVRef]); +validate_objectid(S, _V, _Acc) -> + error({value, "illegal OBJECT IDENTIFIER",S}). + + +%% ITU-T Rec. X.680 Annex B - D +reserved_objectid('itu-t',[]) -> 0; +reserved_objectid('ccitt',[]) -> 0; +%% arcs below "itu-t" +reserved_objectid('recommendation',[0]) -> 0; +reserved_objectid('question',[0]) -> 1; +reserved_objectid('administration',[0]) -> 2; +reserved_objectid('network-operator',[0]) -> 3; +reserved_objectid('identified-organization',[0]) -> 4; +%% arcs below "recommendation" +reserved_objectid('a',[0,0]) -> 1; +reserved_objectid('b',[0,0]) -> 2; +reserved_objectid('c',[0,0]) -> 3; +reserved_objectid('d',[0,0]) -> 4; +reserved_objectid('e',[0,0]) -> 5; +reserved_objectid('f',[0,0]) -> 6; +reserved_objectid('g',[0,0]) -> 7; +reserved_objectid('h',[0,0]) -> 8; +reserved_objectid('i',[0,0]) -> 9; +reserved_objectid('j',[0,0]) -> 10; +reserved_objectid('k',[0,0]) -> 11; +reserved_objectid('l',[0,0]) -> 12; +reserved_objectid('m',[0,0]) -> 13; +reserved_objectid('n',[0,0]) -> 14; +reserved_objectid('o',[0,0]) -> 15; +reserved_objectid('p',[0,0]) -> 16; +reserved_objectid('q',[0,0]) -> 17; +reserved_objectid('r',[0,0]) -> 18; +reserved_objectid('s',[0,0]) -> 19; +reserved_objectid('t',[0,0]) -> 20; +reserved_objectid('u',[0,0]) -> 21; +reserved_objectid('v',[0,0]) -> 22; +reserved_objectid('w',[0,0]) -> 23; +reserved_objectid('x',[0,0]) -> 24; +reserved_objectid('y',[0,0]) -> 25; +reserved_objectid('z',[0,0]) -> 26; + + +reserved_objectid(iso,[]) -> 1; +%% arcs below "iso", note that number 1 is not used +reserved_objectid('standard',[1]) -> 0; +reserved_objectid('member-body',[1]) -> 2; +reserved_objectid('identified-organization',[1]) -> 3; + +reserved_objectid('joint-iso-itu-t',[]) -> 2; +reserved_objectid('joint-iso-ccitt',[]) -> 2; + +reserved_objectid(_,_) -> false. + + + + + +validate_objectdescriptor(_S,_Value,_Constr) -> + ok. + +validate_enumerated(S,Id,NamedNumberList,_Constr) when atom(Id) -> + case lists:keysearch(Id,1,NamedNumberList) of + {value,_} -> ok; + false -> error({value,"unknown ENUMERATED",S}) + end; +validate_enumerated(S,{identifier,_Pos,Id},NamedNumberList,_Constr) -> + case lists:keysearch(Id,1,NamedNumberList) of + {value,_} -> ok; + false -> error({value,"unknown ENUMERATED",S}) + end; +validate_enumerated(S,#'Externalvaluereference'{value=Id}, + NamedNumberList,_Constr) -> + case lists:keysearch(Id,1,NamedNumberList) of + {value,_} -> ok; + false -> error({value,"unknown ENUMERATED",S}) + end. + +validate_boolean(_S,_Value,_Constr) -> + ok. + +validate_octetstring(_S,_Value,_Constr) -> + ok. + +validate_restrictedstring(_S,_Value,_Def,_Constr) -> + ok. + +validate_sequence(S=#state{type=Vtype},Value,_Components,_Constr) -> + case Vtype of + #type{tag=[{tag,'UNIVERSAL',8,'IMPLICIT',32}]} -> + %% this is an 'EXTERNAL' (or INSTANCE OF) + case Value of + [{identification,_}|_RestVal] -> + to_EXTERNAL1990(S,Value); + _ -> + Value + end; + _ -> + Value + end. + +validate_sequenceof(_S,_Value,_Components,_Constr) -> + ok. + +validate_choice(_S,_Value,_Components,_Constr) -> + ok. + +validate_set(_S,_Value,_Components,_Constr) -> + ok. + +validate_setof(_S,_Value,_Components,_Constr) -> + ok. + +to_EXTERNAL1990(S,[{identification,{'CHOICE',{syntax,Stx}}}|Rest]) -> + to_EXTERNAL1990(S,Rest,[{'direct-reference',Stx}]); +to_EXTERNAL1990(S,[{identification,{'CHOICE',{'presentation-context-id',I}}}|Rest]) -> + to_EXTERNAL1990(S,Rest,[{'indirect-reference',I}]); +to_EXTERNAL1990(S,[{identification,{'CHOICE',{'context-negotiation',[{_,PCid},{_,TrStx}]}}}|Rest]) -> + to_EXTERNAL1990(S,Rest,[{'indirect-reference',PCid},{'direct-reference',TrStx}]); +to_EXTERNAL1990(S,_) -> + error({value,"illegal value in EXTERNAL type",S}). + +to_EXTERNAL1990(S,[V={'data-value-descriptor',_}|Rest],Acc) -> + to_EXTERNAL1990(S,Rest,[V|Acc]); +to_EXTERNAL1990(_S,[{'data-value',Val}],Acc) -> + Encoding = {encoding,{'CHOICE',{'octet-aligned',Val}}}, + lists:reverse([Encoding|Acc]); +to_EXTERNAL1990(S,_,_) -> + error({value,"illegal value in EXTERNAL type",S}). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Functions to normalize the default values of SEQUENCE +%% and SET components into Erlang valid format +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +normalize_value(_,_,mandatory,_) -> + mandatory; +normalize_value(_,_,'OPTIONAL',_) -> + 'OPTIONAL'; +normalize_value(S,Type,{'DEFAULT',Value},NameList) -> + case catch get_canonic_type(S,Type,NameList) of + {'BOOLEAN',CType,_} -> + normalize_boolean(S,Value,CType); + {'INTEGER',CType,_} -> + normalize_integer(S,Value,CType); + {'BIT STRING',CType,_} -> + normalize_bitstring(S,Value,CType); + {'OCTET STRING',CType,_} -> + normalize_octetstring(S,Value,CType); + {'NULL',_CType,_} -> + %%normalize_null(Value); + 'NULL'; + {'OBJECT IDENTIFIER',_,_} -> + normalize_objectidentifier(S,Value); + {'ObjectDescriptor',_,_} -> + normalize_objectdescriptor(Value); + {'REAL',_,_} -> + normalize_real(Value); + {'ENUMERATED',CType,_} -> + normalize_enumerated(Value,CType); + {'CHOICE',CType,NewNameList} -> + normalize_choice(S,Value,CType,NewNameList); + {'SEQUENCE',CType,NewNameList} -> + normalize_sequence(S,Value,CType,NewNameList); + {'SEQUENCE OF',CType,NewNameList} -> + normalize_seqof(S,Value,CType,NewNameList); + {'SET',CType,NewNameList} -> + normalize_set(S,Value,CType,NewNameList); + {'SET OF',CType,NewNameList} -> + normalize_setof(S,Value,CType,NewNameList); + {restrictedstring,CType,_} -> + normalize_restrictedstring(S,Value,CType); + _ -> + io:format("WARNING: could not check default value ~p~n",[Value]), + Value + end; +normalize_value(S,Type,Val,NameList) -> + normalize_value(S,Type,{'DEFAULT',Val},NameList). + +normalize_boolean(S,{Name,Bool},CType) when atom(Name) -> + normalize_boolean(S,Bool,CType); +normalize_boolean(_,true,_) -> + true; +normalize_boolean(_,false,_) -> + false; +normalize_boolean(S,Bool=#'Externalvaluereference'{},CType) -> + get_normalized_value(S,Bool,CType,fun normalize_boolean/3,[]); +normalize_boolean(_,Other,_) -> + throw({error,{asn1,{'invalid default value',Other}}}). + +normalize_integer(_S,Int,_) when integer(Int) -> + Int; +normalize_integer(_S,{Name,Int},_) when atom(Name),integer(Int) -> + Int; +normalize_integer(S,{Name,Int=#'Externalvaluereference'{}}, + Type) when atom(Name) -> + normalize_integer(S,Int,Type); +normalize_integer(S,Int=#'Externalvaluereference'{value=Name},Type) -> + case Type of + NNL when list(NNL) -> + case lists:keysearch(Name,1,NNL) of + {value,{Name,Val}} -> + Val; + false -> + get_normalized_value(S,Int,Type, + fun normalize_integer/3,[]) + end; + _ -> + get_normalized_value(S,Int,Type,fun normalize_integer/3,[]) + end; +normalize_integer(_,Int,_) -> + exit({'Unknown INTEGER value',Int}). + +normalize_bitstring(S,Value,Type)-> + %% There are four different Erlang formats of BIT STRING: + %% 1 - a list of ones and zeros. + %% 2 - a list of atoms. + %% 3 - as an integer, for instance in hexadecimal form. + %% 4 - as a tuple {Unused, Binary} where Unused is an integer + %% and tells how many bits of Binary are unused. + %% + %% normalize_bitstring/3 transforms Value according to: + %% A to 3, + %% B to 1, + %% C to 1 or 3 + %% D to 2, + %% Value can be on format: + %% A - {hstring, String}, where String is a hexadecimal string. + %% B - {bstring, String}, where String is a string on bit format + %% C - #'Externalvaluereference'{value=V}, where V is a defined value + %% D - list of #'Externalvaluereference', where each value component + %% is an identifier corresponing to NamedBits in Type. + case Value of + {hstring,String} when list(String) -> + hstring_to_int(String); + {bstring,String} when list(String) -> + bstring_to_bitlist(String); + Rec when record(Rec,'Externalvaluereference') -> + get_normalized_value(S,Value,Type, + fun normalize_bitstring/3,[]); + RecList when list(RecList) -> + case Type of + NBL when list(NBL) -> + F = fun(#'Externalvaluereference'{value=Name}) -> + case lists:keysearch(Name,1,NBL) of + {value,{Name,_}} -> + Name; + Other -> + throw({error,Other}) + end; + (Other) -> + throw({error,Other}) + end, + case catch lists:map(F,RecList) of + {error,Reason} -> + io:format("WARNING: default value not " + "compatible with type definition ~p~n", + [Reason]), + Value; + NewList -> + NewList + end; + _ -> + io:format("WARNING: default value not " + "compatible with type definition ~p~n", + [RecList]), + Value + end; + {Name,String} when atom(Name) -> + normalize_bitstring(S,String,Type); + Other -> + io:format("WARNING: illegal default value ~p~n",[Other]), + Value + end. + +hstring_to_int(L) when list(L) -> + hstring_to_int(L,0). +hstring_to_int([H|T],Acc) when H >= $A, H =< $F -> + hstring_to_int(T,(Acc bsl 4) + (H - $A + 10) ) ; +hstring_to_int([H|T],Acc) when H >= $0, H =< $9 -> + hstring_to_int(T,(Acc bsl 4) + (H - $0)); +hstring_to_int([],Acc) -> + Acc. + +bstring_to_bitlist([H|T]) when H == $0; H == $1 -> + [H - $0 | bstring_to_bitlist(T)]; +bstring_to_bitlist([]) -> + []. + +%% normalize_octetstring/1 changes representation of input Value to a +%% list of octets. +%% Format of Value is one of: +%% {bstring,String} each element in String corresponds to one bit in an octet +%% {hstring,String} each element in String corresponds to one byte in an octet +%% #'Externalvaluereference' +normalize_octetstring(S,Value,CType) -> + case Value of + {bstring,String} -> + bstring_to_octetlist(String); + {hstring,String} -> + hstring_to_octetlist(String); + Rec when record(Rec,'Externalvaluereference') -> + get_normalized_value(S,Value,CType, + fun normalize_octetstring/3,[]); + {Name,String} when atom(Name) -> + normalize_octetstring(S,String,CType); + List when list(List) -> + %% check if list elements are valid octet values + lists:map(fun([])-> ok; + (H)when H > 255-> + io:format("WARNING: not legal octet value ~p in OCTET STRING, ~p~n",[H,List]); + (_)-> ok + end, List), + List; + Other -> + io:format("WARNING: unknown default value ~p~n",[Other]), + Value + end. + + +bstring_to_octetlist([]) -> + []; +bstring_to_octetlist([H|T]) when H == $0 ; H == $1 -> + bstring_to_octetlist(T,6,[(H - $0) bsl 7]). +bstring_to_octetlist([H|T],0,[Hacc|Tacc]) when H == $0; H == $1 -> + bstring_to_octetlist(T, 7, [0,Hacc + (H -$0)| Tacc]); +bstring_to_octetlist([H|T],BSL,[Hacc|Tacc]) when H == $0; H == $1 -> + bstring_to_octetlist(T, BSL-1, [Hacc + ((H - $0) bsl BSL)| Tacc]); +bstring_to_octetlist([],7,[0|Acc]) -> + lists:reverse(Acc); +bstring_to_octetlist([],_,Acc) -> + lists:reverse(Acc). + +hstring_to_octetlist([]) -> + []; +hstring_to_octetlist(L) -> + hstring_to_octetlist(L,4,[]). +hstring_to_octetlist([H|T],0,[Hacc|Tacc]) when H >= $A, H =< $F -> + hstring_to_octetlist(T,4,[Hacc + (H - $A + 10)|Tacc]); +hstring_to_octetlist([H|T],BSL,Acc) when H >= $A, H =< $F -> + hstring_to_octetlist(T,0,[(H - $A + 10) bsl BSL|Acc]); +hstring_to_octetlist([H|T],0,[Hacc|Tacc]) when H >= $0; H =< $9 -> + hstring_to_octetlist(T,4,[Hacc + (H - $0)|Tacc]); +hstring_to_octetlist([H|T],BSL,Acc) when H >= $0; H =< $9 -> + hstring_to_octetlist(T,0,[(H - $0) bsl BSL|Acc]); +hstring_to_octetlist([],_,Acc) -> + lists:reverse(Acc). + +normalize_objectidentifier(S,Value) -> + validate_objectidentifier(S,Value,[]). + +normalize_objectdescriptor(Value) -> + Value. + +normalize_real(Value) -> + Value. + +normalize_enumerated(#'Externalvaluereference'{value=V},CType) + when list(CType) -> + normalize_enumerated2(V,CType); +normalize_enumerated(Value,CType) when atom(Value),list(CType) -> + normalize_enumerated2(Value,CType); +normalize_enumerated({Name,EnumV},CType) when atom(Name) -> + normalize_enumerated(EnumV,CType); +normalize_enumerated(Value,{CType1,CType2}) when list(CType1), list(CType2)-> + normalize_enumerated(Value,CType1++CType2); +normalize_enumerated(V,CType) -> + io:format("WARNING: Enumerated unknown type ~p~n",[CType]), + V. +normalize_enumerated2(V,Enum) -> + case lists:keysearch(V,1,Enum) of + {value,{Val,_}} -> Val; + _ -> + io:format("WARNING: Enumerated value is not correct ~p~n",[V]), + V + end. + +normalize_choice(S,{'CHOICE',{C,V}},CType,NameList) when atom(C) -> + Value = + case V of + Rec when record(Rec,'Externalvaluereference') -> + get_normalized_value(S,V,CType, + fun normalize_choice/4, + [NameList]); + _ -> V + end, + case catch lists:keysearch(C,#'ComponentType'.name,CType) of + {value,#'ComponentType'{typespec=CT,name=Name}} -> + {C,normalize_value(S,CT,{'DEFAULT',Value}, + [Name|NameList])}; + Other -> + io:format("WARNING: Wrong format of type/value ~p/~p~n", + [Other,Value]), + {C,Value} + end; +normalize_choice(S,{'DEFAULT',ValueList},CType,NameList) -> + lists:map(fun(X)-> normalize_choice(S,X,CType,NameList) end, ValueList); +normalize_choice(S,Val=#'Externalvaluereference'{},CType,NameList) -> + {_,#valuedef{value=V}}=get_referenced_type(S,Val), + normalize_choice(S,{'CHOICE',V},CType,NameList); +% get_normalized_value(S,Val,CType,fun normalize_choice/4,[NameList]); +normalize_choice(S,{Name,ChoiceVal},CType,NameList) + when atom(Name) -> + normalize_choice(S,ChoiceVal,CType,NameList). + +normalize_sequence(S,{Name,Value},Components,NameList) + when atom(Name),list(Value) -> + normalize_sequence(S,Value,Components,NameList); +normalize_sequence(S,Value,Components,NameList) -> + normalized_record('SEQUENCE',S,Value,Components,NameList). + +normalize_set(S,{Name,Value},Components,NameList) + when atom(Name),list(Value) -> + normalized_record('SET',S,Value,Components,NameList); +normalize_set(S,Value,Components,NameList) -> + normalized_record('SET',S,Value,Components,NameList). + +normalized_record(SorS,S,Value,Components,NameList) -> + NewName = list_to_atom(asn1ct_gen:list2name(NameList)), + NoComps = length(Components), + case normalize_seq_or_set(SorS,S,Value,Components,NameList,[]) of + ListOfVals when length(ListOfVals) == NoComps -> + list_to_tuple([NewName|ListOfVals]); + _ -> + error({type,{illegal,default,value,Value},S}) + end. + +normalize_seq_or_set(SorS,S,[{Cname,V}|Vs], + [#'ComponentType'{name=Cname,typespec=TS}|Cs], + NameList,Acc) -> + NewNameList = + case TS#type.def of + #'Externaltypereference'{type=TName} -> + [TName]; + _ -> [Cname|NameList] + end, + NVal = normalize_value(S,TS,{'DEFAULT',V},NewNameList), + normalize_seq_or_set(SorS,S,Vs,Cs,NameList,[NVal|Acc]); +normalize_seq_or_set(SorS,S,Values=[{_Cname1,_V}|_Vs], + [#'ComponentType'{prop='OPTIONAL'}|Cs], + NameList,Acc) -> + normalize_seq_or_set(SorS,S,Values,Cs,NameList,[asn1_NOVALUE|Acc]); +normalize_seq_or_set(SorS,S,Values=[{_Cname1,_V}|_Vs], + [#'ComponentType'{name=Cname2,typespec=TS, + prop={'DEFAULT',Value}}|Cs], + NameList,Acc) -> + NewNameList = + case TS#type.def of + #'Externaltypereference'{type=TName} -> + [TName]; + _ -> [Cname2|NameList] + end, + NVal = normalize_value(S,TS,{'DEFAULT',Value},NewNameList), + normalize_seq_or_set(SorS,S,Values,Cs,NameList,[NVal|Acc]); +normalize_seq_or_set(_SorS,_S,[],[],_,Acc) -> + lists:reverse(Acc); +%% If default value is {} ComponentTypes in SEQUENCE are marked DEFAULT +%% or OPTIONAL (or the type is defined SEQUENCE{}, which is handled by +%% the previous case). +normalize_seq_or_set(SorS,S,[], + [#'ComponentType'{name=Name,typespec=TS, + prop={'DEFAULT',Value}}|Cs], + NameList,Acc) -> + NewNameList = + case TS#type.def of + #'Externaltypereference'{type=TName} -> + [TName]; + _ -> [Name|NameList] + end, + NVal = normalize_value(S,TS,{'DEFAULT',Value},NewNameList), + normalize_seq_or_set(SorS,S,[],Cs,NameList,[NVal|Acc]); +normalize_seq_or_set(SorS,S,[],[#'ComponentType'{prop='OPTIONAL'}|Cs], + NameList,Acc) -> + normalize_seq_or_set(SorS,S,[],Cs,NameList,[asn1_NOVALUE|Acc]); +normalize_seq_or_set(SorS,S,Value=#'Externalvaluereference'{}, + Cs,NameList,Acc) -> + get_normalized_value(S,Value,Cs,fun normalize_seq_or_set/6, + [SorS,NameList,Acc]); +normalize_seq_or_set(_SorS,S,V,_,_,_) -> + error({type,{illegal,default,value,V},S}). + +normalize_seqof(S,Value,Type,NameList) -> + normalize_s_of('SEQUENCE OF',S,Value,Type,NameList). + +normalize_setof(S,Value,Type,NameList) -> + normalize_s_of('SET OF',S,Value,Type,NameList). + +normalize_s_of(SorS,S,Value,Type,NameList) when list(Value) -> + DefValueList = lists:map(fun(X) -> {'DEFAULT',X} end,Value), + Suffix = asn1ct_gen:constructed_suffix(SorS,Type), + Def = Type#type.def, + InnerType = asn1ct_gen:get_inner(Def), + WhatKind = asn1ct_gen:type(InnerType), + NewNameList = + case WhatKind of + {constructed,bif} -> + [Suffix|NameList]; + #'Externaltypereference'{type=Name} -> + [Name]; + _ -> [] + end, + NormFun = fun (X) -> normalize_value(S,Type,X, + NewNameList) end, + case catch lists:map(NormFun, DefValueList) of + List when list(List) -> + List; + _ -> + io:format("WARNING: ~p could not handle value ~p~n", + [SorS,Value]), + Value + end; +normalize_s_of(SorS,S,Value,Type,NameList) + when record(Value,'Externalvaluereference') -> + get_normalized_value(S,Value,Type,fun normalize_s_of/5, + [SorS,NameList]). +% case catch get_referenced_type(S,Value) of +% {_,#valuedef{value=V}} -> +% normalize_s_of(SorS,S,V,Type); +% {error,Reason} -> +% io:format("WARNING: ~p could not handle value ~p~n", +% [SorS,Value]), +% Value; +% {_,NewVal} -> +% normalize_s_of(SorS,S,NewVal,Type); +% _ -> +% io:format("WARNING: ~p could not handle value ~p~n", +% [SorS,Value]), +% Value +% end. + + +%% normalize_restrictedstring handles all format of restricted strings. +%% tuple case +normalize_restrictedstring(_S,[Int1,Int2],_) when integer(Int1),integer(Int2) -> + {Int1,Int2}; +%% quadruple case +normalize_restrictedstring(_S,[Int1,Int2,Int3,Int4],_) when integer(Int1), + integer(Int2), + integer(Int3), + integer(Int4) -> + {Int1,Int2,Int3,Int4}; +%% character string list case +normalize_restrictedstring(S,[H|T],CType) when list(H);tuple(H) -> + [normalize_restrictedstring(S,H,CType)|normalize_restrictedstring(S,T,CType)]; +%% character sting case +normalize_restrictedstring(_S,CString,_) when list(CString) -> + Fun = + fun(X) -> + if + $X =< 255, $X >= 0 -> + ok; + true -> + io:format("WARNING: illegal character in string" + " ~p~n",[X]) + end + end, + lists:foreach(Fun,CString), + CString; +%% definedvalue case or argument in a parameterized type +normalize_restrictedstring(S,ERef,CType) when record(ERef,'Externalvaluereference') -> + get_normalized_value(S,ERef,CType, + fun normalize_restrictedstring/3,[]); +%% +normalize_restrictedstring(S,{Name,Val},CType) when atom(Name) -> + normalize_restrictedstring(S,Val,CType). + + +get_normalized_value(S,Val,Type,Func,AddArg) -> + case catch get_referenced_type(S,Val) of + {_,#valuedef{type=_T,value=V}} -> + %% should check that Type and T equals + call_Func(S,V,Type,Func,AddArg); + {error,_} -> + io:format("WARNING: default value not " + "comparable ~p~n",[Val]), + Val; + {_,NewVal} -> + call_Func(S,NewVal,Type,Func,AddArg); + _ -> + io:format("WARNING: default value not " + "comparable ~p~n",[Val]), + Val + end. + +call_Func(S,Val,Type,Func,ArgList) -> + case ArgList of + [] -> + Func(S,Val,Type); + [LastArg] -> + Func(S,Val,Type,LastArg); + [Arg1,LastArg1] -> + Func(Arg1,S,Val,Type,LastArg1); + [Arg1,LastArg1,LastArg2] -> + Func(Arg1,S,Val,Type,LastArg1,LastArg2) + end. + + +get_canonic_type(S,Type,NameList) -> + {InnerType,NewType,NewNameList} = + case Type#type.def of + Name when atom(Name) -> + {Name,Type,NameList}; + Ref when record(Ref,'Externaltypereference') -> + {_,#typedef{name=Name,typespec=RefedType}} = + get_referenced_type(S,Ref), + get_canonic_type(S,RefedType,[Name]); + {Name,T} when atom(Name) -> + {Name,T,NameList}; + Seq when record(Seq,'SEQUENCE') -> + {'SEQUENCE',Seq#'SEQUENCE'.components,NameList}; + Set when record(Set,'SET') -> + {'SET',Set#'SET'.components,NameList} + end, + {asn1ct_gen:unify_if_string(InnerType),NewType,NewNameList}. + + + +check_ptype(_S,Type,Ts) when record(Ts,type) -> + %Tag = Ts#type.tag, + %Constr = Ts#type.constraint, + Def = Ts#type.def, + NewDef= + case Def of + Seq when record(Seq,'SEQUENCE') -> + #newt{type=Seq#'SEQUENCE'{pname=Type#ptypedef.name}}; + Set when record(Set,'SET') -> + #newt{type=Set#'SET'{pname=Type#ptypedef.name}}; + _Other -> + #newt{} + end, + Ts2 = case NewDef of + #newt{type=unchanged} -> + Ts; + #newt{type=TDef}-> + Ts#type{def=TDef} + end, + Ts2. + + +% check_type(S,Type,ObjSpec={{objectclassname,_},_}) -> +% check_class(S,ObjSpec); +check_type(_S,Type,Ts) when record(Type,typedef), + (Type#typedef.checked==true) -> + Ts; +check_type(_S,Type,Ts) when record(Type,typedef), + (Type#typedef.checked==idle) -> % the check is going on + Ts; +check_type(S=#state{recordtopname=TopName},Type,Ts) when record(Ts,type) -> + {Def,Tag,Constr} = + case match_parameters(Ts#type.def,S#state.parameters) of + #type{constraint=_Ctmp,def=Dtmp} -> + {Dtmp,Ts#type.tag,Ts#type.constraint}; + Dtmp -> + {Dtmp,Ts#type.tag,Ts#type.constraint} + end, + TempNewDef = #newt{type=Def,tag=Tag,constraint=Constr}, + TestFun = + fun(Tref) -> + {_,MaybeChoice} = get_referenced_type(S,Tref), + case catch((MaybeChoice#typedef.typespec)#type.def) of + {'CHOICE',_} -> + maybe_illicit_implicit_tag(choice,Tag); + 'ANY' -> + maybe_illicit_implicit_tag(open_type,Tag); + 'ANY DEFINED BY' -> + maybe_illicit_implicit_tag(open_type,Tag); + 'ASN1_OPEN_TYPE' -> + maybe_illicit_implicit_tag(open_type,Tag); + _ -> + Tag + end + end, + NewDef= + case Def of + Ext when record(Ext,'Externaltypereference') -> + {_,RefTypeDef} = get_referenced_type(S,Ext), +% case RefTypeDef of +% Class when record(Class,classdef) -> +% throw({asn1_class,Class}); +% _ -> ok +% end, + case is_class(S,RefTypeDef) of + true -> throw({asn1_class,RefTypeDef}); + _ -> ok + end, + Ct = TestFun(Ext), + RefType = +%case S#state.erule of +% ber_bin_v2 -> + case RefTypeDef#typedef.checked of + true -> + RefTypeDef#typedef.typespec; + _ -> + NewRefTypeDef1 = RefTypeDef#typedef{checked=idle}, + asn1_db:dbput(S#state.mname, + NewRefTypeDef1#typedef.name,NewRefTypeDef1), + RefType1 = + check_type(S,RefTypeDef,RefTypeDef#typedef.typespec), + NewRefTypeDef2 = + RefTypeDef#typedef{checked=true,typespec = RefType1}, + asn1_db:dbput(S#state.mname, + NewRefTypeDef2#typedef.name,NewRefTypeDef2), + %% update the type and mark as checked + RefType1 + end, +% _ -> RefTypeDef#typedef.typespec +% end, + + case asn1ct_gen:prim_bif(asn1ct_gen:get_inner(RefType#type.def)) of + true -> + %% Here we expand to a built in type and inline it + TempNewDef#newt{ + type= + RefType#type.def, + tag= + merge_tags(Ct,RefType#type.tag), + constraint= + merge_constraints(check_constraints(S,Constr), + RefType#type.constraint)}; + _ -> + %% Here we only expand the tags and keep the ext ref + + TempNewDef#newt{ + type= + check_externaltypereference(S,Ext), + tag = + case S#state.erule of + ber_bin_v2 -> + merge_tags(Ct,RefType#type.tag); + _ -> + Ct + end + } + end; + 'ANY' -> + Ct=maybe_illicit_implicit_tag(open_type,Tag), + TempNewDef#newt{type='ASN1_OPEN_TYPE',tag=Ct}; + {'ANY_DEFINED_BY',_} -> + Ct=maybe_illicit_implicit_tag(open_type,Tag), + TempNewDef#newt{type='ASN1_OPEN_TYPE',tag=Ct}; + 'INTEGER' -> + check_integer(S,[],Constr), + TempNewDef#newt{tag= + merge_tags(Tag,?TAG_PRIMITIVE(?N_INTEGER))}; + + {'INTEGER',NamedNumberList} -> + TempNewDef#newt{type={'INTEGER',check_integer(S,NamedNumberList,Constr)}, + tag= + merge_tags(Tag,?TAG_PRIMITIVE(?N_INTEGER))}; + {'BIT STRING',NamedNumberList} -> + NewL = check_bitstring(S,NamedNumberList,Constr), +%% erlang:display({asn1ct_check,NamedNumberList,NewL}), + TempNewDef#newt{type={'BIT STRING',NewL}, + tag= + merge_tags(Tag,?TAG_PRIMITIVE(?N_BIT_STRING))}; + 'NULL' -> + TempNewDef#newt{tag= + merge_tags(Tag,?TAG_PRIMITIVE(?N_NULL))}; + 'OBJECT IDENTIFIER' -> + check_objectidentifier(S,Constr), + TempNewDef#newt{tag= + merge_tags(Tag,?TAG_PRIMITIVE(?N_OBJECT_IDENTIFIER))}; + 'ObjectDescriptor' -> + TempNewDef#newt{tag= + merge_tags(Tag,?TAG_PRIMITIVE(?N_OBJECT_DESCRIPTOR))}; + 'EXTERNAL' -> +%% AssociatedType = asn1_db:dbget(S#state.mname,'EXTERNAL'), +%% #newt{type=check_type(S,Type,AssociatedType)}; + put(external,unchecked), + TempNewDef#newt{type= + #'Externaltypereference'{module=S#state.mname, + type='EXTERNAL'}, + tag= + merge_tags(Tag,?TAG_CONSTRUCTED(?N_EXTERNAL))}; + {'INSTANCE OF',DefinedObjectClass,Constraint} -> + %% check that DefinedObjectClass is of TYPE-IDENTIFIER class + %% If Constraint is empty make it the general INSTANCE OF type + %% If Constraint is not empty make an inlined type + %% convert INSTANCE OF to the associated type + IOFDef=check_instance_of(S,DefinedObjectClass,Constraint), + TempNewDef#newt{type=IOFDef, + tag=merge_tags(Tag,?TAG_CONSTRUCTED(?N_INSTANCE_OF))}; + {'ENUMERATED',NamedNumberList} -> + TempNewDef#newt{type= + {'ENUMERATED', + check_enumerated(S,NamedNumberList,Constr)}, + tag= + merge_tags(Tag,?TAG_PRIMITIVE(?N_ENUMERATED))}; + 'EMBEDDED PDV' -> +% AssociatedType = asn1_db:dbget(S#state.mname,'EMBEDDED PDV'), +% CheckedType = check_type(S,Type, +% AssociatedType#typedef.typespec), + put(embedded_pdv,unchecked), + TempNewDef#newt{type= + #'Externaltypereference'{module=S#state.mname, + type='EMBEDDED PDV'}, + tag= + merge_tags(Tag,?TAG_CONSTRUCTED(?N_EMBEDDED_PDV))}; + 'BOOLEAN'-> + check_boolean(S,Constr), + TempNewDef#newt{tag= + merge_tags(Tag,?TAG_PRIMITIVE(?N_BOOLEAN))}; + 'OCTET STRING' -> + check_octetstring(S,Constr), + TempNewDef#newt{tag= + merge_tags(Tag,?TAG_PRIMITIVE(?N_OCTET_STRING))}; + 'NumericString' -> + check_restrictedstring(S,Def,Constr), + TempNewDef#newt{tag= + merge_tags(Tag,?TAG_PRIMITIVE(?N_NumericString))}; + 'TeletexString' -> + check_restrictedstring(S,Def,Constr), + TempNewDef#newt{tag= + merge_tags(Tag,?TAG_PRIMITIVE(?N_TeletexString))}; + 'VideotexString' -> + check_restrictedstring(S,Def,Constr), + TempNewDef#newt{tag= + merge_tags(Tag,?TAG_PRIMITIVE(?N_VideotexString))}; + 'UTCTime' -> + TempNewDef#newt{tag= + merge_tags(Tag,?TAG_PRIMITIVE(?N_UTCTime))}; + 'GeneralizedTime' -> + TempNewDef#newt{tag= + merge_tags(Tag,?TAG_PRIMITIVE(?N_GeneralizedTime))}; + 'GraphicString' -> + check_restrictedstring(S,Def,Constr), + TempNewDef#newt{tag= + merge_tags(Tag,?TAG_PRIMITIVE(?N_GraphicString))}; + 'VisibleString' -> + check_restrictedstring(S,Def,Constr), + TempNewDef#newt{tag= + merge_tags(Tag,?TAG_PRIMITIVE(?N_VisibleString))}; + 'GeneralString' -> + check_restrictedstring(S,Def,Constr), + TempNewDef#newt{tag= + merge_tags(Tag,?TAG_PRIMITIVE(?N_GeneralString))}; + 'PrintableString' -> + check_restrictedstring(S,Def,Constr), + TempNewDef#newt{tag= + merge_tags(Tag,?TAG_PRIMITIVE(?N_PrintableString))}; + 'IA5String' -> + check_restrictedstring(S,Def,Constr), + TempNewDef#newt{tag= + merge_tags(Tag,?TAG_PRIMITIVE(?N_IA5String))}; + 'BMPString' -> + check_restrictedstring(S,Def,Constr), + TempNewDef#newt{tag= + merge_tags(Tag,?TAG_PRIMITIVE(?N_BMPString))}; + 'UniversalString' -> + check_restrictedstring(S,Def,Constr), + TempNewDef#newt{tag= + merge_tags(Tag,?TAG_PRIMITIVE(?N_UniversalString))}; + 'CHARACTER STRING' -> +% AssociatedType = asn1_db:dbget(S#state.mname, +% 'CHARACTER STRING'), +% CheckedType = check_type(S,Type, +% AssociatedType#typedef.typespec), + put(character_string,unchecked), + TempNewDef#newt{type= + #'Externaltypereference'{module=S#state.mname, + type='CHARACTER STRING'}, + tag= + merge_tags(Tag,?TAG_CONSTRUCTED(?N_CHARACTER_STRING))}; + Seq when record(Seq,'SEQUENCE') -> + RecordName = + case TopName of + [] -> + [Type#typedef.name]; + _ -> + TopName + end, + {TableCInf,Components} = + check_sequence(S#state{recordtopname= + RecordName}, + Type,Seq#'SEQUENCE'.components), + TempNewDef#newt{type=Seq#'SEQUENCE'{tablecinf=TableCInf, + components=Components}, + tag= + merge_tags(Tag,?TAG_CONSTRUCTED(?N_SEQUENCE))}; + {'SEQUENCE OF',Components} -> + TempNewDef#newt{type={'SEQUENCE OF',check_sequenceof(S,Type,Components)}, + tag= + merge_tags(Tag,?TAG_CONSTRUCTED(?N_SEQUENCE))}; + {'CHOICE',Components} -> + Ct = maybe_illicit_implicit_tag(choice,Tag), + TempNewDef#newt{type={'CHOICE',check_choice(S,Type,Components)},tag=Ct}; + Set when record(Set,'SET') -> + RecordName= + case TopName of + [] -> + [Type#typedef.name]; + _ -> + TopName + end, + {Sorted,TableCInf,Components} = + check_set(S#state{recordtopname=RecordName}, + Type,Set#'SET'.components), + TempNewDef#newt{type=Set#'SET'{sorted=Sorted, + tablecinf=TableCInf, + components=Components}, + tag= + merge_tags(Tag,?TAG_CONSTRUCTED(?N_SET))}; + {'SET OF',Components} -> + TempNewDef#newt{type={'SET OF',check_setof(S,Type,Components)}, + tag= + merge_tags(Tag,?TAG_CONSTRUCTED(?N_SET))}; + %% This is a temporary hack until the full Information Obj Spec + %% in X.681 is supported + {{typereference,_,'TYPE-IDENTIFIER'},[{typefieldreference,_,'Type'}]} -> + Ct=maybe_illicit_implicit_tag(open_type,Tag), + TempNewDef#newt{type='ASN1_OPEN_TYPE',tag=Ct}; + + {#'Externaltypereference'{type='TYPE-IDENTIFIER'}, + [{typefieldreference,_,'Type'}]} -> + Ct=maybe_illicit_implicit_tag(open_type,Tag), + TempNewDef#newt{type='ASN1_OPEN_TYPE',tag=Ct}; + + {pt,Ptype,ParaList} -> + %% Ptype might be a parameterized - type, object set or + %% value set. If it isn't a parameterized type notify the + %% calling function. + {_,Ptypedef} = get_referenced_type(S,Ptype), + notify_if_not_ptype(S,Ptypedef), + NewParaList = [match_parameters(TmpParam,S#state.parameters)|| + TmpParam <- ParaList], + Instance = instantiate_ptype(S,Ptypedef,NewParaList), + TempNewDef#newt{type=Instance#type.def, + tag=merge_tags(Tag,Instance#type.tag), + constraint=Instance#type.constraint, + inlined=yes}; + +% {ClRef,FieldRefList} when record(ClRef,'Externaltypereference') -> + OCFT=#'ObjectClassFieldType'{class=ClRef} -> + %% this case occures in a SEQUENCE when + %% the type of the component is a ObjectClassFieldType + ClassSpec = check_class(S,ClRef), + NewTypeDef = maybe_open_type(S,ClassSpec,OCFT,Constr), + InnerTag = get_innertag(S,NewTypeDef), + MergedTag = merge_tags(Tag,InnerTag), + Ct = + case is_open_type(NewTypeDef) of + true -> + maybe_illicit_implicit_tag(open_type,MergedTag); + _ -> + MergedTag + end, + TempNewDef#newt{type=NewTypeDef,tag=Ct}; + {valueset,Vtype} -> + TempNewDef#newt{type={valueset,check_type(S,Type,Vtype)}}; + Other -> + exit({'cant check' ,Other}) + end, + Ts2 = case NewDef of + #newt{type=unchanged} -> + Ts#type{def=Def}; + #newt{type=TDef}-> + Ts#type{def=TDef} + end, + NewTag = case NewDef of + #newt{tag=unchanged} -> + Tag; + #newt{tag=TT} -> + TT + end, + T3 = Ts2#type{tag = lists:map(fun(TempTag = #tag{type={default,TTx}}) -> + TempTag#tag{type=TTx}; + (Else) -> Else end, NewTag)}, + T4 = case NewDef of + #newt{constraint=unchanged} -> + T3#type{constraint=Constr}; + #newt{constraint=NewConstr} -> + T3#type{constraint=NewConstr} + end, + T5 = T4#type{inlined=NewDef#newt.inlined}, + T5#type{constraint=check_constraints(S,T5#type.constraint)}. + + +get_innertag(_S,#'ObjectClassFieldType'{type=Type}) -> + case Type of + #type{tag=Tag} -> Tag; + {fixedtypevaluefield,_,#type{tag=Tag}} -> Tag; + {TypeFieldName,_} when atom(TypeFieldName) -> []; + _ -> [] + end; +get_innertag(_S,_) -> + []. + +is_class(_S,#classdef{}) -> + true; +is_class(S,#typedef{typespec=#type{def=Eref}}) + when record(Eref,'Externaltypereference')-> + {_,NextDef} = get_referenced_type(S,Eref), + is_class(S,NextDef); +is_class(_,_) -> + false. + +get_class_def(_S,CD=#classdef{}) -> + CD; +get_class_def(S,#typedef{typespec=#type{def=Eref}}) + when record(Eref,'Externaltypereference') -> + {_,NextDef} = get_referenced_type(S,Eref), + get_class_def(S,NextDef). + +maybe_illicit_implicit_tag(Kind,Tag) -> + case Tag of + [#tag{type='IMPLICIT'}|_T] -> + throw({error,{asn1,{implicit_tag_before,Kind}}}); + [ChTag = #tag{type={default,_}}|T] -> + case Kind of + open_type -> + [ChTag#tag{type='EXPLICIT',form=32}|T]; %X.680 30.6c, X.690 8.14.2 + choice -> + [ChTag#tag{type='EXPLICIT',form=32}|T] % X.680 28.6 c, 30.6c + end; + _ -> + Tag % unchanged + end. + +%% maybe_open_type/2 -> {ClassSpec,FieldRefList} | 'ASN1_OPEN_TYPE' +%% if the FieldRefList points out a typefield and the class don't have +%% any UNIQUE field, so that a component relation constraint cannot specify +%% the type of a typefield, return 'ASN1_OPEN_TYPE', otherwise return +%% {ClassSpec,FieldRefList}. +maybe_open_type(S,ClassSpec=#objectclass{fields=Fs}, + OCFT=#'ObjectClassFieldType'{fieldname=FieldRefList}, + Constr) -> + Type = get_ObjectClassFieldType(S,Fs,FieldRefList), + FieldNames=get_referenced_fieldname(FieldRefList), + case lists:last(FieldRefList) of + {valuefieldreference,_} -> + OCFT#'ObjectClassFieldType'{class=ClassSpec, + fieldname=FieldNames, + type=Type}; + {typefieldreference,_} -> + case {catch get_unique_fieldname(#classdef{typespec=ClassSpec}), + asn1ct_gen:get_constraint(Constr,componentrelation)}of + {Tuple,_} when tuple(Tuple) -> + OCFT#'ObjectClassFieldType'{class=ClassSpec, + fieldname=FieldNames, + type='ASN1_OPEN_TYPE'}; + {_,no} -> + OCFT#'ObjectClassFieldType'{class=ClassSpec, + fieldname=FieldNames, + type='ASN1_OPEN_TYPE'}; + _ -> + OCFT#'ObjectClassFieldType'{class=ClassSpec, + fieldname=FieldNames, + type=Type} + end + end. + +is_open_type(#'ObjectClassFieldType'{type='ASN1_OPEN_TYPE'}) -> + true; +is_open_type(#'ObjectClassFieldType'{}) -> + false. + + +notify_if_not_ptype(S,#pvaluesetdef{type=Type}) -> + case Type#type.def of + Ref when record(Ref,'Externaltypereference') -> + case get_referenced_type(S,Ref) of + {_,#classdef{}} -> + throw(pobjectsetdef); + {_,#typedef{}} -> + throw(pvalueset) + end; + T when record(T,type) -> % this must be a value set + throw(pvalueset) + end; +notify_if_not_ptype(_S,#ptypedef{}) -> + ok. + +% fix me +instantiate_ptype(S,Ptypedef,ParaList) -> + #ptypedef{args=Args,typespec=Type} = Ptypedef, +% Args = get_pt_args(Ptypedef), +% Type = get_pt_spec(Ptypedef), + MatchedArgs = match_args(Args, ParaList, []), + NewS = S#state{type=Type,parameters=MatchedArgs,abscomppath=[]}, + %The abscomppath must be empty since a table constraint in a + %parameterized type only can refer to components within the type + check_type(NewS, Ptypedef, Type). + +get_pt_args(#ptypedef{args=Args}) -> + Args; +get_pt_args(#pvaluesetdef{args=Args}) -> + Args; +get_pt_args(#pvaluedef{args=Args}) -> + Args; +get_pt_args(#pobjectdef{args=Args}) -> + Args; +get_pt_args(#pobjectsetdef{args=Args}) -> + Args. + +get_pt_spec(#ptypedef{typespec=Type}) -> + Type; +get_pt_spec(#pvaluedef{value=Value}) -> + Value; +get_pt_spec(#pvaluesetdef{valueset=VS}) -> + VS; +get_pt_spec(#pobjectdef{def=Def}) -> + Def; +get_pt_spec(#pobjectsetdef{def=Def}) -> + Def. + + + +match_args([FormArg|Ft], [ActArg|At], Acc) -> + match_args(Ft, At, [{FormArg,ActArg}|Acc]); +match_args([], [], Acc) -> + lists:reverse(Acc); +match_args(_, _, _) -> + throw({error,{asn1,{wrong_number_of_arguments}}}). + +check_constraints(S,C) when list(C) -> + check_constraints(S, C, []); +check_constraints(S,C) when record(C,constraint) -> + check_constraints(S, C#constraint.c, []). + + +resolv_tuple_or_list(S,List) when list(List) -> + lists:map(fun(X)->resolv_value(S,X) end, List); +resolv_tuple_or_list(S,{Lb,Ub}) -> + {resolv_value(S,Lb),resolv_value(S,Ub)}. + +%%%----------------------------------------- +%% If the constraint value is a defined value the valuename +%% is replaced by the actual value +%% +resolv_value(S,Val) -> + case match_parameters(Val, S#state.parameters) of + Id -> % unchanged + resolv_value1(S,Id); + Other -> + resolv_value(S,Other) + end. + +resolv_value1(S = #state{mname=M,inputmodules=InpMods}, + V=#'Externalvaluereference'{pos=Pos,module=ExtM,value=Name}) -> + case ExtM of + M -> resolv_value2(S,M,Name,Pos); + _ -> + case lists:member(ExtM,InpMods) of + true -> + resolv_value2(S,M,Name,Pos); + false -> + V + end + end; +resolv_value1(S,{gt,V}) -> + case V of + Int when integer(Int) -> + V + 1; + #valuedef{value=Int} -> + 1 + resolv_value(S,Int); + Other -> + throw({error,{asn1,{undefined_type_or_value,Other}}}) + end; +resolv_value1(S,{lt,V}) -> + case V of + Int when integer(Int) -> + V - 1; + #valuedef{value=Int} -> + resolv_value(S,Int) - 1; + Other -> + throw({error,{asn1,{undefined_type_or_value,Other}}}) + end; +resolv_value1(S,{'ValueFromObject',{object,Object},[{valuefieldreference, + FieldName}]}) -> + %% FieldName can hold either a fixed-type value or a variable-type value + %% Object is a DefinedObject, i.e. a #'Externaltypereference' + {_,ObjTDef} = get_referenced_type(S,Object), + TS = check_object(S,ObjTDef,ObjTDef#typedef.typespec), + {_,_,Components} = TS#'Object'.def, + case lists:keysearch(FieldName,1,Components) of + {value,{_,#valuedef{value=Val}}} -> + Val; + _ -> + error({value,"illegal value in constraint",S}) + end; +% resolv_value1(S,{'ValueFromObject',{po,Object,Params},FieldName}) -> +% %% FieldName can hold either a fixed-type value or a variable-type value +% %% Object is a ParameterizedObject +resolv_value1(_,V) -> + V. + +resolv_value2(S,ModuleName,Name,Pos) -> + case asn1_db:dbget(ModuleName,Name) of + undefined -> + case imported(S,Name) of + {ok,Imodule} -> + {_,V2} = get_referenced(S,Imodule,Name,Pos), + V2#valuedef.value; + _ -> + throw({error,{asn1,{undefined_type_or_value,Name}}}) + end; + Val -> + Val#valuedef.value + end. + +check_constraints(S,[{'ContainedSubtype',Type} | Rest], Acc) -> + {_,CTDef} = get_referenced_type(S,Type#type.def), + CType = check_type(S,S#state.tname,CTDef#typedef.typespec), + check_constraints(S,Rest,CType#type.constraint ++ Acc); +check_constraints(S,[C | Rest], Acc) -> + check_constraints(S,Rest,[check_constraint(S,C) | Acc]); +check_constraints(S,[],Acc) -> +% io:format("Acc: ~p~n",[Acc]), + C = constraint_merge(S,lists:reverse(Acc)), +% io:format("C: ~p~n",[C]), + lists:flatten(C). + + +range_check(F={FixV,FixV}) -> +% FixV; + F; +range_check(VR={Lb,Ub}) when Lb < Ub -> + VR; +range_check(Err={_,_}) -> + throw({error,{asn1,{illegal_size_constraint,Err}}}); +range_check(Value) -> + Value. + +check_constraint(S,Ext) when record(Ext,'Externaltypereference') -> + check_externaltypereference(S,Ext); + + +check_constraint(S,{'SizeConstraint',{Lb,Ub}}) + when list(Lb);tuple(Lb),size(Lb)==2 -> + case Lb of + #'Externalvaluereference'{} -> + check_constraint(S,{'SizeConstraint',{resolv_value(S,Lb),Ub}}); + _ -> + NewLb = range_check(resolv_tuple_or_list(S,Lb)), + NewUb = range_check(resolv_tuple_or_list(S,Ub)), + {'SizeConstraint',{NewLb,NewUb}} + end; +check_constraint(S,{'SizeConstraint',{Lb,Ub}}) -> + case {resolv_value(S,Lb),resolv_value(S,Ub)} of + {FixV,FixV} -> + {'SizeConstraint',FixV}; + {Low,High} when Low < High -> + {'SizeConstraint',{Low,High}}; + Err -> + throw({error,{asn1,{illegal_size_constraint,Err}}}) + end; +check_constraint(S,{'SizeConstraint',Lb}) -> + {'SizeConstraint',resolv_value(S,Lb)}; + +check_constraint(S,{'SingleValue', L}) when list(L) -> + F = fun(A) -> resolv_value(S,A) end, + {'SingleValue',lists:map(F,L)}; + +check_constraint(S,{'SingleValue', V}) when integer(V) -> + Val = resolv_value(S,V), +%% [{'SingleValue',Val},{'ValueRange',{Val,Val}}]; % Why adding value range? + {'SingleValue',Val}; +check_constraint(S,{'SingleValue', V}) -> + {'SingleValue',resolv_value(S,V)}; + +check_constraint(S,{'ValueRange', {Lb, Ub}}) -> + {'ValueRange',{resolv_value(S,Lb),resolv_value(S,Ub)}}; + +%%check_constraint(S,{'ContainedSubtype',Type}) -> +%% #typedef{typespec=TSpec} = +%% check_type(S,S#state.tname,get_referenced_type(S,Type#type.def)), +%% [C] = TSpec#type.constraint, +%% C; + +check_constraint(S,{valueset,Type}) -> + {valueset,check_type(S,S#state.tname,Type)}; + +check_constraint(S,{simpletable,Type}) -> + OSName = (Type#type.def)#'Externaltypereference'.type, + C = match_parameters(Type#type.def,S#state.parameters), + case C of + #'Externaltypereference'{} -> + Type#type{def=check_externaltypereference(S,C)}, + {simpletable,OSName}; + _ -> + check_type(S,S#state.tname,Type), + {simpletable,OSName} + end; + +check_constraint(S,{componentrelation,{objectset,Opos,Objset},Id}) -> + %% Objset is an 'Externaltypereference' record, since Objset is + %% a DefinedObjectSet. + RealObjset = match_parameters(Objset,S#state.parameters), + Ext = check_externaltypereference(S,RealObjset), + {componentrelation,{objectset,Opos,Ext},Id}; + +check_constraint(S,Type) when record(Type,type) -> + #type{def=Def} = check_type(S,S#state.tname,Type), + Def; + +check_constraint(S,C) when list(C) -> + lists:map(fun(X)->check_constraint(S,X) end,C); +% else keep the constraint unchanged +check_constraint(_S,Any) -> +% io:format("Constraint = ~p~n",[Any]), + Any. + +%% constraint_merge/2 +%% Compute the intersection of the outermost level of the constraint list. +%% See Dubuisson second paragraph and fotnote on page 285. +%% If constraints with extension are included in combined constraints. The +%% resulting combination will have the extension of the last constraint. Thus, +%% there will be no extension if the last constraint is without extension. +%% The rootset of all constraints are considered in the "outermoust +%% intersection". See section 13.1.2 in Dubuisson. +constraint_merge(_S,C=[H])when tuple(H) -> + C; +constraint_merge(_S,[]) -> + []; +constraint_merge(S,C) -> + %% skip all extension but the last + C1 = filter_extensions(C), + %% perform all internal level intersections, intersections first + %% since they have precedence over unions + C2 = lists:map(fun(X)when list(X)->constraint_intersection(S,X); + (X) -> X end, + C1), + %% perform all internal level unions + C3 = lists:map(fun(X)when list(X)->constraint_union(S,X); + (X) -> X end, + C2), + + %% now get intersection of the outermost level + %% get the least common single value constraint + SVs = get_constraints(C3,'SingleValue'), + CombSV = intersection_of_sv(S,SVs), + %% get the least common value range constraint + VRs = get_constraints(C3,'ValueRange'), + CombVR = intersection_of_vr(S,VRs), + %% get the least common size constraint + SZs = get_constraints(C3,'SizeConstraint'), + CombSZ = intersection_of_size(S,SZs), + CminusSVs=ordsets:subtract(ordsets:from_list(C3),ordsets:from_list(SVs)), + % CminusSVsVRs = ordsets:subtract(ordsets:from_list(CminusSVs), +% ordsets:from_list(VRs)), + RestC = ordsets:subtract(ordsets:from_list(CminusSVs), + ordsets:from_list(SZs)), + %% get the least common combined constraint. That is the union of each + %% deep costraint and merge of single value and value range constraints + combine_constraints(S,CombSV,CombVR,CombSZ++RestC). + +%% constraint_union(S,C) takes a list of constraints as input and +%% merge them to a union. Unions are performed when two +%% constraints is found with an atom union between. +%% The list may be nested. Fix that later !!! +constraint_union(_S,[]) -> + []; +constraint_union(_S,C=[_E]) -> + C; +constraint_union(S,C) when list(C) -> + case lists:member(union,C) of + true -> + constraint_union1(S,C,[]); + _ -> + C + end; +% SV = get_constraints(C,'SingleValue'), +% SV1 = constraint_union_sv(S,SV), +% VR = get_constraints(C,'ValueRange'), +% VR1 = constraint_union_vr(VR), +% RestC = ordsets:filter(fun({'SingleValue',_})->false; +% ({'ValueRange',_})->false; +% (_) -> true end,ordsets:from_list(C)), +% SV1++VR1++RestC; +constraint_union(_S,C) -> + [C]. + +constraint_union1(S,[A={'ValueRange',_},union,B={'ValueRange',_}|Rest],Acc) -> + AunionB = constraint_union_vr([A,B]), + constraint_union1(S,Rest,AunionB++Acc); +constraint_union1(S,[A={'SingleValue',_},union,B={'SingleValue',_}|Rest],Acc) -> + AunionB = constraint_union_sv(S,[A,B]), + constraint_union1(S,Rest,AunionB++Acc); +constraint_union1(S,[A={'SingleValue',_},union,B={'ValueRange',_}|Rest],Acc) -> + AunionB = union_sv_vr(S,A,B), + constraint_union1(S,Rest,AunionB++Acc); +constraint_union1(S,[A={'ValueRange',_},union,B={'SingleValue',_}|Rest],Acc) -> + AunionB = union_sv_vr(S,B,A), + constraint_union1(S,Rest,AunionB++Acc); +constraint_union1(S,[union|Rest],Acc) -> %skip when unsupported constraints + constraint_union1(S,Rest,Acc); +constraint_union1(S,[A|Rest],Acc) -> + constraint_union1(S,Rest,[A|Acc]); +constraint_union1(_S,[],Acc) -> + lists:reverse(Acc). + +constraint_union_sv(_S,SV) -> + Values=lists:map(fun({_,V})->V end,SV), + case ordsets:from_list(Values) of + [] -> []; + [N] -> [{'SingleValue',N}]; + L -> [{'SingleValue',L}] + end. + +%% REMOVE???? +%%constraint_union(S,VR,'ValueRange') -> +%% constraint_union_vr(VR). + +%% constraint_union_vr(VR) +%% VR = [{'ValueRange',{Lb,Ub}},...] +%% Lb = 'MIN' | integer() +%% Ub = 'MAX' | integer() +%% Returns if possible only one ValueRange tuple with a range that +%% is a union of all ranges in VR. +constraint_union_vr(VR) -> + %% Sort VR by Lb in first hand and by Ub in second hand + Fun=fun({_,{'MIN',_B1}},{_,{A2,_B2}}) when integer(A2)->true; + ({_,{A1,_B1}},{_,{'MAX',_B2}}) when integer(A1) -> true; + ({_,{A1,_B1}},{_,{A2,_B2}}) when integer(A1),integer(A2),A1<A2 -> true; + ({_,{A,B1}},{_,{A,B2}}) when B1=<B2->true; + (_,_)->false end, + constraint_union_vr(lists:usort(Fun,VR),[]). + +constraint_union_vr([],Acc) -> + lists:reverse(Acc); +constraint_union_vr([C|Rest],[]) -> + constraint_union_vr(Rest,[C]); +constraint_union_vr([{_,{Lb,Ub2}}|Rest],[{_,{Lb,_Ub1}}|Acc]) -> %Ub2 > Ub1 + constraint_union_vr(Rest,[{'ValueRange',{Lb,Ub2}}|Acc]); +constraint_union_vr([{_,{_,Ub}}|Rest],A=[{_,{_,Ub}}|_Acc]) -> + constraint_union_vr(Rest,A); +constraint_union_vr([{_,{Lb2,Ub2}}|Rest],[{_,{Lb1,Ub1}}|Acc]) when Lb2=<Ub1, + Ub2>Ub1-> + constraint_union_vr(Rest,[{'ValueRange',{Lb1,Ub2}}|Acc]); +constraint_union_vr([{_,{_,Ub2}}|Rest],A=[{_,{_,Ub1}}|_Acc]) when Ub2=<Ub1-> + constraint_union_vr(Rest,A); +constraint_union_vr([VR|Rest],Acc) -> + constraint_union_vr(Rest,[VR|Acc]). + +union_sv_vr(_S,[],B) -> + [B]; +union_sv_vr(_S,A,[]) -> + [A]; +union_sv_vr(_S,C1={'SingleValue',SV},C2={'ValueRange',VR={Lb,Ub}}) + when integer(SV) -> + case is_int_in_vr(SV,C2) of + true -> [C2]; + _ -> + case VR of + {'MIN',Ub} when SV==Ub+1 -> [{'ValueRange',{'MIN',SV}}]; + {Lb,'MAX'} when SV==Lb-1 -> [{'ValueRange',{SV,'MAX'}}]; + {Lb,Ub} when SV==Ub+1 -> [{'ValueRange',{Lb,SV}}]; + {Lb,Ub} when SV==Lb-1 -> [{'ValueRange',{SV,Ub}}]; + _ -> + [C1,C2] + end + end; +union_sv_vr(_S,C1={'SingleValue',SV},C2={'ValueRange',{_Lb,_Ub}}) + when list(SV) -> + case lists:filter(fun(X)->is_int_in_vr(X,C2) end,SV) of + [] -> [C2]; + L -> + case expand_vr(L,C2) of + {[],C3} -> [C3]; + {L,C2} -> [C1,C2]; + {[Val],C3} -> [{'SingleValue',Val},C3]; + {L2,C3} -> [{'SingleValue',L2},C3] + end + end. + +expand_vr(L,VR={_,{Lb,Ub}}) -> + case lower_Lb(L,Lb) of + false -> + case higher_Ub(L,Ub) of + false -> + {L,VR}; + {L1,UbNew} -> + expand_vr(L1,{'ValueRange',{Lb,UbNew}}) + end; + {L1,LbNew} -> + expand_vr(L1,{'ValueRange',{LbNew,Ub}}) + end. + +lower_Lb(_,'MIN') -> + false; +lower_Lb(L,Lb) -> + remove_val_from_list(Lb - 1,L). + +higher_Ub(_,'MAX') -> + false; +higher_Ub(L,Ub) -> + remove_val_from_list(Ub + 1,L). + +remove_val_from_list(List,Val) -> + case lists:member(Val,List) of + true -> + {lists:delete(Val,List),Val}; + false -> + false + end. + +%% get_constraints/2 +%% Arguments are a list of constraints, which has the format {key,value}, +%% and a constraint type +%% Returns a list of constraints only of the requested type or the atom +%% 'no' if no such constraints were found +get_constraints(L=[{CType,_}],CType) -> + L; +get_constraints(C,CType) -> + keysearch_allwithkey(CType,1,C). + +%% keysearch_allwithkey(Key,Ix,L) +%% Types: +%% Key = atom() +%% Ix = integer() +%% L = [TwoTuple] +%% TwoTuple = [{atom(),term()}|...] +%% Returns a List that contains all +%% elements from L that has a key Key as element Ix +keysearch_allwithkey(Key,Ix,L) -> + lists:filter(fun(X) when tuple(X) -> + case element(Ix,X) of + Key -> true; + _ -> false + end; + (_) -> false + end, L). + + +%% filter_extensions(C) +%% takes a list of constraints as input and +%% returns a list with the intersection of all extension roots +%% and only the extension of the last constraint kept if any +%% extension in the last constraint +filter_extensions([]) -> + []; +filter_extensions(C=[_H]) -> + C; +filter_extensions(C) when list(C) -> + filter_extensions(C,[]). + +filter_extensions([C],Acc) -> + lists:reverse([C|Acc]); +filter_extensions([{C,_E},H2|T],Acc) when tuple(C) -> + filter_extensions([H2|T],[C|Acc]); +filter_extensions([{'SizeConstraint',{A,_B}},H2|T],Acc) + when list(A);tuple(A) -> + filter_extensions([H2|T],[{'SizeConstraint',A}|Acc]); +filter_extensions([H1,H2|T],Acc) -> + filter_extensions([H2|T],[H1|Acc]). + +%% constraint_intersection(S,C) takes a list of constraints as input and +%% performs intersections. Intersecions are performed when an +%% atom intersection is found between two constraints. +%% The list may be nested. Fix that later !!! +constraint_intersection(_S,[]) -> + []; +constraint_intersection(_S,C=[_E]) -> + C; +constraint_intersection(S,C) when list(C) -> +% io:format("constraint_intersection: ~p~n",[C]), + case lists:member(intersection,C) of + true -> + constraint_intersection1(S,C,[]); + _ -> + C + end; +constraint_intersection(_S,C) -> + [C]. + +constraint_intersection1(S,[A,intersection,B|Rest],Acc) -> + AisecB = c_intersect(S,A,B), + constraint_intersection1(S,Rest,AisecB++Acc); +constraint_intersection1(S,[A|Rest],Acc) -> + constraint_intersection1(S,Rest,[A|Acc]); +constraint_intersection1(_,[],Acc) -> + lists:reverse(Acc). + +c_intersect(S,C1={'SingleValue',_},C2={'SingleValue',_}) -> + intersection_of_sv(S,[C1,C2]); +c_intersect(S,C1={'ValueRange',_},C2={'ValueRange',_}) -> + intersection_of_vr(S,[C1,C2]); +c_intersect(S,C1={'ValueRange',_},C2={'SingleValue',_}) -> + intersection_sv_vr(S,[C2],[C1]); +c_intersect(S,C1={'SingleValue',_},C2={'ValueRange',_}) -> + intersection_sv_vr(S,[C1],[C2]); +c_intersect(_S,C1,C2) -> + [C1,C2]. + +%% combine_constraints(S,SV,VR,CComb) +%% Types: +%% S = record(state,S) +%% SV = [] | [SVC] +%% VR = [] | [VRC] +%% CComb = [] | [Lists] +%% SVC = {'SingleValue',integer()} | {'SingleValue',[integer(),...]} +%% VRC = {'ValueRange',{Lb,Ub}} +%% Lists = List of lists containing any constraint combination +%% Lb = 'MIN' | integer() +%% Ub = 'MAX' | integer() +%% Returns a combination of the least common constraint among SV,VR and all +%% elements in CComb +combine_constraints(_S,[],VR,CComb) -> + VR ++ CComb; +% combine_combined_cnstr(S,VR,CComb); +combine_constraints(_S,SV,[],CComb) -> + SV ++ CComb; +% combine_combined_cnstr(S,SV,CComb); +combine_constraints(S,SV,VR,CComb) -> + C=intersection_sv_vr(S,SV,VR), + C ++ CComb. +% combine_combined_cnstr(S,C,CComb). + +intersection_sv_vr(_,[],_VR) -> + []; +intersection_sv_vr(_,_SV,[]) -> + []; +intersection_sv_vr(_S,[C1={'SingleValue',SV}],[C2={'ValueRange',{_Lb,_Ub}}]) + when integer(SV) -> + case is_int_in_vr(SV,C2) of + true -> [C1]; + _ -> %%error({type,{"asn1 illegal constraint",C1,C2},S}) + throw({error,{"asn1 illegal constraint",C1,C2}}) + end; +intersection_sv_vr(_S,[C1={'SingleValue',SV}],[C2]) + when list(SV) -> + case lists:filter(fun(X)->is_int_in_vr(X,C2) end,SV) of + [] -> + %%error({type,{"asn1 illegal constraint",C1,C2},S}); + throw({error,{"asn1 illegal constraint",C1,C2}}); + [V] -> [{'SingleValue',V}]; + L -> [{'SingleValue',L}] + end. + + + +intersection_of_size(_,[]) -> + []; +intersection_of_size(_,C=[_SZ]) -> + C; +intersection_of_size(S,[SZ,SZ|Rest]) -> + intersection_of_size(S,[SZ|Rest]); +intersection_of_size(S,C=[C1={_,Int},{_,Range}|Rest]) + when integer(Int),tuple(Range) -> + case Range of + {Lb,Ub} when Int >= Lb, + Int =< Ub -> + intersection_of_size(S,[C1|Rest]); + _ -> + throw({error,{asn1,{illegal_size_constraint,C}}}) + end; +intersection_of_size(S,[C1={_,Range},C2={_,Int}|Rest]) + when integer(Int),tuple(Range) -> + intersection_of_size(S,[C2,C1|Rest]); +intersection_of_size(S,[{_,{Lb1,Ub1}},{_,{Lb2,Ub2}}|Rest]) -> + Lb=greatest_LB(ordsets:from_list([Lb1,Lb2])), + Ub=smallest_UB(ordsets:from_list([Ub1,Ub2])), + intersection_of_size(S,[{'SizeConstraint',{Lb,Ub}}|Rest]); +intersection_of_size(_,SZ) -> + throw({error,{asn1,{illegal_size_constraint,SZ}}}). + +intersection_of_vr(_,[]) -> + []; +intersection_of_vr(_,VR=[_C]) -> + VR; +intersection_of_vr(S,[{_,{Lb1,Ub1}},{_,{Lb2,Ub2}}|Rest]) -> + Lb=greatest_LB(ordsets:from_list([Lb1,Lb2])), + Ub=smallest_UB(ordsets:from_list([Ub1,Ub2])), + intersection_of_vr(S,[{'ValueRange',{Lb,Ub}}|Rest]); +intersection_of_vr(_S,VR) -> + %%error({type,{asn1,{illegal_value_range_constraint,VR}},S}); + throw({error,{asn1,{illegal_value_range_constraint,VR}}}). + +intersection_of_sv(_,[]) -> + []; +intersection_of_sv(_,SV=[_C]) -> + SV; +intersection_of_sv(S,[SV,SV|Rest]) -> + intersection_of_sv(S,[SV|Rest]); +intersection_of_sv(S,[{_,Int},{_,SV}|Rest]) when integer(Int), + list(SV) -> + SV2=intersection_of_sv1(S,Int,SV), + intersection_of_sv(S,[SV2|Rest]); +intersection_of_sv(S,[{_,SV},{_,Int}|Rest]) when integer(Int), + list(SV) -> + SV2=intersection_of_sv1(S,Int,SV), + intersection_of_sv(S,[SV2|Rest]); +intersection_of_sv(S,[{_,SV1},{_,SV2}|Rest]) when list(SV1), + list(SV2) -> + SV3=common_set(SV1,SV2), + intersection_of_sv(S,[SV3|Rest]); +intersection_of_sv(_S,SV) -> + %%error({type,{asn1,{illegal_single_value_constraint,SV}},S}). + throw({error,{asn1,{illegal_single_value_constraint,SV}}}). + +intersection_of_sv1(_S,Int,SV) when integer(Int),list(SV) -> + case lists:member(Int,SV) of + true -> {'SingleValue',Int}; + _ -> + %%error({type,{asn1,{illegal_single_value_constraint,Int,SV}},S}) + throw({error,{asn1,{illegal_single_value_constraint,Int,SV}}}) + end; +intersection_of_sv1(_S,SV1,SV2) -> + %%error({type,{asn1,{illegal_single_value_constraint,SV1,SV2}},S}). + throw({error,{asn1,{illegal_single_value_constraint,SV1,SV2}}}). + +greatest_LB([H]) -> + H; +greatest_LB(L) -> + greatest_LB1(lists:reverse(L)). +greatest_LB1(['MIN',H2|_T])-> + H2; +greatest_LB1([H|_T]) -> + H. +smallest_UB(L) -> + hd(L). + +common_set(SV1,SV2) -> + lists:filter(fun(X)->lists:member(X,SV1) end,SV2). + +is_int_in_vr(Int,{_,{'MIN','MAX'}}) when integer(Int) -> + true; +is_int_in_vr(Int,{_,{'MIN',Ub}}) when integer(Int),Int =< Ub -> + true; +is_int_in_vr(Int,{_,{Lb,'MAX'}}) when integer(Int),Int >= Lb -> + true; +is_int_in_vr(Int,{_,{Lb,Ub}}) when integer(Int),Int >= Lb,Int =< Ub -> + true; +is_int_in_vr(_,_) -> + false. + + + +check_imported(_S,Imodule,Name) -> + case asn1_db:dbget(Imodule,'MODULE') of + undefined -> + io:format("~s.asn1db not found~n",[Imodule]), + io:format("Type ~s imported from non existing module ~s~n",[Name,Imodule]); + Im when record(Im,module) -> + case is_exported(Im,Name) of + false -> + io:format("Imported type ~s not exported from module ~s~n",[Name,Imodule]); + _ -> + ok + end + end, + ok. + +is_exported(Module,Name) when record(Module,module) -> + {exports,Exports} = Module#module.exports, + case Exports of + all -> + true; + [] -> + false; + L when list(L) -> + case lists:keysearch(Name,#'Externaltypereference'.type,Exports) of + false -> false; + _ -> true + end + end. + + + +check_externaltypereference(S,Etref=#'Externaltypereference'{module=Emod})-> + Currmod = S#state.mname, + MergedMods = S#state.inputmodules, + case Emod of + Currmod -> + %% reference to current module or to imported reference + check_reference(S,Etref); + _ -> + %% io:format("Type ~s IMPORTED FROM ~s~n",[Etype,Emod]), + case lists:member(Emod,MergedMods) of + true -> + check_reference(S,Etref); + false -> + Etref + end + end. + +check_reference(S,#'Externaltypereference'{pos=Pos,module=Emod,type=Name}) -> + ModName = S#state.mname, + case asn1_db:dbget(ModName,Name) of + undefined -> + case imported(S,Name) of + {ok,Imodule} -> + check_imported(S,Imodule,Name), + #'Externaltypereference'{module=Imodule,type=Name}; + _ -> + %may be a renamed type in multi file compiling! + {_,T}=renamed_reference(S,Name,Emod), + NewName = asn1ct:get_name_of_def(T), + NewPos = asn1ct:get_pos_of_def(T), + #'Externaltypereference'{pos=NewPos, + module=ModName, + type=NewName} + end; + _ -> + %% cannot do check_type here due to recursive definitions, like + %% S ::= SEQUENCE {a INTEGER, b S}. This implies that references + %% that appear before the definition will be an + %% Externaltypereference in the abstract syntax tree + #'Externaltypereference'{pos=Pos,module=ModName,type=Name} + end. + + +name2Extref(_Mod,Name) when record(Name,'Externaltypereference') -> + Name; +name2Extref(Mod,Name) -> + #'Externaltypereference'{module=Mod,type=Name}. + +get_referenced_type(S,Ext) when record(Ext,'Externaltypereference') -> + case match_parameters(Ext, S#state.parameters) of + Ext -> + #'Externaltypereference'{pos=Pos,module=Emod,type=Etype} = Ext, + case S#state.mname of + Emod -> % a local reference in this module + get_referenced1(S,Emod,Etype,Pos); + _ ->% always when multi file compiling + case lists:member(Emod,S#state.inputmodules) of + true -> + get_referenced1(S,Emod,Etype,Pos); + false -> + get_referenced(S,Emod,Etype,Pos) + end + end; + Other -> + {undefined,Other} + end; +get_referenced_type(S=#state{mname=Emod}, + ERef=#'Externalvaluereference'{pos=P,module=Emod, + value=Eval}) -> + case match_parameters(ERef,S#state.parameters) of + ERef -> + get_referenced1(S,Emod,Eval,P); + OtherERef when record(OtherERef,'Externalvaluereference') -> + get_referenced_type(S,OtherERef); + Value -> + {Emod,Value} + end; +get_referenced_type(S,ERef=#'Externalvaluereference'{pos=Pos,module=Emod, + value=Eval}) -> + case match_parameters(ERef,S#state.parameters) of + ERef -> + case lists:member(Emod,S#state.inputmodules) of + true -> + get_referenced1(S,Emod,Eval,Pos); + false -> + get_referenced(S,Emod,Eval,Pos) + end; + OtherERef -> + get_referenced_type(S,OtherERef) + end; +get_referenced_type(S,#identifier{val=Name,pos=Pos}) -> + get_referenced1(S,undefined,Name,Pos); +get_referenced_type(_S,Type) -> + {undefined,Type}. + +%% get_referenced/3 +%% The referenced entity Ename may in case of an imported parameterized +%% type reference imported entities in the other module, which implies that +%% asn1_db:dbget will fail even though the referenced entity exists. Thus +%% Emod may be the module that imports the entity Ename and not holds the +%% data about Ename. +get_referenced(S,Emod,Ename,Pos) -> + case asn1_db:dbget(Emod,Ename) of + undefined -> + %% May be an imported entity in module Emod +% throw({error,{asn1,{undefined_type_or_value,{Emod,Ename}}}}); + NewS = S#state{module=asn1_db:dbget(Emod,'MODULE')}, + get_imported(NewS,Ename,Emod,Pos); + T when record(T,typedef) -> + Spec = T#typedef.typespec, + case Spec#type.def of + Tref when record(Tref,typereference) -> + Def = #'Externaltypereference'{module=Emod, + type=Tref#typereference.val, + pos=Tref#typereference.pos}, + + + {Emod,T#typedef{typespec=Spec#type{def=Def}}}; + _ -> + {Emod,T} % should add check that T is exported here + end; + V -> {Emod,V} + end. + +get_referenced1(S,ModuleName,Name,Pos) -> + case asn1_db:dbget(S#state.mname,Name) of + undefined -> + %% ModuleName may be other than S#state.mname when + %% multi file compiling is used. + get_imported(S,Name,ModuleName,Pos); + T -> + {S#state.mname,T} + end. + +get_imported(S,Name,Module,Pos) -> + case imported(S,Name) of + {ok,Imodule} -> + case asn1_db:dbget(Imodule,'MODULE') of + undefined -> + throw({error,{asn1,{module_not_found,Imodule}}}); + Im when record(Im,module) -> + case is_exported(Im,Name) of + false -> + throw({error, + {asn1,{not_exported,{Im,Name}}}}); + _ -> + get_referenced_type(S, + #'Externaltypereference' + {module=Imodule, + type=Name,pos=Pos}) + end + end; + _ -> + renamed_reference(S,Name,Module) + end. + +renamed_reference(S,Name,Module) -> + %% first check if there is a renamed type in this module + %% second check if any type was imported with this name + case ets:info(renamed_defs) of + undefined -> throw({error,{asn1,{undefined_type,Name}}}); + _ -> + case ets:match(renamed_defs,{'$1',Name,Module}) of + [] -> + case ets:info(original_imports) of + undefined -> + throw({error,{asn1,{undefined_type,Name}}}); + _ -> + case ets:match(original_imports,{Module,'$1'}) of + [] -> + throw({error,{asn1,{undefined_type,Name}}}); + [[ImportsList]] -> + case get_importmoduleoftype(ImportsList,Name) of + undefined -> + throw({error,{asn1,{undefined_type,Name}}}); + NextMod -> + renamed_reference(S,Name,NextMod) + end + end + end; + [[NewTypeName]] -> + get_referenced1(S,Module,NewTypeName,undefined) + end + end. + +get_importmoduleoftype([I|Is],Name) -> + Index = #'Externaltypereference'.type, + case lists:keysearch(Name,Index,I#'SymbolsFromModule'.symbols) of + {value,_Ref} -> + (I#'SymbolsFromModule'.module)#'Externaltypereference'.type; + _ -> + get_importmoduleoftype(Is,Name) + end; +get_importmoduleoftype([],_) -> + undefined. + + +match_parameters(Name,[]) -> + Name; + +match_parameters(#'Externaltypereference'{type=Name},[{#'Externaltypereference'{type=Name},NewName}|_T]) -> + NewName; +match_parameters(#'Externaltypereference'{type=Name},[{{_,#'Externaltypereference'{type=Name}},NewName}|_T]) -> + NewName; +% match_parameters(#'Externaltypereference'{type=Name},[{#typereference{val=Name},NewName}|T]) -> +% NewName; +% match_parameters(#'Externaltypereference'{type=Name},[{{_,#typereference{val=Name}},NewName}|T]) -> +% NewName; +%match_parameters(#typereference{val=Name},[{#typereference{val=Name},NewName}|T]) -> +% NewName; +match_parameters(#'Externalvaluereference'{value=Name},[{#'Externalvaluereference'{value=Name},NewName}|_T]) -> + NewName; +match_parameters(#'Externalvaluereference'{value=Name},[{{_,#'Externalvaluereference'{value=Name}},NewName}|_T]) -> + NewName; +% match_parameters(#identifier{val=Name},[{#identifier{val=Name},NewName}|T]) -> +% NewName; +% match_parameters(#identifier{val=Name},[{{_,#identifier{val=Name}},NewName}|T]) -> +% NewName; +match_parameters({valueset,#type{def=#'Externaltypereference'{type=Name}}}, + [{{_,#'Externaltypereference'{type=Name}},{valueset,#type{def=NewName}}}|_T]) -> + NewName; +match_parameters({valueset,#type{def=#'Externaltypereference'{type=Name}}}, + [{{_,#'Externaltypereference'{type=Name}},NewName}|_T]) -> + NewName; +% match_parameters({valueset,#type{def=#'Externaltypereference'{type=Name}}}, +% [{{_,#typereference{val=Name}},{valueset,#type{def=NewName}}}|T]) -> +% NewName; +% match_parameters({valueset,#type{def=#'Externaltypereference'{type=Name}}}, +% [{{_,#typereference{val=Name}},NewName}|T]) -> +% NewName; + +match_parameters(Name, [_H|T]) -> + %%io:format("match_parameters(~p,~p)~n",[Name,[H|T]]), + match_parameters(Name,T). + +imported(S,Name) -> + {imports,Ilist} = (S#state.module)#module.imports, + imported1(Name,Ilist). + +imported1(Name, + [#'SymbolsFromModule'{symbols=Symlist, + module=#'Externaltypereference'{type=ModuleName}}|T]) -> + case lists:keysearch(Name,#'Externaltypereference'.type,Symlist) of + {value,_V} -> + {ok,ModuleName}; + _ -> + imported1(Name,T) + end; +imported1(_Name,[]) -> + false. + + +check_integer(_S,[],_C) -> + ok; +check_integer(S,NamedNumberList,_C) -> + case check_unique(NamedNumberList,2) of + [] -> + check_int(S,NamedNumberList,[]); + L when list(L) -> + error({type,{duplicates,L},S}), + unchanged + + end. + +check_int(S,[{'NamedNumber',Id,Num}|T],Acc) when integer(Num) -> + check_int(S,T,[{Id,Num}|Acc]); +check_int(S,[{'NamedNumber',Id,{identifier,_,Name}}|T],Acc) -> + Val = dbget_ex(S,S#state.mname,Name), + check_int(S,[{'NamedNumber',Id,Val#valuedef.value}|T],Acc); +check_int(_S,[],Acc) -> + lists:keysort(2,Acc). + + + +check_bitstring(_S,[],_Constr) -> + []; +check_bitstring(S,NamedNumberList,_Constr) -> + case check_unique(NamedNumberList,2) of + [] -> + check_bitstr(S,NamedNumberList,[]); + L when list(L) -> + error({type,{duplicates,L},S}), + unchanged + end. + +check_bitstr(S,[{'NamedNumber',Id,Num}|T],Acc)when integer(Num) -> + check_bitstr(S,T,[{Id,Num}|Acc]); +check_bitstr(S,[{'NamedNumber',Id,Name}|T],Acc) when atom(Name) -> +%%check_bitstr(S,[{'NamedNumber',Id,{identifier,_,Name}}|T],Acc) -> +%% io:format("asn1ct_check:check_bitstr/3 hej hop ~w~n",[Name]), + Val = dbget_ex(S,S#state.mname,Name), +%% io:format("asn1ct_check:check_bitstr/3: ~w~n",[Val]), + check_bitstr(S,[{'NamedNumber',Id,Val#valuedef.value}|T],Acc); +check_bitstr(S,[],Acc) -> + case check_unique(Acc,2) of + [] -> + lists:keysort(2,Acc); + L when list(L) -> + error({type,{duplicate_values,L},S}), + unchanged + end. + +%%check_bitstring(S,NamedNumberList,Constr) -> +%% NamedNumberList. + +%% Check INSTANCE OF +%% check that DefinedObjectClass is of TYPE-IDENTIFIER class +%% If Constraint is empty make it the general INSTANCE OF type +%% If Constraint is not empty make an inlined type +%% convert INSTANCE OF to the associated type +check_instance_of(S,DefinedObjectClass,Constraint) -> + check_type_identifier(S,DefinedObjectClass), + iof_associated_type(S,Constraint). + + +check_type_identifier(_S,'TYPE-IDENTIFIER') -> + ok; +check_type_identifier(S,Eref=#'Externaltypereference'{}) -> + case get_referenced_type(S,Eref) of + {_,#classdef{name='TYPE-IDENTIFIER'}} -> ok; + {_,TD=#typedef{typespec=#type{def=#'Externaltypereference'{}}}} -> + check_type_identifier(S,(TD#typedef.typespec)#type.def); + _ -> + error({type,{"object set in type INSTANCE OF " + "not of class TYPE-IDENTIFIER",Eref},S}) + end. + +iof_associated_type(S,[]) -> + %% in this case encode/decode functions for INSTANCE OF must be + %% generated + case get(instance_of) of + undefined -> + AssociateSeq = iof_associated_type1(S,[]), + Tag = + case S#state.erule of + ber_bin_v2 -> + [?TAG_CONSTRUCTED(?N_INSTANCE_OF)]; + _ -> [] + end, + TypeDef=#typedef{checked=true, + name='INSTANCE OF', + typespec=#type{tag=Tag, + def=AssociateSeq}}, + asn1_db:dbput(S#state.mname,'INSTANCE OF',TypeDef), + put(instance_of,generate); + _ -> + ok + end, + #'Externaltypereference'{module=S#state.mname,type='INSTANCE OF'}; +iof_associated_type(S,C) -> + iof_associated_type1(S,C). + +iof_associated_type1(S,C) -> + {TableCInf,Comp1Cnstr,Comp2Cnstr,Comp2tablecinf}= + instance_of_constraints(S,C), + + ModuleName = S#state.mname, + Typefield_type= + case C of + [] -> 'ASN1_OPEN_TYPE'; + _ -> {typefield,'Type'} + end, + {ObjIdTag,C1TypeTag}= + case S#state.erule of + ber_bin_v2 -> + {[{'UNIVERSAL',8}], + [#tag{class='UNIVERSAL', + number=6, + type='IMPLICIT', + form=0}]}; + _ -> {[{'UNIVERSAL','INTEGER'}],[]} + end, + TypeIdentifierRef=#'Externaltypereference'{module=ModuleName, + type='TYPE-IDENTIFIER'}, + ObjectIdentifier = + #'ObjectClassFieldType'{classname=TypeIdentifierRef, + class=[], + fieldname={id,[]}, + type={fixedtypevaluefield,id, + #type{def='OBJECT IDENTIFIER'}}}, + Typefield = + #'ObjectClassFieldType'{classname=TypeIdentifierRef, + class=[], + fieldname={'Type',[]}, + type=Typefield_type}, + IOFComponents = + [#'ComponentType'{name='type-id', + typespec=#type{tag=C1TypeTag, + def=ObjectIdentifier, + constraint=Comp1Cnstr}, + prop=mandatory, + tags=ObjIdTag}, + #'ComponentType'{name=value, + typespec=#type{tag=[#tag{class='CONTEXT', + number=0, + type='EXPLICIT', + form=32}], + def=Typefield, + constraint=Comp2Cnstr, + tablecinf=Comp2tablecinf}, + prop=mandatory, + tags=[{'CONTEXT',0}]}], + #'SEQUENCE'{tablecinf=TableCInf, + components=IOFComponents}. + + +%% returns the leading attribute, the constraint of the components and +%% the tablecinf value for the second component. +instance_of_constraints(_,[]) -> + {false,[],[],[]}; +instance_of_constraints(S,#constraint{c={simpletable,Type}}) -> + #type{def=#'Externaltypereference'{type=Name}} = Type, + ModuleName = S#state.mname, + ObjectSetRef=#'Externaltypereference'{module=ModuleName, + type=Name}, + CRel=[{componentrelation,{objectset, + undefined, %% pos + ObjectSetRef}, + [{innermost, + [#'Externalvaluereference'{module=ModuleName, + value=type}]}]}], + TableCInf=#simpletableattributes{objectsetname=Name, + c_name='type-id', + c_index=1, + usedclassfield=id, + uniqueclassfield=id, + valueindex=[]}, + {TableCInf,[{simpletable,Name}],CRel,[{objfun,ObjectSetRef}]}. + +%% Check ENUMERATED +%% **************************************** +%% Check that all values are unique +%% assign values to un-numbered identifiers +%% check that the constraints are allowed and correct +%% put the updated info back into database +check_enumerated(_S,[{Name,Number}|Rest],_Constr) when atom(Name), integer(Number)-> + %% already checked , just return the same list + [{Name,Number}|Rest]; +check_enumerated(S,NamedNumberList,_Constr) -> + check_enum(S,NamedNumberList,[],[]). + +%% identifiers are put in Acc2 +%% returns either [{Name,Number}] or {[{Name,Number}],[{ExtName,ExtNumber}]} +%% the latter is returned if the ENUMERATION contains EXTENSIONMARK +check_enum(S,[{'NamedNumber',Id,Num}|T],Acc1,Acc2) when integer(Num) -> + check_enum(S,T,[{Id,Num}|Acc1],Acc2); +check_enum(S,[{'NamedNumber',Id,{identifier,_,Name}}|T],Acc1,Acc2) -> + Val = dbget_ex(S,S#state.mname,Name), + check_enum(S,[{'NamedNumber',Id,Val#valuedef.value}|T],Acc1,Acc2); +check_enum(S,['EXTENSIONMARK'|T],Acc1,Acc2) -> + NewAcc2 = lists:keysort(2,Acc1), + NewList = enum_number(lists:reverse(Acc2),NewAcc2,0,[]), + { NewList, check_enum(S,T,[],[])}; +check_enum(S,[Id|T],Acc1,Acc2) when atom(Id) -> + check_enum(S,T,Acc1,[Id|Acc2]); +check_enum(_S,[],Acc1,Acc2) -> + NewAcc2 = lists:keysort(2,Acc1), + enum_number(lists:reverse(Acc2),NewAcc2,0,[]). + + +% assign numbers to identifiers , numbers from 0 ... but must not +% be the same as already assigned to NamedNumbers +enum_number([H|T],[{Id,Num}|T2],Cnt,Acc) when Num > Cnt -> + enum_number(T,[{Id,Num}|T2],Cnt+1,[{H,Cnt}|Acc]); +enum_number([H|T],[{Id,Num}|T2],Cnt,Acc) when Num < Cnt -> % negative Num + enum_number(T,T2,Cnt+1,[{H,Cnt},{Id,Num}|Acc]); +enum_number([],L2,_Cnt,Acc) -> + lists:concat([lists:reverse(Acc),L2]); +enum_number(L,[{Id,Num}|T2],Cnt,Acc) -> % Num == Cnt + enum_number(L,T2,Cnt+1,[{Id,Num}|Acc]); +enum_number([H|T],[],Cnt,Acc) -> + enum_number(T,[],Cnt+1,[{H,Cnt}|Acc]). + + +check_boolean(_S,_Constr) -> + ok. + +check_octetstring(_S,_Constr) -> + ok. + +% check all aspects of a SEQUENCE +% - that all component names are unique +% - that all TAGS are ok (when TAG default is applied) +% - that each component is of a valid type +% - that the extension marks are valid + +check_sequence(S,Type,Comps) -> + Components = expand_components(S,Comps), + case check_unique([C||C <- Components ,record(C,'ComponentType')] + ,#'ComponentType'.name) of + [] -> + %% sort_canonical(Components), + Components2 = maybe_automatic_tags(S,Components), + %% check the table constraints from here. The outermost type + %% is Type, the innermost is Comps (the list of components) + NewComps = + case check_each_component(S,Type,Components2) of + NewComponents when list(NewComponents) -> + check_unique_sequence_tags(S,NewComponents), + NewComponents; + Ret = {NewComponents,NewEcomps} -> + TagComps = NewComponents ++ + [Comp#'ComponentType'{prop='OPTIONAL'}|| Comp <- NewEcomps], + %% extension components are like optionals when it comes to tagging + check_unique_sequence_tags(S,TagComps), + Ret + end, + %% CRelInf is the "leading attribute" information + %% necessary for code generating of the look up in the + %% object set table, + %% i.e. getenc_ObjectSet/getdec_ObjectSet. + %% {objfun,ERef} tuple added in NewComps2 in tablecinf + %% field in type record of component relation constrained + %% type +% io:format("NewComps: ~p~n",[NewComps]), + {CRelInf,NewComps2} = componentrelation_leadingattr(S,NewComps), +% io:format("CRelInf: ~p~n",[CRelInf]), +% io:format("NewComps2: ~p~n",[NewComps2]), + %% CompListWithTblInf has got a lot unecessary info about + %% the involved class removed, as the class of the object + %% set. + CompListWithTblInf = get_tableconstraint_info(S,Type,NewComps2), +% io:format("CompListWithTblInf: ~p~n",[CompListWithTblInf]), + {CRelInf,CompListWithTblInf}; + Dupl -> + throw({error,{asn1,{duplicate_components,Dupl}}}) + end. + +expand_components(S, [{'COMPONENTS OF',Type}|T]) -> + CompList = + case get_referenced_type(S,Type#type.def) of + {_,#typedef{typespec=#type{def=Seq}}} when record(Seq,'SEQUENCE') -> + case Seq#'SEQUENCE'.components of + {Root,_Ext} -> Root; + Root -> Root + end; + Err -> throw({error,{asn1,{illegal_COMPONENTS_OF,Err}}}) + end, + expand_components(S,CompList) ++ expand_components(S,T); +expand_components(S,[H|T]) -> + [H|expand_components(S,T)]; +expand_components(_,[]) -> + []. + +check_unique_sequence_tags(S,[#'ComponentType'{prop=mandatory}|Rest]) -> + check_unique_sequence_tags(S,Rest); +check_unique_sequence_tags(S,[C|Rest]) when record(C,'ComponentType') -> + check_unique_sequence_tags1(S,Rest,[C]);% optional or default +check_unique_sequence_tags(S,[_ExtensionMarker|Rest]) -> + check_unique_sequence_tags(S,Rest); +check_unique_sequence_tags(_S,[]) -> + true. + +check_unique_sequence_tags1(S,[C|Rest],Acc) when record(C,'ComponentType') -> + case C#'ComponentType'.prop of + mandatory -> + check_unique_tags(S,lists:reverse([C|Acc])), + check_unique_sequence_tags(S,Rest); + _ -> + check_unique_sequence_tags1(S,Rest,[C|Acc]) % default or optional + end; +check_unique_sequence_tags1(S,[H|Rest],Acc) -> + check_unique_sequence_tags1(S,Rest,[H|Acc]); +check_unique_sequence_tags1(S,[],Acc) -> + check_unique_tags(S,lists:reverse(Acc)). + +check_sequenceof(S,Type,Component) when record(Component,type) -> + check_type(S,Type,Component). + +check_set(S,Type,Components) -> + {TableCInf,NewComponents} = check_sequence(S,Type,Components), + case lists:member(der,S#state.options) of + true when S#state.erule == ber; + S#state.erule == ber_bin -> + {Sorted,SortedComponents} = + sort_components(S#state.tname, + (S#state.module)#module.tagdefault, + NewComponents), + {Sorted,TableCInf,SortedComponents}; + _ -> + {false,TableCInf,NewComponents} + end. + +sort_components(_TypeName,'AUTOMATIC',Components) -> + {true,Components}; +sort_components(TypeName,_TagDefault,Components) -> + case untagged_choice(Components) of + false -> + {true,sort_components1(TypeName,Components,[],[],[],[])}; + true -> + {dynamic,Components} % sort in run-time + end. + +sort_components1(TypeName,[C=#'ComponentType'{tags=[{'UNIVERSAL',_}|_R]}|Cs], + UnivAcc,ApplAcc,ContAcc,PrivAcc) -> + sort_components1(TypeName,Cs,[C|UnivAcc],ApplAcc,ContAcc,PrivAcc); +sort_components1(TypeName,[C=#'ComponentType'{tags=[{'APPLICATION',_}|_R]}|Cs], + UnivAcc,ApplAcc,ContAcc,PrivAcc) -> + sort_components1(TypeName,Cs,UnivAcc,[C|ApplAcc],ContAcc,PrivAcc); +sort_components1(TypeName,[C=#'ComponentType'{tags=[{'CONTEXT',_}|_R]}|Cs], + UnivAcc,ApplAcc,ContAcc,PrivAcc) -> + sort_components1(TypeName,Cs,UnivAcc,ApplAcc,[C|ContAcc],PrivAcc); +sort_components1(TypeName,[C=#'ComponentType'{tags=[{'PRIVATE',_}|_R]}|Cs], + UnivAcc,ApplAcc,ContAcc,PrivAcc) -> + sort_components1(TypeName,Cs,UnivAcc,ApplAcc,ContAcc,[C|PrivAcc]); +sort_components1(TypeName,[],UnivAcc,ApplAcc,ContAcc,PrivAcc) -> + I = #'ComponentType'.tags, + ascending_order_check(TypeName,sort_universal_type(UnivAcc)) ++ + ascending_order_check(TypeName,lists:keysort(I,ApplAcc)) ++ + ascending_order_check(TypeName,lists:keysort(I,ContAcc)) ++ + ascending_order_check(TypeName,lists:keysort(I,PrivAcc)). + +ascending_order_check(TypeName,Components) -> + ascending_order_check1(TypeName,Components), + Components. + +ascending_order_check1(TypeName, + [C1 = #'ComponentType'{tags=[{_,T}|_]}, + C2 = #'ComponentType'{tags=[{_,T}|_]}|Rest]) -> + io:format("WARNING: Indistinct tag ~p in SET ~p, components ~p and ~p~n", + [T,TypeName,C1#'ComponentType'.name,C2#'ComponentType'.name]), + ascending_order_check1(TypeName,[C2|Rest]); +ascending_order_check1(TypeName, + [C1 = #'ComponentType'{tags=[{'UNIVERSAL',T1}|_]}, + C2 = #'ComponentType'{tags=[{'UNIVERSAL',T2}|_]}|Rest]) -> + case (asn1ct_gen_ber:decode_type(T1) == asn1ct_gen_ber:decode_type(T2)) of + true -> + io:format("WARNING: Indistinct tags ~p and ~p in" + " SET ~p, components ~p and ~p~n", + [T1,T2,TypeName,C1#'ComponentType'.name, + C2#'ComponentType'.name]), + ascending_order_check1(TypeName,[C2|Rest]); + _ -> + ascending_order_check1(TypeName,[C2|Rest]) + end; +ascending_order_check1(N,[_|Rest]) -> + ascending_order_check1(N,Rest); +ascending_order_check1(_,[_]) -> + ok; +ascending_order_check1(_,[]) -> + ok. + +sort_universal_type(Components) -> + List = lists:map(fun(C) -> + #'ComponentType'{tags=[{_,T}|_]} = C, + {asn1ct_gen_ber:decode_type(T),C} + end, + Components), + SortedList = lists:keysort(1,List), + lists:map(fun(X)->element(2,X) end,SortedList). + +untagged_choice([#'ComponentType'{typespec=#type{tag=[],def={'CHOICE',_}}}|_Rest]) -> + true; +untagged_choice([_|Rest]) -> + untagged_choice(Rest); +untagged_choice([]) -> + false. + +check_setof(S,Type,Component) when record(Component,type) -> + check_type(S,Type,Component). + +check_restrictedstring(_S,_Def,_Constr) -> + ok. + +check_objectidentifier(_S,_Constr) -> + ok. + +% check all aspects of a CHOICE +% - that all alternative names are unique +% - that all TAGS are ok (when TAG default is applied) +% - that each alternative is of a valid type +% - that the extension marks are valid +check_choice(S,Type,Components) when list(Components) -> + case check_unique([C||C <- Components, + record(C,'ComponentType')],#'ComponentType'.name) of + [] -> + %% sort_canonical(Components), + Components2 = maybe_automatic_tags(S,Components), + %NewComps = + case check_each_alternative(S,Type,Components2) of + {NewComponents,NewEcomps} -> + check_unique_tags(S,NewComponents ++ NewEcomps), + {NewComponents,NewEcomps}; + NewComponents -> + check_unique_tags(S,NewComponents), + NewComponents + end; +%% CompListWithTblInf = get_tableconstraint_info(S,Type,NewComps); + Dupl -> + throw({error,{asn1,{duplicate_choice_alternatives,Dupl}}}) + end; +check_choice(_S,_,[]) -> + []. + +%% probably dead code that should be removed +%%maybe_automatic_tags(S,{Rc,Ec}) -> +%% {maybe_automatic_tags1(S,Rc,0),maybe_automatic_tags1(S,Ec,length(Rc))}; +maybe_automatic_tags(#state{erule=per},C) -> + C; +maybe_automatic_tags(#state{erule=per_bin},C) -> + C; +maybe_automatic_tags(S,C) -> + maybe_automatic_tags1(S,C,0). + +maybe_automatic_tags1(S,C,TagNo) -> + case (S#state.module)#module.tagdefault of + 'AUTOMATIC' -> + generate_automatic_tags(S,C,TagNo); + _ -> + %% maybe is the module a multi file module were only some of + %% the modules have defaulttag AUTOMATIC TAGS then the names + %% of those types are saved in the table automatic_tags + Name= S#state.tname, + case is_automatic_tagged_in_multi_file(Name) of + true -> + generate_automatic_tags(S,C,TagNo); + false -> + C + end + end. + +is_automatic_tagged_in_multi_file(Name) -> + case ets:info(automatic_tags) of + undefined -> + %% this case when not multifile compilation + false; + _ -> + case ets:member(automatic_tags,Name) of + true -> + true; + _ -> + false + end + end. + +generate_automatic_tags(_S,C,TagNo) -> + case any_manual_tag(C) of + true -> + C; + false -> + generate_automatic_tags1(C,TagNo) + end. + +generate_automatic_tags1([H|T],TagNo) when record(H,'ComponentType') -> + #'ComponentType'{typespec=Ts} = H, + NewTs = Ts#type{tag=[#tag{class='CONTEXT', + number=TagNo, + type={default,'IMPLICIT'}, + form= 0 }]}, % PRIMITIVE + [H#'ComponentType'{typespec=NewTs}|generate_automatic_tags1(T,TagNo+1)]; +generate_automatic_tags1([ExtMark|T],TagNo) -> % EXTENSIONMARK + [ExtMark | generate_automatic_tags1(T,TagNo)]; +generate_automatic_tags1([],_) -> + []. + +any_manual_tag([#'ComponentType'{typespec=#type{tag=[]}}|Rest]) -> + any_manual_tag(Rest); +any_manual_tag([{'EXTENSIONMARK',_,_}|Rest]) -> + any_manual_tag(Rest); +any_manual_tag([_|_Rest]) -> + true; +any_manual_tag([]) -> + false. + + +check_unique_tags(S,C) -> + case (S#state.module)#module.tagdefault of + 'AUTOMATIC' -> + case any_manual_tag(C) of + false -> true; + _ -> collect_and_sort_tags(C,[]) + end; + _ -> + collect_and_sort_tags(C,[]) + end. + +collect_and_sort_tags([C|Rest],Acc) when record(C,'ComponentType') -> + collect_and_sort_tags(Rest,C#'ComponentType'.tags ++ Acc); +collect_and_sort_tags([_|Rest],Acc) -> + collect_and_sort_tags(Rest,Acc); +collect_and_sort_tags([],Acc) -> + {Dupl,_}= lists:mapfoldl(fun(El,El)->{{dup,El},El};(El,_Prev)-> {El,El} end,notag,lists:sort(Acc)), + Dupl2 = [Dup|| {dup,Dup} <- Dupl], + if + length(Dupl2) > 0 -> + throw({error,{asn1,{duplicates_of_the_tags,Dupl2}}}); + true -> + true + end. + +check_unique(L,Pos) -> + Slist = lists:keysort(Pos,L), + check_unique2(Slist,Pos,[]). + +check_unique2([A,B|T],Pos,Acc) when element(Pos,A) == element(Pos,B) -> + check_unique2([B|T],Pos,[element(Pos,B)|Acc]); +check_unique2([_|T],Pos,Acc) -> + check_unique2(T,Pos,Acc); +check_unique2([],_,Acc) -> + lists:reverse(Acc). + +check_each_component(S,Type,{Rlist,ExtList}) -> + {check_each_component(S,Type,Rlist), + check_each_component(S,Type,ExtList)}; +check_each_component(S,Type,Components) -> + check_each_component(S,Type,Components,[],[],noext). + +check_each_component(S = #state{abscomppath=Path,recordtopname=TopName},Type, + [C|Ct],Acc,Extacc,Ext) when record(C,'ComponentType') -> + #'ComponentType'{name=Cname,typespec=Ts,prop=Prop} = C, + NewAbsCPath = + case Ts#type.def of + #'Externaltypereference'{} -> []; + _ -> [Cname|Path] + end, + CheckedTs = check_type(S#state{abscomppath=NewAbsCPath, + recordtopname=[Cname|TopName]},Type,Ts), + NewTags = get_taglist(S,CheckedTs), + + NewProp = +% case lists:member(der,S#state.options) of +% true -> +% True -> + case normalize_value(S,CheckedTs,Prop,[Cname|TopName]) of + mandatory -> mandatory; + 'OPTIONAL' -> 'OPTIONAL'; + DefaultValue -> {'DEFAULT',DefaultValue} + end, +% _ -> +% Prop +% end, + NewC = C#'ComponentType'{typespec=CheckedTs,prop=NewProp,tags=NewTags}, + case Ext of + noext -> + check_each_component(S,Type,Ct,[NewC|Acc],Extacc,Ext); + ext -> + check_each_component(S,Type,Ct,Acc,[NewC|Extacc],Ext) + end; +check_each_component(S,Type,[_|Ct],Acc,Extacc,noext) -> % skip 'EXTENSIONMARK' + check_each_component(S,Type,Ct,Acc,Extacc,ext); +check_each_component(_S,_,[_C|_Ct],_,_,ext) -> % skip 'EXTENSIONMARK' + throw({error,{asn1,{too_many_extension_marks}}}); +check_each_component(_S,_,[],Acc,Extacc,ext) -> + {lists:reverse(Acc),lists:reverse(Extacc)}; +check_each_component(_S,_,[],Acc,_,noext) -> + lists:reverse(Acc). + +check_each_alternative(S,Type,{Rlist,ExtList}) -> + {check_each_alternative(S,Type,Rlist), + check_each_alternative(S,Type,ExtList)}; +check_each_alternative(S,Type,[C|Ct]) -> + check_each_alternative(S,Type,[C|Ct],[],[],noext). + +check_each_alternative(S=#state{abscomppath=Path,recordtopname=TopName},Type,[C|Ct], + Acc,Extacc,Ext) when record(C,'ComponentType') -> + #'ComponentType'{name=Cname,typespec=Ts,prop=_Prop} = C, + NewAbsCPath = + case Ts#type.def of + #'Externaltypereference'{} -> []; + _ -> [Cname|Path] + end, + NewState = + S#state{abscomppath=NewAbsCPath,recordtopname=[Cname|TopName]}, + CheckedTs = check_type(NewState,Type,Ts), + NewTags = get_taglist(S,CheckedTs), + NewC = C#'ComponentType'{typespec=CheckedTs,tags=NewTags}, + case Ext of + noext -> + check_each_alternative(S,Type,Ct,[NewC|Acc],Extacc,Ext); + ext -> + check_each_alternative(S,Type,Ct,Acc,[NewC|Extacc],Ext) + end; + +check_each_alternative(S,Type,[_|Ct],Acc,Extacc,noext) -> % skip 'EXTENSIONMARK' + check_each_alternative(S,Type,Ct,Acc,Extacc,ext); +check_each_alternative(_S,_,[_C|_Ct],_,_,ext) -> % skip 'EXTENSIONMARK' + throw({error,{asn1,{too_many_extension_marks}}}); +check_each_alternative(_S,_,[],Acc,Extacc,ext) -> + {lists:reverse(Acc),lists:reverse(Extacc)}; +check_each_alternative(_S,_,[],Acc,_,noext) -> + lists:reverse(Acc). + +%% componentrelation_leadingattr/2 searches the structure for table +%% constraints, if any is found componentrelation_leadingattr/5 is +%% called. +componentrelation_leadingattr(S,CompList) -> +% {Cs1,Cs2} = + Cs = + case CompList of + {Components,EComponents} when list(Components) -> +% {Components,Components}; + Components ++ EComponents; + CompList when list(CompList) -> +% {CompList,CompList} + CompList + end, +% case any_simple_table(S,Cs1,[]) of + + %% get_simple_table_if_used/2 should find out whether there are any + %% component relation constraints in the entire tree of Cs1 that + %% relates to this level. It returns information about the simple + %% table constraint necessary for the the call to + %% componentrelation_leadingattr/6. The step when the leading + %% attribute and the syntax tree is modified to support the code + %% generating. + case get_simple_table_if_used(S,Cs) of + [] -> {false,CompList}; + STList -> +% componentrelation_leadingattr(S,Cs1,Cs2,STList,[],[]) + componentrelation_leadingattr(S,Cs,Cs,STList,[],[]) + end. + +%% componentrelation_leadingattr/6 when all components are searched +%% the new modified components are returned together with the "leading +%% attribute" information, which later is stored in the tablecinf +%% field in the SEQUENCE/SET record. The "leading attribute" +%% information is used to generate the lookup in the object set +%% table. The other information gathered in the #type.tablecinf field +%% is used in code generating phase too, to recognice the proper +%% components for "open type" encoding and to propagate the result of +%% the object set lookup when needed. +componentrelation_leadingattr(_,[],_CompList,_,[],NewCompList) -> + {false,lists:reverse(NewCompList)}; +componentrelation_leadingattr(_,[],_CompList,_,LeadingAttr,NewCompList) -> + {lists:last(LeadingAttr),lists:reverse(NewCompList)}; %send all info in Ts later +componentrelation_leadingattr(S,[C|Cs],CompList,STList,Acc,CompAcc) -> + {LAAcc,NewC} = + case catch componentrelation1(S,C#'ComponentType'.typespec, + [C#'ComponentType'.name]) of + {'EXIT',_} -> + {[],C}; + {CRI=[{_A1,_B1,_C1,_D1}|_Rest],NewTSpec} -> + %% {ObjectSet,AtPath,ClassDef,Path} + %% _A1 is a reference to the object set of the + %% component relation constraint. + %% _B1 is the path of names in the at-list of the + %% component relation constraint. + %% _C1 is the class definition of the + %% ObjectClassFieldType. + %% _D1 is the path of components that was traversed to + %% find this constraint. + case leading_attr_index(S,CompList,CRI, + lists:reverse(S#state.abscomppath),[]) of + [] -> + {[],C}; + [{ObjSet,Attr,N,ClassDef,_Path,ValueIndex}|_NewRest] -> + OS = object_set_mod_name(S,ObjSet), + UniqueFieldName = + case (catch get_unique_fieldname(#classdef{typespec=ClassDef})) of + {error,'__undefined_'} -> + no_unique; + {asn1,Msg,_} -> + error({type,Msg,S}); + Other -> Other + end, +% UsedFieldName = get_used_fieldname(S,Attr,STList), + %% Res should be done differently: even though + %% a unique field name exists it is not + %% certain that the ObjectClassFieldType of + %% the simple table constraint picks that + %% class field. + Res = #simpletableattributes{objectsetname=OS, +%% c_name=asn1ct_gen:un_hyphen_var(Attr), + c_name=Attr, + c_index=N, + usedclassfield=UniqueFieldName, + uniqueclassfield=UniqueFieldName, + valueindex=ValueIndex}, + {[Res],C#'ComponentType'{typespec=NewTSpec}} + end; + _ -> + %% no constraint was found + {[],C} + end, + componentrelation_leadingattr(S,Cs,CompList,STList,LAAcc++Acc, + [NewC|CompAcc]). + +object_set_mod_name(_S,ObjSet) when atom(ObjSet) -> + ObjSet; +object_set_mod_name(#state{mname=M}, + #'Externaltypereference'{module=M,type=T}) -> + T; +object_set_mod_name(S,#'Externaltypereference'{module=M,type=T}) -> + case lists:member(M,S#state.inputmodules) of + true -> + T; + false -> + {M,T} + end. + +%% get_used_fieldname gets the used field of the class referenced by +%% the ObjectClassFieldType construct in the simple table constraint +%% corresponding to the component relation constraint that depends on +%% it. +% get_used_fieldname(_S,CName,[{[CName|_Rest],_,ClFieldName}|_RestSimpleT]) -> +% ClFieldName; +% get_used_fieldname(S,CName,[_SimpleTC|Rest]) -> +% get_used_fieldname(S,CName,Rest); +% get_used_fieldname(S,_,[]) -> +% error({type,"Error in Simple table constraint",S}). + +%% any_simple_table/3 checks if any of the components on this level is +%% constrained by a simple table constraint. It returns a list of +%% tuples with three elements. It is a name path to the place in the +%% type structure where the constraint is, and the name of the object +%% set and the referenced field in the class. +% any_simple_table(S = #state{mname=M,abscomppath=Path}, +% [#'ComponentType'{name=Name,typespec=Type}|Cs],Acc) -> +% Constraint = Type#type.constraint, +% case lists:keysearch(simpletable,1,Constraint) of +% {value,{_,#type{def=Ref}}} -> +% %% This ObjectClassFieldType, which has a simple table +% %% constraint, must pick a fixed type value, mustn't it ? +% {ClassDef,[{_,ClassFieldName}]} = Type#type.def, +% ST = +% case Ref of +% #'Externaltypereference'{module=M,type=ObjSetName} -> +% {[Name|Path],ObjSetName,ClassFieldName}; +% _ -> +% {[Name|Path],Ref,ClassFieldName} +% end, +% any_simple_table(S,Cs,[ST|Acc]); +% false -> +% any_simple_table(S,Cs,Acc) +% end; +% any_simple_table(_,[],Acc) -> +% lists:reverse(Acc); +% any_simple_table(S,[_|Cs],Acc) -> +% any_simple_table(S,Cs,Acc). + +%% get_simple_table_if_used/2 searches the structure of Cs for any +%% component relation constraints due to the present level of the +%% structure. If there are any, the necessary information for code +%% generation of the look up functionality in the object set table are +%% returned. +get_simple_table_if_used(S,Cs) -> + CNames = lists:map(fun(#'ComponentType'{name=Name}) -> Name; + (_) -> [] %% in case of extension marks + end, + Cs), + RefedSimpleTable=any_component_relation(S,Cs,CNames,[],[]), + get_simple_table_info(S,Cs,remove_doubles(RefedSimpleTable)). + +remove_doubles(L) -> + remove_doubles(L,[]). +remove_doubles([H|T],Acc) -> + NewT = remove_doubles1(H,T), + remove_doubles(NewT,[H|Acc]); +remove_doubles([],Acc) -> + Acc. + +remove_doubles1(El,L) -> + case lists:delete(El,L) of + L -> L; + NewL -> remove_doubles1(El,NewL) + end. + +%% get_simple_table_info searches the commponents Cs by the path from +%% an at-list (third argument), and follows into a component of it if +%% necessary, to get information needed for code generating. +%% +%% Returns a list of tuples with three elements. It holds a list of +%% atoms that is the path, the name of the field of the class that are +%% referred to in the ObjectClassFieldType, and the name of the unique +%% field of the class of the ObjectClassFieldType. +%% +% %% The level information outermost/innermost must be kept. There are +% %% at least two possibilities to cover here for an outermost case: 1) +% %% Both the simple table and the component relation have a common path +% %% at least one step below the outermost level, i.e. the leading +% %% information shall be on a sub level. 2) They don't have any common +% %% path. +get_simple_table_info(S,Cs,[AtList|Rest]) -> +%% [get_simple_table_info1(S,Cs,AtList,S#state.abscomppath)|get_simple_table_info(S,Cs,Rest)]; + [get_simple_table_info1(S,Cs,AtList,[])|get_simple_table_info(S,Cs,Rest)]; +get_simple_table_info(_,_,[]) -> + []. +get_simple_table_info1(S,Cs,[Cname|Cnames],Path) when list(Cs) -> + case lists:keysearch(Cname,#'ComponentType'.name,Cs) of + {value,C} -> + get_simple_table_info1(S,C,Cnames,[Cname|Path]); + _ -> + error({type,"Missing expected simple table constraint",S}) + end; +get_simple_table_info1(S,#'ComponentType'{typespec=TS},[],Path) -> + %% In this component there must be a simple table constraint + %% o.w. the asn1 code is wrong. + #type{def=OCFT,constraint=Cnstr} = TS, + case Cnstr of + [{simpletable,_OSRef}]�-> + #'ObjectClassFieldType'{classname=ClRef, + class=ObjectClass, + fieldname=FieldName} = OCFT, +% #'ObjectClassFieldType'{ObjectClass,FieldType} = ObjectClassFieldType, + ObjectClassFieldName = + case FieldName of + {LastFieldName,[]} -> LastFieldName; + {_FirstFieldName,FieldNames} -> + lists:last(FieldNames) + end, + %%ObjectClassFieldName is the last element in the dotted + %%list of the ObjectClassFieldType. The last element may + %%be of another class, that is referenced from the class + %%of the ObjectClassFieldType + ClassDef = + case ObjectClass of + [] -> + {_,CDef}=get_referenced_type(S,ClRef), + CDef; + _ -> #classdef{typespec=ObjectClass} + end, + UniqueName = + case (catch get_unique_fieldname(ClassDef)) of + {error,'__undefined_'} -> no_unique; + {asn1,Msg,_} -> + error({type,Msg,S}); + Other -> Other + end, + {lists:reverse(Path),ObjectClassFieldName,UniqueName}; + _ -> + error({type,{asn1,"missing expected simple table constraint", + Cnstr},S}) + end; +get_simple_table_info1(S,#'ComponentType'{typespec=TS},Cnames,Path) -> + Components = get_atlist_components(TS#type.def), + get_simple_table_info1(S,Components,Cnames,Path). + +%% any_component_relation searches for all component relation +%% constraints that refers to the actual level and returns a list of +%% the "name path" in the at-list to the component relation constraint +%% that must refer to a simple table constraint. The list is empty if +%% no component relation constraints were found. +%% +%% NamePath has the names of all components that are followed from the +%% beginning of the search. CNames holds the names of all components +%% of the start level, this info is used if an outermost at-notation +%% is found to check the validity of the at-list. +any_component_relation(S,[C|Cs],CNames,NamePath,Acc) -> + CName = C#'ComponentType'.name, + Type = C#'ComponentType'.typespec, + CRelPath = + case Type#type.constraint of + [{componentrelation,_,AtNotation}] -> + %% Found component relation constraint, now check + %% whether this constraint is relevant for the level + %% where the search started + AtNot = extract_at_notation(AtNotation), + %% evaluate_atpath returns the relative path to the + %% simple table constraint from where the component + %% relation is found. + evaluate_atpath(S#state.abscomppath,NamePath,CNames,AtNot); + _ -> + [] + end, + InnerAcc = + case {Type#type.inlined, + asn1ct_gen:type(asn1ct_gen:get_inner(Type#type.def))} of + {no,{constructed,bif}} -> + InnerCs = + case get_components(Type#type.def) of + {IC1,_IC2} -> IC1 ++ IC1; + IC -> IC + end, + %% here we are interested in components of an + %% SEQUENCE/SET OF as well as SEQUENCE, SET and CHOICE + any_component_relation(S,InnerCs,CNames,[CName|NamePath],[]); + _ -> + [] + end, + any_component_relation(S,Cs,CNames,NamePath,InnerAcc++CRelPath++Acc); +any_component_relation(_,[],_,_,Acc) -> + Acc. + +%% evaluate_atpath/4 finds out whether the at notation refers to the +%% search level. The list of referenced names in the AtNot list shall +%% begin with a name that exists on the level it refers to. If the +%% found AtPath is refering to the same sub-branch as the simple table +%% has, then there shall not be any leading attribute info on this +%% level. +evaluate_atpath(_,[],Cnames,{innermost,AtPath=[Ref|_Refs]}) -> + %% any innermost constraint found deeper in the structure is + %% ignored. + case lists:member(Ref,Cnames) of + true -> [AtPath]; + false -> [] + end; +%% In this case must check that the AtPath doesn't step any step of +%% the NamePath, in that case the constraint will be handled in an +%% inner level. +evaluate_atpath(TopPath,NamePath,Cnames,{outermost,AtPath=[_Ref|_Refs]}) -> + AtPathBelowTop = + case TopPath of + [] -> AtPath; + _ -> + case lists:prefix(TopPath,AtPath) of + true -> + lists:subtract(AtPath,TopPath); + _ -> [] + end + end, + case {NamePath,AtPathBelowTop} of + {[H|_T1],[H|_T2]} -> []; % this must be handled in lower level + {_,[]} -> [];% this must be handled in an above level + {_,[H|_T]} -> + case lists:member(H,Cnames) of + true -> [AtPathBelowTop]; + _ -> error({type,{asn1,"failed to analyze at-path",AtPath}}) + end + end; +evaluate_atpath(_,_,_,_) -> + []. + +%% Type may be any of SEQUENCE, SET, CHOICE, SEQUENCE OF, SET OF but +%% only the three first have valid components. +get_atlist_components(Def) -> + get_components(atlist,Def). + +get_components(Def) -> + get_components(any,Def). + +get_components(_,#'SEQUENCE'{components=Cs}) -> + Cs; +get_components(_,#'SET'{components=Cs}) -> + Cs; +get_components(_,{'CHOICE',Cs}) -> + Cs; +get_components(any,{'SEQUENCE OF',#type{def=Def}}) -> + get_components(any,Def); +get_components(any,{'SET OF',#type{def=Def}}) -> + get_components(any,Def); +get_components(_,_) -> + []. + + +extract_at_notation([{Level,[#'Externalvaluereference'{value=Name}|Rest]}]) -> + {Level,[Name|extract_at_notation1(Rest)]}; +extract_at_notation(At) -> + exit({error,{asn1,{at_notation,At}}}). +extract_at_notation1([#'Externalvaluereference'{value=Name}|Rest]) -> + [Name|extract_at_notation1(Rest)]; +extract_at_notation1([]) -> + []. + +%% componentrelation1/1 identifies all componentrelation constraints +%% that exist in C or in the substructure of C. Info about the found +%% constraints are returned in a list. It is ObjectSet, the reference +%% to the object set, AttrPath, the name atoms extracted from the +%% at-list in the component relation constraint, ClassDef, the +%% objectclass record of the class of the ObjectClassFieldType, Path, +%% that is the component name "path" from the searched level to this +%% constraint. +%% +%% The function is called with one component of the type in turn and +%% with the component name in Path at the first call. When called from +%% within, the name of the inner component is added to Path. +componentrelation1(S,C = #type{def=Def,constraint=Constraint,tablecinf=TCI}, + Path) -> + Ret = + case Constraint of + [{componentrelation,{_,_,ObjectSet},AtList}|_Rest] -> + [{_,AL=[#'Externalvaluereference'{}|_R1]}|_R2] = AtList, + %% Note: if Path is longer than one,i.e. it is within + %% an inner type of the actual level, then the only + %% relevant at-list is of "outermost" type. +%% #'ObjectClassFieldType'{class=ClassDef} = Def, + ClassDef = get_ObjectClassFieldType_classdef(S,Def), + AtPath = + lists:map(fun(#'Externalvaluereference'{value=V})->V end, + AL), + {[{ObjectSet,AtPath,ClassDef,Path}],Def}; + _Other -> + %% check the inner type of component + innertype_comprel(S,Def,Path) + end, + case Ret of + nofunobj -> + nofunobj; %% ignored by caller + {CRelI=[{ObjSet,_,_,_}],NewDef} -> %% + TCItmp = lists:subtract(TCI,[{objfun,ObjSet}]), + {CRelI,C#type{tablecinf=[{objfun,ObjSet}|TCItmp],def=NewDef}}; + {CompRelInf,NewDef} -> %% more than one tuple in CompRelInf + TCItmp = lists:subtract(TCI,[{objfun,anyset}]), + {CompRelInf,C#type{tablecinf=[{objfun,anyset}|TCItmp],def=NewDef}} + end. + +innertype_comprel(S,{'SEQUENCE OF',Type},Path) -> + case innertype_comprel1(S,Type,Path) of + nofunobj -> + nofunobj; + {CompRelInf,NewType} -> + {CompRelInf,{'SEQUENCE OF',NewType}} + end; +innertype_comprel(S,{'SET OF',Type},Path) -> + case innertype_comprel1(S,Type,Path) of + nofunobj -> + nofunobj; + {CompRelInf,NewType} -> + {CompRelInf,{'SET OF',NewType}} + end; +innertype_comprel(S,{'CHOICE',CTypeList},Path) -> + case componentlist_comprel(S,CTypeList,[],Path,[]) of + nofunobj -> + nofunobj; + {CompRelInf,NewCs} -> + {CompRelInf,{'CHOICE',NewCs}} + end; +innertype_comprel(S,Seq = #'SEQUENCE'{components=Cs},Path) -> + case componentlist_comprel(S,Cs,[],Path,[]) of + nofunobj -> + nofunobj; + {CompRelInf,NewCs} -> + {CompRelInf,Seq#'SEQUENCE'{components=NewCs}} + end; +innertype_comprel(S,Set = #'SET'{components=Cs},Path) -> + case componentlist_comprel(S,Cs,[],Path,[]) of + nofunobj -> + nofunobj; + {CompRelInf,NewCs} -> + {CompRelInf,Set#'SET'{components=NewCs}} + end; +innertype_comprel(_,_,_) -> + nofunobj. + +componentlist_comprel(S,[C = #'ComponentType'{name=Name,typespec=Type}|Cs], + Acc,Path,NewCL) -> + case catch componentrelation1(S,Type,Path++[Name]) of + {'EXIT',_} -> + componentlist_comprel(S,Cs,Acc,Path,[C|NewCL]); + nofunobj -> + componentlist_comprel(S,Cs,Acc,Path,[C|NewCL]); + {CRelInf,NewType} -> + componentlist_comprel(S,Cs,CRelInf++Acc,Path, + [C#'ComponentType'{typespec=NewType}|NewCL]) + end; +componentlist_comprel(_,[],Acc,_,NewCL) -> + case Acc of + [] -> + nofunobj; + _ -> + {Acc,lists:reverse(NewCL)} + end. + +innertype_comprel1(S,T = #type{def=Def,constraint=Cons,tablecinf=TCI},Path) -> + Ret = + case Cons of + [{componentrelation,{_,_,ObjectSet},AtList}|_Rest] -> + %% This AtList must have an "outermost" at sign to be + %% relevent here. + [{_,AL=[#'Externalvaluereference'{value=_Attr}|_R1]}|_R2] + = AtList, +%% #'ObjectClassFieldType'{class=ClassDef} = Def, + ClassDef = get_ObjectClassFieldType_classdef(S,Def), + AtPath = + lists:map(fun(#'Externalvaluereference'{value=V})->V end, + AL), + [{ObjectSet,AtPath,ClassDef,Path}]; + _ -> + innertype_comprel(S,Def,Path) + end, + case Ret of + nofunobj -> nofunobj; + L = [{ObjSet,_,_,_}] -> + TCItmp = lists:subtract(TCI,[{objfun,ObjSet}]), + {L,T#type{tablecinf=[{objfun,ObjSet}|TCItmp]}}; + {CRelInf,NewDef} -> + TCItmp = lists:subtract(TCI,[{objfun,anyset}]), + {CRelInf,T#type{def=NewDef,tablecinf=[{objfun,anyset}|TCItmp]}} + end. + + +%% leading_attr_index counts the index and picks the name of the +%% component that is at the actual level in the at-list of the +%% component relation constraint (AttrP). AbsP is the path of +%% component names from the top type level to the actual level. AttrP +%% is a list with the atoms from the at-list. +leading_attr_index(S,Cs,[H={_,AttrP,_,_}|T],AbsP,Acc) -> + AttrInfo = + case lists:prefix(AbsP,AttrP) of + %% why this ?? It is necessary when in same situation as + %% TConstrChoice, there is an inner structure with an + %% outermost at-list and the "leading attribute" code gen + %% may be at a level some steps below the outermost level. + true -> + RelativAttrP = lists:subtract(AttrP,AbsP), + %% The header is used to calculate the index of the + %% component and to give the fun, received from the + %% object set look up, an unique name. The tail is + %% used to match the proper value input to the fun. + {hd(RelativAttrP),tl(RelativAttrP)}; + false -> + {hd(AttrP),tl(AttrP)} + end, + case leading_attr_index1(S,Cs,H,AttrInfo,1) of + 0 -> + leading_attr_index(S,Cs,T,AbsP,Acc); + Res -> + leading_attr_index(S,Cs,T,AbsP,[Res|Acc]) + end; +leading_attr_index(_,_Cs,[],_,Acc) -> + lists:reverse(Acc). + +leading_attr_index1(_,[],_,_,_) -> + 0; +leading_attr_index1(S,[C|Cs],Arg={ObjectSet,_,CDef,P}, + AttrInfo={Attr,SubAttr},N) -> + case C#'ComponentType'.name of + Attr -> + ValueMatch = value_match(S,C,Attr,SubAttr), + {ObjectSet,Attr,N,CDef,P,ValueMatch}; + _ -> + leading_attr_index1(S,Cs,Arg,AttrInfo,N+1) + end. + +%% value_math gathers information for a proper value match in the +%% generated encode function. For a SEQUENCE or a SET the index of the +%% component is counted. For a CHOICE the index is 2. +value_match(S,C,Name,SubAttr) -> + value_match(S,C,Name,SubAttr,[]). % C has name Name +value_match(_S,#'ComponentType'{},_Name,[],Acc) -> + Acc;% do not reverse, indexes in reverse order +value_match(S,#'ComponentType'{typespec=Type},Name,[At|Ats],Acc) -> + InnerType = asn1ct_gen:get_inner(Type#type.def), + Components = + case get_atlist_components(Type#type.def) of + [] -> error({type,{asn1,"element in at list must be a " + "SEQUENCE, SET or CHOICE.",Name},S}); + Comps -> Comps + end, + {Index,ValueIndex} = component_value_index(S,InnerType,At,Components), + value_match(S,lists:nth(Index,Components),At,Ats,[ValueIndex|Acc]). + +component_value_index(S,'CHOICE',At,Components) -> + {component_index(S,At,Components),2}; +component_value_index(S,_,At,Components) -> + %% SEQUENCE or SET + Index = component_index(S,At,Components), + {Index,{Index+1,At}}. + +component_index(S,Name,Components) -> + component_index1(S,Name,Components,1). +component_index1(_S,Name,[#'ComponentType'{name=Name}|_Cs],N) -> + N; +component_index1(S,Name,[_C|Cs],N) -> + component_index1(S,Name,Cs,N+1); +component_index1(S,Name,[],_) -> + error({type,{asn1,"component of at-list was not" + " found in substructure",Name},S}). + +get_unique_fieldname(ClassDef) -> +%% {_,Fields,_} = ClassDef#classdef.typespec, + Fields = (ClassDef#classdef.typespec)#objectclass.fields, + get_unique_fieldname(Fields,[]). + +get_unique_fieldname([],[]) -> + throw({error,'__undefined_'}); +get_unique_fieldname([],[Name]) -> + Name; +get_unique_fieldname([],Acc) -> + throw({asn1,'only one UNIQUE field is allowed in CLASS',Acc}); +get_unique_fieldname([{fixedtypevaluefield,Name,_,'UNIQUE',_}|Rest],Acc) -> + get_unique_fieldname(Rest,[Name|Acc]); +get_unique_fieldname([_H|T],Acc) -> + get_unique_fieldname(T,Acc). + +get_tableconstraint_info(S,Type,{CheckedTs,EComps}) -> + {get_tableconstraint_info(S,Type,CheckedTs,[]), + get_tableconstraint_info(S,Type,EComps,[])}; +get_tableconstraint_info(S,Type,CheckedTs) -> + get_tableconstraint_info(S,Type,CheckedTs,[]). + +get_tableconstraint_info(_S,_Type,[],Acc) -> + lists:reverse(Acc); +get_tableconstraint_info(S,Type,[C|Cs],Acc) -> + CheckedTs = C#'ComponentType'.typespec, + AccComp = + case CheckedTs#type.def of + %% ObjectClassFieldType + OCFT=#'ObjectClassFieldType'{class=#objectclass{}, + type=_AType} -> +% AType = get_ObjectClassFieldType(S,Fields,FieldRef), +% RefedFieldName = +% get_referencedclassfield(CheckedTs#type.def),%is probably obsolete + NewOCFT = + OCFT#'ObjectClassFieldType'{class=[]}, + C#'ComponentType'{typespec= + CheckedTs#type{ +% def=AType, + def=NewOCFT + }}; +% constraint=[{tableconstraint_info, +% FieldRef}]}}; + {'SEQUENCE OF',SOType} when record(SOType,type), + (element(1,SOType#type.def)=='CHOICE') -> + CTypeList = element(2,SOType#type.def), + NewInnerCList = + get_tableconstraint_info(S,Type,CTypeList,[]), + C#'ComponentType'{typespec= + CheckedTs#type{ + def={'SEQUENCE OF', + SOType#type{def={'CHOICE', + NewInnerCList}}}}}; + {'SET OF',SOType} when record(SOType,type), + (element(1,SOType#type.def)=='CHOICE') -> + CTypeList = element(2,SOType#type.def), + NewInnerCList = + get_tableconstraint_info(S,Type,CTypeList,[]), + C#'ComponentType'{typespec= + CheckedTs#type{ + def={'SET OF', + SOType#type{def={'CHOICE', + NewInnerCList}}}}}; + _ -> + C + end, + get_tableconstraint_info(S,Type,Cs,[AccComp|Acc]). + +get_referenced_fieldname([{_,FirstFieldname}]) -> + {FirstFieldname,[]}; +get_referenced_fieldname([{_,FirstFieldname}|Rest]) -> + {FirstFieldname,lists:map(fun(X)->element(2,X) end,Rest)}; +get_referenced_fieldname(Def) -> + {no_type,Def}. + +%% get_ObjectClassFieldType extracts the type from the chain of +%% objects that leads to a final type. +get_ObjectClassFieldType(S,ERef,PrimFieldNameList) when + record(ERef,'Externaltypereference') -> + {_,Type} = get_referenced_type(S,ERef), + ClassSpec = check_class(S,Type), + Fields = ClassSpec#objectclass.fields, + get_ObjectClassFieldType(S,Fields,PrimFieldNameList); +get_ObjectClassFieldType(S,Fields,L=[_PrimFieldName1|_Rest]) -> + check_PrimitiveFieldNames(S,Fields,L), + get_OCFType(S,Fields,L). + +check_PrimitiveFieldNames(_S,_Fields,_) -> + ok. + +%% get_ObjectClassFieldType_classdef gets the def of the class of the +%% ObjectClassFieldType, i.e. the objectclass record. If the type has +%% been checked (it may be a field type of an internal SEQUENCE) the +%% class field = [], then the classdef has to be fetched by help of +%% the class reference in the classname field. +get_ObjectClassFieldType_classdef(S,#'ObjectClassFieldType'{classname=Name, + class=[]}) -> + {_,#classdef{typespec=TS}} = get_referenced_type(S,Name), + TS; +get_ObjectClassFieldType_classdef(_,#'ObjectClassFieldType'{class=Cl}) -> + Cl. + +get_OCFType(S,Fields,[{_FieldType,PrimFieldName}|Rest]) -> + case lists:keysearch(PrimFieldName,2,Fields) of + {value,{fixedtypevaluefield,_,Type,_Unique,_OptSpec}} -> + {fixedtypevaluefield,PrimFieldName,Type}; + {value,{objectfield,_,Type,_Unique,_OptSpec}} -> + {_,ClassDef} = get_referenced_type(S,Type#type.def), + CheckedCDef = check_class(S#state{type=ClassDef, + tname=ClassDef#classdef.name}, + ClassDef#classdef.typespec), + get_OCFType(S,CheckedCDef#objectclass.fields,Rest); + {value,{objectsetfield,_,Type,_OptSpec}} -> + {_,ClassDef} = get_referenced_type(S,Type#type.def), + CheckedCDef = check_class(S#state{type=ClassDef, + tname=ClassDef#classdef.name}, + ClassDef#classdef.typespec), + get_OCFType(S,CheckedCDef#objectclass.fields,Rest); + + {value,Other} -> + {element(1,Other),PrimFieldName}; + _ -> + error({type,"undefined FieldName in ObjectClassFieldType",S}) + end. + +get_taglist(#state{erule=per},_) -> + []; +get_taglist(#state{erule=per_bin},_) -> + []; +get_taglist(S,Ext) when record(Ext,'Externaltypereference') -> + {_,T} = get_referenced_type(S,Ext), + get_taglist(S,T#typedef.typespec); +get_taglist(S,Tref) when record(Tref,typereference) -> + {_,T} = get_referenced_type(S,Tref), + get_taglist(S,T#typedef.typespec); +get_taglist(S,Type) when record(Type,type) -> + case Type#type.tag of + [] -> + get_taglist(S,Type#type.def); + [Tag|_] -> +% case lists:member(S#state.erule,[ber,ber_bin]) of +% true -> +% lists:map(fun(Tx) -> asn1ct_gen:def_to_tag(Tx) end,Type#type.tag); +% _ -> + [asn1ct_gen:def_to_tag(Tag)] +% end + end; +get_taglist(S,{'CHOICE',{Rc,Ec}}) -> + get_taglist(S,{'CHOICE',Rc ++ Ec}); +get_taglist(S,{'CHOICE',Components}) -> + get_taglist1(S,Components); +%% ObjectClassFieldType OTP-4390 +get_taglist(_S,#'ObjectClassFieldType'{type={typefield,_}}) -> + []; +get_taglist(S,#'ObjectClassFieldType'{type={fixedtypevaluefield,_,Type}}) -> + get_taglist(S,Type); +get_taglist(S,{ERef=#'Externaltypereference'{},FieldNameList}) + when list(FieldNameList) -> + case get_ObjectClassFieldType(S,ERef,FieldNameList) of + Type when record(Type,type) -> + get_taglist(S,Type); + {fixedtypevaluefield,_,Type} -> get_taglist(S,Type); + {TypeFieldName,_} when atom(TypeFieldName) -> []%should check if allowed + end; +get_taglist(S,{ObjCl,FieldNameList}) when record(ObjCl,objectclass), + list(FieldNameList) -> + case get_ObjectClassFieldType(S,ObjCl#objectclass.fields,FieldNameList) of + Type when record(Type,type) -> + get_taglist(S,Type); + {fixedtypevaluefield,_,Type} -> get_taglist(S,Type); + {TypeFieldName,_} when atom(TypeFieldName) -> []%should check if allowed + end; +get_taglist(S,Def) -> + case lists:member(S#state.erule,[ber_bin_v2]) of + false -> + case Def of + 'ASN1_OPEN_TYPE' -> % open_type has no UNIVERSAL tag as such + []; + _ -> + [asn1ct_gen:def_to_tag(Def)] + end; + _ -> + [] + end. + +get_taglist1(S,[#'ComponentType'{name=_Cname,tags=TagL}|Rest]) when list(TagL) -> + %% tag_list has been here , just return TagL and continue with next alternative + TagL ++ get_taglist1(S,Rest); +get_taglist1(S,[#'ComponentType'{typespec=Ts,tags=undefined}|Rest]) -> + get_taglist(S,Ts) ++ get_taglist1(S,Rest); +get_taglist1(S,[_H|Rest]) -> % skip EXTENSIONMARK + get_taglist1(S,Rest); +get_taglist1(_S,[]) -> + []. + +dbget_ex(_S,Module,Key) -> + case asn1_db:dbget(Module,Key) of + undefined -> + + throw({error,{asn1,{undefined,{Module,Key}}}}); % this is catched on toplevel type or value + T -> T + end. + +merge_tags(T1, T2) when list(T2) -> + merge_tags2(T1 ++ T2, []); +merge_tags(T1, T2) -> + merge_tags2(T1 ++ [T2], []). + +merge_tags2([T1= #tag{type='IMPLICIT'}, T2 |Rest], Acc) -> + merge_tags2([T1#tag{type=T2#tag.type, form=T2#tag.form}|Rest],Acc); +merge_tags2([T1= #tag{type={default,'IMPLICIT'}}, T2 |Rest], Acc) -> + merge_tags2([T1#tag{type=T2#tag.type, form=T2#tag.form}|Rest],Acc); +merge_tags2([H|T],Acc) -> + merge_tags2(T, [H|Acc]); +merge_tags2([], Acc) -> + lists:reverse(Acc). + +merge_constraints(C1, []) -> + C1; +merge_constraints([], C2) -> + C2; +merge_constraints(C1, C2) -> + {SList,VList,PAList,Rest} = splitlist(C1++C2,[],[],[],[]), + SizeC = merge_constraints(SList), + ValueC = merge_constraints(VList), + PermAlphaC = merge_constraints(PAList), + case Rest of + [] -> + SizeC ++ ValueC ++ PermAlphaC; + _ -> + throw({error,{asn1,{not_implemented,{merge_constraints,Rest}}}}) + end. + +merge_constraints([]) -> []; +merge_constraints([C1 = {_,{Low1,High1}},{_,{Low2,High2}}|Rest]) when Low1 >= Low2, + High1 =< High2 -> + merge_constraints([C1|Rest]); +merge_constraints([C1={'PermittedAlphabet',_},C2|Rest]) -> + [C1|merge_constraints([C2|Rest])]; +merge_constraints([C1 = {_,{_Low1,_High1}},C2 = {_,{_Low2,_High2}}|_Rest]) -> + throw({error,asn1,{conflicting_constraints,{C1,C2}}}); +merge_constraints([C]) -> + [C]. + +splitlist([C={'SizeConstraint',_}|Rest],Sacc,Vacc,PAacc,Restacc) -> + splitlist(Rest,[C|Sacc],Vacc,PAacc,Restacc); +splitlist([C={'ValueRange',_}|Rest],Sacc,Vacc,PAacc,Restacc) -> + splitlist(Rest,Sacc,[C|Vacc],PAacc,Restacc); +splitlist([C={'PermittedAlphabet',_}|Rest],Sacc,Vacc,PAacc,Restacc) -> + splitlist(Rest,Sacc,Vacc,[C|PAacc],Restacc); +splitlist([C|Rest],Sacc,Vacc,PAacc,Restacc) -> + splitlist(Rest,Sacc,Vacc,PAacc,[C|Restacc]); +splitlist([],Sacc,Vacc,PAacc,Restacc) -> + {lists:reverse(Sacc), + lists:reverse(Vacc), + lists:reverse(PAacc), + lists:reverse(Restacc)}. + + + +storeindb(M) when record(M,module) -> + TVlist = M#module.typeorval, + NewM = M#module{typeorval=findtypes_and_values(TVlist)}, + asn1_db:dbnew(NewM#module.name), + asn1_db:dbput(NewM#module.name,'MODULE', NewM), + Res = storeindb(NewM#module.name,TVlist,[]), + include_default_class(NewM#module.name), + include_default_type(NewM#module.name), + Res. + +storeindb(Module,[H|T],ErrAcc) when record(H,typedef) -> + storeindb(Module,H#typedef.name,H,T,ErrAcc); +storeindb(Module,[H|T],ErrAcc) when record(H,valuedef) -> + storeindb(Module,H#valuedef.name,H,T,ErrAcc); +storeindb(Module,[H|T],ErrAcc) when record(H,ptypedef) -> + storeindb(Module,H#ptypedef.name,H,T,ErrAcc); +storeindb(Module,[H|T],ErrAcc) when record(H,classdef) -> + storeindb(Module,H#classdef.name,H,T,ErrAcc); +storeindb(Module,[H|T],ErrAcc) when record(H,pvaluesetdef) -> + storeindb(Module,H#pvaluesetdef.name,H,T,ErrAcc); +storeindb(Module,[H|T],ErrAcc) when record(H,pobjectdef) -> + storeindb(Module,H#pobjectdef.name,H,T,ErrAcc); +storeindb(Module,[H|T],ErrAcc) when record(H,pvaluedef) -> + storeindb(Module,H#pvaluedef.name,H,T,ErrAcc); +storeindb(_,[],[]) -> ok; +storeindb(_,[],ErrAcc) -> + {error,ErrAcc}. + +storeindb(Module,Name,H,T,ErrAcc) -> + case asn1_db:dbget(Module,Name) of + undefined -> + asn1_db:dbput(Module,Name,H), + storeindb(Module,T,ErrAcc); + _ -> + case H of + _Type when record(H,typedef) -> + error({type,"already defined", + #state{mname=Module,type=H,tname=Name}}); + _Type when record(H,valuedef) -> + error({value,"already defined", + #state{mname=Module,value=H,vname=Name}}); + _Type when record(H,ptypedef) -> + error({ptype,"already defined", + #state{mname=Module,type=H,tname=Name}}); + _Type when record(H,pobjectdef) -> + error({ptype,"already defined", + #state{mname=Module,type=H,tname=Name}}); + _Type when record(H,pvaluesetdef) -> + error({ptype,"already defined", + #state{mname=Module,type=H,tname=Name}}); + _Type when record(H,pvaluedef) -> + error({ptype,"already defined", + #state{mname=Module,type=H,tname=Name}}); + _Type when record(H,classdef) -> + error({class,"already defined", + #state{mname=Module,value=H,vname=Name}}) + end, + storeindb(Module,T,[H|ErrAcc]) + end. + +findtypes_and_values(TVList) -> + findtypes_and_values(TVList,[],[],[],[],[],[]).%% Types,Values, +%% Parameterizedtypes,Classes,Objects and ObjectSets + +findtypes_and_values([H|T],Tacc,Vacc,Pacc,Cacc,Oacc,OSacc) + when record(H,typedef),record(H#typedef.typespec,'Object') -> + findtypes_and_values(T,Tacc,Vacc,Pacc,Cacc,[H#typedef.name|Oacc],OSacc); +findtypes_and_values([H|T],Tacc,Vacc,Pacc,Cacc,Oacc,OSacc) + when record(H,typedef),record(H#typedef.typespec,'ObjectSet') -> + findtypes_and_values(T,Tacc,Vacc,Pacc,Cacc,Oacc,[H#typedef.name|OSacc]); +findtypes_and_values([H|T],Tacc,Vacc,Pacc,Cacc,Oacc,OSacc) + when record(H,typedef) -> + findtypes_and_values(T,[H#typedef.name|Tacc],Vacc,Pacc,Cacc,Oacc,OSacc); +findtypes_and_values([H|T],Tacc,Vacc,Pacc,Cacc,Oacc,OSacc) + when record(H,valuedef) -> + findtypes_and_values(T,Tacc,[H#valuedef.name|Vacc],Pacc,Cacc,Oacc,OSacc); +findtypes_and_values([H|T],Tacc,Vacc,Pacc,Cacc,Oacc,OSacc) + when record(H,ptypedef) -> + findtypes_and_values(T,Tacc,Vacc,[H#ptypedef.name|Pacc],Cacc,Oacc,OSacc); +findtypes_and_values([H|T],Tacc,Vacc,Pacc,Cacc,Oacc,OSacc) + when record(H,classdef) -> + findtypes_and_values(T,Tacc,Vacc,Pacc,[H#classdef.name|Cacc],Oacc,OSacc); +findtypes_and_values([H|T],Tacc,Vacc,Pacc,Cacc,Oacc,OSacc) + when record(H,pvaluedef) -> + findtypes_and_values(T,Tacc,[H#pvaluedef.name|Vacc],Pacc,Cacc,Oacc,OSacc); +findtypes_and_values([H|T],Tacc,Vacc,Pacc,Cacc,Oacc,OSacc) + when record(H,pvaluesetdef) -> + findtypes_and_values(T,Tacc,[H#pvaluesetdef.name|Vacc],Pacc,Cacc,Oacc,OSacc); +findtypes_and_values([H|T],Tacc,Vacc,Pacc,Cacc,Oacc,OSacc) + when record(H,pobjectdef) -> + findtypes_and_values(T,Tacc,Vacc,Pacc,Cacc,[H#pobjectdef.name|Oacc],OSacc); +findtypes_and_values([H|T],Tacc,Vacc,Pacc,Cacc,Oacc,OSacc) + when record(H,pobjectsetdef) -> + findtypes_and_values(T,Tacc,Vacc,Pacc,Cacc,Oacc,[H#pobjectsetdef.name|OSacc]); +findtypes_and_values([],Tacc,Vacc,Pacc,Cacc,Oacc,OSacc) -> + {lists:reverse(Tacc),lists:reverse(Vacc),lists:reverse(Pacc), + lists:reverse(Cacc),lists:reverse(Oacc),lists:reverse(OSacc)}. + + + +error({export,Msg,#state{mname=Mname,type=Ref,tname=Typename}}) -> + Pos = Ref#'Externaltypereference'.pos, + io:format("asn1error:~p:~p:~p ~p~n",[Pos,Mname,Typename,Msg]), + {error,{export,Pos,Mname,Typename,Msg}}; +error({type,Msg,#state{mname=Mname,type=Type,tname=Typename}}) + when record(Type,typedef) -> + io:format("asn1error:~p:~p:~p ~p~n", + [Type#typedef.pos,Mname,Typename,Msg]), + {error,{type,Type#typedef.pos,Mname,Typename,Msg}}; +error({type,Msg,#state{mname=Mname,type=Type,tname=Typename}}) + when record(Type,ptypedef) -> + io:format("asn1error:~p:~p:~p ~p~n", + [Type#ptypedef.pos,Mname,Typename,Msg]), + {error,{type,Type#ptypedef.pos,Mname,Typename,Msg}}; +error({type,Msg,#state{mname=Mname,value=Value,vname=Valuename}}) + when record(Value,valuedef) -> + io:format("asn1error:~p:~p:~p ~p~n",[Value#valuedef.pos,Mname,Valuename,Msg]), + {error,{type,Value#valuedef.pos,Mname,Valuename,Msg}}; +error({type,Msg,#state{mname=Mname,type=Type,tname=Typename}}) + when record(Type,pobjectdef) -> + io:format("asn1error:~p:~p:~p ~p~n", + [Type#pobjectdef.pos,Mname,Typename,Msg]), + {error,{type,Type#pobjectdef.pos,Mname,Typename,Msg}}; +error({value,Msg,#state{mname=Mname,value=Value,vname=Valuename}}) -> + io:format("asn1error:~p:~p:~p ~p~n",[Value#valuedef.pos,Mname,Valuename,Msg]), + {error,{value,Value#valuedef.pos,Mname,Valuename,Msg}}; +error({Other,Msg,#state{mname=Mname,value=#valuedef{pos=Pos},vname=Valuename}}) -> + io:format("asn1error:~p:~p:~p ~p~n",[Pos,Mname,Valuename,Msg]), + {error,{Other,Pos,Mname,Valuename,Msg}}; +error({Other,Msg,#state{mname=Mname,type=#typedef{pos=Pos},tname=Typename}}) -> + io:format("asn1error:~p:~p:~p ~p~n",[Pos,Mname,Typename,Msg]), + {error,{Other,Pos,Mname,Typename,Msg}}; +error({Other,Msg,#state{mname=Mname,type=#classdef{pos=Pos},tname=Typename}}) -> + io:format("asn1error:~p:~p:~p ~p~n",[Pos,Mname,Typename,Msg]), + {error,{Other,Pos,Mname,Typename,Msg}}. + +include_default_type(Module) -> + NameAbsList = default_type_list(), + include_default_type1(Module,NameAbsList). + +include_default_type1(_,[]) -> + ok; +include_default_type1(Module,[{Name,TS}|Rest]) -> + case asn1_db:dbget(Module,Name) of + undefined -> + T = #typedef{name=Name, + typespec=TS}, + asn1_db:dbput(Module,Name,T); + _ -> ok + end, + include_default_type1(Module,Rest). + +default_type_list() -> + %% The EXTERNAL type is represented, according to ASN.1 1997, + %% as a SEQUENCE with components: identification, data-value-descriptor + %% and data-value. + Syntax = + #'ComponentType'{name=syntax, + typespec=#type{def='OBJECT IDENTIFIER'}, + prop=mandatory}, + Presentation_Cid = + #'ComponentType'{name='presentation-context-id', + typespec=#type{def='INTEGER'}, + prop=mandatory}, + Transfer_syntax = + #'ComponentType'{name='transfer-syntax', + typespec=#type{def='OBJECT IDENTIFIER'}, + prop=mandatory}, + Negotiation_items = + #type{def= + #'SEQUENCE'{components= + [Presentation_Cid, + Transfer_syntax#'ComponentType'{prop=mandatory}]}}, + Context_negot = + #'ComponentType'{name='context-negotiation', + typespec=Negotiation_items, + prop=mandatory}, + + Data_value_descriptor = + #'ComponentType'{name='data-value-descriptor', + typespec=#type{def='ObjectDescriptor'}, + prop='OPTIONAL'}, + Data_value = + #'ComponentType'{name='data-value', + typespec=#type{def='OCTET STRING'}, + prop=mandatory}, + + %% The EXTERNAL type is represented, according to ASN.1 1990, + %% as a SEQUENCE with components: direct-reference, indirect-reference, + %% data-value-descriptor and encoding. + + Direct_reference = + #'ComponentType'{name='direct-reference', + typespec=#type{def='OBJECT IDENTIFIER'}, + prop='OPTIONAL'}, + + Indirect_reference = + #'ComponentType'{name='indirect-reference', + typespec=#type{def='INTEGER'}, + prop='OPTIONAL'}, + + Single_ASN1_type = + #'ComponentType'{name='single-ASN1-type', + typespec=#type{tag=[{tag,'CONTEXT',0, + 'EXPLICIT',32}], + def='ANY'}, + prop=mandatory}, + + Octet_aligned = + #'ComponentType'{name='octet-aligned', + typespec=#type{tag=[{tag,'CONTEXT',1, + 'IMPLICIT',32}], + def='OCTET STRING'}, + prop=mandatory}, + + Arbitrary = + #'ComponentType'{name=arbitrary, + typespec=#type{tag=[{tag,'CONTEXT',2, + 'IMPLICIT',32}], + def={'BIT STRING',[]}}, + prop=mandatory}, + + Encoding = + #'ComponentType'{name=encoding, + typespec=#type{def={'CHOICE', + [Single_ASN1_type,Octet_aligned, + Arbitrary]}}, + prop=mandatory}, + + EXTERNAL_components1990 = + [Direct_reference,Indirect_reference,Data_value_descriptor,Encoding], + + %% The EMBEDDED PDV type is represented by a SEQUENCE type + %% with components: identification and data-value + Abstract = + #'ComponentType'{name=abstract, + typespec=#type{def='OBJECT IDENTIFIER'}, + prop=mandatory}, + Transfer = + #'ComponentType'{name=transfer, + typespec=#type{def='OBJECT IDENTIFIER'}, + prop=mandatory}, + AbstractTrSeq = + #'SEQUENCE'{components=[Abstract,Transfer]}, + Syntaxes = + #'ComponentType'{name=syntaxes, + typespec=#type{def=AbstractTrSeq}, + prop=mandatory}, + Fixed = #'ComponentType'{name=fixed, + typespec=#type{def='NULL'}, + prop=mandatory}, + Negotiations = + [Syntaxes,Syntax,Presentation_Cid,Context_negot, + Transfer_syntax,Fixed], + Identification2 = + #'ComponentType'{name=identification, + typespec=#type{def={'CHOICE',Negotiations}}, + prop=mandatory}, + EmbeddedPdv_components = + [Identification2,Data_value], + + %% The CHARACTER STRING type is represented by a SEQUENCE type + %% with components: identification and string-value + String_value = + #'ComponentType'{name='string-value', + typespec=#type{def='OCTET STRING'}, + prop=mandatory}, + CharacterString_components = + [Identification2,String_value], + + [{'EXTERNAL', + #type{tag=[#tag{class='UNIVERSAL', + number=8, + type='IMPLICIT', + form=32}], + def=#'SEQUENCE'{components= + EXTERNAL_components1990}}}, + {'EMBEDDED PDV', + #type{tag=[#tag{class='UNIVERSAL', + number=11, + type='IMPLICIT', + form=32}], + def=#'SEQUENCE'{components=EmbeddedPdv_components}}}, + {'CHARACTER STRING', + #type{tag=[#tag{class='UNIVERSAL', + number=29, + type='IMPLICIT', + form=32}], + def=#'SEQUENCE'{components=CharacterString_components}}} + ]. + + +include_default_class(Module) -> + NameAbsList = default_class_list(), + include_default_class1(Module,NameAbsList). + +include_default_class1(_,[]) -> + ok; +include_default_class1(Module,[{Name,TS}|_Rest]) -> + case asn1_db:dbget(Module,Name) of + undefined -> + C = #classdef{checked=true,name=Name, + typespec=TS}, + asn1_db:dbput(Module,Name,C); + _ -> ok + end. + +default_class_list() -> + [{'TYPE-IDENTIFIER', + {objectclass, + [{fixedtypevaluefield, + id, + {type,[],'OBJECT IDENTIFIER',[]}, + 'UNIQUE', + 'MANDATORY'}, + {typefield,'Type','MANDATORY'}], + {'WITH SYNTAX', + [{typefieldreference,'Type'}, + 'IDENTIFIED', + 'BY', + {valuefieldreference,id}]}}}, + {'ABSTRACT-SYNTAX', + {objectclass, + [{fixedtypevaluefield, + id, + {type,[],'OBJECT IDENTIFIER',[]}, + 'UNIQUE', + 'MANDATORY'}, + {typefield,'Type','MANDATORY'}, + {fixedtypevaluefield, + property, + {type, + [], + {'BIT STRING',[]}, + []}, + undefined, + {'DEFAULT', + [0,1,0]}}], + {'WITH SYNTAX', + [{typefieldreference,'Type'}, + 'IDENTIFIED', + 'BY', + {valuefieldreference,id}, + ['HAS', + 'PROPERTY', + {valuefieldreference,property}]]}}}]. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_constructed_ber.erl b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_constructed_ber.erl new file mode 100644 index 0000000000..695f648924 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_constructed_ber.erl @@ -0,0 +1,1468 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: asn1ct_constructed_ber.erl,v 1.1 2008/12/17 09:53:29 mikpe Exp $ +%% +-module(asn1ct_constructed_ber). + +-export([gen_encode_sequence/3]). +-export([gen_decode_sequence/3]). +-export([gen_encode_set/3]). +-export([gen_decode_set/3]). +-export([gen_encode_sof/4]). +-export([gen_decode_sof/4]). +-export([gen_encode_choice/3]). +-export([gen_decode_choice/3]). + +%%%% Application internal exports +-export([match_tag/2]). + +-include("asn1_records.hrl"). + +-import(asn1ct_gen, [emit/1,demit/1]). + +% the encoding of class of tag bits 8 and 7 +-define(UNIVERSAL, 0). +-define(APPLICATION, 16#40). +-define(CONTEXT, 16#80). +-define(PRIVATE, 16#C0). + +% primitive or constructed encoding % bit 6 +-define(PRIMITIVE, 0). +-define(CONSTRUCTED, 2#00100000). + + + + +%%=============================================================================== +%%=============================================================================== +%%=============================================================================== +%% Encode/decode SEQUENCE +%%=============================================================================== +%%=============================================================================== +%%=============================================================================== + +gen_encode_sequence(Erules,Typename,D) when record(D,type) -> + asn1ct_name:start(), + asn1ct_name:new(term), + asn1ct_name:new(bytes), + + %% if EXTERNAL type the input value must be transformed to + %% ASN1 1990 format + case Typename of + ['EXTERNAL'] -> + emit([" NewVal = asn1rt_check:transform_to_EXTERNAL1990(Val),", + nl]); + _ -> + ok + end, + + {SeqOrSet,TableConsInfo,CompList} = + case D#type.def of + #'SEQUENCE'{tablecinf=TCI,components=CL} -> + {'SEQUENCE',TCI,CL}; + #'SET'{tablecinf=TCI,components=CL} -> + {'SET',TCI,CL} + end, + Ext = extensible(CompList), + CompList1 = case CompList of + {Rl,El} -> Rl ++ El; + _ -> CompList + end, + EncObj = + case TableConsInfo of + #simpletableattributes{usedclassfield=Used, + uniqueclassfield=Unique} when Used /= Unique -> + false; + %% ObjectSet, name of the object set in constraints + %% + %%{ObjectSet,AttrN,N,UniqueFieldName} + #simpletableattributes{objectsetname=ObjectSet, + c_name=AttrN, + c_index=N, + usedclassfield=UniqueFieldName, + uniqueclassfield=UniqueFieldName, + valueindex=ValueIndex + } -> + OSDef = + case ObjectSet of + {Module,OSName} -> + asn1_db:dbget(Module,OSName); + OSName -> + asn1_db:dbget(get(currmod),OSName) + end, +% io:format("currmod: ~p~nOSName: ~p~nAttrN: ~p~nN: ~p~nUniqueFieldName: ~p~n", +% [get(currmod),OSName,AttrN,N,UniqueFieldName]), + case (OSDef#typedef.typespec)#'ObjectSet'.gen of + true -> +% Val = lists:concat(["?RT_BER:cindex(", +% N+1,",Val,"]), + ObjectEncode = + asn1ct_gen:un_hyphen_var(lists:concat(['Obj', + AttrN])), + emit({ObjectEncode," = ",nl}), + emit({" 'getenc_",ObjectSet,"'(",{asis,UniqueFieldName}, + ", ",nl}), +% emit({indent(35),"?RT_BER:cindex(",N+1,", Val,", +% {asis,AttrN},")),",nl}), + emit([indent(10+length(atom_to_list(ObjectSet))), + "value_match(",{asis,ValueIndex},",", + "?RT_BER:cindex(",N+1,",Val,", + {asis,AttrN},"))),",nl]), + notice_value_match(), + {AttrN,ObjectEncode}; + _ -> + false + end; + _ -> + case D#type.tablecinf of + [{objfun,_}|_] -> + %% when the simpletableattributes was at an + %% outer level and the objfun has been passed + %% through the function call + {"got objfun through args","ObjFun"}; + _ -> + false + end + end, + + gen_enc_sequence_call(Erules,Typename,CompList1,1,Ext,EncObj), + + MyTag = [X#tag{class=asn1ct_gen_ber:decode_class(X#tag.class)}|| X <- D#type.tag] + ++ + [#tag{class = asn1ct_gen_ber:decode_class('UNIVERSAL'), + number = asn1ct_gen_ber:decode_type(SeqOrSet), + form = ?CONSTRUCTED, + type = 'IMPLICIT'}], + emit([nl," BytesSoFar = "]), + case SeqOrSet of + 'SET' when (D#type.def)#'SET'.sorted == dynamic -> + emit("?RT_BER:dynamicsort_SET_components(["), + mkvlist(asn1ct_name:all(encBytes)), + emit(["]),",nl]); + _ -> + emit("["), + mkvlist(asn1ct_name:all(encBytes)), + emit(["],",nl]) + end, + emit(" LenSoFar = "), + case asn1ct_name:all(encLen) of + [] -> emit("0"); + AllLengths -> + mkvplus(AllLengths) + end, + emit([",",nl]), +% emit(["{TagBytes,Len} = ?RT_BER:encode_tags(TagIn ++ ", + emit([" ?RT_BER:encode_tags(TagIn ++ ", + {asis,MyTag},", BytesSoFar, LenSoFar).",nl]). + + +gen_decode_sequence(Erules,Typename,D) when record(D,type) -> + asn1ct_name:start(), +% asn1ct_name:new(term), + asn1ct_name:new(tag), + #'SEQUENCE'{tablecinf=TableConsInfo,components=CList} = D#type.def, + Ext = extensible(CList), + CompList = case CList of + {Rl,El} -> Rl ++ El; + _ -> CList + end, + + emit({" %%-------------------------------------------------",nl}), + emit({" %% decode tag and length ",nl}), + emit({" %%-------------------------------------------------",nl}), + + asn1ct_name:new(rb), + MyTag = [X#tag{class=asn1ct_gen_ber:decode_class(X#tag.class)}|| X <- D#type.tag] + ++ + [#tag{class = asn1ct_gen_ber:decode_class('UNIVERSAL'), + number = asn1ct_gen_ber:decode_type('SEQUENCE'), + form = ?CONSTRUCTED, + type = 'IMPLICIT'}], + emit([" {{_,",asn1ct_gen_ber:unused_var("Len",D#type.def),"},",{next,bytes},",",{curr,rb}, + "} = ?RT_BER:check_tags(TagIn ++ ",{asis,MyTag},", ", + {curr,bytes},", OptOrMand), ",nl]), + asn1ct_name:new(bytes), + asn1ct_name:new(len), + + case CompList of + [] -> true; + _ -> + emit({"{",{next,bytes}, + ",RemBytes} = ?RT_BER:split_list(", + {curr,bytes}, + ",", {prev,len},"),",nl}), + asn1ct_name:new(bytes) + end, + + {DecObjInf,UniqueFName,ValueIndex} = + case TableConsInfo of + #simpletableattributes{objectsetname=ObjectSet, + c_name=AttrN, + usedclassfield=UniqueFieldName, + uniqueclassfield=UniqueFieldName, + valueindex=ValIndex + } -> + F = fun(#'ComponentType'{typespec=CT})-> + case {CT#type.constraint,CT#type.tablecinf} of + {[],[{objfun,_}|_R]} -> true; + _ -> false + end + end, + case lists:any(F,CompList) of + %%AttributeName = asn1ct_gen:un_hyphen_var(AttrN), + true -> % when component relation constraint establish + %% relation from a component to another components + %% subtype component + {{AttrN,{deep,ObjectSet,UniqueFieldName, + ValIndex}}, + UniqueFieldName,ValIndex}; + false -> + {{AttrN,ObjectSet},UniqueFieldName,ValIndex} + end; + _ -> + {false,false,false} + end, + case gen_dec_sequence_call(Erules,Typename,CompList,Ext,DecObjInf) of + no_terms -> % an empty sequence + emit([nl,nl]), + demit({"Result = "}), %dbg + %% return value as record + asn1ct_name:new(rb), + emit([" {{'",asn1ct_gen:list2rname(Typename),"'}, ",{curr,bytes},",",nl," "]), + asn1ct_gen_ber:add_removed_bytes(), + emit(["}.",nl]); + {LeadingAttrTerm,PostponedDecArgs} -> + emit([com,nl,nl]), + case {LeadingAttrTerm,PostponedDecArgs} of + {[],[]} -> + ok; + {_,[]} -> + ok; + {[{ObjSet,LeadingAttr,Term}],PostponedDecArgs} -> + DecObj = asn1ct_gen:un_hyphen_var(lists:concat(['DecObj',LeadingAttr,Term])), + ValueMatch = value_match(ValueIndex,Term), + emit([DecObj," =",nl," 'getdec_",ObjSet,"'(", +% {asis,UniqueFName},", ",Term,"),",nl}), + {asis,UniqueFName},", ",ValueMatch,"),",nl]), + gen_dec_postponed_decs(DecObj,PostponedDecArgs) + end, + demit({"Result = "}), %dbg + %% return value as record + asn1ct_name:new(rb), + asn1ct_name:new(bytes), + ExtStatus = case Ext of + {ext,_,_} -> ext; + noext -> noext + end, + emit([" {",{next,bytes},",",{curr,rb},"} = ?RT_BER:restbytes2(RemBytes, ", + {curr,bytes},",",ExtStatus,"),",nl]), + asn1ct_name:new(rb), + case Typename of + ['EXTERNAL'] -> + emit([" OldFormat={'",asn1ct_gen:list2rname(Typename), + "', "]), + mkvlist(asn1ct_name:all(term)), + emit(["},",nl]), + emit([" ASN11994Format =",nl, + " asn1rt_check:transform_to_EXTERNAL1994", + "(OldFormat),",nl]), + emit([" {ASN11994Format,",{next,bytes},", "]); + _ -> + emit([" {{'",asn1ct_gen:list2rname(Typename),"', "]), + mkvlist(asn1ct_name:all(term)), + emit(["}, ",{next,bytes},", "]) + end, + asn1ct_gen_ber:add_removed_bytes(), + emit(["}.",nl]) + end. + +gen_dec_postponed_decs(_,[]) -> + emit(nl); +gen_dec_postponed_decs(DecObj,[{_Cname,{FirstPFN,PFNList},Term,TmpTerm,_Tag,OptOrMand}|Rest]) -> +% asn1ct_name:new(term), + asn1ct_name:new(tmpterm), + asn1ct_name:new(reason), + + emit({"{",Term,", _, _} = ",nl}), + N = case OptOrMand of + mandatory -> 0; + 'OPTIONAL' -> + emit_opt_or_mand_check(asn1_NOVALUE,TmpTerm), + 6; + {'DEFAULT',Val} -> + emit_opt_or_mand_check(Val,TmpTerm), + 6 + end, + emit({indent(N+3),"case (catch ",DecObj,"(",{asis,FirstPFN}, +% ", ",TmpTerm,", ", {asis,Tag},", ",{asis,PFNList},")) of",nl}), + ", ",TmpTerm,", [], ",{asis,PFNList},")) of",nl}), + emit({indent(N+6),"{'EXIT', ",{curr,reason},"} ->",nl}), + emit({indent(N+9),"exit({'Type not compatible with table constraint',", + {curr,reason},"});",nl}), + emit({indent(N+6),{curr,tmpterm}," ->",nl}), + emit({indent(N+9),{curr,tmpterm},nl}), + + case OptOrMand of + mandatory -> emit([indent(N+3),"end,",nl]); + _ -> + emit([indent(N+3),"end",nl, + indent(3),"end,",nl]) + end, +% emit({indent(3),"end,",nl}), + gen_dec_postponed_decs(DecObj,Rest). + + +emit_opt_or_mand_check(Value,TmpTerm) -> + emit([indent(3),"case ",TmpTerm," of",nl, + indent(6),{asis,Value}," -> {",{asis,Value},",[],[]};",nl, + indent(6),"_ ->",nl]). + +%%============================================================================ +%% Encode/decode SET +%% +%%============================================================================ + +gen_encode_set(Erules,Typename,D) when record(D,type) -> + gen_encode_sequence(Erules,Typename,D). + +gen_decode_set(Erules,Typename,D) when record(D,type) -> + asn1ct_name:start(), + asn1ct_name:new(term), + asn1ct_name:new(tag), + #'SET'{components=TCompList} = D#type.def, + Ext = extensible(TCompList), + CompList = case TCompList of + {Rl,El} -> Rl ++ El; + _ -> TCompList + end, + + emit([" %%-------------------------------------------------",nl]), + emit([" %% decode tag and length ",nl]), + emit([" %%-------------------------------------------------",nl]), + + asn1ct_name:new(rb), + MyTag = [X#tag{class=asn1ct_gen_ber:decode_class(X#tag.class)}|| X <- D#type.tag] + ++ + [#tag{class = asn1ct_gen_ber:decode_class('UNIVERSAL'), + number = asn1ct_gen_ber:decode_type('SET'), + form = ?CONSTRUCTED, + type = 'IMPLICIT'}], + emit([" {{_,Len},",{next,bytes},",",{curr,rb}, + "} = ?RT_BER:check_tags(TagIn ++ ",{asis,MyTag},", ", + {curr,bytes},", OptOrMand), ",nl]), + asn1ct_name:new(bytes), + asn1ct_name:new(len), + asn1ct_name:new(rb), + + emit([" {SetTerm, SetBytes, ",{curr,rb},"} = ?RT_BER:decode_set(0, Len, ", + {curr,bytes},", OptOrMand, ", + "fun 'dec_",asn1ct_gen:list2name(Typename),"_fun'/2, []),",nl]), + + asn1ct_name:new(rb), + emit([" 'dec_",asn1ct_gen:list2name(Typename),"_result'(lists:sort(SetTerm), SetBytes, "]), + asn1ct_gen_ber:add_removed_bytes(), + emit([").",nl,nl,nl]), + + emit({"%%-------------------------------------------------",nl}), + emit({"%% Set loop fun for ",asn1ct_gen:list2name(Typename),nl}), + emit({"%%-------------------------------------------------",nl}), + + asn1ct_name:clear(), + asn1ct_name:new(term), + emit(["'dec_",asn1ct_gen:list2name(Typename),"_fun'(",{curr,bytes}, + ", OptOrMand) ->",nl]), + + asn1ct_name:new(bytes), + gen_dec_set(Erules,Typename,CompList,1,Ext), + + emit([" %% tag not found, if extensionmark we should skip bytes here",nl]), + emit([indent(6),"_ -> {[], Bytes,0}",nl]), + emit([indent(3),"end.",nl,nl,nl]), + + + emit({"%%-------------------------------------------------",nl}), + emit({"%% Result ",asn1ct_gen:list2name(Typename),nl}), + emit({"%%-------------------------------------------------",nl}), + + asn1ct_name:clear(), + emit({"'dec_",asn1ct_gen:list2name(Typename),"_result'(", + asn1ct_gen_ber:unused_var("TermList",D#type.def),", Bytes, Rb) ->",nl}), + + case gen_dec_set_result(Erules,Typename,CompList) of + no_terms -> + %% return value as record + asn1ct_name:new(rb), + emit({" {{'",asn1ct_gen:list2rname(Typename),"'}, Bytes, Rb}.",nl}); + _ -> + emit({nl," case ",{curr,termList}," of",nl}), + emit({" [] -> {{'",asn1ct_gen:list2rname(Typename),"', "}), + mkvlist(asn1ct_name:all(term)), + emit({"}, Bytes, Rb};",nl}), + emit({" ExtraAtt -> exit({error,{asn1,{too_many_attributes, ExtraAtt}}})",nl}), + emit({" end.",nl}), + emit({nl,nl,nl}) + end. + + +%%=============================================================================== +%%=============================================================================== +%%=============================================================================== +%% Encode/decode SEQUENCE OF and SET OF +%%=============================================================================== +%%=============================================================================== +%%=============================================================================== + +gen_encode_sof(Erules,Typename,_InnerTypename,D) when record(D,type) -> + asn1ct_name:start(), + {SeqOrSetOf, Cont} = D#type.def, + + Objfun = case D#type.tablecinf of + [{objfun,_}|_R] -> + ", ObjFun"; + _ -> + "" + end, + + emit({" {EncBytes,EncLen} = 'enc_",asn1ct_gen:list2name(Typename), + "_components'(Val",Objfun,",[],0),",nl}), + + MyTag = [X#tag{class=asn1ct_gen_ber:decode_class(X#tag.class)}|| X <- D#type.tag] + ++ + [#tag{class = asn1ct_gen_ber:decode_class('UNIVERSAL'), + number = asn1ct_gen_ber:decode_type(SeqOrSetOf), + form = ?CONSTRUCTED, + type = 'IMPLICIT'}], +% gen_encode_tags(Erules,MyTag,"EncLen","EncBytes"), + emit([" ?RT_BER:encode_tags(TagIn ++ ", + {asis,MyTag},", EncBytes, EncLen).",nl,nl]), + + gen_encode_sof_components(Erules,Typename,SeqOrSetOf,Cont). +% gen_enc_line(Erules,Typename,TypeNameSuffix,Cont,"H",0, +% mandatory,"{EncBytes,EncLen} = "), + + +gen_decode_sof(Erules,Typename,_InnerTypename,D) when record(D,type) -> + asn1ct_name:start(), + {SeqOrSetOf, TypeTag, Cont} = + case D#type.def of + {'SET OF',_Cont} -> {'SET OF','SET',_Cont}; + {'SEQUENCE OF',_Cont} -> {'SEQUENCE OF','SEQUENCE',_Cont} + end, + TypeNameSuffix = asn1ct_gen:constructed_suffix(SeqOrSetOf,Cont#type.def), + + emit({" %%-------------------------------------------------",nl}), + emit({" %% decode tag and length ",nl}), + emit({" %%-------------------------------------------------",nl}), + + asn1ct_name:new(rb), + MyTag = [X#tag{class=asn1ct_gen_ber:decode_class(X#tag.class)}|| X <- D#type.tag] + ++ + [#tag{class = asn1ct_gen_ber:decode_class('UNIVERSAL'), + number = asn1ct_gen_ber:decode_type(TypeTag), + form = ?CONSTRUCTED, + type = 'IMPLICIT'}], + emit([" {{_,Len},",{next,bytes},",",{curr,rb}, + "} = ?RT_BER:check_tags(TagIn ++ ",{asis,MyTag},", ", + {curr,bytes},", OptOrMand), ",nl]), + + emit([" ?RT_BER:decode_components(",{curr,rb}]), + InnerType = asn1ct_gen:get_inner(Cont#type.def), + ContName = case asn1ct_gen:type(InnerType) of + Atom when atom(Atom) -> Atom; + _ -> TypeNameSuffix + end, + emit([", Len, ",{next,bytes},", "]), +% NewCont = +% case Cont#type.def of +% {'ENUMERATED',_,Components}-> +% Cont#type{def={'ENUMERATED',Components}}; +% _ -> Cont +% end, + ObjFun = + case D#type.tablecinf of + [{objfun,_}|_R] -> + ", ObjFun"; + _ -> + [] + end, + gen_dec_line_sof(Erules,Typename,ContName,Cont,ObjFun), + emit([", []).",nl,nl,nl]). + + +gen_encode_sof_components(Erules,Typename,SeqOrSetOf,Cont) + when record(Cont,type)-> + + {Objfun,ObjFun_novar,EncObj} = + case Cont#type.tablecinf of + [{objfun,_}|_R] -> + {", ObjFun",", _",{no_attr,"ObjFun"}}; + _ -> + {"","",false} + end, + emit(["'enc_",asn1ct_gen:list2name(Typename), + "_components'([]",ObjFun_novar,", AccBytes, AccLen) -> ",nl]), + + case catch lists:member(der,get(encoding_options)) of + true -> + emit([indent(3), + "{?RT_BER:dynamicsort_SETOF(AccBytes),AccLen};",nl,nl]); + _ -> + emit([indent(3),"{lists:reverse(AccBytes),AccLen};",nl,nl]) + end, + emit(["'enc_",asn1ct_gen:list2name(Typename), + "_components'([H|T]",Objfun,",AccBytes, AccLen) ->",nl]), + TypeNameSuffix = asn1ct_gen:constructed_suffix(SeqOrSetOf,Cont#type.def), + gen_enc_line(Erules,Typename,TypeNameSuffix,Cont,"H",3, + mandatory,"{EncBytes,EncLen} = ",EncObj), + emit([",",nl]), + emit([indent(3),"'enc_",asn1ct_gen:list2name(Typename), + "_components'(T",Objfun,","]), + emit(["[EncBytes|AccBytes], AccLen + EncLen).",nl,nl]). + +%%============================================================================ +%% Encode/decode CHOICE +%% +%%============================================================================ + +gen_encode_choice(Erules,Typename,D) when record(D,type) -> + ChoiceTag = D#type.tag, + {'CHOICE',CompList} = D#type.def, + Ext = extensible(CompList), + CompList1 = case CompList of + {Rl,El} -> Rl ++ El; + _ -> CompList + end, + gen_enc_choice(Erules,Typename,ChoiceTag,CompList1,Ext), + emit({nl,nl}). + +gen_decode_choice(Erules,Typename,D) when record(D,type) -> + asn1ct_name:start(), + asn1ct_name:new(bytes), + ChoiceTag = D#type.tag, + {'CHOICE',CompList} = D#type.def, + Ext = extensible(CompList), + CompList1 = case CompList of + {Rl,El} -> Rl ++ El; + _ -> CompList + end, + gen_dec_choice(Erules,Typename,ChoiceTag,CompList1,Ext), + emit({".",nl}). + + +%%============================================================================ +%% Encode SEQUENCE +%% +%%============================================================================ + +gen_enc_sequence_call(Erules,TopType,[#'ComponentType'{name=Cname,typespec=Type,prop=Prop}|Rest],Pos,Ext,EncObj) -> + asn1ct_name:new(encBytes), + asn1ct_name:new(encLen), + Element = + case TopType of + ['EXTERNAL'] -> + io_lib:format("?RT_BER:cindex(~w,NewVal,~w)",[Pos+1,Cname]); + _ -> + io_lib:format("?RT_BER:cindex(~w,Val,~w)",[Pos+1,Cname]) + end, + InnerType = asn1ct_gen:get_inner(Type#type.def), + print_attribute_comment(InnerType,Pos,Prop), + gen_enc_line(Erules,TopType,Cname,Type,Element,3,Prop,EncObj), + case Rest of + [] -> + emit({com,nl}); + _ -> + emit({com,nl}), + gen_enc_sequence_call(Erules,TopType,Rest,Pos+1,Ext,EncObj) + end; + +gen_enc_sequence_call(_Erules,_TopType,[],_Num,_,_) -> + true. + +%%============================================================================ +%% Decode SEQUENCE +%% +%%============================================================================ + +gen_dec_sequence_call(Erules,TopType,CompList,Ext,DecObjInf) -> + gen_dec_sequence_call1(Erules,TopType, CompList, 1, Ext,DecObjInf,[],[]). + + +gen_dec_sequence_call1(Erules,TopType,[#'ComponentType'{name=Cname,typespec=Type,prop=Prop,tags=Tags}|Rest],Num,Ext,DecObjInf,LeadingAttrAcc,ArgsAcc) -> + {LA,PostponedDec} = + gen_dec_component(Erules,TopType,Cname,Tags,Type,Num,Prop, + Ext,DecObjInf), + case Rest of + [] -> + {LA ++ LeadingAttrAcc,PostponedDec ++ ArgsAcc}; + _ -> + emit({com,nl}), +% asn1ct_name:new(term), + asn1ct_name:new(bytes), + gen_dec_sequence_call1(Erules,TopType,Rest,Num+1,Ext,DecObjInf, + LA++LeadingAttrAcc,PostponedDec++ArgsAcc) + end; + +gen_dec_sequence_call1(_Erules,_TopType,[],1,_,_,_,_) -> + no_terms. +%%gen_dec_sequence_call1(Erules,_TopType,[],Num,_) -> +%% true. + + + +%%---------------------------- +%%SEQUENCE mandatory +%%---------------------------- + +gen_dec_component(Erules,TopType,Cname,CTags,Type,Pos,Prop,Ext,DecObjInf) -> + InnerType = + case Type#type.def of + #'ObjectClassFieldType'{type=OCFTType} -> OCFTType; + _ -> asn1ct_gen:get_inner(Type#type.def) + end, +% case asn1ct_gen:get_constraint(Type#type.constraint, +% tableconstraint_info) of +% no -> +% asn1ct_gen:get_inner(Type#type.def); +% _ -> +% Type#type.def +% end, + Prop1 = case {Prop,Ext} of + {mandatory,{ext,Epos,_}} when Pos >= Epos -> + 'OPTIONAL'; + _ -> + Prop + end, + print_attribute_comment(InnerType,Pos,Prop1), + emit(" "), + + case {InnerType,DecObjInf} of + {{typefield,_},NotFalse} when NotFalse /= false -> + asn1ct_name:new(term), + asn1ct_name:new(tmpterm), + emit({"{",{curr,tmpterm},", ",{next,bytes},",",{next,rb},"} = "}); + {{objectfield,_,_},_} -> + asn1ct_name:new(term), + asn1ct_name:new(tmpterm), + emit({"{",{curr,tmpterm},", ",{next,bytes},",",{next,rb},"} = "}); + _ -> + asn1ct_name:new(term), + emit({"{",{curr,term},",",{next,bytes},",",{next,rb},"} = "}) + end, + asn1ct_name:new(rb), + PostponedDec = + gen_dec_line(Erules,TopType,Cname,CTags,Type,Prop1,DecObjInf), + asn1ct_name:new(form), + PostponedDec. + + +%%------------------------------------- +%% Decode SET +%%------------------------------------- + +gen_dec_set(Erules,TopType,CompList,Pos,_Ext) -> + TagList = get_all_choice_tags(CompList), + emit({indent(3), + {curr,tagList}," = ",{asis,TagList},",",nl}), + emit({indent(3), + "case ?RT_BER:check_if_valid_tag(Bytes, ", + {curr,tagList},", OptOrMand) of",nl}), + asn1ct_name:new(tagList), + asn1ct_name:new(rbCho), + asn1ct_name:new(choTags), + gen_dec_set_cases(Erules,TopType,CompList,TagList,Pos), + asn1ct_name:new(tag), + asn1ct_name:new(bytes). + + + +gen_dec_set_cases(_,_,[],_,_) -> + ok; +gen_dec_set_cases(Erules,TopType,[H|T],List,Pos) -> + case H of + {'EXTENSIONMARK', _, _} -> + gen_dec_set_cases(Erules,TopType,T,List,Pos); + _ -> + Name = H#'ComponentType'.name, + Type = H#'ComponentType'.typespec, + + emit({indent(6),"'",Name,"' ->",nl}), + case Type#type.def of + {'CHOICE',_NewCompList} -> + gen_dec_set_cases_choice(Erules,TopType,H,Pos); + _ -> + gen_dec_set_cases_type(Erules,TopType,H,Pos) + end, + gen_dec_set_cases(Erules,TopType,T,List,Pos+1) + end. + + + + +gen_dec_set_cases_choice(_Erules,TopType,H,Pos) -> + Cname = H#'ComponentType'.name, + Tag = [X#tag{class=asn1ct_gen_ber:decode_class(X#tag.class)} + || X <- (H#'ComponentType'.typespec)#type.tag], + asn1ct_name:new(rbCho), + emit({indent(9),"{Dec, Rest, ",{curr,rbCho},"} = "}), + emit({"'dec_",asn1ct_gen:list2name([Cname|TopType]), + "'(Bytes,OptOrMand,",{asis,Tag},"),",nl}), + emit([" {{",Pos,",Dec}, Rest, ",{curr,rbCho},"}"]), + emit([";",nl,nl]). + + +gen_dec_set_cases_type(Erules,TopType,H,Pos) -> + Cname = H#'ComponentType'.name, + Type = H#'ComponentType'.typespec, + %% always use Prop = mandatory here Prop = H#'ComponentType'.prop, + + asn1ct_name:new(rbCho), + emit({indent(9),"{Dec, Rest, ",{curr,rbCho},"} = "}), + asn1ct_name:delete(bytes), + %% we have already seen the tag so now we must find the value + %% that why we always use 'mandatory' here + gen_dec_line(Erules,TopType,Cname,[],Type,mandatory,decObjInf), + asn1ct_name:new(bytes), + + emit([",",nl]), + emit(["{{",Pos,",Dec}, Rest, ",{curr,rbCho},"}"]), + emit([";",nl,nl]). + + +%%--------------------------------- +%% Decode SET result +%%--------------------------------- + +gen_dec_set_result(Erules,TopType,{CompList,_ExtList}) -> + gen_dec_set_result1(Erules,TopType, CompList, 1); +gen_dec_set_result(Erules,TopType,CompList) -> + gen_dec_set_result1(Erules,TopType, CompList, 1). + +gen_dec_set_result1(Erules,TopType, + [#'ComponentType'{name=Cname, + typespec=Type, + prop=Prop}|Rest],Num) -> + gen_dec_set_component(Erules,TopType,Cname,Type,Num,Prop), + case Rest of + [] -> + true; + _ -> + gen_dec_set_result1(Erules,TopType,Rest,Num+1) + end; + +gen_dec_set_result1(_Erules,_TopType,[],1) -> + no_terms; +gen_dec_set_result1(_Erules,_TopType,[],_Num) -> + true. + + +gen_dec_set_component(_Erules,_TopType,_Cname,Type,Pos,Prop) -> + InnerType = asn1ct_gen:get_inner(Type#type.def), + print_attribute_comment(InnerType,Pos,Prop), + emit({" {",{next,term},com,{next,termList},"} =",nl}), + emit({" case ",{curr,termList}," of",nl}), + emit({" [{",Pos,com,{curr,termTmp},"}|", + {curr,rest},"] -> "}), + emit({"{",{curr,termTmp},com, + {curr,rest},"};",nl}), + case Prop of + 'OPTIONAL' -> + emit([indent(10),"_ -> {asn1_NOVALUE, ",{curr,termList},"}",nl]); + {'DEFAULT', DefVal} -> + emit([indent(10), + "_ -> {",{asis,DefVal},", ",{curr,termList},"}",nl]); + mandatory -> + emit([indent(10), + "_ -> exit({error,{asn1,{mandatory_attribute_no, ", + Pos,", missing}}})",nl]) + end, + emit([indent(6),"end,",nl]), + asn1ct_name:new(rest), + asn1ct_name:new(term), + asn1ct_name:new(termList), + asn1ct_name:new(termTmp). + + +%%--------------------------------------------- +%% Encode CHOICE +%%--------------------------------------------- +%% for BER we currently do care (a little) if the choice has an EXTENSIONMARKER + + +gen_enc_choice(Erules,TopType,Tag,CompList,_Ext) -> + gen_enc_choice1(Erules,TopType,Tag,CompList,_Ext). + +gen_enc_choice1(Erules,TopType,Tag,CompList,_Ext) -> + asn1ct_name:clear(), + emit({" {EncBytes,EncLen} = case element(1,Val) of",nl}), + gen_enc_choice2(Erules,TopType,CompList), + emit([nl," end,",nl,nl]), + NewTag = [X#tag{class=asn1ct_gen_ber:decode_class(X#tag.class)}|| X <- Tag], +% gen_encode_tags(Erules,NewTag,"EncLen","EncBytes"). + emit(["?RT_BER:encode_tags(TagIn ++",{asis,NewTag},", EncBytes, EncLen).",nl]). + + + +gen_enc_choice2(Erules,TopType,[H1|T]) when record(H1,'ComponentType') -> + Cname = H1#'ComponentType'.name, + Type = H1#'ComponentType'.typespec, + emit({" ",{asis,Cname}," ->",nl}), + {Encobj,Assign} = +% case asn1ct_gen:get_constraint(Type#type.constraint, +% tableconstraint_info) of + case {Type#type.def,asn1ct_gen:get_constraint(Type#type.constraint, + componentrelation)} of + {#'ObjectClassFieldType'{},{componentrelation,_,_}} -> + asn1ct_name:new(tmpBytes), + asn1ct_name:new(encBytes), + asn1ct_name:new(encLen), + Emit = ["{",{curr,tmpBytes},", _} = "], + {{no_attr,"ObjFun"},Emit}; + _ -> + {false,[]} + end, + gen_enc_line(Erules,TopType,Cname,Type,"element(2,Val)",9, + mandatory,Assign,Encobj), + case Encobj of + false -> ok; + _ -> + emit({",",nl,indent(9),"{",{curr,encBytes},", ", + {curr,encLen},"}"}) + end, + emit({";",nl}), + case T of + [] -> + emit([indent(6), "Else -> ",nl, + indent(9),"exit({error,{asn1,{invalid_choice_type,Else}}})"]); + _ -> + true + end, + gen_enc_choice2(Erules,TopType,T); + +gen_enc_choice2(_,_,[]) -> + true. + + + + +%%-------------------------------------------- +%% Decode CHOICE +%%-------------------------------------------- + +gen_dec_choice(Erules,TopType, ChTag, CompList, Ext) -> + asn1ct_name:delete(bytes), + Tags = [X#tag{class=asn1ct_gen_ber:decode_class(X#tag.class)}|| X <- ChTag], + + emit([" {{_,Len},",{next,bytes}, + ", RbExp} = ?RT_BER:check_tags(TagIn++", + {asis,Tags},", ", + {curr,bytes},", OptOrMand),",nl]), + asn1ct_name:new(bytes), + asn1ct_name:new(len), + gen_dec_choice_indef_funs(Erules), + case Erules of + ber_bin -> + emit([indent(3),"case ",{curr,bytes}," of",nl]); + ber -> + emit([indent(3), + "case (catch ?RT_BER:peek_tag(",{curr,bytes},")) of",nl]) + end, + asn1ct_name:new(tagList), + asn1ct_name:new(choTags), + gen_dec_choice_cases(Erules,TopType,CompList), + case Ext of + noext -> + emit([indent(6), {curr,else}," -> ",nl]), + emit([indent(9),"case OptOrMand of",nl, + indent(12),"mandatory ->","exit({error,{asn1,", + "{invalid_choice_tag,",{curr,else},"}}});",nl, + indent(12),"_ ->","exit({error,{asn1,{no_optional_tag,", + {curr,else},"}}})",nl, + indent(9),"end",nl]); + _ -> + emit([indent(6),"_ -> ",nl]), + emit([indent(9),"{{asn1_ExtAlt,",{curr,bytes},"},", + empty_lb(Erules),", RbExp}",nl]) + end, + emit([indent(3),"end"]), + asn1ct_name:new(tag), + asn1ct_name:new(else). + +gen_dec_choice_indef_funs(Erules) -> + emit({indent(3),"IndefEndBytes = fun(indefinite,",indefend_match(Erules,used_var), + ")-> R; (_,B)-> B end,",nl}), + emit({indent(3),"IndefEndRb = fun(indefinite,",indefend_match(Erules,unused_var), + ")-> 2; (_,_)-> 0 end,",nl}). + + +gen_dec_choice_cases(_,_, []) -> + ok; +gen_dec_choice_cases(Erules,TopType, [H|T]) -> + asn1ct_name:push(rbCho), + Name = H#'ComponentType'.name, + emit([nl,"%% '",Name,"'",nl]), + Fcases = fun([T1,T2|Tail],Fun) -> + emit([indent(6),match_tag(Erules,T1)," ->",nl]), + gen_dec_choice_cases_type(Erules,TopType, H), + Fun([T2|Tail],Fun); + ([T1],_) -> + emit([indent(6),match_tag(Erules,T1)," ->",nl]), + gen_dec_choice_cases_type(Erules,TopType, H) + end, + Fcases(H#'ComponentType'.tags,Fcases), + asn1ct_name:pop(rbCho), + gen_dec_choice_cases(Erules,TopType, T). + + + +gen_dec_choice_cases_type(Erules,TopType,H) -> + Cname = H#'ComponentType'.name, + Type = H#'ComponentType'.typespec, + Prop = H#'ComponentType'.prop, + emit({indent(9),"{Dec, Rest, ",{curr,rbCho},"} = "}), + gen_dec_line(Erules,TopType,Cname,[],Type,Prop,false), + emit([",",nl,indent(9),"{{",{asis,Cname}, + ", Dec}, IndefEndBytes(Len,Rest), RbExp + ", + {curr,rbCho}," + IndefEndRb(Len,Rest)};",nl,nl]). + +encode_tag_val(Erules,{Class,TagNo}) when integer(TagNo) -> + Rtmod = rtmod(Erules), + Rtmod:encode_tag_val({asn1ct_gen_ber:decode_class(Class), + 0,TagNo}); +encode_tag_val(Erules,{Class,TypeName}) -> + Rtmod = rtmod(Erules), + Rtmod:encode_tag_val({asn1ct_gen_ber:decode_class(Class), + 0,asn1ct_gen_ber:decode_type(TypeName)}). + + +match_tag(ber_bin,Arg) -> + match_tag_with_bitsyntax(Arg); +match_tag(Erules,Arg) -> + io_lib:format("~p",[encode_tag_val(Erules,Arg)]). + +match_tag_with_bitsyntax({Class,TagNo}) when integer(TagNo) -> + match_tag_with_bitsyntax1({asn1ct_gen_ber:decode_class(Class), + 0,TagNo}); +match_tag_with_bitsyntax({Class,TypeName}) -> + match_tag_with_bitsyntax1({asn1ct_gen_ber:decode_class(Class), + 0,asn1ct_gen_ber:decode_type(TypeName)}). + +match_tag_with_bitsyntax1({Class, _Form, TagNo}) when (TagNo =< 30) -> + io_lib:format("<<~p:2,_:1,~p:5,_/binary>>",[Class bsr 6,TagNo]); + +match_tag_with_bitsyntax1({Class, _Form, TagNo}) -> + {Octets,Len} = mk_object_val(TagNo), + OctForm = case Len of + 1 -> "~p"; + 2 -> "~p,~p"; + 3 -> "~p,~p,~p"; + 4 -> "~p,~p,~p,~p" + end, + io_lib:format("<<~p:2,_:1,31:5," ++ OctForm ++ ",_/binary>>", + [Class bsr 6] ++ Octets). + +%%%%%%%%%%% +%% mk_object_val(Value) -> {OctetList, Len} +%% returns a Val as a list of octets, the 8 bit is allways set to one except +%% for the last octet, where its 0 +%% + + +mk_object_val(Val) when Val =< 127 -> + {[255 band Val], 1}; +mk_object_val(Val) -> + mk_object_val(Val bsr 7, [Val band 127], 1). +mk_object_val(0, Ack, Len) -> + {Ack, Len}; +mk_object_val(Val, Ack, Len) -> + mk_object_val(Val bsr 7, [((Val band 127) bor 128) | Ack], Len + 1). + + +get_all_choice_tags(ComponentTypeList) -> + get_all_choice_tags(ComponentTypeList,[]). + +get_all_choice_tags([],TagList) -> + TagList; +get_all_choice_tags([H|T],TagList) -> + Tags = H#'ComponentType'.tags, + get_all_choice_tags(T, TagList ++ [{H#'ComponentType'.name, Tags}]). + + + +%%--------------------------------------- +%% Generate the encode/decode code +%%--------------------------------------- + +gen_enc_line(Erules,TopType,Cname, + Type=#type{constraint=[{componentrelation,_,_}], + def=#'ObjectClassFieldType'{type={typefield,_}}}, + Element,Indent,OptOrMand=mandatory,EncObj) + when list(Element) -> + asn1ct_name:new(tmpBytes), + gen_enc_line(Erules,TopType,Cname,Type,Element,Indent,OptOrMand, + ["{",{curr,tmpBytes},",_} = "],EncObj); +gen_enc_line(Erules,TopType,Cname,Type,Element,Indent,OptOrMand,EncObj) + when list(Element) -> + gen_enc_line(Erules,TopType,Cname,Type,Element,Indent,OptOrMand, + ["{",{curr,encBytes},",",{curr,encLen},"} = "],EncObj). + +gen_enc_line(Erules,TopType,Cname,Type,Element,Indent,OptOrMand,Assign,EncObj) + when list(Element) -> + IndDeep = indent(Indent), + + Tag = [X#tag{class=asn1ct_gen_ber:decode_class(X#tag.class)} + || X <- Type#type.tag], + InnerType = asn1ct_gen:get_inner(Type#type.def), + WhatKind = asn1ct_gen:type(InnerType), + emit(IndDeep), + emit(Assign), + gen_optormand_case(OptOrMand,Erules,TopType,Cname,Type,InnerType,WhatKind, + Element), + case {Type,asn1ct_gen:get_constraint(Type#type.constraint, + componentrelation)} of +% #type{constraint=[{tableconstraint_info,RefedFieldName}], +% def={typefield,_}} -> + {#type{def=#'ObjectClassFieldType'{type={typefield,_}, + fieldname=RefedFieldName}}, + {componentrelation,_,_}} -> + {_LeadingAttrName,Fun} = EncObj, + case RefedFieldName of + {notype,T} -> + throw({error,{notype,type_from_object,T}}); + {Name,RestFieldNames} when atom(Name) -> + case OptOrMand of + mandatory -> ok; + _ -> +% emit(["{",{curr,tmpBytes},",",{curr,tmpLen}, + emit(["{",{curr,tmpBytes},", _} = "]) +%% asn1ct_name:new(tmpBytes), +%% asn1ct_name:new(tmpLen) + end, + emit({Fun,"(",{asis,Name},", ",Element,", [], ", + {asis,RestFieldNames},"),",nl}), + emit(IndDeep), + case OptOrMand of + mandatory -> + emit({"{",{curr,encBytes},", ",{curr,encLen},"} = "}), + emit({"?RT_BER:encode_open_type(",{curr,tmpBytes}, + ",",{asis,Tag},")"}); + _ -> +% emit({"{",{next,tmpBytes},", _} = "}), + emit({"{",{next,tmpBytes},", ",{curr,tmpLen}, + "} = "}), + emit({"?RT_BER:encode_open_type(",{curr,tmpBytes}, + ",",{asis,Tag},"),",nl}), + emit(IndDeep), + emit({"{",{next,tmpBytes},", ",{curr,tmpLen},"}"}) + end; + _ -> + throw({asn1,{'internal error'}}) + end; +% #type{constraint=[{tableconstraint_info,_}], +% def={objectfield,PrimFieldName1,PFNList}} -> + {{#'ObjectClassFieldType'{type={objectfield,PrimFieldName1, + PFNList}},_}, + {componentrelation,_,_}} -> + %% this is when the dotted list in the FieldName has more + %% than one element + {_LeadingAttrName,Fun} = EncObj, + emit({"?RT_BER:encode_open_type(",Fun,"(",{asis,PrimFieldName1}, + ", ",Element,", ",{asis,PFNList},"),",{asis,Tag},")"}); + _ -> + case WhatKind of + {primitive,bif} -> + EncType = + case Type#type.def of + #'ObjectClassFieldType'{ + type={fixedtypevaluefield, + _,Btype}} -> + Btype; + _ -> + Type + end, + asn1ct_gen_ber:gen_encode_prim(ber,EncType,{asis,Tag}, + Element); + {notype,_} -> + emit({"'enc_",InnerType,"'(",Element,", ",{asis,Tag},")"}); + 'ASN1_OPEN_TYPE' -> + asn1ct_gen_ber:gen_encode_prim(ber,Type#type{def='ASN1_OPEN_TYPE'},{asis,Tag},Element); + _ -> + {EncFunName, _, _} = + mkfuncname(TopType,Cname,WhatKind,enc), + case {WhatKind,Type#type.tablecinf,EncObj} of + {{constructed,bif},[{objfun,_}|_R],{_,Fun}} -> + emit([EncFunName,"(",Element,", ",{asis,Tag}, + ", ",Fun,")"]); + _ -> + emit([EncFunName,"(",Element,", ",{asis,Tag},")"]) + end + end + end, + case OptOrMand of + mandatory -> true; + _ -> + emit({nl,indent(7),"end"}) + end. + + + +gen_optormand_case(mandatory,_,_,_,_,_,_, _) -> + ok; +gen_optormand_case('OPTIONAL',Erules,_,_,_,_,_,Element) -> + emit({" case ",Element," of",nl}), + emit({indent(9),"asn1_NOVALUE -> {", + empty_lb(Erules),",0};",nl}), + emit({indent(9),"_ ->",nl,indent(12)}); +gen_optormand_case({'DEFAULT',DefaultValue},Erules,TopType,Cname,Type, + InnerType,WhatKind,Element) -> + CurrMod = get(currmod), + case catch lists:member(der,get(encoding_options)) of + true -> + emit(" case catch "), + asn1ct_gen:gen_check_call(TopType,Cname,Type,InnerType, + WhatKind,{asis,DefaultValue}, + Element), + emit({" of",nl}), + emit({indent(12),"true -> {[],0};",nl}); + _ -> + emit({" case ",Element," of",nl}), + emit({indent(9),"asn1_DEFAULT -> {", + empty_lb(Erules), + ",0};",nl}), + case DefaultValue of + #'Externalvaluereference'{module=CurrMod, + value=V} -> + emit({indent(9),"?",{asis,V}," -> {", + empty_lb(Erules),",0};",nl}); + _ -> + emit({indent(9),{asis, + DefaultValue}," -> {", + empty_lb(Erules),",0};",nl}) + end + end, + emit({indent(9),"_ ->",nl,indent(12)}). + + + + +gen_dec_line_sof(_Erules,TopType,Cname,Type,ObjFun) -> + + Tag = [X#tag{class=asn1ct_gen_ber:decode_class(X#tag.class)} + || X <- Type#type.tag], + InnerType = asn1ct_gen:get_inner(Type#type.def), + WhatKind = asn1ct_gen:type(InnerType), + case WhatKind of + {primitive,bif} -> + asn1ct_name:delete(len), + + asn1ct_name:new(len), + emit(["fun(FBytes,_,_)->",nl]), + EncType = case Type#type.def of + #'ObjectClassFieldType'{ + type={fixedtypevaluefield, + _,Btype}} -> + Btype; + _ -> + Type + end, + asn1ct_gen_ber:gen_dec_prim(ber,EncType,"FBytes",Tag, + [],no_length,?PRIMITIVE, + mandatory), + emit([nl,"end, []"]); + _ -> + case ObjFun of + [] -> + {DecFunName, _, _} = + mkfunname(TopType,Cname,WhatKind,dec,3), + emit([DecFunName,", ",{asis,Tag}]); + _ -> + {DecFunName, _, _} = + mkfunname(TopType,Cname,WhatKind,dec,4), + emit([DecFunName,", ",{asis,Tag},", ObjFun"]) + end + end. + + +gen_dec_line(Erules,TopType,Cname,CTags,Type,OptOrMand,DecObjInf) -> + BytesVar = asn1ct_gen:mk_var(asn1ct_name:curr(bytes)), + Tag = [X#tag{class=asn1ct_gen_ber:decode_class(X#tag.class)} + || X <- Type#type.tag], + InnerType = + case Type#type.def of + #'ObjectClassFieldType'{type=OCFTType} -> + OCFTType; + _ -> + asn1ct_gen:get_inner(Type#type.def) + end, + PostpDec = + case OptOrMand of + mandatory -> + gen_dec_call(InnerType,Erules,TopType,Cname,Type, + BytesVar,Tag,mandatory,", mandatory, ", + DecObjInf,OptOrMand); + _ -> %optional or default + case {CTags,Erules} of + {[CTag],ber_bin} -> + emit(["case ",{curr,bytes}," of",nl]), + emit([match_tag(Erules,CTag)," ->",nl]), + PostponedDec = + gen_dec_call(InnerType,Erules,TopType,Cname,Type, + BytesVar,Tag,mandatory, + ", opt_or_default, ",DecObjInf, + OptOrMand), + emit([";",nl]), + emit(["_ ->",nl]), + case OptOrMand of + {'DEFAULT', Def} -> + emit(["{",{asis,Def},",", + BytesVar,", 0 }",nl]); + 'OPTIONAL' -> + emit(["{ asn1_NOVALUE, ", + BytesVar,", 0 }",nl]) + end, + emit("end"), + PostponedDec; + _ -> + emit("case (catch "), + PostponedDec = + gen_dec_call(InnerType,Erules,TopType,Cname,Type, + BytesVar,Tag,OptOrMand, + ", opt_or_default, ",DecObjInf, + OptOrMand), + emit([") of",nl]), + case OptOrMand of + {'DEFAULT', Def} -> + emit(["{'EXIT',{error,{asn1,{no_optional_tag,_}}}}", + " -> {",{asis,Def},",", + BytesVar,", 0 };",nl]); + 'OPTIONAL' -> + emit(["{'EXIT',{error,{asn1,{no_optional_tag,_}}}}", + " -> { asn1_NOVALUE, ", + BytesVar,", 0 };",nl]) + end, + asn1ct_name:new(casetmp), + emit([{curr,casetmp},"-> ",{curr,casetmp},nl,"end"]), + PostponedDec + end + end, + case DecObjInf of + {Cname,ObjSet} -> % this must be the component were an object is + %% choosen from the object set according to the table + %% constraint. + {[{ObjSet,Cname,asn1ct_gen:mk_var(asn1ct_name:curr(term))}], + PostpDec}; + _ -> {[],PostpDec} + end. + + +gen_dec_call({typefield,_},Erules,_,_,Type,_,Tag,_,_,false,_) -> + %% this in case of a choice with typefield components + asn1ct_name:new(reason), + {FirstPFName,RestPFName} = +% asn1ct_gen:get_constraint(Type#type.constraint, +% tableconstraint_info), + (Type#type.def)#'ObjectClassFieldType'.fieldname, + emit([nl,indent(6),"begin",nl]), + emit([indent(9),"{OpenDec,TmpRest,TmpRbCho} =",nl,indent(12), + "?RT_BER:decode_open_type(",Erules,",",{curr,bytes},",", + {asis,Tag},"),",nl]), + emit([indent(9),"case (catch ObjFun(",{asis,FirstPFName}, + ", OpenDec, [], ",{asis,RestPFName}, + ")) of", nl]),%% ??? What about Tag + emit([indent(12),"{'EXIT',",{curr,reason},"} ->",nl]), +%% emit({indent(15),"throw({runtime_error,{'Type not ", +%% "compatible with tableconstraint', OpenDec}});",nl}), + emit([indent(15),"exit({'Type not ", + "compatible with table constraint', ",{curr,reason},"});",nl]), + emit([indent(12),"{TmpDec,_ ,_} ->",nl]), + emit([indent(15),"{TmpDec, TmpRest, TmpRbCho}",nl]), + emit([indent(9),"end",nl,indent(6),"end",nl]), + []; +gen_dec_call({typefield,_},_Erules,_,Cname,Type,_BytesVar,Tag,_,_, + _DecObjInf,OptOrMandComp) -> + emit(["?RT_BER:decode_open_type(",{curr,bytes},",",{asis,Tag},")"]), + RefedFieldName = + (Type#type.def)#'ObjectClassFieldType'.fieldname, +% asn1ct_gen:get_constraint(Type#type.constraint, +% tableconstraint_info), + [{Cname,RefedFieldName, + asn1ct_gen:mk_var(asn1ct_name:curr(term)), +% asn1ct_gen:mk_var(asn1ct_name:curr(tmpterm)),[],OptOrMandComp}]; + asn1ct_gen:mk_var(asn1ct_name:curr(tmpterm)),Tag,OptOrMandComp}]; +gen_dec_call({objectfield,PrimFieldName,PFNList},_Erules,_,Cname,_,_,Tag,_,_,_, + OptOrMandComp) -> + emit(["?RT_BER:decode_open_type(",{curr,bytes},",",{asis,Tag},")"]), + [{Cname,{PrimFieldName,PFNList}, + asn1ct_gen:mk_var(asn1ct_name:curr(term)), +% asn1ct_gen:mk_var(asn1ct_name:curr(tmpterm)),[],OptOrMandComp}]; + asn1ct_gen:mk_var(asn1ct_name:curr(tmpterm)),Tag,OptOrMandComp}]; +gen_dec_call(InnerType,Erules,TopType,Cname,Type,BytesVar,Tag,PrimOptOrMand, + OptOrMand,DecObjInf,_) -> + WhatKind = asn1ct_gen:type(InnerType), + gen_dec_call1(WhatKind,InnerType,Erules,TopType,Cname,Type,BytesVar,Tag, + PrimOptOrMand,OptOrMand), + case DecObjInf of + {Cname,{_,OSet,UniqueFName,ValIndex}} -> + Term = asn1ct_gen:mk_var(asn1ct_name:curr(term)), + ValueMatch = value_match(ValIndex,Term), + emit({",",nl,"ObjFun = 'getdec_",OSet,"'(", +% {asis,UniqueFName},", ",{curr,term},")"}); + {asis,UniqueFName},", ",ValueMatch,")"}); + _ -> + ok + end, + []. +gen_dec_call1({primitive,bif},InnerType,Erules,_,_,Type,BytesVar, + Tag,OptOrMand,_) -> + case InnerType of + {fixedtypevaluefield,_,Btype} -> + asn1ct_gen_ber:gen_dec_prim(Erules,Btype,BytesVar,Tag,[],no_length, + ?PRIMITIVE,OptOrMand); + _ -> + asn1ct_gen_ber:gen_dec_prim(Erules,Type,BytesVar,Tag,[],no_length, + ?PRIMITIVE,OptOrMand) + end; +gen_dec_call1('ASN1_OPEN_TYPE',_InnerType,Erules,_,_,Type,BytesVar, + Tag,OptOrMand,_) -> + asn1ct_gen_ber:gen_dec_prim(Erules,Type#type{def='ASN1_OPEN_TYPE'}, + BytesVar,Tag,[],no_length, + ?PRIMITIVE,OptOrMand); +gen_dec_call1(WhatKind,_,_Erules,TopType,Cname,Type,_,Tag,_,OptOrMand) -> + {DecFunName,_,_} = + mkfuncname(TopType,Cname,WhatKind,dec), + case {WhatKind,Type#type.tablecinf} of + {{constructed,bif},[{objfun,_}|_R]} -> + emit({DecFunName,"(",{curr,bytes},OptOrMand,{asis,Tag},", ObjFun)"}); + _ -> + emit({DecFunName,"(",{curr,bytes},OptOrMand,{asis,Tag},")"}) + end. + + +%%------------------------------------------------------ +%% General and special help functions (not exported) +%%------------------------------------------------------ + + +indent(N) -> + lists:duplicate(N,32). % 32 = space + + +mkvlist([H,T1|T], Sep) -> % Sep is a string e.g ", " or "+ " + emit([{var,H},Sep]), + mkvlist([T1|T], Sep); +mkvlist([H|T], Sep) -> + emit([{var,H}]), + mkvlist(T, Sep); +mkvlist([], _) -> + true. + +mkvlist(L) -> + mkvlist(L,", "). + +mkvplus(L) -> + mkvlist(L," + "). + +extensible(CompList) when list(CompList) -> + noext; +extensible({RootList,ExtList}) -> + {ext,length(RootList)+1,length(ExtList)}. + + +print_attribute_comment(InnerType,Pos,Prop) -> + CommentLine = "%%-------------------------------------------------", + emit([nl,CommentLine]), + case InnerType of + {typereference,_,Name} -> + emit([nl,"%% attribute number ",Pos," with type ",Name]); + {'Externaltypereference',_,XModule,Name} -> + emit([nl,"%% attribute number ",Pos," External ",XModule,":",Name]); + _ -> + emit([nl,"%% attribute number ",Pos," with type ",InnerType]) + end, + case Prop of + mandatory -> + continue; + {'DEFAULT', Def} -> + emit([" DEFAULT = ",{asis,Def}]); + 'OPTIONAL' -> + emit([" OPTIONAL"]) + end, + emit([nl,CommentLine,nl]). + + +mkfuncname(TopType,Cname,WhatKind,DecOrEnc) -> + CurrMod = get(currmod), + case WhatKind of + #'Externaltypereference'{module=CurrMod,type=EType} -> + F = lists:concat(["'",DecOrEnc,"_",EType,"'"]), + {F, "?MODULE", F}; + #'Externaltypereference'{module=Mod,type=EType} -> + {lists:concat(["'",Mod,"':'",DecOrEnc,"_",EType,"'"]),Mod, + lists:concat(["'",DecOrEnc,"_",EType,"'"])}; + {constructed,bif} -> + F = lists:concat(["'",DecOrEnc,"_",asn1ct_gen:list2name([Cname|TopType]),"'"]), + {F, "?MODULE", F} + end. + +mkfunname(TopType,Cname,WhatKind,DecOrEnc,Arity) -> + CurrMod = get(currmod), + case WhatKind of + #'Externaltypereference'{module=CurrMod,type=EType} -> + F = lists:concat(["fun '",DecOrEnc,"_",EType,"'/",Arity]), + {F, "?MODULE", F}; + #'Externaltypereference'{module=Mod,type=EType} -> + {lists:concat(["{'",Mod,"','",DecOrEnc,"_",EType,"'}"]),Mod, + lists:concat(["'",DecOrEnc,"_",EType,"'"])}; + {constructed,bif} -> + F = + lists:concat(["fun '",DecOrEnc,"_", + asn1ct_gen:list2name([Cname|TopType]),"'/", + Arity]), + {F, "?MODULE", F} + end. + +empty_lb(ber) -> + "[]"; +empty_lb(ber_bin) -> + "<<>>". + +rtmod(ber) -> + list_to_atom(?RT_BER); +rtmod(ber_bin) -> + list_to_atom(?RT_BER_BIN). + +indefend_match(ber,used_var) -> + "[0,0|R]"; +indefend_match(ber,unused_var) -> + "[0,0|_R]"; +indefend_match(ber_bin,used_var) -> + "<<0,0,R/binary>>"; +indefend_match(ber_bin,unused_var) -> + "<<0,0,_R/binary>>". + +notice_value_match() -> + Module = get(currmod), + put(value_match,{true,Module}). + +value_match(Index,Value) when atom(Value) -> + value_match(Index,atom_to_list(Value)); +value_match([],Value) -> + Value; +value_match([{VI,_Cname}|VIs],Value) -> + value_match1(Value,VIs,lists:concat(["element(",VI,","]),1). +value_match1(Value,[],Acc,Depth) -> + Acc ++ Value ++ lists:concat(lists:duplicate(Depth,")")); +value_match1(Value,[{VI,_Cname}|VIs],Acc,Depth) -> + value_match1(Value,VIs,Acc++lists:concat(["element(",VI,","]),Depth+1). diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_constructed_ber_bin_v2.erl b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_constructed_ber_bin_v2.erl new file mode 100644 index 0000000000..991240731e --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_constructed_ber_bin_v2.erl @@ -0,0 +1,1357 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: asn1ct_constructed_ber_bin_v2.erl,v 1.1 2008/12/17 09:53:29 mikpe Exp $ +%% +-module(asn1ct_constructed_ber_bin_v2). + +-export([gen_encode_sequence/3]). +-export([gen_decode_sequence/3]). +-export([gen_encode_set/3]). +-export([gen_decode_set/3]). +-export([gen_encode_sof/4]). +-export([gen_decode_sof/4]). +-export([gen_encode_choice/3]). +-export([gen_decode_choice/3]). + + +-include("asn1_records.hrl"). + +-import(asn1ct_gen, [emit/1,demit/1]). +-import(asn1ct_constructed_ber,[match_tag/2]). + +-define(ASN1CT_GEN_BER,asn1ct_gen_ber_bin_v2). + +% the encoding of class of tag bits 8 and 7 +-define(UNIVERSAL, 0). +-define(APPLICATION, 16#40). +-define(CONTEXT, 16#80). +-define(PRIVATE, 16#C0). + +% primitive or constructed encoding % bit 6 +-define(PRIMITIVE, 0). +-define(CONSTRUCTED, 2#00100000). + + + + +%%=============================================================================== +%%=============================================================================== +%%=============================================================================== +%% Encode/decode SEQUENCE (and SET) +%%=============================================================================== +%%=============================================================================== +%%=============================================================================== + +gen_encode_sequence(Erules,Typename,D) when record(D,type) -> + asn1ct_name:start(), + asn1ct_name:new(term), + asn1ct_name:new(bytes), + + %% if EXTERNAL type the input value must be transformed to + %% ASN1 1990 format + ValName = + case Typename of + ['EXTERNAL'] -> + emit([indent(4), + "NewVal = asn1rt_check:transform_to_EXTERNAL1990(Val),", + nl]), + "NewVal"; + _ -> + "Val" + end, + + {SeqOrSet,TableConsInfo,CompList} = + case D#type.def of + #'SEQUENCE'{tablecinf=TCI,components=CL} -> + {'SEQUENCE',TCI,CL}; + #'SET'{tablecinf=TCI,components=CL} -> + {'SET',TCI,CL} + end, + Ext = extensible(CompList), + CompList1 = case CompList of + {Rl,El} -> Rl ++ El; + _ -> CompList + end, + +%% don't match recordname for now, because of compatibility reasons +%% emit(["{'",asn1ct_gen:list2rname(Typename),"'"]), + emit(["{_"]), + case length(CompList1) of + 0 -> + true; + CompListLen -> + emit([","]), + mkcindexlist([Tc || Tc <- lists:seq(1,CompListLen)]) + end, + emit(["} = ",ValName,",",nl]), + EncObj = + case TableConsInfo of + #simpletableattributes{usedclassfield=Used, + uniqueclassfield=Unique} when Used /= Unique -> + false; + %% ObjectSet, name of the object set in constraints + %% + #simpletableattributes{objectsetname=ObjectSet, + c_name=AttrN, + c_index=N, + usedclassfield=UniqueFieldName, + uniqueclassfield=UniqueFieldName, + valueindex=ValueIndex} -> %% N is index of attribute that determines constraint + OSDef = + case ObjectSet of + {Module,OSName} -> + asn1_db:dbget(Module,OSName); + OSName -> + asn1_db:dbget(get(currmod),OSName) + end, +% io:format("currmod: ~p~nOSName: ~p~nAttrN: ~p~nN: ~p~nUniqueFieldName: ~p~n", +% [get(currmod),OSName,AttrN,N,UniqueFieldName]), + case (OSDef#typedef.typespec)#'ObjectSet'.gen of + true -> + ObjectEncode = + asn1ct_gen:un_hyphen_var(lists:concat(['Obj', + AttrN])), + emit([ObjectEncode," = ",nl]), + emit([" 'getenc_",ObjectSet,"'(",{asis,UniqueFieldName}, + ", ",nl]), + ValueMatch = value_match(ValueIndex, + lists:concat(["Cindex",N])), + emit([indent(35),ValueMatch,"),",nl]), + {AttrN,ObjectEncode}; + _ -> + false + end; + _ -> + case D#type.tablecinf of + [{objfun,_}|_] -> + %% when the simpletableattributes was at an outer + %% level and the objfun has been passed through the + %% function call + {"got objfun through args","ObjFun"}; + _ -> + false + end + end, + + gen_enc_sequence_call(Erules,Typename,CompList1,1,Ext,EncObj), + + emit([nl," BytesSoFar = "]), + case SeqOrSet of + 'SET' when (D#type.def)#'SET'.sorted == dynamic -> + emit("?RT_BER:dynamicsort_SET_components(["), + mkvlist(asn1ct_name:all(encBytes)), + emit(["]),",nl]); + _ -> + emit("["), + mkvlist(asn1ct_name:all(encBytes)), + emit(["],",nl]) + end, + emit("LenSoFar = "), + case asn1ct_name:all(encLen) of + [] -> emit("0"); + AllLengths -> + mkvplus(AllLengths) + end, + emit([",",nl]), + emit(["?RT_BER:encode_tags(TagIn, BytesSoFar, LenSoFar)." + ,nl]). + +gen_decode_sequence(Erules,Typename,D) when record(D,type) -> + asn1ct_name:start(), + asn1ct_name:new(tag), + #'SEQUENCE'{tablecinf=TableConsInfo,components=CList} = D#type.def, + Ext = extensible(CList), + CompList = case CList of + {Rl,El} -> Rl ++ El; + _ -> CList + end, + + emit([" %%-------------------------------------------------",nl]), + emit([" %% decode tag and length ",nl]), + emit([" %%-------------------------------------------------",nl]), + + asn1ct_name:new(tlv), + case CompList of + EmptyCL when EmptyCL == [];EmptyCL == {[],[]}-> % empty sequence + true; + _ -> + emit([{curr,tlv}," = "]) + end, + emit(["?RT_BER:match_tags(",{prev,tlv},",TagIn), ",nl]), + asn1ct_name:new(tlv), + asn1ct_name:new(v), + + {DecObjInf,UniqueFName,ValueIndex} = + case TableConsInfo of + #simpletableattributes{objectsetname=ObjectSet, + c_name=AttrN, + usedclassfield=UniqueFieldName, + uniqueclassfield=UniqueFieldName, + valueindex=ValIndex} -> +% {ObjectSet,AttrN,_N,UniqueFieldName} ->%% N is index of attribute that determines constraint + F = fun(#'ComponentType'{typespec=CT})-> + case {CT#type.constraint,CT#type.tablecinf} of + {[],[{objfun,_}|_]} -> true; + _ -> false + end + end, + case lists:any(F,CompList) of + true -> % when component relation constraint establish + %% relation from a component to another components + %% subtype component + {{AttrN,{deep,ObjectSet,UniqueFieldName,ValIndex}}, + UniqueFieldName,ValIndex}; + false -> + {{AttrN,ObjectSet},UniqueFieldName,ValIndex} + end; + _ -> +% case D#type.tablecinf of +% [{objfun,_}|_] -> +% {{"got objfun through args","ObjFun"},false,false}; +% _ -> + {false,false,false} +% end + end, + case gen_dec_sequence_call(Erules,Typename,CompList,Ext,DecObjInf) of + no_terms -> % an empty sequence + emit([nl,nl]), + demit(["Result = "]), %dbg + %% return value as record + asn1ct_name:new(rb), + emit([" {'",asn1ct_gen:list2rname(Typename),"'}.",nl,nl]); + {LeadingAttrTerm,PostponedDecArgs} -> + emit([com,nl,nl]), + case {LeadingAttrTerm,PostponedDecArgs} of + {[],[]} -> + ok; + {_,[]} -> + ok; + {[{ObjSet,LeadingAttr,Term}],PostponedDecArgs} -> + DecObj = asn1ct_gen:un_hyphen_var(lists:concat(['DecObj',LeadingAttr,Term])), + ValueMatch = value_match(ValueIndex,Term), + emit([DecObj," =",nl," 'getdec_",ObjSet,"'(", + {asis,UniqueFName},", ",ValueMatch,"),",nl]), + gen_dec_postponed_decs(DecObj,PostponedDecArgs) + end, + demit(["Result = "]), %dbg + %% return value as record + case Ext of + {ext,_,_} -> + emit(["case ",{prev,tlv}," of [] -> true; _ -> true end, % ... extra fields skipped",nl]); + noext -> + emit(["case ",{prev,tlv}," of",nl, + "[] -> true;", + "_ -> exit({error,{asn1, {unexpected,",{prev,tlv}, + "}}}) % extra fields not allowed",nl, + "end,",nl]) + end, + asn1ct_name:new(rb), + case Typename of + ['EXTERNAL'] -> + emit([" OldFormat={'",asn1ct_gen:list2rname(Typename), + "', "]), + mkvlist(asn1ct_name:all(term)), + emit(["},",nl]), + emit([" asn1rt_check:transform_to_EXTERNAL1994", + "(OldFormat).",nl]); + _ -> + emit([" {'",asn1ct_gen:list2rname(Typename),"', "]), + mkvlist(asn1ct_name:all(term)), + emit(["}.",nl,nl]) + end + end. + +gen_dec_postponed_decs(_,[]) -> + emit(nl); +gen_dec_postponed_decs(DecObj,[{_Cname,{FirstPFN,PFNList},Term, + TmpTerm,_Tag,OptOrMand}|Rest]) -> + + asn1ct_name:new(tmpterm), + asn1ct_name:new(reason), + asn1ct_name:new(tmptlv), + + emit([Term," = ",nl]), + N = case OptOrMand of + mandatory -> 0; + 'OPTIONAL' -> + emit_opt_or_mand_check(asn1_NOVALUE,TmpTerm), + 6; + {'DEFAULT',Val} -> + emit_opt_or_mand_check(Val,TmpTerm), + 6 + end, + emit([indent(N+3),"case (catch ",DecObj,"(",{asis,FirstPFN}, + ", ",TmpTerm,", ",{asis,PFNList},")) of",nl]), + emit([indent(N+6),"{'EXIT', ",{curr,reason},"} ->",nl]), + emit([indent(N+9),"exit({'Type not compatible with table constraint',", + {curr,reason},"});",nl]), + emit([indent(N+6),{curr,tmpterm}," ->",nl]), + emit([indent(N+9),{curr,tmpterm},nl]), + + case OptOrMand of + mandatory -> emit([indent(N+3),"end,",nl]); + _ -> + emit([indent(N+3),"end",nl, + indent(3),"end,",nl]) + end, + gen_dec_postponed_decs(DecObj,Rest). + +emit_opt_or_mand_check(Value,TmpTerm) -> + emit([indent(3),"case ",TmpTerm," of",nl, + indent(6),{asis,Value}," ->",{asis,Value},";",nl, + indent(6),"_ ->",nl]). + +%%============================================================================ +%% Encode/decode SET +%% +%%============================================================================ + +gen_encode_set(Erules,Typename,D) when record(D,type) -> + gen_encode_sequence(Erules,Typename,D). + +gen_decode_set(Erules,Typename,D) when record(D,type) -> + asn1ct_name:start(), + asn1ct_name:new(term), + asn1ct_name:new(tag), + #'SET'{tablecinf=TableConsInfo,components=TCompList} = D#type.def, + Ext = extensible(TCompList), + CompList = case TCompList of + {Rl,El} -> Rl ++ El; + _ -> TCompList + end, + + asn1ct_name:clear(), + asn1ct_name:new(tlv), + case CompList of + EmptyCL when EmptyCL == [];EmptyCL == {[],[]}-> % empty sequence + true; + _ -> + emit([{curr,tlv}," = "]) + end, + emit(["?RT_BER:match_tags(",{prev,tlv},",TagIn), ",nl]), + asn1ct_name:new(v), + + + {DecObjInf,UniqueFName} = + case TableConsInfo of + {ObjectSet,AttrN,_N,UniqueFieldName} ->%% N is index of attribute that determines constraint + F = fun(#'ComponentType'{typespec=CT})-> + case {CT#type.constraint,CT#type.tablecinf} of + {[],[{objfun,_}|_]} -> true; + _ -> false + end + end, + case lists:any(F,CompList) of + true -> % when component relation constraint establish + %% relation from a component to another components + %% subtype component + {{AttrN,{deep,ObjectSet,UniqueFieldName}}, + UniqueFieldName}; + false -> + {{AttrN,ObjectSet},UniqueFieldName} + end; + _ -> + {false,false} + end, + + case CompList of + [] -> % empty set + true; + _ -> + emit(["SetFun = fun(FunTlv) ->", nl]), + emit(["case FunTlv of ",nl]), + NextNum = gen_dec_set_cases(Erules,Typename,CompList,1), + emit([indent(6), {curr,else}," -> ",nl, + indent(9),"{",NextNum,", ",{curr,else},"}",nl]), + emit([indent(3),"end",nl]), + emit([indent(3),"end,",nl]), + + emit(["PositionList = [SetFun(TempTlv)|| TempTlv <- ",{curr,tlv},"],",nl]), + asn1ct_name:new(tlv), + emit([{curr,tlv}," = [Stlv || {_,Stlv} <- lists:sort(PositionList)],",nl]), + asn1ct_name:new(tlv) + + end, + case gen_dec_sequence_call(Erules,Typename,CompList,Ext,DecObjInf) of + no_terms -> % an empty sequence + emit([nl,nl]), + demit(["Result = "]), %dbg + %% return value as record + emit([" {'",asn1ct_gen:list2rname(Typename),"'}.",nl]); + {LeadingAttrTerm,PostponedDecArgs} -> + emit([com,nl,nl]), + case {LeadingAttrTerm,PostponedDecArgs} of + {[],[]} -> + ok; + {_,[]} -> + ok; + {[{ObjSet,LeadingAttr,Term}],PostponedDecArgs} -> + DecObj = lists:concat(['DecObj',LeadingAttr,Term]), + emit([DecObj," =",nl," 'getdec_",ObjSet,"'(", + {asis,UniqueFName},", ",Term,"),",nl]), + gen_dec_postponed_decs(DecObj,PostponedDecArgs) + end, + demit(["Result = "]), %dbg + %% return value as record + case Ext of + {ext,_,_} -> + emit(["case ",{prev,tlv}," of [] -> true; _ -> true end, % ... extra fields skipped",nl]); + noext -> + emit(["case ",{prev,tlv}," of",nl, + "[] -> true;", + "_ -> exit({error,{asn1, {unexpected,",{prev,tlv}, + "}}}) % extra fields not allowed",nl, + "end,",nl]) + end, + emit([" {'",asn1ct_gen:list2rname(Typename),"', "]), + mkvlist(asn1ct_name:all(term)), + emit(["}.",nl]) + end. + + +%%=============================================================================== +%%=============================================================================== +%%=============================================================================== +%% Encode/decode SEQUENCE OF and SET OF +%%=============================================================================== +%%=============================================================================== +%%=============================================================================== + +gen_encode_sof(Erules,Typename,_InnerTypename,D) when record(D,type) -> + asn1ct_name:start(), + {SeqOrSetOf, Cont} = D#type.def, + + Objfun = case D#type.tablecinf of + [{objfun,_}|_R] -> + ", ObjFun"; + _ -> + "" + end, + + emit([" {EncBytes,EncLen} = 'enc_",asn1ct_gen:list2name(Typename), + "_components'(Val",Objfun,",[],0),",nl]), + + emit([" ?RT_BER:encode_tags(TagIn, EncBytes, EncLen).",nl,nl]), + + gen_encode_sof_components(Erules,Typename,SeqOrSetOf,Cont). + + +gen_decode_sof(Erules,TypeName,_InnerTypeName,D) when record(D,type) -> + asn1ct_name:start(), + {SeqOrSetOf, _TypeTag, Cont} = + case D#type.def of + {'SET OF',_Cont} -> {'SET OF','SET',_Cont}; + {'SEQUENCE OF',_Cont} -> {'SEQUENCE OF','SEQUENCE',_Cont} + end, + TypeNameSuffix = asn1ct_gen:constructed_suffix(SeqOrSetOf,Cont#type.def), + + emit([" %%-------------------------------------------------",nl]), + emit([" %% decode tag and length ",nl]), + emit([" %%-------------------------------------------------",nl]), + + asn1ct_name:new(tlv), + emit([{curr,tlv}, + " = ?RT_BER:match_tags(",{prev,tlv},",TagIn), ",nl]), + asn1ct_name:new(v), + + emit(["["]), + + InnerType = asn1ct_gen:get_inner(Cont#type.def), + ContName = case asn1ct_gen:type(InnerType) of + Atom when atom(Atom) -> Atom; + _ -> TypeNameSuffix + end, +%% fix me + ObjFun = + case D#type.tablecinf of + [{objfun,_}|_R] -> + ", ObjFun"; + _ -> + [] + end, + gen_dec_line(Erules,TypeName,ContName,[],Cont,mandatory,ObjFun), + %% gen_dec_line_sof(Erules,Typename,ContName,Cont,ObjFun), + emit([" || ",{curr,v}," <- ",{curr,tlv},"].",nl,nl,nl]). + + +gen_encode_sof_components(Erules,Typename,SeqOrSetOf,Cont) + when record(Cont,type)-> + + {Objfun,Objfun_novar,EncObj} = + case Cont#type.tablecinf of + [{objfun,_}|_R] -> + {", ObjFun",", _",{no_attr,"ObjFun"}}; + _ -> + {"","",false} + end, + emit(["'enc_",asn1ct_gen:list2name(Typename), + "_components'([]",Objfun_novar,", AccBytes, AccLen) -> ",nl]), + + case catch lists:member(der,get(encoding_options)) of + true -> + emit([indent(3), + "{?RT_BER:dynamicsort_SETOF(AccBytes),AccLen};",nl,nl]); + _ -> + emit([indent(3),"{lists:reverse(AccBytes),AccLen};",nl,nl]) + end, + emit(["'enc_",asn1ct_gen:list2name(Typename), + "_components'([H|T]",Objfun,",AccBytes, AccLen) ->",nl]), + TypeNameSuffix = asn1ct_gen:constructed_suffix(SeqOrSetOf,Cont#type.def), + gen_enc_line(Erules,Typename,TypeNameSuffix,Cont,"H",3, + mandatory,"{EncBytes,EncLen} = ",EncObj), + emit([",",nl]), + emit([indent(3),"'enc_",asn1ct_gen:list2name(Typename), + "_components'(T",Objfun,","]), + emit(["[EncBytes|AccBytes], AccLen + EncLen).",nl,nl]). + +%%============================================================================ +%% Encode/decode CHOICE +%% +%%============================================================================ + +gen_encode_choice(Erules,Typename,D) when record(D,type) -> + ChoiceTag = D#type.tag, + {'CHOICE',CompList} = D#type.def, + Ext = extensible(CompList), + CompList1 = case CompList of + {Rl,El} -> Rl ++ El; + _ -> CompList + end, + gen_enc_choice(Erules,Typename,ChoiceTag,CompList1,Ext), + emit([nl,nl]). + +gen_decode_choice(Erules,Typename,D) when record(D,type) -> + asn1ct_name:start(), + asn1ct_name:new(bytes), + ChoiceTag = D#type.tag, + {'CHOICE',CompList} = D#type.def, + Ext = extensible(CompList), + CompList1 = case CompList of + {Rl,El} -> Rl ++ El; + _ -> CompList + end, + gen_dec_choice(Erules,Typename,ChoiceTag,CompList1,Ext), + emit([".",nl]). + + +%%============================================================================ +%% Encode SEQUENCE +%% +%%============================================================================ + +gen_enc_sequence_call(Erules,TopType,[#'ComponentType'{name=Cname,typespec=Type,prop=Prop}|Rest],Pos,Ext,EncObj) -> + asn1ct_name:new(encBytes), + asn1ct_name:new(encLen), + Element = + case TopType of + ['EXTERNAL'] -> + io_lib:format("Cindex~w",[Pos]); + _ -> + io_lib:format("Cindex~w",[Pos]) + end, + InnerType = asn1ct_gen:get_inner(Type#type.def), + print_attribute_comment(InnerType,Pos,Cname,Prop), + gen_enc_line(Erules,TopType,Cname,Type,Element,3,Prop,EncObj), + emit([com,nl]), + gen_enc_sequence_call(Erules,TopType,Rest,Pos+1,Ext,EncObj); + +gen_enc_sequence_call(_Erules,_TopType,[],_Num,_,_) -> + true. + +%%============================================================================ +%% Decode SEQUENCE +%% +%%============================================================================ + +gen_dec_sequence_call(Erules,TopType,CompList,Ext,DecObjInf) -> + gen_dec_sequence_call1(Erules,TopType, CompList, 1, Ext,DecObjInf,[],[]). + + +gen_dec_sequence_call1(Erules,TopType,[#'ComponentType'{name=Cname,typespec=Type,prop=Prop,tags=Tags}|Rest],Num,Ext,DecObjInf,LeadingAttrAcc,ArgsAcc) -> + {LA,PostponedDec} = + gen_dec_component(Erules,TopType,Cname,Tags,Type,Num,Prop, + Ext,DecObjInf), + case Rest of + [] -> + {LA ++ LeadingAttrAcc,PostponedDec ++ ArgsAcc}; + _ -> + emit([com,nl]), + asn1ct_name:new(bytes), + gen_dec_sequence_call1(Erules,TopType,Rest,Num+1,Ext,DecObjInf, + LA++LeadingAttrAcc,PostponedDec++ArgsAcc) + end; + +gen_dec_sequence_call1(_Erules,_TopType,[],1,_,_,_,_) -> + no_terms. + + +%%---------------------------- +%%SEQUENCE mandatory +%%---------------------------- + +gen_dec_component(Erules,TopType,Cname,CTags,Type,Pos,Prop,Ext,DecObjInf) -> + InnerType = + case Type#type.def of + #'ObjectClassFieldType'{type=OCFTType} -> OCFTType; + _ -> asn1ct_gen:get_inner(Type#type.def) + end, +% case asn1ct_gen:get_constraint(Type#type.constraint, +% tableconstraint_info) of +% no -> +% asn1ct_gen:get_inner(Type#type.def); +% _ -> +% Type#type.def +% end, + Prop1 = case {Prop,Ext} of + {mandatory,{ext,Epos,_}} when Pos >= Epos -> + 'OPTIONAL'; + _ -> + Prop + end, + print_attribute_comment(InnerType,Pos,Cname,Prop1), + asn1ct_name:new(term), + emit_term_tlv(Prop1,InnerType,DecObjInf), + asn1ct_name:new(rb), + PostponedDec = + gen_dec_line(Erules,TopType,Cname,CTags,Type,Prop1,DecObjInf), + asn1ct_name:new(v), + asn1ct_name:new(tlv), + asn1ct_name:new(form), + PostponedDec. + + +emit_term_tlv({'DEFAULT',_},InnerType,DecObjInf) -> + emit_term_tlv(opt_or_def,InnerType,DecObjInf); +emit_term_tlv('OPTIONAL',InnerType,DecObjInf) -> + emit_term_tlv(opt_or_def,InnerType,DecObjInf); +emit_term_tlv(Prop,{typefield,_},DecObjInf) -> + emit_term_tlv(Prop,type_or_object_field,DecObjInf); +emit_term_tlv(Prop,{objectfield,_,_},DecObjInf) -> + emit_term_tlv(Prop,type_or_object_field,DecObjInf); +emit_term_tlv(opt_or_def,type_or_object_field,_) -> + asn1ct_name:new(tmpterm), + emit(["{",{curr,tmpterm},",",{curr,tlv},"} = "]); +emit_term_tlv(opt_or_def,_,_) -> + emit(["{",{curr,term},",",{curr,tlv},"} = "]); +emit_term_tlv(_,type_or_object_field,false) -> + emit(["[",{curr,v},"|",{curr,tlv},"] = ",{prev,tlv},", ",nl, + {curr,term}," = "]); +emit_term_tlv(_,type_or_object_field,_) -> + asn1ct_name:new(tmpterm), + emit(["[",{curr,v},"|",{curr,tlv},"] = ",{prev,tlv},", ",nl]), + emit([nl," ",{curr,tmpterm}," = "]); +emit_term_tlv(mandatory,_,_) -> + emit(["[",{curr,v},"|",{curr,tlv},"] = ",{prev,tlv},", ",nl, + {curr,term}," = "]). + + +gen_dec_set_cases(_Erules,_TopType,[],Pos) -> + Pos; +gen_dec_set_cases(Erules,TopType,[Comp|RestComps],Pos) -> + Name = Comp#'ComponentType'.name, + Type = Comp#'ComponentType'.typespec, + CTags = Comp#'ComponentType'.tags, + + emit([indent(6),"%",Name,nl]), + Tags = case Type#type.tag of + [] -> % this is a choice without explicit tag + [(?ASN1CT_GEN_BER:decode_class(T1class) bsl 10) + T1number|| + {T1class,T1number} <- CTags]; + [FirstTag|_] -> + [(?ASN1CT_GEN_BER:decode_class(FirstTag#tag.class) bsl 10) + FirstTag#tag.number] + end, +% emit([indent(6),"%Tags: ",Tags,nl]), +% emit([indent(6),"%Type#type.tag: ",Type#type.tag,nl]), + CaseFun = fun(TagList=[H|T],Fun,N) -> + Semicolon = case TagList of + [_Tag1,_|_] -> [";",nl]; + _ -> "" + end, + emit(["TTlv = {",H,",_} ->",nl]), + emit([indent(4),"{",Pos,", TTlv}",Semicolon]), + Fun(T,Fun,N+1); + ([],_,0) -> + true; + ([],_,_) -> + emit([";",nl]) + end, + CaseFun(Tags,CaseFun,0), +%% emit([";",nl]), + gen_dec_set_cases(Erules,TopType,RestComps,Pos+1). + + + +%%--------------------------------------------- +%% Encode CHOICE +%%--------------------------------------------- +%% for BER we currently do care (a little) if the choice has an EXTENSIONMARKER + + +gen_enc_choice(Erules,TopType,Tag,CompList,_Ext) -> + gen_enc_choice1(Erules,TopType,Tag,CompList,_Ext). + +gen_enc_choice1(Erules,TopType,_Tag,CompList,_Ext) -> + asn1ct_name:clear(), + emit([" {EncBytes,EncLen} = case element(1,Val) of",nl]), + gen_enc_choice2(Erules,TopType,CompList), + emit([nl," end,",nl,nl]), + + emit(["?RT_BER:encode_tags(TagIn, EncBytes, EncLen).",nl]). + + +gen_enc_choice2(Erules,TopType,[H1|T]) when record(H1,'ComponentType') -> + Cname = H1#'ComponentType'.name, + Type = H1#'ComponentType'.typespec, + emit([" ",{asis,Cname}," ->",nl]), + {Encobj,Assign} = + case {Type#type.def,asn1ct_gen:get_constraint(Type#type.constraint, + componentrelation)} of + {#'ObjectClassFieldType'{},{componentrelation,_,_}} -> + asn1ct_name:new(tmpBytes), + asn1ct_name:new(encBytes), + asn1ct_name:new(encLen), + Emit = ["{",{curr,tmpBytes},", _} = "], + {{no_attr,"ObjFun"},Emit}; + _ -> + {false,[]} + end, +% case asn1ct_gen:get_constraint(Type#type.constraint, +% tableconstraint_info) of +% no -> +% {false,[]}; +% _ -> +% asn1ct_name:new(tmpBytes), +% asn1ct_name:new(encBytes), +% asn1ct_name:new(encLen), +% Emit = ["{",{curr,tmpBytes},", _} = "], +% {{no_attr,"ObjFun"},Emit} +% end, + gen_enc_line(Erules,TopType,Cname,Type,"element(2,Val)",9, + mandatory,Assign,Encobj), + case Encobj of + false -> ok; + _ -> + emit([",",nl,indent(9),"{",{curr,encBytes},", ", + {curr,encLen},"}"]) + end, + emit([";",nl]), + case T of + [] -> + emit([indent(6), "Else -> ",nl, + indent(9),"exit({error,{asn1,{invalid_choice_type,Else}}})"]); + _ -> + true + end, + gen_enc_choice2(Erules,TopType,T); + +gen_enc_choice2(_Erules,_TopType,[]) -> + true. + + + + +%%-------------------------------------------- +%% Decode CHOICE +%%-------------------------------------------- + +gen_dec_choice(Erules,TopType, _ChTag, CompList, Ext) -> + asn1ct_name:clear(), + asn1ct_name:new(tlv), + emit([{curr,tlv}, + " = ?RT_BER:match_tags(",{prev,tlv},",TagIn), ",nl]), + asn1ct_name:new(tlv), + asn1ct_name:new(v), + emit(["case (case ",{prev,tlv}, + " of [Ctemp",{prev,tlv},"] -> Ctemp",{prev,tlv}, + "; _ -> ",{prev,tlv}," end)"," of",nl]), + asn1ct_name:new(tagList), + asn1ct_name:new(choTags), + asn1ct_name:new(res), + gen_dec_choice_cases(Erules,TopType,CompList), + emit([indent(6), {curr,else}," -> ",nl]), + case Ext of + noext -> + emit([indent(9),"exit({error,{asn1,{invalid_choice_tag,", + {curr,else},"}}})",nl]); + _ -> + emit([indent(9),"{asn1_ExtAlt, ?RT_BER:encode(",{curr,else},")}",nl]) + end, + emit([indent(3),"end",nl]), + asn1ct_name:new(tag), + asn1ct_name:new(else). + + +gen_dec_choice_cases(_Erules,_TopType, []) -> + ok; +gen_dec_choice_cases(Erules,TopType, [H|T]) -> + Cname = H#'ComponentType'.name, + Type = H#'ComponentType'.typespec, + Prop = H#'ComponentType'.prop, + Tags = Type#type.tag, + Fcases = fun([{T1class,T1number}|Tail],Fun) -> + emit([indent(4),{curr,v}," = {", + (?ASN1CT_GEN_BER:decode_class(T1class) bsl 10) + + T1number,",_} -> ",nl]), + emit([indent(8),"{",{asis,Cname},", "]), + gen_dec_line(Erules,TopType,Cname,[],Type,Prop,false), + emit(["};",nl,nl]), + Fun(Tail,Fun); + ([],_) -> + ok + end, + emit([nl,"%% '",Cname,"'",nl]), + case {Tags,asn1ct:get_gen_state_field(namelist)} of + {[],_} -> % choice without explicit tags + Fcases(H#'ComponentType'.tags,Fcases); + {[FirstT|_RestT],[{Cname,undecoded}|Names]} -> + DecTag=(?ASN1CT_GEN_BER:decode_class(FirstT#tag.class) bsl 10) + + FirstT#tag.number, + asn1ct:add_generated_refed_func({[Cname|TopType],undecoded, + [DecTag],Type}), + asn1ct:update_gen_state(namelist,Names), + emit([indent(4),{curr,res}," = ", + match_tag(ber_bin,{FirstT#tag.class,FirstT#tag.number}), + " -> ",nl]), + emit([indent(8),"{",{asis,Cname},", {'", + asn1ct_gen:list2name([Cname|TopType]),"',", + {curr,res},"}};",nl,nl]); + {[FirstT|RestT],_} -> + emit([indent(4),"{", + (?ASN1CT_GEN_BER:decode_class(FirstT#tag.class) bsl 10) + + FirstT#tag.number,", ",{curr,v},"} -> ",nl]), + emit([indent(8),"{",{asis,Cname},", "]), + gen_dec_line(Erules,TopType,Cname,[],Type#type{tag=RestT},Prop,false), + emit(["};",nl,nl]) + end, + gen_dec_choice_cases(Erules,TopType, T). + + + +%%--------------------------------------- +%% Generate the encode/decode code +%%--------------------------------------- + +gen_enc_line(Erules,TopType,Cname, + Type=#type{constraint=[{componentrelation,_,_}], + def=#'ObjectClassFieldType'{type={typefield,_}}}, + Element,Indent,OptOrMand=mandatory,EncObj) + when list(Element) -> + asn1ct_name:new(tmpBytes), + gen_enc_line(Erules,TopType,Cname,Type,Element,Indent,OptOrMand, + ["{",{curr,tmpBytes},",_} = "],EncObj); +gen_enc_line(Erules,TopType,Cname,Type,Element,Indent,OptOrMand,EncObj) + when list(Element) -> + gen_enc_line(Erules,TopType,Cname,Type,Element,Indent,OptOrMand, + ["{",{curr,encBytes},",",{curr,encLen},"} = "],EncObj). + +gen_enc_line(Erules,TopType,Cname,Type,Element,Indent,OptOrMand,Assign,EncObj) + when list(Element) -> + IndDeep = indent(Indent), + Tag = lists:reverse([?ASN1CT_GEN_BER:encode_tag_val( + ?ASN1CT_GEN_BER:decode_class(X#tag.class), + X#tag.form, + X#tag.number) + || X <- Type#type.tag]), + InnerType = asn1ct_gen:get_inner(Type#type.def), + WhatKind = asn1ct_gen:type(InnerType), + emit(IndDeep), + emit(Assign), + gen_optormand_case(OptOrMand,Erules,TopType,Cname,Type,InnerType,WhatKind, + Element), + case {Type,asn1ct_gen:get_constraint(Type#type.constraint, + componentrelation)} of +% #type{constraint=[{tableconstraint_info,RefedFieldName}], +% def={typefield,_}} -> + {#type{def=#'ObjectClassFieldType'{type={typefield,_}, + fieldname=RefedFieldName}}, + {componentrelation,_,_}} -> + {_LeadingAttrName,Fun} = EncObj, + case RefedFieldName of + {notype,T} -> + throw({error,{notype,type_from_object,T}}); + {Name,RestFieldNames} when atom(Name) -> + case OptOrMand of + mandatory -> ok; + _ -> +% emit(["{",{curr,tmpBytes},",",{curr,tmpLen}, + emit(["{",{curr,tmpBytes},",_ } = "]) +% "} = "]) + end, + emit([Fun,"(",{asis,Name},", ",Element,", ", + {asis,RestFieldNames},"),",nl]), + emit(IndDeep), + case OptOrMand of + mandatory -> + emit(["{",{curr,encBytes},",",{curr,encLen}, + "} = "]), + emit(["?RT_BER:encode_open_type(",{curr,tmpBytes}, + ",",{asis,Tag},")"]); + _ -> +% emit(["{",{next,tmpBytes},", _} = "]), + emit(["{",{next,tmpBytes},",",{curr,tmpLen}, + "} = "]), + emit(["?RT_BER:encode_open_type(",{curr,tmpBytes}, + ",",{asis,Tag},"),",nl]), + emit(IndDeep), + emit(["{",{next,tmpBytes},", ",{curr,tmpLen},"}"]) + end; + _ -> + throw({asn1,{'internal error'}}) + end; + {{#'ObjectClassFieldType'{type={objectfield,PrimFieldName1, + PFNList}},_}, + {componentrelation,_,_}} -> + %% this is when the dotted list in the FieldName has more + %% than one element + {_LeadingAttrName,Fun} = EncObj, + emit(["?RT_BER:encode_open_type(",Fun,"(",{asis,PrimFieldName1}, + ", ",Element,", ",{asis,PFNList},"))"]); + _ -> + case WhatKind of + {primitive,bif} -> + EncType = + case Type#type.def of + #'ObjectClassFieldType'{type={fixedtypevaluefield,_,Btype}} -> + Btype; + _ -> + Type + end, + ?ASN1CT_GEN_BER:gen_encode_prim(ber,EncType,{asis,Tag}, + Element); + {notype,_} -> + emit(["'enc_",InnerType,"'(",Element,", ",{asis,Tag},")"]); + 'ASN1_OPEN_TYPE' -> + case Type#type.def of + #'ObjectClassFieldType'{} -> %Open Type + ?ASN1CT_GEN_BER:gen_encode_prim(ber,#type{def='ASN1_OPEN_TYPE'},{asis,Tag},Element); + _ -> + ?ASN1CT_GEN_BER:gen_encode_prim(ber,Type, + {asis,Tag}, + Element) + end; + _ -> + {EncFunName, _EncMod, _EncFun} = + mkfuncname(TopType,Cname,WhatKind,"enc_"), + case {WhatKind,Type#type.tablecinf,EncObj} of + {{constructed,bif},[{objfun,_}|_R],{_,Fun}} -> + emit([EncFunName,"(",Element,", ",{asis,Tag}, + ", ",Fun,")"]); + _ -> + emit([EncFunName,"(",Element,", ",{asis,Tag},")"]) + end + end + end, + case OptOrMand of + mandatory -> true; + _ -> + emit([nl,indent(7),"end"]) + end. + +gen_optormand_case(mandatory,_Erules,_TopType,_Cname,_Type,_InnerType,_WhatKind, + _Element) -> + ok; +gen_optormand_case('OPTIONAL',Erules,_TopType,_Cname,_Type,_InnerType,_WhatKind, + Element) -> + emit([" case ",Element," of",nl]), + emit([indent(9),"asn1_NOVALUE -> {", + empty_lb(Erules),",0};",nl]), + emit([indent(9),"_ ->",nl,indent(12)]); +gen_optormand_case({'DEFAULT',DefaultValue},Erules,TopType,Cname,Type, + InnerType,WhatKind,Element) -> + CurrMod = get(currmod), + case catch lists:member(der,get(encoding_options)) of + true -> + emit(" case catch "), + asn1ct_gen:gen_check_call(TopType,Cname,Type,InnerType, + WhatKind,{asis,DefaultValue}, + Element), + emit([" of",nl]), + emit([indent(12),"true -> {[],0};",nl]); + _ -> + emit([" case ",Element," of",nl]), + emit([indent(9),"asn1_DEFAULT -> {", + empty_lb(Erules), + ",0};",nl]), + case DefaultValue of + #'Externalvaluereference'{module=CurrMod, + value=V} -> + emit([indent(9),"?",{asis,V}," -> {", + empty_lb(Erules),",0};",nl]); + _ -> + emit([indent(9),{asis, + DefaultValue}," -> {", + empty_lb(Erules),",0};",nl]) + end + end, + emit([indent(9),"_ ->",nl,indent(12)]). + + + +gen_dec_line(Erules,TopType,Cname,CTags,Type,OptOrMand,DecObjInf) -> + BytesVar = asn1ct_gen:mk_var(asn1ct_name:curr(v)), + Tag = + [(?ASN1CT_GEN_BER:decode_class(X#tag.class) bsl 10) + X#tag.number || + X <- Type#type.tag], + ChoiceTags = + [(?ASN1CT_GEN_BER:decode_class(Class) bsl 10) + Number|| + {Class,Number} <- CTags], + InnerType = + case Type#type.def of + #'ObjectClassFieldType'{type=OCFTType} -> + OCFTType; + _ -> + asn1ct_gen:get_inner(Type#type.def) + end, + PostpDec = + case OptOrMand of + mandatory -> + gen_dec_call(InnerType,Erules,TopType,Cname,Type, + BytesVar,Tag, + mandatory,", mandatory, ",DecObjInf,OptOrMand); + _ -> %optional or default or a mandatory component after an extensionmark + {FirstTag,RestTag} = + case Tag of + [] -> + {ChoiceTags,[]}; + [Ft|Rt] -> + {Ft,Rt} + end, + emit(["case ",{prev,tlv}," of",nl]), + PostponedDec = + case Tag of + [] when length(ChoiceTags) > 0 -> % a choice without explicit tag + Fcases = + fun(FirstTag1) -> + emit(["[",{curr,v}," = {",{asis,FirstTag1}, + ",_}|Temp", + {curr,tlv}, + "] ->",nl]), + emit([indent(4),"{"]), + Pdec= + gen_dec_call(InnerType,Erules, + TopType,Cname,Type, + BytesVar,RestTag, + mandatory, + ", mandatory, ", + DecObjInf,OptOrMand), + + emit([", Temp",{curr,tlv},"}"]), + emit([";",nl]), + Pdec + end, + hd([Fcases(TmpTag)|| TmpTag <- FirstTag]); + + [] -> % an open type without explicit tag + emit(["[",{curr,v},"|Temp",{curr,tlv},"] ->",nl]), + emit([indent(4),"{"]), + Pdec= + gen_dec_call(InnerType,Erules,TopType,Cname, + Type,BytesVar,RestTag,mandatory, + ", mandatory, ",DecObjInf, + OptOrMand), + + emit([", Temp",{curr,tlv},"}"]), + emit([";",nl]), + Pdec; + + _ -> + emit(["[{",{asis,FirstTag}, + ",",{curr,v},"}|Temp", + {curr,tlv}, + "] ->",nl]), + emit([indent(4),"{"]), + Pdec= + gen_dec_call(InnerType,Erules,TopType,Cname, + Type,BytesVar,RestTag,mandatory, + ", mandatory, ",DecObjInf, + OptOrMand), + + emit([", Temp",{curr,tlv},"}"]), + emit([";",nl]), + Pdec + end, + + emit([indent(4),"_ ->",nl]), + case OptOrMand of + {'DEFAULT', Def} -> + emit([indent(8),"{",{asis,Def},",",{prev,tlv},"}",nl]); + 'OPTIONAL' -> + emit([indent(8),"{ asn1_NOVALUE, ",{prev,tlv},"}",nl]) + end, + emit(["end"]), + PostponedDec + end, + case DecObjInf of + {Cname,ObjSet} -> % this must be the component were an object is + %% choosen from the object set according to the table + %% constraint. + {[{ObjSet,Cname,asn1ct_gen:mk_var(asn1ct_name:curr(term))}], + PostpDec}; + _ -> {[],PostpDec} + end. + +gen_dec_call({typefield,_},_,_,_Cname,Type,BytesVar,Tag,_,_,false,_) -> + %% this in case of a choice with typefield components + asn1ct_name:new(reason), + asn1ct_name:new(opendec), + asn1ct_name:new(tmpterm), + asn1ct_name:new(tmptlv), + + {FirstPFName,RestPFName} = +% asn1ct_gen:get_constraint(Type#type.constraint, +% tableconstraint_info), + (Type#type.def)#'ObjectClassFieldType'.fieldname, + emit([nl,indent(6),"begin",nl]), +% emit([indent(9),{curr,opendec}," = ?RT_BER:decode_open_type(", + emit([indent(9),{curr,tmptlv}," = ?RT_BER:decode_open_type(", + BytesVar,",",{asis,Tag},"),",nl]), +% emit([indent(9),"{",{curr,tmptlv},",_} = ?RT_BER:decode(", +% {curr,opendec},"),",nl]), + + emit([indent(9),"case (catch ObjFun(",{asis,FirstPFName}, + ", ",{curr,tmptlv},", ",{asis,RestPFName}, + ")) of", nl]),%% ??? What about Tag + emit([indent(12),"{'EXIT',",{curr,reason},"} ->",nl]), + emit([indent(15),"exit({'Type not ", + "compatible with table constraint', ",{curr,reason},"});",nl]), + emit([indent(12),{curr,tmpterm}," ->",nl]), + emit([indent(15),{curr,tmpterm},nl]), + emit([indent(9),"end",nl,indent(6),"end",nl]), + []; +gen_dec_call({typefield,_},_,_,Cname,Type,BytesVar,Tag,_,_,_DecObjInf,OptOrMandComp) -> + emit(["?RT_BER:decode_open_type(",BytesVar,",",{asis,Tag},")"]), + RefedFieldName = +% asn1ct_gen:get_constraint(Type#type.constraint, +% tableconstraint_info), + (Type#type.def)#'ObjectClassFieldType'.fieldname, + [{Cname,RefedFieldName,asn1ct_gen:mk_var(asn1ct_name:curr(term)), + asn1ct_gen:mk_var(asn1ct_name:curr(tmpterm)),Tag,OptOrMandComp}]; +gen_dec_call({objectfield,PrimFieldName,PFNList},_,_,Cname,_,BytesVar,Tag,_,_,_,OptOrMandComp) -> + emit(["?RT_BER:decode_open_type(",BytesVar,",",{asis,Tag},")"]), + [{Cname,{PrimFieldName,PFNList},asn1ct_gen:mk_var(asn1ct_name:curr(term)), + asn1ct_gen:mk_var(asn1ct_name:curr(tmpterm)),Tag,OptOrMandComp}]; +gen_dec_call(InnerType,Erules,TopType,Cname,Type,BytesVar,Tag,PrimOptOrMand, + OptOrMand,DecObjInf,_) -> + WhatKind = asn1ct_gen:type(InnerType), + gen_dec_call1(WhatKind,InnerType,Erules,TopType,Cname,Type,BytesVar,Tag, + PrimOptOrMand,OptOrMand), + case DecObjInf of + {Cname,{_,OSet,UniqueFName,ValIndex}} -> + Term = asn1ct_gen:mk_var(asn1ct_name:curr(term)), + ValueMatch = value_match(ValIndex,Term), + emit([",",nl,"ObjFun = 'getdec_",OSet,"'(", +% {asis,UniqueFName},", ",{curr,term},")"]); + {asis,UniqueFName},", ",ValueMatch,")"]); + _ -> + ok + end, + []. +gen_dec_call1({primitive,bif},InnerType,Erules,TopType,Cname,Type,BytesVar, + Tag,OptOrMand,_) -> + case {asn1ct:get_gen_state_field(namelist),InnerType} of + {[{Cname,undecoded}|Rest],_} -> + asn1ct:add_generated_refed_func({[Cname|TopType],undecoded, + Tag,Type}), + asn1ct:update_gen_state(namelist,Rest), +% emit(["?RT_BER:match_tags(",BytesVar,",",{asis,Tag},")"]); + emit(["{'",asn1ct_gen:list2name([Cname|TopType]),"',", + BytesVar,"}"]); + {_,{fixedtypevaluefield,_,Btype}} -> + ?ASN1CT_GEN_BER:gen_dec_prim(Erules,Btype,BytesVar,Tag,[], + ?PRIMITIVE,OptOrMand); + _ -> + ?ASN1CT_GEN_BER:gen_dec_prim(Erules,Type,BytesVar,Tag,[], + ?PRIMITIVE,OptOrMand) + end; +gen_dec_call1('ASN1_OPEN_TYPE',_InnerType,Erules,TopType,Cname,Type,BytesVar, + Tag,OptOrMand,_) -> + case {asn1ct:get_gen_state_field(namelist),Type#type.def} of + {[{Cname,undecoded}|Rest],_} -> + asn1ct:add_generated_refed_func({[Cname|TopType],undecoded, + Tag,Type}), + asn1ct:update_gen_state(namelist,Rest), + emit(["{'",asn1ct_gen:list2name([Cname|TopType]),"',", + BytesVar,"}"]); +% emit(["?RT_BER:match_tags(",BytesVar,",",{asis,Tag},")"]); + {_,#'ObjectClassFieldType'{type=OpenType}} -> + ?ASN1CT_GEN_BER:gen_dec_prim(Erules,#type{def=OpenType}, + BytesVar,Tag,[], + ?PRIMITIVE,OptOrMand); + _ -> + ?ASN1CT_GEN_BER:gen_dec_prim(Erules,Type,BytesVar,Tag,[], + ?PRIMITIVE,OptOrMand) + end; +gen_dec_call1(WhatKind,_,_Erules,TopType,Cname,Type,BytesVar, + Tag,_,_OptOrMand) -> + case asn1ct:get_gen_state_field(namelist) of + [{Cname,undecoded}|Rest] -> + asn1ct:add_generated_refed_func({[Cname|TopType],undecoded, + Tag,Type}), + asn1ct:update_gen_state(namelist,Rest), + emit(["{'",asn1ct_gen:list2name([Cname|TopType]),"',", + BytesVar,"}"]); + _ -> +% {DecFunName, _DecMod, _DecFun} = +% case {asn1ct:get_gen_state_field(namelist),WhatKind} of + EmitDecFunCall = + fun(FuncName) -> + case {WhatKind,Type#type.tablecinf} of + {{constructed,bif},[{objfun,_}|_Rest]} -> + emit([FuncName,"(",BytesVar,", ",{asis,Tag}, + ", ObjFun)"]); + _ -> + emit([FuncName,"(",BytesVar,", ",{asis,Tag},")"]) + end + end, + case asn1ct:get_gen_state_field(namelist) of + [{Cname,List}|Rest] when list(List) -> + case WhatKind of + #'Externaltypereference'{} -> + %%io:format("gen_dec_call1 1:~n~p~n~n",[WhatKind]), + asn1ct:add_tobe_refed_func({WhatKind,List}); + _ -> + %%io:format("gen_dec_call1 2:~n~p~n~n",[[Cname|TopType]]), + asn1ct:add_tobe_refed_func({[Cname|TopType], + List}) + end, + asn1ct:update_gen_state(namelist,Rest), + Prefix=asn1ct:get_gen_state_field(prefix), + {DecFunName,_,_}= + mkfuncname(TopType,Cname,WhatKind,Prefix), + EmitDecFunCall(DecFunName); + [{Cname,parts}|Rest] -> + asn1ct:update_gen_state(namelist,Rest), + asn1ct:get_gen_state_field(prefix), + %% This is to prepare SEQUENCE OF value in + %% partial incomplete decode for a later + %% part-decode, i.e. skip %% the tag. + asn1ct:add_generated_refed_func({[Cname|TopType], + parts, + [],Type}), + emit(["{'",asn1ct_gen:list2name([Cname|TopType]),"',"]), + EmitDecFunCall("?RT_BER:match_tags"), + emit("}"); + _ -> + {DecFunName,_,_}= + mkfuncname(TopType,Cname,WhatKind,"dec_"), + EmitDecFunCall(DecFunName) + end +% case {WhatKind,Type#type.tablecinf} of +% {{constructed,bif},[{objfun,_}|_Rest]} -> +% emit([DecFunName,"(",BytesVar,", ",{asis,Tag}, +% ", ObjFun)"]); +% _ -> +% emit([DecFunName,"(",BytesVar,", ",{asis,Tag},")"]) +% end + end. + + +%%------------------------------------------------------ +%% General and special help functions (not exported) +%%------------------------------------------------------ + + +indent(N) -> + lists:duplicate(N,32). % 32 = space + +mkcindexlist([H,T1|T], Sep) -> % Sep is a string e.g ", " or "+ " + emit(["Cindex",H,Sep]), + mkcindexlist([T1|T], Sep); +mkcindexlist([H|T], Sep) -> + emit(["Cindex",H]), + mkcindexlist(T, Sep); +mkcindexlist([], _) -> + true. + +mkcindexlist(L) -> + mkcindexlist(L,", "). + + +mkvlist([H,T1|T], Sep) -> % Sep is a string e.g ", " or "+ " + emit([{var,H},Sep]), + mkvlist([T1|T], Sep); +mkvlist([H|T], Sep) -> + emit([{var,H}]), + mkvlist(T, Sep); +mkvlist([], _) -> + true. + +mkvlist(L) -> + mkvlist(L,", "). + +mkvplus(L) -> + mkvlist(L," + "). + +extensible(CompList) when list(CompList) -> + noext; +extensible({RootList,ExtList}) -> + {ext,length(RootList)+1,length(ExtList)}. + + +print_attribute_comment(InnerType,Pos,Cname,Prop) -> + CommentLine = "%%-------------------------------------------------", + emit([nl,CommentLine]), + case InnerType of + {typereference,_,Name} -> + emit([nl,"%% attribute ",Cname,"(",Pos,") with type ",Name]); + {'Externaltypereference',_,XModule,Name} -> + emit([nl,"%% attribute ",Cname,"(",Pos,") External ",XModule,":",Name]); + _ -> + emit([nl,"%% attribute ",Cname,"(",Pos,") with type ",InnerType]) + end, + case Prop of + mandatory -> + continue; + {'DEFAULT', Def} -> + emit([" DEFAULT = ",{asis,Def}]); + 'OPTIONAL' -> + emit([" OPTIONAL"]) + end, + emit([nl,CommentLine,nl]). + + + +mkfuncname(TopType,Cname,WhatKind,Prefix) -> + CurrMod = get(currmod), + case WhatKind of + #'Externaltypereference'{module=CurrMod,type=EType} -> + F = lists:concat(["'",Prefix,EType,"'"]), + {F, "?MODULE", F}; + #'Externaltypereference'{module=Mod,type=EType} -> + {lists:concat(["'",Mod,"':'",Prefix,EType,"'"]),Mod, + lists:concat(["'",Prefix,EType,"'"])}; + {constructed,bif} -> + F = lists:concat(["'",Prefix,asn1ct_gen:list2name([Cname|TopType]),"'"]), + {F, "?MODULE", F} + end. + +empty_lb(ber) -> + "[]"; +empty_lb(ber_bin) -> + "<<>>"; +empty_lb(ber_bin_v2) -> + "<<>>". + +value_match(Index,Value) when atom(Value) -> + value_match(Index,atom_to_list(Value)); +value_match([],Value) -> + Value; +value_match([{VI,_}|VIs],Value) -> + value_match1(Value,VIs,lists:concat(["element(",VI,","]),1). +value_match1(Value,[],Acc,Depth) -> + Acc ++ Value ++ lists:concat(lists:duplicate(Depth,")")); +value_match1(Value,[{VI,_}|VIs],Acc,Depth) -> + value_match1(Value,VIs,Acc++lists:concat(["element(",VI,","]),Depth+1). diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_constructed_per.erl b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_constructed_per.erl new file mode 100644 index 0000000000..a21c38f8a8 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_constructed_per.erl @@ -0,0 +1,1234 @@ +% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: asn1ct_constructed_per.erl,v 1.1 2008/12/17 09:53:29 mikpe Exp $ +%% +-module(asn1ct_constructed_per). + +-export([gen_encode_sequence/3]). +-export([gen_decode_sequence/3]). +-export([gen_encode_set/3]). +-export([gen_decode_set/3]). +-export([gen_encode_sof/4]). +-export([gen_decode_sof/4]). +-export([gen_encode_choice/3]). +-export([gen_decode_choice/3]). + +-include("asn1_records.hrl"). +%-compile(export_all). + +-import(asn1ct_gen, [emit/1,demit/1]). + + +%% ENCODE GENERATOR FOR SEQUENCE TYPE ** ********** + + +gen_encode_set(Erules,TypeName,D) -> + gen_encode_constructed(Erules,TypeName,D). + +gen_encode_sequence(Erules,TypeName,D) -> + gen_encode_constructed(Erules,TypeName,D). + +gen_encode_constructed(Erules,Typename,D) when record(D,type) -> + asn1ct_name:start(), + asn1ct_name:new(term), + asn1ct_name:new(bytes), + {CompList,TableConsInfo} = + case D#type.def of + #'SEQUENCE'{tablecinf=TCI,components=CL} -> + {CL,TCI}; + #'SET'{tablecinf=TCI,components=CL} -> + {CL,TCI} + end, + case Typename of + ['EXTERNAL'] -> + emit({{var,asn1ct_name:next(val)}, + " = asn1rt_check:transform_to_EXTERNAL1990(", + {var,asn1ct_name:curr(val)},"),",nl}), + asn1ct_name:new(val); + _ -> + ok + end, + case {Optionals = optionals(CompList),CompList} of + {[],EmptyCL} when EmptyCL == {[],[]};EmptyCL == [] -> + emit(["%%Variable setting just to eliminate ", + "compiler warning for unused vars!",nl, + "_Val = ",{var,asn1ct_name:curr(val)},",",nl]); + {[],_} -> + emit([{var,asn1ct_name:next(val)}," = ?RT_PER:list_to_record("]), + emit(["'",asn1ct_gen:list2rname(Typename),"'"]), + emit([", ",{var,asn1ct_name:curr(val)},"),",nl]); + _ -> + Fixoptcall = + case Erules of + per -> ",Opt} = ?RT_PER:fixoptionals2("; + _ -> ",Opt} = ?RT_PER:fixoptionals(" + end, + emit({"{",{var,asn1ct_name:next(val)},Fixoptcall, + {asis,Optionals},",",length(Optionals), + ",",{var,asn1ct_name:curr(val)},"),",nl}) + end, + asn1ct_name:new(val), + Ext = extensible(CompList), + case Ext of + {ext,_,NumExt} when NumExt > 0 -> + emit(["Extensions = ?RT_PER:fixextensions(",{asis,Ext}, + ", ",{curr,val},"),",nl]); + _ -> true + end, + EncObj = + case TableConsInfo of + #simpletableattributes{usedclassfield=Used, + uniqueclassfield=Unique} when Used /= Unique -> + false; + %% ObjectSet, name of the object set in constraints + %% + %%{ObjectSet,AttrN,N,UniqueFieldName} -> %% N is index of attribute that determines constraint + #simpletableattributes{objectsetname=ObjectSet, + c_name=AttrN, + c_index=N, + usedclassfield=UniqueFieldName, + uniqueclassfield=UniqueFieldName, + valueindex=ValueIndex + } -> %% N is index of attribute that determines constraint + OSDef = + case ObjectSet of + {Module,OSName} -> + asn1_db:dbget(Module,OSName); + OSName -> + asn1_db:dbget(get(currmod),OSName) + end, + case (OSDef#typedef.typespec)#'ObjectSet'.gen of + true -> + ObjectEncode = + asn1ct_gen:un_hyphen_var(lists:concat(['Obj',AttrN])), + emit([ObjectEncode," = ",nl]), + emit([" 'getenc_",ObjectSet,"'(", + {asis,UniqueFieldName},", ",nl]), + El = make_element(N+1,asn1ct_gen:mk_var(asn1ct_name:curr(val)),AttrN), + Indent = 12 + length(atom_to_list(ObjectSet)), + case ValueIndex of + [] -> + emit([indent(Indent),El,"),",nl]); + _ -> + emit([indent(Indent),"value_match(", + {asis,ValueIndex},",",El,")),",nl]), + notice_value_match() + end, + {AttrN,ObjectEncode}; + _ -> + false + end; + _ -> + case D#type.tablecinf of + [{objfun,_}|_] -> + %% when the simpletableattributes was at an outer + %% level and the objfun has been passed through the + %% function call + {"got objfun through args","ObjFun"}; + _ -> + false + end + end, + emit({"[",nl}), + MaybeComma1 = + case Ext of + {ext,_Pos,NumExt2} when NumExt2 > 0 -> + emit({"?RT_PER:setext(Extensions =/= [])"}), + ", "; + {ext,_Pos,_} -> + emit({"?RT_PER:setext(false)"}), + ", "; + _ -> + "" + end, + MaybeComma2 = + case optionals(CompList) of + [] -> MaybeComma1; + _ -> + emit(MaybeComma1), + emit("Opt"), + {",",nl} + end, + gen_enc_components_call(Typename,CompList,MaybeComma2,EncObj,Ext), + emit({"].",nl}). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% generate decode function for SEQUENCE and SET +%% +gen_decode_set(Erules,Typename,D) -> + gen_decode_constructed(Erules,Typename,D). + +gen_decode_sequence(Erules,Typename,D) -> + gen_decode_constructed(Erules,Typename,D). + +gen_decode_constructed(_Erules,Typename,D) when record(D,type) -> + asn1ct_name:start(), + {CompList,TableConsInfo} = + case D#type.def of + #'SEQUENCE'{tablecinf=TCI,components=CL} -> + {CL,TCI}; + #'SET'{tablecinf=TCI,components=CL} -> + {CL,TCI} + end, + Ext = extensible(CompList), + MaybeComma1 = case Ext of + {ext,_Pos,_NumExt} -> + gen_dec_extension_value("Bytes"), + {",",nl}; + _ -> + "" + end, + Optionals = optionals(CompList), + MaybeComma2 = case Optionals of + [] -> MaybeComma1; + _ -> + Bcurr = asn1ct_name:curr(bytes), + Bnext = asn1ct_name:next(bytes), + emit(MaybeComma1), + GetoptCall = "} = ?RT_PER:getoptionals2(", + emit({"{Opt,",{var,Bnext},GetoptCall, + {var,Bcurr},",",{asis,length(Optionals)},")"}), + asn1ct_name:new(bytes), + ", " + end, + {DecObjInf,UniqueFName,ValueIndex} = + case TableConsInfo of +%% {ObjectSet,AttrN,N,UniqueFieldName} ->%% N is index of attribute that determines constraint + #simpletableattributes{objectsetname=ObjectSet, + c_name=AttrN, + usedclassfield=UniqueFieldName, + uniqueclassfield=UniqueFieldName, + valueindex=ValIndex} -> +%% {AttrN,ObjectSet}; + F = fun(#'ComponentType'{typespec=CT})-> + case {CT#type.constraint,CT#type.tablecinf} of + {[],[{objfun,_}|_R]} -> true; + _ -> false + end + end, + case lists:any(F,CompList) of + true -> % when component relation constraint establish + %% relation from a component to another components + %% subtype component + {{AttrN,{deep,ObjectSet,UniqueFieldName,ValIndex}}, + UniqueFieldName,ValIndex}; + false -> + {{AttrN,ObjectSet},UniqueFieldName,ValIndex} + end; + _ -> + case D#type.tablecinf of + [{objfun,_}|_] -> + {{"got objfun through args","ObjFun"},false,false}; + _ -> + {false,false,false} + end + end, + {AccTerm,AccBytes} = + gen_dec_components_call(Typename,CompList,MaybeComma2,DecObjInf,Ext,length(Optionals)), + case asn1ct_name:all(term) of + [] -> emit(MaybeComma2); % no components at all + _ -> emit({com,nl}) + end, + case {AccTerm,AccBytes} of + {[],[]} -> + ok; + {_,[]} -> + ok; + {[{ObjSet,LeadingAttr,Term}],ListOfOpenTypes} -> + DecObj = asn1ct_gen:un_hyphen_var(lists:concat(['DecObj',LeadingAttr,Term])), + ValueMatch = value_match(ValueIndex,Term), + emit({DecObj," =",nl," 'getdec_",ObjSet,"'(", +% {asis,UniqueFName},", ",Term,"),",nl}), + {asis,UniqueFName},", ",ValueMatch,"),",nl}), + gen_dec_listofopentypes(DecObj,ListOfOpenTypes,false) + end, + %% we don't return named lists any more Cnames = mkcnamelist(CompList), + demit({"Result = "}), %dbg + %% return value as record + case Typename of + ['EXTERNAL'] -> + emit({" OldFormat={'",asn1ct_gen:list2rname(Typename), + "'"}), + mkvlist(asn1ct_name:all(term)), + emit({"},",nl}), + emit({" ASN11994Format =",nl, + " asn1rt_check:transform_to_EXTERNAL1994", + "(OldFormat),",nl}), + emit(" {ASN11994Format,"); + _ -> + emit(["{{'",asn1ct_gen:list2rname(Typename),"'"]), + mkvlist(asn1ct_name:all(term)), + emit("},") + end, + emit({{var,asn1ct_name:curr(bytes)},"}"}), + emit({".",nl,nl}). + +gen_dec_listofopentypes(_,[],_) -> + emit(nl); +gen_dec_listofopentypes(DecObj,[{_Cname,{FirstPFN,PFNList},Term,TmpTerm,Prop}|Rest],_Update) -> + +% asn1ct_name:new(term), + asn1ct_name:new(tmpterm), + asn1ct_name:new(reason), + + emit([Term," = ",nl]), + + N = case Prop of + mandatory -> 0; + 'OPTIONAL' -> + emit_opt_or_mand_check(asn1_NOVALUE,TmpTerm), + 6; + {'DEFAULT',Val} -> + emit_opt_or_mand_check(Val,TmpTerm), + 6 + end, + + emit([indent(N+3),"case (catch ",DecObj,"(", + {asis,FirstPFN},", ",TmpTerm,", telltype,",{asis,PFNList},")) of",nl]), + emit([indent(N+6),"{'EXIT', ",{curr,reason},"} ->",nl]), +%% emit({indent(9),"throw({runtime_error,{","'Type not compatible with table constraint'",",",Term,"}});",nl}), + emit([indent(N+9),"exit({'Type not compatible with table constraint',", + {curr,reason},"});",nl]), + emit([indent(N+6),"{",{curr,tmpterm},",_} ->",nl]), + emit([indent(N+9),{curr,tmpterm},nl]), + + case Prop of + mandatory -> + emit([indent(N+3),"end,",nl]); + _ -> + emit([indent(N+3),"end",nl, + indent(3),"end,",nl]) + end, + gen_dec_listofopentypes(DecObj,Rest,true). + + +emit_opt_or_mand_check(Val,Term) -> + emit([indent(3),"case ",Term," of",nl, + indent(6),{asis,Val}," ->",{asis,Val},";",nl, + indent(6),"_ ->",nl]). + +%% ENCODE GENERATOR FOR THE CHOICE TYPE ******* +%% assume Val = {Alternative,AltType} +%% generate +%%[ +%% ?RT_PER:set_choice(element(1,Val),Altnum,Altlist,ext), +%%case element(1,Val) of +%% alt1 -> +%% encode_alt1(element(2,Val)); +%% alt2 -> +%% encode_alt2(element(2,Val)) +%%end +%%]. + +gen_encode_choice(_Erules,Typename,D) when record(D,type) -> + {'CHOICE',CompList} = D#type.def, + emit({"[",nl}), + Ext = extensible(CompList), + gen_enc_choice(Typename,CompList,Ext), + emit({nl,"].",nl}). + +gen_decode_choice(_Erules,Typename,D) when record(D,type) -> + asn1ct_name:start(), + asn1ct_name:new(bytes), + {'CHOICE',CompList} = D#type.def, + Ext = extensible(CompList), + gen_dec_choice(Typename,CompList,Ext), + emit({".",nl}). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% Encode generator for SEQUENCE OF type + + +gen_encode_sof(_Erules,Typename,SeqOrSetOf,D) when record(D,type) -> + asn1ct_name:start(), +% Val = [Component] +% ?RT_PER:encode_length(length(Val)), +% lists: + {_SeqOrSetOf,ComponentType} = D#type.def, + emit({"[",nl}), + SizeConstraint = + case asn1ct_gen:get_constraint(D#type.constraint, + 'SizeConstraint') of + no -> undefined; + Range -> Range + end, + ObjFun = + case D#type.tablecinf of + [{objfun,_}|_R] -> + ", ObjFun"; + _-> + "" + end, + emit({nl,indent(3),"?RT_PER:encode_length(", + {asis,SizeConstraint}, + ",length(Val)),",nl}), + emit({indent(3),"'enc_",asn1ct_gen:list2name(Typename), + "_components'(Val",ObjFun,", [])"}), + emit({nl,"].",nl}), + NewComponentType = + case ComponentType#type.def of + {'ENUMERATED',_,Component}-> + ComponentType#type{def={'ENUMERATED',Component}}; + _ -> ComponentType + end, + gen_encode_sof_components(Typename,SeqOrSetOf,NewComponentType). + +gen_decode_sof(_Erules,Typename,SeqOrSetOf,D) when record(D,type) -> + asn1ct_name:start(), +% Val = [Component] +% ?RT_PER:encode_length(length(Val)), +% lists: + {_SeqOrSetOf,ComponentType} = D#type.def, + SizeConstraint = + case asn1ct_gen:get_constraint(D#type.constraint, + 'SizeConstraint') of + no -> undefined; + Range -> Range + end, + ObjFun = + case D#type.tablecinf of + [{objfun,_}|_R] -> + ", ObjFun"; + _ -> + "" + end, + emit({nl,"{Num,Bytes1} = ?RT_PER:decode_length(Bytes,",{asis,SizeConstraint},"),",nl}), + emit({"'dec_",asn1ct_gen:list2name(Typename), + "_components'(Num, Bytes1, telltype",ObjFun,", []).",nl}), + NewComponentType = + case ComponentType#type.def of + {'ENUMERATED',_,Component}-> + ComponentType#type{def={'ENUMERATED',Component}}; + _ -> ComponentType + end, + gen_decode_sof_components(Typename,SeqOrSetOf,NewComponentType). + +gen_encode_sof_components(Typename,SeqOrSetOf,Cont) -> + {ObjFun,ObjFun_Var} = + case Cont#type.tablecinf of + [{objfun,_}|_R] -> + {", ObjFun",", _"}; + _ -> + {"",""} + end, + emit({"'enc_",asn1ct_gen:list2name(Typename),"_components'([]", + ObjFun_Var,", Acc) -> lists:reverse(Acc);",nl,nl}), + emit({"'enc_",asn1ct_gen:list2name(Typename),"_components'([H|T]", + ObjFun,", Acc) ->",nl}), + emit({"'enc_",asn1ct_gen:list2name(Typename),"_components'(T"}), + emit({ObjFun,", ["}), + %% the component encoder + Constructed_Suffix = asn1ct_gen:constructed_suffix(SeqOrSetOf, + Cont#type.def), + + Conttype = asn1ct_gen:get_inner(Cont#type.def), + Currmod = get(currmod), + Ctgenmod = list_to_atom(lists:concat(["asn1ct_gen_",per, + asn1ct_gen:rt2ct_suffix()])), + case asn1ct_gen:type(Conttype) of + {primitive,bif} -> + gen_encode_prim_wrapper(Ctgenmod,per,Cont,false,"H"); +% Ctgenmod:gen_encode_prim(per,Cont,false,"H"); + {constructed,bif} -> + NewTypename = [Constructed_Suffix|Typename], + emit({"'enc_",asn1ct_gen:list2name(NewTypename),"'(H", + ObjFun,")",nl,nl}); + #'Externaltypereference'{module=Currmod,type=Ename} -> + emit({"'enc_",Ename,"'(H)",nl,nl}); + #'Externaltypereference'{module=EMod,type=EType} -> + emit({"'",EMod,"':'enc_",EType,"'(H)",nl,nl}); + _ -> + emit({"'enc_",Conttype,"'(H)",nl,nl}) + end, + emit({" | Acc]).",nl}). + +gen_decode_sof_components(Typename,SeqOrSetOf,Cont) -> + {ObjFun,ObjFun_Var} = + case Cont#type.tablecinf of + [{objfun,_}|_R] -> + {", ObjFun",", _"}; + _ -> + {"",""} + end, + emit({"'dec_",asn1ct_gen:list2name(Typename), + "_components'(0, Bytes, _",ObjFun_Var,", Acc) ->",nl, + indent(3),"{lists:reverse(Acc), Bytes};",nl}), + emit({"'dec_",asn1ct_gen:list2name(Typename), + "_components'(Num, Bytes, _",ObjFun,", Acc) ->",nl}), + emit({indent(3),"{Term,Remain} = "}), + Constructed_Suffix = asn1ct_gen:constructed_suffix(SeqOrSetOf, + Cont#type.def), + Conttype = asn1ct_gen:get_inner(Cont#type.def), + Ctgenmod = list_to_atom(lists:concat(["asn1ct_gen_",per, + asn1ct_gen:rt2ct_suffix()])), + case asn1ct_gen:type(Conttype) of + {primitive,bif} -> + Ctgenmod:gen_dec_prim(per,Cont,"Bytes"), + emit({com,nl}); + {constructed,bif} -> + NewTypename = [Constructed_Suffix|Typename], + emit({"'dec_",asn1ct_gen:list2name(NewTypename), + "'(Bytes, telltype",ObjFun,"),",nl}); + #typereference{val=Dname} -> + emit({"'dec_",Dname,"'(Bytes,telltype),",nl}); + #'Externaltypereference'{module=EMod,type=EType} -> + emit({"'",EMod,"':'dec_",EType,"'(Bytes,telltype),",nl}); + _ -> + emit({"'dec_",Conttype,"'(Bytes,telltype),",nl}) + end, + emit({indent(3),"'dec_",asn1ct_gen:list2name(Typename), + "_components'(Num-1, Remain, telltype",ObjFun,", [Term|Acc]).",nl}). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% General and special help functions (not exported) + +mkvlist([H|T]) -> + emit(","), + mkvlist2([H|T]); +mkvlist([]) -> + true. +mkvlist2([H,T1|T]) -> + emit({{var,H},","}), + mkvlist2([T1|T]); +mkvlist2([H|T]) -> + emit({{var,H}}), + mkvlist2(T); +mkvlist2([]) -> + true. + +extensible(CompList) when list(CompList) -> + noext; +extensible({RootList,ExtList}) -> + {ext,length(RootList)+1,length(ExtList)}. + +gen_dec_extension_value(_) -> + emit({"{Ext,",{next,bytes},"} = ?RT_PER:getext(",{curr,bytes},")"}), + asn1ct_name:new(bytes). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Produce a list with positions (in the Value record) where +%% there are optional components, start with 2 because first element +%% is the record name + +optionals({L,_Ext}) -> optionals(L,[],2); +optionals(L) -> optionals(L,[],2). + +optionals([{'EXTENSIONMARK',_,_}|Rest],Acc,Pos) -> + optionals(Rest,Acc,Pos); % optionals in extension are currently not handled +optionals([#'ComponentType'{prop='OPTIONAL'}|Rest],Acc,Pos) -> + optionals(Rest,[Pos|Acc],Pos+1); +optionals([#'ComponentType'{prop={'DEFAULT',_}}|Rest],Acc,Pos) -> + optionals(Rest,[Pos|Acc],Pos+1); +optionals([#'ComponentType'{}|Rest],Acc,Pos) -> + optionals(Rest,Acc,Pos+1); +optionals([],Acc,_) -> + lists:reverse(Acc). + + +gen_enc_components_call(TopType,{CompList,ExtList},MaybeComma,DynamicEnc,Ext) -> + %% The type has extensionmarker + Rpos = gen_enc_components_call1(TopType,CompList,1,MaybeComma,DynamicEnc,noext), + case Ext of + {ext,_,ExtNum} when ExtNum > 0 -> + emit([nl, + ",Extensions",nl]); + _ -> true + end, + %handle extensions + gen_enc_components_call1(TopType,ExtList,Rpos,MaybeComma,DynamicEnc,Ext); +gen_enc_components_call(TopType, CompList, MaybeComma, DynamicEnc, Ext) -> + %% The type has no extensionmarker + gen_enc_components_call1(TopType,CompList,1,MaybeComma,DynamicEnc,Ext). + +gen_enc_components_call1(TopType, + [C=#'ComponentType'{name=Cname,typespec=Type,prop=Prop}|Rest], + Tpos, + MaybeComma, DynamicEnc, Ext) -> + + put(component_type,{true,C}), + %% information necessary in asn1ct_gen_per_rt2ct:gen_encode_prim + + Pos = case Ext of + noext -> Tpos; + {ext,Epos,_Enum} -> Tpos - Epos + 1 + end, + emit(MaybeComma), + case Prop of + 'OPTIONAL' -> + gen_enc_component_optional(TopType,Cname,Type,Tpos,DynamicEnc,Ext); + {'DEFAULT',_DefVal} -> + gen_enc_component_default(TopType,Cname,Type,Tpos,DynamicEnc,Ext); + _ -> + case Ext of + {ext,ExtPos,_} when Tpos >= ExtPos -> + gen_enc_component_optional(TopType,Cname,Type,Tpos,DynamicEnc,Ext); + _ -> + gen_enc_component_mandatory(TopType,Cname,Type,Tpos,DynamicEnc,Ext) + end + end, + + erase(component_type), + + case Rest of + [] -> + Pos+1; + _ -> + emit({com,nl}), + gen_enc_components_call1(TopType,Rest,Tpos+1,"",DynamicEnc,Ext) + end; +gen_enc_components_call1(_TopType,[],Pos,_,_,_) -> + Pos. + +gen_enc_component_default(TopType,Cname,Type,Pos,DynamicEnc,Ext) -> +% Element = io_lib:format("?RT_PER:cindex(~w,Val1,~w)",[Pos+1,Cname]), + Element = make_element(Pos+1,"Val1",Cname), + emit({"case ",Element," of",nl}), +% case Ext of +% {ext,ExtPos,_} when Pos >= ExtPos -> +% emit({"asn1_NOEXTVALUE -> [];",nl}); +% _ -> + emit({"asn1_DEFAULT -> [];",nl}), +% end, + asn1ct_name:new(tmpval), + emit({{curr,tmpval}," ->",nl}), + InnerType = asn1ct_gen:get_inner(Type#type.def), + emit({nl,"%% attribute number ",Pos," with type ", + InnerType,nl}), + NextElement = asn1ct_gen:mk_var(asn1ct_name:curr(tmpval)), + gen_enc_line(TopType,Cname,Type,NextElement, Pos,DynamicEnc,Ext), + emit({nl,"end"}). + +gen_enc_component_optional(TopType,Cname,Type,Pos,DynamicEnc,Ext) -> +% Element = io_lib:format("?RT_PER:cindex(~w,Val1,~w)",[Pos+1,Cname]), + Element = make_element(Pos+1,"Val1",Cname), + emit({"case ",Element," of",nl}), +% case Ext of +% {ext,ExtPos,_} when Pos >= ExtPos -> +% emit({"asn1_NOEXTVALUE -> [];",nl}); +% _ -> + emit({"asn1_NOVALUE -> [];",nl}), +% end, + asn1ct_name:new(tmpval), + emit({{curr,tmpval}," ->",nl}), + InnerType = asn1ct_gen:get_inner(Type#type.def), + emit({nl,"%% attribute number ",Pos," with type ", + InnerType,nl}), + NextElement = asn1ct_gen:mk_var(asn1ct_name:curr(tmpval)), + gen_enc_line(TopType,Cname,Type,NextElement, Pos,DynamicEnc,Ext), + emit({nl,"end"}). + +gen_enc_component_mandatory(TopType,Cname,Type,Pos,DynamicEnc,Ext) -> + InnerType = asn1ct_gen:get_inner(Type#type.def), + emit({nl,"%% attribute number ",Pos," with type ", + InnerType,nl}), + gen_enc_line(TopType,Cname,Type,[],Pos,DynamicEnc,Ext). + +gen_enc_line(TopType, Cname, Type, [], Pos,DynamicEnc,Ext) -> +% Element = io_lib:format("?RT_PER:cindex(~w,~s,~w)",[Pos+1,asn1ct_gen:mk_var(asn1ct_name:curr(val)),Cname]), + Element = make_element(Pos+1,asn1ct_gen:mk_var(asn1ct_name:curr(val)),Cname), + gen_enc_line(TopType,Cname,Type,Element, Pos,DynamicEnc,Ext); +gen_enc_line(TopType,Cname,Type,Element, Pos,DynamicEnc,Ext) -> + Ctgenmod = list_to_atom(lists:concat(["asn1ct_gen_",per, + asn1ct_gen:rt2ct_suffix()])), + Atype = + case Type of + #type{def=#'ObjectClassFieldType'{type=InnerType}} -> + InnerType; + _ -> + asn1ct_gen:get_inner(Type#type.def) + end, +% case asn1ct_gen:get_constraint(Type#type.constraint, +% tableconstraint_info) of +% no -> +% asn1ct_gen:get_inner(Type#type.def); +% _ -> +% Type#type.def +% end, + case Ext of + {ext,Ep1,_} when Pos >= Ep1 -> + emit(["?RT_PER:encode_open_type(dummy,?RT_PER:complete("]); + _ -> true + end, + case Atype of + {typefield,_} -> + case DynamicEnc of + {_LeadingAttrName,Fun} -> +% case asn1ct_gen:get_constraint(Type#type.constraint, +% componentrelation) of + case (Type#type.def)#'ObjectClassFieldType'.fieldname of + {notype,T} -> + throw({error,{notype,type_from_object,T}}); + {Name,RestFieldNames} when atom(Name) -> + emit({"?RT_PER:encode_open_type([],?RT_PER:complete(",nl}), + emit({" ",Fun,"(",{asis,Name},", ", + Element,", ",{asis,RestFieldNames},")))"}); + Other -> + throw({asn1,{'internal error',Other}}) + end + end; + {objectfield,PrimFieldName1,PFNList} -> + case DynamicEnc of + {_LeadingAttrName,Fun} -> + emit({"?RT_PER:encode_open_type([]," + "?RT_PER:complete(",nl}), + emit({" ",Fun,"(",{asis,PrimFieldName1}, + ", ",Element,", ",{asis,PFNList},")))"}) + end; + _ -> + CurrMod = get(currmod), + case asn1ct_gen:type(Atype) of + #'Externaltypereference'{module=Mod,type=EType} when + (CurrMod==Mod) -> + emit({"'enc_",EType,"'(",Element,")"}); + #'Externaltypereference'{module=Mod,type=EType} -> + emit({"'",Mod,"':'enc_", + EType,"'(",Element,")"}); + #typereference{val=Ename} -> + emit({"'enc_",Ename,"'(",Element,")"}); + {notype,_} -> + emit({"'enc_",Atype,"'(",Element,")"}); + {primitive,bif} -> + EncType = + case Atype of + {fixedtypevaluefield,_,Btype} -> + Btype; + _ -> + Type + end, + gen_encode_prim_wrapper(Ctgenmod,per,EncType, + false,Element); +% Ctgenmod:gen_encode_prim(per,EncType, +% false,Element); + 'ASN1_OPEN_TYPE' -> + case Type#type.def of + #'ObjectClassFieldType'{type=OpenType} -> + gen_encode_prim_wrapper(Ctgenmod,per, + #type{def=OpenType}, + false,Element); + _ -> + gen_encode_prim_wrapper(Ctgenmod,per,Type, + false,Element) + end; +% Ctgenmod:gen_encode_prim(per,Type, +% false,Element); + {constructed,bif} -> + NewTypename = [Cname|TopType], + case {Type#type.tablecinf,DynamicEnc} of + {[{objfun,_}|_R],{_,EncFun}} -> +%% emit({"?RT_PER:encode_open_type([],", +%% "?RT_PER:complete(",nl}), + emit({"'enc_", + asn1ct_gen:list2name(NewTypename), + "'(",Element,", ",EncFun,")"}); + _ -> + emit({"'enc_", + asn1ct_gen:list2name(NewTypename), + "'(",Element,")"}) + end + end + end, + case Ext of + {ext,Ep2,_} when Pos >= Ep2 -> + emit(["))"]); + _ -> true + end. + +gen_dec_components_call(TopType,{CompList,ExtList},MaybeComma,DecInfObj,Ext,NumberOfOptionals) -> + %% The type has extensionmarker + {Rpos,AccTerm,AccBytes} = + gen_dec_components_call1(TopType, CompList, 1, 1, MaybeComma,DecInfObj, + noext,[],[],NumberOfOptionals), + emit([",",nl,"{Extensions,",{next,bytes},"} = "]), + emit(["?RT_PER:getextension(Ext,",{curr,bytes},"),",nl]), + asn1ct_name:new(bytes), + {_Epos,AccTermE,AccBytesE} = + gen_dec_components_call1(TopType,ExtList,Rpos, 1, "",DecInfObj,Ext,[],[],NumberOfOptionals), + case ExtList of + [] -> true; + _ -> emit([",",nl]) + end, + emit([{next,bytes},"= ?RT_PER:skipextensions(",{curr,bytes},",", + length(ExtList)+1,",Extensions)",nl]), + asn1ct_name:new(bytes), + {AccTerm++AccTermE,AccBytes++AccBytesE}; + +gen_dec_components_call(TopType,CompList,MaybeComma,DecInfObj,Ext,NumberOfOptionals) -> + %% The type has no extensionmarker + {_,AccTerm,AccBytes} = + gen_dec_components_call1(TopType, CompList, 1, 1,MaybeComma,DecInfObj,Ext,[],[],NumberOfOptionals), + {AccTerm,AccBytes}. + + +gen_dec_components_call1(TopType, + [C=#'ComponentType'{name=Cname,typespec=Type,prop=Prop}|Rest], + Tpos,OptPos,MaybeComma,DecInfObj,Ext,AccTerm,AccBytes,NumberOfOptionals) -> + Pos = case Ext of + noext -> Tpos; + {ext,Epos,_Enum} -> Tpos - Epos + 1 + end, + emit(MaybeComma), +%% asn1ct_name:new(term), + InnerType = + case Type#type.def of + #'ObjectClassFieldType'{type=InType} -> + InType; + Def -> + asn1ct_gen:get_inner(Def) + end, +% case asn1ct_gen:get_constraint(Type#type.constraint, +% tableconstraint_info) of +% no -> +% asn1ct_gen:get_inner(Type#type.def); +% _ -> +% Type#type.def +% end, + case InnerType of + #'Externaltypereference'{type=T} -> + emit({nl,"%% attribute number ",Tpos," with type ", + T,nl}); + IT when tuple(IT) -> + emit({nl,"%% attribute number ",Tpos," with type ", + element(2,IT),nl}); + _ -> + emit({nl,"%% attribute number ",Tpos," with type ", + InnerType,nl}) + end, + + case InnerType of + {typefield,_} -> + asn1ct_name:new(term), + asn1ct_name:new(tmpterm), + emit({"{",{curr,tmpterm},", ",{next,bytes},"} = "}); + {objectfield,_,_} -> + asn1ct_name:new(term), + asn1ct_name:new(tmpterm), + emit({"{",{curr,tmpterm},", ",{next,bytes},"} = "}); + _ -> + asn1ct_name:new(term), + emit({"{",{curr,term},",",{next,bytes},"} = "}) + end, + + NewOptPos = + case {Ext,Prop} of + {noext,mandatory} -> OptPos; % generate nothing + {noext,_} -> + Element = io_lib:format("Opt band (1 bsl ~w)",[NumberOfOptionals - OptPos]), + emit({"case ",Element," of",nl}), + emit({"_Opt",OptPos," when _Opt",OptPos," > 0 ->"}), + OptPos+1; + _ -> + emit(["case Extensions of",nl]), + emit(["_ when size(Extensions) >= ",Pos,",element(",Pos,",Extensions) == 1 ->",nl]) + end, + put(component_type,{true,C}), + {TermVar,BytesVar} = gen_dec_line(TopType,Cname,Type,Tpos,DecInfObj,Ext), + erase(component_type), + case {Ext,Prop} of + {noext,mandatory} -> true; % generate nothing + {noext,_} -> + emit([";",nl,"0 ->"]), + gen_dec_component_no_val(TopType,Cname,Type,Prop,Tpos,Ext); + _ -> + emit([";",nl,"_ ->",nl]), + gen_dec_component_no_val(TopType,Cname,Type,Prop,Tpos,Ext) + end, + case {Ext,Prop} of + {noext,mandatory} -> true; % generate nothing + {noext,_} -> + emit([nl,"end"]); + _ -> + emit([nl,"end"]) + + end, + asn1ct_name:new(bytes), + case Rest of + [] -> + {Pos+1,AccTerm++TermVar,AccBytes++BytesVar}; + _ -> + emit({com,nl}), + gen_dec_components_call1(TopType,Rest,Tpos+1,NewOptPos,"",DecInfObj,Ext, + AccTerm++TermVar,AccBytes++BytesVar,NumberOfOptionals) + end; + +gen_dec_components_call1(_TopType,[],Pos,_OptPos,_,_,_,AccTerm,AccBytes,_NumberOfOptionals) -> + {Pos,AccTerm,AccBytes}. + + +%%gen_dec_component_no_val(TopType,Cname,Type,_,Pos,{ext,Ep,Enum}) when Pos >= Ep -> +%% emit({"{asn1_NOEXTVALUE,",{curr,bytes},"}",nl}); +gen_dec_component_no_val(_,_,_,{'DEFAULT',DefVal},_,_) -> + emit(["{",{asis,DefVal},",",{curr,bytes},"}",nl]); +gen_dec_component_no_val(_,_,_,'OPTIONAL',_,_) -> + emit({"{asn1_NOVALUE,",{curr,bytes},"}",nl}); +gen_dec_component_no_val(_,_,_,mandatory,_,{ext,_,_}) -> + emit({"{asn1_NOVALUE,",{curr,bytes},"}",nl}). + + +gen_dec_line(TopType,Cname,Type,Pos,DecInfObj,Ext) -> + Ctgenmod = list_to_atom(lists:concat(["asn1ct_gen_",per, + asn1ct_gen:rt2ct_suffix()])), + Atype = + case Type of + #type{def=#'ObjectClassFieldType'{type=InnerType}} -> + InnerType; + _ -> + asn1ct_gen:get_inner(Type#type.def) + end, +% case asn1ct_gen:get_constraint(Type#type.constraint, +% tableconstraint_info) of +% no -> +% asn1ct_gen:get_inner(Type#type.def); +% _ -> +% Type#type.def +% end, + BytesVar0 = asn1ct_gen:mk_var(asn1ct_name:curr(bytes)), + BytesVar = case Ext of + {ext,Ep,_} when Pos >= Ep -> + emit(["begin",nl,"{TmpVal",Pos,",Trem",Pos, + "}=?RT_PER:decode_open_type(", + {curr,bytes},",[]),",nl, + "{TmpValx",Pos,",_}="]), + io_lib:format("TmpVal~p",[Pos]); + _ -> BytesVar0 + end, + SaveBytes = + case Atype of + {typefield,_} -> + case DecInfObj of + false -> % This is in a choice with typefield components + {Name,RestFieldNames} = + (Type#type.def)#'ObjectClassFieldType'.fieldname, +% asn1ct_gen:get_constraint(Type#type.constraint, +% tableconstraint_info), + asn1ct_name:new(tmpterm), + asn1ct_name:new(reason), + emit([indent(2),"{",{curr,tmpterm},", ",{next,bytes}, + "} = ?RT_PER:decode_open_type(",{curr,bytes}, + ", []),",nl]), + emit([indent(2),"case (catch ObjFun(", + {asis,Name}, + ",",{curr,tmpterm},",telltype,", + {asis,RestFieldNames},")) of", nl]), + emit([indent(4),"{'EXIT',",{curr,reason},"} ->",nl]), + emit([indent(6),"exit({'Type not ", + "compatible with table constraint', ", + {curr,reason},"});",nl]), + asn1ct_name:new(tmpterm), + emit([indent(4),"{",{curr,tmpterm},", _} ->",nl]), + emit([indent(6),"{",Cname,", {",{curr,tmpterm},", ", + {next,bytes},"}}",nl]), + emit([indent(2),"end"]), + []; + {"got objfun through args","ObjFun"} -> + %% this is when the generated code gots the + %% objfun though arguments on function + %% invocation. + {Name,RestFieldNames} = + (Type#type.def)#'ObjectClassFieldType'.fieldname, + emit(["?RT_PER:decode_open_type(",{curr,bytes}, + ", []),",nl]), + emit([{curr,term}," =",nl, + " case (catch ObjFun(",{asis,Name},",", + {curr,tmpterm},",telltype,", + {asis,RestFieldNames},")) of", nl]), + emit([" {'EXIT',",{curr,reason},"} ->",nl]), + emit([indent(6),"exit({'Type not ", + "compatible with table constraint', ", + {curr,reason},"});",nl]), + asn1ct_name:new(tmpterm), + emit([indent(4),"{",{curr,tmpterm},", _} ->",nl]), + emit([indent(6),{curr,tmpterm},nl]), + emit([indent(2),"end"]), + []; + _ -> + emit({"?RT_PER:decode_open_type(",{curr,bytes}, + ", [])"}), + RefedFieldName = + (Type#type.def)#'ObjectClassFieldType'.fieldname, +% asn1ct_gen:get_constraint(Type#type.constraint, +% tableconstraint_info), + [{Cname,RefedFieldName, + asn1ct_gen:mk_var(asn1ct_name:curr(term)), + asn1ct_gen:mk_var(asn1ct_name:curr(tmpterm)), + get_components_prop()}] + end; + {objectfield,PrimFieldName1,PFNList} -> + emit({"?RT_PER:decode_open_type(",{curr,bytes},", [])"}), + [{Cname,{PrimFieldName1,PFNList}, + asn1ct_gen:mk_var(asn1ct_name:curr(term)), + asn1ct_gen:mk_var(asn1ct_name:curr(tmpterm)), + get_components_prop()}]; + _ -> + CurrMod = get(currmod), + case asn1ct_gen:type(Atype) of + #'Externaltypereference'{module=CurrMod,type=EType} -> + emit({"'dec_",EType,"'(",BytesVar,",telltype)"}); + #'Externaltypereference'{module=Mod,type=EType} -> + emit({"'",Mod,"':'dec_",EType,"'(",BytesVar, + ",telltype)"}); + {primitive,bif} -> + case Atype of + {fixedtypevaluefield,_,Btype} -> + Ctgenmod:gen_dec_prim(per,Btype, + BytesVar); + _ -> + Ctgenmod:gen_dec_prim(per,Type, + BytesVar) + end; + 'ASN1_OPEN_TYPE' -> + case Type#type.def of + #'ObjectClassFieldType'{type=OpenType} -> + Ctgenmod:gen_dec_prim(per,#type{def=OpenType}, + BytesVar); + _ -> + Ctgenmod:gen_dec_prim(per,Type, + BytesVar) + end; + #typereference{val=Dname} -> + emit({"'dec_",Dname,"'(",BytesVar,",telltype)"}); + {notype,_} -> + emit({"'dec_",Atype,"'(",BytesVar,",telltype)"}); + {constructed,bif} -> + NewTypename = [Cname|TopType], + case Type#type.tablecinf of + [{objfun,_}|_R] -> + emit({"'dec_",asn1ct_gen:list2name(NewTypename), + "'(",BytesVar,", telltype, ObjFun)"}); + _ -> + emit({"'dec_",asn1ct_gen:list2name(NewTypename), + "'(",BytesVar,", telltype)"}) + end + end, + case DecInfObj of + {Cname,{_,OSet,UniqueFName,ValIndex}} -> + Term = asn1ct_gen:mk_var(asn1ct_name:curr(term)), + ValueMatch = value_match(ValIndex,Term), + emit({",",nl,"ObjFun = 'getdec_",OSet,"'(", + {asis,UniqueFName},", ",ValueMatch,")"}); + _ -> + ok + end, + [] + end, + case Ext of + {ext,Ep2,_} when Pos >= Ep2 -> + emit([", {TmpValx",Pos,",Trem",Pos,"}",nl,"end"]); + _ -> true + end, + %% Prepare return value + case DecInfObj of + {Cname,ObjSet} -> + {[{ObjSet,Cname,asn1ct_gen:mk_var(asn1ct_name:curr(term))}], + SaveBytes}; + _ -> + {[],SaveBytes} + end. + +gen_enc_choice(TopType,CompList,Ext) -> + gen_enc_choice_tag(CompList, [], Ext), + emit({com,nl}), + emit({"case element(1,Val) of",nl}), + gen_enc_choice2(TopType, CompList, Ext), + emit({nl,"end"}). + +gen_enc_choice_tag({C1,C2},_,_) -> + N1 = get_name_list(C1), + N2 = get_name_list(C2), + emit(["?RT_PER:set_choice(element(1,Val),", + {asis,{N1,N2}},", ",{asis,{length(N1),length(N2)}},")"]); +gen_enc_choice_tag(C,_,_) -> + N = get_name_list(C), + emit(["?RT_PER:set_choice(element(1,Val),", + {asis,N},", ",{asis,length(N)},")"]). + +get_name_list(L) -> + get_name_list(L,[]). + +get_name_list([#'ComponentType'{name=Name}|T], Acc) -> + get_name_list(T,[Name|Acc]); +get_name_list([], Acc) -> + lists:reverse(Acc). + +%gen_enc_choice_tag([H|T],Acc,Ext) when record(H,'ComponentType') -> +% gen_enc_choice_tag(T,[H#'ComponentType'.name|Acc],Ext); +%gen_enc_choice_tag([H|T],Acc,Ext) -> % skip EXTENSIONMARK +% gen_enc_choice_tag(T,Acc,Ext); +%gen_enc_choice_tag([],Acc,Ext) -> +% Length = length(Acc), +% emit({"?RT_PER:set_choice(element(1,Val),",{asis,Length},",", +% {asis,lists:reverse(Acc)},",",{asis,Ext},")"}), +% Length. + +gen_enc_choice2(TopType, {L1,L2}, Ext) -> + gen_enc_choice2(TopType, L1 ++ L2, 0, Ext); +gen_enc_choice2(TopType, L, Ext) -> + gen_enc_choice2(TopType, L, 0, Ext). + +gen_enc_choice2(TopType,[H1,H2|T], Pos, Ext) +when record(H1,'ComponentType'), record(H2,'ComponentType') -> + Cname = H1#'ComponentType'.name, + Type = H1#'ComponentType'.typespec, + EncObj = +% case asn1ct_gen:get_constraint(Type#type.constraint, +% tableconstraint_info) of +% no -> +% false; +% _ -> +% {no_attr,"ObjFun"} +% end, + case asn1ct_gen:get_constraint(Type#type.constraint, + componentrelation) of + no -> false; + _ -> {no_attr,"ObjFun"} + end, + emit({{asis,Cname}," ->",nl}), + gen_enc_line(TopType,Cname,Type,"element(2,Val)", Pos+1,EncObj,Ext), + emit({";",nl}), + gen_enc_choice2(TopType,[H2|T], Pos+1, Ext); +gen_enc_choice2(TopType,[H1|T], Pos, Ext) when record(H1,'ComponentType') -> + Cname = H1#'ComponentType'.name, + Type = H1#'ComponentType'.typespec, + EncObj = +% case asn1ct_gen:get_constraint(Type#type.constraint, +% tableconstraint_info) of +% no -> +% false; +% _ -> +% {no_attr,"ObjFun"} +% end, + case asn1ct_gen:get_constraint(Type#type.constraint, + componentrelation) of + no -> false; + _ -> {no_attr,"ObjFun"} + end, + emit({{asis,H1#'ComponentType'.name}," ->",nl}), + gen_enc_line(TopType,Cname,Type,"element(2,Val)", Pos+1,EncObj,Ext), + gen_enc_choice2(TopType,T, Pos+1, Ext); +gen_enc_choice2(_,[], _, _) -> + true. + +gen_dec_choice(TopType,CompList,{ext,Pos,NumExt}) -> + emit({"{Ext,",{curr,bytes},"} = ?RT_PER:getbit(Bytes),",nl}), + asn1ct_name:new(bytes), + gen_dec_choice1(TopType,CompList,{ext,Pos,NumExt}); +gen_dec_choice(TopType,CompList,noext) -> + gen_dec_choice1(TopType,CompList,noext). + +gen_dec_choice1(TopType,CompList,noext) -> + emit({"{Choice,",{curr,bytes}, + "} = ?RT_PER:getchoice(",{prev,bytes},",", + length(CompList),", 0),",nl}), + emit({"{Cname,{Val,NewBytes}} = case Choice of",nl}), + gen_dec_choice2(TopType,CompList,noext), + emit({nl,"end,",nl}), + emit({nl,"{{Cname,Val},NewBytes}"}); +gen_dec_choice1(TopType,{RootList,ExtList},Ext) -> + NewList = RootList ++ ExtList, + gen_dec_choice1(TopType, NewList, Ext); +gen_dec_choice1(TopType,CompList,{ext,ExtPos,ExtNum}) -> + emit({"{Choice,",{curr,bytes}, + "} = ?RT_PER:getchoice(",{prev,bytes},",", + length(CompList)-ExtNum,",Ext ),",nl}), + emit({"{Cname,{Val,NewBytes}} = case Choice + Ext*",ExtPos-1," of",nl}), + gen_dec_choice2(TopType,CompList,{ext,ExtPos,ExtNum}), + emit([";",nl,"_ -> {asn1_ExtAlt, ?RT_PER:decode_open_type(",{curr,bytes},",[])}"]), + emit({nl,"end,",nl}), + emit({nl,"{{Cname,Val},NewBytes}"}). + + +gen_dec_choice2(TopType,L,Ext) -> + gen_dec_choice2(TopType,L,0,Ext). + +gen_dec_choice2(TopType,[H1,H2|T],Pos,Ext) +when record(H1,'ComponentType'), record(H2,'ComponentType') -> + Cname = H1#'ComponentType'.name, + Type = H1#'ComponentType'.typespec, + case Type#type.def of + #'ObjectClassFieldType'{type={typefield,_}} -> + emit({Pos," -> ",nl}), + wrap_gen_dec_line(H1,TopType,Cname,Type,Pos+1,false,Ext), + emit({";",nl}); + _ -> + emit({Pos," -> {",{asis,Cname},",",nl}), + wrap_gen_dec_line(H1,TopType,Cname,Type,Pos+1,false,Ext), + emit({"};",nl}) + end, + gen_dec_choice2(TopType,[H2|T],Pos+1,Ext); +gen_dec_choice2(TopType,[H1,_H2|T],Pos,Ext) when record(H1,'ComponentType') -> + gen_dec_choice2(TopType,[H1|T],Pos,Ext); % skip extensionmark +gen_dec_choice2(TopType,[H1|T],Pos,Ext) when record(H1,'ComponentType') -> + Cname = H1#'ComponentType'.name, + Type = H1#'ComponentType'.typespec, + case Type#type.def of + #'ObjectClassFieldType'{type={typefield,_}} -> + emit({Pos," -> ",nl}), + wrap_gen_dec_line(H1,TopType,Cname,Type,Pos+1,false,Ext); + _ -> + emit({Pos," -> {",{asis,Cname},",",nl}), + wrap_gen_dec_line(H1,TopType,Cname,Type,Pos+1,false,Ext), + emit("}") + end, + gen_dec_choice2(TopType,[T],Pos+1); +gen_dec_choice2(TopType,[_|T],Pos,Ext) -> + gen_dec_choice2(TopType,T,Pos,Ext);% skip extensionmark +gen_dec_choice2(_,[],Pos,_) -> + Pos. + +indent(N) -> + lists:duplicate(N,32). % 32 = space + +gen_encode_prim_wrapper(CtgenMod,Erule,Cont,DoTag,Value) -> +% put(component_type,true), % add more info in component_type + CtgenMod:gen_encode_prim(Erule,Cont,DoTag,Value). +% erase(component_type). + +make_element(I,Val,Cname) -> + case lists:member(optimize,get(encoding_options)) of + false -> + io_lib:format("?RT_PER:cindex(~w,~s,~w)",[I,Val,Cname]); + _ -> + io_lib:format("element(~w,~s)",[I,Val]) + end. + +wrap_gen_dec_line(C,TopType,Cname,Type,Pos,DIO,Ext) -> + put(component_type,{true,C}), + gen_dec_line(TopType,Cname,Type,Pos,DIO,Ext), + erase(component_type). + +get_components_prop() -> + case get(component_type) of + undefined -> + mandatory; + {true,#'ComponentType'{prop=Prop}} -> Prop + end. + + +value_match(Index,Value) when atom(Value) -> + value_match(Index,atom_to_list(Value)); +value_match([],Value) -> + Value; +value_match([{VI,_}|VIs],Value) -> + value_match1(Value,VIs,lists:concat(["element(",VI,","]),1). +value_match1(Value,[],Acc,Depth) -> + Acc ++ Value ++ lists:concat(lists:duplicate(Depth,")")); +value_match1(Value,[{VI,_}|VIs],Acc,Depth) -> + value_match1(Value,VIs,Acc++lists:concat(["element(",VI,","]),Depth+1). + +notice_value_match() -> + Module = get(currmod), + put(value_match,{true,Module}). diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_gen.erl b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_gen.erl new file mode 100644 index 0000000000..5d2f7a13bd --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_gen.erl @@ -0,0 +1,1664 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: asn1ct_gen.erl,v 1.1 2008/12/17 09:53:29 mikpe Exp $ +%% +-module(asn1ct_gen). + +-include("asn1_records.hrl"). +%%-compile(export_all). +-export([pgen_exports/3, + pgen_hrl/4, + gen_head/3, + demit/1, + emit/1, + fopen/2, + get_inner/1,type/1,def_to_tag/1,prim_bif/1, + type_from_object/1, + get_typefromobject/1,get_fieldcategory/2, + get_classfieldcategory/2, + list2name/1, + list2rname/1, + constructed_suffix/2, + unify_if_string/1, + gen_check_call/7, + get_constraint/2, + insert_once/2, + rt2ct_suffix/1,rt2ct_suffix/0]). +-export([pgen/4,pgen_module/5,mk_var/1, un_hyphen_var/1]). +-export([gen_encode_constructed/4,gen_decode_constructed/4]). + +%% pgen(Erules, Module, TypeOrVal) +%% Generate Erlang module (.erl) and (.hrl) file corresponding to an ASN.1 module +%% .hrl file is only generated if necessary +%% Erules = per | ber | ber_bin | per_bin +%% Module = atom() +%% TypeOrVal = {TypeList,ValueList} +%% TypeList = ValueList = [atom()] + +pgen(OutFile,Erules,Module,TypeOrVal) -> + pgen_module(OutFile,Erules,Module,TypeOrVal,true). + + +pgen_module(OutFile,Erules,Module,TypeOrVal,Indent) -> + put(outfile,OutFile), + HrlGenerated = asn1ct_gen:pgen_hrl(Erules,Module,TypeOrVal,Indent), + asn1ct_name:start(), + ErlFile = lists:concat([OutFile,".erl"]), + Fid = asn1ct_gen:fopen(ErlFile,write), + put(gen_file_out,Fid), + asn1ct_gen:gen_head(Erules,Module,HrlGenerated), + pgen_exports(Erules,Module,TypeOrVal), + pgen_dispatcher(Erules,Module,TypeOrVal), + pgen_info(Erules,Module), + pgen_typeorval(wrap_ber(Erules),Module,TypeOrVal), + pgen_partial_incomplete_decode(Erules), +% gen_vars(asn1_db:mod_to_vars(Module)), +% gen_tag_table(AllTypes), + file:close(Fid), + io:format("--~p--~n",[{generated,ErlFile}]). + + +pgen_typeorval(Erules,Module,{Types,Values,_Ptypes,_Classes,Objects,ObjectSets}) -> + pgen_types(Erules,Module,Types), + pgen_values(Erules,Module,Values), + pgen_objects(Erules,Module,Objects), + pgen_objectsets(Erules,Module,ObjectSets), + case catch lists:member(der,get(encoding_options)) of + true -> + pgen_check_defaultval(Erules,Module); + _ -> ok + end, + pgen_partial_decode(Erules,Module). + +pgen_values(_,_,[]) -> + true; +pgen_values(Erules,Module,[H|T]) -> + Valuedef = asn1_db:dbget(Module,H), + gen_value(Valuedef), + pgen_values(Erules,Module,T). + +pgen_types(_,Module,[]) -> + gen_value_match(Module), + true; +pgen_types(Erules,Module,[H|T]) -> + Rtmod = list_to_atom(lists:concat(["asn1ct_gen_",erule(Erules), + rt2ct_suffix(Erules)])), + asn1ct_name:clear(), + Typedef = asn1_db:dbget(Module,H), + Rtmod:gen_encode(Erules,Typedef), + asn1ct_name:clear(), + Rtmod:gen_decode(Erules,Typedef), + pgen_types(Erules,Module,T). + +pgen_objects(_,_,[]) -> + true; +pgen_objects(Erules,Module,[H|T]) -> + Rtmod = list_to_atom(lists:concat(["asn1ct_gen_",erule(Erules), + rt2ct_suffix(Erules)])), + asn1ct_name:clear(), + Typedef = asn1_db:dbget(Module,H), + Rtmod:gen_obj_code(Erules,Module,Typedef), + pgen_objects(Erules,Module,T). + +pgen_objectsets(_,_,[]) -> + true; +pgen_objectsets(Erules,Module,[H|T]) -> + Rtmod = list_to_atom(lists:concat(["asn1ct_gen_",erule(Erules), + rt2ct_suffix(Erules)])), + asn1ct_name:clear(), + TypeDef = asn1_db:dbget(Module,H), + Rtmod:gen_objectset_code(Erules,TypeDef), + pgen_objectsets(Erules,Module,T). + +pgen_check_defaultval(Erules,Module) -> + CheckObjects = ets:tab2list(check_functions), + case get(asndebug) of + true -> + FileName = lists:concat([Module,'.table']), + {ok,IoDevice} = file:open(FileName,[write]), + Fun = + fun(X)-> + io:format(IoDevice,"~n~n************~n~n~p~n~n*****" + "********~n~n",[X]) + end, + lists:foreach(Fun,CheckObjects), + file:close(IoDevice); + _ -> ok + end, + gen_check_defaultval(Erules,Module,CheckObjects). + +pgen_partial_decode(Erules,Module) -> + pgen_partial_inc_dec(Erules,Module), + pgen_partial_dec(Erules,Module). + +pgen_partial_inc_dec(Erules,Module) -> +% io:format("Start partial incomplete decode gen?~n"), + case asn1ct:get_gen_state_field(inc_type_pattern) of + undefined -> +% io:format("Partial incomplete decode gen not started:�~w~n",[asn1ct:get_gen_state_field(active)]), + ok; +% [] -> +% ok; + ConfList -> + PatternLists=lists:map(fun({_,P}) -> P end,ConfList), + pgen_partial_inc_dec1(Erules,Module,PatternLists), + gen_partial_inc_dec_refed_funcs(Erules) + end. + +%% pgen_partial_inc_dec1 generates a function of the toptype in each +%% of the partial incomplete decoded types. +pgen_partial_inc_dec1(Erules,Module,[P|Ps]) -> + Rtmod = list_to_atom(lists:concat(["asn1ct_gen_",erule(Erules), + rt2ct_suffix(Erules)])), + TopTypeName = asn1ct:partial_inc_dec_toptype(P), + TypeDef=asn1_db:dbget(Module,TopTypeName), + asn1ct_name:clear(), + asn1ct:update_gen_state(namelist,P), + asn1ct:update_gen_state(active,true), + asn1ct:update_gen_state(prefix,"dec-inc-"), + Rtmod:gen_decode(Erules,TypeDef), +%% asn1ct:update_gen_state(namelist,tl(P)), %% + gen_dec_part_inner_constr(Erules,TypeDef,[TopTypeName]), + pgen_partial_inc_dec1(Erules,Module,Ps); +pgen_partial_inc_dec1(_,_,[]) -> + ok. + +gen_partial_inc_dec_refed_funcs(Erule) when Erule == ber_bin_v2 -> + Rtmod = list_to_atom(lists:concat(["asn1ct_gen_",erule(Erule), + rt2ct_suffix(Erule)])), + case asn1ct:next_refed_func() of + [] -> + ok; + {#'Externaltypereference'{module=M,type=Name},Pattern} -> + TypeDef = asn1_db:dbget(M,Name), + asn1ct:update_gen_state(namelist,Pattern), + Rtmod:gen_inc_decode(Erule,TypeDef), + gen_dec_part_inner_constr(Erule,TypeDef,[Name]), + gen_partial_inc_dec_refed_funcs(Erule); + _ -> + gen_partial_inc_dec_refed_funcs(Erule) + end; +gen_partial_inc_dec_refed_funcs(_) -> + ok. + +pgen_partial_dec(_Erules,_Module) -> + ok. %%%% implement later + +%% generate code for all inner types that are called from the top type +%% of the partial incomplete decode +gen_dec_part_inner_constr(Erules,TypeDef,TypeName) -> + Def = TypeDef#typedef.typespec, + InnerType = asn1ct_gen:get_inner(Def#type.def), + case InnerType of + 'SET' -> + #'SET'{components=Components} = Def#type.def, + gen_dec_part_inner_types(Erules,Components,TypeName); + %% Continue generate the inner of each component + 'SEQUENCE' -> + #'SEQUENCE'{components=Components} = Def#type.def, + gen_dec_part_inner_types(Erules,Components,TypeName); + 'CHOICE' -> + {_,Components} = Def#type.def, + gen_dec_part_inner_types(Erules,Components,TypeName); + 'SEQUENCE OF' -> + %% this and next case must be the last component in the + %% partial decode chain here. Not likely that this occur. + {_,Type} = Def#type.def, + NameSuffix = constructed_suffix(InnerType,Type#type.def), + Rtmod = list_to_atom(lists:concat(["asn1ct_gen_",erule(Erules), + rt2ct_suffix(Erules)])), + asn1ct_name:clear(), + Rtmod:gen_decode(Erules,[NameSuffix|TypeName],Type); +%% gen_types(Erules,[NameSuffix|Typename],Type); + 'SET OF' -> + {_,Type} = Def#type.def, + NameSuffix = constructed_suffix(InnerType,Type#type.def), + Rtmod = list_to_atom(lists:concat(["asn1ct_gen_",erule(Erules), + rt2ct_suffix(Erules)])), + asn1ct_name:clear(), + Rtmod:gen_decode(Erules,[NameSuffix|TypeName],Type); + _ -> + ok + end. + +gen_dec_part_inner_types(Erules,[ComponentType|Rest],TypeName) -> + Rtmod = list_to_atom(lists:concat(["asn1ct_gen_",erule(Erules), + rt2ct_suffix(Erules)])), + asn1ct_name:clear(), + Rtmod:gen_decode(Erules,TypeName,ComponentType), + gen_dec_part_inner_types(Erules,Rest,TypeName); +gen_dec_part_inner_types(Erules,{Comps1,Comps2},TypeName) + when list(Comps1),list(Comps2) -> + gen_dec_part_inner_types(Erules,Comps1 ++ Comps2,TypeName); +gen_dec_part_inner_types(_,[],_) -> + ok. + + +pgen_partial_incomplete_decode(Erule) -> + case asn1ct:get_gen_state_field(active) of + true -> + pgen_partial_incomplete_decode1(Erule), + asn1ct:reset_gen_state(); + _ -> + ok + end. +pgen_partial_incomplete_decode1(ber_bin_v2) -> + case asn1ct:read_config_data(partial_incomplete_decode) of + undefined -> + ok; + Data -> + lists:foreach(fun emit_partial_incomplete_decode/1,Data) + end, + GeneratedFs= asn1ct:get_gen_state_field(gen_refed_funcs), +% io:format("GeneratedFs :~n~p~n",[GeneratedFs]), + gen_part_decode_funcs(GeneratedFs,0); +pgen_partial_incomplete_decode1(_) -> ok. + +emit_partial_incomplete_decode({FuncName,TopTypeName,Pattern}) -> + emit([{asis,FuncName},"(Bytes) ->",nl, + " decode_partial_incomplete(",{asis,TopTypeName},",Bytes,",{asis,Pattern},").",nl]); +emit_partial_incomplete_decode(D) -> + throw({error,{asn1,{"bad data in asn1config file",D}}}). + +gen_part_decode_funcs([Data={Name,_,_,Type}|GeneratedFs],N) -> + InnerType = + case Type#type.def of + #'ObjectClassFieldType'{type=OCFTType} -> + OCFTType; + _ -> + get_inner(Type#type.def) + end, + WhatKind = type(InnerType), + TypeName=list2name(Name), + if + N > 0 -> emit([";",nl]); + true -> ok + end, + emit(["decode_inc_disp('",TypeName,"',Data) ->",nl]), + gen_part_decode_funcs(WhatKind,TypeName,Data), + gen_part_decode_funcs(GeneratedFs,N+1); +gen_part_decode_funcs([_H|T],N) -> + gen_part_decode_funcs(T,N); +gen_part_decode_funcs([],N) -> + if + N > 0 -> + .emit([".",nl]); + true -> + ok + end. + +gen_part_decode_funcs(#'Externaltypereference'{module=M,type=T}, + _TypeName,Data) -> + #typedef{typespec=TS} = asn1_db:dbget(M,T), + InnerType = + case TS#type.def of + #'ObjectClassFieldType'{type=OCFTType} -> + OCFTType; + _ -> + get_inner(TS#type.def) + end, + WhatKind = type(InnerType), + gen_part_decode_funcs(WhatKind,[T],Data); +gen_part_decode_funcs({constructed,bif},TypeName, + {_Name,parts,Tag,_Type}) -> + emit([" case Data of",nl, + " L when list(L) ->",nl, + " 'dec_",TypeName,"'(lists:map(fun(X)->element(1,?RT_BER:decode(X)) end,L),",{asis,Tag},");",nl, + " _ ->",nl, + " [Res] = 'dec_",TypeName,"'([Data],",{asis,Tag},"),",nl, + " Res",nl, + " end"]); +gen_part_decode_funcs(WhatKind,_TypeName,{_Name,parts,_Tag,_Type}) -> + throw({error,{asn1,{"only SEQUENCE OF/SET OF may have the partial incomplete directive 'parts'.",WhatKind}}}); +gen_part_decode_funcs({constructed,bif},TypeName, + {_Name,undecoded,Tag,_Type}) -> + emit([" 'dec_",TypeName,"'(Data,",{asis,Tag},")"]); +gen_part_decode_funcs({primitive,bif},_TypeName, + {_Name,undecoded,Tag,Type}) -> + % Argument no 6 is 0, i.e. bit 6 for primitive encoding. + asn1ct_gen_ber_bin_v2:gen_dec_prim(ber_bin_v2,Type,"Data",Tag,[],0,", mandatory, "); +gen_part_decode_funcs(WhatKind,_TypeName,{_,Directive,_,_}) -> + throw({error,{asn1,{"Not implemented yet",WhatKind," partial incomplete directive:",Directive}}}). + +gen_types(Erules,Tname,{RootList,ExtList}) when list(RootList) -> + gen_types(Erules,Tname,RootList), + gen_types(Erules,Tname,ExtList); +gen_types(Erules,Tname,[{'EXTENSIONMARK',_,_}|Rest]) -> + gen_types(Erules,Tname,Rest); +gen_types(Erules,Tname,[ComponentType|Rest]) -> + Rtmod = list_to_atom(lists:concat(["asn1ct_gen_",erule(Erules), + rt2ct_suffix(Erules)])), + asn1ct_name:clear(), + Rtmod:gen_encode(Erules,Tname,ComponentType), + asn1ct_name:clear(), + Rtmod:gen_decode(Erules,Tname,ComponentType), + gen_types(Erules,Tname,Rest); +gen_types(_,_,[]) -> + true; +gen_types(Erules,Tname,Type) when record(Type,type) -> + Rtmod = list_to_atom(lists:concat(["asn1ct_gen_",erule(Erules), + rt2ct_suffix(Erules)])), + asn1ct_name:clear(), + Rtmod:gen_encode(Erules,Tname,Type), + asn1ct_name:clear(), + Rtmod:gen_decode(Erules,Tname,Type). + +gen_value_match(Module) -> + case get(value_match) of + {true,Module} -> + emit(["value_match([{Index,Cname}|Rest],Value) ->",nl, + " Value2 =",nl, + " case element(Index,Value) of",nl, + " {Cname,Val2} -> Val2;",nl, + " X -> X",nl, + " end,",nl, + " value_match(Rest,Value2);",nl, + "value_match([],Value) ->",nl, + " Value.",nl]); + _ -> ok + end, + put(value_match,undefined). + +gen_check_defaultval(Erules,Module,[{Name,Type}|Rest]) -> + gen_check_func(Name,Type), + gen_check_defaultval(Erules,Module,Rest); +gen_check_defaultval(_,_,[]) -> + ok. + +gen_check_func(Name,FType = #type{def=Def}) -> + emit({Name,"(V,asn1_DEFAULT) ->",nl," true;",nl}), + emit({Name,"(V,V) ->",nl," true;",nl}), + emit({Name,"(V,{_,V}) ->",nl," true;",nl}), + case Def of + {'SEQUENCE OF',Type} -> + gen_check_sof(Name,'SEQOF',Type); + {'SET OF',Type} -> + gen_check_sof(Name,'SETOF',Type); + #'SEQUENCE'{components=Components} -> + gen_check_sequence(Name,Components); + #'SET'{components=Components} -> + gen_check_sequence(Name,Components); + {'CHOICE',Components} -> + gen_check_choice(Name,Components); + #'Externaltypereference'{type=T} -> + emit({Name,"(DefaultValue,Value) ->",nl}), + emit({" ",list2name([T,check]),"(DefaultValue,Value).",nl}); + MaybePrim -> + InnerType = get_inner(MaybePrim), + case type(InnerType) of + {primitive,bif} -> + emit({Name,"(DefaultValue,Value) ->",nl," "}), + gen_prim_check_call(InnerType,"DefaultValue","Value", + FType), + emit({".",nl,nl}); + _ -> + throw({asn1_error,{unknown,type,MaybePrim}}) + end + end. + +gen_check_sof(Name,SOF,Type) -> + NewName = list2name([sorted,Name]), + emit({Name,"(V1,V2) ->",nl}), + emit({" ",NewName,"(lists:sort(V1),lists:sort(V2)).",nl,nl}), + emit({NewName,"([],[]) ->",nl," true;",nl}), + emit({NewName,"([DV|DVs],[V|Vs]) ->",nl," "}), + InnerType = get_inner(Type#type.def), + case type(InnerType) of + {primitive,bif} -> + gen_prim_check_call(InnerType,"DV","V",Type), + emit({",",nl}); + {constructed,bif} -> + emit({list2name([SOF,Name]),"(DV, V),",nl}); + #'Externaltypereference'{type=T} -> + emit({list2name([T,check]),"(DV,V),",nl}) + end, + emit({" ",NewName,"(DVs,Vs).",nl,nl}). + +gen_check_sequence(Name,Components) -> + emit({Name,"(DefaultValue,Value) ->",nl}), + gen_check_sequence(Name,Components,1). +gen_check_sequence(Name,[#'ComponentType'{name=N,typespec=Type}|Cs],Num) -> + InnerType = get_inner(Type#type.def), +% NthDefV = lists:concat(["lists:nth(",Num,",DefaultValue)"]), + NthDefV = ["element(",Num+1,",DefaultValue)"], +% NthV = lists:concat(["lists:nth(",Num,",Value)"]), + NthV = ["element(",Num+1,",Value)"], + gen_check_func_call(Name,Type,InnerType,NthDefV,NthV,N), + case Cs of + [] -> + emit({".",nl,nl}); + _ -> + emit({",",nl}), + gen_check_sequence(Name,Cs,Num+1) + end; +gen_check_sequence(_,[],_) -> + ok. + +gen_check_choice(Name,CList=[#'ComponentType'{}|_Cs]) -> + emit({Name,"({Id,DefaultValue},{Id,Value}) ->",nl}), + emit({" case Id of",nl}), + gen_check_choice_components(Name,CList,1). + +gen_check_choice_components(_,[],_)-> + ok; +gen_check_choice_components(Name,[#'ComponentType'{name=N,typespec=Type}| + Cs],Num) -> + Ind6 = " ", + InnerType = get_inner(Type#type.def), +% DefVal = ["element(2,lists:nth(",Num,",DefaultValue))"], + emit({Ind6,N," ->",nl,Ind6}), + gen_check_func_call(Name,Type,InnerType,{var,"defaultValue"}, + {var,"value"},N), + case Cs of + [] -> + emit({nl," end.",nl,nl}); + _ -> + emit({";",nl}), + gen_check_choice_components(Name,Cs,Num+1) + end. + +gen_check_func_call(Name,Type,InnerType,DefVal,Val,N) -> + case type(InnerType) of + {primitive,bif} -> + emit(" "), + gen_prim_check_call(InnerType,DefVal,Val,Type); + #'Externaltypereference'{type=T} -> + emit({" ",list2name([T,check]),"(",DefVal,",",Val,")"}); + _ -> + emit({" ",list2name([N,Name]),"(",DefVal,",",Val,")"}) + end. + + +%% VARIOUS GENERATOR STUFF +%% ************************************************* +%%************************************************** + +mk_var(X) when atom(X) -> + list_to_atom(mk_var(atom_to_list(X))); + +mk_var([H|T]) -> + [H-32|T]. + +%% Since hyphens are allowed in ASN.1 names, it may occur in a +%% variable to. Turn a hyphen into a under-score sign. +un_hyphen_var(X) when atom(X) -> + list_to_atom(un_hyphen_var(atom_to_list(X))); +un_hyphen_var([45|T]) -> + [95|un_hyphen_var(T)]; +un_hyphen_var([H|T]) -> + [H|un_hyphen_var(T)]; +un_hyphen_var([]) -> + []. + +%% Generate value functions *************** +%% **************************************** +%% Generates a function 'V'/0 for each Value V defined in the ASN.1 module +%% the function returns the value in an Erlang representation which can be +%% used as input to the runtime encode functions + +gen_value(Value) when record(Value,valuedef) -> +%% io:format(" ~w ",[Value#valuedef.name]), + emit({"'",Value#valuedef.name,"'() ->",nl}), + V = Value#valuedef.value, + emit([{asis,V},".",nl,nl]). + +gen_encode_constructed(Erules,Typename,InnerType,D) when record(D,type) -> + + Rtmod = list_to_atom(lists:concat(["asn1ct_constructed_",erule(Erules)])), + case InnerType of + 'SET' -> + Rtmod:gen_encode_set(Erules,Typename,D), + #'SET'{components=Components} = D#type.def, + gen_types(Erules,Typename,Components); + 'SEQUENCE' -> + Rtmod:gen_encode_sequence(Erules,Typename,D), + #'SEQUENCE'{components=Components} = D#type.def, + gen_types(Erules,Typename,Components); + 'CHOICE' -> + Rtmod:gen_encode_choice(Erules,Typename,D), + {_,Components} = D#type.def, + gen_types(Erules,Typename,Components); + 'SEQUENCE OF' -> + Rtmod:gen_encode_sof(Erules,Typename,InnerType,D), + {_,Type} = D#type.def, + NameSuffix = asn1ct_gen:constructed_suffix(InnerType,Type#type.def), + gen_types(Erules,[NameSuffix|Typename],Type); + 'SET OF' -> + Rtmod:gen_encode_sof(Erules,Typename,InnerType,D), + {_,Type} = D#type.def, + NameSuffix = asn1ct_gen:constructed_suffix(InnerType,Type#type.def), + gen_types(Erules,[NameSuffix|Typename],Type); + _ -> + exit({nyi,InnerType}) + end; +gen_encode_constructed(Erules,Typename,InnerType,D) + when record(D,typedef) -> + gen_encode_constructed(Erules,Typename,InnerType,D#typedef.typespec). + +gen_decode_constructed(Erules,Typename,InnerType,D) when record(D,type) -> + Rtmod = list_to_atom(lists:concat(["asn1ct_constructed_",erule(Erules)])), + asn1ct:step_in_constructed(), %% updates namelist for incomplete + %% partial decode + case InnerType of + 'SET' -> + Rtmod:gen_decode_set(Erules,Typename,D); + 'SEQUENCE' -> + Rtmod:gen_decode_sequence(Erules,Typename,D); + 'CHOICE' -> + Rtmod:gen_decode_choice(Erules,Typename,D); + 'SEQUENCE OF' -> + Rtmod:gen_decode_sof(Erules,Typename,InnerType,D); + 'SET OF' -> + Rtmod:gen_decode_sof(Erules,Typename,InnerType,D); + _ -> + exit({nyi,InnerType}) + end; + + +gen_decode_constructed(Erules,Typename,InnerType,D) when record(D,typedef) -> + gen_decode_constructed(Erules,Typename,InnerType,D#typedef.typespec). + + +pgen_exports(Erules,_Module,{Types,Values,_,_,Objects,ObjectSets}) -> + emit({"-export([encoding_rule/0]).",nl}), + case Types of + [] -> ok; + _ -> + emit({"-export([",nl}), + case Erules of + ber -> + gen_exports1(Types,"enc_",2); + ber_bin -> + gen_exports1(Types,"enc_",2); + ber_bin_v2 -> + gen_exports1(Types,"enc_",2); + _ -> + gen_exports1(Types,"enc_",1) + end, + emit({"-export([",nl}), + gen_exports1(Types,"dec_",2), + case Erules of + ber -> + emit({"-export([",nl}), + gen_exports1(Types,"dec_",3); + ber_bin -> + emit({"-export([",nl}), + gen_exports1(Types,"dec_",3); + ber_bin_v2 -> + emit({"-export([",nl}), + gen_exports1(Types,"dec_",2); + _ -> ok + end + end, + case Values of + [] -> ok; + _ -> + emit({"-export([",nl}), + gen_exports1(Values,"",0) + end, + case Objects of + [] -> ok; + _ -> + case erule(Erules) of + per -> + emit({"-export([",nl}), + gen_exports1(Objects,"enc_",3), + emit({"-export([",nl}), + gen_exports1(Objects,"dec_",4); + ber_bin_v2 -> + emit({"-export([",nl}), + gen_exports1(Objects,"enc_",3), + emit({"-export([",nl}), + gen_exports1(Objects,"dec_",3); + _ -> + emit({"-export([",nl}), + gen_exports1(Objects,"enc_",4), + emit({"-export([",nl}), + gen_exports1(Objects,"dec_",4) + end + end, + case ObjectSets of + [] -> ok; + _ -> + emit({"-export([",nl}), + gen_exports1(ObjectSets,"getenc_",2), + emit({"-export([",nl}), + gen_exports1(ObjectSets,"getdec_",2) + end, + emit({"-export([info/0]).",nl}), + gen_partial_inc_decode_exports(), + emit({nl,nl}). + +gen_exports1([F1,F2|T],Prefix,Arity) -> + emit({"'",Prefix,F1,"'/",Arity,com,nl}), + gen_exports1([F2|T],Prefix,Arity); +gen_exports1([Flast|_T],Prefix,Arity) -> + emit({"'",Prefix,Flast,"'/",Arity,nl,"]).",nl,nl}). + +gen_partial_inc_decode_exports() -> + case {asn1ct:read_config_data(partial_incomplete_decode), + asn1ct:get_gen_state_field(inc_type_pattern)} of + {undefined,_} -> + ok; + {_,undefined} -> + ok; + {Data,_} -> + gen_partial_inc_decode_exports(Data), + emit("-export([decode_part/2]).") + end. +gen_partial_inc_decode_exports([]) -> + ok; +gen_partial_inc_decode_exports([{Name,_,_}|Rest]) -> + emit(["-export([",Name,"/1"]), + gen_partial_inc_decode_exports1(Rest); +gen_partial_inc_decode_exports([_|Rest]) -> + gen_partial_inc_decode_exports(Rest). + +gen_partial_inc_decode_exports1([]) -> + emit(["]).",nl]); +gen_partial_inc_decode_exports1([{Name,_,_}|Rest]) -> + emit([", ",Name,"/1"]), + gen_partial_inc_decode_exports1(Rest); +gen_partial_inc_decode_exports1([_|Rest]) -> + gen_partial_inc_decode_exports1(Rest). + +pgen_dispatcher(Erules,_Module,{[],_Values,_,_,_Objects,_ObjectSets}) -> + emit(["encoding_rule() ->",nl]), + emit([{asis,Erules},".",nl,nl]); +pgen_dispatcher(Erules,_Module,{Types,_Values,_,_,_Objects,_ObjectSets}) -> + emit(["-export([encode/2,decode/2,encode_disp/2,decode_disp/2]).",nl,nl]), + emit(["encoding_rule() ->",nl]), + emit([" ",{asis,Erules},".",nl,nl]), + Call = case Erules of + per -> "?RT_PER:complete(encode_disp(Type,Data))"; + per_bin -> "?RT_PER:complete(encode_disp(Type,Data))"; + ber -> "encode_disp(Type,Data)"; + ber_bin -> "encode_disp(Type,Data)"; + ber_bin_v2 -> "encode_disp(Type,Data)" + end, + EncWrap = case Erules of + ber -> "wrap_encode(Bytes)"; + _ -> "Bytes" + end, + emit(["encode(Type,Data) ->",nl, + "case catch ",Call," of",nl, + " {'EXIT',{error,Reason}} ->",nl, + " {error,Reason};",nl, + " {'EXIT',Reason} ->",nl, + " {error,{asn1,Reason}};",nl, + " {Bytes,_Len} ->",nl, + " {ok,",EncWrap,"};",nl, + " Bytes ->",nl, + " {ok,",EncWrap,"}",nl, + "end.",nl,nl]), + + case Erules of + ber_bin_v2 -> + emit(["decode(Type,Data0) ->",nl]), + emit(["{Data,_RestBin} = ?RT_BER:decode(Data0",driver_parameter(),"),",nl]); + _ -> + emit(["decode(Type,Data) ->",nl]) + end, + DecWrap = case Erules of + ber -> "wrap_decode(Data)"; + _ -> "Data" + end, + + emit(["case catch decode_disp(Type,",DecWrap,") of",nl, + " {'EXIT',{error,Reason}} ->",nl, + " {error,Reason};",nl, + " {'EXIT',Reason} ->",nl, + " {error,{asn1,Reason}};",nl]), + case Erules of + ber_bin_v2 -> + emit([" Result ->",nl, + " {ok,Result}",nl]); + _ -> + emit([" {X,_Rest} ->",nl, + " {ok,X};",nl, + " {X,_Rest,_Len} ->",nl, + " {ok,X}",nl]) + end, + emit(["end.",nl,nl]), + + gen_decode_partial_incomplete(Erules), + + case Types of + [] -> ok; + _ -> + case Erules of + ber -> + gen_dispatcher(Types,"encode_disp","enc_",",[]"), + gen_dispatcher(Types,"decode_disp","dec_",",mandatory"); + ber_bin -> + gen_dispatcher(Types,"encode_disp","enc_",",[]"), + gen_dispatcher(Types,"decode_disp","dec_",",mandatory"); + ber_bin_v2 -> + gen_dispatcher(Types,"encode_disp","enc_",""), + gen_dispatcher(Types,"decode_disp","dec_",""), + gen_partial_inc_dispatcher(); + _PerOrPer_bin -> + gen_dispatcher(Types,"encode_disp","enc_",""), + gen_dispatcher(Types,"decode_disp","dec_",",mandatory") + end, + emit([nl]) + end, + case Erules of + ber -> + gen_wrapper(); + _ -> ok + end, + emit({nl,nl}). + + +gen_decode_partial_incomplete(Erule) when Erule == ber;Erule==ber_bin; + Erule==ber_bin_v2 -> + case {asn1ct:read_config_data(partial_incomplete_decode), + asn1ct:get_gen_state_field(inc_type_pattern)} of + {undefined,_} -> + ok; + {_,undefined} -> + ok; + _ -> + case Erule of + ber_bin_v2 -> + EmitCaseClauses = + fun() -> + emit([" {'EXIT',{error,Reason}} ->",nl, + " {error,Reason};",nl, + " {'EXIT',Reason} ->",nl, + " {error,{asn1,Reason}};",nl, + " Result ->",nl, + " {ok,Result}",nl, + " end.",nl,nl]) + end, + emit(["decode_partial_incomplete(Type,Data0,", + "Pattern) ->",nl]), + emit([" {Data,_RestBin} =",nl, + " ?RT_BER:decode_primitive_", + "incomplete(Pattern,Data0),",nl, + " case catch decode_partial_inc_disp(Type,", + "Data) of",nl]), + EmitCaseClauses(), + emit(["decode_part(Type,Data0) ->",nl, + " {Data,_RestBin} = ?RT_BER:decode(Data0),",nl, + " case catch decode_inc_disp(Type,Data) of",nl]), + EmitCaseClauses(); + _ -> ok % add later + end + end; +gen_decode_partial_incomplete(_Erule) -> + ok. + +gen_partial_inc_dispatcher() -> + case {asn1ct:read_config_data(partial_incomplete_decode), + asn1ct:get_gen_state_field(inc_type_pattern)} of + {undefined,_} -> + ok; + {_,undefined} -> + ok; + {Data,_} -> + gen_partial_inc_dispatcher(Data) + end. +gen_partial_inc_dispatcher([{_FuncName,TopType,_Pattern}|Rest]) -> + emit(["decode_partial_inc_disp(",{asis,TopType},",Data) ->",nl, + " ",{asis,list_to_atom(lists:concat([dec,"-inc-",TopType]))}, + "(Data);",nl]), + gen_partial_inc_dispatcher(Rest); +gen_partial_inc_dispatcher([]) -> + emit(["decode_partial_inc_disp(Type,_Data) ->",nl, + " exit({error,{asn1,{undefined_type,Type}}}).",nl]). + +driver_parameter() -> + Options = get(encoding_options), + case lists:member(driver,Options) of + true -> + ",driver"; + _ -> "" + end. + +gen_wrapper() -> + emit(["wrap_encode(Bytes) when list(Bytes) ->",nl, + " binary_to_list(list_to_binary(Bytes));",nl, + "wrap_encode(Bytes) when binary(Bytes) ->",nl, + " binary_to_list(Bytes);",nl, + "wrap_encode(Bytes) -> Bytes.",nl,nl]), + emit(["wrap_decode(Bytes) when list(Bytes) ->",nl, + " list_to_binary(Bytes);",nl, + "wrap_decode(Bytes) -> Bytes.",nl]). + +gen_dispatcher([F1,F2|T],FuncName,Prefix,ExtraArg) -> + emit([FuncName,"('",F1,"',Data) -> '",Prefix,F1,"'(Data",ExtraArg,")",";",nl]), + gen_dispatcher([F2|T],FuncName,Prefix,ExtraArg); +gen_dispatcher([Flast|_T],FuncName,Prefix,ExtraArg) -> + emit([FuncName,"('",Flast,"',Data) -> '",Prefix,Flast,"'(Data",ExtraArg,")",";",nl]), + emit([FuncName,"(","Type",",_Data) -> exit({error,{asn1,{undefined_type,Type}}}).",nl,nl,nl]). + +pgen_info(_Erules,Module) -> + Options = get(encoding_options), + emit({"info() ->",nl, + " [{vsn,'",asn1ct:vsn(),"'},", + " {module,'",Module,"'},", + " {options,",io_lib:format("~p",[Options]),"}].",nl}). + +open_hrl(OutFile,Module) -> + File = lists:concat([OutFile,".hrl"]), + Fid = fopen(File,write), + put(gen_file_out,Fid), + gen_hrlhead(Module). + +%% EMIT functions ************************ +%% *************************************** + + % debug generation +demit(Term) -> + case get(asndebug) of + true -> emit(Term); + _ ->true + end. + + % always generation + +emit({external,_M,T}) -> + emit(T); + +emit({prev,Variable}) when atom(Variable) -> + emit({var,asn1ct_name:prev(Variable)}); + +emit({next,Variable}) when atom(Variable) -> + emit({var,asn1ct_name:next(Variable)}); + +emit({curr,Variable}) when atom(Variable) -> + emit({var,asn1ct_name:curr(Variable)}); + +emit({var,Variable}) when atom(Variable) -> + [Head|V] = atom_to_list(Variable), + emit([Head-32|V]); + +emit({var,Variable}) -> + [Head|V] = Variable, + emit([Head-32|V]); + +emit({asis,What}) -> + format(get(gen_file_out),"~w",[What]); + +emit(nl) -> + nl(get(gen_file_out)); + +emit(com) -> + emit(","); + +emit(tab) -> + put_chars(get(gen_file_out)," "); + +emit(What) when integer(What) -> + put_chars(get(gen_file_out),integer_to_list(What)); + +emit(What) when list(What), integer(hd(What)) -> + put_chars(get(gen_file_out),What); + +emit(What) when atom(What) -> + put_chars(get(gen_file_out),atom_to_list(What)); + +emit(What) when tuple(What) -> + emit_parts(tuple_to_list(What)); + +emit(What) when list(What) -> + emit_parts(What); + +emit(X) -> + exit({'cant emit ',X}). + +emit_parts([]) -> true; +emit_parts([H|T]) -> + emit(H), + emit_parts(T). + +format(undefined,X,Y) -> + io:format(X,Y); +format(X,Y,Z) -> + io:format(X,Y,Z). + +nl(undefined) -> io:nl(); +nl(X) -> io:nl(X). + +put_chars(undefined,X) -> + io:put_chars(X); +put_chars(Y,X) -> + io:put_chars(Y,X). + +fopen(F, Mode) -> + case file:open(F, [Mode]) of + {ok, Fd} -> + Fd; + {error, Reason} -> + io:format("** Can't open file ~p ~n", [F]), + exit({error,Reason}) + end. + +pgen_hrl(Erules,Module,TypeOrVal,_Indent) -> + put(currmod,Module), + {Types,Values,Ptypes,_,_,_} = TypeOrVal, + Ret = + case pgen_hrltypes(Erules,Module,Ptypes++Types,0) of + 0 -> + case Values of + [] -> + 0; + _ -> + open_hrl(get(outfile),get(currmod)), + pgen_macros(Erules,Module,Values), + 1 + end; + X -> + pgen_macros(Erules,Module,Values), + X + end, + case Ret of + 0 -> + 0; + Y -> + Fid = get(gen_file_out), + file:close(Fid), + io:format("--~p--~n", + [{generated,lists:concat([get(outfile),".hrl"])}]), + Y + end. + +pgen_macros(_,_,[]) -> + true; +pgen_macros(Erules,Module,[H|T]) -> + Valuedef = asn1_db:dbget(Module,H), + gen_macro(Valuedef), + pgen_macros(Erules,Module,T). + +pgen_hrltypes(_,_,[],NumRecords) -> + NumRecords; +pgen_hrltypes(Erules,Module,[H|T],NumRecords) -> +% io:format("records = ~p~n",NumRecords), + Typedef = asn1_db:dbget(Module,H), + AddNumRecords = gen_record(Typedef,NumRecords), + pgen_hrltypes(Erules,Module,T,NumRecords+AddNumRecords). + + +%% Generates a macro for value Value defined in the ASN.1 module +gen_macro(Value) when record(Value,valuedef) -> + emit({"-define('",Value#valuedef.name,"', ", + {asis,Value#valuedef.value},").",nl}). + +%% Generate record functions ************** +%% Generates an Erlang record for each named and unnamed SEQUENCE and SET in the ASN.1 +%% module. If no SEQUENCE or SET is found there is no .hrl file generated + + +gen_record(Tdef,NumRecords) when record(Tdef,typedef) -> + Name = [Tdef#typedef.name], + Type = Tdef#typedef.typespec, + gen_record(type,Name,Type,NumRecords); + +gen_record(Tdef,NumRecords) when record(Tdef,ptypedef) -> + Name = [Tdef#ptypedef.name], + Type = Tdef#ptypedef.typespec, + gen_record(ptype,Name,Type,NumRecords). + +gen_record(TorPtype,Name,[#'ComponentType'{name=Cname,typespec=Type}|T],Num) -> + Num2 = gen_record(TorPtype,[Cname|Name],Type,Num), + gen_record(TorPtype,Name,T,Num2); +gen_record(TorPtype,Name,{Clist1,Clist2},Num) when list(Clist1), list(Clist2) -> + gen_record(TorPtype,Name,Clist1++Clist2,Num); +gen_record(TorPtype,Name,[_|T],Num) -> % skip EXTENSIONMARK + gen_record(TorPtype,Name,T,Num); +gen_record(_TorPtype,_Name,[],Num) -> + Num; + +gen_record(TorPtype,Name,Type,Num) when record(Type,type) -> + Def = Type#type.def, + Rec = case Def of + Seq when record(Seq,'SEQUENCE') -> + case Seq#'SEQUENCE'.pname of + false -> + {record,Seq#'SEQUENCE'.components}; + _Pname when TorPtype == type -> + false; + _ -> + {record,Seq#'SEQUENCE'.components} + end; + Set when record(Set,'SET') -> + case Set#'SET'.pname of + false -> + {record,Set#'SET'.components}; + _Pname when TorPtype == type -> + false; + _ -> + {record,Set#'SET'.components} + end; +% {'SET',{_,_CompList}} -> +% {record,_CompList}; + {'CHOICE',_CompList} -> {inner,Def}; + {'SEQUENCE OF',_CompList} -> {['SEQOF'|Name],Def}; + {'SET OF',_CompList} -> {['SETOF'|Name],Def}; + _ -> false + end, + case Rec of + false -> Num; + {record,CompList} -> + case Num of + 0 -> open_hrl(get(outfile),get(currmod)); + _ -> true + end, + emit({"-record('",list2name(Name),"',{",nl}), + RootList = case CompList of + _ when list(CompList) -> + CompList; + {_Rl,_} -> _Rl + end, + gen_record2(Name,'SEQUENCE',RootList), + NewCompList = + case CompList of + {CompList1,[]} -> + emit({"}). % with extension mark",nl,nl}), + CompList1; + {Tr,ExtensionList2} -> + case Tr of + [] -> true; + _ -> emit({",",nl}) + end, + emit({"%% with extensions",nl}), + gen_record2(Name, 'SEQUENCE', ExtensionList2, + "", ext), + emit({"}).",nl,nl}), + Tr ++ ExtensionList2; + _ -> + emit({"}).",nl,nl}), + CompList + end, + gen_record(TorPtype,Name,NewCompList,Num+1); + {inner,{'CHOICE', CompList}} -> + gen_record(TorPtype,Name,CompList,Num); + {NewName,{_, CompList}} -> + gen_record(TorPtype,NewName,CompList,Num) + end; +gen_record(_,_,_,NumRecords) -> % skip CLASS etc for now. + NumRecords. + +gen_head(Erules,Mod,Hrl) -> + {Rtmac,Rtmod} = case Erules of + per -> + emit({"%% Generated by the Erlang ASN.1 PER-" + "compiler version:",asn1ct:vsn(),nl}), + {"RT_PER",?RT_PER}; + ber -> + emit({"%% Generated by the Erlang ASN.1 BER-" + "compiler version:",asn1ct:vsn(),nl}), + {"RT_BER",?RT_BER_BIN}; + per_bin -> + emit({"%% Generated by the Erlang ASN.1 BER-" + "compiler version, utilizing bit-syntax:", + asn1ct:vsn(),nl}), + %% temporary code to enable rt2ct optimization + Options = get(encoding_options), + case lists:member(optimize,Options) of + true -> {"RT_PER","asn1rt_per_bin_rt2ct"}; + _ -> + {"RT_PER",?RT_PER_BIN} + end; + ber_bin -> + emit({"%% Generated by the Erlang ASN.1 BER-" + "compiler version, utilizing bit-syntax:", + asn1ct:vsn(),nl}), + {"RT_BER",?RT_BER_BIN}; + ber_bin_v2 -> + emit({"%% Generated by the Erlang ASN.1 BER_V2-" + "compiler version, utilizing bit-syntax:", + asn1ct:vsn(),nl}), + {"RT_BER","asn1rt_ber_bin_v2"} + end, + emit({"%% Purpose: encoder and decoder to the types in mod ",Mod,nl,nl}), + emit({"-module('",Mod,"').",nl}), + put(currmod,Mod), + %emit({"-compile(export_all).",nl}), + case Hrl of + 0 -> true; + _ -> + emit({"-include(\"",Mod,".hrl\").",nl}) + end, + emit(["-define('",Rtmac,"',",Rtmod,").",nl]). + + +gen_hrlhead(Mod) -> + emit({"%% Generated by the Erlang ASN.1 compiler version:",asn1ct:vsn(),nl}), + emit({"%% Purpose: Erlang record definitions for each named and unnamed",nl}), + emit({"%% SEQUENCE and SET, and macro definitions for each value",nl}), + emit({"%% definition,in module ",Mod,nl,nl}), + emit({nl,nl}). + +gen_record2(Name,SeqOrSet,Comps) -> + gen_record2(Name,SeqOrSet,Comps,"",noext). + +gen_record2(_Name,_SeqOrSet,[],_Com,_Extension) -> + true; +gen_record2(Name,SeqOrSet,[{'EXTENSIONMARK',_,_}|T],Com,Extension) -> + gen_record2(Name,SeqOrSet,T,Com,Extension); +gen_record2(_Name,_SeqOrSet,[H],Com,Extension) -> + #'ComponentType'{name=Cname} = H, + emit(Com), + emit({asis,Cname}), + gen_record_default(H, Extension); +gen_record2(Name,SeqOrSet,[H|T],Com, Extension) -> + #'ComponentType'{name=Cname} = H, + emit(Com), + emit({asis,Cname}), + gen_record_default(H, Extension), +% emit(", "), + gen_record2(Name,SeqOrSet,T,", ", Extension). + +%gen_record_default(C, ext) -> +% emit(" = asn1_NOEXTVALUE"); +gen_record_default(#'ComponentType'{prop='OPTIONAL'}, _)-> + emit(" = asn1_NOVALUE"); +gen_record_default(#'ComponentType'{prop={'DEFAULT',_}}, _)-> + emit(" = asn1_DEFAULT"); +gen_record_default(_, _) -> + true. + +gen_check_call(TopType,Cname,Type,InnerType,WhatKind,DefaultValue,Element) -> + case WhatKind of + {primitive,bif} -> + gen_prim_check_call(InnerType,DefaultValue,Element,Type); + #'Externaltypereference'{module=M,type=T} -> + %% generate function call + Name = list2name([T,check]), + emit({"'",Name,"'(",DefaultValue,", ",Element,")"}), + %% insert in ets table and do look ahead check + Typedef = asn1_db:dbget(M,T), + RefType = Typedef#typedef.typespec, + InType = asn1ct_gen:get_inner(RefType#type.def), + case insert_once(check_functions,{Name,RefType}) of + true -> + lookahead_innertype([T],InType,RefType); +% case asn1ct_gen:type(InType) of +% {constructed,bif} -> +% lookahead_innertype([T],InType,RefType); +% #'Externaltypereference'{type=TNew} -> +% lookahead_innertype([TNew],InType,RefType); +% _ -> +% ok +% end; + _ -> + ok + end; + {constructed,bif} -> + NameList = [Cname|TopType], + Name = list2name(NameList ++ [check]), + emit({"'",Name,"'(",DefaultValue,", ",Element,")"}), + ets:insert(check_functions,{Name,Type}), + %% Must look for check functions in InnerType, + %% that may be referenced or internal defined + %% constructed types not used elsewhere. + lookahead_innertype(NameList,InnerType,Type) + end. + +gen_prim_check_call(PrimType,DefaultValue,Element,Type) -> + case unify_if_string(PrimType) of + 'BOOLEAN' -> + emit({"asn1rt_check:check_bool(",DefaultValue,", ", + Element,")"}); + 'INTEGER' -> + NNL = + case Type#type.def of + {_,NamedNumberList} -> NamedNumberList; + _ -> [] + end, + emit({"asn1rt_check:check_int(",DefaultValue,", ", + Element,", ",{asis,NNL},")"}); + 'BIT STRING' -> + {_,NBL} = Type#type.def, + emit({"asn1rt_check:check_bitstring(",DefaultValue,", ", + Element,", ",{asis,NBL},")"}); + 'OCTET STRING' -> + emit({"asn1rt_check:check_octetstring(",DefaultValue,", ", + Element,")"}); + 'NULL' -> + emit({"asn1rt_check:check_null(",DefaultValue,", ", + Element,")"}); + 'OBJECT IDENTIFIER' -> + emit({"asn1rt_check:check_objectidentifier(",DefaultValue, + ", ",Element,")"}); + 'ObjectDescriptor' -> + emit({"asn1rt_check:check_objectdescriptor(",DefaultValue, + ", ",Element,")"}); + 'REAL' -> + emit({"asn1rt_check:check_real(",DefaultValue, + ", ",Element,")"}); + 'ENUMERATED' -> + {_,Enumerations} = Type#type.def, + emit({"asn1rt_check:check_enum(",DefaultValue, + ", ",Element,", ",{asis,Enumerations},")"}); + restrictedstring -> + emit({"asn1rt_check:check_restrictedstring(",DefaultValue, + ", ",Element,")"}) + end. + +%% lokahead_innertype/3 traverses Type and checks if check functions +%% have to be generated, i.e. for all constructed or referenced types. +lookahead_innertype(Name,'SEQUENCE',Type) -> + Components = (Type#type.def)#'SEQUENCE'.components, + lookahead_components(Name,Components); +lookahead_innertype(Name,'SET',Type) -> + Components = (Type#type.def)#'SET'.components, + lookahead_components(Name,Components); +lookahead_innertype(Name,'CHOICE',Type) -> + {_,Components} = Type#type.def, + lookahead_components(Name,Components); +lookahead_innertype(Name,'SEQUENCE OF',SeqOf) -> + lookahead_sof(Name,'SEQOF',SeqOf); +lookahead_innertype(Name,'SET OF',SeqOf) -> + lookahead_sof(Name,'SETOF',SeqOf); +lookahead_innertype(_Name,#'Externaltypereference'{module=M,type=T},_) -> + Typedef = asn1_db:dbget(M,T), + RefType = Typedef#typedef.typespec, + InType = asn1ct_gen:get_inner(RefType#type.def), + case type(InType) of + {constructed,bif} -> + NewName = list2name([T,check]), + case insert_once(check_functions,{NewName,RefType}) of + true -> + lookahead_innertype([T],InType,RefType); + _ -> + ok + end; + #'Externaltypereference'{} -> + NewName = list2name([T,check]), + case insert_once(check_functions,{NewName,RefType}) of + true -> + lookahead_innertype([T],InType,RefType); + _ -> + ok + end; + _ -> + ok + end; +% case insert_once(check_functions,{list2name(Name++[check]),Type}) of +% true -> +% InnerType = asn1ct_gen:get_inner(Type#type.def), +% case asn1ct_gen:type(InnerType) of +% {constructed,bif} -> +% lookahead_innertype([T],InnerType,Type); +% #'Externaltypereference'{type=TNew} -> +% lookahead_innertype([TNew],InnerType,Type); +% _ -> +% ok +% end; +% _ -> +% ok +% end; +lookahead_innertype(_,_,_) -> + ok. + +lookahead_components(_,[]) -> ok; +lookahead_components(Name,[C|Cs]) -> + #'ComponentType'{name=Cname,typespec=Type} = C, + InType = asn1ct_gen:get_inner(Type#type.def), + case asn1ct_gen:type(InType) of + {constructed,bif} -> + case insert_once(check_functions, + {list2name([Cname|Name] ++ [check]),Type}) of + true -> + lookahead_innertype([Cname|Name],InType,Type); + _ -> + ok + end; + #'Externaltypereference'{module=RefMod,type=RefName} -> + Typedef = asn1_db:dbget(RefMod,RefName), + RefType = Typedef#typedef.typespec, + case insert_once(check_functions,{list2name([RefName,check]), + RefType}) of + true -> + lookahead_innertype([RefName],InType,RefType); + _ -> + ok + end; + _ -> + ok + end, + lookahead_components(Name,Cs). + +lookahead_sof(Name,SOF,SOFType) -> + Type = case SOFType#type.def of + {_,_Type} -> _Type; + _Type -> _Type + end, + InnerType = asn1ct_gen:get_inner(Type#type.def), + case asn1ct_gen:type(InnerType) of + {constructed,bif} -> + %% this is if a constructed type is defined in + %% the SEQUENCE OF type + NameList = [SOF|Name], + insert_once(check_functions, + {list2name(NameList ++ [check]),Type}), + lookahead_innertype(NameList,InnerType,Type); + #'Externaltypereference'{module=M,type=T} -> + Typedef = asn1_db:dbget(M,T), + RefType = Typedef#typedef.typespec, + InType = get_inner(RefType#type.def), + case insert_once(check_functions, + {list2name([T,check]),RefType}) of + true -> + lookahead_innertype([T],InType,RefType); + _ -> + ok + end; + _ -> + ok + end. + + +insert_once(Table,Object) -> + case ets:lookup(Table,element(1,Object)) of + [] -> + ets:insert(Table,Object); %returns true + _ -> false + end. + +unify_if_string(PrimType) -> + case PrimType of + 'NumericString' -> + restrictedstring; + 'PrintableString' -> + restrictedstring; + 'TeletexString' -> + restrictedstring; + 'VideotexString' -> + restrictedstring; + 'IA5String' -> + restrictedstring; + 'UTCTime' -> + restrictedstring; + 'GeneralizedTime' -> + restrictedstring; + 'GraphicString' -> + restrictedstring; + 'VisibleString' -> + restrictedstring; + 'GeneralString' -> + restrictedstring; + 'UniversalString' -> + restrictedstring; + 'BMPString' -> + restrictedstring; + Other -> Other + end. + + + + + +get_inner(A) when atom(A) -> A; +get_inner(Ext) when record(Ext,'Externaltypereference') -> Ext; +get_inner(Tref) when record(Tref,typereference) -> Tref; +get_inner({fixedtypevaluefield,_,Type}) -> + if + record(Type,type) -> + get_inner(Type#type.def); + true -> + get_inner(Type) + end; +get_inner({typefield,TypeName}) -> + TypeName; +get_inner(#'ObjectClassFieldType'{type=Type}) -> +% get_inner(Type); + Type; +get_inner(T) when tuple(T) -> + case element(1,T) of + Tuple when tuple(Tuple),element(1,Tuple) == objectclass -> + case catch(lists:last(element(2,T))) of + {valuefieldreference,FieldName} -> + get_fieldtype(element(2,Tuple),FieldName); + {typefieldreference,FieldName} -> + get_fieldtype(element(2,Tuple),FieldName); + {'EXIT',Reason} -> + throw({asn1,{'internal error in get_inner/1',Reason}}) + end; + _ -> element(1,T) + end. + + + + + +type(X) when record(X,'Externaltypereference') -> + X; +type(X) when record(X,typereference) -> + X; +type('ASN1_OPEN_TYPE') -> + 'ASN1_OPEN_TYPE'; +type({fixedtypevaluefield,_Name,Type}) when record(Type,type) -> + type(get_inner(Type#type.def)); +type({typefield,_}) -> + 'ASN1_OPEN_TYPE'; +type(X) -> + %% io:format("asn1_types:type(~p)~n",[X]), + case catch type2(X) of + {'EXIT',_} -> + {notype,X}; + Normal -> + Normal + end. + +type2(X) -> + case prim_bif(X) of + true -> + {primitive,bif}; + false -> + case construct_bif(X) of + true -> + {constructed,bif}; + false -> + {undefined,user} + end + end. + +prim_bif(X) -> + lists:member(X,['INTEGER' , + 'ENUMERATED', + 'OBJECT IDENTIFIER', + 'ANY', + 'NULL', + 'BIT STRING' , + 'OCTET STRING' , + 'ObjectDescriptor', + 'NumericString', + 'TeletexString', + 'VideotexString', + 'UTCTime', + 'GeneralizedTime', + 'GraphicString', + 'VisibleString', + 'GeneralString', + 'PrintableString', + 'IA5String', + 'UniversalString', + 'BMPString', + 'ENUMERATED', + 'BOOLEAN']). + +construct_bif(T) -> + lists:member(T,['SEQUENCE' , + 'SEQUENCE OF' , + 'CHOICE' , + 'SET' , + 'SET OF']). + +def_to_tag(#tag{class=Class,number=Number}) -> + {Class,Number}; +def_to_tag(#'ObjectClassFieldType'{type=Type}) -> + case Type of + T when tuple(T),element(1,T)==fixedtypevaluefield -> + {'UNIVERSAL',get_inner(Type)}; + _ -> + [] + end; +def_to_tag(Def) -> + {'UNIVERSAL',get_inner(Def)}. + + +%% Information Object Class + +type_from_object(X) -> + case (catch lists:last(element(2,X))) of + {'EXIT',_} -> + {notype,X}; + Normal -> + Normal + end. + + +get_fieldtype([],_FieldName)-> + {no_type,no_name}; +get_fieldtype([Field|Rest],FieldName) -> + case element(2,Field) of + FieldName -> + case element(1,Field) of + fixedtypevaluefield -> + {element(1,Field),FieldName,element(3,Field)}; + _ -> + {element(1,Field),FieldName} + end; + _ -> + get_fieldtype(Rest,FieldName) + end. + +get_fieldcategory([],_FieldName) -> + no_cat; +get_fieldcategory([Field|Rest],FieldName) -> + case element(2,Field) of + FieldName -> + element(1,Field); + _ -> + get_fieldcategory(Rest,FieldName) + end. + +get_typefromobject(Type) when record(Type,type) -> + case Type#type.def of + {{objectclass,_,_},TypeFrObj} when list(TypeFrObj) -> + {_,FieldName} = lists:last(TypeFrObj), + FieldName; + _ -> + {no_field} + end. + +get_classfieldcategory(Type,FieldName) -> + case (catch Type#type.def) of + {{obejctclass,Fields,_},_} -> + get_fieldcategory(Fields,FieldName); + {'EXIT',_} -> + no_cat; + _ -> + no_cat + end. +%% Information Object Class + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Convert a list of name parts to something that can be output by emit +%% +%% used to output function names in generated code. + +list2name(L) -> + NewL = list2name1(L), + lists:concat(lists:reverse(NewL)). + +list2name1([{ptype,H1},H2|T]) -> + [H1,"_",list2name([H2|T])]; +list2name1([H1,H2|T]) -> + [H1,"_",list2name([H2|T])]; +list2name1([{ptype,H}|_T]) -> + [H]; +list2name1([H|_T]) -> + [H]; +list2name1([]) -> + []. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Convert a list of name parts to something that can be output by emit +%% stops at {ptype,Pname} i.e Pname whill be the first part of the name +%% used to output record names in generated code. + +list2rname(L) -> + NewL = list2rname1(L), + lists:concat(lists:reverse(NewL)). + +list2rname1([{ptype,H1},_H2|_T]) -> + [H1]; +list2rname1([H1,H2|T]) -> + [H1,"_",list2name([H2|T])]; +list2rname1([{ptype,H}|_T]) -> + [H]; +list2rname1([H|_T]) -> + [H]; +list2rname1([]) -> + []. + + + +constructed_suffix(_,#'SEQUENCE'{pname=Ptypename}) when Ptypename =/= false -> + {ptype, Ptypename}; +constructed_suffix(_,#'SET'{pname=Ptypename}) when Ptypename =/= false -> + {ptype,Ptypename}; +constructed_suffix('SEQUENCE OF',_) -> + 'SEQOF'; +constructed_suffix('SET OF',_) -> + 'SETOF'. + +erule(ber) -> + ber; +erule(ber_bin) -> + ber; +erule(ber_bin_v2) -> + ber_bin_v2; +erule(per) -> + per; +erule(per_bin) -> + per. + +wrap_ber(ber) -> + ber_bin; +wrap_ber(Erule) -> + Erule. + +rt2ct_suffix() -> + Options = get(encoding_options), + case {lists:member(optimize,Options),lists:member(per_bin,Options)} of + {true,true} -> "_rt2ct"; + _ -> "" + end. +rt2ct_suffix(per_bin) -> + Options = get(encoding_options), + case lists:member(optimize,Options) of + true -> "_rt2ct"; + _ -> "" + end; +rt2ct_suffix(_) -> "". + +get_constraint(C,Key) -> + case lists:keysearch(Key,1,C) of + false -> + no; + {value,{_,V}} -> + V; + {value,Cnstr} -> + Cnstr + end. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_gen_ber.erl b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_gen_ber.erl new file mode 100644 index 0000000000..765745dc13 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_gen_ber.erl @@ -0,0 +1,1525 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: asn1ct_gen_ber.erl,v 1.1 2008/12/17 09:53:29 mikpe Exp $ +%% +-module(asn1ct_gen_ber). + +%% Generate erlang module which handles (PER) encode and decode for +%% all types in an ASN.1 module + +-include("asn1_records.hrl"). + +-export([pgen/4]). +-export([decode_class/1, decode_type/1]). +-export([add_removed_bytes/0]). +-export([gen_encode/2,gen_encode/3,gen_decode/2,gen_decode/3]). +-export([gen_encode_prim/4]). +-export([gen_dec_prim/8]). +-export([gen_objectset_code/2, gen_obj_code/3]). +-export([re_wrap_erule/1]). +-export([unused_var/2]). + +-import(asn1ct_gen, [emit/1,demit/1]). + + % the encoding of class of tag bits 8 and 7 +-define(UNIVERSAL, 0). +-define(APPLICATION, 16#40). +-define(CONTEXT, 16#80). +-define(PRIVATE, 16#C0). + + % primitive or constructed encoding % bit 6 +-define(PRIMITIVE, 0). +-define(CONSTRUCTED, 2#00100000). + + +-define(T_ObjectDescriptor, ?UNIVERSAL bor ?PRIMITIVE bor 7). + % restricted character string types +-define(T_NumericString, ?UNIVERSAL bor ?PRIMITIVE bor 18). %can be constructed +-define(T_PrintableString, ?UNIVERSAL bor ?PRIMITIVE bor 19). %can be constructed +-define(T_TeletexString, ?UNIVERSAL bor ?PRIMITIVE bor 20). %can be constructed +-define(T_VideotexString, ?UNIVERSAL bor ?PRIMITIVE bor 21). %can be constructed +-define(T_IA5String, ?UNIVERSAL bor ?PRIMITIVE bor 22). %can be constructed +-define(T_GraphicString, ?UNIVERSAL bor ?PRIMITIVE bor 25). %can be constructed +-define(T_VisibleString, ?UNIVERSAL bor ?PRIMITIVE bor 26). %can be constructed +-define(T_GeneralString, ?UNIVERSAL bor ?PRIMITIVE bor 27). %can be constructed + +%% pgen(Erules, Module, TypeOrVal) +%% Generate Erlang module (.erl) and (.hrl) file corresponding to an ASN.1 module +%% .hrl file is only generated if necessary +%% Erules = per | ber +%% Module = atom() +%% TypeOrVal = {TypeList,ValueList,PTypeList} +%% TypeList = ValueList = [atom()] + +pgen(OutFile,Erules,Module,TypeOrVal) -> + asn1ct_gen:pgen_module(OutFile,Erules,Module,TypeOrVal,true). + + +%%=============================================================================== +%%=============================================================================== +%%=============================================================================== +%% Generate ENCODING +%%=============================================================================== +%%=============================================================================== +%%=============================================================================== + +%%=============================================================================== +%% encode #{typedef, {pos, name, typespec}} +%%=============================================================================== + +gen_encode(Erules,Type) when record(Type,typedef) -> + gen_encode_user(Erules,Type). + +%%=============================================================================== +%% encode #{type, {tag, def, constraint}} +%%=============================================================================== + +gen_encode(Erules,Typename,Type) when record(Type,type) -> + InnerType = asn1ct_gen:get_inner(Type#type.def), + ObjFun = + case lists:keysearch(objfun,1,Type#type.tablecinf) of + {value,{_,_Name}} -> + ", ObjFun"; + false -> + "" + end, + case asn1ct_gen:type(InnerType) of + {constructed,bif} -> + emit([nl,nl,nl,"%%================================"]), + emit([nl,"%% ",asn1ct_gen:list2name(Typename)]), + emit([nl,"%%================================",nl]), + case lists:member(InnerType,['SET','SEQUENCE']) of + true -> + case get(asn_keyed_list) of + true -> + CompList = + case Type#type.def of + #'SEQUENCE'{components=Cl} -> Cl; + #'SET'{components=Cl} -> Cl + end, + emit([nl,"'enc_",asn1ct_gen:list2name(Typename), + "'(Val, TagIn",ObjFun, + ") when list(Val) ->",nl]), + emit([" 'enc_",asn1ct_gen:list2name(Typename), + "'(?RT_BER:fixoptionals(", + {asis,optionals(CompList)}, + ",Val), TagIn",ObjFun,");",nl,nl]); + _ -> true + end; + _ -> + emit([nl,"'enc_",asn1ct_gen:list2name(Typename), + "'({'",asn1ct_gen:list2name(Typename), + "',Val}, TagIn",ObjFun,") ->",nl]), + emit([" 'enc_",asn1ct_gen:list2name(Typename), + "'(Val, TagIn",ObjFun,");",nl,nl]) + end, + emit(["'enc_",asn1ct_gen:list2name(Typename), + "'(Val, TagIn",ObjFun,") ->",nl," "]), + asn1ct_gen:gen_encode_constructed(Erules,Typename,InnerType,Type); + _ -> + true + end; + +%%=============================================================================== +%% encode ComponentType +%%=============================================================================== + +gen_encode(Erules,Tname,{'ComponentType',_Pos,Cname,Type,_,_}) -> + NewTname = [Cname|Tname], + %% The tag is set to [] to avoid that it is + %% taken into account twice, both as a component/alternative (passed as + %% argument to the encode decode function and within the encode decode + %% function it self. + NewType = Type#type{tag=[]}, + gen_encode(Erules,NewTname,NewType). + +gen_encode_user(Erules,D) when record(D,typedef) -> + Typename = [D#typedef.name], + Type = D#typedef.typespec, + InnerType = asn1ct_gen:get_inner(Type#type.def), + OTag = Type#type.tag, + Tag = [X#tag{class=decode_class(X#tag.class)}|| X <- OTag], + emit([nl,nl,"%%================================"]), + emit([nl,"%% ",Typename]), + emit([nl,"%%================================",nl]), + case lists:member(InnerType,['SET','SEQUENCE']) of + true -> + case get(asn_keyed_list) of + true -> + CompList = + case Type#type.def of + #'SEQUENCE'{components=Cl} -> Cl; + #'SET'{components=Cl} -> Cl + end, + + emit([nl,"'enc_",asn1ct_gen:list2name(Typename), + "'(Val, TagIn) when list(Val) ->",nl]), + emit([" 'enc_",asn1ct_gen:list2name(Typename), + "'(?RT_BER:fixoptionals(", + {asis,optionals(CompList)}, + ",Val), TagIn);",nl,nl]); + _ -> true + end; + _ -> + emit({nl,"'enc_",asn1ct_gen:list2name(Typename), + "'({'",asn1ct_gen:list2name(Typename),"',Val}, TagIn) ->",nl}), + emit({" 'enc_",asn1ct_gen:list2name(Typename),"'(Val, TagIn);",nl,nl}) + end, + emit({"'enc_",asn1ct_gen:list2name(Typename),"'(", + unused_var("Val",Type#type.def),", TagIn) ->",nl}), + CurrentMod = get(currmod), + case asn1ct_gen:type(InnerType) of + {constructed,bif} -> + asn1ct_gen:gen_encode_constructed(Erules,Typename,InnerType,D); + {primitive,bif} -> + asn1ct_gen_ber:gen_encode_prim(ber,Type,["TagIn ++ ", + {asis,Tag}],"Val"), + emit([".",nl]); + #typereference{val=Ename} -> + emit([" 'enc_",Ename,"'(Val, TagIn ++ ",{asis,Tag},").",nl]); + #'Externaltypereference'{module=CurrentMod,type=Etype} -> + emit([" 'enc_",Etype,"'(Val, TagIn ++ ", + {asis,Tag},").",nl]); + #'Externaltypereference'{module=Emod,type=Etype} -> + emit([" '",Emod,"':'enc_",Etype,"'(Val, TagIn ++ ", + {asis,Tag},").",nl]); + 'ASN1_OPEN_TYPE' -> + emit(["%% OPEN TYPE",nl]), + asn1ct_gen_ber:gen_encode_prim(ber, + Type#type{def='ASN1_OPEN_TYPE'}, + ["TagIn ++ ", + {asis,Tag}],"Val"), + emit([".",nl]) + end. + +unused_var(Var,#'SEQUENCE'{components=Cl}) -> + unused_var1(Var,Cl); +unused_var(Var,#'SET'{components=Cl}) -> + unused_var1(Var,Cl); +unused_var(Var,_) -> + Var. +unused_var1(Var,Cs) when Cs == []; Cs == {[],[]} -> + lists:concat(["_",Var]); +unused_var1(Var,_) -> + Var. + +unused_optormand_var(Var,Def) -> + case asn1ct_gen:type(asn1ct_gen:get_inner(Def)) of + 'ASN1_OPEN_TYPE' -> + lists:concat(["_",Var]); + _ -> + Var + end. + + +gen_encode_prim(_Erules,D,DoTag,Value) when record(D,type) -> + +%%% Currently not used for BER (except for BitString) and therefore replaced +%%% with [] as a placeholder + BitStringConstraint = D#type.constraint, + Constraint = [], + asn1ct_name:new(enumval), + case D#type.def of + 'BOOLEAN' -> + emit_encode_func('boolean',Value,DoTag); + 'INTEGER' -> + emit_encode_func('integer',Constraint,Value,DoTag); + {'INTEGER',NamedNumberList} -> + emit_encode_func('integer',Constraint,Value, + NamedNumberList,DoTag); + {'ENUMERATED',NamedNumberList={_,_}} -> + + emit(["case (case ",Value," of {asn1_enum,_}->",Value,";{_,_}->element(2,",Value,");_->", + Value," end) of",nl]), + emit_enc_enumerated_cases(NamedNumberList,DoTag); + {'ENUMERATED',NamedNumberList} -> + + emit(["case (case ",Value," of {_,_}->element(2,",Value,");_->", + Value," end) of",nl]), + emit_enc_enumerated_cases(NamedNumberList,DoTag); + + {'BIT STRING',NamedNumberList} -> + emit_encode_func('bit_string',BitStringConstraint,Value, + NamedNumberList,DoTag); + 'ANY' -> + emit_encode_func('open_type', Value,DoTag); + 'NULL' -> + emit_encode_func('null',Value,DoTag); + 'OBJECT IDENTIFIER' -> + emit_encode_func("object_identifier",Value,DoTag); + 'ObjectDescriptor' -> + emit_encode_func('restricted_string',Constraint,Value, + ?T_ObjectDescriptor,DoTag); + 'OCTET STRING' -> + emit_encode_func('octet_string',Constraint,Value,DoTag); + 'NumericString' -> + emit_encode_func('restricted_string',Constraint,Value, + ?T_NumericString,DoTag); + 'TeletexString' -> + emit_encode_func('restricted_string',Constraint,Value, + ?T_TeletexString,DoTag); + 'VideotexString' -> + emit_encode_func('restricted_string',Constraint,Value, + ?T_VideotexString,DoTag); + 'GraphicString' -> + emit_encode_func('restricted_string',Constraint,Value, + ?T_GraphicString,DoTag); + 'VisibleString' -> + emit_encode_func('restricted_string',Constraint,Value, + ?T_VisibleString,DoTag); + 'GeneralString' -> + emit_encode_func('restricted_string',Constraint,Value, + ?T_GeneralString,DoTag); + 'PrintableString' -> + emit_encode_func('restricted_string',Constraint,Value, + ?T_PrintableString,DoTag); + 'IA5String' -> + emit_encode_func('restricted_string',Constraint,Value, + ?T_IA5String,DoTag); + 'UniversalString' -> + emit_encode_func('universal_string',Constraint,Value,DoTag); + 'BMPString' -> + emit_encode_func('BMP_string',Constraint,Value,DoTag); + 'UTCTime' -> + emit_encode_func('utc_time',Constraint,Value,DoTag); + 'GeneralizedTime' -> + emit_encode_func('generalized_time',Constraint,Value,DoTag); + 'ASN1_OPEN_TYPE' -> + emit_encode_func('open_type', Value,DoTag); + XX -> + exit({'can not encode' ,XX}) + end. + + +emit_encode_func(Name,Value,Tags) when atom(Name) -> + emit_encode_func(atom_to_list(Name),Value,Tags); +emit_encode_func(Name,Value,Tags) -> + Fname = "?RT_BER:encode_" ++ Name, + emit([Fname,"(",Value,", ",Tags,")"]). + +emit_encode_func(Name,Constraint,Value,Tags) when atom(Name) -> + emit_encode_func(atom_to_list(Name),Constraint,Value,Tags); +emit_encode_func(Name,Constraint,Value,Tags) -> + Fname = "?RT_BER:encode_" ++ Name, + emit([Fname,"(",{asis,Constraint},", ",Value,", ",Tags,")"]). + +emit_encode_func(Name,Constraint,Value,Asis,Tags) when atom(Name) -> + emit_encode_func(atom_to_list(Name),Constraint,Value,Asis,Tags); +emit_encode_func(Name,Constraint,Value,Asis,Tags) -> + Fname = "?RT_BER:encode_" ++ Name, + emit([Fname,"(",{asis,Constraint},", ",Value, + ", ",{asis,Asis}, + ", ",Tags,")"]). + +emit_enc_enumerated_cases({L1,L2}, Tags) -> + emit_enc_enumerated_cases(L1++L2, Tags, ext); +emit_enc_enumerated_cases(L, Tags) -> + emit_enc_enumerated_cases(L, Tags, noext). + +emit_enc_enumerated_cases([{EnumName,EnumVal},H2|T], Tags, Ext) -> + emit([{asis,EnumName}," -> ?RT_BER:encode_enumerated(",EnumVal,",",Tags,");",nl]), +%% emit(["'",{asis,EnumName},"' -> ?RT_BER:encode_enumerated(",EnumVal,",",Tags,");",nl]), + emit_enc_enumerated_cases([H2|T], Tags, Ext); +emit_enc_enumerated_cases([{EnumName,EnumVal}], Tags, Ext) -> + emit([{asis,EnumName}," -> ?RT_BER:encode_enumerated(",EnumVal,",",Tags,")"]), +%% emit(["'",{asis,EnumName},"' -> ?RT_BER:encode_enumerated(",EnumVal,",",Tags,")"]), + case Ext of + noext -> emit([";",nl]); + ext -> + emit([";",nl,"{asn1_enum,",{curr,enumval},"} -> ", + "?RT_BER:encode_enumerated(",{curr,enumval},",",Tags,");",nl]), + asn1ct_name:new(enumval) + end, + emit([{curr,enumval}," -> exit({error,{asn1, {enumerated_not_in_range,",{curr, enumval},"}}})"]), + emit([nl,"end"]). + + +%%=============================================================================== +%%=============================================================================== +%%=============================================================================== +%% Generate DECODING +%%=============================================================================== +%%=============================================================================== +%%=============================================================================== + +%%=============================================================================== +%% decode #{typedef, {pos, name, typespec}} +%%=============================================================================== + +gen_decode(Erules,Type) when record(Type,typedef) -> + D = Type, + emit({nl,nl}), + emit({"'dec_",Type#typedef.name,"'(Bytes, OptOrMand) ->",nl}), + emit({" 'dec_",Type#typedef.name,"'(Bytes, OptOrMand, []).",nl,nl}), + emit({"'dec_",Type#typedef.name,"'(Bytes, ", + unused_optormand_var("OptOrMand",(Type#typedef.typespec)#type.def),", TagIn) ->",nl}), + dbdec(Type#typedef.name), + gen_decode_user(Erules,D). + + +%%=============================================================================== +%% decode #{type, {tag, def, constraint}} +%%=============================================================================== + +gen_decode(Erules,Tname,Type) when record(Type,type) -> + Typename = Tname, + InnerType = asn1ct_gen:get_inner(Type#type.def), + case asn1ct_gen:type(InnerType) of + {constructed,bif} -> + ObjFun = + case Type#type.tablecinf of + [{objfun,_}|_R] -> + ", ObjFun"; + _ -> + "" + end, + emit({"'dec_",asn1ct_gen:list2name(Typename),"'(Bytes, OptOrMand, TagIn",ObjFun,") ->",nl}), + dbdec(Typename), + asn1ct_gen:gen_decode_constructed(Erules,Typename,InnerType,Type); + _ -> + true + end; + + +%%=============================================================================== +%% decode ComponentType +%%=============================================================================== + +gen_decode(Erules,Tname,{'ComponentType',_Pos,Cname,Type,_,_}) -> + NewTname = [Cname|Tname], + %% The tag is set to [] to avoid that it is + %% taken into account twice, both as a component/alternative (passed as + %% argument to the encode decode function and within the encode decode + %% function it self. + NewType = Type#type{tag=[]}, + gen_decode(Erules,NewTname,NewType). + + +gen_decode_user(Erules,D) when record(D,typedef) -> + Typename = [D#typedef.name], + Def = D#typedef.typespec, + InnerType = asn1ct_gen:get_inner(Def#type.def), + InnerTag = Def#type.tag , + Tag = [X#tag{class=decode_class(X#tag.class)}|| X <- InnerTag], + case asn1ct_gen:type(InnerType) of + 'ASN1_OPEN_TYPE' -> + BytesVar = asn1ct_gen:mk_var(asn1ct_name:curr(bytes)), + asn1ct_name:new(len), + gen_dec_prim(Erules, Def#type{def='ASN1_OPEN_TYPE'}, + BytesVar, Tag, "TagIn",no_length, + ?PRIMITIVE,"OptOrMand"), + emit({".",nl,nl}); + {primitive,bif} -> + BytesVar = asn1ct_gen:mk_var(asn1ct_name:curr(bytes)), + asn1ct_name:new(len), + gen_dec_prim(Erules, Def, BytesVar, Tag, "TagIn",no_length, + ?PRIMITIVE,"OptOrMand"), + emit({".",nl,nl}); + {constructed,bif} -> + asn1ct_gen:gen_decode_constructed(Erules,Typename,InnerType,D); + TheType -> + DecFunName = mkfuncname(TheType,dec), + emit({DecFunName,"(",{curr,bytes}, + ", OptOrMand, TagIn++",{asis,Tag},")"}), + emit({".",nl,nl}) + end. + + +gen_dec_prim(Erules,Att,BytesVar,DoTag,TagIn,Length,_Form,OptOrMand) -> + Typename = Att#type.def, +%% Currently not used for BER replaced with [] as place holder +%% Constraint = Att#type.constraint, +%% Constraint = [], + Constraint = + case get_constraint(Att#type.constraint,'SizeConstraint') of + no -> []; + Tc -> Tc + end, + ValueRange = + case get_constraint(Att#type.constraint,'ValueRange') of + no -> []; + Tv -> Tv + end, + SingleValue = + case get_constraint(Att#type.constraint,'SingleValue') of + no -> []; + Sv -> Sv + end, + AsBin = case get(binary_strings) of + true -> "_as_bin"; + _ -> "" + end, + NewTypeName = case Typename of + 'ANY' -> 'ASN1_OPEN_TYPE'; + _ -> Typename + end, + DoLength = + case NewTypeName of + 'BOOLEAN'-> + emit({"?RT_BER:decode_boolean(",BytesVar,","}), + false; + 'INTEGER' -> + emit({"?RT_BER:decode_integer(",BytesVar,",", + {asis,int_constr(SingleValue,ValueRange)},","}), + false; + {'INTEGER',NamedNumberList} -> + emit({"?RT_BER:decode_integer(",BytesVar,",", + {asis,int_constr(SingleValue,ValueRange)},",", + {asis,NamedNumberList},","}), + false; + {'ENUMERATED',NamedNumberList} -> + emit({"?RT_BER:decode_enumerated(",BytesVar,",", + {asis,Constraint},",", + {asis,NamedNumberList},","}), + false; + {'BIT STRING',NamedNumberList} -> + case get(compact_bit_string) of + true -> + emit({"?RT_BER:decode_compact_bit_string(", + BytesVar,",",{asis,Constraint},",", + {asis,NamedNumberList},","}); + _ -> + emit({"?RT_BER:decode_bit_string(",BytesVar,",", + {asis,Constraint},",", + {asis,NamedNumberList},","}) + end, + true; + 'NULL' -> + emit({"?RT_BER:decode_null(",BytesVar,","}), + false; + 'OBJECT IDENTIFIER' -> + emit({"?RT_BER:decode_object_identifier(",BytesVar,","}), + false; + 'ObjectDescriptor' -> + emit({"?RT_BER:decode_restricted_string(", + BytesVar,",",{asis,Constraint},",",{asis,?T_ObjectDescriptor},","}), + true; + 'OCTET STRING' -> + emit({"?RT_BER:decode_octet_string",AsBin,"(",BytesVar,",",{asis,Constraint},","}), + true; + 'NumericString' -> + emit({"?RT_BER:decode_restricted_string",AsBin,"(", + BytesVar,",",{asis,Constraint},",",{asis,?T_NumericString},","}),true; + 'TeletexString' -> + emit({"?RT_BER:decode_restricted_string",AsBin,"(", + BytesVar,",",{asis,Constraint},",",{asis,?T_TeletexString},","}), + true; + 'VideotexString' -> + emit({"?RT_BER:decode_restricted_string",AsBin,"(", + BytesVar,",",{asis,Constraint},",",{asis,?T_VideotexString},","}), + true; + 'GraphicString' -> + emit({"?RT_BER:decode_restricted_string",AsBin,"(", + BytesVar,",",{asis,Constraint},",",{asis,?T_GraphicString},","}) + ,true; + 'VisibleString' -> + emit({"?RT_BER:decode_restricted_string",AsBin,"(", + BytesVar,",",{asis,Constraint},",",{asis,?T_VisibleString},","}), + true; + 'GeneralString' -> + emit({"?RT_BER:decode_restricted_string",AsBin,"(", + BytesVar,",",{asis,Constraint},",",{asis,?T_GeneralString},","}), + true; + 'PrintableString' -> + emit({"?RT_BER:decode_restricted_string",AsBin,"(", + BytesVar,",",{asis,Constraint},",",{asis,?T_PrintableString},","}), + true; + 'IA5String' -> + emit({"?RT_BER:decode_restricted_string",AsBin,"(", + BytesVar,",",{asis,Constraint},",",{asis,?T_IA5String},","}), + true; + 'UniversalString' -> + emit({"?RT_BER:decode_universal_string",AsBin,"(", + BytesVar,",",{asis,Constraint},","}), + true; + 'BMPString' -> + emit({"?RT_BER:decode_BMP_string",AsBin,"(", + BytesVar,",",{asis,Constraint},","}), + true; + 'UTCTime' -> + emit({"?RT_BER:decode_utc_time",AsBin,"(", + BytesVar,",",{asis,Constraint},","}), + true; + 'GeneralizedTime' -> + emit({"?RT_BER:decode_generalized_time",AsBin,"(", + BytesVar,",",{asis,Constraint},","}), + true; + 'ASN1_OPEN_TYPE' -> + emit(["?RT_BER:decode_open_type(",re_wrap_erule(Erules),",", + BytesVar,","]), + false; + Other -> + exit({'can not decode' ,Other}) + end, + + NewLength = case DoLength of + true -> [", ", Length]; + false -> "" + end, + NewOptOrMand = case OptOrMand of + _ when list(OptOrMand) -> OptOrMand; + mandatory -> {asis,mandatory}; + _ -> {asis,opt_or_default} + end, + case {TagIn,NewTypeName} of + {[],'ASN1_OPEN_TYPE'} -> + emit([{asis,DoTag},")"]); + {_,'ASN1_OPEN_TYPE'} -> + emit([TagIn,"++",{asis,DoTag},")"]); + {[],_} -> + emit([{asis,DoTag},NewLength,", ",NewOptOrMand,")"]); + _ when list(TagIn) -> + emit([TagIn,"++",{asis,DoTag},NewLength,", ",NewOptOrMand,")"]) + end. + + +int_constr([],[]) -> + []; +int_constr([],ValueRange) -> + ValueRange; +int_constr(SingleValue,[]) -> + SingleValue; +int_constr(SV,VR) -> + [SV,VR]. + +%% Object code generating for encoding and decoding +%% ------------------------------------------------ + +gen_obj_code(Erules,_Module,Obj) when record(Obj,typedef) -> + ObjName = Obj#typedef.name, + Def = Obj#typedef.typespec, + #'Externaltypereference'{module=M,type=ClName} = Def#'Object'.classname, + Class = asn1_db:dbget(M,ClName), + + {object,_,Fields} = Def#'Object'.def, + emit({nl,nl,nl,"%%================================"}), + emit({nl,"%% ",ObjName}), + emit({nl,"%%================================",nl}), + EncConstructed = + gen_encode_objectfields(ClName,get_class_fields(Class), + ObjName,Fields,[]), + emit(nl), + gen_encode_constr_type(Erules,EncConstructed), + emit(nl), + DecConstructed = + gen_decode_objectfields(ClName,get_class_fields(Class), + ObjName,Fields,[]), + emit(nl), + gen_decode_constr_type(Erules,DecConstructed); +gen_obj_code(_Erules,_Module,Obj) when record(Obj,pobjectdef) -> + ok. + + +gen_encode_objectfields(ClassName,[{typefield,Name,OptOrMand}|Rest], + ObjName,ObjectFields,ConstrAcc) -> + EmitFuncClause = + fun(Args) -> + emit(["'enc_",ObjName,"'(",{asis,Name}, + ", ",Args,", _RestPrimFieldName) ->",nl]) + end, +% emit(["'enc_",ObjName,"'(",{asis,Name}, +% ", Val, TagIn, _RestPrimFieldName) ->",nl]), + MaybeConstr= + case {get_object_field(Name,ObjectFields),OptOrMand} of + {false,'MANDATORY'} -> %% this case is illegal + exit({error,{asn1,{"missing mandatory field in object", + ObjName}}}); + {false,'OPTIONAL'} -> + EmitFuncClause("_, _"), + emit([" {[],0}"]), + []; + {false,{'DEFAULT',DefaultType}} -> + EmitFuncClause("Val, TagIn"), + gen_encode_default_call(ClassName,Name,DefaultType); + {{Name,TypeSpec},_} -> + %% A specified field owerwrites any 'DEFAULT' or + %% 'OPTIONAL' field in the class + EmitFuncClause("Val, TagIn"), + gen_encode_field_call(ObjName,Name,TypeSpec) + end, + case more_genfields(Rest) of + true -> + emit([";",nl]); + false -> + emit([".",nl]) + end, + gen_encode_objectfields(ClassName,Rest,ObjName,ObjectFields, + MaybeConstr++ConstrAcc); +gen_encode_objectfields(ClassName,[{objectfield,Name,_,_,OptOrMand}|Rest], + ObjName,ObjectFields,ConstrAcc) -> + EmitFuncClause = + fun(Args) -> + emit(["'enc_",ObjName,"'(",{asis,Name}, + ", ",Args,") ->",nl]) + end, +% emit(["'enc_",ObjName,"'(",{asis,Name}, +% ", Val, TagIn, [H|T]) ->",nl]), + case {get_object_field(Name,ObjectFields),OptOrMand} of + {false,'MANDATORY'} -> + exit({error,{asn1,{"missing mandatory field in object", + ObjName}}}); + {false,'OPTIONAL'} -> + EmitFuncClause("_,_,_"), + emit([" exit({error,{'use of missing field in object', ",Name, + "}})"]); + {false,{'DEFAULT',_DefaultObject}} -> + exit({error,{asn1,{"not implemented yet",Name}}}); + {{Name,TypeSpec},_} -> + EmitFuncClause(" Val, TagIn, [H|T]"), + case TypeSpec#typedef.name of + {ExtMod,TypeName} -> + emit({indent(3),"'",ExtMod,"':'enc_",TypeName, + "'(H, Val, TagIn, T)"}); + TypeName -> + emit({indent(3),"'enc_",TypeName,"'(H, Val, TagIn, T)"}) + end + end, + case more_genfields(Rest) of + true -> + emit([";",nl]); + false -> + emit([".",nl]) + end, + gen_encode_objectfields(ClassName,Rest,ObjName,ObjectFields,ConstrAcc); +gen_encode_objectfields(ClassName,[_|Cs],O,OF,Acc) -> + gen_encode_objectfields(ClassName,Cs,O,OF,Acc); +gen_encode_objectfields(_,[],_,_,Acc) -> + Acc. + + +% gen_encode_objectfields(Class,ObjName,[{FieldName,Type}|Rest],ConstrAcc) -> +% Fields = Class#objectclass.fields, +% MaybeConstr= +% case is_typefield(Fields,FieldName) of +% true -> +% Def = Type#typedef.typespec, +% OTag = Def#type.tag, +% Tag = [X#tag{class=decode_class(X#tag.class)}|| X <- OTag], +% emit({"'enc_",ObjName,"'(",{asis,FieldName}, +% ", Val, TagIn, RestPrimFieldName) ->",nl}), +% CAcc= +% case Type#typedef.name of +% {primitive,bif} -> +% gen_encode_prim(ber,Def,["TagIn ++ ",{asis,Tag}], +% "Val"), +% []; +% {constructed,bif} -> +% %%InnerType = asn1ct_gen:get_inner(Def#type.def), +% %%asn1ct_gen:gen_encode_constructed(ber,[ObjName], +% %% InnerType,Def); +% emit({" 'enc_",ObjName,'_',FieldName, +% "'(Val, TagIn ++ ",{asis,Tag},")"}), +% [{['enc_',ObjName,'_',FieldName],Def}]; +% {ExtMod,TypeName} -> +% emit({" '",ExtMod,"':'enc_",TypeName, +% "'(Val, TagIn ++ ",{asis,Tag},")"}), +% []; +% TypeName -> +% emit({" 'enc_",TypeName,"'(Val, TagIn ++ ", +% {asis,Tag},")"}), +% [] +% end, +% case more_genfields(Fields,Rest) of +% true -> +% emit({";",nl}); +% false -> +% emit({".",nl}) +% end, +% CAcc; +% {false,objectfield} -> +% emit({"'enc_",ObjName,"'(",{asis,FieldName}, +% ", Val, TagIn, [H|T]) ->",nl}), +% case Type#typedef.name of +% {ExtMod,TypeName} -> +% emit({indent(3),"'",ExtMod,"':'enc_",TypeName, +% "'(H, Val, TagIn, T)"}); +% TypeName -> +% emit({indent(3),"'enc_",TypeName,"'(H, Val, TagIn, T)"}) +% end, +% case more_genfields(Fields,Rest) of +% true -> +% emit({";",nl}); +% false -> +% emit({".",nl}) +% end, +% []; +% {false,_} -> [] +% end, +% gen_encode_objectfields(Class,ObjName,Rest,MaybeConstr ++ ConstrAcc); +% gen_encode_objectfields(C,O,[H|T],Acc) -> +% gen_encode_objectfields(C,O,T,Acc); +% gen_encode_objectfields(_,_,[],Acc) -> +% Acc. + +% gen_encode_constr_type([{Name,Def}|Rest]) -> +% emit({Name,"(Val,TagIn) ->",nl}), +% InnerType = asn1ct_gen:get_inner(Def#type.def), +% asn1ct_gen:gen_encode_constructed(ber,Name,InnerType,Def), +% gen_encode_constr_type(Rest); +gen_encode_constr_type(Erules,[TypeDef|Rest]) when record(TypeDef,typedef) -> + case is_already_generated(enc,TypeDef#typedef.name) of + true -> ok; + _ -> gen_encode_user(Erules,TypeDef) + end, + gen_encode_constr_type(Erules,Rest); +gen_encode_constr_type(_,[]) -> + ok. + +gen_encode_field_call(ObjName,FieldName,Type) -> + Def = Type#typedef.typespec, + OTag = Def#type.tag, + Tag = [X#tag{class=decode_class(X#tag.class)}|| X <- OTag], + case Type#typedef.name of + {primitive,bif} -> %%tag should be the primitive tag + gen_encode_prim(ber,Def,["TagIn ++ ",{asis,Tag}], + "Val"), + []; + {constructed,bif} -> + emit({" 'enc_",ObjName,'_',FieldName, + "'(Val, TagIn ++",{asis,Tag},")"}), + [Type#typedef{name=list_to_atom(lists:concat([ObjName,'_',FieldName]))}]; + {ExtMod,TypeName} -> + emit({" '",ExtMod,"':'enc_",TypeName, + "'(Val, TagIn ++ ",{asis,Tag},")"}), + []; + TypeName -> + emit({" 'enc_",TypeName,"'(Val, TagIn ++ ",{asis,Tag},")"}), + [] + end. + +gen_encode_default_call(ClassName,FieldName,Type) -> + CurrentMod = get(currmod), + InnerType = asn1ct_gen:get_inner(Type#type.def), + OTag = Type#type.tag, + Tag = [X#tag{class=decode_class(X#tag.class)}|| X <- OTag], + case asn1ct_gen:type(InnerType) of + {constructed,bif} -> +%% asn1ct_gen:gen_encode_constructed(Erules,Typename,InnerType,Type); + emit([" 'enc_",ClassName,'_',FieldName,"'(Bytes, TagIn ++ ", + {asis,Tag},")"]), + [#typedef{name=list_to_atom(lists:concat([ClassName,'_',FieldName])), + typespec=Type}]; + {primitive,bif} -> + gen_encode_prim(ber,Type,["TagIn ++ ",{asis,Tag}],"Val"), + []; + #'Externaltypereference'{module=CurrentMod,type=Etype} -> + emit([" 'enc_",Etype,"'(Val, TagIn ++ ",{asis,Tag},")",nl]), + []; + #'Externaltypereference'{module=Emod,type=Etype} -> + emit([" '",Emod,"':'enc_",Etype,"'(Val, TagIn ++ ",{asis,Tag},")",nl]), + [] + end. + + + +gen_decode_objectfields(ClassName,[{typefield,Name,OptOrMand}|Rest], + ObjName,ObjectFields,ConstrAcc) -> + EmitFuncClause = + fun(Args) -> + emit(["'dec_",ObjName,"'(",{asis,Name}, + ", ",Args,"_) ->",nl]) + end, +% emit(["'dec_",ObjName,"'(",{asis,Name}, +% ", Bytes, TagIn, RestPrimFieldName) ->",nl]), + MaybeConstr= + case {get_object_field(Name,ObjectFields),OptOrMand} of + {false,'MANDATORY'} -> %% this case is illegal + exit({error,{asn1,{"missing mandatory field in object", + ObjName}}}); + {false,'OPTIONAL'} -> + EmitFuncClause("_, _,"), + emit([" asn1_NOVALUE"]), + []; + {false,{'DEFAULT',DefaultType}} -> + EmitFuncClause("Bytes, TagIn,"), + gen_decode_default_call(ClassName,Name,"Bytes",DefaultType); + {{Name,TypeSpec},_} -> + %% A specified field owerwrites any 'DEFAULT' or + %% 'OPTIONAL' field in the class + EmitFuncClause("Bytes, TagIn,"), + gen_decode_field_call(ObjName,Name,"Bytes",TypeSpec) + end, + case more_genfields(Rest) of + true -> + emit([";",nl]); + false -> + emit([".",nl]) + end, + gen_decode_objectfields(ClassName,Rest,ObjName,ObjectFields,MaybeConstr++ConstrAcc); +gen_decode_objectfields(ClassName,[{objectfield,Name,_,_,OptOrMand}|Rest], + ObjName,ObjectFields,ConstrAcc) -> + EmitFuncClause = + fun(Args) -> + emit(["'dec_",ObjName,"'(",{asis,Name}, + ", ",Args,") ->",nl]) + end, +% emit(["'dec_",ObjName,"'(",{asis,Name}, +% ", Bytes,TagIn,[H|T]) ->",nl]), + case {get_object_field(Name,ObjectFields),OptOrMand} of + {false,'MANDATORY'} -> + exit({error,{asn1,{"missing mandatory field in object", + ObjName}}}); + {false,'OPTIONAL'} -> + EmitFuncClause("_,_,_"), + emit([" exit({error,{'illegal use of missing field in object', ",Name, + "}})"]); + {false,{'DEFAULT',_DefaultObject}} -> + exit({error,{asn1,{"not implemented yet",Name}}}); + {{Name,TypeSpec},_} -> + EmitFuncClause("Bytes,TagIn,[H|T]"), + case TypeSpec#typedef.name of + {ExtMod,TypeName} -> + emit({indent(3),"'",ExtMod,"':'dec_",TypeName, + "'(H, Bytes, TagIn, T)"}); + TypeName -> + emit({indent(3),"'dec_",TypeName,"'(H, Bytes, TagIn, T)"}) + end + end, + case more_genfields(Rest) of + true -> + emit([";",nl]); + false -> + emit([".",nl]) + end, + gen_decode_objectfields(ClassName,Rest,ObjName,ObjectFields,ConstrAcc); +gen_decode_objectfields(CN,[_|Cs],O,OF,CAcc) -> + gen_decode_objectfields(CN,Cs,O,OF,CAcc); +gen_decode_objectfields(_,[],_,_,CAcc) -> + CAcc. + + + +% gen_decode_objectfields(Erules,Class,ObjName,[{FieldName,Type}|Rest],ConstrAcc) -> +% Fields = Class#objectclass.fields, +% MaybeConstr = +% case is_typefield(Fields,FieldName) of +% true -> +% Def = Type#typedef.typespec, +% emit({"'dec_",ObjName,"'(",{asis,FieldName}, +% ", Bytes, TagIn, RestPrimFieldName) ->",nl}), +% OTag = Def#type.tag, +% Tag = [X#tag{class=decode_class(X#tag.class)}|| X <- OTag], +% Prop = +% case get_optionalityspec(Fields,FieldName) of +% 'OPTIONAL' -> opt_or_default; +% {'DEFAULT',_} -> opt_or_default; +% _ -> mandatory +% end, +% CAcc = +% case Type#typedef.name of +% {primitive,bif} -> +% gen_dec_prim(Erules,Def,"Bytes",Tag,"TagIn",no_length, +% ?PRIMITIVE,Prop), +% []; +% {constructed,bif} -> +% emit({" 'dec_",ObjName,'_',FieldName,"'(Bytes,", +% {asis,Prop},", TagIn ++ ",{asis,Tag},")"}), +% [{['dec_',ObjName,'_',FieldName],Def}]; +% {ExtMod,TypeName} -> +% emit({" '",ExtMod,"':'dec_",TypeName,"'(Bytes, ", +% {asis,Prop},", TagIn ++ ",{asis,Tag},")"}), +% []; +% TypeName -> +% emit({" 'dec_",TypeName,"'(Bytes, ",{asis,Prop}, +% ", TagIn ++ ",{asis,Tag},")"}), +% [] +% end, +% case more_genfields(Fields,Rest) of +% true -> +% emit({";",nl}); +% false -> +% emit({".",nl}) +% end, +% CAcc; +% {false,objectfield} -> +% emit({"'dec_",ObjName,"'(",{asis,FieldName}, +% ", Bytes, TagIn, [H|T]) ->",nl}), +% case Type#typedef.name of +% {ExtMod,TypeName} -> +% emit({indent(3),"'",ExtMod,"':'dec_",TypeName, +% "'(H, Bytes, TagIn, T)"}); +% TypeName -> +% emit({indent(3),"'dec_",TypeName, +% "'(H, Bytes, TagIn, T)"}) +% end, +% case more_genfields(Fields,Rest) of +% true -> +% emit({";",nl}); +% false -> +% emit({".",nl}) +% end, +% []; +% {false,_} -> +% [] +% end, +% gen_decode_objectfields(Erules,Class,ObjName,Rest,MaybeConstr ++ ConstrAcc); +% gen_decode_objectfields(Erules,C,O,[H|T],CAcc) -> +% gen_decode_objectfields(Erules,C,O,T,CAcc); +% gen_decode_objectfields(_,_,_,[],CAcc) -> +% CAcc. + +gen_decode_constr_type(Erules,[{Name,Def}|Rest]) -> +%% emit({Name,"(Bytes, OptOrMand) ->",nl}), +%% emit({" ",Name,"(Bytes, OptOrMand, []).",nl,nl}), + emit({Name,"(Bytes, OptOrMand, TagIn) ->",nl}), + InnerType = asn1ct_gen:get_inner(Def#type.def), + asn1ct_gen:gen_decode_constructed(ber,Name,InnerType,Def), + gen_decode_constr_type(Erules,Rest); +gen_decode_constr_type(Erules,[TypeDef|Rest]) when record(TypeDef,typedef) -> + case is_already_generated(dec,TypeDef#typedef.name) of + true -> ok; + _ -> + gen_decode(Erules,TypeDef) + end, + gen_decode_constr_type(Erules,Rest); +gen_decode_constr_type(_,[]) -> + ok. + +gen_decode_field_call(ObjName,FieldName,Bytes,Type) -> + Def = Type#typedef.typespec, + OTag = Def#type.tag, + Tag = [X#tag{class=decode_class(X#tag.class)}|| X <- OTag], + case Type#typedef.name of + {primitive,bif} -> %%tag should be the primitive tag + gen_dec_prim(ber,Def,Bytes,Tag,"TagIn",no_length, + ?PRIMITIVE,opt_or_default), + []; + {constructed,bif} -> + emit({" 'dec_",ObjName,'_',FieldName, + "'(",Bytes,",opt_or_default, TagIn ++ ",{asis,Tag},")"}), + [Type#typedef{name=list_to_atom(lists:concat([ObjName,'_',FieldName]))}]; + {ExtMod,TypeName} -> + emit({" '",ExtMod,"':'dec_",TypeName, + "'(",Bytes,", opt_or_default,TagIn ++ ",{asis,Tag},")"}), + []; + TypeName -> + emit({" 'dec_",TypeName,"'(",Bytes, + ", opt_or_default,TagIn ++ ",{asis,Tag},")"}), + [] + end. + +gen_decode_default_call(ClassName,FieldName,Bytes,Type) -> + CurrentMod = get(currmod), + InnerType = asn1ct_gen:get_inner(Type#type.def), + OTag = Type#type.tag, + Tag = [X#tag{class=decode_class(X#tag.class)}|| X <- OTag], + case asn1ct_gen:type(InnerType) of + {constructed,bif} -> + emit([" 'dec_",ClassName,'_',FieldName,"'(",Bytes, + ",opt_or_default, TagIn ++ ",{asis,Tag},")"]), + [#typedef{name=list_to_atom(lists:concat([ClassName,'_',FieldName])), + typespec=Type}]; + {primitive,bif} -> + gen_dec_prim(ber,Type,Bytes,Tag,"TagIn",no_length, + ?PRIMITIVE,opt_or_default), + []; + #'Externaltypereference'{module=CurrentMod,type=Etype} -> + emit([" 'dec_",Etype,"'(",Bytes, + " ,opt_or_default, TagIn ++ ",{asis,Tag},")",nl]), + []; + #'Externaltypereference'{module=Emod,type=Etype} -> + emit([" '",Emod,"':'dec_",Etype,"'(",Bytes, + ", opt_or_defualt, TagIn ++ ",{asis,Tag},")",nl]), + [] + end. + + +more_genfields([]) -> + false; +more_genfields([Field|Fields]) -> + case element(1,Field) of + typefield -> + true; + objectfield -> + true; + _ -> + more_genfields(Fields) + end. + + + +%% Object Set code generating for encoding and decoding +%% ---------------------------------------------------- +gen_objectset_code(Erules,ObjSet) -> + ObjSetName = ObjSet#typedef.name, + Def = ObjSet#typedef.typespec, +% {ClassName,ClassDef} = Def#'ObjectSet'.class, + #'Externaltypereference'{module=ClassModule, + type=ClassName} = Def#'ObjectSet'.class, + ClassDef = asn1_db:dbget(ClassModule,ClassName), + UniqueFName = Def#'ObjectSet'.uniquefname, + Set = Def#'ObjectSet'.set, + emit({nl,nl,nl,"%%================================"}), + emit({nl,"%% ",ObjSetName}), + emit({nl,"%%================================",nl}), + case ClassName of + {_Module,ExtClassName} -> + gen_objset_code(Erules,ObjSetName,UniqueFName,Set, + ExtClassName,ClassDef); + _ -> + gen_objset_code(Erules,ObjSetName,UniqueFName,Set, + ClassName,ClassDef) + end, + emit(nl). + +gen_objset_code(Erules,ObjSetName,UniqueFName,Set,ClassName,ClassDef)-> + ClassFields = (ClassDef#classdef.typespec)#objectclass.fields, + InternalFuncs=gen_objset_enc(ObjSetName,UniqueFName,Set,ClassName,ClassFields,1,[]), + gen_objset_dec(Erules,ObjSetName,UniqueFName,Set,ClassName,ClassFields,1), + gen_internal_funcs(Erules,InternalFuncs). + +%% gen_objset_enc iterates over the objects of the object set +gen_objset_enc(_,{unique,undefined},_,_,_,_,_) -> + %% There is no unique field in the class of this object set + %% don't bother about the constraint + []; +gen_objset_enc(ObjSName,UniqueName, + [{ObjName,Val,Fields},T|Rest],ClName,ClFields,NthObj,Acc)-> + emit({"'getenc_",ObjSName,"'(",{asis,UniqueName},",",{asis,Val},") ->",nl}), + {InternalFunc,NewNthObj}= + case ObjName of + no_name -> + gen_inlined_enc_funs(Fields,ClFields,ObjSName,NthObj); + _Other -> + emit({" fun 'enc_",ObjName,"'/4"}), + {[],NthObj} + end, + emit({";",nl}), + gen_objset_enc(ObjSName,UniqueName,[T|Rest],ClName,ClFields, + NewNthObj,InternalFunc ++ Acc); +gen_objset_enc(ObjSetName,UniqueName, + [{ObjName,Val,Fields}],_ClName,ClFields,NthObj,Acc) -> + emit({"'getenc_",ObjSetName,"'(",{asis,UniqueName},",",{asis,Val},") ->",nl}), + {InternalFunc,_}= + case ObjName of + no_name -> + gen_inlined_enc_funs(Fields,ClFields,ObjSetName,NthObj); + _Other -> + emit({" fun 'enc_",ObjName,"'/4"}), + {[],NthObj} + end, + emit({".",nl,nl}), + InternalFunc ++ Acc; +%% See X.681 Annex E for the following case +gen_objset_enc(ObjSetName,_UniqueName,['EXTENSIONMARK'], + _ClName,_ClFields,_NthObj,Acc) -> + emit({"'getenc_",ObjSetName,"'(_, _) ->",nl}), + emit({indent(3),"fun(_Attr, Val, _TagIn, _RestPrimFieldName) ->",nl}), + emit({indent(6),"Len = case Val of",nl,indent(9), + "Bin when binary(Bin) -> size(Bin);",nl,indent(9), + "_ -> length(Val)",nl,indent(6),"end,"}), + emit({indent(6),"{Val,Len}",nl}), + emit({indent(3),"end.",nl,nl}), + Acc; +gen_objset_enc(_,_,[],_,_,_,Acc) -> + Acc. + +%% gen_inlined_enc_funs for each object iterates over all fields of a +%% class, and for each typefield it checks if the object has that +%% field and emits the proper code. +gen_inlined_enc_funs(Fields,[{typefield,Name,_}|Rest],ObjSetName, + NthObj) -> + InternalDefFunName = asn1ct_gen:list2name([NthObj,Name,ObjSetName]), + case lists:keysearch(Name,1,Fields) of + {value,{_,Type}} when record(Type,type) -> + emit({indent(3),"fun(Type, Val, TagIn, _RestPrimFieldName) ->",nl, + indent(6),"case Type of",nl}), + {Ret,N} = emit_inner_of_fun(Type,InternalDefFunName), + gen_inlined_enc_funs1(Fields,Rest,ObjSetName,NthObj+N,Ret); + {value,{_,Type}} when record(Type,typedef) -> + emit({indent(3),"fun(Type, Val, TagIn, _RestPrimFieldName) ->",nl, + indent(6),"case Type of",nl}), + emit({indent(9),{asis,Name}," ->",nl}), + {Ret,N} = emit_inner_of_fun(Type,InternalDefFunName), + gen_inlined_enc_funs1(Fields,Rest,ObjSetName,NthObj+N,Ret); + false -> + gen_inlined_enc_funs(Fields,Rest,ObjSetName,NthObj) + end; +gen_inlined_enc_funs(Fields,[_H|Rest],ObjSetName,NthObj) -> + gen_inlined_enc_funs(Fields,Rest,ObjSetName,NthObj); +gen_inlined_enc_funs(_,[],_,NthObj) -> + {[],NthObj}. + +gen_inlined_enc_funs1(Fields,[{typefield,Name,_}|Rest],ObjSetName, + NthObj,Acc) -> + InternalDefFunName = asn1ct_gen:list2name([NthObj,Name,ObjSetName]), + {Acc2,NAdd}= + case lists:keysearch(Name,1,Fields) of + {value,{_,Type}} when record(Type,type) -> + emit({";",nl}), + {Ret,N}=emit_inner_of_fun(Type,InternalDefFunName), + {Ret++Acc,N}; + {value,{_,Type}} when record(Type,typedef) -> + emit({";",nl,indent(9),{asis,Name}," ->",nl}), + {Ret,N}=emit_inner_of_fun(Type,InternalDefFunName), + {Ret++Acc,N}; + false -> + {Acc,0} + end, + gen_inlined_enc_funs1(Fields,Rest,ObjSetName,NthObj+NAdd,Acc2); +gen_inlined_enc_funs1(Fields,[_H|Rest],ObjSetName,NthObj,Acc)-> + gen_inlined_enc_funs1(Fields,Rest,ObjSetName,NthObj,Acc); +gen_inlined_enc_funs1(_,[],_,NthObj,Acc) -> + emit({nl,indent(6),"end",nl}), + emit({indent(3),"end"}), + {Acc,NthObj}. + + +emit_inner_of_fun(TDef = #typedef{name={ExtMod,Name},typespec=Type}, + InternalDefFunName) -> + OTag = Type#type.tag, + Tag = [X#tag{class=decode_class(X#tag.class)}|| X <- OTag], + case {ExtMod,Name} of + {primitive,bif} -> + emit(indent(12)), + gen_encode_prim(ber,Type,["TagIn ++ ",{asis,Tag}],"Val"), + {[],0}; + {constructed,bif} -> + emit([indent(12),"'enc_", + InternalDefFunName,"'(Val,TagIn ++ ", + {asis,Tag},")"]), + {[TDef#typedef{name=InternalDefFunName}],1}; + _ -> + emit({indent(12),"'",ExtMod,"':'enc_",Name,"'(Val, TagIn ++ ", + {asis,Tag},")"}), + {[],0} + end; +emit_inner_of_fun(#typedef{name=Name,typespec=Type},_) -> + OTag = Type#type.tag, + Tag = [X#tag{class=decode_class(X#tag.class)}|| X <- OTag], + emit({indent(12),"'enc_",Name,"'(Val, TagIn ++ ",{asis,Tag},")"}), + {[],0}; +emit_inner_of_fun(Type,_) when record(Type,type) -> + CurrMod = get(currmod), + OTag = Type#type.tag, + Tag = [X#tag{class=decode_class(X#tag.class)}|| X <- OTag], + case Type#type.def of + Def when atom(Def) -> + emit({indent(9),Def," ->",nl,indent(12)}), + gen_encode_prim(ber,Type,["TagIn ++ ",{asis,Tag}],"Val"); + TRef when record(TRef,typereference) -> + T = TRef#typereference.val, + emit({indent(9),T," ->",nl,indent(12),"'enc_",T, + "'(Val, TagIn ++ ",{asis,Tag},")"}); + #'Externaltypereference'{module=CurrMod,type=T} -> + emit({indent(9),T," ->",nl,indent(12),"'enc_",T, + "'(Val, TagIn ++ ",{asis,Tag},")"}); + #'Externaltypereference'{module=ExtMod,type=T} -> + emit({indent(9),T," ->",nl,indent(12),ExtMod,":'enc_", + T,"'(Val, TagIn ++ ",{asis,Tag},")"}) + end, + {[],0}. + +indent(N) -> + lists:duplicate(N,32). % 32 = space + + +gen_objset_dec(_,_,{unique,undefined},_,_,_,_) -> + %% There is no unique field in the class of this object set + %% don't bother about the constraint + ok; +gen_objset_dec(Erules,ObjSName,UniqueName,[{ObjName,Val,Fields},T|Rest], + ClName,ClFields,NthObj)-> + emit({"'getdec_",ObjSName,"'(",{asis,UniqueName},",",{asis,Val}, + ") ->",nl}), + NewNthObj= + case ObjName of + no_name -> + gen_inlined_dec_funs(Erules,Fields,ClFields,ObjSName, + NthObj); + _Other -> + emit({" fun 'dec_",ObjName,"'/4"}), + NthObj + end, + emit({";",nl}), + gen_objset_dec(Erules,ObjSName,UniqueName,[T|Rest],ClName,ClFields, + NewNthObj); +gen_objset_dec(Erules,ObjSetName,UniqueName,[{ObjName,Val,Fields}],_ClName, + ClFields,NthObj) -> + emit({"'getdec_",ObjSetName,"'(",{asis,UniqueName},",",{asis,Val},") ->",nl}), + case ObjName of + no_name -> + gen_inlined_dec_funs(Erules,Fields,ClFields,ObjSetName, + NthObj); + _Other -> + emit({" fun 'dec_",ObjName,"'/4"}) + end, + emit({".",nl,nl}); +gen_objset_dec(_,ObjSetName,_UniqueName,['EXTENSIONMARK'],_ClName,_ClFields, + _NthObj) -> + emit({"'getdec_",ObjSetName,"'(_, _) ->",nl}), + emit({indent(3),"fun(_, Bytes, _, _) ->",nl}), + emit({indent(6),"Len = case Bytes of",nl,indent(9), + "Bin when binary(Bin) -> size(Bin);",nl,indent(9), + "_ -> length(Bytes)",nl,indent(6),"end,"}), + emit({indent(6),"{Bytes,[],Len}",nl}), + emit({indent(3),"end.",nl,nl}), + ok; +gen_objset_dec(_,_,_,[],_,_,_) -> + ok. + +gen_inlined_dec_funs(Erules,Fields,[{typefield,Name,Prop}|Rest], + ObjSetName,NthObj) -> + DecProp = case Prop of + 'OPTIONAL' -> opt_or_default; + {'DEFAULT',_} -> opt_or_default; + _ -> mandatory + end, + InternalDefFunName = [NthObj,Name,ObjSetName], + case lists:keysearch(Name,1,Fields) of + {value,{_,Type}} when record(Type,type) -> + emit({indent(3),"fun(Type, Bytes, TagIn, _RestPrimFieldName) ->", + nl,indent(6),"case Type of",nl}), + N=emit_inner_of_decfun(Erules,Type,DecProp,InternalDefFunName), + gen_inlined_dec_funs1(Erules,Fields,Rest,ObjSetName,NthObj+N); + {value,{_,Type}} when record(Type,typedef) -> + emit({indent(3),"fun(Type, Bytes, TagIn, _RestPrimFieldName) ->", + nl,indent(6),"case Type of",nl}), + emit({indent(9),{asis,Name}," ->",nl}), + N=emit_inner_of_decfun(Erules,Type,DecProp,InternalDefFunName), + gen_inlined_dec_funs1(Erules,Fields,Rest,ObjSetName,NthObj+N); + false -> + gen_inlined_dec_funs(Erules,Fields,Rest,ObjSetName,NthObj) + end; +gen_inlined_dec_funs(Erules,Fields,[_H|Rest],ObjSetName,NthObj) -> + gen_inlined_dec_funs(Erules,Fields,Rest,ObjSetName,NthObj); +gen_inlined_dec_funs(_,_,[],_,NthObj) -> + NthObj. + +gen_inlined_dec_funs1(Erules,Fields,[{typefield,Name,Prop}|Rest], + ObjSetName,NthObj) -> + DecProp = case Prop of + 'OPTIONAL' -> opt_or_default; + {'DEFAULT',_} -> opt_or_default; + _ -> mandatory + end, + InternalDefFunName = [NthObj,Name,ObjSetName], + N= + case lists:keysearch(Name,1,Fields) of + {value,{_,Type}} when record(Type,type) -> + emit({";",nl}), + emit_inner_of_decfun(Erules,Type,DecProp,InternalDefFunName); + {value,{_,Type}} when record(Type,typedef) -> + emit({";",nl,indent(9),{asis,Name}," ->",nl}), + emit_inner_of_decfun(Erules,Type,DecProp,InternalDefFunName); + false -> + 0 + end, + gen_inlined_dec_funs1(Erules,Fields,Rest,ObjSetName,NthObj+N); +gen_inlined_dec_funs1(Erules,Fields,[_H|Rest],ObjSetName,NthObj)-> + gen_inlined_dec_funs1(Erules,Fields,Rest,ObjSetName,NthObj); +gen_inlined_dec_funs1(_,_,[],_,NthObj) -> + emit({nl,indent(6),"end",nl}), + emit({indent(3),"end"}), + NthObj. + +emit_inner_of_decfun(Erules,#typedef{name={ExtName,Name},typespec=Type}, + Prop,InternalDefFunName) -> + OTag = Type#type.tag, + Tag = [X#tag{class=decode_class(X#tag.class)}|| X <- OTag], + case {ExtName,Name} of + {primitive,bif} -> + emit(indent(12)), + gen_dec_prim(Erules,Type,"Bytes",Tag,"TagIn",no_length, + ?PRIMITIVE,Prop), + 0; + {constructed,bif} -> + emit({indent(12),"'dec_", + asn1ct_gen:list2name(InternalDefFunName),"'(Bytes, ",Prop, + ", TagIn ++ ",{asis,Tag},")"}), + 1; + _ -> + emit({indent(12),"'",ExtName,"':'dec_",Name,"'(Bytes, ",Prop, + ", TagIn ++ ",{asis,Tag},")"}), + 0 + end; +emit_inner_of_decfun(_,#typedef{name=Name,typespec=Type},Prop,_) -> + OTag = Type#type.tag, + Tag = [X#tag{class=decode_class(X#tag.class)}|| X <- OTag], + emit({indent(12),"'dec_",Name,"'(Bytes, ",Prop,", TagIn ++ ", + {asis,Tag},")"}), + 0; +emit_inner_of_decfun(Erules,Type,Prop,_) when record(Type,type) -> + OTag = Type#type.tag, + Tag = [X#tag{class=decode_class(X#tag.class)}|| X <- OTag], + CurrMod = get(currmod), + Def = Type#type.def, + InnerType = asn1ct_gen:get_inner(Def), + WhatKind = asn1ct_gen:type(InnerType), + case WhatKind of + {primitive,bif} -> + emit({indent(9),Def," ->",nl,indent(12)}), + gen_dec_prim(Erules,Type,"Bytes",Tag,"TagIn",no_length, + ?PRIMITIVE,Prop); +% TRef when record(TRef,typereference) -> +% T = TRef#typereference.val, +% emit({indent(9),T," ->",nl,indent(12),"'dec_",T,"'(Val)"}); + #'Externaltypereference'{module=CurrMod,type=T} -> + emit({indent(9),T," ->",nl,indent(12),"'dec_",T, + "'(Bytes, ",Prop,", TagIn ++ ",{asis,Tag},")"}); + #'Externaltypereference'{module=ExtMod,type=T} -> + emit({indent(9),T," ->",nl,indent(12),ExtMod,":'dec_", + T,"'(Bytes, ",Prop,", TagIn ++ ",{asis,Tag},")"}) + end, + 0. + + +gen_internal_funcs(_,[]) -> + ok; +gen_internal_funcs(Erules,[TypeDef|Rest]) -> + gen_encode_user(Erules,TypeDef), + emit({"'dec_",TypeDef#typedef.name,"'(Bytes, ", + unused_optormand_var("OptOrMand",(TypeDef#typedef.typespec)#type.def),", TagIn) ->",nl}), + gen_decode_user(Erules,TypeDef), + gen_internal_funcs(Erules,Rest). + + +dbdec(Type) -> + demit({"io:format(\"decoding: ",{asis,Type},"~w~n\",[Bytes]),",nl}). + + +decode_class('UNIVERSAL') -> + ?UNIVERSAL; +decode_class('APPLICATION') -> + ?APPLICATION; +decode_class('CONTEXT') -> + ?CONTEXT; +decode_class('PRIVATE') -> + ?PRIVATE. + +decode_type('BOOLEAN') -> 1; +decode_type('INTEGER') -> 2; +decode_type('BIT STRING') -> 3; +decode_type('OCTET STRING') -> 4; +decode_type('NULL') -> 5; +decode_type('OBJECT IDENTIFIER') -> 6; +decode_type('OBJECT DESCRIPTOR') -> 7; +decode_type('EXTERNAL') -> 8; +decode_type('REAL') -> 9; +decode_type('ENUMERATED') -> 10; +decode_type('EMBEDDED_PDV') -> 11; +decode_type('SEQUENCE') -> 16; +decode_type('SEQUENCE OF') -> 16; +decode_type('SET') -> 17; +decode_type('SET OF') -> 17; +decode_type('NumericString') -> 18; +decode_type('PrintableString') -> 19; +decode_type('TeletexString') -> 20; +decode_type('VideotexString') -> 21; +decode_type('IA5String') -> 22; +decode_type('UTCTime') -> 23; +decode_type('GeneralizedTime') -> 24; +decode_type('GraphicString') -> 25; +decode_type('VisibleString') -> 26; +decode_type('GeneralString') -> 27; +decode_type('UniversalString') -> 28; +decode_type('BMPString') -> 30; +decode_type('CHOICE') -> 'CHOICE'; % choice gets the tag from the actual alternative +decode_type(Else) -> exit({error,{asn1,{unrecognized_type,Else}}}). + +add_removed_bytes() -> + asn1ct_name:delete(rb), + add_removed_bytes(asn1ct_name:all(rb)). + +add_removed_bytes([H,T1|T]) -> + emit({{var,H},"+"}), + add_removed_bytes([T1|T]); +add_removed_bytes([H|T]) -> + emit({{var,H}}), + add_removed_bytes(T); +add_removed_bytes([]) -> + true. + +mkfuncname(WhatKind,DecOrEnc) -> + case WhatKind of + #'Externaltypereference'{module=Mod,type=EType} -> + CurrMod = get(currmod), + case CurrMod of + Mod -> + lists:concat(["'",DecOrEnc,"_",EType,"'"]); + _ -> +% io:format("CurrMod: ~p, Mod: ~p~n",[CurrMod,Mod]), + lists:concat(["'",Mod,"':'",DecOrEnc,"_",EType,"'"]) + end; + #'typereference'{val=EType} -> + lists:concat(["'",DecOrEnc,"_",EType,"'"]); + 'ASN1_OPEN_TYPE' -> + lists:concat(["'",DecOrEnc,"_",WhatKind,"'"]) + + end. + +optionals(L) -> optionals(L,[],1). + +optionals([{'EXTENSIONMARK',_,_}|Rest],Acc,Pos) -> + optionals(Rest,Acc,Pos); % optionals in extension are currently not handled +optionals([#'ComponentType'{name=Name,prop='OPTIONAL'}|Rest],Acc,Pos) -> + optionals(Rest,[{Name,Pos}|Acc],Pos+1); +optionals([#'ComponentType'{name=Name,prop={'DEFAULT',_}}|Rest],Acc,Pos) -> + optionals(Rest,[{Name,Pos}|Acc],Pos+1); +optionals([#'ComponentType'{}|Rest],Acc,Pos) -> + optionals(Rest,Acc,Pos+1); +optionals([],Acc,_) -> + lists:reverse(Acc). + +get_constraint(C,Key) -> + case lists:keysearch(Key,1,C) of + false -> + no; + {value,{_,V}} -> + V + end. + +%% if the original option was ber and it has been wrapped to ber_bin +%% turn it back to ber +re_wrap_erule(ber_bin) -> + case get(encoding_options) of + Options when list(Options) -> + case lists:member(ber,Options) of + true -> ber; + _ -> ber_bin + end; + _ -> ber_bin + end; +re_wrap_erule(Erule) -> + Erule. + +is_already_generated(Operation,Name) -> + case get(class_default_type) of + undefined -> + put(class_default_type,[{Operation,Name}]), + false; + GeneratedList -> + case lists:member({Operation,Name},GeneratedList) of + true -> + true; + false -> + put(class_default_type,[{Operation,Name}|GeneratedList]), + false + end + end. + +get_class_fields(#classdef{typespec=ObjClass}) -> + ObjClass#objectclass.fields; +get_class_fields(#objectclass{fields=Fields}) -> + Fields; +get_class_fields(_) -> + []. + +get_object_field(Name,ObjectFields) -> + case lists:keysearch(Name,1,ObjectFields) of + {value,Field} -> Field; + false -> false + end. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_gen_ber_bin_v2.erl b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_gen_ber_bin_v2.erl new file mode 100644 index 0000000000..89530d4017 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_gen_ber_bin_v2.erl @@ -0,0 +1,1562 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: asn1ct_gen_ber_bin_v2.erl,v 1.1 2008/12/17 09:53:29 mikpe Exp $ +%% +-module(asn1ct_gen_ber_bin_v2). + +%% Generate erlang module which handles (PER) encode and decode for +%% all types in an ASN.1 module + +-include("asn1_records.hrl"). + +-export([pgen/4]). +-export([decode_class/1, decode_type/1]). +-export([add_removed_bytes/0]). +-export([gen_encode/2,gen_encode/3,gen_decode/2,gen_decode/3]). +-export([gen_encode_prim/4]). +-export([gen_dec_prim/7]). +-export([gen_objectset_code/2, gen_obj_code/3]). +-export([encode_tag_val/3]). +-export([gen_inc_decode/2]). + +-import(asn1ct_gen, [emit/1,demit/1]). + + % the encoding of class of tag bits 8 and 7 +-define(UNIVERSAL, 0). +-define(APPLICATION, 16#40). +-define(CONTEXT, 16#80). +-define(PRIVATE, 16#C0). + + % primitive or constructed encoding % bit 6 +-define(PRIMITIVE, 0). +-define(CONSTRUCTED, 2#00100000). + + +-define(T_ObjectDescriptor, ?UNIVERSAL bor ?PRIMITIVE bor 7). + % restricted character string types +-define(T_NumericString, ?UNIVERSAL bor ?PRIMITIVE bor 18). %can be constructed +-define(T_PrintableString, ?UNIVERSAL bor ?PRIMITIVE bor 19). %can be constructed +-define(T_TeletexString, ?UNIVERSAL bor ?PRIMITIVE bor 20). %can be constructed +-define(T_VideotexString, ?UNIVERSAL bor ?PRIMITIVE bor 21). %can be constructed +-define(T_IA5String, ?UNIVERSAL bor ?PRIMITIVE bor 22). %can be constructed +-define(T_GraphicString, ?UNIVERSAL bor ?PRIMITIVE bor 25). %can be constructed +-define(T_VisibleString, ?UNIVERSAL bor ?PRIMITIVE bor 26). %can be constructed +-define(T_GeneralString, ?UNIVERSAL bor ?PRIMITIVE bor 27). %can be constructed + +%% pgen(Erules, Module, TypeOrVal) +%% Generate Erlang module (.erl) and (.hrl) file corresponding to an ASN.1 module +%% .hrl file is only generated if necessary +%% Erules = per | ber +%% Module = atom() +%% TypeOrVal = {TypeList,ValueList,PTypeList} +%% TypeList = ValueList = [atom()] + +pgen(OutFile,Erules,Module,TypeOrVal) -> + asn1ct_gen:pgen_module(OutFile,Erules,Module,TypeOrVal,true). + + +%%=============================================================================== +%%=============================================================================== +%%=============================================================================== +%% Generate ENCODING +%%=============================================================================== +%%=============================================================================== +%%=============================================================================== + +%%=============================================================================== +%% encode #{typedef, {pos, name, typespec}} +%%=============================================================================== + +gen_encode(Erules,Type) when record(Type,typedef) -> + gen_encode_user(Erules,Type). + +%%=============================================================================== +%% encode #{type, {tag, def, constraint}} +%%=============================================================================== + +gen_encode(Erules,Typename,Type) when record(Type,type) -> + InnerType = asn1ct_gen:get_inner(Type#type.def), + ObjFun = + case lists:keysearch(objfun,1,Type#type.tablecinf) of + {value,{_,_Name}} -> + ", ObjFun"; + false -> + "" + end, + + case asn1ct_gen:type(InnerType) of + {constructed,bif} -> + emit([nl,nl,nl,"%%================================"]), + emit([nl,"%% ",asn1ct_gen:list2name(Typename)]), + emit([nl,"%%================================",nl]), + case length(Typename) of + 1 -> % top level type + emit(["'enc_",asn1ct_gen:list2name(Typename), + "'(Val",ObjFun,") ->",nl]), + emit([" 'enc_",asn1ct_gen:list2name(Typename), + "'(Val, ", {asis,lists:reverse(Type#type.tag)},ObjFun,").",nl,nl]); + _ -> % embedded type with constructed name + true + end, + case lists:member(InnerType,['SET','SEQUENCE']) of + true -> + case get(asn_keyed_list) of + true -> + CompList = + case Type#type.def of + #'SEQUENCE'{components=Cl} -> Cl; + #'SET'{components=Cl} -> Cl + end, + emit([nl,"'enc_",asn1ct_gen:list2name(Typename), + "'(Val, TagIn",ObjFun, + ") when list(Val) ->",nl]), + emit([" 'enc_",asn1ct_gen:list2name(Typename), + "'(?RT_BER:fixoptionals(", + {asis,optionals(CompList)}, + ",Val), TagIn",ObjFun,");",nl,nl]); + _ -> true + end; + _ -> + emit([nl,"'enc_",asn1ct_gen:list2name(Typename), + "'({'",asn1ct_gen:list2name(Typename), + "',Val}, TagIn",ObjFun,") ->",nl]), + emit([" 'enc_",asn1ct_gen:list2name(Typename), + "'(Val, TagIn",ObjFun,");",nl,nl]) + end, + emit(["'enc_",asn1ct_gen:list2name(Typename), + "'(Val, TagIn",ObjFun,") ->",nl," "]), + asn1ct_gen:gen_encode_constructed(Erules,Typename,InnerType,Type); + _ -> + true + end; + +%%=============================================================================== +%% encode ComponentType +%%=============================================================================== + +gen_encode(Erules,Tname,{'ComponentType',_Pos,Cname,Type,_Prop,_Tags}) -> + NewTname = [Cname|Tname], + %% The tag is set to [] to avoid that it is + %% taken into account twice, both as a component/alternative (passed as + %% argument to the encode decode function and within the encode decode + %% function it self. + NewType = Type#type{tag=[]}, + gen_encode(Erules,NewTname,NewType). + +gen_encode_user(Erules,D) when record(D,typedef) -> + Typename = [D#typedef.name], + Type = D#typedef.typespec, + InnerType = asn1ct_gen:get_inner(Type#type.def), + OTag = Type#type.tag, + Tag = [encode_tag_val(decode_class(X#tag.class),X#tag.form,X#tag.number)|| X <- OTag], + emit([nl,nl,"%%================================"]), + emit([nl,"%% ",Typename]), + emit([nl,"%%================================",nl]), + emit(["'enc_",asn1ct_gen:list2name(Typename), + "'(Val",") ->",nl]), + emit([" 'enc_",asn1ct_gen:list2name(Typename), + "'(Val, ", {asis,lists:reverse(Tag)},").",nl,nl]), + + case lists:member(InnerType,['SET','SEQUENCE']) of + true -> + case get(asn_keyed_list) of + true -> + CompList = + case Type#type.def of + #'SEQUENCE'{components=Cl} -> Cl; + #'SET'{components=Cl} -> Cl + end, + + emit([nl,"'enc_",asn1ct_gen:list2name(Typename), + "'(Val, TagIn) when list(Val) ->",nl]), + emit([" 'enc_",asn1ct_gen:list2name(Typename), + "'(?RT_BER:fixoptionals(", + {asis,optionals(CompList)}, + ",Val), TagIn);",nl,nl]); + _ -> true + end; + _ -> + emit({nl,"'enc_",asn1ct_gen:list2name(Typename), + "'({'",asn1ct_gen:list2name(Typename),"',Val}, TagIn) ->",nl}), + emit({" 'enc_",asn1ct_gen:list2name(Typename),"'(Val, TagIn);",nl,nl}) + end, + emit({"'enc_",asn1ct_gen:list2name(Typename),"'(Val, TagIn) ->",nl}), + CurrentMod = get(currmod), + case asn1ct_gen:type(InnerType) of + {constructed,bif} -> + asn1ct_gen:gen_encode_constructed(Erules,Typename,InnerType,D); + {primitive,bif} -> + gen_encode_prim(ber,Type,"TagIn","Val"), + emit([".",nl]); + #typereference{val=Ename} -> + emit([" 'enc_",Ename,"'(Val, TagIn).",nl]); + #'Externaltypereference'{module=CurrentMod,type=Etype} -> + emit([" 'enc_",Etype,"'(Val, TagIn).",nl]); + #'Externaltypereference'{module=Emod,type=Etype} -> + emit([" '",Emod,"':'enc_",Etype,"'(Val, TagIn).",nl]); + 'ASN1_OPEN_TYPE' -> + emit(["%% OPEN TYPE",nl]), + gen_encode_prim(ber, + Type#type{def='ASN1_OPEN_TYPE'}, + "TagIn","Val"), + emit([".",nl]) + end. + +gen_encode_prim(_Erules,D,DoTag,Value) when record(D,type) -> + +%%% Constraint is currently not used for BER (except for BitString) and therefore replaced +%%% with [] as a placeholder + BitStringConstraint = D#type.constraint, + Constraint = [], + asn1ct_name:new(enumval), + case D#type.def of + 'BOOLEAN' -> + emit_encode_func('boolean',Value,DoTag); + 'INTEGER' -> + emit_encode_func('integer',Constraint,Value,DoTag); + {'INTEGER',NamedNumberList} -> + emit_encode_func('integer',Constraint,Value, + NamedNumberList,DoTag); + {'ENUMERATED',NamedNumberList={_,_}} -> + + emit(["case (case ",Value," of {asn1_enum,_}->",Value,";{_,_}->element(2,",Value,");_->", + Value," end) of",nl]), + emit_enc_enumerated_cases(NamedNumberList,DoTag); + {'ENUMERATED',NamedNumberList} -> + + emit(["case (case ",Value," of {_,_}->element(2,",Value,");_->", + Value," end) of",nl]), + emit_enc_enumerated_cases(NamedNumberList,DoTag); + + {'BIT STRING',NamedNumberList} -> + emit_encode_func('bit_string',BitStringConstraint,Value, + NamedNumberList,DoTag); + 'ANY' -> + emit_encode_func('open_type', Value,DoTag); + 'NULL' -> + emit_encode_func('null',Value,DoTag); + 'OBJECT IDENTIFIER' -> + emit_encode_func("object_identifier",Value,DoTag); + 'ObjectDescriptor' -> + emit_encode_func('restricted_string',Constraint,Value, + ?T_ObjectDescriptor,DoTag); + 'OCTET STRING' -> + emit_encode_func('octet_string',Constraint,Value,DoTag); + 'NumericString' -> + emit_encode_func('restricted_string',Constraint,Value, + ?T_NumericString,DoTag); + 'TeletexString' -> + emit_encode_func('restricted_string',Constraint,Value, + ?T_TeletexString,DoTag); + 'VideotexString' -> + emit_encode_func('restricted_string',Constraint,Value, + ?T_VideotexString,DoTag); + 'GraphicString' -> + emit_encode_func('restricted_string',Constraint,Value, + ?T_GraphicString,DoTag); + 'VisibleString' -> + emit_encode_func('restricted_string',Constraint,Value, + ?T_VisibleString,DoTag); + 'GeneralString' -> + emit_encode_func('restricted_string',Constraint,Value, + ?T_GeneralString,DoTag); + 'PrintableString' -> + emit_encode_func('restricted_string',Constraint,Value, + ?T_PrintableString,DoTag); + 'IA5String' -> + emit_encode_func('restricted_string',Constraint,Value, + ?T_IA5String,DoTag); + 'UniversalString' -> + emit_encode_func('universal_string',Constraint,Value,DoTag); + 'BMPString' -> + emit_encode_func('BMP_string',Constraint,Value,DoTag); + 'UTCTime' -> + emit_encode_func('utc_time',Constraint,Value,DoTag); + 'GeneralizedTime' -> + emit_encode_func('generalized_time',Constraint,Value,DoTag); + 'ASN1_OPEN_TYPE' -> + emit_encode_func('open_type', Value,DoTag); + XX -> + exit({'can not encode' ,XX}) + end. + + +emit_encode_func(Name,Value,Tags) when atom(Name) -> + emit_encode_func(atom_to_list(Name),Value,Tags); +emit_encode_func(Name,Value,Tags) -> + Fname = "?RT_BER:encode_" ++ Name, + emit([Fname,"(",Value,", ",Tags,")"]). + +emit_encode_func(Name,Constraint,Value,Tags) when atom(Name) -> + emit_encode_func(atom_to_list(Name),Constraint,Value,Tags); +emit_encode_func(Name,Constraint,Value,Tags) -> + Fname = "?RT_BER:encode_" ++ Name, + emit([Fname,"(",{asis,Constraint},", ",Value,", ",Tags,")"]). + +emit_encode_func(Name,Constraint,Value,Asis,Tags) when atom(Name) -> + emit_encode_func(atom_to_list(Name),Constraint,Value,Asis,Tags); +emit_encode_func(Name,Constraint,Value,Asis,Tags) -> + Fname = "?RT_BER:encode_" ++ Name, + emit([Fname,"(",{asis,Constraint},", ",Value, + ", ",{asis,Asis}, + ", ",Tags,")"]). + +emit_enc_enumerated_cases({L1,L2}, Tags) -> + emit_enc_enumerated_cases(L1++L2, Tags, ext); +emit_enc_enumerated_cases(L, Tags) -> + emit_enc_enumerated_cases(L, Tags, noext). + +emit_enc_enumerated_cases([{EnumName,EnumVal},H2|T], Tags, Ext) -> + emit([{asis,EnumName}," -> ?RT_BER:encode_enumerated(",EnumVal,",",Tags,");",nl]), +%% emit(["'",{asis,EnumName},"' -> ?RT_BER:encode_enumerated(",EnumVal,",",Tags,");",nl]), + emit_enc_enumerated_cases([H2|T], Tags, Ext); +emit_enc_enumerated_cases([{EnumName,EnumVal}], Tags, Ext) -> + emit([{asis,EnumName}," -> ?RT_BER:encode_enumerated(",EnumVal,",",Tags,")"]), +%% emit(["'",{asis,EnumName},"' -> ?RT_BER:encode_enumerated(",EnumVal,",",Tags,")"]), + case Ext of + noext -> emit([";",nl]); + ext -> + emit([";",nl,"{asn1_enum,",{curr,enumval},"} -> ", + "?RT_BER:encode_enumerated(",{curr,enumval},",",Tags,");",nl]), + asn1ct_name:new(enumval) + end, + emit([{curr,enumval}," -> exit({error,{asn1, {enumerated_not_in_range,",{curr, enumval},"}}})"]), + emit([nl,"end"]). + + +%%=============================================================================== +%%=============================================================================== +%%=============================================================================== +%% Generate DECODING +%%=============================================================================== +%%=============================================================================== +%%=============================================================================== + +%%=============================================================================== +%% decode #{typedef, {pos, name, typespec}} +%%=============================================================================== + +gen_decode(Erules,Type) when record(Type,typedef) -> + Def = Type#typedef.typespec, + InnerTag = Def#type.tag , + + Tag = [(decode_class(X#tag.class) bsl 10) + X#tag.number || X <- InnerTag], + + Prefix = + case {asn1ct:get_gen_state_field(active), + asn1ct:get_gen_state_field(prefix)} of + {true,Pref} -> Pref; + _ -> "dec_" + end, + emit({nl,nl}), + emit(["'",Prefix,Type#typedef.name,"'(Tlv) ->",nl]), + emit([" '",Prefix,Type#typedef.name,"'(Tlv, ",{asis,Tag},").",nl,nl]), + emit(["'",Prefix,Type#typedef.name,"'(Tlv, TagIn) ->",nl]), + dbdec(Type#typedef.name), + gen_decode_user(Erules,Type). + +gen_inc_decode(Erules,Type) when record(Type,typedef) -> + Prefix = asn1ct:get_gen_state_field(prefix), + emit({nl,nl}), + emit(["'",Prefix,Type#typedef.name,"'(Tlv, TagIn) ->",nl]), + gen_decode_user(Erules,Type). + +%%=============================================================================== +%% decode #{type, {tag, def, constraint}} +%%=============================================================================== + +%% This gen_decode is called by the gen_decode/3 that decodes +%% ComponentType and the type of a SEQUENCE OF/SET OF. +gen_decode(Erules,Tname,Type) when record(Type,type) -> + Typename = Tname, + InnerType = asn1ct_gen:get_inner(Type#type.def), + Prefix = + case asn1ct:get_gen_state_field(active) of + true -> "'dec-inc-"; + _ -> "'dec_" + end, + case asn1ct_gen:type(InnerType) of + {constructed,bif} -> + ObjFun = + case Type#type.tablecinf of + [{objfun,_}|_R] -> + ", ObjFun"; + _ -> + "" + end, + emit([Prefix,asn1ct_gen:list2name(Typename),"'(Tlv, TagIn",ObjFun,") ->",nl]), + dbdec(Typename), + asn1ct_gen:gen_decode_constructed(Erules,Typename,InnerType,Type); + Rec when record(Rec,'Externaltypereference') -> + case {Typename,asn1ct:get_gen_state_field(namelist)} of + {[Cname|_],[{Cname,_}|_]} -> %% + %% This referenced type must only be generated + %% once as incomplete partial decode. Therefore we + %% have to check whether this function already is + %% generated. + case asn1ct:is_function_generated(Typename) of + true -> + ok; + _ -> + asn1ct:generated_refed_func(Typename), + #'Externaltypereference'{module=M,type=Name}=Rec, + TypeDef = asn1_db:dbget(M,Name), + gen_decode(Erules,TypeDef) + end; + _ -> + true + end; + _ -> + true + end; + + +%%=============================================================================== +%% decode ComponentType +%%=============================================================================== + +gen_decode(Erules,Tname,{'ComponentType',_Pos,Cname,Type,_Prop,_Tags}) -> + NewTname = [Cname|Tname], + %% The tag is set to [] to avoid that it is + %% taken into account twice, both as a component/alternative (passed as + %% argument to the encode decode function and within the encode decode + %% function it self. + NewType = Type#type{tag=[]}, + case {asn1ct:get_gen_state_field(active), + asn1ct:get_tobe_refed_func(NewTname)} of + {true,{_,NameList}} -> + asn1ct:update_gen_state(namelist,NameList), + %% remove to gen_refed_funcs list from tobe_refed_funcs later + gen_decode(Erules,NewTname,NewType); + {No,_} when No == false; No == undefined -> + gen_decode(Erules,NewTname,NewType); + _ -> + ok + end. + + +gen_decode_user(Erules,D) when record(D,typedef) -> + Typename = [D#typedef.name], + Def = D#typedef.typespec, + InnerType = asn1ct_gen:get_inner(Def#type.def), + BytesVar = "Tlv", + case asn1ct_gen:type(InnerType) of + 'ASN1_OPEN_TYPE' -> + asn1ct_name:new(len), + gen_dec_prim(ber, Def#type{def='ASN1_OPEN_TYPE'}, + BytesVar,{string,"TagIn"}, [] , + ?PRIMITIVE,"OptOrMand"), + emit({".",nl,nl}); + {primitive,bif} -> + asn1ct_name:new(len), + gen_dec_prim(ber, Def, BytesVar,{string,"TagIn"},[] , + ?PRIMITIVE,"OptOrMand"), + emit([".",nl,nl]); + {constructed,bif} -> + asn1ct:update_namelist(D#typedef.name), + asn1ct_gen:gen_decode_constructed(Erules,Typename,InnerType,D); + TheType -> + DecFunName = mkfuncname(TheType,dec), + emit([DecFunName,"(",BytesVar, + ", TagIn)"]), + emit([".",nl,nl]) + end. + + +gen_dec_prim(_Erules,Att,BytesVar,DoTag,_TagIn,_Form,_OptOrMand) -> + Typename = Att#type.def, +%% Currently not used for BER replaced with [] as place holder +%% Constraint = Att#type.constraint, +%% Constraint = [], + Constraint = + case get_constraint(Att#type.constraint,'SizeConstraint') of + no -> []; + Tc -> Tc + end, + ValueRange = + case get_constraint(Att#type.constraint,'ValueRange') of + no -> []; + Tv -> Tv + end, + SingleValue = + case get_constraint(Att#type.constraint,'SingleValue') of + no -> []; + Sv -> Sv + end, + AsBin = case get(binary_strings) of + true -> "_as_bin"; + _ -> "" + end, + NewTypeName = case Typename of + 'ANY' -> 'ASN1_OPEN_TYPE'; + _ -> Typename + end, +% DoLength = + case NewTypeName of + 'BOOLEAN'-> + emit({"?RT_BER:decode_boolean(",BytesVar,","}), + add_func({decode_boolean,2}); + 'INTEGER' -> + emit({"?RT_BER:decode_integer(",BytesVar,",", + {asis,int_constr(SingleValue,ValueRange)},","}), + add_func({decode_integer,3}); + {'INTEGER',NamedNumberList} -> + emit({"?RT_BER:decode_integer(",BytesVar,",", + {asis,int_constr(SingleValue,ValueRange)},",", + {asis,NamedNumberList},","}), + add_func({decode_integer,4}); + {'ENUMERATED',NamedNumberList} -> + emit({"?RT_BER:decode_enumerated(",BytesVar,",", + {asis,Constraint},",", + {asis,NamedNumberList},","}), + add_func({decode_enumerated,4}); + {'BIT STRING',NamedNumberList} -> + case get(compact_bit_string) of + true -> + emit({"?RT_BER:decode_compact_bit_string(", + BytesVar,",",{asis,Constraint},",", + {asis,NamedNumberList},","}), + add_func({decode_compact_bit_string,4}); + _ -> + emit({"?RT_BER:decode_bit_string(",BytesVar,",", + {asis,Constraint},",", + {asis,NamedNumberList},","}), + add_func({decode_bit_string,4}) + end; + 'NULL' -> + emit({"?RT_BER:decode_null(",BytesVar,","}), + add_func({decode_null,2}); + 'OBJECT IDENTIFIER' -> + emit({"?RT_BER:decode_object_identifier(",BytesVar,","}), + add_func({decode_object_identifier,2}); + 'ObjectDescriptor' -> + emit({"?RT_BER:decode_restricted_string(", + BytesVar,",",{asis,Constraint},",",{asis,?T_ObjectDescriptor},","}), + add_func({decode_restricted_string,4}); + 'OCTET STRING' -> + emit({"?RT_BER:decode_octet_string",AsBin,"(",BytesVar,",",{asis,Constraint},","}), + add_func({decode_octet_string,3}); + 'NumericString' -> + emit({"?RT_BER:decode_restricted_string",AsBin,"(", + BytesVar,",",{asis,Constraint},",",{asis,?T_NumericString},","}), + add_func({decode_restricted_string,4}); + 'TeletexString' -> + emit({"?RT_BER:decode_restricted_string",AsBin,"(", + BytesVar,",",{asis,Constraint},",",{asis,?T_TeletexString},","}), + add_func({decode_restricted_string,4}); + 'VideotexString' -> + emit({"?RT_BER:decode_restricted_string",AsBin,"(", + BytesVar,",",{asis,Constraint},",",{asis,?T_VideotexString},","}), + add_func({decode_restricted_string,4}); + 'GraphicString' -> + emit({"?RT_BER:decode_restricted_string",AsBin,"(", + BytesVar,",",{asis,Constraint},",",{asis,?T_GraphicString},","}), + add_func({decode_restricted_string,4}); + 'VisibleString' -> + emit({"?RT_BER:decode_restricted_string",AsBin,"(", + BytesVar,",",{asis,Constraint},",",{asis,?T_VisibleString},","}), + add_func({decode_restricted_string,4}); + 'GeneralString' -> + emit({"?RT_BER:decode_restricted_string",AsBin,"(", + BytesVar,",",{asis,Constraint},",",{asis,?T_GeneralString},","}), + add_func({decode_restricted_string,4}); + 'PrintableString' -> + emit({"?RT_BER:decode_restricted_string",AsBin,"(", + BytesVar,",",{asis,Constraint},",",{asis,?T_PrintableString},","}), + add_func({decode_restricted_string,4}); + 'IA5String' -> + emit({"?RT_BER:decode_restricted_string",AsBin,"(", + BytesVar,",",{asis,Constraint},",",{asis,?T_IA5String},","}), + add_func({decode_restricted_string,4}) ; + 'UniversalString' -> + emit({"?RT_BER:decode_universal_string",AsBin,"(", + BytesVar,",",{asis,Constraint},","}), + add_func({decode_universal_string,3}); + 'BMPString' -> + emit({"?RT_BER:decode_BMP_string",AsBin,"(", + BytesVar,",",{asis,Constraint},","}), + add_func({decode_BMP_string,3}); + 'UTCTime' -> + emit({"?RT_BER:decode_utc_time",AsBin,"(", + BytesVar,",",{asis,Constraint},","}), + add_func({decode_utc_time,3}); + 'GeneralizedTime' -> + emit({"?RT_BER:decode_generalized_time",AsBin,"(", + BytesVar,",",{asis,Constraint},","}), + add_func({decode_generalized_time,3}); + 'ASN1_OPEN_TYPE' -> + emit(["?RT_BER:decode_open_type_as_binary(", + BytesVar,","]), + add_func({decode_open_type_as_binary,2}); + Other -> + exit({'can not decode' ,Other}) + end, + + case {DoTag,NewTypeName} of + {{string,TagStr},'ASN1_OPEN_TYPE'} -> + emit([TagStr,")"]); + {_,'ASN1_OPEN_TYPE'} -> + emit([{asis,DoTag},")"]); + {{string,TagStr},_} -> + emit([TagStr,")"]); + _ when list(DoTag) -> + emit([{asis,DoTag},")"]) + end. + + +int_constr([],[]) -> + []; +int_constr([],ValueRange) -> + ValueRange; +int_constr(SingleValue,[]) -> + SingleValue; +int_constr(SV,VR) -> + [SV,VR]. + +%% Object code generating for encoding and decoding +%% ------------------------------------------------ + +gen_obj_code(Erules,_Module,Obj) when record(Obj,typedef) -> + ObjName = Obj#typedef.name, + Def = Obj#typedef.typespec, + #'Externaltypereference'{module=M,type=ClName} = Def#'Object'.classname, + Class = asn1_db:dbget(M,ClName), + {object,_,Fields} = Def#'Object'.def, + emit({nl,nl,nl,"%%================================"}), + emit({nl,"%% ",ObjName}), + emit({nl,"%%================================",nl}), + EncConstructed = + gen_encode_objectfields(ClName,get_class_fields(Class), + ObjName,Fields,[]), + emit(nl), + gen_encode_constr_type(Erules,EncConstructed), + emit(nl), + DecConstructed = + gen_decode_objectfields(ClName,get_class_fields(Class), + ObjName,Fields,[]), + emit(nl), + gen_decode_constr_type(Erules,DecConstructed), + emit_tlv_format_function(); +gen_obj_code(_Erules,_Module,Obj) when record(Obj,pobjectdef) -> + ok. + +gen_encode_objectfields(ClassName,[{typefield,Name,OptOrMand}|Rest], + ObjName,ObjectFields,ConstrAcc) -> + EmitFuncClause = + fun(Arg) -> + emit(["'enc_",ObjName,"'(",{asis,Name}, + ", ",Arg,", _RestPrimFieldName) ->",nl]) + end, +% emit(["'enc_",ObjName,"'(",{asis,Name}, +% ", Val, RestPrimFieldName) ->",nl]), + MaybeConstr= + case {get_object_field(Name,ObjectFields),OptOrMand} of + {false,'MANDATORY'} -> %% this case is illegal + exit({error,{asn1,{"missing mandatory field in object", + ObjName}}}); + {false,'OPTIONAL'} -> + EmitFuncClause("_"), + emit([" {<<>>,0}"]), + []; + {false,{'DEFAULT',DefaultType}} -> + EmitFuncClause("Val"), + gen_encode_default_call(ClassName,Name,DefaultType); + {{Name,TypeSpec},_} -> + %% A specified field owerwrites any 'DEFAULT' or + %% 'OPTIONAL' field in the class + EmitFuncClause("Val"), + gen_encode_field_call(ObjName,Name,TypeSpec) + end, + case more_genfields(Rest) of + true -> + emit([";",nl]); + false -> + emit([".",nl]) + end, + gen_encode_objectfields(ClassName,Rest,ObjName,ObjectFields, + MaybeConstr++ConstrAcc); +gen_encode_objectfields(ClassName,[{objectfield,Name,_,_,OptOrMand}|Rest], + ObjName,ObjectFields,ConstrAcc) -> + EmitFuncClause = + fun(Args) -> + emit(["'enc_",ObjName,"'(",{asis,Name}, + ", ",Args,") ->",nl]) + end, +% emit(["'enc_",ObjName,"'(",{asis,Name}, +% ", Val,[H|T]) ->",nl]), + case {get_object_field(Name,ObjectFields),OptOrMand} of + {false,'MANDATORY'} -> + exit({error,{asn1,{"missing mandatory field in object", + ObjName}}}); + {false,'OPTIONAL'} -> + EmitFuncClause("_,_"), + emit([" exit({error,{'use of missing field in object', ",Name, + "}})"]); + {false,{'DEFAULT',_DefaultObject}} -> + exit({error,{asn1,{"not implemented yet",Name}}}); + {{Name,TypeSpec},_} -> + EmitFuncClause(" Val, [H|T]"), + case TypeSpec#typedef.name of + {ExtMod,TypeName} -> + emit({indent(3),"'",ExtMod,"':'enc_",TypeName, + "'(H, Val, T)"}); + TypeName -> + emit({indent(3),"'enc_",TypeName,"'(H, Val, T)"}) + end + end, + case more_genfields(Rest) of + true -> + emit([";",nl]); + false -> + emit([".",nl]) + end, + gen_encode_objectfields(ClassName,Rest,ObjName,ObjectFields,ConstrAcc); + +% gen_encode_objectfields(Class,ObjName,[{FieldName,Type}|Rest],ConstrAcc) -> +% Fields = Class#objectclass.fields, +% MaybeConstr= +% case is_typefield(Fields,FieldName) of +% true -> +% Def = Type#typedef.typespec, +% emit({"'enc_",ObjName,"'(",{asis,FieldName}, +% ", Val, RestPrimFieldName) ->",nl}), +% CAcc= +% case Type#typedef.name of +% {primitive,bif} -> %%tag should be the primitive tag +% OTag = Def#type.tag, +% Tag = [encode_tag_val(decode_class(X#tag.class), +% X#tag.form,X#tag.number)|| +% X <- OTag], +% gen_encode_prim(ber,Def,{asis,lists:reverse(Tag)}, +% "Val"), +% []; +% {constructed,bif} -> +% emit({" 'enc_",ObjName,'_',FieldName, +% "'(Val)"}), +% [Type#typedef{name=list_to_atom(lists:concat([ObjName,'_',FieldName]))}]; +% {ExtMod,TypeName} -> +% emit({" '",ExtMod,"':'enc_",TypeName, +% "'(Val)"}), +% []; +% TypeName -> +% emit({" 'enc_",TypeName,"'(Val)"}), +% [] +% end, +% case more_genfields(Fields,Rest) of +% true -> +% emit({";",nl}); +% false -> +% emit({".",nl}) +% end, +% CAcc; +% {false,objectfield} -> +% emit({"'enc_",ObjName,"'(",{asis,FieldName}, +% ", Val,[H|T]) ->",nl}), +% case Type#typedef.name of +% {ExtMod,TypeName} -> +% emit({indent(3),"'",ExtMod,"':'enc_",TypeName, +% "'(H, Val, T)"}); +% TypeName -> +% emit({indent(3),"'enc_",TypeName,"'(H, Val, T)"}) +% end, +% case more_genfields(Fields,Rest) of +% true -> +% emit({";",nl}); +% false -> +% emit({".",nl}) +% end, +% []; +% {false,_} -> [] +% end, +% gen_encode_objectfields(Class,ObjName,Rest,MaybeConstr ++ ConstrAcc); +gen_encode_objectfields(ClassName,[_C|Cs],O,OF,Acc) -> + gen_encode_objectfields(ClassName,Cs,O,OF,Acc); +gen_encode_objectfields(_,[],_,_,Acc) -> + Acc. + +% gen_encode_constr_type(Erules,[{Name,Def}|Rest]) -> +% emit({Name,"(Val,TagIn) ->",nl}), +% InnerType = asn1ct_gen:get_inner(Def#type.def), +% asn1ct_gen:gen_encode_constructed(Erules,Name,InnerType,Def), +% gen_encode_constr_type(Erules,Rest); +gen_encode_constr_type(Erules,[TypeDef|Rest]) when record(TypeDef,typedef) -> + case is_already_generated(enc,TypeDef#typedef.name) of + true -> ok; + _ -> gen_encode_user(Erules,TypeDef) + end, + gen_encode_constr_type(Erules,Rest); +gen_encode_constr_type(_,[]) -> + ok. + +gen_encode_field_call(ObjName,FieldName,Type) -> + Def = Type#typedef.typespec, + OTag = Def#type.tag, + Tag = [encode_tag_val(decode_class(X#tag.class), + X#tag.form,X#tag.number)|| + X <- OTag], + case Type#typedef.name of + {primitive,bif} -> %%tag should be the primitive tag +% OTag = Def#type.tag, +% Tag = [encode_tag_val(decode_class(X#tag.class), +% X#tag.form,X#tag.number)|| +% X <- OTag], + gen_encode_prim(ber,Def,{asis,lists:reverse(Tag)}, + "Val"), + []; + {constructed,bif} -> + emit({" 'enc_",ObjName,'_',FieldName, + "'(Val,",{asis,Tag},")"}), + [Type#typedef{name=list_to_atom(lists:concat([ObjName,'_',FieldName]))}]; + {ExtMod,TypeName} -> + emit({" '",ExtMod,"':'enc_",TypeName, + "'(Val,",{asis,Tag},")"}), + []; + TypeName -> + emit({" 'enc_",TypeName,"'(Val,",{asis,Tag},")"}), + [] + end. + +gen_encode_default_call(ClassName,FieldName,Type) -> + CurrentMod = get(currmod), + InnerType = asn1ct_gen:get_inner(Type#type.def), + OTag = Type#type.tag, + Tag = [encode_tag_val(decode_class(X#tag.class),X#tag.form,X#tag.number)|| X <- OTag], + case asn1ct_gen:type(InnerType) of + {constructed,bif} -> +%% asn1ct_gen:gen_encode_constructed(Erules,Typename,InnerType,Type); + emit([" 'enc_",ClassName,'_',FieldName,"'(Bytes)"]), + [#typedef{name=list_to_atom(lists:concat([ClassName,'_',FieldName])), + typespec=Type}]; + {primitive,bif} -> + gen_encode_prim(ber,Type,{asis,lists:reverse(Tag)},"Val"), + []; + #'Externaltypereference'{module=CurrentMod,type=Etype} -> + emit([" 'enc_",Etype,"'(Val, ",{asis,Tag},")",nl]), + []; + #'Externaltypereference'{module=Emod,type=Etype} -> + emit([" '",Emod,"':'enc_",Etype,"'(Val, ",{asis,Tag},")",nl]), + [] +% 'ASN1_OPEN_TYPE' -> +% emit(["%% OPEN TYPE",nl]), +% gen_encode_prim(ber, +% Type#type{def='ASN1_OPEN_TYPE'}, +% "TagIn","Val"), +% emit([".",nl]) + end. + +%%%%%%%%%%%%%%%% + +gen_decode_objectfields(ClassName,[{typefield,Name,OptOrMand}|Rest], + ObjName,ObjectFields,ConstrAcc) -> + EmitFuncClause = + fun(Arg) -> + emit(["'dec_",ObjName,"'(",{asis,Name}, + ", ",Arg,",_) ->",nl]) + end, +% emit(["'dec_",ObjName,"'(",{asis,Name}, +% ", Bytes, RestPrimFieldName) ->",nl]), + MaybeConstr= + case {get_object_field(Name,ObjectFields),OptOrMand} of + {false,'MANDATORY'} -> %% this case is illegal + exit({error,{asn1,{"missing mandatory field in object", + ObjName}}}); + {false,'OPTIONAL'} -> + EmitFuncClause(" _"), + emit([" asn1_NOVALUE"]), + []; + {false,{'DEFAULT',DefaultType}} -> + EmitFuncClause("Bytes"), + emit_tlv_format("Bytes"), + gen_decode_default_call(ClassName,Name,"Tlv",DefaultType); + {{Name,TypeSpec},_} -> + %% A specified field owerwrites any 'DEFAULT' or + %% 'OPTIONAL' field in the class + EmitFuncClause("Bytes"), + emit_tlv_format("Bytes"), + gen_decode_field_call(ObjName,Name,"Tlv",TypeSpec) + end, + case more_genfields(Rest) of + true -> + emit([";",nl]); + false -> + emit([".",nl]) + end, + gen_decode_objectfields(ClassName,Rest,ObjName,ObjectFields,MaybeConstr++ConstrAcc); +gen_decode_objectfields(ClassName,[{objectfield,Name,_,_,OptOrMand}|Rest], + ObjName,ObjectFields,ConstrAcc) -> + EmitFuncClause = + fun(Args) -> + emit(["'dec_",ObjName,"'(",{asis,Name}, + ", ",Args,") ->",nl]) + end, +% emit(["'dec_",ObjName,"'(",{asis,Name}, +% ", Bytes,[H|T]) ->",nl]), +% emit_tlv_format("Bytes"), + case {get_object_field(Name,ObjectFields),OptOrMand} of + {false,'MANDATORY'} -> + exit({error,{asn1,{"missing mandatory field in object", + ObjName}}}); + {false,'OPTIONAL'} -> + EmitFuncClause("_,_"), + emit([" exit({error,{'illegal use of missing field in object', ",Name, + "}})"]); + {false,{'DEFAULT',_DefaultObject}} -> + exit({error,{asn1,{"not implemented yet",Name}}}); + {{Name,TypeSpec},_} -> + EmitFuncClause("Bytes,[H|T]"), +% emit_tlv_format("Bytes"), + case TypeSpec#typedef.name of + {ExtMod,TypeName} -> + emit({indent(3),"'",ExtMod,"':'dec_",TypeName, + "'(H, Bytes, T)"}); + TypeName -> + emit({indent(3),"'dec_",TypeName,"'(H, Bytes, T)"}) + end + end, + case more_genfields(Rest) of + true -> + emit([";",nl]); + false -> + emit([".",nl]) + end, + gen_decode_objectfields(ClassName,Rest,ObjName,ObjectFields,ConstrAcc); +gen_decode_objectfields(CN,[_C|Cs],O,OF,CAcc) -> + gen_decode_objectfields(CN,Cs,O,OF,CAcc); +gen_decode_objectfields(_,[],_,_,CAcc) -> + CAcc. + +emit_tlv_format(Bytes) -> + notice_tlv_format_gen(), % notice for generating of tlv_format/1 + emit([" Tlv = tlv_format(",Bytes,"),",nl]). + +notice_tlv_format_gen() -> + Module = get(currmod), +% io:format("Noticed: ~p~n",[Module]), + case get(tlv_format) of + {done,Module} -> + ok; + _ -> % true or undefined + put(tlv_format,true) + end. + +emit_tlv_format_function() -> + Module = get(currmod), +% io:format("Tlv formated: ~p",[Module]), + case get(tlv_format) of + true -> +% io:format(" YES!~n"), + emit_tlv_format_function1(), + put(tlv_format,{done,Module}); + _ -> +% io:format(" NO!~n"), + ok + end. +emit_tlv_format_function1() -> + emit(["tlv_format(Bytes) when binary(Bytes) ->",nl, + " {Tlv,_}=?RT_BER:decode(Bytes),",nl, + " Tlv;",nl, + "tlv_format(Bytes) ->",nl, + " Bytes.",nl]). + + +gen_decode_constr_type(Erules,[{Name,Def}|Rest]) -> + emit([Name,"(Tlv, TagIn) ->",nl]), + InnerType = asn1ct_gen:get_inner(Def#type.def), + asn1ct_gen:gen_decode_constructed(Erules,Name,InnerType,Def), + gen_decode_constr_type(Erules,Rest); +gen_decode_constr_type(Erules,[TypeDef|Rest]) when record(TypeDef,typedef) -> + case is_already_generated(dec,TypeDef#typedef.name) of + true -> ok; + _ -> + gen_decode(Erules,TypeDef) + end, + gen_decode_constr_type(Erules,Rest); +gen_decode_constr_type(_,[]) -> + ok. + +%%%%%%%%%%% +gen_decode_field_call(ObjName,FieldName,Bytes,Type) -> + Def = Type#typedef.typespec, + OTag = Def#type.tag, + Tag = [(decode_class(X#tag.class) bsl 10) + X#tag.number || + X <- OTag], + case Type#typedef.name of + {primitive,bif} -> %%tag should be the primitive tag + gen_dec_prim(ber,Def,Bytes,Tag,"TagIn",?PRIMITIVE, + opt_or_default), + []; + {constructed,bif} -> + emit({" 'dec_",ObjName,'_',FieldName, + "'(",Bytes,",",{asis,Tag},")"}), + [Type#typedef{name=list_to_atom(lists:concat([ObjName,'_',FieldName]))}]; + {ExtMod,TypeName} -> + emit({" '",ExtMod,"':'dec_",TypeName, + "'(",Bytes,",",{asis,Tag},")"}), + []; + TypeName -> + emit({" 'dec_",TypeName,"'(",Bytes,",",{asis,Tag},")"}), + [] + end. + +gen_decode_default_call(ClassName,FieldName,Bytes,Type) -> + CurrentMod = get(currmod), + InnerType = asn1ct_gen:get_inner(Type#type.def), + OTag = Type#type.tag, + Tag = [(decode_class(X#tag.class) bsl 10) + X#tag.number || X <- OTag], + case asn1ct_gen:type(InnerType) of + {constructed,bif} -> + emit([" 'dec_",ClassName,'_',FieldName,"'(",Bytes,",", + {asis,Tag},")"]), + [#typedef{name=list_to_atom(lists:concat([ClassName,'_', + FieldName])), + typespec=Type}]; + {primitive,bif} -> + gen_dec_prim(ber,Type,Bytes,Tag,"TagIn", + ?PRIMITIVE,opt_or_default), + []; + #'Externaltypereference'{module=CurrentMod,type=Etype} -> + emit([" 'dec_",Etype,"'(",Bytes, " ,",{asis,Tag},")",nl]), + []; + #'Externaltypereference'{module=Emod,type=Etype} -> + emit([" '",Emod,"':'dec_",Etype,"'(",Bytes,", ", + {asis,Tag},")",nl]), + [] +% 'ASN1_OPEN_TYPE' -> +% emit(["%% OPEN TYPE",nl]), +% gen_encode_prim(ber, +% Type#type{def='ASN1_OPEN_TYPE'}, +% "TagIn","Val"), +% emit([".",nl]) + end. +%%%%%%%%%%% + +is_already_generated(Operation,Name) -> + case get(class_default_type) of + undefined -> + put(class_default_type,[{Operation,Name}]), + false; + GeneratedList -> + case lists:member({Operation,Name},GeneratedList) of + true -> + true; + false -> + put(class_default_type,[{Operation,Name}|GeneratedList]), + false + end + end. + +more_genfields([]) -> + false; +more_genfields([Field|Fields]) -> + case element(1,Field) of + typefield -> + true; + objectfield -> + true; + _ -> + more_genfields(Fields) + end. + + + + +%% Object Set code generating for encoding and decoding +%% ---------------------------------------------------- +gen_objectset_code(Erules,ObjSet) -> + ObjSetName = ObjSet#typedef.name, + Def = ObjSet#typedef.typespec, +% {ClassName,ClassDef} = Def#'ObjectSet'.class, + #'Externaltypereference'{module=ClassModule, + type=ClassName} = Def#'ObjectSet'.class, + ClassDef = asn1_db:dbget(ClassModule,ClassName), + UniqueFName = Def#'ObjectSet'.uniquefname, + Set = Def#'ObjectSet'.set, + emit({nl,nl,nl,"%%================================"}), + emit({nl,"%% ",ObjSetName}), + emit({nl,"%%================================",nl}), + case ClassName of + {_Module,ExtClassName} -> + gen_objset_code(Erules,ObjSetName,UniqueFName,Set,ExtClassName,ClassDef); + _ -> + gen_objset_code(Erules,ObjSetName,UniqueFName,Set,ClassName,ClassDef) + end, + emit(nl). + +gen_objset_code(Erules,ObjSetName,UniqueFName,Set,ClassName,ClassDef)-> + ClassFields = get_class_fields(ClassDef), + InternalFuncs=gen_objset_enc(Erules,ObjSetName,UniqueFName,Set, + ClassName,ClassFields,1,[]), + gen_objset_dec(Erules,ObjSetName,UniqueFName,Set,ClassName,ClassFields,1), + gen_internal_funcs(Erules,InternalFuncs). + +%% gen_objset_enc iterates over the objects of the object set +gen_objset_enc(_,_,{unique,undefined},_,_,_,_,_) -> + %% There is no unique field in the class of this object set + %% don't bother about the constraint + []; +gen_objset_enc(Erules,ObjSName,UniqueName, + [{ObjName,Val,Fields},T|Rest],ClName,ClFields, + NthObj,Acc)-> + emit({"'getenc_",ObjSName,"'(",{asis,UniqueName},",",{asis,Val}, + ") ->",nl}), + {InternalFunc,NewNthObj}= + case ObjName of + no_name -> + gen_inlined_enc_funs(Fields,ClFields,ObjSName,NthObj); + _ -> + emit({" fun 'enc_",ObjName,"'/3"}), + {[],NthObj} + end, + emit({";",nl}), + gen_objset_enc(Erules,ObjSName,UniqueName,[T|Rest],ClName,ClFields, + NewNthObj,InternalFunc ++ Acc); +gen_objset_enc(_,ObjSetName,UniqueName, + [{ObjName,Val,Fields}],_ClName,ClFields,NthObj,Acc) -> + emit({"'getenc_",ObjSetName,"'(",{asis,UniqueName},",", + {asis,Val},") ->",nl}), + {InternalFunc,_} = + case ObjName of + no_name -> + gen_inlined_enc_funs(Fields,ClFields,ObjSetName,NthObj); + _ -> + emit({" fun 'enc_",ObjName,"'/3"}), + {[],NthObj} + end, + emit({".",nl,nl}), + InternalFunc ++ Acc; +%% See X.681 Annex E for the following case +gen_objset_enc(_,ObjSetName,_UniqueName,['EXTENSIONMARK'],_ClName, + _ClFields,_NthObj,Acc) -> + emit({"'getenc_",ObjSetName,"'(_, _) ->",nl}), + emit({indent(3),"fun(_, Val, _RestPrimFieldName) ->",nl}), + emit({indent(6),"Len = case Val of",nl,indent(9), + "Bin when binary(Bin) -> size(Bin);",nl,indent(9), + "_ -> length(Val)",nl,indent(6),"end,"}), + emit({indent(6),"{Val,Len}",nl}), + emit({indent(3),"end.",nl,nl}), + Acc; +gen_objset_enc(_,_,_,[],_,_,_,Acc) -> + Acc. + +%% gen_inlined_enc_funs for each object iterates over all fields of a +%% class, and for each typefield it checks if the object has that +%% field and emits the proper code. +gen_inlined_enc_funs(Fields,[{typefield,Name,_}|Rest], + ObjSetName,NthObj) -> + InternalDefFunName = asn1ct_gen:list2name([NthObj,Name,ObjSetName]), + case lists:keysearch(Name,1,Fields) of + {value,{_,Type}} when record(Type,type) -> + emit({indent(3),"fun(Type, Val, _RestPrimFieldName) ->",nl, + indent(6),"case Type of",nl}), + {Ret,N}=emit_inner_of_fun(Type,InternalDefFunName), + gen_inlined_enc_funs1(Fields,Rest,ObjSetName,NthObj+N,Ret); + {value,{_,Type}} when record(Type,typedef) -> + emit({indent(3),"fun(Type, Val, _RestPrimFieldName) ->",nl, + indent(6),"case Type of",nl}), + emit({indent(9),{asis,Name}," ->",nl}), + {Ret,N}=emit_inner_of_fun(Type,InternalDefFunName), + gen_inlined_enc_funs1(Fields,Rest,ObjSetName,NthObj+N,Ret); + false -> + gen_inlined_enc_funs(Fields,Rest,ObjSetName,NthObj) + end; +gen_inlined_enc_funs(Fields,[_|Rest],ObjSetName,NthObj) -> + gen_inlined_enc_funs(Fields,Rest,ObjSetName,NthObj); +gen_inlined_enc_funs(_,[],_,NthObj) -> + {[],NthObj}. + +gen_inlined_enc_funs1(Fields,[{typefield,Name,_}|Rest],ObjSetName, + NthObj,Acc) -> + InternalDefFunName = asn1ct_gen:list2name([NthObj,Name,ObjSetName]), + {Acc2,NAdd}= + case lists:keysearch(Name,1,Fields) of + {value,{_,Type}} when record(Type,type) -> + emit({";",nl}), + {Ret,N}=emit_inner_of_fun(Type,InternalDefFunName), + {Ret++Acc,N}; + {value,{_,Type}} when record(Type,typedef) -> + emit({";",nl,indent(9),{asis,Name}," ->",nl}), + {Ret,N}=emit_inner_of_fun(Type,InternalDefFunName), + {Ret++Acc,N}; + false -> + {Acc,0} + end, + gen_inlined_enc_funs1(Fields,Rest,ObjSetName,NthObj+NAdd,Acc2); +gen_inlined_enc_funs1(Fields,[_|Rest],ObjSetName,NthObj,Acc)-> + gen_inlined_enc_funs1(Fields,Rest,ObjSetName,NthObj,Acc); +gen_inlined_enc_funs1(_,[],_,NthObj,Acc) -> + emit({nl,indent(6),"end",nl}), + emit({indent(3),"end"}), + {Acc,NthObj}. + +emit_inner_of_fun(TDef=#typedef{name={ExtMod,Name},typespec=Type}, + InternalDefFunName) -> + OTag = Type#type.tag, + Tag = [encode_tag_val(decode_class(X#tag.class),X#tag.form,X#tag.number)|| X <- OTag], +% remove Tag = [X#tag{class=decode_class(X#tag.class)}|| X <- OTag], + case {ExtMod,Name} of + {primitive,bif} -> + emit(indent(12)), + gen_encode_prim(ber,Type,[{asis,lists:reverse(Tag)}],"Val"), + {[],0}; + {constructed,bif} -> + emit([indent(12),"'enc_", + InternalDefFunName,"'(Val)"]), + {[TDef#typedef{name=InternalDefFunName}],1}; + _ -> + emit({indent(12),"'",ExtMod,"':'enc_",Name,"'(Val)"}), + {[],0} + end; +emit_inner_of_fun(#typedef{name=Name},_) -> +% OTag = Type#type.tag, +% remove Tag = [X#tag{class=decode_class(X#tag.class)}|| X <- OTag], +% Tag = [encode_tag_val(decode_class(X#tag.class),X#tag.form,X#tag.number)|| X <- OTag], + emit({indent(12),"'enc_",Name,"'(Val)"}), + {[],0}; +emit_inner_of_fun(Type,_) when record(Type,type) -> + CurrMod = get(currmod), +% OTag = Type#type.tag, +% remove Tag = [X#tag{class=decode_class(X#tag.class)}|| X <- OTag], +% Tag = [encode_tag_val(decode_class(X#tag.class),X#tag.form,X#tag.number)|| X <- OTag], + case Type#type.def of + Def when atom(Def) -> + OTag = Type#type.tag, + Tag = [encode_tag_val(decode_class(X#tag.class), + X#tag.form,X#tag.number)||X <- OTag], + emit([indent(9),Def," ->",nl,indent(12)]), + gen_encode_prim(ber,Type,{asis,lists:reverse(Tag)},"Val"); + TRef when record(TRef,typereference) -> + T = TRef#typereference.val, + emit([indent(9),T," ->",nl,indent(12),"'enc_",T, + "'(Val)"]); + #'Externaltypereference'{module=CurrMod,type=T} -> + emit([indent(9),T," ->",nl,indent(12),"'enc_",T, + "'(Val)"]); + #'Externaltypereference'{module=ExtMod,type=T} -> + emit([indent(9),T," ->",nl,indent(12),ExtMod,":'enc_", + T,"'(Val)"]) + end, + {[],0}. + +indent(N) -> + lists:duplicate(N,32). % 32 = space + + +gen_objset_dec(_,_,{unique,undefined},_,_,_,_) -> + %% There is no unique field in the class of this object set + %% don't bother about the constraint + ok; +gen_objset_dec(Erules,ObjSName,UniqueName,[{ObjName,Val,Fields},T|Rest], + ClName,ClFields,NthObj)-> + emit(["'getdec_",ObjSName,"'(",{asis,UniqueName},",", + {asis,Val},") ->",nl]), + NewNthObj= + case ObjName of + no_name -> + gen_inlined_dec_funs(Fields,ClFields,ObjSName,NthObj); + _ -> + emit([" fun 'dec_",ObjName,"'/3"]), + NthObj + end, + emit([";",nl]), + gen_objset_dec(Erules,ObjSName,UniqueName,[T|Rest],ClName, + ClFields,NewNthObj); +gen_objset_dec(_,ObjSetName,UniqueName,[{ObjName,Val,Fields}], + _ClName,ClFields,NthObj) -> + emit(["'getdec_",ObjSetName,"'(",{asis,UniqueName},",", + {asis,Val},") ->",nl]), + case ObjName of + no_name -> + gen_inlined_dec_funs(Fields,ClFields,ObjSetName,NthObj); + _ -> + emit([" fun 'dec_",ObjName,"'/3"]) + end, + emit([".",nl,nl]), + ok; +gen_objset_dec(Erules,ObjSetName,_UniqueName,['EXTENSIONMARK'],_ClName, + _ClFields,_NthObj) -> + emit(["'getdec_",ObjSetName,"'(_, _) ->",nl]), + emit([indent(2),"fun(_,Bytes, _RestPrimFieldName) ->",nl]), + case Erules of + ber_bin_v2 -> + emit([indent(4),"case Bytes of",nl, + indent(6),"Bin when binary(Bin) -> ",nl, + indent(8),"Bin;",nl, + indent(6),"_ ->",nl, + indent(8),"?RT_BER:encode(Bytes)",nl, + indent(4),"end",nl]); + _ -> + emit([indent(6),"Len = case Bytes of",nl,indent(9), + "Bin when binary(Bin) -> size(Bin);",nl,indent(9), + "_ -> length(Bytes)",nl,indent(6),"end,"]), + emit([indent(4),"{Bytes,[],Len}",nl]) + end, + emit([indent(2),"end.",nl,nl]), + ok; +gen_objset_dec(_,_,_,[],_,_,_) -> + ok. + +gen_inlined_dec_funs(Fields,[{typefield,Name,Prop}|Rest], + ObjSetName,NthObj) -> + DecProp = case Prop of + 'OPTIONAL' -> opt_or_default; + {'DEFAULT',_} -> opt_or_default; + _ -> mandatory + end, + InternalDefFunName = [NthObj,Name,ObjSetName], + case lists:keysearch(Name,1,Fields) of + {value,{_,Type}} when record(Type,type) -> + emit([indent(3),"fun(Type, Bytes, _RestPrimFieldName) ->", + nl,indent(6),"case Type of",nl]), + N=emit_inner_of_decfun(Type,DecProp,InternalDefFunName), + gen_inlined_dec_funs1(Fields,Rest,ObjSetName,NthObj+N); + {value,{_,Type}} when record(Type,typedef) -> + emit([indent(3),"fun(Type, Bytes, _RestPrimFieldName) ->", + nl,indent(6),"case Type of",nl]), + emit([indent(9),{asis,Name}," ->",nl]), + N=emit_inner_of_decfun(Type,DecProp,InternalDefFunName), + gen_inlined_dec_funs1(Fields,Rest,ObjSetName,NthObj+N); + false -> + gen_inlined_dec_funs(Fields,Rest,ObjSetName,NthObj) + end; +gen_inlined_dec_funs(Fields,[_H|Rest],ObjSetName,NthObj) -> + gen_inlined_dec_funs(Fields,Rest,ObjSetName,NthObj); +gen_inlined_dec_funs(_,[],_,NthObj) -> + NthObj. + +gen_inlined_dec_funs1(Fields,[{typefield,Name,Prop}|Rest], + ObjSetName,NthObj) -> + DecProp = case Prop of + 'OPTIONAL' -> opt_or_default; + {'DEFAULT',_} -> opt_or_default; + _ -> mandatory + end, + InternalDefFunName = [NthObj,Name,ObjSetName], + N= + case lists:keysearch(Name,1,Fields) of + {value,{_,Type}} when record(Type,type) -> + emit([";",nl]), + emit_inner_of_decfun(Type,DecProp,InternalDefFunName); + {value,{_,Type}} when record(Type,typedef) -> + emit([";",nl,indent(9),{asis,Name}," ->",nl]), + emit_inner_of_decfun(Type,DecProp,InternalDefFunName); + false -> + 0 + end, + gen_inlined_dec_funs1(Fields,Rest,ObjSetName,NthObj+N); +gen_inlined_dec_funs1(Fields,[_|Rest],ObjSetName,NthObj)-> + gen_inlined_dec_funs1(Fields,Rest,ObjSetName,NthObj); +gen_inlined_dec_funs1(_,[],_,NthObj) -> + emit([nl,indent(6),"end",nl]), + emit([indent(3),"end"]), + NthObj. + +emit_inner_of_decfun(#typedef{name={ExtName,Name},typespec=Type},Prop, + InternalDefFunName) -> + OTag = Type#type.tag, +%% Tag = [X#tag{class=decode_class(X#tag.class)}|| X <- OTag], + Tag = [(decode_class(X#tag.class) bsl 10) + X#tag.number || X <- OTag], + case {ExtName,Name} of + {primitive,bif} -> + emit(indent(12)), + gen_dec_prim(ber,Type,"Bytes",Tag,"TagIn", + ?PRIMITIVE,Prop), + 0; + {constructed,bif} -> + emit([indent(12),"'dec_", +% asn1ct_gen:list2name(InternalDefFunName),"'(Bytes, ",Prop, +% ", ",{asis,Tag},")"]), + asn1ct_gen:list2name(InternalDefFunName),"'(Bytes, ", + {asis,Tag},")"]), + 1; + _ -> + emit([indent(12),"'",ExtName,"':'dec_",Name,"'(Bytes)"]), + 0 + end; +emit_inner_of_decfun(#typedef{name=Name},_Prop,_) -> + emit([indent(12),"'dec_",Name,"'(Bytes)"]), + 0; +emit_inner_of_decfun(Type,Prop,_) when record(Type,type) -> + OTag = Type#type.tag, +%% Tag = [X#tag{class=decode_class(X#tag.class)}|| X <- OTag], + Tag = [(decode_class(X#tag.class) bsl 10) + X#tag.number || X <- OTag], + CurrMod = get(currmod), + Def = Type#type.def, + InnerType = asn1ct_gen:get_inner(Def), + WhatKind = asn1ct_gen:type(InnerType), + case WhatKind of + {primitive,bif} -> + emit([indent(9),Def," ->",nl,indent(12)]), + gen_dec_prim(ber,Type,"Bytes",Tag,"TagIn", + ?PRIMITIVE,Prop); + #'Externaltypereference'{module=CurrMod,type=T} -> + emit([indent(9),T," ->",nl,indent(12),"'dec_",T, +% "'(Bytes, ",Prop,")"]); + "'(Bytes)"]); + #'Externaltypereference'{module=ExtMod,type=T} -> + emit([indent(9),T," ->",nl,indent(12),ExtMod,":'dec_", +% T,"'(Bytes, ",Prop,")"]) + T,"'(Bytes)"]) + end, + 0. + +gen_internal_funcs(_,[]) -> + ok; +gen_internal_funcs(Erules,[TypeDef|Rest]) -> + gen_encode_user(Erules,TypeDef), + emit([nl,nl,"'dec_",TypeDef#typedef.name, +% "'(Tlv, OptOrMand, TagIn) ->",nl]), + "'(Tlv, TagIn) ->",nl]), + gen_decode_user(Erules,TypeDef), + gen_internal_funcs(Erules,Rest). + + +dbdec(Type) -> + demit({"io:format(\"decoding: ",{asis,Type},"~w~n\",[Bytes]),",nl}). + + +decode_class('UNIVERSAL') -> + ?UNIVERSAL; +decode_class('APPLICATION') -> + ?APPLICATION; +decode_class('CONTEXT') -> + ?CONTEXT; +decode_class('PRIVATE') -> + ?PRIVATE. + +decode_type('BOOLEAN') -> 1; +decode_type('INTEGER') -> 2; +decode_type('BIT STRING') -> 3; +decode_type('OCTET STRING') -> 4; +decode_type('NULL') -> 5; +decode_type('OBJECT IDENTIFIER') -> 6; +decode_type('OBJECT DESCRIPTOR') -> 7; +decode_type('EXTERNAL') -> 8; +decode_type('REAL') -> 9; +decode_type('ENUMERATED') -> 10; +decode_type('EMBEDDED_PDV') -> 11; +decode_type('SEQUENCE') -> 16; +decode_type('SEQUENCE OF') -> 16; +decode_type('SET') -> 17; +decode_type('SET OF') -> 17; +decode_type('NumericString') -> 18; +decode_type('PrintableString') -> 19; +decode_type('TeletexString') -> 20; +decode_type('VideotexString') -> 21; +decode_type('IA5String') -> 22; +decode_type('UTCTime') -> 23; +decode_type('GeneralizedTime') -> 24; +decode_type('GraphicString') -> 25; +decode_type('VisibleString') -> 26; +decode_type('GeneralString') -> 27; +decode_type('UniversalString') -> 28; +decode_type('BMPString') -> 30; +decode_type('CHOICE') -> 'CHOICE'; % choice gets the tag from the actual alternative +decode_type(Else) -> exit({error,{asn1,{unrecognized_type,Else}}}). + +add_removed_bytes() -> + asn1ct_name:delete(rb), + add_removed_bytes(asn1ct_name:all(rb)). + +add_removed_bytes([H,T1|T]) -> + emit({{var,H},"+"}), + add_removed_bytes([T1|T]); +add_removed_bytes([H|T]) -> + emit({{var,H}}), + add_removed_bytes(T); +add_removed_bytes([]) -> + true. + +mkfuncname(WhatKind,DecOrEnc) -> + case WhatKind of + #'Externaltypereference'{module=Mod,type=EType} -> + CurrMod = get(currmod), + case CurrMod of + Mod -> + lists:concat(["'",DecOrEnc,"_",EType,"'"]); + _ -> +% io:format("CurrMod: ~p, Mod: ~p~n",[CurrMod,Mod]), + lists:concat(["'",Mod,"':'",DecOrEnc,"_",EType,"'"]) + end; + #'typereference'{val=EType} -> + lists:concat(["'",DecOrEnc,"_",EType,"'"]); + 'ASN1_OPEN_TYPE' -> + lists:concat(["'",DecOrEnc,"_",WhatKind,"'"]) + + end. + +optionals(L) -> optionals(L,[],1). + +optionals([{'EXTENSIONMARK',_,_}|Rest],Acc,Pos) -> + optionals(Rest,Acc,Pos); % optionals in extension are currently not handled +optionals([#'ComponentType'{name=Name,prop='OPTIONAL'}|Rest],Acc,Pos) -> + optionals(Rest,[{Name,Pos}|Acc],Pos+1); +optionals([#'ComponentType'{name=Name,prop={'DEFAULT',_}}|Rest],Acc,Pos) -> + optionals(Rest,[{Name,Pos}|Acc],Pos+1); +optionals([#'ComponentType'{}|Rest],Acc,Pos) -> + optionals(Rest,Acc,Pos+1); +optionals([],Acc,_) -> + lists:reverse(Acc). + +get_constraint(C,Key) -> + case lists:keysearch(Key,1,C) of + false -> + no; + {value,{_,V}} -> + V + end. + + +get_class_fields(#classdef{typespec=ObjClass}) -> + ObjClass#objectclass.fields; +get_class_fields(#objectclass{fields=Fields}) -> + Fields; +get_class_fields(_) -> + []. + +get_object_field(Name,ObjectFields) -> + case lists:keysearch(Name,1,ObjectFields) of + {value,Field} -> Field; + false -> false + end. + +%%encode_tag(TagClass(?UNI, APP etc), Form (?PRIM etx), TagInteger) -> +%% 8bit Int | binary +encode_tag_val(Class, Form, TagNo) when (TagNo =< 30) -> + <<(Class bsr 6):2,(Form bsr 5):1,TagNo:5>>; + +encode_tag_val(Class, Form, TagNo) -> + {Octets,_Len} = mk_object_val(TagNo), + BinOct = list_to_binary(Octets), + <<(Class bsr 6):2, (Form bsr 5):1, 31:5,BinOct/binary>>. + +%%%%%%%%%%% +%% mk_object_val(Value) -> {OctetList, Len} +%% returns a Val as a list of octets, the 8 bit is allways set to one except +%% for the last octet, where its 0 +%% + + +mk_object_val(Val) when Val =< 127 -> + {[255 band Val], 1}; +mk_object_val(Val) -> + mk_object_val(Val bsr 7, [Val band 127], 1). +mk_object_val(0, Ack, Len) -> + {Ack, Len}; +mk_object_val(Val, Ack, Len) -> + mk_object_val(Val bsr 7, [((Val band 127) bor 128) | Ack], Len + 1). + +add_func(F={_Func,_Arity}) -> + ets:insert(asn1_functab,{F}). diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_gen_per.erl b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_gen_per.erl new file mode 100644 index 0000000000..b5c70fd856 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_gen_per.erl @@ -0,0 +1,1189 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: asn1ct_gen_per.erl,v 1.1 2008/12/17 09:53:30 mikpe Exp $ +%% +-module(asn1ct_gen_per). + +%% Generate erlang module which handles (PER) encode and decode for +%% all types in an ASN.1 module + +-include("asn1_records.hrl"). +%-compile(export_all). + +-export([pgen/4,gen_dec_prim/3,gen_encode_prim/4]). +-export([gen_obj_code/3,gen_objectset_code/2]). +-export([gen_decode/2, gen_decode/3]). +-export([gen_encode/2, gen_encode/3]). +-export([is_already_generated/2,more_genfields/1,get_class_fields/1, + get_object_field/2]). + +-import(asn1ct_gen, [emit/1,demit/1]). + +%% pgen(Erules, Module, TypeOrVal) +%% Generate Erlang module (.erl) and (.hrl) file corresponding to an ASN.1 module +%% .hrl file is only generated if necessary +%% Erules = per | ber +%% Module = atom() +%% TypeOrVal = {TypeList,ValueList} +%% TypeList = ValueList = [atom()] + +pgen(OutFile,Erules,Module,TypeOrVal) -> + asn1ct_gen:pgen_module(OutFile,Erules,Module,TypeOrVal,true). + + +%% Generate ENCODING ****************************** +%%****************************************x + + +gen_encode(Erules,Type) when record(Type,typedef) -> + gen_encode_user(Erules,Type). +%% case Type#typedef.typespec of +%% Def when record(Def,type) -> +%% gen_encode_user(Erules,Type); +%% Def when tuple(Def),(element(1,Def) == 'Object') -> +%% gen_encode_object(Erules,Type); +%% Other -> +%% exit({error,{asn1,{unknown,Other}}}) +%% end. + +gen_encode(Erules,Typename,#'ComponentType'{name=Cname,typespec=Type}) -> + NewTypename = [Cname|Typename], + gen_encode(Erules,NewTypename,Type); + +gen_encode(Erules,Typename,Type) when record(Type,type) -> + InnerType = asn1ct_gen:get_inner(Type#type.def), + ObjFun = + case lists:keysearch(objfun,1,Type#type.tablecinf) of + {value,{_,_Name}} -> +%% lists:concat([", ObjFun",Name]); + ", ObjFun"; + false -> + "" + end, + case asn1ct_gen:type(InnerType) of + {constructed,bif} -> + case InnerType of + 'SET' -> + true; + 'SEQUENCE' -> + true; + _ -> + emit({nl,"'enc_",asn1ct_gen:list2name(Typename), + "'({'",asn1ct_gen:list2name(Typename), + "',Val}",ObjFun,") ->",nl}), + emit({"'enc_",asn1ct_gen:list2name(Typename), + "'(Val",ObjFun,");",nl,nl}) + end, + emit({"'enc_",asn1ct_gen:list2name(Typename),"'(Val",ObjFun, + ") ->",nl}), + asn1ct_gen:gen_encode_constructed(Erules,Typename,InnerType,Type); + _ -> + true + end. + + +gen_encode_user(Erules,D) when record(D,typedef) -> + CurrMod = get(currmod), + Typename = [D#typedef.name], + Def = D#typedef.typespec, + InnerType = asn1ct_gen:get_inner(Def#type.def), + case InnerType of + 'SET' -> true; + 'SEQUENCE' -> true; + _ -> + emit({nl,"'enc_",asn1ct_gen:list2name(Typename),"'({'",asn1ct_gen:list2name(Typename),"',Val}) ->",nl}), + emit({"'enc_",asn1ct_gen:list2name(Typename),"'(Val);",nl,nl}) + end, + emit({"'enc_",asn1ct_gen:list2name(Typename),"'(Val) ->",nl}), + case asn1ct_gen:type(InnerType) of + {primitive,bif} -> + gen_encode_prim(Erules,Def,"false"), + emit({".",nl}); + 'ASN1_OPEN_TYPE' -> + gen_encode_prim(Erules,Def#type{def='ASN1_OPEN_TYPE'},"false"), + emit({".",nl}); + {constructed,bif} -> + asn1ct_gen:gen_encode_constructed(Erules,Typename,InnerType,D); + #'Externaltypereference'{module=CurrMod,type=Etype} -> + emit({"'enc_",Etype,"'(Val).",nl,nl}); + #'Externaltypereference'{module=Emod,type=Etype} -> + emit({"'",Emod,"':'enc_",Etype,"'(Val).",nl,nl}); + #typereference{val=Ename} -> + emit({"'enc_",Ename,"'(Val).",nl,nl}); + {notype,_} -> + emit({"'enc_",InnerType,"'(Val).",nl,nl}) + end. + + +gen_encode_prim(Erules,D,DoTag) -> + Value = case asn1ct_name:active(val) of + true -> + asn1ct_gen:mk_var(asn1ct_name:curr(val)); + false -> + "Val" + end, + gen_encode_prim(Erules,D,DoTag,Value). + +gen_encode_prim(_Erules,D,_DoTag,Value) when record(D,type) -> + Constraint = D#type.constraint, + case D#type.def of + 'INTEGER' -> + emit({"?RT_PER:encode_integer(", %fel + {asis,Constraint},",",Value,")"}); + {'INTEGER',NamedNumberList} -> + emit({"?RT_PER:encode_integer(", + {asis,Constraint},",",Value,",", + {asis,NamedNumberList},")"}); + {'ENUMERATED',{Nlist1,Nlist2}} -> + NewList = lists:concat([[{0,X}||{X,_} <- Nlist1],['EXT_MARK'],[{1,X}||{X,_} <- Nlist2]]), + NewC = [{'ValueRange',{0,length(Nlist1)-1}}], + emit(["case (case ",Value," of {_,_}->element(2,",Value,");_->", + Value," end) of",nl]), + emit_enc_enumerated_cases(NewC, NewList++[{asn1_enum,length(Nlist1)-1}], 0); + {'ENUMERATED',NamedNumberList} -> + NewList = [X||{X,_} <- NamedNumberList], + NewC = [{'ValueRange',{0,length(NewList)-1}}], + emit(["case (case ",Value," of {_,_}->element(2,",Value,");_->", + Value," end) of",nl]), + emit_enc_enumerated_cases(NewC, NewList, 0); + {'BIT STRING',NamedNumberList} -> + emit({"?RT_PER:encode_bit_string(", + {asis,Constraint},",",Value,",", + {asis,NamedNumberList},")"}); + 'NULL' -> + emit({"?RT_PER:encode_null(",Value,")"}); + 'OBJECT IDENTIFIER' -> + emit({"?RT_PER:encode_object_identifier(",Value,")"}); + 'ObjectDescriptor' -> + emit({"?RT_PER:encode_ObjectDescriptor(",{asis,Constraint}, + ",",Value,")"}); + 'BOOLEAN' -> + emit({"?RT_PER:encode_boolean(",Value,")"}); + 'OCTET STRING' -> + emit({"?RT_PER:encode_octet_string(",{asis,Constraint},",",Value,")"}); + 'NumericString' -> + emit({"?RT_PER:encode_NumericString(",{asis,Constraint},",",Value,")"}); + 'TeletexString' -> + emit({"?RT_PER:encode_TeletexString(",{asis,Constraint},",",Value,")"}); + 'VideotexString' -> + emit({"?RT_PER:encode_VideotexString(",{asis,Constraint},",",Value,")"}); + 'UTCTime' -> + emit({"?RT_PER:encode_VisibleString(",{asis,Constraint},",",Value,")"}); + 'GeneralizedTime' -> + emit({"?RT_PER:encode_VisibleString(",{asis,Constraint},",",Value,")"}); + 'GraphicString' -> + emit({"?RT_PER:encode_GraphicString(",{asis,Constraint},",",Value,")"}); + 'VisibleString' -> + emit({"?RT_PER:encode_VisibleString(",{asis,Constraint},",",Value,")"}); + 'GeneralString' -> + emit({"?RT_PER:encode_GeneralString(",{asis,Constraint},",",Value,")"}); + 'PrintableString' -> + emit({"?RT_PER:encode_PrintableString(",{asis,Constraint},",",Value,")"}); + 'IA5String' -> + emit({"?RT_PER:encode_IA5String(",{asis,Constraint},",",Value,")"}); + 'BMPString' -> + emit({"?RT_PER:encode_BMPString(",{asis,Constraint},",",Value,")"}); + 'UniversalString' -> + emit({"?RT_PER:encode_UniversalString(",{asis,Constraint},",",Value,")"}); + 'ANY' -> + emit(["?RT_PER:encode_open_type(", {asis,Constraint}, ",", + Value, ")"]); + 'ASN1_OPEN_TYPE' -> + NewValue = case Constraint of + [#'Externaltypereference'{type=Tname}] -> + io_lib:format( + "?RT_PER:complete(enc_~s(~s))",[Tname,Value]); + [#type{def=#'Externaltypereference'{type=Tname}}] -> + io_lib:format( + "?RT_PER:complete(enc_~s(~s))",[Tname,Value]); + _ -> Value + end, + emit(["?RT_PER:encode_open_type(", {asis,Constraint}, ",", + NewValue, ")"]); + XX -> + exit({asn1_error,nyi,XX}) + end. + +emit_enc_enumerated_cases(C, [H], Count) -> + emit_enc_enumerated_case(C, H, Count), + emit([";",nl,"EnumVal -> exit({error,{asn1, {enumerated_not_in_range, EnumVal}}})"]), + emit([nl,"end"]); +emit_enc_enumerated_cases(C, ['EXT_MARK'|T], _Count) -> + emit_enc_enumerated_cases(C, T, 0); +emit_enc_enumerated_cases(C, [H1,H2|T], Count) -> + emit_enc_enumerated_case(C, H1, Count), + emit([";",nl]), + emit_enc_enumerated_cases(C, [H2|T], Count+1). + + + +emit_enc_enumerated_case(_C, {asn1_enum,High}, _) -> + emit([ + "{asn1_enum,EnumV} when integer(EnumV), EnumV > ",High," -> ", + "[{bit,1},?RT_PER:encode_small_number(EnumV)]"]); +emit_enc_enumerated_case(_C, 'EXT_MARK', _Count) -> + true; +emit_enc_enumerated_case(_C, {1,EnumName}, Count) -> + emit(["'",EnumName,"' -> [{bit,1},?RT_PER:encode_small_number(",Count,")]"]); +emit_enc_enumerated_case(C, {0,EnumName}, Count) -> + emit(["'",EnumName,"' -> [{bit,0},?RT_PER:encode_integer(",{asis,C},", ",Count,")]"]); +emit_enc_enumerated_case(C, EnumName, Count) -> + emit(["'",EnumName,"' -> ?RT_PER:encode_integer(",{asis,C},", ",Count,")"]). + + +%% Object code generating for encoding and decoding +%% ------------------------------------------------ + +gen_obj_code(Erules,_Module,Obj) when record(Obj,typedef) -> + ObjName = Obj#typedef.name, + Def = Obj#typedef.typespec, + #'Externaltypereference'{module=Mod,type=ClassName} = + Def#'Object'.classname, + Class = asn1_db:dbget(Mod,ClassName), + {object,_,Fields} = Def#'Object'.def, + emit({nl,nl,nl,"%%================================"}), + emit({nl,"%% ",ObjName}), + emit({nl,"%%================================",nl}), + EncConstructed = + gen_encode_objectfields(ClassName,get_class_fields(Class), + ObjName,Fields,[]), + emit(nl), + gen_encode_constr_type(Erules,EncConstructed), + emit(nl), + DecConstructed = + gen_decode_objectfields(ClassName,get_class_fields(Class), + ObjName,Fields,[]), + emit(nl), + gen_decode_constr_type(Erules,DecConstructed), + emit(nl); +gen_obj_code(_,_,Obj) when record(Obj,pobjectdef) -> + ok. + + +gen_encode_objectfields(ClassName,[{typefield,Name,OptOrMand}|Rest], + ObjName,ObjectFields,ConstrAcc) -> + EmitFuncClause = + fun(V) -> + emit(["'enc_",ObjName,"'(",{asis,Name}, + ",",V,",_RestPrimFieldName) ->",nl]) + end, +% emit(["'enc_",ObjName,"'(",{asis,Name}, +% ", Val, _RestPrimFieldName) ->",nl]), + MaybeConstr = + case {get_object_field(Name,ObjectFields),OptOrMand} of + {false,'MANDATORY'} -> %% this case is illegal + exit({error,{asn1,{"missing mandatory field in object", + ObjName}}}); + {false,'OPTIONAL'} -> + EmitFuncClause("_"), + emit(" []"), + []; + {false,{'DEFAULT',DefaultType}} -> + EmitFuncClause("Val"), + gen_encode_default_call(ClassName,Name,DefaultType); + {{Name,TypeSpec},_} -> + %% A specified field owerwrites any 'DEFAULT' or + %% 'OPTIONAL' field in the class + EmitFuncClause("Val"), + gen_encode_field_call(ObjName,Name,TypeSpec) + end, + case more_genfields(Rest) of + true -> + emit([";",nl]); + false -> + emit([".",nl]) + end, + gen_encode_objectfields(ClassName,Rest,ObjName,ObjectFields, + MaybeConstr++ConstrAcc); +gen_encode_objectfields(ClassName,[{objectfield,Name,_,_,OptOrMand}|Rest], + ObjName,ObjectFields,ConstrAcc) -> + EmitFuncClause = + fun(Attrs) -> + emit(["'enc_",ObjName,"'(",{asis,Name}, + ",",Attrs,") ->",nl]) + end, +% emit(["'enc_",ObjName,"'(",{asis,Name}, +% ", Val,[H|T]) ->",nl]), + case {get_object_field(Name,ObjectFields),OptOrMand} of + {false,'MANDATORY'} -> + exit({error,{asn1,{"missing mandatory field in object", + ObjName}}}); + {false,'OPTIONAL'} -> + EmitFuncClause("_,_"), + emit([" exit({error,{'use of missing field in object', ",Name, + "}})"]); + {false,{'DEFAULT',_DefaultObject}} -> + exit({error,{asn1,{"not implemented yet",Name}}}); + {{Name,TypeSpec},_} -> + EmitFuncClause("Val,[H|T]"), + case TypeSpec#typedef.name of + {ExtMod,TypeName} -> + emit({indent(3),"'",ExtMod,"':'enc_",TypeName, + "'(H, Val, T)"}); + TypeName -> + emit({indent(3),"'enc_",TypeName,"'(H, Val, T)"}) + end + end, + case more_genfields(Rest) of + true -> + emit([";",nl]); + false -> + emit([".",nl]) + end, + gen_encode_objectfields(ClassName,Rest,ObjName,ObjectFields,ConstrAcc); +gen_encode_objectfields(ClassName,[_C|Cs],O,OF,Acc) -> + gen_encode_objectfields(ClassName,Cs,O,OF,Acc); +gen_encode_objectfields(_,[],_,_,Acc) -> + Acc. + + +% gen_encode_objectfields(Class,ObjName,[{FieldName,Type}|Rest],ConstrAcc) -> +% Fields = Class#objectclass.fields, + +% MaybeConstr = +% case is_typefield(Fields,FieldName) of +% true -> +% Def = Type#typedef.typespec, +% emit({"'enc_",ObjName,"'(",{asis,FieldName}, +% ", Val, Dummy) ->",nl}), + +% CAcc = +% case Type#typedef.name of +% {primitive,bif} -> +% gen_encode_prim(per,Def,"false","Val"), +% []; +% {constructed,bif} -> +% emit({" 'enc_",ObjName,'_',FieldName, +% "'(Val)"}), +% [{['enc_',ObjName,'_',FieldName],Def}]; +% {ExtMod,TypeName} -> +% emit({" '",ExtMod,"':'enc_",TypeName,"'(Val)"}), +% []; +% TypeName -> +% emit({" 'enc_",TypeName,"'(Val)"}), +% [] +% end, +% case more_genfields(Fields,Rest) of +% true -> +% emit({";",nl}); +% false -> +% emit({".",nl}) +% end, +% CAcc; +% {false,objectfield} -> +% emit({"'enc_",ObjName,"'(",{asis,FieldName}, +% ", Val, [H|T]) ->",nl}), +% case Type#typedef.name of +% {ExtMod,TypeName} -> +% emit({indent(3),"'",ExtMod,"':'enc_",TypeName, +% "'(H, Val, T)"}); +% TypeName -> +% emit({indent(3),"'enc_",TypeName,"'(H, Val, T)"}) +% end, +% case more_genfields(Fields,Rest) of +% true -> +% emit({";",nl}); +% false -> +% emit({".",nl}) +% end, +% []; +% {false,_} -> [] +% end, +% gen_encode_objectfields(Class,ObjName,Rest,MaybeConstr ++ ConstrAcc); +% gen_encode_objectfields(C,O,[H|T],Acc) -> +% gen_encode_objectfields(C,O,T,Acc); +% gen_encode_objectfields(_,_,[],Acc) -> +% Acc. + +% gen_encode_constr_type(Erules,[{Name,Def}|Rest]) -> +% emit({Name,"(Val) ->",nl}), +% InnerType = asn1ct_gen:get_inner(Def#type.def), +% asn1ct_gen:gen_encode_constructed(Erules,Name,InnerType,Def), +% gen_encode_constr_type(Erules,Rest); +gen_encode_constr_type(Erules,[TypeDef|Rest]) when record(TypeDef,typedef) -> + case is_already_generated(enc,TypeDef#typedef.name) of + true -> ok; + _ -> + Name = lists:concat(["enc_",TypeDef#typedef.name]), + emit({Name,"(Val) ->",nl}), + Def = TypeDef#typedef.typespec, + InnerType = asn1ct_gen:get_inner(Def#type.def), + asn1ct_gen:gen_encode_constructed(Erules,Name,InnerType,Def), + gen_encode_constr_type(Erules,Rest) + end; +gen_encode_constr_type(_,[]) -> + ok. + +gen_encode_field_call(ObjName,FieldName,Type) -> + Def = Type#typedef.typespec, + case Type#typedef.name of + {primitive,bif} -> + gen_encode_prim(per,Def,"false", + "Val"), + []; + {constructed,bif} -> + emit({" 'enc_",ObjName,'_',FieldName, + "'(Val)"}), + [Type#typedef{name=list_to_atom(lists:concat([ObjName,'_',FieldName]))}]; + {ExtMod,TypeName} -> + emit({" '",ExtMod,"':'enc_",TypeName, + "'(Val)"}), + []; + TypeName -> + emit({" 'enc_",TypeName,"'(Val)"}), + [] + end. + +gen_encode_default_call(ClassName,FieldName,Type) -> + CurrentMod = get(currmod), + InnerType = asn1ct_gen:get_inner(Type#type.def), + case asn1ct_gen:type(InnerType) of + {constructed,bif} -> +%% asn1ct_gen:gen_encode_constructed(Erules,Typename,InnerType,Type); + emit([" 'enc_",ClassName,'_',FieldName,"'(Val)"]), + [#typedef{name=list_to_atom(lists:concat([ClassName,'_',FieldName])), + typespec=Type}]; + {primitive,bif} -> + gen_encode_prim(per,Type,"false","Val"), + []; + #'Externaltypereference'{module=CurrentMod,type=Etype} -> + emit([" 'enc_",Etype,"'(Val)",nl]), + []; + #'Externaltypereference'{module=Emod,type=Etype} -> + emit([" '",Emod,"':'enc_",Etype,"'(Val)",nl]), + [] + end. + + +gen_decode_objectfields(ClassName,[{typefield,Name,OptOrMand}|Rest], + ObjName,ObjectFields,ConstrAcc) -> + EmitFuncClause = + fun(Bytes) -> + emit(["'dec_",ObjName,"'(",{asis,Name},",",Bytes, + ",_,_RestPrimFieldName) ->",nl]) + end, + MaybeConstr= + case {get_object_field(Name,ObjectFields),OptOrMand} of + {false,'MANDATORY'} -> %% this case is illegal + exit({error,{asn1,{"missing mandatory field in object", + ObjName}}}); + {false,'OPTIONAL'} -> + EmitFuncClause("_"), + emit([" asn1_NOVALUE"]), + []; + {false,{'DEFAULT',DefaultType}} -> + EmitFuncClause("Bytes"), + gen_decode_default_call(ClassName,Name,"Bytes",DefaultType); + {{Name,TypeSpec},_} -> + %% A specified field owerwrites any 'DEFAULT' or + %% 'OPTIONAL' field in the class + EmitFuncClause("Bytes"), + gen_decode_field_call(ObjName,Name,"Bytes",TypeSpec) + end, + case more_genfields(Rest) of + true -> + emit([";",nl]); + false -> + emit([".",nl]) + end, + gen_decode_objectfields(ClassName,Rest,ObjName,ObjectFields,MaybeConstr++ConstrAcc); +gen_decode_objectfields(ClassName,[{objectfield,Name,_,_,OptOrMand}|Rest], + ObjName,ObjectFields,ConstrAcc) -> + EmitFuncClause = + fun(Attrs) -> + emit(["'dec_",ObjName,"'(",{asis,Name}, + ",",Attrs,") ->",nl]) + end, +% emit(["'dec_",ObjName,"'(",{asis,Name}, +% ", Bytes,_,[H|T]) ->",nl]), + case {get_object_field(Name,ObjectFields),OptOrMand} of + {false,'MANDATORY'} -> + exit({error,{asn1,{"missing mandatory field in object", + ObjName}}}); + {false,'OPTIONAL'} -> + EmitFuncClause("_,_,_"), + emit([" exit({error,{'illegal use of missing field in object', ",Name, + "}})"]); + {false,{'DEFAULT',_DefaultObject}} -> + exit({error,{asn1,{"not implemented yet",Name}}}); + {{Name,TypeSpec},_} -> + EmitFuncClause("Bytes,_,[H|T]"), + case TypeSpec#typedef.name of + {ExtMod,TypeName} -> + emit({indent(3),"'",ExtMod,"':'dec_",TypeName, + "'(H, Bytes, telltype, T)"}); + TypeName -> + emit({indent(3),"'dec_",TypeName,"'(H, Bytes, telltype, T)"}) + end + end, + case more_genfields(Rest) of + true -> + emit([";",nl]); + false -> + emit([".",nl]) + end, + gen_decode_objectfields(ClassName,Rest,ObjName,ObjectFields,ConstrAcc); +gen_decode_objectfields(CN,[_C|Cs],O,OF,CAcc) -> + gen_decode_objectfields(CN,Cs,O,OF,CAcc); +gen_decode_objectfields(_,[],_,_,CAcc) -> + CAcc. + + +% gen_decode_objectfields(Class,ObjName,[{FieldName,Type}|Rest],ConstrAcc) -> +% Fields = Class#objectclass.fields, + +% MaybeConstr = +% case is_typefield(Fields,FieldName) of +% true -> +% Def = Type#typedef.typespec, +% emit({"'dec_",ObjName,"'(",{asis,FieldName}, +% ", Val, Telltype, RestPrimFieldName) ->",nl}), + +% CAcc = +% case Type#typedef.name of +% {primitive,bif} -> +% gen_dec_prim(per,Def,"Val"), +% []; +% {constructed,bif} -> +% emit({" 'dec_",ObjName,'_',FieldName, +% "'(Val, Telltype)"}), +% [{['dec_',ObjName,'_',FieldName],Def}]; +% {ExtMod,TypeName} -> +% emit({" '",ExtMod,"':'dec_",TypeName, +% "'(Val, Telltype)"}), +% []; +% TypeName -> +% emit({" 'dec_",TypeName,"'(Val, Telltype)"}), +% [] +% end, +% case more_genfields(Fields,Rest) of +% true -> +% emit({";",nl}); +% false -> +% emit({".",nl}) +% end, +% CAcc; +% {false,objectfield} -> +% emit({"'dec_",ObjName,"'(",{asis,FieldName}, +% ", Val, Telltype, [H|T]) ->",nl}), +% case Type#typedef.name of +% {ExtMod,TypeName} -> +% emit({indent(3),"'",ExtMod,"':'dec_",TypeName, +% "'(H, Val, Telltype, T)"}); +% TypeName -> +% emit({indent(3),"'dec_",TypeName, +% "'(H, Val, Telltype, T)"}) +% end, +% case more_genfields(Fields,Rest) of +% true -> +% emit({";",nl}); +% false -> +% emit({".",nl}) +% end, +% []; +% {false,_} -> +% [] +% end, +% gen_decode_objectfields(Class,ObjName,Rest,MaybeConstr ++ ConstrAcc); +% gen_decode_objectfields(C,O,[H|T],CAcc) -> +% gen_decode_objectfields(C,O,T,CAcc); +% gen_decode_objectfields(_,_,[],CAcc) -> +% CAcc. + + +gen_decode_field_call(ObjName,FieldName,Bytes,Type) -> + Def = Type#typedef.typespec, + case Type#typedef.name of + {primitive,bif} -> + gen_dec_prim(per,Def,Bytes), + []; + {constructed,bif} -> + emit({" 'dec_",ObjName,'_',FieldName, + "'(",Bytes,",telltype)"}), + [Type#typedef{name=list_to_atom(lists:concat([ObjName,'_',FieldName]))}]; + {ExtMod,TypeName} -> + emit({" '",ExtMod,"':'dec_",TypeName, + "'(",Bytes,", telltype)"}), + []; + TypeName -> + emit({" 'dec_",TypeName,"'(",Bytes,", telltype)"}), + [] + end. + +gen_decode_default_call(ClassName,FieldName,Bytes,Type) -> + CurrentMod = get(currmod), + InnerType = asn1ct_gen:get_inner(Type#type.def), + case asn1ct_gen:type(InnerType) of + {constructed,bif} -> + emit([" 'dec_",ClassName,'_',FieldName,"'(",Bytes,", telltype)"]), + [#typedef{name=list_to_atom(lists:concat([ClassName,'_',FieldName])), + typespec=Type}]; + {primitive,bif} -> + gen_dec_prim(per,Type,Bytes), + []; + #'Externaltypereference'{module=CurrentMod,type=Etype} -> + emit([" 'dec_",Etype,"'(",Bytes,", telltype)",nl]), + []; + #'Externaltypereference'{module=Emod,type=Etype} -> + emit([" '",Emod,"':'dec_",Etype,"'(",Bytes,", telltype)",nl]), + [] + end. + + +gen_decode_constr_type(Erules,[{Name,Def}|Rest]) -> + emit({Name,"(Bytes,_) ->",nl}), + InnerType = asn1ct_gen:get_inner(Def#type.def), + asn1ct_gen:gen_decode_constructed(Erules,Name,InnerType,Def), + gen_decode_constr_type(Erules,Rest); +gen_decode_constr_type(Erules,[TypeDef|Rest]) when record(TypeDef,typedef) -> + case is_already_generated(dec,TypeDef#typedef.name) of + true -> ok; + _ -> + gen_decode(Erules,TypeDef) + end, + gen_decode_constr_type(Erules,Rest); +gen_decode_constr_type(_,[]) -> + ok. + +% more_genfields(Fields,[]) -> +% false; +% more_genfields(Fields,[{FieldName,_}|T]) -> +% case is_typefield(Fields,FieldName) of +% true -> true; +% {false,objectfield} -> true; +% {false,_} -> more_genfields(Fields,T) +% end. + +more_genfields([]) -> + false; +more_genfields([Field|Fields]) -> + case element(1,Field) of + typefield -> + true; + objectfield -> + true; + _ -> + more_genfields(Fields) + end. + +% is_typefield(Fields,FieldName) -> +% case lists:keysearch(FieldName,2,Fields) of +% {value,Field} -> +% case element(1,Field) of +% typefield -> +% true; +% Other -> +% {false,Other} +% end; +% _ -> +% false +% end. +%% Object Set code generating for encoding and decoding +%% ---------------------------------------------------- +gen_objectset_code(Erules,ObjSet) -> + ObjSetName = ObjSet#typedef.name, + Def = ObjSet#typedef.typespec, +%% {ClassName,ClassDef} = Def#'ObjectSet'.class, + #'Externaltypereference'{module=ClassModule, + type=ClassName} = Def#'ObjectSet'.class, + ClassDef = asn1_db:dbget(ClassModule,ClassName), + UniqueFName = Def#'ObjectSet'.uniquefname, + Set = Def#'ObjectSet'.set, + emit({nl,nl,nl,"%%================================"}), + emit({nl,"%% ",ObjSetName}), + emit({nl,"%%================================",nl}), + case ClassName of + {_Module,ExtClassName} -> + gen_objset_code(Erules,ObjSetName,UniqueFName,Set, + ExtClassName,ClassDef); + _ -> + gen_objset_code(Erules,ObjSetName,UniqueFName,Set, + ClassName,ClassDef) + end, + emit(nl). + +gen_objset_code(Erules,ObjSetName,UniqueFName,Set,ClassName,ClassDef)-> + ClassFields = (ClassDef#classdef.typespec)#objectclass.fields, + InternalFuncs= + gen_objset_enc(ObjSetName,UniqueFName,Set,ClassName,ClassFields,1,[]), + gen_objset_dec(ObjSetName,UniqueFName,Set,ClassName,ClassFields,1), + gen_internal_funcs(Erules,InternalFuncs). + +%% gen_objset_enc iterates over the objects of the object set +gen_objset_enc(_,{unique,undefined},_,_,_,_,_) -> + %% There is no unique field in the class of this object set + %% don't bother about the constraint + []; +gen_objset_enc(ObjSName,UniqueName,[{ObjName,Val,Fields},T|Rest], + ClName,ClFields,NthObj,Acc)-> + emit({"'getenc_",ObjSName,"'(",{asis,UniqueName},",",{asis,Val}, + ") ->",nl}), + {InternalFunc,NewNthObj}= + case ObjName of + no_name -> + gen_inlined_enc_funs(Fields,ClFields,ObjSName,NthObj); + _Other -> + emit({" fun 'enc_",ObjName,"'/3"}), + {[],0} + end, + emit({";",nl}), + gen_objset_enc(ObjSName,UniqueName,[T|Rest],ClName,ClFields, + NewNthObj,InternalFunc ++ Acc); +gen_objset_enc(ObjSetName,UniqueName, + [{ObjName,Val,Fields}],_ClName,ClFields,NthObj,Acc) -> + + emit({"'getenc_",ObjSetName,"'(",{asis,UniqueName},",", + {asis,Val},") ->",nl}), + {InternalFunc,_}= + case ObjName of + no_name -> + gen_inlined_enc_funs(Fields,ClFields,ObjSetName,NthObj); + _Other -> + emit({" fun 'enc_",ObjName,"'/3"}), + {[],NthObj} + end, + emit({".",nl,nl}), + InternalFunc++Acc; +gen_objset_enc(ObjSetName,_UniqueName,['EXTENSIONMARK'],_ClName, + _ClFields,_NthObj,Acc) -> + emit({"'getenc_",ObjSetName,"'(_, _) ->",nl}), + emit({indent(3),"fun(_, Val, _) ->",nl}), + emit({indent(6),"[{octets,Val}]",nl}), + emit({indent(3),"end.",nl,nl}), + Acc; +gen_objset_enc(_,_,[],_,_,_,Acc) -> + Acc. + +%% gen_inlined_enc_funs for each object iterates over all fields of a +%% class, and for each typefield it checks if the object has that +%% field and emits the proper code. +gen_inlined_enc_funs(Fields,[{typefield,Name,_}|Rest],ObjSetName,NthObj) -> + InternalDefFunName = asn1ct_gen:list2name([NthObj,Name,ObjSetName]), + case lists:keysearch(Name,1,Fields) of + {value,{_,Type}} when record(Type,type) -> + emit({indent(3),"fun(Type, Val, _) ->",nl, + indent(6),"case Type of",nl}), + {Ret,N}=emit_inner_of_fun(Type,InternalDefFunName), + gen_inlined_enc_funs1(Fields,Rest,ObjSetName,NthObj+N,Ret); + {value,{_,Type}} when record(Type,typedef) -> + emit({indent(3),"fun(Type, Val, _) ->",nl, + indent(6),"case Type of",nl}), + emit({indent(9),{asis,Name}," ->",nl}), + {Ret,N} = emit_inner_of_fun(Type,InternalDefFunName), + gen_inlined_enc_funs1(Fields,Rest,ObjSetName,NthObj+N,Ret); + false -> + gen_inlined_enc_funs(Fields,Rest,ObjSetName,NthObj) + end; +gen_inlined_enc_funs(Fields,[_H|Rest],ObjSetName,NthObj) -> + gen_inlined_enc_funs(Fields,Rest,ObjSetName,NthObj); +gen_inlined_enc_funs(_,[],_,NthObj) -> + {[],NthObj}. + +gen_inlined_enc_funs1(Fields,[{typefield,Name,_}|Rest],ObjSetName, + NthObj,Acc) -> + InternalDefFunName = asn1ct_gen:list2name([NthObj,Name,ObjSetName]), + {Acc2,NAdd}= + case lists:keysearch(Name,1,Fields) of + {value,{_,Type}} when record(Type,type) -> + emit({";",nl}), + {Ret,N}=emit_inner_of_fun(Type,InternalDefFunName), + {Ret++Acc,N}; + {value,{_,Type}} when record(Type,typedef) -> + emit({";",nl,indent(9),{asis,Name}," ->",nl}), + {Ret,N}=emit_inner_of_fun(Type,InternalDefFunName), + {Ret++Acc,N}; + false -> + {Acc,0} + end, + gen_inlined_enc_funs1(Fields,Rest,ObjSetName,NthObj+NAdd,Acc2); +gen_inlined_enc_funs1(Fields,[_H|Rest],ObjSetName,NthObj,Acc)-> + gen_inlined_enc_funs1(Fields,Rest,ObjSetName,NthObj,Acc); +gen_inlined_enc_funs1(_,[],_,NthObj,Acc) -> + emit({nl,indent(6),"end",nl}), + emit({indent(3),"end"}), + {Acc,NthObj}. + +emit_inner_of_fun(TDef=#typedef{name={ExtMod,Name},typespec=Type}, + InternalDefFunName) -> + case {ExtMod,Name} of + {primitive,bif} -> + emit(indent(12)), + gen_encode_prim(per,Type,dotag,"Val"), + {[],0}; + {constructed,bif} -> + emit([indent(12),"'enc_", + InternalDefFunName,"'(Val)"]), + {[TDef#typedef{name=InternalDefFunName}],1}; + _ -> + emit({indent(12),"'",ExtMod,"':'enc_",Name,"'(Val)"}), + {[],0} + end; +emit_inner_of_fun(#typedef{name=Name},_) -> + emit({indent(12),"'enc_",Name,"'(Val)"}), + {[],0}; +emit_inner_of_fun(Type,_) when record(Type,type) -> + CurrMod = get(currmod), + case Type#type.def of + Def when atom(Def) -> + emit({indent(9),Def," ->",nl,indent(12)}), + gen_encode_prim(erules,Type,dotag,"Val"); + TRef when record(TRef,typereference) -> + T = TRef#typereference.val, + emit({indent(9),T," ->",nl,indent(12),"'enc_",T,"'(Val)"}); + #'Externaltypereference'{module=CurrMod,type=T} -> + emit({indent(9),T," ->",nl,indent(12),"'enc_",T,"'(Val)"}); + #'Externaltypereference'{module=ExtMod,type=T} -> + emit({indent(9),T," ->",nl,indent(12),ExtMod,":'enc_", + T,"'(Val)"}) + end, + {[],0}. + +indent(N) -> + lists:duplicate(N,32). % 32 = space + + +gen_objset_dec(_,{unique,undefined},_,_,_,_) -> + %% There is no unique field in the class of this object set + %% don't bother about the constraint + ok; +gen_objset_dec(ObjSName,UniqueName,[{ObjName,Val,Fields},T|Rest],ClName, + ClFields,NthObj)-> + + emit({"'getdec_",ObjSName,"'(",{asis,UniqueName},",",{asis,Val}, + ") ->",nl}), + NewNthObj= + case ObjName of + no_name -> + gen_inlined_dec_funs(Fields,ClFields,ObjSName,NthObj); + _Other -> + emit({" fun 'dec_",ObjName,"'/4"}), + NthObj + end, + emit({";",nl}), + gen_objset_dec(ObjSName,UniqueName,[T|Rest],ClName,ClFields,NewNthObj); +gen_objset_dec(ObjSetName,UniqueName,[{ObjName,Val,Fields}],_ClName, + ClFields,NthObj) -> + + emit({"'getdec_",ObjSetName,"'(",{asis,UniqueName},",",{asis,Val}, + ") ->",nl}), + case ObjName of + no_name -> + gen_inlined_dec_funs(Fields,ClFields,ObjSetName,NthObj); + _Other -> + emit({" fun 'dec_",ObjName,"'/4"}) + end, + emit({".",nl,nl}), + ok; +gen_objset_dec(ObjSetName,_UniqueName,['EXTENSIONMARK'],_ClName,_ClFields, + _NthObj) -> + emit({"'getdec_",ObjSetName,"'(_, _) ->",nl}), + emit({indent(3),"fun(Attr1, Bytes, _,_) ->",nl}), +%% emit({indent(6),"?RT_PER:decode_open_type(Bytes,[])",nl}), + emit({indent(6),"{Bytes,Attr1}",nl}), + emit({indent(3),"end.",nl,nl}), + ok; +gen_objset_dec(_,_,[],_,_,_) -> + ok. + +gen_inlined_dec_funs(Fields,[{typefield,Name,_}|Rest], + ObjSetName,NthObj) -> + InternalDefFunName = [NthObj,Name,ObjSetName], + case lists:keysearch(Name,1,Fields) of + {value,{_,Type}} when record(Type,type) -> + emit({indent(3),"fun(Type, Val, _, _) ->",nl, + indent(6),"case Type of",nl}), + N=emit_inner_of_decfun(Type,InternalDefFunName), + gen_inlined_dec_funs1(Fields,Rest,ObjSetName,NthObj+N); + {value,{_,Type}} when record(Type,typedef) -> + emit({indent(3),"fun(Type, Val, _, _) ->",nl, + indent(6),"case Type of",nl}), + emit({indent(9),{asis,Name}," ->",nl}), + N=emit_inner_of_decfun(Type,InternalDefFunName), + gen_inlined_dec_funs1(Fields,Rest,ObjSetName,NthObj+N); + false -> + gen_inlined_dec_funs(Fields,Rest,ObjSetName,NthObj) + end; +gen_inlined_dec_funs(Fields,[_|Rest],ObjSetName,NthObj) -> + gen_inlined_dec_funs(Fields,Rest,ObjSetName,NthObj); +gen_inlined_dec_funs(_,[],_,NthObj) -> + NthObj. + +gen_inlined_dec_funs1(Fields,[{typefield,Name,_}|Rest], + ObjSetName,NthObj) -> + InternalDefFunName = [NthObj,Name,ObjSetName], + N=case lists:keysearch(Name,1,Fields) of + {value,{_,Type}} when record(Type,type) -> + emit({";",nl}), + emit_inner_of_decfun(Type,InternalDefFunName); + {value,{_,Type}} when record(Type,typedef) -> + emit({";",nl,indent(9),{asis,Name}," ->",nl}), + emit_inner_of_decfun(Type,InternalDefFunName); + false -> + 0 + end, + gen_inlined_dec_funs1(Fields,Rest,ObjSetName,NthObj+N); +gen_inlined_dec_funs1(Fields,[_|Rest],ObjSetName,NthObj)-> + gen_inlined_dec_funs1(Fields,Rest,ObjSetName,NthObj); +gen_inlined_dec_funs1(_,[],_,NthObj) -> + emit({nl,indent(6),"end",nl}), + emit({indent(3),"end"}), + NthObj. + +emit_inner_of_decfun(#typedef{name={ExtName,Name},typespec=Type}, + InternalDefFunName) -> + case {ExtName,Name} of + {primitive,bif} -> + emit(indent(12)), + gen_dec_prim(per,Type,"Val"), + 0; + {constructed,bif} -> + emit({indent(12),"'dec_", + asn1ct_gen:list2name(InternalDefFunName),"'(Val)"}), + 1; + _ -> + emit({indent(12),"'",ExtName,"':'dec_",Name,"'(Val, telltype)"}), + 0 + end; +emit_inner_of_decfun(#typedef{name=Name},_) -> + emit({indent(12),"'dec_",Name,"'(Val, telltype)"}), + 0; +emit_inner_of_decfun(Type,_) when record(Type,type) -> + CurrMod = get(currmod), + case Type#type.def of + Def when atom(Def) -> + emit({indent(9),Def," ->",nl,indent(12)}), + gen_dec_prim(erules,Type,"Val"); + TRef when record(TRef,typereference) -> + T = TRef#typereference.val, + emit({indent(9),T," ->",nl,indent(12),"'dec_",T,"'(Val)"}); + #'Externaltypereference'{module=CurrMod,type=T} -> + emit({indent(9),T," ->",nl,indent(12),"'dec_",T,"'(Val)"}); + #'Externaltypereference'{module=ExtMod,type=T} -> + emit({indent(9),T," ->",nl,indent(12),ExtMod,":'dec_", + T,"'(Val)"}) + end, + 0. + + +gen_internal_funcs(_,[]) -> + ok; +gen_internal_funcs(Erules,[TypeDef|Rest]) -> + gen_encode_user(Erules,TypeDef), + emit([nl,nl,"'dec_",TypeDef#typedef.name,"'(Bytes) ->",nl]), + gen_decode_user(Erules,TypeDef), + gen_internal_funcs(Erules,Rest). + + + +%% DECODING ***************************** +%%*************************************** + + +gen_decode(Erules,Type) when record(Type,typedef) -> + D = Type, + emit({nl,nl}), + emit({"'dec_",Type#typedef.name,"'(Bytes,_) ->",nl}), + dbdec(Type#typedef.name), + gen_decode_user(Erules,D). + +gen_decode(Erules,Tname,#'ComponentType'{name=Cname,typespec=Type}) -> + NewTname = [Cname|Tname], + gen_decode(Erules,NewTname,Type); + +gen_decode(Erules,Typename,Type) when record(Type,type) -> + InnerType = asn1ct_gen:get_inner(Type#type.def), + case asn1ct_gen:type(InnerType) of + {constructed,bif} -> + ObjFun = + case Type#type.tablecinf of + [{objfun,_}|_R] -> + ", ObjFun"; + _ -> + "" + end, + emit({nl,"'dec_",asn1ct_gen:list2name(Typename), + "'(Bytes,_",ObjFun,") ->",nl}), + dbdec(Typename), + asn1ct_gen:gen_decode_constructed(Erules,Typename,InnerType,Type); + _ -> + true + end. + +dbdec(Type) when list(Type)-> + demit({"io:format(\"decoding: ",asn1ct_gen:list2name(Type),"~w~n\",[Bytes]),",nl}); +dbdec(Type) -> + demit({"io:format(\"decoding: ",{asis,Type},"~w~n\",[Bytes]),",nl}). + +gen_decode_user(Erules,D) when record(D,typedef) -> + CurrMod = get(currmod), + Typename = [D#typedef.name], + Def = D#typedef.typespec, + InnerType = asn1ct_gen:get_inner(Def#type.def), + case asn1ct_gen:type(InnerType) of + {primitive,bif} -> + gen_dec_prim(Erules,Def,"Bytes"), + emit({".",nl,nl}); + 'ASN1_OPEN_TYPE' -> + gen_dec_prim(Erules,Def#type{def='ASN1_OPEN_TYPE'},"Bytes"), + emit({".",nl,nl}); + {constructed,bif} -> + asn1ct_gen:gen_decode_constructed(Erules,Typename,InnerType,D); + #typereference{val=Dname} -> + emit({"'dec_",Dname,"'(Bytes,telltype)"}), + emit({".",nl,nl}); + #'Externaltypereference'{module=CurrMod,type=Etype} -> + emit({"'dec_",Etype,"'(Bytes,telltype).",nl,nl}); + #'Externaltypereference'{module=Emod,type=Etype} -> + emit({"'",Emod,"':'dec_",Etype,"'(Bytes,telltype).",nl,nl}); + Other -> + exit({error,{asn1,{unknown,Other}}}) + end. + + +gen_dec_prim(_Erules,Att,BytesVar) -> + Typename = Att#type.def, + Constraint = Att#type.constraint, + case Typename of + 'INTEGER' -> + emit({"?RT_PER:decode_integer(",BytesVar,",", + {asis,Constraint},")"}); + {'INTEGER',NamedNumberList} -> + emit({"?RT_PER:decode_integer(",BytesVar,",", + {asis,Constraint},",", + {asis,NamedNumberList},")"}); + {'BIT STRING',NamedNumberList} -> + case get(compact_bit_string) of + true -> + emit({"?RT_PER:decode_compact_bit_string(", + BytesVar,",",{asis,Constraint},",", + {asis,NamedNumberList},")"}); + _ -> + emit({"?RT_PER:decode_bit_string(",BytesVar,",", + {asis,Constraint},",", + {asis,NamedNumberList},")"}) + end; + 'NULL' -> + emit({"?RT_PER:decode_null(", + BytesVar,")"}); + 'OBJECT IDENTIFIER' -> + emit({"?RT_PER:decode_object_identifier(", + BytesVar,")"}); + 'ObjectDescriptor' -> + emit({"?RT_PER:decode_ObjectDescriptor(", + BytesVar,")"}); + {'ENUMERATED',{NamedNumberList1,NamedNumberList2}} -> + NewTup = {list_to_tuple([X||{X,_} <- NamedNumberList1]), + list_to_tuple([X||{X,_} <- NamedNumberList2])}, + NewC = [{'ValueRange',{0,size(element(1,NewTup))-1}}], + emit({"?RT_PER:decode_enumerated(",BytesVar,",", + {asis,NewC},",", + {asis,NewTup},")"}); + {'ENUMERATED',NamedNumberList} -> + NewTup = list_to_tuple([X||{X,_} <- NamedNumberList]), + NewC = [{'ValueRange',{0,size(NewTup)-1}}], + emit({"?RT_PER:decode_enumerated(",BytesVar,",", + {asis,NewC},",", + {asis,NewTup},")"}); + 'BOOLEAN'-> + emit({"?RT_PER:decode_boolean(",BytesVar,")"}); + 'OCTET STRING' -> + emit({"?RT_PER:decode_octet_string(",BytesVar,",", + {asis,Constraint},")"}); + 'NumericString' -> + emit({"?RT_PER:decode_NumericString(",BytesVar,",", + {asis,Constraint},")"}); + 'TeletexString' -> + emit({"?RT_PER:decode_TeletexString(",BytesVar,",", + {asis,Constraint},")"}); + 'VideotexString' -> + emit({"?RT_PER:decode_VideotexString(",BytesVar,",", + {asis,Constraint},")"}); + 'UTCTime' -> + emit({"?RT_PER:decode_VisibleString(",BytesVar,",", + {asis,Constraint},")"}); + 'GeneralizedTime' -> + emit({"?RT_PER:decode_VisibleString(",BytesVar,",", + {asis,Constraint},")"}); + 'GraphicString' -> + emit({"?RT_PER:decode_GraphicString(",BytesVar,",", + {asis,Constraint},")"}); + 'VisibleString' -> + emit({"?RT_PER:decode_VisibleString(",BytesVar,",", + {asis,Constraint},")"}); + 'GeneralString' -> + emit({"?RT_PER:decode_GeneralString(",BytesVar,",", + {asis,Constraint},")"}); + 'PrintableString' -> + emit({"?RT_PER:decode_PrintableString(",BytesVar,",",{asis,Constraint},")"}); + 'IA5String' -> + emit({"?RT_PER:decode_IA5String(",BytesVar,",",{asis,Constraint},")"}); + 'BMPString' -> + emit({"?RT_PER:decode_BMPString(",BytesVar,",",{asis,Constraint},")"}); + 'UniversalString' -> + emit({"?RT_PER:decode_UniversalString(",BytesVar,",",{asis,Constraint},")"}); + 'ANY' -> + emit(["?RT_PER:decode_open_type(",BytesVar,",", + {asis,Constraint}, ")"]); + 'ASN1_OPEN_TYPE' -> + case Constraint of + [#'Externaltypereference'{type=Tname}] -> + emit(["fun(FBytes) ->",nl, + " {XTerm,XBytes} = "]), + emit(["?RT_PER:decode_open_type(FBytes,[]),",nl]), + emit([" {YTerm,_} = dec_",Tname,"(XTerm,mandatory),",nl]), + emit([" {YTerm,XBytes} end(",BytesVar,")"]); + [#type{def=#'Externaltypereference'{type=Tname}}] -> + emit(["fun(FBytes) ->",nl, + " {XTerm,XBytes} = "]), + emit(["?RT_PER:decode_open_type(FBytes,[]),",nl]), + emit([" {YTerm,_} = dec_",Tname,"(XTerm,mandatory),",nl]), + emit([" {YTerm,XBytes} end(",BytesVar,")"]); + _ -> + emit(["?RT_PER:decode_open_type(",BytesVar,",[])"]) + end; + Other -> + exit({'cant decode' ,Other}) + end. + + +is_already_generated(Operation,Name) -> + case get(class_default_type) of + undefined -> + put(class_default_type,[{Operation,Name}]), + false; + GeneratedList -> + case lists:member({Operation,Name},GeneratedList) of + true -> + true; + false -> + put(class_default_type,[{Operation,Name}|GeneratedList]), + false + end + end. + +get_class_fields(#classdef{typespec=ObjClass}) -> + ObjClass#objectclass.fields; +get_class_fields(#objectclass{fields=Fields}) -> + Fields; +get_class_fields(_) -> + []. + + +get_object_field(Name,ObjectFields) -> + case lists:keysearch(Name,1,ObjectFields) of + {value,Field} -> Field; + false -> false + end. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_gen_per_rt2ct.erl b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_gen_per_rt2ct.erl new file mode 100644 index 0000000000..ddfa124048 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_gen_per_rt2ct.erl @@ -0,0 +1,1811 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: asn1ct_gen_per_rt2ct.erl,v 1.1 2008/12/17 09:53:30 mikpe Exp $ +%% +-module(asn1ct_gen_per_rt2ct). + +%% Generate erlang module which handles (PER) encode and decode for +%% all types in an ASN.1 module + +-include("asn1_records.hrl"). +%-compile(export_all). + +-export([pgen/4,gen_dec_prim/3,gen_encode_prim/4]). +-export([gen_obj_code/3,gen_objectset_code/2]). +-export([gen_decode/2, gen_decode/3]). +-export([gen_encode/2, gen_encode/3]). + +-import(asn1ct_gen, [emit/1,demit/1]). +-import(asn1ct_gen_per, [is_already_generated/2,more_genfields/1, + get_class_fields/1,get_object_field/2]). + +%% pgen(Erules, Module, TypeOrVal) +%% Generate Erlang module (.erl) and (.hrl) file corresponding to an ASN.1 module +%% .hrl file is only generated if necessary +%% Erules = per | ber +%% Module = atom() +%% TypeOrVal = {TypeList,ValueList} +%% TypeList = ValueList = [atom()] + +pgen(OutFile,Erules,Module,TypeOrVal) -> + asn1ct_gen:pgen_module(OutFile,Erules,Module,TypeOrVal,true). + + +%% Generate ENCODING ****************************** +%%****************************************x + + +gen_encode(Erules,Type) when record(Type,typedef) -> + gen_encode_user(Erules,Type). + +gen_encode(Erules,Typename,#'ComponentType'{name=Cname,typespec=Type}) -> + NewTypename = [Cname|Typename], + gen_encode(Erules,NewTypename,Type); + +gen_encode(Erules,Typename,Type) when record(Type,type) -> + InnerType = asn1ct_gen:get_inner(Type#type.def), + ObjFun = + case lists:keysearch(objfun,1,Type#type.tablecinf) of + {value,{_,_Name}} -> + ", ObjFun"; + false -> + "" + end, + case asn1ct_gen:type(InnerType) of + {constructed,bif} -> + case InnerType of + 'SET' -> + true; + 'SEQUENCE' -> + true; + _ -> + emit({nl,"'enc_",asn1ct_gen:list2name(Typename), + "'({'",asn1ct_gen:list2name(Typename), + "',Val}",ObjFun,") ->",nl}), + emit({"'enc_",asn1ct_gen:list2name(Typename), + "'(Val",ObjFun,");",nl,nl}) + end, + emit({"'enc_",asn1ct_gen:list2name(Typename),"'(Val",ObjFun, + ") ->",nl}), + asn1ct_gen:gen_encode_constructed(Erules,Typename,InnerType,Type); + _ -> + true + end. + + +gen_encode_user(Erules,D) when record(D,typedef) -> + CurrMod = get(currmod), + Typename = [D#typedef.name], + Def = D#typedef.typespec, + InnerType = asn1ct_gen:get_inner(Def#type.def), + case InnerType of + 'SET' -> true; + 'SEQUENCE' -> true; + _ -> + emit({nl,"'enc_",asn1ct_gen:list2name(Typename),"'({'",asn1ct_gen:list2name(Typename),"',Val}) ->",nl}), + emit({"'enc_",asn1ct_gen:list2name(Typename),"'(Val);",nl,nl}) + end, + emit({"'enc_",asn1ct_gen:list2name(Typename),"'(Val) ->",nl}), + case asn1ct_gen:type(InnerType) of + {primitive,bif} -> + gen_encode_prim(Erules,Def,"false"), + emit({".",nl}); + 'ASN1_OPEN_TYPE' -> + gen_encode_prim(Erules,Def#type{def='ASN1_OPEN_TYPE'},"false"), + emit({".",nl}); + {constructed,bif} -> + asn1ct_gen:gen_encode_constructed(Erules,Typename,InnerType,D); + #'Externaltypereference'{module=CurrMod,type=Etype} -> + emit({"'enc_",Etype,"'(Val).",nl,nl}); + #'Externaltypereference'{module=Emod,type=Etype} -> + emit({"'",Emod,"':'enc_",Etype,"'(Val).",nl,nl}); + #typereference{val=Ename} -> + emit({"'enc_",Ename,"'(Val).",nl,nl}); + {notype,_} -> + emit({"'enc_",InnerType,"'(Val).",nl,nl}) + end. + + +gen_encode_prim(Erules,D,DoTag) -> + Value = case asn1ct_name:active(val) of + true -> + asn1ct_gen:mk_var(asn1ct_name:curr(val)); + false -> + "Val" + end, + gen_encode_prim(Erules,D,DoTag,Value). + + + + + +gen_encode_prim(_Erules,D,_DoTag,Value) when record(D,type) -> + Constraint = D#type.constraint, + case D#type.def of + 'INTEGER' -> + EffectiveConstr = effective_constraint(integer,Constraint), + emit([" %%INTEGER with effective constraint: ", + {asis,EffectiveConstr},nl]), + emit_enc_integer(EffectiveConstr,Value); + {'INTEGER',NamedNumberList} -> + EffectiveConstr = effective_constraint(integer,Constraint), + %% maybe an emit_enc_NNL_integer + emit([" %%INTEGER with effective constraint: ", + {asis,EffectiveConstr},nl]), + emit_enc_integer_NNL(EffectiveConstr,Value,NamedNumberList); + {'ENUMERATED',{Nlist1,Nlist2}} -> + NewList = lists:concat([[{0,X}||{X,_} <- Nlist1],['EXT_MARK'],[{1,X}||{X,_} <- Nlist2]]), + NewC = [{'ValueRange',{0,length(Nlist1)-1}}], + emit(["case (case ",Value," of {_,_}->element(2,",Value,");_->", + Value," end) of",nl]), + emit_enc_enumerated_cases(NewC, NewList++[{asn1_enum,length(Nlist1)-1}], 0); + {'ENUMERATED',NamedNumberList} -> + NewList = [X||{X,_} <- NamedNumberList], + NewC = effective_constraint(integer, + [{'ValueRange', + {0,length(NewList)-1}}]), + NewVal = enc_enum_cases(Value,NewList), + emit_enc_integer(NewC,NewVal); + {'BIT STRING',NamedNumberList} -> + EffectiveC = effective_constraint(bitstring,Constraint), + case EffectiveC of + 0 -> emit({"[]"}); + _ -> + emit({"?RT_PER:encode_bit_string(", + {asis,EffectiveC},",",Value,",", + {asis,NamedNumberList},")"}) + end; + 'NULL' -> + emit({"?RT_PER:encode_null(",Value,")"}); + 'OBJECT IDENTIFIER' -> + emit({"?RT_PER:encode_object_identifier(",Value,")"}); + 'ObjectDescriptor' -> + emit({"?RT_PER:encode_ObjectDescriptor(",{asis,Constraint}, + ",",Value,")"}); + 'BOOLEAN' -> +% emit({"?RT_PER:encode_boolean(",Value,")"}); + emit({"case ",Value," of",nl, +% " true -> {bits,1,1};",nl, + " true -> [1];",nl, +% " false -> {bits,1,0};",nl, + " false -> [0];",nl, + " _ -> exit({error,{asn1,{encode_boolean,",Value,"}}})",nl, + "end"}); + 'OCTET STRING' -> + emit_enc_octet_string(Constraint,Value); + + 'NumericString' -> + emit_enc_known_multiplier_string('NumericString',Constraint,Value); + 'TeletexString' -> + emit({"?RT_PER:encode_TeletexString(",{asis,Constraint},",",Value,")"}); + 'VideotexString' -> + emit({"?RT_PER:encode_VideotexString(",{asis,Constraint},",",Value,")"}); + 'UTCTime' -> + emit_enc_known_multiplier_string('VisibleString',Constraint,Value); + 'GeneralizedTime' -> + emit_enc_known_multiplier_string('VisibleString',Constraint,Value); + 'GraphicString' -> + emit({"?RT_PER:encode_GraphicString(",{asis,Constraint},",",Value,")"}); + 'VisibleString' -> + emit_enc_known_multiplier_string('VisibleString',Constraint,Value); + 'GeneralString' -> + emit({"?RT_PER:encode_GeneralString(",{asis,Constraint},",",Value,")"}); + 'PrintableString' -> + emit_enc_known_multiplier_string('PrintableString',Constraint,Value); + 'IA5String' -> + emit_enc_known_multiplier_string('IA5String',Constraint,Value); + 'BMPString' -> + emit_enc_known_multiplier_string('BMPString',Constraint,Value); + 'UniversalString' -> + emit_enc_known_multiplier_string('UniversalString',Constraint,Value); + 'ANY' -> + emit(["?RT_PER:encode_open_type(", {asis,Constraint}, ",", + Value, ")"]); + 'ASN1_OPEN_TYPE' -> + NewValue = case Constraint of + [#'Externaltypereference'{type=Tname}] -> + io_lib:format( + "?RT_PER:complete(enc_~s(~s))",[Tname,Value]); + [#type{def=#'Externaltypereference'{type=Tname}}] -> + io_lib:format( + "?RT_PER:complete(enc_~s(~s))",[Tname,Value]); + _ -> Value + end, + emit(["?RT_PER:encode_open_type(", {asis,Constraint}, ",", + NewValue, ")"]); + XX -> + exit({asn1_error,nyi,XX}) + end. + +emit_enc_known_multiplier_string(StringType,C,Value) -> + SizeC = + case get_constraint(C,'SizeConstraint') of + L when list(L) -> {lists:min(L),lists:max(L)}; + L -> L + end, + PAlphabC = get_constraint(C,'PermittedAlphabet'), + case {StringType,PAlphabC} of + {'UniversalString',{_,_}} -> + exit({error,{asn1,{'not implemented',"UniversalString with " + "PermittedAlphabet constraint"}}}); + {'BMPString',{_,_}} -> + exit({error,{asn1,{'not implemented',"BMPString with " + "PermittedAlphabet constraint"}}}); + _ -> ok + end, + NumBits = get_NumBits(C,StringType), + CharOutTab = get_CharOutTab(C,StringType), + %% NunBits and CharOutTab for chars_encode + emit_enc_k_m_string(StringType,SizeC,NumBits,CharOutTab,Value). + +emit_enc_k_m_string(_StringType,0,_NumBits,_CharOutTab,_Value) -> + emit({"[]"}); +emit_enc_k_m_string(StringType,SizeC,NumBits,CharOutTab,Value) -> + emit({"?RT_PER:encode_known_multiplier_string(",{asis,StringType},",", + {asis,SizeC},",",NumBits,",",{asis,CharOutTab},",",Value,")"}). + +emit_dec_known_multiplier_string(StringType,C,BytesVar) -> + SizeC = get_constraint(C,'SizeConstraint'), + PAlphabC = get_constraint(C,'PermittedAlphabet'), + case {StringType,PAlphabC} of + {'BMPString',{_,_}} -> + exit({error,{asn1, + {'not implemented', + "BMPString with PermittedAlphabet " + "constraint"}}}); + _ -> + ok + end, + NumBits = get_NumBits(C,StringType), + CharInTab = get_CharInTab(C,StringType), + case SizeC of + 0 -> + emit({"{[],",BytesVar,"}"}); + _ -> + emit({"?RT_PER:decode_known_multiplier_string(", + {asis,StringType},",",{asis,SizeC},",",NumBits, + ",",{asis,CharInTab},",",BytesVar,")"}) + end. + + +%% copied from run time module + +get_CharOutTab(C,StringType) -> + get_CharTab(C,StringType,out). + +get_CharInTab(C,StringType) -> + get_CharTab(C,StringType,in). + +get_CharTab(C,StringType,InOut) -> + case get_constraint(C,'PermittedAlphabet') of + {'SingleValue',Sv} -> + get_CharTab2(C,StringType,hd(Sv),lists:max(Sv),Sv,InOut); + no -> + case StringType of + 'IA5String' -> + {0,16#7F,notab}; + 'VisibleString' -> + get_CharTab2(C,StringType,16#20,16#7F,notab,InOut); + 'PrintableString' -> + Chars = lists:sort( + " '()+,-./0123456789:=?ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"), + get_CharTab2(C,StringType,hd(Chars),lists:max(Chars),Chars,InOut); + 'NumericString' -> + get_CharTab2(C,StringType,16#20,$9," 0123456789",InOut); + 'UniversalString' -> + {0,16#FFFFFFFF,notab}; + 'BMPString' -> + {0,16#FFFF,notab} + end + end. + +get_CharTab2(C,StringType,Min,Max,Chars,InOut) -> + BitValMax = (1 bsl get_NumBits(C,StringType))-1, + if + Max =< BitValMax -> + {0,Max,notab}; + true -> + case InOut of + out -> + {Min,Max,create_char_tab(Min,Chars)}; + in -> + {Min,Max,list_to_tuple(Chars)} + end + end. + +create_char_tab(Min,L) -> + list_to_tuple(create_char_tab(Min,L,0)). +create_char_tab(Min,[Min|T],V) -> + [V|create_char_tab(Min+1,T,V+1)]; +create_char_tab(_Min,[],_V) -> + []; +create_char_tab(Min,L,V) -> + [false|create_char_tab(Min+1,L,V)]. + +get_NumBits(C,StringType) -> + case get_constraint(C,'PermittedAlphabet') of + {'SingleValue',Sv} -> + charbits(length(Sv),aligned); + no -> + case StringType of + 'IA5String' -> + charbits(128,aligned); % 16#00..16#7F + 'VisibleString' -> + charbits(95,aligned); % 16#20..16#7E + 'PrintableString' -> + charbits(74,aligned); % [$\s,$',$(,$),$+,$,,$-,$.,$/,"0123456789",$:,$=,$?,$A..$Z,$a..$z + 'NumericString' -> + charbits(11,aligned); % $ ,"0123456789" + 'UniversalString' -> + 32; + 'BMPString' -> + 16 + end + end. + +charbits(NumOfChars,aligned) -> + case charbits(NumOfChars) of + 1 -> 1; + 2 -> 2; + B when B =< 4 -> 4; + B when B =< 8 -> 8; + B when B =< 16 -> 16; + B when B =< 32 -> 32 + end. + +charbits(NumOfChars) when NumOfChars =< 2 -> 1; +charbits(NumOfChars) when NumOfChars =< 4 -> 2; +charbits(NumOfChars) when NumOfChars =< 8 -> 3; +charbits(NumOfChars) when NumOfChars =< 16 -> 4; +charbits(NumOfChars) when NumOfChars =< 32 -> 5; +charbits(NumOfChars) when NumOfChars =< 64 -> 6; +charbits(NumOfChars) when NumOfChars =< 128 -> 7; +charbits(NumOfChars) when NumOfChars =< 256 -> 8; +charbits(NumOfChars) when NumOfChars =< 512 -> 9; +charbits(NumOfChars) when NumOfChars =< 1024 -> 10; +charbits(NumOfChars) when NumOfChars =< 2048 -> 11; +charbits(NumOfChars) when NumOfChars =< 4096 -> 12; +charbits(NumOfChars) when NumOfChars =< 8192 -> 13; +charbits(NumOfChars) when NumOfChars =< 16384 -> 14; +charbits(NumOfChars) when NumOfChars =< 32768 -> 15; +charbits(NumOfChars) when NumOfChars =< 65536 -> 16; +charbits(NumOfChars) when integer(NumOfChars) -> + 16 + charbits1(NumOfChars bsr 16). + +charbits1(0) -> + 0; +charbits1(NumOfChars) -> + 1 + charbits1(NumOfChars bsr 1). + +%% copied from run time module + +emit_enc_octet_string(Constraint,Value) -> + case get_constraint(Constraint,'SizeConstraint') of + 0 -> + emit({" []"}); + 1 -> + asn1ct_name:new(tmpval), + emit({" begin",nl}), + emit({" [",{curr,tmpval},"] = ",Value,",",nl}), +% emit({" {bits,8,",{curr,tmpval},"}",nl}), + emit({" [10,8,",{curr,tmpval},"]",nl}), + emit(" end"); + 2 -> + asn1ct_name:new(tmpval), + emit({" begin",nl}), + emit({" [",{curr,tmpval},",",{next,tmpval},"] = ", + Value,",",nl}), +% emit({" [{bits,8,",{curr,tmpval},"},{bits,8,", +% {next,tmpval},"}]",nl}), + emit({" [[10,8,",{curr,tmpval},"],[10,8,", + {next,tmpval},"]]",nl}), + emit(" end"), + asn1ct_name:new(tmpval); + Sv when integer(Sv),Sv =< 256 -> + asn1ct_name:new(tmpval), + emit({" begin",nl}), +% emit({" case length(",Value,") == ",Sv," of",nl}), + emit({" case length(",Value,") of",nl}), + emit({" ",{curr,tmpval}," when ",{curr,tmpval}," == ",Sv," -> [2,20,",{curr,tmpval},",",Value,"];",nl}), + emit({" _ -> exit({error,{value_out_of_bounds,",Value,"}})", + nl," end",nl}), + emit(" end"); + Sv when integer(Sv),Sv =< 65535 -> + asn1ct_name:new(tmpval), + emit({" begin",nl}), +% emit({" case length(",Value,") == ",Sv," of",nl}), + emit({" case length(",Value,") of",nl}), +% emit({" true -> [align,{octets,",Value,"}];",nl}), + emit({" ",{curr,tmpval}," when ",{curr,tmpval}," == ",Sv," -> [2,21,",{curr,tmpval},",",Value,"];",nl}), + emit({" _ -> exit({error,{value_out_of_bounds,",Value,"}})", + nl," end",nl}), + emit(" end"); + C -> + emit({" ?RT_PER:encode_octet_string(",{asis,C},",false,",Value,")",nl}) + end. + +emit_dec_octet_string(Constraint,BytesVar) -> + case get_constraint(Constraint,'SizeConstraint') of + 0 -> + emit({" {[],",BytesVar,"}",nl}); + {_,0} -> + emit({" {[],",BytesVar,"}",nl}); + C -> + emit({" ?RT_PER:decode_octet_string(",BytesVar,",", + {asis,C},",false)",nl}) + end. + +emit_enc_integer_case(Value) -> + case get(component_type) of + {true,#'ComponentType'{prop=Prop}} -> + emit({" begin",nl}), + case Prop of + Opt when Opt=='OPTIONAL'; + tuple(Opt),element(1,Opt)=='DEFAULT' -> + emit({" case ",Value," of",nl}), + ok; + _ -> + emit({" ",{curr,tmpval},"=",Value,",",nl}), + emit({" case ",{curr,tmpval}," of",nl}), + asn1ct_name:new(tmpval) + end; +% asn1ct_name:new(tmpval); + _ -> + emit({" case ",Value," of ",nl}) + end. +emit_enc_integer_end_case() -> + case get(component_type) of + {true,_} -> + emit({nl," end"}); % end of begin ... end + _ -> ok + end. + + +emit_enc_integer_NNL(C,Value,NNL) -> + EncVal = enc_integer_NNL_cases(Value,NNL), + emit_enc_integer(C,EncVal). + +enc_integer_NNL_cases(Value,NNL) -> + asn1ct_name:new(tmpval), + TmpVal = asn1ct_gen:mk_var(asn1ct_name:curr(tmpval)), + Cases=enc_integer_NNL_cases1(NNL), + lists:flatten(io_lib:format("(case ~s of "++Cases++ + "~s when atom(~s)->exit({error,{asn1,{namednumber,~s}}});_->~s end)",[Value,TmpVal,TmpVal,TmpVal,Value])). + +enc_integer_NNL_cases1([{NNo,No}|Rest]) -> + io_lib:format("~w->~w;",[NNo,No])++enc_integer_NNL_cases1(Rest); +enc_integer_NNL_cases1([]) -> + "". + +emit_enc_integer([{'SingleValue',Int}],Value) -> + asn1ct_name:new(tmpval), + emit_enc_integer_case(Value),% emit([" case ",Value," of",nl]), + emit([" ",Int," -> [];",nl]), + emit([" ",{curr,tmpval}," ->",nl]), + emit([" exit({error,{value_out_of_bounds,",{curr,tmpval},"}})", + nl," end",nl]), + emit_enc_integer_end_case(); + +emit_enc_integer([{_,{Lb,Ub},_Range,{bits,NoBs}}],Value) -> % Range =< 255 + asn1ct_name:new(tmpval), + emit_enc_integer_case(Value), + emit([" ",{curr,tmpval}," when ",{curr,tmpval},"=<",Ub,",", + {curr,tmpval},">=",Lb," ->",nl]), + emit([" [10,",NoBs,",",{curr,tmpval},"-",Lb,"];",nl]), + emit([" ",{curr,tmpval}," ->",nl]), + emit([" exit({error,{value_out_of_bounds,",{curr,tmpval},"}})", + nl," end",nl]), + emit_enc_integer_end_case(); + +emit_enc_integer([{_,{Lb,Ub},Range,_}],Value) when Range =< 256 -> + asn1ct_name:new(tmpval), + emit_enc_integer_case(Value), + emit([" ",{curr,tmpval}," when ",{curr,tmpval},"=<",Ub,",", + {curr,tmpval},">=",Lb," ->",nl]), + emit([" [20,1,",{curr,tmpval},"-",Lb,"];",nl]), + emit([" ",{curr,tmpval}," ->",nl]), + emit([" exit({error,{value_out_of_bounds,",{curr,tmpval},"}})", + nl," end",nl]), + emit_enc_integer_end_case(); + +emit_enc_integer([{_,{Lb,Ub},Range,_}],Value) when Range =< 65536 -> + asn1ct_name:new(tmpval), + emit_enc_integer_case(Value), + emit([" ",{curr,tmpval}," when ",{curr,tmpval},"=<",Ub,",", + {curr,tmpval},">=",Lb," ->",nl]), + emit([" [20,2,<<(",{curr,tmpval},"-",Lb,"):16>>];",nl]), + emit([" ",{curr,tmpval}," ->",nl]), + emit([" exit({error,{value_out_of_bounds,",{curr,tmpval},"}})", + nl," end",nl]), + emit_enc_integer_end_case(); + + +emit_enc_integer(C,Value) -> + emit({" ?RT_PER:encode_integer(",{asis,C},",",Value,")"}). + + + + +enc_enum_cases(Value,NewList) -> + asn1ct_name:new(tmpval), + TmpVal = asn1ct_gen:mk_var(asn1ct_name:curr(tmpval)), + Cases=enc_enum_cases1(NewList), + lists:flatten(io_lib:format("(case ~s of "++Cases++ + "~s ->exit({error," + "{asn1,{enumerated,~s}}})" + " end)", + [Value,TmpVal,TmpVal])). +enc_enum_cases1(NNL) -> + enc_enum_cases1(NNL,0). +enc_enum_cases1([H|T],Index) -> + io_lib:format("~w->~w;",[H,Index])++enc_enum_cases1(T,Index+1); +enc_enum_cases1([],_) -> + "". + + +emit_enc_enumerated_cases(C, [H], Count) -> + emit_enc_enumerated_case(C, H, Count), + emit([";",nl,"EnumVal -> exit({error,{asn1, {enumerated_not_in_range, EnumVal}}})"]), + emit([nl,"end"]); +emit_enc_enumerated_cases(C, ['EXT_MARK'|T], _Count) -> + emit_enc_enumerated_cases(C, T, 0); +emit_enc_enumerated_cases(C, [H1,H2|T], Count) -> + emit_enc_enumerated_case(C, H1, Count), + emit([";",nl]), + emit_enc_enumerated_cases(C, [H2|T], Count+1). + + +%% The function clauses matching on tuples with first element +%% asn1_enum, 1 or 0 and the atom 'EXT_MARK' are for ENUMERATED +%% with extension mark. +emit_enc_enumerated_case(_C, {asn1_enum,High}, _) -> + %% ENUMERATED with extensionmark + %% value higher than the extension base and not + %% present in the extension range. + emit(["{asn1_enum,EnumV} when integer(EnumV), EnumV > ",High," -> ", + "[1,?RT_PER:encode_small_number(EnumV)]"]); +emit_enc_enumerated_case(_C, 'EXT_MARK', _Count) -> + %% ENUMERATED with extensionmark + true; +emit_enc_enumerated_case(_C, {1,EnumName}, Count) -> + %% ENUMERATED with extensionmark + %% values higher than extension root + emit(["'",EnumName,"' -> [1,?RT_PER:encode_small_number(",Count,")]"]); +emit_enc_enumerated_case(C, {0,EnumName}, Count) -> + %% ENUMERATED with extensionmark + %% values within extension root + emit(["'",EnumName,"' -> [0,?RT_PER:encode_integer(",{asis,C},", ",Count,")]"]); + +%% This clause is invoked in case of an ENUMERATED without extension mark +emit_enc_enumerated_case(_C, EnumName, Count) -> + emit(["'",EnumName,"' -> ",Count]). + + +get_constraint([{Key,V}],Key) -> + V; +get_constraint([],_) -> + no; +get_constraint(C,Key) -> + case lists:keysearch(Key,1,C) of + false -> + no; + {value,{_,V}} -> + V + end. + +get_constraints(L=[{Key,_}],Key) -> + L; +get_constraints([],_) -> + []; +get_constraints(C,Key) -> + {value,L} = keysearch_allwithkey(Key,1,C,[]), + L. + +keysearch_allwithkey(Key,Ix,C,Acc) -> + case lists:keysearch(Key,Ix,C) of + false -> + {value,Acc}; + {value,T} -> + RestC = lists:delete(T,C), + keysearch_allwithkey(Key,Ix,RestC,[T|Acc]) + end. + +%% effective_constraint(Type,C) +%% Type = atom() +%% C = [C1,...] +%% C1 = {'SingleValue',SV} | {'ValueRange',VR} | {atom(),term()} +%% SV = integer() | [integer(),...] +%% VR = {Lb,Ub} +%% Lb = 'MIN' | integer() +%% Ub = 'MAX' | integer() +%% Returns a single value if C only has a single value constraint, and no +%% value range constraints, that constrains to a single value, otherwise +%% returns a value range that has the lower bound set to the lowest value +%% of all single values and lower bound values in C and the upper bound to +%% the greatest value. +effective_constraint(integer,[C={{_,_},_}|_Rest]) -> % extension + [C]; %% [C|effective_constraint(integer,Rest)]; XXX what is possible ??? +effective_constraint(integer,C) -> + SVs = get_constraints(C,'SingleValue'), + SV = effective_constr('SingleValue',SVs), + VRs = get_constraints(C,'ValueRange'), + VR = effective_constr('ValueRange',VRs), + CRange = greatest_common_range(SV,VR), + pre_encode(integer,CRange); +effective_constraint(bitstring,C) -> +% Constr=get_constraints(C,'SizeConstraint'), +% case Constr of +% [] -> no; +% [{'SizeConstraint',Val}] -> Val; +% Other -> Other +% end; + get_constraint(C,'SizeConstraint'); +effective_constraint(Type,C) -> + io:format("Effective constraint for ~p, not implemented yet.~n",[Type]), + C. + +effective_constr(_,[]) -> + []; +effective_constr('SingleValue',List) -> + SVList = lists:flatten(lists:map(fun(X)->element(2,X)end,List)), + case lists:usort(SVList) of + [N] -> + [{'SingleValue',N}]; + L when list(L) -> + [{'ValueRange',{hd(L),lists:last(L)}}] + end; +effective_constr('ValueRange',List) -> + LBs = lists:map(fun({_,{Lb,_}})-> Lb end,List), + UBs = lists:map(fun({_,{_,Ub}})-> Ub end,List), + Lb = least_Lb(LBs), + [{'ValueRange',{Lb,lists:max(UBs)}}]. + +greatest_common_range([],VR) -> + VR; +greatest_common_range(SV,[]) -> + SV; +greatest_common_range([{_,Int}],[{_,{'MIN',Ub}}]) when integer(Int), + Int > Ub -> + [{'ValueRange',{'MIN',Int}}]; +greatest_common_range([{_,Int}],[{_,{Lb,Ub}}]) when integer(Int), + Int < Lb -> + [{'ValueRange',{Int,Ub}}]; +greatest_common_range([{_,Int}],VR=[{_,{_Lb,_Ub}}]) when integer(Int) -> + VR; +greatest_common_range([{_,L}],[{_,{Lb,Ub}}]) when list(L) -> + Min = least_Lb([Lb|L]), + Max = greatest_Ub([Ub|L]), + [{'ValueRange',{Min,Max}}]. + + +least_Lb(L) -> + case lists:member('MIN',L) of + true -> 'MIN'; + _ -> lists:min(L) + end. + +greatest_Ub(L) -> + case lists:member('MAX',L) of + true -> 'MAX'; + _ -> lists:max(L) + end. + +% effective_constraint1('SingleValue',List) -> +% SVList = lists:map(fun(X)->element(2,X)end,List), +% sv_effective_constraint(hd(SVList),tl(SVList)); +% effective_constraint1('ValueRange',List) -> +% VRList = lists:map(fun(X)->element(2,X)end,List), +% vr_effective_constraint(lists:map(fun(X)->element(1,X)end,VRList), +% lists:map(fun(X)->element(2,X)end,VRList)). + +%% vr_effective_constraint/2 +%% Gets all LowerEndPoints and UpperEndPoints as arguments +%% Returns {'ValueRange',{Lb,Ub}} where Lb is the highest value of +%% the LowerEndPoints and Ub is the lowest value of the UpperEndPoints, +%% i.e. the intersection of all value ranges. +% vr_effective_constraint(Mins,Maxs) -> +% Lb=lists:foldl(fun(X,'MIN') when integer(X) -> X; +% (X,'MIN') -> 'MIN'; +% (X,AccIn) when integer(X),X >= AccIn -> X; +% (X,AccIn) -> AccIn +% end,hd(Mins),tl(Mins)), +% Ub = lists:min(Maxs), +% {'ValueRange',{Lb,Ub}}. + + +% sv_effective_constraint(SV,[]) -> +% {'SingleValue',SV}; +% sv_effective_constraint([],_) -> +% exit({error,{asn1,{illegal_single_value_constraint}}}); +% sv_effective_constraint(SV,[SV|Rest]) -> +% sv_effective_constraint(SV,Rest); +% sv_effective_constraint(Int,[SV|Rest]) when integer(Int),list(SV) -> +% case lists:member(Int,SV) of +% true -> +% sv_effective_constraint(Int,Rest); +% _ -> +% exit({error,{asn1,{illegal_single_value_constraint}}}) +% end; +% sv_effective_constraint(SV,[Int|Rest]) when integer(Int),list(SV) -> +% case lists:member(Int,SV) of +% true -> +% sv_effective_constraint(Int,Rest); +% _ -> +% exit({error,{asn1,{illegal_single_value_constraint}}}) +% end; +% sv_effective_constraint(SV1,[SV2|Rest]) when list(SV1),list(SV2) -> +% sv_effective_constraint(common_set(SV1,SV2),Rest); +% sv_effective_constraint(_,_) -> +% exit({error,{asn1,{illegal_single_value_constraint}}}). + +%% common_set/2 +%% Two lists as input +%% Returns the list with all elements that are common for both +%% input lists +% common_set(SV1,SV2) -> +% lists:filter(fun(X)->lists:member(X,SV1) end,SV2). + + + +pre_encode(integer,[]) -> + []; +pre_encode(integer,C=[{'SingleValue',_}]) -> + C; +pre_encode(integer,C=[{'ValueRange',VR={Lb,Ub}}]) when integer(Lb),integer(Ub)-> + Range = Ub-Lb+1, + if + Range =< 255 -> + NoBits = no_bits(Range), + [{'ValueRange',VR,Range,{bits,NoBits}}]; + Range =< 256 -> + [{'ValueRange',VR,Range,{octets,1}}]; + Range =< 65536 -> + [{'ValueRange',VR,Range,{octets,2}}]; + true -> + C + end; +pre_encode(integer,C) -> + C. + +no_bits(2) -> 1; +no_bits(N) when N=<4 -> 2; +no_bits(N) when N=<8 -> 3; +no_bits(N) when N=<16 -> 4; +no_bits(N) when N=<32 -> 5; +no_bits(N) when N=<64 -> 6; +no_bits(N) when N=<128 -> 7; +no_bits(N) when N=<255 -> 8. + +%% Object code generating for encoding and decoding +%% ------------------------------------------------ + +gen_obj_code(Erules,_Module,Obj) when record(Obj,typedef) -> + ObjName = Obj#typedef.name, + Def = Obj#typedef.typespec, + #'Externaltypereference'{module=Mod,type=ClassName} = + Def#'Object'.classname, + Class = asn1_db:dbget(Mod,ClassName), + {object,_,Fields} = Def#'Object'.def, + emit({nl,nl,nl,"%%================================"}), + emit({nl,"%% ",ObjName}), + emit({nl,"%%================================",nl}), + EncConstructed = +% gen_encode_objectfields(Class#classdef.typespec,ObjName,Fields,[]), + gen_encode_objectfields(ClassName,get_class_fields(Class), + ObjName,Fields,[]), + emit(nl), + gen_encode_constr_type(Erules,EncConstructed), + emit(nl), + DecConstructed = +% gen_decode_objectfields(Class#classdef.typespec,ObjName,Fields,[]), + gen_decode_objectfields(ClassName,get_class_fields(Class), + ObjName,Fields,[]), + emit(nl), + gen_decode_constr_type(Erules,DecConstructed), + emit(nl); +gen_obj_code(_Erules,_Module,Obj) when record(Obj,pobjectdef) -> + ok. + +gen_encode_objectfields(ClassName,[{typefield,Name,OptOrMand}|Rest], + ObjName,ObjectFields,ConstrAcc) -> + EmitFuncClause = + fun(V) -> + emit(["'enc_",ObjName,"'(",{asis,Name}, + ",",V,",_RestPrimFieldName) ->",nl]) + end, +% emit(["'enc_",ObjName,"'(",{asis,Name}, +% ", Val, RestPrimFieldName) ->",nl]), + MaybeConstr = + case {get_object_field(Name,ObjectFields),OptOrMand} of + {false,'MANDATORY'} -> %% this case is illegal + exit({error,{asn1,{"missing mandatory field in object", + ObjName}}}); + {false,'OPTIONAL'} -> + EmitFuncClause("_"), + emit(" <<>>"), + []; + {false,{'DEFAULT',DefaultType}} -> + EmitFuncClause("Val"), + gen_encode_default_call(ClassName,Name,DefaultType); + {{Name,TypeSpec},_} -> + %% A specified field owerwrites any 'DEFAULT' or + %% 'OPTIONAL' field in the class + EmitFuncClause("Val"), + gen_encode_field_call(ObjName,Name,TypeSpec) + end, + case more_genfields(Rest) of + true -> + emit([";",nl]); + false -> + emit([".",nl]) + end, + gen_encode_objectfields(ClassName,Rest,ObjName,ObjectFields, + MaybeConstr++ConstrAcc); +gen_encode_objectfields(ClassName,[{objectfield,Name,_,_,OptOrMand}|Rest], + ObjName,ObjectFields,ConstrAcc) -> + EmitFuncClause = + fun(Attrs) -> + emit(["'enc_",ObjName,"'(",{asis,Name}, + ",",Attrs,") ->",nl]) + end, +% emit(["'enc_",ObjName,"'(",{asis,Name}, +% ", Val,[H|T]) ->",nl]), + case {get_object_field(Name,ObjectFields),OptOrMand} of + {false,'MANDATORY'} -> + exit({error,{asn1,{"missing mandatory field in object", + ObjName}}}); + {false,'OPTIONAL'} -> + EmitFuncClause("_,_"), + emit([" exit({error,{'use of missing field in object', ",Name, + "}})"]); + {false,{'DEFAULT',_DefaultObject}} -> + exit({error,{asn1,{"not implemented yet",Name}}}); + {{Name,TypeSpec},_} -> + EmitFuncClause("Val,[H|T]"), + case TypeSpec#typedef.name of + {ExtMod,TypeName} -> + emit({indent(3),"'",ExtMod,"':'enc_",TypeName, + "'(H, Val, T)"}); + TypeName -> + emit({indent(3),"'enc_",TypeName,"'(H, Val, T)"}) + end + end, + case more_genfields(Rest) of + true -> + emit([";",nl]); + false -> + emit([".",nl]) + end, + gen_encode_objectfields(ClassName,Rest,ObjName,ObjectFields,ConstrAcc); +gen_encode_objectfields(ClassName,[_C|Cs],O,OF,Acc) -> + gen_encode_objectfields(ClassName,Cs,O,OF,Acc); +gen_encode_objectfields(_,[],_,_,Acc) -> + Acc. + +% gen_encode_objectfields(Class,ObjName,[{FieldName,Type}|Rest],ConstrAcc) -> +% Fields = Class#objectclass.fields, + +% MaybeConstr = +% case is_typefield(Fields,FieldName) of +% true -> +% Def = Type#typedef.typespec, +% emit({"'enc_",ObjName,"'(",{asis,FieldName}, +% ", Val, Dummy) ->",nl}), + +% CAcc = +% case Type#typedef.name of +% {primitive,bif} -> +% gen_encode_prim(per,Def,"false","Val"), +% []; +% {constructed,bif} -> +% emit({" 'enc_",ObjName,'_',FieldName, +% "'(Val)"}), +% [{['enc_',ObjName,'_',FieldName],Def}]; +% {ExtMod,TypeName} -> +% emit({" '",ExtMod,"':'enc_",TypeName,"'(Val)"}), +% []; +% TypeName -> +% emit({" 'enc_",TypeName,"'(Val)"}), +% [] +% end, +% case more_genfields(Fields,Rest) of +% true -> +% emit({";",nl}); +% false -> +% emit({".",nl}) +% end, +% CAcc; +% {false,objectfield} -> +% emit({"'enc_",ObjName,"'(",{asis,FieldName}, +% ", Val, [H|T]) ->",nl}), +% case Type#typedef.name of +% {ExtMod,TypeName} -> +% emit({indent(3),"'",ExtMod,"':'enc_",TypeName, +% "'(H, Val, T)"}); +% TypeName -> +% emit({indent(3),"'enc_",TypeName,"'(H, Val, T)"}) +% end, +% case more_genfields(Fields,Rest) of +% true -> +% emit({";",nl}); +% false -> +% emit({".",nl}) +% end, +% []; +% {false,_} -> [] +% end, +% gen_encode_objectfields(Class,ObjName,Rest,MaybeConstr ++ ConstrAcc); +% gen_encode_objectfields(C,O,[_|T],Acc) -> +% gen_encode_objectfields(C,O,T,Acc); +% gen_encode_objectfields(_,_,[],Acc) -> +% Acc. + +gen_encode_constr_type(Erules,[TypeDef|Rest]) when record(TypeDef,typedef) -> + case is_already_generated(enc,TypeDef#typedef.name) of + true -> ok; + _ -> + Name = lists:concat(["enc_",TypeDef#typedef.name]), + emit({Name,"(Val) ->",nl}), + Def = TypeDef#typedef.typespec, + InnerType = asn1ct_gen:get_inner(Def#type.def), + asn1ct_gen:gen_encode_constructed(Erules,Name,InnerType,Def), + gen_encode_constr_type(Erules,Rest) + end; +gen_encode_constr_type(_,[]) -> + ok. + +gen_encode_field_call(ObjName,FieldName,Type) -> + Def = Type#typedef.typespec, + case Type#typedef.name of + {primitive,bif} -> + gen_encode_prim(per,Def,"false", + "Val"), + []; + {constructed,bif} -> + emit({" 'enc_",ObjName,'_',FieldName, + "'(Val)"}), + [Type#typedef{name=list_to_atom(lists:concat([ObjName,'_',FieldName]))}]; + {ExtMod,TypeName} -> + emit({" '",ExtMod,"':'enc_",TypeName, + "'(Val)"}), + []; + TypeName -> + emit({" 'enc_",TypeName,"'(Val)"}), + [] + end. + +gen_encode_default_call(ClassName,FieldName,Type) -> + CurrentMod = get(currmod), + InnerType = asn1ct_gen:get_inner(Type#type.def), + case asn1ct_gen:type(InnerType) of + {constructed,bif} -> +%% asn1ct_gen:gen_encode_constructed(Erules,Typename,InnerType,Type); + emit([" 'enc_",ClassName,'_',FieldName,"'(Val)"]), + [#typedef{name=list_to_atom(lists:concat([ClassName,'_',FieldName])), + typespec=Type}]; + {primitive,bif} -> + gen_encode_prim(per,Type,"false","Val"), + []; + #'Externaltypereference'{module=CurrentMod,type=Etype} -> + emit([" 'enc_",Etype,"'(Val)",nl]), + []; + #'Externaltypereference'{module=Emod,type=Etype} -> + emit([" '",Emod,"':'enc_",Etype,"'(Val)",nl]), + [] + end. + + + +gen_decode_objectfields(ClassName,[{typefield,Name,OptOrMand}|Rest], + ObjName,ObjectFields,ConstrAcc) -> + EmitFuncClause = + fun(Bytes) -> + emit(["'dec_",ObjName,"'(",{asis,Name},",",Bytes, + ",_,_RestPrimFieldName) ->",nl]) + end, +% emit(["'dec_",ObjName,"'(",{asis,Name}, +% ", Bytes, _, RestPrimFieldName) ->",nl]), + MaybeConstr= + case {get_object_field(Name,ObjectFields),OptOrMand} of + {false,'MANDATORY'} -> %% this case is illegal + exit({error,{asn1,{"missing mandatory field in object", + ObjName}}}); + {false,'OPTIONAL'} -> + EmitFuncClause("_"), + emit([" asn1_NOVALUE"]), + []; + {false,{'DEFAULT',DefaultType}} -> + EmitFuncClause("Bytes"), + gen_decode_default_call(ClassName,Name,"Bytes",DefaultType); + {{Name,TypeSpec},_} -> + %% A specified field owerwrites any 'DEFAULT' or + %% 'OPTIONAL' field in the class + EmitFuncClause("Bytes"), + gen_decode_field_call(ObjName,Name,"Bytes",TypeSpec) + end, + case more_genfields(Rest) of + true -> + emit([";",nl]); + false -> + emit([".",nl]) + end, + gen_decode_objectfields(ClassName,Rest,ObjName,ObjectFields,MaybeConstr++ConstrAcc); +gen_decode_objectfields(ClassName,[{objectfield,Name,_,_,OptOrMand}|Rest], + ObjName,ObjectFields,ConstrAcc) -> + EmitFuncClause = + fun(Attrs) -> + emit(["'dec_",ObjName,"'(",{asis,Name}, + ",",Attrs,") ->",nl]) + end, +% emit(["'dec_",ObjName,"'(",{asis,Name}, +% ", Bytes,_,[H|T]) ->",nl]), + case {get_object_field(Name,ObjectFields),OptOrMand} of + {false,'MANDATORY'} -> + exit({error,{asn1,{"missing mandatory field in object", + ObjName}}}); + {false,'OPTIONAL'} -> + EmitFuncClause("_,_,_"), + emit([" exit({error,{'illegal use of missing field in object', ",Name, + "}})"]); + {false,{'DEFAULT',_DefaultObject}} -> + exit({error,{asn1,{"not implemented yet",Name}}}); + {{Name,TypeSpec},_} -> + EmitFuncClause("Bytes,_,[H|T]"), + case TypeSpec#typedef.name of + {ExtMod,TypeName} -> + emit({indent(3),"'",ExtMod,"':'dec_",TypeName, + "'(H, Bytes, telltype, T)"}); + TypeName -> + emit({indent(3),"'dec_",TypeName,"'(H, Bytes, telltype, T)"}) + end + end, + case more_genfields(Rest) of + true -> + emit([";",nl]); + false -> + emit([".",nl]) + end, + gen_decode_objectfields(ClassName,Rest,ObjName,ObjectFields,ConstrAcc); +gen_decode_objectfields(CN,[_C|Cs],O,OF,CAcc) -> + gen_decode_objectfields(CN,Cs,O,OF,CAcc); +gen_decode_objectfields(_,[],_,_,CAcc) -> + CAcc. + + +gen_decode_field_call(ObjName,FieldName,Bytes,Type) -> + Def = Type#typedef.typespec, + case Type#typedef.name of + {primitive,bif} -> + gen_dec_prim(per,Def,Bytes), + []; + {constructed,bif} -> + emit({" 'dec_",ObjName,'_',FieldName, + "'(",Bytes,",telltype)"}), + [Type#typedef{name=list_to_atom(lists:concat([ObjName,'_',FieldName]))}]; + {ExtMod,TypeName} -> + emit({" '",ExtMod,"':'dec_",TypeName, + "'(",Bytes,", telltype)"}), + []; + TypeName -> + emit({" 'dec_",TypeName,"'(",Bytes,", telltype)"}), + [] + end. + +gen_decode_default_call(ClassName,FieldName,Bytes,Type) -> + CurrentMod = get(currmod), + InnerType = asn1ct_gen:get_inner(Type#type.def), + case asn1ct_gen:type(InnerType) of + {constructed,bif} -> + emit([" 'dec_",ClassName,'_',FieldName,"'(",Bytes,", telltype)"]), + [#typedef{name=list_to_atom(lists:concat([ClassName,'_',FieldName])), + typespec=Type}]; + {primitive,bif} -> + gen_dec_prim(per,Type,Bytes), + []; + #'Externaltypereference'{module=CurrentMod,type=Etype} -> + emit([" 'dec_",Etype,"'(",Bytes,", telltype)",nl]), + []; + #'Externaltypereference'{module=Emod,type=Etype} -> + emit([" '",Emod,"':'dec_",Etype,"'(",Bytes,", telltype)",nl]), + [] + end. + +%%%%%%%%%%%%%%% + +% gen_decode_objectfields(Class,ObjName,[{FieldName,Type}|Rest],ConstrAcc) -> +% Fields = Class#objectclass.fields, + +% MaybeConstr = +% case is_typefield(Fields,FieldName) of +% true -> +% Def = Type#typedef.typespec, +% emit({"'dec_",ObjName,"'(",{asis,FieldName}, +% ", Val, Telltype, RestPrimFieldName) ->",nl}), + +% CAcc = +% case Type#typedef.name of +% {primitive,bif} -> +% gen_dec_prim(per,Def,"Val"), +% []; +% {constructed,bif} -> +% emit({" 'dec_",ObjName,'_',FieldName, +% "'(Val, Telltype)"}), +% [{['dec_',ObjName,'_',FieldName],Def}]; +% {ExtMod,TypeName} -> +% emit({" '",ExtMod,"':'dec_",TypeName, +% "'(Val, Telltype)"}), +% []; +% TypeName -> +% emit({" 'dec_",TypeName,"'(Val, Telltype)"}), +% [] +% end, +% case more_genfields(Fields,Rest) of +% true -> +% emit({";",nl}); +% false -> +% emit({".",nl}) +% end, +% CAcc; +% {false,objectfield} -> +% emit({"'dec_",ObjName,"'(",{asis,FieldName}, +% ", Val, Telltype, [H|T]) ->",nl}), +% case Type#typedef.name of +% {ExtMod,TypeName} -> +% emit({indent(3),"'",ExtMod,"':'dec_",TypeName, +% "'(H, Val, Telltype, T)"}); +% TypeName -> +% emit({indent(3),"'dec_",TypeName, +% "'(H, Val, Telltype, T)"}) +% end, +% case more_genfields(Fields,Rest) of +% true -> +% emit({";",nl}); +% false -> +% emit({".",nl}) +% end, +% []; +% {false,_} -> +% [] +% end, +% gen_decode_objectfields(Class,ObjName,Rest,MaybeConstr ++ ConstrAcc); +% gen_decode_objectfields(C,O,[_|T],CAcc) -> +% gen_decode_objectfields(C,O,T,CAcc); +% gen_decode_objectfields(_,_,[],CAcc) -> +% CAcc. + +gen_decode_constr_type(Erules,[{Name,Def}|Rest]) -> + emit({Name,"(Bytes,_) ->",nl}), + InnerType = asn1ct_gen:get_inner(Def#type.def), + asn1ct_gen:gen_decode_constructed(Erules,Name,InnerType,Def), + gen_decode_constr_type(Erules,Rest); +gen_decode_constr_type(Erules,[TypeDef|Rest]) when record(TypeDef,typedef) -> + case is_already_generated(dec,TypeDef#typedef.name) of + true -> ok; + _ -> + gen_decode(Erules,TypeDef) + end, + gen_decode_constr_type(Erules,Rest); +gen_decode_constr_type(_,[]) -> + ok. + +% is_typefield(Fields,FieldName) -> +% case lists:keysearch(FieldName,2,Fields) of +% {value,Field} -> +% case element(1,Field) of +% typefield -> +% true; +% Other -> +% {false,Other} +% end; +% _ -> +% false +% end. +%% Object Set code generating for encoding and decoding +%% ---------------------------------------------------- +gen_objectset_code(Erules,ObjSet) -> + ObjSetName = ObjSet#typedef.name, + Def = ObjSet#typedef.typespec, +%% {ClassName,ClassDef} = Def#'ObjectSet'.class, + #'Externaltypereference'{module=ClassModule, + type=ClassName} = Def#'ObjectSet'.class, + ClassDef = asn1_db:dbget(ClassModule,ClassName), + UniqueFName = Def#'ObjectSet'.uniquefname, + Set = Def#'ObjectSet'.set, + emit({nl,nl,nl,"%%================================"}), + emit({nl,"%% ",ObjSetName}), + emit({nl,"%%================================",nl}), + case ClassName of + {_Module,ExtClassName} -> + gen_objset_code(Erules,ObjSetName,UniqueFName,Set, + ExtClassName,ClassDef); + _ -> + gen_objset_code(Erules,ObjSetName,UniqueFName,Set, + ClassName,ClassDef) + end, + emit(nl). + +gen_objset_code(Erules,ObjSetName,UniqueFName,Set,ClassName,ClassDef)-> + ClassFields = (ClassDef#classdef.typespec)#objectclass.fields, + InternalFuncs= + gen_objset_enc(ObjSetName,UniqueFName,Set,ClassName, + ClassFields,1,[]), + gen_objset_dec(ObjSetName,UniqueFName,Set,ClassName,ClassFields,1), + gen_internal_funcs(Erules,InternalFuncs). + +gen_objset_enc(_,{unique,undefined},_,_,_,_,_) -> + %% There is no unique field in the class of this object set + %% don't bother about the constraint + []; +gen_objset_enc(ObjSName,UniqueName,[{ObjName,Val,Fields},T|Rest], + ClName,ClFields,NthObj,Acc)-> + emit({"'getenc_",ObjSName,"'(",{asis,UniqueName},",", + {asis,Val},") ->",nl}), + {InternalFunc,NewNthObj}= + case ObjName of + no_name -> + gen_inlined_enc_funs(Fields,ClFields,ObjSName,NthObj); + _ -> + emit({" fun 'enc_",ObjName,"'/3"}), + {[],NthObj} + end, + emit({";",nl}), + gen_objset_enc(ObjSName,UniqueName,[T|Rest],ClName,ClFields, + NewNthObj,InternalFunc++Acc); +gen_objset_enc(ObjSetName,UniqueName, + [{ObjName,Val,Fields}],_ClName,ClFields,NthObj,Acc) -> + + emit({"'getenc_",ObjSetName,"'(",{asis,UniqueName},",", + {asis,Val},") ->",nl}), + {InternalFunc,_}= + case ObjName of + no_name -> + gen_inlined_enc_funs(Fields,ClFields,ObjSetName,NthObj); + _ -> + emit({" fun 'enc_",ObjName,"'/3"}), + {[],NthObj} + end, + emit({".",nl,nl}), + InternalFunc++Acc; +gen_objset_enc(ObjSetName,_UniqueName,['EXTENSIONMARK'],_ClName, + _ClFields,_NthObj,Acc) -> + emit({"'getenc_",ObjSetName,"'(_, _) ->",nl}), + emit({indent(3),"fun(_, Val, _) ->",nl}), + emit({indent(6),"Size = if",nl}), + emit({indent(9),"list(Val) -> length(Val);",nl}), + emit({indent(9),"true -> size(Val)",nl}), + emit({indent(6),"end,",nl}), + emit({indent(6),"if",nl}), + emit({indent(9),"Size < 256 ->",nl}), + emit({indent(12),"[20,Size,Val];",nl}), + emit({indent(9),"true ->",nl}), + emit({indent(12),"[21,<<Size:16>>,Val]",nl}), + emit({indent(6),"end",nl}), + emit({indent(3),"end.",nl,nl}), + Acc; +gen_objset_enc(_,_,[],_,_,_,Acc) -> + Acc. + +%% gen_inlined_enc_funs for each object iterates over all fields of a +%% class, and for each typefield it checks if the object has that +%% field and emits the proper code. +gen_inlined_enc_funs(Fields,[{typefield,Name,_}|Rest],ObjSetName,NthObj) -> + InternalDefFunName=asn1ct_gen:list2name([NthObj,Name,ObjSetName]), + case lists:keysearch(Name,1,Fields) of + {value,{_,Type}} when record(Type,type) -> + emit({indent(3),"fun(Type, Val, _) ->",nl, + indent(6),"case Type of",nl}), + {Ret,N}=emit_inner_of_fun(Type,InternalDefFunName), + gen_inlined_enc_funs1(Fields,Rest,ObjSetName,NthObj+N,Ret); + {value,{_,Type}} when record(Type,typedef) -> + emit({indent(3),"fun(Type, Val, _) ->",nl, + indent(6),"case Type of",nl}), + emit({indent(9),{asis,Name}," ->",nl}), + {Ret,N}=emit_inner_of_fun(Type,InternalDefFunName), + gen_inlined_enc_funs1(Fields,Rest,ObjSetName,NthObj+N,Ret); + false -> + gen_inlined_enc_funs(Fields,Rest,ObjSetName,NthObj) + end; +gen_inlined_enc_funs(Fields,[_|Rest],ObjSetName,NthObj) -> + gen_inlined_enc_funs(Fields,Rest,ObjSetName,NthObj); +gen_inlined_enc_funs(_,[],_,NthObj) -> + {[],NthObj}. + +gen_inlined_enc_funs1(Fields,[{typefield,Name,_}|Rest],ObjSetName, + NthObj,Acc) -> + InternalDefFunName = asn1ct_gen:list2name([NthObj,Name,ObjSetName]), + {Acc2,NAdd}= + case lists:keysearch(Name,1,Fields) of + {value,{_,Type}} when record(Type,type) -> + emit({";",nl}), + {Ret,N}=emit_inner_of_fun(Type,InternalDefFunName), + {Ret++Acc,N}; + {value,{_,Type}} when record(Type,typedef) -> + emit({";",nl,indent(9),{asis,Name}," ->",nl}), + {Ret,N}=emit_inner_of_fun(Type,InternalDefFunName), + {Ret++Acc,N}; + false -> + {Acc,0} + end, + gen_inlined_enc_funs1(Fields,Rest,ObjSetName,NthObj+NAdd,Acc2); +gen_inlined_enc_funs1(Fields,[_|Rest],ObjSetName,NthObj,Acc)-> + gen_inlined_enc_funs1(Fields,Rest,ObjSetName,NthObj,Acc); +gen_inlined_enc_funs1(_,[],_,NthObj,Acc) -> + emit({nl,indent(6),"end",nl}), + emit({indent(3),"end"}), + {Acc,NthObj}. + +emit_inner_of_fun(TDef=#typedef{name={ExtMod,Name},typespec=Type}, + InternalDefFunName) -> + case {ExtMod,Name} of + {primitive,bif} -> + emit(indent(12)), + gen_encode_prim(per,Type,dotag,"Val"), + {[],0}; + {constructed,bif} -> + emit([indent(12),"'enc_", + InternalDefFunName,"'(Val)"]), + {[TDef#typedef{name=InternalDefFunName}],1}; + _ -> + emit({indent(12),"'",ExtMod,"':'enc_",Name,"'(Val)"}), + {[],0} + end; +emit_inner_of_fun(#typedef{name=Name},_) -> + emit({indent(12),"'enc_",Name,"'(Val)"}), + {[],0}; +emit_inner_of_fun(Type,_) when record(Type,type) -> + CurrMod = get(currmod), + case Type#type.def of + Def when atom(Def) -> + emit({indent(9),Def," ->",nl,indent(12)}), + gen_encode_prim(erules,Type,dotag,"Val"); + TRef when record(TRef,typereference) -> + T = TRef#typereference.val, + emit({indent(9),T," ->",nl,indent(12),"'enc_",T,"'(Val)"}); + #'Externaltypereference'{module=CurrMod,type=T} -> + emit({indent(9),T," ->",nl,indent(12),"'enc_",T,"'(Val)"}); + #'Externaltypereference'{module=ExtMod,type=T} -> + emit({indent(9),T," ->",nl,indent(12),ExtMod,":'enc_", + T,"'(Val)"}) + end, + {[],0}. + +indent(N) -> + lists:duplicate(N,32). % 32 = space + + +gen_objset_dec(_,{unique,undefined},_,_,_,_) -> + %% There is no unique field in the class of this object set + %% don't bother about the constraint + ok; +gen_objset_dec(ObjSName,UniqueName,[{ObjName,Val,Fields},T|Rest],ClName, + ClFields,NthObj)-> + + emit({"'getdec_",ObjSName,"'(",{asis,UniqueName},",", + {asis,Val},") ->",nl}), + NewNthObj= + case ObjName of + no_name -> + gen_inlined_dec_funs(Fields,ClFields,ObjSName,NthObj); + _ -> + emit({" fun 'dec_",ObjName,"'/4"}), + NthObj + end, + emit({";",nl}), + gen_objset_dec(ObjSName,UniqueName,[T|Rest],ClName,ClFields,NewNthObj); +gen_objset_dec(ObjSetName,UniqueName,[{ObjName,Val,Fields}],_ClName, + ClFields,NthObj) -> + + emit({"'getdec_",ObjSetName,"'(",{asis,UniqueName},",", + {asis,Val},") ->",nl}), + case ObjName of + no_name -> + gen_inlined_dec_funs(Fields,ClFields,ObjSetName,NthObj); + _ -> + emit({" fun 'dec_",ObjName,"'/4"}) + end, + emit({".",nl,nl}), + ok; +gen_objset_dec(ObjSetName,_,['EXTENSIONMARK'],_ClName,_ClFields, + _NthObj) -> + emit({"'getdec_",ObjSetName,"'(_, _) ->",nl}), + emit({indent(3),"fun(Attr1, Bytes, _, _) ->",nl}), + %% emit({indent(6),"?RT_PER:decode_open_type(Bytes,[])",nl}), + emit({indent(6),"{Bytes,Attr1}",nl}), + emit({indent(3),"end.",nl,nl}), + ok; +gen_objset_dec(_,_,[],_,_,_) -> + ok. + +gen_inlined_dec_funs(Fields,[{typefield,Name,_}|Rest], + ObjSetName,NthObj) -> + InternalDefFunName = [NthObj,Name,ObjSetName], + case lists:keysearch(Name,1,Fields) of + {value,{_,Type}} when record(Type,type) -> + emit({indent(3),"fun(Type, Val, _, _) ->",nl, + indent(6),"case Type of",nl}), + N=emit_inner_of_decfun(Type,InternalDefFunName), + gen_inlined_dec_funs1(Fields,Rest,ObjSetName,NthObj+N); + {value,{_,Type}} when record(Type,typedef) -> + emit({indent(3),"fun(Type, Val, _, _) ->",nl, + indent(6),"case Type of",nl}), + emit({indent(9),{asis,Name}," ->",nl}), + N=emit_inner_of_decfun(Type,InternalDefFunName), + gen_inlined_dec_funs1(Fields,Rest,ObjSetName,NthObj+N); + false -> + gen_inlined_dec_funs(Fields,Rest,ObjSetName,NthObj) + end; +gen_inlined_dec_funs(Fields,[_|Rest],ObjSetName,NthObj) -> + gen_inlined_dec_funs(Fields,Rest,ObjSetName,NthObj); +gen_inlined_dec_funs(_,[],_,NthObj) -> + NthObj. + +gen_inlined_dec_funs1(Fields,[{typefield,Name,_}|Rest], + ObjSetName,NthObj) -> + InternalDefFunName = [NthObj,Name,ObjSetName], + N= + case lists:keysearch(Name,1,Fields) of + {value,{_,Type}} when record(Type,type) -> + emit({";",nl}), + emit_inner_of_decfun(Type,InternalDefFunName); + {value,{_,Type}} when record(Type,typedef) -> + emit({";",nl,indent(9),{asis,Name}," ->",nl}), + emit_inner_of_decfun(Type,InternalDefFunName); + false -> + 0 + end, + gen_inlined_dec_funs1(Fields,Rest,ObjSetName,NthObj+N); +gen_inlined_dec_funs1(Fields,[_|Rest],ObjSetName,NthObj)-> + gen_inlined_dec_funs1(Fields,Rest,ObjSetName,NthObj); +gen_inlined_dec_funs1(_,[],_,NthObj) -> + emit({nl,indent(6),"end",nl}), + emit({indent(3),"end"}), + NthObj. + +emit_inner_of_decfun(#typedef{name={ExtName,Name},typespec=Type}, + InternalDefFunName) -> + case {ExtName,Name} of + {primitive,bif} -> + emit(indent(12)), + gen_dec_prim(per,Type,"Val"), + 0; + {constructed,bif} -> + emit({indent(12),"'dec_", + asn1ct_gen:list2name(InternalDefFunName),"'(Val)"}), + 1; + _ -> + emit({indent(12),"'",ExtName,"':'dec_",Name, + "'(Val, telltype)"}), + 0 + end; +emit_inner_of_decfun(#typedef{name=Name},_) -> + emit({indent(12),"'dec_",Name,"'(Val, telltype)"}), + 0; +emit_inner_of_decfun(Type,_) when record(Type,type) -> + CurrMod = get(currmod), + case Type#type.def of + Def when atom(Def) -> + emit({indent(9),Def," ->",nl,indent(12)}), + gen_dec_prim(erules,Type,"Val"); + TRef when record(TRef,typereference) -> + T = TRef#typereference.val, + emit({indent(9),T," ->",nl,indent(12),"'dec_",T,"'(Val)"}); + #'Externaltypereference'{module=CurrMod,type=T} -> + emit({indent(9),T," ->",nl,indent(12),"'dec_",T,"'(Val)"}); + #'Externaltypereference'{module=ExtMod,type=T} -> + emit({indent(9),T," ->",nl,indent(12),ExtMod,":'dec_", + T,"'(Val)"}) + end, + 0. + + +gen_internal_funcs(_Erules,[]) -> + ok; +gen_internal_funcs(Erules,[TypeDef|Rest]) -> + gen_encode_user(Erules,TypeDef), + emit([nl,nl,"'dec_",TypeDef#typedef.name,"'(Bytes) ->",nl]), + gen_decode_user(Erules,TypeDef), + gen_internal_funcs(Erules,Rest). + + + +%% DECODING ***************************** +%%*************************************** + + +gen_decode(Erules,Type) when record(Type,typedef) -> + D = Type, + emit({nl,nl}), + emit({"'dec_",Type#typedef.name,"'(Bytes,_) ->",nl}), + dbdec(Type#typedef.name), + gen_decode_user(Erules,D). + +gen_decode(Erules,Tname,#'ComponentType'{name=Cname,typespec=Type}) -> + NewTname = [Cname|Tname], + gen_decode(Erules,NewTname,Type); + +gen_decode(Erules,Typename,Type) when record(Type,type) -> + InnerType = asn1ct_gen:get_inner(Type#type.def), + case asn1ct_gen:type(InnerType) of + {constructed,bif} -> + ObjFun = + case Type#type.tablecinf of + [{objfun,_}|_R] -> + ", ObjFun"; + _ -> + "" + end, + emit({nl,"'dec_",asn1ct_gen:list2name(Typename), + "'(Bytes,_",ObjFun,") ->",nl}), + dbdec(Typename), + asn1ct_gen:gen_decode_constructed(Erules,Typename,InnerType,Type); + _ -> + true + end. + +dbdec(Type) when list(Type)-> + demit({"io:format(\"decoding: ",asn1ct_gen:list2name(Type),"~w~n\",[Bytes]),",nl}); +dbdec(Type) -> + demit({"io:format(\"decoding: ",{asis,Type},"~w~n\",[Bytes]),",nl}). + +gen_decode_user(Erules,D) when record(D,typedef) -> + CurrMod = get(currmod), + Typename = [D#typedef.name], + Def = D#typedef.typespec, + InnerType = asn1ct_gen:get_inner(Def#type.def), + case asn1ct_gen:type(InnerType) of + {primitive,bif} -> + gen_dec_prim(Erules,Def,"Bytes"), + emit({".",nl,nl}); + 'ASN1_OPEN_TYPE' -> + gen_dec_prim(Erules,Def#type{def='ASN1_OPEN_TYPE'},"Bytes"), + emit({".",nl,nl}); + {constructed,bif} -> + asn1ct_gen:gen_decode_constructed(Erules,Typename,InnerType,D); + #typereference{val=Dname} -> + emit({"'dec_",Dname,"'(Bytes,telltype)"}), + emit({".",nl,nl}); + #'Externaltypereference'{module=CurrMod,type=Etype} -> + emit({"'dec_",Etype,"'(Bytes,telltype).",nl,nl}); + #'Externaltypereference'{module=Emod,type=Etype} -> + emit({"'",Emod,"':'dec_",Etype,"'(Bytes,telltype).",nl,nl}); + Other -> + exit({error,{asn1,{unknown,Other}}}) + end. + + + +gen_dec_prim(_Erules,Att,BytesVar) -> + Typename = Att#type.def, + Constraint = Att#type.constraint, + case Typename of + 'INTEGER' -> + EffectiveConstr = effective_constraint(integer,Constraint), + emit_dec_integer(EffectiveConstr,BytesVar); +% emit({"?RT_PER:decode_integer(",BytesVar,",", +% {asis,EffectiveConstr},")"}); + {'INTEGER',NamedNumberList} -> + EffectiveConstr = effective_constraint(integer,Constraint), + emit_dec_integer(EffectiveConstr,BytesVar,NamedNumberList); +% emit({"?RT_PER:decode_integer(",BytesVar,",", +% {asis,EffectiveConstr},",", +% {asis,NamedNumberList},")"}); + {'BIT STRING',NamedNumberList} -> + case get(compact_bit_string) of + true -> + emit({"?RT_PER:decode_compact_bit_string(", + BytesVar,",",{asis,Constraint},",", + {asis,NamedNumberList},")"}); + _ -> + emit({"?RT_PER:decode_bit_string(",BytesVar,",", + {asis,Constraint},",", + {asis,NamedNumberList},")"}) + end; + 'NULL' -> + emit({"?RT_PER:decode_null(", + BytesVar,")"}); + 'OBJECT IDENTIFIER' -> + emit({"?RT_PER:decode_object_identifier(", + BytesVar,")"}); + 'ObjectDescriptor' -> + emit({"?RT_PER:decode_ObjectDescriptor(", + BytesVar,")"}); + {'ENUMERATED',{NamedNumberList1,NamedNumberList2}} -> + NewTup = {list_to_tuple([X||{X,_} <- NamedNumberList1]), + list_to_tuple([X||{X,_} <- NamedNumberList2])}, + NewC = [{'ValueRange',{0,size(element(1,NewTup))-1}}], + emit({"?RT_PER:decode_enumerated(",BytesVar,",", + {asis,NewC},",", + {asis,NewTup},")"}); + {'ENUMERATED',NamedNumberList} -> + %NewTup = list_to_tuple([X||{X,Y} <- NamedNumberList]), + NewNNL = [X||{X,_} <- NamedNumberList], + NewC = effective_constraint(integer, + [{'ValueRange',{0,length(NewNNL)-1}}]), + emit_dec_enumerated(BytesVar,NewC,NewNNL); +% emit({"?RT_PER:decode_enumerated(",BytesVar,",", +% {asis,NewC},",", +% {asis,NewTup},")"}); + 'BOOLEAN'-> + emit({"?RT_PER:decode_boolean(",BytesVar,")"}); + 'OCTET STRING' -> + emit_dec_octet_string(Constraint,BytesVar); +% emit({"?RT_PER:decode_octet_string(",BytesVar,",", +% {asis,Constraint},")"}); + 'NumericString' -> + emit_dec_known_multiplier_string('NumericString', + Constraint,BytesVar); +% emit({"?RT_PER:decode_NumericString(",BytesVar,",", +% {asis,Constraint},")"}); + 'TeletexString' -> + emit({"?RT_PER:decode_TeletexString(",BytesVar,",", + {asis,Constraint},")"}); + 'VideotexString' -> + emit({"?RT_PER:decode_VideotexString(",BytesVar,",", + {asis,Constraint},")"}); + 'UTCTime' -> + emit_dec_known_multiplier_string('VisibleString', + Constraint,BytesVar); +% emit({"?RT_PER:decode_VisibleString(",BytesVar,",", +% {asis,Constraint},")"}); + 'GeneralizedTime' -> + emit_dec_known_multiplier_string('VisibleString', + Constraint,BytesVar); +% emit({"?RT_PER:decode_VisibleString(",BytesVar,",", +% {asis,Constraint},")"}); + 'GraphicString' -> + emit({"?RT_PER:decode_GraphicString(",BytesVar,",", + {asis,Constraint},")"}); + 'VisibleString' -> + emit_dec_known_multiplier_string('VisibleString', + Constraint,BytesVar); +% emit({"?RT_PER:decode_VisibleString(",BytesVar,",", +% {asis,Constraint},")"}); + 'GeneralString' -> + emit({"?RT_PER:decode_GeneralString(",BytesVar,",", + {asis,Constraint},")"}); + 'PrintableString' -> + emit_dec_known_multiplier_string('PrintableString', + Constraint,BytesVar); +% emit({"?RT_PER:decode_PrintableString(",BytesVar,",",{asis,Constraint},")"}); + 'IA5String' -> + emit_dec_known_multiplier_string('IA5String',Constraint,BytesVar); +% emit({"?RT_PER:decode_IA5String(",BytesVar,",",{asis,Constraint},")"}); + 'BMPString' -> + emit_dec_known_multiplier_string('BMPString',Constraint,BytesVar); +% emit({"?RT_PER:decode_BMPString(",BytesVar,",",{asis,Constraint},")"}); + 'UniversalString' -> + emit_dec_known_multiplier_string('UniversalString', + Constraint,BytesVar); +% emit({"?RT_PER:decode_UniversalString(",BytesVar,",",{asis,Constraint},")"}); + 'ANY' -> + emit(["?RT_PER:decode_open_type(",BytesVar,",", + {asis,Constraint}, ")"]); + 'ASN1_OPEN_TYPE' -> + case Constraint of + [#'Externaltypereference'{type=Tname}] -> + emit(["fun(FBytes) ->",nl, + " {XTerm,XBytes} = "]), + emit(["?RT_PER:decode_open_type(FBytes,[]),",nl]), + emit([" {YTerm,_} = dec_",Tname,"(XTerm,mandatory),",nl]), + emit([" {YTerm,XBytes} end(",BytesVar,")"]); + [#type{def=#'Externaltypereference'{type=Tname}}] -> + emit(["fun(FBytes) ->",nl, + " {XTerm,XBytes} = "]), + emit(["?RT_PER:decode_open_type(FBytes,[]),",nl]), + emit([" {YTerm,_} = dec_",Tname,"(XTerm,mandatory),",nl]), + emit([" {YTerm,XBytes} end(",BytesVar,")"]); + _ -> + emit(["?RT_PER:decode_open_type(",BytesVar,",[])"]) + end; + Other -> + exit({'cant decode' ,Other}) + end. + + +emit_dec_integer(C,BytesVar,NNL) -> + asn1ct_name:new(tmpterm), + asn1ct_name:new(buffer), + Tmpterm = asn1ct_gen:mk_var(asn1ct_name:curr(tmpterm)), + Buffer = asn1ct_gen:mk_var(asn1ct_name:curr(buffer)), + emit({" begin {",{curr,tmpterm},",",{curr,buffer},"} = ",nl}), + emit_dec_integer(C,BytesVar), + emit({",",nl," case ",Tmpterm," of",nl}), + lists:map(fun({Name,Int})->emit({" ",Int," -> {",{asis,Name},",", + Buffer,"};",nl}); + (_)-> exit({error,{asn1,{"error in named number list",NNL}}}) + end, + NNL), + emit({" _ -> {",Tmpterm,",",Buffer,"}",nl}), + emit({" end",nl}), % end of case + emit(" end"). % end of begin + +emit_dec_integer([{'SingleValue',Int}],BytesVar) when integer(Int) -> + emit(["{",Int,",",BytesVar,"}"]); +emit_dec_integer([{_,{Lb,_Ub},_Range,{BitsOrOctets,N}}],BytesVar) -> + GetBorO = + case BitsOrOctets of + bits -> "getbits"; + _ -> "getoctets" + end, + asn1ct_name:new(tmpterm), + asn1ct_name:new(tmpremain), + emit({" begin",nl," {",{curr,tmpterm},",",{curr,tmpremain},"}=", + "?RT_PER:",GetBorO,"(",BytesVar,",",N,"),",nl}), + emit({" {",{curr,tmpterm},"+",Lb,",",{curr,tmpremain},"}",nl, + " end"}); +emit_dec_integer([{_,{'MIN',_}}],BytesVar) -> + emit({"?RT_PER:decode_unconstrained_number(",BytesVar,")"}); +emit_dec_integer([{_,{Lb,'MAX'}}],BytesVar) -> + emit({"?RT_PER:decode_semi_constrained_number(",BytesVar,",",Lb,")"}); +emit_dec_integer([{'ValueRange',VR={Lb,Ub}}],BytesVar) -> + Range = Ub-Lb+1, + emit({"?RT_PER:decode_constrained_number(",BytesVar,",", + {asis,VR},",",Range,")"}); +emit_dec_integer(C=[{Rc,_}],BytesVar) when tuple(Rc) -> + emit({"?RT_PER:decode_integer(",BytesVar,",",{asis,C},")"}); +emit_dec_integer(_,BytesVar) -> + emit({"?RT_PER:decode_unconstrained_number(",BytesVar,")"}). + + +emit_dec_enumerated(BytesVar,C,NamedNumberList) -> + emit_dec_enumerated_begin(),% emits a begin if component + asn1ct_name:new(tmpterm), + Tmpterm = asn1ct_gen:mk_var(asn1ct_name:curr(tmpterm)), + asn1ct_name:new(tmpremain), + Tmpremain = asn1ct_gen:mk_var(asn1ct_name:curr(tmpremain)), + emit({" {",{curr,tmpterm},",",{curr,tmpremain},"} =",nl}), + emit_dec_integer(C,BytesVar), + emit({",",nl," case ",Tmpterm," of "}), +% Cases=lists:flatten(dec_enumerated_cases(NamedNumberList,asn1ct_gen:mk_var(asn1ct_name:curr(tmpremain)),0)), + Cases=lists:flatten(dec_enumerated_cases(NamedNumberList,Tmpremain,0)), + emit({Cases++"_->exit({error,{asn1,{decode_enumerated,{",Tmpterm, + ",",{asis,NamedNumberList},"}}}}) end",nl}), + emit_dec_enumerated_end(). + +emit_dec_enumerated_begin() -> + case get(component_type) of + {true,_} -> + emit({" begin",nl}); + _ -> ok + end. + +emit_dec_enumerated_end() -> + case get(component_type) of + {true,_} -> + emit(" end"); + _ -> ok + end. + +% dec_enumerated_cases(NNL,Tmpremain,No) -> +% Cases=dec_enumerated_cases1(NNL,Tmpremain,0), +% lists:flatten(io_lib:format("(case ~s "++Cases++ +% "~s when atom(~s)->exit({error,{asn1,{namednumber,~s}}});_->~s end)",[Value,"TmpVal","TmpVal","TmpVal",Value])). + +dec_enumerated_cases([Name|Rest],Tmpremain,No) -> + io_lib:format("~w->{~w,~s};",[No,Name,Tmpremain])++ + dec_enumerated_cases(Rest,Tmpremain,No+1); +dec_enumerated_cases([],_,_) -> + "". + + +% more_genfields(_Fields,[]) -> +% false; +% more_genfields(Fields,[{FieldName,_}|T]) -> +% case is_typefield(Fields,FieldName) of +% true -> true; +% {false,objectfield} -> true; +% {false,_} -> more_genfields(Fields,T) +% end. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_name.erl b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_name.erl new file mode 100644 index 0000000000..1c7769998c --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_name.erl @@ -0,0 +1,225 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: asn1ct_name.erl,v 1.1 2008/12/17 09:53:30 mikpe Exp $ +%% +-module(asn1ct_name). + +%%-compile(export_all). +-export([name_server_loop/1, + start/0, + stop/0, + push/1, + pop/1, + curr/1, + clear/0, + delete/1, + active/1, + prev/1, + next/1, + all/1, + new/1]). + +start() -> + start_server(asn1_ns, asn1ct_name,name_server_loop,[[]]). + +stop() -> stop_server(asn1_ns). + +name_server_loop(Vars) -> +%% io:format("name -- ~w~n",[Vars]), + receive + {From,{current,Variable}} -> + From ! {asn1_ns,get_curr(Vars,Variable)}, + name_server_loop(Vars); + {From,{pop,Variable}} -> + From ! {asn1_ns,done}, + name_server_loop(pop_var(Vars,Variable)); + {From,{push,Variable}} -> + From ! {asn1_ns,done}, + name_server_loop(push_var(Vars,Variable)); + {From,{delete,Variable}} -> + From ! {asn1_ns,done}, + name_server_loop(delete_var(Vars,Variable)); + {From,{new,Variable}} -> + From ! {asn1_ns,done}, + name_server_loop(new_var(Vars,Variable)); + {From,{prev,Variable}} -> + From ! {asn1_ns,get_prev(Vars,Variable)}, + name_server_loop(Vars); + {From,{next,Variable}} -> + From ! {asn1_ns,get_next(Vars,Variable)}, + name_server_loop(Vars); + {From,stop} -> + From ! {asn1_ns,stopped}, + exit(normal) + end. + +active(V) -> + case curr(V) of + nil -> false; + _ -> true + end. + +req(Req) -> + asn1_ns ! {self(), Req}, + receive {asn1_ns, Reply} -> Reply end. + +pop(V) -> req({pop,V}). +push(V) -> req({push,V}). +clear() -> req(stop), start(). +curr(V) -> req({current,V}). +new(V) -> req({new,V}). +delete(V) -> req({delete,V}). +prev(V) -> + case req({prev,V}) of + none -> + exit('cant get prev of none'); + Rep -> Rep + end. + +next(V) -> + case req({next,V}) of + none -> + exit('cant get next of none'); + Rep -> Rep + end. + +all(V) -> + Curr = curr(V), + if Curr == V -> []; + true -> + lists:reverse(generate(V,last(Curr),[],0)) + end. + +generate(V,Number,Res,Pos) -> + Ell = Pos+1, + if + Ell > Number -> + Res; + true -> + generate(V,Number,[list_to_atom(lists:concat([V,Ell]))|Res],Ell) + end. + +last(V) -> + last2(lists:reverse(atom_to_list(V))). + +last2(RevL) -> + list_to_integer(lists:reverse(get_digs(RevL))). + + +get_digs([H|T]) -> + if + H < $9+1, + H > $0-1 -> + [H|get_digs(T)]; + true -> + [] + end. + +push_var(Vars,Variable) -> + case lists:keysearch(Variable,1,Vars) of + false -> + [{Variable,[0]}|Vars]; + {value,{Variable,[Digit|Drest]}} -> + NewVars = lists:keydelete(Variable,1,Vars), + [{Variable,[Digit,Digit|Drest]}|NewVars] + end. + +pop_var(Vars,Variable) -> + case lists:keysearch(Variable,1,Vars) of + false -> + ok; + {value,{Variable,[_Dig]}} -> + lists:keydelete(Variable,1,Vars); + {value,{Variable,[_Dig|Digits]}} -> + NewVars = lists:keydelete(Variable,1,Vars), + [{Variable,Digits}|NewVars] + end. + +get_curr([],Variable) -> + Variable; +get_curr([{Variable,[0|_Drest]}|_Tail],Variable) -> + Variable; +get_curr([{Variable,[Digit|_Drest]}|_Tail],Variable) -> + list_to_atom(lists:concat([Variable,integer_to_list(Digit)])); + +get_curr([_|Tail],Variable) -> + get_curr(Tail,Variable). + +new_var(Vars,Variable) -> + case lists:keysearch(Variable,1,Vars) of + false -> + [{Variable,[1]}|Vars]; + {value,{Variable,[Digit|Drest]}} -> + NewVars = lists:keydelete(Variable,1,Vars), + [{Variable,[Digit+1|Drest]}|NewVars] + end. + +delete_var(Vars,Variable) -> + case lists:keysearch(Variable,1,Vars) of + false -> + Vars; + {value,{Variable,[N]}} when N =< 1 -> + lists:keydelete(Variable,1,Vars); + {value,{Variable,[Digit|Drest]}} -> + case Digit of + 0 -> + Vars; + _ -> + NewVars = lists:keydelete(Variable,1,Vars), + [{Variable,[Digit-1|Drest]}|NewVars] + end + end. + +get_prev(Vars,Variable) -> + case lists:keysearch(Variable,1,Vars) of + false -> + none; + {value,{Variable,[Digit|_]}} when Digit =< 1 -> + Variable; + {value,{Variable,[Digit|_]}} when Digit > 1 -> + list_to_atom(lists:concat([Variable, + integer_to_list(Digit-1)])); + _ -> + none + end. + +get_next(Vars,Variable) -> + case lists:keysearch(Variable,1,Vars) of + false -> + list_to_atom(lists:concat([Variable,"1"])); + {value,{Variable,[Digit|_]}} when Digit >= 0 -> + list_to_atom(lists:concat([Variable, + integer_to_list(Digit+1)])); + _ -> + none + end. + + +stop_server(Name) -> + stop_server(Name, whereis(Name)). +stop_server(_Name, undefined) -> stopped; +stop_server(Name, _Pid) -> + Name ! {self(), stop}, + receive {Name, _} -> stopped end. + + +start_server(Name,Mod,Fun,Args) -> + case whereis(Name) of + undefined -> + register(Name, spawn(Mod,Fun, Args)); + _Pid -> + already_started + end. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_parser.yrl b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_parser.yrl new file mode 100644 index 0000000000..b2c1d70f6e --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_parser.yrl @@ -0,0 +1,1162 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: asn1ct_parser.yrl,v 1.1 2008/12/17 09:53:30 mikpe Exp $ +%% +Nonterminals +ModuleDefinition ModuleIdentifier DefinitiveIdentifier DefinitiveObjIdComponentList +DefinitiveObjIdComponent TagDefault ExtensionDefault +ModuleBody Exports SymbolsExported Imports SymbolsImported +SymbolsFromModuleList SymbolsFromModule GlobalModuleReference AssignedIdentifier SymbolList +Symbol Reference AssignmentList Assignment +ExtensionAndException +ComponentTypeLists +Externaltypereference Externalvaluereference DefinedType DefinedValue +AbsoluteReference ItemSpec ItemId ComponentId TypeAssignment +ValueAssignment +% ValueSetTypeAssignment +ValueSet +Type BuiltinType NamedType ReferencedType +Value ValueNotNull BuiltinValue ReferencedValue NamedValue +% BooleanType +BooleanValue IntegerType NamedNumberList NamedNumber SignedNumber +% inlined IntegerValue +EnumeratedType +% inlined Enumerations +Enumeration EnumerationItem +% inlined EnumeratedValue +% RealType +RealValue NumericRealValue SpecialRealValue BitStringType +% inlined BitStringValue +IdentifierList +% OctetStringType +% inlined OctetStringValue +% NullType NullValue +SequenceType ComponentTypeList ComponentType +% SequenceValue SequenceOfValue +ComponentValueList SequenceOfType +SAndSOfValue ValueList SetType +% SetValue SetOfValue +SetOfType +ChoiceType +% AlternativeTypeList made common with ComponentTypeList +ChoiceValue +AnyValue +AnyDefBy +SelectionType +TaggedType Tag ClassNumber Class +% redundant TaggedValue +% EmbeddedPDVType EmbeddedPDVValue ExternalType ExternalValue ObjectIdentifierType +ObjectIdentifierValue ObjIdComponentList ObjIdComponent +% NameForm NumberForm NameAndNumberForm +CharacterStringType +RestrictedCharacterStringValue CharacterStringList +% CharSyms CharsDefn +Quadruple +% Group Plane Row Cell +Tuple +% TableColumn TableRow +% UnrestrictedCharacterString +CharacterStringValue +% UnrestrictedCharacterStringValue +ConstrainedType Constraint ConstraintSpec TypeWithConstraint +ElementSetSpecs ElementSetSpec +%GeneralConstraint +UserDefinedConstraint UserDefinedConstraintParameter +UserDefinedConstraintParameters +ExceptionSpec +ExceptionIdentification +Unions +UnionMark +UElems +Intersections +IntersectionElements +IntersectionMark +IElems +Elements +Elems +SubTypeElements +Exclusions +LowerEndpoint +UpperEndpoint +LowerEndValue +UpperEndValue +TypeConstraints NamedConstraint PresenceConstraint + +ParameterizedTypeAssignment +ParameterList +Parameters +Parameter +ParameterizedType + +% X.681 +ObjectClassAssignment ObjectClass ObjectClassDefn +FieldSpecs FieldSpec OptionalitySpec WithSyntaxSpec +TokenOrGroupSpecs TokenOrGroupSpec +SyntaxList OptionalGroup RequiredToken Word +TypeOptionalitySpec +ValueOrObjectOptSpec +VSetOrOSetOptSpec +ValueOptionalitySpec +ObjectOptionalitySpec +ValueSetOptionalitySpec +ObjectSetOptionalitySpec +% X.681 chapter 15 +InformationFromObjects +ValueFromObject +%ValueSetFromObjects +TypeFromObject +%ObjectFromObject +%ObjectSetFromObjects +ReferencedObjects +FieldName +PrimitiveFieldName + +ObjectAssignment +ObjectSetAssignment +ObjectSet +ObjectSetElements +Object +ObjectDefn +DefaultSyntax +DefinedSyntax +FieldSettings +FieldSetting +DefinedSyntaxTokens +DefinedSyntaxToken +Setting +DefinedObject +ObjectFromObject +ObjectSetFromObjects +ParameterizedObject +ExternalObjectReference +DefinedObjectSet +DefinedObjectClass +ExternalObjectClassReference + +% X.682 +TableConstraint +ComponentRelationConstraint +ComponentIdList + +% X.683 +ActualParameter +. + +%UsefulType. + +Terminals +'ABSENT' 'ABSTRACT-SYNTAX' 'ALL' 'ANY' +'APPLICATION' 'AUTOMATIC' 'BEGIN' 'BIT' +'BOOLEAN' 'BY' 'CHARACTER' 'CHOICE' 'CLASS' 'COMPONENT' +'COMPONENTS' 'CONSTRAINED' 'DEFAULT' 'DEFINED' 'DEFINITIONS' +'EMBEDDED' 'END' 'ENUMERATED' 'EXCEPT' 'EXPLICIT' +'EXPORTS' 'EXTENSIBILITY' 'EXTERNAL' 'FALSE' 'FROM' 'GeneralizedTime' +'TYPE-IDENTIFIER' +'IDENTIFIER' 'IMPLICIT' 'IMPLIED' 'IMPORTS' +'INCLUDES' 'INSTANCE' 'INTEGER' 'INTERSECTION' +'MAX' 'MIN' 'MINUS-INFINITY' 'NULL' +'OBJECT' 'ObjectDescriptor' 'OCTET' 'OF' 'OPTIONAL' 'PDV' 'PLUS-INFINITY' +'PRESENT' 'PRIVATE' 'REAL' 'SEQUENCE' 'SET' 'SIZE' +'STRING' 'SYNTAX' 'TAGS' 'TRUE' 'UNION' +'UNIQUE' 'UNIVERSAL' 'UTCTime' 'WITH' +'{' '}' '(' ')' '.' '::=' ';' ',' '@' '*' '-' '[' ']' +'!' '..' '...' '|' '<' ':' '^' +number identifier typereference restrictedcharacterstringtype +bstring hstring cstring typefieldreference valuefieldreference +objectclassreference word. + +Rootsymbol ModuleDefinition. +Endsymbol '$end'. + +Left 300 'EXCEPT'. +Left 200 '^'. +Left 200 'INTERSECTION'. +Left 100 '|'. +Left 100 'UNION'. + + +ModuleDefinition -> ModuleIdentifier + 'DEFINITIONS' + TagDefault + ExtensionDefault + '::=' + 'BEGIN' + ModuleBody + 'END' : + {'ModuleBody',Ex,Im,Types} = '$7', + {{typereference,Pos,Name},Defid} = '$1', + #module{ + pos= Pos, + name= Name, + defid= Defid, + tagdefault='$3', + extensiondefault='$4', + exports=Ex, + imports=Im, + typeorval=Types}. +% {module, '$1','$3','$6'}. +% Results always in a record of type module defined in asn_records.hlr + +ModuleIdentifier -> typereference DefinitiveIdentifier : + put(asn1_module,'$1'#typereference.val), + {'$1','$2'}. + +DefinitiveIdentifier -> '{' DefinitiveObjIdComponentList '}' : '$2' . +DefinitiveIdentifier -> '$empty': []. + +DefinitiveObjIdComponentList -> DefinitiveObjIdComponent : ['$1']. +DefinitiveObjIdComponentList -> DefinitiveObjIdComponent DefinitiveObjIdComponentList : ['$1'|'$2']. + +DefinitiveObjIdComponent -> identifier : '$1' . %expanded-> +% DefinitiveObjIdComponent -> NameForm : '$1' . +DefinitiveObjIdComponent -> number : '$1' . %expanded-> +% DefinitiveObjIdComponent -> DefinitiveNumberForm : 'fix' . +DefinitiveObjIdComponent -> identifier '(' number ')' : {'$1','$3'} . %expanded-> +% DefinitiveObjIdComponent -> DefinitiveNameAndNumberForm : {'$1','$3'} . + +% DefinitiveNumberForm -> number : 'fix' . + +% DefinitiveNameAndNumberForm -> identifier '(' DefinitiveNumberForm ')' : 'fix' . + +TagDefault -> 'EXPLICIT' 'TAGS' : put(tagdefault,'EXPLICIT'),'EXPLICIT' . +TagDefault -> 'IMPLICIT' 'TAGS' : put(tagdefault,'IMPLICIT'),'IMPLICIT' . +TagDefault -> 'AUTOMATIC' 'TAGS' : put(tagdefault,'AUTOMATIC'),'AUTOMATIC' . +TagDefault -> '$empty': put(tagdefault,'EXPLICIT'),'EXPLICIT'. % because this is the default + +ExtensionDefault -> 'EXTENSIBILITY' 'IMPLIED' : 'IMPLIED'. +ExtensionDefault -> '$empty' : 'false'. % because this is the default + +ModuleBody -> Exports Imports AssignmentList : {'ModuleBody','$1','$2','$3'}. +ModuleBody -> '$empty' : {'ModuleBody',nil,nil,[]}. + +Exports -> 'EXPORTS' SymbolList ';' : {exports,'$2'}. +Exports -> 'EXPORTS' ';' : {exports,[]}. +Exports -> '$empty' : {exports,all} . + +% inlined above SymbolsExported -> SymbolList : '$1'. +% inlined above SymbolsExported -> '$empty' : []. + +Imports -> 'IMPORTS' SymbolsFromModuleList ';' : {imports,'$2'}. +Imports -> 'IMPORTS' ';' : {imports,[]}. +Imports -> '$empty' : {imports,[]} . + +% inlined above SymbolsImported -> SymbolsFromModuleList : '$1'. +% inlined above SymbolsImported -> '$empty' : []. + +SymbolsFromModuleList -> SymbolsFromModule :['$1']. +% SymbolsFromModuleList -> SymbolsFromModuleList SymbolsFromModule :$1.%changed +SymbolsFromModuleList -> SymbolsFromModule SymbolsFromModuleList :['$1'|'$2']. + +% expanded SymbolsFromModule -> SymbolList 'FROM' GlobalModuleReference : #'SymbolsFromModule'{symbols = '$1',module='$3'}. +SymbolsFromModule -> SymbolList 'FROM' typereference : #'SymbolsFromModule'{symbols = '$1',module='$3'}. +SymbolsFromModule -> SymbolList 'FROM' typereference '{' ValueList '}': #'SymbolsFromModule'{symbols = '$1',module='$3'}. +%SymbolsFromModule -> SymbolList 'FROM' typereference identifier: #'SymbolsFromModule'{symbols = '$1',module='$3'}. +%SymbolsFromModule -> SymbolList 'FROM' typereference Externalvaluereference: #'SymbolsFromModule'{symbols = '$1',module='$3'}. +%SymbolsFromModule -> SymbolList 'FROM' typereference DefinedValue: #'SymbolsFromModule'{symbols = '$1',module='$3'}. + +% inlined GlobalModuleReference -> typereference AssignedIdentifier : {'$1','$2'} . + +% inlined above AssignedIdentifier -> '{' ValueList '}' : '$2'. +% replaced AssignedIdentifier -> '{' DefinedValue ObjIdComponentList '}' :{'$2','$3'}. +% not necessary , replaced by SAndSOfValue AssignedIdentifier -> ObjectIdentifierValue :'$1'. +% AssignedIdentifier -> DefinedValue : '$1'. +% inlined AssignedIdentifier -> '$empty' : undefined. + +SymbolList -> Symbol : ['$1']. +SymbolList -> Symbol ',' SymbolList :['$1'|'$3']. + +Symbol -> Reference :'$1'. +% later Symbol -> ParameterizedReference :'$1'. + +Reference -> typereference :'$1'. +Reference -> identifier:'$1'. +Reference -> typereference '{' '}':'$1'. +Reference -> Externaltypereference '{' '}':'$1'. + +% later Reference -> objectclassreference :'$1'. +% later Reference -> objectreference :'$1'. +% later Reference -> objectsetreference :'$1'. + +AssignmentList -> Assignment : ['$1']. +% modified AssignmentList -> AssignmentList Assignment : '$1'. +AssignmentList -> Assignment AssignmentList : ['$1'|'$2']. + +Assignment -> TypeAssignment : '$1'. +Assignment -> ValueAssignment : '$1'. +% later Assignment -> ValueSetTypeAssignment : '$1'. +Assignment -> ObjectClassAssignment : '$1'. +% later Assignment -> ObjectAssignment : '$1'. +% combined with ValueAssignment Assignment -> ObjectAssignment : '$1'. +Assignment -> ObjectSetAssignment : '$1'. +Assignment -> ParameterizedTypeAssignment : '$1'. +%Assignment -> ParameterizedValueAssignment : '$1'. +%Assignment -> ParameterizedValueSetTypeAssignment : '$1'. +%Assignment -> ParameterizedObjectClassAssignment : '$1'. + +ObjectClassAssignment -> typereference '::=' 'CLASS' '{' FieldSpecs '}' : +%ObjectClassAssignment -> objectclassreference '::=' 'CLASS' '{' FieldSpecs '}' : + #typedef{pos=element(2,'$1'),name=element(3,'$1'),typespec={'CLASS','$5',[]}}. +ObjectClassAssignment -> typereference '::=' 'CLASS' '{' FieldSpecs '}' WithSyntaxSpec : +%ObjectClassAssignment -> objectclassreference '::=' 'CLASS' '{' FieldSpecs '}' WithSyntaxSpec : + #typedef{pos=element(2,'$1'),name=element(3,'$1'),typespec={'CLASS','$5','$7'}}. + +FieldSpecs -> FieldSpec : ['$1']. +FieldSpecs -> FieldSpec ',' FieldSpecs : ['$1'|'$3']. + +FieldSpec -> typefieldreference TypeOptionalitySpec : {typefield,'$1','$2'}. + +FieldSpec -> valuefieldreference Type 'UNIQUE' ValueOrObjectOptSpec : + {fixedtypevaluefield,'$1','$2','UNIQUE','$4'}. +FieldSpec -> valuefieldreference Type ValueOrObjectOptSpec : + {fixedtypevaluefield,'$1','$2',undefined,'$3'}. + +FieldSpec -> valuefieldreference typefieldreference ValueOrObjectOptSpec : + {variabletypevaluefield, '$1','$2','$3'}. + +FieldSpec -> typefieldreference typefieldreference VSetOrOSetOptSpec : + {variabletypevaluesetfield, '$1','$2','$3'}. + +FieldSpec -> typefieldreference Type VSetOrOSetOptSpec : + {fixedtypevaluesetfield, '$1','$2','$3'}. + +TypeOptionalitySpec -> 'DEFAULT' Type : {'DEFAULT','$2'}. +TypeOptionalitySpec -> 'OPTIONAL' : 'OPTIONAL'. +TypeOptionalitySpec -> '$empty' : 'MANDATORY'. + +ValueOrObjectOptSpec -> ValueOptionalitySpec : '$1'. +ValueOrObjectOptSpec -> ObjectOptionalitySpec : '$1'. +ValueOrObjectOptSpec -> 'OPTIONAL' : 'OPTIONAL'. +ValueOrObjectOptSpec -> '$empty' : 'MANDATORY'. + +ValueOptionalitySpec -> 'DEFAULT' Value : + case '$2' of + {identifier,_,Id} -> {'DEFAULT',Id}; + _ -> {'DEFAULT','$2'} + end. + +%ObjectOptionalitySpec -> 'DEFAULT' Object :{'DEFAULT','$1'}. +ObjectOptionalitySpec -> 'DEFAULT' '{' FieldSetting ',' FieldSettings '}' : + {'DEFAULT',{object,['$2'|'$4']}}. +ObjectOptionalitySpec -> 'DEFAULT' '{' FieldSetting '}' : + {'DEFAULT',{object, ['$2']}}. +%ObjectOptionalitySpec -> 'DEFAULT' '{' DefinedSyntaxTokens '}' : +% {'DEFAULT',{object, '$2'}}. +ObjectOptionalitySpec -> 'DEFAULT' ObjectFromObject : + {'DEFAULT',{object, '$2'}}. + + +VSetOrOSetOptSpec -> ValueSetOptionalitySpec : '$1'. +%VSetOrOSetOptSpec -> ObjectSetOptionalitySpec : '$1'. +VSetOrOSetOptSpec -> 'OPTIONAL' : 'OPTIONAL'. +VSetOrOSetOptSpec -> '$empty' : 'MANDATORY'. + +ValueSetOptionalitySpec -> 'DEFAULT' ValueSet : {'DEFAULT','$1'}. + +%ObjectSetOptionalitySpec -> 'DEFAULT' ObjectSet : {'DEFAULT','$1'}. + +OptionalitySpec -> 'DEFAULT' Type : {'DEFAULT','$2'}. +OptionalitySpec -> 'DEFAULT' ValueNotNull : + case '$2' of + {identifier,_,Id} -> {'DEFAULT',Id}; + _ -> {'DEFAULT','$2'} + end. +OptionalitySpec -> 'OPTIONAL' : 'OPTIONAL'. +OptionalitySpec -> '$empty' : 'MANDATORY'. + +WithSyntaxSpec -> 'WITH' 'SYNTAX' SyntaxList : {'WITH SYNTAX','$3'}. + +SyntaxList -> '{' TokenOrGroupSpecs '}' : '$2'. +SyntaxList -> '{' '}' : []. + +TokenOrGroupSpecs -> TokenOrGroupSpec : ['$1']. +TokenOrGroupSpecs -> TokenOrGroupSpec TokenOrGroupSpecs : ['$1'|'$2']. + +TokenOrGroupSpec -> RequiredToken : '$1'. +TokenOrGroupSpec -> OptionalGroup : '$1'. + +OptionalGroup -> '[' TokenOrGroupSpecs ']' : '$2'. + +RequiredToken -> typereference : '$1'. +RequiredToken -> Word : '$1'. +RequiredToken -> ',' : '$1'. +RequiredToken -> PrimitiveFieldName : '$1'. + +Word -> 'BY' : 'BY'. + +ParameterizedTypeAssignment -> typereference ParameterList '::=' Type : + #ptypedef{pos=element(2,'$1'),name=element(3,'$1'), + args='$2', typespec='$4'}. + +ParameterList -> '{' Parameters '}':'$2'. + +Parameters -> Parameter: ['$1']. +Parameters -> Parameter ',' Parameters: ['$1'|'$3']. + +Parameter -> typereference: '$1'. +Parameter -> Value: '$1'. +Parameter -> Type ':' typereference: {'$1','$3'}. +Parameter -> Type ':' Value: {'$1','$3'}. +Parameter -> '{' typereference '}': {objectset,'$2'}. + + +% Externaltypereference -> modulereference '.' typereference : {'$1','$3'} . +Externaltypereference -> typereference '.' typereference : #'Externaltypereference'{pos=element(2,'$1'),module=element(3,'$1'),type=element(3,'$3')}. + +% Externalvaluereference -> modulereference '.' valuereference : {'$1','$3'} . +% inlined Externalvaluereference -> typereference '.' identifier : #'Externalvaluereference'{pos=element(2,'$1'),module=element(3,'$1'),value=element(3,'$3')}. + + +DefinedType -> Externaltypereference : '$1' . +DefinedType -> typereference : + #'Externaltypereference'{pos='$1'#typereference.pos, + module= get(asn1_module), + type= '$1'#typereference.val} . +DefinedType -> typereference ParameterList : {pt,'$1','$2'}. +DefinedType -> Externaltypereference ParameterList : {pt,'$1','$2'}. + +% ActualParameterList -> '{' ActualParameters '}' : '$1'. + +% ActualParameters -> ActualParameter : ['$1']. +% ActualParameters -> ActualParameter ',' ActualParameters : ['$1'|'$3']. + +ActualParameter -> Type : '$1'. +ActualParameter -> ValueNotNull : '$1'. +ActualParameter -> ValueSet : '$1'. +% later DefinedType -> ParameterizedType : '$1' . +% later DefinedType -> ParameterizedValueSetType : '$1' . + +% inlined DefinedValue -> Externalvaluereference :'$1'. +% inlined DefinedValue -> identifier :'$1'. +% later DefinedValue -> ParameterizedValue :'$1'. + +% not referenced yet AbsoluteReference -> '@' GlobalModuleReference '.' ItemSpec :{'$2','$4'}. + +% not referenced yet ItemSpec -> typereference :'$1'. +% not referenced yet ItemSpec -> ItemId '.' ComponentId : {'$1','$3'}. + +% not referenced yet ItemId -> ItemSpec : '$1'. + +% not referenced yet ComponentId -> identifier :'$1'. +% not referenced yet ComponentId -> number :'$1'. +% not referenced yet ComponentId -> '*' :'$1'. + +TypeAssignment -> typereference '::=' Type : + #typedef{pos=element(2,'$1'),name=element(3,'$1'),typespec='$3'}. + +ValueAssignment -> identifier Type '::=' Value : + #valuedef{pos=element(2,'$1'),name=element(3,'$1'),type='$2',value='$4'}. + +% later ValueSetTypeAssignment -> typereference Type '::=' ValueSet :{'ValueSetTypeAssignment','$1','$2','$4'}. + + +ValueSet -> '{' ElementSetSpec '}' : {valueset,'$2'}. + +% record(type,{tag,def,constraint}). +Type -> BuiltinType :#type{def='$1'}. +Type -> 'NULL' :#type{def='NULL'}. +Type -> TaggedType:'$1'. +Type -> ReferencedType:#type{def='$1'}. % change notag later +Type -> ConstrainedType:'$1'. + +%ANY is here for compatibility with the old ASN.1 standard from 1988 +BuiltinType -> 'ANY' AnyDefBy: + case '$2' of + [] -> 'ANY'; + _ -> {'ANY DEFINED BY','$2'} + end. +BuiltinType -> BitStringType :'$1'. +BuiltinType -> 'BOOLEAN' :element(1,'$1'). +BuiltinType -> CharacterStringType :'$1'. +BuiltinType -> ChoiceType :'$1'. +BuiltinType -> 'EMBEDDED' 'PDV' :'EMBEDDED PDV'. +BuiltinType -> EnumeratedType :'$1'. +BuiltinType -> 'EXTERNAL' :element(1,'$1'). +% later BuiltinType -> InstanceOfType :'$1'. +BuiltinType -> IntegerType :'$1'. +% BuiltinType -> 'NULL' :element(1,'$1'). +% later BuiltinType -> ObjectClassFieldType :'$1'. +BuiltinType -> 'OBJECT' 'IDENTIFIER' :'OBJECT IDENTIFIER'. +BuiltinType -> 'OCTET' 'STRING' :'OCTET STRING'. +BuiltinType -> 'REAL' :element(1,'$1'). +BuiltinType -> SequenceType :'$1'. +BuiltinType -> SequenceOfType :'$1'. +BuiltinType -> SetType :'$1'. +BuiltinType -> SetOfType :'$1'. +% The so called Useful types +BuiltinType -> 'GeneralizedTime': 'GeneralizedTime'. +BuiltinType -> 'UTCTime' :'UTCTime'. +BuiltinType -> 'ObjectDescriptor' : 'ObjectDescriptor'. + +% moved BuiltinType -> TaggedType :'$1'. + + +AnyDefBy -> 'DEFINED' 'BY' identifier: '$3'. +AnyDefBy -> '$empty': []. + +NamedType -> identifier Type : +%{_,Pos,Val} = '$1', +%{'NamedType',Pos,{Val,'$2'}}. +V1 = '$1', +{'NamedType',V1#identifier.pos,{V1#identifier.val,'$2'}}. +NamedType -> SelectionType :'$1'. + +ReferencedType -> DefinedType : '$1'. +% redundant ReferencedType -> UsefulType : 'fix'. +ReferencedType -> SelectionType : '$1'. +ReferencedType -> TypeFromObject : '$1'. +% later ReferencedType -> ValueSetFromObjects : 'fix'. + +% to much conflicts Value -> AnyValue :'$1'. +Value -> ValueNotNull : '$1'. +Value -> 'NULL' :element(1,'$1'). + +ValueNotNull -> BuiltinValue :'$1'. +% inlined Value -> DefinedValue :'$1'. % DefinedValue , identifier +% inlined Externalvaluereference -> Externalvaluereference :'$1'. +ValueNotNull -> typereference '.' identifier : + #'Externalvaluereference'{pos=element(2,'$1'),module=element(3,'$1'), + value=element(3,'$3')}. +ValueNotNull -> identifier :'$1'. + + +%tmp Value -> NamedNumber: '$1'. % not a value but part of ObjIdC +% redundant BuiltinValue -> BitStringValue :'$1'. +BuiltinValue -> BooleanValue :'$1'. +BuiltinValue -> CharacterStringValue :'$1'. +BuiltinValue -> ChoiceValue :'$1'. +% BuiltinValue -> EmbeddedPDVValue :'$1'. ==SequenceValue +% BuiltinValue -> EnumeratedValue :'$1'. identifier +% BuiltinValue -> ExternalValue :'$1'. ==SequenceValue +% later BuiltinValue -> InstanceOfValue :'$1'. +BuiltinValue -> SignedNumber :'$1'. +% BuiltinValue -> 'NULL' :'$1'. +% later BuiltinValue -> ObjectClassFieldValue :'$1'. +% replaced by SAndSOfValue BuiltinValue -> ObjectIdentifierValue :'$1'. +BuiltinValue -> bstring :element(3,'$1'). +BuiltinValue -> hstring :element(3,'$1'). +% conflict BuiltinValue -> RealValue :'$1'. +BuiltinValue -> SAndSOfValue :'$1'. +% replaced BuiltinValue -> SequenceOfValue :'$1'. +% replaced BuiltinValue -> SequenceValue :'$1'. +% replaced BuiltinValue -> SetValue :'$1'. +% replaced BuiltinValue -> SetOfValue :'$1'. +% conflict redundant BuiltinValue -> TaggedValue :'$1'. + +% inlined ReferencedValue -> DefinedValue:'$1'. +% ReferencedValue -> Externalvaluereference:'$1'. +% ReferencedValue -> identifier :'$1'. +% later ReferencedValue -> ValueFromObject:'$1'. + +% inlined BooleanType -> BOOLEAN :'BOOLEAN'. + +% to much conflicts AnyValue -> Type ':' Value : {'ANYVALUE',{'$1','$3'}}. + +BooleanValue -> TRUE :true. +BooleanValue -> FALSE :false. + +IntegerType -> 'INTEGER' : 'INTEGER'. +IntegerType -> 'INTEGER' '{' NamedNumberList '}' : {'INTEGER','$3'}. + +NamedNumberList -> NamedNumber :['$1']. +% modified NamedNumberList -> NamedNumberList ',' NamedNumber :'fix'. +NamedNumberList -> NamedNumber ',' NamedNumberList :['$1'|'$3']. + +NamedNumber -> identifier '(' SignedNumber ')' : {'NamedNumber',element(3,'$1'),'$3'}. +NamedNumber -> identifier '(' typereference '.' identifier ')' : {'NamedNumber',element(3,'$1'),{'ExternalValue',element(3,'$3'),element(3,'$5')}}. +NamedNumber -> identifier '(' identifier ')' : {'NamedNumber',element(3,'$1'),element(3,'$3')}. + +%NamedValue -> identifier Value : +% {'NamedValue',element(2,'$1'),element(3,'$1'),'$2'}. + + +SignedNumber -> number : element(3,'$1'). +SignedNumber -> '-' number : - element(3,'$1'). + +% inlined IntegerValue -> SignedNumber :'$1'. +% conflict moved to Value IntegerValue -> identifier:'$1'. + +EnumeratedType -> ENUMERATED '{' Enumeration '}' :{'ENUMERATED','$3'}. + +% inlined Enumerations -> Enumeration :{'$1','false',[]}. +% inlined Enumerations -> Enumeration ',' '...' : {'$1','true',[]}. +% inlined Enumerations -> Enumeration ',' '...' ',' Enumeration : {'$1','true','$5'}. + +Enumeration -> EnumerationItem :['$1']. +% modified Enumeration -> EnumerationItem ',' Enumeration :'fix'. +Enumeration -> EnumerationItem ',' Enumeration :['$1'|'$3']. + +EnumerationItem -> identifier:element(3,'$1'). +EnumerationItem -> NamedNumber :'$1'. +EnumerationItem -> '...' :'EXTENSIONMARK'. + +% conflict moved to Value EnumeratedValue -> identifier:'$1'. + +% inlined RealType -> REAL:'REAL'. + +RealValue -> NumericRealValue :'$1'. +RealValue -> SpecialRealValue:'$1'. + +% ?? NumericRealValue -> number:'$1'. % number MUST BE '0' +NumericRealValue -> SAndSOfValue : '$1'. % Value of the associated sequence type + +SpecialRealValue -> 'PLUS-INFINITY' :'$1'. +SpecialRealValue -> 'MINUS-INFINITY' :'$1'. + +BitStringType -> 'BIT' 'STRING' :{'BIT STRING',[]}. +BitStringType -> 'BIT' 'STRING' '{' NamedNumberList '}' :{'BIT STRING','$4'}. +% NamedBitList replaced by NamedNumberList to reduce the grammar +% Must check later that all "numbers" are positive + +% inlined BitStringValue -> bstring:'$1'. +% inlined BitStringValue -> hstring:'$1'. +% redundant use SequenceValue BitStringValue -> '{' IdentifierList '}' :$2. +% redundant use SequenceValue BitStringValue -> '{' '}' :'fix'. + +IdentifierList -> identifier :[element(3,'$1')]. +% modified IdentifierList -> IdentifierList ',' identifier :'$1'. +IdentifierList -> identifier ',' IdentifierList :[element(3,'$1')|'$3']. + +% inlined OctetStringType -> 'OCTET' 'STRING' :'OCTET STRING'. + +% inlined OctetStringValue -> bstring:'$1'. +% inlined OctetStringValue -> hstring:'$1'. + +% inlined NullType -> 'NULL':'NULL'. + +% inlined NullValue -> NULL:'NULL'. + +% result is {'SEQUENCE',Optionals,Extensionmark,Componenttypelist}. +SequenceType -> SEQUENCE '{' ComponentTypeList '}' :{'SEQUENCE','$3'}. +% SequenceType -> SEQUENCE '{' ComponentTypeLists '}' :{'SEQUENCE','$3'}. +% SequenceType -> SEQUENCE '{' ExtensionAndException '}' :{'SEQUENCE','$3'}. +SequenceType -> SEQUENCE '{' '}' :{'SEQUENCE',[]}. + +% result is {RootComponentList,ExtensionAndException,AdditionalComponentTypeList}. +%ComponentTypeLists -> ComponentTypeList ',' ExtensionAndException :{'$1','$3',[]}. +%ComponentTypeLists -> ComponentTypeList :{'$1','false',[]}. +%ComponentTypeLists -> ComponentTypeList ',' ExtensionAndException +% ',' ComponentTypeList :{'$1','$3', '$5'}. +%ComponentTypeLists -> ExtensionAndException ',' ComponentTypeList :{[],'$1','$3'}. + +ComponentTypeList -> ComponentType :['$1']. +% modified below ComponentTypeList -> ComponentTypeList ',' ComponentType :'$1'. +ComponentTypeList -> ComponentType ',' ComponentTypeList :['$1'|'$3']. + +% -record('ComponentType',{pos,name,type,attrib}). +ComponentType -> '...' ExceptionSpec :{'EXTENSIONMARK',element(2,'$1'),'$2'}. +ComponentType -> NamedType : + {'NamedType',Pos,{Name,Type}} = '$1', + #'ComponentType'{pos=Pos,name=Name,typespec=Type,prop=mandatory}. +ComponentType -> NamedType 'OPTIONAL' : + {'NamedType',Pos,{Name,Type}} = '$1', + #'ComponentType'{pos=Pos,name=Name,typespec=Type,prop='OPTIONAL'}. +ComponentType -> NamedType 'DEFAULT' Value: + {'NamedType',Pos,{Name,Type}} = '$1', + #'ComponentType'{pos=Pos,name=Name,typespec=Type,prop={'DEFAULT','$3'}}. +ComponentType -> 'COMPONENTS' 'OF' Type :{'COMPONENTS OF','$3'}. + +% redundant ExtensionAndException -> '...' : extensionmark. +% ExtensionAndException -> '...' ExceptionSpec : {extensionmark,'$2'}. + +% replaced SequenceValue -> '{' ComponentValueList '}':'$2'. +% replaced SequenceValue -> '{' '}':[]. + +ValueList -> Value :['$1']. +ValueList -> NamedNumber :['$1']. +% modified ValueList -> ValueList ',' Value :'$1'. +ValueList -> Value ',' ValueList :['$1'|'$3']. +ValueList -> Value ',' '...' :['$1' |[]]. +ValueList -> Value ValueList : ['$1',space|'$2']. +ValueList -> NamedNumber ValueList: ['$1',space|'$2']. + +%ComponentValueList -> identifier ObjIdComponent:[{'NamedValue','$1','$2'}]. +%ComponentValueList -> NamedValue :['$1']. +%ComponentValueList -> NamedValue ',' ComponentValueList:['$1'|'$3']. +%ComponentValueList -> identifier ObjIdComponent ',' ComponentValueList :[{'NamedValue', '$1','$2'}|'$4']. + +SequenceOfType -> SEQUENCE OF Type : {'SEQUENCE OF','$3'}. + +% replaced SequenceOfValue with SAndSOfValue + +SAndSOfValue -> '{' ValueList '}' :'$2'. +%SAndSOfValue -> '{' ComponentValueList '}' :'$2'. +SAndSOfValue -> '{' '}' :[]. + +% save for later SetType -> +% result is {'SET',Optionals,Extensionmark,Componenttypelist}. +SetType -> SET '{' ComponentTypeList '}' :{'SET','$3'}. +% SetType -> SET '{' ExtensionAndException '}' :{'SET','$3'}. +SetType -> SET '{' '}' :{'SET',[]}. + +% replaced SetValue with SAndSOfValue + +SetOfType -> SET OF Type : {'SET OF','$3'}. + +% replaced SetOfValue with SAndSOfValue + +ChoiceType -> 'CHOICE' '{' ComponentTypeList '}' :{'CHOICE','$3'}. +% AlternativeTypeList is replaced by ComponentTypeList +ChoiceValue -> identifier ':' Value : {'ChoiceValue',element(3,'$1'),'$3'}. +% save for later SelectionType -> + +TaggedType -> Tag Type : '$2'#type{tag=['$1'#tag{type={default,get(tagdefault)}}]}. +TaggedType -> Tag IMPLICIT Type :'$3'#type{tag=['$1'#tag{type='IMPLICIT'}]}. +TaggedType -> Tag EXPLICIT Type :'$3'#type{tag=['$1'#tag{type='EXPLICIT'}]}. + +Tag -> '[' Class ClassNumber ']': #tag{class='$2',number='$3'}. +Tag -> '[' Class typereference '.' identifier ']': + #tag{class='$2',number=#'Externalvaluereference'{pos=element(2,'$3'),module=element(3,'$3'), + value=element(3,'$5')}}. +Tag -> '[' Class number ']': #tag{class='$2',number=element(3,'$3')}. +Tag -> '[' Class identifier ']': #tag{class='$2',number=element(3,'$3')}. + +ClassNumber -> number :element(3,'$1'). +% inlined above ClassNumber -> typereference '.' identifier :{'Externalvaluereference',element(3,'$1'),element(3,'$3')}. +ClassNumber -> identifier :element(3,'$1'). + +Class -> 'UNIVERSAL' :element(1,'$1'). +Class -> 'APPLICATION' :element(1,'$1'). +Class -> 'PRIVATE' :element(1,'$1'). +Class -> '$empty' :'CONTEXT'. + +% conflict redundant TaggedValue -> Value:'$1'. + +% inlined EmbeddedPDVType -> 'EMBEDDED' 'PDV' :'EMBEDDED PDV'. + +% inlined EmbeddedPDVValue -> SequenceValue:'$1'. + +% inlined ExternalType -> 'EXTERNAL' :'EXTERNAL'. + +% inlined ExternalValue -> SequenceValue :'$1'. + +% inlined ObjectIdentifierType -> 'OBJECT' 'IDENTIFIER' :'OBJECT IDENTIFIER'. + +ObjectIdentifierValue -> '{' ObjIdComponentList '}' :'$2'. +% inlined ObjectIdentifierValue -> SequenceAndSequenceOfValue :'$1'. +% ObjectIdentifierValue -> '{' identifier ObjIdComponentList '}' :{'ObjectIdentifierValue','$2','$3'}. +% ObjectIdentifierValue -> '{' typereference '.' identifier ObjIdComponentList '}' :{'ObjectIdentifierValue',{'$2','$4'},'$5'}. + +ObjIdComponentList -> Value:'$1'. +ObjIdComponentList -> Value ObjIdComponentList :['$1'|'$2']. +%ObjIdComponentList -> DefinedValue:'$1'. +%ObjIdComponentList -> number:'$1'. +%ObjIdComponentList -> DefinedValue ObjIdComponentList :['$1'|'$2']. +%ObjIdComponentList -> number ObjIdComponentList :['$1'|'$2']. +%ObjIdComponentList -> ObjIdComponent ObjIdComponentList :['$1'|'$2']. +%ObjIdComponentList -> ObjIdComponent ObjIdComponentList :['$1'|'$2']. + +% redundant ObjIdComponent -> NameForm :'$1'. % expanded +% replaced by 2 ObjIdComponent -> NumberForm :'$1'. +% ObjIdComponent -> number :'$1'. +% ObjIdComponent -> DefinedValue :'$1'. % means DefinedValue +% ObjIdComponent -> NameAndNumberForm :'$1'. +% ObjIdComponent -> NamedNumber :'$1'. +% NamedBit replaced by NamedNumber to reduce grammar +% must check later that "number" is positive + +% NameForm -> identifier:'$1'. + +% inlined NumberForm -> number :'$1'. +% inlined NumberForm -> DefinedValue :'$1'. + +% replaced by NamedBit NameAndNumberForm -> identifier '(' NumberForm ')'. +% NameAndNumberForm -> NamedBit:'$1'. + + +CharacterStringType -> restrictedcharacterstringtype :element(3,'$1'). +CharacterStringType -> 'CHARACTER' 'STRING' :'CHARACTER STRING'. + +RestrictedCharacterStringValue -> cstring :element(3, '$1'). +% modified below RestrictedCharacterStringValue -> CharacterStringList :'$1'. +% conflict vs BuiltinValue RestrictedCharacterStringValue -> SequenceAndSequenceOfValue :'$1'. +RestrictedCharacterStringValue -> Quadruple :'$1'. +RestrictedCharacterStringValue -> Tuple :'$1'. + +% redundant CharacterStringList -> '{' ValueList '}' :'$2'. % modified + +% redundant CharSyms -> CharsDefn :'$1'. +% redundant CharSyms -> CharSyms ',' CharsDefn :['$1'|'$3']. + +% redundant CharsDefn -> cstring :'$1'. +% temporary replaced see below CharsDefn -> DefinedValue :'$1'. +% redundant CharsDefn -> Value :'$1'. + +Quadruple -> '{' number ',' number ',' number ',' number '}' :{'Quadruple','$2','$4','$6','$8'}. +% {Group,Plane,Row,Cell} + +Tuple -> '{' number ',' number '}' :{'Tuple', '$2','$4'}. +% {TableColumn,TableRow} + +% inlined UnrestrictedCharacterString -> 'CHARACTER' 'STRING' :'CHARACTER STRING'. + +CharacterStringValue -> RestrictedCharacterStringValue :'$1'. +% conflict vs BuiltinValue CharacterStringValue -> SequenceValue :'$1'. % UnrestrictedCharacterStringValue + +% inlined UsefulType -> typereference :'$1'. + +SelectionType -> identifier '<' Type : {'SelectionType',element(3,'$1'),'$3'}. + +ConstrainedType -> Type Constraint : + '$1'#type{constraint=merge_constraints(['$2'])}. +ConstrainedType -> Type Constraint Constraint : + '$1'#type{constraint=merge_constraints(['$2','$3'])}. +ConstrainedType -> Type Constraint Constraint Constraint: + '$1'#type{constraint=merge_constraints(['$2','$3','$4'])}. +ConstrainedType -> Type Constraint Constraint Constraint Constraint: + '$1'#type{constraint=merge_constraints(['$2','$3','$4','$5'])}. +%ConstrainedType -> Type Constraint :'$1'#type{constraint='$2'}. +%ConstrainedType -> Type Constraint :'$1'#type{constraint='$2'}. +ConstrainedType -> TypeWithConstraint :'$1'. + +TypeWithConstraint -> 'SET' Constraint 'OF' Type : + #type{def = {'SET OF','$4'},constraint=merge_constraints(['$2'])}. +TypeWithConstraint -> 'SET' 'SIZE' Constraint 'OF' Type : + #type{def = {'SET OF','$5'},constraint = merge_constraints([#constraint{c={'SizeConstraint','$3'#constraint.c}}])}. +TypeWithConstraint -> 'SEQUENCE' Constraint 'OF' Type : + #type{def = {'SEQUENCE OF','$4'},constraint = + merge_constraints(['$2'])}. +TypeWithConstraint -> 'SEQUENCE' 'SIZE' Constraint 'OF' Type : + #type{def = {'SEQUENCE OF','$5'},constraint = merge_constraints([#constraint{c={'SizeConstraint','$3'#constraint.c}}])}. + + +Constraint -> '(' ConstraintSpec ExceptionSpec ')' : + #constraint{c='$2',e='$3'}. + +% inlined Constraint -> SubTypeConstraint :'$1'. +ConstraintSpec -> ElementSetSpecs :'$1'. +ConstraintSpec -> UserDefinedConstraint :'$1'. +ConstraintSpec -> TableConstraint :'$1'. + +TableConstraint -> ComponentRelationConstraint : '$1'. +TableConstraint -> ObjectSet : '$1'. +%TableConstraint -> '{' typereference '}' :tableconstraint. + +ComponentRelationConstraint -> '{' typereference '}' '{' '@' ComponentIdList '}' : componentrelation. +ComponentRelationConstraint -> '{' typereference '}' '{' '@' '.' ComponentIdList '}' : componentrelation. + +ComponentIdList -> identifier: ['$1']. +ComponentIdList -> identifier '.' ComponentIdList: ['$1'| '$3']. + + +% later ConstraintSpec -> GeneralConstraint :'$1'. + +% from X.682 +UserDefinedConstraint -> 'CONSTRAINED' 'BY' '{' '}' : {constrained_by,[]}. +UserDefinedConstraint -> 'CONSTRAINED' 'BY' + '{' UserDefinedConstraintParameters '}' : {constrained_by,'$4'}. + +UserDefinedConstraintParameters -> UserDefinedConstraintParameter : ['$1']. +UserDefinedConstraintParameters -> + UserDefinedConstraintParameter ',' + UserDefinedConstraintParameters: ['$1'|'$3']. + +UserDefinedConstraintParameter -> Type '.' ActualParameter : {'$1','$3'}. +UserDefinedConstraintParameter -> ActualParameter : '$1'. + + + +ExceptionSpec -> '!' ExceptionIdentification : '$1'. +ExceptionSpec -> '$empty' : undefined. + +ExceptionIdentification -> SignedNumber : '$1'. +% inlined ExceptionIdentification -> DefinedValue : '$1'. +ExceptionIdentification -> typereference '.' identifier : + #'Externalvaluereference'{pos=element(2,'$1'),module=element(3,'$1'), + value=element(3,'$1')}. +ExceptionIdentification -> identifier :'$1'. +ExceptionIdentification -> Type ':' Value : {'$1','$3'}. + +% inlined SubTypeConstraint -> ElementSetSpec + +ElementSetSpecs -> ElementSetSpec : '$1'. +ElementSetSpecs -> ElementSetSpec ',' '...': {'$1',[]}. +ElementSetSpecs -> '...' ',' ElementSetSpec : {[],'$3'}. +ElementSetSpecs -> ElementSetSpec ',' '...' ',' ElementSetSpec : {'$1','$5'}. + +ElementSetSpec -> Unions : '$1'. +ElementSetSpec -> 'ALL' Exclusions : {'ALL','$2'}. + +Unions -> Intersections : '$1'. +Unions -> UElems UnionMark IntersectionElements : + case {'$1','$3'} of + {{'SingleValue',V1},{'SingleValue',V2}} -> + {'SingleValue',ordsets:union(to_set(V1),to_set(V2))} + end. + +UElems -> Unions :'$1'. + +Intersections -> IntersectionElements :'$1'. +Intersections -> IElems IntersectionMark IntersectionElements : + case {'$1','$3'} of + {{'SingleValue',V1},{'SingleValue',V2}} -> + {'SingleValue',ordsets:intersection(to_set(V1),to_set(V2))}; + {V1,V2} when list(V1) -> + V1 ++ [V2]; + {V1,V2} -> + [V1,V2] + end. +%Intersections -> IElems '^' IntersectionElements :{'INTERSECTION','$1','$3'}. +%Intersections -> IElems 'INTERSECTION' IntersectionElements :{'INTERSECTION','$1','$3'}. + +IElems -> Intersections :'$1'. + +IntersectionElements -> Elements :'$1'. +IntersectionElements -> Elems Exclusions :{'$1','$2'}. + +Elems -> Elements :'$1'. + +Exclusions -> 'EXCEPT' Elements :{'EXCEPT','$2'}. + +IntersectionMark -> 'INTERSECTION':'$1'. +IntersectionMark -> '^':'$1'. +UnionMark -> 'UNION':'$1'. +UnionMark -> '|':'$1'. + + +Elements -> SubTypeElements : '$1'. +%Elements -> ObjectSetElements : '$1'. +Elements -> '(' ElementSetSpec ')' : '$2'. +Elements -> ReferencedType : '$1'. + +SubTypeElements -> ValueList : {'SingleValue','$1'}. % NOTE it must be a Value +% The rule above modifyed only because of conflicts +SubTypeElements -> 'INCLUDES' Type : {'ContainedSubType','$2'}. +%not lalr1 if this is activated SubTypeElements -> Type : {'TypeConstraint','$1'}. +SubTypeElements -> LowerEndpoint '..' UpperEndpoint : {'ValueRange',{'$1','$3'}}. +SubTypeElements -> 'FROM' Constraint : {'PermittedAlphabet','$2'#constraint.c}. +SubTypeElements -> 'SIZE' Constraint: {'SizeConstraint','$2'#constraint.c}. +% later will introduce conflicts related to NULL SubTypeElements -> Type : {'TypeConstraint','$1'}. +SubTypeElements -> 'WITH' 'COMPONENT' Constraint:{'WITH COMPONENT','$3'}. +SubTypeElements -> 'WITH' 'COMPONENTS' '{' TypeConstraints '}':{'WITH COMPONENTS',{'FullSpecification','$4'}}. +SubTypeElements -> 'WITH' 'COMPONENTS' '{' '...' ',' TypeConstraints '}' :{'WITH COMPONENTS',{'PartialSpecification','$3'}}. + +% inlined above InnerTypeConstraints ::= +% inlined above SingleTypeConstraint::= Constraint +% inlined above MultipleTypeConstraints ::= FullSpecification | PartialSpecification +% inlined above FullSpecification ::= "{" TypeConstraints "}" +% inlined above PartialSpecification ::= "{" "..." "," TypeConstraints "}" +% TypeConstraints -> identifier : [{'NamedConstraint',element(3,'$1'),undefined,undefined}]. % is this really meaningful or allowed +TypeConstraints -> NamedConstraint : ['$1']. +TypeConstraints -> NamedConstraint ',' TypeConstraints : ['$1'|'$3']. +TypeConstraints -> identifier : ['$1']. +TypeConstraints -> identifier ',' TypeConstraints : ['$1'|'$3']. + +NamedConstraint -> identifier Constraint PresenceConstraint :{'NamedConstraint',element(3,'$1'),'$2','$3'}. +NamedConstraint -> identifier Constraint :{'NamedConstraint',element(3,'$1'),'$2',undefined}. +NamedConstraint -> identifier PresenceConstraint :{'NamedConstraint',element(3,'$1'),undefined,'$2'}. + +PresenceConstraint -> 'PRESENT' : 'PRESENT'. +PresenceConstraint -> 'ABSENT' : 'ABSENT'. +PresenceConstraint -> 'OPTIONAL' : 'OPTIONAL'. + + + +LowerEndpoint -> LowerEndValue :'$1'. +%LowerEndpoint -> LowerEndValue '<':{gt,'$1'}. +LowerEndpoint -> LowerEndValue '<':('$1'+1). + +UpperEndpoint -> UpperEndValue :'$1'. +%UpperEndpoint -> '<' UpperEndValue :{lt,'$2'}. +UpperEndpoint -> '<' UpperEndValue :('$2'-1). + +LowerEndValue -> Value :'$1'. +LowerEndValue -> 'MIN' :'MIN'. + +UpperEndValue -> Value :'$1'. +UpperEndValue -> 'MAX' :'MAX'. + + +% X.681 + + +% X.681 chap 15 + +%TypeFromObject -> ReferencedObjects '.' FieldName : {'$1','$3'}. +TypeFromObject -> typereference '.' FieldName : {'$1','$3'}. + +ReferencedObjects -> typereference : '$1'. +%ReferencedObjects -> ParameterizedObject +%ReferencedObjects -> DefinedObjectSet +%ReferencedObjects -> ParameterizedObjectSet + +FieldName -> typefieldreference : ['$1']. +FieldName -> valuefieldreference : ['$1']. +FieldName -> FieldName '.' FieldName : ['$1' | '$3']. + +PrimitiveFieldName -> typefieldreference : '$1'. +PrimitiveFieldName -> valuefieldreference : '$1'. + +%ObjectSetAssignment -> typereference DefinedObjectClass '::=' ObjectSet: null. +ObjectSetAssignment -> typereference typereference '::=' ObjectSet : + #typedef{pos=element(2,'$1'),name=element(3,'$1'),typespec={'ObjectSet',element(3,'$2'), '$4'}}. +ObjectSetAssignment -> typereference typereference '.' typereference '::=' ObjectSet. + +ObjectSet -> '{' ElementSetSpecs '}' : '$2'. +ObjectSet -> '{' '...' '}' : ['EXTENSIONMARK']. + +%ObjectSetElements -> Object. +% ObjectSetElements -> identifier : '$1'. +%ObjectSetElements -> DefinedObjectSet. +%ObjectSetElements -> ObjectSetFromObjects. +%ObjectSetElements -> ParameterizedObjectSet. + +%ObjectAssignment -> identifier DefinedObjectClass '::=' Object. +ObjectAssignment -> ValueAssignment. +%ObjectAssignment -> identifier typereference '::=' Object. +%ObjectAssignment -> identifier typereference '.' typereference '::=' Object. + +%Object -> DefinedObject: '$1'. +%Object -> ExternalObjectReference: '$1'.%Object -> DefinedObject: '$1'. +Object -> typereference '.' identifier: '$1'.%Object -> DefinedObject: '$1'. +Object -> identifier: '$1'.%Object -> DefinedObject: '$1'. + +%Object -> ObjectDefn -> DefaultSyntax: '$1'. +Object -> '{' FieldSetting ',' FieldSettings '}' : ['$2'|'$4']. +Object -> '{' FieldSetting '}' :['$2']. + +%% For User-friendly notation +%% Object -> ObjectDefn -> DefinedSyntax +Object -> '{' '}'. +Object -> '{' DefinedSyntaxTokens '}'. + +% later Object -> ParameterizedObject: '$1'. look in x.683 + +%DefinedObject -> ExternalObjectReference: '$1'. +%DefinedObject -> identifier: '$1'. + +DefinedObjectClass -> typereference. +%DefinedObjectClass -> objectclassreference. +DefinedObjectClass -> ExternalObjectClassReference. +%DefinedObjectClass -> typereference '.' objectclassreference. +%%DefinedObjectClass -> UsefulObjectClassReference. + +ExternalObjectReference -> typereference '.' identifier. +ExternalObjectClassReference -> typereference '.' typereference. +%%ExternalObjectClassReference -> typereference '.' objectclassreference. + +ObjectDefn -> DefaultSyntax: '$1'. +%ObjectDefn -> DefinedSyntax: '$1'. + +ObjectFromObject -> ReferencedObjects '.' FieldName : {'ObjectFromObject','$1','$3'}. + +% later look in x.683 ParameterizedObject -> + +%DefaultSyntax -> '{' '}'. +%DefaultSyntax -> '{' FieldSettings '}': '$2'. +DefaultSyntax -> '{' FieldSetting ',' FieldSettings '}': '$2'. +DefaultSyntax -> '{' FieldSetting '}': '$2'. + +FieldSetting -> PrimitiveFieldName Setting: {'$1','$2'}. + +FieldSettings -> FieldSetting ',' FieldSettings: ['$1'|'$3']. +FieldSettings -> FieldSetting ',' FieldSettings: ['$1'|'$3']. +FieldSettings -> FieldSetting: '$1'. + +%DefinedSyntax -> '{' '}'. +DefinedSyntax -> '{' DefinedSyntaxTokens '}': '$2'. + +DefinedSyntaxTokens -> DefinedSyntaxToken: '$1'. +DefinedSyntaxTokens -> DefinedSyntaxToken DefinedSyntaxTokens: ['$1'|'$2']. + +% expanded DefinedSyntaxToken -> Literal: '$1'. +%DefinedSyntaxToken -> typereference: '$1'. +DefinedSyntaxToken -> word: '$1'. +DefinedSyntaxToken -> ',': '$1'. +DefinedSyntaxToken -> Setting: '$1'. +%DefinedSyntaxToken -> '$empty': nil . + +% Setting ::= Type|Value|ValueSet|Object|ObjectSet +Setting -> Type: '$1'. +%Setting -> Value: '$1'. +%Setting -> ValueNotNull: '$1'. +Setting -> BuiltinValue: '$1'. +Setting -> ValueSet: '$1'. +%Setting -> Object: '$1'. +%Setting -> ExternalObjectReference. +Setting -> typereference '.' identifier. +Setting -> identifier. +Setting -> ObjectDefn. + +Setting -> ObjectSet: '$1'. + + +Erlang code. +%%-author('[email protected]'). +-copyright('Copyright (c) 1991-99 Ericsson Telecom AB'). +-vsn('$Revision: 1.1 $'). +-include("asn1_records.hrl"). + +to_set(V) when list(V) -> + ordsets:list_to_set(V); +to_set(V) -> + ordsets:list_to_set([V]). + +merge_constraints({Rlist,ExtList}) -> % extensionmarker in constraint + {merge_constraints(Rlist,[],[]), + merge_constraints(ExtList,[],[])}; + +merge_constraints(Clist) -> + merge_constraints(Clist, [], []). + +merge_constraints([Ch|Ct],Cacc, Eacc) -> + NewEacc = case Ch#constraint.e of + undefined -> Eacc; + E -> [E|Eacc] + end, + merge_constraints(Ct,[fixup_constraint(Ch#constraint.c)|Cacc],NewEacc); + +merge_constraints([],Cacc,[]) -> + lists:flatten(Cacc); +merge_constraints([],Cacc,Eacc) -> + lists:flatten(Cacc) ++ [{'Errors',Eacc}]. + +fixup_constraint(C) -> + case C of + {'SingleValue',V} when list(V) -> + [C, + {'ValueRange',{lists:min(V),lists:max(V)}}]; + {'PermittedAlphabet',{'SingleValue',V}} when list(V) -> + V2 = {'SingleValue', + ordsets:list_to_set(lists:flatten(V))}, + {'PermittedAlphabet',V2}; + {'PermittedAlphabet',{'SingleValue',V}} -> + V2 = {'SingleValue',[V]}, + {'PermittedAlphabet',V2}; + {'SizeConstraint',Sc} -> + {'SizeConstraint',fixup_size_constraint(Sc)}; + + List when list(List) -> + [fixup_constraint(Xc)||Xc <- List]; + Other -> + Other + end. + +fixup_size_constraint({'ValueRange',{Lb,Ub}}) -> + {Lb,Ub}; +fixup_size_constraint({{'ValueRange',R},[]}) -> + {R,[]}; +fixup_size_constraint({[],{'ValueRange',R}}) -> + {[],R}; +fixup_size_constraint({{'ValueRange',R1},{'ValueRange',R2}}) -> + {R1,R2}; +fixup_size_constraint({'SingleValue',[Sv]}) -> + fixup_size_constraint({'SingleValue',Sv}); +fixup_size_constraint({'SingleValue',L}) when list(L) -> + ordsets:list_to_set(L); +fixup_size_constraint({'SingleValue',L}) -> + {L,L}; +fixup_size_constraint({C1,C2}) -> + {fixup_size_constraint(C1), fixup_size_constraint(C2)}. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_parser2.erl b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_parser2.erl new file mode 100644 index 0000000000..07dacb73c8 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_parser2.erl @@ -0,0 +1,2763 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 2000, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: asn1ct_parser2.erl,v 1.1 2008/12/17 09:53:30 mikpe Exp $ +%% +-module(asn1ct_parser2). + +-export([parse/1]). +-include("asn1_records.hrl"). + +%% parse all types in module +parse(Tokens) -> + case catch parse_ModuleDefinition(Tokens) of + {'EXIT',Reason} -> + {error,{{undefined,get(asn1_module), + [internal,error,'when',parsing,module,definition,Reason]}, + hd(Tokens)}}; + {asn1_error,Reason} -> + {error,{Reason,hd(Tokens)}}; + {ModuleDefinition,Rest1} -> + {Types,Rest2} = parse_AssignmentList(Rest1), + case Rest2 of + [{'END',_}|_Rest3] -> + {ok,ModuleDefinition#module{typeorval = Types}}; + _ -> + {error,{{get_line(hd(Rest2)),get(asn1_module), + [got,get_token(hd(Rest2)),expected,'END']}, + hd(Rest2)}} + end + end. + +parse_ModuleDefinition([{typereference,L1,ModuleIdentifier}|Rest0]) -> + put(asn1_module,ModuleIdentifier), + {_DefinitiveIdentifier,Rest02} = + case Rest0 of + [{'{',_}|_Rest01] -> + parse_ObjectIdentifierValue(Rest0); + _ -> + {[],Rest0} + end, + Rest = case Rest02 of + [{'DEFINITIONS',_}|Rest03] -> + Rest03; + _ -> + throw({asn1_error,{get_line(hd(Rest02)),get(asn1_module), + [got,get_token(hd(Rest02)), + expected,'DEFINITIONS']}}) + end, + {TagDefault,Rest2} = + case Rest of + [{'EXPLICIT',_L3},{'TAGS',_L4}|Rest1] -> + put(tagdefault,'EXPLICIT'), {'EXPLICIT',Rest1}; + [{'IMPLICIT',_L3},{'TAGS',_L4}|Rest1] -> + put(tagdefault,'IMPLICIT'), {'IMPLICIT',Rest1}; + [{'AUTOMATIC',_L3},{'TAGS',_L4}|Rest1] -> + put(tagdefault,'AUTOMATIC'), {'AUTOMATIC',Rest1}; + Rest1 -> + put(tagdefault,'EXPLICIT'), {'EXPLICIT',Rest1} % The default + end, + {ExtensionDefault,Rest3} = + case Rest2 of + [{'EXTENSIBILITY',_L5}, {'IMPLIED',_L6}|Rest21] -> + {'IMPLIED',Rest21}; + _ -> {false,Rest2} + end, + case Rest3 of + [{'::=',_L7}, {'BEGIN',_L8}|Rest4] -> + {Exports, Rest5} = parse_Exports(Rest4), + {Imports, Rest6} = parse_Imports(Rest5), + {#module{ pos = L1, + name = ModuleIdentifier, + defid = [], % fix this + tagdefault = TagDefault, + extensiondefault = ExtensionDefault, + exports = Exports, + imports = Imports},Rest6}; + _ -> throw({asn1_error,{get_line(hd(Rest3)),get(asn1_module), + [got,get_token(hd(Rest3)),expected,"::= BEGIN"]}}) + end; +parse_ModuleDefinition(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected,typereference]}}). + +parse_Exports([{'EXPORTS',_L1},{';',_L2}|Rest]) -> + {{exports,[]},Rest}; +parse_Exports([{'EXPORTS',_L1}|Rest]) -> + {SymbolList,Rest2} = parse_SymbolList(Rest), + case Rest2 of + [{';',_}|Rest3] -> + {{exports,SymbolList},Rest3}; + _ -> + throw({asn1_error,{get_line(hd(Rest2)),get(asn1_module), + [got,get_token(hd(Rest2)),expected,';']}}) + end; +parse_Exports(Rest) -> + {{exports,all},Rest}. + +parse_SymbolList(Tokens) -> + parse_SymbolList(Tokens,[]). + +parse_SymbolList(Tokens,Acc) -> + {Symbol,Rest} = parse_Symbol(Tokens), + case Rest of + [{',',_L1}|Rest2] -> + parse_SymbolList(Rest2,[Symbol|Acc]); + Rest2 -> + {lists:reverse([Symbol|Acc]),Rest2} + end. + +parse_Symbol(Tokens) -> + parse_Reference(Tokens). + +parse_Reference([{typereference,L1,TrefName},{'{',_L2},{'}',_L3}|Rest]) -> +% {Tref,Rest}; + {tref2Exttref(L1,TrefName),Rest}; +parse_Reference([Tref1 = {typereference,_,_},{'.',_},Tref2 = {typereference,_,_}, + {'{',_L2},{'}',_L3}|Rest]) -> +% {{Tref1,Tref2},Rest}; + {{tref2Exttref(Tref1),tref2Exttref(Tref2)},Rest}; +parse_Reference([Tref = {typereference,_L1,_TrefName}|Rest]) -> + {tref2Exttref(Tref),Rest}; +parse_Reference([Vref = {identifier,_L1,_VName}|Rest]) -> + {identifier2Extvalueref(Vref),Rest}; +parse_Reference(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected, + [typereference,identifier]]}}). + +parse_Imports([{'IMPORTS',_L1},{';',_L2}|Rest]) -> + {{imports,[]},Rest}; +parse_Imports([{'IMPORTS',_L1}|Rest]) -> + {SymbolsFromModuleList,Rest2} = parse_SymbolsFromModuleList(Rest), + case Rest2 of + [{';',_L2}|Rest3] -> + {{imports,SymbolsFromModuleList},Rest3}; + Rest3 -> + throw({asn1_error,{get_line(hd(Rest3)),get(asn1_module), + [got,get_token(hd(Rest3)),expected,';']}}) + end; +parse_Imports(Tokens) -> + {{imports,[]},Tokens}. + +parse_SymbolsFromModuleList(Tokens) -> + parse_SymbolsFromModuleList(Tokens,[]). + +parse_SymbolsFromModuleList(Tokens,Acc) -> + {SymbolsFromModule,Rest} = parse_SymbolsFromModule(Tokens), + case (catch parse_SymbolsFromModule(Rest)) of + {Sl,_Rest2} when record(Sl,'SymbolsFromModule') -> + parse_SymbolsFromModuleList(Rest,[SymbolsFromModule|Acc]); + _ -> + {lists:reverse([SymbolsFromModule|Acc]),Rest} + end. + +parse_SymbolsFromModule(Tokens) -> + SetRefModuleName = + fun(N) -> + fun(X) when record(X,'Externaltypereference')-> + X#'Externaltypereference'{module=N}; + (X) when record(X,'Externalvaluereference')-> + X#'Externalvaluereference'{module=N} + end + end, + {SymbolList,Rest} = parse_SymbolList(Tokens), + case Rest of + %%How does this case correspond to x.680 ? + [{'FROM',_L1},Tref = {typereference,_,_},Ref={identifier,_L2,_Id},C={',',_}|Rest2] -> + {#'SymbolsFromModule'{symbols=SymbolList, + module=tref2Exttref(Tref)},[Ref,C|Rest2]}; + %%How does this case correspond to x.680 ? + [{'FROM',_L1},Tref = {typereference,_,_},{identifier,_L2,_Id}|Rest2] -> + {#'SymbolsFromModule'{symbols=SymbolList, + module=tref2Exttref(Tref)},Rest2}; + [{'FROM',_L1},Tref = {typereference,_,Name},Brace = {'{',_}|Rest2] -> + {_ObjIdVal,Rest3} = parse_ObjectIdentifierValue([Brace|Rest2]), % value not used yet, fix me + NewSymbolList = lists:map(SetRefModuleName(Name),SymbolList), + {#'SymbolsFromModule'{symbols=NewSymbolList, + module=tref2Exttref(Tref)},Rest3}; + [{'FROM',_L1},Tref = {typereference,_,Name}|Rest2] -> + NewSymbolList = lists:map(SetRefModuleName(Name),SymbolList), + {#'SymbolsFromModule'{symbols=NewSymbolList, + module=tref2Exttref(Tref)},Rest2}; + _ -> + throw({asn1_error,{get_line(hd(Rest)),get(asn1_module), + [got,get_token(hd(Rest)),expected, + ['FROM typerefernece identifier ,', + 'FROM typereference identifier', + 'FROM typereference {', + 'FROM typereference']]}}) + end. + +parse_ObjectIdentifierValue([{'{',_}|Rest]) -> + parse_ObjectIdentifierValue(Rest,[]). + +parse_ObjectIdentifierValue([{number,_,Num}|Rest],Acc) -> + parse_ObjectIdentifierValue(Rest,[Num|Acc]); +parse_ObjectIdentifierValue([{identifier,_,Id},{'(',_}, {number,_,Num}, {')',_}|Rest],Acc) -> + parse_ObjectIdentifierValue(Rest,[{'NamedNumber',Id,Num}|Acc]); +parse_ObjectIdentifierValue([{identifier,_,Id},{'(',_}, {identifier,_,Id2}, {')',_}|Rest],Acc) -> + parse_ObjectIdentifierValue(Rest,[{'NamedNumber',Id,Id2}|Acc]); +parse_ObjectIdentifierValue([{identifier,_,Id},{'(',_}, {typereference,_,Tref},{'.',_},{identifier,_,Id2}, {')',_}|Rest],Acc) -> + parse_ObjectIdentifierValue(Rest,[{'NamedNumber',Id,{'ExternalValue',Tref,Id2}}|Acc]); +parse_ObjectIdentifierValue([Id = {identifier,_,_}|Rest],Acc) -> + parse_ObjectIdentifierValue(Rest,[identifier2Extvalueref(Id)|Acc]); +parse_ObjectIdentifierValue([{'}',_}|Rest],Acc) -> + {lists:reverse(Acc),Rest}; +parse_ObjectIdentifierValue([H|_T],_Acc) -> + throw({asn1_error,{get_line(H),get(asn1_module), + [got,get_token(H),expected, + ['{ some of the following }',number,'identifier ( number )', + 'identifier ( identifier )', + 'identifier ( typereference.identifier)',identifier]]}}). + +parse_AssignmentList(Tokens = [{'END',_}|_Rest]) -> + {[],Tokens}; +parse_AssignmentList(Tokens = [{'$end',_}|_Rest]) -> + {[],Tokens}; +parse_AssignmentList(Tokens) -> + parse_AssignmentList(Tokens,[]). + +parse_AssignmentList(Tokens= [{'END',_}|_Rest],Acc) -> + {lists:reverse(Acc),Tokens}; +parse_AssignmentList(Tokens= [{'$end',_}|_Rest],Acc) -> + {lists:reverse(Acc),Tokens}; +parse_AssignmentList(Tokens,Acc) -> + case (catch parse_Assignment(Tokens)) of + {'EXIT',Reason} -> + exit(Reason); + {asn1_error,R} -> +% [H|T] = Tokens, + throw({error,{R,hd(Tokens)}}); + {Assignment,Rest} -> + parse_AssignmentList(Rest,[Assignment|Acc]) + end. + +parse_Assignment(Tokens) -> + Flist = [fun parse_TypeAssignment/1, + fun parse_ValueAssignment/1, + fun parse_ObjectClassAssignment/1, + fun parse_ObjectAssignment/1, + fun parse_ObjectSetAssignment/1, + fun parse_ParameterizedAssignment/1, + fun parse_ValueSetTypeAssignment/1], + case (catch parse_or(Tokens,Flist)) of + {'EXIT',Reason} -> + exit(Reason); + AsnErr = {asn1_error,_} -> + throw(AsnErr); + {asn1_assignment_error,Reason} -> + throw({asn1_error,Reason}); + Result -> + Result + end. + + +parse_or(Tokens,Flist) -> + parse_or(Tokens,Flist,[]). + +parse_or(_Tokens,[],ErrList) -> + case ErrList of + [] -> + throw({asn1_error,{parse_or,ErrList}}); + L when list(L) -> +%%% throw({asn1_error,{parse_or,hd(lists:reverse(ErrList))}}); + %% chose to throw 1) the error with the highest line no, + %% 2) the last error which is not a asn1_assignment_error or + %% 3) the last error. + throw(prioritize_error(ErrList)); + Other -> + throw({asn1_error,{parse_or,Other}}) + end; +parse_or(Tokens,[Fun|Frest],ErrList) -> + case (catch Fun(Tokens)) of + Exit = {'EXIT',_Reason} -> + parse_or(Tokens,Frest,[Exit|ErrList]); + AsnErr = {asn1_error,_} -> + parse_or(Tokens,Frest,[AsnErr|ErrList]); + AsnAssErr = {asn1_assignment_error,_} -> + parse_or(Tokens,Frest,[AsnAssErr|ErrList]); + Result = {_,L} when list(L) -> + Result; +% Result -> +% Result + Error -> + parse_or(Tokens,Frest,[Error|ErrList]) + end. + +parse_TypeAssignment([{typereference,L1,Tref},{'::=',_}|Rest]) -> + {Type,Rest2} = parse_Type(Rest), + {#typedef{pos=L1,name=Tref,typespec=Type},Rest2}; +parse_TypeAssignment([H1,H2|_Rest]) -> + throw({asn1_assignment_error,{get_line(H1),get(asn1_module), + [got,[get_token(H1),get_token(H2)], expected, + typereference,'::=']}}); +parse_TypeAssignment([H|_T]) -> + throw({asn1_assignment_error,{get_line(H),get(asn1_module), + [got,get_token(H),expected, + typereference]}}). + +parse_Type(Tokens) -> + {Tag,Rest3} = case Tokens of + [Lbr= {'[',_}|Rest] -> + parse_Tag([Lbr|Rest]); + Rest-> {[],Rest} + end, + {Tag2,Rest4} = case Rest3 of + [{'IMPLICIT',_}|Rest31] when record(Tag,tag)-> + {[Tag#tag{type='IMPLICIT'}],Rest31}; + [{'EXPLICIT',_}|Rest31] when record(Tag,tag)-> + {[Tag#tag{type='EXPLICIT'}],Rest31}; + Rest31 when record(Tag,tag) -> + {[Tag#tag{type={default,get(tagdefault)}}],Rest31}; + Rest31 -> + {Tag,Rest31} + end, + Flist = [fun parse_BuiltinType/1,fun parse_ReferencedType/1,fun parse_TypeWithConstraint/1], + {Type,Rest5} = case (catch parse_or(Rest4,Flist)) of + {'EXIT',Reason} -> + exit(Reason); + AsnErr = {asn1_error,_Reason} -> + throw(AsnErr); + Result -> + Result + end, + case hd(Rest5) of + {'(',_} -> + {Constraints,Rest6} = parse_Constraints(Rest5), + if record(Type,type) -> + {Type#type{constraint=merge_constraints(Constraints), + tag=Tag2},Rest6}; + true -> + {#type{def=Type,constraint=merge_constraints(Constraints), + tag=Tag2},Rest6} + end; + _ -> + if record(Type,type) -> + {Type#type{tag=Tag2},Rest5}; + true -> + {#type{def=Type,tag=Tag2},Rest5} + end + end. + +parse_BuiltinType([{'BIT',_},{'STRING',_}|Rest]) -> + case Rest of + [{'{',_}|Rest2] -> + {NamedNumberList,Rest3} = parse_NamedNumberList(Rest2), + case Rest3 of + [{'}',_}|Rest4] -> + {#type{def={'BIT STRING',NamedNumberList}},Rest4}; + _ -> + throw({asn1_error,{get_line(hd(Rest3)),get(asn1_module), + [got,get_token(hd(Rest3)),expected,'}']}}) + end; + _ -> + {{'BIT STRING',[]},Rest} + end; +parse_BuiltinType([{'BOOLEAN',_}|Rest]) -> + {#type{def='BOOLEAN'},Rest}; +%% CharacterStringType ::= RestrictedCharacterStringType | +%% UnrestrictedCharacterStringType +parse_BuiltinType([{restrictedcharacterstringtype,_,StringName}|Rest]) -> + {#type{def=StringName},Rest}; +parse_BuiltinType([{'CHARACTER',_},{'STRING',_}|Rest]) -> + {#type{def='CHARACTER STRING'},Rest}; + +parse_BuiltinType([{'CHOICE',_},{'{',_}|Rest]) -> + {AlternativeTypeLists,Rest2} = parse_AlternativeTypeLists(Rest), + case Rest2 of + [{'}',_}|Rest3] -> + {#type{def={'CHOICE',AlternativeTypeLists}},Rest3}; + _ -> + throw({asn1_error,{get_line(hd(Rest2)),get(asn1_module), + [got,get_token(hd(Rest2)),expected,'}']}}) + end; +parse_BuiltinType([{'EMBEDDED',_},{'PDV',_}|Rest]) -> + {#type{def='EMBEDDED PDV'},Rest}; +parse_BuiltinType([{'ENUMERATED',_},{'{',_}|Rest]) -> + {Enumerations,Rest2} = parse_Enumerations(Rest), + case Rest2 of + [{'}',_}|Rest3] -> + {#type{def={'ENUMERATED',Enumerations}},Rest3}; + _ -> + throw({asn1_error,{get_line(hd(Rest2)),get(asn1_module), + [got,get_token(hd(Rest2)),expected,'}']}}) + end; +parse_BuiltinType([{'EXTERNAL',_}|Rest]) -> + {#type{def='EXTERNAL'},Rest}; + +% InstanceOfType +parse_BuiltinType([{'INSTANCE',_},{'OF',_}|Rest]) -> + {DefinedObjectClass,Rest2} = parse_DefinedObjectClass(Rest), + case Rest2 of + [{'(',_}|_] -> + {Constraint,Rest3} = parse_Constraint(Rest2), + {#type{def={'INSTANCE OF',DefinedObjectClass,Constraint}},Rest3}; + _ -> + {#type{def={'INSTANCE OF',DefinedObjectClass,[]}},Rest2} + end; + +% parse_BuiltinType(Tokens) -> + +parse_BuiltinType([{'INTEGER',_}|Rest]) -> + case Rest of + [{'{',_}|Rest2] -> + {NamedNumberList,Rest3} = parse_NamedNumberList(Rest2), + case Rest3 of + [{'}',_}|Rest4] -> + {#type{def={'INTEGER',NamedNumberList}},Rest4}; + _ -> + throw({asn1_error,{get_line(hd(Rest3)),get(asn1_module), + [got,get_token(hd(Rest3)),expected,'}']}}) + end; + _ -> + {#type{def='INTEGER'},Rest} + end; +parse_BuiltinType([{'NULL',_}|Rest]) -> + {#type{def='NULL'},Rest}; + +% ObjectClassFieldType fix me later + +parse_BuiltinType([{'OBJECT',_},{'IDENTIFIER',_}|Rest]) -> + {#type{def='OBJECT IDENTIFIER'},Rest}; +parse_BuiltinType([{'OCTET',_},{'STRING',_}|Rest]) -> + {#type{def='OCTET STRING'},Rest}; +parse_BuiltinType([{'REAL',_}|Rest]) -> + {#type{def='REAL'},Rest}; +parse_BuiltinType([{'SEQUENCE',_},{'{',_},{'...',Line},{'}',_}|Rest]) -> + {#type{def=#'SEQUENCE'{components=[{'EXTENSIONMARK',Line,undefined}]}}, + Rest}; +parse_BuiltinType([{'SEQUENCE',_},{'{',_},{'...',Line},{'!',_}|Rest]) -> + {ExceptionIdentification,Rest2} = parse_ExceptionIdentification(Rest), + case Rest2 of + [{'}',_}|Rest3] -> + {#type{def=#'SEQUENCE'{components=[{'EXTENSIONMARK', + Line, + ExceptionIdentification}]}}, + Rest3}; + _ -> + throw({asn1_error,{get_line(hd(Rest2)),get(asn1_module), + [got,get_token(hd(Rest2)),expected,'}']}}) + end; +parse_BuiltinType([{'SEQUENCE',_},{'{',_}|Rest]) -> + {ComponentTypeLists,Rest2} = parse_ComponentTypeLists(Rest), + case Rest2 of + [{'}',_}|Rest3] -> + {#type{def=#'SEQUENCE'{components=ComponentTypeLists}},Rest3}; + _ -> + throw({asn1_error,{get_line(hd(Rest2)),get(asn1_module), + [got,get_token(hd(Rest2)),expected,'}']}}) + end; +parse_BuiltinType([{'SEQUENCE',_},{'OF',_}|Rest]) -> + {Type,Rest2} = parse_Type(Rest), + {#type{def={'SEQUENCE OF',Type}},Rest2}; + + +parse_BuiltinType([{'SET',_},{'{',_},{'...',Line},{'}',_}|Rest]) -> + {#type{def=#'SET'{components=[{'EXTENSIONMARK',Line,undefined}]}},Rest}; +parse_BuiltinType([{'SET',_},{'{',_},{'...',Line},{'!',_}|Rest]) -> + {ExceptionIdentification,Rest2} = parse_ExceptionIdentification(Rest), + case Rest2 of + [{'}',_}|Rest3] -> + {#type{def=#'SET'{components= + [{'EXTENSIONMARK',Line,ExceptionIdentification}]}}, + Rest3}; + _ -> + throw({asn1_error,{get_line(hd(Rest2)),get(asn1_module), + [got,get_token(hd(Rest2)),expected,'}']}}) + end; +parse_BuiltinType([{'SET',_},{'{',_}|Rest]) -> + {ComponentTypeLists,Rest2} = parse_ComponentTypeLists(Rest), + case Rest2 of + [{'}',_}|Rest3] -> + {#type{def=#'SET'{components=ComponentTypeLists}},Rest3}; + _ -> + throw({asn1_error,{get_line(hd(Rest2)),get(asn1_module), + [got,get_token(hd(Rest2)),expected,'}']}}) + end; +parse_BuiltinType([{'SET',_},{'OF',_}|Rest]) -> + {Type,Rest2} = parse_Type(Rest), + {#type{def={'SET OF',Type}},Rest2}; + +%% The so called Useful types +parse_BuiltinType([{'GeneralizedTime',_}|Rest]) -> + {#type{def='GeneralizedTime'},Rest}; +parse_BuiltinType([{'UTCTime',_}|Rest]) -> + {#type{def='UTCTime'},Rest}; +parse_BuiltinType([{'ObjectDescriptor',_}|Rest]) -> + {#type{def='ObjectDescriptor'},Rest}; + +%% For compatibility with old standard +parse_BuiltinType([{'ANY',_},{'DEFINED',_},{'BY',_},{identifier,_,Id}|Rest]) -> + {#type{def={'ANY_DEFINED_BY',Id}},Rest}; +parse_BuiltinType([{'ANY',_}|Rest]) -> + {#type{def='ANY'},Rest}; + +parse_BuiltinType(Tokens) -> + parse_ObjectClassFieldType(Tokens). +% throw({asn1_error,unhandled_type}). + + +parse_TypeWithConstraint([{'SEQUENCE',_},Lpar = {'(',_}|Rest]) -> + {Constraint,Rest2} = parse_Constraint([Lpar|Rest]), + case Rest2 of + [{'OF',_}|Rest3] -> + {Type,Rest4} = parse_Type(Rest3), + {#type{def = {'SEQUENCE OF',Type}, constraint = merge_constraints([Constraint])},Rest4}; + _ -> + throw({asn1_error,{get_line(hd(Rest2)),get(asn1_module), + [got,get_token(hd(Rest2)),expected,'OF']}}) + end; +parse_TypeWithConstraint([{'SEQUENCE',_},{'SIZE',_},Lpar = {'(',_}|Rest]) -> + {Constraint,Rest2} = parse_Constraint([Lpar|Rest]), + Constraint2 = + case Constraint of + #constraint{c=C} -> + Constraint#constraint{c={'SizeConstraint',C}}; + _ -> Constraint + end, + case Rest2 of + [{'OF',_}|Rest3] -> + {Type,Rest4} = parse_Type(Rest3), + {#type{def = {'SEQUENCE OF',Type}, constraint = merge_constraints([Constraint2])},Rest4}; + _ -> + throw({asn1_error,{get_line(hd(Rest2)),get(asn1_module), + [got,get_token(hd(Rest2)),expected,'OF']}}) + end; +parse_TypeWithConstraint([{'SET',_},Lpar = {'(',_}|Rest]) -> + {Constraint,Rest2} = parse_Constraint([Lpar|Rest]), + case Rest2 of + [{'OF',_}|Rest3] -> + {Type,Rest4} = parse_Type(Rest3), + {#type{def = {'SET OF',Type}, constraint = merge_constraints([Constraint])},Rest4}; + _ -> + throw({asn1_error,{get_line(hd(Rest2)),get(asn1_module), + [got,get_token(hd(Rest2)),expected,'OF']}}) + end; +parse_TypeWithConstraint([{'SET',_},{'SIZE',_},Lpar = {'(',_}|Rest]) -> + {Constraint,Rest2} = parse_Constraint([Lpar|Rest]), + Constraint2 = + case Constraint of + #constraint{c=C} -> + Constraint#constraint{c={'SizeConstraint',C}}; + _ -> Constraint + end, + case Rest2 of + [{'OF',_}|Rest3] -> + {Type,Rest4} = parse_Type(Rest3), + {#type{def = {'SET OF',Type}, constraint = merge_constraints([Constraint2])},Rest4}; + _ -> + throw({asn1_error,{get_line(hd(Rest2)),get(asn1_module), + [got,get_token(hd(Rest2)),expected,'OF']}}) + end; +parse_TypeWithConstraint(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected, + ['SEQUENCE','SEQUENCE SIZE','SET','SET SIZE'], + followed,by,a,constraint]}}). + + +%% -------------------------- + +parse_ReferencedType(Tokens) -> + Flist = [fun parse_DefinedType/1, + fun parse_SelectionType/1, + fun parse_TypeFromObject/1, + fun parse_ValueSetFromObjects/1], + case (catch parse_or(Tokens,Flist)) of + {'EXIT',Reason} -> + exit(Reason); + AsnErr = {asn1_error,_} -> + throw(AsnErr); + Result -> + Result + end. + +parse_DefinedType(Tokens=[{typereference,_,_},{'{',_}|_Rest]) -> + parse_ParameterizedType(Tokens); +parse_DefinedType(Tokens=[{typereference,L1,TypeName}, + T2={typereference,_,_},T3={'{',_}|Rest]) -> + case (catch parse_ParameterizedType(Tokens)) of + {'EXIT',_Reason} -> + Rest2 = [T2,T3|Rest], + {#type{def = #'Externaltypereference'{pos=L1, + module=get(asn1_module), + type=TypeName}},Rest2}; + {asn1_error,_} -> + Rest2 = [T2,T3|Rest], + {#type{def = #'Externaltypereference'{pos=L1, + module=get(asn1_module), + type=TypeName}},Rest2}; + Result -> + Result + end; +parse_DefinedType([{typereference,L1,Module},{'.',_},{typereference,_,TypeName}|Rest]) -> + {#type{def = #'Externaltypereference'{pos=L1,module=Module,type=TypeName}},Rest}; +parse_DefinedType([{typereference,L1,TypeName}|Rest]) -> + {#type{def = #'Externaltypereference'{pos=L1,module=get(asn1_module), + type=TypeName}},Rest}; +parse_DefinedType(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected, + [typereference,'typereference.typereference', + 'typereference typereference']]}}). + +parse_SelectionType([{identifier,_,Name},{'<',_}|Rest]) -> + {Type,Rest2} = parse_Type(Rest), + {{'SelectionType',Name,Type},Rest2}; +parse_SelectionType(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected,'identifier <']}}). + + +%% -------------------------- + + +%% This should probably be removed very soon +% parse_ConstrainedType(Tokens) -> +% case (catch parse_TypeWithConstraint(Tokens)) of +% {'EXIT',Reason} -> +% {Type,Rest} = parse_Type(Tokens), +% {Constraint,Rest2} = parse_Constraint(Rest), +% {Type#type{constraint=Constraint},Rest2}; +% {asn1_error,Reason2} -> +% {Type,Rest} = parse_Type(Tokens), +% {Constraint,Rest2} = parse_Constraint(Rest), +% {Type#type{constraint=Constraint},Rest2}; +% Result -> +% Result +% end. + +parse_Constraints(Tokens) -> + parse_Constraints(Tokens,[]). + +parse_Constraints(Tokens,Acc) -> + {Constraint,Rest} = parse_Constraint(Tokens), + case Rest of + [{'(',_}|_Rest2] -> + parse_Constraints(Rest,[Constraint|Acc]); + _ -> + {lists:reverse([Constraint|Acc]),Rest} + end. + +parse_Constraint([{'(',_}|Rest]) -> + {Constraint,Rest2} = parse_ConstraintSpec(Rest), + {Exception,Rest3} = parse_ExceptionSpec(Rest2), + case Rest3 of + [{')',_}|Rest4] -> + {#constraint{c=Constraint,e=Exception},Rest4}; + [H|_T] -> + throw({asn1_error,{get_line(H),get(asn1_module), + [got,get_token(H),expected,')']}}) + end; +parse_Constraint(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected,'(']}}). + +parse_ConstraintSpec(Tokens) -> + Flist = [fun parse_GeneralConstraint/1, + fun parse_SubtypeConstraint/1], + case (catch parse_or(Tokens,Flist)) of + {'EXIT',Reason} -> + exit(Reason); + {asn1_error,Reason2} -> + throw({asn1_error,Reason2}); + Result -> + Result + end. + +parse_ExceptionSpec([LPar={')',_}|Rest]) -> + {undefined,[LPar|Rest]}; +parse_ExceptionSpec([{'!',_}|Rest]) -> + parse_ExceptionIdentification(Rest); +parse_ExceptionSpec(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected,[')','!']]}}). + +parse_ExceptionIdentification(Tokens) -> + Flist = [fun parse_SignedNumber/1, + fun parse_DefinedValue/1, + fun parse_TypeColonValue/1], + case (catch parse_or(Tokens,Flist)) of + {'EXIT',Reason} -> + exit(Reason); + {asn1_error,Reason2} -> + throw({asn1_error,Reason2}); + Result -> + Result + end. + +parse_TypeColonValue(Tokens) -> + {Type,Rest} = parse_Type(Tokens), + case Rest of + [{':',_}|Rest2] -> + {Value,Rest3} = parse_Value(Rest2), + {{Type,Value},Rest3}; + [H|_T] -> + throw({asn1_error,{get_line(H),get(asn1_module), + [got,get_token(H),expected,':']}}) + end. + +parse_SubtypeConstraint(Tokens) -> + parse_ElementSetSpecs(Tokens). + +parse_ElementSetSpecs([{'...',_}|Rest]) -> + {Elements,Rest2} = parse_ElementSetSpec(Rest), + {{[],Elements},Rest2}; +parse_ElementSetSpecs(Tokens) -> + {RootElems,Rest} = parse_ElementSetSpec(Tokens), + case Rest of + [{',',_},{'...',_},{',',_}|Rest2] -> + {AdditionalElems,Rest3} = parse_ElementSetSpec(Rest2), + {{RootElems,AdditionalElems},Rest3}; + [{',',_},{'...',_}|Rest2] -> + {{RootElems,[]},Rest2}; + _ -> + {RootElems,Rest} + end. + +parse_ElementSetSpec([{'ALL',_},{'EXCEPT',_}|Rest]) -> + {Exclusions,Rest2} = parse_Elements(Rest), + {{'ALL',{'EXCEPT',Exclusions}},Rest2}; +parse_ElementSetSpec(Tokens) -> + parse_Unions(Tokens). + + +parse_Unions(Tokens) -> + {InterSec,Rest} = parse_Intersections(Tokens), + {Unions,Rest2} = parse_UnionsRec(Rest), + case {InterSec,Unions} of + {InterSec,[]} -> + {InterSec,Rest2}; + {{'SingleValue',V1},{'SingleValue',V2}} -> + {{'SingleValue',ordsets:union(to_set(V1),to_set(V2))},Rest2}; + {V1,V2} when list(V2) -> + {[V1] ++ [union|V2],Rest2}; + {V1,V2} -> + {[V1,union,V2],Rest2} +% Other -> +% throw(Other) + end. + +parse_UnionsRec([{'|',_}|Rest]) -> + {InterSec,Rest2} = parse_Intersections(Rest), + {URec,Rest3} = parse_UnionsRec(Rest2), + case {InterSec,URec} of + {V1,[]} -> + {V1,Rest3}; + {{'SingleValue',V1},{'SingleValue',V2}} -> + {{'SingleValue',ordsets:union(to_set(V1),to_set(V2))},Rest3}; + {V1,V2} when list(V2) -> + {[V1] ++ V2,Rest3}; + {V1,V2} -> + {[V1,V2],Rest3} + end; +parse_UnionsRec([{'UNION',_}|Rest]) -> + {InterSec,Rest2} = parse_Intersections(Rest), + {URec,Rest3} = parse_UnionsRec(Rest2), + case {InterSec,URec} of + {V1,[]} -> + {V1,Rest3}; + {{'SingleValue',V1},{'SingleValue',V2}} -> + {{'SingleValue',ordsets:union(to_set(V1),to_set(V2))},Rest3}; + {V1,V2} when list(V2) -> + {[V1] ++ V2,Rest3}; + {V1,V2} -> + {[V1,V2],Rest3} + end; +parse_UnionsRec(Tokens) -> + {[],Tokens}. + +parse_Intersections(Tokens) -> + {InterSec,Rest} = parse_IntersectionElements(Tokens), + {IRec,Rest2} = parse_IElemsRec(Rest), + case {InterSec,IRec} of + {V1,[]} -> + {V1,Rest2}; + {{'SingleValue',V1},{'SingleValue',V2}} -> + {{'SingleValue', + ordsets:intersection(to_set(V1),to_set(V2))},Rest2}; + {V1,V2} when list(V2) -> + {[V1] ++ [intersection|V2],Rest2}; + {V1,V2} -> + {[V1,intersection,V2],Rest2}; + _ -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected,'a Union']}}) + end. + +parse_IElemsRec([{'^',_}|Rest]) -> + {InterSec,Rest2} = parse_IntersectionElements(Rest), + {IRec,Rest3} = parse_IElemsRec(Rest2), + case {InterSec,IRec} of + {{'SingleValue',V1},{'SingleValue',V2}} -> + {{'SingleValue', + ordsets:intersection(to_set(V1),to_set(V2))},Rest3}; + {V1,[]} -> + {V1,Rest3}; + {V1,V2} when list(V2) -> + {[V1] ++ V2,Rest3}; + {V1,V2} -> + {[V1,V2],Rest3}; + _ -> + throw({asn1_error,{get_line(hd(Rest)),get(asn1_module), + [got,get_token(hd(Rest)),expected,'an Intersection']}}) + end; +parse_IElemsRec([{'INTERSECTION',_}|Rest]) -> + {InterSec,Rest2} = parse_IntersectionElements(Rest), + {IRec,Rest3} = parse_IElemsRec(Rest2), + case {InterSec,IRec} of + {{'SingleValue',V1},{'SingleValue',V2}} -> + {{'SingleValue', + ordsets:intersection(to_set(V1),to_set(V2))},Rest3}; + {V1,[]} -> + {V1,Rest3}; + {V1,V2} when list(V2) -> + {[V1] ++ V2,Rest3}; + {V1,V2} -> + {[V1,V2],Rest3}; + _ -> + throw({asn1_error,{get_line(hd(Rest)),get(asn1_module), + [got,get_token(hd(Rest)),expected,'an Intersection']}}) + end; +parse_IElemsRec(Tokens) -> + {[],Tokens}. + +parse_IntersectionElements(Tokens) -> + {InterSec,Rest} = parse_Elements(Tokens), + case Rest of + [{'EXCEPT',_}|Rest2] -> + {Exclusion,Rest3} = parse_Elements(Rest2), + {{InterSec,{'EXCEPT',Exclusion}},Rest3}; + Rest -> + {InterSec,Rest} + end. + +parse_Elements([{'(',_}|Rest]) -> + {Elems,Rest2} = parse_ElementSetSpec(Rest), + case Rest2 of + [{')',_}|Rest3] -> + {Elems,Rest3}; + [H|_T] -> + throw({asn1_error,{get_line(H),get(asn1_module), + [got,get_token(H),expected,')']}}) + end; +parse_Elements(Tokens) -> + Flist = [fun parse_SubtypeElements/1, + fun parse_ObjectSetElements/1], + case (catch parse_or(Tokens,Flist)) of + {'EXIT',Reason} -> + exit(Reason); + Err = {asn1_error,_} -> + throw(Err); + Result -> + Result + end. + + + + +%% -------------------------- + +parse_DefinedObjectClass([{typereference,_,_ModName},{'.',_},Tr={typereference,_,_ObjClName}|Rest]) -> +%% {{objectclassname,ModName,ObjClName},Rest}; +% {{objectclassname,tref2Exttref(Tr)},Rest}; + {tref2Exttref(Tr),Rest}; +parse_DefinedObjectClass([Tr={typereference,_,_ObjClName}|Rest]) -> +% {{objectclassname,tref2Exttref(Tr)},Rest}; + {tref2Exttref(Tr),Rest}; +parse_DefinedObjectClass([{'TYPE-IDENTIFIER',_}|Rest]) -> + {'TYPE-IDENTIFIER',Rest}; +parse_DefinedObjectClass([{'ABSTRACT-SYNTAX',_}|Rest]) -> + {'ABSTRACT-SYNTAX',Rest}; +parse_DefinedObjectClass(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected, + ['typereference . typereference', + typereference, + 'TYPE-IDENTIFIER', + 'ABSTRACT-SYNTAX']]}}). + +parse_ObjectClassAssignment([{typereference,L1,ObjClName},{'::=',_}|Rest]) -> + {Type,Rest2} = parse_ObjectClass(Rest), + {#classdef{pos=L1,name=ObjClName,typespec=Type},Rest2}; +parse_ObjectClassAssignment(Tokens) -> + throw({asn1_assignment_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected, + 'typereference ::=']}}). + +parse_ObjectClass(Tokens) -> + Flist = [fun parse_DefinedObjectClass/1, + fun parse_ObjectClassDefn/1, + fun parse_ParameterizedObjectClass/1], + case (catch parse_or(Tokens,Flist)) of + {'EXIT',Reason} -> + exit(Reason); + {asn1_error,Reason2} -> + throw({asn1_error,Reason2}); + Result -> + Result + end. + +parse_ObjectClassDefn([{'CLASS',_},{'{',_}|Rest]) -> + {Type,Rest2} = parse_FieldSpec(Rest), + {WithSyntaxSpec,Rest3} = parse_WithSyntaxSpec(Rest2), + {#objectclass{fields=Type,syntax=WithSyntaxSpec},Rest3}; +parse_ObjectClassDefn(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected,'CLASS {']}}). + +parse_FieldSpec(Tokens) -> + parse_FieldSpec(Tokens,[]). + +parse_FieldSpec(Tokens,Acc) -> + Flist = [fun parse_FixedTypeValueFieldSpec/1, + fun parse_VariableTypeValueFieldSpec/1, + fun parse_ObjectFieldSpec/1, + fun parse_FixedTypeValueSetFieldSpec/1, + fun parse_VariableTypeValueSetFieldSpec/1, + fun parse_TypeFieldSpec/1, + fun parse_ObjectSetFieldSpec/1], + case (catch parse_or(Tokens,Flist)) of + {'EXIT',Reason} -> + exit(Reason); + AsnErr = {asn1_error,_} -> + throw(AsnErr); + {Type,[{'}',_}|Rest]} -> + {lists:reverse([Type|Acc]),Rest}; + {Type,[{',',_}|Rest2]} -> + parse_FieldSpec(Rest2,[Type|Acc]); + {_,[H|_T]} -> + throw({asn1_error,{get_line(H),get(asn1_module), + [got,get_token(H),expected,'}']}}) + end. + +parse_PrimitiveFieldName([{typefieldreference,_,FieldName}|Rest]) -> + {{typefieldreference,FieldName},Rest}; +parse_PrimitiveFieldName([{valuefieldreference,_,FieldName}|Rest]) -> + {{valuefieldreference,FieldName},Rest}; +parse_PrimitiveFieldName(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected, + [typefieldreference,valuefieldreference]]}}). + +parse_FieldName(Tokens) -> + {Field,Rest} = parse_PrimitiveFieldName(Tokens), + parse_FieldName(Rest,[Field]). + +parse_FieldName([{'.',_}|Rest],Acc) -> + case (catch parse_PrimitiveFieldName(Rest)) of + {'EXIT',Reason} -> + exit(Reason); + AsnErr = {asn1_error,_} -> + throw(AsnErr); + {FieldName,Rest2} -> + parse_FieldName(Rest2,[FieldName|Acc]) + end; +parse_FieldName(Tokens,Acc) -> + {lists:reverse(Acc),Tokens}. + +parse_FixedTypeValueFieldSpec([{valuefieldreference,L1,VFieldName}|Rest]) -> + {Type,Rest2} = parse_Type(Rest), + {Unique,Rest3} = + case Rest2 of + [{'UNIQUE',_}|Rest4] -> + {'UNIQUE',Rest4}; + _ -> + {undefined,Rest2} + end, + {OptionalitySpec,Rest5} = parse_ValueOptionalitySpec(Rest3), + case Unique of + 'UNIQUE' -> + case OptionalitySpec of + {'DEFAULT',_} -> + throw({asn1_error, + {L1,get(asn1_module), + ['UNIQUE and DEFAULT in same field',VFieldName]}}); + _ -> + {{fixedtypevaluefield,VFieldName,Type,Unique,OptionalitySpec},Rest5} + end; + _ -> + {{object_or_fixedtypevalue_field,VFieldName,Type,Unique,OptionalitySpec},Rest5} + end; +parse_FixedTypeValueFieldSpec(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected,valuefieldreference]}}). + +parse_VariableTypeValueFieldSpec([{valuefieldreference,_,VFieldName}|Rest]) -> + {FieldRef,Rest2} = parse_FieldName(Rest), + {OptionalitySpec,Rest3} = parse_ValueOptionalitySpec(Rest2), + {{variabletypevaluefield,VFieldName,FieldRef,OptionalitySpec},Rest3}; +parse_VariableTypeValueFieldSpec(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected,valuefieldreference]}}). + +parse_ObjectFieldSpec([{valuefieldreference,_,VFieldName}|Rest]) -> + {Class,Rest2} = parse_DefinedObjectClass(Rest), + {OptionalitySpec,Rest3} = parse_ObjectOptionalitySpec(Rest2), + {{objectfield,VFieldName,Class,OptionalitySpec},Rest3}; +parse_ObjectFieldSpec(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected,valuefieldreference]}}). + +parse_TypeFieldSpec([{typefieldreference,_,TFieldName}|Rest]) -> + {OptionalitySpec,Rest2} = parse_TypeOptionalitySpec(Rest), + {{typefield,TFieldName,OptionalitySpec},Rest2}; +parse_TypeFieldSpec(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected,typefieldreference]}}). + +parse_FixedTypeValueSetFieldSpec([{typefieldreference,_,TFieldName}|Rest]) -> + {Type,Rest2} = parse_Type(Rest), + {OptionalitySpec,Rest3} = parse_ValueSetOptionalitySpec(Rest2), + {{objectset_or_fixedtypevalueset_field,TFieldName,Type, + OptionalitySpec},Rest3}; +parse_FixedTypeValueSetFieldSpec(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected,typefieldreference]}}). + +parse_VariableTypeValueSetFieldSpec([{typefieldreference,_,TFieldName}|Rest]) -> + {FieldRef,Rest2} = parse_FieldName(Rest), + {OptionalitySpec,Rest3} = parse_ValueSetOptionalitySpec(Rest2), + {{variabletypevaluesetfield,TFieldName,FieldRef,OptionalitySpec},Rest3}; +parse_VariableTypeValueSetFieldSpec(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected,typefieldreference]}}). + +parse_ObjectSetFieldSpec([{typefieldreference,_,TFieldName}|Rest]) -> + {Class,Rest2} = parse_DefinedObjectClass(Rest), + {OptionalitySpec,Rest3} = parse_ObjectSetOptionalitySpec(Rest2), + {{objectsetfield,TFieldName,Class,OptionalitySpec},Rest3}; +parse_ObjectSetFieldSpec(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected,typefieldreference]}}). + +parse_ValueOptionalitySpec(Tokens)-> + case Tokens of + [{'OPTIONAL',_}|Rest] -> {'OPTIONAL',Rest}; + [{'DEFAULT',_}|Rest] -> + {Value,Rest2} = parse_Value(Rest), + {{'DEFAULT',Value},Rest2}; + _ -> {'MANDATORY',Tokens} + end. + +parse_ObjectOptionalitySpec(Tokens) -> + case Tokens of + [{'OPTIONAL',_}|Rest] -> {'OPTIONAL',Rest}; + [{'DEFAULT',_}|Rest] -> + {Object,Rest2} = parse_Object(Rest), + {{'DEFAULT',Object},Rest2}; + _ -> {'MANDATORY',Tokens} + end. + +parse_TypeOptionalitySpec(Tokens) -> + case Tokens of + [{'OPTIONAL',_}|Rest] -> {'OPTIONAL',Rest}; + [{'DEFAULT',_}|Rest] -> + {Type,Rest2} = parse_Type(Rest), + {{'DEFAULT',Type},Rest2}; + _ -> {'MANDATORY',Tokens} + end. + +parse_ValueSetOptionalitySpec(Tokens) -> + case Tokens of + [{'OPTIONAL',_}|Rest] -> {'OPTIONAL',Rest}; + [{'DEFAULT',_}|Rest] -> + {ValueSet,Rest2} = parse_ValueSet(Rest), + {{'DEFAULT',ValueSet},Rest2}; + _ -> {'MANDATORY',Tokens} + end. + +parse_ObjectSetOptionalitySpec(Tokens) -> + case Tokens of + [{'OPTIONAL',_}|Rest] -> {'OPTIONAL',Rest}; + [{'DEFAULT',_}|Rest] -> + {ObjectSet,Rest2} = parse_ObjectSet(Rest), + {{'DEFAULT',ObjectSet},Rest2}; + _ -> {'MANDATORY',Tokens} + end. + +parse_WithSyntaxSpec([{'WITH',_},{'SYNTAX',_}|Rest]) -> + {SyntaxList,Rest2} = parse_SyntaxList(Rest), + {{'WITH SYNTAX',SyntaxList},Rest2}; +parse_WithSyntaxSpec(Tokens) -> + {[],Tokens}. + +parse_SyntaxList([{'{',_},{'}',_}|Rest]) -> + {[],Rest}; +parse_SyntaxList([{'{',_}|Rest]) -> + parse_SyntaxList(Rest,[]); +parse_SyntaxList(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected,['{}','{']]}}). + +parse_SyntaxList(Tokens,Acc) -> + {SyntaxList,Rest} = parse_TokenOrGroupSpec(Tokens), + case Rest of + [{'}',_}|Rest2] -> + {lists:reverse([SyntaxList|Acc]),Rest2}; + _ -> + parse_SyntaxList(Rest,[SyntaxList|Acc]) + end. + +parse_TokenOrGroupSpec(Tokens) -> + Flist = [fun parse_RequiredToken/1, + fun parse_OptionalGroup/1], + case (catch parse_or(Tokens,Flist)) of + {'EXIT',Reason} -> + exit(Reason); + AsnErr = {asn1_error,_} -> + throw(AsnErr); + Result -> + Result + end. + +parse_RequiredToken([{typereference,L1,WordName}|Rest]) -> + case is_word(WordName) of + false -> + throw({asn1_error,{L1,get(asn1_module), + [got,WordName,expected,a,'Word']}}); + true -> + {WordName,Rest} + end; +parse_RequiredToken([{',',L1}|Rest]) -> + {{',',L1},Rest}; +parse_RequiredToken([{WordName,L1}|Rest]) -> + case is_word(WordName) of + false -> + throw({asn1_error,{L1,get(asn1_module), + [got,WordName,expected,a,'Word']}}); + true -> + {WordName,Rest} + end; +parse_RequiredToken(Tokens) -> + parse_PrimitiveFieldName(Tokens). + +parse_OptionalGroup([{'[',_}|Rest]) -> + {Spec,Rest2} = parse_TokenOrGroupSpec(Rest), + {SpecList,Rest3} = parse_OptionalGroup(Rest2,[Spec]), + {SpecList,Rest3}. + +parse_OptionalGroup([{']',_}|Rest],Acc) -> + {lists:reverse(Acc),Rest}; +parse_OptionalGroup(Tokens,Acc) -> + {Spec,Rest} = parse_TokenOrGroupSpec(Tokens), + parse_OptionalGroup(Rest,[Spec|Acc]). + +parse_DefinedObject([Id={identifier,_,_ObjName}|Rest]) -> + {{object,identifier2Extvalueref(Id)},Rest}; +parse_DefinedObject([{typereference,L1,ModName},{'.',_},{identifier,_,ObjName}|Rest]) -> + {{object, #'Externaltypereference'{pos=L1,module=ModName,type=ObjName}},Rest}; +parse_DefinedObject(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected, + [identifier,'typereference.identifier']]}}). + +parse_ObjectAssignment([{identifier,L1,ObjName}|Rest]) -> + {Class,Rest2} = parse_DefinedObjectClass(Rest), + case Rest2 of + [{'::=',_}|Rest3] -> + {Object,Rest4} = parse_Object(Rest3), + {#typedef{pos=L1,name=ObjName, + typespec=#'Object'{classname=Class,def=Object}},Rest4}; + [H|_T] -> + throw({asn1_error,{get_line(H),get(asn1_module), + [got,get_token(H),expected,'::=']}}); + Other -> + throw({asn1_error,{L1,get(asn1_module), + [got,Other,expected,'::=']}}) + end; +parse_ObjectAssignment(Tokens) -> + throw({asn1_assignment_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected,identifier]}}). + +parse_Object(Tokens) -> + Flist=[fun parse_ObjectDefn/1, + fun parse_ObjectFromObject/1, + fun parse_ParameterizedObject/1, + fun parse_DefinedObject/1], + case (catch parse_or(Tokens,Flist)) of + {'EXIT',Reason} -> + exit(Reason); + AsnErr = {asn1_error,_} -> + throw(AsnErr); + Result -> + Result + end. + +parse_ObjectDefn(Tokens) -> + Flist=[fun parse_DefaultSyntax/1, + fun parse_DefinedSyntax/1], + case (catch parse_or(Tokens,Flist)) of + {'EXIT',Reason} -> + exit(Reason); + AsnErr = {asn1_error,_} -> + throw(AsnErr); + Result -> + Result + end. + +parse_DefaultSyntax([{'{',_},{'}',_}|Rest]) -> + {{object,defaultsyntax,[]},Rest}; +parse_DefaultSyntax([{'{',_}|Rest]) -> + parse_DefaultSyntax(Rest,[]); +parse_DefaultSyntax(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected,['{}','{']]}}). + +parse_DefaultSyntax(Tokens,Acc) -> + {Setting,Rest} = parse_FieldSetting(Tokens), + case Rest of + [{',',_}|Rest2] -> + parse_DefaultSyntax(Rest2,[Setting|Acc]); + [{'}',_}|Rest3] -> + {{object,defaultsyntax,lists:reverse([Setting|Acc])},Rest3}; + [H|_T] -> + throw({asn1_error,{get_line(H),get(asn1_module), + [got,get_token(H),expected,[',','}']]}}) + end. + +parse_FieldSetting(Tokens) -> + {{_,PrimFieldName},Rest} = parse_PrimitiveFieldName(Tokens), + {Setting,Rest2} = parse_Setting(Rest), + {{PrimFieldName,Setting},Rest2}. + +parse_DefinedSyntax([{'{',_}|Rest]) -> + parse_DefinedSyntax(Rest,[]). + +parse_DefinedSyntax(Tokens,Acc) -> + case Tokens of + [{'}',_}|Rest2] -> + {{object,definedsyntax,lists:reverse(Acc)},Rest2}; + _ -> + {DefSynTok,Rest3} = parse_DefinedSyntaxToken(Tokens), + parse_DefinedSyntax(Rest3,[DefSynTok|Acc]) + end. + +parse_DefinedSyntaxToken([{',',L1}|Rest]) -> + {{',',L1},Rest}; +parse_DefinedSyntaxToken([{typereference,L1,Name}|Rest]) -> + case is_word(Name) of + false -> + {{setting,L1,Name},Rest}; + true -> + {{word_or_setting,L1,Name},Rest} + end; +parse_DefinedSyntaxToken(Tokens) -> + case catch parse_Setting(Tokens) of + {asn1_error,_} -> + parse_Word(Tokens); + {'EXIT',Reason} -> + exit(Reason); + Result -> + Result + end. + +parse_Word([{Name,Pos}|Rest]) -> + case is_word(Name) of + false -> + throw({asn1_error,{Pos,get(asn1_module), + [got,Name, expected,a,'Word']}}); + true -> + {{word_or_setting,Pos,Name},Rest} + end. + +parse_Setting(Tokens) -> + Flist = [fun parse_Type/1, + fun parse_Value/1, + fun parse_Object/1, + fun parse_ObjectSet/1], + case (catch parse_or(Tokens,Flist)) of + {'EXIT',Reason} -> + exit(Reason); + AsnErr = {asn1_error,_} -> + throw(AsnErr); + Result -> + Result + end. + +parse_DefinedObjectSet([{typereference,L1,ModuleName},{'.',_}, + {typereference,L2,ObjSetName}|Rest]) -> + {{objectset,L1,#'Externaltypereference'{pos=L2,module=ModuleName, + type=ObjSetName}},Rest}; +parse_DefinedObjectSet([{typereference,L1,ObjSetName}|Rest]) -> + {{objectset,L1,#'Externaltypereference'{pos=L1,module=get(asn1_module), + type=ObjSetName}},Rest}; +parse_DefinedObjectSet(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected, + [typereference,'typereference.typereference']]}}). + +parse_ObjectSetAssignment([{typereference,L1,ObjSetName}|Rest]) -> + {Class,Rest2} = parse_DefinedObjectClass(Rest), + case Rest2 of + [{'::=',_}|Rest3] -> + {ObjectSet,Rest4} = parse_ObjectSet(Rest3), + {#typedef{pos=L1,name=ObjSetName, + typespec=#'ObjectSet'{class=Class, + set=ObjectSet}},Rest4}; + [H|_T] -> + throw({asn1_error,{get_line(H),get(asn1_module), + [got,get_token(H),expected,'::=']}}) +%%% Other -> +%%% throw(Other) + end; +parse_ObjectSetAssignment(Tokens) -> + throw({asn1_assignment_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected, + typereference]}}). + +parse_ObjectSet([{'{',_}|Rest]) -> + {ObjSetSpec,Rest2} = parse_ObjectSetSpec(Rest), + case Rest2 of + [{'}',_}|Rest3] -> + {ObjSetSpec,Rest3}; + [H|_T] -> + throw({asn1_error,{get_line(H),get(asn1_module), + [got,get_token(H),expected,'}']}}) + end; +parse_ObjectSet(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected,'{']}}). + +parse_ObjectSetSpec([{'...',_}|Rest]) -> + {['EXTENSIONMARK'],Rest}; +parse_ObjectSetSpec(Tokens) -> + parse_ElementSetSpecs(Tokens). + +parse_ObjectSetElements(Tokens) -> + Flist = [fun parse_Object/1, + fun parse_DefinedObjectSet/1, + fun parse_ObjectSetFromObjects/1, + fun parse_ParameterizedObjectSet/1], + case (catch parse_or(Tokens,Flist)) of + {'EXIT',Reason} -> + exit(Reason); + AsnErr = {asn1_error,_} -> + throw(AsnErr); + Result -> + Result + end. + +parse_ObjectClassFieldType(Tokens) -> + {Class,Rest} = parse_DefinedObjectClass(Tokens), + case Rest of + [{'.',_}|Rest2] -> + {FieldName,Rest3} = parse_FieldName(Rest2), + OCFT = #'ObjectClassFieldType'{ + classname=Class, + class=Class,fieldname=FieldName}, + {#type{def=OCFT},Rest3}; + [H|_T] -> + throw({asn1_error,{get_line(H),get(asn1_module), + [got,get_token(H),expected,'.']}}) +%%% Other -> +%%% throw(Other) + end. + +%parse_ObjectClassFieldValue(Tokens) -> +% Flist = [fun parse_OpenTypeFieldVal/1, +% fun parse_FixedTypeFieldVal/1], +% case (catch parse_or(Tokens,Flist)) of +% {'EXIT',Reason} -> +% throw(Reason); +% AsnErr = {asn1_error,_} -> +% throw(AsnErr); +% Result -> +% Result +% end. + +parse_ObjectClassFieldValue(Tokens) -> + parse_OpenTypeFieldVal(Tokens). + +parse_OpenTypeFieldVal(Tokens) -> + {Type,Rest} = parse_Type(Tokens), + case Rest of + [{':',_}|Rest2] -> + {Value,Rest3} = parse_Value(Rest2), + {{opentypefieldvalue,Type,Value},Rest3}; + [H|_T] -> + throw({asn1_error,{get_line(H),get(asn1_module), + [got,get_token(H),expected,':']}}) + end. + +% parse_FixedTypeFieldVal(Tokens) -> +% parse_Value(Tokens). + +% parse_InformationFromObjects(Tokens) -> +% Flist = [fun parse_ValueFromObject/1, +% fun parse_ValueSetFromObjects/1, +% fun parse_TypeFromObject/1, +% fun parse_ObjectFromObject/1], +% case (catch parse_or(Tokens,Flist)) of +% {'EXIT',Reason} -> +% throw(Reason); +% AsnErr = {asn1_error,_} -> +% throw(AsnErr); +% Result -> +% Result +% end. + +parse_ReferencedObjects(Tokens) -> + Flist = [fun parse_DefinedObject/1, + fun parse_DefinedObjectSet/1, + fun parse_ParameterizedObject/1, + fun parse_ParameterizedObjectSet/1], + case (catch parse_or(Tokens,Flist)) of + {'EXIT',Reason} -> + exit(Reason); + AsnErr = {asn1_error,_} -> + throw(AsnErr); + Result -> + Result + end. + +parse_ValueFromObject(Tokens) -> + {Objects,Rest} = parse_ReferencedObjects(Tokens), + case Rest of + [{'.',_}|Rest2] -> + {Name,Rest3} = parse_FieldName(Rest2), + case lists:last(Name) of + {valuefieldreference,_} -> + {{'ValueFromObject',Objects,Name},Rest3}; + _ -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,typefieldreference,expected, + valuefieldreference]}}) + end; + [H|_T] -> + throw({asn1_error,{get_line(H),get(asn1_module), + [got,get_token(H),expected,'.']}}) +%%% Other -> +%%% throw({asn1_error,{got,Other,expected,'.'}}) + end. + +parse_ValueSetFromObjects(Tokens) -> + {Objects,Rest} = parse_ReferencedObjects(Tokens), + case Rest of + [{'.',_}|Rest2] -> + {Name,Rest3} = parse_FieldName(Rest2), + case lists:last(Name) of + {typefieldreference,_FieldName} -> + {{'ValueSetFromObjects',Objects,Name},Rest3}; + _ -> + throw({asn1_error,{get_line(hd(Rest2)),get(asn1_module), + [got,get_token(hd(Rest2)),expected, + typefieldreference]}}) + end; + [H|_T] -> + throw({asn1_error,{get_line(H),get(asn1_module), + [got,get_token(H),expected,'.']}}) +%%% Other -> +%%% throw({asn1_error,{got,Other,expected,'.'}}) + end. + +parse_TypeFromObject(Tokens) -> + {Objects,Rest} = parse_ReferencedObjects(Tokens), + case Rest of + [{'.',_}|Rest2] -> + {Name,Rest3} = parse_FieldName(Rest2), + case lists:last(Name) of + {typefieldreference,_FieldName} -> + {{'TypeFromObject',Objects,Name},Rest3}; + _ -> + throw({asn1_error,{get_line(hd(Rest2)),get(asn1_module), + [got,get_token(hd(Rest2)),expected, + typefieldreference]}}) + end; + [H|_T] -> + throw({asn1_error,{get_line(H),get(asn1_module), + [got,get_token(H),expected,'.']}}) +%%% Other -> +%%% throw({asn1_error,{got,Other,expected,'.'}}) + end. + +parse_ObjectFromObject(Tokens) -> + {Objects,Rest} = parse_ReferencedObjects(Tokens), + case Rest of + [{'.',_}|Rest2] -> + {Name,Rest3} = parse_FieldName(Rest2), + {{'ObjectFromObject',Objects,Name},Rest3}; + [H|_T] -> + throw({asn1_error,{get_line(H),get(asn1_module), + [got,get_token(H),expected,'.']}}) +%%% Other -> +%%% throw({asn1_error,{got,Other,expected,'.'}}) + end. + +parse_ObjectSetFromObjects(Tokens) -> + {Objects,Rest} = parse_ReferencedObjects(Tokens), + case Rest of + [{'.',_}|Rest2] -> + {Name,Rest3} = parse_FieldName(Rest2), + {{'ObjectSetFromObjects',Objects,Name},Rest3}; + [H|_T] -> + throw({asn1_error,{get_line(H),get(asn1_module), + [got,get_token(H),expected,'.']}}) +%%% Other -> +%%% throw({asn1_error,{got,Other,expected,'.'}}) + end. + +% parse_InstanceOfType([{'INSTANCE',_},{'OF',_}|Rest]) -> +% {Class,Rest2} = parse_DefinedObjectClass(Rest), +% {{'InstanceOfType',Class},Rest2}. + +% parse_InstanceOfValue(Tokens) -> +% parse_Value(Tokens). + + + +%% X.682 constraint specification + +parse_GeneralConstraint(Tokens) -> + Flist = [fun parse_UserDefinedConstraint/1, + fun parse_TableConstraint/1], + case (catch parse_or(Tokens,Flist)) of + {'EXIT',Reason} -> + exit(Reason); + AsnErr = {asn1_error,_} -> + throw(AsnErr); + Result -> + Result + end. + +parse_UserDefinedConstraint([{'CONSTRAINED',_},{'BY',_},{'{',_},{'}',_}|Rest])-> + {{constrained_by,[]},Rest}; +parse_UserDefinedConstraint([{'CONSTRAINED',_}, + {'BY',_}, + {'{',_}|Rest]) -> + {Param,Rest2} = parse_UserDefinedConstraintParameter(Rest), + case Rest2 of + [{'}',_}|Rest3] -> + {{constrained_by,Param},Rest3}; + [H|_T] -> + throw({asn1_error,{get_line(H),get(asn1_module), + [got,get_token(H),expected,'}']}}) + end; +parse_UserDefinedConstraint(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected, + ['CONSTRAINED BY {}','CONSTRAINED BY {']]}}). + +parse_UserDefinedConstraintParameter(Tokens) -> + parse_UserDefinedConstraintParameter(Tokens,[]). +parse_UserDefinedConstraintParameter(Tokens,Acc) -> + Flist = [fun parse_GovernorAndActualParameter/1, + fun parse_ActualParameter/1], + case (catch parse_or(Tokens,Flist)) of + {'EXIT',Reason} -> + exit(Reason); + AsnErr = {asn1_error,_} -> + throw(AsnErr); + {Result,Rest} -> + case Rest of + [{',',_}|_Rest2] -> + parse_UserDefinedConstraintParameter(Tokens,[Result|Acc]); + _ -> + {lists:reverse([Result|Acc]),Rest} + end + end. + +parse_GovernorAndActualParameter(Tokens) -> + {Governor,Rest} = parse_Governor(Tokens), + case Rest of + [{':',_}|Rest2] -> + {Params,Rest3} = parse_ActualParameter(Rest2), + {{'Governor_Params',Governor,Params},Rest3}; + [H|_T] -> + throw({asn1_error,{get_line(H),get(asn1_module), + [got,get_token(H),expected,':']}}) + end. + +parse_TableConstraint(Tokens) -> + Flist = [fun parse_ComponentRelationConstraint/1, + fun parse_SimpleTableConstraint/1], + case (catch parse_or(Tokens,Flist)) of + {'EXIT',Reason} -> + exit(Reason); + AsnErr = {asn1_error,_} -> + throw(AsnErr); + Result -> + Result + end. + +parse_SimpleTableConstraint(Tokens) -> + {ObjectSet,Rest} = parse_ObjectSet(Tokens), + {{simpletable,ObjectSet},Rest}. + +parse_ComponentRelationConstraint([{'{',_}|Rest]) -> + {ObjectSet,Rest2} = parse_DefinedObjectSet(Rest), + case Rest2 of + [{'}',_},{'{',_}|Rest3] -> + {AtNot,Rest4} = parse_AtNotationList(Rest3,[]), + case Rest4 of + [{'}',_}|Rest5] -> + {{componentrelation,ObjectSet,AtNot},Rest5}; + [H|_T] -> + throw({asn1_error,{get_line(H),get(asn1_module), + [got,get_token(H),expected,'}']}}) + end; + [H|_T] -> + throw({asn1_error,{get_line(H),get(asn1_module), + [got,get_token(H),expected, + 'ComponentRelationConstraint',ended,with,'}']}}) +%%% Other -> +%%% throw(Other) + end; +parse_ComponentRelationConstraint(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected,'{']}}). + +parse_AtNotationList(Tokens,Acc) -> + {AtNot,Rest} = parse_AtNotation(Tokens), + case Rest of + [{',',_}|Rest2] -> + parse_AtNotationList(Rest2,[AtNot|Acc]); + _ -> + {lists:reverse([AtNot|Acc]),Rest} + end. + +parse_AtNotation([{'@',_},{'.',_}|Rest]) -> + {CIdList,Rest2} = parse_ComponentIdList(Rest), + {{innermost,CIdList},Rest2}; +parse_AtNotation([{'@',_}|Rest]) -> + {CIdList,Rest2} = parse_ComponentIdList(Rest), + {{outermost,CIdList},Rest2}; +parse_AtNotation(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected,['@','@.']]}}). + +parse_ComponentIdList(Tokens) -> + parse_ComponentIdList(Tokens,[]). + +parse_ComponentIdList([Id = {identifier,_,_},{'.',_}|Rest],Acc) -> + parse_ComponentIdList(Rest,[identifier2Extvalueref(Id)|Acc]); +parse_ComponentIdList([Id = {identifier,_,_}|Rest],Acc) -> + {lists:reverse([identifier2Extvalueref(Id)|Acc]),Rest}; +parse_ComponentIdList(Tokens,_) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected, + [identifier,'identifier.']]}}). + + + + + +% X.683 Parameterization of ASN.1 specifications + +parse_Governor(Tokens) -> + Flist = [fun parse_Type/1, + fun parse_DefinedObjectClass/1], + case (catch parse_or(Tokens,Flist)) of + {'EXIT',Reason} -> + exit(Reason); + AsnErr = {asn1_error,_} -> + throw(AsnErr); + Result -> + Result + end. + +parse_ActualParameter(Tokens) -> + Flist = [fun parse_Type/1, + fun parse_Value/1, + fun parse_ValueSet/1, + fun parse_DefinedObjectClass/1, + fun parse_Object/1, + fun parse_ObjectSet/1], + case (catch parse_or(Tokens,Flist)) of + {'EXIT',Reason} -> + exit(Reason); + AsnErr = {asn1_error,_} -> + throw(AsnErr); + Result -> + Result + end. + +parse_ParameterizedAssignment(Tokens) -> + Flist = [fun parse_ParameterizedTypeAssignment/1, + fun parse_ParameterizedValueAssignment/1, + fun parse_ParameterizedValueSetTypeAssignment/1, + fun parse_ParameterizedObjectClassAssignment/1, + fun parse_ParameterizedObjectAssignment/1, + fun parse_ParameterizedObjectSetAssignment/1], + case (catch parse_or(Tokens,Flist)) of + {'EXIT',Reason} -> + exit(Reason); + AsnErr = {asn1_error,_} -> + throw(AsnErr); + AsnAssErr = {asn1_assignment_error,_} -> + throw(AsnAssErr); + Result -> + Result + end. + +parse_ParameterizedTypeAssignment([{typereference,L1,Name}|Rest]) -> + {ParameterList,Rest2} = parse_ParameterList(Rest), + case Rest2 of + [{'::=',_}|Rest3] -> + {Type,Rest4} = parse_Type(Rest3), + {#ptypedef{pos=L1,name=Name,args=ParameterList,typespec=Type}, + Rest4}; + [H|_T] -> + throw({asn1_error,{get_line(H),get(asn1_module), + [got,get_token(H),expected,'::=']}}) + end; +parse_ParameterizedTypeAssignment(Tokens) -> + throw({asn1_assignment_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected, + typereference]}}). + +parse_ParameterizedValueAssignment([{identifier,L1,Name}|Rest]) -> + {ParameterList,Rest2} = parse_ParameterList(Rest), + {Type,Rest3} = parse_Type(Rest2), + case Rest3 of + [{'::=',_}|Rest4] -> + {Value,Rest5} = parse_Value(Rest4), + {#pvaluedef{pos=L1,name=Name,args=ParameterList,type=Type, + value=Value},Rest5}; + [H|_T] -> + throw({asn1_error,{get_line(H),get(asn1_module), + [got,get_token(H),expected,'::=']}}) + end; +parse_ParameterizedValueAssignment(Tokens) -> + throw({asn1_assignment_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected,identifier]}}). + +parse_ParameterizedValueSetTypeAssignment([{typereference,L1,Name}|Rest]) -> + {ParameterList,Rest2} = parse_ParameterList(Rest), + {Type,Rest3} = parse_Type(Rest2), + case Rest3 of + [{'::=',_}|Rest4] -> + {ValueSet,Rest5} = parse_ValueSet(Rest4), + {#pvaluesetdef{pos=L1,name=Name,args=ParameterList, + type=Type,valueset=ValueSet},Rest5}; + [H|_T] -> + throw({asn1_error,{get_line(H),get(asn1_module), + [got,get_token(H),expected,'::=']}}) + end; +parse_ParameterizedValueSetTypeAssignment(Tokens) -> + throw({asn1_assignment_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected, + typereference]}}). + +parse_ParameterizedObjectClassAssignment([{typereference,L1,Name}|Rest]) -> + {ParameterList,Rest2} = parse_ParameterList(Rest), + case Rest2 of + [{'::=',_}|Rest3] -> + {Class,Rest4} = parse_ObjectClass(Rest3), + {#ptypedef{pos=L1,name=Name,args=ParameterList,typespec=Class}, + Rest4}; + [H|_T] -> + throw({asn1_error,{get_line(H),get(asn1_module), + [got,get_token(H),expected,'::=']}}) + end; +parse_ParameterizedObjectClassAssignment(Tokens) -> + throw({asn1_assignment_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected, + typereference]}}). + +parse_ParameterizedObjectAssignment([{identifier,L1,Name}|Rest]) -> + {ParameterList,Rest2} = parse_ParameterList(Rest), + {Class,Rest3} = parse_DefinedObjectClass(Rest2), + case Rest3 of + [{'::=',_}|Rest4] -> + {Object,Rest5} = parse_Object(Rest4), + {#pobjectdef{pos=L1,name=Name,args=ParameterList, + class=Class,def=Object},Rest5}; + [H|_T] -> + throw({asn1_error,{get_line(H),get(asn1_module), + [got,get_token(H),expected,'::=']}}) +%%% Other -> +%%% throw(Other) + end; +parse_ParameterizedObjectAssignment(Tokens) -> + throw({asn1_assignment_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected,identifier]}}). + +parse_ParameterizedObjectSetAssignment([{typereference,L1,Name}|Rest]) -> + {ParameterList,Rest2} = parse_ParameterList(Rest), + {Class,Rest3} = parse_DefinedObjectClass(Rest2), + case Rest3 of + [{'::=',_}|Rest4] -> + {ObjectSet,Rest5} = parse_ObjectSet(Rest4), + {#pobjectsetdef{pos=L1,name=Name,args=ParameterList, + class=Class,def=ObjectSet},Rest5}; + [H|_T] -> + throw({asn1_error,{get_line(H),get(asn1_module), + [got,get_token(H),expected,'::=']}}) +%%% Other -> +%%% throw(Other) + end; +parse_ParameterizedObjectSetAssignment(Tokens) -> + throw({asn1_assignment_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected, + typereference]}}). + +parse_ParameterList([{'{',_}|Rest]) -> + parse_ParameterList(Rest,[]); +parse_ParameterList(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected,'{']}}). + +parse_ParameterList(Tokens,Acc) -> + {Parameter,Rest} = parse_Parameter(Tokens), + case Rest of + [{',',_}|Rest2] -> + parse_ParameterList(Rest2,[Parameter|Acc]); + [{'}',_}|Rest3] -> + {lists:reverse([Parameter|Acc]),Rest3}; + [H|_T] -> + throw({asn1_error,{get_line(H),get(asn1_module), + [got,get_token(H),expected,[',','}']]}}) + end. + +parse_Parameter(Tokens) -> + Flist = [fun parse_ParamGovAndRef/1, + fun parse_Reference/1], + case (catch parse_or(Tokens,Flist)) of + {'EXIT',Reason} -> + exit(Reason); + AsnErr = {asn1_error,_} -> + throw(AsnErr); + Result -> + Result + end. + +parse_ParamGovAndRef(Tokens) -> + {ParamGov,Rest} = parse_ParamGovernor(Tokens), + case Rest of + [{':',_}|Rest2] -> + {Ref,Rest3} = parse_Reference(Rest2), + {{ParamGov,Ref},Rest3}; + [H|_T] -> + throw({asn1_error,{get_line(H),get(asn1_module), + [got,get_token(H),expected,':']}}) + end. + +parse_ParamGovernor(Tokens) -> + Flist = [fun parse_Governor/1, + fun parse_Reference/1], + case (catch parse_or(Tokens,Flist)) of + {'EXIT',Reason} -> + exit(Reason); + AsnErr = {asn1_error,_} -> + throw(AsnErr); + Result -> + Result + end. + +% parse_ParameterizedReference(Tokens) -> +% {Ref,Rest} = parse_Reference(Tokens), +% case Rest of +% [{'{',_},{'}',_}|Rest2] -> +% {{ptref,Ref},Rest2}; +% _ -> +% {{ptref,Ref},Rest} +% end. + +parse_SimpleDefinedType([{typereference,L1,ModuleName},{'.',_}, + {typereference,_,TypeName}|Rest]) -> + {#'Externaltypereference'{pos=L1,module=ModuleName, + type=TypeName},Rest}; +parse_SimpleDefinedType([Tref={typereference,_,_}|Rest]) -> +% {#'Externaltypereference'{pos=L2,module=get(asn1_module), +% type=TypeName},Rest}; + {tref2Exttref(Tref),Rest}; +parse_SimpleDefinedType(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected, + [typereference,'typereference.typereference']]}}). + +parse_SimpleDefinedValue([{typereference,L1,ModuleName},{'.',_}, + {identifier,_,Value}|Rest]) -> + {{simpledefinedvalue,#'Externalvaluereference'{pos=L1,module=ModuleName, + value=Value}},Rest}; +parse_SimpleDefinedValue([{identifier,L2,Value}|Rest]) -> + {{simpledefinedvalue,L2,Value},Rest}; +parse_SimpleDefinedValue(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected, + ['typereference.identifier',identifier]]}}). + +parse_ParameterizedType(Tokens) -> + {Type,Rest} = parse_SimpleDefinedType(Tokens), + {Params,Rest2} = parse_ActualParameterList(Rest), + {{pt,Type,Params},Rest2}. + +parse_ParameterizedValue(Tokens) -> + {Value,Rest} = parse_SimpleDefinedValue(Tokens), + {Params,Rest2} = parse_ActualParameterList(Rest), + {{pv,Value,Params},Rest2}. + +parse_ParameterizedObjectClass(Tokens) -> + {Type,Rest} = parse_DefinedObjectClass(Tokens), + {Params,Rest2} = parse_ActualParameterList(Rest), + {{poc,Type,Params},Rest2}. + +parse_ParameterizedObjectSet(Tokens) -> + {ObjectSet,Rest} = parse_DefinedObjectSet(Tokens), + {Params,Rest2} = parse_ActualParameterList(Rest), + {{pos,ObjectSet,Params},Rest2}. + +parse_ParameterizedObject(Tokens) -> + {Object,Rest} = parse_DefinedObject(Tokens), + {Params,Rest2} = parse_ActualParameterList(Rest), + {{po,Object,Params},Rest2}. + +parse_ActualParameterList([{'{',_}|Rest]) -> + parse_ActualParameterList(Rest,[]); +parse_ActualParameterList(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected,'{']}}). + +parse_ActualParameterList(Tokens,Acc) -> + {Parameter,Rest} = parse_ActualParameter(Tokens), + case Rest of + [{',',_}|Rest2] -> + parse_ActualParameterList(Rest2,[Parameter|Acc]); + [{'}',_}|Rest3] -> + {lists:reverse([Parameter|Acc]),Rest3}; + [H|_T] -> + throw({asn1_error,{get_line(H),get(asn1_module), + [got,get_token(H),expected,[',','}']]}}) +%%% Other -> +%%% throw(Other) + end. + + + + + + + +%------------------------- + +is_word(Token) -> + case not_allowed_word(Token) of + true -> false; + _ -> + if + atom(Token) -> + Item = atom_to_list(Token), + is_word(Item); + list(Token), length(Token) == 1 -> + check_one_char_word(Token); + list(Token) -> + [A|Rest] = Token, + case check_first(A) of + true -> + check_rest(Rest); + _ -> + false + end + end + end. + +not_allowed_word(Name) -> + lists:member(Name,["BIT", + "BOOLEAN", + "CHARACTER", + "CHOICE", + "EMBEDDED", + "END", + "ENUMERATED", + "EXTERNAL", + "FALSE", + "INSTANCE", + "INTEGER", + "INTERSECTION", + "MINUS-INFINITY", + "NULL", + "OBJECT", + "OCTET", + "PLUS-INFINITY", + "REAL", + "SEQUENCE", + "SET", + "TRUE", + "UNION"]). + +check_one_char_word([A]) when $A =< A, $Z >= A -> + true; +check_one_char_word([_]) -> + false. %% unknown item in SyntaxList + +check_first(A) when $A =< A, $Z >= A -> + true; +check_first(_) -> + false. %% unknown item in SyntaxList + +check_rest([R,R|_Rs]) when $- == R -> + false; %% two consecutive hyphens are not allowed in a word +check_rest([R]) when $- == R -> + false; %% word cannot end with hyphen +check_rest([R|Rs]) when $A=<R, $Z>=R; $-==R -> + check_rest(Rs); +check_rest([]) -> + true; +check_rest(_) -> + false. + + +to_set(V) when list(V) -> + ordsets:list_to_set(V); +to_set(V) -> + ordsets:list_to_set([V]). + + +parse_AlternativeTypeLists(Tokens) -> + {AlternativeTypeList,Rest1} = parse_AlternativeTypeList(Tokens), + {ExtensionAndException,Rest2} = + case Rest1 of + [{',',_},{'...',L1},{'!',_}|Rest12] -> + {_,Rest13} = parse_ExceptionIdentification(Rest12), + %% Exception info is currently thrown away + {[#'EXTENSIONMARK'{pos=L1}],Rest13}; + [{',',_},{'...',L1}|Rest12] -> + {[#'EXTENSIONMARK'{pos=L1}],Rest12}; + _ -> + {[],Rest1} + end, + case ExtensionAndException of + [] -> + {AlternativeTypeList,Rest2}; + _ -> + {ExtensionAddition,Rest3} = + case Rest2 of + [{',',_}|Rest23] -> + parse_ExtensionAdditionAlternativeList(Rest23); + _ -> + {[],Rest2} + end, + {OptionalExtensionMarker,Rest4} = + case Rest3 of + [{',',_},{'...',L3}|Rest31] -> + {[#'EXTENSIONMARK'{pos=L3}],Rest31}; + _ -> + {[],Rest3} + end, + {AlternativeTypeList ++ ExtensionAndException ++ ExtensionAddition ++ OptionalExtensionMarker, Rest4} + end. + + +parse_AlternativeTypeList(Tokens) -> + parse_AlternativeTypeList(Tokens,[]). + +parse_AlternativeTypeList(Tokens,Acc) -> + {NamedType,Rest} = parse_NamedType(Tokens), + case Rest of + [{',',_},Id = {identifier,_,_}|Rest2] -> + parse_AlternativeTypeList([Id|Rest2],[NamedType|Acc]); + _ -> + {lists:reverse([NamedType|Acc]),Rest} + end. + + + +parse_ExtensionAdditionAlternativeList(Tokens) -> + parse_ExtensionAdditionAlternativeList(Tokens,[]). + +parse_ExtensionAdditionAlternativeList(Tokens,Acc) -> + {Element,Rest0} = + case Tokens of + [{identifier,_,_}|_Rest] -> + parse_NamedType(Tokens); + [{'[[',_}|_] -> + parse_ExtensionAdditionAlternatives(Tokens) + end, + case Rest0 of + [{',',_}|Rest01] -> + parse_ExtensionAdditionAlternativeList(Rest01,[Element|Acc]); + _ -> + {lists:reverse([Element|Acc]),Rest0} + end. + +parse_ExtensionAdditionAlternatives([{'[[',_}|Rest]) -> + parse_ExtensionAdditionAlternatives(Rest,[]); +parse_ExtensionAdditionAlternatives(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected,'[[']}}). + +parse_ExtensionAdditionAlternatives([Id = {identifier,_,_}|Rest],Acc) -> + {NamedType, Rest2} = parse_NamedType([Id|Rest]), + case Rest2 of + [{',',_}|Rest21] -> + parse_ExtensionAdditionAlternatives(Rest21,[NamedType|Acc]); + [{']]',_}|Rest21] -> + {lists:reverse(Acc),Rest21}; + _ -> + throw({asn1_error,{get_line(hd(Rest2)),get(asn1_module), + [got,get_token(hd(Rest2)),expected,[',',']]']]}}) + end. + +parse_NamedType([{identifier,L1,Idname}|Rest]) -> + {Type,Rest2} = parse_Type(Rest), + {#'ComponentType'{pos=L1,name=Idname,typespec=Type,prop=mandatory},Rest2}; +parse_NamedType(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected,identifier]}}). + + +parse_ComponentTypeLists(Tokens) -> +% Resulting tuple {ComponentTypeList,Rest1} is returned + case Tokens of + [{identifier,_,_}|_Rest0] -> + {Clist,Rest01} = parse_ComponentTypeList(Tokens), + case Rest01 of + [{',',_}|Rest02] -> + parse_ComponentTypeLists(Rest02,Clist); + _ -> + {Clist,Rest01} + end; + [{'COMPONENTS',_},{'OF',_}|_Rest] -> + {Clist,Rest01} = parse_ComponentTypeList(Tokens), + case Rest01 of + [{',',_}|Rest02] -> + parse_ComponentTypeLists(Rest02,Clist); + _ -> + {Clist,Rest01} + end; + _ -> + parse_ComponentTypeLists(Tokens,[]) + end. + +parse_ComponentTypeLists([{'...',L1},{'!',_}|Rest],Clist1) -> + {_,Rest2} = parse_ExceptionIdentification(Rest), + %% Exception info is currently thrown away + parse_ComponentTypeLists2(Rest2,Clist1++[#'EXTENSIONMARK'{pos=L1}]); +parse_ComponentTypeLists([{'...',L1}|Rest],Clist1) -> + parse_ComponentTypeLists2(Rest,Clist1++[#'EXTENSIONMARK'{pos=L1}]); +parse_ComponentTypeLists(Tokens,Clist1) -> + {Clist1,Tokens}. + + +parse_ComponentTypeLists2(Tokens,Clist1) -> + {ExtensionAddition,Rest2} = + case Tokens of + [{',',_}|Rest1] -> + parse_ExtensionAdditionList(Rest1); + _ -> + {[],Tokens} + end, + {OptionalExtensionMarker,Rest3} = + case Rest2 of + [{',',_},{'...',L2}|Rest21] -> + {[#'EXTENSIONMARK'{pos=L2}],Rest21}; + _ -> + {[],Rest2} + end, + {RootComponentTypeList,Rest4} = + case Rest3 of + [{',',_}|Rest31] -> + parse_ComponentTypeList(Rest31); + _ -> + {[],Rest3} + end, + {Clist1 ++ ExtensionAddition ++ OptionalExtensionMarker ++ RootComponentTypeList, Rest4}. + + +parse_ComponentTypeList(Tokens) -> + parse_ComponentTypeList(Tokens,[]). + +parse_ComponentTypeList(Tokens,Acc) -> + {ComponentType,Rest} = parse_ComponentType(Tokens), + case Rest of + [{',',_},Id = {identifier,_,_}|Rest2] -> + parse_ComponentTypeList([Id|Rest2],[ComponentType|Acc]); + [{',',_},C1={'COMPONENTS',_},C2={'OF',_}|Rest2] -> + parse_ComponentTypeList([C1,C2|Rest2],[ComponentType|Acc]); +% _ -> +% {lists:reverse([ComponentType|Acc]),Rest} + [{'}',_}|_] -> + {lists:reverse([ComponentType|Acc]),Rest}; + [{',',_},{'...',_}|_] -> + {lists:reverse([ComponentType|Acc]),Rest}; + _ -> + throw({asn1_error, + {get_line(hd(Tokens)),get(asn1_module), + [got,[get_token(hd(Rest)),get_token(hd(tl(Rest)))], + expected,['}',', identifier']]}}) + end. + + +parse_ExtensionAdditionList(Tokens) -> + parse_ExtensionAdditionList(Tokens,[]). + +parse_ExtensionAdditionList(Tokens,Acc) -> + {Element,Rest0} = + case Tokens of + [{identifier,_,_}|_Rest] -> + parse_ComponentType(Tokens); + [{'[[',_}|_] -> + parse_ExtensionAdditions(Tokens); + _ -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected, + [identifier,'[[']]}}) + end, + case Rest0 of + [{',',_}|Rest01] -> + parse_ExtensionAdditionList(Rest01,[Element|Acc]); + _ -> + {lists:reverse([Element|Acc]),Rest0} + end. + +parse_ExtensionAdditions([{'[[',_}|Rest]) -> + parse_ExtensionAdditions(Rest,[]); +parse_ExtensionAdditions(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected,'[[']}}). + +parse_ExtensionAdditions([Id = {identifier,_,_}|Rest],Acc) -> + {ComponentType, Rest2} = parse_ComponentType([Id|Rest]), + case Rest2 of + [{',',_}|Rest21] -> + parse_ExtensionAdditions(Rest21,[ComponentType|Acc]); + [{']]',_}|Rest21] -> + {lists:reverse(Acc),Rest21}; + _ -> + throw({asn1_error,{get_line(hd(Rest2)),get(asn1_module), + [got,get_token(hd(Rest2)),expected,[',',']]']]}}) + end; +parse_ExtensionAdditions(Tokens,_) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected,identifier]}}). + +parse_ComponentType([{'COMPONENTS',_},{'OF',_}|Rest]) -> + {Type,Rest2} = parse_Type(Rest), + {{'COMPONENTS OF',Type},Rest2}; +parse_ComponentType(Tokens) -> + {NamedType,Rest} = parse_NamedType(Tokens), + case Rest of + [{'OPTIONAL',_}|Rest2] -> + {NamedType#'ComponentType'{prop='OPTIONAL'},Rest2}; + [{'DEFAULT',_}|Rest2] -> + {Value,Rest21} = parse_Value(Rest2), + {NamedType#'ComponentType'{prop={'DEFAULT',Value}},Rest21}; + _ -> + {NamedType,Rest} + end. + + + +parse_SignedNumber([{number,_,Value}|Rest]) -> + {Value,Rest}; +parse_SignedNumber([{'-',_},{number,_,Value}|Rest]) -> + {-Value,Rest}; +parse_SignedNumber(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected, + [number,'-number']]}}). + +parse_Enumerations(Tokens=[{identifier,_,_}|_Rest]) -> + parse_Enumerations(Tokens,[]); +parse_Enumerations([H|_T]) -> + throw({asn1_error,{get_line(H),get(asn1_module), + [got,get_token(H),expected,identifier]}}). + +parse_Enumerations(Tokens = [{identifier,_,_},{'(',_}|_Rest], Acc) -> + {NamedNumber,Rest2} = parse_NamedNumber(Tokens), + case Rest2 of + [{',',_}|Rest3] -> + parse_Enumerations(Rest3,[NamedNumber|Acc]); + _ -> + {lists:reverse([NamedNumber|Acc]),Rest2} + end; +parse_Enumerations([{identifier,_,Id}|Rest], Acc) -> + case Rest of + [{',',_}|Rest2] -> + parse_Enumerations(Rest2,[Id|Acc]); + _ -> + {lists:reverse([Id|Acc]),Rest} + end; +parse_Enumerations([{'...',_}|Rest], Acc) -> + case Rest of + [{',',_}|Rest2] -> + parse_Enumerations(Rest2,['EXTENSIONMARK'|Acc]); + _ -> + {lists:reverse(['EXTENSIONMARK'|Acc]),Rest} + end; +parse_Enumerations([H|_T],_) -> + throw({asn1_error,{get_line(H),get(asn1_module), + [got,get_token(H),expected,identifier]}}). + +parse_NamedNumberList(Tokens) -> + parse_NamedNumberList(Tokens,[]). + +parse_NamedNumberList(Tokens,Acc) -> + {NamedNum,Rest} = parse_NamedNumber(Tokens), + case Rest of + [{',',_}|Rest2] -> + parse_NamedNumberList(Rest2,[NamedNum|Acc]); + _ -> + {lists:reverse([NamedNum|Acc]),Rest} + end. + +parse_NamedNumber([{identifier,_,Name},{'(',_}|Rest]) -> + Flist = [fun parse_SignedNumber/1, + fun parse_DefinedValue/1], + case (catch parse_or(Rest,Flist)) of + {'EXIT',Reason} -> + exit(Reason); + AsnErr = {asn1_error,_} -> + throw(AsnErr); + {NamedNum,[{')',_}|Rest2]} -> + {{'NamedNumber',Name,NamedNum},Rest2}; + _ -> + throw({asn1_error,{get_line(hd(Rest)),get(asn1_module), + [got,get_token(hd(Rest)),expected,'NamedNumberList']}}) + end; +parse_NamedNumber(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected,identifier]}}). + + +parse_Tag([{'[',_}|Rest]) -> + {Class,Rest2} = parse_Class(Rest), + {ClassNumber,Rest3} = + case Rest2 of + [{number,_,Num}|Rest21] -> + {Num,Rest21}; + _ -> + parse_DefinedValue(Rest2) + end, + case Rest3 of + [{']',_}|Rest4] -> + {#tag{class=Class,number=ClassNumber},Rest4}; + _ -> + throw({asn1_error,{get_line(hd(Rest3)),get(asn1_module), + [got,get_token(hd(Rest3)),expected,']']}}) + end; +parse_Tag(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected,'[']}}). + +parse_Class([{'UNIVERSAL',_}|Rest]) -> + {'UNIVERSAL',Rest}; +parse_Class([{'APPLICATION',_}|Rest]) -> + {'APPLICATION',Rest}; +parse_Class([{'PRIVATE',_}|Rest]) -> + {'PRIVATE',Rest}; +parse_Class(Tokens) -> + {'CONTEXT',Tokens}. + +parse_Value(Tokens) -> + Flist = [fun parse_BuiltinValue/1, + fun parse_ValueFromObject/1, + fun parse_DefinedValue/1], + + case (catch parse_or(Tokens,Flist)) of + {'EXIT',Reason} -> + exit(Reason); + AsnErr = {asn1_error,_} -> + throw(AsnErr); + Result -> + Result + end. + +parse_BuiltinValue([{bstring,_,Bstr}|Rest]) -> + {{bstring,Bstr},Rest}; +parse_BuiltinValue([{hstring,_,Hstr}|Rest]) -> + {{hstring,Hstr},Rest}; +parse_BuiltinValue([{'{',_},{'}',_}|Rest]) -> + {[],Rest}; +parse_BuiltinValue(Tokens = [{'{',_}|_Rest]) -> + Flist = [ + fun parse_SequenceOfValue/1, + fun parse_SequenceValue/1, + fun parse_ObjectIdentifierValue/1], + case (catch parse_or(Tokens,Flist)) of + {'EXIT',Reason} -> + exit(Reason); + AsnErr = {asn1_error,_} -> + throw(AsnErr); + Result -> + Result + end; +parse_BuiltinValue([{identifier,_,IdName},{':',_}|Rest]) -> + {Value,Rest2} = parse_Value(Rest), + {{'CHOICE',{IdName,Value}},Rest2}; +parse_BuiltinValue([{'NULL',_}|Rest]) -> + {'NULL',Rest}; +parse_BuiltinValue([{'TRUE',_}|Rest]) -> + {true,Rest}; +parse_BuiltinValue([{'FALSE',_}|Rest]) -> + {false,Rest}; +parse_BuiltinValue([{'PLUS-INFINITY',_}|Rest]) -> + {'PLUS-INFINITY',Rest}; +parse_BuiltinValue([{'MINUS-INFINITY',_}|Rest]) -> + {'MINUS-INFINITY',Rest}; +parse_BuiltinValue([{cstring,_,Cstr}|Rest]) -> + {Cstr,Rest}; +parse_BuiltinValue([{number,_,Num}|Rest]) -> + {Num,Rest}; +parse_BuiltinValue([{'-',_},{number,_,Num}|Rest]) -> + {- Num,Rest}; +parse_BuiltinValue(Tokens) -> + parse_ObjectClassFieldValue(Tokens). + +%% Externalvaluereference +parse_DefinedValue([{typereference,L1,Tname},{'.',_},{identifier,_,Idname}|Rest]) -> + {#'Externalvaluereference'{pos=L1,module=Tname,value=Idname},Rest}; +%% valuereference +parse_DefinedValue([Id = {identifier,_,_}|Rest]) -> + {identifier2Extvalueref(Id),Rest}; +%% ParameterizedValue +parse_DefinedValue(Tokens) -> + parse_ParameterizedValue(Tokens). + + +parse_SequenceValue([{'{',_}|Tokens]) -> + parse_SequenceValue(Tokens,[]); +parse_SequenceValue(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected,'{']}}). + +parse_SequenceValue([{identifier,_,IdName}|Rest],Acc) -> + {Value,Rest2} = parse_Value(Rest), + case Rest2 of + [{',',_}|Rest3] -> + parse_SequenceValue(Rest3,[{IdName,Value}|Acc]); + [{'}',_}|Rest3] -> + {lists:reverse([{IdName,Value}|Acc]),Rest3}; + _ -> + throw({asn1_error,{get_line(hd(Rest2)),get(asn1_module), + [got,get_token(hd(Rest2)),expected,'}']}}) + end; +parse_SequenceValue(Tokens,_Acc) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected,identifier]}}). + +parse_SequenceOfValue([{'{',_}|Tokens]) -> + parse_SequenceOfValue(Tokens,[]); +parse_SequenceOfValue(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected,'{']}}). + +parse_SequenceOfValue(Tokens,Acc) -> + {Value,Rest2} = parse_Value(Tokens), + case Rest2 of + [{',',_}|Rest3] -> + parse_SequenceOfValue(Rest3,[Value|Acc]); + [{'}',_}|Rest3] -> + {lists:reverse([Value|Acc]),Rest3}; + _ -> + throw({asn1_error,{get_line(hd(Rest2)),get(asn1_module), + [got,get_token(hd(Rest2)),expected,'}']}}) + end. + +parse_ValueSetTypeAssignment([{typereference,L1,Name}|Rest]) -> + {Type,Rest2} = parse_Type(Rest), + case Rest2 of + [{'::=',_}|Rest3] -> + {ValueSet,Rest4} = parse_ValueSet(Rest3), + {#valuedef{pos=L1,name=Name,type=Type,value=ValueSet},Rest4}; + [H|_T] -> + throw({asn1_error,{get_line(L1),get(asn1_module), + [got,get_token(H),expected,'::=']}}) + end; +parse_ValueSetTypeAssignment(Tokens) -> + throw({asn1_assignment_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected, + typereference]}}). + +parse_ValueSet([{'{',_}|Rest]) -> + {Elems,Rest2} = parse_ElementSetSpecs(Rest), + case Rest2 of + [{'}',_}|Rest3] -> + {{valueset,Elems},Rest3}; + [H|_T] -> + throw({asn1_error,{get_line(H),get(asn1_module), + [got,get_token(H),expected,'}']}}) + end; +parse_ValueSet(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected,'{']}}). + +parse_ValueAssignment([{identifier,L1,IdName}|Rest]) -> + {Type,Rest2} = parse_Type(Rest), + case Rest2 of + [{'::=',_}|Rest3] -> + {Value,Rest4} = parse_Value(Rest3), + case lookahead_assignment(Rest4) of + ok -> + {#valuedef{pos=L1,name=IdName,type=Type,value=Value},Rest4}; + _ -> + throw({asn1_error,{get_line(hd(Rest2)),get(asn1_module), + [got,get_token(hd(Rest2)),expected,'::=']}}) + end; + _ -> + throw({asn1_error,{get_line(hd(Rest2)),get(asn1_module), + [got,get_token(hd(Rest2)),expected,'::=']}}) + end; +parse_ValueAssignment(Tokens) -> + throw({asn1_assignment_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected,identifier]}}). + +%% SizeConstraint +parse_SubtypeElements([{'SIZE',_}|Tokens]) -> + {Constraint,Rest} = parse_Constraint(Tokens), + {{'SizeConstraint',Constraint#constraint.c},Rest}; +%% PermittedAlphabet +parse_SubtypeElements([{'FROM',_}|Tokens]) -> + {Constraint,Rest} = parse_Constraint(Tokens), + {{'PermittedAlphabet',Constraint#constraint.c},Rest}; +%% InnerTypeConstraints +parse_SubtypeElements([{'WITH',_},{'COMPONENT',_}|Tokens]) -> + {Constraint,Rest} = parse_Constraint(Tokens), + {{'WITH COMPONENT',Constraint},Rest}; +parse_SubtypeElements([{'WITH',_},{'COMPONENTS',_},{'{',_},{'...',_},{',',_}|Tokens]) -> + {Constraint,Rest} = parse_TypeConstraints(Tokens), + case Rest of + [{'}',_}|Rest2] -> + {{'WITH COMPONENTS',{'PartialSpecification',Constraint}},Rest2}; + _ -> + throw({asn1_error,{get_line(hd(Rest)),get(asn1_module), + [got,get_token(hd(Rest)),expected,'}']}}) + end; +parse_SubtypeElements([{'WITH',_},{'COMPONENTS',_},{'{',_}|Tokens]) -> + {Constraint,Rest} = parse_TypeConstraints(Tokens), + case Rest of + [{'}',_}|Rest2] -> + {{'WITH COMPONENTS',{'FullSpecification',Constraint}},Rest2}; + _ -> + throw({asn1_error,{get_line(hd(Rest)),get(asn1_module), + [got,get_token(hd(Rest)),expected,'}']}}) + end; +%% SingleValue +%% ContainedSubtype +%% ValueRange +%% TypeConstraint +parse_SubtypeElements(Tokens) -> + Flist = [fun parse_ContainedSubtype/1, + fun parse_Value/1, + fun([{'MIN',_}|T]) -> {'MIN',T} end, + fun parse_Type/1], + case (catch parse_or(Tokens,Flist)) of + {'EXIT',Reason} -> + exit(Reason); + {asn1_error,Reason} -> + throw(Reason); + Result = {Val,_} when record(Val,type) -> + Result; + {Lower,[{'..',_}|Rest]} -> + {Upper,Rest2} = parse_UpperEndpoint(Rest), + {{'ValueRange',{Lower,Upper}},Rest2}; + {Lower,[{'<',_},{'..',_}|Rest]} -> + {Upper,Rest2} = parse_UpperEndpoint(Rest), + {{'ValueRange',{{gt,Lower},Upper}},Rest2}; + {Res={'ContainedSubtype',_Type},Rest} -> + {Res,Rest}; + {Value,Rest} -> + {{'SingleValue',Value},Rest} + end. + +parse_ContainedSubtype([{'INCLUDES',_}|Rest]) -> + {Type,Rest2} = parse_Type(Rest), + {{'ContainedSubtype',Type},Rest2}; +parse_ContainedSubtype(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected,'INCLUDES']}}). +%%parse_ContainedSubtype(Tokens) -> %this option is moved to parse_SubtypeElements +%% parse_Type(Tokens). + +parse_UpperEndpoint([{'<',_}|Rest]) -> + parse_UpperEndpoint(lt,Rest); +parse_UpperEndpoint(Tokens) -> + parse_UpperEndpoint(false,Tokens). + +parse_UpperEndpoint(Lt,Tokens) -> + Flist = [ fun([{'MAX',_}|T]) -> {'MAX',T} end, + fun parse_Value/1], + case (catch parse_or(Tokens,Flist)) of + {'EXIT',Reason} -> + exit(Reason); + AsnErr = {asn1_error,_} -> + throw(AsnErr); + {Value,Rest2} when Lt == lt -> + {{lt,Value},Rest2}; + {Value,Rest2} -> + {Value,Rest2} + end. + +parse_TypeConstraints(Tokens) -> + parse_TypeConstraints(Tokens,[]). + +parse_TypeConstraints([{identifier,_,_}|Rest],Acc) -> + {ComponentConstraint,Rest2} = parse_ComponentConstraint(Rest), + case Rest2 of + [{',',_}|Rest3] -> + parse_TypeConstraints(Rest3,[ComponentConstraint|Acc]); + _ -> + {lists:reverse([ComponentConstraint|Acc]),Rest2} + end; +parse_TypeConstraints([H|_T],_) -> + throw({asn1_error,{get_line(H),get(asn1_module), + [got,get_token(H),expected,identifier]}}). + +parse_ComponentConstraint(Tokens = [{'(',_}|_Rest]) -> + {ValueConstraint,Rest2} = parse_Constraint(Tokens), + {PresenceConstraint,Rest3} = parse_PresenceConstraint(Rest2), + {{ValueConstraint,PresenceConstraint},Rest3}; +parse_ComponentConstraint(Tokens) -> + {PresenceConstraint,Rest} = parse_PresenceConstraint(Tokens), + {{asn1_empty,PresenceConstraint},Rest}. + +parse_PresenceConstraint([{'PRESENT',_}|Rest]) -> + {'PRESENT',Rest}; +parse_PresenceConstraint([{'ABSENT',_}|Rest]) -> + {'ABSENT',Rest}; +parse_PresenceConstraint([{'OPTIONAL',_}|Rest]) -> + {'OPTIONAL',Rest}; +parse_PresenceConstraint(Tokens) -> + {asn1_empty,Tokens}. + + +merge_constraints({Rlist,ExtList}) -> % extensionmarker in constraint + {merge_constraints(Rlist,[],[]), + merge_constraints(ExtList,[],[])}; + +merge_constraints(Clist) -> + merge_constraints(Clist, [], []). + +merge_constraints([Ch|Ct],Cacc, Eacc) -> + NewEacc = case Ch#constraint.e of + undefined -> Eacc; + E -> [E|Eacc] + end, + merge_constraints(Ct,[fixup_constraint(Ch#constraint.c)|Cacc],NewEacc); + +merge_constraints([],Cacc,[]) -> +%% lists:flatten(Cacc); + lists:reverse(Cacc); +merge_constraints([],Cacc,Eacc) -> +%% lists:flatten(Cacc) ++ [{'Errors',Eacc}]. + lists:reverse(Cacc) ++ [{'Errors',Eacc}]. + +fixup_constraint(C) -> + case C of + {'SingleValue',SubType} when element(1,SubType) == 'ContainedSubtype' -> + SubType; + {'SingleValue',V} when list(V) -> + C; + %% [C,{'ValueRange',{lists:min(V),lists:max(V)}}]; + %% bug, turns wrong when an element in V is a reference to a defined value + {'PermittedAlphabet',{'SingleValue',V}} when list(V) -> + %%sort and remove duplicates + V2 = {'SingleValue', + ordsets:list_to_set(lists:flatten(V))}, + {'PermittedAlphabet',V2}; + {'PermittedAlphabet',{'SingleValue',V}} -> + V2 = {'SingleValue',[V]}, + {'PermittedAlphabet',V2}; + {'SizeConstraint',Sc} -> + {'SizeConstraint',fixup_size_constraint(Sc)}; + + List when list(List) -> %% In This case maybe a union or intersection + [fixup_constraint(Xc)||Xc <- List]; + Other -> + Other + end. + +fixup_size_constraint({'ValueRange',{Lb,Ub}}) -> + {Lb,Ub}; +fixup_size_constraint({{'ValueRange',R},[]}) -> + {R,[]}; +fixup_size_constraint({[],{'ValueRange',R}}) -> + {[],R}; +fixup_size_constraint({{'ValueRange',R1},{'ValueRange',R2}}) -> + {R1,R2}; +fixup_size_constraint({'SingleValue',[Sv]}) -> + fixup_size_constraint({'SingleValue',Sv}); +fixup_size_constraint({'SingleValue',L}) when list(L) -> + ordsets:list_to_set(L); +fixup_size_constraint({'SingleValue',L}) -> + {L,L}; +fixup_size_constraint({C1,C2}) -> + {fixup_size_constraint(C1), fixup_size_constraint(C2)}. + +get_line({_,Pos,Token}) when integer(Pos),atom(Token) -> + Pos; +get_line({Token,Pos}) when integer(Pos),atom(Token) -> + Pos; +get_line(_) -> + undefined. + +get_token({_,Pos,Token}) when integer(Pos),atom(Token) -> + Token; +get_token({'$end',Pos}) when integer(Pos) -> + undefined; +get_token({Token,Pos}) when integer(Pos),atom(Token) -> + Token; +get_token(_) -> + undefined. + +prioritize_error(ErrList) -> + case lists:keymember(asn1_error,1,ErrList) of + false -> % only asn1_assignment_error -> take the last + lists:last(ErrList); + true -> % contains errors from deeper in a Type + NewErrList = [_Err={_,_}|_RestErr] = + lists:filter(fun({asn1_error,_})->true;(_)->false end, + ErrList), + SplitErrs = + lists:splitwith(fun({_,X})-> + case element(1,X) of + Int when integer(Int) -> true; + _ -> false + end + end, + NewErrList), + case SplitErrs of + {[],UndefPosErrs} -> % if no error with Positon exists + lists:last(UndefPosErrs); + {IntPosErrs,_} -> + IntPosReasons = lists:map(fun(X)->element(2,X) end,IntPosErrs), + SortedReasons = lists:keysort(1,IntPosReasons), + {asn1_error,lists:last(SortedReasons)} + end + end. + +%% most_prio_error([H={_,Reason}|T],Atom,Err) when atom(Atom) -> +%% most_prio_error(T,element(1,Reason),H); +%% most_prio_error([H={_,Reason}|T],Greatest,Err) -> +%% case element(1,Reason) of +%% Pos when integer(Pos),Pos>Greatest -> +%% most_prio_error( + + +tref2Exttref(#typereference{pos=Pos,val=Name}) -> + #'Externaltypereference'{pos=Pos, + module=get(asn1_module), + type=Name}. + +tref2Exttref(Pos,Name) -> + #'Externaltypereference'{pos=Pos, + module=get(asn1_module), + type=Name}. + +identifier2Extvalueref(#identifier{pos=Pos,val=Name}) -> + #'Externalvaluereference'{pos=Pos, + module=get(asn1_module), + value=Name}. + +%% lookahead_assignment/1 checks that the next sequence of tokens +%% in Token contain a valid assignment or the +%% 'END' token. Otherwise an exception is thrown. +lookahead_assignment([{'END',_}|_Rest]) -> + ok; +lookahead_assignment(Tokens) -> + parse_Assignment(Tokens), + ok. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_pretty_format.erl b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_pretty_format.erl new file mode 100644 index 0000000000..99dd246d5c --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_pretty_format.erl @@ -0,0 +1,197 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: asn1ct_pretty_format.erl,v 1.1 2008/12/17 09:53:30 mikpe Exp $ +%% + +%% usage: pretty_format:term(Term) -> PNF list of characters +%% +%% Note: this is usually used in expressions like: +%% io:format('~s\n',[pretty_format:term(Term)]). +%% +%% Uses the following simple heuristics +%% +%% 1) Simple tuples are printed across the page +%% (Simple means *all* the elements are "flat") +%% 2) The Complex tuple {Arg1, Arg2, Arg3,....} is printed thus: +%% {Arg1, +%% Arg2, +%% Arg3, +%% ...} +%% 3) Lists are treated as for tuples +%% 4) Lists of printable characters are treated as strings +%% +%% This method seems to work reasonable well for {Tag, ...} type +%% data structures + +-module(asn1ct_pretty_format). + +-export([term/1]). + +-import(io_lib, [write/1, write_string/1]). + +term(Term) -> + element(2, term(Term, 0)). + +%%______________________________________________________________________ +%% pretty_format:term(Term, Indent} -> {Indent', Chars} +%% Format <Term> -- use <Indent> to indent the *next* line +%% Note: Indent' is a new indentaion level (sometimes printing <Term> +%% the next line to need an "extra" indent!). + +term([], Indent) -> + {Indent, [$[,$]]}; +term(L, Indent) when is_list(L) -> + case is_string(L) of + true -> + {Indent, write_string(L)}; + false -> + case complex_list(L) of + true -> + write_complex_list(L, Indent); + false -> + write_simple_list(L, Indent) + end + end; +term(T, Indent) when is_tuple(T) -> + case complex_tuple(T) of + true -> + write_complex_tuple(T, Indent); + false -> + write_simple_tuple(T, Indent) + end; +term(A, Indent) -> + {Indent, write(A)}. + +%%______________________________________________________________________ +%% write_simple_list([H|T], Indent) -> {Indent', Chars} + +write_simple_list([H|T], Indent) -> + {_, S1} = term(H, Indent), + {_, S2} = write_simple_list_tail(T, Indent), + {Indent, [$[,S1|S2]}. + +write_simple_list_tail([H|T], Indent) -> + {_, S1} = term(H, Indent), + {_, S2} = write_simple_list_tail(T, Indent), + {Indent, [$,,S1| S2]}; +write_simple_list_tail([], Indent) -> + {Indent, "]"}; +write_simple_list_tail(Other, Indent) -> + {_, S} = term(Other, Indent), + {Indent, [$|,S,$]]}. + +%%______________________________________________________________________ +%% write_complex_list([H|T], Indent) -> {Indent', Chars} + +write_complex_list([H|T], Indent) -> + {I1, S1} = term(H, Indent+1), + {_, S2} = write_complex_list_tail(T, I1), + {Indent, [$[,S1|S2]}. + +write_complex_list_tail([H|T], Indent) -> + {I1, S1} = term(H, Indent), + {_, S2} = write_complex_list_tail(T, I1), + {Indent, [$,,nl_indent(Indent),S1,S2]}; +write_complex_list_tail([], Indent) -> + {Indent, "]"}; +write_complex_list_tail(Other, Indent) ->$,, + {_, S} = term(Other, Indent), + {Indent, [$|,S,$]]}. + +%%______________________________________________________________________ +%% complex_list(List) -> true | false +%% returns true if the list is complex otherwise false + +complex_list([]) -> + false; +complex_list([H|T]) when is_number(H); is_atom(H) -> + complex_list(T); +complex_list([H|T]) -> + case is_string(H) of + true -> + complex_list(T); + false -> + true + end; +complex_list(_) -> true. + +%%______________________________________________________________________ +%% complex_tuple(Tuple) -> true | false +%% returns true if the tuple is complex otherwise false + +complex_tuple(T) -> + complex_list(tuple_to_list(T)). + +%%______________________________________________________________________ +%% write_simple_tuple(Tuple, Indent} -> {Indent', Chars} + +write_simple_tuple({}, Indent) -> + {Indent, "{}"}; +write_simple_tuple(Tuple, Indent) -> + {_, S} = write_simple_tuple_args(tuple_to_list(Tuple), Indent), + {Indent, [${, S, $}]}. + +write_simple_tuple_args([X], Indent) -> + term(X, Indent); +write_simple_tuple_args([H|T], Indent) -> + {_, SH} = term(H, Indent), + {_, ST} = write_simple_tuple_args(T, Indent), + {Indent, [SH, $,, ST]}. + +%%______________________________________________________________________ +%% write_complex_tuple(Tuple, Indent} -> {Indent', Chars} + +write_complex_tuple(Tuple, Indent) -> + [H|T] = tuple_to_list(Tuple), + {I1, SH} = term(H, Indent+2), + {_, ST} = write_complex_tuple_args(T, I1), + {Indent, [${, SH, ST, $}]}. + +write_complex_tuple_args([X], Indent) -> + {_, S} = term(X, Indent), + {Indent, [$,, nl_indent(Indent), S]}; +write_complex_tuple_args([H|T], Indent) -> + {I1, SH} = term(H, Indent), + {_, ST} = write_complex_tuple_args(T, I1), + {Indent, [$,, nl_indent(Indent) , SH, ST]}; +write_complex_tuple_args([], Indent) -> + {Indent, []}. + +%%______________________________________________________________________ +%% utilities + +nl_indent(I) when I >= 0 -> + ["\n"|indent(I)]; +nl_indent(_) -> + [$\s]. + +indent(I) when I >= 8 -> + [$\t|indent(I-8)]; +indent(I) when I > 0 -> + [$\s|indent(I-1)]; +indent(_) -> + []. + +is_string([9|T]) -> + is_string(T); +is_string([10|T]) -> + is_string(T); +is_string([H|T]) when H >31, H < 127 -> + is_string(T); +is_string([]) -> + true; +is_string(_) -> + false. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_tok.erl b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_tok.erl new file mode 100644 index 0000000000..b5ccc4a5d2 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_tok.erl @@ -0,0 +1,351 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: asn1ct_tok.erl,v 1.1 2008/12/17 09:53:30 mikpe Exp $ +%% +-module(asn1ct_tok). + +%% Tokenize ASN.1 code (input to parser generated with yecc) + +-export([get_name/2,tokenise/2, file/1]). + + +file(File) -> + case file:open(File, [read]) of + {error, Reason} -> + {error,{File,file:format_error(Reason)}}; + {ok,Stream} -> + process0(Stream) + end. + +process0(Stream) -> + process(Stream,0,[]). + +process(Stream,Lno,R) -> + process(io:get_line(Stream, ''), Stream,Lno+1,R). + +process(eof, Stream,Lno,R) -> + file:close(Stream), + lists:flatten(lists:reverse([{'$end',Lno}|R])); + + +process(L, Stream,Lno,R) when list(L) -> + %%io:format('read:~s',[L]), + case catch tokenise(L,Lno) of + {'ERR',Reason} -> + io:format("Tokeniser error on line: ~w ~w~n",[Lno,Reason]), + exit(0); + T -> + %%io:format('toks:~w~n',[T]), + process(Stream,Lno,[T|R]) + end. + + +tokenise([H|T],Lno) when $a =< H , H =< $z -> + {X, T1} = get_name(T, [H]), + [{identifier,Lno, list_to_atom(X)}|tokenise(T1,Lno)]; + +tokenise([$&,H|T],Lno) when $A =< H , H =< $Z -> + {Y, T1} = get_name(T, [H]), + X = list_to_atom(Y), + [{typefieldreference, Lno, X} | tokenise(T1, Lno)]; + +tokenise([$&,H|T],Lno) when $a =< H , H =< $z -> + {Y, T1} = get_name(T, [H]), + X = list_to_atom(Y), + [{valuefieldreference, Lno, X} | tokenise(T1, Lno)]; + +tokenise([H|T],Lno) when $A =< H , H =< $Z -> + {Y, T1} = get_name(T, [H]), + X = list_to_atom(Y), + case reserved_word(X) of + true -> + [{X,Lno}|tokenise(T1,Lno)]; + false -> + [{typereference,Lno,X}|tokenise(T1,Lno)]; + rstrtype -> + [{restrictedcharacterstringtype,Lno,X}|tokenise(T1,Lno)] + end; + +tokenise([$-,H|T],Lno) when $0 =< H , H =< $9 -> + {X, T1} = get_number(T, [H]), + [{number,Lno,-1 * list_to_integer(X)}|tokenise(T1,Lno)]; + +tokenise([H|T],Lno) when $0 =< H , H =< $9 -> + {X, T1} = get_number(T, [H]), + [{number,Lno,list_to_integer(X)}|tokenise(T1,Lno)]; + +tokenise([$-,$-|T],Lno) -> + tokenise(skip_comment(T),Lno); +tokenise([$:,$:,$=|T],Lno) -> + [{'::=',Lno}|tokenise(T,Lno)]; + +tokenise([$'|T],Lno) -> + case catch collect_quoted(T,Lno,[]) of + {'ERR',_} -> + throw({'ERR','bad_quote'}); + {Thing, T1} -> + [Thing|tokenise(T1,Lno)] + end; + +tokenise([$"|T],Lno) -> + collect_string(T,Lno); + +tokenise([${|T],Lno) -> + [{'{',Lno}|tokenise(T,Lno)]; + +tokenise([$}|T],Lno) -> + [{'}',Lno}|tokenise(T,Lno)]; + +tokenise([$]|T],Lno) -> + [{']',Lno}|tokenise(T,Lno)]; + +tokenise([$[|T],Lno) -> + [{'[',Lno}|tokenise(T,Lno)]; + +tokenise([$,|T],Lno) -> + [{',',Lno}|tokenise(T,Lno)]; + +tokenise([$(|T],Lno) -> + [{'(',Lno}|tokenise(T,Lno)]; +tokenise([$)|T],Lno) -> + [{')',Lno}|tokenise(T,Lno)]; + +tokenise([$.,$.,$.|T],Lno) -> + [{'...',Lno}|tokenise(T,Lno)]; + +tokenise([$.,$.|T],Lno) -> + [{'..',Lno}|tokenise(T,Lno)]; + +tokenise([$.|T],Lno) -> + [{'.',Lno}|tokenise(T,Lno)]; +tokenise([$^|T],Lno) -> + [{'^',Lno}|tokenise(T,Lno)]; +tokenise([$!|T],Lno) -> + [{'!',Lno}|tokenise(T,Lno)]; +tokenise([$||T],Lno) -> + [{'|',Lno}|tokenise(T,Lno)]; + + +tokenise([H|T],Lno) -> + case white_space(H) of + true -> + tokenise(T,Lno); + false -> + [{list_to_atom([H]),Lno}|tokenise(T,Lno)] + end; +tokenise([],_) -> + []. + + +collect_string(L,Lno) -> + collect_string(L,Lno,[]). + +collect_string([],_,_) -> + throw({'ERR','bad_quote found eof'}); + +collect_string([H|T],Lno,Str) -> + case H of + $" -> + [{cstring,1,lists:reverse(Str)}|tokenise(T,Lno)]; + Ch -> + collect_string(T,Lno,[Ch|Str]) + end. + + + +% <name> is letters digits hyphens +% hypen is not the last character. Hypen hyphen is NOT allowed +% +% <identifier> ::= <lowercase> <name> + +get_name([$-,Char|T], L) -> + case isalnum(Char) of + true -> + get_name(T,[Char,$-|L]); + false -> + {lists:reverse(L),[$-,Char|T]} + end; +get_name([$-|T], L) -> + {lists:reverse(L),[$-|T]}; +get_name([Char|T], L) -> + case isalnum(Char) of + true -> + get_name(T,[Char|L]); + false -> + {lists:reverse(L),[Char|T]} + end; +get_name([], L) -> + {lists:reverse(L), []}. + + +isalnum(H) when $A =< H , H =< $Z -> + true; +isalnum(H) when $a =< H , H =< $z -> + true; +isalnum(H) when $0 =< H , H =< $9 -> + true; +isalnum(_) -> + false. + +isdigit(H) when $0 =< H , H =< $9 -> + true; +isdigit(_) -> + false. + +white_space(9) -> true; +white_space(10) -> true; +white_space(13) -> true; +white_space(32) -> true; +white_space(_) -> false. + + +get_number([H|T], L) -> + case isdigit(H) of + true -> + get_number(T, [H|L]); + false -> + {lists:reverse(L), [H|T]} + end; +get_number([], L) -> + {lists:reverse(L), []}. + +skip_comment([]) -> + []; +skip_comment([$-,$-|T]) -> + T; +skip_comment([_|T]) -> + skip_comment(T). + +collect_quoted([$',$B|T],Lno, L) -> + case check_bin(L) of + true -> + {{bstring,Lno, lists:reverse(L)}, T}; + false -> + throw({'ERR',{invalid_binary_number, lists:reverse(L)}}) + end; +collect_quoted([$',$H|T],Lno, L) -> + case check_hex(L) of + true -> + {{hstring,Lno, lists:reverse(L)}, T}; + false -> + throw({'ERR',{invalid_binary_number, lists:reverse(L)}}) + end; +collect_quoted([H|T], Lno, L) -> + collect_quoted(T, Lno,[H|L]); +collect_quoted([], _, _) -> % This should be allowed FIX later + throw({'ERR',{eol_in_token}}). + +check_bin([$0|T]) -> + check_bin(T); +check_bin([$1|T]) -> + check_bin(T); +check_bin([]) -> + true; +check_bin(_) -> + false. + +check_hex([H|T]) when $0 =< H , H =< $9 -> + check_hex(T); +check_hex([H|T]) when $A =< H , H =< $F -> + check_hex(T); +check_hex([]) -> + true; +check_hex(_) -> + false. + + +%% reserved_word(A) -> true|false|rstrtype +%% A = atom() +%% returns true if A is a reserved ASN.1 word +%% returns false if A is not a reserved word +%% returns rstrtype if A is a reserved word in the group +%% RestrictedCharacterStringType +reserved_word('ABSENT') -> true; +%reserved_word('ABSTRACT-SYNTAX') -> true; % impl as predef item +reserved_word('ALL') -> true; +reserved_word('ANY') -> true; +reserved_word('APPLICATION') -> true; +reserved_word('AUTOMATIC') -> true; +reserved_word('BEGIN') -> true; +reserved_word('BIT') -> true; +reserved_word('BMPString') -> rstrtype; +reserved_word('BOOLEAN') -> true; +reserved_word('BY') -> true; +reserved_word('CHARACTER') -> true; +reserved_word('CHOICE') -> true; +reserved_word('CLASS') -> true; +reserved_word('COMPONENT') -> true; +reserved_word('COMPONENTS') -> true; +reserved_word('CONSTRAINED') -> true; +reserved_word('DEFAULT') -> true; +reserved_word('DEFINED') -> true; +reserved_word('DEFINITIONS') -> true; +reserved_word('EMBEDDED') -> true; +reserved_word('END') -> true; +reserved_word('ENUMERATED') -> true; +reserved_word('EXCEPT') -> true; +reserved_word('EXPLICIT') -> true; +reserved_word('EXPORTS') -> true; +reserved_word('EXTERNAL') -> true; +reserved_word('FALSE') -> true; +reserved_word('FROM') -> true; +reserved_word('GeneralizedTime') -> true; +reserved_word('GeneralString') -> rstrtype; +reserved_word('GraphicString') -> rstrtype; +reserved_word('IA5String') -> rstrtype; +% reserved_word('TYPE-IDENTIFIER') -> true; % impl as predef item +reserved_word('IDENTIFIER') -> true; +reserved_word('IMPLICIT') -> true; +reserved_word('IMPORTS') -> true; +reserved_word('INCLUDES') -> true; +reserved_word('INSTANCE') -> true; +reserved_word('INTEGER') -> true; +reserved_word('INTERSECTION') -> true; +reserved_word('ISO646String') -> rstrtype; +reserved_word('MAX') -> true; +reserved_word('MIN') -> true; +reserved_word('MINUS-INFINITY') -> true; +reserved_word('NULL') -> true; +reserved_word('NumericString') -> rstrtype; +reserved_word('OBJECT') -> true; +reserved_word('ObjectDescriptor') -> true; +reserved_word('OCTET') -> true; +reserved_word('OF') -> true; +reserved_word('OPTIONAL') -> true; +reserved_word('PDV') -> true; +reserved_word('PLUS-INFINITY') -> true; +reserved_word('PRESENT') -> true; +reserved_word('PrintableString') -> rstrtype; +reserved_word('PRIVATE') -> true; +reserved_word('REAL') -> true; +reserved_word('SEQUENCE') -> true; +reserved_word('SET') -> true; +reserved_word('SIZE') -> true; +reserved_word('STRING') -> true; +reserved_word('SYNTAX') -> true; +reserved_word('T61String') -> rstrtype; +reserved_word('TAGS') -> true; +reserved_word('TeletexString') -> rstrtype; +reserved_word('TRUE') -> true; +reserved_word('UNION') -> true; +reserved_word('UNIQUE') -> true; +reserved_word('UNIVERSAL') -> true; +reserved_word('UniversalString') -> rstrtype; +reserved_word('UTCTime') -> true; +reserved_word('VideotexString') -> rstrtype; +reserved_word('VisibleString') -> rstrtype; +reserved_word('WITH') -> true; +reserved_word(_) -> false. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_value.erl b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_value.erl new file mode 100644 index 0000000000..3d366a1a27 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_value.erl @@ -0,0 +1,330 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: asn1ct_value.erl,v 1.1 2008/12/17 09:53:30 mikpe Exp $ +%% +-module(asn1ct_value). + +%% Generate Erlang values for ASN.1 types. +%% The value is randomized within it's constraints + +-include("asn1_records.hrl"). +%-compile(export_all). + +-export([get_type/3]). + + + +%% Generate examples of values ****************************** +%%****************************************x + + +get_type(M,Typename,Tellname) -> + case asn1_db:dbget(M,Typename) of + undefined -> + {asn1_error,{not_found,{M,Typename}}}; + Tdef when record(Tdef,typedef) -> + Type = Tdef#typedef.typespec, + get_type(M,[Typename],Type,Tellname); + Err -> + {asn1_error,{other,Err}} + end. + +get_type(M,Typename,Type,Tellname) when record(Type,type) -> + InnerType = get_inner(Type#type.def), + case asn1ct_gen:type(InnerType) of + #'Externaltypereference'{module=Emod,type=Etype} -> + get_type(Emod,Etype,Tellname); + {_,user} -> + case Tellname of + yes -> {Typename,get_type(M,InnerType,no)}; + no -> get_type(M,InnerType,no) + end; + {notype,_} -> + true; + {primitive,bif} -> + get_type_prim(Type); + 'ASN1_OPEN_TYPE' -> + case Type#type.constraint of + [#'Externaltypereference'{type=TrefConstraint}] -> + get_type(M,TrefConstraint,no); + _ -> + "open_type" + end; + {constructed,bif} -> + get_type_constructed(M,Typename,InnerType,Type) + end; +get_type(M,Typename,#'ComponentType'{name = Name,typespec = Type},_) -> + get_type(M,[Name|Typename],Type,no); +get_type(_,_,_,_) -> % 'EXTENSIONMARK' + undefined. + +get_inner(A) when atom(A) -> A; +get_inner(Ext) when record(Ext,'Externaltypereference') -> Ext; +get_inner({typereference,_Pos,Name}) -> Name; +get_inner(T) when tuple(T) -> + case asn1ct_gen:get_inner(T) of + {fixedtypevaluefield,_,Type} -> + Type#type.def; + {typefield,_FieldName} -> + 'ASN1_OPEN_TYPE'; + Other -> + Other + end. +%%get_inner(T) when tuple(T) -> element(1,T). + + + +get_type_constructed(M,Typename,InnerType,D) when record(D,type) -> + case InnerType of + 'SET' -> + get_sequence(M,Typename,D); + 'SEQUENCE' -> + get_sequence(M,Typename,D); + 'CHOICE' -> + get_choice(M,Typename,D); + 'SEQUENCE OF' -> + {_,Type} = D#type.def, + NameSuffix = asn1ct_gen:constructed_suffix(InnerType,Type#type.def), + get_sequence_of(M,Typename,D,NameSuffix); + 'SET OF' -> + {_,Type} = D#type.def, + NameSuffix = asn1ct_gen:constructed_suffix(InnerType,Type#type.def), + get_sequence_of(M,Typename,D,NameSuffix); + _ -> + exit({nyi,InnerType}) + end. + +get_sequence(M,Typename,Type) -> + {_SEQorSET,CompList} = + case Type#type.def of + #'SEQUENCE'{components=Cl} -> {'SEQUENCE',Cl}; + #'SET'{components=Cl} -> {'SET',Cl} + end, + case get_components(M,Typename,CompList) of + [] -> + {list_to_atom(asn1ct_gen:list2rname(Typename))}; + C -> + list_to_tuple([list_to_atom(asn1ct_gen:list2rname(Typename))|C]) + end. + +get_components(M,Typename,{Root,Ext}) -> + get_components(M,Typename,Root++Ext); + +%% Should enhance this *** HERE *** with proper handling of extensions + +get_components(M,Typename,[H|T]) -> + [get_type(M,Typename,H,no)| + get_components(M,Typename,T)]; +get_components(_,_,[]) -> + []. + +get_choice(M,Typename,Type) -> + {'CHOICE',TCompList} = Type#type.def, + case TCompList of + [] -> + {asn1_EMPTY,asn1_EMPTY}; + {CompList,ExtList} -> % Should be enhanced to handle extensions too + CList = CompList ++ ExtList, + C = lists:nth(random(length(CList)),CList), + {C#'ComponentType'.name,get_type(M,Typename,C,no)}; + CompList when list(CompList) -> + C = lists:nth(random(length(CompList)),CompList), + {C#'ComponentType'.name,get_type(M,Typename,C,no)} + end. + +get_sequence_of(M,Typename,Type,TypeSuffix) -> + %% should generate length according to constraints later + {_,Oftype} = Type#type.def, + C = Type#type.constraint, + S = size_random(C), + NewTypeName = [TypeSuffix|Typename], + gen_list(M,NewTypeName,Oftype,no,S). + +gen_list(_,_,_,_,0) -> + []; +gen_list(M,Typename,Oftype,Tellname,N) -> + [get_type(M,Typename,Oftype,no)|gen_list(M,Typename,Oftype,Tellname,N-1)]. + +get_type_prim(D) -> + C = D#type.constraint, + case D#type.def of + 'INTEGER' -> + i_random(C); + {'INTEGER',NamedNumberList} -> + NN = [X||{X,_} <- NamedNumberList], + case NN of + [] -> + i_random(C); + _ -> + lists:nth(random(length(NN)),NN) + end; + Enum when tuple(Enum),element(1,Enum)=='ENUMERATED' -> + NamedNumberList = + case Enum of + {_,_,NNL} -> NNL; + {_,NNL} -> NNL + end, + NNew= + case NamedNumberList of + {N1,N2} -> + N1 ++ N2; + _-> + NamedNumberList + end, + NN = [X||{X,_} <- NNew], + case NN of + [] -> + asn1_EMPTY; + _ -> + lists:nth(random(length(NN)),NN) + end; + {'BIT STRING',NamedNumberList} -> +%% io:format("get_type_prim 1: ~w~n",[NamedNumberList]), + NN = [X||{X,_} <- NamedNumberList], + case NN of + [] -> + Bl1 =lists:reverse(adjust_list(size_random(C),[1,0,1,1])), + lists:reverse(lists:dropwhile(fun(0)->true;(1)->false end,Bl1)); + _ -> +%% io:format("get_type_prim 2: ~w~n",[NN]), + [lists:nth(random(length(NN)),NN)] + end; + 'ANY' -> + exit({asn1_error,nyi,'ANY'}); + 'NULL' -> + 'NULL'; + 'OBJECT IDENTIFIER' -> + Len = random(3), + Olist = [(random(1000)-1)||_X <-lists:seq(1,Len)], + list_to_tuple([random(3)-1,random(40)-1|Olist]); + 'ObjectDescriptor' -> + object_descriptor_nyi; + 'BOOLEAN' -> + true; + 'OCTET STRING' -> + adjust_list(size_random(C),c_string(C,"OCTET STRING")); + 'NumericString' -> + adjust_list(size_random(C),c_string(C,"0123456789")); + 'TeletexString' -> + adjust_list(size_random(C),c_string(C,"TeletexString")); + 'VideotexString' -> + adjust_list(size_random(C),c_string(C,"VideotexString")); + 'UTCTime' -> + "97100211-0500"; + 'GeneralizedTime' -> + "19971002103130.5"; + 'GraphicString' -> + adjust_list(size_random(C),c_string(C,"GraphicString")); + 'VisibleString' -> + adjust_list(size_random(C),c_string(C,"VisibleString")); + 'GeneralString' -> + adjust_list(size_random(C),c_string(C,"GeneralString")); + 'PrintableString' -> + adjust_list(size_random(C),c_string(C,"PrintableString")); + 'IA5String' -> + adjust_list(size_random(C),c_string(C,"IA5String")); + 'BMPString' -> + adjust_list(size_random(C),c_string(C,"BMPString")); + 'UniversalString' -> + adjust_list(size_random(C),c_string(C,"UniversalString")); + XX -> + exit({asn1_error,nyi,XX}) + end. + +c_string(undefined,Default) -> + Default; +c_string(C,Default) -> + case get_constraint(C,'PermittedAlphabet') of + {'SingleValue',Sv} when list(Sv) -> + Sv; + {'SingleValue',V} when integer(V) -> + [V]; + no -> + Default + end. + +random(Upper) -> + {A1,A2,A3} = erlang:now(), + random:seed(A1,A2,A3), + random:uniform(Upper). + +size_random(C) -> + case get_constraint(C,'SizeConstraint') of + no -> + c_random({0,5},no); + {Lb,Ub} when Ub-Lb =< 4 -> + c_random({Lb,Ub},no); + {Lb,_} -> + c_random({Lb,Lb+4},no); + Sv -> + c_random(no,Sv) + end. + +i_random(C) -> + c_random(get_constraint(C,'ValueRange'),get_constraint(C,'SingleValue')). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% c_random(Range,SingleValue) +%% only called from other X_random functions + +c_random(VRange,Single) -> + case {VRange,Single} of + {no,no} -> + random(16#fffffff) - (16#fffffff bsr 1); + {R,no} -> + case R of + {Lb,Ub} when integer(Lb),integer(Ub) -> + Range = Ub - Lb +1, + Lb + (random(Range)-1); + {Lb,'MAX'} -> + Lb + random(16#fffffff)-1; + {'MIN',Ub} -> + Ub - random(16#fffffff)-1; + {A,{'ASN1_OK',B}} -> + Range = B - A +1, + A + (random(Range)-1) + end; + {_,S} when integer(S) -> + S; + {_,S} when list(S) -> + lists:nth(random(length(S)),S) +%% {S1,S2} -> +%% io:format("asn1ct_value: hejsan hoppsan~n"); +%% _ -> +%% io:format("asn1ct_value: hejsan hoppsan 2~n") +%% io:format("asn1ct_value: c_random/2: S1 = ~w~n" +%% "S2 = ~w,~n",[S1,S2]) +%% exit(self(),goodbye) + end. + +adjust_list(Len,Orig) -> + adjust_list1(Len,Orig,Orig,[]). + +adjust_list1(0,_Orig,[_Oh|_Ot],Acc) -> + lists:reverse(Acc); +adjust_list1(Len,Orig,[],Acc) -> + adjust_list1(Len,Orig,Orig,Acc); +adjust_list1(Len,Orig,[Oh|Ot],Acc) -> + adjust_list1(Len-1,Orig,Ot,[Oh|Acc]). + + +get_constraint(C,Key) -> + case lists:keysearch(Key,1,C) of + false -> + no; + {value,{_,V}} -> + V + end. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt.erl b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt.erl new file mode 100644 index 0000000000..efac8daf6b --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt.erl @@ -0,0 +1,69 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: asn1rt.erl,v 1.1 2008/12/17 09:53:30 mikpe Exp $ +%% +-module(asn1rt). + +%% Runtime functions for ASN.1 (i.e encode, decode) + +-export([encode/2,encode/3,decode/3,load_driver/0,unload_driver/0,info/1]). + +encode(Module,{Type,Term}) -> + encode(Module,Type,Term). + +encode(Module,Type,Term) -> + case catch apply(Module,encode,[Type,Term]) of + {'EXIT',undef} -> + {error,{asn1,{undef,Module,Type}}}; + Result -> + Result + end. + +decode(Module,Type,Bytes) -> + case catch apply(Module,decode,[Type,Bytes]) of + {'EXIT',undef} -> + {error,{asn1,{undef,Module,Type}}}; + Result -> + Result + end. + +load_driver() -> + asn1rt_driver_handler:load_driver(), + receive + driver_ready -> + ok; + Err={error,_Reason} -> + Err; + Error -> + {error,Error} + end. + +unload_driver() -> + case catch asn1rt_driver_handler:unload_driver() of + ok -> + ok; + Error -> + {error,Error} + end. + + +info(Module) -> + case catch apply(Module,info,[]) of + {'EXIT',{undef,_Reason}} -> + {error,{asn1,{undef,Module,info}}}; + Result -> + {ok,Result} + end. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_ber_bin.erl b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_ber_bin.erl new file mode 100644 index 0000000000..6064515a7e --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_ber_bin.erl @@ -0,0 +1,2310 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: asn1rt_ber_bin.erl,v 1.1 2008/12/17 09:53:30 mikpe Exp $ +%% +-module(asn1rt_ber_bin). + +%% encoding / decoding of BER + +-export([decode/1]). +-export([fixoptionals/2,split_list/2,cindex/3,restbytes2/3, + list_to_record/2, + encode_tag_val/1,decode_tag/1,peek_tag/1, + check_tags/3, encode_tags/3]). +-export([encode_boolean/2,decode_boolean/3, + encode_integer/3,encode_integer/4, + decode_integer/4,decode_integer/5,encode_enumerated/2, + encode_enumerated/4,decode_enumerated/5, + encode_real/2,decode_real/4, + encode_bit_string/4,decode_bit_string/6, + decode_compact_bit_string/6, + encode_octet_string/3,decode_octet_string/5, + encode_null/2,decode_null/3, + encode_object_identifier/2,decode_object_identifier/3, + encode_restricted_string/4,decode_restricted_string/6, + encode_universal_string/3,decode_universal_string/5, + encode_BMP_string/3,decode_BMP_string/5, + encode_generalized_time/3,decode_generalized_time/5, + encode_utc_time/3,decode_utc_time/5, + encode_length/1,decode_length/1, + check_if_valid_tag/3, + decode_tag_and_length/1, decode_components/6, + decode_components/7, decode_set/6]). + +-export([encode_open_type/1,encode_open_type/2,decode_open_type/1,decode_open_type/2,decode_open_type/3]). +-export([skipvalue/1, skipvalue/2]). + +-include("asn1_records.hrl"). + +% the encoding of class of tag bits 8 and 7 +-define(UNIVERSAL, 0). +-define(APPLICATION, 16#40). +-define(CONTEXT, 16#80). +-define(PRIVATE, 16#C0). + +%%% primitive or constructed encoding % bit 6 +-define(PRIMITIVE, 0). +-define(CONSTRUCTED, 2#00100000). + +%%% The tag-number for universal types +-define(N_BOOLEAN, 1). +-define(N_INTEGER, 2). +-define(N_BIT_STRING, 3). +-define(N_OCTET_STRING, 4). +-define(N_NULL, 5). +-define(N_OBJECT_IDENTIFIER, 6). +-define(N_OBJECT_DESCRIPTOR, 7). +-define(N_EXTERNAL, 8). +-define(N_REAL, 9). +-define(N_ENUMERATED, 10). +-define(N_EMBEDDED_PDV, 11). +-define(N_SEQUENCE, 16). +-define(N_SET, 17). +-define(N_NumericString, 18). +-define(N_PrintableString, 19). +-define(N_TeletexString, 20). +-define(N_VideotexString, 21). +-define(N_IA5String, 22). +-define(N_UTCTime, 23). +-define(N_GeneralizedTime, 24). +-define(N_GraphicString, 25). +-define(N_VisibleString, 26). +-define(N_GeneralString, 27). +-define(N_UniversalString, 28). +-define(N_BMPString, 30). + + +% the complete tag-word of built-in types +-define(T_BOOLEAN, ?UNIVERSAL bor ?PRIMITIVE bor 1). +-define(T_INTEGER, ?UNIVERSAL bor ?PRIMITIVE bor 2). +-define(T_BIT_STRING, ?UNIVERSAL bor ?PRIMITIVE bor 3). % can be CONSTRUCTED +-define(T_OCTET_STRING, ?UNIVERSAL bor ?PRIMITIVE bor 4). % can be CONSTRUCTED +-define(T_NULL, ?UNIVERSAL bor ?PRIMITIVE bor 5). +-define(T_OBJECT_IDENTIFIER,?UNIVERSAL bor ?PRIMITIVE bor 6). +-define(T_OBJECT_DESCRIPTOR,?UNIVERSAL bor ?PRIMITIVE bor 7). +-define(T_EXTERNAL, ?UNIVERSAL bor ?PRIMITIVE bor 8). +-define(T_REAL, ?UNIVERSAL bor ?PRIMITIVE bor 9). +-define(T_ENUMERATED, ?UNIVERSAL bor ?PRIMITIVE bor 10). +-define(T_EMBEDDED_PDV, ?UNIVERSAL bor ?PRIMITIVE bor 11). +-define(T_SEQUENCE, ?UNIVERSAL bor ?CONSTRUCTED bor 16). +-define(T_SET, ?UNIVERSAL bor ?CONSTRUCTED bor 17). +-define(T_NumericString, ?UNIVERSAL bor ?PRIMITIVE bor 18). %can be constructed +-define(T_PrintableString, ?UNIVERSAL bor ?PRIMITIVE bor 19). %can be constructed +-define(T_TeletexString, ?UNIVERSAL bor ?PRIMITIVE bor 20). %can be constructed +-define(T_VideotexString, ?UNIVERSAL bor ?PRIMITIVE bor 21). %can be constructed +-define(T_IA5String, ?UNIVERSAL bor ?PRIMITIVE bor 22). %can be constructed +-define(T_UTCTime, ?UNIVERSAL bor ?PRIMITIVE bor 23). +-define(T_GeneralizedTime, ?UNIVERSAL bor ?PRIMITIVE bor 24). +-define(T_GraphicString, ?UNIVERSAL bor ?PRIMITIVE bor 25). %can be constructed +-define(T_VisibleString, ?UNIVERSAL bor ?PRIMITIVE bor 26). %can be constructed +-define(T_GeneralString, ?UNIVERSAL bor ?PRIMITIVE bor 27). %can be constructed +-define(T_UniversalString, ?UNIVERSAL bor ?PRIMITIVE bor 28). %can be constructed +-define(T_BMPString, ?UNIVERSAL bor ?PRIMITIVE bor 30). %can be constructed + + +decode(Bin) -> + decode_primitive(Bin). + +decode_primitive(Bin) -> + {Tlv = {Tag,Len,V},<<>>} = decode_tlv(Bin), + case element(2,Tag) of + ?CONSTRUCTED -> + {Tag,Len,decode_constructed(V)}; + _ -> + Tlv + end. + +decode_constructed(<<>>) -> + []; +decode_constructed(Bin) -> + {Tlv = {Tag,Len,V},Rest} = decode_tlv(Bin), + NewTlv = + case element(2,Tag) of + ?CONSTRUCTED -> + {Tag,Len,decode_constructed(V)}; + _ -> + Tlv + end, + [NewTlv|decode_constructed(Rest)]. + +decode_tlv(Bin) -> + {Tag,Bin1,_Rb1} = decode_tag(Bin), + {{Len,Bin2},_Rb2} = decode_length(Bin1), + <<V:Len/binary,Bin3/binary>> = Bin2, + {{Tag,Len,V},Bin3}. + + + +%%%%%%%%%%%%% +% split_list(List,HeadLen) -> {HeadList,TailList} +% +% splits List into HeadList (Length=HeadLen) and TailList +% if HeadLen == indefinite -> return {List,indefinite} +split_list(List,indefinite) -> + {List, indefinite}; +split_list(Bin, Len) when binary(Bin) -> + split_binary(Bin,Len); +split_list(List,Len) -> + {lists:sublist(List,Len),lists:nthtail(Len,List)}. + + +%%% new function which fixes a bug regarding indefinite length decoding +restbytes2(indefinite,<<0,0,RemBytes/binary>>,_) -> + {RemBytes,2}; +restbytes2(indefinite,RemBytes,ext) -> + skipvalue(indefinite,RemBytes); +restbytes2(RemBytes,<<>>,_) -> + {RemBytes,0}; +restbytes2(_RemBytes,Bytes,noext) -> + exit({error,{asn1, {unexpected,Bytes}}}); +restbytes2(RemBytes,_Bytes,ext) -> + {RemBytes,0}. + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% skipvalue(Length, Bytes) -> {RemainingBytes, RemovedNumberOfBytes} +%% +%% skips the one complete (could be nested) TLV from Bytes +%% handles both definite and indefinite length encodings +%% + +skipvalue(L, Bytes) -> + skipvalue(L, Bytes, 0). + +skipvalue(indefinite, Bytes, Rb) -> + {_T,Bytes2,R2} = decode_tag(Bytes), + {{L,Bytes3},R3} = decode_length(Bytes2), + {Bytes4,Rb4} = case L of + indefinite -> + skipvalue(indefinite,Bytes3,R2+R3); + _ -> + <<_:L/binary, RestBytes/binary>> = Bytes3, + {RestBytes, R2+R3+L} + end, + case Bytes4 of + <<0,0,Bytes5/binary>> -> + {Bytes5,Rb+Rb4+2}; + _ -> skipvalue(indefinite,Bytes4,Rb+Rb4) + end; +skipvalue(L, Bytes, Rb) -> +% <<Skip:L/binary, RestBytes/binary>> = Bytes, + <<_:L/binary, RestBytes/binary>> = Bytes, + {RestBytes,Rb+L}. + +%%skipvalue(indefinite, Bytes, Rb) -> +%% {T,Bytes2,R2} = decode_tag(Bytes), +%% {L,Bytes3,R3} = decode_length(Bytes2), +%% {Bytes4,Rb4} = case L of +%% indefinite -> +%% skipvalue(indefinite,Bytes3,R2+R3); +%% _ -> +%% lists:nthtail(L,Bytes3) %% konstigt !? +%% end, +%% case Bytes4 of +%% [0,0|Bytes5] -> +%% {Bytes5,Rb4+2}; +%% _ -> skipvalue(indefinite,Bytes4,Rb4) +%% end; +%%skipvalue(L, Bytes, Rb) -> +%% {lists:nthtail(L,Bytes),Rb+L}. + +skipvalue(Bytes) -> + {_T,Bytes2,R2} = decode_tag(Bytes), + {{L,Bytes3},R3} = decode_length(Bytes2), + skipvalue(L,Bytes3,R2+R3). + + +cindex(Ix,Val,Cname) -> + case element(Ix,Val) of + {Cname,Val2} -> Val2; + X -> X + end. + +%%=============================================================================== +%%=============================================================================== +%%=============================================================================== +%% Optionals, preset not filled optionals with asn1_NOVALUE +%%=============================================================================== +%%=============================================================================== +%%=============================================================================== + +% converts a list to a record if necessary +list_to_record(Name,List) when list(List) -> + list_to_tuple([Name|List]); +list_to_record(_Name,Tuple) when tuple(Tuple) -> + Tuple. + + +fixoptionals(OptList,Val) when list(Val) -> + fixoptionals(OptList,Val,1,[],[]). + +fixoptionals([{Name,Pos}|Ot],[{Name,Val}|Vt],_Opt,Acc1,Acc2) -> + fixoptionals(Ot,Vt,Pos+1,[1|Acc1],[{Name,Val}|Acc2]); +fixoptionals([{_Name,Pos}|Ot],V,Pos,Acc1,Acc2) -> + fixoptionals(Ot,V,Pos+1,[0|Acc1],[asn1_NOVALUE|Acc2]); +fixoptionals(O,[Vh|Vt],Pos,Acc1,Acc2) -> + fixoptionals(O,Vt,Pos+1,Acc1,[Vh|Acc2]); +fixoptionals([],[Vh|Vt],Pos,Acc1,Acc2) -> + fixoptionals([],Vt,Pos+1,Acc1,[Vh|Acc2]); +fixoptionals([],[],_,_Acc1,Acc2) -> + % return Val as a record + list_to_tuple([asn1_RECORDNAME|lists:reverse(Acc2)]). + + +%%encode_tag(TagClass(?UNI, APP etc), Form (?PRIM etx), TagInteger) -> +%% 8bit Int | binary +encode_tag_val({Class, Form, TagNo}) when (TagNo =< 30) -> + <<(Class bsr 6):2,(Form bsr 5):1,TagNo:5>>; + +encode_tag_val({Class, Form, TagNo}) -> + {Octets,_Len} = mk_object_val(TagNo), + BinOct = list_to_binary(Octets), + <<(Class bsr 6):2, (Form bsr 5):1, 31:5,BinOct/binary>>; + +%% asumes whole correct tag bitpattern, multiple of 8 +encode_tag_val(Tag) when (Tag =< 255) -> Tag; %% anv�nds denna funktion??!! +%% asumes correct bitpattern of 0-5 +encode_tag_val(Tag) -> encode_tag_val2(Tag,[]). + +encode_tag_val2(Tag, OctAck) when (Tag =< 255) -> + [Tag | OctAck]; +encode_tag_val2(Tag, OctAck) -> + encode_tag_val2(Tag bsr 8, [255 band Tag | OctAck]). + + +%%%encode_tag(TagClass(?UNI, APP etc), Form (?PRIM etx), TagInteger) -> +%%% 8bit Int | [list of octets] +%encode_tag_val({Class, Form, TagNo}) when (TagNo =< 30) -> +%%% <<Class:2,Form:1,TagNo:5>>; +% [Class bor Form bor TagNo]; +%encode_tag_val({Class, Form, TagNo}) -> +% {Octets,L} = mk_object_val(TagNo), +% [Class bor Form bor 31 | Octets]; + + +%%============================================================================\%% Peek on the initial tag +%% peek_tag(Bytes) -> TagBytes +%% interprets the first byte and possible second, third and fourth byte as +%% a tag and returns all the bytes comprising the tag, the constructed/primitive bit (6:th bit of first byte) is normalised to 0 +%% + +peek_tag(<<B7_6:2,_:1,31:5,Buffer/binary>>) -> + Bin = peek_tag(Buffer, <<>>), + <<B7_6:2,31:6,Bin/binary>>; +%% single tag (tagno < 31) +peek_tag(<<B7_6:2,_:1,B4_0:5,_Buffer/binary>>) -> + <<B7_6:2,B4_0:6>>. + +peek_tag(<<0:1,PartialTag:7,_Buffer/binary>>, TagAck) -> + <<TagAck/binary,PartialTag>>; +peek_tag(<<PartialTag,Buffer/binary>>, TagAck) -> + peek_tag(Buffer,<<TagAck/binary,PartialTag>>); +peek_tag(_,TagAck) -> + exit({error,{asn1, {invalid_tag,TagAck}}}). +%%peek_tag([Tag|Buffer]) when (Tag band 31) == 31 -> +%% [Tag band 2#11011111 | peek_tag(Buffer,[])]; +%%%% single tag (tagno < 31) +%%peek_tag([Tag|Buffer]) -> +%% [Tag band 2#11011111]. + +%%peek_tag([PartialTag|Buffer], TagAck) when (PartialTag < 128 ) -> +%% lists:reverse([PartialTag|TagAck]); +%%peek_tag([PartialTag|Buffer], TagAck) -> +%% peek_tag(Buffer,[PartialTag|TagAck]); +%%peek_tag(Buffer,TagAck) -> +%% exit({error,{asn1, {invalid_tag,lists:reverse(TagAck)}}}). + + +%%=============================================================================== +%% Decode a tag +%% +%% decode_tag(OctetListBuffer) -> {{Class, Form, TagNo}, RestOfBuffer, RemovedBytes} +%%=============================================================================== + +%% multiple octet tag +decode_tag(<<Class:2, Form:1, 31:5, Buffer/binary>>) -> + {TagNo, Buffer1, RemovedBytes} = decode_tag(Buffer, 0, 1), + {{(Class bsl 6), (Form bsl 5), TagNo}, Buffer1, RemovedBytes}; + +%% single tag (< 31 tags) +decode_tag(<<Class:2,Form:1,TagNo:5, Buffer/binary>>) -> + {{(Class bsl 6), (Form bsl 5), TagNo}, Buffer, 1}. + +%% last partial tag +decode_tag(<<0:1,PartialTag:7, Buffer/binary>>, TagAck, RemovedBytes) -> + TagNo = (TagAck bsl 7) bor PartialTag, + %%<<TagNo>> = <<TagAck:1, PartialTag:7>>, + {TagNo, Buffer, RemovedBytes+1}; +% more tags +decode_tag(<<_:1,PartialTag:7, Buffer/binary>>, TagAck, RemovedBytes) -> + TagAck1 = (TagAck bsl 7) bor PartialTag, + %%<<TagAck1:16>> = <<TagAck:1, PartialTag:7,0:8>>, + decode_tag(Buffer, TagAck1, RemovedBytes+1). + +%%------------------------------------------------------------------ +%% check_tags_i is the same as check_tags except that it stops and +%% returns the remaining tags not checked when it encounters an +%% indefinite length field +%% only called internally within this module + +check_tags_i([Tag], Buffer, OptOrMand) -> % optimized very usual case + {[],check_one_tag(Tag, Buffer, OptOrMand)}; +check_tags_i(Tags, Buffer, OptOrMand) -> + check_tags_i(Tags, Buffer, 0, OptOrMand). + +check_tags_i([Tag1,Tag2|TagRest], Buffer, Rb, OptOrMand) + when Tag1#tag.type == 'IMPLICIT' -> + check_tags_i([Tag1#tag{type=Tag2#tag.type}|TagRest], Buffer, Rb, OptOrMand); + +check_tags_i([Tag1|TagRest], Buffer, Rb, OptOrMand) -> + {Form_Length,Buffer2,Rb1} = check_one_tag(Tag1, Buffer, OptOrMand), + case TagRest of + [] -> {TagRest, {Form_Length, Buffer2, Rb + Rb1}}; + _ -> + case Form_Length of + {?CONSTRUCTED,_} -> + {TagRest, {Form_Length, Buffer2, Rb + Rb1}}; + _ -> + check_tags_i(TagRest, Buffer2, Rb + Rb1, mandatory) + end + end; + +check_tags_i([], Buffer, Rb, _) -> + {[],{{0,0},Buffer,Rb}}. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% This function is called from generated code + +check_tags([Tag], Buffer, OptOrMand) -> % optimized very usual case + check_one_tag(Tag, Buffer, OptOrMand); +check_tags(Tags, Buffer, OptOrMand) -> + check_tags(Tags, Buffer, 0, OptOrMand). + +check_tags([Tag1,Tag2|TagRest], Buffer, Rb, OptOrMand) + when Tag1#tag.type == 'IMPLICIT' -> + check_tags([Tag1#tag{type=Tag2#tag.type}|TagRest], Buffer, Rb, OptOrMand); + +check_tags([Tag1|TagRest], Buffer, Rb, OptOrMand) -> + {Form_Length,Buffer2,Rb1} = check_one_tag(Tag1, Buffer, OptOrMand), + case TagRest of + [] -> {Form_Length, Buffer2, Rb + Rb1}; + _ -> check_tags(TagRest, Buffer2, Rb + Rb1, mandatory) + end; + +check_tags([], Buffer, Rb, _) -> + {{0,0},Buffer,Rb}. + +check_one_tag(Tag=#tag{class=ExpectedClass,number=ExpectedNumber}, Buffer, OptOrMand) -> + case catch decode_tag(Buffer) of + {'EXIT',_Reason} -> + tag_error(no_data,Tag,Buffer,OptOrMand); + {{ExpectedClass,Form,ExpectedNumber},Buffer2,Rb} -> + {{L,Buffer3},RemBytes2} = decode_length(Buffer2), + {{Form,L}, Buffer3, RemBytes2+Rb}; + {ErrorTag,_,_} -> + tag_error(ErrorTag, Tag, Buffer, OptOrMand) + end. + +tag_error(ErrorTag, Tag, Buffer, OptOrMand) -> + case OptOrMand of + mandatory -> + exit({error,{asn1, {invalid_tag, + {ErrorTag, Tag, Buffer}}}}); + _ -> + exit({error,{asn1, {no_optional_tag, + {ErrorTag, Tag, Buffer}}}}) + end. +%%======================================================================= +%% +%% Encode all tags in the list Tags and return a possibly deep list of +%% bytes with tag and length encoded +%% +%% prepend_tags(Tags, BytesSoFar, LenSoFar) -> {Bytes, Len} +encode_tags(Tags, BytesSoFar, LenSoFar) -> + NewTags = encode_tags1(Tags, []), + %% NewTags contains the resulting tags in reverse order + encode_tags2(NewTags, BytesSoFar, LenSoFar). + +%encode_tags2([#tag{class=?UNIVERSAL,number=No}|Trest], BytesSoFar, LenSoFar) -> +% {Bytes2,L2} = encode_length(LenSoFar), +% encode_tags2(Trest,[[No|Bytes2],BytesSoFar], LenSoFar + 1 + L2); +encode_tags2([Tag|Trest], BytesSoFar, LenSoFar) -> + {Bytes1,L1} = encode_one_tag(Tag), + {Bytes2,L2} = encode_length(LenSoFar), + encode_tags2(Trest, [Bytes1,Bytes2|BytesSoFar], + LenSoFar + L1 + L2); +encode_tags2([], BytesSoFar, LenSoFar) -> + {BytesSoFar,LenSoFar}. + +encode_tags1([Tag1, Tag2| Trest], Acc) + when Tag1#tag.type == 'IMPLICIT' -> + encode_tags1([Tag1#tag{type=Tag2#tag.type,form=Tag2#tag.form}|Trest],Acc); +encode_tags1([Tag1 | Trest], Acc) -> + encode_tags1(Trest, [Tag1|Acc]); +encode_tags1([], Acc) -> + Acc. % the resulting tags are returned in reverse order + +encode_one_tag(Bin) when binary(Bin) -> + {Bin,size(Bin)}; +encode_one_tag(#tag{class=Class,number=No,type=Type, form = Form}) -> + NewForm = case Type of + 'EXPLICIT' -> + ?CONSTRUCTED; + _ -> + Form + end, + Bytes = encode_tag_val({Class,NewForm,No}), + {Bytes,size(Bytes)}. + +%%=============================================================================== +%% Change the tag (used when an implicit tagged type has a reference to something else) +%% The constructed bit in the tag is taken from the tag to be replaced. +%% +%% change_tag(NewTag,[Tag,Buffer]) -> [NewTag,Buffer] +%%=============================================================================== + +%change_tag({NewClass,NewTagNr}, Buffer) -> +% {{OldClass, OldForm, OldTagNo}, Buffer1, RemovedBytes} = decode_tag(lists:flatten(Buffer)), +% [encode_tag_val({NewClass, OldForm, NewTagNr}) | Buffer1]. + + + + + + + +%%=============================================================================== +%% +%% This comment is valid for all the encode/decode functions +%% +%% C = Constraint -> typically {'ValueRange',LowerBound,UpperBound} +%% used for PER-coding but not for BER-coding. +%% +%% Val = Value. If Val is an atom then it is a symbolic integer value +%% (i.e the atom must be one of the names in the NamedNumberList). +%% The NamedNumberList is used to translate the atom to an integer value +%% before encoding. +%% +%%=============================================================================== + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% encode_open_type(Value) -> CompleteList +%% Value = list of bytes of an already encoded value (the list must be flat) +%% | binary + +%% This version does not consider Explicit tagging of the open type. It +%% is only left because of backward compatibility. +encode_open_type(Val) when list(Val) -> + {Val,size(list_to_binary(Val))}; +encode_open_type(Val) -> + {Val, size(Val)}. + +%% +encode_open_type(Val, []) when list(Val) -> + {Val,size(list_to_binary(Val))}; +encode_open_type(Val,[]) -> + {Val, size(Val)}; +encode_open_type(Val, Tag) when list(Val) -> + encode_tags(Tag,Val,size(list_to_binary(Val))); +encode_open_type(Val,Tag) -> + encode_tags(Tag,Val, size(Val)). + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% decode_open_type(Buffer) -> Value +%% Bytes = [byte] with BER encoded data +%% Value = [byte] with decoded data (which must be decoded again as some type) +%% +decode_open_type(Bytes) -> + {_Tag, Len, _RemainingBuffer, RemovedBytes} = decode_tag_and_length(Bytes), + N = Len + RemovedBytes, + <<Val:N/binary, RemainingBytes/binary>> = Bytes, + {Val, RemainingBytes, Len + RemovedBytes}. + +decode_open_type(Bytes,ExplTag) -> + {Tag, Len, RemainingBuffer, RemovedBytes} = decode_tag_and_length(Bytes), + case {Tag,ExplTag} of + {{Class,Form,No},[#tag{class=Class,number=No,form=Form}]} -> + {_Tag2, Len2, _RemainingBuffer2, RemovedBytes2} = decode_tag_and_length(RemainingBuffer), + N = Len2 + RemovedBytes2, + <<_:RemovedBytes/unit:8,Val:N/binary,RemainingBytes/binary>> = Bytes, + {Val, RemainingBytes, N + RemovedBytes}; + _ -> + N = Len + RemovedBytes, + <<Val:N/binary, RemainingBytes/binary>> = Bytes, + {Val, RemainingBytes, Len + RemovedBytes} + end. + +decode_open_type(ber_bin,Bytes,ExplTag) -> + decode_open_type(Bytes,ExplTag); +decode_open_type(ber,Bytes,ExplTag) -> + {Val,RemBytes,Len}=decode_open_type(Bytes,ExplTag), + {binary_to_list(Val),RemBytes,Len}. + +%%=============================================================================== +%%=============================================================================== +%%=============================================================================== +%% Boolean, ITU_T X.690 Chapter 8.2 +%%=============================================================================== +%%=============================================================================== +%%=============================================================================== + +%%=============================================================================== +%% encode_boolean(Integer, tag | notag) -> [octet list] +%%=============================================================================== + +encode_boolean({Name, Val}, DoTag) when atom(Name) -> + dotag(DoTag, ?N_BOOLEAN, encode_boolean(Val)); +encode_boolean(true,[]) -> + {[1,1,16#FF],3}; +encode_boolean(false,[]) -> + {[1,1,0],3}; +encode_boolean(Val, DoTag) -> + dotag(DoTag, ?N_BOOLEAN, encode_boolean(Val)). + +%% encode_boolean(Boolean) -> [Len, Boolean] = [1, $FF | 0] +encode_boolean(true) -> {[16#FF],1}; +encode_boolean(false) -> {[0],1}; +encode_boolean(X) -> exit({error,{asn1, {encode_boolean, X}}}). + + +%%=============================================================================== +%% decode_boolean(BuffList, HasTag, TotalLen) -> {true, Remain, RemovedBytes} | +%% {false, Remain, RemovedBytes} +%%=============================================================================== + +decode_boolean(Buffer, Tags, OptOrMand) -> + NewTags = new_tags(Tags,#tag{class=?UNIVERSAL,number=?N_BOOLEAN}), + decode_boolean_notag(Buffer, NewTags, OptOrMand). + +decode_boolean_notag(Buffer, Tags, OptOrMand) -> + {RestTags, {FormLen,Buffer0,Rb0}} = + check_tags_i(Tags, Buffer, OptOrMand), + case FormLen of + {?CONSTRUCTED,Len} -> + {Buffer00,RestBytes} = split_list(Buffer0,Len), + {Val,Buffer1,Rb1} = decode_boolean_notag(Buffer00, RestTags, OptOrMand), + {Buffer2, Rb2} = restbytes2(RestBytes,Buffer1,noext), + {Val, Buffer2, Rb0+Rb1+Rb2}; + {_,_} -> + decode_boolean2(Buffer0, Rb0) + end. + +decode_boolean2(<<0:8, Buffer/binary>>, RemovedBytes) -> + {false, Buffer, RemovedBytes + 1}; +decode_boolean2(<<_:8, Buffer/binary>>, RemovedBytes) -> + {true, Buffer, RemovedBytes + 1}; +decode_boolean2(Buffer, _) -> + exit({error,{asn1, {decode_boolean, Buffer}}}). + + + + +%%=========================================================================== +%% Integer, ITU_T X.690 Chapter 8.3 + +%% encode_integer(Constraint, Value, Tag) -> [octet list] +%% encode_integer(Constraint, Name, NamedNumberList, Tag) -> [octet list] +%% Value = INTEGER | {Name,INTEGER} +%% Tag = tag | notag +%%=========================================================================== + +encode_integer(C, Val, []) when integer(Val) -> + {EncVal,Len}=encode_integer(C, Val), + dotag_universal(?N_INTEGER,EncVal,Len); +encode_integer(C, Val, Tag) when integer(Val) -> + dotag(Tag, ?N_INTEGER, encode_integer(C, Val)); +encode_integer(C,{Name,Val},Tag) when atom(Name) -> + encode_integer(C,Val,Tag); +encode_integer(_, Val, _) -> + exit({error,{asn1, {encode_integer, Val}}}). + + + +encode_integer(C, Val, NamedNumberList, Tag) when atom(Val) -> + case lists:keysearch(Val, 1, NamedNumberList) of + {value,{_, NewVal}} -> + dotag(Tag, ?N_INTEGER, encode_integer(C, NewVal)); + _ -> + exit({error,{asn1, {encode_integer_namednumber, Val}}}) + end; +encode_integer(C,{_,Val},NamedNumberList,Tag) -> + encode_integer(C,Val,NamedNumberList,Tag); +encode_integer(C, Val, _NamedNumberList, Tag) -> + dotag(Tag, ?N_INTEGER, encode_integer(C, Val)). + + + + +encode_integer(_C, Val) -> + Bytes = + if + Val >= 0 -> + encode_integer_pos(Val, []); + true -> + encode_integer_neg(Val, []) + end, + {Bytes,length(Bytes)}. + +encode_integer_pos(0, L=[B|_Acc]) when B < 128 -> + L; +encode_integer_pos(N, Acc) -> + encode_integer_pos((N bsr 8), [N band 16#ff| Acc]). + +encode_integer_neg(-1, L=[B1|_T]) when B1 > 127 -> + L; +encode_integer_neg(N, Acc) -> + encode_integer_neg(N bsr 8, [N band 16#ff|Acc]). + +%%=============================================================================== +%% decode integer +%% (Buffer, Range, HasTag, TotalLen) -> {Integer, Remain, RemovedBytes} +%% (Buffer, Range, NamedNumberList, HasTag, TotalLen) -> {Integer, Remain, RemovedBytes} +%%=============================================================================== + + +decode_integer(Buffer, Range, Tags, OptOrMand) -> + NewTags = new_tags(Tags,#tag{class=?UNIVERSAL,number=?N_INTEGER}), + decode_integer_notag(Buffer, Range, [], NewTags, OptOrMand). + +decode_integer(Buffer, Range, NamedNumberList, Tags, OptOrMand) -> + NewTags = new_tags(Tags,#tag{class=?UNIVERSAL,number=?N_INTEGER}), + decode_integer_notag(Buffer, Range, NamedNumberList, NewTags, OptOrMand). + +decode_integer_notag(Buffer, Range, NamedNumberList, NewTags, OptOrMand) -> + {RestTags, {FormLen, Buffer0, Rb0}} = + check_tags_i(NewTags, Buffer, OptOrMand), +% Result = {Val, Buffer2, RemovedBytes} = + case FormLen of + {?CONSTRUCTED,Len} -> + {Buffer00, RestBytes} = split_list(Buffer0,Len), + {Val01, Buffer01, Rb01} = + decode_integer_notag(Buffer00, Range, NamedNumberList, + RestTags, OptOrMand), + {Buffer02, Rb02} = restbytes2(RestBytes,Buffer01,noext), + {Val01, Buffer02, Rb0+Rb01+Rb02}; + {_, Len} -> + Result = + decode_integer2(Len,Buffer0,Rb0+Len), + Result2 = check_integer_constraint(Result,Range), + resolve_named_value(Result2,NamedNumberList) + end. + +resolve_named_value(Result={Val,Buffer,RemBytes},NamedNumberList) -> + case NamedNumberList of + [] -> Result; + _ -> + NewVal = case lists:keysearch(Val, 2, NamedNumberList) of + {value,{NamedVal, _}} -> + NamedVal; + _ -> + Val + end, + {NewVal, Buffer, RemBytes} + end. + +check_integer_constraint(Result={Val, _Buffer,_},Range) -> + case Range of + [] -> % No length constraint + Result; + {Lb,Ub} when Val >= Lb, Ub >= Val -> % variable length constraint + Result; + Val -> % fixed value constraint + Result; + {_,_} -> + exit({error,{asn1,{integer_range,Range,Val}}}); + SingleValue when integer(SingleValue) -> + exit({error,{asn1,{integer_range,Range,Val}}}); + _ -> % some strange constraint that we don't support yet + Result + end. + +%%============================================================================ +%% Enumerated value, ITU_T X.690 Chapter 8.4 + +%% encode enumerated value +%%============================================================================ +encode_enumerated(Val, []) when integer(Val)-> + {EncVal,Len} = encode_integer(false,Val), + dotag_universal(?N_ENUMERATED,EncVal,Len); +encode_enumerated(Val, DoTag) when integer(Val)-> + dotag(DoTag, ?N_ENUMERATED, encode_integer(false,Val)); +encode_enumerated({Name,Val}, DoTag) when atom(Name) -> + encode_enumerated(Val, DoTag). + +%% The encode_enumerated functions below this line can be removed when the +%% new code generation is stable. (the functions might have to be kept here +%% a while longer for compatibility reasons) + +encode_enumerated(C, Val, {NamedNumberList,ExtList}, DoTag) when atom(Val) -> + case catch encode_enumerated(C, Val, NamedNumberList, DoTag) of + {'EXIT',_} -> encode_enumerated(C, Val, ExtList, DoTag); + Result -> Result + end; + +encode_enumerated(C, Val, NamedNumberList, DoTag) when atom(Val) -> + case lists:keysearch(Val, 1, NamedNumberList) of + {value, {_, NewVal}} when DoTag == []-> + {EncVal,Len} = encode_integer(C,NewVal), + dotag_universal(?N_ENUMERATED,EncVal,Len); + {value, {_, NewVal}} -> + dotag(DoTag, ?N_ENUMERATED, encode_integer(C, NewVal)); + _ -> + exit({error,{asn1, {enumerated_not_in_range, Val}}}) + end; + +encode_enumerated(C, {asn1_enum, Val}, {_,_}, DoTag) when integer(Val) -> + dotag(DoTag, ?N_ENUMERATED, encode_integer(C,Val)); + +encode_enumerated(C, {Name,Val}, NamedNumberList, DoTag) when atom(Name) -> + encode_enumerated(C, Val, NamedNumberList, DoTag); + +encode_enumerated(_, Val, _, _) -> + exit({error,{asn1, {enumerated_not_namednumber, Val}}}). + + + +%%============================================================================ +%% decode enumerated value +%% (Buffer, Range, NamedNumberList, HasTag, TotalLen) -> +%% {Value, RemainingBuffer, RemovedBytes} +%%=========================================================================== +decode_enumerated(Buffer, Range, NamedNumberList, Tags, OptOrMand) -> + NewTags = new_tags(Tags,#tag{class=?UNIVERSAL,number=?N_ENUMERATED}), + decode_enumerated_notag(Buffer, Range, NamedNumberList, + NewTags, OptOrMand). + +decode_enumerated_notag(Buffer, Range, NNList = {NamedNumberList,ExtList}, Tags, OptOrMand) -> + {RestTags, {FormLen, Buffer0, Rb0}} = + check_tags_i(Tags, Buffer, OptOrMand), + + case FormLen of + {?CONSTRUCTED,Len} -> + {Buffer00,RestBytes} = split_list(Buffer0,Len), + {Val01, Buffer01, Rb01} = + decode_enumerated_notag(Buffer00, Range, NNList, RestTags, OptOrMand), + {Buffer02, Rb02} = restbytes2(RestBytes,Buffer01,noext), + {Val01, Buffer02, Rb0+Rb01+Rb02}; + {_,Len} -> + {Val01, Buffer01, Rb01} = + decode_integer2(Len, Buffer0, Rb0+Len), + case decode_enumerated1(Val01, NamedNumberList) of + {asn1_enum,Val01} -> + {decode_enumerated1(Val01,ExtList), Buffer01, Rb01}; + Result01 -> + {Result01, Buffer01, Rb01} + end + end; + +decode_enumerated_notag(Buffer, Range, NNList, Tags, OptOrMand) -> + {RestTags, {FormLen, Buffer0, Rb0}} = + check_tags_i(Tags, Buffer, OptOrMand), + + case FormLen of + {?CONSTRUCTED,Len} -> + {Buffer00,RestBytes} = split_list(Buffer0,Len), + {Val01, Buffer01, Rb01} = + decode_enumerated_notag(Buffer00, Range, NNList, RestTags, OptOrMand), + {Buffer02, Rb02} = restbytes2(RestBytes,Buffer01,noext), + {Val01, Buffer02, Rb0+Rb01+Rb02}; + {_,Len} -> + {Val01, Buffer02, Rb02} = + decode_integer2(Len, Buffer0, Rb0+Len), + case decode_enumerated1(Val01, NNList) of + {asn1_enum,_} -> + exit({error,{asn1, {illegal_enumerated, Val01}}}); + Result01 -> + {Result01, Buffer02, Rb02} + end + end. + +decode_enumerated1(Val, NamedNumberList) -> + %% it must be a named integer + case lists:keysearch(Val, 2, NamedNumberList) of + {value,{NamedVal, _}} -> + NamedVal; + _ -> + {asn1_enum,Val} + end. + + +%%============================================================================ +%% +%% Real value, ITU_T X.690 Chapter 8.5 +%%============================================================================ +%% +%% encode real value +%%============================================================================ + +%% only base 2 internally so far!! +encode_real(0, DoTag) -> + dotag(DoTag, ?N_REAL, {[],0}); +encode_real('PLUS-INFINITY', DoTag) -> + dotag(DoTag, ?N_REAL, {[64],1}); +encode_real('MINUS-INFINITY', DoTag) -> + dotag(DoTag, ?N_REAL, {[65],1}); +encode_real(Val, DoTag) when tuple(Val)-> + dotag(DoTag, ?N_REAL, encode_real(Val)). + +%%%%%%%%%%%%%% +%% not optimal efficient.. +%% only base 2 of Mantissa encoding! +%% only base 2 of ExpBase encoding! +encode_real({Man, Base, Exp}) -> +%% io:format("Mantissa: ~w Base: ~w, Exp: ~w~n",[Man, Base, Exp]), + + OctExp = if Exp >= 0 -> list_to_binary(encode_integer_pos(Exp, [])); + true -> list_to_binary(encode_integer_neg(Exp, [])) + end, +%% ok = io:format("OctExp: ~w~n",[OctExp]), + SignBit = if Man > 0 -> 0; % bit 7 is pos or neg, no Zeroval + true -> 1 + end, +%% ok = io:format("SignBitMask: ~w~n",[SignBitMask]), + InBase = if Base =:= 2 -> 0; % bit 6,5: only base 2 this far! + true -> + exit({error,{asn1, {encode_real_non_supported_encodeing, Base}}}) + end, + SFactor = 0, % bit 4,3: no scaling since only base 2 + OctExpLen = size(OctExp), + if OctExpLen > 255 -> + exit({error,{asn1, {to_big_exp_in_encode_real, OctExpLen}}}); + true -> true %% make real assert later.. + end, + {LenCode, EOctets} = case OctExpLen of % bit 2,1 + 1 -> {0, OctExp}; + 2 -> {1, OctExp}; + 3 -> {2, OctExp}; + _ -> {3, <<OctExpLen, OctExp/binary>>} + end, + FirstOctet = <<1:1,SignBit:1,InBase:2,SFactor:2,LenCode:2>>, + OctMantissa = if Man > 0 -> list_to_binary(minimum_octets(Man)); + true -> list_to_binary(minimum_octets(-(Man))) % signbit keeps track of sign + end, + %% ok = io:format("LenMask: ~w EOctets: ~w~nFirstOctet: ~w OctMantissa: ~w OctExpLen: ~w~n", [LenMask, EOctets, FirstOctet, OctMantissa, OctExpLen]), + Bin = <<FirstOctet/binary, EOctets/binary, OctMantissa/binary>>, + {Bin, size(Bin)}. + + +%encode_real({Man, Base, Exp}) -> +%% io:format("Mantissa: ~w Base: ~w, Exp: ~w~n",[Man, Base, Exp]), + +% OctExp = if Exp >= 0 -> encode_integer_pos(Exp, []); +% true -> encode_integer_neg(Exp, []) +% end, +%% ok = io:format("OctExp: ~w~n",[OctExp]), +% SignBitMask = if Man > 0 -> 2#00000000; % bit 7 is pos or neg, no Zeroval +% true -> 2#01000000 +% end, +%% ok = io:format("SignBitMask: ~w~n",[SignBitMask]), +% InternalBaseMask = if Base =:= 2 -> 2#00000000; % bit 6,5: only base 2 this far! +% true -> +% exit({error,{asn1, {encode_real_non_supported_encodeing, Base}}}) +% end, +% ScalingFactorMask =2#00000000, % bit 4,3: no scaling since only base 2 +% OctExpLen = length(OctExp), +% if OctExpLen > 255 -> +% exit({error,{asn1, {to_big_exp_in_encode_real, OctExpLen}}}); +% true -> true %% make real assert later.. +% end, +% {LenMask, EOctets} = case OctExpLen of % bit 2,1 +% 1 -> {0, OctExp}; +% 2 -> {1, OctExp}; +% 3 -> {2, OctExp}; +% _ -> {3, [OctExpLen, OctExp]} +% end, +% FirstOctet = (SignBitMask bor InternalBaseMask bor +% ScalingFactorMask bor LenMask bor +% 2#10000000), % bit set for binary mantissa encoding! +% OctMantissa = if Man > 0 -> minimum_octets(Man); +% true -> minimum_octets(-(Man)) % signbit keeps track of sign +% end, +%% ok = io:format("LenMask: ~w EOctets: ~w~nFirstOctet: ~w OctMantissa: ~w OctExpLen: ~w~n", [LenMask, EOctets, FirstOctet, OctMantissa, OctExpLen]), +% {[FirstOctet, EOctets, OctMantissa], +% length(OctMantissa) + +% (if OctExpLen > 3 -> +% OctExpLen + 2; +% true -> +% OctExpLen + 1 +% end) +% }. + + +%%============================================================================ +%% decode real value +%% +%% decode_real([OctetBufferList], tuple|value, tag|notag) -> +%% {{Mantissa, Base, Exp} | realval | PLUS-INFINITY | MINUS-INFINITY | 0, +%% RestBuff} +%% +%% only for base 2 decoding sofar!! +%%============================================================================ + +decode_real(Buffer, Form, Tags, OptOrMand) -> + NewTags = new_tags(Tags,#tag{class=?UNIVERSAL,number=?N_REAL}), + decode_real_notag(Buffer, Form, NewTags, OptOrMand). + +decode_real_notag(Buffer, Form, Tags, OptOrMand) -> + {RestTags, {FormLen, Buffer0, Rb0}} = + check_tags_i(Tags, Buffer, OptOrMand), + + case FormLen of + {?CONSTRUCTED,Len} -> + {Buffer00,RestBytes} = split_list(Buffer0,Len), + {Val01, Buffer01, Rb01} = + decode_real_notag(Buffer00, Form, RestTags, OptOrMand), + {Buffer02, Rb02} = restbytes2(RestBytes,Buffer01,noext), + {Val01, Buffer02, Rb0+Rb01+Rb02}; + {_,Len} -> + decode_real2(Buffer0, Form, Len, Rb0) + end. + +decode_real2(Buffer0, Form, Len, RemBytes1) -> + <<First, Buffer2/binary>> = Buffer0, + if + First =:= 2#01000000 -> {'PLUS-INFINITY', Buffer2}; + First =:= 2#01000001 -> {'MINUS-INFINITY', Buffer2}; + First =:= 2#00000000 -> {0, Buffer2}; + true -> + %% have some check here to verify only supported bases (2) + <<_B7:1,B6:1,B5_4:2,B3_2:2,B1_0:2>> = <<First>>, + Sign = B6, + Base = + case B5_4 of + 0 -> 2; % base 2, only one so far + _ -> exit({error,{asn1, {non_supported_base, First}}}) + end, +% ScalingFactor = + case B3_2 of + 0 -> 0; % no scaling so far + _ -> exit({error,{asn1, {non_supported_scaling, First}}}) + end, + % ok = io:format("Buffer2: ~w~n",[Buffer2]), + {FirstLen, {Exp, Buffer3}, RemBytes2} = + case B1_0 of + 0 -> {2, decode_integer2(1, Buffer2, RemBytes1), RemBytes1+1}; + 1 -> {3, decode_integer2(2, Buffer2, RemBytes1), RemBytes1+2}; + 2 -> {4, decode_integer2(3, Buffer2, RemBytes1), RemBytes1+3}; + 3 -> + <<ExpLen1,RestBuffer/binary>> = Buffer2, + { ExpLen1 + 2, + decode_integer2(ExpLen1, RestBuffer, RemBytes1), + RemBytes1+ExpLen1} + end, + % io:format("FirstLen: ~w, Exp: ~w, Buffer3: ~w ~n", + % [FirstLen, Exp, Buffer3]), + Length = Len - FirstLen, + <<LongInt:Length/unit:8,RestBuff/binary>> = Buffer3, + {{Mantissa, Buffer4}, RemBytes3} = + if Sign =:= 0 -> + % io:format("sign plus~n"), + {{LongInt, RestBuff}, 1 + Length}; + true -> + % io:format("sign minus~n"), + {{-LongInt, RestBuff}, 1 + Length} + end, + % io:format("Form: ~w~n",[Form]), + case Form of + tuple -> + {Val,Buf,_RemB} = Exp, + {{Mantissa, Base, {Val,Buf}}, Buffer4, RemBytes2+RemBytes3}; + _value -> + comming + end + end. + + +%%============================================================================ +%% Bitstring value, ITU_T X.690 Chapter 8.6 +%% +%% encode bitstring value +%% +%% bitstring NamedBitList +%% Val can be of: +%% - [identifiers] where only named identifers are set to one, +%% the Constraint must then have some information of the +%% bitlength. +%% - [list of ones and zeroes] all bits +%% - integer value representing the bitlist +%% C is constrint Len, only valid when identifiers +%%============================================================================ + +encode_bit_string(C,Bin={Unused,BinBits},NamedBitList,DoTag) when integer(Unused), binary(BinBits) -> + encode_bin_bit_string(C,Bin,NamedBitList,DoTag); +encode_bit_string(C, [FirstVal | RestVal], NamedBitList, DoTag) when atom(FirstVal) -> + encode_bit_string_named(C, [FirstVal | RestVal], NamedBitList, DoTag); + +encode_bit_string(C, [{bit,X} | RestVal], NamedBitList, DoTag) -> + encode_bit_string_named(C, [{bit,X} | RestVal], NamedBitList, DoTag); + +encode_bit_string(C, [FirstVal| RestVal], NamedBitList, DoTag) when integer(FirstVal) -> + encode_bit_string_bits(C, [FirstVal | RestVal], NamedBitList, DoTag); + +encode_bit_string(_, 0, _, []) -> + {[?N_BIT_STRING,1,0],3}; + +encode_bit_string(_, 0, _, DoTag) -> + dotag(DoTag, ?N_BIT_STRING, {<<0>>,1}); + +encode_bit_string(_, [], _, []) -> + {[?N_BIT_STRING,1,0],3}; + +encode_bit_string(_, [], _, DoTag) -> + dotag(DoTag, ?N_BIT_STRING, {<<0>>,1}); + +encode_bit_string(C, IntegerVal, NamedBitList, DoTag) when integer(IntegerVal) -> + BitListVal = int_to_bitlist(IntegerVal), + encode_bit_string_bits(C, BitListVal, NamedBitList, DoTag); + +encode_bit_string(C, {Name,BitList}, NamedBitList, DoTag) when atom(Name) -> + encode_bit_string(C, BitList, NamedBitList, DoTag). + + + +int_to_bitlist(0) -> + []; +int_to_bitlist(Int) when integer(Int), Int >= 0 -> + [Int band 1 | int_to_bitlist(Int bsr 1)]. + + +%%================================================================= +%% Encode BIT STRING of the form {Unused,BinBits}. +%% Unused is the number of unused bits in the last byte in BinBits +%% and BinBits is a binary representing the BIT STRING. +%%================================================================= +encode_bin_bit_string(C,{Unused,BinBits},_NamedBitList,DoTag)-> + case get_constraint(C,'SizeConstraint') of + no -> + remove_unused_then_dotag(DoTag,?N_BIT_STRING,Unused,BinBits); + {_Min,Max} -> + BBLen = (size(BinBits)*8)-Unused, + if + BBLen > Max -> + exit({error,{asn1, + {bitstring_length, + {{was,BBLen},{maximum,Max}}}}}); + true -> + remove_unused_then_dotag(DoTag,?N_BIT_STRING, + Unused,BinBits) + end; + Size -> + case ((size(BinBits)*8)-Unused) of + BBSize when BBSize =< Size -> + remove_unused_then_dotag(DoTag,?N_BIT_STRING, + Unused,BinBits); + BBSize -> + exit({error,{asn1, + {bitstring_length, + {{was,BBSize},{should_be,Size}}}}}) + end + end. + +remove_unused_then_dotag(DoTag,StringType,Unused,BinBits) -> + case Unused of + 0 when (size(BinBits) == 0),DoTag==[] -> + %% time optimization of next case + {[StringType,1,0],3}; + 0 when (size(BinBits) == 0) -> + dotag(DoTag,StringType,{<<0>>,1}); + 0 when DoTag==[]-> % time optimization of next case + dotag_universal(StringType,[Unused|BinBits],size(BinBits)+1); +% {LenEnc,Len} = encode_legth(size(BinBits)+1), +% {[StringType,LenEnc,[Unused|BinBits]],size(BinBits)+1+Len+1}; + 0 -> + dotag(DoTag,StringType,<<Unused,BinBits/binary>>); + Num when DoTag == [] -> % time optimization of next case + N = (size(BinBits)-1), + <<BBits:N/binary,LastByte>> = BinBits, + dotag_universal(StringType, + [Unused,BBits,(LastByte bsr Num) bsl Num], + size(BinBits)+1); +% {LenEnc,Len} = encode_legth(size(BinBits)+1), +% {[StringType,LenEnc,[Unused,BBits,(LastByte bsr Num) bsl Num], +% 1+Len+size(BinBits)+1}; + Num -> + N = (size(BinBits)-1), + <<BBits:N/binary,LastByte>> = BinBits, + dotag(DoTag,StringType,{[Unused,binary_to_list(BBits) ++ + [(LastByte bsr Num) bsl Num]], + 1+size(BinBits)}) + end. + + +%%================================================================= +%% Encode named bits +%%================================================================= + +encode_bit_string_named(C, [FirstVal | RestVal], NamedBitList, DoTag) -> + {Len,Unused,OctetList} = + case get_constraint(C,'SizeConstraint') of + no -> + ToSetPos = get_all_bitposes([FirstVal | RestVal], + NamedBitList, []), + BitList = make_and_set_list(lists:max(ToSetPos)+1, + ToSetPos, 0), + encode_bitstring(BitList); + {_Min,Max} -> + ToSetPos = get_all_bitposes([FirstVal | RestVal], + NamedBitList, []), + BitList = make_and_set_list(Max, ToSetPos, 0), + encode_bitstring(BitList); + Size -> + ToSetPos = get_all_bitposes([FirstVal | RestVal], + NamedBitList, []), + BitList = make_and_set_list(Size, ToSetPos, 0), + encode_bitstring(BitList) + end, + case DoTag of + [] -> + dotag_universal(?N_BIT_STRING,[Unused|OctetList],Len+1); +% {EncLen,LenLen} = encode_length(Len+1), +% {[?N_BIT_STRING,EncLen,Unused,OctetList],1+LenLen+Len+1}; + _ -> + dotag(DoTag, ?N_BIT_STRING, {[Unused|OctetList],Len+1}) + end. + + +%%---------------------------------------- +%% get_all_bitposes([list of named bits to set], named_bit_db, []) -> +%% [sorted_list_of_bitpositions_to_set] +%%---------------------------------------- + +get_all_bitposes([{bit,ValPos}|Rest], NamedBitList, Ack) -> + get_all_bitposes(Rest, NamedBitList, [ValPos | Ack ]); +get_all_bitposes([Val | Rest], NamedBitList, Ack) when atom(Val) -> + case lists:keysearch(Val, 1, NamedBitList) of + {value, {_ValName, ValPos}} -> + get_all_bitposes(Rest, NamedBitList, [ValPos | Ack]); + _ -> + exit({error,{asn1, {bitstring_namedbit, Val}}}) + end; +get_all_bitposes([], _NamedBitList, Ack) -> + lists:sort(Ack). + + +%%---------------------------------------- +%% make_and_set_list(Len of list to return, [list of positions to set to 1])-> +%% returns list of Len length, with all in SetPos set. +%% in positioning in list the first element is 0, the second 1 etc.., but +%% Len will make a list of length Len, not Len + 1. +%% BitList = make_and_set_list(C, ToSetPos, 0), +%%---------------------------------------- + +make_and_set_list(0, [], _) -> []; +make_and_set_list(0, _, _) -> + exit({error,{asn1,bitstring_sizeconstraint}}); +make_and_set_list(Len, [XPos|SetPos], XPos) -> + [1 | make_and_set_list(Len - 1, SetPos, XPos + 1)]; +make_and_set_list(Len, [Pos|SetPos], XPos) -> + [0 | make_and_set_list(Len - 1, [Pos | SetPos], XPos + 1)]; +make_and_set_list(Len, [], XPos) -> + [0 | make_and_set_list(Len - 1, [], XPos + 1)]. + + + + + + +%%================================================================= +%% Encode bit string for lists of ones and zeroes +%%================================================================= +encode_bit_string_bits(C, BitListVal, _NamedBitList, DoTag) when list(BitListVal) -> + {Len,Unused,OctetList} = + case get_constraint(C,'SizeConstraint') of + no -> + encode_bitstring(BitListVal); + Constr={Min,Max} when integer(Min),integer(Max) -> + encode_constr_bit_str_bits(Constr,BitListVal,DoTag); + {Constr={_,_},[]} -> + %% constraint with extension mark + encode_constr_bit_str_bits(Constr,BitListVal,DoTag); + Constr={{_,_},{_,_}} ->%{{Min1,Max1},{Min2,Max2}} + %% constraint with extension mark + encode_constr_bit_str_bits(Constr,BitListVal,DoTag); + Size -> + case length(BitListVal) of + BitSize when BitSize == Size -> + encode_bitstring(BitListVal); + BitSize when BitSize < Size -> + PaddedList = + pad_bit_list(Size-BitSize,BitListVal), + encode_bitstring(PaddedList); + BitSize -> + exit({error, + {asn1, + {bitstring_length, + {{was,BitSize}, + {should_be,Size}}}}}) + end + end, + %%add unused byte to the Len + case DoTag of + [] -> + dotag_universal(?N_BIT_STRING,[Unused|OctetList],Len+1); +% {EncLen,LenLen}=encode_length(Len+1), +% {[?N_BIT_STRING,EncLen,Unused|OctetList],1+LenLen+Len+1}; + _ -> + dotag(DoTag, ?N_BIT_STRING, + {[Unused | OctetList],Len+1}) + end. + + +encode_constr_bit_str_bits({_Min,Max},BitListVal,_DoTag) -> + BitLen = length(BitListVal), + if + BitLen > Max -> + exit({error,{asn1,{bitstring_length,{{was,BitLen}, + {maximum,Max}}}}}); + true -> + encode_bitstring(BitListVal) + end; +encode_constr_bit_str_bits({{_Min1,Max1},{Min2,Max2}},BitListVal,_DoTag) -> + BitLen = length(BitListVal), + case BitLen of + Len when Len > Max2 -> + exit({error,{asn1,{bitstring_length,{{was,BitLen}, + {maximum,Max2}}}}}); + Len when Len > Max1, Len < Min2 -> + exit({error,{asn1,{bitstring_length,{{was,BitLen}, + {not_allowed_interval, + Max1,Min2}}}}}); + _ -> + encode_bitstring(BitListVal) + end. + +%% returns a list of length Size + length(BitListVal), with BitListVal +%% as the most significant elements followed by padded zero elements +pad_bit_list(Size,BitListVal) -> + Tail = lists:duplicate(Size,0), + lists:append(BitListVal,Tail). + +%%================================================================= +%% Do the actual encoding +%% ([bitlist]) -> {ListLen, UnusedBits, OctetList} +%%================================================================= + +encode_bitstring([B8, B7, B6, B5, B4, B3, B2, B1 | Rest]) -> + Val = (B8 bsl 7) bor (B7 bsl 6) bor (B6 bsl 5) bor (B5 bsl 4) bor + (B4 bsl 3) bor (B3 bsl 2) bor (B2 bsl 1) bor B1, + encode_bitstring(Rest, [Val], 1); +encode_bitstring(Val) -> + {Unused, Octet} = unused_bitlist(Val, 7, 0), + {1, Unused, [Octet]}. + +encode_bitstring([B8, B7, B6, B5, B4, B3, B2, B1 | Rest], Ack, Len) -> + Val = (B8 bsl 7) bor (B7 bsl 6) bor (B6 bsl 5) bor (B5 bsl 4) bor + (B4 bsl 3) bor (B3 bsl 2) bor (B2 bsl 1) bor B1, + encode_bitstring(Rest, [Ack | [Val]], Len + 1); +%%even multiple of 8 bits.. +encode_bitstring([], Ack, Len) -> + {Len, 0, Ack}; +%% unused bits in last octet +encode_bitstring(Rest, Ack, Len) -> +% io:format("uneven ~w ~w ~w~n",[Rest, Ack, Len]), + {Unused, Val} = unused_bitlist(Rest, 7, 0), + {Len + 1, Unused, [Ack | [Val]]}. + +%%%%%%%%%%%%%%%%%% +%% unused_bitlist([list of ones and zeros <= 7], 7, []) -> +%% {Unused bits, Last octet with bits moved to right} +unused_bitlist([], Trail, Ack) -> + {Trail + 1, Ack}; +unused_bitlist([Bit | Rest], Trail, Ack) -> +%% io:format("trail Bit: ~w Rest: ~w Trail: ~w Ack:~w~n",[Bit, Rest, Trail, Ack]), + unused_bitlist(Rest, Trail - 1, (Bit bsl Trail) bor Ack). + + +%%============================================================================ +%% decode bitstring value +%% (Buffer, Range, NamedNumberList, HasTag, TotalLen) -> {Integer, Remain, RemovedBytes} +%%============================================================================ + +decode_compact_bit_string(Buffer, Range, NamedNumberList, Tags, LenIn, OptOrMand) -> +% NewTags = new_tags(HasTag,#tag{class=?UNIVERSAL,number=?N_BIT_STRING}), + decode_restricted_string(Buffer, Range, ?N_BIT_STRING, Tags, LenIn, + NamedNumberList, OptOrMand,bin). + +decode_bit_string(Buffer, Range, NamedNumberList, Tags, LenIn, OptOrMand) -> +% NewTags = new_tags(HasTag,#tag{class=?UNIVERSAL,number=?N_BIT_STRING}), + decode_restricted_string(Buffer, Range, ?N_BIT_STRING, Tags, LenIn, + NamedNumberList, OptOrMand,old). + + +decode_bit_string2(1,<<0 ,Buffer/binary>>,_NamedNumberList,RemovedBytes,BinOrOld) -> + case BinOrOld of + bin -> + {{0,<<>>},Buffer,RemovedBytes}; + _ -> + {[], Buffer, RemovedBytes} + end; +decode_bit_string2(Len,<<Unused,Buffer/binary>>,NamedNumberList, + RemovedBytes,BinOrOld) -> + L = Len - 1, + <<Bits:L/binary,BufferTail/binary>> = Buffer, + case NamedNumberList of + [] -> + case BinOrOld of + bin -> + {{Unused,Bits},BufferTail,RemovedBytes}; + _ -> + BitString = decode_bitstring2(L, Unused, Buffer), + {BitString,BufferTail, RemovedBytes} + end; + _ -> + BitString = decode_bitstring2(L, Unused, Buffer), + {decode_bitstring_NNL(BitString,NamedNumberList), + BufferTail, + RemovedBytes} + end. + +%%---------------------------------------- +%% Decode the in buffer to bits +%%---------------------------------------- +decode_bitstring2(1,Unused,<<B7:1,B6:1,B5:1,B4:1,B3:1,B2:1,B1:1,B0:1,_/binary>>) -> + lists:sublist([B7,B6,B5,B4,B3,B2,B1,B0],8-Unused); +decode_bitstring2(Len, Unused, + <<B7:1,B6:1,B5:1,B4:1,B3:1,B2:1,B1:1,B0:1,Buffer/binary>>) -> + [B7, B6, B5, B4, B3, B2, B1, B0 | + decode_bitstring2(Len - 1, Unused, Buffer)]. + +%%decode_bitstring2(1, Unused, Buffer) -> +%% make_bits_of_int(hd(Buffer), 128, 8-Unused); +%%decode_bitstring2(Len, Unused, [BitVal | Buffer]) -> +%% [B7, B6, B5, B4, B3, B2, B1, B0] = make_bits_of_int(BitVal, 128, 8), +%% [B7, B6, B5, B4, B3, B2, B1, B0 | +%% decode_bitstring2(Len - 1, Unused, Buffer)]. + + +%%make_bits_of_int(_, _, 0) -> +%% []; +%%make_bits_of_int(BitVal, MaskVal, Unused) when Unused > 0 -> +%% X = case MaskVal band BitVal of +%% 0 -> 0 ; +%% _ -> 1 +%% end, +%% [X | make_bits_of_int(BitVal, MaskVal bsr 1, Unused - 1)]. + + + +%%---------------------------------------- +%% Decode the bitlist to names +%%---------------------------------------- + + +decode_bitstring_NNL(BitList,NamedNumberList) -> + decode_bitstring_NNL(BitList,NamedNumberList,0,[]). + + +decode_bitstring_NNL([],_,_No,Result) -> + lists:reverse(Result); + +decode_bitstring_NNL([B|BitList],[{Name,No}|NamedNumberList],No,Result) -> + if + B == 0 -> + decode_bitstring_NNL(BitList,NamedNumberList,No+1,Result); + true -> + decode_bitstring_NNL(BitList,NamedNumberList,No+1,[Name|Result]) + end; +decode_bitstring_NNL([1|BitList],NamedNumberList,No,Result) -> + decode_bitstring_NNL(BitList,NamedNumberList,No+1,[{bit,No}|Result]); +decode_bitstring_NNL([0|BitList],NamedNumberList,No,Result) -> + decode_bitstring_NNL(BitList,NamedNumberList,No+1,Result). + + +%%============================================================================ +%% Octet string, ITU_T X.690 Chapter 8.7 +%% +%% encode octet string +%% The OctetList must be a flat list of integers in the range 0..255 +%% the function does not check this because it takes to much time +%%============================================================================ +encode_octet_string(_C, OctetList, []) when binary(OctetList) -> + dotag_universal(?N_OCTET_STRING,OctetList,size(OctetList)); +encode_octet_string(_C, OctetList, DoTag) when binary(OctetList) -> + dotag(DoTag, ?N_OCTET_STRING, {OctetList,size(OctetList)}); +encode_octet_string(_C, OctetList, DoTag) when list(OctetList) -> + case length(OctetList) of + Len when DoTag == [] -> + dotag_universal(?N_OCTET_STRING,OctetList,Len); + Len -> + dotag(DoTag, ?N_OCTET_STRING, {OctetList,Len}) + end; +% encode_octet_string(C, OctetList, DoTag) when list(OctetList) -> +% dotag(DoTag, ?N_OCTET_STRING, {OctetList,length(OctetList)}); +encode_octet_string(C, {Name,OctetList}, DoTag) when atom(Name) -> + encode_octet_string(C, OctetList, DoTag). + + +%%============================================================================ +%% decode octet string +%% (Buffer, Range, HasTag, TotalLen) -> {String, Remain, RemovedBytes} +%% +%% Octet string is decoded as a restricted string +%%============================================================================ +decode_octet_string(Buffer, Range, Tags, TotalLen, OptOrMand) -> +% NewTags = new_tags(HasTag,#tag{class=?UNIVERSAL,number=?N_OCTET_STRING}), + decode_restricted_string(Buffer, Range, ?N_OCTET_STRING, + Tags, TotalLen, [], OptOrMand,old). + +%%============================================================================ +%% Null value, ITU_T X.690 Chapter 8.8 +%% +%% encode NULL value +%%============================================================================ + +encode_null(_, []) -> + {[?N_NULL,0],2}; +encode_null(_, DoTag) -> + dotag(DoTag, ?N_NULL, {[],0}). + +%%============================================================================ +%% decode NULL value +%% (Buffer, HasTag, TotalLen) -> {NULL, Remain, RemovedBytes} +%%============================================================================ +decode_null(Buffer, Tags, OptOrMand) -> + NewTags = new_tags(Tags,#tag{class=?UNIVERSAL,number=?N_NULL}), + decode_null_notag(Buffer, NewTags, OptOrMand). + +decode_null_notag(Buffer, Tags, OptOrMand) -> + {RestTags, {FormLen, Buffer0, Rb0}} = + check_tags_i(Tags, Buffer, OptOrMand), + + case FormLen of + {?CONSTRUCTED,Len} -> + {_Buffer00,RestBytes} = split_list(Buffer0,Len), + {Val01, Buffer01, Rb01} = decode_null_notag(Buffer0, RestTags, + OptOrMand), + {Buffer02, Rb02} = restbytes2(RestBytes,Buffer01,noext), + {Val01, Buffer02, Rb0+Rb01+Rb02}; + {_,0} -> + {'NULL', Buffer0, Rb0}; + {_,Len} -> + exit({error,{asn1,{invalid_length,'NULL',Len}}}) + end. + + +%%============================================================================ +%% Object identifier, ITU_T X.690 Chapter 8.19 +%% +%% encode Object Identifier value +%%============================================================================ + +encode_object_identifier({Name,Val}, DoTag) when atom(Name) -> + encode_object_identifier(Val, DoTag); +encode_object_identifier(Val, []) -> + {EncVal,Len} = e_object_identifier(Val), + dotag_universal(?N_OBJECT_IDENTIFIER,EncVal,Len); +encode_object_identifier(Val, DoTag) -> + dotag(DoTag, ?N_OBJECT_IDENTIFIER, e_object_identifier(Val)). + +e_object_identifier({'OBJECT IDENTIFIER', V}) -> + e_object_identifier(V); +e_object_identifier({Cname, V}) when atom(Cname), tuple(V) -> + e_object_identifier(tuple_to_list(V)); +e_object_identifier({Cname, V}) when atom(Cname), list(V) -> + e_object_identifier(V); +e_object_identifier(V) when tuple(V) -> + e_object_identifier(tuple_to_list(V)); + +%%%%%%%%%%%%%%% +%% e_object_identifier([List of Obect Identifiers]) -> +%% {[Encoded Octetlist of ObjIds], IntLength} +%% +e_object_identifier([E1, E2 | Tail]) -> + Head = 40*E1 + E2, % wow! + {H,Lh} = mk_object_val(Head), + {R,Lr} = enc_obj_id_tail(Tail, [], 0), + {[H|R], Lh+Lr}. + +enc_obj_id_tail([], Ack, Len) -> + {lists:reverse(Ack), Len}; +enc_obj_id_tail([H|T], Ack, Len) -> + {B, L} = mk_object_val(H), + enc_obj_id_tail(T, [B|Ack], Len+L). + +%% e_object_identifier([List of Obect Identifiers]) -> +%% {[Encoded Octetlist of ObjIds], IntLength} +%% +%%e_object_identifier([E1, E2 | Tail]) -> +%% Head = 40*E1 + E2, % wow! +%% F = fun(Val, AckLen) -> +%% {L, Ack} = mk_object_val(Val), +%% {L, Ack + AckLen} +%% end, +%% {Octets, Len} = lists:mapfoldl(F, 0, [Head | Tail]). + +%%%%%%%%%%% +%% mk_object_val(Value) -> {OctetList, Len} +%% returns a Val as a list of octets, the 8 bit is allways set to one except +%% for the last octet, where its 0 +%% + + +mk_object_val(Val) when Val =< 127 -> + {[255 band Val], 1}; +mk_object_val(Val) -> + mk_object_val(Val bsr 7, [Val band 127], 1). +mk_object_val(0, Ack, Len) -> + {Ack, Len}; +mk_object_val(Val, Ack, Len) -> + mk_object_val(Val bsr 7, [((Val band 127) bor 128) | Ack], Len + 1). + + + +%%============================================================================ +%% decode Object Identifier value +%% (Buffer, HasTag, TotalLen) -> {{ObjId}, Remain, RemovedBytes} +%%============================================================================ + +decode_object_identifier(Buffer, Tags, OptOrMand) -> + NewTags = new_tags(Tags,#tag{class=?UNIVERSAL, + number=?N_OBJECT_IDENTIFIER}), + decode_object_identifier_notag(Buffer, NewTags, OptOrMand). + +decode_object_identifier_notag(Buffer, Tags, OptOrMand) -> + {RestTags, {FormLen, Buffer0, Rb0}} = + check_tags_i(Tags, Buffer, OptOrMand), + + case FormLen of + {?CONSTRUCTED,Len} -> + {Buffer00,RestBytes} = split_list(Buffer0,Len), + {Val01, Buffer01, Rb01} = + decode_object_identifier_notag(Buffer00, + RestTags, OptOrMand), + {Buffer02, Rb02} = restbytes2(RestBytes,Buffer01,noext), + {Val01, Buffer02, Rb0+Rb01+Rb02}; + {_,Len} -> + {[AddedObjVal|ObjVals],Buffer01} = + dec_subidentifiers(Buffer0,0,[],Len), + {Val1, Val2} = if + AddedObjVal < 40 -> + {0, AddedObjVal}; + AddedObjVal < 80 -> + {1, AddedObjVal - 40}; + true -> + {2, AddedObjVal - 80} + end, + {list_to_tuple([Val1, Val2 | ObjVals]), Buffer01, + Rb0+Len} + end. + +dec_subidentifiers(Buffer,_Av,Al,0) -> + {lists:reverse(Al),Buffer}; +dec_subidentifiers(<<1:1,H:7,T/binary>>,Av,Al,Len) -> + dec_subidentifiers(T,(Av bsl 7) + H,Al,Len-1); +dec_subidentifiers(<<H,T/binary>>,Av,Al,Len) -> + dec_subidentifiers(T,0,[((Av bsl 7) + H)|Al],Len-1). + + +%%dec_subidentifiers(Buffer,Av,Al,0) -> +%% {lists:reverse(Al),Buffer}; +%%dec_subidentifiers([H|T],Av,Al,Len) when H >=16#80 -> +%% dec_subidentifiers(T,(Av bsl 7) + (H band 16#7F),Al,Len-1); +%%dec_subidentifiers([H|T],Av,Al,Len) -> +%% dec_subidentifiers(T,0,[(Av bsl 7) + H |Al],Len-1). + + +%%============================================================================ +%% Restricted character string types, ITU_T X.690 Chapter 8.20 +%% +%% encode Numeric Printable Teletex Videotex Visible IA5 Graphic General strings +%%============================================================================ +encode_restricted_string(_C, OctetList, StringType, []) + when binary(OctetList) -> + dotag_universal(StringType,OctetList,size(OctetList)); +encode_restricted_string(_C, OctetList, StringType, DoTag) + when binary(OctetList) -> + dotag(DoTag, StringType, {OctetList, size(OctetList)}); +encode_restricted_string(_C, OctetList, StringType, []) + when list(OctetList) -> + dotag_universal(StringType,OctetList,length(OctetList)); +encode_restricted_string(_C, OctetList, StringType, DoTag) + when list(OctetList) -> + dotag(DoTag, StringType, {OctetList, length(OctetList)}); +encode_restricted_string(C,{Name,OctetL},StringType,DoTag) when atom(Name)-> + encode_restricted_string(C, OctetL, StringType, DoTag). + +%%============================================================================ +%% decode Numeric Printable Teletex Videotex Visible IA5 Graphic General strings +%% (Buffer, Range, StringType, HasTag, TotalLen) -> +%% {String, Remain, RemovedBytes} +%%============================================================================ + +decode_restricted_string(Buffer, Range, StringType, Tags, LenIn, OptOrMand) -> + {Val,Buffer2,Rb} = + decode_restricted_string_tag(Buffer, Range, StringType, Tags, + LenIn, [], OptOrMand,old), + {check_and_convert_restricted_string(Val,StringType,Range,[],old), + Buffer2,Rb}. + + +decode_restricted_string(Buffer, Range, StringType, Tags, LenIn, NNList, OptOrMand, BinOrOld ) -> + {Val,Buffer2,Rb} = + decode_restricted_string_tag(Buffer, Range, StringType, Tags, + LenIn, NNList, OptOrMand, BinOrOld), + {check_and_convert_restricted_string(Val,StringType,Range,NNList,BinOrOld), + Buffer2,Rb}. + +decode_restricted_string_tag(Buffer, Range, StringType, TagsIn, LenIn, NNList, OptOrMand, BinOrOld ) -> + NewTags = new_tags(TagsIn, #tag{class=?UNIVERSAL,number=StringType}), + decode_restricted_string_notag(Buffer, Range, StringType, NewTags, + LenIn, NNList, OptOrMand, BinOrOld). + + + + +check_and_convert_restricted_string(Val,StringType,Range,NamedNumberList,_BinOrOld) -> + {StrLen,NewVal} = case StringType of + ?N_BIT_STRING when NamedNumberList /= [] -> + {no_check,Val}; + ?N_BIT_STRING when list(Val) -> + {length(Val),Val}; + ?N_BIT_STRING when tuple(Val) -> + {(size(element(2,Val))*8) - element(1,Val),Val}; + _ when binary(Val) -> + {size(Val),binary_to_list(Val)}; + _ when list(Val) -> + {length(Val), Val} + end, + case Range of + _ when StrLen == no_check -> + NewVal; + [] -> % No length constraint + NewVal; + {Lb,Ub} when StrLen >= Lb, Ub >= StrLen -> % variable length constraint + NewVal; + {{Lb,_Ub},[]} when StrLen >= Lb -> + NewVal; + {{Lb1,Ub1},{Lb2,Ub2}} when StrLen >= Lb1, StrLen =< Ub1; + StrLen =< Ub2, StrLen >= Lb2 -> + NewVal; + StrLen -> % fixed length constraint + NewVal; + {_,_} -> + exit({error,{asn1,{length,Range,Val}}}); + _Len when integer(_Len) -> + exit({error,{asn1,{length,Range,Val}}}); + _ -> % some strange constraint that we don't support yet + NewVal + end. + + +%%============================================================================= +%% Common routines for several string types including bit string +%% handles indefinite length +%%============================================================================= + + +decode_restricted_string_notag(Buffer, _Range, StringType, TagsIn, + _, NamedNumberList, OptOrMand,BinOrOld) -> + %%----------------------------------------------------------- + %% Get inner (the implicit tag or no tag) and + %% outer (the explicit tag) lengths. + %%----------------------------------------------------------- + {RestTags, {FormLength={_,_Len01}, Buffer0, Rb0}} = + check_tags_i(TagsIn, Buffer, OptOrMand), + + case FormLength of + {?CONSTRUCTED,Len} -> + {Buffer00, RestBytes} = split_list(Buffer0,Len), + {Val01, Buffer01, Rb01} = + decode_restricted_parts(Buffer00, RestBytes, [], StringType, + RestTags, + Len, NamedNumberList, + OptOrMand, + BinOrOld, 0, []), + {Val01, Buffer01, Rb0+Rb01}; + {_, Len} -> + {Val01, Buffer01, Rb01} = + decode_restricted(Buffer0, Len, StringType, + NamedNumberList, BinOrOld), + {Val01, Buffer01, Rb0+Rb01} + end. + + +decode_restricted_parts(Buffer, RestBytes, [], StringType, RestTags, Len, NNList, + OptOrMand, BinOrOld, AccRb, AccVal) -> + DecodeFun = case RestTags of + [] -> fun decode_restricted_string_tag/8; + _ -> fun decode_restricted_string_notag/8 + end, + {Val, Buffer1, Rb} = + DecodeFun(Buffer, [], StringType, RestTags, + no_length, NNList, + OptOrMand, BinOrOld), + {Buffer2,More} = + case Buffer1 of + <<0,0,Buffer10/binary>> when Len == indefinite -> + {Buffer10,false}; + <<>> -> + {RestBytes,false}; + _ -> + {Buffer1,true} + end, + {NewVal, NewRb} = + case StringType of + ?N_BIT_STRING when BinOrOld == bin -> + {concat_bit_binaries(AccVal, Val), AccRb+Rb}; + _ when binary(Val),binary(AccVal) -> + {<<AccVal/binary,Val/binary>>,AccRb+Rb}; + _ when binary(Val), AccVal==[] -> + {Val,AccRb+Rb}; + _ -> + {AccVal++Val, AccRb+Rb} + end, + case More of + false -> + {NewVal, Buffer2, NewRb}; + true -> + decode_restricted_parts(Buffer2, RestBytes, [], StringType, RestTags, Len, NNList, + OptOrMand, BinOrOld, NewRb, NewVal) + end. + + + +decode_restricted(Buffer, InnerLen, StringType, NamedNumberList,BinOrOld) -> + + case StringType of + ?N_BIT_STRING -> + decode_bit_string2(InnerLen,Buffer,NamedNumberList,InnerLen,BinOrOld); + + ?N_UniversalString -> + <<PreBuff:InnerLen/binary,RestBuff/binary>> = Buffer,%%added for binary + UniString = mk_universal_string(binary_to_list(PreBuff)), + {UniString,RestBuff,InnerLen}; + ?N_BMPString -> + <<PreBuff:InnerLen/binary,RestBuff/binary>> = Buffer,%%added for binary + BMP = mk_BMP_string(binary_to_list(PreBuff)), + {BMP,RestBuff,InnerLen}; + _ -> + <<PreBuff:InnerLen/binary,RestBuff/binary>> = Buffer,%%added for binary + {PreBuff, RestBuff, InnerLen} + end. + + + +%%============================================================================ +%% encode Universal string +%%============================================================================ + +encode_universal_string(C, {Name, Universal}, DoTag) when atom(Name) -> + encode_universal_string(C, Universal, DoTag); +encode_universal_string(_C, Universal, []) -> + OctetList = mk_uni_list(Universal), + dotag_universal(?N_UniversalString,OctetList,length(OctetList)); +encode_universal_string(_C, Universal, DoTag) -> + OctetList = mk_uni_list(Universal), + dotag(DoTag, ?N_UniversalString, {OctetList,length(OctetList)}). + +mk_uni_list(In) -> + mk_uni_list(In,[]). + +mk_uni_list([],List) -> + lists:reverse(List); +mk_uni_list([{A,B,C,D}|T],List) -> + mk_uni_list(T,[D,C,B,A|List]); +mk_uni_list([H|T],List) -> + mk_uni_list(T,[H,0,0,0|List]). + +%%=========================================================================== +%% decode Universal strings +%% (Buffer, Range, StringType, HasTag, LenIn) -> +%% {String, Remain, RemovedBytes} +%%=========================================================================== + +decode_universal_string(Buffer, Range, Tags, LenIn, OptOrMand) -> +% NewTags = new_tags(HasTag, #tag{class=?UNIVERSAL,number=?N_UniversalString}), + decode_restricted_string(Buffer, Range, ?N_UniversalString, + Tags, LenIn, [], OptOrMand,old). + + +mk_universal_string(In) -> + mk_universal_string(In,[]). + +mk_universal_string([],Acc) -> + lists:reverse(Acc); +mk_universal_string([0,0,0,D|T],Acc) -> + mk_universal_string(T,[D|Acc]); +mk_universal_string([A,B,C,D|T],Acc) -> + mk_universal_string(T,[{A,B,C,D}|Acc]). + + +%%============================================================================ +%% encode BMP string +%%============================================================================ + +encode_BMP_string(C, {Name,BMPString}, DoTag) when atom(Name)-> + encode_BMP_string(C, BMPString, DoTag); +encode_BMP_string(_C, BMPString, []) -> + OctetList = mk_BMP_list(BMPString), + dotag_universal(?N_BMPString,OctetList,length(OctetList)); +encode_BMP_string(_C, BMPString, DoTag) -> + OctetList = mk_BMP_list(BMPString), + dotag(DoTag, ?N_BMPString, {OctetList,length(OctetList)}). + +mk_BMP_list(In) -> + mk_BMP_list(In,[]). + +mk_BMP_list([],List) -> + lists:reverse(List); +mk_BMP_list([{0,0,C,D}|T],List) -> + mk_BMP_list(T,[D,C|List]); +mk_BMP_list([H|T],List) -> + mk_BMP_list(T,[H,0|List]). + +%%============================================================================ +%% decode (OctetList, Range(ignored), tag|notag) -> {ValList, RestList} +%% (Buffer, Range, StringType, HasTag, TotalLen) -> +%% {String, Remain, RemovedBytes} +%%============================================================================ +decode_BMP_string(Buffer, Range, Tags, LenIn, OptOrMand) -> +% NewTags = new_tags(HasTag, #tag{class=?UNIVERSAL,number=?N_BMPString}), + decode_restricted_string(Buffer, Range, ?N_BMPString, + Tags, LenIn, [], OptOrMand,old). + +mk_BMP_string(In) -> + mk_BMP_string(In,[]). + +mk_BMP_string([],US) -> + lists:reverse(US); +mk_BMP_string([0,B|T],US) -> + mk_BMP_string(T,[B|US]); +mk_BMP_string([C,D|T],US) -> + mk_BMP_string(T,[{0,0,C,D}|US]). + + +%%============================================================================ +%% Generalized time, ITU_T X.680 Chapter 39 +%% +%% encode Generalized time +%%============================================================================ + +encode_generalized_time(C, {Name,OctetList}, DoTag) when atom(Name) -> + encode_generalized_time(C, OctetList, DoTag); +encode_generalized_time(_C, OctetList, []) -> + dotag_universal(?N_GeneralizedTime,OctetList,length(OctetList)); +encode_generalized_time(_C, OctetList, DoTag) -> + dotag(DoTag, ?N_GeneralizedTime, {OctetList,length(OctetList)}). + +%%============================================================================ +%% decode Generalized time +%% (Buffer, Range, HasTag, TotalLen) -> {String, Remain, RemovedBytes} +%%============================================================================ + +decode_generalized_time(Buffer, Range, Tags, TotalLen, OptOrMand) -> + NewTags = new_tags(Tags,#tag{class=?UNIVERSAL, + number=?N_GeneralizedTime}), + decode_generalized_time_notag(Buffer, Range, NewTags, TotalLen, OptOrMand). + +decode_generalized_time_notag(Buffer, Range, Tags, TotalLen, OptOrMand) -> + {RestTags, {FormLen, Buffer0, Rb0}} = + check_tags_i(Tags, Buffer, OptOrMand), + + case FormLen of + {?CONSTRUCTED,Len} -> + {Buffer00,RestBytes} = split_list(Buffer0,Len), + {Val01, Buffer01, Rb01} = + decode_generalized_time_notag(Buffer00, Range, + RestTags, TotalLen, + OptOrMand), + {Buffer02, Rb02} = restbytes2(RestBytes,Buffer01,noext), + {Val01, Buffer02, Rb0+Rb01+Rb02}; + {_,Len} -> + <<PreBuff:Len/binary,RestBuff/binary>> = Buffer0, + {binary_to_list(PreBuff), RestBuff, Rb0+Len} + end. + +%%============================================================================ +%% Universal time, ITU_T X.680 Chapter 40 +%% +%% encode UTC time +%%============================================================================ + +encode_utc_time(C, {Name,OctetList}, DoTag) when atom(Name) -> + encode_utc_time(C, OctetList, DoTag); +encode_utc_time(_C, OctetList, []) -> + dotag_universal(?N_UTCTime, OctetList,length(OctetList)); +encode_utc_time(_C, OctetList, DoTag) -> + dotag(DoTag, ?N_UTCTime, {OctetList,length(OctetList)}). + +%%============================================================================ +%% decode UTC time +%% (Buffer, Range, HasTag, TotalLen) -> {String, Remain, RemovedBytes} +%%============================================================================ + +decode_utc_time(Buffer, Range, Tags, TotalLen, OptOrMand) -> + NewTags = new_tags(Tags,#tag{class=?UNIVERSAL,number=?N_UTCTime}), + decode_utc_time_notag(Buffer, Range, NewTags, TotalLen, OptOrMand). + +decode_utc_time_notag(Buffer, Range, Tags, TotalLen, OptOrMand) -> + {RestTags, {FormLen, Buffer0, Rb0}} = + check_tags_i(Tags, Buffer, OptOrMand), + + case FormLen of + {?CONSTRUCTED,Len} -> + {Buffer00,RestBytes} = split_list(Buffer0,Len), + {Val01, Buffer01, Rb01} = + decode_utc_time_notag(Buffer00, Range, + RestTags, TotalLen, + OptOrMand), + {Buffer02, Rb02} = restbytes2(RestBytes,Buffer01,noext), + {Val01, Buffer02, Rb0+Rb01+Rb02}; + {_,Len} -> + <<PreBuff:Len/binary,RestBuff/binary>> = Buffer0, + {binary_to_list(PreBuff), RestBuff, Rb0+Len} + end. + + +%%============================================================================ +%% Length handling +%% +%% Encode length +%% +%% encode_length(Int | indefinite) -> +%% [<127]| [128 + Int (<127),OctetList] | [16#80] +%%============================================================================ + +encode_length(indefinite) -> + {[16#80],1}; % 128 +encode_length(L) when L =< 16#7F -> + {[L],1}; +encode_length(L) -> + Oct = minimum_octets(L), + Len = length(Oct), + if + Len =< 126 -> + {[ (16#80+Len) | Oct ],Len+1}; + true -> + exit({error,{asn1, to_long_length_oct, Len}}) + end. + + +%% Val must be >= 0 +minimum_octets(Val) -> + minimum_octets(Val,[]). + +minimum_octets(0,Acc) -> + Acc; +minimum_octets(Val, Acc) -> + minimum_octets((Val bsr 8),[Val band 16#FF | Acc]). + + +%%=========================================================================== +%% Decode length +%% +%% decode_length(OctetList) -> {{indefinite, RestOctetsL}, NoRemovedBytes} | +%% {{Length, RestOctetsL}, NoRemovedBytes} +%%=========================================================================== + +decode_length(<<1:1,0:7,T/binary>>) -> + {{indefinite, T}, 1}; +decode_length(<<0:1,Length:7,T/binary>>) -> + {{Length,T},1}; +decode_length(<<1:1,LL:7,T/binary>>) -> + <<Length:LL/unit:8,Rest/binary>> = T, + {{Length,Rest}, LL+1}. + +%decode_length([128 | T]) -> +% {{indefinite, T},1}; +%decode_length([H | T]) when H =< 127 -> +% {{H, T},1}; +%decode_length([H | T]) -> +% dec_long_length(H band 16#7F, T, 0, 1). + + +%%dec_long_length(0, Buffer, Acc, Len) -> +%% {{Acc, Buffer},Len}; +%%dec_long_length(Bytes, [H | T], Acc, Len) -> +%% dec_long_length(Bytes - 1, T, (Acc bsl 8) + H, Len+1). + +%%=========================================================================== +%% Decode tag and length +%% +%% decode_tag_and_length(Buffer) -> {Tag, Len, RemainingBuffer, RemovedBytes} +%% +%%=========================================================================== + +decode_tag_and_length(Buffer) -> + {Tag, Buffer2, RemBytesTag} = decode_tag(Buffer), + {{Len, Buffer3}, RemBytesLen} = decode_length(Buffer2), + {Tag, Len, Buffer3, RemBytesTag+RemBytesLen}. + + +%%============================================================================ +%% Check if valid tag +%% +%% check_if_valid_tag(Tag, List_of_valid_tags, OptOrMand) -> name of the tag +%%=============================================================================== + +check_if_valid_tag(<<0,0,_/binary>>,_,_) -> + asn1_EOC; +check_if_valid_tag(<<>>, _, OptOrMand) -> + check_if_valid_tag2(false,[],[],OptOrMand); +check_if_valid_tag(Bytes, ListOfTags, OptOrMand) when binary(Bytes) -> + {Tag, _, _} = decode_tag(Bytes), + check_if_valid_tag(Tag, ListOfTags, OptOrMand); + +%% This alternative should be removed in the near future +%% Bytes as input should be the only necessary call +check_if_valid_tag(Tag, ListOfTags, OptOrMand) -> + {Class, _Form, TagNo} = Tag, + C = code_class(Class), + T = case C of + 'UNIVERSAL' -> + code_type(TagNo); + _ -> + TagNo + end, + check_if_valid_tag2({C,T}, ListOfTags, Tag, OptOrMand). + +check_if_valid_tag2(_Class_TagNo, [], Tag, mandatory) -> + exit({error,{asn1,{invalid_tag,Tag}}}); +check_if_valid_tag2(_Class_TagNo, [], Tag, _) -> + exit({error,{asn1,{no_optional_tag,Tag}}}); + +check_if_valid_tag2(Class_TagNo, [{TagName,TagList}|T], Tag, OptOrMand) -> + case check_if_valid_tag_loop(Class_TagNo, TagList) of + true -> + TagName; + false -> + check_if_valid_tag2(Class_TagNo, T, Tag, OptOrMand) + end. + +check_if_valid_tag_loop(_Class_TagNo,[]) -> + false; +check_if_valid_tag_loop(Class_TagNo,[H|T]) -> + %% It is not possible to distinguish between SEQUENCE OF and SEQUENCE, and + %% between SET OF and SET because both are coded as 16 and 17, respectively. + H_without_OF = case H of + {C, 'SEQUENCE OF'} -> + {C, 'SEQUENCE'}; + {C, 'SET OF'} -> + {C, 'SET'}; + Else -> + Else + end, + + case H_without_OF of + Class_TagNo -> + true; + {_,_} -> + check_if_valid_tag_loop(Class_TagNo,T); + _ -> + check_if_valid_tag_loop(Class_TagNo,H), + check_if_valid_tag_loop(Class_TagNo,T) + end. + + + +code_class(0) -> 'UNIVERSAL'; +code_class(16#40) -> 'APPLICATION'; +code_class(16#80) -> 'CONTEXT'; +code_class(16#C0) -> 'PRIVATE'. + + +code_type(1) -> 'BOOLEAN'; +code_type(2) -> 'INTEGER'; +code_type(3) -> 'BIT STRING'; +code_type(4) -> 'OCTET STRING'; +code_type(5) -> 'NULL'; +code_type(6) -> 'OBJECT IDENTIFIER'; +code_type(7) -> 'OBJECT DESCRIPTOR'; +code_type(8) -> 'EXTERNAL'; +code_type(9) -> 'REAL'; +code_type(10) -> 'ENUMERATED'; +code_type(11) -> 'EMBEDDED_PDV'; +code_type(16) -> 'SEQUENCE'; +code_type(16) -> 'SEQUENCE OF'; +code_type(17) -> 'SET'; +code_type(17) -> 'SET OF'; +code_type(18) -> 'NumericString'; +code_type(19) -> 'PrintableString'; +code_type(20) -> 'TeletexString'; +code_type(21) -> 'VideotexString'; +code_type(22) -> 'IA5String'; +code_type(23) -> 'UTCTime'; +code_type(24) -> 'GeneralizedTime'; +code_type(25) -> 'GraphicString'; +code_type(26) -> 'VisibleString'; +code_type(27) -> 'GeneralString'; +code_type(28) -> 'UniversalString'; +code_type(30) -> 'BMPString'; +code_type(Else) -> exit({error,{asn1,{unrecognized_type,Else}}}). + +%%------------------------------------------------------------------------- +%% decoding of the components of a SET +%%------------------------------------------------------------------------- + +decode_set(Rb, indefinite, <<0,0,Bytes/binary>>, _OptOrMand, _Fun3, Acc) -> + {lists:reverse(Acc),Bytes,Rb+2}; + +decode_set(Rb, indefinite, Bytes, OptOrMand, Fun3, Acc) -> + {Term, Remain, Rb1} = Fun3(Bytes, OptOrMand), + decode_set(Rb+Rb1, indefinite, Remain, OptOrMand, Fun3, [Term|Acc]); + +decode_set(Rb, Num, Bytes, _OptOrMand, _Fun3, Acc) when Num == 0 -> + {lists:reverse(Acc), Bytes, Rb}; + +decode_set(_, Num, _, _, _, _) when Num < 0 -> + exit({error,{asn1,{length_error,'SET'}}}); + +decode_set(Rb, Num, Bytes, OptOrMand, Fun3, Acc) -> + {Term, Remain, Rb1} = Fun3(Bytes, OptOrMand), + decode_set(Rb+Rb1, Num-Rb1, Remain, OptOrMand, Fun3, [Term|Acc]). + + +%%------------------------------------------------------------------------- +%% decoding of SEQUENCE OF and SET OF +%%------------------------------------------------------------------------- + +decode_components(Rb, indefinite, <<0,0,Bytes/binary>>, _Fun3, _TagIn, Acc) -> + {lists:reverse(Acc),Bytes,Rb+2}; + +decode_components(Rb, indefinite, Bytes, Fun3, TagIn, Acc) -> + {Term, Remain, Rb1} = Fun3(Bytes, mandatory, TagIn), + decode_components(Rb+Rb1, indefinite, Remain, Fun3, TagIn, [Term|Acc]); + +decode_components(Rb, Num, Bytes, _Fun3, _TagIn, Acc) when Num == 0 -> + {lists:reverse(Acc), Bytes, Rb}; + +decode_components(_, Num, _, _, _, _) when Num < 0 -> + exit({error,{asn1,{length_error,'SET/SEQUENCE OF'}}}); + +decode_components(Rb, Num, Bytes, Fun3, TagIn, Acc) -> + {Term, Remain, Rb1} = Fun3(Bytes, mandatory, TagIn), + decode_components(Rb+Rb1, Num-Rb1, Remain, Fun3, TagIn, [Term|Acc]). + +%%decode_components(Rb, indefinite, [0,0|Bytes], _Fun3, _TagIn, Acc) -> +%% {lists:reverse(Acc),Bytes,Rb+2}; + +decode_components(Rb, indefinite, <<0,0,Bytes/binary>>, _Fun4, _TagIn, _Fun, Acc) -> + {lists:reverse(Acc),Bytes,Rb+2}; + +decode_components(Rb, indefinite, Bytes, _Fun4, TagIn, _Fun, Acc) -> + {Term, Remain, Rb1} = _Fun4(Bytes, mandatory, TagIn, _Fun), + decode_components(Rb+Rb1, indefinite, Remain, _Fun4, TagIn, _Fun, [Term|Acc]); + +decode_components(Rb, Num, Bytes, _Fun4, _TagIn, _Fun, Acc) when Num == 0 -> + {lists:reverse(Acc), Bytes, Rb}; + +decode_components(_, Num, _, _, _, _, _) when Num < 0 -> + exit({error,{asn1,{length_error,'SET/SEQUENCE OF'}}}); + +decode_components(Rb, Num, Bytes, _Fun4, TagIn, _Fun, Acc) -> + {Term, Remain, Rb1} = _Fun4(Bytes, mandatory, TagIn, _Fun), + decode_components(Rb+Rb1, Num-Rb1, Remain, _Fun4, TagIn, _Fun, [Term|Acc]). + + + +%%------------------------------------------------------------------------- +%% INTERNAL HELPER FUNCTIONS (not exported) +%%------------------------------------------------------------------------- + + +%%========================================================================== +%% Encode tag +%% +%% dotag(tag | notag, TagValpattern | TagValTuple, [Length, Value]) -> [Tag] +%% TagValPattern is a correct bitpattern for a tag +%% TagValTuple is a tuple of three bitpatterns, Class, Form and TagNo where +%% Class = UNIVERSAL | APPLICATION | CONTEXT | PRIVATE +%% Form = Primitive | Constructed +%% TagNo = Number of tag +%%========================================================================== + + +dotag([], Tag, {Bytes,Len}) -> + dotag_universal(Tag,Bytes,Len); +dotag(Tags, Tag, {Bytes,Len}) -> + encode_tags(Tags ++ [#tag{class=?UNIVERSAL,number=Tag,form=?PRIMITIVE}], + Bytes, Len); + +dotag(Tags, Tag, Bytes) -> + encode_tags(Tags ++ [#tag{class=?UNIVERSAL,number=Tag,form=?PRIMITIVE}], + Bytes, size(Bytes)). + +dotag_universal(UniversalTag,Bytes,Len) when Len =< 16#7F-> + {[UniversalTag,Len,Bytes],2+Len}; +dotag_universal(UniversalTag,Bytes,Len) -> + {EncLen,LenLen}=encode_length(Len), + {[UniversalTag,EncLen,Bytes],1+LenLen+Len}. + +%% decoding postitive integer values. +decode_integer2(Len,Bin = <<0:1,_:7,_Bs/binary>>,RemovedBytes) -> + <<Int:Len/unit:8,Buffer2/binary>> = Bin, + {Int,Buffer2,RemovedBytes}; +%% decoding negative integer values. +decode_integer2(Len,<<1:1,B2:7,Bs/binary>>,RemovedBytes) -> + <<N:Len/unit:8,Buffer2/binary>> = <<B2,Bs/binary>>, + Int = N - (1 bsl (8 * Len - 1)), + {Int,Buffer2,RemovedBytes}. + +%%decode_integer2(Len,Buffer,Acc,RemovedBytes) when (hd(Buffer) band 16#FF) =< 16#7F -> +%% {decode_integer_pos(Buffer, 8 * (Len - 1)),skip(Buffer,Len),RemovedBytes}; +%%decode_integer2(Len,Buffer,Acc,RemovedBytes) -> +%% {decode_integer_neg(Buffer, 8 * (Len - 1)),skip(Buffer,Len),RemovedBytes}. + +%%decode_integer_pos([Byte|Tail], Shift) -> +%% (Byte bsl Shift) bor decode_integer_pos(Tail, Shift-8); +%%decode_integer_pos([], _) -> 0. + + +%%decode_integer_neg([Byte|Tail], Shift) -> +%% (-128 + (Byte band 127) bsl Shift) bor decode_integer_pos(Tail, Shift-8). + + +concat_bit_binaries([],Bin={_,_}) -> + Bin; +concat_bit_binaries({0,B1},{U2,B2}) -> + {U2,<<B1/binary,B2/binary>>}; +concat_bit_binaries({U1,B1},{U2,B2}) -> + S1 = (size(B1) * 8) - U1, + S2 = (size(B2) * 8) - U2, + PadBits = 8 - ((S1+S2) rem 8), + {PadBits, <<B1:S1/binary-unit:1,B2:S2/binary-unit:1,0:PadBits>>}; +concat_bit_binaries(L1,L2) when list(L1),list(L2) -> + %% this case occur when decoding with NNL + L1 ++ L2. + + +get_constraint(C,Key) -> + case lists:keysearch(Key,1,C) of + false -> + no; + {value,{_,V}} -> + V + end. + +%%skip(Buffer, 0) -> +%% Buffer; +%%skip([H | T], Len) -> +%% skip(T, Len-1). + +new_tags([],LastTag) -> + [LastTag]; +new_tags(Tags=[#tag{type='IMPLICIT'}],_LastTag) -> + Tags; +new_tags([T1 = #tag{type='IMPLICIT'},#tag{type=T2Type}|Rest],LastTag) -> + new_tags([T1#tag{type=T2Type}|Rest],LastTag); +new_tags(Tags,LastTag) -> + case lists:last(Tags) of + #tag{type='IMPLICIT'} -> + Tags; + _ -> + Tags ++ [LastTag] + end. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_ber_bin_v2.erl b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_ber_bin_v2.erl new file mode 100644 index 0000000000..50a91cf201 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_ber_bin_v2.erl @@ -0,0 +1,1849 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: asn1rt_ber_bin_v2.erl,v 1.1 2008/12/17 09:53:30 mikpe Exp $ +%% +-module(asn1rt_ber_bin_v2). + +%% encoding / decoding of BER + +-export([decode/1, decode/2, match_tags/2, encode/1]). +-export([fixoptionals/2, cindex/3, + list_to_record/2, + encode_tag_val/1, + encode_tags/3]). +-export([encode_boolean/2,decode_boolean/2, + encode_integer/3,encode_integer/4, + decode_integer/3, decode_integer/4, + encode_enumerated/2, + encode_enumerated/4,decode_enumerated/4, + encode_real/2,decode_real/3, + encode_bit_string/4,decode_bit_string/4, + decode_compact_bit_string/4, + encode_octet_string/3,decode_octet_string/3, + encode_null/2,decode_null/2, + encode_object_identifier/2,decode_object_identifier/2, + encode_restricted_string/4,decode_restricted_string/4, + encode_universal_string/3,decode_universal_string/3, + encode_BMP_string/3,decode_BMP_string/3, + encode_generalized_time/3,decode_generalized_time/3, + encode_utc_time/3,decode_utc_time/3, + encode_length/1,decode_length/1, + decode_tag_and_length/1]). + +-export([encode_open_type/1,encode_open_type/2, + decode_open_type/2,decode_open_type_as_binary/2]). + +-export([decode_primitive_incomplete/2]). + +-include("asn1_records.hrl"). + +% the encoding of class of tag bits 8 and 7 +-define(UNIVERSAL, 0). +-define(APPLICATION, 16#40). +-define(CONTEXT, 16#80). +-define(PRIVATE, 16#C0). + +%%% primitive or constructed encoding % bit 6 +-define(PRIMITIVE, 0). +-define(CONSTRUCTED, 2#00100000). + +%%% The tag-number for universal types +-define(N_BOOLEAN, 1). +-define(N_INTEGER, 2). +-define(N_BIT_STRING, 3). +-define(N_OCTET_STRING, 4). +-define(N_NULL, 5). +-define(N_OBJECT_IDENTIFIER, 6). +-define(N_OBJECT_DESCRIPTOR, 7). +-define(N_EXTERNAL, 8). +-define(N_REAL, 9). +-define(N_ENUMERATED, 10). +-define(N_EMBEDDED_PDV, 11). +-define(N_SEQUENCE, 16). +-define(N_SET, 17). +-define(N_NumericString, 18). +-define(N_PrintableString, 19). +-define(N_TeletexString, 20). +-define(N_VideotexString, 21). +-define(N_IA5String, 22). +-define(N_UTCTime, 23). +-define(N_GeneralizedTime, 24). +-define(N_GraphicString, 25). +-define(N_VisibleString, 26). +-define(N_GeneralString, 27). +-define(N_UniversalString, 28). +-define(N_BMPString, 30). + + +% the complete tag-word of built-in types +-define(T_BOOLEAN, ?UNIVERSAL bor ?PRIMITIVE bor 1). +-define(T_INTEGER, ?UNIVERSAL bor ?PRIMITIVE bor 2). +-define(T_BIT_STRING, ?UNIVERSAL bor ?PRIMITIVE bor 3). % can be CONSTRUCTED +-define(T_OCTET_STRING, ?UNIVERSAL bor ?PRIMITIVE bor 4). % can be CONSTRUCTED +-define(T_NULL, ?UNIVERSAL bor ?PRIMITIVE bor 5). +-define(T_OBJECT_IDENTIFIER,?UNIVERSAL bor ?PRIMITIVE bor 6). +-define(T_OBJECT_DESCRIPTOR,?UNIVERSAL bor ?PRIMITIVE bor 7). +-define(T_EXTERNAL, ?UNIVERSAL bor ?PRIMITIVE bor 8). +-define(T_REAL, ?UNIVERSAL bor ?PRIMITIVE bor 9). +-define(T_ENUMERATED, ?UNIVERSAL bor ?PRIMITIVE bor 10). +-define(T_EMBEDDED_PDV, ?UNIVERSAL bor ?PRIMITIVE bor 11). +-define(T_SEQUENCE, ?UNIVERSAL bor ?CONSTRUCTED bor 16). +-define(T_SET, ?UNIVERSAL bor ?CONSTRUCTED bor 17). +-define(T_NumericString, ?UNIVERSAL bor ?PRIMITIVE bor 18). %can be constructed +-define(T_PrintableString, ?UNIVERSAL bor ?PRIMITIVE bor 19). %can be constructed +-define(T_TeletexString, ?UNIVERSAL bor ?PRIMITIVE bor 20). %can be constructed +-define(T_VideotexString, ?UNIVERSAL bor ?PRIMITIVE bor 21). %can be constructed +-define(T_IA5String, ?UNIVERSAL bor ?PRIMITIVE bor 22). %can be constructed +-define(T_UTCTime, ?UNIVERSAL bor ?PRIMITIVE bor 23). +-define(T_GeneralizedTime, ?UNIVERSAL bor ?PRIMITIVE bor 24). +-define(T_GraphicString, ?UNIVERSAL bor ?PRIMITIVE bor 25). %can be constructed +-define(T_VisibleString, ?UNIVERSAL bor ?PRIMITIVE bor 26). %can be constructed +-define(T_GeneralString, ?UNIVERSAL bor ?PRIMITIVE bor 27). %can be constructed +-define(T_UniversalString, ?UNIVERSAL bor ?PRIMITIVE bor 28). %can be constructed +-define(T_BMPString, ?UNIVERSAL bor ?PRIMITIVE bor 30). %can be constructed + +% encode(Tlv={_Tag={?PRIMITIVE,_},_VList}) -> +% encode_primitive(Tlv); +% encode(Tlv) -> +% encode_constructed(Tlv). + +encode([Tlv]) -> + encode(Tlv); +encode({TlvTag,TlvVal}) when list(TlvVal) -> + %% constructed form of value + encode_tlv(TlvTag,TlvVal,?CONSTRUCTED); +encode({TlvTag,TlvVal}) -> + encode_tlv(TlvTag,TlvVal,?PRIMITIVE); +encode(Bin) when binary(Bin) -> + Bin. + +encode_tlv(TlvTag,TlvVal,Form) -> + Tag = encode_tlv_tag(TlvTag,Form), + {Val,VLen} = encode_tlv_val(TlvVal), + {Len,_LLen} = encode_length(VLen), + BinLen = list_to_binary(Len), + <<Tag/binary,BinLen/binary,Val/binary>>. + +encode_tlv_tag(ClassTagNo,Form) -> + Class = ClassTagNo bsr 16, + case encode_tag_val({Class bsl 6,Form,(ClassTagNo - (Class bsl 16))}) of + T when list(T) -> + list_to_binary(T); + T -> + T + end. + +encode_tlv_val(TlvL) when list(TlvL) -> + encode_tlv_list(TlvL,[]); +encode_tlv_val(Bin) -> + {Bin,size(Bin)}. + +encode_tlv_list([Tlv|Tlvs],Acc) -> + EncTlv = encode(Tlv), + encode_tlv_list(Tlvs,[EncTlv|Acc]); +encode_tlv_list([],Acc) -> + Bin=list_to_binary(lists:reverse(Acc)), + {Bin,size(Bin)}. + +% encode_primitive({{_,ClassTagNo},V}) -> +% Len = size(V), % not sufficient as length encode +% Class = ClassTagNo bsr 16, +% {TagLen,Tag} = +% case encode_tag_val({Class,?PRIMITIVE,ClassTagNo - Class}) of +% T when list(T) -> +% {length(T),list_to_binary(T)}; +% T -> +% {1,T} +% end, + + +decode(B,driver) -> + case catch port_control(drv_complete,2,B) of + Bin when binary(Bin) -> + binary_to_term(Bin); + List when list(List) -> handle_error(List,B); + {'EXIT',{badarg,Reason}} -> + asn1rt_driver_handler:load_driver(), + receive + driver_ready -> + case catch port_control(drv_complete,2,B) of + Bin2 when binary(Bin2) -> binary_to_term(Bin2); + List when list(List) -> handle_error(List,B); + Error -> exit(Error) + end; + {error,Error} -> % error when loading driver + %% the driver could not be loaded + exit(Error); + Error={port_error,Reason} -> + exit(Error) + end; + {'EXIT',Reason} -> + exit(Reason) + end. + +handle_error([],_)-> + exit({error,{"memory allocation problem"}}); +handle_error([$1|_],L) -> % error in driver + exit({error,{asn1_error,L}}); +handle_error([$2|_],L) -> % error in driver due to wrong tag + exit({error,{asn1_error,{"bad tag",L}}}); +handle_error([$3|_],L) -> % error in driver due to length error + exit({error,{asn1_error,{"bad length field",L}}}); +handle_error([$4|_],L) -> % error in driver due to indefinite length error + exit({error,{asn1_error,{"indefinite length without end bytes",L}}}); +handle_error(ErrL,L) -> + exit({error,{unknown_error,ErrL,L}}). + + +decode(Bin) when binary(Bin) -> + decode_primitive(Bin); +decode(Tlv) -> % assume it is a tlv + {Tlv,<<>>}. + + +decode_primitive(Bin) -> + {{Form,TagNo,Len,V},Rest} = decode_tlv(Bin), + case Form of + 1 when Len == indefinite -> % constructed + {Vlist,Rest2} = decode_constructed_indefinite(V,[]), + {{TagNo,Vlist},Rest2}; + 1 -> % constructed + {{TagNo,decode_constructed(V)},Rest}; + 0 -> % primitive + {{TagNo,V},Rest} + end. + +decode_constructed(<<>>) -> + []; +decode_constructed(Bin) -> + {Tlv,Rest} = decode_primitive(Bin), + [Tlv|decode_constructed(Rest)]. + +decode_constructed_indefinite(<<0,0,Rest/binary>>,Acc) -> + {lists:reverse(Acc),Rest}; +decode_constructed_indefinite(Bin,Acc) -> + {Tlv,Rest} = decode_primitive(Bin), + decode_constructed_indefinite(Rest, [Tlv|Acc]). + +decode_tlv(Bin) -> + {Form,TagNo,Len,Bin2} = decode_tag_and_length(Bin), + case Len of + indefinite -> + {{Form,TagNo,Len,Bin2},[]}; + _ -> + <<V:Len/binary,Bin3/binary>> = Bin2, + {{Form,TagNo,Len,V},Bin3} + end. + +%% decode_primitive_incomplete/2 decodes an encoded message incomplete +%% by help of the pattern attribute (first argument). +decode_primitive_incomplete([[default,TagNo]],Bin) -> %default + case decode_tlv(Bin) of + {{Form,TagNo,Len,V},Rest} -> + decode_incomplete2(Form,TagNo,Len,V,[],Rest); + _ -> + %{asn1_DEFAULT,Bin} + asn1_NOVALUE + end; +decode_primitive_incomplete([[default,TagNo,Directives]],Bin) -> %default, constructed type, Directives points into this type + case decode_tlv(Bin) of + {{Form,TagNo,Len,V},Rest} -> + decode_incomplete2(Form,TagNo,Len,V,Directives,Rest); + _ -> + %{asn1_DEFAULT,Bin} + asn1_NOVALUE + end; +decode_primitive_incomplete([[opt,TagNo]],Bin) -> %optional + case decode_tlv(Bin) of + {{Form,TagNo,Len,V},Rest} -> + decode_incomplete2(Form,TagNo,Len,V,[],Rest); + _ -> + %{{TagNo,asn1_NOVALUE},Bin} + asn1_NOVALUE + end; +decode_primitive_incomplete([[opt,TagNo,Directives]],Bin) -> %optional + case decode_tlv(Bin) of + {{Form,TagNo,Len,V},Rest} -> + decode_incomplete2(Form,TagNo,Len,V,Directives,Rest); + _ -> + %{{TagNo,asn1_NOVALUE},Bin} + asn1_NOVALUE + end; +%% A choice alternative that shall be undecoded +decode_primitive_incomplete([[alt_undec,TagNo]|RestAlts],Bin) -> +% decode_incomplete_bin(Bin); + case decode_tlv(Bin) of + {{_Form,TagNo,_Len,_V},_R} -> + decode_incomplete_bin(Bin); + _ -> + decode_primitive_incomplete(RestAlts,Bin) + end; +decode_primitive_incomplete([[alt,TagNo]|RestAlts],Bin) -> + case decode_tlv(Bin) of + {{_Form,TagNo,_Len,V},Rest} -> + {{TagNo,V},Rest}; + _ -> + decode_primitive_incomplete(RestAlts,Bin) + end; +decode_primitive_incomplete([[alt,TagNo,Directives]|RestAlts],Bin) -> + case decode_tlv(Bin) of + {{Form,TagNo,Len,V},Rest} -> + decode_incomplete2(Form,TagNo,Len,V,Directives,Rest); + _ -> + decode_primitive_incomplete(RestAlts,Bin) + end; +decode_primitive_incomplete([[alt_parts,TagNo]|RestAlts],Bin) -> + case decode_tlv(Bin) of + {{_Form,TagNo,_Len,V},Rest} -> + {{TagNo,decode_parts_incomplete(V)},Rest}; + _ -> + decode_primitive_incomplete(RestAlts,Bin) + end; +decode_primitive_incomplete([[undec,_TagNo]|_RestTag],Bin) -> %incomlete decode + decode_incomplete_bin(Bin); %% use this if changing handling of +decode_primitive_incomplete([[parts,TagNo]|_RestTag],Bin) -> + case decode_tlv(Bin) of + {{_Form,TagNo,_Len,V},Rest} -> + {{TagNo,decode_parts_incomplete(V)},Rest}; + Err -> + {error,{asn1,"tag failure",TagNo,Err}} + end; +decode_primitive_incomplete([mandatory|RestTag],Bin) -> + case decode_tlv(Bin) of + {{Form,TagNo,Len,V},Rest} -> + decode_incomplete2(Form,TagNo,Len,V,RestTag,Rest); + _ -> + {error,{asn1,"partial incomplete decode failure"}} + end; +%% A choice that is a toptype or a mandatory component of a +%% SEQUENCE or SET. +decode_primitive_incomplete([[mandatory,Directives]],Bin) -> + case decode_tlv(Bin) of + {{Form,TagNo,Len,V},Rest} -> + decode_incomplete2(Form,TagNo,Len,V,Directives,Rest); + _ -> + {error,{asn1,"partial incomplete decode failure"}} + end; +decode_primitive_incomplete([],Bin) -> + decode_primitive(Bin). + +%% decode_parts_incomplete/1 receives a number of values encoded in +%% sequence and returns the parts as unencoded binaries +decode_parts_incomplete(<<>>) -> + []; +decode_parts_incomplete(Bin) -> + {ok,Rest} = skip_tag(Bin), + {ok,Rest2} = skip_length_and_value(Rest), + LenPart = size(Bin) - size(Rest2), + <<Part:LenPart/binary,RestBin/binary>> = Bin, + [Part|decode_parts_incomplete(RestBin)]. + + +%% decode_incomplete2 checks if V is a value of a constructed or +%% primitive type, and continues the decode propeerly. +decode_incomplete2(1,TagNo,indefinite,V,TagMatch,_) -> + %% constructed indefinite length + {Vlist,Rest2} = decode_constr_indef_incomplete(TagMatch,V,[]), + {{TagNo,Vlist},Rest2}; +decode_incomplete2(1,TagNo,_Len,V,TagMatch,Rest) -> + {{TagNo,decode_constructed_incomplete(TagMatch,V)},Rest}; +decode_incomplete2(0,TagNo,_Len,V,_TagMatch,Rest) -> + {{TagNo,V},Rest}. + +decode_constructed_incomplete(_TagMatch,<<>>) -> + []; +decode_constructed_incomplete([mandatory|RestTag],Bin) -> + {Tlv,Rest} = decode_primitive(Bin), + [Tlv|decode_constructed_incomplete(RestTag,Rest)]; +decode_constructed_incomplete(Directives=[[Alt,_]|_],Bin) + when Alt == alt_undec; Alt == alt -> + case decode_tlv(Bin) of + {{_Form,TagNo,_Len,V},Rest} -> + case incomplete_choice_alt(TagNo,Directives) of + alt_undec -> + LenA = size(Bin)-size(Rest), + <<A:LenA/binary,Rest/binary>> = Bin, + A; +% {UndecBin,_}=decode_incomplete_bin(Bin), +% UndecBin; +% [{TagNo,V}]; + alt -> + {Tlv,_} = decode_primitive(V), + [{TagNo,Tlv}]; + alt_parts -> + %{{TagNo,decode_parts_incomplete(V)},Rest}; % maybe wrong + [{TagNo,decode_parts_incomplete(V)}]; + Err -> + {error,{asn1,"partial incomplete decode failure",Err}} + end; + _ -> + {error,{asn1,"partial incomplete decode failure"}} + end; +decode_constructed_incomplete([TagNo|RestTag],Bin) -> +%% {Tlv,Rest} = decode_primitive_incomplete([TagNo],Bin), + case decode_primitive_incomplete([TagNo],Bin) of + {Tlv,Rest} -> + [Tlv|decode_constructed_incomplete(RestTag,Rest)]; + asn1_NOVALUE -> + decode_constructed_incomplete(RestTag,Bin) + end; +decode_constructed_incomplete([],Bin) -> + {Tlv,_Rest}=decode_primitive(Bin), + [Tlv]. + +decode_constr_indef_incomplete(_TagMatch,<<0,0,Rest/binary>>,Acc) -> + {lists:reverse(Acc),Rest}; +decode_constr_indef_incomplete([Tag|RestTags],Bin,Acc) -> +% {Tlv,Rest} = decode_primitive_incomplete([Tag],Bin), + case decode_primitive_incomplete([Tag],Bin) of + {Tlv,Rest} -> + decode_constr_indef_incomplete(RestTags,Rest,[Tlv|Acc]); + asn1_NOVALUE -> + decode_constr_indef_incomplete(RestTags,Bin,Acc) + end. + + +decode_incomplete_bin(Bin) -> + {ok,Rest} = skip_tag(Bin), + {ok,Rest2} = skip_length_and_value(Rest), + IncLen = size(Bin) - size(Rest2), + <<IncBin:IncLen/binary,Ret/binary>> = Bin, + {IncBin,Ret}. + +incomplete_choice_alt(TagNo,[[Alt,TagNo]|_Directives]) -> + Alt; +incomplete_choice_alt(TagNo,[_H|Directives]) -> + incomplete_choice_alt(TagNo,Directives); +incomplete_choice_alt(_,[]) -> + error. + + +%% skip_tag and skip_length_and_value are rutines used both by +%% decode_partial_incomplete and decode_partial (decode/2). + +skip_tag(<<_:3,31:5,Rest/binary>>)-> + skip_long_tag(Rest); +skip_tag(<<_:3,_Tag:5,Rest/binary>>) -> + {ok,Rest}. + +skip_long_tag(<<1:1,_:7,Rest/binary>>) -> + skip_long_tag(Rest); +skip_long_tag(<<0:1,_:7,Rest/binary>>) -> + {ok,Rest}. + +skip_length_and_value(Binary) -> + case decode_length(Binary) of + {indefinite,RestBinary} -> + skip_indefinite_value(RestBinary); + {Length,RestBinary} -> + <<_:Length/unit:8,Rest/binary>> = RestBinary, + {ok,Rest} + end. + +skip_indefinite_value(<<0,0,Rest/binary>>) -> + {ok,Rest}; +skip_indefinite_value(Binary) -> + {ok,RestBinary}=skip_tag(Binary), + {ok,RestBinary2} = skip_length_and_value(RestBinary), + skip_indefinite_value(RestBinary2). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% match_tags takes a Tlv (Tag, Length, Value) structure and matches +%% it with the tags in TagList. If the tags does not match the function +%% crashes otherwise it returns the remaining Tlv after that the tags have +%% been removed. +%% +%% match_tags(Tlv, TagList) +%% + + +match_tags({T,V}, [T|Tt]) -> + match_tags(V,Tt); +match_tags([{T,V}],[T|Tt]) -> + match_tags(V, Tt); +match_tags(Vlist = [{T,_V}|_], [T]) -> + Vlist; +match_tags(Tlv, []) -> + Tlv; +match_tags({Tag,_V},[T|_Tt]) -> + {error,{asn1,{wrong_tag,{Tag,T}}}}. + + +cindex(Ix,Val,Cname) -> + case element(Ix,Val) of + {Cname,Val2} -> Val2; + X -> X + end. + +%%=============================================================================== +%%=============================================================================== +%%=============================================================================== +%% Optionals, preset not filled optionals with asn1_NOVALUE +%%=============================================================================== +%%=============================================================================== +%%=============================================================================== + +% converts a list to a record if necessary +list_to_record(Name,List) when list(List) -> + list_to_tuple([Name|List]); +list_to_record(_Name,Tuple) when tuple(Tuple) -> + Tuple. + + +fixoptionals(OptList,Val) when list(Val) -> + fixoptionals(OptList,Val,1,[],[]). + +fixoptionals([{Name,Pos}|Ot],[{Name,Val}|Vt],_Opt,Acc1,Acc2) -> + fixoptionals(Ot,Vt,Pos+1,[1|Acc1],[{Name,Val}|Acc2]); +fixoptionals([{_Name,Pos}|Ot],V,Pos,Acc1,Acc2) -> + fixoptionals(Ot,V,Pos+1,[0|Acc1],[asn1_NOVALUE|Acc2]); +fixoptionals(O,[Vh|Vt],Pos,Acc1,Acc2) -> + fixoptionals(O,Vt,Pos+1,Acc1,[Vh|Acc2]); +fixoptionals([],[Vh|Vt],Pos,Acc1,Acc2) -> + fixoptionals([],Vt,Pos+1,Acc1,[Vh|Acc2]); +fixoptionals([],[],_,_Acc1,Acc2) -> + % return Val as a record + list_to_tuple([asn1_RECORDNAME|lists:reverse(Acc2)]). + + +%%encode_tag(TagClass(?UNI, APP etc), Form (?PRIM etx), TagInteger) -> +%% 8bit Int | binary +encode_tag_val({Class, Form, TagNo}) when (TagNo =< 30) -> + <<(Class bsr 6):2,(Form bsr 5):1,TagNo:5>>; + +encode_tag_val({Class, Form, TagNo}) -> + {Octets,_Len} = mk_object_val(TagNo), + BinOct = list_to_binary(Octets), + <<(Class bsr 6):2, (Form bsr 5):1, 31:5,BinOct/binary>>; + +%% asumes whole correct tag bitpattern, multiple of 8 +encode_tag_val(Tag) when (Tag =< 255) -> Tag; %% anv�nds denna funktion??!! +%% asumes correct bitpattern of 0-5 +encode_tag_val(Tag) -> encode_tag_val2(Tag,[]). + +encode_tag_val2(Tag, OctAck) when (Tag =< 255) -> + [Tag | OctAck]; +encode_tag_val2(Tag, OctAck) -> + encode_tag_val2(Tag bsr 8, [255 band Tag | OctAck]). + + +%%=============================================================================== +%% Decode a tag +%% +%% decode_tag(OctetListBuffer) -> {{Form, (Class bsl 16)+ TagNo}, RestOfBuffer, RemovedBytes} +%%=============================================================================== + +decode_tag_and_length(<<Class:2, Form:1, TagNo:5, 0:1, Length:7, RestBuffer/binary>>) when TagNo < 31 -> + {Form, (Class bsl 16) + TagNo, Length, RestBuffer}; +decode_tag_and_length(<<Class:2, Form:1, TagNo:5, 1:1, 0:7, T/binary>>) when TagNo < 31 -> + {Form, (Class bsl 16) + TagNo, indefinite, T}; +decode_tag_and_length(<<Class:2, Form:1, TagNo:5, 1:1, LL:7, T/binary>>) when TagNo < 31 -> + <<Length:LL/unit:8,RestBuffer/binary>> = T, + {Form, (Class bsl 16) + TagNo, Length, RestBuffer}; +decode_tag_and_length(<<Class:2, Form:1, 31:5, 0:1, TagNo:7, 0:1, Length:7, RestBuffer/binary>>) -> + {Form, (Class bsl 16) + TagNo, Length, RestBuffer}; +decode_tag_and_length(<<Class:2, Form:1, 31:5, 0:1, TagNo:7, 1:1, 0:7, T/binary>>) -> + {Form, (Class bsl 16) + TagNo, indefinite, T}; +decode_tag_and_length(<<Class:2, Form:1, 31:5, 0:1, TagNo:7, 1:1, LL:7, T/binary>>) -> + <<Length:LL/unit:8,RestBuffer/binary>> = T, + {Form, (Class bsl 16) + TagNo, Length, RestBuffer}; +decode_tag_and_length(<<Class:2, Form:1, 31:5, Buffer/binary>>) -> + {TagNo, Buffer1} = decode_tag(Buffer, 0), + {Length, RestBuffer} = decode_length(Buffer1), + {Form, (Class bsl 16) + TagNo, Length, RestBuffer}. + + + +%% last partial tag +decode_tag(<<0:1,PartialTag:7, Buffer/binary>>, TagAck) -> + TagNo = (TagAck bsl 7) bor PartialTag, + %%<<TagNo>> = <<TagAck:1, PartialTag:7>>, + {TagNo, Buffer}; +% more tags +decode_tag(<<_:1,PartialTag:7, Buffer/binary>>, TagAck) -> + TagAck1 = (TagAck bsl 7) bor PartialTag, + %%<<TagAck1:16>> = <<TagAck:1, PartialTag:7,0:8>>, + decode_tag(Buffer, TagAck1). + + +%%======================================================================= +%% +%% Encode all tags in the list Tags and return a possibly deep list of +%% bytes with tag and length encoded +%% The taglist must be in reverse order (fixed by the asn1 compiler) +%% e.g [T1,T2] will result in +%% {[EncodedT2,EncodedT1|BytesSoFar],LenSoFar+LenT2+LenT1} +%% + +encode_tags([Tag|Trest], BytesSoFar, LenSoFar) -> +% remove {Bytes1,L1} = encode_one_tag(Tag), + {Bytes2,L2} = encode_length(LenSoFar), + encode_tags(Trest, [Tag,Bytes2|BytesSoFar], + LenSoFar + size(Tag) + L2); +encode_tags([], BytesSoFar, LenSoFar) -> + {BytesSoFar,LenSoFar}. + +encode_tags(TagIn, {BytesSoFar,LenSoFar}) -> + encode_tags(TagIn, BytesSoFar, LenSoFar). + +% encode_one_tag(#tag{class=Class,number=No,type=Type, form = Form}) -> +% NewForm = case Type of +% 'EXPLICIT' -> +% ?CONSTRUCTED; +% _ -> +% Form +% end, +% Bytes = encode_tag_val({Class,NewForm,No}), +% {Bytes,size(Bytes)}. + + +%%=============================================================================== +%% +%% This comment is valid for all the encode/decode functions +%% +%% C = Constraint -> typically {'ValueRange',LowerBound,UpperBound} +%% used for PER-coding but not for BER-coding. +%% +%% Val = Value. If Val is an atom then it is a symbolic integer value +%% (i.e the atom must be one of the names in the NamedNumberList). +%% The NamedNumberList is used to translate the atom to an integer value +%% before encoding. +%% +%%=============================================================================== + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% encode_open_type(Value) -> io_list (i.e nested list with integers, binaries) +%% Value = list of bytes of an already encoded value (the list must be flat) +%% | binary + +%% +encode_open_type(Val) when list(Val) -> +% {Val,length(Val)}; + encode_open_type(list_to_binary(Val)); +encode_open_type(Val) -> + {Val, size(Val)}. + +%% +encode_open_type(Val, T) when list(Val) -> + encode_open_type(list_to_binary(Val),T); +encode_open_type(Val,[]) -> + {Val, size(Val)}; +encode_open_type(Val,Tag) -> + encode_tags(Tag,Val, size(Val)). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% decode_open_type(Tlv, TagIn) -> Value +%% Tlv = {Tag,V} | V where V -> binary() +%% TagIn = [TagVal] where TagVal -> int() +%% Value = binary with decoded data (which must be decoded again as some type) +%% +decode_open_type(Tlv, TagIn) -> + case match_tags(Tlv,TagIn) of + Bin when binary(Bin) -> + {InnerTlv,_} = decode(Bin), + InnerTlv; + TlvBytes -> TlvBytes + end. + + +decode_open_type_as_binary(Tlv,TagIn)-> + case match_tags(Tlv,TagIn) of + V when binary(V) -> + V; + [Tlv2] -> encode(Tlv2); + Tlv2 -> encode(Tlv2) + end. + +%%=============================================================================== +%%=============================================================================== +%%=============================================================================== +%% Boolean, ITU_T X.690 Chapter 8.2 +%%=============================================================================== +%%=============================================================================== +%%=============================================================================== + +%%=============================================================================== +%% encode_boolean(Integer, ReversedTagList) -> {[Octet],Len} +%%=============================================================================== + +encode_boolean({Name, Val}, TagIn) when atom(Name) -> + encode_boolean(Val, TagIn); +encode_boolean(true, TagIn) -> + encode_tags(TagIn, [16#FF],1); +encode_boolean(false, TagIn) -> + encode_tags(TagIn, [0],1); +encode_boolean(X,_) -> + exit({error,{asn1, {encode_boolean, X}}}). + + +%%=============================================================================== +%% decode_boolean(BuffList, HasTag, TotalLen) -> {true, Remain, RemovedBytes} | +%% {false, Remain, RemovedBytes} +%%=============================================================================== +decode_boolean(Tlv,TagIn) -> + Val = match_tags(Tlv, TagIn), + case Val of + <<0:8>> -> + false; + <<_:8>> -> + true; + _ -> + exit({error,{asn1, {decode_boolean, Val}}}) + end. + + +%%=========================================================================== +%% Integer, ITU_T X.690 Chapter 8.3 + +%% encode_integer(Constraint, Value, Tag) -> [octet list] +%% encode_integer(Constraint, Name, NamedNumberList, Tag) -> [octet list] +%% Value = INTEGER | {Name,INTEGER} +%% Tag = tag | notag +%%=========================================================================== + +encode_integer(C, Val, Tag) when integer(Val) -> + encode_tags(Tag, encode_integer(C, Val)); +encode_integer(C,{Name,Val},Tag) when atom(Name) -> + encode_integer(C,Val,Tag); +encode_integer(_C, Val, _Tag) -> + exit({error,{asn1, {encode_integer, Val}}}). + + + +encode_integer(C, Val, NamedNumberList, Tag) when atom(Val) -> + case lists:keysearch(Val, 1, NamedNumberList) of + {value,{_, NewVal}} -> + encode_tags(Tag, encode_integer(C, NewVal)); + _ -> + exit({error,{asn1, {encode_integer_namednumber, Val}}}) + end; +encode_integer(C,{_Name,Val},NamedNumberList,Tag) -> + encode_integer(C,Val,NamedNumberList,Tag); +encode_integer(C, Val, _NamedNumberList, Tag) -> + encode_tags(Tag, encode_integer(C, Val)). + + +encode_integer(_, Val) -> + Bytes = + if + Val >= 0 -> + encode_integer_pos(Val, []); + true -> + encode_integer_neg(Val, []) + end, + {Bytes,length(Bytes)}. + +encode_integer_pos(0, L=[B|_Acc]) when B < 128 -> + L; +encode_integer_pos(N, Acc) -> + encode_integer_pos((N bsr 8), [N band 16#ff| Acc]). + +encode_integer_neg(-1, L=[B1|_T]) when B1 > 127 -> + L; +encode_integer_neg(N, Acc) -> + encode_integer_neg(N bsr 8, [N band 16#ff|Acc]). + +%%=============================================================================== +%% decode integer +%% (Buffer, Range, HasTag, TotalLen) -> {Integer, Remain, RemovedBytes} +%% (Buffer, Range, NamedNumberList, HasTag, TotalLen) -> {Integer, Remain, RemovedBytes} +%%=============================================================================== + +decode_integer(Tlv,Range,NamedNumberList,TagIn) -> + V = match_tags(Tlv,TagIn), + Int = decode_integer(V), + range_check_integer(Int,Range), + number2name(Int,NamedNumberList). + +decode_integer(Tlv,Range,TagIn) -> + V = match_tags(Tlv, TagIn), + Int = decode_integer(V), + range_check_integer(Int,Range), + Int. + +%% decoding postitive integer values. +decode_integer(Bin = <<0:1,_:7,_/binary>>) -> + Len = size(Bin), +% <<Int:Len/unit:8,Buffer2/binary>> = Bin, + <<Int:Len/unit:8>> = Bin, + Int; +%% decoding negative integer values. +decode_integer(Bin = <<1:1,B2:7,Bs/binary>>) -> + Len = size(Bin), +% <<N:Len/unit:8,Buffer2/binary>> = <<B2,Bs/binary>>, + <<N:Len/unit:8>> = <<B2,Bs/binary>>, + Int = N - (1 bsl (8 * Len - 1)), + Int. + +range_check_integer(Int,Range) -> + case Range of + [] -> % No length constraint + Int; + {Lb,Ub} when Int >= Lb, Ub >= Int -> % variable length constraint + Int; + Int -> % fixed value constraint + Int; + {_,_} -> + exit({error,{asn1,{integer_range,Range,Int}}}); + SingleValue when integer(SingleValue) -> + exit({error,{asn1,{integer_range,Range,Int}}}); + _ -> % some strange constraint that we don't support yet + Int + end. + +number2name(Int,[]) -> + Int; +number2name(Int,NamedNumberList) -> + case lists:keysearch(Int, 2, NamedNumberList) of + {value,{NamedVal, _}} -> + NamedVal; + _ -> + Int + end. + + +%%============================================================================ +%% Enumerated value, ITU_T X.690 Chapter 8.4 + +%% encode enumerated value +%%============================================================================ +encode_enumerated(Val, TagIn) when integer(Val)-> + encode_tags(TagIn, encode_integer(false,Val)); +encode_enumerated({Name,Val}, TagIn) when atom(Name) -> + encode_enumerated(Val, TagIn). + +%% The encode_enumerated functions below this line can be removed when the +%% new code generation is stable. (the functions might have to be kept here +%% a while longer for compatibility reasons) + +encode_enumerated(C, Val, {NamedNumberList,ExtList}, TagIn) when atom(Val) -> + case catch encode_enumerated(C, Val, NamedNumberList, TagIn) of + {'EXIT',_} -> encode_enumerated(C, Val, ExtList, TagIn); + Result -> Result + end; + +encode_enumerated(C, Val, NamedNumberList, TagIn) when atom(Val) -> + case lists:keysearch(Val, 1, NamedNumberList) of + {value, {_, NewVal}} -> + encode_tags(TagIn, encode_integer(C, NewVal)); + _ -> + exit({error,{asn1, {enumerated_not_in_range, Val}}}) + end; + +encode_enumerated(C, {asn1_enum, Val}, {_,_}, TagIn) when integer(Val) -> + encode_tags(TagIn, encode_integer(C,Val)); + +encode_enumerated(C, {Name,Val}, NamedNumberList, TagIn) when atom(Name) -> + encode_enumerated(C, Val, NamedNumberList, TagIn); + +encode_enumerated(_C, Val, _NamedNumberList, _TagIn) -> + exit({error,{asn1, {enumerated_not_namednumber, Val}}}). + + + +%%============================================================================ +%% decode enumerated value +%% (Buffer, Range, NamedNumberList, HasTag, TotalLen) -> Value +%%=========================================================================== +decode_enumerated(Tlv, Range, NamedNumberList, Tags) -> + Buffer = match_tags(Tlv,Tags), + decode_enumerated_notag(Buffer, Range, NamedNumberList, Tags). + +decode_enumerated_notag(Buffer, _Range, {NamedNumberList,ExtList}, _Tags) -> + + IVal = decode_integer2(size(Buffer), Buffer), + case decode_enumerated1(IVal, NamedNumberList) of + {asn1_enum,IVal} -> + decode_enumerated1(IVal,ExtList); + EVal -> + EVal + end; +decode_enumerated_notag(Buffer, _Range, NNList, _Tags) -> + IVal = decode_integer2(size(Buffer), Buffer), + case decode_enumerated1(IVal, NNList) of + {asn1_enum,_} -> + exit({error,{asn1, {illegal_enumerated, IVal}}}); + EVal -> + EVal + end. + +decode_enumerated1(Val, NamedNumberList) -> + %% it must be a named integer + case lists:keysearch(Val, 2, NamedNumberList) of + {value,{NamedVal, _}} -> + NamedVal; + _ -> + {asn1_enum,Val} + end. + + +%%============================================================================ +%% +%% Real value, ITU_T X.690 Chapter 8.5 +%%============================================================================ +%% +%% encode real value +%%============================================================================ + +%% only base 2 internally so far!! +encode_real(0, TagIn) -> + encode_tags(TagIn, {[],0}); +encode_real('PLUS-INFINITY', TagIn) -> + encode_tags(TagIn, {[64],1}); +encode_real('MINUS-INFINITY', TagIn) -> + encode_tags(TagIn, {[65],1}); +encode_real(Val, TagIn) when tuple(Val)-> + encode_tags(TagIn, encode_real(Val)). + +%%%%%%%%%%%%%% +%% not optimal efficient.. +%% only base 2 of Mantissa encoding! +%% only base 2 of ExpBase encoding! +encode_real({Man, Base, Exp}) -> +%% io:format("Mantissa: ~w Base: ~w, Exp: ~w~n",[Man, Base, Exp]), + + OctExp = if Exp >= 0 -> list_to_binary(encode_integer_pos(Exp, [])); + true -> list_to_binary(encode_integer_neg(Exp, [])) + end, +%% ok = io:format("OctExp: ~w~n",[OctExp]), + SignBit = if Man > 0 -> 0; % bit 7 is pos or neg, no Zeroval + true -> 1 + end, +%% ok = io:format("SignBitMask: ~w~n",[SignBitMask]), + InBase = if Base =:= 2 -> 0; % bit 6,5: only base 2 this far! + true -> + exit({error,{asn1, {encode_real_non_supported_encodeing, Base}}}) + end, + SFactor = 0, % bit 4,3: no scaling since only base 2 + OctExpLen = size(OctExp), + if OctExpLen > 255 -> + exit({error,{asn1, {to_big_exp_in_encode_real, OctExpLen}}}); + true -> true %% make real assert later.. + end, + {LenCode, EOctets} = case OctExpLen of % bit 2,1 + 1 -> {0, OctExp}; + 2 -> {1, OctExp}; + 3 -> {2, OctExp}; + _ -> {3, <<OctExpLen, OctExp/binary>>} + end, + FirstOctet = <<1:1,SignBit:1,InBase:2,SFactor:2,LenCode:2>>, + OctMantissa = if Man > 0 -> list_to_binary(minimum_octets(Man)); + true -> list_to_binary(minimum_octets(-(Man))) % signbit keeps track of sign + end, + %% ok = io:format("LenMask: ~w EOctets: ~w~nFirstOctet: ~w OctMantissa: ~w OctExpLen: ~w~n", [LenMask, EOctets, FirstOctet, OctMantissa, OctExpLen]), + Bin = <<FirstOctet/binary, EOctets/binary, OctMantissa/binary>>, + {Bin, size(Bin)}. + + +%%============================================================================ +%% decode real value +%% +%% decode_real([OctetBufferList], tuple|value, tag|notag) -> +%% {{Mantissa, Base, Exp} | realval | PLUS-INFINITY | MINUS-INFINITY | 0, +%% RestBuff} +%% +%% only for base 2 decoding sofar!! +%%============================================================================ + +decode_real(Tlv, Form, Tags) -> + Buffer = match_tags(Tlv,Tags), + decode_real_notag(Buffer, Form). + +decode_real_notag(_Buffer, _Form) -> + exit({error,{asn1, {unimplemented,real}}}). +%% decode_real2(Buffer, Form, size(Buffer)). + +% decode_real2(Buffer, Form, Len) -> +% <<First, Buffer2/binary>> = Buffer, +% if +% First =:= 2#01000000 -> {'PLUS-INFINITY', Buffer2}; +% First =:= 2#01000001 -> {'MINUS-INFINITY', Buffer2}; +% First =:= 2#00000000 -> {0, Buffer2}; +% true -> +% %% have some check here to verify only supported bases (2) +% <<B7:1,B6:1,B5_4:2,B3_2:2,B1_0:2>> = <<First>>, +% Sign = B6, +% Base = +% case B5_4 of +% 0 -> 2; % base 2, only one so far +% _ -> exit({error,{asn1, {non_supported_base, First}}}) +% end, +% ScalingFactor = +% case B3_2 of +% 0 -> 0; % no scaling so far +% _ -> exit({error,{asn1, {non_supported_scaling, First}}}) +% end, + +% {FirstLen,Exp,Buffer3} = +% case B1_0 of +% 0 -> +% <<_:1/unit:8,Buffer21/binary>> = Buffer2, +% {2, decode_integer2(1, Buffer2),Buffer21}; +% 1 -> +% <<_:2/unit:8,Buffer21/binary>> = Buffer2, +% {3, decode_integer2(2, Buffer2)}; +% 2 -> +% <<_:3/unit:8,Buffer21/binary>> = Buffer2, +% {4, decode_integer2(3, Buffer2)}; +% 3 -> +% <<ExpLen1,RestBuffer/binary>> = Buffer2, +% <<_:ExpLen1/unit:8,RestBuffer2/binary>> = RestBuffer, +% { ExpLen1 + 2, +% decode_integer2(ExpLen1, RestBuffer, RemBytes1), +% RestBuffer2} +% end, +% Length = Len - FirstLen, +% <<LongInt:Length/unit:8,RestBuff/binary>> = Buffer3, +% {Mantissa, Buffer4} = +% if Sign =:= 0 -> + +% {LongInt, RestBuff};% sign plus, +% true -> + +% {-LongInt, RestBuff}% sign minus +% end, +% case Form of +% tuple -> +% {Val,Buf,RemB} = Exp, +% {{Mantissa, Base, {Val,Buf}}, Buffer4, RemBytes2+RemBytes3}; +% _value -> +% comming +% end +% end. + + +%%============================================================================ +%% Bitstring value, ITU_T X.690 Chapter 8.6 +%% +%% encode bitstring value +%% +%% bitstring NamedBitList +%% Val can be of: +%% - [identifiers] where only named identifers are set to one, +%% the Constraint must then have some information of the +%% bitlength. +%% - [list of ones and zeroes] all bits +%% - integer value representing the bitlist +%% C is constrint Len, only valid when identifiers +%%============================================================================ + +encode_bit_string(C,Bin={Unused,BinBits},NamedBitList,TagIn) when integer(Unused), binary(BinBits) -> + encode_bin_bit_string(C,Bin,NamedBitList,TagIn); +encode_bit_string(C, [FirstVal | RestVal], NamedBitList, TagIn) when atom(FirstVal) -> + encode_bit_string_named(C, [FirstVal | RestVal], NamedBitList, TagIn); + +encode_bit_string(C, [{bit,X} | RestVal], NamedBitList, TagIn) -> + encode_bit_string_named(C, [{bit,X} | RestVal], NamedBitList, TagIn); + +encode_bit_string(C, [FirstVal| RestVal], NamedBitList, TagIn) when integer(FirstVal) -> + encode_bit_string_bits(C, [FirstVal | RestVal], NamedBitList, TagIn); + +encode_bit_string(_C, 0, _NamedBitList, TagIn) -> + encode_tags(TagIn, <<0>>,1); + +encode_bit_string(_C, [], _NamedBitList, TagIn) -> + encode_tags(TagIn, <<0>>,1); + +encode_bit_string(C, IntegerVal, NamedBitList, TagIn) when integer(IntegerVal) -> + BitListVal = int_to_bitlist(IntegerVal), + encode_bit_string_bits(C, BitListVal, NamedBitList, TagIn); + +encode_bit_string(C, {Name,BitList}, NamedBitList, TagIn) when atom(Name) -> + encode_bit_string(C, BitList, NamedBitList, TagIn). + + + +int_to_bitlist(0) -> + []; +int_to_bitlist(Int) when integer(Int), Int >= 0 -> + [Int band 1 | int_to_bitlist(Int bsr 1)]. + + +%%================================================================= +%% Encode BIT STRING of the form {Unused,BinBits}. +%% Unused is the number of unused bits in the last byte in BinBits +%% and BinBits is a binary representing the BIT STRING. +%%================================================================= +encode_bin_bit_string(C,{Unused,BinBits},_NamedBitList,TagIn)-> + case get_constraint(C,'SizeConstraint') of + no -> + remove_unused_then_dotag(TagIn, Unused, BinBits); + {_Min,Max} -> + BBLen = (size(BinBits)*8)-Unused, + if + BBLen > Max -> + exit({error,{asn1, + {bitstring_length, + {{was,BBLen},{maximum,Max}}}}}); + true -> + remove_unused_then_dotag(TagIn, Unused, BinBits) + end; + Size -> + case ((size(BinBits)*8)-Unused) of + BBSize when BBSize =< Size -> + remove_unused_then_dotag(TagIn, Unused, BinBits); + BBSize -> + exit({error,{asn1, + {bitstring_length, + {{was,BBSize},{should_be,Size}}}}}) + end + end. + +remove_unused_then_dotag(TagIn,Unused,BinBits) -> + case Unused of + 0 when (size(BinBits) == 0) -> + encode_tags(TagIn,<<0>>,1); + 0 -> + Bin = <<Unused,BinBits/binary>>, + encode_tags(TagIn,Bin,size(Bin)); + Num -> + N = (size(BinBits)-1), + <<BBits:N/binary,LastByte>> = BinBits, + encode_tags(TagIn, + [Unused,binary_to_list(BBits) ++[(LastByte bsr Num) bsl Num]], + 1+size(BinBits)) + end. + + +%%================================================================= +%% Encode named bits +%%================================================================= + +encode_bit_string_named(C, [FirstVal | RestVal], NamedBitList, TagIn) -> + ToSetPos = get_all_bitposes([FirstVal | RestVal], NamedBitList, []), + Size = + case get_constraint(C,'SizeConstraint') of + no -> + lists:max(ToSetPos)+1; + {_Min,Max} -> + Max; + TSize -> + TSize + end, + BitList = make_and_set_list(Size, ToSetPos, 0), + {Len, Unused, OctetList} = encode_bitstring(BitList), + encode_tags(TagIn, [Unused|OctetList],Len+1). + + +%%---------------------------------------- +%% get_all_bitposes([list of named bits to set], named_bit_db, []) -> +%% [sorted_list_of_bitpositions_to_set] +%%---------------------------------------- + +get_all_bitposes([{bit,ValPos}|Rest], NamedBitList, Ack) -> + get_all_bitposes(Rest, NamedBitList, [ValPos | Ack ]); +get_all_bitposes([Val | Rest], NamedBitList, Ack) when atom(Val) -> + case lists:keysearch(Val, 1, NamedBitList) of + {value, {_ValName, ValPos}} -> + get_all_bitposes(Rest, NamedBitList, [ValPos | Ack]); + _ -> + exit({error,{asn1, {bitstring_namedbit, Val}}}) + end; +get_all_bitposes([], _NamedBitList, Ack) -> + lists:sort(Ack). + + +%%---------------------------------------- +%% make_and_set_list(Len of list to return, [list of positions to set to 1])-> +%% returns list of Len length, with all in SetPos set. +%% in positioning in list the first element is 0, the second 1 etc.., but +%% Len will make a list of length Len, not Len + 1. +%% BitList = make_and_set_list(C, ToSetPos, 0), +%%---------------------------------------- + +make_and_set_list(0, [], _) -> []; +make_and_set_list(0, _, _) -> + exit({error,{asn1,bitstring_sizeconstraint}}); +make_and_set_list(Len, [XPos|SetPos], XPos) -> + [1 | make_and_set_list(Len - 1, SetPos, XPos + 1)]; +make_and_set_list(Len, [Pos|SetPos], XPos) -> + [0 | make_and_set_list(Len - 1, [Pos | SetPos], XPos + 1)]; +make_and_set_list(Len, [], XPos) -> + [0 | make_and_set_list(Len - 1, [], XPos + 1)]. + + + + + + +%%================================================================= +%% Encode bit string for lists of ones and zeroes +%%================================================================= +encode_bit_string_bits(C, BitListVal, _NamedBitList, TagIn) when list(BitListVal) -> + case get_constraint(C,'SizeConstraint') of + no -> + {Len, Unused, OctetList} = encode_bitstring(BitListVal), + %%add unused byte to the Len + encode_tags(TagIn, [Unused | OctetList], Len+1); + Constr={Min,Max} when integer(Min),integer(Max) -> + encode_constr_bit_str_bits(Constr,BitListVal,TagIn); + {Constr={_,_},[]} ->%Constr={Min,Max} + %% constraint with extension mark + encode_constr_bit_str_bits(Constr,BitListVal,TagIn); + Constr={{_,_},{_,_}} ->%{{Min1,Max1},{Min2,Max2}} + %% constraint with extension mark + encode_constr_bit_str_bits(Constr,BitListVal,TagIn); + Size -> + case length(BitListVal) of + BitSize when BitSize == Size -> + {Len, Unused, OctetList} = encode_bitstring(BitListVal), + %%add unused byte to the Len + encode_tags(TagIn, [Unused | OctetList], Len+1); + BitSize when BitSize < Size -> + PaddedList = pad_bit_list(Size-BitSize,BitListVal), + {Len, Unused, OctetList} = encode_bitstring(PaddedList), + %%add unused byte to the Len + encode_tags(TagIn, [Unused | OctetList], Len+1); + BitSize -> + exit({error,{asn1, + {bitstring_length, {{was,BitSize},{should_be,Size}}}}}) + end + + end. + +encode_constr_bit_str_bits({_Min,Max},BitListVal,TagIn) -> + BitLen = length(BitListVal), + if + BitLen > Max -> + exit({error,{asn1,{bitstring_length,{{was,BitLen}, + {maximum,Max}}}}}); + true -> + {Len, Unused, OctetList} = encode_bitstring(BitListVal), + %%add unused byte to the Len + encode_tags(TagIn, [Unused, OctetList], Len+1) + end; +encode_constr_bit_str_bits({{_Min1,Max1},{Min2,Max2}},BitListVal,TagIn) -> + BitLen = length(BitListVal), + case BitLen of + Len when Len > Max2 -> + exit({error,{asn1,{bitstring_length,{{was,BitLen}, + {maximum,Max2}}}}}); + Len when Len > Max1, Len < Min2 -> + exit({error,{asn1,{bitstring_length,{{was,BitLen}, + {not_allowed_interval, + Max1,Min2}}}}}); + _ -> + {Len, Unused, OctetList} = encode_bitstring(BitListVal), + %%add unused byte to the Len + encode_tags(TagIn, [Unused, OctetList], Len+1) + end. + +%% returns a list of length Size + length(BitListVal), with BitListVal +%% as the most significant elements followed by padded zero elements +pad_bit_list(Size,BitListVal) -> + Tail = lists:duplicate(Size,0), + lists:append(BitListVal,Tail). + +%%================================================================= +%% Do the actual encoding +%% ([bitlist]) -> {ListLen, UnusedBits, OctetList} +%%================================================================= + +encode_bitstring([B8, B7, B6, B5, B4, B3, B2, B1 | Rest]) -> + Val = (B8 bsl 7) bor (B7 bsl 6) bor (B6 bsl 5) bor (B5 bsl 4) bor + (B4 bsl 3) bor (B3 bsl 2) bor (B2 bsl 1) bor B1, + encode_bitstring(Rest, [Val], 1); +encode_bitstring(Val) -> + {Unused, Octet} = unused_bitlist(Val, 7, 0), + {1, Unused, [Octet]}. + +encode_bitstring([B8, B7, B6, B5, B4, B3, B2, B1 | Rest], Ack, Len) -> + Val = (B8 bsl 7) bor (B7 bsl 6) bor (B6 bsl 5) bor (B5 bsl 4) bor + (B4 bsl 3) bor (B3 bsl 2) bor (B2 bsl 1) bor B1, + encode_bitstring(Rest, [Ack | [Val]], Len + 1); +%%even multiple of 8 bits.. +encode_bitstring([], Ack, Len) -> + {Len, 0, Ack}; +%% unused bits in last octet +encode_bitstring(Rest, Ack, Len) -> +% io:format("uneven ~w ~w ~w~n",[Rest, Ack, Len]), + {Unused, Val} = unused_bitlist(Rest, 7, 0), + {Len + 1, Unused, [Ack | [Val]]}. + +%%%%%%%%%%%%%%%%%% +%% unused_bitlist([list of ones and zeros <= 7], 7, []) -> +%% {Unused bits, Last octet with bits moved to right} +unused_bitlist([], Trail, Ack) -> + {Trail + 1, Ack}; +unused_bitlist([Bit | Rest], Trail, Ack) -> +%% io:format("trail Bit: ~w Rest: ~w Trail: ~w Ack:~w~n",[Bit, Rest, Trail, Ack]), + unused_bitlist(Rest, Trail - 1, (Bit bsl Trail) bor Ack). + + +%%============================================================================ +%% decode bitstring value +%% (Buffer, Range, NamedNumberList, HasTag, TotalLen) -> {Integer, Remain, RemovedBytes} +%%============================================================================ + +decode_compact_bit_string(Buffer, Range, NamedNumberList, Tags) -> +% NewTags = new_tags(HasTag,#tag{class=?UNIVERSAL,number=?N_BIT_STRING}), + decode_restricted_string(Buffer, Range, ?N_BIT_STRING, Tags, + NamedNumberList,bin). + +decode_bit_string(Buffer, Range, NamedNumberList, Tags) -> +% NewTags = new_tags(HasTag,#tag{class=?UNIVERSAL,number=?N_BIT_STRING}), + decode_restricted_string(Buffer, Range, ?N_BIT_STRING, Tags, + NamedNumberList,old). + + +decode_bit_string2(<<0>>,_NamedNumberList,BinOrOld) -> + case BinOrOld of + bin -> + {0,<<>>}; + _ -> + [] + end; +decode_bit_string2(<<Unused,Bits/binary>>,NamedNumberList,BinOrOld) -> + case NamedNumberList of + [] -> + case BinOrOld of + bin -> + {Unused,Bits}; + _ -> + decode_bitstring2(size(Bits), Unused, Bits) + end; + _ -> + BitString = decode_bitstring2(size(Bits), Unused, Bits), + decode_bitstring_NNL(BitString,NamedNumberList) + end. + +%%---------------------------------------- +%% Decode the in buffer to bits +%%---------------------------------------- +decode_bitstring2(1,Unused,<<B7:1,B6:1,B5:1,B4:1,B3:1,B2:1,B1:1,B0:1,_/binary>>) -> + lists:sublist([B7,B6,B5,B4,B3,B2,B1,B0],8-Unused); +decode_bitstring2(Len, Unused, + <<B7:1,B6:1,B5:1,B4:1,B3:1,B2:1,B1:1,B0:1,Buffer/binary>>) -> + [B7, B6, B5, B4, B3, B2, B1, B0 | + decode_bitstring2(Len - 1, Unused, Buffer)]. + +%%decode_bitstring2(1, Unused, Buffer) -> +%% make_bits_of_int(hd(Buffer), 128, 8-Unused); +%%decode_bitstring2(Len, Unused, [BitVal | Buffer]) -> +%% [B7, B6, B5, B4, B3, B2, B1, B0] = make_bits_of_int(BitVal, 128, 8), +%% [B7, B6, B5, B4, B3, B2, B1, B0 | +%% decode_bitstring2(Len - 1, Unused, Buffer)]. + + +%%make_bits_of_int(_, _, 0) -> +%% []; +%%make_bits_of_int(BitVal, MaskVal, Unused) when Unused > 0 -> +%% X = case MaskVal band BitVal of +%% 0 -> 0 ; +%% _ -> 1 +%% end, +%% [X | make_bits_of_int(BitVal, MaskVal bsr 1, Unused - 1)]. + + + +%%---------------------------------------- +%% Decode the bitlist to names +%%---------------------------------------- + + +decode_bitstring_NNL(BitList,NamedNumberList) -> + decode_bitstring_NNL(BitList,NamedNumberList,0,[]). + + +decode_bitstring_NNL([],_,_No,Result) -> + lists:reverse(Result); + +decode_bitstring_NNL([B|BitList],[{Name,No}|NamedNumberList],No,Result) -> + if + B == 0 -> + decode_bitstring_NNL(BitList,NamedNumberList,No+1,Result); + true -> + decode_bitstring_NNL(BitList,NamedNumberList,No+1,[Name|Result]) + end; +decode_bitstring_NNL([1|BitList],NamedNumberList,No,Result) -> + decode_bitstring_NNL(BitList,NamedNumberList,No+1,[{bit,No}|Result]); +decode_bitstring_NNL([0|BitList],NamedNumberList,No,Result) -> + decode_bitstring_NNL(BitList,NamedNumberList,No+1,Result). + + +%%============================================================================ +%% Octet string, ITU_T X.690 Chapter 8.7 +%% +%% encode octet string +%% The OctetList must be a flat list of integers in the range 0..255 +%% the function does not check this because it takes to much time +%%============================================================================ +encode_octet_string(_C, OctetList, TagIn) when binary(OctetList) -> + encode_tags(TagIn, OctetList, size(OctetList)); +encode_octet_string(_C, OctetList, TagIn) when list(OctetList) -> + encode_tags(TagIn, OctetList, length(OctetList)); +encode_octet_string(C, {Name,OctetList}, TagIn) when atom(Name) -> + encode_octet_string(C, OctetList, TagIn). + + +%%============================================================================ +%% decode octet string +%% (Buffer, Range, HasTag, TotalLen) -> {String, Remain, RemovedBytes} +%% +%% Octet string is decoded as a restricted string +%%============================================================================ +decode_octet_string(Buffer, Range, Tags) -> +% NewTags = new_tags(HasTag,#tag{class=?UNIVERSAL,number=?N_OCTET_STRING}), + decode_restricted_string(Buffer, Range, ?N_OCTET_STRING, + Tags, [], old). + +%%============================================================================ +%% Null value, ITU_T X.690 Chapter 8.8 +%% +%% encode NULL value +%%============================================================================ + +encode_null({Name, _Val}, TagIn) when atom(Name) -> + encode_tags(TagIn, [], 0); +encode_null(_Val, TagIn) -> + encode_tags(TagIn, [], 0). + +%%============================================================================ +%% decode NULL value +%% (Buffer, HasTag, TotalLen) -> {NULL, Remain, RemovedBytes} +%%============================================================================ + +decode_null(Tlv, Tags) -> + Val = match_tags(Tlv, Tags), + case Val of + <<>> -> + 'NULL'; + _ -> + exit({error,{asn1,{decode_null,Val}}}) + end. + +%%============================================================================ +%% Object identifier, ITU_T X.690 Chapter 8.19 +%% +%% encode Object Identifier value +%%============================================================================ + +encode_object_identifier({Name,Val}, TagIn) when atom(Name) -> + encode_object_identifier(Val, TagIn); +encode_object_identifier(Val, TagIn) -> + encode_tags(TagIn, e_object_identifier(Val)). + +e_object_identifier({'OBJECT IDENTIFIER', V}) -> + e_object_identifier(V); +e_object_identifier({Cname, V}) when atom(Cname), tuple(V) -> + e_object_identifier(tuple_to_list(V)); +e_object_identifier({Cname, V}) when atom(Cname), list(V) -> + e_object_identifier(V); +e_object_identifier(V) when tuple(V) -> + e_object_identifier(tuple_to_list(V)); + +%%%%%%%%%%%%%%% +%% e_object_identifier([List of Obect Identifiers]) -> +%% {[Encoded Octetlist of ObjIds], IntLength} +%% +e_object_identifier([E1, E2 | Tail]) -> + Head = 40*E1 + E2, % wow! + {H,Lh} = mk_object_val(Head), + {R,Lr} = enc_obj_id_tail(Tail, [], 0), + {[H|R], Lh+Lr}. + +enc_obj_id_tail([], Ack, Len) -> + {lists:reverse(Ack), Len}; +enc_obj_id_tail([H|T], Ack, Len) -> + {B, L} = mk_object_val(H), + enc_obj_id_tail(T, [B|Ack], Len+L). + +%% e_object_identifier([List of Obect Identifiers]) -> +%% {[Encoded Octetlist of ObjIds], IntLength} +%% +%%e_object_identifier([E1, E2 | Tail]) -> +%% Head = 40*E1 + E2, % wow! +%% F = fun(Val, AckLen) -> +%% {L, Ack} = mk_object_val(Val), +%% {L, Ack + AckLen} +%% end, +%% {Octets, Len} = lists:mapfoldl(F, 0, [Head | Tail]). + +%%%%%%%%%%% +%% mk_object_val(Value) -> {OctetList, Len} +%% returns a Val as a list of octets, the 8 bit is allways set to one except +%% for the last octet, where its 0 +%% + + +mk_object_val(Val) when Val =< 127 -> + {[255 band Val], 1}; +mk_object_val(Val) -> + mk_object_val(Val bsr 7, [Val band 127], 1). +mk_object_val(0, Ack, Len) -> + {Ack, Len}; +mk_object_val(Val, Ack, Len) -> + mk_object_val(Val bsr 7, [((Val band 127) bor 128) | Ack], Len + 1). + + + +%%============================================================================ +%% decode Object Identifier value +%% (Buffer, HasTag, TotalLen) -> {{ObjId}, Remain, RemovedBytes} +%%============================================================================ + +decode_object_identifier(Tlv, Tags) -> + Val = match_tags(Tlv, Tags), + [AddedObjVal|ObjVals] = dec_subidentifiers(Val,0,[]), + {Val1, Val2} = if + AddedObjVal < 40 -> + {0, AddedObjVal}; + AddedObjVal < 80 -> + {1, AddedObjVal - 40}; + true -> + {2, AddedObjVal - 80} + end, + list_to_tuple([Val1, Val2 | ObjVals]). + +dec_subidentifiers(<<>>,_Av,Al) -> + lists:reverse(Al); +dec_subidentifiers(<<1:1,H:7,T/binary>>,Av,Al) -> + dec_subidentifiers(T,(Av bsl 7) + H,Al); +dec_subidentifiers(<<H,T/binary>>,Av,Al) -> + dec_subidentifiers(T,0,[((Av bsl 7) + H)|Al]). + + +%%============================================================================ +%% Restricted character string types, ITU_T X.690 Chapter 8.20 +%% +%% encode Numeric Printable Teletex Videotex Visible IA5 Graphic General strings +%%============================================================================ +%% The StringType arg is kept for future use but might be removed +encode_restricted_string(_C, OctetList, _StringType, TagIn) + when binary(OctetList) -> + encode_tags(TagIn, OctetList, size(OctetList)); +encode_restricted_string(_C, OctetList, _StringType, TagIn) + when list(OctetList) -> + encode_tags(TagIn, OctetList, length(OctetList)); +encode_restricted_string(C,{Name,OctetL}, StringType, TagIn) when atom(Name)-> + encode_restricted_string(C, OctetL, StringType, TagIn). + +%%============================================================================ +%% decode Numeric Printable Teletex Videotex Visible IA5 Graphic General strings +%% (Buffer, Range, StringType, HasTag, TotalLen) -> +%% {String, Remain, RemovedBytes} +%%============================================================================ + +decode_restricted_string(Buffer, Range, StringType, Tags) -> + decode_restricted_string(Buffer, Range, StringType, Tags, [], old). + + +decode_restricted_string(Tlv, Range, StringType, TagsIn, + NamedNumberList, BinOrOld) -> + Val = match_tags(Tlv, TagsIn), + Val2 = + case Val of + PartList = [_H|_T] -> % constructed val + Bin = collect_parts(PartList), + decode_restricted(Bin, StringType, + NamedNumberList, BinOrOld); + Bin -> + decode_restricted(Bin, StringType, + NamedNumberList, BinOrOld) + end, + check_and_convert_restricted_string(Val2,StringType,Range,NamedNumberList,BinOrOld). + + + +% case StringType of +% ?N_BIT_STRING when BinOrOld == bin -> +% {concat_bit_binaries(AccVal, Val), AccRb+Rb}; +% _ when binary(Val),binary(AccVal) -> +% {<<AccVal/binary,Val/binary>>,AccRb+Rb}; +% _ when binary(Val), AccVal==[] -> +% {Val,AccRb+Rb}; +% _ -> +% {AccVal++Val, AccRb+Rb} +% end, + + + +decode_restricted(Bin, StringType, NamedNumberList,BinOrOld) -> + case StringType of + ?N_BIT_STRING -> + decode_bit_string2(Bin, NamedNumberList, BinOrOld); + ?N_UniversalString -> + mk_universal_string(binary_to_list(Bin)); + ?N_BMPString -> + mk_BMP_string(binary_to_list(Bin)); + _ -> + Bin + end. + + +check_and_convert_restricted_string(Val,StringType,Range,NamedNumberList,_BinOrOld) -> + {StrLen,NewVal} = case StringType of + ?N_BIT_STRING when NamedNumberList /= [] -> + {no_check,Val}; + ?N_BIT_STRING when list(Val) -> + {length(Val),Val}; + ?N_BIT_STRING when tuple(Val) -> + {(size(element(2,Val))*8) - element(1,Val),Val}; + _ when binary(Val) -> + {size(Val),binary_to_list(Val)}; + _ when list(Val) -> + {length(Val), Val} + end, + case Range of + _ when StrLen == no_check -> + NewVal; + [] -> % No length constraint + NewVal; + {Lb,Ub} when StrLen >= Lb, Ub >= StrLen -> % variable length constraint + NewVal; + {{Lb,_Ub},[]} when StrLen >= Lb -> + NewVal; + {{Lb1,Ub1},{Lb2,Ub2}} when StrLen >= Lb1, StrLen =< Ub1; + StrLen =< Ub2, StrLen >= Lb2 -> + NewVal; + StrLen -> % fixed length constraint + NewVal; + {_,_} -> + exit({error,{asn1,{length,Range,Val}}}); + _Len when integer(_Len) -> + exit({error,{asn1,{length,Range,Val}}}); + _ -> % some strange constraint that we don't support yet + NewVal + end. + + +%%============================================================================ +%% encode Universal string +%%============================================================================ + +encode_universal_string(C, {Name, Universal}, TagIn) when atom(Name) -> + encode_universal_string(C, Universal, TagIn); +encode_universal_string(_C, Universal, TagIn) -> + OctetList = mk_uni_list(Universal), + encode_tags(TagIn, OctetList, length(OctetList)). + +mk_uni_list(In) -> + mk_uni_list(In,[]). + +mk_uni_list([],List) -> + lists:reverse(List); +mk_uni_list([{A,B,C,D}|T],List) -> + mk_uni_list(T,[D,C,B,A|List]); +mk_uni_list([H|T],List) -> + mk_uni_list(T,[H,0,0,0|List]). + +%%=========================================================================== +%% decode Universal strings +%% (Buffer, Range, StringType, HasTag, LenIn) -> +%% {String, Remain, RemovedBytes} +%%=========================================================================== + +decode_universal_string(Buffer, Range, Tags) -> + decode_restricted_string(Buffer, Range, ?N_UniversalString, + Tags, [], old). + + +mk_universal_string(In) -> + mk_universal_string(In,[]). + +mk_universal_string([],Acc) -> + lists:reverse(Acc); +mk_universal_string([0,0,0,D|T],Acc) -> + mk_universal_string(T,[D|Acc]); +mk_universal_string([A,B,C,D|T],Acc) -> + mk_universal_string(T,[{A,B,C,D}|Acc]). + + +%%============================================================================ +%% encode BMP string +%%============================================================================ + +encode_BMP_string(C, {Name,BMPString}, TagIn) when atom(Name)-> + encode_BMP_string(C, BMPString, TagIn); +encode_BMP_string(_C, BMPString, TagIn) -> + OctetList = mk_BMP_list(BMPString), + encode_tags(TagIn, OctetList, length(OctetList)). + +mk_BMP_list(In) -> + mk_BMP_list(In,[]). + +mk_BMP_list([],List) -> + lists:reverse(List); +mk_BMP_list([{0,0,C,D}|T],List) -> + mk_BMP_list(T,[D,C|List]); +mk_BMP_list([H|T],List) -> + mk_BMP_list(T,[H,0|List]). + +%%============================================================================ +%% decode (OctetList, Range(ignored), tag|notag) -> {ValList, RestList} +%% (Buffer, Range, StringType, HasTag, TotalLen) -> +%% {String, Remain, RemovedBytes} +%%============================================================================ +decode_BMP_string(Buffer, Range, Tags) -> + decode_restricted_string(Buffer, Range, ?N_BMPString, + Tags, [], old). + +mk_BMP_string(In) -> + mk_BMP_string(In,[]). + +mk_BMP_string([],US) -> + lists:reverse(US); +mk_BMP_string([0,B|T],US) -> + mk_BMP_string(T,[B|US]); +mk_BMP_string([C,D|T],US) -> + mk_BMP_string(T,[{0,0,C,D}|US]). + + +%%============================================================================ +%% Generalized time, ITU_T X.680 Chapter 39 +%% +%% encode Generalized time +%%============================================================================ + +encode_generalized_time(C, {Name,OctetList}, TagIn) when atom(Name) -> + encode_generalized_time(C, OctetList, TagIn); +encode_generalized_time(_C, OctetList, TagIn) -> + encode_tags(TagIn, OctetList, length(OctetList)). + +%%============================================================================ +%% decode Generalized time +%% (Buffer, Range, HasTag, TotalLen) -> {String, Remain, RemovedBytes} +%%============================================================================ + +decode_generalized_time(Tlv, _Range, Tags) -> + Val = match_tags(Tlv, Tags), + NewVal = case Val of + PartList = [_H|_T] -> % constructed + collect_parts(PartList); + Bin -> + Bin + end, + binary_to_list(NewVal). + +%%============================================================================ +%% Universal time, ITU_T X.680 Chapter 40 +%% +%% encode UTC time +%%============================================================================ + +encode_utc_time(C, {Name,OctetList}, TagIn) when atom(Name) -> + encode_utc_time(C, OctetList, TagIn); +encode_utc_time(_C, OctetList, TagIn) -> + encode_tags(TagIn, OctetList, length(OctetList)). + +%%============================================================================ +%% decode UTC time +%% (Buffer, Range, HasTag, TotalLen) -> {String, Remain, RemovedBytes} +%%============================================================================ + +decode_utc_time(Tlv, _Range, Tags) -> + Val = match_tags(Tlv, Tags), + NewVal = case Val of + PartList = [_H|_T] -> % constructed + collect_parts(PartList); + Bin -> + Bin + end, + binary_to_list(NewVal). + + +%%============================================================================ +%% Length handling +%% +%% Encode length +%% +%% encode_length(Int | indefinite) -> +%% [<127]| [128 + Int (<127),OctetList] | [16#80] +%%============================================================================ + +encode_length(indefinite) -> + {[16#80],1}; % 128 +encode_length(L) when L =< 16#7F -> + {[L],1}; +encode_length(L) -> + Oct = minimum_octets(L), + Len = length(Oct), + if + Len =< 126 -> + {[ (16#80+Len) | Oct ],Len+1}; + true -> + exit({error,{asn1, to_long_length_oct, Len}}) + end. + + +%% Val must be >= 0 +minimum_octets(Val) -> + minimum_octets(Val,[]). + +minimum_octets(0,Acc) -> + Acc; +minimum_octets(Val, Acc) -> + minimum_octets((Val bsr 8),[Val band 16#FF | Acc]). + + +%%=========================================================================== +%% Decode length +%% +%% decode_length(OctetList) -> {{indefinite, RestOctetsL}, NoRemovedBytes} | +%% {{Length, RestOctetsL}, NoRemovedBytes} +%%=========================================================================== + +decode_length(<<1:1,0:7,T/binary>>) -> + {indefinite, T}; +decode_length(<<0:1,Length:7,T/binary>>) -> + {Length,T}; +decode_length(<<1:1,LL:7,T/binary>>) -> + <<Length:LL/unit:8,Rest/binary>> = T, + {Length,Rest}. + + + +%%------------------------------------------------------------------------- +%% INTERNAL HELPER FUNCTIONS (not exported) +%%------------------------------------------------------------------------- + + +%% decoding postitive integer values. +decode_integer2(Len,Bin = <<0:1,_:7,_Bs/binary>>) -> + <<Int:Len/unit:8>> = Bin, + Int; +%% decoding negative integer values. +decode_integer2(Len,<<1:1,B2:7,Bs/binary>>) -> + <<N:Len/unit:8>> = <<B2,Bs/binary>>, + Int = N - (1 bsl (8 * Len - 1)), + Int. + +get_constraint(C,Key) -> + case lists:keysearch(Key,1,C) of + false -> + no; + {value,{_,V}} -> + V + end. + +collect_parts(TlvList) -> + collect_parts(TlvList,[]). + +collect_parts([{_,L}|Rest],Acc) when list(L) -> + collect_parts(Rest,[collect_parts(L)|Acc]); +collect_parts([{?N_BIT_STRING,<<Unused,Bits/binary>>}|Rest],_Acc) -> + collect_parts_bit(Rest,[Bits],Unused); +collect_parts([{_T,V}|Rest],Acc) -> + collect_parts(Rest,[V|Acc]); +collect_parts([],Acc) -> + list_to_binary(lists:reverse(Acc)). + +collect_parts_bit([{?N_BIT_STRING,<<Unused,Bits/binary>>}|Rest],Acc,Uacc) -> + collect_parts_bit(Rest,[Bits|Acc],Unused+Uacc); +collect_parts_bit([],Acc,Uacc) -> + list_to_binary([Uacc|lists:reverse(Acc)]). diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_check.erl b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_check.erl new file mode 100644 index 0000000000..cfda8a2a88 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_check.erl @@ -0,0 +1,333 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: asn1rt_check.erl,v 1.1 2008/12/17 09:53:30 mikpe Exp $ +%% +-module(asn1rt_check). + +-include("asn1_records.hrl"). + +-export([check_bool/2, + check_int/3, + check_bitstring/3, + check_octetstring/2, + check_null/2, + check_objectidentifier/2, + check_objectdescriptor/2, + check_real/2, + check_enum/3, + check_restrictedstring/2]). + +-export([transform_to_EXTERNAL1990/1, + transform_to_EXTERNAL1994/1]). + + +check_bool(_Bool,asn1_DEFAULT) -> + true; +check_bool(Bool,Bool) when Bool == true; Bool == false -> + true; +check_bool(_Bool1,Bool2) -> + throw({error,Bool2}). + +check_int(_,asn1_DEFAULT,_) -> + true; +check_int(Value,Value,_) when integer(Value) -> + true; +check_int(DefValue,Value,NNL) when atom(Value) -> + case lists:keysearch(Value,1,NNL) of + {value,{_,DefValue}} -> + true; + _ -> + throw({error,DefValue}) + end; +check_int(DefaultValue,_Value,_) -> + throw({error,DefaultValue}). + +% check_bitstring([H|T],[H|T],_) when integer(H) -> +% true; +% check_bitstring(V,V,_) when integer(V) -> +% true; +%% Two equal lists or integers +check_bitstring(_,asn1_DEFAULT,_) -> + true; +check_bitstring(V,V,_) -> + true; +%% Default value as a list of 1 and 0 and user value as an integer +check_bitstring(L=[H|T],Int,_) when integer(Int),integer(H) -> + case bit_list_to_int(L,length(T)) of + Int -> true; + _ -> throw({error,L,Int}) + end; +%% Default value as an integer, val as list +check_bitstring(Int,Val,NBL) when integer(Int),list(Val) -> + BL = int_to_bit_list(Int,[],length(Val)), + check_bitstring(BL,Val,NBL); +%% Default value and user value as lists of ones and zeros +check_bitstring(L1=[H1|_T1],L2=[H2|_T2],NBL=[_H|_T]) when integer(H1),integer(H2) -> + L2new = remove_trailing_zeros(L2), + check_bitstring(L1,L2new,NBL); +%% Default value as a list of 1 and 0 and user value as a list of atoms +check_bitstring(L1=[H1|_T1],L2=[H2|_T2],NBL) when integer(H1),atom(H2) -> + case bit_list_to_nbl(L1,NBL,0,[]) of + L3 -> check_bitstring(L3,L2,NBL); + _ -> throw({error,L2}) + end; +%% Both default value and user value as a list of atoms +check_bitstring(L1=[H1|T1],L2=[H2|_T2],_) when atom(H1),atom(H2) -> + length(L1) == length(L2), + case lists:member(H1,L2) of + true -> + check_bitstring1(T1,L2); + false -> throw({error,L2}) + end; +%% Default value as a list of atoms and user value as a list of 1 and 0 +check_bitstring(L1=[H1|_T1],L2=[H2|_T2],NBL) when atom(H1),integer(H2) -> + case bit_list_to_nbl(L2,NBL,0,[]) of + L3 -> + check_bitstring(L1,L3,NBL); + _ -> throw({error,L2}) + end; +%% User value in compact format +check_bitstring(DefVal,CBS={_,_},NBL) -> + NewVal = cbs_to_bit_list(CBS), + check_bitstring(DefVal,NewVal,NBL); +check_bitstring(DV,V,_) -> + throw({error,DV,V}). + + +bit_list_to_int([0|Bs],ShL)-> + bit_list_to_int(Bs,ShL-1) + 0; +bit_list_to_int([1|Bs],ShL) -> + bit_list_to_int(Bs,ShL-1) + (1 bsl ShL); +bit_list_to_int([],_) -> + 0. + +int_to_bit_list(0,Acc,0) -> + Acc; +int_to_bit_list(Int,Acc,Len) -> + int_to_bit_list(Int bsr 1,[Int band 1|Acc],Len - 1). + +bit_list_to_nbl([0|T],NBL,Pos,Acc) -> + bit_list_to_nbl(T,NBL,Pos+1,Acc); +bit_list_to_nbl([1|T],NBL,Pos,Acc) -> + case lists:keysearch(Pos,2,NBL) of + {value,{N,_}} -> + bit_list_to_nbl(T,NBL,Pos+1,[N|Acc]); + _ -> + throw({error,{no,named,element,at,pos,Pos}}) + end; +bit_list_to_nbl([],_,_,Acc) -> + Acc. + +remove_trailing_zeros(L2) -> + remove_trailing_zeros1(lists:reverse(L2)). +remove_trailing_zeros1(L) -> + lists:reverse(lists:dropwhile(fun(0)->true; + (_) ->false + end, + L)). + +check_bitstring1([H|T],NBL) -> + case lists:member(H,NBL) of + true -> + check_bitstring1(T,NBL); + V -> throw({error,V}) + end; +check_bitstring1([],_) -> + true. + +cbs_to_bit_list({Unused,<<B7:1,B6:1,B5:1,B4:1,B3:1,B2:1,B1:1,B0:1,Rest/binary>>}) when size(Rest) >= 1 -> + [B7,B6,B5,B4,B3,B2,B1,B0|cbs_to_bit_list({Unused,Rest})]; +cbs_to_bit_list({0,<<B7:1,B6:1,B5:1,B4:1,B3:1,B2:1,B1:1,B0:1>>}) -> + [B7,B6,B5,B4,B3,B2,B1,B0]; +cbs_to_bit_list({Unused,Bin}) when size(Bin) == 1 -> + Used = 8-Unused, + <<Int:Used,_:Unused>> = Bin, + int_to_bit_list(Int,[],Used). + + +check_octetstring(_,asn1_DEFAULT) -> + true; +check_octetstring(L,L) -> + true; +check_octetstring(L,Int) when list(L),integer(Int) -> + case integer_to_octetlist(Int) of + L -> true; + V -> throw({error,V}) + end; +check_octetstring(_,V) -> + throw({error,V}). + +integer_to_octetlist(Int) -> + integer_to_octetlist(Int,[]). +integer_to_octetlist(0,Acc) -> + Acc; +integer_to_octetlist(Int,Acc) -> + integer_to_octetlist(Int bsr 8,[(Int band 255)|Acc]). + +check_null(_,asn1_DEFAULT) -> + true; +check_null('NULL','NULL') -> + true; +check_null(_,V) -> + throw({error,V}). + +check_objectidentifier(_,asn1_DEFAULT) -> + true; +check_objectidentifier(OI,OI) -> + true; +check_objectidentifier(DOI,OI) when tuple(DOI),tuple(OI) -> + check_objectidentifier1(tuple_to_list(DOI),tuple_to_list(OI)); +check_objectidentifier(_,OI) -> + throw({error,OI}). + +check_objectidentifier1([V|Rest1],[V|Rest2]) -> + check_objectidentifier1(Rest1,Rest2,V); +check_objectidentifier1([V1|Rest1],[V2|Rest2]) -> + case reserved_objectid(V2,[]) of + V1 -> + check_objectidentifier1(Rest1,Rest2,[V1]); + V -> + throw({error,V}) + end. +check_objectidentifier1([V|Rest1],[V|Rest2],Above) -> + check_objectidentifier1(Rest1,Rest2,[V|Above]); +check_objectidentifier1([V1|Rest1],[V2|Rest2],Above) -> + case reserved_objectid(V2,Above) of + V1 -> + check_objectidentifier1(Rest1,Rest2,[V1|Above]); + V -> + throw({error,V}) + end; +check_objectidentifier1([],[],_) -> + true; +check_objectidentifier1(_,V,_) -> + throw({error,object,identifier,V}). + +%% ITU-T Rec. X.680 Annex B - D +reserved_objectid('itu-t',[]) -> 0; +reserved_objectid('ccitt',[]) -> 0; +%% arcs below "itu-t" +reserved_objectid('recommendation',[0]) -> 0; +reserved_objectid('question',[0]) -> 1; +reserved_objectid('administration',[0]) -> 2; +reserved_objectid('network-operator',[0]) -> 3; +reserved_objectid('identified-organization',[0]) -> 4; + +reserved_objectid(iso,[]) -> 1; +%% arcs below "iso", note that number 1 is not used +reserved_objectid('standard',[1]) -> 0; +reserved_objectid('member-body',[1]) -> 2; +reserved_objectid('identified-organization',[1]) -> 3; + +reserved_objectid('joint-iso-itu-t',[]) -> 2; +reserved_objectid('joint-iso-ccitt',[]) -> 2; + +reserved_objectid(_,_) -> false. + + +check_objectdescriptor(_,asn1_DEFAULT) -> + true; +check_objectdescriptor(OD,OD) -> + true; +check_objectdescriptor(OD,OD) -> + throw({error,{not_implemented_yet,check_objectdescriptor}}). + +check_real(_,asn1_DEFAULT) -> + true; +check_real(R,R) -> + true; +check_real(_,_) -> + throw({error,{not_implemented_yet,check_real}}). + +check_enum(_,asn1_DEFAULT,_) -> + true; +check_enum(Val,Val,_) -> + true; +check_enum(Int,Atom,Enumerations) when integer(Int),atom(Atom) -> + case lists:keysearch(Atom,1,Enumerations) of + {value,{_,Int}} -> true; + _ -> throw({error,{enumerated,Int,Atom}}) + end; +check_enum(DefVal,Val,_) -> + throw({error,{enumerated,DefVal,Val}}). + + +check_restrictedstring(_,asn1_DEFAULT) -> + true; +check_restrictedstring(Val,Val) -> + true; +check_restrictedstring([V|Rest1],[V|Rest2]) -> + check_restrictedstring(Rest1,Rest2); +check_restrictedstring([V1|Rest1],[V2|Rest2]) -> + check_restrictedstring(V1,V2), + check_restrictedstring(Rest1,Rest2); +%% tuple format of value +check_restrictedstring({V1,V2},[V1,V2]) -> + true; +check_restrictedstring([V1,V2],{V1,V2}) -> + true; +%% quadruple format of value +check_restrictedstring({V1,V2,V3,V4},[V1,V2,V3,V4]) -> + true; +check_restrictedstring([V1,V2,V3,V4],{V1,V2,V3,V4}) -> + true; +%% character string list +check_restrictedstring(V1,V2) when list(V1),tuple(V2) -> + check_restrictedstring(V1,tuple_to_list(V2)); +check_restrictedstring(V1,V2) -> + throw({error,{restricted,string,V1,V2}}). + +transform_to_EXTERNAL1990(Val) when tuple(Val),size(Val) == 4 -> + transform_to_EXTERNAL1990(tuple_to_list(Val),[]); +transform_to_EXTERNAL1990(Val) when tuple(Val) -> + %% Data already in ASN1 1990 format + Val. + +transform_to_EXTERNAL1990(['EXTERNAL'|Rest],Acc) -> + transform_to_EXTERNAL1990(Rest,['EXTERNAL'|Acc]); +transform_to_EXTERNAL1990([{syntax,Syntax}|Rest],Acc) -> + transform_to_EXTERNAL1990(Rest,[asn1_NOVALUE,Syntax|Acc]); +transform_to_EXTERNAL1990([{'presentation-context-id',PCid}|Rest],Acc) -> + transform_to_EXTERNAL1990(Rest,[PCid,asn1_NOVALUE|Acc]); +transform_to_EXTERNAL1990([{'context-negotiation',Context_negot}|Rest],Acc) -> + {_,Presentation_Cid,Transfer_syntax} = Context_negot, + transform_to_EXTERNAL1990(Rest,[Transfer_syntax,Presentation_Cid|Acc]); +transform_to_EXTERNAL1990([asn1_NOVALUE|Rest],Acc) -> + transform_to_EXTERNAL1990(Rest,[asn1_NOVALUE|Acc]); +transform_to_EXTERNAL1990([Data_val_desc,Data_value],Acc) when list(Data_value)-> + list_to_tuple(lists:reverse([{'octet-aligned',Data_value}, + Data_val_desc|Acc])); +transform_to_EXTERNAL1990([Data_value],Acc) when list(Data_value)-> + list_to_tuple(lists:reverse([{'octet-aligned',Data_value}|Acc])). + + +transform_to_EXTERNAL1994(V={'EXTERNAL',DRef,IndRef,Data_v_desc,Encoding}) -> + Identification = + case {DRef,IndRef} of + {DRef,asn1_NOVALUE} -> + {syntax,DRef}; + {asn1_NOVALUE,IndRef} -> + {'presentation-context-id',IndRef}; + _ -> + {'context-negotiation', + {'EXTERNAL_identification_context-negotiation',IndRef,DRef}} + end, + case Encoding of + {_,Val} when list(Val) -> + {'EXTERNAL',Identification,Data_v_desc,Val}; + _ -> + V + end. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_driver_handler.erl b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_driver_handler.erl new file mode 100644 index 0000000000..5200f9d2d9 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_driver_handler.erl @@ -0,0 +1,108 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: asn1rt_driver_handler.erl,v 1.1 2008/12/17 09:53:30 mikpe Exp $ +%% + +-module(asn1rt_driver_handler). + +-export([init/1,load_driver/0,unload_driver/0]). + + +load_driver() -> + spawn(asn1rt_driver_handler, init, [self()]). + +init(From) -> + Port= + case load_driver("asn1_erl_drv") of + ok -> + open_named_port(From); + already_done -> + From ! driver_ready; + Error -> % if erl_ddll:load_driver fails + erl_ddll:unload_driver("asn1_erl_drv"), + From ! Error + end, + register_and_loop(Port). + +load_driver(DriverName) -> + case is_driver_loaded(DriverName) of + false -> + Dir = filename:join([code:priv_dir(asn1),"lib"]), + erl_ddll:load_driver(Dir,DriverName); + true -> + ok + end. + + +is_driver_loaded(_Name) -> + case whereis(asn1_driver_owner) of + undefined -> + false; + _ -> + true + end. + +open_named_port(From) -> + case is_port_open(drv_complete) of + false -> + case catch open_port({spawn,"asn1_erl_drv"},[]) of + {'EXIT',Reason} -> + From ! {port_error,Reason}; + Port -> + register(drv_complete,Port), + From ! driver_ready, + Port + end; + _ -> + From ! driver_ready, + ok + end. + +is_port_open(Name) -> + case whereis(Name) of + Port when port(Port) -> + true; + _ -> false + end. + +register_and_loop(Port) when port(Port) -> + register(asn1_driver_owner,self()), + loop(); +register_and_loop(_) -> + ok. + +loop() -> + receive + unload -> + case whereis(drv_complete) of + Port when port(Port) -> + port_close(Port); + _ -> ok + end, + erl_ddll:unload_driver("asn1_erl_drv"), + ok; + _ -> + loop() + end. + +unload_driver() -> + case whereis(asn1_driver_owner) of + Pid when pid(Pid) -> + Pid ! unload, + ok; + _ -> + ok + end. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_per.erl b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_per.erl new file mode 100644 index 0000000000..4999dde2cc --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_per.erl @@ -0,0 +1,1593 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: asn1rt_per.erl,v 1.1 2008/12/17 09:53:31 mikpe Exp $ +%% +-module(asn1rt_per). + +%% encoding / decoding of PER aligned + +-include("asn1_records.hrl"). + +-export([dec_fixup/3, cindex/3, list_to_record/2]). +-export([setchoiceext/1, setext/1, fixoptionals/2, fixextensions/2, setoptionals/1, + getext/1, getextension/2, skipextensions/3, getbit/1, getchoice/3 ]). +-export([getoptionals/3, set_choice/3, encode_integer/2, encode_integer/3 ]). +-export([decode_integer/2, decode_integer/3, encode_boolean/1, + decode_boolean/1, encode_length/2, decode_length/1, decode_length/2, + encode_small_length/1, decode_small_length/1]). +-export([encode_enumerated/3, decode_enumerated/3, + encode_bit_string/3, decode_bit_string/3 ]). +-export([encode_octet_string/2, decode_octet_string/2, + encode_restricted_string/4, encode_restricted_string/5, + decode_restricted_string/4, decode_restricted_string/5, + encode_null/1, decode_null/1, + encode_object_identifier/1, decode_object_identifier/1, + complete/1]). + +-export([encode_open_type/2, decode_open_type/2]). + +-export([encode_UniversalString/2, decode_UniversalString/2, + encode_PrintableString/2, decode_PrintableString/2, + encode_GeneralString/2, decode_GeneralString/2, + encode_GraphicString/2, decode_GraphicString/2, + encode_TeletexString/2, decode_TeletexString/2, + encode_VideotexString/2, decode_VideotexString/2, + encode_VisibleString/2, decode_VisibleString/2, + encode_BMPString/2, decode_BMPString/2, + encode_IA5String/2, decode_IA5String/2, + encode_NumericString/2, decode_NumericString/2 + ]). + + +dec_fixup(Terms,Cnames,RemBytes) -> + dec_fixup(Terms,Cnames,RemBytes,[]). + +dec_fixup([novalue|T],[_Hc|Tc],RemBytes,Acc) -> + dec_fixup(T,Tc,RemBytes,Acc); +dec_fixup([{_Name,novalue}|T],[_Hc|Tc],RemBytes,Acc) -> + dec_fixup(T,Tc,RemBytes,Acc); +dec_fixup([H|T],[Hc|Tc],RemBytes,Acc) -> + dec_fixup(T,Tc,RemBytes,[{Hc,H}|Acc]); +dec_fixup([],_Cnames,RemBytes,Acc) -> + {lists:reverse(Acc),RemBytes}. + +cindex(Ix,Val,Cname) -> + case element(Ix,Val) of + {Cname,Val2} -> Val2; + X -> X + end. + +% converts a list to a record if necessary +list_to_record(Name,List) when list(List) -> + list_to_tuple([Name|List]); +list_to_record(_Name,Tuple) when tuple(Tuple) -> + Tuple. + +%%-------------------------------------------------------- +%% setchoiceext(InRootSet) -> [{bit,X}] +%% X is set to 1 when InRootSet==false +%% X is set to 0 when InRootSet==true +%% +setchoiceext(true) -> + [{debug,choiceext},{bit,0}]; +setchoiceext(false) -> + [{debug,choiceext},{bit,1}]. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% setext(true|false) -> CompleteList +%% + +setext(true) -> + [{debug,ext},{bit,1}]; +setext(false) -> + [{debug,ext},{bit,0}]. + +fixoptionals(OptList,Val) when tuple(Val) -> + fixoptionals(OptList,Val,[]); + +fixoptionals(OptList,Val) when list(Val) -> + fixoptionals(OptList,Val,1,[],[]). + +fixoptionals([],Val,Acc) -> + % return {Val,Opt} + {Val,lists:reverse(Acc)}; +fixoptionals([{_,Pos}|Ot],Val,Acc) -> + case element(Pos+1,Val) of + asn1_NOVALUE -> fixoptionals(Ot,Val,[0|Acc]); + asn1_DEFAULT -> fixoptionals(Ot,Val,[0|Acc]); + _ -> fixoptionals(Ot,Val,[1|Acc]) + end. + + +%setoptionals(OptList,Val) -> +% Vlist = tuple_to_list(Val), +% setoptionals(OptList,Vlist,1,[]). + +fixoptionals([{Name,Pos}|Ot],[{Name,Val}|Vt],_Opt,Acc1,Acc2) -> + fixoptionals(Ot,Vt,Pos+1,[1|Acc1],[{Name,Val}|Acc2]); +fixoptionals([{_Name,Pos}|Ot],V,Pos,Acc1,Acc2) -> + fixoptionals(Ot,V,Pos+1,[0|Acc1],[asn1_NOVALUE|Acc2]); +fixoptionals(O,[Vh|Vt],Pos,Acc1,Acc2) -> + fixoptionals(O,Vt,Pos+1,Acc1,[Vh|Acc2]); +fixoptionals([],[Vh|Vt],Pos,Acc1,Acc2) -> + fixoptionals([],Vt,Pos+1,Acc1,[Vh|Acc2]); +fixoptionals([],[],_,Acc1,Acc2) -> + % return {Val,Opt} + {list_to_tuple([asn1_RECORDNAME|lists:reverse(Acc2)]),lists:reverse(Acc1)}. + +setoptionals([H|T]) -> + [{bit,H}|setoptionals(T)]; +setoptionals([]) -> + [{debug,optionals}]. + +getext(Bytes) when tuple(Bytes) -> + getbit(Bytes); +getext(Bytes) when list(Bytes) -> + getbit({0,Bytes}). + +getextension(0, Bytes) -> + {{},Bytes}; +getextension(1, Bytes) -> + {Len,Bytes2} = decode_small_length(Bytes), + {Blist, Bytes3} = getbits_as_list(Len,Bytes2), + {list_to_tuple(Blist),Bytes3}. + +fixextensions({ext,ExtPos,ExtNum},Val) -> + case fixextensions(ExtPos,ExtNum+ExtPos,Val,0) of + 0 -> []; + ExtBits -> + [encode_small_length(ExtNum),{bits,ExtNum,ExtBits}] + end. + +fixextensions(Pos,MaxPos,_,Acc) when Pos >= MaxPos -> + Acc; +fixextensions(Pos,ExtPos,Val,Acc) -> + Bit = case catch(element(Pos+1,Val)) of + asn1_NOVALUE -> + 0; + asn1_NOEXTVALUE -> + 0; + {'EXIT',_} -> + 0; + _ -> + 1 + end, + fixextensions(Pos+1,ExtPos,Val,(Acc bsl 1)+Bit). + +skipextensions(Bytes,Nr,ExtensionBitPattern) -> + case (catch element(Nr,ExtensionBitPattern)) of + 1 -> + {_,Bytes2} = decode_open_type(Bytes,[]), + skipextensions(Bytes2, Nr+1, ExtensionBitPattern); + 0 -> + skipextensions(Bytes, Nr+1, ExtensionBitPattern); + {'EXIT',_} -> % badarg, no more extensions + Bytes + end. + + +getchoice(Bytes,1,0) -> % only 1 alternative is not encoded + {0,Bytes}; +getchoice(Bytes,_NumChoices,1) -> + decode_small_number(Bytes); +getchoice(Bytes,NumChoices,0) -> + decode_integer(Bytes,[{'ValueRange',{0,NumChoices-1}}]). + +getoptionals(Bytes,L,NumComp) when list(L) -> + {Blist,Bytes1} = getbits_as_list(length(L),Bytes), + {list_to_tuple(comptuple(Blist,L,NumComp,1)),Bytes1}. + +comptuple([Bh|Bt],[{_Name,Nr}|T],NumComp,Nr) -> + [Bh|comptuple(Bt,T,NumComp-1,Nr+1)]; +comptuple(Bl,[{Name,Tnr}|Tl],NumComp,Nr) -> + [0|comptuple(Bl,[{Name,Tnr}|Tl],NumComp-1,Nr+1)]; +comptuple(_B,_L,0,_Nr) -> + []; +comptuple(B,O,N,Nr) -> + [0|comptuple(B,O,N-1,Nr+1)]. + +getbits_as_list(Num,Bytes) -> + getbits_as_list(Num,Bytes,[]). + +getbits_as_list(0,Bytes,Acc) -> + {lists:reverse(Acc),Bytes}; +getbits_as_list(Num,Bytes,Acc) -> + {Bit,NewBytes} = getbit(Bytes), + getbits_as_list(Num-1,NewBytes,[Bit|Acc]). + +getbit(Bytes) -> +% io:format("getbit:~p~n",[Bytes]), + getbit1(Bytes). + +getbit1({7,[H|T]}) -> + {H band 1,{0,T}}; +getbit1({Pos,[H|T]}) -> + {(H bsr (7-Pos)) band 1,{(Pos+1) rem 8,[H|T]}}; +getbit1(Bytes) when list(Bytes) -> + getbit1({0,Bytes}). + +%% This could be optimized +getbits(Buffer,Num) -> +% io:format("getbits:Buffer = ~p~nNum=~p~n",[Buffer,Num]), + getbits(Buffer,Num,0). + +getbits(Buffer,0,Acc) -> + {Acc,Buffer}; +getbits(Buffer,Num,Acc) -> + {B,NewBuffer} = getbit(Buffer), + getbits(NewBuffer,Num-1,B + (Acc bsl 1)). + + +getoctet(Bytes) when list(Bytes) -> + getoctet({0,Bytes}); +getoctet(Bytes) -> +% io:format("getoctet:Buffer = ~p~n",[Bytes]), + getoctet1(Bytes). + +getoctet1({0,[H|T]}) -> + {H,{0,T}}; +getoctet1({_Pos,[_,H|T]}) -> + {H,{0,T}}. + +align({0,L}) -> + {0,L}; +align({_Pos,[_H|T]}) -> + {0,T}; +align(Bytes) -> + {0,Bytes}. + +getoctets(Buffer,Num) -> +% io:format("getoctets:Buffer = ~p~nNum = ~p~n",[Buffer,Num]), + getoctets(Buffer,Num,0). + +getoctets(Buffer,0,Acc) -> + {Acc,Buffer}; +getoctets(Buffer,Num,Acc) -> + {Oct,NewBuffer} = getoctet(Buffer), + getoctets(NewBuffer,Num-1,(Acc bsl 8)+Oct). + +getoctets_as_list(Buffer,Num) -> + getoctets_as_list(Buffer,Num,[]). + +getoctets_as_list(Buffer,0,Acc) -> + {lists:reverse(Acc),Buffer}; +getoctets_as_list(Buffer,Num,Acc) -> + {Oct,NewBuffer} = getoctet(Buffer), + getoctets_as_list(NewBuffer,Num-1,[Oct|Acc]). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% set_choice(Alt,Choices,Altnum) -> ListofBitSettings +%% Alt = atom() +%% Altnum = integer() | {integer(),integer()}% number of alternatives +%% Choices = [atom()] | {[atom()],[atom()]} +%% When Choices is a tuple the first list is the Rootset and the +%% second is the Extensions and then Altnum must also be a tuple with the +%% lengths of the 2 lists +%% +set_choice(Alt,{L1,L2},{Len1,_Len2}) -> + case set_choice_tag(Alt,L1) of + N when integer(N), Len1 > 1 -> + [{bit,0}, % the value is in the root set + encode_integer([{'ValueRange',{0,Len1-1}}],N)]; + N when integer(N) -> + [{bit,0}]; % no encoding if only 0 or 1 alternative + false -> + [{bit,1}, % extension value + case set_choice_tag(Alt,L2) of + N2 when integer(N2) -> + encode_small_number(N2); + false -> + unknown_choice_alt + end] + end; +set_choice(Alt,L,Len) -> + case set_choice_tag(Alt,L) of + N when integer(N), Len > 1 -> + encode_integer([{'ValueRange',{0,Len-1}}],N); + N when integer(N) -> + []; % no encoding if only 0 or 1 alternative + false -> + [unknown_choice_alt] + end. + +set_choice_tag(Alt,Choices) -> + set_choice_tag(Alt,Choices,0). + +set_choice_tag(Alt,[Alt|_Rest],Tag) -> + Tag; +set_choice_tag(Alt,[_H|Rest],Tag) -> + set_choice_tag(Alt,Rest,Tag+1); +set_choice_tag(_,[],_) -> + false. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% encode_open_type(Constraint, Value) -> CompleteList +%% Value = list of bytes of an already encoded value (the list must be flat) +%% | binary +%% Contraint = not used in this version +%% +encode_open_type(_Constraint, Val) when list(Val) -> + [encode_length(undefined,length(Val)),align, + {octets,Val}]; +encode_open_type(_Constraint, Val) when binary(Val) -> + [encode_length(undefined,size(Val)),align, + {octets,binary_to_list(Val)}]. +%% the binary_to_list is not optimal but compatible with the current solution + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% decode_open_type(Buffer,Constraint) -> Value +%% Constraint is not used in this version +%% Buffer = [byte] with PER encoded data +%% Value = [byte] with decoded data (which must be decoded again as some type) +%% +decode_open_type(Bytes, _Constraint) -> + {Len,Bytes2} = decode_length(Bytes,undefined), + Bytes3 = align(Bytes2), + getoctets_as_list(Bytes3,Len). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% encode_integer(Constraint,Value,NamedNumberList) -> CompleteList +%% encode_integer(Constraint,Value) -> CompleteList +%% encode_integer(Constraint,{Name,Value}) -> CompleteList +%% +%% +encode_integer(C,V,NamedNumberList) when atom(V) -> + case lists:keysearch(V,1,NamedNumberList) of + {value,{_,NewV}} -> + encode_integer(C,NewV); + _ -> + exit({error,{asn1,{namednumber,V}}}) + end; +encode_integer(C,V,_NamedNumberList) when integer(V) -> + encode_integer(C,V). + +encode_integer(C,{Name,Val}) when atom(Name) -> + encode_integer(C,Val); + +encode_integer({Rc,_Ec},Val) -> + case (catch encode_integer(Rc,Val)) of + {'EXIT',{error,{asn1,_}}} -> + [{bit,1},encode_unconstrained_number(Val)]; + Encoded -> + [{bit,0},Encoded] + end; +encode_integer(C,Val ) when list(C) -> + case get_constraint(C,'SingleValue') of + no -> + encode_integer1(C,Val); + V when integer(V),V == Val -> + []; % a type restricted to a single value encodes to nothing + V when list(V) -> + case lists:member(Val,V) of + true -> + encode_integer1(C,Val); + _ -> + exit({error,{asn1,{illegal_value,Val}}}) + end; + _ -> + exit({error,{asn1,{illegal_value,Val}}}) + end. + +encode_integer1(C, Val) -> + case VR = get_constraint(C,'ValueRange') of + no -> + encode_unconstrained_number(Val); + {Lb,'MAX'} -> + encode_semi_constrained_number(Lb,Val); + %% positive with range + {Lb,Ub} when Val >= Lb, + Ub >= Val -> + encode_constrained_number(VR,Val) + end. + +decode_integer(Buffer,Range,NamedNumberList) -> + {Val,Buffer2} = decode_integer(Buffer,Range), + case lists:keysearch(Val,2,NamedNumberList) of + {value,{NewVal,_}} -> {NewVal,Buffer2}; + _ -> {Val,Buffer2} + end. + +decode_integer(Buffer,{Rc,_Ec}) -> + {Ext,Buffer2} = getext(Buffer), + case Ext of + 0 -> decode_integer(Buffer2,Rc); + 1 -> decode_unconstrained_number(Buffer2) + end; +decode_integer(Buffer,undefined) -> + decode_unconstrained_number(Buffer); +decode_integer(Buffer,C) -> + case get_constraint(C,'SingleValue') of + V when integer(V) -> + {V,Buffer}; + V when list(V) -> + {Val,Buffer2} = decode_integer1(Buffer,C), + case lists:member(Val,V) of + true -> + {Val,Buffer2}; + _ -> + exit({error,{asn1,{illegal_value,Val}}}) + end; + _ -> + decode_integer1(Buffer,C) + end. + +decode_integer1(Buffer,C) -> + case VR = get_constraint(C,'ValueRange') of + no -> + decode_unconstrained_number(Buffer); + {Lb, 'MAX'} -> + decode_semi_constrained_number(Buffer,Lb); + {_,_} -> + decode_constrained_number(Buffer,VR) + end. + +% X.691:10.6 Encoding of a normally small non-negative whole number +% Use this for encoding of CHOICE index if there is an extension marker in +% the CHOICE +encode_small_number({Name,Val}) when atom(Name) -> + encode_small_number(Val); +encode_small_number(Val) when Val =< 63 -> + [{bit,0},{bits,6,Val}]; +encode_small_number(Val) -> + [{bit,1},encode_semi_constrained_number(0,Val)]. + +decode_small_number(Bytes) -> + {Bit,Bytes2} = getbit(Bytes), + case Bit of + 0 -> + getbits(Bytes2,6); + 1 -> + decode_semi_constrained_number(Bytes2,{0,'MAX'}) + end. + +% X.691:10.7 Encoding of a semi-constrained whole number +%% might be an optimization encode_semi_constrained_number(0,Val) -> +encode_semi_constrained_number(C,{Name,Val}) when atom(Name) -> + encode_semi_constrained_number(C,Val); +encode_semi_constrained_number({Lb,'MAX'},Val) -> + encode_semi_constrained_number(Lb,Val); +encode_semi_constrained_number(Lb,Val) -> + Val2 = Val - Lb, + Octs = eint_positive(Val2), + [encode_length(undefined,length(Octs)),{octets,Octs}]. + +decode_semi_constrained_number(Bytes,{Lb,_}) -> + decode_semi_constrained_number(Bytes,Lb); +decode_semi_constrained_number(Bytes,Lb) -> + {Len,Bytes2} = decode_length(Bytes,undefined), + {V,Bytes3} = getoctets(Bytes2,Len), + {V+Lb,Bytes3}. + +encode_constrained_number(Range,{Name,Val}) when atom(Name) -> + encode_constrained_number(Range,Val); +encode_constrained_number({Lb,Ub},Val) when Val >= Lb, Ub >= Val -> + Range = Ub - Lb + 1, + Val2 = Val - Lb, + if + Range == 2 -> + {bits,1,Val2}; + Range =< 4 -> + {bits,2,Val2}; + Range =< 8 -> + {bits,3,Val2}; + Range =< 16 -> + {bits,4,Val2}; + Range =< 32 -> + {bits,5,Val2}; + Range =< 64 -> + {bits,6,Val2}; + Range =< 128 -> + {bits,7,Val2}; + Range =< 255 -> + {bits,8,Val2}; + Range =< 256 -> + {octets,1,Val2}; + Range =< 65536 -> + {octets,2,Val2}; + Range =< 16#1000000 -> + Octs = eint_positive(Val2), + [encode_length({1,3},length(Octs)),{octets,Octs}]; + Range =< 16#100000000 -> + Octs = eint_positive(Val2), + [encode_length({1,4},length(Octs)),{octets,Octs}]; + Range =< 16#10000000000 -> + Octs = eint_positive(Val2), + [encode_length({1,5},length(Octs)),{octets,Octs}]; + true -> + exit({not_supported,{integer_range,Range}}) + end. + +decode_constrained_number(Buffer,{Lb,Ub}) -> + Range = Ub - Lb + 1, +% Val2 = Val - Lb, + {Val,Remain} = + if + Range == 2 -> + getbits(Buffer,1); + Range =< 4 -> + getbits(Buffer,2); + Range =< 8 -> + getbits(Buffer,3); + Range =< 16 -> + getbits(Buffer,4); + Range =< 32 -> + getbits(Buffer,5); + Range =< 64 -> + getbits(Buffer,6); + Range =< 128 -> + getbits(Buffer,7); + Range =< 255 -> + getbits(Buffer,8); + Range =< 256 -> + getoctets(Buffer,1); + Range =< 65536 -> + getoctets(Buffer,2); + Range =< 16#1000000 -> + {Len,Bytes2} = decode_length(Buffer,{1,3}), + {Octs,Bytes3} = getoctets_as_list(Bytes2,Len), + {dec_pos_integer(Octs),Bytes3}; + Range =< 16#100000000 -> + {Len,Bytes2} = decode_length(Buffer,{1,4}), + {Octs,Bytes3} = getoctets_as_list(Bytes2,Len), + {dec_pos_integer(Octs),Bytes3}; + Range =< 16#10000000000 -> + {Len,Bytes2} = decode_length(Buffer,{1,5}), + {Octs,Bytes3} = getoctets_as_list(Bytes2,Len), + {dec_pos_integer(Octs),Bytes3}; + true -> + exit({not_supported,{integer_range,Range}}) + end, + {Val+Lb,Remain}. + +% X.691:10.8 Encoding of an unconstrained whole number + +encode_unconstrained_number(Val) when Val >= 0 -> + Oct = eint(Val,[]), + [{debug,unconstrained_number}, + encode_length({0,'MAX'},length(Oct)), + {octets,Oct}]; +encode_unconstrained_number(Val) -> % negative + Oct = enint(Val,[]), + [{debug,unconstrained_number}, + encode_length({0,'MAX'},length(Oct)), + {octets,Oct}]. + +%% used for positive Values which don't need a sign bit +eint_positive(Val) -> + case eint(Val,[]) of + [0,B1|T] -> + [B1|T]; + T -> + T + end. + +eint(0, [B|Acc]) when B < 128 -> + [B|Acc]; +eint(N, Acc) -> + eint(N bsr 8, [N band 16#ff| Acc]). + +enint(-1, [B1|T]) when B1 > 127 -> + [B1|T]; +enint(N, Acc) -> + enint(N bsr 8, [N band 16#ff|Acc]). + +%% used for signed positive values + +%eint(Val, Ack) -> +% X = Val band 255, +% Next = Val bsr 8, +% if +% Next == 0, X >= 127 -> +% [0,X|Ack]; +% Next == 0 -> +% [X|Ack]; +% true -> +% eint(Next,[X|Ack]) +% end. + +%%% used for signed negative values +%enint(Val, Acc) -> +% NumOctets = if +% -Val < 16#80 -> 1; +% -Val < 16#8000 ->2; +% -Val < 16#800000 ->3; +% -Val < 16#80000000 ->4; +% -Val < 16#8000000000 ->5; +% -Val < 16#800000000000 ->6; +% -Val < 16#80000000000000 ->7; +% -Val < 16#8000000000000000 ->8; +% -Val < 16#800000000000000000 ->9 +% end, +% enint(Val,Acc,NumOctets). + +%enint(Val, Acc,0) -> +% Acc; +%enint(Val, Acc,NumOctets) -> +% enint(Val bsr 8,[Val band 255|Acc],NumOctets-1). + + +decode_unconstrained_number(Bytes) -> + {Len,Bytes2} = decode_length(Bytes,undefined), + {Ints,Bytes3} = getoctets_as_list(Bytes2,Len), + {dec_integer(Ints),Bytes3}. + +dec_pos_integer(Ints) -> + decpint(Ints, 8 * (length(Ints) - 1)). +dec_integer(Ints) when hd(Ints) band 255 =< 127 -> %% Positive number + decpint(Ints, 8 * (length(Ints) - 1)); +dec_integer(Ints) -> %% Negative + decnint(Ints, 8 * (length(Ints) - 1)). + +decpint([Byte|Tail], Shift) -> + (Byte bsl Shift) bor decpint(Tail, Shift-8); +decpint([], _) -> 0. + +decnint([Byte|Tail], Shift) -> + (-128 + (Byte band 127) bsl Shift) bor decpint(Tail, Shift-8). + +minimum_octets(Val) -> + minimum_octets(Val,[]). + +minimum_octets(Val,Acc) when Val > 0 -> + minimum_octets((Val bsr 8),[Val band 16#FF|Acc]); +minimum_octets(0,Acc) -> + Acc. + + +%% X.691:10.9 Encoding of a length determinant +%%encode_small_length(undefined,Len) -> % null means no UpperBound +%% encode_small_number(Len). + +%% X.691:10.9.3.5 +%% X.691:10.9.3.7 +encode_length(undefined,Len) -> % un-constrained + if + Len < 128 -> + {octet,Len band 16#7F}; + Len < 16384 -> + {octets,2,2#1000000000000000 bor Len}; + true -> + exit({error,{asn1,{encode_length,{nyi,above_16k}}}}) + end; + +encode_length({0,'MAX'},Len) -> + encode_length(undefined,Len); +encode_length({Lb,Ub},Len) when Ub =< 65535 ,Lb >= 0 -> % constrained + encode_constrained_number({Lb,Ub},Len); +encode_length(SingleValue,_Len) when integer(SingleValue) -> + []. + +encode_small_length(Len) when Len =< 64 -> + [{bit,0},{bits,6,Len-1}]; +encode_small_length(Len) -> + [{bit,1},encode_length(undefined,Len)]. + +decode_small_length(Buffer) -> + case getbit(Buffer) of + {0,Remain} -> + {Bits,Remain2} = getbits(Remain,6), + {Bits+1,Remain2}; + {1,Remain} -> + decode_length(Remain,undefined) + end. + +decode_length(Buffer) -> + decode_length(Buffer,undefined). + +decode_length(Buffer,undefined) -> % un-constrained + Buffer2 = align(Buffer), + {Bits,_} = getbits(Buffer2,2), + case Bits of + 2 -> + {Val,Bytes3} = getoctets(Buffer2,2), + {(Val band 16#3FFF),Bytes3}; + 3 -> + exit({error,{asn1,{decode_length,{nyi,above_16k}}}}); + _ -> + {Val,Bytes3} = getoctet(Buffer2), + {Val band 16#7F,Bytes3} + end; + +decode_length(Buffer,{Lb,Ub}) when Ub =< 65535 ,Lb >= 0 -> % constrained + decode_constrained_number(Buffer,{Lb,Ub}); + % X.691:10.9.3.5 +decode_length(Buffer,{_,_Lb,_Ub}) -> %when Len =< 127 -> % Unconstrained or large Ub + case getbit(Buffer) of + {0,Remain} -> + getbits(Remain,7); + {1,_Remain} -> + {Val,Remain2} = getoctets(Buffer,2), + {Val band 2#0111111111111111, Remain2} + end; +decode_length(Buffer,SingleValue) when integer(SingleValue) -> + {SingleValue,Buffer}. + + +% X.691:11 +encode_boolean({Name,Val}) when atom(Name) -> + encode_boolean(Val); +encode_boolean(true) -> + {bit,1}; +encode_boolean(false) -> + {bit,0}; +encode_boolean(Val) -> + exit({error,{asn1,{encode_boolean,Val}}}). + + +decode_boolean(Buffer) -> %when record(Buffer,buffer) + case getbit(Buffer) of + {1,Remain} -> {true,Remain}; + {0,Remain} -> {false,Remain} + end. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% X.691:12 +%% ENUMERATED +%% +%% encode_enumerated(C,Value,NamedNumberTup) -> CompleteList +%% +%% + +encode_enumerated(C,{Name,Value},NamedNumberList) when + atom(Name),list(NamedNumberList) -> + encode_enumerated(C,Value,NamedNumberList); + +%% ENUMERATED with extension mark +encode_enumerated(_C,{asn1_enum,Value},{_Nlist1,Nlist2}) when Value >= length(Nlist2) -> + [{bit,1},encode_small_number(Value)]; +encode_enumerated(C,Value,{Nlist1,Nlist2}) -> + case enum_search(Value,Nlist1,0) of + NewV when integer(NewV) -> + [{bit,0},encode_integer(C,NewV)]; + false -> + case enum_search(Value,Nlist2,0) of + ExtV when integer(ExtV) -> + [{bit,1},encode_small_number(ExtV)]; + false -> + exit({error,{asn1,{encode_enumerated,Value}}}) + end + end; + +encode_enumerated(C,Value,NamedNumberList) when list(NamedNumberList) -> + case enum_search(Value,NamedNumberList,0) of + NewV when integer(NewV) -> + encode_integer(C,NewV); + false -> + exit({error,{asn1,{encode_enumerated,Value}}}) + end. + +%% returns the ordinal number from 0 ,1 ... in the list where Name is found +%% or false if not found +%% +enum_search(Name,[Name|_NamedNumberList],Acc) -> + Acc; +enum_search(Name,[_H|T],Acc) -> + enum_search(Name,T,Acc+1); +enum_search(_,[],_) -> + false. % name not found !error + +%% ENUMERATED with extension marker +decode_enumerated(Buffer,C,{Ntup1,Ntup2}) when tuple(Ntup1), tuple(Ntup2) -> + {Ext,Buffer2} = getext(Buffer), + case Ext of + 0 -> % not an extension value + {Val,Buffer3} = decode_integer(Buffer2,C), + case catch (element(Val+1,Ntup1)) of + NewVal when atom(NewVal) -> {NewVal,Buffer3}; + _Error -> exit({error,{asn1,{decode_enumerated,{Val,[Ntup1,Ntup2]}}}}) + end; + 1 -> % this an extension value + {Val,Buffer3} = decode_small_number(Buffer2), + case catch (element(Val+1,Ntup2)) of + NewVal when atom(NewVal) -> {NewVal,Buffer3}; + _ -> {{asn1_enum,Val},Buffer3} + end + end; + +decode_enumerated(Buffer,C,NamedNumberTup) when tuple(NamedNumberTup) -> + {Val,Buffer2} = decode_integer(Buffer,C), + case catch (element(Val+1,NamedNumberTup)) of + NewVal when atom(NewVal) -> {NewVal,Buffer2}; + _Error -> exit({error,{asn1,{decode_enumerated,{Val,NamedNumberTup}}}}) + end. + +%%=============================================================================== +%%=============================================================================== +%%=============================================================================== +%% Bitstring value, ITU_T X.690 Chapter 8.5 +%%=============================================================================== +%%=============================================================================== +%%=============================================================================== + +%%=============================================================================== +%% encode bitstring value +%%=============================================================================== + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% bitstring NamedBitList +%% Val can be of: +%% - [identifiers] where only named identifers are set to one, +%% the Constraint must then have some information of the +%% bitlength. +%% - [list of ones and zeroes] all bits +%% - integer value representing the bitlist +%% C is constraint Len, only valid when identifiers + +%% when the value is a list of named bits +encode_bit_string(C, [FirstVal | RestVal], NamedBitList) when atom(FirstVal) -> + ToSetPos = get_all_bitposes([FirstVal | RestVal], NamedBitList, []), + BitList = make_and_set_list(ToSetPos,0), + encode_bit_string(C,BitList,NamedBitList); + +encode_bit_string(C, [{bit,No} | RestVal], NamedBitList) -> + ToSetPos = get_all_bitposes([{bit,No} | RestVal], NamedBitList, []), + BitList = make_and_set_list(ToSetPos,0), + encode_bit_string(C,BitList,NamedBitList); + +%% when the value is a list of ones and zeroes + +encode_bit_string(C, BitListValue, _NamedBitList) when list(BitListValue) -> + %% first remove any trailing zeroes + Bl1 = lists:dropwhile(fun(0)->true;(1)->false end,lists:reverse(BitListValue)), + BitList = [{bit,X} || X <- lists:reverse(Bl1)], + case get_constraint(C,'SizeConstraint') of + 0 -> % fixed length + []; % nothing to encode + V when integer(V),V=<16 -> % fixed length 16 bits or less + pad_list(V,BitList); + V when integer(V) -> % fixed length more than 16 bits + [align,pad_list(V,BitList)]; + {Lb,Ub} when integer(Lb),integer(Ub) -> + [encode_length({Lb,Ub},length(BitList)),align,BitList]; + no -> + [encode_length(undefined,length(BitList)),align,BitList] + end; + +%% when the value is an integer +encode_bit_string(C, IntegerVal, NamedBitList) -> + BitList = int_to_bitlist(IntegerVal), + encode_bit_string(C,BitList,NamedBitList). + + + + +%%%%%%%%%%%%%%% +%% The result is presented as a list of named bits (if possible) +%% else as a list of 0 and 1. +%% +decode_bit_string(Buffer, C, NamedNumberList) -> + case get_constraint(C,'SizeConstraint') of + 0 -> % fixed length + {[],Buffer}; % nothing to encode + V when integer(V),V=<16 -> % fixed length 16 bits or less + bit_list_to_named(Buffer,V,NamedNumberList); + V when integer(V) -> % fixed length 16 bits or less + Bytes2 = align(Buffer), + bit_list_to_named(Bytes2,V,NamedNumberList); + {Lb,Ub} when integer(Lb),integer(Ub) -> + {Len,Bytes2} = decode_length(Buffer,{Lb,Ub}), + Bytes3 = align(Bytes2), + bit_list_to_named(Bytes3,Len,NamedNumberList); + no -> + {Len,Bytes2} = decode_length(Buffer,undefined), + Bytes3 = align(Bytes2), + bit_list_to_named(Bytes3,Len,NamedNumberList) + end. + +%% if no named bits are declared we will return a +%% BitList = [0 | 1] + +bit_list_to_named(Buffer,Len,[]) -> + getbits_as_list(Len,Buffer); + +%% if there are named bits declared we will return a named +%% BitList where the names are atoms and unnamed bits represented +%% as {bit,Pos} +%% BitList = [atom() | {bit,Pos}] +%% Pos = integer() + +bit_list_to_named(Buffer,Len,NamedNumberList) -> + {BitList,Rest} = getbits_as_list(Len,Buffer), + {bit_list_to_named1(0,BitList,NamedNumberList,[]), Rest}. + +bit_list_to_named1(Pos,[0|Bt],Names,Acc) -> + bit_list_to_named1(Pos+1,Bt,Names,Acc); +bit_list_to_named1(Pos,[1|Bt],Names,Acc) -> + case lists:keysearch(Pos,2,Names) of + {value,{Name,_}} -> + bit_list_to_named1(Pos+1,Bt,Names,[Name|Acc]); + _ -> + bit_list_to_named1(Pos+1,Bt,Names,[{bit,Pos}|Acc]) + end; +bit_list_to_named1(_Pos,[],_Names,Acc) -> + lists:reverse(Acc). + + + +%%%%%%%%%%%%%%% +%% + +int_to_bitlist(0) -> + []; +int_to_bitlist(Int) when integer(Int), Int >= 0 -> + [Int band 1 | int_to_bitlist(Int bsr 1)]. + + +%%%%%%%%%%%%%%%%%% +%% get_all_bitposes([list of named bits to set], named_bit_db, []) -> +%% [sorted_list_of_bitpositions_to_set] + +get_all_bitposes([{bit,ValPos}|Rest], NamedBitList, Ack) -> + get_all_bitposes(Rest, NamedBitList, [ValPos | Ack ]); + +get_all_bitposes([Val | Rest], NamedBitList, Ack) -> + case lists:keysearch(Val, 1, NamedBitList) of + {value, {_ValName, ValPos}} -> + get_all_bitposes(Rest, NamedBitList, [ValPos | Ack]); + _ -> + exit({error,{asn1, {bitstring_namedbit, Val}}}) + end; +get_all_bitposes([], _NamedBitList, Ack) -> + lists:sort(Ack). + +%%%%%%%%%%%%%%%%%% +%% make_and_set_list([list of positions to set to 1])-> +%% returns list with all in SetPos set. +%% in positioning in list the first element is 0, the second 1 etc.., but +%% + +make_and_set_list([XPos|SetPos], XPos) -> + [1 | make_and_set_list(SetPos, XPos + 1)]; +make_and_set_list([Pos|SetPos], XPos) -> + [0 | make_and_set_list([Pos | SetPos], XPos + 1)]; +make_and_set_list([], _) -> + []. + +%%%%%%%%%%%%%%%%% +%% pad_list(N,BitList) -> PaddedList +%% returns a padded (with trailing {bit,0} elements) list of length N +%% if Bitlist contains more than N significant bits set an exit asn1_error +%% is generated + +pad_list(0,BitList) -> + case BitList of + [] -> []; + _ -> exit({error,{asn1,{range_error,{bit_string,BitList}}}}) + end; +pad_list(N,[Bh|Bt]) -> + [Bh|pad_list(N-1,Bt)]; +pad_list(N,[]) -> + [{bit,0},pad_list(N-1,[])]. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% X.691:16 +%% encode_octet_string(Constraint,ExtensionMarker,Val) +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +encode_octet_string(C,{Name,Val}) when atom(Name) -> + encode_octet_string(C,false,Val); +encode_octet_string(C,Val) -> + encode_octet_string(C,false,Val). + +encode_octet_string(_C,true,_Val) -> + exit({error,{asn1,{'not_supported',extensionmarker}}}); +encode_octet_string(C,false,Val) -> + case get_constraint(C,'SizeConstraint') of + 0 -> + []; + 1 -> + [V] = Val, + {bits,8,V}; + 2 -> + [V1,V2] = Val, + [{bits,8,V1},{bits,8,V2}]; + Sv when Sv =<65535, Sv == length(Val) -> % fixed length + [align,{octets,Val}]; + {Lb,Ub} -> + [encode_length({Lb,Ub},length(Val)),align, + {octets,Val}]; + Sv when list(Sv) -> + [encode_length({hd(Sv),lists:max(Sv)},length(Val)),align, + {octets,Val}]; + no -> + [encode_length(undefined,length(Val)),align, + {octets,Val}] + end. + +decode_octet_string(Bytes,Range) -> + decode_octet_string(Bytes,Range,false). + +decode_octet_string(Bytes,C,false) -> + case get_constraint(C,'SizeConstraint') of + 0 -> + {[],Bytes}; + 1 -> + {B1,Bytes2} = getbits(Bytes,8), + {[B1],Bytes2}; + 2 -> + {B1,Bytes2}= getbits(Bytes,8), + {B2,Bytes3}= getbits(Bytes2,8), + {[B1,B2],Bytes3}; + {_,0} -> + {[],Bytes}; + Sv when integer(Sv), Sv =<65535 -> % fixed length + Bytes2 = align(Bytes), + getoctets_as_list(Bytes2,Sv); + {Lb,Ub} -> + {Len,Bytes2} = decode_length(Bytes,{Lb,Ub}), + Bytes3 = align(Bytes2), + getoctets_as_list(Bytes3,Len); + Sv when list(Sv) -> + {Len,Bytes2} = decode_length(Bytes,{hd(Sv),lists:max(Sv)}), + Bytes3 = align(Bytes2), + getoctets_as_list(Bytes3,Len); + no -> + {Len,Bytes2} = decode_length(Bytes,undefined), + Bytes3 = align(Bytes2), + getoctets_as_list(Bytes3,Len) + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Restricted char string types +%% (NumericString, PrintableString,VisibleString,IA5String,BMPString,UniversalString) +%% X.691:26 and X.680:34-36 +%%encode_restricted_string(aligned,'BMPString',Constraints,Extension,Val) + +encode_restricted_string(aligned,StringType,C,Val) -> +encode_restricted_string(aligned,StringType,C,false,Val). + + +encode_restricted_string(aligned,StringType,C,_Ext,{Name,Val}) when atom(Name) -> + encode_restricted_string(aligned,StringType,C,false,Val); +encode_restricted_string(aligned,StringType,C,_Ext,Val) -> + Result = chars_encode(C,StringType,Val), + NumBits = get_NumBits(C,StringType), + case get_constraint(C,'SizeConstraint') of + Ub when integer(Ub), Ub*NumBits =< 16 -> + case {StringType,Result} of + {'BMPString',{octets,Ol}} -> + [{bits,8,Oct}||Oct <- Ol]; + _ -> + Result + end; + 0 -> + []; + Ub when integer(Ub),Ub =<65535 -> % fixed length + [align,Result]; + {Ub,Lb} -> + [encode_length({Ub,Lb},length(Val)),align,Result]; + Vl when list(Vl) -> + [encode_length({lists:min(Vl),lists:max(Vl)},length(Val)),align,Result]; + no -> + [encode_length(undefined,length(Val)),align,Result] + end. + +decode_restricted_string(Bytes,aligned,StringType,C) -> + decode_restricted_string(Bytes,aligned,StringType,C,false). + +decode_restricted_string(Bytes,aligned,StringType,C,_Ext) -> + NumBits = get_NumBits(C,StringType), + case get_constraint(C,'SizeConstraint') of + Ub when integer(Ub), Ub*NumBits =< 16 -> + chars_decode(Bytes,NumBits,StringType,C,Ub); + Ub when integer(Ub),Ub =<65535 -> % fixed length + Bytes1 = align(Bytes), + chars_decode(Bytes1,NumBits,StringType,C,Ub); + 0 -> + {[],Bytes}; + Vl when list(Vl) -> + {Len,Bytes1} = decode_length(Bytes,{hd(Vl),lists:max(Vl)}), + Bytes2 = align(Bytes1), + chars_decode(Bytes2,NumBits,StringType,C,Len); + no -> + {Len,Bytes1} = decode_length(Bytes,undefined), + Bytes2 = align(Bytes1), + chars_decode(Bytes2,NumBits,StringType,C,Len); + {Lb,Ub}-> + {Len,Bytes1} = decode_length(Bytes,{Lb,Ub}), + Bytes2 = align(Bytes1), + chars_decode(Bytes2,NumBits,StringType,C,Len) + end. + + + +encode_BMPString(C,Val) -> + encode_restricted_string(aligned,'BMPString',C,false,Val). +decode_BMPString(Bytes,C) -> + decode_restricted_string(Bytes,aligned,'BMPString',C,false). + +encode_GeneralString(C,Val) -> + encode_restricted_string(aligned,'GeneralString',C,false,Val). +decode_GeneralString(Bytes,C) -> + decode_restricted_string(Bytes,aligned,'GeneralString',C,false). + +encode_GraphicString(C,Val) -> + encode_restricted_string(aligned,'GraphicString',C,false,Val). +decode_GraphicString(Bytes,C) -> + decode_restricted_string(Bytes,aligned,'GraphicString',C,false). + +encode_IA5String(C,Val) -> + encode_restricted_string(aligned,'IA5String',C,false,Val). +decode_IA5String(Bytes,C) -> + decode_restricted_string(Bytes,aligned,'IA5String',C,false). + +encode_NumericString(C,Val) -> + encode_restricted_string(aligned,'NumericString',C,false,Val). +decode_NumericString(Bytes,C) -> + decode_restricted_string(Bytes,aligned,'NumericString',C,false). + +encode_PrintableString(C,Val) -> + encode_restricted_string(aligned,'PrintableString',C,false,Val). +decode_PrintableString(Bytes,C) -> + decode_restricted_string(Bytes,aligned,'PrintableString',C,false). + +encode_TeletexString(C,Val) -> % equivalent with T61String + encode_restricted_string(aligned,'TeletexString',C,false,Val). +decode_TeletexString(Bytes,C) -> + decode_restricted_string(Bytes,aligned,'TeletexString',C,false). + +encode_UniversalString(C,Val) -> + encode_restricted_string(aligned,'UniversalString',C,false,Val). +decode_UniversalString(Bytes,C) -> + decode_restricted_string(Bytes,aligned,'UniversalString',C,false). + +encode_VideotexString(C,Val) -> + encode_restricted_string(aligned,'VideotexString',C,false,Val). +decode_VideotexString(Bytes,C) -> + decode_restricted_string(Bytes,aligned,'VideotexString',C,false). + +encode_VisibleString(C,Val) -> % equivalent with ISO646String + encode_restricted_string(aligned,'VisibleString',C,false,Val). +decode_VisibleString(Bytes,C) -> + decode_restricted_string(Bytes,aligned,'VisibleString',C,false). + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% getBMPChars(Bytes,Len) ->{BMPcharList,RemainingBytes} +%% +getBMPChars(Bytes,1) -> + {O1,Bytes2} = getbits(Bytes,8), + {O2,Bytes3} = getbits(Bytes2,8), + if + O1 == 0 -> + {[O2],Bytes3}; + true -> + {[{O1,O2}],Bytes3} + end; +getBMPChars(Bytes,Len) -> + getBMPChars(Bytes,Len,[]). + +getBMPChars(Bytes,0,Acc) -> + {lists:reverse(Acc),Bytes}; +getBMPChars(Bytes,Len,Acc) -> + {Octs,Bytes1} = getoctets_as_list(Bytes,2), + case Octs of + [0,O2] -> + getBMPChars(Bytes1,Len-1,[O2|Acc]); + [O1,O2]-> + getBMPChars(Bytes1,Len-1,[{O1,O2}|Acc]) + end. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% chars_encode(C,StringType,Value) -> ValueList +%% +%% encodes chars according to the per rules taking the constraint PermittedAlphabet +%% into account. +%% This function does only encode the value part and NOT the length + +chars_encode(C,StringType,Value) -> + case {StringType,get_constraint(C,'PermittedAlphabet')} of + {'UniversalString',{_,_Sv}} -> + exit({error,{asn1,{'not implemented',"UniversalString with PermittedAlphabet constraint"}}}); + {'BMPString',{_,_Sv}} -> + exit({error,{asn1,{'not implemented',"BMPString with PermittedAlphabet constraint"}}}); + _ -> + {NumBits,CharOutTab} = {get_NumBits(C,StringType),get_CharOutTab(C,StringType)}, + chars_encode2(Value,NumBits,CharOutTab) + end. + +chars_encode2([H|T],NumBits,{Min,Max,notab}) when H =< Max, H >= Min -> + [{bits,NumBits,H-Min}|chars_encode2(T,NumBits,{Min,Max,notab})]; +chars_encode2([H|T],NumBits,{Min,Max,Tab}) when H =< Max, H >= Min -> + [{bits,NumBits,element(H-Min+1,Tab)}|chars_encode2(T,NumBits,{Min,Max,Tab})]; +chars_encode2([{A,B,C,D}|T],NumBits,{Min,Max,notab}) -> + %% no value range check here (ought to be, but very expensive) + [{bits,NumBits,(A*B*C*D)-Min}|chars_encode2(T,NumBits,{Min,Max,notab})]; +chars_encode2([{A,B,C,D}|T],NumBits,{Min,Max,Tab}) -> + %% no value range check here (ought to be, but very expensive) + [{bits,NumBits,element((A*B*C*D)-Min,Tab)}|chars_encode2(T,NumBits,{Min,Max,notab})]; +chars_encode2([H|_T],_NumBits,{_Min,_Max,_Tab}) -> + exit({error,{asn1,{illegal_char_value,H}}}); +chars_encode2([],_,_) -> + []. + + +get_NumBits(C,StringType) -> + case get_constraint(C,'PermittedAlphabet') of + {'SingleValue',Sv} -> + charbits(length(Sv),aligned); + no -> + case StringType of + 'GeneralString' -> + exit({error,{asn1,{not implemented,'GeneralString'}}}); + 'GraphicString' -> + exit({error,{asn1,{not implemented,'GraphicString'}}}); + 'TeletexString' -> + exit({error,{asn1,{not implemented,'TeletexString'}}}); + 'VideotexString' -> + exit({error,{asn1,{not implemented,'VideotexString'}}}); + 'IA5String' -> + charbits(128,aligned); % 16#00..16#7F + 'VisibleString' -> + charbits(95,aligned); % 16#20..16#7E + 'PrintableString' -> + charbits(74,aligned); % [$\s,$',$(,$),$+,$,,$-,$.,$/,"0123456789",$:,$=,$?,$A..$Z,$a..$z + 'NumericString' -> + charbits(11,aligned); % $ ,"0123456789" + 'UniversalString' -> + 32; + 'BMPString' -> + 16 + end + end. + +%%Maybe used later +%%get_MaxChar(C,StringType) -> +%% case get_constraint(C,'PermittedAlphabet') of +%% {'SingleValue',Sv} -> +%% lists:nth(length(Sv),Sv); +%% no -> +%% case StringType of +%% 'IA5String' -> +%% 16#7F; % 16#00..16#7F +%% 'VisibleString' -> +%% 16#7E; % 16#20..16#7E +%% 'PrintableString' -> +%% $z; % [$\s,$',$(,$),$+,$,,$-,$.,$/,"0123456789",$:,$=,$?,$A..$Z,$a..$z +%% 'NumericString' -> +%% $9; % $ ,"0123456789" +%% 'UniversalString' -> +%% 16#ffffffff; +%% 'BMPString' -> +%% 16#ffff +%% end +%% end. + +%%Maybe used later +%%get_MinChar(C,StringType) -> +%% case get_constraint(C,'PermittedAlphabet') of +%% {'SingleValue',Sv} -> +%% hd(Sv); +%% no -> +%% case StringType of +%% 'IA5String' -> +%% 16#00; % 16#00..16#7F +%% 'VisibleString' -> +%% 16#20; % 16#20..16#7E +%% 'PrintableString' -> +%% $\s; % [$\s,$',$(,$),$+,$,,$-,$.,$/,"0123456789",$:,$=,$?,$A..$Z,$a..$z +%% 'NumericString' -> +%% $\s; % $ ,"0123456789" +%% 'UniversalString' -> +%% 16#00; +%% 'BMPString' -> +%% 16#00 +%% end +%% end. + +get_CharOutTab(C,StringType) -> + get_CharTab(C,StringType,out). + +get_CharInTab(C,StringType) -> + get_CharTab(C,StringType,in). + +get_CharTab(C,StringType,InOut) -> + case get_constraint(C,'PermittedAlphabet') of + {'SingleValue',Sv} -> + get_CharTab2(C,StringType,hd(Sv),lists:max(Sv),Sv,InOut); + no -> + case StringType of + 'IA5String' -> + {0,16#7F,notab}; + 'VisibleString' -> + get_CharTab2(C,StringType,16#20,16#7F,notab,InOut); + 'PrintableString' -> + Chars = lists:sort( + " '()+,-./0123456789:=?ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"), + get_CharTab2(C,StringType,hd(Chars),lists:max(Chars),Chars,InOut); + 'NumericString' -> + get_CharTab2(C,StringType,16#20,$9," 0123456789",InOut); + 'UniversalString' -> + {0,16#FFFFFFFF,notab}; + 'BMPString' -> + {0,16#FFFF,notab} + end + end. + +get_CharTab2(C,StringType,Min,Max,Chars,InOut) -> + BitValMax = (1 bsl get_NumBits(C,StringType))-1, + if + Max =< BitValMax -> + {0,Max,notab}; + true -> + case InOut of + out -> + {Min,Max,create_char_tab(Min,Chars)}; + in -> + {Min,Max,list_to_tuple(Chars)} + end + end. + +create_char_tab(Min,L) -> + list_to_tuple(create_char_tab(Min,L,0)). +create_char_tab(Min,[Min|T],V) -> + [V|create_char_tab(Min+1,T,V+1)]; +create_char_tab(_Min,[],_V) -> + []; +create_char_tab(Min,L,V) -> + [false|create_char_tab(Min+1,L,V)]. + +%% This very inefficient and should be moved to compiletime +charbits(NumOfChars,aligned) -> + case charbits(NumOfChars) of + 1 -> 1; + 2 -> 2; + B when B > 2, B =< 4 -> 4; + B when B > 4, B =< 8 -> 8; + B when B > 8, B =< 16 -> 16; + B when B > 16, B =< 32 -> 32 + end. + +charbits(NumOfChars) when NumOfChars =< 2 -> 1; +charbits(NumOfChars) when NumOfChars =< 4 -> 2; +charbits(NumOfChars) when NumOfChars =< 8 -> 3; +charbits(NumOfChars) when NumOfChars =< 16 -> 4; +charbits(NumOfChars) when NumOfChars =< 32 -> 5; +charbits(NumOfChars) when NumOfChars =< 64 -> 6; +charbits(NumOfChars) when NumOfChars =< 128 -> 7; +charbits(NumOfChars) when NumOfChars =< 256 -> 8; +charbits(NumOfChars) when NumOfChars =< 512 -> 9; +charbits(NumOfChars) when NumOfChars =< 1024 -> 10; +charbits(NumOfChars) when NumOfChars =< 2048 -> 11; +charbits(NumOfChars) when NumOfChars =< 4096 -> 12; +charbits(NumOfChars) when NumOfChars =< 8192 -> 13; +charbits(NumOfChars) when NumOfChars =< 16384 -> 14; +charbits(NumOfChars) when NumOfChars =< 32768 -> 15; +charbits(NumOfChars) when NumOfChars =< 65536 -> 16; +charbits(NumOfChars) when integer(NumOfChars) -> + 16 + charbits1(NumOfChars bsr 16). + +charbits1(0) -> + 0; +charbits1(NumOfChars) -> + 1 + charbits1(NumOfChars bsr 1). + + +chars_decode(Bytes,_,'BMPString',C,Len) -> + case get_constraint(C,'PermittedAlphabet') of + no -> + getBMPChars(Bytes,Len); + _ -> + exit({error,{asn1, + {'not implemented', + "BMPString with PermittedAlphabet constraint"}}}) + end; +chars_decode(Bytes,NumBits,StringType,C,Len) -> + CharInTab = get_CharInTab(C,StringType), + chars_decode2(Bytes,CharInTab,NumBits,Len). + + +chars_decode2(Bytes,CharInTab,NumBits,Len) -> + chars_decode2(Bytes,CharInTab,NumBits,Len,[]). + +chars_decode2(Bytes,_CharInTab,_NumBits,0,Acc) -> + {lists:reverse(Acc),Bytes}; +chars_decode2(Bytes,{Min,Max,notab},NumBits,Len,Acc) when NumBits > 8 -> + {Char,Bytes2} = getbits(Bytes,NumBits), + Result = case minimum_octets(Char+Min) of + [NewChar] -> NewChar; + [C1,C2] -> {0,0,C1,C2}; + [C1,C2,C3] -> {0,C1,C2,C3}; + [C1,C2,C3,C4] -> {C1,C2,C3,C4} + end, + chars_decode2(Bytes2,{Min,Max,notab},NumBits,Len -1,[Result|Acc]); +chars_decode2(Bytes,{Min,Max,notab},NumBits,Len,Acc) -> + {Char,Bytes2} = getbits(Bytes,NumBits), + chars_decode2(Bytes2,{Min,Max,notab},NumBits,Len -1,[Char+Min|Acc]); + +%% BMPString and UniversalString with PermittedAlphabet is currently not supported +chars_decode2(Bytes,{Min,Max,CharInTab},NumBits,Len,Acc) -> + {Char,Bytes2} = getbits(Bytes,NumBits), + chars_decode2(Bytes2,{Min,Max,CharInTab},NumBits,Len -1,[element(Char+1,CharInTab)|Acc]). + + + % X.691:17 +encode_null({Name,Val}) when atom(Name) -> + encode_null(Val); +encode_null(_) -> []. % encodes to nothing + +decode_null(Bytes) -> + {'NULL',Bytes}. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% encode_object_identifier(Val) -> CompleteList +%% encode_object_identifier({Name,Val}) -> CompleteList +%% Val -> {Int1,Int2,...,IntN} % N >= 2 +%% Name -> atom() +%% Int1 -> integer(0..2) +%% Int2 -> integer(0..39) when Int1 (0..1) else integer() +%% Int3-N -> integer() +%% CompleteList -> [{bits,8,Val}|{octets,Ol}|align|...] +%% +encode_object_identifier(Val) -> + Octets = e_object_identifier(Val,notag), + [{debug,object_identifier},encode_length(undefined,length(Octets)),{octets,Octets}]. + +%% This code is copied from asn1_encode.erl (BER) and corrected and modified + +e_object_identifier({'OBJECT IDENTIFIER',V},DoTag) -> + e_object_identifier(V,DoTag); +e_object_identifier({Cname,V},DoTag) when atom(Cname),tuple(V) -> + e_object_identifier(tuple_to_list(V),DoTag); +e_object_identifier({Cname,V},DoTag) when atom(Cname),list(V) -> + e_object_identifier(V,DoTag); +e_object_identifier(V,DoTag) when tuple(V) -> + e_object_identifier(tuple_to_list(V),DoTag); + +% E1 = 0|1|2 and (E2 < 40 when E1 = 0|1) +e_object_identifier([E1,E2|Tail],_DoTag) when E1 =< 2 -> + Head = 40*E1 + E2, % weird + Res = e_object_elements([Head|Tail]), +% dotag(DoTag,[6],elength(length(Res)+1),[Head|Res]), + Res. + +e_object_elements([]) -> + []; +e_object_elements([H|T]) -> + lists:append(e_object_element(H),e_object_elements(T)). + +e_object_element(Num) when Num < 128 -> + [Num]; +% must be changed to handle more than 2 octets +e_object_element(Num) -> %% when Num < ??? + Left = ((Num band 2#11111110000000) bsr 7) bor 2#10000000, + Right = Num band 2#1111111 , + [Left,Right]. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% decode_object_identifier(Bytes) -> {ObjId,RemainingBytes} +%% ObjId -> {integer(),integer(),...} % at least 2 integers +%% RemainingBytes -> [integer()] when integer() (0..255) +decode_object_identifier(Bytes) -> + {Len,Bytes2} = decode_length(Bytes,undefined), + {Octs,Bytes3} = getoctets_as_list(Bytes2,Len), + [First|Rest] = dec_subidentifiers(Octs,0,[]), + Idlist = if + First < 40 -> + [0,First|Rest]; + First < 80 -> + [1,First - 40|Rest]; + true -> + [2,First - 80|Rest] + end, + {list_to_tuple(Idlist),Bytes3}. + +dec_subidentifiers([H|T],Av,Al) when H >=16#80 -> + dec_subidentifiers(T,(Av bsl 7) + (H band 16#7F),Al); +dec_subidentifiers([H|T],Av,Al) -> + dec_subidentifiers(T,0,[(Av bsl 7) + H |Al]); +dec_subidentifiers([],_Av,Al) -> + lists:reverse(Al). + +get_constraint(C,Key) -> + case lists:keysearch(Key,1,C) of + false -> + no; + {value,{_,V}} -> + V + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% complete(InList) -> ByteList +%% Takes a coded list with bits and bytes and converts it to a list of bytes +%% Should be applied as the last step at encode of a complete ASN.1 type +%% +complete(InList) when list(InList) -> + complete(InList,[],0); +complete(InList) -> + complete([InList],[],0). + +complete([{debug,_}|T], Acc, Acclen) -> + complete(T,Acc,Acclen); +complete([H|T],Acc,Acclen) when list(H) -> + complete(lists:concat([H,T]),Acc,Acclen); + + +complete([{octets,N,Val}|T],Acc,Acclen) when N =< 4 ,integer(Val) -> + Newval = case N of + 1 -> + Val4 = Val band 16#FF, + [Val4]; + 2 -> + Val3 = (Val bsr 8) band 16#FF, + Val4 = Val band 16#FF, + [Val3,Val4]; + 3 -> + Val2 = (Val bsr 16) band 16#FF, + Val3 = (Val bsr 8) band 16#FF, + Val4 = Val band 16#FF, + [Val2,Val3,Val4]; + 4 -> + Val1 = (Val bsr 24) band 16#FF, + Val2 = (Val bsr 16) band 16#FF, + Val3 = (Val bsr 8) band 16#FF, + Val4 = Val band 16#FF, + [Val1,Val2,Val3,Val4] + end, + complete([{octets,Newval}|T],Acc,Acclen); + +complete([{octets,Oct}|T],[],_Acclen) when list(Oct) -> + complete(T,lists:reverse(Oct),0); +complete([{octets,Oct}|T],[Hacc|Tacc],Acclen) when list(Oct) -> + Rest = 8 - Acclen, + if + Rest == 8 -> + complete(T,lists:concat([lists:reverse(Oct),[Hacc|Tacc]]),0); + true -> + complete(T,lists:concat([lists:reverse(Oct),[Hacc bsl Rest|Tacc]]),0) + end; + +complete([{bit,Val}|T], Acc, Acclen) -> + complete([{bits,1,Val}|T],Acc,Acclen); +complete([{octet,Val}|T], Acc, Acclen) -> + complete([{octets,1,Val}|T],Acc,Acclen); + +complete([{bits,N,Val}|T], Acc, 0) when N =< 8 -> + complete(T,[Val|Acc],N); +complete([{bits,N,Val}|T], [Hacc|Tacc], Acclen) when N =< 8 -> + Rest = 8 - Acclen, + if + Rest >= N -> + complete(T,[(Hacc bsl N) + Val|Tacc],(Acclen+N) rem 8); + true -> + Diff = N - Rest, + NewHacc = (Hacc bsl Rest) + (Val bsr Diff), + Mask = element(Diff,{1,3,7,15,31,63,127,255}), + complete(T,[(Val band Mask),NewHacc|Tacc],(Acclen+N) rem 8) + end; +complete([{bits,N,Val}|T], Acc, Acclen) -> % N > 8 + complete([{bits,N-8,Val bsr 8},{bits,8,Val band 255}|T],Acc,Acclen); + +complete([align|T],Acc,0) -> + complete(T,Acc,0); +complete([align|T],[Hacc|Tacc],Acclen) -> + Rest = 8 - Acclen, + complete(T,[Hacc bsl Rest|Tacc],0); +complete([{octets,_N,Val}|T],Acc,Acclen) when list(Val) -> % no security check here + complete([{octets,Val}|T],Acc,Acclen); +complete([],Acc,0) -> + lists:reverse(Acc); +complete([],[Hacc|Tacc],Acclen) when Acclen > 0-> + Rest = 8 - Acclen, + NewHacc = Hacc bsl Rest, + lists:reverse([NewHacc|Tacc]). diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_per_bin.erl b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_per_bin.erl new file mode 100644 index 0000000000..8b4512b58e --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_per_bin.erl @@ -0,0 +1,2176 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: asn1rt_per_bin.erl,v 1.1 2008/12/17 09:53:31 mikpe Exp $ +%% +-module(asn1rt_per_bin). + +%% encoding / decoding of PER aligned + +-include("asn1_records.hrl"). + +-export([dec_fixup/3, cindex/3, list_to_record/2]). +-export([setchoiceext/1, setext/1, fixoptionals/2, fixoptionals/3, + fixextensions/2, + getext/1, getextension/2, skipextensions/3, getbit/1, getchoice/3 ]). +-export([getoptionals/2, getoptionals2/2, set_choice/3, encode_integer/2, encode_integer/3 ]). +-export([decode_integer/2, decode_integer/3, encode_small_number/1, encode_boolean/1, + decode_boolean/1, encode_length/2, decode_length/1, decode_length/2, + encode_small_length/1, decode_small_length/1, + decode_compact_bit_string/3]). +-export([decode_enumerated/3, + encode_bit_string/3, decode_bit_string/3 ]). +-export([encode_octet_string/2, decode_octet_string/2, + encode_null/1, decode_null/1, + encode_object_identifier/1, decode_object_identifier/1, + complete/1]). + + +-export([encode_open_type/2, decode_open_type/2]). + +-export([encode_UniversalString/2, decode_UniversalString/2, + encode_PrintableString/2, decode_PrintableString/2, + encode_GeneralString/2, decode_GeneralString/2, + encode_GraphicString/2, decode_GraphicString/2, + encode_TeletexString/2, decode_TeletexString/2, + encode_VideotexString/2, decode_VideotexString/2, + encode_VisibleString/2, decode_VisibleString/2, + encode_BMPString/2, decode_BMPString/2, + encode_IA5String/2, decode_IA5String/2, + encode_NumericString/2, decode_NumericString/2, + encode_ObjectDescriptor/2, decode_ObjectDescriptor/1 + ]). +-export([complete_bytes/1]). + +-define('16K',16384). +-define('32K',32768). +-define('64K',65536). + +dec_fixup(Terms,Cnames,RemBytes) -> + dec_fixup(Terms,Cnames,RemBytes,[]). + +dec_fixup([novalue|T],[_Hc|Tc],RemBytes,Acc) -> + dec_fixup(T,Tc,RemBytes,Acc); +dec_fixup([{_Name,novalue}|T],[_Hc|Tc],RemBytes,Acc) -> + dec_fixup(T,Tc,RemBytes,Acc); +dec_fixup([H|T],[Hc|Tc],RemBytes,Acc) -> + dec_fixup(T,Tc,RemBytes,[{Hc,H}|Acc]); +dec_fixup([],_Cnames,RemBytes,Acc) -> + {lists:reverse(Acc),RemBytes}. + +cindex(Ix,Val,Cname) -> + case element(Ix,Val) of + {Cname,Val2} -> Val2; + X -> X + end. + +%% converts a list to a record if necessary +list_to_record(_Name,Tuple) when tuple(Tuple) -> + Tuple; +list_to_record(Name,List) when list(List) -> + list_to_tuple([Name|List]). + +%%-------------------------------------------------------- +%% setchoiceext(InRootSet) -> [{bit,X}] +%% X is set to 1 when InRootSet==false +%% X is set to 0 when InRootSet==true +%% +setchoiceext(true) -> + [{debug,choiceext},{bits,1,0}]; +setchoiceext(false) -> + [{debug,choiceext},{bits,1,1}]. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% setext(true|false) -> CompleteList +%% + +setext(false) -> + [{debug,ext},{bits,1,0}]; +setext(true) -> + [{debug,ext},{bits,1,1}]. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% This version of fixoptionals/2 are left only because of +%% backward compatibility with older generates + +fixoptionals(OptList,Val) when tuple(Val) -> + fixoptionals1(OptList,Val,[]); + +fixoptionals(OptList,Val) when list(Val) -> + fixoptionals1(OptList,Val,1,[],[]). + +fixoptionals1([],Val,Acc) -> + %% return {Val,Opt} + {Val,lists:reverse(Acc)}; +fixoptionals1([{_,Pos}|Ot],Val,Acc) -> + case element(Pos+1,Val) of + asn1_NOVALUE -> fixoptionals1(Ot,Val,[0|Acc]); + asn1_DEFAULT -> fixoptionals1(Ot,Val,[0|Acc]); + _ -> fixoptionals1(Ot,Val,[1|Acc]) + end. + + +fixoptionals1([{Name,Pos}|Ot],[{Name,Val}|Vt],_Opt,Acc1,Acc2) -> + fixoptionals1(Ot,Vt,Pos+1,[1|Acc1],[{Name,Val}|Acc2]); +fixoptionals1([{_Name,Pos}|Ot],V,Pos,Acc1,Acc2) -> + fixoptionals1(Ot,V,Pos+1,[0|Acc1],[asn1_NOVALUE|Acc2]); +fixoptionals1(O,[Vh|Vt],Pos,Acc1,Acc2) -> + fixoptionals1(O,Vt,Pos+1,Acc1,[Vh|Acc2]); +fixoptionals1([],[Vh|Vt],Pos,Acc1,Acc2) -> + fixoptionals1([],Vt,Pos+1,Acc1,[Vh|Acc2]); +fixoptionals1([],[],_,Acc1,Acc2) -> + % return {Val,Opt} + {list_to_tuple([asn1_RECORDNAME|lists:reverse(Acc2)]),lists:reverse(Acc1)}. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% This is the new fixoptionals/3 which is used by the new generates +%% +fixoptionals(OptList,OptLength,Val) when tuple(Val) -> + Bits = fixoptionals(OptList,Val,0), + {Val,{bits,OptLength,Bits}}; + +fixoptionals([],_Val,Acc) -> + %% Optbits + Acc; +fixoptionals([Pos|Ot],Val,Acc) -> + case element(Pos,Val) of + asn1_NOVALUE -> fixoptionals(Ot,Val,Acc bsl 1); + asn1_DEFAULT -> fixoptionals(Ot,Val,Acc bsl 1); + _ -> fixoptionals(Ot,Val,(Acc bsl 1) + 1) + end. + + +getext(Bytes) when tuple(Bytes) -> + getbit(Bytes); +getext(Bytes) when binary(Bytes) -> + getbit({0,Bytes}); +getext(Bytes) when list(Bytes) -> + getbit({0,Bytes}). + +getextension(0, Bytes) -> + {{},Bytes}; +getextension(1, Bytes) -> + {Len,Bytes2} = decode_small_length(Bytes), + {Blist, Bytes3} = getbits_as_list(Len,Bytes2), + {list_to_tuple(Blist),Bytes3}. + +fixextensions({ext,ExtPos,ExtNum},Val) -> + case fixextensions(ExtPos,ExtNum+ExtPos,Val,0) of + 0 -> []; + ExtBits -> + [encode_small_length(ExtNum),{bits,ExtNum,ExtBits}] + end. + +fixextensions(Pos,MaxPos,_,Acc) when Pos >= MaxPos -> + Acc; +fixextensions(Pos,ExtPos,Val,Acc) -> + Bit = case catch(element(Pos+1,Val)) of + asn1_NOVALUE -> + 0; + asn1_NOEXTVALUE -> + 0; + {'EXIT',_} -> + 0; + _ -> + 1 + end, + fixextensions(Pos+1,ExtPos,Val,(Acc bsl 1)+Bit). + +skipextensions(Bytes,Nr,ExtensionBitPattern) -> + case (catch element(Nr,ExtensionBitPattern)) of + 1 -> + {_,Bytes2} = decode_open_type(Bytes,[]), + skipextensions(Bytes2, Nr+1, ExtensionBitPattern); + 0 -> + skipextensions(Bytes, Nr+1, ExtensionBitPattern); + {'EXIT',_} -> % badarg, no more extensions + Bytes + end. + + +getchoice(Bytes,1,0) -> % only 1 alternative is not encoded + {0,Bytes}; +getchoice(Bytes,_,1) -> + decode_small_number(Bytes); +getchoice(Bytes,NumChoices,0) -> + decode_constrained_number(Bytes,{0,NumChoices-1}). + +%% old version kept for backward compatibility with generates from R7B +getoptionals(Bytes,NumOpt) -> + {Blist,Bytes1} = getbits_as_list(NumOpt,Bytes), + {list_to_tuple(Blist),Bytes1}. + +%% new version used in generates from r8b_patch/3 and later +getoptionals2(Bytes,NumOpt) -> + getbits(Bytes,NumOpt). + + +%% getbits_as_binary(Num,Bytes) -> {{Unused,BinBits},RestBytes}, +%% Num = integer(), +%% Bytes = list() | tuple(), +%% Unused = integer(), +%% BinBits = binary(), +%% RestBytes = tuple() +getbits_as_binary(Num,Bytes) when binary(Bytes) -> + getbits_as_binary(Num,{0,Bytes}); +getbits_as_binary(0,Buffer) -> + {{0,<<>>},Buffer}; +getbits_as_binary(Num,{0,Bin}) when Num > 16 -> + Used = Num rem 8, + Pad = (8 - Used) rem 8, +% Nbytes = Num div 8, + <<Bits:Num,_:Pad,RestBin/binary>> = Bin, + {{Pad,<<Bits:Num,0:Pad>>},RestBin}; +getbits_as_binary(Num,Buffer={_Used,_Bin}) -> % Unaligned buffer + %% Num =< 16, + {Bits2,Buffer2} = getbits(Buffer,Num), + Pad = (8 - (Num rem 8)) rem 8, + {{Pad,<<Bits2:Num,0:Pad>>},Buffer2}. + + +% integer_from_list(Int,[],BigInt) -> +% BigInt; +% integer_from_list(Int,[H|T],BigInt) when Int < 8 -> +% (BigInt bsl Int) bor (H bsr (8-Int)); +% integer_from_list(Int,[H|T],BigInt) -> +% integer_from_list(Int-8,T,(BigInt bsl 8) bor H). + +getbits_as_list(Num,Bytes) when binary(Bytes) -> + getbits_as_list(Num,{0,Bytes},[]); +getbits_as_list(Num,Bytes) -> + getbits_as_list(Num,Bytes,[]). + +%% If buffer is empty and nothing more will be picked. +getbits_as_list(0, B, Acc) -> + {lists:reverse(Acc),B}; +%% If first byte in buffer is full and at least one byte will be picked, +%% then pick one byte. +getbits_as_list(N,{0,Bin},Acc) when N >= 8 -> + <<B7:1,B6:1,B5:1,B4:1,B3:1,B2:1,B1:1,B0:1,Rest/binary>> = Bin, + getbits_as_list(N-8,{0,Rest},[B0,B1,B2,B3,B4,B5,B6,B7|Acc]); +getbits_as_list(N,{Used,Bin},Acc) when N >= 4, Used =< 4 -> + NewUsed = Used + 4, + Rem = 8 - NewUsed, + <<_:Used,B3:1,B2:1,B1:1,B0:1,_:Rem, Rest/binary>> = Bin, + NewRest = case Rem of 0 -> Rest; _ -> Bin end, + getbits_as_list(N-4,{NewUsed rem 8,NewRest},[B0,B1,B2,B3|Acc]); +getbits_as_list(N,{Used,Bin},Acc) when N >= 2, Used =< 6 -> + NewUsed = Used + 2, + Rem = 8 - NewUsed, + <<_:Used,B1:1,B0:1,_:Rem, Rest/binary>> = Bin, + NewRest = case Rem of 0 -> Rest; _ -> Bin end, + getbits_as_list(N-2,{NewUsed rem 8,NewRest},[B0,B1|Acc]); +getbits_as_list(N,{Used,Bin},Acc) when Used =< 7 -> + NewUsed = Used + 1, + Rem = 8 - NewUsed, + <<_:Used,B0:1,_:Rem, Rest/binary>> = Bin, + NewRest = case Rem of 0 -> Rest; _ -> Bin end, + getbits_as_list(N-1,{NewUsed rem 8,NewRest},[B0|Acc]). + + +getbit({7,<<_:7,B:1,Rest/binary>>}) -> + {B,{0,Rest}}; +getbit({0,Buffer = <<B:1,_:7,_/binary>>}) -> + {B,{1,Buffer}}; +getbit({Used,Buffer}) -> + Unused = (8 - Used) - 1, + <<_:Used,B:1,_:Unused,_/binary>> = Buffer, + {B,{Used+1,Buffer}}; +getbit(Buffer) when binary(Buffer) -> + getbit({0,Buffer}). + + +getbits({0,Buffer},Num) when (Num rem 8) == 0 -> + <<Bits:Num,Rest/binary>> = Buffer, + {Bits,{0,Rest}}; +getbits({Used,Bin},Num) -> + NumPlusUsed = Num + Used, + NewUsed = NumPlusUsed rem 8, + Unused = (8-NewUsed) rem 8, + case Unused of + 0 -> + <<_:Used,Bits:Num,Rest/binary>> = Bin, + {Bits,{0,Rest}}; + _ -> + Bytes = NumPlusUsed div 8, + <<_:Used,Bits:Num,_UBits:Unused,_/binary>> = Bin, + <<_:Bytes/binary,Rest/binary>> = Bin, + {Bits,{NewUsed,Rest}} + end; +getbits(Bin,Num) when binary(Bin) -> + getbits({0,Bin},Num). + + + +% getoctet(Bytes) when list(Bytes) -> +% getoctet({0,Bytes}); +% getoctet(Bytes) -> +% %% io:format("getoctet:Buffer = ~p~n",[Bytes]), +% getoctet1(Bytes). + +% getoctet1({0,[H|T]}) -> +% {H,{0,T}}; +% getoctet1({Pos,[_,H|T]}) -> +% {H,{0,T}}. + +align({0,L}) -> + {0,L}; +align({_Pos,<<_H,T/binary>>}) -> + {0,T}; +align(Bytes) -> + {0,Bytes}. + +%% First align buffer, then pick the first Num octets. +%% Returns octets as an integer with bit significance as in buffer. +getoctets({0,Buffer},Num) -> + <<Val:Num/integer-unit:8,RestBin/binary>> = Buffer, + {Val,{0,RestBin}}; +getoctets({U,<<_Padding,Rest/binary>>},Num) when U /= 0 -> + getoctets({0,Rest},Num); +getoctets(Buffer,Num) when binary(Buffer) -> + getoctets({0,Buffer},Num). +% getoctets(Buffer,Num) -> +% %% io:format("getoctets:Buffer = ~p~nNum = ~p~n",[Buffer,Num]), +% getoctets(Buffer,Num,0). + +% getoctets(Buffer,0,Acc) -> +% {Acc,Buffer}; +% getoctets(Buffer,Num,Acc) -> +% {Oct,NewBuffer} = getoctet(Buffer), +% getoctets(NewBuffer,Num-1,(Acc bsl 8)+Oct). + +% getoctets_as_list(Buffer,Num) -> +% getoctets_as_list(Buffer,Num,[]). + +% getoctets_as_list(Buffer,0,Acc) -> +% {lists:reverse(Acc),Buffer}; +% getoctets_as_list(Buffer,Num,Acc) -> +% {Oct,NewBuffer} = getoctet(Buffer), +% getoctets_as_list(NewBuffer,Num-1,[Oct|Acc]). + +%% First align buffer, then pick the first Num octets. +%% Returns octets as a binary +getoctets_as_bin({0,Bin},Num)-> + <<Octets:Num/binary,RestBin/binary>> = Bin, + {Octets,{0,RestBin}}; +getoctets_as_bin({_U,Bin},Num) -> + <<_Padding,Octets:Num/binary,RestBin/binary>> = Bin, + {Octets,{0,RestBin}}; +getoctets_as_bin(Bin,Num) when binary(Bin) -> + getoctets_as_bin({0,Bin},Num). + +%% same as above but returns octets as a List +getoctets_as_list(Buffer,Num) -> + {Bin,Buffer2} = getoctets_as_bin(Buffer,Num), + {binary_to_list(Bin),Buffer2}. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% set_choice(Alt,Choices,Altnum) -> ListofBitSettings +%% Alt = atom() +%% Altnum = integer() | {integer(),integer()}% number of alternatives +%% Choices = [atom()] | {[atom()],[atom()]} +%% When Choices is a tuple the first list is the Rootset and the +%% second is the Extensions and then Altnum must also be a tuple with the +%% lengths of the 2 lists +%% +set_choice(Alt,{L1,L2},{Len1,_Len2}) -> + case set_choice_tag(Alt,L1) of + N when integer(N), Len1 > 1 -> + [{bits,1,0}, % the value is in the root set + encode_integer([{'ValueRange',{0,Len1-1}}],N)]; + N when integer(N) -> + [{bits,1,0}]; % no encoding if only 0 or 1 alternative + false -> + [{bits,1,1}, % extension value + case set_choice_tag(Alt,L2) of + N2 when integer(N2) -> + encode_small_number(N2); + false -> + unknown_choice_alt + end] + end; +set_choice(Alt,L,Len) -> + case set_choice_tag(Alt,L) of + N when integer(N), Len > 1 -> + encode_integer([{'ValueRange',{0,Len-1}}],N); + N when integer(N) -> + []; % no encoding if only 0 or 1 alternative + false -> + [unknown_choice_alt] + end. + +set_choice_tag(Alt,Choices) -> + set_choice_tag(Alt,Choices,0). + +set_choice_tag(Alt,[Alt|_Rest],Tag) -> + Tag; +set_choice_tag(Alt,[_H|Rest],Tag) -> + set_choice_tag(Alt,Rest,Tag+1); +set_choice_tag(_Alt,[],_Tag) -> + false. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% decode_fragmented_XXX; decode of values encoded fragmented according +%% to ITU-T X.691 clause 10.9.3.8. The unit (XXX) is either bits, octets, +%% characters or number of components (in a choice,sequence or similar). +%% Buffer is a buffer {Used, Bin}. +%% C is the constrained length. +%% If the buffer is not aligned, this function does that. +decode_fragmented_bits({0,Buffer},C) -> + decode_fragmented_bits(Buffer,C,[]); +decode_fragmented_bits({_N,<<_,Bs/binary>>},C) -> + decode_fragmented_bits(Bs,C,[]). + +decode_fragmented_bits(<<3:2,Len:6,Bin/binary>>,C,Acc) -> + {Value,Bin2} = split_binary(Bin, Len * ?'16K'), + decode_fragmented_bits(Bin2,C,[Value,Acc]); +decode_fragmented_bits(<<0:1,0:7,Bin/binary>>,C,Acc) -> + BinBits = list_to_binary(lists:reverse(Acc)), + case C of + Int when integer(Int),C == size(BinBits) -> + {BinBits,{0,Bin}}; + Int when integer(Int) -> + exit({error,{asn1,{illegal_value,C,BinBits}}}); + _ -> + {BinBits,{0,Bin}} + end; +decode_fragmented_bits(<<0:1,Len:7,Bin/binary>>,C,Acc) -> + Result = {BinBits,{Used,_Rest}} = + case (Len rem 8) of + 0 -> + <<Value:Len/binary-unit:1,Bin2/binary>> = Bin, + {list_to_binary(lists:reverse([Value|Acc])),{0,Bin2}}; + Rem -> + Bytes = Len div 8, + U = 8 - Rem, + <<Value:Bytes/binary-unit:8,Bits1:Rem,Bits2:U,Bin2/binary>> = Bin, + {list_to_binary(lists:reverse([Bits1 bsl U,Value|Acc])), + {Rem,<<Bits2,Bin2/binary>>}} + end, + case C of + Int when integer(Int),C == (size(BinBits) - ((8 - Used) rem 8)) -> + Result; + Int when integer(Int) -> + exit({error,{asn1,{illegal_value,C,BinBits}}}); + _ -> + Result + end. + + +decode_fragmented_octets({0,Bin},C) -> + decode_fragmented_octets(Bin,C,[]); +decode_fragmented_octets({_N,<<_,Bs/binary>>},C) -> + decode_fragmented_octets(Bs,C,[]). + +decode_fragmented_octets(<<3:2,Len:6,Bin/binary>>,C,Acc) -> + {Value,Bin2} = split_binary(Bin,Len * ?'16K'), + decode_fragmented_octets(Bin2,C,[Value,Acc]); +decode_fragmented_octets(<<0:1,0:7,Bin/binary>>,C,Acc) -> + Octets = list_to_binary(lists:reverse(Acc)), + case C of + Int when integer(Int), C == size(Octets) -> + {Octets,{0,Bin}}; + Int when integer(Int) -> + exit({error,{asn1,{illegal_value,C,Octets}}}); + _ -> + {Octets,{0,Bin}} + end; +decode_fragmented_octets(<<0:1,Len:7,Bin/binary>>,C,Acc) -> + <<Value:Len/binary-unit:8,Bin2/binary>> = Bin, + BinOctets = list_to_binary(lists:reverse([Value|Acc])), + case C of + Int when integer(Int),size(BinOctets) == Int -> + {BinOctets,Bin2}; + Int when integer(Int) -> + exit({error,{asn1,{illegal_value,C,BinOctets}}}); + _ -> + {BinOctets,Bin2} + end. + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% encode_open_type(Constraint, Value) -> CompleteList +%% Value = list of bytes of an already encoded value (the list must be flat) +%% | binary +%% Contraint = not used in this version +%% +encode_open_type(_C, Val) when list(Val) -> + Bin = list_to_binary(Val), + [encode_length(undefined,size(Bin)),{octets,Bin}]; % octets implies align +encode_open_type(_C, Val) when binary(Val) -> + [encode_length(undefined,size(Val)),{octets,Val}]. % octets implies align +%% the binary_to_list is not optimal but compatible with the current solution + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% decode_open_type(Buffer,Constraint) -> Value +%% Constraint is not used in this version +%% Buffer = [byte] with PER encoded data +%% Value = [byte] with decoded data (which must be decoded again as some type) +%% +decode_open_type(Bytes, _C) -> + {Len,Bytes2} = decode_length(Bytes,undefined), + getoctets_as_bin(Bytes2,Len). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% encode_integer(Constraint,Value,NamedNumberList) -> CompleteList +%% encode_integer(Constraint,Value) -> CompleteList +%% encode_integer(Constraint,{Name,Value}) -> CompleteList +%% +%% +encode_integer(C,V,NamedNumberList) when atom(V) -> + case lists:keysearch(V,1,NamedNumberList) of + {value,{_,NewV}} -> + encode_integer(C,NewV); + _ -> + exit({error,{asn1,{namednumber,V}}}) + end; +encode_integer(C,V,_NamedNumberList) when integer(V) -> + encode_integer(C,V); +encode_integer(C,{Name,V},NamedNumberList) when atom(Name) -> + encode_integer(C,V,NamedNumberList). + +encode_integer(C,{Name,Val}) when atom(Name) -> + encode_integer(C,Val); + +encode_integer([{Rc,_Ec}],Val) when tuple(Rc) -> % XXX when is this invoked? First argument most often a list,...Ok this is the extension case...but it doesn't work. + case (catch encode_integer([Rc],Val)) of + {'EXIT',{error,{asn1,_}}} -> + [{bits,1,1},encode_unconstrained_number(Val)]; + Encoded -> + [{bits,1,0},Encoded] + end; +encode_integer(C,Val ) when list(C) -> + case get_constraint(C,'SingleValue') of + no -> + encode_integer1(C,Val); + V when integer(V),V == Val -> + []; % a type restricted to a single value encodes to nothing + V when list(V) -> + case lists:member(Val,V) of + true -> + encode_integer1(C,Val); + _ -> + exit({error,{asn1,{illegal_value,Val}}}) + end; + _ -> + exit({error,{asn1,{illegal_value,Val}}}) + end. + +encode_integer1(C, Val) -> + case VR = get_constraint(C,'ValueRange') of + no -> + encode_unconstrained_number(Val); + {Lb,'MAX'} -> + encode_semi_constrained_number(Lb,Val); + %% positive with range + {Lb,Ub} when Val >= Lb, + Ub >= Val -> + encode_constrained_number(VR,Val); + _ -> + exit({error,{asn1,{illegal_value,VR,Val}}}) + end. + +decode_integer(Buffer,Range,NamedNumberList) -> + {Val,Buffer2} = decode_integer(Buffer,Range), + case lists:keysearch(Val,2,NamedNumberList) of + {value,{NewVal,_}} -> {NewVal,Buffer2}; + _ -> {Val,Buffer2} + end. + +decode_integer(Buffer,[{Rc,_Ec}]) when tuple(Rc) -> + {Ext,Buffer2} = getext(Buffer), + case Ext of + 0 -> decode_integer(Buffer2,[Rc]); + 1 -> decode_unconstrained_number(Buffer2) + end; +decode_integer(Buffer,undefined) -> + decode_unconstrained_number(Buffer); +decode_integer(Buffer,C) -> + case get_constraint(C,'SingleValue') of + V when integer(V) -> + {V,Buffer}; + V when list(V) -> + {Val,Buffer2} = decode_integer1(Buffer,C), + case lists:member(Val,V) of + true -> + {Val,Buffer2}; + _ -> + exit({error,{asn1,{illegal_value,Val}}}) + end; + _ -> + decode_integer1(Buffer,C) + end. + +decode_integer1(Buffer,C) -> + case VR = get_constraint(C,'ValueRange') of + no -> + decode_unconstrained_number(Buffer); + {Lb, 'MAX'} -> + decode_semi_constrained_number(Buffer,Lb); + {_,_} -> + decode_constrained_number(Buffer,VR) + end. + + % X.691:10.6 Encoding of a normally small non-negative whole number + % Use this for encoding of CHOICE index if there is an extension marker in + % the CHOICE +encode_small_number({Name,Val}) when atom(Name) -> + encode_small_number(Val); +encode_small_number(Val) when Val =< 63 -> +% [{bits,1,0},{bits,6,Val}]; + [{bits,7,Val}]; % same as above but more efficient +encode_small_number(Val) -> + [{bits,1,1},encode_semi_constrained_number(0,Val)]. + +decode_small_number(Bytes) -> + {Bit,Bytes2} = getbit(Bytes), + case Bit of + 0 -> + getbits(Bytes2,6); + 1 -> + decode_semi_constrained_number(Bytes2,0) + end. + +%% X.691:10.7 Encoding of a semi-constrained whole number +%% might be an optimization encode_semi_constrained_number(0,Val) -> +encode_semi_constrained_number(C,{Name,Val}) when atom(Name) -> + encode_semi_constrained_number(C,Val); +encode_semi_constrained_number({Lb,'MAX'},Val) -> + encode_semi_constrained_number(Lb,Val); +encode_semi_constrained_number(Lb,Val) -> + Val2 = Val - Lb, + Oct = eint_positive(Val2), + Len = length(Oct), + if + Len < 128 -> + {octets,[Len|Oct]}; % equiv with encode_length(undefined,Len) but faster + true -> + [encode_length(undefined,Len),{octets,Oct}] + end. + +decode_semi_constrained_number(Bytes,{Lb,_}) -> + decode_semi_constrained_number(Bytes,Lb); +decode_semi_constrained_number(Bytes,Lb) -> + {Len,Bytes2} = decode_length(Bytes,undefined), + {V,Bytes3} = getoctets(Bytes2,Len), + {V+Lb,Bytes3}. + +encode_constrained_number(Range,{Name,Val}) when atom(Name) -> + encode_constrained_number(Range,Val); +encode_constrained_number({Lb,Ub},Val) when Val >= Lb, Ub >= Val -> + Range = Ub - Lb + 1, + Val2 = Val - Lb, + if + Range == 2 -> + {bits,1,Val2}; + Range =< 4 -> + {bits,2,Val2}; + Range =< 8 -> + {bits,3,Val2}; + Range =< 16 -> + {bits,4,Val2}; + Range =< 32 -> + {bits,5,Val2}; + Range =< 64 -> + {bits,6,Val2}; + Range =< 128 -> + {bits,7,Val2}; + Range =< 255 -> + {bits,8,Val2}; + Range =< 256 -> + {octets,[Val2]}; + Range =< 65536 -> + {octets,<<Val2:16>>}; + Range =< 16#1000000 -> + Octs = eint_positive(Val2), + [{bits,2,length(Octs)-1},{octets,Octs}]; + Range =< 16#100000000 -> + Octs = eint_positive(Val2), + [{bits,2,length(Octs)-1},{octets,Octs}]; + Range =< 16#10000000000 -> + Octs = eint_positive(Val2), + [{bits,3,length(Octs)-1},{octets,Octs}]; + true -> + exit({not_supported,{integer_range,Range}}) + end; +encode_constrained_number(Range,Val) -> + exit({error,{asn1,{integer_range,Range,value,Val}}}). + + +decode_constrained_number(Buffer,{Lb,Ub}) -> + Range = Ub - Lb + 1, + % Val2 = Val - Lb, + {Val,Remain} = + if + Range == 2 -> + getbits(Buffer,1); + Range =< 4 -> + getbits(Buffer,2); + Range =< 8 -> + getbits(Buffer,3); + Range =< 16 -> + getbits(Buffer,4); + Range =< 32 -> + getbits(Buffer,5); + Range =< 64 -> + getbits(Buffer,6); + Range =< 128 -> + getbits(Buffer,7); + Range =< 255 -> + getbits(Buffer,8); + Range =< 256 -> + getoctets(Buffer,1); + Range =< 65536 -> + getoctets(Buffer,2); + Range =< 16#1000000 -> + {Len,Bytes2} = decode_length(Buffer,{1,3}), + {Octs,Bytes3} = getoctets_as_list(Bytes2,Len), + {dec_pos_integer(Octs),Bytes3}; + Range =< 16#100000000 -> + {Len,Bytes2} = decode_length(Buffer,{1,4}), + {Octs,Bytes3} = getoctets_as_list(Bytes2,Len), + {dec_pos_integer(Octs),Bytes3}; + Range =< 16#10000000000 -> + {Len,Bytes2} = decode_length(Buffer,{1,5}), + {Octs,Bytes3} = getoctets_as_list(Bytes2,Len), + {dec_pos_integer(Octs),Bytes3}; + true -> + exit({not_supported,{integer_range,Range}}) + end, + {Val+Lb,Remain}. + +%% X.691:10.8 Encoding of an unconstrained whole number + +encode_unconstrained_number(Val) when Val >= 0 -> + Oct = eint(Val,[]), + Len = length(Oct), + if + Len < 128 -> + {octets,[Len|Oct]}; % equiv with encode_length(undefined,Len) but faster + true -> + [encode_length(undefined,Len),{octets,Oct}] + end; +encode_unconstrained_number(Val) -> % negative + Oct = enint(Val,[]), + Len = length(Oct), + if + Len < 128 -> + {octets,[Len|Oct]}; % equiv with encode_length(undefined,Len) but faster + true -> + [encode_length(undefined,Len),{octets,Oct}] + end. + + +%% used for positive Values which don't need a sign bit +%% returns a binary +eint_positive(Val) -> + case eint(Val,[]) of + [0,B1|T] -> + [B1|T]; + T -> + T + end. + + +eint(0, [B|Acc]) when B < 128 -> + [B|Acc]; +eint(N, Acc) -> + eint(N bsr 8, [N band 16#ff| Acc]). + +enint(-1, [B1|T]) when B1 > 127 -> + [B1|T]; +enint(N, Acc) -> + enint(N bsr 8, [N band 16#ff|Acc]). + +decode_unconstrained_number(Bytes) -> + {Len,Bytes2} = decode_length(Bytes,undefined), + {Ints,Bytes3} = getoctets_as_list(Bytes2,Len), + {dec_integer(Ints),Bytes3}. + +dec_pos_integer(Ints) -> + decpint(Ints, 8 * (length(Ints) - 1)). +dec_integer(Ints) when hd(Ints) band 255 =< 127 -> %% Positive number + decpint(Ints, 8 * (length(Ints) - 1)); +dec_integer(Ints) -> %% Negative + decnint(Ints, 8 * (length(Ints) - 1)). + +decpint([Byte|Tail], Shift) -> + (Byte bsl Shift) bor decpint(Tail, Shift-8); +decpint([], _) -> 0. + +decnint([Byte|Tail], Shift) -> + (-128 + (Byte band 127) bsl Shift) bor decpint(Tail, Shift-8). + +% minimum_octets(Val) -> +% minimum_octets(Val,[]). + +% minimum_octets(Val,Acc) when Val > 0 -> +% minimum_octets((Val bsr 8),[Val band 16#FF|Acc]); +% minimum_octets(0,Acc) -> +% Acc. + + +%% X.691:10.9 Encoding of a length determinant +%%encode_small_length(undefined,Len) -> % null means no UpperBound +%% encode_small_number(Len). + +%% X.691:10.9.3.5 +%% X.691:10.9.3.7 +encode_length(undefined,Len) -> % un-constrained + if + Len < 128 -> + {octets,[Len]}; + Len < 16384 -> + {octets,<<2:2,Len:14>>}; + true -> % should be able to endode length >= 16384 + exit({error,{asn1,{encode_length,{nyi,above_16k}}}}) + end; + +encode_length({0,'MAX'},Len) -> + encode_length(undefined,Len); +encode_length(Vr={Lb,Ub},Len) when Ub =< 65535 ,Lb >= 0 -> % constrained + encode_constrained_number(Vr,Len); +encode_length({Lb,_Ub},Len) when integer(Lb), Lb >= 0 -> % Ub > 65535 + encode_length(undefined,Len); +encode_length({Vr={Lb,Ub},[]},Len) when Ub =< 65535 ,Lb >= 0 -> + %% constrained extensible + [{bits,1,0},encode_constrained_number(Vr,Len)]; +encode_length(SingleValue,_Len) when integer(SingleValue) -> + []. + +%% X.691 10.9.3.4 (only used for length of bitmap that prefixes extension +%% additions in a sequence or set +encode_small_length(Len) when Len =< 64 -> +%% [{bits,1,0},{bits,6,Len-1}]; + {bits,7,Len-1}; % the same as above but more efficient +encode_small_length(Len) -> + [{bits,1,1},encode_length(undefined,Len)]. + +% decode_small_length({Used,<<_:Used,0:1,Num:6,_:((8-Used+1) rem 8),Rest/binary>>}) -> +% case Buffer of +% <<_:Used,0:1,Num:6,_:((8-Used+1) rem 8),Rest/binary>> -> +% {Num, +% case getbit(Buffer) of +% {0,Remain} -> +% {Bits,Remain2} = getbits(Remain,6), +% {Bits+1,Remain2}; +% {1,Remain} -> +% decode_length(Remain,undefined) +% end. + +decode_small_length(Buffer) -> + case getbit(Buffer) of + {0,Remain} -> + {Bits,Remain2} = getbits(Remain,6), + {Bits+1,Remain2}; + {1,Remain} -> + decode_length(Remain,undefined) + end. + +decode_length(Buffer) -> + decode_length(Buffer,undefined). + +decode_length(Buffer,undefined) -> % un-constrained + {0,Buffer2} = align(Buffer), + case Buffer2 of + <<0:1,Oct:7,Rest/binary>> -> + {Oct,{0,Rest}}; + <<2:2,Val:14,Rest/binary>> -> + {Val,{0,Rest}}; + <<3:2,_:14,_Rest/binary>> -> + %% this case should be fixed + exit({error,{asn1,{decode_length,{nyi,above_16k}}}}) + end; +%% {Bits,_} = getbits(Buffer2,2), +% case Bits of +% 2 -> +% {Val,Bytes3} = getoctets(Buffer2,2), +% {(Val band 16#3FFF),Bytes3}; +% 3 -> +% exit({error,{asn1,{decode_length,{nyi,above_16k}}}}); +% _ -> +% {Val,Bytes3} = getoctet(Buffer2), +% {Val band 16#7F,Bytes3} +% end; + +decode_length(Buffer,{Lb,Ub}) when Ub =< 65535 ,Lb >= 0 -> % constrained + decode_constrained_number(Buffer,{Lb,Ub}); +decode_length(_,{Lb,_}) when integer(Lb), Lb >= 0 -> % Ub > 65535 + exit({error,{asn1,{decode_length,{nyi,above_64K}}}}); +decode_length(Buffer,{{Lb,Ub},[]}) -> + case getbit(Buffer) of + {0,Buffer2} -> + decode_length(Buffer2, {Lb,Ub}) + end; + + +%When does this case occur with {_,_Lb,Ub} ?? +% X.691:10.9.3.5 +decode_length({Used,Bin},{_,_Lb,_Ub}) -> %when Len =< 127 -> % Unconstrained or large Ub NOTE! this case does not cover case when Ub > 65535 + Unused = (8-Used) rem 8, + case Bin of + <<_:Used,0:1,Val:7,R:Unused,Rest/binary>> -> + {Val,{Used,<<R,Rest/binary>>}}; + <<_:Used,_:Unused,2:2,Val:14,Rest/binary>> -> + {Val, {0,Rest}}; + <<_:Used,_:Unused,3:2,_:14,_Rest/binary>> -> + exit({error,{asn1,{decode_length,{nyi,length_above_64K}}}}) + end; +% decode_length(Buffer,{_,_Lb,Ub}) -> %when Len =< 127 -> % Unconstrained or large Ub +% case getbit(Buffer) of +% {0,Remain} -> +% getbits(Remain,7); +% {1,Remain} -> +% {Val,Remain2} = getoctets(Buffer,2), +% {Val band 2#0111111111111111, Remain2} +% end; +decode_length(Buffer,SingleValue) when integer(SingleValue) -> + {SingleValue,Buffer}. + + + % X.691:11 +encode_boolean(true) -> + {bits,1,1}; +encode_boolean(false) -> + {bits,1,0}; +encode_boolean({Name,Val}) when atom(Name) -> + encode_boolean(Val); +encode_boolean(Val) -> + exit({error,{asn1,{encode_boolean,Val}}}). + +decode_boolean(Buffer) -> %when record(Buffer,buffer) + case getbit(Buffer) of + {1,Remain} -> {true,Remain}; + {0,Remain} -> {false,Remain} + end. + + +%% ENUMERATED with extension marker +decode_enumerated(Buffer,C,{Ntup1,Ntup2}) when tuple(Ntup1), tuple(Ntup2) -> + {Ext,Buffer2} = getext(Buffer), + case Ext of + 0 -> % not an extension value + {Val,Buffer3} = decode_integer(Buffer2,C), + case catch (element(Val+1,Ntup1)) of + NewVal when atom(NewVal) -> {NewVal,Buffer3}; + _Error -> exit({error,{asn1,{decode_enumerated,{Val,[Ntup1,Ntup2]}}}}) + end; + 1 -> % this an extension value + {Val,Buffer3} = decode_small_number(Buffer2), + case catch (element(Val+1,Ntup2)) of + NewVal when atom(NewVal) -> {NewVal,Buffer3}; + _ -> {{asn1_enum,Val},Buffer3} + end + end; + +decode_enumerated(Buffer,C,NamedNumberTup) when tuple(NamedNumberTup) -> + {Val,Buffer2} = decode_integer(Buffer,C), + case catch (element(Val+1,NamedNumberTup)) of + NewVal when atom(NewVal) -> {NewVal,Buffer2}; + _Error -> exit({error,{asn1,{decode_enumerated,{Val,NamedNumberTup}}}}) + end. + +%%=============================================================================== +%%=============================================================================== +%%=============================================================================== +%% Bitstring value, ITU_T X.690 Chapter 8.5 +%%=============================================================================== +%%=============================================================================== +%%=============================================================================== + +%%=============================================================================== +%% encode bitstring value +%%=============================================================================== + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% bitstring NamedBitList +%% Val can be of: +%% - [identifiers] where only named identifers are set to one, +%% the Constraint must then have some information of the +%% bitlength. +%% - [list of ones and zeroes] all bits +%% - integer value representing the bitlist +%% C is constraint Len, only valid when identifiers + + +%% when the value is a list of {Unused,BinBits}, where +%% Unused = integer(), +%% BinBits = binary(). + +encode_bit_string(C,Bin={Unused,BinBits},NamedBitList) when integer(Unused), + binary(BinBits) -> + encode_bin_bit_string(C,Bin,NamedBitList); + +%% when the value is a list of named bits +encode_bit_string(C, LoNB=[FirstVal | _RestVal], NamedBitList) when atom(FirstVal) -> + ToSetPos = get_all_bitposes(LoNB, NamedBitList, []), + BitList = make_and_set_list(ToSetPos,0), + encode_bit_string(C,BitList,NamedBitList); + +encode_bit_string(C, BL=[{bit,_No} | _RestVal], NamedBitList) -> + ToSetPos = get_all_bitposes(BL, NamedBitList, []), + BitList = make_and_set_list(ToSetPos,0), + encode_bit_string(C,BitList,NamedBitList); + +%% when the value is a list of ones and zeroes + +% encode_bit_string(C, BitListValue, NamedBitList) when list(BitListValue) -> +% Bl1 = +% case NamedBitList of +% [] -> % dont remove trailing zeroes +% BitListValue; +% _ -> % first remove any trailing zeroes +% lists:reverse(lists:dropwhile(fun(0)->true;(1)->false end, +% lists:reverse(BitListValue))) +% end, +% BitList = [{bit,X} || X <- Bl1], +% %% BListLen = length(BitList), +% case get_constraint(C,'SizeConstraint') of +% 0 -> % fixed length +% []; % nothing to encode +% V when integer(V),V=<16 -> % fixed length 16 bits or less +% pad_list(V,BitList); +% V when integer(V) -> % fixed length 16 bits or more +% [align,pad_list(V,BitList)]; % should be another case for V >= 65537 +% {Lb,Ub} when integer(Lb),integer(Ub) -> +% [encode_length({Lb,Ub},length(BitList)),align,BitList]; +% no -> +% [encode_length(undefined,length(BitList)),align,BitList]; +% Sc -> % extension marker +% [encode_length(Sc,length(BitList)),align,BitList] +% end; +encode_bit_string(C, BitListValue, NamedBitList) when list(BitListValue) -> + BitListToBinary = + %% fun that transforms a list of 1 and 0 to a tuple: + %% {UnusedBitsInLastByte, Binary} + fun([H|T],Acc,N,Fun) -> + Fun(T,(Acc bsl 1)+H,N+1,Fun); + ([],Acc,N,_) -> + Unused = (8 - (N rem 8)) rem 8, + {Unused,<<Acc:N,0:Unused>>} + end, + UnusedAndBin = + case NamedBitList of + [] -> % dont remove trailing zeroes + BitListToBinary(BitListValue,0,0,BitListToBinary); + _ -> + BitListToBinary(lists:reverse( + lists:dropwhile(fun(0)->true;(1)->false end, + lists:reverse(BitListValue))), + 0,0,BitListToBinary) + end, + encode_bin_bit_string(C,UnusedAndBin,NamedBitList); + +%% when the value is an integer +encode_bit_string(C, IntegerVal, NamedBitList) when integer(IntegerVal)-> + BitList = int_to_bitlist(IntegerVal), + encode_bit_string(C,BitList,NamedBitList); + +%% when the value is a tuple +encode_bit_string(C,{Name,Val}, NamedBitList) when atom(Name) -> + encode_bit_string(C,Val,NamedBitList). + + +%% encode_bin_bit_string/3, when value is a tuple of Unused and BinBits. +%% Unused = integer(),i.e. number unused bits in least sign. byte of +%% BinBits = binary(). + + +encode_bin_bit_string(C,UnusedAndBin={_Unused,_BinBits},NamedBitList) -> + Constr = get_constraint(C,'SizeConstraint'), + UnusedAndBin1 = {Unused1,Bin1} = + remove_trailing_bin(NamedBitList,UnusedAndBin,lower_bound(Constr)), + case Constr of + 0 -> + []; + V when integer(V),V=<16 -> + {Unused2,Bin2} = pad_list(V,UnusedAndBin1), + <<BitVal:V,_:Unused2>> = Bin2, + {bits,V,BitVal}; + V when integer(V) -> + [align, pad_list(V, UnusedAndBin1)]; + {Lb,Ub} when integer(Lb),integer(Ub) -> + [encode_length({Lb,Ub},size(Bin1)*8 - Unused1), + align,UnusedAndBin1]; + no -> + [encode_length(undefined,size(Bin1)*8 - Unused1), + align,UnusedAndBin1]; + Sc -> + [encode_length(Sc,size(Bin1)*8 - Unused1), + align,UnusedAndBin1] + end. + +remove_trailing_bin([], {Unused,Bin},_) -> + {Unused,Bin}; +remove_trailing_bin(NamedNumberList, {_Unused,Bin},C) -> + Size = size(Bin)-1, + <<Bfront:Size/binary, LastByte:8>> = Bin, + %% clear the Unused bits to be sure +% LastByte1 = LastByte band (((1 bsl Unused) -1) bxor 255), + Unused1 = trailingZeroesInNibble(LastByte band 15), + Unused2 = + case Unused1 of + 4 -> + 4 + trailingZeroesInNibble(LastByte bsr 4); + _ -> Unused1 + end, + case Unused2 of + 8 -> + remove_trailing_bin(NamedNumberList,{0,Bfront},C); + _ -> + case C of + Int when integer(Int),Int > ((size(Bin)*8)-Unused2) -> + %% this padding see OTP-4353 + pad_list(Int,{Unused2,Bin}); + _ -> {Unused2,Bin} + end + end. + + +trailingZeroesInNibble(0) -> + 4; +trailingZeroesInNibble(1) -> + 0; +trailingZeroesInNibble(2) -> + 1; +trailingZeroesInNibble(3) -> + 0; +trailingZeroesInNibble(4) -> + 2; +trailingZeroesInNibble(5) -> + 0; +trailingZeroesInNibble(6) -> + 1; +trailingZeroesInNibble(7) -> + 0; +trailingZeroesInNibble(8) -> + 3; +trailingZeroesInNibble(9) -> + 0; +trailingZeroesInNibble(10) -> + 1; +trailingZeroesInNibble(11) -> + 0; +trailingZeroesInNibble(12) -> %#1100 + 2; +trailingZeroesInNibble(13) -> + 0; +trailingZeroesInNibble(14) -> + 1; +trailingZeroesInNibble(15) -> + 0. + +lower_bound({{Lb,_},_}) when integer(Lb) -> + Lb; +lower_bound({Lb,_}) when integer(Lb) -> + Lb; +lower_bound(C) -> + C. + +%%%%%%%%%%%%%%% +%% The result is presented as a list of named bits (if possible) +%% else as a tuple {Unused,Bits}. Unused is the number of unused +%% bits, least significant bits in the last byte of Bits. Bits is +%% the BIT STRING represented as a binary. +%% +decode_compact_bit_string(Buffer, C, NamedNumberList) -> + case get_constraint(C,'SizeConstraint') of + 0 -> % fixed length + {{8,0},Buffer}; + V when integer(V),V=<16 -> %fixed length 16 bits or less + compact_bit_string(Buffer,V,NamedNumberList); + V when integer(V),V=<65536 -> %fixed length > 16 bits + Bytes2 = align(Buffer), + compact_bit_string(Bytes2,V,NamedNumberList); + V when integer(V) -> % V > 65536 => fragmented value + {Bin,Buffer2} = decode_fragmented_bits(Buffer,V), + case Buffer2 of + {0,_} -> {{0,Bin},Buffer2}; + {U,_} -> {{8-U,Bin},Buffer2} + end; + {Lb,Ub} when integer(Lb),integer(Ub) -> + %% This case may demand decoding of fragmented length/value + {Len,Bytes2} = decode_length(Buffer,{Lb,Ub}), + Bytes3 = align(Bytes2), + compact_bit_string(Bytes3,Len,NamedNumberList); + no -> + %% This case may demand decoding of fragmented length/value + {Len,Bytes2} = decode_length(Buffer,undefined), + Bytes3 = align(Bytes2), + compact_bit_string(Bytes3,Len,NamedNumberList); + Sc -> + {Len,Bytes2} = decode_length(Buffer,Sc), + Bytes3 = align(Bytes2), + compact_bit_string(Bytes3,Len,NamedNumberList) + end. + + +%%%%%%%%%%%%%%% +%% The result is presented as a list of named bits (if possible) +%% else as a list of 0 and 1. +%% +decode_bit_string(Buffer, C, NamedNumberList) -> + case get_constraint(C,'SizeConstraint') of + {Lb,Ub} when integer(Lb),integer(Ub) -> + {Len,Bytes2} = decode_length(Buffer,{Lb,Ub}), + Bytes3 = align(Bytes2), + bit_list_or_named(Bytes3,Len,NamedNumberList); + no -> + {Len,Bytes2} = decode_length(Buffer,undefined), + Bytes3 = align(Bytes2), + bit_list_or_named(Bytes3,Len,NamedNumberList); + 0 -> % fixed length + {[],Buffer}; % nothing to encode + V when integer(V),V=<16 -> % fixed length 16 bits or less + bit_list_or_named(Buffer,V,NamedNumberList); + V when integer(V),V=<65536 -> + Bytes2 = align(Buffer), + bit_list_or_named(Bytes2,V,NamedNumberList); + V when integer(V) -> + Bytes2 = align(Buffer), + {BinBits,_} = decode_fragmented_bits(Bytes2,V), + bit_list_or_named(BinBits,V,NamedNumberList); + Sc -> % extension marker + {Len,Bytes2} = decode_length(Buffer,Sc), + Bytes3 = align(Bytes2), + bit_list_or_named(Bytes3,Len,NamedNumberList) + end. + + +%% if no named bits are declared we will return a +%% {Unused,Bits}. Unused = integer(), +%% Bits = binary(). +compact_bit_string(Buffer,Len,[]) -> + getbits_as_binary(Len,Buffer); % {{Unused,BinBits},NewBuffer} +compact_bit_string(Buffer,Len,NamedNumberList) -> + bit_list_or_named(Buffer,Len,NamedNumberList). + + +%% if no named bits are declared we will return a +%% BitList = [0 | 1] + +bit_list_or_named(Buffer,Len,[]) -> + getbits_as_list(Len,Buffer); + +%% if there are named bits declared we will return a named +%% BitList where the names are atoms and unnamed bits represented +%% as {bit,Pos} +%% BitList = [atom() | {bit,Pos}] +%% Pos = integer() + +bit_list_or_named(Buffer,Len,NamedNumberList) -> + {BitList,Rest} = getbits_as_list(Len,Buffer), + {bit_list_or_named1(0,BitList,NamedNumberList,[]), Rest}. + +bit_list_or_named1(Pos,[0|Bt],Names,Acc) -> + bit_list_or_named1(Pos+1,Bt,Names,Acc); +bit_list_or_named1(Pos,[1|Bt],Names,Acc) -> + case lists:keysearch(Pos,2,Names) of + {value,{Name,_}} -> + bit_list_or_named1(Pos+1,Bt,Names,[Name|Acc]); + _ -> + bit_list_or_named1(Pos+1,Bt,Names,[{bit,Pos}|Acc]) + end; +bit_list_or_named1(_,[],_,Acc) -> + lists:reverse(Acc). + + + +%%%%%%%%%%%%%%% +%% + +int_to_bitlist(Int) when integer(Int), Int > 0 -> + [Int band 1 | int_to_bitlist(Int bsr 1)]; +int_to_bitlist(0) -> + []. + + +%%%%%%%%%%%%%%%%%% +%% get_all_bitposes([list of named bits to set], named_bit_db, []) -> +%% [sorted_list_of_bitpositions_to_set] + +get_all_bitposes([{bit,ValPos}|Rest], NamedBitList, Ack) -> + get_all_bitposes(Rest, NamedBitList, [ValPos | Ack ]); + +get_all_bitposes([Val | Rest], NamedBitList, Ack) -> + case lists:keysearch(Val, 1, NamedBitList) of + {value, {_ValName, ValPos}} -> + get_all_bitposes(Rest, NamedBitList, [ValPos | Ack]); + _ -> + exit({error,{asn1, {bitstring_namedbit, Val}}}) + end; +get_all_bitposes([], _NamedBitList, Ack) -> + lists:sort(Ack). + +%%%%%%%%%%%%%%%%%% +%% make_and_set_list([list of positions to set to 1])-> +%% returns list with all in SetPos set. +%% in positioning in list the first element is 0, the second 1 etc.., but +%% + +make_and_set_list([XPos|SetPos], XPos) -> + [1 | make_and_set_list(SetPos, XPos + 1)]; +make_and_set_list([Pos|SetPos], XPos) -> + [0 | make_and_set_list([Pos | SetPos], XPos + 1)]; +make_and_set_list([], _) -> + []. + +%%%%%%%%%%%%%%%%% +%% pad_list(N,BitList) -> PaddedList +%% returns a padded (with trailing {bit,0} elements) list of length N +%% if Bitlist contains more than N significant bits set an exit asn1_error +%% is generated + +pad_list(N,In={Unused,Bin}) -> + pad_list(N, size(Bin)*8 - Unused, In). + +pad_list(N,Size,In={_,_}) when N < Size -> + exit({error,{asn1,{range_error,{bit_string,In}}}}); +pad_list(N,Size,{Unused,Bin}) when N > Size, Unused > 0 -> + pad_list(N,Size+1,{Unused-1,Bin}); +pad_list(N,Size,{_Unused,Bin}) when N > Size -> + pad_list(N,Size+1,{7,<<Bin/binary,0>>}); +pad_list(N,N,In={_,_}) -> + In. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% X.691:16 +%% encode_octet_string(Constraint,ExtensionMarker,Val) +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +encode_octet_string(C,Val) -> + encode_octet_string(C,false,Val). + +encode_octet_string(C,Bool,{_Name,Val}) -> + encode_octet_string(C,Bool,Val); +encode_octet_string(_,true,_) -> + exit({error,{asn1,{'not_supported',extensionmarker}}}); +encode_octet_string(C,false,Val) -> + case get_constraint(C,'SizeConstraint') of + 0 -> + []; + 1 -> + [V] = Val, + {bits,8,V}; + 2 -> + [V1,V2] = Val, + [{bits,8,V1},{bits,8,V2}]; + Sv when Sv =<65535, Sv == length(Val) -> % fixed length + {octets,Val}; + {Lb,Ub} -> + [encode_length({Lb,Ub},length(Val)),{octets,Val}]; + Sv when list(Sv) -> + [encode_length({hd(Sv),lists:max(Sv)},length(Val)),{octets,Val}]; + no -> + [encode_length(undefined,length(Val)),{octets,Val}] + end. + +decode_octet_string(Bytes,Range) -> + decode_octet_string(Bytes,Range,false). + +decode_octet_string(Bytes,C,false) -> + case get_constraint(C,'SizeConstraint') of + 0 -> + {[],Bytes}; + 1 -> + {B1,Bytes2} = getbits(Bytes,8), + {[B1],Bytes2}; + 2 -> + {Bs,Bytes2}= getbits(Bytes,16), + {binary_to_list(<<Bs:16>>),Bytes2}; + {_,0} -> + {[],Bytes}; + Sv when integer(Sv), Sv =<65535 -> % fixed length + getoctets_as_list(Bytes,Sv); + Sv when integer(Sv) -> % fragmented encoding + Bytes2 = align(Bytes), + decode_fragmented_octets(Bytes2,Sv); + {Lb,Ub} -> + {Len,Bytes2} = decode_length(Bytes,{Lb,Ub}), + getoctets_as_list(Bytes2,Len); + Sv when list(Sv) -> + {Len,Bytes2} = decode_length(Bytes,{hd(Sv),lists:max(Sv)}), + getoctets_as_list(Bytes2,Len); + no -> + {Len,Bytes2} = decode_length(Bytes,undefined), + getoctets_as_list(Bytes2,Len) + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Restricted char string types +%% (NumericString, PrintableString,VisibleString,IA5String,BMPString,UniversalString) +%% X.691:26 and X.680:34-36 +%%encode_restricted_string(aligned,'BMPString',Constraints,Extension,Val) + + +encode_restricted_string(aligned,{Name,Val}) when atom(Name) -> + encode_restricted_string(aligned,Val); + +encode_restricted_string(aligned,Val) when list(Val)-> + [encode_length(undefined,length(Val)),{octets,Val}]. + +encode_known_multiplier_string(aligned,StringType,C,_Ext,{Name,Val}) when atom(Name) -> + encode_known_multiplier_string(aligned,StringType,C,false,Val); + +encode_known_multiplier_string(aligned,StringType,C,_Ext,Val) -> + Result = chars_encode(C,StringType,Val), + NumBits = get_NumBits(C,StringType), + case get_constraint(C,'SizeConstraint') of + Ub when integer(Ub), Ub*NumBits =< 16 -> + case {StringType,Result} of + {'BMPString',{octets,Ol}} -> + [{bits,8,Oct}||Oct <- Ol]; + _ -> + Result + end; + 0 -> + []; + Ub when integer(Ub),Ub =<65535 -> % fixed length + [align,Result]; + {Ub,Lb} -> + [encode_length({Ub,Lb},length(Val)),align,Result]; + Vl when list(Vl) -> + [encode_length({lists:min(Vl),lists:max(Vl)},length(Val)),align,Result]; + no -> + [encode_length(undefined,length(Val)),align,Result] + end. + +decode_restricted_string(Bytes,aligned) -> + {Len,Bytes2} = decode_length(Bytes,undefined), + getoctets_as_list(Bytes2,Len). + +decode_known_multiplier_string(Bytes,aligned,StringType,C,_Ext) -> + NumBits = get_NumBits(C,StringType), + case get_constraint(C,'SizeConstraint') of + Ub when integer(Ub), Ub*NumBits =< 16 -> + chars_decode(Bytes,NumBits,StringType,C,Ub); + Ub when integer(Ub),Ub =<65535 -> % fixed length + Bytes1 = align(Bytes), + chars_decode(Bytes1,NumBits,StringType,C,Ub); + 0 -> + {[],Bytes}; + Vl when list(Vl) -> + {Len,Bytes1} = decode_length(Bytes,{hd(Vl),lists:max(Vl)}), + Bytes2 = align(Bytes1), + chars_decode(Bytes2,NumBits,StringType,C,Len); + no -> + {Len,Bytes1} = decode_length(Bytes,undefined), + Bytes2 = align(Bytes1), + chars_decode(Bytes2,NumBits,StringType,C,Len); + {Lb,Ub}-> + {Len,Bytes1} = decode_length(Bytes,{Lb,Ub}), + Bytes2 = align(Bytes1), + chars_decode(Bytes2,NumBits,StringType,C,Len) + end. + + +encode_NumericString(C,Val) -> + encode_known_multiplier_string(aligned,'NumericString',C,false,Val). +decode_NumericString(Bytes,C) -> + decode_known_multiplier_string(Bytes,aligned,'NumericString',C,false). + +encode_PrintableString(C,Val) -> + encode_known_multiplier_string(aligned,'PrintableString',C,false,Val). +decode_PrintableString(Bytes,C) -> + decode_known_multiplier_string(Bytes,aligned,'PrintableString',C,false). + +encode_VisibleString(C,Val) -> % equivalent with ISO646String + encode_known_multiplier_string(aligned,'VisibleString',C,false,Val). +decode_VisibleString(Bytes,C) -> + decode_known_multiplier_string(Bytes,aligned,'VisibleString',C,false). + +encode_IA5String(C,Val) -> + encode_known_multiplier_string(aligned,'IA5String',C,false,Val). +decode_IA5String(Bytes,C) -> + decode_known_multiplier_string(Bytes,aligned,'IA5String',C,false). + +encode_BMPString(C,Val) -> + encode_known_multiplier_string(aligned,'BMPString',C,false,Val). +decode_BMPString(Bytes,C) -> + decode_known_multiplier_string(Bytes,aligned,'BMPString',C,false). + +encode_UniversalString(C,Val) -> + encode_known_multiplier_string(aligned,'UniversalString',C,false,Val). +decode_UniversalString(Bytes,C) -> + decode_known_multiplier_string(Bytes,aligned,'UniversalString',C,false). + +%% end of known-multiplier strings for which PER visible constraints are +%% applied + +encode_GeneralString(_C,Val) -> + encode_restricted_string(aligned,Val). +decode_GeneralString(Bytes,_C) -> + decode_restricted_string(Bytes,aligned). + +encode_GraphicString(_C,Val) -> + encode_restricted_string(aligned,Val). +decode_GraphicString(Bytes,_C) -> + decode_restricted_string(Bytes,aligned). + +encode_ObjectDescriptor(_C,Val) -> + encode_restricted_string(aligned,Val). +decode_ObjectDescriptor(Bytes) -> + decode_restricted_string(Bytes,aligned). + +encode_TeletexString(_C,Val) -> % equivalent with T61String + encode_restricted_string(aligned,Val). +decode_TeletexString(Bytes,_C) -> + decode_restricted_string(Bytes,aligned). + +encode_VideotexString(_C,Val) -> + encode_restricted_string(aligned,Val). +decode_VideotexString(Bytes,_C) -> + decode_restricted_string(Bytes,aligned). + + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% getBMPChars(Bytes,Len) ->{BMPcharList,RemainingBytes} +%% +getBMPChars(Bytes,1) -> + {O1,Bytes2} = getbits(Bytes,8), + {O2,Bytes3} = getbits(Bytes2,8), + if + O1 == 0 -> + {[O2],Bytes3}; + true -> + {[{0,0,O1,O2}],Bytes3} + end; +getBMPChars(Bytes,Len) -> + getBMPChars(Bytes,Len,[]). + +getBMPChars(Bytes,0,Acc) -> + {lists:reverse(Acc),Bytes}; +getBMPChars(Bytes,Len,Acc) -> + {Octs,Bytes1} = getoctets_as_list(Bytes,2), + case Octs of + [0,O2] -> + getBMPChars(Bytes1,Len-1,[O2|Acc]); + [O1,O2]-> + getBMPChars(Bytes1,Len-1,[{0,0,O1,O2}|Acc]) + end. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% chars_encode(C,StringType,Value) -> ValueList +%% +%% encodes chars according to the per rules taking the constraint PermittedAlphabet +%% into account. +%% This function does only encode the value part and NOT the length + +chars_encode(C,StringType,Value) -> + case {StringType,get_constraint(C,'PermittedAlphabet')} of + {'UniversalString',{_,_Sv}} -> + exit({error,{asn1,{'not implemented',"UniversalString with PermittedAlphabet constraint"}}}); + {'BMPString',{_,_Sv}} -> + exit({error,{asn1,{'not implemented',"BMPString with PermittedAlphabet constraint"}}}); + _ -> + {NumBits,CharOutTab} = {get_NumBits(C,StringType),get_CharOutTab(C,StringType)}, + chars_encode2(Value,NumBits,CharOutTab) + end. + +chars_encode2([H|T],NumBits,{Min,Max,notab}) when H =< Max, H >= Min -> + [{bits,NumBits,H-Min}|chars_encode2(T,NumBits,{Min,Max,notab})]; +chars_encode2([H|T],NumBits,{Min,Max,Tab}) when H =< Max, H >= Min -> + [{bits,NumBits,exit_if_false(H,element(H-Min+1,Tab))}|chars_encode2(T,NumBits,{Min,Max,Tab})]; +chars_encode2([{A,B,C,D}|T],NumBits,{Min,Max,notab}) -> + %% no value range check here (ought to be, but very expensive) +% [{bits,NumBits,(A*B*C*D)-Min}|chars_encode2(T,NumBits,{Min,Max,notab})]; + [{bits,NumBits,((((((A bsl 8)+B) bsl 8)+C) bsl 8)+D)-Min}|chars_encode2(T,NumBits,{Min,Max,notab})]; +chars_encode2([{A,B,C,D}|T],NumBits,{Min,Max,Tab}) -> + %% no value range check here (ought to be, but very expensive) +% [{bits,NumBits,element((A*B*C*D)-Min,Tab)}|chars_encode2(T,NumBits,{Min,Max,notab})]; + [{bits,NumBits,exit_if_false({A,B,C,D},element(((((((A bsl 8)+B) bsl 8)+C) bsl 8)+D)-Min,Tab))}|chars_encode2(T,NumBits,{Min,Max,notab})]; +chars_encode2([H|_T],_,{_,_,_}) -> + exit({error,{asn1,{illegal_char_value,H}}}); +chars_encode2([],_,_) -> + []. + +exit_if_false(V,false)-> + exit({error,{asn1,{"illegal value according to Permitted alphabet constraint",V}}}); +exit_if_false(_,V) ->V. + + +get_NumBits(C,StringType) -> + case get_constraint(C,'PermittedAlphabet') of + {'SingleValue',Sv} -> + charbits(length(Sv),aligned); + no -> + case StringType of + 'IA5String' -> + charbits(128,aligned); % 16#00..16#7F + 'VisibleString' -> + charbits(95,aligned); % 16#20..16#7E + 'PrintableString' -> + charbits(74,aligned); % [$\s,$',$(,$),$+,$,,$-,$.,$/,"0123456789",$:,$=,$?,$A..$Z,$a..$z + 'NumericString' -> + charbits(11,aligned); % $ ,"0123456789" + 'UniversalString' -> + 32; + 'BMPString' -> + 16 + end + end. + +%%Maybe used later +%%get_MaxChar(C,StringType) -> +%% case get_constraint(C,'PermittedAlphabet') of +%% {'SingleValue',Sv} -> +%% lists:nth(length(Sv),Sv); +%% no -> +%% case StringType of +%% 'IA5String' -> +%% 16#7F; % 16#00..16#7F +%% 'VisibleString' -> +%% 16#7E; % 16#20..16#7E +%% 'PrintableString' -> +%% $z; % [$\s,$',$(,$),$+,$,,$-,$.,$/,"0123456789",$:,$=,$?,$A..$Z,$a..$z +%% 'NumericString' -> +%% $9; % $ ,"0123456789" +%% 'UniversalString' -> +%% 16#ffffffff; +%% 'BMPString' -> +%% 16#ffff +%% end +%% end. + +%%Maybe used later +%%get_MinChar(C,StringType) -> +%% case get_constraint(C,'PermittedAlphabet') of +%% {'SingleValue',Sv} -> +%% hd(Sv); +%% no -> +%% case StringType of +%% 'IA5String' -> +%% 16#00; % 16#00..16#7F +%% 'VisibleString' -> +%% 16#20; % 16#20..16#7E +%% 'PrintableString' -> +%% $\s; % [$\s,$',$(,$),$+,$,,$-,$.,$/,"0123456789",$:,$=,$?,$A..$Z,$a..$z +%% 'NumericString' -> +%% $\s; % $ ,"0123456789" +%% 'UniversalString' -> +%% 16#00; +%% 'BMPString' -> +%% 16#00 +%% end +%% end. + +get_CharOutTab(C,StringType) -> + get_CharTab(C,StringType,out). + +get_CharInTab(C,StringType) -> + get_CharTab(C,StringType,in). + +get_CharTab(C,StringType,InOut) -> + case get_constraint(C,'PermittedAlphabet') of + {'SingleValue',Sv} -> + get_CharTab2(C,StringType,hd(Sv),lists:max(Sv),Sv,InOut); + no -> + case StringType of + 'IA5String' -> + {0,16#7F,notab}; + 'VisibleString' -> + get_CharTab2(C,StringType,16#20,16#7F,notab,InOut); + 'PrintableString' -> + Chars = lists:sort( + " '()+,-./0123456789:=?ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"), + get_CharTab2(C,StringType,hd(Chars),lists:max(Chars),Chars,InOut); + 'NumericString' -> + get_CharTab2(C,StringType,16#20,$9," 0123456789",InOut); + 'UniversalString' -> + {0,16#FFFFFFFF,notab}; + 'BMPString' -> + {0,16#FFFF,notab} + end + end. + +get_CharTab2(C,StringType,Min,Max,Chars,InOut) -> + BitValMax = (1 bsl get_NumBits(C,StringType))-1, + if + Max =< BitValMax -> + {0,Max,notab}; + true -> + case InOut of + out -> + {Min,Max,create_char_tab(Min,Chars)}; + in -> + {Min,Max,list_to_tuple(Chars)} + end + end. + +create_char_tab(Min,L) -> + list_to_tuple(create_char_tab(Min,L,0)). +create_char_tab(Min,[Min|T],V) -> + [V|create_char_tab(Min+1,T,V+1)]; +create_char_tab(_Min,[],_V) -> + []; +create_char_tab(Min,L,V) -> + [false|create_char_tab(Min+1,L,V)]. + +%% This very inefficient and should be moved to compiletime +charbits(NumOfChars,aligned) -> + case charbits(NumOfChars) of + 1 -> 1; + 2 -> 2; + B when B =< 4 -> 4; + B when B =< 8 -> 8; + B when B =< 16 -> 16; + B when B =< 32 -> 32 + end. + +charbits(NumOfChars) when NumOfChars =< 2 -> 1; +charbits(NumOfChars) when NumOfChars =< 4 -> 2; +charbits(NumOfChars) when NumOfChars =< 8 -> 3; +charbits(NumOfChars) when NumOfChars =< 16 -> 4; +charbits(NumOfChars) when NumOfChars =< 32 -> 5; +charbits(NumOfChars) when NumOfChars =< 64 -> 6; +charbits(NumOfChars) when NumOfChars =< 128 -> 7; +charbits(NumOfChars) when NumOfChars =< 256 -> 8; +charbits(NumOfChars) when NumOfChars =< 512 -> 9; +charbits(NumOfChars) when NumOfChars =< 1024 -> 10; +charbits(NumOfChars) when NumOfChars =< 2048 -> 11; +charbits(NumOfChars) when NumOfChars =< 4096 -> 12; +charbits(NumOfChars) when NumOfChars =< 8192 -> 13; +charbits(NumOfChars) when NumOfChars =< 16384 -> 14; +charbits(NumOfChars) when NumOfChars =< 32768 -> 15; +charbits(NumOfChars) when NumOfChars =< 65536 -> 16; +charbits(NumOfChars) when integer(NumOfChars) -> + 16 + charbits1(NumOfChars bsr 16). + +charbits1(0) -> + 0; +charbits1(NumOfChars) -> + 1 + charbits1(NumOfChars bsr 1). + + +chars_decode(Bytes,_,'BMPString',C,Len) -> + case get_constraint(C,'PermittedAlphabet') of + no -> + getBMPChars(Bytes,Len); + _ -> + exit({error,{asn1, + {'not implemented', + "BMPString with PermittedAlphabet constraint"}}}) + end; +chars_decode(Bytes,NumBits,StringType,C,Len) -> + CharInTab = get_CharInTab(C,StringType), + chars_decode2(Bytes,CharInTab,NumBits,Len). + + +chars_decode2(Bytes,CharInTab,NumBits,Len) -> + chars_decode2(Bytes,CharInTab,NumBits,Len,[]). + +chars_decode2(Bytes,_CharInTab,_NumBits,0,Acc) -> + {lists:reverse(Acc),Bytes}; +chars_decode2(Bytes,{Min,Max,notab},NumBits,Len,Acc) when NumBits > 8 -> + {Char,Bytes2} = getbits(Bytes,NumBits), + Result = + if + Char < 256 -> Char; + true -> + list_to_tuple(binary_to_list(<<Char:32>>)) + end, + chars_decode2(Bytes2,{Min,Max,notab},NumBits,Len -1,[Result|Acc]); +% chars_decode2(Bytes,{Min,Max,notab},NumBits,Len,Acc) when NumBits > 8 -> +% {Char,Bytes2} = getbits(Bytes,NumBits), +% Result = case minimum_octets(Char+Min) of +% [NewChar] -> NewChar; +% [C1,C2] -> {0,0,C1,C2}; +% [C1,C2,C3] -> {0,C1,C2,C3}; +% [C1,C2,C3,C4] -> {C1,C2,C3,C4} +% end, +% chars_decode2(Bytes2,{Min,Max,notab},NumBits,Len -1,[Result|Acc]); +chars_decode2(Bytes,{Min,Max,notab},NumBits,Len,Acc) -> + {Char,Bytes2} = getbits(Bytes,NumBits), + chars_decode2(Bytes2,{Min,Max,notab},NumBits,Len -1,[Char+Min|Acc]); + +%% BMPString and UniversalString with PermittedAlphabet is currently not supported +chars_decode2(Bytes,{Min,Max,CharInTab},NumBits,Len,Acc) -> + {Char,Bytes2} = getbits(Bytes,NumBits), + chars_decode2(Bytes2,{Min,Max,CharInTab},NumBits,Len -1,[element(Char+1,CharInTab)|Acc]). + + + % X.691:17 +encode_null(_) -> []; % encodes to nothing +encode_null({Name,Val}) when atom(Name) -> + encode_null(Val). + +decode_null(Bytes) -> + {'NULL',Bytes}. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% encode_object_identifier(Val) -> CompleteList +%% encode_object_identifier({Name,Val}) -> CompleteList +%% Val -> {Int1,Int2,...,IntN} % N >= 2 +%% Name -> atom() +%% Int1 -> integer(0..2) +%% Int2 -> integer(0..39) when Int1 (0..1) else integer() +%% Int3-N -> integer() +%% CompleteList -> [{bits,8,Val}|{octets,Ol}|align|...] +%% +encode_object_identifier({Name,Val}) when atom(Name) -> + encode_object_identifier(Val); +encode_object_identifier(Val) -> + OctetList = e_object_identifier(Val), + Octets = list_to_binary(OctetList), % performs a flatten at the same time + [{debug,object_identifier},encode_length(undefined,size(Octets)),{octets,Octets}]. + +%% This code is copied from asn1_encode.erl (BER) and corrected and modified + +e_object_identifier({'OBJECT IDENTIFIER',V}) -> + e_object_identifier(V); +e_object_identifier({Cname,V}) when atom(Cname),tuple(V) -> + e_object_identifier(tuple_to_list(V)); +e_object_identifier({Cname,V}) when atom(Cname),list(V) -> + e_object_identifier(V); +e_object_identifier(V) when tuple(V) -> + e_object_identifier(tuple_to_list(V)); + +%% E1 = 0|1|2 and (E2 < 40 when E1 = 0|1) +e_object_identifier([E1,E2|Tail]) when E1 >= 0, E1 < 2, E2 < 40 ; E1==2 -> + Head = 40*E1 + E2, % weird + e_object_elements([Head|Tail],[]); +e_object_identifier(Oid=[_,_|_Tail]) -> + exit({error,{asn1,{'illegal_value',Oid}}}). + +e_object_elements([],Acc) -> + lists:reverse(Acc); +e_object_elements([H|T],Acc) -> + e_object_elements(T,[e_object_element(H)|Acc]). + +e_object_element(Num) when Num < 128 -> + Num; +%% must be changed to handle more than 2 octets +e_object_element(Num) -> %% when Num < ??? + Left = ((Num band 2#11111110000000) bsr 7) bor 2#10000000, + Right = Num band 2#1111111 , + [Left,Right]. + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% decode_object_identifier(Bytes) -> {ObjId,RemainingBytes} +%% ObjId -> {integer(),integer(),...} % at least 2 integers +%% RemainingBytes -> [integer()] when integer() (0..255) +decode_object_identifier(Bytes) -> + {Len,Bytes2} = decode_length(Bytes,undefined), + {Octs,Bytes3} = getoctets_as_list(Bytes2,Len), + [First|Rest] = dec_subidentifiers(Octs,0,[]), + Idlist = if + First < 40 -> + [0,First|Rest]; + First < 80 -> + [1,First - 40|Rest]; + true -> + [2,First - 80|Rest] + end, + {list_to_tuple(Idlist),Bytes3}. + +dec_subidentifiers([H|T],Av,Al) when H >=16#80 -> + dec_subidentifiers(T,(Av bsl 7) + (H band 16#7F),Al); +dec_subidentifiers([H|T],Av,Al) -> + dec_subidentifiers(T,0,[(Av bsl 7) + H |Al]); +dec_subidentifiers([],_Av,Al) -> + lists:reverse(Al). + +get_constraint([{Key,V}],Key) -> + V; +get_constraint([],_Key) -> + no; +get_constraint(C,Key) -> + case lists:keysearch(Key,1,C) of + false -> + no; + {value,{_,V}} -> + V + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% complete(InList) -> ByteList +%% Takes a coded list with bits and bytes and converts it to a list of bytes +%% Should be applied as the last step at encode of a complete ASN.1 type +%% + +% complete(L) -> +% case complete1(L) of +% {[],0} -> +% <<0>>; +% {Acc,0} -> +% lists:reverse(Acc); +% {[Hacc|Tacc],Acclen} -> % Acclen >0 +% Rest = 8 - Acclen, +% NewHacc = Hacc bsl Rest, +% lists:reverse([NewHacc|Tacc]) +% end. + + +% complete1(InList) when list(InList) -> +% complete1(InList,[]); +% complete1(InList) -> +% complete1([InList],[]). + +% complete1([{debug,_}|T], Acc) -> +% complete1(T,Acc); +% complete1([H|T],Acc) when list(H) -> +% {NewH,NewAcclen} = complete1(H,Acc), +% complete1(T,NewH,NewAcclen); + +% complete1([{0,Bin}|T],Acc,0) when binary(Bin) -> +% complete1(T,[Bin|Acc],0); +% complete1([{Unused,Bin}|T],Acc,0) when integer(Unused),binary(Bin) -> +% Size = size(Bin)-1, +% <<Bs:Size/binary,B>> = Bin, +% complete1(T,[(B bsr Unused),Bs|Acc],8-Unused); +% complete1([{Unused,Bin}|T],[Hacc|Tacc],Acclen) when integer(Unused),binary(Bin) -> +% Rest = 8 - Acclen, +% Used = 8 - Unused, +% case size(Bin) of +% 1 -> +% if +% Rest >= Used -> +% <<B:Used,_:Unused>> = Bin, +% complete1(T,[(Hacc bsl Used) + B|Tacc], +% (Acclen+Used) rem 8); +% true -> +% LeftOver = 8 - Rest - Unused, +% <<Val2:Rest,Val1:LeftOver,_:Unused>> = Bin, +% complete1(T,[Val1,(Hacc bsl Rest) + Val2|Tacc], +% (Acclen+Used) rem 8) +% end; +% N -> +% if +% Rest == Used -> +% N1 = N - 1, +% <<B:Rest,Bs:N1/binary,_:Unused>> = Bin, +% complete1(T,[Bs,(Hacc bsl Rest) + B|Tacc],0); +% Rest > Used -> +% N1 = N - 2, +% N2 = (8 - Rest) + Used, +% <<B1:Rest,Bytes:N1/binary,B2:N2,_:Unused>> = Bin, +% complete1(T,[B2,Bytes,(Hacc bsl Rest) + B1|Tacc], +% (Acclen + Used) rem 8); +% true -> % Rest < Used +% N1 = N - 1, +% N2 = Used - Rest, +% <<B1:Rest,Bytes:N1/binary,B2:N2,_:Unused>> = Bin, +% complete1(T,[B2,Bytes,(Hacc bsl Rest) + B1|Tacc], +% (Acclen + Used) rem 8) +% end +% end; + +% %complete1([{octets,N,Val}|T],Acc,Acclen) when N =< 4 ,integer(Val) -> +% % complete1([{octets,<<Val:N/unit:8>>}|T],Acc,Acclen); +% complete1([{octets,N,Val}|T],Acc,Acclen) when N =< 4 ,integer(Val) -> +% Newval = case N of +% 1 -> +% Val4 = Val band 16#FF, +% [Val4]; +% 2 -> +% Val3 = (Val bsr 8) band 16#FF, +% Val4 = Val band 16#FF, +% [Val3,Val4]; +% 3 -> +% Val2 = (Val bsr 16) band 16#FF, +% Val3 = (Val bsr 8) band 16#FF, +% Val4 = Val band 16#FF, +% [Val2,Val3,Val4]; +% 4 -> +% Val1 = (Val bsr 24) band 16#FF, +% Val2 = (Val bsr 16) band 16#FF, +% Val3 = (Val bsr 8) band 16#FF, +% Val4 = Val band 16#FF, +% [Val1,Val2,Val3,Val4] +% end, +% complete1([{octets,Newval}|T],Acc,Acclen); + +% complete1([{octets,Bin}|T],Acc,Acclen) when binary(Bin) -> +% Rest = 8 - Acclen, +% if +% Rest == 8 -> +% complete1(T,[Bin|Acc],0); +% true -> +% [Hacc|Tacc]=Acc, +% complete1(T,[Bin, Hacc bsl Rest|Tacc],0) +% end; + +% complete1([{octets,Oct}|T],Acc,Acclen) when list(Oct) -> +% Rest = 8 - Acclen, +% if +% Rest == 8 -> +% complete1(T,[list_to_binary(Oct)|Acc],0); +% true -> +% [Hacc|Tacc]=Acc, +% complete1(T,[list_to_binary(Oct), Hacc bsl Rest|Tacc],0) +% end; + +% complete1([{bit,Val}|T], Acc, Acclen) -> +% complete1([{bits,1,Val}|T],Acc,Acclen); +% complete1([{octet,Val}|T], Acc, Acclen) -> +% complete1([{octets,1,Val}|T],Acc,Acclen); + +% complete1([{bits,N,Val}|T], Acc, 0) when N =< 8 -> +% complete1(T,[Val|Acc],N); +% complete1([{bits,N,Val}|T], [Hacc|Tacc], Acclen) when N =< 8 -> +% Rest = 8 - Acclen, +% if +% Rest >= N -> +% complete1(T,[(Hacc bsl N) + Val|Tacc],(Acclen+N) rem 8); +% true -> +% Diff = N - Rest, +% NewHacc = (Hacc bsl Rest) + (Val bsr Diff), +% Mask = element(Diff,{1,3,7,15,31,63,127,255}), +% complete1(T,[(Val band Mask),NewHacc|Tacc],(Acclen+N) rem 8) +% end; +% complete1([{bits,N,Val}|T], Acc, Acclen) -> % N > 8 +% complete1([{bits,N-8,Val bsr 8},{bits,8,Val band 255}|T],Acc,Acclen); + +% complete1([align|T],Acc,0) -> +% complete1(T,Acc,0); +% complete1([align|T],[Hacc|Tacc],Acclen) -> +% Rest = 8 - Acclen, +% complete1(T,[Hacc bsl Rest|Tacc],0); +% complete1([{octets,N,Val}|T],Acc,Acclen) when list(Val) -> % no security check here +% complete1([{octets,Val}|T],Acc,Acclen); + +% complete1([],Acc,Acclen) -> +% {Acc,Acclen}. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% complete(InList) -> ByteList +%% Takes a coded list with bits and bytes and converts it to a list of bytes +%% Should be applied as the last step at encode of a complete ASN.1 type +%% + +complete(L) -> + case complete1(L) of + {[],[]} -> + <<0>>; + {Acc,[]} -> + Acc; + {Acc,Bacc} -> + [Acc|complete_bytes(Bacc)] + end. + +%% this function builds the ugly form of lists [E1|E2] to avoid having to reverse it at the end. +%% this is done because it is efficient and that the result always will be sent on a port or +%% converted by means of list_to_binary/1 +complete1(InList) when list(InList) -> + complete1(InList,[],[]); +complete1(InList) -> + complete1([InList],[],[]). + +complete1([],Acc,Bacc) -> + {Acc,Bacc}; +complete1([H|T],Acc,Bacc) when list(H) -> + {NewH,NewBacc} = complete1(H,Acc,Bacc), + complete1(T,NewH,NewBacc); + +complete1([{octets,Bin}|T],Acc,[]) -> + complete1(T,[Acc|Bin],[]); + +complete1([{octets,Bin}|T],Acc,Bacc) -> + complete1(T,[Acc|[complete_bytes(Bacc),Bin]],[]); + +complete1([{debug,_}|T], Acc,Bacc) -> + complete1(T,Acc,Bacc); + +complete1([{bits,N,Val}|T],Acc,Bacc) -> + complete1(T,Acc,complete_update_byte(Bacc,Val,N)); + +complete1([{bit,Val}|T],Acc,Bacc) -> + complete1(T,Acc,complete_update_byte(Bacc,Val,1)); + +complete1([align|T],Acc,[]) -> + complete1(T,Acc,[]); +complete1([align|T],Acc,Bacc) -> + complete1(T,[Acc|complete_bytes(Bacc)],[]); +complete1([{0,Bin}|T],Acc,[]) when binary(Bin) -> + complete1(T,[Acc|Bin],[]); +complete1([{Unused,Bin}|T],Acc,[]) when integer(Unused),binary(Bin) -> + Size = size(Bin)-1, + <<Bs:Size/binary,B>> = Bin, + NumBits = 8-Unused, + complete1(T,[Acc|Bs],[[B bsr Unused]|NumBits]); +complete1([{Unused,Bin}|T],Acc,Bacc) when integer(Unused),binary(Bin) -> + Size = size(Bin)-1, + <<Bs:Size/binary,B>> = Bin, + NumBits = 8 - Unused, + Bf = complete_bytes(Bacc), + complete1(T,[Acc|[Bf,Bs]],[[B bsr Unused]|NumBits]). + + +complete_update_byte([],Val,Len) -> + complete_update_byte([[0]|0],Val,Len); +complete_update_byte([[Byte|Bacc]|NumBits],Val,Len) when NumBits + Len == 8 -> + [[0,((Byte bsl Len) + Val) band 255|Bacc]|0]; +complete_update_byte([[Byte|Bacc]|NumBits],Val,Len) when NumBits + Len > 8 -> + Rem = 8 - NumBits, + Rest = Len - Rem, + complete_update_byte([[0,((Byte bsl Rem) + (Val bsr Rest)) band 255 |Bacc]|0],Val,Rest); +complete_update_byte([[Byte|Bacc]|NumBits],Val,Len) -> + [[((Byte bsl Len) + Val) band 255|Bacc]|NumBits+Len]. + + +complete_bytes([[_Byte|Bacc]|0]) -> + lists:reverse(Bacc); +complete_bytes([[Byte|Bacc]|NumBytes]) -> + lists:reverse([(Byte bsl (8-NumBytes)) band 255|Bacc]); +complete_bytes([]) -> + []. + +% complete_bytes(L) -> +% complete_bytes1(lists:reverse(L),[],[],0,0). + +% complete_bytes1([H={V,B}|T],Acc,ReplyAcc,NumBits,NumFields) when ((NumBits+B) rem 8) == 0 -> +% NewReplyAcc = [complete_bytes2([H|Acc],0)|ReplyAcc], +% complete_bytes1(T,[],NewReplyAcc,0,0); +% complete_bytes1([H={V,B}|T],Acc,ReplyAcc,NumBits,NumFields) when NumFields == 7; (NumBits+B) div 8 > 0 -> +% Rem = (NumBits+B) rem 8, +% NewReplyAcc = [complete_bytes2([{V bsr Rem,B - Rem}|Acc],0)|ReplyAcc], +% complete_bytes1([{V,Rem}|T],[],NewReplyAcc,0,0); +% complete_bytes1([H={V,B}|T],Acc,ReplyAcc,NumBits,NumFields) -> +% complete_bytes1(T,[H|Acc],ReplyAcc,NumBits+B,NumFields+1); +% complete_bytes1([],[],ReplyAcc,_,_) -> +% lists:reverse(ReplyAcc); +% complete_bytes1([],Acc,ReplyAcc,NumBits,_) -> +% PadBits = case NumBits rem 8 of +% 0 -> 0; +% Rem -> 8 - Rem +% end, +% lists:reverse([complete_bytes2(Acc,PadBits)|ReplyAcc]). + + +% complete_bytes2([{V1,B1}],PadBits) -> +% <<V1:B1,0:PadBits>>; +% complete_bytes2([{V2,B2},{V1,B1}],PadBits) -> +% <<V1:B1,V2:B2,0:PadBits>>; +% complete_bytes2([{V3,B3},{V2,B2},{V1,B1}],PadBits) -> +% <<V1:B1,V2:B2,V3:B3,0:PadBits>>; +% complete_bytes2([{V4,B4},{V3,B3},{V2,B2},{V1,B1}],PadBits) -> +% <<V1:B1,V2:B2,V3:B3,V4:B4,0:PadBits>>; +% complete_bytes2([{V5,B5},{V4,B4},{V3,B3},{V2,B2},{V1,B1}],PadBits) -> +% <<V1:B1,V2:B2,V3:B3,V4:B4,V5:B5,0:PadBits>>; +% complete_bytes2([{V6,B6},{V5,B5},{V4,B4},{V3,B3},{V2,B2},{V1,B1}],PadBits) -> +% <<V1:B1,V2:B2,V3:B3,V4:B4,V5:B5,V6:B6,0:PadBits>>; +% complete_bytes2([{V7,B7},{V6,B6},{V5,B5},{V4,B4},{V3,B3},{V2,B2},{V1,B1}],PadBits) -> +% <<V1:B1,V2:B2,V3:B3,V4:B4,V5:B5,V6:B6,V7:B7,0:PadBits>>; +% complete_bytes2([{V8,B8},{V7,B7},{V6,B6},{V5,B5},{V4,B4},{V3,B3},{V2,B2},{V1,B1}],PadBits) -> +% <<V1:B1,V2:B2,V3:B3,V4:B4,V5:B5,V6:B6,V7:B7,V8:B8,0:PadBits>>. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_per_bin_rt2ct.erl b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_per_bin_rt2ct.erl new file mode 100644 index 0000000000..9f02ad4466 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_per_bin_rt2ct.erl @@ -0,0 +1,2102 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: asn1rt_per_bin_rt2ct.erl,v 1.1 2008/12/17 09:53:31 mikpe Exp $ +%% +-module(asn1rt_per_bin_rt2ct). + +%% encoding / decoding of PER aligned + +-include("asn1_records.hrl"). + +-export([dec_fixup/3, cindex/3, list_to_record/2]). +-export([setchoiceext/1, setext/1, fixoptionals/3, fixextensions/2, + getext/1, getextension/2, skipextensions/3, getbit/1, getchoice/3 ]). +-export([getoptionals/2, getoptionals2/2, + set_choice/3, encode_integer/2, encode_integer/3 ]). +-export([decode_integer/2, decode_integer/3, encode_small_number/1, + decode_boolean/1, encode_length/2, decode_length/1, decode_length/2, + encode_small_length/1, decode_small_length/1, + decode_compact_bit_string/3]). +-export([decode_enumerated/3, + encode_bit_string/3, decode_bit_string/3 ]). +-export([encode_octet_string/2, decode_octet_string/2, + encode_null/1, decode_null/1, + encode_object_identifier/1, decode_object_identifier/1, + complete/1]). + + +-export([encode_open_type/2, decode_open_type/2]). + +-export([%encode_UniversalString/2, decode_UniversalString/2, + %encode_PrintableString/2, decode_PrintableString/2, + encode_GeneralString/2, decode_GeneralString/2, + encode_GraphicString/2, decode_GraphicString/2, + encode_TeletexString/2, decode_TeletexString/2, + encode_VideotexString/2, decode_VideotexString/2, + %encode_VisibleString/2, decode_VisibleString/2, + %encode_BMPString/2, decode_BMPString/2, + %encode_IA5String/2, decode_IA5String/2, + %encode_NumericString/2, decode_NumericString/2, + encode_ObjectDescriptor/2, decode_ObjectDescriptor/1 + ]). + +-export([decode_constrained_number/2, + decode_constrained_number/3, + decode_unconstrained_number/1, + decode_semi_constrained_number/2, + encode_unconstrained_number/1, + decode_constrained_number/4, + encode_octet_string/3, + decode_octet_string/3, + encode_known_multiplier_string/5, + decode_known_multiplier_string/5, + getoctets/2, getbits/2 +% start_drv/1,start_drv2/1,init_drv/1 + ]). + + +-export([eint_positive/1]). +-export([pre_complete_bits/2]). + +-define('16K',16384). +-define('32K',32768). +-define('64K',65536). + +%%-define(nodriver,true). + +dec_fixup(Terms,Cnames,RemBytes) -> + dec_fixup(Terms,Cnames,RemBytes,[]). + +dec_fixup([novalue|T],[_Hc|Tc],RemBytes,Acc) -> + dec_fixup(T,Tc,RemBytes,Acc); +dec_fixup([{_Name,novalue}|T],[_Hc|Tc],RemBytes,Acc) -> + dec_fixup(T,Tc,RemBytes,Acc); +dec_fixup([H|T],[Hc|Tc],RemBytes,Acc) -> + dec_fixup(T,Tc,RemBytes,[{Hc,H}|Acc]); +dec_fixup([],_Cnames,RemBytes,Acc) -> + {lists:reverse(Acc),RemBytes}. + +cindex(Ix,Val,Cname) -> + case element(Ix,Val) of + {Cname,Val2} -> Val2; + X -> X + end. + +%% converts a list to a record if necessary +list_to_record(_,Tuple) when tuple(Tuple) -> + Tuple; +list_to_record(Name,List) when list(List) -> + list_to_tuple([Name|List]). + +%%-------------------------------------------------------- +%% setchoiceext(InRootSet) -> [{bit,X}] +%% X is set to 1 when InRootSet==false +%% X is set to 0 when InRootSet==true +%% +setchoiceext(true) -> +% [{debug,choiceext},{bits,1,0}]; + [0]; +setchoiceext(false) -> +% [{debug,choiceext},{bits,1,1}]. + [1]. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% setext(true|false) -> CompleteList +%% + +setext(false) -> +% [{debug,ext},{bits,1,0}]; + [0]; +setext(true) -> +% [{debug,ext},{bits,1,1}]; + [1]. + +fixoptionals(OptList,_OptLength,Val) when tuple(Val) -> +% Bits = fixoptionals(OptList,Val,0), +% {Val,{bits,OptLength,Bits}}; +% {Val,[10,OptLength,Bits]}; + {Val,fixoptionals(OptList,Val,[])}; + +fixoptionals([],_,Acc) -> + %% Optbits + lists:reverse(Acc); +fixoptionals([Pos|Ot],Val,Acc) -> + case element(Pos,Val) of +% asn1_NOVALUE -> fixoptionals(Ot,Val,Acc bsl 1); +% asn1_DEFAULT -> fixoptionals(Ot,Val,Acc bsl 1); +% _ -> fixoptionals(Ot,Val,(Acc bsl 1) + 1) + asn1_NOVALUE -> fixoptionals(Ot,Val,[0|Acc]); + asn1_DEFAULT -> fixoptionals(Ot,Val,[0|Acc]); + _ -> fixoptionals(Ot,Val,[1|Acc]) + end. + + +getext(Bytes) when tuple(Bytes) -> + getbit(Bytes); +getext(Bytes) when binary(Bytes) -> + getbit({0,Bytes}); +getext(Bytes) when list(Bytes) -> + getbit({0,Bytes}). + +getextension(0, Bytes) -> + {{},Bytes}; +getextension(1, Bytes) -> + {Len,Bytes2} = decode_small_length(Bytes), + {Blist, Bytes3} = getbits_as_list(Len,Bytes2), + {list_to_tuple(Blist),Bytes3}. + +fixextensions({ext,ExtPos,ExtNum},Val) -> + case fixextensions(ExtPos,ExtNum+ExtPos,Val,0) of + 0 -> []; + ExtBits -> +% [encode_small_length(ExtNum),{bits,ExtNum,ExtBits}] +% [encode_small_length(ExtNum),[10,ExtNum,ExtBits]] + [encode_small_length(ExtNum),pre_complete_bits(ExtNum,ExtBits)] + end. + +fixextensions(Pos,MaxPos,_,Acc) when Pos >= MaxPos -> + Acc; +fixextensions(Pos,ExtPos,Val,Acc) -> + Bit = case catch(element(Pos+1,Val)) of + asn1_NOVALUE -> + 0; + asn1_NOEXTVALUE -> + 0; + {'EXIT',_} -> + 0; + _ -> + 1 + end, + fixextensions(Pos+1,ExtPos,Val,(Acc bsl 1)+Bit). + +skipextensions(Bytes,Nr,ExtensionBitPattern) -> + case (catch element(Nr,ExtensionBitPattern)) of + 1 -> + {_,Bytes2} = decode_open_type(Bytes,[]), + skipextensions(Bytes2, Nr+1, ExtensionBitPattern); + 0 -> + skipextensions(Bytes, Nr+1, ExtensionBitPattern); + {'EXIT',_} -> % badarg, no more extensions + Bytes + end. + + +getchoice(Bytes,1,0) -> % only 1 alternative is not encoded + {0,Bytes}; +getchoice(Bytes,_,1) -> + decode_small_number(Bytes); +getchoice(Bytes,NumChoices,0) -> + decode_constrained_number(Bytes,{0,NumChoices-1}). + +%% old version kept for backward compatibility with generates from R7B01 +getoptionals(Bytes,NumOpt) -> + {Blist,Bytes1} = getbits_as_list(NumOpt,Bytes), + {list_to_tuple(Blist),Bytes1}. + +%% new version used in generates from r8b_patch/3 and later +getoptionals2(Bytes,NumOpt) -> + {_,_} = getbits(Bytes,NumOpt). + + +%% getbits_as_binary(Num,Bytes) -> {{Unused,BinBits},RestBytes}, +%% Num = integer(), +%% Bytes = list() | tuple(), +%% Unused = integer(), +%% BinBits = binary(), +%% RestBytes = tuple() +getbits_as_binary(Num,Bytes) when binary(Bytes) -> + getbits_as_binary(Num,{0,Bytes}); +getbits_as_binary(0,Buffer) -> + {{0,<<>>},Buffer}; +getbits_as_binary(Num,{0,Bin}) when Num > 16 -> + Used = Num rem 8, + Pad = (8 - Used) rem 8, +%% Nbytes = Num div 8, + <<Bits:Num,_:Pad,RestBin/binary>> = Bin, + {{Pad,<<Bits:Num,0:Pad>>},RestBin}; +getbits_as_binary(Num,Buffer={_Used,_Bin}) -> % Unaligned buffer + %% Num =< 16, + {Bits2,Buffer2} = getbits(Buffer,Num), + Pad = (8 - (Num rem 8)) rem 8, + {{Pad,<<Bits2:Num,0:Pad>>},Buffer2}. + + +% integer_from_list(Int,[],BigInt) -> +% BigInt; +% integer_from_list(Int,[H|T],BigInt) when Int < 8 -> +% (BigInt bsl Int) bor (H bsr (8-Int)); +% integer_from_list(Int,[H|T],BigInt) -> +% integer_from_list(Int-8,T,(BigInt bsl 8) bor H). + +getbits_as_list(Num,Bytes) when binary(Bytes) -> + getbits_as_list(Num,{0,Bytes},[]); +getbits_as_list(Num,Bytes) -> + getbits_as_list(Num,Bytes,[]). + +%% If buffer is empty and nothing more will be picked. +getbits_as_list(0, B, Acc) -> + {lists:reverse(Acc),B}; +%% If first byte in buffer is full and at least one byte will be picked, +%% then pick one byte. +getbits_as_list(N,{0,Bin},Acc) when N >= 8 -> + <<B7:1,B6:1,B5:1,B4:1,B3:1,B2:1,B1:1,B0:1,Rest/binary>> = Bin, + getbits_as_list(N-8,{0,Rest},[B0,B1,B2,B3,B4,B5,B6,B7|Acc]); +getbits_as_list(N,{Used,Bin},Acc) when N >= 4, Used =< 4 -> + NewUsed = Used + 4, + Rem = 8 - NewUsed, + <<_:Used,B3:1,B2:1,B1:1,B0:1,_:Rem, Rest/binary>> = Bin, + NewRest = case Rem of 0 -> Rest; _ -> Bin end, + getbits_as_list(N-4,{NewUsed rem 8,NewRest},[B0,B1,B2,B3|Acc]); +getbits_as_list(N,{Used,Bin},Acc) when N >= 2, Used =< 6 -> + NewUsed = Used + 2, + Rem = 8 - NewUsed, + <<_:Used,B1:1,B0:1,_:Rem, Rest/binary>> = Bin, + NewRest = case Rem of 0 -> Rest; _ -> Bin end, + getbits_as_list(N-2,{NewUsed rem 8,NewRest},[B0,B1|Acc]); +getbits_as_list(N,{Used,Bin},Acc) when Used =< 7 -> + NewUsed = Used + 1, + Rem = 8 - NewUsed, + <<_:Used,B0:1,_:Rem, Rest/binary>> = Bin, + NewRest = case Rem of 0 -> Rest; _ -> Bin end, + getbits_as_list(N-1,{NewUsed rem 8,NewRest},[B0|Acc]). + + +getbit({7,<<_:7,B:1,Rest/binary>>}) -> + {B,{0,Rest}}; +getbit({0,Buffer = <<B:1,_:7,_/binary>>}) -> + {B,{1,Buffer}}; +getbit({Used,Buffer}) -> + Unused = (8 - Used) - 1, + <<_:Used,B:1,_:Unused,_/binary>> = Buffer, + {B,{Used+1,Buffer}}; +getbit(Buffer) when binary(Buffer) -> + getbit({0,Buffer}). + + +getbits({0,Buffer},Num) when (Num rem 8) == 0 -> + <<Bits:Num,Rest/binary>> = Buffer, + {Bits,{0,Rest}}; +getbits({Used,Bin},Num) -> + NumPlusUsed = Num + Used, + NewUsed = NumPlusUsed rem 8, + Unused = (8-NewUsed) rem 8, + case Unused of + 0 -> + <<_:Used,Bits:Num,Rest/binary>> = Bin, + {Bits,{0,Rest}}; + _ -> + Bytes = NumPlusUsed div 8, + <<_:Used,Bits:Num,_:Unused,_/binary>> = Bin, + <<_:Bytes/binary,Rest/binary>> = Bin, + {Bits,{NewUsed,Rest}} + end; +getbits(Bin,Num) when binary(Bin) -> + getbits({0,Bin},Num). + + + +% getoctet(Bytes) when list(Bytes) -> +% getoctet({0,Bytes}); +% getoctet(Bytes) -> +% %% io:format("getoctet:Buffer = ~p~n",[Bytes]), +% getoctet1(Bytes). + +% getoctet1({0,[H|T]}) -> +% {H,{0,T}}; +% getoctet1({Pos,[_,H|T]}) -> +% {H,{0,T}}. + +align({0,L}) -> + {0,L}; +align({_Pos,<<_H,T/binary>>}) -> + {0,T}; +align(Bytes) -> + {0,Bytes}. + +%% First align buffer, then pick the first Num octets. +%% Returns octets as an integer with bit significance as in buffer. +getoctets({0,Buffer},Num) -> + <<Val:Num/integer-unit:8,RestBin/binary>> = Buffer, + {Val,{0,RestBin}}; +getoctets({U,<<_Padding,Rest/binary>>},Num) when U /= 0 -> + getoctets({0,Rest},Num); +getoctets(Buffer,Num) when binary(Buffer) -> + getoctets({0,Buffer},Num). +% getoctets(Buffer,Num) -> +% %% io:format("getoctets:Buffer = ~p~nNum = ~p~n",[Buffer,Num]), +% getoctets(Buffer,Num,0). + +% getoctets(Buffer,0,Acc) -> +% {Acc,Buffer}; +% getoctets(Buffer,Num,Acc) -> +% {Oct,NewBuffer} = getoctet(Buffer), +% getoctets(NewBuffer,Num-1,(Acc bsl 8)+Oct). + +% getoctets_as_list(Buffer,Num) -> +% getoctets_as_list(Buffer,Num,[]). + +% getoctets_as_list(Buffer,0,Acc) -> +% {lists:reverse(Acc),Buffer}; +% getoctets_as_list(Buffer,Num,Acc) -> +% {Oct,NewBuffer} = getoctet(Buffer), +% getoctets_as_list(NewBuffer,Num-1,[Oct|Acc]). + +%% First align buffer, then pick the first Num octets. +%% Returns octets as a binary +getoctets_as_bin({0,Bin},Num)-> + <<Octets:Num/binary,RestBin/binary>> = Bin, + {Octets,{0,RestBin}}; +getoctets_as_bin({_U,Bin},Num) -> + <<_Padding,Octets:Num/binary,RestBin/binary>> = Bin, + {Octets,{0,RestBin}}; +getoctets_as_bin(Bin,Num) when binary(Bin) -> + getoctets_as_bin({0,Bin},Num). + +%% same as above but returns octets as a List +getoctets_as_list(Buffer,Num) -> + {Bin,Buffer2} = getoctets_as_bin(Buffer,Num), + {binary_to_list(Bin),Buffer2}. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% set_choice(Alt,Choices,Altnum) -> ListofBitSettings +%% Alt = atom() +%% Altnum = integer() | {integer(),integer()}% number of alternatives +%% Choices = [atom()] | {[atom()],[atom()]} +%% When Choices is a tuple the first list is the Rootset and the +%% second is the Extensions and then Altnum must also be a tuple with the +%% lengths of the 2 lists +%% +set_choice(Alt,{L1,L2},{Len1,_Len2}) -> + case set_choice_tag(Alt,L1) of + N when integer(N), Len1 > 1 -> +% [{bits,1,0}, % the value is in the root set +% encode_constrained_number({0,Len1-1},N)]; + [0, % the value is in the root set + encode_constrained_number({0,Len1-1},N)]; + N when integer(N) -> +% [{bits,1,0}]; % no encoding if only 0 or 1 alternative + [0]; % no encoding if only 0 or 1 alternative + false -> +% [{bits,1,1}, % extension value + [1, % extension value + case set_choice_tag(Alt,L2) of + N2 when integer(N2) -> + encode_small_number(N2); + false -> + unknown_choice_alt + end] + end; +set_choice(Alt,L,Len) -> + case set_choice_tag(Alt,L) of + N when integer(N), Len > 1 -> + encode_constrained_number({0,Len-1},N); + N when integer(N) -> + []; % no encoding if only 0 or 1 alternative + false -> + [unknown_choice_alt] + end. + +set_choice_tag(Alt,Choices) -> + set_choice_tag(Alt,Choices,0). + +set_choice_tag(Alt,[Alt|_Rest],Tag) -> + Tag; +set_choice_tag(Alt,[_H|Rest],Tag) -> + set_choice_tag(Alt,Rest,Tag+1); +set_choice_tag(_Alt,[],_Tag) -> + false. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% decode_fragmented_XXX; decode of values encoded fragmented according +%% to ITU-T X.691 clause 10.9.3.8. The unit (XXX) is either bits, octets, +%% characters or number of components (in a choice,sequence or similar). +%% Buffer is a buffer {Used, Bin}. +%% C is the constrained length. +%% If the buffer is not aligned, this function does that. +decode_fragmented_bits({0,Buffer},C) -> + decode_fragmented_bits(Buffer,C,[]); +decode_fragmented_bits({_N,<<_B,Bs/binary>>},C) -> + decode_fragmented_bits(Bs,C,[]). + +decode_fragmented_bits(<<3:2,Len:6,Bin/binary>>,C,Acc) -> + {Value,Bin2} = split_binary(Bin, Len * ?'16K'), + decode_fragmented_bits(Bin2,C,[Value,Acc]); +decode_fragmented_bits(<<0:1,0:7,Bin/binary>>,C,Acc) -> + BinBits = list_to_binary(lists:reverse(Acc)), + case C of + Int when integer(Int),C == size(BinBits) -> + {BinBits,{0,Bin}}; + Int when integer(Int) -> + exit({error,{asn1,{illegal_value,C,BinBits}}}); + _ -> + {BinBits,{0,Bin}} + end; +decode_fragmented_bits(<<0:1,Len:7,Bin/binary>>,C,Acc) -> + Result = {BinBits,{Used,_Rest}} = + case (Len rem 8) of + 0 -> + <<Value:Len/binary-unit:1,Bin2/binary>> = Bin, + {list_to_binary(lists:reverse([Value|Acc])),{0,Bin2}}; + Rem -> + Bytes = Len div 8, + U = 8 - Rem, + <<Value:Bytes/binary-unit:8,Bits1:Rem,Bits2:U,Bin2/binary>> = Bin, + {list_to_binary(lists:reverse([Bits1 bsl U,Value|Acc])), + {Rem,<<Bits2,Bin2/binary>>}} + end, + case C of + Int when integer(Int),C == (size(BinBits) - ((8 - Used) rem 8)) -> + Result; + Int when integer(Int) -> + exit({error,{asn1,{illegal_value,C,BinBits}}}); + _ -> + Result + end. + + +decode_fragmented_octets({0,Bin},C) -> + decode_fragmented_octets(Bin,C,[]); +decode_fragmented_octets({_N,<<_B,Bs/binary>>},C) -> + decode_fragmented_octets(Bs,C,[]). + +decode_fragmented_octets(<<3:2,Len:6,Bin/binary>>,C,Acc) -> + {Value,Bin2} = split_binary(Bin,Len * ?'16K'), + decode_fragmented_octets(Bin2,C,[Value,Acc]); +decode_fragmented_octets(<<0:1,0:7,Bin/binary>>,C,Acc) -> + Octets = list_to_binary(lists:reverse(Acc)), + case C of + Int when integer(Int), C == size(Octets) -> + {Octets,{0,Bin}}; + Int when integer(Int) -> + exit({error,{asn1,{illegal_value,C,Octets}}}); + _ -> + {Octets,{0,Bin}} + end; +decode_fragmented_octets(<<0:1,Len:7,Bin/binary>>,C,Acc) -> + <<Value:Len/binary-unit:8,Bin2/binary>> = Bin, + BinOctets = list_to_binary(lists:reverse([Value|Acc])), + case C of + Int when integer(Int),size(BinOctets) == Int -> + {BinOctets,Bin2}; + Int when integer(Int) -> + exit({error,{asn1,{illegal_value,C,BinOctets}}}); + _ -> + {BinOctets,Bin2} + end. + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% encode_open_type(Constraint, Value) -> CompleteList +%% Value = list of bytes of an already encoded value (the list must be flat) +%% | binary +%% Contraint = not used in this version +%% +encode_open_type(_Constraint, Val) when list(Val) -> + Bin = list_to_binary(Val), + case size(Bin) of + Size when Size>255 -> + [encode_length(undefined,Size),[21,<<Size:16>>,Bin]]; + Size -> + [encode_length(undefined,Size),[20,Size,Bin]] + end; +% [encode_length(undefined,size(Bin)),{octets,Bin}]; % octets implies align +encode_open_type(_Constraint, Val) when binary(Val) -> +% [encode_length(undefined,size(Val)),{octets,Val}]. % octets implies align + case size(Val) of + Size when Size>255 -> + [encode_length(undefined,size(Val)),[21,<<Size:16>>,Val]]; % octets implies align + Size -> + [encode_length(undefined,Size),[20,Size,Val]] + end. +%% the binary_to_list is not optimal but compatible with the current solution + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% decode_open_type(Buffer,Constraint) -> Value +%% Constraint is not used in this version +%% Buffer = [byte] with PER encoded data +%% Value = [byte] with decoded data (which must be decoded again as some type) +%% +decode_open_type(Bytes, _Constraint) -> + {Len,Bytes2} = decode_length(Bytes,undefined), + getoctets_as_bin(Bytes2,Len). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% encode_integer(Constraint,Value,NamedNumberList) -> CompleteList +%% encode_integer(Constraint,Value) -> CompleteList +%% encode_integer(Constraint,{Name,Value}) -> CompleteList +%% +%% +encode_integer(C,V,NamedNumberList) when atom(V) -> + case lists:keysearch(V,1,NamedNumberList) of + {value,{_,NewV}} -> + encode_integer(C,NewV); + _ -> + exit({error,{asn1,{namednumber,V}}}) + end; +encode_integer(C,V,_NamedNumberList) when integer(V) -> + encode_integer(C,V); +encode_integer(C,{Name,V},NamedNumberList) when atom(Name) -> + encode_integer(C,V,NamedNumberList). + +encode_integer(C,{Name,Val}) when atom(Name) -> + encode_integer(C,Val); + +encode_integer([{Rc,_Ec}],Val) when tuple(Rc) -> % XXX when is this invoked? First argument most often a list,...Ok this is the extension case...but it doesn't work. + case (catch encode_integer([Rc],Val)) of + {'EXIT',{error,{asn1,_}}} -> +% [{bits,1,1},encode_unconstrained_number(Val)]; + [1,encode_unconstrained_number(Val)]; + Encoded -> +% [{bits,1,0},Encoded] + [0,Encoded] + end; + +encode_integer([],Val) -> + encode_unconstrained_number(Val); +%% The constraint is the effective constraint, and in this case is a number +encode_integer([{'SingleValue',V}],V) -> + []; +encode_integer([{'ValueRange',VR={Lb,Ub},Range,PreEnc}],Val) when Val >= Lb, + Ub >= Val -> + %% this case when NamedNumberList + encode_constrained_number(VR,Range,PreEnc,Val); +encode_integer([{'ValueRange',{Lb,'MAX'}}],Val) -> + encode_semi_constrained_number(Lb,Val); +encode_integer([{'ValueRange',{'MIN',_}}],Val) -> + encode_unconstrained_number(Val); +encode_integer([{'ValueRange',VR={_Lb,_Ub}}],Val) -> + encode_constrained_number(VR,Val); +encode_integer(_,Val) -> + exit({error,{asn1,{illegal_value,Val}}}). + + + +decode_integer(Buffer,Range,NamedNumberList) -> + {Val,Buffer2} = decode_integer(Buffer,Range), + case lists:keysearch(Val,2,NamedNumberList) of + {value,{NewVal,_}} -> {NewVal,Buffer2}; + _ -> {Val,Buffer2} + end. + +decode_integer(Buffer,[{Rc,_Ec}]) when tuple(Rc) -> + {Ext,Buffer2} = getext(Buffer), + case Ext of + 0 -> decode_integer(Buffer2,[Rc]); + 1 -> decode_unconstrained_number(Buffer2) + end; +decode_integer(Buffer,undefined) -> + decode_unconstrained_number(Buffer); +decode_integer(Buffer,C) -> + case get_constraint(C,'SingleValue') of + V when integer(V) -> + {V,Buffer}; + _ -> + decode_integer1(Buffer,C) + end. + +decode_integer1(Buffer,C) -> + case VR = get_constraint(C,'ValueRange') of + no -> + decode_unconstrained_number(Buffer); + {Lb, 'MAX'} -> + decode_semi_constrained_number(Buffer,Lb); + {_Lb,_Ub} -> + decode_constrained_number(Buffer,VR) + end. + +%% X.691:10.6 Encoding of a normally small non-negative whole number +%% Use this for encoding of CHOICE index if there is an extension marker in +%% the CHOICE +encode_small_number({Name,Val}) when atom(Name) -> + encode_small_number(Val); +encode_small_number(Val) when Val =< 63 -> +% [{bits,1,0},{bits,6,Val}]; +% [{bits,7,Val}]; % same as above but more efficient + [10,7,Val]; % same as above but more efficient +encode_small_number(Val) -> +% [{bits,1,1},encode_semi_constrained_number(0,Val)]. + [1,encode_semi_constrained_number(0,Val)]. + +decode_small_number(Bytes) -> + {Bit,Bytes2} = getbit(Bytes), + case Bit of + 0 -> + getbits(Bytes2,6); + 1 -> + decode_semi_constrained_number(Bytes2,0) + end. + +%% X.691:10.7 Encoding of a semi-constrained whole number +%% might be an optimization encode_semi_constrained_number(0,Val) -> +encode_semi_constrained_number(C,{Name,Val}) when atom(Name) -> + encode_semi_constrained_number(C,Val); +encode_semi_constrained_number({Lb,'MAX'},Val) -> + encode_semi_constrained_number(Lb,Val); +encode_semi_constrained_number(Lb,Val) -> + Val2 = Val - Lb, + Oct = eint_positive(Val2), + Len = length(Oct), + if + Len < 128 -> + %{octets,[Len|Oct]}; % equiv with encode_length(undefined,Len) but faster + [20,Len+1,[Len|Oct]]; + Len < 256 -> + [encode_length(undefined,Len),[20,Len,Oct]]; + true -> + [encode_length(undefined,Len),[21,<<Len:16>>,Oct]] + end. + +decode_semi_constrained_number(Bytes,{Lb,_}) -> + decode_semi_constrained_number(Bytes,Lb); +decode_semi_constrained_number(Bytes,Lb) -> + {Len,Bytes2} = decode_length(Bytes,undefined), + {V,Bytes3} = getoctets(Bytes2,Len), + {V+Lb,Bytes3}. + +encode_constrained_number({Lb,_Ub},_Range,{bits,N},Val) -> + Val2 = Val-Lb, +% {bits,N,Val2}; + [10,N,Val2]; +encode_constrained_number({Lb,_Ub},_Range,{octets,N},Val) when N < 256-> + %% N is 8 or 16 (1 or 2 octets) + Val2 = Val-Lb, +% {octets,<<Val2:N/unit:8>>}; + [20,N,Val2]; +encode_constrained_number({Lb,_Ub},_Range,{octets,N},Val) -> % N>255 + %% N is 8 or 16 (1 or 2 octets) + Val2 = Val-Lb, +% {octets,<<Val2:N/unit:8>>}; + [21,<<N:16>>,Val2]; +encode_constrained_number({Lb,_Ub},Range,_,Val) -> + Val2 = Val-Lb, + if + Range =< 16#1000000 -> % max 3 octets + Octs = eint_positive(Val2), +% [encode_length({1,3},size(Octs)),{octets,Octs}]; + L = length(Octs), + [encode_length({1,3},L),[20,L,Octs]]; + Range =< 16#100000000 -> % max 4 octets + Octs = eint_positive(Val2), +% [encode_length({1,4},size(Octs)),{octets,Octs}]; + L = length(Octs), + [encode_length({1,4},L),[20,L,Octs]]; + Range =< 16#10000000000 -> % max 5 octets + Octs = eint_positive(Val2), +% [encode_length({1,5},size(Octs)),{octets,Octs}]; + L = length(Octs), + [encode_length({1,5},L),[20,L,Octs]]; + true -> + exit({not_supported,{integer_range,Range}}) + end. + +encode_constrained_number(Range,{Name,Val}) when atom(Name) -> + encode_constrained_number(Range,Val); +encode_constrained_number({Lb,Ub},Val) when Val >= Lb, Ub >= Val -> + Range = Ub - Lb + 1, + Val2 = Val - Lb, + if + Range == 2 -> +% Size = {bits,1,Val2}; + [Val2]; + Range =< 4 -> +% Size = {bits,2,Val2}; + [10,2,Val2]; + Range =< 8 -> + [10,3,Val2]; + Range =< 16 -> + [10,4,Val2]; + Range =< 32 -> + [10,5,Val2]; + Range =< 64 -> + [10,6,Val2]; + Range =< 128 -> + [10,7,Val2]; + Range =< 255 -> + [10,8,Val2]; + Range =< 256 -> +% Size = {octets,[Val2]}; + [20,1,Val2]; + Range =< 65536 -> +% Size = {octets,<<Val2:16>>}; + [20,2,<<Val2:16>>]; + Range =< 16#1000000 -> + Octs = eint_positive(Val2), +% [{bits,2,length(Octs)-1},{octets,Octs}]; + Len = length(Octs), + [10,2,Len-1,20,Len,Octs]; + Range =< 16#100000000 -> + Octs = eint_positive(Val2), + Len = length(Octs), + [10,2,Len-1,20,Len,Octs]; + Range =< 16#10000000000 -> + Octs = eint_positive(Val2), + Len = length(Octs), + [10,3,Len-1,20,Len,Octs]; + true -> + exit({not_supported,{integer_range,Range}}) + end; +encode_constrained_number({_,_},Val) -> + exit({error,{asn1,{illegal_value,Val}}}). + +decode_constrained_number(Buffer,VR={Lb,Ub}) -> + Range = Ub - Lb + 1, + decode_constrained_number(Buffer,VR,Range). + +decode_constrained_number(Buffer,{Lb,_Ub},_Range,{bits,N}) -> + {Val,Remain} = getbits(Buffer,N), + {Val+Lb,Remain}; +decode_constrained_number(Buffer,{Lb,_Ub},_Range,{octets,N}) -> + {Val,Remain} = getoctets(Buffer,N), + {Val+Lb,Remain}. + +decode_constrained_number(Buffer,{Lb,_Ub},Range) -> + % Val2 = Val - Lb, + {Val,Remain} = + if + Range == 2 -> + getbits(Buffer,1); + Range =< 4 -> + getbits(Buffer,2); + Range =< 8 -> + getbits(Buffer,3); + Range =< 16 -> + getbits(Buffer,4); + Range =< 32 -> + getbits(Buffer,5); + Range =< 64 -> + getbits(Buffer,6); + Range =< 128 -> + getbits(Buffer,7); + Range =< 255 -> + getbits(Buffer,8); + Range =< 256 -> + getoctets(Buffer,1); + Range =< 65536 -> + getoctets(Buffer,2); + Range =< 16#1000000 -> + {Len,Bytes2} = decode_length(Buffer,{1,3}), + {Octs,Bytes3} = getoctets_as_list(Bytes2,Len), + {dec_pos_integer(Octs),Bytes3}; + Range =< 16#100000000 -> + {Len,Bytes2} = decode_length(Buffer,{1,4}), + {Octs,Bytes3} = getoctets_as_list(Bytes2,Len), + {dec_pos_integer(Octs),Bytes3}; + Range =< 16#10000000000 -> + {Len,Bytes2} = decode_length(Buffer,{1,5}), + {Octs,Bytes3} = getoctets_as_list(Bytes2,Len), + {dec_pos_integer(Octs),Bytes3}; + true -> + exit({not_supported,{integer_range,Range}}) + end, + {Val+Lb,Remain}. + +%% X.691:10.8 Encoding of an unconstrained whole number + +encode_unconstrained_number(Val) when Val >= 0 -> + Oct = eint(Val,[]), + Len = length(Oct), + if + Len < 128 -> + %{octets,[Len|Oct]}; % equiv with encode_length(undefined,Len) but faster + [20,Len+1,[Len|Oct]]; + Len < 256 -> +% [encode_length(undefined,Len),20,Len,Oct]; + [20,Len+2,<<2:2,Len:14>>,Oct];% equiv with encode_length(undefined,Len) but faster + true -> +% [encode_length(undefined,Len),{octets,Oct}] + [encode_length(undefined,Len),[21,<<Len:16>>,Oct]] + end; +encode_unconstrained_number(Val) -> % negative + Oct = enint(Val,[]), + Len = length(Oct), + if + Len < 128 -> +% {octets,[Len|Oct]}; % equiv with encode_length(undefined,Len) but faster + [20,Len+1,[Len|Oct]];% equiv with encode_length(undefined,Len) but faster + Len < 256 -> +% [encode_length(undefined,Len),20,Len,Oct]; + [20,Len+2,<<2:2,Len:14>>,Oct];% equiv with encode_length(undefined,Len) but faster + true -> + %[encode_length(undefined,Len),{octets,Oct}] + [encode_length(undefined,Len),[21,<<Len:16>>,Oct]] + end. + + +%% used for positive Values which don't need a sign bit +%% returns a list +eint_positive(Val) -> + case eint(Val,[]) of + [0,B1|T] -> + [B1|T]; + T -> + T + end. + + +eint(0, [B|Acc]) when B < 128 -> + [B|Acc]; +eint(N, Acc) -> + eint(N bsr 8, [N band 16#ff| Acc]). + +enint(-1, [B1|T]) when B1 > 127 -> + [B1|T]; +enint(N, Acc) -> + enint(N bsr 8, [N band 16#ff|Acc]). + +decode_unconstrained_number(Bytes) -> + {Len,Bytes2} = decode_length(Bytes,undefined), + {Ints,Bytes3} = getoctets_as_list(Bytes2,Len), + {dec_integer(Ints),Bytes3}. + +dec_pos_integer(Ints) -> + decpint(Ints, 8 * (length(Ints) - 1)). +dec_integer(Ints) when hd(Ints) band 255 =< 127 -> %% Positive number + decpint(Ints, 8 * (length(Ints) - 1)); +dec_integer(Ints) -> %% Negative + decnint(Ints, 8 * (length(Ints) - 1)). + +decpint([Byte|Tail], Shift) -> + (Byte bsl Shift) bor decpint(Tail, Shift-8); +decpint([], _) -> 0. + +decnint([Byte|Tail], Shift) -> + (-128 + (Byte band 127) bsl Shift) bor decpint(Tail, Shift-8). + +% minimum_octets(Val) -> +% minimum_octets(Val,[]). + +% minimum_octets(Val,Acc) when Val > 0 -> +% minimum_octets((Val bsr 8),[Val band 16#FF|Acc]); +% minimum_octets(0,Acc) -> +% Acc. + + +%% X.691:10.9 Encoding of a length determinant +%%encode_small_length(undefined,Len) -> % null means no UpperBound +%% encode_small_number(Len). + +%% X.691:10.9.3.5 +%% X.691:10.9.3.7 +encode_length(undefined,Len) -> % un-constrained + if + Len < 128 -> +% {octets,[Len]}; + [20,1,Len]; + Len < 16384 -> + %{octets,<<2:2,Len:14>>}; + [20,2,<<2:2,Len:14>>]; + true -> % should be able to endode length >= 16384 i.e. fragmented length + exit({error,{asn1,{encode_length,{nyi,above_16k}}}}) + end; + +encode_length({0,'MAX'},Len) -> + encode_length(undefined,Len); +encode_length(Vr={Lb,Ub},Len) when Ub =< 65535 ,Lb >= 0 -> % constrained + encode_constrained_number(Vr,Len); +encode_length({Lb,_Ub},Len) when integer(Lb), Lb >= 0 -> % Ub > 65535 + encode_length(undefined,Len); +encode_length({Vr={Lb,Ub},[]},Len) when Ub =< 65535 ,Lb >= 0,Len=<Ub -> + %% constrained extensible +% [{bits,1,0},encode_constrained_number(Vr,Len)]; + [0,encode_constrained_number(Vr,Len)]; +encode_length({{Lb,_},[]},Len) -> + [1,encode_semi_constrained_number(Lb,Len)]; +encode_length(SingleValue,_Len) when integer(SingleValue) -> + []. + +%% X.691 10.9.3.4 (only used for length of bitmap that prefixes extension +%% additions in a sequence or set +encode_small_length(Len) when Len =< 64 -> +%% [{bits,1,0},{bits,6,Len-1}]; +% {bits,7,Len-1}; % the same as above but more efficient + [10,7,Len-1]; +encode_small_length(Len) -> +% [{bits,1,1},encode_length(undefined,Len)]. + [1,encode_length(undefined,Len)]. + +% decode_small_length({Used,<<_:Used,0:1,Num:6,_:((8-Used+1) rem 8),Rest/binary>>}) -> +% case Buffer of +% <<_:Used,0:1,Num:6,_:((8-Used+1) rem 8),Rest/binary>> -> +% {Num, +% case getbit(Buffer) of +% {0,Remain} -> +% {Bits,Remain2} = getbits(Remain,6), +% {Bits+1,Remain2}; +% {1,Remain} -> +% decode_length(Remain,undefined) +% end. + +decode_small_length(Buffer) -> + case getbit(Buffer) of + {0,Remain} -> + {Bits,Remain2} = getbits(Remain,6), + {Bits+1,Remain2}; + {1,Remain} -> + decode_length(Remain,undefined) + end. + +decode_length(Buffer) -> + decode_length(Buffer,undefined). + +decode_length(Buffer,undefined) -> % un-constrained + {0,Buffer2} = align(Buffer), + case Buffer2 of + <<0:1,Oct:7,Rest/binary>> -> + {Oct,{0,Rest}}; + <<2:2,Val:14,Rest/binary>> -> + {Val,{0,Rest}}; + <<3:2,_Val:14,_Rest/binary>> -> + %% this case should be fixed + exit({error,{asn1,{decode_length,{nyi,above_16k}}}}) + end; +%% {Bits,_} = getbits(Buffer2,2), +% case Bits of +% 2 -> +% {Val,Bytes3} = getoctets(Buffer2,2), +% {(Val band 16#3FFF),Bytes3}; +% 3 -> +% exit({error,{asn1,{decode_length,{nyi,above_16k}}}}); +% _ -> +% {Val,Bytes3} = getoctet(Buffer2), +% {Val band 16#7F,Bytes3} +% end; + +decode_length(Buffer,{Lb,Ub}) when Ub =< 65535 ,Lb >= 0 -> % constrained + decode_constrained_number(Buffer,{Lb,Ub}); +decode_length(_Buffer,{Lb,_Ub}) when integer(Lb), Lb >= 0 -> % Ub > 65535 + exit({error,{asn1,{decode_length,{nyi,above_64K}}}}); +decode_length(Buffer,{{Lb,Ub},[]}) -> + case getbit(Buffer) of + {0,Buffer2} -> + decode_length(Buffer2, {Lb,Ub}) + end; + + +%When does this case occur with {_,_Lb,Ub} ?? +% X.691:10.9.3.5 +decode_length({Used,Bin},{_,_Lb,_Ub}) -> %when Len =< 127 -> % Unconstrained or large Ub NOTE! this case does not cover case when Ub > 65535 + Unused = (8-Used) rem 8, + case Bin of + <<_:Used,0:1,Val:7,R:Unused,Rest/binary>> -> + {Val,{Used,<<R,Rest/binary>>}}; + <<_:Used,_:Unused,2:2,Val:14,Rest/binary>> -> + {Val, {0,Rest}}; + <<_:Used,_:Unused,3:2,_:14,_Rest/binary>> -> + exit({error,{asn1,{decode_length,{nyi,length_above_64K}}}}) + end; +% decode_length(Buffer,{_,_Lb,Ub}) -> %when Len =< 127 -> % Unconstrained or large Ub +% case getbit(Buffer) of +% {0,Remain} -> +% getbits(Remain,7); +% {1,Remain} -> +% {Val,Remain2} = getoctets(Buffer,2), +% {Val band 2#0111111111111111, Remain2} +% end; +decode_length(Buffer,SingleValue) when integer(SingleValue) -> + {SingleValue,Buffer}. + + + % X.691:11 +decode_boolean(Buffer) -> %when record(Buffer,buffer) + case getbit(Buffer) of + {1,Remain} -> {true,Remain}; + {0,Remain} -> {false,Remain} + end. + + +%% ENUMERATED with extension marker +decode_enumerated(Buffer,C,{Ntup1,Ntup2}) when tuple(Ntup1), tuple(Ntup2) -> + {Ext,Buffer2} = getext(Buffer), + case Ext of + 0 -> % not an extension value + {Val,Buffer3} = decode_integer(Buffer2,C), + case catch (element(Val+1,Ntup1)) of + NewVal when atom(NewVal) -> {NewVal,Buffer3}; + _Error -> exit({error,{asn1,{decode_enumerated,{Val,[Ntup1,Ntup2]}}}}) + end; + 1 -> % this an extension value + {Val,Buffer3} = decode_small_number(Buffer2), + case catch (element(Val+1,Ntup2)) of + NewVal when atom(NewVal) -> {NewVal,Buffer3}; + _ -> {{asn1_enum,Val},Buffer3} + end + end; + +decode_enumerated(Buffer,C,NamedNumberTup) when tuple(NamedNumberTup) -> + {Val,Buffer2} = decode_integer(Buffer,C), + case catch (element(Val+1,NamedNumberTup)) of + NewVal when atom(NewVal) -> {NewVal,Buffer2}; + _Error -> exit({error,{asn1,{decode_enumerated,{Val,NamedNumberTup}}}}) + end. + +%%=============================================================================== +%%=============================================================================== +%%=============================================================================== +%% Bitstring value, ITU_T X.690 Chapter 8.5 +%%=============================================================================== +%%=============================================================================== +%%=============================================================================== + +%%=============================================================================== +%% encode bitstring value +%%=============================================================================== + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% bitstring NamedBitList +%% Val can be of: +%% - [identifiers] where only named identifers are set to one, +%% the Constraint must then have some information of the +%% bitlength. +%% - [list of ones and zeroes] all bits +%% - integer value representing the bitlist +%% C is constraint Len, only valid when identifiers + + +%% when the value is a list of {Unused,BinBits}, where +%% Unused = integer(), +%% BinBits = binary(). + +encode_bit_string(C,Bin={Unused,BinBits},NamedBitList) when integer(Unused), + binary(BinBits) -> + encode_bin_bit_string(C,Bin,NamedBitList); + +%% when the value is a list of named bits + +encode_bit_string(C, LoNB=[FirstVal | _RestVal], NamedBitList) when atom(FirstVal) -> + ToSetPos = get_all_bitposes(LoNB, NamedBitList, []), + BitList = make_and_set_list(ToSetPos,0), + encode_bit_string(C,BitList,NamedBitList);% consider the constraint + +encode_bit_string(C, BL=[{bit,_} | _RestVal], NamedBitList) -> + ToSetPos = get_all_bitposes(BL, NamedBitList, []), + BitList = make_and_set_list(ToSetPos,0), + encode_bit_string(C,BitList,NamedBitList); + +%% when the value is a list of ones and zeroes +encode_bit_string(Int, BitListValue, _) + when list(BitListValue),integer(Int) -> + %% The type is constrained by a single value size constraint + [40,Int,length(BitListValue),BitListValue]; +% encode_bit_string(C, BitListValue,NamedBitList) +% when list(BitListValue) -> +% [encode_bit_str_length(C,BitListValue), +% 2,45,BitListValue]; +encode_bit_string(no, BitListValue,[]) + when list(BitListValue) -> + [encode_length(undefined,length(BitListValue)), + 2,BitListValue]; +encode_bit_string(C, BitListValue,[]) + when list(BitListValue) -> + [encode_length(C,length(BitListValue)), + 2,BitListValue]; +encode_bit_string(no, BitListValue,_NamedBitList) + when list(BitListValue) -> + %% this case with an unconstrained BIT STRING can be made more efficient + %% if the complete driver can take a special code so the length field + %% is encoded there. + NewBitLVal = lists:reverse(lists:dropwhile(fun(0)->true;(1)->false end, + lists:reverse(BitListValue))), + [encode_length(undefined,length(NewBitLVal)), + 2,NewBitLVal]; +encode_bit_string(C,BitListValue,_NamedBitList) + when list(BitListValue) ->% C = {_,'MAX'} +% NewBitLVal = lists:reverse(lists:dropwhile(fun(0)->true;(1)->false end, +% lists:reverse(BitListValue))), + NewBitLVal = bit_string_trailing_zeros(BitListValue,C), + [encode_length(C,length(NewBitLVal)), + 2,NewBitLVal]; + +% encode_bit_string(C, BitListValue, NamedBitList) when list(BitListValue) -> +% BitListToBinary = +% %% fun that transforms a list of 1 and 0 to a tuple: +% %% {UnusedBitsInLastByte, Binary} +% fun([H|T],Acc,N,Fun) -> +% Fun(T,(Acc bsl 1)+H,N+1,Fun); +% ([],Acc,N,_) -> % length fits in one byte +% Unused = (8 - (N rem 8)) rem 8, +% % case N/8 of +% % _Len =< 255 -> +% % [30,Unused,(Unused+N)/8,<<Acc:N,0:Unused>>]; +% % _Len -> +% % Len = (Unused+N)/8, +% % [31,Unused,<<Len:16>>,<<Acc:N,0:Unused>>] +% % end +% {Unused,<<Acc:N,0:Unused>>} +% end, +% UnusedAndBin = +% case NamedBitList of +% [] -> % dont remove trailing zeroes +% BitListToBinary(BitListValue,0,0,BitListToBinary); +% _ -> +% BitListToBinary(lists:reverse( +% lists:dropwhile(fun(0)->true;(1)->false end, +% lists:reverse(BitListValue))), +% 0,0,BitListToBinary) +% end, +% encode_bin_bit_string(C,UnusedAndBin,NamedBitList); + +%% when the value is an integer +encode_bit_string(C, IntegerVal, NamedBitList) when integer(IntegerVal)-> + BitList = int_to_bitlist(IntegerVal), + encode_bit_string(C,BitList,NamedBitList); + +%% when the value is a tuple +encode_bit_string(C,{Name,Val}, NamedBitList) when atom(Name) -> + encode_bit_string(C,Val,NamedBitList). + +bit_string_trailing_zeros(BitList,C) when integer(C) -> + bit_string_trailing_zeros1(BitList,C,C); +bit_string_trailing_zeros(BitList,{Lb,Ub}) when integer(Lb) -> + bit_string_trailing_zeros1(BitList,Lb,Ub); +bit_string_trailing_zeros(BitList,{{Lb,Ub},_}) when integer(Lb) -> + bit_string_trailing_zeros1(BitList,Lb,Ub); +bit_string_trailing_zeros(BitList,_) -> + BitList. + +bit_string_trailing_zeros1(BitList,Lb,Ub) -> + case length(BitList) of + Lb -> BitList; + B when B<Lb -> BitList++lists:duplicate(Lb-B,0); + D -> F = fun(L,LB,LB,_,_)->lists:reverse(L); + ([0|R],L1,LB,UB,Fun)->Fun(R,L1-1,LB,UB,Fun); + (L,L1,_,UB,_)when L1 =< UB -> lists:reverse(L); + (_,_L1,_,_,_) ->exit({error,{list_length_BIT_STRING, + BitList}}) end, + F(lists:reverse(BitList),D,Lb,Ub,F) + end. + +%% encode_bin_bit_string/3, when value is a tuple of Unused and BinBits. +%% Unused = integer(),i.e. number unused bits in least sign. byte of +%% BinBits = binary(). +encode_bin_bit_string(C,{_,BinBits},_NamedBitList) + when integer(C),C=<16 -> + [45,C,size(BinBits),BinBits]; +encode_bin_bit_string(C,{_Unused,BinBits},_NamedBitList) + when integer(C) -> + [2,45,C,size(BinBits),BinBits]; +encode_bin_bit_string(C,UnusedAndBin={_,_},NamedBitList) -> +% UnusedAndBin1 = {Unused1,Bin1} = + {Unused1,Bin1} = + %% removes all trailing bits if NamedBitList is not empty + remove_trailing_bin(NamedBitList,UnusedAndBin), + case C of +% case get_constraint(C,'SizeConstraint') of + +% 0 -> +% []; % borde avg�ras i compile-time +% V when integer(V),V=<16 -> +% {Unused2,Bin2} = pad_list(V,UnusedAndBin1), +% <<BitVal:V,_:Unused2>> = Bin2, +% % {bits,V,BitVal}; +% [10,V,BitVal]; +% V when integer(V) -> +% %[align, pad_list(V, UnusedAndBin1)]; +% {Unused2,Bin2} = pad_list(V, UnusedAndBin1), +% <<BitVal:V,_:Unused2>> = Bin2, +% [2,octets_unused_to_complete(Unused2,size(Bin2),Bin2)]; + + {Lb,Ub} when integer(Lb),integer(Ub) -> +% [encode_length({Lb,Ub},size(Bin1)*8 - Unused1), +% align,UnusedAndBin1]; + Size=size(Bin1), + [encode_length({Lb,Ub},Size*8 - Unused1), + 2,octets_unused_to_complete(Unused1,Size,Bin1)]; + no -> + Size=size(Bin1), + [encode_length(undefined,Size*8 - Unused1), + 2,octets_unused_to_complete(Unused1,Size,Bin1)]; + Sc -> + Size=size(Bin1), + [encode_length(Sc,Size*8 - Unused1), + 2,octets_unused_to_complete(Unused1,Size,Bin1)] + end. + +remove_trailing_bin([], {Unused,Bin}) -> + {Unused,Bin}; +remove_trailing_bin(NamedNumberList, {_Unused,Bin}) -> + Size = size(Bin)-1, + <<Bfront:Size/binary, LastByte:8>> = Bin, + %% clear the Unused bits to be sure +% LastByte1 = LastByte band (((1 bsl Unused) -1) bxor 255),% why this??? + Unused1 = trailingZeroesInNibble(LastByte band 15), + Unused2 = + case Unused1 of + 4 -> + 4 + trailingZeroesInNibble(LastByte bsr 4); + _ -> Unused1 + end, + case Unused2 of + 8 -> + remove_trailing_bin(NamedNumberList,{0,Bfront}); + _ -> + {Unused2,Bin} + end. + + +trailingZeroesInNibble(0) -> + 4; +trailingZeroesInNibble(1) -> + 0; +trailingZeroesInNibble(2) -> + 1; +trailingZeroesInNibble(3) -> + 0; +trailingZeroesInNibble(4) -> + 2; +trailingZeroesInNibble(5) -> + 0; +trailingZeroesInNibble(6) -> + 1; +trailingZeroesInNibble(7) -> + 0; +trailingZeroesInNibble(8) -> + 3; +trailingZeroesInNibble(9) -> + 0; +trailingZeroesInNibble(10) -> + 1; +trailingZeroesInNibble(11) -> + 0; +trailingZeroesInNibble(12) -> %#1100 + 2; +trailingZeroesInNibble(13) -> + 0; +trailingZeroesInNibble(14) -> + 1; +trailingZeroesInNibble(15) -> + 0. + +%%%%%%%%%%%%%%% +%% The result is presented as a list of named bits (if possible) +%% else as a tuple {Unused,Bits}. Unused is the number of unused +%% bits, least significant bits in the last byte of Bits. Bits is +%% the BIT STRING represented as a binary. +%% +decode_compact_bit_string(Buffer, C, NamedNumberList) -> + case get_constraint(C,'SizeConstraint') of + 0 -> % fixed length + {{8,0},Buffer}; + V when integer(V),V=<16 -> %fixed length 16 bits or less + compact_bit_string(Buffer,V,NamedNumberList); + V when integer(V),V=<65536 -> %fixed length > 16 bits + Bytes2 = align(Buffer), + compact_bit_string(Bytes2,V,NamedNumberList); + V when integer(V) -> % V > 65536 => fragmented value + {Bin,Buffer2} = decode_fragmented_bits(Buffer,V), + case Buffer2 of + {0,_} -> {{0,Bin},Buffer2}; + {U,_} -> {{8-U,Bin},Buffer2} + end; + {Lb,Ub} when integer(Lb),integer(Ub) -> + %% This case may demand decoding of fragmented length/value + {Len,Bytes2} = decode_length(Buffer,{Lb,Ub}), + Bytes3 = align(Bytes2), + compact_bit_string(Bytes3,Len,NamedNumberList); + no -> + %% This case may demand decoding of fragmented length/value + {Len,Bytes2} = decode_length(Buffer,undefined), + Bytes3 = align(Bytes2), + compact_bit_string(Bytes3,Len,NamedNumberList); + Sc -> + {Len,Bytes2} = decode_length(Buffer,Sc), + Bytes3 = align(Bytes2), + compact_bit_string(Bytes3,Len,NamedNumberList) + end. + + +%%%%%%%%%%%%%%% +%% The result is presented as a list of named bits (if possible) +%% else as a list of 0 and 1. +%% +decode_bit_string(Buffer, C, NamedNumberList) -> + case get_constraint(C,'SizeConstraint') of + {Lb,Ub} when integer(Lb),integer(Ub) -> + {Len,Bytes2} = decode_length(Buffer,{Lb,Ub}), + Bytes3 = align(Bytes2), + bit_list_or_named(Bytes3,Len,NamedNumberList); + no -> + {Len,Bytes2} = decode_length(Buffer,undefined), + Bytes3 = align(Bytes2), + bit_list_or_named(Bytes3,Len,NamedNumberList); + 0 -> % fixed length + {[],Buffer}; % nothing to encode + V when integer(V),V=<16 -> % fixed length 16 bits or less + bit_list_or_named(Buffer,V,NamedNumberList); + V when integer(V),V=<65536 -> + Bytes2 = align(Buffer), + bit_list_or_named(Bytes2,V,NamedNumberList); + V when integer(V) -> + Bytes2 = align(Buffer), + {BinBits,_Bytes3} = decode_fragmented_bits(Bytes2,V), + bit_list_or_named(BinBits,V,NamedNumberList); + Sc -> % extension marker + {Len,Bytes2} = decode_length(Buffer,Sc), + Bytes3 = align(Bytes2), + bit_list_or_named(Bytes3,Len,NamedNumberList) + end. + + +%% if no named bits are declared we will return a +%% {Unused,Bits}. Unused = integer(), +%% Bits = binary(). +compact_bit_string(Buffer,Len,[]) -> + getbits_as_binary(Len,Buffer); % {{Unused,BinBits},NewBuffer} +compact_bit_string(Buffer,Len,NamedNumberList) -> + bit_list_or_named(Buffer,Len,NamedNumberList). + + +%% if no named bits are declared we will return a +%% BitList = [0 | 1] + +bit_list_or_named(Buffer,Len,[]) -> + getbits_as_list(Len,Buffer); + +%% if there are named bits declared we will return a named +%% BitList where the names are atoms and unnamed bits represented +%% as {bit,Pos} +%% BitList = [atom() | {bit,Pos}] +%% Pos = integer() + +bit_list_or_named(Buffer,Len,NamedNumberList) -> + {BitList,Rest} = getbits_as_list(Len,Buffer), + {bit_list_or_named1(0,BitList,NamedNumberList,[]), Rest}. + +bit_list_or_named1(Pos,[0|Bt],Names,Acc) -> + bit_list_or_named1(Pos+1,Bt,Names,Acc); +bit_list_or_named1(Pos,[1|Bt],Names,Acc) -> + case lists:keysearch(Pos,2,Names) of + {value,{Name,_}} -> + bit_list_or_named1(Pos+1,Bt,Names,[Name|Acc]); + _ -> + bit_list_or_named1(Pos+1,Bt,Names,[{bit,Pos}|Acc]) + end; +bit_list_or_named1(_Pos,[],_Names,Acc) -> + lists:reverse(Acc). + + + +%%%%%%%%%%%%%%% +%% + +int_to_bitlist(Int) when integer(Int), Int > 0 -> + [Int band 1 | int_to_bitlist(Int bsr 1)]; +int_to_bitlist(0) -> + []. + + +%%%%%%%%%%%%%%%%%% +%% get_all_bitposes([list of named bits to set], named_bit_db, []) -> +%% [sorted_list_of_bitpositions_to_set] + +get_all_bitposes([{bit,ValPos}|Rest], NamedBitList, Ack) -> + get_all_bitposes(Rest, NamedBitList, [ValPos | Ack ]); + +get_all_bitposes([Val | Rest], NamedBitList, Ack) -> + case lists:keysearch(Val, 1, NamedBitList) of + {value, {_ValName, ValPos}} -> + get_all_bitposes(Rest, NamedBitList, [ValPos | Ack]); + _ -> + exit({error,{asn1, {bitstring_namedbit, Val}}}) + end; +get_all_bitposes([], _NamedBitList, Ack) -> + lists:sort(Ack). + +%%%%%%%%%%%%%%%%%% +%% make_and_set_list([list of positions to set to 1])-> +%% returns list with all in SetPos set. +%% in positioning in list the first element is 0, the second 1 etc.., but +%% + +make_and_set_list([XPos|SetPos], XPos) -> + [1 | make_and_set_list(SetPos, XPos + 1)]; +make_and_set_list([Pos|SetPos], XPos) -> + [0 | make_and_set_list([Pos | SetPos], XPos + 1)]; +make_and_set_list([], _) -> + []. + +%%%%%%%%%%%%%%%%% +%% pad_list(N,BitList) -> PaddedList +%% returns a padded (with trailing {bit,0} elements) list of length N +%% if Bitlist contains more than N significant bits set an exit asn1_error +%% is generated + +% pad_list(N,In={Unused,Bin}) -> +% pad_list(N, size(Bin)*8 - Unused, In). + +% pad_list(N,Size,In={Unused,Bin}) when N < Size -> +% exit({error,{asn1,{range_error,{bit_string,In}}}}); +% pad_list(N,Size,{Unused,Bin}) when N > Size, Unused > 0 -> +% pad_list(N,Size+1,{Unused-1,Bin}); +% pad_list(N,Size,{Unused,Bin}) when N > Size -> +% pad_list(N,Size+1,{7,<<Bin/binary,0>>}); +% pad_list(N,N,In={Unused,Bin}) -> +% In. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% X.691:16 +%% encode_octet_string(Constraint,ExtensionMarker,Val) +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +encode_octet_string(C,Val) -> + encode_octet_string(C,false,Val). + +encode_octet_string(C,Bool,{_Name,Val}) -> + encode_octet_string(C,Bool,Val); +encode_octet_string(_C,true,_Val) -> + exit({error,{asn1,{'not_supported',extensionmarker}}}); +encode_octet_string(SZ={_,_},false,Val) -> +% [encode_length(SZ,length(Val)),align, +% {octets,Val}]; + Len = length(Val), + [encode_length(SZ,Len),2, + octets_to_complete(Len,Val)]; +encode_octet_string(SZ,false,Val) when list(SZ) -> + Len = length(Val), + [encode_length({hd(SZ),lists:max(SZ)},Len),2, + octets_to_complete(Len,Val)]; +encode_octet_string(no,false,Val) -> + Len = length(Val), + [encode_length(undefined,Len),2, + octets_to_complete(Len,Val)]; +encode_octet_string(C,_,_) -> + exit({error,{not_implemented,C}}). + + +decode_octet_string(Bytes,Range) -> + decode_octet_string(Bytes,Range,false). + +decode_octet_string(Bytes,1,false) -> + {B1,Bytes2} = getbits(Bytes,8), + {[B1],Bytes2}; +decode_octet_string(Bytes,2,false) -> + {Bs,Bytes2}= getbits(Bytes,16), + {binary_to_list(<<Bs:16>>),Bytes2}; +decode_octet_string(Bytes,Sv,false) when integer(Sv),Sv=<65535 -> + Bytes2 = align(Bytes), + getoctets_as_list(Bytes2,Sv); +decode_octet_string(Bytes,Sv,false) when integer(Sv) -> + Bytes2 = align(Bytes), + decode_fragmented_octets(Bytes2,Sv); +decode_octet_string(Bytes,{Lb,Ub},false) -> + {Len,Bytes2} = decode_length(Bytes,{Lb,Ub}), + Bytes3 = align(Bytes2), + getoctets_as_list(Bytes3,Len); +decode_octet_string(Bytes,Sv,false) when list(Sv) -> + {Len,Bytes2} = decode_length(Bytes,{hd(Sv),lists:max(Sv)}), + Bytes3 = align(Bytes2), + getoctets_as_list(Bytes3,Len); +decode_octet_string(Bytes,no,false) -> + {Len,Bytes2} = decode_length(Bytes,undefined), + Bytes3 = align(Bytes2), + getoctets_as_list(Bytes3,Len). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Restricted char string types +%% (NumericString, PrintableString,VisibleString,IA5String,BMPString,UniversalString) +%% X.691:26 and X.680:34-36 +%%encode_restricted_string(aligned,'BMPString',Constraints,Extension,Val) + + +encode_restricted_string(aligned,{Name,Val}) when atom(Name) -> + encode_restricted_string(aligned,Val); + +encode_restricted_string(aligned,Val) when list(Val)-> + Len = length(Val), +% [encode_length(undefined,length(Val)),{octets,Val}]. + [encode_length(undefined,Len),octets_to_complete(Len,Val)]. + + +encode_known_multiplier_string(StringType,SizeC,NumBits,CharOutTab,{Name,Val}) when atom(Name) -> + encode_known_multiplier_string(StringType,SizeC,NumBits,CharOutTab,Val); +encode_known_multiplier_string(StringType,SizeC,NumBits,CharOutTab,Val) -> + Result = chars_encode2(Val,NumBits,CharOutTab), + case SizeC of + Ub when integer(Ub), Ub*NumBits =< 16 -> + case {StringType,Result} of + {'BMPString',{octets,Ol}} -> %% this case cannot happen !!?? + [{bits,8,Oct}||Oct <- Ol]; + _ -> + Result + end; + Ub when integer(Ub),Ub =<65535 -> % fixed length +%% [align,Result]; + [2,Result]; + {Ub,Lb} -> +% [encode_length({Ub,Lb},length(Val)),align,Result]; + [encode_length({Ub,Lb},length(Val)),2,Result]; + no -> +% [encode_length(undefined,length(Val)),align,Result] + [encode_length(undefined,length(Val)),2,Result] + end. + +decode_restricted_string(Bytes,aligned) -> + {Len,Bytes2} = decode_length(Bytes,undefined), + getoctets_as_list(Bytes2,Len). + +decode_known_multiplier_string(StringType,SizeC,NumBits,CharInTab,Bytes) -> + case SizeC of + Ub when integer(Ub), Ub*NumBits =< 16 -> + chars_decode(Bytes,NumBits,StringType,CharInTab,Ub); + Ub when integer(Ub),Ub =<65535 -> % fixed length + Bytes1 = align(Bytes), + chars_decode(Bytes1,NumBits,StringType,CharInTab,Ub); + Vl when list(Vl) -> + {Len,Bytes1} = decode_length(Bytes,{hd(Vl),lists:max(Vl)}), + Bytes2 = align(Bytes1), + chars_decode(Bytes2,NumBits,StringType,CharInTab,Len); + no -> + {Len,Bytes1} = decode_length(Bytes,undefined), + Bytes2 = align(Bytes1), + chars_decode(Bytes2,NumBits,StringType,CharInTab,Len); + {Lb,Ub}-> + {Len,Bytes1} = decode_length(Bytes,{Lb,Ub}), + Bytes2 = align(Bytes1), + chars_decode(Bytes2,NumBits,StringType,CharInTab,Len) + end. + +encode_GeneralString(_C,Val) -> + encode_restricted_string(aligned,Val). +decode_GeneralString(Bytes,_C) -> + decode_restricted_string(Bytes,aligned). + +encode_GraphicString(_C,Val) -> + encode_restricted_string(aligned,Val). +decode_GraphicString(Bytes,_C) -> + decode_restricted_string(Bytes,aligned). + +encode_ObjectDescriptor(_C,Val) -> + encode_restricted_string(aligned,Val). +decode_ObjectDescriptor(Bytes) -> + decode_restricted_string(Bytes,aligned). + +encode_TeletexString(_C,Val) -> % equivalent with T61String + encode_restricted_string(aligned,Val). +decode_TeletexString(Bytes,_C) -> + decode_restricted_string(Bytes,aligned). + +encode_VideotexString(_C,Val) -> + encode_restricted_string(aligned,Val). +decode_VideotexString(Bytes,_C) -> + decode_restricted_string(Bytes,aligned). + + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% getBMPChars(Bytes,Len) ->{BMPcharList,RemainingBytes} +%% +getBMPChars(Bytes,1) -> + {O1,Bytes2} = getbits(Bytes,8), + {O2,Bytes3} = getbits(Bytes2,8), + if + O1 == 0 -> + {[O2],Bytes3}; + true -> + {[{0,0,O1,O2}],Bytes3} + end; +getBMPChars(Bytes,Len) -> + getBMPChars(Bytes,Len,[]). + +getBMPChars(Bytes,0,Acc) -> + {lists:reverse(Acc),Bytes}; +getBMPChars(Bytes,Len,Acc) -> + {Octs,Bytes1} = getoctets_as_list(Bytes,2), + case Octs of + [0,O2] -> + getBMPChars(Bytes1,Len-1,[O2|Acc]); + [O1,O2]-> + getBMPChars(Bytes1,Len-1,[{0,0,O1,O2}|Acc]) + end. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% chars_encode(C,StringType,Value) -> ValueList +%% +%% encodes chars according to the per rules taking the constraint PermittedAlphabet +%% into account. +%% This function does only encode the value part and NOT the length + +% chars_encode(C,StringType,Value) -> +% case {StringType,get_constraint(C,'PermittedAlphabet')} of +% {'UniversalString',{_,Sv}} -> +% exit({error,{asn1,{'not implemented',"UniversalString with PermittedAlphabet constraint"}}}); +% {'BMPString',{_,Sv}} -> +% exit({error,{asn1,{'not implemented',"BMPString with PermittedAlphabet constraint"}}}); +% _ -> +% {NumBits,CharOutTab} = {get_NumBits(C,StringType),get_CharOutTab(C,StringType)}, +% chars_encode2(Value,NumBits,CharOutTab) +% end. + + +chars_encode2([H|T],NumBits,T1={Min,Max,notab}) when H =< Max, H >= Min -> +% [[10,NumBits,H-Min]|chars_encode2(T,NumBits,T1)]; + [pre_complete_bits(NumBits,H-Min)|chars_encode2(T,NumBits,T1)]; +chars_encode2([H|T],NumBits,T1={Min,Max,Tab}) when H =< Max, H >= Min -> +% [[10,NumBits,element(H-Min+1,Tab)]|chars_encode2(T,NumBits,T1)]; + [pre_complete_bits(NumBits,exit_if_false(H,element(H-Min+1,Tab)))| + chars_encode2(T,NumBits,T1)]; +chars_encode2([{A,B,C,D}|T],NumBits,T1={Min,_Max,notab}) -> + %% no value range check here (ought to be, but very expensive) +% [{bits,NumBits,(A*B*C*D)-Min}|chars_encode2(T,NumBits,{Min,Max,notab})]; +% [[10,NumBits,((((((A bsl 8)+B) bsl 8)+C) bsl 8)+D)-Min]|chars_encode2(T,NumBits,T1)]; + [pre_complete_bits(NumBits, + ((((((A bsl 8)+B) bsl 8)+C) bsl 8)+D)-Min)| + chars_encode2(T,NumBits,T1)]; +chars_encode2([H={A,B,C,D}|T],NumBits,{Min,Max,Tab}) -> + %% no value range check here (ought to be, but very expensive) + [pre_complete_bits(NumBits,exit_if_false(H,element(((((((A bsl 8)+B) bsl 8)+C) bsl 8)+D)-Min,Tab)))|chars_encode2(T,NumBits,{Min,Max,notab})]; +chars_encode2([H|_T],_NumBits,{_Min,_Max,_Tab}) -> + exit({error,{asn1,{illegal_char_value,H}}}); +chars_encode2([],_,_) -> + []. + +exit_if_false(V,false)-> + exit({error,{asn1,{"illegal value according to Permitted alphabet constraint",V}}}); +exit_if_false(_,V) ->V. + +pre_complete_bits(NumBits,Val) when NumBits =< 8 -> + [10,NumBits,Val]; +pre_complete_bits(NumBits,Val) when NumBits =< 16 -> + [10,NumBits-8,Val bsr 8,10,8,(Val band 255)]; +pre_complete_bits(NumBits,Val) when NumBits =< 2040 -> % 255 * 8 +% LBUsed = NumBits rem 8, +% {Unused,Len} = case (8 - LBUsed) of +% 8 -> {0,NumBits div 8}; +% U -> {U,(NumBits div 8) + 1} +% end, +% NewVal = Val bsr LBUsed, +% [30,Unused,Len,<<NewVal:Len/unit:8,Val:LBUsed,0:Unused>>]. + Unused = (8 - (NumBits rem 8)) rem 8, + Len = NumBits + Unused, + [30,Unused,Len div 8,<<(Val bsl Unused):Len>>]. + +% get_NumBits(C,StringType) -> +% case get_constraint(C,'PermittedAlphabet') of +% {'SingleValue',Sv} -> +% charbits(length(Sv),aligned); +% no -> +% case StringType of +% 'IA5String' -> +% charbits(128,aligned); % 16#00..16#7F +% 'VisibleString' -> +% charbits(95,aligned); % 16#20..16#7E +% 'PrintableString' -> +% charbits(74,aligned); % [$\s,$',$(,$),$+,$,,$-,$.,$/,"0123456789",$:,$=,$?,$A..$Z,$a..$z +% 'NumericString' -> +% charbits(11,aligned); % $ ,"0123456789" +% 'UniversalString' -> +% 32; +% 'BMPString' -> +% 16 +% end +% end. + +%%Maybe used later +%%get_MaxChar(C,StringType) -> +%% case get_constraint(C,'PermittedAlphabet') of +%% {'SingleValue',Sv} -> +%% lists:nth(length(Sv),Sv); +%% no -> +%% case StringType of +%% 'IA5String' -> +%% 16#7F; % 16#00..16#7F +%% 'VisibleString' -> +%% 16#7E; % 16#20..16#7E +%% 'PrintableString' -> +%% $z; % [$\s,$',$(,$),$+,$,,$-,$.,$/,"0123456789",$:,$=,$?,$A..$Z,$a..$z +%% 'NumericString' -> +%% $9; % $ ,"0123456789" +%% 'UniversalString' -> +%% 16#ffffffff; +%% 'BMPString' -> +%% 16#ffff +%% end +%% end. + +%%Maybe used later +%%get_MinChar(C,StringType) -> +%% case get_constraint(C,'PermittedAlphabet') of +%% {'SingleValue',Sv} -> +%% hd(Sv); +%% no -> +%% case StringType of +%% 'IA5String' -> +%% 16#00; % 16#00..16#7F +%% 'VisibleString' -> +%% 16#20; % 16#20..16#7E +%% 'PrintableString' -> +%% $\s; % [$\s,$',$(,$),$+,$,,$-,$.,$/,"0123456789",$:,$=,$?,$A..$Z,$a..$z +%% 'NumericString' -> +%% $\s; % $ ,"0123456789" +%% 'UniversalString' -> +%% 16#00; +%% 'BMPString' -> +%% 16#00 +%% end +%% end. + +% get_CharOutTab(C,StringType) -> +% get_CharTab(C,StringType,out). + +% get_CharInTab(C,StringType) -> +% get_CharTab(C,StringType,in). + +% get_CharTab(C,StringType,InOut) -> +% case get_constraint(C,'PermittedAlphabet') of +% {'SingleValue',Sv} -> +% get_CharTab2(C,StringType,hd(Sv),lists:max(Sv),Sv,InOut); +% no -> +% case StringType of +% 'IA5String' -> +% {0,16#7F,notab}; +% 'VisibleString' -> +% get_CharTab2(C,StringType,16#20,16#7F,notab,InOut); +% 'PrintableString' -> +% Chars = lists:sort( +% " '()+,-./0123456789:=?ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"), +% get_CharTab2(C,StringType,hd(Chars),lists:max(Chars),Chars,InOut); +% 'NumericString' -> +% get_CharTab2(C,StringType,16#20,$9," 0123456789",InOut); +% 'UniversalString' -> +% {0,16#FFFFFFFF,notab}; +% 'BMPString' -> +% {0,16#FFFF,notab} +% end +% end. + +% get_CharTab2(C,StringType,Min,Max,Chars,InOut) -> +% BitValMax = (1 bsl get_NumBits(C,StringType))-1, +% if +% Max =< BitValMax -> +% {0,Max,notab}; +% true -> +% case InOut of +% out -> +% {Min,Max,create_char_tab(Min,Chars)}; +% in -> +% {Min,Max,list_to_tuple(Chars)} +% end +% end. + +% create_char_tab(Min,L) -> +% list_to_tuple(create_char_tab(Min,L,0)). +% create_char_tab(Min,[Min|T],V) -> +% [V|create_char_tab(Min+1,T,V+1)]; +% create_char_tab(_Min,[],_V) -> +% []; +% create_char_tab(Min,L,V) -> +% [false|create_char_tab(Min+1,L,V)]. + +%% This very inefficient and should be moved to compiletime +% charbits(NumOfChars,aligned) -> +% case charbits(NumOfChars) of +% 1 -> 1; +% 2 -> 2; +% B when B =< 4 -> 4; +% B when B =< 8 -> 8; +% B when B =< 16 -> 16; +% B when B =< 32 -> 32 +% end. + +% charbits(NumOfChars) when NumOfChars =< 2 -> 1; +% charbits(NumOfChars) when NumOfChars =< 4 -> 2; +% charbits(NumOfChars) when NumOfChars =< 8 -> 3; +% charbits(NumOfChars) when NumOfChars =< 16 -> 4; +% charbits(NumOfChars) when NumOfChars =< 32 -> 5; +% charbits(NumOfChars) when NumOfChars =< 64 -> 6; +% charbits(NumOfChars) when NumOfChars =< 128 -> 7; +% charbits(NumOfChars) when NumOfChars =< 256 -> 8; +% charbits(NumOfChars) when NumOfChars =< 512 -> 9; +% charbits(NumOfChars) when NumOfChars =< 1024 -> 10; +% charbits(NumOfChars) when NumOfChars =< 2048 -> 11; +% charbits(NumOfChars) when NumOfChars =< 4096 -> 12; +% charbits(NumOfChars) when NumOfChars =< 8192 -> 13; +% charbits(NumOfChars) when NumOfChars =< 16384 -> 14; +% charbits(NumOfChars) when NumOfChars =< 32768 -> 15; +% charbits(NumOfChars) when NumOfChars =< 65536 -> 16; +% charbits(NumOfChars) when integer(NumOfChars) -> +% 16 + charbits1(NumOfChars bsr 16). + +% charbits1(0) -> +% 0; +% charbits1(NumOfChars) -> +% 1 + charbits1(NumOfChars bsr 1). + + +chars_decode(Bytes,_,'BMPString',_,Len) -> + getBMPChars(Bytes,Len); +chars_decode(Bytes,NumBits,_StringType,CharInTab,Len) -> + chars_decode2(Bytes,CharInTab,NumBits,Len). + + +chars_decode2(Bytes,CharInTab,NumBits,Len) -> + chars_decode2(Bytes,CharInTab,NumBits,Len,[]). + +chars_decode2(Bytes,_CharInTab,_NumBits,0,Acc) -> + {lists:reverse(Acc),Bytes}; +chars_decode2(Bytes,{Min,Max,notab},NumBits,Len,Acc) when NumBits > 8 -> + {Char,Bytes2} = getbits(Bytes,NumBits), + Result = + if + Char < 256 -> Char; + true -> + list_to_tuple(binary_to_list(<<Char:32>>)) + end, + chars_decode2(Bytes2,{Min,Max,notab},NumBits,Len -1,[Result|Acc]); +chars_decode2(Bytes,{Min,Max,notab},NumBits,Len,Acc) -> + {Char,Bytes2} = getbits(Bytes,NumBits), + chars_decode2(Bytes2,{Min,Max,notab},NumBits,Len -1,[Char+Min|Acc]); + +%% BMPString and UniversalString with PermittedAlphabet is currently not supported +chars_decode2(Bytes,{Min,Max,CharInTab},NumBits,Len,Acc) -> + {Char,Bytes2} = getbits(Bytes,NumBits), + chars_decode2(Bytes2,{Min,Max,CharInTab},NumBits,Len -1,[element(Char+1,CharInTab)|Acc]). + + + % X.691:17 +encode_null(_Val) -> []; % encodes to nothing +encode_null({Name,Val}) when atom(Name) -> + encode_null(Val). + +decode_null(Bytes) -> + {'NULL',Bytes}. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% encode_object_identifier(Val) -> CompleteList +%% encode_object_identifier({Name,Val}) -> CompleteList +%% Val -> {Int1,Int2,...,IntN} % N >= 2 +%% Name -> atom() +%% Int1 -> integer(0..2) +%% Int2 -> integer(0..39) when Int1 (0..1) else integer() +%% Int3-N -> integer() +%% CompleteList -> [{bits,8,Val}|{octets,Ol}|align|...] +%% +encode_object_identifier({Name,Val}) when atom(Name) -> + encode_object_identifier(Val); +encode_object_identifier(Val) -> + OctetList = e_object_identifier(Val), + Octets = list_to_binary(OctetList), % performs a flatten at the same time +% [{debug,object_identifier},encode_length(undefined,size(Octets)),{octets,Octets}]. + [encode_length(undefined,size(Octets)), + octets_to_complete(size(Octets),Octets)]. + +%% This code is copied from asn1_encode.erl (BER) and corrected and modified + +e_object_identifier({'OBJECT IDENTIFIER',V}) -> + e_object_identifier(V); +e_object_identifier({Cname,V}) when atom(Cname),tuple(V) -> + e_object_identifier(tuple_to_list(V)); +e_object_identifier({Cname,V}) when atom(Cname),list(V) -> + e_object_identifier(V); +e_object_identifier(V) when tuple(V) -> + e_object_identifier(tuple_to_list(V)); + +%% E1 = 0|1|2 and (E2 < 40 when E1 = 0|1) +e_object_identifier([E1,E2|Tail]) when E1 >= 0, E1 < 2, E2 < 40 ; E1==2 -> + Head = 40*E1 + E2, % weird + e_object_elements([Head|Tail],[]); +e_object_identifier(Oid=[_,_|_Tail]) -> + exit({error,{asn1,{'illegal_value',Oid}}}). + +e_object_elements([],Acc) -> + lists:reverse(Acc); +e_object_elements([H|T],Acc) -> + e_object_elements(T,[e_object_element(H)|Acc]). + +e_object_element(Num) when Num < 128 -> + Num; +%% must be changed to handle more than 2 octets +e_object_element(Num) -> %% when Num < ??? + Left = ((Num band 2#11111110000000) bsr 7) bor 2#10000000, + Right = Num band 2#1111111 , + [Left,Right]. + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% decode_object_identifier(Bytes) -> {ObjId,RemainingBytes} +%% ObjId -> {integer(),integer(),...} % at least 2 integers +%% RemainingBytes -> [integer()] when integer() (0..255) +decode_object_identifier(Bytes) -> + {Len,Bytes2} = decode_length(Bytes,undefined), + {Octs,Bytes3} = getoctets_as_list(Bytes2,Len), + [First|Rest] = dec_subidentifiers(Octs,0,[]), + Idlist = if + First < 40 -> + [0,First|Rest]; + First < 80 -> + [1,First - 40|Rest]; + true -> + [2,First - 80|Rest] + end, + {list_to_tuple(Idlist),Bytes3}. + +dec_subidentifiers([H|T],Av,Al) when H >=16#80 -> + dec_subidentifiers(T,(Av bsl 7) + (H band 16#7F),Al); +dec_subidentifiers([H|T],Av,Al) -> + dec_subidentifiers(T,0,[(Av bsl 7) + H |Al]); +dec_subidentifiers([],_Av,Al) -> + lists:reverse(Al). + +get_constraint([{Key,V}],Key) -> + V; +get_constraint([],_) -> + no; +get_constraint(C,Key) -> + case lists:keysearch(Key,1,C) of + false -> + no; + {value,{_,V}} -> + V + end. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% complete(InList) -> ByteList +%% Takes a coded list with bits and bytes and converts it to a list of bytes +%% Should be applied as the last step at encode of a complete ASN.1 type +%% + +-ifdef(nodriver). + +complete(L) -> + case complete1(L) of + {[],[]} -> + <<0>>; + {Acc,[]} -> + Acc; + {Acc,Bacc} -> + [Acc|complete_bytes(Bacc)] + end. + + +% this function builds the ugly form of lists [E1|E2] to avoid having to reverse it at the end. +% this is done because it is efficient and that the result always will be sent on a port or +% converted by means of list_to_binary/1 + complete1(InList) when list(InList) -> + complete1(InList,[],[]); + complete1(InList) -> + complete1([InList],[],[]). + + complete1([],Acc,Bacc) -> + {Acc,Bacc}; + complete1([H|T],Acc,Bacc) when list(H) -> + {NewH,NewBacc} = complete1(H,Acc,Bacc), + complete1(T,NewH,NewBacc); + + complete1([{octets,Bin}|T],Acc,[]) -> + complete1(T,[Acc|Bin],[]); + + complete1([{octets,Bin}|T],Acc,Bacc) -> + complete1(T,[Acc|[complete_bytes(Bacc),Bin]],[]); + + complete1([{debug,_}|T], Acc,Bacc) -> + complete1(T,Acc,Bacc); + + complete1([{bits,N,Val}|T],Acc,Bacc) -> + complete1(T,Acc,complete_update_byte(Bacc,Val,N)); + + complete1([{bit,Val}|T],Acc,Bacc) -> + complete1(T,Acc,complete_update_byte(Bacc,Val,1)); + + complete1([align|T],Acc,[]) -> + complete1(T,Acc,[]); + complete1([align|T],Acc,Bacc) -> + complete1(T,[Acc|complete_bytes(Bacc)],[]); + complete1([{0,Bin}|T],Acc,[]) when binary(Bin) -> + complete1(T,[Acc|Bin],[]); + complete1([{Unused,Bin}|T],Acc,[]) when integer(Unused),binary(Bin) -> + Size = size(Bin)-1, + <<Bs:Size/binary,B>> = Bin, + NumBits = 8-Unused, + complete1(T,[Acc|Bs],[[B bsr Unused]|NumBits]); + complete1([{Unused,Bin}|T],Acc,Bacc) when integer(Unused),binary(Bin) -> + Size = size(Bin)-1, + <<Bs:Size/binary,B>> = Bin, + NumBits = 8 - Unused, + Bf = complete_bytes(Bacc), + complete1(T,[Acc|[Bf,Bs]],[[B bsr Unused]|NumBits]). + + + complete_update_byte([],Val,Len) -> + complete_update_byte([[0]|0],Val,Len); + complete_update_byte([[Byte|Bacc]|NumBits],Val,Len) when NumBits + Len == 8 -> + [[0,((Byte bsl Len) + Val) band 255|Bacc]|0]; + complete_update_byte([[Byte|Bacc]|NumBits],Val,Len) when NumBits + Len > 8 -> + Rem = 8 - NumBits, + Rest = Len - Rem, + complete_update_byte([[0,((Byte bsl Rem) + (Val bsr Rest)) band 255 |Bacc]|0],Val,Rest); + complete_update_byte([[Byte|Bacc]|NumBits],Val,Len) -> + [[((Byte bsl Len) + Val) band 255|Bacc]|NumBits+Len]. + + + complete_bytes([[Byte|Bacc]|0]) -> + lists:reverse(Bacc); + complete_bytes([[Byte|Bacc]|NumBytes]) -> + lists:reverse([(Byte bsl (8-NumBytes)) band 255|Bacc]); + complete_bytes([]) -> + []. + +-else. + + + complete(L) -> + case catch port_control(drv_complete,1,L) of + Bin when binary(Bin) -> + Bin; + List when list(List) -> handle_error(List,L); + {'EXIT',{badarg,Reason}} -> + asn1rt_driver_handler:load_driver(), + receive + driver_ready -> + case catch port_control(drv_complete,1,L) of + Bin2 when binary(Bin2) -> Bin2; + List when list(List) -> handle_error(List,L); + Error -> exit(Error) + end; + {error,Error} -> % error when loading driver + %% the driver could not be loaded + exit(Error); + Error={port_error,Reason} -> + exit(Error) + end; + {'EXIT',Reason} -> + exit(Reason) + end. + +handle_error([],_)-> + exit({error,{"memory allocation problem"}}); +handle_error("1",L) -> % error in complete in driver + exit({error,{asn1_error,L}}); +handle_error(ErrL,L) -> + exit({error,{unknown_error,ErrL,L}}). + +-endif. + + +octets_to_complete(Len,Val) when Len < 256 -> + [20,Len,Val]; +octets_to_complete(Len,Val) -> + [21,<<Len:16>>,Val]. + +octets_unused_to_complete(Unused,Len,Val) when Len < 256 -> + [30,Unused,Len,Val]; +octets_unused_to_complete(Unused,Len,Val) -> + [31,Unused,<<Len:16>>,Val]. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_per_v1.erl b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_per_v1.erl new file mode 100644 index 0000000000..90ffb0cb1c --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_per_v1.erl @@ -0,0 +1,1827 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: asn1rt_per_v1.erl,v 1.1 2008/12/17 09:53:31 mikpe Exp $ +%% +-module(asn1rt_per_v1). + +%% encoding / decoding of PER aligned + +-include("asn1_records.hrl"). + +-export([dec_fixup/3, cindex/3, list_to_record/2]). +-export([setchoiceext/1, setext/1, fixoptionals/2, fixextensions/2, + setoptionals/1, fixoptionals2/3, getext/1, getextension/2, + skipextensions/3, getbit/1, getchoice/3 ]). +-export([getoptionals/2, getoptionals/3, set_choice/3, + getoptionals2/2, + encode_integer/2, encode_integer/3 ]). +-export([decode_integer/2, decode_integer/3, encode_small_number/1, + encode_boolean/1, decode_boolean/1, encode_length/2, + decode_length/1, decode_length/2, + encode_small_length/1, decode_small_length/1, + decode_compact_bit_string/3]). +-export([encode_enumerated/3, decode_enumerated/3, + encode_bit_string/3, decode_bit_string/3 ]). +-export([encode_octet_string/2, decode_octet_string/2, + encode_null/1, decode_null/1, + encode_object_identifier/1, decode_object_identifier/1, + complete/1]). + +-export([encode_open_type/2, decode_open_type/2]). + +-export([encode_UniversalString/2, decode_UniversalString/2, + encode_PrintableString/2, decode_PrintableString/2, + encode_GeneralString/2, decode_GeneralString/2, + encode_GraphicString/2, decode_GraphicString/2, + encode_TeletexString/2, decode_TeletexString/2, + encode_VideotexString/2, decode_VideotexString/2, + encode_VisibleString/2, decode_VisibleString/2, + encode_BMPString/2, decode_BMPString/2, + encode_IA5String/2, decode_IA5String/2, + encode_NumericString/2, decode_NumericString/2, + encode_ObjectDescriptor/2, decode_ObjectDescriptor/1 + ]). + + +dec_fixup(Terms,Cnames,RemBytes) -> + dec_fixup(Terms,Cnames,RemBytes,[]). + +dec_fixup([novalue|T],[_Hc|Tc],RemBytes,Acc) -> + dec_fixup(T,Tc,RemBytes,Acc); +dec_fixup([{_Name,novalue}|T],[_Hc|Tc],RemBytes,Acc) -> + dec_fixup(T,Tc,RemBytes,Acc); +dec_fixup([H|T],[Hc|Tc],RemBytes,Acc) -> + dec_fixup(T,Tc,RemBytes,[{Hc,H}|Acc]); +dec_fixup([],_Cnames,RemBytes,Acc) -> + {lists:reverse(Acc),RemBytes}. + +cindex(Ix,Val,Cname) -> + case element(Ix,Val) of + {Cname,Val2} -> Val2; + X -> X + end. + +% converts a list to a record if necessary +list_to_record(Name,List) when list(List) -> + list_to_tuple([Name|List]); +list_to_record(_Name,Tuple) when tuple(Tuple) -> + Tuple. + +%%-------------------------------------------------------- +%% setchoiceext(InRootSet) -> [{bit,X}] +%% X is set to 1 when InRootSet==false +%% X is set to 0 when InRootSet==true +%% +setchoiceext(true) -> + [{debug,choiceext},{bit,0}]; +setchoiceext(false) -> + [{debug,choiceext},{bit,1}]. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% setext(true|false) -> CompleteList +%% + +setext(true) -> + [{debug,ext},{bit,1}]; +setext(false) -> + [{debug,ext},{bit,0}]. + +%% + +fixoptionals2(OptList,OptLength,Val) when tuple(Val) -> + Bits = fixoptionals2(OptList,Val,0), + {Val,{bits,OptLength,Bits}}; + +fixoptionals2([],_Val,Acc) -> + %% Optbits + Acc; +fixoptionals2([Pos|Ot],Val,Acc) -> + case element(Pos,Val) of + asn1_NOVALUE -> fixoptionals2(Ot,Val,Acc bsl 1); + asn1_DEFAULT -> fixoptionals2(Ot,Val,Acc bsl 1); + _ -> fixoptionals2(Ot,Val,(Acc bsl 1) + 1) + end. + + +%% +%% fixoptionals remains only for backward compatibility purpose +fixoptionals(OptList,Val) when tuple(Val) -> + fixoptionals(OptList,Val,[]); + +fixoptionals(OptList,Val) when list(Val) -> + fixoptionals(OptList,Val,1,[],[]). + +fixoptionals([],Val,Acc) -> + % return {Val,Opt} + {Val,lists:reverse(Acc)}; +fixoptionals([{_,Pos}|Ot],Val,Acc) -> + case element(Pos+1,Val) of + asn1_NOVALUE -> fixoptionals(Ot,Val,[0|Acc]); + asn1_DEFAULT -> fixoptionals(Ot,Val,[0|Acc]); + _ -> fixoptionals(Ot,Val,[1|Acc]) + end. + + +%setoptionals(OptList,Val) -> +% Vlist = tuple_to_list(Val), +% setoptionals(OptList,Vlist,1,[]). + +fixoptionals([{Name,Pos}|Ot],[{Name,Val}|Vt],_Opt,Acc1,Acc2) -> + fixoptionals(Ot,Vt,Pos+1,[1|Acc1],[{Name,Val}|Acc2]); +fixoptionals([{_Name,Pos}|Ot],V,Pos,Acc1,Acc2) -> + fixoptionals(Ot,V,Pos+1,[0|Acc1],[asn1_NOVALUE|Acc2]); +fixoptionals(O,[Vh|Vt],Pos,Acc1,Acc2) -> + fixoptionals(O,Vt,Pos+1,Acc1,[Vh|Acc2]); +fixoptionals([],[Vh|Vt],Pos,Acc1,Acc2) -> + fixoptionals([],Vt,Pos+1,Acc1,[Vh|Acc2]); +fixoptionals([],[],_,Acc1,Acc2) -> + % return {Val,Opt} + {list_to_tuple([asn1_RECORDNAME|lists:reverse(Acc2)]),lists:reverse(Acc1)}. + +setoptionals([H|T]) -> + [{bit,H}|setoptionals(T)]; +setoptionals([]) -> + [{debug,optionals}]. + +getext(Bytes) when tuple(Bytes) -> + getbit(Bytes); +getext(Bytes) when list(Bytes) -> + getbit({0,Bytes}). + +getextension(0, Bytes) -> + {{},Bytes}; +getextension(1, Bytes) -> + {Len,Bytes2} = decode_small_length(Bytes), + {Blist, Bytes3} = getbits_as_list(Len,Bytes2), + {list_to_tuple(Blist),Bytes3}. + +fixextensions({ext,ExtPos,ExtNum},Val) -> + case fixextensions(ExtPos,ExtNum+ExtPos,Val,0) of + 0 -> []; + ExtBits -> + [encode_small_length(ExtNum),{bits,ExtNum,ExtBits}] + end. + +fixextensions(Pos,MaxPos,_,Acc) when Pos >= MaxPos -> + Acc; +fixextensions(Pos,ExtPos,Val,Acc) -> + Bit = case catch(element(Pos+1,Val)) of + asn1_NOVALUE -> + 0; + asn1_NOEXTVALUE -> + 0; + {'EXIT',_} -> + 0; + _ -> + 1 + end, + fixextensions(Pos+1,ExtPos,Val,(Acc bsl 1)+Bit). + +skipextensions(Bytes,Nr,ExtensionBitPattern) -> + case (catch element(Nr,ExtensionBitPattern)) of + 1 -> + {_,Bytes2} = decode_open_type(Bytes,[]), + skipextensions(Bytes2, Nr+1, ExtensionBitPattern); + 0 -> + skipextensions(Bytes, Nr+1, ExtensionBitPattern); + {'EXIT',_} -> % badarg, no more extensions + Bytes + end. + + +getchoice(Bytes,1,0) -> % only 1 alternative is not encoded + {0,Bytes}; +getchoice(Bytes,_NumChoices,1) -> + decode_small_number(Bytes); +getchoice(Bytes,NumChoices,0) -> + decode_integer(Bytes,[{'ValueRange',{0,NumChoices-1}}]). + +getoptionals2(Bytes,NumOpt) -> + getbits(Bytes,NumOpt). + +%% getoptionals is kept only for bakwards compatibility +getoptionals(Bytes,NumOpt) -> + {Blist,Bytes1} = getbits_as_list(NumOpt,Bytes), + {list_to_tuple(Blist),Bytes1}. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% getoptionals/3 is only here for compatibility from 1.3.2 +%% the codegenerator uses getoptionals/2 + +getoptionals(Bytes,L,NumComp) when list(L) -> + {Blist,Bytes1} = getbits_as_list(length(L),Bytes), + {list_to_tuple(comptuple(Blist,L,NumComp,1)),Bytes1}. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% comptuple is only here for compatibility not used from 1.3.2 +comptuple([Bh|Bt],[{_Name,Nr}|T],NumComp,Nr) -> + [Bh|comptuple(Bt,T,NumComp-1,Nr+1)]; +comptuple(Bl,[{Name,Tnr}|Tl],NumComp,Nr) -> + [0|comptuple(Bl,[{Name,Tnr}|Tl],NumComp-1,Nr+1)]; +comptuple(_B,_L,0,_Nr) -> + []; +comptuple(B,O,N,Nr) -> + [0|comptuple(B,O,N-1,Nr+1)]. + +%% getbits_as_binary(Num,Bytes) -> {{Unused,BinBits},RestBytes}, +%% Num = integer(), +%% Bytes = list() | tuple(), +%% Unused = integer(), +%% BinBits = binary(), +%% RestBytes = tuple() +getbits_as_binary(Num,Bytes) when list(Bytes) -> + getbits_as_binary(Num,{0,Bytes}); +getbits_as_binary(_Num,{Used,[]}) -> + {{0,<<>>},{Used,[]}}; +getbits_as_binary(Num,{Used,Bits=[H|T]}) -> + B1 = case (Num+Used) =< 8 of + true -> Num; + _ -> 8-Used + end, + B2 = Num - B1, + Pad = (8 - ((B1+B2) rem 8)) rem 8,% Pad /= 8 + RestBits = lists:nthtail((B1+B2) div 8,Bits), + Int = integer_from_list(B2,T,0), + NewUsed = (Used + Num) rem 8, + {{Pad,<<(H bsr (8-(Used+B1))):B1,Int:B2,0:Pad>>},{NewUsed,RestBits}}. + +integer_from_list(_Int,[],BigInt) -> + BigInt; +integer_from_list(Int,[H|_T],BigInt) when Int < 8 -> + (BigInt bsl Int) bor (H bsr (8-Int)); +integer_from_list(Int,[H|T],BigInt) -> + integer_from_list(Int-8,T,(BigInt bsl 8) bor H). + +getbits_as_list(Num,Bytes) -> + getbits_as_list(Num,Bytes,[]). + +getbits_as_list(0,Bytes,Acc) -> + {lists:reverse(Acc),Bytes}; +getbits_as_list(Num,Bytes,Acc) -> + {Bit,NewBytes} = getbit(Bytes), + getbits_as_list(Num-1,NewBytes,[Bit|Acc]). + +getbit(Bytes) -> +% io:format("getbit:~p~n",[Bytes]), + getbit1(Bytes). + +getbit1({7,[H|T]}) -> + {H band 1,{0,T}}; +getbit1({Pos,[H|T]}) -> + {(H bsr (7-Pos)) band 1,{(Pos+1) rem 8,[H|T]}}; +getbit1(Bytes) when list(Bytes) -> + getbit1({0,Bytes}). + +%% This could be optimized +getbits(Buffer,Num) -> +% io:format("getbits:Buffer = ~p~nNum=~p~n",[Buffer,Num]), + getbits(Buffer,Num,0). + +getbits(Buffer,0,Acc) -> + {Acc,Buffer}; +getbits(Buffer,Num,Acc) -> + {B,NewBuffer} = getbit(Buffer), + getbits(NewBuffer,Num-1,B + (Acc bsl 1)). + + +getoctet(Bytes) when list(Bytes) -> + getoctet({0,Bytes}); +getoctet(Bytes) -> +% io:format("getoctet:Buffer = ~p~n",[Bytes]), + getoctet1(Bytes). + +getoctet1({0,[H|T]}) -> + {H,{0,T}}; +getoctet1({_Pos,[_,H|T]}) -> + {H,{0,T}}. + +align({0,L}) -> + {0,L}; +align({_Pos,[_H|T]}) -> + {0,T}; +align(Bytes) -> + {0,Bytes}. + +getoctets(Buffer,Num) -> +% io:format("getoctets:Buffer = ~p~nNum = ~p~n",[Buffer,Num]), + getoctets(Buffer,Num,0). + +getoctets(Buffer,0,Acc) -> + {Acc,Buffer}; +getoctets(Buffer,Num,Acc) -> + {Oct,NewBuffer} = getoctet(Buffer), + getoctets(NewBuffer,Num-1,(Acc bsl 8)+Oct). + +getoctets_as_list(Buffer,Num) -> + getoctets_as_list(Buffer,Num,[]). + +getoctets_as_list(Buffer,0,Acc) -> + {lists:reverse(Acc),Buffer}; +getoctets_as_list(Buffer,Num,Acc) -> + {Oct,NewBuffer} = getoctet(Buffer), + getoctets_as_list(NewBuffer,Num-1,[Oct|Acc]). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% set_choice(Alt,Choices,Altnum) -> ListofBitSettings +%% Alt = atom() +%% Altnum = integer() | {integer(),integer()}% number of alternatives +%% Choices = [atom()] | {[atom()],[atom()]} +%% When Choices is a tuple the first list is the Rootset and the +%% second is the Extensions and then Altnum must also be a tuple with the +%% lengths of the 2 lists +%% +set_choice(Alt,{L1,L2},{Len1,_Len2}) -> + case set_choice_tag(Alt,L1) of + N when integer(N), Len1 > 1 -> + [{bit,0}, % the value is in the root set + encode_integer([{'ValueRange',{0,Len1-1}}],N)]; + N when integer(N) -> + [{bit,0}]; % no encoding if only 0 or 1 alternative + false -> + [{bit,1}, % extension value + case set_choice_tag(Alt,L2) of + N2 when integer(N2) -> + encode_small_number(N2); + false -> + unknown_choice_alt + end] + end; +set_choice(Alt,L,Len) -> + case set_choice_tag(Alt,L) of + N when integer(N), Len > 1 -> + encode_integer([{'ValueRange',{0,Len-1}}],N); + N when integer(N) -> + []; % no encoding if only 0 or 1 alternative + false -> + [unknown_choice_alt] + end. + +set_choice_tag(Alt,Choices) -> + set_choice_tag(Alt,Choices,0). + +set_choice_tag(Alt,[Alt|_Rest],Tag) -> + Tag; +set_choice_tag(Alt,[_H|Rest],Tag) -> + set_choice_tag(Alt,Rest,Tag+1); +set_choice_tag(_Alt,[],_Tag) -> + false. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% encode_open_type(Constraint, Value) -> CompleteList +%% Value = list of bytes of an already encoded value (the list must be flat) +%% | binary +%% Contraint = not used in this version +%% +encode_open_type(_Constraint, Val) when list(Val) -> + [encode_length(undefined,length(Val)),align, + {octets,Val}]; +encode_open_type(_Constraint, Val) when binary(Val) -> + [encode_length(undefined,size(Val)),align, + {octets,binary_to_list(Val)}]. +%% the binary_to_list is not optimal but compatible with the current solution + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% decode_open_type(Buffer,Constraint) -> Value +%% Constraint is not used in this version +%% Buffer = [byte] with PER encoded data +%% Value = [byte] with decoded data (which must be decoded again as some type) +%% +decode_open_type(Bytes, _Constraint) -> + {Len,Bytes2} = decode_length(Bytes,undefined), + Bytes3 = align(Bytes2), + getoctets_as_list(Bytes3,Len). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% encode_integer(Constraint,Value,NamedNumberList) -> CompleteList +%% encode_integer(Constraint,Value) -> CompleteList +%% encode_integer(Constraint,{Name,Value}) -> CompleteList +%% +%% +encode_integer(C,V,NamedNumberList) when atom(V) -> + case lists:keysearch(V,1,NamedNumberList) of + {value,{_,NewV}} -> + encode_integer(C,NewV); + _ -> + exit({error,{asn1,{namednumber,V}}}) + end; +encode_integer(C,V,_) when integer(V) -> + encode_integer(C,V); +encode_integer(C,{Name,V},NamedNumberList) when atom(Name) -> + encode_integer(C,V,NamedNumberList). + +encode_integer(C,{Name,Val}) when atom(Name) -> + encode_integer(C,Val); + +encode_integer({Rc,_Ec},Val) -> + case (catch encode_integer(Rc,Val)) of + {'EXIT',{error,{asn1,_}}} -> + [{bit,1},encode_unconstrained_number(Val)]; + Encoded -> + [{bit,0},Encoded] + end; +encode_integer(C,Val ) when list(C) -> + case get_constraint(C,'SingleValue') of + no -> + encode_integer1(C,Val); + V when integer(V),V == Val -> + []; % a type restricted to a single value encodes to nothing + V when list(V) -> + case lists:member(Val,V) of + true -> + encode_integer1(C,Val); + _ -> + exit({error,{asn1,{illegal_value,Val}}}) + end; + _ -> + exit({error,{asn1,{illegal_value,Val}}}) + end. + +encode_integer1(C, Val) -> + case VR = get_constraint(C,'ValueRange') of + no -> + encode_unconstrained_number(Val); + {Lb,'MAX'} -> + encode_semi_constrained_number(Lb,Val); + %% positive with range + {Lb,Ub} when Val >= Lb, + Ub >= Val -> + encode_constrained_number(VR,Val); + _ -> + exit({error,{asn1,{illegal_value,VR,Val}}}) + end. + +decode_integer(Buffer,Range,NamedNumberList) -> + {Val,Buffer2} = decode_integer(Buffer,Range), + case lists:keysearch(Val,2,NamedNumberList) of + {value,{NewVal,_}} -> {NewVal,Buffer2}; + _ -> {Val,Buffer2} + end. + +decode_integer(Buffer,{Rc,_Ec}) -> + {Ext,Buffer2} = getext(Buffer), + case Ext of + 0 -> decode_integer(Buffer2,Rc); + 1 -> decode_unconstrained_number(Buffer2) + end; +decode_integer(Buffer,undefined) -> + decode_unconstrained_number(Buffer); +decode_integer(Buffer,C) -> + case get_constraint(C,'SingleValue') of + V when integer(V) -> + {V,Buffer}; + V when list(V) -> + {Val,Buffer2} = decode_integer1(Buffer,C), + case lists:member(Val,V) of + true -> + {Val,Buffer2}; + _ -> + exit({error,{asn1,{illegal_value,Val}}}) + end; + _ -> + decode_integer1(Buffer,C) + end. + +decode_integer1(Buffer,C) -> + case VR = get_constraint(C,'ValueRange') of + no -> + decode_unconstrained_number(Buffer); + {Lb, 'MAX'} -> + decode_semi_constrained_number(Buffer,Lb); + {_,_} -> + decode_constrained_number(Buffer,VR) + end. + +% X.691:10.6 Encoding of a normally small non-negative whole number +% Use this for encoding of CHOICE index if there is an extension marker in +% the CHOICE +encode_small_number({Name,Val}) when atom(Name) -> + encode_small_number(Val); +encode_small_number(Val) when Val =< 63 -> + [{bit,0},{bits,6,Val}]; +encode_small_number(Val) -> + [{bit,1},encode_semi_constrained_number(0,Val)]. + +decode_small_number(Bytes) -> + {Bit,Bytes2} = getbit(Bytes), + case Bit of + 0 -> + getbits(Bytes2,6); + 1 -> + decode_semi_constrained_number(Bytes2,{0,'MAX'}) + end. + +% X.691:10.7 Encoding of a semi-constrained whole number +%% might be an optimization encode_semi_constrained_number(0,Val) -> +encode_semi_constrained_number(C,{Name,Val}) when atom(Name) -> + encode_semi_constrained_number(C,Val); +encode_semi_constrained_number({Lb,'MAX'},Val) -> + encode_semi_constrained_number(Lb,Val); +encode_semi_constrained_number(Lb,Val) -> + Val2 = Val - Lb, + Octs = eint_positive(Val2), + [encode_length(undefined,length(Octs)),{octets,Octs}]. + +decode_semi_constrained_number(Bytes,{Lb,_}) -> + decode_semi_constrained_number(Bytes,Lb); +decode_semi_constrained_number(Bytes,Lb) -> + {Len,Bytes2} = decode_length(Bytes,undefined), + {V,Bytes3} = getoctets(Bytes2,Len), + {V+Lb,Bytes3}. + +encode_constrained_number(Range,{Name,Val}) when atom(Name) -> + encode_constrained_number(Range,Val); +encode_constrained_number({Lb,Ub},Val) when Val >= Lb, Ub >= Val -> + Range = Ub - Lb + 1, + Val2 = Val - Lb, + if + Range == 2 -> + {bits,1,Val2}; + Range =< 4 -> + {bits,2,Val2}; + Range =< 8 -> + {bits,3,Val2}; + Range =< 16 -> + {bits,4,Val2}; + Range =< 32 -> + {bits,5,Val2}; + Range =< 64 -> + {bits,6,Val2}; + Range =< 128 -> + {bits,7,Val2}; + Range =< 255 -> + {bits,8,Val2}; + Range =< 256 -> + {octets,1,Val2}; + Range =< 65536 -> + {octets,2,Val2}; + Range =< 16#1000000 -> + Octs = eint_positive(Val2), + [encode_length({1,3},length(Octs)),{octets,Octs}]; + Range =< 16#100000000 -> + Octs = eint_positive(Val2), + [encode_length({1,4},length(Octs)),{octets,Octs}]; + Range =< 16#10000000000 -> + Octs = eint_positive(Val2), + [encode_length({1,5},length(Octs)),{octets,Octs}]; + true -> + exit({not_supported,{integer_range,Range}}) + end. + +decode_constrained_number(Buffer,{Lb,Ub}) -> + Range = Ub - Lb + 1, +% Val2 = Val - Lb, + {Val,Remain} = + if + Range == 2 -> + getbits(Buffer,1); + Range =< 4 -> + getbits(Buffer,2); + Range =< 8 -> + getbits(Buffer,3); + Range =< 16 -> + getbits(Buffer,4); + Range =< 32 -> + getbits(Buffer,5); + Range =< 64 -> + getbits(Buffer,6); + Range =< 128 -> + getbits(Buffer,7); + Range =< 255 -> + getbits(Buffer,8); + Range =< 256 -> + getoctets(Buffer,1); + Range =< 65536 -> + getoctets(Buffer,2); + Range =< 16#1000000 -> + {Len,Bytes2} = decode_length(Buffer,{1,3}), + {Octs,Bytes3} = getoctets_as_list(Bytes2,Len), + {dec_pos_integer(Octs),Bytes3}; + Range =< 16#100000000 -> + {Len,Bytes2} = decode_length(Buffer,{1,4}), + {Octs,Bytes3} = getoctets_as_list(Bytes2,Len), + {dec_pos_integer(Octs),Bytes3}; + Range =< 16#10000000000 -> + {Len,Bytes2} = decode_length(Buffer,{1,5}), + {Octs,Bytes3} = getoctets_as_list(Bytes2,Len), + {dec_pos_integer(Octs),Bytes3}; + true -> + exit({not_supported,{integer_range,Range}}) + end, + {Val+Lb,Remain}. + +% X.691:10.8 Encoding of an unconstrained whole number + +encode_unconstrained_number(Val) when Val >= 0 -> + Oct = eint(Val,[]), + [{debug,unconstrained_number}, + encode_length({0,'MAX'},length(Oct)), + {octets,Oct}]; +encode_unconstrained_number(Val) -> % negative + Oct = enint(Val,[]), + [{debug,unconstrained_number}, + encode_length({0,'MAX'},length(Oct)), + {octets,Oct}]. + +%% used for positive Values which don't need a sign bit +eint_positive(Val) -> + case eint(Val,[]) of + [0,B1|T] -> + [B1|T]; + T -> + T + end. + +eint(0, [B|Acc]) when B < 128 -> + [B|Acc]; +eint(N, Acc) -> + eint(N bsr 8, [N band 16#ff| Acc]). + +enint(-1, [B1|T]) when B1 > 127 -> + [B1|T]; +enint(N, Acc) -> + enint(N bsr 8, [N band 16#ff|Acc]). + +%% used for signed positive values + +%eint(Val, Ack) -> +% X = Val band 255, +% Next = Val bsr 8, +% if +% Next == 0, X >= 127 -> +% [0,X|Ack]; +% Next == 0 -> +% [X|Ack]; +% true -> +% eint(Next,[X|Ack]) +% end. + +%%% used for signed negative values +%enint(Val, Acc) -> +% NumOctets = if +% -Val < 16#80 -> 1; +% -Val < 16#8000 ->2; +% -Val < 16#800000 ->3; +% -Val < 16#80000000 ->4; +% -Val < 16#8000000000 ->5; +% -Val < 16#800000000000 ->6; +% -Val < 16#80000000000000 ->7; +% -Val < 16#8000000000000000 ->8; +% -Val < 16#800000000000000000 ->9 +% end, +% enint(Val,Acc,NumOctets). + +%enint(Val, Acc,0) -> +% Acc; +%enint(Val, Acc,NumOctets) -> +% enint(Val bsr 8,[Val band 255|Acc],NumOctets-1). + + +decode_unconstrained_number(Bytes) -> + {Len,Bytes2} = decode_length(Bytes,undefined), + {Ints,Bytes3} = getoctets_as_list(Bytes2,Len), + {dec_integer(Ints),Bytes3}. + +dec_pos_integer(Ints) -> + decpint(Ints, 8 * (length(Ints) - 1)). +dec_integer(Ints) when hd(Ints) band 255 =< 127 -> %% Positive number + decpint(Ints, 8 * (length(Ints) - 1)); +dec_integer(Ints) -> %% Negative + decnint(Ints, 8 * (length(Ints) - 1)). + +decpint([Byte|Tail], Shift) -> + (Byte bsl Shift) bor decpint(Tail, Shift-8); +decpint([], _) -> 0. + +decnint([Byte|Tail], Shift) -> + (-128 + (Byte band 127) bsl Shift) bor decpint(Tail, Shift-8). + +minimum_octets(Val) -> + minimum_octets(Val,[]). + +minimum_octets(Val,Acc) when Val > 0 -> + minimum_octets((Val bsr 8),[Val band 16#FF|Acc]); +minimum_octets(0,Acc) -> + Acc. + + +%% X.691:10.9 Encoding of a length determinant +%%encode_small_length(undefined,Len) -> % null means no UpperBound +%% encode_small_number(Len). + +%% X.691:10.9.3.5 +%% X.691:10.9.3.7 +encode_length(undefined,Len) -> % un-constrained + if + Len < 128 -> + {octet,Len band 16#7F}; + Len < 16384 -> + {octets,2,2#1000000000000000 bor Len}; + true -> + exit({error,{asn1,{encode_length,{nyi,above_16k}}}}) + end; + +encode_length({0,'MAX'},Len) -> + encode_length(undefined,Len); +encode_length({Lb,Ub},Len) when Ub =< 65535 ,Lb >= 0 -> % constrained + encode_constrained_number({Lb,Ub},Len); +encode_length({{Lb,Ub},[]},Len) when Ub =< 65535 ,Lb >= 0 -> + %% constrained extensible + [{bit,0},encode_constrained_number({Lb,Ub},Len)]; +encode_length(SingleValue,_) when integer(SingleValue) -> + []. + +encode_small_length(Len) when Len =< 64 -> + [{bit,0},{bits,6,Len-1}]; +encode_small_length(Len) -> + [{bit,1},encode_length(undefined,Len)]. + +decode_small_length(Buffer) -> + case getbit(Buffer) of + {0,Remain} -> + {Bits,Remain2} = getbits(Remain,6), + {Bits+1,Remain2}; + {1,Remain} -> + decode_length(Remain,undefined) + end. + +decode_length(Buffer) -> + decode_length(Buffer,undefined). + +decode_length(Buffer,undefined) -> % un-constrained + Buffer2 = align(Buffer), + {Bits,_} = getbits(Buffer2,2), + case Bits of + 2 -> + {Val,Bytes3} = getoctets(Buffer2,2), + {(Val band 16#3FFF),Bytes3}; + 3 -> + exit({error,{asn1,{decode_length,{nyi,above_16k}}}}); + _ -> + {Val,Bytes3} = getoctet(Buffer2), + {Val band 16#7F,Bytes3} + end; + +decode_length(Buffer,{Lb,Ub}) when Ub =< 65535 ,Lb >= 0 -> % constrained + decode_constrained_number(Buffer,{Lb,Ub}); + +decode_length(Buffer,{{Lb,Ub},[]}) -> + case getbit(Buffer) of + {0,Buffer2} -> + decode_length(Buffer2, {Lb,Ub}) + end; + % X.691:10.9.3.5 +decode_length(Buffer,{_,_Lb,_Ub}) -> %when Len =< 127 -> % Unconstrained or large Ub + case getbit(Buffer) of + {0,Remain} -> + getbits(Remain,7); + {1,_Remain} -> + {Val,Remain2} = getoctets(Buffer,2), + {Val band 2#0111111111111111, Remain2} + end; +decode_length(Buffer,SingleValue) when integer(SingleValue) -> + {SingleValue,Buffer}. + + +% X.691:11 +encode_boolean({Name,Val}) when atom(Name) -> + encode_boolean(Val); +encode_boolean(true) -> + {bit,1}; +encode_boolean(false) -> + {bit,0}; +encode_boolean(Val) -> + exit({error,{asn1,{encode_boolean,Val}}}). + + +decode_boolean(Buffer) -> %when record(Buffer,buffer) + case getbit(Buffer) of + {1,Remain} -> {true,Remain}; + {0,Remain} -> {false,Remain} + end. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% X.691:12 +%% ENUMERATED +%% +%% encode_enumerated(C,Value,NamedNumberTup) -> CompleteList +%% +%% + +encode_enumerated(C,{Name,Value},NamedNumberList) when + atom(Name),list(NamedNumberList) -> + encode_enumerated(C,Value,NamedNumberList); + +%% ENUMERATED with extension mark +encode_enumerated(_C,{asn1_enum,Value},{_Nlist1,Nlist2}) when Value >= length(Nlist2) -> + [{bit,1},encode_small_number(Value)]; +encode_enumerated(C,Value,{Nlist1,Nlist2}) -> + case enum_search(Value,Nlist1,0) of + NewV when integer(NewV) -> + [{bit,0},encode_integer(C,NewV)]; + false -> + case enum_search(Value,Nlist2,0) of + ExtV when integer(ExtV) -> + [{bit,1},encode_small_number(ExtV)]; + false -> + exit({error,{asn1,{encode_enumerated,Value}}}) + end + end; + +encode_enumerated(C,Value,NamedNumberList) when list(NamedNumberList) -> + case enum_search(Value,NamedNumberList,0) of + NewV when integer(NewV) -> + encode_integer(C,NewV); + false -> + exit({error,{asn1,{encode_enumerated,Value}}}) + end. + +%% returns the ordinal number from 0 ,1 ... in the list where Name is found +%% or false if not found +%% +enum_search(Name,[Name|_NamedNumberList],Acc) -> + Acc; +enum_search(Name,[_H|T],Acc) -> + enum_search(Name,T,Acc+1); +enum_search(_,[],_) -> + false. % name not found !error + +%% ENUMERATED with extension marker +decode_enumerated(Buffer,C,{Ntup1,Ntup2}) when tuple(Ntup1), tuple(Ntup2) -> + {Ext,Buffer2} = getext(Buffer), + case Ext of + 0 -> % not an extension value + {Val,Buffer3} = decode_integer(Buffer2,C), + case catch (element(Val+1,Ntup1)) of + NewVal when atom(NewVal) -> {NewVal,Buffer3}; + _Error -> exit({error,{asn1,{decode_enumerated,{Val,[Ntup1,Ntup2]}}}}) + end; + 1 -> % this an extension value + {Val,Buffer3} = decode_small_number(Buffer2), + case catch (element(Val+1,Ntup2)) of + NewVal when atom(NewVal) -> {NewVal,Buffer3}; + _ -> {{asn1_enum,Val},Buffer3} + end + end; + +decode_enumerated(Buffer,C,NamedNumberTup) when tuple(NamedNumberTup) -> + {Val,Buffer2} = decode_integer(Buffer,C), + case catch (element(Val+1,NamedNumberTup)) of + NewVal when atom(NewVal) -> {NewVal,Buffer2}; + _Error -> exit({error,{asn1,{decode_enumerated,{Val,NamedNumberTup}}}}) + end. + +%%=============================================================================== +%%=============================================================================== +%%=============================================================================== +%% Bitstring value, ITU_T X.690 Chapter 8.5 +%%=============================================================================== +%%=============================================================================== +%%=============================================================================== + +%%=============================================================================== +%% encode bitstring value +%%=============================================================================== + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% bitstring NamedBitList +%% Val can be of: +%% - [identifiers] where only named identifers are set to one, +%% the Constraint must then have some information of the +%% bitlength. +%% - [list of ones and zeroes] all bits +%% - integer value representing the bitlist +%% C is constraint Len, only valid when identifiers + + +%% when the value is a list of {Unused,BinBits}, where +%% Unused = integer(), +%% BinBits = binary(). +encode_bit_string(C,Bin={Unused,BinBits},NamedBitList) when integer(Unused), + binary(BinBits) -> + encode_bin_bit_string(C,Bin,NamedBitList); + +%% when the value is a list of named bits +encode_bit_string(C, [FirstVal | RestVal], NamedBitList) when atom(FirstVal) -> + ToSetPos = get_all_bitposes([FirstVal | RestVal], NamedBitList, []), + BitList = make_and_set_list(ToSetPos,0), + encode_bit_string(C,BitList,NamedBitList); + +encode_bit_string(C, [{bit,No} | RestVal], NamedBitList) -> + ToSetPos = get_all_bitposes([{bit,No} | RestVal], NamedBitList, []), + BitList = make_and_set_list(ToSetPos,0), + encode_bit_string(C,BitList,NamedBitList); + +%% when the value is a list of ones and zeroes + +encode_bit_string(C, BitListValue, NamedBitList) when list(BitListValue) -> + Bl1 = + case NamedBitList of + [] -> % dont remove trailing zeroes + BitListValue; + _ -> % first remove any trailing zeroes + lists:reverse(lists:dropwhile(fun(0)->true;(1)->false end, + lists:reverse(BitListValue))) + end, + BitList = [{bit,X} || X <- Bl1], + BListLen = length(BitList), + case get_constraint(C,'SizeConstraint') of + 0 -> % fixed length + []; % nothing to encode + V when integer(V),V=<16 -> % fixed length 16 bits or less + pad_list(V,BitList); + V when integer(V) -> % fixed length 16 bits or less + [align,pad_list(V,BitList)]; + {Lb,Ub} when integer(Lb),integer(Ub),BListLen<Lb -> + %% padding due to OTP-4353 + [encode_length({Lb,Ub},Lb),align,pad_list(Lb,BitList)]; + {Lb,Ub} when integer(Lb),integer(Ub) -> + [encode_length({Lb,Ub},length(BitList)),align,BitList]; + no -> + [encode_length(undefined,length(BitList)),align,BitList]; + Sc={{Lb,Ub},_} when integer(Lb),integer(Ub),BListLen<Lb -> + %% padding due to OTP-4353 + [encode_length(Sc,Lb),align,pad_list(Lb,BitList)]; + Sc -> % extension marker + [encode_length(Sc,length(BitList)),align,BitList] + end; + +%% when the value is an integer +encode_bit_string(C, IntegerVal, NamedBitList) when integer(IntegerVal)-> + BitList = int_to_bitlist(IntegerVal), + encode_bit_string(C,BitList,NamedBitList); + +%% when the value is a tuple +encode_bit_string(C,{Name,Val}, NamedBitList) when atom(Name) -> + encode_bit_string(C,Val,NamedBitList). + + +%% encode_bin_bit_string/3, when value is a tuple of Unused and BinBits. +%% Unused = integer(), +%% BinBits = binary(). + +encode_bin_bit_string(C,{Unused,BinBits},NamedBitList) -> + RemoveZerosIfNNL = + fun({NNL,BitList}) -> + case NNL of + [] -> BitList; + _ -> + lists:reverse( + lists:dropwhile(fun(0)->true;(1)->false end, + lists:reverse(BitList))) + end + end, + {OctetList,OLSize,LastBits} = + case size(BinBits) of + N when N>1 -> + IntList = binary_to_list(BinBits), + [H|T] = lists:reverse(IntList), + Bl1 = RemoveZerosIfNNL({NamedBitList,lists:reverse(int_to_bitlist(H,8-Unused))}),% lists:sublist obsolete if trailing bits are zero ! + {[{octet,X} || X <- lists:reverse(T)],size(BinBits)-1, + [{bit,X} || X <- Bl1]}; + 1 -> + <<B7:1,B6:1,B5:1,B4:1,B3:1,B2:1,B1:1,B0:1>> = BinBits, + {[],0,[{bit,X} || X <- lists:sublist([B7,B6,B5,B4,B3,B2,B1,B0],8-Unused)]}; + _ -> + {[],0,[]} + end, + case get_constraint(C,'SizeConstraint') of + 0 -> + []; + V when integer(V),V=<16 -> + [OctetList, pad_list(V,LastBits)]; + V when integer(V) -> +% [OctetList, align, pad_list(V rem 8,LastBits)]; + [align,OctetList, pad_list(V rem 8,LastBits)]; + {Lb,Ub} when integer(Lb),integer(Ub) -> + NewLastBits = maybe_pad(Lb,length(LastBits)+(OLSize*8),LastBits,NamedBitList), + [encode_length({Lb,Ub},length(NewLastBits)+(OLSize*8)), +% OctetList,align,LastBits]; + align,OctetList,NewLastBits]; + no -> + [encode_length(undefined,length(LastBits)+(OLSize*8)), +% OctetList,align,LastBits]; + align,OctetList,LastBits]; + Sc={{Lb,_},_} when integer(Lb) -> + NewLastBits = maybe_pad(Lb,length(LastBits)+(OLSize*8),LastBits,NamedBitList), + [encode_length(Sc,length(NewLastBits)+(OLSize*8)), + align,OctetList,NewLastBits]; + Sc -> + [encode_length(Sc,length(LastBits)+(OLSize*8)), +% OctetList,align,LastBits] + align,OctetList,LastBits] + end. + +maybe_pad(_,_,Bits,[]) -> + Bits; +maybe_pad(Lb,LenBits,Bits,_) when Lb>LenBits -> + pad_list(Lb,Bits); +maybe_pad(_,_,Bits,_) -> + Bits. + +%%%%%%%%%%%%%%% +%% The result is presented as a list of named bits (if possible) +%% else as a tuple {Unused,Bits}. Unused is the number of unused +%% bits, least significant bits in the last byte of Bits. Bits is +%% the BIT STRING represented as a binary. +%% +decode_compact_bit_string(Buffer, C, NamedNumberList) -> + case get_constraint(C,'SizeConstraint') of + 0 -> % fixed length + {{0,<<>>},Buffer}; + V when integer(V),V=<16 -> %fixed length 16 bits or less + compact_bit_string(Buffer,V,NamedNumberList); + V when integer(V) -> %fixed length > 16 bits + Bytes2 = align(Buffer), + compact_bit_string(Bytes2,V,NamedNumberList); + {Lb,Ub} when integer(Lb),integer(Ub) -> + {Len,Bytes2} = decode_length(Buffer,{Lb,Ub}), + Bytes3 = align(Bytes2), + compact_bit_string(Bytes3,Len,NamedNumberList); + no -> + {Len,Bytes2} = decode_length(Buffer,undefined), + Bytes3 = align(Bytes2), + compact_bit_string(Bytes3,Len,NamedNumberList); + Sc -> + {Len,Bytes2} = decode_length(Buffer,Sc), + Bytes3 = align(Bytes2), + compact_bit_string(Bytes3,Len,NamedNumberList) + end. + + +%%%%%%%%%%%%%%% +%% The result is presented as a list of named bits (if possible) +%% else as a list of 0 and 1. +%% +decode_bit_string(Buffer, C, NamedNumberList) -> + case get_constraint(C,'SizeConstraint') of + 0 -> % fixed length + {[],Buffer}; % nothing to encode + V when integer(V),V=<16 -> % fixed length 16 bits or less + bit_list_to_named(Buffer,V,NamedNumberList); + V when integer(V) -> % fixed length 16 bits or less + Bytes2 = align(Buffer), + bit_list_to_named(Bytes2,V,NamedNumberList); + {Lb,Ub} when integer(Lb),integer(Ub) -> + {Len,Bytes2} = decode_length(Buffer,{Lb,Ub}), + Bytes3 = align(Bytes2), + bit_list_to_named(Bytes3,Len,NamedNumberList); + no -> + {Len,Bytes2} = decode_length(Buffer,undefined), + Bytes3 = align(Bytes2), + bit_list_to_named(Bytes3,Len,NamedNumberList); + Sc -> % extension marker + {Len,Bytes2} = decode_length(Buffer,Sc), + Bytes3 = align(Bytes2), + bit_list_to_named(Bytes3,Len,NamedNumberList) + end. + + +%% if no named bits are declared we will return a +%% {Unused,Bits}. Unused = integer(), +%% Bits = binary(). +compact_bit_string(Buffer,Len,[]) -> + getbits_as_binary(Len,Buffer); % {{Unused,BinBits},NewBuffer} +compact_bit_string(Buffer,Len,NamedNumberList) -> + bit_list_to_named(Buffer,Len,NamedNumberList). + + +%% if no named bits are declared we will return a +%% BitList = [0 | 1] + +bit_list_to_named(Buffer,Len,[]) -> + getbits_as_list(Len,Buffer); + +%% if there are named bits declared we will return a named +%% BitList where the names are atoms and unnamed bits represented +%% as {bit,Pos} +%% BitList = [atom() | {bit,Pos}] +%% Pos = integer() + +bit_list_to_named(Buffer,Len,NamedNumberList) -> + {BitList,Rest} = getbits_as_list(Len,Buffer), + {bit_list_to_named1(0,BitList,NamedNumberList,[]), Rest}. + +bit_list_to_named1(Pos,[0|Bt],Names,Acc) -> + bit_list_to_named1(Pos+1,Bt,Names,Acc); +bit_list_to_named1(Pos,[1|Bt],Names,Acc) -> + case lists:keysearch(Pos,2,Names) of + {value,{Name,_}} -> + bit_list_to_named1(Pos+1,Bt,Names,[Name|Acc]); + _ -> + bit_list_to_named1(Pos+1,Bt,Names,[{bit,Pos}|Acc]) + end; +bit_list_to_named1(_Pos,[],_Names,Acc) -> + lists:reverse(Acc). + + + +%%%%%%%%%%%%%%% +%% + +int_to_bitlist(0) -> + []; +int_to_bitlist(Int) when integer(Int), Int >= 0 -> + [Int band 1 | int_to_bitlist(Int bsr 1)]. + +int_to_bitlist(_Int,0) -> + []; +int_to_bitlist(0,N) -> + [0|int_to_bitlist(0,N-1)]; +int_to_bitlist(Int,N) -> + [Int band 1 | int_to_bitlist(Int bsr 1, N-1)]. + + +%%%%%%%%%%%%%%%%%% +%% get_all_bitposes([list of named bits to set], named_bit_db, []) -> +%% [sorted_list_of_bitpositions_to_set] + +get_all_bitposes([{bit,ValPos}|Rest], NamedBitList, Ack) -> + get_all_bitposes(Rest, NamedBitList, [ValPos | Ack ]); + +get_all_bitposes([Val | Rest], NamedBitList, Ack) -> + case lists:keysearch(Val, 1, NamedBitList) of + {value, {_ValName, ValPos}} -> + get_all_bitposes(Rest, NamedBitList, [ValPos | Ack]); + _ -> + exit({error,{asn1, {bitstring_namedbit, Val}}}) + end; +get_all_bitposes([], _NamedBitList, Ack) -> + lists:sort(Ack). + +%%%%%%%%%%%%%%%%%% +%% make_and_set_list([list of positions to set to 1])-> +%% returns list with all in SetPos set. +%% in positioning in list the first element is 0, the second 1 etc.., but +%% + +make_and_set_list([XPos|SetPos], XPos) -> + [1 | make_and_set_list(SetPos, XPos + 1)]; +make_and_set_list([Pos|SetPos], XPos) -> + [0 | make_and_set_list([Pos | SetPos], XPos + 1)]; +make_and_set_list([], _XPos) -> + []. + +%%%%%%%%%%%%%%%%% +%% pad_list(N,BitList) -> PaddedList +%% returns a padded (with trailing {bit,0} elements) list of length N +%% if Bitlist contains more than N significant bits set an exit asn1_error +%% is generated + +pad_list(0,BitList) -> + case BitList of + [] -> []; + _ -> exit({error,{asn1,{range_error,{bit_string,BitList}}}}) + end; +pad_list(N,[Bh|Bt]) -> + [Bh|pad_list(N-1,Bt)]; +pad_list(N,[]) -> + [{bit,0},pad_list(N-1,[])]. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% X.691:16 +%% encode_octet_string(Constraint,ExtensionMarker,Val) +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +encode_octet_string(C,{Name,Val}) when atom(Name) -> + encode_octet_string(C,false,Val); +encode_octet_string(C,Val) -> + encode_octet_string(C,false,Val). + +encode_octet_string(C,Bool,{_Name,Val}) -> + encode_octet_string(C,Bool,Val); +encode_octet_string(_,true,_) -> + exit({error,{asn1,{'not_supported',extensionmarker}}}); +encode_octet_string(C,false,Val) -> + case get_constraint(C,'SizeConstraint') of + 0 -> + []; + 1 -> + [V] = Val, + {bits,8,V}; + 2 -> + [V1,V2] = Val, + [{bits,8,V1},{bits,8,V2}]; + Sv when Sv =<65535, Sv == length(Val) -> % fixed length + [align,{octets,Val}]; + {Lb,Ub} -> + [encode_length({Lb,Ub},length(Val)),align, + {octets,Val}]; + Sv when list(Sv) -> + [encode_length({hd(Sv),lists:max(Sv)},length(Val)),align, + {octets,Val}]; + no -> + [encode_length(undefined,length(Val)),align, + {octets,Val}] + end. + +decode_octet_string(Bytes,Range) -> + decode_octet_string(Bytes,Range,false). + +decode_octet_string(Bytes,C,false) -> + case get_constraint(C,'SizeConstraint') of + 0 -> + {[],Bytes}; + 1 -> + {B1,Bytes2} = getbits(Bytes,8), + {[B1],Bytes2}; + 2 -> + {B1,Bytes2}= getbits(Bytes,8), + {B2,Bytes3}= getbits(Bytes2,8), + {[B1,B2],Bytes3}; + {_,0} -> + {[],Bytes}; + Sv when integer(Sv), Sv =<65535 -> % fixed length + Bytes2 = align(Bytes), + getoctets_as_list(Bytes2,Sv); + {Lb,Ub} -> + {Len,Bytes2} = decode_length(Bytes,{Lb,Ub}), + Bytes3 = align(Bytes2), + getoctets_as_list(Bytes3,Len); + Sv when list(Sv) -> + {Len,Bytes2} = decode_length(Bytes,{hd(Sv),lists:max(Sv)}), + Bytes3 = align(Bytes2), + getoctets_as_list(Bytes3,Len); + no -> + {Len,Bytes2} = decode_length(Bytes,undefined), + Bytes3 = align(Bytes2), + getoctets_as_list(Bytes3,Len) + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Restricted char string types +%% (NumericString, PrintableString,VisibleString,IA5String,BMPString,UniversalString) +%% X.691:26 and X.680:34-36 +%%encode_restricted_string(aligned,'BMPString',Constraints,Extension,Val) + + +encode_restricted_string(aligned,{Name,Val}) when atom(Name) -> + encode_restricted_string(aligned,Val); + +encode_restricted_string(aligned,Val) when list(Val)-> + [encode_length(undefined,length(Val)),align, + {octets,Val}]. + +encode_known_multiplier_string(aligned,StringType,C,_Ext,{Name,Val}) when atom(Name) -> + encode_known_multiplier_string(aligned,StringType,C,false,Val); + +encode_known_multiplier_string(aligned,StringType,C,_Ext,Val) -> + Result = chars_encode(C,StringType,Val), + NumBits = get_NumBits(C,StringType), + case get_constraint(C,'SizeConstraint') of + Ub when integer(Ub), Ub*NumBits =< 16 -> + case {StringType,Result} of + {'BMPString',{octets,Ol}} -> + [{bits,8,Oct}||Oct <- Ol]; + _ -> + Result + end; + 0 -> + []; + Ub when integer(Ub),Ub =<65535 -> % fixed length + [align,Result]; + {Ub,Lb} -> + [encode_length({Ub,Lb},length(Val)),align,Result]; + Vl when list(Vl) -> + [encode_length({lists:min(Vl),lists:max(Vl)},length(Val)),align,Result]; + no -> + [encode_length(undefined,length(Val)),align,Result] + end. + +decode_restricted_string(Bytes,aligned) -> + {Len,Bytes2} = decode_length(Bytes,undefined), + Bytes3 = align(Bytes2), + getoctets_as_list(Bytes3,Len). + +decode_known_multiplier_string(Bytes,aligned,StringType,C,_Ext) -> + NumBits = get_NumBits(C,StringType), + case get_constraint(C,'SizeConstraint') of + Ub when integer(Ub), Ub*NumBits =< 16 -> + chars_decode(Bytes,NumBits,StringType,C,Ub); + Ub when integer(Ub),Ub =<65535 -> % fixed length + Bytes1 = align(Bytes), + chars_decode(Bytes1,NumBits,StringType,C,Ub); + 0 -> + {[],Bytes}; + Vl when list(Vl) -> + {Len,Bytes1} = decode_length(Bytes,{hd(Vl),lists:max(Vl)}), + Bytes2 = align(Bytes1), + chars_decode(Bytes2,NumBits,StringType,C,Len); + no -> + {Len,Bytes1} = decode_length(Bytes,undefined), + Bytes2 = align(Bytes1), + chars_decode(Bytes2,NumBits,StringType,C,Len); + {Lb,Ub}-> + {Len,Bytes1} = decode_length(Bytes,{Lb,Ub}), + Bytes2 = align(Bytes1), + chars_decode(Bytes2,NumBits,StringType,C,Len) + end. + + +encode_NumericString(C,Val) -> + encode_known_multiplier_string(aligned,'NumericString',C,false,Val). +decode_NumericString(Bytes,C) -> + decode_known_multiplier_string(Bytes,aligned,'NumericString',C,false). + +encode_PrintableString(C,Val) -> + encode_known_multiplier_string(aligned,'PrintableString',C,false,Val). +decode_PrintableString(Bytes,C) -> + decode_known_multiplier_string(Bytes,aligned,'PrintableString',C,false). + +encode_VisibleString(C,Val) -> % equivalent with ISO646String + encode_known_multiplier_string(aligned,'VisibleString',C,false,Val). +decode_VisibleString(Bytes,C) -> + decode_known_multiplier_string(Bytes,aligned,'VisibleString',C,false). + +encode_IA5String(C,Val) -> + encode_known_multiplier_string(aligned,'IA5String',C,false,Val). +decode_IA5String(Bytes,C) -> + decode_known_multiplier_string(Bytes,aligned,'IA5String',C,false). + +encode_BMPString(C,Val) -> + encode_known_multiplier_string(aligned,'BMPString',C,false,Val). +decode_BMPString(Bytes,C) -> + decode_known_multiplier_string(Bytes,aligned,'BMPString',C,false). + +encode_UniversalString(C,Val) -> + encode_known_multiplier_string(aligned,'UniversalString',C,false,Val). +decode_UniversalString(Bytes,C) -> + decode_known_multiplier_string(Bytes,aligned,'UniversalString',C,false). + +%% end of known-multiplier strings for which PER visible constraints are +%% applied + +encode_GeneralString(_C,Val) -> + encode_restricted_string(aligned,Val). +decode_GeneralString(Bytes,_C) -> + decode_restricted_string(Bytes,aligned). + +encode_GraphicString(_C,Val) -> + encode_restricted_string(aligned,Val). +decode_GraphicString(Bytes,_C) -> + decode_restricted_string(Bytes,aligned). + +encode_ObjectDescriptor(_C,Val) -> + encode_restricted_string(aligned,Val). +decode_ObjectDescriptor(Bytes) -> + decode_restricted_string(Bytes,aligned). + +encode_TeletexString(_C,Val) -> % equivalent with T61String + encode_restricted_string(aligned,Val). +decode_TeletexString(Bytes,_C) -> + decode_restricted_string(Bytes,aligned). + +encode_VideotexString(_C,Val) -> + encode_restricted_string(aligned,Val). +decode_VideotexString(Bytes,_C) -> + decode_restricted_string(Bytes,aligned). + + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% getBMPChars(Bytes,Len) ->{BMPcharList,RemainingBytes} +%% +getBMPChars(Bytes,1) -> + {O1,Bytes2} = getbits(Bytes,8), + {O2,Bytes3} = getbits(Bytes2,8), + if + O1 == 0 -> + {[O2],Bytes3}; + true -> + {[{0,0,O1,O2}],Bytes3} + end; +getBMPChars(Bytes,Len) -> + getBMPChars(Bytes,Len,[]). + +getBMPChars(Bytes,0,Acc) -> + {lists:reverse(Acc),Bytes}; +getBMPChars(Bytes,Len,Acc) -> + {Octs,Bytes1} = getoctets_as_list(Bytes,2), + case Octs of + [0,O2] -> + getBMPChars(Bytes1,Len-1,[O2|Acc]); + [O1,O2]-> + getBMPChars(Bytes1,Len-1,[{0,0,O1,O2}|Acc]) + end. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% chars_encode(C,StringType,Value) -> ValueList +%% +%% encodes chars according to the per rules taking the constraint PermittedAlphabet +%% into account. +%% This function does only encode the value part and NOT the length + +chars_encode(C,StringType,Value) -> + case {StringType,get_constraint(C,'PermittedAlphabet')} of + {'UniversalString',{_,_Sv}} -> + exit({error,{asn1,{'not implemented',"UniversalString with PermittedAlphabet constraint"}}}); + {'BMPString',{_,_Sv}} -> + exit({error,{asn1,{'not implemented',"BMPString with PermittedAlphabet constraint"}}}); + _ -> + {NumBits,CharOutTab} = {get_NumBits(C,StringType),get_CharOutTab(C,StringType)}, + chars_encode2(Value,NumBits,CharOutTab) + end. + +chars_encode2([H|T],NumBits,{Min,Max,notab}) when H =< Max, H >= Min -> + [{bits,NumBits,H-Min}|chars_encode2(T,NumBits,{Min,Max,notab})]; +chars_encode2([H|T],NumBits,{Min,Max,Tab}) when H =< Max, H >= Min -> + [{bits,NumBits,element(H-Min+1,Tab)}|chars_encode2(T,NumBits,{Min,Max,Tab})]; +chars_encode2([{A,B,C,D}|T],NumBits,{Min,Max,notab}) -> + %% no value range check here (ought to be, but very expensive) +% [{bits,NumBits,(A*B*C*D)-Min}|chars_encode2(T,NumBits,{Min,Max,notab})]; + [{bits,NumBits,((((((A bsl 8) + B) bsl 8) + C) bsl 8) + D)-Min}|chars_encode2(T,NumBits,{Min,Max,notab})]; +chars_encode2([{A,B,C,D}|T],NumBits,{Min,Max,Tab}) -> + %% no value range check here (ought to be, but very expensive) +% [{bits,NumBits,element((A*B*C*D)-Min,Tab)}|chars_encode2(T,NumBits,{Min,Max,notab})]; + [{bits,NumBits,element(((((((A bsl 8)+B) bsl 8)+C) bsl 8)+D)-Min,Tab)}|chars_encode2(T,NumBits,{Min,Max,notab})]; +chars_encode2([H|_T],_,{_,_,_}) -> + exit({error,{asn1,{illegal_char_value,H}}}); +chars_encode2([],_,_) -> + []. + + +get_NumBits(C,StringType) -> + case get_constraint(C,'PermittedAlphabet') of + {'SingleValue',Sv} -> + charbits(length(Sv),aligned); + no -> + case StringType of + 'IA5String' -> + charbits(128,aligned); % 16#00..16#7F + 'VisibleString' -> + charbits(95,aligned); % 16#20..16#7E + 'PrintableString' -> + charbits(74,aligned); % [$\s,$',$(,$),$+,$,,$-,$.,$/,"0123456789",$:,$=,$?,$A..$Z,$a..$z + 'NumericString' -> + charbits(11,aligned); % $ ,"0123456789" + 'UniversalString' -> + 32; + 'BMPString' -> + 16 + end + end. + +%%Maybe used later +%%get_MaxChar(C,StringType) -> +%% case get_constraint(C,'PermittedAlphabet') of +%% {'SingleValue',Sv} -> +%% lists:nth(length(Sv),Sv); +%% no -> +%% case StringType of +%% 'IA5String' -> +%% 16#7F; % 16#00..16#7F +%% 'VisibleString' -> +%% 16#7E; % 16#20..16#7E +%% 'PrintableString' -> +%% $z; % [$\s,$',$(,$),$+,$,,$-,$.,$/,"0123456789",$:,$=,$?,$A..$Z,$a..$z +%% 'NumericString' -> +%% $9; % $ ,"0123456789" +%% 'UniversalString' -> +%% 16#ffffffff; +%% 'BMPString' -> +%% 16#ffff +%% end +%% end. + +%%Maybe used later +%%get_MinChar(C,StringType) -> +%% case get_constraint(C,'PermittedAlphabet') of +%% {'SingleValue',Sv} -> +%% hd(Sv); +%% no -> +%% case StringType of +%% 'IA5String' -> +%% 16#00; % 16#00..16#7F +%% 'VisibleString' -> +%% 16#20; % 16#20..16#7E +%% 'PrintableString' -> +%% $\s; % [$\s,$',$(,$),$+,$,,$-,$.,$/,"0123456789",$:,$=,$?,$A..$Z,$a..$z +%% 'NumericString' -> +%% $\s; % $ ,"0123456789" +%% 'UniversalString' -> +%% 16#00; +%% 'BMPString' -> +%% 16#00 +%% end +%% end. + +get_CharOutTab(C,StringType) -> + get_CharTab(C,StringType,out). + +get_CharInTab(C,StringType) -> + get_CharTab(C,StringType,in). + +get_CharTab(C,StringType,InOut) -> + case get_constraint(C,'PermittedAlphabet') of + {'SingleValue',Sv} -> + get_CharTab2(C,StringType,hd(Sv),lists:max(Sv),Sv,InOut); + no -> + case StringType of + 'IA5String' -> + {0,16#7F,notab}; + 'VisibleString' -> + get_CharTab2(C,StringType,16#20,16#7F,notab,InOut); + 'PrintableString' -> + Chars = lists:sort( + " '()+,-./0123456789:=?ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"), + get_CharTab2(C,StringType,hd(Chars),lists:max(Chars),Chars,InOut); + 'NumericString' -> + get_CharTab2(C,StringType,16#20,$9," 0123456789",InOut); + 'UniversalString' -> + {0,16#FFFFFFFF,notab}; + 'BMPString' -> + {0,16#FFFF,notab} + end + end. + +get_CharTab2(C,StringType,Min,Max,Chars,InOut) -> + BitValMax = (1 bsl get_NumBits(C,StringType))-1, + if + Max =< BitValMax -> + {0,Max,notab}; + true -> + case InOut of + out -> + {Min,Max,create_char_tab(Min,Chars)}; + in -> + {Min,Max,list_to_tuple(Chars)} + end + end. + +create_char_tab(Min,L) -> + list_to_tuple(create_char_tab(Min,L,0)). +create_char_tab(Min,[Min|T],V) -> + [V|create_char_tab(Min+1,T,V+1)]; +create_char_tab(_Min,[],_V) -> + []; +create_char_tab(Min,L,V) -> + [false|create_char_tab(Min+1,L,V)]. + +%% This very inefficient and should be moved to compiletime +charbits(NumOfChars,aligned) -> + case charbits(NumOfChars) of + 1 -> 1; + 2 -> 2; + B when B > 2, B =< 4 -> 4; + B when B > 4, B =< 8 -> 8; + B when B > 8, B =< 16 -> 16; + B when B > 16, B =< 32 -> 32 + end. + +charbits(NumOfChars) when NumOfChars =< 2 -> 1; +charbits(NumOfChars) when NumOfChars =< 4 -> 2; +charbits(NumOfChars) when NumOfChars =< 8 -> 3; +charbits(NumOfChars) when NumOfChars =< 16 -> 4; +charbits(NumOfChars) when NumOfChars =< 32 -> 5; +charbits(NumOfChars) when NumOfChars =< 64 -> 6; +charbits(NumOfChars) when NumOfChars =< 128 -> 7; +charbits(NumOfChars) when NumOfChars =< 256 -> 8; +charbits(NumOfChars) when NumOfChars =< 512 -> 9; +charbits(NumOfChars) when NumOfChars =< 1024 -> 10; +charbits(NumOfChars) when NumOfChars =< 2048 -> 11; +charbits(NumOfChars) when NumOfChars =< 4096 -> 12; +charbits(NumOfChars) when NumOfChars =< 8192 -> 13; +charbits(NumOfChars) when NumOfChars =< 16384 -> 14; +charbits(NumOfChars) when NumOfChars =< 32768 -> 15; +charbits(NumOfChars) when NumOfChars =< 65536 -> 16; +charbits(NumOfChars) when integer(NumOfChars) -> + 16 + charbits1(NumOfChars bsr 16). + +charbits1(0) -> + 0; +charbits1(NumOfChars) -> + 1 + charbits1(NumOfChars bsr 1). + + +chars_decode(Bytes,_,'BMPString',C,Len) -> + case get_constraint(C,'PermittedAlphabet') of + no -> + getBMPChars(Bytes,Len); + _ -> + exit({error,{asn1, + {'not implemented', + "BMPString with PermittedAlphabet constraint"}}}) + end; +chars_decode(Bytes,NumBits,StringType,C,Len) -> + CharInTab = get_CharInTab(C,StringType), + chars_decode2(Bytes,CharInTab,NumBits,Len). + + +chars_decode2(Bytes,CharInTab,NumBits,Len) -> + chars_decode2(Bytes,CharInTab,NumBits,Len,[]). + +chars_decode2(Bytes,_CharInTab,_NumBits,0,Acc) -> + {lists:reverse(Acc),Bytes}; +chars_decode2(Bytes,{Min,Max,notab},NumBits,Len,Acc) when NumBits > 8 -> + {Char,Bytes2} = getbits(Bytes,NumBits), + Result = case minimum_octets(Char+Min) of + [NewChar] -> NewChar; + [C1,C2] -> {0,0,C1,C2}; + [C1,C2,C3] -> {0,C1,C2,C3}; + [C1,C2,C3,C4] -> {C1,C2,C3,C4} + end, + chars_decode2(Bytes2,{Min,Max,notab},NumBits,Len -1,[Result|Acc]); +chars_decode2(Bytes,{Min,Max,notab},NumBits,Len,Acc) -> + {Char,Bytes2} = getbits(Bytes,NumBits), + chars_decode2(Bytes2,{Min,Max,notab},NumBits,Len -1,[Char+Min|Acc]); + +%% BMPString and UniversalString with PermittedAlphabet is currently not supported +chars_decode2(Bytes,{Min,Max,CharInTab},NumBits,Len,Acc) -> + {Char,Bytes2} = getbits(Bytes,NumBits), + chars_decode2(Bytes2,{Min,Max,CharInTab},NumBits,Len -1,[element(Char+1,CharInTab)|Acc]). + + + % X.691:17 +encode_null({Name,Val}) when atom(Name) -> + encode_null(Val); +encode_null(_) -> []. % encodes to nothing + +decode_null(Bytes) -> + {'NULL',Bytes}. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% encode_object_identifier(Val) -> CompleteList +%% encode_object_identifier({Name,Val}) -> CompleteList +%% Val -> {Int1,Int2,...,IntN} % N >= 2 +%% Name -> atom() +%% Int1 -> integer(0..2) +%% Int2 -> integer(0..39) when Int1 (0..1) else integer() +%% Int3-N -> integer() +%% CompleteList -> [{bits,8,Val}|{octets,Ol}|align|...] +%% +encode_object_identifier({Name,Val}) when atom(Name) -> + encode_object_identifier(Val); +encode_object_identifier(Val) -> + Octets = e_object_identifier(Val,notag), + [{debug,object_identifier},encode_length(undefined,length(Octets)),{octets,Octets}]. + +%% This code is copied from asn1_encode.erl (BER) and corrected and modified + +e_object_identifier({'OBJECT IDENTIFIER',V},DoTag) -> + e_object_identifier(V,DoTag); +e_object_identifier({Cname,V},DoTag) when atom(Cname),tuple(V) -> + e_object_identifier(tuple_to_list(V),DoTag); +e_object_identifier({Cname,V},DoTag) when atom(Cname),list(V) -> + e_object_identifier(V,DoTag); +e_object_identifier(V,DoTag) when tuple(V) -> + e_object_identifier(tuple_to_list(V),DoTag); + +% E1 = 0|1|2 and (E2 < 40 when E1 = 0|1) +e_object_identifier([E1,E2|Tail],_DoTag) when E1 =< 2 -> + Head = 40*E1 + E2, % weird + Res = e_object_elements([Head|Tail]), +% dotag(DoTag,[6],elength(length(Res)+1),[Head|Res]), + Res. + +e_object_elements([]) -> + []; +e_object_elements([H|T]) -> + lists:append(e_object_element(H),e_object_elements(T)). + +e_object_element(Num) when Num < 128 -> + [Num]; +% must be changed to handle more than 2 octets +e_object_element(Num) -> %% when Num < ??? + Left = ((Num band 2#11111110000000) bsr 7) bor 2#10000000, + Right = Num band 2#1111111 , + [Left,Right]. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% decode_object_identifier(Bytes) -> {ObjId,RemainingBytes} +%% ObjId -> {integer(),integer(),...} % at least 2 integers +%% RemainingBytes -> [integer()] when integer() (0..255) +decode_object_identifier(Bytes) -> + {Len,Bytes2} = decode_length(Bytes,undefined), + {Octs,Bytes3} = getoctets_as_list(Bytes2,Len), + [First|Rest] = dec_subidentifiers(Octs,0,[]), + Idlist = if + First < 40 -> + [0,First|Rest]; + First < 80 -> + [1,First - 40|Rest]; + true -> + [2,First - 80|Rest] + end, + {list_to_tuple(Idlist),Bytes3}. + +dec_subidentifiers([H|T],Av,Al) when H >=16#80 -> + dec_subidentifiers(T,(Av bsl 7) + (H band 16#7F),Al); +dec_subidentifiers([H|T],Av,Al) -> + dec_subidentifiers(T,0,[(Av bsl 7) + H |Al]); +dec_subidentifiers([],_Av,Al) -> + lists:reverse(Al). + +get_constraint(C,Key) -> + case lists:keysearch(Key,1,C) of + false -> + no; + {value,{_,V}} -> + V + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% complete(InList) -> ByteList +%% Takes a coded list with bits and bytes and converts it to a list of bytes +%% Should be applied as the last step at encode of a complete ASN.1 type +%% +complete(InList) when list(InList) -> + complete(InList,[],0); +complete(InList) -> + complete([InList],[],0). + +complete([{debug,_}|T], Acc, Acclen) -> + complete(T,Acc,Acclen); +complete([H|T],Acc,Acclen) when list(H) -> + complete(lists:concat([H,T]),Acc,Acclen); + + +complete([{octets,N,Val}|T],Acc,Acclen) when N =< 4 ,integer(Val) -> + Newval = case N of + 1 -> + Val4 = Val band 16#FF, + [Val4]; + 2 -> + Val3 = (Val bsr 8) band 16#FF, + Val4 = Val band 16#FF, + [Val3,Val4]; + 3 -> + Val2 = (Val bsr 16) band 16#FF, + Val3 = (Val bsr 8) band 16#FF, + Val4 = Val band 16#FF, + [Val2,Val3,Val4]; + 4 -> + Val1 = (Val bsr 24) band 16#FF, + Val2 = (Val bsr 16) band 16#FF, + Val3 = (Val bsr 8) band 16#FF, + Val4 = Val band 16#FF, + [Val1,Val2,Val3,Val4] + end, + complete([{octets,Newval}|T],Acc,Acclen); + +complete([{octets,Oct}|T],[],_Acclen) when list(Oct) -> + complete(T,lists:reverse(Oct),0); +complete([{octets,Oct}|T],[Hacc|Tacc],Acclen) when list(Oct) -> + Rest = 8 - Acclen, + if + Rest == 8 -> + complete(T,lists:concat([lists:reverse(Oct),[Hacc|Tacc]]),0); + true -> + complete(T,lists:concat([lists:reverse(Oct),[Hacc bsl Rest|Tacc]]),0) + end; + +complete([{bit,Val}|T], Acc, Acclen) -> + complete([{bits,1,Val}|T],Acc,Acclen); +complete([{octet,Val}|T], Acc, Acclen) -> + complete([{octets,1,Val}|T],Acc,Acclen); + +complete([{bits,N,Val}|T], Acc, 0) when N =< 8 -> + complete(T,[Val|Acc],N); +complete([{bits,N,Val}|T], [Hacc|Tacc], Acclen) when N =< 8 -> + Rest = 8 - Acclen, + if + Rest >= N -> + complete(T,[(Hacc bsl N) + Val|Tacc],(Acclen+N) rem 8); + true -> + Diff = N - Rest, + NewHacc = (Hacc bsl Rest) + (Val bsr Diff), + Mask = element(Diff,{1,3,7,15,31,63,127,255}), + complete(T,[(Val band Mask),NewHacc|Tacc],(Acclen+N) rem 8) + end; +complete([{bits,N,Val}|T], Acc, Acclen) -> % N > 8 + complete([{bits,N-8,Val bsr 8},{bits,8,Val band 255}|T],Acc,Acclen); + +complete([align|T],Acc,0) -> + complete(T,Acc,0); +complete([align|T],[Hacc|Tacc],Acclen) -> + Rest = 8 - Acclen, + complete(T,[Hacc bsl Rest|Tacc],0); +complete([{octets,_N,Val}|T],Acc,Acclen) when list(Val) -> % no security check here + complete([{octets,Val}|T],Acc,Acclen); + +complete([],[],0) -> + [0]; % a complete encoding must always be at least 1 byte +complete([],Acc,0) -> + lists:reverse(Acc); +complete([],[Hacc|Tacc],Acclen) when Acclen > 0-> + Rest = 8 - Acclen, + NewHacc = Hacc bsl Rest, + lists:reverse([NewHacc|Tacc]). diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/notes_history.sgml b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/notes_history.sgml new file mode 100644 index 0000000000..3b50c1b73f --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/notes_history.sgml @@ -0,0 +1,97 @@ +<!doctype chapter PUBLIC "-//Stork//DTD chapter//EN"> +<!-- + ``The contents of this file are subject to the Erlang Public License, + Version 1.1, (the "License"); you may not use this file except in + compliance with the License. You should have received a copy of the + Erlang Public License along with this software. If not, it can be + retrieved via the world wide web at http://www.erlang.org/. + + Software distributed under the License is distributed on an "AS IS" + basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + the License for the specific language governing rights and limitations + under the License. + + The Initial Developer of the Original Code is Ericsson Utvecklings AB. + Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings + AB. All Rights Reserved.'' + + $Id: notes_history.sgml,v 1.1 2008/12/17 09:53:31 mikpe Exp $ +--> +<chapter> + <header> + <title>ASN1 Release Notes (Old)</title> + <prepared>Kenneth Lundin</prepared> + <responsible>Kenneth Lundin</responsible> + <docno></docno> + <approved>Kenneth Lundin</approved> + <checked>Kenneth Lundin</checked> + <date>98-02-02</date> + <rev>A</rev> + <file>notes_history.sgml</file> + </header> + + <p>This document describes the changes made to old versions of the <c>asn1</c> application. + + <section> + <title>ASN1 0.8.1</title> + <p>This is the first release of the ASN1 application. This version is released + for beta-testing. Some functionality will be added until the 1.0 version is + released. A list of missing features and restrictions can be found in the + chapter below. + + <section> + <title>Missing features and other restrictions</title> + <list> + <item> + <p>The encoding rules BER and PER (aligned) is supported. <em>PER (unaligned) + IS NOT SUPPORTED</em>. + <item> + <p>NOT SUPPORTED types <c>ANY</c> and <c>ANY DEFINED BY</c> + (is not in the standard any more). + <item> + <p>NOT SUPPORTED types <c>EXTERNAL</c> and <c>EMBEDDED-PDV</c>. + <item> + <p>NOT SUPPORTED type <c>REAL</c> (planned to be implemented). + <item> + <p>The code generation support for value definitions in the ASN.1 notation is very limited + (planned to be enhanced). + <item> + <p>The support for constraints is limited to: + <list> + <item><p> + SizeConstraint SIZE(X) + <item><p> + SingleValue (1) + <item><p> + ValueRange (X..Y) + <item><p> + PermittedAlpabet FROM (but not for BMPString and UniversalString when generating PER). + </list> + <p>Complex expressions in constraints is not supported (planned to be extended). + <item> + <p>The current version of the compiler has very limited error checking: + <list> + <item><p>Stops at first syntax error. + <item><p>Does not stop when a reference to an undefined type is found , + but prints an error message. Compilation of the generated + Erlang module will then fail. + <item><p>A whole number of other semantical controls is currently missing. This + means that the compiler will give little or bad help to detect what's wrong + with an ASN.1 specification, but will mostly work very well when the + ASN.1 specification is correct. + </list> + <item> + <p>The maximum INTEGER supported in this version is a signed 64 bit integer. This + limitation is probably quite reasonable. (Planned to be extended). + <item> + <p>Only AUTOMATIC TAGS supported for PER. + <item> + <p>Only EXPLICIT and IMPLICIT TAGS supported for BER. + <item> + <p>The compiler supports decoding of BER-data with indefinite length but it is + not possible to produce data with indefinite length with the encoder. + </list> + </section> + + </section> +</chapter> diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/notes_latest.sgml b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/notes_latest.sgml new file mode 100644 index 0000000000..ff1f5adfa2 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/notes_latest.sgml @@ -0,0 +1,97 @@ +<!doctype chapter PUBLIC "-//Stork//DTD chapter//EN"> +<!-- + ``The contents of this file are subject to the Erlang Public License, + Version 1.1, (the "License"); you may not use this file except in + compliance with the License. You should have received a copy of the + Erlang Public License along with this software. If not, it can be + retrieved via the world wide web at http://www.erlang.org/. + + Software distributed under the License is distributed on an "AS IS" + basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + the License for the specific language governing rights and limitations + under the License. + + The Initial Developer of the Original Code is Ericsson Utvecklings AB. + Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings + AB. All Rights Reserved.'' + + $Id: notes_latest.sgml,v 1.1 2008/12/17 09:53:31 mikpe Exp $ +--> +<chapter> + <header> + <title>ASN1 Release Notes</title> + <prepared>Kenneth Lundin</prepared> + <responsible>Kenneth Lundin</responsible> + <docno></docno> + <approved>Kenneth Lundin</approved> + <checked>Kenneth Lundin</checked> + <date>97-10-07</date> + <rev>A</rev> + <file>notes_latest.sgml</file> + </header> + + <p>This document describes the changes made to the asn1 application. + + <section> + <title>ASN1 0.8.1</title> + <p>This is the first release of the ASN1 application. This version is released + for beta-testing. Some functionality will be added until the 1.0 version is + released. A list of missing features and restrictions can be found in the + chapter below. + + <section> + <title>Missing features and other restrictions</title> + <list> + <item> + <p>The encoding rules BER and PER (aligned) is supported. <em>PER (unaligned) + IS NOT SUPPORTED</em>. + <item> + <p>NOT SUPPORTED types <c>ANY</c> and <c>ANY DEFINED BY</c> + (is not in the standard any more). + <item> + <p>NOT SUPPORTED types <c>EXTERNAL</c> and <c>EMBEDDED-PDV</c>. + <item> + <p>NOT SUPPORTED type <c>REAL</c> (planned to be implemented). + <item> + <p>The code generation support for value definitions in the ASN.1 notation is very limited + (planned to be enhanced). + <item> + <p>The support for constraints is limited to: + <list> + <item><p> + SizeConstraint SIZE(X) + <item><p> + SingleValue (1) + <item><p> + ValueRange (X..Y) + <item><p> + PermittedAlpabet FROM (but not for BMPString and UniversalString when generating PER). + </list> + <p>Complex expressions in constraints is not supported (planned to be extended). + <item> + <p>The current version of the compiler has very limited error checking: + <list> + <item><p>Stops at first syntax error. + <item><p>Does not stop when a reference to an undefined type is found , + but prints an error message. Compilation of the generated + Erlang module will then fail. + <item><p>A whole number of other semantical controls is currently missing. This + means that the compiler will give little or bad help to detect what's wrong + with an ASN.1 specification, but will mostly work very well when the + ASN.1 specification is correct. + </list> + <item> + <p>The maximum INTEGER supported in this version is a signed 64 bit integer. This + limitation is probably quite reasonable. (Planned to be extended). + <item> + <p>Only AUTOMATIC TAGS supported for PER. + <item> + <p>Only EXPLICIT and IMPLICIT TAGS supported for BER. + <item> + <p>The compiler supports decoding of BER-data with indefinite length but it is + not possible to produce data with indefinite length with the encoder. + </list> + </section> + + </section> +</chapter> |