From 84adefa331c4159d432d22840663c38f155cd4c1 Mon Sep 17 00:00:00 2001 From: Erlang/OTP Date: Fri, 20 Nov 2009 14:54:40 +0000 Subject: The R13B03 release. --- lib/asn1/src/Makefile | 175 + lib/asn1/src/Restrictions.txt | 55 + lib/asn1/src/asn1.app.src | 21 + lib/asn1/src/asn1.appup.src | 113 + lib/asn1/src/asn1_app.erl | 38 + lib/asn1/src/asn1_db.erl | 167 + lib/asn1/src/asn1_records.hrl | 118 + lib/asn1/src/asn1_server.erl | 107 + lib/asn1/src/asn1_sup.erl | 37 + lib/asn1/src/asn1ct.erl | 2520 ++++++++ lib/asn1/src/asn1ct_check.erl | 7399 ++++++++++++++++++++++++ lib/asn1/src/asn1ct_constructed_ber.erl | 1571 +++++ lib/asn1/src/asn1ct_constructed_ber_bin_v2.erl | 1486 +++++ lib/asn1/src/asn1ct_constructed_per.erl | 1393 +++++ lib/asn1/src/asn1ct_gen.erl | 2066 +++++++ lib/asn1/src/asn1ct_gen_ber.erl | 1736 ++++++ lib/asn1/src/asn1ct_gen_ber_bin_v2.erl | 1833 ++++++ lib/asn1/src/asn1ct_gen_per.erl | 1395 +++++ lib/asn1/src/asn1ct_gen_per_rt2ct.erl | 1798 ++++++ lib/asn1/src/asn1ct_name.erl | 233 + lib/asn1/src/asn1ct_parser.yrl | 1177 ++++ lib/asn1/src/asn1ct_parser2.erl | 3063 ++++++++++ lib/asn1/src/asn1ct_pretty_format.erl | 201 + lib/asn1/src/asn1ct_tok.erl | 391 ++ lib/asn1/src/asn1ct_value.erl | 459 ++ lib/asn1/src/asn1rt.erl | 210 + lib/asn1/src/asn1rt_ber_bin.erl | 2497 ++++++++ lib/asn1/src/asn1rt_ber_bin_v2.erl | 2037 +++++++ lib/asn1/src/asn1rt_check.erl | 361 ++ lib/asn1/src/asn1rt_driver_handler.erl | 141 + lib/asn1/src/asn1rt_per_bin.erl | 2287 ++++++++ lib/asn1/src/asn1rt_per_bin_rt2ct.erl | 1885 ++++++ lib/asn1/src/asn1rt_uper_bin.erl | 1635 ++++++ lib/asn1/src/notes_history.sgml | 100 + lib/asn1/src/notes_latest.sgml | 100 + 35 files changed, 40805 insertions(+) create mode 100644 lib/asn1/src/Makefile create mode 100644 lib/asn1/src/Restrictions.txt create mode 100644 lib/asn1/src/asn1.app.src create mode 100644 lib/asn1/src/asn1.appup.src create mode 100644 lib/asn1/src/asn1_app.erl create mode 100644 lib/asn1/src/asn1_db.erl create mode 100644 lib/asn1/src/asn1_records.hrl create mode 100644 lib/asn1/src/asn1_server.erl create mode 100644 lib/asn1/src/asn1_sup.erl create mode 100644 lib/asn1/src/asn1ct.erl create mode 100644 lib/asn1/src/asn1ct_check.erl create mode 100644 lib/asn1/src/asn1ct_constructed_ber.erl create mode 100644 lib/asn1/src/asn1ct_constructed_ber_bin_v2.erl create mode 100644 lib/asn1/src/asn1ct_constructed_per.erl create mode 100644 lib/asn1/src/asn1ct_gen.erl create mode 100644 lib/asn1/src/asn1ct_gen_ber.erl create mode 100644 lib/asn1/src/asn1ct_gen_ber_bin_v2.erl create mode 100644 lib/asn1/src/asn1ct_gen_per.erl create mode 100644 lib/asn1/src/asn1ct_gen_per_rt2ct.erl create mode 100644 lib/asn1/src/asn1ct_name.erl create mode 100644 lib/asn1/src/asn1ct_parser.yrl create mode 100644 lib/asn1/src/asn1ct_parser2.erl create mode 100644 lib/asn1/src/asn1ct_pretty_format.erl create mode 100644 lib/asn1/src/asn1ct_tok.erl create mode 100644 lib/asn1/src/asn1ct_value.erl create mode 100644 lib/asn1/src/asn1rt.erl create mode 100644 lib/asn1/src/asn1rt_ber_bin.erl create mode 100644 lib/asn1/src/asn1rt_ber_bin_v2.erl create mode 100644 lib/asn1/src/asn1rt_check.erl create mode 100644 lib/asn1/src/asn1rt_driver_handler.erl create mode 100644 lib/asn1/src/asn1rt_per_bin.erl create mode 100644 lib/asn1/src/asn1rt_per_bin_rt2ct.erl create mode 100644 lib/asn1/src/asn1rt_uper_bin.erl create mode 100644 lib/asn1/src/notes_history.sgml create mode 100644 lib/asn1/src/notes_latest.sgml (limited to 'lib/asn1/src') diff --git a/lib/asn1/src/Makefile b/lib/asn1/src/Makefile new file mode 100644 index 0000000000..2733cde3f8 --- /dev/null +++ b/lib/asn1/src/Makefile @@ -0,0 +1,175 @@ +# +# %CopyrightBegin% +# +# Copyright Ericsson AB 1997-2009. All Rights Reserved. +# +# 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 online 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. +# +# %CopyrightEnd% +# +# +# 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 +# + +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_bin \ + asn1rt_ber_bin \ + asn1rt_ber_bin_v2 \ + asn1rt_per_bin_rt2ct \ + asn1rt_uper_bin \ + asn1rt_check \ + asn1rt_driver_handler +# asn1_sup \ +# asn1_app \ +# asn1_server + + +# 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 +# ---------------------------------------------------- + +ifeq ($(USE_ASN1_HIPE),true) +ERL_COMPILE_FLAGS += +native +endif + +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: + + +info: + @echo "PARSER_SRC: $(PARSER_SRC)" + @echo "INSTALL_DATA: $(INSTALL_DATA)" +# ---------------------------------------------------- +# 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) $(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/asn1/src/Restrictions.txt b/lib/asn1/src/Restrictions.txt new file mode 100644 index 0000000000..73b725245d --- /dev/null +++ b/lib/asn1/src/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/asn1/src/asn1.app.src b/lib/asn1/src/asn1.app.src new file mode 100644 index 0000000000..abacb0a1e9 --- /dev/null +++ b/lib/asn1/src/asn1.app.src @@ -0,0 +1,21 @@ +{application, asn1, + [{description, "The Erlang ASN1 compiler version %VSN%"}, + {vsn, "%VSN%"}, + {modules, [ + asn1rt, + asn1rt_per_bin, + asn1rt_per_bin_rt2ct, + asn1rt_uper_bin, + asn1rt_ber_bin, + asn1rt_ber_bin_v2, + asn1rt_check, + asn1rt_driver_handler + ]}, + {registered, [ + asn1_ns, + asn1db, + asn1_driver_owner + ]}, + {env, []}, + {applications, [kernel, stdlib]} + ]}. diff --git a/lib/asn1/src/asn1.appup.src b/lib/asn1/src/asn1.appup.src new file mode 100644 index 0000000000..753d308684 --- /dev/null +++ b/lib/asn1/src/asn1.appup.src @@ -0,0 +1,113 @@ +{"%VSN%", + [ + {"1.6.8", + [ + {load_module, asn1rt, soft_purge, soft_purge, []}, + {load_module, asn1rt_per_bin, soft_purge, soft_purge, []}, + {load_module, asn1rt_per_bin_rt2ct, soft_purge, soft_purge, []}, + {load_module, asn1rt_uper_bin, soft_purge, soft_purge, []}, + {load_module, asn1rt_ber_bin, soft_purge, soft_purge, []}, + {load_module, asn1rt_ber_bin_v2, soft_purge, soft_purge, []}, + {load_module, asn1rt_check, soft_purge, soft_purge, []}, + {load_module, asn1rt_driver_handler, soft_purge, soft_purge, []}, + {apply, {asn1rt_driver_handler,unload_driver,[]}} + ] + }, + {"1.6.8.1", + [ + {load_module, asn1rt, soft_purge, soft_purge, []}, + {load_module, asn1rt_per_bin, soft_purge, soft_purge, []}, + {load_module, asn1rt_per_bin_rt2ct, soft_purge, soft_purge, []}, + {load_module, asn1rt_uper_bin, soft_purge, soft_purge, []}, + {load_module, asn1rt_ber_bin, soft_purge, soft_purge, []}, + {load_module, asn1rt_ber_bin_v2, soft_purge, soft_purge, []}, + {load_module, asn1rt_check, soft_purge, soft_purge, []}, + {load_module, asn1rt_driver_handler, soft_purge, soft_purge, []}, + {apply, {asn1rt_driver_handler,unload_driver,[]}} + ] + }, + {"1.6.9", + [ + {load_module, asn1rt, soft_purge, soft_purge, []}, + {load_module, asn1rt_per_bin, soft_purge, soft_purge, []}, + {load_module, asn1rt_per_bin_rt2ct, soft_purge, soft_purge, []}, + {load_module, asn1rt_uper_bin, soft_purge, soft_purge, []}, + {load_module, asn1rt_ber_bin, soft_purge, soft_purge, []}, + {load_module, asn1rt_ber_bin_v2, soft_purge, soft_purge, []}, + {load_module, asn1rt_check, soft_purge, soft_purge, []}, + {load_module, asn1rt_driver_handler, soft_purge, soft_purge, []}, + {apply, {asn1rt_driver_handler,unload_driver,[]}} + ] + }, + {"1.6.10", + [ + {load_module, asn1rt, soft_purge, soft_purge, []}, + {load_module, asn1rt_per_bin, soft_purge, soft_purge, []}, + {load_module, asn1rt_per_bin_rt2ct, soft_purge, soft_purge, []}, + {load_module, asn1rt_uper_bin, soft_purge, soft_purge, []}, + {load_module, asn1rt_ber_bin, soft_purge, soft_purge, []}, + {load_module, asn1rt_ber_bin_v2, soft_purge, soft_purge, []}, + {load_module, asn1rt_check, soft_purge, soft_purge, []}, + {load_module, asn1rt_driver_handler, soft_purge, soft_purge, []}, + {apply, {asn1rt_driver_handler,unload_driver,[]}} + ] + } + ], + [ + {"1.6.8", + [ + {load_module, asn1rt, soft_purge, soft_purge, []}, + {load_module, asn1rt_per_bin, soft_purge, soft_purge, []}, + {load_module, asn1rt_per_bin_rt2ct, soft_purge, soft_purge, []}, + {load_module, asn1rt_uper_bin, soft_purge, soft_purge, []}, + {load_module, asn1rt_ber_bin, soft_purge, soft_purge, []}, + {load_module, asn1rt_ber_bin_v2, soft_purge, soft_purge, []}, + {load_module, asn1rt_check, soft_purge, soft_purge, []}, + {load_module, asn1rt_driver_handler, soft_purge, soft_purge, []}, + {apply, {asn1rt_driver_handler,unload_driver,[]}} + ] + }, + {"1.6.8.1", + [ + {load_module, asn1rt, soft_purge, soft_purge, []}, + {load_module, asn1rt_per_bin, soft_purge, soft_purge, []}, + {load_module, asn1rt_per_bin_rt2ct, soft_purge, soft_purge, []}, + {load_module, asn1rt_uper_bin, soft_purge, soft_purge, []}, + {load_module, asn1rt_ber_bin, soft_purge, soft_purge, []}, + {load_module, asn1rt_ber_bin_v2, soft_purge, soft_purge, []}, + {load_module, asn1rt_check, soft_purge, soft_purge, []}, + {load_module, asn1rt_driver_handler, soft_purge, soft_purge, []}, + {apply, {asn1rt_driver_handler,unload_driver,[]}} + ] + }, + {"1.6.9", + [ + {load_module, asn1rt, soft_purge, soft_purge, []}, + {load_module, asn1rt_per_bin, soft_purge, soft_purge, []}, + {load_module, asn1rt_per_bin_rt2ct, soft_purge, soft_purge, []}, + {load_module, asn1rt_uper_bin, soft_purge, soft_purge, []}, + {load_module, asn1rt_ber_bin, soft_purge, soft_purge, []}, + {load_module, asn1rt_ber_bin_v2, soft_purge, soft_purge, []}, + {load_module, asn1rt_check, soft_purge, soft_purge, []}, + {load_module, asn1rt_driver_handler, soft_purge, soft_purge, []}, + {apply, {asn1rt_driver_handler,unload_driver,[]}} + ] + }, + {"1.6.10", + [ + {load_module, asn1rt, soft_purge, soft_purge, []}, + {load_module, asn1rt_per_bin, soft_purge, soft_purge, []}, + {load_module, asn1rt_per_bin_rt2ct, soft_purge, soft_purge, []}, + {load_module, asn1rt_uper_bin, soft_purge, soft_purge, []}, + {load_module, asn1rt_ber_bin, soft_purge, soft_purge, []}, + {load_module, asn1rt_ber_bin_v2, soft_purge, soft_purge, []}, + {load_module, asn1rt_check, soft_purge, soft_purge, []}, + {load_module, asn1rt_driver_handler, soft_purge, soft_purge, []}, + {apply, {asn1rt_driver_handler,unload_driver,[]}} + ] + } + ]}. + + + + diff --git a/lib/asn1/src/asn1_app.erl b/lib/asn1/src/asn1_app.erl new file mode 100644 index 0000000000..2d3eed1743 --- /dev/null +++ b/lib/asn1/src/asn1_app.erl @@ -0,0 +1,38 @@ +%% ``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$ +%% + +%% Purpose : Application master for asn1. + +-module(asn1_app). + +-behaviour(application). + +-export([start/2, stop/1]). + +%% start/2(Type, StartArgs) -> {ok, Pid} | {ok, Pid, State} | +%% {error, Reason} +%% +start(_Type, _StartArgs) -> + asn1_sup:start_link(). + +%% stop(State) +%% +stop(_State) -> + ok. + + diff --git a/lib/asn1/src/asn1_db.erl b/lib/asn1/src/asn1_db.erl new file mode 100644 index 0000000000..f680b3d064 --- /dev/null +++ b/lib/asn1/src/asn1_db.erl @@ -0,0 +1,167 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1997-2009. All Rights Reserved. +%% +%% 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 online 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. +%% +%% %CopyrightEnd% +%% +%% +-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])); + {From,{new_includes,[NewIncludes]}} -> + From ! {asn1db,done}, + dbloop(NewIncludes,Tab) + 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 -> + req({new_includes,Args}) + end. + + diff --git a/lib/asn1/src/asn1_records.hrl b/lib/asn1/src/asn1_records.hrl new file mode 100644 index 0000000000..8a428b744c --- /dev/null +++ b/lib/asn1/src/asn1_records.hrl @@ -0,0 +1,118 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1997-2009. All Rights Reserved. +%% +%% 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 online 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. +%% +%% %CopyrightEnd% +%% +%% + +-ifdef(debug). +-define(dbg(Fmt, Args), ok=io:format("~p: " ++ Fmt, [?LINE|Args])). +-else. +-define(dbg(Fmt, Args), no_debug). +-endif. + +-define('RT_BER_BIN',"asn1rt_ber_bin"). +-define('RT_PER_BIN',"asn1rt_per_bin"). + +%% Some encoding are common for BER and PER. Shared code are in RT_COMMON +-define('RT_COMMON',asn1rt_ber_bin). + +-define('COMPLETE_ENCODE',1). +-define('TLV_DECODE',2). + + +-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,textual_order}). +-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,module}). +-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, + sourcedir}). + +%% state record used by back-end 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 tuples with function names,type etc +%% that have been generated. It is to prevent duplicates of referenced +%% functions, and to generate the correct decode_inc_disp functions. +%% suffix_index is a number that is used as a suffix to make function +%% names unique. It is increased for each additional step into a +%% constructed type in an exclusive decode. +%% current_suffix_index is the index of the top type that is generated +%% at the moment. It may be the same as the current suffix_index or an +%% earlier value of it. +-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=[], + generated_functions=[],suffix_index=1, + current_suffix_index}). diff --git a/lib/asn1/src/asn1_server.erl b/lib/asn1/src/asn1_server.erl new file mode 100644 index 0000000000..aeb59d8b0c --- /dev/null +++ b/lib/asn1/src/asn1_server.erl @@ -0,0 +1,107 @@ +%% ``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$ +%% + +%% Purpose: Provide complete encode/and pre-decode of asn1. +-module(asn1_server). + + + +-behaviour(gen_server). + +-export([start_link/0,client_port/0]). + +%% Internal exports, call-back functions. +-export([init/1,handle_call/3,handle_cast/2,handle_info/2,code_change/3, + terminate/2]). + + +%% Macros +-define(port_names, + { asn1_drv01, asn1_drv02, asn1_drv03, asn1_drv04, + asn1_drv05, asn1_drv06, asn1_drv07, asn1_drv08, + asn1_drv09, asn1_drv10, asn1_drv11, asn1_drv12, + asn1_drv13, asn1_drv14, asn1_drv15, asn1_drv16 }). +%%% -------------------------------------------------------- +%%% Interface Functions. +%%% -------------------------------------------------------- + +start_link() -> + gen_server:start_link({local, asn1_server}, asn1_server, [], []). + +init([]) -> + process_flag(trap_exit, true), + erl_ddll:start(), + PrivDir = code:priv_dir(asn1), + LibDir1 = filename:join([PrivDir, "lib"]), + case erl_ddll:load_driver(LibDir1, asn1_erl_drv) of + ok -> ok; + {error,_} -> + LibDir2 = + filename:join(LibDir1, + erlang:system_info(system_architecture)), + erl_ddll:load_driver(LibDir2, asn1_erl_drv) + end, + open_ports("asn1_erl_drv",size(?port_names)). + +open_ports(_,0) -> + {ok, []}; +open_ports(Cmd,N) -> + Port = open_port({spawn, Cmd}, []), + %% check that driver is loaded, linked and working + case catch port_control(Port, 0, []) of + {'EXIT', _} -> + {stop, nodriver}; + _ -> + register(element(N,?port_names), Port), + open_ports(Cmd,N-1) + end. + +client_port() -> + element(erlang:system_info(scheduler_id) rem size(?port_names) + 1, + ?port_names). + + +%%% -------------------------------------------------------- +%%% The call-back functions. +%%% -------------------------------------------------------- + +handle_call(_, _, State) -> + {noreply, State}. + +handle_cast(_, State) -> + {noreply, State}. + +handle_info({'EXIT', Pid, _Reason}, State) when is_pid(Pid) -> + {noreply, State}; + +handle_info({'EXIT', Port, Reason}, State) when is_port(Port) -> + {stop, {port_died, Reason}, State}; +handle_info(_, State) -> + {noreply, State}. + +code_change(_OldVsn, State, _Extra) -> + {ok, State}. + +terminate(_Reason, _State) -> + close_ports(size(?port_names)). + +close_ports(0) -> + ok; +close_ports(N) -> + element(N,?port_names) ! {self(), close}, %% almost same as port_close(Name) + close_ports(N-1). diff --git a/lib/asn1/src/asn1_sup.erl b/lib/asn1/src/asn1_sup.erl new file mode 100644 index 0000000000..a241dec6f4 --- /dev/null +++ b/lib/asn1/src/asn1_sup.erl @@ -0,0 +1,37 @@ +%% ``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$ +%% + +%% Purpose: Main supervisor in asn1 application. + +-module(asn1_sup). + +-behaviour(supervisor). + +-export([start_link/0, init/1]). + +start_link() -> + supervisor:start_link({local, asn1_sup}, asn1_sup, []). + + +%% init([]) +%% Returns: {ok, {SupFlags, [ChildSpec]}} +%% +init([]) -> + Child = {asn1_server, {asn1_server, start_link, []}, + permanent, 2000, worker, [asn1_server]}, + {ok, {{one_for_all, 10, 3600}, [Child]}}. diff --git a/lib/asn1/src/asn1ct.erl b/lib/asn1/src/asn1ct.erl new file mode 100644 index 0000000000..e6fd3663dd --- /dev/null +++ b/lib/asn1/src/asn1ct.erl @@ -0,0 +1,2520 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1997-2009. All Rights Reserved. +%% +%% 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 online 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. +%% +%% %CopyrightEnd% +%% +%% +-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, + maybe_rename_function/3,latest_sindex/0,current_sindex/0, + set_current_sindex/1,next_sindex/0,maybe_saved_sindex/2, + parse_and_save/2]). + +-include("asn1_records.hrl"). +-include_lib("stdlib/include/erl_compile.hrl"). +-include_lib("kernel/include/file.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(OPTIONAL_UNDECODED,opt_undec). +-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 is_list(Options) -> + Options1 = optimize_ber_bin(Options), + Options2 = includes(File,Options1), + Includes=[I||{i,I}<-Options2], + case (catch input_file_type(File,Includes)) of + {single_file,SuffixedFile} -> %% "e.g. "/tmp/File.asn" + (catch compile1(SuffixedFile,Options2)); + {multiple_files_file,SetBase,FileName} -> + FileList = get_file_list(FileName,Includes), +%% io:format("FileList: ~p~n",[FileList]), + case FileList of + L when is_list(L) -> + (catch compile_set(SetBase,FileList,Options2)); + Err -> + Err + end; + Err = {input_file_error,_Reason} -> + {error,Err}; + Err2 -> Err2 + end. + + +compile1(File,Options) when is_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(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]), + Ret = compile_erl(Continue4,OutFile,Options), + case inline(is_inline(Options), + inline_output(Options,filename:rootname(File)), + lists:concat([OutFile,".erl"]),Options) of + false -> + Ret; + InlineRet -> + InlineRet + end. + + +%%****************************************************************************%% +%% functions dealing with compiling of several input files to one output file %% +%%****************************************************************************%% + +%%% +%% inline/4 +%% merges the resulting erlang modules with +%% the appropriate run-time modules so the resulting module contains all +%% run-time asn1 functionality. Then compiles the resulting file to beam code. +%% The merging is done by the igor module. If this function is used in older +%% versions than R10B the igor module, part of user contribution syntax_tools, +%% must be provided. It is possible to pass options for the ASN1 compiler +%% Types: +%% Name -> atom() +%% Modules -> [filename()] +%% Options -> [term()] +%% filename() -> file:filename() +inline(true,Name,Module,Options) -> + RTmodule = get_runtime_mod(Options), + IgorOptions = igorify_options(remove_asn_flags(Options)), + IgorName = filename:rootname(filename:basename(Name)), +% io:format("*****~nName: ~p~nModules: ~p~nIgorOptions: ~p~n*****~n", +% [IgorName,Modules++RTmodule,IgorOptions]), + io:format("Inlining modules: ~p in ~p~n",[[Module]++RTmodule,IgorName]), + case catch igor:merge(IgorName,[Module]++RTmodule,[{preprocess,true},{stubs,false},{backups,false}]++IgorOptions) of + {'EXIT',{undef,Reason}} -> %% module igor first in R10B + io:format("Module igor in syntax_tools must be available:~n~p~n", + [Reason]), + {error,'no_compilation'}; + {'EXIT',Reason} -> + io:format("Merge by igor module failed due to ~p~n",[Reason]), + {error,'no_compilation'}; + _ -> +%% io:format("compiling output module: ~p~n",[generated_file(Name,IgorOptions)]), + erl_compile(generated_file(Name,IgorOptions),Options) + end; +inline(_,_,_,_) -> + false. + +%% compile_set/3 merges and compiles a number of asn1 modules +%% specified in a .set.asn file to one .erl file. +compile_set(SetBase,Files,Options) + when is_list(hd(Files)),is_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(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 + is_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) -> + + 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]), + + Ret = compile_erl(Continue2,OutFile,Options), + case inline(is_inline(Options), + inline_output(Options,filename:rootname(OutFile)), + lists:concat([OutFile,".erl"]),Options) of + false -> + Ret; + InlineRet -> + InlineRet + end. + +%% 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_mod(D1),unset_pos_mod(D2)). +compare_defs2(D,D) -> + equal; +compare_defs2(_,_) -> + not_equal. + +unset_pos_mod(Def) when is_record(Def,typedef) -> + Def#typedef{pos=undefined}; +unset_pos_mod(Def) when is_record(Def,classdef) -> + Def#classdef{pos=undefined}; +unset_pos_mod(Def) when is_record(Def,valuedef) -> + Def#valuedef{pos=undefined,module=undefined}; +unset_pos_mod(Def) when is_record(Def,ptypedef) -> + Def#ptypedef{pos=undefined}; +unset_pos_mod(Def) when is_record(Def,pvaluedef) -> + Def#pvaluedef{pos=undefined}; +unset_pos_mod(Def) when is_record(Def,pvaluesetdef) -> + Def#pvaluesetdef{pos=undefined}; +unset_pos_mod(Def) when is_record(Def,pobjectdef) -> + Def#pobjectdef{pos=undefined}; +unset_pos_mod(Def) when is_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_pos_of_def(_) -> + undefined. + + +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; +get_name_of_def(_) -> + undefined. + +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]), + lists:foreach(fun(X) -> ets:insert(original_imports,X) end,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 is_record(T,typedef)-> + #'Externaltypereference'{pos=0, + module=MName, + type=T#typedef.name}; + V when is_record(V,valuedef) -> + #'Externalvaluereference'{pos=0, + module=MName, + value=V#valuedef.name}; + C when is_record(C,classdef) -> + #'Externaltypereference'{pos=0, + module=MName, + type=C#classdef.name}; + P when is_record(P,ptypedef) -> + #'Externaltypereference'{pos=0, + module=MName, + type=P#ptypedef.name}; + PV when is_record(PV,pvaluesetdef) -> + #'Externaltypereference'{pos=0, + module=MName, + type=PV#pvaluesetdef.name}; + PO when is_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(Files,Options) -> + %% The files in Files already have their relative path and extension + lists:map( + fun(F)-> + case scan(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(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. + + +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 + is_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) -> + + start(Includes), + case asn1ct_check:storeindb(#state{erule=EncodingRule},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, + sourcedir=filename:dirname(File)}, + 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, + + Result = + case (catch asn1ct_gen:pgen(OutFile,EncodingRule, + M#module.name,GenTOrV)) of + {'EXIT',Reason2} -> + io:format("ERROR: ~p~n",[Reason2]), + {error,Reason2}; + _ -> + ok + end, + 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 Result of + {error,_} -> + {false,Result}; + ok -> + case lists:member(sg,Options) of + true -> % terminate here , with .erl file generated + {false,true}; + false -> + {true,true} + end + end; +generate({false,M},_,_,_) -> + {false,M}. + +%% parse_and_save parses an asn1 spec and saves the unchecked parse +%% tree in a data base file. +%% Does not support multifile compilation files +parse_and_save(Module,S) -> + Options = S#state.options, + SourceDir = S#state.sourcedir, + Includes = [I || {i,I} <-Options], + Options1 = optimize_ber_bin(Options), + + case get_input_file(Module,[SourceDir|Includes]) of + %% search for asn1 source + {file,SuffixedASN1source} -> + case dbfile_uptodate(SuffixedASN1source,Options1) of + false -> + parse_and_save1(S,SuffixedASN1source,Options1,Includes); + _ -> ok + end; + Err -> + io:format("Warning: could not do a consistency check of the ~p file: no asn1 source file was found.~n",[lists:concat([Module,".asn1db"])]), + {error,{asn1,input_file_error,Err}} + end. +parse_and_save1(S,File,Options,Includes) -> + Ext = filename:extension(File), + Base = filename:basename(File,Ext), + DbFile = outfile(Base,"asn1db",Options), + Continue1 = scan(File,Options), + M = + case parse(Continue1,File,Options) of + {true,Mod} -> Mod; + _ -> +%% io:format("~p~nnow I die!!!!!!!!!!!~n",[File]), + exit({error,{asn1,File,"no such file"}}) + end, +% start(["."|Includes]), + start(Includes), + case asn1ct_check:storeindb(S,M) of + ok -> + asn1_db:dbsave(DbFile,M#module.name) + end. + +get_input_file(Module,[]) -> + Module; +get_input_file(Module,[I|Includes]) -> + case (catch input_file_type(filename:join([I,Module]))) of + {single_file,FileName} -> +%% case file:read_file_info(FileName) of +%% {ok,_} -> + {file,FileName}; +%% _ -> get_input_file(Module,Includes) +%% end; + _ -> + get_input_file(Module,Includes) + end. + +dbfile_uptodate(File,Options) -> + EncodingRule = get_rule(Options), + Ext = filename:extension(File), + Base = filename:basename(File,Ext), + DbFile = outfile(Base,"asn1db",Options), + case file:read_file_info(DbFile) of + {error,enoent} -> + false; + {ok,FileInfoDb} -> + %% file exists, check date and finally encodingrule + {ok,FileInfoAsn} = file:read_file_info(File), + case FileInfoDb#file_info.mtime < FileInfoAsn#file_info.mtime of + true -> + %% date of asn1 spec newer than db file + false; + _ -> + %% date ok,check that same erule was used + Obase = case lists:keysearch(outdir, 1, Options) of + {value, {outdir, Odir}} -> + Odir; + _NotFound -> "" + end, + BeamFileName = outfile(Base,"beam",Options), + case file:read_file_info(BeamFileName) of + {ok,_} -> + code:add_path(Obase), + BeamFile = list_to_atom(Base), + BeamInfo = (catch BeamFile:info()), + case catch lists:keysearch(options,1,BeamInfo) of + {value,{options,OldOptions}} -> + case get_rule(OldOptions) of + EncodingRule -> true; + _ -> false + end; + _ -> false + end; + _ -> false + end + end + end. + + +compile_erl({true,_},OutFile,Options) -> + erl_compile(OutFile,Options); +compile_erl({false,true},_,_) -> + ok; +compile_erl({false,Result},_,_) -> + Result. + +input_file_type(Name,I) -> + case input_file_type(Name) of + {error,_} -> input_file_type2(filename:basename(Name),I); + Err={input_file_error,_} -> Err; + Res -> Res + end. +input_file_type2(Name,[I|Is]) -> + case input_file_type(filename:join([I,Name])) of + {error,_} -> input_file_type2(Name,Is); + Err={input_file_error,_} -> Err; + Res -> Res + end; +input_file_type2(Name,[]) -> + input_file_type(Name). + +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 -> + case file:read_file_info(lists:concat([File,".py"])) of + {ok,_FileInfo} -> + {single_file, lists:concat([File,".py"])}; + Error -> + Error + end + 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; + Asn1SFix -> + Base = filename:basename(File,Asn1SFix), + Ret = + case filename:extension(Base) of + [] -> + {single_file,File}; + SetSFix when (SetSFix == ".set") -> + {multiple_files_file, + list_to_atom(filename:basename(Base,SetSFix)), + File}; + _Error -> + throw({input_file_error,{'Bad input file',File}}) + end, + %% check that the file exists + case file:read_file_info(File) of + {ok,_} -> Ret; + Err -> Err + end + end. + +get_file_list(File,Includes) -> + case file:open(File,[read]) of + {error,Reason} -> + {error,{File,file:format_error(Reason)}}; + {ok,Stream} -> + get_file_list1(Stream,filename:dirname(File),Includes,[]) + end. + +get_file_list1(Stream,Dir,Includes,Acc) -> + Ret = io:get_line(Stream,''), + case Ret of + eof -> + file:close(Stream), + lists:reverse(Acc); + FileName -> + SuffixedNameList = + case (catch input_file_type(filename:join([Dir,lists:delete($\n,FileName)]),Includes)) of + {empty_name,[]} -> []; + {single_file,Name} -> [Name]; + {multiple_files_file,_,Name} -> + get_file_list(Name,Includes); + _Err -> + [] + end, + get_file_list1(Stream,Dir,Includes,SuffixedNameList++Acc) + end. + +get_rule(Options) -> + case [Rule ||Rule <-[per,ber,ber_bin,ber_bin_v2,per_bin,uper_bin], + Opt <- Options, + Rule==Opt] of + [Rule] -> + Rule; + [Rule|_] -> + Rule; + [] -> + ber + end. + +get_runtime_mod(Options) -> + RtMod1= + case get_rule(Options) of + per -> ["asn1rt_per_bin.erl"]; + ber -> ["asn1rt_ber_bin.erl"]; + per_bin -> + case lists:member(optimize,Options) of + true -> ["asn1rt_per_bin_rt2ct.erl"]; + _ -> ["asn1rt_per_bin.erl"] + end; + ber_bin -> ["asn1rt_ber_bin.erl"]; + ber_bin_v2 -> ["asn1rt_ber_bin_v2.erl"]; + uper_bin -> ["asn1rt_uper_bin.erl"] + end, + RtMod1++["asn1rt_check.erl","asn1rt_driver_handler.erl","asn1rt.erl"]. + + +erl_compile(OutFile,Options) -> +% io:format("Options:~n~p~n",[Options]), + case lists:member(noobj,Options) of + true -> + ok; + _ -> + ErlOptions = remove_asn_flags(Options), + %% io:format("~n~nc:c(~p,~p)~n~n",[OutFile,ErlOptions]), + 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, + X /= asn1config, + X /= record_name_prefix]. + +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. + +igorify_options(Options) -> + case lists:keysearch(outdir,1,Options) of + {value,{_,Dir}} -> + Options1 = lists:keydelete(outdir,1,Options), + [{dir,Dir}|Options1]; + _ -> + Options + end. + +generated_file(Name,Options) -> + case lists:keysearch(dir,1,Options) of + {value,{_,Dir}} -> + filename:join([Dir,filename:basename(Name)]); + _ -> + Name + end. + +debug_off(_Options) -> + erase(asndebug), + erase(asn_keyed_list). + + +outfile(Base, Ext, Opts) -> +% io:format("Opts. ~p~n",[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; + _ -> + lists:concat([Obase,".",Ext]) + end. + +optimize_ber_bin(Options) -> + case {lists:member(optimize,Options),lists:member(ber_bin,Options)} of + {true,true} -> + [ber_bin_v2|Options--[ber_bin]]; + _ -> Options + end. + +includes(File,Options) -> + Dir = filename:dirname(File), + Options2 = + case lists:member({i,"."},Options) of + false -> Options ++ [{i,"."}]; + _ -> Options + end, + case lists:member({i,Dir}, Options2) of + false -> Options2 ++ [{i,Dir}]; + _ -> Options2 + end. + +is_inline(Options) -> + case lists:member(inline,Options) of + true -> true; + _ -> + lists:keymember(inline,1,Options) + end. +inline_output(Options,Default) -> + case [X||{inline,X}<-Options] of + [OutputName] -> + OutputName; + _ -> + Default + 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 is_tuple(ParseRes) -> + io:format("~p~n",[ParseRes]), + ok; + ScanRes when is_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]; + uper_bin -> [uper_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 is_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 is_list(Module) -> + asn1rt:encode(list_to_atom(Module),Type,Term); +encode(Module,Type,Term) -> + asn1rt:encode(Module,Type,Term). + +decode(Module,Type,Bytes) when is_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 + is_list(Module) -> + list_to_atom(Module); + true -> + Module + end, + NewBytes = + case M:encoding_rule() of + ber -> + lists:flatten(Bytes); + ber_bin when is_binary(Bytes) -> + Bytes; + ber_bin -> + list_to_binary(Bytes); + ber_bin_v2 when is_binary(Bytes) -> + Bytes; + ber_bin_v2 -> + list_to_binary(Bytes); + per -> + lists:flatten(Bytes); + per_bin when is_binary(Bytes) -> + Bytes; + per_bin -> + list_to_binary(Bytes); + uper_bin -> + 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. + +vsn() -> + ?vsn. + + + +print_error_message([got,H|T]) when is_list(H) -> + io:format(" got:"), + print_listing(H,"and"), + print_error_message(T); +print_error_message([expected,H|T]) when is_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 is_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) -> + 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 is_tuple(TsAndVs) -> + %% read configure file + + ModName = + case lists:keysearch(asn1config,1,Options) of + {value,{_,MName}} -> MName; + _ -> M#module.name + end, +%% io:format("ModName: ~p~nM#module.name: ~p~n~n",[ModName,M#module.name]), + CfgList = read_config_file(ModName), + SelectedDecode = get_config_info(CfgList,selective_decode), + ExclusiveDecode = get_config_info(CfgList,exclusive_decode), + CommandList = + create_partial_decode_gen_info(M#module.name,SelectedDecode), + %% To convert CommandList to a proper list for the driver change + %% the list:[[choosen,Tag1],skip,[skip_optional,Tag2]] to L = + %% [5,2,Tag1,0,1,Tag2] where 5 is the length, and call + %% port_control(asn1_driver_port,3,[L| Bin]) + save_config(partial_decode,CommandList), + save_gen_state(selective_decode,SelectedDecode), +% io:format("selective_decode: CommandList:~n~p~nSelectedDecode:~n~p~n", +% [CommandList,SelectedDecode]), + CommandList2 = + create_partial_inc_decode_gen_info(M#module.name,ExclusiveDecode), +% io:format("partial_incomplete_decode = ~p~n",[CommandList2]), + Part_inc_tlv_tags = tlv_tags(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(exclusive_decode,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 is_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 is_list(Comps1),is_list(Comps2) -> + create_pdec_inc_command(ModName,Comps1 ++ Comps2,TNL,Acc); +%% The following two functionclauses matches on the type after the top type. This one if the top type had no tag, i.e. a CHOICE +create_pdec_inc_command(ModN,Clist,[CL|_Rest],[[]]) when is_list(CL) -> + create_pdec_inc_command(ModN,Clist,CL,[]); +create_pdec_inc_command(ModN,Clist,[CL|_Rest],Acc) when is_list(CL) -> + InnerDirectives=create_pdec_inc_command(ModN,Clist,CL,[]), + lists:reverse([InnerDirectives|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,concat_sequential(TagCommand,Acc)); + {Name,parts} -> + TagCommand = get_tag_command(TS,?PARTS,Prop), + create_pdec_inc_command(ModName,Comps,Cs,concat_sequential(TagCommand,Acc)); + L when is_list(L) -> % I guess this never happens due to previous function clause + %% 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 is_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,concat_sequential(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 is_list(List) -> +% [Command,Tag] = get_tag_command(TS,?ALTERNATIVE,Prop), + TagCommand = get_tag_command(TS,?ALTERNATIVE,Prop), + CompAcc = + create_pdec_inc_command(ModName, + get_components(TS#type.def),List,[]), + NewAcc = case TagCommand of + [Command,Tag] when is_atom(Command) -> + [[Command,Tag,CompAcc]|Acc]; + [L1,_L2|Rest] when is_list(L1) -> +% [LastComm|Comms] = lists:reverse(TagCommand), +% [concat_sequential(lists:reverse(Comms), +% [LastComm,CompAcc])|Acc] + case lists:reverse(TagCommand) of + [Atom|Comms] when is_atom(Atom) -> + [concat_sequential(lists:reverse(Comms), + [Atom,CompAcc])|Acc]; + [[Command2,Tag2]|Comms] -> + [concat_sequential(lists:reverse(Comms), + [[Command2,Tag2,CompAcc]])|Acc] + end +% [concat_sequential(lists:reverse(Comms), +% InnerCommand)|Acc] + + end, + create_pdec_inc_command(ModName,{'CHOICE',Comps},Rest, +% [[Command,Tag,CompAcc]|Acc]); + NewAcc); + undecoded -> + TagCommand = get_tag_command(TS,?ALTERNATIVE_UNDECODED,Prop), + create_pdec_inc_command(ModName,{'CHOICE',Comps},Rest, + concat_sequential(TagCommand,Acc)); + parts -> + TagCommand = get_tag_command(TS,?ALTERNATIVE_PARTS,Prop), + create_pdec_inc_command(ModName,{'CHOICE',Comps},Rest, + concat_sequential(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, + concat_sequential(TagCommand,Acc)); +create_pdec_inc_command(M,{'CHOICE',{Cs1,Cs2}},TNL,Acc) + when is_list(Cs1),is_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 is_atom(T) -> + T; +partial_inc_dec_toptype([{T,_}|_]) when is_atom(T) -> + T; +partial_inc_dec_toptype([L|_]) when is_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,TypeLists}) -> + [create_partial_decode_gen_info1(ModName,TL) || TL <- TypeLists]; +create_partial_decode_gen_info(_,[]) -> + []; +create_partial_decode_gen_info(_M1,{M2,_}) -> + throw({error,{"wrong module name in asn1 config file", + M2}}). + +%create_partial_decode_gen_info1(ModName,{ModName,TypeList}) -> +create_partial_decode_gen_info1(ModName,{FuncName,TypeList}) -> + case TypeList of + [TopType|Rest] -> + case asn1_db:dbget(ModName,TopType) of + #typedef{typespec=TS} -> + TagCommand = get_tag_command(TS,?CHOOSEN), + Ret=create_pdec_command(ModName, + get_components(TS#type.def), + Rest,concat_tags(TagCommand,[])), + {FuncName,Ret}; + _ -> + throw({error,{"wrong type list in asn1 config file", + TypeList}}) + end; + _ -> + [] + end; +create_partial_decode_gen_info1(_,_) -> + ok. +% create_partial_decode_gen_info1(_,[]) -> +% []; +% create_partial_decode_gen_info1(_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) -> + Remove_empty_lists = + fun([[]|L],Res,Fun) -> + Fun(L,Res,Fun); + ([],Res,_) -> + Res; + ([H|L],Res,Fun) -> + Fun(L,[H|Res],Fun) + end, + Remove_empty_lists(Acc,[],Remove_empty_lists); +% 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,concat_tags(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],concat_tags(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) -> + #type{def=Def} = get_referenced_type(M,C1), + create_pdec_command(ModName,get_components(Def),TypeNameList, + Acc); +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,concat_tags(TagCommand,Acc)); + [N] when is_integer(N) -> + TagCommand = get_tag_command(TS,?SKIP), + create_pdec_command(ModName,Def,[[N-1]|Cs], + concat_tags(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={C1,C2}}) when is_list(C1),is_list(C2) -> + C1++C2; +get_components(#'SEQUENCE'{components=Components}) -> + Components; +get_components(#'SET'{components={C1,C2}}) when is_list(C1),is_list(C2) -> + C1++C2; +get_components(#'SET'{components=Components}) -> + Components; +get_components({'SEQUENCE OF',Components}) -> + Components; +get_components({'SET OF',Components}) -> + Components; +get_components(Def) -> + Def. + +concat_sequential(L=[A,B],Acc) when is_atom(A),is_binary(B) -> + [L|Acc]; +concat_sequential(L,Acc) when is_list(L) -> + concat_sequential1(lists:reverse(L),Acc); +concat_sequential(A,Acc) -> + [A|Acc]. +concat_sequential1([],Acc) -> + Acc; +concat_sequential1([[]],Acc) -> + Acc; +concat_sequential1([El|RestEl],Acc) when is_list(El) -> + concat_sequential1(RestEl,[El|Acc]); +concat_sequential1([mandatory|RestEl],Acc) -> + concat_sequential1(RestEl,[mandatory|Acc]); +concat_sequential1(L,Acc) -> + [L|Acc]. + + +many_tags([?SKIP])-> + false; +many_tags([?SKIP_OPTIONAL,_]) -> + false; +many_tags([?CHOOSEN,_]) -> + false; +many_tags(_) -> + true. + +concat_tags(Ts,Acc) -> + case many_tags(Ts) of + true when is_list(Ts) -> + lists:reverse(Ts)++Acc; + true -> + [Ts|Acc]; + false -> + [Ts|Acc] + end. +%% 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=[]},_) -> + []; +%% SKIP and SKIP_OPTIONAL shall return only one tag command regardless +get_tag_command(#type{},?SKIP) -> + ?SKIP; +get_tag_command(#type{tag=Tags},?SKIP_OPTIONAL) -> + Tag=hd(Tags), + [?SKIP_OPTIONAL,encode_tag_val(decode_class(Tag#tag.class), + Tag#tag.form,Tag#tag.number)]; +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)]]. + TC = get_tag_command(T#type{tag=[Tag]},Command), + TCs = get_tag_command(T#type{tag=Tags},Command), + case many_tags(TCs) of + true when is_list(TCs) -> + [TC|TCs]; + _ -> [TC|[TCs]] + end. + +%% 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,Prop) -> + [anonymous_dec_command(Command,Prop),encode_tag_val(decode_class(Tag#tag.class),Tag#tag.form, Tag#tag.number)]; +get_tag_command(#type{tag=Tag},Command,Prop) when is_record(Tag,tag) -> + get_tag_command(#type{tag=[Tag]},Command,Prop); +get_tag_command(T=#type{tag=[Tag|Tags]},Command,Prop) -> + [get_tag_command(T#type{tag=[Tag]},Command,Prop)|[ +% get_tag_command(T#type{tag=Tags},?MANDATORY,Prop)]]. + get_tag_command(T#type{tag=Tags},Command,Prop)]]. + +anonymous_dec_command(?UNDECODED,'OPTIONAL') -> + ?OPTIONAL_UNDECODED; +anonymous_dec_command(Command,_) -> + Command. + +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. + + +tlv_tags([]) -> + []; +tlv_tags([mandatory|Rest]) -> + [mandatory|tlv_tags(Rest)]; +tlv_tags([[Command,Tag]|Rest]) when is_atom(Command),is_binary(Tag) -> + [[Command,tlv_tag(Tag)]|tlv_tags(Rest)]; +tlv_tags([[Command,Directives]|Rest]) when is_atom(Command),is_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 is_list(L1),is_atom(TopType) -> + [{Name,TopType,tlv_tags(L1)}|tlv_tags(Rest)]; +tlv_tags([[Command,Tag,L1]|Rest]) when is_list(L1),is_binary(Tag) -> + [[Command,tlv_tag(Tag),tlv_tags(L1)]|tlv_tags(Rest)]; +tlv_tags([[mandatory|Rest]]) -> + [[mandatory|tlv_tags(Rest)]]; +tlv_tags([L=[L1|_]|Rest]) when is_list(L1) -> + [tlv_tags(L)|tlv_tags(Rest)]. + +tlv_tag(<>) when TagNo < 31 -> + (Cl bsl 16) + TagNo; +tlv_tag(<>) -> + (Cl bsl 16) + TagNo; +tlv_tag(<>) -> + 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 is_atom(InfoType) -> + CfgList = read_config_file(ModuleName), + get_config_info(CfgList,InfoType). + + +read_config_file(ModuleName) -> + case file:consult(lists:concat([ModuleName,'.asn1config'])) 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 lists:keysearch(InfoType,1,CfgList) of + {value,{InfoType,Value}} -> + Value; + false -> + [] + end. + +%% save_config/2 saves the Info with the key Key +%% Before saving anything check if a table exists +%% The record gen_state is saved with the key {asn1_config,gen_state} +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 -> % Err is [] when nothing was saved in the ets table +%% 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(exclusive_decode,{_,ConfList},PartIncTlvTagList) -> + %ConfList=[{FunctionName,PatternList}|Rest] + State = + case get_gen_state() of + S when is_record(S,gen_state) -> S; + _ -> #gen_state{} + end, + StateRec = State#gen_state{inc_tag_pattern=PartIncTlvTagList, + inc_type_pattern=ConfList}, + save_config(gen_state,StateRec); +save_gen_state(_,_,_) -> +%% ok. + case get_gen_state() of + S when is_record(S,gen_state) -> ok; + _ -> save_config(gen_state,#gen_state{}) + end. + +save_gen_state(selective_decode,{_,Type_component_name_list}) -> +%% io:format("Selective_decode: ~p~n",[Type_component_name_list]), + State = + case get_gen_state() of + S when is_record(S,gen_state) -> S; + _ -> #gen_state{} + end, + StateRec = State#gen_state{type_pattern=Type_component_name_list}, + save_config(gen_state,StateRec); +save_gen_state(selective_decode,_) -> + ok. + +save_gen_state(GenState) when is_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 when is_record(GenState,gen_state) -> + get_gen_state_field(GenState,Field); + Err -> + exit({error,{asn1,{"false configuration file info",Err}}}) + 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_field(GS,generated_functions) -> + GS#gen_state.generated_functions; +get_gen_state_field(GS,suffix_index) -> + GS#gen_state.suffix_index; +get_gen_state_field(GS,current_suffix_index) -> + GS#gen_state.current_suffix_index. + +get_gen_state() -> + read_config_data(gen_state). + + +update_gen_state(Field,Data) -> + case get_gen_state() of + State when is_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 is_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_gen_state(generated_functions,State,Data) -> + save_gen_state(State#gen_state{generated_functions=Data}); +update_gen_state(suffix_index,State,Data) -> + save_gen_state(State#gen_state{suffix_index=Data}); +update_gen_state(current_suffix_index,State,Data) -> + save_gen_state(State#gen_state{current_suffix_index=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 is_list(List) -> update_gen_state(namelist,List); + [{Name,Atom}|Rest] when is_atom(Atom) -> update_gen_state(namelist,Rest); + Other -> Other + end. + +pop_namelist() -> + DeepTail = %% removes next element in order + fun([[{_,A}]|T],_Fun) when is_atom(A) -> T; + ([{_N,L}|T],_Fun) when is_list(L) -> [L|T]; + ([[]|T],Fun) -> Fun(T,Fun); + ([L1|L2],Fun) when is_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 is_list(L) -> next_namelist_el(L) + end. + +next_namelist_el([]) -> + []; +next_namelist_el([L]) when is_list(L) -> + next_namelist_el(L); +next_namelist_el([H|_]) when is_atom(H) -> + H; +next_namelist_el([L|T]) when is_list(L) -> + case next_namelist_el(L) of + [] -> + next_namelist_el([T]); + R -> + R + end; +next_namelist_el([H={_,A}|_]) when is_atom(A) -> + H. + +%% removes a bracket from the namelist +step_in_constructed() -> + case get_gen_state_field(namelist) of + [L] when is_list(L) -> + update_gen_state(namelist,L); + _ -> ok + end. + +is_function_generated(Name) -> + case get_gen_state_field(gen_refed_funcs) of + L when is_list(L) -> + lists:member(Name,L); + _ -> + false + end. + +get_tobe_refed_func(Name) -> + case get_gen_state_field(tobe_refed_funcs) of + L when is_list(L) -> + case lists:keysearch(Name,1,L) of + {_,Element} -> + Element; + _ -> + undefined + end; + _ -> + undefined + end. + +%% add_tobe_refed_func saves Data that is a three or four element +%% tuple. Do not save if it exists in generated_functions, because +%% then it will be or already is generated. +add_tobe_refed_func(Data) -> + %% + {Name,SI,Pattern} = + fun({N,Si,P,_}) -> {N,Si,P}; + (D) -> D end (Data), + NewData = + case SI of + I when is_integer(I) -> + fun(D) -> D end(Data); +% fun({N,Ix,P}) -> {N,Ix+1,P}; +% ({N,Ix,P,T}) -> {N,Ix+1,P,T} end (Data); + _ -> + fun({N,_,P}) -> {N,0,P}; + ({N,_,P,T}) -> {N,0,P,T} end (Data) + end, + + L = get_gen_state_field(generated_functions), + case generated_functions_member(get(currmod),Name,L,Pattern) of + true -> % it exists in generated_functions, it has already + % been generated or saved in tobe_refed_func + ok; + _ -> + add_once_tobe_refed_func(NewData), + %%only to get it saved in generated_functions + maybe_rename_function(tobe_refed,Name,Pattern) + end. + + + +%% Adds only one element with same Name and Index where Data = +%% {Name,Index,Pattern}. +add_once_tobe_refed_func(Data) -> + TRFL = get_gen_state_field(tobe_refed_funcs), + {Name,Index} = {element(1,Data),element(2,Data)}, + case lists:filter(fun({N,I,_}) when N==Name,I==Index ->true; + ({N,I,_,_}) when N==Name,I==Index -> true; + (_) -> false end,TRFL) of + [] -> +%% case lists:keysearch(element(1,Data),1,TRFL) of +%% false -> + update_gen_state(tobe_refed_funcs,[Data|TRFL]); + _ -> + ok + end. + + + +%% 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]). + +%% adds Data to gen_refed_funcs field in gen_state. +add_generated_refed_func(Data) -> + case is_function_generated(Data) of + true -> + ok; + _ -> + L = get_gen_state_field(gen_refed_funcs), + update_gen_state(gen_refed_funcs,[Data|L]) + end. + +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{}). + +%% adds Data to generated_functions field in gen_state. +add_generated_function(Data) -> + L = get_gen_state_field(generated_functions), + update_gen_state(generated_functions,[Data|L]). + + +%% Each type has its own index starting from 0. If index is 0 there is +%% no renaming. +maybe_rename_function(Mode,Name,Pattern) -> + case get_gen_state_field(generated_functions) of + [] when Mode==inc_disp -> add_generated_function({Name,0,Pattern}), + Name; + [] -> + exit({error,{asn1,internal_error_exclusive_decode}}); + L -> + case {Mode,generated_functions_member(get(currmod),Name,L)} of + {_,true} -> + L2 = generated_functions_filter(get(currmod),Name,L), + case lists:keysearch(Pattern,3,L2) of + false -> %name existed, but not pattern + NextIndex = length(L2), + %%rename function + Suffix = lists:concat(["_",NextIndex]), + NewName = + maybe_rename_function2(type_check(Name),Name, + Suffix), + add_generated_function({Name,NextIndex,Pattern}), + NewName; + Value -> % name and pattern existed + %% do not save any new index + Suffix = make_suffix(Value), + Name2 = + case Name of + #'Externaltypereference'{type=T} -> T; + _ -> Name + end, + lists:concat([Name2,Suffix]) + end; + {inc_disp,_} -> %% this is when + %% decode_partial_inc_disp/2 is + %% generated + add_generated_function({Name,0,Pattern}), + Name; + _ -> % this if call from add_tobe_refed_func + add_generated_function({Name,0,Pattern}), + Name + end + end. + + +maybe_rename_function2(record,#'Externaltypereference'{type=Name},Suffix) -> + lists:concat([Name,Suffix]); +maybe_rename_function2(list,List,Suffix) -> + lists:concat([asn1ct_gen:list2name(List),Suffix]); +maybe_rename_function2(Thing,Name,Suffix) + when Thing==atom;Thing==integer;Thing==string -> + lists:concat([Name,Suffix]). + +%% generated_functions_member/4 checks on both Name and Pattern if +%% the element exists in L +generated_functions_member(M,Name,L,Pattern) -> + case generated_functions_member(M,Name,L) of + true -> + L2 = generated_functions_filter(M,Name,L), + case lists:keysearch(Pattern,3,L2) of + {value,_} -> + true; + _ -> false + end; + _ -> false + end. + +generated_functions_member(_M,Name,[{Name,_,_}|_]) -> + true; +generated_functions_member(M,#'Externaltypereference'{module=M,type=T}, + [{#'Externaltypereference'{module=M,type=T} + ,_,_}|_]) -> + true; +generated_functions_member(M,#'Externaltypereference'{module=M,type=Name}, + [{Name,_,_}|_]) -> + true; +generated_functions_member(M,Name,[_|T]) -> + generated_functions_member(M,Name,T); +generated_functions_member(_,_,[]) -> + false. + +% generated_functions_member(M,Name,L) -> +% case lists:keymember(Name,1,L) of +% true -> +% true; +% _ -> +% generated_functions_member1(M,Name,L) +% end. +% generated_functions_member1(M,#'Externaltypereference'{module=M,type=Name},L) -> +% lists:keymember(Name,1,L); +% generated_functions_member1(_,_,_) -> false. + +generated_functions_filter(_,Name,L) when is_atom(Name);is_list(Name) -> + lists:filter(fun({N,_,_}) when N==Name -> true; + (_) -> false + end, L); +generated_functions_filter(M,#'Externaltypereference'{module=M,type=Name},L)-> + % remove toptypename from patterns + RemoveTType = + fun({N,I,[N,P]}) when N == Name -> + {N,I,P}; + ({#'Externaltypereference'{module=M1,type=N},I,P}) when M1==M -> + {N,I,P}; + (P) -> P + end, + L2 = lists:map(RemoveTType,L), + generated_functions_filter(M,Name,L2). + + +maybe_saved_sindex(Name,Pattern) -> + case get_gen_state_field(generated_functions) of + [] -> false; + L -> + case generated_functions_member(get(currmod),Name,L) of + true -> + L2 = generated_functions_filter(get(currmod),Name,L), + case lists:keysearch(Pattern,3,L2) of + {value,{_,I,_}} -> + I; + _ -> length(L2) % this should be length(L2)! + end; + _ -> false + end + end. + +next_sindex() -> + SI = get_gen_state_field(suffix_index), + update_gen_state(suffix_index,SI+1), + SI+1. + +latest_sindex() -> + get_gen_state_field(suffix_index). + +current_sindex() -> + get_gen_state_field(current_suffix_index). + +set_current_sindex(Index) -> + update_gen_state(current_suffix_index,Index). + + +type_check(A) when is_atom(A) -> + atom; +%% type_check(I) when is_integer(I) -> +%% integer; +type_check(L) when is_list(L) -> + Pred = fun(X) when X=<255 -> + false; + (_) -> true + end, + case lists:filter(Pred,L) of + [] -> + string; + _ -> + list + end; +type_check(#'Externaltypereference'{}) -> + record. + + make_suffix({_,{_,0,_}}) -> + ""; + make_suffix({_,{_,I,_}}) -> + lists:concat(["_",I]); + make_suffix(_) -> + "". diff --git a/lib/asn1/src/asn1ct_check.erl b/lib/asn1/src/asn1ct_check.erl new file mode 100644 index 0000000000..f0a48a086b --- /dev/null +++ b/lib/asn1/src/asn1ct_check.erl @@ -0,0 +1,7399 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1997-2009. All Rights Reserved. +%% +%% 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 online 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. +%% +%% %CopyrightEnd% +%% +%% +-module(asn1ct_check). + +%% Main Module for ASN.1 compile time functions + +%-compile(export_all). +-export([check/2,storeindb/2]). +%-define(debug,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_UTF8String, 12). +-define('N_RELATIVE-OID',13). +-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, + Element1 = fun(X) -> element(1,X) end, + + %% initialize internal book keeping + save_asn1db_uptodate(S,S#state.erule,S#state.mname), + put(top_module,S#state.mname), + + _Perror = checkp(S,ParameterizedTypes,[]), % must do this before the templates are used + + %% table to save instances of parameterized objects,object sets + asn1ct:create_ets_table(parameterized_objects,[named_table]), + asn1ct:create_ets_table(inlined_objects,[named_table]), + + + Terror = checkt(S,Types,[]), + ?dbg("checkt finished with errors:~n~p~n~n",[Terror]), + + %% 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 + ?dbg("checkv finished with errors:~n~p~n~n",[Verror]), + %% 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,[]), + ?dbg("checkc finished with errors:~n~p~n~n",[Cerror]), + %% 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), + + {Oerror,ExclO,ExclOS} = checko(S,NewObjects ++ + NewObjectSets, + [],[],[]), + ?dbg("checko finished with errors:~n~p~n~n",[Oerror]), + InlinedObjTuples = ets:tab2list(inlined_objects), + InlinedObjects = lists:map(Element2,InlinedObjTuples), + ets:delete(inlined_objects), + ParameterizedElems = ets:tab2list(parameterized_objects), + ParObjectSets = lists:filter(fun({_OSName,objectset,_}) -> true; + (_)-> false end,ParameterizedElems), + ParObjectSetNames = lists:map(Element1,ParObjectSets), + ParTypes = lists:filter(fun({_TypeName,type,_}) -> true; + (_) -> false end, ParameterizedElems), + ParTypesNames = lists:map(Element1,ParTypes), + ets:delete(parameterized_objects), + put(asn1_reference,undefined), + + Exporterror = check_exports(S,S#state.module), + ImportError = check_imports(S,S#state.module), + + case {Terror3,Verror5,Cerror,Oerror,Exporterror,ImportError} of + {[],[],[],[],[],[]} -> + ContextSwitchTs = context_switch_in_spec(), + InstanceOf = instance_of_in_spec(S#state.mname), + NewTypes = lists:subtract(Types,AddClasses) ++ ContextSwitchTs + ++ InstanceOf ++ ParTypesNames, + 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)++ParObjectSetNames}}; + _ ->{error,{asn1,lists:flatten([Terror3,Verror5,Cerror, + Oerror,Exporterror,ImportError])}} + 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(ModName) -> + case get(instance_of) of + L when is_list(L) -> + case lists:member(ModName,L) of + true -> + erase(instance_of), + ['INSTANCE OF']; + _ -> + erase(instance_of), + [] + end; + _ -> + [] + end. +instance_of_decl(ModName) -> + Mods = get_instance_of(), + case lists:member(ModName,Mods) of + true -> + ok; + _ -> + put(instance_of,[ModName|Mods]) + end. +get_instance_of() -> + case get(instance_of) of + undefined -> + []; + L -> + L + end. + +put_once(T,State) -> + %% state is one of undefined, unchecked, generate + %% undefined > unchecked > generate + case get(T) of + PrevS when PrevS > State -> + put(T,State); + _ -> + ok + 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 is_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. + +check_imports(S,Module = #module{ }) -> + case Module#module.imports of + {imports,[]} -> + []; + {imports,ImportList} when is_list(ImportList) -> + check_imports2(S,ImportList,[]); + _ -> + [] + end. +check_imports2(_S,[],Acc) -> + Acc; +check_imports2(S,[#'SymbolsFromModule'{symbols=Imports,module=ModuleRef}|SFMs],Acc) -> + NameOfDef = + fun(#'Externaltypereference'{type=N}) -> N; + (#'Externalvaluereference'{value=N}) -> N + end, + Module = NameOfDef(ModuleRef), + Refs = [{M,R}||{{M,_},R} <- [{catch get_referenced_type(S,Ref),Ref}||Ref <- Imports]], + {Illegal,Other} = lists:splitwith(fun({error,_}) -> true;(_) -> false end, + Refs), + ChainedRefs = [R||{M,R} <- Other, M =/= Module], + IllegalRefs = [R||{error,R} <- Illegal] ++ + [R||{M,R} <- ChainedRefs, + ok =/= chained_import(S,Module,M,NameOfDef(R))], + ReportError = + fun(Ref) -> + NewS=S#state{type=Ref,tname=NameOfDef(Ref)}, + error({import,"imported undefined entity",NewS}) + end, + check_imports2(S,SFMs,[ReportError(Err)||Err <- IllegalRefs]++Acc). + +chained_import(S,ImpMod,DefMod,Name) -> + %% Name is a referenced structure that is not defined in ImpMod, + %% but must be present in the Imports list of ImpMod. The chain of + %% imports of Name must end in DefMod. + NameOfDef = + fun(#'Externaltypereference'{type=N}) -> N; + (#'Externalvaluereference'{value=N}) -> N; + (Other) -> Other + end, + GetImports = + fun(_M_) -> + case asn1_db:dbget(_M_,'MODULE') of + #module{imports={imports,ImportList}} -> + ImportList; + _ -> [] + end + end, + FindNameInImports = + fun([],N,_) -> {no_mod,N}; + ([#'SymbolsFromModule'{symbols=Imports,module=ModuleRef}|SFMs],N,F) -> + case [NameOfDef(X)||X <- Imports, NameOfDef(X) =:= N] of + [] -> F(SFMs,N,F); + [N] -> {NameOfDef(ModuleRef),N} + end + end, + case GetImports(ImpMod) of + [] -> + error; + Imps -> + case FindNameInImports(Imps,Name,FindNameInImports) of + {no_mod,_} -> + error; + {DefMod,_} -> ok; + {OtherMod,_} -> + chained_import(S,OtherMod,DefMod,Name) + end + end. + +checkt(S,[Name|T],Acc) -> + ?dbg("Checking type ~p~n",[Name]), + Result = + case asn1_db:dbget(S#state.mname,Name) of + undefined -> + error({type,{internal_error,'???'},S}); + Type when is_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}, + + 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) -> + ?dbg("Checking valuedef ~p~n",[Name]), + Result = case asn1_db:dbget(S#state.mname,Name) of + undefined -> error({value,{internal_error,'???'},S}); + Value when is_record(Value,valuedef); + is_record(Value,typedef); %Value set may be parsed as object set. + is_record(Value,pvaluedef); + is_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, + ClassName = Type#type.def, + 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 is_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}; + {asn1_param_class,_} -> ok; + 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 + is_record(Class,classdef) -> +% Class#classdef.typespec; + Class; + is_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 + is_record(Class,classdef) -> + Class#classdef{checked=true,typespec=C}; + is_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) -> + ?dbg("Checking object ~p~n",[Name]), + Result = + case asn1_db:dbget(S#state.mname,Name) of + undefined -> + error({type,{internal_error,'???'},S}); + Object when is_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 + is_record(O,'Object') -> + case O#'Object'.gen of + true -> + {ok,ExclO,ExclOS}; + false -> + {ok,[Name|ExclO],ExclOS} + end; + is_record(O,'ObjectSet') -> + case O#'ObjectSet'.gen of + true -> + {ok,ExclO,ExclOS}; + false -> + {ok,ExclO,[Name|ExclOS]} + end + end + end; + PObject when is_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 is_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; + _ -> + store_class(S,idle,CDef,Name), + CheckedTS = check_class(S,TS), + store_class(S,true,CDef#classdef{typespec=CheckedTS},Name), + CheckedTS + end; +check_class(S = #state{mname=M,tname=T},ClassSpec) + when is_record(ClassSpec,type) -> + Def = ClassSpec#type.def, + case Def of + #'Externaltypereference'{module=M,type=T} -> + #objectclass{fields=Def}; % in case of recursive definitions + Tref = #'Externaltypereference'{type=TName} -> + {MName,RefType} = get_referenced_type(S,Tref), + case is_class(S,RefType) of + true -> + NewState = update_state(S#state{type=RefType, + tname=TName},MName), + check_class(NewState,get_class_def(S,RefType)); + _ -> + error({class,{internal_error,RefType},S}) + end; + {pt,ClassRef,Params} -> + %% parameterized class + {_,PClassDef} = get_referenced_type(S,ClassRef), + NewParaList = + [match_parameters(S,TmpParam,S#state.parameters)|| + TmpParam <- Params], + instantiate_pclass(S,PClassDef,NewParaList) + end; +check_class(S,C) when is_record(C,objectclass) -> + NewFieldSpec = check_class_fields(S,C#objectclass.fields), + C#objectclass{fields=NewFieldSpec}; +check_class(_S,{poc,_ObjSet,_Params}) -> + 'fix this later'; +check_class(S,ClassName) -> + {RefMod,Def} = get_referenced_type(S,ClassName), + case Def of + ClassDef when is_record(ClassDef,classdef) -> + case ClassDef#classdef.checked of + true -> + ClassDef#classdef.typespec; + idle -> + ClassDef#classdef.typespec; + false -> + Name=ClassName#'Externaltypereference'.type, + store_class(S,idle,ClassDef,Name), +% NewS = S#state{mname=RefMod,type=Def,tname=Name}, + NewS = update_state(S#state{type=Def,tname=Name},RefMod), + CheckedTS = check_class(NewS,ClassDef#classdef.typespec), + store_class(S,true,ClassDef#classdef{typespec=CheckedTS},Name), + CheckedTS + end; + TypeDef when is_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 is_record(Ext,'Externaltypereference') -> + check_class(S,Ext) + end + end. + +instantiate_pclass(S=#state{parameters=_OldArgs},PClassDef,Params) -> + #ptypedef{args=Args,typespec=Type} = PClassDef, + MatchedArgs = match_args(S,Args, Params, []), +% NewS = S#state{type=Type,parameters=MatchedArgs++OldArgs,abscomppath=[]}, + NewS = S#state{type=Type,parameters=MatchedArgs,abscomppath=[]}, + check_class(NewS,#classdef{name=S#state.tname,typespec=Type}). + +store_class(S,Mode,ClassDef,ClassName) -> + NewCDef = ClassDef#classdef{checked=Mode}, + asn1_db:dbput(S#state.mname,ClassName,NewCDef). + +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, + Type2 = maybe_unchecked_OCFT(S,Type), + Cat = + case asn1ct_gen:type(asn1ct_gen:get_inner(Type2#type.def)) of + Def when is_record(Def,typereference); + is_record(Def,'Externaltypereference') -> + {_,D} = get_referenced_type(S,Def), + D; + {undefined,user} -> + %% neither of {primitive,bif} or {constructed,bif} + + {_,D} = get_referenced_type(S,#'Externaltypereference'{module=S#state.mname,type=Type#type.def}), + D; + _ -> + Type + end, + case Cat of + Class when is_record(Class,classdef) -> + %% Type must be a referenced type => change it + %% to an external reference. + ToExt = fun(#type{def= CE = #'Externaltypereference'{}}) -> CE; (T) -> T end, + {objectfield,Name,ToExt(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 = + 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 is_record(CheckedType,type) -> + CheckedType; + _ -> + error({class,"internal error, check_class_fields",S}) + end, + if + is_record(RefType,'Externaltypereference') -> + {objectsetfield,Name,Type,OSpec}; + is_record(RefType,classdef) -> + {objectsetfield,Name,Type,OSpec}; + is_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). + +maybe_unchecked_OCFT(S,Type) -> + case Type#type.def of + #'ObjectClassFieldType'{type=undefined} -> + check_type(S,#typedef{typespec=Type},Type); + _ -> + Type + end. + +if_current_checked_type(S,#type{def=Def}) -> + CurrentModule = S#state.mname, + CurrentCheckedName = S#state.tname, + MergedModules = S#state.inputmodules, + % CurrentCheckedModule = S#state.mname, + case Def of + #'Externaltypereference'{module=CurrentModule, + 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 is_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=get_datastr_name(Def)}, + {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}) -> + ?dbg("check_object ~p~n",[ObjectDef]), +%% io:format("check_object,object: ~p~n",[ObjectDef]), +% {MName,_ClassDef} = get_referenced_type(S,ClassRef), + NewClassRef = check_externaltypereference(S,ClassRef), + ClassDef = + case get_referenced_type(S,ClassRef) of + {MName,ClDef=#classdef{checked=false}} -> + NewState = update_state(S#state{type=ClDef, + tname=ClassRef#'Externaltypereference'.type},MName), + ObjClass= + check_class(NewState,ClDef), + #classdef{checked=true, + typespec=ObjClass}; + {_,_ClDef} when is_record(_ClDef,classdef) -> + _ClDef; + {MName,_TDef=#typedef{checked=false,pos=Pos, + name=_TName,typespec=TS}} -> + ClDef = #classdef{pos=Pos,name=_TName,typespec=TS}, + NewState = update_state(S#state{type=_TDef, + tname=ClassRef#'Externaltypereference'.type},MName), + ObjClass = + check_class(NewState,ClDef), + ClDef#classdef{checked=true,typespec=ObjClass}; + {_,_ClDef} -> + _ClDef + end, + NewObj = + case ObjectDef of + Def when is_tuple(Def), (element(1,Def)==object) -> + NewSettingList = check_objectdefn(S,Def,ClassDef), + #'Object'{def=NewSettingList}; + {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 + %% a not initialized parameterized object should be returned. + instantiate_po(S,ClassDef,Object,ArgsList); + {pv,{simpledefinedvalue,ObjRef},ArgList} -> + {_,Object} = get_referenced_type(S,ObjRef), + instantiate_po(S,ClassDef,Object,ArgList); + #'Externalvaluereference'{} -> + {_,Object} = get_referenced_type(S,ObjectDef), + check_object(S,Object,Object#typedef.typespec); + [] -> + %% An object with no fields. All class fields must be + %% optional or default. Check that all fields in + %% class are 'OPTIONAL' or 'DEFAULT' + class_fields_optional_check(S,ClassDef), + #'Object'{def={object,defaultsyntax,[]}}; + _ -> + 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=#'ObjectSet'{class=ClassRef}) -> +%% io:format("check_object,SET: ~p~n",[ObjSet#'ObjectSet'.set]), + ?dbg("check_object set: ~p~n",[ObjSet#'ObjectSet'.set]), + {_,ClassDef} = get_referenced_type(S,ClassRef), + NewClassRef = check_externaltypereference(S,ClassRef), + %% XXXXXXXXXX + case ObjSet of + #'ObjectSet'{set={'Externaltypereference',undefined,'MSAccessProtocol', + 'AllOperations'}} -> + ok; + _ -> + ok + end, + {UniqueFieldName,UniqueInfo} = + case (catch get_unique_fieldname(S,ClassDef)) of + {error,'__undefined_',_} -> + {{unique,undefined},{unique,undefined}}; + {asn1,Msg,_} -> error({class,Msg,S}); + {'EXIT',Msg} -> error({class,{internal_error,Msg},S}); + Other -> {element(1,Other),Other} + end, + NewObjSet= + case prepare_objset(ObjSet#'ObjectSet'.set) of + {set,SET,EXT} -> + CheckedSet = check_object_list(S,NewClassRef,SET), + NewSet = get_unique_valuelist(S,CheckedSet,UniqueInfo), + ObjSet#'ObjectSet'{uniquefname=UniqueFieldName, + set=extensionmark(NewSet,EXT)}; + + {'SingleValue',ERef = #'Externalvaluereference'{}} -> + {RefedMod,ObjDef} = get_referenced_type(S,ERef), + #'Object'{def=CheckedObj} = + check_object(S,ObjDef,ObjDef#typedef.typespec), + + NewSet = get_unique_valuelist(S,[{{RefedMod,get_datastr_name(ObjDef)}, + CheckedObj}], + UniqueInfo), + ObjSet#'ObjectSet'{uniquefname=UniqueFieldName, + set=NewSet}; + ['EXTENSIONMARK'] -> + ObjSet#'ObjectSet'{uniquefname=UniqueFieldName, + set=['EXTENSIONMARK']}; + + OSref when is_record(OSref,'Externaltypereference') -> + {_,OS=#typedef{typespec=OSdef}} = get_referenced_type(S,OSref), + check_object(S,OS,OSdef); + + {Type,{'EXCEPT',Exclusion}} when is_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), + NewParamList = + [match_parameters(S,TmpParam,S#state.parameters)|| + TmpParam <- ParamList], + instantiate_pos(S,ClassRef,PObjSetDef,NewParamList); + + %% actually this is an ObjectSetFromObjects construct, it + %% is when the object set is retrieved from an object + %% field. + #type{def=#'ObjectClassFieldType'{classname=ObjName, + fieldname=FieldName}} -> + {RefedObjMod,TDef} = get_referenced_type(S,ObjName), + OS=TDef#typedef.typespec, + %% should get the right object set here. Get the field + %% FieldName out of the object set OS of class + %% OS#'ObjectSet'.class + OS2=check_object(S,TDef,OS), + NewSet=object_set_from_objects(S,RefedObjMod,FieldName,OS2), + ObjSet#'ObjectSet'{uniquefname=UniqueFieldName, + set=NewSet}; + {'ObjectSetFromObjects',{_,_,ObjName},FieldName} -> + {RefedObjMod,TDef} = get_referenced_type(S,ObjName), + OS=TDef#typedef.typespec, + %% should get the right object set here. Get the field + %% FieldName out of the object set OS of class + %% OS#'ObjectSet'.class + OS2=check_object(S,TDef,OS), + NewSet=object_set_from_objects(S,RefedObjMod,FieldName,OS2), + ObjSet#'ObjectSet'{uniquefname=UniqueFieldName, + set=NewSet}; + {'ObjectSetFromObjects',{_,ObjName},FieldName} -> + %% This is a ObjectSetFromObjects, i.e. + %% ObjectSetFromObjects ::= ReferencedObjects "." FieldName + %% with a defined object as ReferencedObjects. And + %% the FieldName of the Class (object) contains an object set. + {RefedObjMod,TDef} = get_referenced_type(S,ObjName), + O1 = TDef#typedef.typespec, + O2 = check_object(S,TDef,O1), + NewSet = object_set_from_objects(S,RefedObjMod,FieldName,O2), + OS2=ObjSet#'ObjectSet'{uniquefname=UniqueFieldName, + set=NewSet}, + %%io:format("ObjectSet: ~p~n",[OS2]), + OS2; + {pos,{objectset,_,DefinedObjSet},Params} -> + {_,PObjSetDef} = get_referenced_type(S,DefinedObjSet), + NewParamList = + [match_parameters(S,TmpParam,S#state.parameters)|| + TmpParam <- Params], + instantiate_pos(S,ClassRef,PObjSetDef,NewParamList); + Unknown -> + exit({error,{unknown_object_set,Unknown},S}) + end, + NewSet2 = remove_duplicate_objects(NewObjSet#'ObjectSet'.set), + NewObjSet2 = NewObjSet#'ObjectSet'{set=NewSet2}, + Gen = gen_incl_set(S,NewObjSet2#'ObjectSet'.set, + ClassDef), + ?dbg("check_object done~n",[]), + NewObjSet2#'ObjectSet'{class=NewClassRef,gen=Gen}. + +%% remove_duplicate_objects/1 remove duplicates of objects. +%% For instance may Set contain objects of same class from +%% different object sets that in fact might be duplicates. +remove_duplicate_objects(Set) when is_list(Set) -> + Pred = fun({A,B,_},{A,C,_}) when B =< C -> true; + ({A,_,_},{B,_,_}) when A < B -> true; + ('EXTENSIONMARK','EXTENSIONMARK') -> true; + (T,A) when is_tuple(T),is_atom(A) -> true;% EXTENSIONMARK last in list + (_,_) -> false + end, + lists:usort(Pred,Set). + +%% +extensionmark(L,true) -> + case lists:member('EXTENSIONMARK',L) of + true -> L; + _ -> L ++ ['EXTENSIONMARK'] + end; +extensionmark(L,_) -> + L. + +object_to_check(#typedef{typespec=ObjDef}) -> + ObjDef; +object_to_check(#valuedef{type=ClassName,value=ObjectRef}) -> + %% If the object definition is parsed as an object the ClassName + %% is parsed as a type + #'Object'{classname=ClassName#type.def,def=ObjectRef}. + +prepare_objset({'SingleValue',Set}) when is_list(Set) -> + {set,Set,false}; +prepare_objset(L=['EXTENSIONMARK']) -> + L; +prepare_objset(Set) when is_list(Set) -> + {set,Set,false}; +prepare_objset({{'SingleValue',Set},Ext}) -> + {set,merge_sets(Set,Ext),true}; +%%prepare_objset({Set,Ext}) when is_list(Set),is_list(Ext) -> +%% {set,lists:append([Set,Ext]),true}; +prepare_objset({Set,Ext}) when is_list(Set) -> + {set,merge_sets(Set,Ext),true}; +prepare_objset({ObjDef={object,definedsyntax,_ObjFields},_Ext}) -> + {set,[ObjDef],true}; +prepare_objset(ObjDef={object,definedsyntax,_ObjFields}) -> + {set,[ObjDef],false}; +prepare_objset({ObjDef=#type{},Ext}) when is_list(Ext) -> + {set,[ObjDef|Ext],true}; +prepare_objset(Ret) -> + Ret. + +class_fields_optional_check(S,#classdef{typespec=ClassSpec}) -> + Fields = ClassSpec#objectclass.fields, + class_fields_optional_check1(S,Fields). + +class_fields_optional_check1(_S,[]) -> + ok; +class_fields_optional_check1(S,[{typefield,_,'OPTIONAL'}|Rest]) -> + class_fields_optional_check1(S,Rest); +class_fields_optional_check1(S,[{fixedtypevaluefield,_,_,_,'OPTIONAL'}|Rest]) -> + class_fields_optional_check1(S,Rest); +class_fields_optional_check1(S,[{fixedtypevaluesetfield,_,_,'OPTIONAL'}|Rest]) -> + class_fields_optional_check1(S,Rest); +class_fields_optional_check1(S,[{objectfield,_,_,_,'OPTIONAL'}|Rest]) -> + class_fields_optional_check1(S,Rest); +class_fields_optional_check1(S,[{objectsetfield,_,_,'OPTIONAL'}|Rest]) -> + class_fields_optional_check1(S,Rest). + +%% ObjectSetFromObjects functionality + +%% The fieldname is a list of field names.They may be objects or +%% object sets. If ObjectSet is an object set the resulting object set +%% is the union of object sets if the last field name is an object +%% set. If the last field is an object the resulting object set is +%% the set of objects in ObjectSet. +object_set_from_objects(S,RefedObjMod,FieldName,ObjectSet) -> + object_set_from_objects(S,RefedObjMod,FieldName,ObjectSet,[]). +object_set_from_objects(S,RefedObjMod,FieldName,ObjectSet,InterSect) + when is_record(ObjectSet,'ObjectSet') -> + #'ObjectSet'{class=Cl,set=Set} = ObjectSet, + {_,ClassDef} = get_referenced_type(S,Cl), + object_set_from_objects(S,RefedObjMod,ClassDef,FieldName,Set,InterSect,[]); +object_set_from_objects(S,RefedObjMod,FieldName,Object,InterSect) + when is_record(Object,'Object') -> + #'Object'{classname=Cl,def=Def}=Object, + object_set_from_objects(S,RefedObjMod,Cl,FieldName,[Def],InterSect,[]). +object_set_from_objects(S,RefedObjMod,ClassDef,FieldName,['EXTENSIONMARK'|Os], + InterSect,Acc) -> + object_set_from_objects(S,RefedObjMod,ClassDef,FieldName,Os,InterSect,%%Acc); + ['EXTENSIONMARK'|Acc]); +object_set_from_objects(S,RefedObjMod,ClassDef,FieldName,[O|Os],InterSect,Acc) -> + case object_set_from_objects2(S,mod_of_obj(RefedObjMod,element(1,O)), + ClassDef,FieldName,element(3,O),InterSect) of + ObjS when is_list(ObjS) -> + object_set_from_objects(S,RefedObjMod,ClassDef,FieldName,Os,InterSect,ObjS++Acc); + Obj -> + object_set_from_objects(S,RefedObjMod,ClassDef,FieldName,Os,InterSect,[Obj|Acc]) + end; +object_set_from_objects(_S,_RefedObjMod,_ClassDef,_FieldName,[],InterSect,Acc) -> + %% For instance may Acc contain objects of same class from + %% different object sets that in fact might be duplicates. + remove_duplicate_objects(osfo_intersection(InterSect,Acc)). +%% Acc. +object_set_from_objects2(S,RefedObjMod,ClassDef,[{valuefieldreference,OName}], + Fields,_InterSect) -> + %% this is an object + case lists:keysearch(OName,1,Fields) of + {value,{_,TDef}} -> + mk_object_set_from_object(S,RefedObjMod,TDef,ClassDef); + _ -> + [] % it may be an absent optional field + end; +object_set_from_objects2(S,RefedObjMod,ClassDef,[{typefieldreference,OSName}], + Fields,_InterSect) -> + %% this is an object set + case lists:keysearch(OSName,1,Fields) of + {value,{_,TDef}} -> + case TDef#typedef.typespec of + #'ObjectSet'{class=_NextClName,set=NextSet} ->%% = TDef#typedef.typespec, + NextSet; + #'Object'{def=_ObjDef} -> + mk_object_set_from_object(S,RefedObjMod,TDef,ClassDef) +%% ObjDef + %% error({error,{internal,unexpected_object,TDef}}) + end; + _ -> + [] % it may be an absent optional field + end; +object_set_from_objects2(S,RefedObjMod,_ClassDef,[{valuefieldreference,OName}|Rest], + Fields,InterSect) -> + %% this is an object + case lists:keysearch(OName,1,Fields) of + {value,{_,TDef}} -> + #'Object'{classname=NextClName,def=ODef}=TDef#typedef.typespec, + {_,_,NextFields}=ODef, + {_,NextClass} = get_referenced_type(S,NextClName), + object_set_from_objects2(S,RefedObjMod,NextClass,Rest,NextFields,InterSect); + _ -> + [] + end; +object_set_from_objects2(S,RefedObjMod,_ClassDef,[{typefieldreference,OSName}|Rest], + Fields,InterSect) -> + %% this is an object set + Next = {NextClName,NextSet} = + case lists:keysearch(OSName,1,Fields) of + {value,{_,TDef}} when is_record(TDef,'ObjectSet') -> + #'ObjectSet'{class=NextClN,set=NextS} = TDef, + {NextClN,NextS}; + {value,{_,#typedef{typespec=OS}}} -> + %% objectsets in defined syntax will come here as typedef{} + %% #'ObjectSet'{class=NextClN,set=NextS} = OS, + case OS of + #'ObjectSet'{class=NextClN,set=NextS} -> + {NextClN,NextS}; + #'Object'{classname=NextClN,def=NextDef} -> + {NextClN,[NextDef]} + end; + _ -> + {[],[]} + end, + case Next of + {[],[]} -> + []; + _ -> + {_,NextClass} = get_referenced_type(S,NextClName), + object_set_from_objects(S,RefedObjMod,NextClass,Rest,NextSet,InterSect,[]) + end. + +mk_object_set_from_object(S,RefedObjMod,TDef,Class) -> + #'Object'{classname=_NextClName,def=ODef} = TDef#typedef.typespec, + {_,_,NextFields}=ODef, + + UniqueFieldName = + case (catch get_unique_fieldname(S,Class)) of + {error,'__undefined_',_} -> {unique,undefined}; + {asn1,Msg,_} -> error({class,Msg,S}); + {'EXIT',Msg} -> error({class,{internal_error,Msg},S}); + {Other,_} -> Other + end, + VDef = get_unique_value(S,NextFields,UniqueFieldName), + %% XXXXXXXXXXX + case VDef of + [] -> + ['EXTENSIONMARK']; + _ -> + {{RefedObjMod,get_datastr_name(TDef)},VDef,NextFields} + end. + + +mod_of_obj(_RefedObjMod,{NewMod,ObjName}) + when is_atom(NewMod),is_atom(ObjName) -> + NewMod; +mod_of_obj(RefedObjMod,_) -> + RefedObjMod. + + +merge_sets(Root,{'SingleValue',Ext}) -> + merge_sets(Root,Ext); +merge_sets(Root,Ext) when is_list(Root),is_list(Ext) -> + Root ++ Ext; +merge_sets(Root,Ext) when is_list(Ext) -> + [Root|Ext]; +merge_sets(Root,Ext) when is_list(Root) -> + Root++[Ext]; +merge_sets(Root,Ext) -> + [Root]++[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) -> + ?dbg("check_object_list: ~p~n",[ObjOrSet]), + case ObjOrSet of + ObjDef when is_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_mod,no_name},Def#'Object'.def}|Acc]); + {'SingleValue',Ref = #'Externalvaluereference'{}} -> + ?dbg("{SingleValue,Externalvaluereference}~n",[]), + {RefedMod,ObjName, + #'Object'{def=Def}} = check_referenced_object(S,Ref), + check_object_list(S,ClassRef,Objs,[{{RefedMod,ObjName},Def}|Acc]); + ObjRef when is_record(ObjRef,'Externalvaluereference') -> + ?dbg("Externalvaluereference~n",[]), + {RefedMod,ObjName, + #'Object'{def=Def}} = check_referenced_object(S,ObjRef), + check_object_list(S,ClassRef,Objs,[{{RefedMod,ObjName},Def}|Acc]); + {'ValueFromObject',{_,Object},FieldName} -> + {_,Def} = get_referenced_type(S,Object), + TypeDef = get_fieldname_element(S,Def,FieldName), + (TypeDef#typedef.typespec)#'ObjectSet'.set; + ObjSet when is_record(ObjSet,type) -> + ObjSetDef = + case ObjSet#type.def of + Ref when is_record(Ref,typereference); + is_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); + {pos,{objectset,_,DefinedObjectSet},Params} -> + OSDef = #type{def={pt,DefinedObjectSet,Params}}, + #'ObjectSet'{set=Set} = + check_object(S,ObjOrSet,#'ObjectSet'{class=ClassRef, + set=OSDef}), + check_object_list(S,ClassRef,Objs,Set ++ Acc); + {pv,{simpledefinedvalue,DefinedObject},Params} -> + Args = [match_parameters(S,Param,S#state.parameters)|| + Param<-Params], + #'Object'{def=Def} = + check_object(S,ObjOrSet, + #'Object'{classname=ClassRef , + def={po,{object,DefinedObject}, + Args}}), + check_object_list(S,ClassRef,Objs,[{{no_mod,no_name},Def}|Acc]); + {'ObjectSetFromObjects',Os,FieldName} when is_tuple(Os) -> + NewSet = + check_ObjectSetFromObjects(S,element(size(Os),Os), + FieldName,[]), + check_object_list(S,ClassRef,Objs,NewSet++Acc); + {{'ObjectSetFromObjects',Os,FieldName},InterSection} + when is_tuple(Os) -> + NewSet = + check_ObjectSetFromObjects(S, element(size(Os),Os), + FieldName,InterSection), + check_object_list(S,ClassRef,Objs,NewSet++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). + +check_referenced_object(S,ObjRef) + when is_record(ObjRef,'Externalvaluereference')-> + case get_referenced_type(S,ObjRef) of + {RefedMod,ObjectDef} when is_record(ObjectDef,valuedef) -> + ?dbg("Externalvaluereference, ObjectDef: ~p~n",[ObjectDef]), + #type{def=ClassRef} = ObjectDef#valuedef.type, + Def = ObjectDef#valuedef.value, + {RefedMod,get_datastr_name(ObjectDef), + check_object(update_state(S,RefedMod),ObjectDef,#'Object'{classname=ClassRef, + def=Def})}; + {RefedMod,ObjectDef} when is_record(ObjectDef,typedef) -> + {RefedMod,get_datastr_name(ObjectDef), + check_object(update_state(S,RefedMod),ObjectDef,ObjectDef#typedef.typespec)} + end. + +check_ObjectSetFromObjects(S,ObjName,FieldName,InterSection) -> + {RefedMod,TDef} = get_referenced_type(S,ObjName), + ObjOrSet = check_object(update_state(S,RefedMod),TDef,TDef#typedef.typespec), + InterSec = prepare_intersection(S,InterSection), + _NewSet = object_set_from_objects(S,RefedMod,FieldName,ObjOrSet,InterSec). + +prepare_intersection(_S,[]) -> + []; +prepare_intersection(S,{'EXCEPT',ObjRef}) -> + except_names(S,ObjRef); +prepare_intersection(_S,T) -> + exit({error,{internal_error,not_implemented,object_set_from_objects,T}}). +except_names(_S,{'SingleValue',#'Externalvaluereference'{value=ObjName}}) -> + [{except,ObjName}]; +except_names(_,T) -> + exit({error,{internal_error,not_implemented,object_set_from_objects,T}}). + +osfo_intersection(InterSect,ObjList) -> + Res = [X|| X = {{_,N},_,_} <- ObjList, + lists:member({except,N},InterSect) == false], + case lists:member('EXTENSIONMARK',ObjList) of + true -> + Res ++ ['EXTENSIONMARK']; + _ -> + Res + 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 is_record(Def,typedef) -> + {_,_,ObjComps} = (Def#typedef.typespec)#'Object'.def, + check_fieldname_element(S,lists:keysearch(FieldName,1,ObjComps)); +get_fieldname_element(S,Def,[{_RefType,FieldName}|Rest]) + when is_record(Def,typedef) -> + %% As FieldName is followd by other FieldNames it has to be an + %% object or objectset. + {_,_,ObjComps} = (Def#typedef.typespec)#'Object'.def, + NewDef = check_fieldname_element(S,lists:keysearch(FieldName,1,ObjComps)), + ObjDef = fun(#'Object'{def=D}) -> D; + (#'ObjectSet'{set=Set}) -> Set + end + (NewDef), + case ObjDef of + L when is_list(L) -> + [get_fieldname_element(S,X,Rest) || X <- L]; + _ -> + get_fieldname_element(S,ObjDef,Rest) + end; +get_fieldname_element(S,{object,_,Fields},[{_RefType,FieldName}|Rest]) -> + NewDef = check_fieldname_element(S,lists:keysearch(FieldName,1,Fields)), + get_fieldname_element(S,NewDef,Rest); +get_fieldname_element(_S,Def,[]) -> + Def; +get_fieldname_element(_S,Def,[{_RefType,_FieldName}|_RestFName]) + when is_record(Def,typedef) -> + ok. + +check_fieldname_element(S,{value,{_,Def}}) -> + check_fieldname_element(S,Def); +check_fieldname_element(S,TDef) when is_record(TDef,typedef) -> + check_type(S,TDef,TDef#typedef.typespec); +check_fieldname_element(S,VDef) when is_record(VDef,valuedef) -> + check_value(S,VDef); +check_fieldname_element(S,Eref) + when is_record(Eref,'Externaltypereference'); + is_record(Eref,'Externalvaluereference') -> + {_,TDef}=get_referenced_type(S,Eref), + check_fieldname_element(S,TDef); +check_fieldname_element(S,Other) -> + throw({error,{assigned_object_error,"not_assigned_object",Other,S}}). + +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,no_unique_value,F}; + (V={_,_,_}) ->V; + ({A,B}) -> {A,no_unique_value,B} + end, ObjSet); +get_unique_valuelist(S,ObjSet,{UFN,Opt}) -> + get_unique_vlist(S,ObjSet,UFN,Opt,[]). + + +get_unique_vlist(_S,[],_,_,[]) -> + ['EXTENSIONMARK']; +get_unique_vlist(S,[],_,Opt,Acc) -> + case catch check_uniqueness(remove_duplicate_objects(Acc)) of + {asn1_error,_} when Opt =/= 'OPTIONAL' -> + error({'ObjectSet',"not unique objects in object set",S}); + {asn1_error,_} -> + lists:reverse(Acc); + _ -> + lists:reverse(Acc) + end; +get_unique_vlist(S,['EXTENSIONMARK'|Rest],UniqueFieldName,Opt,Acc) -> + get_unique_vlist(S,Rest,UniqueFieldName,Opt,Acc); +get_unique_vlist(S,[{ObjName,Obj}|Rest],UniqueFieldName,Opt,Acc) -> + {_,_,Fields} = Obj, + NewObjInf = + case get_unique_value(S,Fields,UniqueFieldName) of + #valuedef{value=V} -> [{ObjName,V,Fields}]; + [] -> []; % maybe the object only was a reference to an + % empty object set. + no_unique_value -> [{ObjName,no_unique_value,Fields}] + end, + get_unique_vlist(S,Rest,UniqueFieldName,Opt,NewObjInf++Acc); + +get_unique_vlist(S,[V={_,_,_}|Rest],UniqueFieldName,Opt,Acc) -> + get_unique_vlist(S,Rest,UniqueFieldName,Opt,[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 is_record(VDef,valuedef) -> + VDef; + {'ValueFromObject',Object,Name} -> + case Object of + {object,Ext} when is_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 is_atom(Value);is_number(Value) -> + #valuedef{value=Value,module=Module}; + {'CHOICE',{C,Value}} when is_atom(C) -> + %% #valuedef{value=normalize_value(S,element(3,Field),VDef,[])} + case Value of + Scalar when is_atom(Scalar);is_number(Scalar) -> + #valuedef{value=Value,module=Module}; + Eref = #'Externalvaluereference'{} -> + element(2,get_referenced_type(S,Eref)) + end + end; + false -> + case Fields of + [{_,#typedef{typespec=#'ObjectSet'{set=['EXTENSIONMARK']}}}] -> + []; + _ -> + no_unique_value + end + 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=#state{parameters=_OldArgs},_ClassDef,Object,ArgsList) when is_record(Object,pobjectdef) -> + FormalParams = get_pt_args(Object), + MatchedArgs = match_args(S,FormalParams,ArgsList,[]), +% NewS = S#state{type=Object,parameters=MatchedArgs++OldArgs}, + 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=#state{parameters=_OldArgs},ClassRef,ObjectSetDef,ArgsList) -> +% ClassName = ClassDef#classdef.name, + FormalParams = get_pt_args(ObjectSetDef), + OSet = case get_pt_spec(ObjectSetDef) of + {valueset,Set} -> +% #'ObjectSet'{class=name2Extref(S#state.mname, +% ClassName),set=Set}; + #'ObjectSet'{class=ClassRef,set=Set}; + Set when is_record(Set,'ObjectSet') -> Set; + _ -> + error({type,"parameterized object set failure",S}) + end, + MatchedArgs = match_args(S,FormalParams,ArgsList,[]), +% NewS = S#state{type=ObjectSetDef,parameters=MatchedArgs++OldArgs}, + NewS = S#state{type=ObjectSetDef,parameters=MatchedArgs}, + check_object(NewS,ObjectSetDef,OSet). + + +%% 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 -> + 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} -> + ClassRef = case element(3,C) of + #type{def=Ref} -> Ref; + Eref when is_record(Eref,'Externaltypereference') -> + Eref + end, + ClassFields = get_objclass_fields(S,ClassRef), + ObjDef = + case element(2,Field) of + TDef when is_record(TDef,typedef) -> + check_object(S,TDef,TDef#typedef.typespec); + ERef -> + {_,T} = get_referenced_type(S,ERef), + check_object(S,T,object_to_check(T)) + end, + case gen_incl(S,ObjDef#'Object'.def, + ClassFields) of + true -> + true; + _ -> + gen_incl1(S,Fields,CFields) + end; + _ -> + gen_incl1(S,Fields,CFields) + end; + _ -> + gen_incl1(S,Fields,CFields) + end. + +get_objclass_fields(S,Eref=#'Externaltypereference'{}) -> + {_,ClassDef} = get_referenced_type(S,Eref), + get_objclass_fields(S,ClassDef); +get_objclass_fields(S,CD=#classdef{typespec=#'Externaltypereference'{}}) -> + get_objclass_fields(S,CD#classdef.typespec); +get_objclass_fields(_,#classdef{typespec=CDef}) + when is_record(CDef,objectclass) -> + CDef#objectclass.fields. + + +%% first if no unique field in the class return false.(don't generate code) +gen_incl_set(S,Fields,#typedef{typespec=#type{def=Eref}}) + when is_record(Eref,'Externaltypereference') -> + %% When a Defined class is a reference toanother class definition + {_,CDef} = get_referenced_type(S,Eref), + gen_incl_set(S,Fields,CDef); +gen_incl_set(S,Fields,ClassDef) -> + case catch get_unique_fieldname(S,ClassDef) of + Tuple when is_tuple(Tuple), size(Tuple) =:= 3 -> + 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(_,['EXTENSIONMARK'|_],_) -> + true; +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 is_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 is_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,RestFields} = + convert_to_defaultfield(S,FName,[Spec|Fields],CField), + check_defaultfields(S,RestFields,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) -> + {MatchedField,RestFields,RestWS} = + match_field(S,Fields,WithSyntax,ClassFields), + if + is_list(MatchedField) -> + convert_definedsyntax(S,RestFields,RestWS,ClassFields, + lists:append(MatchedField,Acc)); + true -> + convert_definedsyntax(S,RestFields,RestWS,ClassFields, + [MatchedField|Acc]) + end. + +match_field(S,Fields,WithSyntax,ClassFields) -> + match_field(S,Fields,WithSyntax,ClassFields,[]). + +match_field(S,Fields,[W|Ws],ClassFields,Acc) when is_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 is_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 is_list(W) -> + case catch match_optional_field(S,Fields,W,ClassFields,[]) of + {'EXIT',_} when length(Ws) > 0 -> + match_optional_field(S,Fields,Ws,ClassFields,Ret); + {'EXIT',_} -> + {Ret,Fields}; + {asn1,{optional_matcherror,_,_}} when length(Ws) > 0 -> + match_optional_field(S,Fields,Ws,ClassFields,Ret); + {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], + [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); +%% am optional setting inside another optional setting may be "double-listed" +match_optional_field(S,[Setting],DefinedSyntax,ClassFields,Ret) + when is_list(Setting) -> + match_optional_field(S,Setting,DefinedSyntax,ClassFields,Ret); +%% identify and save field data +match_optional_field(S,[Setting|Rest],[{_,W}|Ws],ClassFields,Ret) -> + ?dbg("matching optional field setting: ~p with user friendly syntax: ~p~n",[Setting,W]), + WorS = + case Setting of + Type when is_record(Type,type) -> Type; + {'ValueFromObject',_,_} -> Setting; + {object,_,_} -> Setting; + {_,_,WordOrSetting} -> WordOrSetting; + Other -> Other + end, + case lists:keysearch(W,2,ClassFields) of + false -> + throw({asn1,{optional_matcherror,WorS,W}}); + {value,CField} -> + {NewField,RestFields} = + convert_to_defaultfield(S,W,[WorS|Rest],CField), + match_optional_field(S,RestFields,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 is_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 is_list(W) -> +match_mandatory_field(_S,Fields,WithSyntax=[W|_Ws],_ClassFields,Acc) when is_list(W), length(Acc) >= 1 -> + {Acc,Fields,WithSyntax}; +%% identify and skip word +%%match_mandatory_field(S,[{_,_,WorS}|Rest], +match_mandatory_field(S,[{_,_,#'Externaltypereference'{type=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) -> + ?dbg("matching field setting: ~p with user friendly syntax: ~p~n",[Setting,W]), + WorS = + case Setting of + {object,_,_} -> Setting; + {_,_,WordOrSetting} -> WordOrSetting; + Type when is_record(Type,type) -> Type; + Other -> Other + end, + case lists:keysearch(W,2,ClassFields) of + false -> + throw({asn1,{mandatory_matcherror,WorS,W}}); + {value,CField} -> + {NewField,RestFields} = + convert_to_defaultfield(S,W,[WorS|Rest],CField), + match_mandatory_field(S,RestFields,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 +%% A field may be a type, a fixed type value, an object, an objectset, +%% +convert_to_defaultfield(S,ObjFieldName,[OFS|RestOFS],CField)-> + ?dbg("convert field: ~p of type: ~p~n",[ObjFieldName,element(1,CField)]), + CurrMod = S#state.mname, + Strip_value_tag = + fun({value_tag,ValueSetting}) -> ValueSetting; + (VS) -> VS + end, + ObjFieldSetting = Strip_value_tag(OFS), + RestSettings = [Strip_value_tag(X)||X <- RestOFS], + case element(1,CField) of + typefield -> + TypeDef= + case ObjFieldSetting of + TypeRec when is_record(TypeRec,type) -> TypeRec#type.def; + TDef when is_record(TDef,typedef) -> + TDef#typedef{checked=true, + typespec=check_type(S,TDef, + TDef#typedef.typespec)}; + _ -> ObjFieldSetting + end, + {Type,SettingsLeft} = + if + is_record(TypeDef,typedef) -> {TypeDef,RestSettings}; + is_record(TypeDef,'ObjectClassFieldType') -> + T=check_type(S,#typedef{typespec=ObjFieldSetting},ObjFieldSetting), + {oCFT_def(S,T),RestSettings}; +% #typedef{checked=true,name=Name,typespec=IT}; + is_tuple(TypeDef), element(1,TypeDef) == pt -> + %% this is an inlined type. If constructed + %% type save in data base + T=check_type(S,#typedef{typespec=ObjFieldSetting},ObjFieldSetting), + #'Externaltypereference'{type=PtName} = + element(2,TypeDef), + NameList = [PtName,S#state.tname], + NewName = list_to_atom(asn1ct_gen:list2name(NameList)), + NewTDef=#typedef{checked=true,name=NewName, + typespec=T}, + asn1_db:dbput(S#state.mname,NewName,NewTDef), + %%asn1ct_gen:insert_once(parameterized_objects,{NewName,type,NewTDef}), + insert_once(S,parameterized_objects, + {NewName,type,NewTDef}), + {NewTDef,RestSettings}; + is_tuple(TypeDef), element(1,TypeDef)=='SelectionType' -> + T=check_type(S,#typedef{typespec=ObjFieldSetting}, + ObjFieldSetting), + Name = type_name(S,T), + {#typedef{checked=true,name=Name,typespec=T},RestSettings}; + true -> + case asn1ct_gen:type(asn1ct_gen:get_inner(TypeDef)) of + ERef = #'Externaltypereference'{module=CurrMod} -> + {RefMod,T} = get_referenced_type(S,ERef), + check_and_save(S,ERef#'Externaltypereference'{module=RefMod},T,RestSettings); + + ERef = #'Externaltypereference'{} -> + {RefMod,T} = get_referenced_type(S,ERef), + check_and_save(S,ERef#'Externaltypereference'{module=RefMod},T,RestSettings); + Bif when Bif=={primitive,bif};Bif=={constructed,bif} -> + T = check_type(S,#typedef{typespec=ObjFieldSetting}, + ObjFieldSetting), + {#typedef{checked=true,name=Bif,typespec=T},RestSettings}; + _OCFT = #'ObjectClassFieldType'{} -> + T=check_type(S,#typedef{typespec=ObjFieldSetting},ObjFieldSetting), + %%io:format("OCFT=~p~n,T=~p~n",[OCFT,T]), + {#typedef{checked=true,typespec=T},RestSettings}; + _ -> + %this case should not happen any more + {Mod,T} = + get_referenced_type(S,#'Externaltypereference'{module=S#state.mname,type=ObjFieldSetting}), + case Mod of + CurrMod -> + {T,RestSettings}; + ExtMod -> + #typedef{name=Name} = T, + {T#typedef{name={ExtMod,Name}},RestSettings} + end + end + end, + {{ObjFieldName,Type},SettingsLeft}; + fixedtypevaluefield -> + case ObjFieldName of + Val when is_atom(Val) -> + %% ObjFieldSetting can be a value,an objectidentifiervalue, + %% an element in an enumeration or namednumberlist etc. + ValRef = + case ObjFieldSetting of + ValSetting=#'Externalvaluereference'{} -> + ValSetting; + {'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); + ValSetting = #valuedef{} -> + ValSetting; + ValSetting = {'CHOICE',{Alt,_ChVal}} when is_atom(Alt) -> + #valuedef{type=element(3,CField), + value=ValSetting, + module=S#state.mname}; + ValSetting -> + #identifier{val=ValSetting} + end, + ?dbg("fixedtypevaluefield ValRef: ~p~n",[ValRef]), + case ValRef of + #valuedef{} -> + {{ObjFieldName,check_value(S,ValRef)},RestSettings}; + _ -> + ValDef = + case catch get_referenced_type(S,ValRef) of + {error,_} -> + NewValDef = + #valuedef{name=Val, + type=element(3,CField), + value=ObjFieldSetting, + module=S#state.mname}, + check_value(S,NewValDef); + {M,VDef} when is_record(VDef,valuedef) -> + check_value(update_state(S,M), + %%S#state{mname=M}, + VDef);%% XXX + {M,VDef} -> + check_value(update_state(S,M), + %%S#state{mname=M}, + #valuedef{name=Val, + type=element(3,CField), + value=VDef, + module=M}) + end, + {{ObjFieldName,ValDef},RestSettings} + end; + Val -> + {{ObjFieldName,Val},RestSettings} + end; + fixedtypevaluesetfield -> + {{ObjFieldName,ObjFieldSetting},RestSettings}; + objectfield -> + CheckObject = + fun(O) -> + O#typedef{checked=true,typespec= + check_object(S,O,O#typedef.typespec)} + end, + ObjectSpec = + case ObjFieldSetting of + Ref when is_record(Ref,'Externalvaluereference') -> + %% The object O might be a #valuedef{} if + %% e.g. the definition looks like + %% myobj SOMECLASS ::= referencedObject + {M,O} = get_referenced_type(S,Ref), + check_object(S,O,object_to_check(O)), + Ref#'Externalvaluereference'{module=M}; + + {'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), + CheckObject(ObjFromObj); + ObjDef={object,_,_} -> + %% An object defined inlined in another object + %% class is an objectfield, that implies that + %% {objectsetfield,TypeFieldName,DefinedObjecClass, + %% OptionalitySpec} + %% DefinedObjecClass = #'Externaltypereference'{}| + %% 'TYPE-IDENTIFIER' | 'ABSTRACT-SYNTAX' + ClassName = element(3,CField), + InlinedObjName= + list_to_atom(lists:concat([S#state.tname]++ + ['_',ObjFieldName])), + + ObjSpec = #'Object'{classname=ClassName, + def=ObjDef}, + CheckedObj= + check_object(S,#typedef{typespec=ObjSpec},ObjSpec), + InlObj = #typedef{checked=true,name=InlinedObjName, + typespec=CheckedObj}, + ObjKey = {InlinedObjName,InlinedObjName}, + %% asn1ct_gen:insert_once(inlined_objects,ObjKey), + insert_once(S,inlined_objects,ObjKey), + %% Which module to use here? Could it be other than top_module ? + %% asn1_db:dbput(S#state.mname,InlinedObjName,InlObj), + asn1_db:dbput(get(top_module),InlinedObjName,InlObj), + InlObj; + #type{def=Eref} when is_record(Eref,'Externaltypereference') -> + {_,O} = get_referenced_type(S,Eref), + CheckObject(O); + Other -> + {_,O} = get_referenced_type(S,#'Externaltypereference'{module=S#state.mname,type=Other}), + CheckObject(O) + end, + {{ObjFieldName,ObjectSpec},RestSettings}; + variabletypevaluefield -> + {{ObjFieldName,ObjFieldSetting},RestSettings}; + variabletypevaluesetfield -> + {{ObjFieldName,ObjFieldSetting},RestSettings}; +%% objectset_or_fixedtypevalueset_field -> +%% ok; + objectsetfield -> + ObjSetSpec = get_objectset_def(S,ObjFieldSetting,CField), + ?dbg("objectsetfield, ObjSetSpec:~p~n",[ObjSetSpec]), + {{ObjFieldName, + ObjSetSpec#typedef{checked=true, + typespec=check_object(S,ObjSetSpec, + ObjSetSpec#typedef.typespec)}},RestSettings} + end. + +get_objectset_def(S,Ref,CField) + when is_record(Ref,'Externaltypereference'); + is_record(Ref,'Externalvaluereference') -> + {_M,T}=get_referenced_type(S,Ref), + get_objectset_def2(S,T,CField); +get_objectset_def(S,ObjectList,CField) when is_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 + ?dbg("objectsetfield: ~p~n",[CField]), + get_objectset_def2(S,ObjectList,CField); +get_objectset_def(S,'EXTENSIONMARK',CField) -> + ?dbg("objectsetfield: ~p~n",[CField]), + get_objectset_def2(S,['EXTENSIONMARK'],CField); +get_objectset_def(_S,ObjFieldSetting={'SingleValue',_},CField) -> + %% a Union of defined objects + ?dbg("objectsetfield, SingleValue~n",[]), + union_of_defed_objs(CField,ObjFieldSetting); +get_objectset_def(_S,ObjFieldSetting={{'SingleValue',_},_},CField) -> + %% a Union of defined objects + ?dbg("objectsetfield, SingleValue~n",[]), + union_of_defed_objs(CField,ObjFieldSetting); +get_objectset_def(S,{object,_,[#type{def={'TypeFromObject', + {object,RefedObj}, + FieldName}}]},_CField) -> + %% This case occurs when an ObjectSetFromObjects + %% production is used + {_M,Def} = get_referenced_type(S,RefedObj), + get_fieldname_element(S,Def,FieldName); +get_objectset_def(S,{object,_,[{setting,_,ERef}]},CField) + when is_record(ERef,'Externaltypereference') -> + {_,T} = get_referenced_type(S,ERef), + get_objectset_def2(S,T,CField); +get_objectset_def(S,#type{def=ERef},_CField) + when is_record(ERef,'Externaltypereference') -> + {_,T} = get_referenced_type(S,ERef), + T; +get_objectset_def(S,ObjFieldSetting,CField) + when is_atom(ObjFieldSetting) -> + ERef = #'Externaltypereference'{module=S#state.mname, + type=ObjFieldSetting}, + {_,T} = get_referenced_type(S,ERef), + get_objectset_def2(S,T,CField). + +get_objectset_def2(_S,T = #typedef{typespec=#'Object'{}},_CField) -> + #typedef{typespec=#'Object'{classname=Class,def=Def}} = T, + T#typedef{typespec=#'ObjectSet'{class=Class,set=[Def]}}; +get_objectset_def2(_S,Set,CField) when is_list(Set) -> + {_,_,Type,_} = CField, + ClassDef = Type#type.def, + #typedef{typespec=#'ObjectSet'{class=ClassDef, + set=Set}}; +get_objectset_def2(_S,T = #typedef{typespec=#'ObjectSet'{}},_CField) -> + T; +get_objectset_def2(_S,T,_CField) -> + io:format("Warning get_objectset_def2: uncontrolled object set structure:~n~p~n",[T]). + +type_name(S,#type{def=Def}) -> + CurrMod = S#state.mname, + case asn1ct_gen:type(asn1ct_gen:get_inner(Def)) of + #'Externaltypereference'{module=CurrMod,type=Name} -> + Name; + #'Externaltypereference'{module=Mod,type=Name} -> + {Mod,Name}; + Bif when Bif=={primitive,bif};Bif=={constructed,bif} -> + Bif + end. + +merged_name(#state{inputmodules=[]},ERef) -> + ERef; +merged_name(S,ERef=#'Externaltypereference'{module=M}) -> + case {S#state.mname,lists:member(M,S#state.inputmodules)} of + {M,_} -> + ERef; + {MergeM,true} -> + %% maybe the reference is renamed + NewName = renamed_reference(S,ERef), + ERef#'Externaltypereference'{module=MergeM,type=NewName}; + {_,_} -> % i.e. M /= MergeM, not an inputmodule + ERef + end. + +oCFT_def(S,T) -> + case get_OCFT_inner(S,T) of + ERef=#'Externaltypereference'{} -> ERef; + {Name,Type} -> #typedef{checked=true,name=Name,typespec=Type}; + 'ASN1_OPEN_TYPE' -> + #typedef{checked=true,typespec=T#type{def='ASN1_OPEN_TYPE'}} + end. + +get_OCFT_inner(_S,T) -> +% Module=S#state.mname, + Def = T#type.def, + case Def#'ObjectClassFieldType'.type of + {fixedtypevaluefield,_,InnerType} -> + case asn1ct_gen:type(asn1ct_gen:get_inner(InnerType#type.def)) of + Bif when Bif=={primitive,bif};Bif=={constructed,bif} -> + {Bif,InnerType}; + ERef = #'Externaltypereference'{} -> + ERef + end; + 'ASN1_OPEN_TYPE' -> 'ASN1_OPEN_TYPE' + end. + + + +union_of_defed_objs({_,_,_ObjClass=#type{def=ClassDef},_},ObjFieldSetting) -> + #typedef{typespec=#'ObjectSet'{class = ClassDef, + set = ObjFieldSetting}}; +union_of_defed_objs({_,_,DefObjClassRef,_},ObjFieldSetting) + when is_record(DefObjClassRef,'Externaltypereference') -> + #typedef{typespec=#'ObjectSet'{class = DefObjClassRef, + set = ObjFieldSetting}}. + + +check_value(OldS,V) when is_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 is_record(Class,classdef) -> + throw({pobjectsetdef}); + _ -> continue + end + end; +check_value(_OldS,V) when is_record(V,pvaluedef) -> + %% Fix this case later + V; +check_value(OldS,V) when is_record(V,typedef) -> + %% This case when a value set has been parsed as an object set. + %% It may be a value set + ?dbg("check_value, V: ~p~n",[V]), + #typedef{typespec=TS} = V, + case TS of + #'ObjectSet'{class=ClassRef} -> + {RefM,TSDef} = get_referenced_type(OldS,ClassRef), + %%IsObjectSet(TSDef); + case TSDef of + #classdef{} -> throw({objectsetdef}); + #typedef{typespec=#type{def=Eref}} when + is_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, + module=RefM}), + {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 is_record(V,valuedef) -> + #valuedef{name=Name,checked=Checked,type=Vtype, + value=Value,module=ModName} = V, + ?dbg("check_value, V: ~p~n",[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}, + SVal = update_state(S,ModName), + NewDef = + case Def of + Ext when is_record(Ext,'Externaltypereference') -> + RecName = Ext#'Externaltypereference'.type, + {RefM,Type} = get_referenced_type(S,Ext), + %% If V isn't a value but an object Type is a #classdef{} + %%NewS = S#state{mname=RefM}, + NewS = update_state(S,RefM), + case Type of + #classdef{} -> + throw({objectdef}); + #typedef{} -> + case is_contextswitchtype(Type) of + true -> + #valuedef{value=CheckedVal}= + check_value(NewS,V#valuedef{type=Type#typedef.typespec}), + #newv{value=CheckedVal}; + _ -> + #valuedef{value=CheckedVal}= + check_value(NewS#state{recordtopname=[RecName|TopName]}, + V#valuedef{type=Type#typedef.typespec}), + #newv{value=CheckedVal} + end; + #type{} -> + %% A parameter that couldn't be categorized. + #valuedef{value=CheckedVal}= + check_value(NewS#state{recordtopname=[RecName|TopName]}, + V#valuedef{type=Type}), + #newv{value=CheckedVal} + end; + 'ANY' -> + case Value of + {opentypefieldvalue,ANYType,ANYValue} -> + CheckedV= + check_value(SVal,#valuedef{name=Name, + type=ANYType, + value=ANYValue, + module=ModName}), + #newv{value=CheckedV#valuedef.value}; + _ -> + throw({error,{asn1,{'cant check value of type',Def}}}) + end; + 'INTEGER' -> + ok=validate_integer(SVal,Value,[],Constr), + #newv{value=normalize_value(SVal,Vtype,Value,[])}; + {'INTEGER',NamedNumberList} -> + ok=validate_integer(SVal,Value,NamedNumberList,Constr), + #newv{value=normalize_value(SVal,Vtype,Value,[])}; + {'BIT STRING',NamedNumberList} -> + ok=validate_bitstring(SVal,Value,NamedNumberList,Constr), + #newv{value=normalize_value(SVal,Vtype,Value,[])}; + 'NULL' -> + ok=validate_null(SVal,Value,Constr), + #newv{}; + 'OBJECT IDENTIFIER' -> + {ok,_}=validate_objectidentifier(SVal,Value,Constr), + #newv{value = normalize_value(SVal,Vtype,Value,[])}; + 'RELATIVE-OID' -> + {ok,_}=validate_relative_oid(SVal,Value,Constr), + #newv{value = Value}; + 'ObjectDescriptor' -> + ok=validate_objectdescriptor(SVal,Value,Constr), + #newv{value=normalize_value(SVal,Vtype,Value,[])}; + 'REAL' -> + ok = validate_real(SVal,Value,Constr), + #newv{value=normalize_value(SVal,Vtype,Value,[])}; + {'ENUMERATED',NamedNumberList} -> + ok=validate_enumerated(SVal,Value,NamedNumberList,Constr), + #newv{value=normalize_value(SVal,Vtype,Value,[])}; + 'BOOLEAN'-> + ok=validate_boolean(SVal,Value,Constr), + #newv{value=normalize_value(SVal,Vtype,Value,[])}; + 'OCTET STRING' -> + ok=validate_octetstring(SVal,Value,Constr), + #newv{value=normalize_value(SVal,Vtype,Value,[])}; + 'NumericString' -> + ok=validate_restrictedstring(SVal,Value,Def,Constr), + #newv{value=normalize_value(SVal,Vtype,Value,[])}; + TString when TString =:= 'TeletexString'; + TString =:= 'T61String' -> + ok=validate_restrictedstring(SVal,Value,Def,Constr), + #newv{value=normalize_value(SVal,Vtype,Value,[])}; + 'VideotexString' -> + ok=validate_restrictedstring(SVal,Value,Def,Constr), + #newv{value=normalize_value(SVal,Vtype,Value,[])}; + 'UTCTime' -> + #newv{value=normalize_value(SVal,Vtype,Value,[])}; +% exit({'cant check value of type' ,Def}); + 'GeneralizedTime' -> + #newv{value=normalize_value(SVal,Vtype,Value,[])}; +% exit({'cant check value of type' ,Def}); + 'GraphicString' -> + ok=validate_restrictedstring(SVal,Value,Def,Constr), + #newv{value=normalize_value(SVal,Vtype,Value,[])}; + 'VisibleString' -> + ok=validate_restrictedstring(SVal,Value,Def,Constr), + #newv{value=normalize_value(SVal,Vtype,Value,[])}; + 'GeneralString' -> + ok=validate_restrictedstring(SVal,Value,Def,Constr), + #newv{value=normalize_value(SVal,Vtype,Value,[])}; + 'PrintableString' -> + ok=validate_restrictedstring(SVal,Value,Def,Constr), + #newv{value=normalize_value(SVal,Vtype,Value,[])}; + 'IA5String' -> + ok=validate_restrictedstring(SVal,Value,Def,Constr), + #newv{value=normalize_value(SVal,Vtype,Value,[])}; + 'BMPString' -> + ok=validate_restrictedstring(SVal,Value,Def,Constr), + #newv{value=normalize_value(SVal,Vtype,Value,[])}; + 'UTF8String' -> + ok = validate_restrictedstring(SVal,Vtype,Value,Constr), + %%io:format("Vtype: ~p~nValue: ~p~n",[Vtype,Value]); + #newv{value=normalize_value(SVal,Vtype,Value,[])}; + 'UniversalString' -> %added 6/12 -00 + ok = validate_restrictedstring(SVal,Value,Def,Constr), + #newv{value=normalize_value(SVal,Vtype,Value,[])}; + Seq when is_record(Seq,'SEQUENCE') -> + {ok,SeqVal} = validate_sequence(SVal,Value, + Seq#'SEQUENCE'.components, + Constr), + #newv{value=normalize_value(SVal,Vtype,SeqVal,TopName)}; + {'SEQUENCE OF',Components} -> + ok=validate_sequenceof(SVal,Value,Components,Constr), + #newv{value=normalize_value(SVal,Vtype,Value,TopName)}; + {'CHOICE',Components} -> + ok=validate_choice(SVal,Value,Components,Constr), + #newv{value=normalize_value(SVal,Vtype,Value,TopName)}; + Set when is_record(Set,'SET') -> + ok=validate_set(SVal,Value,Set#'SET'.components, + Constr), + #newv{value=normalize_value(SVal,Vtype,Value,TopName)}; + {'SET OF',Components} -> + ok=validate_setof(SVal,Value,Components,Constr), + #newv{value=normalize_value(SVal,Vtype,Value,TopName)}; + {'SelectionType',SelName,SelT} -> + CheckedT = check_selectiontype(SVal,SelName,SelT), + NewV = V#valuedef{type=CheckedT}, + SelVDef=check_value(S#state{value=NewV},NewV), + #newv{value=SelVDef#valuedef.value}; + Other -> + exit({'cannot 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}=Ref, +validate_integer(S,#'Externalvaluereference'{value=Id}=Ref, + NamedNumberList,Constr) -> + case lists:keysearch(Id,1,NamedNumberList) of + {value,_} -> ok; + false -> validate_integer_ref(S,Ref,NamedNumberList,Constr) + %%error({value,"unknown NamedNumber",S}) + end; +validate_integer(S,Id,NamedNumberList,Constr) when is_atom(Id) -> + case lists:keysearch(Id,1,NamedNumberList) of + {value,_} -> ok; + false -> validate_integer_ref(S,Id,NamedNumberList,Constr) + %error({value,"unknown NamedNumber",S}) + end; +validate_integer(_S,Value,_NamedNumberList,Constr) when is_integer(Value) -> + check_integer_range(Value,Constr). + +validate_integer_ref(S,Id,_,_) when is_atom(Id) -> + error({value,"unknown integer referens",S}); +validate_integer_ref(S,Ref,NamedNumberList,Constr) -> + case get_referenced_type(S,Ref) of + {M,V} when is_record(V,valuedef) -> + NewS = update_state(S,M), + case check_value(NewS,V) of + #valuedef{type=#type{def='INTEGER'},value=Value} -> + validate_integer(NewS,Value,NamedNumberList,Constr); + _Err -> error({value,"unknown integer referens",S}) + end; + _ -> + error({value,"unknown integer referens",S}) + end. + + + +check_integer_range(Int,Constr) when is_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,ERef,C) -> + validate_objectidentifier(S,o_id,ERef,C). + +validate_objectidentifier(S,OID,ERef,C) + when is_record(ERef,'Externalvaluereference') -> + validate_objectidentifier(S,OID,[ERef],C); +validate_objectidentifier(S,OID,Tup,C) when is_tuple(Tup) -> + validate_objectidentifier(S,OID,tuple_to_list(Tup),C); +validate_objectidentifier(S,OID,L,_) -> + NewL = is_space_list(L,[]), + case validate_objectidentifier1(S,OID,NewL) of + NewL2 when is_list(NewL2) ->{ok,list_to_tuple(NewL2)}; + Other -> {ok,Other} + end. + +validate_objectidentifier1(S, OID, [Id|T]) + when is_record(Id,'Externalvaluereference') -> + case catch get_referenced_type(S,Id) of + {M,V} when is_record(V,valuedef) -> + NewS = update_state(S,M), + case check_value(NewS,V) of + #valuedef{type=#type{def=ERef},checked=true, + value=Value} when is_tuple(Value) -> + case is_object_id(OID,NewS,ERef) of + true -> + %% T must be a RELATIVE-OID + validate_oid(true,NewS, rel_oid, T, lists:reverse(tuple_to_list(Value))); + _ -> + error({value, {"illegal "++to_string(OID),[Id|T]}, S}) + end; + _ -> + error({value, {"illegal "++to_string(OID),[Id|T]}, S}) + end; + _ -> + validate_oid(true,S, OID, [Id|T], []) + end; +validate_objectidentifier1(S,OID,V) -> + validate_oid(true,S,OID,V,[]). + +validate_oid(false, S, OID, V, Acc) -> + error({value, {"illegal "++to_string(OID), V,Acc}, S}); +validate_oid(_,_, _, [], Acc) -> + lists:reverse(Acc); +validate_oid(_, S, OID, [Value|Vrest], Acc) when is_integer(Value) -> + validate_oid(valid_objectid(OID,Value,Acc),S, OID, Vrest, [Value|Acc]); +validate_oid(_, S, OID, [{'NamedNumber',_Name,Value}|Vrest], Acc) + when is_integer(Value) -> + validate_oid(valid_objectid(OID,Value,Acc), S, OID, Vrest, [Value|Acc]); +validate_oid(_, S, OID, [Id|Vrest], Acc) + when is_record(Id,'Externalvaluereference') -> + case catch get_referenced_type(S, Id) of + {M,V} when is_record(V,valuedef) -> + NewS = update_state(S,M), + NewVal = case check_value(NewS, V) of + #valuedef{checked=true,value=Value} -> + fun(Int) when is_integer(Int) -> [Int]; + (L) when is_list(L) -> L; + (T) when is_tuple(T) -> tuple_to_list(T) + end (Value); + _ -> + error({value, {"illegal "++to_string(OID), + [Id|Vrest],Acc}, S}) + end, + case NewVal of + List when is_list(List) -> + validate_oid(valid_objectid(OID,NewVal,Acc), NewS, + OID, Vrest,lists:reverse(NewVal)++Acc); + _ -> + NewVal + end; + _ -> + case reserved_objectid(Id#'Externalvaluereference'.value, Acc) of + Value when is_integer(Value) -> + validate_oid(valid_objectid(OID,Value,Acc), + S, OID,Vrest, [Value|Acc]); + false -> + error({value, {"illegal "++to_string(OID),[Id,Vrest],Acc}, S}) + end + end; +validate_oid(_, S, OID, [{Atom,Value}],[]) + when is_atom(Atom),is_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, OID, [Rec,Value]); +validate_oid(_, S, OID, [{Atom,EVRef}],[]) + when is_atom(Atom),is_record(EVRef,'Externalvaluereference') -> + %% this case when an OBJECT IDENTIFIER value has been parsed as a + %% SEQUENCE value OTP-4354 + Rec = #'Externalvaluereference'{module=EVRef#'Externalvaluereference'.module, + value=Atom}, + validate_objectidentifier1(S, OID, [Rec,EVRef]); +validate_oid(_, S, OID, [Atom|Rest],Acc) when is_atom(Atom) -> + Rec = #'Externalvaluereference'{module=S#state.mname, + value=Atom}, + validate_oid(true,S, OID, [Rec|Rest],Acc); +validate_oid(_, S, OID, V, Acc) -> + error({value, {"illegal "++to_string(OID),V,Acc},S}). + +validate_relative_oid(S,Value,Constr) -> + validate_objectidentifier(S,rel_oid,Value,Constr). + +is_object_id(OID,S,ERef=#'Externaltypereference'{}) -> + {_,OI} = get_referenced_type(S,ERef), + is_object_id(OID,S,OI#typedef.typespec); +is_object_id(o_id,_S,'OBJECT IDENTIFIER') -> + true; +is_object_id(rel_oid,_S,'RELATIVE-OID') -> + true; +is_object_id(_,_S,'INTEGER') -> + true; +is_object_id(OID,S,#type{def=Def}) -> + is_object_id(OID,S,Def); +is_object_id(_,_S,_) -> + false. + +to_string(o_id) -> + "OBJECT IDENTIFIER"; +to_string(rel_oid) -> + "RELATIVE-OID". + +%% 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. + +valid_objectid(_OID,[],_Acc) -> + true; +valid_objectid(OID,[H|T],Acc) -> + case valid_objectid(OID, H, Acc) of + true -> + valid_objectid(OID,T,[H|Acc]); + _ -> + false + end; +valid_objectid(o_id,I,[]) when I =:= 0; I =:= 1; I =:= 2 -> true; +valid_objectid(o_id,_I,[]) -> false; +valid_objectid(o_id,I,[0]) when I >= 0; I =< 4 -> true; +valid_objectid(o_id,_I,[0]) -> false; +valid_objectid(o_id,I,[1]) when I =:= 0; I =:= 2; I =:= 3 -> true; +valid_objectid(o_id,_I,[1]) -> false; +valid_objectid(o_id,_I,[2]) -> true; +valid_objectid(_,_,_) -> true. + + + + + + +validate_objectdescriptor(_S,_Value,_Constr) -> + ok. + +validate_real(_S,_Value,_Constr) -> + ok. + +validate_enumerated(S,Id,NamedNumberList,_Constr) when is_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] -> + {ok,to_EXTERNAL1990(S,Value)}; + _ -> + {ok,Value} + end; + _ -> + {ok,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'; + {'RELATIVE-OID',_,_} -> + normalize_relative_oid(S,Value); + {'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); + {'ASN1_OPEN_TYPE',{typefield,_TF},NL} -> %an open type + normalize_objectclassfieldvalue(S,Value,NL); + Err -> + io:format("WARNING: could not check default value ~p~nType:~n~p~nNameList:~n~p~n",[Value,Type,Err]), + Value + end; +normalize_value(S,Type,Val,NameList) -> + normalize_value(S,Type,{'DEFAULT',Val},NameList). + +normalize_boolean(S,{Name,Bool},CType) when is_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 is_integer(Int) -> + Int; +normalize_integer(_S,{Name,Int},_) when is_atom(Name),is_integer(Int) -> + Int; +normalize_integer(S,{Name,Int=#'Externalvaluereference'{}}, + Type) when is_atom(Name) -> + normalize_integer(S,Int,Type); +normalize_integer(S,Int=#'Externalvaluereference'{value=Name},Type) -> + case Type of + NNL when is_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. + %% E - list of ones and zeros, if Value already is normalized. + case Value of + {hstring,String} when is_list(String) -> + hstring_to_int(String); + {bstring,String} when is_list(String) -> + bstring_to_bitlist(String); + Rec when is_record(Rec,'Externalvaluereference') -> + get_normalized_value(S,Value,Type, + fun normalize_bitstring/3,[]); + RecList when is_list(RecList) -> + case Type of + NBL when is_list(NBL) -> + F = fun(#'Externalvaluereference'{value=Name}) -> + case lists:keysearch(Name,1,NBL) of + {value,{Name,_}} -> + Name; + Other -> + throw({error,Other}) + end; + (I) when I =:= 1; I =:= 0 -> + I; + (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 is_atom(Name) -> + normalize_bitstring(S,String,Type); + Other -> + io:format("WARNING: illegal default value ~p~n",[Other]), + Value + end. + +hstring_to_int(L) when is_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 is_record(Rec,'Externalvaluereference') -> + get_normalized_value(S,Value,CType, + fun normalize_octetstring/3,[]); + {Name,String} when is_atom(Name) -> + normalize_octetstring(S,String,CType); + List when is_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) -> + {ok,Val}=validate_objectidentifier(S,Value,[]), + Val. + +normalize_relative_oid(S,Value) -> + {ok,Val} = validate_relative_oid(S,Value,[]), + Val. + +normalize_objectdescriptor(Value) -> + Value. + +normalize_real(Value) -> + Value. + +normalize_enumerated(#'Externalvaluereference'{value=V},CType) + when is_list(CType) -> + normalize_enumerated2(V,CType); +normalize_enumerated(Value,CType) when is_atom(Value),is_list(CType) -> + normalize_enumerated2(Value,CType); +normalize_enumerated({Name,EnumV},CType) when is_atom(Name) -> + normalize_enumerated(EnumV,CType); +normalize_enumerated(Value,{CType1,CType2}) when is_list(CType1), is_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 is_atom(C) -> + case catch lists:keysearch(C,#'ComponentType'.name,CType) of + {value,#'ComponentType'{typespec=CT,name=Name}} -> + {C,normalize_value(S,CT,{'DEFAULT',V}, + [Name|NameList])}; + Other -> + io:format("WARNING: Wrong format of type/value ~p/~p~n", + [Other,V]), + {C,V} + end; +normalize_choice(S,{'DEFAULT',ValueList},CType,NameList) when is_list(ValueList) -> + lists:map(fun(X)-> normalize_choice(S,X,CType,NameList) end, ValueList); +normalize_choice(S,Val=#'Externalvaluereference'{},CType,NameList) -> + {M,#valuedef{value=V}}=get_referenced_type(S,Val), + normalize_choice(update_state(S,M),{'CHOICE',V},CType,NameList); +% get_normalized_value(S,Val,CType,fun normalize_choice/4,[NameList]); +normalize_choice(S,CV={Name,_ChoiceVal},CType,NameList) + when is_atom(Name) -> +% normalize_choice(S,ChoiceVal,CType,NameList). + normalize_choice(S,{'CHOICE',CV},CType,NameList); +normalize_choice(_S,V,_CType,_NameList) -> + exit({error,{bad_choice_value,V}}). + +%% normalize_choice(NameList,S,CVal = {'CHOICE',{_,_}},CType,_) -> +%% normalize_choice(S,CVal,CType,NameList); +%% normalize_choice(NameList,S,CVal={'DEFAULT',VL},CType,_) when is_list(VL)-> +%% normalize_choice(S,CVal,CType,NameList); +%% normalize_choice(NameList,S,CV={Name,_CV},CType,_) when is_atom(Name)-> +%% normalize_choice(S,{'CHOICE',CV},CType,NameList); +%% normalize_choice(_,_S,V,_,_) -> +%% V. + +normalize_sequence(S,Value,Components,NameList) + when is_tuple(Components) -> + normalize_sequence(S,Value,lists:flatten(tuple_to_list(Components)), + NameList); +normalize_sequence(S,{Name,Value},Components,NameList) + when is_atom(Name),is_list(Value) -> + normalize_sequence(S,Value,Components,NameList); +normalize_sequence(S,Value,Components,NameList) -> + normalized_record('SEQUENCE',S,Value,Components,NameList). + +normalize_set(S,Value,Components,NameList) when is_tuple(Components) -> + normalize_set(S,Value,lists:flatten(tuple_to_list(Components)),NameList); +normalize_set(S,{Name,Value},Components,NameList) + when is_atom(Name),is_list(Value) -> + normalized_record('SET',S,Value,Components,NameList); +normalize_set(S,Value,Components,NameList) -> + NewName = list_to_atom(asn1ct_gen:list2name(NameList)), + case is_record_normalized(S,NewName,Value,length(Components)) of + true -> + Value; + _ -> + SortedVal = sort_value(Components,Value), + normalized_record('SET',S,SortedVal,Components,NameList) + end. + +sort_value(Components,Value) -> + ComponentNames = lists:map(fun(#'ComponentType'{name=Cname}) -> Cname end, + Components), + sort_value1(ComponentNames,Value,[]). +sort_value1(_,V=#'Externalvaluereference'{},_) -> + %% sort later, get the value in normalize_seq_or_set + V; +sort_value1([N|Ns],Value,Acc) -> + case lists:keysearch(N,1,Value) of + {value,V} ->sort_value1(Ns,Value,[V|Acc]); + _ -> sort_value1(Ns,Value,Acc) + end; +sort_value1([],_,Acc) -> + lists:reverse(Acc). + +sort_val_if_set(['SET'|_],Val,Type) -> + sort_value(Type,Val); +sort_val_if_set(_,Val,_) -> + Val. + +normalized_record(SorS,S,Value,Components,NameList) -> + NewName = list_to_atom(lists:concat([get_record_prefix_name(S), + asn1ct_gen:list2name(NameList)])), + case is_record_normalized(S,NewName,Value,length(Components)) of + true -> + Value; + _ -> + 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 + end. +is_record_normalized(S,Name,V = #'Externalvaluereference'{},NumComps) -> + case get_referenced_type(S,V) of + {_M,#valuedef{type=_T1,value=V2}} -> + is_record_normalized(S,Name,V2,NumComps); + _ -> false + end; +is_record_normalized(_S,Name,Value,NumComps) when is_tuple(Value) -> + (size(Value) =:= (NumComps + 1)) andalso (element(1,Value)=:=Name); +is_record_normalized(_,_,_,_) -> + false. + +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 is_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 is_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 is_record(Value,'Externalvaluereference') -> + get_normalized_value(S,Value,Type,fun normalize_s_of/5, + [SorS,NameList]). + + +%% normalize_restrictedstring handles all format of restricted strings. +%% tuple case +% normalize_restrictedstring(_S,[Int1,Int2],_) when is_integer(Int1),is_integer(Int2) -> +% {Int1,Int2}; +% %% quadruple case +% normalize_restrictedstring(_S,[Int1,Int2,Int3,Int4],_) when is_integer(Int1), +% is_integer(Int2), +% is_integer(Int3), +% is_integer(Int4) -> +% {Int1,Int2,Int3,Int4}; +%% character string list case +normalize_restrictedstring(S,[H|T],CType) when is_list(H);is_tuple(H) -> + [normalize_restrictedstring(S,H,CType)|normalize_restrictedstring(S,T,CType)]; +%% character sting case +normalize_restrictedstring(_S,CString,_) when is_list(CString) -> + CString; +%% definedvalue case or argument in a parameterized type +normalize_restrictedstring(S,ERef,CType) when is_record(ERef,'Externalvaluereference') -> + get_normalized_value(S,ERef,CType, + fun normalize_restrictedstring/3,[]); +%% +normalize_restrictedstring(S,{Name,Val},CType) when is_atom(Name) -> + normalize_restrictedstring(S,Val,CType). + +normalize_objectclassfieldvalue(S,{opentypefieldvalue,Type,Value},NameList) -> + %% An open type has per definition no type. Thus should the type + %% information of the default type be available at + %% encode/decode. But as encoding the default value causes special + %% treatment (no encoding) whatever type is used the type + %% information is not necessary in encode/decode. + normalize_value(S,Type,Value,NameList); +normalize_objectclassfieldvalue(_S,Other,_NameList) -> + %% If the type info was thrown away in an earlier step the value + %% is already normalized. + Other. + +get_normalized_value(S,Val,Type,Func,AddArg) -> + case catch get_referenced_type(S,Val) of + {ExtM,_VDef = #valuedef{type=_T1,value=V}} -> + %% should check that Type and T equals + V2 = sort_val_if_set(AddArg,V,Type), + call_Func(update_state(S,ExtM),V2,Type,Func,AddArg); + {error,_} -> + io:format("WARNING: default value not " + "comparable ~p~n",[Val]), + Val; + {ExtM,NewVal} -> + V2 = sort_val_if_set(AddArg,NewVal,Type), + call_Func(update_state(S,ExtM),V2,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 is_atom(Name) -> + {Name,Type,NameList}; + Ref when is_record(Ref,'Externaltypereference') -> + {_,#typedef{name=Name,typespec=RefedType}} = + get_referenced_type(S,Ref), + get_canonic_type(S,RefedType,[Name]); + {Name,T} when is_atom(Name) -> + {Name,T,NameList}; + Seq when is_record(Seq,'SEQUENCE') -> + {'SEQUENCE',Seq#'SEQUENCE'.components,NameList}; + Set when is_record(Set,'SET') -> + {'SET',Set#'SET'.components,NameList}; + #'ObjectClassFieldType'{type=T} -> + {'ASN1_OPEN_TYPE',T,NameList} + end, + {asn1ct_gen:unify_if_string(InnerType),NewType,NewNameList}. + + + +check_ptype(S,Type,Ts) when is_record(Ts,type) -> + %Tag = Ts#type.tag, + %Constr = Ts#type.constraint, + Def = Ts#type.def, + NewDef= + case Def of + Seq when is_record(Seq,'SEQUENCE') -> + Components = expand_components(S,Seq#'SEQUENCE'.components), + #newt{type=Seq#'SEQUENCE'{pname=get_datastr_name(Type), + components = Components}}; + Set when is_record(Set,'SET') -> + Components = expand_components(S,Set#'SET'.components), + #newt{type=Set#'SET'{pname=get_datastr_name(Type), + components = Components}}; + _Other -> + #newt{} + end, + Ts2 = case NewDef of + #newt{type=unchanged} -> + Ts; + #newt{type=TDef}-> + Ts#type{def=TDef} + end, + Ts2; +%parameterized class +check_ptype(_S,_PTDef,Ts) when is_record(Ts,objectclass) -> + throw({asn1_param_class,Ts}). + + +% check_type(S,Type,ObjSpec={{objectclassname,_},_}) -> +% check_class(S,ObjSpec); +check_type(_S,Type,Ts) when is_record(Type,typedef), + (Type#typedef.checked==true) -> + Ts; +check_type(_S,Type,Ts) when is_record(Type,typedef), + (Type#typedef.checked==idle) -> % the check is going on + Ts; +check_type(S=#state{recordtopname=TopName},Type,Ts) when is_record(Ts,type) -> + {Def,Tag,Constr,IsInlined} = + case match_parameters(S,Ts#type.def,S#state.parameters) of + #type{tag=PTag,constraint=_Ctmp,def=Dtmp,inlined=Inl} -> + {Dtmp,merge_tags(Ts#type.tag,PTag),Ts#type.constraint,Inl}; + #typedef{typespec=#type{tag=PTag,def=Dtmp,inlined=Inl}} -> + {Dtmp,merge_tags(Ts#type.tag,PTag),Ts#type.constraint,Inl}; + Dtmp -> + {Dtmp,Ts#type.tag,Ts#type.constraint,Ts#type.inlined} + end, + TempNewDef = #newt{type=Def,tag=Tag,constraint=Constr, + inlined=IsInlined}, + 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 is_record(Ext,'Externaltypereference') -> + {RefMod,RefTypeDef,IsParamDef} = + case get_referenced_type(S,Ext) of + {undefined,TmpTDef} -> %% A parameter + {get(top_module),TmpTDef,true}; + {TmpRefMod,TmpRefDef} -> + {TmpRefMod,TmpRefDef,false} + end, + case is_class(S,RefTypeDef) of + true -> throw({asn1_class,RefTypeDef}); + _ -> ok + end, + Ct = TestFun(Ext), + {RefType,ExtRef} = + case RefTypeDef#typedef.checked of + true -> + {RefTypeDef#typedef.typespec,Ext}; + _ -> + %% Put as idle to prevent recursive loops + NewRefTypeDef1 = RefTypeDef#typedef{checked=idle}, + asn1_db:dbput(RefMod, + get_datastr_name(NewRefTypeDef1), + NewRefTypeDef1), + NewS = S#state{mname=RefMod, + module=load_asn1_module(S,RefMod), + tname=get_datastr_name(NewRefTypeDef1), + type=NewRefTypeDef1, + abscomppath=[],recordtopname=[]}, + RefType1 = + check_type(NewS,RefTypeDef,RefTypeDef#typedef.typespec), + %% update the type and mark as checked + NewRefTypeDef2 = + RefTypeDef#typedef{checked=true,typespec = RefType1}, + TmpName = get_datastr_name(NewRefTypeDef2), + asn1_db:dbput(RefMod, + TmpName, + NewRefTypeDef2), + case {RefMod == get(top_module),IsParamDef} of + {true,true} -> + Key = {TmpName, + type, + NewRefTypeDef2}, + asn1ct_gen:insert_once(parameterized_objects, + Key); + _ -> ok + end, + {RefType1,#'Externaltypereference'{module=RefMod, + type=TmpName}} + 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 + NewS2 = S#state{type=#typedef{typespec=RefType}}, + NewC = + constraint_merge(NewS2, + check_constraints(NewS2,Constr)++ + RefType#type.constraint), + TempNewDef#newt{ + type = RefType#type.def, + tag = merge_tags(Ct,RefType#type.tag), + constraint = NewC}; + _ -> + %% Here we only expand the tags and keep the ext ref. + + NewExt = ExtRef#'Externaltypereference'{module=merged_mod(S,RefMod,Ext)}, + TempNewDef#newt{ + type = check_externaltypereference(S,NewExt), + 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))}; + 'REAL' -> + check_real(S,Constr), + TempNewDef#newt{tag=merge_tags(Tag,?TAG_PRIMITIVE(?N_REAL))}; + {'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' -> + put_once(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)), + constraint=[]}; + 'EMBEDDED PDV' -> + put_once(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))}; + TString when TString =:= 'TeletexString'; + TString =:= 'T61String' -> + 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))}; + 'UTF8String' -> + check_restrictedstring(S,Def,Constr), + TempNewDef#newt{tag= + merge_tags(Tag,?TAG_PRIMITIVE(?N_UTF8String))}; + 'RELATIVE-OID' -> + check_relative_oid(S,Constr), + TempNewDef#newt{tag= + merge_tags(Tag,?TAG_PRIMITIVE(?'N_RELATIVE-OID'))}; + 'CHARACTER STRING' -> + put_once(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 is_record(Seq,'SEQUENCE') -> + RecordName = + case TopName of + [] -> + [get_datastr_name(Type)]; +% [Type#typedef.name]; + _ -> + TopName + end, + {TableCInf,Components} = + check_sequence(S#state{recordtopname= + RecordName}, + Type,Seq#'SEQUENCE'.components), + TempNewDef#newt{type=Seq#'SEQUENCE'{tablecinf=tablecinf_choose(Seq,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 is_record(Set,'SET') -> + RecordName= + case TopName of + [] -> + [get_datastr_name(Type)]; +% [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_choose(Set,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. + {_RefMod,Ptypedef} = get_referenced_type(S,Ptype), + notify_if_not_ptype(S,Ptypedef), + NewParaList = + [match_parameters(S,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}; + + OCFT=#'ObjectClassFieldType'{classname=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#'ObjectClassFieldType'{class=ClassSpec},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}; + + {'TypeFromObject',{object,Object},TypeField} -> + CheckedT = get_type_from_object(S,Object,TypeField), + TempNewDef#newt{tag=merge_tags(Tag,CheckedT#type.tag), + type=CheckedT#type.def}; + + {valueset,Vtype} -> + TempNewDef#newt{type={valueset,check_type(S,Type,Vtype)}}; + {'SelectionType',Name,T} -> + CheckedT = check_selectiontype(S,Name,T), + TempNewDef#newt{tag=merge_tags(Tag,CheckedT#type.tag), + type=CheckedT#type.def}; + 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)}; +check_type(_S,Type,Ts) -> + exit({error,{asn1,internal_error,Type,Ts}}). + +%% tablecinf_choose. A SEQUENCE or SET may be inserted in another +%% SEQUENCE or SET by the COMPONENTS OF directive. If this inserted +%% type is a referenced type that already has been checked it already +%% has its tableconstraint information. Furthermore this information +%% may be lost in the analysis in the new environment. Assume this +%% SEQUENCE/SET has a simpletable constraint and a componentrelation +%% constraint whose atlist points to the outermost component of its +%% "standalone" definition. This will cause the analysis to fail as it +%% will not find the right atlist component in the outermost +%% environment in the new inlined environment. +tablecinf_choose(SetOrSeq,false) -> + tablecinf_choose(SetOrSeq); +tablecinf_choose(_, TableCInf) -> + TableCInf. +tablecinf_choose(#'SET'{tablecinf=TCI}) -> + TCI; +tablecinf_choose(#'SEQUENCE'{tablecinf=TCI}) -> + TCI. + +get_innertag(_S,#'ObjectClassFieldType'{type=Type}) -> + case Type of +% #type{tag=Tag} -> Tag; +% {fixedtypevaluefield,_,#type{tag=[]}=T} -> get_taglist(S,T); + {fixedtypevaluefield,_,#type{tag=Tag}} -> Tag; + {TypeFieldName,_} when is_atom(TypeFieldName) -> []; + _ -> [] + end. + +get_type_from_object(S,Object,TypeField) + when is_record(Object,'Externaltypereference'); + is_record(Object,'Externalvaluereference') -> + {_,ObjectDef} = get_referenced_type(S,Object), + ObjSpec = check_object(S,ObjectDef,ObjectDef#typedef.typespec), + get_fieldname_element(S,ObjectDef#typedef{typespec=ObjSpec},TypeField). + +is_class(_S,#classdef{}) -> + true; +is_class(S,#typedef{typespec=#type{def=Eref}}) + when is_record(Eref,'Externaltypereference')-> + is_class(S,Eref); +is_class(S,Eref) when is_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 is_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. + + +merged_mod(S,RefMod,Ext) -> + case S of + #state{inputmodules=[]} -> + RefMod; + _ -> + Ext#'Externaltypereference'.module + end. + +%% maybe_open_type/2 -> #ObjectClassFieldType with updated fieldname and +%% 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'. +%% +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 last_fieldname(FieldRefList) of + {valuefieldreference,_} -> + OCFT#'ObjectClassFieldType'{fieldname=FieldNames, + type=Type}; + {typefieldreference,_} -> + case {catch get_unique_fieldname(S,#classdef{typespec=ClassSpec}), + asn1ct_gen:get_constraint(Constr,componentrelation)}of + {Tuple,_} when is_tuple(Tuple), size(Tuple) =:= 3 -> + OCFT#'ObjectClassFieldType'{fieldname=FieldNames, + type='ASN1_OPEN_TYPE'}; + {_,no} -> + OCFT#'ObjectClassFieldType'{fieldname=FieldNames, + type='ASN1_OPEN_TYPE'}; + _ -> + OCFT#'ObjectClassFieldType'{fieldname=FieldNames, + type=Type} + end + end. + +last_fieldname(FieldRefList) when is_list(FieldRefList) -> + lists:last(FieldRefList); +last_fieldname({FieldName,_}) when is_atom(FieldName) -> + [A|_] = atom_to_list(FieldName), + case is_lowercase(A) of + true -> + {valuefieldreference,FieldName}; + _ -> + {typefieldreference,FieldName} + 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 is_record(Ref,'Externaltypereference') -> + case get_referenced_type(S,Ref) of + {_,#classdef{}} -> + throw(pobjectsetdef); + {_,#typedef{}} -> + throw(pvalueset) + end; + T when is_record(T,type) -> % this must be a value set + throw(pvalueset) + end; +notify_if_not_ptype(_S,PT=#ptypedef{}) -> + %% this may be a parameterized CLASS, in that case throw an + %% asn1_class exception + case PT#ptypedef.typespec of + #objectclass{} -> throw({asn1_class,PT}); + _ -> ok + end; +notify_if_not_ptype(S,#pobjectsetdef{class=Cl}) -> + case Cl of + #'Externaltypereference'{} -> + case get_referenced_type(S,Cl) of + {_,#classdef{}} -> + throw(pobjectsetdef); + {_,#typedef{}} -> + throw(pvalueset) + end; + _ -> + throw(pobjectsetdef) + end; +notify_if_not_ptype(_S,PT) -> + throw({error,{"supposed to be a parameterized type",PT}}). +% fix me +instantiate_ptype(S,Ptypedef,ParaList) -> + #ptypedef{args=Args,typespec=Type} = Ptypedef, + NewType = check_ptype(S,Ptypedef,Type#type{inlined=yes}), + MatchedArgs = match_args(S,Args, ParaList, []), + OldArgs = S#state.parameters, + NewS = S#state{type=NewType,parameters=MatchedArgs++OldArgs,abscomppath=[]}, +%% NewS = S#state{type=NewType,parameters=MatchedArgs,abscomppath=[]}, + check_type(NewS, Ptypedef#ptypedef{typespec=NewType}, NewType). + +get_datastr_name(#typedef{name=N}) -> + N; +get_datastr_name(#classdef{name=N}) -> + N; +get_datastr_name(#valuedef{name=N}) -> + N; +get_datastr_name(#ptypedef{name=N}) -> + N; +get_datastr_name(#pvaluedef{name=N}) -> + N; +get_datastr_name(#pvaluesetdef{name=N}) -> + N; +get_datastr_name(#pobjectdef{name=N}) -> + N; +get_datastr_name(#pobjectsetdef{name=N}) -> + N. + + +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(S,FormalArgs, ActualArgs, Accumulator) -> Result +%% S = #state{} +%% FormalArgs = [term()] | [{Governor,Parameter}] +%% ActualArgs = [term()] +%% Accumulator = [term()] +%% Result = [{term(),term()}] | throw() +%% Governor = #type{} | Reference | 'TYPE-IDENTIFIER' | 'ABSTRACT-SYNTAX' +%% Parameter = Reference | {Governor,Reference} +%% Reference = #'Externaltypereference'{} | #'Externalvaluerference'{} +%% +%% Different categories of parameters and governors (Dubuisson p.382) +%% +----------------+-------------------------------+----------------------+ +%% |Governor is | Parameter name style | Parameter is | +%% +----------------+-------------------------------+----------------------+ +%% | absent | begins with uppercase,(bu) | a type | +%% | | | | +%% | a type | begins with a lowercase,(bl)| a value | +%% | | | | +%% | a type | begins with an uppercase | a value set | +%% | | | | +%% | absent | entirely in uppercase, (eu) | a class (or type) | +%% | | | | +%% | a class name | begins with a lowercase | an object | +%% | | | | +%% | a class name | begins with an uppercase | an object set | +%% +----------------+-------------------------------+----------------------+ +%% +%% Matches each of the formal parameters to corresponding actual +%% parameter, and changes format of the actual parameter according to +%% above table if necessary. +match_args(S,FA = [FormArg|Ft], AA = [ActArg|At], Acc) -> + OldParams = S#state.parameters, + case categorize_arg(S,FormArg,ActArg) of + [CategorizedArg] -> + match_args(S#state{parameters= + [{FormArg,CategorizedArg}|OldParams]}, + Ft, At, [{FormArg,CategorizedArg}|Acc]); + CategorizedArgs -> + match_args(S#state{parameters=CategorizedArgs++OldParams}, + FA, CategorizedArgs ++ AA, Acc) + end; +match_args(_S,[], [], Acc) -> + lists:reverse(Acc); +match_args(_,_, _, _) -> + throw({error,{asn1,{wrong_number_of_arguments}}}). + +%%%%%%%%%%%%%%%%% +%% categorize_arg(S,FormalArg,ActualArg) -> {FormalArg,CatgorizedActualArg} +%% +categorize_arg(S,{Governor,Param},ActArg) -> + case {governor_category(S,Governor),parameter_name_style(Param,ActArg)} of +%% {absent,beginning_uppercase} -> %% a type +%% categorize(S,type,ActArg); + {type,beginning_lowercase} -> %% a value + categorize(S,value,Governor,ActArg); + {type,beginning_uppercase} -> %% a value set + categorize(S,value_set,ActArg); +%% {absent,entirely_uppercase} -> %% a class +%% categorize(S,class,ActArg); + {{class,ClassRef},beginning_lowercase} -> + categorize(S,object,ActArg,ClassRef); + {{class,ClassRef},beginning_uppercase} -> + categorize(S,object_set,ActArg,ClassRef); + _ -> + [ActArg] + end; +categorize_arg(S,FormalArg,ActualArg) -> + %% governor is absent => a type or a class + case FormalArg of + #'Externaltypereference'{type=Name} -> + case is_class_name(Name) of + true -> + categorize(S,class,ActualArg); + _ -> + categorize(S,type,ActualArg) + end; + FA -> + throw({error,{unexpected_formal_argument,FA}}) + end. + +governor_category(S,#type{def=Eref}) + when is_record(Eref,'Externaltypereference') -> + governor_category(S,Eref); +governor_category(_S,#type{}) -> + type; +governor_category(S,Ref) when is_record(Ref,'Externaltypereference') -> + case is_class(S,Ref) of + true -> + {class,Ref}; + _ -> + type + end; +governor_category(_,Class) + when Class == 'TYPE-IDENTIFIER'; Class == 'ABSTRACT-SYNTAX' -> + class. +%% governor_category(_,_) -> +%% absent. + +%% parameter_name_style(Param,Data) -> Result +%% gets the Parameter and the name of the Data and if it exists tells +%% whether it begins with a lowercase letter or is partly or entirely +%% spelled with uppercase letters. Otherwise returns undefined +%% +parameter_name_style(_,#'Externaltypereference'{type=Name}) -> + name_category(Name); +parameter_name_style(_,#'Externalvaluereference'{value=Name}) -> + name_category(Name); +parameter_name_style(_,{valueset,_}) -> + %% It is a object set or value set + beginning_uppercase; +parameter_name_style(#'Externalvaluereference'{},_) -> + beginning_lowercase; +parameter_name_style(#'Externaltypereference'{type=Name},_) -> + name_category(Name); +parameter_name_style(_,_) -> + undefined. + +name_category(Atom) when is_atom(Atom) -> + name_category(atom_to_list(Atom)); +name_category([H|T]) -> + case is_lowercase(H) of + true -> + beginning_lowercase; + _ -> + case is_class_name(T) of + true -> + entirely_uppercase; + _ -> + beginning_uppercase + end + end; +name_category(_) -> + undefined. + +is_lowercase(X) when X >= $A,X =< $W -> + false; +is_lowercase(_) -> + true. + +is_class_name(Name) when is_atom(Name) -> + is_class_name(atom_to_list(Name)); +is_class_name(Name) -> + case [X||X <- Name, X >= $a,X =< $w] of + [] -> + true; + _ -> + false + end. + +%% categorize(S,Category,Parameter) -> CategorizedParameter +%% If Parameter has an abstract syntax of another category than +%% Category, transform it to a known syntax. +categorize(_S,type,{object,_,Type}) -> + %% One example of this case is an object with a parameterized type + %% having a locally defined type as parameter. + Def = fun(D = #type{}) -> + #typedef{name = new_reference_name("type_argument"), + typespec = D#type{inlined=yes}}; + ({setting,_,Eref}) when is_record(Eref,'Externaltypereference') -> + Eref; + (D) -> + D + end, + [Def(X)||X<-Type]; +categorize(_S,type,Def) when is_record(Def,type) -> + [#typedef{name = new_reference_name("type_argument"), + typespec = Def#type{inlined=yes}}]; +categorize(_,_,Def) -> + [Def]. +categorize(S,object_set,Def,ClassRef) -> + %% XXXXXXXXXX + case Def of + {'Externaltypereference',undefined,'MSAccessProtocol','AllOperations'} -> + ok; + _ -> + ok + end, + NewObjSetSpec = + check_object(S,Def,#'ObjectSet'{class = ClassRef, + set = parse_objectset(Def)}), + Name = new_reference_name("object_set_argument"), + %% XXXXXXXXXX + case Name of + internal_object_set_argument_78 -> + ok; + internal_object_set_argument_77 -> + ok; + _ -> + ok + end, + [save_object_set_instance(S,Name,NewObjSetSpec)]; +categorize(_S,object,Def,_ClassRef) -> + %% should be handled + [Def]; +categorize(_S,value,_Type,Value) when is_record(Value,valuedef) -> + [Value]; +categorize(S,value,Type,Value) -> +%% [check_value(S,#valuedef{type=Type,value=Value})]. + [#valuedef{type=Type,value=Value,module=S#state.mname}]. + + +parse_objectset({valueset,T=#type{}}) -> + [T]; +parse_objectset({valueset,Set}) -> + Set; +parse_objectset(#type{def=Ref}) when is_record(Ref,'Externaltypereference') -> + Ref; +parse_objectset(Set) -> + %% extend this later + Set. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% check_constraints/2 +%% +check_constraints(S,C) when is_list(C) -> + check_constraints(S, C, []); +check_constraints(S,C) when is_record(C,constraint) -> + check_constraints(S, C#constraint.c, []). + +resolv_tuple_or_list(S,List) when is_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) -> + Id = match_parameters(S,Val, S#state.parameters), + resolv_value1(S,Id). + +resolv_value1(S, ERef = #'Externalvaluereference'{value=Name}) -> + case catch resolve_namednumber(S,S#state.type,Name) of + V when is_integer(V) -> V; + _ -> + case get_referenced_type(S,ERef) of + {Err,_Reason} when Err == error; Err == 'EXIT' -> + throw({error,{asn1,{undefined_type_or_value, + Name}}}); + {_M,VDef} -> + resolv_value1(S,VDef) + end + end; +resolv_value1(S,{gt,V}) -> + case V of + Int when is_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 is_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' + resolve_value_from_object(S,Object,FieldName); +resolv_value1(_,#valuedef{checked=true,value=V}) -> + V; +resolv_value1(S,#valuedef{type=_T, + value={'ValueFromObject',{object,Object}, + [{valuefieldreference, + FieldName}]}}) -> + resolve_value_from_object(S,Object,FieldName); +resolv_value1(S,VDef = #valuedef{}) -> + #valuedef{value=Val} = check_value(S,VDef), + Val; +resolv_value1(_,V) -> + V. +resolve_value_from_object(S,Object,FieldName) -> + {_,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. + + + +resolve_namednumber(S,#typedef{typespec=Type},Name) -> + case Type#type.def of + {'ENUMERATED',NameList} -> + NamedNumberList=check_enumerated(S,NameList,Type#type.constraint), + N = normalize_enumerated(Name,NamedNumberList), + {value,{_,V}} = lists:keysearch(N,1,NamedNumberList), + V; + {'INTEGER',NameList} -> + NamedNumberList = check_enumerated(S,NameList,Type#type.constraint), + {value,{_,V}} = lists:keysearch(Name,1,NamedNumberList), + V; + _ -> + not_enumerated + end. + +check_constraints(S,[{'ContainedSubtype',Type} | Rest], Acc) -> + {RefMod,CTDef} = get_referenced_type(S,Type#type.def), + NewS = S#state{module=load_asn1_module(S,RefMod),mname=RefMod, + type=CTDef,tname=get_datastr_name(CTDef)}, + CType = check_type(NewS,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) -> + constraint_merge(S,Acc). + + +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 is_record(Ext,'Externaltypereference') -> + check_externaltypereference(S,Ext); + + +check_constraint(S,{'SizeConstraint',{Lb,Ub}}) + when is_list(Lb);is_tuple(Lb),size(Lb)==2 -> + NewLb = range_check(resolv_tuple_or_list(S,Lb)), + NewUb = range_check(resolv_tuple_or_list(S,Ub)), + {'SizeConstraint',{NewLb,NewUb}}; +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 is_list(L) -> + F = fun(A) -> resolv_value(S,A) end, + {'SingleValue',lists:map(F,L)}; + +check_constraint(S,{'SingleValue', V}) when is_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)}}; +%% In case of a constraint with extension marks like (1..Ub,...) +check_constraint(S,{VR={'ValueRange', {_Lb, _Ub}},Rest}) -> + {check_constraint(S,VR),Rest}; +check_constraint(_S,{'PermittedAlphabet',PA}) -> + {'PermittedAlphabet',permitted_alphabet_cnstr(PA)}; + +check_constraint(S,{valueset,Type}) -> + {valueset,check_type(S,S#state.tname,Type)}; + +check_constraint(_S,ST={simpletable,Type}) when is_atom(Type) -> + %% An already checked constraint + ST; +check_constraint(S,{simpletable,Type}) -> + Def = case Type of + #type{def=D} -> D; + {'SingleValue',ObjRef = #'Externalvaluereference'{}} -> + ObjRef + end, + C = match_parameters(S,Def,S#state.parameters), + case C of + #'Externaltypereference'{} -> + ERef = check_externaltypereference(S,C), + {simpletable,ERef#'Externaltypereference'.type}; + #type{def=#'Externaltypereference'{type=T}} -> + check_externaltypereference(S,C#type.def), + {simpletable,T}; + {valueset,#type{def=ERef=#'Externaltypereference'{}}} -> % this is an object set + {_,TDef} = get_referenced_type(S,ERef), + case TDef#typedef.typespec of + #'ObjectSet'{} -> + check_object(S,TDef,TDef#typedef.typespec), + {simpletable,ERef#'Externaltypereference'.type}; + Err -> + exit({error,{internal_error,Err}}) + end; + #'Externalvaluereference'{} -> + %% This is an object set with a referenced object + {_,TorVDef} = get_referenced_type(S,C), + GetObjectSet = + fun(#typedef{typespec=O}) when is_record(O,'Object') -> + #'ObjectSet'{class=O#'Object'.classname, + set={'SingleValue',C}}; + (#valuedef{type=Cl,value=O}) + when is_record(O,'Externalvaluereference'), + is_record(Cl,type) -> + %% an object might reference another object + #'ObjectSet'{class=Cl#type.def, + set={'SingleValue',O}}; + (Err) -> + exit({error,{internal_error,simpletable_constraint,Err}}) + end, + ObjSet = GetObjectSet(TorVDef), + {simpletable,check_object(S,Type,ObjSet)}; + #'ObjectSet'{} -> + io:format("ALERT: simpletable forbidden case!~n",[]), + {simpletable,check_object(S,Type,C)}; + {'ValueFromObject',{_,ORef},FieldName} -> + %% This is an ObjectFromObject + {_,Object} = get_referenced_type(S,ORef), + ChObject = check_object(S,Object, + Object#typedef.typespec), + ObjFromObj= + get_fieldname_element(S,Object#typedef{ + typespec=ChObject}, + FieldName), + {simpletable,ObjFromObj}; +%% ObjFromObj#typedef{checked=true,typespec= +%% check_object(S,ObjFromObj, +%% ObjFromObj#typedef.typespec)}}; + _ -> + check_type(S,S#state.tname,Type),%% this seems stupid. + OSName = Def#'Externaltypereference'.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(S,Objset,S#state.parameters), + ObjSetRef = + case RealObjset of + #'Externaltypereference'{} -> RealObjset; + #type{def=#'Externaltypereference'{}} -> RealObjset#type.def; + {valueset,OS = #type{def=#'Externaltypereference'{}}} -> OS#type.def + end, + Ext = check_externaltypereference(S,ObjSetRef), + {componentrelation,{objectset,Opos,Ext},Id}; + +check_constraint(S,Type) when is_record(Type,type) -> + #type{def=Def} = check_type(S,S#state.tname,Type), + Def; + +check_constraint(S,C) when is_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. + +permitted_alphabet_cnstr(T) when is_tuple(T) -> + permitted_alphabet_cnstr([T]); +permitted_alphabet_cnstr(L) when is_list(L) -> + VRexpand = fun({'ValueRange',{A,B}}) -> + {'SingleValue',expand_valuerange(A,B)}; + (Other) -> + Other + end, + L2 = lists:map(VRexpand,L), + %% first perform intersection + L3 = permitted_alphabet_intersection(L2), + [Res] = permitted_alphabet_union(L3), + Res. + +expand_valuerange([A],[A]) -> + [A]; +expand_valuerange([A],[B]) when A < B -> + [A|expand_valuerange([A+1],[B])]. + +permitted_alphabet_intersection(C) -> + permitted_alphabet_merge(C,intersection, []). + +permitted_alphabet_union(C) -> + permitted_alphabet_merge(C,union, []). + +permitted_alphabet_merge([],_,Acc) -> + lists:reverse(Acc); +permitted_alphabet_merge([{'SingleValue',L1}, + UorI, + {'SingleValue',L2}|Rest],UorI,Acc) + when is_list(L1),is_list(L2) -> + UI = ordsets:UorI([ordsets:from_list(L1),ordsets:from_list(L2)]), + permitted_alphabet_merge([{'SingleValue',UI}|Rest],UorI,Acc); +permitted_alphabet_merge([C1|Rest],UorI,Acc) -> + permitted_alphabet_merge(Rest,UorI,[C1|Acc]). + + +%% 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 is_tuple(H) -> + C; +constraint_merge(_S,[]) -> + []; +constraint_merge(S,C) -> + %% skip all extension but the last extension + C1 = filter_extensions(C), + %% perform all internal level intersections, intersections first + %% since they have precedence over unions + C2 = lists:map(fun(X)when is_list(X)->constraint_intersection(S,X); + (X) -> X end, + C1), + %% perform all internal level unions + C3 = lists:map(fun(X)when is_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 + NewCs = combine_constraints(S,CombSV,CombVR,CombSZ++RestC), + [X||X <- lists:flatten(NewCs), + X /= intersection, + X /= union]. + +%% 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 is_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 is_integer(A2)->true; + ({_,{A1,_B1}},{_,{'MAX',_B2}}) when is_integer(A1) -> true; + ({_,{A1,_B1}},{_,{A2,_B2}}) when is_integer(A1),is_integer(A2),A1 true; + ({_,{A,B1}},{_,{A,B2}}) when B1=true; + (_,_)->false end, + % sort and remove duplicates + SortedVR = lists:sort(Fun,VR), + RemoveDup = fun([],_) ->[]; + ([H],_) -> [H]; + ([H,H|T],F) -> F([H|T],F); + ([H|T],F) -> [H|F(T,F)] + end, + + constraint_union_vr(RemoveDup(SortedVR,RemoveDup),[]). + +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-> + constraint_union_vr(Rest,[{'ValueRange',{Lb1,Ub2}}|Acc]); +constraint_union_vr([{_,{_,Ub2}}|Rest],A=[{_,{_,Ub1}}|_Acc]) when Ub2= + constraint_union_vr(Rest,A); +constraint_union_vr([VR|Rest],Acc) -> + constraint_union_vr(Rest,[VR|Acc]). + +union_sv_vr(_S,C1={'SingleValue',SV},C2={'ValueRange',VR={Lb,Ub}}) + when is_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 is_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(Val,List) -> + 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 = is_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 is_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 +%% constraints and all extensions but the last are removed. +filter_extensions([L]) when is_list(L) -> + [filter_extensions(L)]; +filter_extensions(C=[_H]) -> + C; +filter_extensions(C) when is_list(C) -> + filter_extensions(C,[], []). + +filter_extensions([],Acc,[]) -> + Acc; +filter_extensions([],Acc,[EC|ExtAcc]) -> + CwoExt = remove_extension(ExtAcc,[]), + CwoExt ++ [EC|Acc]; +filter_extensions([C={A,_E}|T],Acc,ExtAcc) when is_tuple(A) -> + filter_extensions(T,Acc,[C|ExtAcc]); +filter_extensions([C={'SizeConstraint',{A,_B}}|T],Acc,ExtAcc) + when is_list(A);is_tuple(A) -> + filter_extensions(T,Acc,[C|ExtAcc]); +filter_extensions([C={'PermittedAlphabet',{{'SingleValue',_},E}}|T],Acc,ExtAcc) + when is_tuple(E); is_list(E) -> + filter_extensions(T,Acc,[C|ExtAcc]); +filter_extensions([H|T],Acc,ExtAcc) -> + filter_extensions(T,[H|Acc],ExtAcc). + +remove_extension([],Acc) -> + Acc; +remove_extension([{'SizeConstraint',{A,_B}}|R],Acc) -> + remove_extension(R,[{'SizeConstraint',A}|Acc]); +remove_extension([{C,_E}|R],Acc) when is_tuple(C) -> + remove_extension(R,[C|Acc]); +remove_extension([{'PermittedAlphabet',{A={'SingleValue',_}, + E}}|R],Acc) + when is_tuple(E);is_list(E) -> + remove_extension(R,[{'PermittedAlphabet',A}|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 is_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 = is_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(_S,[C1={'SingleValue',SV}],[C2={'ValueRange',{_Lb,_Ub}}]) + when is_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}}) + %io:format("warning: could not analyze constraint ~p~n",[[C1,C2]]), + [C1,C2] + end; +intersection_sv_vr(_S,[C1={'SingleValue',SV}],[C2]) + when is_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}}); + %io:format("warning: could not analyze constraint ~p~n",[[C1,C2]]), + [C1,C2]; + [V] -> [{'SingleValue',V}]; + L -> [{'SingleValue',L}] + end. + + +%% Size constraint [{'SizeConstraint',1},{'SizeConstraint',{{1,64},[]}}] + +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 is_integer(Int),is_tuple(Range) -> + case Range of + {Lb,Ub} when Int >= Lb, + Int =< Ub -> + intersection_of_size(S,[C1|Rest]); + {{Lb,Ub},Ext} when is_list(Ext),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 is_integer(Int),is_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 is_integer(Int), + is_list(SV) -> + SV2=intersection_of_sv1(S,Int,SV), + intersection_of_sv(S,[SV2|Rest]); +intersection_of_sv(S,[{_,SV},{_,Int}|Rest]) when is_integer(Int), + is_list(SV) -> + SV2=intersection_of_sv1(S,Int,SV), + intersection_of_sv(S,[SV2|Rest]); +intersection_of_sv(S,[{_,SV1},{_,SV2}|Rest]) when is_list(SV1), + is_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 is_integer(Int),is_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 is_integer(Int) -> + true; +is_int_in_vr(Int,{_,{'MIN',Ub}}) when is_integer(Int),Int =< Ub -> + true; +is_int_in_vr(Int,{_,{Lb,'MAX'}}) when is_integer(Int),Int >= Lb -> + true; +is_int_in_vr(Int,{_,{Lb,Ub}}) when is_integer(Int),Int >= Lb,Int =< Ub -> + true; +is_int_in_vr(_,_) -> + false. + + +check_imported(S,Imodule,Name) -> + check_imported(S,Imodule,Name,false). +check_imported(S,Imodule,Name,IsParsed) -> + case asn1_db:dbget(Imodule,'MODULE') of + undefined when IsParsed == true -> + ErrStr = io_lib:format("Type ~s imported from non existing module ~s~n",[Name,Imodule]), + error({imported,ErrStr,S}); + undefined -> + parse_and_save(S,Imodule), + check_imported(S,Imodule,Name,true); + Im when is_record(Im,module) -> + case is_exported(Im,Name) of + false -> + ErrStr = io_lib:format("Imported type ~s not exported from module ~s~n",[Name,Imodule]), + error({imported,ErrStr,S}); + _ -> + ok + end + end, + ok. + +is_exported(Module,Name) when is_record(Module,module) -> + {exports,Exports} = Module#module.exports, + case Exports of + all -> + true; + [] -> + false; + L when is_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 -> + {NewMod,_} = get_referenced_type(S,Etref), + Etref#'Externaltypereference'{module=NewMod} + 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}; +%% case check_imported(S,Imodule,Name) of +%% ok -> +%% #'Externaltypereference'{module=Imodule,type=Name}; +%% Err -> +%% Err +%% end; + _ -> + %may be a renamed type in multi file compiling! + {M,T}=get_renamed_reference(S,Name,Emod), + NewName = asn1ct:get_name_of_def(T), + NewPos = asn1ct:get_pos_of_def(T), + #'Externaltypereference'{pos=NewPos, + module=M, + 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. + + +get_referenced_type(S,Ext) when is_record(Ext,'Externaltypereference') -> + case match_parameters(S,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; + ERef = #'Externaltypereference'{} -> + get_referenced_type(S,ERef); + Other -> + {undefined,Other} + end; +get_referenced_type(S=#state{mname=Emod}, + ERef=#'Externalvaluereference'{pos=P,module=Emod, + value=Eval}) -> + case match_parameters(S,ERef,S#state.parameters) of + ERef -> + get_referenced1(S,Emod,Eval,P); + OtherERef when is_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(S,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) -> + ?dbg("get_referenced: ~p~n",[Ename]), + parse_and_save(S,Emod), + ?dbg("get_referenced,parse_and_save ~n",[]), + case asn1_db:dbget(Emod,Ename) of + undefined -> + %% May be an imported entity in module Emod or Emod may not exist + case asn1_db:dbget(Emod,'MODULE') of + undefined -> + case parse_and_save(S,Emod) of + ok -> + get_referenced(S,Emod,Ename,Pos); + _ -> + throw({error,{asn1,{module_not_found,Emod}}}) + end; + _ -> + NewS = update_state(S,Emod), + get_imported(NewS,Ename,Emod,Pos) + end; + T when is_record(T,typedef) -> + ?dbg("get_referenced T: ~p~n",[T]), + Spec = T#typedef.typespec, %% XXXX Spec may be something else than #type + case Spec of + #type{def=#typereference{}} -> + Tref = Spec#type.def, + 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 -> + ?dbg("get_referenced V: ~p~n",[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) -> + ?dbg("get_imported, Module: ~p, Name: ~p~n",[Module,Name]), + case imported(S,Name) of + {ok,Imodule} -> + parse_and_save(S,Imodule), + case asn1_db:dbget(Imodule,'MODULE') of + undefined -> + case parse_and_save(S,Imodule) of + ok -> + %% check with cover + get_referenced(S,Module,Name,Pos); + _ -> + throw({error,{asn1,{module_not_found,Imodule}}}) + end; + Im when is_record(Im,module) -> + case is_exported(Im,Name) of + false -> + throw({error, + {asn1,{not_exported,{Im,Name}}}}); + _ -> + ?dbg("get_imported, is_exported ~p, ~p~n",[Imodule,Name]), + get_referenced_type(S, + #'Externaltypereference' + {module=Imodule, + type=Name,pos=Pos}) + end + end; + _ -> + get_renamed_reference(S,Name,Module) + end. + +check_and_save(S,#'Externaltypereference'{module=M}=ERef,#typedef{checked=false}=TDef,Settings) + when S#state.mname /= M -> + %% This ERef is an imported type (or maybe a set.asn compilation) + NewS = S#state{mname=M,module=load_asn1_module(S,M), + type=TDef,tname=get_datastr_name(TDef)}, + Type=check_type(NewS,TDef,TDef#typedef.typespec),%XXX + CheckedTDef = TDef#typedef{checked=true, + typespec=Type}, + asn1_db:dbput(M,get_datastr_name(TDef),CheckedTDef), + {merged_name(S,ERef),Settings}; +check_and_save(S,#'Externaltypereference'{module=M,type=N}=Eref, + #ptypedef{name=Name,args=Params} = PTDef,Settings) -> + %% instantiate a parameterized type + %% The parameterized type should be saved as a type in the module + %% it was instantiated. + NewS = S#state{mname=M,module=load_asn1_module(S,M), + type=PTDef,tname=Name}, + {Args,RestSettings} = lists:split(length(Params),Settings), + Type = check_type(NewS,PTDef,#type{def={pt,Eref,Args}}), + ERefName = new_reference_name(N), + ERefNew = #'Externaltypereference'{type=ERefName,module=S#state.mname}, + NewTDef=#typedef{checked=true,name=ERefName, + typespec=Type}, + insert_once(S,parameterized_objects,{ERefName,type,NewTDef}), + asn1_db:dbput(S#state.mname,ERefNew#'Externaltypereference'.type, + NewTDef), + {ERefNew,RestSettings}; +check_and_save(_S,ERef,TDef,Settings) -> + %% This might be a renamed type in a set of specs, so rename the ERef + {ERef#'Externaltypereference'{type=asn1ct:get_name_of_def(TDef)},Settings}. + +save_object_set_instance(S,Name,ObjSetSpec) + when is_record(ObjSetSpec,'ObjectSet') -> + NewObjSet = #typedef{checked=true,name=Name,typespec=ObjSetSpec}, + asn1_db:dbput(S#state.mname,Name,NewObjSet), + case ObjSetSpec of + #'ObjectSet'{uniquefname={unique,undefined}} -> + ok; + _ -> + %% Should be generated iff + %% ObjSpec#'ObjectSet'.uniquefname /= {unique,undefined} + ObjSetKey = {Name,objectset,NewObjSet}, + %% asn1ct_gen:insert_once(parameterized_objects,ObjSetKey) + insert_once(S,parameterized_objects,ObjSetKey) + end, + #'Externaltypereference'{module=S#state.mname,type=Name}. + +%% load_asn1_module do not check that the module is saved. +%% If get_referenced_type is called before the module must +%% be saved. +load_asn1_module(#state{mname=M,module=Mod},M)-> + Mod; +load_asn1_module(_,M) -> + asn1_db:dbget(M,'MODULE'). + +parse_and_save(S,Module) when is_record(S,state) -> + Erule = S#state.erule, + case asn1db_member(S,Erule,Module) of + true -> + ok; + _ -> + case asn1ct:parse_and_save(Module,S) of + ok -> + save_asn1db_uptodate(S,Erule,Module); + Err -> + Err + end + end. + +asn1db_member(S,Erule,Module) -> + Asn1dbUTL = get_asn1db_uptodate(S), + lists:member({Erule,Module},Asn1dbUTL). + +save_asn1db_uptodate(S,Erule,Module) -> + Asn1dbUTL = get_asn1db_uptodate(S), + Asn1dbUTL2 = lists:keydelete(Module,2,Asn1dbUTL), + put_asn1db_uptodate([{Erule,Module}|Asn1dbUTL2]). + +get_asn1db_uptodate(S) -> + case get(asn1db_uptodate) of + undefined -> [{S#state.erule,S#state.mname}]; %initialize + L -> L + end. + +put_asn1db_uptodate(L) -> + put(asn1db_uptodate,L). + +update_state(S,undefined) -> + S; +update_state(S=#state{mname=ModuleName},ModuleName) -> + S; +update_state(S,ModuleName) -> + case lists:member(ModuleName,S#state.inputmodules) of + true -> + S; + _ -> + parse_and_save(S,ModuleName), + case asn1_db:dbget(ModuleName,'MODULE') of + RefedMod when is_record(RefedMod,module) -> + S#state{mname=ModuleName,module=RefedMod}; + _ -> throw({error,{asn1,{module_does_not_exist,ModuleName}}}) + end + end. + + +get_renamed_reference(S,Name,Module) -> + case renamed_reference(S,Name,Module) of + undefined -> + throw({error,{asn1,{undefined_type,Name}}}); + NewTypeName when NewTypeName =/= Name -> + get_referenced1(S,Module,NewTypeName,undefined) + end. +renamed_reference(S,#'Externaltypereference'{type=Name,module=Module}) -> + case renamed_reference(S,Name,Module) of + undefined -> + Name; + Other -> + Other + 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 -> undefined; + _ -> + case ets:match(renamed_defs,{'$1',Name,Module}) of + [] -> + case ets:info(original_imports) of + undefined -> + undefined; + _ -> + case ets:match(original_imports,{Module,'$1'}) of + [] -> + undefined; + [[ImportsList]] -> + case get_importmoduleoftype(ImportsList,Name) of + undefined -> + undefined; + NextMod -> + renamed_reference(S,Name,NextMod) + end + end + end; + [[NewTypeName]] -> + NewTypeName + 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(_S,Name,[]) -> + Name; + +match_parameters(_S,#'Externaltypereference'{type=Name},[{#'Externaltypereference'{type=Name},NewName}|_T]) -> + NewName; +match_parameters(_S,#'Externaltypereference'{type=Name},[{{_,#'Externaltypereference'{type=Name}},NewName}|_T]) -> + NewName; +match_parameters(_S,#'Externalvaluereference'{value=Name},[{#'Externalvaluereference'{value=Name},NewName}|_T]) -> + NewName; +match_parameters(_S,#'Externalvaluereference'{value=Name},[{{_,#'Externalvaluereference'{value=Name}},NewName}|_T]) -> + NewName; +match_parameters(_S,#type{def=#'Externaltypereference'{module=M,type=Name}}, + [{#'Externaltypereference'{module=M,type=Name},Type}]) -> + Type; +match_parameters(_S,{valueset,#type{def=#'Externaltypereference'{type=Name}}}, + [{{_,#'Externaltypereference'{type=Name}},{valueset,#type{def=NewName}}}|_T]) -> + NewName; +match_parameters(_S,{valueset,#type{def=#'Externaltypereference'{type=Name}}}, + [{{_,#'Externaltypereference'{type=Name}}, + NewName=#type{def=#'Externaltypereference'{}}}|_T]) -> + NewName#type.def; +match_parameters(_S,{valueset,#type{def=#'Externaltypereference'{type=Name}}}, + [{{_,#'Externaltypereference'{type=Name}},NewName}|_T]) -> + NewName; +%% When a parameter is a parameterized element it has to be +%% instantiated now! +match_parameters(S,{valueset,T=#type{def={pt,_,_Args}}},_Parameters) -> + case catch check_type(S,#typedef{name=S#state.tname,typespec=T},T) of + pobjectsetdef -> + + {_,ObjRef,_Params} = T#type.def, + {_,ObjDef}=get_referenced_type(S,ObjRef), + %%ObjDef is a pvaluesetdef where the type field holds the class + ClassRef = + case ObjDef of + #pvaluesetdef{type=TDef} -> + TDef#type.def; + #pobjectsetdef{class=ClRef} -> ClRef + end, + %% The reference may not have the home module of the class + {HomeMod,_} = get_referenced_type(S,ClassRef), + RightClassRef = + ClassRef#'Externaltypereference'{module=HomeMod}, + + ObjectSet = #'ObjectSet'{class=RightClassRef,set=T}, + ObjSpec = check_object(S,#typedef{typespec=ObjectSet},ObjectSet), + Name = list_to_atom(asn1ct_gen:list2name([get_datastr_name(ObjDef)|S#state.recordtopname])), + save_object_set_instance(S,Name,ObjSpec); + pvaluesetdef -> error({pvaluesetdef,"parameterized valueset",S}); + {error,_Reason} -> error({type,"error in parameter",S}); + Ts when is_record(Ts,type) -> Ts#type.def + end; +%% same as previous, only depends on order of parsing +match_parameters(S,{valueset,{pos,{objectset,_,POSref},Args}},Parameters) -> + match_parameters(S,{valueset,#type{def={pt,POSref,Args}}},Parameters); +match_parameters(S,Name, [_H|T]) -> + %%io:format("match_parameters(~p,~p)~n",[Name,[H|T]]), + match_parameters(S,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) -> + []; +check_integer(S,NamedNumberList,_C) -> + case [X||X<-NamedNumberList,is_tuple(X),size(X)=:=2] of + NamedNumberList -> + %% An already checked integer with NamedNumberList + NamedNumberList; + _ -> + case check_unique(NamedNumberList,2) of + [] -> + check_int(S,NamedNumberList,[]); + L when is_list(L) -> + error({type,{duplicates,L},S}), + unchanged + end + end. + + +check_int(S,[{'NamedNumber',Id,Num}|T],Acc) when is_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_real(_S,_Constr) -> + ok. + +check_bitstring(_S,[],_Constr) -> + []; +check_bitstring(S,NamedNumberList,_Constr) -> + case check_unique(NamedNumberList,2) of + [] -> + check_bitstr(S,NamedNumberList,[]); + L when is_list(L) -> + error({type,{duplicates,L},S}), + unchanged + end. + +check_bitstr(S,[{'NamedNumber',Id,Num}|T],Acc)when is_integer(Num) -> + check_bitstr(S,T,[{Id,Num}|Acc]); +check_bitstr(S,[{'NamedNumber',Id,Name}|T],Acc) when is_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 is_list(L) -> + error({type,{duplicate_values,L},S}), + unchanged + end; +%% When a BIT STRING already is checked, for instance a COMPONENTS OF S +%% where S is a sequence that has a component that is a checked BS, the +%% NamedNumber list is a list of {atom(),integer()} elements. +check_bitstr(S,[El={Id,Num}|Rest],Acc) when is_atom(Id),is_integer(Num) -> + check_bitstr(S,Rest,[El|Acc]). + + +%% 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; + {_,#classdef{typespec=NextEref}} + when is_record(NextEref,'Externaltypereference') -> + check_type_identifier(S,NextEref); + {_,TD=#typedef{typespec=#type{def=#'Externaltypereference'{}}}} -> + check_type_identifier(S,(TD#typedef.typespec)#type.def); + Err -> + error({type,{"object set in type INSTANCE OF " + "not of class TYPE-IDENTIFIER",Eref,Err},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), + instance_of_decl(S#state.mname); +%% put(instance_of,{generate,S#state.mname}); + _ -> + instance_of_decl(S#state.mname), + 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=[{valuefieldreference,id}], + fieldname={id,[]}, + type={fixedtypevaluefield,id, + #type{def='OBJECT IDENTIFIER'}}}, + Typefield = + #'ObjectClassFieldType'{classname=TypeIdentifierRef, + class=[], +%% fieldname=[{typefieldreference,'Type'}], + 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 is_atom(Name), is_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,Root) when is_integer(Num) -> + check_enum(S,T,[{Id,Num}|Acc1],Acc2,Root); +check_enum(S,[{'NamedNumber',Id,{identifier,_,Name}}|T],Acc1,Acc2,Root) -> + Val = dbget_ex(S,S#state.mname,Name), + check_enum(S,[{'NamedNumber',Id,Val#valuedef.value}|T],Acc1,Acc2,Root); +check_enum(S,['EXTENSIONMARK'|T],Acc1,Acc2,_Root) -> + NewAcc2 = lists:keysort(2,Acc1), + NewList = enum_number(lists:reverse(Acc2),NewAcc2,0,[],[]), + { NewList, check_enum(S,T,[],[],enum_counts(NewList))}; +check_enum(S,[Id|T],Acc1,Acc2,Root) when is_atom(Id) -> + check_enum(S,T,Acc1,[Id|Acc2],Root); +check_enum(_S,[],Acc1,Acc2,Root) -> + NewAcc2 = lists:keysort(2,Acc1), + enum_number(lists:reverse(Acc2),NewAcc2,0,[],Root). + + +% assign numbers to identifiers , numbers from 0 ... but must not +% be the same as already assigned to NamedNumbers +enum_number(Identifiers,NamedNumbers,Cnt,Acc,[]) -> + enum_number(Identifiers,NamedNumbers,Cnt,Acc); +enum_number(Identifiers,NamedNumbers,_Cnt,Acc,CountL) -> + enum_extnumber(Identifiers,NamedNumbers,Acc,CountL). + +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:append([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]). + +enum_extnumber(Identifiers,NamedNumbers,Acc,[C]) -> + check_add_enum_numbers(NamedNumbers,[C]), + enum_number(Identifiers,NamedNumbers,C,Acc); +enum_extnumber([H|T],[{Id,Num}|T2],Acc,[C|Counts]) when Num > C -> + enum_extnumber(T,[{Id,Num}|T2],[{H,C}|Acc],Counts); +enum_extnumber([],L2,Acc,Cnt) -> + check_add_enum_numbers(L2, Cnt), + lists:concat([lists:reverse(Acc),L2]); +enum_extnumber(_Identifiers,[{Id,Num}|_T2],_Acc,[C|_]) when Num < C -> +%% enum_extnumber(Identifiers,T2,[{Id,Num}|Acc],Counts); + exit({error,{asn1,"AdditionalEnumeration element with same number as root element",{Id,Num}}}); +enum_extnumber(Identifiers,[{Id,Num}|T2],Acc,[_C|Counts]) -> % Num =:= C + enum_extnumber(Identifiers,T2,[{Id,Num}|Acc],Counts); +enum_extnumber([H|T],[],Acc,[C|Counts]) -> + enum_extnumber(T,[],[{H,C}|Acc],Counts). + +enum_counts([]) -> + [0]; +enum_counts(L) -> + Used=[I||{_,I}<-L], + AddEnumLb = lists:max(Used) + 1, + lists:foldl(fun(El,AccIn)->lists:delete(El,AccIn) end, + lists:seq(0,AddEnumLb), + Used). +check_add_enum_numbers(L, Cnt) -> + Max = lists:max(Cnt), + Fun = fun({_,N}=El) when N < Max -> + case lists:member(N,Cnt) of + false -> + exit({error,{asn1,"AdditionalEnumeration element with same number as root element",El}}); + _ -> + ok + end; + (_) -> + ok + end, + lists:foreach(Fun,L). + + +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 ,is_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 is_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; + Ret = {Root1,NewE,Root2} -> + TagComps = Root1 ++ [Comp#'ComponentType'{prop='OPTIONAL'}|| Comp <- NewE]++Root2, + %% This is not correct handling if Extension + %% contains ExtensionAdditionGroups + 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 + {CRelInf,NewComps2} = componentrelation_leadingattr(S,NewComps), + + %% 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), + + {CRelInf,CompListWithTblInf}; + Dupl -> + throw({error,{asn1,{duplicate_components,Dupl}}}) + end. + +expand_components(S, [{'COMPONENTS OF',Type}|T]) -> + CompList = expand_components2(S,get_referenced_type(S,Type#type.def)), + expand_components(S,CompList) ++ expand_components(S,T); +expand_components(S,[H|T]) -> + [H|expand_components(S,T)]; +expand_components(_,[]) -> + []. +expand_components2(_S,{_,#typedef{typespec=#type{def=Seq}}}) + when is_record(Seq,'SEQUENCE') -> + case Seq#'SEQUENCE'.components of + {R1,_Ext,R2} -> R1 ++ R2; + {Root,_Ext} -> Root; + Root -> Root + end; +expand_components2(_S,{_,#typedef{typespec=#type{def=Set}}}) + when is_record(Set,'SET') -> + case Set#'SET'.components of + {R1,_Ext,R2} -> R1 ++ R2; + {Root,_Ext} -> Root; + Root -> Root + end; +expand_components2(_S,{_,#typedef{typespec=RefType=#type{def=#'Externaltypereference'{}}}}) -> + [{'COMPONENTS OF',RefType}]; +expand_components2(S,{_,PT={pt,_,_}}) -> + PTType = check_type(S,PT,#type{def=PT}), + expand_components2(S,{dummy,#typedef{typespec=PTType}}); +expand_components2(S,{_,OCFT = #'ObjectClassFieldType'{}}) -> + UncheckedType = #type{def=OCFT}, + Type = check_type(S,#typedef{typespec=UncheckedType},UncheckedType), + expand_components2(S,{undefined,oCFT_def(S,Type)}); +expand_components2(S,{_,ERef}) when is_record(ERef,'Externaltypereference') -> + expand_components2(S,get_referenced_type(S,ERef)); +expand_components2(_S,Err) -> + throw({error,{asn1,{illegal_COMPONENTS_OF,Err}}}). + + +check_unique_sequence_tags(S,[#'ComponentType'{prop=mandatory}|Rest]) -> + check_unique_sequence_tags(S,Rest); +check_unique_sequence_tags(S,[C|Rest]) when is_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 is_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 is_record(Component,type) -> + check_type(S,Type,Component). + +check_set(S,Type,Components) -> + {TableCInf,NewComponents} = check_sequence(S,Type,Components), + check_distinct_tags(NewComponents,[]), + case {lists:member(der,S#state.options),S#state.erule} of + {true,_} -> + {Sorted,SortedComponents} = sort_components(der,S,NewComponents), + {Sorted,TableCInf,SortedComponents}; + {_,PER} when PER =:= per; PER =:= per_bin; PER =:= uper_bin -> + {Sorted,SortedComponents} = sort_components(per,S,NewComponents), + {Sorted,TableCInf,SortedComponents}; + _ -> + {false,TableCInf,NewComponents} + end. + + +%% check that all tags are distinct according to X.680 26.3 +check_distinct_tags({C1,C2,C3},Acc) when is_list(C1),is_list(C2),is_list(C3) -> + check_distinct_tags(C1++C2++C3,Acc); +check_distinct_tags({C1,C2},Acc) when is_list(C1),is_list(C2) -> + check_distinct_tags(C1++C2,Acc); +check_distinct_tags([#'ComponentType'{tags=[T]}|Cs],Acc) -> + check_distinct(T,Acc), + check_distinct_tags(Cs,[T|Acc]); +check_distinct_tags([C=#'ComponentType'{tags=[T|Ts]}|Cs],Acc) -> + check_distinct(T,Acc), + check_distinct_tags([C#'ComponentType'{tags=Ts}|Cs],[T|Acc]); +check_distinct_tags([#'ComponentType'{tags=[]}|_Cs],_Acc) -> + throw({error,"Not distinct tags in SET"}); +check_distinct_tags([],_) -> + ok. +check_distinct(T,Acc) -> + case lists:member(T,Acc) of + true -> + throw({error,"Not distinct tags in SET"}); + _ -> ok + end. + +%% sorting in canonical order according to X.680 8.6, X.691 9.2 +%% DER: all components shall be sorted in canonical order. +%% PER: only root components shall be sorted in canonical order. The +%% extension components shall remain in textual order. +%% +sort_components(der,S=#state{tname=TypeName},Components) -> + {R1,Ext,R2} = extension(textual_order(Components)), + CompsList = case Ext of + noext -> R1; + _ -> R1 ++ Ext ++ R2 + end, + case {untagged_choice(S,CompsList),Ext} of + {false,noext} -> + {true,sort_components1(TypeName,CompsList,[],[],[],[])}; + {false,_} -> + {true,{sort_components1(TypeName,CompsList,[],[],[],[]), []}}; + {true,noext} -> + %% sort in run-time + {dynamic,R1}; + _ -> + {dynamic,{R1, Ext, R2}} + end; +sort_components(per,S=#state{tname=TypeName},Components) -> + {R1,Ext,R2} = extension(textual_order(Components)), + Root = tag_untagged_choice(S,R1++R2), + case Ext of + noext -> + {true,sort_components1(TypeName,Root,[],[],[],[])}; + _ -> + {true,{sort_components1(TypeName,Root,[],[],[],[]), + Ext}} + 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 (decode_type(T1) == 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. + +sort_universal_type(Components) -> + List = lists:map(fun(C) -> + #'ComponentType'{tags=[{_,T}|_]} = C, + {decode_type(T),C} + end, + Components), + SortedList = lists:keysort(1,List), + lists:map(fun(X)->element(2,X) end,SortedList). + +decode_type(I) when is_integer(I) -> + I; +decode_type(T) -> + asn1ct_gen_ber:decode_type(T). + +untagged_choice(_S,[#'ComponentType'{typespec=#type{tag=[],def={'CHOICE',_}}}|_Rest]) -> + true; +untagged_choice(S,[#'ComponentType'{typespec=#type{tag=[],def=ExRef}}|Rest]) + when is_record(ExRef,'Externaltypereference')-> + case get_referenced_type(S,ExRef) of + {_,#typedef{typespec=#type{tag=[], + def={'CHOICE',_}}}} -> true; + _ -> untagged_choice(S,Rest) + end; +untagged_choice(S,[_|Rest]) -> + untagged_choice(S,Rest); +untagged_choice(_,[]) -> + false. + + +tag_untagged_choice(S,Cs) -> + tag_untagged_choice(S,Cs,[]). +tag_untagged_choice(S,[C = #'ComponentType'{typespec=#type{tag=[],def={'CHOICE',_}}}|Rest],Acc) -> + TagList = C#'ComponentType'.tags, + TaggedC = C#'ComponentType'{tags=get_least_tag(TagList)}, + tag_untagged_choice(S,Rest,[TaggedC|Acc]); +tag_untagged_choice(S,[C = #'ComponentType'{typespec=#type{tag=[],def=ExRef}}|Rest],Acc) when is_record(ExRef,'Externaltypereference') -> + case get_referenced_type(S,ExRef) of + {_,#typedef{typespec=#type{tag=[], + def={'CHOICE',_}}}} -> + TagList = C#'ComponentType'.tags, + TaggedC = C#'ComponentType'{tags = get_least_tag(TagList)}, + tag_untagged_choice(S,Rest,[TaggedC|Acc]); + _ -> + tag_untagged_choice(S,Rest,[C|Acc]) + end; +tag_untagged_choice(S,[C|Rest],Acc) -> + tag_untagged_choice(S,Rest,[C|Acc]); +tag_untagged_choice(_S,[],Acc) -> + Acc. +get_least_tag([]) -> + []; +get_least_tag(TagList) -> + %% The smallest tag 'PRIVATE' < 'CONTEXT' < 'APPLICATION' < 'UNIVERSAL' + Pred = fun({'PRIVATE',_},{'CONTEXT',_}) -> true; + ({'CONTEXT',_},{'APPLICATION',_}) -> true; + ({'APPLICATION',_},{'UNIVERSAL',_}) -> true; + ({A,T1},{A,T2}) when T1 =< T2 -> true; (_,_) -> false + end, + [T|_] = lists:sort(Pred,TagList), + [T]. + +%% adds the textual order to the components to keep right order of +%% components in the asn1-value. +textual_order(Cs) -> + Fun = fun(C,Index) -> + {C#'ComponentType'{textual_order=Index},Index+1} + end, + {NewCs,_} = textual_order(Cs,Fun,1), + NewCs. +textual_order(Cs,Fun,IxIn) when is_list(Cs) -> + lists:mapfoldl(Fun,IxIn,Cs); +textual_order({Root,Ext},Fun,IxIn) -> + {NewRoot,IxR} = textual_order(Root,Fun,IxIn), + {NewExt,_} = textual_order(Ext,Fun,IxR), + {{NewRoot,NewExt},dummy}; +textual_order({Root1,Ext,Root2},Fun,IxIn) -> + {NewRoot1,IxR} = textual_order(Root1,Fun,IxIn), + {NewExt,IxE} = textual_order(Ext,Fun,IxR), + {NewRoot2,_} = textual_order(Root2,Fun,IxE), + {{NewRoot1,NewExt,NewRoot2},dummy}. + +extension(Components) when is_list(Components) -> + {Components,noext,[]}; +extension({Root,ExtList}) -> + ToOpt = fun(mandatory) -> + 'OPTIONAL'; + (X) -> X + end, + {Root, [X#'ComponentType'{prop=ToOpt(Y)}|| + X = #'ComponentType'{prop=Y}<-ExtList],[]}; +extension({Root1,ExtList,Root2}) -> + ToOpt = fun(mandatory) -> + 'OPTIONAL'; + (X) -> X + end, + {Root1, [X#'ComponentType'{prop=ToOpt(Y)}|| + X = #'ComponentType'{prop=Y}<-ExtList], Root2}. + +check_setof(S,Type,Component) when is_record(Component,type) -> + check_type(S,Type,Component). + +check_selectiontype(S,Name,#type{def=Eref}) + when is_record(Eref,'Externaltypereference') -> + {RefMod,TypeDef} = get_referenced_type(S,Eref), + NewS = S#state{module=load_asn1_module(S,RefMod), + mname=RefMod, + type=TypeDef, + tname=get_datastr_name(TypeDef)}, + check_selectiontype2(NewS,Name,TypeDef); +check_selectiontype(S,Name,Type=#type{def={pt,_,_}}) -> + TName = + case S#state.recordtopname of + [] -> + S#state.tname; + N -> N + end, + TDef = #typedef{name=TName,typespec=Type}, + check_selectiontype2(S,Name,TDef); +check_selectiontype(S,Name,Type) -> + Msg = lists:flatten(io_lib:format("SelectionType error: ~w < ~w must be a reference to a CHOICE.",[Name,Type])), + error({type,Msg,S}). + +check_selectiontype2(S,Name,TypeDef) -> + NewS = S#state{recordtopname=get_datastr_name(TypeDef)}, + CheckedType = check_type(NewS,TypeDef,TypeDef#typedef.typespec), + Components = get_choice_components(S,CheckedType#type.def), + case lists:keysearch(Name,#'ComponentType'.name,Components) of + {value,C} -> + %% The selected type will have the tag of the selected type. + _T = C#'ComponentType'.typespec; +% T#type{tag=def_to_tag(NewS,T#type.def)}; + _ -> + Msg = lists:flatten(io_lib:format("error checking SelectionType: ~w~n",[Name])), + error({type,Msg,S}) + end. + + +check_restrictedstring(_S,_Def,_Constr) -> + ok. + +check_objectidentifier(_S,_Constr) -> + ok. + +check_relative_oid(_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 is_list(Components) -> + case check_unique([C||C <- Components, + is_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; + + Dupl -> + throw({error,{asn1,{duplicate_choice_alternatives,Dupl}}}) + end; +check_choice(_S,_,[]) -> + []. + +maybe_automatic_tags(S,C) -> + TagNos = tag_nums(C), + case (S#state.module)#module.tagdefault of + 'AUTOMATIC' -> + generate_automatic_tags(S,C,TagNos); + _ -> + %% 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,TagNos); + false -> + C + end + end. + +%% Pos == 1 for Root1, 2 for Ext, 3 for Root2 +tag_nums(Cl) -> + tag_nums(Cl,0,0). +tag_nums([{'EXTENSIONMARK',_,_}|Rest],Ext,Root2) -> + tag_nums_ext(Rest,Ext,Root2); +tag_nums([_|Rest],Ext,Root2) -> + tag_nums(Rest,Ext+1,Root2+1); +tag_nums([],Ext,Root2) -> + [0,Ext,Root2]. +tag_nums_ext([{'EXTENSIONMARK',_,_}|Rest],Ext,Root2) -> + tag_nums_root2(Rest,Ext,Root2); +tag_nums_ext([_|Rest],Ext,Root2) -> + tag_nums_ext(Rest,Ext,Root2); +tag_nums_ext([],Ext,_Root2) -> + [0,Ext,0]. +tag_nums_root2([_|Rest],Ext,Root2) -> + tag_nums_root2(Rest,Ext+1,Root2); +tag_nums_root2([],Ext,Root2) -> + [0,Ext,Root2]. + +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 + case ets:lookup(automatic_tags,Name) of +% true -> +% true; +% _ -> +% false + [] -> false; + _ -> true + 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|TagNos]) when is_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|TagNos])]; +generate_automatic_tags1([ExtMark|T],[_TagNo|TagNos]) -> % EXTENSIONMARK + [ExtMark | generate_automatic_tags1(T,TagNos)]; +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 is_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,Components) -> + check_each_component(S,Type,Components,[],[],[],root1). + +check_each_component(S = #state{abscomppath=Path,recordtopname=TopName},Type, + [C|Ct],Acc,Extacc,Acc2,Ext) when is_record(C,'ComponentType') -> + #'ComponentType'{name=Cname,typespec=Ts,prop=Prop} = C, + NewAbsCPath = + case Ts#type.def of + #'Externaltypereference'{} -> []; + _ -> [Cname|Path] + end,%%XXX Cname = 'per-message-indicators' + CheckedTs = check_type(S#state{abscomppath=NewAbsCPath, + recordtopname=[Cname|TopName]},Type,Ts), + NewTags = get_taglist(S,CheckedTs), + + NewProp = + case normalize_value(S,CheckedTs,Prop,[Cname|TopName]) of + mandatory -> mandatory; + 'OPTIONAL' -> 'OPTIONAL'; + DefaultValue -> {'DEFAULT',DefaultValue} + end, + NewC = C#'ComponentType'{typespec=CheckedTs,prop=NewProp,tags=NewTags}, + case Ext of + root1 -> + check_each_component(S,Type,Ct,[NewC|Acc],Extacc,Acc2,Ext); + ext -> + check_each_component(S,Type,Ct,Acc,[NewC|Extacc],Acc2,Ext); + root2 -> + check_each_component(S,Type,Ct,Acc,Extacc,[NewC|Acc2],Ext) + end; +check_each_component(S,Type,[_|Ct],Acc,Extacc,Acc2,root1) -> % skip 'EXTENSIONMARK' + check_each_component(S,Type,Ct,Acc,Extacc,Acc2,ext); +check_each_component(S,Type,[_|Ct],Acc,Extacc,Acc2,ext) -> % skip 'EXTENSIONMARK' + check_each_component(S,Type,Ct,Acc,Extacc,Acc2,root2); +check_each_component(_S,_,[_C|_Ct],_,_,_,root2) -> % '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,_,[],Acc1,ExtAcc,Acc2,root2) -> + {lists:reverse(Acc1),lists:reverse(ExtAcc),lists:reverse(Acc2)}; +check_each_component(_S,_,[],Acc,_,_,root1) -> + 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 is_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) -> + Cs = + case CompList of + {Comp1, EComps, Comp2} -> + Comp1++EComps++Comp2; + {Components,EComponents} when is_list(Components) -> + Components ++ EComponents; + CompList when is_list(CompList) -> + CompList + end, + + %% 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,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(S,#classdef{typespec=ClassDef})) of + {error,'__undefined_',_} -> + no_unique; + {asn1,Msg,_} -> + error({type,Msg,S}); + {'EXIT',Msg} -> + error({type,{internal_error,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 is_atom(ObjSet) -> + ObjSet; +object_set_mod_name(#state{mname=M}, + #'Externaltypereference'{module=M,type=T}) -> + {M,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_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,[])|get_simple_table_info(S,Cs,Rest)]; +get_simple_table_info(_,_,[]) -> + []. +get_simple_table_info1(S,Cs,[Cname|Cnames],Path) when is_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 constraint_member(simpletable,Cnstr) of + {true,{simpletable,_OSRef}} -> + simple_table_info(S,OCFT,Path); + _ -> + error({type,{"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). + + +simple_table_info(S,#'ObjectClassFieldType'{classname=ClRef, + class=ObjectClass, + fieldname=FieldName},Path) -> + + 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(S,ClassDef)) of + {error,'__undefined_',_} -> no_unique; + {asn1,Msg,_} -> + error({type,Msg,S}); + {'EXIT',Msg} -> + error({type,{internal_error,Msg},S}); + {Other,_} -> Other + end, + {lists:reverse(Path),ObjectClassFieldName,UniqueName}; +simple_table_info(S,Type,_) -> + error({type,{"the type referenced by a componentrelation constraint must be a ObjectClassFieldType",Type},S}). + + +%% 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 constraint_member(componentrelation,Type#type.constraint) of +%% [{componentrelation,_,AtNotation}] -> + {true,{_,_,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,NamePath,CNames,AtNot); + _ -> + [] + end, + InnerAcc = + case {Type#type.inlined, + asn1ct_gen:type(asn1ct_gen:get_inner(Type#type.def))} of + {no,{constructed,bif}} -> + {InnerCs,NewNamePath} = + case get_components(Type#type.def) of + {IC1,_IC2} -> {IC1 ++ IC1,[CName|NamePath]}; + T when is_record(T,type) -> {T,NamePath}; + IC -> {IC,[CName|NamePath]} + 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,NewNamePath,[]); + _ -> + [] + end, + any_component_relation(S,Cs,CNames,NamePath,InnerAcc++CRelPath++Acc); +any_component_relation(S,Type,CNames,NamePath,Acc) when is_record(Type,type) -> + CRelPath = + case constraint_member(componentrelation,Type#type.constraint) of + {true,{_,_,AtNotation}} -> + AtNot = extract_at_notation(AtNotation), + evaluate_atpath(S,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, + any_component_relation(S,InnerCs,CNames,NamePath,[]); + _ -> + [] + end, + InnerAcc ++ CRelPath ++ Acc; +any_component_relation(_,[],_,_,Acc) -> + Acc. + +constraint_member(componentrelation,[CRel={componentrelation,_,_}|_Rest]) -> + {true,CRel}; +constraint_member(simpletable,[ST={simpletable,_}|_Rest]) -> + {true,ST}; +constraint_member(Key,[_H|T]) -> + constraint_member(Key,T); +constraint_member(_,[]) -> + false. + +%% 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(S=#state{abscomppath=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},S}) + throw({type,{asn1,"failed to analyze at-path",AtPath},S}) + 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; +%do not step in inlined structures +get_components(any,{'SEQUENCE OF',T = #type{def=_Def,inlined=no}}) -> +% get_components(any,Def); + T; +get_components(any,{'SET OF',T = #type{def=_Def,inlined=no}}) -> +% get_components(any,Def); + T; +get_components(_,_) -> + []. + +get_choice_components(_S,{'CHOICE',Components}) when is_list(Components)-> + Components; +get_choice_components(_S,{'CHOICE',{C1,C2}}) when is_list(C1),is_list(C2) -> + C1++C2; +get_choice_components(S,ERef=#'Externaltypereference'{}) -> + {_RefMod,TypeDef}=get_referenced_type(S,ERef), + #typedef{typespec=TS} = TypeDef, + get_choice_components(S,TS#type.def). + +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] -> + case constraint_member(componentrelation,Constraint) of + {true,{_,{_,_,ObjectSet},AtList}} -> + [{_,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}; + _ -> + %% 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] -> + case constraint_member(componentrelation,Cons) of + {true,{_,{_,_,ObjectSet},AtList}} -> + %% 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(_S,ClassDef) when is_record(ClassDef,classdef) -> +%% {_,Fields,_} = ClassDef#classdef.typespec, + Fields = (ClassDef#classdef.typespec)#objectclass.fields, + get_unique_fieldname1(Fields,[]); +get_unique_fieldname(S,#typedef{typespec=#type{def=ClassRef}}) -> + %% A class definition may be referenced as + %% REFED-CLASS ::= DEFINED-CLASS and then REFED-CLASS is a typedef + {_M,ClassDef} = get_referenced_type(S,ClassRef), + get_unique_fieldname(S,ClassDef). + +get_unique_fieldname1([],[]) -> + throw({error,'__undefined_',[]}); +get_unique_fieldname1([],[Name]) -> + Name; +get_unique_fieldname1([],Acc) -> + throw({asn1,'only one UNIQUE field is allowed in CLASS',Acc}); +get_unique_fieldname1([{fixedtypevaluefield,Name,_,'UNIQUE',Opt}|Rest],Acc) -> + get_unique_fieldname1(Rest,[{Name,Opt}|Acc]); +get_unique_fieldname1([_H|T],Acc) -> + get_unique_fieldname1(T,Acc). + +get_tableconstraint_info(S,Type,{CheckedTs,EComps,CheckedTs2}) -> + {get_tableconstraint_info(S,Type,CheckedTs,[]), + get_tableconstraint_info(S,Type,EComps,[]), + get_tableconstraint_info(S,Type,CheckedTs2,[])}; +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'{} -> + NewOCFT = + OCFT#'ObjectClassFieldType'{class=[]}, + C#'ComponentType'{typespec= + CheckedTs#type{ + def=NewOCFT + }}; +% constraint=[{tableconstraint_info, +% FieldRef}]}}; + {'SEQUENCE OF',SOType} when is_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 is_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={FieldName,RestFieldName}) when is_atom(FieldName),is_list(RestFieldName)-> + Def; +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 + is_record(ERef,'Externaltypereference') -> + {MName,Type} = get_referenced_type(S,ERef), + NewS = update_state(S#state{type=Type, + tname=ERef#'Externaltypereference'.type},MName), + ClassSpec = check_class(NewS,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); +get_ObjectClassFieldType(S,ERef,{FieldName,Rest}) -> + get_ObjectClassFieldType(S,ERef,Rest ++ [FieldName]). + +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,FieldnameList=[{_FieldType,_PrimFieldName}|_]) -> + get_OCFType(S,Fields,[PFN||{_,PFN} <- FieldnameList]); +get_OCFType(S,Fields,[PrimFieldName|Rest]) -> + case lists:keysearch(PrimFieldName,2,Fields) of + {value,{fixedtypevaluefield,_,Type,_Unique,_OptSpec}} -> + {fixedtypevaluefield,PrimFieldName,Type}; + {value,{objectfield,_,ClassRef,_Unique,_OptSpec}} -> + {MName,ClassDef} = get_referenced_type(S,ClassRef), + NewS = update_state(S#state{type=ClassDef, + tname=get_datastr_name(ClassDef)}, + MName), + CheckedCDef = check_class(NewS,ClassDef), + get_OCFType(S,CheckedCDef#objectclass.fields,Rest); + {value,{objectsetfield,_,Type,_OptSpec}} -> + {MName,ClassDef} = get_referenced_type(S,Type#type.def), + NewS = update_state(S#state{type=ClassDef, + tname=get_datastr_name(ClassDef)}, + MName), + CheckedCDef = check_class(NewS,ClassDef), + get_OCFType(S,CheckedCDef#objectclass.fields,Rest); + + {value,Other} -> + {element(1,Other),PrimFieldName}; + _ -> + throw({error,lists:flatten(io_lib:format("undefined FieldName in ObjectClassFieldType: ~w",[PrimFieldName]))}) + end. + +get_taglist(S,Ext) when is_record(Ext,'Externaltypereference') -> + {_,T} = get_referenced_type(S,Ext), + get_taglist(S,T#typedef.typespec); +get_taglist(S,Tref) when is_record(Tref,typereference) -> + {_,T} = get_referenced_type(S,Tref), + get_taglist(S,T#typedef.typespec); +get_taglist(S,Type) when is_record(Type,type) -> + case Type#type.tag of + [] -> + get_taglist(S,Type#type.def); + [Tag|_] -> + [asn1ct_gen:def_to_tag(Tag)] + 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 is_list(FieldNameList) -> + case get_ObjectClassFieldType(S,ERef,FieldNameList) of + {fixedtypevaluefield,_,Type} -> get_taglist(S,Type); + {TypeFieldName,_} when is_atom(TypeFieldName) -> []%should check if allowed + end; +get_taglist(S,{ObjCl,FieldNameList}) when is_record(ObjCl,objectclass), + is_list(FieldNameList) -> + case get_ObjectClassFieldType(S,ObjCl#objectclass.fields,FieldNameList) of + {fixedtypevaluefield,_,Type} -> get_taglist(S,Type); + {TypeFieldName,_} when is_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 is_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,[]) -> + []. + +%% def_to_tag(S,Def) -> +%% case asn1ct_gen:def_to_tag(Def) of +%% {'UNIVERSAL',T} -> +%% case asn1ct_gen:prim_bif(T) of +%% true -> +%% ?TAG_PRIMITIVE(tag_number(T)); +%% _ -> +%% ?TAG_CONSTRUCTED(tag_number(T)) +%% end; +%% _ -> [] +%% end. +%% tag_number('BOOLEAN') -> 1; +%% tag_number('INTEGER') -> 2; +%% tag_number('BIT STRING') -> 3; +%% tag_number('OCTET STRING') -> 4; +%% tag_number('NULL') -> 5; +%% tag_number('OBJECT IDENTIFIER') -> 6; +%% tag_number('ObjectDescriptor') -> 7; +%% tag_number('EXTERNAL') -> 8; +%% tag_number('INSTANCE OF') -> 8; +%% tag_number('REAL') -> 9; +%% tag_number('ENUMERATED') -> 10; +%% tag_number('EMBEDDED PDV') -> 11; +%% tag_number('UTF8String') -> 12; +%% %%tag_number('RELATIVE-OID') -> 13; +%% tag_number('SEQUENCE') -> 16; +%% tag_number('SEQUENCE OF') -> 16; +%% tag_number('SET') -> 17; +%% tag_number('SET OF') -> 17; +%% tag_number('NumericString') -> 18; +%% tag_number('PrintableString') -> 19; +%% tag_number('TeletexString') -> 20; +%% %%tag_number('T61String') -> 20; +%% tag_number('VideotexString') -> 21; +%% tag_number('IA5String') -> 22; +%% tag_number('UTCTime') -> 23; +%% tag_number('GeneralizedTime') -> 24; +%% tag_number('GraphicString') -> 25; +%% tag_number('VisibleString') -> 26; +%% %%tag_number('ISO646String') -> 26; +%% tag_number('GeneralString') -> 27; +%% tag_number('UniversalString') -> 28; +%% tag_number('CHARACTER STRING') -> 29; +%% tag_number('BMPString') -> 30. + + +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 is_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(S,M) when is_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(S,NewM#module.name), + include_default_type(NewM#module.name), + Res. + +storeindb(Module,[H|T],ErrAcc) when is_record(H,typedef) -> + storeindb(Module,H#typedef.name,H,T,ErrAcc); +storeindb(Module,[H|T],ErrAcc) when is_record(H,valuedef) -> + storeindb(Module,H#valuedef.name,H,T,ErrAcc); +storeindb(Module,[H|T],ErrAcc) when is_record(H,ptypedef) -> + storeindb(Module,H#ptypedef.name,H,T,ErrAcc); +storeindb(Module,[H|T],ErrAcc) when is_record(H,classdef) -> + storeindb(Module,H#classdef.name,H,T,ErrAcc); +storeindb(Module,[H|T],ErrAcc) when is_record(H,pvaluesetdef) -> + storeindb(Module,H#pvaluesetdef.name,H,T,ErrAcc); +storeindb(Module,[H|T],ErrAcc) when is_record(H,pobjectdef) -> + storeindb(Module,H#pobjectdef.name,H,T,ErrAcc); +storeindb(Module,[H|T],ErrAcc) when is_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 is_record(H,typedef) -> + error({type,"already defined", + #state{mname=Module,type=H,tname=Name}}); + _Type when is_record(H,valuedef) -> + error({value,"already defined", + #state{mname=Module,value=H,vname=Name}}); + _Type when is_record(H,ptypedef) -> + error({ptype,"already defined", + #state{mname=Module,type=H,tname=Name}}); + _Type when is_record(H,pobjectdef) -> + error({ptype,"already defined", + #state{mname=Module,type=H,tname=Name}}); + _Type when is_record(H,pvaluesetdef) -> + error({ptype,"already defined", + #state{mname=Module,type=H,tname=Name}}); + _Type when is_record(H,pvaluedef) -> + error({ptype,"already defined", + #state{mname=Module,type=H,tname=Name}}); + _Type when is_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 is_record(H,typedef),is_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 is_record(H,typedef),is_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 is_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 is_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 is_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 is_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 is_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 is_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 is_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 is_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~n~p~n",[Pos,Mname,Typename,Msg]), + {error,{export,Pos,Mname,Typename,Msg}}; +error({import,Msg,#state{mname=Mname,type=Ref,tname=Typename}}) -> + PosOfDef = + fun(#'Externaltypereference'{pos=P}) -> P; + (#'Externalvaluereference'{pos=P}) -> P + end, + Pos = PosOfDef(Ref), + io:format("asn1error:~p:~p:~p~n~p~n",[Pos,Mname,Typename,Msg]), + {error,{import,Pos,Mname,Typename,Msg}}; +% error({type,{Msg1,Msg2},#state{mname=Mname,type=Type,tname=Typename}}) +% when is_record(Type,typedef) -> +% io:format("asn1error:~p:~p:~p ~p~n", +% [Type#typedef.pos,Mname,Typename,Msg1]), +% {error,{type,Type#typedef.pos,Mname,Typename,Msg1,Msg2}}; +error({type,Msg,#state{mname=Mname,type=Type,tname=Typename}}) + when is_record(Type,type) -> + io:format("asn1error:~p:~p~n~p~n", + [Mname,Typename,Msg]), + {error,{type,Mname,Typename,Msg}}; +error({type,Msg,#state{mname=Mname,type=Type,tname=Typename}}) + when is_record(Type,typedef) -> + io:format("asn1error:~p:~p:~p~n~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 is_record(Type,ptypedef) -> + io:format("asn1error:~p:~p:~p~n~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 is_record(Value,valuedef) -> + io:format("asn1error:~p:~p:~p~n~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 is_record(Type,pobjectdef) -> + io:format("asn1error:~p:~p:~p~n~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}}) + when is_record(Value,valuedef) -> + io:format("asn1error:~p:~p:~p~n~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~n~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~n~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~n~p~n",[Pos,Mname,Typename,Msg]), + {error,{Other,Pos,Mname,Typename,Msg}}; +error({Other,Msg,#state{mname=Mname,type=Type,tname=Typename}}) -> + io:format("asn1error:~p:~p:~p~n~p~n",[asn1ct:get_pos_of_def(Type),Mname,Typename,Msg]), + {error,{Other,asn1ct:get_pos_of_def(Type),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', + tags=[{'UNIVERSAL',6}]}, + + Indirect_reference = + #'ComponentType'{name='indirect-reference', + typespec=#type{def='INTEGER'}, + prop='OPTIONAL', + tags=[{'UNIVERSAL',2}]}, + + Single_ASN1_type = + #'ComponentType'{name='single-ASN1-type', + typespec=#type{tag=[{tag,'CONTEXT',0, + 'EXPLICIT',32}], + def='ANY'}, + prop=mandatory, + tags=[{'CONTEXT',0}]}, + + Octet_aligned = + #'ComponentType'{name='octet-aligned', + typespec=#type{tag=[{tag,'CONTEXT',1, + 'IMPLICIT',0}], + def='OCTET STRING'}, + prop=mandatory, + tags=[{'CONTEXT',1}]}, + + Arbitrary = + #'ComponentType'{name=arbitrary, + typespec=#type{tag=[{tag,'CONTEXT',2, + 'IMPLICIT',0}], + def={'BIT STRING',[]}}, + prop=mandatory, + tags=[{'CONTEXT',2}]}, + + 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(S,Module) -> + NameAbsList = default_class_list(S), + 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, + include_default_class1(Module,Rest). + +default_class_list(S) -> + [{'TYPE-IDENTIFIER', + {objectclass, + [{fixedtypevaluefield, + id, + #type{tag=?TAG_PRIMITIVE(?N_OBJECT_IDENTIFIER), + def='OBJECT IDENTIFIER'}, + 'UNIQUE', + 'MANDATORY'}, + {typefield,'Type','MANDATORY'}], + {'WITH SYNTAX', + [{typefieldreference,'Type'}, + 'IDENTIFIED', + 'BY', + {valuefieldreference,id}]}}}, + {'ABSTRACT-SYNTAX', + {objectclass, + [{fixedtypevaluefield, + id, + #type{tag=?TAG_PRIMITIVE(?N_OBJECT_IDENTIFIER), + def='OBJECT IDENTIFIER'}, + 'UNIQUE', + 'MANDATORY'}, + {typefield,'Type','MANDATORY'}, + {fixedtypevaluefield, + property, + #type{tag=?TAG_PRIMITIVE(?N_BIT_STRING), + def={'BIT STRING',[]}}, + undefined, + {'DEFAULT', + [0,1,0]}}], + {'WITH SYNTAX', + [{typefieldreference,'Type'}, + 'IDENTIFIED', + 'BY', + {valuefieldreference,id}, + ['HAS', + 'PROPERTY', + {valuefieldreference,property}]]}}}]. + + +new_reference_name(Name) -> + case get(asn1_reference) of + undefined -> + put(asn1_reference,1), + list_to_atom(lists:concat([internal_,Name,"_",1])); + Num when is_integer(Num) -> + put(asn1_reference,Num+1), + list_to_atom(lists:concat([internal_,Name,"_",Num+1])) + end. + +get_record_prefix_name(S) -> + case lists:keysearch(record_name_prefix,1,S#state.options) of + {value,{_,Prefix}} -> + Prefix; + _ -> + "" + end. + +insert_once(S,Tab,Key) -> + case get(top_module) of + M when M == S#state.mname -> + asn1ct_gen:insert_once(Tab,Key), + ok; + _ -> + skipped + end. diff --git a/lib/asn1/src/asn1ct_constructed_ber.erl b/lib/asn1/src/asn1ct_constructed_ber.erl new file mode 100644 index 0000000000..51a241ffbd --- /dev/null +++ b/lib/asn1/src/asn1ct_constructed_ber.erl @@ -0,0 +1,1571 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1997-2009. All Rights Reserved. +%% +%% 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 online 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. +%% +%% %CopyrightEnd% +%% +%% +-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,get_record_name_prefix/0]). + +% 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 is_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 + {Rl1,El,Rl2} -> Rl1 ++ El ++ Rl2; + {Rl,El} -> Rl ++ El; + _ -> CompList + end, + EncObj = + case TableConsInfo of + #simpletableattributes{usedclassfield=Used, + uniqueclassfield=Unique} when Used /= Unique -> + false; + %% ObjectSetRef, name of the object set in constraints + %% + %%{ObjectSetRef,AttrN,N,UniqueFieldName} + #simpletableattributes{objectsetname=ObjectSetRef, + c_name=AttrN, + c_index=N, + usedclassfield=UniqueFieldName, + uniqueclassfield=UniqueFieldName, + valueindex=ValueIndex + } -> + OSDef = + case ObjectSetRef 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}), + {ObjSetMod,ObjSetName} = + case ObjectSetRef of + {M,O} -> + {{asis,M},O}; + O -> + {"?MODULE",O} + end, + emit({" ",ObjSetMod,":'getenc_",ObjSetName,"'(",{asis,UniqueFieldName}, + ", ",nl}), +% emit({indent(35),"?RT_BER:cindex(",N+1,", Val,", +% {asis,AttrN},")),",nl}), + Length = fun(X,_LFun) when is_atom(X) -> + length(atom_to_list(X)); + (X,_LFun) when is_list(X) -> + length(X); + ({X1,X2},LFun) -> + LFun(X1,LFun) + LFun(X2,LFun) + end, + emit([indent(10+Length(ObjectSetRef,Length)), + "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("asn1rt_check: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 is_record(D,type) -> + asn1ct_name:start(), + asn1ct_name:new(tag), + #'SEQUENCE'{tablecinf=TableConsInfo,components=CList} = D#type.def, + Ext = extensible(CList), + {CompList,CompList2} = case CList of + {Rl1,El,Rl2} -> {Rl1 ++ El ++ Rl2,CList}; + {Rl,El} -> {Rl ++ El, Rl ++ El}; + _ -> {CList,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 {asn1ct_gen:get_constraint(CT#type.constraint,componentrelation),CT#type.tablecinf} of +% case {CT#type.constraint,CT#type.tablecinf} of + {no,[{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, + RecordName = lists:concat([get_record_name_prefix(),asn1ct_gen:list2rname(Typename)]), + case gen_dec_sequence_call(Erules,Typename,CompList2,Ext,DecObjInf) of + no_terms -> % an empty sequence + emit([nl,nl]), + demit({"Result = "}), %dbg + %% return value as record + asn1ct_name:new(rb), + emit([" {{'",RecordName,"'}, ",{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), + {ObjSetMod,ObjSetName} = + case ObjSet of + {M,O} -> + {{asis,M},O}; + _ -> + {"?MODULE",ObjSet} + end, + emit([DecObj," =",nl," ",ObjSetMod,":'getdec_",ObjSetName,"'(", +% {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 | extensible + end, + emit([" {",{next,bytes},",",{curr,rb},"} = ?RT_BER:restbytes2(RemBytes, ", + {curr,bytes},",",ExtStatus,"),",nl]), + asn1ct_name:new(rb), + case Typename of + ['EXTERNAL'] -> + emit([" OldFormat={'",RecordName, + "', "]), + mkvlist(asn1ct_name:all(term)), + emit(["},",nl]), + emit([" ASN11994Format =",nl, + " asn1rt_check:transform_to_EXTERNAL1994", + "(OldFormat),",nl]), + emit([" {ASN11994Format,",{next,bytes},", "]); + _ -> + emit([" {{'",RecordName,"', "]), + 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 is_record(D,type) -> + gen_encode_sequence(Erules,Typename,D). + +gen_decode_set(Erules,Typename,D) when is_record(D,type) -> + asn1ct_name:start(), + asn1ct_name:clear(), + asn1ct_name:new(term), + asn1ct_name:new(tag), + #'SET'{components=TCompList} = D#type.def, + Ext = extensible(TCompList), + ToOptional = fun(mandatory) -> + 'OPTIONAL'; + (X) -> X + end, + CompList = case TCompList of + {Rl1,El,Rl2} -> + Rl1 ++ [X#'ComponentType'{prop=ToOptional(Y)}||X = #'ComponentType'{prop=Y}<-El] ++ Rl2; + {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), + {ExtFlatten1,ExtFlatten2} = + case Ext of + noext -> {"",""}; + _ -> {"lists:flatten(",")"} + end, + emit([" 'dec_",asn1ct_gen:list2name(Typename), + "__result__'(lists:sort(",ExtFlatten1,"SetTerm",ExtFlatten2,"), 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),"_ -> ",nl]), + case Ext of + noext -> + emit([indent(9),"{[], Bytes,0}",nl]); + _ -> + asn1ct_name:new(rbCho), + emit([indent(9),"{RestBytes, ",{curr,rbCho}, + "} = ?RT_BER:skipvalue(Bytes),",nl, + indent(9),"{[], RestBytes, ",{curr,rbCho},"}",nl]) + end, + 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}), + RecordName = lists:concat([get_record_name_prefix(), + asn1ct_gen:list2rname(Typename)]), + case gen_dec_set_result(Erules,Typename,CompList) of + no_terms -> + %% return value as record + asn1ct_name:new(rb), + emit({" {{'",RecordName,"'}, Bytes, Rb}.",nl}); + _ -> + emit({nl," case ",{curr,termList}," of",nl}), + emit({" [] -> {{'",RecordName,"', "}), + 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 is_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 is_record(D,type) -> + asn1ct_name:start(), + asn1ct_name:clear(), + {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 is_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 is_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 when SeqOrSetOf=='SET OF' -> + emit([indent(3), + "{asn1rt_check: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), + mandatory,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 is_record(D,type) -> + ChoiceTag = D#type.tag, + {'CHOICE',CompList} = D#type.def, + Ext = extensible(CompList), + CompList1 = case CompList of + {Rl1,El,Rl2} -> Rl1 ++ El ++ Rl2; + {Rl,El} -> Rl ++ El; + _ -> CompList + end, + gen_enc_choice(Erules,Typename,ChoiceTag,CompList1,Ext), + emit({nl,nl}). + +gen_decode_choice(Erules,Typename,D) when is_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 + {Rl1,El,Rl2} -> Rl1 ++ El ++Rl2; + {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,textual_order=Order}|Rest],Pos,Ext,EncObj) -> + asn1ct_name:new(encBytes), + asn1ct_name:new(encLen), + CindexPos = + case Order of + undefined -> + Pos; + _ -> Order % der + end, + Element = + case TopType of + ['EXTERNAL'] -> + io_lib:format("?RT_BER:cindex(~w,NewVal,~w)",[CindexPos+1,Cname]); + _ -> + io_lib:format("?RT_BER:cindex(~w,Val,~w)",[CindexPos+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) + when is_list(CompList) -> + gen_dec_sequence_call1(Erules,TopType, CompList, 1, Ext,DecObjInf,[],[]); +gen_dec_sequence_call(Erules,TopType,CList,Ext,DecObjInf) -> + gen_dec_sequence_call2(Erules,TopType,CList,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_call2(_Erules,_TopType,{[],[],[]},_Ext,_DecObjInf) -> + no_terms; +gen_dec_sequence_call2(Erules,TopType,{Root1,EList,Root2},_Ext,DecObjInf) -> + {LA,ArgsAcc} = + case gen_dec_sequence_call1(Erules,TopType,Root1++EList,1, + extensible({Root1,EList}),DecObjInf,[],[]) of + no_terms -> + {[],[]}; + Res -> Res + end, + %% TagList is the tags of Root2 elements from the first up to and + %% including the first mandatory element. + TagList = get_root2_taglist(Root2,[]), + emit({com,nl}), + asn1ct_name:new(bytes), + emit([" {",{next,bytes},", ",{next,rb}, + "} = ?RT_BER:skip_ExtensionAdditions(", + {curr,bytes},", ",{asis,TagList},"),",nl]), + asn1ct_name:new(rb), + asn1ct_name:new(bytes), + gen_dec_sequence_call1(Erules,TopType,Root2, + length(Root1)+length(EList),noext, + DecObjInf,LA,ArgsAcc). + +%% returns a list of tags of the elements in the component (second +%% root) list up to and including the first mandatory tag. See 24.6 in +%% X.680 (7/2002) +get_root2_taglist([],Acc) -> + lists:reverse(Acc); +get_root2_taglist([#'ComponentType'{prop=Prop,typespec=Type}|Rest],Acc) -> + FirstTag = fun([])->[]; + ([H|_T])->H#tag{class=asn1ct_gen_ber:decode_class(H#tag.class)} + end(Type#type.tag), + case Prop of + mandatory -> + %% match_tags/ may be used + %% this is the last tag of interest -> return + lists:reverse([FirstTag|Acc]); + _ -> + get_root2_taglist(Rest,[FirstTag|Acc]) + end. + + +%%---------------------------- +%%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, + + Prop1 = case {Prop,Ext} of + {_,{ext,Epos,_Root2pos}} when Pos < Epos -> + Prop; + {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) -> + ExtCatch = case Ext of + noext ->""; + _ -> " catch" + end, + TagList = get_all_choice_tags(CompList), + emit({indent(3), + {curr,tagList}," = ",{asis,TagList},",",nl}), + emit({indent(3), + "case",ExtCatch," ?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) -> + 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). + + + +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) -> + 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 is_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}; + _ -> + case Type#type.tablecinf of + [{objfun,_}] -> {{no_attr,"ObjFun"},[]}; + _-> {false,[]} + end + end, + gen_enc_line(Erules,TopType,Cname,Type,"element(2,Val)",9, + mandatory,Assign,Encobj), + case {Type#type.def,Encobj} of + {#'ObjectClassFieldType'{},{no_attr,"ObjFun"}} -> + emit({",",nl,indent(9),"{",{curr,encBytes},", ", + {curr,encLen},"}"}); + _ -> ok + 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 is_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 is_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=C, + def=#'ObjectClassFieldType'{type={typefield,_}}}, + Element,Indent,OptOrMand=mandatory,EncObj) + when is_list(Element) -> + case asn1ct_gen:get_constraint(C,componentrelation) of + {componentrelation,_,_} -> + 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, + ["{",{curr,encBytes},",",{curr,encLen},"} = "], + EncObj) + end; + gen_enc_line(Erules,TopType,Cname,Type,Element,Indent,OptOrMand,EncObj) + when is_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 is_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{def=#'ObjectClassFieldType'{type={typefield,_}, + fieldname=RefedFieldName}}, + {componentrelation,_,_}} -> + {_LeadingAttrName,Fun} = EncObj, + case RefedFieldName of + {Name,RestFieldNames} when is_atom(Name),Name =/= notype -> + case OptOrMand of + mandatory -> ok; + _ -> + 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},", ",{curr,tmpLen}, + "} = "}), + emit({"?RT_BER:encode_open_type(",{curr,tmpBytes}, + ",",{asis,Tag},"),",nl}), + emit(IndDeep), + emit({"{",{next,tmpBytes},", ",{curr,tmpLen},"}"}) + end; + Err -> + throw({asn1,{'internal error',Err}}) + end; + _ -> + 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); + '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(Erules,TopType,Cname,WhatKind,dec,3), + emit([DecFunName,", ",{asis,Tag}]); + _ -> + {DecFunName, _, _} = + mkfunname(Erules,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} when CTag =/= [] -> % R9C-0.patch-34 + 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. + ObjSetName = case ObjSet of + {deep,OSName,_,_} -> + OSName; + _ -> ObjSet + end, + {[{ObjSetName,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), + {ObjSetMod,ObjSetName} = + case OSet of + {M,O} -> + {{asis,M},O}; + _ -> + {"?MODULE",OSet} + end, + emit({",",nl,"ObjFun = ",ObjSetMod,":'getdec_",ObjSetName,"'(", + {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 is_list(CompList) -> + noext; +extensible({RootList,ExtList}) -> + {ext,length(RootList)+1,length(ExtList)}; +extensible({_Rl1,_ExtL,_Rl2}) -> + extensible. + +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(Erule,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}; + 'ASN1_OPEN_TYPE' -> + case Arity of + 3 -> + F = lists:concat(["fun(A,_,C) -> ?RT_BER:decode_open_type(",Erule,",A,C) end"]), + {F, "?MODULE", F}; + 4 -> + F = lists:concat(["fun(A,_,C,_) -> ?RT_BER:decode_open_type(",Erule,",A,C) end"]), + {F, "?MODULE", F} + end + end. + +empty_lb(ber) -> + "[]"; +empty_lb(ber_bin) -> + "<<>>". + +rtmod(ber) -> + list_to_atom(?RT_BER_BIN); +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 is_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/asn1/src/asn1ct_constructed_ber_bin_v2.erl b/lib/asn1/src/asn1ct_constructed_ber_bin_v2.erl new file mode 100644 index 0000000000..a55ac9db8e --- /dev/null +++ b/lib/asn1/src/asn1ct_constructed_ber_bin_v2.erl @@ -0,0 +1,1486 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2002-2009. All Rights Reserved. +%% +%% 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 online 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. +%% +%% %CopyrightEnd% +%% +%% +-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,get_record_name_prefix/0]). +-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 is_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 + {Rl1,El,Rl2} -> Rl1 ++ El ++ Rl2; + {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=ObjectSetRef, + c_name=AttrN, + c_index=N, + usedclassfield=UniqueFieldName, + uniqueclassfield=UniqueFieldName, + valueindex=ValueIndex} -> %% N is index of attribute that determines constraint + OSDef = + case ObjectSetRef 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])), + {ObjSetMod,ObjSetName} = + case ObjectSetRef of + {M,O} -> + {{asis,M},O}; + _ -> + {"?MODULE",ObjectSetRef} + end, + emit([ObjectEncode," = ",nl]), + emit([" ",ObjSetMod,":'getenc_",ObjSetName,"'(",{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("asn1rt_check: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 is_record(D,type) -> + asn1ct_name:start(), + asn1ct_name:clear(), + asn1ct_name:new(tag), + #'SEQUENCE'{tablecinf=TableConsInfo,components=CList} = D#type.def, + Ext = extensible(CList), + {CompList,CompList2} = + case CList of + {Rl1,El,Rl2} -> {Rl1 ++ El ++ Rl2, CList}; + {Rl,El} -> {Rl ++ El, Rl ++ El}; + _ -> {CList, CList} + end, + + emit([" %%-------------------------------------------------",nl]), + emit([" %% decode tag and length ",nl]), + emit([" %%-------------------------------------------------",nl]), + + asn1ct_name:new(tlv), + case CompList of + [] -> % 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=ObjectSetRef, + c_name=AttrN, + usedclassfield=UniqueFieldName, + uniqueclassfield=UniqueFieldName, + valueindex=ValIndex} -> +% {ObjectSetRef,AttrN,_N,UniqueFieldName} ->%% N is index of attribute that determines constraint + F = fun(#'ComponentType'{typespec=CT})-> + case {asn1ct_gen:get_constraint(CT#type.constraint,componentrelation),CT#type.tablecinf} of + {no,[{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,ObjectSetRef,UniqueFieldName,ValIndex}}, + UniqueFieldName,ValIndex}; + false -> + {{AttrN,ObjectSetRef},UniqueFieldName,ValIndex} + end; + _ -> + {false,false,false} + end, + RecordName = lists:concat([get_record_name_prefix(), + asn1ct_gen:list2rname(Typename)]), + case gen_dec_sequence_call(Erules,Typename,CompList2,Ext,DecObjInf) of + no_terms -> % an empty sequence + emit([nl,nl]), + demit(["Result = "]), %dbg + %% return value as record + asn1ct_name:new(rb), + emit([" {'",RecordName,"'}.",nl,nl]); + {LeadingAttrTerm,PostponedDecArgs} -> + emit([com,nl,nl]), + case {LeadingAttrTerm,PostponedDecArgs} of + {[],[]} -> + ok; + {_,[]} -> + ok; + {[{ObjSetRef,LeadingAttr,Term}],PostponedDecArgs} -> + DecObj = asn1ct_gen:un_hyphen_var(lists:concat(['DecObj',LeadingAttr,Term])), + ValueMatch = value_match(ValueIndex,Term), + {ObjSetMod,ObjSetName} = + case ObjSetRef of + {M,O} -> + {{asis,M},O}; + _ -> + {"?MODULE",ObjSetRef} + end, + emit([DecObj," =",nl, + " ",ObjSetMod,":'getdec_",ObjSetName,"'(", + {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 | extensible + 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={'",RecordName, + "', "]), + mkvlist(asn1ct_name:all(term)), + emit(["},",nl]), + emit([" asn1rt_check:transform_to_EXTERNAL1994", + "(OldFormat).",nl]); + _ -> + emit([" {'",RecordName,"', "]), + 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 is_record(D,type) -> + gen_encode_sequence(Erules,Typename,D). + +gen_decode_set(Erules,Typename,D) when is_record(D,type) -> + asn1ct_name:start(), + asn1ct_name:clear(), +%% asn1ct_name:new(term), + asn1ct_name:new(tag), + #'SET'{tablecinf=TableConsInfo,components=TCompList} = D#type.def, + Ext = extensible(TCompList), + ToOptional = fun(mandatory) -> + 'OPTIONAL'; + (X) -> X + end, + CompList = case TCompList of + {Rl1,El,Rl2} -> Rl1 ++ [X#'ComponentType'{prop=ToOptional(Y)}||X = #'ComponentType'{prop=Y}<-El] ++ Rl2; + {Rl,El} -> Rl ++ El; + _ -> TCompList + end, + + %% asn1ct_name:clear(), + asn1ct_name:new(tlv), + case CompList of + [] -> % empty sequence + true; + _ -> + emit([{curr,tlv}," = "]) + end, + emit(["?RT_BER:match_tags(",{prev,tlv},",TagIn), ",nl]), + asn1ct_name:new(v), + + + {DecObjInf,UniqueFName,ValueIndex} = + case TableConsInfo of +%% {ObjectSetRef,AttrN,_N,UniqueFieldName} ->%% N is index of attribute that determines constraint + #simpletableattributes{objectsetname=ObjectSetRef, + c_name=AttrN, + usedclassfield=UniqueFieldName, + uniqueclassfield=UniqueFieldName, + valueindex=ValIndex} -> + F = fun(#'ComponentType'{typespec=CT})-> + case {asn1ct_gen:get_constraint(CT#type.constraint, + componentrelation), + CT#type.tablecinf} of + {no,[{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,ObjectSetRef,UniqueFieldName,ValIndex}}, + UniqueFieldName,ValIndex}; + false -> + {{AttrN,ObjectSetRef},UniqueFieldName,ValIndex} + end; + _ -> + {false,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, + RecordName = lists:concat([get_record_name_prefix(), + asn1ct_gen:list2rname(Typename)]), + 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([" {'",RecordName,"'}.",nl]); + {LeadingAttrTerm,PostponedDecArgs} -> + emit([com,nl,nl]), + case {LeadingAttrTerm,PostponedDecArgs} of + {[],[]} -> + ok; + {_,[]} -> + ok; + {[{ObjSetRef,LeadingAttr,Term}],PostponedDecArgs} -> + DecObj = asn1ct_gen:un_hyphen_var(lists:concat(['DecObj',LeadingAttr,Term])), + ValueMatch = value_match(ValueIndex,Term), + {ObjSetMod,ObjSetName} = + case ObjSetRef of + {M,O} -> + {{asis,M},O}; + _ -> + {"?MODULE",ObjSetRef} + end, + emit([DecObj," =",nl, + " ",ObjSetMod,":'getdec_",ObjSetName,"'(", + {asis,UniqueFName},", ",ValueMatch,"),",nl]), + gen_dec_postponed_decs(DecObj,PostponedDecArgs) + end, + demit(["Result = "]), %dbg + %% return value as record + case Ext of + Extnsn when Extnsn =/= noext -> + 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([" {'",RecordName,"', "]), + mkvlist(asn1ct_name:all(term)), + emit(["}.",nl]) + end. + + +%%=============================================================================== +%%=============================================================================== +%%=============================================================================== +%% Encode/decode SEQUENCE OF and SET OF +%%=============================================================================== +%%=============================================================================== +%%=============================================================================== + +gen_encode_sof(Erules,Typename,_InnerTypename,D) when is_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 is_record(D,type) -> + asn1ct_name:start(), + asn1ct_name:clear(), + {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 is_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 is_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 when SeqOrSetOf=='SET OF'-> + emit([indent(3), + "{asn1rt_check: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), + mandatory,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 is_record(D,type) -> + ChoiceTag = D#type.tag, + {'CHOICE',CompList} = D#type.def, + Ext = extensible(CompList), + CompList1 = case CompList of + {Rl1,El,Rl2} -> Rl1 ++ El ++ Rl2; + {Rl,El} -> Rl ++ El; + _ -> CompList + end, + gen_enc_choice(Erules,Typename,ChoiceTag,CompList1,Ext), + emit([nl,nl]). + +gen_decode_choice(Erules,Typename,D) when is_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 + {Rl1,El,Rl2} -> Rl1 ++ El ++ Rl2; + {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,textual_order=Order}|Rest],Pos,Ext,EncObj) -> + asn1ct_name:new(encBytes), + asn1ct_name:new(encLen), + CindexPos = + case Order of + undefined -> + Pos; + _ -> Order % der + end, + Element = + case TopType of + ['EXTERNAL'] -> + io_lib:format("Cindex~w",[CindexPos]); + _ -> + io_lib:format("Cindex~w",[CindexPos]) + 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) + when is_list(CompList) -> + gen_dec_sequence_call1(Erules,TopType, CompList, 1, Ext,DecObjInf,[],[]); +gen_dec_sequence_call(Erules,TopType,CompList,Ext,DecObjInf) -> + gen_dec_sequence_call2(Erules,TopType, CompList, 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. + +gen_dec_sequence_call2(_Erules,_TopType, {[], [], []}, _Ext,_DecObjInf) -> + no_terms; +gen_dec_sequence_call2(Erules,TopType,{Root1,EList,Root2},_Ext,DecObjInf) -> + {LA,ArgsAcc} = + case gen_dec_sequence_call1(Erules,TopType,Root1++EList,1, + extensible({Root1,EList}),DecObjInf,[],[]) of + no_terms -> + {[],[]}; + Res -> Res + end, + %% TagList is the tags of Root2 elements from the first up to and + %% including the first mandatory element. + TagList = get_root2_taglist(Root2,[]), + emit({com,nl}), + emit([{curr,tlv}," = ?RT_BER:skip_ExtensionAdditions(", + {prev,tlv},", ",{asis,TagList},"),",nl]), + asn1ct_name:new(tlv), + gen_dec_sequence_call1(Erules,TopType,Root2, + length(Root1)+length(EList),noext, + DecObjInf,LA,ArgsAcc). + +%% returns a list of tags of the elements in the component (second +%% root) list up to and including the first mandatory tag. See 24.6 in +%% X.680 (7/2002) +get_root2_taglist([],Acc) -> + lists:reverse(Acc); +get_root2_taglist([#'ComponentType'{prop=Prop,typespec=Type}|Rest],Acc) -> + FirstTag = fun([])->[]; + ([H|_T])->(?ASN1CT_GEN_BER:decode_class(H#tag.class) bsl 10) + + H#tag.number + end(Type#type.tag), + case Prop of + mandatory -> + %% match_tags/ may be used + %% this is the last tag of interest -> return + lists:reverse([FirstTag|Acc]); + _ -> + get_root2_taglist(Rest,[FirstTag|Acc]) + end. + + + +%%---------------------------- +%%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, + + 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,NotFalse) + when NotFalse /= false -> + 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 is_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}; + _ -> + case Type#type.tablecinf of + [{objfun,_}] -> {{no_attr,"ObjFun"},[]}; + _ -> {false,[]} + end + end, + gen_enc_line(Erules,TopType,Cname,Type,"element(2,Val)",9, + mandatory,Assign,Encobj), + case {Type#type.def,Encobj} of + {#'ObjectClassFieldType'{},{no_attr,"ObjFun"}} -> + emit([",",nl,indent(9),"{",{curr,encBytes},", ", + {curr,encLen},"}"]); + _ -> ok + 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=C, + def=#'ObjectClassFieldType'{type={typefield,_}}}, + Element,Indent,OptOrMand=mandatory,EncObj) + when is_list(Element) -> + case asn1ct_gen:get_constraint(C,componentrelation) of + {componentrelation,_,_} -> + 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, + ["{",{curr,encBytes},",",{curr,encLen},"} = "], + EncObj) + end; +% gen_enc_line(Erules,TopType,Cname, +% Type=#type{constraint=[{componentrelation,_,_}], +% def=#'ObjectClassFieldType'{type={typefield,_}}}, +% Element,Indent,OptOrMand=mandatory,EncObj) +% when is_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 is_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 is_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 is_atom(Name), Name =/= notype -> + 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; + Err -> + throw({asn1,{'internal error',Err}}) + 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. + ObjSetName = case ObjSet of + {deep,OSName,_,_} -> + OSName; + _ -> ObjSet + end, + {[{ObjSetName,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), + {ObjSetMod,ObjSetName} = + case OSet of + {M,O} -> + {{asis,M},O}; + _ -> + {"?MODULE",OSet} + end, + emit([",",nl,"ObjFun = ",ObjSetMod,":'getdec_",ObjSetName,"'(", + {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 is_list(List) -> + Sindex = + case WhatKind of + #'Externaltypereference'{} -> +% asn1ct:maybe_rename_function(WhatKind,List), + SI = asn1ct:maybe_saved_sindex(WhatKind,List), + Saves = {WhatKind,SI,List}, + asn1ct:add_tobe_refed_func(Saves), + SI; + _ -> +% asn1ct:maybe_rename_function([Cname|TopType], +% List), + SI = asn1ct:maybe_saved_sindex([Cname|TopType],List), + Saves = {[Cname|TopType],SI,List,Type}, + asn1ct:add_tobe_refed_func(Saves), + SI + end, + asn1ct:update_gen_state(namelist,Rest), + Prefix=asn1ct:get_gen_state_field(prefix), +% Suffix = +% lists:concat(["_",asn1ct:latest_sindex()]), + Suffix = + case Sindex of + I when is_integer(I),I>0 -> lists:concat(["_",I]); + _ -> "" + end, + {DecFunName,_,_}= + mkfuncname(TopType,Cname,WhatKind,Prefix,Suffix), +% SuffixedName = +% lists:concat([DecFunName,asn1ct:latest_sindex()]), + 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 is_list(CompList) -> + noext; +extensible({RootList,ExtList}) -> + {ext,length(RootList)+1,length(ExtList)}; +extensible({_Rl1,_Ext,_Rl2}) -> + extensible. + + +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,Suffix) -> + CurrMod = get(currmod), + case WhatKind of + #'Externaltypereference'{module=CurrMod,type=EType} -> + F = lists:concat(["'",Prefix,EType,Suffix,"'"]), + {F, "?MODULE", F}; + #'Externaltypereference'{module=Mod,type=EType} -> + {lists:concat(["'",Mod,"':'",Prefix,EType,Suffix,"'"]),Mod, + lists:concat(["'",Prefix,EType,"'"])}; + {constructed,bif} -> + F = lists:concat(["'",Prefix, + asn1ct_gen:list2name([Cname|TopType]), + Suffix,"'"]), + {F, "?MODULE", F} + end. + +empty_lb(ber) -> + "[]"; +empty_lb(ber_bin) -> + "<<>>"; +empty_lb(ber_bin_v2) -> + "<<>>". + +value_match(Index,Value) when is_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/asn1/src/asn1ct_constructed_per.erl b/lib/asn1/src/asn1ct_constructed_per.erl new file mode 100644 index 0000000000..2a1c0ebc6b --- /dev/null +++ b/lib/asn1/src/asn1ct_constructed_per.erl @@ -0,0 +1,1393 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1997-2009. All Rights Reserved. +%% +%% 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 online 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. +%% +%% %CopyrightEnd% +%% +%% +-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,get_record_name_prefix/0]). + +%% 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(Erule,Typename,D) when is_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(to_textual_order(CompList)),CompList} of + {[],EmptyCL} when EmptyCL == {[],[],[]};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 = ",Opt} = ?RT_PER:fixoptionals(", + 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 + {{ObjSetMod,ObjSetName},OSDef} = + case ObjectSet of + {Module,OSName} -> + {{{asis,Module},OSName},asn1_db:dbget(Module,OSName)}; + OSName -> + {{"?MODULE",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([" ",ObjSetMod,":'getenc_",ObjSetName,"'(", + {asis,UniqueFieldName},", ",nl]), + El = make_element(N+1,asn1ct_gen:mk_var(asn1ct_name:curr(val)),AttrN), + + Length = fun(X,_LFun) when is_atom(X) -> + length(atom_to_list(X)); + (X,_LFun) when is_list(X) -> + length(X); + ({X1,X2},LFun) -> + LFun(X1,LFun) + LFun(X2,LFun) + end, + Indent = 12 + Length(ObjectSet,Length), + 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(Erule,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 is_record(D,type) -> + asn1ct_name:start(), + asn1ct_name:clear(), + {CompList,TableConsInfo} = + case D#type.def of + #'SEQUENCE'{tablecinf=TCI,components=CL} -> + {add_textual_order(CL),TCI}; + #'SET'{tablecinf=TCI,components=CL} -> + {add_textual_order(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 {asn1ct_gen:get_constraint(CT#type.constraint,componentrelation),CT#type.tablecinf} of + {no,[{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(Erules,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), + {ObjSetMod,ObjSetName} = + case ObjSet of + {M,O} -> {{asis,M},O}; + _ -> {"?MODULE",ObjSet} + end, + emit({DecObj," =",nl," ",ObjSetMod,":'getdec_",ObjSetName,"'(", +% {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 + RecordName = lists:concat([get_record_name_prefix(), + asn1ct_gen:list2rname(Typename)]), + case Typename of + ['EXTERNAL'] -> + emit({" OldFormat={'",RecordName, + "'"}), + mkvlist(asn1ct_name:all(term)), + emit({"},",nl}), + emit({" ASN11994Format =",nl, + " asn1rt_check:transform_to_EXTERNAL1994", + "(OldFormat),",nl}), + emit(" {ASN11994Format,"); + _ -> + emit(["{{'",RecordName,"'"]), + mkvlist(textual_order(CompList,asn1ct_name:all(term))), + emit("},") + end, + emit({{var,asn1ct_name:curr(bytes)},"}"}), + emit({".",nl,nl}). + +textual_order([#'ComponentType'{textual_order=undefined}|_],TermList) -> + TermList; +textual_order(CompList,TermList) when is_list(CompList) -> + TermTuple = list_to_tuple(TermList), %% ['Term1','Term2',...'TermN'] + %% OrderList is ordered by canonical order of tags + TmpTuple = TermTuple, + OrderList = [Ix||#'ComponentType'{textual_order=Ix} <- CompList], + Fun = fun(X,{Tpl,Ix}) -> + + {setelement(X,Tpl,element(Ix,TermTuple)),Ix+1} + end, + {Ret,_} = lists:foldl(Fun,{TmpTuple,1},OrderList), +%% io:format("TermTuple: ~p~nOrderList: ~p~nRet: ~p~n",[TermTuple,OrderList,tuple_to_list(Ret)]), + tuple_to_list(Ret); +textual_order({Root,Ext},TermList) -> + textual_order(Root ++ Ext,TermList); +textual_order({Root1,Ext,Root2},TermList) -> + textual_order(Root1 ++ Ext ++ Root2, TermList). + +to_textual_order({Root,Ext}) -> + {to_textual_order(Root),Ext}; +to_textual_order(Cs) when is_list(Cs) -> + case Cs of + [#'ComponentType'{textual_order=undefined}|_] -> + Cs; + _ -> + lists:keysort(#'ComponentType'.textual_order,Cs) + end; +to_textual_order(Cs) -> + Cs. + +gen_dec_listofopentypes(_,[],_) -> + emit(nl); +gen_dec_listofopentypes(DecObj,[{_Cname,{FirstPFN,PFNList},Term,TmpTerm,Prop}|Rest],_Update) -> + + 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(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(Erule,Typename,D) when is_record(D,type) -> + {'CHOICE',CompList} = D#type.def, + emit({"[",nl}), + Ext = extensible(CompList), + gen_enc_choice(Erule,Typename,CompList,Ext), + emit({nl,"].",nl}). + +gen_decode_choice(Erules,Typename,D) when is_record(D,type) -> + asn1ct_name:start(), + asn1ct_name:clear(), + asn1ct_name:new(bytes), + {'CHOICE',CompList} = D#type.def, + Ext = extensible(CompList), + gen_dec_choice(Erules,Typename,CompList,Ext), + emit({".",nl}). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% Encode generator for SEQUENCE OF type + + +gen_encode_sof(Erule,Typename,SeqOrSetOf,D) when is_record(D,type) -> + asn1ct_name:start(), + {_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(Erule,Typename,SeqOrSetOf,NewComponentType). + +gen_decode_sof(Erules,Typename,SeqOrSetOf,D) when is_record(D,type) -> + asn1ct_name:start(), + {_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(Erules,Typename,SeqOrSetOf,NewComponentType). + +gen_encode_sof_components(Erule,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,Erule,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}); + 'ASN1_OPEN_TYPE' -> + gen_encode_prim_wrapper(Ctgenmod,Erule, + #type{def='ASN1_OPEN_TYPE'}, + false,"H"); + _ -> + emit({"'enc_",Conttype,"'(H)",nl,nl}) + end, + emit({" | Acc]).",nl}). + +gen_decode_sof_components(Erule,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()])), + CurrMod = get(currmod), + case asn1ct_gen:type(Conttype) of + {primitive,bif} -> + Ctgenmod:gen_dec_prim(Erule,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=CurrMod,type=EType} -> + emit({"'dec_",EType,"'(Bytes,telltype),",nl}); + #'Externaltypereference'{module=EMod,type=EType} -> + emit({"'",EMod,"':'dec_",EType,"'(Bytes,telltype),",nl}); + 'ASN1_OPEN_TYPE' -> + Ctgenmod:gen_dec_prim(Erule,#type{def='ASN1_OPEN_TYPE'}, + "Bytes"), + emit({com,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 is_list(CompList) -> + noext; +extensible({RootList,ExtList}) -> + {ext,length(RootList)+1,length(ExtList)}; +extensible({Rl1,Ext,_Rl2}) -> + {ext,length(Rl1)+1,length(Ext)}. + +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({L1,_Ext,L2}) -> optionals(L1++L2,[],2); +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',Val}}|Rest],Acc,Pos) -> + optionals(Rest,[{Pos,Val}|Acc],Pos+1); +optionals([#'ComponentType'{}|Rest],Acc,Pos) -> + optionals(Rest,Acc,Pos+1); +optionals([],Acc,_) -> + lists:reverse(Acc). + +%%%%%%%%%%%%%%%%%%%%%% +%% create_optionality_table(Cs=[#'ComponentType'{textual_order=undefined}|_]) -> +%% {NewCs,_} = lists:mapfoldl(fun(C,Num) -> +%% {C#'ComponentType'{textual_order=Num}, +%% Num+1} +%% end, +%% 1,Cs), +%% create_optionality_table(NewCs); +create_optionality_table(Cs) -> + IsOptional = fun('OPTIONAL') -> true; + ({'DEFAULT',_}) -> true; + (_) -> false + end, + OptionalsElNum = [TO || #'ComponentType'{prop = O,textual_order=TO} <- Cs, + IsOptional(O)], + {Table,_} = lists:mapfoldl(fun(X,Num) -> + {{Num,X},Num+1} + end, + 1,lists:sort(OptionalsElNum)), + Table. +get_optionality_pos(TextPos,OptTable) -> + case lists:keysearch(TextPos,2,OptTable) of + {value,{OptNum,_}} -> + OptNum; + _ -> + no_num + end. + +add_textual_order(Cs) when is_list(Cs) -> + {NewCs,_} = add_textual_order1(Cs,1), + NewCs; +add_textual_order({Root,Ext}) -> + {NewRoot,Num} = add_textual_order1(Root,1), + {NewExt,_} = add_textual_order1(Ext,Num), + {NewRoot,NewExt}; +add_textual_order({R1,Ext,R2}) -> + {NewR1,Num1} = add_textual_order1(R1,1), + {NewExt,Num2} = add_textual_order1(Ext,Num1), + {NewR2,_} = add_textual_order1(R2,Num2), + {NewR1,NewExt,NewR2}. +add_textual_order1(Cs=[#'ComponentType'{textual_order=Int}|_],I) + when is_integer(Int) -> + {Cs,I}; +add_textual_order1(Cs,NumIn) -> + lists:mapfoldl(fun(C,Num) -> + {C#'ComponentType'{textual_order=Num}, + Num+1} + end, + NumIn,Cs). + +gen_enc_components_call(Erule,TopType,{Root1,ExtList,Root2},MaybeComma,DynamicEnc,Ext) -> + Rpos = gen_enc_components_call1(Erule,TopType,Root1,1,MaybeComma,DynamicEnc,noext), + case Ext of + {ext,_,ExtNum} when ExtNum > 0 -> + emit([nl, + ",Extensions",nl]); + _ -> true + end, + Rpos2 = gen_enc_components_call1(Erule,TopType,ExtList,Rpos,MaybeComma,DynamicEnc,Ext), + gen_enc_components_call1(Erule,TopType,Root2,Rpos2,MaybeComma,DynamicEnc,noext); +gen_enc_components_call(Erule,TopType,{CompList,ExtList},MaybeComma,DynamicEnc,Ext) -> + %% The type has extensionmarker + Rpos = gen_enc_components_call1(Erule,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(Erule,TopType,ExtList,Rpos,MaybeComma,DynamicEnc,Ext); +gen_enc_components_call(Erule,TopType, CompList, MaybeComma, DynamicEnc, Ext) -> + %% The type has no extensionmarker + gen_enc_components_call1(Erule,TopType,CompList,1,MaybeComma,DynamicEnc,Ext). + +gen_enc_components_call1(Erule,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 + TermNo = + case C#'ComponentType'.textual_order of + undefined -> + Tpos; + CanonicalNum -> + CanonicalNum + end, + emit(MaybeComma), + case Prop of + 'OPTIONAL' -> + gen_enc_component_optional(Erule,TopType,Cname,Type,TermNo,DynamicEnc,Ext); + {'DEFAULT',DefVal} -> + gen_enc_component_default(Erule,TopType,Cname,Type,TermNo,DynamicEnc,Ext,DefVal); + _ -> + case Ext of + {ext,ExtPos,_} when Tpos >= ExtPos -> + gen_enc_component_optional(Erule,TopType,Cname,Type,TermNo,DynamicEnc,Ext); + _ -> + gen_enc_component_mandatory(Erule,TopType,Cname,Type,TermNo,DynamicEnc,Ext) + end + end, + + erase(component_type), + + case Rest of + [] -> + Tpos+1; + _ -> + emit({com,nl}), + gen_enc_components_call1(Erule,TopType,Rest,Tpos+1,"",DynamicEnc,Ext) + end; +gen_enc_components_call1(_Erule,_TopType,[],Pos,_,_,_) -> + Pos. + +gen_enc_component_default(Erule,TopType,Cname,Type,Pos,DynamicEnc,Ext,DefaultVal) -> + Element = make_element(Pos+1,"Val1",Cname), + emit({"case ",Element," of",nl}), +% emit({"asn1_DEFAULT -> [];",nl}), + emit({"DFLT when DFLT == asn1_DEFAULT; DFLT == ",{asis,DefaultVal}," -> [];",nl}), + + 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(Erule,TopType,Cname,Type,NextElement, Pos,DynamicEnc,Ext), + emit({nl,"end"}). +gen_enc_component_optional(Erule,TopType,Cname,Type,Pos,DynamicEnc,Ext) -> + Element = make_element(Pos+1,"Val1",Cname), + emit({"case ",Element," of",nl}), + + emit({"asn1_NOVALUE -> [];",nl}), + 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(Erule,TopType,Cname,Type,NextElement, Pos,DynamicEnc,Ext), + emit({nl,"end"}). + +gen_enc_component_mandatory(Erule,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(Erule,TopType,Cname,Type,[],Pos,DynamicEnc,Ext). + +gen_enc_line(Erule,TopType, Cname, Type, [], Pos,DynamicEnc,Ext) -> + Element = make_element(Pos+1,asn1ct_gen:mk_var(asn1ct_name:curr(val)),Cname), + gen_enc_line(Erule,TopType,Cname,Type,Element, Pos,DynamicEnc,Ext); +gen_enc_line(Erule,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 Ext of + {ext,_Ep1,_} -> + emit(["?RT_PER:encode_open_type(dummy,?RT_PER:complete("]); + _ -> true + end, + case Atype of + {typefield,_} -> + case DynamicEnc of + {_LeadingAttrName,Fun} -> + case (Type#type.def)#'ObjectClassFieldType'.fieldname of + {notype,T} -> + throw({error,{notype,type_from_object,T}}); + {Name,RestFieldNames} when is_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,Erule,EncType, + false,Element); + 'ASN1_OPEN_TYPE' -> + case Type#type.def of + #'ObjectClassFieldType'{type=OpenType} -> + gen_encode_prim_wrapper(Ctgenmod,Erule, + #type{def=OpenType}, + false,Element); + _ -> + gen_encode_prim_wrapper(Ctgenmod,Erule,Type, + false,Element) + end; + {constructed,bif} -> + NewTypename = [Cname|TopType], + case {Type#type.tablecinf,DynamicEnc} of + {[{objfun,_}|_R],{_,EncFun}} -> + emit({"'enc_", + asn1ct_gen:list2name(NewTypename), + "'(",Element,", ",EncFun,")"}); + _ -> + emit({"'enc_", + asn1ct_gen:list2name(NewTypename), + "'(",Element,")"}) + end + end + end, + case Ext of + {ext,_Ep2,_} -> + emit(["))"]); + _ -> true + end. +gen_dec_components_call(Erule,TopType,{Root1,ExtList,Root2},MaybeComma,DecInfObj,Ext,NumberOfOptionals) -> + %% The type has extensionmarker + OptTable = create_optionality_table(Root1 ++ Root2), + {Rpos,AccTerm,AccBytes} = + gen_dec_components_call1(Erule,TopType, Root1, 1, OptTable, + 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(Erule,TopType,ExtList,Rpos, OptTable, "", + 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), + {_RPos2,AccTerm2,AccBytes2} = + gen_dec_components_call1(Erule,TopType,Root2,Epos,OptTable, + "",DecInfObj,noext,[],[],NumberOfOptionals), + {AccTerm++AccTermE++AccTerm2,AccBytes++AccBytesE++AccBytes2}; +gen_dec_components_call(Erule,TopType,{CompList,ExtList},MaybeComma, + DecInfObj,Ext,NumberOfOptionals) -> + %% The type has extensionmarker + OptTable = create_optionality_table(CompList), + {Rpos,AccTerm,AccBytes} = + gen_dec_components_call1(Erule,TopType, CompList, 1, OptTable, + 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(Erule,TopType,ExtList,Rpos, OptTable, + "",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(Erule,TopType,CompList,MaybeComma,DecInfObj, + Ext,NumberOfOptionals) -> + %% The type has no extensionmarker + OptTable = create_optionality_table(CompList), + {_,AccTerm,AccBytes} = + gen_dec_components_call1(Erule,TopType, CompList, 1, OptTable, + MaybeComma,DecInfObj,Ext,[],[], + NumberOfOptionals), + {AccTerm,AccBytes}. + + +gen_dec_components_call1(Erule,TopType, + [C=#'ComponentType'{name=Cname,typespec=Type,prop=Prop,textual_order=TextPos}|Rest], + Tpos,OptTable,MaybeComma,DecInfObj,Ext,AccTerm,AccBytes,NumberOfOptionals) -> + Pos = case Ext of + noext -> Tpos; + {ext,Epos,_Enum} -> Tpos - Epos + 1 + end, + emit(MaybeComma), + InnerType = + case Type#type.def of + #'ObjectClassFieldType'{type=InType} -> + InType; + Def -> + asn1ct_gen:get_inner(Def) + end, + + case InnerType of + #'Externaltypereference'{type=T} -> + emit({nl,"%% attribute number ",TextPos," with type ", + T,nl}); + IT when is_tuple(IT) -> + emit({nl,"%% attribute number ",TextPos," with type ", + element(2,IT),nl}); + _ -> + emit({nl,"%% attribute number ",TextPos," with type ", + InnerType,nl}) + end, + + IsMandatoryAndPredefinedTableC = + fun(noext,mandatory,{"got objfun through args","ObjFun"}) -> + true; + (_,_,{"got objfun through args","ObjFun"}) -> + false; + (_,_,_) -> + true + end, + case {InnerType,IsMandatoryAndPredefinedTableC(Ext,Prop,DecInfObj)} of +%% {typefield,_} when Ext == noext, Prop == mandatory -> + {{typefield,_},true} -> + %% DecInfObj /= {"got objfun through args","ObjFun"} | + %% (DecInfObj == {"got objfun through args","ObjFun"} & + %% Ext == noext & Prop == mandatory) + asn1ct_name:new(term), + asn1ct_name:new(tmpterm), + emit({"{",{curr,tmpterm},", ",{next,bytes},"} = "}); + %%{objectfield,_,_} when Ext == noext, Prop == mandatory -> + {{objectfield,_,_},true} -> + asn1ct_name:new(term), + asn1ct_name:new(tmpterm), + emit({"{",{curr,tmpterm},", ",{next,bytes},"} = "}); + _ -> + asn1ct_name:new(term), + emit({"{",{curr,term},",",{next,bytes},"} = "}) + end, + + case {Ext,Prop,is_optimized(Erule)} of + {noext,mandatory,_} -> ok; % generate nothing + {noext,_,_} -> %% OPTIONAL or DEFAULT + OptPos = get_optionality_pos(TextPos,OptTable), + Element = io_lib:format("Opt band (1 bsl ~w)",[NumberOfOptionals - OptPos]), + emit(["case ",Element," of",nl]), + emit([" _Opt",TextPos," when _Opt",TextPos," > 0 ->"]); + {_,_,false} -> %% extension element, not bitstring + emit(["case Extensions of",nl]), + emit([" _ when size(Extensions) >= ",Pos,",element(",Pos,",Extensions) == 1 ->",nl]); + _ -> + emit(["case Extensions of",nl]), + emit([" <<_:",Pos-1,",1:1,_/bitstring>> when bit_size(Extensions) >= ",Pos," ->",nl]) + end, + put(component_type,{true,C}), + {TermVar,BytesVar} = gen_dec_line(Erule,TopType,Cname,Type,Tpos,DecInfObj,Ext,Prop), + 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,"end"]); + _ -> + emit([";",nl,"_ ->",nl]), + gen_dec_component_no_val(TopType,Cname,Type,Prop,Tpos,Ext), + emit([nl,"end"]) + end, + asn1ct_name:new(bytes), + case Rest of + [] -> + {Tpos+1,AccTerm++TermVar,AccBytes++BytesVar}; + _ -> + emit({com,nl}), + gen_dec_components_call1(Erule,TopType,Rest,Tpos+1,OptTable, + "",DecInfObj,Ext, AccTerm++TermVar, + AccBytes++BytesVar,NumberOfOptionals) + end; + +gen_dec_components_call1(_,_TopType,[],Pos,_OptTable,_,_,_,AccTerm,AccBytes,_NumberOfOptionals) -> + {Pos,AccTerm,AccBytes}. + + +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(Erule,TopType,Cname,Type,Pos,DecInfObj,Ext,Prop) -> + 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, + + 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_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),"{",{asis,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. + if + Ext == noext andalso Prop == mandatory -> + ok; + true -> + asn1ct_name:new(tmpterm), + asn1ct_name:new(tmpbytes), + emit([nl," {",{curr,tmpterm},", ",{curr,tmpbytes},"} ="]) + end, + {Name,RestFieldNames} = + (Type#type.def)#'ObjectClassFieldType'.fieldname, + emit(["?RT_PER:decode_open_type(",{curr,bytes}, + ", []),",nl]), + if + Ext == noext andalso Prop == mandatory -> + emit([{curr,term}," =",nl," "]); + true -> + emit([" {"]) + end, + emit(["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"]), + if + Ext == noext andalso Prop == mandatory -> + ok; + true -> + emit([",",nl,{curr,tmpbytes},"}"]) + end, + []; + _ -> + emit(["?RT_PER:decode_open_type(",{curr,bytes}, + ", [])"]), + RefedFieldName = + (Type#type.def)#'ObjectClassFieldType'.fieldname, + + [{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(Erule,Btype, + BytesVar); + _ -> + Ctgenmod:gen_dec_prim(Erule,Type, + BytesVar) + end; + 'ASN1_OPEN_TYPE' -> + case Type#type.def of + #'ObjectClassFieldType'{type=OpenType} -> + Ctgenmod:gen_dec_prim(Erule,#type{def=OpenType}, + BytesVar); + _ -> + Ctgenmod:gen_dec_prim(Erule,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), + {ObjSetMod,ObjSetName} = + case OSet of + {M,O} -> {{asis,M},O}; + _ -> {"?MODULE",OSet} + end, + emit({",",nl,"ObjFun = ",ObjSetMod, + ":'getdec_",ObjSetName,"'(", + {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} -> + ObjSetRef = + case ObjSet of + {deep,OSName,_,_} -> + OSName; + _ -> ObjSet + end, + {[{ObjSetRef,Cname,asn1ct_gen:mk_var(asn1ct_name:curr(term))}], + SaveBytes}; + _ -> + {[],SaveBytes} + end. + +gen_enc_choice(Erule,TopType,CompList,Ext) -> + gen_enc_choice_tag(CompList, [], Ext), + emit({com,nl}), + emit({"case element(1,Val) of",nl}), + gen_enc_choice2(Erule,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_choice2(Erule,TopType, {L1,L2}, Ext) -> + gen_enc_choice2(Erule,TopType, L1 ++ L2, 0, Ext); +gen_enc_choice2(Erule,TopType, L, Ext) -> + gen_enc_choice2(Erule,TopType, L, 0, Ext). + +gen_enc_choice2(Erule,TopType,[H1,H2|T], Pos, Ext) +when is_record(H1,'ComponentType'), is_record(H2,'ComponentType') -> + Cname = H1#'ComponentType'.name, + Type = H1#'ComponentType'.typespec, + EncObj = + case asn1ct_gen:get_constraint(Type#type.constraint, + componentrelation) of + no -> + case Type#type.tablecinf of + [{objfun,_}|_] -> + {"got objfun through args","ObjFun"}; + _ ->false + end; + _ -> {no_attr,"ObjFun"} + end, + emit({{asis,Cname}," ->",nl}), + DoExt = case Ext of + {ext,ExtPos,_} when (Pos + 1) < ExtPos -> noext; + _ -> Ext + end, + gen_enc_line(Erule,TopType,Cname,Type,"element(2,Val)", + Pos+1,EncObj,DoExt), + emit({";",nl}), + gen_enc_choice2(Erule,TopType,[H2|T], Pos+1, Ext); +gen_enc_choice2(Erule,TopType,[H1|T], Pos, Ext) + when is_record(H1,'ComponentType') -> + Cname = H1#'ComponentType'.name, + Type = H1#'ComponentType'.typespec, + EncObj = + case asn1ct_gen:get_constraint(Type#type.constraint, + componentrelation) of + no -> + case Type#type.tablecinf of + [{objfun,_}|_] -> + {"got objfun through args","ObjFun"}; + _ ->false + end; + _ -> {no_attr,"ObjFun"} + end, + emit({{asis,H1#'ComponentType'.name}," ->",nl}), + DoExt = case Ext of + {ext,ExtPos,_} when (Pos + 1) < ExtPos -> noext; + _ -> Ext + end, + gen_enc_line(Erule,TopType,Cname,Type,"element(2,Val)", + Pos+1,EncObj,DoExt), + gen_enc_choice2(Erule,TopType,T, Pos+1, Ext); +gen_enc_choice2(_Erule,_,[], _, _) -> + true. + +gen_dec_choice(Erule,TopType,CompList,{ext,Pos,NumExt}) -> + emit({"{Ext,",{curr,bytes},"} = ?RT_PER:getbit(Bytes),",nl}), + asn1ct_name:new(bytes), + gen_dec_choice1(Erule,TopType,CompList,{ext,Pos,NumExt}); +gen_dec_choice(Erule,TopType,CompList,noext) -> + gen_dec_choice1(Erule,TopType,CompList,noext). + +gen_dec_choice1(Erule,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(Erule,TopType,CompList,noext), + emit({nl,"end,",nl}), + emit({nl,"{{Cname,Val},NewBytes}"}); +gen_dec_choice1(Erule,TopType,{RootList,ExtList},Ext) -> + NewList = RootList ++ ExtList, + gen_dec_choice1(Erule,TopType, NewList, Ext); +gen_dec_choice1(Erule,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(Erule,TopType,CompList,{ext,ExtPos,ExtNum}), + case Erule of + per -> + emit([";",nl,"_ -> {asn1_ExtAlt,",nl, + " fun() -> ",nl, + " {XTerm,XBytes} = ?RT_PER:decode_open_type(", + {curr,bytes},",[]),",nl, + " {binary_to_list(XTerm),XBytes}",nl, + " end()}"]); + _ -> + emit([";",nl,"_ -> {asn1_ExtAlt, ?RT_PER:decode_open_type(", + {curr,bytes},",[])}"]) + end, + emit({nl,"end,",nl}), + emit({nl,"{{Cname,Val},NewBytes}"}). + + +gen_dec_choice2(Erule,TopType,L,Ext) -> + gen_dec_choice2(Erule,TopType,L,0,Ext). + +gen_dec_choice2(Erule,TopType,[H1,H2|T],Pos,Ext) +when is_record(H1,'ComponentType'), is_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(Erule,H1,TopType,Cname,Type,Pos+1,false,Ext), + emit({";",nl}); + _ -> + emit({Pos," -> {",{asis,Cname},",",nl}), + wrap_gen_dec_line(Erule,H1,TopType,Cname,Type,Pos+1,false,Ext), + emit({"};",nl}) + end, + gen_dec_choice2(Erule,TopType,[H2|T],Pos+1,Ext); +gen_dec_choice2(Erule,TopType,[H1,_H2|T],Pos,Ext) when is_record(H1,'ComponentType') -> + gen_dec_choice2(Erule,TopType,[H1|T],Pos,Ext); % skip extensionmark +gen_dec_choice2(Erule,TopType,[H1|T],Pos,Ext) when is_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(Erule,H1,TopType,Cname,Type,Pos+1,false,Ext); + _ -> + emit({Pos," -> {",{asis,Cname},",",nl}), + wrap_gen_dec_line(Erule,H1,TopType,Cname,Type,Pos+1,false,Ext), + emit("}") + end, + gen_dec_choice2(Erule,TopType,[T],Pos+1); +gen_dec_choice2(Erule,TopType,[_|T],Pos,Ext) -> + gen_dec_choice2(Erule,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 tuple_notation_allowed() of + true -> + io_lib:format("?RT_PER:cindex(~w,~s,~w)",[I,Val,Cname]); + _ -> + io_lib:format("element(~w,~s)",[I,Val]) + end. + +tuple_notation_allowed() -> + Options = get(encoding_options), + not (lists:member(optimize,Options) orelse lists:member(uper_bin,Options)). + +wrap_gen_dec_line(Erule,C,TopType,Cname,Type,Pos,DIO,Ext) -> + put(component_type,{true,C}), + gen_dec_line(Erule,TopType,Cname,Type,Pos,DIO,Ext,mandatory), + erase(component_type). + +get_components_prop() -> + case get(component_type) of + undefined -> + mandatory; + {true,#'ComponentType'{prop=Prop}} -> Prop + end. + + +value_match(Index,Value) when is_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}). + +is_optimized(per_bin) -> + lists:member(optimize,get(encoding_options)); +is_optimized(_Erule) -> + false. diff --git a/lib/asn1/src/asn1ct_gen.erl b/lib/asn1/src/asn1ct_gen.erl new file mode 100644 index 0000000000..fefb92bb34 --- /dev/null +++ b/lib/asn1/src/asn1ct_gen.erl @@ -0,0 +1,2066 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1997-2009. All Rights Reserved. +%% +%% 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 online 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. +%% +%% %CopyrightEnd% +%% +%% +-module(asn1ct_gen). + +-include("asn1_records.hrl"). +%%-compile(export_all). +-export([pgen_exports/3, + pgen_hrl/4, + gen_head/3, + demit/1, + emit/1, + 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, + index2suffix/1, + get_record_name_prefix/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 = {Types,_Values,_Ptypes,_Classes,_Objects,_ObjectSets}, + Indent) -> + N2nConvEnums = [CName|| {n2n,CName} <- get(encoding_options)], + case N2nConvEnums -- Types of + [] -> + ok; + UnmatchedTypes -> + exit({"Non existing ENUMERATION types used in n2n option", + UnmatchedTypes}) + end, + put(outfile,OutFile), + HrlGenerated = pgen_hrl(Erules,Module,TypeOrVal,Indent), + asn1ct_name:start(), + ErlFile = lists:concat([OutFile,".erl"]), + Fid = fopen(ErlFile,[write]), + put(gen_file_out,Fid), + gen_head(Erules,Module,HrlGenerated), + pgen_exports(Erules,Module,TypeOrVal), + pgen_dispatcher(Erules,Module,TypeOrVal), + pgen_info(), + pgen_typeorval(wrap_ber(Erules),Module,N2nConvEnums,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,N2nConvEnums,{Types,Values,_Ptypes,_Classes,Objects,ObjectSets}) -> + Rtmod = list_to_atom(lists:concat(["asn1ct_gen_",erule(Erules), + rt2ct_suffix(Erules)])), + pgen_types(Rtmod,Erules,N2nConvEnums,Module,Types), + pgen_values(Erules,Module,Values), + pgen_objects(Rtmod,Erules,Module,Objects), + pgen_objectsets(Rtmod,Erules,Module,ObjectSets), + case catch lists:member(der,get(encoding_options)) of + true -> + pgen_check_defaultval(Erules,Module); + _ -> ok + end, + pgen_partial_decode(Rtmod,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(Rtmod,Erules,N2nConvEnums,Module,[H|T]) -> + asn1ct_name:clear(), + Typedef = asn1_db:dbget(Module,H), + Rtmod:gen_encode(Erules,Typedef), + asn1ct_name:clear(), + Rtmod:gen_decode(Erules,Typedef), + case lists:member(H,N2nConvEnums) of + true -> + pgen_n2nconversion(Erules,Typedef); + _ -> + true + end, + pgen_types(Rtmod,Erules,N2nConvEnums,Module,T). + +pgen_n2nconversion(_Erules,#typedef{name=TypeName,typespec=#type{def={'ENUMERATED',{NN1,NN2}}}}) -> + NN = NN1 ++ NN2, + pgen_name2numfunc(TypeName,NN), + pgen_num2namefunc(TypeName,NN); +pgen_n2nconversion(_Erules,_) -> + true. + +pgen_name2numfunc(_TypeName,[]) -> + true; +pgen_name2numfunc(TypeName,[{Atom,Number}]) -> + emit(["name2num_",TypeName,"(",{asis,Atom},") ->",Number,".",nl,nl]); +pgen_name2numfunc(TypeName,[{Atom,Number}|NNRest]) -> + emit(["name2num_",TypeName,"(",{asis,Atom},") ->",Number,";",nl]), + pgen_name2numfunc(TypeName,NNRest). + +pgen_num2namefunc(_TypeName,[]) -> + true; +pgen_num2namefunc(TypeName,[{Atom,Number}]) -> + emit(["num2name_",TypeName,"(",Number,") ->",{asis,Atom},".",nl,nl]); +pgen_num2namefunc(TypeName,[{Atom,Number}|NNRest]) -> + emit(["num2name_",TypeName,"(",Number,") ->",{asis,Atom},";",nl]), + pgen_num2namefunc(TypeName,NNRest). + +pgen_objects(_,_,_,[]) -> + true; +pgen_objects(Rtmod,Erules,Module,[H|T]) -> + asn1ct_name:clear(), + Typedef = asn1_db:dbget(Module,H), + Rtmod:gen_obj_code(Erules,Module,Typedef), + pgen_objects(Rtmod,Erules,Module,T). + +pgen_objectsets(_,_,_,[]) -> + true; +pgen_objectsets(Rtmod,Erules,Module,[H|T]) -> + asn1ct_name:clear(), + TypeDef = asn1_db:dbget(Module,H), + Rtmod:gen_objectset_code(Erules,TypeDef), + pgen_objectsets(Rtmod,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(Rtmod,Erule,Module) when Erule == ber_bin_v2 -> + pgen_partial_inc_dec(Rtmod,Erule,Module), + pgen_partial_dec(Rtmod,Erule,Module); +pgen_partial_decode(_,_,_) -> + ok. + +pgen_partial_inc_dec(Rtmod,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(Rtmod,Erules,Module,PatternLists), + gen_partial_inc_dec_refed_funcs(Rtmod,Erules) + end. + +%% pgen_partial_inc_dec1 generates a function of the toptype in each +%% of the partial incomplete decoded types. +pgen_partial_inc_dec1(Rtmod,Erules,Module,[P|Ps]) -> + 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-"), + case asn1ct:maybe_saved_sindex(TopTypeName,P) of + I when is_integer(I),I > 0 -> +% io:format("Index:~p~n",[I]), + asn1ct:set_current_sindex(I); + _I -> + asn1ct:set_current_sindex(0), +% io:format("Index=~p~n",[_I]), + ok + end, + Rtmod:gen_decode(Erules,TypeDef), + gen_dec_part_inner_constr(Rtmod,Erules,TypeDef,[TopTypeName]), + pgen_partial_inc_dec1(Rtmod,Erules,Module,Ps); +pgen_partial_inc_dec1(_,_,_,[]) -> + ok. + +gen_partial_inc_dec_refed_funcs(Rtmod,Erule) when Erule == ber_bin_v2 -> + case asn1ct:next_refed_func() of + [] -> + ok; + {#'Externaltypereference'{module=M,type=Name},Sindex,Pattern} -> + TypeDef = asn1_db:dbget(M,Name), + asn1ct:update_gen_state(namelist,Pattern), + asn1ct:set_current_sindex(Sindex), + Rtmod:gen_inc_decode(Erule,TypeDef), + gen_dec_part_inner_constr(Rtmod,Erule,TypeDef,[Name]), + gen_partial_inc_dec_refed_funcs(Rtmod,Erule); + {Name,Sindex,Pattern,Type} -> + TypeDef=#typedef{name=asn1ct_gen:list2name(Name),typespec=Type}, + asn1ct:update_gen_state(namelist,Pattern), + asn1ct:set_current_sindex(Sindex), + Rtmod:gen_inc_decode(Erule,TypeDef), + gen_dec_part_inner_constr(Rtmod,Erule,TypeDef,Name), + gen_partial_inc_dec_refed_funcs(Rtmod,Erule) + end; +gen_partial_inc_dec_refed_funcs(_,_) -> + ok. + +pgen_partial_dec(_Rtmod,Erules,_Module) -> + Type_pattern = asn1ct:get_gen_state_field(type_pattern), +% io:format("Type_pattern: ~w~n",[Type_pattern]), + %% Get the typedef of the top type and follow into the choosen components until the last type/component. + pgen_partial_types(Erules,Type_pattern), + ok. + +pgen_partial_types(Erules,Type_pattern) -> + % until this functionality works on all back-ends + Options = get(encoding_options), + case lists:member(asn1config,Options) of + true -> + pgen_partial_types1(Erules,Type_pattern); + _ -> ok + end. + + +pgen_partial_types1(Erules,[{FuncName,[TopType|RestTypes]}|Rest]) -> +% emit([FuncName,"(Bytes) ->",nl]), + CurrMod = get(currmod), + TypeDef = asn1_db:dbget(CurrMod,TopType), + traverse_type_structure(Erules,TypeDef,RestTypes,FuncName, + TypeDef#typedef.name), + pgen_partial_types1(Erules,Rest); +pgen_partial_types1(_,[]) -> + ok; +pgen_partial_types1(_,undefined) -> + ok. + +%% traverse_type_structure searches the structure of TypeDef for next +%% type/component in TypeList until the last one. For the last type in +%% TypeList a decode function will be generated. +traverse_type_structure(Erules,Type,[],FuncName,TopTypeName) -> + %% this is the selected type + Ctmod = list_to_atom(lists:concat(["asn1ct_gen_",erule(Erules), + rt2ct_suffix(Erules)])), + TypeDef = + case Type of + #type{} -> + #typedef{name=TopTypeName,typespec=Type}; + #typedef{} -> Type + end, + Ctmod:gen_decode_selected(Erules,TypeDef,FuncName); % what if Type is #type{} +traverse_type_structure(Erules,#type{def=Def},[[N]],FuncName,TopTypeName) + when is_integer(N) -> % this case a decode of one of the elements in + % the SEQUENCE OF is required. + InnerType = asn1ct_gen:get_inner(Def), + case InnerType of + 'SEQUENCE OF' -> + {_,Type} = Def, + traverse_type_structure(Erules,Type,[],FuncName,TopTypeName); + WrongType -> + exit({error,{configuration_file_error,[N],"only for SEQUENCE OF components",WrongType}}) + end; +traverse_type_structure(Erules,Type,[[N]|Ts],FuncName,TopTypeName) + when is_integer(N) -> + traverse_type_structure(Erules,Type,Ts,FuncName,TopTypeName); +traverse_type_structure(Erules,#type{def=Def},[T|Ts],FuncName,TopTypeName) -> + InnerType = asn1ct_gen:get_inner(Def), + case InnerType of + 'SET' -> + #'SET'{components=Components} = Def, + C = get_component(T,Components), + traverse_type_structure(Erules,C#'ComponentType'.typespec,Ts, + FuncName,[T|TopTypeName]); + 'SEQUENCE' -> + #'SEQUENCE'{components=Components} = Def, + C = get_component(T,Components), + traverse_type_structure(Erules,C#'ComponentType'.typespec,Ts, + FuncName,[T|TopTypeName]); + 'CHOICE' -> + {_,Components} = Def, + C = get_component(T,Components), + traverse_type_structure(Erules,C#'ComponentType'.typespec,Ts, + FuncName,[T|TopTypeName]); + 'SEQUENCE OF' -> + {_,Type} = Def, + traverse_SO_type_structure(Erules,Type,[T|Ts],FuncName, + TopTypeName); + 'SET OF' -> + {_,Type} = Def, + traverse_SO_type_structure(Erules,Type,[T|Ts],FuncName, + TopTypeName); + #'Externaltypereference'{module=M,type=TName} -> + TypeDef = asn1_db:dbget(M,TName), + traverse_type_structure(Erules,TypeDef,[T|Ts],FuncName, + [TypeDef#typedef.name]); + _ -> + traverse_type_structure(Erules,Def,Ts,FuncName,[T|TopTypeName]) + end; +traverse_type_structure(Erules,#typedef{typespec=Def},[T|Ts],FuncName, + TopTypeName) -> + InnerType = asn1ct_gen:get_inner(Def#type.def), + case InnerType of + 'SET' -> + #'SET'{components=Components} = Def#type.def, + C = get_component(T,Components), + traverse_type_structure(Erules,C#'ComponentType'.typespec,Ts, + FuncName,[T|TopTypeName]); + 'SEQUENCE' -> + #'SEQUENCE'{components=Components} = Def#type.def, + C = get_component(T,Components), + traverse_type_structure(Erules,C#'ComponentType'.typespec,Ts, + FuncName,[T|TopTypeName]); + 'CHOICE' -> + {_,Components} = Def#type.def, + C = get_component(T,Components), + traverse_type_structure(Erules,C#'ComponentType'.typespec,Ts, + FuncName,[T|TopTypeName]); + 'SEQUENCE OF' -> + {_,Type} = Def#type.def, + traverse_SO_type_structure(Erules,Type,[T|Ts],FuncName, + TopTypeName); + 'SET OF' -> + {_,Type} = Def#type.def, + traverse_SO_type_structure(Erules,Type,[T|Ts],FuncName, + TopTypeName); + #'Externaltypereference'{module=M,type=TName} -> + TypeDef = asn1_db:dbget(M,TName), + traverse_type_structure(Erules,TypeDef,[T|Ts],FuncName, + [TypeDef#typedef.name]); + _ -> %this may be a referenced type that shall be traversed or + %the selected type + traverse_type_structure(Erules,Def,Ts,FuncName,[T|TopTypeName]) + end. + +traverse_SO_type_structure(Erules,Type,[N|Rest],FuncName,TopTypeName) + when is_integer(N) -> + traverse_type_structure(Erules,Type,Rest,FuncName,TopTypeName); +traverse_SO_type_structure(Erules,Type,TypeList,FuncName,TopTypeName) -> + traverse_type_structure(Erules,Type,TypeList,FuncName,TopTypeName). + +get_component(Name,{C1,C2}) when is_list(C1),is_list(C2) -> + get_component(Name,C1++C2); +get_component(Name,[C=#'ComponentType'{name=Name}|_Cs]) -> + C; +get_component(Name,[_C|Cs]) -> + get_component(Name,Cs); +get_component(Name,_) -> + throw({error,{asn1,{internal_error,Name}}}). + +%% generate code for all inner types that are called from the top type +%% of the partial incomplete decode and are defined within the top +%% type.Constructed subtypes deeper in the structure will be generated +%% in turn after all top types have been generated. +gen_dec_part_inner_constr(Rtmod,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(Rtmod,Erules,Components,TypeName); + %% Continue generate the inner of each component + 'SEQUENCE' -> + #'SEQUENCE'{components=Components} = Def#type.def, + gen_dec_part_inner_types(Rtmod,Erules,Components,TypeName); + 'CHOICE' -> + {_,Components} = Def#type.def, + gen_dec_part_inner_types(Rtmod,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), + 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), + asn1ct_name:clear(), + Rtmod:gen_decode(Erules,[NameSuffix|TypeName],Type); + _ -> + ok + end. + +gen_dec_part_inner_types(Rtmod,Erules,[ComponentType|Rest],TypeName) -> + asn1ct_name:clear(), + Rtmod:gen_decode(Erules,TypeName,ComponentType), + gen_dec_part_inner_types(Rtmod,Erules,Rest,TypeName); +gen_dec_part_inner_types(Rtmod,Erules,{Comps1,Comps2},TypeName) + when is_list(Comps1),is_list(Comps2) -> + gen_dec_part_inner_types(Rtmod,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,TopType,Pattern}) -> + TypePattern = asn1ct:get_gen_state_field(inc_type_pattern), + TPattern = + case lists:keysearch(FuncName,1,TypePattern) of + {value,{_,TP}} -> TP; + _ -> exit({error,{asn1_internal_error,exclusive_decode}}) + end, + TopTypeName = + case asn1ct:maybe_saved_sindex(TopType,TPattern) of + I when is_integer(I),I>0 -> + lists:concat([TopType,"_",I]); + _ -> + atom_to_list(TopType) + end, + emit([{asis,FuncName},"(Bytes) ->",nl, + " decode_partial_incomplete('",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 is_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,{RootL1,ExtList,RootL2}) + when is_list(RootL1), is_list(RootL2) -> + gen_types(Erules,Tname,RootL1), + gen_types(Erules,Tname,ExtList), + gen_types(Erules,Tname,RootL2); +gen_types(Erules,Tname,{RootList,ExtList}) when is_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 is_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}) -> + EncName = ensure_atom(Name), + emit({{asis,EncName},"(_V,asn1_DEFAULT) ->",nl," true;",nl}), + emit({{asis,EncName},"(V,V) ->",nl," true;",nl}), + emit({{asis,EncName},"(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({{asis,EncName},"(DefaultValue,Value) ->",nl}), + emit({" '",list2name([T,check]),"'(DefaultValue,Value).",nl}); + MaybePrim -> + InnerType = get_inner(MaybePrim), + case type(InnerType) of + {primitive,bif} -> + emit({{asis,EncName},"(DefaultValue,Value) ->",nl," "}), + gen_prim_check_call(get_inner(InnerType),"DefaultValue","Value", + FType), + emit({".",nl,nl}); + _ -> + throw({asn1_error,{unknown,type,MaybePrim}}) + end + end. + +gen_check_sof(Name,SOF,Type) -> + EncName = ensure_atom(Name), + NewName = ensure_atom(list2name([sorted,Name])), + emit({{asis,EncName},"(V1,V2) ->",nl}), + emit({" ",{asis,NewName},"(lists:sort(V1),lists:sort(V2)).",nl,nl}), + emit({{asis,NewName},"([],[]) ->",nl," true;",nl}), + emit({{asis,NewName},"([DV|DVs],[V|Vs]) ->",nl," "}), + InnerType = get_inner(Type#type.def), + case type(InnerType) of + {primitive,bif} -> + gen_prim_check_call(get_inner(InnerType),"DV","V",Type), + emit({",",nl}); + {constructed,bif} -> + emit([{asis,ensure_atom(list2name([SOF,Name]))},"(DV, V),",nl]); + #'Externaltypereference'{type=T} -> + emit([{asis,ensure_atom(list2name([T,check]))},"(DV,V),",nl]); + 'ASN1_OPEN_TYPE' -> + emit(["DV = V,",nl]); + _ -> + emit(["DV = V,",nl]) + end, + emit({" ",{asis,NewName},"(DVs,Vs).",nl,nl}). + +gen_check_sequence(Name,Components) -> + emit([{asis,ensure_atom(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 = ["element(",Num+1,",DefaultValue)"], + 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([{asis,ensure_atom(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), + 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(get_inner(InnerType),DefVal,Val,Type); + #'Externaltypereference'{type=T} -> + emit({" ",{asis,ensure_atom(list2name([T,check]))},"(",DefVal,",",Val,")"}); + 'ASN1_OPEN_TYPE' -> + emit([" if",nl, + " ",DefVal," == ",Val," -> true;",nl, + " true -> throw({error,{asn1_open_type}})",nl, + " end",nl]); + {constructed,bif} -> + emit([" ",{asis,ensure_atom(list2name([N,Name]))},"(",DefVal,",",Val,")"]); + _ -> + emit([" if",nl, + " ",DefVal," == ",Val," -> true;",nl, + " true -> throw({error,{asn1_open_type}})",nl, + " end",nl]) + end. + + +%% VARIOUS GENERATOR STUFF +%% ************************************************* +%%************************************************** + +mk_var(X) when is_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 is_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 is_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 is_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 is_record(D,typedef) -> + gen_encode_constructed(Erules,Typename,InnerType,D#typedef.typespec). + +gen_decode_constructed(Erules,Typename,InnerType,D) when is_record(D,type) -> + Rtmod = list_to_atom(lists:concat(["asn1ct_constructed_",erule(Erules)])), + asn1ct:step_in_constructed(), %% updates namelist for exclusive 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 is_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 [X || {n2n,X} <- get(encoding_options)] of + [] -> ok; + A2nNames -> + emit({"-export([",nl}), + gen_exports1(A2nNames,"name2num_",1), + emit({"-export([",nl}), + gen_exports1(A2nNames,"num2name_",1) + 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(), + gen_selected_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]).",nl]) + 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). + +gen_selected_decode_exports() -> + case asn1ct:get_gen_state_field(type_pattern) of + undefined -> + ok; + L -> + gen_selected_decode_exports(L) + end. + +gen_selected_decode_exports([]) -> + ok; +gen_selected_decode_exports([{FuncName,_}|Rest]) -> + emit(["-export([",FuncName,"/1"]), + gen_selected_decode_exports1(Rest). +gen_selected_decode_exports1([]) -> + emit(["]).",nl,nl]); +gen_selected_decode_exports1([{FuncName,_}|Rest]) -> + emit([",",nl," ",FuncName,"/1"]), + gen_selected_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]), + NoFinalPadding = lists:member(no_final_padding,get(encoding_options)), + 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)"; + uper_bin when NoFinalPadding == true -> + "?RT_PER:complete_NFP(encode_disp(Type,Data))"; + uper_bin -> "?RT_PER:complete(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]), + case Erules of + per -> + emit([" Bytes when is_binary(Bytes) ->",nl, + " {ok,binary_to_list(Bytes)};",nl, + " Bytes ->",nl, + " {ok,binary_to_list(list_to_binary(Bytes))}",nl, + " end.",nl,nl]); + _ -> + emit([" Bytes ->",nl, + " {ok,",EncWrap,"}",nl, + "end.",nl,nl]) + end, + +% 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, + + Return_rest = lists:member(undec_rest,get(encoding_options)), + Data = case {Erules,Return_rest} of + {ber_bin_v2,true} -> "Data0"; + _ -> "Data" + end, + + emit(["decode(Type,",Data,") ->",nl]), + DecAnonymous = + case {Erules,Return_rest} of + {ber_bin_v2,false} -> + io_lib:format("~s~s~s~n", + ["element(1,?RT_BER:decode(Data", + driver_parameter(),"))"]); + {ber_bin_v2,true} -> + emit(["{Data,Rest} = ?RT_BER:decode(Data0", + driver_parameter(),"),",nl]), + "Data"; + _ -> + "Data" + end, + DecWrap = case Erules of + ber -> "wrap_decode(Data)"; + ber_bin_v2 -> + DecAnonymous; + per -> "list_to_binary(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,Return_rest} of + {ber_bin_v2,false} -> + emit([" Result ->",nl, + " {ok,Result}",nl]); + {ber_bin_v2,true} -> + emit([" Result ->",nl, + " {ok,Result,Rest}",nl]); + {per,false} -> + emit([" {X,_Rest} ->",nl, + " {ok,if_binary2list(X)};",nl, + " {X,_Rest,_Len} ->",nl, + " {ok,if_binary2list(X)}",nl]); + {_,false} -> + emit([" {X,_Rest} ->",nl, + " {ok,X};",nl, + " {X,_Rest,_Len} ->",nl, + " {ok,X}",nl]); + {per,true} -> + emit([" {X,{_,Rest}} ->",nl, + " {ok,if_binary2list(X),Rest};",nl, + " {X,{_,Rest},_Len} ->",nl, + " {ok,if_binary2list(X),Rest};",nl, + " {X,Rest} ->",nl, + " {ok,if_binary2list(X),Rest};",nl, + " {X,Rest,_Len} ->",nl, + " {ok,if_binary2list(X),Rest}",nl]); + {per_bin,true} -> + emit([" {X,{_,Rest}} ->",nl, + " {ok,X,Rest};",nl, + " {X,{_,Rest},_Len} ->",nl, + " {ok,X,Rest};",nl, + " {X,Rest} ->",nl, + " {ok,X,Rest};",nl, + " {X,Rest,_Len} ->",nl, + " {ok,X,Rest}",nl]); + {uper_bin,true} -> + emit([" {X,{_,Rest}} ->",nl, + " {ok,X,Rest};",nl, + " {X,{_,Rest},_Len} ->",nl, + " {ok,X,Rest};",nl, + " {X,Rest} ->",nl, + " {ok,X,Rest};",nl, + " {X,Rest,_Len} ->",nl, + " {ok,X,Rest}",nl]); + _ -> + emit([" {X,Rest} ->",nl, + " {ok,X,Rest};",nl, + " {X,Rest,_Len} ->",nl, + " {ok,X,Rest}",nl]) + end, + emit(["end.",nl,nl]), + + case Erules of + per -> + emit(["if_binary2list(B) when is_binary(B) ->",nl, + " binary_to_list(B);",nl, + "if_binary2list(L) -> L.",nl,nl]); + _ -> + ok + end, + + gen_decode_partial_incomplete(Erules), + + 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]), + + 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]), + Driver = + case lists:member(driver,get(encoding_options)) of + true -> + ",driver"; + _ -> "" + end, + emit([" case catch decode_inc_disp(Type,element(1,?RT_BER:decode(Data0",Driver,"))) of",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; + {Data1,Data2} -> +% io:format("partial_incomplete_decode: ~p~ninc_type_pattern: ~p~n",[Data,Data2]), + gen_partial_inc_dispatcher(Data1,Data2) + end. +gen_partial_inc_dispatcher([{FuncName,TopType,_Pattern}|Rest],TypePattern) -> + TPattern = + case lists:keysearch(FuncName,1,TypePattern) of + {value,{_,TP}} -> TP; + _ -> exit({error,{asn1_internal_error,exclusive_decode}}) + end, + FuncName2=asn1ct:maybe_rename_function(inc_disp,TopType,TPattern), + TopTypeName = + case asn1ct:maybe_saved_sindex(TopType,TPattern) of + I when is_integer(I),I>0 -> + lists:concat([TopType,"_",I]); + _ -> + atom_to_list(TopType) + end, + emit(["decode_partial_inc_disp('",TopTypeName,"',Data) ->",nl, + " ",{asis,list_to_atom(lists:concat(["dec-inc-",FuncName2]))}, + "(Data);",nl]), + gen_partial_inc_dispatcher(Rest,TypePattern); +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 is_list(Bytes) ->",nl, + " binary_to_list(list_to_binary(Bytes));",nl, + "wrap_encode(Bytes) when is_binary(Bytes) ->",nl, + " binary_to_list(Bytes);",nl, + "wrap_encode(Bytes) -> Bytes.",nl,nl]), + emit(["wrap_decode(Bytes) when is_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() -> + emit(["info() ->",nl, + " case ?MODULE:module_info() of",nl, + " MI when is_list(MI) ->",nl, + " case lists:keysearch(attributes,1,MI) of",nl, + " {value,{_,Attributes}} when is_list(Attributes) ->",nl, + " case lists:keysearch(asn1_info,1,Attributes) of",nl, + " {value,{_,Info}} when is_list(Info) ->",nl, + " Info;",nl, + " _ ->",nl, + " []",nl, + " end;",nl, + " _ ->",nl, + " []",nl, + " end",nl, + " end.",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 is_atom(Variable) -> + emit({var,asn1ct_name:prev(Variable)}); + +emit({next,Variable}) when is_atom(Variable) -> + emit({var,asn1ct_name:next(Variable)}); + +emit({curr,Variable}) when is_atom(Variable) -> + emit({var,asn1ct_name:curr(Variable)}); + +emit({var,Variable}) when is_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 is_integer(What) -> + put_chars(get(gen_file_out),integer_to_list(What)); + +emit(What) when is_list(What), is_integer(hd(What)) -> + put_chars(get(gen_file_out),What); + +emit(What) when is_atom(What) -> + put_chars(get(gen_file_out),atom_to_list(What)); + +emit(What) when is_tuple(What) -> + emit_parts(tuple_to_list(What)); + +emit(What) when is_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 is_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 is_record(Tdef,typedef) -> + Name = [Tdef#typedef.name], + Type = Tdef#typedef.typespec, + gen_record(type,Name,Type,NumRecords); + +gen_record(Tdef,NumRecords) when is_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 is_list(Clist1), is_list(Clist2) -> + gen_record(TorPtype,Name,Clist1++Clist2,Num); +gen_record(TorPtype,Name,{Clist1,EClist,Clist2},Num) + when is_list(Clist1), is_list(EClist), is_list(Clist2) -> + gen_record(TorPtype,Name,Clist1++EClist++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 is_record(Type,type) -> + Def = Type#type.def, + Rec = case Def of + Seq when is_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 is_record(Set,'SET') -> + case Set#'SET'.pname of + false -> + {record,to_textual_order(Set#'SET'.components)}; + _Pname when TorPtype == type -> + false; + _ -> + {record,to_textual_order(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, + Prefix = get_record_name_prefix(), + emit({"-record('",Prefix,list2name(Name),"',{",nl}), + RootList = case CompList of + _ when is_list(CompList) -> + CompList; + {Rl,_} -> Rl; + {Rl1,_Ext,_Rl2} -> Rl1 + 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; + {Rootl1,Extl,Rootl2} -> + case Rootl1 of + [] -> true; + _ -> emit([",",nl]) + end, + emit(["%% with extensions",nl]), + gen_record2(Name,'SEQUENCE',Extl,"",ext), + case Extl of + [_H|_] when Rootl2 /= [] -> emit([",",nl]); + _ -> ok + end, + emit(["%% end of extensions",nl]), + gen_record2(Name,'SEQUENCE',Rootl2,"",noext), + emit(["}).",nl,nl]), + Rootl1++Extl++Rootl2; + _ -> + 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) -> + Options = get(encoding_options), + {Rtmac,Rtmod} = case Erules of + per -> + emit({"%% Generated by the Erlang ASN.1 PER-" + "compiler version:",asn1ct:vsn(),nl}), + {"RT_PER",?RT_PER_BIN}; + 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 + 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"}; + uper_bin -> + emit(["%% Generated by the Erlang ASN.1 UNALIGNED" + " PER-compiler version, utilizing" + " bit-syntax:", + asn1ct:vsn(),nl]), + {"RT_PER","asn1rt_uper_bin"} + 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]), + emit(["-asn1_info([{vsn,'",asn1ct:vsn(),"'},",nl, + " {module,'",Mod,"'},",nl, + " {options,",io_lib:format("~w",[Options]),"}]).",nl,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), + gen_record2(Name,SeqOrSet,T,", ", Extension). + +gen_record_default(#'ComponentType'{prop='OPTIONAL'}, _)-> + emit(" = asn1_NOVALUE"); +gen_record_default(#'ComponentType'{prop={'DEFAULT',_}}, _)-> + emit(" = asn1_DEFAULT"); +gen_record_default(_, _) -> + true. + +%% May only be a list or a two-tuple. +to_textual_order({Root,Ext}) -> + {to_textual_order(Root),Ext}; +to_textual_order(Cs={_R1,_Ext,_R2}) -> + Cs; +to_textual_order(Cs=[#'ComponentType'{textual_order=undefined}|_]) -> + Cs; +to_textual_order(Cs) when is_list(Cs) -> + lists:keysort(#'ComponentType'.textual_order,Cs). + + +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); + _ -> + 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); + _ -> + %% Generate Dummy function call i.e. anything is accepted + emit(["fun() -> true end ()"]) + 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,")"}); + 'RELATIVE-OID' -> + 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, + insert_once(check_functions,{list2name([T,check]),RefType}), + InType = asn1ct_gen:get_inner(RefType#type.def), + case type(InType) of + {constructed,bif} -> + lookahead_innertype([T],InType,RefType); + Ref = #'Externaltypereference'{} -> + lookahead_reference(Ref); + _ -> + 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); + Ref = #'Externaltypereference'{} -> + lookahead_reference(Ref); + _ -> + ok + end. + +lookahead_reference(#'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. + +insert_once(Table,Object) -> + _Info = ets:info(Table), + 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; + 'T61String' -> + restrictedstring; + 'VideotexString' -> + restrictedstring; + 'IA5String' -> + restrictedstring; + 'UTCTime' -> + restrictedstring; + 'GeneralizedTime' -> + restrictedstring; + 'GraphicString' -> + restrictedstring; + 'VisibleString' -> + restrictedstring; + 'GeneralString' -> + restrictedstring; + 'UniversalString' -> + restrictedstring; + 'BMPString' -> + restrictedstring; + 'UTF8String' -> + restrictedstring; + Other -> Other + end. + + + + + +get_inner(A) when is_atom(A) -> A; +get_inner(Ext) when is_record(Ext,'Externaltypereference') -> Ext; +get_inner(Tref) when is_record(Tref,typereference) -> Tref; +get_inner({fixedtypevaluefield,_,Type}) -> + if + is_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 is_tuple(T) -> + case element(1,T) of + Tuple when is_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 is_record(X,'Externaltypereference') -> + X; +type(X) when is_record(X,typereference) -> + X; +type('ASN1_OPEN_TYPE') -> + 'ASN1_OPEN_TYPE'; +type({fixedtypevaluefield,_Name,Type}) when is_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', + 'REAL', + 'OBJECT IDENTIFIER', + 'RELATIVE-OID', + 'ANY', + 'NULL', + 'BIT STRING' , + 'OCTET STRING' , + 'ObjectDescriptor', + 'NumericString', + 'TeletexString', + 'T61String', + 'VideotexString', + 'UTCTime', + 'GeneralizedTime', + 'GraphicString', + 'VisibleString', + 'GeneralString', + 'PrintableString', + 'IA5String', + 'UniversalString', + 'UTF8String', + '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 is_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 is_record(Type,type) -> + case Type#type.def of + {{objectclass,_,_},TypeFrObj} when is_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; +erule(uper_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(_) -> "". + +index2suffix(0) -> + ""; +index2suffix(N) -> + lists:concat(["_",N]). + +get_constraint(C,Key) -> + case lists:keysearch(Key,1,C) of + false -> + no; + {value,{_,V}} -> + V; + {value,Cnstr} -> + Cnstr + end. + +ensure_atom(Atom) when is_atom(Atom) -> + Atom; +ensure_atom(List) when is_list(List) -> + list_to_atom(List). + +get_record_name_prefix() -> + case lists:keysearch(record_name_prefix,1,get(encoding_options)) of + false -> + ""; + {value,{_,Prefix}} -> + Prefix + end. diff --git a/lib/asn1/src/asn1ct_gen_ber.erl b/lib/asn1/src/asn1ct_gen_ber.erl new file mode 100644 index 0000000000..7c432f29c3 --- /dev/null +++ b/lib/asn1/src/asn1ct_gen_ber.erl @@ -0,0 +1,1736 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1997-2009. All Rights Reserved. +%% +%% 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 online 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. +%% +%% %CopyrightEnd% +%% +%% +-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 is_record(Type,typedef) -> + gen_encode_user(Erules,Type). + +%%=============================================================================== +%% encode #{type, {tag, def, constraint}} +%%=============================================================================== + +gen_encode(Erules,Typename,Type) when is_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 is_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'{name=Cname,typespec=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 is_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 is_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 is_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 {_,",{curr,enumval},"}->", + {curr,enumval},";_->", Value," end) of",nl]), + asn1ct_name:new(enumval), + emit_enc_enumerated_cases(NamedNumberList,DoTag); + {'ENUMERATED',NamedNumberList} -> + + emit(["case (case ",Value," of {_,",{curr,enumval},"}->", + {curr,enumval},";_->", Value," end) of",nl]), + asn1ct_name:new(enumval), + emit_enc_enumerated_cases(NamedNumberList,DoTag); + + 'REAL' -> + emit_encode_func('real',Constraint,Value,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); + 'RELATIVE-OID' -> + emit_encode_func("relative_oid",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); + TString when TString == 'TeletexString'; + TString == 'T61String' -> + 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); + 'UTF8String' -> + emit_encode_func('UTF8_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); + #'ObjectClassFieldType'{} -> + case asn1ct_gen:get_inner(D#type.def) of + {fixedtypevaluefield,_,InnerType} -> + gen_encode_prim(Erules,InnerType,DoTag,Value); + 'ASN1_OPEN_TYPE' -> + emit_encode_func('open_type', Value,DoTag); + XX -> + exit({'can not encode' ,XX}) + end; + XX -> + exit({'can not encode' ,XX}) + end. + + +emit_encode_func(Name,Value,Tags) when is_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 is_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 is_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) + emit([";",nl]) + 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 is_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 is_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'{name=Cname,typespec=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 is_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; + 'REAL' -> + emit({"?RT_BER:decode_real(",BytesVar,",", + {asis,Constraint},","}), + 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; + 'RELATIVE-OID' -> + emit({"?RT_BER:decode_relative_oid(",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; + TString when TString == 'TeletexString'; + TString == 'T61String' -> + 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; + 'UTF8String' -> + emit({"?RT_BER:decode_UTF8_string",AsBin,"(", + BytesVar,","}), + false; + '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; + #'ObjectClassFieldType'{} -> + case asn1ct_gen:get_inner(Att#type.def) of + {fixedtypevaluefield,_,InnerType} -> + gen_dec_prim(Erules,InnerType,BytesVar,DoTag,TagIn,Length,Form,OptOrMand), + false; + 'ASN1_OPEN_TYPE' -> + emit(["?RT_BER:decode_open_type(", + re_wrap_erule(Erules),",", + BytesVar,","]), + false; + XX -> + exit({'can not decode' ,XX}) + end; + Other -> + exit({'can not decode' ,Other}) + end, + + NewLength = case DoLength of + true -> [", ", Length]; + false -> "" + end, + NewOptOrMand = case OptOrMand of + _ when is_list(OptOrMand) -> OptOrMand; + mandatory -> {asis,mandatory}; + _ -> {asis,opt_or_default} + end, + case {TagIn,NewTypeName} of + {_,#'ObjectClassFieldType'{}} -> + case asn1ct_gen:get_inner(Att#type.def) of + 'ASN1_OPEN_TYPE' -> + emit([{asis,DoTag},")"]); + _ -> ok + end; + {[],'ASN1_OPEN_TYPE'} -> + emit([{asis,DoTag},")"]); + {_,'ASN1_OPEN_TYPE'} -> + emit([TagIn,"++",{asis,DoTag},")"]); + {[],_} -> + emit([{asis,DoTag},NewLength,", ",NewOptOrMand,")"]); + _ when is_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 is_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 is_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'} -> %% OPTIONAL field in class + EmitFuncClause("Val, _"), %% Value must be anything + %% already encoded + emit([" {Val,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) -> + CurrentMod = get(currmod), + 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', ",{asis,Name}, + "}})"]); + {false,{'DEFAULT',_DefaultObject}} -> + exit({error,{asn1,{"not implemented yet",Name}}}); + {{Name,#'Externalvaluereference'{module=CurrentMod, + value=TypeName}},_} -> + EmitFuncClause(" Val, TagIn, [H|T]"), + emit({indent(3),"'enc_",TypeName,"'(H, Val, TagIn, T)"}); + {{Name,#'Externalvaluereference'{module=M,value=TypeName}},_} -> + EmitFuncClause(" Val, TagIn, [H|T]"), + emit({indent(3),"'",M,"':'enc_",TypeName,"'(H, Val, TagIn, T)"}); + {{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 is_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, + #'Externaltypereference'{module=M,type=T}) -> + CurrentMod = get(currmod), + TDef = asn1_db:dbget(M,T), + Def = TDef#typedef.typespec, + OTag = Def#type.tag, + Tag = [X#tag{class=decode_class(X#tag.class)}|| X <- OTag], + if + M == CurrentMod -> + emit({" 'enc_",T,"'(Val, TagIn ++ ",{asis,Tag},")"}), + []; + true -> + emit({" '",M,"':'enc_",T,"'(Val, TagIn ++ ",{asis,Tag},")"}), + [] + end; +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("Bytes, _,"), +% emit([" asn1_NOVALUE"]), + emit([" {Bytes,[],0}"]), + []; + {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) -> + CurrentMod = get(currmod), + 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', ",{asis,Name}, + "}})"]); + {false,{'DEFAULT',_DefaultObject}} -> + exit({error,{asn1,{"not implemented yet",Name}}}); + {{Name,#'Externalvaluereference'{module=CurrentMod, + value=TypeName}},_} -> + EmitFuncClause("Bytes,TagIn,[H|T]"), + emit({indent(3),"'dec_",TypeName,"'(H, Bytes, TagIn, T)"}); + {{Name,#'Externalvaluereference'{module=M,value=TypeName}},_} -> + EmitFuncClause("Bytes,TagIn,[H|T]"), + emit({indent(3),"'",M,"':'dec_",TypeName, + "'(H, Bytes, TagIn, T)"}); + {{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_constr_type(Erules,[TypeDef|Rest]) when is_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, + #'Externaltypereference'{module=M,type=T}) -> + CurrentMod = get(currmod), + TDef = asn1_db:dbget(M,T), + Def = TDef#typedef.typespec, + OTag = Def#type.tag, + Tag = [X#tag{class=decode_class(X#tag.class)}|| X <- OTag], + if + M == CurrentMod -> + emit({" 'dec_",T,"'(",Bytes, + ", opt_or_default,TagIn ++ ",{asis,Tag},")"}), + []; + true -> + emit({" '",M,"':'dec_",T, + "'(",Bytes,", opt_or_default,TagIn ++ ",{asis,Tag},")"}), + [] + end; +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,[{_,no_unique_value,_},T|Rest], + ClName,ClFields,NthObj,Acc) -> + %% No need to check that this class has property OPTIONAL for the + %% unique field, it was detected in the previous phase + gen_objset_enc(ObjSName,UniqueName,[T|Rest],ClName,ClFields,NthObj,Acc); +gen_objset_enc(ObjSetName,UniqueName,[{_,no_unique_value,_}], + _ClName,_ClFields,_NthObj,Acc) -> + %% No need to check that this class has property OPTIONAL for the + %% unique field, it was detected in the previous phase + emit_default_getenc(ObjSetName,UniqueName), + emit({".",nl,nl}), + Acc; +gen_objset_enc(ObjSName,UniqueName, + [{ObjName,Val,Fields},T|Rest],ClName,ClFields,NthObj,Acc)-> + emit({"'getenc_",ObjSName,"'(",{asis,UniqueName},",",{asis,Val},") ->",nl}), + CurrMod = get(currmod), + {InternalFunc,NewNthObj}= + case ObjName of + {no_mod,no_name} -> + gen_inlined_enc_funs(Fields,ClFields,ObjSName,NthObj); + {CurrMod,Name} -> + emit({" fun 'enc_",Name,"'/4"}), + {[],NthObj}; + {ModuleName,Name} -> + emit_ext_fun(enc,ModuleName,Name), +% emit([" {'",ModuleName,"', 'enc_",Name,"'}"]), + {[],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}), + CurrMod = get(currmod), + {InternalFunc,_}= + case ObjName of + {no_mod,no_name} -> + gen_inlined_enc_funs(Fields,ClFields,ObjSetName,NthObj); + {CurrMod,Name} -> + emit({" fun 'enc_",Name,"'/4"}), + {[],NthObj}; + {ModuleName,Name} -> + emit_ext_fun(enc,ModuleName,Name), +% emit([" {'",ModuleName,"', 'enc_",Name,"'}"]), + {[],NthObj}; + _Other -> + emit({" fun 'enc_",ObjName,"'/4"}), + {[],NthObj} + end, + emit([";",nl]), + emit_default_getenc(ObjSetName,UniqueName), + 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 is_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(ObjSetName,UniqueName,['EXTENSIONMARK','EXTENSIONMARK'|Rest], + ClName,ClFields,NthObj,Acc) -> + gen_objset_enc(ObjSetName,UniqueName,['EXTENSIONMARK'|Rest], + ClName,ClFields,NthObj,Acc); +gen_objset_enc(ObjSetName,UniqueName,['EXTENSIONMARK'|Rest], + ClName,ClFields,NthObj,Acc) -> + gen_objset_enc(ObjSetName,UniqueName,Rest++['EXTENSIONMARK'], + ClName,ClFields,NthObj,Acc); +gen_objset_enc(_,_,[],_,_,_,Acc) -> + Acc. + +emit_ext_fun(EncDec,ModuleName,Name) -> + emit([indent(3),"fun(T,V,_O1,_O2) -> '",ModuleName,"':'",EncDec,"_", + Name,"'(T,V,_O1,_O2) end"]). + +emit_default_getenc(ObjSetName,UniqueName) -> + emit(["'getenc_",ObjSetName,"'(",{asis,UniqueName},", ErrV) ->",nl]), + emit([indent(3),"fun(C,V,_,_) -> exit({'Type not compatible with table constraint',{component,C},{value,V}, {unique_name_and_value,",{asis,UniqueName},", ErrV}}) end"]). + +%% 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) -> + CurrMod = get(currmod), + InternalDefFunName = asn1ct_gen:list2name([NthObj,Name,ObjSetName]), + case lists:keysearch(Name,1,Fields) of + {value,{_,Type}} when is_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 is_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); + {value,{_,#'Externaltypereference'{module=M,type=T}}} -> + #typedef{typespec=Type} = asn1_db:dbget(M,T), + OTag = Type#type.tag, + Tag = [X#tag{class=decode_class(X#tag.class)}|| X <- OTag], + emit([indent(3),"fun(Type, Val, TagIn, _RestPrimFieldName) ->",nl, + indent(6),"case Type of",nl]), + emit([indent(9),{asis,Name}," ->",nl]), + if + M == CurrMod -> + emit([indent(12),"'enc_",T,"'(Val, TagIn ++ ", + {asis,Tag},")"]); + true -> + emit([indent(12),"'",M,"':'enc_",T,"'(Val,TagIn ++", + {asis,Tag},")"]) + end, + gen_inlined_enc_funs1(Fields,Rest,ObjSetName,NthObj,[]); + false -> + %% This field was not present in the object thus there were no + %% type in the table and we therefore generate code that returns + %% the input for application treatment. + emit([indent(3),"fun(Type, Val, TagIn, _RestPrimFieldName) ->",nl, + indent(6),"case Type of",nl]), + emit([indent(9),{asis,Name}," ->",nl]), + emit([indent(12),"Len = case Val of",nl, + indent(15),"Bin when is_binary(Bin) -> size(Bin);",nl, + indent(15),"_ -> length(Val)",nl,indent(12),"end,",nl, + indent(12),"{Val,Len}"]), + gen_inlined_enc_funs1(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) -> + CurrMod = get(currmod), + InternalDefFunName = asn1ct_gen:list2name([NthObj,Name,ObjSetName]), + {Acc2,NAdd}= + case lists:keysearch(Name,1,Fields) of + {value,{_,Type}} when is_record(Type,type) -> + emit({";",nl}), + {Ret,N}=emit_inner_of_fun(Type,InternalDefFunName), + {Ret++Acc,N}; + {value,{_,Type}} when is_record(Type,typedef) -> + emit({";",nl,indent(9),{asis,Name}," ->",nl}), + {Ret,N}=emit_inner_of_fun(Type,InternalDefFunName), + {Ret++Acc,N}; + {value,{_,#'Externaltypereference'{module=M,type=T}}} -> + #typedef{typespec=Type} = asn1_db:dbget(M,T), + OTag = Type#type.tag, + Tag = [X#tag{class=decode_class(X#tag.class)}|| X <- OTag], + emit({";",nl,indent(9),{asis,Name}," ->",nl}), + if + M == CurrMod -> + emit([indent(12),"'enc_",T,"'(Val, TagIn ++ ", + {asis,Tag},")"]); + true -> + emit([indent(12),"'",M,"':'enc_",T,"'(Val,TagIn ++", + {asis,Tag},")"]) + end, + {Acc,0}; + false -> + %% This field was not present in the object thus there were no + %% type in the table and we therefore generate code that returns + %% the input for application treatment. + emit([";",nl,indent(9),{asis,Name}," ->",nl]), + emit([indent(12),"Len = case Val of",nl, + indent(15),"Bin when is_binary(Bin) -> size(Bin);",nl, + indent(15),"_ -> length(Val)",nl,indent(12),"end,",nl, + indent(12),"{Val,Len}"]), + {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 is_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 is_atom(Def) -> + emit({indent(9),Def," ->",nl,indent(12)}), + gen_encode_prim(ber,Type,["TagIn ++ ",{asis,Tag}],"Val"); + TRef when is_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,[{_,no_unique_value,_},T|Rest], + ClName,ClFields,NthObj)-> + gen_objset_dec(Erules,ObjSName,UniqueName,[T|Rest],ClName,ClFields, + NthObj); +gen_objset_dec(_Erules,ObjSetName,UniqueName,[{_,no_unique_value,_}], + _ClName,_ClFields,_NthObj)-> + emit_default_getdec(ObjSetName,UniqueName), + emit({".",nl,nl}); +gen_objset_dec(Erules,ObjSName,UniqueName,[{ObjName,Val,Fields},T|Rest], + ClName,ClFields,NthObj)-> + emit({"'getdec_",ObjSName,"'(",{asis,UniqueName},",",{asis,Val}, + ") ->",nl}), + CurrMod = get(currmod), + NewNthObj= + case ObjName of + {no_mod,no_name} -> + gen_inlined_dec_funs(Erules,Fields,ClFields,ObjSName, + NthObj); + {CurrMod,Name} -> + emit({" fun 'dec_",Name,"'/4"}), + NthObj; + {ModName,Name} -> + emit_ext_fun(dec,ModName,Name), +% emit([" {'",ModName,"', 'dec_",Name,"'}"]), + 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}), + CurrMod = get(currmod), + case ObjName of + {no_mod,no_name} -> + gen_inlined_dec_funs(Erules,Fields,ClFields,ObjSetName, + NthObj); + {CurrMod,Name} -> + emit({" fun 'dec_",Name,"'/4"}); + {ModName,Name} -> + emit_ext_fun(dec,ModName,Name); +% emit([" {'",ModName,"', 'dec_",Name,"'}"]); + _Other -> + emit({" fun 'dec_",ObjName,"'/4"}) + end, + emit({";",nl}), + emit_default_getdec(ObjSetName,UniqueName), + 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 is_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(Erule,ObjSetName,UniqueName, + ['EXTENSIONMARK','EXTENSIONMARK'|Rest], + ClName,ClFields,NthObj) -> + gen_objset_dec(Erule,ObjSetName,UniqueName,['EXTENSIONMARK'|Rest], + ClName,ClFields,NthObj); +gen_objset_dec(Erule,ObjSetName,UniqueName,['EXTENSIONMARK'|Rest], + ClName,ClFields,NthObj) -> + gen_objset_dec(Erule,ObjSetName,UniqueName,Rest++['EXTENSIONMARK'], + ClName,ClFields,NthObj); +gen_objset_dec(_,_,_,[],_,_,_) -> + ok. + +emit_default_getdec(ObjSetName,UniqueName) -> + emit(["'getdec_",ObjSetName,"'(",{asis,UniqueName},", ErrV) ->",nl]), + emit([indent(3),"fun(C,V,_,_) -> exit({{component,C},{value,V}, {unique_name_and_value,",{asis,UniqueName},", ErrV}}) end"]). + +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, + CurrMod = get(currmod), + InternalDefFunName = [NthObj,Name,ObjSetName], + case lists:keysearch(Name,1,Fields) of + {value,{_,Type}} when is_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 is_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); + {value,{_,#'Externaltypereference'{module=M,type=T}}} -> + #typedef{typespec=Type} = asn1_db:dbget(M,T), + OTag = Type#type.tag, + Tag = [X#tag{class=decode_class(X#tag.class)}|| X <- OTag], + emit({indent(3),"fun(Type, Bytes, TagIn, _RestPrimFieldName) ->", + nl,indent(6),"case Type of",nl}), + emit({indent(9),{asis,Name}," ->",nl}), + if + M == CurrMod -> + emit([indent(12),"'dec_",T,"'(Bytes, ",DecProp, + ", TagIn ++ ",{asis,Tag},")"]); + true -> + emit([indent(12),"'",M,"':'dec_",T,"'(Bytes, ", + DecProp,", TagIn ++ ",{asis,Tag},")"]) + end, + gen_inlined_dec_funs1(Erules,Fields,Rest,ObjSetName,NthObj); + false -> + emit([indent(3),"fun(Type, Bytes, TagIn, _RestPrimFieldName) ->", + nl,indent(6),"case Type of",nl, + indent(9),{asis,Name}," ->",nl, + indent(12),"Len = case Bytes of",nl, + indent(15),"B when is_binary(B) -> size(B);",nl, + indent(15),"_ -> length(Bytes)",nl, + indent(12),"end,",nl, + indent(12),"{Bytes,[],Len}"]), + gen_inlined_dec_funs1(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, + CurrMod = get(currmod), + InternalDefFunName = [NthObj,Name,ObjSetName], + N= + case lists:keysearch(Name,1,Fields) of + {value,{_,Type}} when is_record(Type,type) -> + emit({";",nl}), + emit_inner_of_decfun(Erules,Type,DecProp,InternalDefFunName); + {value,{_,Type}} when is_record(Type,typedef) -> + emit({";",nl,indent(9),{asis,Name}," ->",nl}), + emit_inner_of_decfun(Erules,Type,DecProp,InternalDefFunName); + {value,{_,#'Externaltypereference'{module=M,type=T}}} -> + #typedef{typespec=Type} = asn1_db:dbget(M,T), + OTag = Type#type.tag, + Tag = [X#tag{class=decode_class(X#tag.class)}|| X <- OTag], + emit({";",nl,indent(9),{asis,Name}," ->",nl}), + if + M == CurrMod -> + emit([indent(12),"'dec_",T,"'(Bytes, ",DecProp, + ", TagIn ++ ",{asis,Tag},")"]); + true -> + emit([indent(12),"'",M,"':'dec_",T,"'(Bytes, ", + DecProp,", TagIn ++ ",{asis,Tag},")"]) + end, + 0; + false -> + emit([";",nl, + indent(9),{asis,Name}," ->",nl, + indent(12),"Len = case Bytes of",nl, + indent(15),"B when is_binary(B) -> size(B);",nl, + indent(15),"_ -> length(Bytes)",nl, + indent(12),"end,",nl, + indent(12),"{Bytes,[],Len}"]), + 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 is_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 is_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('ObjectDescriptor') -> 7; +decode_type('EXTERNAL') -> 8; +decode_type('REAL') -> 9; +decode_type('ENUMERATED') -> 10; +decode_type('EMBEDDED_PDV') -> 11; +decode_type('UTF8String') -> 12; +decode_type('RELATIVE-OID') -> 13; +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('T61String') -> 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 is_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/asn1/src/asn1ct_gen_ber_bin_v2.erl b/lib/asn1/src/asn1ct_gen_ber_bin_v2.erl new file mode 100644 index 0000000000..b7ac0f407c --- /dev/null +++ b/lib/asn1/src/asn1ct_gen_ber_bin_v2.erl @@ -0,0 +1,1833 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2002-2009. All Rights Reserved. +%% +%% 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 online 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. +%% +%% %CopyrightEnd% +%% +%% +-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,gen_decode_selected/3]). + +-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 is_record(Type,typedef) -> + gen_encode_user(Erules,Type). + +%%=============================================================================== +%% encode #{type, {tag, def, constraint}} +%%=============================================================================== + +gen_encode(Erules,Typename,Type) when is_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 is_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'{name=Cname,typespec=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 is_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 is_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 is_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 ",Value," of",nl]), + emit_enc_enumerated_cases(NamedNumberList,DoTag); + {'ENUMERATED',NamedNumberList} -> + + emit(["case ",Value," of",nl]), + emit_enc_enumerated_cases(NamedNumberList,DoTag); + + 'REAL' -> + emit_encode_func('real',Constraint,Value,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); + 'RELATIVE-OID' -> + emit_encode_func("relative_oid",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); + TString when TString == 'TeletexString'; + TString == 'T61String' -> + 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); + 'UTF8String' -> + emit_encode_func('UTF8_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); + #'ObjectClassFieldType'{} -> + case asn1ct_gen:get_inner(D#type.def) of + {fixedtypevaluefield,_,InnerType} -> + gen_encode_prim(Erules,InnerType,DoTag,Value); + 'ASN1_OPEN_TYPE' -> + emit_encode_func('open_type', Value,DoTag); + XX -> + exit({'can not encode' ,XX}) + end; + XX -> + exit({'can not encode' ,XX}) + end. + + +emit_encode_func(Name,Value,Tags) when is_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 is_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 is_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]) +%% 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 is_record(Type,typedef) -> + Def = Type#typedef.typespec, + InnerTag = Def#type.tag , + + Tag = [(decode_class(X#tag.class) bsl 10) + X#tag.number || X <- InnerTag], + + FunctionName = + case {asn1ct:get_gen_state_field(active), + asn1ct:get_gen_state_field(prefix)} of + {true,Pref} -> + %% prevent duplicated function definitions +% Pattern = asn1ct:get_gen_state_field(namelist), +% FuncName=asn1ct:maybe_rename_function(Type#typedef.name, +% Pattern), + case asn1ct:current_sindex() of + I when is_integer(I),I>0 -> + lists:concat([Pref,Type#typedef.name,"_",I]); + _-> + lists:concat([Pref,Type#typedef.name]) + end; % maybe the current_sindex must be reset + _ -> lists:concat(["dec_",Type#typedef.name]) + end, + emit({nl,nl}), + emit(["'",FunctionName,"'(Tlv) ->",nl]), + emit([" '",FunctionName,"'(Tlv, ",{asis,Tag},").",nl,nl]), + emit(["'",FunctionName,"'(Tlv, TagIn) ->",nl]), + dbdec(Type#typedef.name,"Tlv"), + gen_decode_user(Erules,Type). + +gen_inc_decode(Erules,Type) when is_record(Type,typedef) -> + Prefix = asn1ct:get_gen_state_field(prefix), + Suffix = asn1ct_gen:index2suffix(asn1ct:current_sindex()), + emit({nl,nl}), + emit(["'",Prefix,Type#typedef.name,Suffix,"'(Tlv, TagIn) ->",nl]), + gen_decode_user(Erules,Type). + +%% gen_decode_selected exported function for selected decode +gen_decode_selected(Erules,Type,FuncName) -> + emit([FuncName,"(Bin) ->",nl]), +% Pattern = asn1ct:get_gen_state_field(tag_pattern), + Patterns = asn1ct:read_config_data(partial_decode), + Pattern = + case lists:keysearch(FuncName,1,Patterns) of + {value,{_,P}} -> P; + false -> exit({error,{internal,no_pattern_saved}}) + end, + emit([" case ?RT_BER:decode_selective(",{asis,Pattern},",Bin) of",nl, + " {ok,Bin2} when is_binary(Bin2) ->",nl, + " {Tlv,_} = ?RT_BER:decode(Bin2),",nl]), + emit("{ok,"), + gen_decode_selected_type(Erules,Type), + emit(["};",nl," Err -> exit({error,{selctive_decode,Err}})",nl, + " end.",nl]). + +gen_decode_selected_type(_Erules,TypeDef) -> + Def = TypeDef#typedef.typespec, + InnerType = asn1ct_gen:get_inner(Def#type.def), + BytesVar = "Tlv", + Tag = [(decode_class(X#tag.class) bsl 10) + X#tag.number || + X <- Def#type.tag], + case asn1ct_gen:type(InnerType) of + 'ASN1_OPEN_TYPE' -> + asn1ct_name:new(len), + gen_dec_prim(ber, Def#type{def='ASN1_OPEN_TYPE'}, + BytesVar,Tag, [] , + ?PRIMITIVE,"OptOrMand"); +% emit({";",nl}); + {primitive,bif} -> + asn1ct_name:new(len), + gen_dec_prim(ber, Def, BytesVar,Tag,[] , + ?PRIMITIVE,"OptOrMand"); +% emit([";",nl]); + {constructed,bif} -> + TopType = case TypeDef#typedef.name of + A when is_atom(A) -> [A]; + N -> N + end, + DecFunName = lists:concat(["'",dec,"_", + asn1ct_gen:list2name(TopType),"'"]), + emit([DecFunName,"(",BytesVar, + ", ",{asis,Tag},")"]); +% emit([";",nl]); + TheType -> + DecFunName = mkfuncname(TheType,dec), + emit([DecFunName,"(",BytesVar, + ", ",{asis,Tag},")"]) +% emit([";",nl]) + end. + +%%=============================================================================== +%% 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 for an inner +%% type of an exclusive decode top type.. +gen_decode(Erules,Typename,Type) when is_record(Type,type) -> + InnerType = asn1ct_gen:get_inner(Type#type.def), + FunctionName = + case asn1ct:get_gen_state_field(active) of + true -> +% Suffix = asn1ct_gen:index2suffix(SIndex), + Pattern = asn1ct:get_gen_state_field(namelist), + Suffix = + case asn1ct:maybe_saved_sindex(Typename,Pattern) of + I when is_integer(I),I>0 -> + lists:concat(["_",I]); + _ -> "" + end, + lists:concat(["'dec-inc-", + asn1ct_gen:list2name(Typename),Suffix]); + _ -> + lists:concat(["'dec_",asn1ct_gen:list2name(Typename)]) + end, +% io:format("Typename: ~p,~n",[Typename]), +% io:format("FunctionName: ~p~n",[FunctionName]), + 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]), + emit([FunctionName,"'(Tlv, TagIn",ObjFun,") ->",nl]), + dbdec(Typename,"Tlv"), + asn1ct_gen:gen_decode_constructed(Erules,Typename,InnerType,Type); + Rec when is_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'{name=Cname,typespec=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=[]}, + 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 is_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}); + 'REAL' -> + emit({"?RT_BER:decode_real(",BytesVar,","}), + add_func({decode_real,3}); + {'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}); + 'RELATIVE-OID' -> + emit({"?RT_BER:decode_relative_oid(",BytesVar,","}), + add_func({decode_relative_oid,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}); + TString when TString == 'TeletexString'; + TString == 'T61String' -> + 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}); + 'UTF8String' -> + emit({"?RT_BER:decode_UTF8_string",AsBin,"(", + BytesVar,","}), + add_func({decode_UTF8_string,2}); + '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}); + #'ObjectClassFieldType'{} -> + case asn1ct_gen:get_inner(Att#type.def) of + {fixedtypevaluefield,_,InnerType} -> + gen_dec_prim(Erules,InnerType,BytesVar,DoTag,TagIn,Form,OptOrMand); + '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; + Other -> + exit({'can not decode' ,Other}) + end, + + case {DoTag,NewTypeName} of + {_,#'ObjectClassFieldType'{}} -> + case asn1ct_gen:get_inner(Att#type.def) of + 'ASN1_OPEN_TYPE' -> + emit([{asis,DoTag},")"]); + _ -> ok + end; + {{string,TagStr},'ASN1_OPEN_TYPE'} -> + emit([TagStr,")"]); + {_,'ASN1_OPEN_TYPE'} -> + emit([{asis,DoTag},")"]); + {{string,TagStr},_} -> + emit([TagStr,")"]); + _ when is_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 is_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 is_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("Val"), + emit([" {Val,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) -> + CurrentMod = get(currmod), + 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', ",{asis,Name}, + "}})"]); + {false,{'DEFAULT',_DefaultObject}} -> + exit({error,{asn1,{"not implemented yet",Name}}}); + {{Name,#'Externalvaluereference'{module=CurrentMod, + value=TypeName}},_} -> + EmitFuncClause(" Val, [H|T]"), + emit({indent(3),"'enc_",TypeName,"'(H, Val, T)"}); + {{Name,#'Externalvaluereference'{module=M,value=TypeName}},_} -> + EmitFuncClause(" Val, [H|T]"), + emit({indent(3),"'",M,"':'enc_",TypeName,"'(H, Val, T)"}); + {{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_constr_type(Erules,[TypeDef|Rest]) when is_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, + #'Externaltypereference'{module=M,type=T}) -> + CurrentMod = get(currmod), + TDef = asn1_db:dbget(M,T), + Def = TDef#typedef.typespec, + OTag = Def#type.tag, + Tag = [encode_tag_val(decode_class(X#tag.class), + X#tag.form,X#tag.number)|| + X <- OTag], + if + M == CurrentMod -> + emit({" 'enc_",T,"'(Val, ",{asis,Tag},")"}), + []; + true -> + emit({" '",M,"':'enc_",T,"'(Val, ",{asis,Tag},")"}), + [] + end; +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(" Bytes"), + emit([" Bytes"]), + []; + {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) -> + CurrentMod = get(currmod), + 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', ",{asis,Name}, + "}})"]); + {false,{'DEFAULT',_DefaultObject}} -> + exit({error,{asn1,{"not implemented yet",Name}}}); + {{Name,#'Externalvaluereference'{module=CurrentMod, + value=TypeName}},_} -> + EmitFuncClause("Bytes,[H|T]"), + emit({indent(3),"'dec_",TypeName,"'(H, Bytes, T)"}); + {{Name,#'Externalvaluereference'{module=M,value=TypeName}},_} -> + EmitFuncClause("Bytes,[H|T]"), + emit({indent(3),"'",M,"':'dec_",TypeName, + "'(H, Bytes, T)"}); + {{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 is_binary(Bytes) ->",nl, + " {Tlv,_}=?RT_BER:decode(Bytes),",nl, + " Tlv;",nl, + "tlv_format(Bytes) ->",nl, + " Bytes.",nl]). + + +gen_decode_constr_type(Erules,[TypeDef|Rest]) when is_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, + #'Externaltypereference'{module=M,type=T}) -> + CurrentMod = get(currmod), + TDef = asn1_db:dbget(M,T), + Def = TDef#typedef.typespec, + OTag = Def#type.tag, + Tag = [(decode_class(X#tag.class) bsl 10) + X#tag.number || + X <- OTag], + if + M == CurrentMod -> + emit({" 'dec_",T,"'(",Bytes, + ", ",{asis,Tag},")"}), + []; + true -> + emit({" '",M,"':'dec_",T, + "'(",Bytes,", ",{asis,Tag},")"}), + [] + end; +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}), + CurrMod = get(currmod), + {InternalFunc,NewNthObj}= + case ObjName of + {no_mod,no_name} -> + gen_inlined_enc_funs(Fields,ClFields,ObjSName,NthObj); + {CurrMod,Name} -> + emit({" fun 'enc_",Name,"'/3"}), + {[],NthObj}; + {ModuleName,Name} -> + emit_ext_fun(enc,ModuleName,Name), +% emit([" {'",ModuleName,"', 'enc_",Name,"'}"]), + {[],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}), + CurrMod = get(currmod), + {InternalFunc,_} = + case ObjName of + {no_mod,no_name} -> + gen_inlined_enc_funs(Fields,ClFields,ObjSetName,NthObj); + {CurrMod,Name} -> + emit({" fun 'enc_",Name,"'/3"}), + {[],NthObj}; + {ModuleName,Name} -> + emit_ext_fun(enc,ModuleName,Name), +% emit([" {'",ModuleName,"', 'enc_",Name,"'}"]), + {[],NthObj}; + _ -> + emit({" fun 'enc_",ObjName,"'/3"}), + {[],NthObj} + end, + emit([";",nl]), + emit_default_getenc(ObjSetName,UniqueName), + 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 is_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. + +emit_ext_fun(EncDec,ModuleName,Name) -> + emit([indent(3),"fun(T,V,O) -> '",ModuleName,"':'",EncDec,"_", + Name,"'(T,V,O) end"]). + +emit_default_getenc(ObjSetName,UniqueName) -> + emit(["'getenc_",ObjSetName,"'(",{asis,UniqueName},", ErrV) ->",nl]), + emit([indent(3),"fun(C,V,_) -> exit({'Type not compatible with table constraint',{component,C},{value,V}, {unique_name_and_value,",{asis,UniqueName},", ErrV}}) end"]). + +%% 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) -> + CurrMod = get(currmod), + InternalDefFunName = asn1ct_gen:list2name([NthObj,Name,ObjSetName]), + case lists:keysearch(Name,1,Fields) of + {value,{_,Type}} when is_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 is_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); + {value,{_,#'Externaltypereference'{module=M,type=T}}} -> + emit([indent(3),"fun(Type, Val, _RestPrimFieldName) ->",nl, + indent(6),"case Type of",nl]), + emit([indent(9),{asis,Name}," ->",nl]), + if + M == CurrMod -> + emit([indent(12),"'enc_",T,"'(Val)"]); + true -> + #typedef{typespec=Type} = asn1_db:dbget(M,T), + OTag = Type#type.tag, +%% Tag = [encode_tag_val((decode_class(X#tag.class) bsl 10) + +%% X#tag.number) || +%% X <- OTag], + Tag = [encode_tag_val(decode_class(X#tag.class), + X#tag.form,X#tag.number) || + X <- OTag], + emit([indent(12),"'",M,"':'enc_",T,"'(Val, ",{asis,Tag},")"]) + end, + gen_inlined_enc_funs1(Fields,Rest,ObjSetName,NthObj,[]); + false -> + %% This field was not present in the object thus there + %% were no type in the table and we therefore generate + %% code that returns the input for application treatment. + emit([indent(3),"fun(Type, Val, _RestPrimFieldName) ->",nl, + indent(6),"case Type of",nl, + indent(9),{asis,Name}," ->",nl, + indent(12),"Len = case Val of",nl, + indent(15),"B when is_binary(B) -> size(B);",nl, + indent(15),"_ -> length(Val)",nl, + indent(12),"end,",nl, + indent(12),"{Val,Len}"]), + gen_inlined_enc_funs1(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) -> + CurrMod = get(currmod), + InternalDefFunName = asn1ct_gen:list2name([NthObj,Name,ObjSetName]), + {Acc2,NAdd}= + case lists:keysearch(Name,1,Fields) of + {value,{_,Type}} when is_record(Type,type) -> + emit({";",nl}), + {Ret,N}=emit_inner_of_fun(Type,InternalDefFunName), + {Ret++Acc,N}; + {value,{_,Type}} when is_record(Type,typedef) -> + emit({";",nl,indent(9),{asis,Name}," ->",nl}), + {Ret,N}=emit_inner_of_fun(Type,InternalDefFunName), + {Ret++Acc,N}; + {value,{_,#'Externaltypereference'{module=M,type=T}}} -> + emit({";",nl,indent(9),{asis,Name}," ->",nl}), + if + M == CurrMod -> + emit([indent(12),"'enc_",T,"'(Val)"]); + true -> + #typedef{typespec=Type} = asn1_db:dbget(M,T), + OTag = Type#type.tag, + Tag = [encode_tag_val(decode_class(X#tag.class), + X#tag.form,X#tag.number) || + X <- OTag], + emit([indent(12),"'",M,"':'enc_",T,"'(Val, ",{asis,Tag},")"]) + end, + {Acc,0}; + false -> + %% This field was not present in the object thus there + %% were no type in the table and we therefore generate + %% code that returns the input for application + %% treatment. + emit([";",nl,indent(9),{asis,Name}," ->",nl]), + emit([indent(12),"Len = case Val of",nl, + indent(15),"Bin when is_binary(Bin) -> size(Bin);",nl, + indent(15),"_ -> length(Val)",nl,indent(12),"end,",nl, + indent(12),"{Val,Len}"]), + {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, ",{asis,Tag},")"]), + {[TDef#typedef{name=InternalDefFunName}],1}; + _ -> + emit({indent(12),"'",ExtMod,"':'enc_",Name,"'(Val",{asis,Tag},")"}), + {[],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 is_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 is_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 is_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} -> + #typedef{typespec=ExtType} = asn1_db:dbget(ExtMod,T), + OTag = ExtType#type.tag, + Tag = [encode_tag_val(decode_class(X#tag.class), + X#tag.form,X#tag.number) || + X <- OTag], + emit([indent(9),T," ->",nl,indent(12),ExtMod,":'enc_", + T,"'(Val, ",{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]), + CurrMod = get(currmod), + NewNthObj= + case ObjName of + {no_mod,no_name} -> + gen_inlined_dec_funs(Fields,ClFields,ObjSName,NthObj); + {CurrMod,Name} -> + emit([" fun 'dec_",Name,"'/3"]), + NthObj; + {ModuleName,Name} -> + emit_ext_fun(dec,ModuleName,Name), +% emit([" {'",ModuleName,"', 'dec_",Name,"'}"]), + 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]), + CurrMod = get(currmod), + case ObjName of + {no_mod,no_name} -> + gen_inlined_dec_funs(Fields,ClFields,ObjSetName,NthObj); + {CurrMod,Name} -> + emit([" fun 'dec_",Name,"'/3"]); + {ModuleName,Name} -> + emit_ext_fun(dec,ModuleName,Name); +% emit([" {'",ModuleName,"', 'dec_",Name,"'}"]); + _ -> + emit([" fun 'dec_",ObjName,"'/3"]) + end, + emit([";",nl]), + emit_default_getdec(ObjSetName,UniqueName), + 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 is_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 is_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. + +emit_default_getdec(ObjSetName,UniqueName) -> + emit(["'getdec_",ObjSetName,"'(",{asis,UniqueName},", ErrV) ->",nl]), + emit([indent(2), "fun(C,V,_) -> exit({{component,C},{value,V},{unique_name_and_value,",{asis,UniqueName},", ErrV}}) end"]). + +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, + CurrMod = get(currmod), + InternalDefFunName = [NthObj,Name,ObjSetName], + case lists:keysearch(Name,1,Fields) of + {value,{_,Type}} when is_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 is_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); + {value,{_,#'Externaltypereference'{module=M,type=T}}} -> + emit([indent(3),"fun(Type, Bytes, _RestPrimFieldName) ->", + nl,indent(6),"case Type of",nl]), + emit([indent(9),{asis,Name}," ->",nl]), + if + M == CurrMod -> + emit([indent(12),"'dec_",T,"'(Bytes)"]); + true -> + #typedef{typespec=Type} = asn1_db:dbget(M,T), + OTag = Type#type.tag, + Tag = [(decode_class(X#tag.class) bsl 10) + X#tag.number || + X <- OTag], + emit([indent(12),"'",M,"':'dec_",T,"'(Bytes, ",{asis,Tag},")"]) + end, + gen_inlined_dec_funs1(Fields,Rest,ObjSetName,NthObj); + false -> + emit([indent(3),"fun(Type, Bytes, _RestPrimFieldName) ->", + nl,indent(6),"case Type of",nl, + indent(9),{asis,Name}," ->",nl, + indent(12),"Len = case Bytes of",nl, + indent(15),"B when is_binary(B) -> size(B);",nl, + indent(15),"_ -> length(Bytes)",nl, + indent(12),"end,",nl, + indent(12),"{Bytes,[],Len}"]), + gen_inlined_dec_funs1(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, + CurrMod = get(currmod), + InternalDefFunName = [NthObj,Name,ObjSetName], + N= + case lists:keysearch(Name,1,Fields) of + {value,{_,Type}} when is_record(Type,type) -> + emit([";",nl]), + emit_inner_of_decfun(Type,DecProp,InternalDefFunName); + {value,{_,Type}} when is_record(Type,typedef) -> + emit([";",nl,indent(9),{asis,Name}," ->",nl]), + emit_inner_of_decfun(Type,DecProp,InternalDefFunName); + {value,{_,#'Externaltypereference'{module=M,type=T}}} -> + emit([";",nl,indent(9),{asis,Name}," ->",nl]), + if + M == CurrMod -> + emit([indent(12),"'dec_",T,"'(Bytes)"]); + true -> + #typedef{typespec=Type} = asn1_db:dbget(M,T), + OTag = Type#type.tag, + Tag = [(decode_class(X#tag.class) bsl 10) + + X#tag.number || X <- OTag], + emit([indent(12),"'",M,"':'dec_",T,"'(Bytes, ",{asis,Tag},")"]) + end, + 0; + false -> + emit([";",nl, + indent(9),{asis,Name}," ->",nl, + indent(12),"Len = case Bytes of",nl, + indent(15),"B when is_binary(B) -> size(B);",nl, + indent(15),"_ -> length(Bytes)",nl, + indent(12),"end,",nl, + indent(12),"{Bytes,[],Len}"]), + 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, ", + {asis,Tag},")"]), + 0 + end; +emit_inner_of_decfun(#typedef{name=Name},_Prop,_) -> + emit([indent(12),"'dec_",Name,"'(Bytes)"]), + 0; +emit_inner_of_decfun(Type,Prop,_) when is_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, ",{asis,Tag},")"]) + 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,Arg) -> + demit({"io:format(\"decoding: ",{asis,Type},"~w~n\",[",Arg,"]),",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('ObjectDescriptor') -> 7; +decode_type('EXTERNAL') -> 8; +decode_type('REAL') -> 9; +decode_type('ENUMERATED') -> 10; +decode_type('EMBEDDED_PDV') -> 11; +decode_type('UTF8String') -> 12; +decode_type('RELATIVE-OID') -> 13; +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('T61String') -> 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/asn1/src/asn1ct_gen_per.erl b/lib/asn1/src/asn1ct_gen_per.erl new file mode 100644 index 0000000000..06d2489748 --- /dev/null +++ b/lib/asn1/src/asn1ct_gen_per.erl @@ -0,0 +1,1395 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1997-2009. All Rights Reserved. +%% +%% 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 online 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. +%% +%% %CopyrightEnd% +%% +%% +-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 is_record(Type,typedef) -> + gen_encode_user(Erules,Type). +%% case Type#typedef.typespec of +%% Def when is_record(Def,type) -> +%% gen_encode_user(Erules,Type); +%% Def when is_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 is_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 is_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 is_record(D,type) -> + Constraint = D#type.constraint, + asn1ct_name:new(enumval), + case D#type.def of + 'INTEGER' -> + emit({"?RT_PER:encode_integer(", %fel + {asis,effective_constraint(integer,Constraint)},",",Value,")"}); + {'INTEGER',NamedNumberList} -> + emit({"?RT_PER:encode_integer(", + {asis,effective_constraint(integer,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}}], + case Erules of + uper_bin -> + emit(["case ",Value," of",nl]); + _ -> + emit(["case (case ",Value," of {_,",{curr,enumval},"}-> ", + {curr,enumval},";_->", Value," end) of",nl]), + asn1ct_name:new(enumval) + end, +%% emit_enc_enumerated_cases(Erules,NewC, NewList++[{asn1_enum,length(Nlist1)-1}], 0); + emit_enc_enumerated_cases(Erules,NewC, NewList, 0); + {'ENUMERATED',NamedNumberList} -> + NewList = [X||{X,_} <- NamedNumberList], + NewC = [{'ValueRange',{0,length(NewList)-1}}], + case Erules of + uper_bin -> + emit(["case ",Value," of",nl]); + _ -> + emit(["case (case ",Value," of {_,",{curr,enumval}, + "}->",{curr,enumval},";_->",Value," end) of",nl]) + end, + emit_enc_enumerated_cases(Erules,NewC, NewList, 0); + + 'REAL' -> + emit({"?RT_PER:encode_real(",Value,")"}); + + {'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,")"}); + 'RELATIVE-OID' -> + emit({"?RT_PER:encode_relative_oid(",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,")"}); + TString when TString == 'TeletexString'; + TString == 'T61String' -> + 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,")"}); + 'UTF8String' -> + emit({"?RT_PER:encode_UTF8String(",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, ")"]); + #'ObjectClassFieldType'{} -> + case asn1ct_gen:get_inner(D#type.def) of + {fixedtypevaluefield,_,InnerType} -> + gen_encode_prim(Erules,InnerType,DoTag,Value); + T -> %% 'ASN1_OPEN_TYPE' + gen_encode_prim(Erules,D#type{def=T},DoTag,Value) + end; + XX -> + exit({asn1_error,nyi,XX}) + end. + + +emit_enc_enumerated_cases(Erule,C, [H], Count) -> + emit_enc_enumerated_case(Erule,C, H, Count), + case H of + 'EXT_MARK' -> ok; + _ -> + emit([";",nl]) + end, + emit([nl,"EnumVal -> exit({error,{asn1, {enumerated_not_in_range, EnumVal}}})"]), + emit([nl,"end"]); +emit_enc_enumerated_cases(Erule, C, ['EXT_MARK'|T], _Count) -> + emit_enc_enumerated_cases(Erule, C, T, 0); +emit_enc_enumerated_cases(Erule, C, [H1,H2|T], Count) -> + emit_enc_enumerated_case(Erule, C, H1, Count), + emit([";",nl]), + emit_enc_enumerated_cases(Erule, C, [H2|T], Count+1). + + + +emit_enc_enumerated_case(uper_bin,_C, {asn1_enum,High}, _) -> + emit([ + "{asn1_enum,EnumV} when is_integer(EnumV), EnumV > ",High," -> ", + "[<<1:1>>,?RT_PER:encode_small_number(EnumV)]"]); +emit_enc_enumerated_case(_Per,_C, {asn1_enum,High}, _) -> + emit([ + "{asn1_enum,EnumV} when is_integer(EnumV), EnumV > ",High," -> ", + "[{bit,1},?RT_PER:encode_small_number(EnumV)]"]); +emit_enc_enumerated_case(_Erule, _C, 'EXT_MARK', _Count) -> + true; +emit_enc_enumerated_case(uper_bin,_C, {1,EnumName}, Count) -> + emit(["'",EnumName,"' -> [<<1:1>>,?RT_PER:encode_small_number(",Count,")]"]); +emit_enc_enumerated_case(_Per,_C, {1,EnumName}, Count) -> + emit(["'",EnumName,"' -> [{bit,1},?RT_PER:encode_small_number(",Count,")]"]); +emit_enc_enumerated_case(uper_bin,C, {0,EnumName}, Count) -> + emit(["'",EnumName,"' -> [<<0:1>>,?RT_PER:encode_integer(",{asis,C},", ",Count,")]"]); +emit_enc_enumerated_case(_Per,C, {0,EnumName}, Count) -> + emit(["'",EnumName,"' -> [{bit,0},?RT_PER:encode_integer(",{asis,C},", ",Count,")]"]); +emit_enc_enumerated_case(_Erule, C, EnumName, Count) -> + emit(["'",EnumName,"' -> ?RT_PER:encode_integer(",{asis,C},", ",Count,")"]). + +%% 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), + greatest_common_range(SV,VR). + +effective_constr(_,[]) -> + []; +effective_constr('SingleValue',List) -> + SVList = lists:flatten(lists:map(fun(X)->element(2,X)end,List)), + % sort and remove duplicates + SortedSVList = lists:sort(SVList), + RemoveDup = fun([],_) ->[]; + ([H],_) -> [H]; + ([H,H|T],F) -> F([H|T],F); + ([H|T],F) -> [H|F(T,F)] + end, + + case RemoveDup(SortedSVList,RemoveDup) of + [N] -> + [{'SingleValue',N}]; + L when is_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(SV,VR) -> + greatest_common_range2(mk_vr(SV),mk_vr(VR)). +greatest_common_range2({_,Int},{'MIN',Ub}) when is_integer(Int), + Int > Ub -> + [{'ValueRange',{'MIN',Int}}]; +greatest_common_range2({_,Int},{Lb,Ub}) when is_integer(Int), + Int < Lb -> + [{'ValueRange',{Int,Ub}}]; +greatest_common_range2({_,Int},VR={_Lb,_Ub}) when is_integer(Int) -> + [{'ValueRange',VR}]; +greatest_common_range2({_,L},{Lb,Ub}) when is_list(L) -> + Min = least_Lb([Lb|L]), + Max = greatest_Ub([Ub|L]), + [{'ValueRange',{Min,Max}}]. + +mk_vr([{Type,I}]) when is_atom(Type), is_integer(I) -> + {I,I}; +mk_vr([{Type,{Lb,Ub}}]) when is_atom(Type) -> + {Lb,Ub}; +mk_vr(Other) -> + Other. + +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. + + +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. + + +%% Object code generating for encoding and decoding +%% ------------------------------------------------ + +gen_obj_code(Erules,_Module,Obj) when is_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(Erules, 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 is_record(Obj,pobjectdef) -> + ok. + + +gen_encode_objectfields(Erule,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("Val"), + case Erule of + uper_bin -> + emit(" Val"); + _ -> + emit(" [{octets,Val}]") + end, + []; + {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(Erule,ClassName,Rest,ObjName,ObjectFields, + MaybeConstr++ConstrAcc); +gen_encode_objectfields(Erule,ClassName,[{objectfield,Name,_,_,OptOrMand}|Rest], + ObjName,ObjectFields,ConstrAcc) -> + CurrentMod = get(currmod), + 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', ",{asis,Name}, + "}})"]); + {false,{'DEFAULT',_DefaultObject}} -> + exit({error,{asn1,{"not implemented yet",Name}}}); + {{Name,#'Externalvaluereference'{module=CurrentMod, + value=TypeName}},_} -> + EmitFuncClause(" Val, [H|T]"), + emit({indent(3),"'enc_",TypeName,"'(H, Val, T)"}); + {{Name,#'Externalvaluereference'{module=M,value=TypeName}},_} -> + EmitFuncClause(" Val, [H|T]"), + emit({indent(3),"'",M,"':'enc_",TypeName,"'(H, Val, T)"}); + {{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(Erule,ClassName,Rest,ObjName,ObjectFields,ConstrAcc); +gen_encode_objectfields(Erule,ClassName,[_C|Cs],O,OF,Acc) -> + gen_encode_objectfields(Erule,ClassName,Cs,O,OF,Acc); +gen_encode_objectfields(_, _,[],_,_,Acc) -> + Acc. + + +gen_encode_constr_type(Erules,[TypeDef|Rest]) when is_record(TypeDef,typedef) -> + case is_already_generated(enc,TypeDef#typedef.name) of + true -> ok; + _ -> +%% FuncName = list_to_atom(lists:concat(["enc_",TypeDef#typedef.name])), + FuncName = asn1ct_gen:list2rname(TypeDef#typedef.name ++ [enc]), + emit(["'",FuncName,"'(Val) ->",nl]), + Def = TypeDef#typedef.typespec, + InnerType = asn1ct_gen:get_inner(Def#type.def), + asn1ct_gen:gen_encode_constructed(Erules,TypeDef#typedef.name, + InnerType,Def), + gen_encode_constr_type(Erules,Rest) + end; +gen_encode_constr_type(_,[]) -> + ok. + +gen_encode_field_call(_ObjName,_FieldName, + #'Externaltypereference'{module=M,type=T}) -> + CurrentMod = get(currmod), + if + M == CurrentMod -> + emit({" 'enc_",T,"'(Val)"}), + []; + true -> + emit({" '",M,"':'enc_",T,"'(Val)"}), + [] + end; +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]))}]; + [Type#typedef{name=[FieldName,ObjName]}]; + {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])), + [#typedef{name=[FieldName,ClassName], + 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("Bytes"), + emit([" {Bytes,[]}"]), + []; + {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) -> + CurrentMod = get(currmod), + 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', ",{asis,Name}, + "}})"]); + {false,{'DEFAULT',_DefaultObject}} -> + exit({error,{asn1,{"not implemented yet",Name}}}); + {{Name,#'Externalvaluereference'{module=CurrentMod, + value=TypeName}},_} -> + EmitFuncClause("Bytes,_,[H|T]"), + emit({indent(3),"'dec_",TypeName,"'(H, Bytes, telltype, T)"}); + {{Name,#'Externalvaluereference'{module=M,value=TypeName}},_} -> + EmitFuncClause("Bytes,_,[H|T]"), + emit({indent(3),"'",M,"':'dec_",TypeName, + "'(H, Bytes, telltype, T)"}); + {{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, + #'Externaltypereference'{module=M,type=T}) -> + CurrentMod = get(currmod), + if + M == CurrentMod -> + emit([" 'dec_",T,"'(",Bytes,", telltype)"]), + []; + true -> + emit([" '",M,"':'dec_",T,"'(",Bytes,", telltype)"]), + [] + end; +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]))}]; + [Type#typedef{name=[FieldName,ObjName]}]; + {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])), + [#typedef{name=[FieldName,ClassName], + 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,[TypeDef|Rest]) when is_record(TypeDef,typedef) -> + case is_already_generated(dec,TypeDef#typedef.name) of + true -> ok; + _ -> + gen_decode(Erules,TypeDef#typedef{name=asn1ct_gen:list2rname(TypeDef#typedef.name)}) + end, + gen_decode_constr_type(Erules,Rest); +gen_decode_constr_type(_,[]) -> + ok. + + +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(Erules,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(Erule,ObjSName,UniqueName,[{ObjName,Val,Fields},T|Rest], + ClName,ClFields,NthObj,Acc)-> + emit({"'getenc_",ObjSName,"'(",{asis,UniqueName},",",{asis,Val}, + ") ->",nl}), + CurrMod = get(currmod), + {InternalFunc,NewNthObj}= + case ObjName of + {no_mod,no_name} -> + gen_inlined_enc_funs(Erule,Fields,ClFields,ObjSName,NthObj); + {CurrMod,Name} -> + emit({" fun 'enc_",Name,"'/3"}), + {[],0}; + {ModName,Name} -> + emit_ext_encfun(ModName,Name), +% emit([" {'",ModName,"', 'enc_",Name,"'}"]), + {[],0}; + _Other -> + emit({" fun 'enc_",ObjName,"'/3"}), + {[],0} + end, + emit({";",nl}), + gen_objset_enc(Erule,ObjSName,UniqueName,[T|Rest],ClName,ClFields, + NewNthObj,InternalFunc ++ Acc); +gen_objset_enc(Erule,ObjSetName,UniqueName, + [{ObjName,Val,Fields}],_ClName,ClFields,NthObj,Acc) -> + + emit({"'getenc_",ObjSetName,"'(",{asis,UniqueName},",", + {asis,Val},") ->",nl}), + CurrMod = get(currmod), + {InternalFunc,_}= + case ObjName of + {no_mod,no_name} -> + gen_inlined_enc_funs(Erule,Fields,ClFields,ObjSetName,NthObj); + {CurrMod,Name} -> + emit({" fun 'enc_",Name,"'/3"}), + {[],NthObj}; + {ModName,Name} -> + emit_ext_encfun(ModName,Name), +% emit([" {'",ModName,"', 'enc_",Name,"'}"]), + {[],NthObj}; + _Other -> + emit({" fun 'enc_",ObjName,"'/3"}), + {[],NthObj} + end, + emit([";",nl]), + emit_default_getenc(ObjSetName,UniqueName), + emit({".",nl,nl}), + InternalFunc++Acc; +gen_objset_enc(Erule,ObjSetName,_UniqueName,['EXTENSIONMARK'],_ClName, + _ClFields,_NthObj,Acc) -> + emit({"'getenc_",ObjSetName,"'(_, _) ->",nl}), + emit({indent(3),"fun(_, Val, _) ->",nl}), + case Erule of + uper_bin -> + emit([indent(6),"Val",nl]); + _ -> + emit([indent(6),"[{octets,Val}]",nl]) + end, + emit({indent(3),"end.",nl,nl}), + Acc; +gen_objset_enc(_,_,_,[],_,_,_,Acc) -> + Acc. + +emit_ext_encfun(ModuleName,Name) -> + emit([indent(4),"fun(T,V,O) -> '",ModuleName,"':'enc_", + Name,"'(T,V,O) end"]). + +emit_default_getenc(ObjSetName,UniqueName) -> + emit(["'getenc_",ObjSetName,"'(",{asis,UniqueName},", ErrV) ->",nl]), + emit([indent(4),"fun(C,V,_) -> exit({'Type not compatible with table constraint',{component,C},{value,V},{unique_name_and_value,",{asis,UniqueName},",ErrV}}) end"]). + + +%% 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(Erule,Fields,[{typefield,Name,_}|Rest],ObjSetName,NthObj) -> + CurrMod = get(currmod), + InternalDefFunName = asn1ct_gen:list2name([NthObj,Name,ObjSetName]), + case lists:keysearch(Name,1,Fields) of + {value,{_,Type}} when is_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(Erule,Fields,Rest,ObjSetName,NthObj+N,Ret); + {value,{_,Type}} when is_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(Erule,Fields,Rest,ObjSetName,NthObj+N,Ret); + {value,{_,#'Externaltypereference'{module=CurrMod,type=T}}} -> + emit({indent(3),"fun(Type, Val, _) ->",nl, + indent(6),"case Type of",nl}), + emit({indent(9),{asis,Name}," ->",nl}), + emit([indent(12),"'enc_",T,"'(Val)"]), +% {Ret,N} = emit_inner_of_fun(TDef,InternalDefFunName), + gen_inlined_enc_funs1(Erule,Fields,Rest,ObjSetName,NthObj,[]); + {value,{_,#'Externaltypereference'{module=M,type=T}}} -> + emit({indent(3),"fun(Type, Val, _) ->",nl, + indent(6),"case Type of",nl}), + emit({indent(9),{asis,Name}," ->",nl}), + emit([indent(12),"'",M,"'",":'enc_",T,"'(Val)"]), + gen_inlined_enc_funs1(Erule,Fields,Rest,ObjSetName,NthObj,[]); + false when Erule == uper_bin -> + emit([indent(3),"fun(Type,Val,_) ->",nl, + indent(6),"case Type of",nl, + indent(9),{asis,Name}," -> Val",nl]), + gen_inlined_enc_funs1(Erule,Fields,Rest,ObjSetName,NthObj,[]); + false -> + emit([indent(3),"fun(Type,Val,_) ->",nl, + indent(6),"case Type of",nl, + indent(9),{asis,Name}," -> [{octets,Val}]",nl]), + gen_inlined_enc_funs1(Erule,Fields,Rest,ObjSetName,NthObj,[]) + end; +gen_inlined_enc_funs(Erule,Fields,[_H|Rest],ObjSetName,NthObj) -> + gen_inlined_enc_funs(Erule,Fields,Rest,ObjSetName,NthObj); +gen_inlined_enc_funs(_,_,[],_,NthObj) -> + {[],NthObj}. + +gen_inlined_enc_funs1(Erule,Fields,[{typefield,Name,_}|Rest],ObjSetName, + NthObj,Acc) -> + CurrentMod = get(currmod), + InternalDefFunName = asn1ct_gen:list2name([NthObj,Name,ObjSetName]), + {Acc2,NAdd}= + case lists:keysearch(Name,1,Fields) of + {value,{_,Type}} when is_record(Type,type) -> + emit({";",nl}), + {Ret,N}=emit_inner_of_fun(Type,InternalDefFunName), + {Ret++Acc,N}; + {value,{_,Type}} when is_record(Type,typedef) -> + emit({";",nl,indent(9),{asis,Name}," ->",nl}), + {Ret,N}=emit_inner_of_fun(Type,InternalDefFunName), + {Ret++Acc,N}; + {value,{_,#'Externaltypereference'{module=CurrentMod,type=T}}} -> + emit({";",nl,indent(9),{asis,Name}," ->",nl}), + emit([indent(12),"'enc_",T,"'(Val)"]), + {Acc,0}; + {value,{_,#'Externaltypereference'{module=M,type=T}}} -> + emit({";",nl,indent(9),{asis,Name}," ->",nl}), + emit([indent(12),"'",M,"'",":'enc_",T,"'(Val)"]), + {Acc,0}; + false when Erule == uper_bin -> + emit([";",nl, + indent(9),{asis,Name}," -> ",nl, + "Val",nl]), + {Acc,0}; + false -> + emit([";",nl, + indent(9),{asis,Name}," -> ",nl, + "[{octets,Val}]",nl]), + {Acc,0} + end, + gen_inlined_enc_funs1(Erule,Fields,Rest,ObjSetName,NthObj+NAdd,Acc2); +gen_inlined_enc_funs1(Erule,Fields,[_H|Rest],ObjSetName,NthObj,Acc)-> + gen_inlined_enc_funs1(Erule,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 is_record(Type,type) -> + CurrMod = get(currmod), + case Type#type.def of + Def when is_atom(Def) -> + emit({indent(9),Def," ->",nl,indent(12)}), + gen_encode_prim(erules,Type,dotag,"Val"); + TRef when is_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}), + CurrMod = get(currmod), + NewNthObj= + case ObjName of + {no_mod,no_name} -> + gen_inlined_dec_funs(Fields,ClFields,ObjSName,NthObj); + {CurrMod,Name} -> + emit([" fun 'dec_",Name,"'/4"]), + NthObj; + {ModName,Name} -> + emit_ext_decfun(ModName,Name), +% emit([" {'",ModName,"', 'dec_",Name,"'}"]), + 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}), + CurrMod=get(currmod), + case ObjName of + {no_mod,no_name} -> + gen_inlined_dec_funs(Fields,ClFields,ObjSetName,NthObj); + {CurrMod,Name} -> + emit([" fun 'dec_",Name,"'/4"]); + {ModName,Name} -> + emit_ext_decfun(ModName,Name); +% emit([" {'",ModName,"', 'dec_",Name,"'}"]); + _Other -> + emit({" fun 'dec_",ObjName,"'/4"}) + end, + emit([";",nl]), + emit_default_getdec(ObjSetName,UniqueName), + 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. + +emit_ext_decfun(ModuleName,Name) -> + emit([indent(3),"fun(T,V,O1,O2) -> '",ModuleName,"':'dec_", + Name,"'(T,V,O1,O2) end"]). + +emit_default_getdec(ObjSetName,UniqueName) -> + emit(["'getdec_",ObjSetName,"'(",{asis,UniqueName},", ErrV) ->",nl]), + emit([indent(2), "fun(C,V,_,_) -> exit({{component,C},{value,V},{unique_name_and_value,",{asis,UniqueName},",ErrV}}) end"]). + + +gen_inlined_dec_funs(Fields,[{typefield,Name,_}|Rest], + ObjSetName,NthObj) -> + CurrMod = get(currmod), + InternalDefFunName = [NthObj,Name,ObjSetName], + case lists:keysearch(Name,1,Fields) of + {value,{_,Type}} when is_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 is_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); + {value,{_,#'Externaltypereference'{module=CurrMod,type=T}}} -> + emit({indent(3),"fun(Type, Val, _, _) ->",nl, + indent(6),"case Type of",nl}), + emit({indent(9),{asis,Name}," ->",nl}), + emit([indent(12),"'dec_",T,"'(Val, telltype)"]), + gen_inlined_dec_funs1(Fields,Rest,ObjSetName,NthObj); + {value,{_,#'Externaltypereference'{module=M,type=T}}} -> + emit({indent(3),"fun(Type, Val, _, _) ->",nl, + indent(6),"case Type of",nl}), + emit({indent(9),{asis,Name}," ->",nl}), + emit([indent(12),"'",M,"':'dec_",T,"'(Val, telltype)"]), + gen_inlined_dec_funs1(Fields,Rest,ObjSetName,NthObj); + false -> + emit([indent(3),"fun(Type, Val, _, _) ->",nl, + indent(6),"case Type of",nl, + indent(9),{asis,Name}," ->{Val,Type}"]), + gen_inlined_dec_funs1(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) -> + CurrentMod = get(currmod), + InternalDefFunName = [NthObj,Name,ObjSetName], + N=case lists:keysearch(Name,1,Fields) of + {value,{_,Type}} when is_record(Type,type) -> + emit({";",nl}), + emit_inner_of_decfun(Type,InternalDefFunName); + {value,{_,Type}} when is_record(Type,typedef) -> + emit({";",nl,indent(9),{asis,Name}," ->",nl}), + emit_inner_of_decfun(Type,InternalDefFunName); + {value,{_,#'Externaltypereference'{module=CurrentMod,type=T}}} -> + emit([";",nl,indent(9),{asis,Name}," ->",nl]), + emit([indent(12),"'dec_",T,"'(Val,telltype)"]), + 0; + {value,{_,#'Externaltypereference'{module=M,type=T}}} -> + emit([";",nl,indent(9),{asis,Name}," ->",nl]), + emit([indent(12),"'",M,"'",":'dec_",T,"'(Val,telltype)"]), + 0; + false -> + emit([";",nl, + indent(9),{asis,Name}," ->{Val,Type}"]), + 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 is_record(Type,type) -> + CurrMod = get(currmod), + case Type#type.def of + Def when is_atom(Def) -> + emit({indent(9),Def," ->",nl,indent(12)}), + gen_dec_prim(erules,Type,"Val"); + TRef when is_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 is_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 is_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 is_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 is_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,effective_constraint(integer,Constraint)},")"}); + {'INTEGER',NamedNumberList} -> + emit({"?RT_PER:decode_integer(",BytesVar,",", + {asis,effective_constraint(integer,Constraint)},",", + {asis,NamedNumberList},")"}); + + 'REAL' -> + emit({"?RT_PER:decode_real(",BytesVar,")"}); + + {'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,")"}); + 'RELATIVE-OID' -> + emit({"?RT_PER:decode_relative_oid(", + 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},")"}); + TString when TString == 'TeletexString'; + TString == 'T61String' -> + 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},")"}); + 'UTF8String' -> + emit({"?RT_PER:decode_UTF8String(",BytesVar,")"}); + 'ANY' -> + case Erules of + per -> + emit(["fun() -> {XTerm,YTermXBytes} = ?RT_PER:decode_open_type(",BytesVar,",",{asis,Constraint}, "), {binary_to_list(XTerm),XBytes} end ()"]); + _ -> + emit(["?RT_PER:decode_open_type(",BytesVar,",", + {asis,Constraint}, ")"]) + end; + '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,")"]); + _ -> + case Erules of + per -> + emit(["fun() -> {XTerm,XBytes} = ?RT_PER:decode_open_type(",BytesVar,", []), {binary_to_list(XTerm),XBytes} end()"]); + _ -> + emit(["?RT_PER:decode_open_type(",BytesVar,",[])"]) + end + end; + #'ObjectClassFieldType'{} -> + case asn1ct_gen:get_inner(Att#type.def) of + {fixedtypevaluefield,_,InnerType} -> + gen_dec_prim(Erules,InnerType,BytesVar); + T -> + gen_dec_prim(Erules,Att#type{def=T},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/asn1/src/asn1ct_gen_per_rt2ct.erl b/lib/asn1/src/asn1ct_gen_per_rt2ct.erl new file mode 100644 index 0000000000..56f895828a --- /dev/null +++ b/lib/asn1/src/asn1ct_gen_per_rt2ct.erl @@ -0,0 +1,1798 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2002-2009. All Rights Reserved. +%% +%% 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 online 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. +%% +%% %CopyrightEnd% +%% +%% +-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 is_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 is_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 is_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 is_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(Erules,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(Erules,EffectiveConstr,Value,NamedNumberList); + {'ENUMERATED',{Nlist1,Nlist2}} -> + NewList = lists:append([[{0,X}||{X,_} <- Nlist1],['EXT_MARK'],[{1,X}||{X,_} <- Nlist2]]), + NewC = [{'ValueRange',{0,length(Nlist1)-1}}], + emit(["case ",Value," of",nl]), +%% emit_enc_enumerated_cases(Erules,NewC, NewList++[{asn1_enum,length(Nlist1)-1}], 0); + emit_enc_enumerated_cases(Erules,NewC, NewList, 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(Erules,NewC,NewVal); + + 'REAL' -> + emit({"?RT_PER:encode_real(",Value,")"}); + + {'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,")"}); + 'RELATIVE-OID' -> + emit({"?RT_PER:encode_relative_oid(",Value,")"}); + 'ObjectDescriptor' -> + emit({"?RT_PER:encode_ObjectDescriptor(",{asis,Constraint}, + ",",Value,")"}); + 'BOOLEAN' -> + emit({"case ",Value," of",nl, + " true -> [1];",nl, + " false -> [0];",nl, + " _ -> exit({error,{asn1,{encode_boolean,",Value,"}}})",nl, + "end"}); + 'OCTET STRING' -> + emit_enc_octet_string(Erules,Constraint,Value); + + 'NumericString' -> + emit_enc_known_multiplier_string('NumericString',Constraint,Value); + TString when TString == 'TeletexString'; + TString == 'T61String' -> + 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); + 'UTF8String' -> + emit({"?RT_PER:encode_UTF8String(",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, ")"]); + #'ObjectClassFieldType'{} -> + case asn1ct_gen:get_inner(D#type.def) of + {fixedtypevaluefield,_,InnerType} -> + gen_encode_prim(Erules,InnerType,DoTag,Value); + T -> %% 'ASN1_OPEN_TYPE' + gen_encode_prim(Erules,D#type{def=T},DoTag,Value) + end; + XX -> + exit({asn1_error,nyi,XX}) + end. + +emit_enc_known_multiplier_string(StringType,C,Value) -> + SizeC = + case get_constraint(C,'SizeConstraint') of + L when is_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 is_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(_Erules,Constraint,Value) -> + case get_constraint(Constraint,'SizeConstraint') of + 0 -> + emit({" []"}); + 1 -> + asn1ct_name:new(tmpval), + emit({" begin",nl}), + emit({" [",{curr,tmpval},"] = ",Value,",",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({" [[10,8,",{curr,tmpval},"],[10,8,", + {next,tmpval},"]]",nl}), + emit(" end"), + asn1ct_name:new(tmpval); + Sv when is_integer(Sv),Sv =< 256 -> + asn1ct_name:new(tmpval), + emit({" begin",nl}), + emit({" case length(",Value,") of",nl}), + emit([" ",{curr,tmpval}," when ",{curr,tmpval}," == ",Sv," ->"]), + emit([" [2,20,",{curr,tmpval},",",Value,"];",nl]), + emit({" _ -> exit({error,{value_out_of_bounds,", + Value,"}})", nl," end",nl}), + emit(" end"); + Sv when is_integer(Sv),Sv =< 65535 -> + asn1ct_name:new(tmpval), + emit({" begin",nl}), + emit({" case length(",Value,") of",nl}), + emit([" ",{curr,tmpval}," when ",{curr,tmpval}," == ",Sv," ->"]), + emit([" [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'; + is_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(Erules,C,Value,NNL) -> + EncVal = enc_integer_NNL_cases(Value,NNL), + emit_enc_integer(Erules,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 is_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(_Erule,[{'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(_Erule,[{_,{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(_Erule,[{_,{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(_Erule,[{_,{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(_Erule,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(Erule, C, [H], Count) -> + emit_enc_enumerated_case(Erule, C, H, Count), + case H of + 'EXT_MARK' -> + ok; + _ -> + emit([";",nl]) + end, + emit([nl,"EnumVal -> exit({error,{asn1, {enumerated_not_in_range, EnumVal}}})"]), + emit([nl,"end"]); +emit_enc_enumerated_cases(Erule, C, ['EXT_MARK'|T], _Count) -> + emit_enc_enumerated_cases(Erule, C, T, 0); +emit_enc_enumerated_cases(Erule, C, [H1,H2|T], Count) -> + emit_enc_enumerated_case(Erule, C, H1, Count), + emit([";",nl]), + emit_enc_enumerated_cases(Erule, 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(_Erule,_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 is_integer(EnumV), EnumV > ",High," -> ", +%% "[1,?RT_PER:encode_small_number(EnumV)]"]); +emit_enc_enumerated_case(_Erule,_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(_Erule,C, {0,EnumName}, Count) -> + %% ENUMERATED with extensionmark + %% values within extension root +%% emit(["'",EnumName,"' -> [0,?RT_PER:encode_integer(",{asis,C},", ",Count,")]"]); + emit(["'",EnumName,"' -> ",{asis,[0|asn1rt_per_bin_rt2ct:encode_integer(C,Count)]}]); +emit_enc_enumerated_case(_Erule, _C, 'EXT_MARK', _Count) -> + true. +%% %% This clause is invoked in case of an ENUMERATED without extension mark +%% emit_enc_enumerated_case(_Erule,_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) -> + get_constraint(C,'SizeConstraint'). + +effective_constr(_,[]) -> + []; +effective_constr('SingleValue',List) -> + SVList = lists:flatten(lists:map(fun(X)->element(2,X)end,List)), + % sort and remove duplicates + RemoveDup = fun([],_) ->[]; + ([H],_) -> [H]; + ([H,H|T],F) -> F([H|T],F); + ([H|T],F) -> [H|F(T,F)] + end, + + case RemoveDup(SVList,RemoveDup) of + [N] -> + [{'SingleValue',N}]; + L when is_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 is_integer(Int), + Int > Ub -> + [{'ValueRange',{'MIN',Int}}]; +greatest_common_range([{_,Int}],[{_,{Lb,Ub}}]) when is_integer(Int), + Int < Lb -> + [{'ValueRange',{Int,Ub}}]; +greatest_common_range([{_,Int}],VR=[{_,{_Lb,_Ub}}]) when is_integer(Int) -> + VR; +greatest_common_range([{_,L}],[{_,{Lb,Ub}}]) when is_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. + + + + +pre_encode(integer,[]) -> + []; +pre_encode(integer,C=[{'SingleValue',_}]) -> + C; +pre_encode(integer,C=[{'ValueRange',VR={Lb,Ub}}]) when is_integer(Lb),is_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 is_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(Erules,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(_Erules,_Module,Obj) when is_record(Obj,pobjectdef) -> + ok. + +gen_encode_objectfields(Erules,ClassName,[{typefield,Name,OptOrMand}|Rest], + ObjName,ObjectFields,ConstrAcc) -> + EmitFuncClause = + fun(V) -> + emit(["'enc_",ObjName,"'(",{asis,Name}, + ",",V,",_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("Val"), + emit([" if",nl, + " is_list(Val) ->",nl, + " NewVal = list_to_binary(Val),",nl, + " [20,size(NewVal),NewVal];",nl, + " is_binary(Val) ->",nl, + " [20,size(Val),Val]",nl, + " end"]), + []; + {false,{'DEFAULT',DefaultType}} -> + EmitFuncClause("Val"), + gen_encode_default_call(Erules,ClassName,Name,DefaultType); + {{Name,TypeSpec},_} -> + %% A specified field owerwrites any 'DEFAULT' or + %% 'OPTIONAL' field in the class + EmitFuncClause("Val"), + gen_encode_field_call(Erules,ObjName,Name,TypeSpec) + end, + case more_genfields(Rest) of + true -> + emit([";",nl]); + false -> + emit([".",nl]) + end, + gen_encode_objectfields(Erules,ClassName,Rest,ObjName,ObjectFields, + MaybeConstr++ConstrAcc); +gen_encode_objectfields(Erules,ClassName,[{objectfield,Name,_,_,OptOrMand}|Rest], + ObjName,ObjectFields,ConstrAcc) -> + CurrentMod = get(currmod), + 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', ",{asis,Name}, + "}})"]); + {false,{'DEFAULT',_DefaultObject}} -> + exit({error,{asn1,{"not implemented yet",Name}}}); + {{Name,#'Externalvaluereference'{module=CurrentMod, + value=TypeName}},_} -> + EmitFuncClause(" Val, [H|T]"), + emit({indent(3),"'enc_",TypeName,"'(H, Val, T)"}); + {{Name,#'Externalvaluereference'{module=M,value=TypeName}},_} -> + EmitFuncClause(" Val, [H|T]"), + emit({indent(3),"'",M,"':'enc_",TypeName,"'(H, Val, T)"}); + {{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(Erules,ClassName,Rest,ObjName,ObjectFields,ConstrAcc); +gen_encode_objectfields(Erules,ClassName,[_C|Cs],O,OF,Acc) -> + gen_encode_objectfields(Erules,ClassName,Cs,O,OF,Acc); +gen_encode_objectfields(_Erules,_,[],_,_,Acc) -> + Acc. + + + +gen_encode_constr_type(Erules,[TypeDef|Rest]) when is_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(_Erule,_ObjName,_FieldName, + #'Externaltypereference'{module=M,type=T}) -> + CurrentMod = get(currmod), + if + M == CurrentMod -> + emit({" 'enc_",T,"'(Val)"}), + []; + true -> + emit({" '",M,"':'enc_",T,"'(Val)"}), + [] + end; +gen_encode_field_call(Erule,ObjName,FieldName,Type) -> + Def = Type#typedef.typespec, + case Type#typedef.name of + {primitive,bif} -> + gen_encode_prim(Erule,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(Erules,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(Erules,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("Bytes"), + emit([" {Bytes,[]}"]), + []; + {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) -> + CurrentMod = get(currmod), + 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', ",{asis,Name}, + "}})"]); + {false,{'DEFAULT',_DefaultObject}} -> + exit({error,{asn1,{"not implemented yet",Name}}}); + {{Name,#'Externalvaluereference'{module=CurrentMod, + value=TypeName}},_} -> + EmitFuncClause("Bytes,_,[H|T]"), + emit({indent(3),"'dec_",TypeName,"'(H, Bytes, telltype, T)"}); + {{Name,#'Externalvaluereference'{module=M,value=TypeName}},_} -> + EmitFuncClause("Bytes,_,[H|T]"), + emit({indent(3),"'",M,"':'dec_",TypeName, + "'(H, Bytes, telltype, T)"}); + {{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, + #'Externaltypereference'{module=M,type=T}) -> + CurrentMod = get(currmod), + if + M == CurrentMod -> + emit([" 'dec_",T,"'(",Bytes,", telltype)"]), + []; + true -> + emit([" '",M,"':'dec_",T,"'(",Bytes,", telltype)"]), + [] + end; +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,[TypeDef|Rest]) when is_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. + +%% 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(Erule,ObjSetName,UniqueFName,Set,ClassName,ClassDef)-> + ClassFields = (ClassDef#classdef.typespec)#objectclass.fields, + InternalFuncs= + gen_objset_enc(Erule,ObjSetName,UniqueFName,Set,ClassName, + ClassFields,1,[]), + gen_objset_dec(ObjSetName,UniqueFName,Set,ClassName,ClassFields,1), + gen_internal_funcs(Erule,InternalFuncs). + +gen_objset_enc(_Erule,_,{unique,undefined},_,_,_,_,_) -> + %% There is no unique field in the class of this object set + %% don't bother about the constraint + []; +gen_objset_enc(Erule,ObjSName,UniqueName,[{ObjName,Val,Fields},T|Rest], + ClName,ClFields,NthObj,Acc)-> + emit({"'getenc_",ObjSName,"'(",{asis,UniqueName},",", + {asis,Val},") ->",nl}), + CurrMod = get(currmod), + {InternalFunc,NewNthObj}= + case ObjName of + {no_mod,no_name} -> + gen_inlined_enc_funs(Erule,Fields,ClFields,ObjSName,NthObj); + {CurrMod,Name} -> + emit({" fun 'enc_",Name,"'/3"}), + {[],NthObj}; + {ModName,Name} -> + emit_ext_encfun(ModName,Name), +% emit([" {'",ModName,"', 'enc_",Name,"'}"]), + {[],NthObj}; + _ -> + emit({" fun 'enc_",ObjName,"'/3"}), + {[],NthObj} + end, + emit({";",nl}), + gen_objset_enc(Erule,ObjSName,UniqueName,[T|Rest],ClName,ClFields, + NewNthObj,InternalFunc++Acc); +gen_objset_enc(Erule,ObjSetName,UniqueName, + [{ObjName,Val,Fields}],_ClName,ClFields,NthObj,Acc) -> + + emit({"'getenc_",ObjSetName,"'(",{asis,UniqueName},",", + {asis,Val},") ->",nl}), + CurrMod = get(currmod), + {InternalFunc,_}= + case ObjName of + {no_mod,no_name} -> + gen_inlined_enc_funs(Erule,Fields,ClFields,ObjSetName,NthObj); + {CurrMod,Name} -> + emit({" fun 'enc_",Name,"'/3"}), + {[],NthObj}; + {ModName,Name} -> + emit_ext_encfun(ModName,Name), +% emit([" {'",ModName,"', 'enc_",Name,"'}"]), + {[],NthObj}; + _ -> + emit({" fun 'enc_",ObjName,"'/3"}), + {[],NthObj} + end, + emit([";",nl]), + emit_default_getenc(ObjSetName,UniqueName), + emit({".",nl,nl}), + InternalFunc++Acc; +gen_objset_enc(_Erule,ObjSetName,_UniqueName,['EXTENSIONMARK'],_ClName, + _ClFields,_NthObj,Acc) -> + emit({"'getenc_",ObjSetName,"'(_, _) ->",nl}), + emit({indent(3),"fun(_, Val, _) ->",nl}), + emit({indent(6),"BinVal = if",nl}), + emit({indent(9),"is_list(Val) -> list_to_binary(Val);",nl}), + emit({indent(9),"true -> Val",nl}), + emit({indent(6),"end,",nl}), + emit({indent(6),"Size = size(BinVal),",nl}), + emit({indent(6),"if",nl}), + emit({indent(9),"Size < 256 ->",nl}), + emit({indent(12),"[20,Size,BinVal];",nl}), + emit({indent(9),"true ->",nl}), + emit({indent(12),"[21,<>,Val]",nl}), + emit({indent(6),"end",nl}), + emit({indent(3),"end.",nl,nl}), + Acc; +gen_objset_enc(_Erule,_,_,[],_,_,_,Acc) -> + Acc. + +emit_ext_encfun(ModuleName,Name) -> + emit([indent(4),"fun(T,V,O) -> '",ModuleName,"':'enc_", + Name,"'(T,V,O) end"]). + +emit_default_getenc(ObjSetName,UniqueName) -> + emit(["'getenc_",ObjSetName,"'(",{asis,UniqueName},", ErrV) ->",nl]), + emit([indent(4),"fun(C,V,_) -> exit({'Type not compatible with table constraint',{component,C},{value,V},{unique_name_and_value,",{asis,UniqueName},",ErrV}}) end"]). + + +%% 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(Erule,Fields,[{typefield,Name,_}|Rest],ObjSetName,NthObj) -> + CurrMod = get(currmod), + InternalDefFunName=asn1ct_gen:list2name([NthObj,Name,ObjSetName]), + case lists:keysearch(Name,1,Fields) of + {value,{_,Type}} when is_record(Type,type) -> + emit({indent(3),"fun(Type, Val, _) ->",nl, + indent(6),"case Type of",nl}), + {Ret,N}=emit_inner_of_fun(Erule,Type,InternalDefFunName), + gen_inlined_enc_funs1(Erule,Fields,Rest,ObjSetName,NthObj+N,Ret); + {value,{_,Type}} when is_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(Erule,Type,InternalDefFunName), + gen_inlined_enc_funs1(Erule,Fields,Rest,ObjSetName,NthObj+N,Ret); + {value,{_,#'Externaltypereference'{module=CurrMod,type=T}}} -> + emit({indent(3),"fun(Type, Val, _) ->",nl, + indent(6),"case Type of",nl}), + emit({indent(9),{asis,Name}," ->",nl}), + emit([indent(12),"'enc_",T,"'(Val)"]), +% {Ret,N} = emit_inner_of_fun(Erule,TDef,InternalDefFunName), + gen_inlined_enc_funs1(Erule,Fields,Rest,ObjSetName,NthObj,[]); + {value,{_,#'Externaltypereference'{module=M,type=T}}} -> + emit({indent(3),"fun(Type, Val, _) ->",nl, + indent(6),"case Type of",nl}), + emit({indent(9),{asis,Name}," ->",nl}), + emit([indent(12),"'",M,"'",":'enc_",T,"'(Val)"]), + gen_inlined_enc_funs1(Erule,Fields,Rest,ObjSetName,NthObj,[]); + false -> + emit([indent(3),"fun(Type, Val, _) ->",nl, + indent(6),"case Type of",nl, + indent(9),{asis,Name}," ->",nl, + indent(12),"Size = case Val of",nl, + indent(15),"B when is_binary(B) -> size(B);",nl, + indent(15),"_ -> length(Val)",nl, + indent(12),"end,",nl, + indent(12),"if",nl, + indent(15),"Size < 256 -> [20,Size,Val];",nl, + indent(15),"true -> [21,<>,Val]",nl, + indent(12),"end"]), + gen_inlined_enc_funs1(Erule,Fields,Rest,ObjSetName,NthObj,[]) + end; +gen_inlined_enc_funs(Erule,Fields,[_|Rest],ObjSetName,NthObj) -> + gen_inlined_enc_funs(Erule,Fields,Rest,ObjSetName,NthObj); +gen_inlined_enc_funs(_Erule,_,[],_,NthObj) -> + {[],NthObj}. + +gen_inlined_enc_funs1(Erule,Fields,[{typefield,Name,_}|Rest],ObjSetName, + NthObj,Acc) -> + CurrentMod = get(currmod), + InternalDefFunName = asn1ct_gen:list2name([NthObj,Name,ObjSetName]), + {Acc2,NAdd}= + case lists:keysearch(Name,1,Fields) of + {value,{_,Type}} when is_record(Type,type) -> + emit({";",nl}), + {Ret,N}=emit_inner_of_fun(Erule,Type,InternalDefFunName), + {Ret++Acc,N}; + {value,{_,Type}} when is_record(Type,typedef) -> + emit({";",nl,indent(9),{asis,Name}," ->",nl}), + {Ret,N}=emit_inner_of_fun(Erule,Type,InternalDefFunName), + {Ret++Acc,N}; + {value,{_,#'Externaltypereference'{module=CurrentMod,type=T}}} -> + emit({";",nl,indent(9),{asis,Name}," ->",nl}), + emit([indent(12),"'enc_",T,"'(Val)"]), + {Acc,0}; + {value,{_,#'Externaltypereference'{module=M,type=T}}} -> + emit({";",nl,indent(9),{asis,Name}," ->",nl}), + emit([indent(12),"'",M,"'",":'enc_",T,"'(Val)"]), + {Acc,0}; + false -> + emit([";",nl, + indent(9),{asis,Name}," ->",nl, + indent(12),"Size = case Val of",nl, + indent(15),"B when is_binary(B) -> size(B);",nl, + indent(15),"_ -> length(Val)",nl, + indent(12),"end,",nl, + indent(12),"if",nl, + indent(15),"Size < 256 -> [20,Size,Val];",nl, + indent(15),"true -> [21,<>,Val]",nl, + indent(12),"end"]), + {Acc,0} + end, + gen_inlined_enc_funs1(Erule,Fields,Rest,ObjSetName,NthObj+NAdd,Acc2); +gen_inlined_enc_funs1(Erule,Fields,[_|Rest],ObjSetName,NthObj,Acc)-> + gen_inlined_enc_funs1(Erule,Fields,Rest,ObjSetName,NthObj,Acc); +gen_inlined_enc_funs1(_Erule,_,[],_,NthObj,Acc) -> + emit({nl,indent(6),"end",nl}), + emit({indent(3),"end"}), + {Acc,NthObj}. + +emit_inner_of_fun(Erule,TDef=#typedef{name={ExtMod,Name},typespec=Type}, + InternalDefFunName) -> + case {ExtMod,Name} of + {primitive,bif} -> + emit(indent(12)), + gen_encode_prim(Erule,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(_Erule,#typedef{name=Name},_) -> + emit({indent(12),"'enc_",Name,"'(Val)"}), + {[],0}; +emit_inner_of_fun(Erule,Type,_) when is_record(Type,type) -> + CurrMod = get(currmod), + case Type#type.def of + Def when is_atom(Def) -> + emit({indent(9),Def," ->",nl,indent(12)}), + gen_encode_prim(Erule,Type,dotag,"Val"); + TRef when is_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}), + CurrMod = get(currmod), + NewNthObj= + case ObjName of + {no_mod,no_name} -> + gen_inlined_dec_funs(Fields,ClFields,ObjSName,NthObj); + {CurrMod,Name} -> + emit([" fun 'dec_",Name,"'/4"]), + NthObj; + {ModName,Name} -> + emit_ext_decfun(ModName,Name), +% emit([" {'",ModName,"', 'dec_",Name,"'}"]), + 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}), + CurrMod=get(currmod), + case ObjName of + {no_mod,no_name} -> + gen_inlined_dec_funs(Fields,ClFields,ObjSetName,NthObj); + {CurrMod,Name} -> + emit([" fun 'dec_",Name,"'/4"]); + {ModName,Name} -> + emit_ext_decfun(ModName,Name); +% emit([" {'",ModName,"', 'dec_",Name,"'}"]); + _ -> + emit({" fun 'dec_",ObjName,"'/4"}) + end, + emit([";",nl]), + emit_default_getdec(ObjSetName,UniqueName), + 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. + +emit_ext_decfun(ModuleName,Name) -> + emit([indent(3),"fun(T,V,O1,O2) -> '",ModuleName,"':'dec_", + Name,"'(T,V,O1,O2) end"]). + +emit_default_getdec(ObjSetName,UniqueName) -> + emit(["'getdec_",ObjSetName,"'(",{asis,UniqueName},", ErrV) ->",nl]), + emit([indent(2), "fun(C,V,_,_) -> exit({{component,C},{value,V},{unique_name_and_value,",{asis,UniqueName},",ErrV}}) end"]). + + +gen_inlined_dec_funs(Fields,[{typefield,Name,_}|Rest], + ObjSetName,NthObj) -> + CurrMod = get(currmod), + InternalDefFunName = [NthObj,Name,ObjSetName], + case lists:keysearch(Name,1,Fields) of + {value,{_,Type}} when is_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 is_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); + {value,{_,#'Externaltypereference'{module=CurrMod,type=T}}} -> + emit({indent(3),"fun(Type, Val, _, _) ->",nl, + indent(6),"case Type of",nl}), + emit({indent(9),{asis,Name}," ->",nl}), + emit([indent(12),"'dec_",T,"'(Val, telltype)"]), + gen_inlined_dec_funs1(Fields,Rest,ObjSetName,NthObj); + {value,{_,#'Externaltypereference'{module=M,type=T}}} -> + emit({indent(3),"fun(Type, Val, _, _) ->",nl, + indent(6),"case Type of",nl}), + emit({indent(9),{asis,Name}," ->",nl}), + emit([indent(12),"'",M,"':'dec_",T,"'(Val, telltype)"]), + gen_inlined_dec_funs1(Fields,Rest,ObjSetName,NthObj); + false -> + emit([indent(3),"fun(Type, Val, _, _) ->",nl, + indent(6),"case Type of",nl, + indent(9),{asis,Name}," -> {Val,Type}"]), + gen_inlined_dec_funs1(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) -> + CurrentMod = get(currmod), + InternalDefFunName = [NthObj,Name,ObjSetName], + N= + case lists:keysearch(Name,1,Fields) of + {value,{_,Type}} when is_record(Type,type) -> + emit({";",nl}), + emit_inner_of_decfun(Type,InternalDefFunName); + {value,{_,Type}} when is_record(Type,typedef) -> + emit({";",nl,indent(9),{asis,Name}," ->",nl}), + emit_inner_of_decfun(Type,InternalDefFunName); + {value,{_,#'Externaltypereference'{module=CurrentMod,type=T}}} -> + emit([";",nl,indent(9),{asis,Name}," ->",nl]), + emit([indent(12),"'dec_",T,"'(Val,telltype)"]), + 0; + {value,{_,#'Externaltypereference'{module=M,type=T}}} -> + emit([";",nl,indent(9),{asis,Name}," ->",nl]), + emit([indent(12),"'",M,"':'dec_",T,"'(Val,telltype)"]), + 0; + false -> + emit([";",nl, + indent(9),{asis,Name}," -> {Val,Type}"]), + 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 is_record(Type,type) -> + CurrMod = get(currmod), + case Type#type.def of + Def when is_atom(Def) -> + emit({indent(9),Def," ->",nl,indent(12)}), + gen_dec_prim(erules,Type,"Val"); + TRef when is_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 is_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 is_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 is_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 is_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},")"}); + + 'REAL' -> + emit(["?RT_PER:decode_real(",BytesVar,")"]); + + {'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,")"}); + 'RELATIVE-OID' -> + emit({"?RT_PER:decode_relative_oid(", + 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} -> + NewNNL = [X||{X,_} <- NamedNumberList], + NewC = effective_constraint(integer, + [{'ValueRange',{0,length(NewNNL)-1}}]), + emit_dec_enumerated(BytesVar,NewC,NewNNL); + 'BOOLEAN'-> + emit({"?RT_PER:decode_boolean(",BytesVar,")"}); + + 'OCTET STRING' -> + emit_dec_octet_string(Constraint,BytesVar); + + 'NumericString' -> + emit_dec_known_multiplier_string('NumericString', + Constraint,BytesVar); + TString when TString == 'TeletexString'; + TString == 'T61String' -> + 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); + 'GeneralizedTime' -> + emit_dec_known_multiplier_string('VisibleString', + Constraint,BytesVar); + 'GraphicString' -> + emit({"?RT_PER:decode_GraphicString(",BytesVar,",", + {asis,Constraint},")"}); + + 'VisibleString' -> + emit_dec_known_multiplier_string('VisibleString', + Constraint,BytesVar); + 'GeneralString' -> + emit({"?RT_PER:decode_GeneralString(",BytesVar,",", + {asis,Constraint},")"}); + + 'PrintableString' -> + emit_dec_known_multiplier_string('PrintableString', + Constraint,BytesVar); + 'IA5String' -> + emit_dec_known_multiplier_string('IA5String',Constraint,BytesVar); + + 'BMPString' -> + emit_dec_known_multiplier_string('BMPString',Constraint,BytesVar); + + 'UniversalString' -> + emit_dec_known_multiplier_string('UniversalString', + Constraint,BytesVar); + + 'UTF8String' -> + emit({"?RT_PER:decode_UTF8String(",BytesVar,")"}); + '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; + #'ObjectClassFieldType'{} -> + case asn1ct_gen:get_inner(Att#type.def) of + {fixedtypevaluefield,_,InnerType} -> + gen_dec_prim(Erules,InnerType,BytesVar); + T -> + gen_dec_prim(Erules,Att#type{def=T},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 is_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 is_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,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([Name|Rest],Tmpremain,No) -> + io_lib:format("~w->{~w,~s};",[No,Name,Tmpremain])++ + dec_enumerated_cases(Rest,Tmpremain,No+1); +dec_enumerated_cases([],_,_) -> + "". diff --git a/lib/asn1/src/asn1ct_name.erl b/lib/asn1/src/asn1ct_name.erl new file mode 100644 index 0000000000..a6aa4255cc --- /dev/null +++ b/lib/asn1/src/asn1ct_name.erl @@ -0,0 +1,233 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1997-2009. All Rights Reserved. +%% +%% 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 online 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. +%% +%% %CopyrightEnd% +%% +%% +-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} -> + unregister(asn1_ns), + 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 -> + case catch register(Name, spawn(Mod,Fun, Args)) of + {'EXIT',{badarg,_}} -> + start_server(Name,Mod,Fun,Args); + _ -> + ok + end; + _Pid -> + already_started + end. diff --git a/lib/asn1/src/asn1ct_parser.yrl b/lib/asn1/src/asn1ct_parser.yrl new file mode 100644 index 0000000000..083162f191 --- /dev/null +++ b/lib/asn1/src/asn1ct_parser.yrl @@ -0,0 +1,1177 @@ +%% +%% 1997-2008 +%% Ericsson AB, All Rights Reserved +%% +%% +%% 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 online 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 AB. +%% +%% +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('kenneth@erix.ericsson.se'). +-copyright('Copyright (c) 1991-99 Ericsson Telecom AB'). +-vsn('$Revision: /main/release/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/asn1/src/asn1ct_parser2.erl b/lib/asn1/src/asn1ct_parser2.erl new file mode 100644 index 0000000000..9d2df72f5b --- /dev/null +++ b/lib/asn1/src/asn1ct_parser2.erl @@ -0,0 +1,3063 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2000-2009. All Rights Reserved. +%% +%% 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 online 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. +%% +%% %CopyrightEnd% +%% +%% +-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},{'{',_L2},{'}',_L3}|Rest]) -> + {identifier2Extvalueref(Vref),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 is_record(Sl,'SymbolsFromModule') -> + parse_SymbolsFromModuleList(Rest,[SymbolsFromModule|Acc]); + _ -> + {lists:reverse([SymbolsFromModule|Acc]),Rest} + end. + +parse_SymbolsFromModule(Tokens) -> + SetRefModuleName = + fun(N) -> + fun(X) when is_record(X,'Externaltypereference')-> + X#'Externaltypereference'{module=N}; + (X) when is_record(X,'Externalvaluereference')-> + X#'Externalvaluereference'{module=N} + end + end, + {SymbolList,Rest} = parse_SymbolList(Tokens), + case Rest of + [{'FROM',_L1},Tref = {typereference,_,Name},Ref={identifier,_L2,_Id},C={',',_}|Rest2] -> + NewSymbolList = lists:map(SetRefModuleName(Name),SymbolList), + {#'SymbolsFromModule'{symbols=NewSymbolList, + module=tref2Exttref(Tref)},[Ref,C|Rest2]}; + + %% This a special case when there is only one Symbol imported + %% from the next module. No other way to distinguish Ref from + %% a part of the GlobalModuleReference of Name. + [{'FROM',_L1},Tref = {typereference,_,Name},Ref = {identifier,_L2,_Id},From = {'FROM',_}|Rest2] -> + NewSymbolList = lists:map(SetRefModuleName(Name),SymbolList), + {#'SymbolsFromModule'{symbols=NewSymbolList, + module=tref2Exttref(Tref)},[Ref,From|Rest2]}; + [{'FROM',_L1},Tref = {typereference,_,Name},{identifier,_L2,_Id}|Rest2] -> + NewSymbolList = lists:map(SetRefModuleName(Name),SymbolList), + {#'SymbolsFromModule'{symbols=NewSymbolList, + 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 is_list(L) -> + %% 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)) + 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 is_list(L) -> + Result; + Error -> + parse_or(Tokens,Frest,[Error|ErrList]) + end. + +parse_or_tag(Tokens,Flist) -> + parse_or_tag(Tokens,Flist,[]). + +parse_or_tag(_Tokens,[],ErrList) -> + case ErrList of + [] -> + throw({asn1_error,{parse_or_tag,ErrList}}); + L when is_list(L) -> + %% 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)) + end; +parse_or_tag(Tokens,[{Tag,Fun}|Frest],ErrList) when is_function(Fun) -> + case (catch Fun(Tokens)) of + Exit = {'EXIT',_Reason} -> + parse_or_tag(Tokens,Frest,[Exit|ErrList]); + AsnErr = {asn1_error,_} -> + parse_or_tag(Tokens,Frest,[AsnErr|ErrList]); + AsnAssErr = {asn1_assignment_error,_} -> + parse_or_tag(Tokens,Frest,[AsnAssErr|ErrList]); + {ParseRes,Rest} when is_list(Rest) -> + {{Tag,ParseRes},Rest}; + Error -> + parse_or_tag(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) -> Ret +%% +%% Tokens = [Tok] +%% Tok = tuple() +%% Ret = #type{} +%% +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 is_record(Tag,tag)-> + {[Tag#tag{type='IMPLICIT'}],Rest31}; + [{'EXPLICIT',_}|Rest31] when is_record(Tag,tag)-> + {[Tag#tag{type='EXPLICIT'}],Rest31}; + Rest31 when is_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 is_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 is_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([{'RELATIVE-OID',_}|Rest]) -> + {#type{def='RELATIVE-OID'},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}; + _ -> + {ComponentTypeLists,Rest3}=parse_ComponentTypeLists2(Rest2,[#'EXTENSIONMARK'{pos=Line}]), + case Rest3 of + [{'}',_}|Rest4] -> + {#type{def=#'SEQUENCE'{components=ComponentTypeLists}},Rest4}; + _ -> + throw({asn1_error,{get_line(hd(Rest3)),get(asn1_module), + [got,get_token(hd(Rest3)),expected,'}']}}) + end +% _ -> % Seq case 4,17-19,23-26 will fail here +% 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]), + #constraint{c=C} = Constraint, + Constraint2 = Constraint#constraint{c={'SizeConstraint',C}}, + 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]), + #constraint{c=C} = Constraint, + Constraint2 = Constraint#constraint{c={'SizeConstraint',C}}, + 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(Tokens=[{typereference,_L1,_Module},{'.',_}, + {typereference,_,_TypeName},{'{',_}|_Rest]) -> + parse_ParameterizedType(Tokens); +parse_DefinedType([{typereference,L1,Module},{'.',_},{typereference,_,TypeName}|Rest]) -> + {#type{def = #'Externaltypereference'{pos=L1,module=Module,type=TypeName}},Rest}; +parse_DefinedType([{typereference,L1,TypeName}|Rest]) -> + case is_pre_defined_class(TypeName) of + false -> + {#type{def = #'Externaltypereference'{pos=L1,module=get(asn1_module), + type=TypeName}},Rest}; + _ -> + throw({asn1_error, + {L1,get(asn1_module), + [got,TypeName,expected, + [typereference,'typereference.typereference', + 'typereference typereference']]}}) + end; +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) -> {Ret,Rest} +%% Tokens = [Tok] +%% Tok = tuple() +%% Ret = {'SingleValue',list()} | list() | +%% +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 is_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 is_list(V2) -> + {[V1] ++ [union|V2],Rest3}; + {V1,V2} -> + {[V1,union,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 is_list(V2) -> + {[V1] ++ [union|V2],Rest3}; + {V1,V2} -> + {[V1,union,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 is_list(V2) -> + {[V1] ++ [intersection|V2],Rest2}; + {V1,V2} -> + {[V1,intersection,V2],Rest2} + end. + +%% parse_IElemsRec(Tokens) -> Result +%% Result ::= {'SingleValue',ordered_set()} | list() +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 is_list(V2) -> + {[V1] ++ [intersection|V2],Rest3}; + {V1,V2} -> + {[V1,intersection,V2],Rest3} + 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 is_list(V2) -> + {[V1] ++ [intersection|V2],Rest3}; + {V1,V2} -> + {[V1,intersection,V2],Rest3} + end; +parse_IElemsRec(Tokens) -> + {[],Tokens}. + +%% parse_IntersectionElements(Tokens) -> {Result,Rest} +%% Result ::= InterSec | {InterSec,{'EXCEPT',Exclusion}} +%% InterSec ::= {'ALL',{'EXCEPT',Exclusions}} | Unions +%% Unions ::= {'SingleValue',list()} | list() (see parse_Unions) +%% Exclusions ::= InterSec +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(Tokens) -> {Result,Rest} +%% Result ::= {'ALL',{'EXCEPT',Exclusions}} | Unions +%% Exclusions ::= {'ALL',{'EXCEPT',Exclusions}} | Unions +%% Unions ::= {'SingleValue',list()} | list() (see parse_Unions) +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_ObjectSetElements/1, + fun parse_SubtypeElements/1, +% fun parse_Value/1, +% fun parse_Type/1, + fun parse_Object/1, + fun parse_DefinedObjectSet/1], + case (catch parse_or(Tokens,Flist)) of + {'EXIT',Reason} -> + exit(Reason); + Err = {asn1_error,_} -> + throw(Err); + Result = {Val,_} when is_record(Val,type) -> + Result; + + 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,Rest5} of + {'UNIQUE',[{Del,_}|_]} when Del =:= ','; Del =:= '}' -> + 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; + {_,[{Del,_}|_]} when Del =:= ','; Del =:= '}' -> + {{object_or_fixedtypevalue_field,VFieldName,Type,Unique,OptionalitySpec},Rest5}; + _ -> + throw({asn1_error,{L1,get(asn1_module), + [got,get_token(hd(Rest5)),expected,[',','}']]}}) + end; +parse_FixedTypeValueFieldSpec(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected,valuefieldreference]}}). + +parse_VariableTypeValueFieldSpec([{valuefieldreference,L,VFieldName}|Rest]) -> + {FieldRef,Rest2} = parse_FieldName(Rest), + {OptionalitySpec,Rest3} = parse_ValueOptionalitySpec(Rest2), + case Rest3 of + [{Del,_}|_] when Del =:= ','; Del =:= '}' -> + {{variabletypevaluefield,VFieldName,FieldRef,OptionalitySpec},Rest3}; + _ -> + throw({asn1_error,{L,get(asn1_module), + [got,get_token(hd(Rest3)),expected,[',','}']]}}) + end; +parse_VariableTypeValueFieldSpec(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected,valuefieldreference]}}). + +parse_ObjectFieldSpec([{valuefieldreference,L,VFieldName}|Rest]) -> + {Class,Rest2} = parse_DefinedObjectClass(Rest), + {OptionalitySpec,Rest3} = parse_ObjectOptionalitySpec(Rest2), + case Rest3 of + [{Del,_}|_] when Del =:= ','; Del =:= '}' -> + {{objectfield,VFieldName,Class,undefined,OptionalitySpec},Rest3}; + _ -> + throw({asn1_error,{L,get(asn1_module), + [got,get_token(hd(Rest3)),expected,[',','}']]}}) + end; +parse_ObjectFieldSpec(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected,valuefieldreference]}}). + +parse_TypeFieldSpec([{typefieldreference,L,TFieldName}|Rest]) -> + {OptionalitySpec,Rest2} = parse_TypeOptionalitySpec(Rest), + case Rest2 of + [{Del,_}|_] when Del =:= ','; Del =:= '}' -> + {{typefield,TFieldName,OptionalitySpec},Rest2}; + _ -> + throw({asn1_error,{L,get(asn1_module), + [got,get_token(hd(Rest2)),expected,[',','}']]}}) + end; +parse_TypeFieldSpec(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected,typefieldreference]}}). + +parse_FixedTypeValueSetFieldSpec([{typefieldreference,L,TFieldName}|Rest]) -> + {Type,Rest2} = parse_Type(Rest), + {OptionalitySpec,Rest3} = parse_ValueSetOptionalitySpec(Rest2), + case Rest3 of + [{Del,_}|_] when Del =:= ','; Del =:= '}' -> + {{objectset_or_fixedtypevalueset_field,TFieldName,Type, + OptionalitySpec},Rest3}; + _ -> + throw({asn1_error,{L,get(asn1_module), + [got,get_token(hd(Rest3)),expected,[',','}']]}}) + end; +parse_FixedTypeValueSetFieldSpec(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected,typefieldreference]}}). + +parse_VariableTypeValueSetFieldSpec([{typefieldreference,L,TFieldName}|Rest]) -> + {FieldRef,Rest2} = parse_FieldName(Rest), + {OptionalitySpec,Rest3} = parse_ValueSetOptionalitySpec(Rest2), + case Rest3 of + [{Del,_}|_] when Del =:= ','; Del =:= '}' -> + {{variabletypevaluesetfield,TFieldName,FieldRef,OptionalitySpec},Rest3}; + _ -> + throw({asn1_error,{L,get(asn1_module), + [got,get_token(hd(Rest3)),expected,[',','}']]}}) + end; +parse_VariableTypeValueSetFieldSpec(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected,typefieldreference]}}). + +parse_ObjectSetFieldSpec([{typefieldreference,L,TFieldName}|Rest]) -> + {Class,Rest2} = parse_DefinedObjectClass(Rest), + {OptionalitySpec,Rest3} = parse_ObjectSetOptionalitySpec(Rest2), + case Rest3 of + [{Del,_}|_] when Del =:= ','; Del =:= '}' -> + {{objectsetfield,TFieldName,Class,OptionalitySpec},Rest3}; + _ -> + throw({asn1_error,{L,get(asn1_module), + [got,get_token(hd(Rest3)),expected,[',','}']]}}) + end; +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) -> Ret +%% Tokens = [Tok] +%% Tok = tuple() +%% Ret = {object,_} | {object, _, _} +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. + + +%% DefinedSyntaxToken ::= Literal | Setting +%% Literal ::= word | ',' +%% Setting ::= Type | Value | ValueSet | Object | ObjectSet +%% word equals typereference, but no lower cases +parse_DefinedSyntaxToken([{',',L1}|Rest]) -> + {{',',L1},Rest}; +%% ObjectClassFieldType or a defined type with a constraint. +%% Should also be able to parse a parameterized type. It may be +%% impossible to distinguish between a parameterized type and a Literal +%% followed by an object set. +parse_DefinedSyntaxToken(Tokens=[{typereference,L1,_Name},{T,_}|_Rest]) + when T == '.'; T == '(' -> + case catch parse_Setting(Tokens) of + {asn1_error,_} -> + throw({asn1_error,{L1,get(asn1_module), + [got,hd(Tokens), expected,['Word',setting]]}}); + {'EXIT',Reason} -> + exit(Reason); + Result -> + Result + end; +parse_DefinedSyntaxToken(Tokens=[TRef={typereference,L1,Name}|Rest]) -> + case is_word(Name) of + false -> + case lookahead_definedsyntax(Rest) of + word_or_setting -> + {{setting,L1,tref2Exttref(TRef)},Rest}; + _ -> + parse_Setting(Tokens) + end; + true -> + %% {{word_or_setting,L1,Name},Rest} + {{word_or_setting,L1,tref2Exttref(TRef)},Rest} + end; +parse_DefinedSyntaxToken(Tokens) -> + case catch parse_Setting(Tokens) of + {asn1_error,_} -> + parse_Word(Tokens); + {'EXIT',Reason} -> + exit(Reason); + Result -> + Result + end. + +lookahead_definedsyntax([{typereference,_,Name}|_Rest]) -> + case is_word(Name) of + true -> word_or_setting; + _ -> setting + end; +lookahead_definedsyntax([{'}',_}|_Rest]) -> + word_or_setting; +lookahead_definedsyntax(_) -> + setting. + +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,tref2Exttref(Pos,Name)},Rest} + end. + +parse_Setting(Tokens) -> + Flist = [{type_tag,fun parse_Type/1}, + {value_tag,fun parse_Value/1}, + {object_tag,fun parse_Object/1}, + {objectset_tag,fun parse_ObjectSet/1}], + case (catch parse_or_tag(Tokens,Flist)) of + {'EXIT',Reason} -> + exit(Reason); + AsnErr = {asn1_error,_} -> + throw(AsnErr); + Result = {{value_tag,_},_} -> + Result; + {{Tag,Setting},Rest} when is_atom(Tag) -> + {Setting,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(Tokens) -> {Ret,Rest} +%% Tokens = [Tok] +%% Tok = tuple() +%% Ret = {[],tuple()} | +%% {list(),list()} | +%% list() | +%% ['EXTENSIONMARK'] | +%% {'ALL',{'EXCEPT',Exclusions}} | +%% {'SingleValue',SV} +%% SV = list() | #'Externalvaluereference'{} | {definedvalue,term()} +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]) -> + case Rest of + [{',',_}|Rest2] -> + {Elements,Rest3}=parse_ElementSetSpecs(Rest2), + {{[],Elements},Rest3}; + _ -> + {['EXTENSIONMARK'],Rest} + end; +parse_ObjectSetSpec(Tokens) -> + parse_ElementSetSpecs(Tokens). + +% moved fun parse_Object/1 and fun parse_DefinedObjectSet/1 to parse_Elements +%% parse_ObjectSetElements(Tokens) -> {Result,Rest} +%% Result ::= {'ObjectSetFromObjects',Objects,Name} | {pos,ObjectSet,Params} +%% Objects ::= ReferencedObjects +%% ReferencedObjects ::= (see parse_ReferencedObjects/1) +%% Name ::= [FieldName] +%% FieldName ::= {typefieldreference,atom()} | {valuefieldreference,atom()} +%% ObjectSet ::= {objectset,integer(),#'Externaltypereference'{}} +%% Params ::= list() (see parse_ActualParameterList/1) +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) -> {Result,Rest} +%% Result ::= DefObject | DefObjSet | +%% {po,DefObject,Params} | {pos,DefObjSet,Params} | +%% +%% DefObject ::= {object,#'Externaltypereference'{}} | +%% {object,#'Externalvaluereference'{}} +%% DefObjSet ::= {objectset,integer(),#'Externaltypereference'{}} +%% Params ::= list() +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,'.']}}) + end. + +%% parse_ObjectSetFromObjects(Tokens) -> {Result,Rest} +%% Result ::= {'ObjectSetFromObjects',Objects,Name} +%% Objects ::= ReferencedObject (see parse_ReferencedObjects/1) +%% Name ::= [FieldName] +%% FieldName ::= {typefieldreference,atom()} | +%% {valuefieldreference,atom()} +parse_ObjectSetFromObjects(Tokens) -> + {Objects,Rest} = parse_ReferencedObjects(Tokens), + case Rest of + [{'.',_}|Rest2] -> + {Name,Rest3} = parse_FieldName(Rest2), + case lists:last(Name) of + {typefieldreference,_FieldName} -> + {{'ObjectSetFromObjects',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,'.']}}) + 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, + fun parse_ContentsConstraint/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.']]}}). + +parse_ContentsConstraint([{'CONTAINING',_}|Rest]) -> + {Type,Rest2} = parse_Type(Rest), + case Rest2 of + [{'ENCODED',_},{'BY',_}|Rest3] -> + {Value,Rest4} = parse_Value(Rest3), + {{contentsconstraint,Type,Value},Rest4}; + _ -> + {{contentsconstraint,Type,[]},Rest2} + end; +parse_ContentsConstraint([{'ENCODED',_},{'BY',_}|Rest]) -> + {Value,Rest2} = parse_Value(Rest), + {{contentsconstraint,[],Value},Rest2}; +parse_ContentsConstraint(Tokens) -> + throw({asn1_error,{get_line(hd(Tokens)),get(asn1_module), + [got,get_token(hd(Tokens)),expected, + 'CONTAINING','or','ENCODED BY']}}). + + +% 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(Tokens) -> Result +%% Result = {#ptypedef{},Rest} | throw() +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(Tokens) -> Result +%% Result = {#pvaluedef{},Rest} | throw() +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(Tokens) -> Result +%% Result = {#pvaluesetdef{},Rest} | throw() +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(Tokens) -> Result +%% Result = {#ptypedef{},Rest} | throw() +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(Tokens) -> Result +%% Result = {#pobjectdef{},Rest} | throw() +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(Tokens) -> Result +%% Result = {#pobjectsetdef{},Rest} | throw{} +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(Tokens) -> Result +%% Result = [Parameter] +%% Parameter = {Governor,Reference} | Reference +%% Governor = Type | DefinedObjectClass +%% Type = #type{} +%% DefinedObjectClass = #'Externaltypereference'{} | +%% 'ABSTRACT-SYNTAX' | 'TYPE-IDENTIFIER' +%% Reference = #'Externaltypereference'{} | #'Externalvaluereference'{} +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([Id={identifier,_,_Value}|Rest]) -> + {{simpledefinedvalue,identifier2Extvalueref(Id)},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 + is_atom(Token) -> + Item = atom_to_list(Token), + is_word(Item); + is_list(Token), length(Token) == 1 -> + check_one_char_word(Token); + is_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; $-==R -> + check_rest(Rs); +check_rest([]) -> + true; +check_rest(_) -> + false. + + +to_set(V) when is_list(V) -> + ordsets:from_list(V); +to_set(V) -> + ordsets:from_list([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); % 5 - 13 + _ -> + {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) -> %% first Extensionmark + 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}; + [{',',_},{'...',_}|_] ->%% here comes the dubble ellipse + {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); + [{'...',L1}|_Rest] -> + {#'EXTENSIONMARK'{pos=L1},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]); + [{'...',_}|Rest01] -> + {lists:reverse([Element|Acc]),Rest01}; + _ -> + {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([_VsnNr = {number,_,_},{':',_}|Rest],Acc) -> + %% ignor version number for now + parse_ExtensionAdditions(Rest,Acc); +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) -> Ret +%% Tokens = [Tok] +%% Tok = tuple() +%% Ret = term() +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(Tokens=[{'NULL',_},{':',_}|_Rest]) -> + parse_ObjectClassFieldValue(Tokens); +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). + +parse_DefinedValue(Tokens=[{identifier,_,_},{'{',_}|_Rest]) -> + parse_ParameterizedValue(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, + module=get(asn1_module)},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 catch lookahead_assignment(Rest4) of + ok -> + {#valuedef{pos=L1,name=IdName,type=Type,value=Value, + module=get(asn1_module)},Rest4}; + Error -> + throw(Error) +%% 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; +parse_SubtypeElements([{'PATTERN',_}|Tokens]) -> + {Value,Rest} = parse_Value(Tokens), + {{pattern,Value},Rest}; +%% SingleValue +%% ContainedSubtype +%% ValueRange +%% TypeConstraint +%% Moved fun parse_Value/1 and fun parse_Type/1 to parse_Elements +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 is_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,[],[])}; + +%% An arg with a constraint with extension marker will look like +%% [#constraint{c={Root,Ext}}|Rest] + +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 is_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 is_list(V) -> + %%sort and remove duplicates + V2 = {'SingleValue', + ordsets:from_list(lists:flatten(V))}, + {'PermittedAlphabet',V2}; + {'PermittedAlphabet',{'SingleValue',V}} -> + V2 = {'SingleValue',[V]}, + {'PermittedAlphabet',V2}; + {'SizeConstraint',Sc} -> + {'SizeConstraint',fixup_size_constraint(Sc)}; + + List when is_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 is_list(L) -> + ordsets:from_list(L); +fixup_size_constraint({'SingleValue',L}) -> + {L,L}; +fixup_size_constraint({'SizeConstraint',C}) -> + %% this is a second SIZE + fixup_size_constraint(C); +fixup_size_constraint({C1,C2}) -> + %% this is with extension marks + {turn2vr(fixup_size_constraint(C1)), extension_size(fixup_size_constraint(C2))}; +fixup_size_constraint(CList) when is_list(CList) -> + [fixup_constraint(Xc)||Xc <- CList]. + +turn2vr(L) when is_list(L) -> + L2 =[X||X<-ordsets:from_list(L),is_integer(X)], + case L2 of + [H|_] -> + {H,hd(lists:reverse(L2))}; + _ -> + L + end; +turn2vr(VR) -> + VR. +extension_size({I,I}) -> + [I]; +extension_size({I1,I2}) -> + [I1,I2]; +extension_size(C) -> + C. + +get_line({_,Pos,Token}) when is_integer(Pos),is_atom(Token) -> + Pos; +get_line({Token,Pos}) when is_integer(Pos),is_atom(Token) -> + Pos; +get_line(_) -> + undefined. + +get_token({_,Pos,Token}) when is_integer(Pos),is_atom(Token) -> + Token; +get_token({'$end',Pos}) when is_integer(Pos) -> + undefined; +get_token({Token,Pos}) when is_integer(Pos),is_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 is_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 is_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 is_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. + +is_pre_defined_class('TYPE-IDENTIFIER') -> + true; +is_pre_defined_class('ABSTRACT-SYNTAX') -> + true; +is_pre_defined_class(_) -> + false. + diff --git a/lib/asn1/src/asn1ct_pretty_format.erl b/lib/asn1/src/asn1ct_pretty_format.erl new file mode 100644 index 0000000000..a01c1db8c5 --- /dev/null +++ b/lib/asn1/src/asn1ct_pretty_format.erl @@ -0,0 +1,201 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1997-2009. All Rights Reserved. +%% +%% 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 online 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. +%% +%% %CopyrightEnd% +%% +%% + +%% 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 -- use to indent the *next* line +%% Note: Indent' is a new indentaion level (sometimes printing +%% 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_list(H) =:= false , is_tuple(H) =:= false -> + 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/asn1/src/asn1ct_tok.erl b/lib/asn1/src/asn1ct_tok.erl new file mode 100644 index 0000000000..27116c46c5 --- /dev/null +++ b/lib/asn1/src/asn1ct_tok.erl @@ -0,0 +1,391 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1997-2009. All Rights Reserved. +%% +%% 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 online 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. +%% +%% %CopyrightEnd% +%% +%% +-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 is_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); + {multiline_comment,NestingLevel} -> + {RestL,Lno2} = process_skip_multiline_comment(Stream,Lno,NestingLevel), + process(RestL,Stream,Lno2,R); + T -> + %%io:format('toks:~w~n',[T]), + process(Stream,Lno,[T|R]) + end. + +process_skip_multiline_comment(Stream,Lno,NestingLevel) -> + process_skip_multiline_comment(io:get_line(Stream, ''), + Stream, Lno + 1, NestingLevel). +process_skip_multiline_comment(eof,_Stream,Lno,_NestingLevel) -> + io:format("Tokeniser error on line: ~w, premature end of multiline comment~n",[Lno]), + exit(0); +process_skip_multiline_comment(Line,Stream,Lno,NestingLevel) -> + case catch skip_multiline_comment(Line,NestingLevel) of + {multiline_comment,NestingLevel2} -> + process_skip_multiline_comment(Stream,Lno,NestingLevel2); + T -> + {T,Lno} + 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) -> + tokenise(skip_multiline_comment(T,0),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. + + + +% is letters digits hyphens +% hypen is not the last character. Hypen hyphen is NOT allowed +% +% ::= + +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). + + +skip_multiline_comment([],L) -> + throw({multiline_comment,L}); +skip_multiline_comment([$*,$/|T],0) -> + T; +skip_multiline_comment([$*,$/|T],Level) -> + skip_multiline_comment(T,Level - 1); +skip_multiline_comment([$/,$*|T],Level) -> + skip_multiline_comment(T,Level + 1); +skip_multiline_comment([_|T],Level) -> + skip_multiline_comment(T,Level). + + +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('CONTAINING') -> true; +reserved_word('DEFAULT') -> true; +reserved_word('DEFINED') -> true; +reserved_word('DEFINITIONS') -> true; +reserved_word('EMBEDDED') -> true; +reserved_word('ENCODED') -> 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('PATTERN') -> 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('RELATIVE-OID') -> 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('UTF8String') -> rstrtype; +reserved_word('VideotexString') -> rstrtype; +reserved_word('VisibleString') -> rstrtype; +reserved_word('WITH') -> true; +reserved_word(_) -> false. diff --git a/lib/asn1/src/asn1ct_value.erl b/lib/asn1/src/asn1ct_value.erl new file mode 100644 index 0000000000..d9a7e5374a --- /dev/null +++ b/lib/asn1/src/asn1ct_value.erl @@ -0,0 +1,459 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1997-2009. All Rights Reserved. +%% +%% 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 online 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. +%% +%% %CopyrightEnd% +%% +%% +-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]). +-export([i_random/1]). + + +%% 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 is_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 is_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,get_encoding_rule(M)); + 'ASN1_OPEN_TYPE' -> + case Type#type.constraint of + [#'Externaltypereference'{type=TrefConstraint}] -> + get_type(M,TrefConstraint,no); + _ -> + ERule = get_encoding_rule(M), + open_type_value(ERule) + end; + {constructed,bif} when Typename == ['EXTERNAL'] -> + Val=get_type_constructed(M,Typename,InnerType,Type), + asn1rt_check:transform_to_EXTERNAL1994(Val); + {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 is_atom(A) -> A; +get_inner(Ext) when is_record(Ext,'Externaltypereference') -> Ext; +get_inner({typereference,_Pos,Name}) -> Name; +get_inner(T) when is_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 is_tuple(T) -> element(1,T). + + + +get_type_constructed(M,Typename,InnerType,D) when is_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',to_textual_order(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 is_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,Erule) -> + 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); + _ -> + case C of + [] -> + lists:nth(random(length(NN)),NN); + _ -> + lists:nth((fun(0)->1;(X)->X end(i_random(C))),NN) + end + end; + Enum when is_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; + _ -> + case C of + [] -> + lists:nth(random(length(NN)),NN); + _ -> + lists:nth((fun(0)->1;(X)->X end(i_random(C))),NN) + end + end; + {'BIT STRING',NamedNumberList} -> + NN = [X||{X,_} <- NamedNumberList], + case NN of + [] -> + Bl1 =lists:reverse(adjust_list(size_random(C),[1,0,1,1])), + Bl2 = lists:reverse(lists:dropwhile(fun(0)->true;(1)->false end,Bl1)), + case {length(Bl2),get_constraint(C,'SizeConstraint')} of + {Len,Len} -> + Bl2; + {_Len,Int} when is_integer(Int) -> + Bl1; + {Len,{Min,_}} when Min > Len -> + Bl1; + _ -> + Bl2 + end; + _ -> + [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]); + 'RELATIVE-OID' -> + Len = random(5), + Olist = [(random(16#ffff)-1)||_X <-lists:seq(1,Len)], + list_to_tuple(Olist); + 'ObjectDescriptor' -> + "Dummy ObjectDescriptor"; + 'REAL' -> + %% Base is 2 or 10, format is string (base 10) or tuple + %% (base 2 or 10) + %% Tuple: {Mantissa, Base, Exponent} + case random(3) of + 1 -> + %% base 2 + case random(3) of + 3 -> + {129,2,10}; + 2 -> + {1,2,1}; + _ -> + {2#11111111,2,2} + end; +%% Sign1 = random_sign(integer), +%% Sign2 = random_sign(integer), +%% {Sign1*random(10000),2,Sign2*random(1028)}; +%% 2 -> +%% %% base 10 tuple format +%% Sign1 = random_sign(integer), +%% Sign2 = random_sign(integer), +%% {Sign1*random(10000),10,Sign2*random(1028)}; + _ -> + %% base 10 string format, NR3 format + case random(2) of + 2 -> + "123.E10"; + _ -> + "-123.E-10" + end + end; + '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")); + 'T61String' -> + adjust_list(size_random(C),c_string(C,"T61String")); + '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")); + 'UTF8String' -> + {ok,Res}=asn1rt:utf8_list_to_binary(adjust_list(random(50),[$U,$T,$F,$8,$S,$t,$r,$i,$n,$g,16#ffff,16#fffffff,16#ffffff,16#fffff,16#fff])), + case Erule of + per -> + binary_to_list(Res); + _ -> + Res + end; + 'UniversalString' -> + adjust_list(size_random(C),c_string(C,"UniversalString")); + XX -> + exit({asn1_error,nyi,XX}) + end. + +c_string(C,Default) -> + case get_constraint(C,'PermittedAlphabet') of + {'SingleValue',Sv} when is_list(Sv) -> + Sv; + {'SingleValue',V} when is_integer(V) -> + [V]; + no -> + Default + end. + +%% FIXME: +%% random_sign(integer) -> +%% case random(2) of +%% 2 -> +%% -1; +%% _ -> +%% 1 +%% end; +%% random_sign(string) -> +%% case random(2) of +%% 2 -> +%% "-"; +%% _ -> +%% "" +%% 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 is_integer(Lb),is_integer(Ub) -> + if + Ub-Lb =< 4 -> + c_random({Lb,Ub},no); + true -> + c_random({Lb,Lb+4},no) + end; + {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 is_integer(Lb),is_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 is_integer(S) -> + S; + {_,S} when is_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. + +get_encoding_rule(M) -> + Mod = + if is_list(M) -> + list_to_atom(M); + true ->M + end, + case (catch Mod:encoding_rule()) of + A when is_atom(A) -> + A; + _ -> unknown + end. + +open_type_value(ber) -> + [4,9,111,112,101,110,95,116,121,112,101]; +open_type_value(ber_bin) -> + [4,9,111,112,101,110,95,116,121,112,101]; +% <<4,9,111,112,101,110,95,116,121,112,101>>; +open_type_value(ber_bin_v2) -> + [4,9,111,112,101,110,95,116,121,112,101]; +% <<4,9,111,112,101,110,95,116,121,112,101>>; +open_type_value(per) -> + "\n\topen_type"; %octet string value "open_type" +open_type_value(per_bin) -> + "\n\topen_type"; +% <<10,9,111,112,101,110,95,116,121,112,101>>; +open_type_value(_) -> + [4,9,111,112,101,110,95,116,121,112,101]. + +to_textual_order({Root,Ext}) -> + {to_textual_order(Root),Ext}; +to_textual_order(Cs) when is_list(Cs) -> + case Cs of + [#'ComponentType'{textual_order=undefined}|_] -> + Cs; + _ -> + lists:keysort(#'ComponentType'.textual_order,Cs) + end. diff --git a/lib/asn1/src/asn1rt.erl b/lib/asn1/src/asn1rt.erl new file mode 100644 index 0000000000..9ef68efab5 --- /dev/null +++ b/lib/asn1/src/asn1rt.erl @@ -0,0 +1,210 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1997-2009. All Rights Reserved. +%% +%% 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 online 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. +%% +%% %CopyrightEnd% +%% +%% +-module(asn1rt). + +%% Runtime functions for ASN.1 (i.e encode, decode) + +-include("asn1_records.hrl"). + +-export([encode/2,encode/3,decode/3,load_driver/0,unload_driver/0,info/1]). + +-export([utf8_binary_to_list/1,utf8_list_to_binary/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. + +%% asn1-1.6.8.1 +%% load_driver() -> +%% asn1rt_driver_handler:load_driver(), +%% receive +%% driver_ready -> +%% ok; +%% Err={error,_Reason} -> +%% Err; +%% Error -> +%% {error,Error} +%% end. + +%% asn1-1.6.9 + load_driver() -> + case catch asn1rt_driver_handler:load_driver() of + ok -> + ok; + {error,{already_started,asn1}} -> + ok; + Err -> + {error,Err} + 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. + +%% utf8_binary_to_list/1 transforms a utf8 encoded binary to a list of +%% unicode elements, where each element is the unicode integer value +%% of a utf8 character. +%% Bin is a utf8 encoded value. The return value is either {ok,Val} or +%% {error,Reason}. Val is a list of integers, where each integer is a +%% unicode character value. +utf8_binary_to_list(Bin) when is_binary(Bin) -> + utf8_binary_to_list(Bin,[]). + +utf8_binary_to_list(<<>>,Acc) -> + {ok,lists:reverse(Acc)}; +utf8_binary_to_list(Bin,Acc) -> + Len = utf8_binary_len(Bin), + case catch split_binary(Bin,Len) of + {CharBin,RestBin} -> + case utf8_binary_char(CharBin) of + C when is_integer(C) -> + utf8_binary_to_list(RestBin,[C|Acc]); + Err -> Err + end; + Err -> {error,{asn1,{bad_encoded_utf8string,Err}}} + end. + +utf8_binary_len(<<0:1,_:7,_/binary>>) -> + 1; +utf8_binary_len(<<1:1,1:1,0:1,_:5,_/binary>>) -> + 2; +utf8_binary_len(<<1:1,1:1,1:1,0:1,_:4,_/binary>>) -> + 3; +utf8_binary_len(<<1:1,1:1,1:1,1:1,0:1,_:3,_/binary>>) -> + 4; +utf8_binary_len(<<1:1,1:1,1:1,1:1,1:1,0:1,_:2,_/binary>>) -> + 5; +utf8_binary_len(<<1:1,1:1,1:1,1:1,1:1,1:1,0:1,_:1,_/binary>>) -> + 6; +utf8_binary_len(Bin) -> + {error,{asn1,{bad_utf8_length,Bin}}}. + +utf8_binary_char(<<0:1,Int:7>>) -> + Int; +utf8_binary_char(<<_:2,0:1,Int1:5,1:1,0:1,Int2:6>>) -> + (Int1 bsl 6) bor Int2; +utf8_binary_char(<<_:3,0:1,Int1:4,1:1,0:1,Int2:6,1:1,0:1,Int3:6>>) -> + <> = <>, + Res; +utf8_binary_char(<<_:4,0:1,Int1:3,Rest/binary>>) -> + <<1:1,0:1,Int2:6,1:1,0:1,Int3:6,1:1,0:1,Int4:6>> = Rest, + <> = <<0:3,Int1:3,Int2:6,Int3:6,Int4:6>>, + Res; +utf8_binary_char(<<_:5,0:1,Int1:2,Rest/binary>>) -> + <<1:1,0:1,Int2:6,1:1,0:1,Int3:6,1:1,0:1,Int4:6,1:1,0:1,Int5:6>> = Rest, + <> = <<0:6,Int1:2,Int2:6,Int3:6,Int4:6,Int5:6>>, + Res; +utf8_binary_char(<<_:6,0:1,I:1,Rest/binary>>) -> + <<1:1,0:1,Int2:6,1:1,0:1,Int3:6,1:1,0:1,Int4:6,1:1,0:1, + Int5:6,1:1,0:1,Int6:6>> = Rest, + <> = <<0:1,I:1,Int2:6,Int3:6,Int4:6,Int5:6,Int6:6>>, + Res; +utf8_binary_char(Err) -> + {error,{asn1,{bad_utf8_character_encoding,Err}}}. + + +%% macros used for utf8 encoding +-define(bit1to6_into_utf8byte(I),16#80 bor (I band 16#3f)). +-define(bit7to12_into_utf8byte(I),16#80 bor ((I band 16#fc0) bsr 6)). +-define(bit13to18_into_utf8byte(I),16#80 bor ((I band 16#3f000) bsr 12)). +-define(bit19to24_into_utf8byte(I),16#80 bor ((Int band 16#fc0000) bsr 18)). +-define(bit25to30_into_utf8byte(I),16#80 bor ((Int band 16#3f000000) bsr 24)). + +%% utf8_list_to_binary/1 transforms a list of integers to a +%% binary. Each element in the input list has the unicode (integer) +%% value of an utf8 character. +%% The return value is either {ok,Bin} or {error,Reason}. The +%% resulting binary is utf8 encoded. +utf8_list_to_binary(List) -> + utf8_list_to_binary(List,[]). + +utf8_list_to_binary([],Acc) when is_list(Acc) -> + {ok,list_to_binary(lists:reverse(Acc))}; +utf8_list_to_binary([],Acc) -> + {error,{asn1,Acc}}; +utf8_list_to_binary([H|T],Acc) -> + case catch utf8_encode(H,Acc) of + NewAcc when is_list(NewAcc) -> + utf8_list_to_binary(T,NewAcc); + Err -> Err + end. + + +utf8_encode(Int,Acc) when Int < 128 -> + %% range 16#00000000 - 16#0000007f + %% utf8 encoding: 0xxxxxxx + [Int|Acc]; +utf8_encode(Int,Acc) when Int < 16#800 -> + %% range 16#00000080 - 16#000007ff + %% utf8 encoding: 110xxxxx 10xxxxxx + [?bit1to6_into_utf8byte(Int),16#c0 bor (Int bsr 6)|Acc]; +utf8_encode(Int,Acc) when Int < 16#10000 -> + %% range 16#00000800 - 16#0000ffff + %% utf8 encoding: 1110xxxx 10xxxxxx 10xxxxxx + [?bit1to6_into_utf8byte(Int),?bit7to12_into_utf8byte(Int), + 16#e0 bor ((Int band 16#f000) bsr 12)|Acc]; +utf8_encode(Int,Acc) when Int < 16#200000 -> + %% range 16#00010000 - 16#001fffff + %% utf8 encoding: 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx + [?bit1to6_into_utf8byte(Int),?bit7to12_into_utf8byte(Int), + ?bit13to18_into_utf8byte(Int), + 16#f0 bor ((Int band 16#1c0000) bsr 18)|Acc]; +utf8_encode(Int,Acc) when Int < 16#4000000 -> + %% range 16#00200000 - 16#03ffffff + %% utf8 encoding: 111110xx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx + [?bit1to6_into_utf8byte(Int),?bit7to12_into_utf8byte(Int), + ?bit13to18_into_utf8byte(Int),?bit19to24_into_utf8byte(Int), + 16#f8 bor ((Int band 16#3000000) bsr 24)|Acc]; +utf8_encode(Int,Acc) -> + %% range 16#04000000 - 16#7fffffff + %% utf8 encoding: 1111110x 10xxxxxx ...(total 6 bytes) 10xxxxxx + [?bit1to6_into_utf8byte(Int),?bit7to12_into_utf8byte(Int), + ?bit13to18_into_utf8byte(Int),?bit19to24_into_utf8byte(Int), + ?bit25to30_into_utf8byte(Int), + 16#fc bor ((Int band 16#40000000) bsr 30)|Acc]. diff --git a/lib/asn1/src/asn1rt_ber_bin.erl b/lib/asn1/src/asn1rt_ber_bin.erl new file mode 100644 index 0000000000..71d78377d4 --- /dev/null +++ b/lib/asn1/src/asn1rt_ber_bin.erl @@ -0,0 +1,2497 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2000-2009. All Rights Reserved. +%% +%% 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 online 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. +%% +%% %CopyrightEnd% +%% +%% +-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, encode_real/3, + decode_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_relative_oid/2,decode_relative_oid/3, + encode_restricted_string/4,decode_restricted_string/6, + encode_universal_string/3,decode_universal_string/5, + encode_UTF8_string/3, decode_UTF8_string/3, + 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,skip_ExtensionAdditions/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_UTF8String, 12). +-define('N_RELATIVE-OID',13). +-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), + <> = 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 is_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}. + {RemBytes,size(Bytes)}. + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% 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(L, Bytes, Rb) -> + skipvalue(L, Bytes, Rb, 0). + +skipvalue(indefinite, Bytes, Rb, IndefLevel) -> + {T,Bytes2,R2} = decode_tag(Bytes), + {{L,Bytes3},R3} = decode_length(Bytes2), + case {T,L} of + {_,indefinite} -> + skipvalue(indefinite,Bytes3,Rb+R2+R3,IndefLevel+1); + {{0,0,0},0} when IndefLevel =:= 0 -> + %% See X690 8.1.5 NOTE, end of indefinite content + {Bytes3,Rb+2}; + {{0,0,0},0} -> + skipvalue(indefinite,Bytes3,Rb+2,IndefLevel - 1); + _ -> + <<_:L/binary, RestBytes/binary>> = Bytes3, + skipvalue(indefinite,RestBytes,Rb+R2+R3+L, IndefLevel) + %%{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, _) -> +% <> = Bytes, + <<_:L/binary, RestBytes/binary>> = Bytes, + {RestBytes,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. + +%%% +%% skips byte sequence of Bytes that do not match a tag in Tags +skip_ExtensionAdditions(Bytes,Tags) -> + skip_ExtensionAdditions(Bytes,Tags,0). +skip_ExtensionAdditions(<<>>,_Tags,RmB) -> + {<<>>,RmB}; +skip_ExtensionAdditions(Bytes,Tags,RmB) -> + case catch decode_tag(Bytes) of + {'EXIT',_Reason} -> + tag_error(no_data,Tags,Bytes,'OPTIONAL'); + {_T={Class,_Form,TagNo},_Bytes2,_R2} -> + case [X||X=#tag{class=Cl,number=TN} <- Tags,Cl==Class,TN==TagNo] of + [] -> + %% skip this TLV and continue with next + {Bytes3,R3} = skipvalue(Bytes), + skip_ExtensionAdditions(Bytes3,Tags,RmB+R3); + _ -> + {Bytes,RmB} + end + end. + + + +%%=============================================================================== +%%=============================================================================== +%%=============================================================================== +%% Optionals, preset not filled optionals with asn1_NOVALUE +%%=============================================================================== +%%=============================================================================== +%%=============================================================================== + +% converts a list to a record if necessary +list_to_record(Name,List) when is_list(List) -> + list_to_tuple([Name|List]); +list_to_record(_Name,Tuple) when is_tuple(Tuple) -> + Tuple. + + +fixoptionals(OptList,Val) when is_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 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(<>) -> + Bin = peek_tag(Buffer, <<>>), + <>; +%% single tag (tagno < 31) +peek_tag(<>) -> + <>. + +peek_tag(<<0:1,PartialTag:7,_Buffer/binary>>, TagAck) -> + <>; +peek_tag(<>, TagAck) -> + peek_tag(Buffer,<>); +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(<>) -> + {TagNo, Buffer1, RemovedBytes} = decode_tag(Buffer, 0, 1), + {{(Class bsl 6), (Form bsl 5), TagNo}, Buffer1, RemovedBytes}; + +%% single tag (< 31 tags) +decode_tag(<>) -> + {{(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, Buffer, RemovedBytes+1}; +% more tags +decode_tag(<<_:1,PartialTag:7, Buffer/binary>>, TagAck, RemovedBytes) -> + TagAck1 = (TagAck bsl 7) bor PartialTag, + %%<> = <>, + 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 is_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 is_list(Val) -> + {Val,size(list_to_binary(Val))}; +encode_open_type(Val) -> + {Val, size(Val)}. + +%% +encode_open_type(Val, []) when is_list(Val) -> + {Val,size(list_to_binary(Val))}; +encode_open_type(Val,[]) -> + {Val, size(Val)}; +encode_open_type(Val, Tag) when is_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, + {_Tag, Len, RemainingBuffer, RemovedBytes} = decode_tag_and_length(Bytes), + {_RemainingBuffer2, RemovedBytes2} = skipvalue(Len, RemainingBuffer, RemovedBytes), + N = RemovedBytes2, + <> = Bytes, +% {Val, RemainingBytes, Len + RemovedBytes}. + {Val,RemainingBytes,N}. + +decode_open_type(<<>>,[]=ExplTag) -> % R9C-0.patch-40 + exit({error, {asn1,{no_optional_tag, ExplTag}}}); +decode_open_type(Bytes,ExplTag) -> + {Tag, Len, RemainingBuffer, RemovedBytes} = decode_tag_and_length(Bytes), + case {Tag,ExplTag} of +% {{Class,Form,32},[#tag{class=Class,number=No,form=32}]} -> +% {_Tag2, Len2, RemainingBuffer2, RemovedBytes2} = decode_tag_and_length(RemainingBuffer), +% {_RemainingBuffer3, RemovedBytes3} = skipvalue(Len2, RemainingBuffer2, RemovedBytes2), +% N = RemovedBytes3, +% <<_:RemovedBytes/unit:8,Val:N/binary,RemainingBytes/binary>> = Bytes, +% {Val, RemainingBytes, N + RemovedBytes}; + {{Class,Form,No},[#tag{class=Class,number=No,form=Form}]} -> + {_RemainingBuffer2, RemovedBytes2} = + skipvalue(Len, RemainingBuffer), + N = RemovedBytes2, + <<_:RemovedBytes/unit:8,Val:N/binary,RemainingBytes/binary>> = Bytes, + {Val, RemainingBytes, N + RemovedBytes}; + _ -> + {_RemainingBuffer2, RemovedBytes2} = + skipvalue(Len, RemainingBuffer, RemovedBytes), + N = RemovedBytes2, + <> = Bytes, + {Val, RemainingBytes, N} + 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 is_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 is_integer(Val) -> + {EncVal,Len}=encode_integer(C, Val), + dotag_universal(?N_INTEGER,EncVal,Len); +encode_integer(C, Val, Tag) when is_integer(Val) -> + dotag(Tag, ?N_INTEGER, encode_integer(C, Val)); +encode_integer(C,{Name,Val},Tag) when is_atom(Name) -> + encode_integer(C,Val,Tag); +encode_integer(_, Val, _) -> + exit({error,{asn1, {encode_integer, Val}}}). + + + +encode_integer(C, Val, NamedNumberList, Tag) when is_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 is_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 is_integer(Val)-> + {EncVal,Len} = encode_integer(false,Val), + dotag_universal(?N_ENUMERATED,EncVal,Len); +encode_enumerated(Val, DoTag) when is_integer(Val)-> + dotag(DoTag, ?N_ENUMERATED, encode_integer(false,Val)); +encode_enumerated({Name,Val}, DoTag) when is_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 is_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 is_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 is_integer(Val) -> + dotag(DoTag, ?N_ENUMERATED, encode_integer(C,Val)); + +encode_enumerated(C, {Name,Val}, NamedNumberList, DoTag) when is_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(_C,0, DoTag) -> + dotag(DoTag, ?N_REAL, {[],0}); +encode_real(_C,'PLUS-INFINITY', DoTag) -> + dotag(DoTag, ?N_REAL, {[64],1}); +encode_real(_C,'MINUS-INFINITY', DoTag) -> + dotag(DoTag, ?N_REAL, {[65],1}); +encode_real(C,Val, DoTag) when is_tuple(Val); is_list(Val) -> + dotag(DoTag, ?N_REAL, encode_real(C,Val)). + +%%%%%%%%%%%%%% +%% only base 2 encoding! +%% binary encoding: +%% +------------+ +------------+ +-+-+-+-+---+---+ +%% | (tag)9 | | n + p + 1 | |1|S|BB |FF |EE | +%% +------------+ +------------+ +-+-+-+-+---+---+ +%% +%% +------------+ +------------+ +%% | | | | +%% +------------+ ...+------------+ +%% n octets for exponent +%% +%% +------------+ +------------+ +%% | | | | +%% +------------+ ...+------------+ +%% p octets for pos mantissa +%% +%% S is 0 for positive sign +%% 1 for negative sign +%% BB: encoding base, 00 = 2, (01 = 8, 10 = 16) +%% 01 and 10 not used +%% FF: scale factor 00 = 0 (used in base 2 encoding) +%% EE: encoding of the exponent: +%% 00 - on the following octet +%% 01 - on the 2 following octets +%% 10 - on the 3 following octets +%% 11 - encoding of the length of the two's-complement encoding of +%% exponent on the following octet, and two's-complement +%% encoding of exponent on the other octets. +%% +%% In DER and base 2 encoding the mantissa is encoded as value 0 or +%% bit shifted until it is an odd number. Thus, do this for BER as +%% well. +%% This interface also used by RT_COMMON +encode_real(_C,{Mantissa, Base, Exponent}) when Base =:= 2 -> +%% io:format("Mantissa: ~w Base: ~w, Exp: ~w~n",[Man, Base, Exp]), + {Man,ExpAdd} = truncate_zeros(Mantissa), %% DER adjustment + Exp = Exponent + ExpAdd, + 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]), + SFactor = 0, + 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, <>} + end, + BB = 0, %% 00 for base 2 + FirstOctet = <<1:1,SignBit:1,BB: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 = <>, + {Bin, size(Bin)}; +encode_real(C,{Mantissa,Base,Exponent}) + when Base =:= 10, is_integer(Mantissa), is_integer(Exponent) -> + %% always encode as NR3 due to DER on the format + %% mmmm.Eseeee where + %% m := digit + %% s := '-' | '+' | [] + %% '+' only allowed in +0 + %% e := digit + %% ex: 1234.E-5679 +%% {Man,AddExp} = truncate_zeros(Mantissa,0), +%% ManNum = trunc(Mantissa), +%% {TruncatedMan,NumZeros} = truncate_zeros10(Mantissa), + ManStr = integer_to_list(Mantissa), + + encode_real_as_string(C,ManStr,Exponent); +encode_real(_C,{_,Base,_}) -> + exit({error,{asn1, {encode_real_non_supported_encodeing, Base}}}); +%% base 10 +encode_real(C,Real) when is_list(Real) -> + %% The Real string may come in as a NR1, NR2 or NR3 string. + {Mantissa, Exponent} = + case string:tokens(Real,"Ee") of + [NR2] -> + {NR2,0}; + [NR3MB,NR3E] -> + %% remove beginning zeros + {NR3MB,list_to_integer(NR3E)} + end, + + %% .Decimal | Number | Number.Decimal + ZeroDecimal = + fun("0") -> ""; + (L) -> L + end, + {NewMantissa,LenDecimal} = + case Mantissa of + [$.|Dec] -> + NewMan = remove_trailing_zeros(Dec), + {NewMan,length(ZeroDecimal(NewMan))}; + _ -> + case string:tokens(Mantissa,",.") of + [Num] -> %% No decimal-mark + {integer_to_list(list_to_integer(Num)),0}; + [Num,Dec] -> + NewDec = ZeroDecimal(remove_trailing_zeros(Dec)), + NewMan = integer_to_list(list_to_integer(Num)) ++ NewDec, + {integer_to_list(list_to_integer(NewMan)), + length(NewDec)} + end + end, + +% DER_Exponent = integer_to_list(Exponent - ExpReduce), + encode_real_as_string(C,NewMantissa,Exponent - LenDecimal). + +encode_real_as_string(_C,Mantissa,Exponent) + when is_list(Mantissa), is_integer(Exponent) -> + %% Remove trailing zeros in Mantissa and add this to Exponent + TruncMant = remove_trailing_zeros(Mantissa), + + ExpIncr = length(Mantissa) - length(TruncMant), + + ExpStr = integer_to_list(Exponent + ExpIncr), + + ExpBin = + case ExpStr of + "0" -> + <<"E+0">>; + _ -> + ExpB = list_to_binary(ExpStr), + <<$E,ExpB/binary>> + end, + ManBin = list_to_binary(TruncMant), + NR3 = 3, + {<>,2 + size(ManBin) + size(ExpBin)}. + +remove_trailing_zeros(IntStr) -> + case lists:dropwhile(fun($0)-> true; + (_) -> false + end, lists:reverse(IntStr)) of + [] -> + "0"; + ReversedIntStr -> + lists:reverse(ReversedIntStr) + end. + +truncate_zeros(Num) -> + truncate_zeros(Num,0). +truncate_zeros(0,Sum) -> + {0,Sum}; +truncate_zeros(M,Sum) -> + case M band 16#f =:= M band 16#e of + true -> truncate_zeros(M bsr 1,Sum+1); + _ -> {M,Sum} + 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, C, Tags, OptOrMand) -> + NewTags = new_tags(Tags,#tag{class=?UNIVERSAL,number=?N_REAL}), + decode_real_notag(Buffer, C, NewTags, OptOrMand). + +%% This interface used by RT_COMMON +decode_real(Buffer,Len) -> + decode_real2(Buffer,[],Len,0). + +decode_real_notag(Buffer, C, Tags, OptOrMand) -> + {_RestTags, {{_,Len}, Buffer0, Rb0}} = + check_tags_i(Tags, Buffer, OptOrMand), + decode_real2(Buffer0, C, Len, Rb0). + +decode_real2(Buffer, _C, 0, _RemBytes) -> + {0,Buffer}; +decode_real2(Buffer0, _C, Len, RemBytes1) -> + <> = Buffer0, + if + First =:= 2#01000000 -> {'PLUS-INFINITY', Buffer2}; + First =:= 2#01000001 -> {'MINUS-INFINITY', Buffer2}; +%% First =:= 2#00000000 -> {0, Buffer2}; + First =:= 1 orelse First =:= 2 orelse First =:= 3 -> + %% charcter string encoding of base 10 + {NRx,Rest} = split_binary(Buffer2,Len-1), + {binary_to_list(NRx),Rest,Len}; + true -> + %% have some check here to verify only supported bases (2) + %% not base 8 or 16 + <<_B7:1,Sign:1,BB:2,_FF:2,EE:2>> = <>, + Base = + case BB of + 0 -> 2; % base 2, only one so far + _ -> exit({error,{asn1, {non_supported_base, BB}}}) + end, + {FirstLen, {Exp, Buffer3,_Rb2}, RemBytes2} = + case EE 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 -> + <> = Buffer2, + { ExpLen1 + 2, + decode_integer2(ExpLen1, RestBuffer, RemBytes1), + RemBytes1+ExpLen1} + end, + %% io:format("FirstLen: ~w, Exp: ~w, Buffer3: ~w ~n", + + Length = Len - FirstLen, + <> = 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, + {{Mantissa, Base, Exp}, Buffer4, RemBytes2+RemBytes3} + 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 is_integer(Unused), is_binary(BinBits) -> + encode_bin_bit_string(C,Bin,NamedBitList,DoTag); +encode_bit_string(C, [FirstVal | RestVal], NamedBitList, DoTag) when is_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 is_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 is_integer(IntegerVal) -> + BitListVal = int_to_bitlist(IntegerVal), + encode_bit_string_bits(C, BitListVal, NamedBitList, DoTag); + +encode_bit_string(C, {Name,BitList}, NamedBitList, DoTag) when is_atom(Name) -> + encode_bit_string(C, BitList, NamedBitList, DoTag). + + + +int_to_bitlist(0) -> + []; +int_to_bitlist(Int) when is_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,<>); + Num when DoTag == [] -> % time optimization of next case + N = (size(BinBits)-1), + <> = 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), + <> = 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 is_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 is_list(BitListVal) -> + {Len,Unused,OctetList} = + case get_constraint(C,'SizeConstraint') of + no -> + encode_bitstring(BitListVal); + Constr={Min,_Max} when is_integer(Min) -> + 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({{_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; +encode_constr_bit_str_bits({Min,Max},BitListVal,_DoTag) -> + BitLen = length(BitListVal), + if + BitLen > Max -> + exit({error,{asn1,{bitstring_length,{{was,BitLen}, + {maximum,Max}}}}}); + BitLen < Min -> + exit({error,{asn1,{bitstring_length,{{was,BitLen}, + {minimum,Min}}}}}); + true -> + 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,<>,NamedNumberList, + RemovedBytes,BinOrOld) -> + L = Len - 1, + <> = 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,<>) -> + lists:sublist([B7,B6,B5,B4,B3,B2,B1,B0],8-Unused); +decode_bitstring2(Len, Unused, + <>) -> + [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 is_binary(OctetList) -> + dotag_universal(?N_OCTET_STRING,OctetList,size(OctetList)); +encode_octet_string(_C, OctetList, DoTag) when is_binary(OctetList) -> + dotag(DoTag, ?N_OCTET_STRING, {OctetList,size(OctetList)}); +encode_octet_string(_C, OctetList, DoTag) when is_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 is_list(OctetList) -> +% dotag(DoTag, ?N_OCTET_STRING, {OctetList,length(OctetList)}); +encode_octet_string(C, {Name,OctetList}, DoTag) when is_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 is_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 is_atom(Cname), is_tuple(V) -> + e_object_identifier(tuple_to_list(V)); +e_object_identifier({Cname, V}) when is_atom(Cname), is_list(V) -> + e_object_identifier(V); +e_object_identifier(V) when is_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). + + +%%%%%%%%%%% +%% 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(<>,Av,Al,Len) -> + dec_subidentifiers(T,0,[((Av bsl 7) + H)|Al],Len-1). + +%%============================================================================ +%% RELATIVE-OID, ITU_T X.690 Chapter 8.20 +%% +%% encode Relative Object Identifier +%%============================================================================ +encode_relative_oid({Name,Val},TagIn) when is_atom(Name) -> + encode_relative_oid(Val,TagIn); +encode_relative_oid(Val,TagIn) when is_tuple(Val) -> + encode_relative_oid(tuple_to_list(Val),TagIn); +encode_relative_oid(Val,[]) -> + {EncVal,Len} = enc_relative_oid(Val), + dotag_universal(?'N_RELATIVE-OID',EncVal,Len); +encode_relative_oid(Val, DoTag) -> + dotag(DoTag, ?'N_RELATIVE-OID', enc_relative_oid(Val)). + +enc_relative_oid(Val) -> + lists:mapfoldl(fun(X,AccIn) -> + {SO,L}=mk_object_val(X), + {SO,L+AccIn} + end + ,0,Val). + +%%============================================================================ +%% decode Relative Object Identifier value +%% (Buffer, HasTag, TotalLen) -> {{ObjId}, Remain, RemovedBytes} +%%============================================================================ +decode_relative_oid(Buffer, Tags, OptOrMand) -> + NewTags = new_tags(Tags,#tag{class=?UNIVERSAL, + number=?'N_RELATIVE-OID'}), + decode_relative_oid_notag(Buffer, NewTags, OptOrMand). + +decode_relative_oid_notag(Buffer, Tags, OptOrMand) -> + {_RestTags, {_FormLen={_,Len}, Buffer0, Rb0}} = + check_tags_i(Tags, Buffer, OptOrMand), + {ObjVals,Buffer01} = + dec_subidentifiers(Buffer0,0,[],Len), + {list_to_tuple(ObjVals), Buffer01, Rb0+Len}. + +%%============================================================================ +%% Restricted character string types, ITU_T X.690 Chapter 8.21 +%% +%% encode Numeric Printable Teletex Videotex Visible IA5 Graphic General strings +%%============================================================================ +encode_restricted_string(_C, OctetList, StringType, []) + when is_binary(OctetList) -> + dotag_universal(StringType,OctetList,size(OctetList)); +encode_restricted_string(_C, OctetList, StringType, DoTag) + when is_binary(OctetList) -> + dotag(DoTag, StringType, {OctetList, size(OctetList)}); +encode_restricted_string(_C, OctetList, StringType, []) + when is_list(OctetList) -> + dotag_universal(StringType,OctetList,length(OctetList)); +encode_restricted_string(_C, OctetList, StringType, DoTag) + when is_list(OctetList) -> + dotag(DoTag, StringType, {OctetList, length(OctetList)}); +encode_restricted_string(C,{Name,OctetL},StringType,DoTag) when is_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 is_list(Val) -> + {length(Val),Val}; + ?N_BIT_STRING when is_tuple(Val) -> + {(size(element(2,Val))*8) - element(1,Val),Val}; + _ when is_binary(Val) -> + {size(Val),binary_to_list(Val)}; + _ when is_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; + {{Lb,_Ub},_Ext=[MinExt|_]} when StrLen >= Lb; StrLen >= MinExt -> + 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 is_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 is_binary(Val),is_binary(AccVal) -> + {<>,AccRb+Rb}; + _ when is_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 -> + <> = Buffer,%%added for binary + UniString = mk_universal_string(binary_to_list(PreBuff)), + {UniString,RestBuff,InnerLen}; + ?N_BMPString -> + <> = Buffer,%%added for binary + BMP = mk_BMP_string(binary_to_list(PreBuff)), + {BMP,RestBuff,InnerLen}; + _ -> + <> = Buffer,%%added for binary + {PreBuff, RestBuff, InnerLen} + end. + + + +%%============================================================================ +%% encode Universal string +%%============================================================================ + +encode_universal_string(C, {Name, Universal}, DoTag) when is_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 UTF8 string +%%============================================================================ +encode_UTF8_string(_,UTF8String,[]) when is_binary(UTF8String) -> + dotag_universal(?N_UTF8String,UTF8String,size(UTF8String)); +encode_UTF8_string(_,UTF8String,DoTag) when is_binary(UTF8String) -> + dotag(DoTag,?N_UTF8String,{UTF8String,size(UTF8String)}); +encode_UTF8_string(_,UTF8String,[]) -> + dotag_universal(?N_UTF8String,UTF8String,length(UTF8String)); +encode_UTF8_string(_,UTF8String,DoTag) -> + dotag(DoTag,?N_UTF8String,{UTF8String,length(UTF8String)}). + + + +%%============================================================================ +%% decode UTF8 string +%%============================================================================ + +decode_UTF8_string(Buffer, Tags, OptOrMand) -> + NewTags = new_tags(Tags, #tag{class=?UNIVERSAL,number=?N_UTF8String}), + decode_UTF8_string_notag(Buffer, NewTags, OptOrMand). + +decode_UTF8_string_notag(Buffer, Tags, OptOrMand) -> + {RestTags, {FormLen, Buffer0, Rb0}} = + check_tags_i(Tags, Buffer, OptOrMand), + case FormLen of + {?CONSTRUCTED,Len} -> + %% an UTF8String may be encoded as a constructed type + {Buffer00,RestBytes} = split_list(Buffer0,Len), + {Val01, Buffer01, Rb01} = + decode_UTF8_string_notag(Buffer00,RestTags,OptOrMand), + {Buffer02, Rb02} = restbytes2(RestBytes,Buffer01,noext), + {Val01, Buffer02, Rb0+Rb01+Rb02}; + {_,Len} -> + <> = Buffer0, + {Result,RestBuff,Rb0 + Len} + end. + + +%%============================================================================ +%% encode BMP string +%%============================================================================ + +encode_BMP_string(C, {Name,BMPString}, DoTag) when is_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 is_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} -> + <> = 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 is_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} -> + <> = 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>>) -> + <> = 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 is_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, MandOrOpt) -> + check_if_valid_tag2_error(Tag,MandOrOpt); + +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. + +-spec(check_if_valid_tag2_error/2 :: (term(),atom()) -> no_return()). + +check_if_valid_tag2_error(Tag,mandatory) -> + exit({error,{asn1,{invalid_tag,Tag}}}); +check_if_valid_tag2_error(Tag,_) -> + exit({error,{asn1,{no_optional_tag,Tag}}}). + +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) -> 'ObjectDescriptor'; +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) -> + case Fun3(Bytes, OptOrMand) of + {_Term, _Remain, 0} -> + {lists:reverse(Acc),Bytes,Rb}; + {Term, Remain, Rb1} -> + Fun3(Bytes, OptOrMand), + decode_set(Rb+Rb1, indefinite, Remain, OptOrMand, Fun3, [Term|Acc]) + end; +%% {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) -> + case Fun3(Bytes, OptOrMand) of + {_Term, _Remain, 0} -> + {lists:reverse(Acc),Bytes,Rb}; + {Term, Remain, Rb1} -> + Fun3(Bytes, OptOrMand), + decode_set(Rb+Rb1, Num-Rb1, Remain, OptOrMand, Fun3, [Term|Acc]) + end. +%% {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) -> + <> = Bin, + {Int,Buffer2,RemovedBytes}; +%% decoding negative integer values. +decode_integer2(Len,<<1:1,B2:7,Bs/binary>>,RemovedBytes) -> + <> = <>, + 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,<>}; +concat_bit_binaries({U1,B1},{U2,B2}) -> + S1 = (size(B1) * 8) - U1, + S2 = (size(B2) * 8) - U2, + PadBits = 8 - ((S1+S2) rem 8), + {PadBits, <>}; +concat_bit_binaries(L1,L2) when is_list(L1),is_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/asn1/src/asn1rt_ber_bin_v2.erl b/lib/asn1/src/asn1rt_ber_bin_v2.erl new file mode 100644 index 0000000000..a3bb570282 --- /dev/null +++ b/lib/asn1/src/asn1rt_ber_bin_v2.erl @@ -0,0 +1,2037 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2002-2009. All Rights Reserved. +%% +%% 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 online 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. +%% +%% %CopyrightEnd% +%% +%% +-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, + skip_ExtensionAdditions/2]). +-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/3,decode_real/2, + 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_relative_oid/2,decode_relative_oid/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_UTF8_string/3,decode_UTF8_string/2, + 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,decode_selective/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 is_list(TlvVal) -> + %% constructed form of value + encode_tlv(TlvTag,TlvVal,?CONSTRUCTED); +encode({TlvTag,TlvVal}) -> + encode_tlv(TlvTag,TlvVal,?PRIMITIVE); +encode(Bin) when is_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), + <>. + +encode_tlv_tag(ClassTagNo,Form) -> + Class = ClassTagNo bsr 16, + encode_tag_val({Class bsl 6,Form,(ClassTagNo - (Class bsl 16))}). + +encode_tlv_val(TlvL) when is_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)}. + +%% asn1-1.6.8.1 +%% decode(B,driver) -> +%% case catch port_control(asn1_driver_port,2,B) of +%% Bin when is_binary(Bin) -> +%% binary_to_term(Bin); +%% List when is_list(List) -> handle_error(List,B); +%% {'EXIT',{badarg,Reason}} -> +%% asn1rt_driver_handler:load_driver(), +%% receive +%% driver_ready -> +%% case catch port_control(asn1_driver_port,2,B) of +%% Bin2 when is_binary(Bin2) -> binary_to_term(Bin2); +%% List when is_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. + +%% asn1-1.6.9 +decode(B,driver) -> + case catch control(?TLV_DECODE,B) of + Bin when is_binary(Bin) -> + binary_to_term(Bin); + List when is_list(List) -> handle_error(List,B); + {'EXIT',{badarg,_Reason}} -> + case asn1rt:load_driver() of + ok -> + case control(?TLV_DECODE,B) of + Bin when is_binary(Bin) -> binary_to_term(Bin); + List when is_list(List) -> handle_error(List,B) + end; + Err -> + Err + end + end. + + +handle_error([],_)-> + exit({error,{asn1,{"memory allocation problem"}}}); +handle_error([$1|_],L) -> % error in driver + exit({error,{asn1,L}}); +handle_error([$2|T],L) -> % error in driver due to wrong tag + exit({error,{asn1,{"bad tag after byte:",error_pos(T),L}}}); +handle_error([$3|T],L) -> % error in driver due to length error + exit({error,{asn1,{"bad length field after byte:", + error_pos(T),L}}}); +handle_error([$4|T],L) -> % error in driver due to indefinite length error + exit({error,{asn1, + {"indefinite length without end bytes after byte:", + error_pos(T),L}}}); +handle_error([$5|T],L) -> % error in driver due to indefinite length error + exit({error,{asn1,{"bad encoded value after byte:", + error_pos(T),L}}}); +handle_error(ErrL,L) -> + exit({error,{asn1,ErrL,L}}). + +error_pos([]) -> + "unknown position"; +error_pos([B])-> + B; +error_pos([B|Bs]) -> + BS = 8 * length(Bs), + B bsl BS + error_pos(Bs). +%% asn1-1.6.9 +control(Cmd, Data) -> + Port = asn1rt_driver_handler:client_port(), + erlang:port_control(Port, Cmd, Data). + +decode(Bin) when is_binary(Bin) -> + decode_primitive(Bin); +decode(Tlv) -> % assume it is a tlv + {Tlv,<<>>}. + + +decode_primitive(Bin) -> + {Form,TagNo,V,Rest} = decode_tag_and_length(Bin), + case Form of + 1 -> % constructed + {{TagNo,decode_constructed(V)},Rest}; + 0 -> % primitive + {{TagNo,V},Rest}; + 2 -> % constructed indefinite + {Vlist,Rest2} = decode_constructed_indefinite(V,[]), + {{TagNo,Vlist},Rest2} + end. + +decode_constructed(Bin) when byte_size(Bin) =:= 0 -> + []; +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_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_tag_and_length(Bin) of + {Form,TagNo,V,Rest} -> + decode_incomplete2(Form,TagNo,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_tag_and_length(Bin) of + {Form,TagNo,V,Rest} -> + decode_incomplete2(Form,TagNo,V,Directives,Rest); + _ -> + %{asn1_DEFAULT,Bin} + asn1_NOVALUE + end; +decode_primitive_incomplete([[opt,TagNo]],Bin) -> %optional + case decode_tag_and_length(Bin) of + {Form,TagNo,V,Rest} -> + decode_incomplete2(Form,TagNo,V,[],Rest); + _ -> + %{{TagNo,asn1_NOVALUE},Bin} + asn1_NOVALUE + end; +decode_primitive_incomplete([[opt,TagNo,Directives]],Bin) -> %optional + case decode_tag_and_length(Bin) of + {Form,TagNo,V,Rest} -> + decode_incomplete2(Form,TagNo,V,Directives,Rest); + _ -> + %{{TagNo,asn1_NOVALUE},Bin} + asn1_NOVALUE + end; +%% An optional that shall be undecoded +decode_primitive_incomplete([[opt_undec,Tag]],Bin) -> + case decode_tag_and_length(Bin) of + {_,Tag,_,_} -> + decode_incomplete_bin(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 + case decode_tag_and_length(Bin) of +% {{_Form,TagNo,_Len,_V},_R} -> + {_,TagNo,_,_} -> + decode_incomplete_bin(Bin); + _ -> + decode_primitive_incomplete(RestAlts,Bin) + end; +decode_primitive_incomplete([[alt,TagNo]|RestAlts],Bin) -> + case decode_tag_and_length(Bin) of + {_Form,TagNo,V,Rest} -> + {{TagNo,V},Rest}; + _ -> + decode_primitive_incomplete(RestAlts,Bin) + end; +decode_primitive_incomplete([[alt,TagNo,Directives]|RestAlts],Bin) -> + case decode_tag_and_length(Bin) of + {Form,TagNo,V,Rest} -> + decode_incomplete2(Form,TagNo,V,Directives,Rest); + _ -> + decode_primitive_incomplete(RestAlts,Bin) + end; +decode_primitive_incomplete([[alt_parts,TagNo]],Bin) -> + case decode_tag_and_length(Bin) of + {_Form,TagNo,V,Rest} -> + {{TagNo,V},Rest}; + _ -> + asn1_NOVALUE + end; +decode_primitive_incomplete([[alt_parts,TagNo]|RestAlts],Bin) -> + case decode_tag_and_length(Bin) of + {_Form,TagNo,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); +decode_primitive_incomplete([[parts,TagNo]|_RestTag],Bin) -> + case decode_tag_and_length(Bin) of + {_Form,TagNo,V,Rest} -> + {{TagNo,decode_parts_incomplete(V)},Rest}; + Err -> + {error,{asn1,"tag failure",TagNo,Err}} + end; +decode_primitive_incomplete([mandatory|RestTag],Bin) -> + {Form,TagNo,V,Rest} = decode_tag_and_length(Bin), + decode_incomplete2(Form,TagNo,V,RestTag,Rest); +%% A choice that is a toptype or a mandatory component of a +%% SEQUENCE or SET. +decode_primitive_incomplete([[mandatory|Directives]],Bin) -> + {Form,TagNo,V,Rest} = decode_tag_and_length(Bin), + decode_incomplete2(Form,TagNo,V,Directives,Rest); +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), + <> = 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(_Form=2,TagNo,V,TagMatch,_) -> + %% constructed indefinite length + {Vlist,Rest2} = decode_constr_indef_incomplete(TagMatch,V,[]), + {{TagNo,Vlist},Rest2}; +decode_incomplete2(1,TagNo,V,[TagMatch],Rest) when is_list(TagMatch) -> + {{TagNo,decode_constructed_incomplete(TagMatch,V)},Rest}; +decode_incomplete2(1,TagNo,V,TagMatch,Rest) -> + {{TagNo,decode_constructed_incomplete(TagMatch,V)},Rest}; +decode_incomplete2(0,TagNo,V,_TagMatch,Rest) -> + {{TagNo,V},Rest}. + +decode_constructed_incomplete([Tags=[Ts]],Bin) when is_list(Ts) -> + decode_constructed_incomplete(Tags,Bin); +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; Alt == alt_parts -> + {_Form,TagNo,V,Rest} = decode_tag_and_length(Bin), + case incomplete_choice_alt(TagNo,Directives) of + {alt_undec,_} -> + LenA = size(Bin)-size(Rest), + <> = Bin, + A; + {alt,InnerDirectives} -> + {Tlv,Rest} = decode_primitive_incomplete(InnerDirectives,V), + {TagNo,Tlv}; + {alt_parts,_} -> + [{TagNo,decode_parts_incomplete(V)}]; + no_match -> %% if a choice alternative was encoded that + %% was not specified in the config file, + %% thus decode component anonomous. + {Tlv,_}=decode_primitive(Bin), + Tlv + 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_constructed_incomplete([],Rest)]. + +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), + <> = Bin, + {IncBin,Ret}. + +incomplete_choice_alt(TagNo,[[Alt,TagNo]|Directives]) -> + {Alt,Directives}; +incomplete_choice_alt(TagNo,[D]) when is_list(D) -> + incomplete_choice_alt(TagNo,D); +incomplete_choice_alt(TagNo,[_H|Directives]) -> + incomplete_choice_alt(TagNo,Directives); +incomplete_choice_alt(_,[]) -> + no_match. + + + + +%% decode_selective(Pattern, Binary) the first argument is a pattern that tells +%% what to do with the next element the second is the BER encoded +%% message as a binary +%% Returns {ok,Value} or {error,Reason} +%% Value is a binary that in turn must be decoded to get the decoded +%% value. +decode_selective([],Binary) -> + {ok,Binary}; +decode_selective([skip|RestPattern],Binary)-> + {ok,RestBinary}=skip_tag(Binary), + {ok,RestBinary2}=skip_length_and_value(RestBinary), + decode_selective(RestPattern,RestBinary2); +decode_selective([[skip_optional,Tag]|RestPattern],Binary) -> + case skip_optional_tag(Tag,Binary) of + {ok,RestBinary} -> + {ok,RestBinary2}=skip_length_and_value(RestBinary), + decode_selective(RestPattern,RestBinary2); + missing -> + decode_selective(RestPattern,Binary) + end; +decode_selective([[choosen,Tag]],Binary) -> + return_value(Tag,Binary); +% case skip_optional_tag(Tag,Binary) of %may be optional/default +% {ok,RestBinary} -> +% {ok,Value} = get_value(RestBinary); +% missing -> +% {ok,<<>>} +% end; +decode_selective([[choosen,Tag]|RestPattern],Binary) -> + case skip_optional_tag(Tag,Binary) of + {ok,RestBinary} -> + {ok,Value} = get_value(RestBinary), + decode_selective(RestPattern,Value); + missing -> + {ok,<<>>} + end; +decode_selective(P,_) -> + {error,{asn1,{partial_decode,"bad pattern",P}}}. + +return_value(Tag,Binary) -> + {ok,{Tag,RestBinary}}=get_tag(Binary), + {ok,{LenVal,_RestBinary2}} = get_length_and_value(RestBinary), + {ok,<>}. + + +%% skip_tag and skip_length_and_value are rutines used both by +%% decode_partial_incomplete and decode_selective (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_optional_tag(<<>>,Binary) -> + {ok,Binary}; +skip_optional_tag(<>,<>) -> + skip_optional_tag(RestTag,Rest); +skip_optional_tag(_,_) -> + missing. + + + + +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). + +get_value(Binary) -> + case decode_length(Binary) of + {indefinite,RestBinary} -> + get_indefinite_value(RestBinary,[]); + {Length,RestBinary} -> + <> = RestBinary, + {ok,Value} + end. + +get_indefinite_value(<<0,0,_Rest/binary>>,Acc) -> + {ok,list_to_binary(lists:reverse(Acc))}; +get_indefinite_value(Binary,Acc) -> + {ok,{Tag,RestBinary}}=get_tag(Binary), + {ok,{LenVal,RestBinary2}} = get_length_and_value(RestBinary), + get_indefinite_value(RestBinary2,[LenVal,Tag|Acc]). + +get_tag(<>) -> + case H of + <<_:3,31:5>> -> + get_long_tag(Rest,[H]); + _ -> {ok,{H,Rest}} + end. +get_long_tag(<>,Acc) -> + case H of + <<0:1,_:7>> -> + {ok,{list_to_binary(lists:reverse([H|Acc])),Rest}}; + _ -> + get_long_tag(Rest,[H|Acc]) + end. + +get_length_and_value(Bin = <<0:1,Length:7,_T/binary>>) -> + <> = Bin, + {ok,{<>, Rest}}; +get_length_and_value(Bin = <<1:1,0:7,_T/binary>>) -> + get_indefinite_length_and_value(Bin); +get_length_and_value(<<1:1,LL:7,T/binary>>) -> + <> = T, + <> = Rest, + {ok,{<<1:1,LL:7,Length:LL/unit:8,Value/binary>>,Rest2}}. + +get_indefinite_length_and_value(<>) -> + get_indefinite_length_and_value(T,[H]). + +get_indefinite_length_and_value(<<0,0,Rest/binary>>,Acc) -> + {ok,{list_to_binary(lists:reverse(Acc)),Rest}}; +get_indefinite_length_and_value(Binary,Acc) -> + {ok,{Tag,RestBinary}}=get_tag(Binary), + {ok,{LenVal,RestBinary2}}=get_length_and_value(RestBinary), + get_indefinite_length_and_value(RestBinary2,[LenVal,Tag|Acc]). + + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% 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]) -> + V; +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. + +%%% +%% skips components that do not match a tag in Tags +skip_ExtensionAdditions([],_Tags) -> + []; +skip_ExtensionAdditions(TLV=[{Tag,_}|Rest],Tags) -> + case [X||X=T<-Tags,T==Tag] of + [] -> + %% skip this TLV and continue with next + skip_ExtensionAdditions(Rest,Tags); + _ -> + TLV + end. + + +%%=============================================================================== +%%=============================================================================== +%%=============================================================================== +%% Optionals, preset not filled optionals with asn1_NOVALUE +%%=============================================================================== +%%=============================================================================== +%%=============================================================================== + +% converts a list to a record if necessary +list_to_record(Name,List) when is_list(List) -> + list_to_tuple([Name|List]); +list_to_record(_Name,Tuple) when is_tuple(Tuple) -> + Tuple. + + +fixoptionals(OptList,Val) when is_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>>. + + +%%=============================================================================== +%% Decode a tag +%% +%% decode_tag(OctetListBuffer) -> {{Form, (Class bsl 16)+ TagNo}, RestOfBuffer, RemovedBytes} +%%=============================================================================== + +decode_tag_and_length(<>) when TagNo < 31 -> + {Form, (Class bsl 16) + TagNo, V, RestBuffer}; +decode_tag_and_length(<>) when TagNo < 31 -> + {2, (Class bsl 16) + TagNo, T, <<>>}; +decode_tag_and_length(<>) when TagNo < 31 -> + {Form, (Class bsl 16) + TagNo, V, T}; +decode_tag_and_length(<>) -> + {Form, (Class bsl 16) + TagNo, V, RestBuffer}; +decode_tag_and_length(<>) -> + {2, (Class bsl 16) + TagNo, T, <<>>}; +decode_tag_and_length(<>) -> + {Form, (Class bsl 16) + TagNo, V, T}; +decode_tag_and_length(<>) -> + TagNo = (TagPart1 bsl 7) bor TagPartLast, + {Length, RestBuffer} = decode_length(Buffer), + << V:Length/binary, RestBuffer2/binary>> = RestBuffer, + {Form, (Class bsl 16) + TagNo, V, RestBuffer2}; +decode_tag_and_length(<>) -> + {TagNo, Buffer1} = decode_tag(Buffer, 0), + {Length, RestBuffer} = decode_length(Buffer1), + << V:Length/binary, RestBuffer2/binary>> = RestBuffer, + {Form, (Class bsl 16) + TagNo, V, RestBuffer2}. + + + +%% last partial tag +decode_tag(<<0:1,PartialTag:7, Buffer/binary>>, TagAck) -> + TagNo = (TagAck bsl 7) bor PartialTag, + %%<> = <>, + {TagNo, Buffer}; +% more tags +decode_tag(<<_:1,PartialTag:7, Buffer/binary>>, TagAck) -> + TagAck1 = (TagAck bsl 7) bor PartialTag, + %%<> = <>, + 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 is_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 is_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 is_binary(Bin) -> + {InnerTlv,_} = decode(Bin), + InnerTlv; + TlvBytes -> TlvBytes + end. + + +decode_open_type_as_binary(Tlv,TagIn)-> + case match_tags(Tlv,TagIn) of + V when is_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 is_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 is_integer(Val) -> + encode_tags(Tag, encode_integer(C, Val)); +encode_integer(C,{Name,Val},Tag) when is_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 is_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), +% <> = Bin, + <> = Bin, + Int; +%% decoding negative integer values. +decode_integer(Bin = <<1:1,B2:7,Bs/binary>>) -> + Len = size(Bin), +% <> = <>, + <> = <>, + 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 is_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 is_integer(Val)-> + encode_tags(TagIn, encode_integer(false,Val)); +encode_enumerated({Name,Val}, TagIn) when is_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 is_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 is_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 is_integer(Val) -> + encode_tags(TagIn, encode_integer(C,Val)); + +encode_enumerated(C, {Name,Val}, NamedNumberList, TagIn) when is_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(_C,0, TagIn) -> + encode_tags(TagIn, {[],0}); +encode_real(_C,'PLUS-INFINITY', TagIn) -> + encode_tags(TagIn, {[64],1}); +encode_real(_C,'MINUS-INFINITY', TagIn) -> + encode_tags(TagIn, {[65],1}); +encode_real(C,Val, TagIn) when is_tuple(Val); is_list(Val) -> + encode_tags(TagIn, encode_real(C,Val)). + + + +encode_real(C,Val) -> + ?RT_COMMON:encode_real(C,Val). + + +%%============================================================================ +%% decode real value +%% +%% decode_real([OctetBufferList], tuple|value, tag|notag) -> +%% {{Mantissa, Base, Exp} | realval | PLUS-INFINITY | MINUS-INFINITY | 0, +%% RestBuff} +%% +%% only for base 2 and 10 decoding sofar!! +%%============================================================================ + +decode_real(Tlv, Tags) -> + Buffer = match_tags(Tlv,Tags), + decode_real_notag(Buffer). + +decode_real_notag(Buffer) -> + Len = + case Buffer of + Bin when is_binary(Bin) -> + size(Bin); + {_T,_V} -> + exit({error,{asn1,{real_not_in_primitive_form,Buffer}}}) + end, + {Val,_Rest,Len} = ?RT_COMMON:decode_real(Buffer,Len), + Val. +%% exit({error,{asn1, {unimplemented,real}}}). +%% decode_real2(Buffer, Form, size(Buffer)). + +% decode_real2(Buffer, Form, Len) -> +% <> = 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) +% <> = <>, +% 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 -> +% <> = Buffer2, +% <<_:ExpLen1/unit:8,RestBuffer2/binary>> = RestBuffer, +% { ExpLen1 + 2, +% decode_integer2(ExpLen1, RestBuffer, RemBytes1), +% RestBuffer2} +% end, +% Length = Len - FirstLen, +% <> = 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 is_integer(Unused), is_binary(BinBits) -> + encode_bin_bit_string(C,Bin,NamedBitList,TagIn); +encode_bit_string(C, [FirstVal | RestVal], NamedBitList, TagIn) when is_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 is_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 is_integer(IntegerVal) -> + BitListVal = int_to_bitlist(IntegerVal), + encode_bit_string_bits(C, BitListVal, NamedBitList, TagIn); + +encode_bit_string(C, {Name,BitList}, NamedBitList, TagIn) when is_atom(Name) -> + encode_bit_string(C, BitList, NamedBitList, TagIn). + + + +int_to_bitlist(0) -> + []; +int_to_bitlist(Int) when is_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 = <>, + encode_tags(TagIn,Bin,size(Bin)); + Num -> + N = (size(BinBits)-1), + <> = 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 is_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 is_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 is_integer(Min) -> + %% Max may be an integer or '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({{_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; +encode_constr_bit_str_bits({Min,Max},BitListVal,TagIn) -> + BitLen = length(BitListVal), + if + BitLen > Max -> + exit({error,{asn1,{bitstring_length,{{was,BitLen}, + {maximum,Max}}}}}); + BitLen < Min -> + exit({error,{asn1,{bitstring_length,{{was,BitLen}, + {minimum,Max}}}}}); + true -> + {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(<>,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,<>) -> + lists:sublist([B7,B6,B5,B4,B3,B2,B1,B0],8-Unused); +decode_bitstring2(Len, Unused, + <>) -> + [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 is_binary(OctetList) -> + encode_tags(TagIn, OctetList, size(OctetList)); +encode_octet_string(_C, OctetList, TagIn) when is_list(OctetList) -> + encode_tags(TagIn, OctetList, length(OctetList)); +encode_octet_string(C, {Name,OctetList}, TagIn) when is_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 is_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 is_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 is_atom(Cname), is_tuple(V) -> + e_object_identifier(tuple_to_list(V)); +e_object_identifier({Cname, V}) when is_atom(Cname), is_list(V) -> + e_object_identifier(V); +e_object_identifier(V) when is_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). + + +%%%%%%%%%%% +%% 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(<>,Av,Al) -> + dec_subidentifiers(T,0,[((Av bsl 7) + H)|Al]). + +%%============================================================================ +%% RELATIVE-OID, ITU_T X.690 Chapter 8.20 +%% +%% encode Relative Object Identifier +%%============================================================================ +encode_relative_oid({Name,Val},TagIn) when is_atom(Name) -> + encode_relative_oid(Val,TagIn); +encode_relative_oid(Val,TagIn) when is_tuple(Val) -> + encode_relative_oid(tuple_to_list(Val),TagIn); +encode_relative_oid(Val,TagIn) -> + encode_tags(TagIn, enc_relative_oid(Val)). + +enc_relative_oid(Tuple) when is_tuple(Tuple) -> + enc_relative_oid(tuple_to_list(Tuple)); +enc_relative_oid(Val) -> + lists:mapfoldl(fun(X,AccIn) -> + {SO,L}=mk_object_val(X), + {SO,L+AccIn} + end + ,0,Val). + +%%============================================================================ +%% decode Relative Object Identifier value +%% (Buffer, HasTag, TotalLen) -> {{ObjId}, Remain, RemovedBytes} +%%============================================================================ +decode_relative_oid(Tlv, Tags) -> + Val = match_tags(Tlv, Tags), + ObjVals = dec_subidentifiers(Val,0,[]), + list_to_tuple(ObjVals). + +%%============================================================================ +%% 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 is_binary(OctetList) -> + encode_tags(TagIn, OctetList, size(OctetList)); +encode_restricted_string(_C, OctetList, _StringType, TagIn) + when is_list(OctetList) -> + encode_tags(TagIn, OctetList, length(OctetList)); +encode_restricted_string(C,{Name,OctetL}, StringType, TagIn) when is_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 is_binary(Val),is_binary(AccVal) -> +% {<>,AccRb+Rb}; +% _ when is_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 is_list(Val) -> + {length(Val),Val}; + ?N_BIT_STRING when is_tuple(Val) -> + {(size(element(2,Val))*8) - element(1,Val),Val}; + _ when is_binary(Val) -> + {size(Val),binary_to_list(Val)}; + _ when is_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; + {{Lb,_Ub},_Ext=[Min|_]} when StrLen >= Lb; StrLen >= Min -> + 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 is_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 is_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 UTF8 string +%%============================================================================ + +encode_UTF8_string(_C,UTF8String,TagIn) when is_binary(UTF8String) -> + encode_tags(TagIn, UTF8String, size(UTF8String)); +encode_UTF8_string(_C,UTF8String,TagIn) -> + encode_tags(TagIn, UTF8String, length(UTF8String)). + + +%%============================================================================ +%% decode UTF8 string +%%============================================================================ + +decode_UTF8_string(Tlv,TagsIn) -> + Val = match_tags(Tlv, TagsIn), + case Val of + PartList = [_H|_T] -> % constructed val + collect_parts(PartList); + Bin -> + Bin + end. + + +%%============================================================================ +%% encode BMP string +%%============================================================================ + +encode_BMP_string(C, {Name,BMPString}, TagIn) when is_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 is_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 is_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>>) -> + <> = T, + {Length,Rest}. + + + +%%------------------------------------------------------------------------- +%% INTERNAL HELPER FUNCTIONS (not exported) +%%------------------------------------------------------------------------- + + +%% decoding postitive integer values. +decode_integer2(Len,Bin = <<0:1,_:7,_Bs/binary>>) -> + <> = Bin, + Int; +%% decoding negative integer values. +decode_integer2(Len,<<1:1,B2:7,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 is_list(L) -> + collect_parts(Rest,[collect_parts(L)|Acc]); +collect_parts([{?N_BIT_STRING,<>}|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,<>}|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/asn1/src/asn1rt_check.erl b/lib/asn1/src/asn1rt_check.erl new file mode 100644 index 0000000000..59a74a7078 --- /dev/null +++ b/lib/asn1/src/asn1rt_check.erl @@ -0,0 +1,361 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2001-2009. All Rights Reserved. +%% +%% 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 online 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. +%% +%% %CopyrightEnd% +%% +%% +-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]). + +-export([dynamicsort_SET_components/1, + dynamicsort_SETOF/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 is_integer(Value) -> + true; +check_int(DefValue,Value,NNL) when is_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 is_integer(H) -> +% true; +% check_bitstring(V,V,_) when is_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 is_integer(Int),is_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 is_integer(Int),is_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 is_integer(H1),is_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 is_integer(H1),is_atom(H2) -> + L3 = bit_list_to_nbl(L1,NBL,0,[]), + check_bitstring(L3,L2,NBL); +%% Both default value and user value as a list of atoms +check_bitstring(L1=[H1|T1],L2=[H2|_T2],_) + when is_atom(H1),is_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 is_atom(H1),is_integer(H2) -> + L3 = bit_list_to_nbl(L2,NBL,0,[]), + check_bitstring(L1,L3,NBL); +%% 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,<>}) when size(Rest) >= 1 -> + [B7,B6,B5,B4,B3,B2,B1,B0|cbs_to_bit_list({Unused,Rest})]; +cbs_to_bit_list({0,<>}) -> + [B7,B6,B5,B4,B3,B2,B1,B0]; +cbs_to_bit_list({Unused,Bin}) when size(Bin) == 1 -> + Used = 8-Unused, + <> = Bin, + int_to_bit_list(Int,[],Used). + + +check_octetstring(_,asn1_DEFAULT) -> + true; +check_octetstring(L,L) -> + true; +check_octetstring(L,Int) when is_list(L),is_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 is_tuple(DOI),is_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 is_integer(Int),is_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 is_list(V1),is_tuple(V2) -> + check_restrictedstring(V1,tuple_to_list(V2)); +check_restrictedstring(V1,V2) -> + throw({error,{restricted,string,V1,V2}}). + +transform_to_EXTERNAL1990(Val) when is_tuple(Val),size(Val) == 4 -> + transform_to_EXTERNAL1990(tuple_to_list(Val),[]); +transform_to_EXTERNAL1990(Val) when is_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,[Presentation_Cid,Transfer_syntax|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 is_list(Data_value)-> + list_to_tuple(lists:reverse([{'octet-aligned',Data_value}, + Data_val_desc|Acc])); +transform_to_EXTERNAL1990([Data_val_desc,Data_value],Acc) + when is_binary(Data_value)-> + list_to_tuple(lists:reverse([{'octet-aligned',binary_to_list(Data_value)}, + Data_val_desc|Acc])); +transform_to_EXTERNAL1990([Data_value],Acc) when is_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 is_list(Val);is_binary(Val) -> + {'EXTERNAL',Identification,Data_v_desc,Val}; + + _ -> + V + end. + + +%% dynamicsort_SET_components(Arg) -> +%% Res Arg -> list() +%% Res -> list() +%% Sorts the elements in Arg according to the encoded tag in +%% increasing order. +dynamicsort_SET_components(ListOfEncCs) -> + BinL = lists:map(fun(X) -> list_to_binary(X) end,ListOfEncCs), + TagBinL = lists:map(fun(X) -> + {{T,_,TN},_,_} = asn1rt_ber_bin:decode_tag(X), + {{T,TN},X} + end,BinL), + ClassTagNoSorted = lists:keysort(1,TagBinL), + lists:map(fun({_,El}) -> El end,ClassTagNoSorted). + +%% dynamicsort_SETOF(Arg) -> Res +%% Arg -> list() +%% Res -> list() +%% Sorts the elements in Arg in increasing size +dynamicsort_SETOF(ListOfEncVal) -> + BinL = lists:map(fun(L) when is_list(L) -> list_to_binary(L); + (B) -> B end,ListOfEncVal), + lists:sort(BinL). diff --git a/lib/asn1/src/asn1rt_driver_handler.erl b/lib/asn1/src/asn1rt_driver_handler.erl new file mode 100644 index 0000000000..c95b243ae0 --- /dev/null +++ b/lib/asn1/src/asn1rt_driver_handler.erl @@ -0,0 +1,141 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2002-2009. All Rights Reserved. +%% +%% 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 online 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. +%% +%% %CopyrightEnd% +%% +%% + +-module(asn1rt_driver_handler). + +-include("asn1_records.hrl"). + +-export([load_driver/0,unload_driver/0,client_port/0]). + +%% Internal exports +-export([init/2]). + +%% Macros +-define(port_names, + { asn1_drv01, asn1_drv02, asn1_drv03, asn1_drv04, + asn1_drv05, asn1_drv06, asn1_drv07, asn1_drv08, + asn1_drv09, asn1_drv10, asn1_drv11, asn1_drv12, + asn1_drv13, asn1_drv14, asn1_drv15, asn1_drv16 }). + +%%% -------------------------------------------------------- +%%% Interface Functions. +%%% -------------------------------------------------------- +load_driver() -> + load_driver(noreason). + +load_driver(Reason) -> + Ref = make_ref(), + case whereis(asn1_driver_owner) of % to prevent unnecessary spawn + Pid when is_pid(Pid) -> + asn1_driver_owner ! {self(),Ref,are_you_ready}, + receive + {Ref,driver_ready} -> + ok + after 10000 -> + {error,{timeout,waiting_for_drivers}} + end; + _ -> + {_,Mref} = spawn_monitor(asn1rt_driver_handler, init, [self(),Ref]), + receive + {'DOWN', Mref, _, _, NewReason} -> + case NewReason of + Reason -> {error,Reason}; + _ -> load_driver(NewReason) + end; + {Ref,driver_ready} -> + erlang:demonitor(Mref), + ok; + {Ref,Error = {error,_Reason}} -> + erlang:demonitor(Mref), + Error + after 10000 -> %% 10 seconds + {error,{timeout,waiting_for_drivers}} + end + end. + +init(FromPid,FromRef) -> + register(asn1_driver_owner,self()), + Dir = filename:join([code:priv_dir(asn1),"lib"]), + case catch erl_ddll:load_driver(Dir,asn1_erl_drv) of + ok -> + Result = open_named_ports(), + catch (FromPid ! {FromRef,Result}), + loop(Result); + {error,Err} -> % if erl_ddll:load_driver fails + ForErr = erl_ddll:format_error(Err), + OSDir = filename:join(Dir,erlang:system_info(system_architecture)), + case catch erl_ddll:load_driver(OSDir,asn1_erl_drv) of + ok -> + Result = open_named_ports(), + catch (FromPid ! {FromRef,Result}), + loop(Result); + {error,Err2} -> +% catch (FromPid ! {FromRef,Error}) + ForErr2 = erl_ddll:format_error(Err2), + catch (FromPid ! {FromRef,{error,{{Dir,ForErr},{OSDir,ForErr2}}}}) + end + end. + + +open_named_ports() -> + open_named_ports(size(?port_names)). + +open_named_ports(0) -> + driver_ready; +open_named_ports(N) -> + case catch open_port({spawn,"asn1_erl_drv"},[]) of + {'EXIT',Reason} -> + {error,{port_error,Reason}}; + Port -> + register(element(N,?port_names),Port), + open_named_ports(N-1) + end. + +loop(Result) -> + receive + {_FromPid,_FromRef,unload} -> + close_ports(size(?port_names)), + erl_ddll:unload_driver(asn1_erl_drv), + ok; + {FromPid,FromRef,are_you_ready} -> + catch (FromPid ! {FromRef,driver_ready}), + loop(Result); + _ -> + loop(Result) + end. + +unload_driver() -> + case whereis(asn1_driver_owner) of + Pid when is_pid(Pid) -> + Pid ! {self(),make_ref(),unload}, + ok; + _ -> + ok + end. + +close_ports(0) -> + ok; +close_ports(N) -> + element(N,?port_names) ! {self(), close}, %% almost same as port_close(Name) + close_ports(N-1). + +client_port() -> + element(erlang:system_info(scheduler_id) rem size(?port_names) + 1, + ?port_names). diff --git a/lib/asn1/src/asn1rt_per_bin.erl b/lib/asn1/src/asn1rt_per_bin.erl new file mode 100644 index 0000000000..6bbca26209 --- /dev/null +++ b/lib/asn1/src/asn1rt_per_bin.erl @@ -0,0 +1,2287 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2001-2009. All Rights Reserved. +%% +%% 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 online 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. +%% +%% %CopyrightEnd% +%% +%% +-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, + encode_real/1, decode_real/1, + encode_relative_oid/1, decode_relative_oid/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_UTF8String/1, decode_UTF8String/1, + 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 is_tuple(Tuple) -> + Tuple; +list_to_record(Name,List) when is_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 is_tuple(Val) -> + fixoptionals1(OptList,Val,[]); + +fixoptionals(OptList,Val) when is_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 is_tuple(Val) -> + Bits = fixoptionals(OptList,Val,0), + {Val,{bits,OptLength,Bits}}; + +fixoptionals([],_Val,Acc) -> + %% Optbits + Acc; +fixoptionals([{Pos,DefVal}|Ot],Val,Acc) -> + case element(Pos,Val) of + asn1_DEFAULT -> fixoptionals(Ot,Val,Acc bsl 1); + DefVal -> fixoptionals(Ot,Val,Acc bsl 1); + _ -> fixoptionals(Ot,Val,(Acc bsl 1) + 1) + end; +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 is_tuple(Bytes) -> + getbit(Bytes); +getext(Bytes) when is_binary(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 is_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, + <> = Bin, + {{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,<>},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 is_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 -> + <> = 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,Buffer}}; +getbit({Used,Buffer}) -> + Unused = (8 - Used) - 1, + <<_:Used,B:1,_:Unused,_/binary>> = Buffer, + {B,{Used+1,Buffer}}; +getbit(Buffer) when is_binary(Buffer) -> + getbit({0,Buffer}). + + +getbits({0,Buffer},Num) when (Num rem 8) == 0 -> + <> = 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 is_binary(Bin) -> + getbits({0,Bin},Num). + + + +% getoctet(Bytes) when is_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) -> + <> = Buffer, + {Val,{0,RestBin}}; +getoctets({U,<<_Padding,Rest/binary>>},Num) when U /= 0 -> + getoctets({0,Rest},Num); +getoctets(Buffer,Num) when is_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)-> + <> = 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 is_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 is_integer(N), Len1 > 1 -> + [{bits,1,0}, % the value is in the root set + encode_integer([{'ValueRange',{0,Len1-1}}],N)]; + N when is_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 is_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 is_integer(N), Len > 1 -> + encode_integer([{'ValueRange',{0,Len-1}}],N); + N when is_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 is_integer(Int),C == size(BinBits) -> + {BinBits,{0,Bin}}; + Int when is_integer(Int) -> + exit({error,{asn1,{illegal_value,C,BinBits}}}) + end; +decode_fragmented_bits(<<0:1,Len:7,Bin/binary>>,C,Acc) -> + Result = {BinBits,{Used,_Rest}} = + case (Len rem 8) of + 0 -> + <> = Bin, + {list_to_binary(lists:reverse([Value|Acc])),{0,Bin2}}; + Rem -> + Bytes = Len div 8, + U = 8 - Rem, + <> = Bin, + {list_to_binary(lists:reverse([Bits1 bsl U,Value|Acc])), + {Rem,<>}} + end, + case C of + Int when is_integer(Int),C == (size(BinBits) - ((8 - Used) rem 8)) -> + Result; + Int when is_integer(Int) -> + exit({error,{asn1,{illegal_value,C,BinBits}}}) + end. + + +decode_fragmented_octets({0,Bin},C) -> + decode_fragmented_octets(Bin,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 is_integer(Int), C == size(Octets) -> + {Octets,{0,Bin}}; + Int when is_integer(Int) -> + exit({error,{asn1,{illegal_value,C,Octets}}}) + end; +decode_fragmented_octets(<<0:1,Len:7,Bin/binary>>,C,Acc) -> + <> = Bin, + BinOctets = list_to_binary(lists:reverse([Value|Acc])), + case C of + Int when is_integer(Int),size(BinOctets) == Int -> + {BinOctets,Bin2}; + Int when is_integer(Int) -> + exit({error,{asn1,{illegal_value,C,BinOctets}}}) + 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 is_list(Val) -> + Bin = list_to_binary(Val), + [encode_length(undefined,size(Bin)),{octets,Bin}]; % octets implies align +encode_open_type(_C, Val) when is_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 is_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 is_integer(V) -> + encode_integer(C,V); +encode_integer(C,{Name,V},NamedNumberList) when is_atom(Name) -> + encode_integer(C,V,NamedNumberList). + +encode_integer(C,{Name,Val}) when is_atom(Name) -> + encode_integer(C,Val); + +encode_integer([{Rc,_Ec}],Val) when is_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 is_list(C) -> + case get_constraint(C,'SingleValue') of + no -> + encode_integer1(C,Val); + V when is_integer(V),V == Val -> + []; % a type restricted to a single value encodes to nothing + V when is_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 is_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 is_integer(V) -> + {V,Buffer}; + V when is_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 is_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 is_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 is_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 == 1 -> + []; + 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,<>}; + 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 == 1 -> + {0,Buffer}; + 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 is_integer(Lb), Lb >= 0 -> % Ub > 65535 + encode_length(undefined,Len); +encode_length({Vr={Lb,Ub},Ext},Len) + when Ub =< 65535 ,Lb >= 0, Len= + %% constrained extensible + [{bits,1,0},encode_constrained_number(Vr,Len)]; +encode_length({{Lb,_Ub},Ext},Len) when is_list(Ext) -> + [{bits,1,1},encode_semi_constrained_number(Lb,Len)]; +encode_length(SingleValue,_Len) when is_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(Buffer,{Lb,_}) when is_integer(Lb), Lb >= 0 -> % Ub > 65535 + decode_length(Buffer,undefined); +decode_length(Buffer,{VR={_Lb,_Ub},Ext}) when is_list(Ext) -> + case getbit(Buffer) of + {0,Buffer2} -> + decode_length(Buffer2, VR); + {1,Buffer2} -> + decode_length(Buffer2, undefined) + end; +%% {0,Buffer2} = getbit(Buffer), +%% decode_length(Buffer2, VR); + + +%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,<>}}; + <<_: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 is_integer(SingleValue) -> + {SingleValue,Buffer}. + + + % X.691:11 +encode_boolean(true) -> + {bits,1,1}; +encode_boolean(false) -> + {bits,1,0}; +encode_boolean({Name,Val}) when is_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 is_tuple(Ntup1), is_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 is_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 is_atom(NewVal) -> {NewVal,Buffer3}; + _ -> {{asn1_enum,Val},Buffer3} + end + end; + +decode_enumerated(Buffer,C,NamedNumberTup) when is_tuple(NamedNumberTup) -> + {Val,Buffer2} = decode_integer(Buffer,C), + case catch (element(Val+1,NamedNumberTup)) of + NewVal when is_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 is_integer(Unused), + is_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 is_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 is_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 is_integer(V),V=<16 -> % fixed length 16 bits or less +% pad_list(V,BitList); +% V when is_integer(V) -> % fixed length 16 bits or more +% [align,pad_list(V,BitList)]; % should be another case for V >= 65537 +% {Lb,Ub} when is_integer(Lb),is_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 is_list(BitListValue) -> + BitListToBinary = + %% fun that transforms a list of 1 and 0 to a tuple: + %% {UnusedBitsInLastByte, Binary} + fun([1|T],Acc,N,Fun) -> + Fun(T,(Acc bsl 1)+1,N+1,Fun); + ([0|T],Acc,N,Fun) -> + Fun(T,(Acc bsl 1),N+1,Fun); + ([_H|_T],_,_,_) -> + exit({error,{asn1,{bitstring_bitlist,BitListValue}}}); + ([],Acc,N,_) -> + Unused = (8 - (N rem 8)) rem 8, + {Unused,<>} + end, + UnusedAndBin = + case NamedBitList of + [] -> % dont remove trailing zeroes + BitListToBinary(BitListValue,0,0,BitListToBinary); + _ -> + BitListToBinary(lists:reverse( + lists:dropwhile(fun(0)->true;(_)->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 is_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 is_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 is_integer(V),V=<16 -> + {Unused2,Bin2} = pad_list(V,UnusedAndBin1), + <> = Bin2, + {bits,V,BitVal}; + V when is_integer(V) -> + [align, pad_list(V, UnusedAndBin1)]; + {Lb,Ub} when is_integer(Lb),is_integer(Ub) -> + [encode_length({Lb,Ub},size(Bin1)*8 - Unused1), + align,UnusedAndBin1]; + {{Fix,Fix},L} when is_integer(Fix),is_list(L) -> + %% X.691 § 15.6, the rest of this paragraph is covered by + %% the last, ie. Sc, clause in this case + case (size(Bin1)*8)-Unused1 of + Size when Size =< Fix, Fix =< 16 -> + {Unused2,Bin2} = pad_list(Fix,UnusedAndBin), + <> = Bin2, + [{bits,1,0},{bits,Fix,BitVal}]; + Size when Size =< Fix -> + [{bits,1,0},align, pad_list(Fix, UnusedAndBin1)]; + Size -> + [{bits,1,1},encode_length(undefined,Size), + align,UnusedAndBin1] + end; + 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,<<>>},C) -> + case C of + Int when is_integer(Int),Int > 0 -> + %% this padding see OTP-4353 + pad_list(Int,{0,<<>>}); + _ -> {0,<<>>} + end; +remove_trailing_bin(NamedNumberList, {_Unused,Bin},C) -> + Size = size(Bin)-1, + <> = Bin, + %% clear the Unused bits to be sure + 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 is_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 is_integer(Lb) -> + Lb; +lower_bound({Lb,_}) when is_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 is_integer(V),V=<16 -> %fixed length 16 bits or less + compact_bit_string(Buffer,V,NamedNumberList); + V when is_integer(V),V=<65536 -> %fixed length > 16 bits + Bytes2 = align(Buffer), + compact_bit_string(Bytes2,V,NamedNumberList); + V when is_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 is_integer(Lb),is_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); + {{Fix,Fix},L} = Sc when is_list(L), is_integer(Fix), Fix =< 16 -> + %% X.691 §15.6, special case of extension marker + case decode_length(Buffer,Sc) of + {Len,Bytes2} when Len > Fix -> + Bytes3 = align(Bytes2), + compact_bit_string(Bytes3,Len,NamedNumberList); + {Len,Bytes2} -> + compact_bit_string(Bytes2,Len,NamedNumberList) + end; + 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 is_integer(Lb),is_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 is_integer(V),V=<16 -> % fixed length 16 bits or less + bit_list_or_named(Buffer,V,NamedNumberList); + V when is_integer(V),V=<65536 -> + Bytes2 = align(Buffer), + bit_list_or_named(Bytes2,V,NamedNumberList); + V when is_integer(V) -> + Bytes2 = align(Buffer), + {BinBits,_} = decode_fragmented_bits(Bytes2,V), + bit_list_or_named(BinBits,V,NamedNumberList); + {{Fix,Fix},L} = Sc when is_list(L), is_integer(Fix), Fix =< 16 -> + %% X.691 §15.6, special case of extension marker + case decode_length(Buffer,Sc) of + {Len,Bytes2} when Len > Fix -> + Bytes3 = align(Bytes2), + bit_list_or_named(Bytes3,Len,NamedNumberList); + {Len,Bytes2} when Len > 16 -> + Bytes3 = align(Bytes2), + bit_list_or_named(Bytes3,Len,NamedNumberList); + {Len,Bytes2} -> + bit_list_or_named(Bytes2,Len,NamedNumberList) + end; + Sc -> %% X.691 §15.6, 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 is_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,<>}); +pad_list(N,N,In={_,_}) -> + In. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% X.691:16 +%% encode_octet_string(Constraint,ExtensionMarker,Val) +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +encode_octet_string(C,Val) -> + encode_octet_string2(C,Val). + +encode_octet_string2(C,{_Name,Val}) -> + encode_octet_string2(C,Val); +encode_octet_string2(C,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 is_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(<>),Bytes2}; + {_,0} -> + {[],Bytes}; + Sv when is_integer(Sv), Sv =<65535 -> % fixed length + getoctets_as_list(Bytes,Sv); + Sv when is_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 is_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 is_atom(Name) -> + encode_restricted_string(aligned,Val); + +encode_restricted_string(aligned,Val) when is_list(Val)-> + [encode_length(undefined,length(Val)),{octets,Val}]. + +encode_known_multiplier_string(aligned,StringType,C,_Ext,{Name,Val}) when is_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 is_integer(Ub), Ub*NumBits =< 16 -> + Result; + 0 -> + []; + Ub when is_integer(Ub),Ub =<65535 -> % fixed length + [align,Result]; + {Ub,Lb} -> + [encode_length({Ub,Lb},length(Val)),align,Result]; + Vl when is_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 is_integer(Ub), Ub*NumBits =< 16 -> + chars_decode(Bytes,NumBits,StringType,C,Ub); + Ub when is_integer(Ub),Ub =<65535 -> % fixed length + Bytes1 = align(Bytes), + chars_decode(Bytes1,NumBits,StringType,C,Ub); + 0 -> + {[],Bytes}; + Vl when is_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 is_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(<>)) + 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]). + + +%% UTF8String +encode_UTF8String(Val) when is_binary(Val) -> + [encode_length(undefined,size(Val)),{octets,Val}]; +encode_UTF8String(Val) -> + Bin = list_to_binary(Val), + encode_UTF8String(Bin). + +decode_UTF8String(Bytes) -> + {Len,Bytes2} = decode_length(Bytes,undefined), + {Octs,Bytes3} = getoctets_as_list(Bytes2,Len), + {list_to_binary(Octs),Bytes3}. + + + % X.691:17 +encode_null(_) -> []. % encodes to nothing +%encode_null({Name,Val}) when is_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 is_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 is_atom(Cname),is_tuple(V) -> + e_object_identifier(tuple_to_list(V)); +e_object_identifier({Cname,V}) when is_atom(Cname),is_list(V) -> + e_object_identifier(V); +e_object_identifier(V) when is_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]; +e_object_element(Num) -> + [e_o_e(Num bsr 7)|[Num band 2#1111111]]. +e_o_e(Num) when Num < 128 -> + Num bor 2#10000000; +e_o_e(Num) -> + [e_o_e(Num bsr 7)|[(Num band 2#1111111) bor 2#10000000]]. + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% 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). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% encode_relative_oid(Val) -> CompleteList +%% encode_relative_oid({Name,Val}) -> CompleteList +encode_relative_oid({Name,Val}) when is_atom(Name) -> + encode_relative_oid(Val); +encode_relative_oid(Val) when is_tuple(Val) -> + encode_relative_oid(tuple_to_list(Val)); +encode_relative_oid(Val) when is_list(Val) -> + Octets = list_to_binary([e_object_element(X)||X <- Val]), + [encode_length(undefined,size(Octets)),{octets,Octets}]. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% decode_relative_oid(Val) -> {ROID,Rest} +%% decode_relative_oid({Name,Val}) -> {ROID,Rest} +decode_relative_oid(Bytes) -> + {Len,Bytes2} = decode_length(Bytes,undefined), + {Octs,Bytes3} = getoctets_as_list(Bytes2,Len), + ObjVals = dec_subidentifiers(Octs,0,[]), + {list_to_tuple(ObjVals),Bytes3}. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% encode_real(Val) -> CompleteList +%% encode_real({Name,Val}) -> CompleteList +encode_real({Name,Val}) when is_atom(Name) -> + encode_real(Val); +encode_real(Real) -> + {EncVal,Len} = ?RT_COMMON:encode_real([],Real), + [encode_length(undefined,Len),{octets,EncVal}]. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% decode_real(Val) -> {REALvalue,Rest} +%% decode_real({Name,Val}) -> {REALvalue,Rest} +decode_real(Bytes) -> + {Len,{0,Bytes2}} = decode_length(Bytes,undefined), + {RealVal,Rest,Len} = ?RT_COMMON:decode_real(Bytes2,Len), + {RealVal,{0,Rest}}. + + +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 is_list(InList) -> +% complete1(InList,[]); +% complete1(InList) -> +% complete1([InList],[]). + +% complete1([{debug,_}|T], Acc) -> +% complete1(T,Acc); +% complete1([H|T],Acc) when is_list(H) -> +% {NewH,NewAcclen} = complete1(H,Acc), +% complete1(T,NewH,NewAcclen); + +% complete1([{0,Bin}|T],Acc,0) when is_binary(Bin) -> +% complete1(T,[Bin|Acc],0); +% complete1([{Unused,Bin}|T],Acc,0) when is_integer(Unused),is_binary(Bin) -> +% Size = size(Bin)-1, +% <> = Bin, +% complete1(T,[(B bsr Unused),Bs|Acc],8-Unused); +% complete1([{Unused,Bin}|T],[Hacc|Tacc],Acclen) when is_integer(Unused),is_binary(Bin) -> +% Rest = 8 - Acclen, +% Used = 8 - Unused, +% case size(Bin) of +% 1 -> +% if +% Rest >= Used -> +% <> = Bin, +% complete1(T,[(Hacc bsl Used) + B|Tacc], +% (Acclen+Used) rem 8); +% true -> +% LeftOver = 8 - Rest - Unused, +% <> = Bin, +% complete1(T,[Val1,(Hacc bsl Rest) + Val2|Tacc], +% (Acclen+Used) rem 8) +% end; +% N -> +% if +% Rest == Used -> +% N1 = N - 1, +% <> = Bin, +% complete1(T,[Bs,(Hacc bsl Rest) + B|Tacc],0); +% Rest > Used -> +% N1 = N - 2, +% N2 = (8 - Rest) + Used, +% <> = Bin, +% complete1(T,[B2,Bytes,(Hacc bsl Rest) + B1|Tacc], +% (Acclen + Used) rem 8); +% true -> % Rest < Used +% N1 = N - 1, +% N2 = Used - Rest, +% <> = 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 ,is_integer(Val) -> +% % complete1([{octets,<>}|T],Acc,Acclen); +% complete1([{octets,N,Val}|T],Acc,Acclen) when N =< 4 ,is_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 is_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 is_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 is_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 is_list(InList) -> + complete1(InList,[],[]); +complete1(InList) -> + complete1([InList],[],[]). + +complete1([],Acc,Bacc) -> + {Acc,Bacc}; +complete1([H|T],Acc,Bacc) when is_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 is_binary(Bin) -> + complete1(T,[Acc|Bin],[]); +complete1([{Unused,Bin}|T],Acc,[]) when is_integer(Unused),is_binary(Bin) -> + Size = size(Bin)-1, + <> = Bin, + NumBits = 8-Unused, + complete1(T,[Acc|Bs],[[B bsr Unused]|NumBits]); +complete1([{Unused,Bin}|T],Acc,Bacc) when is_integer(Unused),is_binary(Bin) -> + Size = size(Bin)-1, + <> = 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) -> +% <>; +% complete_bytes2([{V2,B2},{V1,B1}],PadBits) -> +% <>; +% complete_bytes2([{V3,B3},{V2,B2},{V1,B1}],PadBits) -> +% <>; +% complete_bytes2([{V4,B4},{V3,B3},{V2,B2},{V1,B1}],PadBits) -> +% <>; +% complete_bytes2([{V5,B5},{V4,B4},{V3,B3},{V2,B2},{V1,B1}],PadBits) -> +% <>; +% complete_bytes2([{V6,B6},{V5,B5},{V4,B4},{V3,B3},{V2,B2},{V1,B1}],PadBits) -> +% <>; +% complete_bytes2([{V7,B7},{V6,B6},{V5,B5},{V4,B4},{V3,B3},{V2,B2},{V1,B1}],PadBits) -> +% <>; +% complete_bytes2([{V8,B8},{V7,B7},{V6,B6},{V5,B5},{V4,B4},{V3,B3},{V2,B2},{V1,B1}],PadBits) -> +% <>. + + + + + + diff --git a/lib/asn1/src/asn1rt_per_bin_rt2ct.erl b/lib/asn1/src/asn1rt_per_bin_rt2ct.erl new file mode 100644 index 0000000000..f4aecf9322 --- /dev/null +++ b/lib/asn1/src/asn1rt_per_bin_rt2ct.erl @@ -0,0 +1,1885 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2002-2009. All Rights Reserved. +%% +%% 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 online 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. +%% +%% %CopyrightEnd% +%% +%% +-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, + encode_real/1, decode_real/1, + encode_relative_oid/1, decode_relative_oid/1, + complete/1]). + + +-export([encode_open_type/2, decode_open_type/2]). + +-export([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_ObjectDescriptor/2, decode_ObjectDescriptor/1, + encode_UTF8String/1,decode_UTF8String/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 is_tuple(Tuple) -> + Tuple; +list_to_record(Name,List) when is_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) -> + [0]; +setchoiceext(false) -> + [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 is_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,DefVal}|Ot],Val,Acc) -> + case element(Pos,Val) of + asn1_DEFAULT -> fixoptionals(Ot,Val,[0|Acc]); + DefVal -> fixoptionals(Ot,Val,[0|Acc]); + _ -> fixoptionals(Ot,Val,[1|Acc]) + end; +fixoptionals([Pos|Ot],Val,Acc) -> + case element(Pos,Val) of + asn1_NOVALUE -> fixoptionals(Ot,Val,[0|Acc]); + asn1_DEFAULT -> fixoptionals(Ot,Val,[0|Acc]); + _ -> fixoptionals(Ot,Val,[1|Acc]) + end. + + +getext(Bytes) when is_bitstring(Bytes) -> + getbit(Bytes). + +getextension(0, Bytes) -> + {<<>>,Bytes}; +getextension(1, Bytes) -> + {Len,Bytes2} = decode_small_length(Bytes), + getbits_as_binary(Len,Bytes2).% {Bin,Bytes3}. + +fixextensions({ext,ExtPos,ExtNum},Val) -> + case fixextensions(ExtPos,ExtNum+ExtPos,Val,0) of + 0 -> []; + 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,ExtensionBitstr) when is_bitstring(ExtensionBitstr) -> + Prev = Nr - 1, + case ExtensionBitstr of + <<_:Prev,1:1,_/bitstring>> -> + {_,Bytes2} = decode_open_type(Bytes,[]), + skipextensions(Bytes2, Nr+1, ExtensionBitstr); + <<_:Prev,0:1,_/bitstring>> -> + skipextensions(Bytes, Nr+1, ExtensionBitstr); + _ -> + 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) -> + getbits_as_binary(NumOpt,Bytes). + +%% new version used in generates from r8b_patch/3 and later +getoptionals2(Bytes,NumOpt) -> + {_,_} = getbits(Bytes,NumOpt). + + +%% getbits_as_binary(Num,Bytes) -> {Bin,Rest} +%% Num = integer(), +%% Bytes = bitstring(), +%% Bin = bitstring(), +%% Rest = bitstring() +getbits_as_binary(Num,Bytes) when is_bitstring(Bytes) -> + <> = Bytes, + {BS,Rest}. + +getbits_as_list(Num,Bytes) when is_bitstring(Bytes) -> + <> = Bytes, + {[ B || <> <= BitStr],Rest}. + + +getbit(Buffer) -> + <> = Buffer, + {B,Rest}. + + +getbits(Buffer,Num) when is_bitstring(Buffer) -> + <> = Buffer, + {Bs,Rest}. + +align(Bin) when is_binary(Bin) -> + Bin; +align(BitStr) when is_bitstring(BitStr) -> + AlignBits = bit_size(BitStr) rem 8, + <<_:AlignBits,Rest/binary>> = BitStr, + Rest. + + +%% First align buffer, then pick the first Num octets. +%% Returns octets as an integer with bit significance as in buffer. +getoctets(Buffer,Num) when is_binary(Buffer) -> + <> = Buffer, + {Val,RestBin}; +getoctets(Buffer,Num) when is_bitstring(Buffer) -> + AlignBits = bit_size(Buffer) rem 8, + <<_:AlignBits,Val:Num/integer-unit:8,RestBin/binary>> = Buffer, + {Val,RestBin}. + + +%% First align buffer, then pick the first Num octets. +%% Returns octets as a binary +getoctets_as_bin(Bin,Num) when is_binary(Bin) -> + <> = Bin, + {Octets,RestBin}; +getoctets_as_bin(Bin,Num) when is_bitstring(Bin) -> + AlignBits = bit_size(Bin) rem 8, + <<_:AlignBits,Val:Num/binary,RestBin/binary>> = Bin, + {Val,RestBin}. + + +%% 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 is_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 is_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 is_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 is_integer(N), Len > 1 -> + encode_constrained_number({0,Len-1},N); + N when is_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 binary(). +%% C is the constrained length. +%% If the buffer is not aligned, this function does that. +decode_fragmented_bits(Buffer,C) when is_binary(Buffer) -> + decode_fragmented_bits(Buffer,C,[]); +decode_fragmented_bits(Buffer,C) when is_bitstring(Buffer) -> + AlignBits = bit_size(Buffer) rem 8, + <<_:AlignBits,Rest/binary>> = Buffer, + decode_fragmented_bits(Rest,C,[]). + +decode_fragmented_bits(<<3:2,Len:6,Bin/binary>>,C,Acc) -> + {Value,Bin2} = split_binary(Bin, Len * ?'16K'), % Len = 1 | 2 | 3 | 4 + decode_fragmented_bits(Bin2,C,[Value|Acc]); +decode_fragmented_bits(<<0:1,0:7,Bin/binary>>,C,Acc) -> + BinBits = erlang:list_to_bitstring(lists:reverse(Acc)), + case C of + Int when is_integer(Int),C == bit_size(BinBits) -> + {BinBits,Bin}; + Int when is_integer(Int) -> + exit({error,{asn1,{illegal_value,C,BinBits}}}) + end; +decode_fragmented_bits(<<0:1,Len:7,Bin/binary>>,C,Acc) -> + <> = Bin, + BinBits = erlang:list_to_bitstring([Value|Acc]), + case C of + Int when is_integer(Int),C == bit_size(BinBits) -> + {BinBits,Rest}; + Int when is_integer(Int) -> + exit({error,{asn1,{illegal_value,C,BinBits}}}) + end. + + +decode_fragmented_octets(Bin,C) -> + decode_fragmented_octets(Bin,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 is_integer(Int), C == size(Octets) -> + {Octets,Bin}; + Int when is_integer(Int) -> + exit({error,{asn1,{illegal_value,C,Octets}}}) + end; +decode_fragmented_octets(<<0:1,Len:7,Bin/binary>>,C,Acc) -> + <> = Bin, + BinOctets = list_to_binary(lists:reverse([Value|Acc])), + case C of + Int when is_integer(Int),size(BinOctets) == Int -> + {BinOctets,Bin2}; + Int when is_integer(Int) -> + exit({error,{asn1,{illegal_value,C,BinOctets}}}) + 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 is_list(Val) -> + Bin = list_to_binary(Val), + case size(Bin) of + Size when Size>255 -> + [encode_length(undefined,Size),[21,<>,Bin]]; + Size -> + [encode_length(undefined,Size),[20,Size,Bin]] + end; +encode_open_type(_Constraint, Val) when is_binary(Val) -> + case size(Val) of + Size when Size>255 -> + [encode_length(undefined,size(Val)),[21,<>,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 is_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 is_integer(V) -> + encode_integer(C,V); +encode_integer(C,{Name,V},NamedNumberList) when is_atom(Name) -> + encode_integer(C,V,NamedNumberList). + +encode_integer(C,{Name,Val}) when is_atom(Name) -> + encode_integer(C,Val); + +encode_integer([{Rc,_Ec}],Val) when is_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 is_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 is_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 is_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 is_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,<>,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,<>}; + [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,<>}; + [21,<>,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 is_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 == 1 -> []; + 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,<>}; + [20,2,<>]; + 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 == 1 -> + {0,Buffer}; + 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_bin(Bytes2,Len), + {dec_pos_integer(Octs),Bytes3}; + Range =< 16#100000000 -> + {Len,Bytes2} = decode_length(Buffer,{1,4}), + {Octs,Bytes3} = getoctets_as_bin(Bytes2,Len), + {dec_pos_integer(Octs),Bytes3}; + Range =< 16#10000000000 -> + {Len,Bytes2} = decode_length(Buffer,{1,5}), + {Octs,Bytes3} = getoctets_as_bin(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,<>,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,<>,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_bin(Bytes2,Len), + {dec_integer(Ints),Bytes3}. + + +dec_pos_integer(Ints) -> + decpint(Ints). +dec_integer(Bin = <<0:1,_:7,_/binary>>) -> + decpint(Bin); +dec_integer(<<_:1,B:7,BitStr/bitstring>>) -> + Size = bit_size(BitStr), + <> = BitStr, + (-128 + B) bsl bit_size(BitStr) bor I. + + + +decpint(Bin) -> + Size = bit_size(Bin), + <> = Bin, + Int. + +%% 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 is_integer(Lb), Lb >= 0 -> % Ub > 65535 + encode_length(undefined,Len); +encode_length({Vr={Lb,Ub},Ext},Len) + when Ub =< 65535 ,Lb >= 0,Len= + %% constrained extensible + [0,encode_constrained_number(Vr,Len)]; +encode_length({{Lb,_},Ext},Len) when is_list(Ext) -> + [1,encode_semi_constrained_number(Lb,Len)]; +encode_length(SingleValue,_Len) when is_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(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 + case align(Buffer) of + <<0:1,Oct:7,Rest/binary>> -> + {Oct,Rest}; + <<2:2,Val:14,Rest/binary>> -> + {Val,Rest}; + <<3:2,_Val:14,_Rest/binary>> -> + %% this case should be fixed + exit({error,{asn1,{decode_length,{nyi,above_16k}}}}) + end; + +decode_length(Buffer,{Lb,Ub}) when Ub =< 65535 ,Lb >= 0 -> % constrained + decode_constrained_number(Buffer,{Lb,Ub}); +decode_length(Buffer,{Lb,_Ub}) when is_integer(Lb), Lb >= 0 -> % Ub > 65535 + decode_length(Buffer,undefined); +decode_length(Buffer,{{Lb,Ub},Ext}) when is_list(Ext) -> + case getbit(Buffer) of + {0,Buffer2} -> + decode_length(Buffer2, {Lb,Ub}); + {1,Buffer2} -> + decode_length(Buffer2, undefined) + end; + + +%When does this case occur with {_,_Lb,Ub} ?? +% X.691:10.9.3.5 +decode_length(Bin,{_,_Lb,_Ub}) -> % Unconstrained or large Ub NOTE! this case does not cover case when Ub > 65535 + case Bin of + <<0:1,Val:7,Rest/bitstring>> -> + {Val,Rest}; + _ -> + case align(Bin) of + <<2:2,Val:14,Rest/binary>> -> + {Val,Rest}; + <<3:2,_:14,_Rest/binary>> -> + exit({error,{asn1,{decode_length,{nyi,length_above_64K}}}}) + end + end; +decode_length(Buffer,SingleValue) when is_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 is_tuple(Ntup1), is_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 is_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 is_atom(NewVal) -> {NewVal,Buffer3}; + _ -> {{asn1_enum,Val},Buffer3} + end + end; + +decode_enumerated(Buffer,C,NamedNumberTup) when is_tuple(NamedNumberTup) -> + {Val,Buffer2} = decode_integer(Buffer,C), + case catch (element(Val+1,NamedNumberTup)) of + NewVal when is_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 is_integer(Unused), + is_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 is_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 is_list(BitListValue),is_integer(Int),Int =< 16 -> + %% The type is constrained by a single value size constraint + %% range_check(Int,length(BitListValue)), + [40,Int,length(BitListValue),BitListValue]; +encode_bit_string(Int, BitListValue, _) + when is_list(BitListValue),is_integer(Int), Int =< 255 -> + %% The type is constrained by a single value size constraint + %% range_check(Int,length(BitListValue)), + [2,40,Int,length(BitListValue),BitListValue]; +encode_bit_string(Int, BitListValue, _) + when is_list(BitListValue),is_integer(Int), Int < ?'64K' -> + {Code,DesiredLength,Length} = + case length(BitListValue) of + B1 when B1 > Int -> + exit({error,{'BIT_STRING_length_greater_than_SIZE', + Int,BitListValue}}); + B1 when B1 =< 255,Int =< 255 -> + {40,Int,B1}; + B1 when B1 =< 255 -> + {42,<>,B1}; + B1 -> + {43,<>,<>} + end, + %% The type is constrained by a single value size constraint + [2,Code,DesiredLength,Length,BitListValue]; +encode_bit_string(no, BitListValue,[]) + when is_list(BitListValue) -> + [encode_length(undefined,length(BitListValue)), + 2,BitListValue]; +encode_bit_string({{Fix,Fix},Ext}, BitListValue,[]) + when is_integer(Fix), is_list(Ext) -> + case length(BitListValue) of + Len when Len =< Fix -> + [0,encode_bit_string(Fix,BitListValue,[])]; + _ -> + [1,encode_bit_string(no,BitListValue,[])] + end; +encode_bit_string(C, BitListValue,[]) + when is_list(BitListValue) -> + [encode_length(C,length(BitListValue)), + 2,BitListValue]; +encode_bit_string(no, BitListValue,_NamedBitList) + when is_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({{Fix,Fix},Ext}, BitListValue,_NamedBitList) + when is_integer(Fix), is_list(Ext) -> + case length(BitListValue) of + Len when Len =< Fix -> + [0,encode_bit_string(Fix,BitListValue,_NamedBitList)]; + _ -> + [1,encode_bit_string(no,BitListValue,_NamedBitList)] + end; +encode_bit_string(C,BitListValue,_NamedBitList) + when is_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]; + + +%% when the value is an integer +encode_bit_string(C, IntegerVal, NamedBitList) when is_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 is_atom(Name) -> + encode_bit_string(C,Val,NamedBitList). + +bit_string_trailing_zeros(BitList,C) when is_integer(C) -> + bit_string_trailing_zeros1(BitList,C,C); +bit_string_trailing_zeros(BitList,{Lb,Ub}) when is_integer(Lb) -> + bit_string_trailing_zeros1(BitList,Lb,Ub); +bit_string_trailing_zeros(BitList,{{Lb,Ub},_}) when is_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 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,{Unused,BinBits},_NamedBitList) + when is_integer(C),C=<16 -> + range_check(C,bit_size(BinBits) - Unused), + [45,C,size(BinBits),BinBits]; +encode_bin_bit_string(C,{Unused,BinBits},_NamedBitList) + when is_integer(C), C =< 255 -> + range_check(C,bit_size(BinBits) - Unused), + [2,45,C,size(BinBits),BinBits]; +encode_bin_bit_string(C,{Unused,BinBits},_NamedBitList) + when is_integer(C), C =< 65535 -> + range_check(C,bit_size(BinBits) - Unused), + case size(BinBits) of + Size when Size =< 255 -> + [2,46,<>,Size,BinBits]; + Size -> + [2,47,<>,<>,BinBits] + end; +%% encode_bin_bit_string(C,{_Unused,BinBits},_NamedBitList) +%% when is_integer(C) -> +%% exit({error,{asn1, {bitstring_size, not_supported, C}}}); +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 + {Lb,Ub} when is_integer(Lb),is_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)]; + {{Fix,Fix},Ext} when is_integer(Fix),is_list(Ext) -> + %%[encode_length(Sc,size(Bin1)*8 - Unused1), + case size(Bin1)*8 - Unused1 of + Size when Size =< Fix -> + [0,encode_bin_bit_string(Fix,UnusedAndBin,NamedBitList)]; + _Size -> + [1,encode_bin_bit_string(no,UnusedAndBin,NamedBitList)] + end; + Sc -> + Size=size(Bin1), + [encode_length(Sc,Size*8 - Unused1), + 2,octets_unused_to_complete(Unused1,Size,Bin1)] + end. + +range_check(C,C) when is_integer(C) -> + ok; +range_check(C1,C2) when is_integer(C1) -> + exit({error,{asn1,{bit_string_out_of_range,{C1,C2}}}}). + +remove_trailing_bin([], {Unused,Bin}) -> + {Unused,Bin}; +remove_trailing_bin(_NamedNumberList,{_Unused,<<>>}) -> + {0,<<>>}; +remove_trailing_bin(NamedNumberList, {_Unused,Bin}) -> + Size = size(Bin)-1, + <> = 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 is_integer(V),V=<16 -> %fixed length 16 bits or less + compact_bit_string(Buffer,V,NamedNumberList); + V when is_integer(V),V=<65536 -> %fixed length > 16 bits + Bytes2 = align(Buffer), + compact_bit_string(Bytes2,V,NamedNumberList); + V when is_integer(V) -> % V > 65536 => fragmented value + {BitStr,Buffer2} = decode_fragmented_bits(Buffer,V), + case bit_size(BitStr) band 7 of + 0 -> {{0,BitStr},Buffer2}; + N -> {{8-N,<>},Buffer2} + end; + {Lb,Ub} when is_integer(Lb),is_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); + {{Fix,Fix},Ext} = Sc when is_integer(Fix), is_list(Ext) -> + case decode_length(Buffer,Sc) of + {Len,Bytes2} when Len > Fix -> + Bytes3 = align(Bytes2), + compact_bit_string(Bytes3,Len,NamedNumberList); + {Len,Bytes2} when Len > 16 -> + Bytes3 = align(Bytes2), + compact_bit_string(Bytes3,Len,NamedNumberList); + {Len,Bytes2} -> + compact_bit_string(Bytes2,Len,NamedNumberList) + end; + 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 is_integer(Lb),is_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 is_integer(V),V=<16 -> % fixed length 16 bits or less + bit_list_or_named(Buffer,V,NamedNumberList); + V when is_integer(V),V=<65536 -> + Bytes2 = align(Buffer), + bit_list_or_named(Bytes2,V,NamedNumberList); + V when is_integer(V) -> + Bytes2 = align(Buffer), + {BinBits,_Bytes3} = decode_fragmented_bits(Bytes2,V), + bit_list_or_named(BinBits,V,NamedNumberList); + {{Fix,Fix},Ext} =Sc when is_integer(Fix), is_list(Ext) -> + case decode_length(Buffer,Sc) of + {Len,Bytes2} when Len > Fix -> + Bytes3 = align(Bytes2), + bit_list_or_named(Bytes3,Len,NamedNumberList); + {Len,Bytes2} when Len > 16 -> + Bytes3 = align(Bytes2), + bit_list_or_named(Bytes3,Len,NamedNumberList); + {Len,Bytes2} -> + bit_list_or_named(Bytes2,Len,NamedNumberList) + end; + 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,[]) -> + {BitStr,Rest} = getbits_as_binary(Len,Buffer), % {{Unused,BinBits},NewBuffer} + PadLen = (8 - (bit_size(BitStr) rem 8)) rem 8, + {{PadLen,<>},Rest}; +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 is_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([], _) -> + []. + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% 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 is_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(<>,1,false) -> +%% {B1,Bytes2} = getbits(Bytes,8), + {[B1],Bytes}; +decode_octet_string(<>,2,false) -> +%% {Bs,Bytes2}= getbits(Bytes,16), +%% {binary_to_list(<>),Bytes2}; + {[B1,B2],Bytes}; +decode_octet_string(Bytes,Sv,false) when is_integer(Sv),Sv=<65535 -> + %% Bytes2 = align(Bytes), + %% getoctets_as_list aligns buffer before it picks octets + getoctets_as_list(Bytes,Sv); +decode_octet_string(Bytes,Sv,false) when is_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(Bytes2,Len); +decode_octet_string(Bytes,Sv,false) when is_list(Sv) -> + {Len,Bytes2} = decode_length(Bytes,{hd(Sv),lists:max(Sv)}), +%% Bytes3 = align(Bytes2), + getoctets_as_list(Bytes2,Len); +decode_octet_string(Bytes,no,false) -> + {Len,Bytes2} = decode_length(Bytes,undefined), +%% Bytes3 = align(Bytes2), + getoctets_as_list(Bytes2,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 is_atom(Name) -> + encode_restricted_string(aligned,Val); + +encode_restricted_string(aligned,Val) when is_list(Val)-> + Len = length(Val), + [encode_length(undefined,Len),octets_to_complete(Len,Val)]. + + +encode_known_multiplier_string(StringType,SizeC,NumBits,CharOutTab,{Name,Val}) when is_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 is_integer(Ub), Ub*NumBits =< 16 -> + Result; + Ub when is_integer(Ub),Ub =<65535 -> % fixed length + [2,Result]; + {Ub,Lb} -> + [encode_length({Ub,Lb},length(Val)),2,Result]; + no -> + [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 is_integer(Ub), Ub*NumBits =< 16 -> + chars_decode(Bytes,NumBits,StringType,CharInTab,Ub); + Ub when is_integer(Ub),Ub =<65535 -> % fixed length + Bytes1 = align(Bytes), + chars_decode(Bytes1,NumBits,StringType,CharInTab,Ub); + Vl when is_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(<>, 0, Acc) -> + {lists:reverse(Acc),T}; +getBMPChars(<<0,O2,Bytes1/bitstring>>, Len, Acc) -> + getBMPChars(Bytes1,Len-1,[O2|Acc]); +getBMPChars(<>, Len, Acc) -> + getBMPChars(Bytes1,Len-1,[{0,0,O1,O2}|Acc]). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% 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,<>]. + Unused = (8 - (NumBits rem 8)) rem 8, + Len = NumBits + Unused, + [30,Unused,Len div 8,<<(Val bsl Unused):Len>>]. + + +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(<>)) + 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 is_atom(Name) -> +% encode_null(Val). + +decode_null(Bytes) -> + {'NULL',Bytes}. + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% encode_UTF8String(Val) -> CompleteList +%% Val -> <> +%% CompleteList -> [apropriate codes and values for driver complete] +%% +encode_UTF8String(Val) when is_binary(Val) -> + [encode_length(undefined,size(Val)), + octets_to_complete(size(Val),Val)]; +encode_UTF8String(Val) -> + encode_UTF8String(list_to_binary(Val)). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% decode_UTF8String(Bytes) -> {Utf8Binary,RemainingBytes} +%% Utf8Binary -> <> +%% RemainingBytes -> <> +decode_UTF8String(Bytes) -> + {Len,Bytes2} = decode_length(Bytes,undefined), + {_Bin,_Bytes3} = getoctets_as_bin(Bytes2,Len). + + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% 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 is_atom(Name) -> + encode_object_identifier(Val); +encode_object_identifier(Val) -> + OctetList = e_object_identifier(Val), + Octets = list_to_binary(OctetList), + [encode_length(undefined,size(Octets)), + octets_to_complete(size(Octets),Octets)]. + +e_object_identifier({'OBJECT IDENTIFIER',V}) -> + e_object_identifier(V); +e_object_identifier({Cname,V}) when is_atom(Cname),is_tuple(V) -> + e_object_identifier(tuple_to_list(V)); +e_object_identifier({Cname,V}) when is_atom(Cname),is_list(V) -> + e_object_identifier(V); +e_object_identifier(V) when is_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]; +e_object_element(Num) -> + [e_o_e(Num bsr 7)|[Num band 2#1111111]]. +e_o_e(Num) when Num < 128 -> + Num bor 2#10000000; +e_o_e(Num) -> + [e_o_e(Num bsr 7)|[(Num band 2#1111111) bor 2#10000000]]. + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% 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). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% encode_relative_oid(Val) -> CompleteList +%% encode_relative_oid({Name,Val}) -> CompleteList +encode_relative_oid({Name,Val}) when is_atom(Name) -> + encode_relative_oid(Val); +encode_relative_oid(Val) when is_tuple(Val) -> + encode_relative_oid(tuple_to_list(Val)); +encode_relative_oid(Val) when is_list(Val) -> + Octets = list_to_binary([e_object_element(X)||X <- Val]), + [encode_length(undefined,size(Octets)), + octets_to_complete(size(Octets),Octets)]. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% decode_relative_oid(Val) -> CompleteList +%% decode_relative_oid({Name,Val}) -> CompleteList +decode_relative_oid(Bytes) -> + {Len,Bytes2} = decode_length(Bytes,undefined), + {Octs,Bytes3} = getoctets_as_list(Bytes2,Len), + ObjVals = dec_subidentifiers(Octs,0,[]), + {list_to_tuple(ObjVals),Bytes3}. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% encode_real(Val) -> CompleteList +%% encode_real({Name,Val}) -> CompleteList +encode_real({Name,Val}) when is_atom(Name) -> + encode_real(Val); +encode_real(Real) -> + {EncVal,Len} = ?RT_COMMON:encode_real([],Real), + [encode_length(undefined,Len),octets_to_complete(size(EncVal),EncVal)]. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% decode_real(Val) -> {REALvalue,Rest} +%% decode_real({Name,Val}) -> {REALvalue,Rest} +decode_real(Bytes) -> + {Len,Bytes2} = decode_length(Bytes,undefined), + {RealVal,Rest,Len} = ?RT_COMMON:decode_real(Bytes2,Len), + {RealVal,Rest}. + + +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 is_list(InList) -> + complete1(InList,[],[]); + complete1(InList) -> + complete1([InList],[],[]). + + complete1([],Acc,Bacc) -> + {Acc,Bacc}; + complete1([H|T],Acc,Bacc) when is_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 is_binary(Bin) -> + complete1(T,[Acc|Bin],[]); + complete1([{Unused,Bin}|T],Acc,[]) when is_integer(Unused),is_binary(Bin) -> + Size = size(Bin)-1, + <> = Bin, + NumBits = 8-Unused, + complete1(T,[Acc|Bs],[[B bsr Unused]|NumBits]); + complete1([{Unused,Bin}|T],Acc,Bacc) when is_integer(Unused),is_binary(Bin) -> + Size = size(Bin)-1, + <> = 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. + +%% asn1-1.6.8.1_dev +%% complete(L) -> +%% case catch port_control(asn1_driver_port,1,L) of +%% Bin when is_binary(Bin) -> +%% Bin; +%% List when is_list(List) -> handle_error(List,L); +%% {'EXIT',{badarg,Reason}} -> +%% asn1rt_driver_handler:load_driver(), +%% receive +%% driver_ready -> +%% case catch port_control(asn1_driver_port,1,L) of +%% Bin2 when is_binary(Bin2) -> Bin2; +%% List when is_list(List) -> handle_error(List,L); +%% {'EXIT',Reason2={badarg,_R}} -> +%% exit({"failed to call driver probably due to bad asn1 value",Reason2}); +%% Reason2 -> exit(Reason2) +%% 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. + +%% asn1-1.6.9 +complete(L) -> + case catch control(?COMPLETE_ENCODE,L) of + Bin when is_binary(Bin) -> + Bin; + List when is_list(List) -> handle_error(List,L); + {'EXIT',{badarg,_Reason}} -> + case asn1rt:load_driver() of + ok -> + case control(?COMPLETE_ENCODE,L) of + Bin when is_binary(Bin) ->Bin; + List when is_list(List) -> handle_error(List,L) + end; + Err -> + Err + end + end. + + +handle_error([],_)-> + exit({error,{asn1,{"memory allocation problem in driver"}}}); +handle_error("1",L) -> % error in complete in driver + exit({error,{asn1,L}}); +handle_error(ErrL,L) -> + exit({error,{asn1,ErrL,L}}). + +%% asn1-1.6.9 +control(Cmd, Data) -> + Port = asn1rt_driver_handler:client_port(), + erlang:port_control(Port, Cmd, Data). + +-endif. + + +octets_to_complete(Len,Val) when Len < 256 -> + [20,Len,Val]; +octets_to_complete(Len,Val) -> + [21,<>,Val]. + +octets_unused_to_complete(Unused,Len,Val) when Len < 256 -> + [30,Unused,Len,Val]; +octets_unused_to_complete(Unused,Len,Val) -> + [31,Unused,<>,Val]. diff --git a/lib/asn1/src/asn1rt_uper_bin.erl b/lib/asn1/src/asn1rt_uper_bin.erl new file mode 100644 index 0000000000..a964b835ae --- /dev/null +++ b/lib/asn1/src/asn1rt_uper_bin.erl @@ -0,0 +1,1635 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2008-2009. All Rights Reserved. +%% +%% 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 online 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. +%% +%% %CopyrightEnd% +%% +%% +-module(asn1rt_uper_bin). + +%% encoding / decoding of PER unaligned + +-include("asn1_records.hrl"). + +%%-compile(export_all). + + -export([cindex/3, list_to_record/2]). + -export([setext/1, fixoptionals/3, + fixextensions/2, + getext/1, getextension/2, skipextensions/3, getbit/1, getchoice/3 ]). + -export([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_relative_oid/1, decode_relative_oid/1, + encode_object_identifier/1, decode_object_identifier/1, + encode_real/1, decode_real/1, + complete/1, complete_NFP/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_UTF8String/1, decode_UTF8String/1, + encode_BMPString/2, decode_BMPString/2, + encode_IA5String/2, decode_IA5String/2, + encode_NumericString/2, decode_NumericString/2, + encode_ObjectDescriptor/2, decode_ObjectDescriptor/1 + ]). + +-define('16K',16384). +-define('32K',32768). +-define('64K',65536). + + +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 is_tuple(Tuple) -> + Tuple; +list_to_record(Name,List) when is_list(List) -> + list_to_tuple([Name|List]). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% setext(true|false) -> CompleteList +%% + +setext(false) -> + <<0:1>>; +setext(true) -> + <<1:1>>. + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% This is the new fixoptionals/3 which is used by the new generates +%% +fixoptionals(OptList,OptLength,Val) when is_tuple(Val) -> + Bits = fixoptionals(OptList,Val,0), + {Val,<>}; + +fixoptionals([],_Val,Acc) -> + %% Optbits + Acc; +fixoptionals([{Pos,DefVal}|Ot],Val,Acc) -> + case element(Pos,Val) of + asn1_DEFAULT -> fixoptionals(Ot,Val,Acc bsl 1); + DefVal -> fixoptionals(Ot,Val,Acc bsl 1); + _ -> fixoptionals(Ot,Val,(Acc bsl 1) + 1) + end; +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 is_bitstring(Bytes) -> + getbit(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),<>] + 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}). + + +%%%%%%%%%%%%%%% +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 is_bitstring(Bytes) -> + <> = Bytes, + {BS,Rest}. + +getbits_as_list(Num,Bytes) when is_bitstring(Bytes) -> + <> = Bytes, + {[ B || <> <= BitStr],Rest}. + +getbit(Buffer) -> + <> = Buffer, + {B,Rest}. + + +getbits(Buffer,Num) when is_bitstring(Buffer) -> + <> = Buffer, + {Bs,Rest}. + + + +%% Pick the first Num octets. +%% Returns octets as an integer with bit significance as in buffer. +getoctets(Buffer,Num) when is_bitstring(Buffer) -> + <> = Buffer, + {Val,RestBitStr}. + +%% Pick the first Num octets. +%% Returns octets as a binary +getoctets_as_bin(Bin,Num) when is_bitstring(Bin) -> + <> = Bin, + {Octets,RestBin}. + +%% 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 is_integer(N), Len1 > 1 -> + [<<0:1>>, % the value is in the root set + encode_integer([{'ValueRange',{0,Len1-1}}],N)]; + N when is_integer(N) -> + <<0:1>>; % no encoding if only 0 or 1 alternative + false -> + [<<1:1>>, % extension value + case set_choice_tag(Alt,L2) of + N2 when is_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 is_integer(N), Len > 1 -> + encode_integer([{'ValueRange',{0,Len-1}}],N); + N when is_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(Buffer,C) -> + decode_fragmented_bits(Buffer,C,[]). +decode_fragmented_bits(<<3:2,Len:6,BitStr/bitstring>>,C,Acc) -> +%% {Value,Bin2} = split_binary(Bin, Len * ?'16K'), + FragLen = (Len*?'16K') div 8, + <> = BitStr, + decode_fragmented_bits(BitStr2,C,[Value|Acc]); +decode_fragmented_bits(<<0:1,0:7,BitStr/bitstring>>,C,Acc) -> + BinBits = list_to_binary(lists:reverse(Acc)), + case C of + Int when is_integer(Int),C == size(BinBits) -> + {BinBits,BitStr}; + Int when is_integer(Int) -> + exit({error,{asn1,{illegal_value,C,BinBits}}}) + end; +decode_fragmented_bits(<<0:1,Len:7,BitStr/bitstring>>,C,Acc) -> + <> = BitStr, +%% <> = Bin, + ResBitStr = list_to_bitstring(lists:reverse([Val|Acc])), + case C of + Int when is_integer(Int),C == bit_size(ResBitStr) -> + {ResBitStr,Rest}; + Int when is_integer(Int) -> + exit({error,{asn1,{illegal_value,C,ResBitStr}}}) + end. + + +decode_fragmented_octets({0,Bin},C) -> + decode_fragmented_octets(Bin,C,[]). + +decode_fragmented_octets(<<3:2,Len:6,BitStr/bitstring>>,C,Acc) -> + FragLen = Len * ?'16K', + <> = BitStr, + decode_fragmented_octets(Rest,C,[Value|Acc]); +decode_fragmented_octets(<<0:1,0:7,Bin/bitstring>>,C,Acc) -> + Octets = list_to_binary(lists:reverse(Acc)), + case C of + Int when is_integer(Int), C == size(Octets) -> + {Octets,Bin}; + Int when is_integer(Int) -> + exit({error,{asn1,{illegal_value,C,Octets}}}) + end; +decode_fragmented_octets(<<0:1,Len:7,BitStr/bitstring>>,C,Acc) -> + <> = BitStr, + BinOctets = list_to_binary(lists:reverse([Value|Acc])), + case C of + Int when is_integer(Int),size(BinOctets) == Int -> + {BinOctets,BitStr2}; + Int when is_integer(Int) -> + exit({error,{asn1,{illegal_value,C,BinOctets}}}) + 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 is_list(Val) -> + encode_open_type(C, list_to_binary(Val)); +encode_open_type(_C, Val) when is_binary(Val) -> + [encode_length(undefined,size(Val)),Val]. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% 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 is_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 is_integer(V) -> + encode_integer(C,V); +encode_integer(C,{Name,V},NamedNumberList) when is_atom(Name) -> + encode_integer(C,V,NamedNumberList). + +encode_integer(C,{Name,Val}) when is_atom(Name) -> + encode_integer(C,Val); + +encode_integer([{Rc,_Ec}],Val) when is_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,_}}} -> + [<<1:1>>,encode_unconstrained_number(Val)]; + Encoded -> + [<<0:1>>,Encoded] + end; +encode_integer(C,Val ) when is_list(C) -> + case get_constraint(C,'SingleValue') of + no -> + encode_integer1(C,Val); + V when is_integer(V),V == Val -> + []; % a type restricted to a single value encodes to nothing + V when is_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 is_tuple(Rc) -> + {Ext,Buffer2} = getext(Buffer), + case Ext of + 0 -> decode_integer(Buffer2,[Rc]); %% Value in root of constraint + 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 is_integer(V) -> + {V,Buffer}; + V when is_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 is_atom(Name) -> + encode_small_number(Val); +encode_small_number(Val) when Val =< 63 -> + <>; +encode_small_number(Val) -> + [<<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 is_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) -> + %% encoding in minimum no of octets preceeded by a length + Val2 = Val - Lb, +%% NumBits = num_bits(Val2), + Bin = eint_bin_positive(Val2), + Size = size(Bin), + if + Size < 128 -> + [<>,Bin]; % equiv with encode_length(undefined,Len) but faster + Size < 16384 -> + [<<2:2,Size:14>>,Bin]; + true -> + [encode_length(undefined,Size),Bin] + 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 is_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, + NumBits = num_bits(Range), + <>; +encode_constrained_number(Range,Val) -> + exit({error,{asn1,{integer_range,Range,value,Val}}}). + + +decode_constrained_number(Buffer,{Lb,Ub}) -> + Range = Ub - Lb + 1, + NumBits = num_bits(Range), + {Val,Remain} = getbits(Buffer,NumBits), + {Val+Lb,Remain}. + +%% X.691:10.8 Encoding of an unconstrained whole number + +encode_unconstrained_number(Val) when Val >= 0 -> + Oct = eint_bin_2Cs(Val), + Len = size(Oct), + if + Len < 128 -> + [<>,Oct]; % equiv with encode_length(undefined,Len) but faster + Len < 16384 -> + [<<2:2,Len:14>>,Oct]; + true -> + [encode_length(undefined,Len),<>,Oct] + end; +encode_unconstrained_number(Val) -> % negative + Oct = enint(Val,[]), + Len = size(Oct), + if + Len < 128 -> + [<>,Oct]; % equiv with encode_length(undefined,Len) but faster + Len < 16384 -> + [<<2:2,Len:14>>,Oct]; + true -> + [encode_length(undefined,Len),Oct] + end. + + +eint_bin_2Cs(Int) -> + case eint_bin_positive(Int) of + Bin = <> when B > 16#7f -> + <<0,Bin/binary>>; + Bin -> Bin + end. + +%% returns the integer as a binary +eint_bin_positive(Val) when Val < 16#100 -> + <>; +eint_bin_positive(Val) when Val < 16#10000 -> + <>; +eint_bin_positive(Val) when Val < 16#1000000 -> + <>; +eint_bin_positive(Val) when Val < 16#100000000 -> + <>; +eint_bin_positive(Val) -> + list_to_binary([eint_bin_positive2(Val bsr 32)|<>]). +eint_bin_positive2(Val) when Val < 16#100 -> + <>; +eint_bin_positive2(Val) when Val < 16#10000 -> + <>; +eint_bin_positive2(Val) when Val < 16#1000000 -> + <>; +eint_bin_positive2(Val) when Val < 16#100000000 -> + <>; +eint_bin_positive2(Val) -> + [eint_bin_positive2(Val bsr 32)|<>]. + + + + +enint(-1, [B1|T]) when B1 > 127 -> + list_to_binary([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_bin(Bytes2,Len), + {dec_integer(Ints),Bytes3}. + +dec_integer(Bin = <<0:1,_:7,_/bitstring>>) -> + decpint(Bin); +dec_integer(<<_:1,B:7,BitStr/bitstring>>) -> + Size = bit_size(BitStr), + <> = BitStr, + (-128 + B) bsl bit_size(BitStr) bor I. + +decpint(Bin) -> + Size = bit_size(Bin), + <> = Bin, + Int. + + +%% 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 -> + <>; + Len < 16384 -> + <<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 is_integer(Lb), Lb >= 0 -> % Ub > 65535 + encode_length(undefined,Len); +encode_length({Vr={Lb,Ub},Ext},Len) + when Ub =< 65535 ,Lb >= 0, Len= + %% constrained extensible + [<<0:1>>,encode_constrained_number(Vr,Len)]; +encode_length({{Lb,_Ub},Ext},Len) when is_list(Ext) -> + [<<1:1>>,encode_semi_constrained_number(Lb,Len)]; +encode_length(SingleValue,_Len) when is_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 -> + <<(Len-1):7>>; +encode_small_length(Len) -> + [<<1: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). + +%% un-constrained +decode_length(<<0:1,Oct:7,Rest/bitstring>>,undefined) -> + {Oct,Rest}; +decode_length(<<2:2,Val:14,Rest/bitstring>>,undefined) -> + {Val,Rest}; +decode_length(<<3:2,_:14,_Rest/bitstring>>,undefined) -> + exit({error,{asn1,{decode_length,{nyi,above_16k}}}}); + +decode_length(Buffer,{Lb,Ub}) when Ub =< 65535 ,Lb >= 0 -> % constrained + decode_constrained_number(Buffer,{Lb,Ub}); +decode_length(Buffer,{Lb,_}) when is_integer(Lb), Lb >= 0 -> % Ub > 65535 + decode_length(Buffer,undefined); +decode_length(Buffer,{VR={_Lb,_Ub},Ext}) when is_list(Ext) -> + {0,Buffer2} = getbit(Buffer), + decode_length(Buffer2, VR); + + +%When does this case occur with {_,_Lb,Ub} ?? +% X.691:10.9.3.5 +decode_length(Bin,{_,_Lb,_Ub}) -> %when Len =< 127 -> % Unconstrained or large Ub NOTE! this case does not cover case when Ub > 65535 + case Bin of + <<0:1,Val:7,Rest/bitstring>> -> + {Val,Rest}; + <<2:2,Val:14,Rest/bitstring>> -> + {Val,Rest}; + <<3:2,_:14,_Rest/bitstring>> -> + exit({error,{asn1,{decode_length,{nyi,length_above_64K}}}}) + end; +decode_length(Buffer,SingleValue) when is_integer(SingleValue) -> + {SingleValue,Buffer}. + + + % X.691:11 +encode_boolean(true) -> + <<1:1>>; +encode_boolean(false) -> + <<0:1>>; +encode_boolean({Name,Val}) when is_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 is_tuple(Ntup1), is_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 is_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 is_atom(NewVal) -> {NewVal,Buffer3}; + _ -> {{asn1_enum,Val},Buffer3} + end + end; + +decode_enumerated(Buffer,C,NamedNumberTup) when is_tuple(NamedNumberTup) -> + {Val,Buffer2} = decode_integer(Buffer,C), + case catch (element(Val+1,NamedNumberTup)) of + NewVal when is_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 is_integer(Unused), + is_binary(BinBits) -> + encode_bin_bit_string(get_constraint(C,'SizeConstraint'),Bin,NamedBitList); + +encode_bit_string(C, BitListVal, NamedBitList) -> + encode_bit_string1(get_constraint(C,'SizeConstraint'), BitListVal, NamedBitList). +%% when the value is a list of named bits +encode_bit_string1(C, LoNB=[FirstVal | _RestVal], NamedBitList) when is_atom(FirstVal) -> + ToSetPos = get_all_bitposes(LoNB, NamedBitList, []), + BitList = make_and_set_list(ToSetPos,0), + encode_bit_string1(C,BitList,NamedBitList); + +encode_bit_string1(C, BL=[{bit,_No} | _RestVal], NamedBitList) -> + ToSetPos = get_all_bitposes(BL, NamedBitList, []), + BitList = make_and_set_list(ToSetPos,0), + encode_bit_string1(C,BitList,NamedBitList); +%% when the value is a list of ones and zeroes +encode_bit_string1(Int, BitListValue, _) + when is_list(BitListValue),is_integer(Int) -> + %% The type is constrained by a single value size constraint + bit_list2bitstr(Int,BitListValue); +encode_bit_string1(no, BitListValue,[]) + when is_list(BitListValue) -> + Len = length(BitListValue), + [encode_length(undefined,Len),bit_list2bitstr(Len,BitListValue)]; +encode_bit_string1(C, BitListValue,[]) + when is_list(BitListValue) -> + Len = length(BitListValue), + [encode_length(C,Len),bit_list2bitstr(Len,BitListValue)]; +encode_bit_string1(no, BitListValue,_NamedBitList) + when is_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))), + Len = length(NewBitLVal), + [encode_length(undefined,Len),bit_list2bitstr(Len,NewBitLVal)]; +encode_bit_string1(C,BitListValue,_NamedBitList) + when is_list(BitListValue) ->% C = {_,'MAX'} + NewBitStr = bitstr_trailing_zeros(BitListValue,C), + [encode_length(C,bit_size(NewBitStr)),NewBitStr]; + + +%% when the value is an integer +encode_bit_string1(C, IntegerVal, NamedBitList) when is_integer(IntegerVal)-> + BitList = int_to_bitlist(IntegerVal), + encode_bit_string1(C,BitList,NamedBitList); + +%% when the value is a tuple +encode_bit_string1(C,{Name,Val}, NamedBitList) when is_atom(Name) -> + encode_bit_string1(C,Val,NamedBitList). + +bit_list2bitstr(Len,BitListValue) -> + case length(BitListValue) of + Len -> + << <> ||B <- BitListValue>>; + L when L > Len -> % truncate + << << <> ||B <- BitListValue>> :Len/bitstring>>; + L -> % Len > L -> pad + << << <> ||B <- BitListValue>>/bitstring ,0:(Len-L)>> + end. + +adjust_trailing_zeros(Len,Bin) when Len == bit_size(Bin) -> + Bin; +adjust_trailing_zeros(Len,Bin) when Len > bit_size(Bin) -> + <>; +adjust_trailing_zeros(Len,Bin) -> + <>. + +bitstr_trailing_zeros(BitList,C) when is_integer(C) -> + bitstr_trailing_zeros1(BitList,C,C); +bitstr_trailing_zeros(BitList,{Lb,Ub}) when is_integer(Lb) -> + bitstr_trailing_zeros1(BitList,Lb,Ub); +bitstr_trailing_zeros(BitList,{{Lb,Ub},_}) when is_integer(Lb) -> + bitstr_trailing_zeros1(BitList,Lb,Ub); +bitstr_trailing_zeros(BitList,_) -> + bit_list2bitstr(length(BitList),BitList). + +bitstr_trailing_zeros1(BitList,Lb,Ub) -> + case length(BitList) of + Lb -> bit_list2bitstr(Lb,BitList); + B when B bit_list2bitstr(Lb,BitList); + D -> F = fun(L,LB,LB,_,_)->bit_list2bitstr(LB,lists:reverse(L)); + ([0|R],L1,LB,UB,Fun)->Fun(R,L1-1,LB,UB,Fun); + (L,L1,_,UB,_)when L1 =< UB -> + bit_list2bitstr(L1,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 is_integer(C),C=<16 -> + adjust_trailing_zeros(C,BinBits); +encode_bin_bit_string(C,{_Unused,BinBits},_NamedBitList) + when is_integer(C) -> + adjust_trailing_zeros(C,BinBits); +encode_bin_bit_string(C,UnusedAndBin={_,_},NamedBitList) -> + %% removes all trailing bits if NamedBitList is not empty + BitStr = remove_trailing_bin(NamedBitList,UnusedAndBin), + case C of + {Lb,Ub} when is_integer(Lb),is_integer(Ub) -> + [encode_length({Lb,Ub},bit_size(BitStr)),BitStr]; + no -> + [encode_length(undefined,bit_size(BitStr)),BitStr]; + Sc -> + [encode_length(Sc,bit_size(BitStr)),BitStr] + end. + + +remove_trailing_bin([], {Unused,Bin}) -> + BS = bit_size(Bin)-Unused, + <> = Bin, + BitStr; +remove_trailing_bin(_NamedNumberList,{_Unused,<<>>}) -> + <<>>; +remove_trailing_bin(NamedNumberList, {_Unused,Bin}) -> + Size = size(Bin)-1, + <> = Bin, + + %% clear the Unused bits to be sure + 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}); + _ -> + BS = bit_size(Bin) - Unused2, + <> = Bin, + BitStr + 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 is_integer(V),V=<16 -> %fixed length 16 bits or less + compact_bit_string(Buffer,V,NamedNumberList); + V when is_integer(V),V=<65536 -> %fixed length > 16 bits + compact_bit_string(Buffer,V,NamedNumberList); + V when is_integer(V) -> % V > 65536 => fragmented value + {Bin,Buffer2} = decode_fragmented_bits(Buffer,V), + PadLen = (8 - (bit_size(Bin) rem 8)) rem 8, + {{PadLen,<>},Buffer2}; +%% {0,_} -> {{0,Bin},Buffer2}; +%% {U,_} -> {{8-U,Bin},Buffer2} + {Lb,Ub} when is_integer(Lb),is_integer(Ub) -> + %% This case may demand decoding of fragmented length/value + {Len,Bytes2} = decode_length(Buffer,{Lb,Ub}), + compact_bit_string(Bytes2,Len,NamedNumberList); + no -> + %% This case may demand decoding of fragmented length/value + {Len,Bytes2} = decode_length(Buffer,undefined), + compact_bit_string(Bytes2,Len,NamedNumberList); + Sc -> + {Len,Bytes2} = decode_length(Buffer,Sc), + compact_bit_string(Bytes2,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 is_integer(Lb),is_integer(Ub) -> + {Len,Bytes2} = decode_length(Buffer,{Lb,Ub}), + bit_list_or_named(Bytes2,Len,NamedNumberList); + no -> + {Len,Bytes2} = decode_length(Buffer,undefined), + bit_list_or_named(Bytes2,Len,NamedNumberList); + 0 -> % fixed length + {[],Buffer}; % nothing to encode + V when is_integer(V),V=<16 -> % fixed length 16 bits or less + bit_list_or_named(Buffer,V,NamedNumberList); + V when is_integer(V),V=<65536 -> + bit_list_or_named(Buffer,V,NamedNumberList); + V when is_integer(V) -> + {BinBits,_} = decode_fragmented_bits(Buffer,V), + bit_list_or_named(BinBits,V,NamedNumberList); + Sc -> % extension marker + {Len,Bytes2} = decode_length(Buffer,Sc), + bit_list_or_named(Bytes2,Len,NamedNumberList) + end. + + +%% if no named bits are declared we will return a +%% {Unused,Bits}. Unused = integer(), +%% Bits = binary(). +compact_bit_string(Buffer,Len,[]) -> + {BitStr,Rest} = getbits_as_binary(Len,Buffer), % {{Unused,BinBits},NewBuffer} + PadLen = (8 - (bit_size(BitStr) rem 8)) rem 8, + {{PadLen,<>},Rest}; +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 is_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([], _) -> + []. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% X.691:16 +%% encode_octet_string(Constraint,Val) +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +encode_octet_string(C,{_Name,Val}) -> + encode_octet_string(C,Val); +encode_octet_string(C,Val) -> + case get_constraint(C,'SizeConstraint') of + 0 -> + <<>>; + 1 -> + list_to_binary(Val); + 2 -> + list_to_binary(Val); + Sv when Sv =<65535, Sv == length(Val) -> % fixed length + list_to_binary(Val); + VR = {_,_} -> + [encode_length(VR,length(Val)),list_to_binary(Val)]; + Sv when is_list(Sv) -> + [encode_length({hd(Sv),lists:max(Sv)},length(Val)),list_to_binary(Val)]; + no -> + [encode_length(undefined,length(Val)),list_to_binary(Val)] + end. + +decode_octet_string(Bytes,C) -> + decode_octet_string1(Bytes,get_constraint(C,'SizeConstraint')). +decode_octet_string1(<>,1) -> + {[B1],Bytes}; +decode_octet_string1(<>,2) -> + {[B1,B2],Bytes}; +decode_octet_string1(Bytes,Sv) when is_integer(Sv),Sv=<65535 -> + getoctets_as_list(Bytes,Sv); +decode_octet_string1(Bytes,Sv) when is_integer(Sv) -> + decode_fragmented_octets(Bytes,Sv); +decode_octet_string1(Bytes,{Lb,Ub}) -> + {Len,Bytes2} = decode_length(Bytes,{Lb,Ub}), + getoctets_as_list(Bytes2,Len); +decode_octet_string1(Bytes,Sv) when is_list(Sv) -> + {Len,Bytes2} = decode_length(Bytes,{hd(Sv),lists:max(Sv)}), + getoctets_as_list(Bytes2,Len); +decode_octet_string1(Bytes,no) -> + {Len,Bytes2} = decode_length(Bytes,undefined), + getoctets_as_list(Bytes2,Len). + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Restricted char string types +%% (NumericString, PrintableString,VisibleString,IA5String,BMPString,UniversalString) +%% X.691:26 and X.680:34-36 +%%encode_restricted_string('BMPString',Constraints,Extension,Val) + + +encode_restricted_string({Name,Val}) when is_atom(Name) -> + encode_restricted_string(Val); + +encode_restricted_string(Val) when is_list(Val)-> + [encode_length(undefined,length(Val)),list_to_binary(Val)]. + +encode_known_multiplier_string(StringType,C,{Name,Val}) when is_atom(Name) -> + encode_known_multiplier_string(StringType,C,Val); + +encode_known_multiplier_string(StringType,C,Val) -> + Result = chars_encode(C,StringType,Val), + NumBits = get_NumBits(C,StringType), + case get_constraint(C,'SizeConstraint') of + Ub when is_integer(Ub), Ub*NumBits =< 16 -> + Result; + 0 -> + []; + Ub when is_integer(Ub),Ub =<65535 -> % fixed length + Result; + {Ub,Lb} -> + [encode_length({Ub,Lb},length(Val)),Result]; + Vl when is_list(Vl) -> + [encode_length({lists:min(Vl),lists:max(Vl)},length(Val)),Result]; + no -> + [encode_length(undefined,length(Val)),Result] + end. + +decode_restricted_string(Bytes) -> + {Len,Bytes2} = decode_length(Bytes,undefined), + getoctets_as_list(Bytes2,Len). + +decode_known_multiplier_string(Bytes,StringType,C,_Ext) -> + NumBits = get_NumBits(C,StringType), + case get_constraint(C,'SizeConstraint') of + Ub when is_integer(Ub), Ub*NumBits =< 16 -> + chars_decode(Bytes,NumBits,StringType,C,Ub); + Ub when is_integer(Ub),Ub =<65535 -> % fixed length + chars_decode(Bytes,NumBits,StringType,C,Ub); + 0 -> + {[],Bytes}; + Vl when is_list(Vl) -> + {Len,Bytes1} = decode_length(Bytes,{hd(Vl),lists:max(Vl)}), + chars_decode(Bytes1,NumBits,StringType,C,Len); + no -> + {Len,Bytes1} = decode_length(Bytes,undefined), + chars_decode(Bytes1,NumBits,StringType,C,Len); + {Lb,Ub}-> + {Len,Bytes1} = decode_length(Bytes,{Lb,Ub}), + chars_decode(Bytes1,NumBits,StringType,C,Len) + end. + + +encode_NumericString(C,Val) -> + encode_known_multiplier_string('NumericString',C,Val). +decode_NumericString(Bytes,C) -> + decode_known_multiplier_string(Bytes,'NumericString',C,false). + +encode_PrintableString(C,Val) -> + encode_known_multiplier_string('PrintableString',C,Val). +decode_PrintableString(Bytes,C) -> + decode_known_multiplier_string(Bytes,'PrintableString',C,false). + +encode_VisibleString(C,Val) -> % equivalent with ISO646String + encode_known_multiplier_string('VisibleString',C,Val). +decode_VisibleString(Bytes,C) -> + decode_known_multiplier_string(Bytes,'VisibleString',C,false). + +encode_IA5String(C,Val) -> + encode_known_multiplier_string('IA5String',C,Val). +decode_IA5String(Bytes,C) -> + decode_known_multiplier_string(Bytes,'IA5String',C,false). + +encode_BMPString(C,Val) -> + encode_known_multiplier_string('BMPString',C,Val). +decode_BMPString(Bytes,C) -> + decode_known_multiplier_string(Bytes,'BMPString',C,false). + +encode_UniversalString(C,Val) -> + encode_known_multiplier_string('UniversalString',C,Val). +decode_UniversalString(Bytes,C) -> + decode_known_multiplier_string(Bytes,'UniversalString',C,false). + + +%% end of known-multiplier strings for which PER visible constraints are +%% applied + +encode_GeneralString(_C,Val) -> + encode_restricted_string(Val). +decode_GeneralString(Bytes,_C) -> + decode_restricted_string(Bytes). + +encode_GraphicString(_C,Val) -> + encode_restricted_string(Val). +decode_GraphicString(Bytes,_C) -> + decode_restricted_string(Bytes). + +encode_ObjectDescriptor(_C,Val) -> + encode_restricted_string(Val). +decode_ObjectDescriptor(Bytes) -> + decode_restricted_string(Bytes). + +encode_TeletexString(_C,Val) -> % equivalent with T61String + encode_restricted_string(Val). +decode_TeletexString(Bytes,_C) -> + decode_restricted_string(Bytes). + +encode_VideotexString(_C,Val) -> + encode_restricted_string(Val). +decode_VideotexString(Bytes,_C) -> + decode_restricted_string(Bytes). + + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% 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})]; + [<<(H-Min):NumBits>>|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})]; + Ch = 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 bsl 8)+B) bsl 8)+C) bsl 8)+D)-Min}|chars_encode2(T,NumBits,{Min,Max,notab})]; + Ch = ((((((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,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})]; + Ch = 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)); + no -> + case StringType of + 'IA5String' -> + charbits(128); % 16#00..16#7F + 'VisibleString' -> + charbits(95); % 16#20..16#7E + 'PrintableString' -> + charbits(74); % [$\s,$',$(,$),$+,$,,$-,$.,$/,"0123456789",$:,$=,$?,$A..$Z,$a..$z + 'NumericString' -> + charbits(11); % $ ,"0123456789" + 'UniversalString' -> + 32; + 'BMPString' -> + 16 + 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)]. + +%% See Table 20.3 in Dubuisson +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 is_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(<>)) + 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]). + + +%% UTF8String +encode_UTF8String(Val) when is_binary(Val) -> + [encode_length(undefined,size(Val)),Val]; +encode_UTF8String(Val) -> + Bin = list_to_binary(Val), + encode_UTF8String(Bin). + +decode_UTF8String(Bytes) -> + {Len,Bytes2} = decode_length(Bytes,undefined), + getoctets_as_bin(Bytes2,Len). + + + % X.691:17 +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 -> [binary()|bitstring()|list()] +%% +encode_object_identifier({Name,Val}) when is_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 + [encode_length(undefined,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 is_atom(Cname),is_tuple(V) -> + e_object_identifier(tuple_to_list(V)); +e_object_identifier({Cname,V}) when is_atom(Cname),is_list(V) -> + e_object_identifier(V); +e_object_identifier(V) when is_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]; +e_object_element(Num) -> + [e_o_e(Num bsr 7)|[Num band 2#1111111]]. +e_o_e(Num) when Num < 128 -> + Num bor 2#10000000; +e_o_e(Num) -> + [e_o_e(Num bsr 7)|[(Num band 2#1111111) bor 2#10000000]]. + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% 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). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% encode_relative_oid(Val) -> CompleteList +%% encode_relative_oid({Name,Val}) -> CompleteList +encode_relative_oid({Name,Val}) when is_atom(Name) -> + encode_relative_oid(Val); +encode_relative_oid(Val) when is_tuple(Val) -> + encode_relative_oid(tuple_to_list(Val)); +encode_relative_oid(Val) when is_list(Val) -> + Octets = list_to_binary([e_object_element(X)||X <- Val]), + [encode_length(undefined,size(Octets)),Octets]. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% decode_relative_oid(Val) -> CompleteList +%% decode_relative_oid({Name,Val}) -> CompleteList +decode_relative_oid(Bytes) -> + {Len,Bytes2} = decode_length(Bytes,undefined), + {Octs,Bytes3} = getoctets_as_list(Bytes2,Len), + ObjVals = dec_subidentifiers(Octs,0,[]), + {list_to_tuple(ObjVals),Bytes3}. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% encode_real(Val) -> CompleteList +%% encode_real({Name,Val}) -> CompleteList +encode_real({Name,Val}) when is_atom(Name) -> + encode_real(Val); +encode_real(Real) -> + {EncVal,Len} = ?RT_COMMON:encode_real([],Real), + [encode_length(undefined,Len),EncVal]. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% decode_real(Val) -> {REALvalue,Rest} +%% decode_real({Name,Val}) -> {REALvalue,Rest} +decode_real(Bytes) -> + {Len,Bytes2} = decode_length(Bytes,undefined), + <> = Bytes2, + {RealVal,Rest,Len} = ?RT_COMMON:decode_real(Bytes3,Len), + {RealVal,Rest}. + + +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(InList) when is_list(InList) -> + case complete1(InList) of + <<>> -> + <<0>>; + Res -> + case bit_size(Res) band 7 of + 0 -> Res; + Bits -> <> + end + end; +complete(InList) when is_binary(InList) -> + InList; +complete(InList) when is_bitstring(InList) -> + PadLen = 8 - (bit_size(InList) band 7), + <>. + +complete1(L) when is_list(L) -> + list_to_bitstring(L). + +%% Special version of complete that does not align the completed message. +complete_NFP(InList) when is_list(InList) -> + list_to_bitstring(InList); +complete_NFP(InList) when is_bitstring(InList) -> + InList. + +%% unaligned helpers + +%% 10.5.6 NOTE: If "range" satisfies the inequality 2^m < "range" =< +%% 2^(m+1) then the number of bits = m + 1 +num_bits(1) -> 0; +num_bits(2) -> 1; +num_bits(R) when R =< 4 -> + 2; +num_bits(R) when R =< 8 -> + 3; +num_bits(R) when R =< 16 -> + 4; +num_bits(R) when R =< 32 -> + 5; +num_bits(R) when R =< 64 -> + 6; +num_bits(R) when R =< 128 -> + 7; +num_bits(R) when R =< 256 -> + 8; +num_bits(R) when R =< 512 -> + 9; +num_bits(R) when R =< 1024 -> + 10; +num_bits(R) -> + 1+num_bits(R bsr 1). diff --git a/lib/asn1/src/notes_history.sgml b/lib/asn1/src/notes_history.sgml new file mode 100644 index 0000000000..107459b37d --- /dev/null +++ b/lib/asn1/src/notes_history.sgml @@ -0,0 +1,100 @@ + + + +
+ ASN1 Release Notes (Old) + Kenneth Lundin + Kenneth Lundin + + Kenneth Lundin + Kenneth Lundin + 98-02-02 + A + notes_history.sgml +
+ +

This document describes the changes made to old versions of the asn1 application. + +

+ ASN1 0.8.1 +

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. + +

+ Missing features and other restrictions + + +

The encoding rules BER and PER (aligned) is supported. PER (unaligned) + IS NOT SUPPORTED. + +

NOT SUPPORTED types ANY and ANY DEFINED BY + (is not in the standard any more). + +

NOT SUPPORTED types EXTERNAL and EMBEDDED-PDV. + +

NOT SUPPORTED type REAL (planned to be implemented). + +

The code generation support for value definitions in the ASN.1 notation is very limited + (planned to be enhanced). + +

The support for constraints is limited to: + +

+ SizeConstraint SIZE(X) +

+ SingleValue (1) +

+ ValueRange (X..Y) +

+ PermittedAlpabet FROM (but not for BMPString and UniversalString when generating PER). + +

Complex expressions in constraints is not supported (planned to be extended). + +

The current version of the compiler has very limited error checking: + +

Stops at first syntax error. +

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. +

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. + + +

The maximum INTEGER supported in this version is a signed 64 bit integer. This + limitation is probably quite reasonable. (Planned to be extended). + +

Only AUTOMATIC TAGS supported for PER. + +

Only EXPLICIT and IMPLICIT TAGS supported for BER. + +

The compiler supports decoding of BER-data with indefinite length but it is + not possible to produce data with indefinite length with the encoder. + +

+ +
+ + + + diff --git a/lib/asn1/src/notes_latest.sgml b/lib/asn1/src/notes_latest.sgml new file mode 100644 index 0000000000..5a397ecbc2 --- /dev/null +++ b/lib/asn1/src/notes_latest.sgml @@ -0,0 +1,100 @@ + + + +
+ ASN1 Release Notes + Kenneth Lundin + Kenneth Lundin + + Kenneth Lundin + Kenneth Lundin + 97-10-07 + A + notes_latest.sgml +
+ +

This document describes the changes made to the asn1 application. + +

+ ASN1 0.8.1 +

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. + +

+ Missing features and other restrictions + + +

The encoding rules BER and PER (aligned) is supported. PER (unaligned) + IS NOT SUPPORTED. + +

NOT SUPPORTED types ANY and ANY DEFINED BY + (is not in the standard any more). + +

NOT SUPPORTED types EXTERNAL and EMBEDDED-PDV. + +

NOT SUPPORTED type REAL (planned to be implemented). + +

The code generation support for value definitions in the ASN.1 notation is very limited + (planned to be enhanced). + +

The support for constraints is limited to: + +

+ SizeConstraint SIZE(X) +

+ SingleValue (1) +

+ ValueRange (X..Y) +

+ PermittedAlpabet FROM (but not for BMPString and UniversalString when generating PER). + +

Complex expressions in constraints is not supported (planned to be extended). + +

The current version of the compiler has very limited error checking: + +

Stops at first syntax error. +

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. +

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. + + +

The maximum INTEGER supported in this version is a signed 64 bit integer. This + limitation is probably quite reasonable. (Planned to be extended). + +

Only AUTOMATIC TAGS supported for PER. + +

Only EXPLICIT and IMPLICIT TAGS supported for BER. + +

The compiler supports decoding of BER-data with indefinite length but it is + not possible to produce data with indefinite length with the encoder. + +

+ +
+ + + + -- cgit v1.2.3