diff options
Diffstat (limited to 'lib')
385 files changed, 11935 insertions, 7638 deletions
diff --git a/lib/Makefile b/lib/Makefile index 4740e6eb59..ae466ed518 100644 --- a/lib/Makefile +++ b/lib/Makefile @@ -35,7 +35,7 @@ ALL_ERLANG_APPLICATIONS = xmerl edoc erl_docgen snmp otp_mibs erl_interface \ public_key ssl observer odbc diameter \ cosTransactions cosEvent cosTime cosNotification \ cosProperty cosFileTransfer cosEventDomain et megaco \ - eunit ssh typer eldap dialyzer hipe + eunit ssh eldap dialyzer hipe ifdef BUILD_ALL ERLANG_APPLICATIONS += $(ALL_ERLANG_APPLICATIONS) diff --git a/lib/asn1/doc/src/asn1_getting_started.xml b/lib/asn1/doc/src/asn1_getting_started.xml index d2b73d63c3..c036d289fc 100644 --- a/lib/asn1/doc/src/asn1_getting_started.xml +++ b/lib/asn1/doc/src/asn1_getting_started.xml @@ -266,6 +266,10 @@ asn1ct:compile("H323-MESSAGES.asn1",[per]). </pre> <c>{error, {asn1, Description}}</c> where <c>Description</c> is an Erlang term describing the error.</p> + <p>Currently, <c>Description</c> looks like this: + <c>{ErrorDescription, StackTrace}</c>. Applications should + not depend on the exact contents of <c>Description</c> as it + could change in the future.</p> </section> </section> diff --git a/lib/asn1/examples/recordnames.txt b/lib/asn1/examples/recordnames.txt index 78e30ab510..9b890b4aa7 100644 --- a/lib/asn1/examples/recordnames.txt +++ b/lib/asn1/examples/recordnames.txt @@ -1,6 +1,6 @@ For each ASN1 types SET and SEQUENCE a record is generated in the .hrl file with the same name as the corresponding type. -A decoded value is also returned as a record with the apropriate name. +A decoded value is also returned as a record with the appropriate name. An internally defined type as the type in component 'a' in the following example will result in a record with name 'Seq_a': diff --git a/lib/asn1/src/asn1_records.hrl b/lib/asn1/src/asn1_records.hrl index d3d76f9566..06a9e3ab03 100644 --- a/lib/asn1/src/asn1_records.hrl +++ b/lib/asn1/src/asn1_records.hrl @@ -108,6 +108,17 @@ options=[] :: [any()] }). +%% Abstract intermediate representation. +-record(abst, + {name :: module(), %Name of module. + types, %Types. + values, %Values. + ptypes, %Parameterized types. + classes, %Classes. + objects, %Objects. + objsets %Object sets. + }). + %% state record used by back-end at partial decode %% active is set to 'yes' when a partial decode function is generated. %% prefix is set to 'dec-inc-' or 'dec-partial-' is for diff --git a/lib/asn1/src/asn1ct.erl b/lib/asn1/src/asn1ct.erl index d27f8897af..9f77a557e5 100644 --- a/lib/asn1/src/asn1ct.erl +++ b/lib/asn1/src/asn1ct.erl @@ -236,12 +236,8 @@ abs_listing(#st{code={M,_},outfile=OutFile}) -> generate_pass(#st{code=Code,outfile=OutFile,erule=Erule,opts=Opts}=St0) -> St = St0#st{code=undefined}, %Reclaim heap space - case generate(Code, OutFile, Erule, Opts) of - {error,Reason} -> - {error,St#st{error=Reason}}; - ok -> - {ok,St} - end. + generate(Code, OutFile, Erule, Opts), + {ok,St}. compile_pass(#st{outfile=OutFile,opts=Opts0}=St) -> asn1_db:dbstop(), %Reclaim memory. @@ -834,7 +830,11 @@ delete_double_of_symbol1([],Acc) -> %%*********************************** -generate({M,GenTOrV}, OutFile, EncodingRule, Options) -> +generate({M,CodeTuple}, OutFile, EncodingRule, Options) -> + {Types,Values,Ptypes,Classes,Objects,ObjectSets} = CodeTuple, + Code = #abst{name=M#module.name, + types=Types,values=Values,ptypes=Ptypes, + classes=Classes,objects=Objects,objsets=ObjectSets}, debug_on(Options), setup_bit_string_format(Options), setup_legacy_erlang_types(Options), @@ -854,19 +854,13 @@ generate({M,GenTOrV}, OutFile, EncodingRule, Options) -> "Error in configuration file") end, - Res = case catch asn1ct_gen:pgen(OutFile, Gen, M#module.name, GenTOrV) of - {'EXIT',Reason2} -> - error("~p~n",[Reason2],Options), - {error,Reason2}; - _ -> - ok - end, + asn1ct_gen:pgen(OutFile, Gen, Code), debug_off(Options), cleanup_bit_string_format(), erase(tlv_format), % used in ber erase(class_default_type),% used in ber asn1ct_table:delete(check_functions), - Res. + ok. init_gen_record(EncodingRule, Options) -> Erule = case EncodingRule of diff --git a/lib/asn1/src/asn1ct_check.erl b/lib/asn1/src/asn1ct_check.erl index 321f4147f5..4f04b78241 100644 --- a/lib/asn1/src/asn1ct_check.erl +++ b/lib/asn1/src/asn1ct_check.erl @@ -4948,7 +4948,7 @@ componentrelation_leadingattr(S,CompList) -> %%FIXME expand_ExtAddGroups([C#'ExtensionAdditionGroup'{components=ExtAdds}|T], %% CurrPos,PosAcc,CompAcc) -> -%% expand_ExtAddGroups(T,CurrPos+ L = lenght(ExtAdds),[{CurrPos,L}|PosAcc],ExtAdds++CompAcc); +%% expand_ExtAddGroups(T,CurrPos+ L = length(ExtAdds),[{CurrPos,L}|PosAcc],ExtAdds++CompAcc); %% expand_ExtAddGroups([C|T],CurrPos,PosAcc,CompAcc) -> %% expand_ExtAddGroups(T,CurrPos+ 1,PosAcc,[C|CompAcc]); %% expand_ExtAddGroups([],_CurrPos,PosAcc,CompAcc) -> diff --git a/lib/asn1/src/asn1ct_constructed_per.erl b/lib/asn1/src/asn1ct_constructed_per.erl index b7579c8065..9cd9864b80 100644 --- a/lib/asn1/src/asn1ct_constructed_per.erl +++ b/lib/asn1/src/asn1ct_constructed_per.erl @@ -979,6 +979,10 @@ mark_optional(Other) -> gen_enc_components_call1(Gen, TopType, [C|Rest], DynamicEnc, Ext) -> #'ComponentType'{name=Cname,typespec=Type, prop=Prop,textual_order=Num} = C, + InnerType = asn1ct_gen:get_inner(Type#type.def), + CommentString = attribute_comment(InnerType, Num, Cname), + ImmComment = asn1ct_imm:enc_comment(CommentString), + {Imm0,Element} = enc_fetch_field(Gen, Num, Prop), Imm1 = gen_enc_line_imm(Gen, TopType, Cname, Type, Element, DynamicEnc, Ext), @@ -993,7 +997,7 @@ gen_enc_components_call1(Gen, TopType, [C|Rest], DynamicEnc, Ext) -> end, Imm = case Imm2 of [] -> []; - _ -> Imm0 ++ Imm2 + _ -> [ImmComment|Imm0 ++ Imm2] end, [Imm|gen_enc_components_call1(Gen, TopType, Rest, DynamicEnc, Ext)]; gen_enc_components_call1(_Gen, _TopType, [], _, _) -> @@ -1328,27 +1332,17 @@ gen_dec_comp_calls([], _, _, _, _, _, _, Tpos, Acc) -> gen_dec_comp_call(Comp, Gen, TopType, Tpos, OptTable, DecInfObj, Ext, NumberOfOptionals) -> - #'ComponentType'{typespec=Type,prop=Prop,textual_order=TextPos} = Comp, + #'ComponentType'{name=Cname,typespec=Type, + prop=Prop,textual_order=TextPos} = Comp, Pos = case Ext of noext -> Tpos; {ext,Epos,_Enum} -> Tpos - Epos + 1 end, - InnerType = - case Type#type.def of - #'ObjectClassFieldType'{type=InType} -> - InType; - Def -> - asn1ct_gen:get_inner(Def) - end, + InnerType = asn1ct_gen:get_inner(Type#type.def), - DispType = case InnerType of - #'Externaltypereference'{type=T} -> T; - IT when is_tuple(IT) -> element(2,IT); - _ -> InnerType - end, + CommentString = attribute_comment(InnerType, TextPos, Cname), Comment = fun(St) -> - emit([nl,"%% attribute number ",TextPos, - " with type ",DispType,nl]), + emit([nl,"%% ",CommentString,nl]), St end, @@ -1987,3 +1981,12 @@ enc_dig_out_value(#gen{pack=map}=Gen, [{_,Name}|T], Value) -> make_var(Base) -> {var,atom_to_list(asn1ct_gen:mk_var(asn1ct_name:curr(Base)))}. + +attribute_comment(InnerType, TextPos, Cname) -> + DispType = case InnerType of + #'Externaltypereference'{type=T} -> T; + IT when is_tuple(IT) -> element(2,IT); + _ -> InnerType + end, + Comment = ["attribute ",Cname,"(",TextPos,") with type ",DispType], + lists:concat(Comment). diff --git a/lib/asn1/src/asn1ct_gen.erl b/lib/asn1/src/asn1ct_gen.erl index 4fa830d7d9..9f628c7b04 100644 --- a/lib/asn1/src/asn1ct_gen.erl +++ b/lib/asn1/src/asn1ct_gen.erl @@ -37,7 +37,7 @@ get_record_name_prefix/1, conform_value/2, named_bitstring_value/2]). --export([pgen/4, +-export([pgen/3, mk_var/1, un_hyphen_var/1]). -export([gen_encode_constructed/4, @@ -50,14 +50,13 @@ %% Generate Erlang module (.erl) and (.hrl) file corresponding to %% an ASN.1 module. The .hrl file is only generated if necessary. --spec pgen(Outfile, Gen, Module, Contents) -> 'ok' when +-spec pgen(Outfile, Gen, Code) -> 'ok' when Outfile :: any(), Gen :: #gen{}, - Module :: module(), - Contents :: tuple(). + Code :: #abst{}. -pgen(OutFile, #gen{options=Options}=Gen, Module, Contents) -> - {Types,_Values,_Ptypes,_Classes,_Objects,_ObjectSets} = Contents, +pgen(OutFile, #gen{options=Options}=Gen, Code) -> + #abst{name=Module,types=Types} = Code, N2nConvEnums = [CName|| {n2n,CName} <- Options], case N2nConvEnums -- Types of [] -> @@ -66,18 +65,18 @@ pgen(OutFile, #gen{options=Options}=Gen, Module, Contents) -> exit({"Non existing ENUMERATION types used in n2n option", UnmatchedTypes}) end, - put(outfile,OutFile), + put(outfile, OutFile), put(currmod, Module), - HrlGenerated = pgen_hrl(Gen, Module, Contents), + HrlGenerated = pgen_hrl(Gen, Code), asn1ct_name:start(), ErlFile = lists:concat([OutFile,".erl"]), _ = open_output_file(ErlFile), asn1ct_func:start_link(), gen_head(Gen, Module, HrlGenerated), - pgen_exports(Gen, Module, Contents), - pgen_dispatcher(Gen, Contents), + pgen_exports(Gen, Code), + pgen_dispatcher(Gen, Types), pgen_info(), - pgen_typeorval(Gen, Module, N2nConvEnums, Contents), + pgen_typeorval(Gen, N2nConvEnums, Code), pgen_partial_incomplete_decode(Gen), emit([nl, "%%%",nl, @@ -88,7 +87,8 @@ pgen(OutFile, #gen{options=Options}=Gen, Module, Contents) -> asn1ct_func:generate(Fd), close_output_file(), _ = erase(outfile), - asn1ct:verbose("--~p--~n", [{generated,ErlFile}], Gen). + asn1ct:verbose("--~p--~n", [{generated,ErlFile}], Gen), + ok. dialyzer_suppressions(Erules) -> emit([nl, @@ -96,20 +96,27 @@ dialyzer_suppressions(Erules) -> Rtmod = ct_gen_module(Erules), Rtmod:dialyzer_suppressions(Erules). -pgen_typeorval(Erules,Module,N2nConvEnums,{Types,Values,_Ptypes,_Classes,Objects,ObjectSets}) -> +pgen_typeorval(Erules, N2nConvEnums, Code) -> + #abst{name=Module,types=Types,values=Values, + objects=Objects,objsets=ObjectSets} = Code, Rtmod = ct_gen_module(Erules), pgen_types(Rtmod,Erules,N2nConvEnums,Module,Types), - pgen_values(Erules,Module,Values), + pgen_values(Values, Module), pgen_objects(Rtmod,Erules,Module,Objects), pgen_objectsets(Rtmod,Erules,Module,ObjectSets), pgen_partial_decode(Rtmod,Erules,Module). -pgen_values(_,_,[]) -> - true; -pgen_values(Erules,Module,[H|T]) -> - Valuedef = asn1_db:dbget(Module,H), - gen_value(Valuedef), - pgen_values(Erules,Module,T). +%% Generate a function 'V'/0 for each Value V defined in the ASN.1 module. +%% The function returns the value in an Erlang representation which can be +%% used as input to the runtime encode functions. + +pgen_values([H|T], Module) -> + #valuedef{name=Name,value=Value} = asn1_db:dbget(Module, H), + emit([{asis,Name},"() ->",nl, + {asis,Value},".",nl,nl]), + pgen_values(T, Module); +pgen_values([], _) -> + ok. pgen_types(_, _, _, _, []) -> true; @@ -573,18 +580,6 @@ un_hyphen_var([H|T]) -> un_hyphen_var([]) -> []. -%% Generate value functions *************** -%% **************************************** -%% Generates a function 'V'/0 for each Value V defined in the ASN.1 module -%% the function returns the value in an Erlang representation which can be -%% used as input to the runtime encode functions - -gen_value(Value) when is_record(Value,valuedef) -> -%% io:format(" ~w ",[Value#valuedef.name]), - emit({"'",Value#valuedef.name,"'() ->",nl}), - V = Value#valuedef.value, - emit([{asis,V},".",nl,nl]). - gen_encode_constructed(Erules,Typename,InnerType,D) when is_record(D,type) -> Rtmod = ct_constructed_module(Erules), case InnerType of @@ -649,79 +644,32 @@ gen_decode_constructed(Erules,Typename,InnerType,D) when is_record(D,typedef) -> gen_decode_constructed(Erules,Typename,InnerType,D#typedef.typespec). -pgen_exports(#gen{options=Options}=Gen, _Module, Contents) -> - {Types,Values,_,_,Objects,ObjectSets} = Contents, +pgen_exports(#gen{options=Options}=Gen, Code) -> + #abst{types=Types,values=Values,objects=Objects,objsets=ObjectSets} = Code, emit(["-export([encoding_rule/0,maps/0,bit_string_format/0,",nl, " legacy_erlang_types/0]).",nl]), emit(["-export([",{asis,?SUPPRESSION_FUNC},"/1]).",nl]), - case Types of - [] -> ok; - _ -> - emit({"-export([",nl}), - case Gen of - #gen{erule=ber} -> - gen_exports1(Types,"enc_",2); - _ -> - gen_exports1(Types,"enc_",1) - end, - emit({"-export([",nl}), - case Gen of - #gen{erule=ber} -> - gen_exports1(Types, "dec_", 2); - _ -> - gen_exports1(Types, "dec_", 1) - end - end, - case [X || {n2n,X} <- Options] of - [] -> ok; - A2nNames -> - emit({"-export([",nl}), - gen_exports1(A2nNames,"name2num_",1), - emit({"-export([",nl}), - gen_exports1(A2nNames,"num2name_",1) - end, - case Values of - [] -> ok; - _ -> - emit({"-export([",nl}), - gen_exports1(Values,"",0) - end, - case Objects of - [] -> ok; - _ -> - case Gen of - #gen{erule=per} -> - ok; - #gen{erule=ber} -> - emit({"-export([",nl}), - gen_exports1(Objects,"enc_",3), - emit({"-export([",nl}), - gen_exports1(Objects,"dec_",3) - end - end, - case ObjectSets of - [] -> ok; - _ -> - case Gen of - #gen{erule=per} -> - ok; - #gen{erule=ber} -> - emit({"-export([",nl}), - gen_exports1(ObjectSets, "getenc_",1), - emit({"-export([",nl}), - gen_exports1(ObjectSets, "getdec_",1) - end + case Gen of + #gen{erule=ber} -> + gen_exports(Types, "enc_", 2), + gen_exports(Types, "dec_", 2), + gen_exports(Objects, "enc_", 3), + gen_exports(Objects, "dec_", 3), + gen_exports(ObjectSets, "getenc_", 1), + gen_exports(ObjectSets, "getdec_", 1); + #gen{erule=per} -> + gen_exports(Types, "enc_", 1), + gen_exports(Types, "dec_", 1) end, - emit({"-export([info/0]).",nl}), - gen_partial_inc_decode_exports(), - gen_selected_decode_exports(), - emit({nl,nl}). -gen_exports1([F1,F2|T],Prefix,Arity) -> - emit({"'",Prefix,F1,"'/",Arity,com,nl}), - gen_exports1([F2|T],Prefix,Arity); -gen_exports1([Flast|_T],Prefix,Arity) -> - emit({"'",Prefix,Flast,"'/",Arity,nl,"]).",nl,nl}). + A2nNames = [X || {n2n,X} <- Options], + gen_exports(A2nNames, "name2num_", 1), + gen_exports(A2nNames, "num2name_", 1), + + gen_exports(Values, "", 0), + emit(["-export([info/0]).",nl,nl]), + gen_partial_inc_decode_exports(), + gen_selected_decode_exports(). gen_partial_inc_decode_exports() -> case {asn1ct:read_config_data(partial_incomplete_decode), @@ -730,49 +678,36 @@ gen_partial_inc_decode_exports() -> ok; {_,undefined} -> ok; - {Data,_} -> - gen_partial_inc_decode_exports0(Data), - emit(["-export([decode_part/2]).",nl]) + {Data0,_} -> + Data = [Name || {Name,_,_} <- Data0], + gen_exports(Data, "", 1), + emit(["-export([decode_part/2]).",nl,nl]) end. -gen_partial_inc_decode_exports0([]) -> - ok; -gen_partial_inc_decode_exports0([{Name,_,_}|Rest]) -> - emit(["-export([",Name,"/1"]), - gen_partial_inc_decode_exports1(Rest); -gen_partial_inc_decode_exports0([_|Rest]) -> - gen_partial_inc_decode_exports0(Rest). - -gen_partial_inc_decode_exports1([]) -> - emit(["]).",nl]); -gen_partial_inc_decode_exports1([{Name,_,_}|Rest]) -> - emit([", ",Name,"/1"]), - gen_partial_inc_decode_exports1(Rest); -gen_partial_inc_decode_exports1([_|Rest]) -> - gen_partial_inc_decode_exports1(Rest). - gen_selected_decode_exports() -> case asn1ct:get_gen_state_field(type_pattern) of undefined -> ok; - L -> - gen_selected_decode_exports(L) + Data0 -> + Data = [Name || {Name,_} <- Data0], + gen_exports(Data, "", 1) end. -gen_selected_decode_exports([]) -> +gen_exports([], _Prefix, _Arity) -> ok; -gen_selected_decode_exports([{FuncName,_}|Rest]) -> - emit(["-export([",FuncName,"/1"]), - gen_selected_decode_exports1(Rest). -gen_selected_decode_exports1([]) -> - emit(["]).",nl,nl]); -gen_selected_decode_exports1([{FuncName,_}|Rest]) -> - emit([",",nl," ",FuncName,"/1"]), - gen_selected_decode_exports1(Rest). - -pgen_dispatcher(Erules, {[],_Values,_,_,_Objects,_ObjectSets}) -> +gen_exports([_|_]=L0, Prefix, Arity) -> + FF = fun(F0) -> + F = list_to_atom(lists:concat([Prefix,F0])), + [{asis,F},"/",Arity] + end, + L = lists:join(",\n", [FF(F) || F <- L0]), + emit(["-export([",nl, + L,nl, + "]).",nl,nl]). + +pgen_dispatcher(Erules, []) -> gen_info_functions(Erules); -pgen_dispatcher(Gen, {Types,_Values,_,_,_Objects,_ObjectSets}) -> +pgen_dispatcher(Gen, Types) -> emit(["-export([encode/2,decode/2]).",nl,nl]), gen_info_functions(Gen), @@ -812,7 +747,7 @@ pgen_dispatcher(Gen, {Types,_Values,_,_,_Objects,_ObjectSets}) -> false -> "Data" end, - emit(["decode(Type,",Data,") ->",nl]), + emit(["decode(Type, ",Data,") ->",nl]), DecWrap = case {Gen,ReturnRest} of {#gen{erule=ber},false} -> @@ -847,17 +782,10 @@ pgen_dispatcher(Gen, {Types,_Values,_,_,_Objects,_ObjectSets}) -> end, gen_decode_partial_incomplete(Gen), + gen_partial_inc_dispatcher(Gen), - case Gen of - #gen{erule=ber} -> - gen_dispatcher(Types,"encode_disp","enc_",""), - gen_dispatcher(Types,"decode_disp","dec_",""), - gen_partial_inc_dispatcher(); - #gen{} -> - gen_dispatcher(Types,"encode_disp","enc_",""), - gen_dispatcher(Types,"decode_disp","dec_","") - end, - emit([nl,nl]). + gen_dispatcher(Types, "encode_disp", "enc_"), + gen_dispatcher(Types, "decode_disp", "dec_"). result_line(NoOkWrapper, Items) -> S = [" "|case NoOkWrapper of @@ -874,11 +802,12 @@ result_line_1(Items) -> try_catch() -> [" catch",nl, " Class:Exception when Class =:= error; Class =:= exit ->",nl, + " Stk = erlang:get_stacktrace(),",nl, " case Exception of",nl, - " {error,Reason}=Error ->",nl, - " Error;",nl, + " {error,{asn1,Reason}} ->",nl, + " {error,{asn1,{Reason,Stk}}};",nl, " Reason ->",nl, - " {error,{asn1,Reason}}",nl, + " {error,{asn1,{Reason,Stk}}}",nl, " end",nl, "end."]. @@ -942,7 +871,7 @@ gen_decode_partial_incomplete(#gen{erule=ber}) -> gen_decode_partial_incomplete(#gen{}) -> ok. -gen_partial_inc_dispatcher() -> +gen_partial_inc_dispatcher(#gen{erule=ber}) -> case {asn1ct:read_config_data(partial_incomplete_decode), asn1ct:get_gen_state_field(inc_type_pattern)} of {undefined,_} -> @@ -952,7 +881,9 @@ gen_partial_inc_dispatcher() -> {Data1,Data2} -> % io:format("partial_incomplete_decode: ~p~ninc_type_pattern: ~p~n",[Data,Data2]), gen_partial_inc_dispatcher(Data1, Data2, "") - end. + end; +gen_partial_inc_dispatcher(#gen{}) -> + ok. gen_partial_inc_dispatcher([{FuncName,TopType,_Pattern}|Rest], TypePattern, Sep) -> TPattern = @@ -976,12 +907,18 @@ gen_partial_inc_dispatcher([{FuncName,TopType,_Pattern}|Rest], TypePattern, Sep) gen_partial_inc_dispatcher([], _, _) -> emit([".",nl]). -gen_dispatcher([F1,F2|T],FuncName,Prefix,ExtraArg) -> - emit([FuncName,"('",F1,"',Data) -> '",Prefix,F1,"'(Data",ExtraArg,")",";",nl]), - gen_dispatcher([F2|T],FuncName,Prefix,ExtraArg); -gen_dispatcher([Flast|_T],FuncName,Prefix,ExtraArg) -> - emit([FuncName,"('",Flast,"',Data) -> '",Prefix,Flast,"'(Data",ExtraArg,")",";",nl]), - emit([FuncName,"(","Type",",_Data) -> exit({error,{asn1,{undefined_type,Type}}}).",nl,nl,nl]). +gen_dispatcher(L, DispFunc, Prefix) -> + gen_dispatcher_1(L, DispFunc, Prefix), + emit([DispFunc,"(","Type",", _Data) ->" + " exit({error,{asn1,{undefined_type,Type}}}).",nl,nl]). + +gen_dispatcher_1([F|T], FuncName, Prefix) -> + Func = list_to_atom(lists:concat([Prefix,F])), + emit([FuncName,"(",{asis,F},", Data) -> ", + {asis,Func},"(Data)",";",nl]), + gen_dispatcher_1(T, FuncName, Prefix); +gen_dispatcher_1([], _, _) -> + ok. pgen_info() -> emit(["info() ->",nl, @@ -1100,8 +1037,8 @@ open_output_file(F) -> close_output_file() -> ok = file:close(erase(gen_file_out)). -pgen_hrl(#gen{pack=record}=Gen, Module, Contents) -> - {Types,Values,Ptypes,_,_,_} = Contents, +pgen_hrl(#gen{pack=record}=Gen, Code) -> + #abst{name=Module,types=Types,values=Values,ptypes=Ptypes} = Code, Ret = case pgen_hrltypes(Gen, Module, Ptypes++Types, 0) of 0 -> @@ -1129,7 +1066,7 @@ pgen_hrl(#gen{pack=record}=Gen, Module, Contents) -> Gen), Y end; -pgen_hrl(#gen{pack=map}, _, _) -> +pgen_hrl(#gen{pack=map}, _) -> 0. pgen_macros(_,_,[]) -> @@ -1215,55 +1152,16 @@ gen_record(Gen, TorPtype, Name, #type{}=Type, Num) -> 0 -> open_hrl(get(outfile),get(currmod)); _ -> true end, - Prefix = get_record_name_prefix(Gen), - emit({"-record('",Prefix,list2name(Name),"',{",nl}), - RootList = case CompList of - _ when is_list(CompList) -> - CompList; - {Rl,_} -> Rl; - {Rl1,_Ext,_Rl2} -> Rl1 - end, - gen_record2(Name,'SEQUENCE',RootList), - NewCompList = + do_gen_record(Gen, Name, CompList), + NewCompList = case CompList of {CompList1,[]} -> - emit({"}). % with extension mark",nl,nl}), CompList1; {Tr,ExtensionList2} -> - case Tr of - [] -> true; - _ -> emit({",",nl}) - end, - emit({"%% with extensions",nl}), - gen_record2(Name, 'SEQUENCE', ExtensionList2, - "", ext), - emit({"}).",nl,nl}), Tr ++ ExtensionList2; {Rootl1,Extl,Rootl2} -> - case Rootl1 =/= [] andalso Extl++Rootl2 =/= [] of - true -> emit([com]); - false -> ok - end, - case Rootl1 of - [_|_] -> emit([nl]); - [] -> ok - end, - emit(["%% with extensions",nl]), - gen_record2(Name,'SEQUENCE',Extl,"",ext), - case Extl =/= [] andalso Rootl2 =/= [] of - true -> emit([com]); - false -> ok - end, - case Extl of - [_|_] -> emit([nl]); - [] -> ok - end, - emit(["%% end of extensions",nl]), - gen_record2(Name,'SEQUENCE',Rootl2,"",noext), - emit(["}).",nl,nl]), Rootl1++Extl++Rootl2; - _ -> - emit({"}).",nl,nl}), + _ -> CompList end, gen_record(Gen, TorPtype, Name, NewCompList, Num+1); @@ -1275,6 +1173,51 @@ gen_record(Gen, TorPtype, Name, #type{}=Type, Num) -> gen_record(_, _, _, _, NumRecords) -> % skip CLASS etc for now. NumRecords. +do_gen_record(Gen, Name, CL0) -> + CL = case CL0 of + {Root,[]} -> + Root ++ [{comment,"with extension mark"}]; + {Root,Ext} -> + Root ++ [{comment,"with exensions"}] ++ + only_components(Ext); + {Root1,Ext,Root2} -> + Root1 ++ [{comment,"with exensions"}] ++ + only_components(Ext) ++ + [{comment,"end of extensions"}] ++ Root2; + _ when is_list(CL0) -> + CL0 + end, + Prefix = get_record_name_prefix(Gen), + emit(["-record('",Prefix,list2name(Name),"', {"] ++ + do_gen_record_1(CL) ++ + [nl,"}).",nl,nl]). + +only_components(CL) -> + [C || #'ComponentType'{}=C <- CL]. + +do_gen_record_1([#'ComponentType'{name=Name,prop=Prop}|T]) -> + Val = case Prop of + 'OPTIONAL' -> + " = asn1_NOVALUE"; + {'DEFAULT',_} -> + " = asn1_DEFAULT"; + _ -> + [] + end, + Com = case needs_trailing_comma(T) of + true -> [com]; + false -> [] + end, + [nl," ",{asis,Name},Val,Com|do_gen_record_1(T)]; +do_gen_record_1([{comment,Text}|T]) -> + [nl," %% ",Text|do_gen_record_1(T)]; +do_gen_record_1([]) -> + []. + +needs_trailing_comma([#'ComponentType'{}|_]) -> true; +needs_trailing_comma([_|T]) -> needs_trailing_comma(T); +needs_trailing_comma([]) -> false. + gen_head(#gen{options=Options}=Gen, Mod, Hrl) -> Name = case Gen of #gen{erule=per,aligned=false} -> @@ -1285,15 +1228,15 @@ gen_head(#gen{options=Options}=Gen, Mod, Hrl) -> "BER" end, emit(["%% Generated by the Erlang ASN.1 ",Name, - "compiler. Version:",asn1ct:vsn(),nl, - "%% Purpose: encoder and decoder of the types in ",Mod,nl,nl, - "-module('",Mod,"').",nl]), - put(currmod,Mod), - emit({"-compile(nowarn_unused_vars).",nl}), - emit({"-dialyzer(no_improper_lists).",nl}), + " compiler. Version: ",asn1ct:vsn(),nl, + "%% Purpose: Encoding and decoding of the types in ", + Mod,".",nl,nl, + "-module('",Mod,"').",nl, + "-compile(nowarn_unused_vars).",nl, + "-dialyzer(no_improper_lists).",nl]), case Hrl of 0 -> ok; - _ -> emit({"-include(\"",Mod,".hrl\").",nl}) + _ -> emit(["-include(\"",Mod,".hrl\").",nl]) end, emit(["-asn1_info([{vsn,'",asn1ct:vsn(),"'},",nl, " {module,'",Mod,"'},",nl, @@ -1301,36 +1244,11 @@ gen_head(#gen{options=Options}=Gen, Mod, Hrl) -> gen_hrlhead(Mod) -> - emit({"%% Generated by the Erlang ASN.1 compiler version:",asn1ct:vsn(),nl}), - emit({"%% Purpose: Erlang record definitions for each named and unnamed",nl}), - emit({"%% SEQUENCE and SET, and macro definitions for each value",nl}), - emit({"%% definition,in module ",Mod,nl,nl}), - emit({nl,nl}). - -gen_record2(Name,SeqOrSet,Comps) -> - gen_record2(Name,SeqOrSet,Comps,"",noext). - -gen_record2(_Name,_SeqOrSet,[],_Com,_Extension) -> - true; -gen_record2(_Name,_SeqOrSet,[H = #'ComponentType'{name=Cname}],Com,Extension) -> - emit(Com), - emit({asis,Cname}), - gen_record_default(H, Extension); -gen_record2(Name,SeqOrSet,[H = #'ComponentType'{name=Cname}|T],Com, Extension) -> - emit(Com), - emit({asis,Cname}), - gen_record_default(H, Extension), - gen_record2(Name,SeqOrSet,T,", ", Extension); -gen_record2(Name,SeqOrSet,[_|T],Com,Extension) -> - %% skip EXTENSIONMARK, ExtensionAdditionGroup and other markers - gen_record2(Name,SeqOrSet,T,Com,Extension). - -gen_record_default(#'ComponentType'{prop='OPTIONAL'}, _)-> - emit(" = asn1_NOVALUE"); -gen_record_default(#'ComponentType'{prop={'DEFAULT',_}}, _)-> - emit(" = asn1_DEFAULT"); -gen_record_default(_, _) -> - true. + emit(["%% Generated by the Erlang ASN.1 compiler. Version: ", + asn1ct:vsn(),nl, + "%% Purpose: Erlang record definitions for each named and unnamed",nl, + "%% SEQUENCE and SET, and macro definitions for each value",nl, + "%% definition in module ",Mod,".",nl,nl]). %% May only be a list or a two-tuple. to_textual_order({Root,Ext}) -> diff --git a/lib/asn1/src/asn1ct_imm.erl b/lib/asn1/src/asn1ct_imm.erl index 2ab848652e..130f68c21d 100644 --- a/lib/asn1/src/asn1ct_imm.erl +++ b/lib/asn1/src/asn1ct_imm.erl @@ -41,7 +41,8 @@ per_enc_extensions_map/4, per_enc_optional/2]). -export([per_enc_sof/5]). --export([enc_absent/3,enc_append/1,enc_element/2,enc_maps_get/2]). +-export([enc_absent/3,enc_append/1,enc_element/2,enc_maps_get/2, + enc_comment/1]). -export([enc_cg/2]). -export([optimize_alignment/1,optimize_alignment/2, dec_slim_cg/2,dec_code_gen/2]). @@ -216,7 +217,8 @@ per_enc_legacy_bit_string(Val0, NNL0, Constraint0, Aligned) -> 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]}]]). + [{eq,Val,true},{put_bits,1,1,[1]}], + ['_',{error,{illegal_boolean,Val}}]]). per_enc_choice(Val0, Cs0, _Aligned) -> {B,[Val]} = mk_vars(Val0, []), @@ -237,7 +239,7 @@ per_enc_enumerated(Val0, Root, Aligned) -> B++[{'cond',Cs++enumerated_error(Val)}]. enumerated_error(Val) -> - [['_',{error,Val}]]. + [['_',{error,{illegal_enumerated,Val}}]]. per_enc_integer(Val0, Constraint0, Aligned) -> {B,[Val]} = mk_vars(Val0, []), @@ -437,6 +439,9 @@ enc_maps_get(N, Val0) -> {var,SrcVar} = Val, {[{assign,DstExpr,SrcVar}],Dst0}. +enc_comment(Comment) -> + {comment,Comment}. + enc_cg(Imm0, false) -> Imm1 = enc_cse(Imm0), Imm2 = enc_pre_cg(Imm1), @@ -874,10 +879,8 @@ flatten_map_cs_1([integer_default], {Int,_}) -> [{'_',Int}]; flatten_map_cs_1([enum_default], {Int,_}) -> [{'_',["{asn1_enum,",Int,"}"]}]; -flatten_map_cs_1([enum_error], {Var,Cs}) -> - Vs = [V || {_,V} <- Cs], - [{'_',["exit({error,{asn1,{decode_enumerated,{",Var,",", - {asis,Vs},"}}}})"]}]; +flatten_map_cs_1([enum_error], {Var,_}) -> + [{'_',["exit({error,{asn1,{decode_enumerated,",Var,"}}})"]}]; flatten_map_cs_1([], _) -> []. flatten_hoist_align([[{align_bits,_,_}=Ab|T]|Cs]) -> @@ -1051,6 +1054,7 @@ split_off_nonbuilding(Imm) -> is_nonbuilding({assign,_,_}) -> true; is_nonbuilding({call,_,_,_,_}) -> true; +is_nonbuilding({comment,_}) -> true; is_nonbuilding({lc,_,_,_,_}) -> true; is_nonbuilding({set,_,_}) -> true; is_nonbuilding({list,_,_}) -> true; @@ -1107,7 +1111,7 @@ per_enc_integer_1(Val0, [{{_,_}=Constr,[]}], 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}]]). + ['_',{error,{illegal_integer,Val0}}]]). per_enc_integer_2(Val, {'SingleValue',Sv}, Aligned) when is_integer(Sv) -> per_enc_constrained(Val, Sv, Sv, Aligned); @@ -1931,6 +1935,8 @@ enc_opt({'cond',Cs0}, St0) -> {Cs,Type} = enc_opt_cond_1(Cs1, Type0, [{Cond,Imm}]), {{'cond',Cs},St0#ost{t=Type}} end; +enc_opt({comment,_}=Imm, St) -> + {Imm,St#ost{t=undefined}}; enc_opt({cons,H0,T0}, St0) -> {H,#ost{t=TypeH}=St1} = enc_opt(H0, St0), {T,#ost{t=TypeT}=St} = enc_opt(T0, St1), @@ -2320,6 +2326,9 @@ enc_cg({block,Imm}) -> enc_cg(Imm), emit([nl, "end"]); +enc_cg({seq,{comment,Comment},Then}) -> + emit(["%% ",Comment,nl]), + enc_cg(Then); enc_cg({seq,First,Then}) -> enc_cg(First), emit([com,nl]), @@ -2353,9 +2362,9 @@ enc_cg({'cond',Cs}) -> enc_cg_cond(Cs); enc_cg({error,Error}) when is_function(Error, 0) -> Error(); -enc_cg({error,Var0}) -> +enc_cg({error,{Tag,Var0}}) -> Var = mk_val(Var0), - emit(["exit({error,{asn1,{illegal_value,",Var,"}}})"]); + emit(["exit({error,{asn1,{",Tag,",",Var,"}}})"]); enc_cg({integer,Int}) -> emit(mk_val(Int)); enc_cg({lc,Body,Var,List}) -> @@ -2618,6 +2627,8 @@ enc_opt_al({call,per_common,encode_unconstrained_number,[_]}=Call, _) -> {[Call],0}; enc_opt_al({call,_,_,_,_}=Call, Al) -> {[Call],Al}; +enc_opt_al({comment,_}=Imm, Al) -> + {[Imm],Al}; enc_opt_al({'cond',Cs0}, Al0) -> {Cs,Al} = enc_opt_al_cond(Cs0, Al0), {[{'cond',Cs}],Al}; @@ -2714,6 +2725,8 @@ per_fixup([{block,Block}|T]) -> [{block,per_fixup(Block)}|per_fixup(T)]; per_fixup([{'assign',_,_}=H|T]) -> [H|per_fixup(T)]; +per_fixup([{comment,_}=H|T]) -> + [H|per_fixup(T)]; per_fixup([{'cond',Cs0}|T]) -> Cs = [[C|per_fixup(Act)] || [C|Act] <- Cs0], [{'cond',Cs}|per_fixup(T)]; diff --git a/lib/asn1/src/asn1rtt_per_common.erl b/lib/asn1/src/asn1rtt_per_common.erl index 3896cb7fa5..e7edfb1ee0 100644 --- a/lib/asn1/src/asn1rtt_per_common.erl +++ b/lib/asn1/src/asn1rtt_per_common.erl @@ -140,6 +140,8 @@ encode_relative_oid(Val) when is_tuple(Val) -> encode_relative_oid(Val) when is_list(Val) -> list_to_binary([e_object_element(X)||X <- Val]). +encode_unconstrained_number(Val) when not is_integer(Val) -> + exit({error,{asn1,{illegal_integer,Val}}}); encode_unconstrained_number(Val) when Val >= 0 -> if Val < 16#80 -> diff --git a/lib/asn1/test/Makefile b/lib/asn1/test/Makefile index d346bb9e12..afd063aa8e 100644 --- a/lib/asn1/test/Makefile +++ b/lib/asn1/test/Makefile @@ -115,8 +115,7 @@ MODULES= \ testImporting \ testExtensibilityImplied \ asn1_test_lib \ - asn1_app_test \ - asn1_appup_test \ + asn1_app_SUITE \ asn1_SUITE \ error_SUITE \ syntax_SUITE diff --git a/lib/asn1/test/asn1_SUITE.erl b/lib/asn1/test/asn1_SUITE.erl index 6769a38b12..580c919b9d 100644 --- a/lib/asn1/test/asn1_SUITE.erl +++ b/lib/asn1/test/asn1_SUITE.erl @@ -42,10 +42,11 @@ suite() -> {timetrap,{minutes,60}}]. all() -> - [{group, compile}, + [xref, + xref_export_all, + + {group, compile}, {group, parallel}, - {group, app_test}, - {group, appup_test}, % TODO: Investigate parallel running of these: testComment, @@ -67,13 +68,8 @@ groups() -> ber_optional, tagdefault_automatic]}, - {app_test, [], [{asn1_app_test, all}]}, - - {appup_test, [], [{asn1_appup_test, all}]}, - {parallel, Parallel, [cover, - xref, {group, ber}, % Uses 'P-Record', 'Constraints', 'MEDIA-GATEWAY-CONTROL'... {group, [], [parse, @@ -1047,18 +1043,6 @@ test_modified_x420(Config, Rule, Opts) -> test_modified_x420:test(Config). -testX420() -> - [{timetrap,{minutes,90}}]. -testX420(Config) -> - case erlang:system_info(system_architecture) of - "sparc-sun-solaris2.10" -> - {skip,"Too slow for an old Sparc"}; - _ -> - Rule = ber, - testX420:compile(Rule, [der], Config), - ok = testX420:ticket7759(Rule, Config) - end. - test_x691(Config) -> test(Config, fun test_x691/3, [per, uper]). test_x691(Config, Rule, Opts) -> @@ -1325,16 +1309,72 @@ ticket7904(Config) -> {ok,_} = 'RANAPextract1':encode('InitiatingMessage', Val1), {ok,_} = 'RANAPextract1':encode('InitiatingMessage', Val1). + +%% Make sure that functions exported from other modules are +%% actually used. + xref(_Config) -> - xref:start(s), - xref:set_default(s, [{verbose,false},{warnings,false},{builtins,true}]), + S = ?FUNCTION_NAME, + xref:start(S), + xref:set_default(S, [{verbose,false},{warnings,false},{builtins,true}]), Test = filename:dirname(code:which(?MODULE)), - {ok,_PMs} = xref:add_directory(s, Test), - UnusedExports = "X - XU - asn1_appup_test - asn1_app_test - \".*_SUITE\" : Mod", - case xref:q(s, UnusedExports) of + {ok,_PMs} = xref:add_directory(S, Test), + Q = "X - XU - \".*_SUITE\" : Mod", + UnusedExports = xref:q(S, Q), + xref:stop(S), + case UnusedExports of {ok,[]} -> ok; {ok,[_|_]=Res} -> io:format("Exported, but unused: ~p\n", [Res]), ?t:fail() end. + +%% Ensure that all functions that are implicitly exported by +%% 'export_all' in this module are actually used. + +xref_export_all(_Config) -> + S = ?FUNCTION_NAME, + xref:start(S), + xref:set_default(S, [{verbose,false},{warnings,false},{builtins,true}]), + {ok,_PMs} = xref:add_module(S, code:which(?MODULE)), + AllCalled = all_called(), + Def = "Called := " ++ lists:flatten(io_lib:format("~p", [AllCalled])), + {ok,_} = xref:q(S, Def), + {ok,Unused} = xref:q(S, "X - Called - range (closure E | Called)"), + xref:stop(S), + case Unused of + [] -> + ok; + [_|_] -> + S = [io_lib:format("~p:~p/~p\n", [M,F,A]) || {M,F,A} <- Unused], + io:format("There are unused functions:\n\n~s\n", [S]), + ?t:fail(unused_functions) + end. + +%% Collect all functions that common_test will call in this module. + +all_called() -> + [{?MODULE,end_per_group,2}, + {?MODULE,end_per_suite,1}, + {?MODULE,end_per_testcase,2}, + {?MODULE,init_per_group,2}, + {?MODULE,init_per_suite,1}, + {?MODULE,init_per_testcase,2}, + {?MODULE,suite,0}] ++ + all_called_1(all() ++ groups()). + +all_called_1([{_,_}|T]) -> + all_called_1(T); +all_called_1([{_Name,_Flags,Fs}|T]) -> + all_called_1(Fs ++ T); +all_called_1([F|T]) when is_atom(F) -> + L = case erlang:function_exported(?MODULE, F, 0) of + false -> + [{?MODULE,F,1}]; + true -> + [{?MODULE,F,0},{?MODULE,F,1}] + end, + L ++ all_called_1(T); +all_called_1([]) -> + []. diff --git a/lib/asn1/test/asn1_SUITE_data/Prim.asn1 b/lib/asn1/test/asn1_SUITE_data/Prim.asn1 index 4fe0901683..91c8696e61 100644 --- a/lib/asn1/test/asn1_SUITE_data/Prim.asn1 +++ b/lib/asn1/test/asn1_SUITE_data/Prim.asn1 @@ -18,6 +18,8 @@ BEGIN IntExpPri ::= [PRIVATE 51] EXPLICIT INTEGER IntExpApp ::= [APPLICATION 52] EXPLICIT INTEGER + IntConstrained ::= INTEGER (0..255) + IntEnum ::= INTEGER {first(1),last(31)} Enum ::= ENUMERATED {monday(1),tuesday(2),wednesday(3),thursday(4), diff --git a/lib/asn1/test/asn1_SUITE_data/testobj.erl b/lib/asn1/test/asn1_SUITE_data/testobj.erl index e547ea4572..66f4a92188 100644 --- a/lib/asn1/test/asn1_SUITE_data/testobj.erl +++ b/lib/asn1/test/asn1_SUITE_data/testobj.erl @@ -967,7 +967,7 @@ pdu_pdp() -> 116,101,115,116, % lable1 = test 4, % length lable2 116,101,115,116, % lable2 = test - 4, % lenght lable3 + 4, % length lable3 116,101,115,116, % lable3 = test 4, % length lable3 116,101,115,116, % lable4 = test diff --git a/lib/asn1/test/asn1_app_test.erl b/lib/asn1/test/asn1_app_SUITE.erl index 028322f555..c089a7267c 100644 --- a/lib/asn1/test/asn1_app_test.erl +++ b/lib/asn1/test/asn1_app_SUITE.erl @@ -21,23 +21,24 @@ %%---------------------------------------------------------------------- %% Purpose: Verify the application specifics of the asn1 application %%---------------------------------------------------------------------- --module(asn1_app_test). - --compile(export_all). +-module(asn1_app_SUITE). +-export([all/0,groups/0,init_per_group/2,end_per_group/2, + init_per_suite/1,end_per_suite/1, + appup/1,fields/1,modules/1,export_all/1,app_depend/1]). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -all() -> - [fields, modules, exportall, app_depend]. +all() -> + [appup, fields, modules, export_all, app_depend]. -groups() -> +groups() -> []. init_per_group(_GroupName, Config) -> - Config. + Config. end_per_group(_GroupName, Config) -> - Config. + Config. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -65,12 +66,15 @@ is_app(App) -> end_per_suite(Config) when is_list(Config) -> Config. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +appup(Config) when is_list(Config) -> + ok = test_server:appup_test(asn1). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% . fields(Config) when is_list(Config) -> - AppFile = key1search(app_file, Config), + AppFile = key1find(app_file, Config), Fields = [vsn, description, modules, registered, applications], case check_fields(Fields, AppFile, []) of [] -> @@ -96,10 +100,9 @@ check_field(Name, AppFile, Missing) -> %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% . modules(Config) when is_list(Config) -> - AppFile = key1search(app_file, Config), - Mods = key1search(modules, AppFile), + AppFile = key1find(app_file, Config), + Mods = key1find(modules, AppFile), EbinList = get_ebin_mods(asn1), case missing_modules(Mods, EbinList, []) of [] -> @@ -112,10 +115,9 @@ modules(Config) when is_list(Config) -> ok; Extra -> check_asn1ct_modules(Extra) -% throw({error, {extra_modules, Extra}}) end, {ok, Mods}. - + get_ebin_mods(App) -> LibDir = code:lib_dir(App), EbinDir = filename:join([LibDir,"ebin"]), @@ -166,10 +168,9 @@ extra_modules(Mods, [Mod|Ebins], Extra) -> %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% . -exportall(Config) when is_list(Config) -> - AppFile = key1search(app_file, Config), - Mods = key1search(modules, AppFile), +export_all(Config) when is_list(Config) -> + AppFile = key1find(app_file, Config), + Mods = key1find(modules, AppFile), check_export_all(Mods). @@ -180,10 +181,10 @@ check_export_all([Mod|Mods]) -> {'EXIT', {undef, _}} -> check_export_all(Mods); O -> - case lists:keysearch(options, 1, O) of + case lists:keyfind(options, 1, O) of false -> check_export_all(Mods); - {value, {options, List}} -> + {options, List} -> case lists:member(export_all, List) of true -> throw({error, {export_all, Mod}}); @@ -193,13 +194,12 @@ check_export_all([Mod|Mods]) -> end end. - + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% . app_depend(Config) when is_list(Config) -> - AppFile = key1search(app_file, Config), - Apps = key1search(applications, AppFile), + AppFile = key1find(app_file, Config), + Apps = key1find(applications, AppFile), check_apps(Apps). @@ -220,10 +220,10 @@ check_apps([App|Apps]) -> fail(Reason) -> exit({suite_failed, Reason}). -key1search(Key, L) -> - case lists:keysearch(Key, 1, L) of - undefined -> +key1find(Key, L) -> + case lists:keyfind(Key, 1, L) of + false -> fail({not_found, Key, L}); - {value, {Key, Value}} -> + {Key, Value} -> Value end. diff --git a/lib/asn1/test/asn1_appup_test.erl b/lib/asn1/test/asn1_appup_test.erl deleted file mode 100644 index 54540e53cc..0000000000 --- a/lib/asn1/test/asn1_appup_test.erl +++ /dev/null @@ -1,58 +0,0 @@ -%% -%% %CopyrightBegin% -%% -%% Copyright Ericsson AB 2005-2016. All Rights Reserved. -%% -%% Licensed under the Apache License, Version 2.0 (the "License"); -%% you may not use this file except in compliance with the License. -%% You may obtain a copy of the License at -%% -%% http://www.apache.org/licenses/LICENSE-2.0 -%% -%% Unless required by applicable law or agreed to in writing, software -%% distributed under the License is distributed on an "AS IS" BASIS, -%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -%% See the License for the specific language governing permissions and -%% limitations under the License. -%% -%% %CopyrightEnd% -%% -%% -%%---------------------------------------------------------------------- -%% Purpose: Verify the application specifics of the asn1 application -%%---------------------------------------------------------------------- --module(asn1_appup_test). --compile(export_all). --include_lib("common_test/include/ct.hrl"). - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -all() -> - [appup]. - -groups() -> - []. - -init_per_group(_GroupName, Config) -> - Config. - -end_per_group(_GroupName, Config) -> - Config. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -init_per_suite(Config) when is_list(Config) -> - Config. - - -end_per_suite(Config) when is_list(Config) -> - Config. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -appup() -> - [{doc, "perform a simple check of the asn1 appup file"}]. -appup(Config) when is_list(Config) -> - ok = ?t:appup_test(asn1). diff --git a/lib/asn1/test/ber_decode_error.erl b/lib/asn1/test/ber_decode_error.erl index c0840e02d7..c45d130ff4 100644 --- a/lib/asn1/test/ber_decode_error.erl +++ b/lib/asn1/test/ber_decode_error.erl @@ -26,48 +26,41 @@ run([]) -> {ok,B} = 'Constructed':encode('S3', {'S3',17}), [T,L|V] = binary_to_list(B), Bytes = list_to_binary([T,L+3|V] ++ [2,1,3]), - case 'Constructed':decode('S3', Bytes) of - {error,{asn1,{unexpected,_}}} -> ok - end, + {unexpected,_} = dec_error('S3', Bytes), %% Unexpected bytes must be accepted if there is an extensionmark {ok,{'S3ext',17}} = 'Constructed':decode('S3ext', Bytes), %% Truncated tag. - {error,{asn1,{invalid_tag,_}}} = - (catch 'Constructed':decode('I', <<31,255,255>>)), + {invalid_tag,_} = dec_error('I', <<31,255,255>>), %% Overlong tag. - {error,{asn1,{invalid_tag,_}}} = - (catch 'Constructed':decode('I', <<31,255,255,255,127>>)), + {invalid_tag,_} = dec_error('I', <<31,255,255,255,127>>), %% Invalid length. - {error,{asn1,{invalid_length,_}}} = - (catch 'Constructed':decode('I', <<8,255>>)), + {invalid_length,_} = dec_error('I', <<8,255>>), %% Other errors. - {error,{asn1,{invalid_value,_}}} = - (catch 'Constructed':decode('I', <<>>)), + {invalid_value,_} = dec_error('I', <<>>), - {error,{asn1,{invalid_value,_}}} = - (catch 'Constructed':decode('I', <<8,7>>)), + {invalid_value,_} = dec_error('I', <<8,7>>), %% Short indefinite length. Make sure that the decoder doesn't look %% beyond the end of binary when looking for a 0,0 terminator. - {error,{asn1,{invalid_length,_}}} = - (catch 'Constructed':decode('S', sub(<<8,16#80,0,0>>, 3))), - {error,{asn1,{invalid_length,_}}} = - (catch 'Constructed':decode('S', sub(<<8,16#80,0,0>>, 2))), - {error,{asn1,{invalid_length,_}}} = - (catch 'Constructed':decode('S', sub(<<40,16#80,1,1,255,0,0>>, 6))), - {error,{asn1,{invalid_length,_}}} = - (catch 'Constructed':decode('S', sub(<<40,16#80,1,1,255,0,0>>, 5))), + {invalid_length,_} = dec_error('S', sub(<<8,16#80,0,0>>, 3)), + {invalid_length,_} = dec_error('S', sub(<<8,16#80,0,0>>, 2)), + {invalid_length,_} = dec_error('S', sub(<<40,16#80,1,1,255,0,0>>, 6)), + {invalid_length,_} = dec_error('S', sub(<<40,16#80,1,1,255,0,0>>, 5)), %% A primitive must not be encoded with an indefinite length. - {error,{asn1,{invalid_length,_}}} = - (catch 'Constructed':decode('OS', <<4,128,4,3,97,98,99,0,0>>)), + {invalid_length,_} = dec_error('OS', <<4,128,4,3,97,98,99,0,0>>), ok. +dec_error(T, Bin) -> + {error,{asn1,{Reason,Stk}}} = 'Constructed':decode(T, Bin), + [{_,_,_,_}|_] = Stk, + Reason. + sub(Bin, Bytes) -> <<B:Bytes/binary,_/binary>> = Bin, B. diff --git a/lib/asn1/test/testChoPrim.erl b/lib/asn1/test/testChoPrim.erl index 573c482f2b..61b6ab2d05 100644 --- a/lib/asn1/test/testChoPrim.erl +++ b/lib/asn1/test/testChoPrim.erl @@ -31,10 +31,10 @@ bool(Rules) -> roundtrip('ChoCon', {int2,233}), case Rules of ber -> - {error,{asn1,{invalid_choice_type,wrong}}} = - (catch 'ChoPrim':encode('ChoCon', {wrong,233})), - {error,{asn1,{invalid_choice_tag,_WrongTag}}} = - (catch 'ChoPrim':decode('ChoCon', <<131,2,0,233>>)); + {error,{asn1,{{invalid_choice_type,wrong},[_|_]}}} = + (catch 'ChoPrim':encode('ChoCon', {wrong,233})), + {error,{asn1,{{invalid_choice_tag,_WrongTag},[_|_]}}} = + (catch 'ChoPrim':decode('ChoCon', <<131,2,0,233>>)); per -> ok; uper -> diff --git a/lib/asn1/test/testInfObjectClass.erl b/lib/asn1/test/testInfObjectClass.erl index 560986fac9..540407fa51 100644 --- a/lib/asn1/test/testInfObjectClass.erl +++ b/lib/asn1/test/testInfObjectClass.erl @@ -33,19 +33,29 @@ main(Rule) -> roundtrip('Seq', Val), %% OTP-5783 - {error,{asn1,{'Type not compatible with table constraint', - {component,'ArgumentType'}, - {value,_},_}}} = 'InfClass':encode('Seq', {'Seq',12,13,1}), + {'Type not compatible with table constraint', + {component,'ArgumentType'}, + {value,_},_} = enc_error('Seq', {'Seq',12,13,1}), Bytes2 = case Rule of ber -> <<48,9,2,1,12,2,1,11,2,1,1>>; _ -> <<1,12,1,11,1,1>> end, - {error,{asn1,{'Type not compatible with table constraint', - {{component,_}, - {value,_B},_}}}} = 'InfClass':decode('Seq', Bytes2), + {'Type not compatible with table constraint', + {{component,_}, + {value,_B},_}} = dec_error('Seq', Bytes2), ok. roundtrip(T, V) -> asn1_test_lib:roundtrip('InfClass', T, V). + +enc_error(T, V) -> + {error,{asn1,{Reason,Stk}}} = 'InfClass':encode(T, V), + [{_,_,_,_}|_] = Stk, + Reason. + +dec_error(T, Bin) -> + {error,{asn1,{Reason,Stk}}} = 'InfClass':decode(T, Bin), + [{_,_,_,_}|_] = Stk, + Reason. diff --git a/lib/asn1/test/testPrim.erl b/lib/asn1/test/testPrim.erl index 96a2dd6c79..b2933dfabc 100644 --- a/lib/asn1/test/testPrim.erl +++ b/lib/asn1/test/testPrim.erl @@ -34,15 +34,12 @@ bool(Rules) -> Types = ['Bool','BoolCon','BoolPri','BoolApp', 'BoolExpCon','BoolExpPri','BoolExpApp'], [roundtrip(T, V) || T <- Types, V <- [true,false]], - case Rules of - ber -> - [begin - {error,{asn1,{encode_boolean,517}}} = enc_error(T, 517) - end || T <- Types], - ok; - _ -> - ok - end. + Tag = case Rules of + ber -> encode_boolean; + _ -> illegal_boolean + end, + [{Tag,517} = enc_error(T, 517) || T <- Types], + ok. int(Rules) -> @@ -60,10 +57,22 @@ int(Rules) -> 123456789,12345678901234567890, -1,-2,-3,-4,-100,-127,-255,-256,-257, -1234567890,-2147483648], - [roundtrip(T, V) || - T <- ['Int','IntCon','IntPri','IntApp', - 'IntExpCon','IntExpPri','IntExpApp'], - V <- [1|Values]], + Types = ['Int','IntCon','IntPri','IntApp', + 'IntExpCon','IntExpPri','IntExpApp'], + _ = [roundtrip(T, V) || T <- Types, V <- [1|Values]], + Tag = case Rules of + ber -> encode_integer; + _ -> illegal_integer + end, + _ = [{Tag,V} = enc_error(T, V) || + T <- Types, V <- [atom,42.0,{a,b,c}]], + case Rules of + ber -> + ok; + _ -> + _ = [{Tag,V} = enc_error('IntConstrained', V) || + V <- [atom,-1,256,42.0]] + end, %%========================================================== %% IntEnum ::= INTEGER {first(1),last(31)} @@ -119,7 +128,11 @@ enum(Rules) -> roundtrip('Enum', monday), roundtrip('Enum', thursday), - {error,{asn1,{_,4}}} = enc_error('Enum', 4), + Tag = case Rules of + ber -> enumerated_not_in_range; + _ -> illegal_enumerated + end, + {Tag,4} = enc_error('Enum', 4), case Rules of Per when Per =:= per; Per =:= uper -> @@ -182,13 +195,15 @@ roundtrip(Type, Value, ExpectedValue) -> enc_error(T, V) -> case get(no_ok_wrapper) of false -> - 'Prim':encode(T, V); + {error,{asn1,{Reason,Stk}}} = 'Prim':encode(T, V), + [{_,_,_,_}|_] = Stk, + Reason; true -> try 'Prim':encode(T, V) of _ -> ?t:fail() catch - _:Reason -> + _:{error,{asn1,Reason}} -> Reason end end. diff --git a/lib/common_test/doc/src/Makefile b/lib/common_test/doc/src/Makefile index e495f587a3..152ece5d25 100644 --- a/lib/common_test/doc/src/Makefile +++ b/lib/common_test/doc/src/Makefile @@ -53,7 +53,8 @@ XML_REF3_FILES = ct.xml \ ct_slave.xml \ ct_property_test.xml \ ct_netconfc.xml \ - ct_hooks.xml + ct_hooks.xml \ + ct_testspec.xml XML_REF6_FILES = common_test_app.xml XML_PART_FILES = part.xml diff --git a/lib/common_test/doc/src/common_test_app.xml b/lib/common_test/doc/src/common_test_app.xml index 48ffe653e4..d407a0a53f 100644 --- a/lib/common_test/doc/src/common_test_app.xml +++ b/lib/common_test/doc/src/common_test_app.xml @@ -224,7 +224,9 @@ </type> <desc> - <p>OPTIONAL</p> + <p>OPTIONAL; if this function is defined, then <seealso + marker="#Module:end_per_suite-1"><c>end_per_suite/1</c></seealso> + must also be defined.</p> <p>This configuration function is called as the first function in the suite. It typically contains initializations that are common for @@ -256,7 +258,9 @@ </type> <desc> - <p>OPTIONAL</p> + <p>OPTIONAL; if this function is defined, then <seealso + marker="#Module:init_per_suite-1"><c>init_per_suite/1</c></seealso> + must also be defined.</p> <p>This function is called as the last test case in the suite. It is meant to be used for cleaning up after @@ -360,7 +364,9 @@ </type> <desc> - <p>OPTIONAL</p> + <p>OPTIONAL; if this function is defined, then <seealso + marker="#Module:end_per_group-2"><c>end_per_group/2</c></seealso> + must also be defined.</p> <p>This configuration function is called before execution of a test case group. It typically contains initializations that are @@ -396,7 +402,9 @@ </type> <desc> - <p>OPTIONAL</p> + <p>OPTIONAL; if this function is defined, then <seealso + marker="#Module:init_per_group-2"><c>init_per_group/2</c></seealso> + must also be defined.</p> <p>This function is called after the execution of a test case group is finished. It is meant to be used for cleaning up after @@ -427,7 +435,10 @@ </type> <desc> - <p>OPTIONAL</p> + <p>OPTIONAL; if this function is defined, + then <seealso marker="#Module:end_per_testcase-2"> + <c>end_per_testcase/2</c></seealso> must also be + defined.</p> <p>This function is called before each test case. Argument <c>TestCase</c> is the test case name, and @@ -454,7 +465,10 @@ </type> <desc> - <p>OPTIONAL</p> + <p>OPTIONAL; if this function is defined, + then <seealso marker="#Module:init_per_testcase-2"> + <c>init_per_testcase/2</c></seealso> must also be + defined.</p> <p>This function is called after each test case, and can be used to clean up after diff --git a/lib/common_test/doc/src/ct_hooks.xml b/lib/common_test/doc/src/ct_hooks.xml index c2cf29c530..a085f30262 100644 --- a/lib/common_test/doc/src/ct_hooks.xml +++ b/lib/common_test/doc/src/ct_hooks.xml @@ -208,9 +208,10 @@ </func> <func> - <name>Module:pre_init_per_group(GroupName, InitData, CTHState) -> Result</name> + <name>Module:pre_init_per_group(SuiteName, GroupName, InitData, CTHState) -> Result</name> <fsummary>Called before init_per_group.</fsummary> <type> + <v>SuiteName = atom()</v> <v>GroupName = atom()</v> <v>InitData = Config | SkipOrFail</v> <v>Config = NewConfig = [{Key,Value}]</v> @@ -231,13 +232,19 @@ but for function <seealso marker="common_test#Module:init_per_group-2"><c>init_per_group</c></seealso> instead.</p> + + <p>If <c>Module:pre_init_per_group/4</c> is not exported, common_test + will attempt to call <c>Module:pre_init_per_group(GroupName, + InitData, CTHState)</c> instead. This is for backwards + compatibility.</p> </desc> </func> <func> - <name>Module:post_init_per_group(GroupName, Config, Return, CTHState) -> Result</name> + <name>Module:post_init_per_group(SuiteName, GroupName, Config, Return, CTHState) -> Result</name> <fsummary>Called after init_per_group.</fsummary> <type> + <v>SuiteName = atom()</v> <v>GroupName = atom()</v> <v>Config = [{Key,Value}]</v> <v>Return = NewReturn = Config | SkipOrFail | term()</v> @@ -258,13 +265,19 @@ but for function <seealso marker="common_test#Module:init_per_group-2"><c>init_per_group</c></seealso> instead.</p> + + <p>If <c>Module:post_init_per_group/5</c> is not exported, common_test + will attempt to call <c>Module:post_init_per_group(GroupName, + Config, Return, CTHState)</c> instead. This is for backwards + compatibility.</p> </desc> </func> <func> - <name>Module:pre_init_per_testcase(TestcaseName, InitData, CTHState) -> Result</name> + <name>Module:pre_init_per_testcase(SuiteName, TestcaseName, InitData, CTHState) -> Result</name> <fsummary>Called before init_per_testcase.</fsummary> <type> + <v>SuiteName = atom()</v> <v>TestcaseName = atom()</v> <v>InitData = Config | SkipOrFail</v> <v>Config = NewConfig = [{Key,Value}]</v> @@ -286,6 +299,11 @@ <seealso marker="common_test#Module:init_per_testcase-2"><c>init_per_testcase</c></seealso> instead.</p> + <p>If <c>Module:pre_init_per_testcase/4</c> is not exported, common_test + will attempt to call <c>Module:pre_init_per_testcase(TestcaseName, + InitData, CTHState)</c> instead. This is for backwards + compatibility.</p> + <p>CTHs cannot be added here right now. That feature may be added in a later release, but it would right now break backwards compatibility.</p> @@ -293,9 +311,10 @@ </func> <func> - <name>Module:post_init_per_testcase(TestcaseName, Config, Return, CTHState) -> Result</name> + <name>Module:post_init_per_testcase(SuiteName, TestcaseName, Config, Return, CTHState) -> Result</name> <fsummary>Called after init_per_testcase.</fsummary> <type> + <v>SuiteName = atom()</v> <v>TestcaseName = atom()</v> <v>Config = [{Key,Value}]</v> <v>Return = NewReturn = Config | SkipOrFail | term()</v> @@ -316,15 +335,21 @@ but for function <seealso marker="common_test#Module:init_per_testcase-2"><c>init_per_testcase</c></seealso> instead.</p> + + <p>If <c>Module:post_init_per_testcase/5</c> is not exported, common_test + will attempt to call <c>Module:post_init_per_testcase(TestcaseName, + Config, Return, CTHState)</c> instead. This is for backwards + compatibility.</p> </desc> </func> <func> - <name>Module:pre_end_per_testcase(TestcaseName, InitData, CTHState) -> Result</name> + <name>Module:pre_end_per_testcase(SuiteName, TestcaseName, EndData, CTHState) -> Result</name> <fsummary>Called before end_per_testcase.</fsummary> <type> + <v>SuiteName = atom()</v> <v>TestcaseName = atom()</v> - <v>InitData = Config</v> + <v>EndData = Config</v> <v>Config = NewConfig = [{Key,Value}]</v> <v>CTHState = NewCTHState = term()</v> <v>Result = {NewConfig, NewCTHState}</v> @@ -345,14 +370,20 @@ <p>This function can not change the result of the test case by returning skip or fail tuples, but it may insert items in <c>Config</c> that can be read in - <c>end_per_testcase/2</c> or in <c>post_end_per_testcase/4</c>.</p> + <c>end_per_testcase/2</c> or in <c>post_end_per_testcase/5</c>.</p> + + <p>If <c>Module:pre_end_per_testcase/4</c> is not exported, common_test + will attempt to call <c>Module:pre_end_per_testcase(TestcaseName, + EndData, CTHState)</c> instead. This is for backwards + compatibility.</p> </desc> </func> <func> - <name>Module:post_end_per_testcase(TestcaseName, Config, Return, CTHState) -> Result</name> + <name>Module:post_end_per_testcase(SuiteName, TestcaseName, Config, Return, CTHState) -> Result</name> <fsummary>Called after end_per_testcase.</fsummary> <type> + <v>SuiteName = atom()</v> <v>TestcaseName = atom()</v> <v>Config = [{Key,Value}]</v> <v>Return = NewReturn = Config | SkipOrFail | term()</v> @@ -373,13 +404,19 @@ but for function <seealso marker="common_test#Module:end_per_testcase-2"><c>end_per_testcase</c></seealso> instead.</p> + + <p>If <c>Module:post_end_per_testcase/5</c> is not exported, common_test + will attempt to call <c>Module:post_end_per_testcase(TestcaseName, + Config, Return, CTHState)</c> instead. This is for backwards + compatibility.</p> </desc> </func> <func> - <name>Module:pre_end_per_group(GroupName, EndData, CTHState) -> Result</name> + <name>Module:pre_end_per_group(SuiteName, GroupName, EndData, CTHState) -> Result</name> <fsummary>Called before end_per_group.</fsummary> <type> + <v>SuiteName = atom()</v> <v>GroupName = atom()</v> <v>EndData = Config | SkipOrFail</v> <v>Config = NewConfig = [{Key,Value}]</v> @@ -400,13 +437,19 @@ but for function <seealso marker="common_test#Module:end_per_group-2"><c>end_per_group</c></seealso> instead.</p> + + <p>If <c>Module:pre_end_per_group/4</c> is not exported, common_test + will attempt to call <c>Module:pre_end_per_group(GroupName, + EndData, CTHState)</c> instead. This is for backwards + compatibility.</p> </desc> </func> <func> - <name>Module:post_end_per_group(GroupName, Config, Return, CTHState) -> Result</name> + <name>Module:post_end_per_group(SuiteName, GroupName, Config, Return, CTHState) -> Result</name> <fsummary>Called after end_per_group.</fsummary> <type> + <v>SuiteName = atom()</v> <v>GroupName = atom()</v> <v>Config = [{Key,Value}]</v> <v>Return = NewReturn = Config | SkipOrFail | term()</v> @@ -427,6 +470,11 @@ but for function <seealso marker="common_test#Module:end_per_group-2">end_per_group</seealso> instead.</p> + + <p>If <c>Module:post_end_per_group/5</c> is not exported, common_test + will attempt to call <c>Module:post_end_per_group(GroupName, + Config, Return, CTHState)</c> instead. This is for backwards + compatibility.</p> </desc> </func> @@ -485,9 +533,10 @@ </func> <func> - <name>Module:on_tc_fail(TestName, Reason, CTHState) -> NewCTHState</name> + <name>Module:on_tc_fail(SuiteName, TestName, Reason, CTHState) -> NewCTHState</name> <fsummary>Called after the CTH scope ends.</fsummary> <type> + <v>SuiteName = atom()</v> <v>TestName = init_per_suite | end_per_suite | {init_per_group,GroupName} | {end_per_group,GroupName} | {FuncName,GroupName} | FuncName</v> <v>FuncName = atom()</v> <v>GroupName = atom()</v> @@ -505,7 +554,7 @@ <item><p>If <c>init_per_suite</c> fails, this function is called after <seealso marker="#Module:post_init_per_suite-4"><c>post_init_per_suite</c></seealso>.</p></item> <item><p>If a test case fails, this funcion is called after - <seealso marker="#Module:post_end_per_testcase-4"><c>post_end_per_testcase</c></seealso>.</p></item> + <seealso marker="#Module:post_end_per_testcase-5"><c>post_end_per_testcase</c></seealso>.</p></item> </list> <p>If the failed test case belongs to a test case group, the first @@ -519,13 +568,19 @@ For details, see section <seealso marker="event_handler_chapter#events">Event Handling</seealso> in the User's Guide.</p> + + <p>If <c>Module:on_tc_fail/4</c> is not exported, common_test + will attempt to call <c>Module:on_tc_fail(TestName, Reason, + CTHState)</c> instead. This is for backwards + compatibility.</p> </desc> </func> <func> - <name>Module:on_tc_skip(TestName, Reason, CTHState) -> NewCTHState</name> + <name>Module:on_tc_skip(SuiteName, TestName, Reason, CTHState) -> NewCTHState</name> <fsummary>Called after the CTH scope ends.</fsummary> <type> + <v>SuiteName = atom()</v> <v>TestName = init_per_suite | end_per_suite | {init_per_group,GroupName} | {end_per_group,GroupName} | {FuncName,GroupName} | FuncName</v> <v>FuncName = atom()</v> <v>GroupName = atom()</v> @@ -542,9 +597,9 @@ <list type="bulleted"> <item><p>If <c>init_per_group</c> is skipped, this function is called after - <seealso marker="#Module:post_init_per_group-4"><c>post_init_per_group</c></seealso>.</p></item> + <seealso marker="#Module:post_init_per_group-5"><c>post_init_per_group</c></seealso>.</p></item> <item><p>If a test case is skipped, this function is called after - <seealso marker="#Module:post_end_per_testcase-4"><c>post_end_per_testcase</c></seealso>.</p></item> + <seealso marker="#Module:post_end_per_testcase-5"><c>post_end_per_testcase</c></seealso>.</p></item> </list> <p>If the skipped test case belongs to a test case group, the first @@ -559,6 +614,11 @@ For details, see section <seealso marker="event_handler_chapter#events">Event Handling</seealso> in the User's Guide.</p> + + <p>If <c>Module:on_tc_skip/4</c> is not exported, common_test + will attempt to call <c>Module:on_tc_skip(TestName, Reason, + CTHState)</c> instead. This is for backwards + compatibility.</p> </desc> </func> diff --git a/lib/common_test/doc/src/ct_hooks_chapter.xml b/lib/common_test/doc/src/ct_hooks_chapter.xml index 0e4c35e11f..bfad96e489 100644 --- a/lib/common_test/doc/src/ct_hooks_chapter.xml +++ b/lib/common_test/doc/src/ct_hooks_chapter.xml @@ -38,7 +38,7 @@ extensions of the default behavior of <c>Common Test</c> using hooks before and after all test suite calls. CTHs allow advanced <c>Common Test</c> users to abstract out behavior that is common to multiple test suites - without littering all test suites with library calls. this can be used + without littering all test suites with library calls. This can be used for logging, starting, and monitoring external systems, building C files needed by the tests, and so on.</p> @@ -175,10 +175,10 @@ <row> <cell><seealso marker="common_test#Module:init_per_group-2"> init_per_group/2</seealso></cell> - <cell><seealso marker="ct_hooks#Module:post_init_per_group-4"> - post_init_per_group/4</seealso> is called</cell> - <cell><seealso marker="ct_hooks#Module:post_end_per_suite-4"> - post_end_per_group/4</seealso> has been called for that group</cell> + <cell><seealso marker="ct_hooks#Module:post_init_per_group-5"> + post_init_per_group/5</seealso> is called</cell> + <cell><seealso marker="ct_hooks#Module:post_end_per_group-5"> + post_end_per_group/5</seealso> has been called for that group</cell> </row> <tcaption>Scope of a CTH</tcaption> </table> @@ -245,16 +245,18 @@ </list> <p> - This is done in the CTH functions called pre_<name of function>. - These functions take the same three arguments, <c>Name</c>, + This is done in the CTH functions called <c>pre_<name of function></c>. + These functions take the arguments <c>SuiteName</c>, <c>Name</c> (group or test case name, if applicable), <c>Config</c>, and <c>CTHState</c>. The return value of the CTH function is always a combination of a result for the suite/group/test and an updated <c>CTHState</c>.</p> <p>To let the test suite continue on executing, return the configuration - list that you want the test to use as the result. To skip or - fail the test, return a tuple with <c>skip</c> or <c>fail</c>, and a reason - as the result.</p> + list that you want the test to use as the result.</p> + + <p>All pre hooks, except <c>pre_end_per_testcase/4</c>, can + skip or fail the test by returning a tuple with <c>skip</c> or + <c>fail</c>, and a reason as the result.</p> <p><em>Example:</em></p> <code> @@ -290,7 +292,7 @@ <p> This is done in the CTH functions called <c>post_<name of function></c>. - These functions take the same four arguments, <c>Name</c>, + These functions take the arguments <c>SuiteName</c>, <c>Name</c> (group or test case name, if applicable), <c>Config</c>, <c>Return</c>, and <c>CTHState</c>. <c>Config</c> in this case is the same <c>Config</c> as the testcase is called with. <c>Return</c> is the value returned by the testcase. If the testcase @@ -308,7 +310,7 @@ <p><em>Example:</em></p> <code> - post_end_per_testcase(_TC, Config, {'EXIT',{_,_}}, CTHState) -> + post_end_per_testcase(_Suite, _TC, Config, {'EXIT',{_,_}}, CTHState) -> case db:check_consistency() of true -> %% DB is good, pass the test. @@ -317,7 +319,7 @@ %% DB is not good, mark as skipped instead of failing {{skip, "DB is inconsisten!"}, CTHState} end; - post_end_per_testcase(_TC, Config, Return, CTHState) -> + post_end_per_testcase(_Suite, _TC, Config, Return, CTHState) -> %% Do nothing if tc does not crash. {Return, CTHState}.</code> @@ -331,8 +333,8 @@ <title>Skip and Fail Hooks</title> <p> After any post hook has been executed for all installed CTHs, - <seealso marker="ct_hooks#Module:on_tc_fail-3">on_tc_fail</seealso> - or <seealso marker="ct_hooks#Module:on_tc_skip-3">on_tc_skip</seealso> + <seealso marker="ct_hooks#Module:on_tc_fail-4">on_tc_fail</seealso> + or <seealso marker="ct_hooks#Module:on_tc_skip-4">on_tc_skip</seealso> is called if the testcase failed or was skipped, respectively. You cannot affect the outcome of the tests any further at this point. </p> @@ -389,18 +391,18 @@ -export([pre_end_per_suite/3]). -export([post_end_per_suite/4]). - -export([pre_init_per_group/3]). - -export([post_init_per_group/4]). - -export([pre_end_per_group/3]). - -export([post_end_per_group/4]). + -export([pre_init_per_group/4]). + -export([post_init_per_group/5]). + -export([pre_end_per_group/4]). + -export([post_end_per_group/5]). - -export([pre_init_per_testcase/3]). - -export([post_init_per_testcase/4]). - -export([pre_end_per_testcase/3]). - -export([post_end_per_testcase/4]). + -export([pre_init_per_testcase/4]). + -export([post_init_per_testcase/5]). + -export([pre_end_per_testcase/4]). + -export([post_end_per_testcase/5]). - -export([on_tc_fail/3]). - -export([on_tc_skip/3]). + -export([on_tc_fail/4]). + -export([on_tc_skip/4]). -export([terminate/1]). @@ -435,46 +437,46 @@ total = State#state.total + State#state.suite_total } }. %% @doc Called before each init_per_group. - pre_init_per_group(Group,Config,State) -> + pre_init_per_group(Suite,Group,Config,State) -> {Config, State}. %% @doc Called after each init_per_group. - post_init_per_group(Group,Config,Return,State) -> + post_init_per_group(Suite,Group,Config,Return,State) -> {Return, State}. %% @doc Called before each end_per_group. - pre_end_per_group(Group,Config,State) -> + pre_end_per_group(Suite,Group,Config,State) -> {Config, State}. %% @doc Called after each end_per_group. - post_end_per_group(Group,Config,Return,State) -> + post_end_per_group(Suite,Group,Config,Return,State) -> {Return, State}. %% @doc Called before each init_per_testcase. - pre_init_per_testcase(TC,Config,State) -> + pre_init_per_testcase(Suite,TC,Config,State) -> {Config, State#state{ ts = now(), total = State#state.suite_total + 1 } }. %% Called after each init_per_testcase (immediately before the test case). - post_init_per_testcase(TC,Config,Return,State) -> + post_init_per_testcase(Suite,TC,Config,Return,State) -> {Return, State} %% @doc Called before each end_per_testcase (immediately after the test case). - pre_end_per_testcase(TC,Config,State) -> + pre_end_per_testcase(Suite,TC,Config,State) -> {Config, State}. %% @doc Called after each end_per_testcase. - post_end_per_testcase(TC,Config,Return,State) -> - TCInfo = {testcase, TC, Return, timer:now_diff(now(), State#state.ts)}, + post_end_per_testcase(Suite,TC,Config,Return,State) -> + TCInfo = {testcase, Suite, TC, Return, timer:now_diff(now(), State#state.ts)}, {Return, State#state{ ts = undefined, tcs = [TCInfo | State#state.tcs] } }. %% @doc Called after post_init_per_suite, post_end_per_suite, post_init_per_group, %% post_end_per_group and post_end_per_testcase if the suite, group or test case failed. - on_tc_fail(TC, Reason, State) -> + on_tc_fail(Suite, TC, Reason, State) -> State. %% @doc Called when a test case is skipped by either user action %% or due to an init function failing. - on_tc_skip(TC, Reason, State) -> + on_tc_skip(Suite, TC, Reason, State) -> State. %% @doc Called when the scope of the CTH is done diff --git a/lib/common_test/doc/src/ct_testspec.xml b/lib/common_test/doc/src/ct_testspec.xml new file mode 100644 index 0000000000..36893f66cf --- /dev/null +++ b/lib/common_test/doc/src/ct_testspec.xml @@ -0,0 +1,84 @@ +<?xml version="1.0" encoding="utf-8" ?> +<!DOCTYPE erlref SYSTEM "erlref.dtd"> + +<erlref> + <header> + <copyright> + <year>2016</year> + <holder>Ericsson AB. All Rights Reserved.</holder> + </copyright> + <legalnotice> + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + + </legalnotice> + + <title>ct_testspec</title> + <prepared></prepared> + <responsible></responsible> + <docno></docno> + <approved></approved> + <checked></checked> + <date></date> + <rev>A</rev> + <file>ct_testspec.xml</file> + </header> + <module>ct_testspec</module> + <modulesummary>Parsing of test specifications for Common Test. + </modulesummary> + +<description> + + <p>Parsing of test specifications for <c>Common Test</c>.</p> + + <p>This module exports help functions for parsing of test specifications.</p> + +</description> + + <funcs> + <func> + <name>get_tests(SpecsIn) -> {ok, [{Specs,Tests}]} | {error, Reason}</name> + <fsummary>Parse the given test specification files and return the tests to run and skip.</fsummary> + <type> + <v>SpecsIn = [string()] | [[string()]]</v> + <v>Specs = [string()]</v> + <v>Test = [{Node,Run,Skip}]</v> + <v>Node = atom()</v> + <v>Run = {Dir,Suites,Cases}</v> + <v>Skip = {Dir,Suites,Comment} | {Dir,Suites,Cases,Comment}</v> + <v>Dir = string()</v> + <v>Suites = atom | [atom()] | all</v> + <v>Cases = atom | [atom()] | all</v> + <v>Comment = string()</v> + <v>Reason = term()</v> + </type> + <desc><marker id="add_nodes-1"/> + <p>Parse the given test specification files and return the + tests to run and skip.</p> + + <p>If <c>SpecsIn=[Spec1,Spec2,...]</c>, separate tests will be + created per specification. If + <c>SpecsIn=[[Spec1,Spec2,...]]</c>, all specifications will be + merge into one test.</p> + + <p>For each test, a <c>{Specs,Tests}</c> element is returned, + where <c>Specs</c> is a list of all included test + specifications, and <c>Tests</c> specifies actual tests to + run/skip per node.</p> + </desc> + </func> + + </funcs> + +</erlref> + + diff --git a/lib/common_test/doc/src/ref_man.xml b/lib/common_test/doc/src/ref_man.xml index d1567e2d3c..1ac20db5c2 100644 --- a/lib/common_test/doc/src/ref_man.xml +++ b/lib/common_test/doc/src/ref_man.xml @@ -47,6 +47,7 @@ <xi:include href="ct_slave.xml"/> <xi:include href="ct_hooks.xml"/> <xi:include href="ct_property_test.xml"/> + <xi:include href="ct_testspec.xml"/> </application> diff --git a/lib/common_test/doc/src/write_test_chapter.xml b/lib/common_test/doc/src/write_test_chapter.xml index f70bdb16c5..6a0d87bcaf 100644 --- a/lib/common_test/doc/src/write_test_chapter.xml +++ b/lib/common_test/doc/src/write_test_chapter.xml @@ -566,7 +566,7 @@ for the test cases in the group. After execution of the group is finished, function <seealso marker="common_test#Module:end_per_group-2"><c>end_per_group(GroupName, Config)</c></seealso> is called. This function is meant to be used for cleaning up after - <c>init_per_group/2</c>.</p> + <c>init_per_group/2</c>. If the init function is defined, so must the end function be.</p> <p>Whenever a group is executed, if <c>init_per_group</c> and <c>end_per_group</c> do not exist in the suite, <c>Common Test</c> calls diff --git a/lib/common_test/src/ct_framework.erl b/lib/common_test/src/ct_framework.erl index 291a4d716c..43f1c9de0f 100644 --- a/lib/common_test/src/ct_framework.erl +++ b/lib/common_test/src/ct_framework.erl @@ -52,6 +52,10 @@ %%% %%% @doc Test server framework callback, called by the test_server %%% when a new test case is started. +init_tc(_,{end_per_testcase_not_run,_},[Config]) -> + %% Testcase is completed (skipped or failed), but end_per_testcase + %% is not run - don't call pre-hook. + {ok,[Config]}; init_tc(Mod,EPTC={end_per_testcase,_},[Config]) -> %% in case Mod == ct_framework, lookup the suite name Suite = get_suite_name(Mod, Config), @@ -62,7 +66,7 @@ init_tc(Mod,EPTC={end_per_testcase,_},[Config]) -> Other end; -init_tc(Mod,Func0,Args) -> +init_tc(Mod,Func0,Args) -> %% in case Mod == ct_framework, lookup the suite name Suite = get_suite_name(Mod, Args), {Func,HookFunc} = case Func0 of @@ -84,12 +88,15 @@ init_tc(Mod,Func0,Args) -> andalso Func=/=end_per_group andalso ct_util:get_testdata(skip_rest) of true -> + initialize(false,Mod,Func,Args), {auto_skip,"Repeated test stopped by force_stop option"}; _ -> case ct_util:get_testdata(curr_tc) of {Suite,{suite0_failed,{require,Reason}}} -> + initialize(false,Mod,Func,Args), {auto_skip,{require_failed_in_suite0,Reason}}; {Suite,{suite0_failed,_}=Failure} -> + initialize(false,Mod,Func,Args), {fail,Failure}; _ -> ct_util:update_testdata(curr_tc, @@ -118,16 +125,14 @@ init_tc(Mod,Func0,Args) -> end, init_tc1(Mod,Suite,Func,HookFunc,Args); {failed,Seq,BadFunc} -> - {auto_skip,{sequence_failed,Seq,BadFunc}} + initialize(false,Mod,Func,Args), + {auto_skip,{sequence_failed,Seq,BadFunc}} end end end. init_tc1(?MODULE,_,error_in_suite,_,[Config0]) when is_list(Config0) -> - ct_logs:init_tc(false), - ct_event:notify(#event{name=tc_start, - node=node(), - data={?MODULE,error_in_suite}}), + initialize(false,?MODULE,error_in_suite), _ = ct_suite_init(?MODULE,error_in_suite,[],Config0), case ?val(error,Config0) of undefined -> @@ -177,27 +182,21 @@ init_tc1(Mod,Suite,Func,HookFunc,[Config0]) when is_list(Config0) -> ct_config:delete_default_config(testcase), HookFunc end, - Initialize = fun() -> - ct_logs:init_tc(false), - ct_event:notify(#event{name=tc_start, - node=node(), - data={Mod,FuncSpec}}) - end, case add_defaults(Mod,Func,AllGroups) of Error = {suite0_failed,_} -> - Initialize(), + initialize(false,Mod,FuncSpec), ct_util:set_testdata({curr_tc,{Suite,Error}}), {error,Error}; Error = {group0_failed,_} -> - Initialize(), + initialize(false,Mod,FuncSpec), {auto_skip,Error}; Error = {testcase0_failed,_} -> - Initialize(), + initialize(false,Mod,FuncSpec), {auto_skip,Error}; {SuiteInfo,MergeResult} -> case MergeResult of {error,Reason} -> - Initialize(), + initialize(false,Mod,FuncSpec), {fail,Reason}; _ -> init_tc2(Mod,Suite,Func,HookFunc1, @@ -236,11 +235,8 @@ init_tc2(Mod,Suite,Func,HookFunc,SuiteInfo,MergeResult,Config) -> Conns -> ct_util:silence_connections(Conns) end, - ct_logs:init_tc(Func == init_per_suite), FuncSpec = group_or_func(Func,Config), - ct_event:notify(#event{name=tc_start, - node=node(), - data={Mod,FuncSpec}}), + initialize((Func==init_per_suite),Mod,FuncSpec), case catch configure(MergedInfo,MergedInfo,SuiteInfo, FuncSpec,[],Config) of @@ -268,6 +264,18 @@ init_tc2(Mod,Suite,Func,HookFunc,SuiteInfo,MergeResult,Config) -> end end. +initialize(RefreshLogs,Mod,Func,[Config]) when is_list(Config) -> + initialize(RefreshLogs,Mod,group_or_func(Func,Config)); +initialize(RefreshLogs,Mod,Func,_) -> + initialize(RefreshLogs,Mod,Func). + +initialize(RefreshLogs,Mod,FuncSpec) -> + ct_logs:init_tc(RefreshLogs), + ct_event:notify(#event{name=tc_start, + node=node(), + data={Mod,FuncSpec}}). + + ct_suite_init(Suite,HookFunc,PostInitHook,Config) when is_list(Config) -> case ct_hooks:init_tc(Suite,HookFunc,Config) of NewConfig when is_list(NewConfig) -> @@ -675,22 +683,35 @@ end_tc(Mod,Func,{Result,[Args]}, Return) -> end_tc(Mod,Func,self(),Result,Args,Return). end_tc(Mod,IPTC={init_per_testcase,_Func},_TCPid,Result,Args,Return) -> - %% in case Mod == ct_framework, lookup the suite name - Suite = get_suite_name(Mod, Args), - case ct_hooks:end_tc(Suite,IPTC,Args,Result,Return) of - '$ct_no_change' -> - ok; - HookResult -> - HookResult + case end_hook_func(IPTC,Return,IPTC) of + undefined -> ok; + _ -> + %% in case Mod == ct_framework, lookup the suite name + Suite = get_suite_name(Mod, Args), + case ct_hooks:end_tc(Suite,IPTC,Args,Result,Return) of + '$ct_no_change' -> + ok; + HookResult -> + HookResult + end end; end_tc(Mod,Func0,TCPid,Result,Args,Return) -> %% in case Mod == ct_framework, lookup the suite name Suite = get_suite_name(Mod, Args), - {EPTC,Func} = case Func0 of - {end_per_testcase,F} -> {true,F}; - _ -> {false,Func0} - end, + {Func,FuncSpec,HookFunc} = + case Func0 of + {end_per_testcase_not_run,F} -> + %% Testcase is completed (skipped or failed), but + %% end_per_testcase is not run - don't call post-hook. + {F,F,undefined}; + {end_per_testcase,F} -> + {F,F,Func0}; + _ -> + FS = group_or_func(Func0,Args), + HF = end_hook_func(Func0,Return,FS), + {Func0,FS,HF} + end, test_server:timetrap_cancel(), @@ -717,20 +738,18 @@ end_tc(Mod,Func0,TCPid,Result,Args,Return) -> end, ct_util:delete_suite_data(last_saved_config), - {FuncSpec,HookFunc} = - if not EPTC -> - FS = group_or_func(Func,Args), - {FS,FS}; - true -> - {Func,Func0} - end, {Result1,FinalNotify} = - case ct_hooks:end_tc(Suite,HookFunc,Args,Result,Return) of - '$ct_no_change' -> - {ok,Result}; - HookResult -> - {HookResult,HookResult} - end, + case HookFunc of + undefined -> + {ok,Result}; + _ -> + case ct_hooks:end_tc(Suite,HookFunc,Args,Result,Return) of + '$ct_no_change' -> + {ok,Result}; + HookResult -> + {HookResult,HookResult} + end + end, FinalResult = case get('$test_server_framework_test') of undefined -> @@ -821,6 +840,34 @@ end_tc(Mod,Func0,TCPid,Result,Args,Return) -> end, FinalResult. +%% This is to make sure that no post_init_per_* is ever called if the +%% corresponding pre_init_per_* was not called. +%% The skip or fail reasons are those that can be returned from +%% init_tc above in situations where we never came to call +%% ct_hooks:init_tc/3, e.g. if suite/0 fails, then we never call +%% ct_hooks:init_tc for init_per_suite, and thus we must not call +%% ct_hooks:end_tc for init_per_suite either. +end_hook_func({init_per_testcase,_},{auto_skip,{sequence_failed,_,_}},_) -> + undefined; +end_hook_func({init_per_testcase,_},{auto_skip,"Repeated test stopped by force_stop option"},_) -> + undefined; +end_hook_func({init_per_testcase,_},{fail,{config_name_already_in_use,_}},_) -> + undefined; +end_hook_func({init_per_testcase,_},{auto_skip,{InfoFuncError,_}},_) + when InfoFuncError==testcase0_failed; + InfoFuncError==require_failed -> + undefined; +end_hook_func(init_per_group,{auto_skip,{InfoFuncError,_}},_) + when InfoFuncError==group0_failed; + InfoFuncError==require_failed -> + undefined; +end_hook_func(init_per_suite,{auto_skip,{require_failed_in_suite0,_}},_) -> + undefined; +end_hook_func(init_per_suite,{auto_skip,{failed,{error,{suite0_failed,_}}}},_) -> + undefined; +end_hook_func(_,_,Default) -> + Default. + %% {error,Reason} | {skip,Reason} | {timetrap_timeout,TVal} | %% {testcase_aborted,Reason} | testcase_aborted_or_killed | %% {'EXIT',Reason} | {fail,Reason} | {failed,Reason} | @@ -1339,25 +1386,25 @@ report(What,Data) -> ok; tc_done -> {Suite,{Func,GrName},Result} = Data, - Data1 = if GrName == undefined -> {Suite,Func,Result}; - true -> Data - end, + FuncSpec = if GrName == undefined -> Func; + true -> {Func,GrName} + end, %% Register the group leader for the process calling the report %% function, making it possible for a hook function to print %% in the test case log file ReportingPid = self(), ct_logs:register_groupleader(ReportingPid, group_leader()), case Result of - {failed, _} -> - ct_hooks:on_tc_fail(What, Data1); - {skipped,{failed,{_,init_per_testcase,_}}} -> - ct_hooks:on_tc_skip(tc_auto_skip, Data1); - {skipped,{require_failed,_}} -> - ct_hooks:on_tc_skip(tc_auto_skip, Data1); - {skipped,_} -> - ct_hooks:on_tc_skip(tc_user_skip, Data1); - {auto_skipped,_} -> - ct_hooks:on_tc_skip(tc_auto_skip, Data1); + {failed, Reason} -> + ct_hooks:on_tc_fail(What, {Suite,FuncSpec,Reason}); + {skipped,{failed,{_,init_per_testcase,_}}=Reason} -> + ct_hooks:on_tc_skip(tc_auto_skip, {Suite,FuncSpec,Reason}); + {skipped,{require_failed,_}=Reason} -> + ct_hooks:on_tc_skip(tc_auto_skip, {Suite,FuncSpec,Reason}); + {skipped,Reason} -> + ct_hooks:on_tc_skip(tc_user_skip, {Suite,FuncSpec,Reason}); + {auto_skipped,Reason} -> + ct_hooks:on_tc_skip(tc_auto_skip, {Suite,FuncSpec,Reason}); _Else -> ok end, diff --git a/lib/common_test/src/ct_groups.erl b/lib/common_test/src/ct_groups.erl index 1375e7dcc7..1c9faf6a70 100644 --- a/lib/common_test/src/ct_groups.erl +++ b/lib/common_test/src/ct_groups.erl @@ -442,17 +442,21 @@ make_conf(Mod, Name, Props, TestSpec) -> ok end, {InitConf,EndConf,ExtraProps} = - case erlang:function_exported(Mod,init_per_group,2) of - true -> - {{Mod,init_per_group},{Mod,end_per_group},[]}; - false -> + case {erlang:function_exported(Mod,init_per_group,2), + erlang:function_exported(Mod,end_per_group,2)} of + {false,false} -> ct_logs:log("TEST INFO", "init_per_group/2 and " "end_per_group/2 missing for group " "~w in ~w, using default.", [Name,Mod]), {{ct_framework,init_per_group}, {ct_framework,end_per_group}, - [{suite,Mod}]} + [{suite,Mod}]}; + _ -> + %% If any of these exist, the other should too + %% (required and documented). If it isn't, it will fail + %% with reason 'undef'. + {{Mod,init_per_group},{Mod,end_per_group},[]} end, {conf,[{name,Name}|Props++ExtraProps],InitConf,TestSpec,EndConf}. diff --git a/lib/common_test/src/ct_hooks.erl b/lib/common_test/src/ct_hooks.erl index c9a4abb5ee..60d1ea2b1c 100644 --- a/lib/common_test/src/ct_hooks.erl +++ b/lib/common_test/src/ct_hooks.erl @@ -92,15 +92,17 @@ init_tc(Mod, end_per_suite, Config) -> call(fun call_generic/3, Config, [pre_end_per_suite, Mod]); init_tc(Mod, {init_per_group, GroupName, Properties}, Config) -> maybe_start_locker(Mod, GroupName, Properties), - call(fun call_generic/3, Config, [pre_init_per_group, GroupName]); -init_tc(_Mod, {end_per_group, GroupName, _}, Config) -> - call(fun call_generic/3, Config, [pre_end_per_group, GroupName]); -init_tc(_Mod, {init_per_testcase,TC}, Config) -> - call(fun call_generic/3, Config, [pre_init_per_testcase, TC]); -init_tc(_Mod, {end_per_testcase,TC}, Config) -> - call(fun call_generic/3, Config, [pre_end_per_testcase, TC]); -init_tc(_Mod, TC = error_in_suite, Config) -> - call(fun call_generic/3, Config, [pre_init_per_testcase, TC]). + call(fun call_generic_fallback/3, Config, + [pre_init_per_group, Mod, GroupName]); +init_tc(Mod, {end_per_group, GroupName, _}, Config) -> + call(fun call_generic_fallback/3, Config, + [pre_end_per_group, Mod, GroupName]); +init_tc(Mod, {init_per_testcase,TC}, Config) -> + call(fun call_generic_fallback/3, Config, [pre_init_per_testcase, Mod, TC]); +init_tc(Mod, {end_per_testcase,TC}, Config) -> + call(fun call_generic_fallback/3, Config, [pre_end_per_testcase, Mod, TC]); +init_tc(Mod, TC = error_in_suite, Config) -> + call(fun call_generic_fallback/3, Config, [pre_init_per_testcase, Mod, TC]). %% @doc Called as each test case is completed. This includes all configuration %% tests. @@ -126,23 +128,23 @@ end_tc(Mod, init_per_suite, Config, _Result, Return) -> end_tc(Mod, end_per_suite, Config, Result, _Return) -> call(fun call_generic/3, Result, [post_end_per_suite, Mod, Config], '$ct_no_change'); -end_tc(_Mod, {init_per_group, GroupName, _}, Config, _Result, Return) -> - call(fun call_generic/3, Return, [post_init_per_group, GroupName, Config], - '$ct_no_change'); +end_tc(Mod, {init_per_group, GroupName, _}, Config, _Result, Return) -> + call(fun call_generic_fallback/3, Return, + [post_init_per_group, Mod, GroupName, Config], '$ct_no_change'); end_tc(Mod, {end_per_group, GroupName, Properties}, Config, Result, _Return) -> - Res = call(fun call_generic/3, Result, - [post_end_per_group, GroupName, Config], '$ct_no_change'), + Res = call(fun call_generic_fallback/3, Result, + [post_end_per_group, Mod, GroupName, Config], '$ct_no_change'), maybe_stop_locker(Mod, GroupName, Properties), Res; -end_tc(_Mod, {init_per_testcase,TC}, Config, Result, _Return) -> - call(fun call_generic/3, Result, [post_init_per_testcase, TC, Config], - '$ct_no_change'); -end_tc(_Mod, {end_per_testcase,TC}, Config, Result, _Return) -> - call(fun call_generic/3, Result, [post_end_per_testcase, TC, Config], - '$ct_no_change'); -end_tc(_Mod, TC = error_in_suite, Config, Result, _Return) -> - call(fun call_generic/3, Result, [post_end_per_testcase, TC, Config], - '$ct_no_change'). +end_tc(Mod, {init_per_testcase,TC}, Config, Result, _Return) -> + call(fun call_generic_fallback/3, Result, + [post_init_per_testcase, Mod, TC, Config], '$ct_no_change'); +end_tc(Mod, {end_per_testcase,TC}, Config, Result, _Return) -> + call(fun call_generic_fallback/3, Result, + [post_end_per_testcase, Mod, TC, Config], '$ct_no_change'); +end_tc(Mod, TC = error_in_suite, Config, Result, _Return) -> + call(fun call_generic_fallback/3, Result, + [post_end_per_testcase, Mod, TC, Config], '$ct_no_change'). %% Case = TestCase | {TestCase,GroupName} @@ -181,15 +183,21 @@ call_terminate(#ct_hook_config{ module = Mod, state = State} = Hook, _, _) -> {[],Hook}. call_cleanup(#ct_hook_config{ module = Mod, state = State} = Hook, - Reason, [Function, _Suite | Args]) -> + Reason, [Function | Args]) -> NewState = catch_apply(Mod,Function, Args ++ [Reason, State], - State), + State, true), {Reason, Hook#ct_hook_config{ state = NewState } }. -call_generic(#ct_hook_config{ module = Mod, state = State} = Hook, - Value, [Function | Args]) -> +call_generic(Hook, Value, Meta) -> + do_call_generic(Hook, Value, Meta, false). + +call_generic_fallback(Hook, Value, Meta) -> + do_call_generic(Hook, Value, Meta, true). + +do_call_generic(#ct_hook_config{ module = Mod, state = State} = Hook, + Value, [Function | Args], Fallback) -> {NewValue, NewState} = catch_apply(Mod, Function, Args ++ [Value, State], - {Value,State}), + {Value,State}, Fallback), {NewValue, Hook#ct_hook_config{ state = NewState } }. %% Generic call function @@ -257,15 +265,15 @@ remove(Key,List) when is_list(List) -> remove(_, Else) -> Else. -%% Translate scopes, i.e. init_per_group,group1 -> end_per_group,group1 etc -scope([pre_init_per_testcase, TC|_]) -> - [post_init_per_testcase, TC]; -scope([pre_end_per_testcase, TC|_]) -> - [post_end_per_testcase, TC]; -scope([pre_init_per_group, GroupName|_]) -> - [post_end_per_group, GroupName]; -scope([post_init_per_group, GroupName|_]) -> - [post_end_per_group, GroupName]; +%% Translate scopes, i.e. is_tuplenit_per_group,group1 -> end_per_group,group1 etc +scope([pre_init_per_testcase, SuiteName, TC|_]) -> + [post_init_per_testcase, SuiteName, TC]; +scope([pre_end_per_testcase, SuiteName, TC|_]) -> + [post_end_per_testcase, SuiteName, TC]; +scope([pre_init_per_group, SuiteName, GroupName|_]) -> + [post_end_per_group, SuiteName, GroupName]; +scope([post_init_per_group, SuiteName, GroupName|_]) -> + [post_end_per_group, SuiteName, GroupName]; scope([pre_init_per_suite, SuiteName|_]) -> [post_end_per_suite, SuiteName]; scope([post_init_per_suite, SuiteName|_]) -> @@ -273,14 +281,29 @@ scope([post_init_per_suite, SuiteName|_]) -> scope(init) -> none. -terminate_if_scope_ends(HookId, [on_tc_skip,_Suite,{end_per_group,Name}], +strip_config([post_init_per_testcase, SuiteName, TC|_]) -> + [post_init_per_testcase, SuiteName, TC]; +strip_config([post_end_per_testcase, SuiteName, TC|_]) -> + [post_end_per_testcase, SuiteName, TC]; +strip_config([post_init_per_group, SuiteName, GroupName|_]) -> + [post_init_per_group, SuiteName, GroupName]; +strip_config([post_end_per_group, SuiteName, GroupName|_]) -> + [post_end_per_group, SuiteName, GroupName]; +strip_config([post_init_per_suite, SuiteName|_]) -> + [post_init_per_suite, SuiteName]; +strip_config([post_end_per_suite, SuiteName|_]) -> + [post_end_per_suite, SuiteName]; +strip_config(Other) -> + Other. + + +terminate_if_scope_ends(HookId, [on_tc_skip,Suite,{end_per_group,Name}], Hooks) -> - terminate_if_scope_ends(HookId, [post_end_per_group, Name], Hooks); + terminate_if_scope_ends(HookId, [post_end_per_group, Suite, Name], Hooks); terminate_if_scope_ends(HookId, [on_tc_skip,Suite,end_per_suite], Hooks) -> terminate_if_scope_ends(HookId, [post_end_per_suite, Suite], Hooks); -terminate_if_scope_ends(HookId, [Function,Tag|T], Hooks) when T =/= [] -> - terminate_if_scope_ends(HookId,[Function,Tag],Hooks); -terminate_if_scope_ends(HookId, Function, Hooks) -> +terminate_if_scope_ends(HookId, Function0, Hooks) -> + Function = strip_config(Function0), case lists:keyfind(HookId, #ct_hook_config.id, Hooks) of #ct_hook_config{ id = HookId, scope = Function} = Hook -> terminate([Hook]), @@ -384,21 +407,29 @@ pos(Id,[_|Rest],Num) -> catch_apply(M,F,A, Default) -> + catch_apply(M,F,A,Default,false). +catch_apply(M,F,A, Default, Fallback) -> + not erlang:module_loaded(M) andalso (catch M:module_info()), + case erlang:function_exported(M,F,length(A)) of + false when Fallback -> + catch_apply(M,F,tl(A),Default,false); + false -> + Default; + true -> + catch_apply(M,F,A) + end. + +catch_apply(M,F,A) -> try - erlang:apply(M,F,A) + erlang:apply(M,F,A) catch _:Reason -> - case erlang:get_stacktrace() of - %% Return the default if it was the CTH module which did not have the function. - [{M,F,A,_}|_] when Reason == undef -> - Default; - Trace -> - ct_logs:log("Suite Hook","Call to CTH failed: ~w:~p", - [error,{Reason,Trace}]), - throw({error_in_cth_call, - lists:flatten( - io_lib:format("~w:~w/~w CTH call failed", - [M,F,length(A)]))}) - end + Trace = erlang:get_stacktrace(), + ct_logs:log("Suite Hook","Call to CTH failed: ~w:~p", + [error,{Reason,Trace}]), + throw({error_in_cth_call, + lists:flatten( + io_lib:format("~w:~w/~w CTH call failed", + [M,F,length(A)]))}) end. diff --git a/lib/common_test/src/ct_release_test.erl b/lib/common_test/src/ct_release_test.erl index d783f8d04e..c53e72ee88 100644 --- a/lib/common_test/src/ct_release_test.erl +++ b/lib/common_test/src/ct_release_test.erl @@ -132,7 +132,7 @@ %%----------------------------------------------------------------- -define(testnode, 'ct_release_test-upgrade'). --define(exclude_apps, [hipe, typer, dialyzer]). % never include these apps +-define(exclude_apps, [hipe, dialyzer]). % never include these apps %%----------------------------------------------------------------- -record(ct_data, {from,to}). diff --git a/lib/common_test/src/ct_run.erl b/lib/common_test/src/ct_run.erl index a049ef5695..cac176de3a 100644 --- a/lib/common_test/src/ct_run.erl +++ b/lib/common_test/src/ct_run.erl @@ -76,8 +76,8 @@ abort_if_missing_suites, silent_connections = [], stylesheet, - multiply_timetraps = 1, - scale_timetraps = false, + multiply_timetraps, + scale_timetraps, create_priv_dir, testspec_files = [], current_testspec, @@ -264,11 +264,11 @@ script_start1(Parent, Args) -> [], Args), Verbosity = verbosity_args2opts(Args), MultTT = get_start_opt(multiply_timetraps, - fun([MT]) -> list_to_integer(MT) end, 1, Args), + fun([MT]) -> list_to_integer(MT) end, Args), ScaleTT = get_start_opt(scale_timetraps, fun([CT]) -> list_to_atom(CT); ([]) -> true - end, false, Args), + end, Args), CreatePrivDir = get_start_opt(create_priv_dir, fun([PD]) -> list_to_atom(PD); ([]) -> auto_per_tc @@ -1055,8 +1055,8 @@ run_test2(StartOpts) -> CoverStop = get_start_opt(cover_stop, value, StartOpts), %% timetrap manipulation - MultiplyTT = get_start_opt(multiply_timetraps, value, 1, StartOpts), - ScaleTT = get_start_opt(scale_timetraps, value, false, StartOpts), + MultiplyTT = get_start_opt(multiply_timetraps, value, StartOpts), + ScaleTT = get_start_opt(scale_timetraps, value, StartOpts), %% create unique priv dir names CreatePrivDir = get_start_opt(create_priv_dir, value, StartOpts), @@ -2280,8 +2280,19 @@ do_run_test(Tests, Skip, Opts0) -> _Lower -> ok end, - test_server_ctrl:multiply_timetraps(Opts0#opts.multiply_timetraps), - test_server_ctrl:scale_timetraps(Opts0#opts.scale_timetraps), + + case Opts0#opts.multiply_timetraps of + undefined -> MultTT = 1; + MultTT -> MultTT + end, + case Opts0#opts.scale_timetraps of + undefined -> ScaleTT = false; + ScaleTT -> ScaleTT + end, + ct_logs:log("TEST INFO","Timetrap time multiplier = ~w~n" + "Timetrap scaling enabled = ~w", [MultTT,ScaleTT]), + test_server_ctrl:multiply_timetraps(MultTT), + test_server_ctrl:scale_timetraps(ScaleTT), test_server_ctrl:create_priv_dir(choose_val( Opts0#opts.create_priv_dir, diff --git a/lib/common_test/src/ct_testspec.erl b/lib/common_test/src/ct_testspec.erl index 991abb0666..466a2c7658 100644 --- a/lib/common_test/src/ct_testspec.erl +++ b/lib/common_test/src/ct_testspec.erl @@ -26,7 +26,8 @@ -export([prepare_tests/1, prepare_tests/2, collect_tests_from_list/2, collect_tests_from_list/3, - collect_tests_from_file/2, collect_tests_from_file/3]). + collect_tests_from_file/2, collect_tests_from_file/3, + get_tests/1]). -export([testspec_rec2list/1, testspec_rec2list/2]). @@ -803,6 +804,31 @@ list_nodes(#testspec{nodes=NodeRefs}) -> lists:map(fun({_Ref,Node}) -> Node end, NodeRefs). +%%%----------------------------------------------------------------- +%%% Parse the given test specs and return the complete set of specs +%%% and tests to run/skip. +%%% [Spec1,Spec2,...] means create separate tests per spec +%%% [[Spec1,Spec2,...]] means merge all specs into one +-spec get_tests(Specs) -> {ok,[{Specs,Tests}]} | {error,Reason} when + Specs :: [string()] | [[string()]], + Tests :: {Node,Run,Skip}, + Node :: atom(), + Run :: {Dir,Suites,Cases}, + Skip :: {Dir,Suites,Comment} | {Dir,Suites,Cases,Comment}, + Dir :: string(), + Suites :: atom | [atom()] | all, + Cases :: atom | [atom()] | all, + Comment :: string(), + Reason :: term(). + +get_tests(Specs) -> + case collect_tests_from_file(Specs,true) of + Tests when is_list(Tests) -> + {ok,[{S,prepare_tests(R)} || {S,R} <- Tests]}; + Error -> + Error + end. + %% ----------------------------------------------------- %% / \ %% | When adding test/config terms, remember to update | @@ -1132,6 +1158,11 @@ handle_data(verbosity,Node,VLvls,_Spec) when is_list(VLvls) -> VLvls1 = lists:map(fun(VLvl = {_Cat,_Lvl}) -> VLvl; (Lvl) -> {'$unspecified',Lvl} end, VLvls), [{Node,VLvls1}]; +handle_data(multiply_timetraps,Node,Mult,_Spec) when is_integer(Mult) -> + [{Node,Mult}]; +handle_data(scale_timetraps,Node,Scale,_Spec) when Scale == true; + Scale == false -> + [{Node,Scale}]; handle_data(silent_connections,Node,all,_Spec) -> [{Node,[all]}]; handle_data(silent_connections,Node,Conn,_Spec) when is_atom(Conn) -> @@ -1150,6 +1181,8 @@ should_be_added(Tag,Node,_Data,Spec) -> Tag == label; Tag == auto_compile; Tag == abort_if_missing_suites; Tag == stylesheet; Tag == verbosity; + Tag == multiply_timetraps; + Tag == scale_timetraps; Tag == silent_connections -> lists:keymember(ref2node(Node,Spec#testspec.nodes),1, read_field(Spec,Tag)) == false; diff --git a/lib/common_test/src/cth_conn_log.erl b/lib/common_test/src/cth_conn_log.erl index 883da0da0a..ce8852b3ea 100644 --- a/lib/common_test/src/cth_conn_log.erl +++ b/lib/common_test/src/cth_conn_log.erl @@ -54,8 +54,8 @@ -include_lib("common_test/include/ct.hrl"). -export([init/2, - pre_init_per_testcase/3, - post_end_per_testcase/4]). + pre_init_per_testcase/4, + post_end_per_testcase/5]). %%---------------------------------------------------------------------- %% Exported types @@ -104,7 +104,7 @@ get_log_opts(Mod,Opts) -> Hosts = proplists:get_value(hosts,Opts,[]), {LogType,Hosts}. -pre_init_per_testcase(TestCase,Config,CthState) -> +pre_init_per_testcase(_Suite,TestCase,Config,CthState) -> Logs = lists:map( fun({ConnMod,{LogType,Hosts}}) -> @@ -158,7 +158,7 @@ pre_init_per_testcase(TestCase,Config,CthState) -> ct_util:update_testdata(?MODULE, Update, [create]), {Config,CthState}. -post_end_per_testcase(TestCase,_Config,Return,CthState) -> +post_end_per_testcase(_Suite,TestCase,_Config,Return,CthState) -> Update = fun(PrevUsers) -> case lists:delete(TestCase, PrevUsers) of diff --git a/lib/common_test/src/cth_log_redirect.erl b/lib/common_test/src/cth_log_redirect.erl index 6d77d7ee9e..eda090d4f5 100644 --- a/lib/common_test/src/cth_log_redirect.erl +++ b/lib/common_test/src/cth_log_redirect.erl @@ -28,10 +28,10 @@ %% CTH Callbacks -export([id/1, init/2, pre_init_per_suite/3, pre_end_per_suite/3, post_end_per_suite/4, - pre_init_per_group/3, post_init_per_group/4, - pre_end_per_group/3, post_end_per_group/4, - pre_init_per_testcase/3, post_init_per_testcase/4, - pre_end_per_testcase/3, post_end_per_testcase/4]). + pre_init_per_group/4, post_init_per_group/5, + pre_end_per_group/4, post_end_per_group/5, + pre_init_per_testcase/4, post_init_per_testcase/5, + pre_end_per_testcase/4, post_end_per_testcase/5]). %% Event handler Callbacks -export([init/1, @@ -71,11 +71,11 @@ post_end_per_suite(_Suite, Config, Return, State) -> set_curr_func(undefined, Config), {Return, State}. -pre_init_per_group(Group, Config, State) -> +pre_init_per_group(_Suite, Group, Config, State) -> set_curr_func({group,Group,init_per_group}, Config), {Config, State}. -post_init_per_group(Group, Config, Result, tc_log_async) when is_list(Config) -> +post_init_per_group(_Suite, Group, Config, Result, tc_log_async) when is_list(Config) -> case lists:member(parallel,proplists:get_value( tc_group_properties,Config,[])) of true -> @@ -83,33 +83,33 @@ post_init_per_group(Group, Config, Result, tc_log_async) when is_list(Config) -> false -> {Result, tc_log_async} end; -post_init_per_group(_Group, _Config, Result, State) -> +post_init_per_group(_Suite, _Group, _Config, Result, State) -> {Result, State}. -pre_init_per_testcase(TC, Config, State) -> +pre_init_per_testcase(_Suite, TC, Config, State) -> set_curr_func(TC, Config), {Config, State}. -post_init_per_testcase(_TC, _Config, Return, State) -> +post_init_per_testcase(_Suite, _TC, _Config, Return, State) -> {Return, State}. -pre_end_per_testcase(_TC, Config, State) -> +pre_end_per_testcase(_Suite, _TC, Config, State) -> {Config, State}. -post_end_per_testcase(_TC, _Config, Result, State) -> +post_end_per_testcase(_Suite, _TC, _Config, Result, State) -> %% Make sure that the event queue is flushed %% before ending this test case. gen_event:call(error_logger, ?MODULE, flush, 300000), {Result, State}. -pre_end_per_group(Group, Config, {tc_log, Group}) -> +pre_end_per_group(_Suite, Group, Config, {tc_log, Group}) -> set_curr_func({group,Group,end_per_group}, Config), {Config, set_log_func(tc_log_async)}; -pre_end_per_group(Group, Config, State) -> +pre_end_per_group(_Suite, Group, Config, State) -> set_curr_func({group,Group,end_per_group}, Config), {Config, State}. -post_end_per_group(_Group, Config, Return, State) -> +post_end_per_group(_Suite, _Group, Config, Return, State) -> set_curr_func({group,undefined}, Config), {Return, State}. diff --git a/lib/common_test/src/cth_surefire.erl b/lib/common_test/src/cth_surefire.erl index 59b916851e..c4941948cc 100644 --- a/lib/common_test/src/cth_surefire.erl +++ b/lib/common_test/src/cth_surefire.erl @@ -33,16 +33,16 @@ -export([pre_end_per_suite/3]). -export([post_end_per_suite/4]). --export([pre_init_per_group/3]). --export([post_init_per_group/4]). --export([pre_end_per_group/3]). --export([post_end_per_group/4]). +-export([pre_init_per_group/4]). +-export([post_init_per_group/5]). +-export([pre_end_per_group/4]). +-export([post_end_per_group/5]). --export([pre_init_per_testcase/3]). --export([post_end_per_testcase/4]). +-export([pre_init_per_testcase/4]). +-export([post_end_per_testcase/5]). --export([on_tc_fail/3]). --export([on_tc_skip/3]). +-export([on_tc_fail/4]). +-export([on_tc_skip/4]). -export([terminate/1]). @@ -116,29 +116,29 @@ pre_end_per_suite(_Suite,Config,State) -> post_end_per_suite(_Suite,Config,Result,State) -> {Result, end_tc(end_per_suite,Config,Result,State)}. -pre_init_per_group(Group,Config,State) -> +pre_init_per_group(_Suite,Group,Config,State) -> {Config, init_tc(State#state{ curr_group = [Group|State#state.curr_group]}, Config)}. -post_init_per_group(_Group,Config,Result,State) -> +post_init_per_group(_Suite,_Group,Config,Result,State) -> {Result, end_tc(init_per_group,Config,Result,State)}. -pre_end_per_group(_Group,Config,State) -> +pre_end_per_group(_Suite,_Group,Config,State) -> {Config, init_tc(State, Config)}. -post_end_per_group(_Group,Config,Result,State) -> +post_end_per_group(_Suite,_Group,Config,Result,State) -> NewState = end_tc(end_per_group, Config, Result, State), {Result, NewState#state{ curr_group = tl(NewState#state.curr_group)}}. -pre_init_per_testcase(_TC,Config,State) -> +pre_init_per_testcase(_Suite,_TC,Config,State) -> {Config, init_tc(State, Config)}. -post_end_per_testcase(TC,Config,Result,State) -> +post_end_per_testcase(_Suite,TC,Config,Result,State) -> {Result, end_tc(TC,Config, Result,State)}. -on_tc_fail(_TC, _Res, State = #state{test_cases = []}) -> +on_tc_fail(_Suite,_TC, _Res, State = #state{test_cases = []}) -> State; -on_tc_fail(_TC, Res, State) -> +on_tc_fail(_Suite,_TC, Res, State) -> TCs = State#state.test_cases, TC = hd(TCs), NewTC = TC#testcase{ @@ -146,10 +146,9 @@ on_tc_fail(_TC, Res, State) -> {fail,lists:flatten(io_lib:format("~p",[Res]))} }, State#state{ test_cases = [NewTC | tl(TCs)]}. -on_tc_skip({ConfigFunc,_GrName},{Type,_Reason} = Res, State0) - when Type == tc_auto_skip; Type == tc_user_skip -> - on_tc_skip(ConfigFunc, Res, State0); -on_tc_skip(Tc,{Type,_Reason} = Res, State0) when Type == tc_auto_skip -> +on_tc_skip(Suite,{ConfigFunc,_GrName}, Res, State) -> + on_tc_skip(Suite,ConfigFunc, Res, State); +on_tc_skip(Suite,Tc, Res, State0) -> TcStr = atom_to_list(Tc), State = case State0#state.test_cases of @@ -158,11 +157,7 @@ on_tc_skip(Tc,{Type,_Reason} = Res, State0) when Type == tc_auto_skip -> _ -> State0 end, - do_tc_skip(Res, end_tc(Tc,[],Res,init_tc(State,[]))); -on_tc_skip(_Tc, _Res, State = #state{test_cases = []}) -> - State; -on_tc_skip(_Tc, Res, State) -> - do_tc_skip(Res, State). + do_tc_skip(Res, end_tc(Tc,[],Res,init_tc(set_suite(Suite,State),[]))). do_tc_skip(Res, State) -> TCs = State#state.test_cases, @@ -209,6 +204,12 @@ end_tc(Name, _Config, _Res, State = #state{ curr_suite = Suite, result = passed }| State#state.test_cases], tc_log = ""}. % so old tc_log is not set if next is on_tc_skip + +set_suite(Suite,#state{curr_suite=undefined}=State) -> + State#state{curr_suite=Suite, curr_suite_ts=?now}; +set_suite(_,State) -> + State. + close_suite(#state{ test_cases = [] } = State) -> State; close_suite(#state{ test_cases = TCs, url_base = UrlBase } = State) -> @@ -228,7 +229,8 @@ close_suite(#state{ test_cases = TCs, url_base = UrlBase } = State) -> testcases = lists:reverse(TCs), log = SuiteLog, url = SuiteUrl}, - State#state{ test_cases = [], + State#state{ curr_suite = undefined, + test_cases = [], test_suites = [Suite | State#state.test_suites]}. terminate(State = #state{ test_cases = [] }) -> diff --git a/lib/common_test/src/test_server.erl b/lib/common_test/src/test_server.erl index 924086f2bd..be49191f2e 100644 --- a/lib/common_test/src/test_server.erl +++ b/lib/common_test/src/test_server.erl @@ -778,9 +778,9 @@ spawn_fw_call(Mod,IPTC={init_per_testcase,Func},CurrConf,Pid, %% if init_per_testcase fails, the test case %% should be skipped try begin do_end_tc_call(Mod,IPTC, {Pid,Skip,[CurrConf]}, Why), - do_init_tc_call(Mod,{end_per_testcase,Func}, + do_init_tc_call(Mod,{end_per_testcase_not_run,Func}, [CurrConf],{ok,[CurrConf]}), - do_end_tc_call(Mod,{end_per_testcase,Func}, + do_end_tc_call(Mod,{end_per_testcase_not_run,Func}, {Pid,Skip,[CurrConf]}, Why) end of _ -> ok catch @@ -1151,14 +1151,14 @@ do_end_tc_call(Mod, IPTC={init_per_testcase,Func}, Res, Return) -> Args end, EPTCInitRes = - case do_init_tc_call(Mod,{end_per_testcase,Func}, + case do_init_tc_call(Mod,{end_per_testcase_not_run,Func}, IPTCEndRes,Return) of {ok,EPTCInitConfig} when is_list(EPTCInitConfig) -> {Return,EPTCInitConfig}; _ -> - Return + {Return,IPTCEndRes} end, - do_end_tc_call1(Mod, {end_per_testcase,Func}, + do_end_tc_call1(Mod, {end_per_testcase_not_run,Func}, EPTCInitRes, Return); _Ok -> do_end_tc_call1(Mod, IPTC, Res, Return) diff --git a/lib/common_test/src/test_server_ctrl.erl b/lib/common_test/src/test_server_ctrl.erl index b52e4bef9b..39c523f8b3 100644 --- a/lib/common_test/src/test_server_ctrl.erl +++ b/lib/common_test/src/test_server_ctrl.erl @@ -2051,17 +2051,21 @@ add_init_and_end_per_suite([], _LastMod, skipped_suite, _FwMod) -> add_init_and_end_per_suite([], LastMod, LastRef, FwMod) -> %% we'll add end_per_suite here even if it's not exported %% (and simply let the call fail if it's missing) - case erlang:function_exported(LastMod, end_per_suite, 1) of - true -> - [{conf,LastRef,[],{LastMod,end_per_suite}}]; - false -> + case {erlang:function_exported(LastMod, end_per_suite, 1), + erlang:function_exported(LastMod, init_per_suite, 1)} of + {false,false} -> %% let's call a "fake" end_per_suite if it exists case erlang:function_exported(FwMod, end_per_suite, 1) of true -> [{conf,LastRef,[{suite,LastMod}],{FwMod,end_per_suite}}]; false -> [{conf,LastRef,[],{LastMod,end_per_suite}}] - end + end; + _ -> + %% If any of these exist, the other should too + %% (required and documented). If it isn't, it will fail + %% with reason 'undef'. + [{conf,LastRef,[],{LastMod,end_per_suite}}] end. do_add_init_and_end_per_suite(LastMod, LastRef, Mod, FwMod) -> @@ -2070,11 +2074,9 @@ do_add_init_and_end_per_suite(LastMod, LastRef, Mod, FwMod) -> _ -> ok end, {Init,NextMod,NextRef} = - case erlang:function_exported(Mod, init_per_suite, 1) of - true -> - Ref = make_ref(), - {[{conf,Ref,[],{Mod,init_per_suite}}],Mod,Ref}; - false -> + case {erlang:function_exported(Mod, init_per_suite, 1), + erlang:function_exported(Mod, end_per_suite, 1)} of + {false,false} -> %% let's call a "fake" init_per_suite if it exists case erlang:function_exported(FwMod, init_per_suite, 1) of true -> @@ -2083,8 +2085,13 @@ do_add_init_and_end_per_suite(LastMod, LastRef, Mod, FwMod) -> {FwMod,init_per_suite}}],Mod,Ref}; false -> {[],Mod,undefined} - end - + end; + _ -> + %% If any of these exist, the other should too + %% (required and documented). If it isn't, it will fail + %% with reason 'undef'. + Ref = make_ref(), + {[{conf,Ref,[],{Mod,init_per_suite}}],Mod,Ref} end, Cases = if LastRef==undefined -> @@ -2094,10 +2101,9 @@ do_add_init_and_end_per_suite(LastMod, LastRef, Mod, FwMod) -> true -> %% we'll add end_per_suite here even if it's not exported %% (and simply let the call fail if it's missing) - case erlang:function_exported(LastMod, end_per_suite, 1) of - true -> - [{conf,LastRef,[],{LastMod,end_per_suite}}|Init]; - false -> + case {erlang:function_exported(LastMod, end_per_suite, 1), + erlang:function_exported(LastMod, init_per_suite, 1)} of + {false,false} -> %% let's call a "fake" end_per_suite if it exists case erlang:function_exported(FwMod, end_per_suite, 1) of true -> @@ -2105,8 +2111,13 @@ do_add_init_and_end_per_suite(LastMod, LastRef, Mod, FwMod) -> {FwMod,end_per_suite}}|Init]; false -> [{conf,LastRef,[],{LastMod,end_per_suite}}|Init] - end - end + end; + _ -> + %% If any of these exist, the other should too + %% (required and documented). If it isn't, it will fail + %% with reason 'undef'. + [{conf,LastRef,[],{LastMod,end_per_suite}}|Init] + end end, {Cases,NextMod,NextRef}. @@ -2115,11 +2126,9 @@ do_add_end_per_suite_and_skip(LastMod, LastRef, Mod, FwMod) -> No when No==undefined ; No==skipped_suite -> {[],Mod,skipped_suite}; _Ref -> - case erlang:function_exported(LastMod, end_per_suite, 1) of - true -> - {[{conf,LastRef,[],{LastMod,end_per_suite}}], - Mod,skipped_suite}; - false -> + case {erlang:function_exported(LastMod, end_per_suite, 1), + erlang:function_exported(LastMod, init_per_suite, 1)} of + {false,false} -> case erlang:function_exported(FwMod, end_per_suite, 1) of true -> %% let's call "fake" end_per_suite if it exists @@ -2128,7 +2137,13 @@ do_add_end_per_suite_and_skip(LastMod, LastRef, Mod, FwMod) -> false -> {[{conf,LastRef,[],{LastMod,end_per_suite}}], Mod,skipped_suite} - end + end; + _ -> + %% If any of these exist, the other should too + %% (required and documented). If it isn't, it will fail + %% with reason 'undef'. + {[{conf,LastRef,[],{LastMod,end_per_suite}}], + Mod,skipped_suite} end end. @@ -2924,22 +2939,21 @@ run_test_cases_loop([{Mod,Func,Args}|Cases], Config, TimetrapData, Mode, Status) exit(framework_error); %% sequential execution of test case finished {Time,RetVal,_} -> + RetTag = + if is_tuple(RetVal) -> element(1,RetVal); + true -> undefined + end, {Failed,Status1} = - case Time of - died -> - {true,update_status(failed, Mod, Func, Status)}; - _ when is_tuple(RetVal) -> - case element(1, RetVal) of - R when R=='EXIT'; R==failed -> - {true,update_status(failed, Mod, Func, Status)}; - R when R==skip; R==skipped -> - {false,update_status(skipped, Mod, Func, Status)}; - _ -> - {false,update_status(ok, Mod, Func, Status)} - end; - _ -> - {false,update_status(ok, Mod, Func, Status)} - end, + case RetTag of + Skip when Skip==skip; Skip==skipped -> + {false,update_status(skipped, Mod, Func, Status)}; + Fail when Fail=='EXIT'; Fail==failed -> + {true,update_status(failed, Mod, Func, Status)}; + _ when Time==died, RetVal=/=ok -> + {true,update_status(failed, Mod, Func, Status)}; + _ -> + {false,update_status(ok, Mod, Func, Status)} + end, case check_prop(sequence, Mode) of false -> stop_minor_log_file(), @@ -3794,7 +3808,15 @@ run_test_case1(Ref, Num, Mod, Func, Args, RunInit, {died,{timetrap_timeout,TimetrapTimeout}} -> progress(failed, Num, Mod, Func, GrName, Loc, timetrap_timeout, TimetrapTimeout, Comment, Style); - {died,Reason} -> + {died,{Skip,Reason}} when Skip==skip; Skip==skipped -> + %% died in init_per_testcase + progress(skip, Num, Mod, Func, GrName, Loc, Reason, + Time, Comment, Style); + {died,Reason} when Reason=/=ok -> + %% (If Reason==ok it means that process died in + %% end_per_testcase after successfully completing the + %% test case itself - then we shall not fail, but a + %% warning will be issued in the comment field.) progress(failed, Num, Mod, Func, GrName, Loc, Reason, Time, Comment, Style); {_,{'EXIT',{Skip,Reason}}} when Skip==skip; Skip==skipped; @@ -3943,6 +3965,9 @@ progress(skip, CaseNum, Mod, Func, GrName, Loc, Reason, Time, [get_info_str(Mod,Func, CaseNum, get(test_server_cases))]), test_server_sup:framework_call(report, [tc_done,{Mod,{Func,GrName}, {ReportTag,Reason1}}]), + TimeStr = io_lib:format(if is_float(Time) -> "~.3fs"; + true -> "~w" + end, [Time]), ReasonStr = escape_chars(reason_to_string(Reason1)), ReasonStr1 = lists:flatten([string:strip(S,left) || S <- string:tokens(ReasonStr,[$\n])]), @@ -3957,10 +3982,10 @@ progress(skip, CaseNum, Mod, Func, GrName, Loc, Reason, Time, _ -> xhtml("<br>(","<br />(") ++ to_string(Comment) ++ ")" end, print(html, - "<td>" ++ St0 ++ "~.3fs" ++ St1 ++ "</td>" + "<td>" ++ St0 ++ "~ts" ++ St1 ++ "</td>" "<td><font color=\"~ts\">SKIPPED</font></td>" "<td>~ts~ts</td></tr>\n", - [Time,Color,ReasonStr2,Comment1]), + [TimeStr,Color,ReasonStr2,Comment1]), FormatLoc = test_server_sup:format_loc(Loc), print(minor, "=== Location: ~ts", [FormatLoc]), print(minor, "=== Reason: ~ts", [ReasonStr1]), @@ -4098,6 +4123,9 @@ progress(ok, _CaseNum, Mod, Func, GrName, _Loc, RetVal, Time, Comment0, {St0,St1}) -> print(minor, "successfully completed test case", []), test_server_sup:framework_call(report, [tc_done,{Mod,{Func,GrName},ok}]), + TimeStr = io_lib:format(if is_float(Time) -> "~.3fs"; + true -> "~w" + end, [Time]), Comment = case RetVal of {comment,RetComment} -> @@ -4116,10 +4144,10 @@ progress(ok, _CaseNum, Mod, Func, GrName, _Loc, RetVal, Time, end, print(major, "=elapsed ~p", [Time]), print(html, - "<td>" ++ St0 ++ "~.3fs" ++ St1 ++ "</td>" + "<td>" ++ St0 ++ "~ts" ++ St1 ++ "</td>" "<td><font color=\"green\">Ok</font></td>" "~ts</tr>\n", - [Time,Comment]), + [TimeStr,Comment]), print(minor, escape_chars(io_lib:format("=== Returned value: ~tp", [RetVal])), []), diff --git a/lib/common_test/test/ct_error_SUITE.erl b/lib/common_test/test/ct_error_SUITE.erl index fae23484e6..621f3b6d2d 100644 --- a/lib/common_test/test/ct_error_SUITE.erl +++ b/lib/common_test/test/ct_error_SUITE.erl @@ -1531,17 +1531,17 @@ test_events(config_func_errors) -> {?eh,tc_start,{config_func_error_1_SUITE,exit_in_iptc}}, {?eh,tc_done,{config_func_error_1_SUITE,exit_in_iptc,'_'}}, - {?eh,test_stats,{0,1,{0,0}}}, + {?eh,test_stats,{0,0,{0,1}}}, {?eh,tc_start,{config_func_error_1_SUITE,exit_in_eptc}}, {?eh,tc_done,{config_func_error_1_SUITE,exit_in_eptc,'_'}}, - {?eh,test_stats,{0,2,{0,0}}}, + {?eh,test_stats,{1,0,{0,1}}}, [{?eh,tc_start,{config_func_error_1_SUITE,{init_per_group,g1,[]}}}, {?eh,tc_done,{config_func_error_1_SUITE,{init_per_group,g1,[]},ok}}, {?eh,tc_start,{config_func_error_1_SUITE,exit_in_iptc}}, {?eh,tc_done,{config_func_error_1_SUITE,exit_in_iptc,'_'}}, - {?eh,test_stats,{0,3,{0,0}}}, + {?eh,test_stats,{1,0,{0,2}}}, {?eh,tc_start,{config_func_error_1_SUITE,{end_per_group,g1,[]}}}, {?eh,tc_done,{config_func_error_1_SUITE,{end_per_group,g1,[]},ok}}], @@ -1549,7 +1549,7 @@ test_events(config_func_errors) -> {?eh,tc_done,{config_func_error_1_SUITE,{init_per_group,g2,[]},ok}}, {?eh,tc_start,{config_func_error_1_SUITE,exit_in_eptc}}, {?eh,tc_done,{config_func_error_1_SUITE,exit_in_eptc,'_'}}, - {?eh,test_stats,{0,4,{0,0}}}, + {?eh,test_stats,{2,0,{0,2}}}, {?eh,tc_start,{config_func_error_1_SUITE,{end_per_group,g2,[]}}}, {?eh,tc_done,{config_func_error_1_SUITE,{end_per_group,g2,[]},ok}}], diff --git a/lib/common_test/test/ct_hooks_SUITE.erl b/lib/common_test/test/ct_hooks_SUITE.erl index bc716fb5e3..93bcb8fe52 100644 --- a/lib/common_test/test/ct_hooks_SUITE.erl +++ b/lib/common_test/test/ct_hooks_SUITE.erl @@ -82,10 +82,13 @@ all(suite) -> scope_suite_state_cth, fail_pre_suite_cth, double_fail_pre_suite_cth, fail_post_suite_cth, skip_pre_suite_cth, skip_pre_end_cth, + skip_pre_init_tc_cth, skip_post_suite_cth, recover_post_suite_cth, update_config_cth, state_update_cth, options_cth, same_id_cth, fail_n_skip_with_minimal_cth, prio_cth, no_config, - data_dir, cth_log + no_init_suite_config, no_init_config, no_end_config, + failed_sequence, repeat_force_stop, config_clash, + callbacks_on_skip, fallback, data_dir, cth_log ] ). @@ -190,6 +193,10 @@ skip_post_suite_cth(Config) when is_list(Config) -> do_test(skip_post_suite_cth, "ct_cth_empty_SUITE.erl", [skip_post_suite_cth],Config). +skip_pre_init_tc_cth(Config) -> + do_test(skip_pre_init_tc_cth, "ct_cth_empty_SUITE.erl", + [skip_pre_init_tc_cth],Config). + recover_post_suite_cth(Config) when is_list(Config) -> do_test(recover_post_suite_cth, "ct_cth_fail_per_suite_SUITE.erl", [recover_post_suite_cth],Config). @@ -223,6 +230,16 @@ no_config(Config) when is_list(Config) -> do_test(no_config, "ct_no_config_SUITE.erl", [verify_config_cth],Config). +no_init_suite_config(Config) when is_list(Config) -> + do_test(no_init_suite_config, "ct_no_init_suite_config_SUITE.erl", + [empty_cth],Config). + +no_init_config(Config) when is_list(Config) -> + do_test(no_init_config, "ct_no_init_config_SUITE.erl",[empty_cth],Config). + +no_end_config(Config) when is_list(Config) -> + do_test(no_end_config, "ct_no_end_config_SUITE.erl",[empty_cth],Config). + data_dir(Config) when is_list(Config) -> do_test(data_dir, "ct_data_dir_SUITE.erl", [verify_data_dir_cth],Config). @@ -254,24 +271,53 @@ cth_log(Config) when is_list(Config) -> end, UnexpIoLogs), ok. +%% OTP-10599 adds the Suite argument as first argument to all hook +%% callbacks that did not have a Suite argument from before. This test +%% checks that ct_hooks will fall back to old versions of callbacks if +%% new versions are not exported. +fallback(Config) -> + do_test(fallback, "all_hook_callbacks_SUITE.erl",[fallback_cth], Config). + +%% Test that expected callbacks, and only those, are called when tests +%% are skipped in different ways +callbacks_on_skip(Config) -> + do_test(callbacks_on_skip, {spec,"skip.spec"},[skip_cth], Config). + +%% Test that expected callbacks, and only those, are called when tests +%% are skipped due to failed sequence +failed_sequence(Config) -> + do_test(failed_sequence, "seq_SUITE.erl", [skip_cth], Config). + +%% Test that expected callbacks, and only those, are called when tests +%% are skipped due to {force_stop,skip_rest} option +repeat_force_stop(Config) -> + do_test(repeat_force_stop, "repeat_SUITE.erl", [skip_cth], Config, ok, 2, + [{force_stop,skip_rest},{duration,"000009"}]). + +%% Test that expected callbacks, and only those, are called when a test +%% are fails due to clash in config alias names +config_clash(Config) -> + do_test(config_clash, "config_clash_SUITE.erl", [skip_cth], Config). %%%----------------------------------------------------------------- %%% HELP FUNCTIONS %%%----------------------------------------------------------------- -do_test(Tag, SWC, CTHs, Config) -> - do_test(Tag, SWC, CTHs, Config, ok). -do_test(Tag, SWC, CTHs, Config, {error,_} = Res) -> - do_test(Tag, SWC, CTHs, Config, Res, 1); -do_test(Tag, SWC, CTHs, Config, Res) -> - do_test(Tag, SWC, CTHs, Config, Res, 2). +do_test(Tag, WTT, CTHs, Config) -> + do_test(Tag, WTT, CTHs, Config, ok). +do_test(Tag, WTT, CTHs, Config, {error,_} = Res) -> + do_test(Tag, WTT, CTHs, Config, Res, 1,[]); +do_test(Tag, WTT, CTHs, Config, Res) -> + do_test(Tag, WTT, CTHs, Config, Res, 2,[]). -do_test(Tag, SuiteWildCard, CTHs, Config, Res, EC) -> +do_test(Tag, WhatToTest, CTHs, Config, Res, EC, ExtraOpts) when is_list(WhatToTest) -> + do_test(Tag, {suite,WhatToTest}, CTHs, Config, Res, EC, ExtraOpts); +do_test(Tag, {WhatTag,Wildcard}, CTHs, Config, Res, EC, ExtraOpts) -> DataDir = ?config(data_dir, Config), - Suites = filelib:wildcard( - filename:join([DataDir,"cth/tests",SuiteWildCard])), - {Opts,ERPid} = setup([{suite,Suites}, - {ct_hooks,CTHs},{label,Tag}], Config), + Files = filelib:wildcard( + filename:join([DataDir,"cth/tests",Wildcard])), + {Opts,ERPid} = + setup([{WhatTag,Files},{ct_hooks,CTHs},{label,Tag}|ExtraOpts], Config), Res = ct_test_support:run(Opts, Config), Events = ct_test_support:get_events(ERPid, Config), @@ -323,10 +369,10 @@ test_events(one_empty_cth) -> {?eh,tc_done,{ct_cth_empty_SUITE,init_per_suite,ok}}, {?eh,tc_start,{ct_cth_empty_SUITE,test_case}}, - {?eh,cth,{empty_cth,pre_init_per_testcase,[test_case,'$proplist',[]]}}, - {?eh,cth,{empty_cth,post_init_per_testcase,[test_case,'$proplist','_',[]]}}, - {?eh,cth,{empty_cth,pre_end_per_testcase,[test_case,'$proplist',[]]}}, - {?eh,cth,{empty_cth,post_end_per_testcase,[test_case,'$proplist','_',[]]}}, + {?eh,cth,{empty_cth,pre_init_per_testcase,[ct_cth_empty_SUITE,test_case,'$proplist',[]]}}, + {?eh,cth,{empty_cth,post_init_per_testcase,[ct_cth_empty_SUITE,test_case,'$proplist','_',[]]}}, + {?eh,cth,{empty_cth,pre_end_per_testcase,[ct_cth_empty_SUITE,test_case,'$proplist',[]]}}, + {?eh,cth,{empty_cth,post_end_per_testcase,[ct_cth_empty_SUITE,test_case,'$proplist','_',[]]}}, {?eh,tc_done,{ct_cth_empty_SUITE,test_case,ok}}, {?eh,tc_start,{ct_cth_empty_SUITE,end_per_suite}}, @@ -355,10 +401,10 @@ test_events(two_empty_cth) -> {?eh,tc_done,{ct_cth_empty_SUITE,init_per_suite,ok}}, {?eh,tc_start,{ct_cth_empty_SUITE,test_case}}, - {?eh,cth,{'_',pre_init_per_testcase,[test_case,'$proplist',[]]}}, - {?eh,cth,{'_',pre_init_per_testcase,[test_case,'$proplist',[]]}}, - {?eh,cth,{'_',post_end_per_testcase,[test_case,'$proplist',ok,[]]}}, - {?eh,cth,{'_',post_end_per_testcase,[test_case,'$proplist',ok,[]]}}, + {?eh,cth,{'_',pre_init_per_testcase,[ct_cth_empty_SUITE,test_case,'$proplist',[]]}}, + {?eh,cth,{'_',pre_init_per_testcase,[ct_cth_empty_SUITE,test_case,'$proplist',[]]}}, + {?eh,cth,{'_',post_end_per_testcase,[ct_cth_empty_SUITE,test_case,'$proplist',ok,[]]}}, + {?eh,cth,{'_',post_end_per_testcase,[ct_cth_empty_SUITE,test_case,'$proplist',ok,[]]}}, {?eh,tc_done,{ct_cth_empty_SUITE,test_case,ok}}, {?eh,tc_start,{ct_cth_empty_SUITE,end_per_suite}}, @@ -423,8 +469,8 @@ test_events(minimal_and_maximal_cth) -> {?eh,tc_done,{ct_cth_empty_SUITE,init_per_suite,ok}}, {?eh,tc_start,{ct_cth_empty_SUITE,test_case}}, - {?eh,cth,{'_',pre_init_per_testcase,[test_case,'$proplist',[]]}}, - {?eh,cth,{'_',post_end_per_testcase,[test_case,'$proplist',ok,[]]}}, + {?eh,cth,{'_',pre_init_per_testcase,[ct_cth_empty_SUITE,test_case,'$proplist',[]]}}, + {?eh,cth,{'_',post_end_per_testcase,[ct_cth_empty_SUITE,test_case,'$proplist',ok,[]]}}, {?eh,tc_done,{ct_cth_empty_SUITE,test_case,ok}}, {?eh,tc_start,{ct_cth_empty_SUITE,end_per_suite}}, @@ -512,8 +558,8 @@ test_events(scope_per_suite_cth) -> {?eh,tc_done,{ct_scope_per_suite_cth_SUITE,init_per_suite,ok}}, {?eh,tc_start,{ct_scope_per_suite_cth_SUITE,test_case}}, - {?eh,cth,{'_',pre_init_per_testcase,[test_case,'$proplist',[]]}}, - {?eh,cth,{'_',post_end_per_testcase,[test_case,'$proplist',ok,[]]}}, + {?eh,cth,{'_',pre_init_per_testcase,[ct_scope_per_suite_cth_SUITE,test_case,'$proplist',[]]}}, + {?eh,cth,{'_',post_end_per_testcase,[ct_scope_per_suite_cth_SUITE,test_case,'$proplist',ok,[]]}}, {?eh,tc_done,{ct_scope_per_suite_cth_SUITE,test_case,ok}}, {?eh,tc_start,{ct_scope_per_suite_cth_SUITE,end_per_suite}}, @@ -538,8 +584,8 @@ test_events(scope_suite_cth) -> {?eh,tc_done,{ct_scope_suite_cth_SUITE,init_per_suite,ok}}, {?eh,tc_start,{ct_scope_suite_cth_SUITE,test_case}}, - {?eh,cth,{'_',pre_init_per_testcase,[test_case,'$proplist',[]]}}, - {?eh,cth,{'_',post_end_per_testcase,[test_case,'$proplist',ok,[]]}}, + {?eh,cth,{'_',pre_init_per_testcase,[ct_scope_suite_cth_SUITE,test_case,'$proplist',[]]}}, + {?eh,cth,{'_',post_end_per_testcase,[ct_scope_suite_cth_SUITE,test_case,'$proplist',ok,[]]}}, {?eh,tc_done,{ct_scope_suite_cth_SUITE,test_case,ok}}, {?eh,tc_start,{ct_scope_suite_cth_SUITE,end_per_suite}}, @@ -561,17 +607,17 @@ test_events(scope_per_group_cth) -> [{?eh,tc_start,{ct_scope_per_group_cth_SUITE,{init_per_group,group1,[]}}}, {?eh,cth,{'_',id,[[]]}}, {?eh,cth,{'_',init,['_',[]]}}, - {?eh,cth,{'_',post_init_per_group,[group1,'$proplist','$proplist',[]]}}, + {?eh,cth,{'_',post_init_per_group,[ct_scope_per_group_cth_SUITE,group1, '$proplist','$proplist',[]]}}, {?eh,tc_done,{ct_scope_per_group_cth_SUITE,{init_per_group,group1,[]},ok}}, {?eh,tc_start,{ct_scope_per_group_cth_SUITE,test_case}}, - {?eh,cth,{'_',pre_init_per_testcase,[test_case,'$proplist',[]]}}, - {?eh,cth,{'_',post_end_per_testcase,[test_case,'$proplist',ok,[]]}}, + {?eh,cth,{'_',pre_init_per_testcase,[ct_scope_per_group_cth_SUITE,test_case,'$proplist',[]]}}, + {?eh,cth,{'_',post_end_per_testcase,[ct_scope_per_group_cth_SUITE,test_case,'$proplist',ok,[]]}}, {?eh,tc_done,{ct_scope_per_group_cth_SUITE,test_case,ok}}, {?eh,tc_start,{ct_scope_per_group_cth_SUITE,{end_per_group,group1,[]}}}, - {?eh,cth,{'_',pre_end_per_group,[group1,'$proplist',[]]}}, - {?eh,cth,{'_',post_end_per_group,[group1,'$proplist','_',[]]}}, + {?eh,cth,{'_',pre_end_per_group,[ct_scope_per_group_cth_SUITE,group1,'$proplist',[]]}}, + {?eh,cth,{'_',post_end_per_group,[ct_scope_per_group_cth_SUITE,group1,'$proplist','_',[]]}}, {?eh,cth,{'_',terminate,[[]]}}, {?eh,tc_done,{ct_scope_per_group_cth_SUITE,{end_per_group,group1,[]},ok}}], @@ -592,8 +638,8 @@ test_events(scope_per_suite_state_cth) -> {?eh,tc_done,{ct_scope_per_suite_state_cth_SUITE,init_per_suite,ok}}, {?eh,tc_start,{ct_scope_per_suite_state_cth_SUITE,test_case}}, - {?eh,cth,{'_',pre_init_per_testcase,[test_case,'$proplist',[test]]}}, - {?eh,cth,{'_',post_end_per_testcase,[test_case,'$proplist',ok,[test]]}}, + {?eh,cth,{'_',pre_init_per_testcase,[ct_scope_per_suite_state_cth_SUITE,test_case,'$proplist',[test]]}}, + {?eh,cth,{'_',post_end_per_testcase,[ct_scope_per_suite_state_cth_SUITE,test_case,'$proplist',ok,[test]]}}, {?eh,tc_done,{ct_scope_per_suite_state_cth_SUITE,test_case,ok}}, {?eh,tc_start,{ct_scope_per_suite_state_cth_SUITE,end_per_suite}}, @@ -618,8 +664,8 @@ test_events(scope_suite_state_cth) -> {?eh,tc_done,{ct_scope_suite_state_cth_SUITE,init_per_suite,ok}}, {?eh,tc_start,{ct_scope_suite_state_cth_SUITE,test_case}}, - {?eh,cth,{'_',pre_init_per_testcase,[test_case,'$proplist',[test]]}}, - {?eh,cth,{'_',post_end_per_testcase,[test_case,'$proplist',ok,[test]]}}, + {?eh,cth,{'_',pre_init_per_testcase,[ct_scope_suite_state_cth_SUITE,test_case,'$proplist',[test]]}}, + {?eh,cth,{'_',post_end_per_testcase,[ct_scope_suite_state_cth_SUITE,test_case,'$proplist',ok,[test]]}}, {?eh,tc_done,{ct_scope_suite_state_cth_SUITE,test_case,ok}}, {?eh,tc_start,{ct_scope_suite_state_cth_SUITE,end_per_suite}}, @@ -641,17 +687,17 @@ test_events(scope_per_group_state_cth) -> [{?eh,tc_start,{ct_scope_per_group_state_cth_SUITE,{init_per_group,group1,[]}}}, {?eh,cth,{'_',id,[[test]]}}, {?eh,cth,{'_',init,['_',[test]]}}, - {?eh,cth,{'_',post_init_per_group,[group1,'$proplist','$proplist',[test]]}}, + {?eh,cth,{'_',post_init_per_group,[ct_scope_per_group_state_cth_SUITE,group1,'$proplist','$proplist',[test]]}}, {?eh,tc_done,{ct_scope_per_group_state_cth_SUITE,{init_per_group,group1,[]},ok}}, {?eh,tc_start,{ct_scope_per_group_state_cth_SUITE,test_case}}, - {?eh,cth,{'_',pre_init_per_testcase,[test_case,'$proplist',[test]]}}, - {?eh,cth,{'_',post_end_per_testcase,[test_case,'$proplist',ok,[test]]}}, + {?eh,cth,{'_',pre_init_per_testcase,[ct_scope_per_group_state_cth_SUITE,test_case,'$proplist',[test]]}}, + {?eh,cth,{'_',post_end_per_testcase,[ct_scope_per_group_state_cth_SUITE,test_case,'$proplist',ok,[test]]}}, {?eh,tc_done,{ct_scope_per_group_state_cth_SUITE,test_case,ok}}, {?eh,tc_start,{ct_scope_per_group_state_cth_SUITE,{end_per_group,group1,[]}}}, - {?eh,cth,{'_',pre_end_per_group,[group1,'$proplist',[test]]}}, - {?eh,cth,{'_',post_end_per_group,[group1,'$proplist','_',[test]]}}, + {?eh,cth,{'_',pre_end_per_group,[ct_scope_per_group_state_cth_SUITE,group1,'$proplist',[test]]}}, + {?eh,cth,{'_',post_end_per_group,[ct_scope_per_group_state_cth_SUITE,group1,'$proplist','_',[test]]}}, {?eh,cth,{'_',terminate,[[test]]}}, {?eh,tc_done,{ct_scope_per_group_state_cth_SUITE,{end_per_group,group1,[]},ok}}], @@ -674,14 +720,14 @@ test_events(fail_pre_suite_cth) -> {?eh,tc_done,{ct_cth_empty_SUITE,init_per_suite, {failed, {error,"Test failure"}}}}, {?eh,cth,{'_',on_tc_fail, - [init_per_suite,{failed,"Test failure"},[]]}}, + [ct_cth_empty_SUITE,init_per_suite,"Test failure",[]]}}, {?eh,tc_auto_skip,{ct_cth_empty_SUITE,test_case, {failed,{ct_cth_empty_SUITE,init_per_suite, {failed,"Test failure"}}}}}, {?eh,cth,{'_',on_tc_skip, - [test_case, {tc_auto_skip, + [ct_cth_empty_SUITE,test_case, {tc_auto_skip, {failed, {ct_cth_empty_SUITE, init_per_suite, {failed, "Test failure"}}}},[]]}}, @@ -690,7 +736,7 @@ test_events(fail_pre_suite_cth) -> {failed, {ct_cth_empty_SUITE, init_per_suite, {failed, "Test failure"}}}}}, {?eh,cth,{'_',on_tc_skip, - [end_per_suite, {tc_auto_skip, + [ct_cth_empty_SUITE,end_per_suite, {tc_auto_skip, {failed, {ct_cth_empty_SUITE, init_per_suite, {failed, "Test failure"}}}},[]]}}, @@ -727,17 +773,17 @@ test_events(fail_post_suite_cth) -> {?eh,cth,{'_',post_init_per_suite,[ct_cth_empty_SUITE,'$proplist','$proplist',[]]}}, {?eh,tc_done,{ct_cth_empty_SUITE,init_per_suite, {failed,{error,"Test failure"}}}}, - {?eh,cth,{'_',on_tc_fail,[init_per_suite, {failed,"Test failure"}, []]}}, + {?eh,cth,{'_',on_tc_fail,[ct_cth_empty_SUITE,init_per_suite, "Test failure", []]}}, {?eh,tc_auto_skip,{ct_cth_empty_SUITE,test_case, {failed,{ct_cth_empty_SUITE,init_per_suite, {failed,"Test failure"}}}}}, - {?eh,cth,{'_',on_tc_skip,[test_case,{tc_auto_skip,'_'},[]]}}, + {?eh,cth,{'_',on_tc_skip,[ct_cth_empty_SUITE,test_case,{tc_auto_skip,'_'},[]]}}, {?eh,tc_auto_skip, {ct_cth_empty_SUITE, end_per_suite, {failed, {ct_cth_empty_SUITE, init_per_suite, {failed, "Test failure"}}}}}, - {?eh,cth,{'_',on_tc_skip,[end_per_suite,{tc_auto_skip,'_'},[]]}}, + {?eh,cth,{'_',on_tc_skip,[ct_cth_empty_SUITE,end_per_suite,{tc_auto_skip,'_'},[]]}}, {?eh,test_done,{'DEF','STOP_TIME'}}, {?eh,cth, {'_',terminate,[[]]}}, @@ -754,10 +800,10 @@ test_events(skip_pre_suite_cth) -> {?eh,cth,{'_',post_init_per_suite,[ct_cth_empty_SUITE,'$proplist',{skip,"Test skip"},[]]}}, {?eh,tc_done,{ct_cth_empty_SUITE,init_per_suite,{skipped,"Test skip"}}}, {?eh,cth,{'_',on_tc_skip, - [init_per_suite,{tc_user_skip,{skipped,"Test skip"}},[]]}}, + [ct_cth_empty_SUITE,init_per_suite,{tc_user_skip,"Test skip"},[]]}}, {?eh,tc_user_skip,{ct_cth_empty_SUITE,test_case,"Test skip"}}, - {?eh,cth,{'_',on_tc_skip,[test_case,{tc_user_skip,"Test skip"},[]]}}, + {?eh,cth,{'_',on_tc_skip,[ct_cth_empty_SUITE,test_case,{tc_user_skip,"Test skip"},[]]}}, {?eh,tc_user_skip, {ct_cth_empty_SUITE, end_per_suite,"Test skip"}}, @@ -776,27 +822,29 @@ test_events(skip_pre_end_cth) -> [{?eh,tc_start,{ct_scope_per_group_cth_SUITE,{init_per_group,group1,[]}}}, {?eh,cth,{'_',id,[[]]}}, {?eh,cth,{'_',init,['_',[]]}}, - {?eh,cth,{'_',post_init_per_group,[group1,'$proplist','$proplist',[]]}}, + {?eh,cth,{'_',post_init_per_group,[ct_scope_per_group_cth_SUITE,group1,'$proplist','$proplist',[]]}}, {?eh,tc_done,{ct_scope_per_group_cth_SUITE,{init_per_group,group1,[]},ok}}, {?eh,tc_start,{ct_scope_per_group_cth_SUITE,test_case}}, - {?eh,cth,{'_',pre_init_per_testcase,[test_case,'$proplist',[]]}}, - {?eh,cth,{'_',post_end_per_testcase,[test_case,'$proplist',ok,[]]}}, + {?eh,cth,{'_',pre_init_per_testcase,[ct_scope_per_group_cth_SUITE,test_case,'$proplist',[]]}}, + {?eh,cth,{'_',post_end_per_testcase,[ct_scope_per_group_cth_SUITE,test_case,'$proplist',ok,[]]}}, {?eh,tc_done,{ct_scope_per_group_cth_SUITE,test_case,ok}}, {?eh,tc_start,{ct_scope_per_group_cth_SUITE,{end_per_group,group1,[]}}}, - {?eh,cth,{'_',pre_end_per_group,[group1,'$proplist',[]]}}, - {?eh,cth,{'_',post_end_per_group,[group1,'$proplist','_',[]]}}, + {?eh,cth,{'_',pre_end_per_group,[ct_scope_per_group_cth_SUITE,group1,'$proplist',[]]}}, + {?eh,cth,{'_',post_end_per_group,[ct_scope_per_group_cth_SUITE,group1,'$proplist','_',[]]}}, {?eh,tc_done,{ct_scope_per_group_cth_SUITE,{end_per_group,group1,[]}, {skipped,"Test skip"}}}], - {?eh,cth,{'_',on_tc_skip,[{end_per_group,group1}, - {tc_user_skip,{skipped,"Test skip"}}, + {?eh,cth,{'_',on_tc_skip,[ct_scope_per_group_cth_SUITE, + {end_per_group,group1}, + {tc_user_skip,"Test skip"}, []]}}, {?eh,tc_start,{ct_scope_per_group_cth_SUITE,end_per_suite}}, {?eh,tc_done,{ct_scope_per_group_cth_SUITE,end_per_suite, {skipped,"Test skip"}}}, - {?eh,cth,{'_',on_tc_skip,[end_per_suite, - {tc_user_skip,{skipped,"Test skip"}}, + {?eh,cth,{'_',on_tc_skip,[ct_scope_per_group_cth_SUITE, + end_per_suite, + {tc_user_skip,"Test skip"}, []]}}, {?eh,test_done,{'DEF','STOP_TIME'}}, {?eh,cth,{'_',terminate,[[]]}}, @@ -814,10 +862,10 @@ test_events(skip_post_suite_cth) -> {?eh,cth,{'_',post_init_per_suite,[ct_cth_empty_SUITE,'$proplist','$proplist',[]]}}, {?eh,tc_done,{ct_cth_empty_SUITE,init_per_suite,{skipped,"Test skip"}}}, {?eh,cth,{'_',on_tc_skip, - [init_per_suite,{tc_user_skip,{skipped,"Test skip"}},[]]}}, + [ct_cth_empty_SUITE,init_per_suite,{tc_user_skip,"Test skip"},[]]}}, {?eh,tc_user_skip,{ct_cth_empty_SUITE,test_case,"Test skip"}}, - {?eh,cth,{'_',on_tc_skip,[test_case,{tc_user_skip,"Test skip"},[]]}}, + {?eh,cth,{'_',on_tc_skip,[ct_cth_empty_SUITE,test_case,{tc_user_skip,"Test skip"},[]]}}, {?eh,tc_user_skip, {ct_cth_empty_SUITE, end_per_suite,"Test skip"}}, @@ -826,6 +874,41 @@ test_events(skip_post_suite_cth) -> {?eh,stop_logging,[]} ]; +test_events(skip_pre_init_tc_cth) -> + [ + {?eh,start_logging,{'DEF','RUNDIR'}}, + {?eh,test_start,{'DEF',{'START_TIME','LOGDIR'}}}, + {?eh,cth,{empty_cth,init,['_',[]]}}, + {?eh,start_info,{1,1,1}}, + {?eh,tc_start,{ct_cth_empty_SUITE,init_per_suite}}, + {?eh,cth,{empty_cth,pre_init_per_suite,[ct_cth_empty_SUITE,'$proplist',[]]}}, + {?eh,cth,{empty_cth,post_init_per_suite, + [ct_cth_empty_SUITE,'$proplist','$proplist',[]]}}, + {?eh,tc_done,{ct_cth_empty_SUITE,init_per_suite,ok}}, + {?eh,tc_start,{ct_cth_empty_SUITE,test_case}}, + {?eh,cth,{empty_cth,pre_init_per_testcase, + [ct_cth_empty_SUITE,test_case,'$proplist',[]]}}, + {?eh,cth,{empty_cth,post_init_per_testcase, + [ct_cth_empty_SUITE,test_case,'$proplist', + {skip,"Skipped in pre_init_per_testcase"}, + []]}}, + {?eh,tc_done,{ct_cth_empty_SUITE,test_case, + {skipped,"Skipped in pre_init_per_testcase"}}}, + {?eh,cth,{empty_cth,on_tc_skip, + [ct_cth_empty_SUITE,test_case, + {tc_user_skip,"Skipped in pre_init_per_testcase"}, + []]}}, + {?eh,test_stats,{0,0,{1,0}}}, + {?eh,tc_start,{ct_cth_empty_SUITE,end_per_suite}}, + {?eh,cth,{empty_cth,pre_end_per_suite,[ct_cth_empty_SUITE,'$proplist',[]]}}, + {?eh,cth,{empty_cth,post_end_per_suite, + [ct_cth_empty_SUITE,'$proplist',ok,[]]}}, + {?eh,tc_done,{ct_cth_empty_SUITE,end_per_suite,ok}}, + {?eh,test_done,{'DEF','STOP_TIME'}}, + {?eh,cth,{empty_cth,terminate,[[]]}}, + {?eh,stop_logging,[]} + ]; + test_events(recover_post_suite_cth) -> Suite = ct_cth_fail_per_suite_SUITE, [ @@ -840,9 +923,9 @@ test_events(recover_post_suite_cth) -> {?eh,tc_start,{Suite,test_case}}, {?eh,cth,{'_',pre_init_per_testcase, - [test_case, not_contains([tc_status]),[]]}}, + [Suite,test_case, not_contains([tc_status]),[]]}}, {?eh,cth,{'_',post_end_per_testcase, - [test_case, contains([tc_status]),'_',[]]}}, + [Suite,test_case, contains([tc_status]),'_',[]]}}, {?eh,tc_done,{Suite,test_case,ok}}, {?eh,tc_start,{Suite,end_per_suite}}, @@ -876,13 +959,15 @@ test_events(update_config_cth) -> {?eh,tc_start,{ct_update_config_SUITE, {init_per_group,group1,[]}}}, {?eh,cth,{'_',pre_init_per_group, - [group1,contains( + [ct_update_config_SUITE, + group1,contains( [post_init_per_suite, init_per_suite, pre_init_per_suite]), []]}}, {?eh,cth,{'_',post_init_per_group, - [group1, + [ct_update_config_SUITE, + group1, contains( [post_init_per_suite, init_per_suite, @@ -898,7 +983,8 @@ test_events(update_config_cth) -> {?eh,tc_start,{ct_update_config_SUITE,test_case}}, {?eh,cth,{'_',pre_init_per_testcase, - [test_case,contains( + [ct_update_config_SUITE, + test_case,contains( [post_init_per_group, init_per_group, pre_init_per_group, @@ -907,7 +993,8 @@ test_events(update_config_cth) -> pre_init_per_suite]), []]}}, {?eh,cth,{'_',post_end_per_testcase, - [test_case,contains( + [ct_update_config_SUITE, + test_case,contains( [init_per_testcase, pre_init_per_testcase, post_init_per_group, @@ -921,7 +1008,8 @@ test_events(update_config_cth) -> {?eh,tc_start,{ct_update_config_SUITE, {end_per_group,group1,[]}}}, {?eh,cth,{'_',pre_end_per_group, - [group1,contains( + [ct_update_config_SUITE, + group1,contains( [post_init_per_group, init_per_group, pre_init_per_group, @@ -930,7 +1018,8 @@ test_events(update_config_cth) -> pre_init_per_suite]), []]}}, {?eh,cth,{'_',post_end_per_group, - [group1, + [ct_update_config_SUITE, + group1, contains( [pre_end_per_group, post_init_per_group, @@ -1018,8 +1107,8 @@ test_events(options_cth) -> {?eh,tc_done,{ct_cth_empty_SUITE,init_per_suite,ok}}, {?eh,tc_start,{ct_cth_empty_SUITE,test_case}}, - {?eh,cth,{empty_cth,pre_init_per_testcase,[test_case,'$proplist',[test]]}}, - {?eh,cth,{empty_cth,post_end_per_testcase,[test_case,'$proplist','_',[test]]}}, + {?eh,cth,{empty_cth,pre_init_per_testcase,[ct_cth_empty_SUITE,test_case,'$proplist',[test]]}}, + {?eh,cth,{empty_cth,post_end_per_testcase,[ct_cth_empty_SUITE,test_case,'$proplist','_',[test]]}}, {?eh,tc_done,{ct_cth_empty_SUITE,test_case,ok}}, {?eh,tc_start,{ct_cth_empty_SUITE,end_per_suite}}, @@ -1051,12 +1140,12 @@ test_events(same_id_cth) -> {?eh,tc_done,{ct_cth_empty_SUITE,init_per_suite,ok}}}, {?eh,tc_start,{ct_cth_empty_SUITE,test_case}}, - {?eh,cth,{'_',pre_init_per_testcase,[test_case,'$proplist',[]]}}, + {?eh,cth,{'_',pre_init_per_testcase,[ct_cth_empty_SUITE,test_case,'$proplist',[]]}}, {negative, - {?eh,cth,{'_',pre_init_per_testcase,[test_case,'$proplist',[]]}}, - {?eh,cth,{'_',post_end_per_testcase,[test_case,'$proplist',ok,[]]}}}, + {?eh,cth,{'_',pre_init_per_testcase,[ct_cth_empty_SUITE,test_case,'$proplist',[]]}}, + {?eh,cth,{'_',post_end_per_testcase,[ct_cth_empty_SUITE,test_case,'$proplist',ok,[]]}}}, {negative, - {?eh,cth,{'_',post_end_per_testcase,[test_case,'$proplist',ok,[]]}}, + {?eh,cth,{'_',post_end_per_testcase,[ct_cth_empty_SUITE,test_case,'$proplist',ok,[]]}}, {?eh,tc_done,{ct_cth_empty_SUITE,test_case,ok}}}, {?eh,tc_start,{ct_cth_empty_SUITE,end_per_suite}}, @@ -1094,11 +1183,13 @@ test_events(fail_n_skip_with_minimal_cth) -> {?eh,tc_done,{ct_cth_fail_one_skip_one_SUITE,test_case2,{skipped,"skip it"}}}, {?eh,tc_start,{ct_cth_fail_one_skip_one_SUITE,test_case3}}, {?eh,tc_done,{ct_cth_fail_one_skip_one_SUITE,test_case3,{skipped,"skip it"}}}, - {?eh,cth,{empty_cth,on_tc_skip,[{test_case2,group2}, - {tc_user_skip,{skipped,"skip it"}}, + {?eh,cth,{empty_cth,on_tc_skip,[ct_cth_fail_one_skip_one_SUITE, + {test_case2,group2}, + {tc_user_skip,"skip it"}, []]}}, - {?eh,cth,{empty_cth,on_tc_skip,[{test_case3,group2}, - {tc_user_skip,{skipped,"skip it"}}, + {?eh,cth,{empty_cth,on_tc_skip,[ct_cth_fail_one_skip_one_SUITE, + {test_case3,group2}, + {tc_user_skip,"skip it"}, []]}}, {?eh,tc_start,{ct_cth_fail_one_skip_one_SUITE,{end_per_group, group2,[parallel]}}}, @@ -1115,13 +1206,24 @@ test_events(fail_n_skip_with_minimal_cth) -> ]; test_events(prio_cth) -> - GenPre = fun(Func,States) -> - [{?eh,cth,{'_',Func,['_','_',State]}} || State <- States] + GenPre = fun(Func,States) when Func==pre_init_per_suite; + Func==pre_end_per_suite -> + [{?eh,cth,{'_',Func,['_','_',State]}} || + State <- States]; + (Func,States) -> + [{?eh,cth,{'_',Func,['_','_','_',State]}} || + State <- States] end, - GenPost = fun(Func,States) -> - [{?eh,cth,{'_',Func,['_','_','_',State]}} || State <- States] - end, + GenPost = fun(Func,States) when Func==post_init_per_suite; + Func==post_end_per_suite -> + [{?eh,cth,{'_',Func,['_','_','_',State]}} || + State <- States]; + (Func,States) -> + [{?eh,cth,{'_',Func,['_','_','_','_',State]}} || + State <- States] + + end, [{?eh,start_logging,{'DEF','RUNDIR'}}, {?eh,test_start,{'DEF',{'START_TIME','LOGDIR'}}}] ++ @@ -1197,30 +1299,30 @@ test_events(no_config) -> {?eh,tc_done,{ct_framework,init_per_suite,ok}}, {?eh,tc_start,{ct_no_config_SUITE,test_case_1}}, {?eh,cth,{empty_cth,pre_init_per_testcase, - [test_case_1,'$proplist',[]]}}, + [ct_no_config_SUITE,test_case_1,'$proplist',[]]}}, {?eh,cth,{empty_cth,post_end_per_testcase, - [test_case_1,'$proplist',ok,[]]}}, + [ct_no_config_SUITE,test_case_1,'$proplist',ok,[]]}}, {?eh,tc_done,{ct_no_config_SUITE,test_case_1,ok}}, {?eh,test_stats,{1,0,{0,0}}}, [{?eh,tc_start,{ct_framework,{init_per_group,test_group,'$proplist'}}}, {?eh,cth,{empty_cth,pre_init_per_group, - [test_group,'$proplist',[]]}}, + [ct_no_config_SUITE,test_group,'$proplist',[]]}}, {?eh,cth,{empty_cth,post_init_per_group, - [test_group,'$proplist','$proplist',[]]}}, + [ct_no_config_SUITE,test_group,'$proplist','$proplist',[]]}}, {?eh,tc_done,{ct_framework, {init_per_group,test_group,'$proplist'},ok}}, {?eh,tc_start,{ct_no_config_SUITE,test_case_2}}, {?eh,cth,{empty_cth,pre_init_per_testcase, - [test_case_2,'$proplist',[]]}}, + [ct_no_config_SUITE,test_case_2,'$proplist',[]]}}, {?eh,cth,{empty_cth,post_end_per_testcase, - [test_case_2,'$proplist',ok,[]]}}, + [ct_no_config_SUITE,test_case_2,'$proplist',ok,[]]}}, {?eh,tc_done,{ct_no_config_SUITE,test_case_2,ok}}, {?eh,test_stats,{2,0,{0,0}}}, {?eh,tc_start,{ct_framework,{end_per_group,test_group,'$proplist'}}}, {?eh,cth,{empty_cth,pre_end_per_group, - [test_group,'$proplist',[]]}}, + [ct_no_config_SUITE,test_group,'$proplist',[]]}}, {?eh,cth,{empty_cth,post_end_per_group, - [test_group,'$proplist',ok,[]]}}, + [ct_no_config_SUITE,test_group,'$proplist',ok,[]]}}, {?eh,tc_done,{ct_framework,{end_per_group,test_group,'$proplist'},ok}}], {?eh,tc_start,{ct_framework,end_per_suite}}, {?eh,cth,{empty_cth,pre_end_per_suite, @@ -1233,6 +1335,166 @@ test_events(no_config) -> {?eh,stop_logging,[]} ]; +test_events(no_init_suite_config) -> + [ + {?eh,start_logging,{'DEF','RUNDIR'}}, + {?eh,test_start,{'DEF',{'START_TIME','LOGDIR'}}}, + {?eh,cth,{empty_cth,init,[{'_','_','_'},[]]}}, + {?eh,start_info,{1,1,1}}, + {?eh,tc_start,{ct_no_init_suite_config_SUITE,init_per_suite}}, + {?eh,cth,{empty_cth,pre_init_per_suite, + [ct_no_init_suite_config_SUITE,'$proplist',[]]}}, + {?eh,cth,{empty_cth,post_init_per_suite, + [ct_no_init_suite_config_SUITE,'$proplist','_',[]]}}, + {?eh,tc_done,{ct_no_init_suite_config_SUITE,init_per_suite, + {failed,{error,{undef,'_'}}}}}, + {?eh,cth,{empty_cth,on_tc_fail,[ct_no_init_suite_config_SUITE, + init_per_suite, + {undef,'_'},[]]}}, + {?eh,tc_auto_skip,{ct_no_init_suite_config_SUITE,test_case, + {failed,{ct_no_init_suite_config_SUITE,init_per_suite, + {'EXIT',{undef,'_'}}}}}}, + {?eh,cth,{empty_cth,on_tc_skip, + [ct_no_init_suite_config_SUITE, + test_case, + {tc_auto_skip, + {failed,{ct_no_init_suite_config_SUITE,init_per_suite, + {'EXIT',{undef,'_'}}}}}, + []]}}, + {?eh,test_stats,{0,0,{0,1}}}, + {?eh,tc_auto_skip,{ct_no_init_suite_config_SUITE,end_per_suite, + {failed,{ct_no_init_suite_config_SUITE,init_per_suite, + {'EXIT',{undef,'_'}}}}}}, + {?eh,cth,{empty_cth,on_tc_skip, + [ct_no_init_suite_config_SUITE, + end_per_suite, + {tc_auto_skip, + {failed,{ct_no_init_suite_config_SUITE,init_per_suite, + {'EXIT',{undef,'_'}}}}}, + []]}}, + {?eh,test_done,{'DEF','STOP_TIME'}}, + {?eh,cth,{empty_cth,terminate,[[]]}}, + {?eh,stop_logging,[]} + ]; + +test_events(no_init_config) -> + [ + {?eh,start_logging,{'DEF','RUNDIR'}}, + {?eh,test_start,{'DEF',{'START_TIME','LOGDIR'}}}, + {?eh,cth,{empty_cth,init,[{'_','_','_'},[]]}}, + {?eh,start_info,{1,1,2}}, + {?eh,tc_start,{ct_no_init_config_SUITE,init_per_suite}}, + {?eh,cth,{empty_cth,pre_init_per_suite, + [ct_no_init_config_SUITE,'$proplist',[]]}}, + {?eh,cth,{empty_cth,post_init_per_suite, + [ct_no_init_config_SUITE,'$proplist','$proplist',[]]}}, + {?eh,tc_done,{ct_no_init_config_SUITE,init_per_suite,ok}}, + {?eh,tc_start,{ct_no_init_config_SUITE,test_case_1}}, + {?eh,cth,{empty_cth,pre_init_per_testcase, + [ct_no_init_config_SUITE,test_case_1,'$proplist',[]]}}, + {?eh,cth,{empty_cth,post_end_per_testcase, + [ct_no_init_config_SUITE,test_case_1,'$proplist',ok,[]]}}, + {?eh,tc_done,{ct_no_init_config_SUITE,test_case_1,ok}}, + {?eh,test_stats,{1,0,{0,0}}}, + [{?eh,tc_start,{ct_no_init_config_SUITE,{init_per_group,test_group,[]}}}, + {?eh,cth,{empty_cth,pre_init_per_group, + [ct_no_init_config_SUITE,test_group,'$proplist',[]]}}, + {?eh,cth,{empty_cth,post_init_per_group, + [ct_no_init_config_SUITE,test_group,'$proplist','_',[]]}}, + {?eh,tc_done,{ct_no_init_config_SUITE,{init_per_group,test_group,[]}, + {failed,{error,{undef,'_'}}}}}, + {?eh,cth,{empty_cth,on_tc_fail,[ct_no_init_config_SUITE, + {init_per_group,test_group}, + {undef,'_'},[]]}}, + {?eh,tc_auto_skip,{ct_no_init_config_SUITE,{test_case_2,test_group}, + {failed,{ct_no_init_config_SUITE,init_per_group, + {'EXIT',{undef,'_'}}}}}}, + {?eh,cth,{empty_cth,on_tc_skip,[ct_no_init_config_SUITE, + {test_case_2,test_group}, + {tc_auto_skip, + {failed, + {ct_no_init_config_SUITE,init_per_group, + {'EXIT',{undef,'_'}}}}}, + []]}}, + {?eh,test_stats,{1,0,{0,1}}}, + {?eh,tc_auto_skip,{ct_no_init_config_SUITE,{end_per_group,test_group}, + {failed,{ct_no_init_config_SUITE,init_per_group, + {'EXIT',{undef,'_'}}}}}}, + {?eh,cth,{empty_cth,on_tc_skip,[ct_no_init_config_SUITE, + {end_per_group,test_group}, + {tc_auto_skip, + {failed, + {ct_no_init_config_SUITE,init_per_group, + {'EXIT',{undef,'_'}}}}}, + []]}}], + {?eh,tc_start,{ct_no_init_config_SUITE,end_per_suite}}, + {?eh,cth,{empty_cth,pre_end_per_suite, + [ct_no_init_config_SUITE,'$proplist',[]]}}, + {?eh,cth,{empty_cth,post_end_per_suite, + [ct_no_init_config_SUITE,'$proplist',ok,[]]}}, + {?eh,tc_done,{ct_no_init_config_SUITE,end_per_suite,ok}}, + {?eh,test_done,{'DEF','STOP_TIME'}}, + {?eh,cth,{empty_cth,terminate,[[]]}}, + {?eh,stop_logging,[]} + ]; + +test_events(no_end_config) -> + [ + {?eh,start_logging,{'DEF','RUNDIR'}}, + {?eh,test_start,{'DEF',{'START_TIME','LOGDIR'}}}, + {?eh,cth,{empty_cth,init,[{'_','_','_'},[]]}}, + {?eh,start_info,{1,1,2}}, + {?eh,tc_start,{ct_no_end_config_SUITE,init_per_suite}}, + {?eh,cth,{empty_cth,pre_init_per_suite, + [ct_no_end_config_SUITE,'$proplist',[]]}}, + {?eh,cth,{empty_cth,post_init_per_suite, + [ct_no_end_config_SUITE,'$proplist','$proplist',[]]}}, + {?eh,tc_done,{ct_no_end_config_SUITE,init_per_suite,ok}}, + {?eh,tc_start,{ct_no_end_config_SUITE,test_case_1}}, + {?eh,cth,{empty_cth,pre_init_per_testcase, + [ct_no_end_config_SUITE,test_case_1,'$proplist',[]]}}, + {?eh,cth,{empty_cth,post_end_per_testcase, + [ct_no_end_config_SUITE,test_case_1,'$proplist',ok,[]]}}, + {?eh,tc_done,{ct_no_end_config_SUITE,test_case_1,ok}}, + {?eh,test_stats,{1,0,{0,0}}}, + [{?eh,tc_start,{ct_no_end_config_SUITE, + {init_per_group,test_group,'$proplist'}}}, + {?eh,cth,{empty_cth,pre_init_per_group, + [ct_no_end_config_SUITE,test_group,'$proplist',[]]}}, + {?eh,cth,{empty_cth,post_init_per_group, + [ct_no_end_config_SUITE,test_group,'$proplist','$proplist',[]]}}, + {?eh,tc_done,{ct_no_end_config_SUITE, + {init_per_group,test_group,'$proplist'},ok}}, + {?eh,tc_start,{ct_no_end_config_SUITE,test_case_2}}, + {?eh,cth,{empty_cth,pre_init_per_testcase, + [ct_no_end_config_SUITE,test_case_2,'$proplist',[]]}}, + {?eh,cth,{empty_cth,post_end_per_testcase, + [ct_no_end_config_SUITE,test_case_2,'$proplist',ok,[]]}}, + {?eh,tc_done,{ct_no_end_config_SUITE,test_case_2,ok}}, + {?eh,test_stats,{2,0,{0,0}}}, + {?eh,tc_start,{ct_no_end_config_SUITE, + {end_per_group,test_group,'$proplist'}}}, + {?eh,cth,{empty_cth,pre_end_per_group, + [ct_no_end_config_SUITE,test_group,'$proplist',[]]}}, + {?eh,cth,{empty_cth,post_end_per_group, + [ct_no_end_config_SUITE,test_group,'$proplist','_',[]]}}, + {?eh,tc_done,{ct_no_end_config_SUITE,{end_per_group,test_group,[]}, + {failed,{error,{undef,'_'}}}}}, + {?eh,cth,{empty_cth,on_tc_fail,[ct_no_end_config_SUITE, + {end_per_group,test_group}, + {undef,'_'},[]]}}], + {?eh,tc_start,{ct_no_end_config_SUITE,end_per_suite}}, + {?eh,cth,{empty_cth,pre_end_per_suite, + [ct_no_end_config_SUITE,'$proplist',[]]}}, + {?eh,cth,{empty_cth,post_end_per_suite, + [ct_no_end_config_SUITE,'$proplist','_',[]]}}, + {?eh,tc_done,{ct_no_end_config_SUITE,end_per_suite, + {failed,{error,{undef,'_'}}}}}, + {?eh,test_done,{'DEF','STOP_TIME'}}, + {?eh,cth,{empty_cth,terminate,[[]]}}, + {?eh,stop_logging,[]} + ]; + test_events(data_dir) -> [ {?eh,start_logging,{'DEF','RUNDIR'}}, @@ -1247,30 +1509,30 @@ test_events(data_dir) -> {?eh,tc_done,{ct_framework,init_per_suite,ok}}, {?eh,tc_start,{ct_data_dir_SUITE,test_case_1}}, {?eh,cth,{empty_cth,pre_init_per_testcase, - [test_case_1,'$proplist',[{data_dir_name,"ct_data_dir_SUITE_data"}]]}}, + [ct_data_dir_SUITE,test_case_1,'$proplist',[{data_dir_name,"ct_data_dir_SUITE_data"}]]}}, {?eh,cth,{empty_cth,post_end_per_testcase, - [test_case_1,'$proplist',ok,[{data_dir_name,"ct_data_dir_SUITE_data"}]]}}, + [ct_data_dir_SUITE,test_case_1,'$proplist',ok,[{data_dir_name,"ct_data_dir_SUITE_data"}]]}}, {?eh,tc_done,{ct_data_dir_SUITE,test_case_1,ok}}, {?eh,test_stats,{1,0,{0,0}}}, [{?eh,tc_start,{ct_framework,{init_per_group,test_group,'$proplist'}}}, {?eh,cth,{empty_cth,pre_init_per_group, - [test_group,'$proplist',[{data_dir_name,"ct_data_dir_SUITE_data"}]]}}, + [ct_data_dir_SUITE,test_group,'$proplist',[{data_dir_name,"ct_data_dir_SUITE_data"}]]}}, {?eh,cth,{empty_cth,post_init_per_group, - [test_group,'$proplist','$proplist',[{data_dir_name,"ct_data_dir_SUITE_data"}]]}}, + [ct_data_dir_SUITE,test_group,'$proplist','$proplist',[{data_dir_name,"ct_data_dir_SUITE_data"}]]}}, {?eh,tc_done,{ct_framework, {init_per_group,test_group,'$proplist'},ok}}, {?eh,tc_start,{ct_data_dir_SUITE,test_case_2}}, {?eh,cth,{empty_cth,pre_init_per_testcase, - [test_case_2,'$proplist',[{data_dir_name,"ct_data_dir_SUITE_data"}]]}}, + [ct_data_dir_SUITE,test_case_2,'$proplist',[{data_dir_name,"ct_data_dir_SUITE_data"}]]}}, {?eh,cth,{empty_cth,post_end_per_testcase, - [test_case_2,'$proplist',ok,[{data_dir_name,"ct_data_dir_SUITE_data"}]]}}, + [ct_data_dir_SUITE,test_case_2,'$proplist',ok,[{data_dir_name,"ct_data_dir_SUITE_data"}]]}}, {?eh,tc_done,{ct_data_dir_SUITE,test_case_2,ok}}, {?eh,test_stats,{2,0,{0,0}}}, {?eh,tc_start,{ct_framework,{end_per_group,test_group,'$proplist'}}}, {?eh,cth,{empty_cth,pre_end_per_group, - [test_group,'$proplist',[{data_dir_name,"ct_data_dir_SUITE_data"}]]}}, + [ct_data_dir_SUITE,test_group,'$proplist',[{data_dir_name,"ct_data_dir_SUITE_data"}]]}}, {?eh,cth,{empty_cth,post_end_per_group, - [test_group,'$proplist',ok,[{data_dir_name,"ct_data_dir_SUITE_data"}]]}}, + [ct_data_dir_SUITE,test_group,'$proplist',ok,[{data_dir_name,"ct_data_dir_SUITE_data"}]]}}, {?eh,tc_done,{ct_framework,{end_per_group,test_group,'$proplist'},ok}}], {?eh,tc_start,{ct_framework,end_per_suite}}, {?eh,cth,{empty_cth,pre_end_per_suite, @@ -1303,6 +1565,645 @@ test_events(cth_log) -> {?eh,stop_logging,[]} ]; +test_events(fallback) -> + [ + {?eh,start_logging,{'DEF','RUNDIR'}}, + {?eh,test_start,{'DEF',{'START_TIME','LOGDIR'}}}, + {?eh,cth,{empty_cth,id,[[]]}}, + {?eh,cth,{empty_cth,init,[{'_','_','_'},[]]}}, + {?eh,tc_start,{all_hook_callbacks_SUITE,init_per_suite}}, + {?eh,cth,{empty_cth,pre_init_per_suite, + [all_hook_callbacks_SUITE,'$proplist',[]]}}, + {?eh,cth,{empty_cth,post_init_per_suite, + [all_hook_callbacks_SUITE,'$proplist','$proplist',[]]}}, + {?eh,tc_done,{all_hook_callbacks_SUITE,init_per_suite,ok}}, + + [{?eh,tc_start,{ct_framework,{init_per_group,test_group,'$proplist'}}}, + {?eh,cth,{empty_cth,pre_init_per_group, + [fallback_nosuite,test_group,'$proplist',[]]}}, + {?eh,cth,{empty_cth,post_init_per_group, + [fallback_nosuite,test_group,'$proplist','$proplist',[]]}}, + {?eh,tc_done,{ct_framework, + {init_per_group,test_group,'$proplist'},ok}}, + {?eh,tc_start,{all_hook_callbacks_SUITE,test_case}}, + {?eh,cth,{empty_cth,pre_init_per_testcase, + [fallback_nosuite,test_case,'$proplist',[]]}}, + {?eh,cth,{empty_cth,post_end_per_testcase, + [fallback_nosuite,test_case,'$proplist',ok,[]]}}, + {?eh,tc_done,{all_hook_callbacks_SUITE,test_case,ok}}, + {?eh,test_stats,{1,0,{0,0}}}, + {?eh,tc_start,{ct_framework,{end_per_group,test_group,'$proplist'}}}, + {?eh,cth,{empty_cth,pre_end_per_group, + [fallback_nosuite,test_group,'$proplist',[]]}}, + {?eh,cth,{empty_cth,post_end_per_group, + [fallback_nosuite,test_group,'$proplist',ok,[]]}}, + {?eh,tc_done,{ct_framework,{end_per_group,test_group,'$proplist'},ok}}], + {?eh,tc_start,{all_hook_callbacks_SUITE,test_case}}, + {?eh,cth,{empty_cth,pre_init_per_testcase, + [fallback_nosuite,test_case,'$proplist',[]]}}, + {?eh,cth,{empty_cth,post_init_per_testcase, + [fallback_nosuite,test_case,'$proplist','_',[]]}}, + {?eh,cth,{empty_cth,pre_end_per_testcase, + [fallback_nosuite,test_case,'$proplist',[]]}}, + {?eh,cth,{empty_cth,post_end_per_testcase, + [fallback_nosuite,test_case,'$proplist','_',[]]}}, + {?eh,tc_done,{all_hook_callbacks_SUITE,test_case,ok}}, + {?eh,test_stats,{2,0,{0,0}}}, + {?eh,tc_start,{all_hook_callbacks_SUITE,skip_case}}, + {?eh,cth,{empty_cth,pre_init_per_testcase, + [fallback_nosuite,skip_case,'$proplist',[]]}}, + {?eh,cth,{empty_cth,post_init_per_testcase, + [fallback_nosuite,skip_case,'$proplist', + {skip,"Skipped in init_per_testcase/2"},[]]}}, + {?eh,tc_done,{all_hook_callbacks_SUITE,skip_case, + {skipped,"Skipped in init_per_testcase/2"}}}, + {?eh,cth,{empty_cth,on_tc_skip, + [fallback_nosuite,skip_case, + {tc_user_skip,"Skipped in init_per_testcase/2"}, + []]}}, + {?eh,test_stats,{2,0,{1,0}}}, + {?eh,tc_start,{all_hook_callbacks_SUITE,end_per_suite}}, + {?eh,cth,{empty_cth,pre_end_per_suite, + [all_hook_callbacks_SUITE,'$proplist',[]]}}, + {?eh,cth,{empty_cth,post_end_per_suite, + [all_hook_callbacks_SUITE,'$proplist','_',[]]}}, + {?eh,tc_done,{all_hook_callbacks_SUITE,end_per_suite,ok}}, + {?eh,test_done,{'DEF','STOP_TIME'}}, + {?eh,cth,{empty_cth,terminate,[[]]}}, + {?eh,stop_logging,[]} + ]; + +test_events(callbacks_on_skip) -> + %% skip_cth.erl will send a 'cth_error' event if a hook is + %% erroneously called. Therefore, all Events are changed to + %% {negative,{?eh,cth_error,'_'},Event} + %% at the end of this function. + Events = + [ + {?eh,start_logging,{'DEF','RUNDIR'}}, + {?eh,test_start,{'DEF',{'START_TIME','LOGDIR'}}}, + {?eh,cth,{empty_cth,id,[[]]}}, + {?eh,cth,{empty_cth,init,[{'_','_','_'},[]]}}, + {?eh,start_info,{6,6,15}}, + + %% all_hook_callbacks_SUITE is skipped in spec + %% Only the on_tc_skip callback shall be called + {?eh,tc_user_skip,{all_hook_callbacks_SUITE,all,"Skipped in spec"}}, + {?eh,cth,{empty_cth,on_tc_skip, + [all_hook_callbacks_SUITE,all, + {tc_user_skip,"Skipped in spec"}, + []]}}, + {?eh,test_stats,{0,0,{1,0}}}, + + %% skip_init_SUITE is skipped in its init_per_suite function + %% No group- or testcase-functions shall be called. + {?eh,tc_start,{skip_init_SUITE,init_per_suite}}, + {?eh,cth,{empty_cth,pre_init_per_suite, + [skip_init_SUITE, + '$proplist', + []]}}, + {?eh,cth,{empty_cth,post_init_per_suite, + [skip_init_SUITE, + '$proplist', + {skip,"Skipped in init_per_suite/1"}, + []]}}, + {?eh,tc_done,{skip_init_SUITE,init_per_suite, + {skipped,"Skipped in init_per_suite/1"}}}, + {?eh,cth,{empty_cth,on_tc_skip, + [skip_init_SUITE,init_per_suite, + {tc_user_skip,"Skipped in init_per_suite/1"}, + []]}}, + {?eh,tc_user_skip,{skip_init_SUITE,test_case,"Skipped in init_per_suite/1"}}, + {?eh,cth,{empty_cth,on_tc_skip, + [skip_init_SUITE,test_case, + {tc_user_skip,"Skipped in init_per_suite/1"}, + []]}}, + {?eh,test_stats,{0,0,{2,0}}}, + {?eh,tc_user_skip,{skip_init_SUITE,end_per_suite, + "Skipped in init_per_suite/1"}}, + {?eh,cth,{empty_cth,on_tc_skip, + [skip_init_SUITE,end_per_suite, + {tc_user_skip,"Skipped in init_per_suite/1"}, + []]}}, + + %% skip_req_SUITE is auto-skipped since a 'require' statement + %% returned by suite/0 is not fulfilled. + %% No group- or testcase-functions shall be called. + {?eh,tc_start,{skip_req_SUITE,init_per_suite}}, + {?eh,tc_done,{skip_req_SUITE,init_per_suite, + {auto_skipped,{require_failed_in_suite0, + {not_available,whatever}}}}}, + {?eh,cth,{empty_cth,on_tc_skip, + [skip_req_SUITE,init_per_suite, + {tc_auto_skip,{require_failed_in_suite0, + {not_available,whatever}}}, + []]}}, + {?eh,tc_auto_skip,{skip_req_SUITE,test_case,{require_failed_in_suite0, + {not_available,whatever}}}}, + {?eh,cth,{empty_cth,on_tc_skip, + [skip_req_SUITE,test_case, + {tc_auto_skip,{require_failed_in_suite0, + {not_available,whatever}}}, + []]}}, + {?eh,test_stats,{0,0,{2,1}}}, + {?eh,tc_auto_skip,{skip_req_SUITE,end_per_suite, + {require_failed_in_suite0, + {not_available,whatever}}}}, + {?eh,cth,{empty_cth,on_tc_skip, + [skip_req_SUITE,end_per_suite, + {tc_auto_skip,{require_failed_in_suite0, + {not_available,whatever}}}, + []]}}, + + %% skip_fail_SUITE is auto-skipped since the suite/0 function + %% retuns a faluty format. + %% No group- or testcase-functions shall be called. + {?eh,tc_start,{skip_fail_SUITE,init_per_suite}}, + {?eh,tc_done,{skip_fail_SUITE,init_per_suite, + {failed,{error,{suite0_failed,bad_return_value}}}}}, + {?eh,cth,{empty_cth,on_tc_skip, + [skip_fail_SUITE,init_per_suite, + {tc_auto_skip, + {failed,{error,{suite0_failed,bad_return_value}}}}, + []]}}, + {?eh,tc_auto_skip,{skip_fail_SUITE,test_case, + {failed,{error,{suite0_failed,bad_return_value}}}}}, + {?eh,cth,{empty_cth,on_tc_skip, + [skip_fail_SUITE,test_case, + {tc_auto_skip, + {failed,{error,{suite0_failed,bad_return_value}}}}, + []]}}, + {?eh,test_stats,{0,0,{2,2}}}, + {?eh,tc_auto_skip,{skip_fail_SUITE,end_per_suite, + {failed,{error,{suite0_failed,bad_return_value}}}}}, + {?eh,cth,{empty_cth,on_tc_skip, + [skip_fail_SUITE,end_per_suite, + {tc_auto_skip, + {failed,{error,{suite0_failed,bad_return_value}}}}, + []]}}, + + %% skip_group_SUITE + {?eh,tc_start,{skip_group_SUITE,init_per_suite}}, + {?eh,cth,{empty_cth,pre_init_per_suite, + [skip_group_SUITE, + '$proplist', + []]}}, + {?eh,cth,{empty_cth,post_init_per_suite, + [skip_group_SUITE, + '$proplist', + '_', + []]}}, + {?eh,tc_done,{skip_group_SUITE,init_per_suite,ok}}, + + %% test_group_1 - auto_skip due to require failed + [{?eh,tc_start,{skip_group_SUITE,{init_per_group,test_group_1,[]}}}, + {?eh,tc_done, + {skip_group_SUITE,{init_per_group,test_group_1,[]}, + {auto_skipped,{require_failed,{not_available,whatever}}}}}, + {?eh,cth,{empty_cth,on_tc_skip, + [skip_group_SUITE, + {init_per_group,test_group_1}, + {tc_auto_skip,{require_failed,{not_available,whatever}}}, + []]}}, + {?eh,tc_auto_skip,{skip_group_SUITE,{test_case,test_group_1}, + {require_failed,{not_available,whatever}}}}, + {?eh,cth,{empty_cth,on_tc_skip, + [skip_group_SUITE, + {test_case,test_group_1}, + {tc_auto_skip,{require_failed,{not_available,whatever}}}, + []]}}, + {?eh,test_stats,{0,0,{2,3}}}, + {?eh,tc_auto_skip,{skip_group_SUITE,{end_per_group,test_group_1}, + {require_failed,{not_available,whatever}}}}], + %% The following appears to be outside of the group, but + %% that's only an implementation detail in + %% ct_test_support.erl - it does not know about events from + %% test suite specific hooks and regards the group ended with + %% the above tc_auto_skip-event for end_per_group. + {?eh,cth,{empty_cth,on_tc_skip, + [skip_group_SUITE, + {end_per_group,test_group_1}, + {tc_auto_skip,{require_failed,{not_available,whatever}}}, + []]}}, + + %% test_group_2 - auto_skip due to failed return from group/1 + [{?eh,tc_start,{skip_group_SUITE,{init_per_group,test_group_2,[]}}}, + {?eh,tc_done, + {skip_group_SUITE,{init_per_group,test_group_2,[]}, + {auto_skipped,{group0_failed,bad_return_value}}}}, + {?eh,cth,{empty_cth,on_tc_skip, + [skip_group_SUITE, + {init_per_group,test_group_2}, + {tc_auto_skip,{group0_failed,bad_return_value}}, + []]}}, + {?eh,tc_auto_skip,{skip_group_SUITE,{test_case,test_group_2}, + {group0_failed,bad_return_value}}}, + {?eh,cth,{empty_cth,on_tc_skip, + [skip_group_SUITE, + {test_case,test_group_2}, + {tc_auto_skip,{group0_failed,bad_return_value}}, + []]}}, + {?eh,test_stats,{0,0,{2,4}}}, + {?eh,tc_auto_skip,{skip_group_SUITE,{end_per_group,test_group_2}, + {group0_failed,bad_return_value}}}], + {?eh,cth,{empty_cth,on_tc_skip, + [skip_group_SUITE, + {end_per_group,test_group_2}, + {tc_auto_skip,{group0_failed,bad_return_value}}, + []]}}, + %% test_group_3 - user_skip in init_per_group/2 + [{?eh,tc_start, + {skip_group_SUITE,{init_per_group,test_group_3,[]}}}, + {?eh,cth,{empty_cth,pre_init_per_group, + [skip_group_SUITE,test_group_3,'$proplist',[]]}}, + {?eh,cth,{empty_cth,post_init_per_group, + [skip_group_SUITE,test_group_3,'$proplist', + {skip,"Skipped in init_per_group/2"}, + []]}}, + {?eh,tc_done,{skip_group_SUITE, + {init_per_group,test_group_3,[]}, + {skipped,"Skipped in init_per_group/2"}}}, + {?eh,cth,{empty_cth,on_tc_skip, + [skip_group_SUITE, + {init_per_group,test_group_3}, + {tc_user_skip,"Skipped in init_per_group/2"}, + []]}}, + {?eh,tc_user_skip,{skip_group_SUITE, + {test_case,test_group_3}, + "Skipped in init_per_group/2"}}, + {?eh,cth,{empty_cth,on_tc_skip, + [skip_group_SUITE, + {test_case,test_group_3}, + {tc_user_skip,"Skipped in init_per_group/2"}, + []]}}, + {?eh,test_stats,{0,0,{3,4}}}, + {?eh,tc_user_skip,{skip_group_SUITE, + {end_per_group,test_group_3}, + "Skipped in init_per_group/2"}}], + {?eh,cth,{empty_cth,on_tc_skip, + [skip_group_SUITE, + {end_per_group,test_group_3}, + {tc_user_skip,"Skipped in init_per_group/2"}, + []]}}, + + {?eh,tc_start,{skip_group_SUITE,end_per_suite}}, + {?eh,cth,{empty_cth,pre_end_per_suite, + [skip_group_SUITE, + '$proplist', + []]}}, + {?eh,cth,{empty_cth,post_end_per_suite, + [skip_group_SUITE, + '$proplist', + ok,[]]}}, + {?eh,tc_done,{skip_group_SUITE,end_per_suite,ok}}, + + + %% skip_case_SUITE has 4 test cases which are all skipped in + %% different ways + {?eh,tc_start,{skip_case_SUITE,init_per_suite}}, + {?eh,cth,{empty_cth,pre_init_per_suite, + [skip_case_SUITE, + '$proplist', + []]}}, + {?eh,cth,{empty_cth,post_init_per_suite, + [skip_case_SUITE, + '$proplist', + '_', + []]}}, + {?eh,tc_done,{skip_case_SUITE,init_per_suite,ok}}, + + %% Skip in spec -> only on_tc_skip shall be called + {?eh,tc_user_skip,{skip_case_SUITE,skip_in_spec,"Skipped in spec"}}, + {?eh,cth,{empty_cth,on_tc_skip, + [skip_case_SUITE,skip_in_spec, + {tc_user_skip,"Skipped in spec"}, + []]}}, + {?eh,test_stats,{0,0,{4,4}}}, + + %% Skip in init_per_testcase -> pre/post_end_per_testcase + %% shall not be called + {?eh,tc_start,{skip_case_SUITE,skip_in_init}}, + {?eh,cth,{empty_cth,pre_init_per_testcase, + [skip_case_SUITE,skip_in_init, + '$proplist', + []]}}, + {?eh,cth,{empty_cth,post_init_per_testcase, + [skip_case_SUITE,skip_in_init, + '$proplist', + {skip,"Skipped in init_per_testcase/2"}, + []]}}, + {?eh,tc_done,{skip_case_SUITE,skip_in_init, + {skipped,"Skipped in init_per_testcase/2"}}}, + {?eh,cth,{empty_cth,on_tc_skip, + [skip_case_SUITE,skip_in_init, + {tc_user_skip,"Skipped in init_per_testcase/2"}, + []]}}, + {?eh,test_stats,{0,0,{5,4}}}, + + %% Fail in init_per_testcase -> pre/post_end_per_testcase + %% shall not be called + {?eh,tc_start,{skip_case_SUITE,fail_in_init}}, + {?eh,cth,{empty_cth,pre_init_per_testcase, + [skip_case_SUITE,fail_in_init, + '$proplist', + []]}}, + {?eh,cth,{empty_cth,post_init_per_testcase, + [skip_case_SUITE,fail_in_init, + '$proplist', + {skip,{failed,'_'}}, + []]}}, + {?eh,tc_done,{skip_case_SUITE,fail_in_init, + {auto_skipped,{failed,'_'}}}}, + {?eh,cth,{empty_cth,on_tc_skip, + [skip_case_SUITE,fail_in_init, + {tc_auto_skip,{failed,'_'}}, + []]}}, + {?eh,test_stats,{0,0,{5,5}}}, + + %% Exit in init_per_testcase -> pre/post_end_per_testcase + %% shall not be called + {?eh,tc_start,{skip_case_SUITE,exit_in_init}}, + {?eh,cth,{empty_cth,pre_init_per_testcase, + [skip_case_SUITE,exit_in_init, + '$proplist', + []]}}, + {?eh,cth,{empty_cth,post_init_per_testcase, + [skip_case_SUITE,exit_in_init, + '$proplist', + {skip,{failed,'_'}}, + []]}}, + {?eh,tc_done,{skip_case_SUITE,exit_in_init, + {auto_skipped,{failed,'_'}}}}, + {?eh,cth,{empty_cth,on_tc_skip, + [skip_case_SUITE,exit_in_init, + {tc_auto_skip,{failed,'_'}}, + []]}}, + {?eh,test_stats,{0,0,{5,6}}}, + + %% Fail in end_per_testcase -> all hooks shall be called and + %% test shall succeed. + {?eh,tc_start,{skip_case_SUITE,fail_in_end}}, + {?eh,cth,{empty_cth,pre_init_per_testcase, + [skip_case_SUITE,fail_in_end, + '$proplist', + []]}}, + {?eh,cth,{empty_cth,post_init_per_testcase, + [skip_case_SUITE,fail_in_end, + '$proplist', + ok, + []]}}, + {?eh,cth,{empty_cth,pre_end_per_testcase, + [skip_case_SUITE,fail_in_end, + '$proplist', + []]}}, + {?eh,cth,{empty_cth,post_end_per_testcase, + [skip_case_SUITE,fail_in_end, + '$proplist', + {failed, + {skip_case_SUITE,end_per_testcase, + {'EXIT', + {test_case_failed,"Failed in end_per_testcase/2"}}}}, + []]}}, + {?eh,tc_done,{skip_case_SUITE,fail_in_end, + {failed, + {skip_case_SUITE,end_per_testcase, + {'EXIT', + {test_case_failed,"Failed in end_per_testcase/2"}}}}}}, + {?eh,test_stats,{1,0,{5,6}}}, + + %% Exit in end_per_testcase -> all hooks shall be called and + %% test shall succeed. + {?eh,tc_start,{skip_case_SUITE,exit_in_end}}, + {?eh,cth,{empty_cth,pre_init_per_testcase, + [skip_case_SUITE,exit_in_end, + '$proplist', + []]}}, + {?eh,cth,{empty_cth,post_init_per_testcase, + [skip_case_SUITE,exit_in_end, + '$proplist', + ok, + []]}}, + {?eh,cth,{empty_cth,pre_end_per_testcase, + [skip_case_SUITE,exit_in_end, + '$proplist', + []]}}, + {?eh,cth,{empty_cth,post_end_per_testcase, + [skip_case_SUITE,exit_in_end, + '$proplist', + {failed, + {skip_case_SUITE,end_per_testcase, + {'EXIT',"Exit in end_per_testcase/2"}}}, + []]}}, + {?eh,tc_done,{skip_case_SUITE,exit_in_end, + {failed, + {skip_case_SUITE,end_per_testcase, + {'EXIT',"Exit in end_per_testcase/2"}}}}}, + {?eh,test_stats,{2,0,{5,6}}}, + + %% Skip in testcase function -> all callbacks shall be called + {?eh,tc_start,{skip_case_SUITE,skip_in_case}}, + {?eh,cth,{empty_cth,pre_init_per_testcase, + [skip_case_SUITE,skip_in_case, + '$proplist', + []]}}, + {?eh,cth,{empty_cth,post_init_per_testcase, + [skip_case_SUITE,skip_in_case, + '$proplist', + ok,[]]}}, + {?eh,cth,{empty_cth,pre_end_per_testcase, + [skip_case_SUITE,skip_in_case, + '$proplist', + []]}}, + {?eh,cth,{empty_cth,post_end_per_testcase, + [skip_case_SUITE,skip_in_case, + '$proplist', + {skip,"Skipped in test case function"}, + []]}}, + {?eh,tc_done,{skip_case_SUITE,skip_in_case, + {skipped,"Skipped in test case function"}}}, + {?eh,cth,{empty_cth,on_tc_skip, + [skip_case_SUITE,skip_in_case, + {tc_user_skip,"Skipped in test case function"}, + []]}}, + {?eh,test_stats,{2,0,{6,6}}}, + + %% Auto skip due to failed 'require' -> only the on_tc_skip + %% callback shall be called + {?eh,tc_start,{skip_case_SUITE,req_auto_skip}}, + {?eh,tc_done,{skip_case_SUITE,req_auto_skip, + {auto_skipped,{require_failed,{not_available,whatever}}}}}, + {?eh,cth,{empty_cth,on_tc_skip, + [skip_case_SUITE,req_auto_skip, + {tc_auto_skip,{require_failed,{not_available,whatever}}}, + []]}}, + {?eh,test_stats,{2,0,{6,7}}}, + + %% Auto skip due to failed testcase/0 function -> only the + %% on_tc_skip callback shall be called + {?eh,tc_start,{skip_case_SUITE,fail_auto_skip}}, + {?eh,tc_done,{skip_case_SUITE,fail_auto_skip, + {auto_skipped,{testcase0_failed,bad_return_value}}}}, + {?eh,cth,{empty_cth,on_tc_skip, + [skip_case_SUITE,fail_auto_skip, + {tc_auto_skip,{testcase0_failed,bad_return_value}}, + []]}}, + {?eh,test_stats,{2,0,{6,8}}}, + + {?eh,tc_start,{skip_case_SUITE,end_per_suite}}, + {?eh,cth,{empty_cth,pre_end_per_suite, + [skip_case_SUITE, + '$proplist', + []]}}, + {?eh,cth,{empty_cth,post_end_per_suite, + [skip_case_SUITE, + '$proplist', + ok,[]]}}, + {?eh,tc_done,{skip_case_SUITE,end_per_suite,ok}}, + {?eh,test_done,{'DEF','STOP_TIME'}}, + {?eh,cth,{empty_cth,terminate,[[]]}}, + {?eh,stop_logging,[]} + ], + %% Make sure no 'cth_error' events are received! + [{negative,{?eh,cth_error,'_'},E} || E <- Events]; + +test_events(failed_sequence) -> + %% skip_cth.erl will send a 'cth_error' event if a hook is + %% erroneously called. Therefore, all Events are changed to + %% {negative,{?eh,cth_error,'_'},Event} + %% at the end of this function. + Events = + [ + {?eh,start_logging,{'DEF','RUNDIR'}}, + {?eh,test_start,{'DEF',{'START_TIME','LOGDIR'}}}, + {?eh,cth,{empty_cth,id,[[]]}}, + {?eh,cth,{empty_cth,init,[{'_','_','_'},[]]}}, + {?eh,start_info,{1,1,2}}, + {?eh,tc_start,{ct_framework,init_per_suite}}, + {?eh,cth,{empty_cth,pre_init_per_suite,[seq_SUITE,'$proplist',[]]}}, + {?eh,cth,{empty_cth,post_init_per_suite, + [seq_SUITE,'$proplist','$proplist',[]]}}, + {?eh,tc_done,{ct_framework,init_per_suite,ok}}, + {?eh,tc_start,{seq_SUITE,test_case_1}}, + {?eh,cth,{empty_cth,pre_init_per_testcase, + [seq_SUITE,test_case_1,'$proplist',[]]}}, + {?eh,cth,{empty_cth,post_init_per_testcase, + [seq_SUITE,test_case_1,'$proplist',ok,[]]}}, + {?eh,cth,{empty_cth,pre_end_per_testcase, + [seq_SUITE,test_case_1,'$proplist',[]]}}, + {?eh,cth,{empty_cth,post_end_per_testcase, + [seq_SUITE,test_case_1,'$proplist', + {error,failed_on_purpose},[]]}}, + {?eh,tc_done,{seq_SUITE,test_case_1,{failed,{error,failed_on_purpose}}}}, + {?eh,cth,{empty_cth,on_tc_fail, + [seq_SUITE,test_case_1,failed_on_purpose,[]]}}, + {?eh,test_stats,{0,1,{0,0}}}, + {?eh,tc_start,{seq_SUITE,test_case_2}}, + {?eh,tc_done,{seq_SUITE,test_case_2, + {auto_skipped,{sequence_failed,seq1,test_case_1}}}}, + {?eh,cth,{empty_cth,on_tc_skip, + [seq_SUITE,test_case_2, + {tc_auto_skip,{sequence_failed,seq1,test_case_1}}, + []]}}, + {?eh,test_stats,{0,1,{0,1}}}, + {?eh,tc_start,{ct_framework,end_per_suite}}, + {?eh,cth,{empty_cth,pre_end_per_suite,[seq_SUITE,'$proplist',[]]}}, + {?eh,cth,{empty_cth,post_end_per_suite,[seq_SUITE,'$proplist',ok,[]]}}, + {?eh,tc_done,{ct_framework,end_per_suite,ok}}, + {?eh,test_done,{'DEF','STOP_TIME'}}, + {?eh,cth,{empty_cth,terminate,[[]]}}, + {?eh,stop_logging,[]} + ], + %% Make sure no 'cth_error' events are received! + [{negative,{?eh,cth_error,'_'},E} || E <- Events]; + +test_events(repeat_force_stop) -> + %% skip_cth.erl will send a 'cth_error' event if a hook is + %% erroneously called. Therefore, all Events are changed to + %% {negative,{?eh,cth_error,'_'},Event} + %% at the end of this function. + Events= + [ + {?eh,start_logging,{'DEF','RUNDIR'}}, + {?eh,test_start,{'DEF',{'START_TIME','LOGDIR'}}}, + {?eh,cth,{empty_cth,id,[[]]}}, + {?eh,cth,{empty_cth,init,[{'_','_','_'},[]]}}, + {?eh,start_info,{1,1,2}}, + {?eh,tc_start,{ct_framework,init_per_suite}}, + {?eh,cth,{empty_cth,pre_init_per_suite,[repeat_SUITE,'$proplist',[]]}}, + {?eh,cth,{empty_cth,post_init_per_suite, + [repeat_SUITE,'$proplist','$proplist',[]]}}, + {?eh,tc_done,{ct_framework,init_per_suite,ok}}, + {?eh,tc_start,{repeat_SUITE,test_case_1}}, + {?eh,cth,{empty_cth,pre_init_per_testcase, + [repeat_SUITE,test_case_1,'$proplist',[]]}}, + {?eh,cth,{empty_cth,post_init_per_testcase, + [repeat_SUITE,test_case_1,'$proplist',ok,[]]}}, + {?eh,cth,{empty_cth,pre_end_per_testcase, + [repeat_SUITE,test_case_1,'$proplist',[]]}}, + {?eh,cth,{empty_cth,post_end_per_testcase, + [repeat_SUITE,test_case_1,'$proplist',ok,[]]}}, + {?eh,tc_done,{repeat_SUITE,test_case_1,ok}}, + {?eh,test_stats,{1,0,{0,0}}}, + {?eh,tc_start,{repeat_SUITE,test_case_2}}, + {?eh,tc_done,{repeat_SUITE,test_case_2, + {auto_skipped, + "Repeated test stopped by force_stop option"}}}, + {?eh,cth,{empty_cth,on_tc_skip, + [repeat_SUITE,test_case_2, + {tc_auto_skip,"Repeated test stopped by force_stop option"}, + []]}}, + {?eh,test_stats,{1,0,{0,1}}}, + {?eh,tc_start,{ct_framework,end_per_suite}}, + {?eh,cth,{empty_cth,pre_end_per_suite,[repeat_SUITE,'$proplist',[]]}}, + {?eh,cth,{empty_cth,post_end_per_suite, + [repeat_SUITE,'$proplist',ok,[]]}}, + {?eh,tc_done,{ct_framework,end_per_suite,ok}}, + {?eh,test_done,{'DEF','STOP_TIME'}}, + {?eh,cth,{empty_cth,terminate,[[]]}}, + {?eh,stop_logging,[]} + ], + %% Make sure no 'cth_error' events are received! + [{negative,{?eh,cth_error,'_'},E} || E <- Events]; + +test_events(config_clash) -> + %% skip_cth.erl will send a 'cth_error' event if a hook is + %% erroneously called. Therefore, all Events are changed to + %% {negative,{?eh,cth_error,'_'},Event} + %% at the end of this function. + Events = + [ + {?eh,start_logging,{'DEF','RUNDIR'}}, + {?eh,test_start,{'DEF',{'START_TIME','LOGDIR'}}}, + {?eh,cth,{empty_cth,id,[[]]}}, + {?eh,cth,{empty_cth,init,[{'_','_','_'},[]]}}, + {?eh,start_info,{1,1,1}}, + {?eh,tc_start,{ct_framework,init_per_suite}}, + {?eh,cth,{empty_cth,pre_init_per_suite, + [config_clash_SUITE,'$proplist',[]]}}, + {?eh,cth,{empty_cth,post_init_per_suite, + [config_clash_SUITE,'$proplist','$proplist',[]]}}, + {?eh,tc_done,{ct_framework,init_per_suite,ok}}, + {?eh,tc_start,{config_clash_SUITE,test_case_1}}, + {?eh,tc_done,{config_clash_SUITE,test_case_1, + {failed,{error,{config_name_already_in_use,[aa]}}}}}, + {?eh,cth,{empty_cth,on_tc_fail, + [config_clash_SUITE,test_case_1, + {config_name_already_in_use,[aa]}, + []]}}, + {?eh,test_stats,{0,1,{0,0}}}, + {?eh,tc_start,{ct_framework,end_per_suite}}, + {?eh,cth,{empty_cth,pre_end_per_suite, + [config_clash_SUITE,'$proplist',[]]}}, + {?eh,cth,{empty_cth,post_end_per_suite, + [config_clash_SUITE,'$proplist',ok,[]]}}, + {?eh,tc_done,{ct_framework,end_per_suite,ok}}, + {?eh,test_done,{'DEF','STOP_TIME'}}, + {?eh,cth,{empty_cth,terminate,[[]]}}, + {?eh,stop_logging,[]} + ], + %% Make sure no 'cth_error' events are received! + [{negative,{?eh,cth_error,'_'},E} || E <- Events]; + test_events(ok) -> ok. diff --git a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/all_hook_callbacks_SUITE.erl b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/all_hook_callbacks_SUITE.erl new file mode 100644 index 0000000000..5b50548694 --- /dev/null +++ b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/all_hook_callbacks_SUITE.erl @@ -0,0 +1,62 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2010-2016. All Rights Reserved. +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. +%% +%% %CopyrightEnd% +%% + +-module(all_hook_callbacks_SUITE). + +-suite_defaults([{timetrap, {minutes, 10}}]). + +%% Note: This directive should only be used in test suites. +-compile(export_all). + +-include("ct.hrl"). + +%% Test server callback functions +init_per_suite(Config) -> + Config. + +end_per_suite(_Config) -> + ok. + +init_per_group(Config) -> + Config. + +end_per_group(_Config) -> + ok. + +init_per_testcase(skip_case, Config) -> + {skip,"Skipped in init_per_testcase/2"}; +init_per_testcase(_TestCase, Config) -> + Config. + +end_per_testcase(_TestCase, _Config) -> + ok. + +all() -> + [{group,test_group},test_case,skip_case]. + +groups() -> + [{test_group,[test_case]}]. + +%% Test cases starts here. +test_case(Config) -> + ok. + +skip_case(Config) -> + ok. diff --git a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/config_clash_SUITE.erl b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/config_clash_SUITE.erl new file mode 100644 index 0000000000..f74c757cc1 --- /dev/null +++ b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/config_clash_SUITE.erl @@ -0,0 +1,43 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2010-2016. All Rights Reserved. +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. +%% +%% %CopyrightEnd% +%% + +-module(config_clash_SUITE). + +-compile(export_all). + +-include("ct.hrl"). + +suite() -> + [{require,aa,yy},{default_config,yy,"this is a default value"}]. + +init_per_testcase(_,Config) -> + Config. + +end_per_testcase(_,_) -> + ok. + +all() -> + [test_case_1]. + +%% Test cases starts here. +test_case_1() -> + [{require,aa,xx}]. +test_case_1(_Config) -> + ok. diff --git a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/ct_no_end_config_SUITE.erl b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/ct_no_end_config_SUITE.erl new file mode 100644 index 0000000000..7cdaf2024b --- /dev/null +++ b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/ct_no_end_config_SUITE.erl @@ -0,0 +1,51 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2010-2016. All Rights Reserved. +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. +%% +%% %CopyrightEnd% +%% + +-module(ct_no_end_config_SUITE). + +-compile(export_all). + +-include("ct.hrl"). + +%%% This suite is used to verify that all pre/post_end_per_* callbacks +%%% are called with correct SuiteName even if no end_per_* config +%%% function exist in the suite, and that the non-exported config +%%% functions fail with 'undef'. + +init_per_suite(Config) -> + Config. + +init_per_group(_Group,Config) -> + Config. + +init_per_testcase(_TC,Config) -> + Config. + +all() -> + [test_case_1, {group,test_group}]. + +groups() -> + [{test_group,[],[test_case_2]}]. + +test_case_1(Config) -> + ok. + +test_case_2(Config) -> + ok. diff --git a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/ct_no_init_config_SUITE.erl b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/ct_no_init_config_SUITE.erl new file mode 100644 index 0000000000..43c062d66f --- /dev/null +++ b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/ct_no_init_config_SUITE.erl @@ -0,0 +1,54 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2010-2016. All Rights Reserved. +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. +%% +%% %CopyrightEnd% +%% + +-module(ct_no_init_config_SUITE). + +-compile(export_all). + +-include("ct.hrl"). + +%%% This suite is used to verify that all +%%% pre/post_init_per_group/testcase callbacks are called with correct +%%% SuiteName even if no init_per_group/testcase function exist in the +%%% suite, and that the non-exported config functions fail with 'undef'. + +init_per_suite(Config) -> + Config. + +end_per_suite(Config) -> + Config. + +end_per_group(_Group,Config) -> + Config. + +end_per_testcase(_TC,Config) -> + Config. + +all() -> + [test_case_1, {group,test_group}]. + +groups() -> + [{test_group,[],[test_case_2]}]. + +test_case_1(Config) -> + ok. + +test_case_2(Config) -> + ok. diff --git a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/ct_no_init_suite_config_SUITE.erl b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/ct_no_init_suite_config_SUITE.erl new file mode 100644 index 0000000000..85dfe8ca4b --- /dev/null +++ b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/ct_no_init_suite_config_SUITE.erl @@ -0,0 +1,39 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2010-2016. All Rights Reserved. +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. +%% +%% %CopyrightEnd% +%% + +-module(ct_no_init_suite_config_SUITE). + +-compile(export_all). + +-include("ct.hrl"). + +%%% This suite is used to verify that pre/post_init_per_suite +%%% callbacks are called with correct SuiteName even if no +%%% init_per_suite function exist in the suite, and that the +%%% non-exported config function fails with 'undef'. + +end_per_suite(Config) -> + Config. + +all() -> + [test_case]. + +test_case(Config) -> + ok. diff --git a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/empty_cth.erl b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/empty_cth.erl index c00eb5cf93..37742f0d20 100644 --- a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/empty_cth.erl +++ b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/empty_cth.erl @@ -44,18 +44,18 @@ -export([pre_end_per_suite/3]). -export([post_end_per_suite/4]). --export([pre_init_per_group/3]). --export([post_init_per_group/4]). --export([pre_end_per_group/3]). --export([post_end_per_group/4]). +-export([pre_init_per_group/4]). +-export([post_init_per_group/5]). +-export([pre_end_per_group/4]). +-export([post_end_per_group/5]). --export([pre_init_per_testcase/3]). --export([post_init_per_testcase/4]). --export([pre_end_per_testcase/3]). --export([post_end_per_testcase/4]). +-export([pre_init_per_testcase/4]). +-export([post_init_per_testcase/5]). +-export([pre_end_per_testcase/4]). +-export([post_end_per_testcase/5]). --export([on_tc_fail/3]). --export([on_tc_skip/3]). +-export([on_tc_fail/4]). +-export([on_tc_skip/4]). -export([terminate/1]). @@ -154,150 +154,160 @@ post_end_per_suite(Suite,Config,Return,State) -> %% @doc Called before each init_per_group. %% You can change the config in this function. --spec pre_init_per_group(Group :: atom(), - Config :: config(), - State :: #state{}) -> +-spec pre_init_per_group(Suite :: atom(), + Group :: atom(), + Config :: config(), + State :: #state{}) -> {config() | skip_or_fail(), NewState :: #state{}}. -pre_init_per_group(Group,Config,State) -> +pre_init_per_group(Suite,Group,Config,State) -> gen_event:notify( ?CT_EVMGR_REF, #event{ name = cth, node = node(), data = {?MODULE, pre_init_per_group, - [Group,Config,State]}}), - ct:log("~w:pre_init_per_group(~w) called", [?MODULE,Group]), + [Suite,Group,Config,State]}}), + ct:log("~w:pre_init_per_group(~w,~w) called", [?MODULE,Suite,Group]), {Config, State}. %% @doc Called after each init_per_group. %% You can change the return value in this function. --spec post_init_per_group(Group :: atom(), +-spec post_init_per_group(Suite :: atom(), + Group :: atom(), Config :: config(), Return :: config() | skip_or_fail(), State :: #state{}) -> {config() | skip_or_fail(), NewState :: #state{}}. -post_init_per_group(Group,Config,Return,State) -> +post_init_per_group(Suite,Group,Config,Return,State) -> gen_event:notify( ?CT_EVMGR_REF, #event{ name = cth, node = node(), data = {?MODULE, post_init_per_group, - [Group,Config,Return,State]}}), - ct:log("~w:post_init_per_group(~w) called", [?MODULE,Group]), + [Suite,Group,Config,Return,State]}}), + ct:log("~w:post_init_per_group(~w,~w) called", [?MODULE,Suite,Group]), {Return, State}. %% @doc Called after each end_per_group. The config/state can be changed here, %% though it will only affect the *end_per_group functions. --spec pre_end_per_group(Group :: atom(), +-spec pre_end_per_group(Suite :: atom(), + Group :: atom(), Config :: config() | skip_or_fail(), State :: #state{}) -> {ok | skip_or_fail(), NewState :: #state{}}. -pre_end_per_group(Group,Config,State) -> +pre_end_per_group(Suite,Group,Config,State) -> gen_event:notify( ?CT_EVMGR_REF, #event{ name = cth, node = node(), data = {?MODULE, pre_end_per_group, - [Group,Config,State]}}), - ct:log("~w:pre_end_per_group(~w) called", [?MODULE,Group]), + [Suite,Group,Config,State]}}), + ct:log("~w:pre_end_per_group(~w~w) called", [?MODULE,Suite,Group]), {Config, State}. %% @doc Called after each end_per_group. Note that the config cannot be %% changed here, only the status of the group. --spec post_end_per_group(Group :: atom(), +-spec post_end_per_group(Suite :: atom(), + Group :: atom(), Config :: config(), Return :: term(), State :: #state{}) -> {ok | skip_or_fail(), NewState :: #state{}}. -post_end_per_group(Group,Config,Return,State) -> +post_end_per_group(Suite,Group,Config,Return,State) -> gen_event:notify( ?CT_EVMGR_REF, #event{ name = cth, node = node(), data = {?MODULE, post_end_per_group, - [Group,Config,Return,State]}}), - ct:log("~w:post_end_per_group(~w) called", [?MODULE,Group]), + [Suite,Group,Config,Return,State]}}), + ct:log("~w:post_end_per_group(~w,~w) called", [?MODULE,Suite,Group]), {Return, State}. %% @doc Called before init_per_testcase/2 for each test case. %% You can change the config in this function. --spec pre_init_per_testcase(TC :: atom(), - Config :: config(), - State :: #state{}) -> +-spec pre_init_per_testcase(Suite :: atom(), + TC :: atom(), + Config :: config(), + State :: #state{}) -> {config() | skip_or_fail(), NewState :: #state{}}. -pre_init_per_testcase(TC,Config,State) -> +pre_init_per_testcase(Suite,TC,Config,State) -> gen_event:notify( ?CT_EVMGR_REF, #event{ name = cth, node = node(), data = {?MODULE, pre_init_per_testcase, - [TC,Config,State]}}), - ct:log("~w:pre_init_per_testcase(~w) called", [?MODULE,TC]), + [Suite,TC,Config,State]}}), + ct:log("~w:pre_init_per_testcase(~w,~w) called", [?MODULE,Suite,TC]), {Config, State}. %% @doc Called after init_per_testcase/2, and before the test case. --spec post_init_per_testcase(TC :: atom(), +-spec post_init_per_testcase(Suite :: atom(), + TC :: atom(), Config :: config(), Return :: config() | skip_or_fail(), State :: #state{}) -> {config() | skip_or_fail(), NewState :: #state{}}. -post_init_per_testcase(TC,Config,Return,State) -> +post_init_per_testcase(Suite,TC,Config,Return,State) -> gen_event:notify( ?CT_EVMGR_REF, #event{ name = cth, node = node(), data = {?MODULE, post_init_per_testcase, - [TC,Config,Return,State]}}), - ct:log("~w:post_init_per_testcase(~w) called", [?MODULE,TC]), + [Suite,TC,Config,Return,State]}}), + ct:log("~w:post_init_per_testcase(~w,~w) called", [?MODULE,Suite,TC]), {Return, State}. %% @doc Called before end_per_testacse/2. No skip or fail allowed here, %% only config additions. --spec pre_end_per_testcase(TC :: atom(), - Config :: config(), - State :: #state{}) -> +-spec pre_end_per_testcase(Suite :: atom(), + TC :: atom(), + Config :: config(), + State :: #state{}) -> {config(), NewState :: #state{}}. -pre_end_per_testcase(TC,Config,State) -> +pre_end_per_testcase(Suite,TC,Config,State) -> gen_event:notify( ?CT_EVMGR_REF, #event{ name = cth, node = node(), data = {?MODULE, pre_end_per_testcase, - [TC,Config,State]}}), - ct:log("~w:pre_end_per_testcase(~w) called", [?MODULE,TC]), + [Suite,TC,Config,State]}}), + ct:log("~w:pre_end_per_testcase(~w,~w) called", [?MODULE,Suite,TC]), {Config, State}. %% @doc Called after end_per_testcase/2 for each test case. Note that %% the config cannot be changed here, only the status of the test case. --spec post_end_per_testcase(TC :: atom(), +-spec post_end_per_testcase(Suite :: atom(), + TC :: atom(), Config :: config(), Return :: term(), State :: #state{}) -> {ok | skip_or_fail(), NewState :: #state{}}. -post_end_per_testcase(TC,Config,Return,State) -> +post_end_per_testcase(Suite,TC,Config,Return,State) -> gen_event:notify( ?CT_EVMGR_REF, #event{ name = cth, node = node(), data = {?MODULE, post_end_per_testcase, - [TC,Config,Return,State]}}), - ct:log("~w:post_end_per_testcase(~w) called", [?MODULE,TC]), + [Suite,TC,Config,Return,State]}}), + ct:log("~w:post_end_per_testcase(~w,~w) called", [?MODULE,Suite,TC]), {Return, State}. %% @doc Called after post_init_per_suite, post_end_per_suite, post_init_per_group, %% post_end_per_group and post_end_per_tc if the suite, group or test case failed. %% This function should be used for extra cleanup which might be needed. %% It is not possible to modify the config or the status of the test run. --spec on_tc_fail(TC :: init_per_suite | end_per_suite | +-spec on_tc_fail(Suite :: atom(), + TC :: init_per_suite | end_per_suite | init_per_group | end_per_group | atom() | {Function :: atom(), GroupName :: atom()}, Reason :: term(), State :: #state{}) -> NewState :: #state{}. -on_tc_fail(TC, Reason, State) -> +on_tc_fail(Suite, TC, Reason, State) -> gen_event:notify( ?CT_EVMGR_REF, #event{ name = cth, node = node(), data = {?MODULE, on_tc_fail, - [TC,Reason,State]}}), - ct:log("~w:on_tc_fail(~w) called", [?MODULE,TC]), + [Suite,TC,Reason,State]}}), + ct:log("~w:on_tc_fail(~w,~w) called", [?MODULE,Suite,TC]), State. %% @doc Called when a test case is skipped by either user action %% or due to an init function failing. Test case can be %% end_per_suite, init_per_group, end_per_group and the actual test cases. --spec on_tc_skip(TC :: end_per_suite | +-spec on_tc_skip(Suite :: atom(), + TC :: end_per_suite | init_per_group | end_per_group | atom() | {Function :: atom(), GroupName :: atom()}, {tc_auto_skip, {failed, {Mod :: atom(), Function :: atom(), Reason :: term()}}} | {tc_user_skip, {skipped, Reason :: term()}}, State :: #state{}) -> NewState :: #state{}. -on_tc_skip(TC, Reason, State) -> +on_tc_skip(Suite, TC, Reason, State) -> gen_event:notify( ?CT_EVMGR_REF, #event{ name = cth, node = node(), data = {?MODULE, on_tc_skip, - [TC,Reason,State]}}), - ct:log("~w:on_tc_skip(~w) called", [?MODULE,TC]), + [Suite,TC,Reason,State]}}), + ct:log("~w:on_tc_skip(~w,~w) called", [?MODULE,Suite,TC]), State. %% @doc Called when the scope of the CTH is done, this depends on diff --git a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/fail_post_suite_cth.erl b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/fail_post_suite_cth.erl index 559b22bc9f..141b933697 100644 --- a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/fail_post_suite_cth.erl +++ b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/fail_post_suite_cth.erl @@ -45,29 +45,29 @@ pre_end_per_suite(Suite,Config,State) -> post_end_per_suite(Suite,Config,Return,State) ->
empty_cth:post_end_per_suite(Suite,Config,Return,State).
-pre_init_per_group(Group,Config,State) ->
- empty_cth:pre_init_per_group(Group,Config,State).
+pre_init_per_group(Suite,Group,Config,State) -> + empty_cth:pre_init_per_group(Suite,Group,Config,State). -post_init_per_group(Group,Config,Return,State) ->
- empty_cth:post_init_per_group(Group,Config,Return,State).
+post_init_per_group(Suite,Group,Config,Return,State) -> + empty_cth:post_init_per_group(Suite,Group,Config,Return,State). -pre_end_per_group(Group,Config,State) ->
- empty_cth:pre_end_per_group(Group,Config,State).
+pre_end_per_group(Suite,Group,Config,State) -> + empty_cth:pre_end_per_group(Suite,Group,Config,State). -post_end_per_group(Group,Config,Return,State) ->
- empty_cth:post_end_per_group(Group,Config,Return,State).
+post_end_per_group(Suite,Group,Config,Return,State) -> + empty_cth:post_end_per_group(Suite,Group,Config,Return,State). -pre_init_per_testcase(TC,Config,State) ->
- empty_cth:pre_init_per_testcase(TC,Config,State).
+pre_init_per_testcase(Suite,TC,Config,State) -> + empty_cth:pre_init_per_testcase(Suite,TC,Config,State). -post_end_per_testcase(TC,Config,Return,State) ->
- empty_cth:post_end_per_testcase(TC,Config,Return,State).
+post_end_per_testcase(Suite,TC,Config,Return,State) -> + empty_cth:post_end_per_testcase(Suite,TC,Config,Return,State). -on_tc_fail(TC, Reason, State) ->
- empty_cth:on_tc_fail(TC,Reason,State).
+on_tc_fail(Suite,TC, Reason, State) -> + empty_cth:on_tc_fail(Suite,TC,Reason,State). -on_tc_skip(TC, Reason, State) ->
- empty_cth:on_tc_skip(TC,Reason,State).
+on_tc_skip(Suite,TC, Reason, State) -> + empty_cth:on_tc_skip(Suite,TC,Reason,State). terminate(State) ->
empty_cth:terminate(State).
diff --git a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/fail_pre_suite_cth.erl b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/fail_pre_suite_cth.erl index 51202443bf..07d7c84ed5 100644 --- a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/fail_pre_suite_cth.erl +++ b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/fail_pre_suite_cth.erl @@ -45,35 +45,35 @@ pre_end_per_suite(Suite,Config,State) -> post_end_per_suite(Suite,Config,Return,State) -> empty_cth:post_end_per_suite(Suite,Config,Return,State). -pre_init_per_group(Group,Config,State) -> - empty_cth:pre_init_per_group(Group,Config,State). +pre_init_per_group(Suite,Group,Config,State) -> + empty_cth:pre_init_per_group(Suite,Group,Config,State). -post_init_per_group(Group,Config,Return,State) -> - empty_cth:post_init_per_group(Group,Config,Return,State). +post_init_per_group(Suite,Group,Config,Return,State) -> + empty_cth:post_init_per_group(Suite,Group,Config,Return,State). -pre_end_per_group(Group,Config,State) -> - empty_cth:pre_end_per_group(Group,Config,State). +pre_end_per_group(Suite,Group,Config,State) -> + empty_cth:pre_end_per_group(Suite,Group,Config,State). -post_end_per_group(Group,Config,Return,State) -> - empty_cth:post_end_per_group(Group,Config,Return,State). +post_end_per_group(Suite,Group,Config,Return,State) -> + empty_cth:post_end_per_group(Suite,Group,Config,Return,State). -pre_init_per_testcase(TC,Config,State) -> - empty_cth:pre_init_per_testcase(TC,Config,State). +pre_init_per_testcase(Suite,TC,Config,State) -> + empty_cth:pre_init_per_testcase(Suite,TC,Config,State). -post_init_per_testcase(TC,Config,Return,State) -> - empty_cth:post_init_per_testcase(TC,Config,Return,State). +post_init_per_testcase(Suite,TC,Config,Return,State) -> + empty_cth:post_init_per_testcase(Suite,TC,Config,Return,State). -pre_end_per_testcase(TC,Config,State) -> - empty_cth:pre_end_per_testcase(TC,Config,State). +pre_end_per_testcase(Suite,TC,Config,State) -> + empty_cth:pre_end_per_testcase(Suite,TC,Config,State). -post_end_per_testcase(TC,Config,Return,State) -> - empty_cth:post_end_per_testcase(TC,Config,Return,State). +post_end_per_testcase(Suite,TC,Config,Return,State) -> + empty_cth:post_end_per_testcase(Suite,TC,Config,Return,State). -on_tc_fail(TC, Reason, State) -> - empty_cth:on_tc_fail(TC,Reason,State). +on_tc_fail(Suite,TC, Reason, State) -> + empty_cth:on_tc_fail(Suite,TC,Reason,State). -on_tc_skip(TC, Reason, State) -> - empty_cth:on_tc_skip(TC,Reason,State). +on_tc_skip(Suite,TC, Reason, State) -> + empty_cth:on_tc_skip(Suite,TC,Reason,State). terminate(State) -> empty_cth:terminate(State). diff --git a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/fallback_cth.erl b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/fallback_cth.erl new file mode 100644 index 0000000000..59a3d5cbf9 --- /dev/null +++ b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/fallback_cth.erl @@ -0,0 +1,81 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2010-2016. All Rights Reserved. +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. +%% +%% %CopyrightEnd% +%% + + +-module(fallback_cth). + + +-include_lib("common_test/src/ct_util.hrl"). +-include_lib("common_test/include/ct_event.hrl"). + + +%% CT Hooks +-compile(export_all). + +id(Opts) -> + empty_cth:id(Opts). + +init(Id, Opts) -> + empty_cth:init(Id, Opts). + +pre_init_per_suite(Suite, Config, State) -> + empty_cth:pre_init_per_suite(Suite,Config,State). + +post_init_per_suite(Suite,Config,Return,State) -> + empty_cth:post_init_per_suite(Suite,Config,Return,State). + +pre_end_per_suite(Suite,Config,State) -> + empty_cth:pre_end_per_suite(Suite,Config,State). + +post_end_per_suite(Suite,Config,Return,State) -> + empty_cth:post_end_per_suite(Suite,Config,Return,State). + +pre_init_per_group(Group,Config,State) -> + empty_cth:pre_init_per_group(fallback_nosuite,Group,Config,State). + +post_init_per_group(Group,Config,Return,State) -> + empty_cth:post_init_per_group(fallback_nosuite,Group,Config,Return,State). + +pre_end_per_group(Group,Config,State) -> + empty_cth:pre_end_per_group(fallback_nosuite,Group,Config,State). + +post_end_per_group(Group,Config,Return,State) -> + empty_cth:post_end_per_group(fallback_nosuite,Group,Config,Return,State). + +pre_init_per_testcase(TC,Config,State) -> + empty_cth:pre_init_per_testcase(fallback_nosuite,TC,Config,State). + +post_init_per_testcase(TC,Config,Return,State) -> + empty_cth:post_init_per_testcase(fallback_nosuite,TC,Config,Return,State). + +pre_end_per_testcase(TC,Config,State) -> + empty_cth:pre_end_per_testcase(fallback_nosuite,TC,Config,State). + +post_end_per_testcase(TC,Config,Return,State) -> + empty_cth:post_end_per_testcase(fallback_nosuite,TC,Config,Return,State). + +on_tc_fail(TC, Reason, State) -> + empty_cth:on_tc_fail(fallback_nosuite,TC,Reason,State). + +on_tc_skip(TC, Reason, State) -> + empty_cth:on_tc_skip(fallback_nosuite,TC,Reason,State). + +terminate(State) -> + empty_cth:terminate(State). diff --git a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/minimal_terminate_cth.erl b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/minimal_terminate_cth.erl index b49cbe7fb4..679f076f3a 100644 --- a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/minimal_terminate_cth.erl +++ b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/minimal_terminate_cth.erl @@ -29,13 +29,13 @@ %% CT Hooks -export([init/2]). -export([terminate/1]). --export([on_tc_skip/3]). +-export([on_tc_skip/4]). init(Id, Opts) -> empty_cth:init(Id, Opts). -on_tc_skip(TC, Reason, State) -> - empty_cth:on_tc_skip(TC,Reason,State). +on_tc_skip(Suite, TC, Reason, State) -> + empty_cth:on_tc_skip(Suite,TC,Reason,State). terminate(State) -> empty_cth:terminate(State). diff --git a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/prio_cth.erl b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/prio_cth.erl index a687743641..95bb76b4c1 100644 --- a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/prio_cth.erl +++ b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/prio_cth.erl @@ -47,35 +47,35 @@ pre_end_per_suite(Suite,Config,State) -> post_end_per_suite(Suite,Config,Return,State) -> empty_cth:post_end_per_suite(Suite,Config,Return,State). -pre_init_per_group(Group,Config,State) -> - empty_cth:pre_init_per_group(Group,Config,State). +pre_init_per_group(Suite,Group,Config,State) -> + empty_cth:pre_init_per_group(Suite,Group,Config,State). -post_init_per_group(Group,Config,Return,State) -> - empty_cth:post_init_per_group(Group,Config,Return,State). +post_init_per_group(Suite,Group,Config,Return,State) -> + empty_cth:post_init_per_group(Suite,Group,Config,Return,State). -pre_end_per_group(Group,Config,State) -> - empty_cth:pre_end_per_group(Group,Config,State). +pre_end_per_group(Suite,Group,Config,State) -> + empty_cth:pre_end_per_group(Suite,Group,Config,State). -post_end_per_group(Group,Config,Return,State) -> - empty_cth:post_end_per_group(Group,Config,Return,State). +post_end_per_group(Suite,Group,Config,Return,State) -> + empty_cth:post_end_per_group(Suite,Group,Config,Return,State). -pre_init_per_testcase(TC,Config,State) -> - empty_cth:pre_init_per_testcase(TC,Config,State). +pre_init_per_testcase(Suite,TC,Config,State) -> + empty_cth:pre_init_per_testcase(Suite,TC,Config,State). -post_init_per_testcase(TC,Config,Return,State) -> - empty_cth:post_init_per_testcase(TC,Config,Return,State). +post_init_per_testcase(Suite,TC,Config,Return,State) -> + empty_cth:post_init_per_testcase(Suite,TC,Config,Return,State). -pre_end_per_testcase(TC,Config,State) -> - empty_cth:pre_end_per_testcase(TC,Config,State). +pre_end_per_testcase(Suite,TC,Config,State) -> + empty_cth:pre_end_per_testcase(Suite,TC,Config,State). -post_end_per_testcase(TC,Config,Return,State) -> - empty_cth:post_end_per_testcase(TC,Config,Return,State). +post_end_per_testcase(Suite,TC,Config,Return,State) -> + empty_cth:post_end_per_testcase(Suite,TC,Config,Return,State). -on_tc_fail(TC, Reason, State) -> - empty_cth:on_tc_fail(TC,Reason,State). +on_tc_fail(Suite,TC, Reason, State) -> + empty_cth:on_tc_fail(Suite,TC,Reason,State). -on_tc_skip(TC, Reason, State) -> - empty_cth:on_tc_skip(TC,Reason,State). +on_tc_skip(Suite,TC, Reason, State) -> + empty_cth:on_tc_skip(Suite,TC,Reason,State). terminate(State) -> empty_cth:terminate(State). diff --git a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/recover_post_suite_cth.erl b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/recover_post_suite_cth.erl index 4d9c60f1ca..3562d39967 100644 --- a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/recover_post_suite_cth.erl +++ b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/recover_post_suite_cth.erl @@ -47,35 +47,35 @@ pre_end_per_suite(Suite,Config,State) -> post_end_per_suite(Suite,Config,Return,State) -> empty_cth:post_end_per_suite(Suite,Config,Return,State). -pre_init_per_group(Group,Config,State) -> - empty_cth:pre_init_per_group(Group,Config,State). +pre_init_per_group(Suite,Group,Config,State) -> + empty_cth:pre_init_per_group(Suite,Group,Config,State). -post_init_per_group(Group,Config,Return,State) -> - empty_cth:post_init_per_group(Group,Config,Return,State). +post_init_per_group(Suite,Group,Config,Return,State) -> + empty_cth:post_init_per_group(Suite,Group,Config,Return,State). -pre_end_per_group(Group,Config,State) -> - empty_cth:pre_end_per_group(Group,Config,State). +pre_end_per_group(Suite,Group,Config,State) -> + empty_cth:pre_end_per_group(Suite,Group,Config,State). -post_end_per_group(Group,Config,Return,State) -> - empty_cth:post_end_per_group(Group,Config,Return,State). +post_end_per_group(Suite,Group,Config,Return,State) -> + empty_cth:post_end_per_group(Suite,Group,Config,Return,State). -pre_init_per_testcase(TC,Config,State) -> - empty_cth:pre_init_per_testcase(TC,Config,State). +pre_init_per_testcase(Suite,TC,Config,State) -> + empty_cth:pre_init_per_testcase(Suite,TC,Config,State). -post_init_per_testcase(TC,Config,Return,State) -> - empty_cth:post_init_per_testcase(TC,Config,Return,State). +post_init_per_testcase(Suite,TC,Config,Return,State) -> + empty_cth:post_init_per_testcase(Suite,TC,Config,Return,State). -pre_end_per_testcase(TC,Config,State) -> - empty_cth:pre_end_per_testcase(TC,Config,State). +pre_end_per_testcase(Suite,TC,Config,State) -> + empty_cth:pre_end_per_testcase(Suite,TC,Config,State). -post_end_per_testcase(TC,Config,Return,State) -> - empty_cth:post_end_per_testcase(TC,Config,Return,State). +post_end_per_testcase(Suite,TC,Config,Return,State) -> + empty_cth:post_end_per_testcase(Suite,TC,Config,Return,State). -on_tc_fail(TC, Reason, State) -> - empty_cth:on_tc_fail(TC,Reason,State). +on_tc_fail(Suite,TC, Reason, State) -> + empty_cth:on_tc_fail(Suite,TC,Reason,State). -on_tc_skip(TC, Reason, State) -> - empty_cth:on_tc_skip(TC,Reason,State). +on_tc_skip(Suite,TC, Reason, State) -> + empty_cth:on_tc_skip(Suite,TC,Reason,State). terminate(State) -> empty_cth:terminate(State). diff --git a/lib/typer/src/typer.appup.src b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/repeat_SUITE.erl index 3b7464a97c..fded4c02ab 100644 --- a/lib/typer/src/typer.appup.src +++ b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/repeat_SUITE.erl @@ -1,7 +1,7 @@ -%% -*- erlang -*- +%% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2014-2016. All Rights Reserved. +%% Copyright Ericsson AB 2010-2016. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -16,7 +16,27 @@ %% limitations under the License. %% %% %CopyrightEnd% -{"%VSN%", - [{<<".*">>,[{restart_application, typer}]}], - [{<<".*">>,[{restart_application, typer}]}] -}. +%% + +-module(repeat_SUITE). + +-compile(export_all). + +-include("ct.hrl"). + +init_per_testcase(_,Config) -> + Config. + +end_per_testcase(_,_) -> + ok. + +all() -> + [test_case_1, test_case_2]. + +%% Test cases starts here. +test_case_1(_Config) -> + timer:sleep(10000), + ok. + +test_case_2(_Config) -> + ok. diff --git a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/same_id_cth.erl b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/same_id_cth.erl index 494f398fc1..b9d9d4cec1 100644 --- a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/same_id_cth.erl +++ b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/same_id_cth.erl @@ -48,35 +48,35 @@ pre_end_per_suite(Suite,Config,State) -> post_end_per_suite(Suite,Config,Return,State) -> empty_cth:post_end_per_suite(Suite,Config,Return,State). -pre_init_per_group(Group,Config,State) -> - empty_cth:pre_init_per_group(Group,Config,State). +pre_init_per_group(Suite,Group,Config,State) -> + empty_cth:pre_init_per_group(Suite,Group,Config,State). -post_init_per_group(Group,Config,Return,State) -> - empty_cth:post_init_per_group(Group,Config,Return,State). +post_init_per_group(Suite,Group,Config,Return,State) -> + empty_cth:post_init_per_group(Suite,Group,Config,Return,State). -pre_end_per_group(Group,Config,State) -> - empty_cth:pre_end_per_group(Group,Config,State). +pre_end_per_group(Suite,Group,Config,State) -> + empty_cth:pre_end_per_group(Suite,Group,Config,State). -post_end_per_group(Group,Config,Return,State) -> - empty_cth:post_end_per_group(Group,Config,Return,State). +post_end_per_group(Suite,Group,Config,Return,State) -> + empty_cth:post_end_per_group(Suite,Group,Config,Return,State). -pre_init_per_testcase(TC,Config,State) -> - empty_cth:pre_init_per_testcase(TC,Config,State). +pre_init_per_testcase(Suite,TC,Config,State) -> + empty_cth:pre_init_per_testcase(Suite,TC,Config,State). -post_init_per_testcase(TC,Config,Return,State) -> - empty_cth:post_init_per_testcase(TC,Config,Return,State). +post_init_per_testcase(Suite,TC,Config,Return,State) -> + empty_cth:post_init_per_testcase(Suite,TC,Config,Return,State). -pre_end_per_testcase(TC,Config,State) -> - empty_cth:pre_end_per_testcase(TC,Config,State). +pre_end_per_testcase(Suite,TC,Config,State) -> + empty_cth:pre_end_per_testcase(Suite,TC,Config,State). -post_end_per_testcase(TC,Config,Return,State) -> - empty_cth:post_end_per_testcase(TC,Config,Return,State). +post_end_per_testcase(Suite,TC,Config,Return,State) -> + empty_cth:post_end_per_testcase(Suite,TC,Config,Return,State). -on_tc_fail(TC, Reason, State) -> - empty_cth:on_tc_fail(TC,Reason,State). +on_tc_fail(Suite,TC, Reason, State) -> + empty_cth:on_tc_fail(Suite,TC,Reason,State). -on_tc_skip(TC, Reason, State) -> - empty_cth:on_tc_skip(TC,Reason,State). +on_tc_skip(Suite,TC, Reason, State) -> + empty_cth:on_tc_skip(Suite,TC,Reason,State). terminate(State) -> empty_cth:terminate(State). diff --git a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/seq_SUITE.erl b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/seq_SUITE.erl new file mode 100644 index 0000000000..6d1302fd35 --- /dev/null +++ b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/seq_SUITE.erl @@ -0,0 +1,45 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2010-2016. All Rights Reserved. +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. +%% +%% %CopyrightEnd% +%% + +-module(seq_SUITE). + +-compile(export_all). + +-include("ct.hrl"). + +init_per_testcase(_,Config) -> + Config. + +end_per_testcase(_,_) -> + ok. + +all() -> + [{sequence,seq1}]. + +sequences() -> + [{seq1,[test_case_1,test_case_2]}]. + +%% Test cases starts here. +test_case_1(_Config) -> + exit(failed_on_purpose). + +test_case_2(_Config) -> + ct:fail("This test shall never be run since test_case_1 fails " + "and they are run in sequence"). diff --git a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/skip.spec b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/skip.spec new file mode 100644 index 0000000000..a271c5e8b2 --- /dev/null +++ b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/skip.spec @@ -0,0 +1,8 @@ +{suites,".",[all_hook_callbacks_SUITE, + skip_init_SUITE, + skip_req_SUITE, + skip_fail_SUITE, + skip_group_SUITE, + skip_case_SUITE]}. +{skip_suites,".",all_hook_callbacks_SUITE,"Skipped in spec"}. +{skip_cases,".",skip_case_SUITE,skip_in_spec,"Skipped in spec"}. diff --git a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/skip_case_SUITE.erl b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/skip_case_SUITE.erl new file mode 100644 index 0000000000..dad80ae914 --- /dev/null +++ b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/skip_case_SUITE.erl @@ -0,0 +1,106 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2010-2016. All Rights Reserved. +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. +%% +%% %CopyrightEnd% +%% + +-module(skip_case_SUITE). + +-compile(export_all). + +-include("ct.hrl"). + +suite() -> + []. + +init_per_suite(Config) -> + Config. + +end_per_suite(Config) -> + ok. + +init_per_group(_,Config) -> + Config. + +end_per_group(_,_) -> + ok. + +init_per_testcase(skip_in_init,Config) -> + {skip,"Skipped in init_per_testcase/2"}; +init_per_testcase(fail_in_init,Config) -> + ct:fail("Failed in init_per_testcase/2"); +init_per_testcase(exit_in_init,Config) -> + exit(self(),"Exit in init_per_testcase/2"); +init_per_testcase(_,Config) -> + Config. + +end_per_testcase(fail_in_end,_) -> + ct:fail("Failed in end_per_testcase/2"); +end_per_testcase(exit_in_end,_) -> + exit(self(),"Exit in end_per_testcase/2"); +end_per_testcase(_,_) -> + ok. + +all() -> + [skip_in_spec, + skip_in_init, + fail_in_init, + exit_in_init, + fail_in_end, + exit_in_end, + skip_in_case, + req_auto_skip, + fail_auto_skip + ]. + +%% Test cases starts here. +skip_in_spec(Config) -> + ct:fail("This test shall never be run. " + "It shall be skipped in the test spec."). + +skip_in_init(Config) -> + ct:fail("This test shall never be run. " + "It shall be skipped in init_per_testcase/2."). + +fail_in_init(Config) -> + ct:fail("This test shall never be run. " + "It shall fail in init_per_testcase/2."). + +exit_in_init(Config) -> + ct:fail("This test shall never be run. " + "It shall exit in init_per_testcase/2."). + +fail_in_end(Config) -> + ok. + +exit_in_end(Config) -> + ok. + +skip_in_case(Config) -> + {skip,"Skipped in test case function"}. + +req_auto_skip() -> + [{require,whatever}]. +req_auto_skip(Config) -> + ct:fail("This test shall never be run due to " + "failed require"). + +fail_auto_skip() -> + faulty_return_value. +fail_auto_skip(Config) -> + ct:fail("This test shall never be run due to " + "faulty return from info function"). diff --git a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/skip_cth.erl b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/skip_cth.erl new file mode 100644 index 0000000000..16f015fe7a --- /dev/null +++ b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/skip_cth.erl @@ -0,0 +1,182 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2010-2016. All Rights Reserved. +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. +%% +%% %CopyrightEnd% +%% + + +-module(skip_cth). + + +-include_lib("common_test/src/ct_util.hrl"). +-include_lib("common_test/include/ct_event.hrl"). + +%% Send a cth_error event if a callback is called with unexpected arguments +-define(fail(Info), + gen_event:notify( + ?CT_EVMGR_REF, + #event{ name = cth_error, + node = node(), + data = {illegal_hook_callback,{?MODULE,?FUNCTION_NAME,Info}}})). + +%% CT Hooks +-compile(export_all). + +id(Opts) -> + empty_cth:id(Opts). + +init(Id, Opts) -> + empty_cth:init(Id, Opts). + +pre_init_per_suite(Suite, Config, State) -> + Suite==skip_init_SUITE + orelse Suite==skip_group_SUITE + orelse Suite==skip_case_SUITE + orelse Suite==seq_SUITE + orelse Suite==repeat_SUITE + orelse Suite==config_clash_SUITE + orelse ?fail(Suite), + empty_cth:pre_init_per_suite(Suite,Config,State). + +post_init_per_suite(Suite,Config,Return,State) -> + Suite==skip_init_SUITE + orelse Suite==skip_group_SUITE + orelse Suite==skip_case_SUITE + orelse Suite==seq_SUITE + orelse Suite==repeat_SUITE + orelse Suite==config_clash_SUITE + orelse ?fail(Suite), + empty_cth:post_init_per_suite(Suite,Config,Return,State). + +pre_end_per_suite(Suite,Config,State) -> + Suite==skip_case_SUITE + orelse Suite==skip_group_SUITE + orelse Suite==seq_SUITE + orelse Suite==repeat_SUITE + orelse Suite==config_clash_SUITE + orelse ?fail(Suite), + empty_cth:pre_end_per_suite(Suite,Config,State). + +post_end_per_suite(Suite,Config,Return,State) -> + Suite==skip_case_SUITE + orelse Suite==skip_group_SUITE + orelse Suite==seq_SUITE + orelse Suite==repeat_SUITE + orelse Suite==config_clash_SUITE + orelse ?fail(Suite), + empty_cth:post_end_per_suite(Suite,Config,Return,State). + +pre_init_per_group(Suite,Group,Config,State) -> + (Suite==skip_group_SUITE andalso Group==test_group_3) + orelse ?fail({Suite,Group}), + empty_cth:pre_init_per_group(Suite,Group,Config,State). + +post_init_per_group(Suite,Group,Config,Return,State) -> + (Suite==skip_group_SUITE andalso Group==test_group_3) + orelse ?fail({Suite,Group}), + empty_cth:post_init_per_group(Suite,Group,Config,Return,State). + +pre_end_per_group(Suite,Group,Config,State) -> + ?fail({Suite,Group}), + empty_cth:pre_end_per_group(Suite,Group,Config,State). + +post_end_per_group(Suite,Group,Config,Return,State) -> + ?fail({Suite,Group}), + empty_cth:post_end_per_group(Suite,Group,Config,Return,State). + +pre_init_per_testcase(Suite,TC,Config,State) -> + (Suite==skip_case_SUITE andalso (TC==skip_in_init + orelse TC==fail_in_init + orelse TC==exit_in_init + orelse TC==fail_in_end + orelse TC==exit_in_end + orelse TC==skip_in_case)) + orelse (Suite==seq_SUITE andalso TC==test_case_1) + orelse (Suite==repeat_SUITE andalso TC==test_case_1) + orelse ?fail({Suite,TC}), + empty_cth:pre_init_per_testcase(Suite,TC,Config,State). + +post_init_per_testcase(Suite,TC,Config,Return,State) -> + (Suite==skip_case_SUITE andalso (TC==skip_in_init + orelse TC==fail_in_init + orelse TC==exit_in_init + orelse TC==fail_in_end + orelse TC==exit_in_end + orelse TC==skip_in_case)) + orelse (Suite==seq_SUITE andalso TC==test_case_1) + orelse (Suite==repeat_SUITE andalso TC==test_case_1) + orelse ?fail({Suite,TC}), + empty_cth:post_init_per_testcase(Suite,TC,Config,Return,State). + +pre_end_per_testcase(Suite,TC,Config,State) -> + (Suite==skip_case_SUITE andalso (TC==skip_in_case + orelse TC==fail_in_end + orelse TC==exit_in_end)) + orelse (Suite==seq_SUITE andalso TC==test_case_1) + orelse (Suite==repeat_SUITE andalso TC==test_case_1) + orelse ?fail({Suite,TC}), + empty_cth:pre_end_per_testcase(Suite,TC,Config,State). + +post_end_per_testcase(Suite,TC,Config,Return,State) -> + (Suite==skip_case_SUITE andalso (TC==skip_in_case + orelse TC==fail_in_end + orelse TC==exit_in_end)) + orelse (Suite==seq_SUITE andalso TC==test_case_1) + orelse (Suite==repeat_SUITE andalso TC==test_case_1) + orelse ?fail({Suite,TC}), + empty_cth:post_end_per_testcase(Suite,TC,Config,Return,State). + +on_tc_fail(Suite,TC,Reason,State) -> + (Suite==seq_SUITE andalso TC==test_case_1) + orelse (Suite==config_clash_SUITE andalso TC==test_case_1) + orelse ?fail({Suite,TC}), + empty_cth:on_tc_fail(Suite,TC,Reason,State). + +on_tc_skip(all_hook_callbacks_SUITE=Suite,all=TC, Reason, State) -> + empty_cth:on_tc_skip(Suite,TC,Reason,State); +on_tc_skip(Suite,TC,Reason,State) + when (Suite==skip_init_SUITE + orelse Suite==skip_req_SUITE + orelse Suite==skip_fail_SUITE) + andalso + (TC==init_per_suite + orelse TC==test_case + orelse TC==end_per_suite) -> + empty_cth:on_tc_skip(Suite,TC,Reason,State); +on_tc_skip(skip_group_SUITE=Suite,TC={C,G},Reason,State) + when (C==init_per_group orelse C==test_case orelse C==end_per_group) andalso + (G==test_group_1 orelse G==test_group_2 orelse G==test_group_3) -> + empty_cth:on_tc_skip(Suite,TC,Reason,State); +on_tc_skip(skip_case_SUITE=Suite,TC,Reason,State) + when TC==skip_in_spec; + TC==skip_in_init; + TC==fail_in_init; + TC==exit_in_init; + TC==skip_in_case; + TC==req_auto_skip; + TC==fail_auto_skip -> + empty_cth:on_tc_skip(Suite,TC,Reason,State); +on_tc_skip(Suite,TC,Reason,State) + when (Suite==seq_SUITE andalso TC==test_case_2) + orelse (Suite==repeat_SUITE andalso TC==test_case_2) -> + empty_cth:on_tc_skip(Suite,TC,Reason,State); +on_tc_skip(Suite,TC,Reason,State) -> + ?fail({Suite,TC}), + empty_cth:on_tc_skip(Suite,TC,Reason,State). + +terminate(State) -> + empty_cth:terminate(State). diff --git a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/skip_fail_SUITE.erl b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/skip_fail_SUITE.erl new file mode 100644 index 0000000000..9f5dfee6b9 --- /dev/null +++ b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/skip_fail_SUITE.erl @@ -0,0 +1,53 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2010-2016. All Rights Reserved. +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. +%% +%% %CopyrightEnd% +%% + +-module(skip_fail_SUITE). + +-compile(export_all). + +-include("ct.hrl"). + +suite() -> + faulty_return_value. + +init_per_suite(Config) -> + Config. + +end_per_suite(Config) -> + ok. + +init_per_group(_,Config) -> + Config. + +end_per_group(_,_) -> + ok. + +init_per_testcase(_,Config) -> + Config. + +end_per_testcase(_,_) -> + ok. + +all() -> + [test_case]. + +%% Test cases starts here. +test_case(Config) -> + ok. diff --git a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/skip_group_SUITE.erl b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/skip_group_SUITE.erl new file mode 100644 index 0000000000..d3b848bfbd --- /dev/null +++ b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/skip_group_SUITE.erl @@ -0,0 +1,64 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2010-2016. All Rights Reserved. +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. +%% +%% %CopyrightEnd% +%% + +-module(skip_group_SUITE). + +-compile(export_all). + +-include("ct.hrl"). + +suite() -> + []. + +init_per_suite(Config) -> + Config. + +end_per_suite(Config) -> + ok. + +group(test_group_1) -> + [{require,whatever}]; +group(test_group_2) -> + faulty_return_value; +group(_) -> + []. + +init_per_group(test_group_3,Config) -> + {skip,"Skipped in init_per_group/2"}; +init_per_group(_,Config) -> + ct:fail("This shall never be run due to auto_skip from group/1"). + +end_per_group(_,_) -> + ct:fail("This shall never be run"). + +all() -> + [{group,test_group_1}, + {group,test_group_2}, + {group,test_group_3}]. + +groups() -> + [{test_group_1,[test_case]}, + {test_group_2,[test_case]}, + {test_group_3,[test_case]}]. + +%% Test cases starts here. +test_case(_Config) -> + ct:fail("This test case shall never be run due to skip on group level"). + diff --git a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/skip_init_SUITE.erl b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/skip_init_SUITE.erl new file mode 100644 index 0000000000..70305421ac --- /dev/null +++ b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/skip_init_SUITE.erl @@ -0,0 +1,53 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2010-2016. All Rights Reserved. +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. +%% +%% %CopyrightEnd% +%% + +-module(skip_init_SUITE). + +-compile(export_all). + +-include("ct.hrl"). + +suite() -> + []. + +init_per_suite(Config) -> + {skip,"Skipped in init_per_suite/1"}. + +end_per_suite(Config) -> + ok. + +init_per_group(_,Config) -> + Config. + +end_per_group(_,_) -> + ok. + +init_per_testcase(_,Config) -> + Config. + +end_per_testcase(_,_) -> + ok. + +all() -> + [test_case]. + +%% Test cases starts here. +test_case(Config) -> + ok. diff --git a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/skip_post_suite_cth.erl b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/skip_post_suite_cth.erl index d5b347e723..48a2d70e22 100644 --- a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/skip_post_suite_cth.erl +++ b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/skip_post_suite_cth.erl @@ -45,35 +45,35 @@ pre_end_per_suite(Suite,Config,State) -> post_end_per_suite(Suite,Config,Return,State) -> empty_cth:post_end_per_suite(Suite,Config,Return,State). -pre_init_per_group(Group,Config,State) -> - empty_cth:pre_init_per_group(Group,Config,State). +pre_init_per_group(Suite,Group,Config,State) -> + empty_cth:pre_init_per_group(Suite,Group,Config,State). -post_init_per_group(Group,Config,Return,State) -> - empty_cth:post_init_per_group(Group,Config,Return,State). +post_init_per_group(Suite,Group,Config,Return,State) -> + empty_cth:post_init_per_group(Suite,Group,Config,Return,State). -pre_end_per_group(Group,Config,State) -> - empty_cth:pre_end_per_group(Group,Config,State). +pre_end_per_group(Suite,Group,Config,State) -> + empty_cth:pre_end_per_group(Suite,Group,Config,State). -post_end_per_group(Group,Config,Return,State) -> - empty_cth:post_end_per_group(Group,Config,Return,State). +post_end_per_group(Suite,Group,Config,Return,State) -> + empty_cth:post_end_per_group(Suite,Group,Config,Return,State). -pre_init_per_testcase(TC,Config,State) -> - empty_cth:pre_init_per_testcase(TC,Config,State). +pre_init_per_testcase(Suite,TC,Config,State) -> + empty_cth:pre_init_per_testcase(Suite,TC,Config,State). -post_init_per_testcase(TC,Config,Return,State) -> - empty_cth:post_init_per_testcase(TC,Config,Return,State). +post_init_per_testcase(Suite,TC,Config,Return,State) -> + empty_cth:post_init_per_testcase(Suite,TC,Config,Return,State). -pre_end_per_testcase(TC,Config,State) -> - empty_cth:pre_end_per_testcase(TC,Config,State). +pre_end_per_testcase(Suite,TC,Config,State) -> + empty_cth:pre_end_per_testcase(Suite,TC,Config,State). -post_end_per_testcase(TC,Config,Return,State) -> - empty_cth:post_end_per_testcase(TC,Config,Return,State). +post_end_per_testcase(Suite,TC,Config,Return,State) -> + empty_cth:post_end_per_testcase(Suite,TC,Config,Return,State). -on_tc_fail(TC, Reason, State) -> - empty_cth:on_tc_fail(TC,Reason,State). +on_tc_fail(Suite,TC, Reason, State) -> + empty_cth:on_tc_fail(Suite,TC,Reason,State). -on_tc_skip(TC, Reason, State) -> - empty_cth:on_tc_skip(TC,Reason,State). +on_tc_skip(Suite,TC, Reason, State) -> + empty_cth:on_tc_skip(Suite,TC,Reason,State). terminate(State) -> empty_cth:terminate(State). diff --git a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/skip_pre_end_cth.erl b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/skip_pre_end_cth.erl index 36abac0bf8..d638954d3c 100644 --- a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/skip_pre_end_cth.erl +++ b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/skip_pre_end_cth.erl @@ -46,36 +46,36 @@ pre_end_per_suite(Suite,Config,State) -> post_end_per_suite(Suite,Config,Return,State) -> empty_cth:post_end_per_suite(Suite,Config,Return,State). -pre_init_per_group(Group,Config,State) -> - empty_cth:pre_init_per_group(Group,Config,State). +pre_init_per_group(Suite,Group,Config,State) -> + empty_cth:pre_init_per_group(Suite,Group,Config,State). -post_init_per_group(Group,Config,Return,State) -> - empty_cth:post_init_per_group(Group,Config,Return,State). +post_init_per_group(Suite,Group,Config,Return,State) -> + empty_cth:post_init_per_group(Suite,Group,Config,Return,State). -pre_end_per_group(Group,Config,State) -> - empty_cth:pre_end_per_group(Group,Config,State), +pre_end_per_group(Suite,Group,Config,State) -> + empty_cth:pre_end_per_group(Suite,Group,Config,State), {{skip, "Test skip"}, State}. -post_end_per_group(Group,Config,Return,State) -> - empty_cth:post_end_per_group(Group,Config,Return,State). +post_end_per_group(Suite,Group,Config,Return,State) -> + empty_cth:post_end_per_group(Suite,Group,Config,Return,State). -pre_init_per_testcase(TC,Config,State) -> - empty_cth:pre_init_per_testcase(TC,Config,State). +pre_init_per_testcase(Suite,TC,Config,State) -> + empty_cth:pre_init_per_testcase(Suite,TC,Config,State). -post_init_per_testcase(TC,Config,Return,State) -> - empty_cth:post_init_per_testcase(TC,Config,Return,State). +post_init_per_testcase(Suite,TC,Config,Return,State) -> + empty_cth:post_init_per_testcase(Suite,TC,Config,Return,State). -pre_end_per_testcase(TC,Config,State) -> - empty_cth:pre_end_per_testcase(TC,Config,State). +pre_end_per_testcase(Suite,TC,Config,State) -> + empty_cth:pre_end_per_testcase(Suite,TC,Config,State). -post_end_per_testcase(TC,Config,Return,State) -> - empty_cth:post_end_per_testcase(TC,Config,Return,State). +post_end_per_testcase(Suite,TC,Config,Return,State) -> + empty_cth:post_end_per_testcase(Suite,TC,Config,Return,State). -on_tc_fail(TC, Reason, State) -> - empty_cth:on_tc_fail(TC,Reason,State). +on_tc_fail(Suite,TC, Reason, State) -> + empty_cth:on_tc_fail(Suite,TC,Reason,State). -on_tc_skip(TC, Reason, State) -> - empty_cth:on_tc_skip(TC,Reason,State). +on_tc_skip(Suite,TC, Reason, State) -> + empty_cth:on_tc_skip(Suite,TC,Reason,State). terminate(State) -> empty_cth:terminate(State). diff --git a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/skip_pre_init_tc_cth.erl b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/skip_pre_init_tc_cth.erl new file mode 100644 index 0000000000..e1d261d59a --- /dev/null +++ b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/skip_pre_init_tc_cth.erl @@ -0,0 +1,79 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2010-2016. All Rights Reserved. +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. +%% +%% %CopyrightEnd% +%% + + +-module(skip_pre_init_tc_cth). + + +-include_lib("common_test/src/ct_util.hrl"). +-include_lib("common_test/include/ct_event.hrl"). + + +%% CT Hooks +-compile(export_all). + +init(Id, Opts) -> + empty_cth:init(Id, Opts). + +pre_init_per_suite(Suite, Config, State) -> + empty_cth:pre_init_per_suite(Suite,Config,State). + +post_init_per_suite(Suite,Config,Return,State) -> + empty_cth:post_init_per_suite(Suite,Config,Return,State). + +pre_end_per_suite(Suite,Config,State) -> + empty_cth:pre_end_per_suite(Suite,Config,State). + +post_end_per_suite(Suite,Config,Return,State) -> + empty_cth:post_end_per_suite(Suite,Config,Return,State). + +pre_init_per_group(Suite,Group,Config,State) -> + empty_cth:pre_init_per_group(Suite,Group,Config,State). + +post_init_per_group(Suite,Group,Config,Return,State) -> + empty_cth:post_init_per_group(Suite,Group,Config,Return,State). + +pre_end_per_group(Suite,Group,Config,State) -> + empty_cth:pre_end_per_group(Suite,Group,Config,State). + +post_end_per_group(Suite,Group,Config,Return,State) -> + empty_cth:post_end_per_group(Suite,Group,Config,Return,State). + +pre_init_per_testcase(Suite,TC,Config,State) -> + empty_cth:pre_init_per_testcase(Suite,TC,Config,State), + {{skip, "Skipped in pre_init_per_testcase"}, State}. + +post_init_per_testcase(Suite,TC,Config,Return,State) -> + empty_cth:post_init_per_testcase(Suite,TC,Config,Return,State). + +pre_end_per_testcase(Suite,TC,Config,State) -> + empty_cth:pre_end_per_testcase(Suite,TC,Config,State). + +post_end_per_testcase(Suite,TC,Config,Return,State) -> + empty_cth:post_end_per_testcase(Suite,TC,Config,Return,State). + +on_tc_fail(Suite,TC, Reason, State) -> + empty_cth:on_tc_fail(Suite,TC,Reason,State). + +on_tc_skip(Suite,TC, Reason, State) -> + empty_cth:on_tc_skip(Suite,TC,Reason,State). + +terminate(State) -> + empty_cth:terminate(State). diff --git a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/skip_pre_suite_cth.erl b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/skip_pre_suite_cth.erl index fa510b2d54..d7b07ee33c 100644 --- a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/skip_pre_suite_cth.erl +++ b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/skip_pre_suite_cth.erl @@ -46,35 +46,35 @@ pre_end_per_suite(Suite,Config,State) -> post_end_per_suite(Suite,Config,Return,State) -> empty_cth:post_end_per_suite(Suite,Config,Return,State). -pre_init_per_group(Group,Config,State) -> - empty_cth:pre_init_per_group(Group,Config,State). +pre_init_per_group(Suite,Group,Config,State) -> + empty_cth:pre_init_per_group(Suite,Group,Config,State). -post_init_per_group(Group,Config,Return,State) -> - empty_cth:post_init_per_group(Group,Config,Return,State). +post_init_per_group(Suite,Group,Config,Return,State) -> + empty_cth:post_init_per_group(Suite,Group,Config,Return,State). -pre_end_per_group(Group,Config,State) -> - empty_cth:pre_end_per_group(Group,Config,State). +pre_end_per_group(Suite,Group,Config,State) -> + empty_cth:pre_end_per_group(Suite,Group,Config,State). -post_end_per_group(Group,Config,Return,State) -> - empty_cth:post_end_per_group(Group,Config,Return,State). +post_end_per_group(Suite,Group,Config,Return,State) -> + empty_cth:post_end_per_group(Suite,Group,Config,Return,State). -pre_init_per_testcase(TC,Config,State) -> - empty_cth:pre_init_per_testcase(TC,Config,State). +pre_init_per_testcase(Suite,TC,Config,State) -> + empty_cth:pre_init_per_testcase(Suite,TC,Config,State). -post_init_per_testcase(TC,Config,Return,State) -> - empty_cth:post_init_per_testcase(TC,Config,Return,State). +post_init_per_testcase(Suite,TC,Config,Return,State) -> + empty_cth:post_init_per_testcase(Suite,TC,Config,Return,State). -pre_end_per_testcase(TC,Config,State) -> - empty_cth:pre_end_per_testcase(TC,Config,State). +pre_end_per_testcase(Suite,TC,Config,State) -> + empty_cth:pre_end_per_testcase(Suite,TC,Config,State). -post_end_per_testcase(TC,Config,Return,State) -> - empty_cth:post_end_per_testcase(TC,Config,Return,State). +post_end_per_testcase(Suite,TC,Config,Return,State) -> + empty_cth:post_end_per_testcase(Suite,TC,Config,Return,State). -on_tc_fail(TC, Reason, State) -> - empty_cth:on_tc_fail(TC,Reason,State). +on_tc_fail(Suite,TC, Reason, State) -> + empty_cth:on_tc_fail(Suite,TC,Reason,State). -on_tc_skip(TC, Reason, State) -> - empty_cth:on_tc_skip(TC,Reason,State). +on_tc_skip(Suite,TC, Reason, State) -> + empty_cth:on_tc_skip(Suite,TC,Reason,State). terminate(State) -> empty_cth:terminate(State). diff --git a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/skip_req_SUITE.erl b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/skip_req_SUITE.erl new file mode 100644 index 0000000000..bc69dd5ea4 --- /dev/null +++ b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/skip_req_SUITE.erl @@ -0,0 +1,53 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2010-2016. All Rights Reserved. +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. +%% +%% %CopyrightEnd% +%% + +-module(skip_req_SUITE). + +-compile(export_all). + +-include("ct.hrl"). + +suite() -> + [{require,whatever}]. + +init_per_suite(Config) -> + Config. + +end_per_suite(Config) -> + ok. + +init_per_group(_,Config) -> + Config. + +end_per_group(_,_) -> + ok. + +init_per_testcase(_,Config) -> + Config. + +end_per_testcase(_,_) -> + ok. + +all() -> + [test_case]. + +%% Test cases starts here. +test_case(Config) -> + ok. diff --git a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/state_update_cth.erl b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/state_update_cth.erl index 7ec0d458b6..c6e0419c50 100644 --- a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/state_update_cth.erl +++ b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/state_update_cth.erl @@ -48,44 +48,44 @@ post_end_per_suite(Suite,Config,Return,State) -> empty_cth:post_end_per_suite(Suite,Config,Return,State), {Return, [post_end_per_suite|State]}. -pre_init_per_group(Group,Config,State) -> - empty_cth:pre_init_per_group(Group,Config,State), +pre_init_per_group(Suite,Group,Config,State) -> + empty_cth:pre_init_per_group(Suite,Group,Config,State), {Config, [pre_init_per_group|State]}. -post_init_per_group(Group,Config,Return,State) -> - empty_cth:post_init_per_group(Group,Config,Return,State), +post_init_per_group(Suite,Group,Config,Return,State) -> + empty_cth:post_init_per_group(Suite,Group,Config,Return,State), {Return, [post_init_per_group|State]}. -pre_end_per_group(Group,Config,State) -> - empty_cth:pre_end_per_group(Group,Config,State), +pre_end_per_group(Suite,Group,Config,State) -> + empty_cth:pre_end_per_group(Suite,Group,Config,State), {Config, [pre_end_per_group|State]}. -post_end_per_group(Group,Config,Return,State) -> - empty_cth:post_end_per_group(Group,Config,Return,State), +post_end_per_group(Suite,Group,Config,Return,State) -> + empty_cth:post_end_per_group(Suite,Group,Config,Return,State), {Return, [post_end_per_group|State]}. -pre_init_per_testcase(TC,Config,State) -> - empty_cth:pre_init_per_testcase(TC,Config,State), +pre_init_per_testcase(Suite,TC,Config,State) -> + empty_cth:pre_init_per_testcase(Suite,TC,Config,State), {Config, [pre_init_per_testcase|State]}. -post_init_per_testcase(TC,Config,Return,State) -> - empty_cth:post_init_per_testcase(TC,Config,Return,State), +post_init_per_testcase(Suite,TC,Config,Return,State) -> + empty_cth:post_init_per_testcase(Suite,TC,Config,Return,State), {Return, [post_init_per_testcase|State]}. -pre_end_per_testcase(TC,Config,State) -> - empty_cth:pre_end_per_testcase(TC,Config,State), +pre_end_per_testcase(Suite,TC,Config,State) -> + empty_cth:pre_end_per_testcase(Suite,TC,Config,State), {Config, [pre_end_per_testcase|State]}. -post_end_per_testcase(TC,Config,Return,State) -> - empty_cth:post_end_per_testcase(TC,Config,Return,State), +post_end_per_testcase(Suite,TC,Config,Return,State) -> + empty_cth:post_end_per_testcase(Suite,TC,Config,Return,State), {Return, [post_end_per_testcase|State]}. -on_tc_fail(TC, Reason, State) -> - empty_cth:on_tc_fail(TC,Reason,State), +on_tc_fail(Suite,TC, Reason, State) -> + empty_cth:on_tc_fail(Suite,TC,Reason,State), [on_tc_fail|State]. -on_tc_skip(TC, Reason, State) -> - empty_cth:on_tc_skip(TC,Reason,State), +on_tc_skip(Suite,TC, Reason, State) -> + empty_cth:on_tc_skip(Suite,TC,Reason,State), [on_tc_skip|State]. terminate(State) -> diff --git a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/undef_cth.erl b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/undef_cth.erl index 2b9e726819..10a7047899 100644 --- a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/undef_cth.erl +++ b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/undef_cth.erl @@ -44,35 +44,35 @@ pre_end_per_suite(Suite,Config,State) -> post_end_per_suite(Suite,Config,Return,State) -> empty_cth:post_end_per_suite(Suite,Config,Return,State). -pre_init_per_group(Group,Config,State) -> - empty_cth:pre_init_per_group(Group,Config,State). +pre_init_per_group(Suite,Group,Config,State) -> + empty_cth:pre_init_per_group(Suite,Group,Config,State). -post_init_per_group(Group,Config,Return,State) -> - empty_cth:post_init_per_group(Group,Config,Return,State). +post_init_per_group(Suite,Group,Config,Return,State) -> + empty_cth:post_init_per_group(Suite,Group,Config,Return,State). -pre_end_per_group(Group,Config,State) -> - empty_cth:pre_end_per_group(Group,Config,State). +pre_end_per_group(Suite,Group,Config,State) -> + empty_cth:pre_end_per_group(Suite,Group,Config,State). -post_end_per_group(Group,Config,Return,State) -> - empty_cth:post_end_per_group(Group,Config,Return,State). +post_end_per_group(Suite,Group,Config,Return,State) -> + empty_cth:post_end_per_group(Suite,Group,Config,Return,State). -pre_init_per_testcase(TC,Config,State) -> - empty_cth:pre_init_per_testcase(TC,Config,State). +pre_init_per_testcase(Suite,TC,Config,State) -> + empty_cth:pre_init_per_testcase(Suite,TC,Config,State). -post_init_per_testcase(TC,Config,Return,State) -> - empty_cth:post_init_per_testcase(TC,Config,Return,State). +post_init_per_testcase(Suite,TC,Config,Return,State) -> + empty_cth:post_init_per_testcase(Suite,TC,Config,Return,State). -pre_end_per_testcase(TC,Config,State) -> - empty_cth:pre_end_per_testcase(TC,Config,State). +pre_end_per_testcase(Suite,TC,Config,State) -> + empty_cth:pre_end_per_testcase(Suite,TC,Config,State). -post_end_per_testcase(TC,Config,Return,State) -> - empty_cth:post_end_per_testcase(TC,Config,Return,State). +post_end_per_testcase(Suite,TC,Config,Return,State) -> + empty_cth:post_end_per_testcase(Suite,TC,Config,Return,State). -on_tc_fail(TC, Reason, State) -> - empty_cth:on_tc_fail(TC,Reason,State). +on_tc_fail(Suite,TC, Reason, State) -> + empty_cth:on_tc_fail(Suite,TC,Reason,State). -on_tc_skip(TC, Reason, State) -> - empty_cth:on_tc_skip(TC,Reason,State). +on_tc_skip(Suite,TC, Reason, State) -> + empty_cth:on_tc_skip(Suite,TC,Reason,State). terminate(State) -> empty_cth:terminate(State). diff --git a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/update_config_cth.erl b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/update_config_cth.erl index d48981f667..f933c7702e 100644 --- a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/update_config_cth.erl +++ b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/update_config_cth.erl @@ -50,43 +50,43 @@ post_end_per_suite(Suite,Config,Return,State) -> NewConfig = [{post_end_per_suite,?now}|Config], {NewConfig,NewConfig}. -pre_init_per_group(Group,Config,State) -> - empty_cth:pre_init_per_group(Group,Config,State), +pre_init_per_group(Suite, Group,Config,State) -> + empty_cth:pre_init_per_group(Suite,Group,Config,State), {[{pre_init_per_group,?now}|Config],State}. -post_init_per_group(Group,Config,Return,State) -> - empty_cth:post_init_per_group(Group,Config,Return,State), +post_init_per_group(Suite,Group,Config,Return,State) -> + empty_cth:post_init_per_group(Suite,Group,Config,Return,State), {[{post_init_per_group,?now}|Return],State}. -pre_end_per_group(Group,Config,State) -> - empty_cth:pre_end_per_group(Group,Config,State), +pre_end_per_group(Suite,Group,Config,State) -> + empty_cth:pre_end_per_group(Suite,Group,Config,State), {[{pre_end_per_group,?now}|Config],State}. -post_end_per_group(Group,Config,Return,State) -> - empty_cth:post_end_per_group(Group,Config,Return,State), +post_end_per_group(Suite,Group,Config,Return,State) -> + empty_cth:post_end_per_group(Suite,Group,Config,Return,State), {[{post_end_per_group,?now}|Config],State}. -pre_init_per_testcase(TC,Config,State) -> - empty_cth:pre_init_per_testcase(TC,Config,State), +pre_init_per_testcase(Suite,TC,Config,State) -> + empty_cth:pre_init_per_testcase(Suite,TC,Config,State), {[{pre_init_per_testcase,?now}|Config],State}. -post_init_per_testcase(TC,Config,Return,State) -> - empty_cth:post_init_per_testcase(TC,Config,Return,State), +post_init_per_testcase(Suite,TC,Config,Return,State) -> + empty_cth:post_init_per_testcase(Suite,TC,Config,Return,State), {[{post_init_per_testcase,?now}|Config],State}. -pre_end_per_testcase(TC,Config,State) -> - empty_cth:pre_end_per_testcase(TC,Config,State), +pre_end_per_testcase(Suite,TC,Config,State) -> + empty_cth:pre_end_per_testcase(Suite,TC,Config,State), {[{pre_end_per_testcase,?now}|Config],State}. -post_end_per_testcase(TC,Config,Return,State) -> - empty_cth:post_end_per_testcase(TC,Config,Return,State), +post_end_per_testcase(Suite,TC,Config,Return,State) -> + empty_cth:post_end_per_testcase(Suite,TC,Config,Return,State), {[{post_end_per_testcase,?now}|Config],State}. -on_tc_fail(TC, Reason, State) -> - empty_cth:on_tc_fail(TC,Reason,State). +on_tc_fail(Suite,TC, Reason, State) -> + empty_cth:on_tc_fail(Suite,TC,Reason,State). -on_tc_skip(TC, Reason, State) -> - empty_cth:on_tc_skip(TC,Reason,State). +on_tc_skip(Suite,TC, Reason, State) -> + empty_cth:on_tc_skip(Suite,TC,Reason,State). terminate(State) -> empty_cth:terminate(State). diff --git a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/verify_config_cth.erl b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/verify_config_cth.erl index 71d84781e0..b29256a77e 100644 --- a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/verify_config_cth.erl +++ b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/verify_config_cth.erl @@ -60,37 +60,37 @@ post_end_per_suite(Suite,Config,Return,State) -> ct_no_config_SUITE = ct:get_config(suite_cfg), empty_cth:post_end_per_suite(Suite,Config,Return,State). -pre_init_per_group(Group,Config,State) -> +pre_init_per_group(Suite,Group,Config,State) -> true = ?val(post_init_per_suite, Config), ct_no_config_SUITE = ct:get_config(suite_cfg), test_group = ct:get_config(group_cfg), - empty_cth:pre_init_per_group(Group, + empty_cth:pre_init_per_group(Suite,Group, [{pre_init_per_group,true} | Config], State). -post_init_per_group(Group,Config,Return,State) -> +post_init_per_group(Suite,Group,Config,Return,State) -> true = ?val(pre_init_per_group, Return), test_group = ct:get_config(group_cfg), - empty_cth:post_init_per_group(Group, + empty_cth:post_init_per_group(Suite,Group, Config, [{post_init_per_group,true} | Return], State). -pre_end_per_group(Group,Config,State) -> +pre_end_per_group(Suite,Group,Config,State) -> true = ?val(post_init_per_group, Config), ct_no_config_SUITE = ct:get_config(suite_cfg), test_group = ct:get_config(group_cfg), - empty_cth:pre_end_per_group(Group, + empty_cth:pre_end_per_group(Suite,Group, [{pre_end_per_group,true} | Config], State). -post_end_per_group(Group,Config,Return,State) -> +post_end_per_group(Suite,Group,Config,Return,State) -> true = ?val(pre_end_per_group, Config), ct_no_config_SUITE = ct:get_config(suite_cfg), test_group = ct:get_config(group_cfg), - empty_cth:post_end_per_group(Group,Config,Return,State). + empty_cth:post_end_per_group(Suite,Group,Config,Return,State). -pre_init_per_testcase(TC,Config,State) -> +pre_init_per_testcase(Suite,TC,Config,State) -> true = ?val(post_init_per_suite, Config), case ?val(name, ?val(tc_group_properties, Config)) of undefined -> @@ -102,19 +102,19 @@ pre_init_per_testcase(TC,Config,State) -> ct_no_config_SUITE = ct:get_config(suite_cfg), CfgKey = list_to_atom(atom_to_list(TC) ++ "_cfg"), TC = ct:get_config(CfgKey), - empty_cth:pre_init_per_testcase(TC, + empty_cth:pre_init_per_testcase(Suite,TC, [{pre_init_per_testcase,true} | Config], State). %%! TODO: Verify Config also in post_init and pre_end! -post_init_per_testcase(TC,Config,Return,State) -> - empty_cth:post_init_per_testcase(TC,Config,Return,State). +post_init_per_testcase(Suite,TC,Config,Return,State) -> + empty_cth:post_init_per_testcase(Suite,TC,Config,Return,State). -pre_end_per_testcase(TC,Config,State) -> - empty_cth:pre_end_per_testcase(TC,Config,State). +pre_end_per_testcase(Suite,TC,Config,State) -> + empty_cth:pre_end_per_testcase(Suite,TC,Config,State). -post_end_per_testcase(TC,Config,Return,State) -> +post_end_per_testcase(Suite,TC,Config,Return,State) -> true = ?val(post_init_per_suite, Config), true = ?val(pre_init_per_testcase, Config), case ?val(name, ?val(tc_group_properties, Config)) of @@ -127,13 +127,13 @@ post_end_per_testcase(TC,Config,Return,State) -> ct_no_config_SUITE = ct:get_config(suite_cfg), CfgKey = list_to_atom(atom_to_list(TC) ++ "_cfg"), TC = ct:get_config(CfgKey), - empty_cth:post_end_per_testcase(TC,Config,Return,State). + empty_cth:post_end_per_testcase(Suite,TC,Config,Return,State). -on_tc_fail(TC, Reason, State) -> - empty_cth:on_tc_fail(TC,Reason,State). +on_tc_fail(Suite,TC, Reason, State) -> + empty_cth:on_tc_fail(Suite,TC,Reason,State). -on_tc_skip(TC, Reason, State) -> - empty_cth:on_tc_skip(TC,Reason,State). +on_tc_skip(Suite,TC, Reason, State) -> + empty_cth:on_tc_skip(Suite,TC,Reason,State). terminate(State) -> empty_cth:terminate(State). diff --git a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/verify_data_dir_cth.erl b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/verify_data_dir_cth.erl index 9abd2e5e83..42e086b96e 100644 --- a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/verify_data_dir_cth.erl +++ b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/verify_data_dir_cth.erl @@ -62,43 +62,43 @@ post_end_per_suite(Suite,Config,Return,State) -> check_dirs(State,Config), empty_cth:post_end_per_suite(Suite,Config,Return,State). -pre_init_per_group(Group,Config,State) -> +pre_init_per_group(Suite,Group,Config,State) -> check_dirs(State,Config), - empty_cth:pre_init_per_group(Group,Config,State). + empty_cth:pre_init_per_group(Suite,Group,Config,State). -post_init_per_group(Group,Config,Return,State) -> +post_init_per_group(Suite,Group,Config,Return,State) -> check_dirs(State,Return), - empty_cth:post_init_per_group(Group,Config,Return,State). + empty_cth:post_init_per_group(Suite,Group,Config,Return,State). -pre_end_per_group(Group,Config,State) -> +pre_end_per_group(Suite,Group,Config,State) -> check_dirs(State,Config), - empty_cth:pre_end_per_group(Group,Config,State). + empty_cth:pre_end_per_group(Suite,Group,Config,State). -post_end_per_group(Group,Config,Return,State) -> +post_end_per_group(Suite,Group,Config,Return,State) -> check_dirs(State,Config), - empty_cth:post_end_per_group(Group,Config,Return,State). + empty_cth:post_end_per_group(Suite,Group,Config,Return,State). -pre_init_per_testcase(TC,Config,State) -> +pre_init_per_testcase(Suite,TC,Config,State) -> check_dirs(State,Config), - empty_cth:pre_init_per_testcase(TC,Config,State). + empty_cth:pre_init_per_testcase(Suite,TC,Config,State). -post_init_per_testcase(TC,Config,Return,State) -> +post_init_per_testcase(Suite,TC,Config,Return,State) -> check_dirs(State,Config), - empty_cth:post_init_per_testcase(TC,Config,Return,State). + empty_cth:post_init_per_testcase(Suite,TC,Config,Return,State). -pre_end_per_testcase(TC,Config,State) -> +pre_end_per_testcase(Suite,TC,Config,State) -> check_dirs(State,Config), - empty_cth:pre_end_per_testcase(TC,Config,State). + empty_cth:pre_end_per_testcase(Suite,TC,Config,State). -post_end_per_testcase(TC,Config,Return,State) -> +post_end_per_testcase(Suite,TC,Config,Return,State) -> check_dirs(State,Config), - empty_cth:post_end_per_testcase(TC,Config,Return,State). + empty_cth:post_end_per_testcase(Suite,TC,Config,Return,State). -on_tc_fail(TC, Reason, State) -> - empty_cth:on_tc_fail(TC,Reason,State). +on_tc_fail(Suite,TC, Reason, State) -> + empty_cth:on_tc_fail(Suite,TC,Reason,State). -on_tc_skip(TC, Reason, State) -> - empty_cth:on_tc_skip(TC,Reason,State). +on_tc_skip(Suite,TC, Reason, State) -> + empty_cth:on_tc_skip(Suite,TC,Reason,State). terminate(State) -> empty_cth:terminate(State). diff --git a/lib/common_test/test/ct_repeat_testrun_SUITE.erl b/lib/common_test/test/ct_repeat_testrun_SUITE.erl index f8b6a379f6..76611a2db3 100644 --- a/lib/common_test/test/ct_repeat_testrun_SUITE.erl +++ b/lib/common_test/test/ct_repeat_testrun_SUITE.erl @@ -363,14 +363,17 @@ skip_first_tc1(Suite) -> {?eh,tc_start,{Suite,tc1}}, {?eh,tc_done,{Suite,tc1,ok}}, {?eh,test_stats,{'_',0,{0,0}}}, + {?eh,tc_start,{Suite,tc2}}, {?eh,tc_done,{Suite,tc2,?skipped}}, {?eh,test_stats,{'_',0,{0,1}}}, + {?eh,tc_start,{Suite,{init_per_group,g,[]}}}, {?eh,tc_done,{Suite,{init_per_group,g,[]},?skipped}}, {?eh,tc_auto_skip,{Suite,{tc1,g},?skip_reason}}, {?eh,test_stats,{'_',0,{0,2}}}, {?eh,tc_auto_skip,{Suite,{tc2,g},?skip_reason}}, {?eh,test_stats,{'_',0,{0,3}}}, {?eh,tc_auto_skip,{Suite,{end_per_group,g},?skip_reason}}, + {?eh,tc_start,{Suite,tc2}}, {?eh,tc_done,{Suite,tc2,?skipped}}, {?eh,test_stats,{'_',0,{0,4}}}, {?eh,tc_start,{Suite,end_per_suite}}, @@ -390,10 +393,12 @@ skip_tc1_in_group(Suite) -> {?eh,tc_start,{Suite,tc1}}, {?eh,tc_done,{Suite,tc1,ok}}, {?eh,test_stats,{'_',0,{0,0}}}, + {?eh,tc_start,{Suite,tc2}}, {?eh,tc_done,{Suite,tc2,?skipped}}, {?eh,test_stats,{'_',0,{0,1}}}, {?eh,tc_start,{Suite,{end_per_group,g,[]}}}, {?eh,tc_done,{Suite,{end_per_group,g,[]},ok}}], + {?eh,tc_start,{Suite,tc2}}, {?eh,tc_done,{Suite,tc2,?skipped}}, {?eh,test_stats,{'_',0,{0,2}}}, {?eh,tc_start,{Suite,end_per_suite}}, diff --git a/lib/common_test/test/ct_surefire_SUITE.erl b/lib/common_test/test/ct_surefire_SUITE.erl index 42ec685c16..884217afc2 100644 --- a/lib/common_test/test/ct_surefire_SUITE.erl +++ b/lib/common_test/test/ct_surefire_SUITE.erl @@ -73,7 +73,9 @@ all() -> relative_path, url, logdir, - fail_pre_init_per_suite + fail_pre_init_per_suite, + skip_case_in_spec, + skip_suite_in_spec ]. %%-------------------------------------------------------------------- @@ -119,6 +121,18 @@ fail_pre_init_per_suite(Config) when is_list(Config) -> run(fail_pre_init_per_suite,[fail_pre_init_per_suite, {cth_surefire,[{path,Path}]}],Path,Config,[],Suites). +skip_case_in_spec(Config) -> + DataDir = ?config(data_dir,Config), + Spec = filename:join(DataDir,"skip_one_case.spec"), + Path = "skip_case_in_spec.xml", + run_spec(skip_case_in_spec,[{cth_surefire,[{path,Path}]}],Path,Config,Spec). + +skip_suite_in_spec(Config) -> + DataDir = ?config(data_dir,Config), + Spec = filename:join(DataDir,"skip_one_suite.spec"), + Path = "skip_suite_in_spec.xml", + run_spec(skip_suite_in_spec,[{cth_surefire,[{path,Path}]}],Path,Config,Spec). + %%%----------------------------------------------------------------- %%% HELP FUNCTIONS %%%----------------------------------------------------------------- @@ -129,8 +143,15 @@ run(Case,CTHs,Report,Config,ExtraOpts) -> Suite = filename:join(DataDir, "surefire_SUITE"), run(Case,CTHs,Report,Config,ExtraOpts,Suite). run(Case,CTHs,Report,Config,ExtraOpts,Suite) -> - {Opts,ERPid} = setup([{suite,Suite},{ct_hooks,CTHs},{label,Case}|ExtraOpts], - Config), + Test = [{suite,Suite},{ct_hooks,CTHs},{label,Case}|ExtraOpts], + do_run(Case, Report, Test, Config). + +run_spec(Case,CTHs,Report,Config,Spec) -> + Test = [{spec,Spec},{ct_hooks,CTHs},{label,Case}], + do_run(Case, Report, Test, Config). + +do_run(Case, Report, Test, Config) -> + {Opts,ERPid} = setup(Test, Config), ok = execute(Case, Opts, ERPid, Config), LogDir = case lists:keyfind(logdir,1,Opts) of @@ -201,7 +222,10 @@ test_suite_events(pass_SUITE) -> {?eh,test_stats,{1,0,{0,0}}}, {?eh,tc_start,{ct_framework,end_per_suite}}, {?eh,tc_done,{ct_framework,end_per_suite,ok}}]; -test_suite_events(_) -> +test_suite_events(skip_all_surefire_SUITE) -> + [{?eh,tc_user_skip,{skip_all_surefire_SUITE,all,"skipped in spec"}}, + {?eh,test_stats,{0,0,{1,0}}}]; +test_suite_events(Test) -> [{?eh,tc_start,{surefire_SUITE,init_per_suite}}, {?eh,tc_done,{surefire_SUITE,init_per_suite,ok}}, {?eh,tc_start,{surefire_SUITE,tc_ok}}, @@ -210,46 +234,55 @@ test_suite_events(_) -> {?eh,tc_start,{surefire_SUITE,tc_fail}}, {?eh,tc_done,{surefire_SUITE,tc_fail, {failed,{error,{test_case_failed,"this test should fail"}}}}}, - {?eh,test_stats,{1,1,{0,0}}}, - {?eh,tc_start,{surefire_SUITE,tc_skip}}, - {?eh,tc_done,{surefire_SUITE,tc_skip,{skipped,"this test is skipped"}}}, - {?eh,test_stats,{1,1,{1,0}}}, - {?eh,tc_start,{surefire_SUITE,tc_autoskip_require}}, - {?eh,tc_done,{surefire_SUITE,tc_autoskip_require, - {auto_skipped,{require_failed,'_'}}}}, - {?eh,test_stats,{1,1,{1,1}}}, - [{?eh,tc_start,{surefire_SUITE,{init_per_group,g,[]}}}, - {?eh,tc_done,{surefire_SUITE,{init_per_group,g,[]},ok}}, - {?eh,tc_start,{surefire_SUITE,tc_ok}}, - {?eh,tc_done,{surefire_SUITE,tc_ok,ok}}, - {?eh,test_stats,{2,1,{1,1}}}, - {?eh,tc_start,{surefire_SUITE,tc_fail}}, - {?eh,tc_done,{surefire_SUITE,tc_fail, - {failed,{error,{test_case_failed,"this test should fail"}}}}}, - {?eh,test_stats,{2,2,{1,1}}}, - {?eh,tc_start,{surefire_SUITE,tc_skip}}, - {?eh,tc_done,{surefire_SUITE,tc_skip,{skipped,"this test is skipped"}}}, - {?eh,test_stats,{2,2,{2,1}}}, - {?eh,tc_start,{surefire_SUITE,tc_autoskip_require}}, - {?eh,tc_done,{surefire_SUITE,tc_autoskip_require, - {auto_skipped,{require_failed,'_'}}}}, - {?eh,test_stats,{2,2,{2,2}}}, - {?eh,tc_start,{surefire_SUITE,{end_per_group,g,[]}}}, - {?eh,tc_done,{surefire_SUITE,{end_per_group,g,[]},ok}}], - [{?eh,tc_start,{surefire_SUITE,{init_per_group,g_fail,[]}}}, - {?eh,tc_done,{surefire_SUITE,{init_per_group,g_fail,[]}, - {failed,{error,all_cases_should_be_skipped}}}}, - {?eh,tc_auto_skip,{surefire_SUITE,{tc_ok,g_fail}, - {failed, - {surefire_SUITE,init_per_group, - {'EXIT',all_cases_should_be_skipped}}}}}, - {?eh,test_stats,{2,2,{2,3}}}, - {?eh,tc_auto_skip,{surefire_SUITE,{end_per_group,g_fail}, - {failed, - {surefire_SUITE,init_per_group, - {'EXIT',all_cases_should_be_skipped}}}}}], - {?eh,tc_start,{surefire_SUITE,end_per_suite}}, - {?eh,tc_done,{surefire_SUITE,end_per_suite,ok}}]. + {?eh,test_stats,{1,1,{0,0}}}] ++ + tc_skip_events(Test,undefined) ++ + [{?eh,test_stats,{1,1,{1,0}}}, + {?eh,tc_start,{surefire_SUITE,tc_autoskip_require}}, + {?eh,tc_done,{surefire_SUITE,tc_autoskip_require, + {auto_skipped,{require_failed,'_'}}}}, + {?eh,test_stats,{1,1,{1,1}}}, + [{?eh,tc_start,{surefire_SUITE,{init_per_group,g,[]}}}, + {?eh,tc_done,{surefire_SUITE,{init_per_group,g,[]},ok}}, + {?eh,tc_start,{surefire_SUITE,tc_ok}}, + {?eh,tc_done,{surefire_SUITE,tc_ok,ok}}, + {?eh,test_stats,{2,1,{1,1}}}, + {?eh,tc_start,{surefire_SUITE,tc_fail}}, + {?eh,tc_done,{surefire_SUITE,tc_fail, + {failed,{error,{test_case_failed,"this test should fail"}}}}}, + {?eh,test_stats,{2,2,{1,1}}}] ++ + tc_skip_events(Test,g) ++ + [{?eh,test_stats,{2,2,{2,1}}}, + {?eh,tc_start,{surefire_SUITE,tc_autoskip_require}}, + {?eh,tc_done,{surefire_SUITE,tc_autoskip_require, + {auto_skipped,{require_failed,'_'}}}}, + {?eh,test_stats,{2,2,{2,2}}}, + {?eh,tc_start,{surefire_SUITE,{end_per_group,g,[]}}}, + {?eh,tc_done,{surefire_SUITE,{end_per_group,g,[]},ok}}], + [{?eh,tc_start,{surefire_SUITE,{init_per_group,g_fail,[]}}}, + {?eh,tc_done,{surefire_SUITE,{init_per_group,g_fail,[]}, + {failed,{error,all_cases_should_be_skipped}}}}, + {?eh,tc_auto_skip,{surefire_SUITE,{tc_ok,g_fail}, + {failed, + {surefire_SUITE,init_per_group, + {'EXIT',all_cases_should_be_skipped}}}}}, + {?eh,test_stats,{2,2,{2,3}}}, + {?eh,tc_auto_skip,{surefire_SUITE,{end_per_group,g_fail}, + {failed, + {surefire_SUITE,init_per_group, + {'EXIT',all_cases_should_be_skipped}}}}}], + {?eh,tc_start,{surefire_SUITE,end_per_suite}}, + {?eh,tc_done,{surefire_SUITE,end_per_suite,ok}}]. + +tc_skip_events(skip_case_in_spec,Group) -> + [{?eh,tc_user_skip,{surefire_SUITE,tc_skip_name(Group),"skipped in spec"}}]; +tc_skip_events(_Test,_Group) -> + [{?eh,tc_start,{surefire_SUITE,tc_skip}}, + {?eh,tc_done,{surefire_SUITE,tc_skip,{skipped,"this test is skipped"}}}]. + +tc_skip_name(undefined) -> + tc_skip; +tc_skip_name(Group) -> + {tc_skip,Group}. test_events(fail_pre_init_per_suite) -> [{?eh,start_logging,{'DEF','RUNDIR'}}, @@ -257,6 +290,10 @@ test_events(fail_pre_init_per_suite) -> test_suite_events(pass_SUITE) ++ test_suite_events(fail_SUITE, {1,0,{0,1}}) ++ [{?eh,stop_logging,[]}]; +test_events(skip_suite_in_spec) -> + [{?eh,start_logging,'_'},{?eh,start_info,{1,1,0}}] ++ + test_suite_events(skip_all_surefire_SUITE) ++ + [{?eh,stop_logging,[]}]; test_events(Test) -> [{?eh,start_logging,'_'}, {?eh,start_info,{1,1,9}}] ++ test_suite_events(Test) ++ @@ -364,6 +401,8 @@ failed_or_skipped([]) -> events_to_result(E) -> events_to_result(E, []). +events_to_result([{?eh,tc_user_skip,{_Suite,all,_}}|E], Result) -> + events_to_result(E, [[[s]]|Result]); events_to_result([{?eh,tc_auto_skip,{_Suite,init_per_suite,_}}|E], Result) -> {Suite,Rest} = events_to_result1(E), events_to_result(Rest, [[[s]|Suite]|Result]); @@ -382,7 +421,7 @@ events_to_result1([{?eh,tc_done,{_Suite, end_per_suite,R}}|E]) -> events_to_result1([{?eh,tc_done,{_Suite,_Case,R}}|E]) -> {Suite,Rest} = events_to_result1(E), {[result(R)|Suite],Rest}; -events_to_result1([{?eh,tc_auto_skip,_}|E]) -> +events_to_result1([{?eh,Skip,_}|E]) when Skip==tc_auto_skip; Skip==tc_user_skip -> {Suite,Rest} = events_to_result1(E), {[[s]|Suite],Rest}; events_to_result1([_|E]) -> diff --git a/lib/common_test/test/ct_surefire_SUITE_data/skip_one_case.spec b/lib/common_test/test/ct_surefire_SUITE_data/skip_one_case.spec new file mode 100644 index 0000000000..42df8a7d1a --- /dev/null +++ b/lib/common_test/test/ct_surefire_SUITE_data/skip_one_case.spec @@ -0,0 +1,2 @@ +{suites,".",surefire_SUITE}. +{skip_cases,".",surefire_SUITE,tc_skip,"skipped in spec"}. diff --git a/lib/common_test/test/ct_surefire_SUITE_data/skip_one_suite.spec b/lib/common_test/test/ct_surefire_SUITE_data/skip_one_suite.spec new file mode 100644 index 0000000000..57966328ab --- /dev/null +++ b/lib/common_test/test/ct_surefire_SUITE_data/skip_one_suite.spec @@ -0,0 +1,2 @@ +{suites,".",[skip_all_surefire_SUITE]}. +{skip_suites,".",skip_all_surefire_SUITE,"skipped in spec"}. diff --git a/lib/common_test/test/ct_test_server_if_1_SUITE.erl b/lib/common_test/test/ct_test_server_if_1_SUITE.erl index 228d900545..ea8a1a5662 100644 --- a/lib/common_test/test/ct_test_server_if_1_SUITE.erl +++ b/lib/common_test/test/ct_test_server_if_1_SUITE.erl @@ -161,6 +161,7 @@ test_events(ts_if_1) -> {?eh,tc_start,{ts_if_1_SUITE,tc4}}, {?eh,tc_done,{ts_if_1_SUITE,tc4,{failed,{error,failed_on_purpose}}}}, {?eh,test_stats,{1,2,{0,1}}}, + {?eh,tc_start,{ts_if_1_SUITE,tc5}}, {?eh,tc_done,{ts_if_1_SUITE,tc5,{auto_skipped,{sequence_failed,seq1,tc4}}}}, {?eh,test_stats,{1,2,{0,2}}}, diff --git a/lib/common_test/test/ct_test_support.erl b/lib/common_test/test/ct_test_support.erl index e926abd885..05a452b99d 100644 --- a/lib/common_test/test/ct_test_support.erl +++ b/lib/common_test/test/ct_test_support.erl @@ -765,23 +765,23 @@ locate({parallel,TEvs}, Node, Evs, Config) -> {Done,RemEvs2,length(RemEvs2)} end; %% end_per_group auto- or user skipped - (TEv={TEH,AutoOrUserSkip,{M,end_per_group,R}}, {Done,RemEvs,_RemSize}) + (TEv={TEH,AutoOrUserSkip,{M,{end_per_group,G},R}}, {Done,RemEvs,_RemSize}) when AutoOrUserSkip == tc_auto_skip; AutoOrUserSkip == tc_user_skip -> RemEvs1 = lists:dropwhile( fun({EH,#event{name=tc_auto_skip, node=EvNode, - data={Mod,end_per_group,Reason}}}) when - EH == TEH, EvNode == Node, Mod == M -> + data={Mod,{end_per_group,EvGroupName},Reason}}}) when + EH == TEH, EvNode == Node, Mod == M, EvGroupName == G -> case match_data(R, Reason) of match -> false; _ -> true end; ({EH,#event{name=tc_user_skip, node=EvNode, - data={Mod,end_per_group,Reason}}}) when - EH == TEH, EvNode == Node, Mod == M -> + data={Mod,{end_per_group,EvGroupName},Reason}}}) when + EH == TEH, EvNode == Node, Mod == M, EvGroupName == G -> case match_data(R, Reason) of match -> false; _ -> true @@ -1008,20 +1008,20 @@ locate({shuffle,TEvs}, Node, Evs, Config) -> {Done,RemEvs2,length(RemEvs2)} end; %% end_per_group auto-or user skipped - (TEv={TEH,AutoOrUserSkip,{M,end_per_group,R}}, {Done,RemEvs,_RemSize}) + (TEv={TEH,AutoOrUserSkip,{M,{end_per_group,G},R}}, {Done,RemEvs,_RemSize}) when AutoOrUserSkip == tc_auto_skip; AutoOrUserSkip == tc_user_skip -> RemEvs1 = lists:dropwhile( fun({EH,#event{name=tc_auto_skip, node=EvNode, - data={Mod,end_per_group,Reason}}}) when - EH == TEH, EvNode == Node, Mod == M, Reason == R -> + data={Mod,{end_per_group,EvGroupName},Reason}}}) when + EH == TEH, EvNode == Node, Mod == M, EvGroupName == G, Reason == R -> false; ({EH,#event{name=tc_user_skip, node=EvNode, - data={Mod,end_per_group,Reason}}}) when - EH == TEH, EvNode == Node, Mod == M, Reason == R -> + data={Mod,{end_per_group,EvGroupName},Reason}}}) when + EH == TEH, EvNode == Node, Mod == M, EvGroupName == G, Reason == R -> false; ({EH,#event{name=stop_logging, node=EvNode,data=_}}) when @@ -1264,10 +1264,10 @@ log_events1([E={_EH,tc_done,{_M,{end_per_group,_GrName,Props},_R}} | Evs], Dev, io:format(Dev, "~s~p]},~n", [Ind,E]), log_events1(Evs, Dev, Ind--" ") end; -log_events1([E={_EH,tc_auto_skip,{_M,end_per_group,_Reason}} | Evs], Dev, Ind) -> +log_events1([E={_EH,tc_auto_skip,{_M,{end_per_group,_GrName},_Reason}} | Evs], Dev, Ind) -> io:format(Dev, "~s~p],~n", [Ind,E]), log_events1(Evs, Dev, Ind--" "); -log_events1([E={_EH,tc_user_skip,{_M,end_per_group,_Reason}} | Evs], Dev, Ind) -> +log_events1([E={_EH,tc_user_skip,{_M,{end_per_group,_GrName},_Reason}} | Evs], Dev, Ind) -> io:format(Dev, "~s~p],~n", [Ind,E]), log_events1(Evs, Dev, Ind--" "); log_events1([E], Dev, Ind) -> diff --git a/lib/common_test/test/ct_testspec_2_SUITE.erl b/lib/common_test/test/ct_testspec_2_SUITE.erl index 1a941df185..1bab80942a 100644 --- a/lib/common_test/test/ct_testspec_2_SUITE.erl +++ b/lib/common_test/test/ct_testspec_2_SUITE.erl @@ -220,7 +220,24 @@ basic_compatible_no_nodes(_Config) -> {tc2,{skip,"skipped"}}]}]}], merge_tests = true}, - verify_result(Verify,ListResult,FileResult). + verify_result(Verify,ListResult,FileResult), + + {ok,Tests} = ct_testspec:get_tests([SpecFile]), + ct:pal("ct_testspec:get_tests/1:~n~p~n", [Tests]), + [{[SpecFile],[{Node,Run,Skip}]}] = Tests, + [{Alias1V,x_SUITE,all}, + {Alias1V,y_SUITE,[{g1,all},{g2,all},tc1,tc2]}, + {Alias1V,z_SUITE,all}, + {Alias2V,x_SUITE,all}, + {Alias2V,y_SUITE,all}] = lists:sort(Run), + [{Alias1V,z_SUITE,"skipped"}, + {Alias2V,x_SUITE,{g1,all},"skipped"}, + {Alias2V,x_SUITE,{g2,all},"skipped"}, + {Alias2V,y_SUITE,tc1,"skipped"}, + {Alias2V,y_SUITE,tc2,"skipped"}] = lists:sort(Skip), + + ok. + %%%----------------------------------------------------------------- %%% @@ -346,7 +363,25 @@ basic_compatible_nodes(_Config) -> {tc2,{skip,"skipped"}}]}]}], merge_tests = true}, - verify_result(Verify,ListResult,FileResult). + verify_result(Verify,ListResult,FileResult), + + {ok,Tests} = ct_testspec:get_tests([SpecFile]), + ct:pal("ct_testspec:get_tests/1:~n~p~n", [Tests]), + [{[SpecFile],[{Node,[],[]}, + {Node1,Run1,Skip1}, + {Node2,Run2,Skip2}]}] = Tests, + [{TO1V,x_SUITE,all}, + {TO1V,y_SUITE,[{g1,all},{g2,all},tc1,tc2]}, + {TO1V,z_SUITE,all}] = lists:sort(Run1), + [{TO2V,x_SUITE,all}, + {TO2V,y_SUITE,all}] = lists:sort(Run2), + [{TO1V,z_SUITE,"skipped"}] = lists:sort(Skip1), + [{TO2V,x_SUITE,{g1,all},"skipped"}, + {TO2V,x_SUITE,{g2,all},"skipped"}, + {TO2V,y_SUITE,tc1,"skipped"}, + {TO2V,y_SUITE,tc2,"skipped"}] = lists:sort(Skip2), + + ok. %%%----------------------------------------------------------------- %%% @@ -439,7 +474,28 @@ no_merging(_Config) -> [{y_SUITE,[{tc1,{skip,"skipped"}}, {tc2,{skip,"skipped"}}]}]}]}, - verify_result(Verify,ListResult,FileResult). + verify_result(Verify,ListResult,FileResult), + + {ok,Tests} = ct_testspec:get_tests([SpecFile]), + ct:pal("ct_testspec:get_tests/1:~n~p~n", [Tests]), + [{[SpecFile],[{Node,[],[]}, + {Node1,Run1,Skip1}, + {Node2,Run2,Skip2}]}] = Tests, + [{TO1V,x_SUITE,all}, + {TO1V,y_SUITE,[tc1,tc2]}, + {TO1V,y_SUITE,[{g1,all},{g2,all}]}, + {TO1V,z_SUITE,all}] = lists:sort(Run1), + [{TO2V,x_SUITE,all}, + {TO2V,x_SUITE,[{skipped,g1,all},{skipped,g2,all}]}, + {TO2V,y_SUITE,all}, + {TO2V,y_SUITE,[{skipped,tc1},{skipped,tc2}]}] = lists:sort(Run2), + [{TO1V,z_SUITE,"skipped"}] = lists:sort(Skip1), + [{TO2V,x_SUITE,{g1,all},"skipped"}, + {TO2V,x_SUITE,{g2,all},"skipped"}, + {TO2V,y_SUITE,tc1,"skipped"}, + {TO2V,y_SUITE,tc2,"skipped"}] = lists:sort(Skip2), + + ok. %%%----------------------------------------------------------------- %%% @@ -510,7 +566,25 @@ multiple_specs(_Config) -> {y_SUITE,[all,{tc1,{skip,"skipped"}}, {tc2,{skip,"skipped"}}]}]}]}, - verify_result(Verify,FileResult,FileResult). + verify_result(Verify,FileResult,FileResult), + + {ok,Tests} = ct_testspec:get_tests([[SpecFile1,SpecFile2]]), + ct:pal("ct_testspec:get_tests/1:~n~p~n", [Tests]), + [{[SpecFile1,SpecFile2],[{Node,[],[]}, + {Node1,Run1,Skip1}, + {Node2,Run2,Skip2}]}] = Tests, + [{TO1V,x_SUITE,all}, + {TO1V,y_SUITE,[{g1,all},{g2,all},tc1,tc2]}, + {TO1V,z_SUITE,all}] = lists:sort(Run1), + [{TO2V,x_SUITE,all}, + {TO2V,y_SUITE,all}] = lists:sort(Run2), + [{TO1V,z_SUITE,"skipped"}] = lists:sort(Skip1), + [{TO2V,x_SUITE,{g1,all},"skipped"}, + {TO2V,x_SUITE,{g2,all},"skipped"}, + {TO2V,y_SUITE,tc1,"skipped"}, + {TO2V,y_SUITE,tc2,"skipped"}] = lists:sort(Skip2), + + ok. %%%----------------------------------------------------------------- %%% diff --git a/lib/compiler/doc/src/compile.xml b/lib/compiler/doc/src/compile.xml index bd488a39a5..ed04dac1c0 100644 --- a/lib/compiler/doc/src/compile.xml +++ b/lib/compiler/doc/src/compile.xml @@ -418,7 +418,7 @@ module.beam: module.erl \ without module prefix to local or imported functions before trying with auto-imported BIFs. If the BIF is to be called, use the <c>erlang</c> module prefix in the call, not - <c>{ no_auto_import,[{F,A}, ...]}</c>.</p> + <c>{no_auto_import,[{F,A}, ...]}</c>.</p> </note> <p>If this option is written in the source code, as a <c>-compile</c> directive, the syntax <c>F/A</c> can be used instead @@ -439,6 +439,15 @@ module.beam: module.erl \ </p> </item> + <tag><c>{extra_chunks, [{binary(), binary()}]}</c></tag> + <item> + <p>Pass extra chunks to be stored in the <c>.beam</c> file. + The extra chunks must be a list of tuples with a four byte + binary as chunk name followed by a binary with the chunk contents. + See <seealso marker="stdlib:beam_lib">beam_lib</seealso> for + more information. + </p> + </item> </taglist> <p>If warnings are turned on (option <c>report_warnings</c> @@ -679,7 +688,7 @@ module.beam: module.erl \ <fsummary>Compiles a list of forms.</fsummary> <desc> <p>Is the same as - <c>forms(File, [verbose,report_errors,report_warnings])</c>. + <c>forms(Forms, [verbose,report_errors,report_warnings])</c>. </p> </desc> </func> diff --git a/lib/compiler/src/beam_asm.erl b/lib/compiler/src/beam_asm.erl index 2fc2850591..1bda185acd 100644 --- a/lib/compiler/src/beam_asm.erl +++ b/lib/compiler/src/beam_asm.erl @@ -49,28 +49,26 @@ -type function_name() :: atom(). --type exports() :: [{function_name(),arity()}]. - -type asm_function() :: {'function',function_name(),arity(),label(),[asm_instruction()]}. -type module_code() :: {module(),[_],[_],[asm_function()],pos_integer()}. --spec module(module_code(), exports(), [_], [compile:option()], [compile:option()]) -> +-spec module(module_code(), [{binary(), binary()}], [_], [compile:option()], [compile:option()]) -> {'ok',binary()}. -module(Code, Abst, SourceFile, Opts, CompilerOpts) -> - {ok,assemble(Code, Abst, SourceFile, Opts, CompilerOpts)}. +module(Code, ExtraChunks, SourceFile, Opts, CompilerOpts) -> + {ok,assemble(Code, ExtraChunks, SourceFile, Opts, CompilerOpts)}. -assemble({Mod,Exp0,Attr0,Asm0,NumLabels}, Abst, SourceFile, Opts, CompilerOpts) -> +assemble({Mod,Exp0,Attr0,Asm0,NumLabels}, ExtraChunks, SourceFile, Opts, CompilerOpts) -> {1,Dict0} = beam_dict:atom(Mod, beam_dict:new()), {0,Dict1} = beam_dict:fname(atom_to_list(Mod) ++ ".erl", Dict0), NumFuncs = length(Asm0), {Asm,Attr} = on_load(Asm0, Attr0), Exp = cerl_sets:from_list(Exp0), {Code,Dict2} = assemble_1(Asm, Exp, Dict1, []), - build_file(Code, Attr, Dict2, NumLabels, NumFuncs, Abst, SourceFile, Opts, CompilerOpts). + build_file(Code, Attr, Dict2, NumLabels, NumFuncs, ExtraChunks, SourceFile, Opts, CompilerOpts). on_load(Fs0, Attr0) -> case proplists:get_value(on_load, Attr0) of @@ -113,7 +111,7 @@ assemble_function([H|T], Acc, Dict0) -> assemble_function([], Code, Dict) -> {Code, Dict}. -build_file(Code, Attr, Dict, NumLabels, NumFuncs, Abst, SourceFile, Opts, CompilerOpts) -> +build_file(Code, Attr, Dict, NumLabels, NumFuncs, ExtraChunks, SourceFile, Opts, CompilerOpts) -> %% Create the code chunk. CodeChunk = chunk(<<"Code">>, @@ -188,18 +186,18 @@ build_file(Code, Attr, Dict, NumLabels, NumFuncs, Abst, SourceFile, Opts, Compil AttrChunk = chunk(<<"Attr">>, Attributes), CompileChunk = chunk(<<"CInf">>, Compile), - %% Create the abstract code chunk. + %% Compile all extra chunks. - AbstChunk = chunk(<<"Abst">>, Abst), + CheckedChunks = [chunk(Key, Value) || {Key, Value} <- ExtraChunks], %% Create IFF chunk. Chunks = case member(slim, Opts) of true -> - [Essentials,AttrChunk,AbstChunk]; + [Essentials,AttrChunk,CheckedChunks]; false -> [Essentials,LocChunk,AttrChunk, - CompileChunk,AbstChunk,LineChunk] + CompileChunk,CheckedChunks,LineChunk] end, build_form(<<"BEAM">>, Chunks). diff --git a/lib/compiler/src/compile.erl b/lib/compiler/src/compile.erl index dcd962df66..c849306c0d 100644 --- a/lib/compiler/src/compile.erl +++ b/lib/compiler/src/compile.erl @@ -315,19 +315,25 @@ format_error_reason(Reason) -> mod_options=[] :: [option()], %Options for module_info encoding=none :: none | epp:source_encoding(), errors=[] :: [err_warn_info()], - warnings=[] :: [err_warn_info()]}). + warnings=[] :: [err_warn_info()], + extra_chunks=[] :: [{binary(), binary()}]}). internal({forms,Forms}, Opts0) -> {_,Ps} = passes(forms, Opts0), Source = proplists:get_value(source, Opts0, ""), Opts1 = proplists:delete(source, Opts0), - Compile = #compile{options=Opts1,mod_options=Opts1}, + Compile = build_compile(Opts1), internal_comp(Ps, Forms, Source, "", Compile); internal({file,File}, Opts) -> {Ext,Ps} = passes(file, Opts), - Compile = #compile{options=Opts,mod_options=Opts}, + Compile = build_compile(Opts), internal_comp(Ps, none, File, Ext, Compile). +build_compile(Opts0) -> + ExtraChunks = proplists:get_value(extra_chunks, Opts0, []), + Opts1 = proplists:delete(extra_chunks, Opts0), + #compile{options=Opts1,mod_options=Opts1,extra_chunks=ExtraChunks}. + internal_comp(Passes, Code0, File, Suffix, St0) -> Dir = filename:dirname(File), Base = filename:basename(File, Suffix), @@ -1386,14 +1392,15 @@ encrypt({des3_cbc=Type,Key,IVec,BlockSize}, Bin0) -> save_core_code(Code, St) -> {ok,Code,St#compile{core_code=cerl:from_records(Code)}}. -beam_asm(Code0, #compile{ifile=File,abstract_code=Abst, +beam_asm(Code0, #compile{ifile=File,abstract_code=Abst,extra_chunks=ExtraChunks, options=CompilerOpts,mod_options=Opts0}=St) -> Source = paranoid_absname(File), Opts1 = lists:map(fun({debug_info_key,_}) -> {debug_info_key,'********'}; (Other) -> Other end, Opts0), Opts2 = [O || O <- Opts1, effects_code_generation(O)], - case beam_asm:module(Code0, Abst, Source, Opts2, CompilerOpts) of + Chunks = [{<<"Abst">>, Abst} | ExtraChunks], + case beam_asm:module(Code0, Chunks, Source, Opts2, CompilerOpts) of {ok,Code} -> {ok,Code,St#compile{abstract_code=[]}} end. diff --git a/lib/compiler/src/v3_core.erl b/lib/compiler/src/v3_core.erl index 14cd41ae27..8dea7ec03a 100644 --- a/lib/compiler/src/v3_core.erl +++ b/lib/compiler/src/v3_core.erl @@ -1059,13 +1059,30 @@ count_bits(Int) -> count_bits_1(0, Bits) -> Bits; count_bits_1(Int, Bits) -> count_bits_1(Int bsr 64, Bits+64). -bin_expand_strings(Es) -> - foldr(fun ({bin_element,Line,{string,_,S},Sz,Ts}, Es1) -> - foldr(fun (C, Es2) -> - [{bin_element,Line,{char,Line,C},Sz,Ts}|Es2] - end, Es1, S); - (E, Es1) -> [E|Es1] - end, [], Es). +bin_expand_strings(Es0) -> + foldr(fun ({bin_element,Line,{string,_,S},{integer,_,8},_}, Es) -> + bin_expand_string(S, Line, 0, 0) ++ Es; + ({bin_element,Line,{string,_,S},Sz,Ts}, Es1) -> + foldr( + fun (C, Es) -> + [{bin_element,Line,{char,Line,C},Sz,Ts}|Es] + end, Es1, S); + (E, Es) -> + [E|Es] + end, [], Es0). + +bin_expand_string(S, Line, Val, Size) when Size >= 2048 -> + Combined = make_combined(Line, Val, Size), + [Combined|bin_expand_string(S, Line, 0, 0)]; +bin_expand_string([H|T], Line, Val, Size) -> + bin_expand_string(T, Line, (Val bsl 8) bor H, Size+8); +bin_expand_string([], Line, Val, Size) -> + [make_combined(Line, Val, Size)]. + +make_combined(Line, Val, Size) -> + {bin_element,Line,{integer,Line,Val}, + {integer,Line,Size}, + [integer,{unit,1},unsigned,big]}. expr_bin_1(Es, St) -> foldr(fun (E, {Ces,Esp,St0}) -> diff --git a/lib/compiler/test/compile_SUITE.erl b/lib/compiler/test/compile_SUITE.erl index 8d7facd727..10740ac2b0 100644 --- a/lib/compiler/test/compile_SUITE.erl +++ b/lib/compiler/test/compile_SUITE.erl @@ -30,7 +30,7 @@ file_1/1, forms_2/1, module_mismatch/1, big_file/1, outdir/1, binary/1, makedep/1, cond_and_ifdef/1, listings/1, listings_big/1, other_output/1, kernel_listing/1, encrypted_abstr/1, - strict_record/1, utf8_atoms/1, + strict_record/1, utf8_atoms/1, extra_chunks/1, cover/1, env/1, core/1, core_roundtrip/1, asm/1, optimized_guards/1, sys_pre_attributes/1, dialyzer/1, @@ -48,7 +48,7 @@ all() -> [app_test, appup_test, file_1, forms_2, module_mismatch, big_file, outdir, binary, makedep, cond_and_ifdef, listings, listings_big, other_output, kernel_listing, encrypted_abstr, - strict_record, utf8_atoms, + strict_record, utf8_atoms, extra_chunks, cover, env, core, core_roundtrip, asm, optimized_guards, sys_pre_attributes, dialyzer, warnings, pre_load_check, env_compiler_options]. @@ -699,6 +699,15 @@ utf8_atoms(Config) when is_list(Config) -> NoUtf8AtomForms = [{attribute,Anno,module,no_utf8_atom}|Forms], error = compile:forms(NoUtf8AtomForms, [binary, r19]). +extra_chunks(Config) when is_list(Config) -> + Anno = erl_anno:new(1), + Forms = [{attribute,Anno,module,extra_chunks}], + + {ok,extra_chunks,ExtraChunksBinary} = + compile:forms(Forms, [binary, {extra_chunks, [{<<"ExCh">>, <<"Contents">>}]}]), + {ok,{extra_chunks,[{"ExCh",<<"Contents">>}]}} = + beam_lib:chunks(ExtraChunksBinary, ["ExCh"]). + env(Config) when is_list(Config) -> {Simple,Target} = get_files(Config, simple, env), {ok,Cwd} = file:get_cwd(), diff --git a/lib/crypto/c_src/crypto.c b/lib/crypto/c_src/crypto.c index 44c3fc4f06..b2f31870b9 100644 --- a/lib/crypto/c_src/crypto.c +++ b/lib/crypto/c_src/crypto.c @@ -71,6 +71,46 @@ PACKED_OPENSSL_VERSION(MAJ,MIN,FIX,('a'-1)) +/* LibreSSL was cloned from OpenSSL 1.0.1g and claims to be API and BPI compatible + * with 1.0.1. + * + * LibreSSL has the same names on include files and symbols as OpenSSL, but defines + * the OPENSSL_VERSION_NUMBER to be >= 2.0.0 + * + * Therefor works tests like this as intendend: + * OPENSSL_VERSION_NUMBER >= PACKED_OPENSSL_VERSION_PLAIN(1,0,0) + * (The test is for example "2.4.2" >= "1.0.0" although the test + * with the cloned OpenSSL test would be "1.0.1" >= "1.0.0") + * + * But tests like this gives wrong result: + * OPENSSL_VERSION_NUMBER < PACKED_OPENSSL_VERSION_PLAIN(1,1,0) + * (The test is false since "2.4.2" < "1.1.0". It should have been + * true because the LibreSSL API version is "1.0.1") + * + */ + +#ifdef LIBRESSL_VERSION_NUMBER +/* A macro to test on in this file */ +#define HAS_LIBRESSL +#endif + +#ifdef HAS_LIBRESSL +/* LibreSSL dislikes FIPS */ +# ifdef FIPS_SUPPORT +# undef FIPS_SUPPORT +# endif + +/* LibreSSL wants the 1.0.1 API */ +# define NEED_EVP_COMPATIBILITY_FUNCTIONS +#endif + + +#if OPENSSL_VERSION_NUMBER < PACKED_OPENSSL_VERSION_PLAIN(1,1,0) +# define NEED_EVP_COMPATIBILITY_FUNCTIONS +#endif + + + #if OPENSSL_VERSION_NUMBER >= PACKED_OPENSSL_VERSION_PLAIN(1,0,0) #include <openssl/modes.h> #endif @@ -120,7 +160,9 @@ #endif #if OPENSSL_VERSION_NUMBER >= PACKED_OPENSSL_VERSION_PLAIN(1,1,0) -# define HAVE_CHACHA20_POLY1305 +# ifndef HAS_LIBRESSL +# define HAVE_CHACHA20_POLY1305 +# endif #endif #if OPENSSL_VERSION_NUMBER <= PACKED_OPENSSL_VERSION(0,9,8,'l') @@ -205,8 +247,8 @@ do { \ } \ } while (0) -#if OPENSSL_VERSION_NUMBER < PACKED_OPENSSL_VERSION_PLAIN(1,1,0) +#ifdef NEED_EVP_COMPATIBILITY_FUNCTIONS /* * In OpenSSL 1.1.0, most structs are opaque. That means that * the structs cannot be allocated as automatic variables on the @@ -237,9 +279,19 @@ static void HMAC_CTX_free(HMAC_CTX *ctx) #define EVP_MD_CTX_new() EVP_MD_CTX_create() #define EVP_MD_CTX_free(ctx) EVP_MD_CTX_destroy(ctx) +static INLINE void *BN_GENCB_get_arg(BN_GENCB *cb); + +static INLINE void *BN_GENCB_get_arg(BN_GENCB *cb) +{ + return cb->arg; +} + static INLINE int RSA_set0_key(RSA *r, BIGNUM *n, BIGNUM *e, BIGNUM *d); +static INLINE void RSA_get0_key(const RSA *r, const BIGNUM **n, const BIGNUM **e, const BIGNUM **d); static INLINE int RSA_set0_factors(RSA *r, BIGNUM *p, BIGNUM *q); +static INLINE void RSA_get0_factors(const RSA *r, const BIGNUM **p, const BIGNUM **q); static INLINE int RSA_set0_crt_params(RSA *r, BIGNUM *dmp1, BIGNUM *dmq1, BIGNUM *iqmp); +static INLINE void RSA_get0_crt_params(const RSA *r, const BIGNUM **dmp1, const BIGNUM **dmq1, const BIGNUM **iqmp); static INLINE int RSA_set0_key(RSA *r, BIGNUM *n, BIGNUM *e, BIGNUM *d) { @@ -249,6 +301,13 @@ static INLINE int RSA_set0_key(RSA *r, BIGNUM *n, BIGNUM *e, BIGNUM *d) return 1; } +static INLINE void RSA_get0_key(const RSA *r, const BIGNUM **n, const BIGNUM **e, const BIGNUM **d) +{ + *n = r->n; + *e = r->e; + *d = r->d; +} + static INLINE int RSA_set0_factors(RSA *r, BIGNUM *p, BIGNUM *q) { r->p = p; @@ -256,6 +315,12 @@ static INLINE int RSA_set0_factors(RSA *r, BIGNUM *p, BIGNUM *q) return 1; } +static INLINE void RSA_get0_factors(const RSA *r, const BIGNUM **p, const BIGNUM **q) +{ + *p = r->p; + *q = r->q; +} + static INLINE int RSA_set0_crt_params(RSA *r, BIGNUM *dmp1, BIGNUM *dmq1, BIGNUM *iqmp) { r->dmp1 = dmp1; @@ -264,6 +329,13 @@ static INLINE int RSA_set0_crt_params(RSA *r, BIGNUM *dmp1, BIGNUM *dmq1, BIGNUM return 1; } +static INLINE void RSA_get0_crt_params(const RSA *r, const BIGNUM **dmp1, const BIGNUM **dmq1, const BIGNUM **iqmp) +{ + *dmp1 = r->dmp1; + *dmq1 = r->dmq1; + *iqmp = r->iqmp; +} + static INLINE int DSA_set0_key(DSA *d, BIGNUM *pub_key, BIGNUM *priv_key); static INLINE int DSA_set0_pqg(DSA *d, BIGNUM *p, BIGNUM *q, BIGNUM *g); @@ -326,7 +398,11 @@ DH_get0_key(const DH *dh, const BIGNUM **pub_key, const BIGNUM **priv_key) *priv_key = dh->priv_key; } -#endif /* End of compatibility definitions. */ +#else /* End of compatibility definitions. */ + +#define HAVE_OPAQUE_BN_GENCB + +#endif /* NIF interface declarations */ static int load(ErlNifEnv* env, void** priv_data, ERL_NIF_TERM load_info); @@ -364,6 +440,7 @@ static ERL_NIF_TERM rsa_sign_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM ar static ERL_NIF_TERM dss_sign_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); static ERL_NIF_TERM rsa_public_crypt(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); static ERL_NIF_TERM rsa_private_crypt(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM rsa_generate_key_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); static ERL_NIF_TERM dh_generate_parameters_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); static ERL_NIF_TERM dh_check(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); static ERL_NIF_TERM dh_generate_key_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); @@ -397,6 +474,7 @@ static EC_KEY* ec_key_new(ErlNifEnv* env, ERL_NIF_TERM curve_arg); static int term2point(ErlNifEnv* env, ERL_NIF_TERM term, EC_GROUP *group, EC_POINT **pptr); #endif +static ERL_NIF_TERM bin_from_bn(ErlNifEnv* env, const BIGNUM *bn); static int library_refc = 0; /* number of users of this dynamic library */ @@ -434,6 +512,7 @@ static ErlNifFunc nif_funcs[] = { {"dss_sign_nif", 3, dss_sign_nif}, {"rsa_public_crypt", 4, rsa_public_crypt}, {"rsa_private_crypt", 4, rsa_private_crypt}, + {"rsa_generate_key_nif", 2, rsa_generate_key_nif}, {"dh_generate_parameters_nif", 2, dh_generate_parameters_nif}, {"dh_check", 1, dh_check}, {"dh_generate_key_nif", 4, dh_generate_key_nif}, @@ -883,6 +962,7 @@ static int initialize(ErlNifEnv* env, ERL_NIF_TERM load_info) CRYPTO_set_dynlock_destroy_callback(ccb->dyn_destroy_function); } #endif /* OPENSSL_THREADS */ + return 0; } @@ -2237,6 +2317,20 @@ static int get_bn_from_bin(ErlNifEnv* env, ERL_NIF_TERM term, BIGNUM** bnp) return 1; } +static ERL_NIF_TERM bin_from_bn(ErlNifEnv* env, const BIGNUM *bn) +{ + int bn_len; + unsigned char *bin_ptr; + ERL_NIF_TERM term; + + /* Copy the bignum into an erlang binary. */ + bn_len = BN_num_bytes(bn); + bin_ptr = enif_make_new_binary(env, bn_len, &term); + BN_bn2bin(bn, bin_ptr); + + return term; +} + static ERL_NIF_TERM rand_uniform_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) {/* (Lo,Hi) */ BIGNUM *bn_from = NULL, *bn_to, *bn_rand; @@ -2808,6 +2902,119 @@ static ERL_NIF_TERM rsa_private_crypt(ErlNifEnv* env, int argc, const ERL_NIF_TE } } +/* Creates a term which can be parsed by get_rsa_private_key(). This is a list of plain integer binaries (not mpints). */ +static ERL_NIF_TERM put_rsa_private_key(ErlNifEnv* env, const RSA *rsa) +{ + ERL_NIF_TERM result[8]; + const BIGNUM *n, *e, *d, *p, *q, *dmp1, *dmq1, *iqmp; + + /* Return at least [E,N,D] */ + n = NULL; e = NULL; d = NULL; + RSA_get0_key(rsa, &n, &e, &d); + + result[0] = bin_from_bn(env, e); // Exponent E + result[1] = bin_from_bn(env, n); // Modulus N = p*q + result[2] = bin_from_bn(env, d); // Exponent D + + /* Check whether the optional additional parameters are available */ + p = NULL; q = NULL; + RSA_get0_factors(rsa, &p, &q); + dmp1 = NULL; dmq1 = NULL; iqmp = NULL; + RSA_get0_crt_params(rsa, &dmp1, &dmq1, &iqmp); + + if (p && q && dmp1 && dmq1 && iqmp) { + result[3] = bin_from_bn(env, p); // Factor p + result[4] = bin_from_bn(env, q); // Factor q + result[5] = bin_from_bn(env, dmp1); // D mod (p-1) + result[6] = bin_from_bn(env, dmq1); // D mod (q-1) + result[7] = bin_from_bn(env, iqmp); // (1/q) mod p + + return enif_make_list_from_array(env, result, 8); + } else { + return enif_make_list_from_array(env, result, 3); + } +} + +static int check_erlang_interrupt(int maj, int min, BN_GENCB *ctxt) +{ + ErlNifEnv *env = BN_GENCB_get_arg(ctxt); + + if (!enif_is_current_process_alive(env)) { + return 0; + } else { + return 1; + } +} + +static ERL_NIF_TERM rsa_generate_key(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{/* (ModulusSize, PublicExponent) */ + int modulus_bits; + BIGNUM *pub_exp, *three; + RSA *rsa; + int success; + ERL_NIF_TERM result; + BN_GENCB *intr_cb; +#ifndef HAVE_OPAQUE_BN_GENCB + BN_GENCB intr_cb_buf; +#endif + + if (!enif_get_int(env, argv[0], &modulus_bits) || modulus_bits < 256) { + return enif_make_badarg(env); + } + + if (!get_bn_from_bin(env, argv[1], &pub_exp)) { + return enif_make_badarg(env); + } + + /* Make sure the public exponent is large enough (at least 3). + * Without this, RSA_generate_key_ex() can run forever. */ + three = BN_new(); + BN_set_word(three, 3); + success = BN_cmp(pub_exp, three); + BN_free(three); + if (success < 0) { + BN_free(pub_exp); + return enif_make_badarg(env); + } + + /* For large keys, prime generation can take many seconds. Set up + * the callback which we use to test whether the process has been + * interrupted. */ +#ifdef HAVE_OPAQUE_BN_GENCB + intr_cb = BN_GENCB_new(); +#else + intr_cb = &intr_cb_buf; +#endif + BN_GENCB_set(intr_cb, check_erlang_interrupt, env); + + rsa = RSA_new(); + success = RSA_generate_key_ex(rsa, modulus_bits, pub_exp, intr_cb); + BN_free(pub_exp); + +#ifdef HAVE_OPAQUE_BN_GENCB + BN_GENCB_free(intr_cb); +#endif + + if (!success) { + RSA_free(rsa); + return atom_error; + } + + result = put_rsa_private_key(env, rsa); + RSA_free(rsa); + + return result; +} + +static ERL_NIF_TERM rsa_generate_key_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{ + /* RSA key generation can take a long time (>1 sec for a large + * modulus), so schedule it as a CPU-bound operation. */ + return enif_schedule_nif(env, "rsa_generate_key", + ERL_NIF_DIRTY_JOB_CPU_BOUND, + rsa_generate_key, argc, argv); +} + static ERL_NIF_TERM dh_generate_parameters_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) {/* (PrimeLen, Generator) */ int prime_len, generator; diff --git a/lib/crypto/c_src/crypto_callback.h b/lib/crypto/c_src/crypto_callback.h index 2641cc0c8b..489810116f 100644 --- a/lib/crypto/c_src/crypto_callback.h +++ b/lib/crypto/c_src/crypto_callback.h @@ -19,7 +19,7 @@ */ #include <openssl/crypto.h> -#if OPENSSL_VERSION_NUMBER < 0x10100000L +#ifdef NEED_EVP_COMPATIBILITY_FUNCTIONS # define CCB_FILE_LINE_ARGS #else # define CCB_FILE_LINE_ARGS , const char *file, int line diff --git a/lib/crypto/doc/src/crypto.xml b/lib/crypto/doc/src/crypto.xml index a4b34657ba..d0deaceaaf 100644 --- a/lib/crypto/doc/src/crypto.xml +++ b/lib/crypto/doc/src/crypto.xml @@ -77,7 +77,7 @@ <code>rsa_private() = [key_value()] = [E, N, D] | [E, N, D, P1, P2, E1, E2, C] </code> <p>Where E is the public exponent, N is public modulus and D is - the private exponent.The longer key format contains redundant + the private exponent. The longer key format contains redundant information that will make the calculation faster. P1,P2 are first and second prime factors. E1,E2 are first and second exponents. C is the CRT coefficient. Terminology is taken from <url href="http://www.ietf.org/rfc/rfc3477.txt"> RFC 3447</url>.</p> @@ -298,22 +298,32 @@ <func> <name>generate_key(Type, Params) -> {PublicKey, PrivKeyOut} </name> <name>generate_key(Type, Params, PrivKeyIn) -> {PublicKey, PrivKeyOut} </name> - <fsummary>Generates a public keys of type <c>Type</c></fsummary> + <fsummary>Generates a public key of type <c>Type</c></fsummary> <type> - <v> Type = dh | ecdh | srp </v> - <v>Params = dh_params() | ecdh_params() | SrpUserParams | SrpHostParams </v> + <v> Type = dh | ecdh | rsa | srp </v> + <v>Params = dh_params() | ecdh_params() | RsaParams | SrpUserParams | SrpHostParams </v> + <v>RsaParams = {ModulusSizeInBits::integer(), PublicExponent::key_value()}</v> <v>SrpUserParams = {user, [Generator::binary(), Prime::binary(), Version::atom()]}</v> <v>SrpHostParams = {host, [Verifier::binary(), Generator::binary(), Prime::binary(), Version::atom()]}</v> - <v>PublicKey = dh_public() | ecdh_public() | srp_public() </v> + <v>PublicKey = dh_public() | ecdh_public() | rsa_public() | srp_public() </v> <v>PrivKeyIn = undefined | dh_private() | ecdh_private() | srp_private() </v> - <v>PrivKeyOut = dh_private() | ecdh_private() | srp_private() </v> - </type> - <desc> - <p>Generates public keys of type <c>Type</c>. - See also <seealso marker="public_key:public_key#generate_key-1">public_key:generate_key/1</seealso> - May throw exception <c>low_entropy</c> in case the random generator - failed due to lack of secure "randomness". - </p> + <v>PrivKeyOut = dh_private() | ecdh_private() | rsa_private() | srp_private() </v> + </type> + <desc> + <p>Generates a public key of type <c>Type</c>. + See also <seealso marker="public_key:public_key#generate_key-1">public_key:generate_key/1</seealso>. + May throw exception an exception of class <c>error</c>: + </p> + <list type="bulleted"> + <item><c>badarg</c>: an argument is of wrong type or has an illegal value,</item> + <item><c>low_entropy</c>: the random generator failed due to lack of secure "randomness",</item> + <item><c>computation_failed</c>: the computation fails of another reason than <c>low_entropy</c>.</item> + </list> + <note> + <p>RSA key generation is only available if the runtime was + built with dirty scheduler support. Otherwise, attempting to + generate an RSA key will throw exception <c>error:notsup</c>.</p> + </note> </desc> </func> diff --git a/lib/crypto/src/crypto.app.src b/lib/crypto/src/crypto.app.src index 460894c012..3bf4279ae1 100644 --- a/lib/crypto/src/crypto.app.src +++ b/lib/crypto/src/crypto.app.src @@ -25,6 +25,6 @@ {registered, []}, {applications, [kernel, stdlib]}, {env, [{fips_mode, false}]}, - {runtime_dependencies, ["erts-6.0","stdlib-2.0","kernel-3.0"]}]}. + {runtime_dependencies, ["erts-9.0","stdlib-3.4","kernel-5.3"]}]}. diff --git a/lib/crypto/src/crypto.erl b/lib/crypto/src/crypto.erl index 5a915d4233..631af62615 100644 --- a/lib/crypto/src/crypto.erl +++ b/lib/crypto/src/crypto.erl @@ -452,6 +452,15 @@ generate_key(srp, {user, [Generator, Prime, Version]}, PrivateArg) end, user_srp_gen_key(Private, Generator, Prime); +generate_key(rsa, {ModulusSize, PublicExponent}, undefined) -> + case rsa_generate_key_nif(ModulusSize, ensure_int_as_bin(PublicExponent)) of + error -> + erlang:error(computation_failed, + [rsa,{ModulusSize,PublicExponent}]); + Private -> + {lists:sublist(Private, 2), Private} + end; + generate_key(ecdh, Curve, PrivKey) -> ec_key_generate(nif_curve_params(Curve), ensure_int_as_bin(PrivKey)). @@ -787,6 +796,11 @@ rsa_verify_nif(_Type, _Digest, _Signature, _Key) -> ?nif_stub. ecdsa_verify_nif(_Type, _Digest, _Signature, _Curve, _Key) -> ?nif_stub. %% Public Keys -------------------------------------------------------------------- +%% RSA Rivest-Shamir-Adleman functions +%% + +rsa_generate_key_nif(_Bits, _Exp) -> ?nif_stub. + %% DH Diffie-Hellman functions %% diff --git a/lib/crypto/test/crypto_SUITE.erl b/lib/crypto/test/crypto_SUITE.erl index 31f4e89ffe..1d7037d003 100644 --- a/lib/crypto/test/crypto_SUITE.erl +++ b/lib/crypto/test/crypto_SUITE.erl @@ -119,7 +119,8 @@ groups() -> {sha384, [], [hash, hmac]}, {sha512, [], [hash, hmac]}, {rsa, [], [sign_verify, - public_encrypt + public_encrypt, + generate ]}, {dss, [], [sign_verify]}, {ecdsa, [], [sign_verify]}, @@ -247,6 +248,21 @@ init_per_testcase(cmac, Config) -> % The CMAC functionality was introduced in OpenSSL 1.0.1 {skip, "OpenSSL is too old"} end; +init_per_testcase(generate, Config) -> + case proplists:get_value(type, Config) of + rsa -> + % RSA key generation is a lengthy process, and is only available + % if dirty CPU scheduler support was enabled for this runtime. + case try erlang:system_info(dirty_cpu_schedulers) of + N -> N > 0 + catch + error:badarg -> false + end of + true -> Config; + false -> {skip, "RSA key generation requires dirty scheduler support."} + end; + _ -> Config + end; init_per_testcase(_Name,Config) -> Config. @@ -756,7 +772,10 @@ do_generate({ecdh = Type, Curve, Priv, Pub}) -> ok; {Other, _} -> ct:fail({{crypto, generate_key, [Type, Priv, Curve]}, {expected, Pub}, {got, Other}}) - end. + end; +do_generate({rsa = Type, Mod, Exp}) -> + {Pub,Priv} = crypto:generate_key(Type, {Mod,Exp}), + do_sign_verify({rsa, sha256, Pub, Priv, rsa_plain()}). notsup(Fun, Args) -> Result = @@ -1008,7 +1027,8 @@ group_config(rsa = Type, Config) -> rsa_oaep(), no_padding() ], - [{sign_verify, SignVerify}, {pub_priv_encrypt, PubPrivEnc} | Config]; + Generate = [{rsa, 2048, 3}, {rsa, 3072, 65537}], + [{sign_verify, SignVerify}, {pub_priv_encrypt, PubPrivEnc}, {generate, Generate} | Config]; group_config(dss = Type, Config) -> Msg = dss_plain(), Public = dss_params() ++ [dss_public()], diff --git a/lib/dialyzer/RELEASE_NOTES b/lib/dialyzer/RELEASE_NOTES index 2457faa07a..299cc8642f 100644 --- a/lib/dialyzer/RELEASE_NOTES +++ b/lib/dialyzer/RELEASE_NOTES @@ -181,7 +181,7 @@ Version 1.8.0 (in Erlang/OTP R12B-2) - Dialyzer has a new warning option -Wunmatched_returns which warns for function calls that ignore the return value. This catches many common programming errors (e.g. calling file:close/1 - and not checking for the absense of errors), interface discrepancies + and not checking for the absence of errors), interface discrepancies (e.g. a function returning multiple values when in reality the function is void and only called for its side-effects), calling the wrong function (e.g. io_lib:format/1 instead of io:format/1), and even possible diff --git a/lib/dialyzer/src/dialyzer.app.src b/lib/dialyzer/src/dialyzer.app.src index 5b28f7ae86..f517c51ec1 100644 --- a/lib/dialyzer/src/dialyzer.app.src +++ b/lib/dialyzer/src/dialyzer.app.src @@ -2,7 +2,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2006-2016. All Rights Reserved. +%% Copyright Ericsson AB 2006-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -48,5 +48,5 @@ {applications, [compiler, hipe, kernel, stdlib, wx]}, {env, []}, {runtime_dependencies, ["wx-1.2","syntax_tools-2.0","stdlib-3.0", - "kernel-5.0","hipe-3.15.1","erts-8.0", + "kernel-5.0","hipe-3.15.4","erts-8.0", "compiler-7.0"]}]}. diff --git a/lib/dialyzer/src/dialyzer_callgraph.erl b/lib/dialyzer/src/dialyzer_callgraph.erl index bb02bc8c0d..6387f3d1e4 100644 --- a/lib/dialyzer/src/dialyzer_callgraph.erl +++ b/lib/dialyzer/src/dialyzer_callgraph.erl @@ -365,7 +365,7 @@ ets_lookup_set(Key, Table) -> %% The core tree must be labeled as by cerl_trees:label/1 (or /2). %% The set of labels in the tree must be disjoint from the set of -%% labels already occuring in the callgraph. +%% labels already occurring in the callgraph. -spec scan_core_tree(cerl:c_module(), callgraph()) -> {[mfa_or_funlbl()], [callgraph_edge()]}. diff --git a/lib/dialyzer/src/dialyzer_dataflow.erl b/lib/dialyzer/src/dialyzer_dataflow.erl index f706ebfb02..4c29b4f1eb 100644 --- a/lib/dialyzer/src/dialyzer_dataflow.erl +++ b/lib/dialyzer/src/dialyzer_dataflow.erl @@ -1344,8 +1344,6 @@ do_clause(C, Arg, ArgType0, OrigArgType, Map, State, Warns) -> {Msg, Force} = case t_is_none(ArgType0) of true -> - PatString = format_patterns(Pats), - PatTypes = [PatString, format_type(OrigArgType, State1)], %% See if this is covered by an earlier clause or if it %% simply cannot match OrigArgTypes = @@ -1353,17 +1351,27 @@ do_clause(C, Arg, ArgType0, OrigArgType, Map, State, Warns) -> true -> Any = t_any(), [Any || _ <- Pats]; false -> t_to_tlist(OrigArgType) end, + PatString = format_patterns(Pats), + ArgTypeString = format_type(OrigArgType, State1), + BindResOrig = + bind_pat_vars(Pats, OrigArgTypes, [], Map1, State1), Tag = - case bind_pat_vars(Pats, OrigArgTypes, [], Map1, State1) of + case BindResOrig of {error, bind, _, _, _} -> pattern_match; {error, record, _, _, _} -> record_match; {error, opaque, _, _, _} -> opaque_match; {_, _} -> pattern_match_cov end, - {{Tag, PatTypes}, false}; + PatTypes = case BindResOrig of + {error, opaque, _, _, OpaqueType} -> + [PatString, ArgTypeString, + format_type(OpaqueType, State1)]; + _ -> [PatString, ArgTypeString] + end, + {{Tag, PatTypes}, false}; false -> %% Try to find out if this is a default clause in a list - %% comprehension and supress this. A real Hack(tm) + %% comprehension and suppress this. A real Hack(tm) Force0 = case is_compiler_generated(cerl:get_ann(C)) of true -> diff --git a/lib/dialyzer/src/dialyzer_plt.erl b/lib/dialyzer/src/dialyzer_plt.erl index eb63e9e695..bfd3f84fc5 100644 --- a/lib/dialyzer/src/dialyzer_plt.erl +++ b/lib/dialyzer/src/dialyzer_plt.erl @@ -233,12 +233,8 @@ contains_mfa(#plt{info = Info, contracts = Contracts}, MFA) -> get_default_plt() -> case os:getenv("DIALYZER_PLT") of false -> - case os:getenv("HOME") of - false -> - plt_error("The HOME environment variable needs to be set " ++ - "so that Dialyzer knows where to find the default PLT"); - HomeDir -> filename:join(HomeDir, ".dialyzer_plt") - end; + {ok,[[HomeDir]]} = init:get_argument(home), + filename:join(HomeDir, ".dialyzer_plt"); UserSpecPlt -> UserSpecPlt end. diff --git a/lib/dialyzer/src/dialyzer_typesig.erl b/lib/dialyzer/src/dialyzer_typesig.erl index c4f8adf7ee..c3ba44fde7 100644 --- a/lib/dialyzer/src/dialyzer_typesig.erl +++ b/lib/dialyzer/src/dialyzer_typesig.erl @@ -2080,8 +2080,6 @@ v2_solve_disjunct(Disj, Map, V2State0) -> var_occurs_everywhere(V, Masks, NotFailed) -> ordsets:is_subset(NotFailed, get_mask(V, Masks)). --dialyzer({no_improper_lists, [v2_solve_disj/10, v2_solve_conj/12]}). - v2_solve_disj([I|Is], [C|Cs], I, Map0, V2State0, UL, MapL, Eval, Uneval, Failed0) -> Id = C#constraint_list.id, @@ -2100,10 +2098,10 @@ v2_solve_disj([I|Is], [C|Cs], I, Map0, V2State0, UL, MapL, Eval, Uneval, end; v2_solve_disj([], [], _I, _Map, V2State, UL, MapL, Eval, Uneval, Failed) -> {ok, V2State, lists:reverse(Eval), UL, MapL, lists:reverse(Uneval), Failed}; -v2_solve_disj(every_i, Cs, I, Map, V2State, UL, MapL, Eval, Uneval, Failed) -> +v2_solve_disj([every_i], Cs, I, Map, V2State, UL, MapL, Eval, Uneval, Failed) -> NewIs = case Cs of [] -> []; - _ -> [I|every_i] + _ -> [I, every_i] end, v2_solve_disj(NewIs, Cs, I, Map, V2State, UL, MapL, Eval, Uneval, Failed); v2_solve_disj(Is, [C|Cs], I, Map, V2State, UL, MapL, Eval, Uneval0, Failed) -> @@ -2199,11 +2197,11 @@ v2_solve_conj([], _Cs, _I, Map, Conj, IsFlat, V2State, UL, NewFs, VarsUp, v2_solve_conj(NewFlags, Cs, 1, Map, Conj, IsFlat, V2State, [], [], [U|VarsUp], Map, NewFlags) end; -v2_solve_conj(every_i, Cs, I, Map, Conj, IsFlat, V2State, UL, NewFs, VarsUp, +v2_solve_conj([every_i], Cs, I, Map, Conj, IsFlat, V2State, UL, NewFs, VarsUp, LastMap, LastFlags) -> NewIs = case Cs of [] -> []; - _ -> [I|every_i] + _ -> [I, every_i] end, v2_solve_conj(NewIs, Cs, I, Map, Conj, IsFlat, V2State, UL, NewFs, VarsUp, LastMap, LastFlags); @@ -2225,8 +2223,8 @@ add_mask_to_flags(Flags, [Im|M], I, L) when I > Im -> add_mask_to_flags(Flags, [_|M], _I, L) -> {umerge_mask(Flags, M), lists:reverse(L)}. -umerge_mask(every_i, _F) -> - every_i; +umerge_mask([every_i]=Is, _F) -> + Is; umerge_mask(Is, F) -> lists:umerge(Is, F). @@ -2242,7 +2240,7 @@ get_flags(#v2_state{constr_data = ConData}=V2State0, C) -> error -> ?debug("get_flags Id=~w Flags=all ~w\n", [Id, length(Cs)]), V2State = V2State0#v2_state{constr_data = maps:put(Id, {[],[]}, ConData)}, - {V2State, every_i}; + {V2State, [every_i]}; {ok, failed} -> {V2State0, failed_list}; {ok, {Part,U}} when U =/= [] -> diff --git a/lib/dialyzer/test/abstract_SUITE.erl b/lib/dialyzer/test/abstract_SUITE.erl index 269db3e836..0e84dfab24 100644 --- a/lib/dialyzer/test/abstract_SUITE.erl +++ b/lib/dialyzer/test/abstract_SUITE.erl @@ -7,7 +7,7 @@ -include_lib("common_test/include/ct.hrl"). -include("dialyzer_test_constants.hrl"). --export([suite/0, all/0, init_per_suite/0, init_per_suite/1]). +-export([suite/0, all/0, init_per_suite/0, init_per_suite/1, end_per_suite/1]). -export([generated_case/1]). suite() -> @@ -24,6 +24,10 @@ init_per_suite(Config) -> ok -> [{dialyzer_options, []}|Config] end. +end_per_suite(_Config) -> + %% This function is required since init_per_suite/1 exists. + ok. + generated_case(Config) when is_list(Config) -> %% Equivalent to: %% diff --git a/lib/dialyzer/test/opaque_SUITE_data/results/weird b/lib/dialyzer/test/opaque_SUITE_data/results/weird new file mode 100644 index 0000000000..d7f57cd152 --- /dev/null +++ b/lib/dialyzer/test/opaque_SUITE_data/results/weird @@ -0,0 +1,6 @@ + +weird_warning1.erl:15: Matching of pattern {'a', Dict} tagged with a record name violates the declared type of #b{q::queue:queue(_)} +weird_warning2.erl:13: Matching of pattern <{'b', Queue}, Key, Value> tagged with a record name violates the declared type of <#a{d::dict:dict(_,_)},'my_key','my_value'> +weird_warning3.erl:14: The call weird_warning3:add_element(#a{d::queue:queue(_)},'my_key','my_value') does not have a term of type #a{d::dict:dict(_,_)} | #b{q::queue:queue(_)} (with opaque subterms) as 1st argument +weird_warning3.erl:16: The attempt to match a term of type #a{d::queue:queue(_)} against the pattern {'a', Dict} breaks the opacity of queue:queue(_) +weird_warning3.erl:18: Matching of pattern {'b', Queue} tagged with a record name violates the declared type of #a{d::queue:queue(_)} diff --git a/lib/dialyzer/test/opaque_SUITE_data/src/recrec/dialyzer_dataflow.erl b/lib/dialyzer/test/opaque_SUITE_data/src/recrec/dialyzer_dataflow.erl index 6a5b593db0..53b08cc5c9 100644 --- a/lib/dialyzer/test/opaque_SUITE_data/src/recrec/dialyzer_dataflow.erl +++ b/lib/dialyzer/test/opaque_SUITE_data/src/recrec/dialyzer_dataflow.erl @@ -1340,7 +1340,7 @@ do_clause(C, Arg, ArgType0, OrigArgType, Map, State) -> {{Tag, PatTypes}, false}; false -> %% Try to find out if this is a default clause in a list - %% comprehension and supress this. A real Hack(tm) + %% comprehension and suppress this. A real Hack(tm) Force0 = case is_compiler_generated(cerl:get_ann(C)) of true -> diff --git a/lib/dialyzer/test/opaque_SUITE_data/src/weird/weird_warning1.erl b/lib/dialyzer/test/opaque_SUITE_data/src/weird/weird_warning1.erl new file mode 100644 index 0000000000..094138e72b --- /dev/null +++ b/lib/dialyzer/test/opaque_SUITE_data/src/weird/weird_warning1.erl @@ -0,0 +1,18 @@ +-module(weird_warning1). +-export([public_func/0]). + +-record(a, { + d = dict:new() :: dict:dict() + }). + +-record(b, { + q = queue:new() :: queue:queue() + }). + +public_func() -> + add_element(#b{}, my_key, my_value). + +add_element(#a{d = Dict}, Key, Value) -> + dict:store(Key, Value, Dict); +add_element(#b{q = Queue}, Key, Value) -> + queue:in({Key, Value}, Queue). diff --git a/lib/dialyzer/test/opaque_SUITE_data/src/weird/weird_warning2.erl b/lib/dialyzer/test/opaque_SUITE_data/src/weird/weird_warning2.erl new file mode 100644 index 0000000000..4e4512157b --- /dev/null +++ b/lib/dialyzer/test/opaque_SUITE_data/src/weird/weird_warning2.erl @@ -0,0 +1,14 @@ +-module(weird_warning2). +-export([public_func/0]). + +-record(a, {d = dict:new() :: dict:dict()}). + +-record(b, {q = queue:new() :: queue:queue()}). + +public_func() -> + add_element(#a{}, my_key, my_value). + +add_element(#a{d = Dict}, Key, Value) -> + dict:store(Key, Value, Dict); +add_element(#b{q = Queue}, Key, Value) -> + queue:in({Key, Value}, Queue). diff --git a/lib/dialyzer/test/opaque_SUITE_data/src/weird/weird_warning3.erl b/lib/dialyzer/test/opaque_SUITE_data/src/weird/weird_warning3.erl new file mode 100644 index 0000000000..b70ca645cb --- /dev/null +++ b/lib/dialyzer/test/opaque_SUITE_data/src/weird/weird_warning3.erl @@ -0,0 +1,19 @@ +-module(weird_warning3). +-export([public_func/0]). + +-record(a, { + d = dict:new() :: dict:dict() + }). + +-record(b, { + q = queue:new() :: queue:queue() + }). + +public_func() -> + %% Notice that t_to_string() will create "#a{d::queue:queue(_)}". + add_element({a, queue:new()}, my_key, my_value). + +add_element(#a{d = Dict}, Key, Value) -> + dict:store(Key, Value, Dict); +add_element(#b{q = Queue}, Key, Value) -> + queue:in({Key, Value}, Queue). diff --git a/lib/dialyzer/test/options1_SUITE_data/results/compiler b/lib/dialyzer/test/options1_SUITE_data/results/compiler index 30b6f4814a..cbb5115c91 100644 --- a/lib/dialyzer/test/options1_SUITE_data/results/compiler +++ b/lib/dialyzer/test/options1_SUITE_data/results/compiler @@ -31,6 +31,8 @@ cerl_inline.erl:2756: The pattern <{F, _L, D}, Vs> can never match the type <[1. compile.erl:788: The pattern {'error', Es} can never match the type {'ok',<<_:64,_:_*8>>} core_lint.erl:473: The pattern <{'c_atom', _, 'all'}, 'binary', _Def, St> can never match the type <_,#c_nil{} | {'c_atom' | 'c_char' | 'c_float' | 'c_int' | 'c_string' | 'c_tuple',_,_} | #c_cons{hd::#c_nil{} | {'c_atom' | 'c_char' | 'c_float' | 'c_int' | 'c_string' | 'c_tuple',_,_} | #c_cons{hd::{_,_} | {_,_,_} | {_,_,_,_},tl::{_,_} | {_,_,_} | {_,_,_,_}},tl::#c_nil{} | {'c_atom' | 'c_char' | 'c_float' | 'c_int' | 'c_string' | 'c_tuple',_,_} | #c_cons{hd::{_,_} | {_,_,_} | {_,_,_,_},tl::{_,_} | {_,_,_} | {_,_,_,_}}},[any()],_> core_lint.erl:505: The pattern <_Req, 'unknown', St> can never match the type <non_neg_integer(),non_neg_integer(),_> +sys_pre_expand.erl:625: Call to missing or unexported function erlang:hash/2 v3_codegen.erl:1569: The call v3_codegen:load_reg_1(V::any(),I::0,Rs::any(),pos_integer()) will never return since it differs in the 4th argument from the success typing arguments: (any(),0,maybe_improper_list(),0) v3_codegen.erl:1571: The call v3_codegen:load_reg_1(V::any(),I::0,[],pos_integer()) will never return since it differs in the 4th argument from the success typing arguments: (any(),0,maybe_improper_list(),0) v3_core.erl:646: Matching of pattern {'iprimop', _, _, _} tagged with a record name violates the declared type of #c_nil{anno::[any(),...]} | {'c_atom' | 'c_char' | 'c_float' | 'c_int' | 'c_string' | 'c_tuple' | 'c_var' | 'ibinary' | 'icatch' | 'ireceive1',[any(),...] | {_,_,_,_},_} | #c_cons{anno::[any(),...]} | #c_fname{anno::[any(),...]} | #iletrec{anno::{_,_,_,_},defs::[any(),...],body::[any(),...]} | #icase{anno::{_,_,_,_},args::[any()],clauses::[any()],fc::{_,_,_,_,_,_}} | #ireceive2{anno::{_,_,_,_},clauses::[any()],action::[any()]} | #ifun{anno::{_,_,_,_},id::[any(),...],vars::[any()],clauses::[any(),...],fc::{_,_,_,_,_,_}} | #imatch{anno::{_,_,_,_},guard::[],fc::{_,_,_,_,_,_}} | #itry{anno::{_,_,_,_},args::[any()],vars::[any(),...],body::[any(),...],evars::[any(),...],handler::[any(),...]} +v3_kernel.erl:1381: Call to missing or unexported function erlang:hash/2 diff --git a/lib/dialyzer/test/options1_SUITE_data/src/compiler/beam_disasm.erl b/lib/dialyzer/test/options1_SUITE_data/src/compiler/beam_disasm.erl index 0108f91b7f..cf2cbe8e2b 100644 --- a/lib/dialyzer/test/options1_SUITE_data/src/compiler/beam_disasm.erl +++ b/lib/dialyzer/test/options1_SUITE_data/src/compiler/beam_disasm.erl @@ -565,7 +565,7 @@ resolve_inst({make_fun2,Args},_,_,Lbls,Lambdas) -> [OldIndex] = resolve_args(Args), {value,{OldIndex,{F,A,_Lbl,_Index,NumFree,OldUniq}}} = lists:keysearch(OldIndex, 1, Lambdas), - [{_,{M,_,_}}|_] = Lbls, % Slighly kludgy. + [{_,{M,_,_}}|_] = Lbls, % Slightly kludgy. {make_fun2,{M,F,A},OldIndex,OldUniq,NumFree}; resolve_inst(Instr, Imports, Str, Lbls, _Lambdas) -> resolve_inst(Instr, Imports, Str, Lbls). diff --git a/lib/dialyzer/test/options1_SUITE_data/src/compiler/cerl_inline.erl b/lib/dialyzer/test/options1_SUITE_data/src/compiler/cerl_inline.erl index 95d2076ccf..8fca202b8c 100644 --- a/lib/dialyzer/test/options1_SUITE_data/src/compiler/cerl_inline.erl +++ b/lib/dialyzer/test/options1_SUITE_data/src/compiler/cerl_inline.erl @@ -951,7 +951,7 @@ i_letrec(Es, B, Xs, Ctxt, Ren, Env, S) -> %% Finally, we create new letrec-bindings for any and all %% residualised definitions. All referenced functions should have - %% been visited; the call to `visit' below is expected to retreive a + %% been visited; the call to `visit' below is expected to retrieve a %% cached expression. Rs1 = keep_referenced(Rs, S4), {Es1, S5} = mapfoldl(fun (R, S) -> @@ -997,7 +997,7 @@ i_apply(E, Ctxt, Ren, Env, S) -> %% location could be recycled after the flag has been tested, but %% there is no real advantage to that, because in practice, only %% 4-5% of all created store locations will ever be reused, while - %% there will be a noticable overhead for managing the free list.) + %% there will be a noticeable overhead for managing the free list.) case st__get_app_inlined(L, S3) of true -> %% The application was inlined, so we have the final @@ -2007,7 +2007,7 @@ residualize_operand(Opnd, E, S) -> case st__get_opnd_effect(Opnd#opnd.loc, S) of true -> %% The operand has not been visited, so we do that now, but - %% in `effect' context. (Waddell's algoritm does some stuff + %% in `effect' context. (Waddell's algorithm does some stuff %% here to account specially for the operand size, which %% appears unnecessary.) {E1, S1} = i(Opnd#opnd.expr, effect, Opnd#opnd.ren, diff --git a/lib/dialyzer/test/options1_SUITE_data/src/compiler/rec_env.erl b/lib/dialyzer/test/options1_SUITE_data/src/compiler/rec_env.erl index 01c2512397..76ae871aee 100644 --- a/lib/dialyzer/test/options1_SUITE_data/src/compiler/rec_env.erl +++ b/lib/dialyzer/test/options1_SUITE_data/src/compiler/rec_env.erl @@ -469,7 +469,7 @@ get(Key, Env) -> -define(MINIMUM_RANGE, 1000). -define(START_RANGE_FACTOR, 50). -define(MAX_RETRIES, 2). % retries before enlarging range --define(ENLARGE_FACTOR, 10). % range enlargment factor +-define(ENLARGE_FACTOR, 10). % range enlargement factor -ifdef(DEBUG). %% If you want to use these process dictionary counters, make sure to diff --git a/lib/dialyzer/test/options1_SUITE_data/src/compiler/sys_pre_expand.erl b/lib/dialyzer/test/options1_SUITE_data/src/compiler/sys_pre_expand.erl index 49a95a95e5..69139cd568 100644 --- a/lib/dialyzer/test/options1_SUITE_data/src/compiler/sys_pre_expand.erl +++ b/lib/dialyzer/test/options1_SUITE_data/src/compiler/sys_pre_expand.erl @@ -316,7 +316,7 @@ record_test_in_guard(Line, Term, Name, Vs, St) -> %% code bloat.) %% (4) Xref may be run on the abstract code, so the name in the %% abstract code must be erlang:is_record/3. - %% (5) To achive both (3) and (4) at the same time, set the name + %% (5) To achieve both (3) and (4) at the same time, set the name %% here to erlang:is_record/3, but mark it as compiler-generated. %% The v3_core pass will change the name to erlang:internal_is_record/3. Fs = record_fields(Name, St), diff --git a/lib/dialyzer/test/options1_SUITE_data/src/compiler/v3_codegen.erl b/lib/dialyzer/test/options1_SUITE_data/src/compiler/v3_codegen.erl index 33a322b466..acb49b5faf 100644 --- a/lib/dialyzer/test/options1_SUITE_data/src/compiler/v3_codegen.erl +++ b/lib/dialyzer/test/options1_SUITE_data/src/compiler/v3_codegen.erl @@ -1667,7 +1667,7 @@ bs_function({function,Name,Arity,CLabel,Asm0}=Func) -> %%% %%% Pass 1: Found out which bs_restore's that are needed. For now we assume -%%% that a bs_restore is needed unless it is directly preceeded by a bs_save. +%%% that a bs_restore is needed unless it is directly preceded by a bs_save. %%% bs_needed([{bs_save,Name},{bs_restore,Name}|T], N, _BsUsed, Dict) -> diff --git a/lib/dialyzer/test/plt_SUITE.erl b/lib/dialyzer/test/plt_SUITE.erl index fbfa979e1b..ba153c1c27 100644 --- a/lib/dialyzer/test/plt_SUITE.erl +++ b/lib/dialyzer/test/plt_SUITE.erl @@ -260,6 +260,8 @@ remove_plt(Config) -> ok. bad_dialyzer_attr(Config) -> + PrivDir = ?config(priv_dir, Config), + Plt = filename:join(PrivDir, "plt_bad_dialyzer_attr.plt"), Prog1 = <<"-module(dial). -dialyzer({no_return, [undef/0]}).">>, {ok, Beam1} = compile(Config, Prog1, dial, []), @@ -267,7 +269,7 @@ bad_dialyzer_attr(Config) -> "Analysis failed with error:\n" "Could not scan the following file(s):\n" " Unknown function undef/0 in line " ++ _} = - (catch run_dialyzer(plt_build, [Beam1], [])), + (catch run_dialyzer(plt_build, [Beam1], [{output_plt, Plt}])), Prog2 = <<"-module(dial). -dialyzer({no_return, [{undef,1,2}]}).">>, @@ -276,7 +278,7 @@ bad_dialyzer_attr(Config) -> "Analysis failed with error:\n" "Could not scan the following file(s):\n" " Bad function {undef,1,2} in line " ++ _} = - (catch run_dialyzer(plt_build, [Beam2], [])), + (catch run_dialyzer(plt_build, [Beam2], [{output_plt, Plt}])), ok. diff --git a/lib/dialyzer/test/r9c_SUITE_data/results/mnesia b/lib/dialyzer/test/r9c_SUITE_data/results/mnesia index bf67447ee7..71acdd9c9e 100644 --- a/lib/dialyzer/test/r9c_SUITE_data/results/mnesia +++ b/lib/dialyzer/test/r9c_SUITE_data/results/mnesia @@ -17,6 +17,7 @@ mnesia_frag.erl:294: The call mnesia_frag:remote_collect(Ref::reference(),{'erro mnesia_frag.erl:304: The call mnesia_frag:remote_collect(Ref::reference(),{'error',{'node_not_running',_}},[],OldSelectFun::fun(() -> [any()])) will never return since it differs in the 2nd argument from the success typing arguments: (reference(),'ok',[any()],fun(() -> [any()])) mnesia_frag.erl:312: The call mnesia_frag:remote_collect(Ref::reference(),LocalRes::{'error',_},[],OldSelectFun::fun(() -> [any()])) will never return since it differs in the 2nd argument from the success typing arguments: (reference(),'ok',[any()],fun(() -> [any()])) mnesia_frag_hash.erl:24: Callback info about the mnesia_frag_hash behaviour is not available +mnesia_frag_old_hash.erl:105: Call to missing or unexported function erlang:hash/2 mnesia_frag_old_hash.erl:23: Callback info about the mnesia_frag_hash behaviour is not available mnesia_index.erl:52: The call mnesia_lib:other_val(Var::{_,'commit_work' | 'index' | 'setorbag' | 'storage_type' | {'index',_}},_ReASoN_::any()) will never return since it differs in the 1st argument from the success typing arguments: ({_,'active_replicas' | 'where_to_read' | 'where_to_write'},any()) mnesia_lib.erl:1028: The pattern {'EXIT', Reason} can never match the type [any()] | {'error',_} diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct.erl b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct.erl index ed38b2f915..3829479a94 100644 --- a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct.erl +++ b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct.erl @@ -520,7 +520,7 @@ save_automatic_tagged_types([_M|Ms]) -> %% remove_in_set_imports/3 : %% input: list with tuples of each module's imports and module name %% respectively. -%% output: one list with same format but each occured import from a +%% output: one list with same format but each occurred import from a %% module in the input set (IMNameL) is removed. remove_in_set_imports([{{imports,ImpL},_ModName}|Rest],InputMNameL,Acc) -> NewImpL = remove_in_set_imports1(ImpL,InputMNameL,[]), @@ -1628,7 +1628,7 @@ tlv_tag1(<<1:1,PartialTag:7,Buffer/binary>>,Acc) -> tlv_tag1(Buffer,(Acc bsl 7) bor PartialTag). %% reads the content from the configuration file and returns the -%% selected part choosen by InfoType. Assumes that the config file +%% selected part chosen by InfoType. Assumes that the config file %% content is an Erlang term. read_config_file(ModuleName,InfoType) when atom(InfoType) -> CfgList = read_config_file(ModuleName), diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_check.erl b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_check.erl index c26b8f851b..a4f39bde74 100644 --- a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_check.erl +++ b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_check.erl @@ -4028,7 +4028,7 @@ check_sequence(S,Type,Comps) -> {CRelInf,NewComps2} = componentrelation_leadingattr(S,NewComps), % io:format("CRelInf: ~p~n",[CRelInf]), % io:format("NewComps2: ~p~n",[NewComps2]), - %% CompListWithTblInf has got a lot unecessary info about + %% CompListWithTblInf has got a lot unnecessary info about %% the involved class removed, as the class of the object %% set. CompListWithTblInf = get_tableconstraint_info(S,Type,NewComps2), @@ -4686,7 +4686,7 @@ any_component_relation(_,[],_,_,Acc) -> %% evaluate_atpath/4 finds out whether the at notation refers to the %% search level. The list of referenced names in the AtNot list shall %% begin with a name that exists on the level it refers to. If the -%% found AtPath is refering to the same sub-branch as the simple table +%% found AtPath is referring to the same sub-branch as the simple table %% has, then there shall not be any leading attribute info on this %% level. evaluate_atpath(_,[],Cnames,{innermost,AtPath=[Ref|_Refs]}) -> @@ -4857,7 +4857,7 @@ innertype_comprel1(S,T = #type{def=Def,constraint=Cons,tablecinf=TCI},Path) -> case Cons of [{componentrelation,{_,_,ObjectSet},AtList}|_Rest] -> %% This AtList must have an "outermost" at sign to be - %% relevent here. + %% relevant here. [{_,AL=[#'Externalvaluereference'{value=_Attr}|_R1]}|_R2] = AtList, %% #'ObjectClassFieldType'{class=ClassDef} = Def, diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_constructed_ber.erl b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_constructed_ber.erl index 392896932a..0b5ea85681 100644 --- a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_constructed_ber.erl +++ b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_constructed_ber.erl @@ -1259,7 +1259,7 @@ gen_dec_line(Erules,TopType,Cname,CTags,Type,OptOrMand,DecObjInf) -> end, case DecObjInf of {Cname,ObjSet} -> % this must be the component were an object is - %% choosen from the object set according to the table + %% chosen from the object set according to the table %% constraint. {[{ObjSet,Cname,asn1ct_gen:mk_var(asn1ct_name:curr(term))}], PostpDec}; diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_constructed_ber_bin_v2.erl b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_constructed_ber_bin_v2.erl index 9725da4d11..fb9ffb13db 100644 --- a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_constructed_ber_bin_v2.erl +++ b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_constructed_ber_bin_v2.erl @@ -1096,7 +1096,7 @@ gen_dec_line(Erules,TopType,Cname,CTags,Type,OptOrMand,DecObjInf) -> end, case DecObjInf of {Cname,ObjSet} -> % this must be the component were an object is - %% choosen from the object set according to the table + %% chosen from the object set according to the table %% constraint. {[{ObjSet,Cname,asn1ct_gen:mk_var(asn1ct_name:curr(term))}], PostpDec}; diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_parser2.erl b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_parser2.erl index 5f8c7a0de8..32676b3448 100644 --- a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_parser2.erl +++ b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1ct_parser2.erl @@ -2721,7 +2721,7 @@ prioritize_error(ErrList) -> end, NewErrList), case SplitErrs of - {[],UndefPosErrs} -> % if no error with Positon exists + {[],UndefPosErrs} -> % if no error with Position exists lists:last(UndefPosErrs); {IntPosErrs,_} -> IntPosReasons = lists:map(fun(X)->element(2,X) end,IntPosErrs), diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_ber_bin.erl b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_ber_bin.erl index 5854f8edbd..8f4d189b5a 100644 --- a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_ber_bin.erl +++ b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_ber_bin.erl @@ -1036,7 +1036,7 @@ decode_real2(Buffer0, Form, Len, RemBytes1) -> %% %% bitstring NamedBitList %% Val can be of: -%% - [identifiers] where only named identifers are set to one, +%% - [identifiers] where only named identifiers are set to one, %% the Constraint must then have some information of the %% bitlength. %% - [list of ones and zeroes] all bits diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_ber_bin_v2.erl b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_ber_bin_v2.erl index 0457425445..6e12d36579 100644 --- a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_ber_bin_v2.erl +++ b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_ber_bin_v2.erl @@ -1034,7 +1034,7 @@ decode_real_notag(_Buffer, _Form) -> %% %% bitstring NamedBitList %% Val can be of: -%% - [identifiers] where only named identifers are set to one, +%% - [identifiers] where only named identifiers are set to one, %% the Constraint must then have some information of the %% bitlength. %% - [list of ones and zeroes] all bits diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_per.erl b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_per.erl index b163aa24ac..97c92a2dd1 100644 --- a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_per.erl +++ b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_per.erl @@ -823,7 +823,7 @@ decode_enumerated(Buffer,C,NamedNumberTup) when tuple(NamedNumberTup) -> %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% bitstring NamedBitList %% Val can be of: -%% - [identifiers] where only named identifers are set to one, +%% - [identifiers] where only named identifiers are set to one, %% the Constraint must then have some information of the %% bitlength. %% - [list of ones and zeroes] all bits diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_per_bin.erl b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_per_bin.erl index 15986cc217..aa2cf5ba88 100644 --- a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_per_bin.erl +++ b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_per_bin.erl @@ -1000,7 +1000,7 @@ decode_enumerated(Buffer,C,NamedNumberTup) when tuple(NamedNumberTup) -> %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% bitstring NamedBitList %% Val can be of: -%% - [identifiers] where only named identifers are set to one, +%% - [identifiers] where only named identifiers are set to one, %% the Constraint must then have some information of the %% bitlength. %% - [list of ones and zeroes] all bits diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_per_bin_rt2ct.erl b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_per_bin_rt2ct.erl index 43d9bef54e..24f7949c21 100644 --- a/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_per_bin_rt2ct.erl +++ b/lib/dialyzer/test/r9c_SUITE_data/src/asn1/asn1rt_per_bin_rt2ct.erl @@ -1059,7 +1059,7 @@ decode_enumerated(Buffer,C,NamedNumberTup) when tuple(NamedNumberTup) -> %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% bitstring NamedBitList %% Val can be of: -%% - [identifiers] where only named identifers are set to one, +%% - [identifiers] where only named identifiers are set to one, %% the Constraint must then have some information of the %% bitlength. %% - [list of ones and zeroes] all bits diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/ftp.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/ftp.erl index 4f0ca99cce..8be5b0cd6e 100644 --- a/lib/dialyzer/test/r9c_SUITE_data/src/inets/ftp.erl +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/ftp.erl @@ -108,7 +108,7 @@ user(Pid, User, Pass) -> gen_server:call(Pid, {user, User, Pass}, infinity). %% user(Pid, User, Pass,Acc) -%% Purpose: Login whith a supplied account name +%% Purpose: Login with a supplied account name %% Args: Pid = pid(), User = Pass = Acc = string() %% Returns: ok | {error, euser} | {error, econn} | {error, eacct} user(Pid, User, Pass,Acc) -> diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/http.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/http.erl index cf05431f5a..039960dac7 100644 --- a/lib/dialyzer/test/r9c_SUITE_data/src/inets/http.erl +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/http.erl @@ -24,7 +24,7 @@ %%% - RFC 3310 Authentication and Key Agreement (AKA) (not yet!) %%% - HTTP/1.1 Specification Errata found at %%% http://world.std.com/~lawrence/http_errata.html -%%% Additionaly follows the following recommendations: +%%% Additionally follows the following recommendations: %%% - RFC 3143 Known HTTP Proxy/Caching Problems (not yet!) %%% - draft-nottingham-hdrreg-http-00.txt (not yet!) %%% diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/http_lib.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/http_lib.erl index ebefcd7ad7..28ea42c685 100644 --- a/lib/dialyzer/test/r9c_SUITE_data/src/inets/http_lib.erl +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/http_lib.erl @@ -697,7 +697,7 @@ lookup(Key,Val) -> %%% This code is for parsing trailer headers in chunked messages. %%% Will be deprecated whenever I have found an alternative working solution! %%% Note: -%%% - The header names are returned slighly different from what the what +%%% - The header names are returned slightly different from what the what %%% inet_drv returns read_headers_old(Scheme,Socket,Timeout) -> read_headers_old(<<>>,Scheme,Socket,Timeout,[],[]). diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpc_manager.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpc_manager.erl index 45beaa84f7..d2653184aa 100644 --- a/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpc_manager.erl +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpc_manager.erl @@ -95,7 +95,7 @@ abort_session(Addr,Sid,Msg) -> next_request(Addr,Sid) -> gen_server:call(?HMACALL,{next_request,Addr,Sid},infinity). -%%% Session handler has succeded to set up a new session, now register +%%% Session handler has succeed to set up a new session, now register %%% the socket register_socket(Addr,Sid,Socket) -> gen_server:cast(?HMACALL,{register_socket,Addr,Sid,Socket}). diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_manager.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_manager.erl index 85e06f43b6..3058ac3556 100644 --- a/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_manager.erl +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_manager.erl @@ -224,7 +224,7 @@ is_blocked(ServerRef) -> %% -%% Module API. Theese functions are intended for use from modules only. +%% Module API. These functions are intended for use from modules only. %% config_lookup(Port, Query) -> diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_parse.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_parse.erl index d7a698d65a..07f951d057 100644 --- a/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_parse.erl +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_parse.erl @@ -109,7 +109,7 @@ get_persistens(HTTPVersion,ParsedHeader,ConfigDB)-> %%If it is version prio to 1.1 kill the conneciton [$H, $T, $T, $P, $\/, $1, $.,N] -> case httpd_util:key1search(ParsedHeader,"connection","keep-alive")of - %%if the connection isnt ordered to go down let it live + %%if the connection isn't ordered to go down let it live %%The keep-alive value is the older http/1.1 might be older %%Clients that use it. "keep-alive" when N >= 49 -> diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_response.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_response.erl index 47c7fc1b8d..50e0e42786 100644 --- a/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_response.erl +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_response.erl @@ -34,7 +34,7 @@ -define(PROCEED_RESPONSE(StatusCode, Info), {proceed, [{response,{already_sent, StatusCode, - httpd_util:key1search(Info#mod.data,content_lenght)}}]}). + httpd_util:key1search(Info#mod.data,content_length)}}]}). -include("httpd.hrl"). diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/jnets_httpd.hrl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/jnets_httpd.hrl index 6b872d7c95..73edcf6b92 100644 --- a/lib/dialyzer/test/r9c_SUITE_data/src/inets/jnets_httpd.hrl +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/jnets_httpd.hrl @@ -60,7 +60,7 @@ % request_line, % string() Request Line headers, % #req_headers{} Parsed request headers entity_body= <<>>, % binary() Body of request - connection, % boolean() true if persistant connection + connection, % boolean() true if persistent connection status_code, % int() Status code logging % int() 0=No logging % 1=Only mod_log present diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_auth_mnesia.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_auth_mnesia.erl index e42494ff76..847d6e97c1 100644 --- a/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_auth_mnesia.erl +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_auth_mnesia.erl @@ -53,7 +53,7 @@ store_directory_data(Directory, DirData) -> %% API %% -%% Compability API +%% Compatibility API store_user(UserName, Password, Port, Dir, AccessPassword) -> diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_esi.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_esi.erl index 1203aeaa4c..a48f73274b 100644 --- a/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_esi.erl +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_esi.erl @@ -440,7 +440,7 @@ try_new_erl_scheme_method(Info,Env,Input,Mod,Func)-> %%---------------------------------------------------------------------- -%%The function recieves the data from the process that generates the page +%%The function receives the data from the process that generates the page %%and send the data to the client through the mod_cgi:send function %%---------------------------------------------------------------------- diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_htaccess.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_htaccess.erl index f600c65e92..d95c745b07 100644 --- a/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_htaccess.erl +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_htaccess.erl @@ -272,10 +272,10 @@ controlIfAllowed(AllowedNetworks,UserNetwork,IfAllowed,IfDenied)-> end. -%---------------------------------------------------------------------% -%The Denycontrol isn't neccessary to preform since the allow control % -%override the deny control % -%---------------------------------------------------------------------% +%--------------------------------------------------------------------% +%The Denycontrol isn't necessary to preform since the allow control % +%override the deny control % +%--------------------------------------------------------------------% controlDenyAllow(DeniedNetworks,AllowedNetworks,UserNetwork)-> case AllowedNetworks of [{allow,all}]-> @@ -657,7 +657,7 @@ getData2(HtAccessFileNames,SplittedPath,Info)-> %---------------------------------------------------------------------- %HtAccessFilenames is a list the names the accesssfiles can have -%Path is the shortest match agains all alias and documentroot +%Path is the shortest match against all alias and documentroot %rest of splitted path is a list of the parts of the path %Info is the mod recod from the server %---------------------------------------------------------------------- diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_range.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_range.erl index 4e6030d5e2..f2c45c4a3f 100644 --- a/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_range.erl +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_range.erl @@ -80,7 +80,7 @@ send_range_response(Path,Info,Ranges,FileInfo,LastModified)-> send_range_response(Path,Info,Start,Stop,FileInfo,LastModified) end. %%More than one range specified -%%Send a multipart reponse to the user +%%Send a multipart response to the user % %%An example of an multipart range response diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_responsecontrol.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_responsecontrol.erl index 76168f3890..a997db6880 100644 --- a/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_responsecontrol.erl +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_responsecontrol.erl @@ -48,8 +48,8 @@ do(Info) -> %%---------------------------------------------------------------------- -%%Control that the request header did not contians any limitations -%%wheather a response shall be createed or not +%%Control that the request header did not contains any limitations +%%whether a response shall be created or not %%---------------------------------------------------------------------- do_responsecontrol(Info) -> diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/mnesia/mnesia.erl b/lib/dialyzer/test/r9c_SUITE_data/src/mnesia/mnesia.erl index 19b571ac47..cc72a9b6fe 100644 --- a/lib/dialyzer/test/r9c_SUITE_data/src/mnesia/mnesia.erl +++ b/lib/dialyzer/test/r9c_SUITE_data/src/mnesia/mnesia.erl @@ -431,7 +431,7 @@ wrap_trans(State, Fun, Args, Retries, Mod, Kind) -> %% read lock is only set on the first node %% Nodes may either be a list of nodes or one node as an atom %% Mnesia on all Nodes must be connected to each other, but -%% it is not neccessary that they are up and running. +%% it is not necessary that they are up and running. lock(LockItem, LockKind) -> case get(mnesia_activity_state) of diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/mnesia/mnesia_bup.erl b/lib/dialyzer/test/r9c_SUITE_data/src/mnesia/mnesia_bup.erl index fdbf3e4481..a85a08e4f8 100644 --- a/lib/dialyzer/test/r9c_SUITE_data/src/mnesia/mnesia_bup.erl +++ b/lib/dialyzer/test/r9c_SUITE_data/src/mnesia/mnesia_bup.erl @@ -775,7 +775,7 @@ restore_tables([Rec | Recs], Header, Schema, State = {local, LocalTabs, L}) -> restore_tables([], _Header, _Schema, State) -> State. -%% Creates all neccessary dat files and inserts +%% Creates all necessary dat files and inserts %% the table definitions in the schema table %% %% Returns a list of local_tab tuples for all local tables diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/mnesia/mnesia_checkpoint.erl b/lib/dialyzer/test/r9c_SUITE_data/src/mnesia/mnesia_checkpoint.erl index 2b5c77b3ba..0403c7e978 100644 --- a/lib/dialyzer/test/r9c_SUITE_data/src/mnesia/mnesia_checkpoint.erl +++ b/lib/dialyzer/test/r9c_SUITE_data/src/mnesia/mnesia_checkpoint.erl @@ -332,7 +332,7 @@ really_retain(Name, Tab) -> %% %% {min, MinTabs} %% Minimize redundancy and only keep checkpoint info together with -%% one replica, preferrably at the local node. If any node involved +%% one replica, preferably at the local node. If any node involved %% the checkpoint goes down, the checkpoint is deactivated. %% %% {max, MaxTabs} @@ -345,7 +345,7 @@ really_retain(Name, Tab) -> %% {ram_overrides_dump, Tabs} %% Only applicable for ram_copies. Bool controls which versions of %% the records that should be included in the checkpoint state. -%% true means that the latest comitted records in ram (i.e. the +%% true means that the latest committed records in ram (i.e. the %% records that the application accesses) should be included %% in the checkpoint. false means that the records dumped to %% dat-files (the records that will be loaded at startup) should diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/mnesia/mnesia_loader.erl b/lib/dialyzer/test/r9c_SUITE_data/src/mnesia/mnesia_loader.erl index 70fee1741e..07667d73f5 100644 --- a/lib/dialyzer/test/r9c_SUITE_data/src/mnesia/mnesia_loader.erl +++ b/lib/dialyzer/test/r9c_SUITE_data/src/mnesia/mnesia_loader.erl @@ -61,7 +61,7 @@ do_get_disc_copy2(Tab, Reason, Storage, Type) when Storage == disc_copies -> Repair = mnesia_monitor:get_env(auto_repair), Args = [{keypos, 2}, public, named_table, Type], case Reason of - {dumper, _} -> %% Resources allready allocated + {dumper, _} -> %% Resources already allocated ignore; _ -> mnesia_monitor:mktab(Tab, Args), @@ -82,7 +82,7 @@ do_get_disc_copy2(Tab, Reason, Storage, Type) when Storage == disc_copies -> do_get_disc_copy2(Tab, Reason, Storage, Type) when Storage == ram_copies -> Args = [{keypos, 2}, public, named_table, Type], case Reason of - {dumper, _} -> %% Resources allready allocated + {dumper, _} -> %% Resources already allocated ignore; _ -> mnesia_monitor:mktab(Tab, Args), diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/mnesia/mnesia_locker.erl b/lib/dialyzer/test/r9c_SUITE_data/src/mnesia/mnesia_locker.erl index 701aa8f598..accb631f2a 100644 --- a/lib/dialyzer/test/r9c_SUITE_data/src/mnesia/mnesia_locker.erl +++ b/lib/dialyzer/test/r9c_SUITE_data/src/mnesia/mnesia_locker.erl @@ -170,14 +170,14 @@ loop(State) -> end; %% If test_set_sticky fails, we send this to all nodes - %% after aquiring a real write lock on Oid + %% after acquiring a real write lock on Oid {stick, {Tab, _}, N} -> ?ets_insert(mnesia_sticky_locks, {Tab, N}), loop(State); %% The caller which sends this message, must have first - %% aquired a write lock on the entire table + %% acquired a write lock on the entire table {unstick, Tab} -> ?ets_delete(mnesia_sticky_locks, Tab), loop(State); @@ -738,11 +738,11 @@ dirty_sticky_lock(Tab, Key, Nodes, Lock) -> sticky_wlock_table(Tid, Store, Tab) -> sticky_lock(Tid, Store, {Tab, ?ALL}, write). -%% aquire a wlock on Oid +%% acquire a wlock on Oid %% We store a {Tabname, write, Tid} in all locktables %% on all nodes containing a copy of Tabname %% We also store an item {{locks, Tab, Key}, write} in the -%% local store when we have aquired the lock. +%% local store when we have acquired the lock. %% wlock(Tid, Store, Oid) -> {Tab, Key} = Oid, diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/mnesia/mnesia_monitor.erl b/lib/dialyzer/test/r9c_SUITE_data/src/mnesia/mnesia_monitor.erl index d1ff09ce29..7fd5f70e23 100644 --- a/lib/dialyzer/test/r9c_SUITE_data/src/mnesia/mnesia_monitor.erl +++ b/lib/dialyzer/test/r9c_SUITE_data/src/mnesia/mnesia_monitor.erl @@ -144,7 +144,7 @@ check_protocol([{Node, {accept, Mon, _Version, Protocol}} | Tail], Protocols) -> end, [node(Mon) | check_protocol(Tail, Protocols)]; false -> - unlink(Mon), % Get rid of unneccessary link + unlink(Mon), % Get rid of unnecessary link check_protocol(Tail, Protocols) end; check_protocol([{Node, {reject, _Mon, Version, Protocol}} | Tail], Protocols) -> diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/mnesia/mnesia_schema.erl b/lib/dialyzer/test/r9c_SUITE_data/src/mnesia/mnesia_schema.erl index ec07e1c1ab..fbd1356a7f 100644 --- a/lib/dialyzer/test/r9c_SUITE_data/src/mnesia/mnesia_schema.erl +++ b/lib/dialyzer/test/r9c_SUITE_data/src/mnesia/mnesia_schema.erl @@ -1265,7 +1265,7 @@ make_change_table_copy_type(Tab, Node, ToS) -> %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% change index functions .... -%% Pos is allready added by 1 in both of these functions +%% Pos is already added by 1 in both of these functions add_table_index(Tab, Pos) -> schema_transaction(fun() -> do_add_table_index(Tab, Pos) end). diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/mnesia/mnesia_tm.erl b/lib/dialyzer/test/r9c_SUITE_data/src/mnesia/mnesia_tm.erl index 3e08354b5a..09e310530d 100644 --- a/lib/dialyzer/test/r9c_SUITE_data/src/mnesia/mnesia_tm.erl +++ b/lib/dialyzer/test/r9c_SUITE_data/src/mnesia/mnesia_tm.erl @@ -1615,7 +1615,7 @@ commit_participant(Coord, Tid, Bin, C0, DiscNs, _RamNs) -> do_abort(Tid, Bin) when binary(Bin) -> %% Possible optimization: - %% If we want we could pass arround a flag + %% If we want we could pass around a flag %% that tells us whether the binary contains %% schema ops or not. Only if the binary %% contains schema ops there are meningful diff --git a/lib/dialyzer/test/small_SUITE_data/src/tuple1.erl b/lib/dialyzer/test/small_SUITE_data/src/tuple1.erl index d608275efe..88ac486044 100644 --- a/lib/dialyzer/test/small_SUITE_data/src/tuple1.erl +++ b/lib/dialyzer/test/small_SUITE_data/src/tuple1.erl @@ -2,7 +2,7 @@ %%% File : tuple1.erl %%% Author : Tobias Lindahl <[email protected]> %%% Description : Exposed two bugs in the analysis; -%%% one supressed warning and one crash. +%%% one suppressed warning and one crash. %%% %%% Created : 13 Nov 2006 by Tobias Lindahl <[email protected]> %%%------------------------------------------------------------------- diff --git a/lib/diameter/doc/src/notes.xml b/lib/diameter/doc/src/notes.xml index c2bbed2e5a..28d6ea4fd0 100644 --- a/lib/diameter/doc/src/notes.xml +++ b/lib/diameter/doc/src/notes.xml @@ -255,8 +255,8 @@ first.</p> Fix decode of Grouped AVPs containing errors.</p> <p> RFC 6733 says this of Failed-AVP in 7.5:</p> - <p> - <taglist><item><p><c> In the case where the offending AVP + + <taglist><tag></tag><item><p><c> In the case where the offending AVP is embedded within a Grouped AVP, the Failed-AVP MAY contain the grouped AVP, which in turn contains the single offending AVP. The same method MAY be employed if @@ -265,11 +265,11 @@ first.</p> the grouped AVP hierarchy up to the single offending AVP. This enables the recipient to detect the location of the offending AVP when embedded in a - group.</c></p></item></taglist></p> + group.</c></p></item></taglist> <p> It says this of DIAMETER_INVALID_AVP_LENGTH in 7.1.5:</p> - <p> - <taglist><item><p><c> The request contained an AVP with + + <taglist><tag></tag><item><p><c> The request contained an AVP with an invalid length. A Diameter message indicating this error MUST include the offending AVPs within a Failed-AVP AVP. In cases where the erroneous AVP length value @@ -284,7 +284,8 @@ first.</p> the minimum AVP header length, it is sufficient to include an offending AVP header that is formulated by padding the incomplete AVP header with zero up to the - minimum AVP header length.</c></p></item></taglist></p> + minimum AVP header length.</c></p></item></taglist> + <p> The AVPs placed in the errors field of a diameter_packet record are intended to be appropriate for inclusion in a @@ -949,8 +950,8 @@ first.</p> Be lenient with the M-bit in Grouped AVPs.</p> <p> RFC 6733 says this, in 4.4:</p> - <p> - <taglist><item><p><c>Receivers of a Grouped AVP that does + + <taglist><tag></tag><item><p><c>Receivers of a Grouped AVP that does not have the 'M' (mandatory) bit set and one or more of the encapsulated AVPs within the group has the 'M' (mandatory) bit set MAY simply be ignored if the Grouped @@ -958,14 +959,14 @@ first.</p> encapsulated AVP with its 'M' (mandatory) bit set is further encapsulated within other sub-groups, i.e., other Grouped AVPs embedded within the Grouped - AVP.</c></p></item></taglist></p> + AVP.</c></p></item></taglist> <p> The first sentence is mangled but take it to mean this:</p> - <p> - <taglist><item><p><c>An unrecognized AVP of type Grouped + + <taglist><tag></tag><item><p><c>An unrecognized AVP of type Grouped that does not set the 'M' bit MAY be ignored even if one of its encapsulated AVPs sets the 'M' - bit.</c></p></item></taglist></p> + bit.</c></p></item></taglist> <p> This is a bit of a non-statement since if the AVP is unrecognized then its type is unknown. We therefore don't diff --git a/lib/diameter/include/diameter_gen.hrl b/lib/diameter/include/diameter_gen.hrl index 611ad796a9..5361510d69 100644 --- a/lib/diameter/include/diameter_gen.hrl +++ b/lib/diameter/include/diameter_gen.hrl @@ -424,7 +424,7 @@ d(true, _, Name, Avp, Acc) -> %% ... or not. Failures here won't be visible since they're a "normal" %% occurrence if the peer sends a faulty AVP that we need to respond -%% sensibly to. Log the occurence for traceability, but the peer will +%% sensibly to. Log the occurrence for traceability, but the peer will %% also receive info in the resulting answer message. d(false, Reason, Name, Avp, {Avps, Acc}) -> Stack = diameter_lib:get_stacktrace(), diff --git a/lib/diameter/src/base/diameter.erl b/lib/diameter/src/base/diameter.erl index e8f2f63f86..253f64133c 100644 --- a/lib/diameter/src/base/diameter.erl +++ b/lib/diameter/src/base/diameter.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2010-2016. All Rights Reserved. +%% Copyright Ericsson AB 2010-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -377,6 +377,7 @@ call(SvcName, App, Message) -> | {capabilities, [capability()]} | {capabilities_cb, evaluable()} | {capx_timeout, 'Unsigned32'()} + | {capx_strictness, boolean()} | {disconnect_cb, evaluable()} | {dpr_timeout, 'Unsigned32'()} | {dpa_timeout, 'Unsigned32'()} diff --git a/lib/diameter/src/base/diameter_callback.erl b/lib/diameter/src/base/diameter_callback.erl index f479cb6612..0e445492b8 100644 --- a/lib/diameter/src/base/diameter_callback.erl +++ b/lib/diameter/src/base/diameter_callback.erl @@ -35,7 +35,7 @@ %% in a callback applied to the atom-valued callback name and argument %% list. For all callbacks not to this module, the 'extra' field is a %% list of additional arguments, following arguments supplied by -%% diameter but preceeding those of the diameter:evaluable() being +%% diameter but preceding those of the diameter:evaluable() being %% applied. %% %% For example, the following config to diameter:start_service/2, in diff --git a/lib/diameter/src/base/diameter_config.erl b/lib/diameter/src/base/diameter_config.erl index fdbbd412a1..e10804c931 100644 --- a/lib/diameter/src/base/diameter_config.erl +++ b/lib/diameter/src/base/diameter_config.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2010-2016. All Rights Reserved. +%% Copyright Ericsson AB 2010-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -580,6 +580,9 @@ opt({K, Tmo}) K == dpa_timeout -> ?IS_UINT32(Tmo); +opt({capx_strictness, B}) -> + is_boolean(B); + opt({length_errors, T}) -> lists:member(T, [exit, handle, discard]); @@ -865,7 +868,7 @@ init_cb(List) -> V <- [proplists:get_value(F, List, D)]], #diameter_callback{} = list_to_tuple([diameter_callback | Values]). -%% Retreive and validate. +%% Retrieve and validate. get_opt(Key, List, Def, Other) -> init_opt(Key, get_opt(Key, List, Def), [Def|Other]). diff --git a/lib/diameter/src/base/diameter_peer_fsm.erl b/lib/diameter/src/base/diameter_peer_fsm.erl index 996e75a8d3..46d231da74 100644 --- a/lib/diameter/src/base/diameter_peer_fsm.erl +++ b/lib/diameter/src/base/diameter_peer_fsm.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2010-2016. All Rights Reserved. +%% Copyright Ericsson AB 2010-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -128,6 +128,7 @@ %% outgoing DPR; boolean says whether or not %% the request was sent explicitly with %% diameter:call/4. + strict :: boolean(), length_errors :: exit | handle | discard, incoming_maxlen :: integer() | infinity}). @@ -233,6 +234,7 @@ i({Ack, WPid, {M, Ref} = T, Opts, {SvcOpts, Nodes, Dict0, Svc}}) -> proplists:get_value(dpa_timeout, Opts, ?DPA_TIMEOUT)}), Tmo = proplists:get_value(capx_timeout, Opts, ?CAPX_TIMEOUT), + Strictness = proplists:get_value(capx_strictness, Opts, true), OnLengthErr = proplists:get_value(length_errors, Opts, exit), {TPid, Addrs} = start_transport(T, Rest, Svc), @@ -246,6 +248,7 @@ i({Ack, WPid, {M, Ref} = T, Opts, {SvcOpts, Nodes, Dict0, Svc}}) -> mode = M, service = svc(Svc, Addrs), length_errors = OnLengthErr, + strict = Strictness, incoming_maxlen = Maxlen}. %% The transport returns its local ip addresses so that different %% transports on the same service can use different local addresses. @@ -356,7 +359,7 @@ handle_info(T, #state{} = State) -> %% Note that there's no guarantee that the service and transport %% capabilities are good enough to build a CER/CEA that can be -%% succesfully encoded. It's not checked at diameter:add_transport/2 +%% successfully encoded. It's not checked at diameter:add_transport/2 %% since this can be called before creating the service. %% terminate/2 @@ -454,6 +457,9 @@ transition({timeout, _}, _) -> %% Outgoing message. transition({send, Msg}, S) -> outgoing(Msg, S); +transition({send, Msg, Route}, S) -> + put_route(Route), + outgoing(Msg, S); %% Request for graceful shutdown at remove_transport, stop_service of %% application shutdown. @@ -483,8 +489,10 @@ transition({'DOWN', _, process, TPid, _}, = S) -> start_next(S); -%% Transport has died after connection timeout. -transition({'DOWN', _, process, _, _}, _) -> +%% Transport has died after connection timeout, or handler process has +%% died. +transition({'DOWN', _, process, Pid, _}, _) -> + erase_route(Pid), ok; %% State query. @@ -494,6 +502,40 @@ transition({state, Pid}, #state{state = S, transport = TPid}) -> %% Crash on anything unexpected. +%% put_route/1 +%% +%% Map identifiers in an outgoing request to be able to lookup the +%% handler process when the answer is received. + +put_route({Pid, Ref, Seqs}) -> + MRef = monitor(process, Pid), + put(Pid, Seqs), + put(Seqs, {Pid, Ref, MRef}). + +%% get_route/1 + +get_route(#diameter_packet{header = #diameter_header{is_request = false}} + = Pkt) -> + Seqs = diameter_codec:sequence_numbers(Pkt), + case erase(Seqs) of + {Pid, Ref, MRef} -> + demonitor(MRef), + erase(Pid), + {Pid, Ref, self()}; + undefined -> + false + end; + +get_route(_) -> + false. + +%% erase_route/1 + +erase_route(Pid) -> + erase(erase(Pid)). + +%% capx/1 + capx(recv_CER) -> 'CER'; capx({'Wait-CEA', _, _}) -> @@ -576,8 +618,7 @@ incoming({Msg, NPid}, S) -> T catch {?MODULE, Name, Pkt} -> - S#state.parent ! {recv, self(), Name, {Pkt, NPid}}, - rcv(Name, Pkt, S) + incoming(Name, Pkt, NPid, S) end; incoming(Msg, S) -> @@ -585,10 +626,15 @@ incoming(Msg, S) -> recv(Msg, S) catch {?MODULE, Name, Pkt} -> - S#state.parent ! {recv, self(), Name, Pkt}, - rcv(Name, Pkt, S) + incoming(Name, Pkt, false, S) end. +%% incoming/4 + +incoming(Name, Pkt, NPid, #state{parent = Pid} = S) -> + Pid ! {recv, self(), get_route(Pkt), Name, Pkt, NPid}, + rcv(Name, Pkt, S). + %% recv/2 recv(#diameter_packet{header = #diameter_header{} = Hdr} @@ -614,6 +660,17 @@ recv1(_, when M < size(Bin) -> invalid(false, incoming_maxlen_exceeded, {size(Bin), H}); +%% Ignore anything but an expected CER/CEA if so configured. This is +%% non-standard behaviour. +recv1(Name, _, #state{state = {'Wait-CEA', _, _}, + strict = false}) + when Name /= 'CEA' -> + ok; +recv1(Name, _, #state{state = recv_CER, + strict = false}) + when Name /= 'CER' -> + ok; + %% Incoming request after outgoing DPR: discard. Don't discard DPR, so %% both ends don't do so when sending simultaneously. recv1(Name, diff --git a/lib/diameter/src/base/diameter_service.erl b/lib/diameter/src/base/diameter_service.erl index ccf68f4d93..e4f77e3a24 100644 --- a/lib/diameter/src/base/diameter_service.erl +++ b/lib/diameter/src/base/diameter_service.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2010-2016. All Rights Reserved. +%% Copyright Ericsson AB 2010-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -1858,13 +1858,6 @@ eq(Any, Id, PeerId) -> %% OctetString() can be specified as an iolist() so test for string %% rather then term equality. -%% transports/1 - -transports(#state{watchdogT = WatchdogT}) -> - ets:select(WatchdogT, [{#watchdog{peer = '$1', _ = '_'}, - [{'is_pid', '$1'}], - ['$1']}]). - %% --------------------------------------------------------------------------- %% # service_info/2 %% --------------------------------------------------------------------------- @@ -1887,7 +1880,6 @@ transports(#state{watchdogT = WatchdogT}) -> -define(ALL_INFO, [capabilities, applications, transport, - pending, options]). %% The rest. @@ -1981,7 +1973,6 @@ complete_info(Item, #state{service = Svc} = S) -> applications -> info_apps(S); transport -> info_transport(S); options -> info_options(S); - pending -> info_pending(S); keys -> ?ALL_INFO ++ ?CAP_INFO ++ ?OTHER_INFO; all -> service_info(?ALL_INFO, S); statistics -> info_stats(S); @@ -2189,13 +2180,6 @@ info_apps(#state{service = #diameter_service{applications = Apps}}) -> mk_app(#diameter_app{} = A) -> lists:zip(record_info(fields, diameter_app), tl(tuple_to_list(A))). -%% info_pending/1 -%% -%% One entry for each outgoing request whose answer is outstanding. - -info_pending(#state{} = S) -> - diameter_traffic:pending(transports(S)). - %% info_info/1 %% %% Extract process_info from connections info. diff --git a/lib/diameter/src/base/diameter_sup.erl b/lib/diameter/src/base/diameter_sup.erl index 482289cb9a..01c51f0856 100644 --- a/lib/diameter/src/base/diameter_sup.erl +++ b/lib/diameter/src/base/diameter_sup.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2010-2016. All Rights Reserved. +%% Copyright Ericsson AB 2010-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -42,7 +42,7 @@ -define(TABLES, [{diameter_sequence, [set]}, {diameter_service, [set, {keypos, 3}]}, - {diameter_request, [bag]}, + {diameter_request, [set]}, {diameter_config, [bag, {keypos, 2}]}]). %% start_link/0 diff --git a/lib/diameter/src/base/diameter_traffic.erl b/lib/diameter/src/base/diameter_traffic.erl index d93a3e71e3..bc1ccf4feb 100644 --- a/lib/diameter/src/base/diameter_traffic.erl +++ b/lib/diameter/src/base/diameter_traffic.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2013-2016. All Rights Reserved. +%% Copyright Ericsson AB 2013-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -30,7 +30,7 @@ -export([send_request/4]). %% towards diameter_watchdog --export([receive_message/4]). +-export([receive_message/6]). %% towards diameter_peer_fsm and diameter_watchdog -export([incr/4, @@ -40,11 +40,11 @@ %% towards diameter_service -export([make_recvdata/1, peer_up/1, - peer_down/1, - pending/1]). + peer_down/1]). -%% towards ?MODULE --export([send/1]). %% send from remote node +%% internal +-export([send/1, %% send from remote node + init/1]). %% monitor process start -include_lib("diameter/include/diameter.hrl"). -include("diameter_internal.hrl"). @@ -57,14 +57,12 @@ -define(DEFAULT_TIMEOUT, 5000). %% for outgoing requests -define(DEFAULT_SPAWN_OPTS, []). -%% Table containing outgoing requests for which a reply has yet to be -%% received. +%% Table containing outgoing entries that live and die with +%% peer_up/down. The name is historic, since the table used to contain +%% information about outgoing requests for which an answer has yet to +%% be received. -define(REQUEST_TABLE, diameter_request). -%% Workaround for dialyzer's lack of understanding of match specs. --type match(T) - :: T | '_' | '$1' | '$2' | '$3' | '$4'. - %% Record diameter:call/4 options are parsed into. -record(options, {filter = none :: diameter:peer_filter(), @@ -72,7 +70,7 @@ timeout = ?DEFAULT_TIMEOUT :: 0..16#FFFFFFFF, detach = false :: boolean()}). -%% Term passed back to receive_message/4 with every incoming message. +%% Term passed back to receive_message/6 with every incoming message. -record(recvdata, {peerT :: ets:tid(), service_name :: diameter:service_name(), @@ -87,12 +85,12 @@ %% Record stored in diameter_request for each outgoing request. -record(request, - {ref :: match(reference()), %% used to receive answer - caller :: match(pid()), %% calling process - handler :: match(pid()), %% request process - transport :: match(pid()), %% peer process - caps :: match(#diameter_caps{}), %% of connection - packet :: match(#diameter_packet{})}). %% of request + {ref :: reference(), %% used to receive answer + caller :: pid() | undefined, %% calling process + handler :: pid(), %% request process + transport :: pid() | undefined, %% peer process + caps :: #diameter_caps{} | undefined, %% of connection + packet :: #diameter_packet{} | undefined}). %% of request %% --------------------------------------------------------------------------- %% # make_recvdata/1 @@ -113,26 +111,27 @@ make_recvdata([SvcName, PeerT, Apps, SvcOpts | _]) -> %% peer_up/1 %% --------------------------------------------------------------------------- -%% Insert an element that is used to detect whether or not there has -%% been a failover when inserting an outgoing request. +%% Start a process that dies with peer_down/1, on which request +%% processes can monitor. There is no other process that dies with +%% peer_down since failover doesn't imply the loss of transport in the +%% case of a watchdog transition into state SUSPECT. peer_up(TPid) -> - ets:insert(?REQUEST_TABLE, {TPid}). + proc_lib:start(?MODULE, init, [TPid]). + +init(TPid) -> + ets:insert(?REQUEST_TABLE, {TPid, self()}), + proc_lib:init_ack(self()), + proc_lib:hibernate(erlang, exit, [{shutdown, TPid}]). %% --------------------------------------------------------------------------- %% peer_down/1 %% --------------------------------------------------------------------------- peer_down(TPid) -> - ets:delete_object(?REQUEST_TABLE, {TPid}), - lists:foreach(fun failover/1, ets:lookup(?REQUEST_TABLE, TPid)). -%% Note that a request process can store its request after failover -%% notifications are sent here: insert_request/2 sends the notification -%% in that case. - -%% failover/1 - -failover({_TPid, {Pid, TRef}}) -> - Pid ! {failover, TRef}. + [{_, Pid}] = ets:lookup(?REQUEST_TABLE, TPid), + ets:delete(?REQUEST_TABLE, TPid), + Pid ! ok, %% make it die + Pid. %% --------------------------------------------------------------------------- %% incr/4 @@ -207,54 +206,25 @@ incr_rc(Dir, Pkt, TPid, Dict0) -> incr_rc(Dir, Pkt, TPid, {Dict0, Dict0, Dict0}). %% --------------------------------------------------------------------------- -%% pending/1 -%% --------------------------------------------------------------------------- - -pending(TPids) -> - MatchSpec = [{{'$1', - #request{caller = '$2', - handler = '$3', - transport = '$4', - _ = '_'}, - '_'}, - [?ORCOND([{'==', T, '$4'} || T <- TPids])], - [{{'$1', [{{caller, '$2'}}, - {{handler, '$3'}}, - {{transport, '$4'}}]}}]}], - - try - ets:select(?REQUEST_TABLE, MatchSpec) - catch - error: badarg -> [] %% service has gone down - end. - -%% --------------------------------------------------------------------------- -%% # receive_message/4 +%% # receive_message/6 %% %% Handle an incoming Diameter message. %% --------------------------------------------------------------------------- -%% Handle an incoming Diameter message in the watchdog process. This -%% used to come through the service process but this avoids that -%% becoming a bottleneck. +%% Handle an incoming Diameter message in the watchdog process. -receive_message(TPid, {Pkt, NPid}, Dict0, RecvData) -> - NPid ! {diameter, incoming(TPid, Pkt, Dict0, RecvData)}; +receive_message(TPid, Route, Pkt, false, Dict0, RecvData) -> + incoming(TPid, Route, Pkt, Dict0, RecvData); -receive_message(TPid, Pkt, Dict0, RecvData) -> - incoming(TPid, Pkt, Dict0, RecvData). +receive_message(TPid, Route, Pkt, NPid, Dict0, RecvData) -> + NPid ! {diameter, incoming(TPid, Route, Pkt, Dict0, RecvData)}. %% incoming/4 -incoming(TPid, Pkt, Dict0, RecvData) +incoming(TPid, Route, Pkt, Dict0, RecvData) when is_pid(TPid) -> #diameter_packet{header = #diameter_header{is_request = R}} = Pkt, - recv(R, - (not R) andalso lookup_request(Pkt, TPid), - TPid, - Pkt, - Dict0, - RecvData). + recv(R, Route, TPid, Pkt, Dict0, RecvData). %% recv/6 @@ -269,8 +239,8 @@ recv(true, false, TPid, Pkt, Dict0, T) -> end; %% ... answer to known request ... -recv(false, #request{ref = Ref, handler = Pid} = Req, _, Pkt, Dict0, _) -> - Pid ! {answer, Ref, Req, Dict0, Pkt}, +recv(false, {Pid, Ref, TPid}, _, Pkt, Dict0, _) -> + Pid ! {answer, Ref, TPid, Dict0, Pkt}, {answer, Pid}; %% Note that failover could have happened prior to this message being @@ -1503,32 +1473,39 @@ send_R(Pkt0, packet = Pkt0}, incr(send, Pkt, TPid, AppDict), - TRef = send_request(TPid, Pkt, Req, SvcName, Timeout), + {TRef, MRef} = zend_requezt(TPid, Pkt, Req, SvcName, Timeout), Pid ! Ref, %% tell caller a send has been attempted handle_answer(SvcName, App, - recv_A(Timeout, SvcName, App, Opts, {TRef, Req})). + recv_A(Timeout, SvcName, App, Opts, {TRef, MRef, Req})). %% recv_A/5 -recv_A(Timeout, SvcName, App, Opts, {TRef, #request{ref = Ref} = Req}) -> +recv_A(Timeout, SvcName, App, Opts, {TRef, MRef, #request{ref = Ref} = Req}) -> %% Matching on TRef below ensures we ignore messages that pertain %% to a previous transport prior to failover. The answer message - %% includes the #request{} since it's not necessarily Req; that - %% is, from the last peer to which we've transmitted. + %% includes the pid of the transport on which it was received, + %% which may not be the last peer to which we've transmitted. receive - {answer = A, Ref, Rq, Dict0, Pkt} -> %% Answer from peer - {A, Rq, Dict0, Pkt}; + {answer = A, Ref, TPid, Dict0, Pkt} -> %% Answer from peer + {A, #request{} = erase(TPid), Dict0, Pkt}; {timeout = Reason, TRef, _} -> %% No timely reply {error, Req, Reason}; - {failover, TRef} -> %% Service says peer has gone down - retransmit(pick_peer(SvcName, App, Req, Opts), - Req, - Opts, - SvcName, - Timeout) + {'DOWN', MRef, process, _, _} when false /= MRef -> %% local peer_down + failover(SvcName, App, Req, Opts, Timeout); + {failover, TRef} -> %% local or remote peer_down + failover(SvcName, App, Req, Opts, Timeout) end. +%% failover/5 + +failover(SvcName, App, Req, Opts, Timeout) -> + retransmit(pick_peer(SvcName, App, Req, Opts), + Req, + Opts, + SvcName, + Timeout). + %% handle_answer/3 handle_answer(SvcName, App, {error, Req, Reason}) -> @@ -1705,44 +1682,63 @@ encode(DictT, TPid, #diameter_packet{bin = undefined} = Pkt) -> encode(_, _, #diameter_packet{} = Pkt) -> Pkt. +%% zend_requezt/5 +%% +%% Strip potentially large record fields that aren't used by the +%% processes the records can be send to, possibly on a remote node. + +zend_requezt(TPid, Pkt, Req, SvcName, Timeout) -> + put(TPid, Req), + send_request(TPid, z(Pkt), Req, SvcName, Timeout). + %% send_request/5 send_request(TPid, #diameter_packet{bin = Bin} = Pkt, Req, _SvcName, Timeout) when node() == node(TPid) -> Seqs = diameter_codec:sequence_numbers(Bin), TRef = erlang:start_timer(Timeout, self(), TPid), - Entry = {Seqs, #request{handler = Pid} = Req, TRef}, - - %% Ensure that request table is cleaned even if the process is - %% killed. - spawn(fun() -> diameter_lib:wait([Pid]), delete_request(Entry) end), - - insert_request(Entry), - send(TPid, Pkt), - TRef; + send(TPid, Pkt, _Route = {self(), Req#request.ref, Seqs}), + {TRef, _MRef = peer_monitor(TPid, TRef)}; %% Send using a remote transport: spawn a process on the remote node %% to relay the answer. send_request(TPid, #diameter_packet{} = Pkt, Req, SvcName, Timeout) -> TRef = erlang:start_timer(Timeout, self(), TPid), - T = {TPid, Pkt, Req, SvcName, Timeout, TRef}, + T = {TPid, Pkt, z(Req), SvcName, Timeout, TRef}, spawn(node(TPid), ?MODULE, send, [T]), - TRef. + {TRef, false}. + +%% z/1 +%% +%% Avoid sending potentially large terms unnecessarily. The records +%% themselves are retained since they're sent between nodes in send/1 +%% and changing what's sent causes upgrade issues. + +z(#request{ref = Ref, handler = Pid}) -> + #request{ref = Ref, + handler = Pid}; + +z(#diameter_packet{header = H, bin = Bin, transport_data = T}) -> + #diameter_packet{header = H, + bin = Bin, + transport_data = T}. %% send/1 send({TPid, Pkt, #request{handler = Pid} = Req0, SvcName, Timeout, TRef}) -> Req = Req0#request{handler = self()}, - recv(TPid, Pid, TRef, send_request(TPid, Pkt, Req, SvcName, Timeout)). + recv(TPid, Pid, TRef, zend_requezt(TPid, Pkt, Req, SvcName, Timeout)). %% recv/4 %% %% Relay an answer from a remote node. -recv(TPid, Pid, TRef, LocalTRef) -> +recv(TPid, Pid, TRef, {LocalTRef, MRef}) -> receive {answer, _, _, _, _} = A -> Pid ! A; + {'DOWN', MRef, process, _, _} -> + Pid ! {failover, TRef}; {failover = T, LocalTRef} -> Pid ! {T, TRef}; T -> @@ -1751,14 +1747,13 @@ recv(TPid, Pid, TRef, LocalTRef) -> %% send/2 -send(Pid, Pkt) -> %% Strip potentially large message terms. - #diameter_packet{header = H, - bin = Bin, - transport_data = T} - = Pkt, - Pid ! {send, #diameter_packet{header = H, - bin = Bin, - transport_data = T}}. +send(Pid, Pkt) -> + Pid ! {send, Pkt}. + +%% send/3 + +send(Pid, Pkt, Route) -> + Pid ! {send, Pkt, Route}. %% retransmit/4 @@ -1768,8 +1763,8 @@ retransmit({TPid, Caps, App} = Req, SvcName, Timeout) -> - have_request(Pkt0, TPid) %% Don't failover to a peer we've - andalso ?THROW(timeout), %% already sent to. + undefined == get(TPid) %% Don't failover to a peer we've + orelse ?THROW(timeout), %% already sent to. Pkt = make_retransmit_packet(Pkt0), @@ -1822,56 +1817,20 @@ resend_request(Pkt0, ?LOG(retransmission, Pkt#diameter_packet.header), incr(TPid, {msg_id(Pkt, AppDict), send, retransmission}), - TRef = send_request(TPid, Pkt, Req, SvcName, Tmo), - {TRef, Req}. - -%% insert_request/1 - -insert_request({_Seqs, #request{transport = TPid}, TRef} = T) -> - ets:insert(?REQUEST_TABLE, [T, {TPid, {self(), TRef}}]), - is_peer_up(TPid) - orelse (self() ! {failover, TRef}). %% failover/1 may have missed - -%% is_peer_up/1 -%% -%% Is the entry written by peer_up/1 and deleted by peer_down/1 still -%% in the request table? + {TRef, MRef} = zend_requezt(TPid, Pkt, Req, SvcName, Tmo), + {TRef, MRef, Req}. -is_peer_up(TPid) -> - Spec = [{{TPid}, [], ['$_']}], - '$end_of_table' /= ets:select(?REQUEST_TABLE, Spec, 1). +%% peer_monitor/2 -%% lookup_request/2 -%% -%% Note the match on both the key and transport pid. The latter is -%% necessary since the same Hop-by-Hop and End-to-End identifiers are -%% reused in the case of retransmission. - -lookup_request(Msg, TPid) -> - Seqs = diameter_codec:sequence_numbers(Msg), - Spec = [{{Seqs, #request{transport = TPid, _ = '_'}, '_'}, - [], - ['$_']}], - case ets:select(?REQUEST_TABLE, Spec) of - [{_, Req, _}] -> - Req; - [] -> +peer_monitor(TPid, TRef) -> + case ets:lookup(?REQUEST_TABLE, TPid) of %% at peer_up/1 + [{_, MPid}] -> + monitor(process, MPid); + [] -> %% transport has gone down + self() ! {failover, TRef}, false end. -%% delete_request/1 - -delete_request({_Seqs, #request{handler = Pid, transport = TPid}, TRef} = T) -> - Spec = [{R, [], [true]} || R <- [T, {TPid, {Pid, TRef}}]], - ets:select_delete(?REQUEST_TABLE, Spec). - -%% have_request/2 - -have_request(Pkt, TPid) -> - Seqs = diameter_codec:sequence_numbers(Pkt), - Pat = {Seqs, #request{transport = TPid, _ = '_'}, '_'}, - '$end_of_table' /= ets:select(?REQUEST_TABLE, [{Pat, [], ['$_']}], 1). - %% get_destination/2 get_destination(Dict, Msg) -> diff --git a/lib/diameter/src/base/diameter_watchdog.erl b/lib/diameter/src/base/diameter_watchdog.erl index 2ba60a65fb..f28b8f2910 100644 --- a/lib/diameter/src/base/diameter_watchdog.erl +++ b/lib/diameter/src/base/diameter_watchdog.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2010-2016. All Rights Reserved. +%% Copyright Ericsson AB 2010-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -283,7 +283,7 @@ event(Msg, ?LOG(transition, {From, To}). data(Msg, TPid, reopen, okay) -> - {recv, TPid, 'DWA', _Pkt} = Msg, %% assert + {recv, TPid, false, 'DWA', _Pkt, _NPid} = Msg, %% assert {TPid, T} = eraser(open), [T]; @@ -447,12 +447,14 @@ transition({'DOWN', _, process, TPid, _Reason} = D, end; %% Incoming message. -transition({recv, TPid, Name, PktT}, #watchdog{transport = TPid} = S) -> +transition({recv, TPid, Route, Name, Pkt, NPid}, + #watchdog{transport = TPid} + = S) -> try - incoming(Name, PktT, S) + incoming(Name, Pkt, NPid, S) catch #watchdog{dictionary = Dict0, receive_data = T} = NS -> - diameter_traffic:receive_message(TPid, PktT, Dict0, T), + diameter_traffic:receive_message(TPid, Route, Pkt, NPid, Dict0, T), NS end; @@ -582,15 +584,17 @@ send_watchdog(#watchdog{pending = false, %% Don't count encode errors since we don't expect any on DWR/DWA. -%% incoming/3 +%% incoming/4 -incoming(Name, {Pkt, NPid}, S) -> - NS = recv(Name, Pkt, S), - NPid ! {diameter, discard}, - NS; +incoming(Name, Pkt, false, S) -> + recv(Name, Pkt, S); -incoming(Name, Pkt, S) -> - recv(Name, Pkt, S). +incoming(Name, Pkt, NPid, S) -> + try + recv(Name, Pkt, S) + after + NPid ! {diameter, discard} + end. %% recv/3 diff --git a/lib/diameter/src/diameter.appup.src b/lib/diameter/src/diameter.appup.src index b1b8e38d39..eb5a5a44f3 100644 --- a/lib/diameter/src/diameter.appup.src +++ b/lib/diameter/src/diameter.appup.src @@ -2,7 +2,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2010-2016. All Rights Reserved. +%% Copyright Ericsson AB 2010-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -50,10 +50,8 @@ {"1.11", [{restart_application, diameter}]}, %% 18.1 {"1.11.1", [{restart_application, diameter}]}, %% 18.2 {"1.11.2", [{restart_application, diameter}]}, %% 18.3 - {"1.12", [{load_module, diameter_lib}, %% 19.0 - {load_module, diameter_traffic}, - {load_module, diameter_tcp}, - {load_module, diameter_sctp}]} + {"1.12", [{restart_application, diameter}]}, %% 19.0 + {"1.12.1", [{restart_application, diameter}]} %% 19.1 ], [ {"0.9", [{restart_application, diameter}]}, @@ -85,9 +83,7 @@ {"1.11", [{restart_application, diameter}]}, {"1.11.1", [{restart_application, diameter}]}, {"1.11.2", [{restart_application, diameter}]}, - {"1.12", [{load_module, diameter_sctp}, - {load_module, diameter_tcp}, - {load_module, diameter_traffic}, - {load_module, diameter_lib}]} + {"1.12", [{restart_application, diameter}]}, + {"1.12.1", [{restart_application, diameter}]} ] }. diff --git a/lib/diameter/src/info/diameter_info.erl b/lib/diameter/src/info/diameter_info.erl index 59a3b94ee4..2a27600346 100644 --- a/lib/diameter/src/info/diameter_info.erl +++ b/lib/diameter/src/info/diameter_info.erl @@ -195,7 +195,7 @@ format(Tables, SFun, CFun) %%% %%% Description: Pretty-print records in a named tables as collected %%% from local and remote nodes. Each table listing is -%%% preceeded by a banner. +%%% preceded by a banner. %%% ---------------------------------------------------------- format(Local, Remote, SFun) -> diff --git a/lib/diameter/src/transport/diameter_sctp.erl b/lib/diameter/src/transport/diameter_sctp.erl index f48e4347ee..ad9f4b0d80 100644 --- a/lib/diameter/src/transport/diameter_sctp.erl +++ b/lib/diameter/src/transport/diameter_sctp.erl @@ -402,7 +402,7 @@ handle_info(T, #transport{} = S) -> handle_info(T, #listener{} = S) -> {noreply, #listener{} = l(T,S)}. -%% Prior to the possiblity of setting pool_size on in transport +%% Prior to the possibility of setting pool_size on in transport %% configuration, a new accepting transport was only started following %% the death of a predecessor, so that there was only at most one %% previously started transport process waiting for an association. diff --git a/lib/diameter/test/diameter_pool_SUITE.erl b/lib/diameter/test/diameter_pool_SUITE.erl index eadb354a1d..383fa0a031 100644 --- a/lib/diameter/test/diameter_pool_SUITE.erl +++ b/lib/diameter/test/diameter_pool_SUITE.erl @@ -115,7 +115,7 @@ connect(ClientProt, ServerProt) -> %% 'up' events. (Although it's likely.) sleep(), {9,5} = count("server", LRef, accept), %% 5 connections + 4 accepting - %% Ensure ther are still the expected number of accepting transports + %% Ensure there are still the expected number of accepting transports %% after stopping the client service. ok = diameter:stop_service("client"), sleep(), diff --git a/lib/diameter/vsn.mk b/lib/diameter/vsn.mk index 23219950bb..94d9d72a48 100644 --- a/lib/diameter/vsn.mk +++ b/lib/diameter/vsn.mk @@ -1,6 +1,6 @@ # %CopyrightBegin% # -# Copyright Ericsson AB 2010-2016. All Rights Reserved. +# Copyright Ericsson AB 2010-2017. All Rights Reserved. # # Licensed under the Apache License, Version 2.0 (the "License"); # you may not use this file except in compliance with the License. @@ -17,5 +17,5 @@ # %CopyrightEnd% APPLICATION = diameter -DIAMETER_VSN = 1.12.1 +DIAMETER_VSN = 1.12.2 APP_VSN = $(APPLICATION)-$(DIAMETER_VSN)$(PRE_VSN) diff --git a/lib/edoc/src/edoc_tags.erl b/lib/edoc/src/edoc_tags.erl index 7e59f373b2..da078de0b9 100644 --- a/lib/edoc/src/edoc_tags.erl +++ b/lib/edoc/src/edoc_tags.erl @@ -227,7 +227,7 @@ filter_tags([#tag{name = N, line = L} = T | Ts], Tags, Where, Ts1) -> filter_tags([], _, _, Ts) -> lists:reverse(Ts). -%% Check occurrances of tags. +%% Check occurrences of tags. check_tags(Ts, Allow, Single, Where) -> check_tags(Ts, Allow, Single, Where, false, sets:new()). diff --git a/lib/eldap/test/README b/lib/eldap/test/README index ec774c1ae3..af1bf6a082 100644 --- a/lib/eldap/test/README +++ b/lib/eldap/test/README @@ -16,7 +16,7 @@ To start slapd: This will however not work, since slapd is guarded by apparmor that checks that slapd does not access other than allowed files... -To make a local extension of alowed operations: +To make a local extension of allowed operations: sudo emacs /etc/apparmor.d/local/usr.sbin.slapd and, after the change (yes, at least on Ubuntu it is right to edit ../local/.. but run with another file): diff --git a/lib/erl_interface/doc/src/erl_call.xml b/lib/erl_interface/doc/src/erl_call.xml index f1e52b1889..426f6b88ca 100644 --- a/lib/erl_interface/doc/src/erl_call.xml +++ b/lib/erl_interface/doc/src/erl_call.xml @@ -193,7 +193,7 @@ erl_call -s -a 'erlang halt' -n madonna <p>To apply with many arguments:</p> <code type="none"><![CDATA[ -erl_call -s -a 'lists map [{math,sqrt},[1,4,9,16,25]]' -n madonna +erl_call -s -a 'lists seq [1,10]' -n madonna ]]></code> <p>To evaluate some expressions diff --git a/lib/erl_interface/src/README b/lib/erl_interface/src/README index feee2e48e8..7591615f78 100644 --- a/lib/erl_interface/src/README +++ b/lib/erl_interface/src/README @@ -11,7 +11,7 @@ Also, assertions are enabled, meaning that the code will be a little bit slower. In the final release, there will be two alternative libraries shipped, with and without assertions. -If an assertion triggers, there will be a printout similiar to this +If an assertion triggers, there will be a printout similar to this one: Assertion failed: ep != NULL in erl_eterm.c, line 694 diff --git a/lib/erl_interface/src/legacy/erl_marshal.c b/lib/erl_interface/src/legacy/erl_marshal.c index 2bdf5f2134..527ae0ef8f 100644 --- a/lib/erl_interface/src/legacy/erl_marshal.c +++ b/lib/erl_interface/src/legacy/erl_marshal.c @@ -1626,7 +1626,7 @@ static int cmp_refs(unsigned char **e1, unsigned char **e2) if (cre1 != cre2) return cre1 < cre2 ? -1 : 1; - /* ... and then finaly ids. */ + /* ... and then finally ids. */ if (n1 != n2) { unsigned char zero[] = {0, 0, 0, 0}; if (n1 > n2) @@ -1791,7 +1791,7 @@ static int cmp_exe2(unsigned char **e1, unsigned char **e2) if (port1.creation < port2.creation) return -1; else if (port1.creation > port2.creation) return 1; - /* ... and then finaly ids. */ + /* ... and then finally ids. */ if (port1.id < port2.id) return -1; else if (port1.id > port2.id) return 1; diff --git a/lib/erl_interface/src/misc/ei_locking.c b/lib/erl_interface/src/misc/ei_locking.c index 85b2a5fd8b..a0e00b7871 100644 --- a/lib/erl_interface/src/misc/ei_locking.c +++ b/lib/erl_interface/src/misc/ei_locking.c @@ -76,8 +76,8 @@ ei_mutex_t *ei_mutex_create(void) return l; } -/* - * Free a mutex and the structure asociated with it. +/* + * Free a mutex and the structure associated with it. * * This function attempts to obtain the mutex before releasing it; * If nblock == 1 and the mutex was unavailable, the function will diff --git a/lib/erl_interface/test/ei_decode_SUITE.erl b/lib/erl_interface/test/ei_decode_SUITE.erl index 1495a0d5d9..10e90685c8 100644 --- a/lib/erl_interface/test/ei_decode_SUITE.erl +++ b/lib/erl_interface/test/ei_decode_SUITE.erl @@ -99,7 +99,7 @@ test_ei_decode_ulonglong(Config) when is_list(Config) -> %% ######################################################################## %% -%% A "character" for us is an 8 bit integer, alwasy positive, i.e. +%% A "character" for us is an 8 bit integer, always positive, i.e. %% it is unsigned. %% FIXME maybe the API should change to use "unsigned char" to be clear?! diff --git a/lib/erl_interface/test/erl_eterm_SUITE.erl b/lib/erl_interface/test/erl_eterm_SUITE.erl index 0e51a50c19..7fd46694b8 100644 --- a/lib/erl_interface/test/erl_eterm_SUITE.erl +++ b/lib/erl_interface/test/erl_eterm_SUITE.erl @@ -31,7 +31,7 @@ %%% 2. Constructing terms (the erl_mk_xxx() functions and erl_copy_term()). %%% 3. Extracting & info functions (erl_hd(), erl_length() etc). %%% 4. I/O list functions. -%%% 5. Miscellanous functions. +%%% 5. Miscellaneous functions. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -export([all/0, suite/0, diff --git a/lib/eunit/doc/overview.edoc b/lib/eunit/doc/overview.edoc index 3a46e991cb..dc9f858812 100644 --- a/lib/eunit/doc/overview.edoc +++ b/lib/eunit/doc/overview.edoc @@ -578,7 +578,7 @@ results for equality, if testing is enabled. If the values are not equal, an informative exception will be generated; see the `assert' macro for further details. -`assertEqual' is more suitable than than `assertMatch' when the +`assertEqual' is more suitable than `assertMatch' when the left-hand side is a computed value rather than a simple pattern, and gives more details than `?assert(Expect =:= Expr)'. @@ -994,7 +994,7 @@ specified node. `local' means that the current process will handle both setup/teardown and running the tests - the drawback is that if a test times out so that the process is killed, the <em>cleanup will not be performed</em>; hence, avoid this for persistent fixtures such as file -operations. In general, 'local' should only be used when: +operations. In general, `local' should only be used when: <ul> <li>the setup/teardown needs to be executed by the process that will run the tests;</li> diff --git a/lib/eunit/doc/src/notes.xml b/lib/eunit/doc/src/notes.xml index 8509f44ffc..d7ec2108e9 100644 --- a/lib/eunit/doc/src/notes.xml +++ b/lib/eunit/doc/src/notes.xml @@ -498,7 +498,7 @@ <list> <item> <p> - Miscellanous updates.</p> + Miscellaneous updates.</p> <p> Own Id: OTP-8038</p> </item> diff --git a/lib/hipe/amd64/Makefile b/lib/hipe/amd64/Makefile index 617f6749ac..d0da8cdff6 100644 --- a/lib/hipe/amd64/Makefile +++ b/lib/hipe/amd64/Makefile @@ -128,6 +128,7 @@ $(EBIN)/hipe_amd64_ra_postconditions.beam: ../main/hipe.hrl ../x86/hipe_x86.hrl $(EBIN)/hipe_amd64_ra_sse2_postconditions.beam: ../main/hipe.hrl $(EBIN)/hipe_amd64_registers.beam: ../rtl/hipe_literals.hrl $(EBIN)/hipe_amd64_spill_restore.beam: ../main/hipe.hrl ../x86/hipe_x86.hrl ../flow/cfg.hrl ../x86/hipe_x86_spill_restore.erl +$(EBIN)/hipe_amd64_subst.beam: ../x86/hipe_x86_subst.erl $(EBIN)/hipe_amd64_x87.beam: ../x86/hipe_x86_x87.erl $(EBIN)/hipe_amd64_sse2.beam: ../main/hipe.hrl ../x86/hipe_x86.hrl $(EBIN)/hipe_rtl_to_amd64.beam: ../x86/hipe_rtl_to_x86.erl ../rtl/hipe_rtl.hrl diff --git a/lib/hipe/amd64/hipe_amd64_encode.erl b/lib/hipe/amd64/hipe_amd64_encode.erl index f8cc0c7d83..bda2824ffc 100644 --- a/lib/hipe/amd64/hipe_amd64_encode.erl +++ b/lib/hipe/amd64/hipe_amd64_encode.erl @@ -1316,6 +1316,7 @@ dotest1(OS) -> RM64 = {rm64,rm_reg(?EDX)}, RM32 = {rm32,rm_reg(?EDX)}, RM16 = {rm16,rm_reg(?EDX)}, + RM16REX = {rm16,rm_reg(?R13)}, RM8 = {rm8,rm_reg(?EDX)}, RM8REX = {rm8,rm_reg(?SIL)}, Rel32 = {rel32,Word32}, @@ -1479,6 +1480,7 @@ dotest1(OS) -> t(OS,'test',{RM8,Imm8}), t(OS,'test',{RM8REX,Imm8}), t(OS,'test',{RM16,Imm16}), + t(OS,'test',{RM16REX,Imm16}), t(OS,'test',{RM32,Imm32}), t(OS,'test',{RM64,Imm32}), t(OS,'test',{RM32,Reg32}), diff --git a/lib/hipe/amd64/hipe_amd64_registers.erl b/lib/hipe/amd64/hipe_amd64_registers.erl index a4cb71a106..a5cecef5a1 100644 --- a/lib/hipe/amd64/hipe_amd64_registers.erl +++ b/lib/hipe/amd64/hipe_amd64_registers.erl @@ -207,19 +207,14 @@ allocatable_x87() -> nr_args() -> ?AMD64_NR_ARG_REGS. -arg(N) -> - if N < ?AMD64_NR_ARG_REGS -> - case N of - 0 -> ?ARG0; - 1 -> ?ARG1; - 2 -> ?ARG2; - 3 -> ?ARG3; - 4 -> ?ARG4; - 5 -> ?ARG5; - _ -> exit({?MODULE, arg, N}) - end; - true -> - exit({?MODULE, arg, N}) +arg(N) when N < ?AMD64_NR_ARG_REGS -> + case N of + 0 -> ?ARG0; + 1 -> ?ARG1; + 2 -> ?ARG2; + 3 -> ?ARG3; + 4 -> ?ARG4; + 5 -> ?ARG5 end. is_arg(R) -> @@ -240,11 +235,7 @@ args(Arity) when is_integer(Arity), Arity >= 0 -> args(I, Rest) when I < 0 -> Rest; args(I, Rest) -> args(I-1, [arg(I) | Rest]). -ret(N) -> - case N of - 0 -> ?RAX; - _ -> exit({?MODULE, ret, N}) - end. +ret(0) -> ?RAX. %% Note: the fact that (allocatable() UNION allocatable_x87() UNION %% allocatable_sse2()) is a subset of call_clobbered() is hard-coded in diff --git a/lib/hipe/cerl/cerl_to_icode.erl b/lib/hipe/cerl/cerl_to_icode.erl index acad8a9da4..e37eae8a03 100644 --- a/lib/hipe/cerl/cerl_to_icode.erl +++ b/lib/hipe/cerl/cerl_to_icode.erl @@ -2621,7 +2621,7 @@ icode_switch_val(Arg, Fail, Length, Cases) -> hipe_icode:mk_switch_val(Arg, Fail, Length, Cases). icode_switch_tuple_arity(Arg, Fail, Length, Cases) -> - SortedCases = lists:keysort(1, Cases), %% immitate BEAM compiler - Kostis + SortedCases = lists:keysort(1, Cases), %% imitate BEAM compiler - Kostis hipe_icode:mk_switch_tuple_arity(Arg, Fail, Length, SortedCases). diff --git a/lib/hipe/cerl/erl_types.erl b/lib/hipe/cerl/erl_types.erl index 9d46d4ac81..ea8cc1677d 100644 --- a/lib/hipe/cerl/erl_types.erl +++ b/lib/hipe/cerl/erl_types.erl @@ -518,7 +518,8 @@ list_contains_opaque(List, Opaques) -> lists:any(fun(E) -> t_contains_opaque(E, Opaques) end, List). %% t_find_opaque_mismatch/2 of two types should only be used if their -%% t_inf is t_none() due to some opaque type violation. +%% t_inf is t_none() due to some opaque type violation. However, +%% 'error' is returned if a structure mismatch is found. %% %% The first argument of the function is the pattern and its second %% argument the type we are matching against the pattern. @@ -527,22 +528,30 @@ list_contains_opaque(List, Opaques) -> 'error' | {'ok', erl_type(), erl_type()}. t_find_opaque_mismatch(T1, T2, Opaques) -> - t_find_opaque_mismatch(T1, T2, T2, Opaques). + catch t_find_opaque_mismatch(T1, T2, T2, Opaques). t_find_opaque_mismatch(?any, _Type, _TopType, _Opaques) -> error; -t_find_opaque_mismatch(?none, _Type, _TopType, _Opaques) -> error; +t_find_opaque_mismatch(?none, _Type, _TopType, _Opaques) -> throw(error); t_find_opaque_mismatch(?list(T1, Tl1, _), ?list(T2, Tl2, _), TopType, Opaques) -> t_find_opaque_mismatch_ordlists([T1, Tl1], [T2, Tl2], TopType, Opaques); t_find_opaque_mismatch(T1, ?opaque(_) = T2, TopType, Opaques) -> case is_opaque_type(T2, Opaques) of - false -> {ok, TopType, T2}; + false -> + case t_is_opaque(T1) andalso compatible_opaque_types(T1, T2) =/= [] of + true -> error; + false -> {ok, TopType, T2} + end; true -> t_find_opaque_mismatch(T1, t_opaque_structure(T2), TopType, Opaques) end; t_find_opaque_mismatch(?opaque(_) = T1, T2, TopType, Opaques) -> %% The generated message is somewhat misleading: case is_opaque_type(T1, Opaques) of - false -> {ok, TopType, T1}; + false -> + case t_is_opaque(T2) andalso compatible_opaque_types(T1, T2) =/= [] of + true -> error; + false -> {ok, TopType, T1} + end; true -> t_find_opaque_mismatch(t_opaque_structure(T1), T2, TopType, Opaques) end; @@ -558,7 +567,11 @@ t_find_opaque_mismatch(?tuple(_, _, _) = T1, ?tuple_set(_) = T2, t_find_opaque_mismatch_lists(Tuples1, Tuples2, TopType, Opaques); t_find_opaque_mismatch(T1, ?union(U2), TopType, Opaques) -> t_find_opaque_mismatch_lists([T1], U2, TopType, Opaques); -t_find_opaque_mismatch(_T1, _T2, _TopType, _Opaques) -> error. +t_find_opaque_mismatch(T1, T2, _TopType, Opaques) -> + case t_is_none(t_inf(T1, T2, Opaques)) of + false -> error; + true -> throw(error) + end. t_find_opaque_mismatch_ordlists(L1, L2, TopType, Opaques) -> List = lists:zipwith(fun(T1, T2) -> @@ -567,10 +580,11 @@ t_find_opaque_mismatch_ordlists(L1, L2, TopType, Opaques) -> t_find_opaque_mismatch_list(List). t_find_opaque_mismatch_lists(L1, L2, _TopType, Opaques) -> - List = [t_find_opaque_mismatch(T1, T2, T2, Opaques) || T1 <- L1, T2 <- L2], + List = [catch t_find_opaque_mismatch(T1, T2, T2, Opaques) || + T1 <- L1, T2 <- L2], t_find_opaque_mismatch_list(List). -t_find_opaque_mismatch_list([]) -> error; +t_find_opaque_mismatch_list([]) -> throw(error); t_find_opaque_mismatch_list([H|T]) -> case H of {ok, _T1, _T2} -> H; @@ -3047,6 +3061,9 @@ inf_opaque_types(IsOpaque1, T1, IsOpaque2, T2, Opaques) -> end end. +compatible_opaque_types(?opaque(Es1), ?opaque(Es2)) -> + [{O1, O2} || O1 <- Es1, O2 <- Es2, is_compat_opaque_names(O1, O2)]. + is_compat_opaque_names(Opaque1, Opaque2) -> #opaque{mod = Mod1, name = Name1, args = Args1} = Opaque1, #opaque{mod = Mod2, name = Name2, args = Args2} = Opaque2, diff --git a/lib/hipe/doc/src/notes.xml b/lib/hipe/doc/src/notes.xml index 0bdd60adfd..82f0c8ec1e 100644 --- a/lib/hipe/doc/src/notes.xml +++ b/lib/hipe/doc/src/notes.xml @@ -130,12 +130,12 @@ </item> <item> <p> - Various fixes and improvements to the HiPE LLVM backend. + Various fixes and improvements to the HiPE LLVM backend.</p> <list> <item>Add support for LLVM 3.7 and 3.8 in the HiPE/LLVM x86_64 backend</item> <item>Reinstate support for the LLVM backend on x86 (works OK for LLVM 3.5 to 3.7 -- LLVM 3.8 has a bug that prevents it from generating - correct native code on x86)</item> </list></p> + correct native code on x86)</item> </list> <p> Own Id: OTP-13626</p> </item> @@ -191,7 +191,7 @@ <item> <p> Fix various binary construction inconsistencies for hipe - compiled code. <list> <item>Passing bad field sizes to + compiled code.</p> <list> <item>Passing bad field sizes to binary constructions would throw <c>badarith</c> rather than <c>badarg</c>. Worse, in guards, when the unit size of the field was 1, the exception would leak rather than @@ -211,7 +211,7 @@ missing check for unit size match when inserting a binary. For example, a faulty expression like <c><<<<1:7>>/binary>></c> would - succeed.</item> </list></p> + succeed.</item> </list> <p> Own Id: OTP-13272</p> </item> @@ -1297,7 +1297,7 @@ <list> <item> <p> - Miscellanous updates.</p> + Miscellaneous updates.</p> <p> Own Id: OTP-8038</p> </item> diff --git a/lib/hipe/flow/cfg.inc b/lib/hipe/flow/cfg.inc index 362c5b697c..17342d3b60 100644 --- a/lib/hipe/flow/cfg.inc +++ b/lib/hipe/flow/cfg.inc @@ -212,7 +212,7 @@ info_update(CFG, I) -> -ifndef(GEN_CFG). -spec other_entrypoints(cfg()) -> [cfg_lbl()]. -%% @doc Returns a list of labels that are refered to from the data section. +%% @doc Returns a list of labels that are referred to from the data section. other_entrypoints(CFG) -> hipe_consttab:referred_labels(data(CFG)). diff --git a/lib/hipe/flow/ebb.inc b/lib/hipe/flow/ebb.inc index 58213e44d5..e4b7fd0efb 100644 --- a/lib/hipe/flow/ebb.inc +++ b/lib/hipe/flow/ebb.inc @@ -40,12 +40,14 @@ %% | {ebb_leaf, SuccesorLabel} %%-------------------------------------------------------------------- -%% XXX: Cheating big time! no recursive types --type ebb() :: {ebb_node, icode_lbl(), _} - | {ebb_leaf, icode_lbl()}. +-type ebb() :: ebb_node() + | ebb_leaf(). -record(ebb_node, {label :: icode_lbl(), successors :: [ebb()]}). +-type ebb_node() :: #ebb_node{}. + -record(ebb_leaf, {successor :: icode_lbl()}). +-type ebb_leaf() :: #ebb_leaf{}. %%-------------------------------------------------------------------- %% Returns a list of extended basic blocks. @@ -193,7 +195,7 @@ add_succ([Lbl|Lbls], Visited, Node, MkFun, EBBs, CFG) -> %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% --spec mk_node(icode_lbl(), [ebb()]) -> #ebb_node{}. +-spec mk_node(icode_lbl(), [ebb()]) -> ebb_node(). mk_node(Label, Successors) -> #ebb_node{label=Label, successors=Successors}. -spec node_label(#ebb_node{}) -> icode_lbl(). @@ -202,11 +204,11 @@ node_label(#ebb_node{label=Label}) -> Label. -spec node_successors(#ebb_node{}) -> [ebb()]. node_successors(#ebb_node{successors=Successors}) -> Successors. --spec mk_leaf(icode_lbl()) -> #ebb_leaf{}. +-spec mk_leaf(icode_lbl()) -> ebb_leaf(). mk_leaf(NextEbb) -> #ebb_leaf{successor=NextEbb}. %% leaf_next(Leaf) -> Leaf#ebb_leaf.successor. --spec type(#ebb_node{}) -> 'node' ; (#ebb_leaf{}) -> 'leaf'. +-spec type(ebb_node()) -> 'node' ; (ebb_leaf()) -> 'leaf'. type(#ebb_node{}) -> node; type(#ebb_leaf{}) -> leaf. diff --git a/lib/hipe/flow/hipe_dominators.erl b/lib/hipe/flow/hipe_dominators.erl index 570452c14e..749edd4f72 100644 --- a/lib/hipe/flow/hipe_dominators.erl +++ b/lib/hipe/flow/hipe_dominators.erl @@ -317,7 +317,7 @@ updateCell(Value, Field, WD) -> %%>----------------------------------------------------------------------< %% Procedure : dfs/1 %% Purpose : The main purpose of this function is to traverse the CFG in -%% a depth first order. It is aslo used to initialize certain +%% a depth first order. It is also used to initialize certain %% elements defined in a workDataCell. %% Arguments : CFG - a Control Flow Graph representation %% Returns : A table (WorkData) and the total number of elements in diff --git a/lib/hipe/icode/hipe_beam_to_icode.erl b/lib/hipe/icode/hipe_beam_to_icode.erl index 100bc0b0e2..610578dfbc 100644 --- a/lib/hipe/icode/hipe_beam_to_icode.erl +++ b/lib/hipe/icode/hipe_beam_to_icode.erl @@ -148,7 +148,8 @@ trans_mfa_code(M,F,A, FunBeamCode, ClosureInfo) -> {Code3,_Env3} = mk_debug_calltrace(MFA, Env1, Code2), {Code3,_Env3} = {Code2,Env1}), %% For stack optimization - Leafness = leafness(Code3), + IsClosure = get_closure_info(MFA, ClosureInfo) =/= not_a_closure, + Leafness = leafness(Code3, IsClosure), IsLeaf = is_leaf_code(Leafness), Code4 = [FunLbl | @@ -156,7 +157,6 @@ trans_mfa_code(M,F,A, FunBeamCode, ClosureInfo) -> false -> Code3; true -> [mk_redtest()|Code3] end], - IsClosure = get_closure_info(MFA, ClosureInfo) =/= not_a_closure, Code5 = hipe_icode:mk_icode(MFA, FunArgs, IsClosure, IsLeaf, remove_dead_code(Code4), hipe_gensym:var_range(icode), @@ -173,12 +173,12 @@ trans_mfa_code(M,F,A, FunBeamCode, ClosureInfo) -> mk_redtest() -> hipe_icode:mk_primop([], redtest, []). -leafness(Is) -> % -> true, selfrec, or false - leafness(Is, true). +leafness(Is, IsClosure) -> % -> true, selfrec, closure, or false + leafness(Is, IsClosure, true). -leafness([], Leafness) -> +leafness([], _IsClosure, Leafness) -> Leafness; -leafness([I|Is], Leafness) -> +leafness([I|Is], IsClosure, Leafness) -> case I of #icode_comment{} -> %% BEAM self-tailcalls become gotos, but they leave @@ -191,7 +191,7 @@ leafness([I|Is], Leafness) -> 'self_tail_recursive' -> selfrec; % call_only to selfrec _ -> Leafness end, - leafness(Is, NewLeafness); + leafness(Is, IsClosure, NewLeafness); #icode_call{} -> case hipe_icode:call_type(I) of 'primop' -> @@ -199,12 +199,12 @@ leafness([I|Is], Leafness) -> call_fun -> false; % Calls closure enter_fun -> false; % Calls closure #apply_N{} -> false; - _ -> leafness(Is, Leafness) % Other primop calls are ok + _ -> leafness(Is, IsClosure, Leafness) % Other primop calls are ok end; T when T =:= 'local' orelse T =:= 'remote' -> {M,F,A} = hipe_icode:call_fun(I), case erlang:is_builtin(M, F, A) of - true -> leafness(Is, Leafness); + true -> leafness(Is, IsClosure, Leafness); false -> false end end; @@ -223,11 +223,12 @@ leafness([I|Is], Leafness) -> T when T =:= 'local' orelse T =:= 'remote' -> {M,F,A} = hipe_icode:enter_fun(I), case erlang:is_builtin(M, F, A) of - true -> leafness(Is, Leafness); + true -> leafness(Is, IsClosure, Leafness); + _ when IsClosure -> leafness(Is, IsClosure, closure); _ -> false end end; - _ -> leafness(Is, Leafness) + _ -> leafness(Is, IsClosure, Leafness) end. %% XXX: this old stuff is passed around but essentially unused @@ -235,12 +236,20 @@ is_leaf_code(Leafness) -> case Leafness of true -> true; selfrec -> true; + closure -> false; false -> false end. needs_redtest(Leafness) -> case Leafness of true -> false; + %% A "leaf" closure may contain tailcalls to non-closures in addition to + %% what other leaves may contain. Omitting the redtest is useful to generate + %% shorter code for closures generated by (fun F/A), and is safe since + %% control flow cannot return to a "leaf" closure again without a reduction + %% being consumed. This is true since no function that can call a closure + %% will ever have its redtest omitted. + closure -> false; selfrec -> true; false -> true end. diff --git a/lib/hipe/icode/hipe_icode_type.erl b/lib/hipe/icode/hipe_icode_type.erl index 815d1e57a8..aafaeb5a0a 100644 --- a/lib/hipe/icode/hipe_icode_type.erl +++ b/lib/hipe/icode/hipe_icode_type.erl @@ -1410,9 +1410,10 @@ transform_element2(I) -> NewIndex = case test_type(integer, IndexType) of true -> - case t_number_vals(IndexType) of - unknown -> unknown; - [_|_] = Vals -> {number, Vals} + case {number_min(IndexType), number_max(IndexType)} of + {Lb0, Ub0} when is_integer(Lb0), is_integer(Ub0) -> + {number, Lb0, Ub0}; + {_, _} -> unknown end; _ -> unknown end, @@ -1427,19 +1428,19 @@ transform_element2(I) -> _ -> unknown end, case {NewIndex, MinSize} of - {{number, [_|_] = Ns}, {tuple, A}} when is_integer(A) -> - case lists:all(fun(X) -> 0 < X andalso X =< A end, Ns) of + {{number, Lb, Ub}, {tuple, A}} when is_integer(A) -> + case 0 < Lb andalso Ub =< A of true -> - case Ns of - [Idx] -> + case {Lb, Ub} of + {Idx, Idx} -> [_, Tuple] = hipe_icode:args(I), update_call_or_enter(I, #unsafe_element{index = Idx}, [Tuple]); - [_|_] -> + {_, _} -> NewFun = {element, [MinSize, valid]}, update_call_or_enter(I, NewFun) end; false -> - case lists:all(fun(X) -> hipe_tagscheme:is_fixnum(X) end, Ns) of + case lists:all(fun(X) -> hipe_tagscheme:is_fixnum(X) end, [Lb, Ub]) of true -> NewFun = {element, [MinSize, fixnums]}, update_call_or_enter(I, NewFun); @@ -1454,7 +1455,7 @@ transform_element2(I) -> NewFun = {element, [MinSize, fixnums]}, update_call_or_enter(I, NewFun); false -> - NewFun = {element, [MinSize, NewIndex]}, + NewFun = {element, [MinSize, NewIndex]}, update_call_or_enter(I, NewFun) end end. diff --git a/lib/hipe/llvm/hipe_llvm.erl b/lib/hipe/llvm/hipe_llvm.erl index b22f8fb320..641d3fda0a 100644 --- a/lib/hipe/llvm/hipe_llvm.erl +++ b/lib/hipe/llvm/hipe_llvm.erl @@ -862,7 +862,7 @@ pp_ins(Dev, Ver, I) -> true -> write(Dev, "volatile "); false -> ok end, - pp_dereference_type(Dev, Ver, load_p_type(I)), + pp_dereference_type(Dev, load_p_type(I)), write(Dev, [" ", load_pointer(I), " "]), case load_alignment(I) of [] -> ok; @@ -898,7 +898,7 @@ pp_ins(Dev, Ver, I) -> true -> write(Dev, "inbounds "); false -> ok end, - pp_dereference_type(Dev, Ver, getelementptr_p_type(I)), + pp_dereference_type(Dev, getelementptr_p_type(I)), write(Dev, [" ", getelementptr_value(I)]), pp_typed_idxs(Dev, getelementptr_typed_idxs(I)), write(Dev, "\n"); @@ -959,10 +959,8 @@ pp_ins(Dev, Ver, I) -> pp_args(Dev, fun_def_arglist(I)), write(Dev, ") "), pp_options(Dev, fun_def_fn_attrs(I)), - case Ver >= {3,7} of false -> ok; true -> - write(Dev, "personality i32 (i32, i64, i8*,i8*)* " - "@__gcc_personality_v0 ") - end, + write(Dev, "personality i32 (i32, i64, i8*,i8*)* " + "@__gcc_personality_v0 "), case fun_def_align(I) of [] -> ok; N -> write(Dev, ["align ", N]) @@ -997,12 +995,7 @@ pp_ins(Dev, Ver, I) -> pp_type(Dev, const_decl_type(I)), write(Dev, [" ", const_decl_value(I), "\n"]); #llvm_landingpad{} -> - write(Dev, "landingpad { i8*, i32 } "), - case Ver < {3,7} of false -> ok; true -> - write(Dev, "personality i32 (i32, i64, i8*,i8*)* " - "@__gcc_personality_v0 ") - end, - write(Dev, "cleanup\n"); + write(Dev, "landingpad { i8*, i32 } cleanup\n"); #llvm_asm{} -> write(Dev, [asm_instruction(I), "\n"]); #llvm_adj_stack{} -> @@ -1011,15 +1004,7 @@ pp_ins(Dev, Ver, I) -> pp_type(Dev, adj_stack_type(I)), write(Dev, [" ", adj_stack_offset(I),")\n"]); #llvm_meta{} -> - write(Dev, ["!", meta_id(I), " = "]), - Named = case string:to_integer(meta_id(I)) of - {_, ""} -> false; - _ -> true - end, - case Ver < {3,6} andalso not Named of - true -> write(Dev, "metadata !{metadata "); - false -> write(Dev, "!{ ") - end, + write(Dev, ["!", meta_id(I), " = !{ "]), write(Dev, string:join([if is_list(Op) -> ["!\"", Op, "\""]; is_integer(Op) -> ["i32 ", integer_to_list(Op)]; is_record(Op, llvm_meta) -> @@ -1030,15 +1015,10 @@ pp_ins(Dev, Ver, I) -> exit({?MODULE, pp_ins, {"Unknown LLVM instruction", Other}}) end. -%% @doc Print the type of a dereference in an LLVM instruction using syntax -%% parsable by the specified LLVM version. -pp_dereference_type(Dev, Ver, Type) -> - case Ver >= {3,7} of - false -> ok; - true -> - pp_type(Dev, pointer_type(Type)), - write(Dev, ", ") - end, +%% @doc Print the type of a dereference in an LLVM instruction. +pp_dereference_type(Dev, Type) -> + pp_type(Dev, pointer_type(Type)), + write(Dev, ", "), pp_type(Dev, Type). %% @doc Pretty-print a list of types diff --git a/lib/hipe/llvm/hipe_rtl_to_llvm.erl b/lib/hipe/llvm/hipe_rtl_to_llvm.erl index f8911c1909..79e1bfd381 100644 --- a/lib/hipe/llvm/hipe_rtl_to_llvm.erl +++ b/lib/hipe/llvm/hipe_rtl_to_llvm.erl @@ -1364,7 +1364,7 @@ create_function_definition(Fun, Params, Code, LocalVars) -> EntryBlock = lists:flatten([EntryLabel, ExceptionSync, I2, LocalVars, StoredParams, I3]), Final_Code = EntryBlock ++ Code, - FunctionOptions = [nounwind, noredzone, list_to_atom("gc \"erlang\"")], + FunctionOptions = [nounwind, noredzone, 'gc "erlang"'], WordTy = hipe_llvm:mk_int(?BITS_IN_WORD), FunRetTy = hipe_llvm:mk_struct(lists:duplicate(?NR_PINNED_REGS + 1, WordTy)), hipe_llvm:mk_fun_def([], [], "cc 11", [], FunRetTy, FunctionName, Args, @@ -1431,7 +1431,7 @@ relocs_to_list(Relocs) -> %% constants/labels. handle_relocations(Relocs, Data, Fun) -> RelocsList = relocs_to_list(Relocs), - %% Seperate Relocations according to their type + %% Separate Relocations according to their type {CallList, AtomList, ClosureList, ClosureLabels, SwitchList} = seperate_relocs(RelocsList), %% Create code to declare atoms @@ -1474,7 +1474,7 @@ handle_relocations(Relocs, Data, Fun) -> LocalVariables = AtomLoad ++ ClosureLoad ++ ConstLoad, {Relocs4, ExternalDeclarations, LocalVariables}. -%% @doc Seperate relocations according to their type. +%% @doc Separate relocations according to their type. seperate_relocs(Relocs) -> seperate_relocs(Relocs, [], [], [], [], []). diff --git a/lib/hipe/main/hipe.erl b/lib/hipe/main/hipe.erl index 06facae5c1..fff397b060 100644 --- a/lib/hipe/main/hipe.erl +++ b/lib/hipe/main/hipe.erl @@ -655,7 +655,7 @@ run_compiler_1(Name, DisasmFun, IcodeFun, Options) -> case proplists:get_bool(to_llvm, Opts0) andalso not llvm_support_available() of true -> - ?error_msg("No LLVM version 3.4 or greater " + ?error_msg("No LLVM version 3.9 or greater " "found in $PATH; aborting " "native code compilation.\n", []), ?EXIT(cant_find_required_llvm_version); @@ -1585,7 +1585,7 @@ check_options(Opts) -> -spec llvm_support_available() -> boolean(). llvm_support_available() -> - get_llvm_version() >= {3,4}. + get_llvm_version() >= {3,9}. -type llvm_version() :: {Major :: integer(), Minor :: integer()}. diff --git a/lib/hipe/opt/hipe_schedule.erl b/lib/hipe/opt/hipe_schedule.erl index 531690f885..0f25940e3d 100644 --- a/lib/hipe/opt/hipe_schedule.erl +++ b/lib/hipe/opt/hipe_schedule.erl @@ -1337,10 +1337,10 @@ cd([{N,I}|Xs], DAG, PrevBr, PrevUnsafe, PrevOthers) -> %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% Function : cd_branch_to_other_deps %% Argument : N - index of branch -%% Ms - list of indexes of "others" preceeding instrs +%% Ms - list of indexes of "others" preceding instrs %% DAG - dependence graph %% Returns : DAG - new graph -%% Description : Makes preceeding instrs fixed so they don't bypass a branch +%% Description : Makes preceding instrs fixed so they don't bypass a branch %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% cd_branch_to_other_deps(_, [], DAG) -> DAG; diff --git a/lib/hipe/opt/hipe_spillmin_color.erl b/lib/hipe/opt/hipe_spillmin_color.erl index 50e073a467..41f1972df7 100644 --- a/lib/hipe/opt/hipe_spillmin_color.erl +++ b/lib/hipe/opt/hipe_spillmin_color.erl @@ -119,7 +119,7 @@ color_heuristic(IG, Min, Max, Safe, MaxNodes, Target, MaxDepth) -> end; _ -> %% This can be increased from 2, and by this the heuristic can be - %% exited earlier, but the same can be achived by decreasing the + %% exited earlier, but the same can be achieved by decreasing the %% recursion depth. This should not be decreased below 2. case (Max - Min) < 2 of true -> diff --git a/lib/hipe/regalloc/hipe_amd64_specific_sse2.erl b/lib/hipe/regalloc/hipe_amd64_specific_sse2.erl index 9c94539bc6..9682d37520 100644 --- a/lib/hipe/regalloc/hipe_amd64_specific_sse2.erl +++ b/lib/hipe/regalloc/hipe_amd64_specific_sse2.erl @@ -126,8 +126,8 @@ temp0(_) -> all_precoloured(Ctx) -> allocatable(Ctx). -is_precoloured(Reg, Ctx) -> - lists:member(Reg,all_precoloured(Ctx)). +is_precoloured(Reg, _) -> + hipe_amd64_registers:is_precoloured_sse2(Reg). physical_name(Reg, _) -> Reg. diff --git a/lib/hipe/rtl/hipe_icode2rtl.erl b/lib/hipe/rtl/hipe_icode2rtl.erl index 82970f04ab..6da8a76d34 100644 --- a/lib/hipe/rtl/hipe_icode2rtl.erl +++ b/lib/hipe/rtl/hipe_icode2rtl.erl @@ -532,8 +532,12 @@ gen_cond(CondOp, Args, TrueLbl, FalseLbl, Pred) -> FalseLbl, Pred)]; '=:=' -> [Arg1, Arg2] = Args, + TypeTestLbl = hipe_rtl:mk_new_label(), [hipe_rtl:mk_branch(Arg1, eq, Arg2, TrueLbl, - hipe_rtl:label_name(GenLbl), Pred), + hipe_rtl:label_name(TypeTestLbl), Pred), + TypeTestLbl, + hipe_tagscheme:test_either_immed(Arg1, Arg2, FalseLbl, + hipe_rtl:label_name(GenLbl)), GenLbl, hipe_rtl:mk_call([Tmp], op_exact_eqeq_2, Args, TestRetName, [], not_remote), @@ -546,8 +550,12 @@ gen_cond(CondOp, Args, TrueLbl, FalseLbl, Pred) -> TrueLbl, 1-Pred)]; '=/=' -> [Arg1, Arg2] = Args, + TypeTestLbl = hipe_rtl:mk_new_label(), [hipe_rtl:mk_branch(Arg1, eq, Arg2, FalseLbl, - hipe_rtl:label_name(GenLbl), 1-Pred), + hipe_rtl:label_name(TypeTestLbl), 1-Pred), + TypeTestLbl, + hipe_tagscheme:test_either_immed(Arg1, Arg2, TrueLbl, + hipe_rtl:label_name(GenLbl)), GenLbl, hipe_rtl:mk_call([Tmp], op_exact_eqeq_2, Args, TestRetName, [], not_remote), diff --git a/lib/hipe/rtl/hipe_rtl_binary_construct.erl b/lib/hipe/rtl/hipe_rtl_binary_construct.erl index fd0d1f1223..52ea5db382 100644 --- a/lib/hipe/rtl/hipe_rtl_binary_construct.erl +++ b/lib/hipe/rtl/hipe_rtl_binary_construct.erl @@ -137,43 +137,6 @@ gen_rtl(BsOP, Dst, Args, TrueLblName, FalseLblName, SystemLimitLblName, ConstTab end end; - {bs_put_integer, Size, Flags, ConstInfo} -> - Aligned = aligned(Flags), - LittleEndian = littleendian(Flags), - [NewOffset] = get_real(Dst), - case is_illegal_const(Size) of - true -> - [hipe_rtl:mk_goto(FalseLblName)]; - false -> - case ConstInfo of - fail -> - [hipe_rtl:mk_goto(FalseLblName)]; - _ -> - case Args of - [Src, Base, Offset] -> - CCode = static_int_c_code(NewOffset, Src, - Base, Offset, Size, - Flags, TrueLblName, - FalseLblName), - put_static_int(NewOffset, Src, Base, Offset, Size, - CCode, Aligned, LittleEndian, TrueLblName); - [Src, Bits, Base, Offset] -> - {SizeCode, SizeReg} = - hipe_rtl_binary:make_size(Size, Bits, - SystemLimitLblName, - FalseLblName), - CCode = int_c_code(NewOffset, Src, Base, - Offset, SizeReg, Flags, - TrueLblName, FalseLblName), - InCode = - put_dynamic_int(NewOffset, Src, Base, Offset, - SizeReg, CCode, Aligned, - LittleEndian, TrueLblName), - SizeCode ++ InCode - end - end - end; - {unsafe_bs_put_integer, 0, _Flags, _ConstInfo} -> [NewOffset] = get_real(Dst), case Args of @@ -186,44 +149,12 @@ gen_rtl(BsOP, Dst, Args, TrueLblName, FalseLblName, SystemLimitLblName, ConstTab end; {unsafe_bs_put_integer, Size, Flags, ConstInfo} -> - case is_illegal_const(Size) of - true -> - [hipe_rtl:mk_goto(FalseLblName)]; - false -> - Aligned = aligned(Flags), - LittleEndian = littleendian(Flags), - [NewOffset] = get_real(Dst), - case ConstInfo of - fail -> - [hipe_rtl:mk_goto(FalseLblName)]; - _ -> - case Args of - [Src, Base, Offset] -> - CCode = static_int_c_code(NewOffset, Src, - Base, Offset, Size, - Flags, TrueLblName, - FalseLblName), - put_unsafe_static_int(NewOffset, Src, Base, - Offset, Size, - CCode, Aligned, LittleEndian, - TrueLblName); - [Src, Bits, Base, Offset] -> - {SizeCode, SizeReg} = - hipe_rtl_binary:make_size(Size, Bits, - SystemLimitLblName, - FalseLblName), - CCode = int_c_code(NewOffset, Src, Base, - Offset, SizeReg, Flags, - TrueLblName, FalseLblName), - InCode = - put_unsafe_dynamic_int(NewOffset, Src, Base, - Offset, SizeReg, CCode, - Aligned, LittleEndian, - TrueLblName), - SizeCode ++ InCode - end - end - end; + do_bs_put_integer(Dst, Args, Size, Flags, ConstInfo, true, + TrueLblName, FalseLblName, SystemLimitLblName); + + {bs_put_integer, Size, Flags, ConstInfo} -> + do_bs_put_integer(Dst, Args, Size, Flags, ConstInfo, false, + TrueLblName, FalseLblName, SystemLimitLblName); bs_utf8_size -> case Dst of @@ -360,6 +291,40 @@ gen_rtl(BsOP, Dst, Args, TrueLblName, FalseLblName, SystemLimitLblName, ConstTab {Code, ConstTab} end. +%% Common implementation of bs_put_integer and unsafe_bs_put_integer +do_bs_put_integer(Dst, Args, Size, Flags, ConstInfo, SrcUnsafe, + TrueLblName, FalseLblName, SystemLimitLblName) -> + case is_illegal_const(Size) of + true -> + [hipe_rtl:mk_goto(FalseLblName)]; + false -> + Aligned = aligned(Flags), + LittleEndian = littleendian(Flags), + [NewOffset] = get_real(Dst), + case ConstInfo of + fail -> + [hipe_rtl:mk_goto(FalseLblName)]; + _ -> + case Args of + [Src, Base, Offset] -> + CCode = static_int_c_code(NewOffset, Src, Base, Offset, Size, + Flags, TrueLblName, FalseLblName), + put_static_int(NewOffset, Src, Base, Offset, Size, CCode, Aligned, + LittleEndian, SrcUnsafe, TrueLblName); + [Src, Bits, Base, Offset] -> + {SizeCode, SizeReg} = + hipe_rtl_binary:make_size(Size, Bits, SystemLimitLblName, + FalseLblName), + CCode = int_c_code(NewOffset, Src, Base, Offset, SizeReg, Flags, + TrueLblName, FalseLblName), + InCode = put_dynamic_int(NewOffset, Src, Base, Offset, SizeReg, + CCode, Aligned, LittleEndian, SrcUnsafe, + TrueLblName), + SizeCode ++ InCode + end + end + end. + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% %% Code that is used in the append and init writeable functions @@ -807,28 +772,8 @@ put_float(_NewOffset, _Src, _Base, _Offset, _Size, CCode, _Aligned, CCode. put_static_int(NewOffset, Src, Base, Offset, Size, CCode, Aligned, - LittleEndian, TrueLblName) -> - {Init, End, UntaggedSrc} = make_init_end(Src, CCode, TrueLblName), - case {Aligned, LittleEndian} of - {true, true} -> - Init ++ - copy_int_little(Base, Offset, NewOffset, Size, UntaggedSrc) ++ - End; - {true, false} -> - Init ++ - copy_int_big(Base, Offset, NewOffset, Size, UntaggedSrc) ++ - End; - {false, true} -> - CCode; - {false, false} -> - Init ++ - copy_offset_int_big(Base, Offset, NewOffset, Size, UntaggedSrc) ++ - End - end. - -put_unsafe_static_int(NewOffset, Src, Base, Offset, Size, CCode, Aligned, - LittleEndian, TrueLblName) -> - {Init, End, UntaggedSrc} = make_init_end(Src, TrueLblName), + LittleEndian, SrcUnsafe, TrueLblName) -> + {Init, End, UntaggedSrc} = make_init_end(Src, CCode, SrcUnsafe, TrueLblName), case {Aligned, LittleEndian} of {true, true} -> Init ++ @@ -847,27 +792,8 @@ put_unsafe_static_int(NewOffset, Src, Base, Offset, Size, CCode, Aligned, end. put_dynamic_int(NewOffset, Src, Base, Offset, SizeReg, CCode, Aligned, - LittleEndian, TrueLblName) -> - {Init, End, UntaggedSrc} = make_init_end(Src, CCode, TrueLblName), - case Aligned of - true -> - case LittleEndian of - true -> - Init ++ - copy_int_little(Base, Offset, NewOffset, SizeReg, UntaggedSrc) ++ - End; - false -> - Init ++ - copy_int_big(Base, Offset, NewOffset, SizeReg, UntaggedSrc) ++ - End - end; - false -> - CCode - end. - -put_unsafe_dynamic_int(NewOffset, Src, Base, Offset, SizeReg, CCode, Aligned, - LittleEndian, TrueLblName) -> - {Init, End, UntaggedSrc} = make_init_end(Src, TrueLblName), + LittleEndian, SrcUnsafe, TrueLblName) -> + {Init, End, UntaggedSrc} = make_init_end(Src, CCode, SrcUnsafe, TrueLblName), case Aligned of true -> case LittleEndian of @@ -884,14 +810,13 @@ put_unsafe_dynamic_int(NewOffset, Src, Base, Offset, SizeReg, CCode, Aligned, CCode end. - %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% %% Help functions used by the above %% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -make_init_end(Src, CCode, TrueLblName) -> +make_init_end(Src, CCode, false, TrueLblName) -> [CLbl, SuccessLbl] = create_lbls(2), [UntaggedSrc] = create_regs(1), Init = [hipe_tagscheme:test_fixnum(Src, hipe_rtl:label_name(SuccessLbl), @@ -899,9 +824,8 @@ make_init_end(Src, CCode, TrueLblName) -> SuccessLbl, hipe_tagscheme:untag_fixnum(UntaggedSrc,Src)], End = [hipe_rtl:mk_goto(TrueLblName), CLbl| CCode], - {Init, End, UntaggedSrc}. - -make_init_end(Src, TrueLblName) -> + {Init, End, UntaggedSrc}; +make_init_end(Src, _CCode, true, TrueLblName) -> [UntaggedSrc] = create_regs(1), Init = [hipe_tagscheme:untag_fixnum(UntaggedSrc,Src)], End = [hipe_rtl:mk_goto(TrueLblName)], diff --git a/lib/hipe/rtl/hipe_tagscheme.erl b/lib/hipe/rtl/hipe_tagscheme.erl index 35d1e7c8a4..68cbe75e85 100644 --- a/lib/hipe/rtl/hipe_tagscheme.erl +++ b/lib/hipe/rtl/hipe_tagscheme.erl @@ -40,6 +40,7 @@ fixnum_gt/5, fixnum_lt/5, fixnum_ge/5, fixnum_le/5, fixnum_val/1, fixnum_mul/4, fixnum_addsub/5, fixnum_andorxor/4, fixnum_not/2, fixnum_bsr/3, fixnum_bsl/3]). +-export([test_either_immed/4]). -export([unsafe_car/2, unsafe_cdr/2, unsafe_constant_element/3, unsafe_update_element/3, element/6]). -export([unsafe_closure_element/3]). @@ -363,14 +364,17 @@ test_matchstate(X, TrueLab, FalseLab, Pred) -> mask_and_compare(Tmp, ?TAG_HEADER_MASK, ?TAG_HEADER_BIN_MATCHSTATE, TrueLab, FalseLab, Pred)]. +test_bitstr_header(HdrTmp, TrueLab, FalseLab, Pred) -> + Mask = ?TAG_HEADER_MASK - ?BINARY_XXX_MASK, + mask_and_compare(HdrTmp, Mask, ?TAG_HEADER_REFC_BIN, TrueLab, FalseLab, Pred). + test_bitstr(X, TrueLab, FalseLab, Pred) -> Tmp = hipe_rtl:mk_new_reg_gcsafe(), HalfTrueLab = hipe_rtl:mk_new_label(), - Mask = ?TAG_HEADER_MASK - ?BINARY_XXX_MASK, [test_is_boxed(X, hipe_rtl:label_name(HalfTrueLab), FalseLab, Pred), HalfTrueLab, get_header(Tmp, X), - mask_and_compare(Tmp, Mask, ?TAG_HEADER_REFC_BIN, TrueLab, FalseLab, Pred)]. + test_bitstr_header(Tmp, TrueLab, FalseLab, Pred)]. test_binary(X, TrueLab, FalseLab, Pred) -> Tmp1 = hipe_rtl:mk_new_reg_gcsafe(), @@ -378,12 +382,10 @@ test_binary(X, TrueLab, FalseLab, Pred) -> IsBoxedLab = hipe_rtl:mk_new_label(), IsBitStrLab = hipe_rtl:mk_new_label(), IsSubBinLab = hipe_rtl:mk_new_label(), - Mask = ?TAG_HEADER_MASK - ?BINARY_XXX_MASK, [test_is_boxed(X, hipe_rtl:label_name(IsBoxedLab), FalseLab, Pred), IsBoxedLab, get_header(Tmp1, X), - mask_and_compare(Tmp1, Mask, ?TAG_HEADER_REFC_BIN, - hipe_rtl:label_name(IsBitStrLab), FalseLab, Pred), + test_bitstr_header(Tmp1, hipe_rtl:label_name(IsBitStrLab), FalseLab, Pred), IsBitStrLab, mask_and_compare(Tmp1, ?TAG_HEADER_MASK, ?TAG_HEADER_SUB_BIN, hipe_rtl:label_name(IsSubBinLab), TrueLab, 0.5), @@ -453,6 +455,10 @@ test_fixnums_1([Arg1, Arg2|Args], Acc) -> Tmp = hipe_rtl:mk_new_reg_gcsafe(), test_fixnums_1([Tmp|Args], [hipe_rtl:mk_alu(Tmp, Arg1, 'and', Arg2)|Acc]). +test_two_fixnums(Arg, Arg, FalseLab) -> + TrueLab = hipe_rtl:mk_new_label(), + [test_fixnum(Arg, hipe_rtl:label_name(TrueLab), FalseLab, 0.99), + TrueLab]; test_two_fixnums(Arg1, Arg2, FalseLab) -> TrueLab = hipe_rtl:mk_new_label(), case hipe_rtl:is_imm(Arg1) orelse hipe_rtl:is_imm(Arg2) of @@ -567,8 +573,8 @@ fixnum_andorxor(AluOp, Arg1, Arg2, Res) -> case AluOp of 'xor' -> Tmp = hipe_rtl:mk_new_reg_gcsafe(), - [hipe_rtl:mk_alu(Tmp, Arg1, 'xor', Arg2), % clears tag :-( - hipe_rtl:mk_alu(Res, Tmp, 'or', hipe_rtl:mk_imm(?TAG_IMMED1_SMALL))]; + [hipe_rtl:mk_alu(Tmp, Arg1, 'sub', hipe_rtl:mk_imm(?TAG_IMMED1_SMALL)), + hipe_rtl:mk_alu(Res, Tmp, 'xor', Arg2)]; _ -> hipe_rtl:mk_alu(Res, Arg1, AluOp, Arg2) end. @@ -595,6 +601,21 @@ fixnum_bsl(Arg1, Arg2, Res) -> %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Test if either of two values are immediate (primary tag IMMED1, 0x3) +test_either_immed(Arg1, Arg2, TrueLab, FalseLab) -> + %% This test assumes primary tag 0x0 is reserved and immed has tag 0x3 + 16#0 = ?TAG_PRIMARY_HEADER, + 16#3 = ?TAG_PRIMARY_IMMED1, + Tmp1 = hipe_rtl:mk_new_reg_gcsafe(), + Tmp2 = hipe_rtl:mk_new_reg_gcsafe(), + [hipe_rtl:mk_alu(Tmp1, Arg1, 'sub', hipe_rtl:mk_imm(1)), + hipe_rtl:mk_alu(Tmp2, Arg2, 'sub', hipe_rtl:mk_imm(1)), + hipe_rtl:mk_alu(Tmp2, Tmp2, 'or', Tmp1), + hipe_rtl:mk_branch(Tmp2, 'and', hipe_rtl:mk_imm(2), eq, + FalseLab, TrueLab, 0.01)]. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + unsafe_car(Dst, Arg) -> hipe_rtl:mk_load(Dst, Arg, hipe_rtl:mk_imm(-(?TAG_PRIMARY_LIST))). @@ -631,14 +652,13 @@ unsafe_update_element(Tuple, Index, Value) -> % Index is an immediate element(Dst, Index, Tuple, FailLabName, {tuple, A}, IndexInfo) -> FixnumOkLab = hipe_rtl:mk_new_label(), IndexOkLab = hipe_rtl:mk_new_label(), - Ptr = hipe_rtl:mk_new_reg(), % offset from Tuple UIndex = hipe_rtl:mk_new_reg_gcsafe(), Arity = hipe_rtl:mk_imm(A), - InvIndex = hipe_rtl:mk_new_reg_gcsafe(), - Offset = hipe_rtl:mk_new_reg_gcsafe(), case IndexInfo of valid -> %% This is no branch, 1 load and 3 alus = 4 instr + Offset = hipe_rtl:mk_new_reg_gcsafe(), + Ptr = hipe_rtl:mk_new_reg(), % offset from Tuple [untag_fixnum(UIndex, Index), hipe_rtl:mk_alu(Ptr, Tuple, 'sub', hipe_rtl:mk_imm(?TAG_PRIMARY_BOXED)), hipe_rtl:mk_alu(Offset, UIndex, 'sll', @@ -647,72 +667,56 @@ element(Dst, Index, Tuple, FailLabName, {tuple, A}, IndexInfo) -> fixnums -> %% This is 1 branch, 1 load and 4 alus = 6 instr [untag_fixnum(UIndex, Index), - hipe_rtl:mk_alu(Ptr, Tuple, 'sub',hipe_rtl:mk_imm(?TAG_PRIMARY_BOXED))| - gen_element_tail(Dst, Ptr, InvIndex, Arity, Offset, UIndex, - FailLabName, IndexOkLab)]; + gen_element_tail(Dst, Tuple, Arity, UIndex, FailLabName, IndexOkLab)]; _ -> %% This is 3 branches, 1 load and 5 alus = 9 instr [test_fixnum(Index, hipe_rtl:label_name(FixnumOkLab), FailLabName, 0.99), FixnumOkLab, untag_fixnum(UIndex, Index), - hipe_rtl:mk_alu(Ptr, Tuple, 'sub',hipe_rtl:mk_imm(?TAG_PRIMARY_BOXED))| - gen_element_tail(Dst, Ptr, InvIndex, Arity, Offset, UIndex, - FailLabName, IndexOkLab)] + gen_element_tail(Dst, Tuple, Arity, UIndex, FailLabName, IndexOkLab)] end; element(Dst, Index, Tuple, FailLabName, tuple, IndexInfo) -> FixnumOkLab = hipe_rtl:mk_new_label(), IndexOkLab = hipe_rtl:mk_new_label(), - Ptr = hipe_rtl:mk_new_reg(), % offset from Tuple Header = hipe_rtl:mk_new_reg_gcsafe(), UIndex = hipe_rtl:mk_new_reg_gcsafe(), Arity = hipe_rtl:mk_new_reg_gcsafe(), - InvIndex = hipe_rtl:mk_new_reg_gcsafe(), - Offset = hipe_rtl:mk_new_reg_gcsafe(), case IndexInfo of fixnums -> %% This is 1 branch, 2 loads and 5 alus = 8 instr - [hipe_rtl:mk_alu(Ptr, Tuple, 'sub', hipe_rtl:mk_imm(?TAG_PRIMARY_BOXED)), - hipe_rtl:mk_load(Header, Ptr, hipe_rtl:mk_imm(0)), + [get_header(Header, Tuple), untag_fixnum(UIndex, Index), hipe_rtl:mk_alu(Arity,Header,'srl',hipe_rtl:mk_imm(?HEADER_ARITY_OFFS))| - gen_element_tail(Dst, Ptr, InvIndex, Arity, Offset, UIndex, - FailLabName, IndexOkLab)]; + gen_element_tail(Dst, Tuple, Arity, UIndex, FailLabName, IndexOkLab)]; Num when is_integer(Num) -> %% This is 1 branch, 1 load and 3 alus = 5 instr - [hipe_rtl:mk_alu(Ptr, Tuple, 'sub', hipe_rtl:mk_imm(?TAG_PRIMARY_BOXED))| - gen_element_tail(Dst, Ptr, InvIndex, hipe_rtl:mk_imm(Num), - Offset, UIndex, FailLabName, IndexOkLab)]; + gen_element_tail(Dst, Tuple, hipe_rtl:mk_imm(Num), UIndex, FailLabName, + IndexOkLab); _ -> %% This is 2 branches, 2 loads and 6 alus = 10 instr [test_fixnum(Index, hipe_rtl:label_name(FixnumOkLab), FailLabName, 0.99), FixnumOkLab, - hipe_rtl:mk_alu(Ptr, Tuple, 'sub', hipe_rtl:mk_imm(?TAG_PRIMARY_BOXED)), - hipe_rtl:mk_load(Header, Ptr, hipe_rtl:mk_imm(0)), + get_header(Header, Tuple), untag_fixnum(UIndex, Index), hipe_rtl:mk_alu(Arity,Header,'srl',hipe_rtl:mk_imm(?HEADER_ARITY_OFFS))| - gen_element_tail(Dst, Ptr, InvIndex, Arity, Offset, UIndex, - FailLabName, IndexOkLab)] + gen_element_tail(Dst, Tuple, Arity, UIndex, FailLabName, IndexOkLab)] end; element(Dst, Index, Tuple, FailLabName, unknown, IndexInfo) -> FixnumOkLab = hipe_rtl:mk_new_label(), BoxedOkLab = hipe_rtl:mk_new_label(), TupleOkLab = hipe_rtl:mk_new_label(), IndexOkLab = hipe_rtl:mk_new_label(), - Ptr = hipe_rtl:mk_new_reg(), % offset from Tuple Header = hipe_rtl:mk_new_reg_gcsafe(), UIndex = hipe_rtl:mk_new_reg_gcsafe(), Arity = hipe_rtl:mk_new_reg_gcsafe(), - InvIndex = hipe_rtl:mk_new_reg_gcsafe(), - Offset = hipe_rtl:mk_new_reg_gcsafe(), case IndexInfo of fixnums -> %% This is 3 branches, 2 loads and 5 alus = 10 instr [test_is_boxed(Tuple, hipe_rtl:label_name(BoxedOkLab), FailLabName, 0.99), BoxedOkLab, - hipe_rtl:mk_alu(Ptr, Tuple, 'sub', hipe_rtl:mk_imm(?TAG_PRIMARY_BOXED)), - hipe_rtl:mk_load(Header, Ptr, hipe_rtl:mk_imm(0)), + get_header(Header, Tuple), hipe_rtl:mk_branch(Header, 'and', hipe_rtl:mk_imm(?TAG_HEADER_MASK), 'eq', hipe_rtl:label_name(TupleOkLab), FailLabName, 0.99), @@ -720,23 +724,21 @@ element(Dst, Index, Tuple, FailLabName, unknown, IndexInfo) -> untag_fixnum(UIndex, Index), hipe_rtl:mk_alu(Arity, Header, 'srl', hipe_rtl:mk_imm(?HEADER_ARITY_OFFS))| - gen_element_tail(Dst, Ptr, InvIndex, Arity, Offset, - UIndex, FailLabName, IndexOkLab)]; + gen_element_tail(Dst, Tuple, Arity, UIndex, FailLabName, IndexOkLab)]; Num when is_integer(Num) -> %% This is 3 branches, 2 loads and 4 alus = 9 instr [test_is_boxed(Tuple, hipe_rtl:label_name(BoxedOkLab), FailLabName, 0.99), BoxedOkLab, - hipe_rtl:mk_alu(Ptr, Tuple, 'sub', hipe_rtl:mk_imm(?TAG_PRIMARY_BOXED)), - hipe_rtl:mk_load(Header, Ptr, hipe_rtl:mk_imm(0)), + get_header(Header, Tuple), hipe_rtl:mk_branch(Header, 'and', hipe_rtl:mk_imm(?TAG_HEADER_MASK), 'eq', hipe_rtl:label_name(TupleOkLab), FailLabName, 0.99), TupleOkLab, hipe_rtl:mk_alu(Arity, Header, 'srl', hipe_rtl:mk_imm(?HEADER_ARITY_OFFS))| - gen_element_tail(Dst, Ptr, InvIndex, Arity, Offset, - hipe_rtl:mk_imm(Num), FailLabName, IndexOkLab)]; + gen_element_tail(Dst, Tuple, Arity, hipe_rtl:mk_imm(Num), FailLabName, + IndexOkLab)]; _ -> %% This is 4 branches, 2 loads, and 6 alus = 12 instr :( [test_fixnum(Index, hipe_rtl:label_name(FixnumOkLab), @@ -745,8 +747,7 @@ element(Dst, Index, Tuple, FailLabName, unknown, IndexInfo) -> test_is_boxed(Tuple, hipe_rtl:label_name(BoxedOkLab), FailLabName, 0.99), BoxedOkLab, - hipe_rtl:mk_alu(Ptr, Tuple, 'sub', hipe_rtl:mk_imm(?TAG_PRIMARY_BOXED)), - hipe_rtl:mk_load(Header, Ptr, hipe_rtl:mk_imm(0)), + get_header(Header, Tuple), hipe_rtl:mk_branch(Header, 'and', hipe_rtl:mk_imm(?TAG_HEADER_MASK), 'eq', hipe_rtl:label_name(TupleOkLab), FailLabName, 0.99), @@ -754,20 +755,21 @@ element(Dst, Index, Tuple, FailLabName, unknown, IndexInfo) -> untag_fixnum(UIndex, Index), hipe_rtl:mk_alu(Arity, Header, 'srl', hipe_rtl:mk_imm(?HEADER_ARITY_OFFS))| - gen_element_tail(Dst, Ptr, InvIndex, Arity, Offset, - UIndex, FailLabName, IndexOkLab)] + gen_element_tail(Dst, Tuple, Arity, UIndex, FailLabName, IndexOkLab)] end. -gen_element_tail(Dst, Ptr, InvIndex, Arity, Offset, - UIndex, FailLabName, IndexOkLab) -> +gen_element_tail(Dst, Tuple, Arity, UIndex, FailLabName, IndexOkLab) -> + ZeroIndex = hipe_rtl:mk_new_reg_gcsafe(), + Offset = hipe_rtl:mk_new_reg_gcsafe(), + Ptr = hipe_rtl:mk_new_reg(), % offset from Tuple %% now check that 1 <= UIndex <= Arity - %% if UIndex < 1, then (Arity - UIndex) >= Arity - %% if UIndex > Arity, then (Arity - UIndex) < 0, which is >=u Arity - %% otherwise, 0 <= (Arity - UIndex) < Arity - [hipe_rtl:mk_alu(InvIndex, Arity, 'sub', UIndex), - hipe_rtl:mk_branch(InvIndex, 'geu', Arity, FailLabName, + %% by checking the equivalent (except for when Arity>=2^(WordSize-1)) + %% (UIndex - 1) <u Arity + [hipe_rtl:mk_alu(ZeroIndex, UIndex, 'sub', hipe_rtl:mk_imm(1)), + hipe_rtl:mk_branch(ZeroIndex, 'geu', Arity, FailLabName, hipe_rtl:label_name(IndexOkLab), 0.01), IndexOkLab, + hipe_rtl:mk_alu(Ptr, Tuple, 'sub', hipe_rtl:mk_imm(?TAG_PRIMARY_BOXED)), hipe_rtl:mk_alu(Offset, UIndex, 'sll', hipe_rtl:mk_imm(hipe_rtl_arch:log2_word_size())), hipe_rtl:mk_load(Dst, Ptr, Offset)]. diff --git a/lib/hipe/test/basic_SUITE_data/basic_tuples.erl b/lib/hipe/test/basic_SUITE_data/basic_tuples.erl index 94c187e364..96e39d565a 100644 --- a/lib/hipe/test/basic_SUITE_data/basic_tuples.erl +++ b/lib/hipe/test/basic_SUITE_data/basic_tuples.erl @@ -55,6 +55,8 @@ test_element(T0, T1, T2, N) -> List = lists:seq(1, N), Tuple = list_to_tuple(List), ok = get_elements(List, Tuple, 1), + %% element/2 of larger tuple with omitted bounds test + true = lists:all(fun(I) -> I * I =:= square(I) end, lists:seq(1, 20)), %% some cases that throw exceptions {'EXIT', _} = (catch my_element(0, T2)), {'EXIT', _} = (catch my_element(3, T2)), @@ -73,6 +75,18 @@ get_elements([Element|Rest], Tuple, Pos) -> get_elements([], _Tuple, _Pos) -> ok. +squares() -> + {1*1, 2*2, 3*3, 4*4, 5*5, 6*6, 7*7, 8*8, 9*9, 10*10, + 11*11, 12*12, 13*13, 14*14, 15*15, 16*16, 17*17, 18*18, 19*19, 20*20}. + +square(N) when is_integer(N), N >= 1, N =< 20 -> + %% The guard tests lets the range analysis conclude N to be an integer in the + %% 1..20 range. 20-1=19 is bigger than ?SET_LIMIT in erl_types.erl, and will + %% thus be represented by an ?int_range() rather than an ?int_set(). + %% Because of the range analysis, the bounds test of this element/2 call + %% should be omitted. + element(N, squares()). + %%-------------------------------------------------------------------- %% Tests set_element/3. diff --git a/lib/hipe/x86/hipe_rtl_to_x86.erl b/lib/hipe/x86/hipe_rtl_to_x86.erl index 29cad6ca51..31e4f6e4ac 100644 --- a/lib/hipe/x86/hipe_rtl_to_x86.erl +++ b/lib/hipe/x86/hipe_rtl_to_x86.erl @@ -124,7 +124,6 @@ conv_insn(I, Map, Data) -> hipe_rtl:call_continuation(I), hipe_rtl:call_fail(I), hipe_rtl:call_type(I)), - %% XXX Fixme: this ++ is probably inefficient. {FixArgs++I2, Map2, Data}; #comment{} -> I2 = [hipe_x86:mk_comment(hipe_rtl:comment_text(I))], diff --git a/lib/hipe/x86/hipe_x86_assemble.erl b/lib/hipe/x86/hipe_x86_assemble.erl index ef9c32ef41..fb0beba293 100644 --- a/lib/hipe/x86/hipe_x86_assemble.erl +++ b/lib/hipe/x86/hipe_x86_assemble.erl @@ -148,6 +148,8 @@ insn_size(I) -> translate_insn(I, Context, Options) -> case I of + #alu{aluop='xor', src=#x86_temp{reg=Reg}=Src, dst=#x86_temp{reg=Reg}=Dst} -> + [{'xor', {temp_to_reg32(Dst), temp_to_rm32(Src)}, I}]; #alu{} -> Arg = resolve_alu_args(hipe_x86:alu_src(I), hipe_x86:alu_dst(I), Context), [{hipe_x86:alu_op(I), Arg, I}]; @@ -228,11 +230,11 @@ translate_insn(I, Context, Options) -> #move64{} -> translate_move64(I, Context); #movsx{} -> - Arg = resolve_movx_args(hipe_x86:movsx_src(I), hipe_x86:movsx_dst(I)), - [{movsx, Arg, I}]; + Src = resolve_movx_src(hipe_x86:movsx_src(I)), + [{movsx, {temp_to_regArch(hipe_x86:movsx_dst(I)), Src}, I}]; #movzx{} -> - Arg = resolve_movx_args(hipe_x86:movzx_src(I), hipe_x86:movzx_dst(I)), - [{movzx, Arg, I}]; + Src = resolve_movx_src(hipe_x86:movzx_src(I)), + [{movzx, {temp_to_reg32(hipe_x86:movzx_dst(I)), Src}, I}]; %% pseudo_call: eliminated before assembly %% pseudo_jcc: eliminated before assembly %% pseudo_tailcall: eliminated before assembly @@ -845,16 +847,15 @@ translate_move64(I, _Context) -> exit({?MODULE, I}). -endif. %%% mov{s,z}x -resolve_movx_args(Src=#x86_mem{type=Type}, Dst=#x86_temp{}) -> - {temp_to_regArch(Dst), - case Type of - byte -> - mem_to_rm8(Src); - int16 -> - mem_to_rm16(Src); - int32 -> - mem_to_rm32(Src) - end}. +resolve_movx_src(Src=#x86_mem{type=Type}) -> + case Type of + byte -> + mem_to_rm8(Src); + int16 -> + mem_to_rm16(Src); + int32 -> + mem_to_rm32(Src) + end. %%% alu/cmp (_not_ test) resolve_alu_args(Src, Dst, Context) -> diff --git a/lib/hipe/x86/hipe_x86_postpass.erl b/lib/hipe/x86/hipe_x86_postpass.erl index b84e9bed91..925054dd68 100644 --- a/lib/hipe/x86/hipe_x86_postpass.erl +++ b/lib/hipe/x86/hipe_x86_postpass.erl @@ -57,9 +57,10 @@ postpass(#defun{code=Code0}=Defun, Options) -> peephole_optimization(Insns) -> peep(Insns, [], []). -%% MoveSelf related peep-opts + +%% MoveSelf related peep-opts %% ------------------------------ -peep([#fmove{src=Src, dst=Src} | Insns], Res,Lst) -> +peep([#fmove{src=Src, dst=Src} | Insns], Res,Lst) -> peep(Insns, Res, [moveSelf1|Lst]); peep([I=#fmove{src=Src, dst=Dst}, #fmove{src=Dst, dst=Src} | Insns], Res,Lst) -> @@ -159,8 +160,7 @@ peep([#jcc{label=Lab}, I=#label{label=Lab}|Insns], Res, Lst) -> %% ElimSet0 %% -------- -peep([#move{src=#x86_imm{value=0},dst=Dst}|Insns],Res,Lst) -when (Dst==#x86_temp{}) -> +peep([#move{src=#x86_imm{value=0},dst=Dst=#x86_temp{}}|Insns],Res,Lst) -> peep(Insns, [#alu{aluop='xor', src=Dst, dst=Dst}|Res], [elimSet0|Lst]); %% ElimMDPow2 diff --git a/lib/inets/doc/src/notes.xml b/lib/inets/doc/src/notes.xml index 5c3b5a2d3c..1d8432ee35 100644 --- a/lib/inets/doc/src/notes.xml +++ b/lib/inets/doc/src/notes.xml @@ -713,7 +713,7 @@ <list> <item> <p> - Gracefully handle invalid content-lenght headers instead + Gracefully handle invalid content-length headers instead of crashing in list_to_integer.</p> <p> Own Id: OTP-12429</p> diff --git a/lib/inets/src/http_client/httpc_response.erl b/lib/inets/src/http_client/httpc_response.erl index 0fd5faa466..d24705a845 100644 --- a/lib/inets/src/http_client/httpc_response.erl +++ b/lib/inets/src/http_client/httpc_response.erl @@ -434,7 +434,7 @@ format_response({StatusLine, Headers, Body}) -> Length = list_to_integer(Headers#http_response_h.'content-length'), {NewBody, Data} = case Length of - -1 -> % When no lenght indicator is provided + -1 -> % When no length indicator is provided {Body, <<>>}; Length when (Length =< size(Body)) -> <<BodyThisReq:Length/binary, Next/binary>> = Body, diff --git a/lib/inets/test/httpd_1_1.erl b/lib/inets/test/httpd_1_1.erl index 3755ed117b..2b5968ca12 100644 --- a/lib/inets/test/httpd_1_1.erl +++ b/lib/inets/test/httpd_1_1.erl @@ -405,11 +405,11 @@ getRangeSize(Head)-> {multiPart, BoundaryString}; _X1 -> case re:run(Head, ?CONTENT_RANGE "bytes=.*\r\n", [{capture, first}]) of - {match, [{Start, Lenght}]} -> + {match, [{Start, Length}]} -> %% Get the range data remove the fieldname and the %% end of line. RangeInfo = string:substr(Head, Start + 1 + 20, - Lenght - (20 +2)), + Length - (20 +2)), rangeSize(string:strip(RangeInfo)); _X2 -> error diff --git a/lib/inets/test/httpd_test_data/server_root/conf/httpd.conf b/lib/inets/test/httpd_test_data/server_root/conf/httpd.conf index 3f9fde03b5..ec05fc6714 100644 --- a/lib/inets/test/httpd_test_data/server_root/conf/httpd.conf +++ b/lib/inets/test/httpd_test_data/server_root/conf/httpd.conf @@ -128,7 +128,7 @@ SecurityDiskLogSize 200000 10 MaxClients 50 -# KeepAlive set the flag for persistent connections. For peristent connections +# KeepAlive set the flag for persistent connections. For persistent connections # set KeepAlive to on. To use One request per connection set the flag to off # Note: The value has changed since previous version of INETS. KeepAlive on diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/conf/httpd.conf b/lib/inets/test/old_httpd_SUITE_data/server_root/conf/httpd.conf index 3f9fde03b5..ec05fc6714 100644 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/conf/httpd.conf +++ b/lib/inets/test/old_httpd_SUITE_data/server_root/conf/httpd.conf @@ -128,7 +128,7 @@ SecurityDiskLogSize 200000 10 MaxClients 50 -# KeepAlive set the flag for persistent connections. For peristent connections +# KeepAlive set the flag for persistent connections. For persistent connections # set KeepAlive to on. To use One request per connection set the flag to off # Note: The value has changed since previous version of INETS. KeepAlive on diff --git a/lib/jinterface/java_src/com/ericsson/otp/erlang/AbstractConnection.java b/lib/jinterface/java_src/com/ericsson/otp/erlang/AbstractConnection.java index 7891871e76..b9b4223155 100644 --- a/lib/jinterface/java_src/com/ericsson/otp/erlang/AbstractConnection.java +++ b/lib/jinterface/java_src/com/ericsson/otp/erlang/AbstractConnection.java @@ -30,7 +30,7 @@ import java.util.Random; * received from the peer. * * <p> - * This abstract class provides the neccesary methods to maintain the actual + * This abstract class provides the necessary methods to maintain the actual * connection and encode the messages and headers in the proper format according * to the Erlang distribution protocol. Subclasses can use these methods to * provide a more or less transparent communication channel as desired. diff --git a/lib/jinterface/java_src/com/ericsson/otp/erlang/OtpMbox.java b/lib/jinterface/java_src/com/ericsson/otp/erlang/OtpMbox.java index 70c9e6db4a..bd3a3f4ad3 100644 --- a/lib/jinterface/java_src/com/ericsson/otp/erlang/OtpMbox.java +++ b/lib/jinterface/java_src/com/ericsson/otp/erlang/OtpMbox.java @@ -38,7 +38,7 @@ package com.ericsson.otp.erlang; * <p> * Mailboxes can be named, either at creation or later. Messages can be sent to * named mailboxes and named Erlang processes without knowing the - * {@link OtpErlangPid pid} that identifies the mailbox. This is neccessary in + * {@link OtpErlangPid pid} that identifies the mailbox. This is necessary in * order to set up initial communication between parts of an application. Each * mailbox can have at most one name. * </p> diff --git a/lib/kernel/doc/src/notes.xml b/lib/kernel/doc/src/notes.xml index 9277c2d353..d80c4f077c 100644 --- a/lib/kernel/doc/src/notes.xml +++ b/lib/kernel/doc/src/notes.xml @@ -108,7 +108,7 @@ <item> <p> Close stdin of commands run in os:cmd. This is a - backwards compatiblity fix that restores the behaviour of + backwards compatibility fix that restores the behaviour of pre 19.0 os:cmd.</p> <p> Own Id: OTP-13867 Aux Id: seq13178 </p> @@ -1445,7 +1445,7 @@ dependent, so applications aiming to be portable should consider using <c>{ipv6_v6only,true}</c> when creating an <c>inet6</c> listening/destination socket, and if - neccesary also create an <c>inet</c> socket on the same + necessary also create an <c>inet</c> socket on the same port for IPv4 traffic. See the documentation.</p> <p> Own Id: OTP-8928 Aux Id: kunagi-193 [104] </p> diff --git a/lib/kernel/include/inet.hrl b/lib/kernel/include/inet.hrl index b39df8c3f2..df788aca08 100644 --- a/lib/kernel/include/inet.hrl +++ b/lib/kernel/include/inet.hrl @@ -22,7 +22,7 @@ -record(hostent, { - h_name :: inet:hostname(), %% offical name of host + h_name :: inet:hostname(), %% official name of host h_aliases = [] :: [inet:hostname()], %% alias list h_addrtype :: 'inet' | 'inet6', %% host address type h_length :: non_neg_integer(), %% length of address diff --git a/lib/kernel/src/dist_ac.erl b/lib/kernel/src/dist_ac.erl index 6c2fa0b6b1..e63c969b79 100644 --- a/lib/kernel/src/dist_ac.erl +++ b/lib/kernel/src/dist_ac.erl @@ -123,7 +123,7 @@ load_application(AppName, DistNodes) -> gen_server:call(?DIST_AC, {load_application, AppName, DistNodes}, infinity). takeover_application(AppName, RestartType) -> - case validRestartType(RestartType) of + case valid_restart_type(RestartType) of true -> wait_for_sync_dacs(), Nodes = get_nodes(AppName), @@ -1514,10 +1514,10 @@ dist_del_node(Appls, Node) -> Appl#appl{run = NRun} end, Appls). -validRestartType(permanent) -> true; -validRestartType(temporary) -> true; -validRestartType(transient) -> true; -validRestartType(_RestartType) -> false. +valid_restart_type(permanent) -> true; +valid_restart_type(temporary) -> true; +valid_restart_type(transient) -> true; +valid_restart_type(_RestartType) -> false. dist_mismatch(AppName, Node) -> error_msg("Distribution mismatch for application \"~p\" on nodes ~p and ~p~n", diff --git a/lib/kernel/src/inet_parse.erl b/lib/kernel/src/inet_parse.erl index b0a3ee3008..9b47199e08 100644 --- a/lib/kernel/src/inet_parse.erl +++ b/lib/kernel/src/inet_parse.erl @@ -701,8 +701,8 @@ dup(N, E, L) when is_integer(N), N >= 1 -> -%% Convert IPv4 adress to ascii -%% Convert IPv6 / IPV4 adress to ascii (plain format) +%% Convert IPv4 address to ascii +%% Convert IPv6 / IPV4 address to ascii (plain format) ntoa({A,B,C,D}) -> integer_to_list(A) ++ "." ++ integer_to_list(B) ++ "." ++ integer_to_list(C) ++ "." ++ integer_to_list(D); diff --git a/lib/kernel/src/inet_udp.erl b/lib/kernel/src/inet_udp.erl index 8a8aa8ecca..c69791b9aa 100644 --- a/lib/kernel/src/inet_udp.erl +++ b/lib/kernel/src/inet_udp.erl @@ -113,7 +113,7 @@ fdopen(Fd, Opts) -> %% Here's how: %% Reverse the list. %% For each head option go through the tail and remove -%% all occurences of the same option from the tail. +%% all occurrences of the same option from the tail. %% Store that head option and iterate using the new tail. %% Return the list of stored head options. optuniquify(List) -> @@ -122,8 +122,8 @@ optuniquify(List) -> optuniquify([], Result) -> Result; optuniquify([Opt | Tail], Result) -> - %% Remove all occurences of Opt in Tail, - %% prepend Opt to Result, + %% Remove all occurrences of Opt in Tail, + %% prepend Opt to Result, %% then iterate back here. optuniquify(Opt, Tail, [], Result). diff --git a/lib/kernel/src/kernel.appup.src b/lib/kernel/src/kernel.appup.src index b505524471..2dc90e2b3e 100644 --- a/lib/kernel/src/kernel.appup.src +++ b/lib/kernel/src/kernel.appup.src @@ -18,7 +18,7 @@ %% %CopyrightEnd% {"%VSN%", %% Up from - max one major revision back - [{<<"5\\.[0-1](\\.[0-9]+)*">>,[restart_new_emulator]}], % OTP-19.* + [{<<"5\\.[0-2](\\.[0-9]+)*">>,[restart_new_emulator]}], % OTP-19.* %% Down to - max one major revision back - [{<<"5\\.[0-1](\\.[0-9]+)*">>,[restart_new_emulator]}] % OTP-19.* + [{<<"5\\.[0-2](\\.[0-9]+)*">>,[restart_new_emulator]}] % OTP-19.* }. diff --git a/lib/kernel/src/os.erl b/lib/kernel/src/os.erl index c3ffcb3f70..7e83b17add 100644 --- a/lib/kernel/src/os.erl +++ b/lib/kernel/src/os.erl @@ -298,12 +298,11 @@ get_data(Port, MonRef, Eot, Sofar) -> more -> get_data(Port, MonRef, Eot, [Sofar,Bytes]); Last -> - Port ! {self(), close}, - flush_until_closed(Port), - flush_exit(Port), + catch port_close(Port), + flush_until_down(Port, MonRef), iolist_to_binary([Sofar, Last]) end; - {'DOWN', MonRef, _, _ , _} -> + {'DOWN', MonRef, _, _, _} -> flush_exit(Port), iolist_to_binary(Sofar) end. @@ -317,18 +316,25 @@ eot(Bs, Eot) -> binary:part(Bs,{0, Pos}) end. -flush_until_closed(Port) -> +%% When port_close returns we know that all the +%% messages sent have been sent and that the +%% DOWN message is after them all. +flush_until_down(Port, MonRef) -> receive {Port, {data, _Bytes}} -> - flush_until_closed(Port); - {Port, closed} -> - true + flush_until_down(Port, MonRef); + {'DOWN', MonRef, _, _, _} -> + flush_exit(Port) end. +%% The exit signal is always delivered before +%% the down signal, so we can be sure that if there +%% was an exit message sent, it will be in the +%% mailbox now. flush_exit(Port) -> receive {'EXIT', Port, _} -> ok - after 1 -> % force context switch + after 0 -> ok end. diff --git a/lib/kernel/test/application_SUITE.erl b/lib/kernel/test/application_SUITE.erl index 81407e9d96..b4cf31b210 100644 --- a/lib/kernel/test/application_SUITE.erl +++ b/lib/kernel/test/application_SUITE.erl @@ -1498,7 +1498,7 @@ otp_5363(Conf) when is_list(Conf) -> %% Ticket: OTP-5606 %% Slogan: Problems with starting a distributed application %%----------------------------------------------------------------- -%% Test of several processes simultanously starting the same +%% Test of several processes simultaneously starting the same %% distributed application. otp_5606(Conf) when is_list(Conf) -> diff --git a/lib/kernel/test/code_SUITE.erl b/lib/kernel/test/code_SUITE.erl index f368232bfc..19d36a7613 100644 --- a/lib/kernel/test/code_SUITE.erl +++ b/lib/kernel/test/code_SUITE.erl @@ -621,20 +621,28 @@ sticky_compiler(Files, PrivDir) -> [R || R <- Rets, R =/= ok]. do_sticky_compile(Mod, Dir) -> - %% Make sure that the module is loaded. A module being sticky - %% only prevents it from begin reloaded, not from being loaded - %% from the wrong place to begin with. - Mod = Mod:module_info(module), - File = filename:append(Dir, atom_to_list(Mod)), - Src = io_lib:format("-module(~s).\n" - "-export([test/1]).\n" - "test(me) -> fail.\n", [Mod]), - ok = file:write_file(File++".erl", Src), - case c:c(File, [{outdir,Dir}]) of - {ok,Module} -> - Module:test(me); - {error,sticky_directory} -> - ok + case code:is_sticky(Mod) of + true -> + %% Make sure that the module is loaded. A module being sticky + %% only prevents it from begin reloaded, not from being loaded + %% from the wrong place to begin with. + Mod = Mod:module_info(module), + File = filename:append(Dir, atom_to_list(Mod)), + Src = io_lib:format("-module(~s).\n" + "-export([test/1]).\n" + "test(me) -> fail.\n", [Mod]), + ok = file:write_file(File++".erl", Src), + case c:c(File, [{outdir,Dir}]) of + {ok,Module} -> + Module:test(me); + {error,sticky_directory} -> + ok + end; + false -> + %% For some reason the module is not sticky + %% could be that the .erlang file has + %% unstuck it? + {Mod, is_not_sticky} end. %% Test that the -pa and -pz options work as expected. @@ -1352,9 +1360,8 @@ create_big_boot(Config) -> %% corresponding beam file (if hipe is not enabled). filter_app("hipe",_) -> false; -%% Dialyzer and typer depends on hipe +%% Dialyzer depends on hipe filter_app("dialyzer",_) -> false; -filter_app("typer",_) -> false; %% Orber requires explicit configuration filter_app("orber",_) -> false; diff --git a/lib/kernel/test/erl_distribution_SUITE.erl b/lib/kernel/test/erl_distribution_SUITE.erl index f630896e03..09c80a0956 100644 --- a/lib/kernel/test/erl_distribution_SUITE.erl +++ b/lib/kernel/test/erl_distribution_SUITE.erl @@ -233,7 +233,7 @@ time_ping(Node) -> erlang:convert_time_unit(T1 - T0, native, millisecond). %% Keep the connection with the client node up. -%% This is neccessary as the client node runs with much shorter +%% This is necessary as the client node runs with much shorter %% tick time !! keep_conn(Node) -> sleep(1), @@ -1059,7 +1059,7 @@ monitor_nodes_otp_6481_test(Config, TestType) when is_list(Config) -> RemotePid = spawn(Node, fun () -> receive after 1500 -> ok end, - %% infinit loop of msgs + %% infinite loop of msgs %% we want an endless stream of messages and the kill %% the node mercilessly. %% We then want to ensure that the nodedown message arrives diff --git a/lib/kernel/test/erl_distribution_wb_SUITE.erl b/lib/kernel/test/erl_distribution_wb_SUITE.erl index 6a23ad0d11..61aa3b32ee 100644 --- a/lib/kernel/test/erl_distribution_wb_SUITE.erl +++ b/lib/kernel/test/erl_distribution_wb_SUITE.erl @@ -30,7 +30,7 @@ %% 1) %% -%% Connections are now always set up symetrically with respect to +%% Connections are now always set up symmetrically with respect to %% publication. If connecting node doesn't send DFLAG_PUBLISHED %% the other node wont send DFLAG_PUBLISHED. If the connecting %% node send DFLAG_PUBLISHED but the other node doesn't send diff --git a/lib/kernel/test/file_SUITE.erl b/lib/kernel/test/file_SUITE.erl index f2094431d8..b402f01758 100644 --- a/lib/kernel/test/file_SUITE.erl +++ b/lib/kernel/test/file_SUITE.erl @@ -18,7 +18,7 @@ %% %CopyrightEnd% %% -%% This is a developement feature when developing a new file module, +%% This is a development feature when developing a new file module, %% ugly but practical. -ifndef(FILE_MODULE). -define(FILE_MODULE, file). diff --git a/lib/kernel/test/file_SUITE_data/realmen.html b/lib/kernel/test/file_SUITE_data/realmen.html index c810a5d088..92e13f23b8 100644 --- a/lib/kernel/test/file_SUITE_data/realmen.html +++ b/lib/kernel/test/file_SUITE_data/realmen.html @@ -237,7 +237,7 @@ destroy most of the interesting uses for EQUIVALENCE, and make it impossible to modify the operating system code with negative subscripts. Worst of all, bounds checking is inefficient. -<LI> Source code maintainance systems. A Real Programmer keeps his +<LI> Source code maintenance systems. A Real Programmer keeps his code locked up in a card file, because it implies that its owner cannot leave his important programs unguarded [5]. @@ -396,7 +396,7 @@ double stuff Oreos for special occasions. <LI> Underneath the Oreos is a flow-charting template, left there by the previous occupant of the office. (Real Programmers write programs, -not documentation. Leave that to the maintainence people.) +not documentation. Leave that to the maintenance people.) </UL> <P> diff --git a/lib/megaco/src/text/megaco_text_gen_prev3a.hrl b/lib/megaco/src/text/megaco_text_gen_prev3a.hrl index ae4a990779..9c75ee5926 100644 --- a/lib/megaco/src/text/megaco_text_gen_prev3a.hrl +++ b/lib/megaco/src/text/megaco_text_gen_prev3a.hrl @@ -424,7 +424,7 @@ enc_TransactionReply(#'TransactionReply'{transactionId = Tid, transactionResult = Res, %% These fields are actually not %% supported in this implementation, - %% but because the messanger module + %% but because the messenger module %% cannot see any diff between the %% various v3 implementations... segmentNumber = asn1_NOVALUE, diff --git a/lib/megaco/src/text/megaco_text_gen_prev3b.hrl b/lib/megaco/src/text/megaco_text_gen_prev3b.hrl index e7fb85d137..7e85be4d64 100644 --- a/lib/megaco/src/text/megaco_text_gen_prev3b.hrl +++ b/lib/megaco/src/text/megaco_text_gen_prev3b.hrl @@ -424,7 +424,7 @@ enc_TransactionReply(#'TransactionReply'{transactionId = Tid, transactionResult = Res, %% These fields are actually not %% supported in this implementation, - %% but because the messanger module + %% but because the messenger module %% cannot see any diff between the %% various v3 implementations... segmentNumber = asn1_NOVALUE, diff --git a/lib/megaco/src/text/megaco_text_gen_prev3c.hrl b/lib/megaco/src/text/megaco_text_gen_prev3c.hrl index 722e97a743..700392efe2 100644 --- a/lib/megaco/src/text/megaco_text_gen_prev3c.hrl +++ b/lib/megaco/src/text/megaco_text_gen_prev3c.hrl @@ -434,7 +434,7 @@ enc_TransactionReply(#'TransactionReply'{transactionId = Tid, transactionResult = Res, %% These fields are actually not %% supported in this implementation, - %% but because the messanger module + %% but because the messenger module %% cannot see any diff between the %% various v3 implementations... segmentNumber = asn1_NOVALUE, diff --git a/lib/mnesia/src/mnesia_monitor.erl b/lib/mnesia/src/mnesia_monitor.erl index ab78c9b13e..ff58974aba 100644 --- a/lib/mnesia/src/mnesia_monitor.erl +++ b/lib/mnesia/src/mnesia_monitor.erl @@ -169,7 +169,7 @@ check_protocol([{Node, {accept, Mon, Version, Protocol}} | Tail], Protocols) -> verbose("Failed to connect with ~p. ~p protocols rejected. " "expected version = ~p, expected protocol = ~p~n", [Node, Protocols, Version, Protocol]), - unlink(Mon), % Get rid of unneccessary link + unlink(Mon), % Get rid of unnecessary link check_protocol(Tail, Protocols) end; check_protocol([{Node, {reject, _Mon, Version, Protocol}} | Tail], Protocols) -> diff --git a/lib/mnesia/src/mnesia_schema.erl b/lib/mnesia/src/mnesia_schema.erl index 0e4017e4c3..b0d7965886 100644 --- a/lib/mnesia/src/mnesia_schema.erl +++ b/lib/mnesia/src/mnesia_schema.erl @@ -1941,7 +1941,7 @@ make_change_table_copy_type(Tab, Node, ToS) -> %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% change index functions .... -%% Pos is allready added by 1 in both of these functions +%% Pos is already added by 1 in both of these functions add_table_index(Tab, Pos) -> schema_transaction(fun() -> do_add_table_index(Tab, Pos) end). diff --git a/lib/observer/src/observer_wx.erl b/lib/observer/src/observer_wx.erl index 3031a1f90d..83de4fa64c 100644 --- a/lib/observer/src/observer_wx.erl +++ b/lib/observer/src/observer_wx.erl @@ -636,7 +636,8 @@ create_connect_dialog(connect, #state{frame = Frame}) -> wxWindow:setSizerAndFit(Dialog, VSizer), wxSizer:setSizeHints(VSizer, Dialog), - CookiePath = filename:join(os:getenv("HOME"), ".erlang.cookie"), + {ok,[[HomeDir]]} = init:get_argument(home), + CookiePath = filename:join(HomeDir, ".erlang.cookie"), DefaultCookie = case filelib:is_file(CookiePath) of true -> {ok, Bin} = file:read_file(CookiePath), diff --git a/lib/observer/test/crashdump_helper.erl b/lib/observer/test/crashdump_helper.erl index 4239a3d0d1..e57c8162e4 100644 --- a/lib/observer/test/crashdump_helper.erl +++ b/lib/observer/test/crashdump_helper.erl @@ -44,7 +44,7 @@ n1_proc(Creator,_N2,Pid2,Port2,_L) -> Ref = make_ref(), Pid = self(), Bin = list_to_binary(lists:seq(1, 255)), - SubBin = element(1, split_binary(element(2, split_binary(Bin, 8)), 17)), + <<_:2,SubBin:17/binary,_/bits>> = Bin, register(named_port,Port), diff --git a/lib/orber/src/cdr_encode.erl b/lib/orber/src/cdr_encode.erl index f922b330a0..d8d1809f9d 100644 --- a/lib/orber/src/cdr_encode.erl +++ b/lib/orber/src/cdr_encode.erl @@ -683,7 +683,7 @@ enc_fixed(_Env, Digits, Scale, Fixed, _Bytes, _Len) -> orber:dbg("[~p] cdr_encode:enc_fixed(~p, ~p, ~p)~n" "The supplied fixed type incorrect. Check that the 'digits' and 'scale' field~n" "match the definition in the IDL-specification. The value field must be~n" - "a list of Digits lenght.", + "a list of Digits length.", [?LINE, Digits, Scale, Fixed], ?DEBUG_LEVEL), corba:raise(#'MARSHAL'{completion_status=?COMPLETED_MAYBE}). diff --git a/lib/orber/src/orber_iiop.hrl b/lib/orber/src/orber_iiop.hrl index 6bc82fb6d6..1b5d6a84ef 100644 --- a/lib/orber/src/orber_iiop.hrl +++ b/lib/orber/src/orber_iiop.hrl @@ -279,8 +279,8 @@ %%---------------------------------------------------------------------- %% Profile Body %% -%% iiop_version: describes the version of IIOP that the agent at the -%% specified adress is prepared to receive. +%% iiop_version: describes the version of IIOP that the agent at the +%% specified address is prepared to receive. %% host: identifies the internet host to which the GIOP messages %% for the specified object may be sent. %% port: contains the TCP?IP port number where the target agnet is listening diff --git a/lib/orber/src/orber_initial_references.erl b/lib/orber/src/orber_initial_references.erl index 738d702088..8caf69a68b 100644 --- a/lib/orber/src/orber_initial_references.erl +++ b/lib/orber/src/orber_initial_references.erl @@ -89,7 +89,7 @@ install(Timeout, Options) -> end, Wait = mnesia:wait_for_tables([orber_references], Timeout), - %% Check if any error has occured yet. If there are errors, return them. + %% Check if any error has occurred yet. If there are errors, return them. if DB_Result == {atomic, ok}, Wait == ok -> diff --git a/lib/orber/src/orber_objectkeys.erl b/lib/orber/src/orber_objectkeys.erl index 1233e4e721..3b1851e9b5 100644 --- a/lib/orber/src/orber_objectkeys.erl +++ b/lib/orber/src/orber_objectkeys.erl @@ -344,7 +344,7 @@ install(Timeout, Options) -> end, Wait = mnesia:wait_for_tables([orber_objkeys], Timeout), - %% Check if any error has occured yet. If there are errors, return them. + %% Check if any error has occurred yet. If there are errors, return them. if DB_Result == {atomic, ok}, Wait == ok -> diff --git a/lib/parsetools/src/leex.erl b/lib/parsetools/src/leex.erl index 602e47404d..e0f37ae9df 100644 --- a/lib/parsetools/src/leex.erl +++ b/lib/parsetools/src/leex.erl @@ -1264,7 +1264,7 @@ pack_dfa([], _, Rs, PDFA) -> {PDFA,Rs}. %% {Action, AcceptLength, CurrTokLen, RestChars, Line, State}. %% The return CurrTokLen is always the current number of characters -%% scanned in the current token. The returns have the follwoing +%% scanned in the current token. The returns have the following %% meanings: %% {Action, AcceptLength, RestChars, Line} - %% The scanner has reached an accepting end-state, for example after @@ -1281,7 +1281,7 @@ pack_dfa([], _, Rs, PDFA) -> {PDFA,Rs}. %% %% {reject, AcceptLength, CurrTokLen, RestChars, Line, State} - %% {Action, AcceptLength, CurrTokLen, RestChars, Line, State} - -%% The scanner has reached a non-accepting transistion state. If +%% The scanner has reached a non-accepting transition state. If %% RestChars == [] we need to get more characters to continue. %% Otherwise if 'reject' then no accepting state has been reached it %% is an error. If we have an Action and AcceptLength then these are diff --git a/lib/public_key/asn1/PKCS-8.asn1 b/lib/public_key/asn1/PKCS-8.asn1 index 8412345b68..292a7b2029 100644 --- a/lib/public_key/asn1/PKCS-8.asn1 +++ b/lib/public_key/asn1/PKCS-8.asn1 @@ -26,7 +26,7 @@ BEGIN -- This import is really unnecessary since ALGORITHM-IDENTIFIER is defined as a -- TYPE-IDENTIFIER --- Renome this import and replace all occurences of ALGORITHM-IDENTIFIER with +-- Rename this import and replace all occurrences of ALGORITHM-IDENTIFIER with -- TYPE-IDENTIFIER as a workaround for weaknesses in the ASN.1 compiler --AlgorithmIdentifier, ALGORITHM-IDENTIFIER -- FROM PKCS5v2-0 {iso(1) member-body(2) us(840) rsadsi(113549) diff --git a/lib/public_key/doc/src/public_key.xml b/lib/public_key/doc/src/public_key.xml index 37aa05e0fd..2300ce3937 100644 --- a/lib/public_key/doc/src/public_key.xml +++ b/lib/public_key/doc/src/public_key.xml @@ -331,13 +331,16 @@ </func> <func> - <name>generate_key(Params) -> {Public::binary(), Private::binary()} | #'ECPrivateKey'{} </name> + <name>generate_key(Params) -> {Public::binary(), Private::binary()} | #'ECPrivateKey'{} | {#'RSAPublicKey'{}, #'RSAPrivateKey'{}}</name> <fsummary>Generates a new keypair.</fsummary> <type> - <v>Params = #'DHParameter'{} | {namedCurve, oid()} | #'ECParameters'{}</v> + <v>Params = #'DHParameter'{} | {namedCurve, oid()} | #'ECParameters'{} + | {rsa, Size::integer(), PubExp::integer} </v> </type> <desc> - <p>Generates a new keypair.</p> + <p>Generates a new keypair. See also + <seealso marker="crypto:crypto#generate_key/2">crypto:generate_key/2</seealso> + </p> </desc> </func> @@ -857,6 +860,7 @@ fun(#'DistributionPoint'{}, #'CertificateList'{}, <func> <name>ssh_hostkey_fingerprint(HostKey) -> string()</name> <name>ssh_hostkey_fingerprint(DigestType, HostKey) -> string()</name> + <name>ssh_hostkey_fingerprint([DigestType], HostKey) -> [string()]</name> <fsummary>Calculates a ssh fingerprint for a hostkey.</fsummary> <type> <v>Key = public_key()</v> @@ -880,6 +884,10 @@ fun(#'DistributionPoint'{}, #'CertificateList'{}, 5> public_key:ssh_hostkey_fingerprint(sha256,Key). "SHA256:aZGXhabfbf4oxglxltItWeHU7ub3Dc31NcNw2cMJePQ" + + 6> public_key:ssh_hostkey_fingerprint([sha,sha256],Key). + ["SHA1:bSLY/C4QXLDL/Iwmhyg0PGW9UbY", + "SHA256:aZGXhabfbf4oxglxltItWeHU7ub3Dc31NcNw2cMJePQ"] </code> </desc> </func> diff --git a/lib/public_key/src/public_key.app.src b/lib/public_key/src/public_key.app.src index 88ef07c5a6..dbd732c384 100644 --- a/lib/public_key/src/public_key.app.src +++ b/lib/public_key/src/public_key.app.src @@ -14,7 +14,7 @@ {applications, [asn1, crypto, kernel, stdlib]}, {registered, []}, {env, []}, - {runtime_dependencies, ["stdlib-2.0","kernel-3.0","erts-6.0","crypto-3.3", + {runtime_dependencies, ["stdlib-2.0","kernel-3.0","erts-6.0","crypto-3.8", "asn1-3.0"]} ] }. diff --git a/lib/public_key/src/public_key.erl b/lib/public_key/src/public_key.erl index 42b6826404..8f185bbbd4 100644 --- a/lib/public_key/src/public_key.erl +++ b/lib/public_key/src/public_key.erl @@ -395,9 +395,15 @@ dh_gex_group(Min, N, Max, Groups) -> pubkey_ssh:dh_gex_group(Min, N, Max, Groups). %%-------------------------------------------------------------------- --spec generate_key(#'DHParameter'{} | {namedCurve, Name ::oid()} | - #'ECParameters'{}) -> {Public::binary(), Private::binary()} | - #'ECPrivateKey'{}. +-spec generate_key(#'DHParameter'{}) -> + {Public::binary(), Private::binary()}; + ({namedCurve, Name ::oid()}) -> + #'ECPrivateKey'{}; + (#'ECParameters'{}) -> + #'ECPrivateKey'{}; + ({rsa, Size::pos_integer(), PubExp::pos_integer()}) -> + {#'RSAPublicKey'{}, #'RSAPrivateKey'{}}. + %% Description: Generates a new keypair %%-------------------------------------------------------------------- generate_key(#'DHParameter'{prime = P, base = G}) -> @@ -405,7 +411,49 @@ generate_key(#'DHParameter'{prime = P, base = G}) -> generate_key({namedCurve, _} = Params) -> ec_generate_key(Params); generate_key(#'ECParameters'{} = Params) -> - ec_generate_key(Params). + ec_generate_key(Params); +generate_key({rsa, ModulusSize, PublicExponent}) -> + case crypto:generate_key(rsa, {ModulusSize,PublicExponent}) of + {[E, N], [E, N, D, P, Q, D_mod_P_1, D_mod_Q_1, InvQ_mod_P]} -> + Nint = crypto:bytes_to_integer(N), + Eint = crypto:bytes_to_integer(E), + {#'RSAPublicKey'{modulus = Nint, + publicExponent = Eint}, + #'RSAPrivateKey'{version = 0, % Two-factor (I guess since otherPrimeInfos is not given) + modulus = Nint, + publicExponent = Eint, + privateExponent = crypto:bytes_to_integer(D), + prime1 = crypto:bytes_to_integer(P), + prime2 = crypto:bytes_to_integer(Q), + exponent1 = crypto:bytes_to_integer(D_mod_P_1), + exponent2 = crypto:bytes_to_integer(D_mod_Q_1), + coefficient = crypto:bytes_to_integer(InvQ_mod_P)} + }; + + {[E, N], [E, N, D]} -> % FIXME: what to set the other fields in #'RSAPrivateKey'? + % Answer: Miller [Mil76] + % G.L. Miller. Riemann's hypothesis and tests for primality. + % Journal of Computer and Systems Sciences, + % 13(3):300-307, + % 1976. + Nint = crypto:bytes_to_integer(N), + Eint = crypto:bytes_to_integer(E), + {#'RSAPublicKey'{modulus = Nint, + publicExponent = Eint}, + #'RSAPrivateKey'{version = 0, % Two-factor (I guess since otherPrimeInfos is not given) + modulus = Nint, + publicExponent = Eint, + privateExponent = crypto:bytes_to_integer(D), + prime1 = '?', + prime2 = '?', + exponent1 = '?', + exponent2 = '?', + coefficient = '?'} + }; + + Other -> + Other + end. %%-------------------------------------------------------------------- -spec compute_key(#'ECPoint'{} , #'ECPrivateKey'{}) -> binary(). @@ -893,21 +941,31 @@ oid2ssh_curvename(?'secp521r1') -> <<"nistp521">>. %%-------------------------------------------------------------------- -spec ssh_hostkey_fingerprint(public_key()) -> string(). --spec ssh_hostkey_fingerprint(digest_type(), public_key()) -> string(). +-spec ssh_hostkey_fingerprint( digest_type(), public_key()) -> string() + ; ([digest_type()], public_key()) -> [string()] + . ssh_hostkey_fingerprint(Key) -> - sshfp_string(md5, Key). + sshfp_string(md5, public_key:ssh_encode(Key,ssh2_pubkey) ). -ssh_hostkey_fingerprint(HashAlg, Key) -> - lists:concat([sshfp_alg_name(HashAlg), - [$: | sshfp_string(HashAlg, Key)] - ]). +ssh_hostkey_fingerprint(HashAlgs, Key) when is_list(HashAlgs) -> + EncKey = public_key:ssh_encode(Key, ssh2_pubkey), + [sshfp_full_string(HashAlg,EncKey) || HashAlg <- HashAlgs]; +ssh_hostkey_fingerprint(HashAlg, Key) when is_atom(HashAlg) -> + EncKey = public_key:ssh_encode(Key, ssh2_pubkey), + sshfp_full_string(HashAlg, EncKey). -sshfp_string(HashAlg, Key) -> + +sshfp_string(HashAlg, EncodedKey) -> %% Other HashAlgs than md5 will be printed with %% other formats than hextstr by %% ssh-keygen -E <alg> -lf <file> - fp_fmt(sshfp_fmt(HashAlg), crypto:hash(HashAlg, public_key:ssh_encode(Key,ssh2_pubkey))). + fp_fmt(sshfp_fmt(HashAlg), crypto:hash(HashAlg, EncodedKey)). + +sshfp_full_string(HashAlg, EncKey) -> + lists:concat([sshfp_alg_name(HashAlg), + [$: | sshfp_string(HashAlg, EncKey)] + ]). sshfp_alg_name(sha) -> "SHA1"; sshfp_alg_name(Alg) -> string:to_upper(atom_to_list(Alg)). @@ -1188,8 +1246,11 @@ ec_curve_spec( #'ECParameters'{fieldID = FieldId, curve = PCurve, base = Base, o FieldId#'FieldID'.parameters}, Curve = {PCurve#'Curve'.a, PCurve#'Curve'.b, none}, {Field, Curve, Base, Order, CoFactor}; -ec_curve_spec({namedCurve, OID}) -> - pubkey_cert_records:namedCurves(OID). +ec_curve_spec({namedCurve, OID}) when is_tuple(OID), is_integer(element(1,OID)) -> + ec_curve_spec({namedCurve, pubkey_cert_records:namedCurves(OID)}); +ec_curve_spec({namedCurve, Name}) when is_atom(Name) -> + crypto:ec_curve(Name). + ec_key({PubKey, PrivateKey}, Params) -> #'ECPrivateKey'{version = 1, diff --git a/lib/public_key/test/erl_make_certs.erl b/lib/public_key/test/erl_make_certs.erl index 3dab70784c..00be7dd5b3 100644 --- a/lib/public_key/test/erl_make_certs.erl +++ b/lib/public_key/test/erl_make_certs.erl @@ -346,10 +346,24 @@ make_key(ec, _Opts) -> %% RSA key generation (OBS: for testing only) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +gen_rsa2(Size) -> + try + %% The numbers 2048,17 is choosen to not cause the cryptolib on + %% FIPS-enabled test machines be mad at us. + public_key:generate_key({rsa, 2048, 17}) + of + {_Public, Private} -> Private + catch + error:notsup -> + %% Disabled dirty_schedulers => crypto:generate_key not working + weak_gen_rsa2(Size) + end. + + -define(SMALL_PRIMES, [65537,97,89,83,79,73,71,67,61,59,53, 47,43,41,37,31,29,23,19,17,13,11,7,5,3]). -gen_rsa2(Size) -> +weak_gen_rsa2(Size) -> P = prime(Size), Q = prime(Size), N = P*Q, diff --git a/lib/public_key/test/public_key_SUITE.erl b/lib/public_key/test/public_key_SUITE.erl index 615ff32539..68aa152911 100644 --- a/lib/public_key/test/public_key_SUITE.erl +++ b/lib/public_key/test/public_key_SUITE.erl @@ -54,7 +54,8 @@ all() -> ssh_hostkey_fingerprint_sha, ssh_hostkey_fingerprint_sha256, ssh_hostkey_fingerprint_sha384, - ssh_hostkey_fingerprint_sha512 + ssh_hostkey_fingerprint_sha512, + ssh_hostkey_fingerprint_list ]. groups() -> @@ -93,20 +94,21 @@ end_per_group(_GroupName, Config) -> %%------------------------------------------------------------------- init_per_testcase(TestCase, Config) -> case TestCase of - ssh_hostkey_fingerprint_md5_implicit -> init_fingerprint_testcase(md5, Config); - ssh_hostkey_fingerprint_md5 -> init_fingerprint_testcase(md5, Config); - ssh_hostkey_fingerprint_sha -> init_fingerprint_testcase(sha, Config); - ssh_hostkey_fingerprint_sha256 -> init_fingerprint_testcase(sha256, Config); - ssh_hostkey_fingerprint_sha384 -> init_fingerprint_testcase(sha384, Config); - ssh_hostkey_fingerprint_sha512 -> init_fingerprint_testcase(sha512, Config); + ssh_hostkey_fingerprint_md5_implicit -> init_fingerprint_testcase([md5], Config); + ssh_hostkey_fingerprint_md5 -> init_fingerprint_testcase([md5], Config); + ssh_hostkey_fingerprint_sha -> init_fingerprint_testcase([sha], Config); + ssh_hostkey_fingerprint_sha256 -> init_fingerprint_testcase([sha256], Config); + ssh_hostkey_fingerprint_sha384 -> init_fingerprint_testcase([sha384], Config); + ssh_hostkey_fingerprint_sha512 -> init_fingerprint_testcase([sha512], Config); + ssh_hostkey_fingerprint_list -> init_fingerprint_testcase([sha,md5], Config); _ -> init_common_per_testcase(Config) end. -init_fingerprint_testcase(Alg, Config) -> - CryptoSupports = lists:member(Alg, proplists:get_value(hashs, crypto:supports())), - case CryptoSupports of - false -> {skip,{Alg,not_supported}}; - true -> init_common_per_testcase(Config) +init_fingerprint_testcase(Algs, Config) -> + Hashs = proplists:get_value(hashs, crypto:supports(), []), + case Algs -- Hashs of + [] -> init_common_per_testcase(Config); + UnsupportedAlgs -> {skip,{UnsupportedAlgs,not_supported}} end. init_common_per_testcase(Config0) -> @@ -600,6 +602,14 @@ ssh_hostkey_fingerprint_sha512(_Config) -> Expected = public_key:ssh_hostkey_fingerprint(sha512, ssh_hostkey(rsa)). %%-------------------------------------------------------------------- +%% Since this kind of fingerprint is not available yet on standard +%% distros, we do like this instead. +ssh_hostkey_fingerprint_list(_Config) -> + Expected = ["SHA1:Soammnaqg06jrm2jivMSnzQGlmk", + "MD5:4b:0b:63:de:0f:a7:3a:ab:2c:cc:2d:d1:21:37:1d:3a"], + Expected = public_key:ssh_hostkey_fingerprint([sha,md5], ssh_hostkey(rsa)). + +%%-------------------------------------------------------------------- encrypt_decrypt() -> [{doc, "Test public_key:encrypt_private and public_key:decrypt_public"}]. encrypt_decrypt(Config) when is_list(Config) -> diff --git a/lib/reltool/doc/src/notes.xml b/lib/reltool/doc/src/notes.xml index 2365a68feb..5b710a3267 100644 --- a/lib/reltool/doc/src/notes.xml +++ b/lib/reltool/doc/src/notes.xml @@ -52,13 +52,13 @@ Some dependency chains would even be missed for applications that are included in a 'rel' spec in the reltool config. E.g.</p> - <p> + <list> <item>Application x has y as included application, and y in turn has z as included application. Then z is not included. </item> <item>Application x has y in its 'applications' tag in the .app file, and y in turn has z as included application. Then z is not included.</item> - </list></p> + </list> <p> These bugs are now corrected.</p> <p> diff --git a/lib/reltool/src/reltool.hrl b/lib/reltool/src/reltool.hrl index 3b1e868757..c61c3a0c71 100644 --- a/lib/reltool/src/reltool.hrl +++ b/lib/reltool/src/reltool.hrl @@ -289,8 +289,8 @@ "^lib", "^releases"]). -define(EMBEDDED_EXCL_SYS_FILTERS, - ["^bin/(erlc|dialyzer|typer)(|\\.exe)\$", - "^erts.*/bin/(erlc|dialyzer|typer)(|\\.exe)\$", + ["^bin/(erlc|dialyzer)(|\\.exe)\$", + "^erts.*/bin/(erlc|dialyzer)(|\\.exe)\$", "^erts.*/bin/.*(debug|pdb)"]). -define(EMBEDDED_INCL_APP_FILTERS, ["^ebin", "^include", @@ -303,7 +303,7 @@ "^erts.*/bin", "^lib\$"]). -define(STANDALONE_EXCL_SYS_FILTERS, - ["^erts.*/bin/(erlc|dialyzer|typer)(|\\.exe)\$", + ["^erts.*/bin/(erlc|dialyzer)(|\\.exe)\$", "^erts.*/bin/(start|escript|to_erl|run_erl)(|\\.exe)\$", "^erts.*/bin/.*(debug|pdb)"]). -define(STANDALONE_INCL_APP_FILTERS, ["^ebin", diff --git a/lib/sasl/src/release_handler.erl b/lib/sasl/src/release_handler.erl index 1fcc9a0288..3250311b8f 100644 --- a/lib/sasl/src/release_handler.erl +++ b/lib/sasl/src/release_handler.erl @@ -831,7 +831,7 @@ do_unpack_release(Root, RelDir, ReleaseName, Releases) -> Tar = filename:join(RelDir, ReleaseName ++ ".tar.gz"), do_check_file(Tar, regular), Rel = ReleaseName ++ ".rel", - extract_rel_file(filename:join("releases", Rel), Tar, Root), + _ = extract_rel_file(filename:join("releases", Rel), Tar, Root), RelFile = filename:join(RelDir, Rel), Release = check_rel(Root, RelFile, false), #release{vsn = Vsn} = Release, @@ -1841,14 +1841,12 @@ do_check_file(Master, FileName, Type) -> %% by the user in another way, i.e. ignore this here. %%----------------------------------------------------------------- extract_rel_file(Rel, Tar, Root) -> - erl_tar:extract(Tar, [{files, [Rel]}, {cwd, Root}, compressed]). + _ = erl_tar:extract(Tar, [{files, [Rel]}, {cwd, Root}, compressed]). extract_tar(Root, Tar) -> case erl_tar:extract(Tar, [keep_old_files, {cwd, Root}, compressed]) of ok -> ok; - {error, Reason, Name} -> % Old erl_tar. - throw({error, {cannot_extract_file, Name, Reason}}); {error, {Name, Reason}} -> % New erl_tar (R3A). throw({error, {cannot_extract_file, Name, Reason}}) end. diff --git a/lib/sasl/src/systools_make.erl b/lib/sasl/src/systools_make.erl index 587bd02cb2..f03b03dc08 100644 --- a/lib/sasl/src/systools_make.erl +++ b/lib/sasl/src/systools_make.erl @@ -1908,8 +1908,10 @@ del_tar(Tar, TarName) -> file:delete(TarName). add_to_tar(Tar, FromFile, ToFile) -> - case erl_tar:add(Tar, FromFile, ToFile, [compressed, dereference]) of + case catch erl_tar:add(Tar, FromFile, ToFile, [compressed, dereference]) of ok -> ok; + {'EXIT', Reason} -> + throw({error, {tar_error, {add, FromFile, Reason}}}); {error, Error} -> throw({error, {tar_error, {add, FromFile, Error}}}) end. diff --git a/lib/snmp/test/snmp_manager_test.erl b/lib/snmp/test/snmp_manager_test.erl index 71f4017d8b..054e998af4 100644 --- a/lib/snmp/test/snmp_manager_test.erl +++ b/lib/snmp/test/snmp_manager_test.erl @@ -1760,7 +1760,7 @@ do_simple_sync_get2(Node, TargetName, Oids, Get, PostVerify) "~n Rem: ~w", [Reply, _Rem]), %% verify that the operation actually worked: - %% The order should be the same, so no need to seach + %% The order should be the same, so no need to search ?line ok = case Reply of {noError, 0, [#varbind{oid = ?sysObjectID_instance, value = SysObjectID}, @@ -2709,7 +2709,7 @@ do_simple_set2(Node, TargetName, VAVs, Set, PostVerify) -> "~n Rem: ~w", [Reply, _Rem]), %% verify that the operation actually worked: - %% The order should be the same, so no need to seach + %% The order should be the same, so no need to search %% The value we get should be exactly the same as we sent ?line ok = case Reply of {noError, 0, [#varbind{oid = ?sysName_instance, @@ -5118,10 +5118,10 @@ inform_swarm_collector(N) -> %% Note that we need to deal with re-transmissions! %% That is, the agent did not receive the ack in time, -%% and therefor did a re-transmit. This means that we -%% expect to receive more inform's then we actually -%% sent. So for sucess we assume: -%% +%% and therefor did a re-transmit. This means that we +%% expect to receive more inform's then we actually +%% sent. So for success we assume: +%% %% SentAckCnt = N %% RespCnt = N %% RecvCnt >= N diff --git a/lib/ssh/doc/src/ssh.xml b/lib/ssh/doc/src/ssh.xml index 6b49f89449..1f07e826ce 100644 --- a/lib/ssh/doc/src/ssh.xml +++ b/lib/ssh/doc/src/ssh.xml @@ -153,7 +153,7 @@ <item> <p>IP version to use.</p> </item> - <tag><c><![CDATA[{user_dir, string()}]]></c></tag> + <tag><marker id="opt_user_dir"></marker><c><![CDATA[{user_dir, string()}]]></c></tag> <item> <p>Sets the user directory, that is, the directory containing <c>ssh</c> configuration files for the user, such as @@ -175,22 +175,48 @@ supplied with this option. </p> </item> - <tag><c><![CDATA[{silently_accept_hosts, boolean() | accept_fun() | {crypto:digest_type(), accept_fun()} }]]></c> - <br/> - <c><![CDATA[accept_fun() :: fun(PeerName::string(), FingerPrint::string()) -> boolean()]]></c> + <tag> + <c><![CDATA[{silently_accept_hosts, boolean()}]]></c> <br/> + <c><![CDATA[{silently_accept_hosts, CallbackFun}]]></c> <br/> + <c><![CDATA[{silently_accept_hosts, {HashAlgoSpec, CallbackFun} }]]></c> <br/> + <br/> + <c><![CDATA[HashAlgoSpec = crypto:digest_type() | [ crypto:digest_type() ] ]]></c><br/> + <c><![CDATA[CallbackFun = fun(PeerName, FingerPrint) -> boolean()]]></c><br/> + <c><![CDATA[PeerName = string()]]></c><br/> + <c><![CDATA[FingerPrint = string() | [ string() ] ]]></c> </tag> <item> - <p>When <c>true</c>, hosts are added to the - file <c><![CDATA[known_hosts]]></c> without asking the user. - Defaults to <c>false</c> which will give a user question on stdio of whether to accept or reject a previously - unseen host.</p> - <p>If the option value is has an <c>accept_fun()</c>, that fun will called with the arguments - <c>(PeerName, PeerHostKeyFingerPrint)</c>. The fingerprint is calculated on the Peer's Host Key with - <seealso marker="public_key:public_key#ssh_hostkey_fingerprint-1">public_key:ssh_hostkey_fingerprint/1</seealso>. - </p> - <p>If the <c>crypto:digest_type()</c> is present, the fingerprint is calculated with that digest type by the function - <seealso marker="public_key:public_key#ssh_hostkey_fingerprint-2">public_key:ssh_hostkey_fingerprint/2</seealso>. - </p> + <p>This option guides the <c>connect</c> function how to act when the connected server presents a Host + Key that the client has not seen before. The default is to ask the user with a question on stdio of whether to + accept or reject the new Host Key. + See also the option <seealso marker="#opt_user_dir"><c>user_dir</c></seealso> + for the path to the file <c>known_hosts</c> where previously accepted Host Keys are recorded. + </p> + <p>The option can be given in three different forms as seen above:</p> + <list> + <item>The value is a <c>boolean()</c>. The value <c>true</c> will make the client accept any unknown + Host Key without any user interaction. The value <c>false</c> keeps the default behaviour of asking the + the user on stdio. + </item> + <item>A <c>CallbackFun</c> will be called and the boolean return value <c>true</c> will make the client + accept the Host Key. A return value of <c>false</c> will make the client to reject the Host Key and therefore + also the connection will be closed. The arguments to the fun are: + <list type="bulleted"> + <item><c>PeerName</c> - a string with the name or address of the remote host.</item> + <item><c>FingerPrint</c> - the fingerprint of the Host Key as + <seealso marker="public_key:public_key#ssh_hostkey_fingerprint-1">public_key:ssh_hostkey_fingerprint/1</seealso> + calculates it. + </item> + </list> + </item> + <item>A tuple <c>{HashAlgoSpec, CallbackFun}</c>. The <c>HashAlgoSpec</c> specifies which hash algorithm + shall be used to calculate the fingerprint used in the call of the <c>CallbackFun</c>. The <c>HashALgoSpec</c> + is either an atom or a list of atoms as the first argument in + <seealso marker="public_key:public_key#ssh_hostkey_fingerprint-2">public_key:ssh_hostkey_fingerprint/2</seealso>. + If it is a list of hash algorithm names, the <c>FingerPrint</c> argument in the <c>CallbackFun</c> will be + a list of fingerprints in the same order as the corresponding name in the <c>HashAlgoSpec</c> list. + </item> + </list> </item> <tag><c><![CDATA[{user_interaction, boolean()}]]></c></tag> <item> @@ -200,7 +226,7 @@ supplying a password. Defaults to <c>true</c>. Even if user interaction is allowed it can be suppressed by other options, such as <c>silently_accept_hosts</c> - and <c>password</c>. However, those optins are not always desirable + and <c>password</c>. However, those options are not always desirable to use from a security point of view.</p> </item> @@ -700,9 +726,10 @@ </func> <func> - <name>daemon_info(Daemon) -> {ok, [{port,Port}]} | {error,Error}</name> + <name>daemon_info(Daemon) -> {ok, [DaemonInfo]} | {error,Error}</name> <fsummary>Get info about a daemon</fsummary> <type> + <v>DaemonInfo = {port,Port::pos_integer()} | {listen_address, any|ip_address()} | {profile,atom()}</v> <v>Port = integer()</v> <v>Error = bad_daemon_ref</v> </type> diff --git a/lib/ssh/doc/src/using_ssh.xml b/lib/ssh/doc/src/using_ssh.xml index 0861c641c7..864378b640 100644 --- a/lib/ssh/doc/src/using_ssh.xml +++ b/lib/ssh/doc/src/using_ssh.xml @@ -305,7 +305,7 @@ ok = erl_tar:close(HandleRead), <code type="erl" > -module(ssh_echo_server). --behaviour(ssh_subsystem). +-behaviour(ssh_daemon_channel). -record(state, { n, id, diff --git a/lib/ssh/src/Makefile b/lib/ssh/src/Makefile index 7ab6f22424..f826fdfd9b 100644 --- a/lib/ssh/src/Makefile +++ b/lib/ssh/src/Makefile @@ -51,6 +51,7 @@ MODULES= \ ssh_sup \ sshc_sup \ sshd_sup \ + ssh_options \ ssh_connection_sup \ ssh_connection \ ssh_connection_handler \ diff --git a/lib/ssh/src/ssh.app.src b/lib/ssh/src/ssh.app.src index 2bb7491b0c..974292fde1 100644 --- a/lib/ssh/src/ssh.app.src +++ b/lib/ssh/src/ssh.app.src @@ -7,6 +7,7 @@ ssh_app, ssh_acceptor, ssh_acceptor_sup, + ssh_options, ssh_auth, ssh_message, ssh_bits, @@ -41,10 +42,10 @@ {env, []}, {mod, {ssh_app, []}}, {runtime_dependencies, [ - "crypto-3.3", + "crypto-3.7.3", "erts-6.0", "kernel-3.0", - "public_key-1.1", - "stdlib-3.1" + "public_key-1.4", + "stdlib-3.3" ]}]}. diff --git a/lib/ssh/src/ssh.erl b/lib/ssh/src/ssh.erl index 31e343e81b..e2a289d737 100644 --- a/lib/ssh/src/ssh.erl +++ b/lib/ssh/src/ssh.erl @@ -40,10 +40,24 @@ ]). %%% Type exports --export_type([connection_ref/0, - channel_id/0 +-export_type([ssh_daemon_ref/0, + ssh_connection_ref/0, + ssh_channel_id/0, + role/0, + subsystem_spec/0, + subsystem_name/0, + channel_callback/0, + channel_init_args/0, + algs_list/0, + alg_entry/0, + simple_algs/0, + double_algs/0 ]). +-opaque ssh_daemon_ref() :: daemon_ref() . +-opaque ssh_connection_ref() :: connection_ref() . +-opaque ssh_channel_id() :: channel_id(). + %%-------------------------------------------------------------------- -spec start() -> ok | {error, term()}. -spec start(permanent | transient | temporary) -> ok | {error, term()}. @@ -71,55 +85,63 @@ stop() -> application:stop(ssh). %%-------------------------------------------------------------------- --spec connect(port(), proplists:proplist()) -> {ok, pid()} | {error, term()}. +-spec connect(inet:socket(), proplists:proplist()) -> ok_error(connection_ref()). + +-spec connect(inet:socket(), proplists:proplist(), timeout()) -> ok_error(connection_ref()) + ; (string(), inet:port_number(), proplists:proplist()) -> ok_error(connection_ref()). --spec connect(port(), proplists:proplist(), timeout()) -> {ok, pid()} | {error, term()} - ; (string(), integer(), proplists:proplist()) -> {ok, pid()} | {error, term()}. +-spec connect(string(), inet:port_number(), proplists:proplist(), timeout()) -> ok_error(connection_ref()). --spec connect(string(), integer(), proplists:proplist(), timeout()) -> {ok, pid()} | {error, term()}. %% %% Description: Starts an ssh connection. %%-------------------------------------------------------------------- -connect(Socket, Options) -> - connect(Socket, Options, infinity). +connect(Socket, UserOptions) when is_port(Socket), + is_list(UserOptions) -> + connect(Socket, UserOptions, infinity). -connect(Socket, Options, Timeout) when is_port(Socket) -> - case handle_options(Options) of +connect(Socket, UserOptions, Timeout) when is_port(Socket), + is_list(UserOptions) -> + case ssh_options:handle_options(client, UserOptions) of {error, Error} -> {error, Error}; - {_SocketOptions, SshOptions} -> - case valid_socket_to_use(Socket, Options) of + Options -> + case valid_socket_to_use(Socket, ?GET_OPT(transport,Options)) of ok -> {ok, {Host,_Port}} = inet:sockname(Socket), - Opts = [{user_pid,self()}, {host,fmt_host(Host)} | SshOptions], + Opts = ?PUT_INTERNAL_OPT([{user_pid,self()}, {host,fmt_host(Host)}], Options), ssh_connection_handler:start_connection(client, Socket, Opts, Timeout); {error,SockError} -> {error,SockError} end end; -connect(Host, Port, Options) when is_integer(Port), Port>0 -> - connect(Host, Port, Options, infinity). +connect(Host, Port, UserOptions) when is_integer(Port), + Port>0, + is_list(UserOptions) -> + connect(Host, Port, UserOptions, infinity). -connect(Host, Port, Options, Timeout) -> - case handle_options(Options) of +connect(Host, Port, UserOptions, Timeout) when is_integer(Port), + Port>0, + is_list(UserOptions) -> + case ssh_options:handle_options(client, UserOptions) of {error, _Reason} = Error -> Error; - {SocketOptions, SshOptions} -> - {_, Transport, _} = TransportOpts = - proplists:get_value(transport, Options, {tcp, gen_tcp, tcp_closed}), - ConnectionTimeout = proplists:get_value(connect_timeout, Options, infinity), - try Transport:connect(Host, Port, [ {active, false} | SocketOptions], ConnectionTimeout) of + Options -> + {_, Transport, _} = TransportOpts = ?GET_OPT(transport, Options), + ConnectionTimeout = ?GET_OPT(connect_timeout, Options), + SocketOpts = [{active,false} | ?GET_OPT(socket_options,Options)], + try Transport:connect(Host, Port, SocketOpts, ConnectionTimeout) of {ok, Socket} -> - Opts = [{user_pid,self()}, {host,Host} | SshOptions], + Opts = ?PUT_INTERNAL_OPT([{user_pid,self()}, {host,Host}], Options), ssh_connection_handler:start_connection(client, Socket, Opts, Timeout); {error, Reason} -> {error, Reason} catch - exit:{function_clause, _} -> + exit:{function_clause, _F} -> + io:format('function_clause ~p~n',[_F]), {error, {options, {transport, TransportOpts}}}; exit:badarg -> - {error, {options, {socket_options, SocketOptions}}} + {error, {options, {socket_options, SocketOpts}}} end end. @@ -148,9 +170,11 @@ channel_info(ConnectionRef, ChannelId, Options) -> ssh_connection_handler:channel_info(ConnectionRef, ChannelId, Options). %%-------------------------------------------------------------------- --spec daemon(integer()) -> {ok, pid()} | {error, term()}. --spec daemon(integer()|port(), proplists:proplist()) -> {ok, pid()} | {error, term()}. --spec daemon(any | inet:ip_address(), integer(), proplists:proplist()) -> {ok, pid()} | {error, term()}. +-spec daemon(inet:port_number()) -> ok_error(daemon_ref()). +-spec daemon(inet:port_number()|inet:socket(), proplists:proplist()) -> ok_error(daemon_ref()). +-spec daemon(any | inet:ip_address(), inet:port_number(), proplists:proplist()) -> ok_error(daemon_ref()) + ;(socket, inet:socket(), proplists:proplist()) -> ok_error(daemon_ref()) + . %% Description: Starts a server listening for SSH connections %% on the given port. @@ -158,34 +182,38 @@ channel_info(ConnectionRef, ChannelId, Options) -> daemon(Port) -> daemon(Port, []). -daemon(Port, Options) when is_integer(Port) -> - daemon(any, Port, Options); -daemon(Socket, Options0) when is_port(Socket) -> - Options = daemon_shell_opt(Options0), - start_daemon(Socket, Options). +daemon(Port, UserOptions) when is_integer(Port), Port >= 0 -> + daemon(any, Port, UserOptions); + +daemon(Socket, UserOptions) when is_port(Socket) -> + daemon(socket, Socket, UserOptions). -daemon(HostAddr, Port, Options0) -> - Options1 = daemon_shell_opt(Options0), - {Host, Inet, Options} = daemon_host_inet_opt(HostAddr, Options1), - start_daemon(Host, Port, Options, Inet). + +daemon(Host0, Port, UserOptions0) -> + {Host, UserOptions} = handle_daemon_args(Host0, UserOptions0), + start_daemon(Host, Port, ssh_options:handle_options(server, UserOptions)). %%-------------------------------------------------------------------- +-spec daemon_info(daemon_ref()) -> ok_error( [{atom(), term()}] ). + daemon_info(Pid) -> case catch ssh_system_sup:acceptor_supervisor(Pid) of AsupPid when is_pid(AsupPid) -> - [Port] = - [Prt || {{ssh_acceptor_sup,any,Prt,default}, + [{ListenAddr,Port,Profile}] = + [{LA,Prt,Prf} || {{ssh_acceptor_sup,LA,Prt,Prf}, _WorkerPid,worker,[ssh_acceptor]} <- supervisor:which_children(AsupPid)], - {ok, [{port,Port}]}; - + {ok, [{port,Port}, + {listen_address,ListenAddr}, + {profile,Profile} + ]}; _ -> {error,bad_daemon_ref} end. %%-------------------------------------------------------------------- --spec stop_listener(pid()) -> ok. --spec stop_listener(inet:ip_address(), integer()) -> ok. +-spec stop_listener(daemon_ref()) -> ok. +-spec stop_listener(inet:ip_address(), inet:port_number()) -> ok. %% %% Description: Stops the listener, but leaves %% existing connections started by the listener up and running. @@ -198,8 +226,9 @@ stop_listener(Address, Port, Profile) -> ssh_system_sup:stop_listener(Address, Port, Profile). %%-------------------------------------------------------------------- --spec stop_daemon(pid()) -> ok. --spec stop_daemon(inet:ip_address(), integer()) -> ok. +-spec stop_daemon(daemon_ref()) -> ok. +-spec stop_daemon(inet:ip_address(), inet:port_number()) -> ok. +-spec stop_daemon(inet:ip_address(), inet:port_number(), atom()) -> ok. %% %% Description: Stops the listener and all connections started by %% the listener. @@ -210,10 +239,11 @@ stop_daemon(Address, Port) -> ssh_system_sup:stop_system(Address, Port, ?DEFAULT_PROFILE). stop_daemon(Address, Port, Profile) -> ssh_system_sup:stop_system(Address, Port, Profile). + %%-------------------------------------------------------------------- --spec shell(port() | string()) -> _. --spec shell(port() | string(), proplists:proplist()) -> _. --spec shell(string(), integer(), proplists:proplist()) -> _. +-spec shell(inet:socket() | string()) -> _. +-spec shell(inet:socket() | string(), proplists:proplist()) -> _. +-spec shell(string(), inet:port_number(), proplists:proplist()) -> _. %% Host = string() %% Port = integer() @@ -254,6 +284,7 @@ start_shell(Error) -> Error. %%-------------------------------------------------------------------- +-spec default_algorithms() -> algs_list() . %%-------------------------------------------------------------------- default_algorithms() -> ssh_transport:default_algorithms(). @@ -261,109 +292,96 @@ default_algorithms() -> %%-------------------------------------------------------------------- %%% Internal functions %%-------------------------------------------------------------------- -valid_socket_to_use(Socket, Options) -> - case proplists:get_value(transport, Options, {tcp, gen_tcp, tcp_closed}) of - {tcp,_,_} -> - %% Is this tcp-socket a valid socket? - case {is_tcp_socket(Socket), - {ok,[{active,false}]} == inet:getopts(Socket, [active]) - } - of - {true, true} -> - ok; - {true, false} -> - {error, not_passive_mode}; - _ -> - {error, not_tcp_socket} - end; - {L4,_,_} -> - {error, {unsupported,L4}} +handle_daemon_args(Host, UserOptions0) -> + case Host of + socket -> + {Host, UserOptions0}; + any -> + {ok, Host0} = inet:gethostname(), + Inet = proplists:get_value(inet, UserOptions0, inet), + {Host0, [Inet | UserOptions0]}; + {_,_,_,_} -> + {Host, [inet, {ip,Host} | UserOptions0]}; + {_,_,_,_,_,_,_,_} -> + {Host, [inet6, {ip,Host} | UserOptions0]}; + _ -> + error(badarg) end. -is_tcp_socket(Socket) -> {ok,[]} =/= inet:getopts(Socket, [delay_send]). - - - -daemon_shell_opt(Options) -> - case proplists:get_value(shell, Options) of - undefined -> - [{shell, {shell, start, []}} | Options]; - _ -> - Options - end. - -daemon_host_inet_opt(HostAddr, Options1) -> - case HostAddr of - any -> - {ok, Host0} = inet:gethostname(), - {Host0, proplists:get_value(inet, Options1, inet), Options1}; - {_,_,_,_} -> - {HostAddr, inet, - [{ip, HostAddr} | Options1]}; - {_,_,_,_,_,_,_,_} -> - {HostAddr, inet6, - [{ip, HostAddr} | Options1]} - end. +%%%---------------------------------------------------------------- +valid_socket_to_use(Socket, {tcp,_,_}) -> + %% Is this tcp-socket a valid socket? + case {is_tcp_socket(Socket), + {ok,[{active,false}]} == inet:getopts(Socket, [active]) + } + of + {true, true} -> + ok; + {true, false} -> + {error, not_passive_mode}; + _ -> + {error, not_tcp_socket} + end; +valid_socket_to_use(_, {L4,_,_}) -> + {error, {unsupported,L4}}. -start_daemon(Socket, Options) -> - case handle_options(Options) of - {error, Error} -> - {error, Error}; - {SocketOptions, SshOptions} -> - case valid_socket_to_use(Socket, Options) of - ok -> - try - do_start_daemon(Socket, [{role,server}|SshOptions], SocketOptions) - catch - throw:bad_fd -> {error,bad_fd}; - _C:_E -> {error,{cannot_start_daemon,_C,_E}} - end; - {error,SockError} -> - {error,SockError} - end + +is_tcp_socket(Socket) -> + case inet:getopts(Socket, [delay_send]) of + {ok,[_]} -> true; + _ -> false end. -start_daemon(Host, Port, Options, Inet) -> - case handle_options(Options) of - {error, _Reason} = Error -> - Error; - {SocketOptions, SshOptions}-> - try - do_start_daemon(Host, Port, [{role,server}|SshOptions] , [Inet|SocketOptions]) - catch - throw:bad_fd -> {error,bad_fd}; - _C:_E -> {error,{cannot_start_daemon,_C,_E}} - end +%%%---------------------------------------------------------------- +start_daemon(_, _, {error,Error}) -> + {error,Error}; + +start_daemon(socket, Socket, Options) -> + case valid_socket_to_use(Socket, ?GET_OPT(transport,Options)) of + ok -> + try + do_start_daemon(Socket, Options) + catch + throw:bad_fd -> {error,bad_fd}; + throw:bad_socket -> {error,bad_socket}; + _C:_E -> {error,{cannot_start_daemon,_C,_E}} + end; + {error,SockError} -> + {error,SockError} + end; + +start_daemon(Host, Port, Options) -> + try + do_start_daemon(Host, Port, Options) + catch + throw:bad_fd -> {error,bad_fd}; + throw:bad_socket -> {error,bad_socket}; + _C:_E -> {error,{cannot_start_daemon,_C,_E}} end. -do_start_daemon(Socket, SshOptions, SocketOptions) -> + +do_start_daemon(Socket, Options) -> {ok, {IP,Port}} = try {ok,_} = inet:sockname(Socket) catch _:_ -> throw(bad_socket) end, Host = fmt_host(IP), - Profile = proplists:get_value(profile, SshOptions, ?DEFAULT_PROFILE), - Opts = [{asocket, Socket}, - {asock_owner,self()}, - {address, Host}, - {port, Port}, - {role, server}, - {socket_opts, SocketOptions}, - {ssh_opts, SshOptions}], - {_, Callback, _} = proplists:get_value(transport, SshOptions, {tcp, gen_tcp, tcp_closed}), + Opts = ?PUT_INTERNAL_OPT([{asocket, Socket}, + {asock_owner,self()}, + {address, Host}, + {port, Port}, + {role, server}], Options), + + Profile = ?GET_OPT(profile, Options), case ssh_system_sup:system_supervisor(Host, Port, Profile) of undefined -> - %% It would proably make more sense to call the - %% address option host but that is a too big change at the - %% monent. The name is a legacy name! try sshd_sup:start_child(Opts) of {error, {already_started, _}} -> {error, eaddrinuse}; Result = {ok,_} -> - ssh_acceptor:handle_connection(Callback, Host, Port, Opts, Socket), - Result; + call_ssh_acceptor_handle_connection(Host, Port, Opts, Socket, Result); Result = {error, _} -> Result catch @@ -376,57 +394,47 @@ do_start_daemon(Socket, SshOptions, SocketOptions) -> {error, {already_started, _}} -> {error, eaddrinuse}; {ok, _} -> - ssh_acceptor:handle_connection(Callback, Host, Port, Opts, Socket), - {ok, Sup}; + call_ssh_acceptor_handle_connection(Host, Port, Opts, Socket, {ok,Sup}); Other -> Other end end. -do_start_daemon(Host0, Port0, SshOptions, SocketOptions) -> +do_start_daemon(Host0, Port0, Options0) -> {Host,Port1} = try - case proplists:get_value(fd, SocketOptions) of + case ?GET_SOCKET_OPT(fd, Options0) of undefined -> {Host0,Port0}; Fd when Port0==0 -> - find_hostport(Fd); - _ -> - {Host0,Port0} + find_hostport(Fd) end catch _:_ -> throw(bad_fd) end, - Profile = proplists:get_value(profile, SshOptions, ?DEFAULT_PROFILE), - {Port, WaitRequestControl, Opts0} = + {Port, WaitRequestControl, Options1} = case Port1 of 0 -> %% Allocate the socket here to get the port number... - {_, Callback, _} = - proplists:get_value(transport, SshOptions, {tcp, gen_tcp, tcp_closed}), - {ok,LSock} = ssh_acceptor:callback_listen(Callback, 0, SocketOptions), + {ok,LSock} = ssh_acceptor:callback_listen(0, Options0), {ok,{_,LPort}} = inet:sockname(LSock), {LPort, - {LSock,Callback}, - [{lsocket,LSock},{lsock_owner,self()}] + LSock, + ?PUT_INTERNAL_OPT({lsocket,{LSock,self()}}, Options0) }; _ -> - {Port1, false, []} + {Port1, false, Options0} end, - Opts = [{address, Host}, - {port, Port}, - {role, server}, - {socket_opts, SocketOptions}, - {ssh_opts, SshOptions} | Opts0], + Options = ?PUT_INTERNAL_OPT([{address, Host}, + {port, Port}, + {role, server}], Options1), + Profile = ?GET_OPT(profile, Options0), case ssh_system_sup:system_supervisor(Host, Port, Profile) of undefined -> - %% It would proably make more sense to call the - %% address option host but that is a too big change at the - %% monent. The name is a legacy name! - try sshd_sup:start_child(Opts) of + try sshd_sup:start_child(Options) of {error, {already_started, _}} -> {error, eaddrinuse}; Result = {ok,_} -> - sync_request_control(WaitRequestControl), + sync_request_control(WaitRequestControl, Options), Result; Result = {error, _} -> Result @@ -434,22 +442,34 @@ do_start_daemon(Host0, Port0, SshOptions, SocketOptions) -> exit:{noproc, _} -> {error, ssh_not_started} end; - Sup -> + Sup -> AccPid = ssh_system_sup:acceptor_supervisor(Sup), - case ssh_acceptor_sup:start_child(AccPid, Opts) of + case ssh_acceptor_sup:start_child(AccPid, Options) of {error, {already_started, _}} -> {error, eaddrinuse}; {ok, _} -> - sync_request_control(WaitRequestControl), + sync_request_control(WaitRequestControl, Options), {ok, Sup}; Other -> Other end end. -sync_request_control(false) -> +call_ssh_acceptor_handle_connection(Host, Port, Options, Socket, DefaultResult) -> + {_, Callback, _} = ?GET_OPT(transport, Options), + try ssh_acceptor:handle_connection(Callback, Host, Port, Options, Socket) + of + {error,Error} -> {error,Error}; + _ -> DefaultResult + catch + C:R -> {error,{could_not_start_connection,{C,R}}} + end. + + +sync_request_control(false, _Options) -> ok; -sync_request_control({LSock,Callback}) -> +sync_request_control(LSock, Options) -> + {_, Callback, _} = ?GET_OPT(transport, Options), receive {request_control,LSock,ReqPid} -> ok = Callback:controlling_process(LSock, ReqPid), @@ -465,512 +485,6 @@ find_hostport(Fd) -> ok = inet:close(S), HostPort. - -handle_options(Opts) -> - try handle_option(algs_compatibility(proplists:unfold(Opts)), [], []) of - {Inet, Ssh} -> - {handle_ip(Inet), Ssh} - catch - throw:Error -> - Error - end. - - -algs_compatibility(Os0) -> - %% Take care of old options 'public_key_alg' and 'pref_public_key_algs' - case proplists:get_value(public_key_alg, Os0) of - undefined -> - Os0; - A when is_atom(A) -> - %% Skip public_key_alg if pref_public_key_algs is defined: - Os = lists:keydelete(public_key_alg, 1, Os0), - case proplists:get_value(pref_public_key_algs,Os) of - undefined when A == 'ssh-rsa' ; A==ssh_rsa -> - [{pref_public_key_algs,['ssh-rsa','ssh-dss']} | Os]; - undefined when A == 'ssh-dss' ; A==ssh_dsa -> - [{pref_public_key_algs,['ssh-dss','ssh-rsa']} | Os]; - undefined -> - throw({error, {eoptions, {public_key_alg,A} }}); - _ -> - Os - end; - V -> - throw({error, {eoptions, {public_key_alg,V} }}) - end. - - -handle_option([], SocketOptions, SshOptions) -> - {SocketOptions, SshOptions}; -handle_option([{system_dir, _} = Opt | Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); -handle_option([{user_dir, _} = Opt | Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); -handle_option([{user_dir_fun, _} = Opt | Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); -handle_option([{silently_accept_hosts, _} = Opt | Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); -handle_option([{user_interaction, _} = Opt | Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); -handle_option([{connect_timeout, _} = Opt | Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); -handle_option([{user, _} = Opt | Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); -handle_option([{dsa_pass_phrase, _} = Opt | Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); -handle_option([{rsa_pass_phrase, _} = Opt | Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); -handle_option([{password, _} = Opt | Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); -handle_option([{user_passwords, _} = Opt | Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); -handle_option([{pwdfun, _} = Opt | Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); -handle_option([{key_cb, {Module, Options}} | Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option({key_cb, Module}), - handle_ssh_priv_option({key_cb_private, Options}) | - SshOptions]); -handle_option([{key_cb, Module} | Rest], SocketOptions, SshOptions) -> - handle_option([{key_cb, {Module, []}} | Rest], SocketOptions, SshOptions); -handle_option([{keyboard_interact_fun, _} = Opt | Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); -%%Backwards compatibility -handle_option([{allow_user_interaction, Value} | Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option({user_interaction, Value}) | SshOptions]); -handle_option([{infofun, _} = Opt | Rest],SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); -handle_option([{connectfun, _} = Opt | Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); -handle_option([{disconnectfun, _} = Opt | Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); -handle_option([{unexpectedfun, _} = Opt | Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); -handle_option([{failfun, _} = Opt | Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); -handle_option([{ssh_msg_debug_fun, _} = Opt | Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); -%%Backwards compatibility should not be underscore between ip and v6 in API -handle_option([{ip_v6_disabled, Value} | Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option({ipv6_disabled, Value}) | SshOptions]); -handle_option([{ipv6_disabled, _} = Opt | Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); -handle_option([{transport, _} = Opt | Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); -handle_option([{subsystems, _} = Opt | Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); -handle_option([{ssh_cli, _} = Opt | Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); -handle_option([{shell, _} = Opt | Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); -handle_option([{exec, _} = Opt | Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); -handle_option([{auth_methods, _} = Opt | Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); -handle_option([{auth_method_kb_interactive_data, _} = Opt | Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); -handle_option([{pref_public_key_algs, _} = Opt | Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); -handle_option([{preferred_algorithms,_} = Opt | Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); -handle_option([{dh_gex_groups,_} = Opt | Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); -handle_option([{dh_gex_limits,_} = Opt | Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); -handle_option([{quiet_mode, _} = Opt|Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); -handle_option([{idle_time, _} = Opt | Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); -handle_option([{rekey_limit, _} = Opt|Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); -handle_option([{max_sessions, _} = Opt|Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); -handle_option([{max_channels, _} = Opt|Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); -handle_option([{negotiation_timeout, _} = Opt|Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); -handle_option([{parallel_login, _} = Opt|Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); -%% (Is handled by proplists:unfold above:) -%% handle_option([parallel_login|Rest], SocketOptions, SshOptions) -> -%% handle_option(Rest, SocketOptions, [handle_ssh_option({parallel_login,true}) | SshOptions]); -handle_option([{minimal_remote_max_packet_size, _} = Opt|Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); -handle_option([{id_string, _ID} = Opt|Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); -handle_option([{profile, _ID} = Opt|Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); -handle_option([{max_random_length_padding, _Bool} = Opt|Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); -handle_option([{tstflg, _} = Opt|Rest], SocketOptions, SshOptions) -> - handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); -handle_option([Opt | Rest], SocketOptions, SshOptions) -> - handle_option(Rest, [handle_inet_option(Opt) | SocketOptions], SshOptions). - - -handle_ssh_option({tstflg,_F} = Opt) -> Opt; -handle_ssh_option({minimal_remote_max_packet_size, Value} = Opt) when is_integer(Value), Value >=0 -> - Opt; -handle_ssh_option({system_dir, Value} = Opt) when is_list(Value) -> - check_dir(Opt); -handle_ssh_option({user_dir, Value} = Opt) when is_list(Value) -> - check_dir(Opt); -handle_ssh_option({user_dir_fun, Value} = Opt) when is_function(Value) -> - Opt; -handle_ssh_option({silently_accept_hosts, Value} = Opt) when is_boolean(Value) -> - Opt; -handle_ssh_option({silently_accept_hosts, Value} = Opt) when is_function(Value,2) -> - Opt; -handle_ssh_option({silently_accept_hosts, {DigestAlg,Value}} = Opt) when is_function(Value,2) -> - case lists:member(DigestAlg, [md5, sha, sha224, sha256, sha384, sha512]) of - true -> - Opt; - false -> - throw({error, {eoptions, Opt}}) - end; -handle_ssh_option({user_interaction, Value} = Opt) when is_boolean(Value) -> - Opt; -handle_ssh_option({preferred_algorithms,[_|_]} = Opt) -> - handle_pref_algs(Opt); - -handle_ssh_option({dh_gex_groups,L0}) when is_list(L0) -> - {dh_gex_groups, - collect_per_size( - lists:foldl( - fun({N,G,P}, Acc) when is_integer(N),N>0, - is_integer(G),G>0, - is_integer(P),P>0 -> - [{N,{G,P}} | Acc]; - ({N,{G,P}}, Acc) when is_integer(N),N>0, - is_integer(G),G>0, - is_integer(P),P>0 -> - [{N,{G,P}} | Acc]; - ({N,GPs}, Acc) when is_list(GPs) -> - lists:foldr(fun({Gi,Pi}, Acci) when is_integer(Gi),Gi>0, - is_integer(Pi),Pi>0 -> - [{N,{Gi,Pi}} | Acci] - end, Acc, GPs) - end, [], L0))}; - -handle_ssh_option({dh_gex_groups,{Tag,File=[C|_]}}=Opt) when is_integer(C), C>0, - Tag == file ; - Tag == ssh_moduli_file -> - {ok,GroupDefs} = - case Tag of - file -> - file:consult(File); - ssh_moduli_file -> - case file:open(File,[read]) of - {ok,D} -> - try - {ok,Moduli} = read_moduli_file(D, 1, []), - file:close(D), - {ok, Moduli} - catch - _:_ -> - throw({error, {{eoptions, Opt}, "Bad format in file "++File}}) - end; - {error,enoent} -> - throw({error, {{eoptions, Opt}, "File not found:"++File}}); - {error,Error} -> - throw({error, {{eoptions, Opt}, io_lib:format("Error reading file ~s: ~p",[File,Error])}}) - end - end, - - try - handle_ssh_option({dh_gex_groups,GroupDefs}) - catch - _:_ -> - throw({error, {{eoptions, Opt}, "Bad format in file: "++File}}) - end; - - -handle_ssh_option({dh_gex_limits,{Min,Max}} = Opt) when is_integer(Min), Min>0, - is_integer(Max), Max>=Min -> - %% Server - Opt; -handle_ssh_option({dh_gex_limits,{Min,I,Max}} = Opt) when is_integer(Min), Min>0, - is_integer(I), I>=Min, - is_integer(Max), Max>=I -> - %% Client - Opt; -handle_ssh_option({pref_public_key_algs, Value} = Opt) when is_list(Value), length(Value) >= 1 -> - case handle_user_pref_pubkey_algs(Value, []) of - {true, NewOpts} -> - {pref_public_key_algs, NewOpts}; - _ -> - throw({error, {eoptions, Opt}}) - end; -handle_ssh_option({connect_timeout, Value} = Opt) when is_integer(Value); Value == infinity -> - Opt; -handle_ssh_option({max_sessions, Value} = Opt) when is_integer(Value), Value>0 -> - Opt; -handle_ssh_option({max_channels, Value} = Opt) when is_integer(Value), Value>0 -> - Opt; -handle_ssh_option({negotiation_timeout, Value} = Opt) when is_integer(Value); Value == infinity -> - Opt; -handle_ssh_option({parallel_login, Value} = Opt) when Value==true ; Value==false -> - Opt; -handle_ssh_option({user, Value} = Opt) when is_list(Value) -> - Opt; -handle_ssh_option({dsa_pass_phrase, Value} = Opt) when is_list(Value) -> - Opt; -handle_ssh_option({rsa_pass_phrase, Value} = Opt) when is_list(Value) -> - Opt; -handle_ssh_option({password, Value} = Opt) when is_list(Value) -> - Opt; -handle_ssh_option({user_passwords, Value} = Opt) when is_list(Value)-> - Opt; -handle_ssh_option({pwdfun, Value} = Opt) when is_function(Value,2) -> - Opt; -handle_ssh_option({pwdfun, Value} = Opt) when is_function(Value,4) -> - Opt; -handle_ssh_option({key_cb, Value} = Opt) when is_atom(Value) -> - Opt; -handle_ssh_option({key_cb, {CallbackMod, CallbackOptions}} = Opt) when is_atom(CallbackMod), - is_list(CallbackOptions) -> - Opt; -handle_ssh_option({keyboard_interact_fun, Value} = Opt) when is_function(Value,3) -> - Opt; -handle_ssh_option({compression, Value} = Opt) when is_atom(Value) -> - Opt; -handle_ssh_option({exec, {Module, Function, _}} = Opt) when is_atom(Module), - is_atom(Function) -> - Opt; -handle_ssh_option({exec, Function} = Opt) when is_function(Function) -> - Opt; -handle_ssh_option({auth_methods, Value} = Opt) when is_list(Value) -> - Opt; -handle_ssh_option({auth_method_kb_interactive_data, {Name,Instruction,Prompt,Echo}} = Opt) when is_list(Name), - is_list(Instruction), - is_list(Prompt), - is_boolean(Echo) -> - Opt; -handle_ssh_option({auth_method_kb_interactive_data, F} = Opt) when is_function(F,3) -> - Opt; -handle_ssh_option({infofun, Value} = Opt) when is_function(Value) -> - Opt; -handle_ssh_option({connectfun, Value} = Opt) when is_function(Value) -> - Opt; -handle_ssh_option({disconnectfun, Value} = Opt) when is_function(Value) -> - Opt; -handle_ssh_option({unexpectedfun, Value} = Opt) when is_function(Value,2) -> - Opt; -handle_ssh_option({failfun, Value} = Opt) when is_function(Value) -> - Opt; -handle_ssh_option({ssh_msg_debug_fun, Value} = Opt) when is_function(Value,4) -> - Opt; - -handle_ssh_option({ipv6_disabled, Value} = Opt) when is_boolean(Value) -> - throw({error, {{ipv6_disabled, Opt}, option_no_longer_valid_use_inet_option_instead}}); -handle_ssh_option({transport, {Protocol, Cb, ClosTag}} = Opt) when is_atom(Protocol), - is_atom(Cb), - is_atom(ClosTag) -> - Opt; -handle_ssh_option({subsystems, Value} = Opt) when is_list(Value) -> - Opt; -handle_ssh_option({ssh_cli, {Cb, _}}= Opt) when is_atom(Cb) -> - Opt; -handle_ssh_option({ssh_cli, no_cli} = Opt) -> - Opt; -handle_ssh_option({shell, {Module, Function, _}} = Opt) when is_atom(Module), - is_atom(Function) -> - Opt; -handle_ssh_option({shell, Value} = Opt) when is_function(Value) -> - Opt; -handle_ssh_option({quiet_mode, Value} = Opt) when is_boolean(Value) -> - Opt; -handle_ssh_option({idle_time, Value} = Opt) when is_integer(Value), Value > 0 -> - Opt; -handle_ssh_option({rekey_limit, Value} = Opt) when is_integer(Value) -> - Opt; -handle_ssh_option({id_string, random}) -> - {id_string, {random,2,5}}; %% 2 - 5 random characters -handle_ssh_option({id_string, ID} = Opt) when is_list(ID) -> - Opt; -handle_ssh_option({max_random_length_padding, Value} = Opt) when is_integer(Value), - Value =< 255 -> - Opt; -handle_ssh_option({profile, Value} = Opt) when is_atom(Value) -> - Opt; -handle_ssh_option(Opt) -> - throw({error, {eoptions, Opt}}). - -handle_ssh_priv_option({key_cb_private, Value} = Opt) when is_list(Value) -> - Opt. - -handle_inet_option({active, _} = Opt) -> - throw({error, {{eoptions, Opt}, "SSH has built in flow control, " - "and active is handled internally, user is not allowed" - "to specify this option"}}); - -handle_inet_option({inet, Value}) when (Value == inet) or (Value == inet6) -> - Value; -handle_inet_option({reuseaddr, _} = Opt) -> - throw({error, {{eoptions, Opt},"Is set internally, user is not allowed" - "to specify this option"}}); -%% Option verified by inet -handle_inet_option(Opt) -> - Opt. - - -%% Check preferred algs - -handle_pref_algs({preferred_algorithms,Algs}) -> - try alg_duplicates(Algs, [], []) of - [] -> - {preferred_algorithms, - [try ssh_transport:supported_algorithms(Key) - of - DefAlgs -> handle_pref_alg(Key,Vals,DefAlgs) - catch - _:_ -> throw({error, {{eoptions, {preferred_algorithms,Key}}, - "Bad preferred_algorithms key"}}) - end || {Key,Vals} <- Algs] - }; - - Dups -> - throw({error, {{eoptions, {preferred_algorithms,Dups}}, "Duplicates found"}}) - catch - _:_ -> - throw({error, {{eoptions, preferred_algorithms}, "Malformed"}}) - end. - -alg_duplicates([{K,V}|KVs], Ks, Dups0) -> - Dups = - case lists:member(K,Ks) of - true -> - [K|Dups0]; - false -> - Dups0 - end, - case V--lists:usort(V) of - [] -> - alg_duplicates(KVs, [K|Ks], Dups); - Ds -> - alg_duplicates(KVs, [K|Ks], Dups++Ds) - end; -alg_duplicates([], _Ks, Dups) -> - Dups. - -handle_pref_alg(Key, - Vs=[{client2server,C2Ss=[_|_]},{server2client,S2Cs=[_|_]}], - [{client2server,Sup_C2Ss},{server2client,Sup_S2Cs}] - ) -> - chk_alg_vs(Key, C2Ss, Sup_C2Ss), - chk_alg_vs(Key, S2Cs, Sup_S2Cs), - {Key, Vs}; - -handle_pref_alg(Key, - Vs=[{server2client,[_|_]},{client2server,[_|_]}], - Sup=[{client2server,_},{server2client,_}] - ) -> - handle_pref_alg(Key, lists:reverse(Vs), Sup); - -handle_pref_alg(Key, - Vs=[V|_], - Sup=[{client2server,_},{server2client,_}] - ) when is_atom(V) -> - handle_pref_alg(Key, [{client2server,Vs},{server2client,Vs}], Sup); - -handle_pref_alg(Key, - Vs=[V|_], - Sup=[S|_] - ) when is_atom(V), is_atom(S) -> - chk_alg_vs(Key, Vs, Sup), - {Key, Vs}; - -handle_pref_alg(Key, Vs, _) -> - throw({error, {{eoptions, {preferred_algorithms,[{Key,Vs}]}}, "Badly formed list"}}). - -chk_alg_vs(OptKey, Values, SupportedValues) -> - case (Values -- SupportedValues) of - [] -> Values; - Bad -> throw({error, {{eoptions, {OptKey,Bad}}, "Unsupported value(s) found"}}) - end. - -handle_ip(Inet) -> %% Default to ipv4 - case lists:member(inet, Inet) of - true -> - Inet; - false -> - case lists:member(inet6, Inet) of - true -> - Inet; - false -> - [inet | Inet] - end - end. - -check_dir({_,Dir} = Opt) -> - case directory_exist_readable(Dir) of - ok -> - Opt; - {error,Error} -> - throw({error, {eoptions,{Opt,Error}}}) - end. - -directory_exist_readable(Dir) -> - case file:read_file_info(Dir) of - {ok, #file_info{type = directory, - access = Access}} -> - case Access of - read -> ok; - read_write -> ok; - _ -> {error, eacces} - end; - - {ok, #file_info{}}-> - {error, enotdir}; - - {error, Error} -> - {error, Error} - end. - - - -collect_per_size(L) -> - lists:foldr( - fun({Sz,GP}, [{Sz,GPs}|Acc]) -> [{Sz,[GP|GPs]}|Acc]; - ({Sz,GP}, Acc) -> [{Sz,[GP]}|Acc] - end, [], lists:sort(L)). - -read_moduli_file(D, I, Acc) -> - case io:get_line(D,"") of - {error,Error} -> - {error,Error}; - eof -> - {ok, Acc}; - "#" ++ _ -> read_moduli_file(D, I+1, Acc); - <<"#",_/binary>> -> read_moduli_file(D, I+1, Acc); - Data -> - Line = if is_binary(Data) -> binary_to_list(Data); - is_list(Data) -> Data - end, - try - [_Time,_Type,_Tests,_Tries,Size,G,P] = string:tokens(Line," \r\n"), - M = {list_to_integer(Size), - {list_to_integer(G), list_to_integer(P,16)} - }, - read_moduli_file(D, I+1, [M|Acc]) - catch - _:_ -> - read_moduli_file(D, I+1, Acc) - end - end. - -handle_user_pref_pubkey_algs([], Acc) -> - {true, lists:reverse(Acc)}; -handle_user_pref_pubkey_algs([H|T], Acc) -> - case lists:member(H, ?SUPPORTED_USER_KEYS) of - true -> - handle_user_pref_pubkey_algs(T, [H| Acc]); - - false when H==ssh_dsa -> handle_user_pref_pubkey_algs(T, ['ssh-dss'| Acc]); - false when H==ssh_rsa -> handle_user_pref_pubkey_algs(T, ['ssh-rsa'| Acc]); - - false -> - false - end. - fmt_host({A,B,C,D}) -> lists:concat([A,".",B,".",C,".",D]); fmt_host(T={_,_,_,_,_,_,_,_}) -> diff --git a/lib/ssh/src/ssh.hrl b/lib/ssh/src/ssh.hrl index 4cd91177f6..c1ba58ed40 100644 --- a/lib/ssh/src/ssh.hrl +++ b/lib/ssh/src/ssh.hrl @@ -33,6 +33,10 @@ -define(REKEY_DATA_TIMOUT, 60000). -define(DEFAULT_PROFILE, default). +-define(DEFAULT_TRANSPORT, {tcp, gen_tcp, tcp_closed} ). + +-define(MAX_RND_PADDING_LEN, 15). + -define(SUPPORTED_AUTH_METHODS, "publickey,keyboard-interactive,password"). -define(SUPPORTED_USER_KEYS, ['ssh-rsa','ssh-dss','ecdsa-sha2-nistp256','ecdsa-sha2-nistp384','ecdsa-sha2-nistp521']). @@ -64,10 +68,49 @@ -define(string_utf8(X), << ?STRING(unicode:characters_to_binary(X)) >> ). -define(binary(X), << ?STRING(X) >>). +%% Cipher details -define(SSH_CIPHER_NONE, 0). -define(SSH_CIPHER_3DES, 3). -define(SSH_CIPHER_AUTHFILE, ?SSH_CIPHER_3DES). +%% Option access macros +-define(do_get_opt(C,K,O), ssh_options:get_value(C,K,O, ?MODULE,?LINE)). +-define(do_get_opt(C,K,O,D), ssh_options:get_value(C,K,O,D,?MODULE,?LINE)). + +-define(GET_OPT(Key,Opts), ?do_get_opt(user_options, Key,Opts ) ). +-define(GET_INTERNAL_OPT(Key,Opts), ?do_get_opt(internal_options,Key,Opts ) ). +-define(GET_INTERNAL_OPT(Key,Opts,Def), ?do_get_opt(internal_options,Key,Opts,Def) ). +-define(GET_SOCKET_OPT(Key,Opts), ?do_get_opt(socket_options, Key,Opts ) ). +-define(GET_SOCKET_OPT(Key,Opts,Def), ?do_get_opt(socket_options, Key,Opts,Def) ). + +-define(do_put_opt(C,KV,O), ssh_options:put_value(C,KV,O, ?MODULE,?LINE)). + +-define(PUT_OPT(KeyVal,Opts), ?do_put_opt(user_options, KeyVal,Opts) ). +-define(PUT_INTERNAL_OPT(KeyVal,Opts), ?do_put_opt(internal_options,KeyVal,Opts) ). +-define(PUT_SOCKET_OPT(KeyVal,Opts), ?do_put_opt(socket_options, KeyVal,Opts) ). + +%% Types +-type role() :: client | server . +-type ok_error(SuccessType) :: {ok, SuccessType} | {error, any()} . +-type daemon_ref() :: pid() . + +-type subsystem_spec() :: {subsystem_name(), {channel_callback(), channel_init_args()}} . +-type subsystem_name() :: string() . +-type channel_callback() :: atom() . +-type channel_init_args() :: list() . + +-type algs_list() :: list( alg_entry() ). +-type alg_entry() :: {kex, simple_algs()} + | {public_key, simple_algs()} + | {cipher, double_algs()} + | {mac, double_algs()} + | {compression, double_algs()} . +-type simple_algs() :: list( atom() ) . +-type double_algs() :: list( {client2serverlist,simple_algs()} | {server2client,simple_algs()} ) + | simple_algs() . + + +%% Records -record(ssh, { role, %% client | server @@ -127,7 +170,7 @@ recv_sequence = 0, keyex_key, keyex_info, - random_length_padding = 15, % From RFC 4253 section 6. + random_length_padding = ?MAX_RND_PADDING_LEN, % From RFC 4253 section 6. %% User auth user, diff --git a/lib/ssh/src/ssh_acceptor.erl b/lib/ssh/src/ssh_acceptor.erl index 13c9d9af4a..42be18f2ad 100644 --- a/lib/ssh/src/ssh_acceptor.erl +++ b/lib/ssh/src/ssh_acceptor.erl @@ -25,56 +25,63 @@ -include("ssh.hrl"). %% Internal application API --export([start_link/5, +-export([start_link/4, number_of_connections/1, - callback_listen/3, + callback_listen/2, handle_connection/5]). %% spawn export --export([acceptor_init/6, acceptor_loop/6]). +-export([acceptor_init/5, acceptor_loop/6]). -define(SLEEP_TIME, 200). %%==================================================================== %% Internal application API %%==================================================================== -start_link(Port, Address, SockOpts, Opts, AcceptTimeout) -> - Args = [self(), Port, Address, SockOpts, Opts, AcceptTimeout], +start_link(Port, Address, Options, AcceptTimeout) -> + Args = [self(), Port, Address, Options, AcceptTimeout], proc_lib:start_link(?MODULE, acceptor_init, Args). %%-------------------------------------------------------------------- %%% Internal functions %%-------------------------------------------------------------------- -acceptor_init(Parent, Port, Address, SockOpts, Opts, AcceptTimeout) -> - {_, Callback, _} = - proplists:get_value(transport, Opts, {tcp, gen_tcp, tcp_closed}), - - SockOwner = proplists:get_value(lsock_owner, Opts), - LSock = proplists:get_value(lsocket, Opts), - UseExistingSocket = - case catch inet:sockname(LSock) of - {ok,{_,Port}} -> is_pid(SockOwner); - _ -> false - end, - - case UseExistingSocket of - true -> - proc_lib:init_ack(Parent, {ok, self()}), +acceptor_init(Parent, Port, Address, Opts, AcceptTimeout) -> + {_, Callback, _} = ?GET_OPT(transport, Opts), + try + {LSock0,SockOwner0} = ?GET_INTERNAL_OPT(lsocket, Opts), + true = is_pid(SockOwner0), + {ok,{_,Port}} = inet:sockname(LSock0), + {LSock0, SockOwner0} + of + {LSock, SockOwner} -> + %% Use existing socket + proc_lib:init_ack(Parent, {ok, self()}), request_ownership(LSock, SockOwner), - acceptor_loop(Callback, Port, Address, Opts, LSock, AcceptTimeout); - - false -> - case (catch do_socket_listen(Callback, Port, SockOpts)) of - {ok, ListenSocket} -> - proc_lib:init_ack(Parent, {ok, self()}), - acceptor_loop(Callback, - Port, Address, Opts, ListenSocket, AcceptTimeout); - Error -> - proc_lib:init_ack(Parent, Error), - error - end + acceptor_loop(Callback, Port, Address, Opts, LSock, AcceptTimeout) + catch + error:{badkey,lsocket} -> + %% Open new socket + try + socket_listen(Port, Opts) + of + {ok, ListenSocket} -> + proc_lib:init_ack(Parent, {ok, self()}), + {_, Callback, _} = ?GET_OPT(transport, Opts), + acceptor_loop(Callback, + Port, Address, Opts, ListenSocket, AcceptTimeout); + {error,Error} -> + proc_lib:init_ack(Parent, Error), + {error,Error} + catch + _:_ -> + {error,listen_socket_failed} + end; + + _:_ -> + {error,use_existing_socket_failed} end. + request_ownership(LSock, SockOwner) -> SockOwner ! {request_control,LSock,self()}, receive @@ -82,23 +89,25 @@ request_ownership(LSock, SockOwner) -> end. -do_socket_listen(Callback, Port0, Opts) -> - Port = - case proplists:get_value(fd, Opts) of - undefined -> Port0; - _ -> 0 - end, - callback_listen(Callback, Port, Opts). - -callback_listen(Callback, Port, Opts0) -> - Opts = [{active, false}, {reuseaddr,true} | Opts0], - case Callback:listen(Port, Opts) of +socket_listen(Port0, Opts) -> + Port = case ?GET_SOCKET_OPT(fd, Opts) of + undefined -> Port0; + _ -> 0 + end, + callback_listen(Port, Opts). + + +callback_listen(Port, Opts0) -> + {_, Callback, _} = ?GET_OPT(transport, Opts0), + Opts = ?PUT_SOCKET_OPT([{active, false}, {reuseaddr,true}], Opts0), + SockOpts = ?GET_OPT(socket_options, Opts), + case Callback:listen(Port, SockOpts) of {error, nxdomain} -> - Callback:listen(Port, lists:delete(inet6, Opts)); + Callback:listen(Port, lists:delete(inet6, SockOpts)); {error, enetunreach} -> - Callback:listen(Port, lists:delete(inet6, Opts)); + Callback:listen(Port, lists:delete(inet6, SockOpts)); {error, eafnosupport} -> - Callback:listen(Port, lists:delete(inet6, Opts)); + Callback:listen(Port, lists:delete(inet6, SockOpts)); Other -> Other end. @@ -120,21 +129,21 @@ acceptor_loop(Callback, Port, Address, Opts, ListenSocket, AcceptTimeout) -> end. handle_connection(Callback, Address, Port, Options, Socket) -> - SSHopts = proplists:get_value(ssh_opts, Options, []), - Profile = proplists:get_value(profile, SSHopts, ?DEFAULT_PROFILE), + Profile = ?GET_OPT(profile, Options), SystemSup = ssh_system_sup:system_supervisor(Address, Port, Profile), - MaxSessions = proplists:get_value(max_sessions,SSHopts,infinity), + MaxSessions = ?GET_OPT(max_sessions, Options), case number_of_connections(SystemSup) < MaxSessions of true -> {ok, SubSysSup} = ssh_system_sup:start_subsystem(SystemSup, Options), ConnectionSup = ssh_subsystem_sup:connection_supervisor(SubSysSup), - Timeout = proplists:get_value(negotiation_timeout, SSHopts, 2*60*1000), + NegTimeout = ?GET_OPT(negotiation_timeout, Options), ssh_connection_handler:start_connection(server, Socket, - [{supervisors, [{system_sup, SystemSup}, - {subsystem_sup, SubSysSup}, - {connection_sup, ConnectionSup}]} - | Options], Timeout); + ?PUT_INTERNAL_OPT( + {supervisors, [{system_sup, SystemSup}, + {subsystem_sup, SubSysSup}, + {connection_sup, ConnectionSup}]}, + Options), NegTimeout); false -> Callback:close(Socket), IPstr = if is_tuple(Address) -> inet:ntoa(Address); diff --git a/lib/ssh/src/ssh_acceptor_sup.erl b/lib/ssh/src/ssh_acceptor_sup.erl index 129f85a3e0..77f7826918 100644 --- a/lib/ssh/src/ssh_acceptor_sup.erl +++ b/lib/ssh/src/ssh_acceptor_sup.erl @@ -44,14 +44,13 @@ start_link(Servers) -> supervisor:start_link(?MODULE, [Servers]). -start_child(AccSup, ServerOpts) -> - Spec = child_spec(ServerOpts), +start_child(AccSup, Options) -> + Spec = child_spec(Options), case supervisor:start_child(AccSup, Spec) of {error, already_present} -> - Address = proplists:get_value(address, ServerOpts), - Port = proplists:get_value(port, ServerOpts), - Profile = proplists:get_value(profile, - proplists:get_value(ssh_opts, ServerOpts), ?DEFAULT_PROFILE), + Address = ?GET_INTERNAL_OPT(address, Options), + Port = ?GET_INTERNAL_OPT(port, Options), + Profile = ?GET_OPT(profile, Options), stop_child(AccSup, Address, Port, Profile), supervisor:start_child(AccSup, Spec); Reply -> @@ -70,24 +69,23 @@ stop_child(AccSup, Address, Port, Profile) -> %%%========================================================================= %%% Supervisor callback %%%========================================================================= -init([ServerOpts]) -> +init([Options]) -> RestartStrategy = one_for_one, MaxR = 10, MaxT = 3600, - Children = [child_spec(ServerOpts)], + Children = [child_spec(Options)], {ok, {{RestartStrategy, MaxR, MaxT}, Children}}. %%%========================================================================= %%% Internal functions %%%========================================================================= -child_spec(ServerOpts) -> - Address = proplists:get_value(address, ServerOpts), - Port = proplists:get_value(port, ServerOpts), - Timeout = proplists:get_value(timeout, ServerOpts, ?DEFAULT_TIMEOUT), - Profile = proplists:get_value(profile, proplists:get_value(ssh_opts, ServerOpts), ?DEFAULT_PROFILE), +child_spec(Options) -> + Address = ?GET_INTERNAL_OPT(address, Options), + Port = ?GET_INTERNAL_OPT(port, Options), + Timeout = ?GET_INTERNAL_OPT(timeout, Options, ?DEFAULT_TIMEOUT), + Profile = ?GET_OPT(profile, Options), Name = id(Address, Port, Profile), - SocketOpts = proplists:get_value(socket_opts, ServerOpts), - StartFunc = {ssh_acceptor, start_link, [Port, Address, SocketOpts, ServerOpts, Timeout]}, + StartFunc = {ssh_acceptor, start_link, [Port, Address, Options, Timeout]}, Restart = transient, Shutdown = brutal_kill, Modules = [ssh_acceptor], diff --git a/lib/ssh/src/ssh_auth.erl b/lib/ssh/src/ssh_auth.erl index 9b54ecb2dd..88c8144063 100644 --- a/lib/ssh/src/ssh_auth.erl +++ b/lib/ssh/src/ssh_auth.erl @@ -96,14 +96,14 @@ unique(L) -> password_msg([#ssh{opts = Opts, io_cb = IoCb, user = User, service = Service} = Ssh0]) -> {Password,Ssh} = - case proplists:get_value(password, Opts) of + case ?GET_OPT(password, Opts) of undefined when IoCb == ssh_no_io -> {not_ok, Ssh0}; undefined -> - {IoCb:read_password("ssh password: ",Ssh0), Ssh0}; + {IoCb:read_password("ssh password: ",Opts), Ssh0}; PW -> %% If "password" option is given it should not be tried again - {PW, Ssh0#ssh{opts = lists:keyreplace(password,1,Opts,{password,not_ok})}} + {PW, Ssh0#ssh{opts = ?PUT_OPT({password,not_ok}, Opts)}} end, case Password of not_ok -> @@ -123,7 +123,7 @@ password_msg([#ssh{opts = Opts, io_cb = IoCb, keyboard_interactive_msg([#ssh{user = User, opts = Opts, service = Service} = Ssh]) -> - case proplists:get_value(password, Opts) of + case ?GET_OPT(password, Opts) of not_ok -> {not_ok,Ssh}; % No need to use a failed pwd once more _ -> @@ -141,8 +141,9 @@ publickey_msg([Alg, #ssh{user = User, service = Service, opts = Opts} = Ssh]) -> Hash = ssh_transport:sha(Alg), - KeyCb = proplists:get_value(key_cb, Opts, ssh_file), - case KeyCb:user_key(Alg, Opts) of + {KeyCb,KeyCbOpts} = ?GET_OPT(key_cb, Opts), + UserOpts = ?GET_OPT(user_options, Opts), + case KeyCb:user_key(Alg, [{key_cb_private,KeyCbOpts}|UserOpts]) of {ok, PrivKey} -> StrAlgo = atom_to_list(Alg), case encode_public_key(StrAlgo, ssh_transport:extract_public_key(PrivKey)) of @@ -174,13 +175,19 @@ service_request_msg(Ssh) -> %%%---------------------------------------------------------------- init_userauth_request_msg(#ssh{opts = Opts} = Ssh) -> - case user_name(Opts) of - {ok, User} -> + case ?GET_OPT(user, Opts) of + undefined -> + ErrStr = "Could not determine the users name", + ssh_connection_handler:disconnect( + #ssh_msg_disconnect{code = ?SSH_DISCONNECT_ILLEGAL_USER_NAME, + description = ErrStr}); + + User -> Msg = #ssh_msg_userauth_request{user = User, service = "ssh-connection", method = "none", data = <<>>}, - Algs0 = proplists:get_value(pref_public_key_algs, Opts, ?SUPPORTED_USER_KEYS), + Algs0 = ?GET_OPT(pref_public_key_algs, Opts), %% The following line is not strictly correct. The call returns the %% supported HOST key types while we are interested in USER keys. However, %% they "happens" to be the same (for now). This could change.... @@ -194,12 +201,7 @@ init_userauth_request_msg(#ssh{opts = Opts} = Ssh) -> ssh_transport:ssh_packet(Msg, Ssh#ssh{user = User, userauth_preference = Prefs, userauth_methods = none, - service = "ssh-connection"}); - {error, no_user} -> - ErrStr = "Could not determine the users name", - ssh_connection_handler:disconnect( - #ssh_msg_disconnect{code = ?SSH_DISCONNECT_ILLEGAL_USER_NAME, - description = ErrStr}) + service = "ssh-connection"}) end. %%%---------------------------------------------------------------- @@ -342,7 +344,7 @@ handle_userauth_request(#ssh_msg_userauth_request{user = User, false}, {Name, Instruction, Prompt, Echo} = - case proplists:get_value(auth_method_kb_interactive_data, Opts) of + case ?GET_OPT(auth_method_kb_interactive_data, Opts) of undefined -> Default; {_,_,_,_}=V -> @@ -407,9 +409,9 @@ handle_userauth_info_response(#ssh_msg_userauth_info_response{num_responses = 1, user = User, userauth_supported_methods = Methods} = Ssh) -> SendOneEmpty = - (proplists:get_value(tstflg,Opts) == one_empty) + (?GET_OPT(tstflg,Opts) == one_empty) orelse - proplists:get_value(one_empty, proplists:get_value(tstflg,Opts,[]), false), + proplists:get_value(one_empty, ?GET_OPT(tstflg,Opts), false), case check_password(User, unicode:characters_to_list(Password), Opts, Ssh) of {true,Ssh1} when SendOneEmpty==true -> @@ -460,27 +462,8 @@ method_preference(Algs) -> ], Algs). -user_name(Opts) -> - Env = case os:type() of - {win32, _} -> - "USERNAME"; - {unix, _} -> - "LOGNAME" - end, - case proplists:get_value(user, Opts, os:getenv(Env)) of - false -> - case os:getenv("USER") of - false -> - {error, no_user}; - User -> - {ok, User} - end; - User -> - {ok, User} - end. - check_password(User, Password, Opts, Ssh) -> - case proplists:get_value(pwdfun, Opts) of + case ?GET_OPT(pwdfun, Opts) of undefined -> Static = get_password_option(Opts, User), {Password == Static, Ssh}; @@ -510,17 +493,18 @@ check_password(User, Password, Opts, Ssh) -> end. get_password_option(Opts, User) -> - Passwords = proplists:get_value(user_passwords, Opts, []), + Passwords = ?GET_OPT(user_passwords, Opts), case lists:keysearch(User, 1, Passwords) of {value, {User, Pw}} -> Pw; - false -> proplists:get_value(password, Opts, false) + false -> ?GET_OPT(password, Opts) end. pre_verify_sig(User, Alg, KeyBlob, Opts) -> try {ok, Key} = decode_public_key_v2(KeyBlob, Alg), - KeyCb = proplists:get_value(key_cb, Opts, ssh_file), - KeyCb:is_auth_key(Key, User, Opts) + {KeyCb,KeyCbOpts} = ?GET_OPT(key_cb, Opts), + UserOpts = ?GET_OPT(user_options, Opts), + KeyCb:is_auth_key(Key, User, [{key_cb_private,KeyCbOpts}|UserOpts]) catch _:_ -> false @@ -529,9 +513,10 @@ pre_verify_sig(User, Alg, KeyBlob, Opts) -> verify_sig(SessionId, User, Service, Alg, KeyBlob, SigWLen, Opts) -> try {ok, Key} = decode_public_key_v2(KeyBlob, Alg), - KeyCb = proplists:get_value(key_cb, Opts, ssh_file), - case KeyCb:is_auth_key(Key, User, Opts) of + {KeyCb,KeyCbOpts} = ?GET_OPT(key_cb, Opts), + UserOpts = ?GET_OPT(user_options, Opts), + case KeyCb:is_auth_key(Key, User, [{key_cb_private,KeyCbOpts}|UserOpts]) of true -> PlainText = build_sig_data(SessionId, User, Service, KeyBlob, Alg), @@ -565,9 +550,9 @@ decode_keyboard_interactive_prompts(_NumPrompts, Data) -> keyboard_interact_get_responses(IoCb, Opts, Name, Instr, PromptInfos) -> NumPrompts = length(PromptInfos), - keyboard_interact_get_responses(proplists:get_value(user_interaction, Opts, true), - proplists:get_value(keyboard_interact_fun, Opts), - proplists:get_value(password, Opts, undefined), IoCb, Name, + keyboard_interact_get_responses(?GET_OPT(user_interaction, Opts), + ?GET_OPT(keyboard_interact_fun, Opts), + ?GET_OPT(password, Opts), IoCb, Name, Instr, PromptInfos, Opts, NumPrompts). diff --git a/lib/ssh/src/ssh_cli.erl b/lib/ssh/src/ssh_cli.erl index 8af0ecc5f9..4c4f61e036 100644 --- a/lib/ssh/src/ssh_cli.erl +++ b/lib/ssh/src/ssh_cli.erl @@ -453,14 +453,20 @@ move_cursor(From, To, #ssh_pty{width=Width, term=Type}) -> %% %%% make sure that there is data to send %% %%% before calling ssh_connection:send write_chars(ConnectionHandler, ChannelId, Chars) -> - case erlang:iolist_size(Chars) of - 0 -> - ok; - _ -> - ssh_connection:send(ConnectionHandler, ChannelId, - ?SSH_EXTENDED_DATA_DEFAULT, Chars) + case has_chars(Chars) of + false -> ok; + true -> ssh_connection:send(ConnectionHandler, + ChannelId, + ?SSH_EXTENDED_DATA_DEFAULT, + Chars) end. +has_chars([C|_]) when is_integer(C) -> true; +has_chars([H|T]) when is_list(H) ; is_binary(H) -> has_chars(H) orelse has_chars(T); +has_chars(<<_:8,_/binary>>) -> true; +has_chars(_) -> false. + + %%% tail, works with empty lists tl1([_|A]) -> A; tl1(_) -> []. @@ -493,14 +499,12 @@ start_shell(ConnectionHandler, State) -> [peer, user]), ShellFun = case is_function(Shell) of true -> - User = - proplists:get_value(user, ConnectionInfo), + User = proplists:get_value(user, ConnectionInfo), case erlang:fun_info(Shell, arity) of {arity, 1} -> fun() -> Shell(User) end; {arity, 2} -> - {_, PeerAddr} = - proplists:get_value(peer, ConnectionInfo), + {_, PeerAddr} = proplists:get_value(peer, ConnectionInfo), fun() -> Shell(User, PeerAddr) end; _ -> Shell @@ -519,8 +523,7 @@ start_shell(ConnectionHandler, Cmd, #state{exec=Shell} = State) when is_function ConnectionInfo = ssh_connection_handler:connection_info(ConnectionHandler, [peer, user]), - User = - proplists:get_value(user, ConnectionInfo), + User = proplists:get_value(user, ConnectionInfo), ShellFun = case erlang:fun_info(Shell, arity) of {arity, 1} -> @@ -528,8 +531,7 @@ start_shell(ConnectionHandler, Cmd, #state{exec=Shell} = State) when is_function {arity, 2} -> fun() -> Shell(Cmd, User) end; {arity, 3} -> - {_, PeerAddr} = - proplists:get_value(peer, ConnectionInfo), + {_, PeerAddr} = proplists:get_value(peer, ConnectionInfo), fun() -> Shell(Cmd, User, PeerAddr) end; _ -> Shell diff --git a/lib/ssh/src/ssh_connect.hrl b/lib/ssh/src/ssh_connect.hrl index 4fb6bc39f3..c91c56435e 100644 --- a/lib/ssh/src/ssh_connect.hrl +++ b/lib/ssh/src/ssh_connect.hrl @@ -22,9 +22,9 @@ %%% Description : SSH connection protocol --type role() :: client | server . --type connection_ref() :: pid(). -type channel_id() :: pos_integer(). +-type connection_ref() :: pid(). + -define(DEFAULT_PACKET_SIZE, 65536). -define(DEFAULT_WINDOW_SIZE, 10*?DEFAULT_PACKET_SIZE). diff --git a/lib/ssh/src/ssh_connection.erl b/lib/ssh/src/ssh_connection.erl index c7a2c92670..930ccecb4c 100644 --- a/lib/ssh/src/ssh_connection.erl +++ b/lib/ssh/src/ssh_connection.erl @@ -56,8 +56,8 @@ %%-------------------------------------------------------------------- %%-------------------------------------------------------------------- --spec session_channel(pid(), timeout()) -> {ok, channel_id()} | {error, timeout | closed}. --spec session_channel(pid(), integer(), integer(), timeout()) -> {ok, channel_id()} | {error, timeout | closed}. +-spec session_channel(connection_ref(), timeout()) -> {ok, channel_id()} | {error, timeout | closed}. +-spec session_channel(connection_ref(), integer(), integer(), timeout()) -> {ok, channel_id()} | {error, timeout | closed}. %% Description: Opens a channel for a ssh session. A session is a %% remote execution of a program. The program may be a shell, an @@ -81,7 +81,7 @@ session_channel(ConnectionHandler, InitialWindowSize, end. %%-------------------------------------------------------------------- --spec exec(pid(), channel_id(), string(), timeout()) -> +-spec exec(connection_ref(), channel_id(), string(), timeout()) -> success | failure | {error, timeout | closed}. %% Description: Will request that the server start the @@ -92,7 +92,7 @@ exec(ConnectionHandler, ChannelId, Command, TimeOut) -> true, [?string(Command)], TimeOut). %%-------------------------------------------------------------------- --spec shell(pid(), channel_id()) -> _. +-spec shell(connection_ref(), channel_id()) -> _. %% Description: Will request that the user's default shell (typically %% defined in /etc/passwd in UNIX systems) be started at the other @@ -102,7 +102,7 @@ shell(ConnectionHandler, ChannelId) -> ssh_connection_handler:request(ConnectionHandler, self(), ChannelId, "shell", false, <<>>, 0). %%-------------------------------------------------------------------- --spec subsystem(pid(), channel_id(), string(), timeout()) -> +-spec subsystem(connection_ref(), channel_id(), string(), timeout()) -> success | failure | {error, timeout | closed}. %% %% Description: Executes a predefined subsystem. @@ -112,11 +112,11 @@ subsystem(ConnectionHandler, ChannelId, SubSystem, TimeOut) -> ChannelId, "subsystem", true, [?string(SubSystem)], TimeOut). %%-------------------------------------------------------------------- --spec send(pid(), channel_id(), iodata()) -> +-spec send(connection_ref(), channel_id(), iodata()) -> ok | {error, closed}. --spec send(pid(), channel_id(), integer()| iodata(), timeout() | iodata()) -> +-spec send(connection_ref(), channel_id(), integer()| iodata(), timeout() | iodata()) -> ok | {error, timeout} | {error, closed}. --spec send(pid(), channel_id(), integer(), iodata(), timeout()) -> +-spec send(connection_ref(), channel_id(), integer(), iodata(), timeout()) -> ok | {error, timeout} | {error, closed}. %% %% @@ -134,7 +134,7 @@ send(ConnectionHandler, ChannelId, Type, Data, TimeOut) -> ssh_connection_handler:send(ConnectionHandler, ChannelId, Type, Data, TimeOut). %%-------------------------------------------------------------------- --spec send_eof(pid(), channel_id()) -> ok | {error, closed}. +-spec send_eof(connection_ref(), channel_id()) -> ok | {error, closed}. %% %% %% Description: Sends eof on the channel <ChannelId>. @@ -143,7 +143,7 @@ send_eof(ConnectionHandler, Channel) -> ssh_connection_handler:send_eof(ConnectionHandler, Channel). %%-------------------------------------------------------------------- --spec adjust_window(pid(), channel_id(), integer()) -> ok | {error, closed}. +-spec adjust_window(connection_ref(), channel_id(), integer()) -> ok | {error, closed}. %% %% %% Description: Adjusts the ssh flowcontrol window. @@ -152,7 +152,7 @@ adjust_window(ConnectionHandler, Channel, Bytes) -> ssh_connection_handler:adjust_window(ConnectionHandler, Channel, Bytes). %%-------------------------------------------------------------------- --spec setenv(pid(), channel_id(), string(), string(), timeout()) -> +-spec setenv(connection_ref(), channel_id(), string(), string(), timeout()) -> success | failure | {error, timeout | closed}. %% %% @@ -165,7 +165,7 @@ setenv(ConnectionHandler, ChannelId, Var, Value, TimeOut) -> %%-------------------------------------------------------------------- --spec close(pid(), channel_id()) -> ok. +-spec close(connection_ref(), channel_id()) -> ok. %% %% %% Description: Sends a close message on the channel <ChannelId>. @@ -174,7 +174,7 @@ close(ConnectionHandler, ChannelId) -> ssh_connection_handler:close(ConnectionHandler, ChannelId). %%-------------------------------------------------------------------- --spec reply_request(pid(), boolean(), success | failure, channel_id()) -> ok. +-spec reply_request(connection_ref(), boolean(), success | failure, channel_id()) -> ok. %% %% %% Description: Send status replies to requests that want such replies. @@ -185,9 +185,9 @@ reply_request(_,false, _, _) -> ok. %%-------------------------------------------------------------------- --spec ptty_alloc(pid(), channel_id(), proplists:proplist()) -> +-spec ptty_alloc(connection_ref(), channel_id(), proplists:proplist()) -> success | failiure | {error, closed}. --spec ptty_alloc(pid(), channel_id(), proplists:proplist(), timeout()) -> +-spec ptty_alloc(connection_ref(), channel_id(), proplists:proplist(), timeout()) -> success | failiure | {error, timeout} | {error, closed}. %% @@ -197,16 +197,16 @@ reply_request(_,false, _, _) -> ptty_alloc(ConnectionHandler, Channel, Options) -> ptty_alloc(ConnectionHandler, Channel, Options, infinity). ptty_alloc(ConnectionHandler, Channel, Options0, TimeOut) -> - Options = backwards_compatible(Options0, []), - {Width, PixWidth} = pty_default_dimensions(width, Options), - {Height, PixHeight} = pty_default_dimensions(height, Options), + TermData = backwards_compatible(Options0, []), % FIXME + {Width, PixWidth} = pty_default_dimensions(width, TermData), + {Height, PixHeight} = pty_default_dimensions(height, TermData), pty_req(ConnectionHandler, Channel, - proplists:get_value(term, Options, os:getenv("TERM", ?DEFAULT_TERMINAL)), - proplists:get_value(width, Options, Width), - proplists:get_value(height, Options, Height), - proplists:get_value(pixel_widh, Options, PixWidth), - proplists:get_value(pixel_height, Options, PixHeight), - proplists:get_value(pty_opts, Options, []), TimeOut + proplists:get_value(term, TermData, os:getenv("TERM", ?DEFAULT_TERMINAL)), + proplists:get_value(width, TermData, Width), + proplists:get_value(height, TermData, Height), + proplists:get_value(pixel_widh, TermData, PixWidth), + proplists:get_value(pixel_height, TermData, PixHeight), + proplists:get_value(pty_opts, TermData, []), TimeOut ). %%-------------------------------------------------------------------- %% Not yet officialy supported! The following functions are part of the @@ -417,7 +417,8 @@ handle_msg(#ssh_msg_channel_open{channel_type = "session" = Type, maximum_packet_size = PacketSz}, #connection{options = SSHopts} = Connection0, server) -> - MinAcceptedPackSz = proplists:get_value(minimal_remote_max_packet_size, SSHopts, 0), + MinAcceptedPackSz = + ?GET_OPT(minimal_remote_max_packet_size, SSHopts), if MinAcceptedPackSz =< PacketSz -> @@ -574,7 +575,6 @@ handle_msg(#ssh_msg_channel_request{recipient_channel = ChannelId, PixWidth, PixHeight, decode_pty_opts(Modes)}, Channel = ssh_channel:cache_lookup(Cache, ChannelId), - handle_cli_msg(Connection, Channel, {pty, ChannelId, WantReply, PtyRequest}); @@ -691,7 +691,6 @@ handle_cli_msg(#connection{channel_cache = Cache} = Connection, #channel{user = undefined, remote_id = RemoteId, local_id = ChannelId} = Channel0, Reply0) -> - case (catch start_cli(Connection, ChannelId)) of {ok, Pid} -> erlang:monitor(process, Pid), @@ -819,7 +818,7 @@ start_channel(Cb, Id, Args, SubSysSup, Exec, Opts) -> ssh_channel_sup:start_child(ChannelSup, ChildSpec). assert_limit_num_channels_not_exceeded(ChannelSup, Opts) -> - MaxNumChannels = proplists:get_value(max_channels, Opts, infinity), + MaxNumChannels = ?GET_OPT(max_channels, Opts), NumChannels = length([x || {_,_,worker,[ssh_channel]} <- supervisor:which_children(ChannelSup)]), if @@ -858,8 +857,8 @@ setup_session(#connection{channel_cache = Cache check_subsystem("sftp"= SsName, Options) -> - case proplists:get_value(subsystems, Options, no_subsys) of - no_subsys -> + case ?GET_OPT(subsystems, Options) of + no_subsys -> % FIXME: Can 'no_subsys' ever be matched? {SsName, {Cb, Opts}} = ssh_sftpd:subsystem_spec([]), {Cb, Opts}; SubSystems -> @@ -867,7 +866,7 @@ check_subsystem("sftp"= SsName, Options) -> end; check_subsystem(SsName, Options) -> - Subsystems = proplists:get_value(subsystems, Options, []), + Subsystems = ?GET_OPT(subsystems, Options), case proplists:get_value(SsName, Subsystems, {none, []}) of Fun when is_function(Fun) -> {Fun, []}; @@ -1022,12 +1021,13 @@ pty_req(ConnectionHandler, Channel, Term, Width, Height, ?uint32(PixWidth),?uint32(PixHeight), encode_pty_opts(PtyOpts)], TimeOut). -pty_default_dimensions(Dimension, Options) -> - case proplists:get_value(Dimension, Options, 0) of +pty_default_dimensions(Dimension, TermData) -> + case proplists:get_value(Dimension, TermData, 0) of N when is_integer(N), N > 0 -> {N, 0}; _ -> - case proplists:get_value(list_to_atom("pixel_" ++ atom_to_list(Dimension)), Options, 0) of + PixelDim = list_to_atom("pixel_" ++ atom_to_list(Dimension)), + case proplists:get_value(PixelDim, TermData, 0) of N when is_integer(N), N > 0 -> {0, N}; _ -> diff --git a/lib/ssh/src/ssh_connection_handler.erl b/lib/ssh/src/ssh_connection_handler.erl index dcf509ca09..b9c643c77e 100644 --- a/lib/ssh/src/ssh_connection_handler.erl +++ b/lib/ssh/src/ssh_connection_handler.erl @@ -76,7 +76,7 @@ %%-------------------------------------------------------------------- -spec start_link(role(), inet:socket(), - proplists:proplist() + ssh_options:options() ) -> {ok, pid()}. %% . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . start_link(Role, Socket, Options) -> @@ -99,12 +99,10 @@ stop(ConnectionHandler)-> %% Internal application API %%==================================================================== --define(DefaultTransport, {tcp, gen_tcp, tcp_closed} ). - %%-------------------------------------------------------------------- -spec start_connection(role(), inet:socket(), - proplists:proplist(), + ssh_options:options(), timeout() ) -> {ok, connection_ref()} | {error, term()}. %% . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . @@ -121,9 +119,8 @@ start_connection(client = Role, Socket, Options, Timeout) -> end; start_connection(server = Role, Socket, Options, Timeout) -> - SSH_Opts = proplists:get_value(ssh_opts, Options, []), try - case proplists:get_value(parallel_login, SSH_Opts, false) of + case ?GET_OPT(parallel_login, Options) of true -> HandshakerPid = spawn_link(fun() -> @@ -346,7 +343,7 @@ renegotiate_data(ConnectionHandler) -> | undefined, last_size_rekey = 0 :: non_neg_integer(), event_queue = [] :: list(), - opts :: proplists:proplist(), + opts :: ssh_options:options(), inet_initial_recbuf_size :: pos_integer() | undefined }). @@ -357,15 +354,14 @@ renegotiate_data(ConnectionHandler) -> %%-------------------------------------------------------------------- -spec init_connection_handler(role(), inet:socket(), - proplists:proplist() + ssh_options:options() ) -> no_return(). %% . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . init_connection_handler(Role, Socket, Opts) -> process_flag(trap_exit, true), S0 = init_process_state(Role, Socket, Opts), try - {Protocol, Callback, CloseTag} = - proplists:get_value(transport, Opts, ?DefaultTransport), + {Protocol, Callback, CloseTag} = ?GET_OPT(transport, Opts), S0#data{ssh_params = init_ssh_record(Role, Socket, Opts), transport_protocol = Protocol, transport_cb = Callback, @@ -393,7 +389,7 @@ init_process_state(Role, Socket, Opts) -> port_bindings = [], requests = [], options = Opts}, - starter = proplists:get_value(user_pid, Opts), + starter = ?GET_INTERNAL_OPT(user_pid, Opts), socket = Socket, opts = Opts }, @@ -409,13 +405,18 @@ init_process_state(Role, Socket, Opts) -> init_connection(server, C = #connection{}, Opts) -> - Sups = proplists:get_value(supervisors, Opts), - SystemSup = proplists:get_value(system_sup, Sups), - SubSystemSup = proplists:get_value(subsystem_sup, Sups), + Sups = ?GET_INTERNAL_OPT(supervisors, Opts), + + SystemSup = proplists:get_value(system_sup, Sups), + SubSystemSup = proplists:get_value(subsystem_sup, Sups), ConnectionSup = proplists:get_value(connection_sup, Sups), - Shell = proplists:get_value(shell, Opts), - Exec = proplists:get_value(exec, Opts), - CliSpec = proplists:get_value(ssh_cli, Opts, {ssh_cli, [Shell]}), + + Shell = ?GET_OPT(shell, Opts), + Exec = ?GET_OPT(exec, Opts), + CliSpec = case ?GET_OPT(ssh_cli, Opts) of + undefined -> {ssh_cli, [Shell]}; + Spec -> Spec + end, C#connection{cli_spec = CliSpec, exec = Exec, system_supervisor = SystemSup, @@ -426,41 +427,38 @@ init_connection(server, C = #connection{}, Opts) -> init_ssh_record(Role, Socket, Opts) -> {ok, PeerAddr} = inet:peername(Socket), - KeyCb = proplists:get_value(key_cb, Opts, ssh_file), - AuthMethods = proplists:get_value(auth_methods, - Opts, - case Role of - server -> ?SUPPORTED_AUTH_METHODS; - client -> undefined - end), + KeyCb = ?GET_OPT(key_cb, Opts), + AuthMethods = + case Role of + server -> ?GET_OPT(auth_methods, Opts); + client -> undefined + end, S0 = #ssh{role = Role, key_cb = KeyCb, opts = Opts, userauth_supported_methods = AuthMethods, available_host_keys = supported_host_keys(Role, KeyCb, Opts), - random_length_padding = proplists:get_value(max_random_length_padding, - Opts, - (#ssh{})#ssh.random_length_padding) + random_length_padding = ?GET_OPT(max_random_length_padding, Opts) }, {Vsn, Version} = ssh_transport:versions(Role, Opts), case Role of client -> - PeerName = proplists:get_value(host, Opts), + PeerName = ?GET_INTERNAL_OPT(host, Opts), S0#ssh{c_vsn = Vsn, c_version = Version, - io_cb = case proplists:get_value(user_interaction, Opts, true) of + io_cb = case ?GET_OPT(user_interaction, Opts) of true -> ssh_io; false -> ssh_no_io end, - userauth_quiet_mode = proplists:get_value(quiet_mode, Opts, false), + userauth_quiet_mode = ?GET_OPT(quiet_mode, Opts), peer = {PeerName, PeerAddr} }; server -> S0#ssh{s_vsn = Vsn, s_version = Version, - io_cb = proplists:get_value(io_cb, Opts, ssh_io), + io_cb = ?GET_INTERNAL_OPT(io_cb, Opts, ssh_io), userauth_methods = string:tokens(AuthMethods, ","), kb_tries_left = 3, peer = {undefined, PeerAddr} @@ -849,14 +847,12 @@ handle_event(_, Msg = #ssh_msg_userauth_failure{}, {userauth_keyboard_interactiv handle_event(_, Msg=#ssh_msg_userauth_failure{}, {userauth_keyboard_interactive_info_response, client}, #data{ssh_params = Ssh0} = D0) -> Opts = Ssh0#ssh.opts, - D = case proplists:get_value(password, Opts) of + D = case ?GET_OPT(password, Opts) of undefined -> D0; _ -> D0#data{ssh_params = - Ssh0#ssh{opts = - lists:keyreplace(password,1,Opts, - {password,not_ok})}} % FIXME:intermodule dependency + Ssh0#ssh{opts = ?PUT_OPT({password,not_ok}, Opts)}} % FIXME:intermodule dependency end, {next_state, {userauth,client}, D, [{next_event, internal, Msg}]}; @@ -954,7 +950,7 @@ handle_event(cast, renegotiate, _, _) -> handle_event(cast, data_size, {connected,Role}, D) -> {ok, [{send_oct,Sent0}]} = inet:getstat(D#data.socket, [send_oct]), Sent = Sent0 - D#data.last_size_rekey, - MaxSent = proplists:get_value(rekey_limit, D#data.opts, 1024000000), + MaxSent = ?GET_OPT(rekey_limit, D#data.opts), timer:apply_after(?REKEY_DATA_TIMOUT, gen_statem, cast, [self(), data_size]), case Sent >= MaxSent of true -> @@ -1294,11 +1290,12 @@ handle_event(info, UnexpectedMessage, StateName, D = #data{ssh_params = Ssh}) -> "Unexpected message '~p' received in state '~p'\n" "Role: ~p\n" "Peer: ~p\n" - "Local Address: ~p\n", [UnexpectedMessage, - StateName, - Ssh#ssh.role, - Ssh#ssh.peer, - proplists:get_value(address, Ssh#ssh.opts)])), + "Local Address: ~p\n", + [UnexpectedMessage, + StateName, + Ssh#ssh.role, + Ssh#ssh.peer, + ?GET_INTERNAL_OPT(address, Ssh#ssh.opts)])), error_logger:info_report(Msg), keep_state_and_data; @@ -1312,11 +1309,12 @@ handle_event(info, UnexpectedMessage, StateName, D = #data{ssh_params = Ssh}) -> "Message: ~p\n" "Role: ~p\n" "Peer: ~p\n" - "Local Address: ~p\n", [Other, - UnexpectedMessage, - Ssh#ssh.role, - element(2,Ssh#ssh.peer), - proplists:get_value(address, Ssh#ssh.opts)] + "Local Address: ~p\n", + [Other, + UnexpectedMessage, + Ssh#ssh.role, + element(2,Ssh#ssh.peer), + ?GET_INTERNAL_OPT(address, Ssh#ssh.opts)] )), error_logger:error_report(Msg), keep_state_and_data @@ -1438,11 +1436,11 @@ code_change(_OldVsn, StateName, State, _Extra) -> %%-------------------------------------------------------------------- %% Starting -start_the_connection_child(UserPid, Role, Socket, Options) -> - Sups = proplists:get_value(supervisors, Options), +start_the_connection_child(UserPid, Role, Socket, Options0) -> + Sups = ?GET_INTERNAL_OPT(supervisors, Options0), ConnectionSup = proplists:get_value(connection_sup, Sups), - Opts = [{supervisors, Sups}, {user_pid, UserPid} | proplists:get_value(ssh_opts, Options, [])], - {ok, Pid} = ssh_connection_sup:start_child(ConnectionSup, [Role, Socket, Opts]), + Options = ?PUT_INTERNAL_OPT({user_pid,UserPid}, Options0), + {ok, Pid} = ssh_connection_sup:start_child(ConnectionSup, [Role, Socket, Options]), ok = socket_control(Socket, Pid, Options), Pid. @@ -1499,7 +1497,7 @@ supported_host_keys(server, KeyCb, Options) -> find_sup_hkeys(Options) -> case proplists:get_value(public_key, - proplists:get_value(preferred_algorithms,Options,[]) + ?GET_OPT(preferred_algorithms,Options) ) of undefined -> @@ -1512,9 +1510,10 @@ find_sup_hkeys(Options) -> %% Alg :: atom() -available_host_key(KeyCb, Alg, Opts) -> - element(1, catch KeyCb:host_key(Alg, Opts)) == ok. - +available_host_key({KeyCb,KeyCbOpts}, Alg, Opts) -> + UserOpts = ?GET_OPT(user_options, Opts), + element(1, + catch KeyCb:host_key(Alg, [{key_cb_private,KeyCbOpts}|UserOpts])) == ok. send_msg(Msg, State=#data{ssh_params=Ssh0}) when is_tuple(Msg) -> {Bytes, Ssh} = ssh_transport:ssh_packet(Msg, Ssh0), @@ -1770,47 +1769,24 @@ get_repl(X, Acc) -> exit({get_repl,X,Acc}). %%%---------------------------------------------------------------- -disconnect_fun({disconnect,Msg}, D) -> - disconnect_fun(Msg, D); -disconnect_fun(Reason, #data{opts=Opts}) -> - case proplists:get_value(disconnectfun, Opts) of - undefined -> - ok; - Fun -> - catch Fun(Reason) - end. - -unexpected_fun(UnexpectedMessage, #data{opts = Opts, - ssh_params = #ssh{peer = {_,Peer} } - } ) -> - case proplists:get_value(unexpectedfun, Opts) of - undefined -> - report; - Fun -> - catch Fun(UnexpectedMessage, Peer) - end. +-define(CALL_FUN(Key,D), catch (?GET_OPT(Key, D#data.opts)) ). +disconnect_fun({disconnect,Msg}, D) -> ?CALL_FUN(disconnectfun,D)(Msg); +disconnect_fun(Reason, D) -> ?CALL_FUN(disconnectfun,D)(Reason). + +unexpected_fun(UnexpectedMessage, #data{ssh_params = #ssh{peer = {_,Peer} }} = D) -> + ?CALL_FUN(unexpectedfun,D)(UnexpectedMessage, Peer). debug_fun(#ssh_msg_debug{always_display = Display, message = DbgMsg, language = Lang}, - #data{opts = Opts}) -> - case proplists:get_value(ssh_msg_debug_fun, Opts) of - undefined -> - ok; - Fun -> - catch Fun(self(), Display, DbgMsg, Lang) - end. + D) -> + ?CALL_FUN(ssh_msg_debug_fun,D)(self(), Display, DbgMsg, Lang). -connected_fun(User, Method, #data{ssh_params = #ssh{peer = {_,Peer}}, - opts = Opts}) -> - case proplists:get_value(connectfun, Opts) of - undefined -> - ok; - Fun -> - catch Fun(User, Peer, Method) - end. +connected_fun(User, Method, #data{ssh_params = #ssh{peer = {_,Peer}}} = D) -> + ?CALL_FUN(connectfun,D)(User, Peer, Method). + retry_fun(_, undefined, _) -> ok; @@ -1824,7 +1800,7 @@ retry_fun(User, Reason, #data{ssh_params = #ssh{opts = Opts, _ -> {infofun, Reason} end, - Fun = proplists:get_value(Tag, Opts, fun(_,_)-> ok end), + Fun = ?GET_OPT(Tag, Opts), try erlang:fun_info(Fun, arity) of {arity, 2} -> %% Backwards compatible @@ -1843,7 +1819,7 @@ retry_fun(User, Reason, #data{ssh_params = #ssh{opts = Opts, %%% channels open for a while. cache_init_idle_timer(D) -> - case proplists:get_value(idle_time, D#data.opts, infinity) of + case ?GET_OPT(idle_time, D#data.opts) of infinity -> D#data{idle_timer_value = infinity, idle_timer_ref = infinity % A flag used later... @@ -1906,9 +1882,8 @@ start_channel_request_timer(Channel, From, Time) -> %%% Connection start and initalization helpers socket_control(Socket, Pid, Options) -> - {_, TransportCallback, _} = % For example {_,gen_tcp,_} - proplists:get_value(transport, Options, ?DefaultTransport), - case TransportCallback:controlling_process(Socket, Pid) of + {_, Callback, _} = ?GET_OPT(transport, Options), + case Callback:controlling_process(Socket, Pid) of ok -> gen_statem:cast(Pid, socket_control); {error, Reason} -> diff --git a/lib/ssh/src/ssh_file.erl b/lib/ssh/src/ssh_file.erl index 216f65f33a..898b4cc5c4 100644 --- a/lib/ssh/src/ssh_file.erl +++ b/lib/ssh/src/ssh_file.erl @@ -192,8 +192,8 @@ lookup_user_key(Key, User, Opts) -> ssh_dir({remoteuser, User}, Opts) -> case proplists:get_value(user_dir_fun, Opts) of undefined -> - case proplists:get_value(user_dir, Opts) of - undefined -> + case proplists:get_value(user_dir, Opts, false) of + false -> default_user_dir(); Dir -> Dir diff --git a/lib/ssh/src/ssh_io.erl b/lib/ssh/src/ssh_io.erl index 1d8f370884..6828fd4760 100644 --- a/lib/ssh/src/ssh_io.erl +++ b/lib/ssh/src/ssh_io.erl @@ -27,17 +27,17 @@ -export([yes_no/2, read_password/2, read_line/2, format/2]). -include("ssh.hrl"). -read_line(Prompt, Ssh) -> +read_line(Prompt, Opts) -> format("~s", [listify(Prompt)]), - proplists:get_value(user_pid, Ssh) ! {self(), question}, + ?GET_INTERNAL_OPT(user_pid, Opts) ! {self(), question}, receive Answer when is_list(Answer) -> Answer end. -yes_no(Prompt, Ssh) -> +yes_no(Prompt, Opts) -> format("~s [y/n]?", [Prompt]), - proplists:get_value(user_pid, Ssh#ssh.opts) ! {self(), question}, + ?GET_INTERNAL_OPT(user_pid, Opts) ! {self(), question}, receive %% I can't see that the atoms y and n are ever received, but it must %% be investigated before removing @@ -52,15 +52,13 @@ yes_no(Prompt, Ssh) -> "N" -> no; _ -> format("please answer y or n\n",[]), - yes_no(Prompt, Ssh) + yes_no(Prompt, Opts) end end. - -read_password(Prompt, #ssh{opts=Opts}) -> read_password(Prompt, Opts); -read_password(Prompt, Opts) when is_list(Opts) -> +read_password(Prompt, Opts) -> format("~s", [listify(Prompt)]), - proplists:get_value(user_pid, Opts) ! {self(), user_password}, + ?GET_INTERNAL_OPT(user_pid, Opts) ! {self(), user_password}, receive Answer when is_list(Answer) -> case trim(Answer) of diff --git a/lib/ssh/src/ssh_options.erl b/lib/ssh/src/ssh_options.erl new file mode 100644 index 0000000000..395be6b220 --- /dev/null +++ b/lib/ssh/src/ssh_options.erl @@ -0,0 +1,895 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2004-2017. All Rights Reserved. +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. +%% +%% %CopyrightEnd% +%% + +%% + +-module(ssh_options). + +-include("ssh.hrl"). +-include_lib("kernel/include/file.hrl"). + +-export([default/1, + get_value/5, get_value/6, + put_value/5, + handle_options/2 + ]). + +-export_type([options/0 + ]). + +%%%================================================================ +%%% Types + +-type options() :: #{socket_options := socket_options(), + internal_options := internal_options(), + option_key() => any() + }. + +-type socket_options() :: proplists:proplist(). +-type internal_options() :: #{option_key() => any()}. + +-type option_key() :: atom(). + +-type option_in() :: proplists:property() | proplists:proplist() . + +-type option_class() :: internal_options | socket_options | user_options . + +-type option_declaration() :: #{class := user_options, + chk := fun((any) -> boolean() | {true,any()}), + default => any() + }. + +-type option_declarations() :: #{ {option_key(),def} := option_declaration() }. + +-type error() :: {error,{eoptions,any()}} . + +%%%================================================================ +%%% +%%% Get an option +%%% + +-spec get_value(option_class(), option_key(), options(), + atom(), non_neg_integer()) -> any() | no_return(). + +get_value(Class, Key, Opts, _CallerMod, _CallerLine) when is_map(Opts) -> + case Class of + internal_options -> maps:get(Key, maps:get(internal_options,Opts)); + socket_options -> proplists:get_value(Key, maps:get(socket_options,Opts)); + user_options -> maps:get(Key, Opts) + end; +get_value(Class, Key, Opts, _CallerMod, _CallerLine) -> + io:format("*** Bad Opts GET OPT ~p ~p:~p Key=~p,~n Opts=~p~n",[Class,_CallerMod,_CallerLine,Key,Opts]), + error({bad_options,Class, Key, Opts, _CallerMod, _CallerLine}). + + +-spec get_value(option_class(), option_key(), options(), any(), + atom(), non_neg_integer()) -> any() | no_return(). + +get_value(socket_options, Key, Opts, Def, _CallerMod, _CallerLine) when is_map(Opts) -> + proplists:get_value(Key, maps:get(socket_options,Opts), Def); +get_value(Class, Key, Opts, Def, CallerMod, CallerLine) when is_map(Opts) -> + try get_value(Class, Key, Opts, CallerMod, CallerLine) + catch + error:{badkey,Key} -> Def + end; +get_value(Class, Key, Opts, _Def, _CallerMod, _CallerLine) -> + io:format("*** Bad Opts GET OPT ~p ~p:~p Key=~p,~n Opts=~p~n",[Class,_CallerMod,_CallerLine,Key,Opts]), + error({bad_options,Class, Key, Opts, _CallerMod, _CallerLine}). + + +%%%================================================================ +%%% +%%% Put an option +%%% + +-spec put_value(option_class(), option_in(), options(), + atom(), non_neg_integer()) -> options(). + +put_value(user_options, KeyVal, Opts, _CallerMod, _CallerLine) when is_map(Opts) -> + put_user_value(KeyVal, Opts); + +put_value(internal_options, KeyVal, Opts, _CallerMod, _CallerLine) when is_map(Opts) -> + InternalOpts = maps:get(internal_options,Opts), + Opts#{internal_options := put_internal_value(KeyVal, InternalOpts)}; + +put_value(socket_options, KeyVal, Opts, _CallerMod, _CallerLine) when is_map(Opts) -> + SocketOpts = maps:get(socket_options,Opts), + Opts#{socket_options := put_socket_value(KeyVal, SocketOpts)}. + + +%%%---------------- +put_user_value(L, Opts) when is_list(L) -> + lists:foldl(fun put_user_value/2, Opts, L); +put_user_value({Key,Value}, Opts) -> + Opts#{Key := Value}. + +%%%---------------- +put_internal_value(L, IntOpts) when is_list(L) -> + lists:foldl(fun put_internal_value/2, IntOpts, L); +put_internal_value({Key,Value}, IntOpts) -> + IntOpts#{Key => Value}. + +%%%---------------- +put_socket_value(L, SockOpts) when is_list(L) -> + L ++ SockOpts; +put_socket_value({Key,Value}, SockOpts) -> + [{Key,Value} | SockOpts]; +put_socket_value(A, SockOpts) when is_atom(A) -> + [A | SockOpts]. + +%%%================================================================ +%%% +%%% Initialize the options +%%% + +-spec handle_options(role(), proplists:proplist()) -> options() | error() . + +-spec handle_options(role(), proplists:proplist(), options()) -> options() | error() . + +handle_options(Role, PropList0) -> + handle_options(Role, PropList0, #{socket_options => [], + internal_options => #{}, + user_options => [] + }). + +handle_options(Role, PropList0, Opts0) when is_map(Opts0), + is_list(PropList0) -> + PropList1 = proplists:unfold(PropList0), + try + OptionDefinitions = default(Role), + InitialMap = + maps:fold( + fun({K,def}, #{default:=V}, M) -> M#{K=>V}; + (_,_,M) -> M + end, + Opts0#{user_options => + maps:get(user_options,Opts0) ++ PropList1 + }, + OptionDefinitions), + %% Enter the user's values into the map; unknown keys are + %% treated as socket options + lists:foldl(fun(KV, Vals) -> + save(KV, OptionDefinitions, Vals) + end, InitialMap, PropList1) + catch + error:{eoptions, KV, undefined} -> + {error, {eoptions,KV}}; + + error:{eoptions, KV, Txt} when is_list(Txt) -> + {error, {eoptions,{KV,lists:flatten(Txt)}}}; + + error:{eoptions, KV, Extra} -> + {error, {eoptions,{KV,Extra}}} + end. + + +check_fun(Key, Defs) -> + #{chk := Fun} = maps:get({Key,def}, Defs), + Fun. + +%%%================================================================ +%%% +%%% Check and save one option +%%% + + +%%% First some prohibited inet options: +save({K,V}, _, _) when K == reuseaddr ; + K == active + -> + forbidden_option(K, V); + +%%% then compatibility conversions: +save({allow_user_interaction,V}, Opts, Vals) -> + save({user_interaction,V}, Opts, Vals); + +save({public_key_alg,V}, Defs, Vals) -> % To remove in OTP-20 + New = case V of + 'ssh-rsa' -> ['ssh-rsa', 'ssh-dss']; + ssh_rsa -> ['ssh-rsa', 'ssh-dss']; + 'ssh-dss' -> ['ssh-dss', 'ssh-rsa']; + ssh_dsa -> ['ssh-dss', 'ssh-rsa']; + _ -> error({eoptions, {public_key_alg,V}, + "Unknown algorithm, try pref_public_key_algs instead"}) + end, + save({pref_public_key_algs,New}, Defs, Vals); + +%% Special case for socket options 'inet' and 'inet6' +save(Inet, Defs, OptMap) when Inet==inet ; Inet==inet6 -> + save({inet,Inet}, Defs, OptMap); + +%% Two clauses to prepare for a proplists:unfold +save({Inet,true}, Defs, OptMap) when Inet==inet ; Inet==inet6 -> save({inet,Inet}, Defs, OptMap); +save({Inet,false}, _Defs, OptMap) when Inet==inet ; Inet==inet6 -> OptMap; + +%% and finaly the 'real stuff': +save({Key,Value}, Defs, OptMap) when is_map(OptMap) -> + try (check_fun(Key,Defs))(Value) + of + true -> + OptMap#{Key := Value}; + {true, ModifiedValue} -> + OptMap#{Key := ModifiedValue}; + false -> + error({eoptions, {Key,Value}, "Bad value"}) + catch + %% An unknown Key (= not in the definition map) is + %% regarded as an inet option: + error:{badkey,{inet,def}} -> + %% atomic (= non-tuple) options 'inet' and 'inet6': + OptMap#{socket_options := [Value | maps:get(socket_options,OptMap)]}; + error:{badkey,{Key,def}} -> + OptMap#{socket_options := [{Key,Value} | maps:get(socket_options,OptMap)]}; + + %% But a Key that is known but the value does not validate + %% by the check fun will give an error exception: + error:{check,{BadValue,Extra}} -> + error({eoptions, {Key,BadValue}, Extra}) + end. + +%%%================================================================ +%%% +%%% Default options +%%% + +-spec default(role() | common) -> option_declarations() . + +default(server) -> + (default(common)) + #{ + {subsystems, def} => + #{default => [ssh_sftpd:subsystem_spec([])], + chk => fun(L) -> + is_list(L) andalso + lists:all(fun({Name,{CB,Args}}) -> + check_string(Name) andalso + is_atom(CB) andalso + is_list(Args); + (_) -> + false + end, L) + end, + class => user_options + }, + + {shell, def} => + #{default => {shell, start, []}, + chk => fun({M,F,A}) -> is_atom(M) andalso is_atom(F) andalso is_list(A); + (V) -> check_function1(V) orelse check_function2(V) + end, + class => user_options + }, + + {exec, def} => % FIXME: need some archeology.... + #{default => undefined, + chk => fun({M,F,_}) -> is_atom(M) andalso is_atom(F); + (V) -> is_function(V) + end, + class => user_options + }, + + {ssh_cli, def} => + #{default => undefined, + chk => fun({Cb, As}) -> is_atom(Cb) andalso is_list(As); + (V) -> V == no_cli + end, + class => user_options + }, + + {system_dir, def} => + #{default => "/etc/ssh", + chk => fun(V) -> check_string(V) andalso check_dir(V) end, + class => user_options + }, + + {auth_methods, def} => + #{default => ?SUPPORTED_AUTH_METHODS, + chk => fun check_string/1, + class => user_options + }, + + {auth_method_kb_interactive_data, def} => + #{default => undefined, % Default value can be constructed when User is known + chk => fun({S1,S2,S3,B}) -> + check_string(S1) andalso + check_string(S2) andalso + check_string(S3) andalso + is_boolean(B); + (F) -> + check_function3(F) + end, + class => user_options + }, + + {user_passwords, def} => + #{default => [], + chk => fun(V) -> + is_list(V) andalso + lists:all(fun({S1,S2}) -> + check_string(S1) andalso + check_string(S2) + end, V) + end, + class => user_options + }, + + {password, def} => + #{default => undefined, + chk => fun check_string/1, + class => user_options + }, + + {dh_gex_groups, def} => + #{default => undefined, + chk => fun check_dh_gex_groups/1, + class => user_options + }, + + {dh_gex_limits, def} => + #{default => {0, infinity}, + chk => fun({I1,I2}) -> + check_pos_integer(I1) andalso + check_pos_integer(I2) andalso + I1 < I2; + (_) -> + false + end, + class => user_options + }, + + {pwdfun, def} => + #{default => undefined, + chk => fun(V) -> check_function4(V) orelse check_function2(V) end, + class => user_options + }, + + {negotiation_timeout, def} => + #{default => 2*60*1000, + chk => fun check_timeout/1, + class => user_options + }, + + {max_sessions, def} => + #{default => infinity, + chk => fun check_pos_integer/1, + class => user_options + }, + + {max_channels, def} => + #{default => infinity, + chk => fun check_pos_integer/1, + class => user_options + }, + + {parallel_login, def} => + #{default => false, + chk => fun erlang:is_boolean/1, + class => user_options + }, + + {minimal_remote_max_packet_size, def} => + #{default => 0, + chk => fun check_pos_integer/1, + class => user_options + }, + + {failfun, def} => + #{default => fun(_,_,_) -> void end, + chk => fun(V) -> check_function3(V) orelse + check_function2(V) % Backwards compatibility + end, + class => user_options + }, + + {connectfun, def} => + #{default => fun(_,_,_) -> void end, + chk => fun check_function3/1, + class => user_options + }, + +%%%%% Undocumented + {infofun, def} => + #{default => fun(_,_,_) -> void end, + chk => fun(V) -> check_function3(V) orelse + check_function2(V) % Backwards compatibility + end, + class => user_options + } + }; + +default(client) -> + (default(common)) + #{ + {dsa_pass_phrase, def} => + #{default => undefined, + chk => fun check_string/1, + class => user_options + }, + + {rsa_pass_phrase, def} => + #{default => undefined, + chk => fun check_string/1, + class => user_options + }, + + {silently_accept_hosts, def} => + #{default => false, + chk => fun check_silently_accept_hosts/1, + class => user_options + }, + + {user_interaction, def} => + #{default => true, + chk => fun erlang:is_boolean/1, + class => user_options + }, + + {pref_public_key_algs, def} => + #{default => + %% Get dynamically supported keys in the order of the ?SUPPORTED_USER_KEYS + [A || A <- ?SUPPORTED_USER_KEYS, + lists:member(A, ssh_transport:supported_algorithms(public_key))], + chk => + fun check_pref_public_key_algs/1, + class => + ssh + }, + + {dh_gex_limits, def} => + #{default => {1024, 6144, 8192}, % FIXME: Is this true nowadays? + chk => fun({Min,I,Max}) -> + lists:all(fun check_pos_integer/1, + [Min,I,Max]); + (_) -> false + end, + class => user_options + }, + + {connect_timeout, def} => + #{default => infinity, + chk => fun check_timeout/1, + class => user_options + }, + + {user, def} => + #{default => + begin + Env = case os:type() of + {win32, _} -> "USERNAME"; + {unix, _} -> "LOGNAME" + end, + case os:getenv(Env) of + false -> + case os:getenv("USER") of + false -> undefined; + User -> User + end; + User -> + User + end + end, + chk => fun check_string/1, + class => user_options + }, + + {password, def} => + #{default => undefined, + chk => fun check_string/1, + class => user_options + }, + + {quiet_mode, def} => + #{default => false, + chk => fun erlang:is_boolean/1, + class => user_options + }, + + {idle_time, def} => + #{default => infinity, + chk => fun check_timeout/1, + class => user_options + }, + +%%%%% Undocumented + {keyboard_interact_fun, def} => + #{default => undefined, + chk => fun check_function3/1, + class => user_options + } + }; + +default(common) -> + #{ + {user_dir, def} => + #{default => false, % FIXME: TBD ~/.ssh at time of call when user is known + chk => fun(V) -> check_string(V) andalso check_dir(V) end, + class => user_options + }, + + {preferred_algorithms, def} => + #{default => ssh:default_algorithms(), + chk => fun check_preferred_algorithms/1, + class => user_options + }, + + {id_string, def} => + #{default => undefined, % FIXME: see ssh_transport:ssh_vsn/0 + chk => fun(random) -> + {true, {random,2,5}}; % 2 - 5 random characters + ({random,I1,I2}) -> + %% Undocumented + check_pos_integer(I1) andalso + check_pos_integer(I2) andalso + I1=<I2; + (V) -> + check_string(V) + end, + class => user_options + }, + + {key_cb, def} => + #{default => {ssh_file, []}, + chk => fun({Mod,Opts}) -> is_atom(Mod) andalso is_list(Opts); + (Mod) when is_atom(Mod) -> {true, {Mod,[]}}; + (_) -> false + end, + class => user_options + }, + + {profile, def} => + #{default => ?DEFAULT_PROFILE, + chk => fun erlang:is_atom/1, + class => user_options + }, + + %% This is a "SocketOption"... + %% {fd, def} => + %% #{default => undefined, + %% chk => fun erlang:is_integer/1, + %% class => user_options + %% }, + + {disconnectfun, def} => + #{default => fun(_) -> void end, + chk => fun check_function1/1, + class => user_options + }, + + {unexpectedfun, def} => + #{default => fun(_,_) -> report end, + chk => fun check_function2/1, + class => user_options + }, + + {ssh_msg_debug_fun, def} => + #{default => fun(_,_,_,_) -> void end, + chk => fun check_function4/1, + class => user_options + }, + + {rekey_limit, def} => % FIXME: Why not common? + #{default => 1024000000, + chk => fun check_non_neg_integer/1, + class => user_options + }, + +%%%%% Undocumented + {transport, def} => + #{default => ?DEFAULT_TRANSPORT, + chk => fun({A,B,C}) -> + is_atom(A) andalso is_atom(B) andalso is_atom(C) + end, + class => user_options + }, + + {vsn, def} => + #{default => {2,0}, + chk => fun({Maj,Min}) -> check_non_neg_integer(Maj) andalso check_non_neg_integer(Min); + (_) -> false + end, + class => user_options + }, + + {tstflg, def} => + #{default => [], + chk => fun erlang:is_list/1, + class => user_options + }, + + {user_dir_fun, def} => + #{default => undefined, + chk => fun check_function1/1, + class => user_options + }, + + {max_random_length_padding, def} => + #{default => ?MAX_RND_PADDING_LEN, + chk => fun check_non_neg_integer/1, + class => user_options + } + }. + + +%%%================================================================ +%%%================================================================ +%%%================================================================ + +%%% +%%% check_*/1 -> true | false | error({check,Spec}) +%%% See error_in_check/2,3 +%%% + +%%% error_in_check(BadValue) -> error_in_check(BadValue, undefined). + +error_in_check(BadValue, Extra) -> error({check,{BadValue,Extra}}). + + +%%%---------------------------------------------------------------- +check_timeout(infinity) -> true; +check_timeout(I) -> check_pos_integer(I). + +%%%---------------------------------------------------------------- +check_pos_integer(I) -> is_integer(I) andalso I>0. + +%%%---------------------------------------------------------------- +check_non_neg_integer(I) -> is_integer(I) andalso I>=0. + +%%%---------------------------------------------------------------- +check_function1(F) -> is_function(F,1). +check_function2(F) -> is_function(F,2). +check_function3(F) -> is_function(F,3). +check_function4(F) -> is_function(F,4). + +%%%---------------------------------------------------------------- +check_pref_public_key_algs(V) -> + %% Get the dynamically supported keys, that is, thoose + %% that are stored + PKs = ssh_transport:supported_algorithms(public_key), + CHK = fun(A, Ack) -> + case lists:member(A, PKs) of + true -> + [A|Ack]; + false -> + %% Check with the documented options, that is, + %% the one we can handle + case lists:member(A,?SUPPORTED_USER_KEYS) of + false -> + %% An algorithm ssh never can handle + error_in_check(A, "Not supported public key"); + true -> + %% An algorithm ssh can handle, but not in + %% this very call + Ack + end + end + end, + case lists:foldr( + fun(ssh_dsa, Ack) -> CHK('ssh-dss', Ack); % compatibility + (ssh_rsa, Ack) -> CHK('ssh-rsa', Ack); % compatibility + (X, Ack) -> CHK(X, Ack) + end, [], V) + of + V -> true; + [] -> false; + V1 -> {true,V1} + end. + + +%%%---------------------------------------------------------------- +%% Check that it is a directory and is readable +check_dir(Dir) -> + case file:read_file_info(Dir) of + {ok, #file_info{type = directory, + access = Access}} -> + case Access of + read -> true; + read_write -> true; + _ -> error_in_check(Dir, eacces) + end; + + {ok, #file_info{}}-> + error_in_check(Dir, enotdir); + + {error, Error} -> + error_in_check(Dir, Error) + end. + +%%%---------------------------------------------------------------- +check_string(S) -> is_list(S). % FIXME: stub + +%%%---------------------------------------------------------------- +check_dh_gex_groups({file,File}) when is_list(File) -> + case file:consult(File) of + {ok, GroupDefs} -> + check_dh_gex_groups(GroupDefs); + {error, Error} -> + error_in_check({file,File},Error) + end; + +check_dh_gex_groups({ssh_moduli_file,File}) when is_list(File) -> + case file:open(File,[read]) of + {ok,D} -> + try + read_moduli_file(D, 1, []) + of + {ok,Moduli} -> + check_dh_gex_groups(Moduli); + {error,Error} -> + error_in_check({ssh_moduli_file,File}, Error) + catch + _:_ -> + error_in_check({ssh_moduli_file,File}, "Bad format in file "++File) + after + file:close(D) + end; + + {error, Error} -> + error_in_check({ssh_moduli_file,File}, Error) + end; + +check_dh_gex_groups(L0) when is_list(L0), is_tuple(hd(L0)) -> + {true, + collect_per_size( + lists:foldl( + fun({N,G,P}, Acc) when is_integer(N),N>0, + is_integer(G),G>0, + is_integer(P),P>0 -> + [{N,{G,P}} | Acc]; + ({N,{G,P}}, Acc) when is_integer(N),N>0, + is_integer(G),G>0, + is_integer(P),P>0 -> + [{N,{G,P}} | Acc]; + ({N,GPs}, Acc) when is_list(GPs) -> + lists:foldr(fun({Gi,Pi}, Acci) when is_integer(Gi),Gi>0, + is_integer(Pi),Pi>0 -> + [{N,{Gi,Pi}} | Acci] + end, Acc, GPs) + end, [], L0))}; + +check_dh_gex_groups(_) -> + false. + + + +collect_per_size(L) -> + lists:foldr( + fun({Sz,GP}, [{Sz,GPs}|Acc]) -> [{Sz,[GP|GPs]}|Acc]; + ({Sz,GP}, Acc) -> [{Sz,[GP]}|Acc] + end, [], lists:sort(L)). + +read_moduli_file(D, I, Acc) -> + case io:get_line(D,"") of + {error,Error} -> + {error,Error}; + eof -> + {ok, Acc}; + "#" ++ _ -> read_moduli_file(D, I+1, Acc); + <<"#",_/binary>> -> read_moduli_file(D, I+1, Acc); + Data -> + Line = if is_binary(Data) -> binary_to_list(Data); + is_list(Data) -> Data + end, + try + [_Time,_Class,_Tests,_Tries,Size,G,P] = string:tokens(Line," \r\n"), + M = {list_to_integer(Size), + {list_to_integer(G), list_to_integer(P,16)} + }, + read_moduli_file(D, I+1, [M|Acc]) + catch + _:_ -> + read_moduli_file(D, I+1, Acc) + end + end. + +%%%---------------------------------------------------------------- +-define(SHAs, [md5, sha, sha224, sha256, sha384, sha512]). + +check_silently_accept_hosts(B) when is_boolean(B) -> true; +check_silently_accept_hosts(F) when is_function(F,2) -> true; +check_silently_accept_hosts({S,F}) when is_atom(S), + is_function(F,2) -> + lists:member(S, ?SHAs) andalso + lists:member(S, proplists:get_value(hashs,crypto:supports())); +check_silently_accept_hosts({L,F}) when is_list(L), + is_function(F,2) -> + lists:all(fun(S) -> + lists:member(S, ?SHAs) andalso + lists:member(S, proplists:get_value(hashs,crypto:supports())) + end, L); +check_silently_accept_hosts(_) -> false. + +%%%---------------------------------------------------------------- +check_preferred_algorithms(Algs) -> + try alg_duplicates(Algs, [], []) + of + [] -> + {true, + [try ssh_transport:supported_algorithms(Key) + of + DefAlgs -> handle_pref_alg(Key,Vals,DefAlgs) + catch + _:_ -> error_in_check(Key,"Bad preferred_algorithms key") + end || {Key,Vals} <- Algs] + }; + + Dups -> + error_in_check(Dups, "Duplicates") + catch + _:_ -> + false + end. + +alg_duplicates([{K,V}|KVs], Ks, Dups0) -> + Dups = + case lists:member(K,Ks) of + true -> [K|Dups0]; + false -> Dups0 + end, + case V--lists:usort(V) of + [] -> alg_duplicates(KVs, [K|Ks], Dups); + Ds -> alg_duplicates(KVs, [K|Ks], Dups++Ds) + end; +alg_duplicates([], _Ks, Dups) -> + Dups. + +handle_pref_alg(Key, + Vs=[{client2server,C2Ss=[_|_]},{server2client,S2Cs=[_|_]}], + [{client2server,Sup_C2Ss},{server2client,Sup_S2Cs}] + ) -> + chk_alg_vs(Key, C2Ss, Sup_C2Ss), + chk_alg_vs(Key, S2Cs, Sup_S2Cs), + {Key, Vs}; + +handle_pref_alg(Key, + Vs=[{server2client,[_|_]},{client2server,[_|_]}], + Sup=[{client2server,_},{server2client,_}] + ) -> + handle_pref_alg(Key, lists:reverse(Vs), Sup); + +handle_pref_alg(Key, + Vs=[V|_], + Sup=[{client2server,_},{server2client,_}] + ) when is_atom(V) -> + handle_pref_alg(Key, [{client2server,Vs},{server2client,Vs}], Sup); + +handle_pref_alg(Key, + Vs=[V|_], + Sup=[S|_] + ) when is_atom(V), is_atom(S) -> + chk_alg_vs(Key, Vs, Sup), + {Key, Vs}; + +handle_pref_alg(Key, Vs, _) -> + error_in_check({Key,Vs}, "Badly formed list"). + +chk_alg_vs(OptKey, Values, SupportedValues) -> + case (Values -- SupportedValues) of + [] -> Values; + Bad -> error_in_check({OptKey,Bad}, "Unsupported value(s) found") + end. + +%%%---------------------------------------------------------------- +forbidden_option(K,V) -> + Txt = io_lib:format("The option '~s' is used internally. The " + "user is not allowed to specify this option.", + [K]), + error({eoptions, {K,V}, Txt}). + +%%%---------------------------------------------------------------- diff --git a/lib/ssh/src/ssh_sftp.erl b/lib/ssh/src/ssh_sftp.erl index b937f0412d..140856c8e3 100644 --- a/lib/ssh/src/ssh_sftp.erl +++ b/lib/ssh/src/ssh_sftp.erl @@ -100,18 +100,14 @@ start_channel(Socket) when is_port(Socket) -> start_channel(Host) when is_list(Host) -> start_channel(Host, []). -start_channel(Socket, Options) when is_port(Socket) -> - Timeout = - %% A mixture of ssh:connect and ssh_sftp:start_channel: - case proplists:get_value(connect_timeout, Options, undefined) of - undefined -> - proplists:get_value(timeout, Options, infinity); - TO -> - TO - end, - case ssh:connect(Socket, Options, Timeout) of +start_channel(Socket, UserOptions) when is_port(Socket) -> + {SshOpts, _ChanOpts, SftpOpts} = handle_options(UserOptions), + Timeout = % A mixture of ssh:connect and ssh_sftp:start_channel: + proplists:get_value(connect_timeout, SshOpts, + proplists:get_value(timeout, SftpOpts, infinity)), + case ssh:connect(Socket, SshOpts, Timeout) of {ok,Cm} -> - case start_channel(Cm, Options) of + case start_channel(Cm, UserOptions) of {ok, Pid} -> {ok, Pid, Cm}; Error -> @@ -120,9 +116,9 @@ start_channel(Socket, Options) when is_port(Socket) -> Error -> Error end; -start_channel(Cm, Opts) when is_pid(Cm) -> - Timeout = proplists:get_value(timeout, Opts, infinity), - {_, ChanOpts, SftpOpts} = handle_options(Opts, [], [], []), +start_channel(Cm, UserOptions) when is_pid(Cm) -> + Timeout = proplists:get_value(timeout, UserOptions, infinity), + {_SshOpts, ChanOpts, SftpOpts} = handle_options(UserOptions), case ssh_xfer:attach(Cm, [], ChanOpts) of {ok, ChannelId, Cm} -> case ssh_channel:start(Cm, ChannelId, @@ -143,15 +139,17 @@ start_channel(Cm, Opts) when is_pid(Cm) -> Error end; -start_channel(Host, Opts) -> - start_channel(Host, 22, Opts). -start_channel(Host, Port, Opts) -> - {SshOpts, ChanOpts, SftpOpts} = handle_options(Opts, [], [], []), - Timeout = proplists:get_value(timeout, SftpOpts, infinity), +start_channel(Host, UserOptions) -> + start_channel(Host, 22, UserOptions). + +start_channel(Host, Port, UserOptions) -> + {SshOpts, ChanOpts, SftpOpts} = handle_options(UserOptions), + Timeout = % A mixture of ssh:connect and ssh_sftp:start_channel: + proplists:get_value(connect_timeout, SshOpts, + proplists:get_value(timeout, SftpOpts, infinity)), case ssh_xfer:connect(Host, Port, SshOpts, ChanOpts, Timeout) of {ok, ChannelId, Cm} -> - case ssh_channel:start(Cm, ChannelId, ?MODULE, [Cm, - ChannelId, SftpOpts]) of + case ssh_channel:start(Cm, ChannelId, ?MODULE, [Cm,ChannelId,SftpOpts]) of {ok, Pid} -> case wait_for_version_negotiation(Pid, Timeout) of ok -> @@ -294,7 +292,7 @@ read(Pid, Handle, Len) -> read(Pid, Handle, Len, FileOpTimeout) -> call(Pid, {read,false,Handle, Len}, FileOpTimeout). -%% TODO this ought to be a cast! Is so in all practial meaning +%% TODO this ought to be a cast! Is so in all practical meaning %% even if it is obscure! apread(Pid, Handle, Offset, Len) -> call(Pid, {pread,true,Handle, Offset, Len}, infinity). @@ -313,12 +311,12 @@ write(Pid, Handle, Data) -> write(Pid, Handle, Data, FileOpTimeout) -> call(Pid, {write,false,Handle,Data}, FileOpTimeout). -%% TODO this ought to be a cast! Is so in all practial meaning +%% TODO this ought to be a cast! Is so in all practical meaning %% even if it is obscure! apwrite(Pid, Handle, Offset, Data) -> call(Pid, {pwrite,true,Handle,Offset,Data}, infinity). -%% TODO this ought to be a cast! Is so in all practial meaning +%% TODO this ought to be a cast! Is so in all practical meaning %% even if it is obscure! awrite(Pid, Handle, Data) -> call(Pid, {write,true,Handle,Data}, infinity). @@ -865,6 +863,9 @@ terminate(_Reason, State) -> %%==================================================================== %% Internal functions %%==================================================================== +handle_options(UserOptions) -> + handle_options(UserOptions, [], [], []). + handle_options([], Sftp, Chan, Ssh) -> {Ssh, Chan, Sftp}; handle_options([{timeout, _} = Opt | Rest], Sftp, Chan, Ssh) -> diff --git a/lib/ssh/src/ssh_sftpd.erl b/lib/ssh/src/ssh_sftpd.erl index b739955836..9352046795 100644 --- a/lib/ssh/src/ssh_sftpd.erl +++ b/lib/ssh/src/ssh_sftpd.erl @@ -664,29 +664,25 @@ open(Vsn, ReqId, Data, State) when Vsn >= 4 -> do_open(ReqId, State, Path, Flags). do_open(ReqId, State0, Path, Flags) -> - #state{file_handler = FileMod, file_state = FS0, root = Root, xf = #ssh_xfer{vsn = Vsn}} = State0, - XF = State0#state.xf, - F = [binary | Flags], - {IsDir, _FS1} = FileMod:is_dir(Path, FS0), + #state{file_handler = FileMod, file_state = FS0, xf = #ssh_xfer{vsn = Vsn}} = State0, + AbsPath = relate_file_name(Path, State0), + {IsDir, _FS1} = FileMod:is_dir(AbsPath, FS0), case IsDir of true when Vsn > 5 -> ssh_xfer:xf_send_status(State0#state.xf, ReqId, - ?SSH_FX_FILE_IS_A_DIRECTORY, "File is a directory"); + ?SSH_FX_FILE_IS_A_DIRECTORY, "File is a directory"), + State0; true -> ssh_xfer:xf_send_status(State0#state.xf, ReqId, - ?SSH_FX_FAILURE, "File is a directory"); + ?SSH_FX_FAILURE, "File is a directory"), + State0; false -> - AbsPath = case Root of - "" -> - Path; - _ -> - relate_file_name(Path, State0) - end, - {Res, FS1} = FileMod:open(AbsPath, F, FS0), + OpenFlags = [binary | Flags], + {Res, FS1} = FileMod:open(AbsPath, OpenFlags, FS0), State1 = State0#state{file_state = FS1}, case Res of {ok, IoDevice} -> - add_handle(State1, XF, ReqId, file, {Path,IoDevice}); + add_handle(State1, State0#state.xf, ReqId, file, {Path,IoDevice}); {error, Error} -> ssh_xfer:xf_send_status(State1#state.xf, ReqId, ssh_xfer:encode_erlang_status(Error)), @@ -742,6 +738,10 @@ resolve_symlinks_2([], State, _LinkCnt, AccPath) -> {{ok, AccPath}, State}. +%% The File argument is always in a user visible file system, i.e. +%% is under Root and is relative to CWD or Root, if starts with "/". +%% The result of the function is always an absolute path in a +%% "backend" file system. relate_file_name(File, State) -> relate_file_name(File, State, _Canonicalize=true). @@ -749,19 +749,20 @@ relate_file_name(File, State, Canonicalize) when is_binary(File) -> relate_file_name(unicode:characters_to_list(File), State, Canonicalize); relate_file_name(File, #state{cwd = CWD, root = ""}, Canonicalize) -> relate_filename_to_path(File, CWD, Canonicalize); -relate_file_name(File, #state{root = Root}, Canonicalize) -> - case is_within_root(Root, File) of - true -> - File; - false -> - RelFile = make_relative_filename(File), - NewFile = relate_filename_to_path(RelFile, Root, Canonicalize), - case is_within_root(Root, NewFile) of - true -> - NewFile; - false -> - Root - end +relate_file_name(File, #state{cwd = CWD, root = Root}, Canonicalize) -> + CWD1 = case is_within_root(Root, CWD) of + true -> CWD; + false -> Root + end, + AbsFile = case make_relative_filename(File) of + File -> + relate_filename_to_path(File, CWD1, Canonicalize); + RelFile -> + relate_filename_to_path(RelFile, Root, Canonicalize) + end, + case is_within_root(Root, AbsFile) of + true -> AbsFile; + false -> Root end. is_within_root(Root, File) -> diff --git a/lib/ssh/src/ssh_subsystem_sup.erl b/lib/ssh/src/ssh_subsystem_sup.erl index 637f5f398f..cf82db458f 100644 --- a/lib/ssh/src/ssh_subsystem_sup.erl +++ b/lib/ssh/src/ssh_subsystem_sup.erl @@ -26,6 +26,8 @@ -behaviour(supervisor). +-include("ssh.hrl"). + -export([start_link/1, connection_supervisor/1, channel_supervisor/1 @@ -37,8 +39,8 @@ %%%========================================================================= %%% API %%%========================================================================= -start_link(Opts) -> - supervisor:start_link(?MODULE, [Opts]). +start_link(Options) -> + supervisor:start_link(?MODULE, [Options]). connection_supervisor(SupPid) -> Children = supervisor:which_children(SupPid), @@ -53,42 +55,42 @@ channel_supervisor(SupPid) -> %%%========================================================================= -spec init( [term()] ) -> {ok,{supervisor:sup_flags(),[supervisor:child_spec()]}} | ignore . -init([Opts]) -> +init([Options]) -> RestartStrategy = one_for_all, MaxR = 0, MaxT = 3600, - Children = child_specs(Opts), + Children = child_specs(Options), {ok, {{RestartStrategy, MaxR, MaxT}, Children}}. %%%========================================================================= %%% Internal functions %%%========================================================================= -child_specs(Opts) -> - case proplists:get_value(role, Opts) of +child_specs(Options) -> + case ?GET_INTERNAL_OPT(role, Options) of client -> []; server -> - [ssh_channel_child_spec(Opts), ssh_connectinon_child_spec(Opts)] + [ssh_channel_child_spec(Options), ssh_connectinon_child_spec(Options)] end. -ssh_connectinon_child_spec(Opts) -> - Address = proplists:get_value(address, Opts), - Port = proplists:get_value(port, Opts), - Role = proplists:get_value(role, Opts), +ssh_connectinon_child_spec(Options) -> + Address = ?GET_INTERNAL_OPT(address, Options), + Port = ?GET_INTERNAL_OPT(port, Options), + Role = ?GET_INTERNAL_OPT(role, Options), Name = id(Role, ssh_connection_sup, Address, Port), - StartFunc = {ssh_connection_sup, start_link, [Opts]}, + StartFunc = {ssh_connection_sup, start_link, [Options]}, Restart = temporary, Shutdown = 5000, Modules = [ssh_connection_sup], Type = supervisor, {Name, StartFunc, Restart, Shutdown, Type, Modules}. -ssh_channel_child_spec(Opts) -> - Address = proplists:get_value(address, Opts), - Port = proplists:get_value(port, Opts), - Role = proplists:get_value(role, Opts), +ssh_channel_child_spec(Options) -> + Address = ?GET_INTERNAL_OPT(address, Options), + Port = ?GET_INTERNAL_OPT(port, Options), + Role = ?GET_INTERNAL_OPT(role, Options), Name = id(Role, ssh_channel_sup, Address, Port), - StartFunc = {ssh_channel_sup, start_link, [Opts]}, + StartFunc = {ssh_channel_sup, start_link, [Options]}, Restart = temporary, Shutdown = infinity, Modules = [ssh_channel_sup], diff --git a/lib/ssh/src/ssh_system_sup.erl b/lib/ssh/src/ssh_system_sup.erl index e97ac7b01a..b0bbd3aae5 100644 --- a/lib/ssh/src/ssh_system_sup.erl +++ b/lib/ssh/src/ssh_system_sup.erl @@ -45,12 +45,12 @@ %%%========================================================================= %%% Internal API %%%========================================================================= -start_link(ServerOpts) -> - Address = proplists:get_value(address, ServerOpts), - Port = proplists:get_value(port, ServerOpts), - Profile = proplists:get_value(profile, proplists:get_value(ssh_opts, ServerOpts), ?DEFAULT_PROFILE), +start_link(Options) -> + Address = ?GET_INTERNAL_OPT(address, Options), + Port = ?GET_INTERNAL_OPT(port, Options), + Profile = ?GET_OPT(profile, Options), Name = make_name(Address, Port, Profile), - supervisor:start_link({local, Name}, ?MODULE, [ServerOpts]). + supervisor:start_link({local, Name}, ?MODULE, [Options]). stop_listener(SysSup) -> stop_acceptor(SysSup). @@ -127,12 +127,12 @@ restart_acceptor(Address, Port, Profile) -> %%%========================================================================= -spec init( [term()] ) -> {ok,{supervisor:sup_flags(),[supervisor:child_spec()]}} | ignore . -init([ServerOpts]) -> +init([Options]) -> RestartStrategy = one_for_one, MaxR = 0, MaxT = 3600, - Children = case proplists:get_value(asocket,ServerOpts) of - undefined -> child_specs(ServerOpts); + Children = case ?GET_INTERNAL_OPT(asocket,Options,undefined) of + undefined -> child_specs(Options); _ -> [] end, {ok, {{RestartStrategy, MaxR, MaxT}, Children}}. @@ -140,24 +140,24 @@ init([ServerOpts]) -> %%%========================================================================= %%% Internal functions %%%========================================================================= -child_specs(ServerOpts) -> - [ssh_acceptor_child_spec(ServerOpts)]. +child_specs(Options) -> + [ssh_acceptor_child_spec(Options)]. -ssh_acceptor_child_spec(ServerOpts) -> - Address = proplists:get_value(address, ServerOpts), - Port = proplists:get_value(port, ServerOpts), - Profile = proplists:get_value(profile, proplists:get_value(ssh_opts, ServerOpts), ?DEFAULT_PROFILE), +ssh_acceptor_child_spec(Options) -> + Address = ?GET_INTERNAL_OPT(address, Options), + Port = ?GET_INTERNAL_OPT(port, Options), + Profile = ?GET_OPT(profile, Options), Name = id(ssh_acceptor_sup, Address, Port, Profile), - StartFunc = {ssh_acceptor_sup, start_link, [ServerOpts]}, + StartFunc = {ssh_acceptor_sup, start_link, [Options]}, Restart = transient, Shutdown = infinity, Modules = [ssh_acceptor_sup], Type = supervisor, {Name, StartFunc, Restart, Shutdown, Type, Modules}. -ssh_subsystem_child_spec(ServerOpts) -> +ssh_subsystem_child_spec(Options) -> Name = make_ref(), - StartFunc = {ssh_subsystem_sup, start_link, [ServerOpts]}, + StartFunc = {ssh_subsystem_sup, start_link, [Options]}, Restart = temporary, Shutdown = infinity, Modules = [ssh_subsystem_sup], diff --git a/lib/ssh/src/ssh_transport.erl b/lib/ssh/src/ssh_transport.erl index 5d178a202d..02c995399a 100644 --- a/lib/ssh/src/ssh_transport.erl +++ b/lib/ssh/src/ssh_transport.erl @@ -153,14 +153,14 @@ supported_algorithms(compression) -> %%%---------------------------------------------------------------------------- versions(client, Options)-> - Vsn = proplists:get_value(vsn, Options, ?DEFAULT_CLIENT_VERSION), + Vsn = ?GET_INTERNAL_OPT(vsn, Options, ?DEFAULT_CLIENT_VERSION), {Vsn, format_version(Vsn, software_version(Options))}; versions(server, Options) -> - Vsn = proplists:get_value(vsn, Options, ?DEFAULT_SERVER_VERSION), + Vsn = ?GET_INTERNAL_OPT(vsn, Options, ?DEFAULT_SERVER_VERSION), {Vsn, format_version(Vsn, software_version(Options))}. software_version(Options) -> - case proplists:get_value(id_string, Options) of + case ?GET_OPT(id_string, Options) of undefined -> "Erlang"++ssh_vsn(); {random,Nlo,Nup} -> @@ -171,7 +171,7 @@ software_version(Options) -> ssh_vsn() -> try {ok,L} = application:get_all_key(ssh), - proplists:get_value(vsn,L,"") + proplists:get_value(vsn, L, "") of "" -> ""; VSN when is_list(VSN) -> "/" ++ VSN; @@ -232,13 +232,7 @@ key_exchange_init_msg(Ssh0) -> kex_init(#ssh{role = Role, opts = Opts, available_host_keys = HostKeyAlgs}) -> Random = ssh_bits:random(16), - PrefAlgs = - case proplists:get_value(preferred_algorithms,Opts) of - undefined -> - default_algorithms(); - Algs0 -> - Algs0 - end, + PrefAlgs = ?GET_OPT(preferred_algorithms, Opts), kexinit_message(Role, Random, PrefAlgs, HostKeyAlgs). key_init(client, Ssh, Value) -> @@ -341,10 +335,7 @@ key_exchange_first_msg(Kex, Ssh0) when Kex == 'diffie-hellman-group1-sha1' ; key_exchange_first_msg(Kex, Ssh0=#ssh{opts=Opts}) when Kex == 'diffie-hellman-group-exchange-sha1' ; Kex == 'diffie-hellman-group-exchange-sha256' -> - {Min,NBits0,Max} = - proplists:get_value(dh_gex_limits, Opts, {?DEFAULT_DH_GROUP_MIN, - ?DEFAULT_DH_GROUP_NBITS, - ?DEFAULT_DH_GROUP_MAX}), + {Min,NBits0,Max} = ?GET_OPT(dh_gex_limits, Opts), DhBits = dh_bits(Ssh0#ssh.algorithms), NBits1 = %% NIST Special Publication 800-57 Part 1 Revision 4: Recommendation for Key Management @@ -458,7 +449,7 @@ handle_kex_dh_gex_request(#ssh_msg_kex_dh_gex_request{min = Min0, %% server {Min, Max} = adjust_gex_min_max(Min0, Max0, Opts), case public_key:dh_gex_group(Min, NBits, Max, - proplists:get_value(dh_gex_groups,Opts)) of + ?GET_OPT(dh_gex_groups,Opts)) of {ok, {_, {G,P}}} -> {SshPacket, Ssh} = ssh_packet(#ssh_msg_kex_dh_gex_group{p = P, g = G}, Ssh0), @@ -481,7 +472,7 @@ handle_kex_dh_gex_request(#ssh_msg_kex_dh_gex_request_old{n = NBits}, %% This message was in the draft-00 of rfc4419 %% (https://tools.ietf.org/html/draft-ietf-secsh-dh-group-exchange-00) %% In later drafts and the rfc is "is used for backward compatibility". - %% Unfortunatly the rfc does not specify how to treat the parameter n + %% Unfortunately the rfc does not specify how to treat the parameter n %% if there is no group of that modulus length :( %% The draft-00 however specifies that n is the "... number of bits %% the subgroup should have at least". @@ -492,7 +483,7 @@ handle_kex_dh_gex_request(#ssh_msg_kex_dh_gex_request_old{n = NBits}, Max0 = 8192, {Min, Max} = adjust_gex_min_max(Min0, Max0, Opts), case public_key:dh_gex_group(Min, NBits, Max, - proplists:get_value(dh_gex_groups,Opts)) of + ?GET_OPT(dh_gex_groups,Opts)) of {ok, {_, {G,P}}} -> {SshPacket, Ssh} = ssh_packet(#ssh_msg_kex_dh_gex_group{p = P, g = G}, Ssh0), @@ -517,22 +508,18 @@ handle_kex_dh_gex_request(_, _) -> adjust_gex_min_max(Min0, Max0, Opts) -> - case proplists:get_value(dh_gex_limits, Opts) of - undefined -> - {Min0, Max0}; - {Min1, Max1} -> - Min2 = max(Min0, Min1), - Max2 = min(Max0, Max1), - if - Min2 =< Max2 -> - {Min2, Max2}; - Max2 < Min2 -> - ssh_connection_handler:disconnect( - #ssh_msg_disconnect{ - code = ?SSH_DISCONNECT_PROTOCOL_ERROR, - description = "No possible diffie-hellman-group-exchange group possible" - }) - end + {Min1, Max1} = ?GET_OPT(dh_gex_limits, Opts), + Min2 = max(Min0, Min1), + Max2 = min(Max0, Max1), + if + Min2 =< Max2 -> + {Min2, Max2}; + Max2 < Min2 -> + ssh_connection_handler:disconnect( + #ssh_msg_disconnect{ + code = ?SSH_DISCONNECT_PROTOCOL_ERROR, + description = "No possible diffie-hellman-group-exchange group possible" + }) end. @@ -719,9 +706,9 @@ sid(#ssh{session_id = Id}, _) -> %% The host key should be read from storage %% get_host_key(SSH) -> - #ssh{key_cb = Mod, opts = Opts, algorithms = ALG} = SSH, - - case Mod:host_key(ALG#alg.hkey, Opts) of + #ssh{key_cb = {KeyCb,KeyCbOpts}, opts = Opts, algorithms = ALG} = SSH, + UserOpts = ?GET_OPT(user_options, Opts), + case KeyCb:host_key(ALG#alg.hkey, [{key_cb_private,KeyCbOpts}|UserOpts]) of {ok, #'RSAPrivateKey'{} = Key} -> Key; {ok, #'DSAPrivateKey'{} = Key} -> Key; {ok, #'ECPrivateKey'{} = Key} -> Key; @@ -767,7 +754,7 @@ public_algo({#'ECPoint'{},{namedCurve,OID}}) -> accepted_host(Ssh, PeerName, Public, Opts) -> - case proplists:get_value(silently_accept_hosts, Opts, false) of + case ?GET_OPT(silently_accept_hosts, Opts) of F when is_function(F,2) -> true == (catch F(PeerName, public_key:ssh_hostkey_fingerprint(Public))); {DigestAlg,F} when is_function(F,2) -> @@ -778,15 +765,16 @@ accepted_host(Ssh, PeerName, Public, Opts) -> yes == yes_no(Ssh, "New host " ++ PeerName ++ " accept") end. -known_host_key(#ssh{opts = Opts, key_cb = Mod, peer = {PeerName,_}} = Ssh, +known_host_key(#ssh{opts = Opts, key_cb = {KeyCb,KeyCbOpts}, peer = {PeerName,_}} = Ssh, Public, Alg) -> - case Mod:is_host_key(Public, PeerName, Alg, Opts) of + UserOpts = ?GET_OPT(user_options, Opts), + case KeyCb:is_host_key(Public, PeerName, Alg, [{key_cb_private,KeyCbOpts}|UserOpts]) of true -> ok; false -> case accepted_host(Ssh, PeerName, Public, Opts) of true -> - Mod:add_host_key(PeerName, Public, Opts); + KeyCb:add_host_key(PeerName, Public, [{key_cb_private,KeyCbOpts}|UserOpts]); false -> {error, rejected} end @@ -1822,10 +1810,6 @@ len_supported(Name, Len) -> same(Algs) -> [{client2server,Algs}, {server2client,Algs}]. - -%% default_algorithms(kex) -> % Example of how to disable an algorithm -%% supported_algorithms(kex, ['ecdh-sha2-nistp521']); - %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% %% Other utils diff --git a/lib/ssh/src/sshd_sup.erl b/lib/ssh/src/sshd_sup.erl index 04d2df30f7..14f1937abd 100644 --- a/lib/ssh/src/sshd_sup.erl +++ b/lib/ssh/src/sshd_sup.erl @@ -41,13 +41,13 @@ start_link(Servers) -> supervisor:start_link({local, ?MODULE}, ?MODULE, [Servers]). -start_child(ServerOpts) -> - Address = proplists:get_value(address, ServerOpts), - Port = proplists:get_value(port, ServerOpts), - Profile = proplists:get_value(profile, proplists:get_value(ssh_opts, ServerOpts), ?DEFAULT_PROFILE), +start_child(Options) -> + Address = ?GET_INTERNAL_OPT(address, Options), + Port = ?GET_INTERNAL_OPT(port, Options), + Profile = ?GET_OPT(profile, Options), case ssh_system_sup:system_supervisor(Address, Port, Profile) of undefined -> - Spec = child_spec(Address, Port, ServerOpts), + Spec = child_spec(Address, Port, Options), case supervisor:start_child(?MODULE, Spec) of {error, already_present} -> Name = id(Address, Port, Profile), @@ -58,7 +58,7 @@ start_child(ServerOpts) -> end; Pid -> AccPid = ssh_system_sup:acceptor_supervisor(Pid), - ssh_acceptor_sup:start_child(AccPid, ServerOpts) + ssh_acceptor_sup:start_child(AccPid, Options) end. stop_child(Name) -> @@ -82,8 +82,8 @@ init([Servers]) -> MaxR = 10, MaxT = 3600, Fun = fun(ServerOpts) -> - Address = proplists:get_value(address, ServerOpts), - Port = proplists:get_value(port, ServerOpts), + Address = ?GET_INTERNAL_OPT(address, ServerOpts), + Port = ?GET_INTERNAL_OPT(port, ServerOpts), child_spec(Address, Port, ServerOpts) end, Children = lists:map(Fun, Servers), @@ -92,10 +92,10 @@ init([Servers]) -> %%%========================================================================= %%% Internal functions %%%========================================================================= -child_spec(Address, Port, ServerOpts) -> - Profile = proplists:get_value(profile, proplists:get_value(ssh_opts, ServerOpts), ?DEFAULT_PROFILE), +child_spec(Address, Port, Options) -> + Profile = ?GET_OPT(profile, Options), Name = id(Address, Port,Profile), - StartFunc = {ssh_system_sup, start_link, [ServerOpts]}, + StartFunc = {ssh_system_sup, start_link, [Options]}, Restart = temporary, Shutdown = infinity, Modules = [ssh_system_sup], diff --git a/lib/ssh/test/ssh_algorithms_SUITE.erl b/lib/ssh/test/ssh_algorithms_SUITE.erl index 4327068b7b..6f75d83c4a 100644 --- a/lib/ssh/test/ssh_algorithms_SUITE.erl +++ b/lib/ssh/test/ssh_algorithms_SUITE.erl @@ -58,9 +58,11 @@ groups() -> || {Tag,Algs} <- ErlAlgos, lists:member(Tag,tags()) ], + + TypeSSH = ssh_test_lib:ssh_type(), AlgoTcSet = - [{Alg, [parallel], specific_test_cases(Tag,Alg,SshcAlgos,SshdAlgos)} + [{Alg, [parallel], specific_test_cases(Tag,Alg,SshcAlgos,SshdAlgos,TypeSSH)} || {Tag,Algs} <- ErlAlgos ++ DoubleAlgos, Alg <- Algs], @@ -198,6 +200,9 @@ try_exec_simple_group(Group, Config) -> %%-------------------------------------------------------------------- %% Testing all default groups +simple_exec_groups() -> + [{timetrap,{seconds,120}}]. + simple_exec_groups(Config) -> Sizes = interpolate( public_key:dh_gex_group_sizes() ), lists:foreach( @@ -313,18 +318,13 @@ concat(A1, A2) -> list_to_atom(lists:concat([A1," + ",A2])). split(Alg) -> ssh_test_lib:to_atoms(string:tokens(atom_to_list(Alg), " + ")). -specific_test_cases(Tag, Alg, SshcAlgos, SshdAlgos) -> +specific_test_cases(Tag, Alg, SshcAlgos, SshdAlgos, TypeSSH) -> [simple_exec, simple_sftp] ++ case supports(Tag, Alg, SshcAlgos) of - true -> - case ssh_test_lib:ssh_type() of - openSSH -> - [sshc_simple_exec_os_cmd]; - _ -> - [] - end; - false -> - [] + true when TypeSSH == openSSH -> + [sshc_simple_exec_os_cmd]; + _ -> + [] end ++ case supports(Tag, Alg, SshdAlgos) of true -> diff --git a/lib/ssh/test/ssh_benchmark_SUITE.erl b/lib/ssh/test/ssh_benchmark_SUITE.erl index 85750f8fbd..fc90750455 100644 --- a/lib/ssh/test/ssh_benchmark_SUITE.erl +++ b/lib/ssh/test/ssh_benchmark_SUITE.erl @@ -139,7 +139,6 @@ openssh_client_shell(Config, Options) -> {ok, TracerPid} = erlang_trace(), {ServerPid, _Host, Port} = ssh_test_lib:daemon([{system_dir, SystemDir}, - {public_key_alg, ssh_dsa}, {failfun, fun ssh_test_lib:failfun/2} | Options]), ct:sleep(500), @@ -215,7 +214,6 @@ openssh_client_sftp(Config, Options) -> {ok, TracerPid} = erlang_trace(), {ServerPid, _Host, Port} = ssh_test_lib:daemon([{system_dir, SystemDir}, - {public_key_alg, ssh_dsa}, {subsystems,[ssh_sftpd:subsystem_spec([%{cwd, SftpSrcDir}, {root, SftpSrcDir}])]}, {failfun, fun ssh_test_lib:failfun/2} diff --git a/lib/ssh/test/ssh_options_SUITE.erl b/lib/ssh/test/ssh_options_SUITE.erl index bd2d72c36c..758c20e2b8 100644 --- a/lib/ssh/test/ssh_options_SUITE.erl +++ b/lib/ssh/test/ssh_options_SUITE.erl @@ -67,7 +67,8 @@ hostkey_fingerprint_check_sha/1, hostkey_fingerprint_check_sha256/1, hostkey_fingerprint_check_sha384/1, - hostkey_fingerprint_check_sha512/1 + hostkey_fingerprint_check_sha512/1, + hostkey_fingerprint_check_list/1 ]). %%% Common test callbacks @@ -112,6 +113,7 @@ all() -> hostkey_fingerprint_check_sha256, hostkey_fingerprint_check_sha384, hostkey_fingerprint_check_sha512, + hostkey_fingerprint_check_list, id_string_no_opt_client, id_string_own_string_client, id_string_random_client, @@ -813,6 +815,8 @@ hostkey_fingerprint_check_sha384(Config) -> hostkey_fingerprint_check_sha512(Config) -> do_hostkey_fingerprint_check(Config, sha512). +hostkey_fingerprint_check_list(Config) -> + do_hostkey_fingerprint_check(Config, [sha,md5,sha256]). %%%---- do_hostkey_fingerprint_check(Config, HashAlg) -> @@ -825,9 +829,10 @@ do_hostkey_fingerprint_check(Config, HashAlg) -> supported_hash(old) -> true; supported_hash(HashAlg) -> - proplists:get_value(HashAlg, - proplists:get_value(hashs, crypto:supports(), []), - false). + Hs = if is_atom(HashAlg) -> [HashAlg]; + is_list(HashAlg) -> HashAlg + end, + [] == (Hs -- proplists:get_value(hashs, crypto:supports(), [])). really_do_hostkey_fingerprint_check(Config, HashAlg) -> @@ -841,7 +846,7 @@ really_do_hostkey_fingerprint_check(Config, HashAlg) -> %% All host key fingerprints. Trust that public_key has checked the ssh_hostkey_fingerprint %% function since that function is used by the ssh client... - FPs = [case HashAlg of + FPs0 = [case HashAlg of old -> public_key:ssh_hostkey_fingerprint(Key); _ -> public_key:ssh_hostkey_fingerprint(HashAlg, Key) end @@ -857,6 +862,9 @@ really_do_hostkey_fingerprint_check(Config, HashAlg) -> _:_ -> [] end end], + FPs = if is_atom(HashAlg) -> FPs0; + is_list(HashAlg) -> lists:concat(FPs0) + end, ct:log("Fingerprints(~p) = ~p",[HashAlg,FPs]), %% Start daemon with the public keys that we got fingerprints from @@ -867,8 +875,12 @@ really_do_hostkey_fingerprint_check(Config, HashAlg) -> FP_check_fun = fun(PeerName, FP) -> ct:pal("PeerName = ~p, FP = ~p",[PeerName,FP]), HostCheck = (Host == PeerName), - FPCheck = lists:member(FP, FPs), - ct:log("check ~p == ~p (~p) and ~n~p in ~p (~p)~n", + FPCheck = + if is_atom(HashAlg) -> lists:member(FP, FPs); + is_list(HashAlg) -> lists:all(fun(FP1) -> lists:member(FP1,FPs) end, + FP) + end, + ct:log("check ~p == ~p (~p) and ~n~p~n in ~p (~p)~n", [PeerName,Host,HostCheck,FP,FPs,FPCheck]), HostCheck and FPCheck end, diff --git a/lib/ssh/test/ssh_sftpd_SUITE.erl b/lib/ssh/test/ssh_sftpd_SUITE.erl index 52a26110c4..b167f98ac8 100644 --- a/lib/ssh/test/ssh_sftpd_SUITE.erl +++ b/lib/ssh/test/ssh_sftpd_SUITE.erl @@ -65,7 +65,12 @@ all() -> ver3_open_flags, relpath, sshd_read_file, - ver6_basic]. + ver6_basic, + access_outside_root, + root_with_cwd, + relative_path, + open_file_dir_v5, + open_file_dir_v6]. groups() -> []. @@ -117,6 +122,31 @@ init_per_testcase(TestCase, Config) -> ver6_basic -> SubSystems = [ssh_sftpd:subsystem_spec([{sftpd_vsn, 6}])], ssh:daemon(0, [{subsystems, SubSystems}|Options]); + access_outside_root -> + %% Build RootDir/access_outside_root/a/b and set Root and CWD + BaseDir = filename:join(PrivDir, access_outside_root), + RootDir = filename:join(BaseDir, a), + CWD = filename:join(RootDir, b), + %% Make the directory chain: + ok = filelib:ensure_dir(filename:join(CWD, tmp)), + SubSystems = [ssh_sftpd:subsystem_spec([{root, RootDir}, + {cwd, CWD}])], + ssh:daemon(0, [{subsystems, SubSystems}|Options]); + root_with_cwd -> + RootDir = filename:join(PrivDir, root_with_cwd), + CWD = filename:join(RootDir, home), + SubSystems = [ssh_sftpd:subsystem_spec([{root, RootDir}, {cwd, CWD}])], + ssh:daemon(0, [{subsystems, SubSystems}|Options]); + relative_path -> + SubSystems = [ssh_sftpd:subsystem_spec([{cwd, PrivDir}])], + ssh:daemon(0, [{subsystems, SubSystems}|Options]); + open_file_dir_v5 -> + SubSystems = [ssh_sftpd:subsystem_spec([{cwd, PrivDir}])], + ssh:daemon(0, [{subsystems, SubSystems}|Options]); + open_file_dir_v6 -> + SubSystems = [ssh_sftpd:subsystem_spec([{cwd, PrivDir}, + {sftpd_vsn, 6}])], + ssh:daemon(0, [{subsystems, SubSystems}|Options]); _ -> SubSystems = [ssh_sftpd:subsystem_spec([])], ssh:daemon(0, [{subsystems, SubSystems}|Options]) @@ -128,8 +158,7 @@ init_per_testcase(TestCase, Config) -> [{user_dir, ClientUserDir}, {user, ?USER}, {password, ?PASSWD}, {user_interaction, false}, - {silently_accept_hosts, true}, - {pwdfun, fun(_,_) -> true end}]), + {silently_accept_hosts, true}]), {ok, Channel} = ssh_connection:session_channel(Cm, ?XFER_WINDOW_SIZE, ?XFER_PACKET_SIZE, ?TIMEOUT), @@ -646,6 +675,133 @@ ver6_basic(Config) when is_list(Config) -> open_file(PrivDir, Cm, Channel, ReqId, ?ACE4_READ_DATA bor ?ACE4_READ_ATTRIBUTES, ?SSH_FXF_OPEN_EXISTING). + +%%-------------------------------------------------------------------- +access_outside_root() -> + [{doc, "Try access files outside the tree below RootDir"}]. +access_outside_root(Config) when is_list(Config) -> + PrivDir = proplists:get_value(priv_dir, Config), + BaseDir = filename:join(PrivDir, access_outside_root), + %% A file outside the tree below RootDir which is BaseDir/a + %% Make the file BaseDir/bad : + BadFilePath = filename:join([BaseDir, bad]), + ok = file:write_file(BadFilePath, <<>>), + {Cm, Channel} = proplists:get_value(sftp, Config), + %% Try to access a file parallell to the RootDir: + try_access("/../bad", Cm, Channel, 0), + %% Try to access the same file via the CWD which is /b relative to the RootDir: + try_access("../../bad", Cm, Channel, 1). + + +try_access(Path, Cm, Channel, ReqId) -> + Return = + open_file(Path, Cm, Channel, ReqId, + ?ACE4_READ_DATA bor ?ACE4_READ_ATTRIBUTES, + ?SSH_FXF_OPEN_EXISTING), + ct:log("Try open ~p -> ~p",[Path,Return]), + case Return of + {ok, <<?SSH_FXP_HANDLE, ?UINT32(ReqId), _Handle0/binary>>, _} -> + ct:fail("Could open a file outside the root tree!"); + {ok, <<?SSH_FXP_STATUS, ?UINT32(ReqId), ?UINT32(Code), Rest/binary>>, <<>>} -> + case Code of + ?SSH_FX_FILE_IS_A_DIRECTORY -> + ct:pal("Got the expected SSH_FX_FILE_IS_A_DIRECTORY status",[]), + ok; + ?SSH_FX_FAILURE -> + ct:pal("Got the expected SSH_FX_FAILURE status",[]), + ok; + _ -> + case Rest of + <<?UINT32(Len), Txt:Len/binary, _/binary>> -> + ct:fail("Got unexpected SSH_FX_code: ~p (~p)",[Code,Txt]); + _ -> + ct:fail("Got unexpected SSH_FX_code: ~p",[Code]) + end + end; + _ -> + ct:fail("Completly unexpected return: ~p", [Return]) + end. + +%%-------------------------------------------------------------------- +root_with_cwd() -> + [{doc, "Check if files are found, if the CWD and Root are specified"}]. +root_with_cwd(Config) when is_list(Config) -> + PrivDir = proplists:get_value(priv_dir, Config), + RootDir = filename:join(PrivDir, root_with_cwd), + CWD = filename:join(RootDir, home), + FileName = "root_with_cwd.txt", + FilePath = filename:join(CWD, FileName), + ok = filelib:ensure_dir(FilePath), + ok = file:write_file(FilePath ++ "0", <<>>), + ok = file:write_file(FilePath ++ "1", <<>>), + ok = file:write_file(FilePath ++ "2", <<>>), + {Cm, Channel} = proplists:get_value(sftp, Config), + ReqId0 = 0, + {ok, <<?SSH_FXP_HANDLE, ?UINT32(ReqId0), _Handle0/binary>>, _} = + open_file(FileName ++ "0", Cm, Channel, ReqId0, + ?ACE4_READ_DATA bor ?ACE4_READ_ATTRIBUTES, + ?SSH_FXF_OPEN_EXISTING), + ReqId1 = 1, + {ok, <<?SSH_FXP_HANDLE, ?UINT32(ReqId1), _Handle1/binary>>, _} = + open_file("./" ++ FileName ++ "1", Cm, Channel, ReqId1, + ?ACE4_READ_DATA bor ?ACE4_READ_ATTRIBUTES, + ?SSH_FXF_OPEN_EXISTING), + ReqId2 = 2, + {ok, <<?SSH_FXP_HANDLE, ?UINT32(ReqId2), _Handle2/binary>>, _} = + open_file("/home/" ++ FileName ++ "2", Cm, Channel, ReqId2, + ?ACE4_READ_DATA bor ?ACE4_READ_ATTRIBUTES, + ?SSH_FXF_OPEN_EXISTING). + +%%-------------------------------------------------------------------- +relative_path() -> + [{doc, "Test paths relative to CWD when opening a file handle."}]. +relative_path(Config) when is_list(Config) -> + PrivDir = proplists:get_value(priv_dir, Config), + FileName = "test_relative_path.txt", + FilePath = filename:join(PrivDir, FileName), + ok = filelib:ensure_dir(FilePath), + ok = file:write_file(FilePath, <<>>), + {Cm, Channel} = proplists:get_value(sftp, Config), + ReqId = 0, + {ok, <<?SSH_FXP_HANDLE, ?UINT32(ReqId), _Handle/binary>>, _} = + open_file(FileName, Cm, Channel, ReqId, + ?ACE4_READ_DATA bor ?ACE4_READ_ATTRIBUTES, + ?SSH_FXF_OPEN_EXISTING). + +%%-------------------------------------------------------------------- +open_file_dir_v5() -> + [{doc, "Test if open_file fails when opening existing directory."}]. +open_file_dir_v5(Config) when is_list(Config) -> + PrivDir = proplists:get_value(priv_dir, Config), + FileName = "open_file_dir_v5", + FilePath = filename:join(PrivDir, FileName), + ok = filelib:ensure_dir(FilePath), + ok = file:make_dir(FilePath), + {Cm, Channel} = proplists:get_value(sftp, Config), + ReqId = 0, + {ok, <<?SSH_FXP_STATUS, ?UINT32(ReqId), + ?UINT32(?SSH_FX_FAILURE), _/binary>>, _} = + open_file(FileName, Cm, Channel, ReqId, + ?ACE4_READ_DATA bor ?ACE4_READ_ATTRIBUTES, + ?SSH_FXF_OPEN_EXISTING). + +%%-------------------------------------------------------------------- +open_file_dir_v6() -> + [{doc, "Test if open_file fails when opening existing directory."}]. +open_file_dir_v6(Config) when is_list(Config) -> + PrivDir = proplists:get_value(priv_dir, Config), + FileName = "open_file_dir_v6", + FilePath = filename:join(PrivDir, FileName), + ok = filelib:ensure_dir(FilePath), + ok = file:make_dir(FilePath), + {Cm, Channel} = proplists:get_value(sftp, Config), + ReqId = 0, + {ok, <<?SSH_FXP_STATUS, ?UINT32(ReqId), + ?UINT32(?SSH_FX_FILE_IS_A_DIRECTORY), _/binary>>, _} = + open_file(FileName, Cm, Channel, ReqId, + ?ACE4_READ_DATA bor ?ACE4_READ_ATTRIBUTES, + ?SSH_FXF_OPEN_EXISTING). + %%-------------------------------------------------------------------- %% Internal functions ------------------------------------------------ %%-------------------------------------------------------------------- @@ -688,9 +844,7 @@ reply(Cm, Channel, RBuf) -> 30000 -> ct:fail("timeout ~p:~p",[?MODULE,?LINE]) end. - open_file(File, Cm, Channel, ReqId, Access, Flags) -> - Data = list_to_binary([?uint32(ReqId), ?binary(list_to_binary(File)), ?uint32(Access), diff --git a/lib/ssh/test/ssh_sftpd_erlclient_SUITE.erl b/lib/ssh/test/ssh_sftpd_erlclient_SUITE.erl index fd5157d603..b4d7eadfa4 100644 --- a/lib/ssh/test/ssh_sftpd_erlclient_SUITE.erl +++ b/lib/ssh/test/ssh_sftpd_erlclient_SUITE.erl @@ -189,7 +189,6 @@ quit(Config) when is_list(Config) -> timer:sleep(5000), {ok, NewSftp, _Conn} = ssh_sftp:start_channel(Host, Port, [{silently_accept_hosts, true}, - {pwdfun, fun(_,_) -> true end}, {user_dir, UserDir}, {user, ?USER}, {password, ?PASSWD}]), diff --git a/lib/ssh/test/ssh_to_openssh_SUITE.erl b/lib/ssh/test/ssh_to_openssh_SUITE.erl index 86c3d5de26..687e6efaf3 100644 --- a/lib/ssh/test/ssh_to_openssh_SUITE.erl +++ b/lib/ssh/test/ssh_to_openssh_SUITE.erl @@ -36,7 +36,7 @@ %%-------------------------------------------------------------------- suite() -> - [{timetrap,{seconds,20}}]. + [{timetrap,{seconds,60}}]. all() -> case os:find_executable("ssh") of @@ -381,7 +381,6 @@ erlang_server_openssh_client_public_key_X(Config, PubKeyAlg) -> PrivDir = proplists:get_value(priv_dir, Config), KnownHosts = filename:join(PrivDir, "known_hosts"), {Pid, Host, Port} = ssh_test_lib:daemon([{system_dir, SystemDir}, - {public_key_alg, PubKeyAlg}, {failfun, fun ssh_test_lib:failfun/2}]), ct:sleep(500), @@ -402,7 +401,6 @@ erlang_server_openssh_client_renegotiate(Config) -> KnownHosts = filename:join(PrivDir, "known_hosts"), {Pid, Host, Port} = ssh_test_lib:daemon([{system_dir, SystemDir}, - {public_key_alg, PubKeyAlg}, {failfun, fun ssh_test_lib:failfun/2}]), ct:sleep(500), @@ -442,7 +440,7 @@ erlang_server_openssh_client_renegotiate(Config) -> ssh_test_lib:rcv_expected(Expect, OpenSsh, ?TIMEOUT) of _ -> - %% Unfortunatly we can't check that there has been a renegotiation, just trust OpenSSH. + %% Unfortunately we can't check that there has been a renegotiation, just trust OpenSSH. ssh:stop_daemon(Pid) catch throw:{skip,R} -> {skip,R} @@ -464,6 +462,7 @@ erlang_client_openssh_server_renegotiate(_Config) -> {silently_accept_hosts,true}], group_leader(IO, self()), {ok, ConnRef} = ssh:connect(Host, ?SSH_DEFAULT_PORT, Options), + ct:pal("Parent = ~p, IO = ~p, Shell = ~p, ConnRef = ~p~n",[Parent, IO, self(), ConnRef]), case ssh_connection:session_channel(ConnRef, infinity) of {ok,ChannelId} -> success = ssh_connection:ptty_alloc(ConnRef, ChannelId, []), diff --git a/lib/ssh/test/ssh_trpt_test_lib.erl b/lib/ssh/test/ssh_trpt_test_lib.erl index 0fa0f0c0e4..261239c152 100644 --- a/lib/ssh/test/ssh_trpt_test_lib.erl +++ b/lib/ssh/test/ssh_trpt_test_lib.erl @@ -85,18 +85,18 @@ exec(Op, S0=#s{}) -> throw:Term -> report_trace(throw, Term, S1), - throw(Term); + throw({Term,Op}); error:Error -> report_trace(error, Error, S1), - error(Error); + error({Error,Op}); exit:Exit -> report_trace(exit, Exit, S1), - exit(Exit); + exit({Exit,Op}); Cls:Err -> ct:pal("Class=~p, Error=~p", [Cls,Err]), - error("fooooooO") + error({"fooooooO",Op}) end; exec(Op, {ok,S=#s{}}) -> exec(Op, S); exec(_, Error) -> Error. @@ -114,20 +114,20 @@ op({accept,Opts}, S) when ?role(S) == server -> {ok,Socket} = gen_tcp:accept(S#s.listen_socket, S#s.timeout), {Host,_Port} = ok(inet:sockname(Socket)), S#s{socket = Socket, - ssh = init_ssh(server,Socket,[{host,host(Host)}|Opts]), + ssh = init_ssh(server, Socket, host(Host), Opts), return_value = ok}; %%%---- Client ops op({connect,Host,Port,Opts}, S) when ?role(S) == undefined -> Socket = ok(gen_tcp:connect(host(Host), Port, mangle_opts([]))), S#s{socket = Socket, - ssh = init_ssh(client, Socket, [{host,host(Host)}|Opts]), + ssh = init_ssh(client, Socket, host(Host), Opts), return_value = ok}; %%%---- ops for both client and server op(close_socket, S) -> - catch tcp_gen:close(S#s.socket), - catch tcp_gen:close(S#s.listen_socket), + catch gen_tcp:close(S#s.socket), + catch gen_tcp:close(S#s.listen_socket), S#s{socket = undefined, listen_socket = undefined, return_value = ok}; @@ -296,12 +296,14 @@ instantiate(X, _S) -> %%%================================================================ %%% -init_ssh(Role, Socket, Options0) -> - Options = [{user_interaction, false}, - {vsn, {2,0}}, - {id_string, "ErlangTestLib"} - | Options0], - ssh_connection_handler:init_ssh_record(Role, Socket, Options). +init_ssh(Role, Socket, Host, UserOptions0) -> + UserOptions = [{user_interaction, false}, + {vsn, {2,0}}, + {id_string, "ErlangTestLib"} + | UserOptions0], + Opts = ?PUT_INTERNAL_OPT({host,Host}, + ssh_options:handle_options(Role, UserOptions)), + ssh_connection_handler:init_ssh_record(Role, Socket, Opts). mangle_opts(Options) -> SysOpts = [{reuseaddr, true}, diff --git a/lib/ssl/doc/src/ssl_session_cache_api.xml b/lib/ssl/doc/src/ssl_session_cache_api.xml index b85d8fb284..1b41eae89d 100644 --- a/lib/ssl/doc/src/ssl_session_cache_api.xml +++ b/lib/ssl/doc/src/ssl_session_cache_api.xml @@ -11,7 +11,7 @@ Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at - + http://www.apache.org/licenses/LICENSE-2.0 Unless required by applicable law or agreed to in writing, software @@ -62,8 +62,8 @@ </taglist> </section> - - <funcs> + + <funcs> <func> <name>delete(Cache, Key) -> _</name> @@ -134,7 +134,7 @@ </p> </desc> </func> - + <func> <name>select_session(Cache, PartialKey) -> [session()]</name> <fsummary>Selects sessions that can be reused.</fsummary> @@ -151,6 +151,21 @@ </func> <func> + <name>size(Cache) -> integer()</name> + <fsummary>Returns the number of sessions in the cache.</fsummary> + <type> + <v>Cache = cache_ref()</v> + </type> + <desc> + <p>Returns the number of sessions in the cache. If size + exceeds the maximum number of sessions, the current cache + entries will be invalidated regardless of their remaining + lifetime. Is to be callable from any process. + </p> + </desc> + </func> + + <func> <name>terminate(Cache) -> _</name> <fsummary>Called by the process that handles the cache when it is about to terminate.</fsummary> @@ -178,7 +193,7 @@ </p> </desc> </func> - - </funcs> - + + </funcs> + </erlref> diff --git a/lib/ssl/src/dtls_connection.erl b/lib/ssl/src/dtls_connection.erl index 070a90d481..f607c86ae3 100644 --- a/lib/ssl/src/dtls_connection.erl +++ b/lib/ssl/src/dtls_connection.erl @@ -39,7 +39,7 @@ -export([start_fsm/8, start_link/7, init/1]). %% State transition handling --export([next_record/1, next_event/3]). +-export([next_record/1, next_event/3, next_event/4]). %% Handshake handling -export([renegotiate/2, @@ -53,7 +53,7 @@ %% Data handling -export([encode_data/3, passive_receive/2, next_record_if_active/1, handle_common_event/4, - send/3]). + send/3, socket/5]). %% gen_statem state functions -export([init/3, error/3, downgrade/3, %% Initiation and take down states @@ -77,20 +77,6 @@ start_fsm(Role, Host, Port, Socket, {#ssl_options{erl_dist = false},_, Tracker} catch error:{badmatch, {error, _} = Error} -> Error - end; - -start_fsm(Role, Host, Port, Socket, {#ssl_options{erl_dist = true},_, Tracker} = Opts, - User, {CbModule, _,_, _} = CbInfo, - Timeout) -> - try - {ok, Pid} = dtls_connection_sup:start_child_dist([Role, Host, Port, Socket, - Opts, User, CbInfo]), - {ok, SslSocket} = ssl_connection:socket_control(?MODULE, Socket, Pid, CbModule, Tracker), - ok = ssl_connection:handshake(SslSocket, Timeout), - {ok, SslSocket} - catch - error:{badmatch, {error, _} = Error} -> - Error end. send_handshake(Handshake, #state{connection_states = ConnectionStates} = States) -> @@ -201,6 +187,7 @@ reinit_handshake_data(#state{protocol_buffers = Buffers} = State) -> State#state{premaster_secret = undefined, public_key_info = undefined, tls_handshake_history = ssl_handshake:init_handshake_history(), + flight_state = {retransmit, ?INITIAL_RETRANSMIT_TIMEOUT}, protocol_buffers = Buffers#protocol_buffers{ dtls_handshake_next_seq = 0, @@ -213,6 +200,9 @@ select_sni_extension(#client_hello{extensions = HelloExtensions}) -> select_sni_extension(_) -> undefined. +socket(Pid, Transport, Socket, Connection, _) -> + dtls_socket:socket(Pid, Transport, Socket, Connection). + %%==================================================================== %% tls_connection_sup API %%==================================================================== @@ -243,7 +233,7 @@ callback_mode() -> state_functions. %%-------------------------------------------------------------------- -%% State functionsconnection/2 +%% State functions %%-------------------------------------------------------------------- init({call, From}, {start, Timeout}, @@ -262,17 +252,19 @@ init({call, From}, {start, Timeout}, Version = Hello#client_hello.client_version, HelloVersion = dtls_record:lowest_protocol_version(SslOpts#ssl_options.versions), State1 = prepare_flight(State0#state{negotiated_version = Version}), - State2 = send_handshake(Hello, State1#state{negotiated_version = HelloVersion}), + {State2, Actions} = send_handshake(Hello, State1#state{negotiated_version = HelloVersion}), State3 = State2#state{negotiated_version = Version, %% Requested version session = Session0#session{session_id = Hello#client_hello.session_id}, start_or_recv_from = From, - timer = Timer}, + timer = Timer, + flight_state = {retransmit, ?INITIAL_RETRANSMIT_TIMEOUT} + }, {Record, State} = next_record(State3), - next_event(hello, Record, State); + next_event(hello, Record, State, Actions); init({call, _} = Type, Event, #state{role = server, transport_cb = gen_udp} = State) -> ssl_connection:init(Type, Event, - State#state{flight_state = {waiting, undefined, ?INITIAL_RETRANSMIT_TIMEOUT}}, + State#state{flight_state = {retransmit, ?INITIAL_RETRANSMIT_TIMEOUT}}, ?MODULE); init({call, _} = Type, Event, #state{role = server} = State) -> %% I.E. DTLS over sctp @@ -302,9 +294,9 @@ hello(internal, #client_hello{cookie = <<>>, Cookie = dtls_handshake:cookie(<<"secret">>, IP, Port, Hello), VerifyRequest = dtls_handshake:hello_verify_request(Cookie, Version), State1 = prepare_flight(State0#state{negotiated_version = Version}), - State2 = send_handshake(VerifyRequest, State1), + {State2, Actions} = send_handshake(VerifyRequest, State1), {Record, State} = next_record(State2), - next_event(hello, Record, State#state{tls_handshake_history = ssl_handshake:init_handshake_history()}); + next_event(hello, Record, State#state{tls_handshake_history = ssl_handshake:init_handshake_history()}, Actions); hello(internal, #client_hello{cookie = Cookie} = Hello, #state{role = server, transport_cb = Transport, socket = Socket} = State0) -> @@ -333,13 +325,13 @@ hello(internal, #hello_verify_request{cookie = Cookie}, #state{role = client, Cache, CacheCb, Renegotiation, OwnCert), Version = Hello#client_hello.client_version, HelloVersion = dtls_record:lowest_protocol_version(SslOpts#ssl_options.versions), - State2 = send_handshake(Hello, State1#state{negotiated_version = HelloVersion}), + {State2, Actions} = send_handshake(Hello, State1#state{negotiated_version = HelloVersion}), State3 = State2#state{negotiated_version = Version, %% Requested version session = Session0#session{session_id = Hello#client_hello.session_id}}, {Record, State} = next_record(State3), - next_event(hello, Record, State); + next_event(hello, Record, State, Actions); hello(internal, #server_hello{} = Hello, #state{connection_states = ConnectionStates0, negotiated_version = ReqVersion, @@ -356,13 +348,13 @@ hello(internal, #server_hello{} = Hello, hello(internal, {handshake, {#client_hello{cookie = <<>>} = Handshake, _}}, State) -> %% Initial hello should not be in handshake history {next_state, hello, State, [{next_event, internal, Handshake}]}; - hello(internal, {handshake, {#hello_verify_request{} = Handshake, _}}, State) -> %% hello_verify should not be in handshake history {next_state, hello, State, [{next_event, internal, Handshake}]}; - hello(info, Event, State) -> handle_info(Event, hello, State); +hello(state_timeout, Event, State) -> + handle_state_timeout(Event, hello, State); hello(Type, Event, State) -> ssl_connection:hello(Type, Event, State, ?MODULE). @@ -375,7 +367,11 @@ abbreviated(internal = Type, ConnectionStates = dtls_record:next_epoch(ConnectionStates1, read), ssl_connection:abbreviated(Type, Event, State#state{connection_states = ConnectionStates}, ?MODULE); abbreviated(internal = Type, #finished{} = Event, #state{connection_states = ConnectionStates} = State) -> - ssl_connection:cipher(Type, Event, prepare_flight(State#state{connection_states = ConnectionStates}), ?MODULE); + ssl_connection:abbreviated(Type, Event, + prepare_flight(State#state{connection_states = ConnectionStates, + flight_state = connection}), ?MODULE); +abbreviated(state_timeout, Event, State) -> + handle_state_timeout(Event, abbreviated, State); abbreviated(Type, Event, State) -> ssl_connection:abbreviated(Type, Event, State, ?MODULE). @@ -383,6 +379,8 @@ certify(info, Event, State) -> handle_info(Event, certify, State); certify(internal = Type, #server_hello_done{} = Event, State) -> ssl_connection:certify(Type, Event, prepare_flight(State), ?MODULE); +certify(state_timeout, Event, State) -> + handle_state_timeout(Event, certify, State); certify(Type, Event, State) -> ssl_connection:certify(Type, Event, State, ?MODULE). @@ -395,7 +393,11 @@ cipher(internal = Type, #change_cipher_spec{type = <<1>>} = Event, ssl_connection:cipher(Type, Event, State#state{connection_states = ConnectionStates}, ?MODULE); cipher(internal = Type, #finished{} = Event, #state{connection_states = ConnectionStates} = State) -> ssl_connection:cipher(Type, Event, - prepare_flight(State#state{connection_states = ConnectionStates}), ?MODULE); + prepare_flight(State#state{connection_states = ConnectionStates, + flight_state = connection}), + ?MODULE); +cipher(state_timeout, Event, State) -> + handle_state_timeout(Event, cipher, State); cipher(Type, Event, State) -> ssl_connection:cipher(Type, Event, State, ?MODULE). @@ -409,12 +411,12 @@ connection(internal, #hello_request{}, #state{host = Host, port = Port, renegotiation = {Renegotiation, _}} = State0) -> Hello = dtls_handshake:client_hello(Host, Port, ConnectionStates0, SslOpts, Cache, CacheCb, Renegotiation, Cert), - State1 = send_handshake(Hello, State0), + {State1, Actions} = send_handshake(Hello, State0), {Record, State} = next_record( State1#state{session = Session0#session{session_id = Hello#client_hello.session_id}}), - next_event(hello, Record, State); + next_event(hello, Record, State, Actions); connection(internal, #client_hello{} = Hello, #state{role = server, allow_renegotiate = true} = State) -> %% Mitigate Computational DoS attack %% http://www.educatedguesswork.org/2011/10/ssltls_and_computational_dos.html @@ -434,7 +436,6 @@ connection(Type, Event, State) -> downgrade(Type, Event, State) -> ssl_connection:downgrade(Type, Event, State, ?MODULE). - %%-------------------------------------------------------------------- %% Description: This function is called by a gen_fsm when it receives any %% other message than a synchronous or asynchronous event @@ -442,16 +443,6 @@ downgrade(Type, Event, State) -> %%-------------------------------------------------------------------- %% raw data from socket, unpack records -handle_info({_,flight_retransmission_timeout}, connection, _) -> - {next_state, keep_state_and_data}; -handle_info({Ref, flight_retransmission_timeout}, StateName, - #state{flight_state = {waiting, Ref, NextTimeout}} = State0) -> - State1 = send_handshake_flight(State0#state{flight_state = {retransmit_timer, NextTimeout}}, - retransmit_epoch(StateName, State0)), - {Record, State} = next_record(State1), - next_event(StateName, Record, State); -handle_info({_, flight_retransmission_timeout}, _, _) -> - {next_state, keep_state_and_data}; handle_info({Protocol, _, _, _, Data}, StateName, #state{data_tag = Protocol} = State0) -> case next_dtls_record(Data, State0) of @@ -489,7 +480,6 @@ handle_call(Event, From, StateName, State) -> handle_common_event(internal, #alert{} = Alert, StateName, #state{negotiated_version = Version} = State) -> ssl_connection:handle_own_alert(Alert, Version, StateName, State); - %%% DTLS record protocol level handshake messages handle_common_event(internal, #ssl_tls{type = ?HANDSHAKE, fragment = Data}, @@ -498,19 +488,14 @@ handle_common_event(internal, #ssl_tls{type = ?HANDSHAKE, negotiated_version = Version} = State0) -> try case dtls_handshake:get_dtls_handshake(Version, Data, Buffers0) of - {more_data, Buffers} -> + {[], Buffers} -> {Record, State} = next_record(State0#state{protocol_buffers = Buffers}), next_event(StateName, Record, State); {Packets, Buffers} -> State = State0#state{protocol_buffers = Buffers}, Events = dtls_handshake_events(Packets), - case StateName of - connection -> - ssl_connection:hibernate_after(StateName, State, Events); - _ -> - {next_state, StateName, - State#state{unprocessed_handshake_events = unprocessed_events(Events)}, Events} - end + {next_state, StateName, + State#state{unprocessed_handshake_events = unprocessed_events(Events)}, Events} end catch throw:#alert{} = Alert -> ssl_connection:handle_own_alert(Alert, Version, StateName, State0) @@ -534,6 +519,13 @@ handle_common_event(internal, #ssl_tls{type = ?ALERT, fragment = EncAlerts}, Sta handle_common_event(internal, #ssl_tls{type = _Unknown}, StateName, State) -> {next_state, StateName, State}. +handle_state_timeout(flight_retransmission_timeout, StateName, + #state{flight_state = {retransmit, NextTimeout}} = State0) -> + {State1, Actions} = send_handshake_flight(State0#state{flight_state = {retransmit, NextTimeout}}, + retransmit_epoch(StateName, State0)), + {Record, State} = next_record(State1), + next_event(StateName, Record, State, Actions). + send(Transport, {_, {{_,_}, _} = Socket}, Data) -> send(Transport, Socket, Data); send(Transport, Socket, Data) -> @@ -645,7 +637,8 @@ initial_state(Role, Host, Port, Socket, {SSLOptions, SocketOptions, _}, User, allow_renegotiate = SSLOptions#ssl_options.client_renegotiation, start_or_recv_from = undefined, protocol_cb = ?MODULE, - flight_buffer = new_flight() + flight_buffer = new_flight(), + flight_state = {retransmit, ?INITIAL_RETRANSMIT_TIMEOUT} }. next_dtls_record(Data, #state{protocol_buffers = #protocol_buffers{ @@ -714,14 +707,14 @@ next_event(connection = StateName, no_record, #state{connection_states = #{current_read := #{epoch := CurrentEpoch}}} = State0, Actions) -> case next_record_if_active(State0) of {no_record, State} -> - ssl_connection:hibernate_after(StateName, State, Actions); + ssl_connection:hibernate_after(StateName, State, Actions); {#ssl_tls{epoch = CurrentEpoch} = Record, State} -> {next_state, StateName, State, [{next_event, internal, {protocol_record, Record}} | Actions]}; {#ssl_tls{epoch = Epoch, type = ?HANDSHAKE, version = _Version}, State1} = _Record when Epoch == CurrentEpoch-1 -> - State = send_handshake_flight(State1, Epoch), - {next_state, StateName, State, Actions}; + {State, MoreActions} = send_handshake_flight(State1, Epoch), + {next_state, StateName, State, Actions ++ MoreActions}; {#ssl_tls{epoch = _Epoch, version = _Version}, State} -> %% TODO maybe buffer later epoch @@ -772,17 +765,20 @@ next_flight(Flight) -> Flight#{handshakes => [], change_cipher_spec => undefined, handshakes_after_change_cipher_spec => []}. - start_flight(#state{transport_cb = gen_udp, - flight_state = {retransmit_timer, Timeout}} = State) -> - Ref = erlang:make_ref(), - _ = erlang:send_after(Timeout, self(), {Ref, flight_retransmission_timeout}), - State#state{flight_state = {waiting, Ref, new_timeout(Timeout)}}; - + flight_state = {retransmit, Timeout}} = State) -> + start_retransmision_timer(Timeout, State); +start_flight(#state{transport_cb = gen_udp, + flight_state = connection} = State) -> + {State, []}; start_flight(State) -> %% No retransmision needed i.e DTLS over SCTP - State#state{flight_state = reliable}. + {State#state{flight_state = reliable}, []}. + +start_retransmision_timer(Timeout, State) -> + {State#state{flight_state = {retransmit, new_timeout(Timeout)}}, + [{state_timeout, Timeout, flight_retransmission_timeout}]}. new_timeout(N) when N =< 30 -> N * 2; @@ -806,13 +802,13 @@ renegotiate(#state{role = server, connection_states = CS0} = State0, Actions) -> HelloRequest = ssl_handshake:hello_request(), CS = CS0#{write_msg_seq => 0}, - State1 = send_handshake(HelloRequest, - State0#state{connection_states = - CS}), + {State1, MoreActions} = send_handshake(HelloRequest, + State0#state{connection_states = + CS}), Hs0 = ssl_handshake:init_handshake_history(), {Record, State} = next_record(State1#state{tls_handshake_history = Hs0, protocol_buffers = #protocol_buffers{}}), - next_event(hello, Record, State, Actions). + next_event(hello, Record, State, Actions ++ MoreActions). handle_alerts([], Result) -> Result; @@ -823,15 +819,11 @@ handle_alerts([Alert | Alerts], {next_state, StateName, State}) -> handle_alerts([Alert | Alerts], {next_state, StateName, State, _Actions}) -> handle_alerts(Alerts, ssl_connection:handle_alert(Alert, StateName, State)). -retransmit_epoch(StateName, #state{connection_states = ConnectionStates}) -> +retransmit_epoch(_StateName, #state{connection_states = ConnectionStates}) -> #{epoch := Epoch} = ssl_record:current_connection_state(ConnectionStates, write), - case StateName of - connection -> - Epoch-1; - _ -> - Epoch - end. + Epoch. + update_handshake_history(#hello_verify_request{}, _, Hist) -> Hist; @@ -846,3 +838,4 @@ unprocessed_events(Events) -> %% handshake events left to process before we should %% process more TLS-records received on the socket. erlang:length(Events)-1. + diff --git a/lib/ssl/src/dtls_handshake.erl b/lib/ssl/src/dtls_handshake.erl index af3708ddb7..fd1f9698fe 100644 --- a/lib/ssl/src/dtls_handshake.erl +++ b/lib/ssl/src/dtls_handshake.erl @@ -136,9 +136,11 @@ handshake_bin([Type, Length, Data], Seq) -> %%-------------------------------------------------------------------- -spec get_dtls_handshake(dtls_record:dtls_version(), binary(), #protocol_buffers{}) -> - {[{dtls_handshake(), binary()}], #protocol_buffers{}} | {more_data, #protocol_buffers{}}. + {[dtls_handshake()], #protocol_buffers{}}. %% -%% Description: ... +%% Description: Given buffered and new data from dtls_record, collects +%% and returns it as a list of handshake messages, also returns +%% possible leftover data in the new "protocol_buffers". %%-------------------------------------------------------------------- get_dtls_handshake(Version, Fragment, ProtocolBuffers) -> handle_fragments(Version, Fragment, ProtocolBuffers, []). @@ -288,8 +290,6 @@ do_handle_fragments(_, [], Buffers, Acc) -> {lists:reverse(Acc), Buffers}; do_handle_fragments(Version, [Fragment | Fragments], Buffers0, Acc) -> case reassemble(Version, Fragment, Buffers0) of - {more_data, _} = More when Acc == []-> - More; {more_data, Buffers} when Fragments == [] -> {lists:reverse(Acc), Buffers}; {more_data, Buffers} -> diff --git a/lib/ssl/src/dtls_record.erl b/lib/ssl/src/dtls_record.erl index f447897d59..0ee51c24b6 100644 --- a/lib/ssl/src/dtls_record.erl +++ b/lib/ssl/src/dtls_record.erl @@ -393,7 +393,7 @@ init_connection_state_seq(_, ConnnectionStates) -> integer(). %% %% Description: Returns the epoch the connection_state record -%% that is currently defined as the current conection state. +%% that is currently defined as the current connection state. %%-------------------------------------------------------------------- current_connection_state_epoch(#{current_read := #{epoch := Epoch}}, read) -> diff --git a/lib/ssl/src/dtls_socket.erl b/lib/ssl/src/dtls_socket.erl index 570b3ae83a..ac1a7b37c6 100644 --- a/lib/ssl/src/dtls_socket.erl +++ b/lib/ssl/src/dtls_socket.erl @@ -71,11 +71,14 @@ connect(Address, Port, #config{transport_info = {Transport, _, _, _} = CbInfo, close(gen_udp, {_Client, _Socket}) -> ok. +socket(Pid, gen_udp = Transport, {{_, _}, Socket}, ConnectionCb) -> + #sslsocket{pid = Pid, + %% "The name "fd" is keept for backwards compatibility + fd = {Transport, Socket, ConnectionCb}}; socket(Pid, Transport, Socket, ConnectionCb) -> #sslsocket{pid = Pid, %% "The name "fd" is keept for backwards compatibility - fd = {Transport, Socket, ConnectionCb}}. - + fd = {Transport, Socket, ConnectionCb}}. %% Vad göra med emulerade setopts(gen_udp, #sslsocket{pid = {Socket, _}}, Options) -> {SockOpts, _} = tls_socket:split_options(Options), @@ -108,11 +111,15 @@ getstat(gen_udp, {_,Socket}, Options) -> inet:getstat(Socket, Options); getstat(Transport, Socket, Options) -> Transport:getstat(Socket, Options). +peername(udp, _) -> + {error, enotconn}; peername(gen_udp, {_, {Client, _Socket}}) -> {ok, Client}; peername(Transport, Socket) -> Transport:peername(Socket). -sockname(gen_udp, {_,Socket}) -> +sockname(gen_udp, {_, {_,Socket}}) -> + inet:sockname(Socket); +sockname(gen_udp, Socket) -> inet:sockname(Socket); sockname(Transport, Socket) -> Transport:sockname(Socket). diff --git a/lib/ssl/src/dtls_udp_listener.erl b/lib/ssl/src/dtls_udp_listener.erl index b7f115582e..ab3d0783bd 100644 --- a/lib/ssl/src/dtls_udp_listener.erl +++ b/lib/ssl/src/dtls_udp_listener.erl @@ -24,7 +24,8 @@ -behaviour(gen_server). %% API --export([start_link/4, active_once/3, accept/2, sockname/1]). +-export([start_link/4, active_once/3, accept/2, sockname/1, close/1, + get_all_opts/1]). %% gen_server callbacks -export([init/1, handle_call/3, handle_cast/2, handle_info/2, @@ -39,7 +40,8 @@ clients = set_new(), dtls_processes = kv_new(), accepters = queue:new(), - first + first, + close }). %%%=================================================================== @@ -53,10 +55,14 @@ active_once(UDPConnection, Client, Pid) -> gen_server:cast(UDPConnection, {active_once, Client, Pid}). accept(UDPConnection, Accepter) -> - gen_server:call(UDPConnection, {accept, Accepter}, infinity). + call(UDPConnection, {accept, Accepter}). sockname(UDPConnection) -> - gen_server:call(UDPConnection, sockname, infinity). + call(UDPConnection, sockname). +close(UDPConnection) -> + call(UDPConnection, close). +get_all_opts(UDPConnection) -> + call(UDPConnection, get_all_opts). %%%=================================================================== %%% gen_server callbacks @@ -69,10 +75,13 @@ init([Port, EmOpts, InetOptions, DTLSOptions]) -> first = true, dtls_options = DTLSOptions, emulated_options = EmOpts, - listner = Socket}} + listner = Socket, + close = false}} catch _:_ -> {error, closed} end. +handle_call({accept, _}, _, #state{close = true} = State) -> + {reply, {error, closed}, State}; handle_call({accept, Accepter}, From, #state{first = true, accepters = Accepters, @@ -87,7 +96,21 @@ handle_call({accept, Accepter}, From, #state{accepters = Accepters} = State0) -> {noreply, State}; handle_call(sockname, _, #state{listner = Socket} = State) -> Reply = inet:sockname(Socket), - {reply, Reply, State}. + {reply, Reply, State}; +handle_call(close, _, #state{dtls_processes = Processes, + accepters = Accepters} = State) -> + case kv_empty(Processes) of + true -> + {stop, normal, ok, State#state{close=true}}; + false -> + lists:foreach(fun({_, From}) -> + gen_server:reply(From, {error, closed}) + end, queue:to_list(Accepters)), + {reply, ok, State#state{close = true, accepters = queue:new()}} + end; +handle_call(get_all_opts, _, #state{dtls_options = DTLSOptions, + emulated_options = EmOpts} = State) -> + {reply, {ok, EmOpts, DTLSOptions}, State}. handle_cast({active_once, Client, Pid}, State0) -> State = handle_active_once(Client, Pid, State0), @@ -99,11 +122,17 @@ handle_info({udp, Socket, IP, InPortNo, _} = Msg, #state{listner = Socket} = Sta {noreply, State}; handle_info({'DOWN', _, process, Pid, _}, #state{clients = Clients, - dtls_processes = Processes0} = State) -> + dtls_processes = Processes0, + close = ListenClosed} = State) -> Client = kv_get(Pid, Processes0), Processes = kv_delete(Pid, Processes0), - {noreply, State#state{clients = set_delete(Client, Clients), - dtls_processes = Processes}}. + case ListenClosed andalso kv_empty(Processes) of + true -> + {stop, normal, State}; + false -> + {noreply, State#state{clients = set_delete(Client, Clients), + dtls_processes = Processes}} + end. terminate(_Reason, _State) -> ok. @@ -182,6 +211,7 @@ setup_new_connection(User, From, Client, Msg, #state{dtls_processes = Processes, gen_server:reply(From, {error, Reason}), State end. + kv_update(Key, Value, Store) -> gb_trees:update(Key, Value, Store). kv_lookup(Key, Store) -> @@ -194,6 +224,8 @@ kv_delete(Key, Store) -> gb_trees:delete(Key, Store). kv_new() -> gb_trees:empty(). +kv_empty(Store) -> + gb_trees:is_empty(Store). set_new() -> gb_sets:empty(). @@ -203,3 +235,15 @@ set_delete(Item, Set) -> gb_sets:delete(Item, Set). set_is_member(Item, Set) -> gb_sets:is_member(Item, Set). + +call(Server, Msg) -> + try + gen_server:call(Server, Msg, infinity) + catch + exit:{noproc, _} -> + {error, closed}; + exit:{normal, _} -> + {error, closed}; + exit:{{shutdown, _},_} -> + {error, closed} + end. diff --git a/lib/ssl/src/dtls_v1.erl b/lib/ssl/src/dtls_v1.erl index ffd3e4b833..dd0d35d404 100644 --- a/lib/ssl/src/dtls_v1.erl +++ b/lib/ssl/src/dtls_v1.erl @@ -21,12 +21,21 @@ -include("ssl_cipher.hrl"). --export([suites/1, mac_hash/7, ecc_curves/1, corresponding_tls_version/1, corresponding_dtls_version/1]). +-export([suites/1, all_suites/1, mac_hash/7, ecc_curves/1, + corresponding_tls_version/1, corresponding_dtls_version/1]). -spec suites(Minor:: 253|255) -> [ssl_cipher:cipher_suite()]. suites(Minor) -> - tls_v1:suites(corresponding_minor_tls_version(Minor)). + lists:filter(fun(Cipher) -> + is_acceptable_cipher(ssl_cipher:suite_definition(Cipher)) + end, + tls_v1:suites(corresponding_minor_tls_version(Minor))). +all_suites(Version) -> + lists:filter(fun(Cipher) -> + is_acceptable_cipher(ssl_cipher:suite_definition(Cipher)) + end, + ssl_cipher:all_suites(corresponding_tls_version(Version))). mac_hash(Version, MacAlg, MacSecret, SeqNo, Type, Length, Fragment) -> tls_v1:mac_hash(MacAlg, MacSecret, SeqNo, Type, Version, @@ -50,3 +59,5 @@ corresponding_minor_dtls_version(2) -> 255; corresponding_minor_dtls_version(3) -> 253. +is_acceptable_cipher(Suite) -> + not ssl_cipher:is_stream_ciphersuite(Suite). diff --git a/lib/ssl/src/ssl.app.src b/lib/ssl/src/ssl.app.src index 148989174d..064dcd6892 100644 --- a/lib/ssl/src/ssl.app.src +++ b/lib/ssl/src/ssl.app.src @@ -63,7 +63,7 @@ {applications, [crypto, public_key, kernel, stdlib]}, {env, []}, {mod, {ssl_app, []}}, - {runtime_dependencies, ["stdlib-3.1","public_key-1.2","kernel-3.0", + {runtime_dependencies, ["stdlib-3.2","public_key-1.2","kernel-3.0", "erts-7.0","crypto-3.3", "inets-5.10.7"]}]}. diff --git a/lib/ssl/src/ssl.appup.src b/lib/ssl/src/ssl.appup.src index 32252386b4..bfdd0c205b 100644 --- a/lib/ssl/src/ssl.appup.src +++ b/lib/ssl/src/ssl.appup.src @@ -1,11 +1,19 @@ %% -*- erlang -*- {"%VSN%", [ - {<<"^8[.]0([.][0-9]+)?$">>, [{restart_application, ssl}]}, - {<<"^[3-7][.][^.].*">>, [{restart_application, ssl}]} + {<<"8\\..*">>, [{restart_application, ssl}]}, + {<<"7\\..*">>, [{restart_application, ssl}]}, + {<<"6\\..*">>, [{restart_application, ssl}]}, + {<<"5\\..*">>, [{restart_application, ssl}]}, + {<<"4\\..*">>, [{restart_application, ssl}]}, + {<<"3\\..*">>, [{restart_application, ssl}]} ], [ - {<<"^8[.]0([.][0-9]+)?$">>, [{restart_application, ssl}]}, - {<<"^[3-7][.][^.].*">>, [{restart_application, ssl}]} - ] + {<<"8\\..*">>, [{restart_application, ssl}]}, + {<<"7\\..*">>, [{restart_application, ssl}]}, + {<<"6\\..*">>, [{restart_application, ssl}]}, + {<<"5\\..*">>, [{restart_application, ssl}]}, + {<<"4\\..*">>, [{restart_application, ssl}]}, + {<<"3\\..*">>, [{restart_application, ssl}]} + ] }. diff --git a/lib/ssl/src/ssl.erl b/lib/ssl/src/ssl.erl index 4a5a7e25ea..ed04c7e67b 100644 --- a/lib/ssl/src/ssl.erl +++ b/lib/ssl/src/ssl.erl @@ -187,16 +187,24 @@ ssl_accept(ListenSocket, SslOptions) when is_port(ListenSocket) -> ssl_accept(#sslsocket{} = Socket, [], Timeout) when (is_integer(Timeout) andalso Timeout >= 0) or (Timeout == infinity)-> ssl_accept(Socket, Timeout); -ssl_accept(#sslsocket{fd = {_, _, _, Tracker}} = Socket, SslOpts0, Timeout) when +ssl_accept(#sslsocket{fd = {_, _, _, Tracker}} = Socket, SslOpts, Timeout) when (is_integer(Timeout) andalso Timeout >= 0) or (Timeout == infinity)-> try - {ok, EmOpts, InheritedSslOpts} = tls_socket:get_all_opts(Tracker), - SslOpts = handle_options(SslOpts0, InheritedSslOpts), + {ok, EmOpts, _} = tls_socket:get_all_opts(Tracker), ssl_connection:handshake(Socket, {SslOpts, tls_socket:emulated_socket_options(EmOpts, #socket_options{})}, Timeout) catch Error = {error, _Reason} -> Error end; +ssl_accept(#sslsocket{pid = Pid, fd = {_, _, _}} = Socket, SslOpts, Timeout) when + (is_integer(Timeout) andalso Timeout >= 0) or (Timeout == infinity)-> + try + {ok, EmOpts, _} = dtls_udp_listener:get_all_opts(Pid), + ssl_connection:handshake(Socket, {SslOpts, + tls_socket:emulated_socket_options(EmOpts, #socket_options{})}, Timeout) + catch + Error = {error, _Reason} -> Error + end; ssl_accept(Socket, SslOptions, Timeout) when is_port(Socket), (is_integer(Timeout) andalso Timeout >= 0) or (Timeout == infinity) -> {Transport,_,_,_} = @@ -215,7 +223,6 @@ ssl_accept(Socket, SslOptions, Timeout) when is_port(Socket), catch Error = {error, _Reason} -> Error end. - %%-------------------------------------------------------------------- -spec close(#sslsocket{}) -> term(). %% @@ -223,6 +230,8 @@ ssl_accept(Socket, SslOptions, Timeout) when is_port(Socket), %%-------------------------------------------------------------------- close(#sslsocket{pid = Pid}) when is_pid(Pid) -> ssl_connection:close(Pid, {close, ?DEFAULT_TIMEOUT}); +close(#sslsocket{pid = {udp, #config{udp_handler = {Pid, _}}}}) -> + dtls_udp_listener:close(Pid); close(#sslsocket{pid = {ListenSocket, #config{transport_info={Transport,_, _, _}}}}) -> Transport:close(ListenSocket). @@ -251,6 +260,8 @@ send(#sslsocket{pid = Pid}, Data) when is_pid(Pid) -> ssl_connection:send(Pid, Data); send(#sslsocket{pid = {_, #config{transport_info={gen_udp, _, _, _}}}}, _) -> {error,enotconn}; %% Emulate connection behaviour +send(#sslsocket{pid = {udp,_}}, _) -> + {error,enotconn}; send(#sslsocket{pid = {ListenSocket, #config{transport_info={Transport, _, _, _}}}}, Data) -> Transport:send(ListenSocket, Data). %% {error,enotconn} @@ -265,6 +276,8 @@ recv(Socket, Length) -> recv(#sslsocket{pid = Pid}, Length, Timeout) when is_pid(Pid), (is_integer(Timeout) andalso Timeout >= 0) or (Timeout == infinity)-> ssl_connection:recv(Pid, Length, Timeout); +recv(#sslsocket{pid = {udp,_}}, _, _) -> + {error,enotconn}; recv(#sslsocket{pid = {Listen, #config{transport_info = {Transport, _, _, _}}}}, _,_) when is_port(Listen)-> Transport:recv(Listen, 0). %% {error,enotconn} @@ -277,10 +290,14 @@ recv(#sslsocket{pid = {Listen, %%-------------------------------------------------------------------- controlling_process(#sslsocket{pid = Pid}, NewOwner) when is_pid(Pid), is_pid(NewOwner) -> ssl_connection:new_user(Pid, NewOwner); +controlling_process(#sslsocket{pid = {udp, _}}, + NewOwner) when is_pid(NewOwner) -> + ok; %% Meaningless but let it be allowed to conform with TLS controlling_process(#sslsocket{pid = {Listen, #config{transport_info = {Transport, _, _, _}}}}, NewOwner) when is_port(Listen), is_pid(NewOwner) -> + %% Meaningless but let it be allowed to conform with normal sockets Transport:controlling_process(Listen, NewOwner). @@ -297,7 +314,9 @@ connection_information(#sslsocket{pid = Pid}) when is_pid(Pid) -> Error end; connection_information(#sslsocket{pid = {Listen, _}}) when is_port(Listen) -> - {error, enotconn}. + {error, enotconn}; +connection_information(#sslsocket{pid = {udp,_}}) -> + {error,enotconn}. %%-------------------------------------------------------------------- -spec connection_information(#sslsocket{}, [atom()]) -> {ok, list()} | {error, reason()}. @@ -333,10 +352,18 @@ connection_info(#sslsocket{} = SSLSocket) -> %% %% Description: same as inet:peername/1. %%-------------------------------------------------------------------- +peername(#sslsocket{pid = Pid, fd = {Transport, Socket, _}}) when is_pid(Pid)-> + dtls_socket:peername(Transport, Socket); peername(#sslsocket{pid = Pid, fd = {Transport, Socket, _, _}}) when is_pid(Pid)-> tls_socket:peername(Transport, Socket); +peername(#sslsocket{pid = {udp = Transport, #config{udp_handler = {_Pid, _}}}}) -> + dtls_socket:peername(Transport, undefined); +peername(#sslsocket{pid = Pid, fd = {gen_udp= Transport, Socket, _, _}}) when is_pid(Pid) -> + dtls_socket:peername(Transport, Socket); peername(#sslsocket{pid = {ListenSocket, #config{transport_info = {Transport,_,_,_}}}}) -> - tls_socket:peername(Transport, ListenSocket). %% Will return {error, enotconn} + tls_socket:peername(Transport, ListenSocket); %% Will return {error, enotconn} +peername(#sslsocket{pid = {udp,_}}) -> + {error,enotconn}. %%-------------------------------------------------------------------- -spec peercert(#sslsocket{}) ->{ok, DerCert::binary()} | {error, reason()}. @@ -350,6 +377,8 @@ peercert(#sslsocket{pid = Pid}) when is_pid(Pid) -> Result -> Result end; +peercert(#sslsocket{pid = {udp, _}}) -> + {error, enotconn}; peercert(#sslsocket{pid = {Listen, _}}) when is_port(Listen) -> {error, enotconn}. @@ -506,6 +535,8 @@ getstat(#sslsocket{pid = Pid, fd = {Transport, Socket, _, _}}, Options) when is_ shutdown(#sslsocket{pid = {Listen, #config{transport_info = {Transport,_, _, _}}}}, How) when is_port(Listen) -> Transport:shutdown(Listen, How); +shutdown(#sslsocket{pid = {udp,_}},_) -> + {error, enotconn}; shutdown(#sslsocket{pid = Pid}, How) -> ssl_connection:shutdown(Pid, How). @@ -518,7 +549,7 @@ sockname(#sslsocket{pid = {Listen, #config{transport_info = {Transport, _, _, _ tls_socket:sockname(Transport, Listen); sockname(#sslsocket{pid = {udp, #config{udp_handler = {Pid, _}}}}) -> dtls_udp_listener:sockname(Pid); -sockname(#sslsocket{pid = Pid, fd = {gen_udp= Transport, Socket, _, _}}) when is_pid(Pid) -> +sockname(#sslsocket{pid = Pid, fd = {Transport, Socket, _}}) when is_pid(Pid) -> dtls_socket:sockname(Transport, Socket); sockname(#sslsocket{pid = Pid, fd = {Transport, Socket, _, _}}) when is_pid(Pid) -> tls_socket:sockname(Transport, Socket). @@ -531,6 +562,8 @@ sockname(#sslsocket{pid = Pid, fd = {Transport, Socket, _, _}}) when is_pid(Pid) %%-------------------------------------------------------------------- session_info(#sslsocket{pid = Pid}) when is_pid(Pid) -> ssl_connection:session_info(Pid); +session_info(#sslsocket{pid = {udp,_}}) -> + {error, enotconn}; session_info(#sslsocket{pid = {Listen,_}}) when is_port(Listen) -> {error, enotconn}. @@ -555,6 +588,8 @@ versions() -> %%-------------------------------------------------------------------- renegotiate(#sslsocket{pid = Pid}) when is_pid(Pid) -> ssl_connection:renegotiation(Pid); +renegotiate(#sslsocket{pid = {udp,_}}) -> + {error, enotconn}; renegotiate(#sslsocket{pid = {Listen,_}}) when is_port(Listen) -> {error, enotconn}. @@ -568,6 +603,8 @@ renegotiate(#sslsocket{pid = {Listen,_}}) when is_port(Listen) -> prf(#sslsocket{pid = Pid}, Secret, Label, Seed, WantedLength) when is_pid(Pid) -> ssl_connection:prf(Pid, Secret, Label, Seed, WantedLength); +prf(#sslsocket{pid = {udp,_}}, _,_,_,_) -> + {error, enotconn}; prf(#sslsocket{pid = {Listen,_}}, _,_,_,_) when is_port(Listen) -> {error, enotconn}. @@ -696,7 +733,7 @@ handle_options(Opts0, Role) -> [RecordCb:protocol_version(Vsn) || Vsn <- Vsns] end, - Protocol = proplists:get_value(protocol, Opts, tls), + Protocol = handle_option(protocol, Opts, tls), SSLOptions = #ssl_options{ versions = Versions, @@ -755,7 +792,7 @@ handle_options(Opts0, Role) -> honor_ecc_order = handle_option(honor_ecc_order, Opts, default_option_role(server, false, Role), server, Role), - protocol = Protocol, + protocol = Protocol, padding_check = proplists:get_value(padding_check, Opts, true), beast_mitigation = handle_option(beast_mitigation, Opts, one_n_minus_one), fallback = handle_option(fallback, Opts, @@ -1032,6 +1069,10 @@ validate_option(v2_hello_compatible, Value) when is_boolean(Value) -> Value; validate_option(max_handshake_size, Value) when is_integer(Value) andalso Value =< ?MAX_UNIT24 -> Value; +validate_option(protocol, Value = tls) -> + Value; +validate_option(protocol, Value = dtls) -> + Value; validate_option(Opt, Value) -> throw({error, {options, {Opt, Value}}}). @@ -1069,17 +1110,37 @@ validate_binary_list(Opt, List) -> (Bin) -> throw({error, {options, {Opt, {invalid_protocol, Bin}}}}) end, List). - validate_versions([], Versions) -> Versions; validate_versions([Version | Rest], Versions) when Version == 'tlsv1.2'; Version == 'tlsv1.1'; Version == tlsv1; Version == sslv3 -> - validate_versions(Rest, Versions); + tls_validate_versions(Rest, Versions); +validate_versions([Version | Rest], Versions) when Version == 'dtlsv1'; + Version == 'dtlsv2'-> + dtls_validate_versions(Rest, Versions); validate_versions([Ver| _], Versions) -> throw({error, {options, {Ver, {versions, Versions}}}}). +tls_validate_versions([], Versions) -> + Versions; +tls_validate_versions([Version | Rest], Versions) when Version == 'tlsv1.2'; + Version == 'tlsv1.1'; + Version == tlsv1; + Version == sslv3 -> + tls_validate_versions(Rest, Versions); +tls_validate_versions([Ver| _], Versions) -> + throw({error, {options, {Ver, {versions, Versions}}}}). + +dtls_validate_versions([], Versions) -> + Versions; +dtls_validate_versions([Version | Rest], Versions) when Version == 'dtlsv1'; + Version == 'dtlsv2'-> + dtls_validate_versions(Rest, Versions); +dtls_validate_versions([Ver| _], Versions) -> + throw({error, {options, {Ver, {versions, Versions}}}}). + validate_inet_option(mode, Value) when Value =/= list, Value =/= binary -> throw({error, {options, {mode,Value}}}); @@ -1151,18 +1212,18 @@ handle_cipher_option(Value, Version) when is_list(Value) -> binary_cipher_suites(Version, []) -> %% Defaults to all supported suites that does %% not require explicit configuration - ssl_cipher:filter_suites(ssl_cipher:suites(Version)); + ssl_cipher:filter_suites(ssl_cipher:suites(tls_version(Version))); binary_cipher_suites(Version, [Tuple|_] = Ciphers0) when is_tuple(Tuple) -> Ciphers = [ssl_cipher:suite(C) || C <- Ciphers0], binary_cipher_suites(Version, Ciphers); binary_cipher_suites(Version, [Cipher0 | _] = Ciphers0) when is_binary(Cipher0) -> - All = ssl_cipher:all_suites(Version), + All = ssl_cipher:all_suites(tls_version(Version)), case [Cipher || Cipher <- Ciphers0, lists:member(Cipher, All)] of [] -> %% Defaults to all supported suites that does %% not require explicit configuration - ssl_cipher:filter_suites(ssl_cipher:suites(Version)); + ssl_cipher:filter_suites(ssl_cipher:suites(tls_version(Version))); Ciphers -> Ciphers end; @@ -1175,7 +1236,8 @@ binary_cipher_suites(Version, Ciphers0) -> Ciphers = [ssl_cipher:openssl_suite(C) || C <- string:tokens(Ciphers0, ":")], binary_cipher_suites(Version, Ciphers). -handle_eccs_option(Value, {_Major, Minor}) when is_list(Value) -> +handle_eccs_option(Value, Version) when is_list(Value) -> + {_Major, Minor} = tls_version(Version), try tls_v1:ecc_curves(Minor, Value) of Curves -> #elliptic_curves{elliptic_curve_list = Curves} catch @@ -1348,7 +1410,10 @@ new_ssl_options([{signature_algs, Value} | Rest], #ssl_options{} = Opts, RecordC handle_hashsigns_option(Value, tls_version(RecordCB:highest_protocol_version()))}, RecordCB); - +new_ssl_options([{protocol, dtls = Value} | Rest], #ssl_options{} = Opts, dtls_record = RecordCB) -> + new_ssl_options(Rest, Opts#ssl_options{protocol = Value}, RecordCB); +new_ssl_options([{protocol, tls = Value} | Rest], #ssl_options{} = Opts, tls_record = RecordCB) -> + new_ssl_options(Rest, Opts#ssl_options{protocol = Value}, RecordCB); new_ssl_options([{Key, Value} | _Rest], #ssl_options{}, _) -> throw({error, {options, {Key, Value}}}). diff --git a/lib/ssl/src/ssl_cipher.erl b/lib/ssl/src/ssl_cipher.erl index 32fec03b8e..8e6860e9dc 100644 --- a/lib/ssl/src/ssl_cipher.erl +++ b/lib/ssl/src/ssl_cipher.erl @@ -40,7 +40,8 @@ ec_keyed_suites/0, anonymous_suites/1, psk_suites/1, srp_suites/0, rc4_suites/1, des_suites/1, openssl_suite/1, openssl_suite_name/1, filter/2, filter_suites/1, hash_algorithm/1, sign_algorithm/1, is_acceptable_hash/2, is_fallback/1, - random_bytes/1, calc_aad/3, calc_mac_hash/4]). + random_bytes/1, calc_aad/3, calc_mac_hash/4, + is_stream_ciphersuite/1]). -export_type([cipher_suite/0, erl_cipher_suite/0, openssl_cipher_suite/0, @@ -310,18 +311,21 @@ aead_decipher(Type, #cipher_state{key = Key, iv = IV} = CipherState, %%-------------------------------------------------------------------- suites({3, 0}) -> ssl_v3:suites(); -suites({3, N}) -> - tls_v1:suites(N); -suites(Version) -> - suites(dtls_v1:corresponding_tls_version(Version)). +suites({3, Minor}) -> + tls_v1:suites(Minor); +suites({_, Minor}) -> + dtls_v1:suites(Minor). -all_suites(Version) -> +all_suites({3, _} = Version) -> suites(Version) ++ anonymous_suites(Version) ++ psk_suites(Version) ++ srp_suites() ++ rc4_suites(Version) - ++ des_suites(Version). + ++ des_suites(Version); +all_suites(Version) -> + dtls_v1:all_suites(Version). + %%-------------------------------------------------------------------- -spec anonymous_suites(ssl_record:ssl_version() | integer()) -> [cipher_suite()]. %% @@ -1541,6 +1545,10 @@ calc_mac_hash(Type, Version, MacSecret, SeqNo, Type, Length, PlainFragment). +is_stream_ciphersuite({_, rc4_128, _, _}) -> + true; +is_stream_ciphersuite(_) -> + false. %%-------------------------------------------------------------------- %%% Internal functions %%-------------------------------------------------------------------- diff --git a/lib/ssl/src/ssl_connection.erl b/lib/ssl/src/ssl_connection.erl index 4fbac4cad3..ea139ac4b1 100644 --- a/lib/ssl/src/ssl_connection.erl +++ b/lib/ssl/src/ssl_connection.erl @@ -148,19 +148,19 @@ socket_control(Connection, Socket, Pid, Transport) -> %%-------------------------------------------------------------------- socket_control(Connection, Socket, Pid, Transport, udp_listner) -> %% dtls listner process must have the socket control - {ok, dtls_socket:socket(Pid, Transport, Socket, Connection)}; + {ok, Connection:socket(Pid, Transport, Socket, Connection, undefined)}; socket_control(tls_connection = Connection, Socket, Pid, Transport, ListenTracker) -> case Transport:controlling_process(Socket, Pid) of ok -> - {ok, tls_socket:socket(Pid, Transport, Socket, Connection, ListenTracker)}; + {ok, Connection:socket(Pid, Transport, Socket, Connection, ListenTracker)}; {error, Reason} -> {error, Reason} end; socket_control(dtls_connection = Connection, {_, Socket}, Pid, Transport, ListenTracker) -> case Transport:controlling_process(Socket, Pid) of ok -> - {ok, tls_socket:socket(Pid, Transport, Socket, Connection, ListenTracker)}; + {ok, Connection:socket(Pid, Transport, Socket, Connection, ListenTracker)}; {error, Reason} -> {error, Reason} end. @@ -363,11 +363,13 @@ init({call, From}, {start, Timeout}, State0, Connection) -> timer = Timer}), Connection:next_event(hello, Record, State); init({call, From}, {start, {Opts, EmOpts}, Timeout}, - #state{role = Role} = State0, Connection) -> + #state{role = Role, ssl_options = OrigSSLOptions, + socket_options = SockOpts} = State0, Connection) -> try - State = ssl_config(Opts, Role, State0), + SslOpts = ssl:handle_options(Opts, OrigSSLOptions), + State = ssl_config(SslOpts, Role, State0), init({call, From}, {start, Timeout}, - State#state{ssl_options = Opts, socket_options = EmOpts}, Connection) + State#state{ssl_options = SslOpts, socket_options = new_emulated(EmOpts, SockOpts)}, Connection) catch throw:Error -> {stop_and_reply, normal, {reply, From, {error, Error}}} end; @@ -432,11 +434,11 @@ abbreviated(internal, #finished{verify_data = Data} = Finished, verified -> ConnectionStates1 = ssl_record:set_server_verify_data(current_read, Data, ConnectionStates0), - State1 = + {State1, Actions} = finalize_handshake(State0#state{connection_states = ConnectionStates1}, abbreviated, Connection), {Record, State} = prepare_connection(State1#state{expecting_finished = false}, Connection), - Connection:next_event(connection, Record, State); + Connection:next_event(connection, Record, State, Actions); #alert{} = Alert -> handle_own_alert(Alert, Version, abbreviated, State0) end; @@ -856,6 +858,7 @@ handle_common_event(internal, #change_cipher_spec{type = <<1>>}, StateName, StateName, State); handle_common_event(_Type, Msg, StateName, #state{negotiated_version = Version} = State, _) -> + ct:pal("Unexpected msg ~p", [Msg]), Alert = ?ALERT_REC(?FATAL,?UNEXPECTED_MESSAGE), handle_own_alert(Alert, Version, {StateName, Msg}, State). @@ -1017,7 +1020,7 @@ terminate(_, _, #state{terminated = true}) -> %% Happens when user closes the connection using ssl:close/1 %% we want to guarantee that Transport:close has been called %% when ssl:close/1 returns unless it is a downgrade where - %% we want to guarantee that close alert is recived before + %% we want to guarantee that close alert is received before %% returning. In both cases terminate has been run manually %% before run by gen_statem which will end up here ok; @@ -1236,13 +1239,13 @@ new_server_hello(#server_hello{cipher_suite = CipherSuite, negotiated_version = Version} = State0, Connection) -> try server_certify_and_key_exchange(State0, Connection) of #state{} = State1 -> - State2 = server_hello_done(State1, Connection), + {State2, Actions} = server_hello_done(State1, Connection), Session = Session0#session{session_id = SessionId, cipher_suite = CipherSuite, compression_method = Compression}, {Record, State} = Connection:next_record(State2#state{session = Session}), - Connection:next_event(certify, Record, State) + Connection:next_event(certify, Record, State, Actions) catch #alert{} = Alert -> handle_own_alert(Alert, Version, hello, State0) @@ -1257,10 +1260,10 @@ resumed_server_hello(#state{session = Session, {_, ConnectionStates1} -> State1 = State0#state{connection_states = ConnectionStates1, session = Session}, - State2 = + {State2, Actions} = finalize_handshake(State1, abbreviated, Connection), {Record, State} = Connection:next_record(State2), - Connection:next_event(abbreviated, Record, State); + Connection:next_event(abbreviated, Record, State, Actions); #alert{} = Alert -> handle_own_alert(Alert, Version, hello, State0) end. @@ -1343,12 +1346,12 @@ client_certify_and_key_exchange(#state{negotiated_version = Version} = State0, Connection) -> try do_client_certify_and_key_exchange(State0, Connection) of State1 = #state{} -> - State2 = finalize_handshake(State1, certify, Connection), + {State2, Actions} = finalize_handshake(State1, certify, Connection), State3 = State2#state{ %% Reinitialize client_certificate_requested = false}, {Record, State} = Connection:next_record(State3), - Connection:next_event(cipher, Record, State) + Connection:next_event(cipher, Record, State, Actions) catch throw:#alert{} = Alert -> handle_own_alert(Alert, Version, certify, State0) @@ -1870,11 +1873,11 @@ cipher_role(server, Data, Session, #state{connection_states = ConnectionStates0 Connection) -> ConnectionStates1 = ssl_record:set_client_verify_data(current_read, Data, ConnectionStates0), - State1 = + {State1, Actions} = finalize_handshake(State0#state{connection_states = ConnectionStates1, session = Session}, cipher, Connection), {Record, State} = prepare_connection(State1, Connection), - Connection:next_event(connection, Record, State). + Connection:next_event(connection, Record, State, Actions). is_anonymous(Algo) when Algo == dh_anon; Algo == ecdh_anon; @@ -2305,7 +2308,7 @@ format_reply(_, _,#socket_options{active = false, mode = Mode, packet = Packet, {ok, do_format_reply(Mode, Packet, Header, Data)}; format_reply(Transport, Socket, #socket_options{active = _, mode = Mode, packet = Packet, header = Header}, Data, Tracker, Connection) -> - {ssl, tls_socket:socket(self(), Transport, Socket, Connection, Tracker), + {ssl, Connection:socket(self(), Transport, Socket, Connection, Tracker), do_format_reply(Mode, Packet, Header, Data)}. deliver_packet_error(Transport, Socket, SO= #socket_options{active = Active}, Data, Pid, From, Tracker, Connection) -> @@ -2314,7 +2317,7 @@ deliver_packet_error(Transport, Socket, SO= #socket_options{active = Active}, Da format_packet_error(_, _,#socket_options{active = false, mode = Mode}, Data, _, _) -> {error, {invalid_packet, do_format_reply(Mode, raw, 0, Data)}}; format_packet_error(Transport, Socket, #socket_options{active = _, mode = Mode}, Data, Tracker, Connection) -> - {ssl_error, tls_socket:socket(self(), Transport, Socket, Connection, Tracker), + {ssl_error, Connection:socket(self(), Transport, Socket, Connection, Tracker), {invalid_packet, do_format_reply(Mode, raw, 0, Data)}}. do_format_reply(binary, _, N, Data) when N > 0 -> % Header mode @@ -2369,11 +2372,11 @@ alert_user(Transport, Tracker, Socket, Active, Pid, From, Alert, Role, Connectio case ssl_alert:reason_code(Alert, Role) of closed -> send_or_reply(Active, Pid, From, - {ssl_closed, tls_socket:socket(self(), + {ssl_closed, Connection:socket(self(), Transport, Socket, Connection, Tracker)}); ReasonCode -> send_or_reply(Active, Pid, From, - {ssl_error, tls_socket:socket(self(), + {ssl_error, Connection:socket(self(), Transport, Socket, Connection, Tracker), ReasonCode}) end. @@ -2472,3 +2475,8 @@ update_ssl_options_from_sni(OrigSSLOptions, SNIHostname) -> _ -> ssl:handle_options(SSLOption, OrigSSLOptions) end. + +new_emulated([], EmOpts) -> + EmOpts; +new_emulated(NewEmOpts, _) -> + NewEmOpts. diff --git a/lib/ssl/src/ssl_internal.hrl b/lib/ssl/src/ssl_internal.hrl index c34af9f82c..c10ec3a2d6 100644 --- a/lib/ssl/src/ssl_internal.hrl +++ b/lib/ssl/src/ssl_internal.hrl @@ -76,7 +76,7 @@ -define(ALL_SUPPORTED_VERSIONS, ['tlsv1.2', 'tlsv1.1', tlsv1]). -define(MIN_SUPPORTED_VERSIONS, ['tlsv1.1', tlsv1]). -define(ALL_DATAGRAM_SUPPORTED_VERSIONS, ['dtlsv1.2', dtlsv1]). --define(MIN_DATAGRAM_SUPPORTED_VERSIONS, ['dtlsv1.2', dtlsv1]). +-define(MIN_DATAGRAM_SUPPORTED_VERSIONS, [dtlsv1]). -define('24H_in_msec', 86400000). -define('24H_in_sec', 86400). diff --git a/lib/ssl/src/ssl_record.erl b/lib/ssl/src/ssl_record.erl index b10069c3cb..539e189c4f 100644 --- a/lib/ssl/src/ssl_record.erl +++ b/lib/ssl/src/ssl_record.erl @@ -67,7 +67,7 @@ connection_state(). %% %% Description: Returns the instance of the connection_state map -%% that is currently defined as the current conection state. +%% that is currently defined as the current connection state. %%-------------------------------------------------------------------- current_connection_state(ConnectionStates, read) -> maps:get(current_read, ConnectionStates); @@ -79,7 +79,7 @@ current_connection_state(ConnectionStates, write) -> connection_state(). %% %% Description: Returns the instance of the connection_state map -%% that is pendingly defined as the pending conection state. +%% that is pendingly defined as the pending connection state. %%-------------------------------------------------------------------- pending_connection_state(ConnectionStates, read) -> maps:get(pending_read, ConnectionStates); diff --git a/lib/ssl/src/tls_connection.erl b/lib/ssl/src/tls_connection.erl index 77606911be..c6e530e164 100644 --- a/lib/ssl/src/tls_connection.erl +++ b/lib/ssl/src/tls_connection.erl @@ -48,7 +48,7 @@ -export([encode_data/3, encode_alert/3]). %% State transition handling --export([next_record/1, next_event/3]). +-export([next_record/1, next_event/3, next_event/4]). %% Handshake handling -export([renegotiate/2, send_handshake/2, @@ -59,7 +59,8 @@ -export([send_alert/2, close/5]). %% Data handling --export([passive_receive/2, next_record_if_active/1, handle_common_event/4, send/3]). +-export([passive_receive/2, next_record_if_active/1, handle_common_event/4, send/3, + socket/5]). %% gen_statem state functions -export([init/3, error/3, downgrade/3, %% Initiation and take down states @@ -117,7 +118,7 @@ send_handshake_flight(#state{socket = Socket, transport_cb = Transport, flight_buffer = Flight} = State0) -> send(Transport, Socket, Flight), - State0#state{flight_buffer = []}. + {State0#state{flight_buffer = []}, []}. queue_change_cipher(Msg, #state{negotiated_version = Version, flight_buffer = Flight0, @@ -191,6 +192,10 @@ init([Role, Host, Port, Socket, Options, User, CbInfo]) -> callback_mode() -> state_functions. +socket(Pid, Transport, Socket, Connection, Tracker) -> + tls_socket:socket(Pid, Transport, Socket, Connection, Tracker). + + %%-------------------------------------------------------------------- %% State functions %%-------------------------------------------------------------------- @@ -340,12 +345,12 @@ connection(internal, #hello_request{}, renegotiation = {Renegotiation, _}} = State0) -> Hello = tls_handshake:client_hello(Host, Port, ConnectionStates0, SslOpts, Cache, CacheCb, Renegotiation, Cert), - State1 = send_handshake(Hello, State0), + {State1, Actions} = send_handshake(Hello, State0), {Record, State} = next_record( State1#state{session = Session0#session{session_id = Hello#client_hello.session_id}}), - next_event(hello, Record, State); + next_event(hello, Record, State, Actions); connection(internal, #client_hello{} = Hello, #state{role = server, allow_renegotiate = true} = State0) -> %% Mitigate Computational DoS attack diff --git a/lib/ssl/src/tls_handshake.erl b/lib/ssl/src/tls_handshake.erl index 2800ee6537..5726561865 100644 --- a/lib/ssl/src/tls_handshake.erl +++ b/lib/ssl/src/tls_handshake.erl @@ -88,7 +88,7 @@ client_hello(Host, Port, ConnectionStates, #hello_extensions{}, {ssl_cipher:hash(), ssl_cipher:sign_algo()} | undefined} | #alert{}. %% -%% Description: Handles a recieved hello message +%% Description: Handles a received hello message %%-------------------------------------------------------------------- hello(#server_hello{server_version = Version, random = Random, cipher_suite = CipherSuite, @@ -192,7 +192,8 @@ handle_client_hello(Version, #client_hello{session_id = SugesstedId, end. get_tls_handshake_aux(Version, <<?BYTE(Type), ?UINT24(Length), - Body:Length/binary,Rest/binary>>, #ssl_options{v2_hello_compatible = V2Hello} = Opts, Acc) -> + Body:Length/binary,Rest/binary>>, + #ssl_options{v2_hello_compatible = V2Hello} = Opts, Acc) -> Raw = <<?BYTE(Type), ?UINT24(Length), Body/binary>>, try decode_handshake(Version, Type, Body, V2Hello) of Handshake -> @@ -207,27 +208,17 @@ get_tls_handshake_aux(_Version, Data, _, Acc) -> decode_handshake(_, ?HELLO_REQUEST, <<>>, _) -> #hello_request{}; -%% Client hello v2. -%% The server must be able to receive such messages, from clients that -%% are willing to use ssl v3 or higher, but have ssl v2 compatibility. -decode_handshake(_Version, ?CLIENT_HELLO, <<?BYTE(Major), ?BYTE(Minor), - ?UINT16(CSLength), ?UINT16(0), - ?UINT16(CDLength), - CipherSuites:CSLength/binary, - ChallengeData:CDLength/binary>>, true) -> - #client_hello{client_version = {Major, Minor}, - random = ssl_v2:client_random(ChallengeData, CDLength), - session_id = 0, - cipher_suites = ssl_handshake:decode_suites('3_bytes', CipherSuites), - compression_methods = [?NULL], - extensions = #hello_extensions{} - }; -decode_handshake(_Version, ?CLIENT_HELLO, <<?BYTE(_), ?BYTE(_), - ?UINT16(CSLength), ?UINT16(0), - ?UINT16(CDLength), - _CipherSuites:CSLength/binary, - _ChallengeData:CDLength/binary>>, false) -> - throw(?ALERT_REC(?FATAL, ?PROTOCOL_VERSION, ssl_v2_client_hello_no_supported)); +decode_handshake(_Version, ?CLIENT_HELLO, Bin, true) -> + try decode_hello(Bin) of + Hello -> + Hello + catch + _:_ -> + decode_v2_hello(Bin) + end; +decode_handshake(_Version, ?CLIENT_HELLO, Bin, false) -> + decode_hello(Bin); + decode_handshake(_Version, ?CLIENT_HELLO, <<?BYTE(Major), ?BYTE(Minor), Random:32/binary, ?BYTE(SID_length), Session_ID:SID_length/binary, ?UINT16(Cs_length), CipherSuites:Cs_length/binary, @@ -244,10 +235,40 @@ decode_handshake(_Version, ?CLIENT_HELLO, <<?BYTE(Major), ?BYTE(Minor), Random:3 compression_methods = Comp_methods, extensions = DecodedExtensions }; - decode_handshake(Version, Tag, Msg, _) -> ssl_handshake:decode_handshake(Version, Tag, Msg). + +decode_hello(<<?BYTE(Major), ?BYTE(Minor), Random:32/binary, + ?BYTE(SID_length), Session_ID:SID_length/binary, + ?UINT16(Cs_length), CipherSuites:Cs_length/binary, + ?BYTE(Cm_length), Comp_methods:Cm_length/binary, + Extensions/binary>>) -> + DecodedExtensions = ssl_handshake:decode_hello_extensions({client, Extensions}), + + #client_hello{ + client_version = {Major,Minor}, + random = Random, + session_id = Session_ID, + cipher_suites = ssl_handshake:decode_suites('2_bytes', CipherSuites), + compression_methods = Comp_methods, + extensions = DecodedExtensions + }. +%% The server must be able to receive such messages, from clients that +%% are willing to use ssl v3 or higher, but have ssl v2 compatibility. +decode_v2_hello(<<?BYTE(Major), ?BYTE(Minor), + ?UINT16(CSLength), ?UINT16(0), + ?UINT16(CDLength), + CipherSuites:CSLength/binary, + ChallengeData:CDLength/binary>>) -> + #client_hello{client_version = {Major, Minor}, + random = ssl_v2:client_random(ChallengeData, CDLength), + session_id = 0, + cipher_suites = ssl_handshake:decode_suites('3_bytes', CipherSuites), + compression_methods = [?NULL], + extensions = #hello_extensions{} + }. + enc_handshake(#hello_request{}, _Version) -> {?HELLO_REQUEST, <<>>}; enc_handshake(#client_hello{client_version = {Major, Minor}, diff --git a/lib/ssl/src/tls_v1.erl b/lib/ssl/src/tls_v1.erl index 7f24ce5192..f52ee06e71 100644 --- a/lib/ssl/src/tls_v1.erl +++ b/lib/ssl/src/tls_v1.erl @@ -204,21 +204,21 @@ suites(Minor) when Minor == 1; Minor == 2 -> ?TLS_ECDH_RSA_WITH_AES_256_CBC_SHA, ?TLS_RSA_WITH_AES_256_CBC_SHA, - ?TLS_ECDHE_ECDSA_WITH_3DES_EDE_CBC_SHA, - ?TLS_ECDHE_RSA_WITH_3DES_EDE_CBC_SHA, - ?TLS_DHE_RSA_WITH_3DES_EDE_CBC_SHA, - ?TLS_DHE_DSS_WITH_3DES_EDE_CBC_SHA, - ?TLS_ECDH_ECDSA_WITH_3DES_EDE_CBC_SHA, - ?TLS_ECDH_RSA_WITH_3DES_EDE_CBC_SHA, - ?TLS_RSA_WITH_3DES_EDE_CBC_SHA, - ?TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA, ?TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA, ?TLS_DHE_RSA_WITH_AES_128_CBC_SHA, ?TLS_DHE_DSS_WITH_AES_128_CBC_SHA, ?TLS_ECDH_ECDSA_WITH_AES_128_CBC_SHA, ?TLS_ECDH_RSA_WITH_AES_128_CBC_SHA, - ?TLS_RSA_WITH_AES_128_CBC_SHA + ?TLS_RSA_WITH_AES_128_CBC_SHA, + + ?TLS_ECDHE_ECDSA_WITH_3DES_EDE_CBC_SHA, + ?TLS_ECDHE_RSA_WITH_3DES_EDE_CBC_SHA, + ?TLS_DHE_RSA_WITH_3DES_EDE_CBC_SHA, + ?TLS_DHE_DSS_WITH_3DES_EDE_CBC_SHA, + ?TLS_ECDH_ECDSA_WITH_3DES_EDE_CBC_SHA, + ?TLS_ECDH_RSA_WITH_3DES_EDE_CBC_SHA, + ?TLS_RSA_WITH_3DES_EDE_CBC_SHA ]; suites(3) -> [ @@ -407,7 +407,7 @@ is_pair(Hash, rsa, Hashs) -> AtLeastMd5 = Hashs -- [md2,md4], lists:member(Hash, AtLeastMd5). -%% list ECC curves in prefered order +%% list ECC curves in preferred order -spec ecc_curves(1..3 | all) -> [named_curve()]. ecc_curves(all) -> [sect571r1,sect571k1,secp521r1,brainpoolP512r1, diff --git a/lib/ssl/test/ssl_basic_SUITE.erl b/lib/ssl/test/ssl_basic_SUITE.erl index f0a3c42e8d..bff6d254f1 100644 --- a/lib/ssl/test/ssl_basic_SUITE.erl +++ b/lib/ssl/test/ssl_basic_SUITE.erl @@ -53,7 +53,8 @@ all() -> {group, options_tls}, {group, session}, {group, 'dtlsv1.2'}, - %%{group, 'dtlsv1'}, + %% {group, 'dtlsv1'}, Breaks dtls in cert_verify_SUITE enable later when + %% problem is identified and fixed {group, 'tlsv1.2'}, {group, 'tlsv1.1'}, {group, 'tlsv1'}, @@ -65,15 +66,15 @@ groups() -> {basic_tls, [], basic_tests_tls()}, {options, [], options_tests()}, {options_tls, [], options_tests_tls()}, - %%{'dtlsv1.2', [], all_versions_groups()}, - {'dtlsv1.2', [], [connection_information]}, - %%{'dtlsv1', [], all_versions_groups()}, + {'dtlsv1.2', [], all_versions_groups()}, + {'dtlsv1', [], all_versions_groups()}, {'tlsv1.2', [], all_versions_groups() ++ tls_versions_groups() ++ [conf_signature_algs, no_common_signature_algs]}, {'tlsv1.1', [], all_versions_groups() ++ tls_versions_groups()}, {'tlsv1', [], all_versions_groups() ++ tls_versions_groups() ++ rizzo_tests()}, {'sslv3', [], all_versions_groups() ++ tls_versions_groups() ++ rizzo_tests() ++ [tls_ciphersuite_vs_version]}, {api,[], api_tests()}, {api_tls,[], api_tests_tls()}, + {tls_ciphers,[], tls_cipher_tests()}, {session, [], session_tests()}, {renegotiate, [], renegotiate_tests()}, {ciphers, [], cipher_tests()}, @@ -83,12 +84,13 @@ groups() -> ]. tls_versions_groups ()-> - [{group, api_tls}, + [{group, renegotiate}, %% Should be in all_versions_groups not fixed for DTLS yet + {group, api_tls}, + {group, tls_ciphers}, {group, error_handling_tests_tls}]. all_versions_groups ()-> [{group, api}, - {group, renegotiate}, {group, ciphers}, {group, ciphers_ec}, {group, error_handling_tests}]. @@ -147,10 +149,8 @@ options_tests_tls() -> api_tests() -> [connection_info, connection_information, - peername, peercert, peercert_with_client_cert, - sockname, versions, eccs, controlling_process, @@ -162,7 +162,6 @@ api_tests() -> ssl_recv_timeout, server_name_indication_option, accept_pool, - new_options_in_accept, prf ]. @@ -175,7 +174,10 @@ api_tests_tls() -> tls_shutdown, tls_shutdown_write, tls_shutdown_both, - tls_shutdown_error + tls_shutdown_error, + peername, + sockname, + new_options_in_accept ]. session_tests() -> @@ -197,6 +199,11 @@ renegotiate_tests() -> renegotiate_dos_mitigate_passive, renegotiate_dos_mitigate_absolute]. +tls_cipher_tests() -> + [rc4_rsa_cipher_suites, + rc4_ecdh_rsa_cipher_suites, + rc4_ecdsa_cipher_suites]. + cipher_tests() -> [cipher_suites, cipher_suites_mix, @@ -212,9 +219,6 @@ cipher_tests() -> srp_cipher_suites, srp_anon_cipher_suites, srp_dsa_cipher_suites, - rc4_rsa_cipher_suites, - rc4_ecdh_rsa_cipher_suites, - rc4_ecdsa_cipher_suites, des_rsa_cipher_suites, des_ecdh_rsa_cipher_suites, default_reject_anonymous]. @@ -226,15 +230,15 @@ cipher_tests_ec() -> ciphers_ecdh_rsa_signed_certs_openssl_names]. error_handling_tests()-> - [controller_dies, - close_transport_accept, + [close_transport_accept, recv_active, recv_active_once, recv_error_handling ]. error_handling_tests_tls()-> - [tls_client_closes_socket, + [controller_dies, + tls_client_closes_socket, tls_tcp_error_propagation_in_active_mode, tls_tcp_connect, tls_tcp_connect_big, @@ -843,8 +847,7 @@ controller_dies(Config) when is_list(Config) -> Server ! listen, Tester = self(), Connect = fun(Pid) -> - {ok, Socket} = ssl:connect(Hostname, Port, - [{reuseaddr,true},{ssl_imp,new}]), + {ok, Socket} = ssl:connect(Hostname, Port, ClientOpts), %% Make sure server finishes and verification %% and is in coonection state before %% killing client @@ -2194,8 +2197,9 @@ ciphers_dsa_signed_certs() -> [{doc,"Test all dsa ssl cipher suites in highest support ssl/tls version"}]. ciphers_dsa_signed_certs(Config) when is_list(Config) -> + NVersion = ssl_test_lib:protocol_version(Config, tuple), Version = ssl_test_lib:protocol_version(Config), - Ciphers = ssl_test_lib:dsa_suites(tls_record:protocol_version(Version)), + Ciphers = ssl_test_lib:dsa_suites(NVersion), ct:log("~p erlang cipher suites ~p~n", [Version, Ciphers]), run_suites(Ciphers, Version, Config, dsa). %%------------------------------------------------------------------- @@ -2218,29 +2222,33 @@ anonymous_cipher_suites(Config) when is_list(Config) -> psk_cipher_suites() -> [{doc, "Test the PSK ciphersuites WITHOUT server supplied identity hint"}]. psk_cipher_suites(Config) when is_list(Config) -> + NVersion = tls_record:highest_protocol_version([]), Version = ssl_test_lib:protocol_version(Config), - Ciphers = ssl_test_lib:psk_suites(), + Ciphers = ssl_test_lib:psk_suites(NVersion), run_suites(Ciphers, Version, Config, psk). %%------------------------------------------------------------------- psk_with_hint_cipher_suites()-> [{doc, "Test the PSK ciphersuites WITH server supplied identity hint"}]. psk_with_hint_cipher_suites(Config) when is_list(Config) -> + NVersion = tls_record:highest_protocol_version([]), Version = ssl_test_lib:protocol_version(Config), - Ciphers = ssl_test_lib:psk_suites(), + Ciphers = ssl_test_lib:psk_suites(NVersion), run_suites(Ciphers, Version, Config, psk_with_hint). %%------------------------------------------------------------------- psk_anon_cipher_suites() -> [{doc, "Test the anonymous PSK ciphersuites WITHOUT server supplied identity hint"}]. psk_anon_cipher_suites(Config) when is_list(Config) -> + NVersion = tls_record:highest_protocol_version([]), Version = ssl_test_lib:protocol_version(Config), - Ciphers = ssl_test_lib:psk_anon_suites(), + Ciphers = ssl_test_lib:psk_anon_suites(NVersion), run_suites(Ciphers, Version, Config, psk_anon). %%------------------------------------------------------------------- psk_anon_with_hint_cipher_suites()-> [{doc, "Test the anonymous PSK ciphersuites WITH server supplied identity hint"}]. psk_anon_with_hint_cipher_suites(Config) when is_list(Config) -> + NVersion = tls_record:highest_protocol_version([]), Version = ssl_test_lib:protocol_version(Config), - Ciphers = ssl_test_lib:psk_anon_suites(), + Ciphers = ssl_test_lib:psk_anon_suites(NVersion), run_suites(Ciphers, Version, Config, psk_anon_with_hint). %%------------------------------------------------------------------- srp_cipher_suites()-> @@ -2291,18 +2299,17 @@ rc4_ecdsa_cipher_suites(Config) when is_list(Config) -> %%------------------------------------------------------------------- des_rsa_cipher_suites()-> - [{doc, "Test the RC4 ciphersuites"}]. + [{doc, "Test the des_rsa ciphersuites"}]. des_rsa_cipher_suites(Config) when is_list(Config) -> - NVersion = tls_record:highest_protocol_version([]), - Version = tls_record:protocol_version(NVersion), - Ciphers = ssl_test_lib:des_suites(NVersion), + Version = ssl_test_lib:protocol_version(Config), + Ciphers = ssl_test_lib:des_suites(Config), run_suites(Ciphers, Version, Config, des_rsa). %------------------------------------------------------------------- des_ecdh_rsa_cipher_suites()-> - [{doc, "Test the RC4 ciphersuites"}]. + [{doc, "Test ECDH rsa signed ciphersuites"}]. des_ecdh_rsa_cipher_suites(Config) when is_list(Config) -> - NVersion = tls_record:highest_protocol_version([]), - Version = tls_record:protocol_version(NVersion), + NVersion = ssl_test_lib:protocol_version(Config, tuple), + Version = ssl_test_lib:protocol_version(Config), Ciphers = ssl_test_lib:des_suites(NVersion), run_suites(Ciphers, Version, Config, des_dhe_rsa). @@ -2313,9 +2320,11 @@ default_reject_anonymous(Config) when is_list(Config) -> {ClientNode, ServerNode, Hostname} = ssl_test_lib:run_where(Config), ClientOpts = ssl_test_lib:ssl_options(client_opts, Config), ServerOpts = ssl_test_lib:ssl_options(server_opts, Config), - Version = tls_record:highest_protocol_version(tls_record:supported_protocol_versions()), - [CipherSuite | _] = ssl_test_lib:anonymous_suites(Version), - + Version = ssl_test_lib:protocol_version(Config), + TLSVersion = ssl_test_lib:tls_version(Version), + + [CipherSuite | _] = ssl_test_lib:anonymous_suites(TLSVersion), + Server = ssl_test_lib:start_server_error([{node, ServerNode}, {port, 0}, {from, self()}, {options, ServerOpts}]), @@ -2335,8 +2344,9 @@ ciphers_ecdsa_signed_certs() -> [{doc, "Test all ecdsa ssl cipher suites in highest support ssl/tls version"}]. ciphers_ecdsa_signed_certs(Config) when is_list(Config) -> + NVersion = ssl_test_lib:protocol_version(Config, tuple), Version = ssl_test_lib:protocol_version(Config), - Ciphers = ssl_test_lib:ecdsa_suites(tls_record:protocol_version(Version)), + Ciphers = ssl_test_lib:ecdsa_suites(NVersion), ct:log("~p erlang cipher suites ~p~n", [Version, Ciphers]), run_suites(Ciphers, Version, Config, ecdsa). %%-------------------------------------------------------------------- @@ -2353,8 +2363,9 @@ ciphers_ecdh_rsa_signed_certs() -> [{doc, "Test all ecdh_rsa ssl cipher suites in highest support ssl/tls version"}]. ciphers_ecdh_rsa_signed_certs(Config) when is_list(Config) -> + NVersion = ssl_test_lib:protocol_version(Config, tuple), Version = ssl_test_lib:protocol_version(Config), - Ciphers = ssl_test_lib:ecdh_rsa_suites(tls_record:protocol_version(Version)), + Ciphers = ssl_test_lib:ecdh_rsa_suites(NVersion), ct:log("~p erlang cipher suites ~p~n", [Version, Ciphers]), run_suites(Ciphers, Version, Config, ecdh_rsa). %%-------------------------------------------------------------------- @@ -3326,11 +3337,11 @@ hibernate(Config) -> process_info(Pid, current_function), ssl_test_lib:check_result(Server, ok, Client, ok), - timer:sleep(1100), - + + timer:sleep(1500), {current_function, {erlang, hibernate, 3}} = process_info(Pid, current_function), - + ssl_test_lib:close(Server), ssl_test_lib:close(Client). @@ -3363,13 +3374,12 @@ hibernate_right_away(Config) -> [{port, Port1}, {options, [{hibernate_after, 0}|ClientOpts]}]), ssl_test_lib:check_result(Server1, ok, Client1, ok), - - {current_function, {erlang, hibernate, 3}} = + + {current_function, {erlang, hibernate, 3}} = process_info(Pid1, current_function), - ssl_test_lib:close(Server1), ssl_test_lib:close(Client1), - + Server2 = ssl_test_lib:start_server(StartServerOpts), Port2 = ssl_test_lib:inet_port(Server2), {Client2, #sslsocket{pid = Pid2}} = ssl_test_lib:start_client(StartClientOpts ++ @@ -3377,8 +3387,8 @@ hibernate_right_away(Config) -> ssl_test_lib:check_result(Server2, ok, Client2, ok), - ct:sleep(100), %% Schedule out - + ct:sleep(1000), %% Schedule out + {current_function, {erlang, hibernate, 3}} = process_info(Pid2, current_function), @@ -4507,16 +4517,21 @@ run_suites(Ciphers, Version, Config, Type) -> [{reuseaddr, true}, {ciphers, ssl_test_lib:anonymous_suites(Version)}]}; psk -> {ssl_test_lib:ssl_options(client_psk, Config), - ssl_test_lib:ssl_options(server_psk, Config)}; + [{ciphers, ssl_test_lib:psk_suites(Version)} | + ssl_test_lib:ssl_options(server_psk, Config)]}; psk_with_hint -> {ssl_test_lib:ssl_options(client_psk, Config), - ssl_test_lib:ssl_options(server_psk_hint, Config)}; + [{ciphers, ssl_test_lib:psk_suites(Version)} | + ssl_test_lib:ssl_options(server_psk_hint, Config) + ]}; psk_anon -> {ssl_test_lib:ssl_options(client_psk, Config), - ssl_test_lib:ssl_options(server_psk_anon, Config)}; + [{ciphers, ssl_test_lib:psk_anon_suites(Version)} | + ssl_test_lib:ssl_options(server_psk_anon, Config)]}; psk_anon_with_hint -> {ssl_test_lib:ssl_options(client_psk, Config), - ssl_test_lib:ssl_options(server_psk_anon_hint, Config)}; + [{ciphers, ssl_test_lib:psk_anon_suites(Version)} | + ssl_test_lib:ssl_options(server_psk_anon_hint, Config)]}; srp -> {ssl_test_lib:ssl_options(client_srp, Config), ssl_test_lib:ssl_options(server_srp, Config)}; @@ -4556,7 +4571,7 @@ run_suites(Ciphers, Version, Config, Type) -> Result = lists:map(fun(Cipher) -> cipher(Cipher, Version, Config, ClientOpts, ServerOpts) end, - ssl_test_lib:filter_suites(Ciphers)), + ssl_test_lib:filter_suites(Ciphers, Version)), case lists:flatten(Result) of [] -> ok; diff --git a/lib/ssl/test/ssl_certificate_verify_SUITE.erl b/lib/ssl/test/ssl_certificate_verify_SUITE.erl index 5265c87e29..4552a4f57d 100644 --- a/lib/ssl/test/ssl_certificate_verify_SUITE.erl +++ b/lib/ssl/test/ssl_certificate_verify_SUITE.erl @@ -39,17 +39,26 @@ %% Common Test interface functions ----------------------------------- %%-------------------------------------------------------------------- all() -> - [{group, active}, - {group, passive}, - {group, active_once}, - {group, error_handling}]. - + [ + {group, tls}, + {group, dtls} + ]. groups() -> - [{active, [], tests()}, + [ + {tls, [], all_protocol_groups()}, + {dtls, [], all_protocol_groups()}, + {active, [], tests()}, {active_once, [], tests()}, {passive, [], tests()}, - {error_handling, [],error_handling_tests()}]. + {error_handling, [],error_handling_tests()} + ]. + +all_protocol_groups() -> + [{group, active}, + {group, passive}, + {group, active_once}, + {group, error_handling}]. tests() -> [verify_peer, @@ -85,7 +94,7 @@ init_per_suite(Config0) -> catch crypto:stop(), try crypto:start() of ok -> - ssl_test_lib:clean_start(), + ssl_test_lib:clean_start(), %% make rsa certs using oppenssl {ok, _} = make_certs:all(proplists:get_value(data_dir, Config0), proplists:get_value(priv_dir, Config0)), @@ -99,6 +108,26 @@ end_per_suite(_Config) -> ssl:stop(), application:stop(crypto). +init_per_group(tls, Config) -> + Version = tls_record:protocol_version(tls_record:highest_protocol_version([])), + ssl:stop(), + application:load(ssl), + application:set_env(ssl, protocol_version, Version), + application:set_env(ssl, bypass_pem_cache, Version), + ssl:start(), + NewConfig = proplists:delete(protocol, Config), + [{protocol, tls}, {version, tls_record:protocol_version(Version)} | NewConfig]; + +init_per_group(dtls, Config) -> + Version = dtls_record:protocol_version(dtls_record:highest_protocol_version([])), + ssl:stop(), + application:load(ssl), + application:set_env(ssl, protocol_version, Version), + application:set_env(ssl, bypass_pem_cache, Version), + ssl:start(), + NewConfig = proplists:delete(protocol_opts, proplists:delete(protocol, Config)), + [{protocol, dtls}, {protocol_opts, [{protocol, dtls}]}, {version, dtls_record:protocol_version(Version)} | NewConfig]; + init_per_group(active, Config) -> [{active, true}, {receive_function, send_recv_result_active} | Config]; init_per_group(active_once, Config) -> @@ -262,7 +291,7 @@ server_require_peer_cert_fail() -> server_require_peer_cert_fail(Config) when is_list(Config) -> ServerOpts = [{verify, verify_peer}, {fail_if_no_peer_cert, true} | ssl_test_lib:ssl_options(server_verification_opts, Config)], - BadClientOpts = ssl_test_lib:ssl_options(client_opts, []), + BadClientOpts = ssl_test_lib:ssl_options(empty_client_opts, Config), {ClientNode, ServerNode, Hostname} = ssl_test_lib:run_where(Config), Server = ssl_test_lib:start_server_error([{node, ServerNode}, {port, 0}, @@ -411,7 +440,7 @@ server_require_peer_cert_partial_chain_fun_fail() -> server_require_peer_cert_partial_chain_fun_fail(Config) when is_list(Config) -> ServerOpts = [{verify, verify_peer}, {fail_if_no_peer_cert, true} | ssl_test_lib:ssl_options(server_verification_opts, Config)], - ClientOpts = proplists:get_value(client_opts, Config), + ClientOpts = ssl_test_lib:ssl_options(client_opts, Config), {ClientNode, ServerNode, Hostname} = ssl_test_lib:run_where(Config), {ok, ServerCAs} = file:read_file(proplists:get_value(cacertfile, ServerOpts)), @@ -1091,6 +1120,7 @@ client_with_cert_cipher_suites_handshake() -> client_with_cert_cipher_suites_handshake(Config) when is_list(Config) -> ClientOpts = ssl_test_lib:ssl_options(client_verification_opts_digital_signature_only, Config), ServerOpts = ssl_test_lib:ssl_options(server_verification_opts, Config), + {ClientNode, ServerNode, Hostname} = ssl_test_lib:run_where(Config), Server = ssl_test_lib:start_server([{node, ServerNode}, {port, 0}, {from, self()}, @@ -1098,7 +1128,7 @@ client_with_cert_cipher_suites_handshake(Config) when is_list(Config) -> send_recv_result_active, []}}, {options, [{active, true}, {ciphers, - ssl_test_lib:rsa_non_signed_suites(tls_record:highest_protocol_version([]))} + ssl_test_lib:rsa_non_signed_suites(proplists:get_value(version, Config))} | ServerOpts]}]), Port = ssl_test_lib:inet_port(Server), Client = ssl_test_lib:start_client([{node, ClientNode}, {port, Port}, @@ -1132,7 +1162,7 @@ server_verify_no_cacerts(Config) when is_list(Config) -> unknown_server_ca_fail() -> [{doc,"Test that the client fails if the ca is unknown in verify_peer mode"}]. unknown_server_ca_fail(Config) when is_list(Config) -> - ClientOpts = ssl_test_lib:ssl_options(client_opts, []), + ClientOpts = ssl_test_lib:ssl_options(empty_client_opts, Config), ServerOpts = ssl_test_lib:ssl_options(server_verification_opts, Config), {ClientNode, ServerNode, Hostname} = ssl_test_lib:run_where(Config), Server = ssl_test_lib:start_server_error([{node, ServerNode}, {port, 0}, @@ -1176,7 +1206,7 @@ unknown_server_ca_fail(Config) when is_list(Config) -> unknown_server_ca_accept_verify_none() -> [{doc,"Test that the client succeds if the ca is unknown in verify_none mode"}]. unknown_server_ca_accept_verify_none(Config) when is_list(Config) -> - ClientOpts = ssl_test_lib:ssl_options(client_opts, []), + ClientOpts = ssl_test_lib:ssl_options(empty_client_opts, Config), ServerOpts = ssl_test_lib:ssl_options(server_verification_opts, Config), {ClientNode, ServerNode, Hostname} = ssl_test_lib:run_where(Config), Server = ssl_test_lib:start_server([{node, ServerNode}, {port, 0}, @@ -1201,8 +1231,8 @@ unknown_server_ca_accept_verify_peer() -> [{doc, "Test that the client succeds if the ca is unknown in verify_peer mode" " with a verify_fun that accepts the unknown ca error"}]. unknown_server_ca_accept_verify_peer(Config) when is_list(Config) -> - ClientOpts =ssl_test_lib:ssl_options(client_opts, []), - ServerOpts = ssl_test_lib:ssl_options(server_verification_opts, Config), + ClientOpts = ssl_test_lib:ssl_options(empty_client_opts, Config), + ServerOpts = ssl_test_lib:ssl_options(server_verification_opts, Config), {ClientNode, ServerNode, Hostname} = ssl_test_lib:run_where(Config), Server = ssl_test_lib:start_server([{node, ServerNode}, {port, 0}, {from, self()}, @@ -1240,7 +1270,7 @@ unknown_server_ca_accept_verify_peer(Config) when is_list(Config) -> unknown_server_ca_accept_backwardscompatibility() -> [{doc,"Test that old style verify_funs will work"}]. unknown_server_ca_accept_backwardscompatibility(Config) when is_list(Config) -> - ClientOpts = ssl_test_lib:ssl_options(client_opts, []), + ClientOpts = ssl_test_lib:ssl_options(empty_client_opts, Config), ServerOpts = ssl_test_lib:ssl_options(server_verification_opts, Config), {ClientNode, ServerNode, Hostname} = ssl_test_lib:run_where(Config), Server = ssl_test_lib:start_server([{node, ServerNode}, {port, 0}, diff --git a/lib/ssl/test/ssl_handshake_SUITE.erl b/lib/ssl/test/ssl_handshake_SUITE.erl index 74b14145dd..0a50c98a28 100644 --- a/lib/ssl/test/ssl_handshake_SUITE.erl +++ b/lib/ssl/test/ssl_handshake_SUITE.erl @@ -33,6 +33,7 @@ %% Common Test interface functions ----------------------------------- %%-------------------------------------------------------------------- all() -> [decode_hello_handshake, + decode_hello_handshake_version_confusion, decode_single_hello_extension_correctly, decode_supported_elliptic_curves_hello_extension_correctly, decode_unknown_hello_extension_correctly, @@ -106,6 +107,14 @@ decode_hello_handshake(_Config) -> #renegotiation_info{renegotiated_connection = <<0>>} = (Hello#server_hello.extensions)#hello_extensions.renegotiation_info. + +decode_hello_handshake_version_confusion(_) -> + HelloPacket = <<3,3,0,0,0,0,0,63,210,235,149,6,244,140,108,13,177,74,16,218,33,108,219,41,73,228,3,82,132,123,73,144,118,100,0,0,32,192,4,0,10,192,45,192,38,0,47,192,18,0,163,0,22,0,165,192,29,192,18,192,30,0,103,0,57,192,48,0,47,1,0>>, + Version = {3,3}, + ClientHello = 1, + Hello = tls_handshake:decode_handshake({3,3}, ClientHello, HelloPacket, false), + Hello = tls_handshake:decode_handshake({3,3}, ClientHello, HelloPacket, true). + decode_single_hello_extension_correctly(_Config) -> Renegotiation = <<?UINT16(?RENEGOTIATION_EXT), ?UINT16(1), 0>>, Extensions = ssl_handshake:decode_hello_extensions(Renegotiation), diff --git a/lib/ssl/test/ssl_npn_hello_SUITE.erl b/lib/ssl/test/ssl_npn_hello_SUITE.erl index 69aeea10c5..0b1de1dc1c 100644 --- a/lib/ssl/test/ssl_npn_hello_SUITE.erl +++ b/lib/ssl/test/ssl_npn_hello_SUITE.erl @@ -50,6 +50,10 @@ init_per_suite(Config) -> {skip, "Crypto did not start"} end. +end_per_suite(_Config) -> + %% This function is required since init_per_suite/1 exists. + ok. + init_per_testcase(_TestCase, Config) -> ssl_test_lib:ct_log_supported_protocol_versions(Config), ct:timetrap({seconds, 5}), diff --git a/lib/ssl/test/ssl_test_lib.erl b/lib/ssl/test/ssl_test_lib.erl index 9632103696..7a644968f2 100644 --- a/lib/ssl/test/ssl_test_lib.erl +++ b/lib/ssl/test/ssl_test_lib.erl @@ -278,8 +278,11 @@ check_result(Server, ServerMsg, Client, ClientMsg) -> check_result(Server, ServerMsg); {Port, {data,Debug}} when is_port(Port) -> - ct:log("~p:~p~nopenssl ~s~n",[?MODULE,?LINE, Debug]), + ct:log("~p:~p~n Openssl ~s~n",[?MODULE,?LINE, Debug]), check_result(Server, ServerMsg, Client, ClientMsg); + {Port,closed} when is_port(Port) -> + ct:log("~p:~p~n Openssl port ~n",[?MODULE,?LINE]), + check_result(Server, ServerMsg, Client, ClientMsg); Unexpected -> Reason = {{expected, {Client, ClientMsg}}, {expected, {Server, ServerMsg}}, {got, Unexpected}}, @@ -291,11 +294,11 @@ check_result(Pid, Msg) -> {Pid, Msg} -> ok; {Port, {data,Debug}} when is_port(Port) -> - ct:log("~p:~p~nopenssl ~s~n",[?MODULE,?LINE, Debug]), + ct:log("~p:~p~n Openssl ~s~n",[?MODULE,?LINE, Debug]), check_result(Pid,Msg); - %% {Port, {exit_status, Status}} when is_port(Port) -> - %% ct:log("~p:~p Exit status: ~p~n",[?MODULE,?LINE, Status]), - %% check_result(Pid, Msg); + {Port,closed} when is_port(Port)-> + ct:log("~p:~p Openssl port closed ~n",[?MODULE,?LINE]), + check_result(Pid, Msg); Unexpected -> Reason = {{expected, {Pid, Msg}}, {got, Unexpected}}, @@ -398,27 +401,22 @@ cert_options(Config) -> {ssl_imp, new}]}, {server_opts, [{ssl_imp, new},{reuseaddr, true}, {cacertfile, ServerCaCertFile}, {certfile, ServerCertFile}, {keyfile, ServerKeyFile}]}, - %%{server_anon, [{ssl_imp, new},{reuseaddr, true}, {ciphers, anonymous_suites()}]}, - {client_psk, [{ssl_imp, new},{reuseaddr, true}, + {client_psk, [{ssl_imp, new}, {psk_identity, "Test-User"}, {user_lookup_fun, {fun user_lookup/3, PskSharedSecret}}]}, {server_psk, [{ssl_imp, new},{reuseaddr, true}, {certfile, ServerCertFile}, {keyfile, ServerKeyFile}, - {user_lookup_fun, {fun user_lookup/3, PskSharedSecret}}, - {ciphers, psk_suites()}]}, + {user_lookup_fun, {fun user_lookup/3, PskSharedSecret}}]}, {server_psk_hint, [{ssl_imp, new},{reuseaddr, true}, {certfile, ServerCertFile}, {keyfile, ServerKeyFile}, {psk_identity, "HINT"}, - {user_lookup_fun, {fun user_lookup/3, PskSharedSecret}}, - {ciphers, psk_suites()}]}, + {user_lookup_fun, {fun user_lookup/3, PskSharedSecret}}]}, {server_psk_anon, [{ssl_imp, new},{reuseaddr, true}, - {user_lookup_fun, {fun user_lookup/3, PskSharedSecret}}, - {ciphers, psk_anon_suites()}]}, + {user_lookup_fun, {fun user_lookup/3, PskSharedSecret}}]}, {server_psk_anon_hint, [{ssl_imp, new},{reuseaddr, true}, {psk_identity, "HINT"}, - {user_lookup_fun, {fun user_lookup/3, PskSharedSecret}}, - {ciphers, psk_anon_suites()}]}, - {client_srp, [{ssl_imp, new},{reuseaddr, true}, + {user_lookup_fun, {fun user_lookup/3, PskSharedSecret}}]}, + {client_srp, [{ssl_imp, new}, {srp_identity, {"Test-User", "secret"}}]}, {server_srp, [{ssl_imp, new},{reuseaddr, true}, {certfile, ServerCertFile}, {keyfile, ServerKeyFile}, @@ -473,7 +471,7 @@ make_dsa_cert(Config) -> {cacertfile, ClientCaCertFile}, {certfile, ServerCertFile}, {keyfile, ServerKeyFile}, {verify, verify_peer}]}, - {client_dsa_opts, [{ssl_imp, new},{reuseaddr, true}, + {client_dsa_opts, [{ssl_imp, new}, {cacertfile, ClientCaCertFile}, {certfile, ClientCertFile}, {keyfile, ClientKeyFile}]}, {server_srp_dsa, [{ssl_imp, new},{reuseaddr, true}, @@ -481,7 +479,7 @@ make_dsa_cert(Config) -> {certfile, ServerCertFile}, {keyfile, ServerKeyFile}, {user_lookup_fun, {fun user_lookup/3, undefined}}, {ciphers, srp_dss_suites()}]}, - {client_srp_dsa, [{ssl_imp, new},{reuseaddr, true}, + {client_srp_dsa, [{ssl_imp, new}, {srp_identity, {"Test-User", "secret"}}, {cacertfile, ClientCaCertFile}, {certfile, ClientCertFile}, {keyfile, ClientKeyFile}]} @@ -502,7 +500,7 @@ make_ecdsa_cert(Config) -> {cacertfile, ClientCaCertFile}, {certfile, ServerCertFile}, {keyfile, ServerKeyFile}, {verify, verify_peer}]}, - {client_ecdsa_opts, [{ssl_imp, new},{reuseaddr, true}, + {client_ecdsa_opts, [{ssl_imp, new}, {cacertfile, ClientCaCertFile}, {certfile, ClientCertFile}, {keyfile, ClientKeyFile}]} | Config]; @@ -537,7 +535,7 @@ make_ecdh_rsa_cert(Config) -> {cacertfile, ClientCaCertFile}, {certfile, ServerCertFile}, {keyfile, ServerKeyFile}, {verify, verify_peer}]}, - {client_ecdh_rsa_opts, [{ssl_imp, new},{reuseaddr, true}, + {client_ecdh_rsa_opts, [{ssl_imp, new}, {cacertfile, ClientCaCertFile}, {certfile, ClientCertFile}, {keyfile, ClientKeyFile}]} | Config]; @@ -557,7 +555,7 @@ make_mix_cert(Config) -> {cacertfile, ClientCaCertFile}, {certfile, ServerCertFile}, {keyfile, ServerKeyFile}, {verify, verify_peer}]}, - {client_mix_opts, [{ssl_imp, new},{reuseaddr, true}, + {client_mix_opts, [{ssl_imp, new}, {cacertfile, ClientCaCertFile}, {certfile, ClientCertFile}, {keyfile, ClientKeyFile}]} | Config]. @@ -827,17 +825,17 @@ rsa_suites(CounterPart) -> ({dhe_rsa, des_cbc, sha}) when FIPS == true -> false; ({rsa, Cipher, _}) -> - lists:member(Cipher, Ciphers); + lists:member(cipher_atom(Cipher), Ciphers); ({dhe_rsa, Cipher, _}) -> - lists:member(Cipher, Ciphers); + lists:member(cipher_atom(Cipher), Ciphers); ({ecdhe_rsa, Cipher, _}) when ECC == true -> - lists:member(Cipher, Ciphers); + lists:member(cipher_atom(Cipher), Ciphers); ({rsa, Cipher, _, _}) -> - lists:member(Cipher, Ciphers); + lists:member(cipher_atom(Cipher), Ciphers); ({dhe_rsa, Cipher, _,_}) -> - lists:member(Cipher, Ciphers); + lists:member(cipher_atom(Cipher), Ciphers); ({ecdhe_rsa, Cipher, _,_}) when ECC == true -> - lists:member(Cipher, Ciphers); + lists:member(cipher_atom(Cipher), Ciphers); (_) -> false end, @@ -930,44 +928,12 @@ anonymous_suites(Version) -> Suites = ssl_cipher:anonymous_suites(Version), ssl_cipher:filter_suites(Suites). -psk_suites() -> - Suites = - [{psk, rc4_128, sha}, - {psk, '3des_ede_cbc', sha}, - {psk, aes_128_cbc, sha}, - {psk, aes_256_cbc, sha}, - {psk, aes_128_cbc, sha256}, - {psk, aes_256_cbc, sha384}, - {dhe_psk, rc4_128, sha}, - {dhe_psk, '3des_ede_cbc', sha}, - {dhe_psk, aes_128_cbc, sha}, - {dhe_psk, aes_256_cbc, sha}, - {dhe_psk, aes_128_cbc, sha256}, - {dhe_psk, aes_256_cbc, sha384}, - {rsa_psk, rc4_128, sha}, - {rsa_psk, '3des_ede_cbc', sha}, - {rsa_psk, aes_128_cbc, sha}, - {rsa_psk, aes_256_cbc, sha}, - {rsa_psk, aes_128_cbc, sha256}, - {rsa_psk, aes_256_cbc, sha384}, - {psk, aes_128_gcm, null, sha256}, - {psk, aes_256_gcm, null, sha384}, - {dhe_psk, aes_128_gcm, null, sha256}, - {dhe_psk, aes_256_gcm, null, sha384}, - {rsa_psk, aes_128_gcm, null, sha256}, - {rsa_psk, aes_256_gcm, null, sha384}], +psk_suites(Version) -> + Suites = ssl_cipher:psk_suites(Version), ssl_cipher:filter_suites(Suites). -psk_anon_suites() -> - Suites = - [{psk, rc4_128, sha}, - {psk, '3des_ede_cbc', sha}, - {psk, aes_128_cbc, sha}, - {psk, aes_256_cbc, sha}, - {dhe_psk, rc4_128, sha}, - {dhe_psk, '3des_ede_cbc', sha}, - {dhe_psk, aes_128_cbc, sha}, - {dhe_psk, aes_256_cbc, sha}], +psk_anon_suites(Version) -> + Suites = [Suite || Suite <- psk_suites(Version), is_psk_anon_suite(Suite)], ssl_cipher:filter_suites(Suites). srp_suites() -> @@ -1089,14 +1055,16 @@ init_tls_version(Version, Config) application:load(ssl), application:set_env(ssl, dtls_protocol_version, Version), ssl:start(), - [{protocol, dtls}, {protocol_opts, [{protocol, dtls}]}|Config]; + NewConfig = proplists:delete(protocol_opts, proplists:delete(protocol, Config)), + [{protocol, dtls}, {protocol_opts, [{protocol, dtls}]} | NewConfig]; init_tls_version(Version, Config) -> ssl:stop(), application:load(ssl), application:set_env(ssl, protocol_version, Version), ssl:start(), - [{protocol, tls}|Config]. + NewConfig = proplists:delete(protocol_opts, proplists:delete(protocol, Config)), + [{protocol, tls} | NewConfig]. sufficient_crypto_support(Version) when Version == 'tlsv1.2'; Version == 'dtlsv1.2' -> @@ -1231,19 +1199,37 @@ check_sane_openssl_version(Version) -> enough_openssl_crl_support("OpenSSL 0." ++ _) -> false; enough_openssl_crl_support(_) -> true. -wait_for_openssl_server(Port) -> - wait_for_openssl_server(Port, 10). -wait_for_openssl_server(_, 0) -> +wait_for_openssl_server(Port, tls) -> + do_wait_for_openssl_tls_server(Port, 10); +wait_for_openssl_server(Port, dtls) -> + do_wait_for_openssl_dtls_server(Port, 10). + +do_wait_for_openssl_tls_server(_, 0) -> exit(failed_to_connect_to_openssl); -wait_for_openssl_server(Port, N) -> +do_wait_for_openssl_tls_server(Port, N) -> case gen_tcp:connect("localhost", Port, []) of {ok, S} -> gen_tcp:close(S); _ -> ct:sleep(?SLEEP), - wait_for_openssl_server(Port, N-1) + do_wait_for_openssl_tls_server(Port, N-1) end. +do_wait_for_openssl_dtls_server(_, 0) -> + %%exit(failed_to_connect_to_openssl); + ok; +do_wait_for_openssl_dtls_server(Port, N) -> + %% case gen_udp:open(0) of + %% {ok, S} -> + %% gen_udp:connect(S, "localhost", Port), + %% gen_udp:close(S); + %% _ -> + %% ct:sleep(?SLEEP), + %% do_wait_for_openssl_dtls_server(Port, N-1) + %% end. + ct:sleep(500), + do_wait_for_openssl_dtls_server(Port, N-1). + version_flag(tlsv1) -> "-tls1"; version_flag('tlsv1.1') -> @@ -1253,10 +1239,14 @@ version_flag('tlsv1.2') -> version_flag(sslv3) -> "-ssl3"; version_flag(sslv2) -> - "-ssl2". - -filter_suites(Ciphers0) -> - Version = tls_record:highest_protocol_version([]), + "-ssl2"; +version_flag('dtlsv1.2') -> + "-dtls1_2"; +version_flag('dtlsv1') -> + "-dtls1". + +filter_suites(Ciphers0, AtomVersion) -> + Version = tls_version(AtomVersion), Supported0 = ssl_cipher:suites(Version) ++ ssl_cipher:anonymous_suites(Version) ++ ssl_cipher:psk_suites(Version) @@ -1338,7 +1328,7 @@ protocol_version(Config) -> protocol_version(Config, tuple) -> case proplists:get_value(protocol, Config) of dtls -> - dtls_record:protocol_version(dtls_record:highest_protocol_version([])); + dtls_record:highest_protocol_version(dtls_record:supported_protocol_versions()); _ -> tls_record:highest_protocol_version(tls_record:supported_protocol_versions()) end; @@ -1372,6 +1362,7 @@ clean_env() -> application:unset_env(ssl, session_cache_client_max), application:unset_env(ssl, session_cache_server_max), application:unset_env(ssl, ssl_pem_cache_clean), + application:unset_env(ssl, bypass_pem_cache), application:unset_env(ssl, alert_timeout). clean_start() -> @@ -1379,3 +1370,105 @@ clean_start() -> application:load(ssl), clean_env(), ssl:start(). + +is_psk_anon_suite({psk, _,_}) -> + true; +is_psk_anon_suite({dhe_psk,_,_}) -> + true; +is_psk_anon_suite({psk, _,_,_}) -> + true; +is_psk_anon_suite({dhe_psk, _,_,_}) -> + true; +is_psk_anon_suite(_) -> + false. + +cipher_atom(aes_256_cbc) -> + aes_cbc256; +cipher_atom(aes_128_cbc) -> + aes_cbc128; +cipher_atom('3des_ede_cbc') -> + des_ede3; +cipher_atom(Atom) -> + Atom. +tls_version('dtlsv1' = Atom) -> + dtls_v1:corresponding_tls_version(dtls_record:protocol_version(Atom)); +tls_version('dtlsv1.2' = Atom) -> + dtls_v1:corresponding_tls_version(dtls_record:protocol_version(Atom)); +tls_version(Atom) -> + tls_record:protocol_version(Atom). + +dtls_hello() -> + [1, + <<0,1,4>>, + <<0,0>>, + <<0,0,0>>, + <<0,1,4>>, + <<254,253,88, + 156,129,61, + 131,216,15, + 131,194,242, + 46,154,190, + 20,228,234, + 234,150,44, + 62,96,96,103, + 127,95,103, + 23,24,42,138, + 13,142,32,57, + 230,177,32, + 210,154,152, + 188,121,134, + 136,53,105, + 118,96,106, + 103,231,223, + 133,10,165, + 50,32,211, + 227,193,14, + 181,143,48, + 66,0,0,100,0, + 255,192,44, + 192,48,192, + 36,192,40, + 192,46,192, + 50,192,38, + 192,42,0,159, + 0,163,0,107, + 0,106,0,157, + 0,61,192,43, + 192,47,192, + 35,192,39, + 192,45,192, + 49,192,37, + 192,41,0,158, + 0,162,0,103, + 0,64,0,156,0, + 60,192,10, + 192,20,0,57, + 0,56,192,5, + 192,15,0,53, + 192,8,192,18, + 0,22,0,19, + 192,3,192,13, + 0,10,192,9, + 192,19,0,51, + 0,50,192,4, + 192,14,0,47, + 1,0,0,86,0,0, + 0,14,0,12,0, + 0,9,108,111, + 99,97,108, + 104,111,115, + 116,0,10,0, + 58,0,56,0,14, + 0,13,0,25,0, + 28,0,11,0,12, + 0,27,0,24,0, + 9,0,10,0,26, + 0,22,0,23,0, + 8,0,6,0,7,0, + 20,0,21,0,4, + 0,5,0,18,0, + 19,0,1,0,2,0, + 3,0,15,0,16, + 0,17,0,11,0, + 2,1,0>>]. + diff --git a/lib/ssl/test/ssl_to_openssl_SUITE.erl b/lib/ssl/test/ssl_to_openssl_SUITE.erl index e99340822d..7a1dce70c2 100644 --- a/lib/ssl/test/ssl_to_openssl_SUITE.erl +++ b/lib/ssl/test/ssl_to_openssl_SUITE.erl @@ -42,7 +42,9 @@ all() -> {group, 'tlsv1.2'}, {group, 'tlsv1.1'}, {group, 'tlsv1'}, - {group, 'sslv3'} + {group, 'sslv3'}, + {group, 'dtlsv1.2'}, + {group, 'dtlsv1'} ]. groups() -> @@ -50,7 +52,10 @@ groups() -> {'tlsv1.2', [], all_versions_tests() ++ alpn_tests() ++ npn_tests() ++ sni_server_tests()}, {'tlsv1.1', [], all_versions_tests() ++ alpn_tests() ++ npn_tests() ++ sni_server_tests()}, {'tlsv1', [], all_versions_tests()++ alpn_tests() ++ npn_tests() ++ sni_server_tests()}, - {'sslv3', [], all_versions_tests()}]. + {'sslv3', [], all_versions_tests()}, + {'dtlsv1.2', [], dtls_all_versions_tests()}, + {'dtlsv1', [], dtls_all_versions_tests()} + ]. basic_tests() -> [basic_erlang_client_openssl_server, @@ -78,6 +83,25 @@ all_versions_tests() -> expired_session, ssl2_erlang_server_openssl_client ]. +dtls_all_versions_tests() -> + [ + %%erlang_client_openssl_server, + erlang_server_openssl_client, + %%erlang_client_openssl_server_dsa_cert, + erlang_server_openssl_client_dsa_cert + %% This one works but gets port EXIT first some times + %%erlang_server_openssl_client_reuse_session + %%erlang_client_openssl_server_renegotiate, + %%erlang_client_openssl_server_nowrap_seqnum, + %%erlang_server_openssl_client_nowrap_seqnum, + %%erlang_client_openssl_server_no_server_ca_cert, + %%erlang_client_openssl_server_client_cert, + %%erlang_server_openssl_client_client_cert + %%ciphers_rsa_signed_certs, + %%ciphers_dsa_signed_certs, + %%erlang_client_bad_openssl_server, + %%expired_session + ]. alpn_tests() -> [erlang_client_alpn_openssl_server_alpn, @@ -284,7 +308,8 @@ basic_erlang_client_openssl_server(Config) when is_list(Config) -> OpensslPort = ssl_test_lib:portable_open_port(Exe, Args), - ssl_test_lib:wait_for_openssl_server(Port), + + ssl_test_lib:wait_for_openssl_server(Port, tls), Client = ssl_test_lib:start_client([{node, ClientNode}, {port, Port}, {host, Hostname}, @@ -357,7 +382,7 @@ erlang_client_openssl_server(Config) when is_list(Config) -> OpensslPort = ssl_test_lib:portable_open_port(Exe, Args), - ssl_test_lib:wait_for_openssl_server(Port), + ssl_test_lib:wait_for_openssl_server(Port, proplists:get_value(protocol, Config)), Client = ssl_test_lib:start_client([{node, ClientNode}, {port, Port}, {host, Hostname}, @@ -431,7 +456,7 @@ erlang_client_openssl_server_dsa_cert(Config) when is_list(Config) -> OpensslPort = ssl_test_lib:portable_open_port(Exe, Args), - ssl_test_lib:wait_for_openssl_server(Port), + ssl_test_lib:wait_for_openssl_server(Port, proplists:get_value(protocol, Config)), Client = ssl_test_lib:start_client([{node, ClientNode}, {port, Port}, {host, Hostname}, @@ -551,7 +576,7 @@ erlang_client_openssl_server_renegotiate(Config) when is_list(Config) -> OpensslPort = ssl_test_lib:portable_open_port(Exe, Args), - ssl_test_lib:wait_for_openssl_server(Port), + ssl_test_lib:wait_for_openssl_server(Port, proplists:get_value(protocol, Config)), Client = ssl_test_lib:start_client([{node, ClientNode}, {port, Port}, {host, Hostname}, @@ -600,7 +625,7 @@ erlang_client_openssl_server_nowrap_seqnum(Config) when is_list(Config) -> OpensslPort = ssl_test_lib:portable_open_port(Exe, Args), - ssl_test_lib:wait_for_openssl_server(Port), + ssl_test_lib:wait_for_openssl_server(Port, proplists:get_value(protocol, Config)), Client = ssl_test_lib:start_client([{node, ClientNode}, {port, Port}, {host, Hostname}, @@ -681,7 +706,7 @@ erlang_client_openssl_server_no_server_ca_cert(Config) when is_list(Config) -> OpensslPort = ssl_test_lib:portable_open_port(Exe, Args), - ssl_test_lib:wait_for_openssl_server(Port), + ssl_test_lib:wait_for_openssl_server(Port, proplists:get_value(protocol, Config)), Client = ssl_test_lib:start_client([{node, ClientNode}, {port, Port}, {host, Hostname}, @@ -724,7 +749,7 @@ erlang_client_openssl_server_client_cert(Config) when is_list(Config) -> OpensslPort = ssl_test_lib:portable_open_port(Exe, Args), - ssl_test_lib:wait_for_openssl_server(Port), + ssl_test_lib:wait_for_openssl_server(Port, proplists:get_value(protocol, Config)), Client = ssl_test_lib:start_client([{node, ClientNode}, {port, Port}, {host, Hostname}, @@ -856,7 +881,7 @@ erlang_client_bad_openssl_server(Config) when is_list(Config) -> "-cert", CertFile, "-key", KeyFile], OpensslPort = ssl_test_lib:portable_open_port(Exe, Args), - ssl_test_lib:wait_for_openssl_server(Port), + ssl_test_lib:wait_for_openssl_server(Port, proplists:get_value(protocol, Config)), Client0 = ssl_test_lib:start_client([{node, ClientNode}, {port, Port}, {host, Hostname}, @@ -911,7 +936,7 @@ expired_session(Config) when is_list(Config) -> OpensslPort = ssl_test_lib:portable_open_port(Exe, Args), - ssl_test_lib:wait_for_openssl_server(Port), + ssl_test_lib:wait_for_openssl_server(Port, tls), Client0 = ssl_test_lib:start_client([{node, ClientNode}, @@ -1399,7 +1424,7 @@ cipher(CipherSuite, Version, Config, ClientOpts, ServerOpts) -> OpenSslPort = ssl_test_lib:portable_open_port(Exe, Args), - ssl_test_lib:wait_for_openssl_server(Port), + ssl_test_lib:wait_for_openssl_server(Port, proplists:get_value(protocol, Config)), ConnectionInfo = {ok, {Version, CipherSuite}}, @@ -1469,7 +1494,7 @@ start_erlang_client_and_openssl_server_with_opts(Config, ErlangClientOpts, Opens OpensslPort = ssl_test_lib:portable_open_port(Exe, Args), - ssl_test_lib:wait_for_openssl_server(Port), + ssl_test_lib:wait_for_openssl_server(Port, proplists:get_value(protocol, Config)), Client = ssl_test_lib:start_client([{node, ClientNode}, {port, Port}, {host, Hostname}, @@ -1505,7 +1530,7 @@ start_erlang_client_and_openssl_server_for_alpn_negotiation(Config, Data, Callba Args = ["s_server", "-msg", "-alpn", "http/1.1,spdy/2", "-accept", integer_to_list(Port), ssl_test_lib:version_flag(Version), "-cert", CertFile, "-key", KeyFile], OpensslPort = ssl_test_lib:portable_open_port(Exe, Args), - ssl_test_lib:wait_for_openssl_server(Port), + ssl_test_lib:wait_for_openssl_server(Port, proplists:get_value(protocol, Config)), Client = ssl_test_lib:start_client([{node, ClientNode}, {port, Port}, {host, Hostname}, @@ -1574,7 +1599,7 @@ start_erlang_client_and_openssl_server_for_alpn_npn_negotiation(Config, Data, Ca OpensslPort = ssl_test_lib:portable_open_port(Exe, Args), - ssl_test_lib:wait_for_openssl_server(Port), + ssl_test_lib:wait_for_openssl_server(Port, proplists:get_value(protocol, Config)), Client = ssl_test_lib:start_client([{node, ClientNode}, {port, Port}, {host, Hostname}, @@ -1639,7 +1664,7 @@ start_erlang_client_and_openssl_server_for_npn_negotiation(Config, Data, Callbac "-cert", CertFile, "-key", KeyFile], OpensslPort = ssl_test_lib:portable_open_port(Exe, Args), - ssl_test_lib:wait_for_openssl_server(Port), + ssl_test_lib:wait_for_openssl_server(Port, proplists:get_value(protocol, Config)), Client = ssl_test_lib:start_client([{node, ClientNode}, {port, Port}, {host, Hostname}, diff --git a/lib/ssl/vsn.mk b/lib/ssl/vsn.mk index 2cdb825d75..415a47949d 100644 --- a/lib/ssl/vsn.mk +++ b/lib/ssl/vsn.mk @@ -1 +1 @@ -SSL_VSN = 8.1 +SSL_VSN = 8.1.1 diff --git a/lib/stdlib/doc/src/erl_tar.xml b/lib/stdlib/doc/src/erl_tar.xml index 24e7b64b9e..f28d8b425b 100644 --- a/lib/stdlib/doc/src/erl_tar.xml +++ b/lib/stdlib/doc/src/erl_tar.xml @@ -37,12 +37,13 @@ </modulesummary> <description> <p>This module archives and extract files to and from - a tar file. This module supports the <c>ustar</c> format - (IEEE Std 1003.1 and ISO/IEC 9945-1). All modern <c>tar</c> - programs (including GNU tar) can read this format. To ensure that - that GNU tar produces a tar file that <c>erl_tar</c> can read, - specify option <c>--format=ustar</c> to GNU tar.</p> - + a tar file. This module supports reading most common tar formats, + namely v7, STAR, USTAR, and PAX, as well as some of GNU tar's extensions + to the USTAR format (sparse files most notably). It produces tar archives + in USTAR format, unless the files being archived require PAX format due to + restrictions in USTAR (such as unicode metadata, filename length, and more). + As such, <c>erl_tar</c> supports tar archives produced by most all modern + tar utilities, and produces tarballs which should be similarly portable.</p> <p>By convention, the name of a tar file is to end in "<c>.tar</c>". To abide to the convention, add "<c>.tar</c>" to the name.</p> @@ -83,6 +84,8 @@ <p>If <seealso marker="kernel:file#native_name_encoding/0"> <c>file:native_name_encoding/0</c></seealso> returns <c>latin1</c>, no translation of path names is done.</p> + + <p>Unicode metadata stored in PAX headers is preserved</p> </section> <section> @@ -104,21 +107,20 @@ <title>Limitations</title> <list type="bulleted"> <item> - <p>For maximum compatibility, it is safe to archive files with names - up to 100 characters in length. Such tar files can generally be - extracted by any <c>tar</c> program.</p> - </item> - <item> - <p>For filenames exceeding 100 characters in length, the resulting tar - file can only be correctly extracted by a POSIX-compatible <c>tar</c> - program (such as Solaris <c>tar</c> or a modern GNU <c>tar</c>).</p> - </item> - <item> - <p>Files with longer names than 256 bytes cannot be stored.</p> + <p>If you must remain compatible with the USTAR tar format, you must ensure file paths being + stored are less than 255 bytes in total, with a maximum filename component + length of 100 bytes. USTAR uses a header field (prefix) in addition to the name field, and + splits file paths longer than 100 bytes into two parts. This split is done on a directory boundary, + and is done in such a way to make the best use of the space available in those two fields, but in practice + this will often mean that you have less than 255 bytes for a path. <c>erl_tar</c> will + automatically upgrade the format to PAX to handle longer filenames, so this is only an issue if you + need to extract the archive with an older implementation of <c>erl_tar</c> or <c>tar</c> which does + not support PAX. In this case, the PAX headers will be extracted as regular files, and you will need to + apply them manually.</p> </item> <item> - <p>The file name a symbolic link points is always limited - to 100 characters.</p> + <p>Like the above, if you must remain USTAR compatible, you must also ensure than paths for + symbolic/hard links are no more than 100 bytes, otherwise PAX headers will be used.</p> </item> </list> </section> @@ -129,7 +131,9 @@ <fsummary>Add a file to an open tar file.</fsummary> <type> <v>TarDescriptor = term()</v> - <v>Filename = filename()</v> + <v>FilenameOrBin = filename()|binary()</v> + <v>NameInArchive = filename()</v> + <v>Filename = filename()|{NameInArchive,FilenameOrBin}</v> <v>Options = [Option]</v> <v>Option = dereference|verbose|{chunks,ChunkSize}</v> <v>ChunkSize = positive_integer()</v> @@ -139,6 +143,9 @@ <desc> <p>Adds a file to a tar file that has been opened for writing by <seealso marker="#open/2"><c>open/1</c></seealso>.</p> + <p><c>NameInArchive</c> is the name under which the file becomes + stored in the tar file. The file gets this name when it is + extracted from the tar file.</p> <p>Options:</p> <taglist> <tag><c>dereference</c></tag> @@ -183,9 +190,6 @@ <seealso marker="#open/2"><c>open/2</c></seealso>. This function accepts the same options as <seealso marker="#add/3"><c>add/3</c></seealso>.</p> - <p><c>NameInArchive</c> is the name under which the file becomes - stored in the tar file. The file gets this name when it is - extracted from the tar file.</p> </desc> </func> @@ -206,8 +210,8 @@ <fsummary>Create a tar archive.</fsummary> <type> <v>Name = filename()</v> - <v>FileList = [Filename|{NameInArchive, binary()},{NameInArchive, - Filename}]</v> + <v>FileList = [Filename|{NameInArchive, FilenameOrBin}]</v> + <v>FilenameOrBin = filename()|binary()</v> <v>Filename = filename()</v> <v>NameInArchive = filename()</v> <v>RetValue = ok|{error,{Name,Reason}}</v> @@ -225,8 +229,8 @@ <fsummary>Create a tar archive with options.</fsummary> <type> <v>Name = filename()</v> - <v>FileList = [Filename|{NameInArchive, binary()},{NameInArchive, - Filename}]</v> + <v>FileList = [Filename|{NameInArchive, FilenameOrBin}]</v> + <v>FilenameOrBin = filename()|binary()</v> <v>Filename = filename()</v> <v>NameInArchive = filename()</v> <v>OptionList = [Option]</v> @@ -275,7 +279,8 @@ <name>extract(Name) -> RetValue</name> <fsummary>Extract all files from a tar file.</fsummary> <type> - <v>Name = filename()</v> + <v>Name = filename() | {binary,binary()} | {file,Fd}</v> + <v>Fd = file_descriptor()</v> <v>RetValue = ok|{error,{Name,Reason}}</v> <v>Reason = term()</v> </type> @@ -294,8 +299,7 @@ <name>extract(Name, OptionList)</name> <fsummary>Extract files from a tar file.</fsummary> <type> - <v>Name = filename() | {binary,Binary} | {file,Fd}</v> - <v>Binary = binary()</v> + <v>Name = filename() | {binary,binary()} | {file,Fd}</v> <v>Fd = file_descriptor()</v> <v>OptionList = [Option]</v> <v>Option = {cwd,Cwd}|{files,FileList}|keep_old_files|verbose|memory</v> @@ -521,7 +525,7 @@ erl_tar:close(TarDesc)</code> <name>table(Name) -> RetValue</name> <fsummary>Retrieve the name of all files in a tar file.</fsummary> <type> - <v>Name = filename()</v> + <v>Name = filename()|{binary,binary()}|{file,file_descriptor()}</v> <v>RetValue = {ok,[string()]}|{error,{Name,Reason}}</v> <v>Reason = term()</v> </type> @@ -535,7 +539,7 @@ erl_tar:close(TarDesc)</code> <fsummary>Retrieve name and information of all files in a tar file. </fsummary> <type> - <v>Name = filename()</v> + <v>Name = filename()|{binary,binary()}|{file,file_descriptor()}</v> </type> <desc> <p>Retrieves the names of all files in the tar file <c>Name</c>.</p> @@ -546,7 +550,7 @@ erl_tar:close(TarDesc)</code> <name>t(Name)</name> <fsummary>Print the name of each file in a tar file.</fsummary> <type> - <v>Name = filename()</v> + <v>Name = filename()|{binary,binary()}|{file,file_descriptor()}</v> </type> <desc> <p>Prints the names of all files in the tar file <c>Name</c> to the @@ -559,7 +563,7 @@ erl_tar:close(TarDesc)</code> <fsummary>Print name and information for each file in a tar file. </fsummary> <type> - <v>Name = filename()</v> + <v>Name = filename()|{binary,binary()}|{file,file_descriptor()}</v> </type> <desc> <p>Prints names and information about all files in the tar file diff --git a/lib/stdlib/doc/src/filename.xml b/lib/stdlib/doc/src/filename.xml index 7acef51ca1..0ccca37a9d 100644 --- a/lib/stdlib/doc/src/filename.xml +++ b/lib/stdlib/doc/src/filename.xml @@ -513,6 +513,33 @@ true </func> <func> + <name name="safe_relative_path" arity="1"/> + <fsummary>Sanitize a relative path to avoid directory traversal attacks.</fsummary> + <desc> + <p>Sanitizes the relative path by eliminating ".." and "." + components to protect against directory traversal attacks. + Either returns the sanitized path name, or the atom + <c>unsafe</c> if the path is unsafe. + The path is considered unsafe in the following circumstances:</p> + <list type="bulleted"> + <item><p>The path is not relative.</p></item> + <item><p>A ".." component would climb up above the root of + the relative path.</p></item> + </list> + <p><em>Examples:</em></p> + <pre> +1> <input>filename:safe_relative_path("dir/sub_dir/..").</input> +"dir" +2> <input>filename:safe_relative_path("dir/..").</input> +[] +3> <input>filename:safe_relative_path("dir/../..").</input> +unsafe +4> <input>filename:safe_relative_path("/abs/path").</input> +unsafe</pre> + </desc> + </func> + + <func> <name name="split" arity="1"/> <fsummary>Split a filename into its path components.</fsummary> <desc> diff --git a/lib/stdlib/doc/src/gen_statem.xml b/lib/stdlib/doc/src/gen_statem.xml index fd498ee82e..5eb13db1aa 100644 --- a/lib/stdlib/doc/src/gen_statem.xml +++ b/lib/stdlib/doc/src/gen_statem.xml @@ -4,7 +4,7 @@ <erlref> <header> <copyright> - <year>2016</year> + <year>2016-2017</year> <holder>Ericsson AB. All Rights Reserved.</holder> </copyright> <legalnotice> @@ -587,8 +587,8 @@ handle_event(_, _, State, Data) -> <name name="state_enter"/> <desc> <p> - If the state machine should use <em>state enter calls</em> - is selected when starting the <c>gen_statem</c> + Whether the state machine should use <em>state enter calls</em> + or not is selected when starting the <c>gen_statem</c> and after code change using the return value from <seealso marker="#Module:callback_mode/0"><c>Module:callback_mode/0</c></seealso>. </p> @@ -606,7 +606,16 @@ handle_event(_, _, State, Data) -> See <seealso marker="#Module:StateName/3"><c>Module:StateName/3</c></seealso> and - <seealso marker="#Module:handle_event/4"><c>Module:handle_event/4</c></seealso>. + <seealso marker="#Module:handle_event/4"><c>Module:handle_event/4</c></seealso>. + Such a call can be repeated by returning a + <seealso marker="#type-state_callback_result"> + <c>repeat_state</c> + </seealso> + or + <seealso marker="#type-state_callback_result"> + <c>repeat_state_and_data</c> + </seealso> + tuple from the state callback. </p> <p> If @@ -625,7 +634,8 @@ handle_event(_, _, State, Data) -> right before entering the initial state even though this formally is not a state change. In this case <c>OldState</c> will be the same as <c>State</c>, - which can not happen for a subsequent state change. + which can not happen for a subsequent state change, + but will happen when repeating the state enter call. </p> </desc> </datatype> @@ -640,7 +650,15 @@ handle_event(_, _, State, Data) -> <list type="ordered"> <item> <p> - If the state changes or is the initial state, and + If the state changes, is the initial state, + <seealso marker="#type-state_callback_result"> + <c>repeat_state</c> + </seealso> + or + <seealso marker="#type-state_callback_result"> + <c>repeat_state_and_data</c> + </seealso> + is used, and also <seealso marker="#type-state_enter"><em>state enter calls</em></seealso> are used, the <c>gen_statem</c> calls the new state callback with arguments @@ -983,6 +1001,33 @@ handle_event(_, _, State, Data) -> </desc> </datatype> <datatype> + <name name="init_result"/> + <desc> + <p> + For a succesful initialization, + <c><anno>State</anno></c> is the initial + <seealso marker="#type-state"><c>state()</c></seealso> + and <c><anno>Data</anno></c> the initial server + <seealso marker="#type-data"><c>data()</c></seealso> + of the <c>gen_statem</c>. + </p> + <p> + The <seealso marker="#type-action"><c>Actions</c></seealso> + are executed when entering the first + <seealso marker="#type-state">state</seealso> just as for a + <seealso marker="#state callback">state callback</seealso>, + except that the action <c>postpone</c> is forced to + <c>false</c> since there is no event to postpone. + </p> + <p> + For an unsuccesful initialization, + <c>{stop,<anno>Reason</anno>}</c> + or <c>ignore</c> should be used; see + <seealso marker="#start_link/3"><c>start_link/3,4</c></seealso>. + </p> + </desc> + </datatype> + <datatype> <name name="state_enter_result"/> <desc> <p> @@ -1068,6 +1113,37 @@ handle_event(_, _, State, Data) -> <c>{next_state,CurrentState,CurrentData,<anno>Actions</anno>}</c>. </p> </item> + <tag><c>repeat_state</c></tag> + <item> + <p> + The <c>gen_statem</c> keeps the current state, or + does a state transition to the current state if you like, + sets <c><anno>NewData</anno></c>, + and executes all <c><anno>Actions</anno></c>. + If the <c>gen_statem</c> runs with + <seealso marker="#type-state_enter"><em>state enter calls</em></seealso>, + the state enter call is repeated, see type + <seealso marker="#type-transition_option"><c>transition_option()</c></seealso>, + otherwise <c>repeat_state</c> is the same as + <c>keep_state</c>. + </p> + </item> + <tag><c>repeat_state_and_data</c></tag> + <item> + <p> + The <c>gen_statem</c> keeps the current state and data, or + does a state transition to the current state if you like, + and executes all <c><anno>Actions</anno></c>. + This is the same as + <c>{repeat_state,CurrentData,<anno>Actions</anno>}</c>. + If the <c>gen_statem</c> runs with + <seealso marker="#type-state_enter"><em>state enter calls</em></seealso>, + the state enter call is repeated, see type + <seealso marker="#type-transition_option"><c>transition_option()</c></seealso>, + otherwise <c>repeat_state_and_data</c> is the same as + <c>keep_state_and_data</c>. + </p> + </item> <tag><c>stop</c></tag> <item> <p> @@ -1609,29 +1685,33 @@ handle_event(_, _, State, Data) -> It is recommended to use an atom as <c>Reason</c> since it will be wrapped in an <c>{error,Reason}</c> tuple. </p> + <p> + Also note when upgrading a <c>gen_statem</c>, + this function and hence + the <c>Change={advanced,Extra}</c> parameter in the + <seealso marker="sasl:appup"><c>appup</c></seealso> file + is not only needed to update the internal state + or to act on the <c>Extra</c> argument. + It is also needed if an upgrade or downgrade should change + <seealso marker="#type-callback_mode"><em>callback mode</em></seealso>, + or else the callback mode after the code change + will not be honoured, + most probably causing a server crash. + </p> </desc> </func> <func> - <name>Module:init(Args) -> Result</name> + <name>Module:init(Args) -> Result(StateType)</name> <fsummary> Optional function for initializing process and internal state. </fsummary> <type> <v>Args = term()</v> - <v>Result = {ok,State,Data}</v> - <v> | {ok,State,Data,Actions}</v> - <v> | {stop,Reason} | ignore</v> - <v>State = <seealso marker="#type-state">state()</seealso></v> - <v> - Data = <seealso marker="#type-data">data()</seealso> - </v> <v> - Actions = - [<seealso marker="#type-action">action()</seealso>] | - <seealso marker="#type-action">action()</seealso> + Result(StateType) = + <seealso marker="#type-init_result">init_result(StateType)</seealso> </v> - <v>Reason = term()</v> </type> <desc> <marker id="Module:init-1"/> @@ -1644,30 +1724,9 @@ handle_event(_, _, State, Data) -> the implementation state and server data. </p> <p> - <c>Args</c> is the <c>Args</c> argument provided to the start + <c>Args</c> is the <c>Args</c> argument provided to that start function. </p> - <p> - If the initialization is successful, the function is to - return <c>{ok,State,Data}</c> or - <c>{ok,State,Data,Actions}</c>. - <c>State</c> is the initial - <seealso marker="#type-state"><c>state()</c></seealso> - and <c>Data</c> the initial server - <seealso marker="#type-data"><c>data()</c></seealso>. - </p> - <p> - The <seealso marker="#type-action"><c>Actions</c></seealso> - are executed when entering the first - <seealso marker="#type-state">state</seealso> just as for a - <seealso marker="#state callback">state callback</seealso>. - </p> - <p> - If the initialization fails, - the function is to return <c>{stop,Reason}</c> - or <c>ignore</c>; see - <seealso marker="#start_link/3"><c>start_link/3,4</c></seealso>. - </p> <note> <p> This callback is optional, so a callback module does not need @@ -1873,22 +1932,33 @@ handle_event(_, _, State, Data) -> <seealso marker="#type-enter_action">actions</seealso> that may be returned: <seealso marker="#type-postpone"><c>postpone()</c></seealso> - and + is not allowed since a <em>state enter call</em> is not + an event so there is no event to postpone, and <seealso marker="#type-action"><c>{next_event,_,_}</c></seealso> - are not allowed. + is not allowed since using <em>state enter calls</em> + should not affect how events are consumed and produced. You may also not change states from this call. Should you return <c>{next_state,NextState, ...}</c> with <c>NextState =/= State</c> the <c>gen_statem</c> crashes. - You are advised to use <c>{keep_state,...}</c> or - <c>keep_state_and_data</c>. + It is possible to use <c>{repeat_state, ...}</c>, + <c>{repeat_state_and_data,_}</c> or + <c>repeat_state_and_data</c> but all of them makes little + sense since you immediately will be called again with a new + <em>state enter call</em> making this just a weird way + of looping, and there are better ways to loop in Erlang. + You are advised to use <c>{keep_state,...}</c>, + <c>{keep_state_and_data,_}</c> or + <c>keep_state_and_data</c> since you can not change states + from a <em>state enter call</em> anyway. </p> <p> Note the fact that you can use <seealso marker="erts:erlang#throw/1"><c>throw</c></seealso> to return the result, which can be useful. For example to bail out with <c>throw(keep_state_and_data)</c> - from deep within complex code that is in no position to - return <c>{next_state,State,Data}</c>. + from deep within complex code that can not + return <c>{next_state,State,Data}</c> because + <c>State</c> or <c>Data</c> is no longer in scope. </p> </desc> </func> @@ -1903,6 +1973,11 @@ handle_event(_, _, State, Data) -> <v>Ignored = term()</v> </type> <desc> + <note> + <p>This callback is optional, so callback modules need not + export it. The <c>gen_statem</c> module provides a default + implementation without cleanup.</p> + </note> <p> This function is called by a <c>gen_statem</c> when it is about to terminate. It is to be the opposite of diff --git a/lib/stdlib/doc/src/notes.xml b/lib/stdlib/doc/src/notes.xml index 0143686bb2..0e8bf3d27c 100644 --- a/lib/stdlib/doc/src/notes.xml +++ b/lib/stdlib/doc/src/notes.xml @@ -3163,7 +3163,7 @@ <p> Two bugs in io:format for ~F.~Ps has been corrected. When length(S) >= abs(F) > P, the precision P was incorrectly - ignored. When F == P > lenght(S) the result was + ignored. When F == P > length(S) the result was incorrectly left adjusted. Bug found by Ali Yakout who also provided a fix.</p> <p> diff --git a/lib/stdlib/doc/src/sys.xml b/lib/stdlib/doc/src/sys.xml index 9091a46df9..45171f814d 100644 --- a/lib/stdlib/doc/src/sys.xml +++ b/lib/stdlib/doc/src/sys.xml @@ -83,8 +83,8 @@ <p>If the modules used to implement the process change dynamically during runtime, the process must understand one more message. An example is the <seealso marker="gen_event"><c>gen_event</c></seealso> - processes. The message is <c>{get_modules, From}</c>. - The reply to this message is <c>From ! {modules, Modules}</c>, where + processes. The message is <c>{_Label, {From, Ref}, get_modules}</c>. + The reply to this message is <c>From ! {Ref, Modules}</c>, where <c>Modules</c> is a list of the currently active modules in the process.</p> <p>This message is used by the release handler to find which diff --git a/lib/stdlib/src/Makefile b/lib/stdlib/src/Makefile index d6c0ff8d8d..ed3dfb342c 100644 --- a/lib/stdlib/src/Makefile +++ b/lib/stdlib/src/Makefile @@ -130,7 +130,7 @@ HRL_FILES= \ ../include/qlc.hrl \ ../include/zip.hrl -INTERNAL_HRL_FILES= dets.hrl +INTERNAL_HRL_FILES= dets.hrl erl_tar.hrl ERL_FILES= $(MODULES:%=%.erl) @@ -228,7 +228,7 @@ $(EBIN)/dets_v9.beam: dets.hrl $(EBIN)/erl_bits.beam: ../include/erl_bits.hrl $(EBIN)/erl_compile.beam: ../include/erl_compile.hrl ../../kernel/include/file.hrl $(EBIN)/erl_lint.beam: ../include/erl_bits.hrl -$(EBIN)/erl_tar.beam: ../../kernel/include/file.hrl +$(EBIN)/erl_tar.beam: ../../kernel/include/file.hrl erl_tar.hrl $(EBIN)/file_sorter.beam: ../../kernel/include/file.hrl $(EBIN)/filelib.beam: ../../kernel/include/file.hrl $(EBIN)/filename.beam: ../../kernel/include/file.hrl diff --git a/lib/stdlib/src/base64.erl b/lib/stdlib/src/base64.erl index bf259e6691..0c8d817910 100644 --- a/lib/stdlib/src/base64.erl +++ b/lib/stdlib/src/base64.erl @@ -219,38 +219,49 @@ mime_decode_binary(Result, <<0:8,T/bits>>) -> mime_decode_binary(Result, T); mime_decode_binary(Result0, <<C:8,T/bits>>) -> case element(C, ?DECODE_MAP) of - Bits when is_integer(Bits) -> - mime_decode_binary(<<Result0/bits,Bits:6>>, T); - eq -> - case tail_contains_more(T, false) of - {<<>>, Eq} -> - %% No more valid data. - case bit_size(Result0) rem 8 of - 0 -> - %% '====' is not uncommon. - Result0; - 4 when Eq -> - %% enforce at least one more '=' only ignoring illegals and spacing - Split = byte_size(Result0) - 1, - <<Result:Split/bytes,_:4>> = Result0, - Result; - 2 -> - %% remove 2 bits - Split = byte_size(Result0) - 1, - <<Result:Split/bytes,_:2>> = Result0, - Result - end; - {More, _} -> - %% More valid data, skip the eq as invalid - mime_decode_binary(Result0, More) - end; - _ -> - mime_decode_binary(Result0, T) + Bits when is_integer(Bits) -> + mime_decode_binary(<<Result0/bits,Bits:6>>, T); + eq -> + mime_decode_binary_after_eq(Result0, T, false); + _ -> + mime_decode_binary(Result0, T) end; -mime_decode_binary(Result, <<>>) -> +mime_decode_binary(Result, _) -> true = is_binary(Result), Result. +mime_decode_binary_after_eq(Result, <<0:8,T/bits>>, Eq) -> + mime_decode_binary_after_eq(Result, T, Eq); +mime_decode_binary_after_eq(Result0, <<C:8,T/bits>>, Eq) -> + case element(C, ?DECODE_MAP) of + bad -> + mime_decode_binary_after_eq(Result0, T, Eq); + ws -> + mime_decode_binary_after_eq(Result0, T, Eq); + eq -> + mime_decode_binary_after_eq(Result0, T, true); + Bits when is_integer(Bits) -> + %% More valid data, skip the eq as invalid + mime_decode_binary(<<Result0/bits,Bits:6>>, T) + end; +mime_decode_binary_after_eq(Result0, <<>>, Eq) -> + %% No more valid data. + case bit_size(Result0) rem 8 of + 0 -> + %% '====' is not uncommon. + Result0; + 4 when Eq -> + %% enforce at least one more '=' only ignoring illegals and spacing + Split = byte_size(Result0) - 1, + <<Result:Split/bytes,_:4>> = Result0, + Result; + 2 -> + %% remove 2 bits + Split = byte_size(Result0) - 1, + <<Result:Split/bytes,_:2>> = Result0, + Result + end. + decode([], A) -> A; decode([$=,$=,C2,C1|Cs], A) -> Bits2x6 = (b64d(C1) bsl 18) bor (b64d(C2) bsl 12), diff --git a/lib/stdlib/src/c.erl b/lib/stdlib/src/c.erl index d3f9a9c7af..52df2319dd 100644 --- a/lib/stdlib/src/c.erl +++ b/lib/stdlib/src/c.erl @@ -35,7 +35,7 @@ -export([appcall/4]). -import(lists, [reverse/1,flatten/1,sublist/3,sort/1,keysort/2, - concat/1,max/1,min/1,foreach/2,foldl/3,flatmap/2]). + max/1,min/1,foreach/2,foldl/3,flatmap/2]). -import(io, [format/1, format/2]). %%----------------------------------------------------------------------- @@ -83,9 +83,11 @@ c(Module) -> c(Module, []). -spec c(Module, Options) -> {'ok', ModuleName} | 'error' when Module :: file:name(), - Options :: [compile:option()], + Options :: [compile:option()] | compile:option(), ModuleName :: module(). +c(Module, SingleOption) when not is_list(SingleOption) -> + c(Module, [SingleOption]); c(Module, Opts) when is_atom(Module) -> %% either a module name or a source file name (possibly without %% suffix); if such a source file exists, it is used to compile from diff --git a/lib/stdlib/src/edlin_expand.erl b/lib/stdlib/src/edlin_expand.erl index 5f821caef0..a1a97af4c5 100644 --- a/lib/stdlib/src/edlin_expand.erl +++ b/lib/stdlib/src/edlin_expand.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2005-2016. All Rights Reserved. +%% Copyright Ericsson AB 2005-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -101,44 +101,77 @@ match(Prefix, Alts, Extra0) -> %% Return the list of names L in multiple columns. format_matches(L) -> - S = format_col(lists:sort(L), []), + {S1, Dots} = format_col(lists:sort(L), []), + S = case Dots of + true -> + {_, Prefix} = longest_common_head(vals(L)), + PrefixLen = length(Prefix), + case PrefixLen =< 3 of + true -> S1; % Do not replace the prefix with "...". + false -> + LeadingDotsL = leading_dots(L, PrefixLen), + {S2, _} = format_col(lists:sort(LeadingDotsL), []), + S2 + end; + false -> S1 + end, ["\n" | S]. format_col([], _) -> []; -format_col(L, Acc) -> format_col(L, field_width(L), 0, Acc). - -format_col(X, Width, Len, Acc) when Width + Len > 79 -> - format_col(X, Width, 0, ["\n" | Acc]); -format_col([A|T], Width, Len, Acc0) -> - H = case A of - %% If it's a tuple {string(), integer()}, we assume it's an - %% arity, and meant to be printed. - {H0, I} when is_integer(I) -> - H0 ++ "/" ++ integer_to_list(I); - {H1, _} -> H1; - H2 -> H2 - end, - Acc = [io_lib:format("~-*ts", [Width,H]) | Acc0], - format_col(T, Width, Len+Width, Acc); -format_col([], _, _, Acc) -> - lists:reverse(Acc, "\n"). - -field_width(L) -> field_width(L, 0). - -field_width([{H,_}|T], W) -> +format_col(L, Acc) -> + LL = 79, + format_col(L, field_width(L, LL), 0, Acc, LL, false). + +format_col(X, Width, Len, Acc, LL, Dots) when Width + Len > LL -> + format_col(X, Width, 0, ["\n" | Acc], LL, Dots); +format_col([A|T], Width, Len, Acc0, LL, Dots) -> + {H0, R} = format_val(A), + Hmax = LL - length(R), + {H, NewDots} = + case length(H0) > Hmax of + true -> {io_lib:format("~-*ts", [Hmax - 3, H0]) ++ "...", true}; + false -> {H0, Dots} + end, + Acc = [io_lib:format("~-*ts", [Width, H ++ R]) | Acc0], + format_col(T, Width, Len+Width, Acc, LL, NewDots); +format_col([], _, _, Acc, _LL, Dots) -> + {lists:reverse(Acc, "\n"), Dots}. + +format_val({H, I}) when is_integer(I) -> + %% If it's a tuple {string(), integer()}, we assume it's an + %% arity, and meant to be printed. + {H, "/" ++ integer_to_list(I)}; +format_val({H, _}) -> + {H, ""}; +format_val(H) -> + {H, ""}. + +field_width(L, LL) -> field_width(L, 0, LL). + +field_width([{H,_}|T], W, LL) -> case length(H) of - L when L > W -> field_width(T, L); - _ -> field_width(T, W) + L when L > W -> field_width(T, L, LL); + _ -> field_width(T, W, LL) end; -field_width([H|T], W) -> +field_width([H|T], W, LL) -> case length(H) of - L when L > W -> field_width(T, L); - _ -> field_width(T, W) + L when L > W -> field_width(T, L, LL); + _ -> field_width(T, W, LL) end; -field_width([], W) when W < 40 -> +field_width([], W, LL) when W < LL - 3 -> W + 4; -field_width([], _) -> - 40. +field_width([], _, LL) -> + LL. + +vals([]) -> []; +vals([{S, _}|L]) -> [S|vals(L)]; +vals([S|L]) -> [S|vals(L)]. + +leading_dots([], _Len) -> []; +leading_dots([{H, I}|L], Len) -> + [{"..." ++ nthtail(Len, H), I}|leading_dots(L, Len)]; +leading_dots([H|L], Len) -> + ["..." ++ nthtail(Len, H)|leading_dots(L, Len)]. longest_common_head([]) -> no; diff --git a/lib/stdlib/src/erl_expand_records.erl b/lib/stdlib/src/erl_expand_records.erl index 2280464bff..16220bceb4 100644 --- a/lib/stdlib/src/erl_expand_records.erl +++ b/lib/stdlib/src/erl_expand_records.erl @@ -30,13 +30,13 @@ -import(lists, [map/2,foldl/3,foldr/3,sort/1,reverse/1,duplicate/2]). --record(exprec, {compile=[], % Compile flags - vcount=0, % Variable counter - calltype=#{}, % Call types - records=dict:new(), % Record definitions - strict_ra=[], % strict record accesses - checked_ra=[] % successfully accessed records - }). +-record(exprec, {compile=[], % Compile flags + vcount=0, % Variable counter + calltype=#{}, % Call types + records=#{}, % Record definitions + strict_ra=[], % strict record accesses + checked_ra=[] % successfully accessed records + }). -spec(module(AbsForms, CompileOptions) -> AbsForms2 when AbsForms :: [erl_parse:abstract_form()], @@ -72,7 +72,7 @@ init_calltype_imports([], Ctype) -> Ctype. forms([{attribute,_,record,{Name,Defs}}=Attr | Fs], St0) -> NDefs = normalise_fields(Defs), - St = St0#exprec{records=dict:store(Name, NDefs, St0#exprec.records)}, + St = St0#exprec{records=maps:put(Name, NDefs, St0#exprec.records)}, {Fs1, St1} = forms(Fs, St), {[Attr | Fs1], St1}; forms([{function,L,N,A,Cs0} | Fs0], St0) -> @@ -546,7 +546,7 @@ normalise_fields(Fs) -> %% record_fields(RecordName, State) %% find_field(FieldName, Fields) -record_fields(R, St) -> dict:fetch(R, St#exprec.records). +record_fields(R, St) -> maps:get(R, St#exprec.records). find_field(F, [{record_field,_,{atom,_,F},Val} | _]) -> {ok,Val}; find_field(F, [_ | Fs]) -> find_field(F, Fs); diff --git a/lib/stdlib/src/erl_tar.erl b/lib/stdlib/src/erl_tar.erl index a383a0fc67..086e77cd28 100644 --- a/lib/stdlib/src/erl_tar.erl +++ b/lib/stdlib/src/erl_tar.erl @@ -1,8 +1,8 @@ %% %% %CopyrightBegin% -%% -%% Copyright Ericsson AB 1997-2016. All Rights Reserved. -%% +%% +%% Copyright Ericsson AB 1997-2017. All Rights Reserved. +%% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. %% You may obtain a copy of the License at @@ -14,191 +14,245 @@ %% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. %% See the License for the specific language governing permissions and %% limitations under the License. -%% +%% %% %CopyrightEnd% %% +%% This module implements extraction/creation of tar archives. +%% It supports reading most common tar formats, namely V7, STAR, +%% USTAR, GNU, BSD/libarchive, and PAX. It produces archives in USTAR +%% format, unless it must use PAX headers, in which case it produces PAX +%% format. +%% +%% The following references where used: +%% http://www.freebsd.org/cgi/man.cgi?query=tar&sektion=5 +%% http://www.gnu.org/software/tar/manual/html_node/Standard.html +%% http://pubs.opengroup.org/onlinepubs/9699919799/utilities/pax.html -module(erl_tar). -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Purpose: Unix tar (tape archive) utility. -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - --export([init/3, create/2, create/3, extract/1, extract/2, table/1, table/2, - open/2, close/1, add/3, add/4, - t/1, tt/1, format_error/1]). +-export([init/3, + create/2, create/3, + extract/1, extract/2, + table/1, table/2, t/1, tt/1, + open/2, close/1, + add/3, add/4, + format_error/1]). -include_lib("kernel/include/file.hrl"). +-include_lib("erl_tar.hrl"). --record(add_opts, - {read_info, % Fun to use for read file/link info. - chunk_size = 0, % For file reading when sending to sftp. 0=do not chunk - verbose = false :: boolean()}). % Verbose on/off. - -%% Opens a tar archive. - -init(UsrHandle, AccessMode, Fun) when is_function(Fun,2) -> - {ok, {AccessMode,{tar_descriptor,UsrHandle,Fun}}}. - -%%%================================================================ -%%% The open function with friends is to keep the file and binary api of this module -open(Name, Mode) -> - case open_mode(Mode) of - {ok, Access, Raw, Opts} -> - open1(Name, Access, Raw, Opts); - {error, Reason} -> - {error, {Name, Reason}} - end. - -open1({binary,Bin}, read, _Raw, Opts) -> - case file:open(Bin, [ram,binary,read]) of - {ok,File} -> - _ = [ram_file:uncompress(File) || Opts =:= [compressed]], - init(File,read,file_fun()); - Error -> - Error - end; -open1({file, Fd}, read, _Raw, _Opts) -> - init(Fd, read, file_fun()); -open1(Name, Access, Raw, Opts) -> - case file:open(Name, Raw ++ [binary, Access|Opts]) of - {ok, File} -> - init(File, Access, file_fun()); - {error, Reason} -> - {error, {Name, Reason}} - end. - -file_fun() -> - fun(write, {Fd,Data}) -> file:write(Fd, Data); - (position, {Fd,Pos}) -> file:position(Fd, Pos); - (read2, {Fd,Size}) -> file:read(Fd,Size); - (close, Fd) -> file:close(Fd) - end. - -%%% End of file and binary api (except for open_mode/1 downwards -%%%================================================================ - -%% Closes a tar archive. - -close({read, File}) -> - ok = do_close(File); -close({write, File}) -> - PadResult = pad_file(File), - ok = do_close(File), - PadResult; -close(_) -> - {error, einval}. - -%% Adds a file to a tape archive. - -add(File, Name, Options) -> - add(File, Name, Name, Options). -add({write, File}, Name, NameInArchive, Options) -> - Opts = #add_opts{read_info=fun(F) -> file:read_link_info(F) end}, - add1(File, Name, NameInArchive, add_opts(Options, Opts)); -add({read, _File}, _, _, _) -> - {error, eacces}; -add(_, _, _, _) -> - {error, einval}. - -add_opts([dereference|T], Opts) -> - add_opts(T, Opts#add_opts{read_info=fun(F) -> file:read_file_info(F) end}); -add_opts([verbose|T], Opts) -> - add_opts(T, Opts#add_opts{verbose=true}); -add_opts([{chunks,N}|T], Opts) -> - add_opts(T, Opts#add_opts{chunk_size=N}); -add_opts([_|T], Opts) -> - add_opts(T, Opts); -add_opts([], Opts) -> - Opts. - -%% Creates a tar file Name containing the given files. - -create(Name, Filenames) -> - create(Name, Filenames, []). - -%% Creates a tar archive Name containing the given files. -%% Accepted options: verbose, compressed, cooked +%% Converts the short error reason to a descriptive string. +-spec format_error(term()) -> string(). +format_error(invalid_tar_checksum) -> + "Checksum failed"; +format_error(bad_header) -> + "Unrecognized tar header format"; +format_error({bad_header, Reason}) -> + lists:flatten(io_lib:format("Unrecognized tar header format: ~p", [Reason])); +format_error({invalid_header, negative_size}) -> + "Invalid header: negative size"; +format_error(invalid_sparse_header_size) -> + "Invalid sparse header: negative size"; +format_error(invalid_sparse_map_entry) -> + "Invalid sparse map entry"; +format_error({invalid_sparse_map_entry, Reason}) -> + lists:flatten(io_lib:format("Invalid sparse map entry: ~p", [Reason])); +format_error(invalid_end_of_archive) -> + "Invalid end of archive"; +format_error(eof) -> + "Unexpected end of file"; +format_error(integer_overflow) -> + "Failed to parse numeric: integer overflow"; +format_error({misaligned_read, Pos}) -> + lists:flatten(io_lib:format("Read a block which was misaligned: block_size=~p pos=~p", + [?BLOCK_SIZE, Pos])); +format_error(invalid_gnu_1_0_sparsemap) -> + "Invalid GNU sparse map (version 1.0)"; +format_error({invalid_gnu_0_1_sparsemap, Format}) -> + lists:flatten(io_lib:format("Invalid GNU sparse map (version ~s)", [Format])); +format_error({Name,Reason}) -> + lists:flatten(io_lib:format("~ts: ~ts", [Name,format_error(Reason)])); +format_error(Atom) when is_atom(Atom) -> + file:format_error(Atom); +format_error(Term) -> + lists:flatten(io_lib:format("~tp", [Term])). -create(Name, FileList, Options) -> - Mode = lists:filter(fun(X) -> (X=:=compressed) or (X=:=cooked) - end, Options), - case open(Name, [write|Mode]) of - {ok, TarFile} -> - Add = fun({NmInA, NmOrBin}) -> - add(TarFile, NmOrBin, NmInA, Options); - (Nm) -> - add(TarFile, Nm, Nm, Options) - end, - Result = foreach_while_ok(Add, FileList), - case {Result, close(TarFile)} of - {ok, Res} -> Res; - {Res, _} -> Res - end; - Reason -> - Reason - end. +%% Initializes a new reader given a custom file handle and I/O wrappers +-spec init(handle(), write | read, file_op()) -> {ok, reader()} | {error, badarg}. +init(Handle, AccessMode, Fun) when is_function(Fun, 2) -> + Reader = #reader{handle=Handle,access=AccessMode,func=Fun}, + {ok, Pos, Reader2} = do_position(Reader, {cur, 0}), + {ok, Reader2#reader{pos=Pos}}; +init(_Handle, _AccessMode, _Fun) -> + {error, badarg}. +%%%================================================================ %% Extracts all files from the tar file Name. - +-spec extract(open_handle()) -> ok | {error, term()}. extract(Name) -> extract(Name, []). %% Extracts (all) files from the tar file Name. -%% Options accepted: keep_old_files, {files, ListOfFilesToExtract}, verbose, -%% {cwd, AbsoluteDirectory} +%% Options accepted: +%% - cooked: Opens the tar file without mode `raw` +%% - compressed: Uncompresses the tar file when reading +%% - memory: Returns the tar contents as a list of tuples {Name, Bin} +%% - keep_old_files: Extracted files will not overwrite the destination +%% - {files, ListOfFilesToExtract}: Only extract ListOfFilesToExtract +%% - verbose: Prints verbose information about the extraction, +%% - {cwd, AbsoluteDir}: Sets the current working directory for the extraction +-spec extract(open_handle(), [extract_opt()]) -> + ok + | {ok, [{string(), binary()}]} + | {error, term()}. +extract({binary, Bin}, Opts) when is_list(Opts) -> + do_extract({binary, Bin}, Opts); +extract({file, Fd}, Opts) when is_list(Opts) -> + do_extract({file, Fd}, Opts); +extract(#reader{}=Reader, Opts) when is_list(Opts) -> + do_extract(Reader, Opts); +extract(Name, Opts) when is_list(Name); is_binary(Name), is_list(Opts) -> + do_extract(Name, Opts). + +do_extract(Handle, Opts) when is_list(Opts) -> + Opts2 = extract_opts(Opts), + Acc = if Opts2#read_opts.output =:= memory -> []; true -> ok end, + foldl_read(Handle, fun extract1/4, Acc, Opts2). + +extract1(eof, Reader, _, Acc) when is_list(Acc) -> + {ok, {ok, lists:reverse(Acc)}, Reader}; +extract1(eof, Reader, _, Acc) -> + {ok, Acc, Reader}; +extract1(#tar_header{name=Name,size=Size}=Header, Reader, Opts, Acc) -> + case check_extract(Name, Opts) of + true -> + case do_read(Reader, Size) of + {ok, Bin, Reader2} -> + case write_extracted_element(Header, Bin, Opts) of + ok -> + {ok, Acc, Reader2}; + {ok, NameBin} when is_list(Acc) -> + {ok, [NameBin | Acc], Reader2}; + {error, _} = Err -> + throw(Err) + end; + {error, _} = Err -> + throw(Err) + end; + false -> + {ok, Acc, skip_file(Reader)} + end. -extract(Name, Opts) -> - foldl_read(Name, fun extract1/4, ok, extract_opts(Opts)). +%% Checks if the file Name should be extracted. +check_extract(_, #read_opts{files=all}) -> + true; +check_extract(Name, #read_opts{files=Files}) -> + ordsets:is_element(Name, Files). -%% Returns a list of names of the files in the tar file Name. -%% Options accepted: verbose +%%%================================================================ +%% The following table functions produce a list of information about +%% the files contained in the archive. +-type filename() :: string(). +-type typeflag() :: regular | link | symlink | + char | block | directory | + fifo | reserved | unknown. +-type mode() :: non_neg_integer(). +-type uid() :: non_neg_integer(). +-type gid() :: non_neg_integer(). + +-type tar_entry() :: {filename(), + typeflag(), + non_neg_integer(), + calendar:datetime(), + mode(), + uid(), + gid()}. +%% Returns a list of names of the files in the tar file Name. +-spec table(open_handle()) -> {ok, [string()]} | {error, term()}. table(Name) -> table(Name, []). %% Returns a list of names of the files in the tar file Name. %% Options accepted: compressed, verbose, cooked. - -table(Name, Opts) -> +-spec table(open_handle(), [compressed | verbose | cooked]) -> + {ok, [tar_entry()]} | {error, term()}. +table(Name, Opts) when is_list(Opts) -> foldl_read(Name, fun table1/4, [], table_opts(Opts)). +table1(eof, Reader, _, Result) -> + {ok, {ok, lists:reverse(Result)}, Reader}; +table1(#tar_header{}=Header, Reader, #read_opts{verbose=Verbose}, Result) -> + Attrs = table1_attrs(Header, Verbose), + Reader2 = skip_file(Reader), + {ok, [Attrs|Result], Reader2}. + +%% Extracts attributes relevant to table1's output +table1_attrs(#tar_header{typeflag=Typeflag,mode=Mode}=Header, true) -> + Type = typeflag(Typeflag), + Name = Header#tar_header.name, + Mtime = Header#tar_header.mtime, + Uid = Header#tar_header.uid, + Gid = Header#tar_header.gid, + Size = Header#tar_header.size, + {Name, Type, Size, Mtime, Mode, Uid, Gid}; +table1_attrs(#tar_header{name=Name}, _Verbose) -> + Name. + +typeflag(?TYPE_REGULAR) -> regular; +typeflag(?TYPE_REGULAR_A) -> regular; +typeflag(?TYPE_GNU_SPARSE) -> regular; +typeflag(?TYPE_CONT) -> regular; +typeflag(?TYPE_LINK) -> link; +typeflag(?TYPE_SYMLINK) -> symlink; +typeflag(?TYPE_CHAR) -> char; +typeflag(?TYPE_BLOCK) -> block; +typeflag(?TYPE_DIR) -> directory; +typeflag(?TYPE_FIFO) -> fifo; +typeflag(_) -> unknown. +%%%================================================================ %% Comments for printing the contents of a tape archive, %% meant to be invoked from the shell. -t(Name) -> +%% Prints each filename in the archive +-spec t(file:filename()) -> ok | {error, term()}. +t(Name) when is_list(Name); is_binary(Name) -> case table(Name) of - {ok, List} -> - lists:foreach(fun(N) -> ok = io:format("~ts\n", [N]) end, List); - Error -> - Error + {ok, List} -> + lists:foreach(fun(N) -> ok = io:format("~ts\n", [N]) end, List); + Error -> + Error end. +%% Prints verbose information about each file in the archive +-spec tt(open_handle()) -> ok | {error, term()}. tt(Name) -> case table(Name, [verbose]) of - {ok, List} -> - lists:foreach(fun print_header/1, List); - Error -> - Error + {ok, List} -> + lists:foreach(fun print_header/1, List); + Error -> + Error end. +%% Used by tt/1 to print a tar_entry tuple +-spec print_header(tar_entry()) -> ok. print_header({Name, Type, Size, Mtime, Mode, Uid, Gid}) -> io:format("~s~s ~4w/~-4w ~7w ~s ~s\n", - [type_to_string(Type), mode_to_string(Mode), - Uid, Gid, Size, time_to_string(Mtime), Name]). + [type_to_string(Type), mode_to_string(Mode), + Uid, Gid, Size, time_to_string(Mtime), Name]). -type_to_string(regular) -> "-"; +type_to_string(regular) -> "-"; type_to_string(directory) -> "d"; -type_to_string(link) -> "l"; -type_to_string(symlink) -> "s"; -type_to_string(char) -> "c"; -type_to_string(block) -> "b"; -type_to_string(fifo) -> "f"; -type_to_string(_) -> "?". - +type_to_string(link) -> "l"; +type_to_string(symlink) -> "s"; +type_to_string(char) -> "c"; +type_to_string(block) -> "b"; +type_to_string(fifo) -> "f"; +type_to_string(unknown) -> "?". + +%% Converts a numeric mode to its human-readable representation mode_to_string(Mode) -> mode_to_string(Mode, "xwrxwrxwr", []). - mode_to_string(Mode, [C|T], Acc) when Mode band 1 =:= 1 -> mode_to_string(Mode bsr 1, T, [C|Acc]); mode_to_string(Mode, [_|T], Acc) -> @@ -206,6 +260,7 @@ mode_to_string(Mode, [_|T], Acc) -> mode_to_string(_, [], Acc) -> Acc. +%% Converts a datetime tuple to a readable string time_to_string({{Y, Mon, Day}, {H, Min, _}}) -> io_lib:format("~s ~2w ~s:~s ~w", [month(Mon), Day, two_d(H), two_d(Min), Y]). @@ -225,809 +280,1608 @@ month(10) -> "Oct"; month(11) -> "Nov"; month(12) -> "Dec". -%% Converts the short error reason to a descriptive string. +%%%================================================================ +%% The open function with friends is to keep the file and binary api of this module +-type open_handle() :: file:filename() + | {binary, binary()} + | {file, term()}. +-spec open(open_handle(), [write | compressed | cooked]) -> + {ok, reader()} | {error, term()}. +open({binary, Bin}, Mode) when is_binary(Bin) -> + do_open({binary, Bin}, Mode); +open({file, Fd}, Mode) -> + do_open({file, Fd}, Mode); +open(Name, Mode) when is_list(Name); is_binary(Name) -> + do_open(Name, Mode). + +do_open(Name, Mode) when is_list(Mode) -> + case open_mode(Mode) of + {ok, Access, Raw, Opts} -> + open1(Name, Access, Raw, Opts); + {error, Reason} -> + {error, {Name, Reason}} + end. -format_error(bad_header) -> "Bad directory header"; -format_error(eof) -> "Unexpected end of file"; -format_error(symbolic_link_too_long) -> "Symbolic link too long"; -format_error({Name,Reason}) -> - lists:flatten(io_lib:format("~ts: ~ts", [Name,format_error(Reason)])); -format_error(Atom) when is_atom(Atom) -> - file:format_error(Atom); -format_error(Term) -> - lists:flatten(io_lib:format("~tp", [Term])). +open1({binary,Bin}, read, _Raw, Opts) when is_binary(Bin) -> + case file:open(Bin, [ram,binary,read]) of + {ok,File} -> + _ = [ram_file:uncompress(File) || Opts =:= [compressed]], + {ok, #reader{handle=File,access=read,func=fun file_op/2}}; + Error -> + Error + end; +open1({file, Fd}, read, _Raw, _Opts) -> + Reader = #reader{handle=Fd,access=read,func=fun file_op/2}, + case do_position(Reader, {cur, 0}) of + {ok, Pos, Reader2} -> + {ok, Reader2#reader{pos=Pos}}; + {error, _} = Err -> + Err + end; +open1(Name, Access, Raw, Opts) when is_list(Name) or is_binary(Name) -> + case file:open(Name, Raw ++ [binary, Access|Opts]) of + {ok, File} -> + {ok, #reader{handle=File,access=Access,func=fun file_op/2}}; + {error, Reason} -> + {error, {Name, Reason}} + end. +open_mode(Mode) -> + open_mode(Mode, false, [raw], []). -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%% -%%% Useful definitions (also start of implementation). -%%% -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -%% Offset for fields in the tar header. -%% Note that these offsets are ZERO-based as in the POSIX standard -%% document, while binaries use ONE-base offset. Caveat Programmer. - --define(th_name, 0). --define(th_mode, 100). --define(th_uid, 108). --define(th_gid, 116). --define(th_size, 124). --define(th_mtime, 136). --define(th_chksum, 148). --define(th_typeflag, 156). --define(th_linkname, 157). --define(th_magic, 257). --define(th_version, 263). --define(th_prefix, 345). - -%% Length of these fields. - --define(th_name_len, 100). --define(th_mode_len, 8). --define(th_uid_len, 8). --define(th_gid_len, 8). --define(th_size_len, 12). --define(th_mtime_len, 12). --define(th_chksum_len, 8). --define(th_linkname_len, 100). --define(th_magic_len, 6). --define(th_version_len, 2). --define(th_prefix_len, 167). - --record(tar_header, - {name, % Name of file. - mode, % Mode bits. - uid, % User id. - gid, % Group id. - size, % Size of file - mtime, % Last modified (seconds since - % Jan 1, 1970). - chksum, % Checksum of header. - typeflag = [], % Type of file. - linkname = [], % Name of link. - filler = [], - prefix}). % Filename prefix. - --define(record_size, 512). --define(block_size, (512*20)). - - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%% -%%% Adding members to a tar archive. -%%% -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -add1(TarFile, Bin, NameInArchive, Opts) when is_binary(Bin) -> - Now = calendar:now_to_local_time(erlang:timestamp()), - Info = #file_info{size = byte_size(Bin), - type = regular, - access = read_write, - atime = Now, - mtime = Now, - ctime = Now, - mode = 8#100644, - links = 1, - major_device = 0, - minor_device = 0, - inode = 0, - uid = 0, - gid = 0}, - Header = create_header(NameInArchive, Info), - add1(TarFile, NameInArchive, Header, Bin, Opts); -add1(TarFile, Name, NameInArchive, Opts) -> - case read_file_and_info(Name, Opts) of - {ok, Bin, Info} when Info#file_info.type =:= regular -> - Header = create_header(NameInArchive, Info), - add1(TarFile, Name, Header, Bin, Opts); - {ok, PointsTo, Info} when Info#file_info.type =:= symlink -> - if - length(PointsTo) > 100 -> - {error,{PointsTo,symbolic_link_too_long}}; - true -> - Info2 = Info#file_info{size=0}, - Header = create_header(NameInArchive, Info2, PointsTo), - add1(TarFile, Name, Header, list_to_binary([]), Opts) - end; - {ok, _, Info} when Info#file_info.type =:= directory -> - add_directory(TarFile, Name, NameInArchive, Info, Opts); - {ok, _, #file_info{type=Type}} -> - {error, {bad_file_type, Name, Type}}; - {error, Reason} -> - {error, {Name, Reason}} +open_mode(read, _, Raw, _) -> + {ok, read, Raw, []}; +open_mode(write, _, Raw, _) -> + {ok, write, Raw, []}; +open_mode([read|Rest], false, Raw, Opts) -> + open_mode(Rest, read, Raw, Opts); +open_mode([write|Rest], false, Raw, Opts) -> + open_mode(Rest, write, Raw, Opts); +open_mode([compressed|Rest], Access, Raw, Opts) -> + open_mode(Rest, Access, Raw, [compressed|Opts]); +open_mode([cooked|Rest], Access, _Raw, Opts) -> + open_mode(Rest, Access, [], Opts); +open_mode([], Access, Raw, Opts) -> + {ok, Access, Raw, Opts}; +open_mode(_, _, _, _) -> + {error, einval}. + +file_op(write, {Fd, Data}) -> + file:write(Fd, Data); +file_op(position, {Fd, Pos}) -> + file:position(Fd, Pos); +file_op(read2, {Fd, Size}) -> + file:read(Fd, Size); +file_op(close, Fd) -> + file:close(Fd). + +%% Closes a tar archive. +-spec close(reader()) -> ok | {error, term()}. +close(#reader{access=read}=Reader) -> + ok = do_close(Reader); +close(#reader{access=write}=Reader) -> + {ok, Reader2} = pad_file(Reader), + ok = do_close(Reader2), + ok; +close(_) -> + {error, einval}. + +pad_file(#reader{pos=Pos}=Reader) -> + %% There must be at least two zero blocks at the end. + PadCurrent = skip_padding(Pos+?BLOCK_SIZE), + Padding = <<0:PadCurrent/unit:8>>, + do_write(Reader, [Padding, ?ZERO_BLOCK, ?ZERO_BLOCK]). + + +%%%================================================================ +%% Creation/modification of tar archives + +%% Creates a tar file Name containing the given files. +-spec create(file:filename(), filelist()) -> ok | {error, {string(), term()}}. +create(Name, FileList) when is_list(Name); is_binary(Name) -> + create(Name, FileList, []). + +%% Creates a tar archive Name containing the given files. +%% Accepted options: verbose, compressed, cooked +-spec create(file:filename(), filelist(), [create_opt()]) -> + ok | {error, term()} | {error, {string(), term()}}. +create(Name, FileList, Options) when is_list(Name); is_binary(Name) -> + Mode = lists:filter(fun(X) -> (X=:=compressed) or (X=:=cooked) + end, Options), + case open(Name, [write|Mode]) of + {ok, TarFile} -> + do_create(TarFile, FileList, Options); + {error, _} = Err -> + Err end. -add1(Tar, Name, Header, chunked, Options) -> - add_verbose(Options, "a ~ts [chunked ", [Name]), - try - ok = do_write(Tar, Header), - {ok,D} = file:open(Name, [read,binary]), - {ok,NumBytes} = add_read_write_chunks(D, Tar, Options#add_opts.chunk_size, 0, Options), - _ = file:close(D), - ok = do_write(Tar, padding(NumBytes,?record_size)) - of - ok -> - add_verbose(Options, "~n", []), - ok - catch - error:{badmatch,{error,Error}} -> - add_verbose(Options, "~n", []), - {error,{Name,Error}} +do_create(TarFile, [], _Opts) -> + close(TarFile); +do_create(TarFile, [{NameInArchive, NameOrBin}|Rest], Opts) -> + case add(TarFile, NameOrBin, NameInArchive, Opts) of + ok -> + do_create(TarFile, Rest, Opts); + {error, _} = Err -> + _ = close(TarFile), + Err end; -add1(Tar, Name, Header, Bin, Options) -> - add_verbose(Options, "a ~ts~n", [Name]), - do_write(Tar, [Header, Bin, padding(byte_size(Bin), ?record_size)]). - -add_read_write_chunks(D, Tar, ChunkSize, SumNumBytes, Options) -> - case file:read(D, ChunkSize) of - {ok,Bin} -> - ok = do_write(Tar, Bin), - add_verbose(Options, ".", []), - add_read_write_chunks(D, Tar, ChunkSize, SumNumBytes+byte_size(Bin), Options); - eof -> - add_verbose(Options, "]", []), - {ok,SumNumBytes}; - Other -> - Other +do_create(TarFile, [Name|Rest], Opts) -> + case add(TarFile, Name, Name, Opts) of + ok -> + do_create(TarFile, Rest, Opts); + {error, _} = Err -> + _ = close(TarFile), + Err end. -add_directory(TarFile, DirName, NameInArchive, Info, Options) -> +%% Adds a file to a tape archive. +-type add_type() :: string() + | {string(), string()} + | {string(), binary()}. +-spec add(reader(), add_type(), [add_opt()]) -> ok | {error, term()}. +add(Reader, {NameInArchive, Name}, Opts) + when is_list(NameInArchive), is_list(Name) -> + do_add(Reader, Name, NameInArchive, Opts); +add(Reader, {NameInArchive, Bin}, Opts) + when is_list(NameInArchive), is_binary(Bin) -> + do_add(Reader, Bin, NameInArchive, Opts); +add(Reader, Name, Opts) when is_list(Name) -> + do_add(Reader, Name, Name, Opts). + + +-spec add(reader(), string() | binary(), string(), [add_opt()]) -> + ok | {error, term()}. +add(Reader, NameOrBin, NameInArchive, Options) + when is_list(NameOrBin); is_binary(NameOrBin), + is_list(NameInArchive), is_list(Options) -> + do_add(Reader, NameOrBin, NameInArchive, Options). + +do_add(#reader{access=write}=Reader, Name, NameInArchive, Options) + when is_list(NameInArchive), is_list(Options) -> + Opts = #add_opts{read_info=fun(F) -> file:read_link_info(F) end}, + add1(Reader, Name, NameInArchive, add_opts(Options, Opts)); +do_add(#reader{access=read},_,_,_) -> + {error, eacces}; +do_add(Reader,_,_,_) -> + {error, {badarg, Reader}}. + +add_opts([dereference|T], Opts) -> + add_opts(T, Opts#add_opts{read_info=fun(F) -> file:read_file_info(F) end}); +add_opts([verbose|T], Opts) -> + add_opts(T, Opts#add_opts{verbose=true}); +add_opts([{chunks,N}|T], Opts) -> + add_opts(T, Opts#add_opts{chunk_size=N}); +add_opts([_|T], Opts) -> + add_opts(T, Opts); +add_opts([], Opts) -> + Opts. + +add1(#reader{}=Reader, Name, NameInArchive, #add_opts{read_info=ReadInfo}=Opts) + when is_list(Name) -> + Res = case ReadInfo(Name) of + {error, Reason0} -> + {error, {Name, Reason0}}; + {ok, #file_info{type=symlink}=Fi} -> + add_verbose(Opts, "a ~ts~n", [NameInArchive]), + {ok, Linkname} = file:read_link(Name), + Header = fileinfo_to_header(NameInArchive, Fi, Linkname), + add_header(Reader, Header, Opts); + {ok, #file_info{type=regular}=Fi} -> + add_verbose(Opts, "a ~ts~n", [NameInArchive]), + Header = fileinfo_to_header(NameInArchive, Fi, false), + {ok, Reader2} = add_header(Reader, Header, Opts), + FileSize = Header#tar_header.size, + {ok, FileSize, Reader3} = do_copy(Reader2, Name, Opts), + Padding = skip_padding(FileSize), + Pad = <<0:Padding/unit:8>>, + do_write(Reader3, Pad); + {ok, #file_info{type=directory}=Fi} -> + add_directory(Reader, Name, NameInArchive, Fi, Opts); + {ok, #file_info{}=Fi} -> + add_verbose(Opts, "a ~ts~n", [NameInArchive]), + Header = fileinfo_to_header(NameInArchive, Fi, false), + add_header(Reader, Header, Opts) + end, + case Res of + ok -> ok; + {ok, _Reader} -> ok; + {error, _Reason} = Err -> Err + end; +add1(Reader, Bin, NameInArchive, Opts) when is_binary(Bin) -> + add_verbose(Opts, "a ~ts~n", [NameInArchive]), + Now = calendar:now_to_local_time(erlang:timestamp()), + Header = #tar_header{ + name = NameInArchive, + size = byte_size(Bin), + typeflag = ?TYPE_REGULAR, + atime = Now, + mtime = Now, + ctime = Now, + mode = 8#100644}, + {ok, Reader2} = add_header(Reader, Header, Opts), + Padding = skip_padding(byte_size(Bin)), + Data = [Bin, <<0:Padding/unit:8>>], + case do_write(Reader2, Data) of + {ok, _Reader3} -> ok; + {error, Reason} -> {error, {NameInArchive, Reason}} + end. + +add_directory(Reader, DirName, NameInArchive, Info, Opts) -> case file:list_dir(DirName) of - {ok, []} -> - add_verbose(Options, "a ~ts~n", [DirName]), - Header = create_header(NameInArchive, Info), - do_write(TarFile, Header); - {ok, Files} -> - Add = fun (File) -> - add1(TarFile, - filename:join(DirName, File), - filename:join(NameInArchive, File), - Options) end, - foreach_while_ok(Add, Files); - {error, Reason} -> - {error, {DirName, Reason}} + {ok, []} -> + add_verbose(Opts, "a ~ts~n", [NameInArchive]), + Header = fileinfo_to_header(NameInArchive, Info, false), + add_header(Reader, Header, Opts); + {ok, Files} -> + add_verbose(Opts, "a ~ts~n", [NameInArchive]), + try add_files(Reader, Files, DirName, NameInArchive, Opts) of + ok -> ok; + {error, _} = Err -> Err + catch + throw:{error, {_Name, _Reason}} = Err -> Err; + throw:{error, Reason} -> {error, {DirName, Reason}} + end; + {error, Reason} -> + {error, {DirName, Reason}} end. - -%% Creates a header for file in a tar file. - -create_header(Name, Info) -> - create_header(Name, Info, []). -create_header(Name, #file_info {mode=Mode, uid=Uid, gid=Gid, - size=Size, mtime=Mtime0, type=Type}, Linkname) -> - Mtime = posix_time(erlang:localtime_to_universaltime(Mtime0)), - {Prefix,Suffix} = split_filename(Name), - H0 = [to_string(Suffix, 100), - to_octal(Mode, 8), - to_octal(Uid, 8), - to_octal(Gid, 8), - to_octal(Size, ?th_size_len), - to_octal(Mtime, ?th_mtime_len), - <<" ">>, - file_type(Type), - to_string(Linkname, ?th_linkname_len), - "ustar",0, - "00", - zeroes(?th_prefix-?th_version-?th_version_len), - to_string(Prefix, ?th_prefix_len)], - H = list_to_binary(H0), - 512 = byte_size(H), %Assertion. - ChksumString = to_octal(checksum(H), 6, [0,$\s]), - <<Before:?th_chksum/binary,_:?th_chksum_len/binary,After/binary>> = H, - [Before,ChksumString,After]. - -file_type(regular) -> $0; -file_type(symlink) -> $2; -file_type(directory) -> $5. - -to_octal(Int, Count) when Count > 1 -> - to_octal(Int, Count-1, [0]). - -to_octal(_, 0, Result) -> Result; -to_octal(Int, Count, Result) -> - to_octal(Int div 8, Count-1, [Int rem 8 + $0|Result]). - -to_string(Str0, Count) -> - Str = case file:native_name_encoding() of - utf8 -> - unicode:characters_to_binary(Str0); - latin1 -> - list_to_binary(Str0) - end, - case byte_size(Str) of - Size when Size < Count -> - [Str|zeroes(Count-Size)]; - _ -> Str + +add_files(_Reader, [], _Dir, _DirInArchive, _Opts) -> + ok; +add_files(Reader, [Name|Rest], Dir, DirInArchive, #add_opts{read_info=Info}=Opts) -> + FullName = filename:join(Dir, Name), + NameInArchive = filename:join(DirInArchive, Name), + Res = case Info(FullName) of + {error, Reason} -> + {error, {FullName, Reason}}; + {ok, #file_info{type=directory}=Fi} -> + add_directory(Reader, FullName, NameInArchive, Fi, Opts); + {ok, #file_info{type=symlink}=Fi} -> + add_verbose(Opts, "a ~ts~n", [NameInArchive]), + {ok, Linkname} = file:read_link(FullName), + Header = fileinfo_to_header(NameInArchive, Fi, Linkname), + add_header(Reader, Header, Opts); + {ok, #file_info{type=regular}=Fi} -> + add_verbose(Opts, "a ~ts~n", [NameInArchive]), + Header = fileinfo_to_header(NameInArchive, Fi, false), + {ok, Reader2} = add_header(Reader, Header, Opts), + FileSize = Header#tar_header.size, + {ok, FileSize, Reader3} = do_copy(Reader2, FullName, Opts), + Padding = skip_padding(FileSize), + Pad = <<0:Padding/unit:8>>, + do_write(Reader3, Pad); + {ok, #file_info{}=Fi} -> + add_verbose(Opts, "a ~ts~n", [NameInArchive]), + Header = fileinfo_to_header(NameInArchive, Fi, false), + add_header(Reader, Header, Opts) + end, + case Res of + ok -> add_files(Reader, Rest, Dir, DirInArchive, Opts); + {ok, ReaderNext} -> add_files(ReaderNext, Rest, Dir, DirInArchive, Opts); + {error, _} = Err -> Err end. -%% Pads out end of file. - -pad_file(File) -> - {ok,Position} = do_position(File, {cur,0}), - %% There must be at least two zero records at the end. - Fill = case ?block_size - (Position rem ?block_size) of - Fill0 when Fill0 < 2*?record_size -> - %% We need to another block here to ensure that there - %% are at least two zero records at the end. - Fill0 + ?block_size; - Fill0 -> - %% Large enough. - Fill0 - end, - do_write(File, zeroes(Fill)). - -split_filename(Name) when length(Name) =< ?th_name_len -> - {"", Name}; -split_filename(Name0) -> - split_filename(lists:reverse(filename:split(Name0)), [], [], 0). - -split_filename([Comp|Rest], Prefix, Suffix, Len) - when Len+length(Comp) < ?th_name_len -> - split_filename(Rest, Prefix, [Comp|Suffix], Len+length(Comp)+1); -split_filename([Comp|Rest], Prefix, Suffix, Len) -> - split_filename(Rest, [Comp|Prefix], Suffix, Len+length(Comp)+1); -split_filename([], Prefix, Suffix, _) -> - {filename:join(Prefix),filename:join(Suffix)}. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%% -%%% Retrieving files from a tape archive. -%%% -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -%% Options used when reading a tar archive. - --record(read_opts, - {cwd :: string(), % Current working directory. - keep_old_files = false :: boolean(), % Owerwrite or not. - files = all, % Set of files to extract - % (or all). - output = file :: 'file' | 'memory', - open_mode = [], % Open mode options. - verbose = false :: boolean()}). % Verbose on/off. +format_string(String, Size) when length(String) > Size -> + throw({error, {write_string, field_too_long}}); +format_string(String, Size) -> + Ascii = to_ascii(String), + if byte_size(Ascii) < Size -> + [Ascii, 0]; + true -> + Ascii + end. -extract_opts(List) -> - extract_opts(List, default_options()). +format_octal(Octal) -> + iolist_to_binary(io_lib:fwrite("~.8B", [Octal])). + +add_header(#reader{}=Reader, #tar_header{}=Header, Opts) -> + {ok, Iodata} = build_header(Header, Opts), + do_write(Reader, Iodata). + +write_to_block(Block, IoData, Start) when is_list(IoData) -> + write_to_block(Block, iolist_to_binary(IoData), Start); +write_to_block(Block, Bin, Start) when is_binary(Bin) -> + Size = byte_size(Bin), + <<Head:Start/unit:8, _:Size/unit:8, Rest/binary>> = Block, + <<Head:Start/unit:8, Bin/binary, Rest/binary>>. + +build_header(#tar_header{}=Header, Opts) -> + #tar_header{ + name=Name, + mode=Mode, + uid=Uid, + gid=Gid, + size=Size, + typeflag=Type, + linkname=Linkname, + uname=Uname, + gname=Gname, + devmajor=Devmaj, + devminor=Devmin + } = Header, + Mtime = datetime_to_posix(Header#tar_header.mtime), + + Block0 = ?ZERO_BLOCK, + {Block1, Pax0} = write_string(Block0, ?V7_NAME, ?V7_NAME_LEN, Name, ?PAX_PATH, #{}), + Block2 = write_octal(Block1, ?V7_MODE, ?V7_MODE_LEN, Mode), + {Block3, Pax1} = write_numeric(Block2, ?V7_UID, ?V7_UID_LEN, Uid, ?PAX_UID, Pax0), + {Block4, Pax2} = write_numeric(Block3, ?V7_GID, ?V7_GID_LEN, Gid, ?PAX_GID, Pax1), + {Block5, Pax3} = write_numeric(Block4, ?V7_SIZE, ?V7_SIZE_LEN, Size, ?PAX_SIZE, Pax2), + {Block6, Pax4} = write_numeric(Block5, ?V7_MTIME, ?V7_MTIME_LEN, Mtime, ?PAX_NONE, Pax3), + {Block7, Pax5} = write_string(Block6, ?V7_TYPE, ?V7_TYPE_LEN, <<Type>>, ?PAX_NONE, Pax4), + {Block8, Pax6} = write_string(Block7, ?V7_LINKNAME, ?V7_LINKNAME_LEN, + Linkname, ?PAX_LINKPATH, Pax5), + {Block9, Pax7} = write_string(Block8, ?USTAR_UNAME, ?USTAR_UNAME_LEN, + Uname, ?PAX_UNAME, Pax6), + {Block10, Pax8} = write_string(Block9, ?USTAR_GNAME, ?USTAR_GNAME_LEN, + Gname, ?PAX_GNAME, Pax7), + {Block11, Pax9} = write_numeric(Block10, ?USTAR_DEVMAJ, ?USTAR_DEVMAJ_LEN, + Devmaj, ?PAX_NONE, Pax8), + {Block12, Pax10} = write_numeric(Block11, ?USTAR_DEVMIN, ?USTAR_DEVMIN_LEN, + Devmin, ?PAX_NONE, Pax9), + {Block13, Pax11} = set_path(Block12, Pax10), + PaxEntry = case maps:size(Pax11) of + 0 -> []; + _ -> build_pax_entry(Header, Pax11, Opts) + end, + Block14 = set_format(Block13, ?FORMAT_USTAR), + Block15 = set_checksum(Block14), + {ok, [PaxEntry, Block15]}. + +set_path(Block0, Pax) -> + %% only use ustar header when name is too long + case maps:get(?PAX_PATH, Pax, nil) of + nil -> + {Block0, Pax}; + PaxPath -> + case split_ustar_path(PaxPath) of + {ok, UstarName, UstarPrefix} -> + {Block1, _} = write_string(Block0, ?V7_NAME, ?V7_NAME_LEN, + UstarName, ?PAX_NONE, #{}), + {Block2, _} = write_string(Block1, ?USTAR_PREFIX, ?USTAR_PREFIX_LEN, + UstarPrefix, ?PAX_NONE, #{}), + {Block2, maps:remove(?PAX_PATH, Pax)}; + false -> + {Block0, Pax} + end + end. -table_opts(List) -> - read_opts(List, default_options()). +set_format(Block0, Format) + when Format =:= ?FORMAT_USTAR; Format =:= ?FORMAT_PAX -> + Block1 = write_to_block(Block0, ?MAGIC_USTAR, ?USTAR_MAGIC), + write_to_block(Block1, ?VERSION_USTAR, ?USTAR_VERSION); +set_format(_Block, Format) -> + throw({error, {invalid_format, Format}}). + +set_checksum(Block) -> + Checksum = compute_checksum(Block), + write_octal(Block, ?V7_CHKSUM, ?V7_CHKSUM_LEN, Checksum). + +build_pax_entry(Header, PaxAttrs, Opts) -> + Path = Header#tar_header.name, + Filename = filename:basename(Path), + Dir = filename:dirname(Path), + Path2 = filename:join([Dir, "PaxHeaders.0", Filename]), + AsciiPath = to_ascii(Path2), + Path3 = if byte_size(AsciiPath) > ?V7_NAME_LEN -> + binary_part(AsciiPath, 0, ?V7_NAME_LEN - 1); + true -> + AsciiPath + end, + Keys = maps:keys(PaxAttrs), + SortedKeys = lists:sort(Keys), + PaxFile = build_pax_file(SortedKeys, PaxAttrs), + Size = byte_size(PaxFile), + Padding = (?BLOCK_SIZE - + (byte_size(PaxFile) rem ?BLOCK_SIZE)) rem ?BLOCK_SIZE, + Pad = <<0:Padding/unit:8>>, + PaxHeader = #tar_header{ + name=unicode:characters_to_list(Path3), + size=Size, + mtime=Header#tar_header.mtime, + atime=Header#tar_header.atime, + ctime=Header#tar_header.ctime, + typeflag=?TYPE_X_HEADER + }, + {ok, PaxHeaderData} = build_header(PaxHeader, Opts), + [PaxHeaderData, PaxFile, Pad]. + +build_pax_file(Keys, PaxAttrs) -> + build_pax_file(Keys, PaxAttrs, []). +build_pax_file([], _, Acc) -> + unicode:characters_to_binary(Acc); +build_pax_file([K|Rest], Attrs, Acc) -> + V = maps:get(K, Attrs), + Size = sizeof(K) + sizeof(V) + 3, + Size2 = sizeof(Size) + Size, + Key = to_string(K), + Value = to_string(V), + Record = unicode:characters_to_binary(io_lib:format("~B ~ts=~ts\n", [Size2, Key, Value])), + if byte_size(Record) =/= Size2 -> + Size3 = byte_size(Record), + Record2 = io_lib:format("~B ~ts=~ts\n", [Size3, Key, Value]), + build_pax_file(Rest, Attrs, [Acc, Record2]); + true -> + build_pax_file(Rest, Attrs, [Acc, Record]) + end. -default_options() -> - {ok, Cwd} = file:get_cwd(), - #read_opts{cwd=Cwd}. +sizeof(Bin) when is_binary(Bin) -> + byte_size(Bin); +sizeof(List) when is_list(List) -> + length(List); +sizeof(N) when is_integer(N) -> + byte_size(integer_to_binary(N)); +sizeof(N) when is_float(N) -> + byte_size(float_to_binary(N)). + +to_string(Bin) when is_binary(Bin) -> + unicode:characters_to_list(Bin); +to_string(List) when is_list(List) -> + List; +to_string(N) when is_integer(N) -> + integer_to_list(N); +to_string(N) when is_float(N) -> + float_to_list(N). + +split_ustar_path(Path) -> + Len = length(Path), + NotAscii = not is_ascii(Path), + if Len =< ?V7_NAME_LEN; NotAscii -> + false; + true -> + PathBin = binary:list_to_bin(Path), + case binary:split(PathBin, [<<$/>>], [global, trim_all]) of + [Part] when byte_size(Part) >= ?V7_NAME_LEN -> + false; + Parts -> + case lists:last(Parts) of + Name when byte_size(Name) >= ?V7_NAME_LEN -> + false; + Name -> + Parts2 = lists:sublist(Parts, length(Parts) - 1), + join_split_ustar_path(Parts2, {ok, Name, nil}) + end + end + end. -%% Parse options for extract. +join_split_ustar_path([], Acc) -> + Acc; +join_split_ustar_path([Part|_], {ok, _, nil}) + when byte_size(Part) > ?USTAR_PREFIX_LEN -> + false; +join_split_ustar_path([Part|_], {ok, _Name, Acc}) + when (byte_size(Part)+byte_size(Acc)) > ?USTAR_PREFIX_LEN -> + false; +join_split_ustar_path([Part|Rest], {ok, Name, nil}) -> + join_split_ustar_path(Rest, {ok, Name, Part}); +join_split_ustar_path([Part|Rest], {ok, Name, Acc}) -> + join_split_ustar_path(Rest, {ok, Name, <<Acc/binary,$/,Part/binary>>}). + +datetime_to_posix(DateTime) -> + Epoch = calendar:datetime_to_gregorian_seconds(?EPOCH), + Secs = calendar:datetime_to_gregorian_seconds(DateTime), + case Secs - Epoch of + N when N < 0 -> 0; + N -> N + end. -extract_opts([keep_old_files|Rest], Opts) -> - extract_opts(Rest, Opts#read_opts{keep_old_files=true}); -extract_opts([{cwd, Cwd}|Rest], Opts) -> - extract_opts(Rest, Opts#read_opts{cwd=Cwd}); -extract_opts([{files, Files}|Rest], Opts) -> - Set = ordsets:from_list(Files), - extract_opts(Rest, Opts#read_opts{files=Set}); -extract_opts([memory|Rest], Opts) -> - extract_opts(Rest, Opts#read_opts{output=memory}); -extract_opts([compressed|Rest], Opts=#read_opts{open_mode=OpenMode}) -> - extract_opts(Rest, Opts#read_opts{open_mode=[compressed|OpenMode]}); -extract_opts([cooked|Rest], Opts=#read_opts{open_mode=OpenMode}) -> - extract_opts(Rest, Opts#read_opts{open_mode=[cooked|OpenMode]}); -extract_opts([verbose|Rest], Opts) -> - extract_opts(Rest, Opts#read_opts{verbose=true}); -extract_opts([Other|Rest], Opts) -> - extract_opts(Rest, read_opts([Other], Opts)); -extract_opts([], Opts) -> - Opts. +write_octal(Block, Pos, Size, X) -> + Octal = zero_pad(format_octal(X), Size-1), + if byte_size(Octal) < Size -> + write_to_block(Block, Octal, Pos); + true -> + throw({error, {write_failed, octal_field_too_long}}) + end. -%% Common options for all read operations. +write_string(Block, Pos, Size, Str, PaxAttr, Pax0) -> + NotAscii = not is_ascii(Str), + if PaxAttr =/= ?PAX_NONE andalso (length(Str) > Size orelse NotAscii) -> + Pax1 = maps:put(PaxAttr, Str, Pax0), + {Block, Pax1}; + true -> + Formatted = format_string(Str, Size), + {write_to_block(Block, Formatted, Pos), Pax0} + end. +write_numeric(Block, Pos, Size, X, PaxAttr, Pax0) -> + %% attempt octal + Octal = zero_pad(format_octal(X), Size-1), + if byte_size(Octal) < Size -> + {write_to_block(Block, [Octal, 0], Pos), Pax0}; + PaxAttr =/= ?PAX_NONE -> + Pax1 = maps:put(PaxAttr, X, Pax0), + {Block, Pax1}; + true -> + throw({error, {write_failed, numeric_field_too_long}}) + end. -read_opts([compressed|Rest], Opts=#read_opts{open_mode=OpenMode}) -> - read_opts(Rest, Opts#read_opts{open_mode=[compressed|OpenMode]}); -read_opts([cooked|Rest], Opts=#read_opts{open_mode=OpenMode}) -> - read_opts(Rest, Opts#read_opts{open_mode=[cooked|OpenMode]}); -read_opts([verbose|Rest], Opts) -> - read_opts(Rest, Opts#read_opts{verbose=true}); -read_opts([_|Rest], Opts) -> - read_opts(Rest, Opts); -read_opts([], Opts) -> - Opts. +zero_pad(Str, Size) when byte_size(Str) >= Size -> + Str; +zero_pad(Str, Size) -> + Padding = Size - byte_size(Str), + Pad = binary:copy(<<$0>>, Padding), + <<Pad/binary, Str/binary>>. -foldl_read({AccessMode,TD={tar_descriptor,_UsrHandle,_AccessFun}}, Fun, Accu, Opts) -> - case AccessMode of - read -> - foldl_read0(TD, Fun, Accu, Opts); - _ -> - {error,{read_mode_expected,AccessMode}} - end; -foldl_read(TarName, Fun, Accu, Opts) -> - case open(TarName, [read|Opts#read_opts.open_mode]) of - {ok, {read, File}} -> - Result = foldl_read0(File, Fun, Accu, Opts), - ok = do_close(File), - Result; - Error -> - Error + +%%%================================================================ +%% Functions for creating or modifying tar archives + +read_block(Reader) -> + case do_read(Reader, ?BLOCK_SIZE) of + eof -> + throw({error, eof}); + %% Two zero blocks mark the end of the archive + {ok, ?ZERO_BLOCK, Reader1} -> + case do_read(Reader1, ?BLOCK_SIZE) of + eof -> + % This is technically a malformed end-of-archive marker, + % as two ZERO_BLOCKs are expected as the marker, + % but if we've already made it this far, we should just ignore it + eof; + {ok, ?ZERO_BLOCK, _Reader2} -> + eof; + {ok, _Block, _Reader2} -> + throw({error, invalid_end_of_archive}); + {error,_} = Err -> + throw(Err) + end; + {ok, Block, Reader1} when is_binary(Block) -> + {ok, Block, Reader1}; + {error, _} = Err -> + throw(Err) end. -foldl_read0(File, Fun, Accu, Opts) -> - case catch foldl_read1(Fun, Accu, File, Opts) of - {'EXIT', Reason} -> - exit(Reason); - {error, {Reason, Format, Args}} -> - read_verbose(Opts, Format, Args), - {error, Reason}; - {error, Reason} -> - {error, Reason}; - Ok -> - Ok +get_header(#reader{}=Reader) -> + case read_block(Reader) of + eof -> + eof; + {ok, Block, Reader1} -> + convert_header(Block, Reader1) end. -foldl_read1(Fun, Accu0, File, Opts) -> - case get_header(File) of - eof -> - Fun(eof, File, Opts, Accu0); - Header -> - {ok, NewAccu} = Fun(Header, File, Opts, Accu0), - foldl_read1(Fun, NewAccu, File, Opts) +%% Converts the tar header to a record. +to_v7(Bin) when is_binary(Bin), byte_size(Bin) =:= ?BLOCK_SIZE -> + #header_v7{ + name=binary_part(Bin, ?V7_NAME, ?V7_NAME_LEN), + mode=binary_part(Bin, ?V7_MODE, ?V7_MODE_LEN), + uid=binary_part(Bin, ?V7_UID, ?V7_UID_LEN), + gid=binary_part(Bin, ?V7_GID, ?V7_GID_LEN), + size=binary_part(Bin, ?V7_SIZE, ?V7_SIZE_LEN), + mtime=binary_part(Bin, ?V7_MTIME, ?V7_MTIME_LEN), + checksum=binary_part(Bin, ?V7_CHKSUM, ?V7_CHKSUM_LEN), + typeflag=binary:at(Bin, ?V7_TYPE), + linkname=binary_part(Bin, ?V7_LINKNAME, ?V7_LINKNAME_LEN) + }; +to_v7(_) -> + {error, header_block_too_small}. + +to_gnu(#header_v7{}=V7, Bin) + when is_binary(Bin), byte_size(Bin) =:= ?BLOCK_SIZE -> + #header_gnu{ + header_v7=V7, + magic=binary_part(Bin, ?GNU_MAGIC, ?GNU_MAGIC_LEN), + version=binary_part(Bin, ?GNU_VERSION, ?GNU_VERSION_LEN), + uname=binary_part(Bin, 265, 32), + gname=binary_part(Bin, 297, 32), + devmajor=binary_part(Bin, 329, 8), + devminor=binary_part(Bin, 337, 8), + atime=binary_part(Bin, 345, 12), + ctime=binary_part(Bin, 357, 12), + sparse=to_sparse_array(binary_part(Bin, 386, 24*4+1)), + real_size=binary_part(Bin, 483, 12) + }. + +to_star(#header_v7{}=V7, Bin) + when is_binary(Bin), byte_size(Bin) =:= ?BLOCK_SIZE -> + #header_star{ + header_v7=V7, + magic=binary_part(Bin, ?USTAR_MAGIC, ?USTAR_MAGIC_LEN), + version=binary_part(Bin, ?USTAR_VERSION, ?USTAR_VERSION_LEN), + uname=binary_part(Bin, ?USTAR_UNAME, ?USTAR_UNAME_LEN), + gname=binary_part(Bin, ?USTAR_GNAME, ?USTAR_GNAME_LEN), + devmajor=binary_part(Bin, ?USTAR_DEVMAJ, ?USTAR_DEVMAJ_LEN), + devminor=binary_part(Bin, ?USTAR_DEVMIN, ?USTAR_DEVMIN_LEN), + prefix=binary_part(Bin, 345, 131), + atime=binary_part(Bin, 476, 12), + ctime=binary_part(Bin, 488, 12), + trailer=binary_part(Bin, ?STAR_TRAILER, ?STAR_TRAILER_LEN) + }. + +to_ustar(#header_v7{}=V7, Bin) + when is_binary(Bin), byte_size(Bin) =:= ?BLOCK_SIZE -> + #header_ustar{ + header_v7=V7, + magic=binary_part(Bin, ?USTAR_MAGIC, ?USTAR_MAGIC_LEN), + version=binary_part(Bin, ?USTAR_VERSION, ?USTAR_VERSION_LEN), + uname=binary_part(Bin, ?USTAR_UNAME, ?USTAR_UNAME_LEN), + gname=binary_part(Bin, ?USTAR_GNAME, ?USTAR_GNAME_LEN), + devmajor=binary_part(Bin, ?USTAR_DEVMAJ, ?USTAR_DEVMAJ_LEN), + devminor=binary_part(Bin, ?USTAR_DEVMIN, ?USTAR_DEVMIN_LEN), + prefix=binary_part(Bin, 345, 155) + }. + +to_sparse_array(Bin) when is_binary(Bin) -> + MaxEntries = byte_size(Bin) div 24, + IsExtended = 1 =:= binary:at(Bin, 24*MaxEntries), + Entries = parse_sparse_entries(Bin, MaxEntries-1, []), + #sparse_array{ + entries=Entries, + max_entries=MaxEntries, + is_extended=IsExtended + }. + +parse_sparse_entries(<<>>, _, Acc) -> + Acc; +parse_sparse_entries(_, -1, Acc) -> + Acc; +parse_sparse_entries(Bin, N, Acc) -> + case to_sparse_entry(binary_part(Bin, N*24, 24)) of + nil -> + parse_sparse_entries(Bin, N-1, Acc); + Entry = #sparse_entry{} -> + parse_sparse_entries(Bin, N-1, [Entry|Acc]) end. -table1(eof, _, _, Result) -> - {ok, lists:reverse(Result)}; -table1(Header = #tar_header{}, File, #read_opts{verbose=true}, Result) -> - #tar_header{name=Name, size=Size, mtime=Mtime, typeflag=Type, - mode=Mode, uid=Uid, gid=Gid} = Header, - skip(File, Size), - {ok, [{Name, Type, Size, posix_to_erlang_time(Mtime), Mode, Uid, Gid}|Result]}; -table1(#tar_header{name=Name, size=Size}, File, _, Result) -> - skip(File, Size), - {ok, [Name|Result]}. - -extract1(eof, _, _, Acc) -> - if - is_list(Acc) -> - {ok, lists:reverse(Acc)}; - true -> - Acc - end; -extract1(Header, File, Opts, Acc) -> - Name = Header#tar_header.name, - case check_extract(Name, Opts) of - true -> - {ok, Bin} = get_element(File, Header), - case write_extracted_element(Header, Bin, Opts) of - ok -> - {ok, Acc}; - {ok, NameBin} when is_list(Acc) -> - {ok, [NameBin | Acc]}; - {ok, NameBin} when Acc =:= ok -> - {ok, [NameBin]} - end; - false -> - ok = skip(File, Header#tar_header.size), - {ok, Acc} +-define(EMPTY_ENTRY, <<0,0,0,0,0,0,0,0,0,0,0,0>>). +to_sparse_entry(Bin) when is_binary(Bin), byte_size(Bin) =:= 24 -> + OffsetBin = binary_part(Bin, 0, 12), + NumBytesBin = binary_part(Bin, 12, 12), + case {OffsetBin, NumBytesBin} of + {?EMPTY_ENTRY, ?EMPTY_ENTRY} -> + nil; + _ -> + #sparse_entry{ + offset=parse_numeric(OffsetBin), + num_bytes=parse_numeric(NumBytesBin)} end. -%% Checks if the file Name should be extracted. +-spec get_format(binary()) -> {ok, pos_integer(), header_v7()} + | ?FORMAT_UNKNOWN + | {error, term()}. +get_format(Bin) when is_binary(Bin), byte_size(Bin) =:= ?BLOCK_SIZE -> + do_get_format(to_v7(Bin), Bin). + +do_get_format({error, _} = Err, _Bin) -> + Err; +do_get_format(#header_v7{}=V7, Bin) + when is_binary(Bin), byte_size(Bin) =:= ?BLOCK_SIZE -> + Checksum = parse_octal(V7#header_v7.checksum), + Chk1 = compute_checksum(Bin), + Chk2 = compute_signed_checksum(Bin), + if Checksum =/= Chk1 andalso Checksum =/= Chk2 -> + ?FORMAT_UNKNOWN; + true -> + %% guess magic + Ustar = to_ustar(V7, Bin), + Star = to_star(V7, Bin), + Magic = Ustar#header_ustar.magic, + Version = Ustar#header_ustar.version, + Trailer = Star#header_star.trailer, + Format = if + Magic =:= ?MAGIC_USTAR, Trailer =:= ?TRAILER_STAR -> + ?FORMAT_STAR; + Magic =:= ?MAGIC_USTAR -> + ?FORMAT_USTAR; + Magic =:= ?MAGIC_GNU, Version =:= ?VERSION_GNU -> + ?FORMAT_GNU; + true -> + ?FORMAT_V7 + end, + {ok, Format, V7} + end. -check_extract(_, #read_opts{files=all}) -> +unpack_format(Format, #header_v7{}=V7, Bin, Reader) + when is_binary(Bin), byte_size(Bin) =:= ?BLOCK_SIZE -> + Mtime = posix_to_erlang_time(parse_numeric(V7#header_v7.mtime)), + Header0 = #tar_header{ + name=parse_string(V7#header_v7.name), + mode=parse_numeric(V7#header_v7.mode), + uid=parse_numeric(V7#header_v7.uid), + gid=parse_numeric(V7#header_v7.gid), + size=parse_numeric(V7#header_v7.size), + mtime=Mtime, + atime=Mtime, + ctime=Mtime, + typeflag=V7#header_v7.typeflag, + linkname=parse_string(V7#header_v7.linkname) + }, + Typeflag = Header0#tar_header.typeflag, + Header1 = if Format > ?FORMAT_V7 -> + unpack_modern(Format, V7, Bin, Header0); + true -> + Name = Header0#tar_header.name, + Header0#tar_header{name=safe_join_path("", Name)} + end, + HeaderOnly = is_header_only_type(Typeflag), + Header2 = if HeaderOnly -> + Header1#tar_header{size=0}; + true -> + Header1 + end, + if Typeflag =:= ?TYPE_GNU_SPARSE -> + Gnu = to_gnu(V7, Bin), + RealSize = parse_numeric(Gnu#header_gnu.real_size), + {Sparsemap, Reader2} = parse_sparse_map(Gnu, Reader), + Header3 = Header2#tar_header{size=RealSize}, + {Header3, new_sparse_file_reader(Reader2, Sparsemap, RealSize)}; + true -> + FileReader = #reg_file_reader{ + handle=Reader, + num_bytes=Header2#tar_header.size, + size=Header2#tar_header.size, + pos = 0 + }, + {Header2, FileReader} + end. + +unpack_modern(Format, #header_v7{}=V7, Bin, #tar_header{}=Header0) + when is_binary(Bin) -> + Typeflag = Header0#tar_header.typeflag, + Ustar = to_ustar(V7, Bin), + H0 = Header0#tar_header{ + uname=parse_string(Ustar#header_ustar.uname), + gname=parse_string(Ustar#header_ustar.gname)}, + H1 = if Typeflag =:= ?TYPE_CHAR + orelse Typeflag =:= ?TYPE_BLOCK -> + Ma = parse_numeric(Ustar#header_ustar.devmajor), + Mi = parse_numeric(Ustar#header_ustar.devminor), + H0#tar_header{ + devmajor=Ma, + devminor=Mi + }; + true -> + H0 + end, + {Prefix, H2} = case Format of + ?FORMAT_USTAR -> + {parse_string(Ustar#header_ustar.prefix), H1}; + ?FORMAT_STAR -> + Star = to_star(V7, Bin), + Prefix0 = parse_string(Star#header_star.prefix), + Atime0 = Star#header_star.atime, + Atime = posix_to_erlang_time(parse_numeric(Atime0)), + Ctime0 = Star#header_star.ctime, + Ctime = posix_to_erlang_time(parse_numeric(Ctime0)), + {Prefix0, H1#tar_header{ + atime=Atime, + ctime=Ctime + }}; + _ -> + {"", H1} + end, + Name = H2#tar_header.name, + H2#tar_header{name=safe_join_path(Prefix, Name)}. + + +safe_join_path([], Name) -> + strip_slashes(Name, both); +safe_join_path(Prefix, []) -> + strip_slashes(Prefix, right); +safe_join_path(Prefix, Name) -> + filename:join(strip_slashes(Prefix, right), strip_slashes(Name, both)). + +strip_slashes(Str, Direction) -> + string:strip(Str, Direction, $/). + +new_sparse_file_reader(Reader, Sparsemap, RealSize) -> + true = validate_sparse_entries(Sparsemap, RealSize), + #sparse_file_reader{ + handle = Reader, + num_bytes = RealSize, + pos = 0, + size = RealSize, + sparse_map = Sparsemap}. + +validate_sparse_entries(Entries, RealSize) -> + validate_sparse_entries(Entries, RealSize, 0, 0). +validate_sparse_entries([], _RealSize, _I, _LastOffset) -> true; -check_extract(Name, #read_opts{files=Files}) -> - ordsets:is_element(Name, Files). +validate_sparse_entries([#sparse_entry{}=Entry|Rest], RealSize, I, LastOffset) -> + Offset = Entry#sparse_entry.offset, + NumBytes = Entry#sparse_entry.num_bytes, + if + Offset > ?MAX_INT64-NumBytes -> + throw({error, {invalid_sparse_map_entry, offset_too_large}}); + Offset+NumBytes > RealSize -> + throw({error, {invalid_sparse_map_entry, offset_too_large}}); + I > 0 andalso LastOffset > Offset -> + throw({error, {invalid_sparse_map_entry, overlapping_offsets}}); + true -> + ok + end, + validate_sparse_entries(Rest, RealSize, I+1, Offset+NumBytes). + + +-spec parse_sparse_map(header_gnu(), reader_type()) -> + {[sparse_entry()], reader_type()}. +parse_sparse_map(#header_gnu{sparse=Sparse}, Reader) + when Sparse#sparse_array.is_extended -> + parse_sparse_map(Sparse, Reader, []); +parse_sparse_map(#header_gnu{sparse=Sparse}, Reader) -> + {Sparse#sparse_array.entries, Reader}. +parse_sparse_map(#sparse_array{is_extended=true,entries=Entries}, Reader, Acc) -> + case read_block(Reader) of + eof -> + throw({error, eof}); + {ok, Block, Reader2} -> + Sparse2 = to_sparse_array(Block), + parse_sparse_map(Sparse2, Reader2, Entries++Acc) + end; +parse_sparse_map(#sparse_array{entries=Entries}, Reader, Acc) -> + Sorted = lists:sort(fun (#sparse_entry{offset=A},#sparse_entry{offset=B}) -> + A =< B + end, Entries++Acc), + {Sorted, Reader}. + +%% Defined by taking the sum of the unsigned byte values of the +%% entire header record, treating the checksum bytes to as ASCII spaces +compute_checksum(<<H1:?V7_CHKSUM/binary, + H2:?V7_CHKSUM_LEN/binary, + Rest:(?BLOCK_SIZE - ?V7_CHKSUM - ?V7_CHKSUM_LEN)/binary, + _/binary>>) -> + C0 = checksum(H1) + (byte_size(H2) * $\s), + C1 = checksum(Rest), + C0 + C1. + +compute_signed_checksum(<<H1:?V7_CHKSUM/binary, + H2:?V7_CHKSUM_LEN/binary, + Rest:(?BLOCK_SIZE - ?V7_CHKSUM - ?V7_CHKSUM_LEN)/binary, + _/binary>>) -> + C0 = signed_checksum(H1) + (byte_size(H2) * $\s), + C1 = signed_checksum(Rest), + C0 + C1. -get_header(File) -> - case do_read(File, ?record_size) of - eof -> - throw({error,eof}); - {ok, Bin} when is_binary(Bin) -> - convert_header(Bin); - {ok, List} -> - convert_header(list_to_binary(List)); - {error, Reason} -> - throw({error, Reason}) - end. +%% Returns the checksum of a binary. +checksum(Bin) -> checksum(Bin, 0). +checksum(<<A/unsigned,Rest/binary>>, Sum) -> + checksum(Rest, Sum+A); +checksum(<<>>, Sum) -> Sum. -%% Converts the tar header to a record. +signed_checksum(Bin) -> signed_checksum(Bin, 0). +signed_checksum(<<A/signed,Rest/binary>>, Sum) -> + signed_checksum(Rest, Sum+A); +signed_checksum(<<>>, Sum) -> Sum. + +-spec parse_numeric(binary()) -> non_neg_integer(). +parse_numeric(<<>>) -> + 0; +parse_numeric(<<First, _/binary>> = Bin) -> + %% check for base-256 format first + %% if the bit is set, then all following bits constitute a two's + %% complement encoded number in big-endian byte order + if + First band 16#80 =/= 0 -> + %% Handling negative numbers relies on the following identity: + %% -a-1 == ^a + %% If the number is negative, we use an inversion mask to invert + %% the data bytes and treat the value as an unsigned number + Inv = if First band 16#40 =/= 0 -> 16#00; true -> 16#FF end, + Bytes = binary:bin_to_list(Bin), + Reducer = fun (C, {I, X}) -> + C1 = C bxor Inv, + C2 = if I =:= 0 -> C1 band 16#7F; true -> C1 end, + if (X bsr 56) > 0 -> + throw({error,integer_overflow}); + true -> + {I+1, (X bsl 8) bor C2} + end + end, + {_, N} = lists:foldl(Reducer, {0,0}, Bytes), + if (N bsr 63) > 0 -> + throw({error, integer_overflow}); + true -> + if Inv =:= 16#FF -> + -1 bxor N; + true -> + N + end + end; + true -> + %% normal case is an octal number + parse_octal(Bin) + end. -convert_header(Bin) when byte_size(Bin) =:= ?record_size -> - case verify_checksum(Bin) of - ok -> - Hd = #tar_header{name=get_name(Bin), - mode=from_octal(Bin, ?th_mode, ?th_mode_len), - uid=from_octal(Bin, ?th_uid, ?th_uid_len), - gid=from_octal(Bin, ?th_gid, ?th_gid_len), - size=from_octal(Bin, ?th_size, ?th_size_len), - mtime=from_octal(Bin, ?th_mtime, ?th_mtime_len), - linkname=from_string(Bin, - ?th_linkname, ?th_linkname_len), - typeflag=typeflag(Bin)}, - convert_header1(Hd); - eof -> - eof +parse_octal(Bin) when is_binary(Bin) -> + %% skip leading/trailing zero bytes and spaces + do_parse_octal(Bin, <<>>). +do_parse_octal(<<>>, <<>>) -> + 0; +do_parse_octal(<<>>, Acc) -> + case io_lib:fread("~8u", binary:bin_to_list(Acc)) of + {error, _} -> throw({error, invalid_tar_checksum}); + {ok, [Octal], []} -> Octal; + {ok, _, _} -> throw({error, invalid_tar_checksum}) end; -convert_header(Bin) when byte_size(Bin) =:= 0 -> +do_parse_octal(<<$\s,Rest/binary>>, Acc) -> + do_parse_octal(Rest, Acc); +do_parse_octal(<<0, Rest/binary>>, Acc) -> + do_parse_octal(Rest, Acc); +do_parse_octal(<<C, Rest/binary>>, Acc) -> + do_parse_octal(Rest, <<Acc/binary, C>>). + +parse_string(Bin) when is_binary(Bin) -> + do_parse_string(Bin, <<>>). +do_parse_string(<<>>, Acc) -> + case unicode:characters_to_list(Acc) of + Str when is_list(Str) -> + Str; + {incomplete, _Str, _Rest} -> + binary:bin_to_list(Acc); + {error, _Str, _Rest} -> + throw({error, {bad_header, invalid_string}}) + end; +do_parse_string(<<0, _/binary>>, Acc) -> + do_parse_string(<<>>, Acc); +do_parse_string(<<C, Rest/binary>>, Acc) -> + do_parse_string(Rest, <<Acc/binary, C>>). + +convert_header(Bin, #reader{pos=Pos}=Reader) + when byte_size(Bin) =:= ?BLOCK_SIZE, (Pos rem ?BLOCK_SIZE) =:= 0 -> + case get_format(Bin) of + ?FORMAT_UNKNOWN -> + throw({error, bad_header}); + {ok, Format, V7} -> + unpack_format(Format, V7, Bin, Reader); + {error, Reason} -> + throw({error, {bad_header, Reason}}) + end; +convert_header(Bin, #reader{pos=Pos}) when byte_size(Bin) =:= ?BLOCK_SIZE -> + throw({error, misaligned_read, Pos}); +convert_header(Bin, _Reader) when byte_size(Bin) =:= 0 -> eof; -convert_header(_Bin) -> +convert_header(_Bin, _Reader) -> throw({error, eof}). -%% Basic sanity. Better set the element size to zero here if the type -%% always is of zero length. - -convert_header1(H) when H#tar_header.typeflag =:= symlink, H#tar_header.size =/= 0 -> - convert_header1(H#tar_header{size=0}); -convert_header1(H) when H#tar_header.typeflag =:= directory, H#tar_header.size =/= 0 -> - convert_header1(H#tar_header{size=0}); -convert_header1(Header) -> - Header. - -typeflag(Bin) -> - [T] = binary_to_list(Bin, ?th_typeflag+1, ?th_typeflag+1), - case T of - 0 -> regular; - $0 -> regular; - $1 -> link; - $2 -> symlink; - $3 -> char; - $4 -> block; - $5 -> directory; - $6 -> fifo; - $7 -> regular; - _ -> unknown +%% Creates a partially-populated header record based +%% on the provided file_info record. If the file is +%% a symlink, then `link` is used as the link target. +%% If the file is a directory, a slash is appended to the name. +fileinfo_to_header(Name, #file_info{}=Fi, Link) when is_list(Name) -> + BaseHeader = #tar_header{name=Name, + mtime=Fi#file_info.mtime, + atime=Fi#file_info.atime, + ctime=Fi#file_info.ctime, + mode=Fi#file_info.mode, + uid=Fi#file_info.uid, + gid=Fi#file_info.gid, + typeflag=?TYPE_REGULAR}, + do_fileinfo_to_header(BaseHeader, Fi, Link). + +do_fileinfo_to_header(Header, #file_info{size=Size,type=regular}, _Link) -> + Header#tar_header{size=Size,typeflag=?TYPE_REGULAR}; +do_fileinfo_to_header(#tar_header{name=Name}=Header, + #file_info{type=directory}, _Link) -> + Header#tar_header{name=Name++"/",typeflag=?TYPE_DIR}; +do_fileinfo_to_header(Header, #file_info{type=symlink}, Link) -> + Header#tar_header{typeflag=?TYPE_SYMLINK,linkname=Link}; +do_fileinfo_to_header(Header, #file_info{type=device,mode=Mode}=Fi, _Link) + when (Mode band ?S_IFMT) =:= ?S_IFCHR -> + Header#tar_header{typeflag=?TYPE_CHAR, + devmajor=Fi#file_info.major_device, + devminor=Fi#file_info.minor_device}; +do_fileinfo_to_header(Header, #file_info{type=device,mode=Mode}=Fi, _Link) + when (Mode band ?S_IFMT) =:= ?S_IFBLK -> + Header#tar_header{typeflag=?TYPE_BLOCK, + devmajor=Fi#file_info.major_device, + devminor=Fi#file_info.minor_device}; +do_fileinfo_to_header(Header, #file_info{type=other,mode=Mode}, _Link) + when (Mode band ?S_IFMT) =:= ?S_FIFO -> + Header#tar_header{typeflag=?TYPE_FIFO}; +do_fileinfo_to_header(Header, Fi, _Link) -> + {error, {invalid_file_type, Header#tar_header.name, Fi}}. + +is_ascii(Str) when is_list(Str) -> + not lists:any(fun (Char) -> Char >= 16#80 end, Str); +is_ascii(Bin) when is_binary(Bin) -> + is_ascii1(Bin). + +is_ascii1(<<>>) -> + true; +is_ascii1(<<C,_Rest/binary>>) when C >= 16#80 -> + false; +is_ascii1(<<_, Rest/binary>>) -> + is_ascii1(Rest). + +to_ascii(Str) when is_list(Str) -> + case is_ascii(Str) of + true -> + unicode:characters_to_binary(Str); + false -> + Chars = lists:filter(fun (Char) -> Char < 16#80 end, Str), + unicode:characters_to_binary(Chars) + end; +to_ascii(Bin) when is_binary(Bin) -> + to_ascii(Bin, <<>>). +to_ascii(<<>>, Acc) -> + Acc; +to_ascii(<<C, Rest/binary>>, Acc) when C < 16#80 -> + to_ascii(Rest, <<Acc/binary,C>>); +to_ascii(<<_, Rest/binary>>, Acc) -> + to_ascii(Rest, Acc). + +is_header_only_type(?TYPE_SYMLINK) -> true; +is_header_only_type(?TYPE_LINK) -> true; +is_header_only_type(?TYPE_DIR) -> true; +is_header_only_type(_) -> false. + +posix_to_erlang_time(Sec) -> + OneMillion = 1000000, + Time = calendar:now_to_datetime({Sec div OneMillion, Sec rem OneMillion, 0}), + erlang:universaltime_to_localtime(Time). + +foldl_read(#reader{access=read}=Reader, Fun, Accu, #read_opts{}=Opts) + when is_function(Fun,4) -> + case foldl_read0(Reader, Fun, Accu, Opts) of + {ok, Result, _Reader2} -> + Result; + {error, _} = Err -> + Err + end; +foldl_read(#reader{access=Access}, _Fun, _Accu, _Opts) -> + {error, {read_mode_expected, Access}}; +foldl_read(TarName, Fun, Accu, #read_opts{}=Opts) + when is_function(Fun,4) -> + try open(TarName, [read|Opts#read_opts.open_mode]) of + {ok, #reader{access=read}=Reader} -> + foldl_read(Reader, Fun, Accu, Opts); + {error, _} = Err -> + Err + catch + throw:Err -> + Err end. -%% Get the name of the file from the prefix and name fields of the -%% tar header. - -get_name(Bin0) -> - List0 = get_name_raw(Bin0), - case file:native_name_encoding() of - utf8 -> - Bin = list_to_binary(List0), - case unicode:characters_to_list(Bin) of - {error,_,_} -> - List0; - List when is_list(List) -> - List - end; - latin1 -> - List0 +foldl_read0(Reader, Fun, Accu, Opts) -> + try foldl_read1(Fun, Accu, Reader, Opts, #{}) of + {ok,_,_} = Ok -> + Ok + catch + throw:{error, {Reason, Format, Args}} -> + read_verbose(Opts, Format, Args), + {error, Reason}; + throw:Err -> + Err end. -get_name_raw(Bin) -> - Name = from_string(Bin, ?th_name, ?th_name_len), - case binary_to_list(Bin, ?th_prefix+1, ?th_prefix+1) of - [0] -> - Name; - [_] -> - Prefix = binary_to_list(Bin, ?th_prefix+1, byte_size(Bin)), - lists:reverse(remove_nulls(Prefix), [$/|Name]) +foldl_read1(Fun, Accu0, Reader0, Opts, ExtraHeaders) -> + {ok, Reader1} = skip_unread(Reader0), + case get_header(Reader1) of + eof -> + Fun(eof, Reader1, Opts, Accu0); + {Header, Reader2} -> + case Header#tar_header.typeflag of + ?TYPE_X_HEADER -> + {ExtraHeaders2, Reader3} = parse_pax(Reader2), + ExtraHeaders3 = maps:merge(ExtraHeaders, ExtraHeaders2), + foldl_read1(Fun, Accu0, Reader3, Opts, ExtraHeaders3); + ?TYPE_GNU_LONGNAME -> + {RealName, Reader3} = get_real_name(Reader2), + ExtraHeaders2 = maps:put(?PAX_PATH, + parse_string(RealName), ExtraHeaders), + foldl_read1(Fun, Accu0, Reader3, Opts, ExtraHeaders2); + ?TYPE_GNU_LONGLINK -> + {RealName, Reader3} = get_real_name(Reader2), + ExtraHeaders2 = maps:put(?PAX_LINKPATH, + parse_string(RealName), ExtraHeaders), + foldl_read1(Fun, Accu0, Reader3, Opts, ExtraHeaders2); + _ -> + Header1 = merge_pax(Header, ExtraHeaders), + {ok, NewAccu, Reader3} = Fun(Header1, Reader2, Opts, Accu0), + foldl_read1(Fun, NewAccu, Reader3, Opts, #{}) + end end. -from_string(Bin, Pos, Len) -> - lists:reverse(remove_nulls(binary_to_list(Bin, Pos+1, Pos+Len))). - -%% Returns all characters up to (but not including) the first null -%% character, in REVERSE order. - -remove_nulls(List) -> - remove_nulls(List, []). - -remove_nulls([0|_], Result) -> - remove_nulls([], Result); -remove_nulls([C|Rest], Result) -> - remove_nulls(Rest, [C|Result]); -remove_nulls([], Result) -> - Result. - -from_octal(Bin, Pos, Len) -> - from_octal(binary_to_list(Bin, Pos+1, Pos+Len)). - -from_octal([$\s|Rest]) -> - from_octal(Rest); -from_octal([Digit|Rest]) when $0 =< Digit, Digit =< $7 -> - from_octal(Rest, Digit-$0); -from_octal(Bin) when is_binary(Bin) -> - from_octal(binary_to_list(Bin)); -from_octal(Other) -> - throw({error, {bad_header, "Bad octal number: ~p", [Other]}}). - -from_octal([Digit|Rest], Result) when $0 =< Digit, Digit =< $7 -> - from_octal(Rest, Result*8+Digit-$0); -from_octal([$\s|_], Result) -> - Result; -from_octal([0|_], Result) -> - Result; -from_octal(Other, _) -> - throw({error, {bad_header, "Bad contents in octal field: ~p", [Other]}}). - -%% Retrieves the next element from the archive. -%% Returns {ok, Bin} | eof | {error, Reason} - -get_element(File, #tar_header{size = 0}) -> - skip_to_next(File), - {ok,<<>>}; -get_element(File, #tar_header{size = Size}) -> - case do_read(File, Size) of - {ok,Bin}=Res when byte_size(Bin) =:= Size -> - skip_to_next(File), - Res; - {ok,List} when length(List) =:= Size -> - skip_to_next(File), - {ok,list_to_binary(List)}; - {ok,_} -> throw({error,eof}); - {error, Reason} -> throw({error, Reason}); - eof -> throw({error,eof}) +%% Applies all known PAX attributes to the current tar header +-spec merge_pax(tar_header(), #{binary() => binary()}) -> tar_header(). +merge_pax(Header, ExtraHeaders) when is_map(ExtraHeaders) -> + do_merge_pax(Header, maps:to_list(ExtraHeaders)). + +do_merge_pax(Header, []) -> + Header; +do_merge_pax(Header, [{?PAX_PATH, Path}|Rest]) -> + do_merge_pax(Header#tar_header{name=unicode:characters_to_list(Path)}, Rest); +do_merge_pax(Header, [{?PAX_LINKPATH, LinkPath}|Rest]) -> + do_merge_pax(Header#tar_header{linkname=unicode:characters_to_list(LinkPath)}, Rest); +do_merge_pax(Header, [{?PAX_GNAME, Gname}|Rest]) -> + do_merge_pax(Header#tar_header{gname=unicode:characters_to_list(Gname)}, Rest); +do_merge_pax(Header, [{?PAX_UNAME, Uname}|Rest]) -> + do_merge_pax(Header#tar_header{uname=unicode:characters_to_list(Uname)}, Rest); +do_merge_pax(Header, [{?PAX_UID, Uid}|Rest]) -> + Uid2 = binary_to_integer(Uid), + do_merge_pax(Header#tar_header{uid=Uid2}, Rest); +do_merge_pax(Header, [{?PAX_GID, Gid}|Rest]) -> + Gid2 = binary_to_integer(Gid), + do_merge_pax(Header#tar_header{gid=Gid2}, Rest); +do_merge_pax(Header, [{?PAX_ATIME, Atime}|Rest]) -> + Atime2 = parse_pax_time(Atime), + do_merge_pax(Header#tar_header{atime=Atime2}, Rest); +do_merge_pax(Header, [{?PAX_MTIME, Mtime}|Rest]) -> + Mtime2 = parse_pax_time(Mtime), + do_merge_pax(Header#tar_header{mtime=Mtime2}, Rest); +do_merge_pax(Header, [{?PAX_CTIME, Ctime}|Rest]) -> + Ctime2 = parse_pax_time(Ctime), + do_merge_pax(Header#tar_header{ctime=Ctime2}, Rest); +do_merge_pax(Header, [{?PAX_SIZE, Size}|Rest]) -> + Size2 = binary_to_integer(Size), + do_merge_pax(Header#tar_header{size=Size2}, Rest); +do_merge_pax(Header, [{<<?PAX_XATTR_STR, _Key/binary>>, _Value}|Rest]) -> + do_merge_pax(Header, Rest); +do_merge_pax(Header, [_Ignore|Rest]) -> + do_merge_pax(Header, Rest). + +%% Returns the time since UNIX epoch as a datetime +-spec parse_pax_time(binary()) -> calendar:datetime(). +parse_pax_time(Bin) when is_binary(Bin) -> + TotalNano = case binary:split(Bin, [<<$.>>]) of + [SecondsStr, NanoStr0] -> + Seconds = binary_to_integer(SecondsStr), + if byte_size(NanoStr0) < ?MAX_NANO_INT_SIZE -> + %% right pad + PaddingN = ?MAX_NANO_INT_SIZE-byte_size(NanoStr0), + Padding = binary:copy(<<$0>>, PaddingN), + NanoStr1 = <<NanoStr0/binary,Padding/binary>>, + Nano = binary_to_integer(NanoStr1), + (Seconds*?BILLION)+Nano; + byte_size(NanoStr0) > ?MAX_NANO_INT_SIZE -> + %% right truncate + NanoStr1 = binary_part(NanoStr0, 0, ?MAX_NANO_INT_SIZE), + Nano = binary_to_integer(NanoStr1), + (Seconds*?BILLION)+Nano; + true -> + (Seconds*?BILLION)+binary_to_integer(NanoStr0) + end; + [SecondsStr] -> + binary_to_integer(SecondsStr)*?BILLION + end, + %% truncate to microseconds + Micro = TotalNano div 1000, + Mega = Micro div 1000000000000, + Secs = Micro div 1000000 - (Mega*1000000), + Micro2 = Micro rem 1000000, + calendar:now_to_datetime({Mega, Secs, Micro2}). + +%% Given a regular file reader, reads the whole file and +%% parses all extended attributes it contains. +parse_pax(#reg_file_reader{handle=Handle,num_bytes=0}) -> + {#{}, Handle}; +parse_pax(#reg_file_reader{handle=Handle0,num_bytes=NumBytes}) -> + case do_read(Handle0, NumBytes) of + {ok, Bytes, Handle1} -> + do_parse_pax(Handle1, Bytes, #{}); + {error, _} = Err -> + throw(Err) end. -%% Verify the checksum in the header. First try an unsigned addition -%% of all bytes in the header (as it should be according to Posix). - -verify_checksum(Bin) -> - <<H1:?th_chksum/binary,CheckStr:?th_chksum_len/binary,H2/binary>> = Bin, - case checksum(H1) + checksum(H2) of - 0 -> eof; - Checksum0 -> - Csum = from_octal(CheckStr), - CsumInit = ?th_chksum_len * $\s, - case Checksum0 + CsumInit of - Csum -> ok; - Unsigned -> - verify_checksum(H1, H2, CsumInit, Csum, Unsigned) - end +do_parse_pax(Reader, <<>>, Headers) -> + {Headers, Reader}; +do_parse_pax(Reader, Bin, Headers) -> + {Key, Value, Residual} = parse_pax_record(Bin), + NewHeaders = maps:put(Key, Value, Headers), + do_parse_pax(Reader, Residual, NewHeaders). + +%% Parse an extended attribute +parse_pax_record(Bin) when is_binary(Bin) -> + case binary:split(Bin, [<<$\n>>]) of + [Record, Residual] -> + case binary:split(Record, [<<$\s>>], [trim_all]) of + [_Len, Record1] -> + case binary:split(Record1, [<<$=>>], [trim_all]) of + [AttrName, AttrValue] -> + {AttrName, AttrValue, Residual}; + _Other -> + throw({error, malformed_pax_record}) + end; + _Other -> + throw({error, malformed_pax_record}) + end; + _Other -> + throw({error, malformed_pax_record}) end. -%% The checksums didn't match. Now try a signed addition. +get_real_name(#reg_file_reader{handle=Handle,num_bytes=0}) -> + {"", Handle}; +get_real_name(#reg_file_reader{handle=Handle0,num_bytes=NumBytes}) -> + case do_read(Handle0, NumBytes) of + {ok, RealName, Handle1} -> + {RealName, Handle1}; + {error, _} = Err -> + throw(Err) + end; +get_real_name(#sparse_file_reader{num_bytes=NumBytes}=Reader0) -> + case do_read(Reader0, NumBytes) of + {ok, RealName, Reader1} -> + {RealName, Reader1}; + {error, _} = Err -> + throw(Err) + end. -verify_checksum(H1, H2, Csum, ShouldBe, Unsigned) -> - case signed_sum(binary_to_list(H1), signed_sum(binary_to_list(H2), Csum)) of - ShouldBe -> ok; - Signed -> - throw({error, - {bad_header, - "Incorrect directory checksum ~w (~w), should be ~w", - [Signed, Unsigned, ShouldBe]}}) +%% Skip the remaining bytes for the current file entry +skip_file(#reg_file_reader{handle=Handle0,pos=Pos,size=Size}=Reader) -> + Padding = skip_padding(Size), + AbsPos = Handle0#reader.pos + (Size-Pos) + Padding, + case do_position(Handle0, AbsPos) of + {ok, _, Handle1} -> + Reader#reg_file_reader{handle=Handle1,num_bytes=0,pos=Size}; + Err -> + throw(Err) + end; +skip_file(#sparse_file_reader{pos=Pos,size=Size}=Reader) -> + case do_read(Reader, Size-Pos) of + {ok, _, Reader2} -> + Reader2; + Err -> + throw(Err) end. -signed_sum([C|Rest], Sum) when C < 128 -> - signed_sum(Rest, Sum+C); -signed_sum([C|Rest], Sum) -> - signed_sum(Rest, Sum+C-256); -signed_sum([], Sum) -> Sum. - -write_extracted_element(Header, Bin, Opts) - when Opts#read_opts.output =:= memory -> - case Header#tar_header.typeflag of - regular -> - {ok, {Header#tar_header.name, Bin}}; - _ -> - ok +skip_padding(0) -> + 0; +skip_padding(Size) when (Size rem ?BLOCK_SIZE) =:= 0 -> + 0; +skip_padding(Size) when Size =< ?BLOCK_SIZE -> + ?BLOCK_SIZE - Size; +skip_padding(Size) -> + ?BLOCK_SIZE - (Size rem ?BLOCK_SIZE). + +skip_unread(#reader{pos=Pos}=Reader0) when (Pos rem ?BLOCK_SIZE) > 0 -> + Padding = skip_padding(Pos + ?BLOCK_SIZE), + AbsPos = Pos + Padding, + case do_position(Reader0, AbsPos) of + {ok, _, Reader1} -> + {ok, Reader1}; + Err -> + throw(Err) + end; +skip_unread(#reader{}=Reader) -> + {ok, Reader}; +skip_unread(#reg_file_reader{handle=Handle,num_bytes=0}) -> + skip_unread(Handle); +skip_unread(#reg_file_reader{}=Reader) -> + #reg_file_reader{handle=Handle} = skip_file(Reader), + {ok, Handle}; +skip_unread(#sparse_file_reader{handle=Handle,num_bytes=0}) -> + skip_unread(Handle); +skip_unread(#sparse_file_reader{}=Reader) -> + #sparse_file_reader{handle=Handle} = skip_file(Reader), + {ok, Handle}. + +write_extracted_element(#tar_header{name=Name,typeflag=Type}, + Bin, + #read_opts{output=memory}=Opts) -> + case typeflag(Type) of + regular -> + read_verbose(Opts, "x ~ts~n", [Name]), + {ok, {Name, Bin}}; + _ -> + ok end; -write_extracted_element(Header, Bin, Opts) -> - Name = filename:absname(Header#tar_header.name, Opts#read_opts.cwd), - Created = - case Header#tar_header.typeflag of - regular -> - write_extracted_file(Name, Bin, Opts); - directory -> - create_extracted_dir(Name, Opts); - symlink -> - create_symlink(Name, Header, Opts); - Other -> % Ignore. - read_verbose(Opts, "x ~ts - unsupported type ~p~n", - [Name, Other]), - not_written - end, +write_extracted_element(#tar_header{name=Name0}=Header, Bin, Opts) -> + Name1 = filename:absname(Name0, Opts#read_opts.cwd), + Created = + case typeflag(Header#tar_header.typeflag) of + regular -> + create_regular(Name1, Name0, Bin, Opts); + directory -> + read_verbose(Opts, "x ~ts~n", [Name0]), + create_extracted_dir(Name1, Opts); + symlink -> + read_verbose(Opts, "x ~ts~n", [Name0]), + create_symlink(Name1, Header#tar_header.linkname, Opts); + Device when Device =:= char orelse Device =:= block -> + %% char/block devices will be created as empty files + %% and then have their major/minor device set later + create_regular(Name1, Name0, <<>>, Opts); + fifo -> + %% fifo devices will be created as empty files + create_regular(Name1, Name0, <<>>, Opts); + Other -> % Ignore. + read_verbose(Opts, "x ~ts - unsupported type ~p~n", + [Name0, Other]), + not_written + end, case Created of - ok -> set_extracted_file_info(Name, Header); - not_written -> ok + ok -> set_extracted_file_info(Name1, Header); + not_written -> ok + end. + +create_regular(Name, NameInArchive, Bin, Opts) -> + case write_extracted_file(Name, Bin, Opts) of + not_written -> + read_verbose(Opts, "x ~ts - exists, not created~n", [NameInArchive]), + not_written; + Ok -> + read_verbose(Opts, "x ~ts~n", [NameInArchive]), + Ok end. create_extracted_dir(Name, _Opts) -> case file:make_dir(Name) of - ok -> ok; - {error,enotsup} -> not_written; - {error,eexist} -> not_written; - {error,enoent} -> make_dirs(Name, dir); - {error,Reason} -> throw({error, Reason}) + ok -> ok; + {error,enotsup} -> not_written; + {error,eexist} -> not_written; + {error,enoent} -> make_dirs(Name, dir); + {error,Reason} -> throw({error, Reason}) end. -create_symlink(Name, #tar_header{linkname=Linkname}=Header, Opts) -> +create_symlink(Name, Linkname, Opts) -> case file:make_symlink(Linkname, Name) of - ok -> ok; - {error,enoent} -> - ok = make_dirs(Name, file), - create_symlink(Name, Header, Opts); - {error,eexist} -> not_written; - {error,enotsup} -> - read_verbose(Opts, "x ~ts - symbolic links not supported~n", [Name]), - not_written; - {error,Reason} -> throw({error, Reason}) + ok -> ok; + {error,enoent} -> + ok = make_dirs(Name, file), + create_symlink(Name, Linkname, Opts); + {error,eexist} -> not_written; + {error,enotsup} -> + read_verbose(Opts, "x ~ts - symbolic links not supported~n", [Name]), + not_written; + {error,Reason} -> throw({error, Reason}) end. write_extracted_file(Name, Bin, Opts) -> Write = - case Opts#read_opts.keep_old_files of - true -> - case file:read_file_info(Name) of - {ok, _} -> false; - _ -> true - end; - false -> true - end, + case Opts#read_opts.keep_old_files of + true -> + case file:read_file_info(Name) of + {ok, _} -> false; + _ -> true + end; + false -> true + end, case Write of - true -> - read_verbose(Opts, "x ~ts~n", [Name]), - write_file(Name, Bin); - false -> - read_verbose(Opts, "x ~ts - exists, not created~n", [Name]), - not_written + true -> write_file(Name, Bin); + false -> not_written end. write_file(Name, Bin) -> case file:write_file(Name, Bin) of - ok -> ok; - {error,enoent} -> - ok = make_dirs(Name, file), - write_file(Name, Bin); - {error,Reason} -> - throw({error, Reason}) + ok -> ok; + {error,enoent} -> + ok = make_dirs(Name, file), + write_file(Name, Bin); + {error,Reason} -> + throw({error, Reason}) end. -set_extracted_file_info(_, #tar_header{typeflag = symlink}) -> ok; -set_extracted_file_info(Name, #tar_header{mode=Mode, mtime=Mtime}) -> - Info = #file_info{mode=Mode, mtime=posix_to_erlang_time(Mtime)}, +set_extracted_file_info(_, #tar_header{typeflag = ?TYPE_SYMLINK}) -> ok; +set_extracted_file_info(_, #tar_header{typeflag = ?TYPE_LINK}) -> ok; +set_extracted_file_info(Name, #tar_header{typeflag = ?TYPE_CHAR}=Header) -> + set_device_info(Name, Header); +set_extracted_file_info(Name, #tar_header{typeflag = ?TYPE_BLOCK}=Header) -> + set_device_info(Name, Header); +set_extracted_file_info(Name, #tar_header{mtime=Mtime,mode=Mode}) -> + Info = #file_info{mode=Mode, mtime=Mtime}, + file:write_file_info(Name, Info). + +set_device_info(Name, #tar_header{}=Header) -> + Mtime = Header#tar_header.mtime, + Mode = Header#tar_header.mode, + Devmajor = Header#tar_header.devmajor, + Devminor = Header#tar_header.devminor, + Info = #file_info{ + mode=Mode, + mtime=Mtime, + major_device=Devmajor, + minor_device=Devminor + }, file:write_file_info(Name, Info). %% Makes all directories leading up to the file. make_dirs(Name, file) -> - filelib:ensure_dir(Name); + filelib:ensure_dir(Name); make_dirs(Name, dir) -> - filelib:ensure_dir(filename:join(Name,"*")). + filelib:ensure_dir(filename:join(Name,"*")). %% Prints the message on if the verbose option is given (for reading). - read_verbose(#read_opts{verbose=true}, Format, Args) -> - io:format(Format, Args), - io:nl(); + io:format(Format, Args); read_verbose(_, _, _) -> ok. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%% -%%% Utility functions. -%%% -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -%% Returns the checksum of a binary. - -checksum(Bin) -> checksum(Bin, 0). - -checksum(<<A,B,C,D,E,F,G,H,T/binary>>, Sum) -> - checksum(T, Sum+A+B+C+D+E+F+G+H); -checksum(<<A,T/binary>>, Sum) -> - checksum(T, Sum+A); -checksum(<<>>, Sum) -> Sum. - -%% Returns a list of zeroes to pad out to the given block size. - -padding(Size, BlockSize) -> - zeroes(pad_size(Size, BlockSize)). - -pad_size(Size, BlockSize) -> - case Size rem BlockSize of - 0 -> 0; - Rem -> BlockSize-Rem - end. - -zeroes(0) -> []; -zeroes(1) -> [0]; -zeroes(2) -> [0,0]; -zeroes(Number) -> - Half = zeroes(Number div 2), - case Number rem 2 of - 0 -> [Half|Half]; - 1 -> [Half|[0|Half]] - end. - -%% Skips the given number of bytes rounded up to an even record. - -skip(File, Size) -> - %% Note: There is no point in handling failure to get the current position - %% in the file. If it doesn't work, something serious is wrong. - Amount = ((Size + ?record_size - 1) div ?record_size) * ?record_size, - {ok,_} = do_position(File, {cur, Amount}), - ok. - -%% Skips to the next record in the file. - -skip_to_next(File) -> - %% Note: There is no point in handling failure to get the current position - %% in the file. If it doesn't work, something serious is wrong. - {ok, Position} = do_position(File, {cur, 0}), - NewPosition = ((Position + ?record_size - 1) div ?record_size) * ?record_size, - {ok,NewPosition} = do_position(File, NewPosition), - ok. - %% Prints the message on if the verbose option is given. - add_verbose(#add_opts{verbose=true}, Format, Args) -> io:format(Format, Args); add_verbose(_, _, _) -> ok. -%% Converts a tuple containing the time to a Posix time (seconds -%% since Jan 1, 1970). +%%%%%%%%%%%%%%%%%% +%% I/O primitives +%%%%%%%%%%%%%%%%%% + +do_write(#reader{handle=Handle,func=Fun}=Reader0, Data) + when is_function(Fun,2) -> + case Fun(write,{Handle,Data}) of + ok -> + {ok, Pos, Reader1} = do_position(Reader0, {cur,0}), + {ok, Reader1#reader{pos=Pos}}; + {error, _} = Err -> + Err + end. -posix_time(Time) -> - EpochStart = {{1970,1,1},{0,0,0}}, - {Days,{Hour,Min,Sec}} = calendar:time_difference(EpochStart, Time), - 86400*Days + 3600*Hour + 60*Min + Sec. +do_copy(#reader{func=Fun}=Reader, Source, #add_opts{chunk_size=0}=Opts) + when is_function(Fun, 2) -> + do_copy(Reader, Source, Opts#add_opts{chunk_size=65536}); +do_copy(#reader{func=Fun}=Reader, Source, #add_opts{chunk_size=ChunkSize}) + when is_function(Fun, 2) -> + case file:open(Source, [read, binary]) of + {ok, SourceFd} -> + case copy_chunked(Reader, SourceFd, ChunkSize, 0) of + {ok, _Copied, _Reader2} = Ok-> + _ = file:close(SourceFd), + Ok; + Err -> + _ = file:close(SourceFd), + throw(Err) + end; + Err -> + throw(Err) + end. -posix_to_erlang_time(Sec) -> - OneMillion = 1000000, - Time = calendar:now_to_datetime({Sec div OneMillion, Sec rem OneMillion, 0}), - erlang:universaltime_to_localtime(Time). +copy_chunked(#reader{}=Reader, Source, ChunkSize, Copied) -> + case file:read(Source, ChunkSize) of + {ok, Bin} -> + {ok, Reader2} = do_write(Reader, Bin), + copy_chunked(Reader2, Source, ChunkSize, Copied+byte_size(Bin)); + eof -> + {ok, Copied, Reader}; + Other -> + Other + end. -read_file_and_info(Name, Opts) -> - ReadInfo = Opts#add_opts.read_info, - case ReadInfo(Name) of - {ok,Info} when Info#file_info.type =:= regular, - Opts#add_opts.chunk_size>0 -> - {ok,chunked,Info}; - {ok,Info} when Info#file_info.type =:= regular -> - case file:read_file(Name) of - {ok,Bin} -> - {ok,Bin,Info}; - Error -> - Error - end; - {ok,Info} when Info#file_info.type =:= symlink -> - case file:read_link(Name) of - {ok,PointsTo} -> - {ok,PointsTo,Info}; - Error -> - Error - end; - {ok, Info} -> - {ok,[],Info}; - Error -> - Error + +do_position(#reader{handle=Handle,func=Fun}=Reader, Pos) + when is_function(Fun,2)-> + case Fun(position, {Handle,Pos}) of + {ok, NewPos} -> + %% since Pos may not always be an absolute seek, + %% make sure we update the reader with the new absolute position + {ok, AbsPos} = Fun(position, {Handle, {cur, 0}}), + {ok, NewPos, Reader#reader{pos=AbsPos}}; + Other -> + Other end. -foreach_while_ok(Fun, [First|Rest]) -> - case Fun(First) of - ok -> foreach_while_ok(Fun, Rest); - Other -> Other +do_read(#reg_file_reader{handle=Handle,pos=Pos,size=Size}=Reader, Len) -> + NumBytes = Size - Pos, + ActualLen = if NumBytes - Len < 0 -> NumBytes; true -> Len end, + case do_read(Handle, ActualLen) of + {ok, Bin, Handle2} -> + NewPos = Pos + ActualLen, + NumBytes2 = Size - NewPos, + Reader1 = Reader#reg_file_reader{ + handle=Handle2, + pos=NewPos, + num_bytes=NumBytes2}, + {ok, Bin, Reader1}; + Other -> + Other end; -foreach_while_ok(_, []) -> ok. - -open_mode(Mode) -> - open_mode(Mode, false, [raw], []). +do_read(#sparse_file_reader{}=Reader, Len) -> + do_sparse_read(Reader, Len); +do_read(#reader{pos=Pos,handle=Handle,func=Fun}=Reader, Len) + when is_function(Fun,2)-> + %% Always convert to binary internally + case Fun(read2,{Handle,Len}) of + {ok, List} when is_list(List) -> + Bin = list_to_binary(List), + NewPos = Pos+byte_size(Bin), + {ok, Bin, Reader#reader{pos=NewPos}}; + {ok, Bin} when is_binary(Bin) -> + NewPos = Pos+byte_size(Bin), + {ok, Bin, Reader#reader{pos=NewPos}}; + Other -> + Other + end. -open_mode(read, _, Raw, _) -> - {ok, read, Raw, []}; -open_mode(write, _, Raw, _) -> - {ok, write, Raw, []}; -open_mode([read|Rest], false, Raw, Opts) -> - open_mode(Rest, read, Raw, Opts); -open_mode([write|Rest], false, Raw, Opts) -> - open_mode(Rest, write, Raw, Opts); -open_mode([compressed|Rest], Access, Raw, Opts) -> - open_mode(Rest, Access, Raw, [compressed|Opts]); -open_mode([cooked|Rest], Access, _Raw, Opts) -> - open_mode(Rest, Access, [], Opts); -open_mode([], Access, Raw, Opts) -> - {ok, Access, Raw, Opts}; -open_mode(_, _, _, _) -> - {error, einval}. -%%%================================================================ -do_write({tar_descriptor,UsrHandle,Fun}, Data) -> Fun(write,{UsrHandle,Data}). +do_sparse_read(Reader, Len) -> + do_sparse_read(Reader, Len, <<>>). + +do_sparse_read(#sparse_file_reader{sparse_map=[#sparse_entry{num_bytes=0}|Entries] + }=Reader0, Len, Acc) -> + %% skip all empty fragments + Reader1 = Reader0#sparse_file_reader{sparse_map=Entries}, + do_sparse_read(Reader1, Len, Acc); +do_sparse_read(#sparse_file_reader{sparse_map=[], + pos=Pos,size=Size}=Reader0, Len, Acc) + when Pos < Size -> + %% if there are no more fragments, it is possible that there is one last sparse hole + %% this behaviour matches the BSD tar utility + %% however, GNU tar stops returning data even if we haven't reached the end + {ok, Bin, Reader1} = read_sparse_hole(Reader0, Size, Len), + do_sparse_read(Reader1, Len-byte_size(Bin), <<Acc/binary,Bin/binary>>); +do_sparse_read(#sparse_file_reader{sparse_map=[]}=Reader, _Len, Acc) -> + {ok, Acc, Reader}; +do_sparse_read(#sparse_file_reader{}=Reader, 0, Acc) -> + {ok, Acc, Reader}; +do_sparse_read(#sparse_file_reader{sparse_map=[#sparse_entry{offset=Offset}|_], + pos=Pos}=Reader0, Len, Acc) + when Pos < Offset -> + {ok, Bin, Reader1} = read_sparse_hole(Reader0, Offset, Offset-Pos), + do_sparse_read(Reader1, Len-byte_size(Bin), <<Acc/binary,Bin/binary>>); +do_sparse_read(#sparse_file_reader{sparse_map=[Entry|Entries], + pos=Pos}=Reader0, Len, Acc) -> + %% we're in a data fragment, so read from it + %% end offset of fragment + EndPos = Entry#sparse_entry.offset + Entry#sparse_entry.num_bytes, + %% bytes left in fragment + NumBytes = EndPos - Pos, + ActualLen = if Len > NumBytes -> NumBytes; true -> Len end, + case do_read(Reader0#sparse_file_reader.handle, ActualLen) of + {ok, Bin, Handle} -> + BytesRead = byte_size(Bin), + ActualEndPos = Pos+BytesRead, + Reader1 = if ActualEndPos =:= EndPos -> + Reader0#sparse_file_reader{sparse_map=Entries}; + true -> + Reader0 + end, + Size = Reader1#sparse_file_reader.size, + NumBytes2 = Size - ActualEndPos, + Reader2 = Reader1#sparse_file_reader{ + handle=Handle, + pos=ActualEndPos, + num_bytes=NumBytes2}, + do_sparse_read(Reader2, Len-byte_size(Bin), <<Acc/binary,Bin/binary>>); + Other -> + Other + end. + +%% Reads a sparse hole ending at Offset +read_sparse_hole(#sparse_file_reader{pos=Pos}=Reader, Offset, Len) -> + N = Offset - Pos, + N2 = if N > Len -> + Len; + true -> + N + end, + Bin = <<0:N2/unit:8>>, + NumBytes = Reader#sparse_file_reader.size - (Pos+N2), + {ok, Bin, Reader#sparse_file_reader{ + num_bytes=NumBytes, + pos=Pos+N2}}. + +-spec do_close(reader()) -> ok | {error, term()}. +do_close(#reader{handle=Handle,func=Fun}) when is_function(Fun,2) -> + Fun(close,Handle). + +%%%%%%%%%%%%%%%%%% +%% Option parsing +%%%%%%%%%%%%%%%%%% -do_position({tar_descriptor,UsrHandle,Fun}, Pos) -> Fun(position,{UsrHandle,Pos}). +extract_opts(List) -> + extract_opts(List, default_options()). -do_read({tar_descriptor,UsrHandle,Fun}, Len) -> Fun(read2,{UsrHandle,Len}). +table_opts(List) -> + read_opts(List, default_options()). + +default_options() -> + {ok, Cwd} = file:get_cwd(), + #read_opts{cwd=Cwd}. -do_close({tar_descriptor,UsrHandle,Fun}) -> Fun(close,UsrHandle). +extract_opts([keep_old_files|Rest], Opts) -> + extract_opts(Rest, Opts#read_opts{keep_old_files=true}); +extract_opts([{cwd, Cwd}|Rest], Opts) -> + extract_opts(Rest, Opts#read_opts{cwd=Cwd}); +extract_opts([{files, Files}|Rest], Opts) -> + Set = ordsets:from_list(Files), + extract_opts(Rest, Opts#read_opts{files=Set}); +extract_opts([memory|Rest], Opts) -> + extract_opts(Rest, Opts#read_opts{output=memory}); +extract_opts([compressed|Rest], Opts=#read_opts{open_mode=OpenMode}) -> + extract_opts(Rest, Opts#read_opts{open_mode=[compressed|OpenMode]}); +extract_opts([cooked|Rest], Opts=#read_opts{open_mode=OpenMode}) -> + extract_opts(Rest, Opts#read_opts{open_mode=[cooked|OpenMode]}); +extract_opts([verbose|Rest], Opts) -> + extract_opts(Rest, Opts#read_opts{verbose=true}); +extract_opts([Other|Rest], Opts) -> + extract_opts(Rest, read_opts([Other], Opts)); +extract_opts([], Opts) -> + Opts. + +read_opts([compressed|Rest], Opts=#read_opts{open_mode=OpenMode}) -> + read_opts(Rest, Opts#read_opts{open_mode=[compressed|OpenMode]}); +read_opts([cooked|Rest], Opts=#read_opts{open_mode=OpenMode}) -> + read_opts(Rest, Opts#read_opts{open_mode=[cooked|OpenMode]}); +read_opts([verbose|Rest], Opts) -> + read_opts(Rest, Opts#read_opts{verbose=true}); +read_opts([_|Rest], Opts) -> + read_opts(Rest, Opts); +read_opts([], Opts) -> + Opts. diff --git a/lib/stdlib/src/erl_tar.hrl b/lib/stdlib/src/erl_tar.hrl new file mode 100644 index 0000000000..d646d02989 --- /dev/null +++ b/lib/stdlib/src/erl_tar.hrl @@ -0,0 +1,394 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2017. All Rights Reserved. +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. +%% +%% %CopyrightEnd% + +%% Options used when adding files to a tar archive. +-record(add_opts, { + read_info, %% Fun to use for read file/link info. + chunk_size = 0, %% For file reading when sending to sftp. 0=do not chunk + verbose = false}). %% Verbose on/off. +-type add_opts() :: #add_opts{}. + +%% Options used when reading a tar archive. +-record(read_opts, { + cwd :: string(), %% Current working directory. + keep_old_files = false :: boolean(), %% Owerwrite or not. + files = all, %% Set of files to extract (or all) + output = file :: 'file' | 'memory', + open_mode = [], %% Open mode options. + verbose = false :: boolean()}). %% Verbose on/off. +-type read_opts() :: #read_opts{}. + +-type add_opt() :: dereference | + verbose | + {chunks, pos_integer()}. + +-type extract_opt() :: {cwd, string()} | + {files, [string()]} | + compressed | + cooked | + memory | + keep_old_files | + verbose. + +-type create_opt() :: compressed | + cooked | + dereference | + verbose. + +-type filelist() :: [file:filename() | + {string(), binary()} | + {string(), file:filename()}]. + +%% The tar header, once fully parsed. +-record(tar_header, { + name = "" :: string(), %% name of header file entry + mode = 8#100644 :: non_neg_integer(), %% permission and mode bits + uid = 0 :: non_neg_integer(), %% user id of owner + gid = 0 :: non_neg_integer(), %% group id of owner + size = 0 :: non_neg_integer(), %% length in bytes + mtime :: calendar:datetime(), %% modified time + typeflag :: char(), %% type of header entry + linkname = "" :: string(), %% target name of link + uname = "" :: string(), %% user name of owner + gname = "" :: string(), %% group name of owner + devmajor = 0 :: non_neg_integer(), %% major number of character or block device + devminor = 0 :: non_neg_integer(), %% minor number of character or block device + atime :: calendar:datetime(), %% access time + ctime :: calendar:datetime() %% status change time + }). +-type tar_header() :: #tar_header{}. + +%% Metadata for a sparse file fragment +-record(sparse_entry, { + offset = 0 :: non_neg_integer(), + num_bytes = 0 :: non_neg_integer()}). +-type sparse_entry() :: #sparse_entry{}. +%% Contains metadata about fragments of a sparse file +-record(sparse_array, { + entries = [] :: [sparse_entry()], + is_extended = false :: boolean(), + max_entries = 0 :: non_neg_integer()}). +-type sparse_array() :: #sparse_array{}. +%% A subset of tar header fields common to all tar implementations +-record(header_v7, { + name :: binary(), + mode :: binary(), %% octal + uid :: binary(), %% integer + gid :: binary(), %% integer + size :: binary(), %% integer + mtime :: binary(), %% integer + checksum :: binary(), %% integer + typeflag :: byte(), %% char + linkname :: binary()}). +-type header_v7() :: #header_v7{}. +%% The set of fields specific to GNU tar formatted archives +-record(header_gnu, { + header_v7 :: header_v7(), + magic :: binary(), + version :: binary(), + uname :: binary(), + gname :: binary(), + devmajor :: binary(), %% integer + devminor :: binary(), %% integer + atime :: binary(), %% integer + ctime :: binary(), %% integer + sparse :: sparse_array(), + real_size :: binary()}). %% integer +-type header_gnu() :: #header_gnu{}. +%% The set of fields specific to STAR-formatted archives +-record(header_star, { + header_v7 :: header_v7(), + magic :: binary(), + version :: binary(), + uname :: binary(), + gname :: binary(), + devmajor :: binary(), %% integer + devminor :: binary(), %% integer + prefix :: binary(), + atime :: binary(), %% integer + ctime :: binary(), %% integer + trailer :: binary()}). +-type header_star() :: #header_star{}. +%% The set of fields specific to USTAR-formatted archives +-record(header_ustar, { + header_v7 :: header_v7(), + magic :: binary(), + version :: binary(), + uname :: binary(), + gname :: binary(), + devmajor :: binary(), %% integer + devminor :: binary(), %% integer + prefix :: binary()}). +-type header_ustar() :: #header_ustar{}. + +-type header_fields() :: header_v7() | + header_gnu() | + header_star() | + header_ustar(). + +%% The overall tar reader, it holds the low-level file handle, +%% its access, position, and the I/O primitives wrapper. +-record(reader, { + handle :: file:io_device() | term(), + access :: read | write | ram, + pos = 0 :: non_neg_integer(), + func :: file_op() + }). +-type reader() :: #reader{}. +%% A reader for a regular file within the tar archive, +%% It tracks its current state relative to that file. +-record(reg_file_reader, { + handle :: reader(), + num_bytes = 0, + pos = 0, + size = 0 + }). +-type reg_file_reader() :: #reg_file_reader{}. +%% A reader for a sparse file within the tar archive, +%% It tracks its current state relative to that file. +-record(sparse_file_reader, { + handle :: reader(), + num_bytes = 0, %% bytes remaining + pos = 0, %% pos + size = 0, %% total size of file + sparse_map = #sparse_array{} + }). +-type sparse_file_reader() :: #sparse_file_reader{}. + +%% Types for the readers +-type reader_type() :: reader() | reg_file_reader() | sparse_file_reader(). +-type handle() :: file:io_device() | term(). + +%% Type for the I/O primitive wrapper function +-type file_op() :: fun((write | close | read2 | position, + {handle(), iodata()} | handle() | {handle(), non_neg_integer()} + | {handle(), non_neg_integer()}) -> + ok | eof | {ok, string() | binary()} | {ok, non_neg_integer()} + | {error, term()}). + +%% These constants (except S_IFMT) are +%% used to determine what type of device +%% a file is. Namely, `S_IFMT band file_info.mode` +%% will equal one of these contants, and tells us +%% which type it is. The stdlib file_info record +%% does not differentiate between device types, and +%% will not allow us to differentiate between sockets +%% and named pipes. These constants are pulled from libc. +-define(S_IFMT, 61440). +-define(S_IFSOCK, 49152). %% socket +-define(S_FIFO, 4096). %% fifo/named pipe +-define(S_IFBLK, 24576). %% block device +-define(S_IFCHR, 8192). %% character device + +%% Typeflag constants for the tar header +-define(TYPE_REGULAR, $0). %% regular file +-define(TYPE_REGULAR_A, 0). %% regular file +-define(TYPE_LINK, $1). %% hard link +-define(TYPE_SYMLINK, $2). %% symbolic link +-define(TYPE_CHAR, $3). %% character device node +-define(TYPE_BLOCK, $4). %% block device node +-define(TYPE_DIR, $5). %% directory +-define(TYPE_FIFO, $6). %% fifo node +-define(TYPE_CONT, $7). %% reserved +-define(TYPE_X_HEADER, $x). %% extended header +-define(TYPE_X_GLOBAL_HEADER, $g). %% global extended header +-define(TYPE_GNU_LONGNAME, $L). %% next file has a long name +-define(TYPE_GNU_LONGLINK, $K). %% next file symlinks to a file with a long name +-define(TYPE_GNU_SPARSE, $S). %% sparse file + +%% Mode constants from tar spec +-define(MODE_ISUID, 4000). %% set uid +-define(MODE_ISGID, 2000). %% set gid +-define(MODE_ISVTX, 1000). %% save text (sticky bit) +-define(MODE_ISDIR, 40000). %% directory +-define(MODE_ISFIFO, 10000). %% fifo +-define(MODE_ISREG, 100000). %% regular file +-define(MODE_ISLNK, 120000). %% symbolic link +-define(MODE_ISBLK, 60000). %% block special file +-define(MODE_ISCHR, 20000). %% character special file +-define(MODE_ISSOCK, 140000). %% socket + +%% Keywords for PAX extended header +-define(PAX_ATIME, <<"atime">>). +-define(PAX_CHARSET, <<"charset">>). +-define(PAX_COMMENT, <<"comment">>). +-define(PAX_CTIME, <<"ctime">>). %% ctime is not a valid pax header +-define(PAX_GID, <<"gid">>). +-define(PAX_GNAME, <<"gname">>). +-define(PAX_LINKPATH, <<"linkpath">>). +-define(PAX_MTIME, <<"mtime">>). +-define(PAX_PATH, <<"path">>). +-define(PAX_SIZE, <<"size">>). +-define(PAX_UID, <<"uid">>). +-define(PAX_UNAME, <<"uname">>). +-define(PAX_XATTR, <<"SCHILY.xattr.">>). +-define(PAX_XATTR_STR, "SCHILY.xattr."). +-define(PAX_NONE, <<"">>). + +%% Tar format constants +%% Unknown format +-define(FORMAT_UNKNOWN, 0). +%% The format of the original Unix V7 tar tool prior to standardization +-define(FORMAT_V7, 1). +%% The old and new GNU formats, incompatible with USTAR. +%% This covers the old GNU sparse extension, but it does +%% not cover the GNU sparse extensions using PAX headers, +%% versions 0.0, 0.1, and 1.0; these fall under the PAX format. +-define(FORMAT_GNU, 2). +%% Schily's tar format, which is incompatible with USTAR. +%% This does not cover STAR extensions to the PAX format; these +%% fall under the PAX format. +-define(FORMAT_STAR, 3). +%% USTAR is the former standardization of tar defined in POSIX.1-1988, +%% it is incompatible with the GNU and STAR formats. +-define(FORMAT_USTAR, 4). +%% PAX is the latest standardization of tar defined in POSIX.1-2001. +%% This is an extension of USTAR and is "backwards compatible" with it. +%% +%% Some newer formats add their own extensions to PAX, such as GNU sparse +%% files and SCHILY extended attributes. Since they are backwards compatible +%% with PAX, they will be labelled as "PAX". +-define(FORMAT_PAX, 5). + +%% Magic constants +-define(MAGIC_GNU, <<"ustar ">>). +-define(VERSION_GNU, <<" \x00">>). +-define(MAGIC_USTAR, <<"ustar\x00">>). +-define(VERSION_USTAR, <<"00">>). +-define(TRAILER_STAR, <<"tar\x00">>). + +%% Size constants +-define(BLOCK_SIZE, 512). %% size of each block in a tar stream +-define(NAME_SIZE, 100). %% max length of the name field in USTAR format +-define(PREFIX_SIZE, 155). %% max length of the prefix field in USTAR format + +%% Maximum size of a nanosecond value as an integer +-define(MAX_NANO_INT_SIZE, 9). +%% Maximum size of a 64-bit signed integer +-define(MAX_INT64, (1 bsl 63 - 1)). + +-define(PAX_GNU_SPARSE_NUMBLOCKS, <<"GNU.sparse.numblocks">>). +-define(PAX_GNU_SPARSE_OFFSET, <<"GNU.sparse.offset">>). +-define(PAX_GNU_SPARSE_NUMBYTES, <<"GNU.sparse.numbytes">>). +-define(PAX_GNU_SPARSE_MAP, <<"GNU.sparse.map">>). +-define(PAX_GNU_SPARSE_NAME, <<"GNU.sparse.name">>). +-define(PAX_GNU_SPARSE_MAJOR, <<"GNU.sparse.major">>). +-define(PAX_GNU_SPARSE_MINOR, <<"GNU.sparse.minor">>). +-define(PAX_GNU_SPARSE_SIZE, <<"GNU.sparse.size">>). +-define(PAX_GNU_SPARSE_REALSIZE, <<"GNU.sparse.realsize">>). + +-define(V7_NAME, 0). +-define(V7_NAME_LEN, 100). +-define(V7_MODE, 100). +-define(V7_MODE_LEN, 8). +-define(V7_UID, 108). +-define(V7_UID_LEN, 8). +-define(V7_GID, 116). +-define(V7_GID_LEN, 8). +-define(V7_SIZE, 124). +-define(V7_SIZE_LEN, 12). +-define(V7_MTIME, 136). +-define(V7_MTIME_LEN, 12). +-define(V7_CHKSUM, 148). +-define(V7_CHKSUM_LEN, 8). +-define(V7_TYPE, 156). +-define(V7_TYPE_LEN, 1). +-define(V7_LINKNAME, 157). +-define(V7_LINKNAME_LEN, 100). + +-define(STAR_TRAILER, 508). +-define(STAR_TRAILER_LEN, 4). + +-define(USTAR_MAGIC, 257). +-define(USTAR_MAGIC_LEN, 6). +-define(USTAR_VERSION, 263). +-define(USTAR_VERSION_LEN, 2). +-define(USTAR_UNAME, 265). +-define(USTAR_UNAME_LEN, 32). +-define(USTAR_GNAME, 297). +-define(USTAR_GNAME_LEN, 32). +-define(USTAR_DEVMAJ, 329). +-define(USTAR_DEVMAJ_LEN, 8). +-define(USTAR_DEVMIN, 337). +-define(USTAR_DEVMIN_LEN, 8). +-define(USTAR_PREFIX, 345). +-define(USTAR_PREFIX_LEN, 155). + +-define(GNU_MAGIC, 257). +-define(GNU_MAGIC_LEN, 6). +-define(GNU_VERSION, 263). +-define(GNU_VERSION_LEN, 2). + +%% ?BLOCK_SIZE of zero-bytes. +%% Two of these in a row mark the end of an archive. +-define(ZERO_BLOCK, <<0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0>>). + +-define(BILLION, 1000000000). + +-define(EPOCH, {{1970,1,1}, {0,0,0}}). diff --git a/lib/stdlib/src/filename.erl b/lib/stdlib/src/filename.erl index 2a2f25dcd2..b5df5c9d37 100644 --- a/lib/stdlib/src/filename.erl +++ b/lib/stdlib/src/filename.erl @@ -37,7 +37,8 @@ -export([absname/1, absname/2, absname_join/2, basename/1, basename/2, dirname/1, extension/1, join/1, join/2, pathtype/1, - rootname/1, rootname/2, split/1, flatten/1, nativename/1]). + rootname/1, rootname/2, split/1, flatten/1, nativename/1, + safe_relative_path/1]). -export([find_src/1, find_src/2]). % deprecated -export([basedir/2, basedir/3]). @@ -753,12 +754,46 @@ separators() -> _ -> {false, false} end. +-spec safe_relative_path(Filename) -> 'unsafe' | SafeFilename when + Filename :: file:name_all(), + SafeFilename :: file:name_all(). + +safe_relative_path(Path) -> + case pathtype(Path) of + relative -> + Cs0 = split(Path), + safe_relative_path_1(Cs0, []); + _ -> + unsafe + end. + +safe_relative_path_1(["."|T], Acc) -> + safe_relative_path_1(T, Acc); +safe_relative_path_1([<<".">>|T], Acc) -> + safe_relative_path_1(T, Acc); +safe_relative_path_1([".."|T], Acc) -> + climb(T, Acc); +safe_relative_path_1([<<"..">>|T], Acc) -> + climb(T, Acc); +safe_relative_path_1([H|T], Acc) -> + safe_relative_path_1(T, [H|Acc]); +safe_relative_path_1([], []) -> + []; +safe_relative_path_1([], Acc) -> + join(lists:reverse(Acc)). + +climb(_, []) -> + unsafe; +climb(T, [_|Acc]) -> + safe_relative_path_1(T, Acc). + %% NOTE: The find_src/1/2 functions are deprecated; they try to do too much %% at once and are not a good fit for this module. Parts of the code have %% been moved to filelib:find_file/2 instead. Only this part of this %% module is allowed to call the filelib module; such mutual dependency %% should otherwise be avoided! This code should eventually be removed. %% + %% find_src(Module) -- %% find_src(Module, Rules) -- %% diff --git a/lib/stdlib/src/gen_event.erl b/lib/stdlib/src/gen_event.erl index 4839fe4f2c..0aebf1bdc5 100644 --- a/lib/stdlib/src/gen_event.erl +++ b/lib/stdlib/src/gen_event.erl @@ -778,7 +778,7 @@ stop_handlers([], _) -> []. %% Message from the release_handler. -%% The list of modules got to be a set ! +%% The list of modules got to be a set, i.e. no duplicate elements! get_modules(MSL) -> Mods = [Handler#handler.module || Handler <- MSL], ordsets:to_list(ordsets:from_list(Mods)). diff --git a/lib/stdlib/src/gen_fsm.erl b/lib/stdlib/src/gen_fsm.erl index 6e7528fd98..e925a75fe8 100644 --- a/lib/stdlib/src/gen_fsm.erl +++ b/lib/stdlib/src/gen_fsm.erl @@ -273,7 +273,7 @@ start_timer(Time, Msg) -> send_event_after(Time, Event) -> erlang:start_timer(Time, self(), {'$gen_event', Event}). -%% Returns the remaing time for the timer if Ref referred to +%% Returns the remaining time for the timer if Ref referred to %% an active timer/send_event_after, false otherwise. cancel_timer(Ref) -> case erlang:cancel_timer(Ref) of diff --git a/lib/stdlib/src/gen_statem.erl b/lib/stdlib/src/gen_statem.erl index 018aca90e6..cacc932ec4 100644 --- a/lib/stdlib/src/gen_statem.erl +++ b/lib/stdlib/src/gen_statem.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2016. All Rights Reserved. +%% Copyright Ericsson AB 2016-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -47,15 +47,17 @@ %% Type exports for templates and callback modules -export_type( [event_type/0, - init_result/0, callback_mode_result/0, - state_function_result/0, - handle_event_result/0, + init_result/1, state_enter_result/1, event_handler_result/1, reply_action/0, enter_action/0, action/0]). +%% Old types, not advertised +-export_type( + [state_function_result/0, + handle_event_result/0]). %% Type that is exported just to be documented -export_type([transition_option/0]). @@ -143,9 +145,10 @@ {'reply', % Reply to a caller From :: from(), Reply :: term()}. --type init_result() :: - {ok, state(), data()} | - {ok, state(), data(), [action()] | action()} | +-type init_result(StateType) :: + {ok, State :: StateType, Data :: data()} | + {ok, State :: StateType, Data :: data(), + Actions :: [action()] | action()} | 'ignore' | {'stop', Reason :: term()}. @@ -182,12 +185,23 @@ 'keep_state_and_data' | % {keep_state_and_data,[]} {'keep_state_and_data', % Keep state and data -> only actions Actions :: [ActionType] | ActionType} | + %% + {'repeat_state', % {repeat_state,NewData,[]} + NewData :: data()} | + {'repeat_state', % Repeat state, change data + NewData :: data(), + Actions :: [ActionType] | ActionType} | + 'repeat_state_and_data' | % {repeat_state_and_data,[]} + {'repeat_state_and_data', % Repeat state and data -> only actions + Actions :: [ActionType] | ActionType} | + %% 'stop' | % {stop,normal} {'stop', % Stop the server Reason :: term()} | {'stop', % Stop the server Reason :: term(), NewData :: data()} | + %% {'stop_and_reply', % Reply then stop the server Reason :: term(), Replies :: [reply_action()] | reply_action()} | @@ -201,7 +215,7 @@ %% the server is not running until this function has returned %% an {ok, ...} tuple. Thereafter the state callbacks are called %% for all events to this server. --callback init(Args :: term()) -> init_result(). +-callback init(Args :: term()) -> init_result(state()). %% This callback shall return the callback mode of the callback module. %% @@ -275,6 +289,8 @@ -optional_callbacks( [init/1, % One may use enter_loop/5,6,7 instead format_status/2, % Has got a default implementation + terminate/3, % Has got a default implementation + code_change/4, % Only needed by advanced soft upgrade %% state_name/3, % Example for callback_mode() =:= state_functions: %% there has to be a StateName/3 callback function @@ -304,12 +320,16 @@ event_type({call,From}) -> from(From); event_type(Type) -> case Type of + {call,From} -> + from(From); cast -> true; info -> true; timeout -> true; + state_timeout -> + true; internal -> true; _ -> @@ -588,6 +608,22 @@ enter(Module, Opts, State, Data, Server, Actions, Parent) -> true -> [Actions,{postpone,false}] end, + TimerRefs = #{}, + %% Key: timer ref + %% Value: the timer type i.e the timer's event type + %% + TimerTypes = #{}, + %% Key: timer type i.e the timer's event type + %% Value: timer ref + %% + %% We add a timer to both timer_refs and timer_types + %% when we start it. When we request an asynchronous + %% timer cancel we remove it from timer_types. When + %% the timer cancel message arrives we remove it from + %% timer_refs. + %% + Hibernate = false, + CancelTimers = 0, S = #{ callback_mode => undefined, state_enter => false, @@ -596,25 +632,25 @@ enter(Module, Opts, State, Data, Server, Actions, Parent) -> state => State, data => Data, postponed => P, - %% The rest of the fields are set from to the arguments to - %% loop_event_actions/10 when it finally loops back to loop/3 - %% in loop_events/10 %% - %% Marker for initial state, cleared immediately when used - init_state => true + %% The following fields are finally set from to the arguments to + %% loop_event_actions/9 when it finally loops back to loop/3 + %% in loop_event_result/11 + timer_refs => TimerRefs, + timer_types => TimerTypes, + hibernate => Hibernate, + cancel_timers => CancelTimers }, NewDebug = sys_debug(Debug, S, State, {enter,Event,State}), case call_callback_mode(S) of {ok,NewS} -> - TimerRefs = #{}, - TimerTypes = #{}, loop_event_actions( - Parent, NewDebug, NewS, TimerRefs, TimerTypes, - Events, Event, State, Data, NewActions); + Parent, NewDebug, NewS, + Events, Event, State, Data, NewActions, true); {Class,Reason,Stacktrace} -> terminate( - Class, Reason, Stacktrace, - NewDebug, S, [Event|Events]) + Class, Reason, Stacktrace, NewDebug, + S, [Event|Events]) end. %%%========================================================================== @@ -683,9 +719,7 @@ system_continue(Parent, Debug, S) -> loop(Parent, Debug, S). system_terminate(Reason, _Parent, Debug, S) -> - terminate( - exit, Reason, ?STACKTRACE(), - Debug, S, []). + terminate(exit, Reason, ?STACKTRACE(), Debug, S, []). system_code_change( #{module := Module, @@ -796,23 +830,22 @@ wakeup_from_hibernate(Parent, Debug, S) -> %% and detours through sys:handle_system_message/7 and proc_lib:hibernate/3 %% Entry point for system_continue/3 -loop(Parent, Debug, #{hibernate := Hibernate} = S) -> - case Hibernate of - true -> - %% Does not return but restarts process at - %% wakeup_from_hibernate/3 that jumps to loop_receive/3 - proc_lib:hibernate( - ?MODULE, wakeup_from_hibernate, [Parent,Debug,S]), - error( - {should_not_have_arrived_here_but_instead_in, - {wakeup_from_hibernate,3}}); - false -> - loop_receive(Parent, Debug, S) - end. +loop(Parent, Debug, #{hibernate := true, cancel_timers := 0} = S) -> + loop_hibernate(Parent, Debug, S); +loop(Parent, Debug, S) -> + loop_receive(Parent, Debug, S). + +loop_hibernate(Parent, Debug, S) -> + %% Does not return but restarts process at + %% wakeup_from_hibernate/3 that jumps to loop_receive/3 + proc_lib:hibernate( + ?MODULE, wakeup_from_hibernate, [Parent,Debug,S]), + error( + {should_not_have_arrived_here_but_instead_in, + {wakeup_from_hibernate,3}}). %% Entry point for wakeup_from_hibernate/3 -loop_receive( - Parent, Debug, #{timer_refs := TimerRefs, timer_types := TimerTypes} = S) -> +loop_receive(Parent, Debug, S) -> receive Msg -> case Msg of @@ -821,30 +854,87 @@ loop_receive( %% Does not return but tail recursively calls %% system_continue/3 that jumps to loop/3 sys:handle_system_msg( - Req, Pid, Parent, ?MODULE, Debug, S, Hibernate); + Req, Pid, Parent, ?MODULE, Debug, S, + Hibernate); {'EXIT',Parent,Reason} = EXIT -> - %% EXIT is not a 2-tuple and therefore - %% not an event and has no event_type(), - %% but this will stand out in the crash report... - terminate( - exit, Reason, ?STACKTRACE(), Debug, S, [EXIT]); + %% EXIT is not a 2-tuple therefore + %% not an event but this will stand out + %% in the crash report... + Q = [EXIT], + terminate(exit, Reason, ?STACKTRACE(), Debug, S, Q); {timeout,TimerRef,TimerMsg} -> + #{timer_refs := TimerRefs, + timer_types := TimerTypes, + hibernate := Hibernate} = S, case TimerRefs of #{TimerRef := TimerType} -> - Event = {TimerType,TimerMsg}, - %% Unregister the triggered timeout + %% We know of this timer; is it a running + %% timer or a timer being cancelled that + %% managed to send a late timeout message? + case TimerTypes of + #{TimerType := TimerRef} -> + %% The timer type maps back to this + %% timer ref, so it was a running timer + Event = {TimerType,TimerMsg}, + %% Unregister the triggered timeout + NewTimerRefs = + maps:remove(TimerRef, TimerRefs), + NewTimerTypes = + maps:remove(TimerType, TimerTypes), + loop_receive_result( + Parent, Debug, + S#{ + timer_refs := NewTimerRefs, + timer_types := NewTimerTypes}, + Hibernate, + Event); + _ -> + %% This was a late timeout message + %% from timer being cancelled, so + %% ignore it and expect a cancel_timer + %% msg shortly + loop_receive(Parent, Debug, S) + end; + _ -> + %% Not our timer; present it as an event + Event = {info,Msg}, loop_receive_result( - Parent, Debug, S, - maps:remove(TimerRef, TimerRefs), - maps:remove(TimerType, TimerTypes), - Event); + Parent, Debug, S, Hibernate, Event) + end; + {cancel_timer,TimerRef,_} -> + #{timer_refs := TimerRefs, + cancel_timers := CancelTimers, + hibernate := Hibernate} = S, + case TimerRefs of + #{TimerRef := _} -> + %% We must have requested a cancel + %% of this timer so it is already + %% removed from TimerTypes + NewTimerRefs = + maps:remove(TimerRef, TimerRefs), + NewCancelTimers = CancelTimers - 1, + NewS = + S#{ + timer_refs := NewTimerRefs, + cancel_timers := NewCancelTimers}, + if + Hibernate =:= true, NewCancelTimers =:= 0 -> + %% No more cancel_timer msgs to expect; + %% we can hibernate + loop_hibernate(Parent, Debug, NewS); + NewCancelTimers >= 0 -> % Assert + loop_receive(Parent, Debug, NewS) + end; _ -> + %% Not our cancel_timer msg; + %% present it as an event Event = {info,Msg}, loop_receive_result( - Parent, Debug, S, - TimerRefs, TimerTypes, Event) + Parent, Debug, S, Hibernate, Event) end; _ -> + %% External msg + #{hibernate := Hibernate} = S, Event = case Msg of {'$gen_call',From,Request} -> @@ -855,208 +945,212 @@ loop_receive( {info,Msg} end, loop_receive_result( - Parent, Debug, S, - TimerRefs, TimerTypes, Event) + Parent, Debug, S, Hibernate, Event) end end. loop_receive_result( - Parent, Debug, #{state := State} = S, - TimerRefs, TimerTypes, Event) -> - %% The fields 'timer_refs', 'timer_types' and 'hibernate' - %% are now invalid in state map S - they will be recalculated - %% and restored when we return to loop/3 - %% + Parent, Debug, + #{state := State, + timer_types := TimerTypes, cancel_timers := CancelTimers} = S, + Hibernate, Event) -> + %% From now the 'hibernate' field in S is invalid + %% and will be restored when looping back + %% in loop_event_result/11 NewDebug = sys_debug(Debug, S, State, {in,Event}), - %% Here the queue of not yet handled events is created + %% Here is the queue of not yet handled events created Events = [], - Hibernate = false, - loop_event( - Parent, NewDebug, S, TimerRefs, TimerTypes, Events, Event, Hibernate). + %% Cancel any running event timer + case + cancel_timer_by_type(timeout, TimerTypes, CancelTimers) + of + {_,CancelTimers} -> + %% No timer cancelled + loop_event(Parent, NewDebug, S, Events, Event, Hibernate); + {NewTimerTypes,NewCancelTimers} -> + %% The timer is removed from NewTimerTypes but + %% remains in TimerRefs until we get + %% the cancel_timer msg + NewS = + S#{ + timer_types := NewTimerTypes, + cancel_timers := NewCancelTimers}, + loop_event(Parent, NewDebug, NewS, Events, Event, Hibernate) + end. %% Entry point for handling an event, received or enqueued loop_event( - Parent, Debug, #{state := State, data := Data} = S, TimerRefs, TimerTypes, + Parent, Debug, + #{state := State, data := Data} = S, Events, {Type,Content} = Event, Hibernate) -> %% - %% If Hibernate is true here it can only be + %% If (this old) Hibernate is true here it can only be %% because it was set from an event action - %% and we did not go into hibernation since there - %% were events in queue, so we do what the user + %% and we did not go into hibernation since there were + %% events in queue, so we do what the user %% might rely on i.e collect garbage which %% would have happened if we actually hibernated %% and immediately was awakened Hibernate andalso garbage_collect(), case call_state_function(S, Type, Content, State, Data) of {ok,Result,NewS} -> - %% Cancel event timeout - {NewTimerRefs,NewTimerTypes} = - cancel_timer_by_type( - timeout, TimerRefs, TimerTypes), - {NewData,NextState,Actions} = + {NextState,NewData,Actions,EnterCall} = parse_event_result( - true, Debug, NewS, Result, - Events, Event, State, Data), + true, Debug, NewS, + Events, Event, State, Data, Result), loop_event_actions( - Parent, Debug, S, NewTimerRefs, NewTimerTypes, - Events, Event, NextState, NewData, Actions); + Parent, Debug, NewS, + Events, Event, NextState, NewData, Actions, EnterCall); {Class,Reason,Stacktrace} -> terminate( - Class, Reason, Stacktrace, Debug, S, [Event|Events]) + Class, Reason, Stacktrace, Debug, S, + [Event|Events]) end. loop_event_actions( Parent, Debug, - #{state := State, state_enter := StateEnter} = S, TimerRefs, TimerTypes, - Events, Event, NextState, NewData, Actions) -> + #{state := State, state_enter := StateEnter} = S, + Events, Event, NextState, NewData, + Actions, EnterCall) -> + %% Hibernate is reborn here as false being + %% the default value from parse_actions/4 case parse_actions(Debug, S, State, Actions) of {ok,NewDebug,Hibernate,TimeoutsR,Postpone,NextEventsR} -> if - StateEnter, NextState =/= State -> + StateEnter, EnterCall -> loop_event_enter( - Parent, NewDebug, S, TimerRefs, TimerTypes, + Parent, NewDebug, S, Events, Event, NextState, NewData, Hibernate, TimeoutsR, Postpone, NextEventsR); - StateEnter -> - case maps:is_key(init_state, S) of - true -> - %% Avoid infinite loop in initial state - %% with state entry events - NewS = maps:remove(init_state, S), - loop_event_enter( - Parent, NewDebug, NewS, TimerRefs, TimerTypes, - Events, Event, NextState, NewData, - Hibernate, TimeoutsR, Postpone, NextEventsR); - false -> - loop_event_result( - Parent, NewDebug, S, TimerRefs, TimerTypes, - Events, Event, NextState, NewData, - Hibernate, TimeoutsR, Postpone, NextEventsR) - end; true -> loop_event_result( - Parent, NewDebug, S, TimerRefs, TimerTypes, + Parent, NewDebug, S, Events, Event, NextState, NewData, Hibernate, TimeoutsR, Postpone, NextEventsR) end; {Class,Reason,Stacktrace} -> terminate( - Class, Reason, Stacktrace, - Debug, S#{data := NewData}, [Event|Events]) + Class, Reason, Stacktrace, Debug, S, + [Event|Events]) end. loop_event_enter( - Parent, Debug, #{state := State} = S, TimerRefs, TimerTypes, + Parent, Debug, #{state := State} = S, Events, Event, NextState, NewData, Hibernate, TimeoutsR, Postpone, NextEventsR) -> case call_state_function(S, enter, State, NextState, NewData) of {ok,Result,NewS} -> - {NewerData,_,Actions} = - parse_event_result( - false, Debug, NewS, Result, - Events, Event, NextState, NewData), - loop_event_enter_actions( - Parent, Debug, NewS, TimerRefs, TimerTypes, - Events, Event, NextState, NewerData, - Hibernate, TimeoutsR, Postpone, NextEventsR, Actions); + case parse_event_result( + false, Debug, NewS, + Events, Event, NextState, NewData, Result) of + {_,NewerData,Actions,EnterCall} -> + loop_event_enter_actions( + Parent, Debug, NewS, + Events, Event, NextState, NewerData, + Hibernate, TimeoutsR, Postpone, NextEventsR, + Actions, EnterCall) + end; {Class,Reason,Stacktrace} -> terminate( - Class, Reason, Stacktrace, - Debug, S#{state := NextState, data := NewData}, + Class, Reason, Stacktrace, Debug, + S#{ + state := NextState, + data := NewData, + hibernate := Hibernate}, [Event|Events]) end. loop_event_enter_actions( - Parent, Debug, S, TimerRefs, TimerTypes, + Parent, Debug, #{state_enter := StateEnter} = S, Events, Event, NextState, NewData, - Hibernate, TimeoutsR, Postpone, NextEventsR, Actions) -> + Hibernate, TimeoutsR, Postpone, NextEventsR, + Actions, EnterCall) -> case parse_enter_actions( - Debug, S, NextState, Actions, - Hibernate, TimeoutsR) + Debug, S, NextState, Actions, Hibernate, TimeoutsR) of {ok,NewDebug,NewHibernate,NewTimeoutsR,_,_} -> - loop_event_result( - Parent, NewDebug, S, TimerRefs, TimerTypes, - Events, Event, NextState, NewData, - NewHibernate, NewTimeoutsR, Postpone, NextEventsR); + if + StateEnter, EnterCall -> + loop_event_enter( + Parent, NewDebug, S, + Events, Event, NextState, NewData, + NewHibernate, NewTimeoutsR, Postpone, NextEventsR); + true -> + loop_event_result( + Parent, NewDebug, S, + Events, Event, NextState, NewData, + NewHibernate, NewTimeoutsR, Postpone, NextEventsR) + end; {Class,Reason,Stacktrace} -> terminate( - Class, Reason, Stacktrace, - Debug, S#{state := NextState, data := NewData}, + Class, Reason, Stacktrace, Debug, + S#{ + state := NextState, + data := NewData, + hibernate := Hibernate}, [Event|Events]) end. loop_event_result( - Parent, Debug, - #{state := State, postponed := P_0} = S, TimerRefs_0, TimerTypes_0, - Events, Event, NextState, NewData, + Parent, Debug_0, + #{state := State, postponed := P_0, + timer_refs := TimerRefs_0, timer_types := TimerTypes_0, + cancel_timers := CancelTimers_0} = S_0, + Events_0, Event_0, NextState, NewData, Hibernate, TimeoutsR, Postpone, NextEventsR) -> %% %% All options have been collected and next_events are buffered. %% Do the actual state transition. %% - {NewDebug,P_1} = % Move current event to postponed if Postpone + {Debug_1,P_1} = % Move current event to postponed if Postpone case Postpone of true -> - {sys_debug(Debug, S, State, {postpone,Event,State}), - [Event|P_0]}; + {sys_debug(Debug_0, S_0, State, {postpone,Event_0,State}), + [Event_0|P_0]}; false -> - {sys_debug(Debug, S, State, {consume,Event,State}), + {sys_debug(Debug_0, S_0, State, {consume,Event_0,State}), P_0} end, - {Events_1,NewP,{TimerRefs_1,TimerTypes_1}} = + {Events_1,P_2,{TimerTypes_1,CancelTimers_1}} = %% Move all postponed events to queue and cancel the %% state timeout if the state changes if NextState =:= State -> - {Events,P_1,{TimerRefs_0,TimerTypes_0}}; + {Events_0,P_1,{TimerTypes_0,CancelTimers_0}}; true -> - {lists:reverse(P_1, Events),[], + {lists:reverse(P_1, Events_0), + [], cancel_timer_by_type( - state_timeout, TimerRefs_0, TimerTypes_0)} + state_timeout, TimerTypes_0, CancelTimers_0)} + %% The state timer is removed from TimerTypes_1 + %% but remains in TimerRefs_0 until we get + %% the cancel_timer msg end, - {TimerRefs_2,TimerTypes_2,TimeoutEvents} = - %% Stop and start timers non-event timers - parse_timers(TimerRefs_1, TimerTypes_1, TimeoutsR), + {TimerRefs_2,TimerTypes_2,CancelTimers_2,TimeoutEvents} = + %% Stop and start non-event timers + parse_timers(TimerRefs_0, TimerTypes_1, CancelTimers_1, TimeoutsR), %% Place next events last in reversed queue Events_2R = lists:reverse(Events_1, NextEventsR), %% Enqueue immediate timeout events and start event timer - {NewTimerRefs,NewTimerTypes,Events_3R} = - process_timeout_events( - TimerRefs_2, TimerTypes_2, TimeoutEvents, Events_2R), - NewEvents = lists:reverse(Events_3R), - loop_events( - Parent, NewDebug, S, NewTimerRefs, NewTimerTypes, - NewEvents, Hibernate, NextState, NewData, NewP). - -%% Loop until out of enqueued events -%% -loop_events( - Parent, Debug, S, TimerRefs, TimerTypes, - [] = _Events, Hibernate, State, Data, P) -> - %% Update S and loop back to loop/3 to receive a new event - NewS = - S#{ - state := State, - data := Data, - postponed := P, - hibernate => Hibernate, - timer_refs => TimerRefs, - timer_types => TimerTypes}, - loop(Parent, Debug, NewS); -loop_events( - Parent, Debug, S, TimerRefs, TimerTypes, - [Event|Events], Hibernate, State, Data, P) -> - %% Update S and continue with enqueued events - NewS = - S#{ - state := State, - data := Data, - postponed := P}, - loop_event( - Parent, Debug, NewS, TimerRefs, TimerTypes, Events, Event, Hibernate). - + Events_3R = prepend_timeout_events(TimeoutEvents, Events_2R), + S_1 = + S_0#{ + state := NextState, + data := NewData, + postponed := P_2, + timer_refs := TimerRefs_2, + timer_types := TimerTypes_2, + cancel_timers := CancelTimers_2, + hibernate := Hibernate}, + case lists:reverse(Events_3R) of + [] -> + %% Get a new event + loop(Parent, Debug_1, S_1); + [Event|Events] -> + %% Loop until out of enqueued events + loop_event(Parent, Debug_1, S_1, Events, Event, Hibernate) + end. %%--------------------------------------------------------------------------- @@ -1069,19 +1163,6 @@ call_callback_mode(#{module := Module} = S) -> catch CallbackMode -> callback_mode_result(S, CallbackMode); - error:undef -> - %% Process undef to check for the simple mistake - %% of calling a nonexistent state function - %% to make the undef more precise - case erlang:get_stacktrace() of - [{Module,callback_mode,[]=Args,_} - |Stacktrace] -> - {error, - {undef_callback,{Module,callback_mode,Args}}, - Stacktrace}; - Stacktrace -> - {error,undef,Stacktrace} - end; Class:Reason -> {Class,Reason,erlang:get_stacktrace()} end. @@ -1126,8 +1207,7 @@ parse_callback_mode(_, _CBMode, StateEnter) -> call_state_function( - #{callback_mode := undefined} = S, - Type, Content, State, Data) -> + #{callback_mode := undefined} = S, Type, Content, State, Data) -> case call_callback_mode(S) of {ok,NewS} -> call_state_function(NewS, Type, Content, State, Data); @@ -1135,13 +1215,12 @@ call_state_function( Error end; call_state_function( - #{callback_mode := CallbackMode, - module := Module} = S, + #{callback_mode := CallbackMode, module := Module} = S, Type, Content, State, Data) -> try case CallbackMode of state_functions -> - erlang:apply(Module, State, [Type,Content,Data]); + Module:State(Type, Content, Data); handle_event_function -> Module:handle_event(Type, Content, State, Data) end @@ -1151,41 +1230,6 @@ call_state_function( catch Result -> {ok,Result,S}; - error:badarg -> - case erlang:get_stacktrace() of - [{erlang,apply, - [Module,State,[Type,Content,Data]=Args], - _} - |Stacktrace] - when CallbackMode =:= state_functions -> - %% We get here e.g if apply fails - %% due to State not being an atom - {error, - {undef_state_function,{Module,State,Args}}, - Stacktrace}; - Stacktrace -> - {error,badarg,Stacktrace} - end; - error:undef -> - %% Process undef to check for the simple mistake - %% of calling a nonexistent state function - %% to make the undef more precise - case erlang:get_stacktrace() of - [{Module,State,[Type,Content,Data]=Args,_} - |Stacktrace] - when CallbackMode =:= state_functions -> - {error, - {undef_state_function,{Module,State,Args}}, - Stacktrace}; - [{Module,handle_event,[Type,Content,State,Data]=Args,_} - |Stacktrace] - when CallbackMode =:= handle_event_function -> - {error, - {undef_state_function,{Module,handle_event,Args}}, - Stacktrace}; - Stacktrace -> - {error,undef,Stacktrace} - end; Class:Reason -> {Class,Reason,erlang:get_stacktrace()} end. @@ -1193,65 +1237,83 @@ call_state_function( %% Interpret all callback return variants parse_event_result( - AllowStateChange, Debug, S, Result, Events, Event, State, Data) -> + AllowStateChange, Debug, S, + Events, Event, State, Data, Result) -> case Result of stop -> terminate( - exit, normal, ?STACKTRACE(), Debug, S, [Event|Events]); + exit, normal, ?STACKTRACE(), Debug, + S#{state := State, data := Data}, + [Event|Events]); {stop,Reason} -> terminate( - exit, Reason, ?STACKTRACE(), Debug, S, [Event|Events]); + exit, Reason, ?STACKTRACE(), Debug, + S#{state := State, data := Data}, + [Event|Events]); {stop,Reason,NewData} -> terminate( - exit, Reason, ?STACKTRACE(), - Debug, S#{data := NewData}, [Event|Events]); + exit, Reason, ?STACKTRACE(), Debug, + S#{state := State, data := NewData}, + [Event|Events]); + %% {stop_and_reply,Reason,Replies} -> - Q = [Event|Events], reply_then_terminate( - exit, Reason, ?STACKTRACE(), - Debug, S, Q, Replies); + exit, Reason, ?STACKTRACE(), Debug, + S#{state := State, data := Data}, + [Event|Events], Replies); {stop_and_reply,Reason,Replies,NewData} -> - Q = [Event|Events], reply_then_terminate( - exit, Reason, ?STACKTRACE(), - Debug, S#{data := NewData}, Q, Replies); + exit, Reason, ?STACKTRACE(), Debug, + S#{state := State, data := NewData}, + [Event|Events], Replies); + %% {next_state,State,NewData} -> - {NewData,State,[]}; + {State,NewData,[],false}; {next_state,NextState,NewData} when AllowStateChange -> - {NewData,NextState,[]}; + {NextState,NewData,[],true}; {next_state,State,NewData,Actions} -> - {NewData,State,Actions}; + {State,NewData,Actions,false}; {next_state,NextState,NewData,Actions} when AllowStateChange -> - {NewData,NextState,Actions}; + {NextState,NewData,Actions,true}; + %% {keep_state,NewData} -> - {NewData,State,[]}; + {State,NewData,[],false}; {keep_state,NewData,Actions} -> - {NewData,State,Actions}; + {State,NewData,Actions,false}; keep_state_and_data -> - {Data,State,[]}; + {State,Data,[],false}; {keep_state_and_data,Actions} -> - {Data,State,Actions}; + {State,Data,Actions,false}; + %% + {repeat_state,NewData} -> + {State,NewData,[],true}; + {repeat_state,NewData,Actions} -> + {State,NewData,Actions,true}; + repeat_state_and_data -> + {State,Data,[],true}; + {repeat_state_and_data,Actions} -> + {State,Data,Actions,true}; + %% _ -> terminate( error, {bad_return_from_state_function,Result}, - ?STACKTRACE(), - Debug, S, [Event|Events]) + ?STACKTRACE(), Debug, + S#{state := State, data := Data}, + [Event|Events]) end. -parse_enter_actions( - Debug, S, State, Actions, - Hibernate, TimeoutsR) -> +parse_enter_actions(Debug, S, State, Actions, Hibernate, TimeoutsR) -> Postpone = forbidden, NextEventsR = forbidden, parse_actions( Debug, S, State, listify(Actions), Hibernate, TimeoutsR, Postpone, NextEventsR). - + parse_actions(Debug, S, State, Actions) -> Hibernate = false, - TimeoutsR = [], + TimeoutsR = [{timeout,infinity,infinity}], %% Will cancel event timer Postpone = false, NextEventsR = [], parse_actions( @@ -1279,64 +1341,29 @@ parse_actions( {bad_action_from_state_function,Action}, ?STACKTRACE()} end; + %% %% Actions that set options {hibernate,NewHibernate} when is_boolean(NewHibernate) -> parse_actions( Debug, S, State, Actions, NewHibernate, TimeoutsR, Postpone, NextEventsR); - {hibernate,_} -> - {error, - {bad_action_from_state_function,Action}, - ?STACKTRACE()}; hibernate -> + NewHibernate = true, parse_actions( Debug, S, State, Actions, - true, TimeoutsR, Postpone, NextEventsR); - {state_timeout,Time,_} = StateTimeout - when is_integer(Time), Time >= 0; - Time =:= infinity -> - parse_actions( - Debug, S, State, Actions, - Hibernate, [StateTimeout|TimeoutsR], Postpone, NextEventsR); - {state_timeout,_,_} -> - {error, - {bad_action_from_state_function,Action}, - ?STACKTRACE()}; - {timeout,infinity,_} -> - %% Ignore - timeout will never happen and already cancelled - parse_actions( - Debug, S, State, Actions, - Hibernate, TimeoutsR, Postpone, NextEventsR); - {timeout,Time,_} = Timeout when is_integer(Time), Time >= 0 -> - parse_actions( - Debug, S, State, Actions, - Hibernate, [Timeout|TimeoutsR], Postpone, NextEventsR); - {timeout,_,_} -> - {error, - {bad_action_from_state_function,Action}, - ?STACKTRACE()}; - infinity -> % Ignore - timeout will never happen - parse_actions( - Debug, S, State, Actions, - Hibernate, TimeoutsR, Postpone, NextEventsR); - Time when is_integer(Time), Time >= 0 -> - Timeout = {timeout,Time,Time}, - parse_actions( - Debug, S, State, Actions, - Hibernate, [Timeout|TimeoutsR], Postpone, NextEventsR); + NewHibernate, TimeoutsR, Postpone, NextEventsR); + %% {postpone,NewPostpone} when is_boolean(NewPostpone), Postpone =/= forbidden -> parse_actions( Debug, S, State, Actions, Hibernate, TimeoutsR, NewPostpone, NextEventsR); - {postpone,_} -> - {error, - {bad_action_from_state_function,Action}, - ?STACKTRACE()}; postpone when Postpone =/= forbidden -> + NewPostpone = true, parse_actions( Debug, S, State, Actions, - Hibernate, TimeoutsR, true, NextEventsR); + Hibernate, TimeoutsR, NewPostpone, NextEventsR); + %% {next_event,Type,Content} -> case event_type(Type) of true when NextEventsR =/= forbidden -> @@ -1351,96 +1378,150 @@ parse_actions( {bad_action_from_state_function,Action}, ?STACKTRACE()} end; - _ -> + %% + {state_timeout,_,_} = Timeout -> + parse_actions_timeout( + Debug, S, State, Actions, + Hibernate, TimeoutsR, Postpone, NextEventsR, Timeout); + {timeout,_,_} = Timeout -> + parse_actions_timeout( + Debug, S, State, Actions, + Hibernate, TimeoutsR, Postpone, NextEventsR, Timeout); + Time -> + parse_actions_timeout( + Debug, S, State, Actions, + Hibernate, TimeoutsR, Postpone, NextEventsR, Time) + end. + +parse_actions_timeout( + Debug, S, State, Actions, + Hibernate, TimeoutsR, Postpone, NextEventsR, Timeout) -> + Time = + case Timeout of + {_,T,_} -> T; + T -> T + end, + case validate_time(Time) of + true -> + parse_actions( + Debug, S, State, Actions, + Hibernate, [Timeout|TimeoutsR], + Postpone, NextEventsR); + false -> {error, - {bad_action_from_state_function,Action}, + {bad_action_from_state_function,Timeout}, ?STACKTRACE()} end. +validate_time(Time) when is_integer(Time), Time >= 0 -> true; +validate_time(infinity) -> true; +validate_time(_) -> false. %% Stop and start timers as well as create timeout zero events %% and pending event timer %% %% Stop and start timers non-event timers -parse_timers(TimerRefs, TimerTypes, TimeoutsR) -> - parse_timers(TimerRefs, TimerTypes, TimeoutsR, #{}, []). +parse_timers(TimerRefs, TimerTypes, CancelTimers, TimeoutsR) -> + parse_timers(TimerRefs, TimerTypes, CancelTimers, TimeoutsR, #{}, []). %% -parse_timers(TimerRefs, TimerTypes, [], _Seen, TimeoutEvents) -> - {TimerRefs,TimerTypes,TimeoutEvents}; parse_timers( - TimerRefs, TimerTypes, [Timeout|TimeoutsR], Seen, TimeoutEvents) -> - {TimerType,Time,TimerMsg} = Timeout, + TimerRefs, TimerTypes, CancelTimers, [], _Seen, TimeoutEvents) -> + {TimerRefs,TimerTypes,CancelTimers,TimeoutEvents}; +parse_timers( + TimerRefs, TimerTypes, CancelTimers, [Timeout|TimeoutsR], + Seen, TimeoutEvents) -> + case Timeout of + {TimerType,Time,TimerMsg} -> + parse_timers( + TimerRefs, TimerTypes, CancelTimers, TimeoutsR, + Seen, TimeoutEvents, + TimerType, Time, TimerMsg); + Time -> + parse_timers( + TimerRefs, TimerTypes, CancelTimers, TimeoutsR, + Seen, TimeoutEvents, + timeout, Time, Time) + end. + +parse_timers( + TimerRefs, TimerTypes, CancelTimers, TimeoutsR, + Seen, TimeoutEvents, + TimerType, Time, TimerMsg) -> case Seen of #{TimerType := _} -> %% Type seen before - ignore parse_timers( - TimerRefs, TimerTypes, TimeoutsR, Seen, TimeoutEvents); + TimerRefs, TimerTypes, CancelTimers, TimeoutsR, + Seen, TimeoutEvents); #{} -> %% Unseen type - handle NewSeen = Seen#{TimerType => true}, - %% Cancel any running timer - {NewTimerRefs,NewTimerTypes} = - cancel_timer_by_type(TimerType, TimerRefs, TimerTypes), - if - Time =:= infinity -> - %% Ignore - timer will never fire + case Time of + infinity -> + %% Cancel any running timer + {NewTimerTypes,NewCancelTimers} = + cancel_timer_by_type( + TimerType, TimerTypes, CancelTimers), parse_timers( - NewTimerRefs, NewTimerTypes, TimeoutsR, + TimerRefs, NewTimerTypes, NewCancelTimers, TimeoutsR, NewSeen, TimeoutEvents); - TimerType =:= timeout -> - %% Handle event timer later - parse_timers( - NewTimerRefs, NewTimerTypes, TimeoutsR, - NewSeen, [Timeout|TimeoutEvents]); - Time =:= 0 -> + 0 -> + %% Cancel any running timer + {NewTimerTypes,NewCancelTimers} = + cancel_timer_by_type( + TimerType, TimerTypes, CancelTimers), %% Handle zero time timeouts later TimeoutEvent = {TimerType,TimerMsg}, parse_timers( - NewTimerRefs, NewTimerTypes, TimeoutsR, + TimerRefs, NewTimerTypes, NewCancelTimers, TimeoutsR, NewSeen, [TimeoutEvent|TimeoutEvents]); - true -> - %% Start a new timer - TimerRef = erlang:start_timer(Time, self(), TimerMsg), - parse_timers( - NewTimerRefs#{TimerRef => TimerType}, - NewTimerTypes#{TimerType => TimerRef}, - TimeoutsR, NewSeen, TimeoutEvents) + _ -> + %% (Re)start the timer + TimerRef = + erlang:start_timer(Time, self(), TimerMsg), + case TimerTypes of + #{TimerType := OldTimerRef} -> + %% Cancel the running timer + cancel_timer(OldTimerRef), + NewCancelTimers = CancelTimers + 1, + %% Insert the new timer into + %% both TimerRefs and TimerTypes + parse_timers( + TimerRefs#{TimerRef => TimerType}, + TimerTypes#{TimerType => TimerRef}, + NewCancelTimers, TimeoutsR, + NewSeen, TimeoutEvents); + #{} -> + parse_timers( + TimerRefs#{TimerRef => TimerType}, + TimerTypes#{TimerType => TimerRef}, + CancelTimers, TimeoutsR, + NewSeen, TimeoutEvents) + end end end. -%% Enqueue immediate timeout events and start event timer -process_timeout_events(TimerRefs, TimerTypes, [], EventsR) -> - {TimerRefs, TimerTypes, EventsR}; -process_timeout_events( - TimerRefs, TimerTypes, - [{timeout,0,TimerMsg}|TimeoutEvents], []) -> - %% No enqueued events - insert a timeout zero event - TimeoutEvent = {timeout,TimerMsg}, - process_timeout_events( - TimerRefs, TimerTypes, - TimeoutEvents, [TimeoutEvent]); -process_timeout_events( - TimerRefs, TimerTypes, - [{timeout,Time,TimerMsg}], []) -> - %% No enqueued events - start event timer - TimerRef = erlang:start_timer(Time, self(), TimerMsg), - process_timeout_events( - TimerRefs#{TimerRef => timeout}, TimerTypes#{timeout => TimerRef}, - [], []); -process_timeout_events( - TimerRefs, TimerTypes, - [{timeout,_Time,_TimerMsg}|TimeoutEvents], EventsR) -> - %% There will be some other event so optimize by not starting - %% an event timer to just have to cancel it again - process_timeout_events( - TimerRefs, TimerTypes, - TimeoutEvents, EventsR); -process_timeout_events( - TimerRefs, TimerTypes, - [{_TimeoutType,_TimeoutMsg} = TimeoutEvent|TimeoutEvents], EventsR) -> - process_timeout_events( - TimerRefs, TimerTypes, - TimeoutEvents, [TimeoutEvent|EventsR]). +%% Enqueue immediate timeout events (timeout 0 events) +%% +%% Event timer timeout 0 events gets special treatment since +%% an event timer is cancelled by any received event, +%% so if there are enqueued events before the event timer +%% timeout 0 event - the event timer is cancelled hence no event. +%% +%% Other (state_timeout) timeout 0 events that are after +%% the event timer timeout 0 events are considered to +%% belong to timers that were started after the event timer +%% timeout 0 event fired, so they do not cancel the event timer. +%% +prepend_timeout_events([], EventsR) -> + EventsR; +prepend_timeout_events([{timeout,_} = TimeoutEvent|TimeoutEvents], []) -> + prepend_timeout_events(TimeoutEvents, [TimeoutEvent]); +prepend_timeout_events([{timeout,_}|TimeoutEvents], EventsR) -> + prepend_timeout_events(TimeoutEvents, EventsR); +prepend_timeout_events([TimeoutEvent|TimeoutEvents], EventsR) -> + %% Just prepend all others + prepend_timeout_events(TimeoutEvents, [TimeoutEvent|EventsR]). @@ -1448,18 +1529,11 @@ process_timeout_events( %% Server helpers reply_then_terminate( - Class, Reason, Stacktrace, - Debug, #{state := State} = S, Q, Replies) -> - if - is_list(Replies) -> - do_reply_then_terminate( - Class, Reason, Stacktrace, - Debug, S, Q, Replies, State); - true -> - do_reply_then_terminate( - Class, Reason, Stacktrace, - Debug, S, Q, [Replies], State) - end. + Class, Reason, Stacktrace, Debug, + #{state := State} = S, Q, Replies) -> + do_reply_then_terminate( + Class, Reason, Stacktrace, Debug, + S, Q, listify(Replies), State). %% do_reply_then_terminate( Class, Reason, Stacktrace, Debug, S, Q, [], _State) -> @@ -1485,21 +1559,25 @@ do_reply(Debug, S, State, From, Reply) -> terminate( - Class, Reason, Stacktrace, - Debug, + Class, Reason, Stacktrace, Debug, #{module := Module, state := State, data := Data, postponed := P} = S, Q) -> - try Module:terminate(Reason, State, Data) of - _ -> ok - catch - _ -> ok; - C:R -> - ST = erlang:get_stacktrace(), - error_info( - C, R, ST, S, Q, P, - format_status(terminate, get(), S)), - sys:print_log(Debug), - erlang:raise(C, R, ST) + case erlang:function_exported(Module, terminate, 3) of + true -> + try Module:terminate(Reason, State, Data) of + _ -> ok + catch + _ -> ok; + C:R -> + ST = erlang:get_stacktrace(), + error_info( + C, R, ST, S, Q, P, + format_status(terminate, get(), S)), + sys:print_log(Debug), + erlang:raise(C, R, ST) + end; + false -> + ok end, _ = case Reason of @@ -1637,28 +1715,21 @@ listify(Item) -> [Item]. %% Cancel timer if running, otherwise no op -cancel_timer_by_type(TimerType, TimerRefs, TimerTypes) -> +%% +%% This is an asynchronous cancel so the timer is not really cancelled +%% until we get a cancel_timer msg i.e {cancel_timer,TimerRef,_}. +%% In the mean time we might get a timeout message. +%% +%% Remove the timer from TimerTypes. +%% When we get the cancel_timer msg we remove it from TimerRefs. +cancel_timer_by_type(TimerType, TimerTypes, CancelTimers) -> case TimerTypes of #{TimerType := TimerRef} -> cancel_timer(TimerRef), - {maps:remove(TimerRef, TimerRefs), - maps:remove(TimerType, TimerTypes)}; + {maps:remove(TimerType, TimerTypes),CancelTimers + 1}; #{} -> - {TimerRefs,TimerTypes} + {TimerTypes,CancelTimers} end. -%%cancel_timer(undefined) -> -%% ok; -cancel_timer(TRef) -> - case erlang:cancel_timer(TRef) of - false -> - %% We have to assume that TRef is the ref of a running timer - %% and if so the timer has expired - %% hence we must wait for the timeout message - receive - {timeout,TRef,_} -> - ok - end; - _TimeLeft -> - ok - end. +cancel_timer(TimerRef) -> + ok = erlang:cancel_timer(TimerRef, [{async,true}]). diff --git a/lib/stdlib/src/io_lib.erl b/lib/stdlib/src/io_lib.erl index ad98bc0420..a91143a764 100644 --- a/lib/stdlib/src/io_lib.erl +++ b/lib/stdlib/src/io_lib.erl @@ -28,7 +28,7 @@ %% Most of the code here is derived from the original prolog versions and %% from similar code written by Joe Armstrong and myself. %% -%% This module has been split into seperate modules: +%% This module has been split into separate modules: %% io_lib - basic write and utilities %% io_lib_format - formatted output %% io_lib_fread - formatted input diff --git a/lib/stdlib/src/io_lib_format.erl b/lib/stdlib/src/io_lib_format.erl index c7b75961cb..3113767614 100644 --- a/lib/stdlib/src/io_lib_format.erl +++ b/lib/stdlib/src/io_lib_format.erl @@ -265,7 +265,10 @@ control($W, [A,Depth], F, Adj, P, Pad, _Enc, _Str, _I) when is_integer(Depth) -> term(io_lib:write(A, Depth), F, Adj, P, Pad); control($P, [A,Depth], F, Adj, P, Pad, Enc, Str, I) when is_integer(Depth) -> print(A, Depth, F, Adj, P, Pad, Enc, Str, I); -control($s, [A], F, Adj, P, Pad, _Enc, _Str, _I) when is_atom(A) -> +control($s, [A], F, Adj, P, Pad, latin1, _Str, _I) when is_atom(A) -> + L = iolist_to_chars(atom_to_list(A)), + string(L, F, Adj, P, Pad); +control($s, [A], F, Adj, P, Pad, unicode, _Str, _I) when is_atom(A) -> string(atom_to_list(A), F, Adj, P, Pad); control($s, [L0], F, Adj, P, Pad, latin1, _Str, _I) -> L = iolist_to_chars(L0), diff --git a/lib/stdlib/src/io_lib_pretty.erl b/lib/stdlib/src/io_lib_pretty.erl index 94376408d1..aabccfc5d9 100644 --- a/lib/stdlib/src/io_lib_pretty.erl +++ b/lib/stdlib/src/io_lib_pretty.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2016. All Rights Reserved. +%% Copyright Ericsson AB 1996-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -139,6 +139,10 @@ max_cs(M, _Len) -> M. -define(ATM(T), is_list(element(1, T))). +-define(ATM_PAIR(Pair), + ?ATM(element(2, element(1, Pair))) % Key + andalso + ?ATM(element(3, element(1, Pair)))). % Value -define(ATM_FLD(Field), ?ATM(element(4, element(1, Field)))). pp({_S, Len} = If, Col, Ll, M, _TInd, _Ind, LD, W) @@ -151,9 +155,8 @@ pp({{tuple,true,L}, _Len}, Col, Ll, M, TInd, Ind, LD, W) -> pp({{tuple,false,L}, _Len}, Col, Ll, M, TInd, Ind, LD, W) -> [${, pp_list(L, Col + 1, Ll, M, TInd, indent(1, Ind), LD, $,, W + 1), $}]; pp({{map,Pairs},_Len}, Col, Ll, M, TInd, Ind, LD, W) -> - [$#,${, pp_list(Pairs, Col + 2, Ll, M, TInd, indent(2, Ind), LD, $,, W + 1), $}]; -pp({{map_pair,K,V},_Len}, Col, Ll, M, TInd, Ind, LD, W) -> - [pp(K, Col, Ll, M, TInd, Ind, LD, W), " => ", pp(V, Col, Ll, M, TInd, Ind, LD, W)]; + [$#, ${, pp_map(Pairs, Col + 2, Ll, M, TInd, indent(2, Ind), LD, W + 1), + $}]; pp({{record,[{Name,NLen} | L]}, _Len}, Col, Ll, M, TInd, Ind, LD, W) -> [Name, ${, pp_record(L, NLen, Col, Ll, M, TInd, Ind, LD, W + NLen+1), $}]; pp({{bin,S}, _Len}, Col, Ll, M, _TInd, Ind, LD, W) -> @@ -178,6 +181,46 @@ pp_tag_tuple([{Tag,Tlen} | L], Col, Ll, M, TInd, Ind, LD, W) -> [Tag, S | pp_list(L, Tcol, Ll, M, TInd, Indent, LD, S, W+Tlen+1)] end. +pp_map([], _Col, _Ll, _M, _TInd, _Ind, _LD, _W) -> + ""; +pp_map({dots, _}, _Col, _Ll, _M, _TInd, _Ind, _LD, _W) -> + "..."; +pp_map([P | Ps], Col, Ll, M, TInd, Ind, LD, W) -> + {PS, PW} = pp_pair(P, Col, Ll, M, TInd, Ind, last_depth(Ps, LD), W), + [PS | pp_pairs_tail(Ps, Col, Col + PW, Ll, M, TInd, Ind, LD, PW)]. + +pp_pairs_tail([], _Col0, _Col, _Ll, _M, _TInd, _Ind, _LD, _W) -> + ""; +pp_pairs_tail({dots, _}, _Col0, _Col, _M, _Ll, _TInd, _Ind, _LD, _W) -> + ",..."; +pp_pairs_tail([{_, Len}=P | Ps], Col0, Col, Ll, M, TInd, Ind, LD, W) -> + LD1 = last_depth(Ps, LD), + ELen = 1 + Len, + if + LD1 =:= 0, ELen + 1 < Ll - Col, W + ELen + 1 =< M, ?ATM_PAIR(P); + LD1 > 0, ELen < Ll - Col - LD1, W + ELen + LD1 =< M, ?ATM_PAIR(P) -> + [$,, write_pair(P) | + pp_pairs_tail(Ps, Col0, Col+ELen, Ll, M, TInd, Ind, LD, W+ELen)]; + true -> + {PS, PW} = pp_pair(P, Col0, Ll, M, TInd, Ind, LD1, 0), + [$,, $\n, Ind, PS | + pp_pairs_tail(Ps, Col0, Col0 + PW, Ll, M, TInd, Ind, LD, PW)] + end. + +pp_pair({_, Len}=Pair, Col, Ll, M, _TInd, _Ind, LD, W) + when Len < Ll - Col - LD, Len + W + LD =< M -> + {write_pair(Pair), if + ?ATM_PAIR(Pair) -> + Len; + true -> + Ll % force nl + end}; +pp_pair({{map_pair, K, V}, _Len}, Col0, Ll, M, TInd, Ind0, LD, W) -> + I = map_value_indent(TInd), + Ind = indent(I, Ind0), + {[pp(K, Col0, Ll, M, TInd, Ind0, LD, W), " =>\n", + Ind | pp(V, Col0 + I, Ll, M, TInd, Ind, LD, 0)], Ll}. % force nl + pp_record([], _Nlen, _Col, _Ll, _M, _TInd, _Ind, _LD, _W) -> ""; pp_record({dots, _}, _Nlen, _Col, _Ll, _M, _TInd, _Ind, _LD, _W) -> @@ -216,7 +259,11 @@ pp_field({_, Len}=Fl, Col, Ll, M, _TInd, _Ind, LD, W) end}; pp_field({{field, Name, NameL, F}, _Len}, Col0, Ll, M, TInd, Ind0, LD, W0) -> {Col, Ind, S, W} = rec_indent(NameL, TInd, Col0, Ind0, W0 + NameL), - {[Name, " = ", S | pp(F, Col, Ll, M, TInd, Ind, LD, W)], Ll}. % force nl + Sep = case S of + [$\n | _] -> " ="; + _ -> " = " + end, + {[Name, Sep, S | pp(F, Col, Ll, M, TInd, Ind, LD, W)], Ll}. % force nl rec_indent(RInd, TInd, Col0, Ind0, W0) -> %% this uses TInd @@ -305,8 +352,8 @@ write({{list, L}, _}) -> [$[, write_list(L, $|), $]]; write({{map, Pairs}, _}) -> [$#,${, write_list(Pairs, $,), $}]; -write({{map_pair, K, V}, _}) -> - [write(K)," => ",write(V)]; +write({{map_pair, _K, _V}, _}=Pair) -> + write_pair(Pair); write({{record, [{Name,_} | L]}, _}) -> [Name, ${, write_fields(L), $}]; write({{bin, S}, _}) -> @@ -314,6 +361,9 @@ write({{bin, S}, _}) -> write({S, _}) -> S. +write_pair({{map_pair, K, V}, _}) -> + [write(K), " => ", write(V)]. + write_fields([]) -> ""; write_fields({dots, _}) -> @@ -347,7 +397,7 @@ write_tail(E, S) -> %% The depth (D) is used for extracting and counting the characters to %% print. The structure is kept so that the returned intermediate -%% format can be formatted. The separators (list, tuple, record) are +%% format can be formatted. The separators (list, tuple, record, map) are %% counted but need to be added later. %% D =/= 0 @@ -423,21 +473,22 @@ print_length(Term, _D, _RF, _Enc, _Str) -> print_length_map(_Map, 1, _RF, _Enc, _Str) -> {"#{...}", 6}; print_length_map(Map, D, RF, Enc, Str) when is_map(Map) -> - Pairs = print_length_map_pairs(maps:to_list(Map), D, RF, Enc, Str), + Pairs = print_length_map_pairs(erts_internal:maps_to_list(Map, D), D, RF, Enc, Str), {{map, Pairs}, list_length(Pairs, 3)}. print_length_map_pairs([], _D, _RF, _Enc, _Str) -> []; print_length_map_pairs(_Pairs, 1, _RF, _Enc, _Str) -> {dots, 3}; -print_length_map_pairs([{K,V}|Pairs], D, RF, Enc, Str) -> - [print_length_map_pair(K,V,D-1,RF,Enc,Str) | - print_length_map_pairs(Pairs,D-1,RF,Enc,Str)]. +print_length_map_pairs([{K, V} | Pairs], D, RF, Enc, Str) -> + [print_length_map_pair(K, V, D - 1, RF, Enc, Str) | + print_length_map_pairs(Pairs, D - 1, RF, Enc, Str)]. print_length_map_pair(K, V, D, RF, Enc, Str) -> {KS, KL} = print_length(K, D, RF, Enc, Str), {VS, VL} = print_length(V, D, RF, Enc, Str), - {{map_pair, {KS,KL}, {VS,VL}}, KL + VL}. + KL1 = KL + 4, + {{map_pair, {KS, KL1}, {VS, VL}}, KL1 + VL}. print_length_tuple(_Tuple, 1, _RF, _Enc, _Str) -> {"{...}", 5}; @@ -630,6 +681,8 @@ cind({{tuple,true,L}, _Len}, Col, Ll, M, Ind, LD, W) -> cind_tag_tuple(L, Col, Ll, M, Ind, LD, W + 1); cind({{tuple,false,L}, _Len}, Col, Ll, M, Ind, LD, W) -> cind_list(L, Col + 1, Ll, M, Ind, LD, W + 1); +cind({{map,Pairs},_Len}, Col, Ll, M, Ind, LD, W) -> + cind_map(Pairs, Col + 2, Ll, M, Ind, LD, W + 2); cind({{record,[{_Name,NLen} | L]}, _Len}, Col, Ll, M, Ind, LD, W) -> cind_record(L, NLen, Col, Ll, M, Ind, LD, W + NLen + 1); cind({{bin,_S}, _Len}, _Col, _Ll, _M, Ind, _LD, _W) -> @@ -655,6 +708,48 @@ cind_tag_tuple([{_Tag,Tlen} | L], Col, Ll, M, Ind, LD, W) -> throw(no_good) end. +cind_map([P | Ps], Col, Ll, M, Ind, LD, W) -> + PW = cind_pair(P, Col, Ll, M, Ind, last_depth(Ps, LD), W), + cind_pairs_tail(Ps, Col, Col + PW, Ll, M, Ind, LD, W + PW); +cind_map(_, _Col, _Ll, _M, Ind, _LD, _W) -> + Ind. + +cind_pairs_tail([{_, Len}=P | Ps], Col0, Col, Ll, M, Ind, LD, W) -> + LD1 = last_depth(Ps, LD), + ELen = 1 + Len, + if + LD1 =:= 0, ELen + 1 < Ll - Col, W + ELen + 1 =< M, ?ATM_PAIR(P); + LD1 > 0, ELen < Ll - Col - LD1, W + ELen + LD1 =< M, ?ATM_PAIR(P) -> + cind_pairs_tail(Ps, Col0, Col + ELen, Ll, M, Ind, LD, W + ELen); + true -> + PW = cind_pair(P, Col0, Ll, M, Ind, LD1, 0), + cind_pairs_tail(Ps, Col0, Col0 + PW, Ll, M, Ind, LD, PW) + end; +cind_pairs_tail(_, _Col0, _Col, _Ll, _M, Ind, _LD, _W) -> + Ind. + +cind_pair({{map_pair, _Key, _Value}, Len}=Pair, Col, Ll, M, _Ind, LD, W) + when Len < Ll - Col - LD, Len + W + LD =< M -> + if + ?ATM_PAIR(Pair) -> + Len; + true -> + Ll + end; +cind_pair({{map_pair, K, V}, _Len}, Col0, Ll, M, Ind, LD, W0) -> + cind(K, Col0, Ll, M, Ind, LD, W0), + I = map_value_indent(Ind), + cind(V, Col0 + I, Ll, M, Ind, LD, 0), + Ll. + +map_value_indent(TInd) -> + case TInd > 0 of + true -> + TInd; + false -> + 4 + end. + cind_record([F | Fs], Nlen, Col0, Ll, M, Ind, LD, W0) -> Nind = Nlen + 1, {Col, W} = cind_rec(Nind, Col0, Ll, M, Ind, W0), diff --git a/lib/stdlib/src/proplists.erl b/lib/stdlib/src/proplists.erl index 21de8c45c1..340dfdcac9 100644 --- a/lib/stdlib/src/proplists.erl +++ b/lib/stdlib/src/proplists.erl @@ -83,7 +83,7 @@ property(Key, Value) -> %% --------------------------------------------------------------------- -%% @doc Unfolds all occurences of atoms in <code>ListIn</code> to tuples +%% @doc Unfolds all occurrences of atoms in <code>ListIn</code> to tuples %% <code>{Atom, true}</code>. %% %% @see compact/1 diff --git a/lib/stdlib/src/qlc.erl b/lib/stdlib/src/qlc.erl index f3665824f2..8c4d835432 100644 --- a/lib/stdlib/src/qlc.erl +++ b/lib/stdlib/src/qlc.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2004-2016. All Rights Reserved. +%% Copyright Ericsson AB 2004-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -1292,6 +1292,10 @@ abstr_term(Fun, Line) when is_function(Fun) -> end; abstr_term(PPR, Line) when is_pid(PPR); is_port(PPR); is_reference(PPR) -> {special, Line, lists:flatten(io_lib:write(PPR))}; +abstr_term(Map, Line) when is_map(Map) -> + {map,Line, + [{map_field_assoc,Line,abstr_term(K, Line),abstr_term(V, Line)} || + {K,V} <- maps:to_list(Map)]}; abstr_term(Simple, Line) -> erl_parse:abstract(Simple, erl_anno:line(Line)). diff --git a/lib/stdlib/src/sofs.erl b/lib/stdlib/src/sofs.erl index c244e06ca4..cc50e1b52c 100644 --- a/lib/stdlib/src/sofs.erl +++ b/lib/stdlib/src/sofs.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2001-2016. All Rights Reserved. +%% Copyright Ericsson AB 2001-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -76,7 +76,7 @@ %% %% See also "Naive Set Theory" by Paul R. Halmos. %% -%% By convention, erlang:error/2 is called from exported functions. +%% By convention, erlang:error/1 is called from exported functions. -define(TAG, 'Set'). -define(ORDTAG, 'OrdSet'). @@ -87,12 +87,6 @@ -define(LIST(S), (S)#?TAG.data). -define(TYPE(S), (S)#?TAG.type). -%%-define(SET(L, T), -%% case is_type(T) of -%% true -> #?TAG{data = L, type = T}; -%% false -> erlang:error(badtype, [T]) -%% end -%% ). -define(SET(L, T), #?TAG{data = L, type = T}). -define(IS_SET(S), is_record(S, ?TAG)). -define(IS_UNTYPED_SET(S), ?TYPE(S) =:= ?ANYTYPE). @@ -154,11 +148,8 @@ from_term(T) -> _ when is_list(T) -> [?ANYTYPE]; _ -> ?ANYTYPE end, - case catch setify(T, Type) of - {'EXIT', _} -> - erlang:error(badarg, [T]); - Set -> - Set + try setify(T, Type) + catch _:_ -> erlang:error(badarg) end. -spec(from_term(Term, Type) -> AnySet when @@ -168,14 +159,11 @@ from_term(T) -> from_term(L, T) -> case is_type(T) of true -> - case catch setify(L, T) of - {'EXIT', _} -> - erlang:error(badarg, [L, T]); - Set -> - Set + try setify(L, T) + catch _:_ -> erlang:error(badarg) end; false -> - erlang:error(badarg, [L, T]) + erlang:error(badarg) end. -spec(from_external(ExternalSet, Type) -> AnySet when @@ -208,33 +196,26 @@ is_type(_T) -> Set :: a_set(), Terms :: [term()]). set(L) -> - case catch usort(L) of - {'EXIT', _} -> - erlang:error(badarg, [L]); - SL -> - ?SET(SL, ?ATOM_TYPE) + try usort(L) of + SL -> ?SET(SL, ?ATOM_TYPE) + catch _:_ -> erlang:error(badarg) end. -spec(set(Terms, Type) -> Set when Set :: a_set(), Terms :: [term()], Type :: type()). -set(L, ?SET_OF(Type) = T) when ?IS_ATOM_TYPE(Type), Type =/= ?ANYTYPE -> - case catch usort(L) of - {'EXIT', _} -> - erlang:error(badarg, [L, T]); - SL -> - ?SET(SL, Type) +set(L, ?SET_OF(Type)) when ?IS_ATOM_TYPE(Type), Type =/= ?ANYTYPE -> + try usort(L) of + SL -> ?SET(SL, Type) + catch _:_ -> erlang:error(badarg) end; set(L, ?SET_OF(_) = T) -> - case catch setify(L, T) of - {'EXIT', _} -> - erlang:error(badarg, [L, T]); - Set -> - Set + try setify(L, T) + catch _:_ -> erlang:error(badarg) end; -set(L, T) -> - erlang:error(badarg, [L, T]). +set(_, _) -> + erlang:error(badarg). -spec(from_sets(ListOfSets) -> Set when Set :: a_set(), @@ -245,19 +226,19 @@ set(L, T) -> from_sets(Ss) when is_list(Ss) -> case set_of_sets(Ss, [], ?ANYTYPE) of {error, Error} -> - erlang:error(Error, [Ss]); + erlang:error(Error); Set -> Set end; from_sets(Tuple) when is_tuple(Tuple) -> case ordset_of_sets(tuple_to_list(Tuple), [], []) of error -> - erlang:error(badarg, [Tuple]); + erlang:error(badarg); Set -> Set end; -from_sets(T) -> - erlang:error(badarg, [T]). +from_sets(_) -> + erlang:error(badarg). -spec(relation(Tuples) -> Relation when Relation :: relation(), @@ -265,14 +246,11 @@ from_sets(T) -> relation([]) -> ?SET([], ?BINREL(?ATOM_TYPE, ?ATOM_TYPE)); relation(Ts = [T | _]) when is_tuple(T) -> - case catch rel(Ts, tuple_size(T)) of - {'EXIT', _} -> - erlang:error(badarg, [Ts]); - Set -> - Set + try rel(Ts, tuple_size(T)) + catch _:_ -> erlang:error(badarg) end; -relation(E) -> - erlang:error(badarg, [E]). +relation(_) -> + erlang:error(badarg). -spec(relation(Tuples, Type) -> Relation when N :: integer(), @@ -280,24 +258,20 @@ relation(E) -> Relation :: relation(), Tuples :: [tuple()]). relation(Ts, TS) -> - case catch rel(Ts, TS) of - {'EXIT', _} -> - erlang:error(badarg, [Ts, TS]); - Set -> - Set + try rel(Ts, TS) + catch _:_ -> erlang:error(badarg) end. -spec(a_function(Tuples) -> Function when Function :: a_function(), Tuples :: [tuple()]). a_function(Ts) -> - case catch func(Ts, ?BINREL(?ATOM_TYPE, ?ATOM_TYPE)) of - {'EXIT', _} -> - erlang:error(badarg, [Ts]); + try func(Ts, ?BINREL(?ATOM_TYPE, ?ATOM_TYPE)) of Bad when is_atom(Bad) -> - erlang:error(Bad, [Ts]); - Set -> - Set + erlang:error(Bad); + Set -> + Set + catch _:_ -> erlang:error(badarg) end. -spec(a_function(Tuples, Type) -> Function when @@ -305,26 +279,24 @@ a_function(Ts) -> Tuples :: [tuple()], Type :: type()). a_function(Ts, T) -> - case catch a_func(Ts, T) of - {'EXIT', _} -> - erlang:error(badarg, [Ts, T]); + try a_func(Ts, T) of Bad when is_atom(Bad) -> - erlang:error(Bad, [Ts, T]); + erlang:error(Bad); Set -> Set + catch _:_ -> erlang:error(badarg) end. -spec(family(Tuples) -> Family when Family :: family(), Tuples :: [tuple()]). family(Ts) -> - case catch fam2(Ts, ?FAMILY(?ATOM_TYPE, ?ATOM_TYPE)) of - {'EXIT', _} -> - erlang:error(badarg, [Ts]); + try fam2(Ts, ?FAMILY(?ATOM_TYPE, ?ATOM_TYPE)) of Bad when is_atom(Bad) -> - erlang:error(Bad, [Ts]); + erlang:error(Bad); Set -> Set + catch _:_ -> erlang:error(badarg) end. -spec(family(Tuples, Type) -> Family when @@ -332,13 +304,12 @@ family(Ts) -> Tuples :: [tuple()], Type :: type()). family(Ts, T) -> - case catch fam(Ts, T) of - {'EXIT', _} -> - erlang:error(badarg, [Ts, T]); + try fam(Ts, T) of Bad when is_atom(Bad) -> - erlang:error(Bad, [Ts, T]); + erlang:error(Bad); Set -> Set + catch _:_ -> erlang:error(badarg) end. %%% @@ -373,7 +344,7 @@ to_sets(S) when ?IS_SET(S) -> to_sets(S) when ?IS_ORDSET(S), is_tuple(?ORDTYPE(S)) -> tuple_of_sets(tuple_to_list(?ORDDATA(S)), tuple_to_list(?ORDTYPE(S)), []); to_sets(S) when ?IS_ORDSET(S) -> - erlang:error(badarg, [S]). + erlang:error(badarg). -spec(no_elements(ASet) -> NoElements when ASet :: a_set() | ordset(), @@ -383,7 +354,7 @@ no_elements(S) when ?IS_SET(S) -> no_elements(S) when ?IS_ORDSET(S), is_tuple(?ORDTYPE(S)) -> tuple_size(?ORDDATA(S)); no_elements(S) when ?IS_ORDSET(S) -> - erlang:error(badarg, [S]). + erlang:error(badarg). -spec(specification(Fun, Set1) -> Set2 when Fun :: spec_fun(), @@ -401,7 +372,7 @@ specification(Fun, S) when ?IS_SET(S) -> SL when is_list(SL) -> ?SET(SL, Type); Bad -> - erlang:error(Bad, [Fun, S]) + erlang:error(Bad) end. -spec(union(Set1, Set2) -> Set3 when @@ -410,7 +381,7 @@ specification(Fun, S) when ?IS_SET(S) -> Set3 :: a_set()). union(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> case unify_types(?TYPE(S1), ?TYPE(S2)) of - [] -> erlang:error(type_mismatch, [S1, S2]); + [] -> erlang:error(type_mismatch); Type -> ?SET(umerge(?LIST(S1), ?LIST(S2)), Type) end. @@ -420,7 +391,7 @@ union(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> Set3 :: a_set()). intersection(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> case unify_types(?TYPE(S1), ?TYPE(S2)) of - [] -> erlang:error(type_mismatch, [S1, S2]); + [] -> erlang:error(type_mismatch); Type -> ?SET(intersection(?LIST(S1), ?LIST(S2), []), Type) end. @@ -430,7 +401,7 @@ intersection(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> Set3 :: a_set()). difference(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> case unify_types(?TYPE(S1), ?TYPE(S2)) of - [] -> erlang:error(type_mismatch, [S1, S2]); + [] -> erlang:error(type_mismatch); Type -> ?SET(difference(?LIST(S1), ?LIST(S2), []), Type) end. @@ -440,7 +411,7 @@ difference(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> Set3 :: a_set()). symdiff(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> case unify_types(?TYPE(S1), ?TYPE(S2)) of - [] -> erlang:error(type_mismatch, [S1, S2]); + [] -> erlang:error(type_mismatch); Type -> ?SET(symdiff(?LIST(S1), ?LIST(S2), []), Type) end. @@ -452,7 +423,7 @@ symdiff(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> Set5 :: a_set()). symmetric_partition(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> case unify_types(?TYPE(S1), ?TYPE(S2)) of - [] -> erlang:error(type_mismatch, [S1, S2]); + [] -> erlang:error(type_mismatch); Type -> sympart(?LIST(S1), ?LIST(S2), [], [], [], Type) end. @@ -477,11 +448,9 @@ product({S1, S2}) -> product(S1, S2); product(T) when is_tuple(T) -> Ss = tuple_to_list(T), - case catch sets_to_list(Ss) of - {'EXIT', _} -> - erlang:error(badarg, [T]); + try sets_to_list(Ss) of [] -> - erlang:error(badarg, [T]); + erlang:error(badarg); L -> Type = types(Ss, []), case member([], L) of @@ -490,6 +459,7 @@ product(T) when is_tuple(T) -> false -> ?SET(reverse(prod(L, [], [])), Type) end + catch _:_ -> erlang:error(badarg) end. -spec(constant_function(Set, AnySet) -> Function when @@ -502,10 +472,10 @@ constant_function(S, E) when ?IS_SET(S) -> {Type, true} -> NType = ?BINREL(Type, type(E)), ?SET(constant_function(?LIST(S), to_external(E), []), NType); - _ -> erlang:error(badarg, [S, E]) + _ -> erlang:error(badarg) end; -constant_function(S, E) when ?IS_ORDSET(S) -> - erlang:error(badarg, [S, E]). +constant_function(S, _) when ?IS_ORDSET(S) -> + erlang:error(badarg). -spec(is_equal(AnySet1, AnySet2) -> Bool when AnySet1 :: anyset(), @@ -514,17 +484,17 @@ constant_function(S, E) when ?IS_ORDSET(S) -> is_equal(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> case match_types(?TYPE(S1), ?TYPE(S2)) of true -> ?LIST(S1) == ?LIST(S2); - false -> erlang:error(type_mismatch, [S1, S2]) + false -> erlang:error(type_mismatch) end; is_equal(S1, S2) when ?IS_ORDSET(S1), ?IS_ORDSET(S2) -> case match_types(?ORDTYPE(S1), ?ORDTYPE(S2)) of true -> ?ORDDATA(S1) == ?ORDDATA(S2); - false -> erlang:error(type_mismatch, [S1, S2]) + false -> erlang:error(type_mismatch) end; is_equal(S1, S2) when ?IS_SET(S1), ?IS_ORDSET(S2) -> - erlang:error(type_mismatch, [S1, S2]); + erlang:error(type_mismatch); is_equal(S1, S2) when ?IS_ORDSET(S1), ?IS_SET(S2) -> - erlang:error(type_mismatch, [S1, S2]). + erlang:error(type_mismatch). -spec(is_subset(Set1, Set2) -> Bool when Bool :: boolean(), @@ -533,7 +503,7 @@ is_equal(S1, S2) when ?IS_ORDSET(S1), ?IS_SET(S2) -> is_subset(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> case match_types(?TYPE(S1), ?TYPE(S2)) of true -> subset(?LIST(S1), ?LIST(S2)); - false -> erlang:error(type_mismatch, [S1, S2]) + false -> erlang:error(type_mismatch) end. -spec(is_sofs_set(Term) -> Bool when @@ -573,7 +543,7 @@ is_disjoint(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> [] -> true; [A | As] -> disjoint(?LIST(S2), A, As) end; - false -> erlang:error(type_mismatch, [S1, S2]) + false -> erlang:error(type_mismatch) end. %%% @@ -587,7 +557,7 @@ union(Sets) when ?IS_SET(Sets) -> case ?TYPE(Sets) of ?SET_OF(Type) -> ?SET(lunion(?LIST(Sets)), Type); ?ANYTYPE -> Sets; - _ -> erlang:error(badarg, [Sets]) + _ -> erlang:error(badarg) end. -spec(intersection(SetOfSets) -> Set when @@ -595,12 +565,12 @@ union(Sets) when ?IS_SET(Sets) -> SetOfSets :: set_of_sets()). intersection(Sets) when ?IS_SET(Sets) -> case ?LIST(Sets) of - [] -> erlang:error(badarg, [Sets]); + [] -> erlang:error(badarg); [L | Ls] -> case ?TYPE(Sets) of ?SET_OF(Type) -> ?SET(lintersection(Ls, L), Type); - _ -> erlang:error(badarg, [Sets]) + _ -> erlang:error(badarg) end end. @@ -614,7 +584,7 @@ canonical_relation(Sets) when ?IS_SET(Sets) -> ?SET_OF(Type) -> ?SET(can_rel(?LIST(Sets), []), ?BINREL(Type, ST)); ?ANYTYPE -> Sets; - _ -> erlang:error(badarg, [Sets]) + _ -> erlang:error(badarg) end. %%% @@ -636,7 +606,7 @@ relation_to_family(R) when ?IS_SET(R) -> ?BINREL(DT, RT) -> ?SET(rel2family(?LIST(R)), ?FAMILY(DT, RT)); ?ANYTYPE -> R; - _Else -> erlang:error(badarg, [R]) + _Else -> erlang:error(badarg) end. -spec(domain(BinRel) -> Set when @@ -646,7 +616,7 @@ domain(R) when ?IS_SET(R) -> case ?TYPE(R) of ?BINREL(DT, _) -> ?SET(dom(?LIST(R)), DT); ?ANYTYPE -> R; - _Else -> erlang:error(badarg, [R]) + _Else -> erlang:error(badarg) end. -spec(range(BinRel) -> Set when @@ -656,7 +626,7 @@ range(R) when ?IS_SET(R) -> case ?TYPE(R) of ?BINREL(_, RT) -> ?SET(ran(?LIST(R), []), RT); ?ANYTYPE -> R; - _ -> erlang:error(badarg, [R]) + _ -> erlang:error(badarg) end. -spec(field(BinRel) -> Set when @@ -679,7 +649,7 @@ relative_product(RT) when is_tuple(RT) -> relative_product(RL) when is_list(RL) -> case relprod_n(RL, foo, false, false) of {error, Reason} -> - erlang:error(Reason, [RL]); + erlang:error(Reason); Reply -> Reply end. @@ -703,11 +673,11 @@ relative_product(RL, R) when is_list(RL), ?IS_SET(R) -> EmptyR = case ?TYPE(R) of ?BINREL(_, _) -> ?LIST(R) =:= []; ?ANYTYPE -> true; - _ -> erlang:error(badarg, [RL, R]) + _ -> erlang:error(badarg) end, case relprod_n(RL, R, EmptyR, true) of {error, Reason} -> - erlang:error(Reason, [RL, R]); + erlang:error(Reason); Reply -> Reply end. @@ -720,18 +690,18 @@ relative_product1(R1, R2) when ?IS_SET(R1), ?IS_SET(R2) -> {DTR1, RTR1} = case ?TYPE(R1) of ?BINREL(_, _) = R1T -> R1T; ?ANYTYPE -> {?ANYTYPE, ?ANYTYPE}; - _ -> erlang:error(badarg, [R1, R2]) + _ -> erlang:error(badarg) end, {DTR2, RTR2} = case ?TYPE(R2) of ?BINREL(_, _) = R2T -> R2T; ?ANYTYPE -> {?ANYTYPE, ?ANYTYPE}; - _ -> erlang:error(badarg, [R1, R2]) + _ -> erlang:error(badarg) end, case match_types(DTR1, DTR2) of true when DTR1 =:= ?ANYTYPE -> R1; true when DTR2 =:= ?ANYTYPE -> R2; true -> ?SET(relprod(?LIST(R1), ?LIST(R2)), ?BINREL(RTR1, RTR2)); - false -> erlang:error(type_mismatch, [R1, R2]) + false -> erlang:error(type_mismatch) end. -spec(converse(BinRel1) -> BinRel2 when @@ -741,7 +711,7 @@ converse(R) when ?IS_SET(R) -> case ?TYPE(R) of ?BINREL(DT, RT) -> ?SET(converse(?LIST(R), []), ?BINREL(RT, DT)); ?ANYTYPE -> R; - _ -> erlang:error(badarg, [R]) + _ -> erlang:error(badarg) end. -spec(image(BinRel, Set1) -> Set2 when @@ -755,10 +725,10 @@ image(R, S) when ?IS_SET(R), ?IS_SET(S) -> true -> ?SET(usort(restrict(?LIST(S), ?LIST(R))), RT); false -> - erlang:error(type_mismatch, [R, S]) + erlang:error(type_mismatch) end; ?ANYTYPE -> R; - _ -> erlang:error(badarg, [R, S]) + _ -> erlang:error(badarg) end. -spec(inverse_image(BinRel, Set1) -> Set2 when @@ -773,10 +743,10 @@ inverse_image(R, S) when ?IS_SET(R), ?IS_SET(S) -> NL = restrict(?LIST(S), converse(?LIST(R), [])), ?SET(usort(NL), DT); false -> - erlang:error(type_mismatch, [R, S]) + erlang:error(type_mismatch) end; ?ANYTYPE -> R; - _ -> erlang:error(badarg, [R, S]) + _ -> erlang:error(badarg) end. -spec(strict_relation(BinRel1) -> BinRel2 when @@ -787,7 +757,7 @@ strict_relation(R) when ?IS_SET(R) -> Type = ?BINREL(_, _) -> ?SET(strict(?LIST(R), []), Type); ?ANYTYPE -> R; - _ -> erlang:error(badarg, [R]) + _ -> erlang:error(badarg) end. -spec(weak_relation(BinRel1) -> BinRel2 when @@ -798,12 +768,12 @@ weak_relation(R) when ?IS_SET(R) -> ?BINREL(DT, RT) -> case unify_types(DT, RT) of [] -> - erlang:error(badarg, [R]); + erlang:error(badarg); Type -> ?SET(weak(?LIST(R)), ?BINREL(Type, Type)) end; ?ANYTYPE -> R; - _ -> erlang:error(badarg, [R]) + _ -> erlang:error(badarg) end. -spec(extension(BinRel1, Set, AnySet) -> BinRel2 when @@ -816,7 +786,7 @@ extension(R, S, E) when ?IS_SET(R), ?IS_SET(S) -> {T=?BINREL(DT, RT), ST, true} -> case match_types(DT, ST) and match_types(RT, type(E)) of false -> - erlang:error(type_mismatch, [R, S, E]); + erlang:error(type_mismatch); true -> RL = ?LIST(R), case extc([], ?LIST(S), to_external(E), RL) of @@ -836,7 +806,7 @@ extension(R, S, E) when ?IS_SET(R), ?IS_SET(S) -> ?SET([], ?BINREL(ST, ET)) end; {_, _, true} -> - erlang:error(badarg, [R, S, E]) + erlang:error(badarg) end. -spec(is_a_function(BinRel) -> Bool when @@ -850,7 +820,7 @@ is_a_function(R) when ?IS_SET(R) -> [{V,_} | Es] -> is_a_func(Es, V) end; ?ANYTYPE -> true; - _ -> erlang:error(badarg, [R]) + _ -> erlang:error(badarg) end. -spec(restriction(BinRel1, Set) -> BinRel2 when @@ -879,12 +849,12 @@ composite(Fn1, Fn2) when ?IS_SET(Fn1), ?IS_SET(Fn2) -> ?BINREL(DTF1, RTF1) = case ?TYPE(Fn1)of ?BINREL(_, _) = F1T -> F1T; ?ANYTYPE -> {?ANYTYPE, ?ANYTYPE}; - _ -> erlang:error(badarg, [Fn1, Fn2]) + _ -> erlang:error(badarg) end, ?BINREL(DTF2, RTF2) = case ?TYPE(Fn2) of ?BINREL(_, _) = F2T -> F2T; ?ANYTYPE -> {?ANYTYPE, ?ANYTYPE}; - _ -> erlang:error(badarg, [Fn1, Fn2]) + _ -> erlang:error(badarg) end, case match_types(RTF1, DTF2) of true when DTF1 =:= ?ANYTYPE -> Fn1; @@ -894,9 +864,9 @@ composite(Fn1, Fn2) when ?IS_SET(Fn1), ?IS_SET(Fn2) -> SL when is_list(SL) -> ?SET(sort(SL), ?BINREL(DTF1, RTF2)); Bad -> - erlang:error(Bad, [Fn1, Fn2]) + erlang:error(Bad) end; - false -> erlang:error(type_mismatch, [Fn1, Fn2]) + false -> erlang:error(type_mismatch) end. -spec(inverse(Function1) -> Function2 when @@ -909,10 +879,10 @@ inverse(Fn) when ?IS_SET(Fn) -> SL when is_list(SL) -> ?SET(SL, ?BINREL(RT, DT)); Bad -> - erlang:error(Bad, [Fn]) + erlang:error(Bad) end; ?ANYTYPE -> Fn; - _ -> erlang:error(badarg, [Fn]) + _ -> erlang:error(badarg) end. %%% @@ -932,7 +902,7 @@ restriction(I, R, S) when is_integer(I), ?IS_SET(R), ?IS_SET(S) -> empty -> R; error -> - erlang:error(badarg, [I, R, S]); + erlang:error(badarg); Sort -> RL = ?LIST(R), case {match_types(?REL_TYPE(I, RT), ST), ?LIST(S)} of @@ -945,7 +915,7 @@ restriction(I, R, S) when is_integer(I), ?IS_SET(R), ?IS_SET(S) -> {true, [E | Es]} -> ?SET(sort(restrict_n(I, keysort(I, RL), E, Es, [])), RT); {false, _SL} -> - erlang:error(type_mismatch, [I, R, S]) + erlang:error(type_mismatch) end end; restriction(SetFun, S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> @@ -963,28 +933,27 @@ restriction(SetFun, S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> NL = sort(restrict(?LIST(S2), converse(NSL, []))), ?SET(NL, Type1); false -> - erlang:error(type_mismatch, [SetFun, S1, S2]) + erlang:error(type_mismatch) end; Bad -> - erlang:error(Bad, [SetFun, S1, S2]) + erlang:error(Bad) end; _ when Type1 =:= ?ANYTYPE -> S1; _XFun when ?IS_SET_OF(Type1) -> - erlang:error(badarg, [SetFun, S1, S2]); + erlang:error(badarg); XFun -> FunT = XFun(Type1), - case catch check_fun(Type1, XFun, FunT) of - {'EXIT', _} -> - erlang:error(badarg, [SetFun, S1, S2]); + try check_fun(Type1, XFun, FunT) of Sort -> case match_types(FunT, Type2) of true -> R1 = inverse_substitution(SL1, XFun, Sort), ?SET(sort(Sort, restrict(?LIST(S2), R1)), Type1); false -> - erlang:error(type_mismatch, [SetFun, S1, S2]) + erlang:error(type_mismatch) end + catch _:_ -> erlang:error(badarg) end end. @@ -1000,7 +969,7 @@ drestriction(I, R, S) when is_integer(I), ?IS_SET(R), ?IS_SET(S) -> empty -> R; error -> - erlang:error(badarg, [I, R, S]); + erlang:error(badarg); Sort -> RL = ?LIST(R), case {match_types(?REL_TYPE(I, RT), ST), ?LIST(S)} of @@ -1013,7 +982,7 @@ drestriction(I, R, S) when is_integer(I), ?IS_SET(R), ?IS_SET(S) -> {true, [E | Es]} -> ?SET(diff_restrict_n(I, keysort(I, RL), E, Es, []), RT); {false, _SL} -> - erlang:error(type_mismatch, [I, R, S]) + erlang:error(type_mismatch) end end; drestriction(SetFun, S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> @@ -1032,20 +1001,18 @@ drestriction(SetFun, S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> NL = sort(diff_restrict(SL2, converse(NSL, []))), ?SET(NL, Type1); false -> - erlang:error(type_mismatch, [SetFun, S1, S2]) + erlang:error(type_mismatch) end; Bad -> - erlang:error(Bad, [SetFun, S1, S2]) + erlang:error(Bad) end; _ when Type1 =:= ?ANYTYPE -> S1; _XFun when ?IS_SET_OF(Type1) -> - erlang:error(badarg, [SetFun, S1, S2]); + erlang:error(badarg); XFun -> FunT = XFun(Type1), - case catch check_fun(Type1, XFun, FunT) of - {'EXIT', _} -> - erlang:error(badarg, [SetFun, S1, S2]); + try check_fun(Type1, XFun, FunT) of Sort -> case match_types(FunT, Type2) of true -> @@ -1053,8 +1020,9 @@ drestriction(SetFun, S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> SL2 = ?LIST(S2), ?SET(sort(Sort, diff_restrict(SL2, R1)), Type1); false -> - erlang:error(type_mismatch, [SetFun, S1, S2]) + erlang:error(type_mismatch) end + catch _:_ -> erlang:error(badarg) end end. @@ -1068,7 +1036,7 @@ projection(I, Set) when is_integer(I), ?IS_SET(Set) -> empty -> Set; error -> - erlang:error(badarg, [I, Set]); + erlang:error(badarg); _ when I =:= 1 -> ?SET(projection1(?LIST(Set)), ?REL_TYPE(I, Type)); _ -> @@ -1087,7 +1055,7 @@ substitution(I, Set) when is_integer(I), ?IS_SET(Set) -> empty -> Set; error -> - erlang:error(badarg, [I, Set]); + erlang:error(badarg); _Sort -> NType = ?REL_TYPE(I, Type), NSL = substitute_element(?LIST(Set), I, []), @@ -1102,22 +1070,21 @@ substitution(SetFun, Set) when ?IS_SET(Set) -> {SL, NewType} -> ?SET(reverse(SL), ?BINREL(Type, NewType)); Bad -> - erlang:error(Bad, [SetFun, Set]) + erlang:error(Bad) end; false -> empty_set(); _ when Type =:= ?ANYTYPE -> empty_set(); _XFun when ?IS_SET_OF(Type) -> - erlang:error(badarg, [SetFun, Set]); + erlang:error(badarg); XFun -> FunT = XFun(Type), - case catch check_fun(Type, XFun, FunT) of - {'EXIT', _} -> - erlang:error(badarg, [SetFun, Set]); + try check_fun(Type, XFun, FunT) of _Sort -> SL = substitute(L, XFun, []), ?SET(SL, ?BINREL(Type, FunT)) + catch _:_ -> erlang:error(badarg) end end. @@ -1139,7 +1106,7 @@ partition(I, Set) when is_integer(I), ?IS_SET(Set) -> empty -> Set; error -> - erlang:error(badarg, [I, Set]); + erlang:error(badarg); false -> % I =:= 1 ?SET(partition_n(I, ?LIST(Set)), ?SET_OF(Type)); true -> @@ -1161,7 +1128,7 @@ partition(I, R, S) when is_integer(I), ?IS_SET(R), ?IS_SET(S) -> empty -> {R, R}; error -> - erlang:error(badarg, [I, R, S]); + erlang:error(badarg); Sort -> RL = ?LIST(R), case {match_types(?REL_TYPE(I, RT), ST), ?LIST(S)} of @@ -1176,7 +1143,7 @@ partition(I, R, S) when is_integer(I), ?IS_SET(R), ?IS_SET(S) -> [L1 | L2] = partition3_n(I, keysort(I,RL), E, Es, [], []), {?SET(L1, RT), ?SET(L2, RT)}; {false, _SL} -> - erlang:error(type_mismatch, [I, R, S]) + erlang:error(type_mismatch) end end; partition(SetFun, S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> @@ -1195,20 +1162,18 @@ partition(SetFun, S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> [L1 | L2] = partition3(?LIST(S2), R1), {?SET(sort(L1), Type1), ?SET(sort(L2), Type1)}; false -> - erlang:error(type_mismatch, [SetFun, S1, S2]) + erlang:error(type_mismatch) end; Bad -> - erlang:error(Bad, [SetFun, S1, S2]) + erlang:error(Bad) end; _ when Type1 =:= ?ANYTYPE -> {S1, S1}; _XFun when ?IS_SET_OF(Type1) -> - erlang:error(badarg, [SetFun, S1, S2]); + erlang:error(badarg); XFun -> FunT = XFun(Type1), - case catch check_fun(Type1, XFun, FunT) of - {'EXIT', _} -> - erlang:error(badarg, [SetFun, S1, S2]); + try check_fun(Type1, XFun, FunT) of Sort -> case match_types(FunT, Type2) of true -> @@ -1216,8 +1181,9 @@ partition(SetFun, S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> [L1 | L2] = partition3(?LIST(S2), R1), {?SET(sort(L1), Type1), ?SET(sort(L2), Type1)}; false -> - erlang:error(type_mismatch, [SetFun, S1, S2]) + erlang:error(type_mismatch) end + catch _:_ -> erlang:error(badarg) end end. @@ -1234,7 +1200,7 @@ multiple_relative_product(T, R) when is_tuple(T), ?IS_SET(R) -> MProd = mul_relprod(tuple_to_list(T), 1, R), relative_product(MProd); false -> - erlang:error(badarg, [T, R]) + erlang:error(badarg) end. -spec(join(Relation1, I, Relation2, J) -> Relation3 when @@ -1246,8 +1212,7 @@ multiple_relative_product(T, R) when is_tuple(T), ?IS_SET(R) -> join(R1, I1, R2, I2) when ?IS_SET(R1), ?IS_SET(R2), is_integer(I1), is_integer(I2) -> case test_rel(R1, I1, lte) and test_rel(R2, I2, lte) of - false -> - erlang:error(badarg, [R1, I1, R2, I2]); + false -> erlang:error(badarg); true when ?TYPE(R1) =:= ?ANYTYPE -> R1; true when ?TYPE(R2) =:= ?ANYTYPE -> R2; true -> @@ -1294,7 +1259,7 @@ family_to_relation(F) when ?IS_SET(F) -> ?FAMILY(DT, RT) -> ?SET(family2rel(?LIST(F), []), ?BINREL(DT, RT)); ?ANYTYPE -> F; - _ -> erlang:error(badarg, [F]) + _ -> erlang:error(badarg) end. -spec(family_specification(Fun, Family1) -> Family2 when @@ -1314,10 +1279,10 @@ family_specification(Fun, F) when ?IS_SET(F) -> SL when is_list(SL) -> ?SET(SL, FType); Bad -> - erlang:error(Bad, [Fun, F]) + erlang:error(Bad) end; ?ANYTYPE -> F; - _ -> erlang:error(badarg, [Fun, F]) + _ -> erlang:error(badarg) end. -spec(union_of_family(Family) -> Set when @@ -1328,7 +1293,7 @@ union_of_family(F) when ?IS_SET(F) -> ?FAMILY(_DT, Type) -> ?SET(un_of_fam(?LIST(F), []), Type); ?ANYTYPE -> F; - _ -> erlang:error(badarg, [F]) + _ -> erlang:error(badarg) end. -spec(intersection_of_family(Family) -> Set when @@ -1341,9 +1306,9 @@ intersection_of_family(F) when ?IS_SET(F) -> FU when is_list(FU) -> ?SET(FU, Type); Bad -> - erlang:error(Bad, [F]) + erlang:error(Bad) end; - _ -> erlang:error(badarg, [F]) + _ -> erlang:error(badarg) end. -spec(family_union(Family1) -> Family2 when @@ -1354,7 +1319,7 @@ family_union(F) when ?IS_SET(F) -> ?FAMILY(DT, ?SET_OF(Type)) -> ?SET(fam_un(?LIST(F), []), ?FAMILY(DT, Type)); ?ANYTYPE -> F; - _ -> erlang:error(badarg, [F]) + _ -> erlang:error(badarg) end. -spec(family_intersection(Family1) -> Family2 when @@ -1367,10 +1332,10 @@ family_intersection(F) when ?IS_SET(F) -> FU when is_list(FU) -> ?SET(FU, ?FAMILY(DT, Type)); Bad -> - erlang:error(Bad, [F]) + erlang:error(Bad) end; ?ANYTYPE -> F; - _ -> erlang:error(badarg, [F]) + _ -> erlang:error(badarg) end. -spec(family_domain(Family1) -> Family2 when @@ -1382,7 +1347,7 @@ family_domain(F) when ?IS_SET(F) -> ?SET(fam_dom(?LIST(F), []), ?FAMILY(FDT, DT)); ?ANYTYPE -> F; ?FAMILY(_, ?ANYTYPE) -> F; - _ -> erlang:error(badarg, [F]) + _ -> erlang:error(badarg) end. -spec(family_range(Family1) -> Family2 when @@ -1394,7 +1359,7 @@ family_range(F) when ?IS_SET(F) -> ?SET(fam_ran(?LIST(F), []), ?FAMILY(DT, RT)); ?ANYTYPE -> F; ?FAMILY(_, ?ANYTYPE) -> F; - _ -> erlang:error(badarg, [F]) + _ -> erlang:error(badarg) end. -spec(family_field(Family1) -> Family2 when @@ -1428,12 +1393,12 @@ family_difference(F1, F2) -> fam_binop(F1, F2, FF) when ?IS_SET(F1), ?IS_SET(F2) -> case unify_types(?TYPE(F1), ?TYPE(F2)) of [] -> - erlang:error(type_mismatch, [F1, F2]); + erlang:error(type_mismatch); ?ANYTYPE -> F1; Type = ?FAMILY(_, _) -> ?SET(FF(?LIST(F1), ?LIST(F2), []), Type); - _ -> erlang:error(badarg, [F1, F2]) + _ -> erlang:error(badarg) end. -spec(partition_family(SetFun, Set) -> Family when @@ -1446,7 +1411,7 @@ partition_family(I, Set) when is_integer(I), ?IS_SET(Set) -> empty -> Set; error -> - erlang:error(badarg, [I, Set]); + erlang:error(badarg); false -> % when I =:= 1 ?SET(fam_partition_n(I, ?LIST(Set)), ?BINREL(?REL_TYPE(I, Type), ?SET_OF(Type))); @@ -1464,23 +1429,22 @@ partition_family(SetFun, Set) when ?IS_SET(Set) -> P = fam_partition(converse(NSL, []), true), ?SET(reverse(P), ?BINREL(NewType, ?SET_OF(Type))); Bad -> - erlang:error(Bad, [SetFun, Set]) + erlang:error(Bad) end; false -> empty_set(); _ when Type =:= ?ANYTYPE -> empty_set(); _XFun when ?IS_SET_OF(Type) -> - erlang:error(badarg, [SetFun, Set]); + erlang:error(badarg); XFun -> DType = XFun(Type), - case catch check_fun(Type, XFun, DType) of - {'EXIT', _} -> - erlang:error(badarg, [SetFun, Set]); + try check_fun(Type, XFun, DType) of Sort -> Ts = inverse_substitution(?LIST(Set), XFun, Sort), P = fam_partition(Ts, Sort), ?SET(reverse(P), ?BINREL(DType, ?SET_OF(Type))) + catch _:_ -> erlang:error(badarg) end end. @@ -1499,13 +1463,13 @@ family_projection(SetFun, F) when ?IS_SET(F) -> {SL, NewType} -> ?SET(SL, ?BINREL(DT, NewType)); Bad -> - erlang:error(Bad, [SetFun, F]) + erlang:error(Bad) end; _ -> - erlang:error(badarg, [SetFun, F]) + erlang:error(badarg) end; ?ANYTYPE -> F; - _ -> erlang:error(badarg, [SetFun, F]) + _ -> erlang:error(badarg) end. %%% @@ -1519,7 +1483,7 @@ family_to_digraph(F) when ?IS_SET(F) -> case ?TYPE(F) of ?FAMILY(_, _) -> fam2digraph(F, digraph:new()); ?ANYTYPE -> digraph:new(); - _Else -> erlang:error(badarg, [F]) + _Else -> erlang:error(badarg) end. -spec(family_to_digraph(Family, GraphType) -> Graph when @@ -1530,27 +1494,27 @@ family_to_digraph(F, Type) when ?IS_SET(F) -> case ?TYPE(F) of ?FAMILY(_, _) -> ok; ?ANYTYPE -> ok; - _Else -> erlang:error(badarg, [F, Type]) + _Else -> erlang:error(badarg) end, try digraph:new(Type) of G -> case catch fam2digraph(F, G) of {error, Reason} -> true = digraph:delete(G), - erlang:error(Reason, [F, Type]); + erlang:error(Reason); _ -> G end catch - error:badarg -> erlang:error(badarg, [F, Type]) + error:badarg -> erlang:error(badarg) end. -spec(digraph_to_family(Graph) -> Family when Graph :: digraph:graph(), Family :: family()). digraph_to_family(G) -> - case catch digraph_family(G) of - {'EXIT', _} -> erlang:error(badarg, [G]); + try digraph_family(G) of L -> ?SET(L, ?FAMILY(?ATOM_TYPE, ?ATOM_TYPE)) + catch _:_ -> erlang:error(badarg) end. -spec(digraph_to_family(Graph, Type) -> Family when @@ -1560,12 +1524,12 @@ digraph_to_family(G) -> digraph_to_family(G, T) -> case {is_type(T), T} of {true, ?SET_OF(?FAMILY(_,_) = Type)} -> - case catch digraph_family(G) of - {'EXIT', _} -> erlang:error(badarg, [G, T]); + try digraph_family(G) of L -> ?SET(L, Type) + catch _:_ -> erlang:error(badarg) end; _ -> - erlang:error(badarg, [G, T]) + erlang:error(badarg) end. %% @@ -1713,14 +1677,15 @@ func_type([], SL, Type, F) -> setify(L, ?SET_OF(Atom)) when ?IS_ATOM_TYPE(Atom), Atom =/= ?ANYTYPE -> ?SET(usort(L), Atom); setify(L, ?SET_OF(Type0)) -> - case catch is_no_lists(Type0) of - {'EXIT', _} -> - {?SET_OF(Type), Set} = create(L, Type0, Type0, []), - ?SET(Set, Type); + try is_no_lists(Type0) of N when is_integer(N) -> - rel(L, N, Type0); + rel(L, N, Type0); Sizes -> make_oset(L, Sizes, L, Type0) + catch + _:_ -> + {?SET_OF(Type), Set} = create(L, Type0, Type0, []), + ?SET(Set, Type) end; setify(E, Type0) -> {Type, OrdSet} = make_element(E, Type0, Type0), diff --git a/lib/stdlib/src/stdlib.appup.src b/lib/stdlib/src/stdlib.appup.src index 979161fef7..3c9e95e3a9 100644 --- a/lib/stdlib/src/stdlib.appup.src +++ b/lib/stdlib/src/stdlib.appup.src @@ -18,7 +18,7 @@ %% %CopyrightEnd% {"%VSN%", %% Up from - max one major revision back - [{<<"3\\.[0-1](\\.[0-9]+)*">>,[restart_new_emulator]}], % OTP-19.* + [{<<"3\\.[0-3](\\.[0-9]+)*">>,[restart_new_emulator]}], % OTP-19.* %% Down to - max one major revision back - [{<<"3\\.[0-1](\\.[0-9]+)*">>,[restart_new_emulator]}] % OTP-19.* + [{<<"3\\.[0-3](\\.[0-9]+)*">>,[restart_new_emulator]}] % OTP-19.* }. diff --git a/lib/stdlib/src/zip.erl b/lib/stdlib/src/zip.erl index 340cc21390..fadf96146e 100644 --- a/lib/stdlib/src/zip.erl +++ b/lib/stdlib/src/zip.erl @@ -179,19 +179,6 @@ external_attr, local_header_offset}). -%% Unix extra fields (not yet supported) --define(UNIX_EXTRA_FIELD_TAG, 16#000d). --record(unix_extra_field, {atime, - mtime, - uid, - gid}). - -%% extended timestamps (not yet supported) --define(EXTENDED_TIMESTAMP_TAG, 16#5455). -%% -record(extended_timestamp, {mtime, -%% atime, -%% ctime}). - -define(END_OF_CENTRAL_DIR_MAGIC, 16#06054b50). -define(END_OF_CENTRAL_DIR_SZ, (4+2+2+2+2+4+4+2)). @@ -381,9 +368,12 @@ do_unzip(F, Options) -> {Info, In1} = get_central_dir(In0, RawIterator, Input), %% get rid of zip-comment Z = zlib:open(), - Files = get_z_files(Info, Z, In1, Opts, []), - zlib:close(Z), - Input(close, In1), + Files = try + get_z_files(Info, Z, In1, Opts, []) + after + zlib:close(Z), + Input(close, In1) + end, {ok, Files}. %% Iterate over all files in a zip archive @@ -460,11 +450,20 @@ do_zip(F, Files, Options) -> #zip_opts{output = Output, open_opts = OpO} = Opts, Out0 = Output({open, F, OpO}, []), Z = zlib:open(), - {Out1, LHS, Pos} = put_z_files(Files, Z, Out0, 0, Opts, []), - zlib:close(Z), - Out2 = put_central_dir(LHS, Pos, Out1, Opts), - Out3 = Output({close, F}, Out2), - {ok, Out3}. + try + {Out1, LHS, Pos} = put_z_files(Files, Z, Out0, 0, Opts, []), + zlib:close(Z), + Out2 = put_central_dir(LHS, Pos, Out1, Opts), + Out3 = Output({close, F}, Out2), + {ok, Out3} + catch + C:R -> + Stk = erlang:get_stacktrace(), + zlib:close(Z), + Output({close, F}, Out0), + erlang:raise(C, R, Stk) + end. + %% List zip directory contents %% @@ -1379,12 +1378,7 @@ cd_file_header_to_file_info(FileName, gid = 0}, add_extra_info(FI, ExtraField). -%% add extra info to file (some day when we implement it) -add_extra_info(FI, <<?EXTENDED_TIMESTAMP_TAG:16/little, _Rest/binary>>) -> - FI; % not yet supported, some other day... -add_extra_info(FI, <<?UNIX_EXTRA_FIELD_TAG:16/little, Rest/binary>>) -> - _UnixExtra = unix_extra_field_and_var_from_bin(Rest), - FI; % not yet supported, and not widely used +%% Currently, we ignore all the extra fields. add_extra_info(FI, _) -> FI. @@ -1572,20 +1566,6 @@ dos_date_time_from_datetime({{Year, Month, Day}, {Hour, Min, Sec}}) -> <<DosDate:16>> = <<YearFrom1980:7, Month:4, Day:5>>, {DosDate, DosTime}. -unix_extra_field_and_var_from_bin(<<TSize:16/little, - ATime:32/little, - MTime:32/little, - UID:16/little, - GID:16/little, - Var:TSize/binary>>) -> - {#unix_extra_field{atime = ATime, - mtime = MTime, - uid = UID, - gid = GID}, - Var}; -unix_extra_field_and_var_from_bin(_) -> - throw(bad_unix_extra_field). - %% A pwrite-like function for iolists (used by memory-option) pwrite_binary(B, Pos, Bin) when byte_size(B) =:= Pos -> diff --git a/lib/stdlib/test/base64_SUITE.erl b/lib/stdlib/test/base64_SUITE.erl index d0abe5c961..6ddc67464c 100644 --- a/lib/stdlib/test/base64_SUITE.erl +++ b/lib/stdlib/test/base64_SUITE.erl @@ -82,7 +82,7 @@ base64_decode(Config) when is_list(Config) -> Alphabet = list_to_binary(lists:seq(0, 255)), Alphabet = base64:decode(base64:encode(Alphabet)), - %% Encoded base 64 strings may be devided by non base 64 chars. + %% Encoded base 64 strings may be divided by non base 64 chars. %% In this cases whitespaces. "0123456789!@#0^&*();:<>,. []{}" = base64:decode_to_string( diff --git a/lib/stdlib/test/edlin_expand_SUITE.erl b/lib/stdlib/test/edlin_expand_SUITE.erl index 718d91c6a3..1f694ea549 100644 --- a/lib/stdlib/test/edlin_expand_SUITE.erl +++ b/lib/stdlib/test/edlin_expand_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2010-2016. All Rights Reserved. +%% Copyright Ericsson AB 2010-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -21,7 +21,8 @@ -export([all/0, suite/0,groups/0,init_per_suite/1, end_per_suite/1, init_per_testcase/2, end_per_testcase/2, init_per_group/2,end_per_group/2]). --export([normal/1, quoted_fun/1, quoted_module/1, quoted_both/1, erl_1152/1]). +-export([normal/1, quoted_fun/1, quoted_module/1, quoted_both/1, erl_1152/1, + erl_352/1]). -include_lib("common_test/include/ct.hrl"). @@ -36,7 +37,7 @@ suite() -> {timetrap,{minutes,1}}]. all() -> - [normal, quoted_fun, quoted_module, quoted_both, erl_1152]. + [normal, quoted_fun, quoted_module, quoted_both, erl_1152, erl_352]. groups() -> []. @@ -153,6 +154,78 @@ erl_1152(Config) when is_list(Config) -> "\n"++"foo"++" "++[1089]++_ = do_format(["foo",[1089]]), ok. +erl_352(Config) when is_list(Config) -> + erl_352_test(3, 3), + + erl_352_test(3, 75), + erl_352_test(3, 76, [trailing]), + erl_352_test(4, 74), + erl_352_test(4, 75, [leading]), + erl_352_test(4, 76, [leading, trailing]), + + erl_352_test(75, 3), + erl_352_test(76, 3, [leading]), + erl_352_test(74, 4), + erl_352_test(75, 4, [leading]), + erl_352_test(76, 4, [leading]), + + erl_352_test(74, 74, [leading]), + erl_352_test(74, 75, [leading]), + erl_352_test(74, 76, [leading, trailing]). + +erl_352_test(PrefixLen, SuffixLen) -> + erl_352_test(PrefixLen, SuffixLen, []). + +erl_352_test(PrefixLen, SuffixLen, Dots) -> + io:format("\nPrefixLen = ~w, SuffixLen = ~w\n", [PrefixLen, SuffixLen]), + + PrefixM = lists:duplicate(PrefixLen, $p), + SuffixM = lists:duplicate(SuffixLen, $s), + LM = [PrefixM ++ S ++ SuffixM || S <- ["1", "2"]], + StrM = do_format(LM), + check_leading(StrM, "", PrefixM, SuffixM, Dots), + + PrefixF = lists:duplicate(PrefixLen, $p), + SuffixF = lists:duplicate(SuffixLen-2, $s), + LF = [{PrefixF ++ S ++ SuffixF, 1} || S <- ["1", "2"]], + StrF = do_format(LF), + true = check_leading(StrF, "/1", PrefixF, SuffixF, Dots), + + ok. + +check_leading(FormStr, ArityStr, Prefix, Suffix, Dots) -> + List = string:tokens(FormStr, "\n "), + io:format("~p\n", [List]), + true = lists:all(fun(L) -> length(L) < 80 end, List), + case lists:member(leading, Dots) of + true -> + true = lists:all(fun(L) -> + {"...", Rest} = lists:split(3, L), + check_trailing(Rest, ArityStr, + Suffix, Dots) + end, List); + false -> + true = lists:all(fun(L) -> + {Prefix, Rest} = + lists:split(length(Prefix), L), + check_trailing(Rest, ArityStr, + Suffix, Dots) + end, List) + end. + +check_trailing([I|Str], ArityStr, Suffix, Dots) -> + true = lists:member(I, [$1, $2]), + case lists:member(trailing, Dots) of + true -> + {Rest, "..." ++ ArityStr} = + lists:split(length(Str) - (3 + length(ArityStr)), Str), + true = lists:prefix(Rest, Suffix); + false -> + {Rest, ArityStr} = + lists:split(length(Str) - length(ArityStr), Str), + Rest =:= Suffix + end. + do_expand(String) -> edlin_expand:expand(lists:reverse(String)). diff --git a/lib/stdlib/test/ets_SUITE.erl b/lib/stdlib/test/ets_SUITE.erl index f68d5eca3f..8581440d58 100644 --- a/lib/stdlib/test/ets_SUITE.erl +++ b/lib/stdlib/test/ets_SUITE.erl @@ -22,7 +22,7 @@ -export([all/0, suite/0,groups/0,init_per_suite/1, end_per_suite/1, init_per_group/2,end_per_group/2]). -export([default/1,setbag/1,badnew/1,verybadnew/1,named/1,keypos2/1, - privacy/1,privacy_owner/2]). + privacy/1]). -export([empty/1,badinsert/1]). -export([time_lookup/1,badlookup/1,lookup_order/1]). -export([delete_elem/1,delete_tab/1,delete_large_tab/1, @@ -82,27 +82,6 @@ %% Convenience for manual testing -export([random_test/0]). -%% internal exports --export([dont_make_worse_sub/0, make_better_sub1/0, make_better_sub2/0]). --export([t_repair_continuation_do/1, t_bucket_disappears_do/1, - select_fail_do/1, whitebox_1/1, whitebox_2/1, t_delete_all_objects_do/1, - t_delete_object_do/1, t_init_table_do/1, t_insert_list_do/1, - update_element_opts/1, update_element_opts/4, update_element/4, update_element_do/4, - update_element_neg/1, update_element_neg_do/1, update_counter_do/1, update_counter_neg/1, - evil_update_counter_do/1, fixtable_next_do/1, heir_do/1, give_away_do/1, setopts_do/1, - rename_do/1, rename_unnamed_do/1, interface_equality_do/1, ordered_match_do/1, - ordered_do/1, privacy_do/1, empty_do/1, badinsert_do/1, time_lookup_do/1, - lookup_order_do/1, lookup_element_mult_do/1, delete_tab_do/1, delete_elem_do/1, - match_delete_do/1, match_delete3_do/1, firstnext_do/1, - slot_do/1, match1_do/1, match2_do/1, match_object_do/1, match_object2_do/1, - misc1_do/1, safe_fixtable_do/1, info_do/1, dups_do/1, heavy_lookup_do/1, - heavy_lookup_element_do/1, member_do/1, otp_5340_do/1, otp_7665_do/1, meta_wb_do/1, - do_heavy_concurrent/1, tab2file2_do/2, exit_large_table_owner_do/2, - types_do/1, sleeper/0, memory_do/1, update_counter_with_default_do/1, - update_counter_table_growth_do/1, - ms_tracee_dummy/1, ms_tracee_dummy/2, ms_tracee_dummy/3, ms_tracee_dummy/4 - ]). - -export([t_select_reverse/1]). -include_lib("common_test/include/ct.hrl"). @@ -228,7 +207,7 @@ memory_check_summary(_Config) -> %% Test that a disappearing bucket during select of a non-fixed table works. t_bucket_disappears(Config) when is_list(Config) -> - repeat_for_opts(t_bucket_disappears_do). + repeat_for_opts(fun t_bucket_disappears_do/1). t_bucket_disappears_do(Opts) -> EtsMem = etsmem(), @@ -396,11 +375,16 @@ ms_tracer_collect(Tracee, Ref, Acc) -> ms_tracee(Parent, CallArgList) -> Parent ! {self(), ready}, receive start -> ok end, - lists:foreach(fun(Args) -> - erlang:apply(?MODULE, ms_tracee_dummy, tuple_to_list(Args)) - end, CallArgList). - - + F = fun({A1}) -> + ms_tracee_dummy(A1); + ({A1,A2}) -> + ms_tracee_dummy(A1, A2); + ({A1,A2,A3}) -> + ms_tracee_dummy(A1, A2, A3); + ({A1,A2,A3,A4}) -> + ms_tracee_dummy(A1, A2, A3, A4) + end, + lists:foreach(F, CallArgList). ms_tracee_dummy(_) -> ok. ms_tracee_dummy(_,_) -> ok. @@ -418,7 +402,7 @@ assert_eq(A,B) -> %% Test ets:repair_continuation/2. t_repair_continuation(Config) when is_list(Config) -> - repeat_for_opts(t_repair_continuation_do). + repeat_for_opts(fun t_repair_continuation_do/1). t_repair_continuation_do(Opts) -> @@ -564,7 +548,8 @@ default(Config) when is_list(Config) -> %% Test that select fails even if nothing can match. select_fail(Config) when is_list(Config) -> EtsMem = etsmem(), - repeat_for_opts(select_fail_do, [all_types,write_concurrency]), + repeat_for_opts(fun select_fail_do/1, + [all_types,write_concurrency]), verify_etsmem(EtsMem). select_fail_do(Opts) -> @@ -594,7 +579,7 @@ select_fail_do(Opts) -> %% Whitebox test of ets:info(X, memory). memory(Config) when is_list(Config) -> ok = chk_normal_tab_struct_size(), - repeat_for_opts(memory_do,[compressed]), + repeat_for_opts(fun memory_do/1, [compressed]), catch erts_debug:set_internal_state(available_internal_state, false). memory_do(Opts) -> @@ -704,12 +689,12 @@ adjust_xmem([_T1,_T2,_T3,_T4], {A0,B0,C0,D0} = _Mem0, EstCnt) -> %% Misc. whitebox tests t_whitebox(Config) when is_list(Config) -> EtsMem = etsmem(), - repeat_for_opts(whitebox_1), - repeat_for_opts(whitebox_1), - repeat_for_opts(whitebox_1), - repeat_for_opts(whitebox_2), - repeat_for_opts(whitebox_2), - repeat_for_opts(whitebox_2), + repeat_for_opts(fun whitebox_1/1), + repeat_for_opts(fun whitebox_1/1), + repeat_for_opts(fun whitebox_1/1), + repeat_for_opts(fun whitebox_2/1), + repeat_for_opts(fun whitebox_2/1), + repeat_for_opts(fun whitebox_2/1), verify_etsmem(EtsMem). whitebox_1(Opts) -> @@ -774,7 +759,7 @@ check_badarg({'EXIT', {badarg, [{M,F,A,_} | _]}}, M, F, Args) -> %% Test ets:delete_all_objects/1. t_delete_all_objects(Config) when is_list(Config) -> EtsMem = etsmem(), - repeat_for_opts(t_delete_all_objects_do), + repeat_for_opts(fun t_delete_all_objects_do/1), verify_etsmem(EtsMem). get_kept_objects(T) -> @@ -808,7 +793,7 @@ t_delete_all_objects_do(Opts) -> %% Test ets:delete_object/2. t_delete_object(Config) when is_list(Config) -> EtsMem = etsmem(), - repeat_for_opts(t_delete_object_do), + repeat_for_opts(fun t_delete_object_do/1), verify_etsmem(EtsMem). t_delete_object_do(Opts) -> @@ -881,7 +866,7 @@ make_init_fun(N) -> %% Test ets:init_table/2. t_init_table(Config) when is_list(Config)-> EtsMem = etsmem(), - repeat_for_opts(t_init_table_do), + repeat_for_opts(fun t_init_table_do/1), verify_etsmem(EtsMem). t_init_table_do(Opts) -> @@ -957,7 +942,7 @@ t_insert_new(Config) when is_list(Config) -> %% Test ets:insert/2 with list of objects. t_insert_list(Config) when is_list(Config) -> EtsMem = etsmem(), - repeat_for_opts(t_insert_list_do), + repeat_for_opts(fun t_insert_list_do/1), verify_etsmem(EtsMem). t_insert_list_do(Opts) -> @@ -1187,7 +1172,7 @@ partly_bound(Config) when is_list(Config) -> end. dont_make_worse() -> - seventyfive_percent_success({?MODULE,dont_make_worse_sub,[]},0,0,10). + seventyfive_percent_success(fun dont_make_worse_sub/0, 0, 0, 10). dont_make_worse_sub() -> T = build_table([a,b],[a,b],15000), @@ -1199,8 +1184,9 @@ dont_make_worse_sub() -> ok. make_better() -> - fifty_percent_success({?MODULE,make_better_sub2,[]},0,0,10), - fifty_percent_success({?MODULE,make_better_sub1,[]},0,0,10). + fifty_percent_success(fun make_better_sub2/0, 0, 0, 10), + fifty_percent_success(fun make_better_sub1/0, 0, 0, 10). + make_better_sub1() -> T = build_table2([a,b],[a,b],15000), T1 = time_match_object(T,{'_',1500,a,a}, [{{1500,a,a},1500,a,a}]), @@ -1485,7 +1471,7 @@ do_random_test() -> %% Ttest various variants of update_element. update_element(Config) when is_list(Config) -> EtsMem = etsmem(), - repeat_for_opts(update_element_opts), + repeat_for_opts(fun update_element_opts/1), verify_etsmem(EtsMem). update_element_opts(Opts) -> @@ -1647,7 +1633,7 @@ update_element_neg_do(T) -> %% test various variants of update_counter. update_counter(Config) when is_list(Config) -> EtsMem = etsmem(), - repeat_for_opts(update_counter_do), + repeat_for_opts(fun update_counter_do/1), verify_etsmem(EtsMem). update_counter_do(Opts) -> @@ -1868,7 +1854,7 @@ evil_update_counter(Config) when is_list(Config) -> ordsets:module_info(), rand:module_info(), - repeat_for_opts(evil_update_counter_do). + repeat_for_opts(fun evil_update_counter_do/1). evil_update_counter_do(Opts) -> EtsMem = etsmem(), @@ -1915,7 +1901,7 @@ evil_counter_1(Iter, T) -> evil_counter_1(Iter-1, T). update_counter_with_default(Config) when is_list(Config) -> - repeat_for_opts(update_counter_with_default_do). + repeat_for_opts(fun update_counter_with_default_do/1). update_counter_with_default_do(Opts) -> T1 = ets_new(a, [set | Opts]), @@ -1953,7 +1939,7 @@ update_counter_with_default_do(Opts) -> ok. update_counter_table_growth(_Config) -> - repeat_for_opts(update_counter_table_growth_do). + repeat_for_opts(fun update_counter_table_growth_do/1). update_counter_table_growth_do(Opts) -> Set = ets_new(b, [set | Opts]), @@ -1964,7 +1950,8 @@ update_counter_table_growth_do(Opts) -> %% Check that a first-next sequence always works on a fixed table. fixtable_next(Config) when is_list(Config) -> - repeat_for_opts(fixtable_next_do, [write_concurrency,all_types]). + repeat_for_opts(fun fixtable_next_do/1, + [write_concurrency,all_types]). fixtable_next_do(Opts) -> EtsMem = etsmem(), @@ -2104,7 +2091,7 @@ write_concurrency(Config) when is_list(Config) -> %% The 'heir' option. heir(Config) when is_list(Config) -> - repeat_for_opts(heir_do). + repeat_for_opts(fun heir_do/1). heir_do(Opts) -> EtsMem = etsmem(), @@ -2244,7 +2231,7 @@ heir_1(HeirData,Mode,Opts) -> %% Test ets:give_way/3. give_away(Config) when is_list(Config) -> - repeat_for_opts(give_away_do). + repeat_for_opts(fun give_away_do/1). give_away_do(Opts) -> T = ets_new(foo,[named_table, private | Opts]), @@ -2325,7 +2312,7 @@ give_away_receiver(T, Giver) -> %% Test ets:setopts/2. setopts(Config) when is_list(Config) -> - repeat_for_opts(setopts_do,[write_concurrency,all_types]). + repeat_for_opts(fun setopts_do/1, [write_concurrency,all_types]). setopts_do(Opts) -> Self = self(), @@ -2475,7 +2462,7 @@ bad_table_call(T,{F,Args,_,{return,Return}}) -> %% Check rename of ets tables. rename(Config) when is_list(Config) -> - repeat_for_opts(rename_do, [write_concurrency, all_types]). + repeat_for_opts(fun rename_do/1, [write_concurrency, all_types]). rename_do(Opts) -> EtsMem = etsmem(), @@ -2490,7 +2477,8 @@ rename_do(Opts) -> %% Check rename of unnamed ets table. rename_unnamed(Config) when is_list(Config) -> - repeat_for_opts(rename_unnamed_do,[write_concurrency,all_types]). + repeat_for_opts(fun rename_unnamed_do/1, + [write_concurrency,all_types]). rename_unnamed_do(Opts) -> EtsMem = etsmem(), @@ -2565,7 +2553,7 @@ evil_create_fixed_tab() -> %% Tests that the return values and errors are equal for set's and %% ordered_set's where applicable. interface_equality(Config) when is_list(Config) -> - repeat_for_opts(interface_equality_do). + repeat_for_opts(fun interface_equality_do/1). interface_equality_do(Opts) -> EtsMem = etsmem(), @@ -2629,7 +2617,7 @@ maybe_sort(Any) -> %% Test match, match_object and match_delete in ordered set's. ordered_match(Config) when is_list(Config)-> - repeat_for_opts(ordered_match_do). + repeat_for_opts(fun ordered_match_do/1). ordered_match_do(Opts) -> EtsMem = etsmem(), @@ -2675,7 +2663,7 @@ ordered_match_do(Opts) -> %% Test basic functionality in ordered_set's. ordered(Config) when is_list(Config) -> - repeat_for_opts(ordered_do). + repeat_for_opts(fun ordered_do/1). ordered_do(Opts) -> EtsMem = etsmem(), @@ -2801,12 +2789,13 @@ keypos2(Config) when is_list(Config) -> %% Privacy check. Check that a named(public/private/protected) table %% cannot be read by the wrong process(es). privacy(Config) when is_list(Config) -> - repeat_for_opts(privacy_do). + repeat_for_opts(fun privacy_do/1). privacy_do(Opts) -> EtsMem = etsmem(), process_flag(trap_exit,true), - Owner = my_spawn_link(?MODULE,privacy_owner,[self(),Opts]), + Parent = self(), + Owner = my_spawn_link(fun() -> privacy_owner(Parent, Opts) end), receive {'EXIT',Owner,Reason} -> exit({privacy_test,Reason}); @@ -2886,7 +2875,7 @@ rotate_tuple(Tuple, N) -> %% Check lookup in an empty table and lookup of a non-existing key. empty(Config) when is_list(Config) -> - repeat_for_opts(empty_do). + repeat_for_opts(fun empty_do/1). empty_do(Opts) -> EtsMem = etsmem(), @@ -2899,7 +2888,7 @@ empty_do(Opts) -> %% Check proper return values for illegal insert operations. badinsert(Config) when is_list(Config) -> - repeat_for_opts(badinsert_do). + repeat_for_opts(fun badinsert_do/1). badinsert_do(Opts) -> EtsMem = etsmem(), @@ -2923,7 +2912,7 @@ badinsert_do(Opts) -> time_lookup(Config) when is_list(Config) -> %% just for timing, really EtsMem = etsmem(), - Values = repeat_for_opts(time_lookup_do), + Values = repeat_for_opts(fun time_lookup_do/1), verify_etsmem(EtsMem), {comment,lists:flatten(io_lib:format( "~p ets lookups/s",[Values]))}. @@ -2957,7 +2946,8 @@ badlookup(Config) when is_list(Config) -> %% Test that lookup returns objects in order of insertion for bag and dbag. lookup_order(Config) when is_list(Config) -> EtsMem = etsmem(), - repeat_for_opts(lookup_order_do, [write_concurrency,[bag,duplicate_bag]]), + repeat_for_opts(fun lookup_order_do/1, + [write_concurrency,[bag,duplicate_bag]]), verify_etsmem(EtsMem), ok. @@ -3048,7 +3038,7 @@ fill_tab(Tab,Val) -> %% OTP-2386. Multiple return elements. lookup_element_mult(Config) when is_list(Config) -> - repeat_for_opts(lookup_element_mult_do). + repeat_for_opts(fun lookup_element_mult_do/1). lookup_element_mult_do(Opts) -> EtsMem = etsmem(), @@ -3086,7 +3076,8 @@ lem_crash_3(T) -> %% Check delete of an element inserted in a `filled' table. delete_elem(Config) when is_list(Config) -> - repeat_for_opts(delete_elem_do, [write_concurrency, all_types]). + repeat_for_opts(fun delete_elem_do/1, + [write_concurrency, all_types]). delete_elem_do(Opts) -> EtsMem = etsmem(), @@ -3103,7 +3094,8 @@ delete_elem_do(Opts) -> %% Check that ets:delete() works and releases the name of the %% deleted table. delete_tab(Config) when is_list(Config) -> - repeat_for_opts(delete_tab_do,[write_concurrency,all_types]). + repeat_for_opts(fun delete_tab_do/1, + [write_concurrency,all_types]). delete_tab_do(Opts) -> Name = foo, @@ -3301,10 +3293,14 @@ exit_large_table_owner(Config) when is_list(Config) -> end, 1) end, EtsMem = etsmem(), - repeat_for_opts({exit_large_table_owner_do,{FEData,Config}}), + repeat_for_opts(fun(Opts) -> + exit_large_table_owner_do(Opts, + FEData, + Config) + end), verify_etsmem(EtsMem). -exit_large_table_owner_do(Opts,{FEData,Config}) -> +exit_large_table_owner_do(Opts, FEData, Config) -> verify_rescheduling_exit(Config, FEData, [named_table | Opts], true, 1, 1), verify_rescheduling_exit(Config, FEData, Opts, false, 1, 1). @@ -3472,7 +3468,8 @@ baddelete(Config) when is_list(Config) -> %% Check that match_delete works. Also tests tab2list function. match_delete(Config) when is_list(Config) -> EtsMem = etsmem(), - repeat_for_opts(match_delete_do,[write_concurrency,all_types]), + repeat_for_opts(fun match_delete_do/1, + [write_concurrency,all_types]), verify_etsmem(EtsMem). match_delete_do(Opts) -> @@ -3489,7 +3486,7 @@ match_delete_do(Opts) -> %% OTP-3005: check match_delete with constant argument. match_delete3(Config) when is_list(Config) -> - repeat_for_opts(match_delete3_do). + repeat_for_opts(fun match_delete3_do/1). match_delete3_do(Opts) -> EtsMem = etsmem(), @@ -3514,7 +3511,7 @@ match_delete3_do(Opts) -> %% Test ets:first/1 & ets:next/2. firstnext(Config) when is_list(Config) -> - repeat_for_opts(firstnext_do). + repeat_for_opts(fun firstnext_do/1). firstnext_do(Opts) -> EtsMem = etsmem(), @@ -3572,7 +3569,7 @@ dyn_lookup(T, K) -> %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% slot(Config) when is_list(Config) -> - repeat_for_opts(slot_do). + repeat_for_opts(fun slot_do/1). slot_do(Opts) -> EtsMem = etsmem(), @@ -3597,7 +3594,7 @@ slot_loop(Tab,SlotNo,EltsSoFar) -> match1(Config) when is_list(Config) -> - repeat_for_opts(match1_do). + repeat_for_opts(fun match1_do/1). match1_do(Opts) -> EtsMem = etsmem(), @@ -3633,7 +3630,7 @@ match1_do(Opts) -> %% Test match with specified keypos bag table. match2(Config) when is_list(Config) -> - repeat_for_opts(match2_do). + repeat_for_opts(fun match2_do/1). match2_do(Opts) -> EtsMem = etsmem(), @@ -3660,7 +3657,7 @@ match2_do(Opts) -> %% Some ets:match_object tests. match_object(Config) when is_list(Config) -> - repeat_for_opts(match_object_do). + repeat_for_opts(fun match_object_do/1). match_object_do(Opts) -> EtsMem = etsmem(), @@ -3760,7 +3757,7 @@ match_object_do(Opts) -> %% Tests that db_match_object does not generate a `badarg' when %% resuming a search with no previous matches. match_object2(Config) when is_list(Config) -> - repeat_for_opts(match_object2_do). + repeat_for_opts(fun match_object2_do/1). match_object2_do(Opts) -> EtsMem = etsmem(), @@ -3796,7 +3793,7 @@ tab2list(Config) when is_list(Config) -> %% Simple general small test. If this fails, ets is in really bad %% shape. misc1(Config) when is_list(Config) -> - repeat_for_opts(misc1_do). + repeat_for_opts(fun misc1_do/1). misc1_do(Opts) -> EtsMem = etsmem(), @@ -3814,7 +3811,7 @@ misc1_do(Opts) -> %% Check the safe_fixtable function. safe_fixtable(Config) when is_list(Config) -> - repeat_for_opts(safe_fixtable_do). + repeat_for_opts(fun safe_fixtable_do/1). safe_fixtable_do(Opts) -> EtsMem = etsmem(), @@ -3872,7 +3869,7 @@ safe_fixtable_do(Opts) -> %% Tests ets:info result for required tuples. info(Config) when is_list(Config) -> - repeat_for_opts(info_do). + repeat_for_opts(fun info_do/1). info_do(Opts) -> EtsMem = etsmem(), @@ -3904,7 +3901,7 @@ info_do(Opts) -> %% Test various duplicate_bags stuff. dups(Config) when is_list(Config) -> - repeat_for_opts(dups_do). + repeat_for_opts(fun dups_do/1). dups_do(Opts) -> EtsMem = etsmem(), @@ -3970,7 +3967,9 @@ tab2file_do(FName, Opts) -> %% Check the ets:tab2file function on a filled set/bag type ets table. tab2file2(Config) when is_list(Config) -> - repeat_for_opts({tab2file2_do,Config}, [[set,bag],compressed]). + repeat_for_opts(fun(Opts) -> + tab2file2_do(Opts, Config) + end, [[set,bag],compressed]). tab2file2_do(Opts, Config) -> EtsMem = etsmem(), @@ -4234,7 +4233,7 @@ make_sub_binary(List, Num) when is_list(List) -> %% Perform multiple lookups for every key in a large table. heavy_lookup(Config) when is_list(Config) -> - repeat_for_opts(heavy_lookup_do). + repeat_for_opts(fun heavy_lookup_do/1). heavy_lookup_do(Opts) -> EtsMem = etsmem(), @@ -4257,7 +4256,7 @@ do_lookup(Tab, N) -> %% Perform multiple lookups for every element in a large table. heavy_lookup_element(Config) when is_list(Config) -> - repeat_for_opts(heavy_lookup_element_do). + repeat_for_opts(fun heavy_lookup_element_do/1). heavy_lookup_element_do(Opts) -> EtsMem = etsmem(), @@ -4285,7 +4284,7 @@ do_lookup_element(Tab, N, M) -> heavy_concurrent(Config) when is_list(Config) -> ct:timetrap({minutes,30}), %% valgrind needs a lot of time - repeat_for_opts(do_heavy_concurrent). + repeat_for_opts(fun do_heavy_concurrent/1). do_heavy_concurrent(Opts) -> Size = 10000, @@ -4370,7 +4369,7 @@ foldr_ordered(Config) when is_list(Config) -> %% Test ets:member BIF. member(Config) when is_list(Config) -> - repeat_for_opts(member_do, [write_concurrency, all_types]). + repeat_for_opts(fun member_do/1, [write_concurrency, all_types]). member_do(Opts) -> EtsMem = etsmem(), @@ -4453,26 +4452,26 @@ time_match(Tab,Match) -> seventyfive_percent_success(_,S,Fa,0) -> true = (S > ((S + Fa) * 0.75)); -seventyfive_percent_success({M,F,A},S,Fa,N) -> - case (catch apply(M,F,A)) of - {'EXIT', _} -> - seventyfive_percent_success({M,F,A},S,Fa+1,N-1); - _ -> - seventyfive_percent_success({M,F,A},S+1,Fa,N-1) +seventyfive_percent_success(F, S, Fa, N) when is_function(F, 0) -> + try F() of + _ -> + seventyfive_percent_success(F, S+1, Fa, N-1) + catch error:_ -> + seventyfive_percent_success(F, S, Fa+1, N-1) end. fifty_percent_success(_,S,Fa,0) -> true = (S > ((S + Fa) * 0.5)); -fifty_percent_success({M,F,A},S,Fa,N) -> - case (catch apply(M,F,A)) of - {'EXIT', _} -> - fifty_percent_success({M,F,A},S,Fa+1,N-1); - _ -> - fifty_percent_success({M,F,A},S+1,Fa,N-1) +fifty_percent_success(F, S, Fa, N) when is_function(F, 0) -> + try F() of + _ -> + fifty_percent_success(F, S+1, Fa, N-1) + catch + error:_ -> + fifty_percent_success(F, S, Fa+1, N-1) end. - create_random_string(0) -> []; @@ -4811,7 +4810,7 @@ otp_6338(Config) when is_list(Config) -> %% Elements could come in the wrong order in a bag if a rehash occurred. otp_5340(Config) when is_list(Config) -> - repeat_for_opts(otp_5340_do). + repeat_for_opts(fun otp_5340_do/1). otp_5340_do(Opts) -> N = 3000, @@ -4847,7 +4846,7 @@ verify2(_Err, _) -> %% delete_object followed by delete on fixed bag failed to delete objects. otp_7665(Config) when is_list(Config) -> - repeat_for_opts(otp_7665_do). + repeat_for_opts(fun otp_7665_do/1). otp_7665_do(Opts) -> Tab = ets_new(otp_7665,[bag | Opts]), @@ -4877,7 +4876,7 @@ otp_7665_act(Tab,Min,Max,DelNr) -> %% Whitebox testing of meta name table hashing. meta_wb(Config) when is_list(Config) -> EtsMem = etsmem(), - repeat_for_opts(meta_wb_do), + repeat_for_opts(fun meta_wb_do/1), verify_etsmem(EtsMem). @@ -5446,7 +5445,7 @@ smp_select_delete(Config) when is_list(Config) -> %% Test different types. types(Config) when is_list(Config) -> init_externals(), - repeat_for_opts(types_do,[[set,ordered_set],compressed]). + repeat_for_opts(fun types_do/1, [[set,ordered_set],compressed]). types_do(Opts) -> EtsMem = etsmem(), @@ -5848,12 +5847,8 @@ log_test_proc(Proc) when is_pid(Proc) -> Proc. my_spawn(Fun) -> log_test_proc(spawn(Fun)). -%%my_spawn(M,F,A) -> log_test_proc(spawn(M,F,A)). -%%my_spawn(N,M,F,A) -> log_test_proc(spawn(N,M,F,A)). my_spawn_link(Fun) -> log_test_proc(spawn_link(Fun)). -my_spawn_link(M,F,A) -> log_test_proc(spawn_link(M,F,A)). -%%my_spawn_link(N,M,F,A) -> log_test_proc(spawn_link(N,M,F,A)). my_spawn_opt(Fun,Opts) -> case spawn_opt(Fun,Opts) of @@ -6096,7 +6091,7 @@ make_port() -> open_port({spawn, "efile"}, [eof]). make_pid() -> - spawn_link(?MODULE, sleeper, []). + spawn_link(fun sleeper/0). sleeper() -> receive after infinity -> ok end. @@ -6232,11 +6227,7 @@ make_unaligned_sub_binary(List) -> repeat_for_opts(F) -> repeat_for_opts(F, [write_concurrency, read_concurrency, compressed]). -repeat_for_opts(F, OptGenList) when is_atom(F) -> - repeat_for_opts(fun(Opts) -> ?MODULE:F(Opts) end, OptGenList); -repeat_for_opts({F,Args}, OptGenList) when is_atom(F) -> - repeat_for_opts(fun(Opts) -> ?MODULE:F(Opts,Args) end, OptGenList); -repeat_for_opts(F, OptGenList) -> +repeat_for_opts(F, OptGenList) when is_function(F, 1) -> repeat_for_opts(F, OptGenList, []). repeat_for_opts(F, [], Acc) -> diff --git a/lib/stdlib/test/ets_tough_SUITE.erl b/lib/stdlib/test/ets_tough_SUITE.erl index 49aba7a529..0abce3200f 100644 --- a/lib/stdlib/test/ets_tough_SUITE.erl +++ b/lib/stdlib/test/ets_tough_SUITE.erl @@ -19,10 +19,15 @@ %% -module(ets_tough_SUITE). -export([all/0, suite/0,groups/0,init_per_suite/1, end_per_suite/1, - init_per_group/2,end_per_group/2,ex1/1]). --export([init/1,terminate/2,handle_call/3,handle_info/2]). + init_per_group/2,end_per_group/2, + ex1/1]). -export([init_per_testcase/2, end_per_testcase/2]). --compile([export_all]). + +%% gen_server behavior. +-behavior(gen_server). +-export([init/1,terminate/2,handle_call/3,handle_cast/2, + handle_info/2,code_change/3]). + -include_lib("common_test/include/ct.hrl"). suite() -> @@ -235,33 +240,6 @@ random_element(T) -> I = rand:uniform(tuple_size(T)), element(I,T). -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -show_table(N) -> - FileName = ["etsdump.",integer_to_list(N)], - case file:open(FileName,read) of - {ok,Fd} -> - show_entries(Fd); - _ -> - error - end. - -show_entries(Fd) -> - case phys_read_len(Fd) of - {ok,Len} -> - case phys_read_entry(Fd,Len) of - {ok,ok} -> - ok; - {ok,{Key,Val}} -> - io:format("~w\n",[{Key,Val}]), - show_entries(Fd); - _ -> - error - end; - _ -> - error - end. - %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -378,20 +356,6 @@ dget_class(ServerPid,Class,Condition) -> derase_class(ServerPid,Class) -> gen_server:call(ServerPid,{handle_delete_class,Class}, infinity). -%%% dmodify(ServerPid,Application) -> ok -%%% -%%% Applies a function on every instance in the database. -%%% The user provided function must always return one of the -%%% terms {ok,NewItem}, true, or false. -%%% Aug 96, this is only used to reset all timestamp values -%%% in the database. -%%% The function is supplied as Application = {Mod, Fun, ExtraArgs}, -%%% where the instance will be prepended to ExtraArgs before each -%%% call is made. - -dmodify(ServerPid,Application) -> - gen_server:call(ServerPid,{handle_dmodify,Application}, infinity). - %%% ddump_first(ServerPid,DumpDir) -> {dump_more,Ticket} | already_dumping %%% %%% Starts dumping the database. This call redirects all database updates @@ -643,9 +607,15 @@ handle_call(stop,_From,Admin) -> ?ets_delete(Admin), % Make sure table is gone before reply is sent. {stop, normal, ok, []}. +handle_cast(_Req, Admin) -> + {noreply, Admin}. + handle_info({'EXIT',_Pid,_Reason},Admin) -> {stop,normal,Admin}. +code_change(_OldVsn, StateData, _Extra) -> + {ok, StateData}. + handle_delete(Class, Key, Admin) -> handle_call({handle_delete,Class,Key},from,Admin). diff --git a/lib/stdlib/test/filename_SUITE.erl b/lib/stdlib/test/filename_SUITE.erl index 54066021fb..dc3daa56c1 100644 --- a/lib/stdlib/test/filename_SUITE.erl +++ b/lib/stdlib/test/filename_SUITE.erl @@ -29,6 +29,7 @@ dirname_bin/1, extension_bin/1, join_bin/1, t_nativename_bin/1]). -export([pathtype_bin/1,rootname_bin/1,split_bin/1]). -export([t_basedir_api/1, t_basedir_xdg/1, t_basedir_windows/1]). +-export([safe_relative_path/1]). -include_lib("common_test/include/ct.hrl"). @@ -41,7 +42,8 @@ all() -> find_src, absname_bin, absname_bin_2, {group,p}, - t_basedir_xdg, t_basedir_windows]. + t_basedir_xdg, t_basedir_windows, + safe_relative_path]. groups() -> [{p, [parallel], @@ -770,6 +772,71 @@ t_nativename_bin(Config) when is_list(Config) -> filename:nativename(<<"/usr/tmp//arne/">>) end. +safe_relative_path(Config) -> + PrivDir = proplists:get_value(priv_dir, Config), + Root = filename:join(PrivDir, ?FUNCTION_NAME), + ok = file:make_dir(Root), + ok = file:set_cwd(Root), + + ok = file:make_dir("a"), + ok = file:set_cwd("a"), + ok = file:make_dir("b"), + ok = file:set_cwd("b"), + ok = file:make_dir("c"), + + ok = file:set_cwd(Root), + + "a" = test_srp("a"), + "a/b" = test_srp("a/b"), + "a/b" = test_srp("a/./b"), + "a/b" = test_srp("a/./b/."), + + "" = test_srp("a/.."), + "" = test_srp("a/./.."), + "" = test_srp("a/../."), + "a" = test_srp("a/b/.."), + "a" = test_srp("a/../a"), + "a" = test_srp("a/../a/../a"), + "a/b/c" = test_srp("a/../a/b/c"), + + unsafe = test_srp("a/../.."), + unsafe = test_srp("a/../../.."), + unsafe = test_srp("a/./../.."), + unsafe = test_srp("a/././../../.."), + unsafe = test_srp("a/b/././../../.."), + + unsafe = test_srp(PrivDir), %Absolute path. + + ok. + +test_srp(RelPath) -> + Res = do_test_srp(RelPath), + Res = case do_test_srp(list_to_binary(RelPath)) of + Bin when is_binary(Bin) -> + binary_to_list(Bin); + Other -> + Other + end. + +do_test_srp(RelPath) -> + {ok,Root} = file:get_cwd(), + ok = file:set_cwd(RelPath), + {ok,Cwd} = file:get_cwd(), + ok = file:set_cwd(Root), + case filename:safe_relative_path(RelPath) of + unsafe -> + true = length(Cwd) < length(Root), + unsafe; + "" -> + ""; + SafeRelPath -> + ok = file:set_cwd(SafeRelPath), + {ok,Cwd} = file:get_cwd(), + true = length(Cwd) >= length(Root), + ok = file:set_cwd(Root), + SafeRelPath + end. + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% basedirs t_basedir_api(Config) when is_list(Config) -> diff --git a/lib/stdlib/test/gen_statem_SUITE.erl b/lib/stdlib/test/gen_statem_SUITE.erl index 8f2ba0cab2..ac27c9fc79 100644 --- a/lib/stdlib/test/gen_statem_SUITE.erl +++ b/lib/stdlib/test/gen_statem_SUITE.erl @@ -38,7 +38,7 @@ all() -> {group, abnormal}, {group, abnormal_handle_event}, shutdown, stop_and_reply, state_enter, event_order, - state_timeout, code_change, + state_timeout, event_types, code_change, {group, sys}, hibernate, enter_loop]. @@ -600,15 +600,26 @@ state_enter(_Config) -> (internal, Prev, N) -> Self ! {internal,start,Prev,N}, {keep_state,N + 1}; + ({call,From}, repeat, N) -> + {repeat_state,N + 1, + [{reply,From,{repeat,start,N}}]}; ({call,From}, echo, N) -> - {next_state,wait,N + 1,{reply,From,{echo,start,N}}}; + {next_state,wait,N + 1, + {reply,From,{echo,start,N}}}; ({call,From}, {stop,Reason}, N) -> - {stop_and_reply,Reason,[{reply,From,{stop,N}}],N + 1} + {stop_and_reply,Reason, + [{reply,From,{stop,N}}],N + 1} end, wait => - fun (enter, Prev, N) -> + fun (enter, Prev, N) when N < 5 -> + {repeat_state,N + 1, + {reply,{Self,N},{enter,Prev}}}; + (enter, Prev, N) -> Self ! {enter,wait,Prev,N}, {keep_state,N + 1}; + ({call,From}, repeat, N) -> + {repeat_state_and_data, + [{reply,From,{repeat,wait,N}}]}; ({call,From}, echo, N) -> {next_state,start,N + 1, [{next_event,internal,wait}, @@ -620,11 +631,15 @@ state_enter(_Config) -> [{enter,start,start,1}] = flush(), {echo,start,2} = gen_statem:call(STM, echo), - [{enter,wait,start,3}] = flush(), - {wait,[4|_]} = sys:get_state(STM), - {echo,wait,4} = gen_statem:call(STM, echo), - [{enter,start,wait,5},{internal,start,wait,6}] = flush(), - {stop,7} = gen_statem:call(STM, {stop,bye}), + [{3,{enter,start}},{4,{enter,start}},{enter,wait,start,5}] = flush(), + {wait,[6|_]} = sys:get_state(STM), + {repeat,wait,6} = gen_statem:call(STM, repeat), + [{enter,wait,wait,6}] = flush(), + {echo,wait,7} = gen_statem:call(STM, echo), + [{enter,start,wait,8},{internal,start,wait,9}] = flush(), + {repeat,start,10} = gen_statem:call(STM, repeat), + [{enter,start,start,11}] = flush(), + {stop,12} = gen_statem:call(STM, {stop,bye}), [{'EXIT',STM,bye}] = flush(), {noproc,_} = @@ -801,6 +816,74 @@ state_timeout(_Config) -> +%% Test that all event types can be sent with {next_event,EventType,_} +event_types(_Config) -> + process_flag(trap_exit, true), + + Machine = + %% Abusing the internal format of From... + #{init => + fun () -> + {ok, start, undefined} + end, + start => + fun ({call,_} = Call, Req, undefined) -> + {next_state, state1, undefined, + [{next_event,internal,1}, + {next_event,state_timeout,2}, + {next_event,timeout,3}, + {next_event,info,4}, + {next_event,cast,5}, + {next_event,Call,Req}]} + end, + state1 => + fun (internal, 1, undefined) -> + {next_state, state2, undefined} + end, + state2 => + fun (state_timeout, 2, undefined) -> + {next_state, state3, undefined} + end, + state3 => + fun (timeout, 3, undefined) -> + {next_state, state4, undefined} + end, + state4 => + fun (info, 4, undefined) -> + {next_state, state5, undefined} + end, + state5 => + fun (cast, 5, undefined) -> + {next_state, state6, undefined} + end, + state6 => + fun ({call,From}, stop, undefined) -> + {stop_and_reply, shutdown, + [{reply,From,stopped}]} + end}, + {ok,STM} = + gen_statem:start_link( + ?MODULE, {map_statem,Machine,[]}, [{debug,[trace]}]), + + stopped = gen_statem:call(STM, stop), + receive + {'EXIT',STM,shutdown} -> + ok + after 500 -> + ct:fail(did_not_stop) + end, + + {noproc,_} = + ?EXPECT_FAILURE(gen_statem:call(STM, hej), Reason), + case flush() of + [] -> + ok; + Other2 -> + ct:fail({unexpected,Other2}) + end. + + + sys1(Config) -> {ok,Pid} = gen_statem:start(?MODULE, start_arg(Config, []), []), {status, Pid, {module,gen_statem}, _} = sys:get_status(Pid), @@ -1722,6 +1805,10 @@ handle_event( {keep_state,[NewData|Machine]}; {keep_state,NewData,Ops} -> {keep_state,[NewData|Machine],Ops}; + {repeat_state,NewData} -> + {repeat_state,[NewData|Machine]}; + {repeat_state,NewData,Ops} -> + {repeat_state,[NewData|Machine],Ops}; Other -> Other end; diff --git a/lib/stdlib/test/io_SUITE.erl b/lib/stdlib/test/io_SUITE.erl index 7d48cbc97c..d546e8fad2 100644 --- a/lib/stdlib/test/io_SUITE.erl +++ b/lib/stdlib/test/io_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1999-2016. All Rights Reserved. +%% Copyright Ericsson AB 1999-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -30,7 +30,7 @@ io_lib_print_binary_depth_one/1, otp_10302/1, otp_10755/1, otp_10836/1, io_lib_width_too_small/1, io_with_huge_message_queue/1, format_string/1, - maps/1, coverage/1]). + maps/1, coverage/1, otp_14178_unicode_atoms/1, otp_14175/1]). -export([pretty/2]). @@ -61,7 +61,7 @@ all() -> printable_range, bad_printable_range, io_lib_print_binary_depth_one, otp_10302, otp_10755, otp_10836, io_lib_width_too_small, io_with_huge_message_queue, - format_string, maps, coverage]. + format_string, maps, coverage, otp_14178_unicode_atoms, otp_14175]. %% Error cases for output. error_1(Config) when is_list(Config) -> @@ -415,13 +415,13 @@ otp_6354(Config) when is_list(Config) -> bt(<<"#rrrrr{\n" " f1 = 1,\n" " f2 = #rrrrr{f1 = a,f2 = b,f3 = c},\n" - " f3 = \n" + " f3 =\n" " #rrrrr{\n" " f1 = h,f2 = i,\n" - " f3 = \n" + " f3 =\n" " #rrrrr{\n" " f1 = aa,\n" - " f2 = \n" + " f2 =\n" " #rrrrr{\n" " f1 = #rrrrr{f1 = a,f2 = b,f3 = c},\n" " f2 = 2,f3 = 3},\n" @@ -431,17 +431,17 @@ otp_6354(Config) when is_list(Config) -> 2,3},bb}}}, -1)), bt(<<"#d{aaaaaaaaaaaaaaaaaaaa = 1,\n" - " bbbbbbbbbbbbbbbbbbbb = \n" + " bbbbbbbbbbbbbbbbbbbb =\n" " #d{aaaaaaaaaaaaaaaaaaaa = a,bbbbbbbbbbbbbbbbbbbb = b,\n" " cccccccccccccccccccc = c,dddddddddddddddddddd = d,\n" " eeeeeeeeeeeeeeeeeeee = e},\n" " cccccccccccccccccccc = 3,\n" - " dddddddddddddddddddd = \n" + " dddddddddddddddddddd =\n" " #d{aaaaaaaaaaaaaaaaaaaa = h,bbbbbbbbbbbbbbbbbbbb = i,\n" - " cccccccccccccccccccc = \n" + " cccccccccccccccccccc =\n" " #d{aaaaaaaaaaaaaaaaaaaa = aa," "bbbbbbbbbbbbbbbbbbbb = bb,\n" - " cccccccccccccccccccc = \n" + " cccccccccccccccccccc =\n" " #d{aaaaaaaaaaaaaaaaaaaa = 1," "bbbbbbbbbbbbbbbbbbbb = 2,\n" " cccccccccccccccccccc = 3," @@ -534,21 +534,21 @@ otp_6354(Config) when is_list(Config) -> p({A,{A,{A,{A,{A,{A,{A, {g,{h,{i,{j,{k,{l,{m,{n,{o,{a}}}}}}}}}}}}}}}}}, 100)), bt(<<"#c{\n" - " f1 = \n" + " f1 =\n" " #c{\n" - " f1 = \n" + " f1 =\n" " #c{\n" - " f1 = \n" + " f1 =\n" " #c{\n" - " f1 = \n" + " f1 =\n" " #c{\n" - " f1 = \n" + " f1 =\n" " #c{\n" - " f1 = \n" + " f1 =\n" " #c{\n" - " f1 = \n" + " f1 =\n" " #c{\n" - " f1 = \n" + " f1 =\n" " #c{\n" " f1 = #c{f1 = #c{f1 = #c{f1 = a," "f2 = b},f2 = b},f2 = b},\n" @@ -564,13 +564,13 @@ otp_6354(Config) when is_list(Config) -> p({c,{c,{c,{c,{c,{c,{c,{c,{c,{c,{c,{c,a,b},b},b},b},b},b}, b},b},b},b},b},b}, -1)), bt(<<"#rrrrr{\n" - " f1 = \n" + " f1 =\n" " #rrrrr{\n" - " f1 = \n" + " f1 =\n" " #rrrrr{\n" - " f1 = \n" + " f1 =\n" " #rrrrr{\n" - " f1 = \n" + " f1 =\n" " {rrrrr,{rrrrr,a,#rrrrr{f1 = {rrrrr,1,2},f2 = a," "f3 = b}},b},\n" " f2 = {rrrrr,c,d},\n" @@ -2106,3 +2106,221 @@ coverage(_Config) -> io:format("~s\n", [S2]), ok. + +%% Test UTF-8 atoms. +otp_14178_unicode_atoms(_Config) -> + "atom" = fmt("~ts", ['atom']), + "кирилли́ческий атом" = fmt("~ts", ['кирилли́ческий атом']), + [16#10FFFF] = fmt("~ts", ['\x{10FFFF}']), + + %% ~s must not accept code points greater than 255. + bad_io_lib_format("~s", ['\x{100}']), + bad_io_lib_format("~s", ['кирилли́ческий атом']), + + ok. + +bad_io_lib_format(F, S) -> + try io_lib:format(F, S) of + _ -> + ct:fail({should_fail,F,S}) + catch + error:badarg -> + ok + end. + +otp_14175(_Config) -> + "..." = p(#{}, 0), + "#{}" = p(#{}, 1), + "#{...}" = p(#{a => 1}, 1), + "#{#{} => a}" = p(#{#{} => a}, 2), + "#{a => 1,...}" = p(#{a => 1, b => 2}, 2), + "#{a => 1,b => 2}" = p(#{a => 1, b => 2}, -1), + + M = #{kaaaaaaaaaaaaaaaaaaa => v1,kbbbbbbbbbbbbbbbbbbb => v2, + kccccccccccccccccccc => v3,kddddddddddddddddddd => v4, + keeeeeeeeeeeeeeeeeee => v5}, + "#{...}" = p(M, 1), + mt("#{kaaaaaaaaaaaaaaaaaaaa => v1,...}", p(M, 2)), + mt("#{kaaaaaaaaaaaaaaaaaaaa => 1,kbbbbbbbbbbbbbbbbbbbb => 2,...}", + p(M, 3)), + + mt("#{kaaaaaaaaaaaaaaaaaaa => v1,kbbbbbbbbbbbbbbbbbbb => v2,\n" + " kccccccccccccccccccc => v3,...}", p(M, 4)), + + mt("#{kaaaaaaaaaaaaaaaaaaa => v1,kbbbbbbbbbbbbbbbbbbb => v2,\n" + " kccccccccccccccccccc => v3,kddddddddddddddddddd => v4,...}", + p(M, 5)), + + mt("#{kaaaaaaaaaaaaaaaaaaa => v1,kbbbbbbbbbbbbbbbbbbb => v2,\n" + " kccccccccccccccccccc => v3,kddddddddddddddddddd => v4,\n" + " keeeeeeeeeeeeeeeeeee => v5}", p(M, 6)), + + weak("#{aaaaaaaaaaaaaaaaaaa => 1,bbbbbbbbbbbbbbbbbbbb => 2,\n" + " cccccccccccccccccccc => {3},\n" + " dddddddddddddddddddd => 4,eeeeeeeeeeeeeeeeeeee => 5}", + p(#{aaaaaaaaaaaaaaaaaaa => 1,bbbbbbbbbbbbbbbbbbbb => 2, + cccccccccccccccccccc => {3}, + dddddddddddddddddddd => 4,eeeeeeeeeeeeeeeeeeee => 5}, -1)), + + M2 = #{dddddddddddddddddddd => {1}, {aaaaaaaaaaaaaaaaaaaa} => 2, + {bbbbbbbbbbbbbbbbbbbb} => 3,{cccccccccccccccccccc} => 4, + {eeeeeeeeeeeeeeeeeeee} => 5}, + "#{...}" = p(M2, 1), + weak("#{dddddddddddddddddddd => {...},...}", p(M2, 2)), + weak("#{dddddddddddddddddddd => {1},{...} => 2,...}", p(M2, 3)), + + weak("#{dddddddddddddddddddd => {1},\n" + " {aaaaaaaaaaaaaaaaaaaa} => 2,\n" + " {...} => 3,...}", p(M2, 4)), + + weak("#{dddddddddddddddddddd => {1},\n" + " {aaaaaaaaaaaaaaaaaaaa} => 2,\n" + " {bbbbbbbbbbbbbbbbbbbb} => 3,\n" + " {...} => 4,...}", p(M2, 5)), + + weak("#{dddddddddddddddddddd => {1},\n" + " {aaaaaaaaaaaaaaaaaaaa} => 2,\n" + " {bbbbbbbbbbbbbbbbbbbb} => 3,\n" + " {cccccccccccccccccccc} => 4,\n" + " {...} => 5}", p(M2, 6)), + + weak("#{dddddddddddddddddddd => {1},\n" + " {aaaaaaaaaaaaaaaaaaaa} => 2,\n" + " {bbbbbbbbbbbbbbbbbbbb} => 3,\n" + " {cccccccccccccccccccc} => 4,\n" + " {eeeeeeeeeeeeeeeeeeee} => 5}", p(M2, 7)), + + M3 = #{kaaaaaaaaaaaaaaaaaaa => vuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuu, + kbbbbbbbbbbbbbbbbbbb => vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv, + kccccccccccccccccccc => vxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx, + kddddddddddddddddddd => vyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyy, + keeeeeeeeeeeeeeeeeee => vzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz}, + + mt("#{aaaaaaaaaaaaaaaaaaaa =>\n" + " uuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuu,\n" + " bbbbbbbbbbbbbbbbbbbb =>\n" + " vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv,\n" + " cccccccccccccccccccc =>\n" + " xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx,\n" + " dddddddddddddddddddd =>\n" + " yyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyy,\n" + " eeeeeeeeeeeeeeeeeeee =>\n" + " zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz}", p(M3, -1)), + + R4 = {c,{c,{c,{c,{c,{c,{c,{c,{c,{c,{c,{c,a,b},b},b},b},b},b}, + b},b},b},b},b},b}, + M4 = #{aaaaaaaaaaaaaaaaaaaa => R4, + bbbbbbbbbbbbbbbbbbbb => R4, + cccccccccccccccccccc => R4, + dddddddddddddddddddd => R4, + eeeeeeeeeeeeeeeeeeee => R4}, + + weak("#{aaaaaaaaaaaaaaaaaaaa =>\n" + " #c{f1 = #c{f1 = #c{...},f2 = b},f2 = b},\n" + " bbbbbbbbbbbbbbbbbbbb => #c{f1 = #c{f1 = {...},...},f2 = b},\n" + " cccccccccccccccccccc => #c{f1 = #c{...},f2 = b},\n" + " dddddddddddddddddddd => #c{f1 = {...},...},\n" + " eeeeeeeeeeeeeeeeeeee => #c{...}}", p(M4, 7)), + + M5 = #{aaaaaaaaaaaaaaaaaaaa => R4}, + mt("#{aaaaaaaaaaaaaaaaaaaa =>\n" + " #c{\n" + " f1 =\n" + " #c{\n" + " f1 =\n" + " #c{\n" + " f1 =\n" + " #c{\n" + " f1 =\n" + " #c{\n" + " f1 =\n" + " #c{\n" + " f1 =\n" + " #c{\n" + " f1 =\n" + " #c{\n" + " f1 =\n" + " #c{\n" + " f1 = #c{f1 = #c{f1 = #c{f1 = a,f2 = b},f2 = b}," + "f2 = b},\n" + " f2 = b},\n" + " f2 = b},\n" + " f2 = b},\n" + " f2 = b},\n" + " f2 = b},\n" + " f2 = b},\n" + " f2 = b},\n" + " f2 = b},\n" + " f2 = b}}", p(M5, -1)), + ok. + +%% Just check number of newlines and dots ('...'). +-define(WEAK, true). + +-ifdef(WEAK). + +weak(S, R) -> + (nl(S) =:= nl(R) andalso + dots(S) =:= dots(S)). + +nl(S) -> + [C || C <- S, C =:= $\n]. + +dots(S) -> + [C || C <- S, C =:= $\.]. + +-else. % WEAK + +weak(S, R) -> + mt(S, R). + +-endif. % WEAK + +%% If EXACT is defined: mt() matches strings exactly. +%% +%% if EXACT is not defined: do not match the strings exactly, but +%% compare them assuming that all map keys and all map values are +%% equal (by assuming all map keys and all map values have the same +%% length and begin with $k and $v respectively). + +%-define(EXACT, true). + +-ifdef(EXACT). + +mt(S, R) -> + S =:= R. + +-else. % EXACT + +mt(S, R) -> + anon(S) =:= anon(R). + +anon(S) -> + {ok, Ts0, _} = erl_scan:string(S, 1, [text]), + Ts = anon1(Ts0), + text(Ts). + +anon1([]) -> []; +anon1([{atom,Anno,Atom}=T|Ts]) -> + case erl_anno:text(Anno) of + "k" ++ _ -> + NewAnno = erl_anno:set_text("key", Anno), + [{atom,NewAnno,Atom}|anon1(Ts)]; + "v" ++ _ -> + NewAnno = erl_anno:set_text("val", Anno), + [{atom,NewAnno,Atom}|anon1(Ts)]; + _ -> + [T|anon1(Ts)] + end; +anon1([T|Ts]) -> + [T|anon1(Ts)]. + +text(Ts) -> + lists:append(text1(Ts)). + +text1([]) -> []; +text1([T|Ts]) -> + Anno = element(2, T), + [erl_anno:text(Anno) | text1(Ts)]. + +-endif. % EXACT diff --git a/lib/stdlib/test/lists_SUITE.erl b/lib/stdlib/test/lists_SUITE.erl index 531e97e8d6..5f2d8f0f4e 100644 --- a/lib/stdlib/test/lists_SUITE.erl +++ b/lib/stdlib/test/lists_SUITE.erl @@ -121,7 +121,7 @@ groups() -> {zip, [parallel], [zip_unzip, zip_unzip3, zipwith, zipwith3]}, {misc, [parallel], [reverse, member, dropwhile, takewhile, filter_partition, suffix, subtract, join, - hof]} + hof, droplast]} ]. init_per_suite(Config) -> diff --git a/lib/stdlib/test/qlc_SUITE.erl b/lib/stdlib/test/qlc_SUITE.erl index c08e138ad3..2b5d52287e 100644 --- a/lib/stdlib/test/qlc_SUITE.erl +++ b/lib/stdlib/test/qlc_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2004-2016. All Rights Reserved. +%% Copyright Ericsson AB 2004-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -886,11 +886,12 @@ eval_unique(Config) when is_list(Config) -> [a] = qlc:e(Q2, {unique_all, true}) ">>, - <<"Q = qlc:q([SQV || SQV <- qlc:q([X || X <- [1,2,1]],unique)], + <<"Q = qlc:q([SQV || SQV <- qlc:q([X || X <- [1,2,1,#{a => 1}]], + unique)], unique), {call,_,_,[{lc,_,{var,_,'X'},[{generate,_,{var,_,'X'},_}]},_]} = qlc:info(Q, [{format,abstract_code},unique_all]), - [1,2] = qlc:e(Q)">>, + [1,2,#{a := 1}] = qlc:e(Q)">>, <<"Q = qlc:q([X || X <- [1,2,1]]), {call,_,_,[{lc,_,{var,_,'X'},[{generate,_,{var,_,'X'},_}]},_]} = @@ -2637,7 +2638,16 @@ info(Config) when is_list(Config) -> {cons, _, _, _}]}, {nil,_}}]}]} = i(QH, {format, abstract_code}), [{5},{6}] = qlc:e(QH), - [{4},{5},{6}] = qlc:e(F(3))">> + [{4},{5},{6}] = qlc:e(F(3))">>, + + <<"Fun = fun ?MODULE:i/2, + L = [{#{k => #{v => Fun}}, Fun}], + H = qlc:q([Q || Q <- L, Q =:= {#{k => #{v => Fun}}, Fun}]), + L = qlc:e(H), + {call,_,_,[{lc,_,{var,_,'Q'}, + [{generate,_,_,_}, + {op,_,_,_,_}]}]} = + qlc:info(H, [{format,abstract_code}])">> ], run(Config, Ts), diff --git a/lib/stdlib/test/random_iolist.erl b/lib/stdlib/test/random_iolist.erl index 555f063e0a..b62cf5b82b 100644 --- a/lib/stdlib/test/random_iolist.erl +++ b/lib/stdlib/test/random_iolist.erl @@ -24,17 +24,13 @@ -module(random_iolist). --export([run/3, run2/3, standard_seed/0, compare/3, compare2/3, +-export([run/3, standard_seed/0, compare/3, random_iolist/1]). run(Iter,Fun1,Fun2) -> standard_seed(), compare(Iter,Fun1,Fun2). -run2(Iter,Fun1,Fun2) -> - standard_seed(), - compare2(Iter,Fun1,Fun2). - random_byte() -> rand:uniform(256) - 1. @@ -150,16 +146,6 @@ do_comp(List,F1,F2) -> _ -> true end. - -do_comp(List,List2,F1,F2) -> - X = F1(List,List2), - Y = F2(List,List2), - case X =:= Y of - false -> - exit({not_matching,List,List2,X,Y}); - _ -> - true - end. compare(0,Fun1,Fun2) -> do_comp(<<>>,Fun1,Fun2), @@ -172,25 +158,3 @@ compare(N,Fun1,Fun2) -> L = random_iolist(N), do_comp(L,Fun1,Fun2), compare(N-1,Fun1,Fun2). - -compare2(0,Fun1,Fun2) -> - L = random_iolist(100), - do_comp(<<>>,L,Fun1,Fun2), - do_comp(L,<<>>,Fun1,Fun2), - do_comp(<<>>,<<>>,Fun1,Fun2), - do_comp([],L,Fun1,Fun2), - do_comp(L,[],Fun1,Fun2), - do_comp([],[],Fun1,Fun2), - do_comp([[]|<<>>],L,Fun1,Fun2), - do_comp(L,[[]|<<>>],Fun1,Fun2), - do_comp([[]|<<>>],[[]|<<>>],Fun1,Fun2), - do_comp([<<>>,[]|<<>>],L,Fun1,Fun2), - do_comp(L,[<<>>,[]|<<>>],Fun1,Fun2), - do_comp([<<>>,[]|<<>>],[<<>>,[]|<<>>],Fun1,Fun2), - true; - -compare2(N,Fun1,Fun2) -> - L = random_iolist(N), - L2 = random_iolist(N), - do_comp(L,L2,Fun1,Fun2), - compare2(N-1,Fun1,Fun2). diff --git a/lib/stdlib/test/random_unicode_list.erl b/lib/stdlib/test/random_unicode_list.erl index 8db2fa8b56..2eeb28113d 100644 --- a/lib/stdlib/test/random_unicode_list.erl +++ b/lib/stdlib/test/random_unicode_list.erl @@ -24,7 +24,7 @@ -module(random_unicode_list). --export([run/3, run/4, run2/3, standard_seed/0, compare/4, compare2/3, +-export([run/3, run/4, standard_seed/0, compare/4, random_unicode_list/2]). run(I,F1,F2) -> @@ -33,10 +33,6 @@ run(Iter,Fun1,Fun2,Enc) -> standard_seed(), compare(Iter,Fun1,Fun2,Enc). -run2(Iter,Fun1,Fun2) -> - standard_seed(), - compare2(Iter,Fun1,Fun2). - int_to_utf8(I) when I =< 16#7F -> <<I>>; int_to_utf8(I) when I =< 16#7FF -> @@ -225,16 +221,6 @@ do_comp(List,F1,F2) -> _ -> true end. - -do_comp(List,List2,F1,F2) -> - X = F1(List,List2), - Y = F2(List,List2), - case X =:= Y of - false -> - exit({not_matching,List,List2,X,Y}); - _ -> - true - end. compare(0,Fun1,Fun2,_Enc) -> do_comp(<<>>,Fun1,Fun2), @@ -247,25 +233,3 @@ compare(N,Fun1,Fun2,Enc) -> L = random_unicode_list(N,Enc), do_comp(L,Fun1,Fun2), compare(N-1,Fun1,Fun2,Enc). - -compare2(0,Fun1,Fun2) -> - L = random_unicode_list(100,utf8), - do_comp(<<>>,L,Fun1,Fun2), - do_comp(L,<<>>,Fun1,Fun2), - do_comp(<<>>,<<>>,Fun1,Fun2), - do_comp([],L,Fun1,Fun2), - do_comp(L,[],Fun1,Fun2), - do_comp([],[],Fun1,Fun2), - do_comp([[]|<<>>],L,Fun1,Fun2), - do_comp(L,[[]|<<>>],Fun1,Fun2), - do_comp([[]|<<>>],[[]|<<>>],Fun1,Fun2), - do_comp([<<>>,[]|<<>>],L,Fun1,Fun2), - do_comp(L,[<<>>,[]|<<>>],Fun1,Fun2), - do_comp([<<>>,[]|<<>>],[<<>>,[]|<<>>],Fun1,Fun2), - true; - -compare2(N,Fun1,Fun2) -> - L = random_unicode_list(N,utf8), - L2 = random_unicode_list(N,utf8), - do_comp(L,L2,Fun1,Fun2), - compare2(N-1,Fun1,Fun2). diff --git a/lib/stdlib/test/re_testoutput1_replacement_test.erl b/lib/stdlib/test/re_testoutput1_replacement_test.erl index a40800d760..563e0001e4 100644 --- a/lib/stdlib/test/re_testoutput1_replacement_test.erl +++ b/lib/stdlib/test/re_testoutput1_replacement_test.erl @@ -18,7 +18,7 @@ %% %CopyrightEnd% %% -module(re_testoutput1_replacement_test). --compile(export_all). +-export([run/0]). -compile(no_native). %% This file is generated by running run_pcre_tests:gen_repl_test("re_SUITE_data/testoutput1") run() -> diff --git a/lib/stdlib/test/re_testoutput1_split_test.erl b/lib/stdlib/test/re_testoutput1_split_test.erl index 02987971fa..b39cb53a55 100644 --- a/lib/stdlib/test/re_testoutput1_split_test.erl +++ b/lib/stdlib/test/re_testoutput1_split_test.erl @@ -18,7 +18,7 @@ %% %CopyrightEnd% %% -module(re_testoutput1_split_test). --compile(export_all). +-export([run/0]). -compile(no_native). %% This file is generated by running run_pcre_tests:gen_split_test("re_SUITE_data/testoutput1") join([]) -> []; diff --git a/lib/stdlib/test/run_pcre_tests.erl b/lib/stdlib/test/run_pcre_tests.erl index ae56db59d6..b62674d6e0 100644 --- a/lib/stdlib/test/run_pcre_tests.erl +++ b/lib/stdlib/test/run_pcre_tests.erl @@ -18,8 +18,7 @@ %% %CopyrightEnd% %% -module(run_pcre_tests). - --compile(export_all). +-export([test/1,gen_split_test/1,gen_repl_test/1]). test(RootDir) -> put(verbose,false), @@ -119,49 +118,6 @@ test([{RE0,Line,Options0,Tests}|T],PreCompile,XMode,REAsList) -> end end. -loopexec(_,_,X,Y,_,_) when X > Y -> - {match,[]}; -loopexec(P,Chal,X,Y,Unicode,Xopt) -> - case re:run(Chal,P,[{offset,X}]++Xopt) of - nomatch -> - {match,[]}; - {match,[{A,B}|More]} -> - {match,Rest} = - case B>0 of - true -> - loopexec(P,Chal,A+B,Y,Unicode,Xopt); - false -> - {match,M} = case re:run(Chal,P,[{offset,X},notempty,anchored]++Xopt) of - nomatch -> - {match,[]}; - {match,Other} -> - {match,fixup(Chal,Other,0)} - end, - NewA = forward(Chal,A,1,Unicode), - {match,MM} = loopexec(P,Chal,NewA,Y,Unicode,Xopt), - {match,M ++ MM} - end, - {match,fixup(Chal,[{A,B}|More],0)++Rest} - end. - -forward(_Chal,A,0,_) -> - A; -forward(_Chal,A,N,false) -> - A+N; -forward(Chal,A,N,true) -> - <<_:A/binary,Tl/binary>> = Chal, - Forw = case Tl of - <<1:1,1:1,0:1,_:5,_/binary>> -> - 2; - <<1:1,1:1,1:1,0:1,_:4,_/binary>> -> - 3; - <<1:1,1:1,1:1,1:1,0:1,_:3,_/binary>> -> - 4; - _ -> - 1 - end, - forward(Chal,A+Forw,N-1,true). - contains_eightbit(<<>>) -> false; contains_eightbit(<<X:8,_/binary>>) when X >= 128 -> @@ -201,23 +157,6 @@ clean_duplicates([X|T],L) -> end. -global_fixup(_,nomatch) -> - nomatch; -global_fixup(P,{match,M}) -> - {match,lists:flatten(global_fixup2(P,M))}. - -global_fixup2(_,[]) -> - []; -global_fixup2(P,[H|T]) -> - [gfixup_one(P,0,H)|global_fixup2(P,T)]. - -gfixup_one(_,_,[]) -> - []; -gfixup_one(P,I,[{Start,Len}|T]) -> - <<_:Start/binary,R:Len/binary,_/binary>> = P, - [{I,R}|gfixup_one(P,I+1,T)]. - - press([]) -> []; press([H|T]) -> @@ -981,7 +920,7 @@ gen_split_test(OneFile) -> ErlFileName = ErlModule++".erl", {ok,F}= file:open(ErlFileName,[write]), io:format(F,"-module(~s).~n",[ErlModule]), - io:format(F,"-compile(export_all).~n",[]), + io:format(F,"-export([run/0]).~n",[]), io:format(F,"-compile(no_native).~n",[]), io:format(F,"%% This file is generated by running ~w:gen_split_test(~p)~n", [?MODULE,OneFile]), @@ -1024,7 +963,7 @@ dumponesplit(F,{RE,Line,O,TS}) -> "$x =~~ s/\\\\/\\\\\\\\/g; $x =~~ s/\\\"/\\\\\"/g; " "print \" <<\\\"$x\\\">> = " "iolist_to_binary(join(re:split(\\\"~s\\\"," - "\\\"~s\\\",~p))), \\n\";'~n", + "\\\"~s\\\",~p))),\\n\";'~n", [zsafe(safe(RE)), SSS, ysafe(safe(Str)), @@ -1035,7 +974,7 @@ dumponesplit(F,{RE,Line,O,TS}) -> "$x =~~ s/\\\\/\\\\\\\\/g; $x =~~ s/\\\"/\\\\\"/g; " "print \" <<\\\"$x\\\">> = " "iolist_to_binary(join(re:split(\\\"~s\\\"," - "\\\"~s\\\",~p))), \\n\";'~n", + "\\\"~s\\\",~p))),\\n\";'~n", [zsafe(safe(RE)), SSS, ysafe(safe(Str)), @@ -1046,7 +985,7 @@ dumponesplit(F,{RE,Line,O,TS}) -> "$x =~~ s/\\\\/\\\\\\\\/g; $x =~~ s/\\\"/\\\\\"/g; " "print \" <<\\\"$x\\\">> = " "iolist_to_binary(join(re:split(\\\"~s\\\"," - "\\\"~s\\\",~p))), \\n\";'~n", + "\\\"~s\\\",~p))),\\n\";'~n", [zsafe(safe(RE)), SSS, ysafe(safe(Str)), @@ -1071,7 +1010,7 @@ gen_repl_test(OneFile) -> ErlFileName = ErlModule++".erl", {ok,F}= file:open(ErlFileName,[write]), io:format(F,"-module(~s).~n",[ErlModule]), - io:format(F,"-compile(export_all).~n",[]), + io:format(F,"-export([run/0]).~n",[]), io:format(F,"-compile(no_native).~n",[]), io:format(F,"%% This file is generated by running ~w:gen_repl_test(~p)~n", [?MODULE,OneFile]), diff --git a/lib/stdlib/test/sofs_SUITE.erl b/lib/stdlib/test/sofs_SUITE.erl index 13c12ad2f2..f67bf16f0f 100644 --- a/lib/stdlib/test/sofs_SUITE.erl +++ b/lib/stdlib/test/sofs_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2001-2016. All Rights Reserved. +%% Copyright Ericsson AB 2001-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -1837,11 +1837,8 @@ digraph(Conf) when is_list(Conf) -> ok. digraph_fail(ExitReason, Fail) -> - {'EXIT', {ExitReason, [{sofs,family_to_digraph,A,_}|_]}} = Fail, - case {test_server:is_native(sofs),A} of - {false,[_,_]} -> ok; - {true,2} -> ok - end. + {'EXIT', {ExitReason, [{sofs,family_to_digraph,2,_}|_]}} = Fail, + ok. constant_function(Conf) when is_list(Conf) -> E = empty_set(), diff --git a/lib/stdlib/test/tar_SUITE.erl b/lib/stdlib/test/tar_SUITE.erl index 6f3979bb77..d6b6d3f80c 100644 --- a/lib/stdlib/test/tar_SUITE.erl +++ b/lib/stdlib/test/tar_SUITE.erl @@ -22,9 +22,10 @@ -export([all/0, suite/0,groups/0,init_per_suite/1, end_per_suite/1, init_per_group/2,end_per_group/2, borderline/1, atomic/1, long_names/1, create_long_names/1, bad_tar/1, errors/1, extract_from_binary/1, - extract_from_binary_compressed/1, + extract_from_binary_compressed/1, extract_filtered/1, extract_from_open_file/1, symlinks/1, open_add_close/1, cooked_compressed/1, - memory/1,unicode/1]). + memory/1,unicode/1,read_other_implementations/1, + sparse/1, init/1]). -include_lib("common_test/include/ct.hrl"). -include_lib("kernel/include/file.hrl"). @@ -35,7 +36,10 @@ all() -> [borderline, atomic, long_names, create_long_names, bad_tar, errors, extract_from_binary, extract_from_binary_compressed, extract_from_open_file, - symlinks, open_add_close, cooked_compressed, memory, unicode]. + extract_filtered, + symlinks, open_add_close, cooked_compressed, memory, unicode, + read_other_implementations, + sparse,init]. groups() -> []. @@ -84,17 +88,30 @@ borderline(Config) when is_list(Config) -> ok. borderline_test(Size, TempDir) -> - Archive = filename:join(TempDir, "ar_"++integer_to_list(Size)++".tar"), - Name = filename:join(TempDir, "file_"++integer_to_list(Size)), io:format("Testing size ~p", [Size]), + borderline_test(Size, TempDir, true), + borderline_test(Size, TempDir, false), + ok. + +borderline_test(Size, TempDir, IsUstar) -> + Prefix = case IsUstar of + true -> + "file_"; + false -> + lists:duplicate(100, $f) ++ "ile_" + end, + SizeList = integer_to_list(Size), + Archive = filename:join(TempDir, "ar_"++ SizeList ++".tar"), + Name = filename:join(TempDir, Prefix++SizeList), %% Create a file and archive it. X0 = erlang:monotonic_time(), - file:write_file(Name, random_byte_list(X0, Size)), + ok = file:write_file(Name, random_byte_list(X0, Size)), ok = erl_tar:create(Archive, [Name]), ok = file:delete(Name), %% Verify listing and extracting. + IsUstar = is_ustar(Archive), {ok, [Name]} = erl_tar:table(Archive), ok = erl_tar:extract(Archive, [verbose]), @@ -103,7 +120,12 @@ borderline_test(Size, TempDir) -> true = match_byte_list(X0, binary_to_list(Bin)), %% Verify that Unix tar can read it. - tar_tf(Archive, Name), + case IsUstar of + true -> + tar_tf(Archive, Name); + false -> + ok + end, ok. @@ -336,6 +358,7 @@ create_long_names() -> ok = erl_tar:tt(TarName), %% Extract and verify. + true = is_ustar(TarName), ExtractDir = "extract_dir", ok = file:make_dir(ExtractDir), ok = erl_tar:extract(TarName, [{cwd,ExtractDir}]), @@ -357,7 +380,7 @@ make_dirs([], Dir) -> %% Try erl_tar:table/2 and erl_tar:extract/2 on some corrupted tar files. bad_tar(Config) when is_list(Config) -> try_bad("bad_checksum", bad_header, Config), - try_bad("bad_octal", bad_header, Config), + try_bad("bad_octal", invalid_tar_checksum, Config), try_bad("bad_too_short", eof, Config), try_bad("bad_even_shorter", eof, Config), ok. @@ -370,8 +393,10 @@ try_bad(Name0, Reason, Config) -> Name = Name0 ++ ".tar", io:format("~nTrying ~s", [Name]), Full = filename:join(DataDir, Name), - Opts = [verbose, {cwd, PrivDir}], + Dest = filename:join(PrivDir, Name0), + Opts = [verbose, {cwd, Dest}], Expected = {error, Reason}, + io:fwrite("Expected: ~p\n", [Expected]), case {erl_tar:table(Full, Opts), erl_tar:extract(Full, Opts)} of {Expected, Expected} -> io:format("Result: ~p", [Expected]), @@ -493,6 +518,27 @@ extract_from_binary_compressed(Config) when is_list(Config) -> ok. +%% Test extracting a tar archive from a binary. +extract_filtered(Config) when is_list(Config) -> + DataDir = proplists:get_value(data_dir, Config), + PrivDir = proplists:get_value(priv_dir, Config), + Long = filename:join(DataDir, "no_fancy_stuff.tar"), + ExtractDir = filename:join(PrivDir, "extract_from_binary"), + ok = file:make_dir(ExtractDir), + + ok = erl_tar:extract(Long, [{cwd,ExtractDir},{files,["no_fancy_stuff/EPLICENCE"]}]), + + %% Verify. + Dir = filename:join(ExtractDir, "no_fancy_stuff"), + true = filelib:is_dir(Dir), + false = filelib:is_file(filename:join(Dir, "a_dir_list")), + true = filelib:is_file(filename:join(Dir, "EPLICENCE")), + + %% Clean up. + delete_files([ExtractDir]), + + ok. + %% Test extracting a tar archive from an open file. extract_from_open_file(Config) when is_list(Config) -> DataDir = proplists:get_value(data_dir, Config), @@ -573,6 +619,7 @@ symlinks(Dir, BadSymlink, PointsTo) -> ok = file:write_file(AFile, ALine), ok = file:make_symlink(AFile, GoodSymlink), ok = erl_tar:create(Tar, [BadSymlink, GoodSymlink, AFile], [verbose]), + true = is_ustar(Tar), %% List contents of tar file. @@ -581,6 +628,7 @@ symlinks(Dir, BadSymlink, PointsTo) -> %% Also create another archive with the dereference flag. ok = erl_tar:create(DerefTar, [AFile, GoodSymlink], [dereference, verbose]), + true = is_ustar(DerefTar), %% Extract files to a new directory. @@ -619,13 +667,50 @@ long_symlink(Dir) -> ok = file:set_cwd(Dir), AFile = "long_symlink", - FarTooLong = "/tmp/aarrghh/this/path/is/far/longer/than/one/hundred/characters/which/is/the/maximum/number/of/characters/allowed", - ok = file:make_symlink(FarTooLong, AFile), - {error,Error} = erl_tar:create(Tar, [AFile], [verbose]), - io:format("Error: ~s\n", [erl_tar:format_error(Error)]), - {FarTooLong,symbolic_link_too_long} = Error, + RequiresPAX = "/tmp/aarrghh/this/path/is/far/longer/than/one/hundred/characters/which/is/the/maximum/number/of/characters/allowed", + ok = file:make_symlink(RequiresPAX, AFile), + ok = erl_tar:create(Tar, [AFile], [verbose]), + false = is_ustar(Tar), + NewDir = filename:join(Dir, "extracted"), + _ = file:make_dir(NewDir), + ok = erl_tar:extract(Tar, [{cwd, NewDir}, verbose]), + ok = file:set_cwd(NewDir), + {ok, #file_info{type=symlink}} = file:read_link_info(AFile), + {ok, RequiresPAX} = file:read_link(AFile), + ok. + +init(Config) when is_list(Config) -> + PrivDir = proplists:get_value(priv_dir, Config), + ok = file:set_cwd(PrivDir), + Dir = filename:join(PrivDir, "init"), + ok = file:make_dir(Dir), + + [{FileOne,_,_}|_] = oac_files(), + TarOne = filename:join(Dir, "archive1.tar"), + {ok,Fd} = file:open(TarOne, [write]), + + %% If the arity of the fun is wrong, badarg should be returned + {error, badarg} = erl_tar:init(Fd, write, fun file_op_bad/1), + + %% Otherwise we should be good to go + {ok, Tar} = erl_tar:init(Fd, write, fun file_op/2), + ok = erl_tar:add(Tar, FileOne, []), + ok = erl_tar:close(Tar), + {ok, [FileOne]} = erl_tar:table(TarOne), ok. +file_op_bad(_) -> + throw({error, should_never_be_called}). + +file_op(write, {Fd, Data}) -> + file:write(Fd, Data); +file_op(position, {Fd, Pos}) -> + file:position(Fd, Pos); +file_op(read2, {Fd, Size}) -> + file:read(Fd, Size); +file_op(close, Fd) -> + file:close(Fd). + open_add_close(Config) when is_list(Config) -> PrivDir = proplists:get_value(priv_dir, Config), ok = file:set_cwd(PrivDir), @@ -643,17 +728,26 @@ open_add_close(Config) when is_list(Config) -> TarOne = filename:join(Dir, "archive1.tar"), {ok,AD} = erl_tar:open(TarOne, [write]), ok = erl_tar:add(AD, FileOne, []), - ok = erl_tar:add(AD, FileTwo, "second file", []), - ok = erl_tar:add(AD, FileThree, [verbose]), + + %% Add with {NameInArchive,Name} + ok = erl_tar:add(AD, {"second file", FileTwo}, []), + + %% Add with {binary, Bin} + {ok,FileThreeBin} = file:read_file(FileThree), + ok = erl_tar:add(AD, {FileThree, FileThreeBin}, [verbose]), + + %% Add with Name ok = erl_tar:add(AD, FileThree, "chunked", [{chunks,11411},verbose]), ok = erl_tar:add(AD, ADir, [verbose]), ok = erl_tar:add(AD, AnotherDir, [verbose]), ok = erl_tar:close(AD), + true = is_ustar(TarOne), ok = erl_tar:t(TarOne), ok = erl_tar:tt(TarOne), - {ok,[FileOne,"second file",FileThree,"chunked",ADir,SomeContent]} = erl_tar:table(TarOne), + Expected = {ok,[FileOne,"second file",FileThree,"chunked",ADir,SomeContent]}, + Expected = erl_tar:table(TarOne), delete_files(["oac_file","oac_small","oac_big",Dir,AnotherDir,ADir]), @@ -718,6 +812,41 @@ memory(Config) when is_list(Config) -> ok = delete_files([Name1,Name2]), ok. +read_other_implementations(Config) when is_list(Config) -> + DataDir = proplists:get_value(data_dir, Config), + Files = ["v7.tar", "gnu.tar", "bsd.tar", + "star.tar", "pax_mtime.tar"], + do_read_other_implementations(Files, DataDir). + +do_read_other_implementations([], _DataDir) -> + ok; +do_read_other_implementations([File|Rest], DataDir) -> + io:format("~nTrying ~s", [File]), + Full = filename:join(DataDir, File), + {ok, _} = erl_tar:table(Full), + {ok, _} = erl_tar:extract(Full, [memory]), + do_read_other_implementations(Rest, DataDir). + + +%% Test handling of sparse files +sparse(Config) when is_list(Config) -> + DataDir = proplists:get_value(data_dir, Config), + PrivDir = proplists:get_value(priv_dir, Config), + Sparse01Empty = "sparse01_empty.tar", + Sparse01 = "sparse01.tar", + Sparse10Empty = "sparse10_empty.tar", + Sparse10 = "sparse10.tar", + do_sparse([Sparse01Empty, Sparse01, Sparse10Empty, Sparse10], DataDir, PrivDir). + +do_sparse([], _DataDir, _PrivDir) -> + ok; +do_sparse([Name|Rest], DataDir, PrivDir) -> + io:format("~nTrying sparse file ~s", [Name]), + Full = filename:join(DataDir, Name), + {ok, [_]} = erl_tar:table(Full), + {ok, _} = erl_tar:extract(Full, [memory]), + do_sparse(Rest, DataDir, PrivDir). + %% Test filenames with characters outside the US ASCII range. unicode(Config) when is_list(Config) -> run_unicode_node(Config, "+fnu"), @@ -753,6 +882,9 @@ do_unicode(PrivDir) -> Names = lists:sort(unicode_create_files()), Tar = "unicöde.tar", ok = erl_tar:create(Tar, ["unicöde"], []), + + %% Unicode filenames require PAX format. + false = is_ustar(Tar), {ok,Names0} = erl_tar:table(Tar, []), Names = lists:sort(Names0), _ = [ok = file:delete(Name) || Name <- Names], @@ -850,3 +982,15 @@ start_node(Name, Args) -> ct:log("Node ~p started~n", [Node]), Node end. + +%% Test that the given tar file is a plain USTAR archive, +%% without any PAX extensions. +is_ustar(File) -> + {ok,Bin} = file:read_file(File), + <<_:257/binary,"ustar",0,_/binary>> = Bin, + <<_:156/binary,Type:8,_/binary>> = Bin, + case Type of + $x -> false; + $g -> false; + _ -> true + end. diff --git a/lib/stdlib/test/tar_SUITE_data/bsd.tar b/lib/stdlib/test/tar_SUITE_data/bsd.tar Binary files differnew file mode 100644 index 0000000000..8c31864be0 --- /dev/null +++ b/lib/stdlib/test/tar_SUITE_data/bsd.tar diff --git a/lib/stdlib/test/tar_SUITE_data/gnu.tar b/lib/stdlib/test/tar_SUITE_data/gnu.tar Binary files differnew file mode 100644 index 0000000000..60268065c1 --- /dev/null +++ b/lib/stdlib/test/tar_SUITE_data/gnu.tar diff --git a/lib/stdlib/test/tar_SUITE_data/pax_mtime.tar b/lib/stdlib/test/tar_SUITE_data/pax_mtime.tar Binary files differnew file mode 100644 index 0000000000..1b6e80ffac --- /dev/null +++ b/lib/stdlib/test/tar_SUITE_data/pax_mtime.tar diff --git a/lib/stdlib/test/tar_SUITE_data/sparse00.tar b/lib/stdlib/test/tar_SUITE_data/sparse00.tar Binary files differnew file mode 100644 index 0000000000..61a04de90b --- /dev/null +++ b/lib/stdlib/test/tar_SUITE_data/sparse00.tar diff --git a/lib/stdlib/test/tar_SUITE_data/sparse01.tar b/lib/stdlib/test/tar_SUITE_data/sparse01.tar Binary files differnew file mode 100644 index 0000000000..61a04de90b --- /dev/null +++ b/lib/stdlib/test/tar_SUITE_data/sparse01.tar diff --git a/lib/stdlib/test/tar_SUITE_data/sparse01_empty.tar b/lib/stdlib/test/tar_SUITE_data/sparse01_empty.tar Binary files differnew file mode 100644 index 0000000000..efa6d060f4 --- /dev/null +++ b/lib/stdlib/test/tar_SUITE_data/sparse01_empty.tar diff --git a/lib/stdlib/test/tar_SUITE_data/sparse10.tar b/lib/stdlib/test/tar_SUITE_data/sparse10.tar Binary files differnew file mode 100644 index 0000000000..61a04de90b --- /dev/null +++ b/lib/stdlib/test/tar_SUITE_data/sparse10.tar diff --git a/lib/stdlib/test/tar_SUITE_data/sparse10_empty.tar b/lib/stdlib/test/tar_SUITE_data/sparse10_empty.tar Binary files differnew file mode 100644 index 0000000000..efa6d060f4 --- /dev/null +++ b/lib/stdlib/test/tar_SUITE_data/sparse10_empty.tar diff --git a/lib/stdlib/test/tar_SUITE_data/star.tar b/lib/stdlib/test/tar_SUITE_data/star.tar Binary files differnew file mode 100644 index 0000000000..b0631e3b13 --- /dev/null +++ b/lib/stdlib/test/tar_SUITE_data/star.tar diff --git a/lib/stdlib/test/tar_SUITE_data/v7.tar b/lib/stdlib/test/tar_SUITE_data/v7.tar Binary files differnew file mode 100644 index 0000000000..9918e006bb --- /dev/null +++ b/lib/stdlib/test/tar_SUITE_data/v7.tar diff --git a/lib/stdlib/test/zip_SUITE.erl b/lib/stdlib/test/zip_SUITE.erl index 7d90795c9e..f0feda217a 100644 --- a/lib/stdlib/test/zip_SUITE.erl +++ b/lib/stdlib/test/zip_SUITE.erl @@ -27,7 +27,7 @@ openzip_api/1, zip_api/1, open_leak/1, unzip_jar/1, unzip_traversal_exploit/1, compress_control/1, - foldl/1]). + foldl/1,fd_leak/1]). -include_lib("common_test/include/ct.hrl"). -include_lib("kernel/include/file.hrl"). @@ -40,7 +40,7 @@ all() -> unzip_to_binary, zip_to_binary, unzip_options, zip_options, list_dir_options, aliases, openzip_api, zip_api, open_leak, unzip_jar, compress_control, foldl, - unzip_traversal_exploit]. + unzip_traversal_exploit,fd_leak]. groups() -> []. @@ -882,3 +882,35 @@ foldl(Config) -> {error, enoent} = zip:foldl(ZipFun, [], File), ok. + +fd_leak(Config) -> + ok = file:set_cwd(proplists:get_value(priv_dir, Config)), + DataDir = proplists:get_value(data_dir, Config), + Name = filename:join(DataDir, "bad_file_header.zip"), + BadExtract = fun() -> + {error,bad_file_header} = zip:extract(Name), + ok + end, + do_fd_leak(BadExtract, 1), + + BadCreate = fun() -> + {error,enoent} = zip:zip("failed.zip", + ["none"]), + ok + end, + do_fd_leak(BadCreate, 1), + + ok. + +do_fd_leak(_Bad, 10000) -> + ok; +do_fd_leak(Bad, N) -> + try Bad() of + ok -> + do_fd_leak(Bad, N + 1) + catch + C:R -> + Stk = erlang:get_stacktrace(), + io:format("Bad error after ~p attempts\n", [N]), + erlang:raise(C, R, Stk) + end. diff --git a/lib/tools/doc/src/make.xml b/lib/tools/doc/src/make.xml index fddf5ebd7b..6b878f72fb 100644 --- a/lib/tools/doc/src/make.xml +++ b/lib/tools/doc/src/make.xml @@ -43,15 +43,15 @@ <fsummary>Compile a set of modules.</fsummary> <type> <v>Options = [Option]</v> - <v> Option = noexec | load | netload | <compiler option></v> + <v> Option = noexec | load | netload | {emake, Emake} | <compiler option></v> </type> <desc> - <p>This function first looks in the current working directory - for a file named <c>Emakefile</c> (see below) specifying the - set of modules to compile and the compile options to use. If - no such file is found, the set of modules to compile - defaults to all modules in the current working - directory.</p> + <p>This function determines the set of modules to compile and the + compile options to use, by first looking for the <c>emake</c> make + option, if not present reads the configuration from a file named + <c>Emakefile</c> (see below). If no such file is found, the + set of modules to compile defaults to all modules in the + current working directory.</p> <p>Traversing the set of modules, it then recompiles every module for which at least one of the following conditions apply:</p> <list type="bulleted"> @@ -77,6 +77,9 @@ <item><c>netload</c> <br></br> Net load mode. Loads all recompiled modules on all known nodes.</item> + <item><c>{emake, Emake}</c> <br></br> + + Rather than reading the <c>Emakefile</c> specify configuration explicitly.</item> </list> <p>All items in <c>Options</c> that are not make options are assumed to be compiler options and are passed as-is to @@ -108,9 +111,10 @@ <section> <title>Emakefile</title> - <p><c>make:all/0,1</c> and <c>make:files/1,2</c> looks in the - current working directory for a file named <c>Emakefile</c>. If - it exists, <c>Emakefile</c> should contain elements like this:</p> + <p><c>make:all/0,1</c> and <c>make:files/1,2</c> first looks for + <c>{emake, Emake}</c> in options, then in the current working directory + for a file named <c>Emakefile</c>. If present <c>Emake</c> should + contain elements like this:</p> <code type="none"> Modules. {Modules,Options}. </code> diff --git a/lib/tools/emacs/erlang-skels.el b/lib/tools/emacs/erlang-skels.el index eeba7f34e9..bdb3d9ad4a 100644 --- a/lib/tools/emacs/erlang-skels.el +++ b/lib/tools/emacs/erlang-skels.el @@ -1,7 +1,7 @@ ;; ;; %CopyrightBegin% ;; -;; Copyright Ericsson AB 2010-2016. All Rights Reserved. +;; Copyright Ericsson AB 2010-2017. All Rights Reserved. ;; ;; Licensed under the Apache License, Version 2.0 (the "License"); ;; you may not use this file except in compliance with the License. @@ -915,11 +915,7 @@ Please see the function `tempo-define-template'.") "%% process to initialize." n (erlang-skel-separator-end 2) "-spec init(Args :: term()) ->" n> - "{ok, State :: term(), Data :: term()} |" n> - "{ok, State :: term(), Data :: term()," n> - "[gen_statem:action()] | gen_statem:action()} |" n> - "ignore |" n> - "{stop, Reason :: term()}." n + "gen_statem:init_result(atom())." n "init([]) ->" n> "process_flag(trap_exit, true)," n> "{ok, state_name, #data{}}." n @@ -1028,11 +1024,7 @@ Please see the function `tempo-define-template'.") "%% process to initialize." n (erlang-skel-separator-end 2) "-spec init(Args :: term()) ->" n> - "{ok, State :: term(), Data :: term()} |" n> - "{ok, State :: term(), Data :: term()," n> - "[gen_statem:action()] | gen_statem:action()} |" n> - "ignore |" n> - "{stop, Reason :: term()}." n + "gen_statem:init_result(term())." n "init([]) ->" n> "process_flag(trap_exit, true)," n> "{ok, state_name, #data{}}." n diff --git a/lib/tools/emacs/erldoc.el b/lib/tools/emacs/erldoc.el index e1fd661348..348800f880 100644 --- a/lib/tools/emacs/erldoc.el +++ b/lib/tools/emacs/erldoc.el @@ -407,7 +407,7 @@ up the indexing." (defvar erldoc-user-guides nil) (defvar erldoc-missing-user-guides - '("compiler" "hipe" "kernel" "os_mon" "parsetools" "typer") + '("compiler" "hipe" "kernel" "os_mon" "parsetools") "List of standard Erlang applications with no user guides.") ;; Search in `code:lib_dir/0' using find LIB_DIR -type f -name @@ -417,7 +417,7 @@ up the indexing." "runtime_tools" "sasl" "snmp" "ssl" "test_server" ("ssh" . "SSH") ("stdlib" . "STDLIB") - ("hipe" . "HiPE") ("typer" . "TypEr")) + ("hipe" . "HiPE")) "List of applications that come with a manual.") (defun erldoc-user-guide-chapters (user-guide) diff --git a/lib/tools/examples/xref_examples.erl b/lib/tools/examples/xref_examples.erl index 4c082195a2..f7e71c9708 100644 --- a/lib/tools/examples/xref_examples.erl +++ b/lib/tools/examples/xref_examples.erl @@ -7,7 +7,7 @@ %% ${HOME}/unused_locals.txt. script() -> Root = code:root_dir(), - Dir = os:getenv("HOME"), + {ok,[[Dir]]} = init:get_argument(home), Server = s, xref:start(Server), {ok, _Relname} = xref:add_release(Server, code:lib_dir(), {name,otp}), diff --git a/lib/tools/src/make.erl b/lib/tools/src/make.erl index 37e67cbe34..60695febb4 100644 --- a/lib/tools/src/make.erl +++ b/lib/tools/src/make.erl @@ -29,7 +29,7 @@ -include_lib("kernel/include/file.hrl"). --define(MakeOpts,[noexec,load,netload,noload]). +-define(MakeOpts,[noexec,load,netload,noload,emake]). all_or_nothing() -> case all() of @@ -43,29 +43,30 @@ all() -> all([]). all(Options) -> - {MakeOpts,CompileOpts} = sort_options(Options,[],[]), - case read_emakefile('Emakefile',CompileOpts) of - Files when is_list(Files) -> - do_make_files(Files,MakeOpts); - error -> - error - end. + run_emake(undefined, Options). files(Fs) -> files(Fs, []). files(Fs0, Options) -> Fs = [filename:rootname(F,".erl") || F <- Fs0], + run_emake(Fs, Options). + +run_emake(Mods, Options) -> {MakeOpts,CompileOpts} = sort_options(Options,[],[]), - case get_opts_from_emakefile(Fs,'Emakefile',CompileOpts) of + Emake = get_emake(Options), + case normalize_emake(Emake, Mods, CompileOpts) of Files when is_list(Files) -> - do_make_files(Files,MakeOpts); - error -> error + do_make_files(Files,MakeOpts); + error -> + error end. do_make_files(Fs, Opts) -> process(Fs, lists:member(noexec, Opts), load_opt(Opts)). +sort_options([{emake, _}=H|T],Make,Comp) -> + sort_options(T,[H|Make],Comp); sort_options([H|T],Make,Comp) -> case lists:member(H,?MakeOpts) of @@ -89,20 +90,35 @@ sort_options([],Make,Comp) -> %%% %%% These elements are converted to [{ModList,OptList},...] %%% ModList is a list of modulenames (strings) -read_emakefile(Emakefile,Opts) -> - case file:consult(Emakefile) of - {ok,Emake} -> + +normalize_emake(EmakeRaw, Mods, Opts) -> + case EmakeRaw of + {ok, Emake} when Mods =:= undefined -> transform(Emake,Opts,[],[]); - {error,enoent} -> + {ok, Emake} when is_list(Mods) -> + ModsOpts = transform(Emake,Opts,[],[]), + ModStrings = [coerce_2_list(M) || M <- Mods], + get_opts_from_emakefile(ModsOpts,ModStrings,Opts,[]); + {error,enoent} when Mods =:= undefined -> %% No Emakefile found - return all modules in current %% directory and the options given at command line - Mods = [filename:rootname(F) || F <- filelib:wildcard("*.erl")], + CwdMods = [filename:rootname(F) || F <- filelib:wildcard("*.erl")], + [{CwdMods, Opts}]; + {error,enoent} when is_list(Mods) -> [{Mods, Opts}]; - {error,Other} -> - io:format("make: Trouble reading 'Emakefile':~n~tp~n",[Other]), + {error, Error} -> + io:format("make: Trouble reading 'Emakefile':~n~tp~n",[Error]), error end. +get_emake(Opts) -> + case proplists:get_value(emake, Opts, false) of + false -> + file:consult('Emakefile'); + OptsEmake -> + {ok, OptsEmake} + end. + transform([{Mod,ModOpts}|Emake],Opts,Files,Already) -> case expand(Mod,Already) of [] -> @@ -143,31 +159,19 @@ expand(Mod,Already) -> end end. -%%% Reads the given Emakefile to see if there are any specific compile +%%% Reads the given Emake to see if there are any specific compile %%% options given for the modules. -get_opts_from_emakefile(Mods,Emakefile,Opts) -> - case file:consult(Emakefile) of - {ok,Emake} -> - Modsandopts = transform(Emake,Opts,[],[]), - ModStrings = [coerce_2_list(M) || M <- Mods], - get_opts_from_emakefile2(Modsandopts,ModStrings,Opts,[]); - {error,enoent} -> - [{Mods, Opts}]; - {error,Other} -> - io:format("make: Trouble reading 'Emakefile':~n~tp~n",[Other]), - error - end. -get_opts_from_emakefile2([{MakefileMods,O}|Rest],Mods,Opts,Result) -> +get_opts_from_emakefile([{MakefileMods,O}|Rest],Mods,Opts,Result) -> case members(Mods,MakefileMods,[],Mods) of {[],_} -> - get_opts_from_emakefile2(Rest,Mods,Opts,Result); + get_opts_from_emakefile(Rest,Mods,Opts,Result); {I,RestOfMods} -> - get_opts_from_emakefile2(Rest,RestOfMods,Opts,[{I,O}|Result]) + get_opts_from_emakefile(Rest,RestOfMods,Opts,[{I,O}|Result]) end; -get_opts_from_emakefile2([],[],_Opts,Result) -> +get_opts_from_emakefile([],[],_Opts,Result) -> Result; -get_opts_from_emakefile2([],RestOfMods,Opts,Result) -> +get_opts_from_emakefile([],RestOfMods,Opts,Result) -> [{RestOfMods,Opts}|Result]. members([H|T],MakefileMods,I,Rest) -> diff --git a/lib/tools/test/Makefile b/lib/tools/test/Makefile index 84c4e56aff..fe65d1484d 100644 --- a/lib/tools/test/Makefile +++ b/lib/tools/test/Makefile @@ -52,8 +52,8 @@ RELSYSDIR = $(RELEASE_PATH)/tools_test # ---------------------------------------------------- # FLAGS # ---------------------------------------------------- -ERL_MAKE_FLAGS += -ERL_COMPILE_FLAGS += -I$(ERL_TOP)/lib/percept/include +ERL_MAKE_FLAGS += +ERL_COMPILE_FLAGS += EBIN = . diff --git a/lib/tools/test/make_SUITE.erl b/lib/tools/test/make_SUITE.erl index e6284db8b8..2a94ead329 100644 --- a/lib/tools/test/make_SUITE.erl +++ b/lib/tools/test/make_SUITE.erl @@ -20,7 +20,7 @@ -module(make_SUITE). -export([all/0, suite/0,groups/0,init_per_suite/1, end_per_suite/1, - init_per_group/2,end_per_group/2, make_all/1, make_files/1]). + init_per_group/2,end_per_group/2, make_all/1, make_files/1, emake_opts/1]). -export([otp_6057_init/1, otp_6057_a/1, otp_6057_b/1, otp_6057_c/1, otp_6057_end/1]). @@ -40,7 +40,7 @@ suite() -> [{ct_hooks,[ts_install_cth]}]. all() -> - [make_all, make_files, {group, otp_6057}]. + [make_all, make_files, emake_opts, {group, otp_6057}]. groups() -> [{otp_6057,[],[otp_6057_a, otp_6057_b, @@ -86,6 +86,20 @@ make_files(Config) when is_list(Config) -> ensure_no_messages(), ok. +emake_opts(Config) when is_list(Config) -> + Current = prepare_data_dir(Config), + + %% prove that emake is used in opts instead of local Emakefile + Opts = [{emake, [test8, test9]}], + error = make:all(Opts), + error = make:files([test9], Opts), + "test8.beam" = ensure_exists([test8]), + "test9.beam" = ensure_exists([test9]), + "test5.S" = ensure_exists(["test5"],".S"), + + file:set_cwd(Current), + ensure_no_messages(), + ok. %% Moves to the data directory of this suite, clean it from any object %% files (*.jam for a JAM emulator). Returns the previous directory. diff --git a/lib/typer/Makefile b/lib/typer/Makefile deleted file mode 100644 index bd1b6458a8..0000000000 --- a/lib/typer/Makefile +++ /dev/null @@ -1,44 +0,0 @@ -# -# %CopyrightBegin% -# -# Copyright Ericsson AB 2006-2016. All Rights Reserved. -# -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software -# distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and -# limitations under the License. -# -# %CopyrightEnd% -# -#============================================================================= -# -# File: lib/typer/Makefile -# Authors: Bingwen He, Tobias Lindahl, and Kostis Sagonas -# -#============================================================================= -include $(ERL_TOP)/make/target.mk -include $(ERL_TOP)/make/$(TARGET)/otp.mk - -# -# Macros -# - -SUB_DIRECTORIES = src doc/src - -include vsn.mk -VSN = $(TYPER_VSN) - -SPECIAL_TARGETS = - -# -# Default Subdir Targets -# -include $(ERL_TOP)/make/otp_subdir.mk - diff --git a/lib/typer/RELEASE_NOTES b/lib/typer/RELEASE_NOTES deleted file mode 100644 index d91a815ee9..0000000000 --- a/lib/typer/RELEASE_NOTES +++ /dev/null @@ -1,22 +0,0 @@ -============================================================================== - Major features, additions and changes between Typer versions - (in reversed chronological order) -============================================================================== - -Version 0.9 (in Erlang/OTP R14B02) ----------------------------------- - - Major rewrite; all code has been cleaned up and placed in one file. - The only reason why this is not version 1.0 yet is that there is no proper - documentation for typer which can be displayed in the www.erlang.org site. - - Added ability to receive the set of exported types and report unknown ones. - - Better handling of overloaded contracts; especially erroneous ones on which - typer does not crash anymore. - - Fixed problem that caused typer to hang when given a file whose module name - did not correspond to the file name. - - Added two undocumented options that may come very handy when trying to - understand why typer reports some particular set of types for the functions - in a module. These options are mainly for typer developers at this point, - but may become documented in some future version. - -Older versions --------------- diff --git a/lib/typer/doc/Makefile b/lib/typer/doc/Makefile deleted file mode 100644 index 1015ca78eb..0000000000 --- a/lib/typer/doc/Makefile +++ /dev/null @@ -1,40 +0,0 @@ -# -# %CopyrightBegin% -# -# Copyright Ericsson AB 2006-2016. All Rights Reserved. -# -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software -# distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and -# limitations under the License. -# -# %CopyrightEnd% -# -SHELL=/bin/sh - -include $(ERL_TOP)/make/target.mk -include $(ERL_TOP)/make/$(TARGET)/otp.mk - -clean: - -rm -f *.html edoc-info stylesheet.css erlang.png - -distclean: clean -realclean: clean - -# ---------------------------------------------------- -# Special Build Targets -# ---------------------------------------------------- - - - -# ---------------------------------------------------- -# Release Target -# ---------------------------------------------------- -include $(ERL_TOP)/make/otp_release_targets.mk diff --git a/lib/typer/doc/html/.gitignore b/lib/typer/doc/html/.gitignore deleted file mode 100644 index e69de29bb2..0000000000 --- a/lib/typer/doc/html/.gitignore +++ /dev/null diff --git a/lib/typer/doc/pdf/.gitignore b/lib/typer/doc/pdf/.gitignore deleted file mode 100644 index e69de29bb2..0000000000 --- a/lib/typer/doc/pdf/.gitignore +++ /dev/null diff --git a/lib/typer/doc/src/Makefile b/lib/typer/doc/src/Makefile deleted file mode 100644 index 3724a2e4d1..0000000000 --- a/lib/typer/doc/src/Makefile +++ /dev/null @@ -1,118 +0,0 @@ -# -# %CopyrightBegin% -# -# Copyright Ericsson AB 2006-2016. All Rights Reserved. -# -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software -# distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and -# limitations under the License. -# -# %CopyrightEnd% -# -include $(ERL_TOP)/make/target.mk -include $(ERL_TOP)/make/$(TARGET)/otp.mk - -# ---------------------------------------------------- -# Application version -# ---------------------------------------------------- -include ../../vsn.mk -VSN=$(TYPER_VSN) -APPLICATION=typer - -# ---------------------------------------------------- -# Release directory specification -# ---------------------------------------------------- -RELSYSDIR = $(RELEASE_PATH)/lib/$(APPLICATION)-$(VSN) - -# ---------------------------------------------------- -# Target Specs -# ---------------------------------------------------- -XML_APPLICATION_FILES = ref_man.xml -XML_REF3_FILES = - -XML_PART_FILES = part_notes.xml -XML_CHAPTER_FILES = notes.xml - -BOOK_FILES = book.xml - -XML_FILES = \ - $(BOOK_FILES) $(XML_CHAPTER_FILES) \ - $(XML_PART_FILES) $(XML_REF3_FILES) $(XML_APPLICATION_FILES) - -GIF_FILES = - -# ---------------------------------------------------- - -HTML_FILES = $(XML_APPLICATION_FILES:%.xml=$(HTMLDIR)/%.html) \ - $(XML_PART_FILES:%.xml=$(HTMLDIR)/%.html) - -INFO_FILE = ../../info -EXTRA_FILES = \ - $(DEFAULT_GIF_FILES) \ - $(DEFAULT_HTML_FILES) \ - $(XML_REF3_FILES:%.xml=$(HTMLDIR)/%.html) \ - $(XML_CHAPTER_FILES:%.xml=$(HTMLDIR)/%.html) - -MAN3_FILES = $(XML_REF3_FILES:%.xml=$(MAN3DIR)/%.3) - -HTML_REF_MAN_FILE = $(HTMLDIR)/index.html - -TOP_PDF_FILE = $(PDFDIR)/$(APPLICATION)-$(VSN).pdf - -# ---------------------------------------------------- -# FLAGS -# ---------------------------------------------------- -XML_FLAGS += - -# ---------------------------------------------------- -# Targets -# ---------------------------------------------------- -$(HTMLDIR)/%.gif: %.gif - $(INSTALL_DATA) $< $@ - -docs: pdf html man - -$(TOP_PDF_FILE): $(XML_FILES) - -pdf: $(TOP_PDF_FILE) - -html: gifs $(HTML_REF_MAN_FILE) - -man: $(MAN3_FILES) - -gifs: $(GIF_FILES:%=$(HTMLDIR)/%) - -debug opt: - -clean clean_docs: - rm -rf $(HTMLDIR)/* - rm -f $(MAN3DIR)/* - rm -f $(TOP_PDF_FILE) $(TOP_PDF_FILE:%.pdf=%.fo) - rm -f errs core *~ - -distclean: clean -realclean: clean - -# ---------------------------------------------------- -# Release Target -# ---------------------------------------------------- -include $(ERL_TOP)/make/otp_release_targets.mk - -release_docs_spec: docs - $(INSTALL_DIR) "$(RELSYSDIR)/doc/pdf" - $(INSTALL_DATA) $(TOP_PDF_FILE) "$(RELSYSDIR)/doc/pdf" - $(INSTALL_DIR) "$(RELSYSDIR)/doc/html" - $(INSTALL_DATA) $(HTMLDIR)/* \ - "$(RELSYSDIR)/doc/html" - $(INSTALL_DATA) $(INFO_FILE) "$(RELSYSDIR)" - - -release_spec: diff --git a/lib/typer/doc/src/book.xml b/lib/typer/doc/src/book.xml deleted file mode 100644 index 20da44ae04..0000000000 --- a/lib/typer/doc/src/book.xml +++ /dev/null @@ -1,42 +0,0 @@ -<?xml version="1.0" encoding="utf-8" ?> -<!DOCTYPE book SYSTEM "book.dtd"> - -<book xmlns:xi="http://www.w3.org/2001/XInclude"> - <header titlestyle="normal"> - <copyright> - <year>2006</year><year>2016</year> - <holder>Ericsson AB. All Rights Reserved.</holder> - </copyright> - <legalnotice> - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. - - </legalnotice> - - <title>TypEr</title> - <prepared></prepared> - <docno></docno> - <date></date> - <rev></rev> - </header> - <pagetext></pagetext> - <preamble> - </preamble> - <pagetext>TypEr</pagetext> - <applications> - <xi:include href="ref_man.xml"/> - </applications> - <releasenotes> - <xi:include href="notes.xml"/> - </releasenotes> -</book> - diff --git a/lib/typer/doc/src/fascicules.xml b/lib/typer/doc/src/fascicules.xml deleted file mode 100644 index b15610fa8b..0000000000 --- a/lib/typer/doc/src/fascicules.xml +++ /dev/null @@ -1,12 +0,0 @@ -<?xml version="1.0" encoding="utf-8" ?> -<!DOCTYPE fascicules SYSTEM "fascicules.dtd"> - -<fascicules> - <fascicule file="part_notes" href="part_notes_frame.html" entry="yes"> - Release Notes - </fascicule> - <fascicule file="" href="../../../../doc/print.html" entry="no"> - Off-Print - </fascicule> -</fascicules> - diff --git a/lib/typer/doc/src/notes.xml b/lib/typer/doc/src/notes.xml deleted file mode 100644 index 9ef5ca1c70..0000000000 --- a/lib/typer/doc/src/notes.xml +++ /dev/null @@ -1,111 +0,0 @@ -<?xml version="1.0" encoding="utf-8" ?> -<!DOCTYPE chapter SYSTEM "chapter.dtd"> - -<chapter> - <header> - <copyright> - <year>2014</year><year>2016</year> - <holder>Ericsson AB. All Rights Reserved.</holder> - </copyright> - <legalnotice> - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. - - </legalnotice> - - <title>TypEr Release Notes</title> - <prepared>otp_appnotes</prepared> - <docno>nil</docno> - <date>nil</date> - <rev>nil</rev> - <file>notes.xml</file> - </header> - <p>This document describes the changes made to TypEr.</p> - -<section><title>TypEr 0.9.11</title> - - <section><title>Improvements and New Features</title> - <list> - <item> - <p> - Internal changes</p> - <p> - Own Id: OTP-13551</p> - </item> - </list> - </section> - -</section> - -<section><title>TypEr 0.9.10</title> - - <section><title>Fixed Bugs and Malfunctions</title> - <list> - <item> - <p>Fix a bug that could result in a crash when printing - warnings onto standard error. </p> - <p> - Own Id: OTP-13010</p> - </item> - </list> - </section> - -</section> - -<section><title>TypEr 0.9.9</title> - - <section><title>Fixed Bugs and Malfunctions</title> - <list> - <item> - <p> Properly extract annotations from core code. </p> - <p> - Own Id: OTP-12727</p> - </item> - </list> - </section> - -</section> - -<section><title>TypEr 0.9.8</title> - - <section><title>Fixed Bugs and Malfunctions</title> - <list> - <item> - <p> The name of a compiler option has been fixed in the - Makefile. </p> - <p> - Own Id: OTP-11996</p> - </item> - </list> - </section> - -</section> - -<section><title>TypEr 0.9.7</title> - - <section><title>Fixed Bugs and Malfunctions</title> - <list> - <item> - <p> - Added initial documentation framework for TypEr.</p> - <p> - Own Id: OTP-11860</p> - </item> - </list> - </section> - -</section> - - - -</chapter> - diff --git a/lib/typer/doc/src/part_notes.xml b/lib/typer/doc/src/part_notes.xml deleted file mode 100644 index 3234f0903e..0000000000 --- a/lib/typer/doc/src/part_notes.xml +++ /dev/null @@ -1,36 +0,0 @@ -<?xml version="1.0" encoding="utf-8" ?> -<!DOCTYPE part SYSTEM "part.dtd"> - -<part xmlns:xi="http://www.w3.org/2001/XInclude"> - <header> - <copyright> - <year>2006</year><year>2016</year> - <holder>Ericsson AB. All Rights Reserved.</holder> - </copyright> - <legalnotice> - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. - - </legalnotice> - - <title>TypEr Release Notes</title> - <prepared></prepared> - <docno></docno> - <date></date> - <rev></rev> - </header> - <description> - <p><em>TypEr</em></p> - </description> - <xi:include href="notes.xml"/> -</part> - diff --git a/lib/typer/doc/src/ref_man.xml b/lib/typer/doc/src/ref_man.xml deleted file mode 100644 index c793207443..0000000000 --- a/lib/typer/doc/src/ref_man.xml +++ /dev/null @@ -1,36 +0,0 @@ -<?xml version="1.0" encoding="utf-8" ?> -<!DOCTYPE application SYSTEM "application.dtd"> - -<application xmlns:xi="http://www.w3.org/2001/XInclude"> - <header> - <copyright> - <year>2014</year><year>2016</year> - <holder>Ericsson AB. All Rights Reserved.</holder> - </copyright> - <legalnotice> - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. - - </legalnotice> - - <title>TypEr</title> - <prepared></prepared> - <docno></docno> - <date></date> - <rev></rev> - <file>ref_man.xml</file> - </header> - <description> - </description> - <xi:include href="typer_app.xml"/> -</application> - diff --git a/lib/typer/doc/src/typer_app.xml b/lib/typer/doc/src/typer_app.xml deleted file mode 100644 index d52df5d0da..0000000000 --- a/lib/typer/doc/src/typer_app.xml +++ /dev/null @@ -1,44 +0,0 @@ -<?xml version="1.0" encoding="utf-8" ?> -<!DOCTYPE appref SYSTEM "appref.dtd"> - -<appref> - <header> - <copyright> - <year>2014</year><year>2016</year> - <holder>Ericsson AB. All Rights Reserved.</holder> - </copyright> - <legalnotice> - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. - - </legalnotice> - - <title>TypEr</title> - <prepared></prepared> - <responsible></responsible> - <docno></docno> - <approved></approved> - <checked></checked> - <date></date> - <rev></rev> - <file>typer.xml</file> - </header> - <app>TypEr</app> - <appsummary>The TypEr Application</appsummary> - <description> - <p>An Erlang/OTP application that shows type information - for Erlang modules to the user. Additionally, it can - annotate the code of files with such type information.</p> - </description> - -</appref> - diff --git a/lib/typer/ebin/.gitignore b/lib/typer/ebin/.gitignore deleted file mode 100644 index e69de29bb2..0000000000 --- a/lib/typer/ebin/.gitignore +++ /dev/null diff --git a/lib/typer/info b/lib/typer/info deleted file mode 100644 index 5145fbcfff..0000000000 --- a/lib/typer/info +++ /dev/null @@ -1,2 +0,0 @@ -group: tools -short: TypEr diff --git a/lib/typer/src/Makefile b/lib/typer/src/Makefile deleted file mode 100644 index 6c5d8b0726..0000000000 --- a/lib/typer/src/Makefile +++ /dev/null @@ -1,111 +0,0 @@ -# -# %CopyrightBegin% -# -# Copyright Ericsson AB 2006-2016. All Rights Reserved. -# -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software -# distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and -# limitations under the License. -# -# %CopyrightEnd% -# -#============================================================================= -# -# File: lib/typer/src/Makefile -# Authors: Kostis Sagonas -# -#============================================================================= - -include $(ERL_TOP)/make/target.mk -include $(ERL_TOP)/make/$(TARGET)/otp.mk - -# ---------------------------------------------------- -# Application version -# ---------------------------------------------------- -include ../vsn.mk -VSN=$(TYPER_VSN) - -# ---------------------------------------------------- -# Release directory specification -# ---------------------------------------------------- -RELSYSDIR = $(RELEASE_PATH)/lib/typer-$(VSN) - -# ---------------------------------------------------- -# Orientation information -- find dialyzer's dir -# ---------------------------------------------------- -DIALYZER_DIR = $(ERL_TOP)/lib/dialyzer - -# ---------------------------------------------------- -# Target Specs -# ---------------------------------------------------- -MODULES = typer - -HRL_FILES= -ERL_FILES= $(MODULES:%=%.erl) -INSTALL_FILES= $(MODULES:%=$(EBIN)/%.$(EMULATOR)) $(APP_TARGET) $(APPUP_TARGET) -TARGET_FILES= $(INSTALL_FILES) - -APP_FILE= typer.app -APP_SRC= $(APP_FILE).src -APP_TARGET= $(EBIN)/$(APP_FILE) - -APPUP_FILE= typer.appup -APPUP_SRC= $(APPUP_FILE).src -APPUP_TARGET= $(EBIN)/$(APPUP_FILE) - -# ---------------------------------------------------- -# FLAGS -# ---------------------------------------------------- -ERL_COMPILE_FLAGS += +warn_export_vars +warn_untyped_record +warn_missing_spec - -# ---------------------------------------------------- -# Targets -# ---------------------------------------------------- - -debug opt: $(TARGET_FILES) - -docs: - -clean: - rm -f $(TARGET_FILES) - rm -f core - -# ---------------------------------------------------- -# Special Build Targets -# ---------------------------------------------------- - -$(EBIN)/typer.$(EMULATOR): typer.erl ../vsn.mk Makefile - $(erlc_verbose)erlc -W $(ERL_COMPILE_FLAGS) -DVSN="\"v$(VSN)\"" -o$(EBIN) typer.erl - -$(APP_TARGET): $(APP_SRC) ../vsn.mk - $(vsn_verbose)sed -e 's;%VSN%;$(VSN);' $< > $@ - -$(APPUP_TARGET): $(APPUP_SRC) ../vsn.mk - $(vsn_verbose)sed -e 's;%VSN%;$(VSN);' $< > $@ - -# --------------------------------------------------------------------- -# dependencies -# --------------------------------------------------------------------- - - -# ---------------------------------------------------- -# Release Target -# ---------------------------------------------------- -include $(ERL_TOP)/make/otp_release_targets.mk - -release_spec: opt - $(INSTALL_DIR) "$(RELSYSDIR)/src" - $(INSTALL_DATA) $(ERL_FILES) $(HRL_FILES) $(YRL_FILES) \ - "$(RELSYSDIR)/src" - $(INSTALL_DIR) "$(RELSYSDIR)/ebin" - $(INSTALL_DATA) $(INSTALL_FILES) "$(RELSYSDIR)/ebin" - -release_docs_spec: diff --git a/lib/typer/src/typer.app.src b/lib/typer/src/typer.app.src deleted file mode 100644 index 974091b44c..0000000000 --- a/lib/typer/src/typer.app.src +++ /dev/null @@ -1,11 +0,0 @@ -% This is an -*- erlang -*- file. - -{application, typer, - [{description, "TYPe annotator for ERlang programs, version %VSN%"}, - {vsn, "%VSN%"}, - {modules, [typer]}, - {registered, []}, - {applications, [compiler, dialyzer, hipe, kernel, stdlib]}, - {env, []}, - {runtime_dependencies, ["stdlib-2.0","kernel-3.0","hipe-3.10.3","erts-6.0", - "dialyzer-2.7","compiler-5.0"]}]}. diff --git a/lib/typer/src/typer.erl b/lib/typer/src/typer.erl deleted file mode 100644 index 18c4fe902d..0000000000 --- a/lib/typer/src/typer.erl +++ /dev/null @@ -1,1110 +0,0 @@ -%% -*- erlang-indent-level: 2 -*- -%% -%% Licensed under the Apache License, Version 2.0 (the "License"); -%% you may not use this file except in compliance with the License. -%% You may obtain a copy of the License at -%% -%% http://www.apache.org/licenses/LICENSE-2.0 -%% -%% Unless required by applicable law or agreed to in writing, software -%% distributed under the License is distributed on an "AS IS" BASIS, -%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -%% See the License for the specific language governing permissions and -%% limitations under the License. - -%%----------------------------------------------------------------------- -%% File : typer.erl -%% Author(s) : The first version of typer was written by Bingwen He -%% with guidance from Kostis Sagonas and Tobias Lindahl. -%% Since June 2008 typer is maintained by Kostis Sagonas. -%% Description : An Erlang/OTP application that shows type information -%% for Erlang modules to the user. Additionally, it can -%% annotate the code of files with such type information. -%%----------------------------------------------------------------------- - --module(typer). - --export([start/0]). - -%%----------------------------------------------------------------------- - --define(SHOW, show). --define(SHOW_EXPORTED, show_exported). --define(ANNOTATE, annotate). --define(ANNOTATE_INC_FILES, annotate_inc_files). - --type mode() :: ?SHOW | ?SHOW_EXPORTED | ?ANNOTATE | ?ANNOTATE_INC_FILES. - -%%----------------------------------------------------------------------- - --type files() :: [file:filename()]. --type callgraph() :: dialyzer_callgraph:callgraph(). --type codeserver() :: dialyzer_codeserver:codeserver(). --type plt() :: dialyzer_plt:plt(). - --record(analysis, - {mode :: mode() | 'undefined', - macros = [] :: [{atom(), term()}], - includes = [] :: files(), - codeserver = dialyzer_codeserver:new():: codeserver(), - callgraph = dialyzer_callgraph:new() :: callgraph(), - files = [] :: files(), % absolute names - plt = none :: 'none' | file:filename(), - no_spec = false :: boolean(), - show_succ = false :: boolean(), - %% For choosing between specs or edoc @spec comments - edoc = false :: boolean(), - %% Files in 'fms' are compilable with option 'to_pp'; we keep them - %% as {FileName, ModuleName} in case the ModuleName is different - fms = [] :: [{file:filename(), module()}], - ex_func = map__new() :: map_dict(), - record = map__new() :: map_dict(), - func = map__new() :: map_dict(), - inc_func = map__new() :: map_dict(), - trust_plt = dialyzer_plt:new() :: plt()}). --type analysis() :: #analysis{}. - --record(args, {files = [] :: files(), - files_r = [] :: files(), - trusted = [] :: files()}). --type args() :: #args{}. - -%%-------------------------------------------------------------------- - --spec start() -> no_return(). - -start() -> - {Args, Analysis} = process_cl_args(), - %% io:format("Args: ~p\n", [Args]), - %% io:format("Analysis: ~p\n", [Analysis]), - Timer = dialyzer_timing:init(false), - TrustedFiles = filter_fd(Args#args.trusted, [], fun is_erl_file/1), - Analysis2 = extract(Analysis, TrustedFiles), - All_Files = get_all_files(Args), - %% io:format("All_Files: ~p\n", [All_Files]), - Analysis3 = Analysis2#analysis{files = All_Files}, - Analysis4 = collect_info(Analysis3), - %% io:format("Final: ~p\n", [Analysis4#analysis.fms]), - TypeInfo = get_type_info(Analysis4), - dialyzer_timing:stop(Timer), - show_or_annotate(TypeInfo), - %% io:format("\nTyper analysis finished\n"), - erlang:halt(0). - -%%-------------------------------------------------------------------- - --spec extract(analysis(), files()) -> analysis(). - -extract(#analysis{macros = Macros, - includes = Includes, - trust_plt = TrustPLT} = Analysis, TrustedFiles) -> - %% io:format("--- Extracting trusted typer_info... "), - Ds = [{d, Name, Value} || {Name, Value} <- Macros], - CodeServer = dialyzer_codeserver:new(), - Fun = - fun(File, CS) -> - %% We include one more dir; the one above the one we are trusting - %% E.g, for /home/tests/typer_ann/test.ann.erl, we should include - %% /home/tests/ rather than /home/tests/typer_ann/ - AllIncludes = [filename:dirname(filename:dirname(File)) | Includes], - Is = [{i, Dir} || Dir <- AllIncludes], - CompOpts = dialyzer_utils:src_compiler_opts() ++ Is ++ Ds, - case dialyzer_utils:get_abstract_code_from_src(File, CompOpts) of - {ok, AbstractCode} -> - case dialyzer_utils:get_record_and_type_info(AbstractCode) of - {ok, RecDict} -> - Mod = list_to_atom(filename:basename(File, ".erl")), - case dialyzer_utils:get_spec_info(Mod, AbstractCode, RecDict) of - {ok, SpecDict, CbDict} -> - CS1 = dialyzer_codeserver:store_temp_records(Mod, RecDict, CS), - dialyzer_codeserver:store_temp_contracts(Mod, SpecDict, CbDict, CS1); - {error, Reason} -> compile_error([Reason]) - end; - {error, Reason} -> compile_error([Reason]) - end; - {error, Reason} -> compile_error(Reason) - end - end, - CodeServer1 = lists:foldl(Fun, CodeServer, TrustedFiles), - %% Process remote types - NewCodeServer = - try - CodeServer2 = - dialyzer_utils:merge_types(CodeServer1, - TrustPLT), % XXX change to the PLT? - NewExpTypes = dialyzer_codeserver:get_temp_exported_types(CodeServer1), - case sets:size(NewExpTypes) of 0 -> ok end, - CodeServer3 = dialyzer_codeserver:finalize_exported_types(NewExpTypes, CodeServer2), - CodeServer4 = dialyzer_utils:process_record_remote_types(CodeServer3), - dialyzer_contracts:process_contract_remote_types(CodeServer4) - catch - throw:{error, ErrorMsg} -> - compile_error(ErrorMsg) - end, - %% Create TrustPLT - ContractsDict = dialyzer_codeserver:get_contracts(NewCodeServer), - Contracts = orddict:from_list(dict:to_list(ContractsDict)), - NewTrustPLT = dialyzer_plt:insert_contract_list(TrustPLT, Contracts), - Analysis#analysis{trust_plt = NewTrustPLT}. - -%%-------------------------------------------------------------------- - --spec get_type_info(analysis()) -> analysis(). - -get_type_info(#analysis{callgraph = CallGraph, - trust_plt = TrustPLT, - codeserver = CodeServer} = Analysis) -> - StrippedCallGraph = remove_external(CallGraph, TrustPLT), - %% io:format("--- Analyzing callgraph... "), - try - NewMiniPlt = dialyzer_succ_typings:analyze_callgraph(StrippedCallGraph, - TrustPLT, - CodeServer), - NewPlt = dialyzer_plt:restore_full_plt(NewMiniPlt), - Analysis#analysis{callgraph = StrippedCallGraph, trust_plt = NewPlt} - catch - error:What -> - fatal_error(io_lib:format("Analysis failed with message: ~p", - [{What, erlang:get_stacktrace()}])); - throw:{dialyzer_succ_typing_error, Msg} -> - fatal_error(io_lib:format("Analysis failed with message: ~s", [Msg])) - end. - --spec remove_external(callgraph(), plt()) -> callgraph(). - -remove_external(CallGraph, PLT) -> - {StrippedCG0, Ext} = dialyzer_callgraph:remove_external(CallGraph), - case get_external(Ext, PLT) of - [] -> ok; - Externals -> - msg(io_lib:format(" Unknown functions: ~p\n", [lists:usort(Externals)])), - ExtTypes = rcv_ext_types(), - case ExtTypes of - [] -> ok; - _ -> msg(io_lib:format(" Unknown types: ~p\n", [ExtTypes])) - end - end, - StrippedCG0. - --spec get_external([{mfa(), mfa()}], plt()) -> [mfa()]. - -get_external(Exts, Plt) -> - Fun = fun ({_From, To = {M, F, A}}, Acc) -> - case dialyzer_plt:contains_mfa(Plt, To) of - false -> - case erl_bif_types:is_known(M, F, A) of - true -> Acc; - false -> [To|Acc] - end; - true -> Acc - end - end, - lists:foldl(Fun, [], Exts). - -%%-------------------------------------------------------------------- -%% Showing type information or annotating files with such information. -%%-------------------------------------------------------------------- - --define(TYPER_ANN_DIR, "typer_ann"). - --type line() :: non_neg_integer(). --type fa() :: {atom(), arity()}. --type func_info() :: {line(), atom(), arity()}. - --record(info, {records = maps:new() :: erl_types:type_table(), - functions = [] :: [func_info()], - types = map__new() :: map_dict(), - edoc = false :: boolean()}). --record(inc, {map = map__new() :: map_dict(), filter = [] :: files()}). --type inc() :: #inc{}. - --spec show_or_annotate(analysis()) -> 'ok'. - -show_or_annotate(#analysis{mode = Mode, fms = Files} = Analysis) -> - case Mode of - ?SHOW -> show(Analysis); - ?SHOW_EXPORTED -> show(Analysis); - ?ANNOTATE -> - Fun = fun ({File, Module}) -> - Info = get_final_info(File, Module, Analysis), - write_typed_file(File, Info) - end, - lists:foreach(Fun, Files); - ?ANNOTATE_INC_FILES -> - IncInfo = write_and_collect_inc_info(Analysis), - write_inc_files(IncInfo) - end. - -write_and_collect_inc_info(Analysis) -> - Fun = fun ({File, Module}, Inc) -> - Info = get_final_info(File, Module, Analysis), - write_typed_file(File, Info), - IncFuns = get_functions(File, Analysis), - collect_imported_functions(IncFuns, Info#info.types, Inc) - end, - NewInc = lists:foldl(Fun, #inc{}, Analysis#analysis.fms), - clean_inc(NewInc). - -write_inc_files(Inc) -> - Fun = - fun (File) -> - Val = map__lookup(File, Inc#inc.map), - %% Val is function with its type info - %% in form [{{Line,F,A},Type}] - Functions = [Key || {Key, _} <- Val], - Val1 = [{{F,A},Type} || {{_Line,F,A},Type} <- Val], - Info = #info{types = map__from_list(Val1), - records = maps:new(), - %% Note we need to sort functions here! - functions = lists:keysort(1, Functions)}, - %% io:format("Types ~p\n", [Info#info.types]), - %% io:format("Functions ~p\n", [Info#info.functions]), - %% io:format("Records ~p\n", [Info#info.records]), - write_typed_file(File, Info) - end, - lists:foreach(Fun, dict:fetch_keys(Inc#inc.map)). - -show(Analysis) -> - Fun = fun ({File, Module}) -> - Info = get_final_info(File, Module, Analysis), - show_type_info(File, Info) - end, - lists:foreach(Fun, Analysis#analysis.fms). - -get_final_info(File, Module, Analysis) -> - Records = get_records(File, Analysis), - Types = get_types(Module, Analysis, Records), - Functions = get_functions(File, Analysis), - Edoc = Analysis#analysis.edoc, - #info{records = Records, functions = Functions, types = Types, edoc = Edoc}. - -collect_imported_functions(Functions, Types, Inc) -> - %% Coming from other sourses, including: - %% FIXME: How to deal with yecc-generated file???? - %% --.yrl (yecc-generated file)??? - %% -- yeccpre.hrl (yecc-generated file)??? - %% -- other cases - Fun = fun ({File, _} = Obj, I) -> - case is_yecc_gen(File, I) of - {true, NewI} -> NewI; - {false, NewI} -> - check_imported_functions(Obj, NewI, Types) - end - end, - lists:foldl(Fun, Inc, Functions). - --spec is_yecc_gen(file:filename(), inc()) -> {boolean(), inc()}. - -is_yecc_gen(File, #inc{filter = Fs} = Inc) -> - case lists:member(File, Fs) of - true -> {true, Inc}; - false -> - case filename:extension(File) of - ".yrl" -> - Rootname = filename:rootname(File, ".yrl"), - Obj = Rootname ++ ".erl", - case lists:member(Obj, Fs) of - true -> {true, Inc}; - false -> - NewInc = Inc#inc{filter = [Obj|Fs]}, - {true, NewInc} - end; - _ -> - case filename:basename(File) of - "yeccpre.hrl" -> {true, Inc}; - _ -> {false, Inc} - end - end - end. - -check_imported_functions({File, {Line, F, A}}, Inc, Types) -> - IncMap = Inc#inc.map, - FA = {F, A}, - Type = get_type_info(FA, Types), - case map__lookup(File, IncMap) of - none -> %% File is not added. Add it - Obj = {File,[{FA, {Line, Type}}]}, - NewMap = map__insert(Obj, IncMap), - Inc#inc{map = NewMap}; - Val -> %% File is already in. Check. - case lists:keyfind(FA, 1, Val) of - false -> - %% Function is not in; add it - Obj = {File, Val ++ [{FA, {Line, Type}}]}, - NewMap = map__insert(Obj, IncMap), - Inc#inc{map = NewMap}; - Type -> - %% Function is in and with same type - Inc; - _ -> - %% Function is in but with diff type - inc_warning(FA, File), - Elem = lists:keydelete(FA, 1, Val), - NewMap = case Elem of - [] -> map__remove(File, IncMap); - _ -> map__insert({File, Elem}, IncMap) - end, - Inc#inc{map = NewMap} - end - end. - -inc_warning({F, A}, File) -> - io:format(" ***Warning: Skip function ~p/~p ", [F, A]), - io:format("in file ~p because of inconsistent type\n", [File]). - -clean_inc(Inc) -> - Inc1 = remove_yecc_generated_file(Inc), - normalize_obj(Inc1). - -remove_yecc_generated_file(#inc{filter = Filter} = Inc) -> - Fun = fun (Key, #inc{map = Map} = I) -> - I#inc{map = map__remove(Key, Map)} - end, - lists:foldl(Fun, Inc, Filter). - -normalize_obj(TmpInc) -> - Fun = fun (Key, Val, Inc) -> - NewVal = [{{Line,F,A},Type} || {{F,A},{Line,Type}} <- Val], - map__insert({Key, NewVal}, Inc) - end, - TmpInc#inc{map = map__fold(Fun, map__new(), TmpInc#inc.map)}. - -get_records(File, Analysis) -> - map__lookup(File, Analysis#analysis.record). - -get_types(Module, Analysis, Records) -> - TypeInfoPlt = Analysis#analysis.trust_plt, - TypeInfo = - case dialyzer_plt:lookup_module(TypeInfoPlt, Module) of - none -> []; - {value, List} -> List - end, - CodeServer = Analysis#analysis.codeserver, - TypeInfoList = - case Analysis#analysis.show_succ of - true -> - [convert_type_info(I) || I <- TypeInfo]; - false -> - [get_type(I, CodeServer, Records) || I <- TypeInfo] - end, - map__from_list(TypeInfoList). - -convert_type_info({{_M, F, A}, Range, Arg}) -> - {{F, A}, {Range, Arg}}. - -get_type({{M, F, A} = MFA, Range, Arg}, CodeServer, Records) -> - case dialyzer_codeserver:lookup_mfa_contract(MFA, CodeServer) of - error -> - {{F, A}, {Range, Arg}}; - {ok, {_FileLine, Contract, _Xtra}} -> - Sig = erl_types:t_fun(Arg, Range), - case dialyzer_contracts:check_contract(Contract, Sig) of - ok -> {{F, A}, {contract, Contract}}; - {error, {extra_range, _, _}} -> - {{F, A}, {contract, Contract}}; - {error, {overlapping_contract, []}} -> - {{F, A}, {contract, Contract}}; - {error, invalid_contract} -> - CString = dialyzer_contracts:contract_to_string(Contract), - SigString = dialyzer_utils:format_sig(Sig, Records), - Msg = io_lib:format("Error in contract of function ~w:~w/~w\n" - "\t The contract is: " ++ CString ++ "\n" ++ - "\t but the inferred signature is: ~s", - [M, F, A, SigString]), - fatal_error(Msg); - {error, ErrorStr} when is_list(ErrorStr) -> % ErrorStr is a string() - Msg = io_lib:format("Error in contract of function ~w:~w/~w: ~s", - [M, F, A, ErrorStr]), - fatal_error(Msg) - end - end. - -get_functions(File, Analysis) -> - case Analysis#analysis.mode of - ?SHOW -> - Funcs = map__lookup(File, Analysis#analysis.func), - Inc_Funcs = map__lookup(File, Analysis#analysis.inc_func), - remove_module_info(Funcs) ++ normalize_incFuncs(Inc_Funcs); - ?SHOW_EXPORTED -> - Ex_Funcs = map__lookup(File, Analysis#analysis.ex_func), - remove_module_info(Ex_Funcs); - ?ANNOTATE -> - Funcs = map__lookup(File, Analysis#analysis.func), - remove_module_info(Funcs); - ?ANNOTATE_INC_FILES -> - map__lookup(File, Analysis#analysis.inc_func) - end. - -normalize_incFuncs(Functions) -> - [FunInfo || {_FileName, FunInfo} <- Functions]. - --spec remove_module_info([func_info()]) -> [func_info()]. - -remove_module_info(FunInfoList) -> - F = fun ({_,module_info,0}) -> false; - ({_,module_info,1}) -> false; - ({Line,F,A}) when is_integer(Line), is_atom(F), is_integer(A) -> true - end, - lists:filter(F, FunInfoList). - -write_typed_file(File, Info) -> - io:format(" Processing file: ~p\n", [File]), - Dir = filename:dirname(File), - RootName = filename:basename(filename:rootname(File)), - Ext = filename:extension(File), - TyperAnnDir = filename:join(Dir, ?TYPER_ANN_DIR), - TmpNewFilename = lists:concat([RootName, ".ann", Ext]), - NewFileName = filename:join(TyperAnnDir, TmpNewFilename), - case file:make_dir(TyperAnnDir) of - {error, Reason} -> - case Reason of - eexist -> %% TypEr dir exists; remove old typer files if they exist - case file:delete(NewFileName) of - ok -> ok; - {error, enoent} -> ok; - {error, _} -> - Msg = io_lib:format("Error in deleting file ~s\n", [NewFileName]), - fatal_error(Msg) - end, - write_typed_file(File, Info, NewFileName); - enospc -> - Msg = io_lib:format("Not enough space in ~p\n", [Dir]), - fatal_error(Msg); - eacces -> - Msg = io_lib:format("No write permission in ~p\n", [Dir]), - fatal_error(Msg); - _ -> - Msg = io_lib:format("Unhandled error ~s when writing ~p\n", - [Reason, Dir]), - fatal_error(Msg) - end; - ok -> %% Typer dir does NOT exist - write_typed_file(File, Info, NewFileName) - end. - -write_typed_file(File, Info, NewFileName) -> - {ok, Binary} = file:read_file(File), - Chars = binary_to_list(Binary), - write_typed_file(Chars, NewFileName, Info, 1, []), - io:format(" Saved as: ~p\n", [NewFileName]). - -write_typed_file(Chars, File, #info{functions = []}, _LNo, _Acc) -> - ok = file:write_file(File, list_to_binary(Chars), [append]); -write_typed_file([Ch|Chs] = Chars, File, Info, LineNo, Acc) -> - [{Line,F,A}|RestFuncs] = Info#info.functions, - case Line of - 1 -> %% This will happen only for inc files - ok = raw_write(F, A, Info, File, []), - NewInfo = Info#info{functions = RestFuncs}, - NewAcc = [], - write_typed_file(Chars, File, NewInfo, Line, NewAcc); - _ -> - case Ch of - 10 -> - NewLineNo = LineNo + 1, - {NewInfo, NewAcc} = - case NewLineNo of - Line -> - ok = raw_write(F, A, Info, File, [Ch|Acc]), - {Info#info{functions = RestFuncs}, []}; - _ -> - {Info, [Ch|Acc]} - end, - write_typed_file(Chs, File, NewInfo, NewLineNo, NewAcc); - _ -> - write_typed_file(Chs, File, Info, LineNo, [Ch|Acc]) - end - end. - -raw_write(F, A, Info, File, Content) -> - TypeInfo = get_type_string(F, A, Info, file), - ContentList = lists:reverse(Content) ++ TypeInfo ++ "\n", - ContentBin = list_to_binary(ContentList), - file:write_file(File, ContentBin, [append]). - -get_type_string(F, A, Info, Mode) -> - Type = get_type_info({F,A}, Info#info.types), - TypeStr = - case Type of - {contract, C} -> - dialyzer_contracts:contract_to_string(C); - {RetType, ArgType} -> - Sig = erl_types:t_fun(ArgType, RetType), - dialyzer_utils:format_sig(Sig, Info#info.records) - end, - case Info#info.edoc of - false -> - case {Mode, Type} of - {file, {contract, _}} -> ""; - _ -> - Prefix = lists:concat(["-spec ", erl_types:atom_to_string(F)]), - lists:concat([Prefix, TypeStr, "."]) - end; - true -> - Prefix = lists:concat(["%% @spec ", F]), - lists:concat([Prefix, TypeStr, "."]) - end. - -show_type_info(File, Info) -> - io:format("\n%% File: ~p\n%% ", [File]), - OutputString = lists:concat(["~.", length(File)+8, "c~n"]), - io:fwrite(OutputString, [$-]), - Fun = fun ({_LineNo, F, A}) -> - TypeInfo = get_type_string(F, A, Info, show), - io:format("~s\n", [TypeInfo]) - end, - lists:foreach(Fun, Info#info.functions). - -get_type_info(Func, Types) -> - case map__lookup(Func, Types) of - none -> - %% Note: Typeinfo of any function should exist in - %% the result offered by dialyzer, otherwise there - %% *must* be something wrong with the analysis - Msg = io_lib:format("No type info for function: ~p\n", [Func]), - fatal_error(Msg); - {contract, _Fun} = C -> C; - {_RetType, _ArgType} = RA -> RA - end. - -%%-------------------------------------------------------------------- -%% Processing of command-line options and arguments. -%%-------------------------------------------------------------------- - --spec process_cl_args() -> {args(), analysis()}. - -process_cl_args() -> - ArgList = init:get_plain_arguments(), - %% io:format("Args is ~p\n", [ArgList]), - {Args, Analysis} = analyze_args(ArgList, #args{}, #analysis{}), - %% if the mode has not been set, set it to the default mode (show) - {Args, case Analysis#analysis.mode of - undefined -> Analysis#analysis{mode = ?SHOW}; - Mode when is_atom(Mode) -> Analysis - end}. - -analyze_args([], Args, Analysis) -> - {Args, Analysis}; -analyze_args(ArgList, Args, Analysis) -> - {Result, Rest} = cl(ArgList), - {NewArgs, NewAnalysis} = analyze_result(Result, Args, Analysis), - analyze_args(Rest, NewArgs, NewAnalysis). - -cl(["-h"|_]) -> help_message(); -cl(["--help"|_]) -> help_message(); -cl(["-v"|_]) -> version_message(); -cl(["--version"|_]) -> version_message(); -cl(["--edoc"|Opts]) -> {edoc, Opts}; -cl(["--show"|Opts]) -> {{mode, ?SHOW}, Opts}; -cl(["--show_exported"|Opts]) -> {{mode, ?SHOW_EXPORTED}, Opts}; -cl(["--show-exported"|Opts]) -> {{mode, ?SHOW_EXPORTED}, Opts}; -cl(["--show_success_typings"|Opts]) -> {show_succ, Opts}; -cl(["--show-success-typings"|Opts]) -> {show_succ, Opts}; -cl(["--annotate"|Opts]) -> {{mode, ?ANNOTATE}, Opts}; -cl(["--annotate-inc-files"|Opts]) -> {{mode, ?ANNOTATE_INC_FILES}, Opts}; -cl(["--no_spec"|Opts]) -> {no_spec, Opts}; -cl(["--plt",Plt|Opts]) -> {{plt, Plt}, Opts}; -cl(["-D"++Def|Opts]) -> - case Def of - "" -> fatal_error("no variable name specified after -D"); - _ -> - DefPair = process_def_list(re:split(Def, "=", [{return, list}])), - {{def, DefPair}, Opts} - end; -cl(["-I",Dir|Opts]) -> {{inc, Dir}, Opts}; -cl(["-I"++Dir|Opts]) -> - case Dir of - "" -> fatal_error("no include directory specified after -I"); - _ -> {{inc, Dir}, Opts} - end; -cl(["-T"|Opts]) -> - {Files, RestOpts} = dialyzer_cl_parse:collect_args(Opts), - case Files of - [] -> fatal_error("no file or directory specified after -T"); - [_|_] -> {{trusted, Files}, RestOpts} - end; -cl(["-r"|Opts]) -> - {Files, RestOpts} = dialyzer_cl_parse:collect_args(Opts), - {{files_r, Files}, RestOpts}; -cl(["-pa",Dir|Opts]) -> {{pa,Dir}, Opts}; -cl(["-pz",Dir|Opts]) -> {{pz,Dir}, Opts}; -cl(["-"++H|_]) -> fatal_error("unknown option -"++H); -cl(Opts) -> - {Files, RestOpts} = dialyzer_cl_parse:collect_args(Opts), - {{files, Files}, RestOpts}. - -process_def_list(L) -> - case L of - [Name, Value] -> - {ok, Tokens, _} = erl_scan:string(Value ++ "."), - {ok, ErlValue} = erl_parse:parse_term(Tokens), - {list_to_atom(Name), ErlValue}; - [Name] -> - {list_to_atom(Name), true} - end. - -%% Get information about files that the user trusts and wants to analyze -analyze_result({files, Val}, Args, Analysis) -> - NewVal = Args#args.files ++ Val, - {Args#args{files = NewVal}, Analysis}; -analyze_result({files_r, Val}, Args, Analysis) -> - NewVal = Args#args.files_r ++ Val, - {Args#args{files_r = NewVal}, Analysis}; -analyze_result({trusted, Val}, Args, Analysis) -> - NewVal = Args#args.trusted ++ Val, - {Args#args{trusted = NewVal}, Analysis}; -analyze_result(edoc, Args, Analysis) -> - {Args, Analysis#analysis{edoc = true}}; -%% Get useful information for actual analysis -analyze_result({mode, Mode}, Args, Analysis) -> - case Analysis#analysis.mode of - undefined -> {Args, Analysis#analysis{mode = Mode}}; - OldMode -> mode_error(OldMode, Mode) - end; -analyze_result({def, Val}, Args, Analysis) -> - NewVal = Analysis#analysis.macros ++ [Val], - {Args, Analysis#analysis{macros = NewVal}}; -analyze_result({inc, Val}, Args, Analysis) -> - NewVal = Analysis#analysis.includes ++ [Val], - {Args, Analysis#analysis{includes = NewVal}}; -analyze_result({plt, Plt}, Args, Analysis) -> - {Args, Analysis#analysis{plt = Plt}}; -analyze_result(show_succ, Args, Analysis) -> - {Args, Analysis#analysis{show_succ = true}}; -analyze_result(no_spec, Args, Analysis) -> - {Args, Analysis#analysis{no_spec = true}}; -analyze_result({pa, Dir}, Args, Analysis) -> - true = code:add_patha(Dir), - {Args, Analysis}; -analyze_result({pz, Dir}, Args, Analysis) -> - true = code:add_pathz(Dir), - {Args, Analysis}. - -%%-------------------------------------------------------------------- -%% File processing. -%%-------------------------------------------------------------------- - --spec get_all_files(args()) -> [file:filename(),...]. - -get_all_files(#args{files = Fs, files_r = Ds}) -> - case filter_fd(Fs, Ds, fun test_erl_file_exclude_ann/1) of - [] -> fatal_error("no file(s) to analyze"); - AllFiles -> AllFiles - end. - --spec test_erl_file_exclude_ann(file:filename()) -> boolean(). - -test_erl_file_exclude_ann(File) -> - case is_erl_file(File) of - true -> %% Exclude files ending with ".ann.erl" - case re:run(File, "[\.]ann[\.]erl$") of - {match, _} -> false; - nomatch -> true - end; - false -> false - end. - --spec is_erl_file(file:filename()) -> boolean(). - -is_erl_file(File) -> - filename:extension(File) =:= ".erl". - --type test_file_fun() :: fun((file:filename()) -> boolean()). - --spec filter_fd(files(), files(), test_file_fun()) -> files(). - -filter_fd(File_Dir, Dir_R, Fun) -> - All_File_1 = process_file_and_dir(File_Dir, Fun), - All_File_2 = process_dir_rec(Dir_R, Fun), - remove_dup(All_File_1 ++ All_File_2). - --spec process_file_and_dir(files(), test_file_fun()) -> files(). - -process_file_and_dir(File_Dir, TestFun) -> - Fun = - fun (Elem, Acc) -> - case filelib:is_regular(Elem) of - true -> process_file(Elem, TestFun, Acc); - false -> check_dir(Elem, false, Acc, TestFun) - end - end, - lists:foldl(Fun, [], File_Dir). - --spec process_dir_rec(files(), test_file_fun()) -> files(). - -process_dir_rec(Dirs, TestFun) -> - Fun = fun (Dir, Acc) -> check_dir(Dir, true, Acc, TestFun) end, - lists:foldl(Fun, [], Dirs). - --spec check_dir(file:filename(), boolean(), files(), test_file_fun()) -> files(). - -check_dir(Dir, Recursive, Acc, Fun) -> - case file:list_dir(Dir) of - {ok, Files} -> - {TmpDirs, TmpFiles} = split_dirs_and_files(Files, Dir), - case Recursive of - false -> - FinalFiles = process_file_and_dir(TmpFiles, Fun), - Acc ++ FinalFiles; - true -> - TmpAcc1 = process_file_and_dir(TmpFiles, Fun), - TmpAcc2 = process_dir_rec(TmpDirs, Fun), - Acc ++ TmpAcc1 ++ TmpAcc2 - end; - {error, eacces} -> - fatal_error("no access permission to dir \""++Dir++"\""); - {error, enoent} -> - fatal_error("cannot access "++Dir++": No such file or directory"); - {error, _Reason} -> - fatal_error("error involving a use of file:list_dir/1") - end. - -%% Same order as the input list --spec process_file(file:filename(), test_file_fun(), files()) -> files(). - -process_file(File, TestFun, Acc) -> - case TestFun(File) of - true -> Acc ++ [File]; - false -> Acc - end. - -%% Same order as the input list --spec split_dirs_and_files(files(), file:filename()) -> {files(), files()}. - -split_dirs_and_files(Elems, Dir) -> - Test_Fun = - fun (Elem, {DirAcc, FileAcc}) -> - File = filename:join(Dir, Elem), - case filelib:is_regular(File) of - false -> {[File|DirAcc], FileAcc}; - true -> {DirAcc, [File|FileAcc]} - end - end, - {Dirs, Files} = lists:foldl(Test_Fun, {[], []}, Elems), - {lists:reverse(Dirs), lists:reverse(Files)}. - -%% Removes duplicate filenames but keeps the order of the input list --spec remove_dup(files()) -> files(). - -remove_dup(Files) -> - Test_Dup = fun (File, Acc) -> - case lists:member(File, Acc) of - true -> Acc; - false -> [File|Acc] - end - end, - Reversed_Elems = lists:foldl(Test_Dup, [], Files), - lists:reverse(Reversed_Elems). - -%%-------------------------------------------------------------------- -%% Collect information. -%%-------------------------------------------------------------------- - --type inc_file_info() :: {file:filename(), func_info()}. - --record(tmpAcc, {file :: file:filename(), - module :: atom(), - funcAcc = [] :: [func_info()], - incFuncAcc = [] :: [inc_file_info()], - dialyzerObj = [] :: [{mfa(), {_, _}}]}). - --spec collect_info(analysis()) -> analysis(). - -collect_info(Analysis) -> - NewPlt = - try get_dialyzer_plt(Analysis) of - DialyzerPlt -> - dialyzer_plt:merge_plts([Analysis#analysis.trust_plt, DialyzerPlt]) - catch - throw:{dialyzer_error,_Reason} -> - fatal_error("Dialyzer's PLT is missing or is not up-to-date; please (re)create it") - end, - NewAnalysis = lists:foldl(fun collect_one_file_info/2, - Analysis#analysis{trust_plt = NewPlt}, - Analysis#analysis.files), - %% Process Remote Types - TmpCServer = NewAnalysis#analysis.codeserver, - NewCServer = - try - TmpCServer1 = dialyzer_utils:merge_types(TmpCServer, NewPlt), - NewExpTypes = dialyzer_codeserver:get_temp_exported_types(TmpCServer), - OldExpTypes = dialyzer_plt:get_exported_types(NewPlt), - MergedExpTypes = sets:union(NewExpTypes, OldExpTypes), - TmpCServer2 = - dialyzer_codeserver:finalize_exported_types(MergedExpTypes, TmpCServer1), - TmpCServer3 = dialyzer_utils:process_record_remote_types(TmpCServer2), - dialyzer_contracts:process_contract_remote_types(TmpCServer3) - catch - throw:{error, ErrorMsg} -> - fatal_error(ErrorMsg) - end, - NewAnalysis#analysis{codeserver = NewCServer}. - -collect_one_file_info(File, Analysis) -> - Ds = [{d,Name,Val} || {Name,Val} <- Analysis#analysis.macros], - %% Current directory should also be included in "Includes". - Includes = [filename:dirname(File)|Analysis#analysis.includes], - Is = [{i,Dir} || Dir <- Includes], - Options = dialyzer_utils:src_compiler_opts() ++ Is ++ Ds, - case dialyzer_utils:get_abstract_code_from_src(File, Options) of - {error, Reason} -> - %% io:format("File=~p\n,Options=~p\n,Error=~p\n", [File,Options,Reason]), - compile_error(Reason); - {ok, AbstractCode} -> - case dialyzer_utils:get_core_from_abstract_code(AbstractCode, Options) of - error -> compile_error(["Could not get core erlang for "++File]); - {ok, Core} -> - case dialyzer_utils:get_record_and_type_info(AbstractCode) of - {error, Reason} -> compile_error([Reason]); - {ok, Records} -> - Mod = cerl:concrete(cerl:module_name(Core)), - case dialyzer_utils:get_spec_info(Mod, AbstractCode, Records) of - {error, Reason} -> compile_error([Reason]); - {ok, SpecInfo, CbInfo} -> - ExpTypes = get_exported_types_from_core(Core), - analyze_core_tree(Core, Records, SpecInfo, CbInfo, - ExpTypes, Analysis, File) - end - end - end - end. - -analyze_core_tree(Core, Records, SpecInfo, CbInfo, ExpTypes, Analysis, File) -> - Module = cerl:concrete(cerl:module_name(Core)), - TmpTree = cerl:from_records(Core), - CS1 = Analysis#analysis.codeserver, - NextLabel = dialyzer_codeserver:get_next_core_label(CS1), - {Tree, NewLabel} = cerl_trees:label(TmpTree, NextLabel), - CS2 = dialyzer_codeserver:insert(Module, Tree, CS1), - CS3 = dialyzer_codeserver:set_next_core_label(NewLabel, CS2), - CS4 = dialyzer_codeserver:store_temp_records(Module, Records, CS3), - CS5 = - case Analysis#analysis.no_spec of - true -> CS4; - false -> - dialyzer_codeserver:store_temp_contracts(Module, SpecInfo, CbInfo, CS4) - end, - OldExpTypes = dialyzer_codeserver:get_temp_exported_types(CS5), - MergedExpTypes = sets:union(ExpTypes, OldExpTypes), - CS6 = dialyzer_codeserver:insert_temp_exported_types(MergedExpTypes, CS5), - Ex_Funcs = [{0,F,A} || {_,_,{F,A}} <- cerl:module_exports(Tree)], - CG = Analysis#analysis.callgraph, - {V, E} = dialyzer_callgraph:scan_core_tree(Tree, CG), - dialyzer_callgraph:add_edges(E, V, CG), - Fun = fun analyze_one_function/2, - All_Defs = cerl:module_defs(Tree), - Acc = lists:foldl(Fun, #tmpAcc{file = File, module = Module}, All_Defs), - Exported_FuncMap = map__insert({File, Ex_Funcs}, Analysis#analysis.ex_func), - %% we must sort all functions in the file which - %% originate from this file by *numerical order* of lineNo - Sorted_Functions = lists:keysort(1, Acc#tmpAcc.funcAcc), - FuncMap = map__insert({File, Sorted_Functions}, Analysis#analysis.func), - %% we do not need to sort functions which are imported from included files - IncFuncMap = map__insert({File, Acc#tmpAcc.incFuncAcc}, - Analysis#analysis.inc_func), - FMs = Analysis#analysis.fms ++ [{File, Module}], - RecordMap = map__insert({File, Records}, Analysis#analysis.record), - Analysis#analysis{fms = FMs, - callgraph = CG, - codeserver = CS6, - ex_func = Exported_FuncMap, - inc_func = IncFuncMap, - record = RecordMap, - func = FuncMap}. - -analyze_one_function({Var, FunBody} = Function, Acc) -> - F = cerl:fname_id(Var), - A = cerl:fname_arity(Var), - TmpDialyzerObj = {{Acc#tmpAcc.module, F, A}, Function}, - NewDialyzerObj = Acc#tmpAcc.dialyzerObj ++ [TmpDialyzerObj], - Anno = cerl:get_ann(FunBody), - LineNo = get_line(Anno), - FileName = get_file(Anno), - BaseName = filename:basename(FileName), - FuncInfo = {LineNo, F, A}, - OriginalName = Acc#tmpAcc.file, - {FuncAcc, IncFuncAcc} = - case (FileName =:= OriginalName) orelse (BaseName =:= OriginalName) of - true -> %% Coming from original file - %% io:format("Added function ~p\n", [{LineNo, F, A}]), - {Acc#tmpAcc.funcAcc ++ [FuncInfo], Acc#tmpAcc.incFuncAcc}; - false -> - %% Coming from other sourses, including: - %% -- .yrl (yecc-generated file) - %% -- yeccpre.hrl (yecc-generated file) - %% -- other cases - {Acc#tmpAcc.funcAcc, Acc#tmpAcc.incFuncAcc ++ [{FileName, FuncInfo}]} - end, - Acc#tmpAcc{funcAcc = FuncAcc, - incFuncAcc = IncFuncAcc, - dialyzerObj = NewDialyzerObj}. - -get_line([Line|_]) when is_integer(Line) -> Line; -get_line([_|T]) -> get_line(T); -get_line([]) -> none. - -get_file([{file,File}|_]) -> File; -get_file([_|T]) -> get_file(T); -get_file([]) -> "no_file". % should not happen - --spec get_dialyzer_plt(analysis()) -> plt(). - -get_dialyzer_plt(#analysis{plt = PltFile0}) -> - PltFile = - case PltFile0 =:= none of - true -> dialyzer_plt:get_default_plt(); - false -> PltFile0 - end, - dialyzer_plt:from_file(PltFile). - -%% Exported Types - -get_exported_types_from_core(Core) -> - Attrs = cerl:module_attrs(Core), - ExpTypes1 = [cerl:concrete(L2) || {L1, L2} <- Attrs, - cerl:is_literal(L1), - cerl:is_literal(L2), - cerl:concrete(L1) =:= 'export_type'], - ExpTypes2 = lists:flatten(ExpTypes1), - M = cerl:atom_val(cerl:module_name(Core)), - sets:from_list([{M, F, A} || {F, A} <- ExpTypes2]). - -%%-------------------------------------------------------------------- -%% Utilities for error reporting. -%%-------------------------------------------------------------------- - --spec fatal_error(string()) -> no_return(). - -fatal_error(Slogan) -> - msg(io_lib:format("typer: ~s\n", [Slogan])), - erlang:halt(1). - --spec mode_error(mode(), mode()) -> no_return(). - -mode_error(OldMode, NewMode) -> - Msg = io_lib:format("Mode was previously set to '~s'; " - "can not set it to '~s' now", - [OldMode, NewMode]), - fatal_error(Msg). - --spec compile_error([string()]) -> no_return(). - -compile_error(Reason) -> - JoinedString = lists:flatten([X ++ "\n" || X <- Reason]), - Msg = "Analysis failed with error report:\n" ++ JoinedString, - fatal_error(Msg). - --spec msg(string()) -> 'ok'. - -msg(Msg) -> - io:format(standard_error, "~s", [Msg]). - -%%-------------------------------------------------------------------- -%% Version and help messages. -%%-------------------------------------------------------------------- - --spec version_message() -> no_return(). - -version_message() -> - io:format("TypEr version "++?VSN++"\n"), - erlang:halt(0). - --spec help_message() -> no_return(). - -help_message() -> - S = <<" Usage: typer [--help] [--version] [--plt PLT] [--edoc] - [--show | --show-exported | --annotate | --annotate-inc-files] - [-Ddefine]* [-I include_dir]* [-pa dir]* [-pz dir]* - [-T application]* [-r] file* - - Options: - -r dir* - search directories recursively for .erl files below them - --show - Prints type specifications for all functions on stdout. - (this is the default behaviour; this option is not really needed) - --show-exported (or --show_exported) - Same as --show, but prints specifications for exported functions only - Specs are displayed sorted alphabetically on the function's name - --annotate - Annotates the specified files with type specifications - --annotate-inc-files - Same as --annotate but annotates all -include() files as well as - all .erl files (use this option with caution - has not been tested much) - --edoc - Prints type information as Edoc @spec comments, not as type specs - --plt PLT - Use the specified dialyzer PLT file rather than the default one - -T file* - The specified file(s) already contain type specifications and these - are to be trusted in order to print specs for the rest of the files - (Multiple files or dirs, separated by spaces, can be specified.) - -Dname (or -Dname=value) - pass the defined name(s) to TypEr - (The syntax of defines is the same as that used by \"erlc\".) - -I include_dir - pass the include_dir to TypEr - (The syntax of includes is the same as that used by \"erlc\".) - -pa dir - -pz dir - Set code path options to TypEr - (This is useful for files that use parse tranforms.) - --version (or -v) - prints the Typer version and exits - --help (or -h) - prints this message and exits - - Note: - * denotes that multiple occurrences of these options are possible. -">>, - io:put_chars(S), - erlang:halt(0). - -%%-------------------------------------------------------------------- -%% Handle messages. -%%-------------------------------------------------------------------- - -rcv_ext_types() -> - Self = self(), - Self ! {Self, done}, - rcv_ext_types(Self, []). - -rcv_ext_types(Self, ExtTypes) -> - receive - {Self, ext_types, ExtType} -> - rcv_ext_types(Self, [ExtType|ExtTypes]); - {Self, done} -> - lists:usort(ExtTypes) - end. - -%%-------------------------------------------------------------------- -%% A convenient abstraction of a Key-Value mapping data structure -%% specialized for the uses in this module -%%-------------------------------------------------------------------- - --type map_dict() :: dict:dict(). - --spec map__new() -> map_dict(). -map__new() -> - dict:new(). - --spec map__insert({term(), term()}, map_dict()) -> map_dict(). -map__insert(Object, Map) -> - {Key, Value} = Object, - dict:store(Key, Value, Map). - --spec map__lookup(term(), map_dict()) -> term(). -map__lookup(Key, Map) -> - try dict:fetch(Key, Map) catch error:_ -> none end. - --spec map__from_list([{fa(), term()}]) -> map_dict(). -map__from_list(List) -> - dict:from_list(List). - --spec map__remove(term(), map_dict()) -> map_dict(). -map__remove(Key, Dict) -> - dict:erase(Key, Dict). - --spec map__fold(fun((term(), term(), term()) -> map_dict()), map_dict(), map_dict()) -> map_dict(). -map__fold(Fun, Acc0, Dict) -> - dict:fold(Fun, Acc0, Dict). diff --git a/lib/typer/test/Makefile b/lib/typer/test/Makefile deleted file mode 100644 index fb5570d9f0..0000000000 --- a/lib/typer/test/Makefile +++ /dev/null @@ -1,65 +0,0 @@ -include $(ERL_TOP)/make/target.mk -include $(ERL_TOP)/make/$(TARGET)/otp.mk - -# ---------------------------------------------------- -# Target Specs -# ---------------------------------------------------- - -MODULES= \ - typer_SUITE - -ERL_FILES= $(MODULES:%=%.erl) - -TARGET_FILES= $(MODULES:%=$(EBIN)/%.$(EMULATOR)) -INSTALL_PROGS= $(TARGET_FILES) - -EMAKEFILE=Emakefile - -# ---------------------------------------------------- -# Release directory specification -# ---------------------------------------------------- -RELSYSDIR = $(RELEASE_PATH)/typer_test - -# ---------------------------------------------------- -# FLAGS -# ---------------------------------------------------- - -ERL_MAKE_FLAGS += -ERL_COMPILE_FLAGS += - -EBIN = . - -# ---------------------------------------------------- -# Targets -# ---------------------------------------------------- - -make_emakefile: - $(ERL_TOP)/make/make_emakefile $(ERL_COMPILE_FLAGS) -o$(EBIN) $(MODULES) \ - > $(EMAKEFILE) - $(ERL_TOP)/make/make_emakefile $(ERL_COMPILE_FLAGS) -o$(EBIN) '*_SUITE_make' \ - >> $(EMAKEFILE) - -tests debug opt: make_emakefile - erl $(ERL_MAKE_FLAGS) -make - -clean: - rm -f $(EMAKEFILE) - rm -f $(TARGET_FILES) $(GEN_FILES) - rm -f core - -docs: - -# ---------------------------------------------------- -# Release Target -# ---------------------------------------------------- -include $(ERL_TOP)/make/otp_release_targets.mk - -release_spec: opt - -release_tests_spec: make_emakefile - $(INSTALL_DIR) "$(RELSYSDIR)" - $(INSTALL_DATA) $(EMAKEFILE) $(ERL_FILES) "$(RELSYSDIR)" - $(INSTALL_DATA) typer.spec "$(RELSYSDIR)" - chmod -R u+w "$(RELSYSDIR)" - -release_docs_spec: diff --git a/lib/typer/test/typer.spec b/lib/typer/test/typer.spec deleted file mode 100644 index 79f51b6781..0000000000 --- a/lib/typer/test/typer.spec +++ /dev/null @@ -1 +0,0 @@ -{suites,"../typer_test",all}. diff --git a/lib/typer/test/typer_SUITE.erl b/lib/typer/test/typer_SUITE.erl deleted file mode 100644 index 25f0229640..0000000000 --- a/lib/typer/test/typer_SUITE.erl +++ /dev/null @@ -1,57 +0,0 @@ -%% ``Licensed under the Apache License, Version 2.0 (the "License"); -%% you may not use this file except in compliance with the License. -%% You may obtain a copy of the License at -%% -%% http://www.apache.org/licenses/LICENSE-2.0 -%% -%% Unless required by applicable law or agreed to in writing, software -%% distributed under the License is distributed on an "AS IS" BASIS, -%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -%% See the License for the specific language governing permissions and -%% limitations under the License. -%% -%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. -%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings -%% AB. All Rights Reserved.'' -%% --module(typer_SUITE). - --compile([export_all]). --include_lib("common_test/include/ct.hrl"). - -suite() -> - [{ct_hooks, [ts_install_cth]}]. - -all() -> - case application:ensure_all_started(typer) of - {ok, Apps} -> - [application:stop(App) || App <- lists:reverse(Apps)], - [app, appup]; - _ -> - [appup] - end. - -groups() -> - []. - -init_per_suite(Config) -> - Config. - -end_per_suite(_Config) -> - ok. - -init_per_group(_GroupName, Config) -> - Config. - -end_per_group(_GroupName, Config) -> - Config. - -app() -> - [{doc, "Test that the typer app file is ok"}]. -app(Config) when is_list(Config) -> - ok = ?t:app_test(typer). - -appup() -> - [{doc, "Test that the typer appup file is ok"}]. -appup(Config) when is_list(Config) -> - ok = ?t:appup_test(typer). diff --git a/lib/typer/vsn.mk b/lib/typer/vsn.mk deleted file mode 100644 index ed12e067c1..0000000000 --- a/lib/typer/vsn.mk +++ /dev/null @@ -1 +0,0 @@ -TYPER_VSN = 0.9.11 diff --git a/lib/wx/api_gen/gen_util.erl b/lib/wx/api_gen/gen_util.erl index cd42ad2d96..49a3cb521e 100644 --- a/lib/wx/api_gen/gen_util.erl +++ b/lib/wx/api_gen/gen_util.erl @@ -203,7 +203,7 @@ replace_and_remove([$; | R], Acc) -> replace_and_remove([$@ | R], Acc) -> replace_and_remove(R, [directive|Acc]); -replace_and_remove([_E|R], Acc) -> %% Ignore everthing else +replace_and_remove([_E|R], Acc) -> %% Ignore everything else replace_and_remove(R, Acc); replace_and_remove([], Acc) -> Acc. diff --git a/lib/wx/api_gen/wx_gen_cpp.erl b/lib/wx/api_gen/wx_gen_cpp.erl index d4b6db8153..4b208001a0 100644 --- a/lib/wx/api_gen/wx_gen_cpp.erl +++ b/lib/wx/api_gen/wx_gen_cpp.erl @@ -627,7 +627,7 @@ decode_arg(N,#type{name="wxArrayString"},Place,A0) -> w(" int * ~sLen = (int *) bp; bp += 4;~n", [N]), case Place of arg -> w(" wxArrayString ~s;~n", [N]); - opt -> ignore %% Allready declared + opt -> ignore %% Already declared end, w(" int ~sASz = 0, * ~sTemp;~n", [N,N]), w(" for(int i=0; i < *~sLen; i++) {~n", [N]), diff --git a/lib/xmerl/src/xmerl_regexp.erl b/lib/xmerl/src/xmerl_regexp.erl index fc89b80ff1..566b77725f 100644 --- a/lib/xmerl/src/xmerl_regexp.erl +++ b/lib/xmerl/src/xmerl_regexp.erl @@ -1154,7 +1154,7 @@ comp_crs([], Last) -> [{Last,maxchar}]. %% build_dfa(NFA, NfaStartState) -> {DFA,DfaStartState}. %% Build a DFA from an NFA using "subset construction". The major %% difference from the book is that we keep the marked and unmarked -%% DFA states in seperate lists. New DFA states are added to the +%% DFA states in separate lists. New DFA states are added to the %% unmarked list and states are marked by moving them to the marked %% list. We assume that the NFA accepting state numbers are in %% ascending order for the rules and use ordsets to keep this order. diff --git a/lib/xmerl/src/xmerl_sax_parser.erl b/lib/xmerl/src/xmerl_sax_parser.erl index 318a0cf7f4..1aef6c58c4 100644 --- a/lib/xmerl/src/xmerl_sax_parser.erl +++ b/lib/xmerl/src/xmerl_sax_parser.erl @@ -1,7 +1,7 @@ %%-------------------------------------------------------------------- %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2008-2016. All Rights Reserved. +%% Copyright Ericsson AB 2008-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -33,6 +33,7 @@ %% External exports %%---------------------------------------------------------------------- -export([file/2, + stream/3, stream/2]). %%---------------------------------------------------------------------- @@ -72,11 +73,12 @@ file(Name,Options) -> File = filename:basename(Name), ContinuationFun = fun default_continuation_cb/1, Res = stream(<<>>, - [{continuation_fun, ContinuationFun}, - {continuation_state, FD}, - {current_location, CL}, - {entity, File} - |Options]), + [{continuation_fun, ContinuationFun}, + {continuation_state, FD}, + {current_location, CL}, + {entity, File} + |Options], + file), ok = file:close(FD), Res end. @@ -92,19 +94,22 @@ file(Name,Options) -> %% EventState = term() %% Description: Parse a stream containing an XML document. %%---------------------------------------------------------------------- -stream(Xml, Options) when is_list(Xml), is_list(Options) -> +stream(Xml, Options) -> + stream(Xml, Options, stream). + +stream(Xml, Options, InputType) when is_list(Xml), is_list(Options) -> State = parse_options(Options, initial_state()), - case State#xmerl_sax_parser_state.file_type of + case State#xmerl_sax_parser_state.file_type of dtd -> xmerl_sax_parser_list:parse_dtd(Xml, State#xmerl_sax_parser_state{encoding = list, - input_type = stream}); + input_type = InputType}); normal -> xmerl_sax_parser_list:parse(Xml, State#xmerl_sax_parser_state{encoding = list, - input_type = stream}) + input_type = InputType}) end; -stream(Xml, Options) when is_binary(Xml), is_list(Options) -> +stream(Xml, Options, InputType) when is_binary(Xml), is_list(Options) -> case parse_options(Options, initial_state()) of {error, Reason} -> {error, Reason}; State -> @@ -127,7 +132,7 @@ stream(Xml, Options) when is_binary(Xml), is_list(Options) -> State#xmerl_sax_parser_state.event_state}; {Xml1, State1} -> parse_binary(Xml1, - State1#xmerl_sax_parser_state{input_type = stream}, + State1#xmerl_sax_parser_state{input_type = InputType}, ParseFunction) end end. @@ -226,12 +231,12 @@ check_encoding_option(E) -> %% Description: Detects which character set is used in a binary stream. %%---------------------------------------------------------------------- detect_charset(<<>>, #xmerl_sax_parser_state{continuation_fun = undefined} = _) -> - throw({error, "Can't detect character encoding due to no indata"}); + {error, "Can't detect character encoding due to no indata"}; detect_charset(<<>>, #xmerl_sax_parser_state{continuation_fun = CFun, continuation_state = CState} = State) -> case CFun(CState) of {<<>>, _} -> - throw({error, "Can't detect character encoding due to lack of indata"}); + {error, "Can't detect character encoding due to lack of indata"}; {NewBytes, NewContState} -> detect_charset(NewBytes, State#xmerl_sax_parser_state{continuation_state = NewContState}) end; diff --git a/lib/xmerl/src/xmerl_sax_parser.hrl b/lib/xmerl/src/xmerl_sax_parser.hrl index 932ab0cec5..7f9bf6c4d3 100644 --- a/lib/xmerl/src/xmerl_sax_parser.hrl +++ b/lib/xmerl/src/xmerl_sax_parser.hrl @@ -88,14 +88,7 @@ current_location, % Location of the currently parsed XML entity entity, % Parsed XML entity skip_external_dtd = false,% If true the external DTD is skipped during parsing - input_type % Source type: file | stream. - % This field is a preparation for an fix in R17 of a bug in - % the conformance against the standard. - % Today a file which contains two XML documents will be considered - % well-formed and the second is placed in the rest part of the - % return tuple, according to the conformance tests this should fail. - % In the future this will fail if xmerl_sax_aprser:file/2 is used but - % left to the user in the xmerl_sax_aprser:stream/2 case. + input_type % Source type: file | stream }). diff --git a/lib/xmerl/src/xmerl_sax_parser_base.erlsrc b/lib/xmerl/src/xmerl_sax_parser_base.erlsrc index 4d75805b9b..f3470b2809 100644 --- a/lib/xmerl/src/xmerl_sax_parser_base.erlsrc +++ b/lib/xmerl/src/xmerl_sax_parser_base.erlsrc @@ -1,7 +1,7 @@ %%-*-erlang-*- %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2008-2016. All Rights Reserved. +%% Copyright Ericsson AB 2008-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -72,7 +72,12 @@ parse(Xml, State) -> {ok, Rest, State2} -> State3 = event_callback(endDocument, State2), ets:delete(RefTable), - {ok, State3#xmerl_sax_parser_state.event_state, Rest}; + case check_if_rest_ok(State3#xmerl_sax_parser_state.input_type, Rest) of + true -> + {ok, State3#xmerl_sax_parser_state.event_state, Rest}; + false -> + format_error(fatal_error, State3, "Input found after legal document") + end; {fatal_error, {State2, Reason}} -> State3 = event_callback(endDocument, State2), ets:delete(RefTable), @@ -81,10 +86,14 @@ parse(Xml, State) -> State3 = event_callback(endDocument, State2), ets:delete(RefTable), format_error(Tag, State3, Reason); + {endDocument, Rest, State2} -> + State3 = event_callback(endDocument, State2), + ets:delete(RefTable), + {ok, State3#xmerl_sax_parser_state.event_state, Rest}; Other -> _State2 = event_callback(endDocument, State1), ets:delete(RefTable), - throw(Other) + {fatal_error, Other} end. %%---------------------------------------------------------------------- @@ -111,7 +120,7 @@ parse_dtd(Xml, State) -> {Rest, State2} when is_record(State2, xmerl_sax_parser_state) -> State3 = event_callback(endDocument, State2), ets:delete(RefTable), - {ok, State3#xmerl_sax_parser_state.event_state, Rest}; + {ok, State3#xmerl_sax_parser_state.event_state, Rest}; {endDocument, Rest, State2} when is_record(State2, xmerl_sax_parser_state) -> State3 = event_callback(endDocument, State2), ets:delete(RefTable), @@ -119,7 +128,7 @@ parse_dtd(Xml, State) -> Other -> _State2 = event_callback(endDocument, State1), ets:delete(RefTable), - throw(Other) + {fatal_error, Other} end. @@ -136,10 +145,11 @@ parse_dtd(Xml, State) -> %% [1] document ::= prolog element Misc* %%---------------------------------------------------------------------- parse_document(Rest, State) when is_record(State, xmerl_sax_parser_state) -> - {Rest1, State1} = parse_xml_decl(Rest, State), + {Rest1, State1} = parse_byte_order_mark(Rest, State), {Rest2, State2} = parse_misc(Rest1, State1, true), {ok, Rest2, State2}. +?PARSE_BYTE_ORDER_MARK(Bytes, State). %%---------------------------------------------------------------------- %% Function: parse_xml_decl(Rest, State) -> Result @@ -150,15 +160,8 @@ parse_document(Rest, State) when is_record(State, xmerl_sax_parser_state) -> %% [22] prolog ::= XMLDecl? Misc* (doctypedecl Misc*)? %% [23] XMLDecl ::= '<?xml' VersionInfo EncodingDecl? SDDecl? S? '?>' %%---------------------------------------------------------------------- --dialyzer({[no_fail_call, no_match], parse_xml_decl/2}). parse_xml_decl(?STRING_EMPTY, State) -> cf(?STRING_EMPTY, State, fun parse_xml_decl/2); -parse_xml_decl(?BYTE_ORDER_MARK_1, State) -> - cf(?BYTE_ORDER_MARK_1, State, fun parse_xml_decl/2); -parse_xml_decl(?BYTE_ORDER_MARK_2, State) -> - cf(?BYTE_ORDER_MARK_2, State, fun parse_xml_decl/2); -parse_xml_decl(?BYTE_ORDER_MARK_REST(Rest), State) -> - cf(Rest, State, fun parse_xml_decl/2); parse_xml_decl(?STRING("<") = Bytes, State) -> cf(Bytes, State, fun parse_xml_decl/2); parse_xml_decl(?STRING("<?") = Bytes, State) -> @@ -170,31 +173,19 @@ parse_xml_decl(?STRING("<?xm") = Bytes, State) -> parse_xml_decl(?STRING("<?xml") = Bytes, State) -> cf(Bytes, State, fun parse_xml_decl/2); parse_xml_decl(?STRING_REST("<?xml", Rest1), State) -> - parse_xml_decl_1(Rest1, State); -parse_xml_decl(Bytes, #xmerl_sax_parser_state{encoding=Enc} = State) when is_binary(Bytes) -> - case unicode:characters_to_list(Bytes, Enc) of - {incomplete, _, _} -> - cf(Bytes, State, fun parse_xml_decl/2); - {error, _Encoded, _Rest} -> - ?fatal_error(State, lists:flatten(io_lib:format("Bad character, not in ~p\n", [Enc]))); - _ -> - parse_prolog(Bytes, State) - end; -parse_xml_decl(Bytes, State) -> - parse_prolog(Bytes, State). - + parse_xml_decl_rest(Rest1, State); +?PARSE_XML_DECL(Bytes, State). -parse_xml_decl_1(?STRING_UNBOUND_REST(C, Rest) = Bytes, State) -> +parse_xml_decl_rest(?STRING_UNBOUND_REST(C, Rest) = Bytes, State) -> if ?is_whitespace(C) -> {_XmlAttributes, Rest1, State1} = parse_version_info(Rest, State, []), - %State2 = event_callback({processingInstruction, "xml", XmlAttributes}, State1),% The XML decl. should not be reported as a PI parse_prolog(Rest1, State1); true -> parse_prolog(?STRING_REST("<?xml", Bytes), State) end; -parse_xml_decl_1(Bytes, State) -> - unicode_incomplete_check([Bytes, State, fun parse_xml_decl_1/2], undefined). +parse_xml_decl_rest(Bytes, State) -> + unicode_incomplete_check([Bytes, State, fun parse_xml_decl_rest/2], undefined). @@ -216,8 +207,6 @@ parse_prolog(?STRING_REST("<?", Rest), State) -> parse_prolog(Rest1, State1); {endDocument, Rest1, State1} -> parse_prolog(Rest1, State1) - % IValue = ?TO_INPUT_FORMAT("<?"), - % {?APPEND_STRING(IValue, Rest1), State1} end; parse_prolog(?STRING_REST("<!", Rest), State) -> parse_prolog_1(Rest, State); @@ -230,7 +219,6 @@ parse_prolog(Bytes, State) -> unicode_incomplete_check([Bytes, State, fun parse_prolog/2], "expecting < or whitespace"). - parse_prolog_1(?STRING_EMPTY, State) -> cf(?STRING_EMPTY, State, fun parse_prolog_1/2); parse_prolog_1(?STRING("D") = Bytes, State) -> @@ -442,6 +430,15 @@ check_if_new_doc_allowed(stream, []) -> check_if_new_doc_allowed(_, _) -> false. +check_if_rest_ok(file, []) -> + true; +check_if_rest_ok(file, <<>>) -> + true; +check_if_rest_ok(stream, _) -> + true; +check_if_rest_ok(_, _) -> + false. + %%---------------------------------------------------------------------- %% Function: parse_pi_1(Rest, State) -> Result %% Input: Rest = string() | binary() @@ -1024,16 +1021,21 @@ parse_etag(Bytes, State) -> unicode_incomplete_check([Bytes, State, fun parse_etag/2], undefined). - parse_etag_1(?STRING_REST(">", Rest), #xmerl_sax_parser_state{end_tags=[{_ETag, Uri, LocalName, QName, OldNsList, NewNsList} - |RestOfETags]} = State, _Tag) -> + |RestOfETags], + input_type=InputType} = State, _Tag) -> State1 = event_callback({endElement, Uri, LocalName, QName}, State), State2 = send_end_prefix_mapping_event(NewNsList, State1), - parse_content(Rest, - State2#xmerl_sax_parser_state{end_tags=RestOfETags, - ns = OldNsList}, - [], true); + case check_if_new_doc_allowed(InputType, RestOfETags) of + true -> + throw({endDocument, Rest, State2#xmerl_sax_parser_state{ns = OldNsList}}); + false -> + parse_content(Rest, + State2#xmerl_sax_parser_state{end_tags=RestOfETags, + ns = OldNsList}, + [], true) + end; parse_etag_1(?STRING_UNBOUND_REST(_C, _), State, Tag) -> {P,TN} = Tag, ?fatal_error(State, "Bad EndTag: " ++ P ++ ":" ++ TN); @@ -1051,21 +1053,26 @@ parse_etag_1(Bytes, State, Tag) -> %% Description: Parsing the content part of tags %% [43] content ::= (element | CharData | Reference | CDSect | PI | Comment)* %%---------------------------------------------------------------------- - parse_content(?STRING_EMPTY, State, Acc, IgnorableWS) -> - case catch cf(?STRING_EMPTY, State, Acc, IgnorableWS, fun parse_content/4) of - {Rest, State1} when is_record(State1, xmerl_sax_parser_state) -> - {Rest, State1}; - {fatal_error, {State1, Msg}} -> - case check_if_document_complete(State1, Msg) of - true -> - State2 = send_character_event(length(Acc), IgnorableWS, lists:reverse(Acc), State1), - {?STRING_EMPTY, State2}; - false -> - ?fatal_error(State1, Msg) - end; - Other -> - throw(Other) + case check_if_document_complete(State, "No more bytes") of + true -> + State1 = send_character_event(length(Acc), IgnorableWS, lists:reverse(Acc), State), + {?STRING_EMPTY, State1}; + false -> + case catch cf(?STRING_EMPTY, State, Acc, IgnorableWS, fun parse_content/4) of + {Rest, State1} when is_record(State1, xmerl_sax_parser_state) -> + {Rest, State1}; + {fatal_error, {State1, Msg}} -> + case check_if_document_complete(State1, Msg) of + true -> + State2 = send_character_event(length(Acc), IgnorableWS, lists:reverse(Acc), State1), + {?STRING_EMPTY, State2}; + false -> + ?fatal_error(State1, Msg) + end; + Other -> + throw(Other) + end end; parse_content(?STRING("\r") = Bytes, State, Acc, IgnorableWS) -> cf(Bytes, State, Acc, IgnorableWS, fun parse_content/4); @@ -1094,7 +1101,7 @@ parse_content(?STRING_REST("<?", Rest), State, Acc, IgnorableWS) -> parse_content(?STRING_REST("<!", Rest1) = Rest, #xmerl_sax_parser_state{end_tags = ET} = State, Acc, IgnorableWS) -> case ET of [] -> - {Rest, State}; %%LATH : Skicka ignorable WS ??? + {Rest, State}; %% Skicka ignorable WS ??? _ -> State1 = send_character_event(length(Acc), IgnorableWS, lists:reverse(Acc), State), parse_cdata(Rest1, State1) @@ -1102,7 +1109,7 @@ parse_content(?STRING_REST("<!", Rest1) = Rest, #xmerl_sax_parser_state{end_tags parse_content(?STRING_REST("<", Rest1) = Rest, #xmerl_sax_parser_state{end_tags = ET} = State, Acc, IgnorableWS) -> case ET of [] -> - {Rest, State}; %%LATH : Skicka ignorable WS ??? + {Rest, State}; %% Skicka ignorable WS ??? _ -> State1 = send_character_event(length(Acc), IgnorableWS, lists:reverse(Acc), State), parse_stag(Rest1, State1) @@ -1204,7 +1211,6 @@ send_character_event(_, true, String, State) -> %% Description: Parse whitespaces. %% [3] S ::= (#x20 | #x9 | #xD | #xA)+ %%---------------------------------------------------------------------- --dialyzer({no_fail_call, whitespace/3}). whitespace(?STRING_EMPTY, State, Acc) -> case cf(?STRING_EMPTY, State, Acc, fun whitespace/3) of {?STRING_EMPTY, State} -> @@ -1230,16 +1236,7 @@ whitespace(?STRING_REST("\r", Rest), State, Acc) -> whitespace(Rest, State#xmerl_sax_parser_state{line_no=N+1}, [?lf |Acc]); whitespace(?STRING_UNBOUND_REST(C, Rest), State, Acc) when ?is_whitespace(C) -> whitespace(Rest, State, [C|Acc]); -whitespace(?STRING_UNBOUND_REST(_C, _) = Bytes, State, Acc) -> - {lists:reverse(Acc), Bytes, State}; -whitespace(Bytes, #xmerl_sax_parser_state{encoding=Enc} = State, Acc) when is_binary(Bytes) -> - case unicode:characters_to_list(Bytes, Enc) of - {incomplete, _, _} -> - cf(Bytes, State, Acc, fun whitespace/3); - {error, _Encoded, _Rest} -> - ?fatal_error(State, lists:flatten(io_lib:format("Bad character, not in ~p\n", [Enc]))) - end. - +?WHITESPACE(Bytes, State, Acc). %%---------------------------------------------------------------------- %% Function: parse_reference(Rest, State, HaveToExist) -> Result @@ -1362,7 +1359,6 @@ parse_pe_reference_1(Bytes, State, Name) -> "missing ; after reference " ++ Name). - %%---------------------------------------------------------------------- %% Function: insert_reference(Reference, State) -> Result %% Parameters: Reference = string() @@ -1378,7 +1374,6 @@ insert_reference({Name, Type, Value}, Table) -> end. - %%---------------------------------------------------------------------- %% Function: look_up_reference(Reference, State) -> Result %% Parameters: Reference = string() @@ -1693,7 +1688,7 @@ handle_external_entity({http, Url}, State) -> ++ file:format_error(Reason)); {ok, FD} -> {?STRING_EMPTY, EntityState} = - parse_external_entity_1(<<>>, + parse_external_entity_byte_order_mark(<<>>, State#xmerl_sax_parser_state{continuation_state=FD, current_location=filename:dirname(Url), entity=filename:basename(Url), @@ -1709,6 +1704,8 @@ handle_external_entity({http, Url}, State) -> handle_external_entity({Tag, _Url}, State) -> ?fatal_error(State, "Unsupported URI type: " ++ atom_to_list(Tag)). +?PARSE_EXTERNAL_ENTITY_BYTE_ORDER_MARK(Bytes, State). + %%---------------------------------------------------------------------- %% Function : parse_external_entity_1(Rest, State) -> Result %% Parameters: Rest = string() | binary() @@ -1716,7 +1713,6 @@ handle_external_entity({Tag, _Url}, State) -> %% Result : {Rest, State} %% Description: Parse the external entity. %%---------------------------------------------------------------------- --dialyzer({[no_fail_call, no_match], parse_external_entity_1/2}). parse_external_entity_1(?STRING_EMPTY, #xmerl_sax_parser_state{file_type=Type} = State) -> case catch cf(?STRING_EMPTY, State, fun parse_external_entity_1/2) of {Rest, State1} when is_record(State1, xmerl_sax_parser_state) -> @@ -1726,12 +1722,6 @@ parse_external_entity_1(?STRING_EMPTY, #xmerl_sax_parser_state{file_type=Type} = Other -> throw(Other) end; -parse_external_entity_1(?BYTE_ORDER_MARK_1, State) -> - cf(?BYTE_ORDER_MARK_1, State, fun parse_external_entity_1/2); -parse_external_entity_1(?BYTE_ORDER_MARK_2, State) -> - cf(?BYTE_ORDER_MARK_2, State, fun parse_external_entity_1/2); -parse_external_entity_1(?BYTE_ORDER_MARK_REST(Rest), State) -> - parse_external_entity_1(Rest, State); parse_external_entity_1(?STRING("<") = Bytes, State) -> cf(Bytes, State, fun parse_external_entity_1/2); parse_external_entity_1(?STRING("<?") = Bytes, State) -> @@ -3290,7 +3280,7 @@ cf(Rest, #xmerl_sax_parser_state{continuation_fun = CFun, continuation_state = C catch throw:ErrorTerm -> ?fatal_error(State, ErrorTerm); - exit:Reason -> + exit:Reason -> ?fatal_error(State, {'EXIT', Reason}) end, case Result of diff --git a/lib/xmerl/src/xmerl_sax_parser_latin1.erlsrc b/lib/xmerl/src/xmerl_sax_parser_latin1.erlsrc index 961806bf4c..6e59347fb8 100644 --- a/lib/xmerl/src/xmerl_sax_parser_latin1.erlsrc +++ b/lib/xmerl/src/xmerl_sax_parser_latin1.erlsrc @@ -2,7 +2,7 @@ %%-------------------------------------------------------------------- %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2008-2016. All Rights Reserved. +%% Copyright Ericsson AB 2008-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -34,8 +34,36 @@ -define(APPEND_STRING(Rest, New), <<Rest/binary, New/binary>>). -define(TO_INPUT_FORMAT(Val), unicode:characters_to_binary(Val, unicode, latin1)). -%% STRING_REST and STRING_UNBOUND_REST is only different in the list case -define(STRING_UNBOUND_REST(MatchChar, Rest), <<MatchChar, Rest/binary>>). --define(BYTE_ORDER_MARK_1, undefined_bom1). --define(BYTE_ORDER_MARK_2, undefined_bom2). --define(BYTE_ORDER_MARK_REST(Rest), <<undefined, Rest/binary>>). + +-define(PARSE_BYTE_ORDER_MARK(Bytes, State), + parse_byte_order_mark(Bytes, State) -> + parse_xml_decl(Bytes, State)). + +-define(PARSE_XML_DECL(Bytes, State), + parse_xml_decl(Bytes, #xmerl_sax_parser_state{encoding=Enc} = State) when is_binary(Bytes) -> + case unicode:characters_to_list(Bytes, Enc) of + {incomplete, _, _} -> + cf(Bytes, State, fun parse_xml_decl/2); + {error, _Encoded, _Rest} -> + ?fatal_error(State, lists:flatten(io_lib:format("Bad character, not in ~p\n", [Enc]))); + _ -> + parse_prolog(Bytes, State) + end; + parse_xml_decl(Bytes, State) -> + parse_prolog(Bytes, State)). + +-define(WHITESPACE(Bytes, State, Acc), + whitespace(?STRING_UNBOUND_REST(_C, _) = Bytes, State, Acc) -> + {lists:reverse(Acc), Bytes, State}; + whitespace(Bytes, #xmerl_sax_parser_state{encoding=Enc} = State, Acc) when is_binary(Bytes) -> + case unicode:characters_to_list(Bytes, Enc) of + {incomplete, _, _} -> + cf(Bytes, State, Acc, fun whitespace/3); + {error, _Encoded, _Rest} -> + ?fatal_error(State, lists:flatten(io_lib:format("Bad character, not in ~p\n", [Enc]))) + end). + +-define(PARSE_EXTERNAL_ENTITY_BYTE_ORDER_MARK(Bytes, State), + parse_external_entity_byte_order_mark(Bytes, State) -> + parse_external_entity_1(Bytes, State)). diff --git a/lib/xmerl/src/xmerl_sax_parser_list.erlsrc b/lib/xmerl/src/xmerl_sax_parser_list.erlsrc index 624a621d92..6a4435b1d9 100644 --- a/lib/xmerl/src/xmerl_sax_parser_list.erlsrc +++ b/lib/xmerl/src/xmerl_sax_parser_list.erlsrc @@ -36,6 +36,19 @@ %% In the list case we can't use a '++' when matchin against an unbound variable -define(STRING_UNBOUND_REST(MatchChar, Rest), [MatchChar | Rest]). --define(BYTE_ORDER_MARK_1, undefined_bom1). --define(BYTE_ORDER_MARK_2, undefined_bom2). --define(BYTE_ORDER_MARK_REST(Rest), [undefined|Rest]). + +-define(PARSE_BYTE_ORDER_MARK(Bytes, State), + parse_byte_order_mark(Bytes, State) -> + parse_xml_decl(Bytes, State)). + +-define(PARSE_XML_DECL(Bytes, State), + parse_xml_decl(Bytes, State) -> + parse_prolog(Bytes, State)). + +-define(WHITESPACE(Bytes, State, Acc), + whitespace(?STRING_UNBOUND_REST(_C, _) = Bytes, State, Acc) -> + {lists:reverse(Acc), Bytes, State}). + +-define(PARSE_EXTERNAL_ENTITY_BYTE_ORDER_MARK(Bytes, State), + parse_external_entity_byte_order_mark(Bytes, State) -> + parse_external_entity_1(Bytes, State)). diff --git a/lib/xmerl/src/xmerl_sax_parser_utf16be.erlsrc b/lib/xmerl/src/xmerl_sax_parser_utf16be.erlsrc index ff84ece97a..ec89024729 100644 --- a/lib/xmerl/src/xmerl_sax_parser_utf16be.erlsrc +++ b/lib/xmerl/src/xmerl_sax_parser_utf16be.erlsrc @@ -2,7 +2,7 @@ %%-------------------------------------------------------------------- %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2008-2016. All Rights Reserved. +%% Copyright Ericsson AB 2008-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -34,8 +34,50 @@ -define(APPEND_STRING(Rest, New), <<Rest/binary, New/binary>>). -define(TO_INPUT_FORMAT(Val), unicode:characters_to_binary(Val, unicode, {utf16, big})). -%% STRING_REST and STRING_UNBOUND_REST is only different in the list case -define(STRING_UNBOUND_REST(MatchChar, Rest), <<MatchChar/big-utf16, Rest/binary>>). --define(BYTE_ORDER_MARK_1, undefined_bom1). --define(BYTE_ORDER_MARK_2, <<16#FE>>). +-define(BYTE_ORDER_MARK_1, <<16#FE>>). -define(BYTE_ORDER_MARK_REST(Rest), <<16#FE, 16#FF, Rest/binary>>). + +-define(PARSE_BYTE_ORDER_MARK(Bytes, State), + parse_byte_order_mark(?STRING_EMPTY, State) -> + cf(?STRING_EMPTY, State, fun parse_byte_order_mark/2); + parse_byte_order_mark(?BYTE_ORDER_MARK_1, State) -> + cf(?BYTE_ORDER_MARK_1, State, fun parse_byte_order_mark/2); + parse_byte_order_mark(?BYTE_ORDER_MARK_REST(Rest), State) -> + parse_xml_decl(Rest, State); + parse_byte_order_mark(Bytes, State) -> + parse_xml_decl(Bytes, State)). + +-define(PARSE_XML_DECL(Bytes, State), + parse_xml_decl(Bytes, #xmerl_sax_parser_state{encoding=Enc} = State) when is_binary(Bytes) -> + case unicode:characters_to_list(Bytes, Enc) of + {incomplete, _, _} -> + cf(Bytes, State, fun parse_xml_decl/2); + {error, _Encoded, _Rest} -> + ?fatal_error(State, lists:flatten(io_lib:format("Bad character, not in ~p\n", [Enc]))); + _ -> + parse_prolog(Bytes, State) + end; + parse_xml_decl(Bytes, State) -> + parse_prolog(Bytes, State)). + +-define(WHITESPACE(Bytes, State, Acc), + whitespace(?STRING_UNBOUND_REST(_C, _) = Bytes, State, Acc) -> + {lists:reverse(Acc), Bytes, State}; + whitespace(Bytes, #xmerl_sax_parser_state{encoding=Enc} = State, Acc) when is_binary(Bytes) -> + case unicode:characters_to_list(Bytes, Enc) of + {incomplete, _, _} -> + cf(Bytes, State, Acc, fun whitespace/3); + {error, _Encoded, _Rest} -> + ?fatal_error(State, lists:flatten(io_lib:format("Bad character, not in ~p\n", [Enc]))) + end). + +-define(PARSE_EXTERNAL_ENTITY_BYTE_ORDER_MARK(Bytes, State), + parse_external_entity_byte_order_mark(?STRING_EMPTY, State) -> + cf(?STRING_EMPTY, State, fun parse_external_entity_byte_order_mark/2); + parse_external_entity_byte_order_mark(?BYTE_ORDER_MARK_1, State) -> + cf(?BYTE_ORDER_MARK_1, State, fun parse_external_entity_byte_order_mark/2); + parse_external_entity_byte_order_mark(?BYTE_ORDER_MARK_REST(Rest), State) -> + parse_external_entity_1(Rest, State); + parse_external_entity_byte_order_mark(Bytes, State) -> + parse_external_entity_1(Bytes, State)). diff --git a/lib/xmerl/src/xmerl_sax_parser_utf16le.erlsrc b/lib/xmerl/src/xmerl_sax_parser_utf16le.erlsrc index a330fce8d0..566333a045 100644 --- a/lib/xmerl/src/xmerl_sax_parser_utf16le.erlsrc +++ b/lib/xmerl/src/xmerl_sax_parser_utf16le.erlsrc @@ -2,7 +2,7 @@ %%-------------------------------------------------------------------- %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2008-2016. All Rights Reserved. +%% Copyright Ericsson AB 2008-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -34,8 +34,50 @@ -define(APPEND_STRING(Rest, New), <<Rest/binary, New/binary>>). -define(TO_INPUT_FORMAT(Val), unicode:characters_to_binary(Val, unicode, {utf16, little})). -%% STRING_REST and STRING_UNBOUND_REST is only different in the list case -define(STRING_UNBOUND_REST(MatchChar, Rest), <<MatchChar/little-utf16, Rest/binary>>). --define(BYTE_ORDER_MARK_1, undefined_bom1). --define(BYTE_ORDER_MARK_2, <<16#FF>>). +-define(BYTE_ORDER_MARK_1, <<16#FF>>). -define(BYTE_ORDER_MARK_REST(Rest), <<16#FF, 16#FE, Rest/binary>>). + +-define(PARSE_BYTE_ORDER_MARK(Bytes, State), + parse_byte_order_mark(?STRING_EMPTY, State) -> + cf(?STRING_EMPTY, State, fun parse_byte_order_mark/2); + parse_byte_order_mark(?BYTE_ORDER_MARK_1, State) -> + cf(?BYTE_ORDER_MARK_1, State, fun parse_byte_order_mark/2); + parse_byte_order_mark(?BYTE_ORDER_MARK_REST(Rest), State) -> + parse_xml_decl(Rest, State); + parse_byte_order_mark(Bytes, State) -> + parse_xml_decl(Bytes, State)). + +-define(PARSE_XML_DECL(Bytes, State), + parse_xml_decl(Bytes, #xmerl_sax_parser_state{encoding=Enc} = State) when is_binary(Bytes) -> + case unicode:characters_to_list(Bytes, Enc) of + {incomplete, _, _} -> + cf(Bytes, State, fun parse_xml_decl/2); + {error, _Encoded, _Rest} -> + ?fatal_error(State, lists:flatten(io_lib:format("Bad character, not in ~p\n", [Enc]))); + _ -> + parse_prolog(Bytes, State) + end; + parse_xml_decl(Bytes, State) -> + parse_prolog(Bytes, State)). + +-define(WHITESPACE(Bytes, State, Acc), + whitespace(?STRING_UNBOUND_REST(_C, _) = Bytes, State, Acc) -> + {lists:reverse(Acc), Bytes, State}; + whitespace(Bytes, #xmerl_sax_parser_state{encoding=Enc} = State, Acc) when is_binary(Bytes) -> + case unicode:characters_to_list(Bytes, Enc) of + {incomplete, _, _} -> + cf(Bytes, State, Acc, fun whitespace/3); + {error, _Encoded, _Rest} -> + ?fatal_error(State, lists:flatten(io_lib:format("Bad character, not in ~p\n", [Enc]))) + end). + +-define(PARSE_EXTERNAL_ENTITY_BYTE_ORDER_MARK(Bytes, State), + parse_external_entity_byte_order_mark(?STRING_EMPTY, State) -> + cf(?STRING_EMPTY, State, fun parse_external_entity_byte_order_mark/2); + parse_external_entity_byte_order_mark(?BYTE_ORDER_MARK_1, State) -> + cf(?BYTE_ORDER_MARK_1, State, fun parse_external_entity_byte_order_mark/2); + parse_external_entity_byte_order_mark(?BYTE_ORDER_MARK_REST(Rest), State) -> + parse_external_entity_1(Rest, State); + parse_external_entity_byte_order_mark(Bytes, State) -> + parse_external_entity_1(Bytes, State)). diff --git a/lib/xmerl/src/xmerl_sax_parser_utf8.erlsrc b/lib/xmerl/src/xmerl_sax_parser_utf8.erlsrc index d46d60d237..f41d06d013 100644 --- a/lib/xmerl/src/xmerl_sax_parser_utf8.erlsrc +++ b/lib/xmerl/src/xmerl_sax_parser_utf8.erlsrc @@ -2,7 +2,7 @@ %%-------------------------------------------------------------------- %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2008-2016. All Rights Reserved. +%% Copyright Ericsson AB 2008-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -34,11 +34,55 @@ -define(APPEND_STRING(Rest, New), <<Rest/binary, New/binary>>). -define(TO_INPUT_FORMAT(Val), unicode:characters_to_binary(Val, unicode, utf8)). - -%% STRING_REST and STRING_UNBOUND_REST is only different in the list case -define(STRING_UNBOUND_REST(MatchChar, Rest), <<MatchChar/utf8, Rest/binary>>). -define(BYTE_ORDER_MARK_1, <<16#EF>>). -define(BYTE_ORDER_MARK_2, <<16#EF, 16#BB>>). -define(BYTE_ORDER_MARK_REST(Rest), <<16#EF, 16#BB, 16#BF, Rest/binary>>). +-define(PARSE_BYTE_ORDER_MARK(Bytes, State), + parse_byte_order_mark(?STRING_EMPTY, State) -> + cf(?STRING_EMPTY, State, fun parse_byte_order_mark/2); + parse_byte_order_mark(?BYTE_ORDER_MARK_1, State) -> + cf(?BYTE_ORDER_MARK_1, State, fun parse_byte_order_mark/2); + parse_byte_order_mark(?BYTE_ORDER_MARK_2, State) -> + cf(?BYTE_ORDER_MARK_2, State, fun parse_byte_order_mark/2); + parse_byte_order_mark(?BYTE_ORDER_MARK_REST(Rest), State) -> + parse_xml_decl(Rest, State); + parse_byte_order_mark(Bytes, State) -> + parse_xml_decl(Bytes, State)). + +-define(PARSE_XML_DECL(Bytes, State), + parse_xml_decl(Bytes, #xmerl_sax_parser_state{encoding=Enc} = State) when is_binary(Bytes) -> + case unicode:characters_to_list(Bytes, Enc) of + {incomplete, _, _} -> + cf(Bytes, State, fun parse_xml_decl/2); + {error, _Encoded, _Rest} -> + ?fatal_error(State, lists:flatten(io_lib:format("Bad character, not in ~p\n", [Enc]))); + _ -> + parse_prolog(Bytes, State) + end; + parse_xml_decl(Bytes, State) -> + parse_prolog(Bytes, State)). + +-define(WHITESPACE(Bytes, State, Acc), + whitespace(?STRING_UNBOUND_REST(_C, _) = Bytes, State, Acc) -> + {lists:reverse(Acc), Bytes, State}; + whitespace(Bytes, #xmerl_sax_parser_state{encoding=Enc} = State, Acc) when is_binary(Bytes) -> + case unicode:characters_to_list(Bytes, Enc) of + {incomplete, _, _} -> + cf(Bytes, State, Acc, fun whitespace/3); + {error, _Encoded, _Rest} -> + ?fatal_error(State, lists:flatten(io_lib:format("Bad character, not in ~p\n", [Enc]))) + end). +-define(PARSE_EXTERNAL_ENTITY_BYTE_ORDER_MARK(Bytes, State), + parse_external_entity_byte_order_mark(?STRING_EMPTY, State) -> + cf(?STRING_EMPTY, State, fun parse_external_entity_byte_order_mark/2); + parse_external_entity_byte_order_mark(?BYTE_ORDER_MARK_1, State) -> + cf(?BYTE_ORDER_MARK_1, State, fun parse_external_entity_byte_order_mark/2); + parse_external_entity_byte_order_mark(?BYTE_ORDER_MARK_2, State) -> + cf(?BYTE_ORDER_MARK_2, State, fun parse_external_entity_byte_order_mark/2); + parse_external_entity_byte_order_mark(?BYTE_ORDER_MARK_REST(Rest), State) -> + parse_external_entity_1(Rest, State); + parse_external_entity_byte_order_mark(Bytes, State) -> + parse_external_entity_1(Bytes, State)). diff --git a/lib/xmerl/src/xmerl_scan.erl b/lib/xmerl/src/xmerl_scan.erl index 9f6b27113e..95dc82e5c9 100644 --- a/lib/xmerl/src/xmerl_scan.erl +++ b/lib/xmerl/src/xmerl_scan.erl @@ -2309,7 +2309,9 @@ expanded_name(Name, [], #xmlNamespace{default = URI}, S) -> expanded_name(Name, N = {"xmlns", Local}, #xmlNamespace{nodes = Ns}, S) -> {_, Value} = lists:keyfind(Local, 1, Ns), case Name of - 'xmlns:xml' when Value =/= 'http://www.w3.org/XML/1998/namespace' -> + 'xmlns:xml' when Value =:= 'http://www.w3.org/XML/1998/namespace' -> + N; + 'xmlns:xml' when Value =/= 'http://www.w3.org/XML/1998/namespace' -> ?fatal({xml_prefix_cannot_be_redeclared, Value}, S); 'xmlns:xmlns' -> ?fatal({xmlns_prefix_cannot_be_declared, Value}, S); @@ -2323,6 +2325,8 @@ expanded_name(Name, N = {"xmlns", Local}, #xmlNamespace{nodes = Ns}, S) -> N end end; +expanded_name(_Name, {"xml", Local}, _NS, _S) -> + {'http://www.w3.org/XML/1998/namespace', list_to_atom(Local)}; expanded_name(_Name, {Prefix, Local}, #xmlNamespace{nodes = Ns}, S) -> case lists:keysearch(Prefix, 1, Ns) of {value, {_, URI}} -> @@ -2333,9 +2337,6 @@ expanded_name(_Name, {Prefix, Local}, #xmlNamespace{nodes = Ns}, S) -> ?fatal({namespace_prefix_not_declared, Prefix}, S) end. - - - keyreplaceadd(K, Pos, [H|T], Obj) when K == element(Pos, H) -> [Obj|T]; keyreplaceadd(K, Pos, [H|T], Obj) -> diff --git a/lib/xmerl/test/Makefile b/lib/xmerl/test/Makefile index 7a326e334f..b13fee05b3 100644 --- a/lib/xmerl/test/Makefile +++ b/lib/xmerl/test/Makefile @@ -55,7 +55,8 @@ SUITE_FILES= \ xmerl_xsd_SUITE.erl \ xmerl_xsd_MS2002-01-16_SUITE.erl \ xmerl_xsd_NIST2002-01-16_SUITE.erl \ - xmerl_xsd_Sun2002-01-16_SUITE.erl + xmerl_xsd_Sun2002-01-16_SUITE.erl \ + xmerl_sax_stream_SUITE.erl XML_FILES= \ testcases.dtd \ @@ -125,4 +126,5 @@ release_tests_spec: opt @tar cfh - xmerl_xsd_MS2002-01-16_SUITE_data | (cd "$(RELSYSDIR)"; tar xf -) @tar cfh - xmerl_xsd_NIST2002-01-16_SUITE_data | (cd "$(RELSYSDIR)"; tar xf -) @tar cfh - xmerl_xsd_Sun2002-01-16_SUITE_data | (cd "$(RELSYSDIR)"; tar xf -) + @tar cfh - xmerl_sax_stream_SUITE_data | (cd "$(RELSYSDIR)"; tar xf -) chmod -R u+w "$(RELSYSDIR)" diff --git a/lib/xmerl/test/xmerl_SUITE.erl b/lib/xmerl/test/xmerl_SUITE.erl index cf7c0b7548..58c462483c 100644 --- a/lib/xmerl/test/xmerl_SUITE.erl +++ b/lib/xmerl/test/xmerl_SUITE.erl @@ -55,7 +55,7 @@ groups() -> {misc, [], [latin1_alias, syntax_bug1, syntax_bug2, syntax_bug3, pe_ref1, copyright, testXSEIF, export_simple1, export, - default_attrs_bug]}, + default_attrs_bug, xml_ns]}, {eventp_tests, [], [sax_parse_and_export]}, {ticket_tests, [], [ticket_5998, ticket_7211, ticket_7214, ticket_7430, @@ -237,7 +237,36 @@ default_attrs_bug(Config) -> {#xmlElement{attributes = [#xmlAttribute{name = b, value = "also explicit"}, #xmlAttribute{name = a, value = "explicit"}]}, [] - } = xmerl_scan:string(Doc2, [{default_attrs, true}]). + } = xmerl_scan:string(Doc2, [{default_attrs, true}]), + ok. + + +xml_ns(Config) -> + Doc = "<?xml version='1.0'?>\n" + "<doc xml:attr1=\"implicit xml ns\"/>", + {#xmlElement{namespace=#xmlNamespace{default = [], nodes = []}, + attributes = [#xmlAttribute{name = 'xml:attr1', + expanded_name = {'http://www.w3.org/XML/1998/namespace',attr1}, + nsinfo = {"xml","attr1"}, + namespace = #xmlNamespace{default = [], nodes = []}}]}, + [] + } = xmerl_scan:string(Doc, [{namespace_conformant, true}]), + Doc2 = "<?xml version='1.0'?>\n" + "<doc xmlns:xml=\"http://www.w3.org/XML/1998/namespace\" xml:attr1=\"explicit xml ns\"/>", + {#xmlElement{namespace=#xmlNamespace{default = [], nodes = [{"xml",'http://www.w3.org/XML/1998/namespace'}]}, + attributes = [#xmlAttribute{name = 'xmlns:xml', + expanded_name = {"xmlns","xml"}, + nsinfo = {"xmlns","xml"}, + namespace = #xmlNamespace{default = [], + nodes = [{"xml",'http://www.w3.org/XML/1998/namespace'}]}}, + #xmlAttribute{name = 'xml:attr1', + expanded_name = {'http://www.w3.org/XML/1998/namespace',attr1}, + nsinfo = {"xml","attr1"}, + namespace = #xmlNamespace{default = [], + nodes = [{"xml",'http://www.w3.org/XML/1998/namespace'}]}}]}, + [] + } = xmerl_scan:string(Doc2, [{namespace_conformant, true}]), + ok. pe_ref1(Config) -> file:set_cwd(datadir(Config)), diff --git a/lib/xmerl/test/xmerl_sax_SUITE.erl b/lib/xmerl/test/xmerl_sax_SUITE.erl index f5c0a783c4..7d1a70905c 100644 --- a/lib/xmerl/test/xmerl_sax_SUITE.erl +++ b/lib/xmerl/test/xmerl_sax_SUITE.erl @@ -85,17 +85,17 @@ ticket_11551(_Config) -> <a>hej</a> <?xml version=\"1.0\" encoding=\"utf-8\" ?> <a>hej</a>">>, - {ok, undefined, <<"<?xml", _/binary>>} = xmerl_sax_parser:stream(Stream1, []), + {ok, undefined, <<"\n<?xml", _/binary>>} = xmerl_sax_parser:stream(Stream1, []), Stream2= <<"<?xml version=\"1.0\" encoding=\"utf-8\" ?> <a>hej</a> <?xml version=\"1.0\" encoding=\"utf-8\" ?> <a>hej</a>">>, - {ok, undefined, <<"<?xml", _/binary>>} = xmerl_sax_parser:stream(Stream2, []), + {ok, undefined, <<"\n\n\n<?xml", _/binary>>} = xmerl_sax_parser:stream(Stream2, []), Stream3= <<"<a>hej</a> <?xml version=\"1.0\" encoding=\"utf-8\" ?> <a>hej</a>">>, - {ok, undefined, <<"<?xml", _/binary>>} = xmerl_sax_parser:stream(Stream3, []), + {ok, undefined, <<"\n\n<?xml", _/binary>>} = xmerl_sax_parser:stream(Stream3, []), ok. diff --git a/lib/xmerl/test/xmerl_sax_std_SUITE.erl b/lib/xmerl/test/xmerl_sax_std_SUITE.erl index 525a3b175a..b8412206cc 100644 --- a/lib/xmerl/test/xmerl_sax_std_SUITE.erl +++ b/lib/xmerl/test/xmerl_sax_std_SUITE.erl @@ -2,7 +2,7 @@ %%---------------------------------------------------------------------- %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2010-2016. All Rights Reserved. +%% Copyright Ericsson AB 2010-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -507,11 +507,8 @@ end_per_testcase(_Func,_Config) -> 'not-wf-sa-036'(Config) -> file:set_cwd(xmerl_test_lib:get_data_dir(Config)), Path = filename:join([xmerl_test_lib:get_data_dir(Config),"xmltest","not-wf/sa/036.xml"]), - %% Special case becase we returns everything after a legal document - %% as an rest instead of giving and error to let the user handle - %% multipple docs on a stream. - {ok,_,<<"Illegal data\r\n">>} = xmerl_sax_parser:file(Path, [{event_fun, fun(_,_,S) -> S end}]). - %%check_result(R, "not-wf"). + R = xmerl_sax_parser:file(Path, [{event_fun, fun(_,_,S) -> S end}]), + check_result(R, "not-wf"). %%---------------------------------------------------------------------- %% Test Case @@ -522,11 +519,8 @@ end_per_testcase(_Func,_Config) -> 'not-wf-sa-037'(Config) -> file:set_cwd(xmerl_test_lib:get_data_dir(Config)), Path = filename:join([xmerl_test_lib:get_data_dir(Config),"xmltest","not-wf/sa/037.xml"]), - %% Special case becase we returns everything after a legal document - %% as an rest instead of giving and error to let the user handle - %% multipple docs on a stream. - {ok,_,<<" \r\n">>} = xmerl_sax_parser:file(Path, [{event_fun, fun(_,_,S) -> S end}]). - %%check_result(R, "not-wf"). + R = xmerl_sax_parser:file(Path, [{event_fun, fun(_,_,S) -> S end}]), + check_result(R, "not-wf"). %%---------------------------------------------------------------------- %% Test Case @@ -561,11 +555,8 @@ end_per_testcase(_Func,_Config) -> 'not-wf-sa-040'(Config) -> file:set_cwd(xmerl_test_lib:get_data_dir(Config)), Path = filename:join([xmerl_test_lib:get_data_dir(Config),"xmltest","not-wf/sa/040.xml"]), - %% Special case becase we returns everything after a legal document - %% as an rest instead of giving and error to let the user handle - %% multipple docs on a stream. - {ok,_,<<"<doc></doc>\r\n">>} = xmerl_sax_parser:file(Path, [{event_fun, fun(_,_,S) -> S end}]). - %%check_result(R, "not-wf"). + R = xmerl_sax_parser:file(Path, [{event_fun, fun(_,_,S) -> S end}]), + check_result(R, "not-wf"). %%---------------------------------------------------------------------- %% Test Case @@ -576,11 +567,8 @@ end_per_testcase(_Func,_Config) -> 'not-wf-sa-041'(Config) -> file:set_cwd(xmerl_test_lib:get_data_dir(Config)), Path = filename:join([xmerl_test_lib:get_data_dir(Config),"xmltest","not-wf/sa/041.xml"]), - %% Special case becase we returns everything after a legal document - %% as an rest instead of giving and error to let the user handle - %% multipple docs on a stream. - {ok,_,<<"<doc></doc>\r\n">>} = xmerl_sax_parser:file(Path, [{event_fun, fun(_,_,S) -> S end}]). - %%check_result(R, "not-wf"). + R = xmerl_sax_parser:file(Path, [{event_fun, fun(_,_,S) -> S end}]), + check_result(R, "not-wf"). %%---------------------------------------------------------------------- %% Test Case @@ -603,11 +591,8 @@ end_per_testcase(_Func,_Config) -> 'not-wf-sa-043'(Config) -> file:set_cwd(xmerl_test_lib:get_data_dir(Config)), Path = filename:join([xmerl_test_lib:get_data_dir(Config),"xmltest","not-wf/sa/043.xml"]), - %% Special case becase we returns everything after a legal document - %% as an rest instead of giving and error to let the user handle - %% multipple docs on a stream. - {ok,_,<<"Illegal data\r\n">>} = xmerl_sax_parser:file(Path, [{event_fun, fun(_,_,S) -> S end}]). - %%check_result(R, "not-wf"). + R = xmerl_sax_parser:file(Path, [{event_fun, fun(_,_,S) -> S end}]), + check_result(R, "not-wf"). %%---------------------------------------------------------------------- %% Test Case @@ -618,11 +603,8 @@ end_per_testcase(_Func,_Config) -> 'not-wf-sa-044'(Config) -> file:set_cwd(xmerl_test_lib:get_data_dir(Config)), Path = filename:join([xmerl_test_lib:get_data_dir(Config),"xmltest","not-wf/sa/044.xml"]), - %% Special case becase we returns everything after a legal document - %% as an rest instead of giving and error to let the user handle - %% multipple docs on a stream. - {ok,_,<<"<doc/>\r\n">>} = xmerl_sax_parser:file(Path, [{event_fun, fun(_,_,S) -> S end}]). - %%check_result(R, "not-wf"). + R = xmerl_sax_parser:file(Path, [{event_fun, fun(_,_,S) -> S end}]), + check_result(R, "not-wf"). %%---------------------------------------------------------------------- %% Test Case @@ -669,11 +651,8 @@ end_per_testcase(_Func,_Config) -> 'not-wf-sa-048'(Config) -> file:set_cwd(xmerl_test_lib:get_data_dir(Config)), Path = filename:join([xmerl_test_lib:get_data_dir(Config),"xmltest","not-wf/sa/048.xml"]), - %% Special case becase we returns everything after a legal document - %% as an rest instead of giving and error to let the user handle - %% multipple docs on a stream. - {ok,_,<<"<![CDATA[]]>\r\n">>} = xmerl_sax_parser:file(Path, [{event_fun, fun(_,_,S) -> S end}]). - %%check_result(R, "not-wf"). + R = xmerl_sax_parser:file(Path, [{event_fun, fun(_,_,S) -> S end}]), + check_result(R, "not-wf"). %%---------------------------------------------------------------------- %% Test Case @@ -1416,11 +1395,8 @@ end_per_testcase(_Func,_Config) -> 'not-wf-sa-110'(Config) -> file:set_cwd(xmerl_test_lib:get_data_dir(Config)), Path = filename:join([xmerl_test_lib:get_data_dir(Config),"xmltest","not-wf/sa/110.xml"]), - %% Special case becase we returns everything after a legal document - %% as an rest instead of giving and error to let the user handle - %% multipple docs on a stream. - {ok,_,<<"&e;\r\n">>} = xmerl_sax_parser:file(Path, [{event_fun, fun(_,_,S) -> S end}]). - %%check_result(R, "not-wf"). + R = xmerl_sax_parser:file(Path, [{event_fun, fun(_,_,S) -> S end}]), + check_result(R, "not-wf"). %%---------------------------------------------------------------------- %% Test Case @@ -1914,9 +1890,9 @@ end_per_testcase(_Func,_Config) -> %% Special case becase we returns everything after a legal document %% as an rest instead of giving and error to let the user handle %% multipple docs on a stream. - {ok,_,<<"<?xml version=\"1.0\"?>\r\n">>} = xmerl_sax_parser:file(Path, [{event_fun, fun(_,_,S) -> S end}]). - % R = xmerl_sax_parser:file(Path, [{event_fun, fun(_,_,S) -> S end}]), - % check_result(R, "not-wf"). + %{ok,_,<<"<?xml version=\"1.0\"?>\r\n">>} = xmerl_sax_parser:file(Path, [{event_fun, fun(_,_,S) -> S end}]). + R = xmerl_sax_parser:file(Path, [{event_fun, fun(_,_,S) -> S end}]), + check_result(R, "not-wf"). %%---------------------------------------------------------------------- %% Test Case @@ -7784,11 +7760,8 @@ end_per_testcase(_Func,_Config) -> 'o-p01fail3'(Config) -> file:set_cwd(xmerl_test_lib:get_data_dir(Config)), Path = filename:join([xmerl_test_lib:get_data_dir(Config),"oasis","p01fail3.xml"]), - %% Special case becase we returns everything after a legal document - %% as an rest instead of giving and error to let the user handle - %% multipple docs on a stream. - {ok,_, <<"<bad/>", _/binary>>} = xmerl_sax_parser:file(Path, [{event_fun, fun(_,_,S) -> S end}]). - %%check_result(R, "not-wf"). + R = xmerl_sax_parser:file(Path, [{event_fun, fun(_,_,S) -> S end}]), + check_result(R, "not-wf"). %%---------------------------------------------------------------------- %% Test Case @@ -11417,12 +11390,8 @@ end_per_testcase(_Func,_Config) -> 'ibm-not-wf-P01-ibm01n02'(Config) -> file:set_cwd(xmerl_test_lib:get_data_dir(Config)), Path = filename:join([xmerl_test_lib:get_data_dir(Config),"ibm","not-wf/P01/ibm01n02.xml"]), - %% Special case becase we returns everything after a legal document - %% as an rest instead of giving and error to let the user handle - %% multipple docs on a stream. - {ok,_, <<"<?xml version=\"1.0\"?>", _/binary>>} = xmerl_sax_parser:file(Path, [{event_fun, fun(_,_,S) -> S end}]). - % R = xmerl_sax_parser:file(Path, [{event_fun, fun(_,_,S) -> S end}]), - % check_result(R, "not-wf"). + R = xmerl_sax_parser:file(Path, [{event_fun, fun(_,_,S) -> S end}]), + check_result(R, "not-wf"). %%---------------------------------------------------------------------- %% Test Case @@ -11433,11 +11402,8 @@ end_per_testcase(_Func,_Config) -> 'ibm-not-wf-P01-ibm01n03'(Config) -> file:set_cwd(xmerl_test_lib:get_data_dir(Config)), Path = filename:join([xmerl_test_lib:get_data_dir(Config),"ibm","not-wf/P01/ibm01n03.xml"]), - %% Special case becase we returns everything after a legal document - %% as an rest instead of giving and error to let the user handle - %% multipple docs on a stream. - {ok,_, <<"<title>Wrong combination!</title>", _/binary>>} = xmerl_sax_parser:file(Path, [{event_fun, fun(_,_,S) -> S end}]). - %%check_result(R, "not-wf"). + R = xmerl_sax_parser:file(Path, [{event_fun, fun(_,_,S) -> S end}]), + check_result(R, "not-wf"). %%---------------------------------------------------------------------- %% Test Cases @@ -13027,11 +12993,8 @@ end_per_testcase(_Func,_Config) -> 'ibm-not-wf-P27-ibm27n01'(Config) -> file:set_cwd(xmerl_test_lib:get_data_dir(Config)), Path = filename:join([xmerl_test_lib:get_data_dir(Config),"ibm","not-wf/P27/ibm27n01.xml"]), - %% Special case becase we returns everything after a legal document - %% as an rest instead of giving and error to let the user handle - %% multipple docs on a stream. - {ok,_, <<"<!ELEMENT cat EMPTY>">>} = xmerl_sax_parser:file(Path, [{event_fun, fun(_,_,S) -> S end}]). - %%check_result(R, "not-wf"). + R = xmerl_sax_parser:file(Path, [{event_fun, fun(_,_,S) -> S end}]), + check_result(R, "not-wf"). %%---------------------------------------------------------------------- %% Test Cases @@ -13461,11 +13424,8 @@ end_per_testcase(_Func,_Config) -> 'ibm-not-wf-P39-ibm39n06'(Config) -> file:set_cwd(xmerl_test_lib:get_data_dir(Config)), Path = filename:join([xmerl_test_lib:get_data_dir(Config),"ibm","not-wf/P39/ibm39n06.xml"]), - %% Special case becase we returns everything after a legal document - %% as an rest instead of giving and error to let the user handle - %% multipple docs on a stream. - {ok,_,<<"content after end tag\r\n">>} = xmerl_sax_parser:file(Path, [{event_fun, fun(_,_,S) -> S end}]). - %%check_result(R, "not-wf"). + R = xmerl_sax_parser:file(Path, [{event_fun, fun(_,_,S) -> S end}]), + check_result(R, "not-wf"). %%---------------------------------------------------------------------- %% Test Cases diff --git a/lib/xmerl/test/xmerl_sax_stream_SUITE.erl b/lib/xmerl/test/xmerl_sax_stream_SUITE.erl new file mode 100644 index 0000000000..a306eb66a2 --- /dev/null +++ b/lib/xmerl/test/xmerl_sax_stream_SUITE.erl @@ -0,0 +1,245 @@ +%%-*-erlang-*- +%%---------------------------------------------------------------------- +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2017. All Rights Reserved. +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. +%% +%% %CopyrightEnd% +%%---------------------------------------------------------------------- +%% File : xmerl_sax_stream_SUITE.erl +%%---------------------------------------------------------------------- +-module(xmerl_sax_stream_SUITE). +-compile(export_all). + +%%---------------------------------------------------------------------- +%% Include files +%%---------------------------------------------------------------------- +-include_lib("common_test/include/ct.hrl"). +-include_lib("kernel/include/file.hrl"). + +%%====================================================================== +%% External functions +%%====================================================================== + +%%---------------------------------------------------------------------- +%% Initializations +%%---------------------------------------------------------------------- +all() -> + [ + one_document, + two_documents, + one_document_and_junk + ]. + +%%---------------------------------------------------------------------- +%% Initializations +%%---------------------------------------------------------------------- + +init_per_suite(Config) -> + Config. + +end_per_suite(_Config) -> + ok. + +init_per_testcase(_TestCase, Config) -> + Config. + +end_per_testcase(_Func, _Config) -> + ok. + +%%---------------------------------------------------------------------- +%% Tests +%%---------------------------------------------------------------------- +one_document(Config) -> + Port = 11111, + + {ok, ListenSocket} = listen(Port), + Self = self(), + + spawn( + fun() -> + case catch gen_tcp:accept(ListenSocket) of + {ok, S} -> + Result = xmerl_sax_parser:stream(<<>>, + [{continuation_state, S}, + {continuation_fun, + fun(Sd) -> + io:format("Continuation called!!", []), + case gen_tcp:recv(Sd, 0) of + {ok, Packet} -> + io:format("Packet: ~p\n", [Packet]), + {Packet, Sd}; + {error, Reason} -> + throw({error, Reason}) + end + end}]), + Self ! {xmerl_sax, Result}, + close(S); + Error -> + Self ! {xmerl_sax, {error, {accept, Error}}} + end + end), + + {ok, SendSocket} = connect(localhost, Port), + + {ok, Binary} = file:read_file(filename:join([datadir(Config), "xmerl_sax_stream_one.xml"])), + + send_chunks(SendSocket, Binary), + + receive + {xmerl_sax, {ok, undefined, Rest}} -> + <<"\n">> = Rest, + io:format("Ok Rest: ~p\n", [Rest]) + after 5000 -> + ct:fail("Timeout") + end, + ok. + +two_documents(Config) -> + Port = 11111, + + {ok, ListenSocket} = listen(Port), + Self = self(), + + spawn( + fun() -> + case catch gen_tcp:accept(ListenSocket) of + {ok, S} -> + Result = xmerl_sax_parser:stream(<<>>, + [{continuation_state, S}, + {continuation_fun, + fun(Sd) -> + io:format("Continuation called!!", []), + case gen_tcp:recv(Sd, 0) of + {ok, Packet} -> + io:format("Packet: ~p\n", [Packet]), + {Packet, Sd}; + {error, Reason} -> + throw({error, Reason}) + end + end}]), + Self ! {xmerl_sax, Result}, + close(S); + Error -> + Self ! {xmerl_sax, {error, {accept, Error}}} + end + end), + + {ok, SendSocket} = connect(localhost, Port), + + {ok, Binary} = file:read_file(filename:join([datadir(Config), "xmerl_sax_stream_two.xml"])), + + send_chunks(SendSocket, Binary), + + receive + {xmerl_sax, {ok, undefined, Rest}} -> + <<"\n<?x", _R/binary>> = Rest, + io:format("Ok Rest: ~p\n", [Rest]) + after 5000 -> + ct:fail("Timeout") + end, + ok. + +one_document_and_junk(Config) -> + Port = 11111, + + {ok, ListenSocket} = listen(Port), + Self = self(), + + spawn( + fun() -> + case catch gen_tcp:accept(ListenSocket) of + {ok, S} -> + Result = xmerl_sax_parser:stream(<<>>, + [{continuation_state, S}, + {continuation_fun, + fun(Sd) -> + io:format("Continuation called!!", []), + case gen_tcp:recv(Sd, 0) of + {ok, Packet} -> + io:format("Packet: ~p\n", [Packet]), + {Packet, Sd}; + {error, Reason} -> + throw({error, Reason}) + end + end}]), + Self ! {xmerl_sax, Result}, + close(S); + Error -> + Self ! {xmerl_sax, {error, {accept, Error}}} + end + end), + + {ok, SendSocket} = connect(localhost, Port), + + {ok, Binary} = file:read_file(filename:join([datadir(Config), "xmerl_sax_stream_one_junk.xml"])), + + send_chunks(SendSocket, Binary), + + receive + {xmerl_sax, {ok, undefined, Rest}} -> + <<"\nth", _R/binary>> = Rest, + io:format("Ok Rest: ~p\n", [Rest]) + after 10000 -> + ct:fail("Timeout") + end, + ok. + +%%---------------------------------------------------------------------- +%% Utility functions +%%---------------------------------------------------------------------- +listen(Port) -> + case catch gen_tcp:listen(Port, [{active, false}, + binary, + {keepalive, true}, + {reuseaddr,true}]) of + {ok, ListenSocket} -> + {ok, ListenSocket}; + {error, Reason} -> + {error, {listen, Reason}} + end. + +close(Socket) -> + (catch gen_tcp:close(Socket)). + +connect(Host, Port) -> + Timeout = 5000, + % Options1 = check_options(Options), + Options = [binary], + case catch gen_tcp:connect(Host, Port, Options, Timeout) of + {ok, Socket} -> + {ok, Socket}; + {error, Reason} -> + {error, Reason} + end. + +send_chunks(Socket, Binary) -> + BSize = erlang:size(Binary), + if + BSize > 25 -> + <<Head:25/binary, Tail/binary>> = Binary, + case gen_tcp:send(Socket, Head) of + ok -> + timer:sleep(1000), + send_chunks(Socket, Tail); + {error,closed} -> + ok + end; + true -> + gen_tcp:send(Socket, Binary) + end. + +datadir(Config) -> + proplists:get_value(data_dir, Config). diff --git a/lib/xmerl/test/xmerl_sax_stream_SUITE_data/xmerl_sax_stream_one.xml b/lib/xmerl/test/xmerl_sax_stream_SUITE_data/xmerl_sax_stream_one.xml new file mode 100644 index 0000000000..30328bb188 --- /dev/null +++ b/lib/xmerl/test/xmerl_sax_stream_SUITE_data/xmerl_sax_stream_one.xml @@ -0,0 +1,17 @@ +<?xml version="1.0"?> +<person> +<name> +Arne Andersson +</name> +<address> +<street> + Old Road 456 +</street> +<zip> +12323 +</zip> +<city> +Small City +</city> +</address> +</person> diff --git a/lib/xmerl/test/xmerl_sax_stream_SUITE_data/xmerl_sax_stream_one_junk.xml b/lib/xmerl/test/xmerl_sax_stream_SUITE_data/xmerl_sax_stream_one_junk.xml new file mode 100644 index 0000000000..f730a95865 --- /dev/null +++ b/lib/xmerl/test/xmerl_sax_stream_SUITE_data/xmerl_sax_stream_one_junk.xml @@ -0,0 +1,18 @@ +<?xml version="1.0"?> +<person> +<name> +Arne Andersson +</name> +<address> +<street> + Old Road 456 +</street> +<zip> +12323 +</zip> +<city> +Small City +</city> +</address> +</person> +this is junk ...... diff --git a/lib/xmerl/test/xmerl_sax_stream_SUITE_data/xmerl_sax_stream_two.xml b/lib/xmerl/test/xmerl_sax_stream_SUITE_data/xmerl_sax_stream_two.xml new file mode 100644 index 0000000000..e241a02190 --- /dev/null +++ b/lib/xmerl/test/xmerl_sax_stream_SUITE_data/xmerl_sax_stream_two.xml @@ -0,0 +1,34 @@ +<?xml version="1.0"?> +<person> +<name> +Arne Andersson +</name> +<address> +<street> + Old Road 456 +</street> +<zip> +12323 +</zip> +<city> +Small City +</city> +</address> +</person> +<?xml version="1.0"?> +<person> +<name> +Bertil Bengtson +</name> +<address> +<street> + New Road 4 +</street> +<zip> +12328 +</zip> +<city> +Small City +</city> +</address> +</person> |