diff options
Diffstat (limited to 'lib')
73 files changed, 4736 insertions, 4078 deletions
diff --git a/lib/asn1/src/Makefile b/lib/asn1/src/Makefile index 33cd3cc4c3..3f24e15c04 100644 --- a/lib/asn1/src/Makefile +++ b/lib/asn1/src/Makefile @@ -43,9 +43,7 @@ RELSYSDIR = $(RELEASE_PATH)/lib/asn1-$(VSN) EBIN = ../ebin -EVAL_CT_MODULES = asn1ct_eval_ext \ - asn1ct_eval_per \ - asn1ct_eval_uper +EVAL_CT_MODULES = asn1ct_eval_ext CT_MODULES= \ asn1ct \ @@ -55,7 +53,6 @@ CT_MODULES= \ asn1ct_func \ asn1ct_gen \ asn1ct_gen_per \ - asn1ct_gen_per_rt2ct \ asn1ct_name \ asn1ct_constructed_per \ asn1ct_constructed_ber_bin_v2 \ diff --git a/lib/asn1/src/asn1_db.erl b/lib/asn1/src/asn1_db.erl index 869b36ddbd..48d9dd16d7 100644 --- a/lib/asn1/src/asn1_db.erl +++ b/lib/asn1/src/asn1_db.erl @@ -19,25 +19,37 @@ %% -module(asn1_db). --export([dbstart/1,dbnew/1,dbsave/2,dbput/3,dbget/2]). +-export([dbstart/1,dbnew/2,dbload/1,dbload/3,dbsave/2,dbput/3,dbget/2]). -export([dbstop/0]). -record(state, {parent, monitor, includes, table}). %% Interface -dbstart(Includes) -> +dbstart(Includes0) -> + Includes = case Includes0 of + [] -> ["."]; + [_|_] -> Includes0 + end, Parent = self(), undefined = get(?MODULE), %Assertion. put(?MODULE, spawn_link(fun() -> init(Parent, Includes) end)), ok. -dbnew(Module) -> req({new, Module}). +dbload(Module, Erule, Mtime) -> + req({load, Module, Erule, Mtime}). + +dbload(Module) -> + req({load, Module, any, {{0,0,0},{0,0,0}}}). + +dbnew(Module, Erule) -> req({new, Module, Erule}). dbsave(OutFile, Module) -> cast({save, OutFile, Module}). dbput(Module, K, V) -> cast({set, Module, K, V}). dbget(Module, K) -> req({get, Module, K}). dbstop() -> Resp = req(stop), erase(?MODULE), Resp. %% Internal functions +-define(MAGIC_KEY, '__version_and_erule__'). + req(Request) -> DbPid = get(?MODULE), Ref = erlang:monitor(process,DbPid), @@ -71,47 +83,57 @@ loop(#state{parent = Parent, monitor = MRef, table = Table, ets:insert(Modtab, {K2, V}), loop(State); {From, {get, Mod, K2}} -> - Result = case ets:lookup(Table, Mod) of - [] -> opentab(Table, Mod, Includes); - [{_, Modtab}] -> {ok, Modtab} - end, - case Result of - {ok, Newtab} -> reply(From, lookup(Newtab, K2)); - _Error -> reply(From, undefined) + %% XXX If there is no information for Mod, get_table/3 + %% will attempt to load information from an .asn1db + %% file, without comparing its timestamp against the + %% source file. This is known to happen when check_* + %% functions for DER are generated, but it could possibly + %% happen in other circumstances. Ideally, this issue should + %% be rectified in some way, perhaps by ensuring that + %% the module has been loaded (using dbload/4) prior + %% to calling dbget/2. + case get_table(Table, Mod, Includes) of + {ok,Tab} -> reply(From, lookup(Tab, K2)); + error -> reply(From, undefined) end, loop(State); {save, OutFile, Mod} -> [{_,Mtab}] = ets:lookup(Table, Mod), ok = ets:tab2file(Mtab, OutFile), loop(State); - {From, {new, Mod}} -> + {From, {new, Mod, Erule}} -> [] = ets:lookup(Table, Mod), %Assertion. ModTableId = ets:new(list_to_atom(lists:concat(["asn1_",Mod])), []), ets:insert(Table, {Mod, ModTableId}), + ets:insert(ModTableId, {?MAGIC_KEY, info(Erule)}), reply(From, ok), loop(State); + {From, {load, Mod, Erule, Mtime}} -> + case ets:member(Table, Mod) of + true -> + reply(From, ok); + false -> + case load_table(Mod, Erule, Mtime, Includes) of + {ok, ModTableId} -> + ets:insert(Table, {Mod, ModTableId}), + reply(From, ok); + error -> + reply(From, error) + end + end, + loop(State); {From, stop} -> reply(From, stopped); %% Nothing to store {'DOWN', MRef, process, Parent, Reason} -> exit(Reason) end. -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) +get_table(Table, Mod, Includes) -> + case ets:lookup(Table, Mod) of + [{Mod,Tab}] -> + {ok,Tab}; + [] -> + load_table(Mod, any, {{0,0,0},{0,0,0}}, Includes) end. lookup(Tab, K) -> @@ -119,3 +141,43 @@ lookup(Tab, K) -> [] -> undefined; [{K,V}] -> V end. + +info(Erule) -> + {asn1ct:vsn(),Erule}. + +load_table(Mod, Erule, Mtime, Includes) -> + Base = lists:concat([Mod, ".asn1db"]), + case path_find(Includes, Mtime, Base) of + error -> + error; + {ok,ModTab} when Erule =:= any -> + {ok,ModTab}; + {ok,ModTab} -> + Vsn = asn1ct:vsn(), + case ets:lookup(ModTab, ?MAGIC_KEY) of + [{_,{Vsn,Erule}}] -> + %% Correct version and encoding rule. + {ok,ModTab}; + _ -> + %% Missing key or wrong version/encoding rule. + ets:delete(ModTab), + error + end + end. + +path_find([H|T], Mtime, Base) -> + File = filename:join(H, Base), + case filelib:last_modified(File) of + 0 -> + path_find(T, Mtime, Base); + DbMtime when DbMtime >= Mtime -> + case ets:file2tab(File) of + {ok,_}=Ret -> + Ret; + _ -> + path_find(T, Mtime, Base) + end; + _ -> + path_find(T, Mtime, Base) + end; +path_find([], _, _) -> error. diff --git a/lib/asn1/src/asn1ct.erl b/lib/asn1/src/asn1ct.erl index 8e71a5697c..f2ccf5f212 100644 --- a/lib/asn1/src/asn1ct.erl +++ b/lib/asn1/src/asn1ct.erl @@ -893,17 +893,23 @@ parse_and_save(Module,S) -> Options = S#state.options, SourceDir = S#state.sourcedir, Includes = [I || {i,I} <- Options], + Erule = S#state.erule, case get_input_file(Module, [SourceDir|Includes]) of %% search for asn1 source {file,SuffixedASN1source} -> - case dbfile_uptodate(SuffixedASN1source,Options) of - false -> - parse_and_save1(S, SuffixedASN1source, Options); - _ -> ok + Mtime = filelib:last_modified(SuffixedASN1source), + case asn1_db:dbload(Module, Erule, Mtime) of + ok -> ok; + error -> parse_and_save1(S, SuffixedASN1source, Options) end; Err -> - warning("could not do a consistency check of the ~p file: no asn1 source file was found.~n", - [lists:concat([Module,".asn1db"])],Options), + case asn1_db:dbload(Module) of + ok -> + warning("could not do a consistency check of the ~p file: no asn1 source file was found.~n", + [lists:concat([Module,".asn1db"])],Options); + error -> + ok + end, {error,{asn1,input_file_error,Err}} end. @@ -929,48 +935,6 @@ get_input_file(Module,[I|Includes]) -> 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. - - input_file_type(Name,I) -> case input_file_type(Name) of {error,_} -> input_file_type2(filename:basename(Name),I); @@ -1374,10 +1338,11 @@ get_value(Module, Type) -> end. check(Module, Includes) -> - case asn1_db:dbget(Module,'MODULE') of - undefined -> - {error, {file_not_found, lists:concat([Module, ".asn1db"])}}; - M -> + case asn1_db:dbload(Module) of + error -> + {error,asn1db_missing_or_out_of_date}; + ok -> + M = asn1_db:dbget(Module, 'MODULE'), TypeOrVal = M#module.typeorval, State = #state{mname = M#module.name, module = M#module{typeorval=[]}, diff --git a/lib/asn1/src/asn1ct_check.erl b/lib/asn1/src/asn1ct_check.erl index f94550b0a4..eddcda0018 100644 --- a/lib/asn1/src/asn1ct_check.erl +++ b/lib/asn1/src/asn1ct_check.erl @@ -1557,21 +1557,32 @@ check_objectdefn(S,Def,CDef) when is_record(CDef,classdef) -> exit({error,{objectdefn,Other}}) end. -check_defaultfields(S,Fields,ClassFields) -> - check_defaultfields(S,Fields,ClassFields,[]). +check_defaultfields(S, Fields, ClassFields) -> + Present = ordsets:from_list([F || {F,_} <- Fields]), + Mandatory0 = get_mandatory_class_fields(ClassFields), + Mandatory = ordsets:from_list(Mandatory0), + All = ordsets:from_list([element(2, F) || F <- ClassFields]), + #state{type=T,tname=Obj} = S, + case ordsets:subtract(Present, All) of + [] -> + ok; + [_|_]=Invalid -> + throw(asn1_error(S, T, {invalid_fields,Invalid,Obj})) + end, + case ordsets:subtract(Mandatory, Present) of + [] -> + check_defaultfields_1(S, Fields, ClassFields, []); + [_|_]=Missing -> + throw(asn1_error(S, T, {missing_mandatory_fields,Missing,Obj})) + end. -check_defaultfields(_S,[],_ClassFields,Acc) -> +check_defaultfields_1(_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}. +check_defaultfields_1(S, [{FName,Spec}|Fields], ClassFields, Acc) -> + CField = lists:keyfind(FName, 2, ClassFields), + {NewField,RestFields} = + convert_to_defaultfield(S, FName, [Spec|Fields], CField), + check_defaultfields_1(S, RestFields, ClassFields, [NewField|Acc]). convert_definedsyntax(_S,[],[],_ClassFields,Acc) -> lists:reverse(Acc); @@ -1587,6 +1598,23 @@ convert_definedsyntax(S,Fields,WithSyntax,ClassFields,Acc) -> [MatchedField|Acc]) end. +get_mandatory_class_fields([{fixedtypevaluefield,Name,_,_,'MANDATORY'}|T]) -> + [Name|get_mandatory_class_fields(T)]; +get_mandatory_class_fields([{objectfield,Name,_,_,'MANDATORY'}|T]) -> + [Name|get_mandatory_class_fields(T)]; +get_mandatory_class_fields([{objectsetfield,Name,_,'MANDATORY'}|T]) -> + [Name|get_mandatory_class_fields(T)]; +get_mandatory_class_fields([{typefield,Name,'MANDATORY'}|T]) -> + [Name|get_mandatory_class_fields(T)]; +get_mandatory_class_fields([{variabletypevaluefield,Name,_,'MANDATORY'}|T]) -> + [Name|get_mandatory_class_fields(T)]; +get_mandatory_class_fields([{variabletypevaluesetfield, + Name,_,'MANDATORY'}|T]) -> + [Name|get_mandatory_class_fields(T)]; +get_mandatory_class_fields([_|T]) -> + get_mandatory_class_fields(T); +get_mandatory_class_fields([]) -> []. + match_field(S,Fields,WithSyntax,ClassFields) -> match_field(S,Fields,WithSyntax,ClassFields,[]). @@ -6798,7 +6826,7 @@ merge_tags2([], Acc) -> 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:dbnew(NewM#module.name, S#state.erule), asn1_db:dbput(NewM#module.name,'MODULE', NewM), Res = storeindb(#state{mname=NewM#module.name}, TVlist, []), include_default_class(S,NewM#module.name), @@ -6867,11 +6895,22 @@ asn1_error(#state{mname=Where}, Item, Error) -> format_error({already_defined,Name,PrevLine}) -> io_lib:format("the name ~p has already been defined at line ~p", [Name,PrevLine]); +format_error({invalid_fields,Fields,Obj}) -> + io_lib:format("invalid ~s in ~p", [format_fields(Fields),Obj]); +format_error({missing_mandatory_fields,Fields,Obj}) -> + io_lib:format("missing mandatory ~s in ~p", + [format_fields(Fields),Obj]); format_error({undefined,Name}) -> io_lib:format("'~s' is referenced, but is not defined", [Name]); format_error(Other) -> io_lib:format("~p", [Other]). +format_fields([F]) -> + io_lib:format("field &~s", [F]); +format_fields([H|T]) -> + [io_lib:format("fields &~s", [H])| + [io_lib:format(", &~s", [F]) || F <- T]]. + error({_,{structured_error,_,_,_}=SE,_}) -> SE; error({export,Msg,#state{mname=Mname,type=Ref,tname=Typename}}) -> diff --git a/lib/asn1/src/asn1ct_constructed_ber_bin_v2.erl b/lib/asn1/src/asn1ct_constructed_ber_bin_v2.erl index 761faa53c5..8359b81b33 100644 --- a/lib/asn1/src/asn1ct_constructed_ber_bin_v2.erl +++ b/lib/asn1/src/asn1ct_constructed_ber_bin_v2.erl @@ -122,8 +122,8 @@ gen_encode_sequence(Erules,Typename,D) when is_record(D,type) -> asn1ct_gen:un_hyphen_var(lists:concat(['Obj', AttrN])), emit([ObjectEncode," = ",nl, - " ",{asis,ObjSetMod},":'getenc_",ObjSetName, - "'(",{asis,UniqueFieldName},", ",nl]), + " ",{asis,ObjSetMod},":'getenc_",ObjSetName, + "'("]), ValueMatch = value_match(ValueIndex, lists:concat(["Cindex",N])), emit([indent(35),ValueMatch,"),",nl]), @@ -198,7 +198,7 @@ gen_decode_sequence(Erules,Typename,D) when is_record(D,type) -> asn1ct_name:new(tlv), asn1ct_name:new(v), - {DecObjInf,UniqueFName,ValueIndex} = + {DecObjInf,ValueIndex} = case TableConsInfo of #simpletableattributes{objectsetname=ObjectSetRef, c_name=AttrN, @@ -217,12 +217,12 @@ gen_decode_sequence(Erules,Typename,D) when is_record(D,type) -> %% relation from a component to another components %% subtype component {{AttrN,{deep,ObjectSetRef,UniqueFieldName,ValIndex}}, - UniqueFieldName,ValIndex}; + ValIndex}; false -> - {{AttrN,ObjectSetRef},UniqueFieldName,ValIndex} + {{AttrN,ObjectSetRef},ValIndex} end; _ -> - {false,false,false} + {false,false} end, RecordName = lists:concat([get_record_name_prefix(), asn1ct_gen:list2rname(Typename)]), @@ -246,7 +246,7 @@ gen_decode_sequence(Erules,Typename,D) when is_record(D,type) -> {ObjSetMod,ObjSetName} = ObjSetRef, emit([DecObj," =",nl, " ",{asis,ObjSetMod},":'getdec_",ObjSetName,"'(", - {asis,UniqueFName},", ",ValueMatch,"),",nl]), + ValueMatch,"),",nl]), gen_dec_postponed_decs(DecObj,PostponedDecArgs) end, demit(["Result = "]), %dbg @@ -357,7 +357,7 @@ gen_decode_set(Erules,Typename,D) when is_record(D,type) -> asn1ct_name:new(v), - {DecObjInf,UniqueFName,ValueIndex} = + {DecObjInf,ValueIndex} = case TableConsInfo of %% {ObjectSetRef,AttrN,_N,UniqueFieldName} ->%% N is index of attribute that determines constraint #simpletableattributes{objectsetname=ObjectSetRef, @@ -378,12 +378,12 @@ gen_decode_set(Erules,Typename,D) when is_record(D,type) -> %% relation from a component to another components %% subtype component {{AttrN,{deep,ObjectSetRef,UniqueFieldName,ValIndex}}, - UniqueFieldName,ValIndex}; + ValIndex}; false -> - {{AttrN,ObjectSetRef},UniqueFieldName,ValIndex} + {{AttrN,ObjectSetRef},ValIndex} end; _ -> - {false,false,false} + {false,false} end, case CompList of @@ -425,7 +425,7 @@ gen_decode_set(Erules,Typename,D) when is_record(D,type) -> {ObjSetMod,ObjSetName} = ObjSetRef, emit([DecObj," =",nl, " ",{asis,ObjSetMod},":'getdec_",ObjSetName,"'(", - {asis,UniqueFName},", ",ValueMatch,"),",nl]), + ValueMatch,"),",nl]), gen_dec_postponed_decs(DecObj,PostponedDecArgs) end, demit(["Result = "]), %dbg @@ -577,6 +577,8 @@ gen_decode_choice(Erules,Typename,D) when is_record(D,type) -> 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), + asn1ct_name:new(tmpBytes), + asn1ct_name:new(tmpLen), CindexPos = case Order of undefined -> @@ -706,8 +708,6 @@ 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), @@ -789,6 +789,7 @@ gen_enc_choice2(Erules,TopType,[H1|T]) when is_record(H1,'ComponentType') -> componentrelation)} of {#'ObjectClassFieldType'{},{componentrelation,_,_}} -> asn1ct_name:new(tmpBytes), + asn1ct_name:new(tmpLen), asn1ct_name:new(encBytes), asn1ct_name:new(encLen), Emit = ["{",{curr,tmpBytes},", _} = "], @@ -929,7 +930,6 @@ gen_enc_line(Erules,TopType,Cname, 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); _ -> @@ -991,12 +991,8 @@ gen_enc_line(Erules,TopType,Cname,Type,Element,Indent,OptOrMand,Assign,EncObj) {call,ber,encode_open_type, [{curr,tmpBytes},{asis,Tag}]},nl]); _ -> - emit(["{",{next,tmpBytes},",",{curr,tmpLen}, - "} = ", - {call,ber,encode_open_type, - [{curr,tmpBytes},{asis,Tag}]},com,nl]), - emit(IndDeep), - emit(["{",{next,tmpBytes},", ",{curr,tmpLen},"}"]) + emit([{call,ber,encode_open_type, + [{curr,tmpBytes},{asis,Tag}]}]) end; Err -> throw({asn1,{'internal error',Err}}) @@ -1213,22 +1209,18 @@ gen_dec_call({typefield,_},_,_,Cname,Type,BytesVar,Tag,_,_,_DecObjInf,OptOrMandC (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) -> - call(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}} -> + {Cname,{_,OSet,_UniqueFName,ValIndex}} -> Term = asn1ct_gen:mk_var(asn1ct_name:curr(term)), ValueMatch = value_match(ValIndex,Term), {ObjSetMod,ObjSetName} = OSet, emit([",",nl,"ObjFun = ",{asis,ObjSetMod},":'getdec_",ObjSetName, - "'(",{asis,UniqueFName},", ",ValueMatch,")"]); + "'(",ValueMatch,")"]); _ -> ok end, diff --git a/lib/asn1/src/asn1ct_constructed_per.erl b/lib/asn1/src/asn1ct_constructed_per.erl index d279e9697f..8d4afc0a0b 100644 --- a/lib/asn1/src/asn1ct_constructed_per.erl +++ b/lib/asn1/src/asn1ct_constructed_per.erl @@ -43,10 +43,13 @@ gen_encode_set(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) -> +gen_encode_constructed(Erule, Typename, #type{}=D) -> asn1ct_name:start(), - asn1ct_name:new(term), - asn1ct_name:new(bytes), + Imm = gen_encode_constructed_imm(Erule, Typename, D), + asn1ct_imm:enc_cg(Imm, is_aligned(Erule)), + emit([".",nl]). + +gen_encode_constructed_imm(Erule, Typename, #type{}=D) -> {ExtAddGroup,TmpCompList,TableConsInfo} = case D#type.def of #'SEQUENCE'{tablecinf=TCI,components=CL,extaddgroup=ExtAddGroup0} -> @@ -65,74 +68,36 @@ gen_encode_constructed(Erule,Typename,D) when is_record(D,type) -> [Comp#'ComponentType'{textual_order=undefined}|| Comp<-TmpCompList] end, - case Typename of - ['EXTERNAL'] -> - emit([{next,val}," = ", - {call,ext,transform_to_EXTERNAL1990, - [{curr,val}]},com,nl]), - asn1ct_name:new(val); - _ -> - ok - end, - case {Optionals = optionals(to_textual_order(CompList)),CompList, - is_optimized(Erule)} of - {[],EmptyCL,_} when EmptyCL == {[],[],[]};EmptyCL == {[],[]};EmptyCL == [] -> - ok; - {[],_,_} -> - emit([{next,val}," = ",{curr,val},",",nl]); - {_,_,true} -> - gen_fixoptionals(Optionals), - FixOpts = param_map(fun(Var) -> - {var,Var} - end,asn1ct_name:all(fixopt)), - emit({"{",{next,val},",Opt} = {",{curr,val},",[",FixOpts,"]},",nl}); - {_,_,false} -> - asn1ct_func:need({Erule,fixoptionals,3}), - Fixoptcall = ",Opt} = fixoptionals(", - emit({"{",{next,val},Fixoptcall, - {asis,Optionals},",",length(Optionals), - ",",{curr,val},"),",nl}) - end, - asn1ct_name:new(val), + ExternalImm = + case Typename of + ['EXTERNAL'] -> + Next = asn1ct_gen:mk_var(asn1ct_name:next(val)), + Curr = asn1ct_gen:mk_var(asn1ct_name:curr(val)), + asn1ct_name:new(val), + [{call,ext,transform_to_EXTERNAL1990,[{var,Curr}],{var,Next}}]; + _ -> + [] + end, + Aligned = is_aligned(Erule), + Value0 = asn1ct_gen:mk_var(asn1ct_name:curr(val)), + Optionals = optionals(to_textual_order(CompList)), + ImmOptionals = [asn1ct_imm:per_enc_optional(Value0, Opt, Aligned) || + Opt <- Optionals], Ext = extensible_enc(CompList), - case Ext of - {ext,_,NumExt} when NumExt > 0 -> - case extgroup_pos_and_length(CompList) of - {extgrouppos,[]} -> % no extenstionAdditionGroup - ok; - {extgrouppos,ExtGroupPosLenList} -> - ExtGroupFun = - fun({ExtActualGroupPos,ExtGroupVirtualPos,ExtGroupLen}) -> - Elements = - make_elements(ExtGroupVirtualPos+1, - "Val1", - lists:seq(1,ExtGroupLen)), - emit([ - {next,val}," = case [X || X <- [",Elements, - "],X =/= asn1_NOVALUE] of",nl, - "[] -> setelement(", - {asis,ExtActualGroupPos+1},",", - {curr,val},",", - "asn1_NOVALUE);",nl, - "_ -> setelement(",{asis,ExtActualGroupPos+1},",", - {curr,val},",", - "{extaddgroup,", Elements,"})",nl, - "end,",nl]), - asn1ct_name:new(val) - end, - lists:foreach(ExtGroupFun,ExtGroupPosLenList) - end, - asn1ct_name:new(tmpval), - emit(["Extensions = ", - {call,Erule,fixextensions,[{asis,Ext},{curr,val}]}, - com,nl]); - _ -> true - end, - EncObj = + ExtImm = case Ext of + {ext,ExtPos,NumExt} when NumExt > 0 -> + gen_encode_extaddgroup(CompList), + Value = asn1ct_gen:mk_var(asn1ct_name:curr(val)), + asn1ct_imm:per_enc_extensions(Value, ExtPos, + NumExt, Aligned); + _ -> + [] + end, + {EncObj,ObjSetImm} = case TableConsInfo of #simpletableattributes{usedclassfield=Used, uniqueclassfield=Unique} when Used /= Unique -> - false; + {false,[]}; %% ObjectSet, name of the object set in constraints %% %%{ObjectSet,AttrN,N,UniqueFieldName} -> %% N is index of attribute that determines constraint @@ -152,13 +117,10 @@ gen_encode_constructed(Erule,Typename,D) when is_record(D,type) -> asn1ct_gen:un_hyphen_var(lists:concat(['Obj',AttrN])), El = make_element(N+1, asn1ct_gen:mk_var(asn1ct_name:curr(val))), ValueMatch = value_match(ValueIndex, El), - emit([ObjectEncode," =",nl, - " ",{asis,Module},":'getenc_",ObjSetName,"'(", - {asis,UniqueFieldName},", ",nl, - " ",ValueMatch,"),",nl]), - {AttrN,ObjectEncode}; + ObjSetImm0 = [{assign,{var,ObjectEncode},ValueMatch}], + {{AttrN,ObjectEncode},ObjSetImm0}; false -> - false + {false,[]} end; _ -> case D#type.tablecinf of @@ -166,34 +128,52 @@ gen_encode_constructed(Erule,Typename,D) when is_record(D,type) -> %% when the simpletableattributes was at an outer %% level and the objfun has been passed through the %% function call - {"got objfun through args","ObjFun"}; + {{"got objfun through args","ObjFun"},[]}; _ -> - false + {false,[]} end end, - emit({"[",nl}), - MaybeComma1 = + ImmSetExt = case Ext of - {ext,_Pos,NumExt2} when NumExt2 > 0 -> - call(Erule, setext, ["Extensions =/= []"]), - ", "; - {ext,_Pos,_} -> - call(Erule, setext, ["false"]), - ", "; - _ -> - "" - end, - MaybeComma2 = - case optionals(CompList) of - [] -> MaybeComma1; - _ -> - emit(MaybeComma1), - emit("Opt"), - {",",nl} + {ext,_Pos,NumExt2} when NumExt2 > 0 -> + asn1ct_imm:per_enc_extension_bit('Extensions', Aligned); + {ext,_Pos,_} -> + asn1ct_imm:per_enc_extension_bit([], Aligned); + _ -> + [] end, - gen_enc_components_call(Erule,Typename,CompList,MaybeComma2,EncObj,Ext), - emit({"].",nl}). + ImmBody = gen_enc_components_call(Erule, Typename, CompList, EncObj, Ext), + ExternalImm ++ ExtImm ++ ObjSetImm ++ + asn1ct_imm:enc_append([ImmSetExt] ++ ImmOptionals ++ ImmBody). + +gen_encode_extaddgroup(CompList) -> + case extgroup_pos_and_length(CompList) of + {extgrouppos,[]} -> + ok; + {extgrouppos,ExtGroupPosLenList} -> + _ = [do_gen_encode_extaddgroup(G) || G <- ExtGroupPosLenList], + ok + end. +do_gen_encode_extaddgroup({ActualGroupPos,GroupVirtualPos,GroupLen}) -> + Val = asn1ct_gen:mk_var(asn1ct_name:curr(val)), + Elements = make_elements(GroupVirtualPos+1, + Val, + lists:seq(1, GroupLen)), + Expr = any_non_value(GroupVirtualPos+1, Val, GroupLen, ""), + emit([{next,val}," = case ",Expr," of",nl, + "false -> setelement(",{asis,ActualGroupPos+1},", ", + {curr,val},", asn1_NOVALUE);",nl, + "true -> setelement(",{asis,ActualGroupPos+1},", ", + {curr,val},", {extaddgroup,", Elements,"})",nl, + "end,",nl]), + asn1ct_name:new(val). + +any_non_value(_, _, 0, _) -> + []; +any_non_value(Pos, Val, N, Sep) -> + Sep ++ [make_element(Pos, Val)," =/= asn1_NOVALUE"] ++ + any_non_value(Pos+1, Val, N-1, [" orelse",nl]). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% generate decode function for SEQUENCE and SET @@ -328,28 +308,29 @@ gen_dec_constructed_imm(Erule, Typename, #type{}=D) -> EmitComp = gen_dec_components_call(Erule, Typename, CompList, DecObjInf, Ext, length(Optionals)), EmitRest = fun({AccTerm,AccBytes}) -> - gen_dec_constructed_imm_2(Typename, CompList, + gen_dec_constructed_imm_2(Erule, Typename, + CompList, ObjSetInfo, AccTerm, AccBytes) end, [EmitExt,EmitOpt|EmitComp++[{safe,EmitRest}]]. -gen_dec_constructed_imm_2(Typename, CompList, +gen_dec_constructed_imm_2(Erule, Typename, CompList, ObjSetInfo, AccTerm, AccBytes) -> - {_,UniqueFName,ValueIndex} = ObjSetInfo, + {_,_UniqueFName,ValueIndex} = ObjSetInfo, 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} = ObjSet, - emit([DecObj," =",nl, - " ",{asis,ObjSetMod},":'getdec_",ObjSetName,"'(", - {asis,UniqueFName},", ",ValueMatch,"),",nl]), - gen_dec_listofopentypes(DecObj,ListOfOpenTypes,false) + ValueMatch = value_match(ValueIndex, Term), + _ = [begin + gen_dec_open_type(Erule, ValueMatch, ObjSet, + LeadingAttr, T), + emit([com,nl]) + end || T <- ListOfOpenTypes], + ok end, %% we don't return named lists any more Cnames = mkcnamelist(CompList), demit({"Result = "}), %dbg @@ -423,67 +404,143 @@ to_textual_order(Cs) when is_list(Cs) -> 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]), +gen_dec_open_type(Erule, Val, {Xmod,Xtype}, LeadingAttr, + {_,{Name,RestFieldNames},Term,TmpTerm,Prop}) -> + #typedef{typespec=ObjSet0} = asn1_db:dbget(Xmod, Xtype), + #'ObjectSet'{class=Class,set=ObjSet1} = ObjSet0, + #'Externaltypereference'{module=ClMod,type=ClType} = Class, + #classdef{typespec=ClassDef} = asn1_db:dbget(ClMod, ClType), + #objectclass{fields=ClassFields} = ClassDef, + Extensible = lists:member('EXTENSIONMARK', ObjSet1), + ObjSet2 = [{Key,fix_object_code(Name, Code, ClassFields)} || + {_,Key,Code} <- ObjSet1], + ObjSet = lists:sort([P || {_,B}=P <- ObjSet2, B =/= none]), + Key = erlang:md5(term_to_binary({decode,ObjSet,RestFieldNames, + Prop,Extensible})), + Typename = [Name,ClType], + Gen = fun(_Fd, N) -> + dec_objset_optional(N, Prop), + dec_objset(Erule, N, ObjSet, RestFieldNames, Typename), + dec_objset_default(N, Name, LeadingAttr, Extensible) + end, + Prefix = lists:concat(["dec_os_",Name]), + F = asn1ct_func:call_gen(Prefix, Key, Gen), + emit([Term," = ",{asis,F},"(",TmpTerm,", ",Val,")"]). + +dec_objset_optional(N, {'DEFAULT',Val}) -> + dec_objset_optional_1(N, Val), + dec_objset_optional_1(N, asn1_DEFAULT); +dec_objset_optional(N, 'OPTIONAL') -> + dec_objset_optional_1(N, asn1_NOVALUE); +dec_objset_optional(_N, mandatory) -> ok. + +dec_objset_optional_1(N, Val) -> + emit([{asis,N},"(",{asis,Val},", _Id) ->",nl, + {asis,Val},";",nl]). + +dec_objset(_Erule, _N, [], _, _) -> + ok; +dec_objset(Erule, N, [Obj|Objs], RestFields, Cl) -> + dec_objset_1(Erule, N, Obj, RestFields, Cl), + emit([";",nl]), + dec_objset(Erule, N, Objs, RestFields, Cl). + +dec_objset_default(N, C, LeadingAttr, false) -> + emit([{asis,N},"(Bytes, Id) ->",nl, + "exit({'Type not compatible with table constraint'," + "{{component,",{asis,C},"}," + "{value,Bytes}," + "{unique_name_and_value,",{asis,LeadingAttr},",Id}}}).",nl,nl]); +dec_objset_default(N, _, _, true) -> + emit([{asis,N},"(Bytes, Id) ->",nl, + "Bytes.",nl,nl]). + +dec_objset_1(Erule, N, {Id,Obj}, RestFields, Typename) -> + emit([{asis,N},"(Bytes, ",{asis,Id},") ->",nl]), + dec_objset_2(Erule, Obj, RestFields, Typename). + +dec_objset_2(Erule, Obj, RestFields0, Typename) -> + case Obj of + #typedef{name={primitive,bif},typespec=Type} -> + Imm = asn1ct_gen_per:gen_dec_imm(Erule, Type), + {Term,_} = asn1ct_imm:dec_slim_cg(Imm, 'Bytes'), + emit([com,nl,Term]); + #typedef{name={constructed,bif},typespec=Def} -> + InnerType = asn1ct_gen:get_inner(Def#type.def), + case InnerType of + 'CHOICE' -> + asn1ct_name:start(), + asn1ct_name:new(bytes), + {'CHOICE',CompList} = Def#type.def, + Ext = extensible_enc(CompList), + emit(["{Result,_} = begin",nl]), + gen_dec_choice(Erule, Typename, CompList, Ext), + emit([nl, + "end",com,nl, + "Result"]); + 'SET' -> + Imm0 = gen_dec_constructed_imm(Erule, Typename, Def), + Imm = opt_imm(Imm0), + asn1ct_name:start(), + emit(["{Result,_} = begin",nl]), + emit_gen_dec_imm(Imm), + emit([nl, + "end",com,nl, + "Result"]); + 'SET OF' -> + asn1ct_name:start(), + do_gen_decode_sof(Erule, Typename, 'SET OF', + Def, false); + 'SEQUENCE' -> + Imm0 = gen_dec_constructed_imm(Erule, Typename, Def), + Imm = opt_imm(Imm0), + asn1ct_name:start(), + emit(["{Result,_} = begin",nl]), + emit_gen_dec_imm(Imm), + emit([nl, + "end",com,nl, + "Result"]); + 'SEQUENCE OF' -> + asn1ct_name:start(), + do_gen_decode_sof(Erule, Typename, 'SEQUENCE OF', + Def, false) + end; + #typedef{name=Type} -> + emit(["{Result,_} = ",{asis,enc_func("dec_", Type)},"(Bytes),",nl, + "Result"]); + #'Externaltypereference'{module=Mod,type=Type} -> + emit("{Term,_} = "), + Func = enc_func("dec_", Type), + case get(currmod) of + Mod -> + emit([{asis,Func},"(Bytes)"]); + _ -> + emit([{asis,Mod},":",{asis,Func},"(Bytes)"]) + end, + emit([com,nl, + "Term"]); + #'Externalvaluereference'{module=Mod,value=Value} -> + case asn1_db:dbget(Mod, Value) of + #typedef{typespec=#'Object'{def=Def}} -> + {object,_,Fields} = Def, + [NextField|RestFields] = RestFields0, + {NextField,Typedef} = lists:keyfind(NextField, 1, Fields), + dec_objset_2(Erule, Typedef, RestFields, Typename) + end + end. - 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, +gen_encode_choice(Erule, TopType, D) -> + asn1ct_name:start(), + Imm = gen_encode_choice_imm(Erule, TopType, D), + asn1ct_imm:enc_cg(Imm, is_aligned(Erule)), + emit([".",nl]). - 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}), +gen_encode_choice_imm(Erule, TopType, #type{def={'CHOICE',CompList}}) -> Ext = extensible_enc(CompList), - gen_enc_choice(Erule,Typename,CompList,Ext), - emit({nl,"].",nl}). + Aligned = is_aligned(Erule), + Cs = gen_enc_choice(Erule, TopType, CompList, Ext), + [{assign,{expr,"{ChoiceTag,ChoiceVal}"},"Val"}| + asn1ct_imm:per_enc_choice('ChoiceTag', Cs, Aligned)]. gen_decode_choice(Erules,Typename,D) when is_record(D,type) -> asn1ct_name:start(), @@ -496,72 +553,48 @@ gen_decode_choice(Erules,Typename,D) when is_record(D,type) -> %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Encode generator for SEQUENCE OF type - -gen_encode_sof(Erule,Typename,SeqOrSetOf,D) when is_record(D,type) -> +gen_encode_sof(Erule, Typename, SeqOrSetOf, D) -> asn1ct_name:start(), - {_SeqOrSetOf,ComponentType} = D#type.def, - emit({"[",nl}), - SizeConstraint = asn1ct_imm:effective_constraint(bitstring, - D#type.constraint), - ObjFun = - case D#type.tablecinf of - [{objfun,_}|_R] -> - ", ObjFun"; - _-> - "" - end, - gen_encode_length(Erule, SizeConstraint), - emit({indent(3),"'enc_",asn1ct_gen:list2name(Typename), - "_components'(Val",ObjFun,", [])"}), - emit({nl,"].",nl}), - gen_encode_sof_components(Erule, Typename, SeqOrSetOf, ComponentType). - - -%% Logic copied from asn1_per_bin_rt2ct:encode_constrained_number -gen_encode_length(per, {Lb,Ub}) when Ub =< 65535, Lb >= 0 -> - Range = Ub - Lb + 1, - V2 = ["(length(Val) - ",Lb,")"], - Encode = if - Range == 1 -> - "[]"; - Range == 2 -> - {"[",V2,"]"}; - Range =< 4 -> - {"[10,2,",V2,"]"}; - Range =< 8 -> - {"[10,3,",V2,"]"}; - Range =< 16 -> - {"[10,4,",V2,"]"}; - Range =< 32 -> - {"[10,5,",V2,"]"}; - Range =< 64 -> - {"[10,6,",V2,"]"}; - Range =< 128 -> - {"[10,7,",V2,"]"}; - Range =< 255 -> - {"[10,8,",V2,"]"}; - Range =< 256 -> - {"[20,1,",V2,"]"}; - Range =< 65536 -> - {"[20,2,<<",V2,":16>>]"}; - true -> - {call,per,encode_length, - [{asis,{Lb,Ub}},"length(Val)"]} - end, - emit({nl,Encode,",",nl}); -gen_encode_length(Erules, SizeConstraint) -> - emit([nl,indent(3), - case SizeConstraint of - no -> - {call,Erules,encode_length,["length(Val)"]}; - _ -> - {call,Erules,encode_length, - [{asis,SizeConstraint},"length(Val)"]} - end, - com,nl]). + Imm = gen_encode_sof_imm(Erule, Typename, SeqOrSetOf, D), + asn1ct_imm:enc_cg(Imm, is_aligned(Erule)), + emit([".",nl,nl]). -gen_decode_sof(Erules,Typename,SeqOrSetOf,D) when is_record(D,type) -> +gen_encode_sof_imm(Erule, Typename, SeqOrSetOf, #type{}=D) -> + {_SeqOrSetOf,ComponentType} = D#type.def, + Aligned = is_aligned(Erule), + Constructed_Suffix = + asn1ct_gen:constructed_suffix(SeqOrSetOf, + ComponentType#type.def), + Conttype = asn1ct_gen:get_inner(ComponentType#type.def), + Currmod = get(currmod), + Imm0 = case asn1ct_gen:type(Conttype) of + {primitive,bif} -> + asn1ct_gen_per:gen_encode_prim_imm('Comp', ComponentType, Aligned); + {constructed,bif} -> + TypeName = [Constructed_Suffix|Typename], + Enc = enc_func(asn1ct_gen:list2name(TypeName)), + ObjArg = case D#type.tablecinf of + [{objfun,_}|_] -> [{var,"ObjFun"}]; + _ -> [] + end, + [{apply,Enc,[{var,"Comp"}|ObjArg]}]; + #'Externaltypereference'{module=Currmod,type=Ename} -> + [{apply,enc_func(Ename),[{var,"Comp"}]}]; + #'Externaltypereference'{module=EMod,type=Ename} -> + [{apply,{EMod,enc_func(Ename)},[{var,"Comp"}]}]; + 'ASN1_OPEN_TYPE' -> + asn1ct_gen_per:gen_encode_prim_imm('Comp', + #type{def='ASN1_OPEN_TYPE'}, + Aligned) + end, + asn1ct_imm:per_enc_sof('Val', D#type.constraint, 'Comp', Imm0, Aligned). + +gen_decode_sof(Erules, Typename, SeqOrSetOf, #type{}=D) -> asn1ct_name:start(), + do_gen_decode_sof(Erules, Typename, SeqOrSetOf, D, true), + emit([".",nl,nl]). + +do_gen_decode_sof(Erules, Typename, SeqOrSetOf, D, NeedRest) -> {_SeqOrSetOf,ComponentType} = D#type.def, SizeConstraint = asn1ct_imm:effective_constraint(bitstring, D#type.constraint), @@ -573,10 +606,16 @@ gen_decode_sof(Erules,Typename,SeqOrSetOf,D) when is_record(D,type) -> "" end, {Num,Buf} = gen_decode_length(SizeConstraint, Erules), + Key = erlang:md5(term_to_binary({Typename,SeqOrSetOf, + ComponentType,NeedRest})), + Gen = fun(_Fd, Name) -> + gen_decode_sof_components(Erules, Name, + Typename, SeqOrSetOf, + ComponentType, NeedRest) + end, + F = asn1ct_func:call_gen("dec_components", Key, Gen), emit([",",nl, - "'dec_",asn1ct_gen:list2name(Typename), - "_components'(",Num,", ",Buf,ObjFun,", []).",nl,nl]), - gen_decode_sof_components(Erules, Typename, SeqOrSetOf, ComponentType). + {asis,F},"(",Num,", ",Buf,ObjFun,", [])"]). is_aligned(per) -> true; is_aligned(uper) -> false. @@ -586,7 +625,7 @@ gen_decode_length(Constraint, Erule) -> Imm = asn1ct_imm:per_dec_length(Constraint, true, is_aligned(Erule)), asn1ct_imm:dec_slim_cg(Imm, "Bytes"). -gen_encode_sof_components(Erule,Typename,SeqOrSetOf,Cont) -> +gen_decode_sof_components(Erule, Name, Typename, SeqOrSetOf, Cont, NeedRest) -> {ObjFun,ObjFun_Var} = case Cont#type.tablecinf of [{objfun,_}|_R] -> @@ -594,76 +633,38 @@ gen_encode_sof_components(Erule,Typename,SeqOrSetOf,Cont) -> _ -> {"",""} 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), - case asn1ct_gen:type(Conttype) of - {primitive,bif} -> - asn1ct_gen_per:gen_encode_prim(Erule, Cont, "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' -> - asn1ct_gen_per:gen_encode_prim(Erule, - #type{def='ASN1_OPEN_TYPE'}, - "H"); - _ -> - emit({"'enc_",Conttype,"'(H)",nl,nl}) + case NeedRest of + false -> + emit([{asis,Name},"(0, _Bytes",ObjFun_Var,", Acc) ->",nl, + "lists:reverse(Acc);",nl]); + true -> + emit([{asis,Name},"(0, Bytes",ObjFun_Var,", Acc) ->",nl, + "{lists:reverse(Acc),Bytes};",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} = "}), + emit([{asis,Name},"(Num, Bytes",ObjFun,", Acc) ->",nl, + "{Term,Remain} = "]), Constructed_Suffix = asn1ct_gen:constructed_suffix(SeqOrSetOf, Cont#type.def), Conttype = asn1ct_gen:get_inner(Cont#type.def), - Ctgenmod = asn1ct_gen:ct_gen_module(Erule), case asn1ct_gen:type(Conttype) of {primitive,bif} -> - Ctgenmod:gen_dec_prim(Erule,Cont,"Bytes"), + asn1ct_gen_per: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}); + "'(Bytes",ObjFun,"),",nl}); #'Externaltypereference'{}=Etype -> asn1ct_gen_per:gen_dec_external(Etype, "Bytes"), emit([com,nl]); 'ASN1_OPEN_TYPE' -> - Ctgenmod:gen_dec_prim(Erule,#type{def='ASN1_OPEN_TYPE'}, - "Bytes"), + asn1ct_gen_per:gen_dec_prim(Erule, #type{def='ASN1_OPEN_TYPE'}, + "Bytes"), emit({com,nl}); _ -> - emit({"'dec_",Conttype,"'(Bytes,telltype),",nl}) + emit({"'dec_",Conttype,"'(Bytes),",nl}) end, - emit({indent(3),"'dec_",asn1ct_gen:list2name(Typename), - "_components'(Num-1, Remain",ObjFun,", [Term|Acc]).",nl}). + emit([{asis,Name},"(Num-1, Remain",ObjFun,", [Term|Acc]).",nl]). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -754,27 +755,6 @@ gen_dec_optionals(Optionals) -> end, {imm,Imm0,E}. -gen_fixoptionals([{Pos,Def}|R]) -> - asn1ct_name:new(fixopt), - emit({{curr,fixopt}," = case element(",{asis,Pos},",",{curr,val},") of",nl, - "asn1_DEFAULT -> 0;",nl, - {asis,Def}," -> 0;",nl, - "_ -> 1",nl, - "end,",nl}), - gen_fixoptionals(R); -gen_fixoptionals([Pos|R]) -> - gen_fixoptionals([{Pos,asn1_NOVALUE}|R]); -gen_fixoptionals([]) -> - ok. - - -param_map(Fun, [H]) -> - [Fun(H)]; -param_map(Fun, [H|T]) -> - [Fun(H),","|param_map(Fun,T)]. - - - %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% Produce a list with positions (in the Value record) where %% there are optional components, start with 2 because first element @@ -788,15 +768,13 @@ optionals({L1,Ext,L2}) -> 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,_) -> +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). %%%%%%%%%%%%%%%%%%%%%% @@ -858,33 +836,32 @@ add_textual_order1(Cs,NumIn) -> end, NumIn,Cs). -gen_enc_components_call(Erule,TopType,{Root,ExtList},MaybeComma,DynamicEnc,Ext) -> - gen_enc_components_call(Erule,TopType,{Root,ExtList,[]},MaybeComma,DynamicEnc,Ext); -gen_enc_components_call(Erule,TopType,CL={Root,ExtList,Root2},MaybeComma,DynamicEnc,Ext) -> +gen_enc_components_call(Erule,TopType,{Root,ExtList}, DynamicEnc,Ext) -> + gen_enc_components_call(Erule,TopType,{Root,ExtList,[]}, DynamicEnc,Ext); +gen_enc_components_call(Erule,TopType,CL={Root,ExtList,Root2}, DynamicEnc,Ext) -> %% The type has extensionmarker - Rpos = gen_enc_components_call1(Erule,TopType,Root++Root2,1,MaybeComma,DynamicEnc,noext), - case Ext of - {ext,_,ExtNum} when ExtNum > 0 -> - emit([nl, - ",Extensions",nl]); - - _ -> true - end, + {Imm0,Rpos} = gen_enc_components_call1(Erule,TopType,Root++Root2,1, DynamicEnc,noext,[]), + ExtImm = case Ext of + {ext,_,ExtNum} when ExtNum > 0 -> + [{var,"Extensions"}]; + _ -> + [] + end, %handle extensions {extgrouppos,ExtGroupPosLen} = extgroup_pos_and_length(CL), NewExtList = wrap_extensionAdditionGroups(ExtList,ExtGroupPosLen), - gen_enc_components_call1(Erule,TopType,NewExtList,Rpos,MaybeComma,DynamicEnc,Ext); -gen_enc_components_call(Erule,TopType, CompList, MaybeComma, DynamicEnc, Ext) -> + {Imm1,_} = gen_enc_components_call1(Erule,TopType,NewExtList,Rpos,DynamicEnc,Ext,[]), + Imm0 ++ [ExtImm|Imm1]; +gen_enc_components_call(Erule,TopType, CompList, DynamicEnc, Ext) -> %% The type has no extensionmarker - gen_enc_components_call1(Erule,TopType,CompList,1,MaybeComma,DynamicEnc,Ext). + {Imm,_} = gen_enc_components_call1(Erule,TopType,CompList,1,DynamicEnc,Ext,[]), + Imm. gen_enc_components_call1(Erule,TopType, [C=#'ComponentType'{name=Cname,typespec=Type,prop=Prop}|Rest], Tpos, - MaybeComma, DynamicEnc, Ext) -> + DynamicEnc, Ext, Acc) -> - put(component_type,{true,C}), - %% information necessary in asn1ct_gen_per_rt2ct:gen_encode_prim TermNo = case C#'ComponentType'.textual_order of undefined -> @@ -892,90 +869,48 @@ gen_enc_components_call1(Erule,TopType, 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); + Element0 = make_element(TermNo+1, asn1ct_gen:mk_var(asn1ct_name:curr(val))), + {Imm0,Element} = asn1ct_imm:enc_bind_var(Element0), + Imm1 = gen_enc_line_imm(Erule, TopType, Cname, Type, Element, DynamicEnc, Ext), + Category = case {Prop,Ext} of + {'OPTIONAL',_} -> + optional; + {{'DEFAULT',DefVal},_} -> + {default,DefVal}; + {_,{ext,ExtPos,_}} when Tpos >= ExtPos -> + optional; + {_,_} -> + mandatory + end, + Imm2 = case Category of + mandatory -> + Imm1; + optional -> + asn1ct_imm:enc_absent(Element, [asn1_NOVALUE], Imm1); + {default,Def} -> + asn1ct_imm:enc_absent(Element, [asn1_DEFAULT,Def], Imm1) + end, + Imm = case Imm2 of + [] -> []; + _ -> Imm0 ++ Imm2 + end, + gen_enc_components_call1(Erule, TopType, Rest, Tpos+1, DynamicEnc, Ext, [Imm|Acc]); +gen_enc_components_call1(_Erule,_TopType,[],Pos,_,_, Acc) -> + ImmList = lists:reverse(Acc), + {ImmList,Pos}. + +gen_enc_line_imm(Erule, TopType, Cname, Type, Element, DynamicEnc, Ext) -> + Imm0 = gen_enc_line_imm_1(Erule, TopType, Cname, Type, + Element, DynamicEnc), + Aligned = is_aligned(Erule), + case Ext of + {ext,_Ep2,_} -> + asn1ct_imm:per_enc_open_type(Imm0, Aligned); _ -> - 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), + Imm0 + end. - 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,asn1ct_gen:mk_var(asn1ct_name:curr(val))), - 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=#type{def=#'SEQUENCE'{ - extaddgroup=Number, - components=_ExtGroupCompList}}, - Pos,DynamicEnc,Ext) when is_integer(Number) -> - - Element = make_element(Pos+1,asn1ct_gen:mk_var(asn1ct_name:curr(val))), - 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_optional(Erule,TopType,Cname,Type,Pos,DynamicEnc,Ext) -> - Element = make_element(Pos+1,asn1ct_gen:mk_var(asn1ct_name:curr(val))), - 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))), - gen_enc_line(Erule,TopType,Cname,Type,Element, Pos,DynamicEnc,Ext); -gen_enc_line(Erule,TopType,Cname,Type,Element, _Pos,DynamicEnc,Ext) -> +gen_enc_line_imm_1(Erule, TopType, Cname, Type, Element, DynamicEnc) -> Atype = case Type of #type{def=#'ObjectClassFieldType'{type=InnerType}} -> @@ -983,81 +918,157 @@ gen_enc_line(Erule,TopType,Cname,Type,Element, _Pos,DynamicEnc,Ext) -> _ -> asn1ct_gen:get_inner(Type#type.def) end, - - case Ext of - {ext,_Ep1,_} -> - asn1ct_func:need({Erule,encode_open_type,1}), - asn1ct_func:need({Erule,complete,1}), - emit(["encode_open_type(complete("]); - _ -> true - end, - + Aligned = is_aligned(Erule), case Atype of {typefield,_} -> - case DynamicEnc of - {_LeadingAttrName,Fun} -> - case (Type#type.def)#'ObjectClassFieldType'.fieldname of - {Name,RestFieldNames} when is_atom(Name) -> - asn1ct_func:need({Erule,complete,1}), - asn1ct_func:need({Erule,encode_open_type,1}), - emit({"encode_open_type(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} -> - asn1ct_func:need({Erule,complete,1}), - asn1ct_func:need({Erule,encode_open_type,1}), - emit({"encode_open_type(" - "complete(",nl}), - emit({" ",Fun,"(",{asis,PrimFieldName1}, - ", ",Element,", ",{asis,PFNList},")))"}) + {_LeadingAttrName,Fun} = DynamicEnc, + case (Type#type.def)#'ObjectClassFieldType'.fieldname of + {Name,RestFieldNames} when is_atom(Name) -> + Imm = enc_var_type_call(Erule, Name, RestFieldNames, + Type, Fun, Element), + asn1ct_imm:per_enc_open_type(Imm, Aligned) end; _ -> CurrMod = get(currmod), case asn1ct_gen:type(Atype) of - #'Externaltypereference'{module=Mod,type=EType} when - (CurrMod==Mod) -> - emit({"'enc_",EType,"'(",Element,")"}); + #'Externaltypereference'{module=CurrMod,type=EType} -> + [{apply,enc_func(EType),[{expr,Element}]}]; #'Externaltypereference'{module=Mod,type=EType} -> - emit({"'",Mod,"':'enc_", - EType,"'(",Element,")"}); + [{apply,{Mod,enc_func(EType)},[{expr,Element}]}]; {primitive,bif} -> - asn1ct_gen_per:gen_encode_prim(Erule, Type, Element); + asn1ct_gen_per:gen_encode_prim_imm(Element, Type, Aligned); 'ASN1_OPEN_TYPE' -> case Type#type.def of #'ObjectClassFieldType'{type=OpenType} -> - asn1ct_gen_per:gen_encode_prim(Erule, - #type{def=OpenType}, - Element); + asn1ct_gen_per:gen_encode_prim_imm(Element, + #type{def=OpenType}, + Aligned); _ -> - asn1ct_gen_per:gen_encode_prim(Erule, Type, - Element) + asn1ct_gen_per:gen_encode_prim_imm(Element, + Type, + Aligned) end; {constructed,bif} -> NewTypename = [Cname|TopType], + Enc = enc_func(asn1ct_gen:list2name(NewTypename)), case {Type#type.tablecinf,DynamicEnc} of {[{objfun,_}|_R],{_,EncFun}} -> - emit({"'enc_", - asn1ct_gen:list2name(NewTypename), - "'(",Element,", ",EncFun,")"}); + [{apply,Enc,[{expr,Element},{var,EncFun}]}]; _ -> - emit({"'enc_", - asn1ct_gen:list2name(NewTypename), - "'(",Element,")"}) + [{apply,Enc,[{expr,Element}]}] end end - end, - case Ext of - {ext,_Ep2,_} -> - emit("))"); - _ -> true end. +enc_func(Type) -> + enc_func("enc_", Type). + +enc_func(Prefix, Name) -> + list_to_atom(lists:concat([Prefix,Name])). + +enc_var_type_call(Erule, Name, RestFieldNames, + #type{tablecinf=TCI}, Fun, Val) -> + [{objfun,#'Externaltypereference'{module=Xmod,type=Xtype}}] = TCI, + #typedef{typespec=ObjSet0} = asn1_db:dbget(Xmod, Xtype), + #'ObjectSet'{class=Class,set=ObjSet1} = ObjSet0, + #'Externaltypereference'{module=ClMod,type=ClType} = Class, + #classdef{typespec=ClassDef} = asn1_db:dbget(ClMod, ClType), + #objectclass{fields=ClassFields} = ClassDef, + Extensible = lists:member('EXTENSIONMARK', ObjSet1), + ObjSet2 = [{Key,fix_object_code(Name, Code, ClassFields)} || + {_,Key,Code} <- ObjSet1], + ObjSet = lists:sort([P || {_,B}=P <- ObjSet2, B =/= none]), + Key = erlang:md5(term_to_binary({encode,ObjSet,RestFieldNames,Extensible})), + Gen = fun(_Fd, N) -> + enc_objset(Erule, Name, N, ObjSet, + RestFieldNames, Extensible) + end, + Prefix = lists:concat(["enc_os_",Name]), + F = asn1ct_func:call_gen(Prefix, Key, Gen), + [{apply,F,[{var,atom_to_list(Val)},{var,Fun}]}]. + +fix_object_code(Name, [{Name,B}|_], _ClassFields) -> + B; +fix_object_code(Name, [_|T], ClassFields) -> + fix_object_code(Name, T, ClassFields); +fix_object_code(Name, [], ClassFields) -> + case lists:keyfind(Name, 2, ClassFields) of + {typefield,Name,'OPTIONAL'} -> + none; + {objectfield,Name,_,_,'OPTIONAL'} -> + none; + {typefield,Name,{'DEFAULT',#type{}=Type}} -> + InnerType = asn1ct_gen:get_inner(Type#type.def), + case asn1ct_gen:type(InnerType) of + {primitive,bif} -> + #typedef{name={primitive,bif},typespec=Type}; + {constructed,bif} -> + #typedef{name={constructed,bif},typespec=Type} + end + end. + + +enc_objset(Erule, Component, Name, ObjSet, RestFieldNames, Extensible) -> + asn1ct_name:start(), + Aligned = is_aligned(Erule), + E = {error, + fun() -> + emit(["exit({'Type not compatible with table constraint'," + "{component,",{asis,Component},"}," + "{value,Val}," + "{unique_name_and_value,'_'}})",nl]) + end}, + Imm = [{'cond', + [[{eq,{var,"Id"},Key}| + enc_obj(Erule, Obj, RestFieldNames, Aligned)] || + {Key,Obj} <- ObjSet] ++ + [['_',case Extensible of + false -> E; + true -> {put_bits,{var,"Val"},binary,[1]} + end]]}], + emit([{asis,Name},"(Val, Id) ->",nl]), + asn1ct_imm:enc_cg(Imm, Aligned), + emit([".",nl]). + +enc_obj(Erule, Obj, RestFieldNames0, Aligned) -> + case Obj of + #typedef{name={primitive,bif},typespec=Def} -> + asn1ct_gen_per:gen_encode_prim_imm('Val', Def, Aligned); + #typedef{name={constructed,bif},typespec=Def} -> + InnerType = asn1ct_gen:get_inner(Def#type.def), + case InnerType of + 'CHOICE' -> + gen_encode_choice_imm(Erule, name, Def); + 'SET' -> + gen_encode_constructed_imm(Erule, name, Def); + 'SET OF' -> + gen_encode_sof_imm(Erule, name, InnerType, Def); + 'SEQUENCE' -> + gen_encode_constructed_imm(Erule, name, Def); + 'SEQUENCE OF' -> + gen_encode_sof_imm(Erule, name, InnerType, Def) + end; + #typedef{name=Type} -> + [{apply,enc_func(Type),[{var,"Val"}]}]; + #'Externalvaluereference'{module=Mod,value=Value} -> + case asn1_db:dbget(Mod, Value) of + #typedef{typespec=#'Object'{def=Def}} -> + {object,_,Fields} = Def, + [NextField|RestFieldNames] = RestFieldNames0, + {NextField,Typedef} = lists:keyfind(NextField, 1, Fields), + enc_obj(Erule, Typedef, RestFieldNames, Aligned) + end; + #'Externaltypereference'{module=Mod,type=Type} -> + Func = enc_func(Type), + case get(currmod) of + Mod -> + [{apply,Func,[{var,"Val"}]}]; + _ -> + [{apply,{Mod,Func},[{var,"Val"}]}] + end + end. + + gen_dec_components_call(Erule, TopType, {Root,ExtList}, DecInfObj, Ext, NumberOfOptionals) -> gen_dec_components_call(Erule,TopType,{Root,ExtList,[]}, @@ -1163,14 +1174,6 @@ gen_dec_comp_call(Comp, Erule, TopType, Tpos, OptTable, DecInfObj, emit(["{",{curr,tmpterm},", ",{next,bytes},"} = "]), St end; - %%{objectfield,_,_} when Ext == noext, Prop == mandatory -> - {{objectfield,_,_},true} -> - fun(St) -> - asn1ct_name:new(term), - asn1ct_name:new(tmpterm), - emit(["{",{curr,tmpterm},", ",{next,bytes},"} = "]), - St - end; _ -> case Type of #type{def=#'SEQUENCE'{ @@ -1350,25 +1353,19 @@ gen_dec_line_special(Erule, {typefield,_}, _TopType, Comp, false -> % This is in a choice with typefield components {Name,RestFieldNames} = (Type#type.def)#'ObjectClassFieldType'.fieldname, - - asn1ct_name:new(reason), Imm = asn1ct_imm:per_dec_open_type(is_aligned(Erule)), BytesVar = asn1ct_gen:mk_var(asn1ct_name:curr(bytes)), {TmpTerm,TempBuf} = asn1ct_imm:dec_slim_cg(Imm, BytesVar), + emit([com,nl]), + #type{tablecinf=[{objfun, + #'Externaltypereference'{module=Xmod, + type=Xtype}}]} = + Type, + gen_dec_open_type(Erule, "ObjFun", {Xmod,Xtype}, + '_', {'_',{Name,RestFieldNames}, + 'Result',TmpTerm,mandatory}), emit([com,nl, - {next,bytes}," = ",TempBuf,com,nl, - indent(2),"case (catch ObjFun(", - {asis,Name},",",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"]), + "{",{asis,Cname},",{Result,",TempBuf,"}}"]), {[],PrevSt}; {"got objfun through args","ObjFun"} -> %% this is when the generated code gots the @@ -1388,27 +1385,22 @@ gen_dec_line_special(Erule, {typefield,_}, _TopType, Comp, BytesVar = asn1ct_gen:mk_var(asn1ct_name:curr(bytes)), asn1ct_imm:dec_code_gen(Imm, BytesVar), emit([com,nl]), + #type{tablecinf=[{objfun, + #'Externaltypereference'{module=Xmod, + type=Xtype}}]} = + Type, + Term = asn1ct_gen:mk_var(asn1ct_name:curr(term)), + TmpTerm = asn1ct_gen:mk_var(asn1ct_name:curr(tmpterm)), if 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 - Prop =:= mandatory -> - ok; + gen_dec_open_type(Erule, "ObjFun", {Xmod,Xtype}, + '_', {'_',{Name,RestFieldNames}, + Term,TmpTerm,Prop}); true -> + emit([" {"]), + gen_dec_open_type(Erule, "ObjFun", {Xmod,Xtype}, + '_', {'_',{Name,RestFieldNames}, + '_',TmpTerm,Prop}), emit([",",nl,{curr,tmpbytes},"}"]) end, {[],PrevSt}; @@ -1425,19 +1417,6 @@ gen_dec_line_special(Erule, {typefield,_}, _TopType, Comp, Prop}],PrevSt} end end; -gen_dec_line_special(Erule, {objectfield,PrimFieldName1,PFNList}, _TopType, - Comp, _DecInfObj) -> - fun({_BytesVar,PrevSt}) -> - Imm = asn1ct_imm:per_dec_open_type(is_aligned(Erule)), - BytesVar = asn1ct_gen:mk_var(asn1ct_name:curr(bytes)), - asn1ct_imm:dec_code_gen(Imm, BytesVar), - #'ComponentType'{name=Cname,prop=Prop} = Comp, - SaveBytes = [{Cname,{PrimFieldName1,PFNList}, - asn1ct_gen:mk_var(asn1ct_name:curr(term)), - asn1ct_gen:mk_var(asn1ct_name:curr(tmpterm)), - Prop}], - {SaveBytes,PrevSt} - end; gen_dec_line_special(Erule, Atype, TopType, Comp, DecInfObj) -> case gen_dec_line_other(Erule, Atype, TopType, Comp) of Fun when is_function(Fun, 1) -> @@ -1458,14 +1437,11 @@ gen_dec_line_special(Erule, Atype, TopType, Comp, DecInfObj) -> gen_dec_line_dec_inf(Comp, DecInfObj) -> #'ComponentType'{name=Cname} = Comp, case DecInfObj of - {Cname,{_,OSet,UniqueFName,ValIndex}} -> + {Cname,{_,_OSet,_UniqueFName,ValIndex}} -> Term = asn1ct_gen:mk_var(asn1ct_name:curr(term)), ValueMatch = value_match(ValIndex,Term), - {ObjSetMod,ObjSetName} = OSet, emit([",",nl, - "ObjFun = ",{asis,ObjSetMod}, - ":'getdec_",ObjSetName,"'(", - {asis,UniqueFName},", ",ValueMatch,")"]); + "ObjFun = ",ValueMatch]); _ -> ok end. @@ -1492,63 +1468,35 @@ gen_dec_line_other(Erule, Atype, TopType, Comp) -> [{objfun,_}|_R] -> fun(BytesVar) -> emit({"'dec_",asn1ct_gen:list2name(NewTypename), - "'(",BytesVar,", telltype, ObjFun)"}) + "'(",BytesVar,", ObjFun)"}) end; _ -> fun(BytesVar) -> emit({"'dec_",asn1ct_gen:list2name(NewTypename), - "'(",BytesVar,", telltype)"}) + "'(",BytesVar,")"}) end end end. -gen_enc_choice(Erule,TopType,CompList,Ext) -> - gen_enc_choice_tag(Erule, 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(Erule, {C1,C2}, _, _) -> - N1 = get_name_list(C1), - N2 = get_name_list(C2), - call(Erule,set_choice, - ["element(1, Val)", - {asis,{N1,N2}}, - {asis,{length(N1),length(N2)}}]); -gen_enc_choice_tag(Erule, {C1,C2,C3}, _, _) -> - N1 = get_name_list(C1), - N2 = get_name_list(C2), - N3 = get_name_list(C3), - Root = N1 ++ N3, - call(Erule,set_choice, - ["element(1, Val)", - {asis,{Root,N2}}, - {asis,{length(Root),length(N2)}}]); -gen_enc_choice_tag(Erule, C, _, _) -> - N = get_name_list(C), - call(Erule,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, {L1,L2,L3}, Ext) -> - gen_enc_choice2(Erule, TopType, L1 ++ L3 ++ L2, 0, [], Ext); -gen_enc_choice2(Erule,TopType, L, Ext) -> - gen_enc_choice2(Erule,TopType, L, 0, [], Ext). +gen_enc_choice(Erule, TopType, {Root,Exts}, Ext) -> + Constr = choice_constraint(Root), + gen_enc_choices(Root, Erule, TopType, 0, Constr, Ext) ++ + gen_enc_choices(Exts, Erule, TopType, 0, ext, Ext); +gen_enc_choice(Erule, TopType, {Root,Exts,[]}, Ext) -> + gen_enc_choice(Erule, TopType, {Root,Exts}, Ext); +gen_enc_choice(Erule, TopType, Root, Ext) when is_list(Root) -> + Constr = choice_constraint(Root), + gen_enc_choices(Root, Erule, TopType, 0, Constr, Ext). + +choice_constraint(L) -> + case length(L) of + 0 -> [{'SingleValue',0}]; + Len -> [{'ValueRange',{0,Len-1}}] + end. -gen_enc_choice2(Erule, TopType, [H|T], Pos, Sep0, Ext) -> +gen_enc_choices([H|T], Erule, TopType, Pos, Constr, Ext) -> #'ComponentType'{name=Cname,typespec=Type} = H, + Aligned = is_aligned(Erule), EncObj = case asn1ct_gen:get_constraint(Type#type.constraint, componentrelation) of @@ -1562,16 +1510,25 @@ gen_enc_choice2(Erule, TopType, [H|T], Pos, Sep0, Ext) -> _ -> {no_attr,"ObjFun"} end, - emit([Sep0,{asis,Cname}," ->",nl]), - DoExt = case Ext of - {ext,ExtPos,_} when Pos + 1 < ExtPos -> noext; - _ -> Ext + DoExt = case Constr of + ext -> Ext; + _ -> noext end, - gen_enc_line(Erule, TopType, Cname, Type, "element(2, Val)", - Pos+1, EncObj, DoExt), - Sep = [";",nl], - gen_enc_choice2(Erule, TopType, T, Pos+1, Sep, Ext); -gen_enc_choice2(_, _, [], _, _, _) -> ok. + Tag = case {Ext,Constr} of + {noext,_} -> + asn1ct_imm:per_enc_integer(Pos, Constr, Aligned); + {{ext,_,_},ext} -> + [{put_bits,1,1,[1]}| + asn1ct_imm:per_enc_small_number(Pos, Aligned)]; + {{ext,_,_},_} -> + [{put_bits,0,1,[1]}| + asn1ct_imm:per_enc_integer(Pos, Constr, Aligned)] + end, + Body = gen_enc_line_imm(Erule, TopType, Cname, Type, 'ChoiceVal', + EncObj, DoExt), + Imm = Tag ++ Body, + [{Cname,Imm}|gen_enc_choices(T, Erule, TopType, Pos+1, Constr, Ext)]; +gen_enc_choices([], _, _, _, _, _) -> []. %% Generate the code for CHOICE. If the CHOICE is extensible, %% the structure of the generated code is as follows: @@ -1704,9 +1661,6 @@ gen_dec_choice2(Erule, TopType, [H0|T], Pos, Sep0, Pre) -> gen_dec_choice2(Erule, TopType, T, Pos+1, Sep, Pre); gen_dec_choice2(_, _, [], _, _, _) -> ok. -indent(N) -> - lists:duplicate(N,32). % 32 = space - make_elements(I,Val,ExtCnames) -> make_elements(I,Val,ExtCnames,[]). @@ -1720,7 +1674,7 @@ make_elements(_I,_,[],Acc) -> lists:reverse(Acc). make_element(I, Val) -> - io_lib:format("element(~w,~s)", [I,Val]). + lists:flatten(io_lib:format("element(~w, ~s)", [I,Val])). emit_extaddgroupTerms(VarSeries,[_]) -> asn1ct_name:new(VarSeries), @@ -1787,6 +1741,3 @@ 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). - -is_optimized(per) -> true; -is_optimized(uper) -> false. diff --git a/lib/asn1/src/asn1ct_eval_per.funcs b/lib/asn1/src/asn1ct_eval_per.funcs deleted file mode 100644 index a1ea5cd043..0000000000 --- a/lib/asn1/src/asn1ct_eval_per.funcs +++ /dev/null @@ -1,2 +0,0 @@ -{per,encode_constrained_number,2}. -{per,encode_small_number,1}. diff --git a/lib/asn1/src/asn1ct_eval_uper.funcs b/lib/asn1/src/asn1ct_eval_uper.funcs deleted file mode 100644 index 884a486f40..0000000000 --- a/lib/asn1/src/asn1ct_eval_uper.funcs +++ /dev/null @@ -1,2 +0,0 @@ -{uper,encode_constrained_number,2}. -{uper,encode_small_number,1}. diff --git a/lib/asn1/src/asn1ct_func.erl b/lib/asn1/src/asn1ct_func.erl index ab0dbcce8f..dbadedb683 100644 --- a/lib/asn1/src/asn1ct_func.erl +++ b/lib/asn1/src/asn1ct_func.erl @@ -19,7 +19,7 @@ %% -module(asn1ct_func). --export([start_link/0,need/1,call/3,generate/1]). +-export([start_link/0,need/1,call/3,call_gen/3,call_gen/4,generate/1]). -export([init/1,handle_call/3,handle_cast/2,terminate/2]). start_link() -> @@ -28,15 +28,33 @@ start_link() -> ok. call(M, F, Args) -> - MFA = {M,F,length(Args)}, + A = length(Args), + MFA = {M,F,A}, need(MFA), - asn1ct_gen:emit([F,"(",call_args(Args, ""),")"]). + case M of + binary -> + asn1ct_gen:emit(["binary:",F,"(",call_args(Args, ""),")"]); + _ -> + asn1ct_gen:emit([F,"(",call_args(Args, ""),")"]) + end. +need({binary,_,_}) -> + ok; +need({erlang,_,_}) -> + ok; need(MFA) -> asn1ct_rtt:assert_defined(MFA), cast({need,MFA}). +call_gen(Prefix, Key, Gen, Args) when is_function(Gen, 2) -> + F = req({gen_func,Prefix,Key,Gen}), + asn1ct_gen:emit([F,"(",call_args(Args, ""),")"]). + +call_gen(Prefix, Key, Gen) when is_function(Gen, 2) -> + req({gen_func,Prefix,Key,Gen}). + generate(Fd) -> + do_generate(Fd), Used0 = req(get_used), erase(?MODULE), Used = sofs:set(Used0, [mfa]), @@ -53,10 +71,13 @@ cast(Req) -> %%% Internal functions. --record(st, {used}). +-record(st, {used, %Used functions + gen, %Dynamically generated functions + gc=1 %Counter for generated functions + }). init([]) -> - St = #st{used=gb_sets:empty()}, + St = #st{used=gb_sets:empty(),gen=gb_trees:empty()}, {ok,St}. handle_cast({need,MFA}, #st{used=Used0}=St) -> @@ -69,7 +90,20 @@ handle_cast({need,MFA}, #st{used=Used0}=St) -> end. handle_call(get_used, _From, #st{used=Used}=St) -> - {stop,normal,gb_sets:to_list(Used),St}. + {stop,normal,gb_sets:to_list(Used),St}; +handle_call(get_gen, _From, #st{gen=G0}=St) -> + {L,G} = do_get_gen(gb_trees:to_list(G0), [], []), + {reply,L,St#st{gen=gb_trees:from_orddict(G)}}; +handle_call({gen_func,Prefix,Key,GenFun}, _From, #st{gen=G0,gc=Gc0}=St) -> + case gb_trees:lookup(Key, G0) of + none -> + Name = list_to_atom(Prefix ++ integer_to_list(Gc0)), + Gc = Gc0 + 1, + G = gb_trees:insert(Key, {Name,GenFun}, G0), + {reply,Name,St#st{gen=G,gc=Gc}}; + {value,{Name,_}} -> + {reply,Name,St} + end. terminate(_, _) -> ok. @@ -98,3 +132,22 @@ update_worklist([H|T], Used, Ws) -> update_worklist(T, Used, Ws) end; update_worklist([], _, Ws) -> Ws. + +do_get_gen([{_,{_,done}}=Keep|T], Gacc, Kacc) -> + do_get_gen(T, Gacc, [Keep|Kacc]); +do_get_gen([{K,{Name,_}=V}|T], Gacc, Kacc) -> + do_get_gen(T, [V|Gacc], [{K,{Name,done}}|Kacc]); +do_get_gen([], Gacc, Kacc) -> + {lists:sort(Gacc),lists:reverse(Kacc)}. + +do_generate(Fd) -> + case req(get_gen) of + [] -> + ok; + [_|_]=Gen -> + _ = [begin + ok = file:write(Fd, "\n"), + GenFun(Fd, Name) + end || {Name,GenFun} <- Gen], + do_generate(Fd) + end. diff --git a/lib/asn1/src/asn1ct_gen.erl b/lib/asn1/src/asn1ct_gen.erl index 9095e145a3..e6ec0cb12b 100644 --- a/lib/asn1/src/asn1ct_gen.erl +++ b/lib/asn1/src/asn1ct_gen.erl @@ -798,7 +798,12 @@ pgen_exports(Erules,_Module,{Types,Values,_,_,Objects,ObjectSets}) -> gen_exports1(Types,"enc_",1) end, emit({"-export([",nl}), - gen_exports1(Types,"dec_",2) + case Erules of + ber -> + gen_exports1(Types, "dec_", 2); + _ -> + gen_exports1(Types, "dec_", 1) + end end, case [X || {n2n,X} <- get(encoding_options)] of [] -> ok; @@ -819,10 +824,7 @@ pgen_exports(Erules,_Module,{Types,Values,_,_,Objects,ObjectSets}) -> _ -> case erule(Erules) of per -> - emit({"-export([",nl}), - gen_exports1(Objects,"enc_",3), - emit({"-export([",nl}), - gen_exports1(Objects,"dec_",4); + ok; ber -> emit({"-export([",nl}), gen_exports1(Objects,"enc_",3), @@ -833,10 +835,15 @@ pgen_exports(Erules,_Module,{Types,Values,_,_,Objects,ObjectSets}) -> case ObjectSets of [] -> ok; _ -> - emit({"-export([",nl}), - gen_exports1(ObjectSets,"getenc_",2), - emit({"-export([",nl}), - gen_exports1(ObjectSets,"getdec_",2) + case erule(Erules) of + per -> + ok; + ber -> + emit({"-export([",nl}), + gen_exports1(ObjectSets, "getenc_",1), + emit({"-export([",nl}), + gen_exports1(ObjectSets, "getdec_",1) + end end, emit({"-export([info/0]).",nl}), gen_partial_inc_decode_exports(), @@ -916,15 +923,23 @@ pgen_dispatcher(Erules,_Module,{Types,_Values,_,_,_Objects,_ObjectSets}) -> {["complete(encode_disp(Type, Data))"],"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,",BytesAsBinary,"};",nl, - " Bytes ->",nl, - " {ok,",BytesAsBinary,"}",nl, + "try ",Call," of",nl, + case erule(Erules) of + ber -> + [" {Bytes,_Len} ->",nl, + " {ok,",BytesAsBinary,"}",nl]; + per -> + [" Bytes ->",nl, + " {ok,",BytesAsBinary,"}",nl] + end, + " catch",nl, + " Class:Exception when Class =:= error; Class =:= exit ->",nl, + " case Exception of",nl, + " {error,Reason}=Error ->",nl, + " Error;",nl, + " Reason ->",nl, + " {error,{asn1,Reason}}",nl, + " end",nl, "end.",nl,nl]), Return_rest = lists:member(undec_rest,get(encoding_options)), @@ -999,7 +1014,7 @@ pgen_dispatcher(Erules,_Module,{Types,_Values,_,_,_Objects,_ObjectSets}) -> gen_partial_inc_dispatcher(); _PerOrPer_bin -> gen_dispatcher(Types,"encode_disp","enc_",""), - gen_dispatcher(Types,"decode_disp","dec_",",mandatory") + gen_dispatcher(Types,"decode_disp","dec_","") end, emit([nl]), emit({nl,nl}). diff --git a/lib/asn1/src/asn1ct_gen_ber_bin_v2.erl b/lib/asn1/src/asn1ct_gen_ber_bin_v2.erl index 8ab49aec2c..de81259fcb 100644 --- a/lib/asn1/src/asn1ct_gen_ber_bin_v2.erl +++ b/lib/asn1/src/asn1ct_gen_ber_bin_v2.erl @@ -196,8 +196,16 @@ gen_encode_prim(_Erules, #type{}=D, DoTag, Value) -> emit(["case ",Value," of",nl]), emit_enc_enumerated_cases(NamedNumberList,DoTag); 'REAL' -> - emit([{call,ber,encode_tags, - [DoTag,{call,real_common,ber_encode_real,[Value]}]}]); + asn1ct_name:new(realval), + asn1ct_name:new(realsize), + emit(["begin",nl, + {curr,realval}," = ", + {call,real_common,ber_encode_real,[Value]},com,nl, + {curr,realsize}," = ", + {call,erlang,byte_size,[{curr,realval}]},com,nl, + {call,ber,encode_tags, + [DoTag,{curr,realval},{curr,realsize}]},nl, + "end"]); {'BIT STRING',NamedNumberList} -> call(encode_bit_string, [{asis,BitStringConstraint},Value, @@ -637,9 +645,6 @@ gen_encode_objectfields(ClassName,[{typefield,Name,OptOrMand}|Rest], % ", 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}"]), @@ -672,9 +677,6 @@ gen_encode_objectfields(ClassName,[{objectfield,Name,_,_,OptOrMand}|Rest], % 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}, @@ -807,9 +809,6 @@ gen_decode_objectfields(ClassName,[{typefield,Name,OptOrMand}|Rest], % ", 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"]), @@ -844,9 +843,6 @@ gen_decode_objectfields(ClassName,[{objectfield,Name,_,_,OptOrMand}|Rest], % ", 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}, @@ -1072,8 +1068,7 @@ gen_objset_enc(_,_,{unique,undefined},_,_,_,_,_) -> gen_objset_enc(Erules, ObjSetName, UniqueName, [{ObjName,Val,Fields}|T], ClName, ClFields, NthObj,Acc)-> - emit(["'getenc_",ObjSetName,"'(",{asis,UniqueName},",",{asis,Val}, - ") ->",nl]), + emit(["'getenc_",ObjSetName,"'(",{asis,Val},") ->",nl]), CurrMod = get(currmod), {InternalFunc,NewNthObj}= case ObjName of @@ -1095,7 +1090,7 @@ gen_objset_enc(Erules, ObjSetName, UniqueName, %% See X.681 Annex E for the following case gen_objset_enc(_,ObjSetName,_UniqueName,['EXTENSIONMARK'],_ClName, _ClFields,_NthObj,Acc) -> - emit({"'getenc_",ObjSetName,"'(_, _) ->",nl}), + 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) -> byte_size(Bin);",nl,indent(9), @@ -1113,7 +1108,7 @@ emit_ext_fun(EncDec,ModuleName,Name) -> Name,"'(T,V,O) end"]). emit_default_getenc(ObjSetName,UniqueName) -> - emit(["'getenc_",ObjSetName,"'(",{asis,UniqueName},", ErrV) ->",nl]), + emit(["'getenc_",ObjSetName,"'(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 @@ -1240,8 +1235,7 @@ gen_objset_dec(_,_,{unique,undefined},_,_,_,_) -> ok; gen_objset_dec(Erules, ObjSName, UniqueName, [{ObjName,Val,Fields}|T], ClName, ClFields, NthObj)-> - emit(["'getdec_",ObjSName,"'(",{asis,UniqueName},",", - {asis,Val},") ->",nl]), + emit(["'getdec_",ObjSName,"'(",{asis,Val},") ->",nl]), CurrMod = get(currmod), NewNthObj= case ObjName of @@ -1262,7 +1256,7 @@ gen_objset_dec(Erules, ObjSName, UniqueName, [{ObjName,Val,Fields}|T], ClFields, NewNthObj); gen_objset_dec(_,ObjSetName,_UniqueName,['EXTENSIONMARK'],_ClName, _ClFields,_NthObj) -> - emit(["'getdec_",ObjSetName,"'(_, _) ->",nl]), + emit(["'getdec_",ObjSetName,"'(_) ->",nl]), emit([indent(2),"fun(_,Bytes, _RestPrimFieldName) ->",nl]), emit([indent(4),"case Bytes of",nl, @@ -1279,7 +1273,7 @@ gen_objset_dec(_, ObjSetName, UniqueName, [], _, _, _) -> ok. emit_default_getdec(ObjSetName,UniqueName) -> - emit(["'getdec_",ObjSetName,"'(",{asis,UniqueName},", ErrV) ->",nl]), + emit(["'getdec_",ObjSetName,"'(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, ClFields, ObjSetName, NthObj) -> diff --git a/lib/asn1/src/asn1ct_gen_per.erl b/lib/asn1/src/asn1ct_gen_per.erl index 69d9d51bf1..8b999ddbf0 100644 --- a/lib/asn1/src/asn1ct_gen_per.erl +++ b/lib/asn1/src/asn1ct_gen_per.erl @@ -26,7 +26,7 @@ %-compile(export_all). -export([gen_dec_imm/2]). --export([gen_dec_prim/3,gen_encode_prim/3]). +-export([gen_dec_prim/3,gen_encode_prim_imm/3]). -export([gen_obj_code/3,gen_objectset_code/2]). -export([gen_decode/2, gen_decode/3]). -export([gen_encode/2, gen_encode/3]). @@ -102,832 +102,106 @@ gen_encode_prim(Erules, D) -> Value = asn1ct_gen:mk_var(asn1ct_name:curr(val)), gen_encode_prim(Erules, D, Value). -gen_encode_prim(Erules, #type{def={'ENUMERATED',{N1,N2}}}, Value) -> - NewList = [{0,X} || {X,_} <- N1] ++ ['EXT_MARK'] ++ - [{1,X} || {X,_} <- N2], - NewC = {0,length(N1)-1}, - emit(["case ",Value," of",nl]), - emit_enc_enumerated_cases(Erules, NewC, NewList, 0); -gen_encode_prim(Erules, #type{def={'ENUMERATED',NNL}}, Value) -> - NewList = [X || {X,_} <- NNL], - NewC = {0,length(NewList)-1}, - emit(["case ",Value," of",nl]), - emit_enc_enumerated_cases(Erules, NewC, NewList, 0); -gen_encode_prim(per=Erules, D, Value) -> - asn1ct_gen_per_rt2ct:gen_encode_prim(Erules, D, Value); gen_encode_prim(Erules, #type{}=D, Value) -> - Constraint = D#type.constraint, - SizeConstr = asn1ct_imm:effective_constraint(bitstring, Constraint), - Pa = case lists:keyfind('PermittedAlphabet', 1, Constraint) of - false -> no; - {_,Pa0} -> Pa0 - end, - case D#type.def of + Aligned = case Erules of + uper -> false; + per -> true + end, + Imm = gen_encode_prim_imm(Value, D, Aligned), + asn1ct_imm:enc_cg(Imm, Aligned). + +gen_encode_prim_imm(Val, #type{def=Type0,constraint=Constraint}, Aligned) -> + case simplify_type(Type0) of + k_m_string -> + Type = case Type0 of + 'GeneralizedTime' -> 'VisibleString'; + 'UTCTime' -> 'VisibleString'; + _ -> Type0 + end, + asn1ct_imm:per_enc_k_m_string(Val, Type, Constraint, Aligned); + restricted_string -> + ToBinary = {erlang,iolist_to_binary}, + asn1ct_imm:per_enc_restricted_string(Val, ToBinary, Aligned); + {'ENUMERATED',NNL} -> + asn1ct_imm:per_enc_enumerated(Val, NNL, Aligned); 'INTEGER' -> - Args = [{asis,asn1ct_imm:effective_constraint(integer,Constraint)}, - Value], - call(Erules, encode_integer, Args); - {'INTEGER',NamedNumberList} -> - Args = [{asis,asn1ct_imm:effective_constraint(integer,Constraint)}, - Value,{asis,NamedNumberList}], - call(Erules, encode_integer, Args); + asn1ct_imm:per_enc_integer(Val, Constraint, Aligned); + {'INTEGER',NNL} -> + asn1ct_imm:per_enc_integer(Val, NNL, Constraint, Aligned); 'REAL' -> - emit_enc_real(Erules, Value); - - {'BIT STRING',NamedNumberList} -> - call(Erules, encode_bit_string, - [{asis,SizeConstr},Value, - {asis,NamedNumberList}]); + ToBinary = {real_common,encode_real}, + asn1ct_imm:per_enc_restricted_string(Val, ToBinary, Aligned); + {'BIT STRING',NNL} -> + asn1ct_imm:per_enc_bit_string(Val, NNL, Constraint, Aligned); 'NULL' -> - emit("[]"); + asn1ct_imm:per_enc_null(Val, Aligned); 'OBJECT IDENTIFIER' -> - call(Erules, encode_object_identifier, [Value]); + ToBinary = {per_common,encode_oid}, + asn1ct_imm:per_enc_restricted_string(Val, ToBinary, Aligned); 'RELATIVE-OID' -> - call(Erules, encode_relative_oid, [Value]); - 'ObjectDescriptor' -> - call(Erules, encode_ObjectDescriptor, - [{asis,Constraint},Value]); + ToBinary = {per_common,encode_relative_oid}, + asn1ct_imm:per_enc_restricted_string(Val, ToBinary, Aligned); 'BOOLEAN' -> - call(Erules, encode_boolean, [Value]); + asn1ct_imm:per_enc_boolean(Val, Aligned); 'OCTET STRING' -> - case SizeConstr of - 0 -> - emit("[]"); - no -> - call(Erules, encode_octet_string, [Value]); - C -> - call(Erules, encode_octet_string, [{asis,C},Value]) - end; - 'NumericString' -> - call(Erules, encode_NumericString, [{asis,SizeConstr}, - {asis,Pa},Value]); - TString when TString == 'TeletexString'; - TString == 'T61String' -> - call(Erules, encode_TeletexString, [{asis,Constraint},Value]); - 'VideotexString' -> - call(Erules, encode_VideotexString, [{asis,Constraint},Value]); - 'UTCTime' -> - call(Erules, encode_VisibleString, [{asis,SizeConstr}, - {asis,Pa},Value]); - 'GeneralizedTime' -> - call(Erules, encode_VisibleString, [{asis,SizeConstr}, - {asis,Pa},Value]); - 'GraphicString' -> - call(Erules, encode_GraphicString, [{asis,Constraint},Value]); - 'VisibleString' -> - call(Erules, encode_VisibleString, [{asis,SizeConstr}, - {asis,Pa},Value]); - 'GeneralString' -> - call(Erules, encode_GeneralString, [{asis,Constraint},Value]); - 'PrintableString' -> - call(Erules, encode_PrintableString, [{asis,SizeConstr}, - {asis,Pa},Value]); - 'IA5String' -> - call(Erules, encode_IA5String, [{asis,SizeConstr}, - {asis,Pa},Value]); - 'BMPString' -> - call(Erules, encode_BMPString, [{asis,SizeConstr}, - {asis,Pa},Value]); - 'UniversalString' -> - call(Erules, encode_UniversalString, [{asis,SizeConstr}, - {asis,Pa},Value]); - 'UTF8String' -> - call(Erules, encode_UTF8String, [Value]); + asn1ct_imm:per_enc_octet_string(Val, Constraint, Aligned); 'ASN1_OPEN_TYPE' -> - NewValue = case Constraint of - [#'Externaltypereference'{type=Tname}] -> - asn1ct_func:need({Erules,complete,1}), - io_lib:format( - "complete(enc_~s(~s))",[Tname,Value]); - [#type{def=#'Externaltypereference'{type=Tname}}] -> - asn1ct_func:need({Erules,complete,1}), - io_lib:format( - "complete(enc_~s(~s))", - [Tname,Value]); - _ -> - io_lib:format("iolist_to_binary(~s)", - [Value]) - end, - call(Erules, encode_open_type, [NewValue]) - end. - -emit_enc_real(Erules, Real) -> - asn1ct_name:new(tmpval), - asn1ct_name:new(tmplen), - emit(["begin",nl, - "{",{curr,tmpval},com,{curr,tmplen},"} = ", - {call,real_common,encode_real,[Real]},com,nl, - "[",{call,Erules,encode_length,[{curr,tmplen}]},",", - {curr,tmpval},"]",nl, - "end"]). - -emit_enc_enumerated_cases(Erules, C, ['EXT_MARK'|T], _Count) -> - %% Reset enumeration counter. - emit_enc_enumerated_cases(Erules, C, T, 0); -emit_enc_enumerated_cases(Erules, C, [H|T], Count) -> - emit_enc_enumerated_case(Erules, C, H, Count), - emit([";",nl]), - emit_enc_enumerated_cases(Erules, C, T, Count+1); -emit_enc_enumerated_cases(_Erules, _, [], _Count) -> - emit(["EnumVal -> " - "exit({error,{asn1,{enumerated_not_in_range, EnumVal}}})",nl, - "end"]). - -emit_enc_enumerated_case(Erules, C, {0,EnumName}, Count) -> - %% ENUMERATED with extensionmark; the value lies within then extension root - Enc = enc_ext_and_val(Erules, 0, encode_constrained_number, [C,Count]), - emit(["'",EnumName,"' -> ",{asis,Enc}]); -emit_enc_enumerated_case(Erules, _C, {1,EnumName}, Count) -> - %% ENUMERATED with extensionmark; the value is higher than extension root - Enc = enc_ext_and_val(Erules, 1, encode_small_number, [Count]), - emit(["'",EnumName,"' -> ",{asis,Enc}]); -emit_enc_enumerated_case(Erules, C, EnumName, Count) -> - %% ENUMERATED without extension - EvalMod = eval_module(Erules), - emit(["'",EnumName,"' -> ", - {asis,EvalMod:encode_constrained_number(C, Count)}]). - -enc_ext_and_val(per, E, F, Args) -> - [E|apply(asn1ct_eval_per, F, Args)]; -enc_ext_and_val(uper, E, F, Args) -> - Bs = list_to_bitstring([apply(asn1ct_eval_uper, F, Args)]), - <<E:1,Bs/bitstring>>. - - -%% 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(Erules, ClassName, get_class_fields(Class), - ObjName, Fields, []), - emit(nl), - gen_decode_constr_type(Erules,DecConstructed), - emit(nl). - - -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 -> - emit(" Val"); - per -> - emit([" if",nl, - " is_list(Val) ->",nl, - " NewVal = list_to_binary(Val),",nl, - " [20,byte_size(NewVal),NewVal];",nl, - " is_binary(Val) ->",nl, - " [20,byte_size(Val),Val]",nl, - " end"]) - end, - []; - {false,{'DEFAULT',DefaultType}} -> - EmitFuncClause("Val"), - gen_encode_default_call(Erule, ClassName, Name, DefaultType); - {{Name,TypeSpec},_} -> - %% A specified field owerwrites any 'DEFAULT' or - %% 'OPTIONAL' field in the class - EmitFuncClause("Val"), - gen_encode_field_call(Erule, 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)"}) + case Constraint of + [#'Externaltypereference'{type=Tname}] -> + EncFunc = enc_func(Tname), + Imm = [{apply,EncFunc,[{expr,Val}]}], + asn1ct_imm:per_enc_open_type(Imm, Aligned); + [] -> + Imm = [{call,erlang,iolist_to_binary,[{expr,Val}]}], + asn1ct_imm:per_enc_open_type(Imm, Aligned) 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(_Erules, _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(Erules, ObjName, FieldName, Type) -> - Def = Type#typedef.typespec, - case Type#typedef.name of - {primitive,bif} -> - gen_encode_prim(Erules, Def, "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(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])), - [#typedef{name=[FieldName,ClassName], - typespec=Type}]; - {primitive,bif} -> - gen_encode_prim(Erules, Type, "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(Erules, 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(Erules, ClassName, Name, "Bytes", - DefaultType); - {{Name,TypeSpec},_} -> - %% A specified field owerwrites any 'DEFAULT' or - %% 'OPTIONAL' field in the class - EmitFuncClause("Bytes"), - gen_decode_field_call(Erules, ObjName, Name, "Bytes", TypeSpec) - end, - case more_genfields(Rest) of - true -> - emit([";",nl]); - false -> - emit([".",nl]) - end, - gen_decode_objectfields(Erules, ClassName, Rest, ObjName, - ObjectFields, MaybeConstr++ConstrAcc); -gen_decode_objectfields(Erules, 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(Erules, ClassName, Rest, ObjName, - ObjectFields, ConstrAcc); -gen_decode_objectfields(Erules, CN, [_C|Cs], O, OF, CAcc) -> - gen_decode_objectfields(Erules, CN, Cs, O, OF, CAcc); -gen_decode_objectfields(_, _, [], _, _, CAcc) -> - CAcc. - - - -gen_decode_field_call(_Erules, _ObjName, _FieldName, Bytes, - #'Externaltypereference'{}=Etype) -> - emit(" "), - gen_dec_external(Etype, Bytes), - []; -gen_decode_field_call(Erules, ObjName, FieldName, Bytes, Type) -> - Def = Type#typedef.typespec, - case Type#typedef.name of - {primitive,bif} -> - gen_dec_prim(Erules, 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(Erules, ClassName, FieldName, Bytes, Type) -> - 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(Erules, Type, Bytes), - []; - #'Externaltypereference'{}=Etype -> - asn1ct_gen_per:gen_dec_external(Etype, Bytes), - [] +dec_func(Tname) -> + list_to_atom(lists:concat(["dec_",Tname])). + +enc_func(Tname) -> + list_to_atom(lists:concat(["enc_",Tname])). + +simplify_type(Type) -> + case Type of + 'BMPString' -> k_m_string; + 'IA5String' -> k_m_string; + 'NumericString' -> k_m_string; + 'PrintableString' -> k_m_string; + 'VisibleString' -> k_m_string; + 'UniversalString' -> k_m_string; + 'GeneralizedTime' -> k_m_string; + 'UTCTime' -> k_m_string; + 'TeletexString' -> restricted_string; + 'T61String' -> restricted_string; + 'VideotexString' -> restricted_string; + 'GraphicString' -> restricted_string; + 'GeneralString' -> restricted_string; + 'UTF8String' -> restricted_string; + 'ObjectDescriptor' -> restricted_string; + Other -> Other end. +%% Object code generating for encoding and decoding +%% ------------------------------------------------ -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(_,[]) -> +gen_obj_code(_Erules, _Module, #typedef{}) -> 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(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(Erule, ObjSetName, UniqueName, [{ObjName,Val,Fields}|T], - ClName, ClFields, NthObj, Acc)-> - emit(["'getenc_",ObjSetName,"'(",{asis,UniqueName},",",{asis,Val}, - ") ->",nl]), - CurrMod = get(currmod), - {InternalFunc,NewNthObj}= - case ObjName of - {no_mod,no_name} -> - gen_inlined_enc_funs(Erule, Fields, ClFields, - ObjSetName, NthObj); - {CurrMod,Name} -> - emit({" fun 'enc_",Name,"'/3"}), - {[],0}; - {ModName,Name} -> - emit_ext_encfun(ModName,Name), - {[],0}; - _Other -> - emit({" fun 'enc_",ObjName,"'/3"}), - {[],0} - end, - emit({";",nl}), - gen_objset_enc(Erule, ObjSetName, UniqueName, T, ClName, ClFields, - NewNthObj, InternalFunc ++ Acc); -gen_objset_enc(uper, ObjSetName, _UniqueName, ['EXTENSIONMARK'], - _ClName, _ClFields, _NthObj, Acc) -> - emit({"'getenc_",ObjSetName,"'(_, _) ->",nl}), - emit({indent(3),"fun(_, Val, _) ->",nl}), - emit([indent(6),"Val",nl, - indent(3),"end.",nl,nl]), - Acc; -gen_objset_enc(per, ObjSetName, _UniqueName, ['EXTENSIONMARK'], - _ClName, _ClFields, _NthObj, Acc) -> - emit(["'getenc_",ObjSetName,"'(_, _) ->",nl, - indent(3),"fun(_, Val, _) ->",nl, - indent(6),"BinVal = if",nl, - indent(9),"is_list(Val) -> list_to_binary(Val);",nl, - indent(9),"true -> Val",nl, - indent(6),"end,",nl, - indent(6),"Size = byte_size(BinVal),",nl, - indent(6),"if",nl, - indent(9),"Size < 256 ->",nl, - indent(12),"[20,Size,BinVal];",nl, - indent(9),"true ->",nl, - indent(12),"[21,<<Size:16>>,Val]",nl, - indent(6),"end",nl, - indent(3),"end.",nl,nl]), - Acc; -gen_objset_enc(_, ObjSetName, UniqueName, [], _, _, _, Acc) -> - emit_default_getenc(ObjSetName, UniqueName), - emit([".",nl,nl]), - 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,_,_}|_]=T, - ObjSetName, NthObj) -> - emit([indent(3),"fun(Type, Val, _) ->",nl, - indent(6),"case Type of",nl]), - gen_inlined_enc_funs1(Erule, Fields, T, ObjSetName, [], NthObj, []); -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, - Sep0, NthObj, Acc0) -> - emit(Sep0), - Sep = [";",nl], - CurrentMod = get(currmod), - InternalDefFunName = asn1ct_gen:list2name([NthObj,Name,ObjSetName]), - {Acc,NAdd} = - case lists:keyfind(Name, 1, Fields) of - {_,#type{}=Type} -> - {Ret,N} = emit_inner_of_fun(Erule, Type, InternalDefFunName), - {Ret++Acc0,N}; - {_,#typedef{}=Type} -> - emit([indent(9),{asis,Name}," ->",nl]), - {Ret,N} = emit_inner_of_fun(Erule, Type, InternalDefFunName), - {Ret++Acc0,N}; - {_,#'Externaltypereference'{module=CurrentMod,type=T}} -> - emit([indent(9),{asis,Name}," ->",nl, - indent(12),"'enc_",T,"'(Val)"]), - {Acc0,0}; - {_,#'Externaltypereference'{module=M,type=T}} -> - emit([indent(9),{asis,Name}," ->",nl, - indent(12),"'",M,"'",":'enc_",T,"'(Val)"]), - {Acc0,0}; - false when Erule =:= uper -> - emit([indent(9),{asis,Name}," ->",nl, - indent(12),"Val",nl]), - {Acc0,0}; - false when Erule =:= per -> - emit([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,<<Size:16>>,Val]",nl, - indent(12),"end"]), - {Acc0,0} - end, - gen_inlined_enc_funs1(Erule, Fields, Rest, ObjSetName, Sep, - NthObj+NAdd, Acc); -gen_inlined_enc_funs1(Erule, Fields, [_|T], ObjSetName, Sep, NthObj, Acc)-> - gen_inlined_enc_funs1(Erule, Fields, T, ObjSetName, Sep, NthObj, Acc); -gen_inlined_enc_funs1(_, _, [], _, _, NthObj, Acc) -> - emit([nl,indent(6),"end",nl, - indent(3),"end"]), - {Acc,NthObj}. - -emit_inner_of_fun(Erule, #typedef{name={ExtMod,Name},typespec=Type}=TDef, - InternalDefFunName) -> - case {ExtMod,Name} of - {primitive,bif} -> - emit(indent(12)), - gen_encode_prim(Erule, Type, "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{}=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, "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(Erule, ObjSName, UniqueName, [{ObjName,Val,Fields}|T], 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(Erule, Fields, ClFields, - ObjSName, NthObj); - {CurrMod,Name} -> - emit([" fun 'dec_",Name,"'/4"]), - NthObj; - {ModName,Name} -> - emit_ext_decfun(ModName,Name), - NthObj; - _Other -> - emit({" fun 'dec_",ObjName,"'/4"}), - NthObj - end, - emit({";",nl}), - gen_objset_dec(Erule, ObjSName, UniqueName, T, ClName, ClFields, NewNthObj); -gen_objset_dec(_Erule, ObjSetName, _UniqueName, ['EXTENSIONMARK'], - _ClName, _ClFields, _NthObj) -> - emit({"'getdec_",ObjSetName,"'(_, _) ->",nl}), - emit({indent(3),"fun(Attr1, Bytes, _,_) ->",nl}), - emit({indent(6),"{Bytes,Attr1}",nl}), - emit({indent(3),"end.",nl,nl}), - ok; -gen_objset_dec(_Erule, ObjSetName, UniqueName, [], _, _, _) -> - emit_default_getdec(ObjSetName, UniqueName), - emit([".",nl,nl]), +gen_objectset_code(_Erules, _ObjSet) -> 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(Erule, Fields, List, ObjSetName, NthObj0) -> - emit([indent(3),"fun(Type, Val, _, _) ->",nl, - indent(6),"case Type of",nl]), - NthObj = gen_inlined_dec_funs1(Erule, Fields, List, - ObjSetName, "", NthObj0), - emit([nl,indent(6),"end",nl, - indent(3),"end"]), - NthObj. - -gen_inlined_dec_funs1(Erule, Fields, [{typefield,Name,_}|Rest], - ObjSetName, Sep0, NthObj) -> - InternalDefFunName = [NthObj,Name,ObjSetName], - emit(Sep0), - Sep = [";",nl], - N = case lists:keyfind(Name, 1, Fields) of - {_,#type{}=Type} -> - emit_inner_of_decfun(Erule, Type, InternalDefFunName); - {_,#typedef{}=Type} -> - emit([indent(9),{asis,Name}," ->",nl]), - emit_inner_of_decfun(Erule, Type, InternalDefFunName); - {_,#'Externaltypereference'{}=Etype} -> - emit([indent(9),{asis,Name}," ->",nl, - indent(12)]), - gen_dec_external(Etype, "Val"), - 0; - false -> - emit([indent(9),{asis,Name}," -> {Val,Type}"]), - 0 - end, - gen_inlined_dec_funs1(Erule, Fields, Rest, ObjSetName, Sep, NthObj+N); -gen_inlined_dec_funs1(Erule, Fields, [_|Rest], ObjSetName, Sep, NthObj) -> - gen_inlined_dec_funs1(Erule, Fields, Rest, ObjSetName, Sep, NthObj); -gen_inlined_dec_funs1(_, _, [], _, _, NthObj) -> NthObj. - -emit_inner_of_decfun(Erule, #typedef{name={ExtName,Name},typespec=Type}, - InternalDefFunName) -> - case {ExtName,Name} of - {primitive,bif} -> - emit(indent(12)), - gen_dec_prim(Erule, 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(_Erule, #typedef{name=Name}, _) -> - emit({indent(12),"'dec_",Name,"'(Val, telltype)"}), - 0; -emit_inner_of_decfun(Erule, #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(Erule, Type, "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}), +gen_decode(Erules, #typedef{}=Type) -> + DecFunc = dec_func(Type#typedef.name), + emit([nl,nl,{asis,DecFunc},"(Bytes) ->",nl]), dbdec(Type#typedef.name), - gen_decode_user(Erules,D). + gen_decode_user(Erules, Type). gen_decode(Erules,Tname,#'ComponentType'{name=Cname,typespec=Type}) -> NewTname = [Cname|Tname], @@ -944,8 +218,9 @@ gen_decode(Erules,Typename,Type) when is_record(Type,type) -> _ -> "" end, - emit({nl,"'dec_",asn1ct_gen:list2name(Typename), - "'(Bytes,_",ObjFun,") ->",nl}), + emit([nl, + {asis,dec_func(asn1ct_gen:list2name(Typename))}, + "(Bytes",ObjFun,") ->",nl]), dbdec(Typename), asn1ct_gen:gen_decode_constructed(Erules,Typename,InnerType,Type); _ -> @@ -982,8 +257,8 @@ gen_dec_external(Ext, BytesVar) -> #'Externaltypereference'{module=Mod,type=Type} = Ext, emit([case CurrMod of Mod -> []; - _ -> ["'",Mod,"':"] - end,"'dec_",Type,"'(",BytesVar,",telltype)"]). + _ -> [{asis,Mod},":"] + end,{asis,dec_func(Type)},"(",BytesVar,")"]). gen_dec_imm(Erule, #type{def=Name,constraint=C}) -> Aligned = case Erule of @@ -1103,35 +378,6 @@ gen_dec_prim(Erule, Type, BytesVar) -> Imm = gen_dec_imm(Erule, Type), asn1ct_imm:dec_code_gen(Imm, BytesVar). -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. - %% For PER the ExtensionAdditionGroup notation has significance for the encoding and decoding %% the components within the ExtensionAdditionGroup is treated in a similar way as if they @@ -1170,11 +416,8 @@ imm_dec_open_type_1(Type, Aligned) -> asn1ct_name:new(tmpval), emit(["begin",nl, "{",{curr,tmpval},",_} = ", - "dec_",Type,"(",OpenType,", mandatory),",nl, + {asis,dec_func(Type)},"(",OpenType,"),",nl, "{",{curr,tmpval},com,Buf,"}",nl, "end"]) end, {call,D,asn1ct_imm:per_dec_open_type(Aligned)}. - -eval_module(per) -> asn1ct_eval_per; -eval_module(uper) -> asn1ct_eval_uper. diff --git a/lib/asn1/src/asn1ct_gen_per_rt2ct.erl b/lib/asn1/src/asn1ct_gen_per_rt2ct.erl deleted file mode 100644 index 012d54e7a1..0000000000 --- a/lib/asn1/src/asn1ct_gen_per_rt2ct.erl +++ /dev/null @@ -1,461 +0,0 @@ -%% -%% %CopyrightBegin% -%% -%% Copyright Ericsson AB 2002-2013. 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). - -%% Handle encoding of primitives for aligned PER. - --include("asn1_records.hrl"). - --export([gen_encode_prim/3]). - --import(asn1ct_gen, [emit/1,demit/1]). --import(asn1ct_func, [call/3]). - -gen_encode_prim(Erules, #type{}=D, Value) -> - 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); - 'REAL' -> - emit_enc_real(Erules, Value); - - {'BIT STRING',NamedNumberList} -> - EffectiveC = effective_constraint(bitstring,Constraint), - case EffectiveC of - 0 -> - emit({"[]"}); - _ -> - call(Erules, encode_bit_string, - [{asis,EffectiveC},Value, - {asis,NamedNumberList}]) - end; - 'NULL' -> - emit("[]"); - 'OBJECT IDENTIFIER' -> - call(Erules, encode_object_identifier, [Value]); - 'RELATIVE-OID' -> - call(Erules, encode_relative_oid, [Value]); - 'ObjectDescriptor' -> - call(Erules, 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' -> - call(Erules, encode_TeletexString, [{asis,Constraint},Value]); - 'VideotexString' -> - call(Erules, encode_VideotexString, [{asis,Constraint},Value]); - 'UTCTime' -> - emit_enc_known_multiplier_string('VisibleString',Constraint,Value); - 'GeneralizedTime' -> - emit_enc_known_multiplier_string('VisibleString',Constraint,Value); - 'GraphicString' -> - call(Erules, encode_GraphicString, [{asis,Constraint},Value]); - 'VisibleString' -> - emit_enc_known_multiplier_string('VisibleString',Constraint,Value); - 'GeneralString' -> - call(Erules, 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' -> - call(Erules, encode_UTF8String, [Value]); - 'ASN1_OPEN_TYPE' -> - NewValue = case Constraint of - [#'Externaltypereference'{type=Tname}] -> - asn1ct_func:need({Erules,complete,1}), - io_lib:format( - "complete(enc_~s(~s))",[Tname,Value]); - [#type{def=#'Externaltypereference'{type=Tname}}] -> - asn1ct_func:need({Erules,complete,1}), - io_lib:format( - "complete(enc_~s(~s))", - [Tname,Value]); - _ -> - io_lib:format("iolist_to_binary(~s)", - [Value]) - end, - call(Erules, encode_open_type, [NewValue]) - end. - -emit_enc_real(Erules, Real) -> - asn1ct_name:new(tmpval), - asn1ct_name:new(tmplen), - emit(["begin",nl, - "{",{curr,tmpval},com,{curr,tmplen},"} = ", - {call,real_common,encode_real,[Real]},com,nl, - "[",{call,Erules,encode_length,[{curr,tmplen}]},",",nl, - {call,Erules,octets_to_complete, - [{curr,tmplen},{curr,tmpval}]},"]",nl, - "end"]). - -emit_enc_known_multiplier_string(StringType,C,Value) -> - SizeC = effective_constraint(bitstring, C), - 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(SizeC, NumBits, CharOutTab, Value). - -emit_enc_k_m_string(0, _NumBits, _CharOutTab, _Value) -> - emit({"[]"}); -emit_enc_k_m_string(SizeC, NumBits, CharOutTab, Value) -> - call(per, encode_known_multiplier_string, - [{asis,SizeC},NumBits,{asis,CharOutTab},Value]). - - -%% copied from run time module - -get_CharOutTab(C, StringType) -> - case get_constraint(C,'PermittedAlphabet') of - {'SingleValue',Sv} -> - get_CharTab2(C, StringType, hd(Sv), lists:max(Sv), Sv); - no -> - case StringType of - 'IA5String' -> - {0,16#7F,notab}; - 'VisibleString' -> - get_CharTab2(C, StringType, 16#20, 16#7F, notab); - 'PrintableString' -> - Chars = lists:sort( - " '()+,-./0123456789:=?ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"), - get_CharTab2(C, StringType, hd(Chars), - lists:max(Chars), Chars); - 'NumericString' -> - get_CharTab2(C, StringType, 16#20, $9, " 0123456789"); - 'UniversalString' -> - {0,16#FFFFFFFF,notab}; - 'BMPString' -> - {0,16#FFFF,notab} - end - end. - -get_CharTab2(C, StringType, Min, Max, Chars) -> - BitValMax = (1 bsl get_NumBits(C,StringType))-1, - if - Max =< BitValMax -> - {0,Max,notab}; - true -> - {Min,Max,create_char_tab(Min,Chars)} - 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 effective_constraint(bitstring, Constraint) 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, - " ",{curr,tmpval}," = ",Value,",",nl, - " case length(",{curr,tmpval},") of",nl, - " 2 ->",nl, - " [[45,16,2]|",{curr,tmpval},"];",nl, - " _ ->",nl, - " exit({error,{value_out_of_bounds,", - {curr,tmpval},"}})",nl, - " end",nl, - " end"]); - Sv when is_integer(Sv), Sv < 256 -> - asn1ct_name:new(tmpval), - asn1ct_name:new(tmplen), - emit([" begin",nl, - " ",{curr,tmpval}," = ",Value,",",nl, - " case length(",{curr,tmpval},") of",nl, - " ",Sv,"=",{curr,tmplen}," ->",nl, - " [20,",{curr,tmplen},"|",{curr,tmpval},"];",nl, - " _ ->",nl, - " exit({error,{value_out_of_bounds,", - {curr,tmpval},"}})",nl, - " end",nl, - " end"]); - Sv when is_integer(Sv),Sv =< 65535 -> - asn1ct_name:new(tmpval), - asn1ct_name:new(tmplen), - emit([" begin",nl, - " ",{curr,tmpval}," = ",Value,",",nl, - " case length(",{curr,tmpval},") of",nl, - " ",Sv,"=",{curr,tmplen}," ->",nl, - " [<<21,",{curr,tmplen},":16>>|",Value,"];",nl, - " _ ->",nl, - " exit({error,{value_out_of_bounds,", - {curr,tmpval},"}})",nl, - " end",nl, - " end"]); - C -> - call(Erules, encode_octet_string, - [{asis,C},Value]) - 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, [{'ValueRange',{Lb,Ub}=VR}], Value) - when is_integer(Lb), is_integer(Ub) -> - call(Erule, encode_constrained_number, [{asis,VR},Value]); - -emit_enc_integer(Erule, C, Value) -> - call(Erule, encode_integer, [{asis,C},Value]). - - -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. - -%% 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) -> - pre_encode(integer, asn1ct_imm:effective_constraint(integer, C)); -effective_constraint(bitstring,C) -> - asn1ct_imm:effective_constraint(bitstring, C). - -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. diff --git a/lib/asn1/src/asn1ct_imm.erl b/lib/asn1/src/asn1ct_imm.erl index bf362db843..892178f61b 100644 --- a/lib/asn1/src/asn1ct_imm.erl +++ b/lib/asn1/src/asn1ct_imm.erl @@ -26,6 +26,18 @@ per_dec_octet_string/2,per_dec_open_type/1,per_dec_real/1, per_dec_restricted_string/1]). -export([per_dec_constrained/3,per_dec_normally_small_number/1]). +-export([per_enc_bit_string/4,per_enc_boolean/2, + per_enc_choice/3,per_enc_enumerated/3, + per_enc_integer/3,per_enc_integer/4, + per_enc_null/2, + per_enc_k_m_string/4,per_enc_octet_string/3, + per_enc_open_type/2, + per_enc_restricted_string/3, + per_enc_small_number/2]). +-export([per_enc_extension_bit/2,per_enc_extensions/4,per_enc_optional/3]). +-export([per_enc_sof/5]). +-export([enc_absent/3,enc_append/1,enc_bind_var/1]). +-export([enc_cg/2]). -export([optimize_alignment/1,optimize_alignment/2, dec_slim_cg/2,dec_code_gen/2]). -export([effective_constraint/2]). @@ -115,29 +127,18 @@ per_dec_named_integer(Constraint, NamedList0, Aligned) -> per_dec_k_m_string(StringType, Constraint, Aligned) -> SzConstr = effective_constraint(bitstring, Constraint), N = string_num_bits(StringType, Constraint, Aligned), - %% X.691 (07/2002) 27.5.7 says if the upper bound times the number - %% of bits is greater than or equal to 16, then the bit field should - %% be aligned. - Imm = dec_string(SzConstr, N, Aligned, fun(_, Ub) -> Ub >= 16 end), + Imm = dec_string(SzConstr, N, Aligned, k_m_string), Chars = char_tab(Constraint, StringType, N), convert_string(N, Chars, Imm). per_dec_octet_string(Constraint, Aligned) -> - dec_string(Constraint, 8, Aligned, - %% Aligned unless the size is fixed and =< 16. - fun(Sv, Sv) -> Sv > 16; - (_, _) -> true - end). + dec_string(Constraint, 8, Aligned, 'OCTET STRING'). per_dec_raw_bitstring(Constraint, Aligned) -> - dec_string(Constraint, 1, Aligned, - fun(Sv, Sv) -> Sv > 16; - (_, _) -> true - end). + dec_string(Constraint, 1, Aligned, 'BIT STRING'). per_dec_open_type(Aligned) -> - {get_bits,decode_unconstrained_length(true, Aligned), - [8,binary,{align,Aligned}]}. + dec_string(no, 8, Aligned, open_type). per_dec_real(Aligned) -> Dec = fun(V, Buf) -> @@ -152,26 +153,285 @@ per_dec_restricted_string(Aligned) -> DecLen = decode_unconstrained_length(true, Aligned), {get_bits,DecLen,[8,binary]}. +%%% +%%% Encoding. +%%% + +per_enc_bit_string(Val0, [], Constraint0, Aligned) -> + {B,[Val,Bs,Bits]} = mk_vars(Val0, [bs,bits]), + Constraint = effective_constraint(bitstring, Constraint0), + ExtraArgs = case constr_min_size(Constraint) of + no -> []; + Lb -> [Lb] + end, + B ++ [{call,per_common,to_bitstring,[Val|ExtraArgs],Bs}, + {call,erlang,bit_size,[Bs],Bits}| + per_enc_length(Bs, 1, Bits, Constraint, Aligned, 'BIT STRING')]; +per_enc_bit_string(Val0, NNL0, Constraint0, Aligned) -> + {B,[Val,Bs,Bits,Positions]} = mk_vars(Val0, [bs,bits,positions]), + NNL = lists:keysort(2, NNL0), + Constraint = effective_constraint(bitstring, Constraint0), + ExtraArgs = case constr_min_size(Constraint) of + no -> []; + Lb -> [Lb] + end, + B ++ [{'try', + [bit_string_name2pos_fun(NNL, Val)], + {Positions, + [{call,per_common,bitstring_from_positions, + [Positions|ExtraArgs]}]}, + [{call,per_common,to_named_bitstring,[Val|ExtraArgs]}],Bs}, + {call,erlang,bit_size,[Bs],Bits}| + per_enc_length(Bs, 1, Bits, Constraint, Aligned, 'BIT STRING')]. + +per_enc_boolean(Val0, _Aligned) -> + {B,[Val]} = mk_vars(Val0, []), + B++build_cond([[{eq,Val,false},{put_bits,0,1,[1]}], + [{eq,Val,true},{put_bits,1,1,[1]}]]). + +per_enc_choice(Val0, Cs0, _Aligned) -> + {B,[Val]} = mk_vars(Val0, []), + Cs = [[{eq,Val,Tag}|opt_choice(Imm)] || {Tag,Imm} <- Cs0], + B++build_cond(Cs). + +per_enc_enumerated(Val0, {Root,Ext}, Aligned) -> + {B,[Val]} = mk_vars(Val0, []), + Constr = enumerated_constraint(Root), + RootCs = per_enc_enumerated_root(Root, [{put_bits,0,1,[1]}], + Val, Constr, Aligned), + ExtCs = per_enc_enumerated_ext(Ext, Val, Aligned), + B++[{'cond',RootCs++ExtCs++enumerated_error(Val)}]; +per_enc_enumerated(Val0, Root, Aligned) -> + {B,[Val]} = mk_vars(Val0, []), + Constr = enumerated_constraint(Root), + Cs = per_enc_enumerated_root(Root, [], Val, Constr, Aligned), + B++[{'cond',Cs++enumerated_error(Val)}]. + +enumerated_error(Val) -> + [['_',{error,Val}]]. + +per_enc_integer(Val0, Constraint0, Aligned) -> + {B,[Val]} = mk_vars(Val0, []), + Constraint = effective_constraint(integer, Constraint0), + B ++ per_enc_integer_1(Val, Constraint, Aligned). + +per_enc_integer(Val0, NNL, Constraint0, Aligned) -> + {B,[Val]} = mk_vars(Val0, []), + Constraint = effective_constraint(integer, Constraint0), + Cs = [[{eq,Val,N}|per_enc_integer_1(V, Constraint, Aligned)] || + {N,V} <- NNL], + case per_enc_integer_1(Val, Constraint, Aligned) of + [{'cond',IntCs}] -> + B ++ [{'cond',Cs++IntCs}]; + Other -> + B ++ [{'cond',Cs++[['_'|Other]]}] + end. + +per_enc_null(_Val, _Aligned) -> + []. + +per_enc_k_m_string(Val0, StringType, Constraint, Aligned) -> + {B,[Val,Bin,Len]} = mk_vars(Val0, [bin,len]), + SzConstraint = effective_constraint(bitstring, Constraint), + Unit = string_num_bits(StringType, Constraint, Aligned), + Chars0 = char_tab(Constraint, StringType, Unit), + Args = case enc_char_tab(Chars0) of + notab -> [Val,Unit]; + Chars -> [Val,Unit,Chars] + end, + Enc = case Unit of + 16 -> + {call,per_common,encode_chars_16bit,[Val],Bin}; + 32 -> + {call,per_common,encode_big_chars,[Val],Bin}; + 8 -> + {call,erlang,list_to_binary,[Val],Bin}; + _ -> + {call,per_common,encode_chars,Args,Bin} + end, + case Unit of + 8 -> + B ++ [Enc,{call,erlang,byte_size,[Bin],Len}]; + _ -> + B ++ [{call,erlang,length,[Val],Len},Enc] + end ++ per_enc_length(Bin, Unit, Len, SzConstraint, Aligned, k_m_string). + +per_enc_open_type([], Aligned) -> + [{put_bits,1,8,unit(1, Aligned)},{put_bits,0,8,[1]}]; +per_enc_open_type([{'cond', + [['_', + {put_bits,0,0,_}, + {call,per_common,encode_unconstrained_number,_}=Call]]}], + Aligned) -> + %% We KNOW that encode_unconstrained_number/1 will return an IO list; + %% therefore the call to complete/1 can be replaced with a cheaper + %% call to iolist_to_binary/1. + {Dst,Imm} = per_enc_open_type_output([Call], []), + ToBin = {erlang,iolist_to_binary}, + Imm ++ per_enc_open_type(Dst, ToBin, Aligned); +per_enc_open_type([{call,erlang,iolist_to_binary,Args}], Aligned) -> + {_,[_,Bin,Len]} = mk_vars('dummy', [bin,len]), + [{call,erlang,iolist_to_binary,Args,Bin}, + {call,erlang,byte_size,[Bin],Len}|per_enc_length(Bin, 8, Len, Aligned)]; +per_enc_open_type(Imm0, Aligned) -> + try + {Prefix,Imm1} = split_off_nonbuilding(Imm0), + Prefix ++ enc_open_type(Imm1, Aligned) + catch + throw:impossible -> + {Dst,Imm} = per_enc_open_type_output(Imm0, []), + ToBin = {enc_mod(Aligned),complete}, + Imm ++ per_enc_open_type(Dst, ToBin, Aligned) + end. + +per_enc_octet_string(Val0, Constraint0, Aligned) -> + {B,[Val,Bin,Len]} = mk_vars(Val0, [bin,len]), + Constraint = effective_constraint(bitstring, Constraint0), + B ++ [{call,erlang,iolist_to_binary,[Val],Bin}, + {call,erlang,byte_size,[Bin],Len}| + per_enc_length(Bin, 8, Len, Constraint, Aligned, 'OCTET STRING')]. + +per_enc_restricted_string(Val0, {M,F}, Aligned) -> + {B,[Val,Bin,Len]} = mk_vars(Val0, [bin,len]), + B ++ [{call,M,F,[Val],Bin}, + {call,erlang,byte_size,[Bin],Len}| + per_enc_length(Bin, 8, Len, Aligned)]. + +per_enc_small_number(Val, Aligned) -> + build_cond([[{lt,Val,64},{put_bits,Val,7,[1]}], + ['_',{put_bits,1,1,[1]}| + per_enc_unsigned(Val, Aligned)]]). + +per_enc_extension_bit(Val0, _Aligned) -> + {B,[Val]} = mk_vars(Val0, []), + B++build_cond([[{eq,Val,[]},{put_bits,0,1,[1]}], + ['_',{put_bits,1,1,[1]}]]). + +per_enc_extensions(Val0, Pos0, NumBits, Aligned) when NumBits > 0 -> + Pos = Pos0 + 1, + {B,[Val,Bitmap]} = mk_vars(Val0, [bitmap]), + Length = per_enc_small_length(NumBits, Aligned), + PutBits = case NumBits of + 1 -> [{put_bits,1,1,[1]}]; + _ -> [{put_bits,Bitmap,NumBits,[1]}] + end, + B++[{call,per_common,extension_bitmap,[Val,Pos,Pos+NumBits],Bitmap}, + {'cond',[[{eq,Bitmap,0}], + ['_'|Length ++ PutBits]],{var,"Extensions"}}]. + +per_enc_optional(Val0, {Pos,Def}, _Aligned) when is_integer(Pos) -> + Val1 = lists:concat(["element(",Pos,", ",Val0,")"]), + {B,[Val]} = mk_vars(Val1, []), + Zero = {put_bits,0,1,[1]}, + One = {put_bits,1,1,[1]}, + B++[{'cond',[[{eq,Val,asn1_DEFAULT},Zero], + [{eq,Val,Def},Zero], + ['_',One]]}]; +per_enc_optional(Val0, Pos, _Aligned) when is_integer(Pos) -> + Val1 = lists:concat(["element(",Pos,", ",Val0,")"]), + {B,[Val]} = mk_vars(Val1, []), + Zero = {put_bits,0,1,[1]}, + One = {put_bits,1,1,[1]}, + B++[{'cond',[[{eq,Val,asn1_NOVALUE},Zero], + ['_',One]]}]. + +per_enc_sof(Val0, Constraint, ElementVar, ElementImm, Aligned) -> + {B,[Val,Len]} = mk_vars(Val0, [len]), + SzConstraint = effective_constraint(bitstring, Constraint), + LenImm = enc_length(Len, SzConstraint, Aligned), + Lc0 = [{lc,ElementImm,{var,atom_to_list(ElementVar)},Val}], + Lc = opt_lc(Lc0, LenImm), + PreBlock = B ++ [{call,erlang,length,[Val],Len}], + case LenImm of + [{'cond',[[C|Action]]}] -> + PreBlock ++ [{'cond',[[C|Action++Lc]]}]; + [{sub,_,_,_}=Sub,{'cond',[[C|Action]]}] -> + PreBlock ++ + [Sub,{'cond',[[C|Action++Lc]]}]; + EncLen -> + PreBlock ++ EncLen ++ Lc + end. + +enc_absent(Val0, AbsVals, Body) -> + {B,[Var]} = mk_vars(Val0, []), + Cs = [[{eq,Var,Aval}] || Aval <- AbsVals] ++ [['_'|Body]], + B++build_cond(Cs). + +enc_append([[]|T]) -> + enc_append(T); +enc_append([[{put_bits,_,_,_}|_]=Pb|[Imm|T]=T0]) -> + case opt_choice(Pb++Imm) of + [{put_bits,_,_,_}|_] -> + [{block,Pb}|enc_append(T0)]; + Opt -> + enc_append([Opt|T]) + end; +enc_append([Imm0|[Imm1|T]=T0]) -> + try combine_imms(Imm0, Imm1) of + Imm -> + enc_append([Imm|T]) + catch + throw:impossible -> + [{block,Imm0}|enc_append(T0)] + end; +enc_append([H|T]) -> + [{block,H}|enc_append(T)]; +enc_append([]) -> []. + +enc_bind_var(Val) -> + {B,[{var,Var}]} = mk_vars(Val, []), + {B,list_to_atom(Var)}. + +enc_cg(Imm0, false) -> + Imm1 = enc_cse(Imm0), + Imm = enc_pre_cg(Imm1), + enc_cg(Imm); +enc_cg(Imm0, true) -> + Imm1 = enc_cse(Imm0), + Imm2 = enc_hoist_align(Imm1), + Imm3 = enc_opt_al(Imm2), + Imm4 = per_fixup(Imm3), + Imm = enc_pre_cg(Imm4), + enc_cg(Imm). %%% %%% Local functions. %%% -dec_string(Sv, U, Aligned0, AF) when is_integer(Sv) -> +%% is_aligned(StringType, LowerBound, UpperBound) -> boolean() +%% StringType = 'OCTET STRING' | 'BIT STRING' | k_m_string +%% LowerBound = UpperBound = number of bits +%% Determine whether a string should be aligned in PER. + +is_aligned(T, Lb, Ub) when T =:= 'OCTET STRING'; T =:= 'BIT STRING' -> + %% OCTET STRINGs and BIT STRINGs are aligned to a byte boundary + %% unless the size is fixed and less than or equal to 16 bits. + Lb =/= Ub orelse Lb > 16; +is_aligned(k_m_string, _Lb, Ub) -> + %% X.691 (07/2002) 27.5.7 says if the upper bound times the number + %% of bits is greater than or equal to 16, then the bit field should + %% be aligned. + Ub >= 16. + +%%% +%%% Generating the intermediate format format for decoding. +%%% + +dec_string(Sv, U, Aligned0, T) when is_integer(Sv) -> Bits = U*Sv, - Aligned = Aligned0 andalso AF(Bits, Bits), + Aligned = Aligned0 andalso is_aligned(T, Bits, Bits), {get_bits,Sv,[U,binary,{align,Aligned}]}; -dec_string({{Sv,Sv},[]}, U, Aligned, AF) -> - bit_case(dec_string(Sv, U, Aligned, AF), - dec_string(no, U, Aligned, AF)); -dec_string({{_,_}=C,[]}, U, Aligned, AF) -> - bit_case(dec_string(C, U, Aligned, AF), - dec_string(no, U, Aligned, AF)); -dec_string({Lb,Ub}, U, Aligned0, AF) -> +dec_string({{Sv,Sv},[]}, U, Aligned, T) -> + bit_case(dec_string(Sv, U, Aligned, T), + dec_string(no, U, Aligned, T)); +dec_string({{_,_}=C,[]}, U, Aligned, T) -> + bit_case(dec_string(C, U, Aligned, T), + dec_string(no, U, Aligned, T)); +dec_string({Lb,Ub}, U, Aligned0, T) -> Len = per_dec_constrained(Lb, Ub, Aligned0), - Aligned = Aligned0 andalso AF(Lb*U, Ub*U), + Aligned = Aligned0 andalso is_aligned(T, Lb*U, Ub*U), {get_bits,Len,[U,binary,{align,Aligned}]}; -dec_string(_, U, Aligned, _AF) -> +dec_string(_, U, Aligned, _T) -> Al = [{align,Aligned}], DecRest = fun(V, Buf) -> asn1ct_func:call(per_common, @@ -692,6 +952,1164 @@ mk_dest(I) when is_integer(I) -> integer_to_list(I); mk_dest(S) -> S. +%%% +%%% Constructing the intermediate format for encoding. +%%% + +split_off_nonbuilding(Imm) -> + lists:splitwith(fun is_nonbuilding/1, Imm). + +is_nonbuilding({apply,_,_,_}) -> true; +is_nonbuilding({assign,_,_}) -> true; +is_nonbuilding({call,_,_,_,_}) -> true; +is_nonbuilding({'cond',_,_}) -> true; +is_nonbuilding({lc,_,_,_,_}) -> true; +is_nonbuilding({sub,_,_,_}) -> true; +is_nonbuilding({'try',_,_,_,_}) -> true; +is_nonbuilding(_) -> false. + +mk_vars(Input0, Temps) -> + asn1ct_name:new(enc), + Curr = asn1ct_name:curr(enc), + [H|T] = atom_to_list(Curr), + Base = [H - ($a - $A)|T ++ "@"], + if + is_atom(Input0) -> + Input = {var,atom_to_list(Input0)}, + {[],[Input|mk_vars_1(Base, Temps)]}; + is_integer(Input0) -> + {[],[Input0|mk_vars_1(Base, Temps)]}; + Input0 =:= [] -> + {[],[Input0|mk_vars_1(Base, Temps)]}; + true -> + Input = mk_var(Base, input), + {[{assign,Input,Input0}],[Input|mk_vars_1(Base, Temps)]} + end. + +mk_vars_1(Base, Vars) -> + [mk_var(Base, V) || V <- Vars]. + +mk_var(Base, V) -> + {var,Base ++ atom_to_list(V)}. + +per_enc_integer_1(Val, [], Aligned) -> + [{'cond',[['_'|per_enc_unconstrained(Val, Aligned)]]}]; +per_enc_integer_1(Val0, [{{_,_}=Constr,[]}], Aligned) -> + {Prefix,Check,Action} = per_enc_integer_2(Val0, Constr, Aligned), + Prefix++build_cond([[Check,{put_bits,0,1,[1]}|Action], + ['_',{put_bits,1,1,[1]}| + per_enc_unconstrained(Val0, Aligned)]]); +per_enc_integer_1(Val0, [Constr], Aligned) -> + {Prefix,Check,Action} = per_enc_integer_2(Val0, Constr, Aligned), + Prefix++build_cond([[Check|Action], + ['_',{error,Val0}]]). + +per_enc_integer_2(Val, {'SingleValue',Sv}, Aligned) -> + per_enc_constrained(Val, Sv, Sv, Aligned); +per_enc_integer_2(Val0, {'ValueRange',{Lb,'MAX'}}, Aligned) + when is_integer(Lb) -> + {Prefix,Val} = sub_lb(Val0, Lb), + {Prefix,{ge,Val,0},per_enc_unsigned(Val, Aligned)}; +per_enc_integer_2(Val, {'ValueRange',{Lb,Ub}}, Aligned) + when is_integer(Lb), is_integer(Ub) -> + per_enc_constrained(Val, Lb, Ub, Aligned). + +per_enc_constrained(Val, Sv, Sv, _Aligned) -> + {[],{eq,Val,Sv},[]}; +per_enc_constrained(Val0, Lb, Ub, false) -> + {Prefix,Val} = sub_lb(Val0, Lb), + Range = Ub - Lb + 1, + NumBits = uper_num_bits(Range), + Check = {ult,Val,Range}, + Put = [{put_bits,Val,NumBits,[1]}], + {Prefix,Check,Put}; +per_enc_constrained(Val0, Lb, Ub, true) -> + {Prefix,Val} = sub_lb(Val0, Lb), + Range = Ub - Lb + 1, + if + Range < 256 -> + NumBits = per_num_bits(Range), + Check = {ult,Val,Range}, + Put = [{put_bits,Val,NumBits,[1]}], + {Prefix,Check,Put}; + Range =:= 256 -> + NumBits = 8, + Check = {ult,Val,Range}, + Put = [{put_bits,Val,NumBits,[1,align]}], + {Prefix,Check,Put}; + Range =< 65536 -> + Check = {ult,Val,Range}, + Put = [{put_bits,Val,16,[1,align]}], + {Prefix,Check,Put}; + true -> + {var,VarBase} = Val, + Bin = {var,VarBase++"@bin"}, + BinSize0 = {var,VarBase++"@bin_size0"}, + BinSize = {var,VarBase++"@bin_size"}, + Check = {ult,Val,Range}, + RangeOctsLen = byte_size(binary:encode_unsigned(Range - 1)), + BitsNeeded = per_num_bits(RangeOctsLen), + Enc = [{call,binary,encode_unsigned,[Val],Bin}, + {call,erlang,byte_size,[Bin],BinSize0}, + {sub,BinSize0,1,BinSize}, + {'cond',[['_', + {put_bits,BinSize,BitsNeeded,[1]}, + {put_bits,Bin,binary,[8,align]}]]}], + {Prefix,Check,Enc} + end. + +per_enc_unconstrained(Val, Aligned) -> + case Aligned of + false -> []; + true -> [{put_bits,0,0,[1,align]}] + end ++ [{call,per_common,encode_unconstrained_number,[Val]}]. + +per_enc_unsigned(Val, Aligned) -> + case is_integer(Val) of + false -> + {var,VarBase} = Val, + Bin = {var,VarBase++"@bin"}, + BinSize = {var,VarBase++"@bin_size"}, + [{call,binary,encode_unsigned,[Val],Bin}, + {call,erlang,byte_size,[Bin],BinSize}| + per_enc_length(Bin, 8, BinSize, Aligned)]; + true -> + Bin = binary:encode_unsigned(Val), + Len = byte_size(Bin), + per_enc_length(Bin, 8, Len, Aligned) + end. + +%% Encode a length field without any constraint. +per_enc_length(Bin, Unit, Len, Aligned) -> + U = unit(1, Aligned), + PutBits = put_bits_binary(Bin, Unit, Aligned), + EncFragmented = {call,per_common,encode_fragmented,[Bin,Unit]}, + Al = case Aligned of + false -> []; + true -> [{put_bits,0,0,[1,align]}] + end, + build_cond([[{lt,Len,128}, + {put_bits,Len,8,U},PutBits], + [{lt,Len,16384}, + {put_bits,2,2,U},{put_bits,Len,14,[1]},PutBits], + ['_'|Al++[EncFragmented]]]). + +per_enc_length(Bin, Unit, Len, no, Aligned, _Type) -> + per_enc_length(Bin, Unit, Len, Aligned); +per_enc_length(Bin, Unit, Len, {{Lb,Ub},[]}, Aligned, Type) -> + {Prefix,Check,PutLen} = per_enc_constrained(Len, Lb, Ub, Aligned), + NoExt = {put_bits,0,1,[1]}, + U = unit(Unit, Aligned, Type, Lb*Unit, Ub*Unit), + PutBits = [{put_bits,Bin,binary,U}], + [{'cond',ExtConds0}] = per_enc_length(Bin, Unit, Len, Aligned), + Ext = {put_bits,1,1,[1]}, + ExtConds = prepend_to_cond(ExtConds0, Ext), + build_length_cond(Prefix, [[Check,NoExt|PutLen++PutBits]|ExtConds]); +per_enc_length(Bin, Unit, Len, {Lb,Ub}, Aligned, Type) + when is_integer(Lb) -> + {Prefix,Check,PutLen} = per_enc_constrained(Len, Lb, Ub, Aligned), + U = unit(Unit, Aligned, Type, Lb*Unit, Ub*Unit), + PutBits = [{put_bits,Bin,binary,U}], + build_length_cond(Prefix, [[Check|PutLen++PutBits]]); +per_enc_length(Bin, Unit, Len, Sv, Aligned, Type) when is_integer(Sv) -> + NumBits = Sv*Unit, + U = unit(Unit, Aligned, Type, NumBits, NumBits), + Pb = {put_bits,Bin,binary,U}, + [{'cond',[[{eq,Len,Sv},Pb]]}]. + +enc_length(Len, no, Aligned) -> + U = unit(1, Aligned), + build_cond([[{lt,Len,128}, + {put_bits,Len,8,U}], + [{lt,Len,16384}, + {put_bits,2,2,U},{put_bits,Len,14,[1]}]]); +enc_length(Len, {{Lb,Ub},[]}, Aligned) -> + {Prefix,Check,PutLen} = per_enc_constrained(Len, Lb, Ub, Aligned), + NoExt = {put_bits,0,1,[1]}, + [{'cond',ExtConds0}] = enc_length(Len, no, Aligned), + Ext = {put_bits,1,1,[1]}, + ExtConds = prepend_to_cond(ExtConds0, Ext), + build_length_cond(Prefix, [[Check,NoExt|PutLen]|ExtConds]); +enc_length(Len, {Lb,Ub}, Aligned) when is_integer(Lb) -> + {Prefix,Check,PutLen} = per_enc_constrained(Len, Lb, Ub, Aligned), + build_length_cond(Prefix, [[Check|PutLen]]); +enc_length(Len, Sv, _Aligned) when is_integer(Sv) -> + [{'cond',[[{eq,Len,Sv}]]}]. + +put_bits_binary(Bin, _Unit, Aligned) when is_binary(Bin) -> + Sz = byte_size(Bin), + <<Int:Sz/unit:8>> = Bin, + {put_bits,Int,8*Sz,unit(1, Aligned)}; +put_bits_binary(Bin, Unit, Aligned) -> + {put_bits,Bin,binary,unit(Unit, Aligned)}. + +sub_lb(Val, 0) -> + {[],Val}; +sub_lb({var,Var}=Val0, Lb) -> + Val = {var,Var++"@sub"}, + {[{sub,Val0,Lb,Val}],Val}; +sub_lb(Val, Lb) when is_integer(Val) -> + {[],Val-Lb}. + +build_length_cond([{sub,Var0,Base,Var}]=Prefix, Cs) -> + %% Non-zero lower bound, such as: SIZE (50..200, ...) + Prefix++[{'cond',opt_length_nzlb(Cs, {Var0,Var,Base}, 0)}]; +build_length_cond([], Cs) -> + %% Zero lower bound, such as: SIZE (0..200, ...) + [{'cond',opt_length_zlb(Cs, 0)}]. + +opt_length_zlb([[{ult,Var,Val}|Actions]|T], Ub) -> + %% Since the SIZE constraint is zero-based, Var + %% must be greater than zero, and we can use + %% the slightly cheaper signed less than operator. + opt_length_zlb([[{lt,Var,Val}|Actions]|T], Ub); +opt_length_zlb([[{lt,_,Val}|_]=H|T], Ub) -> + if + Val =< Ub -> + %% A previous test has already matched. + opt_length_zlb(T, Ub); + true -> + [H|opt_length_zlb(T, max(Ub, Val))] + end; +opt_length_zlb([H|T], Ub) -> + [H|opt_length_zlb(T, Ub)]; +opt_length_zlb([], _) -> []. + +opt_length_nzlb([[{ult,Var,Val}|_]=H|T], {_,Var,Base}=St, _Ub) -> + [H|opt_length_nzlb(T, St, Base+Val)]; +opt_length_nzlb([[{lt,Var0,Val}|_]=H|T], {Var0,_,_}=St, Ub) -> + if + Val =< Ub -> + %% A previous test has already matched. + opt_length_nzlb(T, St, Ub); + true -> + [H|opt_length_nzlb(T, St, Val)] + end; +opt_length_nzlb([H|T], St, Ub) -> + [H|opt_length_nzlb(T, St, Ub)]; +opt_length_nzlb([], _, _) -> []. + +build_cond(Conds0) -> + case eval_cond(Conds0, gb_sets:empty()) of + [['_'|Actions]] -> + Actions; + Conds -> + [{'cond',Conds}] + end. + +eval_cond([['_',{'cond',Cs}]], Seen) -> + eval_cond(Cs, Seen); +eval_cond([[Cond|Actions]=H|T], Seen0) -> + case gb_sets:is_element(Cond, Seen0) of + false -> + Seen = gb_sets:insert(Cond, Seen0), + case eval_cond_1(Cond) of + false -> + eval_cond(T, Seen); + true -> + [['_'|Actions]]; + maybe -> + [H|eval_cond(T, Seen)] + end; + true -> + eval_cond(T, Seen0) + end; +eval_cond([], _) -> []. + +eval_cond_1({ult,I,N}) when is_integer(I), is_integer(N) -> + 0 =< I andalso I < N; +eval_cond_1({eq,[],[]}) -> + true; +eval_cond_1({eq,I,N}) when is_integer(I), is_integer(N) -> + I =:= N; +eval_cond_1({lt,I,N}) when is_integer(I), is_integer(N) -> + I < N; +eval_cond_1(_) -> maybe. + +prepend_to_cond([H|T], Code) -> + [prepend_to_cond_1(H, Code)|prepend_to_cond(T, Code)]; +prepend_to_cond([], _) -> []. + +prepend_to_cond_1([Check|T], Code) -> + [Check,Code|T]. + +enc_char_tab(notab) -> + notab; +enc_char_tab(Tab0) -> + Tab = tuple_to_list(Tab0), + First = hd(Tab), + {First-1,list_to_tuple(enc_char_tab_1(Tab, First, 0))}. + +enc_char_tab_1([H|T], H, I) -> + [I|enc_char_tab_1(T, H+1, I+1)]; +enc_char_tab_1([_|_]=T, H, I) -> + [ill|enc_char_tab_1(T, H+1, I)]; +enc_char_tab_1([], _, _) -> []. + +enumerated_constraint([_]) -> + [{'SingleValue',0}]; +enumerated_constraint(Root) -> + [{'ValueRange',{0,length(Root)-1}}]. + +per_enc_enumerated_root(NNL, Prefix, Val, Constr, Aligned) -> + per_enc_enumerated_root_1(NNL, Prefix, Val, Constr, Aligned, 0). + +per_enc_enumerated_root_1([{H,_}|T], Prefix, Val, Constr, Aligned, N) -> + [[{eq,Val,H}|Prefix++per_enc_integer_1(N, Constr, Aligned)]| + per_enc_enumerated_root_1(T, Prefix, Val, Constr, Aligned, N+1)]; +per_enc_enumerated_root_1([], _, _, _, _, _) -> []. + +per_enc_enumerated_ext(NNL, Val, Aligned) -> + per_enc_enumerated_ext_1(NNL, Val, Aligned, 0). + +per_enc_enumerated_ext_1([{H,_}|T], Val, Aligned, N) -> + [[{eq,Val,H},{put_bits,1,1,[1]}|per_enc_small_number(N, Aligned)]| + per_enc_enumerated_ext_1(T, Val, Aligned, N+1)]; +per_enc_enumerated_ext_1([], _, _, _) -> []. + +per_enc_small_length(Val0, Aligned) -> + {Sub,Val} = sub_lb(Val0, 1), + U = unit(1, Aligned), + Sub ++ build_cond([[{lt,Val,64},{put_bits,Val,7,[1]}], + [{lt,Val0,128},{put_bits,1,1,[1]}, + {put_bits,Val0,8,U}], + ['_',{put_bits,1,1,[1]}, + {put_bits,2,2,U},{put_bits,Val0,14,[1]}]]). + +constr_min_size(no) -> no; +constr_min_size({{Lb,_},[]}) when is_integer(Lb) -> Lb; +constr_min_size({Lb,_}) when is_integer(Lb) -> Lb; +constr_min_size(Sv) when is_integer(Sv) -> Sv. + +enc_mod(false) -> uper; +enc_mod(true) -> per. + +unit(U, false) -> [U]; +unit(U, true) -> [U,align]. + +unit(U, Aligned, Type, Lb, Ub) -> + case Aligned andalso is_aligned(Type, Lb, Ub) of + true -> [U,align]; + false -> [U] + end. + +opt_choice(Imm) -> + {Pb,T0} = lists:splitwith(fun({put_bits,V,_,_}) when is_integer(V) -> + true; + (_) -> + false + end, Imm), + try + {Prefix,T} = split_off_nonbuilding(T0), + Prefix ++ opt_choice_1(T, Pb) + catch + throw:impossible -> + Imm + end. + +opt_choice_1([{'cond',Cs0}], Pb) -> + case Cs0 of + [[C|Act]] -> + [{'cond',[[C|Pb++Act]]}]; + [[C|Act],['_',{error,_}]=Error] -> + [{'cond',[[C|Pb++Act],Error]}]; + _ -> + [{'cond',opt_choice_2(Cs0, Pb)}] + end; +opt_choice_1(_, _) -> throw(impossible). + +opt_choice_2([[C|[{put_bits,_,_,_}|_]=Act]|T], Pb) -> + [[C|Pb++Act]|opt_choice_2(T, Pb)]; +opt_choice_2([[_,{error,_}]=H|T], Pb) -> + [H|opt_choice_2(T, Pb)]; +opt_choice_2([_|_], _) -> + throw(impossible); +opt_choice_2([], _) -> []. + + +%%% +%%% Helper functions for code generation of open types. +%%% + +per_enc_open_type(Val0, {ToBinMod,ToBinFunc}, Aligned) -> + {B,[Val,Len,Bin]} = mk_vars(Val0, [len,bin]), + B ++ [{call,ToBinMod,ToBinFunc,[Val],Bin}, + {call,erlang,byte_size,[Bin],Len}| + per_enc_length(Bin, 8, Len, Aligned)]. + +enc_open_type([{'cond',Cs}], Aligned) -> + [{'cond',[[C|enc_open_type_1(Act, Aligned)] || [C|Act] <- Cs]}]; +enc_open_type(_, _) -> + throw(impossible). + +enc_open_type_1([{error,_}]=Imm, _) -> + Imm; +enc_open_type_1(Imm, Aligned) -> + NumBits = num_bits(Imm, 0), + Pad = case 8 - (NumBits rem 8) of + 8 -> []; + Pad0 -> [{put_bits,0,Pad0,[1]}] + end, + NumBytes = (NumBits+7) div 8, + enc_length(NumBytes, no, Aligned) ++ Imm ++ Pad. + +num_bits([{put_bits,_,N,[U|_]}|T], Sum) when is_integer(N) -> + num_bits(T, Sum+N*U); +num_bits([_|_], _) -> + throw(impossible); +num_bits([], Sum) -> Sum. + +per_enc_open_type_output([{apply,F,A}], Acc) -> + Dst = output_var(), + {Dst,lists:reverse(Acc, [{apply,F,A,{var,atom_to_list(Dst)}}])}; +per_enc_open_type_output([{call,M,F,A}], Acc) -> + Dst = output_var(), + {Dst,lists:reverse(Acc, [{call,M,F,A,{var,atom_to_list(Dst)}}])}; +per_enc_open_type_output([{'cond',Cs}], Acc) -> + Dst = output_var(), + {Dst,lists:reverse(Acc, [{'cond',Cs,{var,atom_to_list(Dst)}}])}; +per_enc_open_type_output([H|T], Acc) -> + per_enc_open_type_output(T, [H|Acc]). + +output_var() -> + asn1ct_name:new(enc), + Curr = asn1ct_name:curr(enc), + [H|T] = atom_to_list(Curr), + list_to_atom([H - ($a - $A)|T ++ "@output"]). + + +%%% +%%% Optimize list comprehensions (SEQUENCE OF/SET OF). +%%% + +opt_lc([{lc,[{call,erlang,iolist_to_binary,[Var],Bin}, + {call,erlang,byte_size,[Bin],LenVar}, + {'cond',[[{eq,LenVar,Len},{put_bits,Bin,_,[_|Align]}]]}], + Var,Val}]=Lc, LenImm) -> + %% Given a sequence of a fixed length string, such as + %% SEQUENCE OF OCTET STRING (SIZE (4)), attempt to rewrite to + %% a list comprehension that just checks the size, followed by + %% a conversion to binary: + %% + %% _ = [if length(Comp) =:= 4; byte_size(Comp) =:= 4 -> [] end || + %% Comp <- Sof], + %% [align|iolist_to_binary(Sof)] + + CheckImm = [{'cond',[[{eq,{expr,"length("++mk_val(Var)++")"},Len}], + [{eq,{expr,"byte_size("++mk_val(Var)++")"},Len}]]}], + Al = case Align of + [] -> + []; + [align] -> + [{put_bits,0,0,[1|Align]}] + end, + case Al =:= [] orelse + is_end_aligned(LenImm) orelse + lb_is_nonzero(LenImm) of + false -> + %% Not possible because an empty SEQUENCE OF would be + %% improperly aligned. Example: + %% + %% SEQUENCE (SIZE (0..3)) OF ... + + Lc; + true -> + %% Examples: + %% + %% SEQUENCE (SIZE (1..4)) OF ... + %% (OK because there must be at least one element) + %% + %% SEQUENCE OF ... + %% (OK because the length field will force alignment) + %% + Al ++ [{lc,CheckImm,Var,Val,{var,"_"}}, + {call,erlang,iolist_to_binary,[Val]}] + end; +opt_lc([{lc,ElementImm0,V,L}]=Lc, LenImm) -> + %% Attempt to hoist the alignment, putting after the length + %% and before the list comprehension: + %% + %% [Length, + %% align, + %% [Encode(Comp) || Comp <- Sof]] + %% + + case enc_opt_al_1(ElementImm0, 0) of + {ElementImm,0} -> + case is_end_aligned(LenImm) orelse + (is_beginning_aligned(ElementImm0) andalso + lb_is_nonzero(LenImm)) of + false -> + %% Examples: + %% + %% SEQUENCE (SIZE (0..3)) OF OCTET STRING + %% (An empty SEQUENCE OF would be improperly aligned) + %% + %% SEQUENCE (SIZE (1..3)) OF OCTET STRING (SIZE (0..4)) + %% (There would be an improper alignment before the + %% first element) + + Lc; + true -> + %% Examples: + %% + %% SEQUENCE OF INTEGER + %% SEQUENCE (SIZE (1..4)) OF INTEGER + %% SEQUENCE (SIZE (1..4)) OF INTEGER (0..256) + + [{put_bits,0,0,[1,align]},{lc,ElementImm,V,L}] + end; + _ -> + %% Unknown alignment, no alignment, or not aligned at the end. + %% Examples: + %% + %% SEQUENCE OF SomeConstructedType + %% SEQUENCE OF INTEGER (0..15) + + Lc + end. + +is_beginning_aligned([{'cond',Cs}]) -> + lists:all(fun([_|Act]) -> is_beginning_aligned(Act) end, Cs); +is_beginning_aligned([{error,_}|_]) -> true; +is_beginning_aligned([{put_bits,_,_,U}|_]) -> + case U of + [_,align] -> true; + [_] -> false + end; +is_beginning_aligned(Imm0) -> + case split_off_nonbuilding(Imm0) of + {[],_} -> false; + {[_|_],Imm} -> is_beginning_aligned(Imm) + end. + +is_end_aligned(Imm) -> + case enc_opt_al_1(Imm, unknown) of + {_,0} -> true; + {_,_} -> false + end. + +lb_is_nonzero([{sub,_,_,_}|_]) -> true; +lb_is_nonzero(_) -> false. + +%%% +%%% Attempt to combine two chunks of intermediate code. +%%% + +combine_imms(ImmA0, ImmB0) -> + {Prefix0,ImmA} = split_off_nonbuilding(ImmA0), + {Prefix1,ImmB} = split_off_nonbuilding(ImmB0), + Prefix = Prefix0 ++ Prefix1, + Combined = do_combine(ImmA ++ ImmB, 3.0), + Prefix ++ Combined. + +do_combine([{error,_}=Imm|_], _Budget) -> + [Imm]; +do_combine([{'cond',Cs0}|T], Budget0) -> + Budget = debit(Budget0, num_clauses(Cs0, 0)), + Cs = [[C|do_combine(Act++T, Budget)] || [C|Act] <- Cs0], + [{'cond',Cs}]; +do_combine([{put_bits,V,_,_}|_]=L, Budget) when is_integer(V) -> + {Pb,T} = collect_put_bits(L), + do_combine_put_bits(Pb, T,Budget); +do_combine(_, _) -> + throw(impossible). + +do_combine_put_bits(Pb, [], _Budget) -> + Pb; +do_combine_put_bits(Pb, [{'cond',Cs0}|T], Budget) -> + Cs = [case Act of + [{error,_}] -> + [C|Act]; + _ -> + [C|do_combine(Pb++Act, Budget)] + end || [C|Act] <- Cs0], + do_combine([{'cond',Cs}|T], Budget); +do_combine_put_bits(_, _, _) -> + throw(impossible). + +debit(Budget0, Alternatives) -> + case Budget0 - log2(Alternatives) of + Budget when Budget > 0.0 -> + Budget; + _ -> + throw(impossible) + end. + +num_clauses([[_,{error,_}]|T], N) -> + num_clauses(T, N); +num_clauses([_|T], N) -> + num_clauses(T, N+1); +num_clauses([], N) -> N. + +log2(N) -> + math:log(N) / math:log(2.0). + +collect_put_bits(Imm) -> + lists:splitwith(fun({put_bits,V,_,_}) when is_integer(V) -> true; + (_) -> false + end, Imm). + +%%% +%%% Simple common subexpression elimination to avoid fetching +%%% the same element twice. +%%% + +enc_cse([{assign,{var,V},E}=H|T]) -> + [H|enc_cse_1(T, E, V)]; +enc_cse(Imm) -> Imm. + +enc_cse_1([{assign,Dst,E}|T], E, V) -> + [{assign,Dst,V}|enc_cse_1(T, E, V)]; +enc_cse_1([{block,Bl}|T], E, V) -> + [{block,enc_cse_1(Bl, E, V)}|enc_cse_1(T, E, V)]; +enc_cse_1([H|T], E, V) -> + [H|enc_cse_1(T, E, V)]; +enc_cse_1([], _, _) -> []. + + +%%% +%%% Pre-process the intermediate code to simplify code generation. +%%% + +enc_pre_cg(Imm) -> + enc_pre_cg_1(Imm, outside_list, in_seq). + +enc_pre_cg_1([], _StL, _StB) -> + nil; +enc_pre_cg_1([H], StL, StB) -> + enc_pre_cg_2(H, StL, StB); +enc_pre_cg_1([H0|T0], StL, StB) -> + case is_nonbuilding(H0) of + true -> + H = enc_pre_cg_nonbuilding(H0, StL), + Seq = {seq,H,enc_pre_cg_1(T0, StL, in_seq)}, + case StB of + outside_seq -> {block,Seq}; + in_seq -> Seq + end; + false -> + H = enc_pre_cg_2(H0, in_head, outside_seq), + T = enc_pre_cg_1(T0, in_tail, outside_seq), + enc_make_cons(H, T) + end. + +enc_pre_cg_2(align, StL, _StB) -> + case StL of + in_head -> align; + in_tail -> {cons,align,nil} + end; +enc_pre_cg_2({apply,_,_}=Imm, _, _) -> + Imm; +enc_pre_cg_2({block,Bl0}, StL, StB) -> + enc_pre_cg_1(Bl0, StL, StB); +enc_pre_cg_2({call,_,_,_}=Imm, _, _) -> + Imm; +enc_pre_cg_2({call_gen,_,_,_,_}=Imm, _, _) -> + Imm; +enc_pre_cg_2({'cond',Cs0}, StL, _StB) -> + Cs = [{C,enc_pre_cg_1(Act, StL, outside_seq)} || [C|Act] <- Cs0], + {'cond',Cs}; +enc_pre_cg_2({error,_}=E, _, _) -> + E; +enc_pre_cg_2({lc,B0,V,L}, StL, _StB) -> + B = enc_pre_cg_1(B0, StL, outside_seq), + {lc,B,V,L}; +enc_pre_cg_2({put_bits,V,8,[1]}, StL, _StB) -> + case StL of + in_head -> {integer,V}; + in_tail -> {cons,{integer,V},nil}; + outside_list -> {cons,{integer,V},nil} + end; +enc_pre_cg_2({put_bits,V,binary,_}, _StL, _StB) -> + V; +enc_pre_cg_2({put_bits,_,_,[_]}=PutBits, _StL, _StB) -> + {binary,[PutBits]}; +enc_pre_cg_2({var,_}=Imm, _, _) -> Imm. + +enc_make_cons({binary,H}, {binary,T}) -> + {binary,H++T}; +enc_make_cons({binary,H0}, {cons,{binary,H1},T}) -> + {cons,{binary,H0++H1},T}; +enc_make_cons({integer,Int}, {binary,T}) -> + {binary,[{put_bits,Int,8,[1]}|T]}; +enc_make_cons(H, T) -> + {cons,H,T}. + +enc_pre_cg_nonbuilding({'cond',Cs0,Dst}, StL) -> + Cs = [{C,enc_pre_cg_1(Act, StL, outside_seq)} || [C|Act] <- Cs0], + {'cond',Cs,Dst}; +enc_pre_cg_nonbuilding({lc,B0,Var,List,Dst}, StL) -> + B = enc_pre_cg_1(B0, StL, outside_seq), + {lc,B,Var,List,Dst}; +enc_pre_cg_nonbuilding({'try',Try0,{P,Succ0},Else0,Dst}, StL) -> + Try = enc_pre_cg_1(Try0, StL, outside_seq), + Succ = enc_pre_cg_1(Succ0, StL, outside_seq), + Else = enc_pre_cg_1(Else0, StL, outside_seq), + {'try',Try,{P,Succ},Else,Dst}; +enc_pre_cg_nonbuilding(Imm, _) -> Imm. + + +%%% +%%% Code generation for encoding. +%%% + +enc_cg({cons,_,_}=Cons) -> + enc_cg_cons(Cons); +enc_cg({block,Imm}) -> + emit(["begin",nl]), + enc_cg(Imm), + emit([nl, + "end"]); +enc_cg({seq,First,Then}) -> + enc_cg(First), + emit([com,nl]), + enc_cg(Then); +enc_cg(align) -> + emit(align); +enc_cg({apply,F0,As0}) -> + As = enc_call_args(As0, ""), + case F0 of + {M,F} -> + emit([{asis,M},":",{asis,F},"(",As,")"]); + F when is_atom(F) -> + emit([{asis,F},"(",As,")"]) + end; +enc_cg({apply,F0,As0,Dst}) -> + As = enc_call_args(As0, ""), + emit([mk_val(Dst)," = "]), + case F0 of + {M,F} -> + emit([{asis,M},":",{asis,F},"(",As,")"]); + F when is_atom(F) -> + emit([{asis,F},"(",As,")"]) + end; +enc_cg({assign,Dst0,Expr}) -> + Dst = mk_val(Dst0), + emit([Dst," = ",Expr]); +enc_cg({binary,PutBits}) -> + emit(["<<",enc_cg_put_bits(PutBits, ""),">>"]); +enc_cg({call,M,F,As0}) -> + As = [mk_val(A) || A <- As0], + asn1ct_func:call(M, F, As); +enc_cg({call,M,F,As0,Dst}) -> + As = [mk_val(A) || A <- As0], + emit([mk_val(Dst)," = "]), + asn1ct_func:call(M, F, As); +enc_cg({call_gen,Prefix,Key,Gen,As0}) -> + As = [mk_val(A) || A <- As0], + asn1ct_func:call_gen(Prefix, Key, Gen, As); +enc_cg({'cond',Cs}) -> + enc_cg_cond(Cs); +enc_cg({'cond',Cs,Dst0}) -> + Dst = mk_val(Dst0), + emit([Dst," = "]), + enc_cg_cond(Cs); +enc_cg({error,Error}) when is_function(Error, 0) -> + Error(); +enc_cg({error,Var0}) -> + Var = mk_val(Var0), + emit(["exit({error,{asn1,{illegal_value,",Var,"}}})"]); +enc_cg({integer,Int}) -> + emit(mk_val(Int)); +enc_cg({lc,Body,Var,List}) -> + emit("["), + enc_cg(Body), + emit([" || ",mk_val(Var)," <- ",mk_val(List),"]"]); +enc_cg({lc,Body,Var,List,Dst}) -> + emit([mk_val(Dst)," = ["]), + enc_cg(Body), + emit([" || ",mk_val(Var)," <- ",mk_val(List),"]"]); +enc_cg(nil) -> + emit("[]"); +enc_cg({sub,Src0,Int,Dst0}) -> + Src = mk_val(Src0), + Dst = mk_val(Dst0), + emit([Dst," = ",Src," - ",Int]); +enc_cg({'try',Try,{P,Succ},Else,Dst}) -> + emit([mk_val(Dst)," = try "]), + enc_cg(Try), + emit([" of",nl, + mk_val(P)," ->",nl]), + enc_cg(Succ), + emit([nl, + "catch throw:invalid ->",nl]), + enc_cg(Else), + emit([nl, + "end"]); +enc_cg({var,V}) -> + emit(V). + +enc_cg_cons(Cons) -> + emit("["), + enc_cg_cons_1(Cons), + emit("]"). + +enc_cg_cons_1({cons,H,{cons,_,_}=T}) -> + enc_cg(H), + emit([com,nl]), + enc_cg_cons_1(T); +enc_cg_cons_1({cons,H,nil}) -> + enc_cg(H); +enc_cg_cons_1({cons,H,T}) -> + enc_cg(H), + emit("|"), + enc_cg(T). + +enc_call_args([A|As], Sep) -> + [Sep,mk_val(A)|enc_call_args(As, ", ")]; +enc_call_args([], _) -> []. + +enc_cg_cond([{'_',Action}]) -> + enc_cg(Action); +enc_cg_cond(Cs) -> + emit("if "), + enc_cg_cond(Cs, ""), + emit([nl, + "end"]). + +enc_cg_cond([C|Cs], Sep) -> + emit(Sep), + enc_cg_cond_1(C), + enc_cg_cond(Cs, [";",nl]); +enc_cg_cond([], _) -> ok. + +enc_cg_cond_1({Cond,Action}) -> + enc_cond_term(Cond), + emit([" ->",nl]), + enc_cg(Action). + +enc_cond_term('_') -> + emit("true"); +enc_cond_term({ult,Var0,Int}) -> + Var = mk_val(Var0), + N = uper_num_bits(Int), + case 1 bsl N of + Int -> + emit([Var," bsr ",N," =:= 0"]); + _ -> + emit(["0 =< ",Var,", ",Var," < ",Int]) + end; +enc_cond_term({eq,Var0,Term}) -> + Var = mk_val(Var0), + emit([Var," =:= ",{asis,Term}]); +enc_cond_term({ge,Var0,Int}) -> + Var = mk_val(Var0), + emit([Var," >= ",Int]); +enc_cond_term({lt,Var0,Int}) -> + Var = mk_val(Var0), + emit([Var," < ",Int]). + +enc_cg_put_bits([{put_bits,Val0,N,[1]}|T], Sep) -> + Val = mk_val(Val0), + [[Sep,Val,":",integer_to_list(N)]|enc_cg_put_bits(T, ",")]; +enc_cg_put_bits([], _) -> []. + +mk_val({var,Str}) -> Str; +mk_val({expr,Str}) -> Str; +mk_val(Int) when is_integer(Int) -> integer_to_list(Int); +mk_val(Other) -> {asis,Other}. + +%%% +%%% Generate a function that maps a name of a bit position +%%% to the bit position. +%%% + +bit_string_name2pos_fun(NNL, Src) -> + {call_gen,"bit_string_name2pos_",NNL, + fun(Fd, Name) -> gen_name2pos(Fd, Name, NNL) end,[Src]}. + +gen_name2pos(Fd, Name, Names) -> + Cs0 = gen_name2pos_cs(Names, Name), + Cs = Cs0 ++ [bit_clause(Name),nil_clause(),invalid_clause()], + F = {function,1,Name,1,Cs}, + file:write(Fd, [erl_pp:function(F)]). + +gen_name2pos_cs([{K,V}|T], Name) -> + P = [{cons,0,{atom,0,K},{var,0,'T'}}], + B = [{cons,0,{integer,0,V},{call,0,{atom,0,Name},[{var,0,'T'}]}}], + [{clause,0,P,[],B}|gen_name2pos_cs(T, Name)]; +gen_name2pos_cs([], _) -> []. + +bit_clause(Name) -> + VarT = {var,0,'T'}, + VarPos = {var,0,'Pos'}, + P = [{cons,0,{tuple,0,[{atom,0,bit},VarPos]},VarT}], + G = [[{call,0,{atom,0,is_integer},[VarPos]}]], + B = [{cons,0,VarPos,{call,0,{atom,0,Name},[VarT]}}], + {clause,0,P,G,B}. + +nil_clause() -> + P = B = [{nil,0}], + {clause,0,P,[],B}. + +invalid_clause() -> + P = [{var,0,'_'}], + B = [{call,0,{atom,0,throw},[{atom,0,invalid}]}], + {clause,0,P,[],B}. + +%%% +%%% Hoist alignment to reduce the number of list elements in +%%% encode. Fewer lists elements means faster traversal in +%%% complete/{2,3}. +%%% +%%% For example, the following data sequence: +%%% +%%% [align,<<1:1,0:1>>,[align,<<Len:16>>|Data]] +%%% +%%% can be rewritten to: +%%% +%%% [align,<<1:1,0:1,0:6>>,[<<Len:16>>|Data]] +%%% +%%% The change from the literal <<1:1,0:1>> to <<1:1,0:1,0:6>> +%%% comes for free, and we have eliminated one element of the +%%% sub list. +%%% +%%% We must be careful not to rewrite: +%%% +%%% [<<1:1,0:1>>,[align,<<Len:16>>|Data]] +%%% +%%% to: +%%% +%%% [[<<1:1,0:1>>,align],[<<Len:16>>|Data]] +%%% +%%% because even though [<<1:0,0:1>>,align] is a literal and does +%%% not add any additional construction cost, there is one more +%%% sub list that needs to be traversed. +%%% + +enc_hoist_align(Imm0) -> + Imm = enc_hoist_align_reverse(Imm0, []), + enc_hoist_align(Imm, false, []). + +enc_hoist_align_reverse([H|T], Acc) -> + case enc_opt_al_1([H], 0) of + {[H],_} -> + enc_hoist_align_reverse(T, [H|Acc]); + {_,_} -> + lists:reverse(T, [H,stop|Acc]) + end; +enc_hoist_align_reverse([], Acc) -> Acc. + +enc_hoist_align([stop|T], _Aligned, Acc) -> + lists:reverse(T, Acc); +enc_hoist_align([{block,Bl0}|T], Aligned, Acc) -> + Bl = case Aligned of + false -> Bl0; + true -> enc_hoist_block(Bl0) + end, + case is_beginning_aligned(Bl) of + false -> + enc_hoist_align(T, false, [{block,Bl}|Acc]); + true -> + enc_hoist_align(T, true, [{put_bits,0,0,[1,align]}, + {block,Bl}|Acc]) + end; +enc_hoist_align([H|T], _, Acc) -> + enc_hoist_align(T, false, [H|Acc]); +enc_hoist_align([], _, Acc) -> Acc. + +enc_hoist_block(Bl) -> + try + enc_hoist_block_1(lists:reverse(Bl)) + catch + throw:impossible -> + Bl + end. + +enc_hoist_block_1([{'cond',Cs0}|T]) -> + Cs = [[C|enc_hoist_block_2(Act)] || [C|Act] <- Cs0], + H = {'cond',Cs}, + lists:reverse(T, [H]); +enc_hoist_block_1(_) -> + throw(impossible). + +enc_hoist_block_2([{'cond',_}|_]=L) -> + enc_hoist_block(L); +enc_hoist_block_2([{error,_}]=L) -> + L; +enc_hoist_block_2([]) -> + [{put_bits,0,0,[1,align]}]; +enc_hoist_block_2(L) -> + case lists:last(L) of + {put_bits,_,_,_} -> + L ++ [{put_bits,0,0,[1,align]}]; + _ -> + throw(impossible) + end. + +%%% +%%% Optimize alignment for encoding. +%%% + +enc_opt_al(Imm0) -> + {Imm,_} = enc_opt_al_1(Imm0, unknown), + Imm. + +enc_opt_al_1([{'cond',Cs0,Dst},{call,per,complete,[Dst],Bin}|T0], Al0) -> + {Cs1,{M,F}} = enc_opt_al_prepare_cond(Cs0), + {Cs,_} = enc_opt_al_cond(Cs1, 0), + {T,Al} = enc_opt_al_1([{call,M,F,[Dst],Bin}|T0], Al0), + {[{'cond',Cs,Dst}|T],Al}; +enc_opt_al_1([H0|T0], Al0) -> + {H,Al1} = enc_opt_al(H0, Al0), + {T,Al} = enc_opt_al_1(T0, Al1), + {H++T,Al}; +enc_opt_al_1([], Al) -> {[],Al}. + +enc_opt_al({apply,_,_,_}=Imm, Al) -> + {[Imm],Al}; +enc_opt_al({assign,_,_}=Imm, Al) -> + {[Imm],Al}; +enc_opt_al({block,Bl0}, Al0) -> + {Bl,Al} = enc_opt_al_1(Bl0, Al0), + {[{block,Bl}],Al}; +enc_opt_al({call,erlang,iolist_to_binary,[_]}=Imm, Al) -> + {[Imm],Al}; +enc_opt_al({call,per_common,encode_fragmented,[_,U]}=Call, Al) -> + case U rem 8 of + 0 -> {[Call],Al}; + _ -> {[Call],unknown} + end; +enc_opt_al({call,per_common,encode_unconstrained_number,[_]}=Call, _) -> + {[Call],0}; +enc_opt_al({call,_,_,_,_}=Call, Al) -> + {[Call],Al}; +enc_opt_al({'cond',Cs0}, Al0) -> + {Cs,Al} = enc_opt_al_cond(Cs0, Al0), + {[{'cond',Cs}],Al}; +enc_opt_al({error,_}=Imm, Al) -> + {[Imm],Al}; +enc_opt_al({put_bits,V,N,[U,align]}, Al0) when Al0 rem 8 =:= 0 -> + Al = if + is_integer(N) -> N*U; + N =:= binary, U rem 8 =:= 0 -> 0; + true -> unknown + end, + {[{put_bits,V,N,[U]}],Al}; +enc_opt_al({put_bits,V,binary,[U,align]}, Al0) when is_integer(Al0) -> + N = 8 - (Al0 rem 8), + Al = case U rem 8 of + 0 -> 0; + _ -> unknown + end, + {[{put_bits,0,N,[1]},{put_bits,V,binary,[U]}],Al}; +enc_opt_al({put_bits,V,N0,[U,align]}, Al0) when is_integer(N0), is_integer(Al0) -> + N = N0 + (8 - Al0 rem 8), + Al = N0*U, + {[{put_bits,V,N,[1]}],Al}; +enc_opt_al({put_bits,_,N,[U,align]}=PutBits, _) when is_integer(N) -> + {[PutBits],N*U}; +enc_opt_al({put_bits,_,binary,[U,align]}=PutBits, _) when U rem 8 =:= 0 -> + {[PutBits],0}; +enc_opt_al({put_bits,_,N,[U]}=PutBits, Al) when is_integer(N), is_integer(Al) -> + {[PutBits],Al+N*U}; +enc_opt_al({put_bits,_,binary,[U]}=PutBits, Al) when U rem 8 =:= 0 -> + {[PutBits],Al}; +enc_opt_al({sub,_,_,_}=Imm, Al) -> + {[Imm],Al}; +enc_opt_al(Imm, _) -> + {[Imm],unknown}. + +enc_opt_al_cond(Cs0, Al0) -> + enc_opt_al_cond_1(Cs0, Al0, [], []). + +enc_opt_al_cond_1([['_',{error,_}]=C|Cs], Al, CAcc, AAcc) -> + enc_opt_al_cond_1(Cs, Al, [C|CAcc], AAcc); +enc_opt_al_cond_1([[C|Act0]|Cs0], Al0, CAcc, AAcc) -> + {Act,Al1} = enc_opt_al_1(Act0, Al0), + Al = if + Al1 =:= unknown -> Al1; + true -> Al1 rem 8 + end, + enc_opt_al_cond_1(Cs0, Al0, [[C|Act]|CAcc], [Al|AAcc]); +enc_opt_al_cond_1([], _, CAcc, AAcc) -> + Al = case lists:usort(AAcc) of + [] -> unknown; + [Al0] -> Al0; + [_|_] -> unknown + end, + {lists:reverse(CAcc),Al}. + +enc_opt_al_prepare_cond(Cs0) -> + try enc_opt_al_prepare_cond_1(Cs0) of + Cs -> + {Cs,{erlang,iolist_to_binary}} + catch + throw:impossible -> + {Cs0,{per,complete}} + end. + +enc_opt_al_prepare_cond_1(Cs) -> + [[C|enc_opt_al_prepare_cond_2(Act)] || [C|Act] <- Cs]. + +enc_opt_al_prepare_cond_2([{put_bits,_,binary,[U|_]}|_]) when U rem 8 =/= 0 -> + throw(impossible); +enc_opt_al_prepare_cond_2([{put_bits,_,_,_}=H|T]) -> + [H|enc_opt_al_prepare_cond_2(T)]; +enc_opt_al_prepare_cond_2([{call,per_common,encode_fragmented,_}=H|T]) -> + [H|enc_opt_al_prepare_cond_2(T)]; +enc_opt_al_prepare_cond_2([_|_]) -> + throw(impossible); +enc_opt_al_prepare_cond_2([]) -> + [{put_bits,0,0,[1,align]}]. + + +%%% +%%% For the aligned PER format, fix up the intermediate format +%%% before code generation. Code generation will be somewhat +%%% easier if 'align' appear as a separate instruction. +%%% + +per_fixup([{apply,_,_}=H|T]) -> + [H|per_fixup(T)]; +per_fixup([{apply,_,_,_}=H|T]) -> + [H|per_fixup(T)]; +per_fixup([{block,Block}|T]) -> + [{block,per_fixup(Block)}|per_fixup(T)]; +per_fixup([{'assign',_,_}=H|T]) -> + [H|per_fixup(T)]; +per_fixup([{'cond',Cs0}|T]) -> + Cs = [[C|per_fixup(Act)] || [C|Act] <- Cs0], + [{'cond',Cs}|per_fixup(T)]; +per_fixup([{'cond',Cs0,Dst}|T]) -> + Cs = [[C|per_fixup(Act)] || [C|Act] <- Cs0], + [{'cond',Cs,Dst}|per_fixup(T)]; +per_fixup([{call,_,_,_}=H|T]) -> + [H|per_fixup(T)]; +per_fixup([{call,_,_,_,_}=H|T]) -> + [H|per_fixup(T)]; +per_fixup([{call_gen,_,_,_,_}=H|T]) -> + [H|per_fixup(T)]; +per_fixup([{error,_}=H|T]) -> + [H|per_fixup(T)]; +per_fixup([{lc,B,V,L}|T]) -> + [{lc,per_fixup(B),V,L}|per_fixup(T)]; +per_fixup([{lc,B,V,L,Dst}|T]) -> + [{lc,per_fixup(B),V,L,Dst}|per_fixup(T)]; +per_fixup([{sub,_,_,_}=H|T]) -> + [H|per_fixup(T)]; +per_fixup([{'try',Try0,{P,Succ0},Else0,Dst}|T]) -> + Try = per_fixup(Try0), + Succ = per_fixup(Succ0), + Else = per_fixup(Else0), + [{'try',Try,{P,Succ},Else,Dst}|per_fixup(T)]; +per_fixup([{put_bits,_,_,_}|_]=L) -> + fixup_put_bits(L); +per_fixup([{var,_}=H|T]) -> + [H|per_fixup(T)]; +per_fixup([]) -> []. + +fixup_put_bits([{put_bits,0,0,[_,align]}|T]) -> + [align|fixup_put_bits(T)]; +fixup_put_bits([{put_bits,0,0,_}|T]) -> + fixup_put_bits(T); +fixup_put_bits([{put_bits,V,N,[U,align]}|T]) -> + [align,{put_bits,V,N,[U]}|fixup_put_bits(T)]; +fixup_put_bits([{put_bits,_,_,_}=H|T]) -> + [H|fixup_put_bits(T)]; +fixup_put_bits(Other) -> per_fixup(Other). + %% effective_constraint(Type,C) %% Type = atom() %% C = [C1,...] diff --git a/lib/asn1/src/asn1ct_value.erl b/lib/asn1/src/asn1ct_value.erl index ecdfa3f645..992210232f 100644 --- a/lib/asn1/src/asn1ct_value.erl +++ b/lib/asn1/src/asn1ct_value.erl @@ -32,11 +32,11 @@ from_type(M,Typename) -> - case asn1_db:dbget(M,Typename) of - undefined -> + case asn1_db:dbload(M) of + error -> {error,{not_found,{M,Typename}}}; - Tdef when is_record(Tdef,typedef) -> - Type = Tdef#typedef.typespec, + ok -> + #typedef{typespec=Type} = asn1_db:dbget(M, Typename), from_type(M,[Typename],Type); Vdef when is_record(Vdef,valuedef) -> from_value(Vdef); diff --git a/lib/asn1/src/asn1rtt_ber.erl b/lib/asn1/src/asn1rtt_ber.erl index b5429fe324..583ff790b7 100644 --- a/lib/asn1/src/asn1rtt_ber.erl +++ b/lib/asn1/src/asn1rtt_ber.erl @@ -22,8 +22,7 @@ %% encoding / decoding of BER -export([ber_decode_nif/1,ber_decode_erlang/1,match_tags/2,ber_encode/1]). --export([encode_tags/2, - encode_tags/3, +-export([encode_tags/3, skip_ExtensionAdditions/2]). -export([encode_boolean/2,decode_boolean/2, encode_integer/2,encode_integer/3, diff --git a/lib/asn1/src/asn1rtt_per.erl b/lib/asn1/src/asn1rtt_per.erl index 9f4b7500d8..672c84593c 100644 --- a/lib/asn1/src/asn1rtt_per.erl +++ b/lib/asn1/src/asn1rtt_per.erl @@ -18,62 +18,7 @@ %% -module(asn1rtt_per). --export([setext/1, fixextensions/2, - skipextensions/3, - set_choice/3,encode_integer/2, - encode_small_number/1, - encode_constrained_number/2, - encode_length/1, - encode_length/2, - encode_bit_string/3, - encode_object_identifier/1, - encode_relative_oid/1, - complete/1, - encode_open_type/1, - encode_GeneralString/2, - encode_GraphicString/2, - encode_TeletexString/2, - encode_VideotexString/2, - encode_ObjectDescriptor/2, - encode_UTF8String/1, - encode_octet_string/2, - encode_known_multiplier_string/4, - octets_to_complete/2]). - --define('16K',16384). --define('32K',32768). --define('64K',65536). - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% setext(true|false) -> CompleteList -%% - -setext(false) -> - [0]; -setext(true) -> - [1]. - -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). +-export([skipextensions/3,complete/1]). skipextensions(Bytes0, Nr, ExtensionBitstr) when is_bitstring(ExtensionBitstr) -> Prev = Nr - 1, @@ -95,270 +40,6 @@ align(BitStr) when is_bitstring(BitStr) -> <<_:AlignBits,Rest/binary>> = BitStr, Rest. -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% 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, % the value is in the root set - encode_constrained_number({0,Len1-1},N)]; - N when is_integer(N) -> - [0]; % no encoding if only 0 or 1 alternative - false -> - [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. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% 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(Val) -> - case byte_size(Val) of - Size when Size > 255 -> - [encode_length(Size),21,<<Size:16>>,Val]; % octets implies align - Size -> - [encode_length(Size),20,Size,Val] - end. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% encode_integer(Constraint, Value) -> CompleteList -%% -encode_integer([{Rc,_Ec}],Val) when is_tuple(Rc) -> - try - [0|encode_integer([Rc], Val)] - catch - _:{error,{asn1,_}} -> - [1|encode_unconstrained_number(Val)] - 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',{Lb,Ub}=VR,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) when Lb =< 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}}}). - - -%% 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(Val) when Val < 64 -> - [10,7,Val]; -encode_small_number(Val) -> - [1|encode_semi_constrained_number(0, Val)]. - -%% X.691:10.7 Encoding of a semi-constrained whole number -encode_semi_constrained_number(Lb, Val) -> - Val2 = Val - Lb, - Oct = eint_positive(Val2), - Len = length(Oct), - if - Len < 128 -> - [20,Len+1,Len|Oct]; - Len < 256 -> - [encode_length(Len),20,Len|Oct]; - true -> - [encode_length(Len),21,<<Len:16>>|Oct] - end. - -encode_constrained_number({Lb,_Ub},_Range,{bits,N},Val) -> - Val2 = Val-Lb, - [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, - [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, - [21,<<N:16>>,Val2]; -encode_constrained_number({Lb,_Ub},Range,_,Val) -> - Val2 = Val-Lb, - if - Range =< 16#1000000 -> % max 3 octets - Octs = eint_positive(Val2), - L = length(Octs), - [encode_length({1,3},L),[20,L,Octs]]; - Range =< 16#100000000 -> % max 4 octets - Octs = eint_positive(Val2), - L = length(Octs), - [encode_length({1,4},L),[20,L,Octs]]; - Range =< 16#10000000000 -> % max 5 octets - Octs = eint_positive(Val2), - L = length(Octs), - [encode_length({1,5},L),[20,L,Octs]]; - true -> - exit({not_supported,{integer_range,Range}}) - end. - -encode_constrained_number({Lb,Ub}, Val) when Val >= Lb, Ub >= Val -> - Range = Ub - Lb + 1, - Val2 = Val - Lb, - if - Range == 1 -> []; - Range == 2 -> - [Val2]; - Range =< 4 -> - [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 -> - [20,1,Val2]; - Range =< 65536 -> - [20,2,<<Val2:16>>]; - Range =< (1 bsl (255*8)) -> - Octs = binary:encode_unsigned(Val2), - RangeOcts = binary:encode_unsigned(Range - 1), - OctsLen = byte_size(Octs), - RangeOctsLen = byte_size(RangeOcts), - LengthBitsNeeded = minimum_bits(RangeOctsLen - 1), - [10,LengthBitsNeeded,OctsLen-1,20,OctsLen,Octs]; - true -> - exit({not_supported,{integer_range,Range}}) - end; -encode_constrained_number({_,_},Val) -> - exit({error,{asn1,{illegal_value,Val}}}). - -%% For some reason the minimum bits needed in the length field in -%% the encoding of constrained whole numbers must always be at least 2? -minimum_bits(N) when N < 4 -> 2; -minimum_bits(N) when N < 8 -> 3; -minimum_bits(N) when N < 16 -> 4; -minimum_bits(N) when N < 32 -> 5; -minimum_bits(N) when N < 64 -> 6; -minimum_bits(N) when N < 128 -> 7; -minimum_bits(_N) -> 8. - -%% X.691:10.8 Encoding of an unconstrained whole number - -encode_unconstrained_number(Val) -> - Oct = if - Val >= 0 -> - eint(Val, []); - true -> - enint(Val, []) - end, - Len = length(Oct), - if - Len < 128 -> - [20,Len + 1,Len|Oct]; - Len < 256 -> - [20,Len + 2,<<2:2,Len:14>>|Oct]; - true -> - [encode_length(Len),21,<<Len:16>>|Oct] - end. - -%% used for positive Values which don't need a sign bit -%% returns a list -eint_positive(Val) -> - case eint(Val,[]) of - [0,B1|T] -> - [B1|T]; - T -> - T - end. - - -eint(0, [B|Acc]) when B < 128 -> - [B|Acc]; -eint(N, Acc) -> - eint(N bsr 8, [N band 16#ff| Acc]). - -enint(-1, [B1|T]) when B1 > 127 -> - [B1|T]; -enint(N, Acc) -> - enint(N bsr 8, [N band 16#ff|Acc]). - -%% 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(Len) -> % unconstrained - if - Len < 128 -> - [20,1,Len]; - Len < 16384 -> - <<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({C,[]}, Len) -> - case C of - {Lb,Ub}=Vr when Lb =< Len, Len =< Ub -> - [0|encode_constrained_number(Vr, Len)]; - _ -> - [1|encode_length(Len)] - end; -encode_length(Len, Len) -> - []; -encode_length(Vr, Len) -> - encode_constrained_number(Vr, Len). - -%% 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 -> - [10,7,Len-1]; -encode_small_length(Len) -> - [1,encode_length(Len)]. - - decode_length(Buffer) -> % un-constrained case align(Buffer) of <<0:1,Oct:7,Rest/binary>> -> @@ -370,511 +51,70 @@ decode_length(Buffer) -> % un-constrained exit({error,{asn1,{decode_length,{nyi,above_16k}}}}) end. -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% 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, Bits, NamedBitList) when is_bitstring(Bits) -> - PadLen = (8 - (bit_size(Bits) band 7)) band 7, - Compact = {PadLen,<<Bits/bitstring,0:PadLen>>}, - encode_bin_bit_string(C, Compact, NamedBitList); -encode_bit_string(C, {Unused,BinBits}=Bin, 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,<<Int:16>>,B1}; - B1 -> - {43,<<Int:16>>,<<B1:16>>} - 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(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(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 = 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). - -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 < Lb -> BitList++lists:duplicate(Lb-B, 0); - D -> F = fun(L,LB,LB,_,_)->lists:reverse(L); - ([0|R],L1,LB,UB,Fun)->Fun(R,L1-1,LB,UB,Fun); - (L,L1,_,UB,_)when L1 =< UB -> lists:reverse(L); - (_,_L1,_,_,_) ->exit({error,{list_length_BIT_STRING, - BitList}}) end, - F(lists:reverse(BitList),D,Lb,Ub,F) - end. - -%% encode_bin_bit_string/3, when value is a tuple of Unused and BinBits. -%% Unused = integer(),i.e. number unused bits in least sign. byte of -%% BinBits = binary(). -encode_bin_bit_string(C, {Unused,BinBits}, _NamedBitList) - when is_integer(C),C=<16 -> - range_check(C, bit_size(BinBits) - Unused), - [45,C,byte_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,byte_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 byte_size(BinBits) of - Size when Size =< 255 -> - [2,46,<<C:16>>,Size,BinBits]; - Size -> - [2,47,<<C:16>>,<<Size:16>>,BinBits] - end; -encode_bin_bit_string(C,UnusedAndBin={_,_},NamedBitList) -> - {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) -> - Size = byte_size(Bin1), - [encode_length({Lb,Ub}, Size*8 - Unused1), - 2,octets_unused_to_complete(Unused1,Size,Bin1)]; - no -> - Size = byte_size(Bin1), - [encode_length(Size*8 - Unused1), - 2|octets_unused_to_complete(Unused1, Size, Bin1)]; - {{Fix,Fix},Ext} when is_integer(Fix),is_list(Ext) -> - case byte_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 = byte_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 = byte_size(Bin)-1, - <<Bfront:Size/binary, LastByte:8>> = 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}); - _ -> - {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. - - -%%%%%%%%%%%%%%% -%% - -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:keyfind(Val, 1, NamedBitList) of - {_ValName, ValPos} -> - get_all_bitposes(Rest, NamedBitList, [ValPos | Ack]); - false -> - 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({{Sv,Sv},Ext}=SZ, Val) when is_list(Ext), Sv =< 2 -> - Len = length(Val), - try - case encode_length(SZ, Len) of - [0|_]=EncLen -> - [EncLen,45,Sv*8,Sv,Val]; - [_|_]=EncLen -> - [EncLen|octets_to_complete(Len, Val)] - end - catch - exit:{error,{asn1,{encode_length,_}}} -> - encode_fragmented_octet_string(Val) - end; -encode_octet_string({_,_}=SZ, Val) -> - Len = length(Val), - try - [encode_length(SZ, Len),2|octets_to_complete(Len, Val)] - catch - exit:{error,{asn1,{encode_length,_}}} -> - encode_fragmented_octet_string(Val) - end; -encode_octet_string(Sv, Val) when is_integer(Sv) -> - encode_fragmented_octet_string(Val); -encode_octet_string(no, Val) -> - Len = length(Val), - try - [encode_length(Len),2|octets_to_complete(Len, Val)] - catch - exit:{error,{asn1,{encode_length,_}}} -> - encode_fragmented_octet_string(Val) - end. - -encode_fragmented_octet_string(Val) -> - Bin = iolist_to_binary(Val), - efos_1(Bin). - -efos_1(<<B1:16#C000/binary,B2:16#4000/binary,T/binary>>) -> - [20,1,<<3:2,4:6>>, - octets_to_complete(16#C000, B1), - octets_to_complete(16#4000, B2)|efos_1(T)]; -efos_1(<<B:16#C000/binary,T/binary>>) -> - [20,1,<<3:2,3:6>>,octets_to_complete(16#C000, B)|efos_1(T)]; -efos_1(<<B:16#8000/binary,T/binary>>) -> - [20,1,<<3:2,2:6>>,octets_to_complete(16#8000, B)|efos_1(T)]; -efos_1(<<B:16#4000/binary,T/binary>>) -> - [20,1,<<3:2,1:6>>,octets_to_complete(16#4000, B)|efos_1(T)]; -efos_1(<<>>) -> - [20,1,0]; -efos_1(<<B/bitstring>>) -> - Len = byte_size(B), - [encode_length(Len)|octets_to_complete(Len, B)]. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Restricted char string types -%% (NumericString, PrintableString,VisibleString,IA5String,BMPString,UniversalString) -%% X.691:26 and X.680:34-36 - -encode_restricted_string(Val) when is_list(Val)-> - Len = length(Val), - [encode_length(Len)|octets_to_complete(Len, Val)]. - -encode_known_multiplier_string(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) -> - [2,Result]; - {{_,Ub},Ext}=SZ when is_list(Ext) -> - Len = length(Val), - case encode_length(SZ, Len) of - [0|_]=EncLen when Ub*NumBits < 16 -> - [EncLen,45,Len*NumBits,Len,Val]; - [_|_]=EncLen -> - [EncLen,2|Result] - end; - {_,Ub}=Range -> - [encode_length(Range, length(Val))| - if - Ub*NumBits < 16 -> Result; - true -> [2|Result] - end]; - no -> - [encode_length(length(Val)),2,Result] - end. - -encode_GeneralString(_C,Val) -> - encode_restricted_string(Val). - -encode_GraphicString(_C,Val) -> - encode_restricted_string(Val). - -encode_ObjectDescriptor(_C,Val) -> - encode_restricted_string(Val). - -encode_TeletexString(_C,Val) -> % equivalent with T61String - encode_restricted_string(Val). - -encode_VideotexString(_C,Val) -> - encode_restricted_string(Val). - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% chars_encode(C,StringType,Value) -> ValueList -%% -%% encodes chars according to the per rules taking the constraint -%% PermittedAlphabet into account. -%% -%% This function only encodes the value part and NOT the length. - -chars_encode2([H|T],NumBits,T1={Min,Max,notab}) when H =< Max, H >= Min -> - [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 -> - [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) - [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 - Unused = (8 - (NumBits rem 8)) rem 8, - Len = NumBits + Unused, - [30,Unused,Len div 8,<<(Val bsl Unused):Len>>]. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% encode_UTF8String(Val) -> CompleteList -%% Val -> <<utf8encoded binary>> -%% CompleteList -> [apropriate codes and values for driver complete] -%% -encode_UTF8String(Val) when is_binary(Val) -> - Sz = byte_size(Val), - [encode_length(Sz),octets_to_complete(Sz, Val)]; -encode_UTF8String(Val) -> - encode_UTF8String(list_to_binary(Val)). - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% encode_object_identifier(Val) -> CompleteList -%% encode_object_identifier({Name,Val}) -> CompleteList -%% Val -> {Int1,Int2,...,IntN} % N >= 2 -%% Name -> atom() -%% Int1 -> integer(0..2) -%% Int2 -> integer(0..39) when Int1 (0..1) else integer() -%% Int3-N -> integer() -%% CompleteList -> [{bits,8,Val}|{octets,Ol}|align|...] -%% -encode_object_identifier(Val) -> - OctetList = e_object_identifier(Val), - Octets = list_to_binary(OctetList), - Sz = byte_size(Octets), - [encode_length(Sz), - octets_to_complete(Sz, Octets)]. - -e_object_identifier({'OBJECT IDENTIFIER',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]]. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% encode_relative_oid(Val) -> CompleteList -%% encode_relative_oid({Name,Val}) -> CompleteList -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]), - Sz = byte_size(Octets), - [encode_length(Sz)|octets_to_complete(Sz, Octets)]. - %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% 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 asn1rt_nif:encode_per_complete(L) of +complete(L0) -> + L = complete(L0, []), + case list_to_bitstring(L) of <<>> -> <<0>>; Bin -> Bin end. -octets_to_complete(Len,Val) when Len < 256 -> - [20,Len,Val]; -octets_to_complete(Len,Val) -> - [21,<<Len:16>>,Val]. - -octets_unused_to_complete(Unused,Len,Val) when Len < 256 -> - [30,Unused,Len,Val]; -octets_unused_to_complete(Unused,Len,Val) -> - [31,Unused,<<Len:16>>,Val]. +complete([], []) -> + []; +complete([], [H|More]) -> + complete(H, More); +complete([align|T], More) -> + complete(T, More); +complete([[]|T], More) -> + complete(T, More); +complete([[_|_]=H], More) -> + complete(H, More); +complete([[_|_]=H|T], More) -> + complete(H, [T|More]); +complete([H|T], More) when is_integer(H); is_binary(H) -> + [H|complete(T, More)]; +complete([H|T], More) -> + [H|complete(T, bit_size(H), More)]; +complete(Bin, More) when is_binary(Bin) -> + [Bin|complete([], More)]; +complete(Bin, More) -> + [Bin|complete([], bit_size(Bin), More)]. + +complete([], Bits, []) -> + case Bits band 7 of + 0 -> []; + N -> [<<0:(8-N)>>] + end; +complete([], Bits, [H|More]) -> + complete(H, Bits, More); +complete([align|T], Bits, More) -> + case Bits band 7 of + 0 -> complete(T, More); + 1 -> [<<0:7>>|complete(T, More)]; + 2 -> [<<0:6>>|complete(T, More)]; + 3 -> [<<0:5>>|complete(T, More)]; + 4 -> [<<0:4>>|complete(T, More)]; + 5 -> [<<0:3>>|complete(T, More)]; + 6 -> [<<0:2>>|complete(T, More)]; + 7 -> [<<0:1>>|complete(T, More)] + end; +complete([[]|T], Bits, More) -> + complete(T, Bits, More); +complete([[_|_]=H], Bits, More) -> + complete(H, Bits, More); +complete([[_|_]=H|T], Bits, More) -> + complete(H, Bits, [T|More]); +complete([H|T], Bits, More) when is_integer(H); + is_binary(H) -> + [H|complete(T, Bits, More)]; +complete([H|T], Bits, More) -> + [H|complete(T, Bits+bit_size(H), More)]; +complete(Bin, Bits, More) when is_binary(Bin) -> + [Bin|complete([], Bits, More)]; +complete(Bin, Bits, More) -> + [Bin|complete([], Bits+bit_size(Bin), More)]. diff --git a/lib/asn1/src/asn1rtt_per_common.erl b/lib/asn1/src/asn1rtt_per_common.erl index e7edc2b65f..9e9fd87ec3 100644 --- a/lib/asn1/src/asn1rtt_per_common.erl +++ b/lib/asn1/src/asn1rtt_per_common.erl @@ -28,7 +28,16 @@ decode_chars/2,decode_chars/3, decode_chars_16bit/1, decode_big_chars/2, - decode_oid/1,decode_relative_oid/1]). + decode_oid/1,decode_relative_oid/1, + encode_chars/2,encode_chars/3, + encode_chars_16bit/1,encode_big_chars/1, + encode_fragmented/2, + encode_oid/1,encode_relative_oid/1, + encode_unconstrained_number/1, + bitstring_from_positions/1,bitstring_from_positions/2, + to_bitstring/1,to_bitstring/2, + to_named_bitstring/1,to_named_bitstring/2, + extension_bitmap/3]). -define('16K',16384). @@ -90,6 +99,182 @@ decode_oid(Octets) -> decode_relative_oid(Octets) -> list_to_tuple(dec_subidentifiers(Octets, 0, [])). +encode_chars(Val, NumBits) -> + << <<C:NumBits>> || C <- Val >>. + +encode_chars(Val, NumBits, {Lb,Tab}) -> + << <<(enc_char(C, Lb, Tab)):NumBits>> || C <- Val >>. + +encode_chars_16bit(Val) -> + L = [case C of + {0,0,A,B} -> [A,B]; + C when is_integer(C) -> [0,C] + end || C <- Val], + iolist_to_binary(L). + +encode_big_chars(Val) -> + L = [case C of + {_,_,_,_} -> tuple_to_list(C); + C when is_integer(C) -> [<<0,0,0>>,C] + end || C <- Val], + iolist_to_binary(L). + +encode_fragmented(Bin, Unit) -> + encode_fragmented_1(Bin, Unit, 4). + +encode_oid(Val) when is_tuple(Val) -> + encode_oid(tuple_to_list(Val)); +encode_oid(Val) -> + iolist_to_binary(e_object_identifier(Val)). + +encode_relative_oid(Val) when is_tuple(Val) -> + encode_relative_oid(tuple_to_list(Val)); +encode_relative_oid(Val) when is_list(Val) -> + list_to_binary([e_object_element(X)||X <- Val]). + +encode_unconstrained_number(Val) when Val >= 0 -> + if + Val < 16#80 -> + [1,Val]; + Val < 16#100 -> + [<<2,0>>,Val]; + true -> + case binary:encode_unsigned(Val) of + <<0:1,_/bitstring>>=Bin -> + case byte_size(Bin) of + Sz when Sz < 128 -> + [Sz,Bin]; + Sz when Sz < 16384 -> + [<<2:2,Sz:14>>,Bin] + end; + <<1:1,_/bitstring>>=Bin -> + case byte_size(Bin)+1 of + Sz when Sz < 128 -> + [Sz,0,Bin]; + Sz when Sz < 16384 -> + [<<2:2,Sz:14,0:8>>,Bin] + end + end + end; +encode_unconstrained_number(Val) -> + Oct = enint(Val, []), + Len = length(Oct), + if + Len < 128 -> + [Len|Oct]; + Len < 16384 -> + [<<2:2,Len:14>>|Oct] + end. + +%% bitstring_from_positions([Position]) -> BitString +%% Given an unsorted list of bit positions (0..MAX), construct +%% a BIT STRING. The rightmost bit will always be a one. + +bitstring_from_positions([]) -> <<>>; +bitstring_from_positions([_|_]=L0) -> + L1 = lists:sort(L0), + L = diff(L1, -1), + << <<1:(N+0)>> || N <- L >>. + +%% bitstring_from_positions([Position], Lb) -> BitString +%% Given an unsorted list of bit positions (0..MAX) and a lower bound +%% for the number of bits, construct BIT STRING (zero-padded on the +%% right side if needed). + +bitstring_from_positions(L0, Lb) -> + L1 = lists:sort(L0), + L = diff(L1, -1, Lb-1), + << <<B:(N+0)>> || {B,N} <- L >>. + +%% to_bitstring(Val) -> BitString +%% Val = BitString | {Unused,Binary} | [OneOrZero] | Integer +%% Given one of the possible representations for a BIT STRING, +%% return a bitstring (without adding or removing any zero bits +%% at the right end). + +to_bitstring({0,Bs}) when is_binary(Bs) -> + Bs; +to_bitstring({Unused,Bs0}) when is_binary(Bs0) -> + Sz = bit_size(Bs0) - Unused, + <<Bs:Sz/bits,_/bits>> = Bs0, + Bs; +to_bitstring(Bs) when is_bitstring(Bs) -> + Bs; +to_bitstring(Int) when is_integer(Int), Int >= 0 -> + L = int_to_bitlist(Int), + << <<B:1>> || B <- L >>; +to_bitstring(L) when is_list(L) -> + << <<B:1>> || B <- L >>. + +%% to_bitstring(Val, Lb) -> BitString +%% Val = BitString | {Unused,Binary} | [OneOrZero] | Integer +%% Lb = Integer +%% Given one of the possible representations for a BIT STRING +%% and the lower bound for the number of bits, +%% return a bitstring at least Lb bits long (padded with zeroes +%% if needed). + +to_bitstring({0,Bs}, Lb) when is_binary(Bs) -> + case bit_size(Bs) of + Sz when Sz < Lb -> + <<Bs/bits,0:(Lb-Sz)>>; + _ -> + Bs + end; +to_bitstring({Unused,Bs0}, Lb) when is_binary(Bs0) -> + Sz = bit_size(Bs0) - Unused, + if + Sz < Lb -> + <<Bs0:Sz/bits,0:(Lb-Sz)>>; + true -> + <<Bs:Sz/bits,_/bits>> = Bs0, + Bs + end; +to_bitstring(Bs, Lb) when is_bitstring(Bs) -> + adjust_size(Bs, Lb); +to_bitstring(Int, Lb) when is_integer(Int), Int >= 0 -> + L = int_to_bitlist(Int), + Bs = << <<B:1>> || B <- L >>, + adjust_size(Bs, Lb); +to_bitstring(L, Lb) when is_list(L) -> + Bs = << <<B:1>> || B <- L >>, + adjust_size(Bs, Lb). + +%% to_named_bitstring(Val) -> BitString +%% Val = BitString | {Unused,Binary} | [OneOrZero] | Integer +%% Given one of the possible representations for a BIT STRING, +%% return a bitstring where any trailing zeroes have been stripped. + +to_named_bitstring(Val) -> + Bs = to_bitstring(Val), + bs_drop_trailing_zeroes(Bs). + +%% to_named_bitstring(Val, Lb) -> BitString +%% Val = BitString | {Unused,Binary} | [OneOrZero] | Integer +%% Lb = Integer +%% Given one of the possible representations for a BIT STRING +%% and the lower bound for the number of bits, +%% return a bitstring that is at least Lb bits long. There will +%% be zeroes at the right only if needed to reach the lower bound +%% for the number of bits. + +to_named_bitstring({0,Bs}, Lb) when is_binary(Bs) -> + adjust_trailing_zeroes(Bs, Lb); +to_named_bitstring({Unused,Bs0}, Lb) when is_binary(Bs0) -> + Sz = bit_size(Bs0) - Unused, + <<Bs:Sz/bits,_/bits>> = Bs0, + adjust_trailing_zeroes(Bs, Lb); +to_named_bitstring(Bs, Lb) when is_bitstring(Bs) -> + adjust_trailing_zeroes(Bs, Lb); +to_named_bitstring(Val, Lb) -> + %% Obsolete representations: list or integer. Optimize + %% for correctness, not speed. + adjust_trailing_zeroes(to_bitstring(Val), Lb). + + +extension_bitmap(Val, Pos, Limit) -> + extension_bitmap(Val, Pos, Limit, 0). + %%% %%% Internal functions. %%% @@ -124,3 +309,149 @@ dec_subidentifiers([H|T], Av, Al) -> dec_subidentifiers(T, 0, [(Av bsl 7) bor H|Al]); dec_subidentifiers([], _Av, Al) -> lists:reverse(Al). + +enc_char(C0, Lb, Tab) -> + try element(C0-Lb, Tab) of + ill -> + illegal_char_error(); + C -> + C + catch + error:badarg -> + illegal_char_error() + end. + +illegal_char_error() -> + error({error,{asn1,"value forbidden by FROM constraint"}}). + +encode_fragmented_1(Bin, Unit, N) -> + SegSz = Unit * N * ?'16K', + case Bin of + <<B:SegSz/bitstring,T/bitstring>> -> + [<<3:2,N:6>>,B|encode_fragmented_1(T, Unit, N)]; + _ when N > 1 -> + encode_fragmented_1(Bin, Unit, N-1); + _ -> + case bit_size(Bin) div Unit of + Len when Len < 128 -> + [Len,Bin]; + Len when Len < 16384 -> + [<<2:2,Len:14>>,Bin] + end + end. + +%% 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, + e_object_elements([Head|Tail], []); +e_object_identifier([_,_|_Tail]=Oid) -> + 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]]. + +enint(-1, [B1|T]) when B1 > 127 -> + [B1|T]; +enint(N, Acc) -> + enint(N bsr 8, [N band 16#ff|Acc]). + +diff([H|T], Prev) -> + [H-Prev|diff(T, H)]; +diff([], _) -> []. + +diff([H|T], Prev, Last) -> + [{1,H-Prev}|diff(T, H, Last)]; +diff([], Prev, Last) when Last >= Prev -> + [{0,Last-Prev}]; +diff([], _, _) -> []. + +int_to_bitlist(0) -> []; +int_to_bitlist(Int) -> [Int band 1|int_to_bitlist(Int bsr 1)]. + +adjust_size(Bs, Lb) -> + case bit_size(Bs) of + Sz when Sz < Lb -> + <<Bs:Sz/bits,0:(Lb-Sz)>>; + _ -> + Bs + end. + +adjust_trailing_zeroes(Bs0, Lb) -> + case bit_size(Bs0) of + Sz when Sz < Lb -> + %% Too short - pad with zeroes. + <<Bs0:Sz/bits,0:(Lb-Sz)>>; + Lb -> + %% Exactly the right size - nothing to do. + Bs0; + _ -> + %% Longer than the lower bound - drop trailing zeroes. + <<_:Lb/bits,Tail/bits>> = Bs0, + Sz = Lb + bit_size(bs_drop_trailing_zeroes(Tail)), + <<Bs:Sz/bits,_/bits>> = Bs0, + Bs + end. + +bs_drop_trailing_zeroes(Bs) -> + bs_drop_trailing_zeroes(Bs, bit_size(Bs)). + +bs_drop_trailing_zeroes(Bs0, Sz0) when Sz0 < 8 -> + <<Byte:Sz0>> = Bs0, + Sz = Sz0 - ntz(Byte), + <<Bs:Sz/bits,_/bits>> = Bs0, + Bs; +bs_drop_trailing_zeroes(Bs0, Sz0) -> + Sz1 = Sz0 - 8, + <<Bs1:Sz1/bits,Byte:8>> = Bs0, + case ntz(Byte) of + 8 -> + bs_drop_trailing_zeroes(Bs1, Sz1); + Ntz -> + Sz = Sz0 - Ntz, + <<Bs:Sz/bits,_:Ntz/bits>> = Bs0, + Bs + end. + +%% ntz(Byte) -> Number of trailing zeroes. +ntz(Byte) -> + %% The table was calculated like this: + %% NTZ = fun (B, N, NTZ) when B band 1 =:= 0 -> NTZ(B bsr 1, N+1, NTZ); (_, N, _) -> N end. + %% io:format("~w\n", [list_to_tuple([NTZ(B+256, 0, NTZ) || B <- lists:seq(0, 255)])]). + T = {8,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0, + 4,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0, + 5,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0, + 4,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0, + 6,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0, + 4,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0, + 5,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0, + 4,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0, + 7,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0, + 4,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0, + 5,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0, + 4,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0, + 6,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0, + 4,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0, + 5,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0, + 4,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0}, + element(Byte+1, T). + +extension_bitmap(_Val, Pos, Limit, Acc) when Pos >= Limit -> + Acc; +extension_bitmap(Val, Pos, Limit, Acc) -> + Bit = case element(Pos, Val) of + asn1_NOVALUE -> 0; + _ -> 1 + end, + extension_bitmap(Val, Pos+1, Limit, (Acc bsl 1) bor Bit). diff --git a/lib/asn1/src/asn1rtt_real_common.erl b/lib/asn1/src/asn1rtt_real_common.erl index 22a1f4c4dd..12ca165ecd 100644 --- a/lib/asn1/src/asn1rtt_real_common.erl +++ b/lib/asn1/src/asn1rtt_real_common.erl @@ -105,8 +105,7 @@ encode_real(_C, {Mantissa, Base, Exponent}) when Base =:= 2 -> true -> list_to_binary(real_mininum_octets(-(Man))) % signbit keeps track of sign end, %% ok = io:format("LenMask: ~w EOctets: ~w~nFirstOctet: ~w OctMantissa: ~w OctExpLen: ~w~n", [LenMask, EOctets, FirstOctet, OctMantissa, OctExpLen]), - Bin = <<FirstOctet/binary, EOctets/binary, OctMantissa/binary>>, - {Bin, size(Bin)}; + <<FirstOctet/binary, EOctets/binary, OctMantissa/binary>>; 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 @@ -176,8 +175,7 @@ encode_real_as_string(_C, Mantissa, Exponent) end, ManBin = list_to_binary(TruncMant), NR3 = 3, - {<<NR3,ManBin/binary,$.,ExpBin/binary>>, - 2 + byte_size(ManBin) + byte_size(ExpBin)}. + <<NR3,ManBin/binary,$.,ExpBin/binary>>. remove_trailing_zeros(IntStr) -> case lists:dropwhile(fun($0)-> true; diff --git a/lib/asn1/src/asn1rtt_uper.erl b/lib/asn1/src/asn1rtt_uper.erl index a5035c6660..68a89c70e1 100644 --- a/lib/asn1/src/asn1rtt_uper.erl +++ b/lib/asn1/src/asn1rtt_uper.erl @@ -19,95 +19,8 @@ %% -module(asn1rtt_uper). --export([setext/1, fixoptionals/3, - fixextensions/2, - skipextensions/3]). --export([set_choice/3, encode_integer/2, encode_integer/3]). --export([encode_small_number/1, encode_constrained_number/2, - encode_boolean/1, - encode_length/1, encode_length/2, - encode_bit_string/3]). --export([encode_octet_string/1,encode_octet_string/2, - encode_relative_oid/1, - encode_object_identifier/1, - complete/1, complete_NFP/1]). - - -export([encode_open_type/1]). - - -export([encode_UniversalString/3, - encode_PrintableString/3, - encode_GeneralString/2, - encode_GraphicString/2, - encode_TeletexString/2, - encode_VideotexString/2, - encode_VisibleString/3, - encode_UTF8String/1, - encode_BMPString/3, - encode_IA5String/3, - encode_NumericString/3, - encode_ObjectDescriptor/2 - ]). - --define('16K',16384). --define('32K',32768). --define('64K',65536). - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% 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,<<Bits:OptLength>>}; - -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. - - -fixextensions({ext,ExtPos,ExtNum},Val) -> - case fixextensions(ExtPos,ExtNum+ExtPos,Val,0) of - 0 -> []; - ExtBits -> - [encode_small_length(ExtNum),<<ExtBits: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). +-export([skipextensions/3]). +-export([complete/1, complete_NFP/1]). skipextensions(Bytes0, Nr, ExtensionBitstr) when is_bitstring(ExtensionBitstr) -> Prev = Nr - 1, @@ -122,249 +35,6 @@ skipextensions(Bytes0, Nr, ExtensionBitstr) when is_bitstring(ExtensionBitstr) - Bytes0 end. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% 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. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% 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(Val) -> - [encode_length(byte_size(Val)),Val]. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% 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:keyfind(V, 1, NamedNumberList) of - {_,NewV} -> - encode_integer(C, NewV); - false -> - exit({error,{asn1,{namednumber,V}}}) - end; -encode_integer(C, V, _NamedNumberList) when is_integer(V) -> - encode_integer(C, V). - -encode_integer([{Rc,_Ec}],Val) when is_tuple(Rc) -> - try - [<<0:1>>,encode_integer([Rc], Val)] - catch - _:{error,{asn1,_}} -> - [<<1:1>>,encode_unconstrained_number(Val)] - 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'} when Lb =< Val -> - 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. - -%% 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(Val) when Val < 64 -> - <<Val:7>>; -encode_small_number(Val) -> - [<<1:1>>|encode_semi_constrained_number(0, Val)]. - -%% X.691:10.7 Encoding of a semi-constrained whole number -encode_semi_constrained_number(Lb, Val) -> - %% encoding in minimum number of octets preceeded by a length - Val2 = Val - Lb, - Bin = eint_bin_positive(Val2), - Size = byte_size(Bin), - if - Size < 128 -> - [<<Size>>,Bin]; - Size < 16384 -> - [<<2:2,Size:14>>,Bin]; - true -> - [encode_length(Size),Bin] - end. - -encode_constrained_number({Lb,Ub}, Val) when Val >= Lb, Ub >= Val -> - Range = Ub - Lb + 1, - Val2 = Val - Lb, - NumBits = num_bits(Range), - <<Val2:NumBits>>; -encode_constrained_number(Range,Val) -> - exit({error,{asn1,{integer_range,Range,value,Val}}}). - -%% X.691:10.8 Encoding of an unconstrained whole number - -encode_unconstrained_number(Val) when Val >= 0 -> - Oct = eint_bin_2Cs(Val), - Len = byte_size(Oct), - if - Len < 128 -> - [<<Len>>,Oct]; % equiv with encode_length(undefined,Len) but faster - Len < 16384 -> - [<<2:2,Len:14>>,Oct]; - true -> - [encode_length(Len),<<Len:16>>,Oct] - end; -encode_unconstrained_number(Val) -> % negative - Oct = enint(Val,[]), - Len = byte_size(Oct), - if - Len < 128 -> - [<<Len>>,Oct]; % equiv with encode_length(undefined,Len) but faster - Len < 16384 -> - [<<2:2,Len:14>>,Oct]; - true -> - [encode_length(Len),Oct] - end. - - -eint_bin_2Cs(Int) -> - case eint_bin_positive(Int) of - <<B,_/binary>> = 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 -> - <<Val>>; -eint_bin_positive(Val) when Val < 16#10000 -> - <<Val:16>>; -eint_bin_positive(Val) when Val < 16#1000000 -> - <<Val:24>>; -eint_bin_positive(Val) when Val < 16#100000000 -> - <<Val:32>>; -eint_bin_positive(Val) -> - list_to_binary([eint_bin_positive2(Val bsr 32),<<Val:32>>]). - -eint_bin_positive2(Val) when Val < 16#100 -> - <<Val>>; -eint_bin_positive2(Val) when Val < 16#10000 -> - <<Val:16>>; -eint_bin_positive2(Val) when Val < 16#1000000 -> - <<Val:24>>; -eint_bin_positive2(Val) when Val < 16#100000000 -> - <<Val:32>>; -eint_bin_positive2(Val) -> - [eint_bin_positive2(Val bsr 32),<<Val: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]). - - -%% 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(Len) -> % un-constrained - if - Len < 128 -> - <<Len>>; - Len < 16384 -> - <<2:2,Len:14>>; - true -> % should be able to endode length >= 16384 - error({error,{asn1,{encode_length,{nyi,above_16k}}}}) - end. - -encode_length({C,[]}, Len) -> - case C of - {Lb,Ub}=Vr when Lb =< Len, Len =< Ub -> - [<<0:1>>|encode_constrained_number(Vr, Len)]; - _ -> - [<<1:1>>|encode_length(Len)] - end; -encode_length(Len, Len) -> - []; -encode_length(Vr, Len) -> - encode_constrained_number(Vr, Len). - - -%% 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(Len)]. - - %% un-constrained decode_length(<<0:1,Oct:7,Rest/bitstring>>) -> {Oct,Rest}; @@ -373,575 +43,20 @@ decode_length(<<2:2,Val:14,Rest/bitstring>>) -> decode_length(<<3:2,_:14,_Rest/bitstring>>) -> exit({error,{asn1,{decode_length,{nyi,above_16k}}}}). - % X.691:11 -encode_boolean(true) -> - <<1:1>>; -encode_boolean(false) -> - <<0:1>>; -encode_boolean(Val) -> - exit({error,{asn1,{encode_boolean,Val}}}). - - -%%============================================================================ -%%============================================================================ -%% 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 are present - - -%% when the value is a list of {Unused,BinBits}, where -%% Unused = integer(), -%% BinBits = binary(). - -encode_bit_string(C, Bits, NamedBitList) when is_bitstring(Bits) -> - PadLen = (8 - (bit_size(Bits) band 7)) band 7, - Compact = {PadLen,<<Bits/bitstring,0:PadLen>>}, - encode_bit_string(C, Compact, NamedBitList); -encode_bit_string(C, {Unused,BinBits}=Bin, NamedBitList) - when is_integer(Unused), is_binary(BinBits) -> - encode_bin_bit_string(C, Bin, NamedBitList); - -encode_bit_string(C, BitListVal, NamedBitList) -> - encode_bit_string1(C, BitListVal, NamedBitList). - -%% when the value is a list of named bits -encode_bit_string1(C, [FirstVal|_RestVal]=LoNB, 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, [{bit,_No}|_RestVal]=BL, 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(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) -> - NewBitLVal = lists:reverse(lists:dropwhile(fun(0)->true;(1)->false end, - lists:reverse(BitListValue))), - Len = length(NewBitLVal), - [encode_length(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). - -bit_list2bitstr(Len,BitListValue) -> - case length(BitListValue) of - Len -> - << <<B:1>> || B <- BitListValue>>; - L when L > Len -> % truncate - <<(<< <<B:1>> || B <- BitListValue>>):Len/bitstring>>; - L -> % Len > L -> pad - <<(<< <<B:1>> || 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) -> - <<Bin/bitstring,0:(Len-bit_size(Bin))>>; -adjust_trailing_zeros(Len,Bin) -> - <<Bin:Len/bitstring>>. - -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 < Lb -> 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(bit_size(BitStr)),BitStr]; - Sc -> - [encode_length(Sc,bit_size(BitStr)),BitStr] - end. - - -remove_trailing_bin([], {Unused,Bin}) -> - BS = bit_size(Bin)-Unused, - <<BitStr:BS/bitstring,_:Unused>> = Bin, - BitStr; -remove_trailing_bin(_NamedNumberList, {_Unused,<<>>}) -> - <<>>; -remove_trailing_bin(NamedNumberList, {_Unused,Bin}) -> - Size = byte_size(Bin)-1, - <<Bfront:Size/binary, LastByte:8>> = 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, - <<BitStr:BS/bitstring,_: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. - - -%%%%%%%%%%%%%%% -%% - -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:keyfind(Val, 1, NamedBitList) of - {_ValName, ValPos} -> - get_all_bitposes(Rest, NamedBitList, [ValPos | Ack]); - false -> - 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(Val) -%% encode_octet_string(Constraint, Val) -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -encode_octet_string(Val) -> - try - [encode_length(length(Val)),list_to_binary(Val)] - catch - error:{error,{asn1,{encode_length,_}}} -> - encode_fragmented_octet_string(Val) - end. - -encode_octet_string(C, Val) -> - case C of - {_,_}=VR -> - try - [encode_length(VR, length(Val)),list_to_binary(Val)] - catch - error:{error,{asn1,{encode_length,_}}} -> - encode_fragmented_octet_string(Val) - end; - Sv when is_integer(Sv), Sv =:= length(Val) -> % fixed length - list_to_binary(Val) - end. - - -encode_fragmented_octet_string(Val) -> - Bin = list_to_binary(Val), - efos_1(Bin). - -efos_1(<<B:16#10000/binary,T/binary>>) -> - [<<3:2,4:6>>,B|efos_1(T)]; -efos_1(<<B:16#C000/binary,T/binary>>) -> - [<<3:2,3:6>>,B|efos_1(T)]; -efos_1(<<B:16#8000/binary,T/binary>>) -> - [<<3:2,2:6>>,B|efos_1(T)]; -efos_1(<<B:16#4000/binary,T/binary>>) -> - [<<3:2,1:6>>,B|efos_1(T)]; -efos_1(<<B/bitstring>>) -> - Len = byte_size(B), - [encode_length(Len),B]. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% 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(Val) when is_list(Val)-> - [encode_length(length(Val)),list_to_binary(Val)]. - -encode_known_multiplier_string(StringType, C, Pa, Val) -> - Result = chars_encode(Pa, StringType, Val), - case C of - Ub when is_integer(Ub) -> - Result; - {_,_}=Range -> - [encode_length(Range, length(Val)),Result]; - no -> - [encode_length(length(Val)),Result] - end. - -encode_NumericString(C, Pa, Val) -> - encode_known_multiplier_string('NumericString', C, Pa, Val). - -encode_PrintableString(C, Pa, Val) -> - encode_known_multiplier_string('PrintableString', C, Pa, Val). - -encode_VisibleString(C, Pa, Val) -> % equivalent with ISO646String - encode_known_multiplier_string('VisibleString', C, Pa, Val). - -encode_IA5String(C, Pa, Val) -> - encode_known_multiplier_string('IA5String', C, Pa, Val). - -encode_BMPString(C, Pa, Val) -> - encode_known_multiplier_string('BMPString', C, Pa, Val). - -encode_UniversalString(C, Pa, Val) -> - encode_known_multiplier_string('UniversalString', C, Pa, Val). - - -%% end of known-multiplier strings for which PER visible constraints are -%% applied - -encode_GeneralString(_C,Val) -> - encode_restricted_string(Val). - -encode_GraphicString(_C,Val) -> - encode_restricted_string(Val). - -encode_ObjectDescriptor(_C,Val) -> - encode_restricted_string(Val). - -encode_TeletexString(_C,Val) -> % equivalent with T61String - encode_restricted_string(Val). - -encode_VideotexString(_C,Val) -> - encode_restricted_string(Val). - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% 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(Pa, StringType, Value) -> - case {StringType,Pa} 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(Pa, StringType), - get_CharOutTab(Pa, StringType)}, - chars_encode2(Value,NumBits,CharOutTab) - end. - -chars_encode2([H|T],NumBits,{Min,Max,notab}) when H =< Max, H >= Min -> - [<<(H-Min):NumBits>>|chars_encode2(T,NumBits,{Min,Max,notab})]; -chars_encode2([H|T],NumBits,{Min,Max,Tab}) when H =< Max, H >= Min -> - Ch = exit_if_false(H,element(H-Min+1,Tab)), - [<<Ch:NumBits>>|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) - Ch = ((((((A bsl 8)+B) bsl 8)+C) bsl 8)+D)-Min, - [<<Ch:NumBits>>|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) - Ch = exit_if_false({A,B,C,D},element(((((((A bsl 8)+B) bsl 8)+C) bsl 8)+D)-Min,Tab)), - [<<Ch:NumBits>>|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(Pa, StringType) -> - case Pa 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(Pa, StringType) -> - case Pa of - {'SingleValue',Sv} -> - get_CharTab2(Pa, StringType, hd(Sv), lists:max(Sv), Sv); - no -> - case StringType of - 'IA5String' -> - {0,16#7F,notab}; - 'VisibleString' -> - get_CharTab2(Pa, StringType, 16#20, 16#7F, notab); - 'PrintableString' -> - Chars = lists:sort( - " '()+,-./0123456789:=?ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"), - get_CharTab2(Pa, StringType, hd(Chars), - lists:max(Chars), Chars); - 'NumericString' -> - get_CharTab2(Pa, StringType, 16#20, $9, " 0123456789"); - 'UniversalString' -> - {0,16#FFFFFFFF,notab}; - 'BMPString' -> - {0,16#FFFF,notab} - end - end. - -get_CharTab2(C,StringType,Min,Max,Chars) -> - BitValMax = (1 bsl get_NumBits(C,StringType))-1, - if - Max =< BitValMax -> - {0,Max,notab}; - true -> - {Min,Max,create_char_tab(Min,Chars)} - 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). - - -%% UTF8String -encode_UTF8String(Val) when is_binary(Val) -> - [encode_length(byte_size(Val)),Val]; -encode_UTF8String(Val) -> - Bin = list_to_binary(Val), - encode_UTF8String(Bin). - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% 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(Val) -> - OctetList = e_object_identifier(Val), - Octets = list_to_binary(OctetList), % performs a flatten at the same time - [encode_length(byte_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(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]]. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% encode_relative_oid(Val) -> CompleteList -%% encode_relative_oid({Name,Val}) -> CompleteList -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(byte_size(Octets)),Octets]. - - -get_constraint([{Key,V}],Key) -> - V; -get_constraint([],_Key) -> - no; -get_constraint(C,Key) -> - case lists:keyfind(Key, 1, C) of - false -> - no; - {_,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 + case list_to_bitstring(InList) of <<>> -> <<0>>; Res -> - case bit_size(Res) band 7 of + Sz = bit_size(Res), + case Sz band 7 of 0 -> Res; - Bits -> <<Res/bitstring,0:(8-Bits)>> + Bits -> <<Res:Sz/bitstring,0:(8-Bits)>> end end; complete(Bin) when is_binary(Bin) -> @@ -950,24 +65,12 @@ complete(Bin) when is_binary(Bin) -> _ -> Bin end; complete(InList) when is_bitstring(InList) -> - PadLen = 8 - (bit_size(InList) band 7), - <<InList/bitstring,0:PadLen>>. - -complete1(L) when is_list(L) -> - list_to_bitstring(L). + Sz = bit_size(InList), + PadLen = 8 - (Sz band 7), + <<InList:Sz/bitstring,0:PadLen>>. %% 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(N) -> num_bits(N, 1, 0). - -num_bits(N,T,B) when N =< T -> B; -num_bits(N,T,B) -> num_bits(N, T bsl 1, B+1). diff --git a/lib/asn1/test/Makefile b/lib/asn1/test/Makefile index 15b97df972..a3fa4f2968 100644 --- a/lib/asn1/test/Makefile +++ b/lib/asn1/test/Makefile @@ -82,6 +82,7 @@ MODULES= \ testInfObjectClass \ testInfObj \ testParameterizedInfObj \ + testFragmented \ testMergeCompile \ testMultipleLevels \ testDeepTConstr \ diff --git a/lib/asn1/test/asn1_SUITE.erl b/lib/asn1/test/asn1_SUITE.erl index f00b23a8b2..9a149a495a 100644 --- a/lib/asn1/test/asn1_SUITE.erl +++ b/lib/asn1/test/asn1_SUITE.erl @@ -150,6 +150,7 @@ groups() -> per_open_type, testInfObjectClass, testParameterizedInfObj, + testFragmented, testMergeCompile, testobj, testDeepTConstr, @@ -186,8 +187,7 @@ groups() -> {performance, [], [testTimer_ber, testTimer_per, - testTimer_uper, - smp]}]. + testTimer_uper]}]. parallel(Options) -> case erlang:system_info(smp_support) andalso @@ -360,7 +360,8 @@ testPrimStrings_cases(Rule) -> testPrimStrings:universal_string(Rule), testPrimStrings:bmp_string(Rule), testPrimStrings:times(Rule), - testPrimStrings:utf8_string(Rule). + testPrimStrings:utf8_string(Rule), + testPrimStrings:fragmented(Rule). testPrimExternal(Config) -> test(Config, fun testPrimExternal/3). testPrimExternal(Config, Rule, Opts) -> @@ -452,7 +453,7 @@ testSeqDefault(Config, Rule, Opts) -> asn1_test_lib:compile("SeqDefault", Config, [Rule|Opts]), testSeqDefault:main(Rule). -testSeqExtension(Config) -> test(Config, fun testSeqExtension/3). +testSeqExtension(Config) -> test(Config, fun testSeqExtension/3, [ber,uper]). testSeqExtension(Config, Rule, Opts) -> asn1_test_lib:compile_all(["External", "SeqExtension", @@ -830,6 +831,12 @@ testParameterizedInfObj(Config, Rule, Opts) -> asn1_test_lib:compile_all(Files, Config, [Rule|Opts]), testParameterizedInfObj:main(Config, Rule). +testFragmented(Config) -> + test(Config, fun testFragmented/3). +testFragmented(Config, Rule, Opts) -> + asn1_test_lib:compile("Fragmented", Config, [Rule|Opts]), + testFragmented:main(Rule). + testMergeCompile(Config) -> test(Config, fun testMergeCompile/3). testMergeCompile(Config, Rule, Opts) -> Files = ["MS.set.asn", "RANAPSET.set.asn1", "Mvrasn4.set.asn", @@ -1230,70 +1237,6 @@ ticket_7407(Config) -> [uper, no_final_padding]), asn1_test_lib:ticket_7407_code(false). -smp(suite) -> []; -smp(Config) -> - case erlang:system_info(smp_support) of - true -> - NumOfProcs = erlang:system_info(schedulers), - io:format("smp starting ~p workers\n",[NumOfProcs]), - - Msg = {initiatingMessage, testNBAPsystem:cell_setup_req_msg()}, - ok = testNBAPsystem:compile(Config, [per]), - - enc_dec(NumOfProcs,Msg,2), - - N = 10000, - - {Time1,ok} = timer:tc(?MODULE,enc_dec,[NumOfProcs,Msg, N]), - {Time1S,ok} = timer:tc(?MODULE,enc_dec,[1, Msg, NumOfProcs * N]), - - ok = testNBAPsystem:compile(Config, [ber]), - {Time3,ok} = timer:tc(?MODULE,enc_dec,[NumOfProcs,Msg, N]), - - {Time3S,ok} = timer:tc(?MODULE,enc_dec,[1, Msg, NumOfProcs * N]), - - {comment,lists:flatten( - io_lib:format( - "Encode/decode time parallell with ~p cores: ~p [microsecs]~n" - "Encode/decode time sequential: ~p [microsecs]", - [NumOfProcs,Time1+Time3,Time1S+Time3S]))}; - false -> - {skipped,"No smp support"} - end. - -enc_dec(1, Msg, N) -> - worker_loop(N, Msg); -enc_dec(NumOfProcs,Msg, N) -> - pforeach(fun(_) -> - worker_loop(N, Msg) - end, [I || I <- lists:seq(1,NumOfProcs)]). - -worker_loop(0, _Msg) -> - ok; -worker_loop(N, Msg) -> - {ok,B}=asn1_wrapper:encode('NBAP-PDU-Discriptions', - 'NBAP-PDU', - Msg), - {ok,_Msg}=asn1_wrapper:decode('NBAP-PDU-Discriptions', - 'NBAP-PDU', - B), - worker_loop(N - 1, Msg). - - -pforeach(Fun, List) -> - pforeach(Fun, List, []). -pforeach(Fun, [], [{Pid,Ref}|Pids]) -> - receive - {'DOWN', Ref, process, Pid, normal} -> - pforeach(Fun, [], Pids) - end; -pforeach(Fun, [H|T], Pids) -> - Pid = spawn(fun() -> Fun(H) end), - Ref = erlang:monitor(process, Pid), - pforeach(Fun, T, [{Pid, Ref}|Pids]); -pforeach(_Fun,[],[]) -> - ok. - -record('InitiatingMessage',{procedureCode,criticality,value}). -record('Iu-ReleaseCommand',{first,second}). diff --git a/lib/asn1/test/asn1_SUITE_data/Fragmented.asn1 b/lib/asn1/test/asn1_SUITE_data/Fragmented.asn1 new file mode 100644 index 0000000000..bfc939737f --- /dev/null +++ b/lib/asn1/test/asn1_SUITE_data/Fragmented.asn1 @@ -0,0 +1,24 @@ +Fragmented DEFINITIONS AUTOMATIC TAGS ::= +BEGIN + +FUNCTION ::= CLASS { + &code INTEGER UNIQUE, + &b BOOLEAN, + &ArgumentType +} + +SS ::= SEQUENCE OF OCTET STRING + +val1 FUNCTION ::= { + &code 1, &b FALSE, &ArgumentType SS +} + +ObjSet FUNCTION ::= { val1 } + +PDU ::= SEQUENCE { + code FUNCTION.&code ({ObjSet}), + b FUNCTION.&b ({ObjSet}{@code}), + arg FUNCTION.&ArgumentType ({ObjSet}{@code}) +} + +END diff --git a/lib/asn1/test/asn1_SUITE_data/InfObj.asn b/lib/asn1/test/asn1_SUITE_data/InfObj.asn index 53e5043cb7..880e81c3b1 100644 --- a/lib/asn1/test/asn1_SUITE_data/InfObj.asn +++ b/lib/asn1/test/asn1_SUITE_data/InfObj.asn @@ -202,7 +202,11 @@ constructed2 CONSTRUCTED-DEFAULT ::= { &id 2, &ok false } ConstructedDefaultSet CONSTRUCTED-DEFAULT ::= { constructed1 | constructed2 | - { &id 3, &Type BOOLEAN } + { &id 3, &Type BOOLEAN } | + { &id 4, &Type SET { a INTEGER, b BIT STRING } } | + { &id 5, &Type CHOICE { i INTEGER, b BIT STRING } } | + { &id 6, &Type SEQUENCE OF INTEGER (1..16) } | + { &id 7, &Type SET OF INTEGER (1..64) } } ConstructedPdu ::= SEQUENCE { @@ -210,6 +214,47 @@ ConstructedPdu ::= SEQUENCE { content CONSTRUCTED-DEFAULT.&Type ({ConstructedDefaultSet}{@id}) } +ConstructedSet ::= SET { + id [0] CONSTRUCTED-DEFAULT.&id ({ConstructedDefaultSet}), + content [1] CONSTRUCTED-DEFAULT.&Type ({ConstructedDefaultSet}{@id}) +} + +-- Test OPTIONAL and DEFAULT + +OptionalInSeq ::= SEQUENCE { + id CONSTRUCTED-DEFAULT.&id ({ConstructedDefaultSet}), + content CONSTRUCTED-DEFAULT.&Type ({ConstructedDefaultSet}{@id}) OPTIONAL +} + +DefaultInSeq ::= SEQUENCE { + id CONSTRUCTED-DEFAULT.&id ({ConstructedDefaultSet}), + content CONSTRUCTED-DEFAULT.&Type ({ConstructedDefaultSet}{@id}) + DEFAULT BOOLEAN:TRUE +} + +-- Test more than one optional typefield table constraint in a SEQUENCE. + +MULTIPLE-OPTIONALS ::= CLASS { + &id INTEGER UNIQUE, + &T1, + &T2, + &T3 +} + +multiple-optionals-1 MULTIPLE-OPTIONALS ::= + {&id 1, &T1 INTEGER, &T2 BOOLEAN, &T3 OCTET STRING} + +Multiple-Optionals-Set MULTIPLE-OPTIONALS ::= { + multiple-optionals-1 +} + +Multiple-Optionals ::= SEQUENCE { + id MULTIPLE-OPTIONALS.&id ({Multiple-Optionals-Set}), + t1 [0] MULTIPLE-OPTIONALS.&T1 ({Multiple-Optionals-Set}{@id}) OPTIONAL, + t2 [1] MULTIPLE-OPTIONALS.&T2 ({Multiple-Optionals-Set}{@id}) OPTIONAL, + t3 [2] MULTIPLE-OPTIONALS.&T3 ({Multiple-Optionals-Set}{@id}) OPTIONAL +} + END diff --git a/lib/asn1/test/asn1_SUITE_data/Param.asn1 b/lib/asn1/test/asn1_SUITE_data/Param.asn1 index b2987a7885..4eff0da781 100644 --- a/lib/asn1/test/asn1_SUITE_data/Param.asn1 +++ b/lib/asn1/test/asn1_SUITE_data/Param.asn1 @@ -88,6 +88,28 @@ POS2 {CONFIG-DATA:obj} ::= OCTET STRING (SIZE(obj.&minLevel .. obj.&maxLevel)) OS2 ::= POS2 {config-data} +-- +-- Test a CLASS without the user-friendly syntax. +-- + +CL ::= CLASS { + &code INTEGER UNIQUE, + &Data +} + +P{T} ::= CHOICE { a INTEGER, b T } + +o1 CL ::= { + &code 42, + &Data P{BOOLEAN} +} + +SetCL CL ::= { o1 } + +Scl ::= SEQUENCE { + code CL.&code ({SetCL}), + data CL.&Data ({SetCL}{@code}) +} END diff --git a/lib/asn1/test/asn1_SUITE_data/SeqOf.asn1 b/lib/asn1/test/asn1_SUITE_data/SeqOf.asn1 index 888dbe5dd7..670f827f5e 100644 --- a/lib/asn1/test/asn1_SUITE_data/SeqOf.asn1 +++ b/lib/asn1/test/asn1_SUITE_data/SeqOf.asn1 @@ -31,7 +31,43 @@ Seq4 ::= SEQUENCE seq43 [43] SEQUENCE OF SeqIn DEFAULT {} } +Seq5 ::= SEQUENCE { + b BOOLEAN, + s SEQUENCE SIZE (0..3) OF OCTET STRING (SIZE (0..3)), + -- If 's' is empty, 'magic' should not be aligned. + magic INTEGER (0..127) +} + +Seq6 ::= SEQUENCE { + a SEQUENCE OF INTEGER (0..7), + b SEQUENCE (SIZE (0..7)) OF INTEGER (0..7), + -- 'magic' should never be aligned. + magic INTEGER (0..127) +} +Seq7 ::= SEQUENCE { + a SEQUENCE OF INTEGER (1..512), + b SEQUENCE (SIZE (0..255)) OF INTEGER (1..512), + i INTEGER +} + +Seq8 ::= SEQUENCE { + sof SEQUENCE (SIZE (0..3)) OF OCTET STRING (SIZE (3)), + -- Not aligned here if the size of 'sof' is zero. + i INTEGER (0..127) +} + +Seq9 ::= SEQUENCE { + b BOOLEAN, + s SEQUENCE SIZE (0..3) OF OCTET STRING (SIZE (0..3)), + magic INTEGER (0..127) +} + +Seq10 ::= SEQUENCE { + b BOOLEAN, + s SEQUENCE SIZE (1..3) OF OCTET STRING (SIZE (0..3)), + magic INTEGER (0..127) +} SeqIn ::= SEQUENCE { @@ -50,9 +86,6 @@ SeqCho ::= SEQUENCE OF CHOICE {bool BOOLEAN, SeqOfInt ::= SEQUENCE OF INTEGER - - - SeqEmp ::= SEQUENCE { seq1 SEQUENCE OF Empty DEFAULT {} diff --git a/lib/asn1/test/asn1_SUITE_data/TConstr.asn1 b/lib/asn1/test/asn1_SUITE_data/TConstr.asn1 index e2e0a11dc4..b2b2de2f56 100644 --- a/lib/asn1/test/asn1_SUITE_data/TConstr.asn1 +++ b/lib/asn1/test/asn1_SUITE_data/TConstr.asn1 @@ -58,6 +58,40 @@ Deeper ::= SEQUENCE { b SEQUENCE {ba INTEGER, bb MYCLASS.&Type ({ObjectSet}{@a.s.ab})} } +Seq3 ::= SEQUENCE { + a SEQUENCE { + aa INTEGER, + ab MYCLASS.&id ({ObjectSet}) + }, + -- Multiple references from the same SEQUENCE... + b SEQUENCE { + ba MYCLASS.&Type ({ObjectSet}{@a.ab}), + bb MYCLASS.&Result ({ObjectSet}{@a.ab}), + -- ... and references from multiple SEQUENCEs... + bc SEQUENCE { + bca MYCLASS.&Result ({ObjectSet}{@a.ab}), + bcb MYCLASS.&Type ({ObjectSet}{@a.ab}) + } + } +} + +Seq3-Opt ::= SEQUENCE { + a SEQUENCE { + aa INTEGER, + ab MYCLASS.&id ({ObjectSet}) + }, + -- Multiple references from the same SEQUENCE... + b SEQUENCE { + ba MYCLASS.&Type ({ObjectSet}{@a.ab}) OPTIONAL, + bb MYCLASS.&Result ({ObjectSet}{@a.ab}) OPTIONAL, + -- ... and references from multiple SEQUENCEs... + bc SEQUENCE { + bca MYCLASS.&Result ({ObjectSet}{@a.ab}), + bcb MYCLASS.&Type ({ObjectSet}{@a.ab}) + } OPTIONAL + } +} + -- following from Peter's definitions diff --git a/lib/asn1/test/error_SUITE.erl b/lib/asn1/test/error_SUITE.erl index a94a6d95a0..6451f81c01 100644 --- a/lib/asn1/test/error_SUITE.erl +++ b/lib/asn1/test/error_SUITE.erl @@ -19,7 +19,7 @@ -module(error_SUITE). -export([suite/0,all/0,groups/0, - already_defined/1,enumerated/1]). + already_defined/1,enumerated/1,objects/1]). -include_lib("test_server/include/test_server.hrl"). @@ -30,7 +30,8 @@ all() -> groups() -> [{p,parallel(),[already_defined, - enumerated]}]. + enumerated, + objects]}]. parallel() -> case erlang:system_info(schedulers) > 1 of @@ -95,6 +96,48 @@ enumerated(Config) -> } = run(P, Config), ok. +objects(Config) -> + M = 'Objects', + P = {M, + <<"Objects DEFINITIONS AUTOMATIC TAGS ::= BEGIN\n" + " obj1 CL ::= { &wrong 42 }\n" + " obj2 CL ::= { &wrong 1, &Wrong INTEGER }\n" + " obj3 CL ::= { &Data OCTET STRING }\n" + " obj4 SMALL ::= { &code 42 }\n" + " InvalidSet CL ::= { obj1 }\n" + + " CL ::= CLASS {\n" + " &code INTEGER UNIQUE,\n" + " &enum ENUMERATED { a, b, c},\n" + " &Data,\n" + " &object CL,\n" + " &Set CL,\n" + " &vartypevalue &Data,\n" + " &VarTypeValue &Data\n" + " }\n" + + " SMALL ::= CLASS {\n" + " &code INTEGER UNIQUE,\n" + " &i INTEGER\n" + " }\n" + "END\n">>}, + {error, + [ + {structured_error,{M,2},asn1ct_check, + {invalid_fields,[wrong],obj1}}, + {structured_error,{M,3},asn1ct_check, + {invalid_fields,['Wrong',wrong],obj2}}, + {structured_error,{M,4},asn1ct_check, + {missing_mandatory_fields,['Set','VarTypeValue',code, + enum,object,vartypevalue],obj3}}, + {structured_error,{M,5},asn1ct_check, + {missing_mandatory_fields,[i],obj4}}, + {structured_error,{M,6},asn1ct_check, + {invalid_fields,[wrong],'InvalidSet'}} + ] + } = run(P, Config), + ok. + run({Mod,Spec}, Config) -> diff --git a/lib/asn1/test/testDeepTConstr.erl b/lib/asn1/test/testDeepTConstr.erl index f17dedc043..620b5f3356 100644 --- a/lib/asn1/test/testDeepTConstr.erl +++ b/lib/asn1/test/testDeepTConstr.erl @@ -40,8 +40,7 @@ main(_Erule) -> {any,"DK"}, {final,"NO"}]}}, - {ok,Bytes1} = 'TConstrChoice':encode('FilterItem', Val1), - {error,Reason} = asn1_wrapper:decode('TConstrChoice','FilterItem',Bytes1), + Reason = must_fail('TConstrChoice', 'FilterItem', Val1), io:format("Reason: ~p~n~n",[Reason]), {ok,Bytes2} = 'TConstrChoice':encode('FilterItem', Val2), {ok,Res} = 'TConstrChoice':decode('FilterItem', Bytes2), @@ -70,6 +69,21 @@ main(_Erule) -> {'Deeper_a',12, {'Deeper_a_s',{2,4},42}}, {'Deeper_b',13,{'Type-object1',14,true}}}), + + roundtrip('TConstr', 'Seq3', + {'Seq3', + {'Seq3_a',42,'TConstr':'id-object1'()}, + {'Seq3_b', + {'Type-object1',-777,true}, + 12345, + {'Seq3_b_bc',12345789,{'Type-object1',-999,true}}}}), + roundtrip('TConstr', 'Seq3-Opt', + {'Seq3-Opt', + {'Seq3-Opt_a',42,'TConstr':'id-object1'()}, + {'Seq3-Opt_b', + {'Type-object1',-777,true}, + 12345, + {'Seq3-Opt_b_bc',12345789,{'Type-object1',-999,true}}}}), ok. @@ -77,3 +91,13 @@ roundtrip(M, T, V) -> {ok,E} = M:encode(T, V), {ok,V} = M:decode(T, E), ok. + +%% Either encoding or decoding must fail. +must_fail(M, T, V) -> + case M:encode(T, V) of + {ok,E} -> + {error,Reason} = M:decode(T, E), + Reason; + {error,Reason} -> + Reason + end. diff --git a/lib/asn1/test/testFragmented.erl b/lib/asn1/test/testFragmented.erl new file mode 100644 index 0000000000..c391ba8305 --- /dev/null +++ b/lib/asn1/test/testFragmented.erl @@ -0,0 +1,42 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2013. 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(testFragmented). + +-export([main/1]). + +main(_Erule) -> + roundtrip('PDU', {'PDU',1,false,["abc","def"]}), + B256 = lists:seq(0, 255), + K1 = lists:duplicate(4, B256), + K8 = binary_to_list(iolist_to_binary(lists:duplicate(8, K1))), + roundtrip('PDU', {'PDU',1,false,[K8,K8]}), + roundtrip('PDU', {'PDU',1,false,[K8,K8,K8,K8]}), + roundtrip('PDU', {'PDU',1,false,[K8,K8,K8,K8,K8,K8]}), + roundtrip('PDU', {'PDU',1,false,[K8,K8,K8,K8,K8,K8,K8,K8]}), + roundtrip('PDU', {'PDU',1,false,[K8,K8,K8,K8,K8,K8,K8,K8, + K8,K8,K8,K8,K8,K8]}), + roundtrip('PDU', {'PDU',1,false,[K8,K8,K8,K8,K8,K8,K8,K8, + K8,K8,K8,K8,K8,K8,K8,K8]}), + ok. + +roundtrip(T, V) -> + {ok,E} = 'Fragmented':encode(T, V), + {ok,V} = 'Fragmented':decode(T, E), + ok. diff --git a/lib/asn1/test/testInfObj.erl b/lib/asn1/test/testInfObj.erl index c7b19a0cbb..76f216fdad 100644 --- a/lib/asn1/test/testInfObj.erl +++ b/lib/asn1/test/testInfObj.erl @@ -59,13 +59,73 @@ main(_Erule) -> {'ConstructedPdu',2,{'CONSTRUCTED-DEFAULT_Type',999,false}}), roundtrip('InfObj', 'ConstructedPdu', {'ConstructedPdu',3,true}), + {'ConstructedPdu',4,{_,42,<<13:7>>}} = + enc_dec('InfObj', 'ConstructedPdu', + {'ConstructedPdu',4,{'',42,<<13:7>>}}), + roundtrip('InfObj', 'ConstructedPdu', + {'ConstructedPdu',5,{i,-250138}}), + roundtrip('InfObj', 'ConstructedPdu', + {'ConstructedPdu',5,{b,<<13456:15>>}}), + roundtrip('InfObj', 'ConstructedPdu', + {'ConstructedPdu',6,[]}), + roundtrip('InfObj', 'ConstructedPdu', + {'ConstructedPdu',6,[10,7,16,1,5,13,12]}), + roundtrip('InfObj', 'ConstructedPdu', + {'ConstructedPdu',7,[]}), + roundtrip('InfObj', 'ConstructedPdu', + {'ConstructedPdu',7,[64,1,19,17,35]}), + + roundtrip('InfObj', 'ConstructedSet', + {'ConstructedSet',1,{'CONSTRUCTED-DEFAULT_Type',-2001,true}}), + roundtrip('InfObj', 'ConstructedSet', + {'ConstructedSet',2,{'CONSTRUCTED-DEFAULT_Type',999,false}}), + roundtrip('InfObj', 'ConstructedSet', + {'ConstructedSet',3,true}), + {'ConstructedSet',4,{_,42,<<13:7>>}} = + enc_dec('InfObj', 'ConstructedSet', + {'ConstructedSet',4,{'',42,<<13:7>>}}), + roundtrip('InfObj', 'ConstructedSet', + {'ConstructedSet',5,{i,-250138}}), + roundtrip('InfObj', 'ConstructedSet', + {'ConstructedSet',5,{b,<<13456:15>>}}), + roundtrip('InfObj', 'ConstructedSet', + {'ConstructedSet',6,[]}), + roundtrip('InfObj', 'ConstructedSet', + {'ConstructedSet',6,[10,7,16,1,5,13,12]}), + roundtrip('InfObj', 'ConstructedSet', + {'ConstructedSet',7,[]}), + roundtrip('InfObj', 'ConstructedSet', + {'ConstructedSet',7,[64,1,19,17,35]}), roundtrip('InfObj', 'Seq2', {'Seq2',42,[true,false,false,true], - [false,true,false]}). + [false,true,false]}), + + roundtrip('InfObj', 'OptionalInSeq', {'OptionalInSeq',3,true}), + roundtrip('InfObj', 'OptionalInSeq', {'OptionalInSeq',3,asn1_NOVALUE}), + + roundtrip('InfObj', 'DefaultInSeq', {'DefaultInSeq',3,false}), + roundtrip('InfObj', 'DefaultInSeq', {'DefaultInSeq',3,true}), + {'DefaultInSeq',3,true} = + enc_dec('InfObj', 'DefaultInSeq', {'DefaultInSeq',3,asn1_DEFAULT}), + roundtrip('InfObj', 'Multiple-Optionals', + {'Multiple-Optionals',1,42,true,"abc"}), + roundtrip('InfObj', 'Multiple-Optionals', + {'Multiple-Optionals',1,asn1_NOVALUE,true,"abc"}), + roundtrip('InfObj', 'Multiple-Optionals', + {'Multiple-Optionals',1,42,asn1_NOVALUE,"abc"}), + roundtrip('InfObj', 'Multiple-Optionals', + {'Multiple-Optionals',1,42,true,asn1_NOVALUE}), + roundtrip('InfObj', 'Multiple-Optionals', + {'Multiple-Optionals',1,asn1_NOVALUE,asn1_NOVALUE,asn1_NOVALUE}). roundtrip(M, T, V) -> {ok,Enc} = M:encode(T, V), {ok,V} = M:decode(T, Enc), ok. + +enc_dec(M, T, V0) -> + {ok,Enc} = M:encode(T, V0), + {ok,V} = M:decode(T, Enc), + V. diff --git a/lib/asn1/test/testParameterizedInfObj.erl b/lib/asn1/test/testParameterizedInfObj.erl index 1dfa52f401..02847e502b 100644 --- a/lib/asn1/test/testParameterizedInfObj.erl +++ b/lib/asn1/test/testParameterizedInfObj.erl @@ -86,8 +86,18 @@ param(Erule) -> asn1_wrapper:encode('Param','OS1',[1,2,3,4]) end, + roundtrip('Scl', {'Scl',42,{a,9738654}}), + roundtrip('Scl', {'Scl',42,{b,false}}), + roundtrip('Scl', {'Scl',42,{b,true}}), + + ok. + +roundtrip(T, V) -> + {ok,Enc} = 'Param':encode(T, V), + {ok,V} = 'Param':decode(T, Enc), ok. + ranap(_Erule) -> PIEVal2 = [{'ProtocolIE-Field',4,ignore,{radioNetwork,'rab-pre-empted'}}], ?line Val2 = diff --git a/lib/asn1/test/testPrimStrings.erl b/lib/asn1/test/testPrimStrings.erl index e2322c92a9..1762e34599 100644 --- a/lib/asn1/test/testPrimStrings.erl +++ b/lib/asn1/test/testPrimStrings.erl @@ -28,9 +28,46 @@ -export([bmp_string/1]). -export([times/1]). -export([utf8_string/1]). +-export([fragmented/1]). -include_lib("test_server/include/test_server.hrl"). +fragmented(Rules) -> + Lens = fragmented_lengths(), + fragmented_octet_string(Rules, Lens), + case Rules of + per -> + %% NYI. + ok; + _ -> + fragmented_strings(Lens) + end. + +fragmented_strings(Lens) -> + Types = ['Ns','Ps','Ps11','Vis','IA5'], + [fragmented_strings(Len, Types) || Len <- Lens], + ok. + +fragmented_strings(Len, Types) -> + Str = make_ns_value(Len), + [roundtrip(Type, Str) || Type <- Types], + ok. + +make_ns_value(0) -> []; +make_ns_value(N) -> [($0 - 1) + random:uniform(10)|make_ns_value(N-1)]. + +fragmented_lengths() -> + K16 = 1 bsl 14, + K32 = K16 + K16, + K48 = K32 + K16, + K64 = K48 + K16, + [0,1,14,15,16,17,127,128, + K16-1,K16,K16+1,K16+(1 bsl 7)-1,K16+(1 bsl 7),K16+(1 bsl 7)+1, + K32-1,K32,K32+1,K32+(1 bsl 7)-1,K32+(1 bsl 7),K32+(1 bsl 7)+1, + K48-1,K48,K48+1,K48+(1 bsl 7)-1,K48+(1 bsl 7),K48+(1 bsl 7)+1, + K64-1,K64,K64+1,K64+(1 bsl 7)-1,K64+(1 bsl 7),K64+(1 bsl 7)+1, + K64+K16-1,K64+K16,K64+K16+1]. + bit_string(Rules) -> %%========================================================== @@ -311,8 +348,6 @@ octet_string(Rules) -> ok end, - fragmented_octet_string(Rules), - S255 = lists:seq(1, 255), Strings = {type,true,"","1","12","345",true, S255,[$a|S255],[$a,$b|S255],397}, @@ -324,17 +359,7 @@ octet_string(Rules) -> p_roundtrip('OsVarStringsExt', ShortenedStrings), ok. -fragmented_octet_string(Erules) -> - K16 = 1 bsl 14, - K32 = K16 + K16, - K48 = K32 + K16, - K64 = K48 + K16, - Lens = [0,1,14,15,16,17,127,128, - K16-1,K16,K16+1,K16+(1 bsl 7)-1,K16+(1 bsl 7),K16+(1 bsl 7)+1, - K32-1,K32,K32+1,K32+(1 bsl 7)-1,K32+(1 bsl 7),K32+(1 bsl 7)+1, - K48-1,K48,K48+1,K48+(1 bsl 7)-1,K48+(1 bsl 7),K48+(1 bsl 7)+1, - K64-1,K64,K64+1,K64+(1 bsl 7)-1,K64+(1 bsl 7),K64+(1 bsl 7)+1, - K64+K16-1,K64+K16,K64+K16+1], +fragmented_octet_string(Erules, Lens) -> Types = ['Os','OsFrag','OsFragExt'], [fragmented_octet_string(Erules, Types, L) || L <- Lens], fragmented_octet_string(Erules, ['FixedOs65536'], 65536), diff --git a/lib/asn1/test/testSeqOf.erl b/lib/asn1/test/testSeqOf.erl index db537b1478..c50cc27f6f 100644 --- a/lib/asn1/test/testSeqOf.erl +++ b/lib/asn1/test/testSeqOf.erl @@ -83,6 +83,32 @@ main(_Rules) -> roundtrip('Seq4', #'Seq4'{seq43=SeqIn3}, #'Seq4'{seq41=[],seq42=[], seq43=SeqIn3}), + + roundtrip('Seq5', {'Seq5',true,[],77}), + roundtrip('Seq5', {'Seq5',true,[""],77}), + roundtrip('Seq5', {'Seq5',true,["a"],77}), + roundtrip('Seq5', {'Seq5',true,["ab"],77}), + roundtrip('Seq5', {'Seq5',true,["abc"],77}), + + roundtrip('Seq6', {'Seq6',[],[],101}), + roundtrip('Seq6', {'Seq6',[],[7],101}), + roundtrip('Seq6', {'Seq6',[],[1,7],101}), + roundtrip('Seq6', {'Seq6',[1],[],101}), + roundtrip('Seq6', {'Seq6',[2],[7],101}), + roundtrip('Seq6', {'Seq6',[3],[1,7],101}), + + roundtrip('Seq8', {'Seq8',[],37}), + + roundtrip('Seq9', {'Seq9',true,[],97}), + roundtrip('Seq9', {'Seq9',true,[""],97}), + roundtrip('Seq9', {'Seq9',true,["x"],97}), + roundtrip('Seq9', {'Seq9',true,["xy"],97}), + roundtrip('Seq9', {'Seq9',true,["xyz"],97}), + + roundtrip('Seq10', {'Seq10',true,[""],97}), + roundtrip('Seq10', {'Seq10',true,["a"],97}), + roundtrip('Seq10', {'Seq10',true,["a","b"],97}), + roundtrip('Seq10', {'Seq10',true,["a","b","c"],97}), roundtrip('SeqEmp', #'SeqEmp'{seq1=[#'Empty'{}]}), diff --git a/lib/common_test/src/ct_hooks.erl b/lib/common_test/src/ct_hooks.erl index 3d87a82e24..e845e9e908 100644 --- a/lib/common_test/src/ct_hooks.erl +++ b/lib/common_test/src/ct_hooks.erl @@ -50,9 +50,8 @@ -spec init(State :: term()) -> ok | {fail, Reason :: term()}. init(Opts) -> - call(get_new_hooks(Opts, undefined) ++ get_builtin_hooks(Opts), + call(get_builtin_hooks(Opts) ++ get_new_hooks(Opts, undefined), ok, init, []). - %% @doc Called after all suites are done. -spec terminate(Hooks :: term()) -> @@ -276,8 +275,10 @@ get_new_hooks(Config, Fun) -> end, get_new_hooks(Config)). get_new_hooks(Config) when is_list(Config) -> - lists:flatmap(fun({?config_name, HookConfigs}) -> + lists:flatmap(fun({?config_name, HookConfigs}) when is_list(HookConfigs) -> HookConfigs; + ({?config_name, HookConfig}) when is_atom(HookConfig) -> + [HookConfig]; (_) -> [] end, Config); diff --git a/lib/common_test/src/ct_logs.erl b/lib/common_test/src/ct_logs.erl index bd37b690b6..1a6e4d31a8 100644 --- a/lib/common_test/src/ct_logs.erl +++ b/lib/common_test/src/ct_logs.erl @@ -61,6 +61,7 @@ -define(index_name, "index.html"). -define(totals_name, "totals.info"). -define(log_cache_name, "ct_log_cache"). +-define(misc_io_log, "misc_io.log.html"). -define(table_color1,"#ADD8E6"). -define(table_color2,"#E4F0FE"). @@ -523,7 +524,7 @@ int_footer() -> div_header(Class) -> div_header(Class,"User"). div_header(Class,Printer) -> - "<div class=\"" ++ atom_to_list(Class) ++ "\"><b>*** " ++ Printer ++ + "\n<div class=\"" ++ atom_to_list(Class) ++ "\"><b>*** " ++ Printer ++ " " ++ log_timestamp(now()) ++ " ***</b>". div_footer() -> "</div>". @@ -617,6 +618,34 @@ logger(Parent, Mode, Verbosity) -> end end end, + + test_server_io:start_link(), + MiscIoName = filename:join(Dir, ?misc_io_log), + {ok,MiscIoFd} = file:open(MiscIoName, + [write,{encoding,utf8}]), + test_server_io:set_fd(unexpected_io, MiscIoFd), + + {MiscIoHeader,MiscIoFooter} = + case get_ts_html_wrapper("Pre/post-test I/O log", Dir, false, + Dir, undefined, utf8) of + {basic_html,UH,UF} -> + {UH,UF}; + {xhtml,UH,UF} -> + {UH,UF} + end, + io:put_chars(MiscIoFd, + [MiscIoHeader, + "<a name=\"pretest\"></a>\n", + xhtml("<br>\n<h2>Pre-test Log</h2>", + "<br />\n<h3>PRE-TEST LOG</h3>"), + "\n<pre>\n"]), + MiscIoDivider = + "\n<a name=\"posttest\"></a>\n"++ + xhtml("</pre>\n<br><h2>Post-test Log</h2>\n<pre>\n", + "</pre>\n<br />\n<h3>POST-TEST LOG</h3>\n<pre>\n"), + ct_util:set_testdata_async({misc_io_log,{filename:absname(MiscIoName), + MiscIoDivider,MiscIoFooter}}), + ct_event:notify(#event{name=start_logging,node=node(), data=AbsDir}), make_all_runs_index(start), @@ -627,7 +656,7 @@ logger(Parent, Mode, Verbosity) -> end, file:set_cwd(Dir), make_last_run_index(Time), - CtLogFd = open_ctlog(), + CtLogFd = open_ctlog(?misc_io_log), io:format(CtLogFd,int_header()++int_footer(), [log_timestamp(now()),"Common Test Logger started"]), Parent ! {started,self(),{Time,filename:absname("")}}, @@ -922,7 +951,7 @@ set_evmgr_gl(GL) -> EvMgrPid -> group_leader(GL,EvMgrPid) end. -open_ctlog() -> +open_ctlog(MiscIoName) -> {ok,Fd} = file:open(?ct_log_name,[write,{encoding,utf8}]), io:format(Fd, header("Common Test Framework Log", {[],[1,2],[]}), []), case file:consult(ct_run:variables_file_name("../")) of @@ -937,10 +966,21 @@ open_ctlog() -> "No configuration found for test!!\n", [Variables,Reason]) end, + io:format(Fd, + xhtml("<br><br><h2>Pre/post-test I/O Log</h2>\n", + "<br /><br />\n<h4>PRE/POST TEST I/O LOG</h4>\n"), []), + io:format(Fd, + "\n<ul>\n" + "<li><a href=\"~ts#pretest\">" + "View I/O logged before the test run</a></li>\n" + "<li><a href=\"~ts#posttest\">" + "View I/O logged after the test run</a></li>\n</ul>\n", + [MiscIoName,MiscIoName]), + print_style(Fd,undefined), io:format(Fd, - xhtml("<br><br><h2>Progress Log</h2>\n<pre>\n", - "<br /><br /><h4>PROGRESS LOG</h4>\n<pre>\n"), []), + xhtml("<br><h2>Progress Log</h2>\n<pre>\n", + "<br />\n<h4>PROGRESS LOG</h4>\n<pre>\n"), []), Fd. print_style(Fd,undefined) -> @@ -2856,6 +2896,9 @@ make_relative1(DirTs, CwdTs) -> %%% @doc %%% get_ts_html_wrapper(TestName, PrintLabel, Cwd, TableCols, Encoding) -> + get_ts_html_wrapper(TestName, undefined, PrintLabel, Cwd, TableCols, Encoding). + +get_ts_html_wrapper(TestName, Logdir, PrintLabel, Cwd, TableCols, Encoding) -> TestName1 = if is_list(TestName) -> lists:flatten(TestName); true -> @@ -2876,7 +2919,12 @@ get_ts_html_wrapper(TestName, PrintLabel, Cwd, TableCols, Encoding) -> end end, CTPath = code:lib_dir(common_test), - {ok,CtLogdir} = get_log_dir(true), + + {ok,CtLogdir} = + if Logdir == undefined -> get_log_dir(true); + true -> {ok,Logdir} + end, + AllRuns = make_relative(filename:join(filename:dirname(CtLogdir), ?all_runs_name), Cwd), TestIndex = make_relative(filename:join(filename:dirname(CtLogdir), @@ -3074,16 +3122,8 @@ unexpected_io(Pid,ct_internal,_Importance,List,State) -> IoFun = create_io_fun(Pid,State), io:format(State#logger_state.ct_log_fd, "~ts", [lists:foldl(IoFun, [], List)]); -unexpected_io(Pid,Category,Importance,List,State) -> +unexpected_io(Pid,_Category,_Importance,List,State) -> IoFun = create_io_fun(Pid,State), Data = io_lib:format("~ts", [lists:foldl(IoFun, [], List)]), - %% if unexpected io comes in during startup or shutdown, test_server - %% might not be running - if so (noproc exit), simply print to - %% stdout instead (will result in double printouts when pal is used) - try test_server_io:print_unexpected(Data) of - _ -> - ok - catch - _:{noproc,_} -> tc_print(Category,Importance,Data,[]); - _:Reason -> exit(Reason) - end. + test_server_io:print_unexpected(Data), + ok. diff --git a/lib/common_test/src/ct_run.erl b/lib/common_test/src/ct_run.erl index 266ca73417..7c797be03e 100644 --- a/lib/common_test/src/ct_run.erl +++ b/lib/common_test/src/ct_run.erl @@ -1883,7 +1883,7 @@ verify_suites(TestSuites) -> atom_to_list( Suite)), io:format(user, - "Suite ~w not found" + "Suite ~w not found " "in directory ~ts~n", [Suite,TestDir]), {Found,[{DS,[Name]}|NotFound]} diff --git a/lib/common_test/src/ct_util.erl b/lib/common_test/src/ct_util.erl index abda87c2cd..bcc4caa62e 100644 --- a/lib/common_test/src/ct_util.erl +++ b/lib/common_test/src/ct_util.erl @@ -187,6 +187,7 @@ do_start(Parent, Mode, LogDir, Verbosity) -> false -> ok end, + {StartTime,TestLogDir} = ct_logs:init(Mode, Verbosity), ct_event:notify(#event{name=test_start, @@ -198,12 +199,26 @@ do_start(Parent, Mode, LogDir, Verbosity) -> ok -> Parent ! {self(),started}; {fail,CTHReason} -> - ct_logs:tc_print('Suite Callback',CTHReason,[]), + ErrorInfo = if is_atom(CTHReason) -> + io_lib:format("{~p,~p}", + [CTHReason, + erlang:get_stacktrace()]); + true -> + CTHReason + end, + ct_logs:tc_print('Suite Callback',ErrorInfo,[]), self() ! {{stop,{self(),{user_error,CTHReason}}}, {Parent,make_ref()}} catch _:CTHReason -> - ct_logs:tc_print('Suite Callback',CTHReason,[]), + ErrorInfo = if is_atom(CTHReason) -> + io_lib:format("{~p,~p}", + [CTHReason, + erlang:get_stacktrace()]); + true -> + CTHReason + end, + ct_logs:tc_print('Suite Callback',ErrorInfo,[]), self() ! {{stop,{self(),{user_error,CTHReason}}}, {Parent,make_ref()}} end, @@ -392,19 +407,38 @@ loop(Mode,TestData,StartDir) -> return(From,StartDir), loop(From,TestData,StartDir); {{stop,Info},From} -> + test_server_io:reset_state(), + {MiscIoName,MiscIoDivider,MiscIoFooter} = + proplists:get_value(misc_io_log,TestData), + {ok,MiscIoFd} = file:open(MiscIoName, + [append,{encoding,utf8}]), + io:put_chars(MiscIoFd, MiscIoDivider), + test_server_io:set_fd(unexpected_io, MiscIoFd), + Time = calendar:local_time(), ct_event:sync_notify(#event{name=test_done, node=node(), data=Time}), - Callbacks = ets:lookup_element(?suite_table, - ct_hooks, - #suite_data.value), + Callbacks = + try ets:lookup_element(?suite_table, + ct_hooks, + #suite_data.value) of + CTHMods -> CTHMods + catch + %% this is because ct_util failed in init + error:badarg -> [] + end, ct_hooks:terminate(Callbacks), close_connections(ets:tab2list(?conn_table)), ets:delete(?conn_table), ets:delete(?board_table), ets:delete(?suite_table), ets:delete(?verbosity_table), + + io:put_chars(MiscIoFd, "\n</pre>\n"++MiscIoFooter), + test_server_io:stop([unexpected_io]), + test_server_io:finish(), + ct_logs:close(Info, StartDir), ct_event:stop(), ct_config:stop(), @@ -679,8 +713,14 @@ reset_silent_connections() -> %%% @see ct stop(Info) -> case whereis(ct_util_server) of - undefined -> ok; - _ -> call({stop,Info}) + undefined -> + ok; + CtUtilPid -> + Ref = monitor(process, CtUtilPid), + call({stop,Info}), + receive + {'DOWN',Ref,_,_,_} -> ok + end end. %%%----------------------------------------------------------------- diff --git a/lib/common_test/src/cth_log_redirect.erl b/lib/common_test/src/cth_log_redirect.erl index a030701f19..11af1aa346 100644 --- a/lib/common_test/src/cth_log_redirect.erl +++ b/lib/common_test/src/cth_log_redirect.erl @@ -36,13 +36,17 @@ handle_event/2, handle_call/2, handle_info/2, terminate/1]). +%% Other +-export([handle_remote_events/1]). + -include("ct.hrl"). -record(eh_state, {log_func, curr_suite, curr_group, curr_func, - parallel_tcs = false}). + parallel_tcs = false, + handle_remote_events = false}). id(_Opts) -> ?MODULE. @@ -51,7 +55,6 @@ init(?MODULE, _Opts) -> error_logger:add_report_handler(?MODULE), tc_log_async. - pre_init_per_suite(Suite, Config, State) -> set_curr_func({Suite,init_per_suite}, Config), {Config, State}. @@ -104,7 +107,8 @@ post_end_per_group(_Group, Config, Return, State) -> init(_Type) -> {ok, #eh_state{log_func = tc_log_async}}. -handle_event({_Type, GL, _Msg}, State) when node(GL) /= node() -> +handle_event({_Type,GL,_Msg}, #eh_state{handle_remote_events = false} = State) + when node(GL) /= node() -> {ok, State}; handle_event(Event, #eh_state{log_func = LogFunc} = State) -> case lists:keyfind(sasl, 1, application:which_applications()) of @@ -160,9 +164,12 @@ handle_call({set_curr_func,undefined,_Config}, State) -> handle_call({set_curr_func,TC,_Config}, State) -> {ok, ok, State#eh_state{curr_func = TC}}; -handle_call({set_logfunc,NewLogFunc},State) -> +handle_call({set_logfunc,NewLogFunc}, State) -> {ok, NewLogFunc, State#eh_state{log_func = NewLogFunc}}; +handle_call({handle_remote_events,Bool}, State) -> + {ok, ok, State#eh_state{handle_remote_events = Bool}}; + handle_call(_Query, _State) -> {error, bad_query}. @@ -179,8 +186,16 @@ set_curr_func(CurrFunc, Config) -> set_log_func(Func) -> gen_event:call(error_logger, ?MODULE, {set_logfunc, Func}). +handle_remote_events(Bool) -> + gen_event:call(error_logger, ?MODULE, {handle_remote_events, Bool}). + %%%----------------------------------------------------------------- +format_header(#eh_state{curr_suite = undefined, + curr_group = undefined, + curr_func = undefined}) -> + io_lib:format("System report", []); + format_header(#eh_state{curr_suite = Suite, curr_group = undefined, curr_func = undefined}) -> diff --git a/lib/common_test/test/Makefile b/lib/common_test/test/Makefile index 9d2edcd653..085f19d023 100644 --- a/lib/common_test/test/Makefile +++ b/lib/common_test/test/Makefile @@ -51,6 +51,7 @@ MODULES= \ ct_master_SUITE \ ct_misc_1_SUITE \ ct_hooks_SUITE \ + ct_pre_post_test_io_SUITE \ ct_netconfc_SUITE \ ct_basic_html_SUITE \ ct_auto_compile_SUITE \ diff --git a/lib/common_test/test/ct_gen_conn_SUITE_data/proto.erl b/lib/common_test/test/ct_gen_conn_SUITE_data/proto.erl index 8fcd35e0a4..1d08ce167b 100644 --- a/lib/common_test/test/ct_gen_conn_SUITE_data/proto.erl +++ b/lib/common_test/test/ct_gen_conn_SUITE_data/proto.erl @@ -1,10 +1,21 @@ -%%% @author Peter Andersson <[email protected]> -%%% @copyright (C) 2013, Peter Andersson -%%% @doc -%%% -%%% @end -%%% Created : 24 May 2013 by Peter Andersson <[email protected]> - +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2012. 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(proto). -compile(export_all). diff --git a/lib/common_test/test/ct_pre_post_test_io_SUITE.erl b/lib/common_test/test/ct_pre_post_test_io_SUITE.erl new file mode 100644 index 0000000000..84341a0b99 --- /dev/null +++ b/lib/common_test/test/ct_pre_post_test_io_SUITE.erl @@ -0,0 +1,252 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2012. 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% +%% + +%%%------------------------------------------------------------------- +%%% File: ct_pre_post_test_io_SUITE +%%% +%%% Description: +%%% +%%% Test that ct:log/2 printouts and error/progress reports that happen +%%% before or after the test run are saved in the pre/post test IO log. +%%%------------------------------------------------------------------- +-module(ct_pre_post_test_io_SUITE). + +-compile(export_all). + +-include_lib("common_test/include/ct.hrl"). +-include_lib("common_test/include/ct_event.hrl"). + +-define(eh, ct_test_support_eh). + +%%-------------------------------------------------------------------- +%% TEST SERVER CALLBACK FUNCTIONS +%%-------------------------------------------------------------------- + +%%-------------------------------------------------------------------- +%% Description: Since Common Test starts another Test Server +%% instance, the tests need to be performed on a separate node (or +%% there will be clashes with logging processes etc). +%%-------------------------------------------------------------------- +init_per_suite(Config) -> + DataDir = ?config(data_dir, Config), + CTH = filename:join(DataDir, "cth_ctrl.erl"), + ct:pal("Compiling ~p: ~p", + [CTH,compile:file(CTH,[{outdir,DataDir},debug_info])]), + ct_test_support:init_per_suite([{path_dirs,[DataDir]}, + {start_sasl,true} | Config]). + +end_per_suite(Config) -> + ct_test_support:end_per_suite(Config). + +init_per_testcase(TestCase, Config) -> + ct_test_support:init_per_testcase(TestCase, Config). + +end_per_testcase(TestCase, Config) -> + ct_test_support:end_per_testcase(TestCase, Config). + +suite() -> [{ct_hooks,[ts_install_cth]}]. + +all() -> + [ + pre_post_io + ]. + +%%-------------------------------------------------------------------- +%% TEST CASES +%%-------------------------------------------------------------------- + +%%%----------------------------------------------------------------- +%%% +pre_post_io(Config) -> + TC = pre_post_io, + DataDir = ?config(data_dir, Config), + Suite = filename:join(DataDir, "dummy_SUITE"), + {Opts,ERPid} = setup([{suite,Suite},{label,TC},{ct_hooks,[cth_ctrl]}], + Config), + + %%!-------------------------------------------------------------------- + %%! Note that error reports will not start showing up in the pre-test + %%! io log until handle_remote_events has been set to true (see below). + %%! The reason is that the error logger has its group leader on the + %%! test_server node (not the ct node) and cth_log_redirect ignores + %%! events with remote destination until told otherwise. + %%!-------------------------------------------------------------------- + + spawn(fun() -> + %% --- test run 1 --- + ct:sleep(3000), + ct_test_support:ct_rpc({cth_log_redirect, + handle_remote_events, + [true]}, Config), + ct:sleep(2000), + io:format(user, "Starting test run!~n", []), + ct_test_support:ct_rpc({cth_ctrl,proceed,[]}, Config), + ct:sleep(6000), + io:format(user, "Finishing off!~n", []), + ct_test_support:ct_rpc({cth_ctrl,proceed,[]}, Config), + %% --- test run 2 --- + ct:sleep(3000), + ct_test_support:ct_rpc({cth_log_redirect, + handle_remote_events, + [true]}, Config), + ct:sleep(2000), + io:format(user, "Starting test run!~n", []), + ct_test_support:ct_rpc({cth_ctrl,proceed,[]}, Config), + ct:sleep(6000), + io:format(user, "Finishing off!~n", []), + ct_test_support:ct_rpc({cth_ctrl,proceed,[]}, Config) + end), + ct_test_support:run(Opts, Config), + Events = ct_test_support:get_events(ERPid, Config), + ct_test_support:log_events(TC, + reformat(Events, ?eh), + ?config(priv_dir, Config), + Opts), + TestEvents = events_to_check(TC), + ok = ct_test_support:verify_events(TestEvents, Events, Config), + + LogDirs = lists:flatmap(fun({_EH,#event{name=start_logging,data=Dir}}) -> + [Dir]; + (_) -> + [] + end, Events), + PrePostIoFiles = + [filename:join(LogDir, "misc_io.log.html") || LogDir <- LogDirs], + lists:foreach( + fun(PrePostIoFile) -> + ct:log("Reading Pre/Post Test IO Log file: ~ts", [PrePostIoFile]), + {ok,Bin} = file:read_file(PrePostIoFile), + Ts = string:tokens(binary_to_list(Bin),[$\n]), + PrePostIOEntries = + lists:foldl(fun([$L,$o,$g,$g,$e,$r|_], + {pre,PreLogN,PreErrN,0,0}) -> + {pre,PreLogN+1,PreErrN,0,0}; + ([$=,$E,$R,$R,$O,$R|_], + {pre,PreLogN,PreErrN,0,0}) -> + {pre,PreLogN,PreErrN+1,0,0}; + ([_,_,_,_,$P,$O,$S,$T,$-,$T,$E,$S,$T|_], + {pre,PreLogN,PreErrN,0,0}) -> + {post,PreLogN,PreErrN,0,0}; + ([$L,$o,$g,$g,$e,$r|_], + {post,PreLogN,PreErrN,PostLogN,PostErrN}) -> + {post,PreLogN,PreErrN,PostLogN+1,PostErrN}; + ([$=,$E,$R,$R,$O,$R|_], + {post,PreLogN,PreErrN,PostLogN,PostErrN}) -> + {post,PreLogN,PreErrN,PostLogN,PostErrN+1}; + (_, Counters) -> + Counters + end, {pre,0,0,0,0}, Ts), + [_|Counters] = tuple_to_list(PrePostIOEntries), + ct:log("Entries in the Pre/Post Test IO Log: ~p", [Counters]), + case [C || C <- Counters, C < 2] of + [] -> + ok; + _ -> + exit("Not enough entries in the Pre/Post Test IO Log!") + end + end, PrePostIoFiles), + + UnexpIoFiles = + [filelib:wildcard( + filename:join(LogDir, + "*dummy_SUITE.logs/run.*/" + "unexpected_io.log.html")) || LogDir <- LogDirs], + lists:foreach( + fun(UnexpIoFile) -> + ct:log("Reading Unexpected IO Log file: ~ts", [UnexpIoFile]), + {ok,Bin} = file:read_file(UnexpIoFile), + Ts = string:tokens(binary_to_list(Bin),[$\n]), + UnexpIOEntries = + lists:foldl(fun([$L,$o,$g,$g,$e,$r|_], [LogN,ErrN]) -> + [LogN+1,ErrN]; + ([$=,$E,$R,$R,$O,$R|_], [LogN,ErrN]) -> + [LogN,ErrN+1]; + (_, Counters) -> Counters + end, [0,0], Ts), + ct:log("Entries in the Unexpected IO Log: ~p", [UnexpIOEntries]), + case [N || N <- UnexpIOEntries, N < 2] of + [] -> + ok; + _ -> + exit("Not enough entries in the Unexpected IO Log!") + end + end, UnexpIoFiles), + ok. + +%%%----------------------------------------------------------------- +%%% HELP FUNCTIONS +%%%----------------------------------------------------------------- + +setup(Test, Config) -> + Opts0 = ct_test_support:get_opts(Config), + Level = ?config(trace_level, Config), + EvHArgs = [{cbm,ct_test_support},{trace_level,Level}], + Opts = Opts0 ++ [{event_handler,{?eh,EvHArgs}}|Test], + ERPid = ct_test_support:start_event_receiver(Config), + {Opts,ERPid}. + +reformat(Events, EH) -> + ct_test_support:reformat(Events, EH). + +%%%----------------------------------------------------------------- +%%% TEST EVENTS +%%%----------------------------------------------------------------- + +events_to_check(pre_post_io) -> + [ + {?eh,start_logging,{'DEF','RUNDIR'}}, + {?eh,test_start,{'DEF',{'START_TIME','LOGDIR'}}}, + {?eh,start_info,{1,1,7}}, + {?eh,tc_start,{dummy_SUITE,init_per_suite}}, + {?eh,tc_done,{dummy_SUITE,init_per_suite,ok}}, + {parallel, + [{?eh,tc_start,{dummy_SUITE,{init_per_group,g1,[parallel]}}}, + {?eh,tc_done, + {dummy_SUITE,{init_per_group,g1,[parallel]},ok}}, + {?eh,tc_start,{dummy_SUITE,tc1}}, + {?eh,tc_start,{dummy_SUITE,tc2}}, + {?eh,tc_start,{dummy_SUITE,tc3}}, + {?eh,tc_done,{dummy_SUITE,tc2,ok}}, + {?eh,tc_done,{dummy_SUITE,tc1,ok}}, + {?eh,tc_done,{dummy_SUITE,tc3,ok}}, + {?eh,test_stats,{1,0,{0,0}}}, + {?eh,test_stats,{2,0,{0,0}}}, + {?eh,test_stats,{3,0,{0,0}}}, + {?eh,tc_start,{dummy_SUITE,{end_per_group,g1,[parallel]}}}, + {?eh,tc_done,{dummy_SUITE,{end_per_group,g1,[parallel]},ok}}]}, + {?eh,tc_start,{dummy_SUITE,tc1}}, + {?eh,tc_done,{dummy_SUITE,tc1,ok}}, + {?eh,test_stats,{4,0,{0,0}}}, + {?eh,tc_start,{dummy_SUITE,tc2}}, + {?eh,tc_done,{dummy_SUITE,tc2,ok}}, + {?eh,test_stats,{5,0,{0,0}}}, + [{?eh,tc_start,{dummy_SUITE,{init_per_group,g2,[]}}}, + {?eh,tc_done,{dummy_SUITE,{init_per_group,g2,[]},ok}}, + {?eh,tc_start,{dummy_SUITE,tc4}}, + {?eh,tc_done,{dummy_SUITE,tc4,ok}}, + {?eh,test_stats,{6,0,{0,0}}}, + {?eh,tc_start,{dummy_SUITE,tc5}}, + {?eh,tc_done,{dummy_SUITE,tc5,ok}}, + {?eh,test_stats,{7,0,{0,0}}}, + {?eh,tc_start,{dummy_SUITE,{end_per_group,g2,[]}}}, + {?eh,tc_done,{dummy_SUITE,{end_per_group,g2,[]},ok}}], + {?eh,tc_start,{dummy_SUITE,end_per_suite}}, + {?eh,tc_done,{dummy_SUITE,end_per_suite,ok}}, + {?eh,test_done,{'DEF','STOP_TIME'}}, + {?eh,stop_logging,[]}]. diff --git a/lib/common_test/test/ct_pre_post_test_io_SUITE_data/cth_ctrl.erl b/lib/common_test/test/ct_pre_post_test_io_SUITE_data/cth_ctrl.erl new file mode 100644 index 0000000000..a9ea7b14dd --- /dev/null +++ b/lib/common_test/test/ct_pre_post_test_io_SUITE_data/cth_ctrl.erl @@ -0,0 +1,104 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2012. 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(cth_ctrl). + +-export([proceed/0, + init/2, terminate/1]). + +%%%=================================================================== +%%% API +%%%=================================================================== + +proceed() -> + ?MODULE ! proceed. + +%%-------------------------------------------------------------------- +%% Hook functions +%%-------------------------------------------------------------------- +init(_Id, _Opts) -> + case lists:keyfind(sasl, 1, application:which_applications()) of + false -> + exit(sasl_not_started); + _Else -> + ok + end, + WhoAmI = self(), + DispPid = spawn_link(fun() -> dispatcher(WhoAmI) end), + register(?MODULE, DispPid), + io:format(user, + "~n~n+++ Startup of ~w on ~p finished, " + "call ~w:proceed() to run tests...~n", + [?MODULE,node(),?MODULE]), + start_external_logger(cth_logger), + receive + {?MODULE,proceed} -> ok + after + 10000 -> + ok + end, + {ok,[],ct_last}. + +terminate(_State) -> + io:format(user, + "~n~n+++ Tests finished, call ~w:proceed() to shut down...~n", + [?MODULE]), + receive + {?MODULE,proceed} -> ok + after + 10000 -> + ok + end, + stop_external_logger(cth_logger), + stop_dispatcher(), + ok. + +%%%=================================================================== +%%% Internal functions +%%%=================================================================== + +start_external_logger(Name) -> + case whereis(Name) of + undefined -> ok; + Pid -> exit(Pid, kill) + end, + spawn(fun() -> init_logger(Name) end). + +stop_external_logger(Name) -> + catch exit(whereis(Name), kill). + +init_logger(Name) -> + register(Name, self()), + logger_loop(1). + +logger_loop(N) -> + ct:log("Logger iteration: ~p", [N]), + error_logger:error_report(N), + timer:sleep(250), + logger_loop(N+1). + +%%%----------------------------------------------------------------- + +dispatcher(SendTo) -> + receive Msg -> SendTo ! {?MODULE,Msg} end, + dispatcher(SendTo). + +stop_dispatcher() -> + catch exit(whereis(?MODULE), kill). + + diff --git a/lib/common_test/test/ct_pre_post_test_io_SUITE_data/dummy_SUITE.erl b/lib/common_test/test/ct_pre_post_test_io_SUITE_data/dummy_SUITE.erl new file mode 100644 index 0000000000..ac9c4efd31 --- /dev/null +++ b/lib/common_test/test/ct_pre_post_test_io_SUITE_data/dummy_SUITE.erl @@ -0,0 +1,132 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2012. 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(dummy_SUITE). + +-compile(export_all). + +-include_lib("common_test/include/ct.hrl"). + +%%-------------------------------------------------------------------- +%% @spec suite() -> Info +%% Info = [tuple()] +%% @end +%%-------------------------------------------------------------------- +suite() -> + [{timetrap,{seconds,30}}]. + +%%-------------------------------------------------------------------- +%% @spec init_per_suite(Config0) -> +%% Config1 | {skip,Reason} | {skip_and_save,Reason,Config1} +%% Config0 = Config1 = [tuple()] +%% Reason = term() +%% @end +%%-------------------------------------------------------------------- +init_per_suite(Config) -> + Config. + +%%-------------------------------------------------------------------- +%% @spec end_per_suite(Config0) -> void() | {save_config,Config1} +%% Config0 = Config1 = [tuple()] +%% @end +%%-------------------------------------------------------------------- +end_per_suite(_Config) -> + ok. + +%%-------------------------------------------------------------------- +%% @spec init_per_group(GroupName, Config0) -> +%% Config1 | {skip,Reason} | {skip_and_save,Reason,Config1} +%% GroupName = atom() +%% Config0 = Config1 = [tuple()] +%% Reason = term() +%% @end +%%-------------------------------------------------------------------- +init_per_group(_GroupName, Config) -> + Config. + +%%-------------------------------------------------------------------- +%% @spec end_per_group(GroupName, Config0) -> +%% void() | {save_config,Config1} +%% GroupName = atom() +%% Config0 = Config1 = [tuple()] +%% @end +%%-------------------------------------------------------------------- +end_per_group(_GroupName, _Config) -> + ok. + +%%-------------------------------------------------------------------- +%% @spec init_per_testcase(TestCase, Config0) -> +%% Config1 | {skip,Reason} | {skip_and_save,Reason,Config1} +%% TestCase = atom() +%% Config0 = Config1 = [tuple()] +%% Reason = term() +%% @end +%%-------------------------------------------------------------------- +init_per_testcase(_TestCase, Config) -> + ct:sleep(500), + Config. + +%%-------------------------------------------------------------------- +%% @spec end_per_testcase(TestCase, Config0) -> +%% void() | {save_config,Config1} | {fail,Reason} +%% TestCase = atom() +%% Config0 = Config1 = [tuple()] +%% Reason = term() +%% @end +%%-------------------------------------------------------------------- +end_per_testcase(_TestCase, _Config) -> + ok. + +%%-------------------------------------------------------------------- +%% @spec groups() -> [Group] +%% Group = {GroupName,Properties,GroupsAndTestCases} +%% GroupName = atom() +%% Properties = [parallel | sequence | Shuffle | {RepeatType,N}] +%% GroupsAndTestCases = [Group | {group,GroupName} | TestCase] +%% TestCase = atom() +%% Shuffle = shuffle | {shuffle,{integer(),integer(),integer()}} +%% RepeatType = repeat | repeat_until_all_ok | repeat_until_all_fail | +%% repeat_until_any_ok | repeat_until_any_fail +%% N = integer() | forever +%% @end +%%-------------------------------------------------------------------- +groups() -> + [{g1,[parallel],[tc1,tc2,tc3]}, + {g2,[],[tc4,tc5]}]. + +%%-------------------------------------------------------------------- +%% @spec all() -> GroupsAndTestCases | {skip,Reason} +%% GroupsAndTestCases = [{group,GroupName} | TestCase] +%% GroupName = atom() +%% TestCase = atom() +%% Reason = term() +%% @end +%%-------------------------------------------------------------------- +all() -> + [{group,g1},tc1,tc2,{group,g2}]. + +tc1(_C) -> + ok. +tc2(_C) -> + ok. +tc3(_C) -> + ok. +tc4(_C) -> + ok. +tc5(_C) -> + ok. diff --git a/lib/common_test/test/ct_test_support.erl b/lib/common_test/test/ct_test_support.erl index 4132995bf6..67e430f821 100644 --- a/lib/common_test/test/ct_test_support.erl +++ b/lib/common_test/test/ct_test_support.erl @@ -38,7 +38,7 @@ -export([start_slave/3, slave_stop/1]). --export([ct_test_halt/1]). +-export([ct_test_halt/1, ct_rpc/2]). -include_lib("kernel/include/file.hrl"). @@ -65,7 +65,6 @@ init_per_suite(Config, Level) -> _ -> ok end, - start_slave(Config, Level). start_slave(Config, Level) -> @@ -103,6 +102,14 @@ start_slave(NodeName, Config, Level) -> test_server:format(Level, "Dirs added to code path (on ~w):~n", [CTNode]), [io:format("~s~n", [D]) || D <- PathDirs], + + case proplists:get_value(start_sasl, Config) of + true -> + rpc:call(CTNode, application, start, [sasl]), + test_server:format(Level, "SASL started on ~w~n", [CTNode]); + _ -> + ok + end, TraceFile = filename:join(DataDir, "ct.trace"), case file:read_file_info(TraceFile) of @@ -378,6 +385,16 @@ wait_for_ct_stop(Retries, CTNode) -> end. %%%----------------------------------------------------------------- +%%% ct_rpc/1 +ct_rpc({M,F,A}, Config) -> + CTNode = proplists:get_value(ct_node, Config), + Level = proplists:get_value(trace_level, Config), + test_server:format(Level, "~nCalling ~w:~w(~p) on ~p...", + [M,F,A, CTNode]), + rpc:call(CTNode, M, F, A). + + +%%%----------------------------------------------------------------- %%% EVENT HANDLING handle_event(EH, Event) -> diff --git a/lib/compiler/doc/src/compile.xml b/lib/compiler/doc/src/compile.xml index ddaae2655d..f1238f27a6 100644 --- a/lib/compiler/doc/src/compile.xml +++ b/lib/compiler/doc/src/compile.xml @@ -859,6 +859,10 @@ pi() -> 3.1416. {ErrorLine, Module, ErrorDescriptor} </code> + <p><c>ErrorLine</c> will be the atom <c>none</c> if the error does + not correspond to a specific line (e.g. if the source file does + not exist).</p> + <p>A string describing the error is obtained with the following call:</p> <code> diff --git a/lib/compiler/src/compile.erl b/lib/compiler/src/compile.erl index 2ca403de54..802e3dfa2f 100644 --- a/lib/compiler/src/compile.erl +++ b/lib/compiler/src/compile.erl @@ -41,7 +41,8 @@ -type option() :: atom() | {atom(), term()} | {'d', atom(), term()}. --type err_info() :: {erl_scan:line(), module(), term()}. %% ErrorDescriptor +-type err_info() :: {erl_scan:line() | 'none', + module(), term()}. %% ErrorDescriptor -type errors() :: [{file:filename(), [err_info()]}]. -type warnings() :: [{file:filename(), [err_info()]}]. -type mod_ret() :: {'ok', module()} @@ -1290,10 +1291,10 @@ native_compile_1(St) -> {error,R} -> case IgnoreErrors of true -> - Ws = [{St#compile.ifile,[{?MODULE,{native,R}}]}], + Ws = [{St#compile.ifile,[{none,?MODULE,{native,R}}]}], {ok,St#compile{warnings=St#compile.warnings ++ Ws}}; false -> - Es = [{St#compile.ifile,[{?MODULE,{native,R}}]}], + Es = [{St#compile.ifile,[{none,?MODULE,{native,R}}]}], {error,St#compile{errors=St#compile.errors ++ Es}} end catch @@ -1302,7 +1303,7 @@ native_compile_1(St) -> case IgnoreErrors of true -> Ws = [{St#compile.ifile, - [{?MODULE,{native_crash,R,Stk}}]}], + [{none,?MODULE,{native_crash,R,Stk}}]}], {ok,St#compile{warnings=St#compile.warnings ++ Ws}}; false -> erlang:raise(Class, R, Stk) @@ -1349,7 +1350,7 @@ save_binary(#compile{module=Mod,ofile=Outfile, save_binary_1(St); _ -> Es = [{St#compile.ofile, - [{?MODULE,{module_name,Mod,Base}}]}], + [{none,?MODULE,{module_name,Mod,Base}}]}], {error,St#compile{errors=St#compile.errors ++ Es}} end end. @@ -1363,20 +1364,20 @@ save_binary_1(St) -> ok -> {ok,St}; {error,RenameError} -> - Es0 = [{Ofile,[{?MODULE,{rename,Tfile,Ofile, - RenameError}}]}], + Es0 = [{Ofile,[{none,?MODULE,{rename,Tfile,Ofile, + RenameError}}]}], Es = case file:delete(Tfile) of ok -> Es0; {error,DeleteError} -> Es0 ++ [{Ofile, - [{?MODULE,{delete_temp,Tfile, - DeleteError}}]}] + [{none,?MODULE,{delete_temp,Tfile, + DeleteError}}]}] end, {error,St#compile{errors=St#compile.errors ++ Es}} end; {error,_Error} -> - Es = [{Tfile,[{compile,write_error}]}], + Es = [{Tfile,[{none,compile,write_error}]}], {error,St#compile{errors=St#compile.errors ++ Es}} end. @@ -1419,6 +1420,9 @@ report_warnings(#compile{options=Opts,warnings=Ws0}) -> false -> ok end. +format_message(F, P, [{none,Mod,E}|Es]) -> + M = {none,io_lib:format("~ts: ~s~ts\n", [F,P,Mod:format_error(E)])}, + [M|format_message(F, P, Es)]; format_message(F, P, [{{Line,Column}=Loc,Mod,E}|Es]) -> M = {{F,Loc},io_lib:format("~ts:~w:~w ~s~ts\n", [F,Line,Column,P,Mod:format_error(E)])}, @@ -1428,12 +1432,17 @@ format_message(F, P, [{Line,Mod,E}|Es]) -> [F,Line,P,Mod:format_error(E)])}, [M|format_message(F, P, Es)]; format_message(F, P, [{Mod,E}|Es]) -> + %% Not documented and not expected to be used any more, but + %% keep a while just in case. M = {none,io_lib:format("~ts: ~s~ts\n", [F,P,Mod:format_error(E)])}, [M|format_message(F, P, Es)]; format_message(_, _, []) -> []. %% list_errors(File, ErrorDescriptors) -> ok +list_errors(F, [{none,Mod,E}|Es]) -> + io:fwrite("~ts: ~ts\n", [F,Mod:format_error(E)]), + list_errors(F, Es); list_errors(F, [{{Line,Column},Mod,E}|Es]) -> io:fwrite("~ts:~w:~w: ~ts\n", [F,Line,Column,Mod:format_error(E)]), list_errors(F, Es); @@ -1441,6 +1450,8 @@ list_errors(F, [{Line,Mod,E}|Es]) -> io:fwrite("~ts:~w: ~ts\n", [F,Line,Mod:format_error(E)]), list_errors(F, Es); list_errors(F, [{Mod,E}|Es]) -> + %% Not documented and not expected to be used any more, but + %% keep a while just in case. io:fwrite("~ts: ~ts\n", [F,Mod:format_error(E)]), list_errors(F, Es); list_errors(_F, []) -> ok. diff --git a/lib/compiler/src/core_lint.erl b/lib/compiler/src/core_lint.erl index 1e8983f594..e5d5fa2bcd 100644 --- a/lib/compiler/src/core_lint.erl +++ b/lib/compiler/src/core_lint.erl @@ -162,7 +162,7 @@ return_status(St) -> %% add_warning(ErrorDescriptor, State) -> State' %% Note that we don't use line numbers here. -add_error(E, St) -> St#lint{errors=[{?MODULE,E}|St#lint.errors]}. +add_error(E, St) -> St#lint{errors=[{none,?MODULE,E}|St#lint.errors]}. %%add_warning(W, St) -> St#lint{warnings=[{none,core_lint,W}|St#lint.warnings]}. diff --git a/lib/compiler/src/genop.tab b/lib/compiler/src/genop.tab index 75ac91907a..ebc9b1c85b 100644..100755 --- a/lib/compiler/src/genop.tab +++ b/lib/compiler/src/genop.tab @@ -23,45 +23,148 @@ BEAM_FORMAT_NUMBER=0 # arity or semantics, the format number above must be bumped. # +## @spec label Lbl +## @doc Specify a module local label. +## Label gives this code address a name (Lbl) and marks the start of +## a basic block. 1: label/1 + +## @spec func_info M F A +## @doc Define a function M:F/A 2: func_info/3 + 3: int_code_end/0 # # Function and BIF calls. # + +## @spec call Arity Label +## @doc Call the function at Label. +## Save the next instruction as the return address in the CP register. 4: call/2 + +## @spec call_last Arity Label Dellocate +## @doc Deallocate and do a tail recursive call to the function at Label. +## Do not update the CP register. +## Before the call deallocate Deallocate words of stack. 5: call_last/3 + +## @spec call_only Arity Label +## @doc Do a tail recursive call to the function at Label. +## Do not update the CP register. 6: call_only/2 +## @spec call_ext Arity Destination +## @doc Call the function of arity Arity pointed to by Destination. +## Save the next instruction as the return address in the CP register. 7: call_ext/2 + +## @spec call_ext_last Arity Destination Deallocate +## @doc Deallocate and do a tail call to function of arity Arity +## pointed to by Destination. +## Do not update the CP register. +## Deallocate Deallocate words from the stack before the call. 8: call_ext_last/3 +## @spec bif0 Bif Reg +## @doc Call the bif Bif and store the result in Reg. 9: bif0/2 + +## @spec bif1 Lbl Bif Arg Reg +## @doc Call the bif Bif with the argument Arg, and store the result in Reg. +## On failure jump to Lbl. 10: bif1/4 + +## @spec bif2 Lbl Bif Arg1 Arg2 Reg +## @doc Call the bif Bif with the arguments Arg1 and Arg2, +## and store the result in Reg. +## On failure jump to Lbl. 11: bif2/5 # # Allocating, deallocating and returning. # + +## @spec allocate StackNeed Live +## @doc Allocate space for StackNeed words on the stack. If a GC is needed +## during allocation there are Live number of live X registers. +## Also save the continuation pointer (CP) on the stack. 12: allocate/2 + +## @spec allocate_heap StackNeed HeapNeed Live +## @doc Allocate space for StackNeed words on the stack and ensure there is +## space for HeapNeed words on the heap. If a GC is needed +## save Live number of X registers. +## Also save the continuation pointer (CP) on the stack. 13: allocate_heap/3 + +## @spec allocate_zero StackNeed Live +## @doc Allocate space for StackNeed words on the stack. If a GC is needed +## during allocation there are Live number of live X registers. +## Clear the new stack words. (By writing NIL.) +## Also save the continuation pointer (CP) on the stack. 14: allocate_zero/2 + +## @spec allocate_heap_zero StackNeed HeapNeed Live +## @doc Allocate space for StackNeed words on the stack and HeapNeed words +## on the heap. If a GC is needed +## during allocation there are Live number of live X registers. +## Clear the new stack words. (By writing NIL.) +## Also save the continuation pointer (CP) on the stack. 15: allocate_heap_zero/3 + +## @spec test_heap HeapNeed Live +## @doc Ensure there is space for HeapNeed words on the heap. If a GC is needed +## save Live number of X registers. 16: test_heap/2 + +## @spec init N +## @doc Clear the Nth stack word. (By writing NIL.) 17: init/1 + +## @spec deallocate N +## @doc Restore the continuation pointer (CP) from the stack and deallocate +## N+1 words from the stack (the + 1 is for the CP). 18: deallocate/1 + +## @spec return +## @doc Return to the address in the continuation pointer (CP). 19: return/0 # # Sending & receiving. # +## @spec send +## @doc Send argument in x(0) as a message to the destination process in x(0). +## The message in x(1) ends up as the result of the send in x(0). 20: send/0 + +## @spec remove_message +## @doc Unlink the current message from the message queue and store a +## pointer to the message in x(0). Remove any timeout. 21: remove_message/0 + +## @spec timeout +## @doc Reset the save point of the mailbox and clear the timeout flag. 22: timeout/0 + +## @spec loop_rec Label Source +## @doc Loop over the message queue, if it is empty jump to Label. 23: loop_rec/2 + +## @spec loop_rec_end Label +## @doc Advance the save pointer to the next message and jump back to Label. 24: loop_rec_end/1 + +## @spec wait Label +## @doc Suspend the processes and set the entry point to the beginning of the +## receive loop at Label. 25: wait/1 + +## @spec wait_timeout Lable Time +## @doc Sets up a timeout of Time milllisecons and saves the address of the +## following instruction as the entry point if the timeout triggers. 26: wait_timeout/2 # @@ -83,36 +186,106 @@ BEAM_FORMAT_NUMBER=0 # # Comparision operators. # + +## @spec is_lt Lbl Arg1 Arg2 +## @doc Compare two terms and jump to Lbl if Arg1 is not less than Arg2. 39: is_lt/3 + +## @spec is_ge Lbl Arg1 Arg2 +## @doc Compare two terms and jump to Lbl if Arg1 is less than Arg2. 40: is_ge/3 + +## @spec is_eq Lbl Arg1 Arg2 +## @doc Compare two terms and jump to Lbl if Arg1 is not (numerically) equal to Arg2. 41: is_eq/3 + +## @spec is_ne Lbl Arg1 Arg2 +## @doc Compare two terms and jump to Lbl if Arg1 is (numerically) equal to Arg2. 42: is_ne/3 + +## @spec is_eq_exact Lbl Arg1 Arg2 +## @doc Compare two terms and jump to Lbl if Arg1 is not exactly equal to Arg2. 43: is_eq_exact/3 + +## @spec is_ne_exact Lbl Arg1 Arg2 +## @doc Compare two terms and jump to Lbl if Arg1 is exactly equal to Arg2. 44: is_ne_exact/3 # # Type tests. # + +## @spec is_integer Lbl Arg1 +## @doc Test the type of Arg1 and jump to Lbl if it is not an integer. 45: is_integer/2 + +## @spec is_float Lbl Arg1 +## @doc Test the type of Arg1 and jump to Lbl if it is not a float. 46: is_float/2 + +## @spec is_number Lbl Arg1 +## @doc Test the type of Arg1 and jump to Lbl if it is not a number. 47: is_number/2 + +## @spec is_atom Lbl Arg1 +## @doc Test the type of Arg1 and jump to Lbl if it is not an atom. 48: is_atom/2 + +## @spec is_pid Lbl Arg1 +## @doc Test the type of Arg1 and jump to Lbl if it is not a pid. 49: is_pid/2 + +## @spec is_reference Lbl Arg1 +## @doc Test the type of Arg1 and jump to Lbl if it is not a reference. 50: is_reference/2 + +## @spec is_port Lbl Arg1 +## @doc Test the type of Arg1 and jump to Lbl if it is not a port. 51: is_port/2 + +## @spec is_nil Lbl Arg1 +## @doc Test the type of Arg1 and jump to Lbl if it is not nil. 52: is_nil/2 + +## @spec is_binary Lbl Arg1 +## @doc Test the type of Arg1 and jump to Lbl if it is not a binary. 53: is_binary/2 + 54: -is_constant/2 + +## @spec is_list Lbl Arg1 +## @doc Test the type of Arg1 and jump to Lbl if it is not a cons or nil. 55: is_list/2 + +## @spec is_nonempty_list Lbl Arg1 +## @doc Test the type of Arg1 and jump to Lbl if it is not a cons. 56: is_nonempty_list/2 + +## @spec is_tuple Lbl Arg1 +## @doc Test the type of Arg1 and jump to Lbl if it is not a tuple. 57: is_tuple/2 + +## @spec test_arity Lbl Arg1 Arity +## @doc Test the arity of (the tuple in) Arg1 and jump +## to Lbl if it is not equal to Arity. 58: test_arity/3 # # Indexing & jumping. # + +## @spec select_val Arg FailLabel Destinations +## @doc Jump to the destination label corresponding to Arg +## in the Destinations list, if no arity matches, jump to FailLabel. 59: select_val/3 + +## @spec select_tuple_arity Tuple FailLabel Destinations +## @doc Check the arity of the tuple Tuple and jump to the corresponding +## destination label, if no arity matches, jump to FailLabel. 60: select_tuple_arity/3 + +## @spec jump Label +## @doc Jump to Label. 61: jump/1 # @@ -124,9 +297,26 @@ BEAM_FORMAT_NUMBER=0 # # Moving, extracting, modifying. # + +## @spec move Source Destination +## @doc Move the source Source (a literal or a register) to +## the destination register Destination. 64: move/2 + +## @spec get_list Source Head Tail +## @doc Get the head and tail (or car and cdr) parts of a list +## (a cons cell) from Source and put them into the registers +## Head and Tail. 65: get_list/3 + +## @spec get_tuple_element Source Element Destination +## @doc Get element number Element from the tuple in Source and put +## it in the destination register Destination. 66: get_tuple_element/3 + +## @spec set_tuple_element NewElement Tuple Position +## @doc Update the element at postition Position of the tuple Tuple +## with the new element NewElement. 67: set_tuple_element/3 # @@ -147,13 +337,26 @@ BEAM_FORMAT_NUMBER=0 # # 'fun' support. # +## @spec call_fun Arity +## @doc Call a fun of arity Arity. Assume arguments in +## registers x(0) to x(Arity-1) and that the fun is in x(Arity). +## Save the next instruction as the return address in the CP register. 75: call_fun/1 + 76: -make_fun/3 + +## @spec is_function Lbl Arg1 +## @doc Test the type of Arg1 and jump to Lbl if it is not a +## function (i.e. fun or closure). 77: is_function/2 # # Late additions to R5. # + +## @spec call_ext_only Arity Label +## Do a tail recursive call to the function at Label. +## Do not update the CP register. 78: call_ext_only/2 # @@ -212,9 +415,14 @@ BEAM_FORMAT_NUMBER=0 111: bs_add/5 112: apply/1 113: apply_last/2 +## @spec is_boolean Lbl Arg1 +## @doc Test the type of Arg1 and jump to Lbl if it is not a Boolean. 114: is_boolean/2 # New instructions in R10B-6. +## @spec is_function2 Lbl Arg1 Arity +## @doc Test the type of Arg1 and jump to Lbl if it is not a +## function of arity Arity. 115: is_function2/3 # New bit syntax matching in R11B. @@ -229,7 +437,20 @@ BEAM_FORMAT_NUMBER=0 123: bs_restore2/2 # New GC bifs introduced in R11B. + +## @spec gc_bif1 Lbl Live Bif Arg Reg +## @doc Call the bif Bif with the argument Arg, and store the result in Reg. +## On failure jump to Lbl. +## Do a garbage collection if necessary to allocate space on the heap +## for the result (saving Live number of X registers). 124: gc_bif1/5 + +## @spec gc_bif2 Lbl Live Bif Arg1 Arg2 Reg +## @doc Call the bif Bif with the arguments Arg1 and Arg2, +## and store the result in Reg. +## On failure jump to Lbl. +## Do a garbage collection if necessary to allocate space on the heap +## for the result (saving Live number of X registers). 125: gc_bif2/6 # Experimental new bit_level bifs introduced in R11B. @@ -241,6 +462,8 @@ BEAM_FORMAT_NUMBER=0 128: -put_literal/2 # R11B-5 +## @spec is_bitstr Lbl Arg1 +## @doc Test the type of Arg1 and jump to Lbl if it is not a bit string. 129: is_bitstr/2 # R12B @@ -250,7 +473,12 @@ BEAM_FORMAT_NUMBER=0 133: bs_init_writable/0 134: bs_append/8 135: bs_private_append/6 + +## @spec trim N Remaining +## @doc Reduce the stack usage by N words, +## keeping the CP on the top of the stack. 136: trim/2 + 137: bs_init_bits/6 # R12B-5 @@ -277,8 +505,24 @@ BEAM_FORMAT_NUMBER=0 # R14A +## @spec recv_mark Label +## @doc Save the end of the message queue and the address of +## the label Label so that a recv_set instruction can start +## scanning the inbox from this position. 150: recv_mark/1 + +## @spec recv_set Label +## @doc Check that the saved mark points to Label and set the +## save pointer in the message queue to the last position +## of the message queue saved by the recv_mark instruction. 151: recv_set/1 + +## @spec gc_bif3 Lbl Live Bif Arg1 Arg2 Arg3 Reg +## @doc Call the bif Bif with the arguments Arg1, Arg2 and Arg3, +## and store the result in Reg. +## On failure jump to Lbl. +## Do a garbage collection if necessary to allocate space on the heap +## for the result (saving Live number of X registers). 152: gc_bif3/7 # R15A diff --git a/lib/compiler/src/v3_kernel.erl b/lib/compiler/src/v3_kernel.erl index 5f1c108f7c..2b2b8bf550 100644 --- a/lib/compiler/src/v3_kernel.erl +++ b/lib/compiler/src/v3_kernel.erl @@ -1875,7 +1875,7 @@ format_error(bad_segment_size) -> add_warning(none, Term, Anno, #kern{ws=Ws}=St) -> File = get_file(Anno), - St#kern{ws=[{File,[{?MODULE,Term}]}|Ws]}; + St#kern{ws=[{File,[{none,?MODULE,Term}]}|Ws]}; add_warning(Line, Term, Anno, #kern{ws=Ws}=St) -> File = get_file(Anno), St#kern{ws=[{File,[{Line,?MODULE,Term}]}|Ws]}. diff --git a/lib/compiler/test/compile_SUITE.erl b/lib/compiler/test/compile_SUITE.erl index 97777568b6..be01ea713d 100644 --- a/lib/compiler/test/compile_SUITE.erl +++ b/lib/compiler/test/compile_SUITE.erl @@ -139,8 +139,8 @@ forms_2(Config) when is_list(Config) -> module_mismatch(Config) when is_list(Config) -> ?line DataDir = ?config(data_dir, Config), ?line File = filename:join(DataDir, "wrong_module_name.erl"), - ?line {error,[{"wrong_module_name.beam", - [{compile,{module_name,arne,"wrong_module_name"}}]}], + {error,[{"wrong_module_name.beam", + [{none,compile,{module_name,arne,"wrong_module_name"}}]}], []} = compile:file(File, [return]), ?line error = compile:file(File, [report]), diff --git a/lib/compiler/test/core_fold_SUITE.erl b/lib/compiler/test/core_fold_SUITE.erl index abc9ab6a72..a5a4e62a42 100644 --- a/lib/compiler/test/core_fold_SUITE.erl +++ b/lib/compiler/test/core_fold_SUITE.erl @@ -299,7 +299,7 @@ unused_multiple_values_error(Config) when is_list(Config) -> Opts = [no_copt,clint,return,from_core,{outdir,PrivDir} |test_lib:opt_opts(?MODULE)], {error,[{unused_multiple_values_error, - [{core_lint,{return_mismatch,{hello,1}}}]}], + [{none,core_lint,{return_mismatch,{hello,1}}}]}], []} = c:c(Core, Opts), ok. diff --git a/lib/erl_interface/test/ei_decode_encode_SUITE.erl b/lib/erl_interface/test/ei_decode_encode_SUITE.erl index 2271278291..c7830f58f2 100644 --- a/lib/erl_interface/test/ei_decode_encode_SUITE.erl +++ b/lib/erl_interface/test/ei_decode_encode_SUITE.erl @@ -68,6 +68,8 @@ test_ei_decode_encode(Config) when is_list(Config) -> Port = case os:type() of {win32,_} -> open_port({spawn,"sort"},[]); + {unix, darwin} -> + open_port({spawn,"/usr/bin/true"},[]); _ -> open_port({spawn,"/bin/true"},[]) end, diff --git a/lib/inets/test/Makefile b/lib/inets/test/Makefile index dfa86906fd..2f2f6ec16e 100644 --- a/lib/inets/test/Makefile +++ b/lib/inets/test/Makefile @@ -215,7 +215,7 @@ INETS_FILES = inets.config $(INETS_SPECS) # inets_tftp_suite INETS_DATADIRS = inets_SUITE_data inets_sup_SUITE_data -HTTPD_DATADIRS = httpd_test_data httpd_SUITE_data +HTTPD_DATADIRS = httpd_test_data httpd_SUITE_data httpd_basic_SUITE_data HTTPC_DATADIRS = httpc_SUITE_data httpc_proxy_SUITE_data FTP_DATADIRS = ftp_SUITE_data diff --git a/lib/inets/test/httpd_SUITE.erl b/lib/inets/test/httpd_SUITE.erl index 1efa78a63e..5dca76b76b 100644 --- a/lib/inets/test/httpd_SUITE.erl +++ b/lib/inets/test/httpd_SUITE.erl @@ -1919,7 +1919,7 @@ ticket_5865(Config) -> " HTTP/1.1\r\nHost:" ++Host++"\r\n\r\n", [{statuscode, 200}, - {no_last_modified, + {no_header, "last-modified"}]), ok; {error, Reason} -> diff --git a/lib/inets/test/httpd_basic_SUITE.erl b/lib/inets/test/httpd_basic_SUITE.erl index fef0a1f0f4..b1fe373cff 100644 --- a/lib/inets/test/httpd_basic_SUITE.erl +++ b/lib/inets/test/httpd_basic_SUITE.erl @@ -19,6 +19,7 @@ %% -module(httpd_basic_SUITE). +-include_lib("kernel/include/file.hrl"). -include_lib("common_test/include/ct.hrl"). -include("inets_test_lib.hrl"). @@ -35,6 +36,7 @@ all() -> uri_too_long_414, header_too_long_413, erl_script_nocache_opt, + script_nocache, escaped_url_in_error_body, slowdose ]. @@ -63,6 +65,7 @@ init_per_suite(Config) -> "~n Config: ~p", [Config]), ok = inets:start(), PrivDir = ?config(priv_dir, Config), + DataDir = ?config(data_dir, Config), Dummy = "<HTML> @@ -75,6 +78,18 @@ DUMMY </HTML>", DummyFile = filename:join([PrivDir,"dummy.html"]), + CgiDir = filename:join(PrivDir, "cgi-bin"), + ok = file:make_dir(CgiDir), + Cgi = case test_server:os_type() of + {win32, _} -> + "printenv.bat"; + _ -> + "printenv.sh" + end, + inets_test_lib:copy_file(Cgi, DataDir, CgiDir), + AbsCgi = filename:join([CgiDir, Cgi]), + {ok, FileInfo} = file:read_file_info(AbsCgi), + ok = file:write_file_info(AbsCgi, FileInfo#file_info{mode = 8#00755}), {ok, Fd} = file:open(DummyFile, [write]), ok = file:write(Fd, Dummy), ok = file:close(Fd), @@ -85,7 +100,7 @@ DUMMY {document_root, PrivDir}, {bind_address, "localhost"}], - [{httpd_conf, HttpdConf} | Config]. + [{httpd_conf, HttpdConf}, {cgi_dir, CgiDir}, {cgi_script, Cgi} | Config]. %%-------------------------------------------------------------------- %% Function: end_per_suite(Config) -> _ @@ -205,6 +220,52 @@ erl_script_nocache_opt(Config) when is_list(Config) -> %%------------------------------------------------------------------------- %%------------------------------------------------------------------------- +script_nocache(doc) -> + ["Test nocache option for mod_cgi and mod_esi"]; +script_nocache(suite) -> + []; +script_nocache(Config) when is_list(Config) -> + Normal = {no_header, "cache-control"}, + NoCache = {header, "cache-control", "no-cache"}, + verify_script_nocache(Config, false, false, Normal, Normal), + verify_script_nocache(Config, true, false, NoCache, Normal), + verify_script_nocache(Config, false, true, Normal, NoCache), + verify_script_nocache(Config, true, true, NoCache, NoCache), + ok. + +verify_script_nocache(Config, CgiNoCache, EsiNoCache, CgiOption, EsiOption) -> + HttpdConf = ?config(httpd_conf, Config), + CgiScript = ?config(cgi_script, Config), + CgiDir = ?config(cgi_dir, Config), + {ok, Pid} = inets:start(httpd, [{port, 0}, + {script_alias, + {"/cgi-bin/", CgiDir ++ "/"}}, + {script_nocache, CgiNoCache}, + {erl_script_alias, + {"/cgi-bin/erl", [httpd_example,io]}}, + {erl_script_nocache, EsiNoCache} + | HttpdConf]), + Info = httpd:info(Pid), + Port = proplists:get_value(port, Info), + Address = proplists:get_value(bind_address, Info), + ok = httpd_test_lib:verify_request(ip_comm, Address, Port, node(), + "GET /cgi-bin/" ++ CgiScript ++ + " HTTP/1.0\r\n\r\n", + [{statuscode, 200}, + CgiOption, + {version, "HTTP/1.0"}]), + ok = httpd_test_lib:verify_request(ip_comm, Address, Port, node(), + "GET /cgi-bin/erl/httpd_example:get " + "HTTP/1.0\r\n\r\n", + [{statuscode, 200}, + EsiOption, + {version, "HTTP/1.0"}]), + inets:stop(httpd, Pid). + + +%%------------------------------------------------------------------------- +%%------------------------------------------------------------------------- + escaped_url_in_error_body(doc) -> ["Test Url-encoding see OTP-8940"]; escaped_url_in_error_body(suite) -> diff --git a/lib/inets/test/httpd_basic_SUITE_data/printenv.bat b/lib/inets/test/httpd_basic_SUITE_data/printenv.bat new file mode 120000 index 0000000000..1bc8e52059 --- /dev/null +++ b/lib/inets/test/httpd_basic_SUITE_data/printenv.bat @@ -0,0 +1 @@ +../httpd_SUITE_data/server_root/cgi-bin/printenv.bat
\ No newline at end of file diff --git a/lib/inets/test/httpd_basic_SUITE_data/printenv.sh b/lib/inets/test/httpd_basic_SUITE_data/printenv.sh new file mode 120000 index 0000000000..0136a3fa23 --- /dev/null +++ b/lib/inets/test/httpd_basic_SUITE_data/printenv.sh @@ -0,0 +1 @@ +../httpd_SUITE_data/server_root/cgi-bin/printenv.sh
\ No newline at end of file diff --git a/lib/inets/test/httpd_mod.erl b/lib/inets/test/httpd_mod.erl index df4ed6b179..7d3326fb65 100644 --- a/lib/inets/test/httpd_mod.erl +++ b/lib/inets/test/httpd_mod.erl @@ -842,6 +842,14 @@ cgi(Type, Port, Host, Node) -> {version, "HTTP/1.0"}]), %% tsp("cgi -> done"), + + %% Check "ScriptNoCache" directive (default: false) + ok = httpd_test_lib:verify_request(Type, Host, Port, Node, + "GET /cgi-bin/" ++ Script ++ + " HTTP/1.0\r\n\r\n", + [{statuscode, 200}, + {no_header, "cache-control"}, + {version, "HTTP/1.0"}]), ok. @@ -899,6 +907,13 @@ esi(Type, Port, Host, Node) -> " HTTP/1.0\r\n\r\n", [{statuscode, 302}, {version, "HTTP/1.0"}]), + %% Check "ErlScriptNoCache" directive (default: false) + ok = httpd_test_lib:verify_request(Type, Host, Port, Node, + "GET /cgi-bin/erl/httpd_example:get" + " HTTP/1.0\r\n\r\n", + [{statuscode, 200}, + {no_header, "cache-control"}, + {version, "HTTP/1.0"}]), ok. diff --git a/lib/inets/test/httpd_test_lib.erl b/lib/inets/test/httpd_test_lib.erl index 13584c50f6..3e82324a30 100644 --- a/lib/inets/test/httpd_test_lib.erl +++ b/lib/inets/test/httpd_test_lib.erl @@ -361,7 +361,7 @@ do_validate(Header, [{header, HeaderField, Value}|Rest],N,P) -> tsf({wrong_header_field_value, LowerHeaderField, Header}) end, do_validate(Header, Rest, N, P); -do_validate(Header,[{no_last_modified, HeaderField}|Rest],N,P) -> +do_validate(Header,[{no_header, HeaderField}|Rest],N,P) -> case lists:keysearch(HeaderField,1,Header) of {value,_} -> tsf({wrong_header_field_value, HeaderField, Header}); diff --git a/lib/kernel/doc/src/inet.xml b/lib/kernel/doc/src/inet.xml index 254dfbf034..fd62f778a2 100644 --- a/lib/kernel/doc/src/inet.xml +++ b/lib/kernel/doc/src/inet.xml @@ -722,6 +722,59 @@ fe80::204:acff:fe17:bf38 <p>Received <c>Packet</c> is delivered as defined by Mode.</p> </item> + <tag><c>{netns, Namespace :: file:filename_all()}</c></tag> + <item> + <p>Set a network namespace for the socket. The <c>Namespace</c> + parameter is a filename defining the namespace for example + <c>"/var/run/netns/example"</c> typically created by the command + <c>ip netns add example</c>. This option must be used in a + function call that creates a socket i.e + <seealso marker="gen_tcp#connect/3"> + gen_tcp:connect/3,4</seealso>, + <seealso marker="gen_tcp#listen/2"> + gen_tcp:listen/2</seealso>, + <seealso marker="gen_udp#open/1"> + gen_udp:open/1,2</seealso> or + <seealso marker="gen_sctp#open/0"> + gen_sctp:open/0-2</seealso>. + </p> + <p>This option uses the Linux specific syscall + <c>setns()</c> such as in Linux kernel 3.0 or later + and therefore only exists when the runtime system + has been compiled for such an operating system. + </p> + <p> + The virtual machine also needs elevated privileges either + running as superuser or (for Linux) having the capability + <c>CAP_SYS_ADMIN</c> according to the documentation for setns(2). + However, during testing also <c>CAP_SYS_PTRACE</c> + and <c>CAP_DAC_READ_SEARCH</c> has proven to be necessary. + Example:<code> +setcap cap_sys_admin,cap_sys_ptrace,cap_dac_read_search+epi beam.smp +</code> + Note also that the filesystem containing the virtual machine + executable (<c>beam.smp</c> in the example above) has to be local, + mounted without the <c>nosetuid</c> flag, + support extended attributes and that + the kernel has to support file capabilities. + All this runs out of the box on at least Ubuntu 12.04 LTS, + except that SCTP sockets appears to not support + network namespaces. + </p> + <p>The <c>Namespace</c> is a file name and is encoded + and decoded as discussed in + <seealso marker="file">file</seealso> + except that the emulator flag <c>+fnu</c> is ignored and + <seealso marker="#getopts/2">getopts/2</seealso> + for this option will return a binary for the filename + if the stored filename can not be decoded, + which should only happen if you set the option using a binary + that can not be decoded with the emulator's filename encoding: + <seealso marker="file#native_name_encoding/0"> + file:native_name_encoding/0</seealso>. + </p> + </item> + <tag><c>list</c></tag> <item> <p>Received <c>Packet</c> is delivered as a list.</p> diff --git a/lib/kernel/src/hipe_unified_loader.erl b/lib/kernel/src/hipe_unified_loader.erl index e676ca997d..0a0e6003ee 100644 --- a/lib/kernel/src/hipe_unified_loader.erl +++ b/lib/kernel/src/hipe_unified_loader.erl @@ -85,7 +85,7 @@ chunk_name(Architecture) -> %%======================================================================== -spec load_native_code(Mod, binary()) -> 'no_native' | {'module', Mod} - when is_subtype(Mod, atom()). + when Mod :: atom(). %% @doc %% Loads the native code of a module Mod. %% Returns {module,Mod} on success (for compatibility with @@ -148,8 +148,8 @@ version_check(Version, Mod) when is_atom(Mod) -> %%======================================================================== --spec load_module(Mod, binary(), _) -> 'bad_crc' | {'module',Mod} - when is_subtype(Mod,atom()). +-spec load_module(Mod, binary(), _) -> 'bad_crc' | {'module', Mod} + when Mod :: atom(). load_module(Mod, Bin, Beam) -> erlang:system_flag(multi_scheduling, block), try @@ -169,8 +169,8 @@ load_module(Mod, Bin, Beam, OldReferencesToPatch) -> %%======================================================================== --spec load(Mod, binary()) -> 'bad_crc' | {'module',Mod} - when is_subtype(Mod,atom()). +-spec load(Mod, binary()) -> 'bad_crc' | {'module', Mod} when Mod :: atom(). + load(Mod, Bin) -> erlang:system_flag(multi_scheduling, block), try @@ -204,15 +204,17 @@ load_common(Mod, Bin, Beam, OldReferencesToPatch) -> bad_crc; true -> %% Create data segment - {ConstAddr,ConstMap2} = create_data_segment(ConstAlign, ConstSize, ConstMap), + {ConstAddr,ConstMap2} = + create_data_segment(ConstAlign, ConstSize, ConstMap), %% Find callees for which we may need trampolines. CalleeMFAs = find_callee_mfas(Refs), %% Write the code to memory. - {CodeAddress,Trampolines} = enter_code(CodeSize, CodeBinary, CalleeMFAs, Mod, Beam), + {CodeAddress,Trampolines} = + enter_code(CodeSize, CodeBinary, CalleeMFAs, Mod, Beam), %% Construct CalleeMFA-to-trampoline mapping. TrampolineMap = mk_trampoline_map(CalleeMFAs, Trampolines), %% Patch references to code labels in data seg. - patch_consts(LabelMap, ConstAddr, CodeAddress), + ok = patch_consts(LabelMap, ConstAddr, CodeAddress), %% Find out which functions are being loaded (and where). %% Note: Addresses are sorted descending. {MFAs,Addresses} = exports(ExportMap, CodeAddress), @@ -221,7 +223,7 @@ load_common(Mod, Bin, Beam, OldReferencesToPatch) -> ok = remove_refs_from(MFAs), %% Patch all dynamic references in the code. %% Function calls, Atoms, Constants, System calls - patch(Refs, CodeAddress, ConstMap2, Addresses, TrampolineMap), + ok = patch(Refs, CodeAddress, ConstMap2, Addresses, TrampolineMap), %% Tell the system where the loaded funs are. %% (patches the BEAM code to redirect to native.) case Beam of @@ -322,7 +324,7 @@ trampoline_map_get(MFA, Map) -> gb_trees:get(MFA, Map). trampoline_map_lookup(_, []) -> []; % archs not using trampolines trampoline_map_lookup(Primop, Map) -> case gb_trees:lookup(Primop, Map) of - {value,X} -> X; + {value, X} -> X; _ -> [] end. @@ -369,7 +371,7 @@ offsets_to_addresses(Os, Base) -> find_closure_patches([{Type,Refs} | Rest]) -> case ?EXT2PATCH_TYPE(Type) of load_address -> - find_closure_refs(Refs,Rest); + find_closure_refs(Refs, Rest); _ -> find_closure_patches(Rest) end; @@ -404,16 +406,17 @@ export_funs([FunDef | Addresses]) -> hipe_bifs:set_native_address(MFA, Address, IsClosure), export_funs(Addresses); export_funs([]) -> - true. + ok. export_funs(Mod, Beam, Addresses, ClosuresToPatch) -> - Fs = [{F,A,Address} || #fundef{address=Address, mfa={_M,F,A}} <- Addresses], - code:make_stub_module(Mod, Beam, {Fs,ClosuresToPatch}). + Fs = [{F,A,Address} || #fundef{address=Address, mfa={_M,F,A}} <- Addresses], + Mod = code:make_stub_module(Mod, Beam, {Fs,ClosuresToPatch}), + ok. %%======================================================================== %% Patching %% @spec patch(refs(), BaseAddress::integer(), ConstAndZone::term(), -%% Addresses::term(), TrampolineMap::term()) -> term() +%% Addresses::term(), TrampolineMap::term()) -> 'ok'. %% @type refs()=[{RefType::integer(), Reflist::reflist()} | refs()] %% %% @type reflist()= [{Data::term(), Offsets::offests()}|reflist()] @@ -426,7 +429,7 @@ export_funs(Mod, Beam, Addresses, ClosuresToPatch) -> %% patch([{Type,SortedRefs}|Rest], CodeAddress, ConstMap2, Addresses, TrampolineMap) -> - ?debug_msg("Patching ~w at [~w+offset] with ~w\n", + ?debug_msg("Patching ~w at [~w+offset] with ~w\n", [Type,CodeAddress,SortedRefs]), case ?EXT2PATCH_TYPE(Type) of call_local -> @@ -437,7 +440,7 @@ patch([{Type,SortedRefs}|Rest], CodeAddress, ConstMap2, Addresses, TrampolineMap patch_all(Other, SortedRefs, CodeAddress, {ConstMap2,CodeAddress}, Addresses) end, patch(Rest, CodeAddress, ConstMap2, Addresses, TrampolineMap); -patch([], _, _, _, _) -> true. +patch([], _, _, _, _) -> ok. %%---------------------------------------------------------------- %% Handle a 'call_local' or 'call_remote' patch. @@ -459,14 +462,14 @@ patch_call([{DestMFA,Offsets}|SortedRefs], BaseAddress, Addresses, RemoteOrLocal end, patch_call(SortedRefs, BaseAddress, Addresses, RemoteOrLocal, TrampolineMap); patch_call([], _, _, _, _) -> - true. + ok. patch_bif_call_list([Offset|Offsets], BaseAddress, BifAddress, Trampoline) -> CallAddress = BaseAddress+Offset, ?ASSERT(assert_local_patch(CallAddress)), patch_call_insn(CallAddress, BifAddress, Trampoline), patch_bif_call_list(Offsets, BaseAddress, BifAddress, Trampoline); -patch_bif_call_list([], _, _, _) -> []. +patch_bif_call_list([], _, _, _) -> ok. patch_mfa_call_list([Offset|Offsets], BaseAddress, DestMFA, DestAddress, Addresses, RemoteOrLocal, Trampoline) -> CallAddress = BaseAddress+Offset, @@ -474,7 +477,7 @@ patch_mfa_call_list([Offset|Offsets], BaseAddress, DestMFA, DestAddress, Address ?ASSERT(assert_local_patch(CallAddress)), patch_call_insn(CallAddress, DestAddress, Trampoline), patch_mfa_call_list(Offsets, BaseAddress, DestMFA, DestAddress, Addresses, RemoteOrLocal, Trampoline); -patch_mfa_call_list([], _, _, _, _, _, _) -> []. +patch_mfa_call_list([], _, _, _, _, _, _) -> ok. patch_call_insn(CallAddress, DestAddress, Trampoline) -> %% This assertion is false when we're called from redirect/2. @@ -487,7 +490,7 @@ patch_call_insn(CallAddress, DestAddress, Trampoline) -> patch_all(Type, [{Dest,Offsets}|Rest], BaseAddress, ConstAndZone, Addresses)-> patch_all_offsets(Type, Dest, Offsets, BaseAddress, ConstAndZone, Addresses), patch_all(Type, Rest, BaseAddress, ConstAndZone, Addresses); -patch_all(_, [], _, _, _) -> true. +patch_all(_, [], _, _, _) -> ok. patch_all_offsets(Type, Data, [Offset|Offsets], BaseAddress, ConstAndZone, Addresses) -> @@ -497,7 +500,7 @@ patch_all_offsets(Type, Data, [Offset|Offsets], BaseAddress, patch_offset(Type, Data, Address, ConstAndZone, Addresses), ?debug_msg("Patching done\n",[]), patch_all_offsets(Type, Data, Offsets, BaseAddress, ConstAndZone, Addresses); -patch_all_offsets(_, _, [], _, _, _) -> true. +patch_all_offsets(_, _, [], _, _, _) -> ok. %%---------------------------------------------------------------- %% Handle any patch type except 'call_local' or 'call_remote'. diff --git a/lib/kernel/src/inet.erl b/lib/kernel/src/inet.erl index 5749027acd..27f085c3aa 100644 --- a/lib/kernel/src/inet.erl +++ b/lib/kernel/src/inet.erl @@ -200,7 +200,14 @@ send(Socket, Packet) -> Options :: [socket_setopt()]. setopts(Socket, Opts) -> - prim_inet:setopts(Socket, Opts). + SocketOpts = + [case Opt of + {netns,NS} -> + {netns,filename2binary(NS)}; + _ -> + Opt + end || Opt <- Opts], + prim_inet:setopts(Socket, SocketOpts). -spec getopts(Socket, Options) -> {'ok', OptionValues} | {'error', posix()} when @@ -209,7 +216,18 @@ setopts(Socket, Opts) -> OptionValues :: [socket_setopt()]. getopts(Socket, Opts) -> - prim_inet:getopts(Socket, Opts). + case prim_inet:getopts(Socket, Opts) of + {ok,OptionValues} -> + {ok, + [case OptionValue of + {netns,Bin} -> + {netns,binary2filename(Bin)}; + _ -> + OptionValue + end || OptionValue <- OptionValues]}; + Other -> + Other + end. -spec getifaddrs(Socket :: socket()) -> {'ok', [string()]} | {'error', posix()}. @@ -641,6 +659,14 @@ con_opt([Opt | Opts], R, As) -> {tcp_module,_} -> con_opt(Opts, R, As); inet -> con_opt(Opts, R, As); inet6 -> con_opt(Opts, R, As); + {netns,NS} -> + BinNS = filename2binary(NS), + case prim_inet:is_sockopt_val(netns, BinNS) of + true -> + con_opt(Opts, R#connect_opts { fd = [{netns,BinNS}] }, As); + false -> + {error, badarg} + end; {Name,Val} when is_atom(Name) -> con_add(Name, Val, R, Opts, As); _ -> {error, badarg} end; @@ -699,6 +725,14 @@ list_opt([Opt | Opts], R, As) -> {tcp_module,_} -> list_opt(Opts, R, As); inet -> list_opt(Opts, R, As); inet6 -> list_opt(Opts, R, As); + {netns,NS} -> + BinNS = filename2binary(NS), + case prim_inet:is_sockopt_val(netns, BinNS) of + true -> + list_opt(Opts, R#listen_opts { fd = [{netns,BinNS}] }, As); + false -> + {error, badarg} + end; {Name,Val} when is_atom(Name) -> list_add(Name, Val, R, Opts, As); _ -> {error, badarg} end; @@ -745,6 +779,14 @@ udp_opt([Opt | Opts], R, As) -> {udp_module,_} -> udp_opt(Opts, R, As); inet -> udp_opt(Opts, R, As); inet6 -> udp_opt(Opts, R, As); + {netns,NS} -> + BinNS = filename2binary(NS), + case prim_inet:is_sockopt_val(netns, BinNS) of + true -> + list_opt(Opts, R#udp_opts { fd = [{netns,BinNS}] }, As); + false -> + {error, badarg} + end; {Name,Val} when is_atom(Name) -> udp_add(Name, Val, R, Opts, As); _ -> {error, badarg} end; @@ -814,6 +856,17 @@ sctp_opt([Opt|Opts], Mod, R, As) -> {sctp_module,_} -> sctp_opt (Opts, Mod, R, As); % Done with inet -> sctp_opt (Opts, Mod, R, As); % Done with inet6 -> sctp_opt (Opts, Mod, R, As); % Done with + {netns,NS} -> + BinNS = filename2binary(NS), + case prim_inet:is_sockopt_val(netns, BinNS) of + true -> + sctp_opt( + Opts, Mod, + R#sctp_opts { fd = [{netns,BinNS}] }, + As); + false -> + {error, badarg} + end; {Name,Val} -> sctp_opt (Opts, Mod, R, As, Name, Val); _ -> {error,badarg} end; @@ -858,6 +911,39 @@ add_opt(Name, Val, Opts, As) -> end. +%% Passthrough all unknown - catch type errors later +filename2binary(List) when is_list(List) -> + OutEncoding = file:native_name_encoding(), + try unicode:characters_to_binary(List, unicode, OutEncoding) of + Bin when is_binary(Bin) -> + Bin; + _ -> + List + catch + error:badarg -> + List + end; +filename2binary(Bin) -> + Bin. + +binary2filename(Bin) -> + InEncoding = file:native_name_encoding(), + case unicode:characters_to_list(Bin, InEncoding) of + Filename when is_list(Filename) -> + Filename; + _ -> + %% For getopt/setopt of netns this should only happen if + %% a binary with wrong encoding was used when setting the + %% option, hence the user shall eat his/her own medicine. + %% + %% I.e passthrough here too for now. + %% Future usecases will most probably not want this, + %% rather Unicode error or warning + %% depending on emulator flag instead. + Bin + end. + + translate_ip(any, inet) -> {0,0,0,0}; translate_ip(loopback, inet) -> {127,0,0,1}; translate_ip(any, inet6) -> {0,0,0,0,0,0,0,0}; @@ -1070,7 +1156,7 @@ gethostbyaddr_tm_native(Addr, Timer, Opts) -> Result -> Result end. --spec open(Fd :: integer(), +-spec open(Fd_or_OpenOpts :: integer() | list(), Addr :: ip_address(), Port :: port_number(), Opts :: [socket_setopt()], @@ -1080,8 +1166,14 @@ gethostbyaddr_tm_native(Addr, Timer, Opts) -> Module :: atom()) -> {'ok', socket()} | {'error', posix()}. -open(Fd, Addr, Port, Opts, Protocol, Family, Type, Module) when Fd < 0 -> - case prim_inet:open(Protocol, Family, Type) of +open(FdO, Addr, Port, Opts, Protocol, Family, Type, Module) + when is_integer(FdO), FdO < 0; + is_list(FdO) -> + OpenOpts = + if is_list(FdO) -> FdO; + true -> [] + end, + case prim_inet:open(Protocol, Family, Type, OpenOpts) of {ok,S} -> case prim_inet:setopts(S, Opts) of ok -> @@ -1104,7 +1196,8 @@ open(Fd, Addr, Port, Opts, Protocol, Family, Type, Module) when Fd < 0 -> Error -> Error end; -open(Fd, _Addr, _Port, Opts, Protocol, Family, Type, Module) -> +open(Fd, _Addr, _Port, Opts, Protocol, Family, Type, Module) + when is_integer(Fd) -> fdopen(Fd, Opts, Protocol, Family, Type, Module). bindx(S, [Addr], Port0) -> diff --git a/lib/kernel/src/inet_int.hrl b/lib/kernel/src/inet_int.hrl index 67a99913a1..18a4a61b2f 100644 --- a/lib/kernel/src/inet_int.hrl +++ b/lib/kernel/src/inet_int.hrl @@ -143,6 +143,7 @@ -define(INET_LOPT_TCP_SEND_TIMEOUT_CLOSE, 35). -define(INET_LOPT_MSGQ_HIWTRMRK, 36). -define(INET_LOPT_MSGQ_LOWTRMRK, 37). +-define(INET_LOPT_NETNS, 38). % Specific SCTP options: separate range: -define(SCTP_OPT_RTOINFO, 100). -define(SCTP_OPT_ASSOCINFO, 101). diff --git a/lib/kernel/test/inet_SUITE.erl b/lib/kernel/test/inet_SUITE.erl index 46c8c0b88b..ed43749cc0 100644 --- a/lib/kernel/test/inet_SUITE.erl +++ b/lib/kernel/test/inet_SUITE.erl @@ -38,10 +38,10 @@ gethostnative_debug_level/0, gethostnative_debug_level/1, getif/1, getif_ifr_name_overflow/1,getservbyname_overflow/1, getifaddrs/1, - parse_strict_address/1]). + parse_strict_address/1, simple_netns/1]). -export([get_hosts/1, get_ipv6_hosts/1, parse_hosts/1, parse_address/1, - kill_gethost/0, parallell_gethost/0]). + kill_gethost/0, parallell_gethost/0, test_netns/0]). -export([init_per_testcase/2, end_per_testcase/2]). suite() -> [{ct_hooks,[ts_install_cth]}]. @@ -53,7 +53,7 @@ all() -> t_gethostnative, gethostnative_parallell, cname_loop, gethostnative_debug_level, gethostnative_soft_restart, getif, getif_ifr_name_overflow, getservbyname_overflow, - getifaddrs, parse_strict_address]. + getifaddrs, parse_strict_address, simple_netns]. groups() -> [{parse, [], [parse_hosts, parse_address]}]. @@ -1099,3 +1099,96 @@ toupper([C|Cs]) when is_integer(C) -> end; toupper([]) -> []. + + +simple_netns(Config) when is_list(Config) -> + {ok,U} = gen_udp:open(0), + case inet:setopts(U, [{netns,""}]) of + ok -> + jog_netns_opt(U), + ok = gen_udp:close(U), + %% + {ok,L} = gen_tcp:listen(0, []), + jog_netns_opt(L), + ok = gen_tcp:close(L), + %% + {ok,S} = gen_sctp:open(), + jog_netns_opt(S), + ok = gen_sctp:close(S); + {error,einval} -> + {skip,"setns() not supported"} + end. + +jog_netns_opt(S) -> + %% This is just jogging the option mechanics + ok = inet:setopts(S, [{netns,""}]), + {ok,[{netns,""}]} = inet:getopts(S, [netns]), + ok = inet:setopts(S, [{netns,"/proc/self/ns/net"}]), + {ok,[{netns,"/proc/self/ns/net"}]} = inet:getopts(S, [netns]), + ok. + + +%% Manual test to be run outside test_server in an emulator +%% started by root, in a machine with setns() support... +test_netns() -> + DefaultIF = v1, + DefaultIP = {192,168,1,17}, + Namespace = "test", + NamespaceIF = v2, + NamespaceIP = {192,168,1,18}, + %% + DefaultIPString = inet_parse:ntoa(DefaultIP), + NamespaceIPString = inet_parse:ntoa(NamespaceIP), + cmd("ip netns add ~s", + [Namespace]), + cmd("ip link add name ~w type veth peer name ~w netns ~s", + [DefaultIF,NamespaceIF,Namespace]), + cmd("ip netns exec ~s ip addr add ~s/30 dev ~w", + [Namespace,NamespaceIPString,NamespaceIF]), + cmd("ip netns exec ~s ip link set ~w up", + [Namespace,NamespaceIF]), + cmd("ip addr add ~s/30 dev ~w", + [DefaultIPString,DefaultIF]), + cmd("ip link set ~w up", + [DefaultIF]), + try test_netns( + {DefaultIF,DefaultIP}, + filename:join("/var/run/netns/", Namespace), + {NamespaceIF,NamespaceIP}) of + Result -> + io:put_chars(["#### Test done",io_lib:nl()]), + Result + after + cmd("ip link delete ~w type veth", + [DefaultIF]), + cmd("ip netns delete ~s", + [Namespace]) + end. + +test_netns({DefaultIF,DefaultIP}, Namespace, {NamespaceIF,NamespaceIP}) -> + {ok,ListenSocket} = gen_tcp:listen(0, [{active,false}]), + {ok,[{addr,DefaultIP}]} = inet:ifget(ListenSocket, DefaultIF, [addr]), + {ok,ListenPort} = inet:port(ListenSocket), + {ok,ConnectSocket} = + gen_tcp:connect( + DefaultIP, ListenPort, [{active,false},{netns,Namespace}], 3000), + {ok,[{addr,NamespaceIP}]} = inet:ifget(ConnectSocket, NamespaceIF, [addr]), + {ok,ConnectPort} = inet:port(ConnectSocket), + {ok,AcceptSocket} = gen_tcp:accept(ListenSocket, 0), + {ok,AcceptPort} = inet:port(AcceptSocket), + {ok,{NamespaceIP,ConnectPort}} = inet:peername(AcceptSocket), + {ok,{DefaultIP,AcceptPort}} = inet:peername(ConnectSocket), + ok = gen_tcp:send(ConnectSocket, "data"), + ok = gen_tcp:close(ConnectSocket), + {ok,"data"} = gen_tcp:recv(AcceptSocket, 4, 1000), + {error,closed} = gen_tcp:recv(AcceptSocket, 1, 1000), + ok = gen_tcp:close(AcceptSocket), + ok = gen_tcp:close(ListenSocket). + +cmd(Cmd, Args) -> + cmd(io_lib:format(Cmd, Args)). +%% +cmd(CmdString) -> + io:put_chars(["# ",CmdString,io_lib:nl()]), + io:put_chars([os:cmd(CmdString++" ; echo ' =>' $?")]), + ok. diff --git a/lib/odbc/test/odbc_connect_SUITE.erl b/lib/odbc/test/odbc_connect_SUITE.erl index 74ae2c96e6..2a16388929 100644 --- a/lib/odbc/test/odbc_connect_SUITE.erl +++ b/lib/odbc/test/odbc_connect_SUITE.erl @@ -77,6 +77,8 @@ end_per_group(_GroupName, Config) -> %% variable, but should NOT alter/remove any existing entries. %%-------------------------------------------------------------------- init_per_suite(Config) when is_list(Config) -> + file:write_file(filename:join([proplists:get_value(priv_dir,Config), + "..","..","..","ignore_core_files"]),""), case odbc_test_lib:skip() of true -> {skip, "ODBC not supported"}; diff --git a/lib/os_mon/c_src/Makefile.in b/lib/os_mon/c_src/Makefile.in index 51569f6ec9..f84ccf7c87 100644 --- a/lib/os_mon/c_src/Makefile.in +++ b/lib/os_mon/c_src/Makefile.in @@ -84,6 +84,7 @@ debug opt: $(TARGET_FILES) clean: rm -f $(TARGET_FILES) + rm -rf $(OBJDIR) rm -f core *~ docs: diff --git a/lib/os_mon/c_src/cpu_sup.c b/lib/os_mon/c_src/cpu_sup.c index 7372d5b0e8..e9fd75a32c 100644 --- a/lib/os_mon/c_src/cpu_sup.c +++ b/lib/os_mon/c_src/cpu_sup.c @@ -29,6 +29,7 @@ #include <stdio.h> #include <stdlib.h> #include <unistd.h> +#include <string.h> #if defined(__sun__) #include <kstat.h> @@ -120,7 +121,9 @@ typedef struct { static void util_measure(unsigned int **result_vec, int *result_sz); +#if defined(__sun__) static unsigned int misc_measure(char* name); +#endif static void send(unsigned int data); static void sendv(unsigned int data[], int ints); static void error(char* err_msg); @@ -140,7 +143,9 @@ int main(int argc, char** argv) { int rc; int sz; unsigned int *rv; +#if defined(__linux__) unsigned int no_of_cpus = 0; +#endif #if defined(__sun__) kstat_ctl = kstat_open(); @@ -288,10 +293,10 @@ static unsigned int misc_measure(char* name) { if(!entry) return -1; - if(entry->data_type != KSTAT_DATA_ULONG) + if(entry->data_type != KSTAT_DATA_UINT32) return -1; - return entry->value.ul; + return entry->value.ui32; } diff --git a/lib/os_mon/test/cpu_sup_SUITE.erl b/lib/os_mon/test/cpu_sup_SUITE.erl index d04adbb6d3..e0382cb0c7 100644 --- a/lib/os_mon/test/cpu_sup_SUITE.erl +++ b/lib/os_mon/test/cpu_sup_SUITE.erl @@ -88,6 +88,7 @@ load_api(Config) when is_list(Config) -> ?line N = cpu_sup:nprocs(), ?line true = is_integer(N), ?line true = N>0, + ?line true = N<1000000, %% avg1() ?line Load1 = cpu_sup:avg1(), diff --git a/lib/stdlib/src/erl_lint.erl b/lib/stdlib/src/erl_lint.erl index 8f07750b9b..f599881c07 100644 --- a/lib/stdlib/src/erl_lint.erl +++ b/lib/stdlib/src/erl_lint.erl @@ -1953,12 +1953,10 @@ expr({string,_Line,_S}, _Vt, St) -> {[],St}; expr({nil,_Line}, _Vt, St) -> {[],St}; expr({cons,_Line,H,T}, Vt, St) -> expr_list([H,T], Vt, St); -expr({lc,_Line,E,Qs}, Vt0, St0) -> - {Vt,St} = handle_comprehension(E, Qs, Vt0, St0), - {vtold(Vt, Vt0),St}; %Don't export local variables -expr({bc,_Line,E,Qs}, Vt0, St0) -> - {Vt,St} = handle_comprehension(E, Qs, Vt0, St0), - {vtold(Vt,Vt0),St}; %Don't export local variables +expr({lc,_Line,E,Qs}, Vt, St) -> + handle_comprehension(E, Qs, Vt, St); +expr({bc,_Line,E,Qs}, Vt, St) -> + handle_comprehension(E, Qs, Vt, St); expr({tuple,_Line,Es}, Vt, St) -> expr_list(Es, Vt, St); expr({record_index,Line,Name,Field}, _Vt, St) -> @@ -2012,8 +2010,7 @@ expr({'fun',Line,Body}, Vt, St) -> %%No one can think funs export! case Body of {clauses,Cs} -> - {Bvt, St1} = fun_clauses(Cs, Vt, St), - {vtupdate(Bvt, Vt), St1}; + fun_clauses(Cs, Vt, St); {function,F,A} -> %% BifClash - Fun expression %% N.B. Only allows BIFs here as well, NO IMPORTS!! @@ -2111,12 +2108,12 @@ expr({'try',Line,Es,Scs,Ccs,As}, Vt, St0) -> {Evt0,St1} = exprs(Es, Vt, St0), TryLine = {'try',Line}, Uvt = vtunsafe(vtnames(vtnew(Evt0, Vt)), TryLine, []), - Evt1 = vtupdate(Uvt, vtupdate(Evt0, Vt)), - {Sccs,St2} = icrt_clauses(Scs++Ccs, TryLine, Evt1, St1), + Evt1 = vtupdate(Uvt, vtsubtract(Evt0, Uvt)), + {Sccs,St2} = icrt_clauses(Scs++Ccs, TryLine, vtupdate(Evt1, Vt), St1), Rvt0 = Sccs, Rvt1 = vtupdate(vtunsafe(vtnames(vtnew(Rvt0, Vt)), TryLine, []), Rvt0), Evt2 = vtmerge(Evt1, Rvt1), - {Avt0,St} = exprs(As, Evt2, St2), + {Avt0,St} = exprs(As, vtupdate(Evt2, Vt), St2), Avt1 = vtupdate(vtunsafe(vtnames(vtnew(Avt0, Vt)), TryLine, []), Avt0), Avt = vtmerge(Evt2, Avt1), {Avt,St}; @@ -2150,10 +2147,11 @@ expr({remote,Line,_M,_F}, _Vt, St) -> %% {UsedVarTable,State} expr_list(Es, Vt, St) -> - foldl(fun (E, {Esvt,St0}) -> - {Evt,St1} = expr(E, Vt, St0), - {vtmerge(Evt, Esvt),St1} - end, {[],St}, Es). + {Vt1,St1} = foldl(fun (E, {Esvt,St0}) -> + {Evt,St1} = expr(E, Vt, St0), + {vtmerge_pat(Evt, Esvt),St1} + end, {[],St}, Es), + {vtmerge(vtnew(Vt1, Vt), vtold(Vt1, Vt)),St1}. record_expr(Line, Rec, Vt, St0) -> St1 = warn_invalid_record(Line, Rec, St0), @@ -2310,7 +2308,7 @@ check_fields(Fs, Name, Fields, Vt, St0, CheckFun) -> check_field({record_field,Lf,{atom,La,F},Val}, Name, Fields, Vt, St, Sfs, CheckFun) -> case member(F, Sfs) of - true -> {Sfs,{Vt,add_error(Lf, {redefine_field,Name,F}, St)}}; + true -> {Sfs,{[],add_error(Lf, {redefine_field,Name,F}, St)}}; false -> {[F|Sfs], case find_field(F, Fields) of @@ -2843,7 +2841,9 @@ icrt_export(Csvt, Vt, In, St) -> Uvt = vtmerge(Evt, Unused), %% Make exported and unsafe unused variables unused in subsequent code: Vt2 = vtmerge(Uvt, vtsubtract(Vt1, Uvt)), - {Vt2,St}. + %% Forget about old variables which were not used: + Vt3 = vtmerge(vtnew(Vt2, Vt), vt_no_unused(vtold(Vt2, Vt))), + {Vt3,St}. handle_comprehension(E, Qs, Vt0, St0) -> {Vt1, Uvt, St1} = lc_quals(Qs, Vt0, St0), @@ -2856,7 +2856,11 @@ handle_comprehension(E, Qs, Vt0, St0) -> %% Local variables that have not been shadowed. {_,St} = check_unused_vars(Vt2, Vt0, St4), Vt3 = vtmerge(vtsubtract(Vt2, Uvt), Uvt), - {Vt3,St}. + %% Don't export local variables. + Vt4 = vtold(Vt3, Vt0), + %% Forget about old variables which were not used. + Vt5 = vt_no_unused(Vt4), + {Vt5,St}. %% lc_quals(Qualifiers, ImportVarTable, State) -> %% {VarTable,ShadowedVarTable,State} @@ -2920,7 +2924,7 @@ fun_clauses(Cs, Vt, St) -> {Cvt,St1} = fun_clause(C, Vt, St0), {vtmerge(Cvt, Bvt0),St1} end, {[],St#lint{recdef_top = false}}, Cs), - {Bvt,St2#lint{recdef_top = OldRecDef}}. + {vt_no_unused(vtold(Bvt, Vt)),St2#lint{recdef_top = OldRecDef}}. fun_clause({clause,_Line,H,G,B}, Vt0, St0) -> {Hvt,Binvt,St1} = head(H, Vt0, [], St0), % No imported pattern variables @@ -3181,6 +3185,8 @@ vt_no_unsafe(Vt) -> [V || {_,{S,_U,_L}}=V <- Vt, _ -> true end]. +vt_no_unused(Vt) -> [V || {_,{_,U,_L}}=V <- Vt, U =/= unused]. + %% vunion(VarTable1, VarTable2) -> [VarName]. %% vunion([VarTable]) -> [VarName]. %% vintersection(VarTable1, VarTable2) -> [VarName]. diff --git a/lib/stdlib/test/erl_lint_SUITE.erl b/lib/stdlib/test/erl_lint_SUITE.erl index 4dc7a44064..48ddeac478 100644 --- a/lib/stdlib/test/erl_lint_SUITE.erl +++ b/lib/stdlib/test/erl_lint_SUITE.erl @@ -151,7 +151,16 @@ unused_vars_warn_basic(Config) when is_list(Config) -> {22,erl_lint,{unused_var,'N'}}, {23,erl_lint,{shadowed_var,'N','fun'}}, {28,erl_lint,{unused_var,'B'}}, - {29,erl_lint,{unused_var,'B'}}]}}], + {29,erl_lint,{unused_var,'B'}}]}}, + {basic2, + <<"-record(r, {x,y}). + f({X,Y}) -> {Z=X,Z=Y}; + f([H|T]) -> [Z=H|Z=T]; + f(#r{x=X,y=Y}) -> #r{x=A=X,y=A=Y}. + g({M, F}) -> (Z=M):(Z=F)(); + g({M, F, Arg}) -> (Z=M):F(Z=Arg). + h(X, Y) -> (Z=X) + (Z=Y).">>, + [warn_unused_vars], []}], ?line [] = run(Config, Ts), ok. @@ -537,7 +546,29 @@ unused_vars_warn_rec(Config) when is_list(Config) -> end. ">>, [warn_unused_vars], - {warnings,[{22,erl_lint,{unused_var,'Same'}}]}}], + {warnings,[{22,erl_lint,{unused_var,'Same'}}]}}, + {rec2, + <<"-record(r, {a,b}). + f(X, Y) -> #r{a=[K || K <- Y], b=[K || K <- Y]}. + g(X, Y) -> #r{a=lists:map(fun (K) -> K end, Y), + b=lists:map(fun (K) -> K end, Y)}. + h(X, Y) -> #r{a=case Y of _ when is_list(Y) -> Y end, + b=case Y of _ when is_list(Y) -> Y end}. + i(X, Y) -> #r{a=if is_list(Y) -> Y end, b=if is_list(Y) -> Y end}. + ">>, + [warn_unused_vars], + {warnings,[{2,erl_lint,{unused_var,'X'}}, + {3,erl_lint,{unused_var,'X'}}, + {5,erl_lint,{unused_var,'X'}}, + {7,erl_lint,{unused_var,'X'}}]}}, + {rec3, + <<"-record(r, {a}). + t() -> X = 1, #r{a=foo, a=bar, a=qux}. + ">>, + [warn_unused_vars], + {error,[{2,erl_lint,{redefine_field,r,a}}, + {2,erl_lint,{redefine_field,r,a}}], + [{2,erl_lint,{unused_var,'X'}}]}}], ?line [] = run(Config, Ts), ok. @@ -1075,7 +1106,24 @@ unsafe_vars_try(Config) when is_list(Config) -> {10,erl_lint,{unsafe_var,'Ra',{'try',3}}}, {10,erl_lint,{unsafe_var,'Rc',{'try',3}}}, {10,erl_lint,{unsafe_var,'Ro',{'try',3}}}], - []}}], + []}}, + {unsafe_try5, + <<"bang() -> + case 1 of + nil -> + Acc = 2; + _ -> + try + Acc = 3, + Acc + catch _:_ -> + ok + end + end, + Acc. + ">>, + [], + {errors,[{13,erl_lint,{unsafe_var,'Acc',{'try',6}}}],[]}}], ?line [] = run(Config, Ts), ok. diff --git a/lib/test_server/src/test_server_ctrl.erl b/lib/test_server/src/test_server_ctrl.erl index 4a10684ea5..d0f31af198 100644 --- a/lib/test_server/src/test_server_ctrl.erl +++ b/lib/test_server/src/test_server_ctrl.erl @@ -1171,7 +1171,13 @@ init_tester(Mod, Func, Args, Dir, Name, {_,_,MinLev}=Levels, "<td>~.3fs</td><td><b>~ts</b></td><td>~w Ok, ~w Failed~ts of ~w</td></tr>\n" "</tfoot>\n", [Time,SuccessStr,OkN,FailedN,SkipStr,OkN+FailedN+SkippedN]), - test_server_io:stop([major,html,unexpected_io]). + + test_server_io:stop([major,html,unexpected_io]), + {UnexpectedIoName,UnexpectedIoFooter} = get(test_server_unexpected_footer), + {ok,UnexpectedIoFd} = open_html_file(UnexpectedIoName, [append]), + io:put_chars(UnexpectedIoFd, "\n</pre>\n"++UnexpectedIoFooter), + file:close(UnexpectedIoFd), + ok. report_severe_error(Reason) -> test_server_sup:framework_call(report, [severe_error,Reason]). @@ -1630,15 +1636,13 @@ start_log_file() -> FilenameMode), ok = write_file(?last_file, TestDir1 ++ "\n", FilenameMode), put(test_server_log_dir_base,TestDir1), + MajorName = filename:join(TestDir1, ?suitelog_name), HtmlName = MajorName ++ ?html_ext, UnexpectedName = filename:join(TestDir1, ?unexpected_io_log), + {ok,Major} = open_utf8_file(MajorName), {ok,Html} = open_html_file(HtmlName), - {ok,Unexpected} = open_html_file(UnexpectedName), - test_server_io:set_fd(major, Major), - test_server_io:set_fd(html, Html), - test_server_io:set_fd(unexpected_io, Unexpected), {UnexpHeader,UnexpFooter} = case test_server_sup:framework_call(get_html_wrapper, @@ -1651,8 +1655,17 @@ start_log_file() -> {xhtml,UH,UF} -> {UH,UF} end, - io:put_chars(Unexpected, UnexpHeader++"\n<pre>\n"), - put(test_server_unexpected_footer,UnexpFooter), + + {ok,Unexpected} = open_html_file(UnexpectedName), + io:put_chars(Unexpected, [UnexpHeader, + xhtml("<br>\n<h2>Unexpected I/O</h2>", + "<br />\n<h3>Unexpected I/O</h3>"), + "\n<pre>\n"]), + put(test_server_unexpected_footer,{UnexpectedName,UnexpFooter}), + + test_server_io:set_fd(major, Major), + test_server_io:set_fd(html, Html), + test_server_io:set_fd(unexpected_io, Unexpected), make_html_link(filename:absname(?last_test ++ ?html_ext), HtmlName, filename:basename(Dir)), @@ -5287,6 +5300,9 @@ html_header(Title) -> open_html_file(File) -> open_utf8_file(File). +open_html_file(File,Opts) -> + open_utf8_file(File,Opts). + write_html_file(File,Content) -> write_file(File,Content,utf8). @@ -5295,6 +5311,9 @@ write_html_file(File,Content) -> open_utf8_file(File) -> file:open(File,[write,{encoding,utf8}]). +open_utf8_file(File,Opts) -> + file:open(File,[{encoding,utf8}|Opts]). + %% Write a file with specified encoding write_file(File,Content,latin1) -> file:write_file(File,Content); diff --git a/lib/test_server/src/test_server_io.erl b/lib/test_server/src/test_server_io.erl index 73d4468bda..62af3d5b28 100644 --- a/lib/test_server/src/test_server_io.erl +++ b/lib/test_server/src/test_server_io.erl @@ -32,27 +32,39 @@ -export([start_link/0,stop/1,get_gl/1,set_fd/2, start_transaction/0,end_transaction/0, print_buffered/1,print/3,print_unexpected/1, - set_footer/1,set_job_name/1,set_gl_props/1]). + set_footer/1,set_job_name/1,set_gl_props/1, + reset_state/0,finish/0]). -export([init/1,handle_call/3,handle_info/2,terminate/2]). --record(st, {fds, %Singleton fds (gb_tree) - shared_gl :: pid(), %Shared group leader - gls, %Group leaders (gb_set) - io_buffering=false, %I/O buffering - buffered, %Buffered I/O requests - html_footer, %HTML footer - job_name, %Name of current job. - gl_props, %Properties for GL. - stopping +-record(st, {fds, % Singleton fds (gb_tree) + tags=[], % Known tag types + shared_gl :: pid(), % Shared group leader + gls, % Group leaders (gb_set) + io_buffering=false, % I/O buffering + buffered, % Buffered I/O requests + html_footer, % HTML footer + job_name, % Name of current job. + gl_props, % Properties for GL + phase, % Indicates current mode + offline_buffer, % Buffer I/O during startup + stopping, % Reply to when process stopped + pending_ops % Perform when process idle }). start_link() -> - case gen_server:start_link({local,?MODULE}, ?MODULE, [], []) of - {ok,Pid} -> - {ok,Pid}; - Other -> - Other + case whereis(?MODULE) of + undefined -> + case gen_server:start_link({local,?MODULE}, ?MODULE, [], []) of + {ok,Pid} -> + {ok,Pid}; + Other -> + Other + end; + Pid -> + %% already running, reset the state + reset_state(), + {ok,Pid} end. stop(FilesToClose) -> @@ -62,6 +74,9 @@ stop(FilesToClose) -> group_leader(OldGL, self()), ok. +finish() -> + req(finish). + %% get_gl(Shared) -> Pid %% Shared = boolean() %% Pid = pid() @@ -142,19 +157,27 @@ set_footer(Footer) -> req({set_footer,Footer}). %% set_job_name(Name) +%% %% Set a name for the currently running job. The name will be used %% when printing to 'stdout'. %% + set_job_name(Name) -> req({set_job_name,Name}). %% set_gl_props(PropList) +%% %% Set properties for group leader processes. When a group_leader process %% is created, test_server_gl:set_props(PropList) will be called. set_gl_props(PropList) -> req({set_gl_props,PropList}). +%% reset_state +%% +%% Reset the initial state +reset_state() -> + req(reset_state). %%% Internal functions. @@ -167,7 +190,10 @@ init([]) -> buffered=Empty, html_footer="</body>\n</html>\n", job_name="<name not set>", - gl_props=[]}}. + gl_props=[], + phase=starting, + offline_buffer=[], + pending_ops=[]}}. req(Req) -> gen_server:call(?MODULE, Req, infinity). @@ -178,9 +204,24 @@ handle_call({get_gl,false}, _From, #st{gls=Gls,gl_props=Props}=St) -> {reply,Pid,St#st{gls=gb_sets:insert(Pid, Gls)}}; handle_call({get_gl,true}, _From, #st{shared_gl=Shared}=St) -> {reply,Shared,St}; -handle_call({set_fd,Tag,Fd}, _From, #st{fds=Fds0}=St) -> +handle_call({set_fd,Tag,Fd}, _From, #st{fds=Fds0,tags=Tags0, + offline_buffer=OfflineBuff}=St) -> Fds = gb_trees:enter(Tag, Fd, Fds0), - {reply,ok,St#st{fds=Fds}}; + St1 = St#st{fds=Fds,tags=[Tag|lists:delete(Tag, Tags0)]}, + OfflineBuff1 = + if OfflineBuff == [] -> + []; + true -> + %% Fd ready, print anything buffered for associated Tag + lists:filtermap(fun({T,From,Str}) when T == Tag -> + output(From, Tag, Str, St1), + false; + (_) -> + true + end, lists:reverse(OfflineBuff)) + end, + {reply,ok,St1#st{phase=started, + offline_buffer=lists:reverse(OfflineBuff1)}}; handle_call({start_transaction,Pid}, _From, #st{io_buffering=Buffer0, buffered=Buf0}=St) -> Buf = case gb_trees:is_defined(Pid, Buf0) of @@ -213,12 +254,15 @@ handle_call({set_job_name,Name}, _From, St) -> handle_call({set_gl_props,Props}, _From, #st{shared_gl=Shared}=St) -> test_server_gl:set_props(Shared, Props), {reply,ok,St#st{gl_props=Props}}; -handle_call({stop,FdTags}, From, #st{fds=Fds,shared_gl=SGL,gls=Gls0}=St0) -> - St = St0#st{gls=gb_sets:insert(SGL, Gls0),stopping=From}, - gc(St), - %% Give the users of the surviving group leaders some - %% time to finish. - erlang:send_after(2000, self(), stop_group_leaders), +handle_call(reset_state, From, #st{phase=stopping,pending_ops=Ops}=St) -> + %% can't reset during stopping phase, save op for later + Op = fun(NewSt) -> + {_,Result,NewSt1} = handle_call(reset_state, From, NewSt), + {Result,NewSt1} + end, + {noreply,St#st{pending_ops=[{From,Op}|Ops]}}; +handle_call(reset_state, _From, #st{fds=Fds,tags=Tags,gls=Gls, + offline_buffer=OfflineBuff}) -> %% close open log files lists:foreach(fun(Tag) -> case gb_trees:lookup(Tag, Fds) of @@ -227,8 +271,50 @@ handle_call({stop,FdTags}, From, #st{fds=Fds,shared_gl=SGL,gls=Gls0}=St0) -> {value,Fd} -> file:close(Fd) end - end, FdTags), - {noreply,St}. + end, Tags), + GlList = gb_sets:to_list(Gls), + [test_server_gl:stop(GL) || GL <- GlList], + timer:sleep(100), + case lists:filter(fun(GlPid) -> is_process_alive(GlPid) end, GlList) of + [] -> + ok; + _ -> + timer:sleep(2000), + [exit(GL, kill) || GL <- GlList] + end, + Empty = gb_trees:empty(), + {ok,Shared} = test_server_gl:start_link(), + {reply,ok,#st{fds=Empty,shared_gl=Shared,gls=gb_sets:empty(), + io_buffering=gb_sets:empty(), + buffered=Empty, + html_footer="</body>\n</html>\n", + job_name="<name not set>", + gl_props=[], + phase=starting, + offline_buffer=OfflineBuff, + pending_ops=[]}}; +handle_call({stop,FdTags}, From, #st{fds=Fds0,tags=Tags0, + shared_gl=SGL,gls=Gls0}=St0) -> + St = St0#st{gls=gb_sets:insert(SGL, Gls0),phase=stopping,stopping=From}, + gc(St), + %% close open log files + {Fds1,Tags1} = lists:foldl(fun(Tag, {Fds,Tags}) -> + case gb_trees:lookup(Tag, Fds) of + none -> + {Fds,Tags}; + {value,Fd} -> + file:close(Fd), + {gb_trees:delete(Tag, Fds), + lists:delete(Tag, Tags)} + end + end, {Fds0,Tags0}, FdTags), + %% Give the users of the surviving group leaders some + %% time to finish. + erlang:send_after(1000, self(), stop_group_leaders), + {noreply,St#st{fds=Fds1,tags=Tags1}}; +handle_call(finish, From, St) -> + gen_server:reply(From, ok), + {stop,normal,St}. handle_info({'EXIT',Pid,normal}, #st{gls=Gls0,stopping=From}=St) -> Gls = gb_sets:delete_any(Pid, Gls0), @@ -236,22 +322,40 @@ handle_info({'EXIT',Pid,normal}, #st{gls=Gls0,stopping=From}=St) -> true -> %% No more group leaders left. gen_server:reply(From, ok), - {stop,normal,St#st{gls=Gls,stopping=undefined}}; + {noreply,St#st{gls=Gls,phase=stopping,stopping=undefined}}; false -> %% Wait for more group leaders to finish. - {noreply,St#st{gls=Gls}} + {noreply,St#st{gls=Gls,phase=stopping}} end; handle_info({'EXIT',_Pid,Reason}, _St) -> exit(Reason); handle_info(stop_group_leaders, #st{gls=Gls}=St) -> %% Stop the remaining group leaders. - [test_server_gl:stop(GL) || GL <- gb_sets:to_list(Gls)], - erlang:send_after(2000, self(), kill_group_leaders), + GlPids = gb_sets:to_list(Gls), + [test_server_gl:stop(GL) || GL <- GlPids], + timer:sleep(100), + Wait = + case lists:filter(fun(GlPid) -> is_process_alive(GlPid) end, GlPids) of + [] -> 0; + _ -> 2000 + end, + erlang:send_after(Wait, self(), kill_group_leaders), {noreply,St}; -handle_info(kill_group_leaders, #st{gls=Gls,stopping=From}=St) -> +handle_info(kill_group_leaders, #st{gls=Gls,stopping=From, + pending_ops=Ops}=St) -> [exit(GL, kill) || GL <- gb_sets:to_list(Gls)], - gen_server:reply(From, ok), - {stop,normal,St}; + if From /= undefined -> + gen_server:reply(From, ok); + true -> % reply has been sent already + ok + end, + %% we're idle, check if any ops are pending + St1 = lists:foldr(fun({ReplyTo,Op},NewSt) -> + {Result,NewSt1} = Op(NewSt), + gen_server:reply(ReplyTo, Result), + NewSt1 + end, St#st{phase=idle,pending_ops=[]}, Ops), + {noreply,St1}; handle_info(Other, St) -> io:format("Ignoring: ~p\n", [Other]), {noreply,St}. @@ -259,11 +363,19 @@ handle_info(Other, St) -> terminate(_, _) -> ok. -output(From, Tag, Str, #st{io_buffering=Buffered,buffered=Buf0}=St) -> +output(From, Tag, Str, #st{io_buffering=Buffered,buffered=Buf0, + phase=Phase,offline_buffer=OfflineBuff}=St) -> case gb_sets:is_member(From, Buffered) of false -> - do_output(Tag, Str, St), - St; + case do_output(Tag, Str, Phase, St) of + buffer when length(OfflineBuff)>500 -> + %% something's wrong, clear buffer + St#st{offline_buffer=[]}; + buffer -> + St#st{offline_buffer=[{Tag,From,Str}|OfflineBuff]}; + _ -> + St + end; true -> Q0 = gb_trees:get(From, Buf0), Q = queue:in({Tag,Str}, Q0), @@ -271,17 +383,19 @@ output(From, Tag, Str, #st{io_buffering=Buffered,buffered=Buf0}=St) -> St#st{buffered=Buf} end. -do_output(stdout, Str, #st{job_name=undefined}) -> +do_output(stdout, Str, _, #st{job_name=undefined}) -> io:put_chars(Str); -do_output(stdout, Str0, #st{job_name=Name}) -> +do_output(stdout, Str0, _, #st{job_name=Name}) -> Str = io_lib:format("Testing ~ts: ~ts\n", [Name,Str0]), io:put_chars(Str); -do_output(Tag, Str, #st{fds=Fds}=St) -> +do_output(Tag, Str, Phase, #st{fds=Fds}=St) -> case gb_trees:lookup(Tag, Fds) of + none when Phase /= started -> + buffer; none -> S = io_lib:format("\n*** ERROR: ~w, line ~w: No known '~p' log file\n", [?MODULE,?LINE,Tag]), - do_output(stdout, [S,Str], St); + do_output(stdout, [S,Str], Phase, St); {value,Fd} -> try io:put_chars(Fd, Str), @@ -293,14 +407,14 @@ do_output(Tag, Str, #st{fds=Fds}=St) -> S = io_lib:format("\n*** ERROR: ~w, line ~w: Error writing to " "log file '~p': ~p\n", [?MODULE,?LINE,Tag,Error]), - do_output(stdout, [S,Str], St) + do_output(stdout, [S,Str], Phase, St) end end. finalise_table(Fd, #st{html_footer=Footer}) -> case file:position(Fd, {cur,0}) of {ok,Pos} -> - %% We are writing to a seekable file. Finalise so + %% We are writing to a seekable file. Finalise so %% we get complete valid (and viewable) HTML code. %% Then rewind to overwrite the finalising code. io:put_chars(Fd, ["\n</table>\n",Footer]), @@ -319,7 +433,7 @@ do_print_buffered(Q0, St) -> eot -> Q; {Tag,Str} -> - do_output(Tag, Str, St), + do_output(Tag, Str, undefined, St), do_print_buffered(Q, St) end. |