diff options
Diffstat (limited to 'lib')
820 files changed, 39855 insertions, 17666 deletions
diff --git a/lib/.gitignore b/lib/.gitignore index 283393faa9..7cef9d7cf3 100644 --- a/lib/.gitignore +++ b/lib/.gitignore @@ -1,32 +1,3 @@ -# common test - -/common_test/doc/src/ct.xml -/common_test/doc/src/ct_cover.xml -/common_test/doc/src/ct_ftp.xml -/common_test/doc/src/ct_master.xml -/common_test/doc/src/ct_rpc.xml -/common_test/doc/src/ct_snmp.xml -/common_test/doc/src/ct_ssh.xml -/common_test/doc/src/ct_netconfc.xml -/common_test/doc/src/ct_telnet.xml -/common_test/doc/src/unix_telnet.xml - -# edoc - -/edoc/doc/src/chapter.xml -/edoc/doc/src/edoc.xml -/edoc/doc/src/edoc_doclet.xml -/edoc/doc/src/edoc_extract.xml -/edoc/doc/src/edoc_layout.xml -/edoc/doc/src/edoc_lib.xml -/edoc/doc/src/edoc_run.xml - -# eunit - -/eunit/doc/src/chapter.xml -/eunit/doc/src/eunit.xml -/eunit/doc/src/eunit_surefire.xml - # erl_interface /erl_interface/bin @@ -34,15 +5,6 @@ /erl_interface/obj.st /erl_interface/obj -# gs - -/gs/doc/src/gs_chapter2.xml -/gs/doc/src/gs_chapter4.xml -/gs/doc/src/gs_chapter5.xml -/gs/doc/src/gs_chapter6.xml -/gs/doc/src/gs_chapter7.xml -/gs/doc/src/gs_chapter8.xml - # megaco /megaco/src/binary/megaco_ber_bin_drv_media_gateway_control_prev3a.erl @@ -129,19 +91,6 @@ /megaco/src/text/megaco_text_parser_v1.erl /megaco/src/text/megaco_text_parser_v2.erl /megaco/src/text/megaco_text_parser_v3.erl -/megaco/doc/html/mstone1.jpg - -# mnesia - -/mnesia/doc/src/Mnesia_App_A.xml -/mnesia/doc/src/Mnesia_App_B.xml -/mnesia/doc/src/Mnesia_App_C.xml -/mnesia/doc/src/Mnesia_App_D.xml -/mnesia/doc/src/Mnesia_chap2.xml -/mnesia/doc/src/Mnesia_chap3.xml -/mnesia/doc/src/Mnesia_chap4.xml -/mnesia/doc/src/Mnesia_chap5.xml -/mnesia/doc/src/Mnesia_chap7.xml # orber & cos* applications @@ -525,39 +474,3 @@ /orber/src/oe_OrberIFR.hrl /orber/src/oe_erlang.erl /orber/src/oe_erlang.hrl - -# snmp - -snmp/doc/intex.html - -# syntax_tools - -/syntax_tools/doc/src/chapter.xml -/syntax_tools/doc/src/epp_dodger.xml -/syntax_tools/doc/src/erl_comment_scan.xml -/syntax_tools/doc/src/erl_prettypr.xml -/syntax_tools/doc/src/erl_recomment.xml -/syntax_tools/doc/src/erl_syntax.xml -/syntax_tools/doc/src/erl_syntax_lib.xml -/syntax_tools/doc/src/erl_tidy.xml -/syntax_tools/doc/src/merl.xml -/syntax_tools/doc/src/merl_transform.xml -/syntax_tools/doc/src/igor.xml -/syntax_tools/doc/src/prettypr.xml - -# wx - -/wx/doc/src/chapter.xml -/wx/doc/src/gl.xml -/wx/doc/src/glu.xml -/wx/doc/src/ref_man.xml - -# xmerl - -/xmerl/doc/src/xmerl.xml -/xmerl/doc/src/xmerl_eventp.xml -/xmerl/doc/src/xmerl_scan.xml -/xmerl/doc/src/xmerl_ug.xml -/xmerl/doc/src/xmerl_xpath.xml -/xmerl/doc/src/xmerl_xs.xml -/xmerl/doc/src/xmerl_xsd.xml diff --git a/lib/Makefile b/lib/Makefile index ae466ed518..d67e605875 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 eldap dialyzer hipe + eunit ssh eldap dialyzer hipe ftp tftp ifdef BUILD_ALL ERLANG_APPLICATIONS += $(ALL_ERLANG_APPLICATIONS) diff --git a/lib/asn1/doc/src/Makefile b/lib/asn1/doc/src/Makefile index 9a388e4e8a..2b5d9467d9 100644 --- a/lib/asn1/doc/src/Makefile +++ b/lib/asn1/doc/src/Makefile @@ -51,13 +51,14 @@ XML_CHAPTER_FILES = \ asn1_introduction.xml \ asn1_getting_started.xml \ asn1_overview.xml \ - asn1_spec.xml \ notes.xml BOOK_FILES = book.xml XML_FILES = $(BOOK_FILES) $(XML_APPLICATION_FILES) $(XML_REF3_FILES) \ - $(GEN_XML) $(XML_PART_FILES) $(XML_CHAPTER_FILES) + $(XML_PART_FILES) $(XML_CHAPTER_FILES) + +XML_GEN_FILES = $(GEN_XML:%=$(XMLDIR)/%) GIF_FILES = \ exclusive_Win_But.gif \ @@ -75,7 +76,8 @@ EXTRA_FILES = \ $(DEFAULT_HTML_FILES) \ $(ASN1_FILES) \ $(XML_REF3_FILES:%.xml=$(HTMLDIR)/%.html) \ - $(XML_CHAPTER_FILES:%.xml=$(HTMLDIR)/%.html) + $(XML_CHAPTER_FILES:%.xml=$(HTMLDIR)/%.html) \ + $(GEN_XML:%.xml=$(HTMLDIR)/%.html) \ MAN3_FILES = $(XML_REF3_FILES:%.xml=$(MAN3DIR)/%.3) diff --git a/lib/asn1/src/asn1ct.erl b/lib/asn1/src/asn1ct.erl index 81a2735a0d..e9e9f6eb42 100644 --- a/lib/asn1/src/asn1ct.erl +++ b/lib/asn1/src/asn1ct.erl @@ -292,8 +292,7 @@ run_passes_1([{pass,Name,Pass}|Passes], #st{run=Run}=St0) done -> ok catch - Class:Error -> - Stk = erlang:get_stacktrace(), + Class:Error:Stk -> io:format("Internal error: ~p:~p\n~p\n", [Class,Error,Stk]), {error,{internal_error,{Class,Error}}} @@ -2390,13 +2389,13 @@ in_process(Fun) -> receive {Pid, Result} -> Result; {Pid, Class, Reason, Stack} -> - ST = try throw(x) catch throw:x -> erlang:get_stacktrace() end, + ST = try throw(x) catch throw:x:Stk -> Stk end, erlang:raise(Class, Reason, Stack ++ ST) end. process(Parent, Fun) -> try Parent ! {self(), Fun()} - catch Class:Reason -> - Parent ! {self(), Class, Reason, erlang:get_stacktrace()} + catch Class:Reason:Stack -> + Parent ! {self(), Class, Reason, Stack} end. diff --git a/lib/asn1/src/asn1ct_check.erl b/lib/asn1/src/asn1ct_check.erl index 83d12600b7..321980e5e4 100644 --- a/lib/asn1/src/asn1ct_check.erl +++ b/lib/asn1/src/asn1ct_check.erl @@ -1576,13 +1576,15 @@ printable_string_1(#'Externalvaluereference'{value=Type}) -> printable_string_1({Atom,Line}) when is_atom(Atom), is_integer(Line) -> q(Atom); printable_string_1({object,definedsyntax,L}) -> - q(string:join([printable_string_1(Item) || Item <- L], " ")); + Str = lists:join($\s, [printable_string_1(Item) || Item <- L]), + q(lists:flatten(Str)); printable_string_1([_|_]=Def) -> case lists:all(fun is_integer/1, Def) of true -> lists:flatten(io_lib:format("~p", [Def])); false -> - q(string:join([printable_string_1(Item) || Item <- Def], " ")) + Str = lists:join($\s, [printable_string_1(Item) || Item <- Def]), + q(lists:flatten(Str)) end; printable_string_1(Def) -> lists:flatten(io_lib:format("~p", [Def])). diff --git a/lib/asn1/src/asn1ct_gen.erl b/lib/asn1/src/asn1ct_gen.erl index da9f6ac559..ee039dfbab 100644 --- a/lib/asn1/src/asn1ct_gen.erl +++ b/lib/asn1/src/asn1ct_gen.erl @@ -811,12 +811,11 @@ result_line(NoOkWrapper, Items) -> result_line_1([SingleItem]) -> SingleItem; result_line_1(Items) -> - ["{",string:join(Items, ","),"}"]. + ["{",lists:join(",",Items),"}"]. try_catch() -> [" catch",nl, - " Class:Exception when Class =:= error; Class =:= exit ->",nl, - " Stk = erlang:get_stacktrace(),",nl, + " Class:Exception:Stk when Class =:= error; Class =:= exit ->",nl, " case Exception of",nl, " {error,{asn1,Reason}} ->",nl, " {error,{asn1,{Reason,Stk}}};",nl, @@ -958,7 +957,7 @@ open_hrl(OutFile,Module) -> hrl_protector(OutFile) -> BaseName = filename:basename(OutFile), - P = "_" ++ string:to_upper(BaseName) ++ "_HRL_", + P = "_" ++ string:uppercase(BaseName) ++ "_HRL_", [if $A =< C, C =< $Z -> C; $a =< C, C =< $a -> C; diff --git a/lib/asn1/src/asn1rtt_real_common.erl b/lib/asn1/src/asn1rtt_real_common.erl index 3a79209015..81c1f54d74 100644 --- a/lib/asn1/src/asn1rtt_real_common.erl +++ b/lib/asn1/src/asn1rtt_real_common.erl @@ -125,7 +125,7 @@ encode_real(_C, {_,Base,_}) -> encode_real(C, Real) when is_list(Real) -> %% The Real string may come in as a NR1, NR2 or NR3 string. {Mantissa, Exponent} = - case string:tokens(Real,"Ee") of + case string:lexemes(Real,"Ee") of [NR2] -> {NR2,0}; [NR3MB,NR3E] -> @@ -144,7 +144,7 @@ encode_real(C, Real) when is_list(Real) -> NewMan = remove_trailing_zeros(Dec), {NewMan,length(ZeroDecimal(NewMan))}; _ -> - case string:tokens(Mantissa,",.") of + case string:lexemes(Mantissa,",.") of [Num] -> %% No decimal-mark {integer_to_list(list_to_integer(Num)),0}; [Num,Dec] -> diff --git a/lib/asn1/test/asn1_SUITE.erl b/lib/asn1/test/asn1_SUITE.erl index bfeffa969f..8cf6745103 100644 --- a/lib/asn1/test/asn1_SUITE.erl +++ b/lib/asn1/test/asn1_SUITE.erl @@ -227,10 +227,9 @@ test(Config, TestF, Rules) -> try TestF(C, R, O) catch - Class:Reason -> + Class:Reason:Stk -> NewReason = {Reason, [{rule, R}, {options, O}]}, - erlang:raise(Class, NewReason, - erlang:get_stacktrace()) + erlang:raise(Class, NewReason, Stk) end end, Result = [run_case(Config, Fun, rule(Rule), opts(Rule)) || Rule <- Rules], diff --git a/lib/asn1/test/testUniqueObjectSets.erl b/lib/asn1/test/testUniqueObjectSets.erl index cabdb44a0c..c75a673c4b 100644 --- a/lib/asn1/test/testUniqueObjectSets.erl +++ b/lib/asn1/test/testUniqueObjectSets.erl @@ -30,8 +30,7 @@ seq_roundtrip(I, D0) -> asn1_test_lib:map_roundtrip(M, 'Seq', Enc), {ok,{'Seq',I,D}} = M:decode('Seq', Enc), D - catch C:E -> - Stk = erlang:get_stacktrace(), + catch C:E:Stk -> io:format("FAILED: ~p ~p\n", [I,D0]), erlang:raise(C, E, Stk) end. diff --git a/lib/common_test/doc/src/ct_ftp.xml b/lib/common_test/doc/src/ct_ftp.xml index e8c6f72db7..a6f01dd58e 100644 --- a/lib/common_test/doc/src/ct_ftp.xml +++ b/lib/common_test/doc/src/ct_ftp.xml @@ -33,13 +33,11 @@ <file>ct_ftp.xml</file> </header> <module>ct_ftp</module> - <modulesummary>FTP client module (based on the FTP support of the Inets - application).</modulesummary> + <modulesummary>FTP client module (based on the FTP application).</modulesummary> <description> - <p>FTP client module (based on the FTP support of the <c>Inets</c> - application).</p> + <p>FTP client module (based on the <c>ftp</c> application).</p> </description> diff --git a/lib/common_test/src/common_test.app.src b/lib/common_test/src/common_test.app.src index 0aa4aacf16..f686003637 100644 --- a/lib/common_test/src/common_test.app.src +++ b/lib/common_test/src/common_test.app.src @@ -85,6 +85,7 @@ "crypto-3.6", "debugger-4.1", "erts-7.0", + "ftp-1.0.0", "inets-6.0", "kernel-4.0", "observer-2.1", @@ -92,7 +93,7 @@ "sasl-2.4.2", "snmp-5.1.2", "ssh-4.0", - "stdlib-3.4", + "stdlib-3.5", "syntax_tools-1.7", "tools-2.8", "xmerl-1.3.8" diff --git a/lib/common_test/src/ct.erl b/lib/common_test/src/ct.erl index 4c4dc8bede..fd7fa07b81 100644 --- a/lib/common_test/src/ct.erl +++ b/lib/common_test/src/ct.erl @@ -872,8 +872,8 @@ fail(Reason) -> try exit({test_case_failed,Reason}) catch - Class:R -> - case erlang:get_stacktrace() of + Class:R:S -> + case S of [{?MODULE,fail,1,_}|Stk] -> ok; Stk -> ok end, @@ -894,8 +894,8 @@ fail(Format, Args) -> try exit({test_case_failed,lists:flatten(Str)}) catch - Class:R -> - case erlang:get_stacktrace() of + Class:R:S -> + case S of [{?MODULE,fail,2,_}|Stk] -> ok; Stk -> ok end, @@ -1032,7 +1032,7 @@ make_and_load(Dir, Suite) -> EnvInclude = case os:getenv("CT_INCLUDE_PATH") of false -> []; - CtInclPath -> string:tokens(CtInclPath, [$:,$ ,$,]) + CtInclPath -> string:lexemes(CtInclPath, [$:,$ ,$,]) end, StartInclude = case init:get_argument(include) of diff --git a/lib/common_test/src/ct_config.erl b/lib/common_test/src/ct_config.erl index 9cb9b0ba16..e33b47b0e8 100644 --- a/lib/common_test/src/ct_config.erl +++ b/lib/common_test/src/ct_config.erl @@ -660,7 +660,7 @@ decrypt_config_file(EncryptFileName, TargetFileName, {key,Key}) -> get_crypt_key_from_file(File) -> case file:read_file(File) of {ok,Bin} -> - case catch string:tokens(binary_to_list(Bin), [$\n,$\r]) of + case catch string:lexemes(binary_to_list(Bin), [$\n, [$\r,$\n]]) of [Key] -> Key; _ -> @@ -694,7 +694,7 @@ get_crypt_key_from_file() -> noent -> Result; _ -> - case catch string:tokens(binary_to_list(Result), [$\n,$\r]) of + case catch string:lexemes(binary_to_list(Result), [$\n, [$\r,$\n]]) of [Key] -> io:format("~nCrypt key file: ~ts~n", [FullName]), Key; diff --git a/lib/common_test/src/ct_config_plain.erl b/lib/common_test/src/ct_config_plain.erl index e72b55971b..d525019f7b 100644 --- a/lib/common_test/src/ct_config_plain.erl +++ b/lib/common_test/src/ct_config_plain.erl @@ -106,7 +106,7 @@ read_config_terms1({done,{eof,EL},_}, L, _, _) -> read_config_terms1({done,{error,Info,EL},_}, L, _, _) -> {error,{Info,{L,EL}}}; read_config_terms1({more,_}, L, Terms, Rest) -> - case string:tokens(Rest, [$\n,$\r,$\t]) of + case string:lexemes(Rest, [$\n,[$\r,$\n],$\t]) of [] -> lists:reverse(Terms); _ -> diff --git a/lib/common_test/src/ct_conn_log_h.erl b/lib/common_test/src/ct_conn_log_h.erl index cf0a228e1b..3e83020f45 100644 --- a/lib/common_test/src/ct_conn_log_h.erl +++ b/lib/common_test/src/ct_conn_log_h.erl @@ -224,7 +224,7 @@ now_to_time({_,_,MicroS}=Now) -> {calendar:now_to_local_time(Now),MicroS}. pretty_head({{{Y,Mo,D},{H,Mi,S}},MicroS},ConnMod,Text0) -> - Text = string:to_upper(atom_to_list(ConnMod) ++ Text0), + Text = string:uppercase(atom_to_list(ConnMod) ++ Text0), io_lib:format("= ~s ==== ~s-~s-~w::~s:~s:~s,~s ", [Text,t(D),month(Mo),Y,t(H),t(Mi),t(S), micro2milli(MicroS)]). @@ -275,7 +275,7 @@ pad0(N,Str) -> lists:duplicate(N-M,$0) ++ Str. pad_char_end(N,Str,Char) -> - case length(lists:flatten(Str)) of + case string:length(Str) of M when M<N -> Str ++ lists:duplicate(N-M,Char); _ -> Str end. diff --git a/lib/common_test/src/ct_framework.erl b/lib/common_test/src/ct_framework.erl index 6066470233..7f7e9ae6f9 100644 --- a/lib/common_test/src/ct_framework.erl +++ b/lib/common_test/src/ct_framework.erl @@ -921,9 +921,10 @@ error_notification(Mod,Func,_Args,{Error,Loc}) -> end, ErrorStr = case ErrorSpec of {badmatch,Descr} -> - Descr1 = lists:flatten(io_lib:format("~tP",[Descr,10])), - if length(Descr1) > 50 -> - Descr2 = string:substr(Descr1,1,50), + Descr1 = io_lib:format("~tP",[Descr,10]), + DescrLength = string:length(Descr1), + if DescrLength > 50 -> + Descr2 = string:slice(Descr1,0,50), io_lib:format("{badmatch,~ts...}",[Descr2]); true -> io_lib:format("{badmatch,~ts}",[Descr1]) diff --git a/lib/common_test/src/ct_ftp.erl b/lib/common_test/src/ct_ftp.erl index 8effb06e7e..8b02ae3a0f 100644 --- a/lib/common_test/src/ct_ftp.erl +++ b/lib/common_test/src/ct_ftp.erl @@ -18,7 +18,7 @@ %% %CopyrightEnd% %% -%%% @doc FTP client module (based on the FTP support of the INETS application). +%%% @doc FTP client module (based on the FTP application). %%% %%% @type connection() = handle() | ct:target_name() %%% @type handle() = ct_gen_conn:handle(). Handle for a specific @@ -285,15 +285,15 @@ init(KeyOrName,{IP,Port},{Username,Password}) -> {ok,FtpPid} -> log(heading(init,KeyOrName), "Opened ftp connection:\nIP: ~tp\nUsername: ~tp\nPassword: ~p\n", - [IP,Username,lists:duplicate(length(Password),$*)]), + [IP,Username,lists:duplicate(string:length(Password),$*)]), {ok,FtpPid,#state{ftp_pid=FtpPid,target_name=KeyOrName}}; Error -> Error end. ftp_connect(IP,Port,Username,Password) -> - _ = inets:start(), - case inets:start(ftpc,[{host,IP},{port,Port}]) of + _ = ftp:start(), + case ftp:start_service([{host,IP},{port,Port}]) of {ok,FtpPid} -> case ftp:user(FtpPid,Username,Password) of ok -> @@ -341,7 +341,7 @@ reconnect(_Addr,_State) -> terminate(FtpPid,State) -> log(heading(terminate,State#state.target_name), "Closing FTP connection.\nHandle: ~p\n",[FtpPid]), - inets:stop(ftpc,FtpPid). + ftp:stop_service(FtpPid). %%%================================================================= diff --git a/lib/common_test/src/ct_hooks.erl b/lib/common_test/src/ct_hooks.erl index f0592a40be..bb33f0243b 100644 --- a/lib/common_test/src/ct_hooks.erl +++ b/lib/common_test/src/ct_hooks.erl @@ -233,8 +233,7 @@ call([{Hook, call_id, NextFun} | Rest], Config, Meta, Hooks) -> Rest ++ [{NewId, call_init}, {NewId,NextFun}]} end, call(resort(NewRest,NewHooks,Meta), Config, Meta, NewHooks) - catch Error:Reason -> - Trace = erlang:get_stacktrace(), + catch Error:Reason:Trace -> ct_logs:log("Suite Hook","Failed to start a CTH: ~tp:~tp", [Error,{Reason,Trace}]), call([], {fail,"Failed to start CTH" @@ -422,8 +421,7 @@ catch_apply(M,F,A, Default, Fallback) -> catch_apply(M,F,A) -> try erlang:apply(M,F,A) - catch _:Reason -> - Trace = erlang:get_stacktrace(), + catch _:Reason:Trace -> ct_logs:log("Suite Hook","Call to CTH failed: ~w:~tp", [error,{Reason,Trace}]), throw({error_in_cth_call, diff --git a/lib/common_test/src/ct_logs.erl b/lib/common_test/src/ct_logs.erl index fb6a095b57..9861b1e521 100644 --- a/lib/common_test/src/ct_logs.erl +++ b/lib/common_test/src/ct_logs.erl @@ -1191,26 +1191,23 @@ print_style(Fd, IoFormat, StyleSheet) -> case file:read_file(StyleSheet) of {ok,Bin} -> Str = b2s(Bin,encoding(StyleSheet)), - Pos0 = case string:str(Str,"<style>") of - 0 -> string:str(Str,"<STYLE>"); - N0 -> N0 - end, - Pos1 = case string:str(Str,"</style>") of - 0 -> string:str(Str,"</STYLE>"); - N1 -> N1 - end, - if (Pos0 == 0) and (Pos1 /= 0) -> - print_style_error(Fd, IoFormat, - StyleSheet, missing_style_start_tag); - (Pos0 /= 0) and (Pos1 == 0) -> - print_style_error(Fd, IoFormat, - StyleSheet,missing_style_end_tag); - Pos0 /= 0 -> - Style = string:sub_string(Str,Pos0,Pos1+7), - IoFormat(Fd,"~ts\n",[Style]); - Pos0 == 0 -> - IoFormat(Fd,"<style>\n~ts</style>\n",[Str]) - end; + case re:run(Str,"<style>.*</style>", + [dotall,caseless,{capture,all,list}]) of + nomatch -> + case re:run(Str,"</?style>",[caseless,{capture,all,list}]) of + nomatch -> + IoFormat(Fd,"<style>\n~ts</style>\n",[Str]); + {match,["</"++_]} -> + print_style_error(Fd, IoFormat, + StyleSheet, + missing_style_start_tag); + {match,[_]} -> + print_style_error(Fd, IoFormat, + StyleSheet,missing_style_end_tag) + end; + {match,[Style]} -> + IoFormat(Fd,"~ts\n",[Style]) + end; {error,Reason} -> print_style_error(Fd,IoFormat,StyleSheet,Reason) end. @@ -1417,9 +1414,9 @@ make_one_index_entry1(SuiteName, Link, Label, Success, Fail, UserSkip, AutoSkip, {Lbl,Timestamp,Node,AllInfo} = case All of {true,OldRuns} -> - [_Prefix,NodeOrDate|_] = string:tokens(Link,"."), - Node1 = case string:chr(NodeOrDate,$@) of - 0 -> "-"; + [_Prefix,NodeOrDate|_] = string:lexemes(Link,"."), + Node1 = case string:find(NodeOrDate,[$@]) of + nomatch -> "-"; _ -> NodeOrDate end, @@ -1526,7 +1523,7 @@ not_built(BaseName,_LogDir,_All,Missing) -> %% Top.ObjDir | Top.ObjDir.suites | Top.ObjDir.Suite | %% Top.ObjDir.Suite.cases | Top.ObjDir.Suite.Case Failed = - case string:tokens(BaseName,".") of + case string:lexemes(BaseName,".") of [T,O] when is_list(T) -> % all under Top.ObjDir locate_info({T,O},all,Missing); [T,O,"suites"] -> @@ -2054,9 +2051,9 @@ sort_all_runs(Dirs) -> %% "YYYY-MM-DD_HH.MM.SS" lists:sort(fun(Dir1,Dir2) -> [SS1,MM1,HH1,Date1|_] = - lists:reverse(string:tokens(Dir1,[$.,$_])), + lists:reverse(string:lexemes(Dir1,[$.,$_])), [SS2,MM2,HH2,Date2|_] = - lists:reverse(string:tokens(Dir2,[$.,$_])), + lists:reverse(string:lexemes(Dir2,[$.,$_])), {Date1,HH1,MM1,SS1} > {Date2,HH2,MM2,SS2} end, Dirs). @@ -2066,9 +2063,9 @@ sort_ct_runs(Dirs) -> lists:sort( fun(Dir1,Dir2) -> [SS1,MM1,DateHH1 | _] = - lists:reverse(string:tokens(filename:dirname(Dir1),[$.])), + lists:reverse(string:lexemes(filename:dirname(Dir1),[$.])), [SS2,MM2,DateHH2 | _] = - lists:reverse(string:tokens(filename:dirname(Dir2),[$.])), + lists:reverse(string:lexemes(filename:dirname(Dir2),[$.])), {DateHH1,MM1,SS1} =< {DateHH2,MM2,SS2} end, Dirs). @@ -2214,27 +2211,15 @@ runentry(Dir, Totals={Node,Label,Logs, 0 -> "-"; N -> integer_to_list(N) end, - StripExt = - fun(File) -> - string:sub_string(File,1, - length(File)- - length(?logdir_ext)) ++ ", " - end, - Polish = fun(S) -> case lists:reverse(S) of - [32,$,|Rev] -> lists:reverse(Rev); - [$,|Rev] -> lists:reverse(Rev); - _ -> S - end - end, - TestNames = Polish(lists:flatten(lists:map(StripExt,Logs))), + + RootNames = lists:map(fun(F) -> filename:rootname(F,?logdir_ext) end, Logs), + TestNames = lists:flatten(lists:join(", ", RootNames)), TestNamesTrunc = - if TestNames=="" -> - ""; - length(TestNames) < ?testname_width -> + if length(TestNames) < ?testname_width -> TestNames; true -> - Trunc = Polish(string:substr(TestNames,1, - ?testname_width-3)), + Trunc = string:trim(string:slice(TestNames,0,?testname_width-3), + trailing,",\s"), lists:flatten(io_lib:format("~ts...",[Trunc])) end, TotMissingStr = @@ -2377,7 +2362,7 @@ force_rename(From,To,Number) -> timestamp(Dir) -> - TsR = lists:reverse(string:tokens(Dir,".-_")), + TsR = lists:reverse(string:lexemes(Dir,".-_")), [S,Min,H,D,M,Y] = [list_to_integer(N) || N <- lists:sublist(TsR,6)], format_time({{Y,M,D},{H,Min,S}}). @@ -2926,7 +2911,7 @@ cache_vsn() -> VSNfile = filename:join([EbinDir,"..","vsn.mk"]), case file:read_file(VSNfile) of {ok,Bin} -> - [_,VSN] = string:tokens(binary_to_list(Bin),[$=,$\n,$ ]), + [_,VSN] = string:lexemes(binary_to_list(Bin),[$=,$\n,$ ]), VSN; _ -> undefined @@ -3332,7 +3317,7 @@ insert_javascript({tablesorter,TableName, end, [{"CTDateSorter",DateCols}, {"CTTextSorter",TextCols}, {"CTValSorter",ValCols}]))), - Headers1 = string:substr(Headers, 1, length(Headers)-2), + Headers1 = string:trim(Headers, trailing, ",\n"), ["<script type=\"text/javascript\">\n", "// Parser for date format, e.g: Wed Jul 4 2012 11:24:15\n", diff --git a/lib/common_test/src/ct_master.erl b/lib/common_test/src/ct_master.erl index ef2aff69b7..e2ea525cdd 100644 --- a/lib/common_test/src/ct_master.erl +++ b/lib/common_test/src/ct_master.erl @@ -809,7 +809,7 @@ filter_accessible(InitOptions, Inaccessible)-> start_nodes(InitOptions)-> lists:foreach(fun({NodeName, Options})-> - [NodeS,HostS]=string:tokens(atom_to_list(NodeName), "@"), + [NodeS,HostS]=string:lexemes(atom_to_list(NodeName), "@"), Node=list_to_atom(NodeS), Host=list_to_atom(HostS), HasNodeStart = lists:keymember(node_start, 1, Options), diff --git a/lib/common_test/src/ct_master_logs.erl b/lib/common_test/src/ct_master_logs.erl index c4bb2cc69f..1308720823 100644 --- a/lib/common_test/src/ct_master_logs.erl +++ b/lib/common_test/src/ct_master_logs.erl @@ -298,7 +298,7 @@ sort_all_runs(Dirs) -> %% "YYYY-MM-DD_HH.MM.SS" KeyList = lists:map(fun(Dir) -> - case lists:reverse(string:tokens(Dir,[$.,$_])) of + case lists:reverse(string:lexemes(Dir,[$.,$_])) of [SS,MM,HH,Date|_] -> {{Date,HH,MM,SS},Dir}; _Other -> @@ -313,18 +313,8 @@ runentry(Dir) -> {MasterStr,NodesStr} = case read_details_file(Dir) of {Master,Nodes} when is_list(Nodes) -> - [_,Host] = string:tokens(atom_to_list(Master),"@"), - NodesList = - lists:reverse(lists:map(fun(N) -> - atom_to_list(N) ++ ", " - end,Nodes)), - case NodesList of - [N|NListR] -> - N1 = string:sub_string(N,1,length(N)-2), - {Host,lists:flatten(lists:reverse([N1|NListR]))}; - [] -> - {Host,""} - end; + [_,Host] = string:lexemes(atom_to_list(Master),"@"), + {Host,lists:concat(lists:join(", ",Nodes))}; _Error -> {"unknown",""} end, @@ -349,7 +339,7 @@ all_runs_header() -> xhtml("", "</tr></thead>\n<tbody>\n")]]. timestamp(Dir) -> - [S,Min,H,D,M,Y|_] = lists:reverse(string:tokens(Dir,".-_")), + [S,Min,H,D,M,Y|_] = lists:reverse(string:lexemes(Dir,".-_")), [S1,Min1,H1,D1,M1,Y1] = [list_to_integer(N) || N <- [S,Min,H,D,M,Y]], format_time({{Y1,M1,D1},{H1,Min1,S1}}). diff --git a/lib/common_test/src/ct_netconfc.erl b/lib/common_test/src/ct_netconfc.erl index 2c4b97df20..29188a648e 100644 --- a/lib/common_test/src/ct_netconfc.erl +++ b/lib/common_test/src/ct_netconfc.erl @@ -1467,7 +1467,7 @@ decode_data(Other) -> {error,{unexpected_rpc_reply,Other}}. get_qualified_name(Tag) -> - case string:tokens(atom_to_list(Tag),":") of + case string:lexemes(atom_to_list(Tag),":") of [TagStr] -> {[],TagStr}; [PrefixStr,TagStr] -> {PrefixStr,TagStr} end. diff --git a/lib/common_test/src/ct_release_test.erl b/lib/common_test/src/ct_release_test.erl index 551a7e06d7..4af9afb45b 100644 --- a/lib/common_test/src/ct_release_test.erl +++ b/lib/common_test/src/ct_release_test.erl @@ -817,7 +817,7 @@ get_runtime_deps([App|Apps],StartApps,Acc,Visited) -> RuntimeDeps = lists:flatmap( fun(Str) -> - [RuntimeAppStr,_] = string:tokens(Str,"-"), + [RuntimeAppStr,_] = string:lexemes(Str,"-"), RuntimeApp = list_to_atom(RuntimeAppStr), case {lists:keymember(RuntimeApp,1,Acc), lists:member(RuntimeApp,StartApps)} of diff --git a/lib/common_test/src/ct_run.erl b/lib/common_test/src/ct_run.erl index 05b1e70098..afc5fee4f7 100644 --- a/lib/common_test/src/ct_run.erl +++ b/lib/common_test/src/ct_run.erl @@ -147,7 +147,7 @@ script_start(Args) -> CTVsn = case filename:basename(code:lib_dir(common_test)) of CTBase when is_list(CTBase) -> - case string:tokens(CTBase, "-") of + case string:lexemes(CTBase, "-") of ["common_test",Vsn] -> " v"++Vsn; _ -> "" end @@ -317,7 +317,7 @@ script_start1(Parent, Args) -> {undefined,InclDirs}; CtInclPath -> AllInclDirs = - string:tokens(CtInclPath,[$:,$ ,$,]) ++ InclDirs, + string:lexemes(CtInclPath,[$:,$ ,$,]) ++ InclDirs, application:set_env(common_test, include, AllInclDirs), {undefined,AllInclDirs} end; @@ -442,11 +442,9 @@ script_start2(Opts = #opts{vts = undefined, TestSpecData -> execute_all_specs(TestSpecData, Opts, Args, []) catch - throw:{error,Reason} -> - StackTrace = erlang:get_stacktrace(), + throw:{error,Reason}:StackTrace -> {error,{invalid_testspec,{Reason,StackTrace}}}; - _:Reason -> - StackTrace = erlang:get_stacktrace(), + _:Reason:StackTrace -> {error,{invalid_testspec,{Reason,StackTrace}}} end; [] -> @@ -1101,7 +1099,7 @@ run_test2(StartOpts) -> application:set_env(common_test, include, InclDirs), {undefined,InclDirs}; CtInclPath -> - InclDirs1 = string:tokens(CtInclPath, [$:,$ ,$,]), + InclDirs1 = string:lexemes(CtInclPath, [$:,$ ,$,]), AllInclDirs = InclDirs1++InclDirs, application:set_env(common_test, include, AllInclDirs), {undefined,AllInclDirs} @@ -1211,11 +1209,9 @@ run_spec_file(Relaxed, TestSpecData -> run_all_specs(TestSpecData, Opts, StartOpts, []) catch - throw:{error,CTReason} -> - StackTrace = erlang:get_stacktrace(), + throw:{error,CTReason}:StackTrace -> exit({error,{invalid_testspec,{CTReason,StackTrace}}}); - _:CTReason -> - StackTrace = erlang:get_stacktrace(), + _:CTReason:StackTrace -> exit({error,{invalid_testspec,{CTReason,StackTrace}}}) end. @@ -1490,7 +1486,7 @@ run_testspec2(TestSpec) -> false -> Opts#opts.include; CtInclPath -> - EnvInclude = string:tokens(CtInclPath, [$:,$ ,$,]), + EnvInclude = string:lexemes(CtInclPath, [$:,$ ,$,]), EnvInclude++Opts#opts.include end, application:set_env(common_test, include, AllInclude), diff --git a/lib/common_test/src/ct_slave.erl b/lib/common_test/src/ct_slave.erl index b39195483b..0c16ad5980 100644 --- a/lib/common_test/src/ct_slave.erl +++ b/lib/common_test/src/ct_slave.erl @@ -38,7 +38,8 @@ -record(options, {username, password, boot_timeout, init_timeout, startup_timeout, startup_functions, monitor_master, - kill_if_fail, erl_flags, env, ssh_port, ssh_opts}). + kill_if_fail, erl_flags, env, ssh_port, ssh_opts, + stop_timeout}). %%%----------------------------------------------------------------- %%% @spec start(Node) -> Result @@ -198,6 +199,7 @@ start(Host, Node, Opts) -> end end. +%%%----------------------------------------------------------------- %%% @spec stop(Node) -> Result %%% Node = atom() %%% Result = {ok, NodeName} | @@ -205,16 +207,41 @@ start(Host, Node, Opts) -> %%% Reason = not_started | %%% not_connected | %%% stop_timeout - %%% NodeName = atom() %%% @doc Stops the running Erlang node with name <code>Node</code> on %%% the localhost. stop(Node) -> stop(gethostname(), Node). -%%% @spec stop(Host, Node) -> Result +%%%----------------------------------------------------------------- +%%% @spec stop(HostOrNode, NodeOrOpts) -> Result +%%% HostOrNode = atom() +%%% NodeOrOpts = atom() | list() +%%% Result = {ok, NodeName} | +%%% {error, Reason, NodeName} +%%% Reason = not_started | +%%% not_connected | +%%% stop_timeout +%%% NodeName = atom() +%%% @doc Stops the running Erlang node with default options on a specified +%%% host, or on the local host with specified options. That is, +%%% the call is interpreted as <code>stop(Host, Node)</code> when the +%%% second argument is atom-valued and <code>stop(Node, Opts)</code> +%%% when it's list-valued. +%%% @see stop/3 +stop(_HostOrNode = Node, _NodeOrOpts = Opts) %% match to satiate edoc + when is_list(Opts) -> + stop(gethostname(), Node, Opts); + +stop(Host, Node) -> + stop(Host, Node, []). + +%%% @spec stop(Host, Node, Opts) -> Result %%% Host = atom() %%% Node = atom() +%%% Opts = [OptTuples] +%%% OptTuples = {stop_timeout, StopTimeout} +%%% StopTimeout = integer() %%% Result = {ok, NodeName} | %%% {error, Reason, NodeName} %%% Reason = not_started | @@ -222,12 +249,19 @@ stop(Node) -> %%% stop_timeout %%% NodeName = atom() %%% @doc Stops the running Erlang node with name <code>Node</code> on -%%% host <code>Host</code>. -stop(Host, Node) -> +%%% host <code>Host</code> as specified by options <code>Opts</code>. +%%% +%%% <p>Option <code>stop_timeout</code> specifies, in seconds, +%%% the time to wait until the node is disconnected. +%%% Defaults to 5 seconds. If this timeout occurs, +%%% the result <code>{error, stop_timeout, NodeName}</code> is returned. +%%% +stop(Host, Node, Opts) -> ENode = enodename(Host, Node), case is_started(ENode) of {true, connected}-> - do_stop(ENode); + OptionsRec = fetch_options(Opts), + do_stop(ENode, OptionsRec); {true, not_connected}-> {error, not_connected, ENode}; false-> @@ -257,11 +291,13 @@ fetch_options(Options) -> EnvVars = get_option_value(env, Options, []), SSHPort = get_option_value(ssh_port, Options, []), SSHOpts = get_option_value(ssh_opts, Options, []), + StopTimeout = get_option_value(stop_timeout, Options, 5), #options{username=UserName, password=Password, boot_timeout=BootTimeout, init_timeout=InitTimeout, startup_timeout=StartupTimeout, startup_functions=StartupFunctions, monitor_master=Monitor, kill_if_fail=KillIfFail, - erl_flags=ErlFlags, env=EnvVars, ssh_port=SSHPort, ssh_opts=SSHOpts}. + erl_flags=ErlFlags, env=EnvVars, ssh_port=SSHPort, ssh_opts=SSHOpts, + stop_timeout=StopTimeout}. % send a message when slave node is started % @hidden @@ -462,6 +498,8 @@ wait_for_node_alive(Node, N) -> % call init:stop on a remote node do_stop(ENode) -> + do_stop(ENode, fetch_options([])). +do_stop(ENode, Options) -> {Cover,MainCoverNode} = case test_server:is_cover() of true -> @@ -472,7 +510,8 @@ do_stop(ENode) -> {false,undefined} end, spawn(ENode, init, stop, []), - case wait_for_node_dead(ENode, 5) of + StopTimeout = Options#options.stop_timeout, + case wait_for_node_dead(ENode, StopTimeout) of {ok,ENode} -> if Cover -> %% To avoid that cover is started again if a node diff --git a/lib/common_test/src/ct_ssh.erl b/lib/common_test/src/ct_ssh.erl index ca62357e1c..491d56dfc1 100644 --- a/lib/common_test/src/ct_ssh.erl +++ b/lib/common_test/src/ct_ssh.erl @@ -996,7 +996,8 @@ init(KeyOrName, {ConnType,Addr,Port}, AllOpts) -> try_log(heading(init,KeyOrName), "Opened ~w connection:\n" "Host: ~tp (~p)\nUser: ~tp\nPassword: ~p\n", - [ConnType,Addr,Port,User,lists:duplicate(length(Password),$*)]), + [ConnType,Addr,Port,User, + lists:duplicate(string:length(Password),$*)]), {ok,SSHRef,#state{ssh_ref=SSHRef, conn_type=ConnType, target=KeyOrName}} end. diff --git a/lib/common_test/src/ct_util.erl b/lib/common_test/src/ct_util.erl index 468edc4bee..e904bb1e7c 100644 --- a/lib/common_test/src/ct_util.erl +++ b/lib/common_test/src/ct_util.erl @@ -209,11 +209,10 @@ do_start(Parent, Mode, LogDir, Verbosity) -> self() ! {{stop,{self(),{user_error,CTHReason}}}, {Parent,make_ref()}} catch - _:CTHReason -> + _:CTHReason:StackTrace -> ErrorInfo = if is_atom(CTHReason) -> io_lib:format("{~tp,~tp}", - [CTHReason, - erlang:get_stacktrace()]); + [CTHReason, StackTrace]); true -> CTHReason end, @@ -799,25 +798,25 @@ parse_table(Data) -> {Heading,Lines}. get_headings(["|" ++ Headings | Rest]) -> - {remove_space(string:tokens(Headings, "|"),[]), Rest}; + {remove_space(string:lexemes(Headings, "|"),[]), Rest}; get_headings([_ | Rest]) -> get_headings(Rest); get_headings([]) -> {{},[]}. parse_row(["|" ++ _ = Row | T], Rows, NumCols) when NumCols > 1 -> - case string:tokens(Row, "|") of + case string:lexemes(Row, "|") of Values when length(Values) =:= NumCols -> parse_row(T,[remove_space(Values,[])|Rows], NumCols); Values when length(Values) < NumCols -> parse_row([Row ++"\n"++ hd(T) | tl(T)], Rows, NumCols) end; -parse_row(["|" ++ _ = Row | T], Rows, 1 = NumCols) -> - case string:rchr(Row, $|) of - 1 -> +parse_row(["|" ++ X = Row | T], Rows, 1 = NumCols) -> + case string:find(X, [$|]) of + nomatch -> parse_row([Row ++"\n"++hd(T) | tl(T)], Rows, NumCols); _Else -> - parse_row(T, [remove_space(string:tokens(Row,"|"),[])|Rows], + parse_row(T, [remove_space(string:lexemes(Row,"|"),[])|Rows], NumCols) end; parse_row([_Skip | T], Rows, NumCols) -> @@ -826,7 +825,7 @@ parse_row([], Rows, _NumCols) -> lists:reverse(Rows). remove_space([Str|Rest],Acc) -> - remove_space(Rest,[string:strip(string:strip(Str),both,$')|Acc]); + remove_space(Rest,[string:trim(string:trim(Str,both,[$\s]),both,[$'])|Acc]); remove_space([],Acc) -> list_to_tuple(lists:reverse(Acc)). @@ -836,7 +835,7 @@ remove_space([],Acc) -> %%% %%% @doc is_test_dir(Dir) -> - lists:last(string:tokens(filename:basename(Dir), "_")) == "test". + lists:last(string:lexemes(filename:basename(Dir), "_")) == "test". %%%----------------------------------------------------------------- %%% @spec @@ -1145,7 +1144,7 @@ open_url(iexplore, Args, URL) -> _ = case win32reg:values(R) of {ok, Paths} -> Path = proplists:get_value(default, Paths), - [Cmd | _] = string:tokens(Path, "%"), + [Cmd | _] = string:lexemes(Path, "%"), Cmd1 = Cmd ++ " " ++ Args ++ " " ++ URL, io:format(?def_gl, "~nOpening ~ts with command:~n ~ts~n", [URL,Cmd1]), open_port({spawn,Cmd1}, []); diff --git a/lib/common_test/src/ct_webtool.erl b/lib/common_test/src/ct_webtool.erl index 82aa78fc4b..c7174b13f5 100644 --- a/lib/common_test/src/ct_webtool.erl +++ b/lib/common_test/src/ct_webtool.erl @@ -771,7 +771,7 @@ fill_out(Nr)-> %Controls whether the user selected a tool to start %---------------------------------------------------------------------- get_tools(Input)-> - case httpd:parse_query(Input) of + case uri_string:dissect_query(Input) of []-> no_tools; Tools-> diff --git a/lib/common_test/src/cth_log_redirect.erl b/lib/common_test/src/cth_log_redirect.erl index 77f90c0df6..b05f0bd28b 100644 --- a/lib/common_test/src/cth_log_redirect.erl +++ b/lib/common_test/src/cth_log_redirect.erl @@ -122,8 +122,8 @@ handle_event({_Type,GL,_Msg}, #eh_state{handle_remote_events = false} = State) when node(GL) /= node() -> {ok, State}; handle_event(Event, #eh_state{log_func = LogFunc} = State) -> - case lists:keyfind(sasl, 1, application:which_applications()) of - false -> + case whereis(sasl_sup) of + undefined -> sasl_not_started; _Else -> {ok, ErrLogType} = application:get_env(sasl, errlog_type), diff --git a/lib/common_test/src/cth_surefire.erl b/lib/common_test/src/cth_surefire.erl index da68bd105e..4407ff56c1 100644 --- a/lib/common_test/src/cth_surefire.erl +++ b/lib/common_test/src/cth_surefire.erl @@ -184,15 +184,14 @@ end_tc(Name, _Config, _Res, State = #state{ curr_suite = Suite, Log = case Log0 of "" -> - LowerSuiteName = string:to_lower(atom_to_list(Suite)), + LowerSuiteName = string:lowercase(atom_to_list(Suite)), filename:join(CurrLogDir,LowerSuiteName++"."++Name++".html"); _ -> Log0 end, Url = make_url(UrlBase,Log), ClassName = atom_to_list(Suite), - PGroup = string:join([ atom_to_list(Group)|| - Group <- lists:reverse(Groups)],"."), + PGroup = lists:concat(lists:join(".",lists:reverse(Groups))), TimeTakes = io_lib:format("~f",[timer:now_diff(?now,TS) / 1000000]), State#state{ test_cases = [#testcase{ log = Log, url = Url, @@ -317,9 +316,9 @@ make_url(undefined,_) -> make_url(_,[]) -> undefined; make_url(UrlBase0,Log) -> - UrlBase = string:strip(UrlBase0,right,$/), + UrlBase = string:trim(UrlBase0,trailing,[$/]), RelativeLog = get_relative_log_url(Log), - string:join([UrlBase,RelativeLog],"/"). + lists:flatten(lists:join($/,[UrlBase,RelativeLog])). get_test_root(Log) -> LogParts = filename:split(Log), @@ -329,7 +328,7 @@ get_relative_log_url(Log) -> LogParts = filename:split(Log), Start = length(LogParts)-?log_depth, Length = ?log_depth+1, - string:join(lists:sublist(LogParts,Start,Length),"/"). + lists:flatten(lists:join($/,lists:sublist(LogParts,Start,Length))). count_tcs([#testcase{name=ConfCase}|TCs],Ok,F,S) when ConfCase=="init_per_suite"; diff --git a/lib/common_test/src/test_server.erl b/lib/common_test/src/test_server.erl index e56106408f..9469619aa9 100644 --- a/lib/common_test/src/test_server.erl +++ b/lib/common_test/src/test_server.erl @@ -463,11 +463,12 @@ run_test_case_msgloop(#st{ref=Ref,pid=Pid,end_conf_pid=EndConfPid0}=St0) -> %% it as a comment, potentially replacing user data Error = lists:flatten(io_lib:format("Aborted: ~tp", [Reason])), - Error1 = lists:flatten([string:strip(S,left) || - S <- string:tokens(Error, - [$\n])]), - Comment = if length(Error1) > 63 -> - string:substr(Error1,1,60) ++ "..."; + Error1 = lists:flatten([string:trim(S,leading,"\s") || + S <- string:lexemes(Error, + [$\n])]), + ErrorLength = string:length(Error1), + Comment = if ErrorLength > 63 -> + string:slice(Error1,0,60) ++ "..."; true -> Error1 end, @@ -1339,13 +1340,12 @@ do_init_per_testcase(Mod, Args) -> {skip,Reason}; exit:{Skip,Reason} when Skip =:= skip; Skip =:= skipped -> {skip,Reason}; - throw:Other -> - set_loc(erlang:get_stacktrace()), + throw:Other:Stk -> + set_loc(Stk), Line = get_loc(), print_init_conf_result(Line,"thrown",Other), {skip,{failed,{Mod,init_per_testcase,Other}}}; - _:Reason0 -> - Stk = erlang:get_stacktrace(), + _:Reason0:Stk -> Reason = {Reason0,Stk}, set_loc(Stk), Line = get_loc(), @@ -1394,20 +1394,19 @@ do_end_per_testcase(Mod,EndFunc,Func,Conf) -> _ -> ok catch - throw:Other -> + throw:Other:Stk -> Comment0 = case read_comment() of "" -> ""; Cmt -> Cmt ++ test_server_ctrl:xhtml("<br>", "<br />") end, - set_loc(erlang:get_stacktrace()), + set_loc(Stk), comment(io_lib:format("~ts<font color=\"red\">" "WARNING: ~w thrown!" "</font>\n",[Comment0,EndFunc])), print_end_tc_warning(EndFunc,Other,"thrown",get_loc()), {failed,{Mod,end_per_testcase,Other}}; - Class:Reason -> - Stk = erlang:get_stacktrace(), + Class:Reason:Stk -> set_loc(Stk), Why = case Class of exit -> {'EXIT',Reason}; @@ -1549,8 +1548,7 @@ ts_tc(M, F, A) -> throw:{skipped, Reason} -> {skip, Reason}; exit:{skip, Reason} -> {skip, Reason}; exit:{skipped, Reason} -> {skip, Reason}; - Type:Reason -> - Stk = erlang:get_stacktrace(), + Type:Reason:Stk -> set_loc(Stk), case Type of throw -> @@ -1739,8 +1737,8 @@ fail(Reason) -> try exit({suite_failed,Reason}) catch - Class:R -> - case erlang:get_stacktrace() of + Class:R:Stacktrace -> + case Stacktrace of [{?MODULE,fail,1,_}|Stk] -> ok; Stk -> ok end, @@ -1762,8 +1760,8 @@ fail() -> try exit(suite_failed) catch - Class:R -> - case erlang:get_stacktrace() of + Class:R:Stacktrace -> + case Stacktrace of [{?MODULE,fail,0,_}|Stk] -> ok; Stk -> ok end, @@ -2042,15 +2040,15 @@ call_user_timetrap(Func, Sup) when is_function(Func) -> try Func() of Result -> Sup ! {self(),Result} - catch _:Error -> - exit({Error,erlang:get_stacktrace()}) + catch _:Error:Stk -> + exit({Error,Stk}) end; call_user_timetrap({M,F,A}, Sup) -> try apply(M,F,A) of Result -> Sup ! {self(),Result} - catch _:Error -> - exit({Error,erlang:get_stacktrace()}) + catch _:Error:Stk -> + exit({Error,Stk}) end. save_user_timetrap(TCPid, UserTTSup, StartTime) -> @@ -2707,9 +2705,9 @@ is_cover() -> is_debug() -> case catch erlang:system_info(debug_compiled) of {'EXIT', _} -> - case string:str(erlang:system_info(system_version), "debug") of - Int when is_integer(Int), Int > 0 -> true; - _ -> false + case string:find(erlang:system_info(system_version), "debug") of + nomatch -> false; + _ -> true end; Res -> Res @@ -2745,9 +2743,9 @@ has_superfluous_schedulers() -> %% We might want to do more tests on a commercial platform, for instance %% ensuring that all applications have documentation). is_commercial() -> - case string:str(erlang:system_info(system_version), "source") of - Int when is_integer(Int), Int > 0 -> false; - _ -> true + case string:find(erlang:system_info(system_version), "source") of + nomatch -> true; + _ -> false end. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% diff --git a/lib/common_test/src/test_server_ctrl.erl b/lib/common_test/src/test_server_ctrl.erl index 8ef28b3343..1ae6c8c7c7 100644 --- a/lib/common_test/src/test_server_ctrl.erl +++ b/lib/common_test/src/test_server_ctrl.erl @@ -1472,13 +1472,14 @@ get_suites([], Mods) -> lists:reverse(Mods). add_mod(Mod, Mods) -> - case string:rstr(atom_to_list(Mod), "_SUITE") of - 0 -> false; - _ -> % test suite + case lists:reverse(atom_to_list(Mod)) of + "ETIUS_" ++ _ -> % test suite case lists:member(Mod, Mods) of true -> false; false -> true - end + end; + _ -> + false end. @@ -2300,7 +2301,7 @@ run_test_cases(TestSpec, Config, TimetrapData) -> %% test_server_io:print_buffered/1 to print the data. To help with this, %% two variables in the process dictionary are used: %% 'test_server_common_io_handler' and 'test_server_queued_io'. The values -%% are set to as follwing: +%% are set to as following: %% %% Value Meaning %% ----- ------- @@ -2632,7 +2633,7 @@ run_test_cases_loop([{conf,Ref,Props,{Mod,Func}}|_Cases]=Cs0, NumStr -> %% Ex: "123 456 789" or "123,456,789" -> {123,456,789} list_to_tuple([list_to_integer(NS) || - NS <- string:tokens(NumStr, [$ ,$:,$,])]) + NS <- string:lexemes(NumStr, [$ ,$:,$,])]) end, {shuffle_cases(Ref, Cs0, UseSeed),{shuffle,UseSeed}} end; @@ -4001,11 +4002,12 @@ progress(skip, CaseNum, Mod, Func, GrName, Loc, Reason, Time, true -> "~w" end, [Time]), ReasonStr = escape_chars(reason_to_string(Reason1)), - ReasonStr1 = lists:flatten([string:strip(S,left) || - S <- string:tokens(ReasonStr,[$\n])]), + ReasonStr1 = lists:flatten([string:trim(S,leading,"\s") || + S <- string:lexemes(ReasonStr,[$\n])]), + ReasonLength = string:length(ReasonStr1), ReasonStr2 = - if length(ReasonStr1) > 80 -> - string:substr(ReasonStr1, 1, 77) ++ "..."; + if ReasonLength > 80 -> + string:slice(ReasonStr1, 0, 77) ++ "..."; true -> ReasonStr1 end, @@ -4089,11 +4091,12 @@ progress(failed, CaseNum, Mod, Func, GrName, unknown, Reason, Time, true -> "~w" end, [Time]), ErrorReason = escape_chars(lists:flatten(io_lib:format("~tp", [Reason]))), - ErrorReason1 = lists:flatten([string:strip(S,left) || - S <- string:tokens(ErrorReason,[$\n])]), + ErrorReason1 = lists:flatten([string:trim(S,leading,"\s") || + S <- string:lexemes(ErrorReason,[$\n])]), + ErrorReasonLength = string:length(ErrorReason1), ErrorReason2 = - if length(ErrorReason1) > 63 -> - string:substr(ErrorReason1, 1, 60) ++ "..."; + if ErrorReasonLength > 63 -> + string:slice(ErrorReason1, 0, 60) ++ "..."; true -> ErrorReason1 end, @@ -5164,7 +5167,7 @@ display_info([Pid|T], R, M) -> Other end, Reds = fetch(reductions, Info), - LM = length(fetch(messages, Info)), + LM = fetch(message_queue_len, Info), pformat(io_lib:format("~w", [Pid]), io_lib:format("~tw", [Call]), io_lib:format("~tw", [Curr]), Reds, LM), @@ -5736,7 +5739,7 @@ uri_encode_comp([Char|Chars],Encoding) -> Reserved = sets:is_element(Char, reserved()), case (Char>127 andalso Encoding==latin1) orelse Reserved of true -> - [ $% | http_util:integer_to_hexlist(Char)] ++ + [ $% | integer_to_list(Char, 16)] ++ uri_encode_comp(Chars,Encoding); false -> [Char | uri_encode_comp(Chars,Encoding)] diff --git a/lib/common_test/src/test_server_node.erl b/lib/common_test/src/test_server_node.erl index b3b6ae3d92..b2d4f199c3 100644 --- a/lib/common_test/src/test_server_node.erl +++ b/lib/common_test/src/test_server_node.erl @@ -315,9 +315,11 @@ start_node_peer(SlaveName, OptList, From, TI) -> Prog0 = start_node_get_option_value(erl, OptList, default), Prog = quote_progname(pick_erl_program(Prog0)), Args = - case string:str(SuppliedArgs,"-setcookie") of - 0 -> "-setcookie " ++ TI#target_info.cookie ++ " " ++ SuppliedArgs; - _ -> SuppliedArgs + case string:find(SuppliedArgs,"-setcookie") of + nomatch -> + "-setcookie " ++ TI#target_info.cookie ++ " " ++ SuppliedArgs; + _ -> + SuppliedArgs end, Cmd = lists:concat([Prog, " -detached ", @@ -612,7 +614,7 @@ pick_erl_program(L) -> %% emulator and flags as the test node. The return from lib:progname() %% could then typically be '/<full_path_to>/cerl -gcov'). quote_progname(Progname) -> - do_quote_progname(string:tokens(Progname," ")). + do_quote_progname(string:lexemes(Progname," ")). do_quote_progname([Prog]) -> "\""++Prog++"\""; diff --git a/lib/common_test/src/test_server_sup.erl b/lib/common_test/src/test_server_sup.erl index 6ddbf1ad27..139621141d 100644 --- a/lib/common_test/src/test_server_sup.erl +++ b/lib/common_test/src/test_server_sup.erl @@ -781,8 +781,8 @@ framework_call(Callback,Func,Args,DefaultReturn) -> catch exit:Why -> EH(Why); - error:Why -> - EH({Why,erlang:get_stacktrace()}); + error:Why:Stacktrace -> + EH({Why,Stacktrace}); throw:Why -> EH(Why) end; diff --git a/lib/common_test/src/unix_telnet.erl b/lib/common_test/src/unix_telnet.erl index 8ac467014c..5992f26e6d 100644 --- a/lib/common_test/src/unix_telnet.erl +++ b/lib/common_test/src/unix_telnet.erl @@ -121,7 +121,8 @@ connect1(Name,Ip,Port,Timeout,KeepAlive,TCPNoDelay,Username,Password) -> prompt,?prx,[]) of {ok,{prompt,?password},_} -> ok = ct_telnet_client:send_data(Pid,Password), - Stars = lists:duplicate(length(Password),$*), + Stars = + lists:duplicate(string:length(Password),$*), log(Name,send,"Password: ~s",[Stars]), % ok = ct_telnet_client:send_data(Pid,""), case ct_telnet:silent_teln_expect(Name,Pid,[], diff --git a/lib/common_test/src/vts.erl b/lib/common_test/src/vts.erl index 83fcde2f48..2bf3e82ade 100644 --- a/lib/common_test/src/vts.erl +++ b/lib/common_test/src/vts.erl @@ -919,7 +919,7 @@ get_input_data(Input,Key)-> end. parse(Input) -> - httpd:parse_query(Input). + uri_string:dissect_query(Input). vts_integer_to_list(X) when is_atom(X) -> atom_to_list(X); diff --git a/lib/common_test/test/ct_config_SUITE.erl b/lib/common_test/test/ct_config_SUITE.erl index 250700741c..5ffc735d6a 100644 --- a/lib/common_test/test/ct_config_SUITE.erl +++ b/lib/common_test/test/ct_config_SUITE.erl @@ -213,8 +213,8 @@ reformat_events(Events, EH) -> skip_dynamic() -> case os:getenv("TS_EXTRA_PLATFORM_LABEL") of TSExtraPlatformLabel when is_list(TSExtraPlatformLabel) -> - case string:str(TSExtraPlatformLabel,"TimeWarpingOS") of - 0 -> false; + case string:find(TSExtraPlatformLabel,"TimeWarpingOS") of + nomatch -> false; _ -> true end; _ -> diff --git a/lib/common_test/test/ct_hooks_SUITE.erl b/lib/common_test/test/ct_hooks_SUITE.erl index 8ba14e63bc..3c1e887f65 100644 --- a/lib/common_test/test/ct_hooks_SUITE.erl +++ b/lib/common_test/test/ct_hooks_SUITE.erl @@ -257,7 +257,7 @@ cth_log(Config) when is_list(Config) -> lists:foreach( fun(UnexpIoLog) -> {ok,Bin} = file:read_file(UnexpIoLog), - Ts = string:tokens(binary_to_list(Bin),[$\n]), + Ts = string:lexemes(binary_to_list(Bin),[$\n]), Matches = lists:foldl(fun([$=,$E,$R,$R,$O,$R|_], N) -> N+1; ([$L,$o,$g,$g,$e,$r|_], N) -> diff --git a/lib/common_test/test/ct_log_SUITE.erl b/lib/common_test/test/ct_log_SUITE.erl index 93affda398..9655b6f09a 100644 --- a/lib/common_test/test/ct_log_SUITE.erl +++ b/lib/common_test/test/ct_log_SUITE.erl @@ -174,7 +174,7 @@ verify(Config) -> TcLogFile = proplists:get_value(the_logfile, SavedCfg), Pid = proplists:get_value(the_pid, SavedCfg), StrPid = lists:flatten(io_lib:format("~p",[Pid])), - EscPid = "<" ++ string:substr(StrPid, 2, length(StrPid)-2) ++ ">", + EscPid = "<" ++ string:slice(StrPid, 1, length(StrPid)-2) ++ ">", String = proplists:get_value(the_string, SavedCfg), ct:log("Read from prev testcase: ~p & ~p", [TcLogFile,Pid]), {ok,Dev} = file:open(TcLogFile, [read]), diff --git a/lib/common_test/test/ct_netconfc_SUITE_data/ns.erl b/lib/common_test/test/ct_netconfc_SUITE_data/ns.erl index 63bf9be134..975f6cafcb 100644 --- a/lib/common_test/test/ct_netconfc_SUITE_data/ns.erl +++ b/lib/common_test/test/ct_netconfc_SUITE_data/ns.erl @@ -231,8 +231,7 @@ data_for_channel(CM, Ch, Data, State) -> {ok, NewState} end catch - Class:Reason -> - Stacktrace = erlang:get_stacktrace(), + Class:Reason:Stacktrace -> error_logger:error_report([{?MODULE, data_for_channel}, {request, Data}, {buffer, State#session.buffer}, diff --git a/lib/common_test/test/ct_pre_post_test_io_SUITE.erl b/lib/common_test/test/ct_pre_post_test_io_SUITE.erl index 7ffe6f045b..0b85392009 100644 --- a/lib/common_test/test/ct_pre_post_test_io_SUITE.erl +++ b/lib/common_test/test/ct_pre_post_test_io_SUITE.erl @@ -164,7 +164,7 @@ pre_post_io(Config) -> fun(PrePostIoFile) -> ct:log("Reading Pre/Post Test IO Log file: ~ts", [PrePostIoFile]), {ok,Bin} = file:read_file(PrePostIoFile), - Ts = string:tokens(binary_to_list(Bin),[$\n]), + Ts = string:lexemes(binary_to_list(Bin),[$\n]), PrePostIOEntries = lists:foldl(fun([$L,$o,$g,$g,$e,$r|_], {pre,PreLogN,PreErrN,0,0}) -> @@ -203,7 +203,7 @@ pre_post_io(Config) -> fun(UnexpIoFile) -> ct:log("Reading Unexpected IO Log file: ~ts", [UnexpIoFile]), {ok,Bin} = file:read_file(UnexpIoFile), - Ts = string:tokens(binary_to_list(Bin),[$\n]), + Ts = string:lexemes(binary_to_list(Bin),[$\n]), UnexpIOEntries = lists:foldl(fun([$L,$o,$g,$g,$e,$r|_], [LogN,ErrN]) -> [LogN+1,ErrN]; diff --git a/lib/common_test/test/ct_priv_dir_SUITE_data/priv_dir_SUITE.erl b/lib/common_test/test/ct_priv_dir_SUITE_data/priv_dir_SUITE.erl index 1b171801a3..b1d191873d 100644 --- a/lib/common_test/test/ct_priv_dir_SUITE_data/priv_dir_SUITE.erl +++ b/lib/common_test/test/ct_priv_dir_SUITE_data/priv_dir_SUITE.erl @@ -126,12 +126,12 @@ default(Config) -> auto_per_tc(Config) -> PrivDir = proplists:get_value(priv_dir, Config), - ["log_private",_] = string:tokens(filename:basename(PrivDir), "."), + ["log_private",_] = string:lexemes(filename:basename(PrivDir), "."), {ok,_} = file:list_dir(PrivDir). manual_per_tc(Config) -> PrivDir = proplists:get_value(priv_dir, Config), - ["log_private",_] = string:tokens(filename:basename(PrivDir), "."), + ["log_private",_] = string:lexemes(filename:basename(PrivDir), "."), {error,_} = file:list_dir(PrivDir), ok = ct:make_priv_dir(), {ok,_} = file:list_dir(PrivDir). diff --git a/lib/common_test/test/ct_test_support.erl b/lib/common_test/test/ct_test_support.erl index 44c27e54c2..2ba7c7c13f 100644 --- a/lib/common_test/test/ct_test_support.erl +++ b/lib/common_test/test/ct_test_support.erl @@ -88,7 +88,7 @@ start_slave(Config, Level) -> start_slave(ct, Config, Level). start_slave(NodeName, Config, Level) -> - [_,Host] = string:tokens(atom_to_list(node()), "@"), + [_,Host] = string:lexemes(atom_to_list(node()), "@"), test_server:format(0, "Trying to start ~s~n", [atom_to_list(NodeName)++"@"++Host]), PR = proplists:get_value(printable_range,Config,io:printable_range()), @@ -1088,8 +1088,8 @@ locate({TEH,Name,{'DEF','RUNDIR'}}, Node, [Ev|Evs], Config) -> {TEH,#event{name=Name, node=Node, data=EvData}} -> {_,{_,LogDir}} = lists:keysearch(logdir, 1, get_opts(Config)), D = filename:join(LogDir, "ct_run." ++ atom_to_list(Node)), - case string:str(EvData, D) of - 0 -> exit({badmatch,EvData}); + case string:find(EvData, D) of + nomatch -> exit({badmatch,EvData}); _ -> ok end, {Config,Evs}; @@ -1104,8 +1104,8 @@ locate({TEH,Name,{'DEF',{'START_TIME','LOGDIR'}}}, Node, [Ev|Evs], Config) -> {DT={{_,_,_},{_,_,_}},Dir} when is_list(Dir) -> {_,{_,LogDir}} = lists:keysearch(logdir, 1, get_opts(Config)), D = filename:join(LogDir, "ct_run." ++ atom_to_list(Node)), - case string:str(Dir, D) of - 0 -> exit({badmatch,Dir}); + case string:find(Dir, D) of + nomatch -> exit({badmatch,Dir}); _ -> ok end, {[{start_time,DT}|Config],Evs}; @@ -1373,7 +1373,7 @@ delete_dirs(LogDir) -> Dirs2Del = lists:foldl(fun(Dir, Del) -> [S,Mi,H,D,Mo,Y|_] = - lists:reverse(string:tokens(Dir, [$.,$-,$_])), + lists:reverse(string:lexemes(Dir, [$.,$-,$_])), S2I = fun(Str) -> list_to_integer(Str) end, DT = {{S2I(Y),S2I(Mo),S2I(D)}, {S2I(H),S2I(Mi),S2I(S)}}, Then = calendar:datetime_to_gregorian_seconds(DT), diff --git a/lib/common_test/test/ct_unicode_SUITE.erl b/lib/common_test/test/ct_unicode_SUITE.erl index 355503a5dc..6f6ec97ceb 100644 --- a/lib/common_test/test/ct_unicode_SUITE.erl +++ b/lib/common_test/test/ct_unicode_SUITE.erl @@ -191,7 +191,7 @@ check_logs(Dirs) -> [] -> ok; Match -> - MatchStr = string:join(Match,"\n"), + MatchStr = lists:join("\n",Match), ct:log("ERROR: Escaped unicode characters found in:~n~ts",[MatchStr]), ct:fail(escaped_unicode_characters_found) end. diff --git a/lib/common_test/test/ct_unicode_SUITE_data/unicode_atoms_SUITE.erl b/lib/common_test/test/ct_unicode_SUITE_data/unicode_atoms_SUITE.erl index 993452500e..041c13cdbd 100644 --- a/lib/common_test/test/ct_unicode_SUITE_data/unicode_atoms_SUITE.erl +++ b/lib/common_test/test/ct_unicode_SUITE_data/unicode_atoms_SUITE.erl @@ -77,7 +77,7 @@ all() -> 'fail_αβ_4'(_Config) -> ct:log("This is test case ~tw",[?FUNCTION_NAME]), - S = try throw(ok) catch throw:ok -> erlang:get_stacktrace() end, + S = try throw(ok) catch throw:ok:Stacktrace -> Stacktrace end, erlang:raise(error,{error,testcase,?FUNCTION_NAME},S), ok. diff --git a/lib/common_test/test/ct_userconfig_callback.erl b/lib/common_test/test/ct_userconfig_callback.erl index c723f4ca1c..14e3d9a688 100644 --- a/lib/common_test/test/ct_userconfig_callback.erl +++ b/lib/common_test/test/ct_userconfig_callback.erl @@ -21,7 +21,7 @@ -export([check_parameter/1, read_config/1]). read_config(Str) -> - KeyVals = string:tokens(Str, " "), + KeyVals = string:lexemes(Str, " "), {ok,read_config1(KeyVals)}. read_config1([Key,Val | KeyVals]) -> diff --git a/lib/common_test/test/erl2html2_SUITE.erl b/lib/common_test/test/erl2html2_SUITE.erl index 53a63578b2..b2336ff0bc 100644 --- a/lib/common_test/test/erl2html2_SUITE.erl +++ b/lib/common_test/test/erl2html2_SUITE.erl @@ -214,10 +214,10 @@ check_line_number(Last,Line,OrigLine) -> [$>|Rest] = lists:dropwhile(fun($>) -> false; (_) -> true end,Line), check_line_number(Last,Rest,OrigLine); _ -> - [N |_] = string:tokens(Line,":"), + [N |_] = string:lexemes(Line,":"), % erlang:display(N), Num = - try list_to_integer(string:strip(N)) + try list_to_integer(string:trim(N,both,"\s")) catch _:_ -> ct:fail({no_line_number_after,Last,OrigLine}) end, if Num == Last+1 -> diff --git a/lib/common_test/test/telnet_server.erl b/lib/common_test/test/telnet_server.erl index 65300b0bdf..cef7784333 100644 --- a/lib/common_test/test/telnet_server.erl +++ b/lib/common_test/test/telnet_server.erl @@ -249,7 +249,7 @@ do_handle_data("echo " ++ Data,State) -> send(Data++"\r\n> ",State), {ok,State}; do_handle_data("echo_sep " ++ Data,State) -> - Msgs = string:tokens(Data," "), + Msgs = string:lexemes(Data," "), lists:foreach(fun(Msg) -> send(Msg,State), timer:sleep(10) @@ -260,28 +260,28 @@ do_handle_data("echo_no_prompt " ++ Data,State) -> send(Data,State), {ok,State}; do_handle_data("echo_ml " ++ Data,State) -> - Lines = string:tokens(Data," "), - ReturnData = string:join(Lines,"\n"), + Lines = string:lexemes(Data," "), + ReturnData = lists:flatten(lists:join("\n",Lines)), send(ReturnData++"\r\n> ",State), {ok,State}; do_handle_data("echo_ml_no_prompt " ++ Data,State) -> - Lines = string:tokens(Data," "), - ReturnData = string:join(Lines,"\n"), + Lines = string:lexemes(Data," "), + ReturnData = lists:flatten(lists:join("\n",Lines)), send(ReturnData,State), {ok,State}; do_handle_data("echo_loop " ++ Data,State) -> - [TStr|Lines] = string:tokens(Data," "), - ReturnData = string:join(Lines,"\n"), + [TStr|Lines] = string:lexemes(Data," "), + ReturnData = lists:flatten(lists:join("\n",Lines)), send_loop(list_to_integer(TStr),ReturnData,State), {ok,State}; do_handle_data("echo_delayed_prompt "++Data,State) -> - [MsStr|EchoData] = string:tokens(Data, " "), - send(string:join(EchoData,"\n"),State), + [MsStr|EchoData] = string:lexemes(Data, " "), + send(lists:flatten(lists:join("\n",EchoData)),State), timer:sleep(list_to_integer(MsStr)), send("\r\n> ",State), {ok,State}; do_handle_data("disconnect_after " ++WaitStr,State) -> - Wait = list_to_integer(string:strip(WaitStr,right,$\n)), + Wait = list_to_integer(string:trim(WaitStr,trailing,"\n")), dbg("Server will close connection in ~w ms...", [Wait]), erlang:send_after(Wait,self(),disconnect), {ok,State}; diff --git a/lib/common_test/test/test_server_SUITE.erl b/lib/common_test/test/test_server_SUITE.erl index 50d8bdd1ac..edfaea1d08 100644 --- a/lib/common_test/test/test_server_SUITE.erl +++ b/lib/common_test/test/test_server_SUITE.erl @@ -71,7 +71,7 @@ init_per_testcase(_TestCase, Config) -> %% @spec end_per_testcase(TestCase, Config0) -> %% void() | {save_config,Config1} | {fail,Reason} end_per_testcase(test_server_unicode, _Config) -> - [_,Host] = string:tokens(atom_to_list(node()), "@"), + [_,Host] = string:lexemes(atom_to_list(node()), "@"), N1 = list_to_atom("test_server_tester_latin1" ++ "@" ++ Host), N2 = list_to_atom("test_server_tester_utf8" ++ "@" ++ Host), test_server:stop_node(N1), @@ -347,7 +347,7 @@ generate_and_run_unicode_test(Config0,Encoding) -> RunDir = get_latest_run_dir(LogDir), true = filelib:is_dir(RunDir), - LowerModStr = string:to_lower(ModStr), + LowerModStr = string:lowercase(ModStr), SuiteHtml = translate_filename(LowerModStr++".src.html",Encoding), true = filelib:is_regular(filename:join(RunDir,SuiteHtml)), @@ -362,7 +362,7 @@ generate_and_run_unicode_test(Config0,Encoding) -> %% remote file system on master - i.e. they will use same file name %% mode as the master. start_node(Config,Name,Args) -> - [_,Host] = string:tokens(atom_to_list(node()), "@"), + [_,Host] = string:lexemes(atom_to_list(node()), "@"), ct:log("Trying to start ~w@~s~n",[Name,Host]), case test_server:start_node(Name, peer, [{args,Args}]) of {error,Reason} -> diff --git a/lib/common_test/test/test_server_test_lib.erl b/lib/common_test/test/test_server_test_lib.erl index c18b89b178..9ee946af0b 100644 --- a/lib/common_test/test/test_server_test_lib.erl +++ b/lib/common_test/test/test_server_test_lib.erl @@ -43,7 +43,7 @@ pre_init_per_testcase(_TC,Config,State) -> {start_slave(Config, 50),State}. start_slave(Config,_Level) -> - [_,Host] = string:tokens(atom_to_list(node()), "@"), + [_,Host] = string:lexemes(atom_to_list(node()), "@"), ct:log("Trying to start ~s~n", ["test_server_tester@"++Host]), @@ -121,7 +121,7 @@ parse_suite(FileName) -> end. fline(Fd) -> - case prim_file:read_line(Fd) of + case file:read_line(Fd) of eof -> eof; {ok, Line} -> Line end. diff --git a/lib/common_test/test_server/ts.erl b/lib/common_test/test_server/ts.erl index 5bfea9f4de..330652e73f 100644 --- a/lib/common_test/test_server/ts.erl +++ b/lib/common_test/test_server/ts.erl @@ -583,7 +583,7 @@ is_list_of_suites(List) -> S = if is_atom(Suite) -> atom_to_list(Suite); true -> Suite end, - try lists:last(string:tokens(S,"_")) of + try lists:last(string:lexemes(S,"_")) of "SUITE" -> true; "suite" -> true; _ -> false diff --git a/lib/common_test/test_server/ts_autoconf_win32.erl b/lib/common_test/test_server/ts_autoconf_win32.erl index 52e5ac8e69..6f6caaeb70 100644 --- a/lib/common_test/test_server/ts_autoconf_win32.erl +++ b/lib/common_test/test_server/ts_autoconf_win32.erl @@ -228,7 +228,7 @@ make(Vars) -> end. find_make(MakeCmd, Vars) -> - [Make|_] = string:tokens(MakeCmd, " \t"), + [Make|_] = string:lexemes(MakeCmd, " \t"), case os:find_executable(Make) of false -> {no, Vars}; @@ -248,9 +248,9 @@ javac(Vars) -> end. is_debug_build() -> - case catch string:str(erlang:system_info(system_version), "debug") of - Int when is_integer(Int), Int > 0 -> - true; - _ -> - false + case catch string:find(erlang:system_info(system_version), "debug") of + nomatch -> + false; + _Else -> + true end. diff --git a/lib/common_test/test_server/ts_erl_config.erl b/lib/common_test/test_server/ts_erl_config.erl index 032593bdda..c7fe4ccf83 100644 --- a/lib/common_test/test_server/ts_erl_config.erl +++ b/lib/common_test/test_server/ts_erl_config.erl @@ -311,7 +311,7 @@ lib_dir(Vars, Lib) -> end, CLibDir = filename:join(CLibDirList), Cmd = "ls -d " ++ CLibDir ++ "*", - XLibDir = lists:last(string:tokens(os:cmd(Cmd),"\n")), + XLibDir = lists:last(string:lexemes(os:cmd(Cmd),"\n")), case file:list_dir(XLibDir) of {error, enoent} -> []; @@ -361,15 +361,11 @@ emu_vars(Vars) -> {erl_name, atom_to_list(lib:progname())}|Vars]. is_source_build() -> - string:str(erlang:system_info(system_version), "[source]") > 0. + string:find(erlang:system_info(system_version), "source") =/= nomatch. is_debug_build() -> - case catch string:str(erlang:system_info(system_version), "debug") of - Int when is_integer(Int), Int > 0 -> - true; - _ -> - false - end. + string:find(erlang:system_info(system_version), "debug") =/= nomatch. + %% %% ssl_libdir %% diff --git a/lib/common_test/test_server/ts_install.erl b/lib/common_test/test_server/ts_install.erl index c4e0223ac7..048e5493d2 100644 --- a/lib/common_test/test_server/ts_install.erl +++ b/lib/common_test/test_server/ts_install.erl @@ -115,7 +115,7 @@ get_vars(_, _, _, _) -> config_flags() -> case os:getenv("CONFIG_FLAGS") of false -> []; - CF -> string:tokens(CF, " \t\n") + CF -> string:lexemes(CF, " \t\n") end. unix_autoconf(XConf) -> @@ -127,7 +127,7 @@ unix_autoconf(XConf) -> Threads = [" --enable-shlib-thread-safety" || erlang:system_info(threads) /= false], Debug = [" --enable-debug-mode" || - string:str(erlang:system_info(system_version),"debug") > 0], + string:find(erlang:system_info(system_version),"debug") =/= nomatch], MXX_Build = [Y || Y <- config_flags(), Y == "--enable-m64-build" orelse Y == "--enable-m32-build"], @@ -159,10 +159,8 @@ assign_vars([]) -> assign_vars([{VAR,FlagsStr} | VARs]) -> [{VAR,assign_vars(FlagsStr)} | assign_vars(VARs)]; assign_vars(FlagsStr) -> - Flags = [assign_all_vars(Str,[]) || Str <- string:tokens(FlagsStr, [$ ])], - string:strip(lists:flatten(lists:map(fun(Flag) -> - Flag ++ " " - end, Flags)), right). + Flags = [assign_all_vars(Str,[]) || Str <- string:lexemes(FlagsStr, [$\s])], + lists:flatten(lists:join(" ", Flags)). assign_all_vars([$$ | Rest], FlagSoFar) -> {VarName,Rest1} = get_var_name(Rest, []), @@ -292,7 +290,7 @@ add_vars(Vars0, Opts0) -> get_testcase_callback() -> case os:getenv("TS_TESTCASE_CALLBACK") of ModFunc when is_list(ModFunc), ModFunc /= "" -> - case string:tokens(ModFunc, " ") of + case string:lexemes(ModFunc, " ") of [_Mod,_Func] -> ModFunc; _ -> "" end; @@ -408,17 +406,13 @@ off_heap_msgq() -> end. schedulers() -> - case catch erlang:system_info(smp_support) of - true -> - case {erlang:system_info(schedulers), - erlang:system_info(schedulers_online)} of - {S,S} -> - "/S"++integer_to_list(S); - {S,O} -> - "/S"++integer_to_list(S) ++ ":" ++ - integer_to_list(O) - end; - _ -> "" + case {erlang:system_info(schedulers), + erlang:system_info(schedulers_online)} of + {S,S} -> + "/S"++integer_to_list(S); + {S,O} -> + "/S"++integer_to_list(S) ++ ":" ++ + integer_to_list(O) end. bind_type() -> @@ -434,8 +428,8 @@ bind_type() -> debug() -> - case string:str(erlang:system_info(system_version), "debug") of - 0 -> ""; + case string:find(erlang:system_info(system_version), "debug") of + nomatch -> ""; _ -> "/Debug" end. diff --git a/lib/common_test/test_server/ts_install_cth.erl b/lib/common_test/test_server/ts_install_cth.erl index 5d325b1115..35a5ec916c 100644 --- a/lib/common_test/test_server/ts_install_cth.erl +++ b/lib/common_test/test_server/ts_install_cth.erl @@ -108,8 +108,7 @@ pre_init_per_suite(_Suite,Config,State) -> {add_node_name(Config, State), State} catch error:{badmatch,{error,enoent}} -> {add_node_name(Config, State), State}; - Error:Reason -> - Stack = erlang:get_stacktrace(), + Error:Reason:Stack -> ct:pal("~p failed! ~p:{~p,~p}",[?MODULE,Error,Reason,Stack]), {{fail,{?MODULE,{Error,Reason, Stack}}},State} end. diff --git a/lib/common_test/test_server/ts_lib.erl b/lib/common_test/test_server/ts_lib.erl index ea039a2c2b..da8d676b18 100644 --- a/lib/common_test/test_server/ts_lib.erl +++ b/lib/common_test/test_server/ts_lib.erl @@ -99,7 +99,7 @@ specialized_specs(Dir,PostFix) -> sort_tests([begin DirPart = filename:dirname(Name), AppTest = hd(lists:reverse(filename:split(DirPart))), - list_to_atom(string:substr(AppTest, 1, length(AppTest)-5)) + list_to_atom(string:slice(AppTest, 0, string:length(AppTest)-5)) end || Name <- Specs]). specs(Dir) -> @@ -111,9 +111,9 @@ specs(Dir) -> [Spec,TestDir|_] = lists:reverse(filename:split(FullName)), [_TestSuffix|TDParts] = - lists:reverse(string:tokens(TestDir,[$_,$.])), + lists:reverse(string:lexemes(TestDir,[$_,$.])), [_SpecSuffix|SParts] = - lists:reverse(string:tokens(Spec,[$_,$.])), + lists:reverse(string:lexemes(Spec,[$_,$.])), if TDParts == SParts -> [filename_to_atom(FullName)]; true -> @@ -273,7 +273,7 @@ do_test(Rest, Vars, Test) -> get_arg([$(|Rest], Vars, Stop, _) -> get_arg(Rest, Vars, Stop, []); get_arg([Stop|Rest], Vars, Stop, Acc) -> - Arg = string:strip(lists:reverse(Acc)), + Arg = string:trim(lists:reverse(Acc),both,[$\s]), Subst = subst(Arg, Vars), {Subst,Rest}; get_arg([C|Rest], Vars, Stop, Acc) -> diff --git a/lib/common_test/test_server/ts_run.erl b/lib/common_test/test_server/ts_run.erl index e22fa8d196..3f594236bc 100644 --- a/lib/common_test/test_server/ts_run.erl +++ b/lib/common_test/test_server/ts_run.erl @@ -207,11 +207,7 @@ make_command(Vars, Spec, State) -> _ -> ok end, - "cerl -valgrind" ++ - case erlang:system_info(smp_support) of - true -> " -smp"; - false -> "" - end + "cerl -valgrind" end, Naming = case ts_lib:var(longnames, Vars) of @@ -468,4 +464,4 @@ split_one(Path) -> filename:split(Path). split_path(Path) -> - string:tokens(Path,";"). + string:lexemes(Path,";"). diff --git a/lib/compiler/doc/src/compile.xml b/lib/compiler/doc/src/compile.xml index 10164890f2..e4491288a6 100644 --- a/lib/compiler/doc/src/compile.xml +++ b/lib/compiler/doc/src/compile.xml @@ -123,6 +123,17 @@ in the Efficiency Guide.</p> </item> + <tag><c>{compile_info, [{atom(), term()}]}</c></tag> + <item> + <p>Allows compilers built on top of <c>compile</c> to attach + extra compilation metadata to the <c>compile_info</c> chunk + in the generated beam file.</p> + + <p>It is advised for compilers to remove all non-deterministic + information if the <c>deterministic</c> option is supported and + it was supplied by the user.</p> + </item> + <tag><c>compressed</c></tag> <item> <p>The compiler will compress the generated object code, @@ -222,6 +233,15 @@ module.beam: module.erl \ header.hrl</code> </item> + <tag><c>makedep_side_effect</c></tag> + <item> + <p>The dependecies are created as a side effect to the + normal compilation process. This means that the object + file will also be produced. This option override the + <c>makedep</c> option. + </p> + </item> + <tag><c>{makedep_output, Output}</c></tag> <item> <p>Writes generated rules to <c>Output</c> instead of the @@ -629,14 +649,6 @@ module.beam: module.erl \ <p>Turns off warnings for unused record types. Default is to emit warnings for unused locally defined record types.</p> </item> - - <tag><c>nowarn_get_stacktrace</c></tag> - <item> - <p>Turns off warnings for using <c>get_stacktrace/0</c> in a context - where it will probably not work in a future release. For example, - by default there will be a warning if <c>get_stacktrace/0</c> is - used following a <c>catch</c> expression.</p> - </item> </taglist> <p>Another class of warnings is generated by the compiler diff --git a/lib/compiler/internal_doc/cerl-notes.md b/lib/compiler/internal_doc/cerl-notes.md new file mode 100644 index 0000000000..705fe8f42d --- /dev/null +++ b/lib/compiler/internal_doc/cerl-notes.md @@ -0,0 +1,75 @@ +Some notes on the cerl modules +============================== + +Maps in cerl_clauses:match/3 +---------------------------- + +Not much optimization is done for maps in `cerl_clauses:match/3`. + +The reason is that the inliner (`cerl_inline`) was not designed for +data types that depend on variables bound in the enclosing environment +(for example, the keys for maps). If we attempt to extend the +optimizations for maps similar to the optimizations for the other data +types, the inliner will crash for certain code. Here is an example of +code that would crash the inliner: + + t() -> + f(key). + + f(K) -> + case #{K => value} of + #{key := V} -> V + end. + +The reason for the crash is that the inliner works in several +passes and calls `cerl_clauses:match/3` twice. The inliner will +assume that the same result will be returned both times, but +for this example different bindings will be returned. + +Here is the rough outline of what happens: + +* The first time `cerl_clauses:match/3` will be asked to match the +pattern `#{K := V}` against `#{key => value}`. It cannot say more +than that the pattern *may* match. + +* Now the inliner will add the bindings to body of the clause (which +is simply `V`). In this case, the bindings are still empty, so +nothing is added. + +* The inliner will now do some substitutions and renaming. The +variable `K` will be replaced with `key`. + +* The next time `cerl_clauses:match/3` is called, it will be asked to +match the pattern `#{key := V}` against `#{key => value#}`. In this +case, there will be a match and the bindings can be extended with +`{V,value}`. + +* The inliner will see that the entire case can be removed. Only +the body for the clause needs to be kept. + +Thus, after inlining the function `t/0` will look like this: + + t() -> + V. + +The problem here is that the inliner assumed that the bindings from +the first and second call to `cer_clauses:match/3` would be the same. +It used the empty bindings from the first call for the body. + +The correct way would be to add the bindings from the second call: + + t() -> + let V = value in V. + +### How to fix this ### + +The inliner will need to call `cerl_clauses:match/3` after doing +all substitutions and renaming. It is not clear to me how difficult +that would be. I assume that the inliner is written the way it is +for a good reason. That means that switching the order things are +done would lead to correctness and/or performance problems. + +### What must also be done to fix this ### + +`cerl_inline:make_template/3` must be extended to create a template +for maps. That is relatively straightforward. diff --git a/lib/compiler/src/Makefile b/lib/compiler/src/Makefile index ef6db66ff6..c81b81e82b 100644 --- a/lib/compiler/src/Makefile +++ b/lib/compiler/src/Makefile @@ -83,6 +83,7 @@ MODULES = \ core_scan \ erl_bifs \ rec_env \ + sys_core_alias \ sys_core_bsm \ sys_core_dsetel \ sys_core_fold \ @@ -92,16 +93,14 @@ MODULES = \ v3_codegen \ v3_core \ v3_kernel \ - v3_kernel_pp \ - v3_life + v3_kernel_pp BEAM_H = $(wildcard ../priv/beam_h/*.h) HRL_FILES= \ beam_disasm.hrl \ core_parse.hrl \ - v3_kernel.hrl \ - v3_life.hrl + v3_kernel.hrl YRL_FILE = core_parse.yrl @@ -186,20 +185,19 @@ release_docs_spec: # ---------------------------------------------------- $(EBIN)/beam_disasm.beam: $(EGEN)/beam_opcodes.hrl beam_disasm.hrl -$(EBIN)/beam_listing.beam: v3_life.hrl -$(EBIN)/beam_validator.beam: beam_disasm.hrl +$(EBIN)/beam_listing.beam: core_parse.hrl v3_kernel.hrl $(EBIN)/cerl.beam: core_parse.hrl $(EBIN)/compile.beam: core_parse.hrl ../../stdlib/include/erl_compile.hrl $(EBIN)/core_lib.beam: core_parse.hrl $(EBIN)/core_lint.beam: core_parse.hrl $(EBIN)/core_parse.beam: core_parse.hrl $(EGEN)/core_parse.erl $(EBIN)/core_pp.beam: core_parse.hrl +$(EBIN)/sys_core_alias.beam: core_parse.hrl $(EBIN)/sys_core_dsetel.beam: core_parse.hrl $(EBIN)/sys_core_fold.beam: core_parse.hrl $(EBIN)/sys_core_fold_lists.beam: core_parse.hrl $(EBIN)/sys_core_inline.beam: core_parse.hrl -$(EBIN)/v3_codegen.beam: v3_life.hrl +$(EBIN)/v3_codegen.beam: v3_kernel.hrl $(EBIN)/v3_core.beam: core_parse.hrl $(EBIN)/v3_kernel.beam: core_parse.hrl v3_kernel.hrl $(EBIN)/v3_kernel_pp.beam: v3_kernel.hrl -$(EBIN)/v3_life.beam: v3_kernel.hrl v3_life.hrl diff --git a/lib/compiler/src/beam_a.erl b/lib/compiler/src/beam_a.erl index cdb32d5d55..91acb19971 100644 --- a/lib/compiler/src/beam_a.erl +++ b/lib/compiler/src/beam_a.erl @@ -42,8 +42,7 @@ function({function,Name,Arity,CLabel,Is0}) -> Is = beam_jump:remove_unused_labels(Is1), {function,Name,Arity,CLabel,Is} catch - Class:Error -> - Stack = erlang:get_stacktrace(), + Class:Error:Stack -> io:fwrite("Function: ~w/~w\n", [Name,Arity]), erlang:raise(Class, Error, Stack) end. @@ -59,8 +58,17 @@ rename_instrs([{call_only,A,F}|Is]) -> rename_instrs([{call_ext_only,A,F}|Is]) -> [{call_ext,A,F},return|rename_instrs(Is)]; rename_instrs([{'%live',_}|Is]) -> - %% When compiling from old .S files. + %% Ignore old type of live annotation. Only happens when compiling + %% from very old .S files. rename_instrs(Is); +rename_instrs([{get_list,S,D1,D2}|Is]) -> + %% Only happens when compiling from old .S files. + if + D1 =:= S -> + [{get_tl,S,D2},{get_hd,S,D1}|rename_instrs(Is)]; + true -> + [{get_hd,S,D1},{get_tl,S,D2}|rename_instrs(Is)] + end; rename_instrs([I|Is]) -> [rename_instr(I)|rename_instrs(Is)]; rename_instrs([]) -> []. diff --git a/lib/compiler/src/beam_asm.erl b/lib/compiler/src/beam_asm.erl index f7c838e392..5ef340c831 100644 --- a/lib/compiler/src/beam_asm.erl +++ b/lib/compiler/src/beam_asm.erl @@ -21,10 +21,10 @@ -module(beam_asm). --export([module/5]). +-export([module/4]). -export([encode/2]). --export_type([fail/0,label/0,reg/0,src/0,module_code/0,function_name/0]). +-export_type([fail/0,label/0,reg/0,reg_num/0,src/0,module_code/0,function_name/0]). -import(lists, [map/2,member/2,keymember/3,duplicate/2,splitwith/2]). -include("beam_opcodes.hrl"). @@ -55,20 +55,20 @@ -type module_code() :: {module(),[_],[_],[asm_function()],pos_integer()}. --spec module(module_code(), [{binary(), binary()}], [_], [compile:option()], [compile:option()]) -> +-spec module(module_code(), [{binary(), binary()}], [{atom(),term()}], [compile:option()]) -> {'ok',binary()}. -module(Code, ExtraChunks, SourceFile, Opts, CompilerOpts) -> - {ok,assemble(Code, ExtraChunks, SourceFile, Opts, CompilerOpts)}. +module(Code, ExtraChunks, CompileInfo, CompilerOpts) -> + {ok,assemble(Code, ExtraChunks, CompileInfo, CompilerOpts)}. -assemble({Mod,Exp0,Attr0,Asm0,NumLabels}, ExtraChunks, SourceFile, Opts, CompilerOpts) -> +assemble({Mod,Exp0,Attr0,Asm0,NumLabels}, ExtraChunks, CompileInfo, 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, ExtraChunks, SourceFile, Opts, CompilerOpts). + build_file(Code, Attr, Dict2, NumLabels, NumFuncs, ExtraChunks, CompileInfo, CompilerOpts). on_load(Fs0, Attr0) -> case proplists:get_value(on_load, Attr0) of @@ -111,7 +111,7 @@ assemble_function([H|T], Acc, Dict0) -> assemble_function([], Code, Dict) -> {Code, Dict}. -build_file(Code, Attr, Dict, NumLabels, NumFuncs, ExtraChunks, SourceFile, Opts, CompilerOpts) -> +build_file(Code, Attr, Dict, NumLabels, NumFuncs, ExtraChunks, CompileInfo, CompilerOpts) -> %% Create the code chunk. CodeChunk = chunk(<<"Code">>, @@ -182,8 +182,7 @@ build_file(Code, Attr, Dict, NumLabels, NumFuncs, ExtraChunks, SourceFile, Opts, Essentials1 = [iolist_to_binary(C) || C <- Essentials0], MD5 = module_md5(Essentials1), Essentials = finalize_fun_table(Essentials1, MD5), - {Attributes,Compile} = build_attributes(Opts, CompilerOpts, SourceFile, - Attr, MD5), + {Attributes,Compile} = build_attributes(Attr, CompileInfo, MD5), AttrChunk = chunk(<<"Attr">>, Attributes), CompileChunk = chunk(<<"CInf">>, Compile), @@ -193,7 +192,7 @@ build_file(Code, Attr, Dict, NumLabels, NumFuncs, ExtraChunks, SourceFile, Opts, %% Create IFF chunk. - Chunks = case member(slim, Opts) of + Chunks = case member(slim, CompilerOpts) of true -> [Essentials,AttrChunk]; false -> @@ -241,9 +240,7 @@ build_form(Id, Chunks0) when byte_size(Id) =:= 4, is_list(Chunks0) -> chunk(Id, Contents) when byte_size(Id) =:= 4, is_binary(Contents) -> Size = byte_size(Contents), - [<<Id/binary,Size:32>>,Contents|pad(Size)]; -chunk(Id, Contents) when is_list(Contents) -> - chunk(Id, list_to_binary(Contents)). + [<<Id/binary,Size:32>>,Contents|pad(Size)]. %% Build a correctly padded chunk (with a sub-header). @@ -265,22 +262,10 @@ flatten_exports(Exps) -> flatten_imports(Imps) -> list_to_binary(map(fun({M,F,A}) -> <<M:32,F:32,A:32>> end, Imps)). -build_attributes(Opts, CompilerOpts, SourceFile, Attr, MD5) -> - Misc0 = case SourceFile of - [] -> []; - [_|_] -> [{source,SourceFile}] - end, - Misc = case member(slim, CompilerOpts) of - false -> Misc0; - true -> [] - end, - Compile = case member(deterministic, CompilerOpts) of - false -> - [{options,Opts},{version,?COMPILER_VSN}|Misc]; - true -> - [{version,?COMPILER_VSN}] - end, - {term_to_binary(set_vsn_attribute(Attr, MD5)),term_to_binary(Compile)}. +build_attributes(Attr, Compile, MD5) -> + AttrBinary = term_to_binary(set_vsn_attribute(Attr, MD5)), + CompileBinary = term_to_binary([{version,?COMPILER_VSN}|Compile]), + {AttrBinary,CompileBinary}. build_line_table(Dict) -> {NumLineInstrs,NumFnames0,Fnames0,NumLines,Lines0} = @@ -422,7 +407,17 @@ encode_arg({atom, Atom}, Dict0) when is_atom(Atom) -> {Index, Dict} = beam_dict:atom(Atom, Dict0), {encode(?tag_a, Index), Dict}; encode_arg({integer, N}, Dict) -> - {encode(?tag_i, N), Dict}; + %% Conservatily assume that all integers whose absolute + %% value is greater than 1 bsl 128 will be bignums in + %% the runtime system. + if + N >= 1 bsl 128 -> + encode_arg({literal, N}, Dict); + N =< -(1 bsl 128) -> + encode_arg({literal, N}, Dict); + true -> + {encode(?tag_i, N), Dict} + end; encode_arg(nil, Dict) -> {encode(?tag_a, 0), Dict}; encode_arg({f, W}, Dict) -> @@ -480,7 +475,7 @@ encode_alloc_list_1([{floats,Floats}|T], Dict, Acc0) -> encode_alloc_list_1([], Dict, Acc) -> {iolist_to_binary(Acc),Dict}. --spec encode(non_neg_integer(), pos_integer()) -> iodata(). +-spec encode(non_neg_integer(), integer()) -> iodata(). encode(Tag, N) when N < 0 -> encode1(Tag, negative_to_bytes(N)); diff --git a/lib/compiler/src/beam_block.erl b/lib/compiler/src/beam_block.erl index 6543e05e20..8cd271e1dc 100644 --- a/lib/compiler/src/beam_block.erl +++ b/lib/compiler/src/beam_block.erl @@ -23,30 +23,36 @@ -module(beam_block). -export([module/2]). --import(lists, [reverse/1,reverse/2,foldl/3,member/2]). +-import(lists, [reverse/1,reverse/2,member/2]). -spec module(beam_utils:module_code(), [compile:option()]) -> {'ok',beam_utils:module_code()}. -module({Mod,Exp,Attr,Fs0,Lc}, _Opt) -> - Fs = [function(F) || F <- Fs0], +module({Mod,Exp,Attr,Fs0,Lc}, Opts) -> + Blockify = not member(no_blockify, Opts), + Fs = [function(F, Blockify) || F <- Fs0], {ok,{Mod,Exp,Attr,Fs,Lc}}. -function({function,Name,Arity,CLabel,Is0}) -> +function({function,Name,Arity,CLabel,Is0}, Blockify) -> try %% Collect basic blocks and optimize them. - Is1 = blockify(Is0), - Is2 = embed_lines(Is1), - Is3 = move_allocates(Is2), - Is4 = beam_utils:live_opt(Is3), - Is5 = opt_blocks(Is4), - Is6 = beam_utils:delete_live_annos(Is5), - - %% Done. - {function,Name,Arity,CLabel,Is6} + Is1 = case Blockify of + false -> Is0; + true -> blockify(Is0) + end, + Is2 = embed_lines(Is1), + Is3 = local_cse(Is2), + Is4 = beam_utils:anno_defs(Is3), + Is5 = move_allocates(Is4), + Is6 = beam_utils:live_opt(Is5), + Is7 = opt_blocks(Is6), + Is8 = beam_utils:delete_annos(Is7), + Is = opt_allocs(Is8), + + %% Done. + {function,Name,Arity,CLabel,Is} catch - Class:Error -> - Stack = erlang:get_stacktrace(), + Class:Error:Stack -> io:fwrite("Function: ~w/~w\n", [Name,Arity]), erlang:raise(Class, Error, Stack) end. @@ -102,7 +108,8 @@ collect({put_tuple,A,D}) -> {set,[D],[],{put_tuple,A}}; collect({put,S}) -> {set,[],[S],put}; collect({get_tuple_element,S,I,D}) -> {set,[D],[S],{get_tuple_element,I}}; collect({set_tuple_element,S,D,I}) -> {set,[],[S,D],{set_tuple_element,I}}; -collect({get_list,S,D1,D2}) -> {set,[D1,D2],[S],get_list}; +collect({get_hd,S,D}) -> {set,[D],[S],get_hd}; +collect({get_tl,S,D}) -> {set,[D],[S],get_tl}; collect(remove_message) -> {set,[],[],remove_message}; collect({put_map,F,Op,S,D,R,{list,Puts}}) -> {set,[D],[S|Puts],{alloc,R,{put_map,Op,F}}}; @@ -130,23 +137,27 @@ embed_lines([{block,B2},{line,_}=Line,{block,B1}|T], Acc) -> embed_lines([{block,B1},{line,_}=Line|T], Acc) -> B = {block,[{set,[],[],Line}|B1]}, embed_lines([B|T], Acc); +embed_lines([{block,B2},{block,B1}|T], Acc) -> + %% This can only happen when beam_block is run for + %% the second time. + B = {block,B1++B2}, + embed_lines([B|T], Acc); embed_lines([I|Is], Acc) -> embed_lines(Is, [I|Acc]); embed_lines([], Acc) -> Acc. opt_blocks([{block,Bl0}|Is]) -> %% The live annotation at the beginning is not useful. - [{'%live',_,_}|Bl] = Bl0, + [{'%anno',_}|Bl] = Bl0, [{block,opt_block(Bl)}|opt_blocks(Is)]; opt_blocks([I|Is]) -> [I|opt_blocks(Is)]; opt_blocks([]) -> []. opt_block(Is0) -> - Is = find_fixpoint(fun(Is) -> - opt_tuple_element(opt(Is)) - end, Is0), - opt_alloc(Is). + find_fixpoint(fun(Is) -> + opt_tuple_element(opt(Is)) + end, Is0). find_fixpoint(OptFun, Is0) -> case OptFun(Is0) of @@ -173,7 +184,7 @@ find_fixpoint(OptFun, Is0) -> %% safe to assume that if x(N) is initialized, then all lower-numbered %% x registers are also initialized. %% -%% For example, in general it is not safe to transform the following +%% For example, we must be careful when transforming the following %% instructions: %% %% get_tuple_element x(0) Element => x(1) @@ -185,13 +196,9 @@ find_fixpoint(OptFun, Is0) -> %% get_tuple_element x(0) Element => x(1) %% %% The transformation is safe if and only if x(1) has been -%% initialized previously. Unfortunately, beam_reorder may have moved -%% a get_tuple_element instruction so that x(1) is not always -%% initialized when this code is reached. To find whether or not x(1) -%% is initialized, we would need to analyze all code preceding these -%% two instructions (across branches). Since we currently don't have -%% any practical mechanism for doing that, we will have to -%% conservatively assume that the transformation is unsafe. +%% initialized previously. We will use the annotations added by +%% beam_utils:anno_defs/1 to determine whether x(a) has been +%% initialized. move_allocates([{block,Bl0}|Is]) -> Bl = move_allocates_1(reverse(Bl0), []), @@ -200,40 +207,77 @@ move_allocates([I|Is]) -> [I|move_allocates(Is)]; move_allocates([]) -> []. -move_allocates_1([I|Is], [{set,[],[],{alloc,Live0,Info}}|Acc]=Acc0) -> - case {alloc_may_pass(I),alloc_live_regs(I, Live0)} of - {false,_} -> - move_allocates_1(Is, [I|Acc0]); - {true,not_possible} -> - move_allocates_1(Is, [I|Acc0]); - {true,Live} when is_integer(Live) -> - A = {set,[],[],{alloc,Live,Info}}, - move_allocates_1(Is, [A,I|Acc]) +move_allocates_1([{'%anno',_}|Is], Acc) -> + move_allocates_1(Is, Acc); +move_allocates_1([I|Is], [{set,[],[],{alloc,Live0,Info0}}|Acc]=Acc0) -> + case alloc_may_pass(I) of + false -> + move_allocates_1(Is, [I|Acc0]); + true -> + case alloc_live_regs(I, Is, Live0) of + not_possible -> + move_allocates_1(Is, [I|Acc0]); + Live when is_integer(Live) -> + Info = safe_info(Info0), + A = {set,[],[],{alloc,Live,Info}}, + move_allocates_1(Is, [A,I|Acc]) + end end; move_allocates_1([I|Is], Acc) -> move_allocates_1(Is, [I|Acc]); move_allocates_1([], Acc) -> Acc. +alloc_may_pass({set,_,[{fr,_}],fmove}) -> false; alloc_may_pass({set,_,_,{alloc,_,_}}) -> false; alloc_may_pass({set,_,_,{set_tuple_element,_}}) -> false; alloc_may_pass({set,_,_,put_list}) -> false; alloc_may_pass({set,_,_,put}) -> false; alloc_may_pass({set,_,_,_}) -> true. - + +safe_info({nozero,Stack,Heap,_}) -> + %% nozero is not safe if the allocation instruction is moved + %% upwards past an instruction that may throw an exception + %% (such as element/2). + {zero,Stack,Heap,[]}; +safe_info(Info) -> Info. + %% opt([Instruction]) -> [Instruction] %% Optimize the instruction stream inside a basic block. opt([{set,[X],[X],move}|Is]) -> opt(Is); +opt([{set,[Dst],_,move},{set,[Dst],[Src],move}=I|Is]) when Dst =/= Src -> + opt([I|Is]); +opt([{set,[{x,0}],[S1],move}=I1,{set,[D2],[{x,0}],move}|Is]) -> + opt([I1,{set,[D2],[S1],move}|Is]); +opt([{set,[{x,0}],[S1],move}=I1,{set,[D2],[S2],move}|Is0]) when S1 =/= D2 -> + %% Place move S x0 at the end of move sequences so that + %% loader can merge with the following instruction + {Ds,Is} = opt_moves([D2], Is0), + [{set,Ds,[S2],move}|opt([I1|Is])]; opt([{set,_,_,{line,_}}=Line1, {set,[D1],[{integer,Idx1},Reg],{bif,element,{f,0}}}=I1, {set,_,_,{line,_}}=Line2, {set,[D2],[{integer,Idx2},Reg],{bif,element,{f,0}}}=I2|Is]) when Idx1 < Idx2, D1 =/= D2, D1 =/= Reg, D2 =/= Reg -> opt([Line2,I2,Line1,I1|Is]); +opt([{set,[D1],[{integer,Idx1},Reg],{bif,element,{f,L}}}=I1, + {set,[D2],[{integer,Idx2},Reg],{bif,element,{f,L}}}=I2|Is]) + when Idx1 < Idx2, D1 =/= D2, D1 =/= Reg, D2 =/= Reg -> + opt([I2,I1|Is]); +opt([{set,Hd0,Cons,get_hd}=GetHd, + {set,Tl0,Cons,get_tl}=GetTl|Is0]) -> + case {opt_moves(Hd0, [GetTl|Is0]),opt_moves(Tl0, [GetHd|Is0])} of + {{Hd0,Is},{Tl0,_}} -> + [GetHd|opt(Is)]; + {{Hd,Is},{Tl0,_}} -> + [{set,Hd,Cons,get_hd}|opt(Is)]; + {{_,_},{Tl,Is}} -> + [{set,Tl,Cons,get_tl}|opt(Is)] + end; opt([{set,Ds0,Ss,Op}|Is0]) -> {Ds,Is} = opt_moves(Ds0, Is0), [{set,Ds,Ss,Op}|opt(Is)]; -opt([{'%live',_,_}=I|Is]) -> +opt([{'%anno',_}=I|Is]) -> [I|opt(Is)]; opt([]) -> []. @@ -245,17 +289,6 @@ opt_moves([D0]=Ds, Is0) -> case opt_move(D0, Is0) of not_possible -> {Ds,Is0}; {D1,Is} -> {[D1],Is} - end; -opt_moves([X0,Y0], Is0) -> - {X,Is2} = case opt_move(X0, Is0) of - not_possible -> {X0,Is0}; - {Y0,_} -> {X0,Is0}; - {_X1,_Is1} = XIs1 -> XIs1 - end, - case opt_move(Y0, Is2) of - not_possible -> {[X,Y0],Is2}; - {X,_} -> {[X,Y0],Is2}; - {Y,Is} -> {[X,Y],Is} end. %% opt_move(Dest, [Instruction]) -> {UpdatedDest,[Instruction]} | not_possible @@ -269,7 +302,7 @@ opt_move(Dest, Is) -> opt_move_1(R, [{set,[D],[R],move}|Is0], Acc) -> %% Provided that the source register is killed by instructions %% that follow, the optimization is safe. - case eliminate_use_of_from_reg(Is0, R, D, []) of + case eliminate_use_of_from_reg(Is0, R, D) of {yes,Is} -> opt_move_rev(D, Acc, Is); no -> not_possible end; @@ -327,13 +360,21 @@ opt_tuple_element_1([{set,_,_,{alloc,_,_}}|_], _, _, _) -> opt_tuple_element_1([{set,_,_,{try_catch,_,_}}|_], _, _, _) -> no; opt_tuple_element_1([{set,[D],[S],move}|Is0], I0, {_,S}, Acc) -> - case eliminate_use_of_from_reg(Is0, S, D, []) of + case eliminate_use_of_from_reg(Is0, S, D) of no -> no; - {yes,Is} -> + {yes,Is1} -> {set,[S],Ss,Op} = I0, I = {set,[D],Ss,Op}, - {yes,reverse(Acc, [I|Is])} + case opt_move_rev(S, Acc, [I|Is1]) of + not_possible -> + %% Not safe because the move of the + %% get_tuple_element instruction would cause the + %% result of a previous instruction to be ignored. + no; + {_,Is} -> + {yes,Is} + end end; opt_tuple_element_1([{set,Ds,Ss,_}=I|Is], MovedI, {S,D}=Regs, Acc) -> case member(S, Ds) orelse member(D, Ss) of @@ -369,6 +410,14 @@ is_killed_or_used(R, {set,Ss,Ds,_}) -> %% that FromRegister is still used and that the optimization is not %% possible. +eliminate_use_of_from_reg(Is, From, To) -> + try + eliminate_use_of_from_reg(Is, From, To, []) + catch + throw:not_possible -> + no + end. + eliminate_use_of_from_reg([{set,_,_,{alloc,Live,_}}|_]=Is0, {x,X}, _, Acc) -> if X < Live -> @@ -377,21 +426,32 @@ eliminate_use_of_from_reg([{set,_,_,{alloc,Live,_}}|_]=Is0, {x,X}, _, Acc) -> {yes,reverse(Acc, Is0)} end; eliminate_use_of_from_reg([{set,Ds,Ss0,Op}=I0|Is], From, To, Acc) -> + ensure_safe_tuple(I0, To), I = case member(From, Ss0) of - true -> - Ss = [case S of - From -> To; - _ -> S - end || S <- Ss0], - {set,Ds,Ss,Op}; - false -> - I0 - end, + true -> + Ss = [case S of + From -> To; + _ -> S + end || S <- Ss0], + {set,Ds,Ss,Op}; + false -> + I0 + end, case member(From, Ds) of - true -> - {yes,reverse(Acc, [I|Is])}; - false -> - eliminate_use_of_from_reg(Is, From, To, [I|Acc]) + true -> + {yes,reverse(Acc, [I|Is])}; + false -> + case member(To, Ds) of + true -> + case beam_utils:is_killed_block(From, Is) of + true -> + {yes,reverse(Acc, [I|Is])}; + false -> + no + end; + false -> + eliminate_use_of_from_reg(Is, From, To, [I|Acc]) + end end; eliminate_use_of_from_reg([I]=Is, From, _To, Acc) -> case beam_utils:is_killed_block(From, [I]) of @@ -401,31 +461,51 @@ eliminate_use_of_from_reg([I]=Is, From, _To, Acc) -> no end. +ensure_safe_tuple({set,[To],[],{put_tuple,_}}, To) -> + throw(not_possible); +ensure_safe_tuple(_, _) -> ok. + +%% opt_allocs(Instructions) -> Instructions. Optimize allocate +%% instructions inside blocks. If safe, replace an allocate_zero +%% instruction with the slightly cheaper allocate instruction. + +opt_allocs(Is) -> + D = beam_utils:index_labels(Is), + opt_allocs_1(Is, D). + +opt_allocs_1([{block,Bl0}|Is], D) -> + Bl = opt_alloc(Bl0, {D,Is}), + [{block,Bl}|opt_allocs_1(Is, D)]; +opt_allocs_1([I|Is], D) -> + [I|opt_allocs_1(Is, D)]; +opt_allocs_1([], _) -> []. + %% opt_alloc(Instructions) -> Instructions' %% Optimises all allocate instructions. opt_alloc([{set,[],[],{alloc,Live0,Info0}}, - {set,[],[],{alloc,Live,Info}}|Is]) -> + {set,[],[],{alloc,Live,Info}}|Is], D) -> Live = Live0, %Assertion. Alloc = combine_alloc(Info0, Info), I = {set,[],[],{alloc,Live,Alloc}}, - opt_alloc([I|Is]); -opt_alloc([{set,[],[],{alloc,R,{_,Ns,Nh,[]}}}|Is]) -> - [{set,[],[],opt_alloc(Is, Ns, Nh, R)}|Is]; -opt_alloc([I|Is]) -> [I|opt_alloc(Is)]; -opt_alloc([]) -> []. + opt_alloc([I|Is], D); +opt_alloc([{set,[],[],{alloc,R,{_,Ns,Nh,[]}}}|Is], D) -> + [{set,[],[],opt_alloc(Is, D, Ns, Nh, R)}|Is]; +opt_alloc([I|Is], D) -> [I|opt_alloc(Is, D)]; +opt_alloc([], _) -> []. combine_alloc({_,Ns,Nh1,Init}, {_,nostack,Nh2,[]}) -> {zero,Ns,beam_utils:combine_heap_needs(Nh1, Nh2),Init}. - + %% opt_alloc(Instructions, FrameSize, HeapNeed, LivingRegs) -> [Instr] %% Generates the optimal sequence of instructions for %% allocating and initalizing the stack frame and needed heap. -opt_alloc(_Is, nostack, Nh, LivingRegs) -> +opt_alloc(_Is, _D, nostack, Nh, LivingRegs) -> {alloc,LivingRegs,{nozero,nostack,Nh,[]}}; -opt_alloc(Is, Ns, Nh, LivingRegs) -> - InitRegs = init_yreg(Is, 0), +opt_alloc(Bl, {D,OuterIs}, Ns, Nh, LivingRegs) -> + Is = [{block,Bl}|OuterIs], + InitRegs = init_yregs(Ns, Is, D), case count_ones(InitRegs) of N when N*2 > Ns -> {alloc,LivingRegs,{nozero,Ns,Nh,gen_init(Ns, InitRegs)}}; @@ -441,19 +521,14 @@ gen_init(Fs, Regs, Y, Acc) when Regs band 1 =:= 0 -> gen_init(Fs, Regs, Y, Acc) -> gen_init(Fs, Regs bsr 1, Y+1, Acc). -%% init_yreg(Instructions, RegSet) -> RegSetInitialized -%% Calculate the set of initialized y registers. - -init_yreg([{set,_,_,{bif,_,_}}|_], Reg) -> Reg; -init_yreg([{set,_,_,{alloc,_,{gc_bif,_,_}}}|_], Reg) -> Reg; -init_yreg([{set,_,_,{alloc,_,{put_map,_,_}}}|_], Reg) -> Reg; -init_yreg([{set,Ds,_,_}|Is], Reg) -> init_yreg(Is, add_yregs(Ds, Reg)); -init_yreg(_Is, Reg) -> Reg. - -add_yregs(Ys, Reg) -> foldl(fun(Y, R0) -> add_yreg(Y, R0) end, Reg, Ys). - -add_yreg({y,Y}, Reg) -> Reg bor (1 bsl Y); -add_yreg(_, Reg) -> Reg. +init_yregs(Y, Is, D) when Y >= 0 -> + case beam_utils:is_killed({y,Y}, Is, D) of + true -> + (1 bsl Y) bor init_yregs(Y-1, Is, D); + false -> + init_yregs(Y-1, Is, D) + end; +init_yregs(_, _, _) -> 0. count_ones(Bits) -> count_ones(Bits, 0). count_ones(0, Acc) -> Acc; @@ -463,16 +538,34 @@ count_ones(Bits, Acc) -> %% Calculate the new number of live registers when we move an allocate %% instruction upwards, passing a 'set' instruction. -alloc_live_regs({set,Ds,Ss,_}, Regs0) -> +alloc_live_regs({set,Ds,Ss,_}, Is, Regs0) -> Rset = x_live(Ss, x_dead(Ds, (1 bsl Regs0)-1)), - live_regs(0, Rset). + Live = live_regs(0, Rset), + case ensure_contiguous(Rset, Live) of + not_possible -> + %% Liveness information (looking forward in the + %% instruction stream) can't prove that moving this + %% allocation instruction is safe. Now use the annotation + %% of defined registers at the beginning of the current + %% block to see whether moving would be safe. + Def0 = defined_regs(Is, 0), + Def = Def0 band ((1 bsl Live) - 1), + ensure_contiguous(Rset bor Def, Live); + Live -> + %% Safe based on liveness information. + Live + end. live_regs(N, 0) -> N; -live_regs(N, Regs) when Regs band 1 =:= 1 -> - live_regs(N+1, Regs bsr 1); -live_regs(_, _) -> - not_possible. +live_regs(N, Regs) -> + live_regs(N+1, Regs bsr 1). + +ensure_contiguous(Regs, Live) -> + case (1 bsl Live) - 1 of + Regs -> Live; + _ -> not_possible + end. x_dead([{x,N}|Rs], Regs) -> x_dead(Rs, Regs band (bnot (1 bsl N))); x_dead([_|Rs], Regs) -> x_dead(Rs, Regs); @@ -481,3 +574,120 @@ x_dead([], Regs) -> Regs. x_live([{x,N}|Rs], Regs) -> x_live(Rs, Regs bor (1 bsl N)); x_live([_|Rs], Regs) -> x_live(Rs, Regs); x_live([], Regs) -> Regs. + +%% defined_regs(ReversedInstructions) -> RegBitmap. +%% Given a reversed instruction stream, determine the +%% the registers that are defined. + +defined_regs([{'%anno',{def,Def}}|_], Regs) -> + Def bor Regs; +defined_regs([{set,Ds,_,{alloc,Live,_}}|_], Regs) -> + x_live(Ds, Regs bor ((1 bsl Live) - 1)); +defined_regs([{set,Ds,_,_}|Is], Regs) -> + defined_regs(Is, x_live(Ds, Regs)). + +%%% +%%% Do local common sub expression elimination (CSE) in each block. +%%% + +local_cse([{block,Bl0}|Is]) -> + Bl = cse_block(Bl0, orddict:new(), []), + [{block,Bl}|local_cse(Is)]; +local_cse([I|Is]) -> + [I|local_cse(Is)]; +local_cse([]) -> []. + +cse_block([I|Is], Es0, Acc0) -> + Es1 = cse_clear(I, Es0), + case cse_expr(I) of + none -> + %% Instruction is not suitable for CSE. + cse_block(Is, Es1, [I|Acc0]); + {ok,D,Expr} -> + %% Suitable instruction. First update the dictionary of + %% suitable expressions for the next iteration. + Es = cse_add(D, Expr, Es1), + + %% Search for a previous identical expression. + case cse_find(Expr, Es0) of + error -> + %% Nothing found + cse_block(Is, Es, [I|Acc0]); + Src -> + %% Use the previously calculated result. + %% Also eliminate any line instruction. + Move = {set,[D],[Src],move}, + case Acc0 of + [{set,_,_,{line,_}}|Acc] -> + cse_block(Is, Es, [Move|Acc]); + [_|_] -> + cse_block(Is, Es, [Move|Acc0]) + end + end + end; +cse_block([], _, Acc) -> + reverse(Acc). + +%% cse_find(Expr, Expressions) -> error | Register. +%% Find a previously evaluated expression whose result can be reused, +%% or return 'error' if no such expression is found. + +cse_find(Expr, Es) -> + case orddict:find(Expr, Es) of + {ok,{Src,_}} -> Src; + error -> error + end. + +cse_expr({set,[D],Ss,{bif,N,_}}) -> + case D of + {fr,_} -> + %% There are too many things that can go wrong. + none; + _ -> + {ok,D,{{bif,N},Ss}} + end; +cse_expr({set,[D],Ss,{alloc,_,{gc_bif,N,_}}}) -> + {ok,D,{{gc_bif,N},Ss}}; +cse_expr({set,[D],Ss,put_list}) -> + {ok,D,{put_list,Ss}}; +cse_expr(_) -> none. + +%% cse_clear(Instr, Expressions0) -> Expressions. +%% Remove all previous expressions that will become +%% invalid when this instruction is executed. Basically, +%% an expression is no longer safe to reuse when the +%% register it has been stored to has been modified, killed, +%% or if any of the source operands have changed. + +cse_clear({set,Ds,_,{alloc,Live,_}}, Es) -> + cse_clear_1(Es, Live, Ds); +cse_clear({set,Ds,_,_}, Es) -> + cse_clear_1(Es, all, Ds). + +cse_clear_1(Es, Live, Ds0) -> + Ds = ordsets:from_list(Ds0), + [E || E <- Es, cse_is_safe(E, Live, Ds)]. + +cse_is_safe({_,{Dst,Interfering}}, Live, Ds) -> + ordsets:is_disjoint(Interfering, Ds) andalso + case Dst of + {x,X} -> + X < Live; + _ -> + true + end. + +%% cse_add(Dest, Expr, Expressions0) -> Expressions. +%% Provided that it is safe, add a new expression to the dictionary +%% of already evaluated expressions. + +cse_add(D, {_,Ss}=Expr, Es) -> + case member(D, Ss) of + false -> + Interfering = ordsets:from_list([D|Ss]), + orddict:store(Expr, {D,Interfering}, Es); + true -> + %% Unsafe because the instruction overwrites one of + %% source operands. + Es + end. diff --git a/lib/compiler/src/beam_bs.erl b/lib/compiler/src/beam_bs.erl index beb055b23d..14cedbb582 100644 --- a/lib/compiler/src/beam_bs.erl +++ b/lib/compiler/src/beam_bs.erl @@ -38,8 +38,7 @@ function({function,Name,Arity,CLabel,Is0}, Lc0) -> {Is,Lc} = bsm_opt(Is1, Lc0), {{function,Name,Arity,CLabel,Is},Lc} catch - Class:Error -> - Stack = erlang:get_stacktrace(), + Class:Error:Stack -> io:fwrite("Function: ~w/~w\n", [Name,Arity]), erlang:raise(Class, Error, Stack) end. diff --git a/lib/compiler/src/beam_bsm.erl b/lib/compiler/src/beam_bsm.erl index 9a4e7fb133..9f3b9d788f 100644 --- a/lib/compiler/src/beam_bsm.erl +++ b/lib/compiler/src/beam_bsm.erl @@ -105,8 +105,7 @@ function({function,Name,Arity,Entry,Is}, FIndex) -> D = #btb{f=FIndex,index=Index}, {function,Name,Arity,Entry,btb_opt_1(Is, D, [])} catch - Class:Error -> - Stack = erlang:get_stacktrace(), + Class:Error:Stack -> io:fwrite("Function: ~w/~w\n", [Name,Arity]), erlang:raise(Class, Error, Stack) end. @@ -125,20 +124,21 @@ btb_opt_1([{test,bs_get_binary2,F,_,[Reg,{atom,all},U,Fs],Reg}=I0|Is], D, Acc0) end, btb_opt_1(Is, D, Acc) end; -btb_opt_1([{test,bs_get_binary2,F,_,[Ctx,{atom,all},U,Fs],Dst}=I0|Is], D, Acc0) -> - case btb_reaches_match(Is, [Ctx,Dst], D) of +btb_opt_1([{test,bs_get_binary2,F,_,[Ctx,{atom,all},U,Fs],Dst}=I0|Is0], D, Acc0) -> + case btb_reaches_match(Is0, [Ctx,Dst], D) of {error,Reason} -> Comment = btb_comment_no_opt(Reason, Fs), - btb_opt_1(Is, D, [Comment,I0|Acc0]); + btb_opt_1(Is0, D, [Comment,I0|Acc0]); {ok,MustSave} when U =:= 1 -> Comment = btb_comment_opt(Fs), - Acc1 = btb_gen_save(MustSave, Ctx, [Comment|Acc0]), - Acc = [{move,Ctx,Dst}|Acc1], + Acc = btb_gen_save(MustSave, Ctx, [Comment|Acc0]), + Is = prepend_move(Ctx, Dst, Is0), btb_opt_1(Is, D, Acc); {ok,MustSave} -> Comment = btb_comment_opt(Fs), Acc1 = btb_gen_save(MustSave, Ctx, [Comment|Acc0]), - Acc = [{move,Ctx,Dst},{test,bs_test_unit,F,[Ctx,U]}|Acc1], + Acc = [{test,bs_test_unit,F,[Ctx,U]}|Acc1], + Is = prepend_move(Ctx, Dst, Is0), btb_opt_1(Is, D, Acc) end; btb_opt_1([I|Is], D, Acc) -> @@ -151,6 +151,12 @@ btb_gen_save(true, Reg, Acc) -> [{bs_save2,Reg,{atom,start}}|Acc]; btb_gen_save(false, _, Acc) -> Acc. +prepend_move(Ctx, Dst, [{block,Bl0}|Is]) -> + Bl = [{set,[Dst],[Ctx],move}|Bl0], + [{block,Bl}|Is]; +prepend_move(Ctx, Dst, Is) -> + [{move,Ctx,Dst}|Is]. + %% btb_reaches_match([Instruction], [Register], D) -> %% {ok,MustSave}|{error,Reason} %% diff --git a/lib/compiler/src/beam_clean.erl b/lib/compiler/src/beam_clean.erl index b736d39f9c..955c128699 100644 --- a/lib/compiler/src/beam_clean.erl +++ b/lib/compiler/src/beam_clean.erl @@ -24,7 +24,7 @@ -export([module/2]). -export([bs_clean_saves/1]). -export([clean_labels/1]). --import(lists, [map/2,foldl/3,reverse/1,filter/2]). +-import(lists, [foldl/3,reverse/1]). -spec module(beam_utils:module_code(), [compile:option()]) -> {'ok',beam_utils:module_code()}. @@ -118,7 +118,7 @@ add_to_work_list(F, {Fs,Used}=Sets) -> clean_labels(Fs0) -> St0 = #st{lmap=[],entry=1,lc=1}, {Fs1,#st{lmap=Lmap0,lc=Lc}} = function_renumber(Fs0, St0, []), - Lmap = gb_trees:from_orddict(ordsets:from_list(Lmap0)), + Lmap = maps:from_list(Lmap0), Fs = function_replace(Fs1, Lmap, []), {Fs,Lc}. @@ -187,7 +187,8 @@ is_record_tuple(_, _, _) -> no. function_replace([{function,Name,Arity,Entry,Asm0}|Fs], Dict, Acc) -> Asm = try - replace(Asm0, [], Dict) + Fb = fun(Old) -> throw({error,{undefined_label,Old}}) end, + beam_utils:replace_labels(Asm0, [], Dict, Fb) catch throw:{error,{undefined_label,Lbl}=Reason} -> io:format("Function ~s/~w refers to undefined label ~w\n", @@ -197,57 +198,6 @@ function_replace([{function,Name,Arity,Entry,Asm0}|Fs], Dict, Acc) -> function_replace(Fs, Dict, [{function,Name,Arity,Entry,Asm}|Acc]); function_replace([], _, Acc) -> Acc. -replace([{test,Test,{f,Lbl},Ops}|Is], Acc, D) -> - replace(Is, [{test,Test,{f,label(Lbl, D)},Ops}|Acc], D); -replace([{test,Test,{f,Lbl},Live,Ops,Dst}|Is], Acc, D) -> - replace(Is, [{test,Test,{f,label(Lbl, D)},Live,Ops,Dst}|Acc], D); -replace([{select,I,R,{f,Fail0},Vls0}|Is], Acc, D) -> - Vls = map(fun ({f,L}) -> {f,label(L, D)}; - (Other) -> Other - end, Vls0), - Fail = label(Fail0, D), - replace(Is, [{select,I,R,{f,Fail},Vls}|Acc], D); -replace([{'try',R,{f,Lbl}}|Is], Acc, D) -> - replace(Is, [{'try',R,{f,label(Lbl, D)}}|Acc], D); -replace([{'catch',R,{f,Lbl}}|Is], Acc, D) -> - replace(Is, [{'catch',R,{f,label(Lbl, D)}}|Acc], D); -replace([{jump,{f,Lbl}}|Is], Acc, D) -> - replace(Is, [{jump,{f,label(Lbl, D)}}|Acc], D); -replace([{loop_rec,{f,Lbl},R}|Is], Acc, D) -> - replace(Is, [{loop_rec,{f,label(Lbl, D)},R}|Acc], D); -replace([{loop_rec_end,{f,Lbl}}|Is], Acc, D) -> - replace(Is, [{loop_rec_end,{f,label(Lbl, D)}}|Acc], D); -replace([{wait,{f,Lbl}}|Is], Acc, D) -> - replace(Is, [{wait,{f,label(Lbl, D)}}|Acc], D); -replace([{wait_timeout,{f,Lbl},To}|Is], Acc, D) -> - replace(Is, [{wait_timeout,{f,label(Lbl, D)},To}|Acc], D); -replace([{bif,Name,{f,Lbl},As,R}|Is], Acc, D) when Lbl =/= 0 -> - replace(Is, [{bif,Name,{f,label(Lbl, D)},As,R}|Acc], D); -replace([{gc_bif,Name,{f,Lbl},Live,As,R}|Is], Acc, D) when Lbl =/= 0 -> - replace(Is, [{gc_bif,Name,{f,label(Lbl, D)},Live,As,R}|Acc], D); -replace([{call,Ar,{f,Lbl}}|Is], Acc, D) -> - replace(Is, [{call,Ar,{f,label(Lbl,D)}}|Acc], D); -replace([{make_fun2,{f,Lbl},U1,U2,U3}|Is], Acc, D) -> - replace(Is, [{make_fun2,{f,label(Lbl, D)},U1,U2,U3}|Acc], D); -replace([{bs_init,{f,Lbl},Info,Live,Ss,Dst}|Is], Acc, D) when Lbl =/= 0 -> - replace(Is, [{bs_init,{f,label(Lbl, D)},Info,Live,Ss,Dst}|Acc], D); -replace([{bs_put,{f,Lbl},Info,Ss}|Is], Acc, D) when Lbl =/= 0 -> - replace(Is, [{bs_put,{f,label(Lbl, D)},Info,Ss}|Acc], D); -replace([{put_map=I,{f,Lbl},Op,Src,Dst,Live,List}|Is], Acc, D) - when Lbl =/= 0 -> - replace(Is, [{I,{f,label(Lbl, D)},Op,Src,Dst,Live,List}|Acc], D); -replace([{get_map_elements=I,{f,Lbl},Src,List}|Is], Acc, D) when Lbl =/= 0 -> - replace(Is, [{I,{f,label(Lbl, D)},Src,List}|Acc], D); -replace([I|Is], Acc, D) -> - replace(Is, [I|Acc], D); -replace([], Acc, _) -> Acc. - -label(Old, D) -> - case gb_trees:lookup(Old, D) of - {value,Val} -> Val; - none -> throw({error,{undefined_label,Old}}) - end. - %%% %%% Final fixup of bs_start_match2/5,bs_save2/bs_restore2 instructions for %%% new bit syntax matching (introduced in R11B). @@ -304,7 +254,7 @@ bs_restores([_|Is], Dict) -> bs_restores([], Dict) -> Dict. %% Pass 2. -bs_replace([{test,bs_start_match2,F,Live,[Src,Ctx],CtxR}|T], Dict, Acc) when is_atom(Ctx) -> +bs_replace([{test,bs_start_match2,F,Live,[Src,{context,Ctx}],CtxR}|T], Dict, Acc) -> Slots = case gb_trees:lookup(Ctx, Dict) of {value,Slots0} -> Slots0; none -> 0 @@ -353,8 +303,21 @@ maybe_remove_lines(Fs, Opts) -> end. remove_lines([{function,N,A,Lbl,Is0}|T]) -> - Is = filter(fun({line,_}) -> false; - (_) -> true - end, Is0), + Is = remove_lines_fun(Is0), [{function,N,A,Lbl,Is}|remove_lines(T)]; remove_lines([]) -> []. + +remove_lines_fun([{line,_}|Is]) -> + remove_lines_fun(Is); +remove_lines_fun([{block,Bl0}|Is]) -> + Bl = remove_lines_block(Bl0), + [{block,Bl}|remove_lines_fun(Is)]; +remove_lines_fun([I|Is]) -> + [I|remove_lines_fun(Is)]; +remove_lines_fun([]) -> []. + +remove_lines_block([{set,_,_,{line,_}}|Is]) -> + remove_lines_block(Is); +remove_lines_block([I|Is]) -> + [I|remove_lines_block(Is)]; +remove_lines_block([]) -> []. diff --git a/lib/compiler/src/beam_dead.erl b/lib/compiler/src/beam_dead.erl index d379fdc4eb..dbbaae05eb 100644 --- a/lib/compiler/src/beam_dead.erl +++ b/lib/compiler/src/beam_dead.erl @@ -56,8 +56,7 @@ function({function,Name,Arity,CLabel,Is0}, Lc0) -> Is = move_move_into_block(Is3, []), {{function,Name,Arity,CLabel,Is},Lc} catch - Class:Error -> - Stack = erlang:get_stacktrace(), + Class:Error:Stack -> io:fwrite("Function: ~w/~w\n", [Name,Arity]), erlang:raise(Class, Error, Stack) end. @@ -272,7 +271,8 @@ backward([{jump,{f,To0}},{move,Src,Reg}=Move|Is], D, Acc) -> end; backward([{jump,{f,To}}=J|[{bif,Op,{f,BifFail},Ops,Reg}|Is]=Is0], D, Acc) -> try replace_comp_op(To, Reg, Op, Ops, D) of - I -> backward(Is, D, I++Acc) + {Test,Jump} -> + backward([Jump,Test|Is], D, Acc) catch throw:not_possible -> case To =:= BifFail of @@ -294,24 +294,25 @@ backward([{jump,{f,To}}=J|[{gc_bif,_,{f,To},_,_,_Dst}|Is]], D, Acc) -> %% register is initialized, and it is therefore no need to test %% for liveness of the destination register at label To. backward([J|Is], D, Acc); -backward([{test,bs_start_match2,F,Live,[R,_]=Args,Ctxt}|Is], D, - [{test,bs_match_string,F,[Ctxt,Bs]}, - {test,bs_test_tail2,F,[Ctxt,0]}|Acc0]=Acc) -> +backward([{test,bs_start_match2,F,Live,[Src,_]=Args,Ctxt}|Is], D, Acc0) -> {f,To0} = F, - case beam_utils:is_killed(Ctxt, Acc0, D) of - true -> - To = shortcut_bs_context_to_binary(To0, R, D), - Eq = {test,is_eq_exact,{f,To},[R,{literal,Bs}]}, - backward(Is, D, [Eq|Acc0]); - false -> - To = shortcut_bs_start_match(To0, R, D), - I = {test,bs_start_match2,{f,To},Live,Args,Ctxt}, - backward(Is, D, [I|Acc]) + case test_bs_literal(F, Ctxt, D, Acc0) of + {none,Acc} -> + %% Ctxt killed immediately after bs_start_match2. + To = shortcut_bs_context_to_binary(To0, Src, D), + I = {test,is_bitstr,{f,To},[Src]}, + backward(Is, D, [I|Acc]); + {Literal,Acc} -> + %% Ctxt killed after matching a literal. + To = shortcut_bs_context_to_binary(To0, Src, D), + Eq = {test,is_eq_exact,{f,To},[Src,{literal,Literal}]}, + backward(Is, D, [Eq|Acc]); + not_killed -> + %% Ctxt not killed. Not much to do. + To = shortcut_bs_start_match(To0, Src, D), + I = {test,bs_start_match2,{f,To},Live,Args,Ctxt}, + backward(Is, D, [I|Acc0]) end; -backward([{test,bs_start_match2,{f,To0},Live,[Src|_]=Info,Dst}|Is], D, Acc) -> - To = shortcut_bs_start_match(To0, Src, D), - I = {test,bs_start_match2,{f,To},Live,Info,Dst}, - backward(Is, D, [I|Acc]); backward([{test,Op,{f,To0},Ops0}|Is], D, Acc) -> To1 = shortcut_bs_test(To0, Is, D), To2 = shortcut_label(To1, D), @@ -446,7 +447,7 @@ prune_redundant([], _) -> []. replace_comp_op(To, Reg, Op, Ops, D) -> False = comp_op_find_shortcut(To, Reg, {atom,false}, D), True = comp_op_find_shortcut(To, Reg, {atom,true}, D), - [bif_to_test(Op, Ops, False),{jump,{f,True}}]. + {bif_to_test(Op, Ops, False),{jump,{f,True}}}. comp_op_find_shortcut(To0, Reg, Val, D) -> case shortcut_select_label(To0, Reg, Val, D) of @@ -483,15 +484,22 @@ not_possible() -> throw(not_possible). %% F1: is_eq_exact F2 Reg Lit2 F1: is_eq_exact F2 Reg Lit2 %% L2: .... L2: %% -combine_eqs(To, [Reg,{Type,_}=Lit1]=Ops, D, [{label,L1}|_]) - when Type =:= atom; Type =:= integer -> +combine_eqs(To, [Reg,{Type,_}=Lit1]=Ops, D, Acc) + when Type =:= atom; Type =:= integer -> + Next = case Acc of + [{label,Lbl}|_] -> Lbl; + [{jump,{f,Lbl}}|_] -> Lbl + end, case beam_utils:code_at(To, D) of [{test,is_eq_exact,{f,F2},[Reg,{Type,_}=Lit2]}, {label,L2}|_] when Lit1 =/= Lit2 -> - {select,select_val,Reg,{f,F2},[Lit1,{f,L1},Lit2,{f,L2}]}; + {select,select_val,Reg,{f,F2},[Lit1,{f,Next},Lit2,{f,L2}]}; + [{test,is_eq_exact,{f,F2},[Reg,{Type,_}=Lit2]}, + {jump,{f,L2}}|_] when Lit1 =/= Lit2 -> + {select,select_val,Reg,{f,F2},[Lit1,{f,Next},Lit2,{f,L2}]}; [{select,select_val,Reg,{f,F2},[{Type,_}|_]=List0}|_] -> List = remove_from_list(Lit1, List0), - {select,select_val,Reg,{f,F2},[Lit1,{f,L1}|List]}; + {select,select_val,Reg,{f,F2},[Lit1,{f,Next}|List]}; _Is -> {test,is_eq_exact,{f,To},Ops} end; @@ -504,6 +512,22 @@ remove_from_list(Lit, [Val,{f,_}=Fail|T]) -> [Val,Fail|remove_from_list(Lit, T)]; remove_from_list(_, []) -> []. + +test_bs_literal(F, Ctxt, D, + [{test,bs_match_string,F,[Ctxt,Bs]}, + {test,bs_test_tail2,F,[Ctxt,0]}|Acc]) -> + test_bs_literal_1(Ctxt, Acc, D, Bs); +test_bs_literal(F, Ctxt, D, [{test,bs_test_tail2,F,[Ctxt,0]}|Acc]) -> + test_bs_literal_1(Ctxt, Acc, D, <<>>); +test_bs_literal(_, Ctxt, D, Acc) -> + test_bs_literal_1(Ctxt, Acc, D, none). + +test_bs_literal_1(Ctxt, Is, D, Literal) -> + case beam_utils:is_killed(Ctxt, Is, D) of + true -> {Literal,Is}; + false -> not_killed + end. + %% shortcut_bs_test(TargetLabel, ReversedInstructions, D) -> TargetLabel' %% Try to shortcut the failure label for bit syntax matching. diff --git a/lib/compiler/src/beam_disasm.erl b/lib/compiler/src/beam_disasm.erl index 8fd0b36d05..a68c4b5367 100644 --- a/lib/compiler/src/beam_disasm.erl +++ b/lib/compiler/src/beam_disasm.erl @@ -163,8 +163,8 @@ pp_instr(I) -> file(File) -> try process_chunks(File) - catch error:Reason -> - {error,?MODULE,{internal,{Reason,erlang:get_stacktrace()}}} + catch error:Reason:Stack -> + {error,?MODULE,{internal,{Reason,Stack}}} end. %%----------------------------------------------------------------------- @@ -719,42 +719,6 @@ resolve_inst({wait,[Lbl]},_,_,_) -> {wait,Lbl}; resolve_inst({wait_timeout,[Lbl,Int]},_,_,_) -> {wait_timeout,Lbl,resolve_arg(Int)}; -resolve_inst({m_plus,Args},_,_,_) -> - [W,SrcR1,SrcR2,DstR] = resolve_args(Args), - {arithbif,'+',W,[SrcR1,SrcR2],DstR}; -resolve_inst({m_minus,Args},_,_,_) -> - [W,SrcR1,SrcR2,DstR] = resolve_args(Args), - {arithbif,'-',W,[SrcR1,SrcR2],DstR}; -resolve_inst({m_times,Args},_,_,_) -> - [W,SrcR1,SrcR2,DstR] = resolve_args(Args), - {arithbif,'*',W,[SrcR1,SrcR2],DstR}; -resolve_inst({m_div,Args},_,_,_) -> - [W,SrcR1,SrcR2,DstR] = resolve_args(Args), - {arithbif,'/',W,[SrcR1,SrcR2],DstR}; -resolve_inst({int_div,Args},_,_,_) -> - [W,SrcR1,SrcR2,DstR] = resolve_args(Args), - {arithbif,'div',W,[SrcR1,SrcR2],DstR}; -resolve_inst({int_rem,Args},_,_,_) -> - [W,SrcR1,SrcR2,DstR] = resolve_args(Args), - {arithbif,'rem',W,[SrcR1,SrcR2],DstR}; -resolve_inst({int_band,Args},_,_,_) -> - [W,SrcR1,SrcR2,DstR] = resolve_args(Args), - {arithbif,'band',W,[SrcR1,SrcR2],DstR}; -resolve_inst({int_bor,Args},_,_,_) -> - [W,SrcR1,SrcR2,DstR] = resolve_args(Args), - {arithbif,'bor',W,[SrcR1,SrcR2],DstR}; -resolve_inst({int_bxor,Args},_,_,_) -> - [W,SrcR1,SrcR2,DstR] = resolve_args(Args), - {arithbif,'bxor',W,[SrcR1,SrcR2],DstR}; -resolve_inst({int_bsl,Args},_,_,_) -> - [W,SrcR1,SrcR2,DstR] = resolve_args(Args), - {arithbif,'bsl',W,[SrcR1,SrcR2],DstR}; -resolve_inst({int_bsr,Args},_,_,_) -> - [W,SrcR1,SrcR2,DstR] = resolve_args(Args), - {arithbif,'bsr',W,[SrcR1,SrcR2],DstR}; -resolve_inst({int_bnot,Args},_,_,_) -> - [W,SrcR,DstR] = resolve_args(Args), - {arithbif,'bnot',W,[SrcR],DstR}; resolve_inst({is_lt=I,Args0},_,_,_) -> [L|Args] = resolve_args(Args0), {test,I,L,Args}; @@ -800,9 +764,6 @@ resolve_inst({is_nil=I,Args0},_,_,_) -> resolve_inst({is_binary=I,Args0},_,_,_) -> [L|Args] = resolve_args(Args0), {test,I,L,Args}; -resolve_inst({is_constant=I,Args0},_,_,_) -> - [L|Args] = resolve_args(Args0), - {test,I,L,Args}; resolve_inst({is_list=I,Args0},_,_,_) -> [L|Args] = resolve_args(Args0), {test,I,L,Args}; @@ -840,11 +801,6 @@ resolve_inst({get_tuple_element,[Src,{u,Off},Dst]},_,_,_) -> {get_tuple_element,resolve_arg(Src),Off,resolve_arg(Dst)}; resolve_inst({set_tuple_element,[Src,Dst,{u,Off}]},_,_,_) -> {set_tuple_element,resolve_arg(Src),resolve_arg(Dst),Off}; -resolve_inst({put_string,[{u,Len},{u,Off},Dst]},_,Strings,_) -> - String = if Len > 0 -> binary_to_list(Strings, Off+1, Off+Len); - true -> "" - end, - {put_string,Len,{string,String},Dst}; resolve_inst({put_list,[Src1,Src2,Dst]},_,_,_) -> {put_list,resolve_arg(Src1),resolve_arg(Src2),Dst}; resolve_inst({put_tuple,[{u,Arity},Dst]},_,_,_) -> @@ -859,9 +815,6 @@ resolve_inst({case_end,[X]},_,_,_) -> {case_end,resolve_arg(X)}; resolve_inst({call_fun,[{u,N}]},_,_,_) -> {call_fun,N}; -resolve_inst({make_fun,Args},_,_,Lbls) -> - [{f,L},Magic,FreeVars] = resolve_args(Args), - {make_fun,lookup(L,Lbls),Magic,FreeVars}; resolve_inst({is_function=I,Args0},_,_,_) -> [L|Args] = resolve_args(Args0), {test,I,L,Args}; @@ -870,30 +823,6 @@ resolve_inst({call_ext_only,[{u,N},{u,MFAix}]},Imports,_,_) -> %% %% Instructions for handling binaries added in R7A & R7B %% -resolve_inst({bs_start_match,[F,Reg]},_,_,_) -> - {bs_start_match,F,Reg}; -resolve_inst({bs_get_integer=I,[Lbl,Arg2,{u,N},{u,U},Arg5]},_,_,_) -> - [A2,A5] = resolve_args([Arg2,Arg5]), - {test,I,Lbl,[A2,N,decode_field_flags(U),A5]}; -resolve_inst({bs_get_float=I,[Lbl,Arg2,{u,N},{u,U},Arg5]},_,_,_) -> - [A2,A5] = resolve_args([Arg2,Arg5]), - {test,I,Lbl,[A2,N,decode_field_flags(U),A5]}; -resolve_inst({bs_get_binary=I,[Lbl,Arg2,{u,N},{u,U},Arg5]},_,_,_) -> - [A2,A5] = resolve_args([Arg2,Arg5]), - {test,I,Lbl,[A2,N,decode_field_flags(U),A5]}; -resolve_inst({bs_skip_bits,[Lbl,Arg2,{u,N},{u,U}]},_,_,_) -> - A2 = resolve_arg(Arg2), - {test,bs_skip_bits,Lbl,[A2,N,decode_field_flags(U)]}; -resolve_inst({bs_test_tail,[F,{u,N}]},_,_,_) -> - {test,bs_test_tail,F,[N]}; -resolve_inst({bs_save,[{u,N}]},_,_,_) -> - {bs_save,N}; -resolve_inst({bs_restore,[{u,N}]},_,_,_) -> - {bs_restore,N}; -resolve_inst({bs_init,[{u,N},{u,U}]},_,_,_) -> - {bs_init,N,decode_field_flags(U)}; -resolve_inst({bs_final,[F,X]},_,_,_) -> - {bs_final,F,X}; resolve_inst({bs_put_integer,[Lbl,Arg2,{u,N},{u,U},Arg5]},_,_,_) -> [A2,A5] = resolve_args([Arg2,Arg5]), {bs_put_integer,Lbl,A2,N,decode_field_flags(U),A5}; @@ -908,8 +837,6 @@ resolve_inst({bs_put_string,[{u,Len},{u,Off}]},_,Strings,_) -> true -> "" end, {bs_put_string,Len,{string,String}}; -resolve_inst({bs_need_buf,[{u,N}]},_,_,_) -> - {bs_need_buf,N}; %% %% Instructions for handling floating point numbers added in June 2001 (R8). @@ -961,9 +888,6 @@ resolve_inst({raise,[_Reg1,_Reg2]=Regs},_,_,_) -> resolve_inst({bs_init2,[Lbl,Arg2,{u,W},{u,R},{u,F},Arg6]},_,_,_) -> [A2,A6] = resolve_args([Arg2,Arg6]), {bs_init2,Lbl,A2,W,R,decode_field_flags(F),A6}; -resolve_inst({bs_bits_to_bytes,[Lbl,Arg2,Arg3]},_,_,_) -> - [A2,A3] = resolve_args([Arg2,Arg3]), - {bs_bits_to_bytes,Lbl,A2,A3}; resolve_inst({bs_add=I,[Lbl,Arg2,Arg3,Arg4,Arg5]},_,_,_) -> [A2,A3,A4,A5] = resolve_args([Arg2,Arg3,Arg4,Arg5]), {I,Lbl,[A2,A3,A4],A5}; @@ -1041,12 +965,6 @@ resolve_inst({gc_bif3,Args},Imports,_,_) -> {gc_bif,BifName,F,Live,[A1,A2,A3],Reg}; %% -%% New instructions for creating non-byte aligned binaries. -%% -resolve_inst({bs_final2,[X,Y]},_,_,_) -> - {bs_final2,X,Y}; - -%% %% R11B-5. %% resolve_inst({is_bitstr=I,Args0},_,_,_) -> @@ -1165,6 +1083,19 @@ resolve_inst({get_map_elements,Args0},_,_,_) -> {get_map_elements,FLbl,Src,{list,List}}; %% +%% OTP 21. +%% + +resolve_inst({build_stacktrace,[]},_,_,_) -> + build_stacktrace; +resolve_inst({raw_raise,[]},_,_,_) -> + raw_raise; +resolve_inst({get_hd,[Src,Dst]},_,_,_) -> + {get_hd,Src,Dst}; +resolve_inst({get_tl,[Src,Dst]},_,_,_) -> + {get_tl,Src,Dst}; + +%% %% Catches instructions that are not yet handled. %% resolve_inst(X,_,_,_) -> ?exit({resolve_inst,X}). diff --git a/lib/compiler/src/beam_disasm.hrl b/lib/compiler/src/beam_disasm.hrl index d968cd9587..c3326c15a0 100644 --- a/lib/compiler/src/beam_disasm.hrl +++ b/lib/compiler/src/beam_disasm.hrl @@ -26,7 +26,8 @@ %% IT SHOULD BE MOVED TO A FILE THAT DEFINES (AND EXPORTS) %% PROPER TYPES FOR THE SET OF BEAM INSTRUCTIONS. %% --type beam_instr() :: 'bs_init_writable' | 'fclearerror' | 'if_end' +-type beam_instr() :: 'bs_init_writable' | 'build_stacktrace' + | 'fclearerror' | 'if_end' | 'raw_raise' | 'remove_message' | 'return' | 'send' | 'timeout' | tuple(). %% XXX: Very underspecified - FIX THIS diff --git a/lib/compiler/src/beam_except.erl b/lib/compiler/src/beam_except.erl index 9801c68ee2..abd39c661d 100644 --- a/lib/compiler/src/beam_except.erl +++ b/lib/compiler/src/beam_except.erl @@ -45,8 +45,7 @@ function({function,Name,Arity,CLabel,Is0}) -> Is = function_1(Is0), {function,Name,Arity,CLabel,Is} catch - Class:Error -> - Stack = erlang:get_stacktrace(), + Class:Error:Stack -> io:fwrite("Function: ~w/~w\n", [Name,Arity]), erlang:raise(Class, Error, Stack) end. diff --git a/lib/compiler/src/beam_flatten.erl b/lib/compiler/src/beam_flatten.erl index a4d45a4ca6..c60211f516 100644 --- a/lib/compiler/src/beam_flatten.erl +++ b/lib/compiler/src/beam_flatten.erl @@ -50,6 +50,9 @@ norm_block([{set,[],[],{alloc,R,Alloc}}|Is], Acc0) -> Acc -> norm_block(Is, Acc) end; +norm_block([{set,[D1],[S],get_hd},{set,[D2],[S],get_tl}|Is], Acc) -> + I = {get_list,S,D1,D2}, + norm_block(Is, [I|Acc]); norm_block([I|Is], Acc) -> norm_block(Is, [norm(I)|Acc]); norm_block([], Acc) -> Acc. @@ -64,12 +67,14 @@ norm({set,[D],[],{put_tuple,A}}) -> {put_tuple,A,D}; norm({set,[],[S],put}) -> {put,S}; norm({set,[D],[S],{get_tuple_element,I}}) -> {get_tuple_element,S,I,D}; norm({set,[],[S,D],{set_tuple_element,I}}) -> {set_tuple_element,S,D,I}; -norm({set,[D1,D2],[S],get_list}) -> {get_list,S,D1,D2}; +norm({set,[D],[S],get_hd}) -> {get_hd,S,D}; +norm({set,[D],[S],get_tl}) -> {get_tl,S,D}; norm({set,[D],[S|Puts],{alloc,R,{put_map,Op,F}}}) -> {put_map,F,Op,S,D,R,{list,Puts}}; norm({set,[],[],remove_message}) -> remove_message; norm({set,[],[],fclearerror}) -> fclearerror; -norm({set,[],[],fcheckerror}) -> {fcheckerror,{f,0}}. +norm({set,[],[],fcheckerror}) -> {fcheckerror,{f,0}}; +norm({set,[],[],{line,_}=Line}) -> Line. norm_allocate({_Zero,nostack,Nh,[]}, Regs) -> [{test_heap,Nh,Regs}]; diff --git a/lib/compiler/src/beam_jump.erl b/lib/compiler/src/beam_jump.erl index 4365451356..c33de217bd 100644 --- a/lib/compiler/src/beam_jump.erl +++ b/lib/compiler/src/beam_jump.erl @@ -71,9 +71,9 @@ %%% %%% jump L2 %%% . . . -%%% L1: %%% L2: ... %%% +%%% and all preceding uses of L1 renamed to L2. %%% If the jump is unreachable, it will be removed according to (1). %%% %%% (5) In @@ -156,41 +156,46 @@ function({function,Name,Arity,CLabel,Asm0}) -> %%% share(Is0) -> - %% We will get more sharing if we never fall through to a label. - Is = eliminate_fallthroughs(Is0, []), - share_1(Is, #{}, [], []). + Is1 = eliminate_fallthroughs(Is0, []), + Is2 = find_fixpoint(fun(Is) -> + share_1(Is, #{}, #{}, [], []) + end, Is1), + reverse(Is2). -share_1([{label,L}=Lbl|Is], Dict0, [_|_]=Seq, Acc) -> +share_1([{label,L}=Lbl|Is], Dict0, Lbls0, [_|_]=Seq, Acc) -> case maps:find(Seq, Dict0) of error -> Dict = maps:put(Seq, L, Dict0), - share_1(Is, Dict, [], [Lbl|Seq ++ Acc]); + share_1(Is, Dict, Lbls0, [], [Lbl|Seq ++ Acc]); {ok,Label} -> - share_1(Is, Dict0, [], [Lbl,{jump,{f,Label}}|Acc]) + Lbls = maps:put(L, Label, Lbls0), + share_1(Is, Dict0, Lbls, [], [Lbl,{jump,{f,Label}}|Acc]) end; -share_1([{func_info,_,_,_}=I|Is], _, [], Acc) -> - reverse(Is, [I|Acc]); -share_1([{'catch',_,_}=I|Is], Dict0, Seq, Acc) -> - Dict = clean_non_sharable(Dict0), - share_1(Is, Dict, [I|Seq], Acc); -share_1([{'try',_,_}=I|Is], Dict0, Seq, Acc) -> - Dict = clean_non_sharable(Dict0), - share_1(Is, Dict, [I|Seq], Acc); -share_1([{try_case,_}=I|Is], Dict0, Seq, Acc) -> - Dict = clean_non_sharable(Dict0), - share_1(Is, Dict, [I|Seq], Acc); -share_1([{catch_end,_}=I|Is], Dict0, Seq, Acc) -> - Dict = clean_non_sharable(Dict0), - share_1(Is, Dict, [I|Seq], Acc); -share_1([I|Is], Dict, Seq, Acc) -> +share_1([{func_info,_,_,_}|_]=Is, _, Lbls, [], Acc) when Lbls =/= #{} -> + beam_utils:replace_labels(Acc, Is, Lbls, fun(Old) -> Old end); +share_1([{func_info,_,_,_}|_]=Is, _, Lbls, [], Acc) when Lbls =:= #{} -> + reverse(Acc, Is); +share_1([{'catch',_,_}=I|Is], Dict0, Lbls0, Seq, Acc) -> + {Dict,Lbls} = clean_non_sharable(Dict0, Lbls0), + share_1(Is, Dict, Lbls, [I|Seq], Acc); +share_1([{'try',_,_}=I|Is], Dict0, Lbls0, Seq, Acc) -> + {Dict,Lbls} = clean_non_sharable(Dict0, Lbls0), + share_1(Is, Dict, Lbls, [I|Seq], Acc); +share_1([{try_case,_}=I|Is], Dict0, Lbls0, Seq, Acc) -> + {Dict,Lbls} = clean_non_sharable(Dict0, Lbls0), + share_1(Is, Dict, Lbls, [I|Seq], Acc); +share_1([{catch_end,_}=I|Is], Dict0, Lbls0, Seq, Acc) -> + {Dict,Lbls} = clean_non_sharable(Dict0, Lbls0), + share_1(Is, Dict, Lbls, [I|Seq], Acc); +share_1([I|Is], Dict, Lbls, Seq, Acc) -> case is_unreachable_after(I) of false -> - share_1(Is, Dict, [I|Seq], Acc); + share_1(Is, Dict, Lbls, [I|Seq], Acc); true -> - share_1(Is, Dict, [I], Acc) + share_1(Is, Dict, Lbls, [I], Acc) end. -clean_non_sharable(Dict) -> +clean_non_sharable(Dict0, Lbls0) -> %% We are passing in or out of a 'catch' or 'try' block. Remove %% sequences that should not be shared over the boundaries of the %% block. Since the end of the sequence must match, the only @@ -198,7 +203,17 @@ clean_non_sharable(Dict) -> %% the 'catch'/'try' block is a sequence that ends with an %% instruction that causes an exception. Any sequence that causes %% an exception must contain a line/1 instruction. - maps:filter(fun(K, _V) -> sharable_with_try(K) end, Dict). + Dict1 = maps:to_list(Dict0), + Lbls1 = maps:to_list(Lbls0), + {Dict2,Lbls2} = foldl(fun({K, V}, {Dict,Lbls}) -> + case sharable_with_try(K) of + true -> + {[{K,V}|Dict],lists:keydelete(V, 2, Lbls)}; + false -> + {Dict,Lbls} + end + end, {[],Lbls1}, Dict1), + {maps:from_list(Dict2),maps:from_list(Lbls2)}. sharable_with_try([{line,_}|_]) -> %% This sequence may cause an exception and may potentially @@ -275,14 +290,15 @@ extract_seq_1(_, _) -> no. -record(st, { entry :: beam_asm:label(), %Entry label (must not be moved). - mlbl :: #{beam_asm:label() := [beam_asm:label()]}, %Moved labels. - labels :: cerl_sets:set() %Set of referenced labels. + replace :: #{beam_asm:label() := beam_asm:label()}, %Labels to replace. + labels :: cerl_sets:set(), %Set of referenced labels. + index :: beam_utils:code_index() | {lazy,[beam_utils:instruction()]} %Index built lazily only if needed }). opt(Is0, CLabel) -> find_fixpoint(fun(Is) -> Lbls = initial_labels(Is), - St = #st{entry=CLabel,mlbl=#{},labels=Lbls}, + St = #st{entry=CLabel,replace=#{},labels=Lbls,index={lazy,Is}}, opt(Is, [], St) end, Is0). @@ -292,7 +308,7 @@ find_fixpoint(OptFun, Is0) -> Is -> find_fixpoint(OptFun, Is) end. -opt([{test,_,{f,L}=Lbl,_}=I|[{jump,{f,L}}|_]=Is], Acc, St) -> +opt([{test,_,{f,L}=Lbl,_}=I|[{jump,{f,L}}|_]=Is], Acc0, St0) -> %% We have %% Test Label Ops %% jump Label @@ -301,10 +317,23 @@ opt([{test,_,{f,L}=Lbl,_}=I|[{jump,{f,L}}|_]=Is], Acc, St) -> case beam_utils:is_pure_test(I) of false -> %% Test is not pure; we must keep it. - opt(Is, [I|Acc], label_used(Lbl, St)); + opt(Is, [I|Acc0], label_used(Lbl, St0)); true -> %% The test is pure and its failure label is the same %% as in the jump that follows -- thus it is not needed. + %% Check if any of the previous instructions could also be eliminated. + {Acc,St} = opt_useless_loads(Acc0, L, St0), + opt(Is, Acc, St) + end; +opt([{test,_,{f,L}=Lbl,_}=I|[{label,L}|_]=Is], Acc0, St0) -> + %% Similar to the above, except we have a fall-through rather than jump + %% Test Label Ops + %% label Label + case beam_utils:is_pure_test(I) of + false -> + opt(Is, [I|Acc0], label_used(Lbl, St0)); + true -> + {Acc,St} = opt_useless_loads(Acc0, L, St0), opt(Is, Acc, St) end; opt([{test,Test0,{f,L}=Lbl,Ops}=I|[{jump,To}|Is]=Is0], Acc, St) -> @@ -326,30 +355,16 @@ opt([{test,_,{f,_}=Lbl,_,_,_}=I|Is], Acc, St) -> opt(Is, [I|Acc], label_used(Lbl, St)); opt([{select,_,_R,Fail,Vls}=I|Is], Acc, St) -> skip_unreachable(Is, [I|Acc], label_used([Fail|Vls], St)); -opt([{label,Lbl}=I|Is], Acc, #st{mlbl=Mlbl}=St0) -> - case maps:find(Lbl, Mlbl) of - {ok,Lbls} -> - %% Essential to remove the list of labels from the dictionary, - %% since we will rescan the inserted labels. We MUST rescan. - St = St0#st{mlbl=maps:remove(Lbl, Mlbl)}, - insert_labels([Lbl|Lbls], Is, Acc, St); - error -> - opt(Is, [I|Acc], St0) - end; +opt([{label,From}=I,{label,To}|Is], Acc, #st{replace=Replace}=St) -> + opt([I|Is], Acc, St#st{replace=Replace#{To => From}}); opt([{jump,{f,_}=X}|[{label,_},{jump,X}|_]=Is], Acc, St) -> opt(Is, Acc, St); opt([{jump,{f,Lbl}}|[{label,Lbl}|_]=Is], Acc, St) -> opt(Is, Acc, St); -opt([{jump,{f,L}=Lbl}=I|Is], Acc0, #st{mlbl=Mlbl0}=St0) -> - %% All labels before this jump instruction should now be - %% moved to the location of the jump's target. - {Lbls,Acc} = collect_labels(Acc0, St0), - St = case Lbls of - [] -> St0; - [_|_] -> - Mlbl = maps_append_list(L, Lbls, Mlbl0), - St0#st{mlbl=Mlbl} - end, +opt([{jump,{f,L}=Lbl}=I|Is], Acc0, St0) -> + %% Replace all labels before this jump instruction into the + %% location of the jump's target. + {Acc,St} = collect_labels(Acc0, L, St0), skip_unreachable(Is, [I|Acc], label_used(Lbl, St)); %% Optimization: quickly handle some common instructions that don't %% have any failure labels and where is_unreachable_after(I) =:= false. @@ -369,36 +384,72 @@ opt([I|Is], Acc, #st{labels=Used0}=St0) -> true -> skip_unreachable(Is, [I|Acc], St); false -> opt(Is, [I|Acc], St) end; -opt([], Acc, #st{mlbl=Mlbl}) -> - Code = reverse(Acc), - insert_fc_labels(Code, Mlbl). - -insert_fc_labels([{label,L}=I|Is0], Mlbl) -> - case maps:find(L, Mlbl) of - error -> - [I|insert_fc_labels(Is0, Mlbl)]; - {ok,Lbls} -> - Is = [{label,Lb} || Lb <- Lbls] ++ Is0, - [I|insert_fc_labels(Is, maps:remove(L, Mlbl))] +opt([], Acc, #st{replace=Replace0}) when Replace0 =/= #{} -> + Replace = normalize_replace(maps:to_list(Replace0), Replace0, []), + beam_utils:replace_labels(Acc, [], Replace, fun(Old) -> Old end); +opt([], Acc, #st{replace=Replace}) when Replace =:= #{} -> + reverse(Acc). + +normalize_replace([{From,To0}|Rest], Replace, Acc) -> + case Replace of + #{To0 := To} -> + normalize_replace([{From,To}|Rest], Replace, Acc); + _ -> + normalize_replace(Rest, Replace, [{From,To0}|Acc]) end; -insert_fc_labels([_|_]=Is, _) -> Is. - -maps_append_list(K,Vs,M) -> - case M of - #{K:=Vs0} -> M#{K:=Vs0++Vs}; % same order as dict - _ -> M#{K => Vs} - end. +normalize_replace([], _Replace, Acc) -> + maps:from_list(Acc). + +%% After eliminating a test, it might happen, that a register was only used +%% in this test. Let's check if that was the case and if it was so, we can +%% eliminate the load into the register completely. +opt_useless_loads([{block,_}|_]=Is, L, #st{index={lazy,FIs}}=St) -> + opt_useless_loads(Is, L, St#st{index=beam_utils:index_labels(FIs)}); +opt_useless_loads([{block,Block0}|Is], L, #st{index=Index}=St) -> + case opt_useless_block_loads(Block0, L, Index) of + [] -> + opt_useless_loads(Is, L, St); + [_|_]=Block -> + {[{block,Block}|Is],St} + end; +%% After eliminating the test and useless blocks, it might happen, +%% that the previous test could also be eliminated. +%% It might be that the label was already marked as used, even if ultimately, +%% it never will be - we can't do much about it at that point, though +opt_useless_loads([{test,_,{f,L},_}=I|Is], L, St) -> + case beam_utils:is_pure_test(I) of + false -> + {[I|Is],St}; + true -> + opt_useless_loads(Is, L, St) + end; +opt_useless_loads(Is, _L, St) -> + {Is,St}. + +opt_useless_block_loads([{set,[Dst],_,_}=I|Is], L, Index) -> + BlockJump = [{block,Is},{jump,{f,L}}], + case beam_utils:is_killed(Dst, BlockJump, Index) of + true -> + %% The register is killed and not used, we can remove the load + opt_useless_block_loads(Is, L, Index); + false -> + [I|opt_useless_block_loads(Is, L, Index)] + end; +opt_useless_block_loads([I|Is], L, Index) -> + [I|opt_useless_block_loads(Is, L, Index)]; +opt_useless_block_loads([], _L, _Index) -> + []. -collect_labels(Is, #st{entry=Entry}) -> - collect_labels_1(Is, Entry, []). +collect_labels(Is, Label, #st{entry=Entry,replace=Replace} = St) -> + collect_labels_1(Is, Label, Entry, Replace, St). -collect_labels_1([{label,Entry}|_]=Is, Entry, Acc) -> +collect_labels_1([{label,Entry}|_]=Is, _Label, Entry, Acc, St) -> %% Never move the entry label. - {Acc,Is}; -collect_labels_1([{label,L}|Is], Entry, Acc) -> - collect_labels_1(Is, Entry, [L|Acc]); -collect_labels_1(Is, _Entry, Acc) -> - {Acc,Is}. + {Is,St#st{replace=Acc}}; +collect_labels_1([{label,L}|Is], Label, Entry, Acc, St) -> + collect_labels_1(Is, Label, Entry, Acc#{L => Label}, St); +collect_labels_1(Is, _Label, _Entry, Acc, St) -> + {Is,St#st{replace=Acc}}. %% label_defined(Is, Label) -> true | false. %% Test whether the label Label is defined at the start of the instruction @@ -418,13 +469,6 @@ invert_test(is_eq_exact) -> is_ne_exact; invert_test(is_ne_exact) -> is_eq_exact; invert_test(_) -> not_possible. -insert_labels([L|Ls], Is, [{jump,{f,L}}|Acc], St) -> - insert_labels(Ls, [{label,L}|Is], Acc, St); -insert_labels([L|Ls], Is, Acc, St) -> - insert_labels(Ls, [{label,L}|Is], Acc, St); -insert_labels([], Is, Acc, St) -> - opt(Is, Acc, St). - %% skip_unreachable([Instruction], St). %% Remove all instructions (including definitions of labels %% that have not been referenced yet) up to the next diff --git a/lib/compiler/src/beam_listing.erl b/lib/compiler/src/beam_listing.erl index 836378727b..73c6501fe5 100644 --- a/lib/compiler/src/beam_listing.erl +++ b/lib/compiler/src/beam_listing.erl @@ -23,7 +23,6 @@ -include("core_parse.hrl"). -include("v3_kernel.hrl"). --include("v3_life.hrl"). -include("beam_disasm.hrl"). -import(lists, [foreach/2]). @@ -31,7 +30,6 @@ -type code() :: cerl:c_module() | beam_utils:module_code() | #k_mdef{} - | {module(),_,_,_} %v3_life | [_]. %form-based format -spec module(file:io_device(), code()) -> 'ok'. @@ -43,13 +41,9 @@ module(File, #k_mdef{}=Kern) -> %% This is a kernel module. io:put_chars(File, v3_kernel_pp:format(Kern)); %%io:put_chars(File, io_lib:format("~p~n", [Kern])); -module(File, {Mod,Exp,Attr,Kern}) -> - %% This is output from beam_life (v3). - io:fwrite(File, "~w.~n~p.~n~p.~n", [Mod,Exp,Attr]), - foreach(fun (F) -> function(File, F) end, Kern); module(Stream, {Mod,Exp,Attr,Code,NumLabels}) -> - %% This is output from beam_codegen. - io:format(Stream, "{module, ~p}. %% version = ~w\n", + %% This is output from v3_codegen. + io:format(Stream, "{module, ~p}. %% version = ~w\n", [Mod, beam_opcodes:format_number()]), io:format(Stream, "\n{exports, ~p}.\n", [Exp]), io:format(Stream, "\n{attributes, ~p}.\n", [Attr]), @@ -60,19 +54,6 @@ module(Stream, {Mod,Exp,Attr,Code,NumLabels}) -> [Name, Arity, Entry]), io:put_chars(Stream, format_asm(Asm)) end, Code); -module(Stream, Code) when is_binary(Code) -> - #beam_file{ module = Module, compile_info = CInfo } = beam_disasm:file(Code), - Loaded = code:is_loaded(Module), - Sticky = code:is_sticky(Module), - [code:unstick_mod(Module) || Sticky], - - {module, Module} = code:load_binary(Module, proplists:get_value(source, CInfo), Code), - ok = erts_debug:df(Stream, Module), - - %% Restore loaded module - _ = [{module, Module} = code:load_file(Module) || Loaded =/= false], - [code:stick_mod(Module) || Sticky], - ok; module(Stream, [_|_]=Fs) -> %% Form-based abstract format. foreach(fun (F) -> io:format(Stream, "~p.\n", [F]) end, Fs). @@ -82,60 +63,3 @@ format_asm([{label,L}|Is]) -> format_asm([I|Is]) -> [io_lib:format(" ~p", [I]),".\n"|format_asm(Is)]; format_asm([]) -> []. - -function(File, {function,Name,Arity,Args,Body,Vdb,_Anno}) -> - io:nl(File), - io:format(File, "function ~p/~p.\n", [Name,Arity]), - io:format(File, " ~p.\n", [Args]), - print_vdb(File, Vdb), - put(beam_listing_nl, false), - nl(File), - foreach(fun(F) -> format(File, F, []) end, Body), - nl(File), - erase(beam_listing_nl). - -format(File, #l{ke=Ke,i=I,vdb=Vdb}, Ind) -> - nl(File), - ind_format(File, Ind, "~p ", [I]), - print_vdb(File, Vdb), - nl(File), - format(File, Ke, Ind); -format(File, Tuple, Ind) when is_tuple(Tuple) -> - ind_format(File, Ind, "{", []), - format_list(File, tuple_to_list(Tuple), [$\s|Ind]), - ind_format(File, Ind, "}", []); -format(File, List, Ind) when is_list(List) -> - ind_format(File, Ind, "[", []), - format_list(File, List, [$\s|Ind]), - ind_format(File, Ind, "]", []); -format(File, F, Ind) -> - ind_format(File, Ind, "~p", [F]). - -format_list(File, [F], Ind) -> - format(File, F, Ind); -format_list(File, [F|Fs], Ind) -> - format(File, F, Ind), - ind_format(File, Ind, ",", []), - format_list(File, Fs, Ind); -format_list(_, [], _) -> ok. - - -print_vdb(File, [{Var,F,E}|Vs]) -> - io:format(File, "~p:~p..~p ", [Var,F,E]), - print_vdb(File, Vs); -print_vdb(_, []) -> ok. - -ind_format(File, Ind, Format, Args) -> - case get(beam_listing_nl) of - true -> - put(beam_listing_nl, false), - io:put_chars(File, Ind); - false -> ok - end, - io:format(File, Format, Args). - -nl(File) -> - case put(beam_listing_nl, true) of - true -> ok; - false -> io:nl(File) - end. diff --git a/lib/compiler/src/beam_peep.erl b/lib/compiler/src/beam_peep.erl index 6df5c02334..eb3192fe8f 100644 --- a/lib/compiler/src/beam_peep.erl +++ b/lib/compiler/src/beam_peep.erl @@ -41,8 +41,7 @@ function({function,Name,Arity,CLabel,Is0}) -> Is = beam_jump:remove_unused_labels(Is1), {function,Name,Arity,CLabel,Is} catch - Class:Error -> - Stack = erlang:get_stacktrace(), + Class:Error:Stack -> io:fwrite("Function: ~w/~w\n", [Name,Arity]), erlang:raise(Class, Error, Stack) end. @@ -89,15 +88,37 @@ peep([{gc_bif,_,_,_,_,Dst}=I|Is], SeenTests0, Acc) -> peep([{jump,{f,L}},{label,L}=I|Is], _, Acc) -> %% Sometimes beam_jump has missed this optimization. peep(Is, gb_sets:empty(), [I|Acc]); -peep([{select,Op,R,F,Vls0}|Is], _, Acc) -> +peep([{select,Op,R,F,Vls0}|Is], SeenTests0, Acc0) -> case prune_redundant_values(Vls0, F) of [] -> %% No values left. Must convert to plain jump. I = {jump,F}, - peep(Is, gb_sets:empty(), [I|Acc]); + peep([I|Is], gb_sets:empty(), Acc0); + [{atom,_}=Value,Lbl] when Op =:= select_val -> + %% Single value left. Convert to regular test and pop redundant tests. + Is1 = [{test,is_eq_exact,F,[R,Value]},{jump,Lbl}|Is], + case Acc0 of + [{test,is_atom,F,[R]}|Acc] -> + peep(Is1, SeenTests0, Acc); + _ -> + peep(Is1, SeenTests0, Acc0) + end; + [{integer,_}=Value,Lbl] when Op =:= select_val -> + %% Single value left. Convert to regular test and pop redundant tests. + Is1 = [{test,is_eq_exact,F,[R,Value]},{jump,Lbl}|Is], + case Acc0 of + [{test,is_integer,F,[R]}|Acc] -> + peep(Is1, SeenTests0, Acc); + _ -> + peep(Is1, SeenTests0, Acc0) + end; + [Arity,Lbl] when Op =:= select_tuple_arity -> + %% Single value left. Convert to regular test + Is1 = [{test,test_arity,F,[R,Arity]},{jump,Lbl}|Is], + peep(Is1, SeenTests0, Acc0); [_|_]=Vls -> I = {select,Op,R,F,Vls}, - peep(Is, gb_sets:empty(), [I|Acc]) + peep(Is, gb_sets:empty(), [I|Acc0]) end; peep([{test,Op,_,Ops}=I|Is], SeenTests0, Acc) -> case beam_utils:is_pure_test(I) of diff --git a/lib/compiler/src/beam_receive.erl b/lib/compiler/src/beam_receive.erl index 1403e1e05e..3c8efa577c 100644 --- a/lib/compiler/src/beam_receive.erl +++ b/lib/compiler/src/beam_receive.erl @@ -82,8 +82,7 @@ function({function,Name,Arity,Entry,Is}) -> D = beam_utils:index_labels(Is), {function,Name,Arity,Entry,opt(Is, D, [])} catch - Class:Error -> - Stack = erlang:get_stacktrace(), + Class:Error:Stack -> io:fwrite("Function: ~w/~w\n", [Name,Arity]), erlang:raise(Class, Error, Stack) end. @@ -207,6 +206,8 @@ opt_update_regs({label,Lbl}, R, L) -> %% A catch label for a previously seen catch instruction is OK. {R,L} end; +opt_update_regs({'try',_,{f,Lbl}}, R, L) -> + {R,gb_sets:add(Lbl, L)}; opt_update_regs({try_end,_}, R, L) -> {R,L}; opt_update_regs({line,_}, R, L) -> diff --git a/lib/compiler/src/beam_record.erl b/lib/compiler/src/beam_record.erl index 419089b1bc..58a6de6775 100644 --- a/lib/compiler/src/beam_record.erl +++ b/lib/compiler/src/beam_record.erl @@ -15,19 +15,12 @@ %% %% %CopyrightEnd% %% -%% File: beam_record.erl -%% Author: Björn-Egil Dahlberg -%% Created: 2014-09-03 -%% - --module(beam_record). --export([module/2]). %% Rewrite the instruction stream on tagged tuple tests. -%% Tagged tuples means a tuple of any arity with an atom as its first element. -%% Typically records, ok-tuples and error-tuples. -%% -%% from: +%% Tagged tuples means a tuple of any arity with an atom as its +%% first element, such as records and error tuples. +%% +%% From: %% ... %% {test,is_tuple,Fail,[Src]}. %% {test,test_arity,Fail,[Src,Sz]}. @@ -36,13 +29,16 @@ %% ... %% {test,is_eq_exact,Fail,[Dst,Atom]}. %% ... -%% to: +%% To: %% ... %% {test,is_tagged_tuple,Fail,[Src,Sz,Atom]}. %% ... +%% +-module(beam_record). +-export([module/2]). --import(lists, [reverse/1]). +-import(lists, [reverse/1,reverse/2]). -spec module(beam_utils:module_code(), [compile:option()]) -> {'ok',beam_utils:module_code()}. @@ -51,56 +47,85 @@ module({Mod,Exp,Attr,Fs0,Lc}, _Opt) -> Fs = [function(F) || F <- Fs0], {ok,{Mod,Exp,Attr,Fs,Lc}}. -function({function,Name,Arity,CLabel,Is}) -> +function({function,Name,Arity,CLabel,Is0}) -> try - Idx = beam_utils:index_labels(Is), - {function,Name,Arity,CLabel,rewrite(Is,Idx)} + Is1 = beam_utils:anno_defs(Is0), + Idx = beam_utils:index_labels(Is1), + Is = rewrite(reverse(Is1), Idx), + {function,Name,Arity,CLabel,Is} catch - Class:Error -> - Stack = erlang:get_stacktrace(), + Class:Error:Stack -> io:fwrite("Function: ~w/~w\n", [Name,Arity]), erlang:raise(Class, Error, Stack) end. -rewrite(Is,Idx) -> - rewrite(Is,Idx,[]). +rewrite(Is, Idx) -> + rewrite(Is, Idx, 0, []). -rewrite([{test,is_tuple,Fail,[Src]}=I1, - {test,test_arity,Fail,[Src,N]}=I2|Is],Idx,Acc) -> - case is_tagged_tuple(Is,Fail,Src,Idx) of +rewrite([{test,test_arity,Fail,[Src,N]}=TA, + {test,is_tuple,Fail,[Src]}=TT|Is], Idx, Def, Acc0) -> + case is_tagged_tuple(Acc0, Def, Fail, Src, Idx) of no -> - rewrite(Is,Idx,[I2,I1|Acc]); - {Atom,[{block,[]}|Is1]} -> - rewrite(Is1,Idx,[{test,is_tagged_tuple,Fail,[Src,N,Atom]}|Acc]); - {Atom,Is1} -> - rewrite(Is1,Idx,[{test,is_tagged_tuple,Fail,[Src,N,Atom]}|Acc]) + rewrite(Is, Idx, 0, [TT,TA|Acc0]); + {yes,Atom,Acc} -> + I = {test,is_tagged_tuple,Fail,[Src,N,Atom]}, + rewrite(Is, Idx, Def, [I|Acc]) end; -rewrite([I|Is],Idx,Acc) -> - rewrite(Is,Idx,[I|Acc]); -rewrite([],_,Acc) -> reverse(Acc). - -is_tagged_tuple([{block,[{set,[Dst],[Src],{get_tuple_element,0}}=B|Bs]}, - {test,is_eq_exact,Fail,[Dst,{atom,_}=Atom]}|Is],Fail,Src,Idx) -> +rewrite([{block,[{'%anno',{def,Def}}|Bl]}|Is], Idx, _Def, Acc) -> + rewrite(Is, Idx, Def, [{block,Bl}|Acc]); +rewrite([{label,L}=I|Is], Idx0, Def, Acc) -> + Idx = beam_utils:index_label(L, Acc, Idx0), + rewrite(Is, Idx, Def, [I|Acc]); +rewrite([I|Is], Idx, Def, Acc) -> + rewrite(Is, Idx, Def, [I|Acc]); +rewrite([], _, _, Acc) -> Acc. - %% if Dst is killed in the instruction stream and at fail label, - %% we can safely remove get_tuple_element. - %% - %% if Dst is not killed in the stream, we cannot remove get_tuple_element - %% since it is referenced. - - case is_killed(Dst,Is,Fail,Idx) of - true -> {Atom,[{block,Bs}|Is]}; - false -> {Atom,[{block,[B|Bs]}|Is]} +is_tagged_tuple([{block,Bl}, + {test,is_eq_exact,Fail,[Dst,{atom,_}=Atom]}|Is], + Def, Fail, Src, Idx) -> + case is_tagged_tuple_1(Bl, Is, Fail, Src, Dst, Idx, Def, []) of + no -> + no; + {yes,[]} -> + {yes,Atom,Is}; + {yes,[_|_]=Block} -> + {yes,Atom,[{block,Block}|Is]} end; -is_tagged_tuple([{block,[{set,_,_,_}=B|Bs]}, - {test,is_eq_exact,_,_}=I|Is],Fail,Src,Idx) -> - case is_tagged_tuple([{block,Bs},I|Is],Fail,Src,Idx) of - {Atom,[{block,Bsr}|Isr]} -> {Atom,[{block,[B|Bsr]}|Isr]}; - no -> no +is_tagged_tuple(_, _, _, _, _) -> + no. + +is_tagged_tuple_1([{set,[Dst],[Src],{get_tuple_element,0}}=I|Bl], + Is, Fail, Src, Dst, Idx, Def, Acc) -> + %% Check usage of Dst to find out whether the get_tuple_element + %% is needed. + case usage(Dst, Is, Fail, Idx) of + killed -> + %% Safe to remove the get_tuple_element instruction. + {yes,reverse(Acc, Bl)}; + used -> + %% Actively used. Must keep instruction. + {yes,reverse(Acc, [I|Bl])}; + not_used -> + %% Not actually used (but must be initialized). + case is_defined(Dst, Def) of + false -> + %% Dst must be initialized, but the + %% actual value does not matter. + Kill = {set,[Dst],[nil],move}, + {yes,reverse(Acc, [Kill|Bl])}; + true -> + %% The register is previously initialized. + %% We can remove the instruction. + {yes,reverse(Acc, Bl)} + end end; -is_tagged_tuple(_Is,_Fail,_Src,_Idx) -> +is_tagged_tuple_1([I|Bl], Is, Fail, Src, Dst, Idx, Def, Acc) -> + is_tagged_tuple_1(Bl, Is, Fail, Src, Dst, Idx, Def, [I|Acc]); +is_tagged_tuple_1(_, _, _, _, _, _, _, _) -> no. -is_killed(Dst,Is,{_,Lbl},Idx) -> - beam_utils:is_killed(Dst,Is,Idx) andalso - beam_utils:is_killed_at(Dst,Lbl,Idx). +usage(Dst, Is, Fail, Idx) -> + beam_utils:usage(Dst, [{test,is_number,Fail,[nil]}|Is], Idx). + +is_defined({x,X}, Def) -> + (Def bsr X) band 1 =:= 1. diff --git a/lib/compiler/src/beam_reorder.erl b/lib/compiler/src/beam_reorder.erl index 910b7f6b0a..63bb57a1ac 100644 --- a/lib/compiler/src/beam_reorder.erl +++ b/lib/compiler/src/beam_reorder.erl @@ -35,8 +35,7 @@ function({function,Name,Arity,CLabel,Is0}) -> Is = reorder(Is0), {function,Name,Arity,CLabel,Is} catch - Class:Error -> - Stack = erlang:get_stacktrace(), + Class:Error:Stack -> io:fwrite("Function: ~w/~w\n", [Name,Arity]), erlang:raise(Class, Error, Stack) end. diff --git a/lib/compiler/src/beam_split.erl b/lib/compiler/src/beam_split.erl index d041f18806..52dd89b5bb 100644 --- a/lib/compiler/src/beam_split.erl +++ b/lib/compiler/src/beam_split.erl @@ -50,8 +50,9 @@ split_block([{set,[R],[_,_,_]=As,{bif,is_record,{f,Lbl}}}|Is], Bl, Acc) -> split_block(Is, [], [{bif,is_record,{f,Lbl},As,R}|make_block(Bl, Acc)]); split_block([{set,[R],As,{bif,N,{f,Lbl}=Fail}}|Is], Bl, Acc) when Lbl =/= 0 -> split_block(Is, [], [{bif,N,Fail,As,R}|make_block(Bl, Acc)]); -split_block([{set,[R],As,{bif,raise,{f,_}=Fail}}|Is], Bl, Acc) -> - split_block(Is, [], [{bif,raise,Fail,As,R}|make_block(Bl, Acc)]); +split_block([{set,[],[],{line,_}=Line}, + {set,[R],As,{bif,raise,{f,_}=Fail}}|Is], Bl, Acc) -> + split_block(Is, [], [{bif,raise,Fail,As,R},Line|make_block(Bl, Acc)]); split_block([{set,[R],As,{alloc,Live,{gc_bif,N,{f,Lbl}=Fail}}}|Is], Bl, Acc) when Lbl =/= 0 -> split_block(Is, [], [{gc_bif,N,Fail,Live,As,R}|make_block(Bl, Acc)]); @@ -61,8 +62,6 @@ split_block([{set,[D],[S|Puts],{alloc,R,{put_map,Op,{f,Lbl}=Fail}}}|Is], make_block(Bl, Acc)]); split_block([{set,[R],[],{try_catch,Op,L}}|Is], Bl, Acc) -> split_block(Is, [], [{Op,R,L}|make_block(Bl, Acc)]); -split_block([{set,[],[],{line,_}=Line}|Is], Bl, Acc) -> - split_block(Is, [], [Line|make_block(Bl, Acc)]); split_block([I|Is], Bl, Acc) -> split_block(Is, [I|Bl], Acc); split_block([], Bl, Acc) -> make_block(Bl, Acc). diff --git a/lib/compiler/src/beam_type.erl b/lib/compiler/src/beam_type.erl index fc2c7a991b..28f36db399 100644 --- a/lib/compiler/src/beam_type.erl +++ b/lib/compiler/src/beam_type.erl @@ -17,14 +17,15 @@ %% %% %CopyrightEnd% %% -%% Purpose : Type-based optimisations. +%% Purpose: Type-based optimisations. See the comment for verified_type/1 +%% the very end of this file for a description of the types in the +%% type database. -module(beam_type). -export([module/2]). --import(lists, [filter/2,foldl/3,keyfind/3,member/2, - reverse/1,reverse/2,sort/1]). +-import(lists, [foldl/3,member/2,reverse/1,reverse/2,sort/1]). -define(UNICODE_INT, {integer,{0,16#10FFFF}}). @@ -40,11 +41,10 @@ function({function,Name,Arity,CLabel,Asm0}) -> Asm1 = beam_utils:live_opt(Asm0), Asm2 = opt(Asm1, [], tdb_new()), Asm3 = beam_utils:live_opt(Asm2), - Asm = beam_utils:delete_live_annos(Asm3), + Asm = beam_utils:delete_annos(Asm3), {function,Name,Arity,CLabel,Asm} catch - Class:Error -> - Stack = erlang:get_stacktrace(), + Class:Error:Stack -> io:fwrite("Function: ~w/~w\n", [Name,Arity]), erlang:raise(Class, Error, Stack) end. @@ -81,80 +81,81 @@ simplify(Is0, TypeDb0) -> %% Basic simplification, mostly tuples, no floating point optimizations. simplify_basic(Is, Ts) -> - simplify_basic_1(Is, Ts, []). - -simplify_basic_1([{set,[D],[{integer,Index},Reg],{bif,element,_}}=I0|Is], Ts0, Acc) -> - I = case max_tuple_size(Reg, Ts0) of - Sz when 0 < Index, Index =< Sz -> - {set,[D],[Reg],{get_tuple_element,Index-1}}; - _Other -> I0 - end, - Ts = update(I, Ts0), - simplify_basic_1(Is, Ts, [I|Acc]); -simplify_basic_1([{set,[D],[TupleReg],{get_tuple_element,0}}=I|Is0], Ts0, Acc) -> - case tdb_find(TupleReg, Ts0) of - {tuple,_,[Contents]} -> - simplify_basic_1([{set,[D],[Contents],move}|Is0], Ts0, Acc); - _ -> - Ts = update(I, Ts0), - simplify_basic_1(Is0, Ts, [I|Acc]) + simplify_basic(Is, Ts, []). + +simplify_basic([I0|Is], Ts0, Acc) -> + case simplify_instr(I0, Ts0) of + [] -> + simplify_basic(Is, Ts0, Acc); + [I] -> + Ts = update(I, Ts0), + simplify_basic(Is, Ts, [I|Acc]) end; -simplify_basic_1([{set,_,_,{try_catch,_,_}}=I|Is], _Ts, Acc) -> - simplify_basic_1(Is, tdb_new(), [I|Acc]); -simplify_basic_1([{test,is_atom,_,[R]}=I|Is], Ts, Acc) -> +simplify_basic([], Ts, Acc) -> + {reverse(Acc),Ts}. + +%% simplify_instr(Instruction, Ts) -> [Instruction]. + +%% Simplify a simple instruction using type information. Return an +%% empty list if the instruction should be removed, or a list with +%% the original or modified instruction. + +simplify_instr({set,[D],[{integer,Index},Reg],{bif,element,_}}=I, Ts) -> + case max_tuple_size(Reg, Ts) of + Sz when 0 < Index, Index =< Sz -> + [{set,[D],[Reg],{get_tuple_element,Index-1}}]; + _ -> [I] + end; +simplify_instr({test,Test,Fail,[R]}=I, Ts) -> case tdb_find(R, Ts) of - boolean -> simplify_basic_1(Is, Ts, Acc); - _ -> simplify_basic_1(Is, Ts, [I|Acc]) + any -> + [I]; + Type -> + case will_succeed(Test, Type) of + yes -> []; + no -> [{jump,Fail}]; + maybe -> [I] + end + end; +simplify_instr({set,[D],[TupleReg],{get_tuple_element,0}}=I, Ts) -> + case tdb_find(TupleReg, Ts) of + {tuple,_,_,[Contents]} -> + [{set,[D],[Contents],move}]; + _ -> + [I] end; -simplify_basic_1([{test,is_integer,_,[R]}=I|Is], Ts, Acc) -> +simplify_instr({test,test_arity,_,[R,Arity]}=I, Ts) -> case tdb_find(R, Ts) of - integer -> simplify_basic_1(Is, Ts, Acc); - {integer,_} -> simplify_basic_1(Is, Ts, Acc); - _ -> simplify_basic_1(Is, Ts, [I|Acc]) + {tuple,exact_size,Arity,_} -> []; + _ -> [I] end; -simplify_basic_1([{test,is_tuple,_,[R]}=I|Is], Ts, Acc) -> +simplify_instr({test,is_eq_exact,Fail,[R,{atom,A}=Atom]}=I, Ts) -> case tdb_find(R, Ts) of - {tuple,_,_} -> simplify_basic_1(Is, Ts, Acc); - _ -> simplify_basic_1(Is, Ts, [I|Acc]) + {atom,_}=Atom -> []; + boolean when is_boolean(A) -> [I]; + any -> [I]; + _ -> [{jump,Fail}] end; -simplify_basic_1([{test,is_map,_,[R]}=I|Is], Ts0, Acc) -> - case tdb_find(R, Ts0) of - map -> simplify_basic_1(Is, Ts0, Acc); - _Other -> - Ts = update(I, Ts0), - simplify_basic_1(Is, Ts, [I|Acc]) +simplify_instr({test,is_record,_,[R,{atom,_}=Tag,{integer,Arity}]}=I, Ts) -> + case tdb_find(R, Ts) of + {tuple,exact_size,Arity,[Tag]} -> []; + _ -> [I] end; -simplify_basic_1([{test,is_nonempty_list,_,[R]}=I|Is], Ts0, Acc) -> - case tdb_find(R, Ts0) of - nonempty_list -> simplify_basic_1(Is, Ts0, Acc); - _Other -> - Ts = update(I, Ts0), - simplify_basic_1(Is, Ts, [I|Acc]) - end; -simplify_basic_1([{test,is_eq_exact,Fail,[R,{atom,_}=Atom]}=I|Is0], Ts0, Acc0) -> - Acc = case tdb_find(R, Ts0) of - {atom,_}=Atom -> Acc0; - {atom,_} -> [{jump,Fail}|Acc0]; - _ -> [I|Acc0] - end, - Ts = update(I, Ts0), - simplify_basic_1(Is0, Ts, Acc); -simplify_basic_1([{select,select_val,Reg,_,_}=I0|Is], Ts, Acc) -> - I = case tdb_find(Reg, Ts) of - {integer,Range} -> - simplify_select_val_int(I0, Range); - boolean -> - simplify_select_val_bool(I0); - _ -> - I0 - end, - simplify_basic_1(Is, tdb_new(), [I|Acc]); -simplify_basic_1([I|Is], Ts0, Acc) -> - Ts = update(I, Ts0), - simplify_basic_1(Is, Ts, [I|Acc]); -simplify_basic_1([], Ts, Acc) -> - Is = reverse(Acc), - {Is,Ts}. +simplify_instr({select,select_val,Reg,_,_}=I, Ts) -> + [case tdb_find(Reg, Ts) of + {integer,Range} -> + simplify_select_val_int(I, Range); + boolean -> + simplify_select_val_bool(I); + _ -> + I + end]; +simplify_instr({test,bs_test_unit,_,[Src,Unit]}=I, Ts) -> + case tdb_find(Src, Ts) of + {binary,U} when U rem Unit =:= 0 -> []; + _ -> [I] + end; +simplify_instr(I, _) -> [I]. simplify_select_val_int({select,select_val,R,_,L0}=I, {Min,Max}) -> Vs = sort([V || {integer,V} <- L0]), @@ -182,6 +183,53 @@ eq_ranges([H], H, H) -> true; eq_ranges([H|T], H, Max) -> eq_ranges(T, H+1, Max); eq_ranges(_, _, _) -> false. +%% will_succeed(TestOperation, Type) -> yes|no|maybe. +%% Test whether TestOperation applied to an argument of type Type +%% will succeed. Return yes, no, or maybe. +%% +%% Type is a type as described in the comment for verified_type/1 at +%% the very end of this file, but it will *never* be 'any'. + +will_succeed(is_atom, Type) -> + case Type of + {atom,_} -> yes; + boolean -> yes; + _ -> no + end; +will_succeed(is_binary, Type) -> + case Type of + {binary,U} when U rem 8 =:= 0 -> yes; + {binary,_} -> maybe; + _ -> no + end; +will_succeed(is_bitstr, Type) -> + case Type of + {binary,_} -> yes; + _ -> no + end; +will_succeed(is_integer, Type) -> + case Type of + integer -> yes; + {integer,_} -> yes; + _ -> no + end; +will_succeed(is_map, Type) -> + case Type of + map -> yes; + _ -> no + end; +will_succeed(is_nonempty_list, Type) -> + case Type of + nonempty_list -> yes; + _ -> no + end; +will_succeed(is_tuple, Type) -> + case Type of + {tuple,_,_,_} -> yes; + _ -> no + end; +will_succeed(_, _) -> maybe. + %% simplify_float([Instruction], TypeDatabase) -> %% {[Instruction],TypeDatabase'} | not_possible %% Simplify floating point operations in blocks. @@ -211,7 +259,7 @@ simplify_float_1([{set,[D0],[A0],{alloc,_,{gc_bif,'-',{f,0}}}}=I|Is]=Is0, {D,Rs} = find_dest(D0, Rs1), Areg = fetch_reg(A, Rs), Acc = [{set,[D],[Areg],{bif,fnegate,{f,0}}}|clearerror(Acc1)], - Ts = tdb_update([{D0,float}], Ts0), + Ts = tdb_store(D0, float, Ts0), simplify_float_1(Is, Ts, Rs, Acc); _Other -> Ts = update(I, Ts0), @@ -234,7 +282,7 @@ simplify_float_1([{set,[D0],[A0,B0],{alloc,_,{gc_bif,Op0,{f,0}}}}=I|Is]=Is0, Areg = fetch_reg(A, Rs), Breg = fetch_reg(B, Rs), Acc = [{set,[D],[Areg,Breg],{bif,Op,{f,0}}}|clearerror(Acc2)], - Ts = tdb_update([{D0,float}], Ts0), + Ts = tdb_store(D0, float, Ts0), simplify_float_1(Is, Ts, Rs, Acc) end; simplify_float_1([{set,_,_,{try_catch,_,_}}=I|Is]=Is0, _Ts, Rs0, Acc0) -> @@ -285,7 +333,7 @@ clearerror([], OrigIs) -> [{set,[],[],fclearerror}|OrigIs]. %% Combine two blocks and eliminate any move instructions that assign %% to registers that are killed later in the block. %% -merge_blocks(B1, [{'%live',_,_}|B2]) -> +merge_blocks(B1, [{'%anno',_}|B2]) -> merge_blocks_1(B1++[{set,[],[],stop_here}|B2]). merge_blocks_1([{set,[],_,stop_here}|Is]) -> Is; @@ -334,29 +382,17 @@ flt_need_heap_2({set,_,_,{put_tuple,_}}, H, Fl) -> {[],H+1,Fl}; flt_need_heap_2({set,_,_,put}, H, Fl) -> {[],H+1,Fl}; -%% Then the "neutral" instructions. We just pass them. -flt_need_heap_2({set,[{fr,_}],_,_}, H, Fl) -> - {[],H,Fl}; -flt_need_heap_2({set,[],[],fclearerror}, H, Fl) -> - {[],H,Fl}; -flt_need_heap_2({set,[],[],fcheckerror}, H, Fl) -> - {[],H,Fl}; -flt_need_heap_2({set,_,_,{bif,_,_}}, H, Fl) -> - {[],H,Fl}; -flt_need_heap_2({set,_,_,move}, H, Fl) -> - {[],H,Fl}; -flt_need_heap_2({set,_,_,{get_tuple_element,_}}, H, Fl) -> - {[],H,Fl}; -flt_need_heap_2({set,_,_,get_list}, H, Fl) -> - {[],H,Fl}; -flt_need_heap_2({set,_,_,{try_catch,_,_}}, H, Fl) -> - {[],H,Fl}; -flt_need_heap_2({set,_,_,init}, H, Fl) -> - {[],H,Fl}; -%% All other instructions should cause the insertion of an allocation +%% The following instructions cause the insertion of an allocation %% instruction if needed. +flt_need_heap_2({set,_,_,{alloc,_,_}}, H, Fl) -> + {flt_alloc(H, Fl),0,0}; +flt_need_heap_2({set,_,_,{set_tuple_element,_}}, H, Fl) -> + {flt_alloc(H, Fl),0,0}; +flt_need_heap_2({'%anno',_}, H, Fl) -> + {flt_alloc(H, Fl),0,0}; +%% All other instructions are "neutral". We just pass them. flt_need_heap_2(_, H, Fl) -> - {flt_alloc(H, Fl),0,0}. + {[],H,Fl}. flt_alloc(0, 0) -> []; @@ -379,7 +415,7 @@ build_alloc(Words, Floats) -> {alloc,[{words,Words},{floats,Floats}]}. %% is not continous at an allocation function (e.g. if {x,0} and {x,2} %% are live, but not {x,1}). -flt_liveness([{'%live',_Live,Regs}=LiveInstr|Is]) -> +flt_liveness([{'%anno',{used,Regs}}=LiveInstr|Is]) -> flt_liveness_1(Is, Regs, [LiveInstr]). flt_liveness_1([{set,Ds,Ss,{alloc,Live0,Alloc}}|Is], Regs0, Acc) -> @@ -391,7 +427,7 @@ flt_liveness_1([{set,Ds,Ss,{alloc,Live0,Alloc}}|Is], Regs0, Acc) -> flt_liveness_1([{set,Ds,_,_}=I|Is], Regs0, Acc) -> Regs = x_live(Ds, Regs0), flt_liveness_1(Is, Regs, [I|Acc]); -flt_liveness_1([{'%live',_,_}], _Regs, Acc) -> +flt_liveness_1([{'%anno',_}], _Regs, Acc) -> reverse(Acc). init_regs(Live) -> @@ -415,103 +451,104 @@ x_live([], Regs) -> Regs. %% Update the type database to account for executing an instruction. %% %% First the cases for instructions inside basic blocks. -update({'%live',_,_}, Ts) -> Ts; +update({'%anno',_}, Ts) -> + Ts; update({set,[D],[S],move}, Ts) -> tdb_copy(S, D, Ts); -update({set,[D],[{integer,I},Reg],{bif,element,_}}, Ts0) -> - tdb_update([{Reg,{tuple,I,[]}},{D,kill}], Ts0); -update({set,[D],[_Index,Reg],{bif,element,_}}, Ts0) -> - tdb_update([{Reg,{tuple,0,[]}},{D,kill}], Ts0); -update({set,[D],Args,{bif,N,_}}, Ts0) -> +update({set,[D],[Index,Reg],{bif,element,_}}, Ts0) -> + MinSize = case Index of + {integer,I} -> I; + _ -> 0 + end, + Ts = tdb_meet(Reg, {tuple,min_size,MinSize,[]}, Ts0), + tdb_store(D, any, Ts); +update({set,[D],Args,{bif,N,_}}, Ts) -> Ar = length(Args), BoolOp = erl_internal:new_type_test(N, Ar) orelse erl_internal:comp_op(N, Ar) orelse erl_internal:bool_op(N, Ar), - case BoolOp of - true -> - tdb_update([{D,boolean}], Ts0); - false -> - tdb_update([{D,kill}], Ts0) + Type = case BoolOp of + true -> boolean; + false -> unary_op_type(N) + end, + tdb_store(D, Type, Ts); +update({set,[D],[S],{get_tuple_element,0}}, Ts0) -> + if + D =:= S -> + tdb_store(D, any, Ts0); + true -> + Ts = tdb_store(D, {tuple_element,S,0}, Ts0), + tdb_store(S, {tuple,min_size,1,[]}, Ts) end; -update({set,[D],[S],{get_tuple_element,0}}, Ts) -> - tdb_update([{D,{tuple_element,S,0}}], Ts); update({set,[D],[S],{alloc,_,{gc_bif,float,{f,0}}}}, Ts0) -> %% Make sure we reject non-numeric literal argument. case possibly_numeric(S) of - true -> tdb_update([{D,float}], Ts0); - false -> Ts0 + true -> tdb_store(D, float, Ts0); + false -> Ts0 end; update({set,[D],[S1,S2],{alloc,_,{gc_bif,'band',{f,0}}}}, Ts) -> - case keyfind(integer, 1, [S1,S2]) of - {integer,N} -> - update_band(N, D, Ts); - false -> - tdb_update([{D,integer}], Ts) - end; -update({set,[D],[S1,S2],{alloc,_,{gc_bif,'/',{f,0}}}}, Ts0) -> + Type = band_type(S1, S2, Ts), + tdb_store(D, Type, Ts); +update({set,[D],[S1,S2],{alloc,_,{gc_bif,'/',{f,0}}}}, Ts) -> %% Make sure we reject non-numeric literals. case possibly_numeric(S1) andalso possibly_numeric(S2) of - true -> tdb_update([{D,float}], Ts0); - false -> Ts0 + true -> tdb_store(D, float, Ts); + false -> Ts end; update({set,[D],[S1,S2],{alloc,_,{gc_bif,Op,{f,0}}}}, Ts0) -> case op_type(Op) of integer -> - tdb_update([{D,integer}], Ts0); - {float,_} -> - case {tdb_find(S1, Ts0),tdb_find(S2, Ts0)} of - {float,_} -> tdb_update([{D,float}], Ts0); - {_,float} -> tdb_update([{D,float}], Ts0); - {_,_} -> tdb_update([{D,kill}], Ts0) - end; - unknown -> - tdb_update([{D,kill}], Ts0) - end; -update({set,[],_Src,_Op}, Ts0) -> Ts0; -update({set,[D],_Src,_Op}, Ts0) -> - tdb_update([{D,kill}], Ts0); -update({set,[D1,D2],_Src,_Op}, Ts0) -> - tdb_update([{D1,kill},{D2,kill}], Ts0); + tdb_store(D, integer, Ts0); + {float,_} -> + case {tdb_find(S1, Ts0),tdb_find(S2, Ts0)} of + {float,_} -> tdb_store(D, float, Ts0); + {_,float} -> tdb_store(D, float, Ts0); + {_,_} -> tdb_store(D, any, Ts0) + end; + Type -> + tdb_store(D, Type, Ts0) + end; +update({set,[D],[_],{alloc,_,{gc_bif,Op,{f,0}}}}, Ts) -> + tdb_store(D, unary_op_type(Op), Ts); +update({set,[],_Src,_Op}, Ts) -> + Ts; +update({set,[D],_Src,_Op}, Ts) -> + tdb_store(D, any, Ts); update({kill,D}, Ts) -> - tdb_update([{D,kill}], Ts); + tdb_store(D, any, Ts); %% Instructions outside of blocks. -update({test,is_float,_Fail,[Src]}, Ts0) -> - tdb_update([{Src,float}], Ts0); -update({test,test_arity,_Fail,[Src,Arity]}, Ts0) -> - tdb_update([{Src,{tuple,Arity,[]}}], Ts0); -update({test,is_map,_Fail,[Src]}, Ts0) -> - tdb_update([{Src,map}], Ts0); +update({test,test_arity,_Fail,[Src,Arity]}, Ts) -> + tdb_meet(Src, {tuple,exact_size,Arity,[]}, Ts); update({get_map_elements,_,Src,{list,Elems0}}, Ts0) -> + Ts1 = tdb_meet(Src, map, Ts0), {_Ss,Ds} = beam_utils:split_even(Elems0), - Elems = [{Dst,kill} || Dst <- Ds], - tdb_update([{Src,map}|Elems], Ts0); -update({test,is_nonempty_list,_Fail,[Src]}, Ts0) -> - tdb_update([{Src,nonempty_list}], Ts0); -update({test,is_eq_exact,_,[Reg,{atom,_}=Atom]}, Ts) -> - case tdb_find(Reg, Ts) of - error -> - Ts; - {tuple_element,TupleReg,0} -> - tdb_update([{TupleReg,{tuple,1,[Atom]}}], Ts); - _ -> - Ts - end; + foldl(fun(Dst, A) -> tdb_store(Dst, any, A) end, Ts1, Ds); +update({test,is_eq_exact,_,[Reg,{atom,_}=Atom]}, Ts0) -> + Ts = case tdb_find_source_tuple(Reg, Ts0) of + {source_tuple,TupleReg} -> + tdb_meet(TupleReg, {tuple,min_size,1,[Atom]}, Ts0); + none -> + Ts0 + end, + tdb_meet(Reg, Atom, Ts); update({test,is_record,_Fail,[Src,Tag,{integer,Arity}]}, Ts) -> - tdb_update([{Src,{tuple,Arity,[Tag]}}], Ts); + tdb_meet(Src, {tuple,exact_size,Arity,[Tag]}, Ts); -%% Binary matching +%% Binaries and binary matching. update({test,bs_get_integer2,_,_,Args,Dst}, Ts) -> - tdb_update([{Dst,get_bs_integer_type(Args)}], Ts); + tdb_store(Dst, get_bs_integer_type(Args), Ts); update({test,bs_get_utf8,_,_,_,Dst}, Ts) -> - tdb_update([{Dst,?UNICODE_INT}], Ts); + tdb_store(Dst, ?UNICODE_INT, Ts); update({test,bs_get_utf16,_,_,_,Dst}, Ts) -> - tdb_update([{Dst,?UNICODE_INT}], Ts); + tdb_store(Dst, ?UNICODE_INT, Ts); update({test,bs_get_utf32,_,_,_,Dst}, Ts) -> - tdb_update([{Dst,?UNICODE_INT}], Ts); + tdb_store(Dst, ?UNICODE_INT, Ts); +update({bs_init,_,{bs_init2,_,_},_,_,Dst}, Ts) -> + tdb_store(Dst, {binary,8}, Ts); update({bs_init,_,_,_,_,Dst}, Ts) -> - tdb_update([{Dst,kill}], Ts); + tdb_store(Dst, {binary,1}, Ts); update({bs_put,_,_,_}, Ts) -> Ts; update({bs_save2,_,_}, Ts) -> @@ -519,14 +556,31 @@ update({bs_save2,_,_}, Ts) -> update({bs_restore2,_,_}, Ts) -> Ts; update({bs_context_to_binary,Dst}, Ts) -> - tdb_update([{Dst,kill}], Ts); -update({test,bs_start_match2,_,_,_,Dst}, Ts) -> - tdb_update([{Dst,kill}], Ts); -update({test,bs_get_binary2,_,_,_,Dst}, Ts) -> - tdb_update([{Dst,kill}], Ts); + tdb_store(Dst, {binary,1}, Ts); +update({test,bs_start_match2,_,_,[Src,_],Dst}, Ts0) -> + Ts = tdb_meet(Src, {binary,1}, Ts0), + tdb_copy(Src, Dst, Ts); +update({test,bs_get_binary2,_,_,[_,_,Unit,_],Dst}, Ts) -> + true = is_integer(Unit), %Assertion. + tdb_store(Dst, {binary,Unit}, Ts); update({test,bs_get_float2,_,_,_,Dst}, Ts) -> - tdb_update([{Dst,float}], Ts); - + tdb_store(Dst, float, Ts); +update({test,bs_test_unit,_,[Src,Unit]}, Ts) -> + tdb_meet(Src, {binary,Unit}, Ts); + +%% Other test instructions +update({test,Test,_Fail,[Src]}, Ts) -> + Type = case Test of + is_binary -> {binary,8}; + is_bitstr -> {binary,1}; + is_boolean -> boolean; + is_float -> float; + is_integer -> integer; + is_map -> map; + is_nonempty_list -> nonempty_list; + _ -> any + end, + tdb_meet(Src, Type, Ts); update({test,_Test,_Fail,_Other}, Ts) -> Ts; @@ -534,13 +588,13 @@ update({test,_Test,_Fail,_Other}, Ts) -> update({call_ext,Ar,{extfunc,math,Math,Ar}}, Ts) -> case is_math_bif(Math, Ar) of - true -> tdb_update([{{x,0},float}], Ts); + true -> tdb_store({x,0}, float, Ts); false -> tdb_kill_xregs(Ts) end; update({call_ext,3,{extfunc,erlang,setelement,3}}, Ts0) -> Ts = tdb_kill_xregs(Ts0), case tdb_find({x,1}, Ts0) of - {tuple,Sz,_}=T0 -> + {tuple,SzKind,Sz,_}=T0 -> T = case tdb_find({x,0}, Ts0) of {integer,{I,I}} when I > 1 -> %% First element is not changed. The result @@ -549,9 +603,9 @@ update({call_ext,3,{extfunc,erlang,setelement,3}}, Ts0) -> _ -> %% Position is 1 or unknown. May change the %% first element of the tuple. - {tuple,Sz,[]} + {tuple,SzKind,Sz,[]} end, - tdb_update([{{x,0},T}], Ts); + tdb_store({x,0}, T, Ts); _ -> Ts end; @@ -562,24 +616,32 @@ update({call_fun, _}, Ts) -> tdb_kill_xregs(Ts); update({apply, _}, Ts) -> tdb_kill_xregs(Ts); update({line,_}, Ts) -> Ts; +update({'%',_}, Ts) -> Ts; %% The instruction is unknown. Kill all information. update(_I, _Ts) -> tdb_new(). -update_band(N, Reg, Ts) -> - Type = update_band_1(N, 0), - tdb_update([{Reg,Type}], Ts). +band_type({integer,Int}, Other, Ts) -> + band_type_1(Int, Other, Ts); +band_type(Other, {integer,Int}, Ts) -> + band_type_1(Int, Other, Ts); +band_type(_, _, _) -> integer. + +band_type_1(Int, OtherSrc, Ts) -> + Type = band_type_2(Int, 0), + OtherType = tdb_find(OtherSrc, Ts), + meet(Type, OtherType). -update_band_1(N, Bits) when Bits < 64 -> +band_type_2(N, Bits) when Bits < 64 -> case 1 bsl Bits of P when P =:= N + 1 -> {integer,{0,N}}; P when P > N + 1 -> integer; _ -> - update_band_1(N, Bits+1) + band_type_2(N, Bits+1) end; -update_band_1(_, _) -> +band_type_2(_, _) -> %% Negative or large positive number. Give up. integer. @@ -633,7 +695,7 @@ possibly_numeric(_) -> false. max_tuple_size(Reg, Ts) -> case tdb_find(Reg, Ts) of - {tuple,Sz,_} -> Sz; + {tuple,_,Sz,_} -> Sz; _Other -> 0 end. @@ -703,7 +765,15 @@ op_type('bxor') -> integer; op_type('bsl') -> integer; op_type('bsr') -> integer; op_type('div') -> integer; -op_type(_) -> unknown. +op_type(_) -> any. + +unary_op_type(bit_size) -> integer; +unary_op_type(byte_size) -> integer; +unary_op_type(length) -> integer; +unary_op_type(map_size) -> integer; +unary_op_type(size) -> integer; +unary_op_type(tuple_size) -> integer; +unary_op_type(_) -> any. flush(Rs, [{set,[_],[_,_,_],{bif,is_record,_}}|_]=Is0, Acc0) -> Acc = flush_all(Rs, Is0, Acc0), @@ -786,37 +856,39 @@ checkerror_1([], OrigIs) -> OrigIs. checkerror_2(OrigIs) -> [{set,[],[],fcheckerror}|OrigIs]. -%%% Routines for maintaining a type database. The type database +%%% Routines for maintaining a type database. The type database %%% associates type information with registers. %%% -%%% {tuple,Size,First} means that the corresponding register contains a -%%% tuple with *at least* Size elements. An tuple with unknown -%%% size is represented as {tuple,0,[]}. First is either [] (meaning that -%%% the tuple's first element is unknown) or [FirstElement] (the contents -%%% of the first element). -%%% -%%% 'float' means that the register contains a float. -%%% -%%% 'integer' or {integer,{Min,Max}} that the register contains an -%%% integer. +%%% See the comment for verified_type/1 at the end of module for +%%% a description of the possible types. %% tdb_new() -> EmptyDataBase %% Creates a new, empty type database. tdb_new() -> []. -%% tdb_find(Register, Db) -> Information|error +%% tdb_find(Register, Db) -> Type %% Returns type information or the atom error if there is no type %% information available for Register. +%% +%% See the comment for verified_type/1 at the end of module for +%% a description of the possible types. + +tdb_find(Reg, Ts) -> + case tdb_find_raw(Reg, Ts) of + {tuple_element,_,_} -> any; + Type -> Type + end. -tdb_find({x,_}=K, Ts) -> tdb_find_1(K, Ts); -tdb_find({y,_}=K, Ts) -> tdb_find_1(K, Ts); -tdb_find(_, _) -> error. +%% tdb_find_source_tuple(Register, Ts) -> {source_tuple,Register} | 'none'. +%% Find the tuple whose first element was fetched to the register Register. -tdb_find_1(K, Ts) -> - case orddict:find(K, Ts) of - {ok,Val} -> Val; - error -> error +tdb_find_source_tuple(Reg, Ts) -> + case tdb_find_raw(Reg, Ts) of + {tuple_element,Src,0} -> + {source_tuple,Src}; + _ -> + none end. %% tdb_copy(Source, Dest, Db) -> Db' @@ -824,9 +896,9 @@ tdb_find_1(K, Ts) -> %% as the Source. tdb_copy({Tag,_}=S, D, Ts) when Tag =:= x; Tag =:= y -> - case tdb_find(S, Ts) of - error -> orddict:erase(D, Ts); - Type -> orddict:store(D, Type, Ts) + case tdb_find_raw(S, Ts) of + any -> orddict:erase(D, Ts); + Type -> orddict:store(D, Type, Ts) end; tdb_copy(Literal, D, Ts) -> Type = case Literal of @@ -837,15 +909,90 @@ tdb_copy(Literal, D, Ts) -> {literal,#{}} -> map; {literal,Tuple} when tuple_size(Tuple) >= 1 -> Lit = tag_literal(element(1, Tuple)), - {tuple,tuple_size(Tuple),[Lit]}; - _ -> term + {tuple,exact_size,tuple_size(Tuple),[Lit]}; + _ -> any end, - if - Type =:= term -> - orddict:erase(D, Ts); - true -> - verify_type(Type), - orddict:store(D, Type, Ts) + tdb_store(D, verified_type(Type), Ts). + +%% tdb_store(Register, Type, Ts0) -> Ts. +%% Store a new type for register Register. Return the update type +%% database. Use this function when a new value is assigned to +%% a register. +%% +%% See the comment for verified_type/1 at the end of module for +%% a description of the possible types. + +tdb_store(Reg, any, Ts) -> + erase(Reg, Ts); +tdb_store(Reg, Type, Ts) -> + store(Reg, verified_type(Type), Ts). + +store(Key, New, [{K,_}|_]=Dict) when Key < K -> + [{Key,New}|Dict]; +store(Key, New, [{K,Val}=E|Dict]) when Key > K -> + case Val of + {tuple_element,Key,_} -> store(Key, New, Dict); + _ -> [E|store(Key, New, Dict)] + end; +store(Key, New, [{_K,Old}|Dict]) -> %Key == K + case Old of + {tuple,_,_,_} -> + [{Key,New}|erase_tuple_element(Key, Dict)]; + _ -> + [{Key,New}|Dict] + end; +store(Key, New, []) -> [{Key,New}]. + +erase(Key, [{K,_}=E|Dict]) when Key < K -> + [E|Dict]; +erase(Key, [{K,Val}=E|Dict]) when Key > K -> + case Val of + {tuple_element,Key,_} -> erase(Key, Dict); + _ -> [E|erase(Key, Dict)] + end; +erase(Key, [{_K,Val}|Dict]) -> %Key == K + case Val of + {tuple,_,_,_} -> erase_tuple_element(Key, Dict); + _ -> Dict + end; +erase(_, []) -> []. + +erase_tuple_element(Key, [{_,{tuple_element,Key,_}}|Dict]) -> + erase_tuple_element(Key, Dict); +erase_tuple_element(Key, [E|Dict]) -> + [E|erase_tuple_element(Key, Dict)]; +erase_tuple_element(_Key, []) -> []. + +%% tdb_meet(Register, Type, Ts0) -> Ts. +%% Update information of a register that is used as the source for an +%% instruction. The type Type will be combined using the meet operation +%% with the previous type information for the register, resulting in +%% narrower (more specific) type. +%% +%% For example, if the previous type is {tuple,min_size,2,[]} and the +%% the new type is {tuple,exact_size,5,[]}, the meet of the types will +%% be {tuple,exact_size,5,[]}. +%% +%% See the comment for verified_type/1 at the end of module for +%% a description of the possible types. + +tdb_meet(Reg, NewType, Ts) -> + Update = fun(Type0) -> meet(Type0, NewType) end, + orddict:update(Reg, Update, NewType, Ts). + +%%% +%%% Here follows internal helper functions for accessing and +%%% updating the type database. +%%% + +tdb_find_raw({x,_}=K, Ts) -> tdb_find_raw_1(K, Ts); +tdb_find_raw({y,_}=K, Ts) -> tdb_find_raw_1(K, Ts); +tdb_find_raw(_, _) -> any. + +tdb_find_raw_1(K, Ts) -> + case orddict:find(K, Ts) of + {ok,Val} -> Val; + error -> any end. tag_literal(A) when is_atom(A) -> {atom,A}; @@ -854,45 +1001,6 @@ tag_literal(I) when is_integer(I) -> {integer,I}; tag_literal([]) -> nil; tag_literal(Lit) -> {literal,Lit}. -%% tdb_update([UpdateOp], Db) -> NewDb -%% UpdateOp = {Register,kill}|{Register,NewInfo} -%% Updates a type database. If a 'kill' operation is given, the type -%% information for that register will be removed from the database. -%% A kill operation takes precedence over other operations for the same -%% register (i.e. [{{x,0},kill},{{x,0},{tuple,5,[]}}] means that the -%% the existing type information, if any, will be discarded, and the -%% the '{tuple,5,[]}' information ignored. -%% -%% If NewInfo information is given and there exists information about -%% the register, the old and new type information will be merged. -%% For instance, {tuple,5,_} and {tuple,10,_} will be merged to produce -%% {tuple,10,_}. - -tdb_update(Uis0, Ts0) -> - Uis1 = filter(fun ({{x,_},_Op}) -> true; - ({{y,_},_Op}) -> true; - (_) -> false - end, Uis0), - tdb_update1(lists:sort(Uis1), Ts0). - -tdb_update1([{Key,kill}|Ops], [{K,_Old}|_]=Db) when Key < K -> - tdb_update1(remove_key(Key, Ops), Db); -tdb_update1([{Key,Type}=New|Ops], [{K,_Old}|_]=Db) when Key < K -> - verify_type(Type), - [New|tdb_update1(Ops, Db)]; -tdb_update1([{Key,kill}|Ops], [{Key,_}|Db]) -> - tdb_update1(remove_key(Key, Ops), Db); -tdb_update1([{Key,NewInfo}|Ops], [{Key,OldInfo}|Db]) -> - [{Key,merge_type_info(NewInfo, OldInfo)}|tdb_update1(Ops, Db)]; -tdb_update1([{_,_}|_]=Ops, [Old|Db]) -> - [Old|tdb_update1(Ops, Db)]; -tdb_update1([{Key,kill}|Ops], []) -> - tdb_update1(remove_key(Key, Ops), []); -tdb_update1([{_,Type}=New|Ops], []) -> - verify_type(Type), - [New|tdb_update1(Ops, [])]; -tdb_update1([], Db) -> Db. - %% tdb_kill_xregs(Db) -> NewDb %% Kill all information about x registers. Also kill all tuple_element %% dependencies from y registers to x registers. @@ -901,37 +1009,106 @@ tdb_kill_xregs([{{x,_},_Type}|Db]) -> tdb_kill_xregs(Db); tdb_kill_xregs([{{y,_},{tuple_element,{x,_},_}}|Db]) -> tdb_kill_xregs(Db); tdb_kill_xregs([Any|Db]) -> [Any|tdb_kill_xregs(Db)]; tdb_kill_xregs([]) -> []. - -remove_key(Key, [{Key,_Op}|Ops]) -> remove_key(Key, Ops); -remove_key(_, Ops) -> Ops. - -merge_type_info(I, I) -> I; -merge_type_info({tuple,Sz1,Same}, {tuple,Sz2,Same}=Max) when Sz1 < Sz2 -> + +%% meet(Type1, Type2) -> Type +%% Returns the "meet" of Type1 and Type2. The meet is a narrower +%% type than Type1 and Type2. For example: +%% +%% meet(integer, {integer,{0,3}}) -> {integer,{0,3}} +%% +%% The meet for two different types result in 'none', which is +%% the bottom element for our type lattice: +%% +%% meet(integer, map) -> none + +meet(T, T) -> + T; +meet({integer,_}=T, integer) -> + T; +meet(integer, {integer,_}=T) -> + T; +meet({integer,{Min1,Max1}}, {integer,{Min2,Max2}}) -> + {integer,{max(Min1, Min2),min(Max1, Max2)}}; +meet({tuple,min_size,Sz1,Same}, {tuple,min_size,Sz2,Same}=Max) when Sz1 < Sz2 -> Max; -merge_type_info({tuple,Sz1,Same}=Max, {tuple,Sz2,Same}) when Sz1 > Sz2 -> +meet({tuple,min_size,Sz1,Same}=Max, {tuple,min_size,Sz2,Same}) when Sz1 > Sz2 -> Max; -merge_type_info({tuple,Sz1,[]}, {tuple,_Sz2,First}=Tuple2) -> - merge_type_info({tuple,Sz1,First}, Tuple2); -merge_type_info({tuple,_Sz1,First}=Tuple1, {tuple,Sz2,_}) -> - merge_type_info(Tuple1, {tuple,Sz2,First}); -merge_type_info(integer, {integer,_}) -> - integer; -merge_type_info({integer,_}, integer) -> - integer; -merge_type_info({integer,{Min1,Max1}}, {integer,{Min2,Max2}}) -> - {integer,{max(Min1, Min2),min(Max1, Max2)}}; -merge_type_info(NewType, _) -> - verify_type(NewType), - NewType. - -verify_type({atom,_}) -> ok; -verify_type(boolean) -> ok; -verify_type(integer) -> ok; -verify_type({integer,{Min,Max}}) - when is_integer(Min), is_integer(Max) -> ok; -verify_type(map) -> ok; -verify_type(nonempty_list) -> ok; -verify_type({tuple,Sz,[]}) when is_integer(Sz) -> ok; -verify_type({tuple,Sz,[_]}) when is_integer(Sz) -> ok; -verify_type({tuple_element,_,_}) -> ok; -verify_type(float) -> ok. +meet({tuple,exact_size,_,Same}=Exact, {tuple,_,_,Same}) -> + Exact; +meet({tuple,_,_,Same},{tuple,exact_size,_,Same}=Exact) -> + Exact; +meet({tuple,SzKind1,Sz1,[]}, {tuple,_SzKind2,_Sz2,First}=Tuple2) -> + meet({tuple,SzKind1,Sz1,First}, Tuple2); +meet({tuple,_SzKind1,_Sz1,First}=Tuple1, {tuple,SzKind2,Sz2,_}) -> + meet(Tuple1, {tuple,SzKind2,Sz2,First}); +meet({binary,U1}, {binary,U2}) -> + {binary,max(U1, U2)}; +meet(T1, T2) -> + case is_any(T1) of + true -> + verified_type(T2); + false -> + case is_any(T2) of + true -> + verified_type(T1); + false -> + none %The bottom element. + end + end. + +is_any(any) -> true; +is_any({tuple_element,_,_}) -> true; +is_any(_) -> false. + +%% verified_type(Type) -> Type +%% Returns the passed in type if it is one of the defined types. +%% Crashes if there is anything wrong with the type. +%% +%% Here are all possible types: +%% +%% any Any Erlang term (top element for the type lattice). +%% +%% {atom,Atom} The specific atom Atom. +%% {binary,Unit} Binary/bitstring aligned to unit Unit. +%% boolean 'true' | 'false' +%% float Floating point number. +%% integer Integer. +%% {integer,{Min,Max}} Integer in the inclusive range Min through Max. +%% map Map. +%% nonempty_list Nonempty list. +%% {tuple,_,_,_} Tuple (see below). +%% +%% none No type (bottom element for the type lattice). +%% +%% {tuple,min_size,Size,First} means that the corresponding register +%% contains a tuple with *at least* Size elements (conversely, +%% {tuple,exact_size,Size,First} means that it contains a tuple with +%% *exactly* Size elements). An tuple with unknown size is +%% represented as {tuple,min_size,0,[]}. First is either [] (meaning +%% that the tuple's first element is unknown) or [FirstElement] (the +%% contents of the first element). +%% +%% There is also a pseudo-type called {tuple_element,_,_}: +%% +%% {tuple_element,SrcTuple,ElementNumber} +%% +%% that does not provide any information about the type of the +%% register itself, but provides a link back to the source tuple that +%% the register got its value from. +%% +%% Note that {tuple_element,_,_} will *never* be returned by tdb_find/2. +%% Use tdb_find_source_tuple/2 to locate the source tuple for a register. + +verified_type(any=T) -> T; +verified_type({atom,_}=T) -> T; +verified_type({binary,U}=T) when is_integer(U) -> T; +verified_type(boolean=T) -> T; +verified_type(integer=T) -> T; +verified_type({integer,{Min,Max}}=T) + when is_integer(Min), is_integer(Max) -> T; +verified_type(map=T) -> T; +verified_type(nonempty_list=T) -> T; +verified_type({tuple,_,Sz,[]}=T) when is_integer(Sz) -> T; +verified_type({tuple,_,Sz,[_]}=T) when is_integer(Sz) -> T; +verified_type({tuple_element,_,_}=T) -> T; +verified_type(float=T) -> T. diff --git a/lib/compiler/src/beam_utils.erl b/lib/compiler/src/beam_utils.erl index e39fbdc3b7..1ddad30328 100644 --- a/lib/compiler/src/beam_utils.erl +++ b/lib/compiler/src/beam_utils.erl @@ -22,15 +22,23 @@ -module(beam_utils). -export([is_killed_block/2,is_killed/3,is_killed_at/3, - is_not_used/3, - empty_label_index/0,index_label/3,index_labels/1, + is_not_used/3,usage/3, + empty_label_index/0,index_label/3,index_labels/1,replace_labels/4, code_at/2,bif_to_test/3,is_pure_test/1, - live_opt/1,delete_live_annos/1,combine_heap_needs/2, - split_even/1]). + live_opt/1,delete_annos/1,combine_heap_needs/2, + anno_defs/1, + split_even/1 + ]). -export_type([code_index/0,module_code/0,instruction/0]). --import(lists, [member/2,sort/1,reverse/1,splitwith/2]). +-import(lists, [flatmap/2,map/2,member/2,sort/1,reverse/1,splitwith/2]). + +-define(is_const(Val), (Val =:= nil orelse + element(1, Val) =:= integer orelse + element(1, Val) =:= float orelse + element(1, Val) =:= atom orelse + element(1, Val) =:= literal)). %% instruction() describes all instructions that are used during optimzation %% (from beam_a to beam_z). @@ -54,6 +62,23 @@ {lbl :: code_index(), %Label to code index. res :: result_cache()}). %Result cache for each label. +%% usage(Register, [Instruction], State) -> killed|not_used|used. +%% Determine the usage of Register in the instruction sequence. +%% The return value is one of: +%% +%% killed - The register is not used in any way. +%% not_used - The register is referenced only by an allocating instruction +%% (the actual value does not matter). +%% used - The register is used (its value do matter). + +-spec usage(beam_asm:reg(), [instruction()], code_index()) -> + 'killed' | 'not_used' | 'used'. + +usage(R, Is, D) -> + St = #live{lbl=D,res=gb_trees:empty()}, + {Usage,_} = check_liveness(R, Is, St), + Usage. + %% is_killed_block(Register, [Instruction]) -> true|false %% Determine whether a register is killed by the instruction sequence inside @@ -70,7 +95,7 @@ is_killed_block({x,X}, [{set,_,_,{alloc,Live,_}}|_]) -> X >= Live; is_killed_block(R, [{set,Ds,Ss,_Op}|Is]) -> not member(R, Ss) andalso (member(R, Ds) orelse is_killed_block(R, Is)); -is_killed_block(R, [{'%live',_,Regs}|Is]) -> +is_killed_block(R, [{'%anno',{used,Regs}}|Is]) -> case R of {x,X} when (Regs bsr X) band 1 =:= 0 -> true; _ -> is_killed_block(R, Is) @@ -93,6 +118,7 @@ is_killed(R, Is, D) -> St = #live{lbl=D,res=gb_trees:empty()}, case check_liveness(R, Is, St) of {killed,_} -> true; + {exit_not_used,_} -> false; {_,_} -> false end. @@ -105,6 +131,7 @@ is_killed_at(R, Lbl, D) when is_integer(Lbl) -> St0 = #live{lbl=D,res=gb_trees:empty()}, case check_liveness_at(R, Lbl, St0) of {killed,_} -> true; + {exit_not_used,_} -> false; {_,_} -> false end. @@ -121,6 +148,7 @@ is_not_used(R, Is, D) -> St = #live{lbl=D,res=gb_trees:empty()}, case check_liveness(R, Is, St) of {used,_} -> false; + {exit_not_used,_} -> true; {_,_} -> true end. @@ -160,6 +188,18 @@ index_label(Lbl, Is0, Acc) -> code_at(L, Ll) -> gb_trees:get(L, Ll). +%% replace_labels(FunctionIs, Tail, ReplaceDb, Fallback) -> FunctionIs. +%% Replace all labels in instructions according to the ReplaceDb. +%% If label is not found the Fallback is called with the label to +%% produce a new one. + +-spec replace_labels([instruction()], + [instruction()], + #{beam_asm:label() => beam_asm:label()}, + fun((beam_asm:label()) -> term())) -> [instruction()]. +replace_labels(Is, Acc, D, Fb) -> + replace_labels_1(Is, Acc, D, Fb). + %% bif_to_test(Bif, [Op], Fail) -> {test,Test,Fail,[Op]} %% Convert a BIF to a test. Fail if not possible. @@ -185,10 +225,20 @@ bif_to_test('>', [A,B], Fail) -> {test,is_lt,Fail,[B,A]}; bif_to_test('<', [_,_]=Ops, Fail) -> {test,is_lt,Fail,Ops}; bif_to_test('>=', [_,_]=Ops, Fail) -> {test,is_ge,Fail,Ops}; bif_to_test('==', [A,nil], Fail) -> {test,is_nil,Fail,[A]}; +bif_to_test('==', [nil,A], Fail) -> {test,is_nil,Fail,[A]}; +bif_to_test('==', [C,A], Fail) when ?is_const(C) -> + {test,is_eq,Fail,[A,C]}; bif_to_test('==', [_,_]=Ops, Fail) -> {test,is_eq,Fail,Ops}; +bif_to_test('/=', [C,A], Fail) when ?is_const(C) -> + {test,is_ne,Fail,[A,C]}; bif_to_test('/=', [_,_]=Ops, Fail) -> {test,is_ne,Fail,Ops}; bif_to_test('=:=', [A,nil], Fail) -> {test,is_nil,Fail,[A]}; +bif_to_test('=:=', [nil,A], Fail) -> {test,is_nil,Fail,[A]}; +bif_to_test('=:=', [C,A], Fail) when ?is_const(C) -> + {test,is_eq_exact,Fail,[A,C]}; bif_to_test('=:=', [_,_]=Ops, Fail) -> {test,is_eq_exact,Fail,Ops}; +bif_to_test('=/=', [C,A], Fail) when ?is_const(C) -> + {test,is_ne_exact,Fail,[A,C]}; bif_to_test('=/=', [_,_]=Ops, Fail) -> {test,is_ne_exact,Fail,Ops}; bif_to_test(is_record, [_,_,_]=Ops, Fail) -> {test,is_record,Fail,Ops}. @@ -220,7 +270,7 @@ is_pure_test({test,Op,_,Ops}) -> %% Go through the instruction sequence in reverse execution %% order, keep track of liveness and remove 'move' instructions %% whose destination is a register that will not be used. -%% Also insert {'%live',Live,Regs} annotations at the beginning +%% Also insert {used,Regs} annotations at the beginning %% and end of each block. -spec live_opt([instruction()]) -> [instruction()]. @@ -235,35 +285,52 @@ live_opt(Is0) -> Bef ++ [Fi|live_opt(reverse(Is), 0, D, [])]. -%% delete_live_annos([Instruction]) -> [Instruction]. -%% Delete all live annotations. +%% delete_annos([Instruction]) -> [Instruction]. +%% Delete all annotations. --spec delete_live_annos([instruction()]) -> [instruction()]. +-spec delete_annos([instruction()]) -> [instruction()]. -delete_live_annos([{block,Bl0}|Is]) -> - case delete_live_annos(Bl0) of - [] -> delete_live_annos(Is); - [_|_]=Bl -> [{block,Bl}|delete_live_annos(Is)] +delete_annos([{block,Bl0}|Is]) -> + case delete_annos(Bl0) of + [] -> delete_annos(Is); + [_|_]=Bl -> [{block,Bl}|delete_annos(Is)] end; -delete_live_annos([{'%live',_,_}|Is]) -> - delete_live_annos(Is); -delete_live_annos([I|Is]) -> - [I|delete_live_annos(Is)]; -delete_live_annos([]) -> []. - +delete_annos([{'%anno',_}|Is]) -> + delete_annos(Is); +delete_annos([I|Is]) -> + [I|delete_annos(Is)]; +delete_annos([]) -> []. + %% combine_heap_needs(HeapNeed1, HeapNeed2) -> HeapNeed %% Combine the heap need for two allocation instructions. --spec combine_heap_needs(term(), term()) -> term(). +-type heap_need_tag() :: 'floats' | 'words'. +-type heap_need() :: non_neg_integer() | + {'alloc',[{heap_need_tag(),non_neg_integer()}]}. +-spec combine_heap_needs(heap_need(), heap_need()) -> heap_need(). -combine_heap_needs({alloc,Alloc1}, {alloc,Alloc2}) -> - {alloc,combine_alloc_lists(Alloc1, Alloc2)}; -combine_heap_needs({alloc,Alloc}, Words) when is_integer(Words) -> - {alloc,combine_alloc_lists(Alloc, [{words,Words}])}; -combine_heap_needs(Words, {alloc,Alloc}) when is_integer(Words) -> - {alloc,combine_alloc_lists(Alloc, [{words,Words}])}; combine_heap_needs(H1, H2) when is_integer(H1), is_integer(H2) -> - H1+H2. + H1 + H2; +combine_heap_needs(H1, H2) -> + {alloc,combine_alloc_lists([H1,H2])}. + + +%% anno_defs(Instructions) -> Instructions' +%% Add {def,RegisterBitmap} annotations to the beginning of +%% each block. Iff bit X is set in the the bitmap, it means +%% that {x,X} is defined when the block is entered. + +-spec anno_defs([instruction()]) -> [instruction()]. + +anno_defs(Is0) -> + {Bef,[Fi|Is1]} = + splitwith(fun({func_info,_,_,_}) -> false; + (_) -> true + end, Is0), + {func_info,_,_,Arity} = Fi, + Regs = init_def_regs(Arity), + Is = defs(Is1, Regs, #{}), + Bef ++ [Fi|Is]. %% split_even/1 %% [1,2,3,4,5,6] -> {[1,3,5],[2,4,6]} @@ -272,7 +339,6 @@ combine_heap_needs(H1, H2) when is_integer(H1), is_integer(H2) -> split_even(Rs) -> split_even(Rs, [], []). - %%% %%% Local functions. %%% @@ -284,12 +350,19 @@ split_even(Rs) -> split_even(Rs, [], []). %% %% killed - Reg is assigned or killed by an allocation instruction. %% not_used - the value of Reg is not used, but Reg must not be garbage +%% exit_not_used - the value of Reg is not used, but must not be garbage +%% because the stack will be scanned because an +%% exit BIF will raise an exception %% used - Reg is used check_liveness(R, [{block,Blk}|Is], St0) -> case check_liveness_block(R, Blk, St0) of {transparent,St1} -> check_liveness(R, Is, St1); + {alloc_used,St1} -> + %% Used by an allocating instruction, but value not referenced. + %% Must check the rest of the instructions. + not_used(check_liveness(R, Is, St1)); {Other,_}=Res when is_atom(Other) -> Res end; @@ -303,6 +376,8 @@ check_liveness(R, [{test,_,{f,Fail},As}|Is], St0) -> case check_liveness_at(R, Fail, St0) of {killed,St1} -> check_liveness(R, Is, St1); + {exit_not_used,St1} -> + check_liveness(R, Is, St1); {not_used,St1} -> not_used(check_liveness(R, Is, St1)); {used,_}=Used -> @@ -322,6 +397,8 @@ check_liveness(R, [{jump,{f,F}}|_], St) -> check_liveness_at(R, F, St); check_liveness(R, [{case_end,Used}|_], St) -> check_liveness_ret(R, Used, St); +check_liveness(R, [{try_case_end,Used}|_], St) -> + check_liveness_ret(R, Used, St); check_liveness(R, [{badmatch,Used}|_], St) -> check_liveness_ret(R, Used, St); check_liveness(_, [if_end|_], St) -> @@ -348,17 +425,27 @@ check_liveness(R, [{bs_init,_,_,none,Ss,Dst}|Is], St) -> check_liveness(R, [{bs_init,_,_,Live,Ss,Dst}|Is], St) -> case R of {x,X} -> - case X < Live orelse member(R, Ss) of - true -> {used,St}; - false -> {killed,St} + case member(R, Ss) of + true -> + {used,St}; + false -> + if + X < Live -> + not_used(check_liveness(R, Is, St)); + true -> + {killed,St} + end end; {y,_} -> case member(R, Ss) of true -> {used,St}; false -> + %% If the exception is taken, the stack may + %% be scanned. Therefore the register is not + %% guaranteed to be killed. if - R =:= Dst -> {killed,St}; - true -> check_liveness(R, Is, St) + R =:= Dst -> {not_used,St}; + true -> not_used(check_liveness(R, Is, St)) end end end; @@ -392,7 +479,7 @@ check_liveness(R, [{call_ext,Live,_}=I|Is], St) -> %% We must make sure we don't check beyond this %% instruction or we will fall through into random %% unrelated code and get stuck in a loop. - {killed,St} + {exit_not_used,St} end end; check_liveness(R, [{call_fun,Live}|Is], St) -> @@ -440,16 +527,12 @@ check_liveness(R, [{make_fun2,_,_,_,NumFree}|Is], St) -> {x,_} -> {killed,St}; {y,_} -> not_used(check_liveness(R, Is, St)) end; -check_liveness({x,_}=R, [{'catch',_,_}|Is], St) -> - %% All x registers will be killed if an exception occurs. - %% Therefore we only need to check the liveness for the - %% instructions following the catch instruction. - check_liveness(R, Is, St); -check_liveness({x,_}=R, [{'try',_,_}|Is], St) -> - %% All x registers will be killed if an exception occurs. - %% Therefore we only need to check the liveness for the - %% instructions inside the 'try' block. - check_liveness(R, Is, St); +check_liveness(R, [{'catch'=Op,Y,Fail}|Is], St) -> + Set = {set,[Y],[],{try_catch,Op,Fail}}, + check_liveness(R, [{block,[Set]}|Is], St); +check_liveness(R, [{'try'=Op,Y,Fail}|Is], St) -> + Set = {set,[Y],[],{try_catch,Op,Fail}}, + check_liveness(R, [{block,[Set]}|Is], St); check_liveness(R, [{try_end,Y}|Is], St) -> case R of Y -> @@ -510,15 +593,34 @@ check_liveness(R, [{get_map_elements,{f,Fail},S,{list,L}}|Is], St0) -> check_liveness(R, [{put_map,F,Op,S,D,Live,{list,Puts}}|Is], St) -> Set = {set,[D],[S|Puts],{alloc,Live,{put_map,Op,F}}}, check_liveness(R, [{block,[Set]}||Is], St); +check_liveness(R, [{put_tuple,Ar,D}|Is], St) -> + Set = {set,[D],[],{put_tuple,Ar}}, + check_liveness(R, [{block,[Set]}||Is], St); +check_liveness(R, [{put_list,S1,S2,D}|Is], St) -> + Set = {set,[D],[S1,S2],put_list}, + check_liveness(R, [{block,[Set]}||Is], St); check_liveness(R, [{test_heap,N,Live}|Is], St) -> I = {block,[{set,[],[],{alloc,Live,{nozero,nostack,N,[]}}}]}, check_liveness(R, [I|Is], St); check_liveness(R, [{allocate_zero,N,Live}|Is], St) -> I = {block,[{set,[],[],{alloc,Live,{zero,N,0,[]}}}]}, check_liveness(R, [I|Is], St); -check_liveness(R, [{get_list,S,D1,D2}|Is], St) -> - I = {block,[{set,[D1,D2],[S],get_list}]}, +check_liveness(R, [{get_hd,S,D}|Is], St) -> + I = {block,[{set,[D],[S],get_hd}]}, check_liveness(R, [I|Is], St); +check_liveness(R, [{get_tl,S,D}|Is], St) -> + I = {block,[{set,[D],[S],get_tl}]}, + check_liveness(R, [I|Is], St); +check_liveness(R, [remove_message|Is], St) -> + check_liveness(R, Is, St); +check_liveness({x,X}, [build_stacktrace|_], St) when X > 0 -> + {killed,St}; +check_liveness(R, [{recv_mark,_}|Is], St) -> + check_liveness(R, Is, St); +check_liveness(R, [{recv_set,_}|Is], St) -> + check_liveness(R, Is, St); +check_liveness(R, [{'%',_}|Is], St) -> + check_liveness(R, Is, St); check_liveness(_R, Is, St) when is_list(Is) -> %% Not implemented. Conservatively assume that the register is used. {used,St}. @@ -553,14 +655,14 @@ check_liveness_at(R, Lbl, #live{lbl=Ll,res=ResMemorized}=St0) -> {Res,St#live{res=gb_trees:insert(Lbl, Res, St#live.res)}} end. -not_used({killed,St}) -> {not_used,St}; -not_used({_,_}=Res) -> Res. +not_used({used,_}=Res) -> Res; +not_used({_,St}) -> {not_used,St}. check_liveness_ret(R, R, St) -> {used,St}; check_liveness_ret(_, _, St) -> {killed,St}. %% check_liveness_block(Reg, [Instruction], State) -> -%% {killed | not_used | used | transparent,State'} +%% {killed | not_used | used | alloc_used | transparent,State'} %% Finds out how Reg is used in the instruction sequence inside a block. %% Returns one of: %% killed - Reg is assigned a new value or killed by an @@ -568,9 +670,10 @@ check_liveness_ret(_, _, St) -> {killed,St}. %% not_used - The value is not used, but the register is referenced %% e.g. by an allocation instruction %% transparent - Reg is neither used nor killed +%% alloc_used - Used only in an allocate instruction %% used - Reg is explicitly used by an instruction %% -%% '%live' annotations are not allowed. +%% Annotations are not allowed. %% %% (Unknown instructions will cause an exception.) @@ -580,13 +683,30 @@ check_liveness_block({x,X}=R, [{set,Ds,Ss,{alloc,Live,Op}}|Is], St0) -> {killed,St0}; true -> case check_liveness_block_1(R, Ss, Ds, Op, Is, St0) of - {killed,St} -> {not_used,St}; - {transparent,St} -> {not_used,St}; - {_,_}=Res -> Res + {transparent,St} -> {alloc_used,St}; + {_,_}=Res -> not_used(Res) end end; -check_liveness_block({y,_}=R, [{set,Ds,Ss,{alloc,_Live,Op}}|Is], St) -> - check_liveness_block_1(R, Ss, Ds, Op, Is, St); +check_liveness_block({y,_}=R, [{set,Ds,Ss,{alloc,_Live,Op}}|Is], St0) -> + case check_liveness_block_1(R, Ss, Ds, Op, Is, St0) of + {transparent,St} -> {alloc_used,St}; + {_,_}=Res -> not_used(Res) + end; +check_liveness_block({y,_}=R, [{set,Ds,Ss,{try_catch,_,Op}}|Is], St0) -> + case Ds of + [R] -> + {killed,St0}; + _ -> + case check_liveness_block_1(R, Ss, Ds, Op, Is, St0) of + {exit_not_used,St} -> + {used,St}; + {transparent,St} -> + %% Conservatively assumed that it is used. + {used,St}; + {_,_}=Res -> + Res + end + end; check_liveness_block(R, [{set,Ds,Ss,Op}|Is], St) -> check_liveness_block_1(R, Ss, Ds, Op, Is, St); check_liveness_block(_, [], St) -> {transparent,St}. @@ -602,6 +722,11 @@ check_liveness_block_1(R, Ss, Ds, Op, Is, St0) -> true -> {killed,St}; false -> check_liveness_block(R, Is, St) end; + {exit_not_used,St} -> + case member(R, Ds) of + true -> {exit_not_used,St}; + false -> check_liveness_block(R, Is, St) + end; {not_used,St} -> not_used(case member(R, Ds) of true -> {killed,St}; @@ -612,8 +737,8 @@ check_liveness_block_1(R, Ss, Ds, Op, Is, St0) -> end end. -check_liveness_block_2(R, {gc_bif,_Op,{f,Lbl}}, _Ss, St) -> - check_liveness_block_3(R, Lbl, St); +check_liveness_block_2(R, {gc_bif,Op,{f,Lbl}}, Ss, St) -> + check_liveness_block_3(R, Lbl, {Op,length(Ss)}, St); check_liveness_block_2(R, {bif,Op,{f,Lbl}}, Ss, St) -> Arity = length(Ss), case erl_internal:comp_op(Op, Arity) orelse @@ -621,16 +746,23 @@ check_liveness_block_2(R, {bif,Op,{f,Lbl}}, Ss, St) -> true -> {killed,St}; false -> - check_liveness_block_3(R, Lbl, St) + check_liveness_block_3(R, Lbl, {Op,length(Ss)}, St) end; check_liveness_block_2(R, {put_map,_Op,{f,Lbl}}, _Ss, St) -> - check_liveness_block_3(R, Lbl, St); + check_liveness_block_3(R, Lbl, {unsafe,0}, St); check_liveness_block_2(_, _, _, St) -> {killed,St}. -check_liveness_block_3(_, 0, St) -> +check_liveness_block_3({x,_}, 0, _FA, St) -> {killed,St}; -check_liveness_block_3(R, Lbl, St0) -> +check_liveness_block_3({y,_}, 0, {F,A}, St) -> + %% If the exception is thrown, the stack may be scanned, + %% thus implicitly using the y register. + case erl_bifs:is_safe(erlang, F, A) of + true -> {killed,St}; + false -> {used,St} + end; +check_liveness_block_3(R, Lbl, _FA, St0) -> check_liveness_at(R, Lbl, St0). index_labels_1([{label,Lbl}|Is0], Acc) -> @@ -643,22 +775,74 @@ index_labels_1([], Acc) -> gb_trees:from_orddict(sort(Acc)). drop_labels([{label,_}|Is]) -> drop_labels(Is); drop_labels(Is) -> Is. -%% Help functions for combine_heap_needs. -combine_alloc_lists(Al1, Al2) -> - combine_alloc_lists_1(sort(Al1++Al2)). +replace_labels_1([{test,Test,{f,Lbl},Ops}|Is], Acc, D, Fb) -> + replace_labels_1(Is, [{test,Test,{f,label(Lbl, D, Fb)},Ops}|Acc], D, Fb); +replace_labels_1([{test,Test,{f,Lbl},Live,Ops,Dst}|Is], Acc, D, Fb) -> + replace_labels_1(Is, [{test,Test,{f,label(Lbl, D, Fb)},Live,Ops,Dst}|Acc], D, Fb); +replace_labels_1([{select,I,R,{f,Fail0},Vls0}|Is], Acc, D, Fb) -> + Vls = map(fun ({f,L}) -> {f,label(L, D, Fb)}; + (Other) -> Other + end, Vls0), + Fail = label(Fail0, D, Fb), + replace_labels_1(Is, [{select,I,R,{f,Fail},Vls}|Acc], D, Fb); +replace_labels_1([{'try',R,{f,Lbl}}|Is], Acc, D, Fb) -> + replace_labels_1(Is, [{'try',R,{f,label(Lbl, D, Fb)}}|Acc], D, Fb); +replace_labels_1([{'catch',R,{f,Lbl}}|Is], Acc, D, Fb) -> + replace_labels_1(Is, [{'catch',R,{f,label(Lbl, D, Fb)}}|Acc], D, Fb); +replace_labels_1([{jump,{f,Lbl}}|Is], Acc, D, Fb) -> + replace_labels_1(Is, [{jump,{f,label(Lbl, D, Fb)}}|Acc], D, Fb); +replace_labels_1([{loop_rec,{f,Lbl},R}|Is], Acc, D, Fb) -> + replace_labels_1(Is, [{loop_rec,{f,label(Lbl, D, Fb)},R}|Acc], D, Fb); +replace_labels_1([{loop_rec_end,{f,Lbl}}|Is], Acc, D, Fb) -> + replace_labels_1(Is, [{loop_rec_end,{f,label(Lbl, D, Fb)}}|Acc], D, Fb); +replace_labels_1([{wait,{f,Lbl}}|Is], Acc, D, Fb) -> + replace_labels_1(Is, [{wait,{f,label(Lbl, D, Fb)}}|Acc], D, Fb); +replace_labels_1([{wait_timeout,{f,Lbl},To}|Is], Acc, D, Fb) -> + replace_labels_1(Is, [{wait_timeout,{f,label(Lbl, D, Fb)},To}|Acc], D, Fb); +replace_labels_1([{recv_mark=Op,{f,Lbl}}|Is], Acc, D, Fb) -> + replace_labels_1(Is, [{Op,{f,label(Lbl, D, Fb)}}|Acc], D, Fb); +replace_labels_1([{recv_set=Op,{f,Lbl}}|Is], Acc, D, Fb) -> + replace_labels_1(Is, [{Op,{f,label(Lbl, D, Fb)}}|Acc], D, Fb); +replace_labels_1([{bif,Name,{f,Lbl},As,R}|Is], Acc, D, Fb) when Lbl =/= 0 -> + replace_labels_1(Is, [{bif,Name,{f,label(Lbl, D, Fb)},As,R}|Acc], D, Fb); +replace_labels_1([{gc_bif,Name,{f,Lbl},Live,As,R}|Is], Acc, D, Fb) when Lbl =/= 0 -> + replace_labels_1(Is, [{gc_bif,Name,{f,label(Lbl, D, Fb)},Live,As,R}|Acc], D, Fb); +replace_labels_1([{call,Ar,{f,Lbl}}|Is], Acc, D, Fb) -> + replace_labels_1(Is, [{call,Ar,{f,label(Lbl, D, Fb)}}|Acc], D, Fb); +replace_labels_1([{make_fun2,{f,Lbl},U1,U2,U3}|Is], Acc, D, Fb) -> + replace_labels_1(Is, [{make_fun2,{f,label(Lbl, D, Fb)},U1,U2,U3}|Acc], D, Fb); +replace_labels_1([{bs_init,{f,Lbl},Info,Live,Ss,Dst}|Is], Acc, D, Fb) when Lbl =/= 0 -> + replace_labels_1(Is, [{bs_init,{f,label(Lbl, D, Fb)},Info,Live,Ss,Dst}|Acc], D, Fb); +replace_labels_1([{bs_put,{f,Lbl},Info,Ss}|Is], Acc, D, Fb) when Lbl =/= 0 -> + replace_labels_1(Is, [{bs_put,{f,label(Lbl, D, Fb)},Info,Ss}|Acc], D, Fb); +replace_labels_1([{put_map=I,{f,Lbl},Op,Src,Dst,Live,List}|Is], Acc, D, Fb) + when Lbl =/= 0 -> + replace_labels_1(Is, [{I,{f,label(Lbl, D, Fb)},Op,Src,Dst,Live,List}|Acc], D, Fb); +replace_labels_1([{get_map_elements=I,{f,Lbl},Src,List}|Is], Acc, D, Fb) when Lbl =/= 0 -> + replace_labels_1(Is, [{I,{f,label(Lbl, D, Fb)},Src,List}|Acc], D, Fb); +replace_labels_1([I|Is], Acc, D, Fb) -> + replace_labels_1(Is, [I|Acc], D, Fb); +replace_labels_1([], Acc, _, _) -> Acc. + +label(Old, D, Fb) -> + case D of + #{Old := New} -> New; + _ -> Fb(Old) + end. -combine_alloc_lists_1([{words,W1},{words,W2}|T]) - when is_integer(W1), is_integer(W2) -> - [{words,W1+W2}|combine_alloc_lists_1(T)]; -combine_alloc_lists_1([{floats,F1},{floats,F2}|T]) - when is_integer(F1), is_integer(F2) -> - [{floats,F1+F2}|combine_alloc_lists_1(T)]; -combine_alloc_lists_1([{words,_}=W|T]) -> - [W|combine_alloc_lists_1(T)]; -combine_alloc_lists_1([{floats,_}=F|T]) -> - [F|combine_alloc_lists_1(T)]; -combine_alloc_lists_1([]) -> []. +%% Help function for combine_heap_needs. + +combine_alloc_lists(Al0) -> + Al1 = flatmap(fun(Words) when is_integer(Words) -> + [{words,Words}]; + ({alloc,List}) -> + List + end, Al0), + Al2 = sofs:relation(Al1), + Al3 = sofs:relation_to_family(Al2), + Al4 = sofs:to_external(Al3), + [{Tag,lists:sum(L)} || {Tag,L} <- Al4]. %% live_opt/4. @@ -697,10 +881,14 @@ live_opt([{test,bs_start_match2,Fail,Live,[Src,_],_}=I|Is], _, D, Acc) -> %% Other instructions. live_opt([{block,Bl0}|Is], Regs0, D, Acc) -> - Live0 = {'%live',live_regs(Regs0),Regs0}, + Live0 = make_anno({used,Regs0}), {Bl,Regs} = live_opt_block(reverse(Bl0), Regs0, D, [Live0]), - Live = {'%live',live_regs(Regs),Regs}, + Live = make_anno({used,Regs}), live_opt(Is, Regs, D, [{block,[Live|Bl]}|Acc]); +live_opt([build_stacktrace=I|Is], _, D, Acc) -> + live_opt(Is, live_call(1), D, [I|Acc]); +live_opt([raw_raise=I|Is], _, D, Acc) -> + live_opt(Is, live_call(3), D, [I|Acc]); live_opt([{label,L}=I|Is], Regs, D0, Acc) -> D = gb_trees:insert(L, Regs, D0), live_opt(Is, Regs, D, [I|Acc]); @@ -742,12 +930,19 @@ live_opt([{test,_,Fail,Live,Ss,_}=I|Is], _, D, Acc) -> Regs1 = x_live(Ss, Regs0), Regs = live_join_label(Fail, D, Regs1), live_opt(Is, Regs, D, [I|Acc]); -live_opt([{select,_,Src,Fail,List}=I|Is], Regs0, D, Acc) -> +live_opt([{select,_,Src,Fail,List}=I|Is], _, D, Acc) -> + Regs0 = 0, Regs1 = x_live([Src], Regs0), Regs = live_join_labels([Fail|List], D, Regs1), live_opt(Is, Regs, D, [I|Acc]); -live_opt([{try_case,_}=I|Is], _, D, Acc) -> - live_opt(Is, live_call(1), D, [I|Acc]); +live_opt([{try_case,Y}=I|Is], Regs0, D, Acc) -> + Regs = live_call(1), + case Regs0 of + 0 -> + live_opt(Is, Regs, D, [{try_end,Y}|Acc]); + _ -> + live_opt(Is, live_call(1), D, [I|Acc]) + end; live_opt([{loop_rec,_Fail,_Dst}=I|Is], _, D, Acc) -> live_opt(Is, 0, D, [I|Acc]); live_opt([timeout=I|Is], _, D, Acc) -> @@ -759,6 +954,25 @@ live_opt([{get_map_elements,Fail,Src,{list,List}}=I|Is], Regs0, D, Acc) -> Regs1 = x_live([Src|Ss], x_dead(Ds, Regs0)), Regs = live_join_label(Fail, D, Regs1), live_opt(Is, Regs, D, [I|Acc]); +live_opt([{gc_bif,N,F,R,As,Dst}=I|Is], Regs0, D, Acc) -> + Bl = [{set,[Dst],As,{alloc,R,{gc_bif,N,F}}}], + {_,Regs} = live_opt_block(Bl, Regs0, D, []), + live_opt(Is, Regs, D, [I|Acc]); +live_opt([{bif,N,F,As,Dst}=I|Is], Regs0, D, Acc) -> + Bl = [{set,[Dst],As,{bif,N,F}}], + {_,Regs} = live_opt_block(Bl, Regs0, D, []), + live_opt(Is, Regs, D, [I|Acc]); +live_opt([{get_tuple_element,Src,Idx,Dst}=I|Is], Regs0, D, Acc) -> + Bl = [{set,[Dst],[Src],{get_tuple_element,Idx}}], + {_,Regs} = live_opt_block(Bl, Regs0, D, []), + live_opt(Is, Regs, D, [I|Acc]); +live_opt([{move,Src,Dst}=I|Is], Regs0, D, Acc) -> + Regs = x_live([Src], x_dead([Dst], Regs0)), + live_opt(Is, Regs, D, [I|Acc]); +live_opt([{put_map,F,Op,S,Dst,R,{list,Puts}}=I|Is], Regs0, D, Acc) -> + Bl = [{set,[Dst],[S|Puts],{alloc,R,{put_map,Op,F}}}], + {_,Regs} = live_opt_block(Bl, Regs0, D, []), + live_opt(Is, Regs, D, [I|Acc]); %% Transparent instructions - they neither use nor modify x registers. live_opt([{deallocate,_}=I|Is], Regs, D, Acc) -> @@ -775,6 +989,10 @@ live_opt([{wait_timeout,_,{Tag,_}}=I|Is], Regs, D, Acc) when Tag =/= x -> live_opt(Is, Regs, D, [I|Acc]); live_opt([{line,_}=I|Is], Regs, D, Acc) -> live_opt(Is, Regs, D, [I|Acc]); +live_opt([{'catch',_,_}=I|Is], Regs, D, Acc) -> + live_opt(Is, Regs, D, [I|Acc]); +live_opt([{'try',_,_}=I|Is], Regs, D, Acc) -> + live_opt(Is, Regs, D, [I|Acc]); %% The following instructions can occur if the "compilation" has been %% started from a .S file using the 'from_asm' option. @@ -789,47 +1007,52 @@ live_opt([{recv_mark,_}=I|Is], Regs, D, Acc) -> live_opt([], _, _, Acc) -> Acc. -live_opt_block([{set,Ds,Ss,Op0}|Is], Regs0, D, Acc) -> - Regs1 = x_live(Ss, x_dead(Ds, Regs0)), - {Op, Regs} = live_opt_block_op(Op0, Regs1, D), - I = {set, Ds, Ss, Op}, - - case Ds of - [{x,X}] -> - case (not is_live(X, Regs0)) andalso Op =:= move of - true -> - live_opt_block(Is, Regs0, D, Acc); - false -> - live_opt_block(Is, Regs, D, [I|Acc]) - end; - _ -> - live_opt_block(Is, Regs, D, [I|Acc]) +live_opt_block([{set,[{x,X}]=Ds,Ss,move}=I|Is], Regs0, D, Acc) -> + Regs = x_live(Ss, x_dead(Ds, Regs0)), + case is_live(X, Regs0) of + true -> + live_opt_block(Is, Regs, D, [I|Acc]); + false -> + %% Useless move, will never be used. + live_opt_block(Is, Regs, D, Acc) end; -live_opt_block([{'%live',_,_}|Is], Regs, D, Acc) -> - live_opt_block(Is, Regs, D, Acc); -live_opt_block([], Regs, _, Acc) -> {Acc,Regs}. - -live_opt_block_op({alloc,Live0,AllocOp}, Regs0, D) -> - Regs = - case AllocOp of - {Kind, _N, Fail} when Kind =:= gc_bif; Kind =:= put_map -> - live_join_label(Fail, D, Regs0); - _ -> - Regs0 - end, +live_opt_block([{set,Ds,Ss,{alloc,Live0,AllocOp}}|Is], Regs0, D, Acc) -> + %% Calculate liveness from the point of view of the GC. + %% There will never be a GC if the instruction fails, so we should + %% ignore the failure branch. + GcRegs1 = x_dead(Ds, Regs0), + GcRegs = x_live(Ss, GcRegs1), + Live = live_regs(GcRegs), %% The life-time analysis used by the code generator is sometimes too %% conservative, so it may be possible to lower the number of live %% registers based on the exact liveness information. The main benefit is %% that more optimizations that depend on liveness information (such as the - %% beam_bool and beam_dead passes) may be applied. - Live = live_regs(Regs), - true = Live =< Live0, - {{alloc,Live,AllocOp}, live_call(Live)}; -live_opt_block_op({bif,_N,Fail} = Op, Regs, D) -> - {Op, live_join_label(Fail, D, Regs)}; -live_opt_block_op(Op, Regs, _D) -> - {Op, Regs}. + %% beam_dead pass) may be applied. + true = Live =< Live0, %Assertion. + I = {set,Ds,Ss,{alloc,Live,AllocOp}}, + + %% Calculate liveness from the point of view of the preceding instruction. + %% The liveness is the union of live registers in the GC and the live + %% registers at the failure label. + Regs1 = live_call(Live), + Regs = live_join_alloc(AllocOp, D, Regs1), + live_opt_block(Is, Regs, D, [I|Acc]); +live_opt_block([{set,Ds,Ss,{bif,_,Fail}}=I|Is], Regs0, D, Acc) -> + Regs1 = x_dead(Ds, Regs0), + Regs2 = x_live(Ss, Regs1), + Regs = live_join_label(Fail, D, Regs2), + live_opt_block(Is, Regs, D, [I|Acc]); +live_opt_block([{set,Ds,Ss,_}=I|Is], Regs0, D, Acc) -> + Regs = x_live(Ss, x_dead(Ds, Regs0)), + live_opt_block(Is, Regs, D, [I|Acc]); +live_opt_block([{'%anno',_}|Is], Regs, D, Acc) -> + live_opt_block(Is, Regs, D, Acc); +live_opt_block([], Regs, _, Acc) -> {Acc,Regs}. + +live_join_alloc({Kind,_Name,Fail}, D, Regs) when Kind =:= gc_bif; Kind =:= put_map -> + live_join_label(Fail, D, Regs); +live_join_alloc(_, _, Regs) -> Regs. live_join_labels([{f,L}|T], D, Regs0) when L =/= 0 -> Regs = gb_trees:get(L, D) bor Regs0, @@ -865,3 +1088,220 @@ split_even([], Ss, Ds) -> {reverse(Ss),reverse(Ds)}; split_even([S,D|Rs], Ss, Ds) -> split_even(Rs, [S|Ss], [D|Ds]). + +%%% +%%% Add annotations for defined registers. +%%% +%%% This analysis is done by scanning the instructions in +%%% execution order. +%%% + +defs([{apply,_}=I|Is], _Regs, D) -> + [I|defs(Is, 1, D)]; +defs([{bif,_,{f,Fail},_Src,Dst}=I|Is], Regs0, D) -> + Regs = def_regs([Dst], Regs0), + [I|defs(Is, Regs, update_regs(Fail, Regs0, D))]; +defs([{block,Block0}|Is], Regs0, D0) -> + {Block,Regs,D} = defs_list(Block0, Regs0, D0), + [{block,[make_anno({def,Regs0})|Block]}|defs(Is, Regs, D)]; +defs([{bs_init,{f,L},_,_,_,Dst}=I|Is], Regs0, D) -> + Regs = def_regs([Dst], Regs0), + [I|defs(Is, Regs, update_regs(L, Regs, D))]; +defs([{bs_put,{f,L},_,_}=I|Is], Regs, D) -> + [I|defs(Is, Regs, update_regs(L, Regs, D))]; +defs([build_stacktrace=I|Is], _Regs, D) -> + [I|defs(Is, 1, D)]; +defs([{call,_,_}=I|Is], _Regs, D) -> + [I|defs(Is, 1, D)]; +defs([{call_ext,_,{extfunc,M,F,A}}=I|Is], _Regs, D) -> + case erl_bifs:is_exit_bif(M, F, A) of + false -> + [I|defs(Is, 1, D)]; + true -> + [I|defs_unreachable(Is, D)] + end; +defs([{call_ext,_,_}=I|Is], _Regs, D) -> + [I|defs(Is, 1, D)]; +defs([{call_fun,_}=I|Is], _Regs, D) -> + [I|defs(Is, 1, D)]; +defs([{'catch',_,{f,L}}=I|Is], Regs, D) -> + RegsAtLabel = init_def_regs(1), + [I|defs(Is, Regs, update_regs(L, RegsAtLabel, D))]; +defs([{catch_end,_}=I|Is], _Regs, D) -> + Regs = init_def_regs(1), + [I|defs(Is, Regs, D)]; +defs([{gc_bif,_,{f,Fail},Live,_Src,Dst}=I|Is], Regs0, D) -> + true = all_defined(Live, Regs0), %Assertion. + Regs = def_regs([Dst], init_def_regs(Live)), + [I|defs(Is, Regs, update_regs(Fail, Regs0, D))]; +defs([{get_map_elements,{f,L},_Src,{list,DstList}}=I|Is], Regs0, D) -> + {_,Ds} = beam_utils:split_even(DstList), + Regs = def_regs(Ds, Regs0), + [I|defs(Is, Regs, update_regs(L, Regs0, D))]; +defs([{get_tuple_element,_,_,Dst}=I|Is], Regs0, D) -> + Regs = def_regs([Dst], Regs0), + [I|defs(Is, Regs, D)]; +defs([{jump,{f,L}}=I|Is], Regs, D) -> + [I|defs_unreachable(Is, update_regs(L, Regs, D))]; +defs([{label,L}=I|Is], Regs0, D) -> + case D of + #{L:=Regs1} -> + Regs = Regs0 band Regs1, + [I|defs(Is, Regs, D)]; + #{} -> + [I|defs(Is, Regs0, D)] + end; +defs([{loop_rec,{f,L},{x,0}}=I|Is], _Regs, D0) -> + RegsAtLabel = init_def_regs(0), + D = update_regs(L, RegsAtLabel, D0), + [I|defs(Is, init_def_regs(1), D)]; +defs([{loop_rec_end,_}=I|Is], _Regs, D) -> + [I|defs(Is, 0, D)]; +defs([{make_fun2,_,_,_,_}=I|Is], _Regs, D) -> + [I|defs(Is, 1, D)]; +defs([{move,_,Dst}=I|Is], Regs0, D) -> + Regs = def_regs([Dst], Regs0), + [I|defs(Is, Regs, D)]; +defs([{put_map,{f,Fail},_,_,Dst,_,_}=I|Is], Regs0, D) -> + Regs = def_regs([Dst], Regs0), + [I|defs(Is, Regs, update_regs(Fail, Regs0, D))]; +defs([raw_raise=I|Is], _Regs, D) -> + [I|defs(Is, 1, D)]; +defs([return=I|Is], _Regs, D) -> + [I|defs_unreachable(Is, D)]; +defs([{select,_,_Src,Fail,List}=I|Is], Regs, D0) -> + D = update_list([Fail|List], Regs, D0), + [I|defs_unreachable(Is, D)]; +defs([{test,_,{f,L},_}=I|Is], Regs, D) -> + [I|defs(Is, Regs, update_regs(L, Regs, D))]; +defs([{test,_,{f,L},Live,_,Dst}=I|Is], Regs0, D) -> + true = all_defined(Live, Regs0), %Assertion. + Regs = def_regs([Dst], init_def_regs(Live)), + [I|defs(Is, Regs, update_regs(L, Regs0, D))]; +defs([{'try',_,{f,L}}=I|Is], Regs, D) -> + RegsAtLabel = init_def_regs(3), + [I|defs(Is, Regs, update_regs(L, RegsAtLabel, D))]; +defs([{try_case,_}=I|Is], _Regs, D) -> + [I|defs(Is, init_def_regs(3), D)]; +defs([{wait,_}=I|Is], _Regs, D) -> + [I|defs_unreachable(Is, D)]; +defs([{wait_timeout,_,_}=I|Is], _Regs, D) -> + [I|defs(Is, 0, D)]; + +%% Exceptions. +defs([{badmatch,_}=I|Is], _Regs, D) -> + [I|defs_unreachable(Is, D)]; +defs([{case_end,_}=I|Is], _Regs, D) -> + [I|defs_unreachable(Is, D)]; +defs([if_end=I|Is], _Regs, D) -> + [I|defs_unreachable(Is, D)]; +defs([{try_case_end,_}=I|Is], _Regs, D) -> + [I|defs_unreachable(Is, D)]; + +%% Neutral instructions +defs([{bs_context_to_binary,_}=I|Is], Regs, D) -> + [I|defs(Is, Regs, D)]; +defs([{bs_restore2,_,_}=I|Is], Regs, D) -> + [I|defs(Is, Regs, D)]; +defs([{bs_save2,_,_}=I|Is], Regs, D) -> + [I|defs(Is, Regs, D)]; +defs([{deallocate,_}=I|Is], Regs, D) -> + [I|defs(Is, Regs, D)]; +defs([{kill,_}=I|Is], Regs, D) -> + [I|defs(Is, Regs, D)]; +defs([{line,_}=I|Is], Regs, D) -> + [I|defs(Is, Regs, D)]; +defs([{recv_mark,_}=I|Is], Regs, D) -> + [I|defs(Is, Regs, D)]; +defs([{recv_set,_}=I|Is], Regs, D) -> + [I|defs(Is, Regs, D)]; +defs([timeout=I|Is], Regs, D) -> + [I|defs(Is, Regs, D)]; +defs([{trim,_,_}=I|Is], Regs, D) -> + [I|defs(Is, Regs, D)]; +defs([{try_end,_}=I|Is], Regs, D) -> + [I|defs(Is, Regs, D)]; +defs([{'%',_}=I|Is], Regs, D) -> + [I|defs(Is, Regs, D)]; +defs([], _, _) -> []. + +defs_unreachable([{label,L}=I|Is], D) -> + case D of + #{L:=Regs} -> + [I|defs(Is, Regs, D)]; + #{} -> + defs_unreachable(Is, D) + end; +defs_unreachable([_|Is], D) -> + defs_unreachable(Is, D); +defs_unreachable([], _D) -> []. + +defs_list(Is, Regs, D) -> + defs_list(Is, Regs, D, []). + +defs_list([{set,Ds,_,{alloc,Live,Info}}=I|Is], Regs0, D0, Acc) -> + true = all_defined(Live, Regs0), %Assertion. + D = case Info of + {gc_bif,_,{f,Fail}} -> + update_regs(Fail, Regs0, D0); + {put_map,_,{f,Fail}} -> + update_regs(Fail, Regs0, D0); + _ -> + D0 + end, + Regs = def_regs(Ds, init_def_regs(Live)), + defs_list(Is, Regs, D, [I|Acc]); +defs_list([{set,Ds,_,Info}=I|Is], Regs0, D0, Acc) -> + D = case Info of + {bif,_,{f,Fail}} -> + update_regs(Fail, Regs0, D0); + {try_catch,'catch',{f,Fail}} -> + update_regs(Fail, init_def_regs(1), D0); + {try_catch,'try',{f,Fail}} -> + update_regs(Fail, init_def_regs(3), D0); + _ -> + D0 + end, + Regs = def_regs(Ds, Regs0), + defs_list(Is, Regs, D, [I|Acc]); +defs_list([], Regs, D, Acc) -> + {reverse(Acc),Regs,D}. + +init_def_regs(Arity) -> + (1 bsl Arity) - 1. + +def_regs([{x,X}|T], Regs) -> + def_regs(T, Regs bor (1 bsl X)); +def_regs([_|T], Regs) -> + def_regs(T, Regs); +def_regs([], Regs) -> Regs. + +update_list([{f,L}|T], Regs, D0) -> + D = update_regs(L, Regs, D0), + update_list(T, Regs, D); +update_list([_|T], Regs, D) -> + update_list(T, Regs, D); +update_list([], _Regs, D) -> D. + +update_regs(L, Regs0, D) -> + case D of + #{L:=Regs1} -> + Regs = Regs0 band Regs1, + D#{L:=Regs}; + #{} -> + D#{L=>Regs0} + end. + +all_defined(Live, Regs) -> + All = (1 bsl Live) - 1, + Regs band All =:= All. + +%%% +%%% Utilities. +%%% + +%% make_anno(Anno) -> WrappedAnno. +%% Wrap an annotation term. + +make_anno(Anno) -> + {'%anno',Anno}. diff --git a/lib/compiler/src/beam_validator.erl b/lib/compiler/src/beam_validator.erl index ea38969814..962f17d83c 100644 --- a/lib/compiler/src/beam_validator.erl +++ b/lib/compiler/src/beam_validator.erl @@ -27,9 +27,7 @@ %% Interface for compiler. -export([module/2, format_error/1]). --include("beam_disasm.hrl"). - --import(lists, [reverse/1,foldl/3,foreach/2,dropwhile/2]). +-import(lists, [any/2,dropwhile/2,foldl/3,foreach/2,reverse/1]). %% To be called by the compiler. @@ -85,8 +83,6 @@ format_error(Error) -> %%% Things currently not checked. XXX %%% %%% - Heap allocation for binaries. -%%% - That put_tuple is followed by the correct number of -%%% put instructions. %%% %% validate(Module, [Function]) -> [] | [Error] @@ -130,9 +126,8 @@ validate_0(Module, [{function,Name,Ar,Entry,Code}|Fs], Ft) -> throw:Error -> %% Controlled error. [Error|validate_0(Module, Fs, Ft)]; - Class:Error -> + Class:Error:Stack -> %% Crash. - Stack = erlang:get_stacktrace(), io:fwrite("Function: ~w/~w\n", [Name,Ar]), erlang:raise(Class, Error, Stack) end. @@ -149,7 +144,8 @@ validate_0(Module, [{function,Name,Ar,Entry,Code}|Fs], Ft) -> hf=0, %Available heap size for floats. fls=undefined, %Floating point state. ct=[], %List of hot catch/try labels - setelem=false %Previous instruction was setelement/3. + setelem=false, %Previous instruction was setelement/3. + puts_left=none %put/1 instructions left. }). -type label() :: integer(). @@ -294,6 +290,8 @@ valfun_1({bs_context_to_binary,Ctx}, #vst{current=#st{x=Xs}}=Vst) -> end; valfun_1(bs_init_writable=I, Vst) -> call(I, 1, Vst); +valfun_1(build_stacktrace=I, Vst) -> + call(I, 1, Vst); valfun_1({move,{y,_}=Src,{y,_}=Dst}, Vst) -> %% The stack trimming optimization may generate a move from an initialized %% but unassigned Y register to another Y register. @@ -339,11 +337,25 @@ valfun_1({put_list,A,B,Dst}, Vst0) -> Vst = eat_heap(2, Vst0), set_type_reg(cons, Dst, Vst); valfun_1({put_tuple,Sz,Dst}, Vst0) when is_integer(Sz) -> + Vst1 = eat_heap(1, Vst0), + Vst = set_type_reg(tuple_in_progress, Dst, Vst1), + #vst{current=St0} = Vst, + St = St0#st{puts_left={Sz,{Dst,{tuple,Sz}}}}, + Vst#vst{current=St}; +valfun_1({put,Src}, Vst0) -> + assert_term(Src, Vst0), Vst = eat_heap(1, Vst0), - set_type_reg({tuple,Sz}, Dst, Vst); -valfun_1({put,Src}, Vst) -> - assert_term(Src, Vst), - eat_heap(1, Vst); + #vst{current=St0} = Vst, + case St0 of + #st{puts_left=none} -> + error(not_building_a_tuple); + #st{puts_left={1,{Dst,Type}}} -> + St = St0#st{puts_left=none}, + set_type_reg(Type, Dst, Vst#vst{current=St}); + #st{puts_left={PutsLeft,Info}} when is_integer(PutsLeft) -> + St = St0#st{puts_left={PutsLeft-1,Info}}, + Vst#vst{current=St} + end; %% Instructions for optimization of selective receives. valfun_1({recv_mark,{f,Fail}}, Vst) when is_integer(Fail) -> Vst; @@ -351,7 +363,9 @@ valfun_1({recv_set,{f,Fail}}, Vst) when is_integer(Fail) -> Vst; %% Misc. valfun_1(remove_message, Vst) -> - Vst; + %% The message term is no longer fragile. It can be used + %% without restrictions. + remove_fragility(Vst); valfun_1({'%',_}, Vst) -> Vst; valfun_1({line,_}, Vst) -> @@ -519,14 +533,17 @@ valfun_4({bif,element,{f,Fail},[Pos,Tuple],Dst}, Vst0) -> Vst1 = branch_state(Fail, Vst0), TupleType = upgrade_tuple_type({tuple,[get_tuple_size(PosType)]}, TupleType0), Vst = set_type(TupleType, Tuple, Vst1), - set_type_reg(term, Dst, Vst); + set_type_reg(term, Tuple, Dst, Vst); valfun_4({bif,raise,{f,0},Src,_Dst}, Vst) -> validate_src(Src, Vst), kill_state(Vst); +valfun_4(raw_raise=I, Vst) -> + call(I, 3, Vst); valfun_4({bif,Op,{f,Fail},Src,Dst}, Vst0) -> validate_src(Src, Vst0), Vst = branch_state(Fail, Vst0), - Type = bif_type(Op, Src, Vst), + Type0 = bif_type(Op, Src, Vst), + Type = propagate_fragility(Type0, Src, Vst), set_type_reg(Type, Dst, Vst); valfun_4({gc_bif,Op,{f,Fail},Live,Src,Dst}, #vst{current=St0}=Vst0) -> verify_live(Live, Vst0), @@ -536,7 +553,8 @@ valfun_4({gc_bif,Op,{f,Fail},Live,Src,Dst}, #vst{current=St0}=Vst0) -> Vst2 = branch_state(Fail, Vst1), Vst = prune_x_regs(Live, Vst2), validate_src(Src, Vst), - Type = bif_type(Op, Src, Vst), + Type0 = bif_type(Op, Src, Vst), + Type = propagate_fragility(Type0, Src, Vst), set_type_reg(Type, Dst, Vst); valfun_4(return, #vst{current=#st{numy=none}}=Vst) -> assert_term({x,0}, Vst), @@ -547,13 +565,20 @@ valfun_4({jump,{f,Lbl}}, Vst) -> kill_state(branch_state(Lbl, Vst)); valfun_4({loop_rec,{f,Fail},Dst}, Vst0) -> Vst = branch_state(Fail, Vst0), - set_type_reg(term, Dst, Vst); + %% This term may not be part of the root set until + %% remove_message/0 is executed. If control transfers + %% to the loop_rec_end/1 instruction, no part of + %% this term must be stored in a Y register. + set_type_reg({fragile,term}, Dst, Vst); valfun_4({wait,_}, Vst) -> + verify_y_init(Vst), kill_state(Vst); valfun_4({wait_timeout,_,Src}, Vst) -> assert_term(Src, Vst), - Vst; + verify_y_init(Vst), + prune_x_regs(0, Vst); valfun_4({loop_rec_end,_}, Vst) -> + verify_y_init(Vst), kill_state(Vst); valfun_4(timeout, #vst{current=St}=Vst) -> Vst#vst{current=St#st{x=init_regs(0, term)}}; @@ -573,11 +598,17 @@ valfun_4({select_tuple_arity,Tuple,{f,Fail},{list,Choices}}, Vst) -> kill_state(branch_arities(Choices, Tuple, branch_state(Fail, Vst))); valfun_4({get_list,Src,D1,D2}, Vst0) -> assert_type(cons, Src, Vst0), - Vst = set_type_reg(term, D1, Vst0), - set_type_reg(term, D2, Vst); + Vst = set_type_reg(term, Src, D1, Vst0), + set_type_reg(term, Src, D2, Vst); +valfun_4({get_hd,Src,Dst}, Vst) -> + assert_type(cons, Src, Vst), + set_type_reg(term, Src, Dst, Vst); +valfun_4({get_tl,Src,Dst}, Vst) -> + assert_type(cons, Src, Vst), + set_type_reg(term, Src, Dst, Vst); valfun_4({get_tuple_element,Src,I,Dst}, Vst) -> assert_type({tuple_element,I+1}, Src, Vst), - set_type_reg(term, Dst, Vst); + set_type_reg(term, Src, Dst, Vst); %% New bit syntax matching instructions. valfun_4({test,bs_start_match2,{f,Fail},Live,[Ctx,NeedSlots],Ctx}, Vst0) -> @@ -585,6 +616,7 @@ valfun_4({test,bs_start_match2,{f,Fail},Live,[Ctx,NeedSlots],Ctx}, Vst0) -> %% is OK as input. CtxType = get_move_term_type(Ctx, Vst0), verify_live(Live, Vst0), + verify_y_init(Vst0), Vst1 = prune_x_regs(Live, Vst0), BranchVst = case CtxType of #ms{} -> @@ -601,9 +633,10 @@ valfun_4({test,bs_start_match2,{f,Fail},Live,[Ctx,NeedSlots],Ctx}, Vst0) -> valfun_4({test,bs_start_match2,{f,Fail},Live,[Src,Slots],Dst}, Vst0) -> assert_term(Src, Vst0), verify_live(Live, Vst0), + verify_y_init(Vst0), Vst1 = prune_x_regs(Live, Vst0), Vst = branch_state(Fail, Vst1), - set_type_reg(bsm_match_state(Slots), Dst, Vst); + set_type_reg(bsm_match_state(Slots), Src, Dst, Vst); valfun_4({test,bs_match_string,{f,Fail},[Ctx,_,_]}, Vst) -> bsm_validate_context(Ctx, Vst), branch_state(Fail, Vst); @@ -628,7 +661,8 @@ valfun_4({test,bs_get_integer2,{f,Fail},Live,[Ctx,_,_,_],Dst}, Vst) -> valfun_4({test,bs_get_float2,{f,Fail},Live,[Ctx,_,_,_],Dst}, Vst) -> validate_bs_get(Fail, Ctx, Live, {float, []}, Dst, Vst); valfun_4({test,bs_get_binary2,{f,Fail},Live,[Ctx,_,_,_],Dst}, Vst) -> - validate_bs_get(Fail, Ctx, Live, term, Dst, Vst); + Type = propagate_fragility(term, [Ctx], Vst), + validate_bs_get(Fail, Ctx, Live, Type, Dst, Vst); valfun_4({test,bs_get_utf8,{f,Fail},Live,[Ctx,_],Dst}, Vst) -> validate_bs_get(Fail, Ctx, Live, {integer, []}, Dst, Vst); valfun_4({test,bs_get_utf16,{f,Fail},Live,[Ctx,_],Dst}, Vst) -> @@ -768,7 +802,7 @@ verify_get_map(Fail, Src, List, Vst0) -> Vst2 = branch_state(Fail, Vst1), Keys = extract_map_keys(List), assert_unique_map_keys(Keys), - verify_get_map_pair(List,Vst0,Vst2). + verify_get_map_pair(List, Src, Vst0, Vst2). extract_map_vals([_Key,Val|T]) -> [Val|extract_map_vals(T)]; @@ -778,10 +812,11 @@ extract_map_keys([Key,_Val|T]) -> [Key|extract_map_keys(T)]; extract_map_keys([]) -> []. -verify_get_map_pair([],_,Vst) -> Vst; -verify_get_map_pair([Src,Dst|Vs],Vst0,Vsti) -> +verify_get_map_pair([Src,Dst|Vs], Map, Vst0, Vsti0) -> assert_term(Src, Vst0), - verify_get_map_pair(Vs,Vst0,set_type_reg(term,Dst,Vsti)). + Vsti = set_type_reg(term, Map, Dst, Vsti0), + verify_get_map_pair(Vs, Map, Vst0, Vsti); +verify_get_map_pair([], _Map, _Vst0, Vst) -> Vst. verify_put_map(Fail, Src, Dst, Live, List, Vst0) -> assert_type(map, Src, Vst0), @@ -801,6 +836,7 @@ verify_put_map(Fail, Src, Dst, Live, List, Vst0) -> validate_bs_get(Fail, Ctx, Live, Type, Dst, Vst0) -> bsm_validate_context(Ctx, Vst0), verify_live(Live, Vst0), + verify_y_init(Vst0), Vst1 = prune_x_regs(Live, Vst0), Vst = branch_state(Fail, Vst1), set_type_reg(Type, Dst, Vst). @@ -810,6 +846,7 @@ validate_bs_get(Fail, Ctx, Live, Type, Dst, Vst0) -> %% validate_bs_skip_utf(Fail, Ctx, Live, Vst0) -> bsm_validate_context(Ctx, Vst0), + verify_y_init(Vst0), verify_live(Live, Vst0), Vst = prune_x_regs(Live, Vst0), branch_state(Fail, Vst). @@ -1071,10 +1108,11 @@ bsm_validate_context(Reg, Vst) -> bsm_get_context({x,X}=Reg, #vst{current=#st{x=Xs}}=_Vst) when is_integer(X) -> case gb_trees:lookup(X, Xs) of {value,#ms{}=Ctx} -> Ctx; + {value,{fragile,#ms{}=Ctx}} -> Ctx; _ -> error({no_bsm_context,Reg}) end; bsm_get_context(Reg, _) -> error({bad_source,Reg}). - + bsm_save(Reg, {atom,start}, Vst) -> %% Save point refering to where the match started. %% It is always valid. But don't forget to validate the context register. @@ -1111,13 +1149,34 @@ set_type(Type, {x,_}=Reg, Vst) -> set_type_reg(Type, Reg, Vst); set_type(Type, {y,_}=Reg, Vst) -> set_type_y(Type, Reg, Vst); set_type(_, _, #vst{}=Vst) -> Vst. -set_type_reg(Type, {x,X}=Reg, #vst{current=#st{x=Xs}=St}=Vst) - when is_integer(X), 0 =< X -> - check_limit(Reg), - Vst#vst{current=St#st{x=gb_trees:enter(X, Type, Xs)}}; +set_type_reg(Type, Src, Dst, Vst) -> + case get_term_type_1(Src, Vst) of + {fragile,_} -> + set_type_reg(make_fragile(Type), Dst, Vst); + _ -> + set_type_reg(Type, Dst, Vst) + end. + +set_type_reg(Type, {x,_}=Reg, Vst) -> + set_type_x(Type, Reg, Vst); set_type_reg(Type, Reg, Vst) -> set_type_y(Type, Reg, Vst). +set_type_x(Type, {x,X}=Reg, #vst{current=#st{x=Xs0}=St}=Vst) + when is_integer(X), 0 =< X -> + check_limit(Reg), + Xs = case gb_trees:lookup(X, Xs0) of + none -> + gb_trees:insert(X, Type, Xs0); + {value,{fragile,_}} -> + gb_trees:update(X, make_fragile(Type), Xs0); + {value,_} -> + gb_trees:update(X, Type, Xs0) + end, + Vst#vst{current=St#st{x=Xs}}; +set_type_x(Type, Reg, #vst{}) -> + error({invalid_store,Reg,Type}). + set_type_y(Type, {y,Y}=Reg, #vst{current=#st{y=Ys0}=St}=Vst) when is_integer(Y), 0 =< Y -> check_limit(Reg), @@ -1131,13 +1190,40 @@ set_type_y(Type, {y,Y}=Reg, #vst{current=#st{y=Ys0}=St}=Vst) {value,_} -> gb_trees:update(Y, Type, Ys0) end, + check_try_catch_tags(Type, Y, Ys0), Vst#vst{current=St#st{y=Ys}}; set_type_y(Type, Reg, #vst{}) -> error({invalid_store,Reg,Type}). +make_fragile({fragile,_}=Type) -> Type; +make_fragile(Type) -> {fragile,Type}. + set_catch_end({y,Y}, #vst{current=#st{y=Ys0}=St}=Vst) -> Ys = gb_trees:update(Y, initialized, Ys0), Vst#vst{current=St#st{y=Ys}}. +check_try_catch_tags(Type, LastY, Ys) -> + case is_try_catch_tag(Type) of + false -> + ok; + true -> + %% Every catch or try/catch must use a lower Y register + %% number than any enclosing catch or try/catch. That will + %% ensure that when the stack is scanned when an + %% exception occurs, the innermost try/catch tag is found + %% first. + Bad = [{{y,Y},Tag} || {Y,Tag} <- gb_trees:to_list(Ys), + Y < LastY, is_try_catch_tag(Tag)], + case Bad of + [] -> + ok; + [_|_] -> + error({bad_try_catch_nesting,{y,LastY},Bad}) + end + end. + +is_try_catch_tag({catchtag,_}) -> true; +is_try_catch_tag({trytag,_}) -> true; +is_try_catch_tag(_) -> false. is_reg_defined({x,_}=Reg, Vst) -> is_type_defined_x(Reg, Vst); is_reg_defined({y,_}=Reg, Vst) -> is_type_defined_y(Reg, Vst); @@ -1211,9 +1297,26 @@ assert_term(Src, Vst) -> %% %% map Map. %% +%% +%% +%% FRAGILITY +%% --------- +%% +%% The loop_rec/2 instruction may return a reference to a term that is +%% not part of the root set. That term or any part of it must not be +%% included in a garbage collection. Therefore, the term (or any part +%% of it) must not be stored in an Y register. +%% +%% Such terms are wrapped in a {fragile,Type} tuple, where Type is one +%% of the types described above. assert_type(WantedType, Term, Vst) -> - assert_type(WantedType, get_term_type(Term, Vst)). + case get_term_type(Term, Vst) of + {fragile,Type} -> + assert_type(WantedType, Type); + Type -> + assert_type(WantedType, Type) + end. assert_type(Correct, Correct) -> ok; assert_type(float, {float,_}) -> ok; @@ -1239,14 +1342,19 @@ assert_type(Needed, Actual) -> %% is inconsistent, and we know that some instructions will never %% be executed at run-time. -upgrade_tuple_type({tuple,[Sz]}, {tuple,[OldSz]}=T) when Sz < OldSz -> +upgrade_tuple_type(NewType, {fragile,OldType}) -> + make_fragile(upgrade_tuple_type_1(NewType, OldType)); +upgrade_tuple_type(NewType, OldType) -> + upgrade_tuple_type_1(NewType, OldType). + +upgrade_tuple_type_1({tuple,[Sz]}, {tuple,[OldSz]}=T) when Sz < OldSz -> %% The old type has a higher value for the least tuple size. T; -upgrade_tuple_type({tuple,[Sz]}, {tuple,OldSz}=T) +upgrade_tuple_type_1({tuple,[Sz]}, {tuple,OldSz}=T) when is_integer(Sz), is_integer(OldSz), Sz =< OldSz -> %% The old size is exact, and the new size is smaller than the old size. T; -upgrade_tuple_type({tuple,_}=T, _) -> +upgrade_tuple_type_1({tuple,_}=T, _) -> %% The new type information is exact or has a higher value for %% the least tuple size. %% Note that inconsistencies are also handled in this @@ -1271,6 +1379,7 @@ get_move_term_type(Src, Vst) -> initialized -> error({unassigned,Src}); {catchtag,_} -> error({catchtag,Src}); {trytag,_} -> error({trytag,Src}); + tuple_in_progress -> error({tuple_in_progress,Src}); Type -> Type end. @@ -1279,10 +1388,7 @@ get_move_term_type(Src, Vst) -> %% a standard Erlang type (no catch/try tags or match contexts). get_term_type(Src, Vst) -> - case get_term_type_1(Src, Vst) of - initialized -> error({unassigned,Src}); - {catchtag,_} -> error({catchtag,Src}); - {trytag,_} -> error({trytag,Src}); + case get_move_term_type(Src, Vst) of #ms{} -> error({match_context,Src}); Type -> Type end. @@ -1415,6 +1521,14 @@ merge_y_regs_1(_, _, Regs) -> Regs. %% merge_types(Type1, Type2) -> Type %% Return the most specific type possible. %% Note: Type1 must NOT be the same as Type2. +merge_types({fragile,Same}=Type, Same) -> + Type; +merge_types({fragile,T1}, T2) -> + make_fragile(merge_types(T1, T2)); +merge_types(Same, {fragile,Same}=Type) -> + Type; +merge_types(T1, {fragile,T2}) -> + make_fragile(merge_types(T1, T2)); merge_types(uninitialized=I, _) -> I; merge_types(_, uninitialized=I) -> I; merge_types(initialized=I, _) -> I; @@ -1465,6 +1579,10 @@ verify_y_init(#vst{current=#st{y=Ys}}) -> verify_y_init_1([]) -> ok; verify_y_init_1([{Y,uninitialized}|_]) -> error({uninitialized_reg,{y,Y}}); +verify_y_init_1([{Y,{fragile,_}}|_]) -> + %% Unsafe. This term may be outside any heap belonging + %% to the process and would be corrupted by a GC. + error({fragile_message_reference,{y,Y}}); verify_y_init_1([{_,_}|Ys]) -> verify_y_init_1(Ys). @@ -1510,6 +1628,27 @@ eat_heap_float(#vst{current=#st{hf=HeapFloats0}=St}=Vst) -> Vst#vst{current=St#st{hf=HeapFloats}} end. +remove_fragility(#vst{current=#st{x=Xs0,y=Ys0}=St0}=Vst) -> + F = fun(_, {fragile,Type}) -> Type; + (_, Type) -> Type + end, + Xs = gb_trees:map(F, Xs0), + Ys = gb_trees:map(F, Ys0), + St = St0#st{x=Xs,y=Ys}, + Vst#vst{current=St}. + +propagate_fragility(Type, Ss, Vst) -> + F = fun(S) -> + case get_term_type_1(S, Vst) of + {fragile,_} -> true; + _ -> false + end + end, + case any(F, Ss) of + true -> make_fragile(Type); + false -> Type + end. + bif_type('-', Src, Vst) -> arith_type(Src, Vst); bif_type('+', Src, Vst) -> diff --git a/lib/compiler/src/beam_z.erl b/lib/compiler/src/beam_z.erl index 787e33c142..6c3a6995d7 100644 --- a/lib/compiler/src/beam_z.erl +++ b/lib/compiler/src/beam_z.erl @@ -24,22 +24,23 @@ -export([module/2]). --import(lists, [dropwhile/2]). +-import(lists, [dropwhile/2,map/2]). -spec module(beam_utils:module_code(), [compile:option()]) -> {'ok',beam_asm:module_code()}. -module({Mod,Exp,Attr,Fs0,Lc}, _Opt) -> - Fs = [function(F) || F <- Fs0], +module({Mod,Exp,Attr,Fs0,Lc}, Opts) -> + NoGetHdTl = proplists:get_bool(no_get_hd_tl, Opts), + Fs = [function(F, NoGetHdTl) || F <- Fs0], {ok,{Mod,Exp,Attr,Fs,Lc}}. -function({function,Name,Arity,CLabel,Is0}) -> +function({function,Name,Arity,CLabel,Is0}, NoGetHdTl) -> try - Is = undo_renames(Is0), + Is1 = undo_renames(Is0), + Is = maybe_eliminate_get_hd_tl(Is1, NoGetHdTl), {function,Name,Arity,CLabel,Is} catch - Class:Error -> - Stack = erlang:get_stacktrace(), + Class:Error:Stack -> io:fwrite("Function: ~w/~w\n", [Name,Arity]), erlang:raise(Class, Error, Stack) end. @@ -66,6 +67,10 @@ undo_renames([{bif,raise,_,_,_}=I|Is0]) -> (_) -> true end, Is0), [I|undo_renames(Is)]; +undo_renames([{get_hd,Src,Dst1},{get_tl,Src,Dst2}|Is]) -> + [{get_list,Src,Dst1,Dst2}|undo_renames(Is)]; +undo_renames([{get_tl,Src,Dst2},{get_hd,Src,Dst1}|Is]) -> + [{get_list,Src,Dst1,Dst2}|undo_renames(Is)]; undo_renames([I|Is]) -> [undo_rename(I)|undo_renames(Is)]; undo_renames([]) -> []. @@ -108,3 +113,17 @@ undo_rename({get_map_elements,Fail,Src,{list,List}}) -> undo_rename({select,I,Reg,Fail,List}) -> {I,Reg,Fail,{list,List}}; undo_rename(I) -> I. + +%%% +%%% Eliminate get_hd/get_tl instructions if requested by +%%% the no_get_hd_tl option. +%%% + +maybe_eliminate_get_hd_tl(Is, true) -> + map(fun({get_hd,Cons,Hd}) -> + {get_list,Cons,Hd,{x,1022}}; + ({get_tl,Cons,Tl}) -> + {get_list,Cons,{x,1022},Tl}; + (I) -> I + end, Is); +maybe_eliminate_get_hd_tl(Is, false) -> Is. diff --git a/lib/compiler/src/cerl.erl b/lib/compiler/src/cerl.erl index 6b936a7687..fce23bfd68 100644 --- a/lib/compiler/src/cerl.erl +++ b/lib/compiler/src/cerl.erl @@ -433,6 +433,8 @@ is_literal_term(T) when is_tuple(T) -> is_literal_term(B) when is_bitstring(B) -> true; is_literal_term(M) when is_map(M) -> is_literal_term_list(maps:to_list(M)); +is_literal_term(F) when is_function(F) -> + erlang:fun_info(F, type) =:= {type,external}; is_literal_term(_) -> false. diff --git a/lib/compiler/src/cerl_clauses.erl b/lib/compiler/src/cerl_clauses.erl index 7d6518c3c6..fa5104c01b 100644 --- a/lib/compiler/src/cerl_clauses.erl +++ b/lib/compiler/src/cerl_clauses.erl @@ -353,6 +353,8 @@ match(P, E, Bs) -> map -> %% The most we can do is to say "definitely no match" if a %% map pattern is matched against non-map data. + %% (Note: See the document internal_doc/cerl-notes.md for + %% information why we don't try to do more here.) case E of any -> {false, Bs}; diff --git a/lib/compiler/src/cerl_inline.erl b/lib/compiler/src/cerl_inline.erl index f5afa75b16..caff47dbcb 100644 --- a/lib/compiler/src/cerl_inline.erl +++ b/lib/compiler/src/cerl_inline.erl @@ -1822,6 +1822,14 @@ new_var(Env) -> Name = env__new_vname(Env), c_var(Name). +%% The way a template variable is used makes it necessary +%% to make sure that it is unique in the entire function. +%% Therefore, template variables are atoms with the prefix "@i". + +new_template_var(Env) -> + Name = env__new_tname(Env), + c_var(Name). + residualize_var(R, S) -> S1 = count_size(weight(var), S), {ref_to_var(R), st__set_var_referenced(R#ref.loc, S1)}. @@ -2183,7 +2191,7 @@ make_template(E, Vs0, Env0) -> T = make_data_skel(data_type(E), Ts), E1 = update_data(E, data_type(E), [hd(get_ann(T)) || T <- Ts]), - V = new_var(Env1), + V = new_template_var(Env1), Env2 = env__bind(var_name(V), E1, Env1), {set_ann(T, [V]), [V | Vs1], Env2}; false -> @@ -2198,7 +2206,7 @@ make_template(E, Vs0, Env0) -> Env2 = env__bind(V, E1, Env1), {T, Vs1, Env2}; _ -> - V = new_var(Env0), + V = new_template_var(Env0), Env1 = env__bind(var_name(V), E, Env0), {set_ann(V, [V]), [V | Vs0], Env1} end @@ -2564,6 +2572,11 @@ env__is_defined(Key, Env) -> env__new_vname(Env) -> rec_env:new_key(Env). +env__new_tname(Env) -> + rec_env:new_key(fun(I) -> + list_to_atom("@i"++integer_to_list(I)) + end, Env). + env__new_fname(A, N, Env) -> rec_env:new_key(fun (X) -> S = integer_to_list(X), diff --git a/lib/compiler/src/cerl_trees.erl b/lib/compiler/src/cerl_trees.erl index f30a0b33ac..c7a129b42c 100644 --- a/lib/compiler/src/cerl_trees.erl +++ b/lib/compiler/src/cerl_trees.erl @@ -22,7 +22,8 @@ -module(cerl_trees). -export([depth/1, fold/3, free_variables/1, get_label/1, label/1, label/2, - map/2, mapfold/3, mapfold/4, size/1, variables/1]). + map/2, mapfold/3, mapfold/4, next_free_variable_name/1, + size/1, variables/1]). -import(cerl, [alias_pat/1, alias_var/1, ann_c_alias/3, ann_c_apply/3, ann_c_binary/2, ann_c_bitstr/6, ann_c_call/4, @@ -507,6 +508,7 @@ mapfold_pairs(_, _, S, []) -> %% well-formed Core Erlang syntax tree. %% %% @see free_variables/1 +%% @see next_free_variable_name/1 -spec variables(cerl:cerl()) -> [cerl:var_name()]. @@ -519,6 +521,7 @@ variables(T) -> %% @doc Like <code>variables/1</code>, but only includes variables %% that are free in the tree. %% +%% @see next_free_variable_name/1 %% @see variables/1 -spec free_variables(cerl:cerl()) -> [cerl:var_name()]. @@ -678,6 +681,110 @@ var_list_names([V | Vs], A) -> var_list_names([], A) -> A. +%% --------------------------------------------------------------------- + +%% @spec next_free_variable_name(Tree::cerl()) -> var_name() +%% +%% var_name() = integer() +%% +%% @doc Returns a integer variable name higher than any other integer +%% variable name in the syntax tree. An exception is thrown if +%% <code>Tree</code> does not represent a well-formed Core Erlang +%% syntax tree. +%% +%% @see variables/1 +%% @see free_variables/1 + +-spec next_free_variable_name(cerl:cerl()) -> integer(). + +next_free_variable_name(T) -> + 1 + next_free(T, -1). + +next_free(T, Max) -> + case type(T) of + literal -> + Max; + var -> + case var_name(T) of + Int when is_integer(Int) -> + max(Int, Max); + _ -> + Max + end; + values -> + next_free_in_list(values_es(T), Max); + cons -> + next_free(cons_hd(T), next_free(cons_tl(T), Max)); + tuple -> + next_free_in_list(tuple_es(T), Max); + map -> + next_free_in_list([map_arg(T)|map_es(T)], Max); + map_pair -> + next_free_in_list([map_pair_op(T),map_pair_key(T), + map_pair_val(T)], Max); + 'let' -> + Max1 = next_free(let_body(T), Max), + Max2 = next_free_in_list(let_vars(T), Max1), + next_free(let_arg(T), Max2); + seq -> + next_free(seq_arg(T), + next_free(seq_body(T), Max)); + apply -> + next_free(apply_op(T), + next_free_in_list(apply_args(T), Max)); + call -> + next_free(call_module(T), + next_free(call_name(T), + next_free_in_list( + call_args(T), Max))); + primop -> + next_free_in_list(primop_args(T), Max); + 'case' -> + next_free(case_arg(T), + next_free_in_list(case_clauses(T), Max)); + clause -> + Max1 = next_free(clause_guard(T), + next_free(clause_body(T), Max)), + next_free_in_list(clause_pats(T), Max1); + alias -> + next_free(alias_var(T), + next_free(alias_pat(T), Max)); + 'fun' -> + next_free(fun_body(T), + next_free_in_list(fun_vars(T), Max)); + 'receive' -> + Max1 = next_free_in_list(receive_clauses(T), + next_free(receive_timeout(T), Max)), + next_free(receive_action(T), Max1); + 'try' -> + Max1 = next_free(try_body(T), Max), + Max2 = next_free_in_list(try_vars(T), Max1), + Max3 = next_free(try_handler(T), Max2), + Max4 = next_free_in_list(try_evars(T), Max3), + next_free(try_arg(T), Max4); + 'catch' -> + next_free(catch_body(T), Max); + binary -> + next_free_in_list(binary_segments(T), Max); + bitstr -> + next_free(bitstr_val(T), next_free(bitstr_size(T), Max)); + letrec -> + Max1 = next_free_in_defs(letrec_defs(T), Max), + Max2 = next_free(letrec_body(T), Max1), + next_free_in_list(letrec_vars(T), Max2); + module -> + next_free_in_defs(module_defs(T), Max) + end. + +next_free_in_list([H | T], Max) -> + next_free_in_list(T, next_free(H, Max)); +next_free_in_list([], Max) -> + Max. + +next_free_in_defs([{_, Post} | Ds], Max) -> + next_free_in_defs(Ds, next_free(Post, Max)); +next_free_in_defs([], Max) -> + Max. %% --------------------------------------------------------------------- diff --git a/lib/compiler/src/compile.erl b/lib/compiler/src/compile.erl index 50b0ba76f8..c6a0056a70 100644 --- a/lib/compiler/src/compile.erl +++ b/lib/compiler/src/compile.erl @@ -203,7 +203,12 @@ expand_opts(Opts0) -> {_,_,undefined} -> [debug_info|Opts0]; {_,_,_} -> Opts0 end, - foldr(fun expand_opt/2, [], Opts). + %% iff,unless processing is to complex... + Opts1 = case proplists:is_defined(makedep_side_effect,Opts) of + true -> proplists:delete(makedep,Opts); + false -> Opts + end, + foldr(fun expand_opt/2, [], Opts1). expand_opt(basic_validation, Os) -> [no_code_generation,to_pp,binary|Os]; @@ -214,13 +219,15 @@ expand_opt(report, Os) -> expand_opt(return, Os) -> [return_errors,return_warnings|Os]; expand_opt(r16, Os) -> - [no_record_opt,no_utf8_atoms|Os]; + [no_get_hd_tl,no_record_opt,no_utf8_atoms|Os]; expand_opt(r17, Os) -> - [no_record_opt,no_utf8_atoms|Os]; + [no_get_hd_tl,no_record_opt,no_utf8_atoms|Os]; expand_opt(r18, Os) -> - [no_record_opt,no_utf8_atoms|Os]; + [no_get_hd_tl,no_record_opt,no_utf8_atoms|Os]; expand_opt(r19, Os) -> - [no_record_opt,no_utf8_atoms|Os]; + [no_get_hd_tl,no_record_opt,no_utf8_atoms|Os]; +expand_opt(r20, Os) -> + [no_get_hd_tl,no_record_opt,no_utf8_atoms|Os]; expand_opt({debug_info_key,_}=O, Os) -> [encrypt_debug_info,O|Os]; expand_opt(no_float_opt, Os) -> @@ -674,6 +681,7 @@ select_list_passes_1([], _, Acc) -> standard_passes() -> [?pass(transform_module), + {iff,makedep_side_effect,?pass(makedep_and_output)}, {iff,makedep,[ ?pass(makedep), {unless,binary,?pass(makedep_output)} @@ -706,14 +714,16 @@ core_passes() -> [{unless,no_copt, [{core_old_inliner,fun test_old_inliner/1,fun core_old_inliner/2}, {iff,doldinline,{listing,"oldinline"}}, - {pass,sys_core_fold}, + {unless,no_fold,{pass,sys_core_fold}}, {iff,dcorefold,{listing,"corefold"}}, {core_inline_module,fun test_core_inliner/1,fun core_inline_module/2}, {iff,dinline,{listing,"inline"}}, {core_fold_after_inlining,fun test_any_inliner/1, fun core_fold_module_after_inlining/2}, + {iff,dcopt,{listing,"copt"}}, + {unless,no_alias,{pass,sys_core_alias}}, + {iff,dalias,{listing,"core_alias"}}, ?pass(core_transforms)]}, - {iff,dcopt,{listing,"copt"}}, {iff,'to_core',{done,"core"}}]} | kernel_passes()]. @@ -731,8 +741,6 @@ kernel_passes() -> ?pass(v3_kernel), {iff,dkern,{listing,"kernel"}}, {iff,'to_kernel',{done,"kernel"}}, - {pass,v3_life}, - {iff,dlife,{listing,"life"}}, {pass,v3_codegen}, {iff,dcg,{listing,"codegen"}} | asm_passes()]. @@ -769,6 +777,8 @@ asm_passes() -> {iff,drecv,{listing,"recv"}}, {unless,no_record_opt,{pass,beam_record}}, {iff,drecord,{listing,"record"}}, + {unless,no_blk2,?pass(block2)}, + {iff,dblk2,{listing,"block2"}}, {unless,no_stack_trimming,{pass,beam_trim}}, {iff,dtrim,{listing,"trim"}}, {pass,beam_flatten}]}, @@ -787,7 +797,7 @@ asm_passes() -> | binary_passes()]. binary_passes() -> - [{iff,'to_dis',{listing,"dis"}}, + [{iff,'to_dis',?pass(to_dis)}, {native_compile,fun test_native/1,fun native_compile/2}, {unless,binary,?pass(save_binary,not_werror)} ]. @@ -1128,6 +1138,16 @@ core_lint_module(Code, St) -> errors=St#compile.errors ++ Es}} end. +%% makedep + output and continue +makedep_and_output(Code0, St) -> + {ok,DepCode,St1} = makedep(Code0,St), + case makedep_output(DepCode, St1) of + {ok,_IgnoreCode,St2} -> + {ok,Code0,St2}; + {error,St2} -> + {error,St2} + end. + makedep(Code0, #compile{ifile=Ifile,ofile=Ofile,options=Opts}=St) -> %% Get the target of the Makefile rule. @@ -1334,6 +1354,10 @@ v3_kernel(Code0, #compile{options=Opts,warnings=Ws0}=St) -> {ok,Code,St} end. +block2(Code0, #compile{options=Opts}=St) -> + {ok,Code} = beam_block:module(Code0, [no_blockify|Opts]), + {ok,Code,St}. + test_old_inliner(#compile{options=Opts}) -> %% The point of this test is to avoid loading the old inliner %% if we know that it will not be used. @@ -1448,15 +1472,33 @@ save_core_code(Code, St) -> beam_asm(Code0, #compile{ifile=File,extra_chunks=ExtraChunks,options=CompilerOpts}=St) -> case debug_info(St) of {ok,DebugInfo,Opts0} -> - Source = paranoid_absname(File), Opts1 = [O || O <- Opts0, effects_code_generation(O)], Chunks = [{<<"Dbgi">>, DebugInfo} | ExtraChunks], - {ok,Code} = beam_asm:module(Code0, Chunks, Source, Opts1, CompilerOpts), + CompileInfo = compile_info(File, CompilerOpts, Opts1), + {ok,Code} = beam_asm:module(Code0, Chunks, CompileInfo, CompilerOpts), {ok,Code,St#compile{abstract_code=[]}}; {error,Es} -> {error,St#compile{errors=St#compile.errors ++ [{File,Es}]}} end. +compile_info(File, CompilerOpts, Opts) -> + IsSlim = member(slim, CompilerOpts), + IsDeterministic = member(deterministic, CompilerOpts), + Info0 = proplists:get_value(compile_info, Opts, []), + Info1 = + case paranoid_absname(File) of + [_|_] = Source when not IsSlim, not IsDeterministic -> + [{source,Source} | Info0]; + _ -> + Info0 + end, + Info2 = + case IsDeterministic of + false -> [{options,proplists:delete(compile_info, Opts)} | Info1]; + true -> Info1 + end, + Info2. + paranoid_absname(""=File) -> File; paranoid_absname(File) -> @@ -1512,15 +1554,14 @@ native_compile_1(Code, St) -> {error,St#compile{errors=St#compile.errors ++ Es}} end catch - Class:R -> - Stk = erlang:get_stacktrace(), + Class:R:Stack -> case IgnoreErrors of true -> Ws = [{St#compile.ifile, - [{none,?MODULE,{native_crash,R,Stk}}]}], + [{none,?MODULE,{native_crash,R,Stack}}]}], {ok,St#compile{warnings=St#compile.warnings ++ Ws}}; false -> - erlang:raise(Class, R, Stk) + erlang:raise(Class, R, Stack) end end. @@ -1748,6 +1789,21 @@ listing(LFun, Ext, Code, St) -> {error,St#compile{errors=St#compile.errors ++ Es}} end. +to_dis(Code, #compile{module=Module,ofile=Outfile}=St) -> + Loaded = code:is_loaded(Module), + Sticky = code:is_sticky(Module), + _ = [code:unstick_mod(Module) || Sticky], + + {module,Module} = code:load_binary(Module, "", Code), + DestDir = filename:dirname(Outfile), + DisFile = filename:join(DestDir, atom_to_list(Module) ++ ".dis"), + ok = erts_debug:dis_to_file(Module, DisFile), + + %% Restore loaded module + _ = [{module, Module} = code:load_file(Module) || Loaded =/= false], + [code:stick_mod(Module) || Sticky], + {ok,Code,St}. + output_encoding(F, #compile{encoding = none}) -> ok = io:setopts(F, [{encoding, epp:default_encoding()}]); output_encoding(F, #compile{encoding = Encoding}) -> @@ -1923,12 +1979,12 @@ pre_load() -> erl_lint, erl_parse, erl_scan, + sys_core_alias, sys_core_bsm, sys_core_dsetel, sys_core_fold, v3_codegen, v3_core, - v3_kernel, - v3_life], + v3_kernel], _ = code:ensure_modules_loaded(L), ok. diff --git a/lib/compiler/src/compiler.app.src b/lib/compiler/src/compiler.app.src index 3139d68902..cf32fd251c 100644 --- a/lib/compiler/src/compiler.app.src +++ b/lib/compiler/src/compiler.app.src @@ -58,6 +58,7 @@ core_lib, erl_bifs, rec_env, + sys_core_alias, sys_core_bsm, sys_core_dsetel, sys_core_fold, @@ -67,8 +68,7 @@ v3_codegen, v3_core, v3_kernel, - v3_kernel_pp, - v3_life + v3_kernel_pp ]}, {registered, []}, {applications, [kernel, stdlib]}, diff --git a/lib/compiler/src/core_lint.erl b/lib/compiler/src/core_lint.erl index 7d3513c0ba..6ded8fe78f 100644 --- a/lib/compiler/src/core_lint.erl +++ b/lib/compiler/src/core_lint.erl @@ -353,12 +353,6 @@ expr(#c_case{arg=Arg,clauses=Cs}, Def, Rt, St0) -> Pc = case_patcount(Cs), St1 = body(Arg, Def, Pc, St0), clauses(Cs, Def, Pc, Rt, St1); -expr(#c_receive{clauses=Cs,timeout=#c_literal{val=infinity}, - action=#c_literal{}}, - Def, Rt, St) -> - %% If the timeout is 'infinity', the after code can never - %% be reached. We don't care if the return count is wrong. - clauses(Cs, Def, 1, Rt, St); expr(#c_receive{clauses=Cs,timeout=T,action=A}, Def, Rt, St0) -> St1 = expr(T, Def, 1, St0), St2 = body(A, Def, Rt, St1), @@ -497,8 +491,10 @@ pattern(#c_tuple{es=Es}, Def, Ps, St) -> pattern_list(Es, Def, Ps, St); pattern(#c_map{es=Es}, Def, Ps, St) -> pattern_list(Es, Def, Ps, St); -pattern(#c_map_pair{op=#c_literal{val=exact},key=K,val=V},Def,Ps,St) -> - pattern_list([K,V],Def,Ps,St); +pattern(#c_map_pair{op=#c_literal{val=exact},key=K,val=V}, Def, Ps, St) -> + %% The key is an input. + pat_map_expr(K, Def, St), + pattern_list([V],Def,Ps,St); pattern(#c_binary{segments=Ss}, Def, Ps, St0) -> St = pat_bin_tail_check(Ss, St0), pat_bin(Ss, Def, Ps, St); @@ -561,6 +557,10 @@ pat_bit_expr(#c_binary{}, _, _Def, St) -> pat_bit_expr(_, _, _, St) -> add_error({illegal_expr,St#lint.func}, St). +pat_map_expr(#c_var{name=N}, Def, St) -> expr_var(N, Def, St); +pat_map_expr(#c_literal{}, _Def, St) -> St; +pat_map_expr(_, _, St) -> add_error({illegal_expr,St#lint.func}, St). + %% pattern_list([Var], Defined, State) -> {[PatVar],State}. %% pattern_list([Var], Defined, [PatVar], State) -> {[PatVar],State}. diff --git a/lib/compiler/src/core_parse.yrl b/lib/compiler/src/core_parse.yrl index 79a7cccd98..11c4cd8b50 100644 --- a/lib/compiler/src/core_parse.yrl +++ b/lib/compiler/src/core_parse.yrl @@ -36,7 +36,7 @@ other_pattern atomic_pattern tuple_pattern cons_pattern tail_pattern binary_pattern segment_patterns segment_pattern expression single_expression -literal literals atomic_literal tuple_literal cons_literal tail_literal +literal literals atomic_literal tuple_literal cons_literal tail_literal fun_literal nil tuple cons tail binary segments segment @@ -267,6 +267,7 @@ single_expression -> cons : '$1'. single_expression -> binary : '$1'. single_expression -> variable : '$1'. single_expression -> function_name : '$1'. +single_expression -> fun_literal : '$1'. single_expression -> fun_expr : '$1'. single_expression -> let_expr : '$1'. single_expression -> letrec_expr : '$1'. @@ -303,6 +304,9 @@ tail_literal -> ']' : #c_literal{val=[]}. tail_literal -> '|' literal ']' : '$2'. tail_literal -> ',' literal tail_literal : c_cons('$2', '$3'). +fun_literal -> 'fun' atom ':' atom '/' integer : + #c_literal{val = erlang:make_fun(tok_val('$2'), tok_val('$4'), tok_val('$6'))}. + tuple -> '{' '}' : c_tuple([]). tuple -> '{' anno_expressions '}' : c_tuple('$2'). @@ -496,7 +500,7 @@ make_lit_bin(Acc, [#c_bitstr{val=I0,size=Sz0,unit=U0,type=Type0,flags=F0}|T]) -> throw(impossible) end, if - Sz =< 8, T =:= [] -> + 0 =< Sz, Sz =< 8, T =:= [] -> <<Acc/binary,I:Sz>>; Sz =:= 8 -> make_lit_bin(<<Acc/binary,I:8>>, T); diff --git a/lib/compiler/src/core_pp.erl b/lib/compiler/src/core_pp.erl index cff6c7098b..f247722b4c 100644 --- a/lib/compiler/src/core_pp.erl +++ b/lib/compiler/src/core_pp.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. @@ -136,6 +136,11 @@ format_1(#c_literal{anno=A,val=M},Ctxt) when is_map(M) -> key=#c_literal{val=K}, val=#c_literal{val=V}} || {K,V} <- Pairs], format_1(#c_map{anno=A,arg=#c_literal{val=#{}},es=Cpairs},Ctxt); +format_1(#c_literal{val=F},_Ctxt) when is_function(F) -> + {module,M} = erlang:fun_info(F, module), + {name,N} = erlang:fun_info(F, name), + {arity,A} = erlang:fun_info(F, arity), + ["fun ",core_atom(M),$:,core_atom(N),$/,integer_to_list(A)]; format_1(#c_var{name={I,A}}, _) -> [core_atom(I),$/,integer_to_list(A)]; format_1(#c_var{name=V}, _) -> @@ -464,7 +469,7 @@ indent(#ctxt{indent=N}) -> N =< 0 -> ""; true -> - string:chars($\t, N div ?TAB_WIDTH, spaces(N rem ?TAB_WIDTH)) + lists:duplicate(N div ?TAB_WIDTH, $\t) ++ spaces(N rem ?TAB_WIDTH) end. nl_indent(Ctxt) -> [$\n|indent(Ctxt)]. @@ -541,4 +546,3 @@ segs_from_bitstring(Bitstring) -> unit=#c_literal{val=1}, type=#c_literal{val=integer}, flags=#c_literal{val=[unsigned,big]}}]. - diff --git a/lib/compiler/src/core_scan.erl b/lib/compiler/src/core_scan.erl index 9f0676538f..a50a2ffa8d 100644 --- a/lib/compiler/src/core_scan.erl +++ b/lib/compiler/src/core_scan.erl @@ -200,8 +200,8 @@ pre_string(eof, Q, _, Sp, SoFar, Pos) -> pre_string_error(Q, Sp, SoFar, Pos). pre_string_error(Q, Sp, SoFar, Pos) -> - S = reverse(string:substr(SoFar, 1, string:chr(SoFar, Q)-1)), - pre_error({string,Q,string:substr(S, 1, 16)}, Sp, Pos). + [S,_] = string:split(SoFar, [Q]), + pre_error({string,Q,string:slice(string:reverse(S), 0, 16)}, Sp, Pos). pre_char([C|Cs], SoFar) -> pre_char(C, Cs, SoFar); pre_char([], _) -> more; diff --git a/lib/compiler/src/erl_bifs.erl b/lib/compiler/src/erl_bifs.erl index bafa9d75b7..70b36f029e 100644 --- a/lib/compiler/src/erl_bifs.erl +++ b/lib/compiler/src/erl_bifs.erl @@ -109,6 +109,8 @@ is_pure(erlang, list_to_integer, 1) -> true; is_pure(erlang, list_to_pid, 1) -> true; is_pure(erlang, list_to_tuple, 1) -> true; is_pure(erlang, max, 2) -> true; +is_pure(erlang, make_fun, 3) -> true; +is_pure(erlang, map_get, 2) -> true; is_pure(erlang, min, 2) -> true; is_pure(erlang, phash, 2) -> false; is_pure(erlang, pid_to_list, 1) -> true; @@ -196,6 +198,7 @@ is_safe(erlang, is_port, 1) -> true; is_safe(erlang, is_reference, 1) -> true; is_safe(erlang, is_tuple, 1) -> true; is_safe(erlang, make_ref, 0) -> true; +is_safe(erlang, make_fun, 3) -> true; is_safe(erlang, max, 2) -> true; is_safe(erlang, min, 2) -> true; is_safe(erlang, node, 0) -> true; diff --git a/lib/compiler/src/genop.tab b/lib/compiler/src/genop.tab index b5688de339..a47d4e8cf7 100755 --- a/lib/compiler/src/genop.tab +++ b/lib/compiler/src/genop.tab @@ -545,3 +545,32 @@ BEAM_FORMAT_NUMBER=0 ## Test the arity of Reg and jumps to Lbl if it is not N. ## Test the first element of the tuple and jumps to Lbl if it is not Atom. 159: is_tagged_tuple/4 + +# OTP 21 + +## @spec build_stacktrace +## @doc Given the raw stacktrace in x(0), build a cooked stacktrace suitable +## for human consumption. Store it in x(0). Destroys all other registers. +## Do a garbage collection if necessary to allocate space on the heap +## for the result. +160: build_stacktrace/0 + +## @spec raw_raise +## @doc This instruction works like the erlang:raise/3 BIF, except that the +## stacktrace in x(2) must be a raw stacktrace. +## x(0) is the class of the exception (error, exit, or throw), +## x(1) is the exception term, and x(2) is the raw stackframe. +## If x(0) is not a valid class, the instruction will not throw an +## exception, but store the atom 'badarg' in x(0) and execute the +## next instruction. +161: raw_raise/0 + +## @spec get_hd Source Head +## @doc Get the head (or car) part of a list (a cons cell) from Source and +## put it into the register Head. +162: get_hd/2 + +## @spec get_tl Source Tail +## @doc Get the tail (or cdr) part of a list (a cons cell) from Source and +## put it into the register Tail. +163: get_tl/2 diff --git a/lib/compiler/src/sys_core_alias.erl b/lib/compiler/src/sys_core_alias.erl new file mode 100644 index 0000000000..1bce1577d1 --- /dev/null +++ b/lib/compiler/src/sys_core_alias.erl @@ -0,0 +1,307 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1999-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 : Replace values by aliases from patterns optimisation for Core + +%% Replace expressions by aliases from patterns. For example: +%% +%% example({ok, Val}) -> +%% {ok, Val}. +%% +%% will become: +%% +%% example({ok, Val} = Tuple) -> +%% Tuple. +%% +%% Currently this pass aliases tuple and cons nodes made of literals, +%% variables and other cons. The tuple/cons may appear anywhere in the +%% pattern and it will be aliased if used later on. +%% +%% Notice a tuple/cons made only of literals is not aliased as it may +%% be part of the literal pool. + +-module(sys_core_alias). + +-export([module/2]). + +-include("core_parse.hrl"). + +-define(NOTSET, 0). + +-record(sub, {p=#{} :: #{term() => ?NOTSET | atom()}, %% Found pattern substitutions + v=cerl_sets:new() :: cerl_sets:set(cerl:var_name()), %% Variables used by patterns + t=undefined :: term()}). %% Temporary information from pre to post + +-type sub() :: #sub{}. + +-spec module(cerl:c_module(), [compile:option()]) -> + {'ok',cerl:c_module(),[]}. + +module(#c_module{defs=Ds0}=Mod, _Opts) -> + Ds1 = [def(D) || D <- Ds0], + {ok,Mod#c_module{defs=Ds1},[]}. + +def({#c_var{name={F,Arity}}=Name,B0}) -> + try + put(new_var_num, 0), + {B1,_} = cerl_trees:mapfold(fun pre/2, fun post/2, sub_new(undefined), B0), + erase(new_var_num), + {Name,B1} + catch + Class:Error:Stack -> + io:fwrite("Function: ~w/~w\n", [F,Arity]), + erlang:raise(Class, Error, Stack) + end. + +pre(#c_let{vars=Vars}=Node, Sub) -> + {Node,sub_fold(get_variables(Vars), Sub)}; + +pre(#c_fun{vars=Vars}=Node, Sub) -> + {Node,sub_fold(get_variables(Vars), Sub)}; + +pre(#c_clause{pats=Pats}=Node, Sub0) -> + VarNames = get_variables(Pats), + Sub1 = sub_fold(VarNames, Sub0), + Keys = get_pattern_keys(Pats), + Sub2 = sub_add_keys(Keys, Sub1), + + #sub{v=SubNames,t=Temp} = Sub2, + Sub3 = Sub2#sub{v=merge_variables(VarNames, SubNames), + t={clause,Pats,Keys,SubNames,Temp}}, + + {Node#c_clause{pats=[]},Sub3}; + +pre(Node, Sub0) -> + %% We cache only tuples and cons. + case cerl:is_data(Node) andalso not cerl:is_literal(Node) of + false -> + {Node,Sub0}; + true -> + Kind = cerl:data_type(Node), + Es = cerl:data_es(Node), + case sub_cache_nodes(Kind, Es, Sub0) of + {Name,Sub1} -> + {cerl:ann_c_var(cerl:get_ann(Node), Name),Sub1}; + error -> + {Node,Sub0} + end + end. + +post(#c_let{}=Node, Sub) -> + {Node,sub_unfold(Sub)}; + +post(#c_fun{}=Node, Sub) -> + {Node,sub_unfold(Sub)}; + +post(#c_clause{}=Node, #sub{t={clause,Pats0,Keys,V,T}}=Sub0) -> + {Sub1,PostKeys} = sub_take_keys(Keys, Sub0), + Pats1 = put_pattern_keys(Pats0, PostKeys), + Sub2 = sub_unfold(Sub1#sub{v=V,t=T}), + {Node#c_clause{pats=Pats1},Sub2}; + +post(Node, Sub) -> + {Node,Sub}. + +%% sub_new/1 +%% sub_add_keys/2 +%% sub_take_keys/3 +%% sub_cache_nodes/3 +%% +%% Manages the substitutions record. + +%% Builds a new sub. +-spec sub_new(term()) -> sub(). +sub_new(Temp) -> + #sub{t=Temp}. + +%% Folds the sub into a new one if the variables in nodes are not disjoint +sub_fold(VarNames, #sub{v=SubNames}=Sub) -> + case is_disjoint_variables(VarNames, SubNames) of + true -> Sub#sub{t={temp,Sub#sub.t}}; + false -> sub_new({sub,Sub}) + end. + +%% Unfolds the sub in case one was folded in the previous step +sub_unfold(#sub{t={temp,Temp}}=Sub) -> + Sub#sub{t=Temp}; +sub_unfold(#sub{t={sub,Sub}}) -> + Sub. + +%% Adds the keys extracted from patterns to the state. +-spec sub_add_keys([term()], sub()) -> sub(). +sub_add_keys(Keys, #sub{p=Pat0}=Sub) -> + Pat1 = + lists:foldl(fun(Key, Acc) -> + false = maps:is_key(Key, Acc), %Assertion. + maps:put(Key, ?NOTSET, Acc) + end, Pat0, Keys), + Sub#sub{p=Pat1}. + +%% Take the keys from the map taking into account the keys +%% that have changed as those must become aliases in the pattern. +-spec sub_take_keys([term()], sub()) -> {sub(), [{term(), atom()}]}. +sub_take_keys(Keys, #sub{p=Pat0}=Sub) -> + {Pat1,Acc} = sub_take_keys(Keys, Pat0, []), + {Sub#sub{p=Pat1},Acc}. + +sub_take_keys([K|T], Sub0, Acc) -> + case maps:take(K, Sub0) of + {?NOTSET,Sub1} -> + sub_take_keys(T, Sub1, Acc); + {Name,Sub1} -> + sub_take_keys(T, Sub1, [{K,Name}|Acc]) + end; +sub_take_keys([], Sub, Acc) -> + {Sub,Acc}. + +%% Check if the node can be cached based on the state information. +%% If it can be cached and it does not have an alias for it, we +%% build one. +-spec sub_cache_nodes(atom(), [cerl:cerl()], sub()) -> {atom(), sub()} | error. +sub_cache_nodes(Kind, Nodes, #sub{p=Pat}=Sub) -> + case nodes_to_key(Kind, Nodes) of + {ok, Key} -> + case Pat of + #{Key := ?NOTSET} -> + new_var_name(Key, Sub); + #{Key := Name} -> + {Name,Sub}; + #{} -> + error + end; + error -> + error + end. + +new_var_name(Key, #sub{p=Pat}=Sub) -> + Counter = get(new_var_num), + Name = list_to_atom("@r" ++ integer_to_list(Counter)), + put(new_var_num, Counter + 1), + {Name,Sub#sub{p=maps:put(Key, Name, Pat)}}. + +%% get_variables/1 +%% is_disjoint_variables/2 +%% merge_variables/2 + +get_variables(NodesList) -> + cerl_sets:from_list([Var || Node <- NodesList, Var <- cerl_trees:variables(Node)]). + +is_disjoint_variables(Vars1, Vars2) -> + cerl_sets:is_disjoint(Vars1, Vars2). + +merge_variables(Vars1, Vars2) -> + cerl_sets:union(Vars1, Vars2). + +%% get_pattern_keys/2 +%% put_pattern_keys/2 +%% +%% Gets keys from patterns or add them as aliases. + +get_pattern_keys(Patterns) -> + lists:foldl(fun get_pattern_keys/2, [], Patterns). + +get_pattern_keys(#c_tuple{es=Es}, Acc0) -> + Acc1 = accumulate_pattern_keys(tuple, Es, Acc0), + lists:foldl(fun get_pattern_keys/2, Acc1, Es); +get_pattern_keys(#c_cons{hd=Hd,tl=Tl}, Acc0) -> + Acc1 = accumulate_pattern_keys(cons, [Hd, Tl], Acc0), + get_pattern_keys(Tl, get_pattern_keys(Hd, Acc1)); +get_pattern_keys(#c_alias{pat=Pat}, Acc0) -> + get_pattern_keys(Pat, Acc0); +get_pattern_keys(#c_map{es=Es}, Acc0) -> + lists:foldl(fun get_pattern_keys/2, Acc0, Es); +get_pattern_keys(#c_map_pair{val=Val}, Acc0) -> + get_pattern_keys(Val, Acc0); +get_pattern_keys(_, Acc) -> + Acc. + +accumulate_pattern_keys(Kind, Nodes, Acc) -> + case nodes_to_key(Kind, Nodes) of + {ok,Key} -> [Key|Acc]; + error -> Acc + end. + +put_pattern_keys(Patterns, []) -> + Patterns; +put_pattern_keys(Patterns, Keys) -> + {NewPatterns,Map} = + lists:mapfoldl(fun alias_pattern_keys/2, maps:from_list(Keys), Patterns), + %% Check all aliases have been consumed from the map. + 0 = map_size(Map), + NewPatterns. + +alias_pattern_keys(#c_tuple{anno=Anno,es=Es0}=Node, Acc0) -> + {Es1,Acc1} = lists:mapfoldl(fun alias_pattern_keys/2, Acc0, Es0), + nodes_to_alias(tuple, Es0, Anno, Node#c_tuple{es=Es1}, Acc1); +alias_pattern_keys(#c_cons{anno=Anno,hd=Hd0,tl=Tl0}=Node, Acc0) -> + {Hd1,Acc1} = alias_pattern_keys(Hd0, Acc0), + {Tl1,Acc2} = alias_pattern_keys(Tl0, Acc1), + nodes_to_alias(cons, [Hd0, Tl0], Anno, Node#c_cons{hd=Hd1,tl=Tl1}, Acc2); +alias_pattern_keys(#c_alias{pat=Pat0}=Node, Acc0) -> + {Pat1,Acc1} = alias_pattern_keys(Pat0, Acc0), + {Node#c_alias{pat=Pat1}, Acc1}; +alias_pattern_keys(#c_map{es=Es0}=Node, Acc0) -> + {Es1,Acc1} = lists:mapfoldl(fun alias_pattern_keys/2, Acc0, Es0), + {Node#c_map{es=Es1}, Acc1}; +alias_pattern_keys(#c_map_pair{val=Val0}=Node, Acc0) -> + {Val1,Acc1} = alias_pattern_keys(Val0, Acc0), + {Node#c_map_pair{val=Val1}, Acc1}; +alias_pattern_keys(Pattern, Acc) -> + {Pattern,Acc}. + +%% Check if a node must become an alias because +%% its pattern was used later on as an expression. +nodes_to_alias(Kind, Inner, Anno, Node, Keys0) -> + case nodes_to_key(Kind, Inner) of + {ok,Key} -> + case maps:take(Key, Keys0) of + {Name,Keys1} -> + Var = cerl:ann_c_var(Anno, Name), + {cerl:ann_c_alias(Anno, Var, Node), Keys1}; + error -> + {Node,Keys0} + end; + error -> + {Node,Keys0} + end. + +%% Builds the key used to check if a value can be +%% replaced by an alias. It considers literals, +%% aliases, variables, tuples and cons recursively. +nodes_to_key(Kind, Nodes) -> + nodes_to_key(Nodes, [], Kind). + +nodes_to_key([#c_alias{var=Var}|T], Acc, Kind) -> + nodes_to_key([Var|T], Acc, Kind); +nodes_to_key([#c_var{name=Name}|T], Acc, Kind) -> + nodes_to_key(T, [[var,Name]|Acc], Kind); +nodes_to_key([Node|T], Acc0, Kind) -> + case cerl:is_data(Node) of + false -> + error; + true -> + case nodes_to_key(cerl:data_es(Node), [], cerl:data_type(Node)) of + {ok,Key} -> + nodes_to_key(T, [Key|Acc0], Kind); + error -> + error + end + end; +nodes_to_key([], Acc, Kind) -> + {ok,[Kind|Acc]}. diff --git a/lib/compiler/src/sys_core_bsm.erl b/lib/compiler/src/sys_core_bsm.erl index 3e04cc33df..65580f79e3 100644 --- a/lib/compiler/src/sys_core_bsm.erl +++ b/lib/compiler/src/sys_core_bsm.erl @@ -24,7 +24,7 @@ -export([module/2,format_error/1]). -include("core_parse.hrl"). --import(lists, [member/2,nth/2,reverse/1,usort/1]). +-import(lists, [member/2,reverse/1,usort/1]). -spec module(cerl:c_module(), [compile:option()]) -> {'ok', cerl:c_module()}. @@ -44,8 +44,7 @@ function([{#c_var{name={F,Arity}}=Name,B0}|Fs], FsAcc, Ws0) -> {B,Ws} -> function(Fs, [{Name,B}|FsAcc], Ws) catch - Class:Error -> - Stack = erlang:get_stacktrace(), + Class:Error:Stack -> io:fwrite("Function: ~w/~w\n", [F,Arity]), erlang:raise(Class, Error, Stack) end; @@ -60,13 +59,6 @@ format_error(bin_opt_alias) -> format_error(bin_partition) -> "INFO: matching non-variables after a previous clause matching a variable " "will prevent delayed sub binary optimization"; -format_error(bin_left_var_used_in_guard) -> - "INFO: a variable to the left of the binary pattern is used in a guard; " - "will prevent delayed sub binary optimization"; -format_error(bin_argument_order) -> - "INFO: matching anything else but a plain variable to the left of " - "binary pattern will prevent delayed sub binary optimization; " - "SUGGEST changing argument order"; format_error(bin_var_used) -> "INFO: using a matched out sub binary will prevent " "delayed sub binary optimization"; @@ -97,46 +89,41 @@ bsm_an(#c_case{arg=#c_values{es=Es}}=Case) -> bsm_an(Other) -> {ok,Other}. -bsm_an_1(Vs, #c_case{clauses=Cs}=Case) -> - case bsm_leftmost(Cs) of - none -> {ok,Case}; - Pos -> bsm_an_2(Vs, Cs, Case, Pos) - end. - -bsm_an_2(Vs, Cs, Case, Pos) -> - case bsm_nonempty(Cs, Pos) of - true -> bsm_an_3(Vs, Cs, Case, Pos); - false -> {ok,Case} +bsm_an_1(Vs0, #c_case{clauses=Cs0}=Case) -> + case bsm_leftmost(Cs0) of + none -> + {ok,Case}; + 1 -> + bsm_an_2(Vs0, Cs0, Case); + Pos -> + Vs = move_from_col(Pos, Vs0), + Cs = [C#c_clause{pats=move_from_col(Pos, Ps)} || + #c_clause{pats=Ps}=C <- Cs0], + bsm_an_2(Vs, Cs, Case) end. -bsm_an_3(Vs, Cs, Case, Pos) -> +bsm_an_2(Vs, Cs, Case) -> try - bsm_ensure_no_partition(Cs, Pos), - {ok,bsm_do_an(Vs, Pos, Cs, Case)} + bsm_ensure_no_partition(Cs), + {ok,bsm_do_an(Vs, Cs, Case)} catch - throw:{problem,Where,What} -> - {ok,Case,{Where,What}} + throw:{problem,Where,What} -> + {ok,Case,{Where,What}} end. -bsm_do_an(Vs0, Pos, Cs0, Case) -> - case nth(Pos, Vs0) of - #c_var{name=Vname}=V0 -> - Cs = bsm_do_an_var(Vname, Pos, Cs0, []), - V = bsm_annotate_for_reuse(V0), - Bef = lists:sublist(Vs0, Pos-1), - Aft = lists:nthtail(Pos, Vs0), - case Bef ++ [V|Aft] of - [_] -> - Case#c_case{arg=V,clauses=Cs}; - Vs -> - Case#c_case{arg=#c_values{es=Vs},clauses=Cs} - end; - _ -> - Case - end. +move_from_col(Pos, L) -> + {First,[Col|Rest]} = lists:split(Pos - 1, L), + [Col|First] ++ Rest. -bsm_do_an_var(V, S, [#c_clause{pats=Ps,guard=G,body=B0}=C0|Cs], Acc) -> - case nth(S, Ps) of +bsm_do_an([#c_var{name=Vname}=V0|Vs0], Cs0, Case) -> + Cs = bsm_do_an_var(Vname, Cs0), + V = bsm_annotate_for_reuse(V0), + Vs = core_lib:make_values([V|Vs0]), + Case#c_case{arg=Vs,clauses=Cs}; +bsm_do_an(_Vs, _Cs, Case) -> Case. + +bsm_do_an_var(V, [#c_clause{pats=[P|_],guard=G,body=B0}=C0|Cs]) -> + case P of #c_var{name=VarName} -> case core_lib:is_var_used(V, G) of true -> bsm_problem(C0, orig_bin_var_used_in_guard); @@ -149,23 +136,23 @@ bsm_do_an_var(V, S, [#c_clause{pats=Ps,guard=G,body=B0}=C0|Cs], Acc) -> B1 = bsm_maybe_ctx_to_binary(VarName, B0), B = bsm_maybe_ctx_to_binary(V, B1), C = C0#c_clause{body=B}, - bsm_do_an_var(V, S, Cs, [C|Acc]); - #c_alias{}=P -> + [C|bsm_do_an_var(V, Cs)]; + #c_alias{} -> case bsm_could_match_binary(P) of false -> - bsm_do_an_var(V, S, Cs, [C0|Acc]); + [C0|bsm_do_an_var(V, Cs)]; true -> bsm_problem(C0, bin_opt_alias) end; - P -> + _ -> case bsm_could_match_binary(P) andalso bsm_is_var_used(V, G, B0) of false -> - bsm_do_an_var(V, S, Cs, [C0|Acc]); + [C0|bsm_do_an_var(V, Cs)]; true -> bsm_problem(C0, bin_var_used) end end; -bsm_do_an_var(_, _, [], Acc) -> reverse(Acc). +bsm_do_an_var(_, []) -> []. bsm_annotate_for_reuse(#c_var{anno=Anno}=Var) -> Var#c_var{anno=[reuse_for_context|Anno]}. @@ -193,131 +180,82 @@ previous_ctx_to_binary(V, Core) -> end. %% bsm_leftmost(Cs) -> none | ArgumentNumber -%% Find the leftmost argument that does binary matching. Return -%% the number of the argument (1-N). +%% Find the leftmost argument that matches a nonempty binary. +%% Return either 'none' or the argument number (1-N). bsm_leftmost(Cs) -> bsm_leftmost_1(Cs, none). +bsm_leftmost_1([_|_], 1) -> + 1; bsm_leftmost_1([#c_clause{pats=Ps}|Cs], Pos) -> bsm_leftmost_2(Ps, Cs, 1, Pos); bsm_leftmost_1([], Pos) -> Pos. bsm_leftmost_2(_, Cs, Pos, Pos) -> bsm_leftmost_1(Cs, Pos); -bsm_leftmost_2([#c_binary{}|_], Cs, N, _) -> +bsm_leftmost_2([#c_binary{segments=[_|_]}|_], Cs, N, _) -> bsm_leftmost_1(Cs, N); bsm_leftmost_2([_|Ps], Cs, N, Pos) -> bsm_leftmost_2(Ps, Cs, N+1, Pos); bsm_leftmost_2([], Cs, _, Pos) -> bsm_leftmost_1(Cs, Pos). -%% bsm_nonempty(Cs, Pos) -> true|false -%% Check if at least one of the clauses matches a non-empty -%% binary in the given argument position. +%% bsm_ensure_no_partition(Cs) -> ok (exception if problem) +%% There must only be a single bs_start_match2 instruction if we +%% are to reuse the binary variable for the match context. +%% +%% To make sure that there is only a single bs_start_match2 +%% instruction, we will check for partitions such as: %% -bsm_nonempty([#c_clause{pats=Ps}|Cs], Pos) -> - case nth(Pos, Ps) of - #c_binary{segments=[_|_]} -> - true; - _ -> - bsm_nonempty(Cs, Pos) - end; -bsm_nonempty([], _ ) -> false. - -%% bsm_ensure_no_partition(Cs, Pos) -> ok (exception if problem) -%% We must make sure that matching is not partitioned between -%% variables like this: %% foo(<<...>>) -> ... %% foo(<Variable>) when ... -> ... -%% foo(<Any non-variable pattern>) -> -%% If there is such partition, we are not allowed to reuse the binary variable -%% for the match context. +%% foo(<Non-variable pattern>) -> %% -%% Also, arguments to the left of the argument that is matched -%% against a binary, are only allowed to be simple variables, not -%% used in guards. The reason is that we must know that the binary is -%% only matched in one place (i.e. there must be only one bs_start_match2 -%% instruction emitted). +%% If there is such partition, we reject the optimization. -bsm_ensure_no_partition(Cs, Pos) -> - bsm_ensure_no_partition_1(Cs, Pos, before). +bsm_ensure_no_partition(Cs) -> + bsm_ensure_no_partition_1(Cs, before). %% Loop through each clause. -bsm_ensure_no_partition_1([#c_clause{pats=Ps,guard=G}|Cs], Pos, State0) -> - State = bsm_ensure_no_partition_2(Ps, Pos, G, simple_vars, State0), +bsm_ensure_no_partition_1([#c_clause{pats=Ps,guard=G}|Cs], State0) -> + State = bsm_ensure_no_partition_2(Ps, G, State0), case State of 'after' -> - bsm_ensure_no_partition_after(Cs, Pos); + bsm_ensure_no_partition_after(Cs); _ -> ok end, - bsm_ensure_no_partition_1(Cs, Pos, State); -bsm_ensure_no_partition_1([], _, _) -> ok. + bsm_ensure_no_partition_1(Cs, State); +bsm_ensure_no_partition_1([], _) -> ok. -%% Loop through each pattern for this clause. -bsm_ensure_no_partition_2([#c_binary{}=Where|_], 1, _, Vstate, State) -> - case State of - before when Vstate =:= simple_vars -> within; - before -> bsm_problem(Where, Vstate); - within when Vstate =:= simple_vars -> within; - within -> bsm_problem(Where, Vstate) - end; -bsm_ensure_no_partition_2([#c_alias{}=Alias|_], 1, N, Vstate, State) -> +bsm_ensure_no_partition_2([#c_binary{}|_], _, _State) -> + within; +bsm_ensure_no_partition_2([#c_alias{}=Alias|_], N, State) -> %% Retrieve the real pattern that the alias refers to and check that. P = bsm_real_pattern(Alias), - bsm_ensure_no_partition_2([P], 1, N, Vstate, State); -bsm_ensure_no_partition_2([_|_], 1, _, _Vstate, before=State) -> + bsm_ensure_no_partition_2([P], N, State); +bsm_ensure_no_partition_2([_|_], _, before=State) -> %% No binary matching yet - therefore no partition. State; -bsm_ensure_no_partition_2([P|_], 1, _, Vstate, State) -> +bsm_ensure_no_partition_2([P|_], _, State) -> case bsm_could_match_binary(P) of false -> - %% If clauses can be freely arranged (Vstate =:= simple_vars), - %% a clause that cannot match a binary will not partition the clause. - %% Example: - %% - %% a(Var, <<>>) -> ... - %% a(Var, []) -> ... - %% a(Var, <<B>>) -> ... - %% - %% But if the clauses can't be freely rearranged, as in - %% - %% b(Var, <<X>>) -> ... - %% b(1, 2) -> ... - %% - %% we do have a problem. - %% - case Vstate of - simple_vars -> State; - _ -> bsm_problem(P, Vstate) - end; + State; true -> %% The pattern P *may* match a binary, so we must update the state. %% (P must be a variable.) - case State of - within -> 'after'; - 'after' -> 'after' - end - end; -bsm_ensure_no_partition_2([#c_var{name=V}|Ps], N, G, Vstate, S) -> - case core_lib:is_var_used(V, G) of - false -> - bsm_ensure_no_partition_2(Ps, N-1, G, Vstate, S); - true -> - bsm_ensure_no_partition_2(Ps, N-1, G, bin_left_var_used_in_guard, S) - end; -bsm_ensure_no_partition_2([_|Ps], N, G, _, S) -> - bsm_ensure_no_partition_2(Ps, N-1, G, bin_argument_order, S). + 'after' + end. -bsm_ensure_no_partition_after([#c_clause{pats=Ps}=C|Cs], Pos) -> - case nth(Pos, Ps) of - #c_var{} -> - bsm_ensure_no_partition_after(Cs, Pos); - _ -> - bsm_problem(C, bin_partition) +bsm_ensure_no_partition_after([#c_clause{pats=Ps}=C|Cs]) -> + case Ps of + [#c_var{}|_] -> + bsm_ensure_no_partition_after(Cs); + _ -> + bsm_problem(C, bin_partition) end; -bsm_ensure_no_partition_after([], _) -> ok. +bsm_ensure_no_partition_after([]) -> ok. bsm_could_match_binary(#c_alias{pat=P}) -> bsm_could_match_binary(P); bsm_could_match_binary(#c_cons{}) -> false; diff --git a/lib/compiler/src/sys_core_dsetel.erl b/lib/compiler/src/sys_core_dsetel.erl index bd3eeae238..9e2df69b33 100644 --- a/lib/compiler/src/sys_core_dsetel.erl +++ b/lib/compiler/src/sys_core_dsetel.erl @@ -81,8 +81,7 @@ visit_module_1([{Name,F0}|Fs], Env, Acc) -> {F,_} -> visit_module_1(Fs, Env, [{Name,F}|Acc]) catch - Class:Error -> - Stack = erlang:get_stacktrace(), + Class:Error:Stack -> #c_var{name={Func,Arity}} = Name, io:fwrite("Function: ~w/~w\n", [Func,Arity]), erlang:raise(Class, Error, Stack) diff --git a/lib/compiler/src/sys_core_fold.erl b/lib/compiler/src/sys_core_fold.erl index d73060fb7e..a13bdedaf9 100644 --- a/lib/compiler/src/sys_core_fold.erl +++ b/lib/compiler/src/sys_core_fold.erl @@ -108,25 +108,36 @@ module(#c_module{defs=Ds0}=Mod, Opts) -> put(no_inline_list_funcs, not member(inline_list_funcs, Opts)), - case get(new_var_num) of - undefined -> put(new_var_num, 0); - _ -> ok - end, init_warnings(), Ds1 = [function_1(D) || D <- Ds0], + erase(new_var_num), erase(no_inline_list_funcs), {ok,Mod#c_module{defs=Ds1},get_warnings()}. function_1({#c_var{name={F,Arity}}=Name,B0}) -> + %% Find a suitable starting value for the variable counter. Note + %% that this pass assumes that new_var_name/1 returns a variable + %% name distinct from any variable used in the entire body of + %% the function. We use integers as variable names to avoid + %% filling up the atom table when compiling huge functions. + Count = cerl_trees:next_free_variable_name(B0), + put(new_var_num, Count), try + %% Find a suitable starting value for the variable + %% counter. Note that this pass assumes that new_var_name/1 + %% returns a variable name distinct from any variable used in + %% the entire body of the function. We use integers as + %% variable names to avoid filling up the atom table when + %% compiling huge functions. + Count = cerl_trees:next_free_variable_name(B0), + put(new_var_num, Count), B = find_fixpoint(fun(Core) -> %% This must be a fun! expr(Core, value, sub_new()) end, B0, 20), {Name,B} catch - Class:Error -> - Stack = erlang:get_stacktrace(), + Class:Error:Stack -> io:fwrite("Function: ~w/~w\n", [F,Arity]), erlang:raise(Class, Error, Stack) end. @@ -146,14 +157,9 @@ find_fixpoint(OptFun, Core0, Max) -> body(Body, Sub) -> body(Body, value, Sub). -body(#c_values{anno=A,es=Es0}, Ctxt, Sub) -> - Es1 = expr_list(Es0, Ctxt, Sub), - case Ctxt of - value -> - #c_values{anno=A,es=Es1}; - effect -> - make_effect_seq(Es1, Sub) - end; +body(#c_values{anno=A,es=Es0}, value, Sub) -> + Es1 = expr_list(Es0, value, Sub), + #c_values{anno=A,es=Es1}; body(E, Ctxt, Sub) -> ?ASSERT(verify_scope(E, Sub)), expr(E, Ctxt, Sub). @@ -208,6 +214,8 @@ opt_guard_try(#c_case{clauses=Cs}=Term) -> Term#c_case{clauses=opt_guard_try_list(Cs)}; opt_guard_try(#c_clause{body=B0}=Term) -> Term#c_clause{body=opt_guard_try(B0)}; +opt_guard_try(#c_let{vars=[],arg=#c_values{es=[]},body=B}) -> + B; opt_guard_try(#c_let{arg=Arg,body=B0}=Term) -> case opt_guard_try(B0) of #c_literal{}=B -> @@ -314,9 +322,15 @@ expr(#c_seq{arg=Arg0,body=B0}=Seq0, Ctxt, Sub) -> false -> %% Arg cannot be "values" here - only a single value %% make sense here. - case is_safe_simple(Arg, Sub) of - true -> B1; - false -> Seq0#c_seq{arg=Arg,body=B1} + case {Ctxt,is_safe_simple(Arg, Sub)} of + {effect,true} -> B1; + {effect,false} -> + case is_safe_simple(B1, Sub) of + true -> Arg; + false -> Seq0#c_seq{arg=Arg,body=B1} + end; + {value,true} -> B1; + {value,false} -> Seq0#c_seq{arg=Arg,body=B1} end end; expr(#c_let{}=Let0, Ctxt, Sub) -> @@ -380,10 +394,7 @@ expr(#c_case{}=Case0, Ctxt, Sub) -> Case = Case1#c_case{arg=Arg2,clauses=Cs2}, warn_no_clause_match(Case1, Case), Expr = eval_case(Case, Sub), - case move_case_into_arg(Case, Sub) of - impossible -> Expr; - Other -> Other - end; + move_case_into_arg(Expr, Sub); Other -> expr(Other, Ctxt, Sub) end; @@ -392,14 +403,15 @@ expr(#c_receive{clauses=Cs0,timeout=T0,action=A0}=Recv, Ctxt, Sub) -> T1 = expr(T0, value, Sub), A1 = body(A0, Ctxt, Sub), Recv#c_receive{clauses=Cs1,timeout=T1,action=A1}; -expr(#c_apply{anno=Anno,op=Op0,args=As0}=App, _, Sub) -> +expr(#c_apply{anno=Anno,op=Op0,args=As0}=Apply0, _, Sub) -> Op1 = expr(Op0, value, Sub), As1 = expr_list(As0, value, Sub), - case cerl:is_data(Op1) of + case cerl:is_data(Op1) andalso not is_literal_fun(Op1) of false -> - App#c_apply{op=Op1,args=As1}; + Apply = Apply0#c_apply{op=Op1,args=As1}, + fold_apply(Apply, Op1, As1); true -> - add_warning(App, invalid_call), + add_warning(Apply0, invalid_call), Err = #c_call{anno=Anno, module=#c_literal{val=erlang}, name=#c_literal{val=error}, @@ -415,9 +427,20 @@ expr(#c_call{module=M0,name=N0}=Call0, Ctxt, Sub) -> no -> call(Call, M1, N1, Sub); {yes,Seq} -> expr(Seq, Ctxt, Sub) end; +expr(#c_primop{name=#c_literal{val=build_stacktrace}}, effect, _Sub) -> + void(); expr(#c_primop{args=As0}=Prim, _, Sub) -> As1 = expr_list(As0, value, Sub), Prim#c_primop{args=As1}; +expr(#c_catch{anno=Anno,body=B}, effect, Sub) -> + %% When the return value of the 'catch' is ignored, we can replace it + %% with a try/catch to avoid building a stack trace when an exception + %% occurs. + Var = #c_var{name='catch_value'}, + Evs = [#c_var{name='Class'},#c_var{name='Reason'},#c_var{name='Stk'}], + Try = #c_try{anno=Anno,arg=B,vars=[Var],body=Var, + evars=Evs,handler=void()}, + expr(Try, effect, Sub); expr(#c_catch{body=B0}=Catch, _, Sub) -> %% We can remove catch if the value is simple B1 = body(B0, value, Sub), @@ -479,6 +502,9 @@ bitstr_list(Es, Sub) -> bitstr(#c_bitstr{val=Val,size=Size}=BinSeg, Sub) -> BinSeg#c_bitstr{val=expr(Val, Sub),size=expr(Size, value, Sub)}. +is_literal_fun(#c_literal{val=F}) -> is_function(F); +is_literal_fun(_) -> false. + %% is_safe_simple(Expr, Sub) -> true | false. %% A safe simple cannot fail with badarg and is safe to use %% in a guard. @@ -743,6 +769,25 @@ make_effect_seq([H|T], Sub) -> end; make_effect_seq([], _) -> void(). +%% fold_apply(Apply, LiteraFun, Args) -> Apply. +%% Replace an apply of a literal external fun with a call. + +fold_apply(Apply, #c_literal{val=Fun}, Args) when is_function(Fun) -> + {module,Mod} = erlang:fun_info(Fun, module), + {name,Name} = erlang:fun_info(Fun, name), + {arity,Arity} = erlang:fun_info(Fun, arity), + if + Arity =:= length(Args) -> + #c_call{anno=Apply#c_apply.anno, + module=#c_literal{val=Mod}, + name=#c_literal{val=Name}, + args=Args}; + true -> + Apply + end; +fold_apply(Apply, _, _) -> Apply. + + %% Handling remote calls. The module/name fields have been processed. call(#c_call{args=As}=Call, #c_literal{val=M}=M0, #c_literal{val=N}=N0, Sub) -> @@ -780,6 +825,8 @@ fold_call(Call, #c_literal{val=M}, #c_literal{val=F}, Args, Sub) -> fold_call_1(Call, M, F, Args, Sub); fold_call(Call, _M, _N, _Args, _Sub) -> Call. +fold_call_1(Call, erlang, apply, [Fun,Args], _) -> + simplify_fun_apply(Call, Fun, Args); fold_call_1(Call, erlang, apply, [Mod,Func,Args], _) -> simplify_apply(Call, Mod, Func, Args); fold_call_1(Call, Mod, Name, Args, Sub) -> @@ -1088,24 +1135,38 @@ eval_failure(Call, Reason) -> %% Simplify an apply/3 to a call if the number of arguments %% are known at compile time. -simplify_apply(Call, Mod, Func, Args) -> +simplify_apply(Call, Mod, Func, Args0) -> case is_atom_or_var(Mod) andalso is_atom_or_var(Func) of - true -> simplify_apply_1(Args, Call, Mod, Func, []); - false -> Call + true -> + case get_fixed_args(Args0, []) of + error -> + Call; + {ok,Args} -> + Call#c_call{module=Mod,name=Func,args=Args} + end; + false -> + Call end. - -simplify_apply_1(#c_literal{val=MoreArgs0}, Call, Mod, Func, Args) - when length(MoreArgs0) >= 0 -> - MoreArgs = [#c_literal{val=Arg} || Arg <- MoreArgs0], - Call#c_call{module=Mod,name=Func,args=reverse(Args, MoreArgs)}; -simplify_apply_1(#c_cons{hd=Arg,tl=T}, Call, Mod, Func, Args) -> - simplify_apply_1(T, Call, Mod, Func, [Arg|Args]); -simplify_apply_1(_, Call, _, _, _) -> Call. - is_atom_or_var(#c_literal{val=Atom}) when is_atom(Atom) -> true; is_atom_or_var(#c_var{}) -> true; is_atom_or_var(_) -> false. +simplify_fun_apply(#c_call{anno=Anno}=Call, Fun, Args0) -> + case get_fixed_args(Args0, []) of + error -> + Call; + {ok,Args} -> + #c_apply{anno=Anno,op=Fun,args=Args} + end. + +get_fixed_args(#c_literal{val=MoreArgs0}, Args) + when length(MoreArgs0) >= 0 -> + MoreArgs = [#c_literal{val=Arg} || Arg <- MoreArgs0], + {ok,reverse(Args, MoreArgs)}; +get_fixed_args(#c_cons{hd=Arg,tl=T}, Args) -> + get_fixed_args(T, [Arg|Args]); +get_fixed_args(_, _) -> error. + %% clause(Clause, Cepxr, Context, Sub) -> Clause. clause(#c_clause{pats=Ps0}=Cl, Cexpr, Ctxt, Sub0) -> @@ -2146,7 +2207,7 @@ make_var(A) -> make_var_name() -> N = get(new_var_num), put(new_var_num, N+1), - list_to_atom("@f"++integer_to_list(N)). + N. letify(Bs, Body) -> Ann = cerl:get_ann(Body), @@ -2422,16 +2483,10 @@ move_let_into_expr(#c_let{vars=InnerVs0,body=InnerBody0}=Inner, Outer#c_let{vars=OuterVs,arg=Arg, body=Inner#c_let{vars=InnerVs,arg=OuterBody,body=InnerBody}}; move_let_into_expr(#c_let{vars=Lvs0,body=Lbody0}=Let, - #c_case{arg=Cexpr0,clauses=[Ca0,Cb0|Cs]}=Case, Sub0) -> - %% Test if there are no more clauses than Ca0 and Cb0, or if - %% Cb0 is guaranteed to match. - TwoClauses = Cs =:= [] orelse - case Cb0 of - #c_clause{pats=[#c_var{}],guard=#c_literal{val=true}} -> true; - _ -> false - end, - case {TwoClauses,is_failing_clause(Ca0),is_failing_clause(Cb0)} of - {true,false,true} -> + #c_case{arg=Cexpr0,clauses=[Ca0|Cs0]}=Case, Sub0) -> + case not is_failing_clause(Ca0) andalso + are_all_failing_clauses(Cs0) of + true -> %% let <Lvars> = case <Case-expr> of %% <Cpats> -> <Clause-body>; %% <OtherCpats> -> erlang:error(...) @@ -2467,8 +2522,8 @@ move_let_into_expr(#c_let{vars=Lvs0,body=Lbody0}=Let, body=Lbody}, Ca = Ca0#c_clause{pats=CaPats,guard=G,body=B}, - Cb = clause(Cb0, Cexpr, value, Sub0), - Case#c_case{arg=Cexpr,clauses=[Ca,Cb]} + Cs = [clause(C, Cexpr, value, Sub0) || C <- Cs0], + Case#c_case{arg=Cexpr,clauses=[Ca|Cs]} catch nomatch -> %% This is not a defeat. The code will eventually @@ -2476,7 +2531,7 @@ move_let_into_expr(#c_let{vars=Lvs0,body=Lbody0}=Let, %% optimizations done in this module. impossible end; - {_,_,_} -> impossible + false -> impossible end; move_let_into_expr(#c_let{vars=Lvs0,body=Lbody0}=Let, #c_seq{arg=Sarg0,body=Sbody0}=Seq, Sub0) -> @@ -2499,9 +2554,78 @@ move_let_into_expr(#c_let{vars=Lvs0,body=Lbody0}=Let, body=Lbody}}; move_let_into_expr(_Let, _Expr, _Sub) -> impossible. +are_all_failing_clauses(Cs) -> + all(fun is_failing_clause/1, Cs). + is_failing_clause(#c_clause{body=B}) -> will_fail(B). +%% opt_build_stacktrace(Let) -> Core. +%% If the stacktrace is *only* used in a call to erlang:raise/3, +%% there is no need to build a cooked stackframe using build_stacktrace/1. + +opt_build_stacktrace(#c_let{vars=[#c_var{name=Cooked}], + arg=#c_primop{name=#c_literal{val=build_stacktrace}, + args=[RawStk]}, + body=Body}=Let) -> + case Body of + #c_call{module=#c_literal{val=erlang}, + name=#c_literal{val=raise}, + args=[Class,Exp,#c_var{name=Cooked}]} -> + %% The stacktrace is only used in a call to erlang:raise/3. + %% There is no need to build the stacktrace. Replace the + %% call to erlang:raise/3 with the the raw_raise/3 instruction, + %% which will use a raw stacktrace. + #c_primop{name=#c_literal{val=raw_raise}, + args=[Class,Exp,RawStk]}; + #c_let{vars=[#c_var{name=V}],arg=Arg,body=B0} when V =/= Cooked -> + case core_lib:is_var_used(Cooked, Arg) of + false -> + %% The built stacktrace is not used in the argument, + %% so we can sink the building of the stacktrace into + %% the body of the let. + B = opt_build_stacktrace(Let#c_let{body=B0}), + Body#c_let{body=B}; + true -> + Let + end; + #c_seq{arg=Arg,body=B0} -> + case core_lib:is_var_used(Cooked, Arg) of + false -> + %% The built stacktrace is not used in the argument, + %% so we can sink the building of the stacktrace into + %% the body of the sequence. + B = opt_build_stacktrace(Let#c_let{body=B0}), + Body#c_seq{body=B}; + true -> + Let + end; + #c_case{arg=Arg,clauses=Cs0} -> + case core_lib:is_var_used(Cooked, Arg) orelse + is_used_in_any_guard(Cooked, Cs0) of + false -> + %% The built stacktrace is not used in the argument, + %% so we can sink the building of the stacktrace into + %% each arm of the case. + Cs = [begin + B = opt_build_stacktrace(Let#c_let{body=B0}), + C#c_clause{body=B} + end || #c_clause{body=B0}=C <- Cs0], + Body#c_case{clauses=Cs}; + true -> + Let + end; + _ -> + Let + end; +opt_build_stacktrace(Expr) -> + Expr. + +is_used_in_any_guard(V, Cs) -> + any(fun(#c_clause{guard=G}) -> + core_lib:is_var_used(V, G) + end, Cs). + %% opt_case_in_let(Let) -> Let' %% Try to avoid building tuples that are immediately matched. %% A common pattern is: @@ -2616,9 +2740,13 @@ delay_build_expr_1(#c_receive{clauses=Cs0, timeout=Timeout, action=A0}=Rec, TypeSig) -> Cs = delay_build_cs(Cs0, TypeSig), - A = case Timeout of - #c_literal{val=infinity} -> A0; - _ -> delay_build_expr(A0, TypeSig) + A = case {Timeout,A0} of + {#c_literal{val=infinity},#c_literal{}} -> + {_Type,Arity} = TypeSig, + Es = lists:duplicate(Arity, A0), + core_lib:make_values(Es); + _ -> + delay_build_expr(A0, TypeSig) end, Rec#c_receive{clauses=Cs,action=A}; delay_build_expr_1(#c_seq{body=B0}=Seq, TypeSig) -> @@ -2653,53 +2781,94 @@ opt_simple_let_1(#c_let{vars=Vs0,body=B0}=Let, Arg0, Ctxt, Sub0) -> %% Optimise let and add new substitutions. {Vs,Args,Sub1} = let_substs(Vs0, Arg0, Sub0), BodySub = update_let_types(Vs, Args, Sub1), + Sub = Sub1#sub{v=[],s=cerl_sets:new()}, B = body(B0, Ctxt, BodySub), Arg = core_lib:make_values(Args), - opt_simple_let_2(Let, Vs, Arg, B, B0, Ctxt, Sub1). + opt_simple_let_2(Let, Vs, Arg, B, B0, Sub). -opt_simple_let_2(Let0, Vs0, Arg0, Body, PrevBody, Ctxt, Sub) -> + +%% opt_simple_let_2(Let0, Vs0, Arg0, Body, PrevBody, Ctxt, Sub) -> Core. +%% Do final simplifications of the let. +%% +%% Note that the substitutions and scope in Sub have been cleared +%% and should not be used. + +opt_simple_let_2(Let0, Vs0, Arg0, Body, PrevBody, Sub) -> case {Vs0,Arg0,Body} of - {[#c_var{name=N1}],Arg1,#c_var{name=N2}} -> - case N1 =:= N2 of - true -> - %% let <Var> = Arg in <Var> ==> Arg - Arg1; - false -> - %% let <Var> = Arg in <OtherVar> ==> seq Arg OtherVar - Arg = maybe_suppress_warnings(Arg1, Vs0, PrevBody), - #c_seq{arg=Arg,body=Body} - end; + {[#c_var{name=V}],Arg1,#c_var{name=V}} -> + %% let <Var> = Arg in <Var> ==> Arg + Arg1; {[],#c_values{es=[]},_} -> %% No variables left. Body; - {Vs,Arg1,#c_literal{}} -> - Arg = maybe_suppress_warnings(Arg1, Vs, PrevBody), - case Ctxt of - effect -> - %% Throw away the literal body. - Arg; - value -> - %% Since the variable is not used in the body, we - %% can rewrite the let to a sequence. - %% let <Var> = Arg in Literal ==> seq Arg Literal - #c_seq{arg=Arg,body=Body} - end; - {Vs,Arg1,Body} -> - %% If none of the variables are used in the body, we can - %% rewrite the let to a sequence: - %% let <Var> = Arg in BodyWithoutVar ==> - %% seq Arg BodyWithoutVar - case is_any_var_used(Vs, Body) of - false -> - Arg = maybe_suppress_warnings(Arg1, Vs, PrevBody), - #c_seq{arg=Arg,body=Body}; - true -> - Let1 = Let0#c_let{vars=Vs,arg=Arg1,body=Body}, - opt_bool_case_in_let(Let1, Sub) + {[#c_var{name=V}=Var|Vars]=Vars0,Arg1,Body} -> + case core_lib:is_var_used(V, Body) of + false when Vars =:= [] -> + %% If the variable is not used in the body, we can + %% rewrite the let to a sequence: + %% let <Var> = Arg in BodyWithoutVar ==> + %% seq Arg BodyWithoutVar + Arg = maybe_suppress_warnings(Arg1, Var, PrevBody), + #c_seq{arg=Arg,body=Body}; + false -> + %% There are multiple values returned by the argument + %% and the first value is not used (this is a 'case' + %% with exported variables, but the return value is + %% ignored). We can remove the first variable and the + %% the first value returned from the 'let' argument. + Arg2 = remove_first_value(Arg1, Sub), + Let1 = Let0#c_let{vars=Vars,arg=Arg2,body=Body}, + post_opt_let(Let1, Sub); + true -> + Let1 = Let0#c_let{vars=Vars0,arg=Arg1,body=Body}, + post_opt_let(Let1, Sub) end end. -%% maybe_suppress_warnings(Arg, [#c_var{}], PreviousBody) -> Arg' +%% post_opt_let(Let, Sub) +%% Final optimizations of the let. +%% +%% Note that the substitutions and scope in Sub have been cleared +%% and should not be used. + +post_opt_let(Let0, Sub) -> + Let1 = opt_bool_case_in_let(Let0, Sub), + opt_build_stacktrace(Let1). + + +%% remove_first_value(Core0, Sub) -> Core. +%% Core0 is an expression that returns at least two values. +%% Remove the first value returned from Core0. + +remove_first_value(#c_values{es=[V|Vs]}, Sub) -> + Values = core_lib:make_values(Vs), + case is_safe_simple(V, Sub) of + false -> + #c_seq{arg=V,body=Values}; + true -> + Values + end; +remove_first_value(#c_case{clauses=Cs0}=Core, Sub) -> + Cs = remove_first_value_cs(Cs0, Sub), + Core#c_case{clauses=Cs}; +remove_first_value(#c_receive{clauses=Cs0,action=Act0}=Core, Sub) -> + Cs = remove_first_value_cs(Cs0, Sub), + Act = remove_first_value(Act0, Sub), + Core#c_receive{clauses=Cs,action=Act}; +remove_first_value(#c_let{body=B}=Core, Sub) -> + Core#c_let{body=remove_first_value(B, Sub)}; +remove_first_value(#c_seq{body=B}=Core, Sub) -> + Core#c_seq{body=remove_first_value(B, Sub)}; +remove_first_value(#c_primop{}=Core, _Sub) -> + Core; +remove_first_value(#c_call{}=Core, _Sub) -> + Core. + +remove_first_value_cs(Cs, Sub) -> + [C#c_clause{body=remove_first_value(B, Sub)} || + #c_clause{body=B}=C <- Cs]. + +%% maybe_suppress_warnings(Arg, #c_var{}, PreviousBody) -> Arg' %% Try to suppress false warnings when a variable is not used. %% For instance, we don't expect a warning for useless building in: %% @@ -2710,12 +2879,12 @@ opt_simple_let_2(Let0, Vs0, Arg0, Body, PrevBody, Ctxt, Sub) -> %% referenced in the original unoptimized code. If they were, we will %% consider the warning false and suppress it. -maybe_suppress_warnings(Arg, Vs, PrevBody) -> +maybe_suppress_warnings(Arg, #c_var{name=V}, PrevBody) -> case should_suppress_warning(Arg) of true -> Arg; %Already suppressed. false -> - case is_any_var_used(Vs, PrevBody) of + case core_lib:is_var_used(V, PrevBody) of true -> suppress_warning([Arg]); false -> @@ -2804,7 +2973,7 @@ move_case_into_arg(#c_case{arg=#c_case{arg=OuterArg, Outer#c_case{arg=OuterArg, clauses=[OuterCa,OuterCb]}; false -> - impossible + Inner0 end; move_case_into_arg(#c_case{arg=#c_seq{arg=OuterArg,body=InnerArg}=Outer, clauses=InnerClauses}=Inner, _Sub) -> @@ -2820,15 +2989,8 @@ move_case_into_arg(#c_case{arg=#c_seq{arg=OuterArg,body=InnerArg}=Outer, %% Outer#c_seq{arg=OuterArg, body=Inner#c_case{arg=InnerArg,clauses=InnerClauses}}; -move_case_into_arg(_, _) -> - impossible. - -is_any_var_used([#c_var{name=V}|Vs], Expr) -> - case core_lib:is_var_used(V, Expr) of - false -> is_any_var_used(Vs, Expr); - true -> true - end; -is_any_var_used([], _) -> false. +move_case_into_arg(Expr, _) -> + Expr. %%% %%% Retrieving information about types. diff --git a/lib/compiler/src/v3_codegen.erl b/lib/compiler/src/v3_codegen.erl index 47c1567f10..8e73b613a0 100644 --- a/lib/compiler/src/v3_codegen.erl +++ b/lib/compiler/src/v3_codegen.erl @@ -19,25 +19,6 @@ %% %% Purpose : Code generator for Beam. -%% The following assumptions have been made: -%% -%% 1. Matches, i.e. things with {match,M,Ret} wrappers, only return -%% values; no variables are exported. If the match would have returned -%% extra variables then these have been transformed to multiple return -%% values. -%% -%% 2. All BIF's called in guards are gc-safe so there is no need to -%% put thing on the stack in the guard. While this would in principle -%% work it would be difficult to keep track of the stack depth when -%% trimming. -%% -%% The code generation uses variable lifetime information added by -%% the v3_life module to save variables, allocate registers and -%% move registers to the stack when necessary. -%% -%% We try to use a consistent variable name scheme throughout. The -%% StackReg record is always called Bef,Int<n>,Aft. - -module(v3_codegen). %% The main interface. @@ -45,12 +26,14 @@ -import(lists, [member/2,keymember/3,keysort/2,keydelete/3, append/1,flatmap/2,filter/2,foldl/3,foldr/3,mapfoldl/3, - sort/1,reverse/1,reverse/2]). --import(v3_life, [vdb_find/2]). + sort/1,reverse/1,reverse/2,map/2]). +-import(ordsets, [add_element/2,intersection/2,union/2]). -%%-compile([export_all]). +-include("v3_kernel.hrl"). --include("v3_life.hrl"). +%% These are not defined in v3_kernel.hrl. +get_kanno(Kthing) -> element(2, Kthing). +set_kanno(Kthing, Anno) -> setelement(2, Kthing, Anno). %% Main codegen structure. -record(cg, {lcount=1, %Label counter @@ -61,38 +44,400 @@ functable=#{}, %Map of local functions: {Name,Arity}=>Label in_catch=false, %Inside a catch or not. need_frame, %Need a stack frame. - ultimate_failure %Label for ultimate match failure. - }). + ultimate_failure, %Label for ultimate match failure. + ctx %Match context. + }). %% Stack/register state record. -record(sr, {reg=[], %Register table stk=[], %Stack table - res=[]}). %Reserved regs: [{reserved,I,V}] + res=[]}). %Registers to reserve + +%% Internal records. +-record(cg_need_heap, {anno=[] :: term(), + h=0 :: integer()}). +-record(cg_block, {anno=[] :: term(), + es=[] :: [term()]}). --type life_module() :: {module(),_,_,[_]}. +-type vdb_entry() :: {atom(),non_neg_integer(),non_neg_integer()}. --spec module(life_module(), [compile:option()]) -> {'ok',beam_asm:module_code()}. +-record(l, {i=0 :: non_neg_integer(), %Op number + vdb=[] :: [vdb_entry()], %Variable database + a=[] :: [term()]}). %Core annotation -module({Mod,Exp,Attr,Forms}, _Options) -> - {Fs,St} = functions(Forms, {atom,Mod}), - {ok,{Mod,Exp,Attr,Fs,St#cg.lcount}}. +-spec module(#k_mdef{}, [compile:option()]) -> {'ok',beam_asm:module_code()}. + +module(#k_mdef{name=Mod,exports=Es,attributes=Attr,body=Forms}, _Opts) -> + {Asm,St} = functions(Forms, {atom,Mod}), + {ok,{Mod,Es,Attr,Asm,St#cg.lcount}}. functions(Forms, AtomMod) -> mapfoldl(fun (F, St) -> function(F, AtomMod, St) end, #cg{lcount=1}, Forms). -function({function,Name,Arity,Asm0,Vb,Vdb,Anno}, AtomMod, St0) -> +function(#k_fdef{anno=#k{a=Anno},func=Name,arity=Arity, + vars=As,body=Kb}, AtomMod, St0) -> + try + #k_match{} = Kb, %Assertion. + + %% Try to suppress the stack frame unless it is + %% really needed. + Body0 = avoid_stack_frame(Kb), + + %% Annotate kernel records with variable usage. + Vdb0 = init_vars(As), + {Body,_,Vdb} = body(Body0, 1, Vdb0), + + %% Generate the BEAM assembly code. + {Asm,EntryLabel,St} = cg_fun(Body, As, Vdb, AtomMod, + {Name,Arity}, Anno, St0), + Func = {function,Name,Arity,EntryLabel,Asm}, + {Func,St} + catch + Class:Error:Stack -> + io:fwrite("Function: ~w/~w\n", [Name,Arity]), + erlang:raise(Class, Error, Stack) + end. + + +%% avoid_stack_frame(Kernel) -> Kernel' +%% If possible, avoid setting up a stack frame. Functions +%% that only do matching, calls to guard BIFs, and tail-recursive +%% calls don't need a stack frame. + +avoid_stack_frame(#k_match{body=Body}=M) -> try - {Asm,EntryLabel,St} = cg_fun(Vb, Asm0, Vdb, AtomMod, - {Name,Arity}, Anno, St0), - Func = {function,Name,Arity,EntryLabel,Asm}, - {Func,St} + M#k_match{body=avoid_stack_frame_1(Body)} catch - Class:Error -> - Stack = erlang:get_stacktrace(), - io:fwrite("Function: ~w/~w\n", [Name,Arity]), - erlang:raise(Class, Error, Stack) + impossible -> + M end. +avoid_stack_frame_1(#k_alt{first=First0,then=Then0}=Alt) -> + First = avoid_stack_frame_1(First0), + Then = avoid_stack_frame_1(Then0), + Alt#k_alt{first=First,then=Then}; +avoid_stack_frame_1(#k_bif{op=Op}=Bif) -> + case Op of + #k_internal{} -> + %% Most internal BIFs clobber the X registers. + throw(impossible); + _ -> + Bif + end; +avoid_stack_frame_1(#k_break{anno=Anno,args=Args}) -> + #k_guard_break{anno=Anno,args=Args}; +avoid_stack_frame_1(#k_guard_break{}=Break) -> + Break; +avoid_stack_frame_1(#k_enter{}=Enter) -> + %% Tail-recursive calls don't need a stack frame. + Enter; +avoid_stack_frame_1(#k_guard{clauses=Cs0}=Guard) -> + Cs = avoid_stack_frame_list(Cs0), + Guard#k_guard{clauses=Cs}; +avoid_stack_frame_1(#k_guard_clause{guard=G0,body=B0}=C) -> + G = avoid_stack_frame_1(G0), + B = avoid_stack_frame_1(B0), + C#k_guard_clause{guard=G,body=B}; +avoid_stack_frame_1(#k_match{anno=A,vars=Vs,body=B0,ret=Ret}) -> + %% Use #k_guard_match{} instead to avoid saving the X registers + %% to the stack before matching. + B = avoid_stack_frame_1(B0), + #k_guard_match{anno=A,vars=Vs,body=B,ret=Ret}; +avoid_stack_frame_1(#k_guard_match{body=B0}=M) -> + B = avoid_stack_frame_1(B0), + M#k_guard_match{body=B}; +avoid_stack_frame_1(#k_protected{arg=Arg0}=Prot) -> + Arg = avoid_stack_frame_1(Arg0), + Prot#k_protected{arg=Arg}; +avoid_stack_frame_1(#k_put{}=Put) -> + Put; +avoid_stack_frame_1(#k_return{}=Ret) -> + Ret; +avoid_stack_frame_1(#k_select{var=#k_var{anno=Vanno},types=Types0}=Select) -> + case member(reuse_for_context, Vanno) of + false -> + Types = avoid_stack_frame_list(Types0), + Select#k_select{types=Types}; + true -> + %% Including binary patterns that overwrite the register containing + %% the binary with the match context may not be safe. For example, + %% bs_match_SUITE:bin_tail_e/1 with inlining will be rejected by + %% beam_validator. + %% + %% Essentially the following code is produced: + %% + %% bs_match {x,0} => {x,0} + %% ... + %% bs_match {x,0} => {x,1} %% ILLEGAL + %% + %% A bs_match instruction will only accept a match context as the + %% source operand if the source and destination registers are the + %% the same (as in the first bs_match instruction above). + %% The second bs_match instruction is therefore illegal. + %% + %% This situation is avoided if there is a stack frame: + %% + %% move {x,0} => {y,0} + %% bs_match {x,0} => {x,0} + %% ... + %% bs_match {y,0} => {x,1} %% LEGAL + %% + throw(impossible) + end; +avoid_stack_frame_1(#k_seq{arg=#k_call{anno=Anno,op=Op}=Call, + body=#k_break{args=BrArgs0}}=Seq) -> + case Op of + #k_remote{mod=#k_atom{val=Mod}, + name=#k_atom{val=Name}, + arity=Arity} -> + case erl_bifs:is_exit_bif(Mod, Name, Arity) of + false -> + %% Will clobber X registers. Must have a stack frame. + throw(impossible); + true -> + %% The call to this BIF will never return. It is safe + %% to suppress the stack frame. + Bif = #k_bif{anno=Anno, + op=#k_internal{name=guard_error,arity=1}, + args=[Call],ret=[]}, + BrArgs = lists:duplicate(length(BrArgs0), #k_nil{}), + GB = #k_guard_break{anno=#k{us=[],ns=[],a=[]},args=BrArgs}, + Seq#k_seq{arg=Bif,body=GB} + end; + _ -> + %% Will clobber X registers. Must have a stack frame. + throw(impossible) + end; +avoid_stack_frame_1(#k_seq{arg=A0,body=B0}=Seq) -> + A = avoid_stack_frame_1(A0), + B = avoid_stack_frame_1(B0), + Seq#k_seq{arg=A,body=B}; +avoid_stack_frame_1(#k_test{}=Test) -> + Test; +avoid_stack_frame_1(#k_type_clause{values=Values0}=TC) -> + Values = avoid_stack_frame_list(Values0), + TC#k_type_clause{values=Values}; +avoid_stack_frame_1(#k_val_clause{body=B0}=VC) -> + B = avoid_stack_frame_1(B0), + VC#k_val_clause{body=B}; +avoid_stack_frame_1(_Body) -> + throw(impossible). + +avoid_stack_frame_list([H|T]) -> + [avoid_stack_frame_1(H)|avoid_stack_frame_list(T)]; +avoid_stack_frame_list([]) -> []. + + +%% This pass creates beam format annotated with variable lifetime +%% information. Each thing is given an index and for each variable we +%% store the first and last index for its occurrence. The variable +%% database, VDB, attached to each thing is only relevant internally +%% for that thing. +%% +%% For nested things like matches the numbering continues locally and +%% the VDB for that thing refers to the variable usage within that +%% thing. Variables which live through a such a thing are internally +%% given a very large last index. Internally the indexes continue +%% after the index of that thing. This creates no problems as the +%% internal variable info never escapes and externally we only see +%% variable which are alive both before or after. +%% +%% This means that variables never "escape" from a thing and the only +%% way to get values from a thing is to "return" them, with 'break' or +%% 'return'. Externally these values become the return values of the +%% thing. This is no real limitation as most nested things have +%% multiple threads so working out a common best variable usage is +%% difficult. + +%% body(Kbody, I, Vdb) -> {[Expr],MaxI,Vdb}. +%% Handle a body. + +body(#k_seq{arg=Ke,body=Kb}, I, Vdb0) -> + %%ok = io:fwrite("life ~w:~p~n", [?LINE,{Ke,I,Vdb0}]), + A = get_kanno(Ke), + Vdb1 = use_vars(union(A#k.us, A#k.ns), I, Vdb0), + {Es,MaxI,Vdb2} = body(Kb, I+1, Vdb1), + E = expr(Ke, I, Vdb2), + {[E|Es],MaxI,Vdb2}; +body(Ke, I, Vdb0) -> + %%ok = io:fwrite("life ~w:~p~n", [?LINE,{Ke,I,Vdb0}]), + A = get_kanno(Ke), + Vdb1 = use_vars(union(A#k.us, A#k.ns), I, Vdb0), + E = expr(Ke, I, Vdb1), + {[E],I,Vdb1}. + +%% expr(Kexpr, I, Vdb) -> Expr. + +expr(#k_test{anno=A}=Test, I, _Vdb) -> + Test#k_test{anno=#l{i=I,a=A#k.a}}; +expr(#k_call{anno=A}=Call, I, _Vdb) -> + Call#k_call{anno=#l{i=I,a=A#k.a}}; +expr(#k_enter{anno=A}=Enter, I, _Vdb) -> + Enter#k_enter{anno=#l{i=I,a=A#k.a}}; +expr(#k_bif{anno=A}=Bif, I, _Vdb) -> + Bif#k_bif{anno=#l{i=I,a=A#k.a}}; +expr(#k_match{anno=A,body=Kb,ret=Rs}, I, Vdb) -> + %% Work out imported variables which need to be locked. + Mdb = vdb_sub(I, I+1, Vdb), + M = match(Kb, A#k.us, I+1, Mdb), + L = #l{i=I,vdb=use_vars(A#k.us, I+1, Mdb),a=A#k.a}, + #k_match{anno=L,body=M,ret=Rs}; +expr(#k_guard_match{anno=A,body=Kb,ret=Rs}, I, Vdb) -> + %% Work out imported variables which need to be locked. + Mdb = vdb_sub(I, I+1, Vdb), + M = match(Kb, A#k.us, I+1, Mdb), + L = #l{i=I,vdb=use_vars(A#k.us, I+1, Mdb),a=A#k.a}, + #k_guard_match{anno=L,body=M,ret=Rs}; +expr(#k_protected{}=Protected, I, Vdb) -> + protected(Protected, I, Vdb); +expr(#k_try{anno=A,arg=Ka,vars=Vs,body=Kb,evars=Evs,handler=Kh}=Try, I, Vdb) -> + %% Lock variables that are alive before the catch and used afterwards. + %% Don't lock variables that are only used inside the try. + Tdb0 = vdb_sub(I, I+1, Vdb), + %% This is the tricky bit. Lock variables in Arg that are used in + %% the body and handler. Add try tag 'variable'. + Ab = get_kanno(Kb), + Ah = get_kanno(Kh), + Tdb1 = use_vars(union(Ab#k.us, Ah#k.us), I+3, Tdb0), + Tdb2 = vdb_sub(I, I+2, Tdb1), + Vnames = fun (Kvar) -> Kvar#k_var.name end, %Get the variable names + {Aes,_,Adb} = body(Ka, I+2, add_var({catch_tag,I+1}, I+1, locked, Tdb2)), + {Bes,_,Bdb} = body(Kb, I+4, new_vars(sort(map(Vnames, Vs)), I+3, Tdb2)), + {Hes,_,Hdb} = body(Kh, I+4, new_vars(sort(map(Vnames, Evs)), I+3, Tdb2)), + L = #l{i=I,vdb=Tdb1,a=A#k.a}, + Try#k_try{anno=L, + arg=#cg_block{es=Aes,anno=#l{i=I+1,vdb=Adb,a=[]}}, + vars=Vs,body=#cg_block{es=Bes,anno=#l{i=I+3,vdb=Bdb,a=[]}}, + evars=Evs,handler=#cg_block{es=Hes,anno=#l{i=I+3,vdb=Hdb,a=[]}}}; +expr(#k_try_enter{anno=A,arg=Ka,vars=Vs,body=Kb,evars=Evs,handler=Kh}, I, Vdb) -> + %% Lock variables that are alive before the catch and used afterwards. + %% Don't lock variables that are only used inside the try. + Tdb0 = vdb_sub(I, I+1, Vdb), + %% This is the tricky bit. Lock variables in Arg that are used in + %% the body and handler. Add try tag 'variable'. + Ab = get_kanno(Kb), + Ah = get_kanno(Kh), + Tdb1 = use_vars(union(Ab#k.us, Ah#k.us), I+3, Tdb0), + Tdb2 = vdb_sub(I, I+2, Tdb1), + Vnames = fun (Kvar) -> Kvar#k_var.name end, %Get the variable names + {Aes,_,Adb} = body(Ka, I+2, add_var({catch_tag,I+1}, I+1, 1000000, Tdb2)), + {Bes,_,Bdb} = body(Kb, I+4, new_vars(sort(map(Vnames, Vs)), I+3, Tdb2)), + {Hes,_,Hdb} = body(Kh, I+4, new_vars(sort(map(Vnames, Evs)), I+3, Tdb2)), + L = #l{i=I,vdb=Tdb1,a=A#k.a}, + #k_try_enter{anno=L, + arg=#cg_block{es=Aes,anno=#l{i=I+1,vdb=Adb,a=[]}}, + vars=Vs,body=#cg_block{es=Bes,anno=#l{i=I+3,vdb=Bdb,a=[]}}, + evars=Evs,handler=#cg_block{es=Hes,anno=#l{i=I+3,vdb=Hdb,a=[]}}}; +expr(#k_catch{anno=A,body=Kb}=Catch, I, Vdb) -> + %% Lock variables that are alive before the catch and used afterwards. + %% Don't lock variables that are only used inside the catch. + %% Add catch tag 'variable'. + Cdb0 = vdb_sub(I, I+1, Vdb), + {Es,_,Cdb1} = body(Kb, I+1, add_var({catch_tag,I}, I, locked, Cdb0)), + L = #l{i=I,vdb=Cdb1,a=A#k.a}, + Catch#k_catch{anno=L,body=#cg_block{es=Es}}; +expr(#k_receive{anno=A,var=V,body=Kb,action=Ka}=Recv, I, Vdb) -> + %% Work out imported variables which need to be locked. + Rdb = vdb_sub(I, I+1, Vdb), + M = match(Kb, add_element(V#k_var.name, A#k.us), I+1, + new_vars([V#k_var.name], I, Rdb)), + {Tes,_,Adb} = body(Ka, I+1, Rdb), + Le = #l{i=I,vdb=use_vars(A#k.us, I+1, Vdb),a=A#k.a}, + Recv#k_receive{anno=Le,body=M, + action=#cg_block{anno=#l{i=I+1,vdb=Adb,a=[]},es=Tes}}; +expr(#k_receive_accept{anno=A}, I, _Vdb) -> + #k_receive_accept{anno=#l{i=I,a=A#k.a}}; +expr(#k_receive_next{anno=A}, I, _Vdb) -> + #k_receive_next{anno=#l{i=I,a=A#k.a}}; +expr(#k_put{anno=A}=Put, I, _Vdb) -> + Put#k_put{anno=#l{i=I,a=A#k.a}}; +expr(#k_break{anno=A}=Break, I, _Vdb) -> + Break#k_break{anno=#l{i=I,a=A#k.a}}; +expr(#k_guard_break{anno=A}=Break, I, _Vdb) -> + Break#k_guard_break{anno=#l{i=I,a=A#k.a}}; +expr(#k_return{anno=A}=Ret, I, _Vdb) -> + Ret#k_return{anno=#l{i=I,a=A#k.a}}. + +%% protected(Kprotected, I, Vdb) -> Protected. +%% Only used in guards. + +protected(#k_protected{anno=A,arg=Ts}=Prot, I, Vdb) -> + %% Lock variables that are alive before try and used afterwards. + %% Don't lock variables that are only used inside the protected + %% expression. + Pdb0 = vdb_sub(I, I+1, Vdb), + {T,MaxI,Pdb1} = body(Ts, I+1, Pdb0), + Pdb2 = use_vars(A#k.ns, MaxI+1, Pdb1), %Save "return" values + Prot#k_protected{arg=T,anno=#l{i=I,a=A#k.a,vdb=Pdb2}}. + +%% match(Kexpr, [LockVar], I, Vdb) -> Expr. +%% Convert match tree to old format. + +match(#k_alt{anno=A,first=Kf,then=Kt}, Ls, I, Vdb0) -> + Vdb1 = use_vars(union(A#k.us, Ls), I, Vdb0), + F = match(Kf, Ls, I+1, Vdb1), + T = match(Kt, Ls, I+1, Vdb1), + #k_alt{anno=[],first=F,then=T}; +match(#k_select{anno=A,types=Kts}=Select, Ls, I, Vdb0) -> + Vdb1 = use_vars(union(A#k.us, Ls), I, Vdb0), + Ts = [type_clause(Tc, Ls, I+1, Vdb1) || Tc <- Kts], + Select#k_select{anno=[],types=Ts}; +match(#k_guard{anno=A,clauses=Kcs}, Ls, I, Vdb0) -> + Vdb1 = use_vars(union(A#k.us, Ls), I, Vdb0), + Cs = [guard_clause(G, Ls, I+1, Vdb1) || G <- Kcs], + #k_guard{anno=[],clauses=Cs}; +match(Other, Ls, I, Vdb0) -> + Vdb1 = use_vars(Ls, I, Vdb0), + {B,_,Vdb2} = body(Other, I+1, Vdb1), + Le = #l{i=I,vdb=Vdb2,a=[]}, + #cg_block{anno=Le,es=B}. + +type_clause(#k_type_clause{anno=A,type=T,values=Kvs}, Ls, I, Vdb0) -> + %%ok = io:format("life ~w: ~p~n", [?LINE,{T,Kvs}]), + Vdb1 = use_vars(union(A#k.us, Ls), I+1, Vdb0), + Vs = [val_clause(Vc, Ls, I+1, Vdb1) || Vc <- Kvs], + #k_type_clause{anno=[],type=T,values=Vs}. + +val_clause(#k_val_clause{anno=A,val=V,body=Kb}, Ls0, I, Vdb0) -> + New = (get_kanno(V))#k.ns, + Bus = (get_kanno(Kb))#k.us, + %%ok = io:format("Ls0 = ~p, Used=~p\n New=~p, Bus=~p\n", [Ls0,Used,New,Bus]), + Ls1 = union(intersection(New, Bus), Ls0), %Lock for safety + Vdb1 = use_vars(union(A#k.us, Ls1), I+1, new_vars(New, I, Vdb0)), + B = match(Kb, Ls1, I+1, Vdb1), + Le = #l{i=I,vdb=use_vars(Bus, I+1, Vdb1),a=A#k.a}, + #k_val_clause{anno=Le,val=V,body=B}. + +guard_clause(#k_guard_clause{anno=A,guard=Kg,body=Kb}, Ls, I, Vdb0) -> + Vdb1 = use_vars(union(A#k.us, Ls), I+2, Vdb0), + Gdb = vdb_sub(I+1, I+2, Vdb1), + G = protected(Kg, I+1, Gdb), + B = match(Kb, Ls, I+2, Vdb1), + Le = #l{i=I,vdb=use_vars((get_kanno(Kg))#k.us, I+2, Vdb1),a=A#k.a}, + #k_guard_clause{anno=Le,guard=G,body=B}. + + +%% Here follows the code generator pass. +%% +%% The following assumptions have been made: +%% +%% 1. Matches, i.e. things with {match,M,Ret} wrappers, only return +%% values; no variables are exported. If the match would have returned +%% extra variables then these have been transformed to multiple return +%% values. +%% +%% 2. All BIF's called in guards are gc-safe so there is no need to +%% put thing on the stack in the guard. While this would in principle +%% work it would be difficult to keep track of the stack depth when +%% trimming. +%% +%% The code generation uses variable lifetime information added by +%% the previous pass to save variables, allocate registers and +%% move registers to the stack when necessary. +%% +%% We try to use a consistent variable name scheme throughout. The +%% StackReg record is always called Bef,Int<n>,Aft. + %% cg_fun([Lkexpr], [HeadVar], Vdb, State) -> {[Ainstr],State} cg_fun(Les, Hvs, Vdb, AtomMod, NameArity, Anno, St0) -> @@ -114,18 +459,18 @@ cg_fun(Les, Hvs, Vdb, AtomMod, NameArity, Anno, St0) -> %% Note that and 'if_end' instruction does not need any %% live x registers, so it will always be safe to jump to %% it. (We never ever expect the jump to be taken, and in - %% must functions there will never be any references to + %% most functions there will never be any references to %% the label in the first place.) %% {UltimateMatchFail,St3} = new_label(St2), %% Create initial stack/register state, clear unused arguments. - Bef = clear_dead(#sr{reg=foldl(fun ({var,V}, Reg) -> + Bef = clear_dead(#sr{reg=foldl(fun (#k_var{name=V}, Reg) -> put_reg(V, Reg) end, [], Hvs), stk=[]}, 0, Vdb), - {B,_Aft,St} = cg_list(Les, 0, Vdb, Bef, + {B,_Aft,St} = cg_list(Les, Vdb, Bef, St3#cg{bfail=0, ultimate_failure=UltimateMatchFail, is_top_block=true}), @@ -136,66 +481,64 @@ cg_fun(Les, Hvs, Vdb, AtomMod, NameArity, Anno, St0) -> %% cg(Lkexpr, Vdb, StackReg, State) -> {[Ainstr],StackReg,State}. %% Generate code for a kexpr. -%% Split function into two steps for clarity, not efficiency. -cg(Le, Vdb, Bef, St) -> - cg(Le#l.ke, Le, Vdb, Bef, St). - -cg({block,Es}, Le, Vdb, Bef, St) -> +cg(#cg_block{anno=Le,es=Es}, Vdb, Bef, St) -> block_cg(Es, Le, Vdb, Bef, St); -cg({match,M,Rs}, Le, Vdb, Bef, St) -> +cg(#k_match{anno=Le,body=M,ret=Rs}, Vdb, Bef, St) -> match_cg(M, Rs, Le, Vdb, Bef, St); -cg({guard_match,M,Rs}, Le, Vdb, Bef, St) -> +cg(#k_guard_match{anno=Le,body=M,ret=Rs}, Vdb, Bef, St) -> guard_match_cg(M, Rs, Le, Vdb, Bef, St); -cg({call,Func,As,Rs}, Le, Vdb, Bef, St) -> +cg(#k_call{anno=Le,op=Func,args=As,ret=Rs}, Vdb, Bef, St) -> call_cg(Func, As, Rs, Le, Vdb, Bef, St); -cg({enter,Func,As}, Le, Vdb, Bef, St) -> +cg(#k_enter{anno=Le,op=Func,args=As}, Vdb, Bef, St) -> enter_cg(Func, As, Le, Vdb, Bef, St); -cg({bif,Bif,As,Rs}, Le, Vdb, Bef, St) -> - bif_cg(Bif, As, Rs, Le, Vdb, Bef, St); -cg({gc_bif,Bif,As,Rs}, Le, Vdb, Bef, St) -> - gc_bif_cg(Bif, As, Rs, Le, Vdb, Bef, St); -cg({internal,Bif,As,Rs}, Le, Vdb, Bef, St) -> - internal_cg(Bif, As, Rs, Le, Vdb, Bef, St); -cg({receive_loop,Te,Rvar,Rm,Tes,Rs}, Le, Vdb, Bef, St) -> +cg(#k_bif{anno=Le}=Bif, Vdb, Bef, St) -> + bif_cg(Bif, Le, Vdb, Bef, St); +cg(#k_receive{anno=Le,timeout=Te,var=Rvar,body=Rm,action=Tes,ret=Rs}, + Vdb, Bef, St) -> recv_loop_cg(Te, Rvar, Rm, Tes, Rs, Le, Vdb, Bef, St); -cg(receive_next, Le, Vdb, Bef, St) -> +cg(#k_receive_next{anno=Le}, Vdb, Bef, St) -> recv_next_cg(Le, Vdb, Bef, St); -cg(receive_accept, _Le, _Vdb, Bef, St) -> {[remove_message],Bef,St}; -cg({'try',Ta,Vs,Tb,Evs,Th,Rs}, Le, Vdb, Bef, St) -> +cg(#k_receive_accept{}, _Vdb, Bef, St) -> + {[remove_message],Bef,St}; +cg(#k_try{anno=Le,arg=Ta,vars=Vs,body=Tb,evars=Evs,handler=Th,ret=Rs}, + Vdb, Bef, St) -> try_cg(Ta, Vs, Tb, Evs, Th, Rs, Le, Vdb, Bef, St); -cg({try_enter,Ta,Vs,Tb,Evs,Th}, Le, Vdb, Bef, St) -> +cg(#k_try_enter{anno=Le,arg=Ta,vars=Vs,body=Tb,evars=Evs,handler=Th}, + Vdb, Bef, St) -> try_enter_cg(Ta, Vs, Tb, Evs, Th, Le, Vdb, Bef, St); -cg({'catch',Cb,R}, Le, Vdb, Bef, St) -> +cg(#k_catch{anno=Le,body=Cb,ret=[R]}, Vdb, Bef, St) -> catch_cg(Cb, R, Le, Vdb, Bef, St); -cg({set,Var,Con}, Le, Vdb, Bef, St) -> - set_cg(Var, Con, Le, Vdb, Bef, St); -cg({return,Rs}, Le, Vdb, Bef, St) -> return_cg(Rs, Le, Vdb, Bef, St); -cg({break,Bs}, Le, Vdb, Bef, St) -> break_cg(Bs, Le, Vdb, Bef, St); -cg({guard_break,Bs,N}, Le, Vdb, Bef, St) -> - guard_break_cg(Bs, N, Le, Vdb, Bef, St); -cg({need_heap,H}, _Le, _Vdb, Bef, St) -> +cg(#k_put{anno=Le,arg=Con,ret=Var}, Vdb, Bef, St) -> + put_cg(Var, Con, Le, Vdb, Bef, St); +cg(#k_return{anno=Le,args=Rs}, Vdb, Bef, St) -> + return_cg(Rs, Le, Vdb, Bef, St); +cg(#k_break{anno=Le,args=Bs}, Vdb, Bef, St) -> + break_cg(Bs, Le, Vdb, Bef, St); +cg(#k_guard_break{anno=Le,args=Bs}, Vdb, Bef, St) -> + guard_break_cg(Bs, Le, Vdb, Bef, St); +cg(#cg_need_heap{h=H}, _Vdb, Bef, St) -> {[{test_heap,H,max_reg(Bef#sr.reg)}],Bef,St}. %% cg_list([Kexpr], FirstI, Vdb, StackReg, St) -> {[Ainstr],StackReg,St}. -cg_list(Kes, I, Vdb, Bef, St0) -> +cg_list(Kes, Vdb, Bef, St0) -> {Keis,{Aft,St1}} = flatmapfoldl(fun (Ke, {Inta,Sta}) -> {Keis,Intb,Stb} = cg(Ke, Vdb, Inta, Sta), {Keis,{Intb,Stb}} - end, {Bef,St0}, need_heap(Kes, I)), + end, {Bef,St0}, need_heap(Kes)), {Keis,Aft,St1}. %% need_heap([Lkexpr], I, St) -> [Lkexpr]. %% Insert need_heap instructions in Kexpr list. Try to be smart and %% collect them together as much as possible. -need_heap(Kes0, I) -> +need_heap(Kes0) -> {Kes,H} = need_heap_0(reverse(Kes0), 0, []), %% Prepend need_heap if necessary. - need_heap_need(I, H) ++ Kes. + need_heap_need(H) ++ Kes. need_heap_0([Ke|Kes], H0, Acc) -> {Ns,H} = need_heap_1(Ke, H0), @@ -203,27 +546,55 @@ need_heap_0([Ke|Kes], H0, Acc) -> need_heap_0([], H, Acc) -> {Acc,H}. -need_heap_1(#l{ke={set,_,{binary,_}},i=I}, H) -> - {need_heap_need(I, H),0}; -need_heap_1(#l{ke={set,_,{map,_,_,_}},i=I}, H) -> - {need_heap_need(I, H),0}; -need_heap_1(#l{ke={set,_,Val}}, H) -> +need_heap_1(#k_put{arg=#k_binary{}}, H) -> + {need_heap_need(H),0}; +need_heap_1(#k_put{arg=#k_map{}}, H) -> + {need_heap_need(H),0}; +need_heap_1(#k_put{arg=Val}, H) -> %% Just pass through adding to needed heap. {[],H + case Val of - {cons,_} -> 2; - {tuple,Es} -> 1 + length(Es); + #k_cons{} -> 2; + #k_tuple{es=Es} -> 1 + length(Es); _Other -> 0 end}; -need_heap_1(#l{ke={bif,_Bif,_As,_Rs}}, H) -> - {[],H}; -need_heap_1(#l{i=I}, H) -> +need_heap_1(#k_bif{}=Bif, H) -> + case is_gc_bif(Bif) of + false -> + {[],H}; + true -> + {need_heap_need(H),0} + end; +need_heap_1(_Ke, H) -> %% Call or call-like instruction such as set_tuple_element/3. - {need_heap_need(I, H),0}. - -need_heap_need(_I, 0) -> []; -need_heap_need(I, H) -> [#l{ke={need_heap,H},i=I}]. - -%% match_cg(Match, [Ret], Le, Vdb, StackReg, State) -> + {need_heap_need(H),0}. + +need_heap_need(0) -> []; +need_heap_need(H) -> [#cg_need_heap{h=H}]. + +%% is_gc_bif(#k_bif{}) -> true|false. +%% is_gc_bif(Name, Arity) -> true|false. +%% Determines whether the BIF Name/Arity might do a GC. + +is_gc_bif(#k_bif{op=#k_remote{name=#k_atom{val=Name}},args=Args}) -> + is_gc_bif(Name, length(Args)); +is_gc_bif(#k_bif{op=#k_internal{}}) -> + true. + +is_gc_bif(hd, 1) -> false; +is_gc_bif(tl, 1) -> false; +is_gc_bif(self, 0) -> false; +is_gc_bif(node, 0) -> false; +is_gc_bif(node, 1) -> false; +is_gc_bif(element, 2) -> false; +is_gc_bif(get, 1) -> false; +is_gc_bif(tuple_size, 1) -> false; +is_gc_bif(map_get, 2) -> false; +is_gc_bif(Bif, Arity) -> + not (erl_internal:bool_op(Bif, Arity) orelse + erl_internal:new_type_test(Bif, Arity) orelse + erl_internal:comp_op(Bif, Arity)). + +%% match_cg(Matc, [Ret], Le, Vdb, StackReg, State) -> %% {[Ainstr],StackReg,State}. %% Generate code for a match. First save all variables on the stack %% that are to survive after the match. We leave saved variables in @@ -244,7 +615,10 @@ match_cg(M, Rs, Le, Vdb, Bef, St0) -> guard_match_cg(M, Rs, Le, Vdb, Bef, St0) -> I = Le#l.i, {B,St1} = new_label(St0), - #cg{bfail=Fail} = St1, + Fail = case St0 of + #cg{bfail=0,ultimate_failure=Fail0} -> Fail0; + #cg{bfail=Fail0} -> Fail0 + end, {Mis,Aft,St2} = match_cg(M, Fail, Bef, St1#cg{break=B}), %% Update the register descriptors for the return registers. Reg = guard_match_regs(Aft#sr.reg, Rs), @@ -252,7 +626,7 @@ guard_match_cg(M, Rs, Le, Vdb, Bef, St0) -> clear_dead(Aft#sr{reg=Reg}, I, Vdb), St2#cg{break=St1#cg.break}}. -guard_match_regs([{I,gbreakvar}|Rs], [{var,V}|Vs]) -> +guard_match_regs([{I,gbreakvar}|Rs], [#k_var{name=V}|Vs]) -> [{I,V}|guard_match_regs(Rs, Vs)]; guard_match_regs([R|Rs], Vs) -> [R|guard_match_regs(Rs, Vs)]; @@ -264,17 +638,14 @@ guard_match_regs([], []) -> []. %% down as each level which uses this takes its own internal Vdb not %% the outer one. -match_cg(Le, Fail, Bef, St) -> - match_cg(Le#l.ke, Le, Fail, Bef, St). - -match_cg({alt,F,S}, _Le, Fail, Bef, St0) -> +match_cg(#k_alt{first=F,then=S}, Fail, Bef, St0) -> {Tf,St1} = new_label(St0), {Fis,Faft,St2} = match_cg(F, Tf, Bef, St1), {Sis,Saft,St3} = match_cg(S, Fail, Bef, St2), Aft = sr_merge(Faft, Saft), {Fis ++ [{label,Tf}] ++ Sis,Aft,St3}; -match_cg({select,{var,Vname}=V,Scs0}, #l{a=Anno}, Fail, Bef, St) -> - ReuseForContext = member(reuse_for_context, Anno) andalso +match_cg(#k_select{var=#k_var{anno=Vanno,name=Vname}=V,types=Scs0}, Fail, Bef, St) -> + ReuseForContext = member(reuse_for_context, Vanno) andalso find_reg(Vname, Bef#sr.reg) =/= error, Scs = case ReuseForContext of false -> Scs0; @@ -283,10 +654,10 @@ match_cg({select,{var,Vname}=V,Scs0}, #l{a=Anno}, Fail, Bef, St) -> match_fmf(fun (S, F, Sta) -> select_cg(S, V, F, Fail, Bef, Sta) end, Fail, St, Scs); -match_cg({guard,Gcs}, _Le, Fail, Bef, St) -> +match_cg(#k_guard{clauses=Gcs}, Fail, Bef, St) -> match_fmf(fun (G, F, Sta) -> guard_clause_cg(G, F, Bef, Sta) end, Fail, St, Gcs); -match_cg({block,Es}, Le, _Fail, Bef, St) -> +match_cg(#cg_block{anno=Le,es=Es}, _Fail, Bef, St) -> %% Must clear registers and stack of dead variables. Int = clear_dead(Bef, Le#l.i, Le#l.vdb), block_cg(Es, Le, Int, St). @@ -294,8 +665,8 @@ match_cg({block,Es}, Le, _Fail, Bef, St) -> %% bsm_rename_ctx([Clause], Var) -> [Clause] %% We know from an annotation that the register for a binary can %% be reused for the match context because the two are not truly -%% alive at the same time (even though the conservative life time -%% information calculated by v3_life says so). +%% alive at the same time (even though the life time information +%% says so). %% %% The easiest way to have those variables share the same register is %% to rename the variable with the shortest life-span (the match @@ -306,12 +677,14 @@ match_cg({block,Es}, Le, _Fail, Bef, St) -> %% We must also remove all information about the match context %% variable from all life-time information databases (Vdb). -bsm_rename_ctx([#l{ke={type_clause,binary, - [#l{ke={val_clause,{binary,{var,Old}},Ke0}}=L2]}}=L1|Cs], New) -> +bsm_rename_ctx([#k_type_clause{type=k_binary,values=Vcs}=TC|Cs], New) -> + [#k_val_clause{val=#k_binary{segs=#k_var{name=Old}}=Bin, + body=Ke0}=VC0] = Vcs, Ke = bsm_rename_ctx(Ke0, Old, New, false), - [L1#l{ke={type_clause,binary, - [L2#l{ke={val_clause,{binary,{var,New}},Ke}}]}}|bsm_rename_ctx(Cs, New)]; -bsm_rename_ctx([C|Cs], New) -> + VC = VC0#k_val_clause{val=Bin#k_binary{segs=#k_var{name=New}}, + body=Ke}, + [TC#k_type_clause{values=[VC]}|bsm_rename_ctx(Cs, New)]; +bsm_rename_ctx([C|Cs], New) -> [C|bsm_rename_ctx(Cs, New)]; bsm_rename_ctx([], _) -> []. @@ -321,34 +694,24 @@ bsm_rename_ctx([], _) -> []. %% only complicatate things to recurse into blocks not in a protected %% (the match context variable is not live inside them). -bsm_rename_ctx(#l{ke={select,{var,V},Cs0}}=L, Old, New, InProt) -> +bsm_rename_ctx(#k_select{var=#k_var{name=V},types=Cs0}=Sel, + Old, New, InProt) -> Cs = bsm_rename_ctx_list(Cs0, Old, New, InProt), - L#l{ke={select,{var,bsm_rename_var(V, Old, New)},Cs}}; -bsm_rename_ctx(#l{ke={type_clause,Type,Cs0}}=L, Old, New, InProt) -> + Sel#k_select{var=#k_var{name=bsm_rename_var(V, Old, New)},types=Cs}; +bsm_rename_ctx(#k_type_clause{values=Cs0}=TC, Old, New, InProt) -> Cs = bsm_rename_ctx_list(Cs0, Old, New, InProt), - L#l{ke={type_clause,Type,Cs}}; -bsm_rename_ctx(#l{ke={val_clause,{bin_end,V},Ke0}}=L, Old, New, InProt) -> + TC#k_type_clause{values=Cs}; +bsm_rename_ctx(#k_val_clause{body=Ke0}=VC, Old, New, InProt) -> Ke = bsm_rename_ctx(Ke0, Old, New, InProt), - L#l{ke={val_clause,{bin_end,bsm_rename_var(V, Old, New)},Ke}}; -bsm_rename_ctx(#l{ke={val_clause,{bin_seg,V,Sz,U,Type,Fl,Vs},Ke0}}=L, - Old, New, InProt) -> - Ke = bsm_rename_ctx(Ke0, Old, New, InProt), - L#l{ke={val_clause,{bin_seg,bsm_rename_var(V, Old, New),Sz,U,Type,Fl,Vs},Ke}}; -bsm_rename_ctx(#l{ke={val_clause,{bin_int,V,Sz,U,Fl,Val,Vs},Ke0}}=L, - Old, New, InProt) -> - Ke = bsm_rename_ctx(Ke0, Old, New, InProt), - L#l{ke={val_clause,{bin_int,bsm_rename_var(V, Old, New),Sz,U,Fl,Val,Vs},Ke}}; -bsm_rename_ctx(#l{ke={val_clause,Val,Ke0}}=L, Old, New, InProt) -> - Ke = bsm_rename_ctx(Ke0, Old, New, InProt), - L#l{ke={val_clause,Val,Ke}}; -bsm_rename_ctx(#l{ke={alt,F0,S0}}=L, Old, New, InProt) -> + VC#k_val_clause{body=Ke}; +bsm_rename_ctx(#k_alt{first=F0,then=S0}=Alt, Old, New, InProt) -> F = bsm_rename_ctx(F0, Old, New, InProt), S = bsm_rename_ctx(S0, Old, New, InProt), - L#l{ke={alt,F,S}}; -bsm_rename_ctx(#l{ke={guard,Gcs0}}=L, Old, New, InProt) -> + Alt#k_alt{first=F,then=S}; +bsm_rename_ctx(#k_guard{clauses=Gcs0}=Guard, Old, New, InProt) -> Gcs = bsm_rename_ctx_list(Gcs0, Old, New, InProt), - L#l{ke={guard,Gcs}}; -bsm_rename_ctx(#l{ke={guard_clause,G0,B0}}=L, Old, New, InProt) -> + Guard#k_guard{clauses=Gcs}; +bsm_rename_ctx(#k_guard_clause{guard=G0,body=B0}=GC, Old, New, InProt) -> G = bsm_rename_ctx(G0, Old, New, InProt), B = bsm_rename_ctx(B0, Old, New, InProt), %% A guard clause may cause unsaved variables to be saved on the stack. @@ -356,49 +719,45 @@ bsm_rename_ctx(#l{ke={guard_clause,G0,B0}}=L, Old, New, InProt) -> %% same register), it is neither in the stack nor register descriptor %% lists and we would crash when we didn't find it unless we remove %% it from the database. - bsm_forget_var(L#l{ke={guard_clause,G,B}}, Old); -bsm_rename_ctx(#l{ke={protected,Ts0,Rs}}=L, Old, New, _InProt) -> + bsm_forget_var(GC#k_guard_clause{guard=G,body=B}, Old); +bsm_rename_ctx(#k_protected{arg=Ts0}=Prot, Old, New, _InProt) -> InProt = true, Ts = bsm_rename_ctx_list(Ts0, Old, New, InProt), - bsm_forget_var(L#l{ke={protected,Ts,Rs}}, Old); -bsm_rename_ctx(#l{ke={match,Ms0,Rs}}=L, Old, New, InProt) -> + bsm_forget_var(Prot#k_protected{arg=Ts}, Old); +bsm_rename_ctx(#k_guard_match{body=Ms0}=Match, Old, New, InProt) -> Ms = bsm_rename_ctx(Ms0, Old, New, InProt), - L#l{ke={match,Ms,Rs}}; -bsm_rename_ctx(#l{ke={guard_match,Ms0,Rs}}=L, Old, New, InProt) -> - Ms = bsm_rename_ctx(Ms0, Old, New, InProt), - L#l{ke={guard_match,Ms,Rs}}; -bsm_rename_ctx(#l{ke={test,_,_,_}}=L, _, _, _) -> L; -bsm_rename_ctx(#l{ke={bif,_,_,_}}=L, _, _, _) -> L; -bsm_rename_ctx(#l{ke={gc_bif,_,_,_}}=L, _, _, _) -> L; -bsm_rename_ctx(#l{ke={set,_,_}}=L, _, _, _) -> L; -bsm_rename_ctx(#l{ke={call,_,_,_}}=L, _, _, _) -> L; -bsm_rename_ctx(#l{ke={block,_}}=L, Old, _, false) -> + Match#k_guard_match{body=Ms}; +bsm_rename_ctx(#k_test{}=Test, _, _, _) -> Test; +bsm_rename_ctx(#k_bif{}=Bif, _, _, _) -> Bif; +bsm_rename_ctx(#k_put{}=Put, _, _, _) -> Put; +bsm_rename_ctx(#k_call{}=Call, _, _, _) -> Call; +bsm_rename_ctx(#cg_block{}=Block, Old, _, false) -> %% This block is not inside a protected. The match context variable cannot %% possibly be live inside the block. - bsm_forget_var(L, Old); -bsm_rename_ctx(#l{ke={block,Bl0}}=L, Old, New, true) -> + bsm_forget_var(Block, Old); +bsm_rename_ctx(#cg_block{es=Es0}=Block, Old, New, true) -> %% A block in a protected. We must recursively rename the variable %% inside the block. - Bl = bsm_rename_ctx_list(Bl0, Old, New, true), - bsm_forget_var(L#l{ke={block,Bl}}, Old); -bsm_rename_ctx(#l{ke={guard_break,Bs,Locked0}}=L0, Old, _New, _InProt) -> - Locked = Locked0 -- [Old], - L = L0#l{ke={guard_break,Bs,Locked}}, - bsm_forget_var(L, Old). + Es = bsm_rename_ctx_list(Es0, Old, New, true), + bsm_forget_var(Block#cg_block{es=Es}, Old); +bsm_rename_ctx(#k_guard_break{}=Break, Old, _New, _InProt) -> + bsm_forget_var(Break, Old). bsm_rename_ctx_list([C|Cs], Old, New, InProt) -> [bsm_rename_ctx(C, Old, New, InProt)| bsm_rename_ctx_list(Cs, Old, New, InProt)]; bsm_rename_ctx_list([], _, _, _) -> []. - + bsm_rename_var(Old, Old, New) -> New; bsm_rename_var(V, _, _) -> V. %% bsm_forget_var(#l{}, Variable) -> #l{} %% Remove a variable from the variable life-time database. -bsm_forget_var(#l{vdb=Vdb}=L, V) -> - L#l{vdb=keydelete(V, 1, Vdb)}. +bsm_forget_var(Ke, V) -> + #l{vdb=Vdb} = L0 = get_kanno(Ke), + L = L0#l{vdb=keydelete(V, 1, Vdb)}, + set_kanno(Ke, L). %% block_cg([Kexpr], Le, Vdb, StackReg, St) -> {[Ainstr],StackReg,St}. %% block_cg([Kexpr], Le, StackReg, St) -> {[Ainstr],StackReg,St}. @@ -407,158 +766,227 @@ block_cg(Es, Le, _Vdb, Bef, St) -> block_cg(Es, Le, Bef, St). block_cg(Es, Le, Bef, #cg{is_top_block=false}=St) -> - cg_block(Es, Le#l.i, Le#l.vdb, Bef, St); -block_cg(Es, Le, Bef, St0) -> - {Is0,Aft,St} = cg_block(Es, Le#l.i, Le#l.vdb, Bef, - St0#cg{is_top_block=false,need_frame=false}), - Is = top_level_block(Is0, Aft, max_reg(Bef#sr.reg), St), - {Is,Aft,St#cg{is_top_block=true}}. - -cg_block([], _I, _Vdb, Bef, St0) -> + cg_block(Es, Le#l.vdb, Bef, St); +block_cg(Es, Le, Bef, #cg{is_top_block=true}=St0) -> + %% No stack frame has been established yet. Do we need one? + case need_stackframe(Es) of + true -> + %% We need a stack frame. Generate the code and add the + %% code for creating and deallocating the stack frame. + {Is0,Aft,St} = cg_block(Es, Le#l.vdb, Bef, + St0#cg{is_top_block=false,need_frame=false}), + Is = top_level_block(Is0, Aft, max_reg(Bef#sr.reg), St), + {Is,Aft,St#cg{is_top_block=true}}; + false -> + %% This sequence of instructions ending in a #k_match{} (a + %% 'case' or 'if') in the Erlang code does not need a + %% stack frame yet. Delay the creation (if a stack frame + %% is needed at all, it will be created inside the + %% #k_match{}). + cg_list(Es, Le#l.vdb, Bef, St0) + end. + +%% need_stackframe([Kexpr]) -> true|false. +%% Does this list of instructions need a stack frame? +%% +%% A sequence of instructions that don't clobber the X registers +%% followed by a single #k_match{} doesn't need a stack frame. + +need_stackframe([H|T]) -> + case H of + #k_bif{op=#k_internal{}} -> true; + #k_put{arg=#k_binary{}} -> true; + #k_bif{} -> need_stackframe(T); + #k_put{} -> need_stackframe(T); + #k_guard_match{} -> need_stackframe(T); + #k_match{} when T =:= [] -> false; + _ -> true + end; +need_stackframe([]) -> false. + +cg_block([], _Vdb, Bef, St0) -> {[],Bef,St0}; -cg_block(Kes0, I, Vdb, Bef, St0) -> +cg_block(Kes0, Vdb, Bef, St0) -> {Kes2,Int1,St1} = case basic_block(Kes0) of {Kes1,LastI,Args,Rest} -> - Ke = hd(Kes1), - Fb = Ke#l.i, - cg_basic_block(Kes1, Fb, LastI, Args, Vdb, Bef, St0); + cg_basic_block(Kes1, LastI, Args, Vdb, Bef, St0); {Kes1,Rest} -> - cg_list(Kes1, I, Vdb, Bef, St0) + cg_list(Kes1, Vdb, Bef, St0) end, - {Kes3,Int2,St2} = cg_block(Rest, I, Vdb, Int1, St1), + {Kes3,Int2,St2} = cg_block(Rest, Vdb, Int1, St1), {Kes2 ++ Kes3,Int2,St2}. basic_block(Kes) -> basic_block(Kes, []). -basic_block([Le|Les], Acc) -> - case collect_block(Le#l.ke) of - include -> basic_block(Les, [Le|Acc]); +basic_block([Ke|Kes], Acc) -> + case collect_block(Ke) of + include -> basic_block(Kes, [Ke|Acc]); {block_end,As} -> case Acc of [] -> - %% If the basic block does not contain any set instructions, + %% If the basic block does not contain any #k_put{} instructions, %% it serves no useful purpose to do basic block optimizations. - {[Le],Les}; + {[Ke],Kes}; _ -> - {reverse(Acc, [Le]),Le#l.i,As,Les} + #l{i=I} = get_kanno(Ke), + {reverse(Acc, [Ke]),I,As,Kes} end; - no_block -> {reverse(Acc, [Le]),Les} + no_block -> {reverse(Acc, [Ke]),Kes} end. -%% sets that may garbage collect are not allowed in basic blocks. - -collect_block({set,_,{binary,_}}) -> no_block; -collect_block({set,_,{map,_,_,_}}) -> no_block; -collect_block({set,_,_}) -> include; -collect_block({call,{var,_}=Var,As,_Rs}) -> {block_end,As++[Var]}; -collect_block({call,Func,As,_Rs}) -> {block_end,As++func_vars(Func)}; -collect_block({enter,{var,_}=Var,As})-> {block_end,As++[Var]}; -collect_block({enter,Func,As}) -> {block_end,As++func_vars(Func)}; -collect_block({return,Rs}) -> {block_end,Rs}; -collect_block({break,Bs}) -> {block_end,Bs}; -collect_block(_) -> no_block. - -func_vars({remote,M,F}) when element(1, M) =:= var; - element(1, F) =:= var -> +collect_block(#k_put{arg=Arg}) -> + %% #k_put{} instructions that may garbage collect are not allowed + %% in basic blocks. + case Arg of + #k_binary{} -> no_block; + #k_map{} -> no_block; + _ -> include + end; +collect_block(#k_call{op=Func,args=As}) -> + {block_end,As++func_vars(Func)}; +collect_block(#k_enter{op=Func,args=As}) -> + {block_end,As++func_vars(Func)}; +collect_block(#k_return{args=Rs}) -> + {block_end,Rs}; +collect_block(#k_break{args=Bs}) -> + {block_end,Bs}; +collect_block(_) -> no_block. + +func_vars(#k_var{}=Var) -> + [Var]; +func_vars(#k_remote{mod=M,name=F}) + when is_record(M, k_var); is_record(F, k_var) -> [M,F]; func_vars(_) -> []. -%% cg_basic_block([Kexpr], FirstI, LastI, As, Vdb, StackReg, State) -> +%% cg_basic_block([Kexpr], FirstI, LastI, Arguments, Vdb, StackReg, State) -> %% {[Ainstr],StackReg,State}. - -cg_basic_block(Kes, Fb, Lf, As, Vdb, Bef, St0) -> - Res = make_reservation(As, 0), - Regs0 = reserve(Res, Bef#sr.reg, Bef#sr.stk), - Stk = extend_stack(Bef, Lf, Lf+1, Vdb), - Int0 = Bef#sr{reg=Regs0,stk=Stk,res=Res}, - X0_v0 = x0_vars(As, Fb, Lf, Vdb), - {Keis,{Aft,_,St1}} = +%% +%% Do a specialized code generation for a basic block of #put{} +%% instructions (that don't do any garbage collection) followed by a +%% call, break, or return. +%% +%% 'Arguments' is a list of the variables that must be loaded into +%% consecutive X registers before the last instruction in the block. +%% The point of this specialized code generation is to try put the +%% all of the variables in 'Arguments' into the correct X register +%% to begin with, instead of putting them into the first available +%% X register and having to move them to the correct X register +%% later. +%% +%% To achieve that, we attempt to reserve the X registers that the +%% variables in 'Arguments' will need to be in when the block ends. +%% +%% To make it more likely that reservations will be successful, we +%% will try to save variables that need to be saved to the stack as +%% early as possible (if an X register needed by a variable in +%% Arguments is occupied by another variable, the value in the +%% X register can be evicted if it is saved on the stack). +%% +%% We will take care not to increase the size of stack frame compared +%% to what the standard code generator would have done (that is, to +%% save all X registers at the last possible moment). We will do that +%% by extending the stack frame to the minimal size needed to save +%% all that needs to be saved using extend_stack/4, and use +%% save_carefully/4 during code generation to only save the variables +%% that can be saved without growing the stack frame. + +cg_basic_block(Kes, Lf, As, Vdb, Bef, St0) -> + Int0 = reserve_arg_regs(As, Bef), + Int = extend_stack(Int0, Lf, Lf+1, Vdb), + {Keis,{Aft,St1}} = flatmapfoldl(fun(Ke, St) -> cg_basic_block(Ke, St, Lf, Vdb) end, - {Int0,X0_v0,St0}, need_heap(Kes, Fb)), + {Int,St0}, need_heap(Kes)), {Keis,Aft,St1}. -cg_basic_block(#l{ke={need_heap,_}}=Ke, {Inta,X0v,Sta}, _Lf, Vdb) -> - {Keis,Intb,Stb} = cg(Ke, Vdb, Inta, Sta), - {Keis, {Intb,X0v,Stb}}; -cg_basic_block(Ke, {Inta,X0_v1,Sta}, Lf, Vdb) -> - {Sis,Intb} = save_carefully(Inta, Ke#l.i, Lf+1, Vdb), - {X0_v2,Intc} = allocate_x0(X0_v1, Ke#l.i, Intb), - Intd = reserve(Intc), - {Keis,Inte,Stb} = cg(Ke, Vdb, Intd, Sta), - {Sis ++ Keis, {Inte,X0_v2,Stb}}. - -make_reservation([], _) -> []; -make_reservation([{var,V}|As], I) -> [{I,V}|make_reservation(As, I+1)]; -make_reservation([A|As], I) -> [{I,A}|make_reservation(As, I+1)]. - -reserve(Sr) -> Sr#sr{reg=reserve(Sr#sr.res, Sr#sr.reg, Sr#sr.stk)}. - -reserve([{I,V}|Rs], [free|Regs], Stk) -> [{reserved,I,V}|reserve(Rs, Regs, Stk)]; -reserve([{I,V}|Rs], [{I,V}|Regs], Stk) -> [{I,V}|reserve(Rs, Regs, Stk)]; -reserve([{I,V}|Rs], [{I,Var}|Regs], Stk) -> +cg_basic_block(#cg_need_heap{}=Ke, {Bef,St0}, _Lf, Vdb) -> + {Keis,Aft,St1} = cg(Ke, Vdb, Bef, St0), + {Keis,{Aft,St1}}; +cg_basic_block(Ke, {Bef,St0}, Lf, Vdb) -> + #l{i=I} = get_kanno(Ke), + + %% Save all we can to increase the possibility that reserving + %% registers will succeed. + {Sis,Int0} = save_carefully(Bef, I, Lf+1, Vdb), + Int1 = reserve(Int0), + {Keis,Aft,St1} = cg(Ke, Vdb, Int1, St0), + {Sis ++ Keis,{Aft,St1}}. + +%% reserve_arg_regs([Argument], Bef) -> Aft. +%% Try to reserve the X registers for all arguments. All registers +%% that we wish to reserve will be saved in Bef#sr.res. + +reserve_arg_regs(As, Bef) -> + Res = reserve_arg_regs_1(As, 0), + reserve(Bef#sr{res=Res}). + +reserve_arg_regs_1([#k_var{name=V}|As], I) -> + [{I,V}|reserve_arg_regs_1(As, I+1)]; +reserve_arg_regs_1([A|As], I) -> + [{I,A}|reserve_arg_regs_1(As, I+1)]; +reserve_arg_regs_1([], _) -> []. + +%% reserve(Bef) -> Aft. +%% Try to reserve more registers. The registers we wish to reserve +%% are found in Bef#sr.res. + +reserve(#sr{reg=Regs,stk=Stk,res=Res}=Sr) -> + Sr#sr{reg=reserve_1(Res, Regs, Stk)}. + +reserve_1([{I,V}|Rs], [free|Regs], Stk) -> + [{reserved,I,V}|reserve_1(Rs, Regs, Stk)]; +reserve_1([{I,V}|Rs], [{I,V}|Regs], Stk) -> + [{I,V}|reserve_1(Rs, Regs, Stk)]; +reserve_1([{I,V}|Rs], [{I,Var}|Regs], Stk) -> case on_stack(Var, Stk) of - true -> [{reserved,I,V}|reserve(Rs, Regs, Stk)]; - false -> [{I,Var}|reserve(Rs, Regs, Stk)] + true -> [{reserved,I,V}|reserve_1(Rs, Regs, Stk)]; + false -> [{I,Var}|reserve_1(Rs, Regs, Stk)] end; -reserve([{I,V}|Rs], [{reserved,I,_}|Regs], Stk) -> - [{reserved,I,V}|reserve(Rs, Regs, Stk)]; -%reserve([{I,V}|Rs], [Other|Regs], Stk) -> [Other|reserve(Rs, Regs, Stk)]; -reserve([{I,V}|Rs], [], Stk) -> [{reserved,I,V}|reserve(Rs, [], Stk)]; -reserve([], Regs, _) -> Regs. - -extend_stack(Bef, Fb, Lf, Vdb) -> - Stk0 = clear_dead_stk(Bef#sr.stk, Fb, Vdb), - Saves = [V || {V,F,L} <- Vdb, - F < Fb, - L >= Lf, - not on_stack(V, Stk0)], - Stk1 = foldl(fun (V, Stk) -> put_stack(V, Stk) end, Stk0, Saves), - Bef#sr.stk ++ lists:duplicate(length(Stk1) - length(Bef#sr.stk), free). - -save_carefully(Bef, Fb, Lf, Vdb) -> - Stk = Bef#sr.stk, - %% New variables that are in use but not on stack. - New = [VFL || {V,F,L} = VFL <- Vdb, - F < Fb, - L >= Lf, - not on_stack(V, Stk)], - Saves = [V || {V,_,_} <- keysort(2, New)], - save_carefully(Saves, Bef, []). - -save_carefully([], Bef, Acc) -> {reverse(Acc),Bef}; -save_carefully([V|Vs], Bef, Acc) -> - case put_stack_carefully(V, Bef#sr.stk) of - error -> {reverse(Acc),Bef}; +reserve_1([{I,V}|Rs], [{reserved,I,_}|Regs], Stk) -> + [{reserved,I,V}|reserve_1(Rs, Regs, Stk)]; +reserve_1([{I,V}|Rs], [], Stk) -> + [{reserved,I,V}|reserve_1(Rs, [], Stk)]; +reserve_1([], Regs, _) -> Regs. + +%% extend_stack(Bef, FirstBefore, LastFrom, Vdb) -> Aft. +%% Extend the stack enough to fit all variables alive past LastFrom +%% and not already on the stack. + +extend_stack(#sr{stk=Stk0}=Bef, Fb, Lf, Vdb) -> + Stk1 = clear_dead_stk(Stk0, Fb, Vdb), + New = new_not_on_stack(Stk1, Fb, Lf, Vdb), + Stk2 = foldl(fun ({V,_,_}, Stk) -> put_stack(V, Stk) end, Stk1, New), + Stk = Stk0 ++ lists:duplicate(length(Stk2) - length(Stk0), free), + Bef#sr{stk=Stk}. + +%% save_carefully(Bef, FirstBefore, LastFrom, Vdb) -> {[SaveVar],Aft}. +%% Save variables which are used past current point and which are not +%% already on the stack, but only if the variables can be saved without +%% growing the stack frame. + +save_carefully(#sr{stk=Stk}=Bef, Fb, Lf, Vdb) -> + New0 = new_not_on_stack(Stk, Fb, Lf, Vdb), + New = keysort(2, New0), + save_carefully_1(New, Bef, []). + +save_carefully_1([{V,_,_}|Vs], #sr{reg=Regs,stk=Stk0}=Bef, Acc) -> + case put_stack_carefully(V, Stk0) of + error -> + {reverse(Acc),Bef}; Stk1 -> - SrcReg = fetch_reg(V, Bef#sr.reg), + SrcReg = fetch_reg(V, Regs), Move = {move,SrcReg,fetch_stack(V, Stk1)}, {x,_} = SrcReg, %Assertion - must be X register. - save_carefully(Vs, Bef#sr{stk=Stk1}, [Move|Acc]) - end. + save_carefully_1(Vs, Bef#sr{stk=Stk1}, [Move|Acc]) + end; +save_carefully_1([], Bef, Acc) -> + {reverse(Acc),Bef}. -x0_vars([], _Fb, _Lf, _Vdb) -> []; -x0_vars([{var,V}|_], Fb, _Lf, Vdb) -> - {V,F,_L} = VFL = vdb_find(V, Vdb), - x0_vars1([VFL], Fb, F, Vdb); -x0_vars([X0|_], Fb, Lf, Vdb) -> - x0_vars1([{X0,Lf,Lf}], Fb, Lf, Vdb). - -x0_vars1(X0, Fb, Xf, Vdb) -> - Vs0 = [VFL || {_V,F,L}=VFL <- Vdb, - F >= Fb, - L < Xf], - Vs1 = keysort(3, Vs0), - keysort(2, X0++Vs1). - -allocate_x0([], _, Bef) -> {[],Bef#sr{res=[]}}; -allocate_x0([{_,_,L}|Vs], I, Bef) when L =< I -> - allocate_x0(Vs, I, Bef); -allocate_x0([{V,_F,_L}=VFL|Vs], _, Bef) -> - {[VFL|Vs],Bef#sr{res=reserve_x0(V, Bef#sr.res)}}. - -reserve_x0(V, [_|Res]) -> [{0,V}|Res]; -reserve_x0(V, []) -> [{0,V}]. +%% top_level_block([Instruction], Bef, MaxRegs, St) -> [Instruction]. +%% For the top-level block, allocate a stack frame a necessary, +%% adjust Y register numbering and instructions that return +%% from the function. top_level_block(Keis, #sr{stk=[]}, _MaxRegs, #cg{need_frame=false}) -> Keis; @@ -640,21 +1068,27 @@ turn_yreg(Other, _MaxY) -> %% wrong. These are different as in the second case there is no need %% to try the next type, it will always fail. -select_cg(#l{ke={type_clause,cons,[S]}}, {var,V}, Tf, Vf, Bef, St) -> +select_cg(#k_type_clause{type=Type,values=Vs}, Var, Tf, Vf, Bef, St) -> + #k_var{name=V} = Var, + select_cg(Type, Vs, V, Tf, Vf, Bef, St). + +select_cg(k_cons, [S], V, Tf, Vf, Bef, St) -> select_cons(S, V, Tf, Vf, Bef, St); -select_cg(#l{ke={type_clause,nil,[S]}}, {var,V}, Tf, Vf, Bef, St) -> +select_cg(k_nil, [S], V, Tf, Vf, Bef, St) -> select_nil(S, V, Tf, Vf, Bef, St); -select_cg(#l{ke={type_clause,binary,[S]}}, {var,V}, Tf, Vf, Bef, St) -> +select_cg(k_binary, [S], V, Tf, Vf, Bef, St) -> select_binary(S, V, Tf, Vf, Bef, St); -select_cg(#l{ke={type_clause,bin_seg,S}}, {var,V}, Tf, _Vf, Bef, St) -> +select_cg(k_bin_seg, S, V, Tf, _Vf, Bef, St) -> select_bin_segs(S, V, Tf, Bef, St); -select_cg(#l{ke={type_clause,bin_int,S}}, {var,V}, Tf, _Vf, Bef, St) -> +select_cg(k_bin_int, S, V, Tf, _Vf, Bef, St) -> select_bin_segs(S, V, Tf, Bef, St); -select_cg(#l{ke={type_clause,bin_end,[S]}}, {var,V}, Tf, _Vf, Bef, St) -> +select_cg(k_bin_end, [S], V, Tf, _Vf, Bef, St) -> select_bin_end(S, V, Tf, Bef, St); -select_cg(#l{ke={type_clause,map,S}}, {var,V}, Tf, Vf, Bef, St) -> +select_cg(k_map, S, V, Tf, Vf, Bef, St) -> select_map(S, V, Tf, Vf, Bef, St); -select_cg(#l{ke={type_clause,Type,Scs}}, {var,V}, Tf, Vf, Bef, St0) -> +select_cg(k_literal, S, V, Tf, Vf, Bef, St) -> + select_literal(S, V, Tf, Vf, Bef, St); +select_cg(Type, Scs, V, Tf, Vf, Bef, St0) -> {Vis,{Aft,St1}} = mapfoldl(fun (S, {Int,Sta}) -> {Val,Is,Inta,Stb} = select_val(S, V, Vf, Bef, Sta), @@ -664,22 +1098,29 @@ select_cg(#l{ke={type_clause,Type,Scs}}, {var,V}, Tf, Vf, Bef, St0) -> {Vls,Sis,St2} = select_labels(OptVls, St1, [], []), {select_val_cg(Type, fetch_var(V, Bef), Vls, Tf, Vf, Sis), Aft, St2}. -select_val_cg(tuple, R, [Arity,{f,Lbl}], Tf, Vf, [{label,Lbl}|Sis]) -> +select_val_cg(k_tuple, R, [Arity,{f,Lbl}], Tf, Vf, [{label,Lbl}|Sis]) -> [{test,is_tuple,{f,Tf},[R]},{test,test_arity,{f,Vf},[R,Arity]}|Sis]; -select_val_cg(tuple, R, Vls, Tf, Vf, Sis) -> +select_val_cg(k_tuple, R, Vls, Tf, Vf, Sis) -> [{test,is_tuple,{f,Tf},[R]},{select_tuple_arity,R,{f,Vf},{list,Vls}}|Sis]; select_val_cg(Type, R, [Val, {f,Lbl}], Fail, Fail, [{label,Lbl}|Sis]) -> - [{test,is_eq_exact,{f,Fail},[R,{Type,Val}]}|Sis]; + [{test,is_eq_exact,{f,Fail},[R,{type(Type),Val}]}|Sis]; select_val_cg(Type, R, [Val, {f,Lbl}], Tf, Vf, [{label,Lbl}|Sis]) -> [{test,select_type_test(Type),{f,Tf},[R]}, - {test,is_eq_exact,{f,Vf},[R,{Type,Val}]}|Sis]; + {test,is_eq_exact,{f,Vf},[R,{type(Type),Val}]}|Sis]; select_val_cg(Type, R, Vls0, Tf, Vf, Sis) -> - Vls1 = [case Value of {f,_Lbl} -> Value; _ -> {Type,Value} end || Value <- Vls0], + Vls1 = [case Value of + {f,_Lbl} -> Value; + _ -> {type(Type),Value} + end || Value <- Vls0], [{test,select_type_test(Type),{f,Tf},[R]}, {select_val,R,{f,Vf},{list,Vls1}}|Sis]. - -select_type_test(integer) -> is_integer; -select_type_test(atom) -> is_atom; -select_type_test(float) -> is_float. + +type(k_atom) -> atom; +type(k_float) -> float; +type(k_int) -> integer. + +select_type_test(k_int) -> is_integer; +select_type_test(k_atom) -> is_atom; +select_type_test(k_float) -> is_float. combine([{Is,Vs1}, {Is,Vs2}|Vis]) -> combine([{Is,Vs1 ++ Vs2}|Vis]); combine([V|Vis]) -> [V|combine(Vis)]; @@ -695,36 +1136,50 @@ add_vls([V|Vs], Lbl, Acc) -> add_vls(Vs, Lbl, [V, {f,Lbl}|Acc]); add_vls([], _, Acc) -> Acc. -select_cons(#l{ke={val_clause,{cons,Es},B},i=I,vdb=Vdb}, V, Tf, Vf, Bef, St0) -> +select_literal(S, V, Tf, Vf, Bef, St) -> + Reg = fetch_var(V, Bef), + F = fun(ValClause, Fail, St0) -> + {Val,Is,Aft,St1} = select_val(ValClause, V, Vf, Bef, St0), + Test = {test,is_eq_exact,{f,Fail},[Reg,{literal,Val}]}, + {[Test|Is],Aft,St1} + end, + match_fmf(F, Tf, St, S). + +select_cons(#k_val_clause{val=#k_cons{hd=Hd,tl=Tl},body=B,anno=#l{i=I,vdb=Vdb}}, + V, Tf, Vf, Bef, St0) -> + Es = [Hd,Tl], {Eis,Int,St1} = select_extract_cons(V, Es, I, Vdb, Bef, St0), {Bis,Aft,St2} = match_cg(B, Vf, Int, St1), {[{test,is_nonempty_list,{f,Tf},[fetch_var(V, Bef)]}] ++ Eis ++ Bis,Aft,St2}. -select_nil(#l{ke={val_clause,nil,B}}, V, Tf, Vf, Bef, St0) -> +select_nil(#k_val_clause{val=#k_nil{},body=B}, V, Tf, Vf, Bef, St0) -> {Bis,Aft,St1} = match_cg(B, Vf, Bef, St0), {[{test,is_nil,{f,Tf},[fetch_var(V, Bef)]}] ++ Bis,Aft,St1}. -select_binary(#l{ke={val_clause,{binary,{var,V}},B},i=I,vdb=Vdb}, - V, Tf, Vf, Bef, St0) -> +select_binary(#k_val_clause{val=#k_binary{segs=#k_var{name=V}},body=B, + anno=#l{i=I,vdb=Vdb}}, V, Tf, Vf, Bef, St0) -> + #cg{ctx=OldCtx} = St0, Int0 = clear_dead(Bef#sr{reg=Bef#sr.reg}, I, Vdb), - {Bis0,Aft,St1} = match_cg(B, Vf, Int0, St0), + {Bis0,Aft,St1} = match_cg(B, Vf, Int0, St0#cg{ctx=V}), CtxReg = fetch_var(V, Int0), Live = max_reg(Bef#sr.reg), - Bis1 = [{test,bs_start_match2,{f,Tf},Live,[CtxReg,V],CtxReg}, + Bis1 = [{test,bs_start_match2,{f,Tf},Live,[CtxReg,{context,V}],CtxReg}, {bs_save2,CtxReg,{V,V}}|Bis0], Bis = finish_select_binary(Bis1), - {Bis,Aft,St1}; -select_binary(#l{ke={val_clause,{binary,{var,Ivar}},B},i=I,vdb=Vdb}, - V, Tf, Vf, Bef, St0) -> + {Bis,Aft,St1#cg{ctx=OldCtx}}; +select_binary(#k_val_clause{val=#k_binary{segs=#k_var{name=Ivar}},body=B, + anno=#l{i=I,vdb=Vdb}}, V, Tf, Vf, Bef, St0) -> + #cg{ctx=OldCtx} = St0, Regs = put_reg(Ivar, Bef#sr.reg), Int0 = clear_dead(Bef#sr{reg=Regs}, I, Vdb), - {Bis0,Aft,St1} = match_cg(B, Vf, Int0, St0), + {Bis0,Aft,St1} = match_cg(B, Vf, Int0, St0#cg{ctx=Ivar}), CtxReg = fetch_var(Ivar, Int0), Live = max_reg(Bef#sr.reg), - Bis1 = [{test,bs_start_match2,{f,Tf},Live,[fetch_var(V, Bef),Ivar],CtxReg}, + Bis1 = [{test,bs_start_match2,{f,Tf},Live, + [fetch_var(V, Bef),{context,Ivar}],CtxReg}, {bs_save2,CtxReg,{Ivar,Ivar}}|Bis0], Bis = finish_select_binary(Bis1), - {Bis,Aft,St1}. + {Bis,Aft,St1#cg{ctx=OldCtx}}. finish_select_binary([{bs_save2,R,Point}=I,{bs_restore2,R,Point}|Is]) -> [I|finish_select_binary(Is)]; @@ -746,9 +1201,16 @@ select_bin_segs(Scs, Ivar, Tf, Bef, St) -> select_bin_seg(S, Ivar, Fail, Bef, Sta) end, Tf, St, Scs). -select_bin_seg(#l{ke={val_clause,{bin_seg,Ctx,Size,U,T,Fs0,Es},B},i=I,vdb=Vdb,a=A}, - Ivar, Fail, Bef, St0) -> +select_bin_seg(#k_val_clause{val=#k_bin_seg{size=Size,unit=U,type=T, + seg=Seg,flags=Fs0,next=Next}, + body=B, + anno=#l{i=I,vdb=Vdb,a=A}}, Ivar, Fail, Bef, St0) -> + Ctx = St0#cg.ctx, Fs = [{anno,A}|Fs0], + Es = case Next of + [] -> [Seg]; + _ -> [Seg,Next] + end, {Mis,Int,St1} = select_extract_bin(Es, Size, U, T, Fs, Fail, I, Vdb, Bef, Ctx, B, St0), {Bis,Aft,St2} = match_cg(B, Fail, Int, St1), @@ -761,9 +1223,12 @@ select_bin_seg(#l{ke={val_clause,{bin_seg,Ctx,Size,U,T,Fs0,Es},B},i=I,vdb=Vdb,a= [{bs_restore2,CtxReg,{Ctx,Ivar}}|Mis++Bis] end, {Is,Aft,St2}; -select_bin_seg(#l{ke={val_clause,{bin_int,Ctx,Sz,U,Fs,Val,Es},B},i=I,vdb=Vdb}, - Ivar, Fail, Bef, St0) -> - {Mis,Int,St1} = select_extract_int(Es, Val, Sz, U, Fs, Fail, +select_bin_seg(#k_val_clause{val=#k_bin_int{size=Sz,unit=U,flags=Fs, + val=Val,next=Next}, + body=B, + anno=#l{i=I,vdb=Vdb}}, Ivar, Fail, Bef, St0) -> + Ctx = St0#cg.ctx, + {Mis,Int,St1} = select_extract_int(Next, Val, Sz, U, Fs, Fail, I, Vdb, Bef, Ctx, St0), {Bis,Aft,St2} = match_cg(B, Fail, Int, St1), CtxReg = fetch_var(Ctx, Bef), @@ -784,7 +1249,7 @@ select_bin_seg(#l{ke={val_clause,{bin_int,Ctx,Sz,U,Fs,Val,Es},B},i=I,vdb=Vdb}, end, {[{bs_restore2,CtxReg,{Ctx,Ivar}}|Is],Aft,St2}. -select_extract_int([{var,Tl}], Val, {integer,Sz}, U, Fs, Vf, +select_extract_int(#k_var{name=Tl}, Val, #k_int{val=Sz}, U, Fs, Vf, I, Vdb, Bef, Ctx, St) -> Bits = U*Sz, Bin = case member(big, Fs) of @@ -805,7 +1270,7 @@ select_extract_int([{var,Tl}], Val, {integer,Sz}, U, Fs, Vf, end, {Is,clear_dead(Bef, I, Vdb),St}. -select_extract_bin([{var,Hd},{var,Tl}], Size0, Unit, Type, Flags, Vf, +select_extract_bin([#k_var{name=Hd},#k_var{name=Tl}], Size0, Unit, Type, Flags, Vf, I, Vdb, Bef, Ctx, _Body, St) -> SizeReg = get_bin_size_reg(Size0, Bef), {Es,Aft} = @@ -828,11 +1293,11 @@ select_extract_bin([{var,Hd},{var,Tl}], Size0, Unit, Type, Flags, Vf, {bs_save2,CtxReg,{Ctx,Tl}}],Int1} end, {Es,clear_dead(Aft, I, Vdb),St}; -select_extract_bin([{var,Hd}], Size, Unit, binary, Flags, Vf, +select_extract_bin([#k_var{name=Hd}], Size, Unit, binary, Flags, Vf, I, Vdb, Bef, Ctx, Body, St) -> %% Match the last segment of a binary. We KNOW that the size %% must be 'all'. - Size = {atom,all}, %Assertion. + #k_atom{val=all} = Size, %Assertion. {Es,Aft} = case vdb_find(Hd, Vdb) of {_,_,Lhd} when Lhd =< I -> @@ -857,7 +1322,7 @@ select_extract_bin([{var,Hd}], Size, Unit, binary, Flags, Vf, Name = bs_get_binary2, Live = max_reg(Bef#sr.reg), {[{test,Name,{f,Vf},Live, - [CtxReg,Size,Unit,{field_flags,Flags}],Rhd}], + [CtxReg,atomic(Size),Unit,{field_flags,Flags}],Rhd}], Int1}; true -> %% Since the matching context will not be used again, @@ -872,36 +1337,42 @@ select_extract_bin([{var,Hd}], Size, Unit, binary, Flags, Vf, Name = bs_get_binary2, Live = max_reg(Int1#sr.reg), {[{test,Name,{f,Vf},Live, - [CtxReg,Size,Unit,{field_flags,Flags}],CtxReg}], + [CtxReg,atomic(Size),Unit,{field_flags,Flags}],CtxReg}], Int1} end end, {Es,clear_dead(Aft, I, Vdb),St}. %% is_context_unused(Ke) -> true | false -%% Simple heurististic to determine whether the code that follows will -%% use the current matching context again. (The information of liveness -%% calculcated by v3_life is too conservative to be useful for this purpose.) -%% 'true' means that the code that follows will definitely not use the context -%% again (because it is a block, not guard or matching code); 'false' that we -%% are not sure (there is either a guard, or more matching, either which may -%% reference the context again). - -is_context_unused(#l{ke=Ke}) -> is_context_unused(Ke); -is_context_unused({block,_}) -> true; -is_context_unused(_) -> false. - -select_bin_end(#l{ke={val_clause,{bin_end,Ctx},B}}, - Ivar, Tf, Bef, St0) -> +%% Simple heurististic to determine whether the code that follows +%% will use the current matching context again. (The liveness +%% information is too conservative to be useful for this purpose.) +%% 'true' means that the code that follows will definitely not use +%% the context again (because it is a block, not guard or matching +%% code); 'false' that we are not sure (there could be more +%% matching). + +is_context_unused(#k_alt{then=Then}) -> + %% #k_alt{} can be used for different purposes. If the Then part + %% is a block, it means that matching has finished and is used for a guard + %% to choose between the matched clauses. + is_context_unused(Then); +is_context_unused(#cg_block{}) -> + true; +is_context_unused(_) -> + false. + +select_bin_end(#k_val_clause{val=#k_bin_end{},body=B}, Ivar, Tf, Bef, St0) -> + Ctx = St0#cg.ctx, {Bis,Aft,St2} = match_cg(B, Tf, Bef, St0), CtxReg = fetch_var(Ctx, Bef), {[{bs_restore2,CtxReg,{Ctx,Ivar}}, {test,bs_test_tail2,{f,Tf},[CtxReg,0]}|Bis],Aft,St2}. -get_bin_size_reg({var,V}, Bef) -> +get_bin_size_reg(#k_var{name=V}, Bef) -> fetch_var(V, Bef); get_bin_size_reg(Literal, _Bef) -> - Literal. + atomic(Literal). build_bs_instr(Type, Vf, CtxReg, Live, SizeReg, Unit, Flags, Rhd) -> {Format,Name} = case Type of @@ -935,11 +1406,18 @@ build_skip_instr(Type, Vf, CtxReg, Live, SizeReg, Unit, Flags) -> {test,Name,{f,Vf},[CtxReg,Live,{field_flags,Flags}]} end. -select_val(#l{ke={val_clause,{tuple,Es},B},i=I,vdb=Vdb}, V, Vf, Bef, St0) -> +select_val(#k_val_clause{val=#k_tuple{es=Es},body=B,anno=#l{i=I,vdb=Vdb}}, + V, Vf, Bef, St0) -> {Eis,Int,St1} = select_extract_tuple(V, Es, I, Vdb, Bef, St0), {Bis,Aft,St2} = match_cg(B, Vf, Int, St1), {length(Es),Eis ++ Bis,Aft,St2}; -select_val(#l{ke={val_clause,{_,Val},B}}, _V, Vf, Bef, St0) -> +select_val(#k_val_clause{val=Val0,body=B}, _V, Vf, Bef, St0) -> + Val = case Val0 of + #k_atom{val=Lit} -> Lit; + #k_float{val=Lit} -> Lit; + #k_int{val=Lit} -> Lit; + #k_literal{val=Lit} -> Lit + end, {Bis,Aft,St1} = match_cg(B, Vf, Bef, St0), {Val,Bis,Aft,St1}. @@ -948,7 +1426,7 @@ select_val(#l{ke={val_clause,{_,Val},B}}, _V, Vf, Bef, St0) -> %% Extract tuple elements, but only if they do not immediately die. select_extract_tuple(Src, Vs, I, Vdb, Bef, St) -> - F = fun ({var,V}, {Int0,Elem}) -> + F = fun (#k_var{name=V}, {Int0,Elem}) -> case vdb_find(V, Vdb) of {V,_,L} when L =< I -> {[], {Int0,Elem+1}}; _Other -> @@ -965,9 +1443,10 @@ select_extract_tuple(Src, Vs, I, Vdb, Bef, St) -> select_map(Scs, V, Tf, Vf, Bef, St0) -> Reg = fetch_var(V, Bef), {Is,Aft,St1} = - match_fmf(fun(#l{ke={val_clause,{map,exact,_,Es},B},i=I,vdb=Vdb}, Fail, St1) -> - select_map_val(V, Es, B, Fail, I, Vdb, Bef, St1) - end, Vf, St0, Scs), + match_fmf(fun(#k_val_clause{val=#k_map{op=exact,es=Es}, + body=B,anno=#l{i=I,vdb=Vdb}}, Fail, St1) -> + select_map_val(V, Es, B, Fail, I, Vdb, Bef, St1) + end, Vf, St0, Scs), {[{test,is_map,{f,Tf},[Reg]}|Is],Aft,St1}. select_map_val(V, Es, B, Fail, I, Vdb, Bef, St0) -> @@ -984,29 +1463,32 @@ select_extract_map(Src, Vs, Fail, I, Vdb, Bef, St) -> %% Assume keys are term-sorted Rsrc = fetch_var(Src, Bef), - {{HasKs,GetVs,HasVarKs,GetVarVs},Aft} = lists:foldr(fun - ({map_pair,{var,K},{var,V}},{{HasKsi,GetVsi,HasVarVsi,GetVarVsi},Int0}) -> - case vdb_find(V, Vdb) of - {V,_,L} when L =< I -> - RK = fetch_var(K,Int0), - {{HasKsi,GetVsi,[RK|HasVarVsi],GetVarVsi},Int0}; - _Other -> - Reg1 = put_reg(V, Int0#sr.reg), - Int1 = Int0#sr{reg=Reg1}, - RK = fetch_var(K,Int0), - RV = fetch_reg(V,Reg1), - {{HasKsi,GetVsi,HasVarVsi,[[RK,RV]|GetVarVsi]},Int1} - end; - ({map_pair,Key,{var,V}},{{HasKsi,GetVsi,HasVarVsi,GetVarVsi},Int0}) -> - case vdb_find(V, Vdb) of - {V,_,L} when L =< I -> - {{[Key|HasKsi],GetVsi,HasVarVsi,GetVarVsi},Int0}; - _Other -> - Reg1 = put_reg(V, Int0#sr.reg), - Int1 = Int0#sr{reg=Reg1}, - {{HasKsi,[Key,fetch_reg(V, Reg1)|GetVsi],HasVarVsi,GetVarVsi},Int1} - end - end, {{[],[],[],[]},Bef}, Vs), + {{HasKs,GetVs,HasVarKs,GetVarVs},Aft} = + foldr(fun(#k_map_pair{key=#k_var{name=K},val=#k_var{name=V}}, + {{HasKsi,GetVsi,HasVarVsi,GetVarVsi},Int0}) -> + case vdb_find(V, Vdb) of + {V,_,L} when L =< I -> + RK = fetch_var(K,Int0), + {{HasKsi,GetVsi,[RK|HasVarVsi],GetVarVsi},Int0}; + _Other -> + Reg1 = put_reg(V, Int0#sr.reg), + Int1 = Int0#sr{reg=Reg1}, + RK = fetch_var(K,Int0), + RV = fetch_reg(V,Reg1), + {{HasKsi,GetVsi,HasVarVsi,[[RK,RV]|GetVarVsi]},Int1} + end; + (#k_map_pair{key=Key,val=#k_var{name=V}}, + {{HasKsi,GetVsi,HasVarVsi,GetVarVsi},Int0}) -> + case vdb_find(V, Vdb) of + {V,_,L} when L =< I -> + {{[atomic(Key)|HasKsi],GetVsi,HasVarVsi,GetVarVsi},Int0}; + _Other -> + Reg1 = put_reg(V, Int0#sr.reg), + Int1 = Int0#sr{reg=Reg1}, + {{HasKsi,[atomic(Key),fetch_reg(V, Reg1)|GetVsi], + HasVarVsi,GetVarVsi},Int1} + end + end, {{[],[],[],[]},Bef}, Vs), Code = [{test,has_map_fields,{f,Fail},Rsrc,{list,HasKs}} || HasKs =/= []] ++ [{test,has_map_fields,{f,Fail},Rsrc,{list,[K]}} || K <- HasVarKs] ++ @@ -1015,30 +1497,36 @@ select_extract_map(Src, Vs, Fail, I, Vdb, Bef, St) -> {Code, Aft, St}. -select_extract_cons(Src, [{var,Hd}, {var,Tl}], I, Vdb, Bef, St) -> - {Es,Aft} = case {vdb_find(Hd, Vdb), vdb_find(Tl, Vdb)} of - {{_,_,Lhd}, {_,_,Ltl}} when Lhd =< I, Ltl =< I -> - %% Both head and tail are dead. No need to generate - %% any instruction. - {[], Bef}; - _ -> - %% At least one of head and tail will be used, - %% but we must always fetch both. We will call - %% clear_dead/2 to allow reuse of the register - %% in case only of them is used. - - Reg0 = put_reg(Tl, put_reg(Hd, Bef#sr.reg)), - Int0 = Bef#sr{reg=Reg0}, - Rsrc = fetch_var(Src, Int0), - Rhd = fetch_reg(Hd, Reg0), - Rtl = fetch_reg(Tl, Reg0), - Int1 = clear_dead(Int0, I, Vdb), - {[{get_list,Rsrc,Rhd,Rtl}], Int1} - end, - {Es,Aft,St}. - +select_extract_cons(Src, [#k_var{name=Hd},#k_var{name=Tl}], I, Vdb, Bef, St) -> + Rsrc = fetch_var(Src, Bef), + Int = clear_dead(Bef, I, Vdb), + {{_,_,Lhd},{_,_,Ltl}} = {vdb_find(Hd, Vdb),vdb_find(Tl, Vdb)}, + case {Lhd =< I, Ltl =< I} of + {true,true} -> + %% Both dead. + {[],Bef,St}; + {true,false} -> + %% Head dead. + Reg0 = put_reg(Tl, Bef#sr.reg), + Aft = Int#sr{reg=Reg0}, + Rtl = fetch_reg(Tl, Reg0), + {[{get_tl,Rsrc,Rtl}],Aft,St}; + {false,true} -> + %% Tail dead. + Reg0 = put_reg(Hd, Bef#sr.reg), + Aft = Int#sr{reg=Reg0}, + Rhd = fetch_reg(Hd, Reg0), + {[{get_hd,Rsrc,Rhd}],Aft,St}; + {false,false} -> + %% Both used. + Reg0 = put_reg(Tl, put_reg(Hd, Bef#sr.reg)), + Aft = Bef#sr{reg=Reg0}, + Rhd = fetch_reg(Hd, Reg0), + Rtl = fetch_reg(Tl, Reg0), + {[{get_hd,Rsrc,Rhd},{get_tl,Rsrc,Rtl}],Aft,St} + end. -guard_clause_cg(#l{ke={guard_clause,G,B},vdb=Vdb}, Fail, Bef, St0) -> +guard_clause_cg(#k_guard_clause{anno=#l{vdb=Vdb},guard=G,body=B}, Fail, Bef, St0) -> {Gis,Int,St1} = guard_cg(G, Fail, Vdb, Bef, St0), {Bis,Aft,St} = match_cg(B, Fail, Int, St1), {Gis ++ Bis,Aft,St}. @@ -1051,11 +1539,11 @@ guard_clause_cg(#l{ke={guard_clause,G,B},vdb=Vdb}, Fail, Bef, St0) -> %% the correct exit point. Primops and tests all go to the next %% instruction on success or jump to a failure label. -guard_cg(#l{ke={protected,Ts,Rs},i=I,vdb=Pdb}, Fail, _Vdb, Bef, St) -> - protected_cg(Ts, Rs, Fail, I, Pdb, Bef, St); -guard_cg(#l{ke={block,Ts},i=I,vdb=Bdb}, Fail, _Vdb, Bef, St) -> - guard_cg_list(Ts, Fail, I, Bdb, Bef, St); -guard_cg(#l{ke={test,Test,As,Inverted},i=I,vdb=_Tdb}, Fail, Vdb, Bef, St0) -> +guard_cg(#k_protected{arg=Ts,ret=Rs,anno=#l{vdb=Pdb}}, Fail, _Vdb, Bef, St) -> + protected_cg(Ts, Rs, Fail, Pdb, Bef, St); +guard_cg(#k_test{anno=#l{i=I},op=Test0,args=As,inverted=Inverted}, + Fail, Vdb, Bef, St0) -> + #k_remote{mod=#k_atom{val=erlang},name=#k_atom{val=Test}} = Test0, case Inverted of false -> test_cg(Test, As, Fail, I, Vdb, Bef, St0); @@ -1070,6 +1558,18 @@ guard_cg(G, _Fail, Vdb, Bef, St) -> %%ok = io:fwrite("cg ~w: ~p~n", [?LINE,{Aft}]), {Gis,Aft,St1}. +%% guard_cg_list([Kexpr], Fail, I, Vdb, StackReg, St) -> +%% {[Ainstr],StackReg,St}. + +guard_cg_list(Kes, Fail, Vdb, Bef, St0) -> + {Keis,{Aft,St1}} = + flatmapfoldl(fun (Ke, {Inta,Sta}) -> + {Keis,Intb,Stb} = + guard_cg(Ke, Fail, Vdb, Inta, Sta), + {Keis,{Intb,Stb}} + end, {Bef,St0}, need_heap(Kes)), + {Keis,Aft,St1}. + %% protected_cg([Kexpr], [Ret], Fail, I, Vdb, Bef, St) -> {[Ainstr],Aft,St}. %% Do a protected. Protecteds without return values are just done %% for effect, the return value is not checked, success passes on to @@ -1077,19 +1577,18 @@ guard_cg(G, _Fail, Vdb, Bef, St) -> %% return values then these must be set to 'false' on failure, %% control always passes to the next instruction. -protected_cg(Ts, [], Fail, I, Vdb, Bef, St0) -> +protected_cg(Ts, [], Fail, Vdb, Bef, St0) -> %% Protect these calls, revert when done. - {Tis,Aft,St1} = guard_cg_list(Ts, Fail, I, Vdb, Bef, - St0#cg{bfail=Fail}), + {Tis,Aft,St1} = guard_cg_list(Ts, Fail, Vdb, Bef, St0#cg{bfail=Fail}), {Tis,Aft,St1#cg{bfail=St0#cg.bfail}}; -protected_cg(Ts, Rs, _Fail, I, Vdb, Bef, St0) -> +protected_cg(Ts, Rs, _Fail, Vdb, Bef, St0) -> {Pfail,St1} = new_label(St0), {Psucc,St2} = new_label(St1), - {Tis,Aft,St3} = guard_cg_list(Ts, Pfail, I, Vdb, Bef, + {Tis,Aft,St3} = guard_cg_list(Ts, Pfail, Vdb, Bef, St2#cg{bfail=Pfail}), %%ok = io:fwrite("cg ~w: ~p~n", [?LINE,{Rs,I,Vdb,Aft}]), %% Set return values to false. - Mis = [{move,{atom,false},fetch_var(V,Aft)}||{var,V} <- Rs], + Mis = [{move,{atom,false},fetch_var(V,Aft)}||#k_var{name=V} <- Rs], {Tis ++ [{jump,{f,Psucc}}, {label,Pfail}] ++ Mis ++ [{label,Psucc}], Aft,St3#cg{bfail=St0#cg.bfail}}. @@ -1114,7 +1613,7 @@ test_cg(is_map, [A], Fail, I, Vdb, Bef, St) -> Arg = cg_reg_arg_prefer_y(A, Bef), Aft = clear_dead(Bef, I, Vdb), {[{test,is_map,{f,Fail},[Arg]}],Aft,St}; -test_cg(is_boolean, [{atom,Val}], Fail, I, Vdb, Bef, St) -> +test_cg(is_boolean, [#k_atom{val=Val}], Fail, I, Vdb, Bef, St) -> Aft = clear_dead(Bef, I, Vdb), Is = case is_boolean(Val) of true -> []; @@ -1126,18 +1625,6 @@ test_cg(Test, As, Fail, I, Vdb, Bef, St) -> Aft = clear_dead(Bef, I, Vdb), {[beam_utils:bif_to_test(Test, Args, {f,Fail})],Aft,St}. -%% guard_cg_list([Kexpr], Fail, I, Vdb, StackReg, St) -> -%% {[Ainstr],StackReg,St}. - -guard_cg_list(Kes, Fail, I, Vdb, Bef, St0) -> - {Keis,{Aft,St1}} = - flatmapfoldl(fun (Ke, {Inta,Sta}) -> - {Keis,Intb,Stb} = - guard_cg(Ke, Fail, Vdb, Inta, Sta), - {Keis,{Intb,Stb}} - end, {Bef,St0}, need_heap(Kes, I)), - {Keis,Aft,St1}. - %% match_fmf(Fun, LastFail, State, [Clause]) -> {Is,Aft,State}. %% This is a special flatmapfoldl for match code gen where we %% generate a "failure" label for each clause. The last clause uses @@ -1160,7 +1647,7 @@ match_fmf(F, LastFail, St0, [H|T]) -> %% frame size. Finally the actual call is made. Call then needs the %% return values filled in. -call_cg({var,_V} = Var, As, Rs, Le, Vdb, Bef, St0) -> +call_cg(#k_var{}=Var, As, Rs, Le, Vdb, Bef, St0) -> {Sis,Int} = cg_setup_call(As++[Var], Bef, Le#l.i, Vdb), %% Put return values in registers. Reg = load_vars(Rs, clear_regs(Int#sr.reg)), @@ -1169,9 +1656,8 @@ call_cg({var,_V} = Var, As, Rs, Le, Vdb, Bef, St0) -> {Frees,Aft} = free_dead(clear_dead(Int#sr{reg=Reg}, Le#l.i, Vdb)), {Sis ++ Frees ++ [line(Le),{call_fun,Arity}],Aft, need_stack_frame(St0)}; -call_cg({remote,Mod,Name}, As, Rs, Le, Vdb, Bef, St0) - when element(1, Mod) =:= var; - element(1, Name) =:= var -> +call_cg(#k_remote{mod=Mod,name=Name}, As, Rs, Le, Vdb, Bef, St0) + when is_record(Mod, k_var); is_record(Name, k_var) -> {Sis,Int} = cg_setup_call(As++[Mod,Name], Bef, Le#l.i, Vdb), %% Put return values in registers. Reg = load_vars(Rs, clear_regs(Int#sr.reg)), @@ -1189,8 +1675,9 @@ call_cg(Func, As, Rs, Le, Vdb, Bef, St0) -> %% %% move {atom,ok} DestReg %% jump FailureLabel - {remote,{atom,erlang},{atom,error}} = Func, %Assertion. - [{var,DestVar}] = Rs, + #k_remote{mod=#k_atom{val=erlang}, + name=#k_atom{val=error}} = Func, %Assertion. + [#k_var{name=DestVar}] = Rs, Int0 = clear_dead(Bef, Le#l.i, Vdb), Reg = put_reg(DestVar, Int0#sr.reg), Int = Int0#sr{reg=Reg}, @@ -1209,11 +1696,11 @@ call_cg(Func, As, Rs, Le, Vdb, Bef, St0) -> {Sis ++ Frees ++ [line(Le)|Call],Aft,St1} end. -build_call({remote,{atom,erlang},{atom,'!'}}, 2, St0) -> +build_call(#k_remote{mod=#k_atom{val=erlang},name=#k_atom{val='!'}}, 2, St0) -> {[send],need_stack_frame(St0)}; -build_call({remote,{atom,Mod},{atom,Name}}, Arity, St0) -> +build_call(#k_remote{mod=#k_atom{val=Mod},name=#k_atom{val=Name}}, Arity, St0) -> {[{call_ext,Arity,{extfunc,Mod,Name,Arity}}],need_stack_frame(St0)}; -build_call(Name, Arity, St0) when is_atom(Name) -> +build_call(#k_local{name=Name}, Arity, St0) when is_atom(Name) -> {Lbl,St1} = local_func_label(Name, Arity, need_stack_frame(St0)), {[{call,Arity,{f,Lbl}}],St1}. @@ -1229,16 +1716,15 @@ free_dead([Any|Stk], Y, Instr, StkAcc) -> free_dead(Stk, Y+1, Instr, [Any|StkAcc]); free_dead([], _, Instr, StkAcc) -> {Instr,reverse(StkAcc)}. -enter_cg({var,_V} = Var, As, Le, Vdb, Bef, St0) -> +enter_cg(#k_var{} = Var, As, Le, Vdb, Bef, St0) -> {Sis,Int} = cg_setup_call(As++[Var], Bef, Le#l.i, Vdb), %% Build complete code and final stack/register state. Arity = length(As), {Sis ++ [line(Le),{call_fun,Arity},return], clear_dead(Int#sr{reg=clear_regs(Int#sr.reg)}, Le#l.i, Vdb), need_stack_frame(St0)}; -enter_cg({remote,Mod,Name}, As, Le, Vdb, Bef, St0) - when element(1, Mod) =:= var; - element(1, Name) =:= var -> +enter_cg(#k_remote{mod=Mod,name=Name}, As, Le, Vdb, Bef, St0) + when is_record(Mod, k_var); is_record(Name, k_var) -> {Sis,Int} = cg_setup_call(As++[Mod,Name], Bef, Le#l.i, Vdb), %% Build complete code and final stack/register state. Arity = length(As), @@ -1256,19 +1742,19 @@ enter_cg(Func, As, Le, Vdb, Bef, St0) -> clear_dead(Int#sr{reg=clear_regs(Int#sr.reg)}, Le#l.i, Vdb), St1}. -build_enter({remote,{atom,erlang},{atom,'!'}}, 2, St0) -> +build_enter(#k_remote{mod=#k_atom{val=erlang},name=#k_atom{val='!'}}, 2, St0) -> {[send,return],need_stack_frame(St0)}; -build_enter({remote,{atom,Mod},{atom,Name}}, Arity, St0) -> +build_enter(#k_remote{mod=#k_atom{val=Mod},name=#k_atom{val=Name}}, Arity, St0) -> St1 = case trap_bif(Mod, Name, Arity) of true -> need_stack_frame(St0); false -> St0 end, {[{call_ext_only,Arity,{extfunc,Mod,Name,Arity}}],St1}; -build_enter(Name, Arity, St0) when is_atom(Name) -> +build_enter(#k_local{name=Name}, Arity, St0) when is_atom(Name) -> {Lbl,St1} = local_func_label(Name, Arity, St0), {[{call_only,Arity,{f,Lbl}}],St1}. -enter_line({remote,{atom,Mod},{atom,Name}}, Arity, Le) -> +enter_line(#k_remote{mod=#k_atom{val=Mod},name=#k_atom{val=Name}}, Arity, Le) -> case erl_bifs:is_safe(Mod, Name, Arity) of false -> %% Tail-recursive call, possibly to a BIF. @@ -1316,17 +1802,28 @@ trap_bif(erlang, group_leader, 2) -> true; trap_bif(erlang, exit, 2) -> true; trap_bif(_, _, _) -> false. +%% bif_cg(#k_bif{}, Le, Vdb, StackReg, State) -> +%% {[Ainstr],StackReg,State}. +%% Generate code a BIF. + +bif_cg(#k_bif{op=#k_internal{name=Name},args=As,ret=Rs}, Le, Vdb, Bef, St) -> + internal_cg(Name, As, Rs, Le, Vdb, Bef, St); +bif_cg(#k_bif{op=#k_remote{mod=#k_atom{val=erlang},name=#k_atom{val=Name}}, + args=As,ret=Rs}, Le, Vdb, Bef, St) -> + Ar = length(As), + case is_gc_bif(Name, Ar) of + false -> + bif_cg(Name, As, Rs, Le, Vdb, Bef, St); + true -> + gc_bif_cg(Name, As, Rs, Le, Vdb, Bef, St) + end. + %% internal_cg(Bif, [Arg], [Ret], Le, Vdb, StackReg, State) -> %% {[Ainstr],StackReg,State}. internal_cg(bs_context_to_binary=Instr, [Src0], [], Le, Vdb, Bef, St0) -> [Src] = cg_reg_args([Src0], Bef), - case is_register(Src) of - false -> - {[],clear_dead(Bef, Le#l.i, Vdb), St0}; - true -> - {[{Instr,Src}],clear_dead(Bef, Le#l.i, Vdb), St0} - end; + {[{Instr,Src}],clear_dead(Bef, Le#l.i, Vdb), St0}; internal_cg(dsetelement, [Index0,Tuple0,New0], _Rs, Le, Vdb, Bef, St0) -> [New,Tuple,{integer,Index1}] = cg_reg_args([New0,Tuple0,Index0], Bef), Index = Index1-1, @@ -1334,8 +1831,8 @@ internal_cg(dsetelement, [Index0,Tuple0,New0], _Rs, Le, Vdb, Bef, St0) -> clear_dead(Bef, Le#l.i, Vdb), St0}; internal_cg(make_fun, [Func0,Arity0|As], Rs, Le, Vdb, Bef, St0) -> %% This behaves more like a function call. - {atom,Func} = Func0, - {integer,Arity} = Arity0, + #k_atom{val=Func} = Func0, + #k_int{val=Arity} = Arity0, {Sis,Int} = cg_setup_call(As, Bef, Le#l.i, Vdb), Reg = load_vars(Rs, clear_regs(Int#sr.reg)), {FuncLbl,St1} = local_func_label(Func, Arity, St0), @@ -1348,14 +1845,35 @@ internal_cg(bs_init_writable=I, As, Rs, Le, Vdb, Bef, St) -> {Sis,Int} = cg_setup_call(As, Bef, Le#l.i, Vdb), Reg = load_vars(Rs, clear_regs(Int#sr.reg)), {Sis++[I],clear_dead(Int#sr{reg=Reg}, Le#l.i, Vdb),St}; +internal_cg(build_stacktrace=I, As, Rs, Le, Vdb, Bef, St) -> + %% This behaves like a function call. + {Sis,Int} = cg_setup_call(As, Bef, Le#l.i, Vdb), + Reg = load_vars(Rs, clear_regs(Int#sr.reg)), + {Sis++[I],clear_dead(Int#sr{reg=Reg}, Le#l.i, Vdb),St}; internal_cg(raise, As, Rs, Le, Vdb, Bef, St) -> %% raise can be treated like a guard BIF. - bif_cg(raise, As, Rs, Le, Vdb, Bef, St). + bif_cg(raise, As, Rs, Le, Vdb, Bef, St); +internal_cg(guard_error, [ExitCall], _Rs, Le, Vdb, Bef, St) -> + %% A call an exit BIF from inside a #k_guard_match{}. + %% Generate a standard call, but leave the register descriptors + %% alone, effectively pretending that there was no call. + #k_call{op=#k_remote{mod=#k_atom{val=Mod},name=#k_atom{val=Name}}, + args=As} = ExitCall, + Arity = length(As), + {Ms,_} = cg_call_args(As, Bef, Le#l.i, Vdb), + Call = {call_ext,Arity,{extfunc,Mod,Name,Arity}}, + Is = Ms++[line(Le),Call], + {Is,Bef,St}; +internal_cg(raw_raise=I, As, Rs, Le, Vdb, Bef, St) -> + %% This behaves like a function call. + {Sis,Int} = cg_setup_call(As, Bef, Le#l.i, Vdb), + Reg = load_vars(Rs, clear_regs(Int#sr.reg)), + {Sis++[I],clear_dead(Int#sr{reg=Reg}, Le#l.i, Vdb),St}. %% bif_cg(Bif, [Arg], [Ret], Le, Vdb, StackReg, State) -> %% {[Ainstr],StackReg,State}. -bif_cg(Bif, As, [{var,V}], Le, Vdb, Bef, St0) -> +bif_cg(Bif, As, [#k_var{name=V}], Le, Vdb, Bef, St0) -> Ars = cg_reg_args(As, Bef), %% If we are inside a catch and in a body (not in guard) and the @@ -1393,7 +1911,7 @@ bif_cg(Bif, As, [{var,V}], Le, Vdb, Bef, St0) -> %% gc_bif_cg(Bif, [Arg], [Ret], Le, Vdb, StackReg, State) -> %% {[Ainstr],StackReg,State}. -gc_bif_cg(Bif, As, [{var,V}], Le, Vdb, Bef, St0) -> +gc_bif_cg(Bif, As, [#k_var{name=V}], Le, Vdb, Bef, St0) -> Ars = cg_reg_args(As, Bef), %% If we are inside a catch and in a body (not in guard) and the @@ -1439,7 +1957,7 @@ recv_loop_cg(Te, Rvar, Rm, Tes, Rs, Le, Vdb, Bef, St0) -> %% cg_recv_mesg( ) -> {[Ainstr],Aft,St}. -cg_recv_mesg({var,R}, Rm, Tl, Bef, St0) -> +cg_recv_mesg(#k_var{name=R}, Rm, Tl, Bef, St0) -> Int0 = Bef#sr{reg=put_reg(R, Bef#sr.reg)}, Ret = fetch_reg(R, Int0#sr.reg), %% Int1 = clear_dead(Int0, I, Rm#l.vdb), @@ -1449,22 +1967,22 @@ cg_recv_mesg({var,R}, Rm, Tl, Bef, St0) -> %% cg_recv_wait(Te, Tes, I, Vdb, Int2, St3) -> {[Ainstr],Aft,St}. -cg_recv_wait({atom,infinity}, Tes, I, Bef, St0) -> +cg_recv_wait(#k_atom{val=infinity}, #cg_block{anno=Le,es=Tes}, I, Bef, St0) -> %% We know that the 'after' body will never be executed. %% But to keep the stack and register information up to date, %% we will generate the code for the 'after' body, and then discard it. - Int1 = clear_dead(Bef, I, Tes#l.vdb), - {_,Int2,St1} = cg_block(Tes#l.ke, Tes#l.i, Tes#l.vdb, - Int1#sr{reg=clear_regs(Int1#sr.reg)}, St0), + Int1 = clear_dead(Bef, I, Le#l.vdb), + {_,Int2,St1} = cg_block(Tes, Le#l.vdb, + Int1#sr{reg=clear_regs(Int1#sr.reg)}, St0), {[{wait,{f,St1#cg.recv}}],Int2,St1}; -cg_recv_wait({integer,0}, Tes, _I, Bef, St0) -> - {Tis,Int,St1} = cg_block(Tes#l.ke, Tes#l.i, Tes#l.vdb, Bef, St0), +cg_recv_wait(#k_int{val=0}, #cg_block{anno=Le,es=Tes}, _I, Bef, St0) -> + {Tis,Int,St1} = cg_block(Tes, Le#l.vdb, Bef, St0), {[timeout|Tis],Int,St1}; -cg_recv_wait(Te, Tes, I, Bef, St0) -> +cg_recv_wait(Te, #cg_block{anno=Le,es=Tes}, I, Bef, St0) -> Reg = cg_reg_arg(Te, Bef), %% Must have empty registers here! Bug if anything in registers. - Int0 = clear_dead(Bef, I, Tes#l.vdb), - {Tis,Int,St1} = cg_block(Tes#l.ke, Tes#l.i, Tes#l.vdb, + Int0 = clear_dead(Bef, I, Le#l.vdb), + {Tis,Int,St1} = cg_block(Tes, Le#l.vdb, Int0#sr{reg=clear_regs(Int0#sr.reg)}, St0), {[{wait_timeout,{f,St1#cg.recv},Reg},timeout] ++ Tis,Int,St1}. @@ -1482,7 +2000,7 @@ try_cg(Ta, Vs, Tb, Evs, Th, Rs, Le, Vdb, Bef, St0) -> {B,St1} = new_label(St0), %Body label {H,St2} = new_label(St1), %Handler label {E,St3} = new_label(St2), %End label - TryTag = Ta#l.i, + #l{i=TryTag} = get_kanno(Ta), Int1 = Bef#sr{stk=put_catch(TryTag, Bef#sr.stk)}, TryReg = fetch_stack({catch_tag,TryTag}, Int1#sr.stk), {Ais,Int2,St4} = cg(Ta, Vdb, Int1, St3#cg{break=B,in_catch=true}), @@ -1502,7 +2020,7 @@ try_cg(Ta, Vs, Tb, Evs, Th, Rs, Le, Vdb, Bef, St0) -> try_enter_cg(Ta, Vs, Tb, Evs, Th, Le, Vdb, Bef, St0) -> {B,St1} = new_label(St0), %Body label {H,St2} = new_label(St1), %Handler label - TryTag = Ta#l.i, + #l{i=TryTag} = get_kanno(Ta), Int1 = Bef#sr{stk=put_catch(TryTag, Bef#sr.stk)}, TryReg = fetch_stack({catch_tag,TryTag}, Int1#sr.stk), {Ais,Int2,St3} = cg(Ta, Vdb, Int1, St2#cg{break=B,in_catch=true}), @@ -1520,12 +2038,12 @@ try_enter_cg(Ta, Vs, Tb, Evs, Th, Le, Vdb, Bef, St0) -> %% catch_cg(CatchBlock, Ret, Le, Vdb, Bef, St) -> {[Ainstr],Aft,St}. -catch_cg(C, {var,R}, Le, Vdb, Bef, St0) -> +catch_cg(#cg_block{es=C}, #k_var{name=R}, Le, Vdb, Bef, St0) -> {B,St1} = new_label(St0), CatchTag = Le#l.i, Int1 = Bef#sr{stk=put_catch(CatchTag, Bef#sr.stk)}, CatchReg = fetch_stack({catch_tag,CatchTag}, Int1#sr.stk), - {Cis,Int2,St2} = cg_block(C, Le#l.i, Le#l.vdb, Int1, + {Cis,Int2,St2} = cg_block(C, Le#l.vdb, Int1, St1#cg{break=B,in_catch=true}), [] = Int2#sr.reg, %Assertion. Aft = Int2#sr{reg=[{0,R}],stk=drop_catch(CatchTag, Int2#sr.stk)}, @@ -1534,8 +2052,8 @@ catch_cg(C, {var,R}, Le, Vdb, Bef, St0) -> clear_dead(Aft, Le#l.i, Vdb), St2#cg{break=St1#cg.break,in_catch=St1#cg.in_catch}}. -%% set_cg([Var], Constr, Le, Vdb, Bef, St) -> {[Ainstr],Aft,St}. -%% We have to be careful how a 'set' works. First the structure is +%% put_cg([Var], Constr, Le, Vdb, Bef, St) -> {[Ainstr],Aft,St}. +%% We have to be careful how a 'put' works. First the structure is %% built, then it is filled and finally things can be cleared. The %% annotation must reflect this and make sure that the return %% variable is allocated first. @@ -1543,13 +2061,14 @@ catch_cg(C, {var,R}, Le, Vdb, Bef, St0) -> %% put_list and put_map are atomic instructions, both of %% which can safely resuse one of the source registers as target. -set_cg([{var,R}], {cons,Es}, Le, Vdb, Bef, St) -> - [S1,S2] = cg_reg_args(Es, Bef), +put_cg([#k_var{name=R}], #k_cons{hd=Hd,tl=Tl}, Le, Vdb, Bef, St) -> + [S1,S2] = cg_reg_args([Hd,Tl], Bef), Int0 = clear_dead(Bef, Le#l.i, Vdb), Int1 = Int0#sr{reg=put_reg(R, Int0#sr.reg)}, Ret = fetch_reg(R, Int1#sr.reg), {[{put_list,S1,S2,Ret}], Int1, St}; -set_cg([{var,R}], {binary,Segs}, Le, Vdb, Bef, #cg{bfail=Bfail}=St) -> +put_cg([#k_var{name=R}], #k_binary{segs=Segs}, Le, Vdb, Bef, + #cg{bfail=Bfail}=St) -> %% At run-time, binaries are constructed in three stages: %% 1) First the size of the binary is calculated. %% 2) Then the binary is allocated. @@ -1577,7 +2096,9 @@ set_cg([{var,R}], {binary,Segs}, Le, Vdb, Bef, #cg{bfail=Bfail}=St) -> {Sis++Code,Aft,St}; %% Map: single variable key. -set_cg([{var,R}], {map,Op,Map,[{map_pair,{var,_}=K,V}]}, Le, Vdb, Bef, St0) -> +put_cg([#k_var{name=R}], #k_map{op=Op,var=Map, + es=[#k_map_pair{key=#k_var{}=K,val=V}]}, + Le, Vdb, Bef, St0) -> {Sis,Int0} = maybe_adjust_stack(Bef, Le#l.i, Le#l.i+1, Vdb, St0), SrcReg = cg_reg_arg_prefer_y(Map, Int0), @@ -1592,22 +2113,23 @@ set_cg([{var,R}], {map,Op,Map,[{map_pair,{var,_}=K,V}]}, Le, Vdb, Bef, St0) -> Aft = Aft0#sr{reg=put_reg(R, Aft0#sr.reg)}, Target = fetch_reg(R, Aft#sr.reg), - {Is,St1} = set_cg_map(Line, Op, SrcReg, Target, Live, List, St0), + {Is,St1} = put_cg_map(Line, Op, SrcReg, Target, Live, List, St0), {Sis++Is,Aft,St1}; %% Map: (possibly) multiple literal keys. -set_cg([{var,R}], {map,Op,Map,Es}, Le, Vdb, Bef, St0) -> +put_cg([#k_var{name=R}], #k_map{op=Op,var=Map,es=Es}, Le, Vdb, Bef, St0) -> %% assert key literals - [] = [Var||{map_pair,{var,_}=Var,_} <- Es], + [] = [Var || #k_map_pair{key=#k_var{}=Var} <- Es], {Sis,Int0} = maybe_adjust_stack(Bef, Le#l.i, Le#l.i+1, Vdb, St0), SrcReg = cg_reg_arg_prefer_y(Map, Int0), Line = line(Le#l.a), %% fetch registers for values to be put into the map - Pairs = [{K,V} || {_,K,V} <- Es], - List = flatmap(fun({K,V}) -> [K,cg_reg_arg(V,Int0)] end, Pairs), + List = flatmap(fun(#k_map_pair{key=K,val=V}) -> + [atomic(K),cg_reg_arg(V, Int0)] + end, Es), Live = max_reg(Bef#sr.reg), @@ -1616,16 +2138,16 @@ set_cg([{var,R}], {map,Op,Map,Es}, Le, Vdb, Bef, St0) -> Aft = Aft0#sr{reg=put_reg(R, Aft0#sr.reg)}, Target = fetch_reg(R, Aft#sr.reg), - {Is,St1} = set_cg_map(Line, Op, SrcReg, Target, Live, List, St0), + {Is,St1} = put_cg_map(Line, Op, SrcReg, Target, Live, List, St0), {Sis++Is,Aft,St1}; %% Everything else. -set_cg([{var,R}], Con, Le, Vdb, Bef, St) -> +put_cg([#k_var{name=R}], Con, Le, Vdb, Bef, St) -> %% Find a place for the return register first. Int = Bef#sr{reg=put_reg(R, Bef#sr.reg)}, Ret = fetch_reg(R, Int#sr.reg), Ais = case Con of - {tuple,Es} -> + #k_tuple{es=Es} -> [{put_tuple,length(Es),Ret}] ++ cg_build_args(Es, Bef); Other -> [{move,cg_reg_arg(Other, Int),Ret}] @@ -1633,7 +2155,7 @@ set_cg([{var,R}], Con, Le, Vdb, Bef, St) -> {Ais,clear_dead(Int, Le#l.i, Vdb),St}. -set_cg_map(Line, Op0, SrcReg, Target, Live, List, St0) -> +put_cg_map(Line, Op0, SrcReg, Target, Live, List, St0) -> Bfail = St0#cg.bfail, Fail = {f,St0#cg.bfail}, Op = case Op0 of @@ -1811,24 +2333,44 @@ cg_gen_binsize([], _, _, _, _, Acc) -> Acc. %% cg_bin_opt(Code0) -> Code %% Optimize the size calculations for binary construction. -cg_bin_opt([{move,Size,D},{bs_append,Fail,D,Extra,Regs,U,Bin,Flags,D}|Is]) -> - cg_bin_opt([{bs_append,Fail,Size,Extra,Regs,U,Bin,Flags,D}|Is]); -cg_bin_opt([{move,Size,D},{bs_private_append,Fail,D,U,Bin,Flags,D}|Is]) -> - cg_bin_opt([{bs_private_append,Fail,Size,U,Bin,Flags,D}|Is]); -cg_bin_opt([{move,{integer,0},D},{bs_add,_,[D,{integer,_}=S,1],Dst}|Is]) -> - cg_bin_opt([{move,S,Dst}|Is]); -cg_bin_opt([{move,{integer,0},D},{bs_add,Fail,[D,S,U],Dst}|Is]) -> - cg_bin_opt([{bs_add,Fail,[{integer,0},S,U],Dst}|Is]); -cg_bin_opt([{move,{integer,Bytes},D},{Op,Fail,D,Extra,Regs,Flags,D}|Is]) +cg_bin_opt([{move,S1,{x,X}=D},{gc_bif,Op,Fail,Live0,As,Dst}|Is]) -> + Live = if + X + 1 =:= Live0 -> X; + true -> Live0 + end, + [{gc_bif,Op,Fail,Live,As,D}|cg_bin_opt([{move,S1,Dst}|Is])]; +cg_bin_opt([{move,_,_}=I1,{Op,_,_,_}=I2|Is]) + when Op =:= bs_utf8_size orelse Op =:= bs_utf16_size -> + [I2|cg_bin_opt([I1|Is])]; +cg_bin_opt([{bs_add,_,[{integer,0},Src,1],Dst}|Is]) -> + cg_bin_opt_1([{move,Src,Dst}|Is]); +cg_bin_opt([{bs_add,_,[Src,{integer,0},_],Dst}|Is]) -> + cg_bin_opt_1([{move,Src,Dst}|Is]); +cg_bin_opt(Is) -> + cg_bin_opt_1(Is). + +cg_bin_opt_1([{move,Size,D},{bs_append,Fail,D,Extra,Regs,U,Bin,Flags,D}|Is]) -> + [{bs_append,Fail,Size,Extra,Regs,U,Bin,Flags,D}|cg_bin_opt(Is)]; +cg_bin_opt_1([{move,Size,D},{bs_private_append,Fail,D,U,Bin,Flags,D}|Is]) -> + [{bs_private_append,Fail,Size,U,Bin,Flags,D}|cg_bin_opt(Is)]; +cg_bin_opt_1([{move,Size,D},{Op,Fail,D,Extra,Regs,Flags,D}|Is]) when Op =:= bs_init2; Op =:= bs_init_bits -> - cg_bin_opt([{Op,Fail,Bytes,Extra,Regs,Flags,D}|Is]); -cg_bin_opt([{move,Src1,Dst},{bs_add,Fail,[Dst,Src2,U],Dst}|Is]) -> - cg_bin_opt([{bs_add,Fail,[Src1,Src2,U],Dst}|Is]); -cg_bin_opt([I|Is]) -> + Bytes = case Size of + {integer,Int} -> Int; + _ -> Size + end, + [{Op,Fail,Bytes,Extra,Regs,Flags,D}|cg_bin_opt(Is)]; +cg_bin_opt_1([{move,S1,D},{bs_add,Fail,[D,S2,U],Dst}|Is]) -> + cg_bin_opt([{bs_add,Fail,[S1,S2,U],Dst}|Is]); +cg_bin_opt_1([{move,S1,D},{bs_add,Fail,[S2,D,U],Dst}|Is]) -> + cg_bin_opt([{bs_add,Fail,[S2,S1,U],Dst}|Is]); +cg_bin_opt_1([I|Is]) -> [I|cg_bin_opt(Is)]; -cg_bin_opt([]) -> []. +cg_bin_opt_1([]) -> + []. -cg_bin_put({bin_seg,[],S0,U,T,Fs,[E0,Next]}, Fail, Bef) -> +cg_bin_put(#k_bin_seg{size=S0,unit=U,type=T,flags=Fs,seg=E0,next=Next}, + Fail, Bef) -> S1 = cg_reg_arg(S0, Bef), E1 = cg_reg_arg(E0, Bef), {Format,Op} = case T of @@ -1845,7 +2387,7 @@ cg_bin_put({bin_seg,[],S0,U,T,Fs,[E0,Next]}, Fail, Bef) -> utf -> [{Op,Fail,{field_flags,Fs},E1}|cg_bin_put(Next, Fail, Bef)] end; -cg_bin_put({bin_end,[]}, _, _) -> []. +cg_bin_put(#k_bin_end{}, _, _) -> []. cg_build_args(As, Bef) -> [{put,cg_reg_arg(A, Bef)} || A <- As]. @@ -1865,13 +2407,12 @@ break_cg(Bs, Le, Vdb, Bef, St) -> {Ms ++ [{jump,{f,St#cg.break}}], Int#sr{reg=clear_regs(Int#sr.reg)},St}. -guard_break_cg(Bs, Locked, #l{i=I}, Vdb, #sr{reg=Reg0}=Bef, St) -> - RegLocked = get_locked_regs(Reg0, Locked), - #sr{reg=Reg1} = Int = clear_dead(Bef#sr{reg=RegLocked}, I, Vdb), +guard_break_cg(Bs, #l{i=I}, Vdb, #sr{reg=Reg0}=Bef, St) -> + #sr{reg=Reg1} = Int = clear_dead(Bef, I, Vdb), Reg2 = trim_free(Reg1), NumLocked = length(Reg2), Moves0 = gen_moves(Bs, Bef, NumLocked, []), - Moves = order_moves(Moves0, find_scratch_reg(RegLocked)), + Moves = order_moves(Moves0, find_scratch_reg(Reg0)), {BreakVars,_} = mapfoldl(fun(_, RegNum) -> {{RegNum,gbreakvar},RegNum+1} end, length(Reg2), Bs), @@ -1879,31 +2420,17 @@ guard_break_cg(Bs, Locked, #l{i=I}, Vdb, #sr{reg=Reg0}=Bef, St) -> Aft = Int#sr{reg=Reg}, {Moves ++ [{jump,{f,St#cg.break}}],Aft,St}. -get_locked_regs([R|Rs0], Preserve) -> - case {get_locked_regs(Rs0, Preserve),R} of - {[],{_,V}} -> - case lists:member(V, Preserve) of - true -> [R]; - false -> [] - end; - {[],_} -> - []; - {Rs,_} -> - [R|Rs] - end; -get_locked_regs([], _) -> []. - %% cg_reg_arg(Arg0, Info) -> Arg %% cg_reg_args([Arg0], Info) -> [Arg] %% Convert argument[s] into registers. Literal values are returned unchanged. cg_reg_args(As, Bef) -> [cg_reg_arg(A, Bef) || A <- As]. -cg_reg_arg({var,V}, Bef) -> fetch_var(V, Bef); -cg_reg_arg(Literal, _) -> Literal. +cg_reg_arg(#k_var{name=V}, Bef) -> fetch_var(V, Bef); +cg_reg_arg(Literal, _) -> atomic(Literal). -cg_reg_arg_prefer_y({var,V}, Bef) -> fetch_var_prefer_y(V, Bef); -cg_reg_arg_prefer_y(Literal, _) -> Literal. +cg_reg_arg_prefer_y(#k_var{name=V}, Bef) -> fetch_var_prefer_y(V, Bef); +cg_reg_arg_prefer_y(Literal, _) -> atomic(Literal). %% cg_setup_call([Arg], Bef, Cur, Vdb) -> {[Instr],Aft}. %% Do the complete setup for a call/enter. @@ -1941,9 +2468,9 @@ cg_call_args(As, Bef, I, Vdb) -> load_arg_regs(Regs, As) -> load_arg_regs(Regs, As, 0). -load_arg_regs([_|Rs], [{var,V}|As], I) -> [{I,V}|load_arg_regs(Rs, As, I+1)]; +load_arg_regs([_|Rs], [#k_var{name=V}|As], I) -> [{I,V}|load_arg_regs(Rs, As, I+1)]; load_arg_regs([_|Rs], [A|As], I) -> [{I,A}|load_arg_regs(Rs, As, I+1)]; -load_arg_regs([], [{var,V}|As], I) -> [{I,V}|load_arg_regs([], As, I+1)]; +load_arg_regs([], [#k_var{name=V}|As], I) -> [{I,V}|load_arg_regs([], As, I+1)]; load_arg_regs([], [A|As], I) -> [{I,A}|load_arg_regs([], As, I+1)]; load_arg_regs(Rs, [], _) -> Rs. @@ -1979,12 +2506,13 @@ move_unsaved([], _, Regs, Acc) -> {Acc,Regs}. gen_moves(As, Sr) -> gen_moves(As, Sr, 0, []). -gen_moves([{var,V}|As], Sr, I, Acc) -> +gen_moves([#k_var{name=V}|As], Sr, I, Acc) -> case fetch_var(V, Sr) of {x,I} -> gen_moves(As, Sr, I+1, Acc); Reg -> gen_moves(As, Sr, I+1, [{move,Reg,{x,I}}|Acc]) end; -gen_moves([A|As], Sr, I, Acc) -> +gen_moves([A0|As], Sr, I, Acc) -> + A = atomic(A0), gen_moves(As, Sr, I+1, [{move,A,{x,I}}|Acc]); gen_moves([], _, _, Acc) -> lists:keysort(3, Acc). @@ -2032,21 +2560,21 @@ break_up_cycle1(Dst, [M|Path], LastMove) -> %% clear_dead(Sr, Until, Vdb) -> Aft. %% Remove all variables in Sr which have died AT ALL so far. -clear_dead(Sr, Until, Vdb) -> - Sr#sr{reg=clear_dead_reg(Sr, Until, Vdb), - stk=clear_dead_stk(Sr#sr.stk, Until, Vdb)}. +clear_dead(#sr{stk=Stk}=Sr0, Until, Vdb) -> + Sr = Sr0#sr{reg=clear_dead_reg(Sr0, Until, Vdb), + stk=clear_dead_stk(Stk, Until, Vdb)}, + reserve(Sr). clear_dead_reg(Sr, Until, Vdb) -> - Reg = [case R of - {_I,V} = IV -> - case vdb_find(V, Vdb) of - {V,_,L} when L > Until -> IV; - _ -> free %Remove anything else - end; - {reserved,_I,_V} = Reserved -> Reserved; - free -> free - end || R <- Sr#sr.reg], - reserve(Sr#sr.res, Reg, Sr#sr.stk). + [case R of + {_I,V} = IV -> + case vdb_find(V, Vdb) of + {V,_,L} when L > Until -> IV; + _ -> free %Remove anything else + end; + {reserved,_I,_V}=Reserved -> Reserved; + free -> free + end || R <- Sr#sr.reg]. clear_dead_stk(Stk, Until, Vdb) -> [case S of @@ -2118,16 +2646,25 @@ adjust_stack(Bef, Fb, Lf, Vdb) -> save_stack(Stk0, Fb, Lf, Vdb) -> %% New variables that are in use but not on stack. - New = [VFL || {V,F,L} = VFL <- Vdb, - F < Fb, - L >= Lf, - not on_stack(V, Stk0)], + New = new_not_on_stack(Stk0, Fb, Lf, Vdb), + %% Add new variables that are not just dropped immediately. %% N.B. foldr works backwards from the end!! Saves = [V || {V,_,_} <- keysort(3, New)], Stk1 = foldr(fun (V, Stk) -> put_stack(V, Stk) end, Stk0, Saves), {Stk1,Saves}. +%% new_not_on_stack(Stack, FirstBefore, LastFrom, Vdb) -> +%% [{Variable,First,Last}] +%% Return information about all variables that are used past current +%% point and that are not already on the stack. + +new_not_on_stack(Stk, Fb, Lf, Vdb) -> + [VFL || {V,F,L} = VFL <- Vdb, + F < Fb, + L >= Lf, + not on_stack(V, Stk)]. + %% saves([SaveVar], Reg, Stk) -> [{move,Reg,Stk}]. %% Generate move instructions to save variables onto stack. The %% stack/reg info used is that after the new stack has been made. @@ -2153,7 +2690,7 @@ fetch_var_prefer_y(V, #sr{reg=Reg,stk=Stk}) -> end. load_vars(Vs, Regs) -> - foldl(fun ({var,V}, Rs) -> put_reg(V, Rs) end, Regs, Vs). + foldl(fun (#k_var{name=V}, Rs) -> put_reg(V, Rs) end, Regs, Vs). %% put_reg(Val, Regs) -> Regs. %% find_reg(Val, Regs) -> {ok,r{R}} | error. @@ -2233,10 +2770,6 @@ find_stack(_, [], _) -> error. on_stack(V, Stk) -> keymember(V, 1, Stk). -is_register({x,_}) -> true; -is_register({yy,_}) -> true; -is_register(_) -> false. - %% put_catch(CatchTag, Stack) -> Stack' %% drop_catch(CatchTag, Stack) -> Stack' %% Special interface for putting and removing catch tags, to ensure that @@ -2254,6 +2787,16 @@ put_catch(Tag, [Other|Stk], Acc) -> drop_catch(Tag, [{{catch_tag,Tag}}|Stk]) -> [free|Stk]; drop_catch(Tag, [Other|Stk]) -> [Other|drop_catch(Tag, Stk)]. +%% atomic(Klit) -> Lit. +%% atomic_list([Klit]) -> [Lit]. + +atomic(#k_literal{val=V}) -> {literal,V}; +atomic(#k_int{val=I}) -> {integer,I}; +atomic(#k_float{val=F}) -> {float,F}; +atomic(#k_atom{val=A}) -> {atom,A}; +%%atomic(#k_char{val=C}) -> {char,C}; +atomic(#k_nil{}) -> nil. + %% new_label(St) -> {L,St}. new_label(#cg{lcount=Next}=St) -> @@ -2296,3 +2839,86 @@ flatmapfoldl(F, Accu0, [Hd|Tail]) -> {Rs,Accu2} = flatmapfoldl(F, Accu1, Tail), {R++Rs,Accu2}; flatmapfoldl(_, Accu, []) -> {[],Accu}. + +%% Keep track of life time for variables. +%% +%% init_vars([{var,VarName}]) -> Vdb. +%% new_vars([VarName], I, Vdb) -> Vdb. +%% use_vars([VarName], I, Vdb) -> Vdb. +%% add_var(VarName, F, L, Vdb) -> Vdb. +%% +%% The list of variable names for new_vars/3 and use_vars/3 +%% must be sorted. + +init_vars(Vs) -> + vdb_new(Vs). + +new_vars([], _, Vdb) -> Vdb; +new_vars([V], I, Vdb) -> vdb_store_new(V, {V,I,I}, Vdb); +new_vars(Vs, I, Vdb) -> vdb_update_vars(Vs, Vdb, I). + +use_vars([], _, Vdb) -> + Vdb; +use_vars([V], I, Vdb) -> + case vdb_find(V, Vdb) of + {V,F,L} when I > L -> vdb_update(V, {V,F,I}, Vdb); + {V,_,_} -> Vdb; + error -> vdb_store_new(V, {V,I,I}, Vdb) + end; +use_vars(Vs, I, Vdb) -> vdb_update_vars(Vs, Vdb, I). + +add_var(V, F, L, Vdb) -> + vdb_store_new(V, {V,F,L}, Vdb). + +%% vdb + +vdb_new(Vs) -> + ordsets:from_list([{V,0,0} || #k_var{name=V} <- Vs]). + +-type var() :: atom(). + +-spec vdb_find(var(), [vdb_entry()]) -> 'error' | vdb_entry(). + +vdb_find(V, Vdb) -> + case lists:keyfind(V, 1, Vdb) of + false -> error; + Vd -> Vd + end. + +vdb_update(V, Update, [{V,_,_}|Vdb]) -> + [Update|Vdb]; +vdb_update(V, Update, [Vd|Vdb]) -> + [Vd|vdb_update(V, Update, Vdb)]. + +vdb_store_new(V, New, [{V1,_,_}=Vd|Vdb]) when V > V1 -> + [Vd|vdb_store_new(V, New, Vdb)]; +vdb_store_new(V, New, [{V1,_,_}|_]=Vdb) when V < V1 -> + [New|Vdb]; +vdb_store_new(_, New, []) -> [New]. + +vdb_update_vars([V|_]=Vs, [{V1,_,_}=Vd|Vdb], I) when V > V1 -> + [Vd|vdb_update_vars(Vs, Vdb, I)]; +vdb_update_vars([V|Vs], [{V1,_,_}|_]=Vdb, I) when V < V1 -> + %% New variable. + [{V,I,I}|vdb_update_vars(Vs, Vdb, I)]; +vdb_update_vars([V|Vs], [{_,F,L}=Vd|Vdb], I) -> + %% Existing variable. + if + I > L -> [{V,F,I}|vdb_update_vars(Vs, Vdb, I)]; + true -> [Vd|vdb_update_vars(Vs, Vdb, I)] + end; +vdb_update_vars([V|Vs], [], I) -> + %% New variable. + [{V,I,I}|vdb_update_vars(Vs, [], I)]; +vdb_update_vars([], Vdb, _) -> Vdb. + +%% vdb_sub(Min, Max, Vdb) -> Vdb. +%% Extract variables which are used before and after Min. Lock +%% variables alive after Max. + +vdb_sub(Min, Max, Vdb) -> + [ if L >= Max -> {V,F,locked}; + true -> Vd + end || {V,F,L}=Vd <- Vdb, + F < Min, + L >= Min ]. diff --git a/lib/compiler/src/v3_core.erl b/lib/compiler/src/v3_core.erl index ae650546e5..4799105d05 100644 --- a/lib/compiler/src/v3_core.erl +++ b/lib/compiler/src/v3_core.erl @@ -920,8 +920,9 @@ try_exception(Ecs0, St0) -> %% Note that Tag is not needed for rethrow - it is already in Info. {Evs,St1} = new_vars(3, St0), % Tag, Value, Info {Ecs1,Ceps,St2} = clauses(Ecs0, St1), + Ecs2 = try_build_stacktrace(Ecs1, hd(Evs)), [_,Value,Info] = Evs, - LA = case Ecs1 of + LA = case Ecs2 of [] -> []; [C|_] -> get_lineno_anno(C) end, @@ -930,7 +931,7 @@ try_exception(Ecs0, St0) -> body=[#iprimop{anno=#a{}, %Must have an #a{} name=#c_literal{val=raise}, args=[Info,Value]}]}, - Hs = [#icase{anno=#a{anno=LA},args=[c_tuple(Evs)],clauses=Ecs1,fc=Ec}], + Hs = [#icase{anno=#a{anno=LA},args=[c_tuple(Evs)],clauses=Ecs2,fc=Ec}], {Evs,Ceps++Hs,St2}. try_after(As, St0) -> @@ -946,6 +947,25 @@ try_after(As, St0) -> Hs = [#icase{anno=#a{},args=[c_tuple(Evs)],clauses=[],fc=Ec}], {Evs,Hs,St1}. +try_build_stacktrace([#iclause{pats=Ps0,body=B0}=C0|Cs], RawStk) -> + [#c_tuple{es=[Class,Exc,Stk]}=Tup] = Ps0, + case Stk of + #c_var{name='_'} -> + %% Stacktrace variable is not used. Nothing to do. + [C0|try_build_stacktrace(Cs, RawStk)]; + _ -> + %% Add code to build the stacktrace. + Ps = [Tup#c_tuple{es=[Class,Exc,RawStk]}], + Call = #iprimop{anno=#a{}, + name=#c_literal{val=build_stacktrace}, + args=[RawStk]}, + Iset = #iset{var=Stk,arg=Call}, + B = [Iset|B0], + C = C0#iclause{pats=Ps,body=B}, + [C|try_build_stacktrace(Cs, RawStk)] + end; +try_build_stacktrace([], _) -> []. + %% expr_bin([ArgExpr], St) -> {[Arg],[PreExpr],St}. %% Flatten the arguments of a bin. Do this straight left to right! %% Note that ibinary needs to have its annotation wrapped in a #a{} @@ -1132,7 +1152,7 @@ fun_tq(Cs0, L, St0, NameInfo) -> %% lc_tq(Line, Exp, [Qualifier], Mc, State) -> {LetRec,[PreExp],State}. %% This TQ from Simon PJ pp 127-138. -lc_tq(Line, E, [#igen{anno=GAnno,ceps=Ceps, +lc_tq(Line, E, [#igen{anno=#a{anno=GA}=GAnno,ceps=Ceps, acc_pat=AccPat,acc_guard=AccGuard, skip_pat=SkipPat,tail=Tail,tail_pat=TailPat, arg={Pre,Arg}}|Qs], Mc, St0) -> @@ -1142,7 +1162,7 @@ lc_tq(Line, E, [#igen{anno=GAnno,ceps=Ceps, F = #c_var{anno=LA,name={Name,1}}, Nc = #iapply{anno=GAnno,op=F,args=[Tail]}, {Var,St2} = new_var(St1), - Fc = function_clause([Var], LA, {Name,1}), + Fc = function_clause([Var], GA, {Name,1}), TailClause = #iclause{anno=LAnno,pats=[TailPat],guard=[],body=[Mc]}, Cs0 = case {AccPat,AccGuard} of {SkipPat,[]} -> @@ -1165,9 +1185,9 @@ lc_tq(Line, E, [#igen{anno=GAnno,ceps=Ceps, body=Lps ++ [Lc]}|Cs0], St3} end, - Fun = #ifun{anno=LAnno,id=[],vars=[Var],clauses=Cs,fc=Fc}, - {#iletrec{anno=LAnno#a{anno=[list_comprehension|LA]},defs=[{{Name,1},Fun}], - body=Pre ++ [#iapply{anno=LAnno,op=F,args=[Arg]}]}, + Fun = #ifun{anno=GAnno,id=[],vars=[Var],clauses=Cs,fc=Fc}, + {#iletrec{anno=GAnno#a{anno=[list_comprehension|GA]},defs=[{{Name,1},Fun}], + body=Pre ++ [#iapply{anno=GAnno,op=F,args=[Arg]}]}, Ceps,St4}; lc_tq(Line, E, [#ifilter{}=Filter|Qs], Mc, St) -> filter_tq(Line, E, Filter, Mc, St, Qs, fun lc_tq/5); @@ -1985,7 +2005,7 @@ new_fun_name(Type, #core{fcount=C}=St) -> %% new_var_name(State) -> {VarName,State}. new_var_name(#core{vcount=C}=St) -> - {list_to_atom("@c" ++ integer_to_list(C)),St#core{vcount=C + 1}}. + {C,St#core{vcount=C + 1}}. %% new_var(State) -> {{var,Name},State}. %% new_var(LineAnno, State) -> {{var,Name},State}. @@ -2462,9 +2482,11 @@ cexpr(#icase{anno=A,args=Largs,clauses=Lcs,fc=Lfc}, As, St0) -> cexpr(#ireceive1{anno=A,clauses=Lcs}, As, St0) -> Exp = intersection(A#a.ns, As), %Exports {Ccs,St1} = cclauses(Lcs, Exp, St0), + True = #c_literal{val=true}, + Action = core_lib:make_values(lists:duplicate(1+length(Exp), True)), {#c_receive{anno=A#a.anno, clauses=Ccs, - timeout=#c_literal{val=infinity},action=#c_literal{val=true}}, + timeout=#c_literal{val=infinity},action=Action}, Exp,A#a.us,St1}; cexpr(#ireceive2{anno=A,clauses=Lcs,timeout=Lto,action=Les}, As, St0) -> Exp = intersection(A#a.ns, As), %Exports @@ -2505,8 +2527,46 @@ cexpr(#ifun{anno=#a{us=Us0}=A0,name={named,Name},fc=#iclause{pats=Ps}}=Fun0, end; cexpr(#iapply{anno=A,op=Op,args=Args}, _As, St) -> {#c_apply{anno=A#a.anno,op=Op,args=Args},[],A#a.us,St}; -cexpr(#icall{anno=A,module=Mod,name=Name,args=Args}, _As, St) -> - {#c_call{anno=A#a.anno,module=Mod,name=Name,args=Args},[],A#a.us,St}; +cexpr(#icall{anno=A,module=Mod,name=Name,args=Args}, _As, St0) -> + Anno = A#a.anno, + case (not cerl:is_c_atom(Mod)) andalso member(tuple_calls, St0#core.opts) of + true -> + GenAnno = [compiler_generated|Anno], + + %% Generate the clause that matches on the tuple + {TupleVar,St1} = new_var(GenAnno, St0), + {TupleSizeVar, St2} = new_var(GenAnno, St1), + {TupleModVar, St3} = new_var(GenAnno, St2), + {TupleArgsVar, St4} = new_var(GenAnno, St3), + TryVar = cerl:c_var('Try'), + + TupleGuardExpr = + cerl:c_let([TupleSizeVar], + c_call_erl(tuple_size, [TupleVar]), + c_call_erl('>', [TupleSizeVar, cerl:c_int(0)])), + + TupleGuard = + cerl:c_try(TupleGuardExpr, [TryVar], TryVar, + [cerl:c_var('T'),cerl:c_var('R')], cerl:c_atom(false)), + + TupleApply = + cerl:c_let([TupleModVar], + c_call_erl(element, [cerl:c_int(1),TupleVar]), + cerl:c_let([TupleArgsVar], + cerl:make_list(Args ++ [TupleVar]), + c_call_erl(apply, [TupleModVar,Name,TupleArgsVar]))), + + TupleClause = cerl:ann_c_clause(GenAnno, [TupleVar], TupleGuard, TupleApply), + + %% Generate the fallback clause + {OtherVar,St5} = new_var(GenAnno, St4), + OtherApply = cerl:ann_c_call(GenAnno, OtherVar, Name, Args), + OtherClause = cerl:ann_c_clause(GenAnno, [OtherVar], OtherApply), + + {cerl:ann_c_case(GenAnno, Mod, [TupleClause,OtherClause]),[],A#a.us,St5}; + false -> + {#c_call{anno=Anno,module=Mod,name=Name,args=Args},[],A#a.us,St0} + end; cexpr(#iprimop{anno=A,name=Name,args=Args}, _As, St) -> {#c_primop{anno=A#a.anno,name=Name,args=Args},[],A#a.us,St}; cexpr(#iprotect{anno=A,body=Es}, _As, St0) -> @@ -2536,6 +2596,9 @@ cfun(#ifun{anno=A,id=Id,vars=Args,clauses=Lcs,fc=Lfc}, _As, St0) -> clauses=Ccs ++ [Cfc]}}, [],A#a.us,St2}. +c_call_erl(Fun, Args) -> + cerl:c_call(cerl:c_atom(erlang), cerl:c_atom(Fun), Args). + %% lit_vars(Literal) -> [Var]. lit_vars(Lit) -> lit_vars(Lit, []). diff --git a/lib/compiler/src/v3_kernel.erl b/lib/compiler/src/v3_kernel.erl index 1fc05109c5..4e3ceedbc0 100644 --- a/lib/compiler/src/v3_kernel.erl +++ b/lib/compiler/src/v3_kernel.erl @@ -82,7 +82,8 @@ -export([module/2,format_error/1]). -import(lists, [map/2,foldl/3,foldr/3,mapfoldl/3,splitwith/2,member/2, - keymember/3,keyfind/3,partition/2,droplast/1,last/1,sort/1]). + keymember/3,keyfind/3,partition/2,droplast/1,last/1,sort/1, + reverse/1]). -import(ordsets, [add_element/2,del_element/2,union/2,union/1,subtract/2]). -import(cerl, [c_tuple/1]). @@ -107,6 +108,7 @@ copy_anno(Kdst, Ksrc) -> -record(iclause, {anno=[],isub,osub,pats,guard,body}). -record(ireceive_accept, {anno=[],arg}). -record(ireceive_next, {anno=[],arg}). +-record(ignored, {anno=[]}). -type warning() :: term(). % XXX: REFINE @@ -155,20 +157,23 @@ include_attribute(_) -> true. function({#c_var{name={F,Arity}=FA},Body}, St0) -> %%io:format("~w/~w~n", [F,Arity]), try - St1 = St0#kern{func=FA,ff=undefined,vcount=0,fcount=0,ds=cerl_sets:new()}, + %% Find a suitable starting value for the variable counter. Note + %% that this pass assumes that new_var_name/1 returns a variable + %% name distinct from any variable used in the entire body of + %% the function. We use integers as variable names to avoid + %% filling up the atom table when compiling huge functions. + Count = cerl_trees:next_free_variable_name(Body), + St1 = St0#kern{func=FA,ff=undefined,vcount=Count,fcount=0,ds=cerl_sets:new()}, {#ifun{anno=Ab,vars=Kvs,body=B0},[],St2} = expr(Body, new_sub(), St1), {B1,_,St3} = ubody(B0, return, St2), %%B1 = B0, St3 = St2, %Null second pass - {#k_fdef{anno=#k{us=[],ns=[],a=Ab}, - func=F,arity=Arity,vars=Kvs,body=B1},St3} + {make_fdef(#k{us=[],ns=[],a=Ab}, F, Arity, Kvs, B1),St3} catch - Class:Error -> - Stack = erlang:get_stacktrace(), + Class:Error:Stack -> io:fwrite("Function: ~w/~w\n", [F,Arity]), erlang:raise(Class, Error, Stack) end. - %% body(Cexpr, Sub, State) -> {Kexpr,[PreKepxr],State}. %% Do the main sequence of a body. A body ends in an atomic value or %% values. Must check if vector first so do expr. @@ -489,7 +494,7 @@ make_alt(First0, Then0) -> Then1 = pre_seq(droplast(Then0), last(Then0)), First2 = make_protected(First1), Then2 = make_protected(Then1), - Body = #k_atom{val=ignored}, + Body = #ignored{}, First3 = #k_guard_clause{guard=First2,body=Body}, Then3 = #k_guard_clause{guard=Then2,body=Body}, First = #k_guard{clauses=[First3]}, @@ -1356,7 +1361,7 @@ new_fun_name(Type, #kern{func={F,Arity},fcount=C}=St) -> %% new_var_name(State) -> {VarName,State}. new_var_name(#kern{vcount=C}=St) -> - {list_to_atom("@k" ++ integer_to_list(C)),St#kern{vcount=C+1}}. + {C,St#kern{vcount=C+1}}. %% new_var(State) -> {#k_var{},State}. @@ -1589,23 +1594,18 @@ match_var([U|Us], Cs0, Def, St) -> %% according to type, the order is really irrelevant but tries to be %% smart. -match_con(Us, [C], Def, St) -> - %% There is only one clause. We can keep literal tuples and - %% lists, but we must convert []/integer/float/atom literals - %% to the proper record (#k_nil{} and so on). - Cs = [expand_pat_lit_clause(C, false)], - match_con_1(Us, Cs, Def, St); match_con(Us, Cs0, Def, St) -> - %% More than one clause. Remove literals at the top level. - Cs = [expand_pat_lit_clause(C, true) || C <- Cs0], + %% Expand literals at the top level. + Cs = [expand_pat_lit_clause(C) || C <- Cs0], match_con_1(Us, Cs, Def, St). match_con_1([U|_Us] = L, Cs, Def, St0) -> %% Extract clauses for different constructors (types). %%ok = io:format("match_con ~p~n", [Cs]), - Ttcs = select_types([k_binary], Cs) ++ select_bin_con(Cs) ++ - select_types([k_cons,k_tuple,k_map,k_atom,k_float,k_int, - k_nil,k_literal], Cs), + Ttcs0 = select_types([k_binary], Cs) ++ select_bin_con(Cs) ++ + select_types([k_cons,k_tuple,k_map,k_atom,k_float, + k_int,k_nil], Cs), + Ttcs = opt_single_valued(Ttcs0), %%ok = io:format("ttcs = ~p~n", [Ttcs]), {Scs,St1} = mapfoldl(fun ({T,Tcs}, St) -> @@ -1618,28 +1618,14 @@ match_con_1([U|_Us] = L, Cs, Def, St0) -> select_types(Types, Cs) -> [{T,Tcs} || T <- Types, begin Tcs = select(T, Cs), Tcs =/= [] end]. - -expand_pat_lit_clause(#iclause{pats=[#ialias{pat=#k_literal{anno=A,val=Val}}=Alias|Ps]}=C, B) -> - P = case B of - true -> expand_pat_lit(Val, A); - false -> literal(Val, A) - end, + +expand_pat_lit_clause(#iclause{pats=[#ialias{pat=#k_literal{anno=A,val=Val}}=Alias|Ps]}=C) -> + P = expand_pat_lit(Val, A), C#iclause{pats=[Alias#ialias{pat=P}|Ps]}; -expand_pat_lit_clause(#iclause{pats=[#k_literal{anno=A,val=Val}|Ps]}=C, B) -> - P = case B of - true -> expand_pat_lit(Val, A); - false -> literal(Val, A) - end, +expand_pat_lit_clause(#iclause{pats=[#k_literal{anno=A,val=Val}|Ps]}=C) -> + P = expand_pat_lit(Val, A), C#iclause{pats=[P|Ps]}; -expand_pat_lit_clause(#iclause{pats=[#k_binary{anno=A,segs=#k_bin_end{}}|Ps]}=C, B) -> - case B of - true -> - C; - false -> - P = #k_literal{anno=A,val = <<>>}, - C#iclause{pats=[P|Ps]} - end; -expand_pat_lit_clause(C, _) -> C. +expand_pat_lit_clause(C) -> C. expand_pat_lit([H|T], A) -> #k_cons{anno=A,hd=literal(H, A),tl=literal(T, A)}; @@ -1659,6 +1645,107 @@ literal(Val, A) when is_atom(Val) -> literal(Val, A) when is_list(Val); is_tuple(Val) -> #k_literal{anno=A,val=Val}. +%% opt_singled_valued([{Type,Clauses}]) -> [{Type,Clauses}]. +%% If a type only has one clause and if the pattern is literal, +%% the matching can be done more efficiently by directly comparing +%% with the literal (that is especially true for binaries). + +opt_single_valued(Ttcs) -> + opt_single_valued(Ttcs, [], []). + +opt_single_valued([{_,[#iclause{pats=[P0|Ps]}=Tc]}=Ttc|Ttcs], TtcAcc, LitAcc) -> + try combine_lit_pat(P0) of + P -> + LitTtc = Tc#iclause{pats=[P|Ps]}, + opt_single_valued(Ttcs, TtcAcc, [LitTtc|LitAcc]) + catch + not_possible -> + opt_single_valued(Ttcs, [Ttc|TtcAcc], LitAcc) + end; +opt_single_valued([Ttc|Ttcs], TtcAcc, LitAcc) -> + opt_single_valued(Ttcs, [Ttc|TtcAcc], LitAcc); +opt_single_valued([], TtcAcc, []) -> + reverse(TtcAcc); +opt_single_valued([], TtcAcc, LitAcc) -> + Literals = {k_literal,reverse(LitAcc)}, + %% Test the literals as early as possible. + case reverse(TtcAcc) of + [{k_binary,_}=Bin|Ttcs] -> + %% The delayed creation of sub binaries requires + %% bs_start_match2 to be the first instruction in the + %% function. + [Bin,Literals|Ttcs]; + Ttcs -> + [Literals|Ttcs] + end. + +combine_lit_pat(#ialias{pat=Pat0}=Alias) -> + Pat = combine_lit_pat(Pat0), + Alias#ialias{pat=Pat}; +combine_lit_pat(Pat) -> + case do_combine_lit_pat(Pat) of + #k_literal{val=Val} when is_atom(Val) -> + throw(not_possible); + #k_literal{val=Val} when is_number(Val) -> + throw(not_possible); + #k_literal{val=[]} -> + throw(not_possible); + #k_literal{}=Lit -> + Lit + end. + +do_combine_lit_pat(#k_atom{anno=A,val=Val}) -> + #k_literal{anno=A,val=Val}; +do_combine_lit_pat(#k_float{anno=A,val=Val}) -> + #k_literal{anno=A,val=Val}; +do_combine_lit_pat(#k_int{anno=A,val=Val}) -> + #k_literal{anno=A,val=Val}; +do_combine_lit_pat(#k_nil{anno=A}) -> + #k_literal{anno=A,val=[]}; +do_combine_lit_pat(#k_binary{anno=A,segs=Segs}) -> + Bin = combine_bin_segs(Segs), + #k_literal{anno=A,val=Bin}; +do_combine_lit_pat(#k_cons{anno=A,hd=Hd0,tl=Tl0}) -> + #k_literal{val=Hd} = do_combine_lit_pat(Hd0), + #k_literal{val=Tl} = do_combine_lit_pat(Tl0), + #k_literal{anno=A,val=[Hd|Tl]}; +do_combine_lit_pat(#k_literal{}=Lit) -> + Lit; +do_combine_lit_pat(#k_tuple{anno=A,es=Es0}) -> + Es = [begin + #k_literal{val=Lit} = do_combine_lit_pat(El), + Lit + end || El <- Es0], + #k_literal{anno=A,val=list_to_tuple(Es)}; +do_combine_lit_pat(_) -> + throw(not_possible). + +combine_bin_segs(#k_bin_seg{size=Size0,unit=Unit,type=integer, + flags=[unsigned,big],seg=Seg,next=Next}) -> + #k_literal{val=Size1} = do_combine_lit_pat(Size0), + #k_literal{val=Int} = do_combine_lit_pat(Seg), + Size = Size1 * Unit, + if + 0 < Size, Size < 64 -> + Bin = <<Int:Size>>, + case Bin of + <<Int:Size>> -> + NextBin = combine_bin_segs(Next), + <<Bin/bits,NextBin/bits>>; + _ -> + %% The integer Int does not fit in the segment, + %% thus it will not match. + throw(not_possible) + end; + true -> + %% Avoid creating huge binary literals. + throw(not_possible) + end; +combine_bin_segs(#k_bin_end{}) -> + <<>>; +combine_bin_segs(_) -> + throw(not_possible). + %% select_bin_con([Clause]) -> [{Type,[Clause]}]. %% Extract clauses for the k_bin_seg constructor. As k_bin_seg %% matching can overlap, the k_bin_seg constructors cannot be @@ -2143,7 +2230,9 @@ ubody(E, return, St0) -> {Ea,Pa,St1} = force_atomic(E, St0), ubody(pre_seq(Pa, #ivalues{args=[Ea]}), return, St1) end; -ubody(E, {break,_Rs} = Break, St0) -> +ubody(#ignored{}, {break,_} = Break, St) -> + ubody(#ivalues{args=[]}, Break, St); +ubody(E, {break,[_]} = Break, St0) -> %%ok = io:fwrite("ubody ~w:~p~n", [?LINE,{E,Br}]), %% Exiting expressions need no trailing break. case is_exit_expr(E) of @@ -2151,6 +2240,16 @@ ubody(E, {break,_Rs} = Break, St0) -> false -> {Ea,Pa,St1} = force_atomic(E, St0), ubody(pre_seq(Pa, #ivalues{args=[Ea]}), Break, St1) + end; +ubody(E, {break,Rs}=Break, St0) -> + case is_exit_expr(E) of + true -> + uexpr(E, return, St0); + false -> + {Vs,St1} = new_vars(length(Rs), St0), + Iset = #iset{vars=Vs,arg=E}, + PreSeq = pre_seq([Iset], #ivalues{args=Vs}), + ubody(PreSeq, Break, St1) end. iletrec_funs(#iletrec{defs=Fs}, St0) -> @@ -2179,9 +2278,8 @@ iletrec_funs_gen(Fs, FreeVs, St) -> Arity0 = length(Vs), {Fb1,_,Lst1} = ubody(Fb0, return, Lst0#kern{ff={N,Arity0}}), Arity = Arity0 + length(FreeVs), - Fun = #k_fdef{anno=#k{us=[],ns=[],a=Fa}, - func=N,arity=Arity, - vars=Vs ++ FreeVs,body=Fb1}, + Fun = make_fdef(#k{us=[],ns=[],a=Fa}, N, Arity, + Vs++FreeVs, Fb1), Lst1#kern{funs=[Fun|Lst1#kern.funs]} end, St, Fs). @@ -2284,12 +2382,11 @@ uexpr(#k_try{anno=A,arg=A0,vars=Vs,body=B0,evars=Evs,handler=H0}, {A1,Au,St2} = ubody(A0, {break,Avs}, St1), {B1,Bu,St3} = ubody(B0, Br, St2), {H1,Hu,St4} = ubody(H0, Br, St3), - {Rs1,St5} = ensure_return_vars(Rs0, St4), Used = union([Au,subtract(Bu, lit_list_vars(Vs)), subtract(Hu, lit_list_vars(Evs))]), - {#k_try{anno=#k{us=Used,ns=lit_list_vars(Rs1),a=A}, - arg=A1,vars=Vs,body=B1,evars=Evs,handler=H1,ret=Rs1}, - Used,St5} + {#k_try{anno=#k{us=Used,ns=lit_list_vars(Rs0),a=A}, + arg=A1,vars=Vs,body=B1,evars=Evs,handler=H1,ret=Rs0}, + Used,St4} end; uexpr(#k_try{anno=A,arg=A0,vars=Vs,body=B0,evars=Evs,handler=H0}, return, St0) -> @@ -2297,13 +2394,11 @@ uexpr(#k_try{anno=A,arg=A0,vars=Vs,body=B0,evars=Evs,handler=H0}, {A1,Au,St2} = ubody(A0, {break,Avs}, St1), %Must break to clean up here! {B1,Bu,St3} = ubody(B0, return, St2), {H1,Hu,St4} = ubody(H0, return, St3), - NumNew = 1, - {Ns,St5} = new_vars(NumNew, St4), Used = union([Au,subtract(Bu, lit_list_vars(Vs)), subtract(Hu, lit_list_vars(Evs))]), - {#k_try_enter{anno=#k{us=Used,ns=Ns,a=A}, + {#k_try_enter{anno=#k{us=Used,ns=[],a=A}, arg=A1,vars=Vs,body=B1,evars=Evs,handler=H1}, - Used,St5}; + Used,St4}; uexpr(#k_catch{anno=A,body=B0}, {break,Rs0}, St0) -> {Rb,St1} = new_var(St0), {B1,Bu,St2} = ubody(B0, {break,[Rb]}, St1), @@ -2325,8 +2420,7 @@ uexpr(#ifun{anno=A,vars=Vs,body=B0}, {break,Rs}, St0) -> %% No id annotation. Must invent a fun name. new_fun_name(St1) end, - Fun = #k_fdef{anno=#k{us=[],ns=[],a=A},func=Fname,arity=Arity, - vars=Vs ++ Fvs,body=B1}, + Fun = make_fdef(#k{us=[],ns=[],a=A}, Fname, Arity, Vs++Fvs, B1), {#k_bif{anno=#k{us=Free,ns=lit_list_vars(Rs),a=A}, op=#k_internal{name=make_fun,arity=length(Free)+2}, args=[#k_atom{val=Fname},#k_int{val=Arity}|Fvs], @@ -2343,6 +2437,16 @@ uexpr(Lit, {break,Rs0}, St0) -> add_local_function(_, #kern{funs=ignore}=St) -> St; add_local_function(F, #kern{funs=Funs}=St) -> St#kern{funs=[F|Funs]}. +%% Make a #k_fdef{}, making sure that the body is always a #k_match{}. +make_fdef(Anno, Name, Arity, Vs, #k_match{}=Body) -> + #k_fdef{anno=Anno,func=Name,arity=Arity,vars=Vs,body=Body}; +make_fdef(Anno, Name, Arity, Vs, Body) -> + Ka = get_kanno(Body), + Match = #k_match{anno=#k{us=Ka#k.us,ns=[],a=Ka#k.a}, + vars=Vs,body=Body,ret=[]}, + #k_fdef{anno=Anno,func=Name,arity=Arity,vars=Vs,body=Match}. + + %% handle_reuse_annos([#k_var{}], State) -> State. %% In general, it is only safe to reuse a variable for a match context %% if the original value of the variable will no longer be needed. diff --git a/lib/compiler/src/v3_kernel_pp.erl b/lib/compiler/src/v3_kernel_pp.erl index 53097d0d7d..e9cbe81088 100644 --- a/lib/compiler/src/v3_kernel_pp.erl +++ b/lib/compiler/src/v3_kernel_pp.erl @@ -248,7 +248,7 @@ format_1(#k_put{arg=A,ret=Rs}, Ctxt) -> [format(A, Ctxt), format_ret(Rs, ctxt_bump_indent(Ctxt, 1)) ]; -format_1(#k_try{arg=A,vars=Vs,body=B,evars=Evs,handler=H}, Ctxt) -> +format_1(#k_try{arg=A,vars=Vs,body=B,evars=Evs,handler=H,ret=Rs}, Ctxt) -> Ctxt1 = ctxt_bump_indent(Ctxt, Ctxt#ctxt.body_indent), ["try", nl_indent(Ctxt1), @@ -264,7 +264,8 @@ format_1(#k_try{arg=A,vars=Vs,body=B,evars=Evs,handler=H}, Ctxt) -> nl_indent(Ctxt1), format(H, Ctxt1), nl_indent(Ctxt), - "end" + "end", + format_ret(Rs, Ctxt) ]; format_1(#k_try_enter{arg=A,vars=Vs,body=B,evars=Evs,handler=H}, Ctxt) -> Ctxt1 = ctxt_bump_indent(Ctxt, Ctxt#ctxt.body_indent), @@ -491,7 +492,7 @@ indent(Ctxt) -> indent(Ctxt#ctxt.indent, Ctxt). indent(N, _Ctxt) when N =< 0 -> ""; indent(N, Ctxt) -> T = Ctxt#ctxt.tab_width, - string:chars($\t, N div T, string:chars($\s, N rem T)). + lists:duplicate(N div T, $\t) ++ lists:duplicate(N rem T, $\s). nl_indent(Ctxt) -> [$\n|indent(Ctxt)]. @@ -508,7 +509,7 @@ unindent([$\t|T], N, Ctxt, C) -> if N >= Tab -> unindent(T, N - Tab, Ctxt, C); true -> - unindent([string:chars($\s, Tab - N)|T], 0, Ctxt, C) + unindent([lists:duplicate(Tab - N, $\s)|T], 0, Ctxt, C) end; unindent([L|T], N, Ctxt, C) when is_list(L) -> unindent(L, N, Ctxt, [T|C]); diff --git a/lib/compiler/src/v3_life.erl b/lib/compiler/src/v3_life.erl deleted file mode 100644 index be3ade47ff..0000000000 --- a/lib/compiler/src/v3_life.erl +++ /dev/null @@ -1,468 +0,0 @@ -%% -%% %CopyrightBegin% -%% -%% Copyright Ericsson AB 1999-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 : Convert annotated kernel expressions to annotated beam format. - -%% This module creates beam format annotated with variable lifetime -%% information. Each thing is given an index and for each variable we -%% store the first and last index for its occurrence. The variable -%% database, VDB, attached to each thing is only relevant internally -%% for that thing. -%% -%% For nested things like matches the numbering continues locally and -%% the VDB for that thing refers to the variable usage within that -%% thing. Variables which live through a such a thing are internally -%% given a very large last index. Internally the indexes continue -%% after the index of that thing. This creates no problems as the -%% internal variable info never escapes and externally we only see -%% variable which are alive both before or after. -%% -%% This means that variables never "escape" from a thing and the only -%% way to get values from a thing is to "return" them, with 'break' or -%% 'return'. Externally these values become the return values of the -%% thing. This is no real limitation as most nested things have -%% multiple threads so working out a common best variable usage is -%% difficult. - --module(v3_life). - --export([module/2]). - --export([vdb_find/2]). - --import(lists, [member/2,map/2,reverse/1,sort/1]). --import(ordsets, [add_element/2,intersection/2,union/2]). - --include("v3_kernel.hrl"). --include("v3_life.hrl"). - --type fa() :: {atom(),arity()}. - -%% These are not defined in v3_kernel.hrl. -get_kanno(Kthing) -> element(2, Kthing). -%%set_kanno(Kthing, Anno) -> setelement(2, Kthing, Anno). - --spec module(#k_mdef{}, [compile:option()]) -> - {'ok',{module(),[fa()],[_],[_]}}. - -module(#k_mdef{name=M,exports=Es,attributes=As,body=Fs0}, _Opts) -> - Fs1 = functions(Fs0, []), - {ok,{M,Es,As,Fs1}}. - -functions([F|Fs], Acc) -> - functions(Fs, [function(F)|Acc]); -functions([], Acc) -> reverse(Acc). - -%% function(Kfunc) -> Func. - -function(#k_fdef{anno=#k{a=Anno},func=F,arity=Ar,vars=Vs,body=Kb}) -> - try - As = var_list(Vs), - Vdb0 = init_vars(As), - %% Force a top-level match! - B0 = case Kb of - #k_match{} -> Kb; - _ -> - Ka = get_kanno(Kb), - #k_match{anno=#k{us=Ka#k.us,ns=[],a=Ka#k.a}, - vars=Vs,body=Kb,ret=[]} - end, - {B1,_,Vdb1} = body(B0, 1, Vdb0), - {function,F,Ar,As,B1,Vdb1,Anno} - catch - Class:Error -> - Stack = erlang:get_stacktrace(), - io:fwrite("Function: ~w/~w\n", [F,Ar]), - erlang:raise(Class, Error, Stack) - end. - -%% body(Kbody, I, Vdb) -> {[Expr],MaxI,Vdb}. -%% Handle a body. - -body(#k_seq{arg=Ke,body=Kb}, I, Vdb0) -> - %%ok = io:fwrite("life ~w:~p~n", [?LINE,{Ke,I,Vdb0}]), - A = get_kanno(Ke), - Vdb1 = use_vars(union(A#k.us, A#k.ns), I, Vdb0), - {Es,MaxI,Vdb2} = body(Kb, I+1, Vdb1), - E = expr(Ke, I, Vdb2), - {[E|Es],MaxI,Vdb2}; -body(Ke, I, Vdb0) -> - %%ok = io:fwrite("life ~w:~p~n", [?LINE,{Ke,I,Vdb0}]), - A = get_kanno(Ke), - Vdb1 = use_vars(union(A#k.us, A#k.ns), I, Vdb0), - E = expr(Ke, I, Vdb1), - {[E],I,Vdb1}. - -%% protected(Kprotected, I, Vdb) -> Protected. -%% Only used in guards. - -protected(#k_protected{anno=A,arg=Ts,ret=Rs}, I, Vdb) -> - %% Lock variables that are alive before try and used afterwards. - %% Don't lock variables that are only used inside the protected - %% expression. - Pdb0 = vdb_sub(I, I+1, Vdb), - {T,MaxI,Pdb1} = body(Ts, I+1, Pdb0), - Pdb2 = use_vars(A#k.ns, MaxI+1, Pdb1), %Save "return" values - #l{ke={protected,T,var_list(Rs)},i=I,a=A#k.a,vdb=Pdb2}. - -%% expr(Kexpr, I, Vdb) -> Expr. - -expr(#k_test{anno=A,op=Op,args=As,inverted=Inverted}, I, _Vdb) -> - #l{ke={test,test_op(Op),atomic_list(As),Inverted},i=I,a=A#k.a}; -expr(#k_call{anno=A,op=Op,args=As,ret=Rs}, I, _Vdb) -> - #l{ke={call,call_op(Op),atomic_list(As),var_list(Rs)},i=I,a=A#k.a}; -expr(#k_enter{anno=A,op=Op,args=As}, I, _Vdb) -> - #l{ke={enter,call_op(Op),atomic_list(As)},i=I,a=A#k.a}; -expr(#k_bif{anno=A,op=Op,args=As,ret=Rs}, I, _Vdb) -> - Bif = k_bif(A, Op, As, Rs), - #l{ke=Bif,i=I,a=A#k.a}; -expr(#k_match{anno=A,body=Kb,ret=Rs}, I, Vdb) -> - %% Work out imported variables which need to be locked. - Mdb = vdb_sub(I, I+1, Vdb), - M = match(Kb, A#k.us, I+1, [], Mdb), - #l{ke={match,M,var_list(Rs)},i=I,vdb=use_vars(A#k.us, I+1, Mdb),a=A#k.a}; -expr(#k_guard_match{anno=A,body=Kb,ret=Rs}, I, Vdb) -> - %% Work out imported variables which need to be locked. - Mdb = vdb_sub(I, I+1, Vdb), - M = match(Kb, A#k.us, I+1, [], Mdb), - #l{ke={guard_match,M,var_list(Rs)},i=I,vdb=use_vars(A#k.us, I+1, Mdb),a=A#k.a}; -expr(#k_try{}=Try, I, Vdb) -> - body_try(Try, I, Vdb); -expr(#k_protected{}=Protected, I, Vdb) -> - protected(Protected, I, Vdb); -expr(#k_try_enter{anno=A,arg=Ka,vars=Vs,body=Kb,evars=Evs,handler=Kh}, I, Vdb) -> - %% Lock variables that are alive before the catch and used afterwards. - %% Don't lock variables that are only used inside the try. - Tdb0 = vdb_sub(I, I+1, Vdb), - %% This is the tricky bit. Lock variables in Arg that are used in - %% the body and handler. Add try tag 'variable'. - Ab = get_kanno(Kb), - Ah = get_kanno(Kh), - Tdb1 = use_vars(union(Ab#k.us, Ah#k.us), I+3, Tdb0), - Tdb2 = vdb_sub(I, I+2, Tdb1), - Vnames = fun (Kvar) -> Kvar#k_var.name end, %Get the variable names - {Aes,_,Adb} = body(Ka, I+2, add_var({catch_tag,I+1}, I+1, 1000000, Tdb2)), - {Bes,_,Bdb} = body(Kb, I+4, new_vars(sort(map(Vnames, Vs)), I+3, Tdb2)), - {Hes,_,Hdb} = body(Kh, I+4, new_vars(sort(map(Vnames, Evs)), I+3, Tdb2)), - #l{ke={try_enter,#l{ke={block,Aes},i=I+1,vdb=Adb,a=[]}, - var_list(Vs),#l{ke={block,Bes},i=I+3,vdb=Bdb,a=[]}, - var_list(Evs),#l{ke={block,Hes},i=I+3,vdb=Hdb,a=[]}}, - i=I,vdb=Tdb1,a=A#k.a}; -expr(#k_catch{anno=A,body=Kb,ret=[R]}, I, Vdb) -> - %% Lock variables that are alive before the catch and used afterwards. - %% Don't lock variables that are only used inside the catch. - %% Add catch tag 'variable'. - Cdb0 = vdb_sub(I, I+1, Vdb), - {Es,_,Cdb1} = body(Kb, I+1, add_var({catch_tag,I}, I, locked, Cdb0)), - #l{ke={'catch',Es,variable(R)},i=I,vdb=Cdb1,a=A#k.a}; -expr(#k_receive{anno=A,var=V,body=Kb,timeout=T,action=Ka,ret=Rs}, I, Vdb) -> - %% Work out imported variables which need to be locked. - Rdb = vdb_sub(I, I+1, Vdb), - M = match(Kb, add_element(V#k_var.name, A#k.us), I+1, [], - new_vars([V#k_var.name], I, Rdb)), - {Tes,_,Adb} = body(Ka, I+1, Rdb), - #l{ke={receive_loop,atomic(T),variable(V),M, - #l{ke=Tes,i=I+1,vdb=Adb,a=[]},var_list(Rs)}, - i=I,vdb=use_vars(A#k.us, I+1, Vdb),a=A#k.a}; -expr(#k_receive_accept{anno=A}, I, _Vdb) -> - #l{ke=receive_accept,i=I,a=A#k.a}; -expr(#k_receive_next{anno=A}, I, _Vdb) -> - #l{ke=receive_next,i=I,a=A#k.a}; -expr(#k_put{anno=A,arg=Arg,ret=Rs}, I, _Vdb) -> - #l{ke={set,var_list(Rs),literal(Arg, [])},i=I,a=A#k.a}; -expr(#k_break{anno=A,args=As}, I, _Vdb) -> - #l{ke={break,atomic_list(As)},i=I,a=A#k.a}; -expr(#k_guard_break{anno=A,args=As}, I, Vdb) -> - Locked = [V || {V,_,_} <- Vdb], - #l{ke={guard_break,atomic_list(As),Locked},i=I,a=A#k.a}; -expr(#k_return{anno=A,args=As}, I, _Vdb) -> - #l{ke={return,atomic_list(As)},i=I,a=A#k.a}. - -body_try(#k_try{anno=A,arg=Ka,vars=Vs,body=Kb,evars=Evs,handler=Kh,ret=Rs}, - I, Vdb) -> - %% Lock variables that are alive before the catch and used afterwards. - %% Don't lock variables that are only used inside the try. - Tdb0 = vdb_sub(I, I+1, Vdb), - %% This is the tricky bit. Lock variables in Arg that are used in - %% the body and handler. Add try tag 'variable'. - Ab = get_kanno(Kb), - Ah = get_kanno(Kh), - Tdb1 = use_vars(union(Ab#k.us, Ah#k.us), I+3, Tdb0), - Tdb2 = vdb_sub(I, I+2, Tdb1), - Vnames = fun (Kvar) -> Kvar#k_var.name end, %Get the variable names - {Aes,_,Adb} = body(Ka, I+2, add_var({catch_tag,I+1}, I+1, locked, Tdb2)), - {Bes,_,Bdb} = body(Kb, I+4, new_vars(sort(map(Vnames, Vs)), I+3, Tdb2)), - {Hes,_,Hdb} = body(Kh, I+4, new_vars(sort(map(Vnames, Evs)), I+3, Tdb2)), - #l{ke={'try',#l{ke={block,Aes},i=I+1,vdb=Adb,a=[]}, - var_list(Vs),#l{ke={block,Bes},i=I+3,vdb=Bdb,a=[]}, - var_list(Evs),#l{ke={block,Hes},i=I+3,vdb=Hdb,a=[]}, - var_list(Rs)}, - i=I,vdb=Tdb1,a=A#k.a}. - -%% call_op(Op) -> Op. -%% test_op(Op) -> Op. -%% Do any necessary name translations here to munge into beam format. - -call_op(#k_local{name=N}) -> N; -call_op(#k_remote{mod=M,name=N}) -> {remote,atomic(M),atomic(N)}; -call_op(Other) -> variable(Other). - -test_op(#k_remote{mod=#k_atom{val=erlang},name=#k_atom{val=N}}) -> N. - -%% k_bif(Anno, Op, [Arg], [Ret], Vdb) -> Expr. -%% Build bifs. - -k_bif(_A, #k_internal{name=Name}, As, Rs) -> - {internal,Name,atomic_list(As),var_list(Rs)}; -k_bif(_A, #k_remote{mod=#k_atom{val=erlang},name=#k_atom{val=Name}}, As, Rs) -> - Ar = length(As), - case is_gc_bif(Name, Ar) of - false -> - {bif,Name,atomic_list(As),var_list(Rs)}; - true -> - {gc_bif,Name,atomic_list(As),var_list(Rs)} - end. - -%% match(Kexpr, [LockVar], I, Vdb) -> Expr. -%% Convert match tree to old format. - -match(#k_alt{anno=A,first=Kf,then=Kt}, Ls, I, Ctxt, Vdb0) -> - Vdb1 = use_vars(union(A#k.us, Ls), I, Vdb0), - F = match(Kf, Ls, I+1, Ctxt, Vdb1), - T = match(Kt, Ls, I+1, Ctxt, Vdb1), - #l{ke={alt,F,T},i=I,vdb=Vdb1,a=A#k.a}; -match(#k_select{anno=A,var=V,types=Kts}, Ls0, I, Ctxt, Vdb0) -> - Vanno = get_kanno(V), - Ls1 = case member(no_usage, Vanno) of - false -> add_element(V#k_var.name, Ls0); - true -> Ls0 - end, - Anno = case member(reuse_for_context, Vanno) of - true -> [reuse_for_context|A#k.a]; - false -> A#k.a - end, - Vdb1 = use_vars(union(A#k.us, Ls1), I, Vdb0), - Ts = [type_clause(Tc, Ls1, I+1, Ctxt, Vdb1) || Tc <- Kts], - #l{ke={select,literal(V, Ctxt),Ts},i=I,vdb=Vdb1,a=Anno}; -match(#k_guard{anno=A,clauses=Kcs}, Ls, I, Ctxt, Vdb0) -> - Vdb1 = use_vars(union(A#k.us, Ls), I, Vdb0), - Cs = [guard_clause(G, Ls, I+1, Ctxt, Vdb1) || G <- Kcs], - #l{ke={guard,Cs},i=I,vdb=Vdb1,a=A#k.a}; -match(Other, Ls, I, _Ctxt, Vdb0) -> - Vdb1 = use_vars(Ls, I, Vdb0), - {B,_,Vdb2} = body(Other, I+1, Vdb1), - #l{ke={block,B},i=I,vdb=Vdb2,a=[]}. - -type_clause(#k_type_clause{anno=A,type=T,values=Kvs}, Ls, I, Ctxt, Vdb0) -> - %%ok = io:format("life ~w: ~p~n", [?LINE,{T,Kvs}]), - Vdb1 = use_vars(union(A#k.us, Ls), I+1, Vdb0), - Vs = [val_clause(Vc, Ls, I+1, Ctxt, Vdb1) || Vc <- Kvs], - #l{ke={type_clause,type(T),Vs},i=I,vdb=Vdb1,a=A#k.a}. - -val_clause(#k_val_clause{anno=A,val=V,body=Kb}, Ls0, I, Ctxt0, Vdb0) -> - New = (get_kanno(V))#k.ns, - Bus = (get_kanno(Kb))#k.us, - %%ok = io:format("Ls0 = ~p, Used=~p\n New=~p, Bus=~p\n", [Ls0,Used,New,Bus]), - Ls1 = union(intersection(New, Bus), Ls0), %Lock for safety - Vdb1 = use_vars(union(A#k.us, Ls1), I+1, new_vars(New, I, Vdb0)), - Ctxt = case V of - #k_binary{segs=#k_var{name=C0}} -> C0; - _ -> Ctxt0 - end, - B = match(Kb, Ls1, I+1, Ctxt, Vdb1), - #l{ke={val_clause,literal(V, Ctxt),B},i=I,vdb=use_vars(Bus, I+1, Vdb1),a=A#k.a}. - -guard_clause(#k_guard_clause{anno=A,guard=Kg,body=Kb}, Ls, I, Ctxt, Vdb0) -> - Vdb1 = use_vars(union(A#k.us, Ls), I+2, Vdb0), - Gdb = vdb_sub(I+1, I+2, Vdb1), - G = protected(Kg, I+1, Gdb), - B = match(Kb, Ls, I+2, Ctxt, Vdb1), - #l{ke={guard_clause,G,B}, - i=I,vdb=use_vars((get_kanno(Kg))#k.us, I+2, Vdb1), - a=A#k.a}. - -%% type(Ktype) -> Type. - -type(k_literal) -> literal; -type(k_int) -> integer; -%%type(k_char) -> integer; %Hhhmmm??? -type(k_float) -> float; -type(k_atom) -> atom; -type(k_nil) -> nil; -type(k_cons) -> cons; -type(k_tuple) -> tuple; -type(k_binary) -> binary; -type(k_bin_seg) -> bin_seg; -type(k_bin_int) -> bin_int; -type(k_bin_end) -> bin_end; -type(k_map) -> map. - -%% variable(Klit) -> Lit. -%% var_list([Klit]) -> [Lit]. - -variable(#k_var{name=N}) -> {var,N}. - -var_list(Ks) -> [variable(K) || K <- Ks]. - -%% atomic(Klit) -> Lit. -%% atomic_list([Klit]) -> [Lit]. - -atomic(#k_literal{val=V}) -> {literal,V}; -atomic(#k_var{name=N}) -> {var,N}; -atomic(#k_int{val=I}) -> {integer,I}; -atomic(#k_float{val=F}) -> {float,F}; -atomic(#k_atom{val=N}) -> {atom,N}; -%%atomic(#k_char{val=C}) -> {char,C}; -atomic(#k_nil{}) -> nil. - -atomic_list(Ks) -> [atomic(K) || K <- Ks]. - -%% literal(Klit) -> Lit. -%% literal_list([Klit]) -> [Lit]. - -literal(#k_var{name=N}, _) -> {var,N}; -literal(#k_literal{val=I}, _) -> {literal,I}; -literal(#k_int{val=I}, _) -> {integer,I}; -literal(#k_float{val=F}, _) -> {float,F}; -literal(#k_atom{val=N}, _) -> {atom,N}; -%%literal(#k_char{val=C}, _) -> {char,C}; -literal(#k_nil{}, _) -> nil; -literal(#k_cons{hd=H,tl=T}, Ctxt) -> - {cons,[literal(H, Ctxt),literal(T, Ctxt)]}; -literal(#k_binary{segs=V}, Ctxt) -> - {binary,literal(V, Ctxt)}; -literal(#k_bin_seg{size=S,unit=U,type=T,flags=Fs,seg=Seg,next=[]}, Ctxt) -> - %% Only occurs in patterns. - {bin_seg,Ctxt,literal(S, Ctxt),U,T,Fs,[literal(Seg, Ctxt)]}; -literal(#k_bin_seg{size=S,unit=U,type=T,flags=Fs,seg=Seg,next=N}, Ctxt) -> - {bin_seg,Ctxt,literal(S, Ctxt),U,T,Fs, - [literal(Seg, Ctxt),literal(N, Ctxt)]}; -literal(#k_bin_int{size=S,unit=U,flags=Fs,val=Int,next=N}, Ctxt) -> - %% Only occurs in patterns. - {bin_int,Ctxt,literal(S, Ctxt),U,Fs,Int, - [literal(N, Ctxt)]}; -literal(#k_bin_end{}, Ctxt) -> - {bin_end,Ctxt}; -literal(#k_tuple{es=Es}, Ctxt) -> - {tuple,literal_list(Es, Ctxt)}; -literal(#k_map{op=Op,var=Var,es=Es0}, Ctxt) -> - {map,Op,literal(Var, Ctxt),literal_list(Es0, Ctxt)}; -literal(#k_map_pair{key=K,val=V}, Ctxt) -> - {map_pair,literal(K, Ctxt),literal(V, Ctxt)}. - -literal_list(Ks, Ctxt) -> - [literal(K, Ctxt) || K <- Ks]. - - -%% is_gc_bif(Name, Arity) -> true|false -%% Determines whether the BIF Name/Arity might do a GC. - -is_gc_bif(hd, 1) -> false; -is_gc_bif(tl, 1) -> false; -is_gc_bif(self, 0) -> false; -is_gc_bif(node, 0) -> false; -is_gc_bif(node, 1) -> false; -is_gc_bif(element, 2) -> false; -is_gc_bif(get, 1) -> false; -is_gc_bif(tuple_size, 1) -> false; -is_gc_bif(Bif, Arity) -> - not (erl_internal:bool_op(Bif, Arity) orelse - erl_internal:new_type_test(Bif, Arity) orelse - erl_internal:comp_op(Bif, Arity)). - -%% Keep track of life time for variables. -%% -%% init_vars([{var,VarName}]) -> Vdb. -%% new_vars([VarName], I, Vdb) -> Vdb. -%% use_vars([VarName], I, Vdb) -> Vdb. -%% add_var(VarName, F, L, Vdb) -> Vdb. -%% -%% The list of variable names for new_vars/3 and use_vars/3 -%% must be sorted. - -init_vars(Vs) -> - vdb_new(Vs). - -new_vars([], _, Vdb) -> Vdb; -new_vars([V], I, Vdb) -> vdb_store_new(V, {V,I,I}, Vdb); -new_vars(Vs, I, Vdb) -> vdb_update_vars(Vs, Vdb, I). - -use_vars([], _, Vdb) -> - Vdb; -use_vars([V], I, Vdb) -> - case vdb_find(V, Vdb) of - {V,F,L} when I > L -> vdb_update(V, {V,F,I}, Vdb); - {V,_,_} -> Vdb; - error -> vdb_store_new(V, {V,I,I}, Vdb) - end; -use_vars(Vs, I, Vdb) -> vdb_update_vars(Vs, Vdb, I). - -add_var(V, F, L, Vdb) -> - vdb_store_new(V, {V,F,L}, Vdb). - -%% vdb - -vdb_new(Vs) -> - sort([{V,0,0} || {var,V} <- Vs]). - --type var() :: atom(). - --spec vdb_find(var(), [vdb_entry()]) -> 'error' | vdb_entry(). - -vdb_find(V, Vdb) -> - case lists:keyfind(V, 1, Vdb) of - false -> error; - Vd -> Vd - end. - -vdb_update(V, Update, [{V,_,_}|Vdb]) -> - [Update|Vdb]; -vdb_update(V, Update, [Vd|Vdb]) -> - [Vd|vdb_update(V, Update, Vdb)]. - -vdb_store_new(V, New, [{V1,_,_}=Vd|Vdb]) when V > V1 -> - [Vd|vdb_store_new(V, New, Vdb)]; -vdb_store_new(V, New, [{V1,_,_}|_]=Vdb) when V < V1 -> - [New|Vdb]; -vdb_store_new(_, New, []) -> [New]. - -vdb_update_vars([V|_]=Vs, [{V1,_,_}=Vd|Vdb], I) when V > V1 -> - [Vd|vdb_update_vars(Vs, Vdb, I)]; -vdb_update_vars([V|Vs], [{V1,_,_}|_]=Vdb, I) when V < V1 -> - %% New variable. - [{V,I,I}|vdb_update_vars(Vs, Vdb, I)]; -vdb_update_vars([V|Vs], [{_,F,L}=Vd|Vdb], I) -> - %% Existing variable. - if - I > L -> [{V,F,I}|vdb_update_vars(Vs, Vdb, I)]; - true -> [Vd|vdb_update_vars(Vs, Vdb, I)] - end; -vdb_update_vars([V|Vs], [], I) -> - %% New variable. - [{V,I,I}|vdb_update_vars(Vs, [], I)]; -vdb_update_vars([], Vdb, _) -> Vdb. - -%% vdb_sub(Min, Max, Vdb) -> Vdb. -%% Extract variables which are used before and after Min. Lock -%% variables alive after Max. - -vdb_sub(Min, Max, Vdb) -> - [ if L >= Max -> {V,F,locked}; - true -> Vd - end || {V,F,L}=Vd <- Vdb, F < Min, L >= Min ]. diff --git a/lib/compiler/test/Makefile b/lib/compiler/test/Makefile index 63763f31b2..da5d207db9 100644 --- a/lib/compiler/test/Makefile +++ b/lib/compiler/test/Makefile @@ -22,6 +22,7 @@ MODULES= \ bs_construct_SUITE \ bs_match_SUITE \ bs_utf_SUITE \ + core_alias_SUITE \ core_fold_SUITE \ compile_SUITE \ compilation_SUITE \ diff --git a/lib/compiler/test/beam_block_SUITE.erl b/lib/compiler/test/beam_block_SUITE.erl index 55d5f2dbe8..38ead96cc8 100644 --- a/lib/compiler/test/beam_block_SUITE.erl +++ b/lib/compiler/test/beam_block_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, get_map_elements/1,otp_7345/1,move_opt_across_gc_bif/1, - erl_202/1,repro/1]). + erl_202/1,repro/1,local_cse/1,second_block_pass/1]). %% The only test for the following functions is that %% the code compiles and is accepted by beam_validator. @@ -40,7 +40,9 @@ groups() -> otp_7345, move_opt_across_gc_bif, erl_202, - repro + repro, + local_cse, + second_block_pass ]}]. init_per_suite(Config) -> @@ -237,6 +239,72 @@ find_operands(Cfg,XsiGraph,ActiveList,Count) -> [Count+1, length(NewActiveList), length(digraph:vertices(XsiGraph))], find_operands(NewCfg,XsiGraph,NewActiveList,Count+1). +%% Some tests of local common subexpression elimination (CSE). + +local_cse(_Config) -> + {Self,{ok,Self}} = local_cse_1(), + + local_cse_2([]), + local_cse_2(lists:seq(1, 512)), + local_cse_2(?MODULE:module_info()), + + {[b],[a,b]} = local_cse_3(a, b), + + {2000,Self,{Self,write_cache}} = local_cse_4(), + + ok. + +local_cse_1() -> + %% Cover handling of unsafe tuple construction in + %% eliminate_use_of_from_reg/4. It became necessary to handle + %% unsafe tuples when local CSE was introduced. + + {self(),{ok,self()}}. + +local_cse_2(Term) -> + case cse_make_binary(Term) of + <<Size:8,BinTerm:Size/binary>> -> + Term = binary_to_term(BinTerm); + <<Size:8,SizeTerm:Size/binary,BinTerm/binary>> -> + {'$size',TermSize} = binary_to_term(SizeTerm), + TermSize = byte_size(BinTerm), + Term = binary_to_term(BinTerm) + end. + +%% Copy of observer_backend:ttb_make_binary/1. During development of +%% the local CSE optimization this function was incorrectly optimized. + +cse_make_binary(Term) -> + B = term_to_binary(Term), + SizeB = byte_size(B), + if SizeB > 255 -> + SB = term_to_binary({'$size',SizeB}), + <<(byte_size(SB)):8, SB/binary, B/binary>>; + true -> + <<SizeB:8, B/binary>> + end. + +local_cse_3(X, Y) -> + %% The following expression was incorrectly transformed to {[X,Y],[X,Y]} + %% during development of the local CSE optimization. + + {[Y],[X,Y]}. + +local_cse_4() -> + do_local_cse_4(2000, self(), {self(), write_cache}). + +do_local_cse_4(X, Y, Z) -> + {X,Y,Z}. + +%% Tests previously found bugs when running beam_block the second time. + +second_block_pass(_Config) -> + [#{dts:=5.0}] = second_1([#{dts => 10.0}], 2.0), + ok. + +second_1(Fs, TS) -> + [F#{dts=>DTS / TS} || #{dts:=DTS} = F <- Fs]. + %%% %%% Common functions. %%% diff --git a/lib/compiler/test/beam_type_SUITE.erl b/lib/compiler/test/beam_type_SUITE.erl index d44fa60997..541075af2a 100644 --- a/lib/compiler/test/beam_type_SUITE.erl +++ b/lib/compiler/test/beam_type_SUITE.erl @@ -23,7 +23,7 @@ init_per_group/2,end_per_group/2, integers/1,coverage/1,booleans/1,setelement/1,cons/1, tuple/1,record_float/1,binary_float/1,float_compare/1, - arity_checks/1]). + arity_checks/1,elixir_binaries/1]). suite() -> [{ct_hooks,[ts_install_cth]}]. @@ -42,7 +42,8 @@ groups() -> record_float, binary_float, float_compare, - arity_checks + arity_checks, + elixir_binaries ]}]. init_per_suite(Config) -> @@ -121,7 +122,7 @@ do_integers_5(X0, Y0) -> 3 -> three end. -coverage(_Config) -> +coverage(Config) -> {'EXIT',{badarith,_}} = (catch id(1) bsl 0.5), {'EXIT',{badarith,_}} = (catch id(2.0) bsl 2), {'EXIT',{badarith,_}} = (catch a + 0.5), @@ -132,6 +133,29 @@ coverage(_Config) -> id(id(42) band 387439739874298734983787934283479243879), id(-1 band id(13)), + error = if + is_map(Config), is_integer(Config) -> ok; + true -> error + end, + error = if + is_map(Config), is_atom(Config) -> ok; + true -> error + end, + error = if + is_map(Config), is_tuple(Config) -> ok; + true -> error + end, + error = if + is_integer(Config), is_bitstring(Config) -> ok; + true -> error + end, + + ok = case Config of + <<_>> when is_binary(Config) -> + impossible; + [_|_] -> + ok + end, ok. booleans(_Config) -> @@ -232,5 +256,42 @@ do_tuple_arity_check(RGB) when is_tuple(RGB), _ -> ok end. +elixir_binaries(_Config) -> + <<"foo blitzky baz">> = elixir_binary_1(<<"blitzky">>), + <<"foo * baz">> = elixir_binary_2($*), + <<7:4,755:10>> = elixir_bitstring_3(<<755:10>>), + ok. + +elixir_binary_1(Bar) when is_binary(Bar) -> + <<"foo ", + case Bar of + Rewrite when is_binary(Rewrite) -> + Rewrite; + Rewrite -> + list_to_binary(Rewrite) + end/binary, + " baz">>. + +elixir_binary_2(Arg) -> + Bin = <<Arg>>, + <<"foo ", + case Bin of + Rewrite when is_binary(Rewrite) -> + Rewrite; + Rewrite -> + list_to_binary:to_string(Rewrite) + end/binary, + " baz">>. + +elixir_bitstring_3(Bar) when is_bitstring(Bar) -> + <<7:4, + case Bar of + Rewrite when is_bitstring(Rewrite) -> + Rewrite; + Rewrite -> + list_to_bitstring(Rewrite) + end/bitstring>>. + + id(I) -> I. diff --git a/lib/compiler/test/beam_utils_SUITE.erl b/lib/compiler/test/beam_utils_SUITE.erl index 710cb050d4..b2a5cada3d 100644 --- a/lib/compiler/test/beam_utils_SUITE.erl +++ b/lib/compiler/test/beam_utils_SUITE.erl @@ -24,7 +24,8 @@ apply_fun/1,apply_mf/1,bs_init/1,bs_save/1, is_not_killed/1,is_not_used_at/1, select/1,y_catch/1,otp_8949_b/1,liveopt/1,coverage/1, - y_registers/1]). + y_registers/1,user_predef/1,scan_f/1,cafu/1, + receive_label/1,read_size_file_version/1,not_used/1]). -export([id/1]). suite() -> [{ct_hooks,[ts_install_cth]}]. @@ -46,7 +47,12 @@ groups() -> otp_8949_b, liveopt, coverage, - y_registers + y_registers, + user_predef, + scan_f, + cafu, + read_size_file_version, + not_used ]}]. init_per_suite(Config) -> @@ -117,6 +123,15 @@ bs_init(_Config) -> {'EXIT',{badarg,_}} = (catch do_bs_init_2([0.5])), {'EXIT',{badarg,_}} = (catch do_bs_init_2([-1])), {'EXIT',{badarg,_}} = (catch do_bs_init_2([1 bsl 32])), + + <<>> = do_bs_init_3({tag,0}, 0, 0), + <<0>> = do_bs_init_3({tag,0}, 2, 1), + + <<"_build/shared">> = do_bs_init_4([], false), + <<"abc/shared">> = do_bs_init_4(<<"abc">>, false), + <<"foo/foo">> = do_bs_init_4(<<"foo">>, true), + error = do_bs_init_4([], not_boolean), + ok. do_bs_init_1([?MODULE], Sz) -> @@ -134,6 +149,45 @@ do_bs_init_2(SigNos) -> erlang:error(badarg) >>. +do_bs_init_3({tag,Pos}, Offset, Len) -> + N0 = Offset - Pos, + N = if N0 > Len -> Len; + true -> N0 + end, + <<0:N/unit:8>>. + +do_bs_init_4(Arg1, Arg2) -> + Build = + case id(Arg1) of + X when X =:= [] orelse X =:= false -> <<"_build">>; + X -> X + end, + case id(Arg2) of + true -> + id(<<case Build of + Rewrite when is_binary(Rewrite) -> + Rewrite; + Rewrite -> + id(Rewrite) + end/binary, + "/", + case id(<<"foo">>) of + Rewrite when is_binary(Rewrite) -> + Rewrite; + Rewrite -> + id(Rewrite) + end/binary>>); + false -> + id(<<case Build of + Rewrite when is_binary(Rewrite) -> + Rewrite; + Rewrite -> + id(Rewrite) + end/binary, + "/shared">>); + Other -> + error + end. bs_save(_Config) -> {a,30,<<>>} = do_bs_save(<<1:1,30:5>>), @@ -376,5 +430,102 @@ do(A, B) -> {A,B}. appointment(#{"resolution" := Url}) -> do(receive _ -> Url end, #{true => Url}). +%% From epp.erl. +user_predef(_Config) -> + #{key:="value"} = user_predef({key,"value"}, #{}), + #{key:="value"} = user_predef({key,"value"}, #{key=>defined}), + error = user_predef({key,"value"}, #{key=>[defined]}), + ok. + +user_predef({M,Val}, Ms) -> + case Ms of + #{M:=Defs} when is_list(Defs) -> + error; + _ -> + Ms#{M=>Val} + end. + +%% From disk_log_1.erl. +scan_f(_Config) -> + {1,<<>>,[]} = scan_f(<<1:32>>, 1, []), + {1,<<>>,[<<156>>]} = scan_f(<<1:32,156,1:32>>, 1, []), + ok. + +scan_f(<<Size:32,Tail/binary>>, FSz, Acc) when Size =< FSz -> + case Tail of + <<BinTerm:Size/binary,Tail2/binary>> -> + scan_f(Tail2, FSz, [BinTerm | Acc]); + _ -> + {Size,Tail,Acc} + end. + +%% From file_io_server.erl. +cafu(_Config) -> + error = cafu(<<42:32>>, -1, 0, {utf32,big}), + error = cafu(<<42:32>>, 10, 0, {utf32,big}), + error = cafu(<<42:32>>, -1, 0, {utf32,little}), + ok. + +cafu(<<_/big-utf32,Rest/binary>>, N, Count, {utf32,big}) when N < 0 -> + cafu(Rest, -1, Count+1, {utf32,big}); +cafu(<<_/big-utf32,Rest/binary>>, N, Count, {utf32,big}) -> + cafu(Rest, N-1, Count+1, {utf32,big}); +cafu(<<_/little-utf32,Rest/binary>>, N, Count, {utf32,little}) when N < 0 -> + cafu(Rest, -1, Count+1, {utf32,little}); +cafu(_, _, _, _) -> + error. + +-record(rec_label, {bool}). + +receive_label(_Config) -> + Pid = spawn_link(fun() -> do_receive_label(#rec_label{bool=true}) end), + Msg = {a,b,c}, + Pid ! {self(),Msg}, + receive + {ok,Msg} -> + unlink(Pid), + exit(Pid, die), + ok + end. + +do_receive_label(Rec) -> + receive + {From,Message} when Rec#rec_label.bool -> + From ! {ok,Message}, + do_receive_label(Rec) + end. + +read_size_file_version(_Config) -> + ok = do_read_size_file_version({ok,<<42>>}), + {ok,7777} = do_read_size_file_version({ok,<<7777:32>>}), + ok. + +do_read_size_file_version(E) -> + case E of + {ok,<<Version>>} when Version =:= 42 -> + ok; + {ok,<<MaxFiles:32>>} -> + {ok,MaxFiles} + end. + +-record(s, { a, b }). +-record(k, { v }). + +not_used(_Config) -> + [] = not_used_p(any, #s{b=true}, #k{}, ignored), + #k{v=42} = not_used_p(any, #s{b=false}, #k{v=42}, ignored), + #k{v=42} = not_used_p(any, #s{b=bad}, #k{v=42}, ignored), + ok. + +not_used_p(_C, S, K, L) when is_record(K, k) -> + if ((S#s.b) and + (S#s.b)) -> + []; + true -> + id(L), + id(K#k.v), + id(K) + end. + %% The identity function. id(I) -> I. diff --git a/lib/compiler/test/beam_validator_SUITE.erl b/lib/compiler/test/beam_validator_SUITE.erl index c23514b36b..3af71559ae 100644 --- a/lib/compiler/test/beam_validator_SUITE.erl +++ b/lib/compiler/test/beam_validator_SUITE.erl @@ -33,8 +33,9 @@ state_after_fault_in_catch/1,no_exception_in_catch/1, undef_label/1,illegal_instruction/1,failing_gc_guard_bif/1, map_field_lists/1,cover_bin_opt/1, - val_dsetel/1]). - + val_dsetel/1,bad_tuples/1,bad_try_catch_nesting/1, + receive_stacked/1]). + -include_lib("common_test/include/ct.hrl"). init_per_testcase(Case, Config) when is_atom(Case), is_list(Config) -> @@ -61,7 +62,9 @@ groups() -> freg_state,bad_bin_match,bad_dsetel, state_after_fault_in_catch,no_exception_in_catch, undef_label,illegal_instruction,failing_gc_guard_bif, - map_field_lists,cover_bin_opt,val_dsetel]}]. + map_field_lists,cover_bin_opt,val_dsetel, + bad_tuples,bad_try_catch_nesting, + receive_stacked]}]. init_per_suite(Config) -> Config. @@ -421,9 +424,9 @@ try_bin_opt(Mod) -> try do_bin_opt(Mod) catch - Class:Error -> + Class:Error:Stk -> io:format("~p: ~p ~p\n~p\n", - [Mod,Class,Error,erlang:get_stacktrace()]), + [Mod,Class,Error,Stk]), error end. @@ -509,6 +512,73 @@ destroy_reg({Tag,N}) -> {y,N+1} end. +bad_tuples(Config) -> + Errors = do_val(bad_tuples, Config), + [{{bad_tuples,heap_overflow,1}, + {{put,{x,0}},8,{heap_overflow,{left,0},{wanted,1}}}}, + {{bad_tuples,long,2}, + {{put,{atom,too_long}},8,not_building_a_tuple}}, + {{bad_tuples,self_referential,1}, + {{put,{x,1}},7,{tuple_in_progress,{x,1}}}}, + {{bad_tuples,short,1}, + {{move,{x,1},{x,0}},7,{tuple_in_progress,{x,1}}}}] = Errors, + + ok. + +bad_try_catch_nesting(Config) -> + Errors = do_val(bad_try_catch_nesting, Config), + [{{bad_try_catch_nesting,main,2}, + {{'try',{y,2},{f,3}}, + 7, + {bad_try_catch_nesting,{y,2},[{{y,1},{trytag,[5]}}]}}}] = Errors, + ok. + +receive_stacked(Config) -> + Mod = ?FUNCTION_NAME, + Errors = do_val(Mod, Config), + [{{receive_stacked,f1,0}, + {{loop_rec_end,{f,3}}, + 17, + {fragile_message_reference,{y,0}}}}, + {{receive_stacked,f2,0}, + {{test_heap,3,0},10,{fragile_message_reference,{y,1}}}}, + {{receive_stacked,f3,0}, + {{test_heap,3,0},10,{fragile_message_reference,{y,1}}}}, + {{receive_stacked,f4,0}, + {{test_heap,3,0},10,{fragile_message_reference,{y,1}}}}, + {{receive_stacked,f5,0}, + {{loop_rec_end,{f,23}}, + 23, + {fragile_message_reference,{y,1}}}}, + {{receive_stacked,f6,0}, + {{gc_bif,byte_size,{f,29},0,[{y,0}],{x,0}}, + 12, + {fragile_message_reference,{y,0}}}}, + {{receive_stacked,f7,0}, + {{loop_rec_end,{f,33}}, + 20, + {fragile_message_reference,{y,0}}}}, + {{receive_stacked,f8,0}, + {{loop_rec_end,{f,38}}, + 20, + {fragile_message_reference,{y,0}}}}, + {{receive_stacked,m1,0}, + {{loop_rec_end,{f,43}}, + 19, + {fragile_message_reference,{y,0}}}}, + {{receive_stacked,m2,0}, + {{loop_rec_end,{f,48}}, + 33, + {fragile_message_reference,{y,0}}}}] = Errors, + + %% Compile the original source code as a smoke test. + Data = proplists:get_value(data_dir, Config), + Base = atom_to_list(Mod), + File = filename:join(Data, Base), + {ok,Mod,_} = compile:file(File, [binary]), + + ok. + %%%------------------------------------------------------------------------- transform_remove(Remove, Module) -> diff --git a/lib/compiler/test/beam_validator_SUITE_data/bad_try_catch_nesting.S b/lib/compiler/test/beam_validator_SUITE_data/bad_try_catch_nesting.S new file mode 100644 index 0000000000..9f1b21a17b --- /dev/null +++ b/lib/compiler/test/beam_validator_SUITE_data/bad_try_catch_nesting.S @@ -0,0 +1,64 @@ +{module, bad_try_catch_nesting}. %% version = 0 + +{exports, [{main,2},{module_info,0},{module_info,1}]}. + +{attributes, []}. + +{labels, 11}. + + +{function, main, 2, 2}. + {label,1}. + {line,[{location,"bad_try_catch_nesting.erl",4}]}. + {func_info,{atom,bad_try_catch_nesting},{atom,main},2}. + {label,2}. + {allocate_zero,3,2}. + {'try',{y,1},{f,5}}. + {move,{x,1},{y,0}}. + {'try',{y,2},{f,3}}. + {line,[{location,"bad_try_catch_nesting.erl",7}]}. + {call_fun,0}. + {try_end,{y,2}}. + {jump,{f,4}}. + {label,3}. + {try_case,{y,2}}. + {test,is_ne_exact,{f,4},[{x,0},{atom,error}]}. + {line,[]}. + {bif,raise,{f,0},[{x,2},{x,1}],{x,0}}. + {label,4}. + {move,{y,0},{x,0}}. + {kill,{y,0}}. + {line,[{location,"bad_try_catch_nesting.erl",12}]}. + {call_fun,0}. + {try_end,{y,1}}. + {deallocate,3}. + return. + {label,5}. + {try_case,{y,1}}. + {test,is_eq_exact,{f,6},[{x,0},{atom,throw}]}. + {deallocate,3}. + return. + {label,6}. + {line,[]}. + {bif,raise,{f,0},[{x,2},{x,1}],{x,0}}. + + +{function, module_info, 0, 8}. + {label,7}. + {line,[]}. + {func_info,{atom,bad_try_catch_nesting},{atom,module_info},0}. + {label,8}. + {move,{atom,bad_try_catch_nesting},{x,0}}. + {line,[]}. + {call_ext_only,1,{extfunc,erlang,get_module_info,1}}. + + +{function, module_info, 1, 10}. + {label,9}. + {line,[]}. + {func_info,{atom,bad_try_catch_nesting},{atom,module_info},1}. + {label,10}. + {move,{x,0},{x,1}}. + {move,{atom,bad_try_catch_nesting},{x,0}}. + {line,[]}. + {call_ext_only,2,{extfunc,erlang,get_module_info,2}}. diff --git a/lib/compiler/test/beam_validator_SUITE_data/bad_tuples.S b/lib/compiler/test/beam_validator_SUITE_data/bad_tuples.S new file mode 100644 index 0000000000..7980241c37 --- /dev/null +++ b/lib/compiler/test/beam_validator_SUITE_data/bad_tuples.S @@ -0,0 +1,88 @@ +{module, bad_tuples}. %% version = 0 + +{exports, [{heap_overflow,1}, + {long,2}, + {module_info,0}, + {module_info,1}, + {self_referential,1}, + {short,1}]}. + +{attributes, []}. + +{labels, 13}. + + +{function, short, 1, 2}. + {label,1}. + {line,[{location,"bad_tuples.erl",4}]}. + {func_info,{atom,bad_tuples},{atom,short},1}. + {label,2}. + {test_heap,3,1}. + {put_tuple,2,{x,1}}. + {put,{atom,ok}}. + {move,{x,1},{x,0}}. + return. + + +{function, long, 2, 4}. + {label,3}. + {line,[{location,"bad_tuples.erl",7}]}. + {func_info,{atom,bad_tuples},{atom,long},2}. + {label,4}. + {test_heap,6,2}. + {put_tuple,2,{x,2}}. + {put,{x,0}}. + {put,{x,1}}. + {put,{atom,too_long}}. + {put_tuple,2,{x,0}}. + {put,{atom,ok}}. + {put,{x,2}}. + return. + + +{function, heap_overflow, 1, 6}. + {label,5}. + {line,[{location,"bad_tuples.erl",10}]}. + {func_info,{atom,bad_tuples},{atom,heap_overflow},1}. + {label,6}. + {test_heap,3,1}. + {put_tuple,2,{x,1}}. + {put,{atom,ok}}. + {put,{x,0}}. + {put,{x,0}}. + {move,{x,1},{x,0}}. + return. + + +{function, self_referential, 1, 8}. + {label,7}. + {line,[{location,"bad_tuples.erl",13}]}. + {func_info,{atom,bad_tuples},{atom,self_referential},1}. + {label,8}. + {test_heap,3,1}. + {put_tuple,2,{x,1}}. + {put,{atom,ok}}. + {put,{x,1}}. + {move,{x,1},{x,0}}. + return. + + +{function, module_info, 0, 10}. + {label,9}. + {line,[]}. + {func_info,{atom,bad_tuples},{atom,module_info},0}. + {label,10}. + {move,{atom,bad_tuples},{x,0}}. + {line,[]}. + {call_ext_only,1,{extfunc,erlang,get_module_info,1}}. + + +{function, module_info, 1, 12}. + {label,11}. + {line,[]}. + {func_info,{atom,bad_tuples},{atom,module_info},1}. + {label,12}. + {move,{x,0},{x,1}}. + {move,{atom,bad_tuples},{x,0}}. + {line,[]}. + {call_ext_only,2,{extfunc,erlang,get_module_info,2}}. diff --git a/lib/compiler/test/beam_validator_SUITE_data/receive_stacked.S b/lib/compiler/test/beam_validator_SUITE_data/receive_stacked.S new file mode 100644 index 0000000000..cca052a9c4 --- /dev/null +++ b/lib/compiler/test/beam_validator_SUITE_data/receive_stacked.S @@ -0,0 +1,390 @@ +{module, receive_stacked}. %% version = 0 + +{exports, [{f1,0}, + {f2,0}, + {f3,0}, + {f4,0}, + {f5,0}, + {f6,0}, + {f7,0}, + {f8,0}, + {id,1}, + {m1,0}, + {m2,0}, + {module_info,0}, + {module_info,1}]}. + +{attributes, []}. + +{labels, 57}. + + +{function, f1, 0, 2}. + {label,1}. + {line,[{location,"receive_stacked.erl",15}]}. + {func_info,{atom,receive_stacked},{atom,f1},0}. + {label,2}. + {allocate_zero,1,0}. + {label,3}. + {loop_rec,{f,5},{x,0}}. + {move,{x,0},{y,0}}. + {test,is_integer,{f,4},[{y,0}]}. + remove_message. + {move,{integer,42},{x,0}}. + {line,[{location,"receive_stacked.erl",18}]}. + {call,1,{f,52}}. + {move,{y,0},{x,0}}. + {deallocate,1}. + return. + {label,4}. + {loop_rec_end,{f,3}}. + {label,5}. + {wait,{f,3}}. + + +{function, f2, 0, 7}. + {label,6}. + {line,[{location,"receive_stacked.erl",22}]}. + {func_info,{atom,receive_stacked},{atom,f2},0}. + {label,7}. + {allocate_zero,2,0}. + {label,8}. + {loop_rec,{f,10},{x,0}}. + {test,is_nonempty_list,{f,9},[{x,0}]}. + {get_list,{x,0},{y,1},{x,0}}. + {test,is_nil,{f,9},[{x,0}]}. + {test_heap,3,0}. + remove_message. + {put_tuple,2,{y,0}}. + {put,{atom,ok}}. + {put,{y,1}}. + {move,{integer,42},{x,0}}. + {line,[{location,"receive_stacked.erl",26}]}. + {call,1,{f,52}}. + {test_heap,3,0}. + {put_tuple,2,{x,0}}. + {put,{y,0}}. + {put,{y,1}}. + {deallocate,2}. + return. + {label,9}. + {loop_rec_end,{f,8}}. + {label,10}. + {wait,{f,8}}. + + +{function, f3, 0, 12}. + {label,11}. + {line,[{location,"receive_stacked.erl",30}]}. + {func_info,{atom,receive_stacked},{atom,f3},0}. + {label,12}. + {allocate_zero,2,0}. + {label,13}. + {loop_rec,{f,15},{x,0}}. + {test,is_nonempty_list,{f,14},[{x,0}]}. + {get_hd,{x,0},{y,1}}. + {test,is_integer,{f,14},[{y,1}]}. + {test_heap,3,0}. + remove_message. + {put_tuple,2,{y,0}}. + {put,{atom,ok}}. + {put,{y,1}}. + {move,{integer,42},{x,0}}. + {line,[{location,"receive_stacked.erl",34}]}. + {call,1,{f,52}}. + {test_heap,3,0}. + {put_tuple,2,{x,0}}. + {put,{y,0}}. + {put,{y,1}}. + {deallocate,2}. + return. + {label,14}. + {loop_rec_end,{f,13}}. + {label,15}. + {wait,{f,13}}. + + +{function, f4, 0, 17}. + {label,16}. + {line,[{location,"receive_stacked.erl",38}]}. + {func_info,{atom,receive_stacked},{atom,f4},0}. + {label,17}. + {allocate_zero,2,0}. + {label,18}. + {loop_rec,{f,20},{x,0}}. + {test,is_nonempty_list,{f,19},[{x,0}]}. + {get_tl,{x,0},{y,1}}. + {test,is_list,{f,19},[{y,1}]}. + {test_heap,3,0}. + remove_message. + {put_tuple,2,{y,0}}. + {put,{atom,ok}}. + {put,{y,1}}. + {move,{integer,42},{x,0}}. + {line,[{location,"receive_stacked.erl",42}]}. + {call,1,{f,52}}. + {test_heap,3,0}. + {put_tuple,2,{x,0}}. + {put,{y,0}}. + {put,{y,1}}. + {deallocate,2}. + return. + {label,19}. + {loop_rec_end,{f,18}}. + {label,20}. + {wait,{f,18}}. + + +{function, f5, 0, 22}. + {label,21}. + {line,[{location,"receive_stacked.erl",46}]}. + {func_info,{atom,receive_stacked},{atom,f5},0}. + {label,22}. + {allocate_zero,2,0}. + {label,23}. + {loop_rec,{f,25},{x,0}}. + {test,is_tuple,{f,24},[{x,0}]}. + {test,test_arity,{f,24},[{x,0},1]}. + {get_tuple_element,{x,0},0,{y,1}}. + {test,is_integer,{f,24},[{y,1}]}. + remove_message. + {put_map_assoc,{f,0},{literal,#{}},{y,0},0,{list,[{atom,key},{y,1}]}}. + {move,{integer,42},{x,0}}. + {line,[{location,"receive_stacked.erl",50}]}. + {call,1,{f,52}}. + {test_heap,3,0}. + {put_tuple,2,{x,0}}. + {put,{y,0}}. + {put,{y,1}}. + {deallocate,2}. + return. + {label,24}. + {loop_rec_end,{f,23}}. + {label,25}. + {wait,{f,23}}. + + +{function, f6, 0, 27}. + {label,26}. + {line,[{location,"receive_stacked.erl",54}]}. + {func_info,{atom,receive_stacked},{atom,f6},0}. + {label,27}. + {allocate_zero,1,0}. + {label,28}. + {loop_rec,{f,30},{x,0}}. + {test,bs_start_match2,{f,29},1,[{x,0},0],{x,0}}. + {test,bs_get_integer2, + {f,29}, + 1, + [{x,0}, + {integer,8}, + 1, + {field_flags,[{anno,[56,{file,"receive_stacked.erl"}]}, + unsigned,big]}], + {x,1}}. + {test,bs_get_binary2, + {f,29}, + 1, + [{x,0}, + {atom,all}, + 8, + {field_flags,[{anno,[56,{file,"receive_stacked.erl"}]}, + unsigned,big]}], + {y,0}}. + {'%', + {no_bin_opt, + {binary_used_in,{gc_bif,byte_size,{f,29},0,[{y,0}],{x,0}}}, + [56,{file,"receive_stacked.erl"}]}}. + {line,[{location,"receive_stacked.erl",56}]}. + {gc_bif,byte_size,{f,29},0,[{y,0}],{x,0}}. + {test,is_lt,{f,29},[{integer,8},{x,0}]}. + remove_message. + {move,{integer,42},{x,0}}. + {line,[{location,"receive_stacked.erl",57}]}. + {call,1,{f,52}}. + {move,{y,0},{x,0}}. + {deallocate,1}. + return. + {label,29}. + {loop_rec_end,{f,28}}. + {label,30}. + {wait,{f,28}}. + + +{function, f7, 0, 32}. + {label,31}. + {line,[{location,"receive_stacked.erl",61}]}. + {func_info,{atom,receive_stacked},{atom,f7},0}. + {label,32}. + {allocate_zero,1,0}. + {label,33}. + {loop_rec,{f,35},{x,0}}. + {test,bs_start_match2,{f,34},1,[{x,0},0],{x,0}}. + {test,bs_get_integer2, + {f,34}, + 1, + [{x,0}, + {integer,8}, + 1, + {field_flags,[{anno,[63,{file,"receive_stacked.erl"}]}, + unsigned,big]}], + {x,1}}. + {test,bs_get_binary2, + {f,34}, + 1, + [{x,0}, + {atom,all}, + 8, + {field_flags,[{anno,[63,{file,"receive_stacked.erl"}]}, + unsigned,big]}], + {y,0}}. + {'%',{no_bin_opt,{binary_used_in,{test,is_binary,{f,34},[{y,0}]}}, + [63,{file,"receive_stacked.erl"}]}}. + {test,is_binary,{f,34},[{y,0}]}. + remove_message. + {move,{integer,42},{x,0}}. + {line,[{location,"receive_stacked.erl",64}]}. + {call,1,{f,52}}. + {move,{y,0},{x,0}}. + {deallocate,1}. + return. + {label,34}. + {loop_rec_end,{f,33}}. + {label,35}. + {wait,{f,33}}. + + +{function, f8, 0, 37}. + {label,36}. + {line,[{location,"receive_stacked.erl",68}]}. + {func_info,{atom,receive_stacked},{atom,f8},0}. + {label,37}. + {allocate_zero,1,0}. + {label,38}. + {loop_rec,{f,40},{x,0}}. + {test,bs_start_match2,{f,39},1,[{x,0},0],{x,1}}. + {test,bs_get_integer2, + {f,39}, + 2, + [{x,1}, + {integer,8}, + 1, + {field_flags,[{anno,[70,{file,"receive_stacked.erl"}]}, + unsigned,big]}], + {x,2}}. + {test,bs_get_binary2, + {f,39}, + 2, + [{x,1}, + {atom,all}, + 8, + {field_flags,[{anno,[70,{file,"receive_stacked.erl"}]}, + unsigned,big]}], + {y,0}}. + {'%',{no_bin_opt,{[{x,1},{y,0}],{loop_rec_end,{f,38}},not_handled}, + [70,{file,"receive_stacked.erl"}]}}. + {test,is_binary,{f,39},[{x,0}]}. + remove_message. + {move,{integer,42},{x,0}}. + {line,[{location,"receive_stacked.erl",71}]}. + {call,1,{f,52}}. + {move,{y,0},{x,0}}. + {deallocate,1}. + return. + {label,39}. + {loop_rec_end,{f,38}}. + {label,40}. + {wait,{f,38}}. + + +{function, m1, 0, 42}. + {label,41}. + {line,[{location,"receive_stacked.erl",75}]}. + {func_info,{atom,receive_stacked},{atom,m1},0}. + {label,42}. + {allocate_zero,1,0}. + {label,43}. + {loop_rec,{f,45},{x,0}}. + {test,is_map,{f,44},[{x,0}]}. + {get_map_elements,{f,44},{x,0},{list,[{atom,key},{y,0}]}}. + {test,is_integer,{f,44},[{y,0}]}. + remove_message. + {move,{integer,42},{x,0}}. + {line,[{location,"receive_stacked.erl",78}]}. + {call,1,{f,52}}. + {test_heap,2,0}. + {put_list,{y,0},nil,{x,0}}. + {deallocate,1}. + return. + {label,44}. + {loop_rec_end,{f,43}}. + {label,45}. + {wait,{f,43}}. + + +{function, m2, 0, 47}. + {label,46}. + {line,[{location,"receive_stacked.erl",82}]}. + {func_info,{atom,receive_stacked},{atom,m2},0}. + {label,47}. + {allocate_zero,4,0}. + {move,{atom,key1},{x,0}}. + {line,[{location,"receive_stacked.erl",83}]}. + {call,1,{f,52}}. + {move,{x,0},{y,3}}. + {move,{atom,key2},{x,0}}. + {line,[{location,"receive_stacked.erl",84}]}. + {call,1,{f,52}}. + {move,{x,0},{y,2}}. + {label,48}. + {loop_rec,{f,50},{x,0}}. + {test,is_map,{f,49},[{x,0}]}. + {get_map_elements,{f,49},{x,0},{list,[{y,3},{y,1}]}}. + {get_map_elements,{f,49},{x,0},{list,[{y,2},{y,0}]}}. + {test,is_integer,{f,49},[{y,1}]}. + {test,is_integer,{f,49},[{y,0}]}. + remove_message. + {kill,{y,2}}. + {kill,{y,3}}. + {move,{integer,42},{x,0}}. + {line,[{location,"receive_stacked.erl",87}]}. + {call,1,{f,52}}. + {test_heap,3,0}. + {put_tuple,2,{x,0}}. + {put,{y,1}}. + {put,{y,0}}. + {deallocate,4}. + return. + {label,49}. + {loop_rec_end,{f,48}}. + {label,50}. + {wait,{f,48}}. + + +{function, id, 1, 52}. + {label,51}. + {line,[{location,"receive_stacked.erl",91}]}. + {func_info,{atom,receive_stacked},{atom,id},1}. + {label,52}. + return. + + +{function, module_info, 0, 54}. + {label,53}. + {line,[]}. + {func_info,{atom,receive_stacked},{atom,module_info},0}. + {label,54}. + {move,{atom,receive_stacked},{x,0}}. + {line,[]}. + {call_ext_only,1,{extfunc,erlang,get_module_info,1}}. + + +{function, module_info, 1, 56}. + {label,55}. + {line,[]}. + {func_info,{atom,receive_stacked},{atom,module_info},1}. + {label,56}. + {move,{x,0},{x,1}}. + {move,{atom,receive_stacked},{x,0}}. + {line,[]}. + {call_ext_only,2,{extfunc,erlang,get_module_info,2}}. diff --git a/lib/compiler/test/beam_validator_SUITE_data/receive_stacked.erl b/lib/compiler/test/beam_validator_SUITE_data/receive_stacked.erl new file mode 100644 index 0000000000..b95fa9ca62 --- /dev/null +++ b/lib/compiler/test/beam_validator_SUITE_data/receive_stacked.erl @@ -0,0 +1,92 @@ +-module(receive_stacked). +-compile([export_all,nowarn_export_all]). + +%% Messages may be stored outside any process heap until they +%% have been accepted by the 'remove_message' instruction. +%% When matching of a message fails, it is not allowed to +%% leave references to the message or any part of it in +%% the Y registers. An experimental code generator could +%% do that, causing an emulator crash if there happenened to +%% be a garbage collection. +%% +%% The 'S' file corresponding to this file was compiled with +%% that experimental code generator. + +f1() -> + receive + X when is_integer(X) -> + id(42), + X + end. + +f2() -> + receive + [X] -> + Res = {ok,X}, + id(42), + {Res,X} + end. + +f3() -> + receive + [H|_] when is_integer(H) -> + Res = {ok,H}, + id(42), + {Res,H} + end. + +f4() -> + receive + [_|T] when is_list(T) -> + Res = {ok,T}, + id(42), + {Res,T} + end. + +f5() -> + receive + {X} when is_integer(X) -> + Res = #{key=>X}, + id(42), + {Res,X} + end. + +f6() -> + receive + <<_:8,T/binary>> when byte_size(T) > 8 -> + id(42), + T + end. + +f7() -> + receive + <<_:8,T/binary>> when is_binary(T) -> + id(42), + T + end. + +f8() -> + receive + <<_:8,T/binary>> = Bin when is_binary(Bin) -> + id(42), + T + end. + +m1() -> + receive + #{key:=V} when is_integer(V) -> + id(42), + [V] + end. + +m2() -> + K1 = id(key1), + K2 = id(key2), + receive + #{K1:=V1,K2:=V2} when is_integer(V1), is_integer(V2) -> + id(42), + {V1,V2} + end. + +id(I) -> + I. diff --git a/lib/compiler/test/bs_construct_SUITE.erl b/lib/compiler/test/bs_construct_SUITE.erl index da99aba346..7c5ad97f7e 100644 --- a/lib/compiler/test/bs_construct_SUITE.erl +++ b/lib/compiler/test/bs_construct_SUITE.erl @@ -303,7 +303,14 @@ fail(Config) when is_list(Config) -> {'EXIT',{badarg,_}} = (catch <<42.0/integer>>), {'EXIT',{badarg,_}} = (catch <<42/binary>>), {'EXIT',{badarg,_}} = (catch <<an_atom/integer>>), - + + %% Bad literal sizes + Bin = i(<<>>), + {'EXIT',{badarg,_}} = (catch <<0:(-1)>>), + {'EXIT',{badarg,_}} = (catch <<Bin/binary,0:(-1)>>), + {'EXIT',{badarg,_}} = (catch <<0:(-(1 bsl 100))>>), + {'EXIT',{badarg,_}} = (catch <<Bin/binary,0:(-(1 bsl 100))>>), + ok. float_bin(Config) when is_list(Config) -> diff --git a/lib/compiler/test/bs_match_SUITE.erl b/lib/compiler/test/bs_match_SUITE.erl index 2fe8cd0cff..235956a714 100644 --- a/lib/compiler/test/bs_match_SUITE.erl +++ b/lib/compiler/test/bs_match_SUITE.erl @@ -39,7 +39,8 @@ match_string_opt/1,select_on_integer/1, map_and_binary/1,unsafe_branch_caching/1, bad_literals/1,good_literals/1,constant_propagation/1, - parse_xml/1,get_payload/1,num_slots_different/1]). + parse_xml/1,get_payload/1,escape/1,num_slots_different/1, + beam_bsm/1,guard/1,is_ascii/1,non_opt_eq/1]). -export([coverage_id/1,coverage_external_ignore/2]). @@ -71,7 +72,8 @@ groups() -> match_string_opt,select_on_integer, map_and_binary,unsafe_branch_caching, bad_literals,good_literals,constant_propagation,parse_xml, - get_payload,num_slots_different]}]. + get_payload,escape,num_slots_different, + beam_bsm,guard,is_ascii,non_opt_eq]}]. init_per_suite(Config) -> @@ -676,6 +678,10 @@ coverage(Config) when is_list(Config) -> <<>> = coverage_per_key(<<4:32>>), <<$a,$b,$c>> = coverage_per_key(<<7:32,"abc">>), + binary = coverage_bitstring(<<>>), + binary = coverage_bitstring(<<7>>), + bitstring = coverage_bitstring(<<7:4>>), + other = coverage_bitstring([a]), ok. coverage_fold(Fun, Acc, <<H,T/binary>>) -> @@ -766,6 +772,10 @@ coverage_per_key(<<BinSize:32,Bin/binary>> = B) -> true = (byte_size(B) =:= BinSize), Bin. +coverage_bitstring(Bin) when is_binary(Bin) -> binary; +coverage_bitstring(<<_/bitstring>>) -> bitstring; +coverage_bitstring(_) -> other. + multiple_uses(Config) when is_list(Config) -> {344,62879,345,<<245,159,1,89>>} = multiple_uses_1(<<1,88,245,159,1,89>>), true = multiple_uses_2(<<0,0,197,18>>), @@ -799,7 +809,7 @@ multiple_uses_cmp(<<_:16>>, <<_:16>>) -> false. first_after(Data, Offset) -> case byte_size(Data) > Offset of false -> - {First, Rest} = {ok, ok}, + {_First, _Rest} = {ok, ok}, ok; true -> <<_:Offset/binary, Rest/binary>> = Data, @@ -1513,7 +1523,7 @@ is_next_char_whitespace(<<C/utf8,_/binary>>) -> {this_hdr = 17, ext_hdr_opts}). -get_payload(Config) -> +get_payload(_Config) -> <<3445:48>> = do_get_payload(#ext_header{ext_hdr_opts = <<3445:48>>}), {'EXIT',_} = (catch do_get_payload(#ext_header{})), ok. @@ -1524,6 +1534,21 @@ do_get_payload(ExtHdr) -> <<_:13,_:35>> = ExtHdr#ext_header.ext_hdr_opts, ExtHdrOptions. +escape(_Config) -> + 0 = escape(<<>>, 0), + 1 = escape(<<128>>, 0), + 2 = escape(<<128,255>>, 0), + 42 = escape(<<42>>, 0), + 50 = escape(<<42,8>>, 0), + ok. + +escape(<<Byte, Rest/bits>>, Pos) when Byte >= 127 -> + escape(Rest, Pos + 1); +escape(<<Byte, Rest/bits>>, Pos) -> + escape(Rest, Pos + Byte); +escape(<<_Rest/bits>>, Pos) -> + Pos. + %% ERL-490 num_slots_different(_Config) -> Ts = [{<<"de">>, <<"default">>, <<"Remove">>, <<"a">>}, @@ -1557,6 +1582,101 @@ lgettext(<<"de">>, <<"navigation">>, <<"Results">>) -> lgettext(<<"de">>, <<"navigation">>, <<"Resources">>) -> {ok, <<"Ressourcen">>}. +%% Test more code in beam_bsm. +beam_bsm(_Config) -> + true = check_bitstring_list(<<1:1,0:1,1:1,1:1>>, [1,0,1,1]), + false = check_bitstring_list(<<1:1,0:1,1:1,1:1>>, [0]), + + true = bsm_validate_scheme(<<>>), + true = bsm_validate_scheme(<<5,10>>), + false = bsm_validate_scheme(<<5,10,11,12>>), + true = bsm_validate_scheme([]), + true = bsm_validate_scheme([5,10]), + false = bsm_validate_scheme([5,6,7]), + + <<1,2,3>> = bsm_must_save_and_not_save(<<1,2,3>>, []), + D = fun(N) -> 2*N end, + [2,4|<<3>>] = bsm_must_save_and_not_save(<<1,2,3>>, [D,D]), + + ok. + +check_bitstring_list(<<H:1,T1/bitstring>>, [H|T2]) -> + check_bitstring_list(T1, T2); +check_bitstring_list(<<>>, []) -> + true; +check_bitstring_list(_, _) -> + false. + +bsm_validate_scheme([]) -> true; +bsm_validate_scheme([H|T]) -> + case bsm_is_scheme(H) of + true -> bsm_validate_scheme(T); + false -> false + end; +bsm_validate_scheme(<<>>) -> true; +bsm_validate_scheme(<<H, Rest/binary>>) -> + case bsm_is_scheme(H) of + true -> bsm_validate_scheme(Rest); + false -> false + end. + +bsm_is_scheme(Int) -> + Int rem 5 =:= 0. + +%% NOT OPTIMIZED: different control paths use different positions in the binary +bsm_must_save_and_not_save(Bin, []) -> + Bin; +bsm_must_save_and_not_save(<<H,T/binary>>, [F|Fs]) -> + [F(H)|bsm_must_save_and_not_save(T, Fs)]; +bsm_must_save_and_not_save(<<>>, []) -> + []. + +guard(_Config) -> + _Tuple = id({a,b}), + ok = guard_1(<<1,2,3>>, {1,2,3}), + ok = guard_2(<<42>>, #{}), + ok. + +%% Cover handling of #k_put{} in v3_codegen:bsm_rename_ctx/4. +guard_1(<<A,B,C>>, Tuple) when Tuple =:= {A,B,C} -> + ok. + +%% Cover handling of #k_call{} in v3_codegen:bsm_rename_ctx/4. +guard_2(<<_>>, Healing) when Healing#{[] => Healing} =:= #{[] => #{}} -> + ok. + +is_ascii(_Config) -> + true = do_is_ascii(<<>>), + true = do_is_ascii(<<"string">>), + false = do_is_ascii(<<1024/utf8>>), + {'EXIT',{function_clause,_}} = (catch do_is_ascii(<<$A,0:3>>)), + {'EXIT',{function_clause,_}} = (catch do_is_ascii(<<16#80,0:3>>)), + ok. + +do_is_ascii(<<>>) -> + true; +do_is_ascii(<<C,_/binary>>) when C >= 16#80 -> + %% This clause must fail to match if the size of the argument in + %% bits is not divisible by 8. Beware of unsafe optimizations. + false; +do_is_ascii(<<_, T/binary>>) -> + do_is_ascii(T). + +non_opt_eq(_Config) -> + true = non_opt_eq([], <<>>), + true = non_opt_eq([$a], <<$a>>), + false = non_opt_eq([$a], <<$b>>), + ok. + +%% An example from the Efficiency Guide. It used to be not optimized, +%% but now it can be optimized. + +non_opt_eq([H|T1], <<H,T2/binary>>) -> + non_opt_eq(T1, T2); +non_opt_eq([_|_], <<_,_/binary>>) -> + false; +non_opt_eq([], <<>>) -> + true. check(F, R) -> R = F(). diff --git a/lib/compiler/test/compilation_SUITE_data/opt_crash.erl b/lib/compiler/test/compilation_SUITE_data/opt_crash.erl index f1607cca68..c65ec31593 100644 --- a/lib/compiler/test/compilation_SUITE_data/opt_crash.erl +++ b/lib/compiler/test/compilation_SUITE_data/opt_crash.erl @@ -33,7 +33,7 @@ test() -> {userinfo,nil}, fun() -> nil end}, nil}, - {'query',nil}}}, + {query,nil}}}, {absoluteURI, {scheme,_}, @@ -43,7 +43,7 @@ test() -> {userinfo,nil}, HostportBefore}, nil}, - {'query',nil}}} = URI_Before, + {query,nil}}} = URI_Before, %% ... some funky code ommitted, not relevant ... @@ -55,7 +55,7 @@ test() -> {userinfo,nil}, HostportAfter}, nil}, - {'query',nil}}} = URI_Before, + {query,nil}}} = URI_Before, %% NOTE: I intended to write URI_After instead of URI_Before %% but the accident revealed that when you add the line below, %% it causes internal error in v3_codegen on compilation diff --git a/lib/compiler/test/compile_SUITE.erl b/lib/compiler/test/compile_SUITE.erl index 96897d612d..a1de8961bd 100644 --- a/lib/compiler/test/compile_SUITE.erl +++ b/lib/compiler/test/compile_SUITE.erl @@ -27,12 +27,12 @@ -export([all/0, suite/0,groups/0,init_per_suite/1, end_per_suite/1, init_per_group/2,end_per_group/2, app_test/1,appup_test/1, - debug_info/4, custom_debug_info/1, + debug_info/4, custom_debug_info/1, custom_compile_info/1, 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, utf8_functions/1, extra_chunks/1, - cover/1, env/1, core_pp/1, + cover/1, env/1, core_pp/1, tuple_calls/1, core_roundtrip/1, asm/1, optimized_guards/1, sys_pre_attributes/1, dialyzer/1, warnings/1, pre_load_check/1, env_compiler_options/1, @@ -49,11 +49,12 @@ all() -> test_lib:recompile(?MODULE), [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, + other_output, kernel_listing, encrypted_abstr, tuple_calls, strict_record, utf8_atoms, utf8_functions, extra_chunks, cover, env, core_pp, core_roundtrip, asm, optimized_guards, sys_pre_attributes, dialyzer, warnings, pre_load_check, - env_compiler_options, custom_debug_info, bc_options]. + env_compiler_options, custom_debug_info, bc_options, + custom_compile_info]. groups() -> []. @@ -384,7 +385,6 @@ do_file_listings(DataDir, PrivDir, [File|Files]) -> do_listing(Simple, TargetDir, dcbsm, ".core_bsm"), do_listing(Simple, TargetDir, dsetel, ".dsetel"), do_listing(Simple, TargetDir, dkern, ".kernel"), - do_listing(Simple, TargetDir, dlife, ".life"), do_listing(Simple, TargetDir, dcg, ".codegen"), do_listing(Simple, TargetDir, dblk, ".block"), do_listing(Simple, TargetDir, dexcept, ".except"), @@ -500,9 +500,8 @@ do_kernel_listing({M,A}) -> io:format("*** compilation failure '~p' for module ~s\n", [Error,M]), error; - Class:Error -> - io:format("~p: ~p ~p\n~p\n", - [M,Class,Error,erlang:get_stacktrace()]), + Class:Error:Stk -> + io:format("~p: ~p ~p\n~p\n", [M,Class,Error,Stk]), error end. @@ -661,6 +660,23 @@ custom_debug_info(Config) when is_list(Config) -> {ok,{simple,[{debug_info,{debug_info_v1,?MODULE,error}}]}} = beam_lib:chunks(ErrorBin, [debug_info]). +custom_compile_info(Config) when is_list(Config) -> + Anno = erl_anno:new(1), + Forms = [{attribute,Anno,module,custom_compile_info}], + Opts = [binary,{compile_info,[{another,version}]}], + + {ok,custom_compile_info,Bin} = compile:forms(Forms, Opts), + {ok,{custom_compile_info,[{compile_info,CompileInfo}]}} = + beam_lib:chunks(Bin, [compile_info]), + version = proplists:get_value(another, CompileInfo), + CompileOpts = proplists:get_value(options, CompileInfo), + undefined = proplists:get_value(compile_info, CompileOpts), + + {ok,custom_compile_info,DetBin} = compile:forms(Forms, [deterministic|Opts]), + {ok,{custom_compile_info,[{compile_info,DetInfo}]}} = + beam_lib:chunks(DetBin, [compile_info]), + version = proplists:get_value(another, DetInfo). + cover(Config) when is_list(Config) -> io:format("~p\n", [compile:options()]), ok. @@ -793,6 +809,37 @@ extra_chunks(Config) when is_list(Config) -> {ok,{extra_chunks,[{"ExCh",<<"Contents">>}]}} = beam_lib:chunks(ExtraChunksBinary, ["ExCh"]). +tuple_calls(Config) when is_list(Config) -> + Anno = erl_anno:new(1), + Forms = [{attribute,Anno,export,[{size,1},{store,1}]}, + {function,Anno,size,1, + [{clause,Anno,[{var,[],mod}],[], + [{call,[],{remote,[],{var,[],mod},{atom,[],size}},[]}]}]}, + {function,Anno,store,1, + [{clause,Anno,[{var,[],mod}],[], + [{call,[],{remote,[],{var,[],mod},{atom,[],store}},[{atom,[],key},{atom,[],value}]}]}]}], + + TupleCallsFalse = [{attribute,Anno,module,tuple_calls_false}|Forms], + {ok,_,TupleCallsFalseBinary} = compile:forms(TupleCallsFalse, [binary]), + code:load_binary(tuple_calls_false, "compile_SUITE.erl", TupleCallsFalseBinary), + {'EXIT',{badarg,_}} = (catch tuple_calls_false:store(dict())), + {'EXIT',{badarg,_}} = (catch tuple_calls_false:size(dict())), + {'EXIT',{badarg,_}} = (catch tuple_calls_false:size(empty_tuple())), + + TupleCallsTrue = [{attribute,Anno,module,tuple_calls_true}|Forms], + {ok,_,TupleCallsTrueBinary} = compile:forms(TupleCallsTrue, [binary,tuple_calls]), + code:load_binary(tuple_calls_true, "compile_SUITE.erl", TupleCallsTrueBinary), + Dict = tuple_calls_true:store(dict()), + 1 = tuple_calls_true:size(Dict), + {'EXIT',{badarg,_}} = (catch tuple_calls_true:size(empty_tuple())), + + ok. + +dict() -> + dict:new(). +empty_tuple() -> + {}. + env(Config) when is_list(Config) -> {Simple,Target} = get_files(Config, simple, env), {ok,Cwd} = file:get_cwd(), @@ -854,9 +901,8 @@ do_core_pp({M,A}, Outdir) -> io:format("*** compilation failure '~p' for module ~s\n", [Error,M]), error; - Class:Error -> - io:format("~p: ~p ~p\n~p\n", - [M,Class,Error,erlang:get_stacktrace()]), + Class:Error:Stk -> + io:format("~p: ~p ~p\n~p\n", [M,Class,Error,Stk]), error end. @@ -913,9 +959,8 @@ do_core_roundtrip(Beam, Outdir) -> io:format("*** compilation failure '~p' for file ~s\n", [Error,Beam]), error; - Class:Error -> - io:format("~p: ~p ~p\n~p\n", - [Beam,Class,Error,erlang:get_stacktrace()]), + Class:Error:Stk -> + io:format("~p: ~p ~p\n~p\n", [Beam,Class,Error,Stk]), error end. @@ -1066,10 +1111,30 @@ remove_compiler_gen(M) -> remove_compiler_gen_1(Pair) -> Op0 = cerl:map_pair_op(Pair), Op = cerl:set_ann(Op0, []), - K = cerl:map_pair_key(Pair), - V = cerl:map_pair_val(Pair), + K = map_var(cerl:map_pair_key(Pair)), + V = map_var(cerl:map_pair_val(Pair)), cerl:update_c_map_pair(Pair, Op, K, V). +map_var(Var) -> + case cerl:is_c_var(Var) of + true -> + case cerl:var_name(Var) of + Name when is_atom(Name) -> + L = atom_to_list(Name), + try list_to_integer(L) of + Int -> + cerl:update_c_var(Var, Int) + catch + error:_ -> + Var + end; + _ -> + Var + end; + false -> + Var + end. + %% Compile to Beam assembly language (.S) and then try to %% run .S through the compiler again. @@ -1100,9 +1165,8 @@ do_asm(Beam, Outdir) -> [Other,AsmFile]), error end - catch Class:Error -> - io:format("~p: ~p ~p\n~p\n", - [M,Class,Error,erlang:get_stacktrace()]), + catch Class:Error:Stk -> + io:format("~p: ~p ~p\n~p\n", [M,Class,Error,Stk]), error end. @@ -1119,9 +1183,8 @@ do_opt_guards(Beam) -> try {ok,M,Asm} = compile:forms(A, ['S']), do_opt_guards_mod(Asm) - catch Class:Error -> - io:format("~p: ~p ~p\n~p\n", - [M,Class,Error,erlang:get_stacktrace()]), + catch Class:Error:Stk -> + io:format("~p: ~p ~p\n~p\n", [M,Class,Error,Stk]), error end. @@ -1282,10 +1345,13 @@ do_warnings_2([], Next, F) -> %% pre-loads the modules that are used by a typical compilation. pre_load_check(Config) -> - case test_server:is_cover() of - true -> + case {test_server:is_cover(),code:module_info(native)} of + {true,_} -> {skip,"Cover is running"}; - false -> + {false,true} -> + %% Tracing won't work. + {skip,"'code' is native-compiled"}; + {false,false} -> try do_pre_load_check(Config) after @@ -1409,19 +1475,21 @@ env_compiler_options(_Config) -> bc_options(Config) -> DataDir = proplists:get_value(data_dir, Config), - 101 = highest_opcode(DataDir, small_float, [no_line_info]), + 101 = highest_opcode(DataDir, small_float, [no_get_hd_tl,no_line_info]), 103 = highest_opcode(DataDir, big, - [no_record_opt,no_line_info,no_stack_trimming]), + [no_get_hd_tl,no_record_opt, + no_line_info,no_stack_trimming]), - 125 = highest_opcode(DataDir, small_float, [no_line_info,no_float_opt]), + 125 = highest_opcode(DataDir, small_float, + [no_get_hd_tl,no_line_info,no_float_opt]), 132 = highest_opcode(DataDir, small, - [no_record_opt,no_float_opt,no_line_info]), + [no_get_hd_tl,no_record_opt,no_float_opt,no_line_info]), - 136 = highest_opcode(DataDir, big, [no_record_opt,no_line_info]), + 136 = highest_opcode(DataDir, big, [no_get_hd_tl,no_record_opt,no_line_info]), - 153 = highest_opcode(DataDir, big, [no_record_opt]), + 153 = highest_opcode(DataDir, big, [no_get_hd_tl,no_record_opt]), 153 = highest_opcode(DataDir, big, [r16]), 153 = highest_opcode(DataDir, big, [r17]), 153 = highest_opcode(DataDir, big, [r18]), @@ -1432,9 +1500,10 @@ bc_options(Config) -> 158 = highest_opcode(DataDir, small_maps, [r17]), 158 = highest_opcode(DataDir, small_maps, [r18]), 158 = highest_opcode(DataDir, small_maps, [r19]), + 158 = highest_opcode(DataDir, small_maps, [r20]), 158 = highest_opcode(DataDir, small_maps, []), - 159 = highest_opcode(DataDir, big, []), + 163 = highest_opcode(DataDir, big, []), ok. diff --git a/lib/compiler/test/compile_SUITE_data/big.erl b/lib/compiler/test/compile_SUITE_data/big.erl index 2e54ee8660..1db07755a1 100644 --- a/lib/compiler/test/compile_SUITE_data/big.erl +++ b/lib/compiler/test/compile_SUITE_data/big.erl @@ -741,3 +741,7 @@ snmp_access(suite) -> debug_support(suite) -> [ info, schema, schema, kill, lkill ]. +%% Cover translation of get_hd/2 to get_list/3 when option no_get_hd_tl +%% is given. +cover_get_hd([Hd|_]) -> + Hd. diff --git a/lib/compiler/test/core_alias_SUITE.erl b/lib/compiler/test/core_alias_SUITE.erl new file mode 100644 index 0000000000..f3f15ef0f8 --- /dev/null +++ b/lib/compiler/test/core_alias_SUITE.erl @@ -0,0 +1,195 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2007-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(core_alias_SUITE). + +-export([all/0, suite/0, groups/0,init_per_suite/1, end_per_suite/1, + init_per_group/2, end_per_group/2, + tuples/1, cons/1]). + +-include_lib("common_test/include/ct.hrl"). + +suite() -> [{ct_hooks,[ts_install_cth]}]. + +all() -> + test_lib:recompile(?MODULE), + [{group,p}]. + +groups() -> + [{p,[parallel], + [tuples, cons]}]. + +init_per_suite(Config) -> + Config. + +end_per_suite(_Config) -> + ok. + +init_per_group(_GroupName, Config) -> + Config. + +end_per_group(_GroupName, Config) -> + Config. + + +id(X) -> X. + +tuples(Config) when is_list(Config) -> + Tuple = {ok,id(value)}, + + true = erts_debug:same(Tuple, simple_tuple(Tuple)), + true = erts_debug:same(Tuple, simple_tuple_in_map(#{hello => Tuple})), + true = erts_debug:same(Tuple, simple_tuple_case_repeated(Tuple, Tuple)), + true = erts_debug:same(Tuple, simple_tuple_fun_repeated(Tuple, Tuple)), + true = erts_debug:same(Tuple, simple_tuple_twice_head(Tuple, Tuple)), + + {Tuple1, Tuple2} = simple_tuple_twice_body(Tuple), + true = erts_debug:same(Tuple, Tuple1), + true = erts_debug:same(Tuple, Tuple2), + + Nested = {nested,Tuple}, + true = erts_debug:same(Tuple, nested_tuple_part(Nested)), + true = erts_debug:same(Nested, nested_tuple_whole(Nested)), + true = erts_debug:same(Nested, nested_tuple_with_alias(Nested)), + + true = erts_debug:same(Tuple, tuple_rebinding_after(Tuple)), + + Tuple = unaliased_tuple_rebinding_before(Tuple), + false = erts_debug:same(Tuple, unaliased_tuple_rebinding_before(Tuple)), + Nested = unaliased_literal_tuple_head(Nested), + false = erts_debug:same(Nested, unaliased_literal_tuple_head(Nested)), + Nested = unaliased_literal_tuple_body(Nested), + false = erts_debug:same(Nested, unaliased_literal_tuple_body(Nested)), + Nested = unaliased_different_var_tuple(Nested, Tuple), + false = erts_debug:same(Nested, unaliased_different_var_tuple(Nested, Tuple)). + +simple_tuple({ok,X}) -> + {ok,X}. +simple_tuple_twice_head({ok,X}, {ok,X}) -> + {ok,X}. +simple_tuple_twice_body({ok,X}) -> + {{ok,X},{ok,X}}. +simple_tuple_in_map(#{hello := {ok,X}}) -> + {ok,X}. +simple_tuple_fun_repeated({ok,X}, Y) -> + io:format("~p~n", [X]), + (fun({ok,X}) -> {ok,X} end)(Y). +simple_tuple_case_repeated({ok,X}, Y) -> + io:format("~p~n", [X]), + case Y of {ok,X} -> {ok,X} end. + +nested_tuple_part({nested,{ok,X}}) -> + {ok,X}. +nested_tuple_whole({nested,{ok,X}}) -> + {nested,{ok,X}}. +nested_tuple_with_alias({nested,{ok,_}=Y}) -> + {nested,Y}. + +tuple_rebinding_after(Y) -> + (fun(X) -> {ok,X} end)(Y), + case Y of {ok,X} -> {ok,X} end. +unaliased_tuple_rebinding_before({ok,X}) -> + io:format("~p~n", [X]), + (fun(X) -> {ok,X} end)(value). +unaliased_literal_tuple_head({nested,{ok,value}=X}) -> + io:format("~p~n", [X]), + {nested,{ok,value}}. +unaliased_literal_tuple_body({nested,{ok,value}=X}) -> + Res = {nested,Y={ok,value}}, + io:format("~p~n", [[X,Y]]), + Res. +unaliased_different_var_tuple({nested,{ok,value}=X}, Y) -> + io:format("~p~n", [X]), + {nested,Y}. + +cons(Config) when is_list(Config) -> + Cons = [ok|id(value)], + + true = erts_debug:same(Cons, simple_cons(Cons)), + true = erts_debug:same(Cons, simple_cons_in_map(#{hello => Cons})), + true = erts_debug:same(Cons, simple_cons_case_repeated(Cons, Cons)), + true = erts_debug:same(Cons, simple_cons_fun_repeated(Cons, Cons)), + true = erts_debug:same(Cons, simple_cons_twice_head(Cons, Cons)), + + {Cons1,Cons2} = simple_cons_twice_body(Cons), + true = erts_debug:same(Cons, Cons1), + true = erts_debug:same(Cons, Cons2), + + Nested = [nested,Cons], + true = erts_debug:same(Cons, nested_cons_part(Nested)), + true = erts_debug:same(Nested, nested_cons_whole(Nested)), + true = erts_debug:same(Nested, nested_cons_with_alias(Nested)), + true = erts_debug:same(Cons, cons_rebinding_after(Cons)), + + Unstripped = id([a,b]), + Stripped = cons_with_binary([<<>>|Unstripped]), + true = erts_debug:same(Unstripped, Stripped), + + Cons = unaliased_cons_rebinding_before(Cons), + false = erts_debug:same(Cons, unaliased_cons_rebinding_before(Cons)), + Nested = unaliased_literal_cons_head(Nested), + false = erts_debug:same(Nested, unaliased_literal_cons_head(Nested)), + Nested = unaliased_literal_cons_body(Nested), + false = erts_debug:same(Nested, unaliased_literal_cons_body(Nested)), + Nested = unaliased_different_var_cons(Nested, Cons), + false = erts_debug:same(Nested, unaliased_different_var_cons(Nested, Cons)). + +simple_cons([ok|X]) -> + [ok|X]. +simple_cons_twice_head([ok|X], [ok|X]) -> + [ok|X]. +simple_cons_twice_body([ok|X]) -> + {[ok|X],[ok|X]}. +simple_cons_in_map(#{hello := [ok|X]}) -> + [ok|X]. +simple_cons_fun_repeated([ok|X], Y) -> + io:format("~p~n", [X]), + (fun([ok|X]) -> [ok|X] end)(Y). +simple_cons_case_repeated([ok|X], Y) -> + io:format("~p~n", [X]), + case Y of [ok|X] -> [ok|X] end. + +nested_cons_part([nested,[ok|X]]) -> + [ok|X]. +nested_cons_whole([nested,[ok|X]]) -> + [nested,[ok|X]]. +nested_cons_with_alias([nested,[ok|_]=Y]) -> + [nested,Y]. + +cons_with_binary([<<>>,X|Y]) -> + cons_with_binary([X|Y]); +cons_with_binary(A) -> + A. + +cons_rebinding_after(Y) -> + (fun(X) -> [ok|X] end)(Y), + case Y of [ok|X] -> [ok|X] end. +unaliased_cons_rebinding_before([ok|X]) -> + io:format("~p~n", [X]), + (fun(X) -> [ok|X] end)(value). +unaliased_literal_cons_head([nested,[ok|value]=X]) -> + io:format("~p~n", [X]), + [nested,[ok|value]]. +unaliased_literal_cons_body([nested,[ok|value]=X]) -> + Res = [nested,Y=[ok|value]], + io:format("~p~n", [[X, Y]]), + Res. +unaliased_different_var_cons([nested,[ok|value]=X], Y) -> + io:format("~p~n", [X]), + [nested,Y]. diff --git a/lib/compiler/test/core_fold_SUITE.erl b/lib/compiler/test/core_fold_SUITE.erl index 0097e28d4d..ab7f36abf7 100644 --- a/lib/compiler/test/core_fold_SUITE.erl +++ b/lib/compiler/test/core_fold_SUITE.erl @@ -26,7 +26,9 @@ unused_multiple_values_error/1,unused_multiple_values/1, multiple_aliases/1,redundant_boolean_clauses/1, mixed_matching_clauses/1,unnecessary_building/1, - no_no_file/1,configuration/1,supplies/1]). + no_no_file/1,configuration/1,supplies/1, + redundant_stack_frame/1,export_from_case/1, + empty_values/1]). -export([foo/0,foo/1,foo/2,foo/3]). @@ -45,7 +47,9 @@ groups() -> unused_multiple_values_error,unused_multiple_values, multiple_aliases,redundant_boolean_clauses, mixed_matching_clauses,unnecessary_building, - no_no_file,configuration,supplies]}]. + no_no_file,configuration,supplies, + redundant_stack_frame,export_from_case, + empty_values]}]. init_per_suite(Config) -> @@ -527,4 +531,72 @@ supplies(_Config) -> do_supplies(#{1 := Value}) when byte_size(Value), byte_size(kg) -> working. +redundant_stack_frame(_Config) -> + {1,2} = do_redundant_stack_frame(#{x=>1,y=>2}), + {'EXIT',{{badkey,_,x},_}} = (catch do_redundant_stack_frame(#{y=>2})), + {'EXIT',{{badkey,_,y},_}} = (catch do_redundant_stack_frame(#{x=>1})), + ok. + +do_redundant_stack_frame(Map) -> + %% There should not be a stack frame for this function. + X = case Map of + #{x := X0} -> + X0; + #{} -> + erlang:error({badkey, Map, x}) + end, + Y = case Map of + #{y := Y0} -> + Y0; + #{} -> + erlang:error({badkey, Map, y}) + end, + {X, Y}. + +%% Cover some clauses in sys_core_fold:remove_first_value/2. + +-record(export_from_case, {val}). + +export_from_case(_Config) -> + a = export_from_case_1(true), + b = export_from_case_1(false), + + R = #export_from_case{val=0}, + {ok,R} = export_from_case_2(false, R), + {ok,#export_from_case{val=42}} = export_from_case_2(true, R), + + ok. + +export_from_case_1(Bool) -> + case Bool of + true -> + id(42), + Result = a; + false -> + Result = b + end, + id(Result). + +export_from_case_2(Bool, Rec) -> + case Bool of + false -> + Result = Rec; + true -> + Result = Rec#export_from_case{val=42} + end, + {ok,Result}. + +empty_values(_Config) -> + case ?MODULE of + core_fold_inline_SUITE -> + {'EXIT',_} = (catch do_empty_values()); + _ -> + {'EXIT',{function_clause,_}} = (catch do_empty_values()) + end, + ok. + +do_empty_values() when (#{})#{} -> + c. + + id(I) -> I. diff --git a/lib/compiler/test/fun_SUITE.erl b/lib/compiler/test/fun_SUITE.erl index 16474adf5b..3c272a35a6 100644 --- a/lib/compiler/test/fun_SUITE.erl +++ b/lib/compiler/test/fun_SUITE.erl @@ -194,6 +194,17 @@ external(Config) when is_list(Config) -> ?APPLY2(ListsMod, ListsMap, 2), ?APPLY2(ListsMod, ListsMap, ListsArity), + 42 = (fun erlang:abs/1)(-42), + 42 = (id(fun erlang:abs/1))(-42), + 42 = apply(fun erlang:abs/1, [-42]), + 42 = apply(id(fun erlang:abs/1), [-42]), + 6 = (fun lists:sum/1)([1,2,3]), + 6 = (id(fun lists:sum/1))([1,2,3]), + + {'EXIT',{{badarity,_},_}} = (catch (fun lists:sum/1)(1, 2, 3)), + {'EXIT',{{badarity,_},_}} = (catch (id(fun lists:sum/1))(1, 2, 3)), + {'EXIT',{{badarity,_},_}} = (catch apply(fun lists:sum/1, [1,2,3])), + ok. call_me(I) -> diff --git a/lib/compiler/test/guard_SUITE.erl b/lib/compiler/test/guard_SUITE.erl index ccb9b58225..0d6f8c6f98 100644 --- a/lib/compiler/test/guard_SUITE.erl +++ b/lib/compiler/test/guard_SUITE.erl @@ -35,7 +35,8 @@ basic_andalso_orelse/1,traverse_dcd/1, check_qlc_hrl/1,andalso_semi/1,t_tuple_size/1,binary_part/1, bad_constants/1,bad_guards/1, - guard_in_catch/1,beam_bool_SUITE/1]). + guard_in_catch/1,beam_bool_SUITE/1, + cover_beam_dead/1]). suite() -> [{ct_hooks,[ts_install_cth]}]. @@ -54,7 +55,8 @@ groups() -> rel_ops,rel_op_combinations, literal_type_tests,basic_andalso_orelse,traverse_dcd, check_qlc_hrl,andalso_semi,t_tuple_size,binary_part, - bad_constants,bad_guards,guard_in_catch,beam_bool_SUITE]}]. + bad_constants,bad_guards,guard_in_catch,beam_bool_SUITE, + cover_beam_dead]}]. init_per_suite(Config) -> Config. @@ -1291,6 +1293,10 @@ rel_ops(Config) when is_list(Config) -> true = any_atom /= id(42), true = [] /= id(42), + %% Coverage of beam_utils:bif_to_test/3 + Empty = id([]), + ?T(==, [], Empty), + ok. -undef(TestOp). @@ -1615,7 +1621,9 @@ type_tests() -> is_reference, is_port, is_binary, - is_function]. + is_bitstring, + is_function, + is_map]. basic_andalso_orelse(Config) when is_list(Config) -> T = id({type,integers,23,42}), @@ -2198,7 +2206,31 @@ maps() -> evidence(#{0 := Charge}) when 0; #{[] => Charge} == #{[] => 42} -> ok. +cover_beam_dead(_Config) -> + Mod = ?FUNCTION_NAME, + Attr = [], + Fs = [{function,test,1,2, + [{label,1}, + {line,[]}, + {func_info,{atom,Mod},{atom,test},1}, + {label,2}, + %% Cover beam_dead:turn_op/1 using swapped operand order. + {test,is_ne_exact,{f,3},[{integer,1},{x,0}]}, + {test,is_eq_exact,{f,1},[{atom,a},{x,0}]}, + {label,3}, + {move,{atom,ok},{x,0}}, + return]}], + Exp = [{test,1}], + Asm = {Mod,Exp,Attr,Fs,3}, + {ok,Mod,Beam} = compile:forms(Asm, [from_asm,binary,report]), + {module,Mod} = code:load_binary(Mod, Mod, Beam), + ok = Mod:test(1), + ok = Mod:test(a), + {'EXIT',_} = (catch Mod:test(other)), + true = code:delete(Mod), + _ = code:purge(Mod), + ok. %% Call this function to turn off constant propagation. id(I) -> I. diff --git a/lib/compiler/test/lc_SUITE.erl b/lib/compiler/test/lc_SUITE.erl index 9ad417b09b..699081470d 100644 --- a/lib/compiler/test/lc_SUITE.erl +++ b/lib/compiler/test/lc_SUITE.erl @@ -107,6 +107,31 @@ basic(Config) when is_list(Config) -> [] = [X || X <- L1, X+1 < 2], {'EXIT',_} = (catch [X || X <- L1, odd(X)]), fc([x], catch [E || E <- id(x)]), + + %% Make sure that line numbers point out the generator. + case ?MODULE of + lc_inline_SUITE -> + ok; + _ -> + {'EXIT',{function_clause, + [{?MODULE,_,_, + [{file,"bad_lc.erl"},{line,4}]}|_]}} = + (catch bad_generator(a)), + {'EXIT',{function_clause, + [{?MODULE,_,_, + [{file,"bad_lc.erl"},{line,4}]}|_]}} = + (catch bad_generator([a|b])), + {'EXIT',{badarg, + [{erlang,length,_,_}, + {?MODULE,bad_generator_bc,1, + [{file,"bad_lc.erl"},{line,7}]}|_]}} = + (catch bad_generator_bc(a)), + {'EXIT',{badarg, + [{erlang,length,_,_}, + {?MODULE,bad_generator_bc,1, + [{file,"bad_lc.erl"},{line,7}]}|_]}} = + (catch bad_generator_bc([a|b])) + end, ok. tuple_list() -> @@ -249,3 +274,11 @@ fc(Args, {'EXIT',{function_clause,[{?MODULE,_,Arity,_}|_]}}) fc(Args, {'EXIT',{{case_clause,ActualArgs},_}}) when ?MODULE =:= lc_inline_SUITE -> Args = tuple_to_list(ActualArgs). + +-file("bad_lc.erl", 1). +bad_generator(List) -> %Line 2 + [I || %Line 3 + I <- List]. %Line 4 +bad_generator_bc(List) -> %Line 5 + << <<I:4>> || %Line 6 + I <- List>>. %Line 7 diff --git a/lib/compiler/test/map_SUITE.erl b/lib/compiler/test/map_SUITE.erl index 5e90b79aa2..e98c295da6 100644 --- a/lib/compiler/test/map_SUITE.erl +++ b/lib/compiler/test/map_SUITE.erl @@ -36,7 +36,7 @@ t_guard_fun/1, t_list_comprehension/1, t_map_sort_literals/1, - t_map_size/1, + t_map_size/1, t_map_get/1, t_build_and_match_aliasing/1, t_is_map/1, @@ -67,8 +67,10 @@ %% errors in 18 t_register_corruption/1, - t_bad_update/1 + t_bad_update/1, + %% new in OTP 21 + t_reused_key_variable/1 ]). suite() -> []. @@ -89,7 +91,7 @@ all() -> t_guard_receive, t_guard_receive_large, t_guard_fun, t_list_comprehension, t_map_sort_literals, - t_map_size, + t_map_size, t_map_get, t_build_and_match_aliasing, t_is_map, @@ -120,7 +122,10 @@ all() -> %% errors in 18 t_register_corruption, - t_bad_update + t_bad_update, + + %% new in OTP 21 + t_reused_key_variable ]. groups() -> []. @@ -686,6 +691,26 @@ t_map_size(Config) when is_list(Config) -> map_is_size(M,N) when map_size(M) =:= N -> true; map_is_size(_,_) -> false. +t_map_get(Config) when is_list(Config) -> + 1 = map_get(a, id(#{a=>1})), + + {'EXIT',{{badkey,a},_}} = (catch map_get(a, #{})), + {'EXIT',{{badkey,a},_}} = (catch map_get(a, #{b=>1})), + + M = #{"a"=>1, "b" => 2}, + true = check_map_value(M, "a", 1), + false = check_map_value(M, "b", 1), + true = check_map_value(M#{"c"=>2}, "c", 2), + false = check_map_value(M#{"a"=>5}, "a", 1), + + {'EXIT',{{badmap,[]},_}} = (catch map_get(a, [])), + {'EXIT',{{badmap,<<1,2,3>>},_}} = (catch map_get(a, <<1,2,3>>)), + {'EXIT',{{badmap,1},_}} = (catch map_get(a, 1)), + ok. + +check_map_value(Map, Key, Value) when map_get(Key, Map) =:= Value -> true; +check_map_value(_, _, _) -> false. + t_is_map(Config) when is_list(Config) -> true = is_map(#{}), true = is_map(#{a=>1}), @@ -695,8 +720,28 @@ t_is_map(Config) when is_list(Config) -> if is_map(#{b=>1}) -> ok end, if not is_map([1,2,3]) -> ok end, if not is_map(x) -> ok end, + + ok = do_t_is_map(map, #{}), + error = do_t_is_map(map, {a,b,c}), + ok = do_t_is_map(number, 42), + ok = do_t_is_map(number, 42.0), + error = do_t_is_map(number, {a,b,c}), ok. +do_t_is_map(What, X) -> + B = case What of + map -> + %% Cover conversion of is_map/1 BIF to test instruction + %% in beam_utils:bif_to_test/3. + is_map(X); + number -> + is_number(X) + end, + case B of + true -> ok; + false -> error + end. + % test map updates without matching t_update_literals(Config) when is_list(Config) -> Map = #{x=>1,y=>2,z=>3,q=>4}, @@ -1960,6 +2005,16 @@ properly(Item) -> increase(Allows) -> catch fun() -> Allows end#{[] => +Allows, "warranty" => fun id/1}. +t_reused_key_variable(Config) when is_list(Config) -> + Key = id(key), + Map1 = id(#{Key=>Config}), + Map2 = id(#{Key=>Config}), + case {Map1,Map2} of + %% core_lint treated Key as pattern variables, not input variables, + %% and complained about the variable being duplicated. + {#{Key:=Same},#{Key:=Same}} -> + ok + end. %% aux diff --git a/lib/compiler/test/match_SUITE.erl b/lib/compiler/test/match_SUITE.erl index 52b2da05f7..4b26a8dcdc 100644 --- a/lib/compiler/test/match_SUITE.erl +++ b/lib/compiler/test/match_SUITE.erl @@ -23,8 +23,9 @@ init_per_group/2,end_per_group/2, pmatch/1,mixed/1,aliases/1,non_matching_aliases/1, match_in_call/1,untuplify/1,shortcut_boolean/1,letify_guard/1, - selectify/1,underscore/1,match_map/1,map_vars_used/1, - coverage/1,grab_bag/1,literal_binary/1]). + selectify/1,deselectify/1,underscore/1,match_map/1,map_vars_used/1, + coverage/1,grab_bag/1,literal_binary/1, + unary_op/1]). -include_lib("common_test/include/ct.hrl"). @@ -38,9 +39,9 @@ groups() -> [{p,[parallel], [pmatch,mixed,aliases,non_matching_aliases, match_in_call,untuplify, - shortcut_boolean,letify_guard,selectify, + shortcut_boolean,letify_guard,selectify,deselectify, underscore,match_map,map_vars_used,coverage, - grab_bag,literal_binary]}]. + grab_bag,literal_binary,unary_op]}]. init_per_suite(Config) -> @@ -466,6 +467,66 @@ sel_same_value2(V) when V =:= 42; V =:= 43 -> sel_same_value2(_) -> error. +%% Test deconstruction of select_val instructions in beam_peep into +%% regular tests with just one possible value left. Hitting proper cases +%% in beam_peep relies on unification of labels by beam_jump. + +deselectify(Config) when is_list(Config) -> + one_or_other = desel_tuple_arity({1}), + two = desel_tuple_arity({1,1}), + one_or_other = desel_tuple_arity({1,1,1}), + + one_or_other = dsel_integer(1), + two = dsel_integer(2), + one_or_other = dsel_integer(3), + + one_or_other = dsel_integer_typecheck(1), + two = dsel_integer_typecheck(2), + one_or_other = dsel_integer_typecheck(3), + + one_or_other = dsel_atom(one), + two = dsel_atom(two), + one_or_other = dsel_atom(three), + + one_or_other = dsel_atom_typecheck(one), + two = dsel_atom_typecheck(two), + one_or_other = dsel_atom_typecheck(three). + +desel_tuple_arity(Tuple) when is_tuple(Tuple) -> + case Tuple of + {_} -> one_or_other; + {_,_} -> two; + _ -> one_or_other + end. + +dsel_integer(Val) -> + case Val of + 1 -> one_or_other; + 2 -> two; + _ -> one_or_other + end. + +dsel_integer_typecheck(Val) when is_integer(Val) -> + case Val of + 1 -> one_or_other; + 2 -> two; + _ -> one_or_other + end. + +dsel_atom(Val) -> + case Val of + one -> one_or_other; + two -> two; + _ -> one_or_other + end. + +dsel_atom_typecheck(Val) when is_atom(Val) -> + case Val of + one -> one_or_other; + two -> two; + _ -> one_or_other + end. + underscore(Config) when is_list(Config) -> case Config of [] -> @@ -557,6 +618,10 @@ grab_bag(_Config) -> {bad,16#555555555555555555555555555555555555555555555555555}], ok = grab_bag_remove_failure(L, unit, 0), + {42,<<43,44>>} = grab_bag_single_valued(<<42,43,44>>), + empty_list = grab_bag_single_valued([]), + empty_tuple = grab_bag_single_valued({}), + ok. grab_bag_remove_failure([], _Unit, _MaxFailure) -> @@ -574,6 +639,12 @@ grab_bag_remove_failure([{stretch,_,Mi}=Stretch | Specs], Unit, _MaxFailure) -> ok end. +%% Cover a line v3_kernel that places binary matching first. +grab_bag_single_valued(<<H,T/bytes>>) -> {H,T}; +grab_bag_single_valued([]) -> empty_list; +grab_bag_single_valued({}) -> empty_tuple. + + %% Regression in 19.0, reported by Alexei Sholik literal_binary(_Config) -> 3 = literal_binary_match(bar, <<"y">>), @@ -592,5 +663,74 @@ literal_binary_match(_, <<"x">>) -> 2; literal_binary_match(_, <<"y">>) -> 3; literal_binary_match(_, _) -> fail. +unary_op(Config) -> + %% ERL-514. This test case only verifies that the code + %% calculates the correct result, not that the generated + %% code is optimial. + + {non_associative,30} = unary_op_1('&'), + {non_associative,300} = unary_op_1('^'), + {non_associative,300} = unary_op_1('not'), + {non_associative,300} = unary_op_1('+'), + {non_associative,300} = unary_op_1('-'), + {non_associative,300} = unary_op_1('~~~'), + {non_associative,300} = unary_op_1('!'), + {non_associative,320} = unary_op_1('@'), + + error = unary_op_1(Config), + error = unary_op_1(abc), + error = unary_op_1(42), + + ok. + +unary_op_1(Vop@1) -> + %% If all optimizations are working as they should, there should + %% be no stack frame and all '=:=' tests should be coalesced into + %% a single select_val instruction. + + case Vop@1 =:= '&' of + true -> + {non_associative,30}; + false -> + case + case Vop@1 =:= '^' of + true -> + true; + false -> + case Vop@1 =:= 'not' of + true -> + true; + false -> + case Vop@1 =:= '+' of + true -> + true; + false -> + case Vop@1 =:= '-' of + true -> + true; + false -> + case Vop@1 =:= '~~~' of + true -> + true; + false -> + Vop@1 =:= '!' + end + end + end + end + end + of + true -> + {non_associative,300}; + false -> + case Vop@1 =:= '@' of + true -> + {non_associative,320}; + false -> + error + end + end + end. + id(I) -> I. diff --git a/lib/compiler/test/misc_SUITE.erl b/lib/compiler/test/misc_SUITE.erl index 4bd884d86b..4e39f4663e 100644 --- a/lib/compiler/test/misc_SUITE.erl +++ b/lib/compiler/test/misc_SUITE.erl @@ -161,16 +161,17 @@ md5_1(Beam) -> %% Cover some code that handles internal errors. silly_coverage(Config) when is_list(Config) -> - %% sys_core_fold, sys_core_bsm, sys_core_setel, v3_kernel + %% sys_core_fold, sys_core_alias, sys_core_bsm, sys_core_setel, v3_kernel BadCoreErlang = {c_module,[], name,[],[], [{{c_var,[],{foo,2}},seriously_bad_body}]}, expect_error(fun() -> sys_core_fold:module(BadCoreErlang, []) end), + expect_error(fun() -> sys_core_alias:module(BadCoreErlang, []) end), expect_error(fun() -> sys_core_bsm:module(BadCoreErlang, []) end), expect_error(fun() -> sys_core_dsetel:module(BadCoreErlang, []) end), expect_error(fun() -> v3_kernel:module(BadCoreErlang, []) end), - %% v3_life + %% v3_codegen BadKernel = {k_mdef,[],?MODULE, [{foo,0}], [], @@ -178,11 +179,7 @@ silly_coverage(Config) when is_list(Config) -> {k,[],[],[]}, f,0,[], seriously_bad_body}]}, - expect_error(fun() -> v3_life:module(BadKernel, []) end), - - %% v3_codegen - CodegenInput = {?MODULE,[{foo,0}],[],[{function,foo,0,[a|b],a,b,[]}]}, - expect_error(fun() -> v3_codegen:module(CodegenInput, []) end), + expect_error(fun() -> v3_codegen:module(BadKernel, []) end), %% beam_a BeamAInput = {?MODULE,[{foo,0}],[], @@ -321,8 +318,7 @@ expect_error(Fun) -> io:format("~p", [Any]), ct:fail(call_was_supposed_to_fail) catch - Class:Reason -> - Stk = erlang:get_stacktrace(), + Class:Reason:Stk -> io:format("~p:~p\n~p\n", [Class,Reason,Stk]), case {Class,Reason} of {error,undef} -> @@ -363,9 +359,7 @@ integer_encoding_1(Config) -> io:put_chars(Src, "t(Last) ->[\n"), io:put_chars(Data, "[\n"), - do_integer_encoding(-(id(1) bsl 10000), Src, Data), - do_integer_encoding(id(1) bsl 10000, Src, Data), - do_integer_encoding(1024, 0, Src, Data), + do_integer_encoding(137, 0, Src, Data), _ = [begin B = 1 bsl I, do_integer_encoding(-B-1, Src, Data), @@ -374,7 +368,7 @@ integer_encoding_1(Config) -> do_integer_encoding(B-1, Src, Data), do_integer_encoding(B, Src, Data), do_integer_encoding(B+1, Src, Data) - end || I <- lists:seq(1, 128)], + end || I <- lists:seq(1, 130)], io:put_chars(Src, "Last].\n\n"), ok = file:close(Src), io:put_chars(Data, "0].\n\n"), @@ -388,8 +382,6 @@ integer_encoding_1(Config) -> %% Compare lists. List = Mod:t(0), {ok,[List]} = file:consult(DataFile), - OneBsl10000 = id(1) bsl 10000, - [-(1 bsl 10000),OneBsl10000|_] = List, %% Cleanup. file:delete(SrcFile), @@ -408,7 +400,3 @@ do_integer_encoding(I, Src, Data) -> Str = integer_to_list(I), io:put_chars(Src, [Str,",\n"]), io:put_chars(Data, [Str,",\n"]). - - -id(I) -> I. - diff --git a/lib/compiler/test/receive_SUITE.erl b/lib/compiler/test/receive_SUITE.erl index 8304672558..5e386790c0 100644 --- a/lib/compiler/test/receive_SUITE.erl +++ b/lib/compiler/test/receive_SUITE.erl @@ -222,9 +222,8 @@ do_ref_opt(Source, PrivDir) -> collect_recv_opt_instrs(Code) end, ok - catch Class:Error -> - io:format("~s: ~p ~p\n~p\n", - [Source,Class,Error,erlang:get_stacktrace()]), + catch Class:Error:Stk -> + io:format("~s: ~p ~p\n~p\n", [Source,Class,Error,Stk]), error end. @@ -265,6 +264,10 @@ export(Config) when is_list(Config) -> self() ! {result,Ref,42}, 42 = export_1(Ref), {error,timeout} = export_1(Ref), + + self() ! {result,Ref}, + {ok,Ref} = export_2(), + ok. export_1(Reference) -> @@ -281,6 +284,10 @@ export_1(Reference) -> id({build,self()}), Result. +export_2() -> + receive {result,Result} -> ok end, + {ok,Result}. + wait(Config) when is_list(Config) -> self() ! <<42>>, <<42>> = wait_1(r, 1, 2), diff --git a/lib/compiler/test/trycatch_SUITE.erl b/lib/compiler/test/trycatch_SUITE.erl index a591d6cc93..d5a1dc642f 100644 --- a/lib/compiler/test/trycatch_SUITE.erl +++ b/lib/compiler/test/trycatch_SUITE.erl @@ -26,7 +26,8 @@ nested_of/1,nested_catch/1,nested_after/1, nested_horrid/1,last_call_optimization/1,bool/1, plain_catch_coverage/1,andalso_orelse/1,get_in_try/1, - hockey/1,handle_info/1,catch_in_catch/1,grab_bag/1]). + hockey/1,handle_info/1,catch_in_catch/1,grab_bag/1, + stacktrace/1,nested_stacktrace/1,raise/1]). -include_lib("common_test/include/ct.hrl"). @@ -42,7 +43,8 @@ groups() -> after_oops,eclectic,rethrow,nested_of,nested_catch, nested_after,nested_horrid,last_call_optimization, bool,plain_catch_coverage,andalso_orelse,get_in_try, - hockey,handle_info,catch_in_catch,grab_bag]}]. + hockey,handle_info,catch_in_catch,grab_bag, + stacktrace,nested_stacktrace,raise]}]. init_per_suite(Config) -> @@ -115,6 +117,16 @@ basic(Conf) when is_list(Conf) -> catch nisse -> erro end, + %% Unmatchable clauses. + try + throw(thrown) + catch + {a,b}={a,b,c} -> %Intentionally no match. + ok; + thrown -> + ok + end, + ok. after_call() -> @@ -324,11 +336,11 @@ eclectic(Conf) when is_list(Conf) -> {{error,{exit,V},{'EXIT',V}},V} = eclectic_1({foo,{error,{exit,V}}}, error, {value,V}), {{value,{value,V},V}, - {'EXIT',{badarith,[{?MODULE,my_add,2,_}|_]}}} = + {'EXIT',{badarith,[{erlang,'+',[0,a],_},{?MODULE,my_add,2,_}|_]}}} = eclectic_1({foo,{value,{value,V}}}, undefined, {'add',{0,a}}), {{'EXIT',V},V} = eclectic_1({catch_foo,{exit,V}}, undefined, {throw,V}), - {{error,{'div',{1,0}},{'EXIT',{badarith,[{?MODULE,my_div,2,_}|_]}}}, + {{error,{'div',{1,0}},{'EXIT',{badarith,[{erlang,'div',[1,0],_},{?MODULE,my_div,2,_}|_]}}}, {'EXIT',V}} = eclectic_1({foo,{error,{'div',{1,0}}}}, error, {exit,V}), {{{error,V},{'EXIT',{V,[{?MODULE,foo,1,_}|_]}}}, @@ -345,7 +357,7 @@ eclectic(Conf) when is_list(Conf) -> eclectic_2({error,{value,V}}, throw, {error,V}), {{caught,{'EXIT',{badarg,[{erlang,abs,[V],_}|_]}}},V} = eclectic_2({value,{'abs',V}}, undefined, {value,V}), - {{caught,{'EXIT',{badarith,[{?MODULE,my_add,2,_}|_]}}},V} = + {{caught,{'EXIT',{badarith,[{erlang,'+',[0,a],_},{?MODULE,my_add,2,_}|_]}}},V} = eclectic_2({exit,{'add',{0,a}}}, exit, {value,V}), {{caught,{'EXIT',V}},undefined} = eclectic_2({value,{error,V}}, undefined, {exit,V}), @@ -1039,5 +1051,217 @@ grab_bag(_Config) -> ok. +stacktrace(_Config) -> + V = [make_ref()|self()], + case ?MODULE:module_info(native) of + false -> + {value2,{caught1,badarg,[{erlang,abs,[V],_}|_]}} = + stacktrace_1({'abs',V}, error, {value,V}), + {caught2,{error,badarith},[{erlang,'+',[0,a],_}, + {?MODULE,my_add,2,_}|_]} = + stacktrace_1({'div',{1,0}}, error, {'add',{0,a}}); + true -> + {value2,{caught1,badarg,[{?MODULE,my_abs,1,_}|_]}} = + stacktrace_1({'abs',V}, error, {value,V}), + {caught2,{error,badarith},[{?MODULE,my_add,2,_}|_]} = + stacktrace_1({'div',{1,0}}, error, {'add',{0,a}}) + end, + {caught2,{error,{try_clause,V}},[{?MODULE,stacktrace_1,3,_}|_]} = + stacktrace_1({value,V}, error, {value,V}), + {caught2,{throw,V},[{?MODULE,foo,1,_}|_]} = + stacktrace_1({value,V}, error, {throw,V}), + + try + stacktrace_2() + catch + error:{badmatch,_}:Stk2 -> + [{?MODULE,stacktrace_2,0,_}, + {?MODULE,stacktrace,1,_}|_] = Stk2, + Stk2 = erlang:get_stacktrace(), + ok + end, + + try + stacktrace_3(a, b) + catch + error:function_clause:Stk3 -> + Stk3 = erlang:get_stacktrace(), + case lists:module_info(native) of + false -> + [{lists,prefix,[a,b],_}|_] = Stk3; + true -> + [{lists,prefix,2,_}|_] = Stk3 + end + end, + + try + throw(x) + catch + throw:x:IntentionallyUnused -> + ok + end. + +stacktrace_1(X, C1, Y) -> + try try foo(X) of + C1 -> value1 + catch + C1:D1:Stk1 -> + Stk1 = erlang:get_stacktrace(), + {caught1,D1,Stk1} + after + foo(Y) + end of + V2 -> {value2,V2} + catch + C2:D2:Stk2 -> {caught2,{C2,D2},Stk2=erlang:get_stacktrace()} + end. + +stacktrace_2() -> + ok = erlang:process_info(self(), current_function), + ok. + +stacktrace_3(A, B) -> + {ok,lists:prefix(A, B)}. + +nested_stacktrace(_Config) -> + V = [{make_ref()}|[self()]], + value1 = nested_stacktrace_1({{value,{V,x1}},void,{V,x1}}, + {void,void,void}), + case ?MODULE:module_info(native) of + false -> + {caught1, + [{erlang,'+',[V,x1],_},{?MODULE,my_add,2,_}|_], + value2} = + nested_stacktrace_1({{'add',{V,x1}},error,badarith}, + {{value,{V,x2}},void,{V,x2}}), + {caught1, + [{erlang,'+',[V,x1],_},{?MODULE,my_add,2,_}|_], + {caught2,[{erlang,abs,[V],_}|_]}} = + nested_stacktrace_1({{'add',{V,x1}},error,badarith}, + {{'abs',V},error,badarg}); + true -> + {caught1, + [{?MODULE,my_add,2,_}|_], + value2} = + nested_stacktrace_1({{'add',{V,x1}},error,badarith}, + {{value,{V,x2}},void,{V,x2}}), + {caught1, + [{?MODULE,my_add,2,_}|_], + {caught2,[{?MODULE,my_abs,1,_}|_]}} = + nested_stacktrace_1({{'add',{V,x1}},error,badarith}, + {{'abs',V},error,badarg}) + end, + ok. + +nested_stacktrace_1({X1,C1,V1}, {X2,C2,V2}) -> + try foo(X1) of + V1 -> value1 + catch + C1:V1:S1 -> + S1 = erlang:get_stacktrace(), + T2 = try foo(X2) of + V2 -> value2 + catch + C2:V2:S2 -> + S2 = erlang:get_stacktrace(), + {caught2,S2} + end, + {caught1,S1,T2} + end. + +raise(_Config) -> + test_raise(fun() -> exit({exit,tuple}) end), + test_raise(fun() -> abs(id(x)) end), + test_raise(fun() -> throw({was,thrown}) end), + + badarg = bad_raise(fun() -> abs(id(x)) end), + + ok. + +bad_raise(Expr) -> + try + Expr() + catch + _:E:Stk -> + erlang:raise(bad_class, E, Stk) + end. + +test_raise(Expr) -> + test_raise_1(Expr), + test_raise_2(Expr), + test_raise_3(Expr). + +test_raise_1(Expr) -> + erase(exception), + try + do_test_raise_1(Expr) + catch + C:E:Stk -> + {C,E,Stk} = erase(exception) + end. + +do_test_raise_1(Expr) -> + try + Expr() + catch + C:E:Stk -> + %% Here the stacktrace must be built. + put(exception, {C,E,Stk}), + erlang:raise(C, E, Stk) + end. + +test_raise_2(Expr) -> + erase(exception), + try + do_test_raise_2(Expr) + catch + C:E:Stk -> + {C,E} = erase(exception), + try + Expr() + catch + _:_:S -> + [StkTop|_] = S, + [StkTop|_] = Stk + end + end. + +do_test_raise_2(Expr) -> + try + Expr() + catch + C:E:Stk -> + %% Here it is possible to replace erlang:raise/3 with + %% the raw_raise/3 instruction since the stacktrace is + %% not actually used. + put(exception, {C,E}), + erlang:raise(C, E, Stk) + end. + +test_raise_3(Expr) -> + try + do_test_raise_3(Expr) + catch + exit:{exception,C,E}:Stk -> + try + Expr() + catch + C:E:S -> + [StkTop|_] = S, + [StkTop|_] = Stk + end + end. + +do_test_raise_3(Expr) -> + try + Expr() + catch + C:E:Stk -> + %% Here it is possible to replace erlang:raise/3 with + %% the raw_raise/3 instruction since the stacktrace is + %% not actually used. + erlang:raise(exit, {exception,C,E}, Stk) + end. + id(I) -> I. diff --git a/lib/compiler/test/z_SUITE.erl b/lib/compiler/test/z_SUITE.erl index d864184f4c..cd95d0e733 100644 --- a/lib/compiler/test/z_SUITE.erl +++ b/lib/compiler/test/z_SUITE.erl @@ -54,8 +54,7 @@ do_loaded([{M,_}|Ms], E0) -> _ = M:module_info(functions), E0 catch - C:Error -> - Stk = erlang:get_stacktrace(), + C:Error:Stk -> io:format("~p:~p\n~p\n", [C,Error,Stk]), E0 + 1 end, diff --git a/lib/crypto/c_src/crypto.c b/lib/crypto/c_src/crypto.c index 9a3ea07c97..dbb6bf8135 100644 --- a/lib/crypto/c_src/crypto.c +++ b/lib/crypto/c_src/crypto.c @@ -479,8 +479,6 @@ static ERL_NIF_TERM pkey_sign_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM a static ERL_NIF_TERM pkey_verify_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); static ERL_NIF_TERM pkey_crypt_nif(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[]); static ERL_NIF_TERM dh_compute_key_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); static ERL_NIF_TERM privkey_to_pubkey_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); @@ -568,8 +566,6 @@ static ErlNifFunc nif_funcs[] = { {"pkey_verify_nif", 6, pkey_verify_nif}, {"pkey_crypt_nif", 6, pkey_crypt_nif}, {"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}, {"dh_compute_key_nif", 3, dh_compute_key_nif}, {"privkey_to_pubkey_nif", 2, privkey_to_pubkey_nif}, @@ -3006,82 +3002,23 @@ static ERL_NIF_TERM rsa_generate_key_nif(ErlNifEnv* env, int argc, const ERL_NIF 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; - DH* dh_params = NULL; - int p_len, g_len; - unsigned char *p_ptr, *g_ptr; - ERL_NIF_TERM ret_p, ret_g; - const BIGNUM *dh_p, *dh_q, *dh_g; - - if (!enif_get_int(env, argv[0], &prime_len) - || !enif_get_int(env, argv[1], &generator)) { - - return enif_make_badarg(env); - } - - if (DH_generate_parameters_ex(dh_params, prime_len, generator, NULL)) { - return atom_error; - } - DH_get0_pqg(dh_params, &dh_p, &dh_q, &dh_g); - DH_free(dh_params); - p_len = BN_num_bytes(dh_p); - g_len = BN_num_bytes(dh_g); - p_ptr = enif_make_new_binary(env, p_len, &ret_p); - g_ptr = enif_make_new_binary(env, g_len, &ret_g); - BN_bn2bin(dh_p, p_ptr); - BN_bn2bin(dh_g, g_ptr); - ERL_VALGRIND_MAKE_MEM_DEFINED(p_ptr, p_len); - ERL_VALGRIND_MAKE_MEM_DEFINED(g_ptr, g_len); - return enif_make_list2(env, ret_p, ret_g); -} - -static ERL_NIF_TERM dh_check(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) -{/* ([PrimeLen, Generator]) */ - DH* dh_params; - int i; - ERL_NIF_TERM ret, head, tail; - BIGNUM *dh_p, *dh_g; - - if (!enif_get_list_cell(env, argv[0], &head, &tail) - || !get_bn_from_bin(env, head, &dh_p) - || !enif_get_list_cell(env, tail, &head, &tail) - || !get_bn_from_bin(env, head, &dh_g) - || !enif_is_empty_list(env,tail)) { - - return enif_make_badarg(env); - } - - dh_params = DH_new(); - DH_set0_pqg(dh_params, dh_p, NULL, dh_g); - if (DH_check(dh_params, &i)) { - if (i == 0) ret = atom_ok; - else if (i & DH_CHECK_P_NOT_PRIME) ret = atom_not_prime; - else if (i & DH_CHECK_P_NOT_SAFE_PRIME) ret = atom_not_strong_prime; - else if (i & DH_UNABLE_TO_CHECK_GENERATOR) ret = atom_unable_to_check_generator; - else if (i & DH_NOT_SUITABLE_GENERATOR) ret = atom_not_suitable_generator; - else ret = enif_make_tuple2(env, atom_unknown, enif_make_uint(env, i)); - } - else { /* Check Failed */ - ret = enif_make_tuple2(env, atom_error, atom_check_failed); - } - DH_free(dh_params); - return ret; -} - static ERL_NIF_TERM dh_generate_key_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) {/* (PrivKey|undefined, DHParams=[P,G], Mpint, Len|0) */ - DH* dh_params; + DH* dh_params = NULL; int pub_len, prv_len; unsigned char *pub_ptr, *prv_ptr; ERL_NIF_TERM ret, ret_pub, ret_prv, head, tail; int mpint; /* 0 or 4 */ - BIGNUM *priv_key = NULL; + BIGNUM *priv_key_in = NULL; BIGNUM *dh_p = NULL, *dh_g = NULL; unsigned long len = 0; +#ifdef HAS_EVP_PKEY_CTX + EVP_PKEY_CTX *ctx = NULL; + EVP_PKEY *dhkey = NULL, + *params = NULL; +#endif - if (!(get_bn_from_bin(env, argv[0], &priv_key) + if (!(get_bn_from_bin(env, argv[0], &priv_key_in) || argv[0] == atom_undefined) || !enif_get_list_cell(env, argv[1], &head, &tail) || !get_bn_from_bin(env, head, &dh_p) @@ -3089,40 +3026,63 @@ static ERL_NIF_TERM dh_generate_key_nif(ErlNifEnv* env, int argc, const ERL_NIF_ || !get_bn_from_bin(env, head, &dh_g) || !enif_is_empty_list(env, tail) || !enif_get_int(env, argv[2], &mpint) || (mpint & ~4) - || !enif_get_ulong(env, argv[3], &len) ) { - - if (priv_key) BN_free(priv_key); + || !enif_get_ulong(env, argv[3], &len) + + /* Load dh_params with values to use by the generator. + Mem mgmnt transfered from dh_p etc to dh_params */ + || !(dh_params = DH_new()) + || (priv_key_in && !DH_set0_key(dh_params, NULL, priv_key_in)) + || !DH_set0_pqg(dh_params, dh_p, NULL, dh_g) + ) { + if (priv_key_in) BN_free(priv_key_in); if (dh_p) BN_free(dh_p); if (dh_g) BN_free(dh_g); + if (dh_params) DH_free(dh_params); return enif_make_badarg(env); } - dh_params = DH_new(); - DH_set0_key(dh_params, NULL, priv_key); - DH_set0_pqg(dh_params, dh_p, NULL, dh_g); - if (len) { if (len < BN_num_bits(dh_p)) DH_set_length(dh_params, len); else { - DH_free(dh_params); + if (priv_key_in) BN_free(priv_key_in); + if (dh_p) BN_free(dh_p); + if (dh_g) BN_free(dh_g); + if (dh_params) DH_free(dh_params); return enif_make_badarg(env); } } +#ifdef HAS_EVP_PKEY_CTX + if ((dhkey = EVP_PKEY_new()) + && (params = EVP_PKEY_new()) + && EVP_PKEY_set1_DH(params, dh_params) /* set the key referenced by params to dh_params. + dh_params (and params) must be freed by us*/ + && (ctx = EVP_PKEY_CTX_new(params, NULL)) + && EVP_PKEY_keygen_init(ctx) + && EVP_PKEY_keygen(ctx, &dhkey) + && (dh_params = EVP_PKEY_get1_DH(dhkey)) /* return the referenced key. dh_params and dhkey must be freed */ + ) { +#else if (DH_generate_key(dh_params)) { - const BIGNUM *pub_key, *priv_key; - DH_get0_key(dh_params, &pub_key, &priv_key); - pub_len = BN_num_bytes(pub_key); - prv_len = BN_num_bytes(priv_key); +#endif + const BIGNUM *pub_key_gen, *priv_key_gen; + + DH_get0_key(dh_params, + &pub_key_gen, &priv_key_gen); /* Get pub_key_gen and priv_key_gen. + "The values point to the internal representation of + the public key and private key values. This memory + should not be freed directly." says man */ + pub_len = BN_num_bytes(pub_key_gen); + prv_len = BN_num_bytes(priv_key_gen); pub_ptr = enif_make_new_binary(env, pub_len+mpint, &ret_pub); prv_ptr = enif_make_new_binary(env, prv_len+mpint, &ret_prv); if (mpint) { put_int32(pub_ptr, pub_len); pub_ptr += 4; put_int32(prv_ptr, prv_len); prv_ptr += 4; } - BN_bn2bin(pub_key, pub_ptr); - BN_bn2bin(priv_key, prv_ptr); + BN_bn2bin(pub_key_gen, pub_ptr); + BN_bn2bin(priv_key_gen, prv_ptr); ERL_VALGRIND_MAKE_MEM_DEFINED(pub_ptr, pub_len); ERL_VALGRIND_MAKE_MEM_DEFINED(prv_ptr, prv_len); ret = enif_make_tuple2(env, ret_pub, ret_prv); @@ -3130,21 +3090,33 @@ static ERL_NIF_TERM dh_generate_key_nif(ErlNifEnv* env, int argc, const ERL_NIF_ else { ret = atom_error; } + DH_free(dh_params); +#ifdef HAS_EVP_PKEY_CTX + if (ctx) EVP_PKEY_CTX_free(ctx); + /* if (dhkey) EVP_PKEY_free(dhkey); */ + /* if (params) EVP_PKEY_free(params); */ +#endif return ret; } static ERL_NIF_TERM dh_compute_key_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) {/* (OthersPublicKey, MyPrivateKey, DHParams=[P,G]) */ - DH* dh_params; - BIGNUM *dummy_pub_key = NULL, *priv_key = NULL; - BIGNUM *other_pub_key; - BIGNUM *dh_p = NULL, *dh_g = NULL; - int i; + BIGNUM *dummy_pub_key = NULL, + *priv_key = NULL, + *other_pub_key = NULL, + *dh_p = NULL, + *dh_g = NULL; ErlNifBinary ret_bin; ERL_NIF_TERM ret, head, tail; - - dh_params = DH_new(); + DH *dh_priv = DH_new(), *dh_pub = DH_new(); +#ifdef HAS_EVP_PKEY_CTX + EVP_PKEY_CTX *ctx = NULL; + EVP_PKEY *my_priv_key = NULL, *peer_pub_key = NULL; + size_t skeylen; +#else + int i; +#endif if (!get_bn_from_bin(env, argv[0], &other_pub_key) || !get_bn_from_bin(env, argv[1], &priv_key) @@ -3152,35 +3124,78 @@ static ERL_NIF_TERM dh_compute_key_nif(ErlNifEnv* env, int argc, const ERL_NIF_T || !get_bn_from_bin(env, head, &dh_p) || !enif_get_list_cell(env, tail, &head, &tail) || !get_bn_from_bin(env, head, &dh_g) - || !enif_is_empty_list(env, tail)) { + || !enif_is_empty_list(env, tail) + + /* Note: DH_set0_key() does not allow setting only the + * private key, although DH_compute_key() does not use the + * public key. Work around this limitation by setting + * the public key to a copy of the private key. + */ + || !(dummy_pub_key = BN_dup(priv_key)) + || !DH_set0_key(dh_priv, dummy_pub_key, priv_key) + || !DH_set0_pqg(dh_priv, dh_p, NULL, dh_g) + ) { if (dh_p) BN_free(dh_p); if (dh_g) BN_free(dh_g); - ret = enif_make_badarg(env); + if (other_pub_key) BN_free(other_pub_key); + if (dummy_pub_key) BN_free(dummy_pub_key); + if (priv_key) BN_free(priv_key); + return enif_make_badarg(env); + } + +#ifdef HAS_EVP_PKEY_CTX + if (!(my_priv_key = EVP_PKEY_new()) + || !EVP_PKEY_set1_DH(my_priv_key, dh_priv) /* set the key referenced by my_priv_key to dh_priv. + dh_priv (and my_priv_key) must be freed by us*/ + + || !(peer_pub_key = EVP_PKEY_new()) + || !DH_set0_key(dh_pub, other_pub_key, NULL) + || !DH_set0_pqg(dh_pub, dh_p, NULL, dh_g) + || !EVP_PKEY_set1_DH(peer_pub_key, dh_pub) + + || !(ctx = EVP_PKEY_CTX_new(my_priv_key, NULL)) + || (EVP_PKEY_derive_init(ctx) <= 0) + || (EVP_PKEY_derive_set_peer(ctx, peer_pub_key) <= 0) + || (EVP_PKEY_derive(ctx, NULL, &skeylen) <= 0)) { + + ret = atom_error; } else { - /* Note: DH_set0_key() does not allow setting only the - * private key, although DH_compute_key() does not use the - * public key. Work around this limitation by setting - * the public key to a copy of the private key. - */ - dummy_pub_key = BN_dup(priv_key); - DH_set0_key(dh_params, dummy_pub_key, priv_key); - DH_set0_pqg(dh_params, dh_p, NULL, dh_g); - enif_alloc_binary(DH_size(dh_params), &ret_bin); - i = DH_compute_key(ret_bin.data, other_pub_key, dh_params); - if (i > 0) { - if (i != ret_bin.size) { - enif_realloc_binary(&ret_bin, i); - } - ret = enif_make_binary(env, &ret_bin); - } - else { + enif_alloc_binary(skeylen, &ret_bin); + + if ((EVP_PKEY_derive(ctx, ret_bin.data, &skeylen) > 0) + && (ret_bin.size >= skeylen)) { + /* Derivation succeded */ + if (ret_bin.size > skeylen) enif_realloc_binary(&ret_bin, skeylen); + ret = enif_make_binary(env, &ret_bin); + } + else { enif_release_binary(&ret_bin); - ret = atom_error; - } + ret = atom_error; + } + } + +#else + enif_alloc_binary(DH_size(dh_priv), &ret_bin); + i = DH_compute_key(ret_bin.data, other_pub_key, dh_priv); + if (i > 0) { + if (i != ret_bin.size) enif_realloc_binary(&ret_bin, i); + ret = enif_make_binary(env, &ret_bin); } + else { + enif_release_binary(&ret_bin); + ret = atom_error; + } +#endif + if (other_pub_key) BN_free(other_pub_key); - DH_free(dh_params); + if (dh_priv) DH_free(dh_priv); + if (dh_pub) DH_free(dh_pub); +#ifdef HAS_EVP_PKEY_CTX + if (ctx) EVP_PKEY_CTX_free(ctx); + /* if (my_priv_key) EVP_PKEY_free(my_priv_key); */ + /* if (peer_pub_key) EVP_PKEY_free(peer_pub_key); */ +#endif return ret; } diff --git a/lib/crypto/doc/src/crypto.xml b/lib/crypto/doc/src/crypto.xml index 464799b320..af676d9021 100644 --- a/lib/crypto/doc/src/crypto.xml +++ b/lib/crypto/doc/src/crypto.xml @@ -136,6 +136,7 @@ See also <seealso marker="#supports-0">crypto:supports/0</seealso> </p> + <marker id="type-engine_key_ref"/> <marker id="engine_key_ref_type"/> <code>engine_key_ref() = #{engine := engine_ref(), key_id := key_id(), @@ -790,9 +791,16 @@ <seealso marker="stdlib:rand">random number generation</seealso>, in order to generate cryptographically strong random numbers (based on OpenSSL's <c>BN_rand_range</c>), - and saves it on process dictionary before returning it as well. + and saves it in the process dictionary before returning it as well. See also - <seealso marker="stdlib:rand#seed-1">rand:seed/1</seealso>. + <seealso marker="stdlib:rand#seed-1">rand:seed/1</seealso> and + <seealso marker="#rand_seed_s-0">rand_seed_s/0</seealso>. + </p> + <p> + When using the state object from this function the + <seealso marker="stdlib:rand">rand</seealso> functions using it + may throw exception <c>low_entropy</c> in case the random generator + failed due to lack of secure "randomness". </p> <p><em>Example</em></p> <pre> @@ -814,6 +822,120 @@ _FloatValue = rand:uniform(). % [0.0; 1.0[</pre> See also <seealso marker="stdlib:rand#seed_s-1">rand:seed_s/1</seealso>. </p> + <p> + When using the state object from this function the + <seealso marker="stdlib:rand">rand</seealso> functions using it + may throw exception <c>low_entropy</c> in case the random generator + failed due to lack of secure "randomness". + </p> + <note> + <p> + The state returned from this function can not be used + to get a reproducable random sequence as from + the other + <seealso marker="stdlib:rand">rand</seealso> + functions, + since reproducability does not match cryptographically safe. + </p> + <p> + The only supported usage is to generate one distinct + random sequence from this start state. + </p> + </note> + </desc> + </func> + + <func> + <name>rand_seed_alg(Alg) -> rand:state()</name> + <fsummary>Strong random number generation plugin state</fsummary> + <type> + <v>Alg = crypto | crypto_cache</v> + </type> + <desc> + <marker id="rand_seed_alg-1" /> + <p> + Creates state object for + <seealso marker="stdlib:rand">random number generation</seealso>, + in order to generate cryptographically strong random numbers. + See also + <seealso marker="stdlib:rand#seed-1">rand:seed/1</seealso> and + <seealso marker="#rand_seed_alg_s-1">rand_seed_alg_s/1</seealso>. + </p> + <p> + When using the state object from this function the + <seealso marker="stdlib:rand">rand</seealso> functions using it + may throw exception <c>low_entropy</c> in case the random generator + failed due to lack of secure "randomness". + </p> + <p> + The cache size can be changed from its default value using the + <seealso marker="crypto_app"> + crypto app's + </seealso> configuration parameter <c>rand_cache_size</c>. + </p> + <p><em>Example</em></p> + <pre> +_ = crypto:rand_seed_alg(crypto_cache), +_IntegerValue = rand:uniform(42), % [1; 42] +_FloatValue = rand:uniform(). % [0.0; 1.0[</pre> + </desc> + </func> + + <func> + <name>rand_seed_alg_s(Alg) -> rand:state()</name> + <fsummary>Strong random number generation plugin state</fsummary> + <type> + <v>Alg = crypto | crypto_cache</v> + </type> + <desc> + <marker id="rand_seed_alg_s-1" /> + <p> + Creates state object for + <seealso marker="stdlib:rand">random number generation</seealso>, + in order to generate cryptographically strongly random numbers. + See also + <seealso marker="stdlib:rand#seed_s-1">rand:seed_s/1</seealso>. + </p> + <p> + If <c>Alg</c> is <c>crypto</c> this function behaves exactly like + <seealso marker="#rand_seed_s-0">rand_seed_s/0</seealso>. + </p> + <p> + If <c>Alg</c> is <c>crypto_cache</c> this function + fetches random data with OpenSSL's <c>RAND_bytes</c> + and caches it for speed using an internal word size + of 56 bits that makes calculations fast on 64 bit machines. + </p> + <p> + When using the state object from this function the + <seealso marker="stdlib:rand">rand</seealso> functions using it + may throw exception <c>low_entropy</c> in case the random generator + failed due to lack of secure "randomness". + </p> + <p> + The cache size can be changed from its default value using the + <seealso marker="crypto_app"> + crypto app's + </seealso> configuration parameter <c>rand_cache_size</c>. + </p> + <note> + <p> + The state returned from this function can not be used + to get a reproducable random sequence as from + the other + <seealso marker="stdlib:rand">rand</seealso> + functions, + since reproducability does not match cryptographically safe. + </p> + <p> + In fact since random data is cached some numbers may + get reproduced if you try, but this is unpredictable. + </p> + <p> + The only supported usage is to generate one distinct + random sequence from this start state. + </p> + </note> </desc> </func> diff --git a/lib/crypto/doc/src/crypto_app.xml b/lib/crypto/doc/src/crypto_app.xml index ba22557480..8296b1bc77 100644 --- a/lib/crypto/doc/src/crypto_app.xml +++ b/lib/crypto/doc/src/crypto_app.xml @@ -68,6 +68,24 @@ thus the crypto module will fail to load. This mechanism prevents the accidental use of non-validated algorithms.</p> </item> + <tag><c>rand_cache_size = integer()</c></tag> + <item> + <p> + Sets the cache size in bytes to use by + <seealso marker="crypto#rand_seed_alg-1"> + <c>crypto:rand_seed_alg(crypto_cache)</c> + </seealso> and + <seealso marker="crypto#rand_seed_alg_s-1"> + <c>crypto:rand_seed_alg_s(crypto_cache)</c> + </seealso>. + This parameter is read when a seed function is called, + and then kept in generators state object. It has a rather + small default value that causes reads of strong random bytes + about once per hundred calls for a random value. + The set value is rounded up to an integral number of words + of the size these seed functions use. + </p> + </item> </taglist> </section> diff --git a/lib/crypto/src/crypto.app.src b/lib/crypto/src/crypto.app.src index 1d3f35e465..492aa10e51 100644 --- a/lib/crypto/src/crypto.app.src +++ b/lib/crypto/src/crypto.app.src @@ -24,7 +24,7 @@ crypto_ec_curves]}, {registered, []}, {applications, [kernel, stdlib]}, - {env, [{fips_mode, false}]}, + {env, [{fips_mode, false}, {rand_cache_size, 896}]}, {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 1a1b4f98b5..46775989ae 100644 --- a/lib/crypto/src/crypto.erl +++ b/lib/crypto/src/crypto.erl @@ -30,18 +30,18 @@ -export([hmac/3, hmac/4, hmac_init/2, hmac_update/2, hmac_final/1, hmac_final_n/2]). -export([cmac/3, cmac/4]). -export([exor/2, strong_rand_bytes/1, mod_pow/3]). --export([rand_seed/0]). --export([rand_seed_s/0]). +-export([rand_seed/0, rand_seed_alg/1]). +-export([rand_seed_s/0, rand_seed_alg_s/1]). -export([rand_plugin_next/1]). -export([rand_plugin_uniform/1]). -export([rand_plugin_uniform/2]). +-export([rand_cache_plugin_next/1]). -export([rand_uniform/2]). -export([block_encrypt/3, block_decrypt/3, block_encrypt/4, block_decrypt/4]). -export([next_iv/2, next_iv/3]). -export([stream_init/2, stream_init/3, stream_encrypt/2, stream_decrypt/2]). -export([public_encrypt/4, private_decrypt/4]). -export([private_encrypt/4, public_decrypt/4]). --export([dh_generate_parameters/2, dh_check/1]). %% Testing see -export([privkey_to_pubkey/2]). -export([ec_curve/1, ec_curves/0]). -export([rand_seed/1]). @@ -317,9 +317,17 @@ stream_decrypt(State, Data0) -> %% %% RAND - pseudo random numbers using RN_ and BN_ functions in crypto lib %% +-type rand_cache_seed() :: + nonempty_improper_list(non_neg_integer(), binary()). -spec strong_rand_bytes(non_neg_integer()) -> binary(). -spec rand_seed() -> rand:state(). -spec rand_seed_s() -> rand:state(). +-spec rand_seed_alg(Alg :: atom()) -> + {rand:alg_handler(), + atom() | rand_cache_seed()}. +-spec rand_seed_alg_s(Alg :: atom()) -> + {rand:alg_handler(), + atom() | rand_cache_seed()}. -spec rand_uniform(crypto_integer(), crypto_integer()) -> crypto_integer(). @@ -335,12 +343,36 @@ rand_seed() -> rand:seed(rand_seed_s()). rand_seed_s() -> + rand_seed_alg_s(?MODULE). + +rand_seed_alg(Alg) -> + rand:seed(rand_seed_alg_s(Alg)). + +-define(CRYPTO_CACHE_BITS, 56). +rand_seed_alg_s(?MODULE) -> {#{ type => ?MODULE, bits => 64, next => fun ?MODULE:rand_plugin_next/1, uniform => fun ?MODULE:rand_plugin_uniform/1, uniform_n => fun ?MODULE:rand_plugin_uniform/2}, - no_seed}. + no_seed}; +rand_seed_alg_s(crypto_cache) -> + CacheBits = ?CRYPTO_CACHE_BITS, + EnvCacheSize = + application:get_env( + crypto, rand_cache_size, CacheBits * 16), % Cache 16 * 8 words + Bytes = (CacheBits + 7) div 8, + CacheSize = + case ((EnvCacheSize + (Bytes - 1)) div Bytes) * Bytes of + Sz when is_integer(Sz), Bytes =< Sz -> + Sz; + _ -> + Bytes + end, + {#{ type => crypto_cache, + bits => CacheBits, + next => fun ?MODULE:rand_cache_plugin_next/1}, + {CacheBits, CacheSize, <<>>}}. rand_plugin_next(Seed) -> {bytes_to_integer(strong_rand_range(1 bsl 64)), Seed}. @@ -351,6 +383,12 @@ rand_plugin_uniform(State) -> rand_plugin_uniform(Max, State) -> {bytes_to_integer(strong_rand_range(Max)) + 1, State}. +rand_cache_plugin_next({CacheBits, CacheSize, <<>>}) -> + rand_cache_plugin_next( + {CacheBits, CacheSize, strong_rand_bytes(CacheSize)}); +rand_cache_plugin_next({CacheBits, CacheSize, Cache}) -> + <<I:CacheBits, NewCache/binary>> = Cache, + {I, {CacheBits, CacheSize, NewCache}}. strong_rand_range(Range) when is_integer(Range), Range > 0 -> BinRange = int_to_bin(Range), @@ -398,7 +436,7 @@ rand_uniform_nif(_From,_To) -> ?nif_stub. -spec rand_seed(binary()) -> ok. -rand_seed(Seed) -> +rand_seed(Seed) when is_binary(Seed) -> rand_seed_nif(Seed). rand_seed_nif(_Seed) -> ?nif_stub. @@ -809,8 +847,13 @@ on_load() -> case Status of ok -> ok; {error, {E, Str}} -> - error_logger:error_msg("Unable to load crypto library. Failed with error:~n\"~p, ~s\"~n" - "OpenSSL might not be installed on this system.~n",[E,Str]), + Fmt = "Unable to load crypto library. Failed with error:~n\"~p, ~s\"~n~s", + Extra = case E of + load_failed -> + "OpenSSL might not be installed on this system.\n"; + _ -> "" + end, + error_logger:error_msg(Fmt, [E,Str,Extra]), Status end. @@ -1051,27 +1094,6 @@ rsa_generate_key_nif(_Bits, _Exp) -> ?nif_stub. %% DH Diffie-Hellman functions %% -%% Generate (and check) Parameters is not documented because they are implemented -%% for testing (and offline parameter generation) only. -%% From the openssl doc: -%% DH_generate_parameters() may run for several hours before finding a suitable prime. -%% Thus dh_generate_parameters may in this implementation block -%% the emulator for several hours. -%% -%% usage: dh_generate_parameters(1024, 2 or 5) -> -%% [Prime=mpint(), SharedGenerator=mpint()] -dh_generate_parameters(PrimeLen, Generator) -> - case dh_generate_parameters_nif(PrimeLen, Generator) of - error -> erlang:error(generation_failed, [PrimeLen,Generator]); - Ret -> Ret - end. - -dh_generate_parameters_nif(_PrimeLen, _Generator) -> ?nif_stub. - -%% Checks that the DHParameters are ok. -%% DHParameters = [P (Prime)= mpint(), G(Generator) = mpint()] -dh_check([_Prime,_Gen]) -> ?nif_stub. - %% DHParameters = [P (Prime)= mpint(), G(Generator) = mpint()] %% PrivKey = mpint() dh_generate_key_nif(_PrivateKey, _DHParameters, _Mpint, _Length) -> ?nif_stub. diff --git a/lib/crypto/test/crypto_SUITE.erl b/lib/crypto/test/crypto_SUITE.erl index 6dab459df6..d148fa3856 100644 --- a/lib/crypto/test/crypto_SUITE.erl +++ b/lib/crypto/test/crypto_SUITE.erl @@ -131,7 +131,8 @@ groups() -> {ecdsa, [], [sign_verify %% Does not work yet: ,public_encrypt, private_encrypt ]}, - {dh, [], [generate_compute]}, + {dh, [], [generate_compute, + compute_bug]}, {ecdh, [], [compute, generate]}, {srp, [], [generate_compute]}, {des_cbc, [], [block]}, @@ -463,6 +464,24 @@ generate_compute(Config) when is_list(Config) -> GenCom = proplists:get_value(generate_compute, Config), lists:foreach(fun do_generate_compute/1, GenCom). %%-------------------------------------------------------------------- +compute_bug() -> + [{doc, "Test that it works even if the Secret is smaller than expected"}]. +compute_bug(Config) -> + ExpectedSecret = <<118,89,171,16,156,18,156,103,189,134,130,49,28,144,111,241,247,82,79,32,228,11,209,141,119,176,251,80,105,143,235,251,203,121,223,211,129,3,233,133,45,2,31,157,24,111,5,75,153,66,135,185,128,115,229,178,216,39,73,52,80,151,8,241,34,52,226,71,137,167,53,48,59,224,175,154,89,110,76,83,24,117,149,21,72,6,186,78,149,74,188,56,98,244,30,77,108,248,88,194,195,237,23,51,20,242,254,123,21,12,209,74,217,168,230,65,7,60,211,139,128,239,234,153,22,229,180,59,159,121,41,156,121,200,177,130,163,162,54,224,93,1,94,11,177,254,118,28,156,26,116,10,207,145,219,166,214,189,214,230,221,170,228,15,69,88,31,68,94,255,113,58,49,82,86,192,248,176,131,133,39,186,194,172,206,84,184,16,66,68,153,128,178,227,27,118,52,130,122,92,24,222,102,195,221,207,255,13,152,175,65,32,167,84,54,244,243,109,244,18,234,16,159,224,188,2,106,123,27,17,131,171,226,34,111,251,62,119,155,124,221,124,254,62,97,167,1,105,116,98,98,19,197,30,72,180,79,221,100,134,120,117,124,85,73,132,224,223,222,41,155,137,218,130,238,237,157,161,134,150,69,206,91,141,17,89,120,218,235,229,37,150,76,197,7,157,56,144,42,203,137,100,200,72,141,194,239,1,67,236,238,183,48,214,75,76,108,235,3,237,67,40,137,45,182,236,246,37,116,103,144,237,142,211,88,233,11,24,21,218,41,245,250,51,130,250,104,74,189,17,69,145,70,50,50,215,253,155,10,128,41,114,185,211,82,164,72,92,17,145,104,66,6,140,226,80,43,62,1,166,216,153,118,96,15,147,126,137,118,191,192,75,149,241,206,18,92,17,154,215,219,18,6,139,190,103,210,156,184,29,224,213,157,60,112,189,104,220,125,40,186,50,119,17,143,136,149,38,74,107,21,192,59,61,59,42,231,144,59,175,3,176,87,23,16,122,54,31,82,34,230,211,44,81,41,47,86,37,228,175,130,148,88,136,131,254,241,202,99,199,175,1,141,215,124,155,120,43,141,89,11,140,120,141,29,35,82,219,155,204,75,12,66,241,253,33,250,84,24,85,68,13,80,85,142,227,34,139,26,146,24>>, + OthersPublicKey = 635619632099733175381667940709387641100492974601603060984753028943194386334921787463327680809776598322996634648015962954045728174069768874873236397421720142610982770302060309928552098274817978606093380781524199673890631795310930242601197479471368910519338301177304682162189801040921618559902948819107531088646753320486728060005223263561551402855338732899079439899705951063999951507319258050864346087428042978411873495523439615429804957374639092580169417598963105885529553632847023899713490485619763926900318508906706745060947269748612049634207985438016935262521715769812475329234748426647554362991758104620357149045960316987533503707855364806010494793980069245562784050236811004893018183726397041999426883788660276453352521120006817370050691205529335316794439089316232980047277245051173281601960196573681285904611182521967067911862467395705665888521948321299521549941618586026714676885890192323289343756440666276226084448279082483536164085883288884231665240707495770544705648564889889198060417915693315346959170105413290799314390963124178046425737828369059171472978294050322371452255088799865552038756937873388385970088906560408959959429398326288750834357514847891423941047433478384621074116184703014798814515161475596555032391555842, + MyPrivateKey = 387759582879975726965038486537011291913744975764132199838375902680222019267527675651273586836110220500657652661706223760165097275862806031329642160439090779625708664007910974206651834216043397115514725827856461492311499129200688538220719685637154290305617686974719521885238198226075381217068175824097878445476010193039590876624464274744156624589136789060427283492343902761765833713520850870233407503430180028104167029073459918756981323130062648615262139444306321256382009848217866984408901761817655567071716275177768316006340055589170095799943481591033461616307776069027985761229636731465482676467627154100912586936231051371168178564599296638350391246393336702334311781595616786107810962134407697848002331639021101685320844880636050048769216986088652236979636019052557155807310341483407890060105599892252118584570558049301477535792498672552850760356632076013402382600669875697284264329434950712239302528367835155163504374877787288116104285944993818319105835423479332617802010952731990182088670508346704423006877514817882782443833997288652405892920173712497948376815825396272381214976859009518623799156300136570204539240675245115597412280078940442452936425561984312708387584800789375684525365060589104566195610526570099527133097201479, + P = 818034524162384276004384029858643530286875094391273833506734966261806257117433972760379103507630310628953496150318170372254219924175532996281953750642804369831900894594960807970232131410638888573275563720690293481410915588408505771183615664441221559618326229227448328879290185035795866796496147000467456347856187771645103733376761936369144682074588463621004219054111244232031965820058057143484947957179035662640791007685559024477920075136419228662974090561346329074935312181886940693299380892129818458511403741106419480550004799657220331973244248753744516935739033770420884365608406478656143540532371463443324228730693491647103274058971797182813283112583029849186056551355376851686616057869624968077484471229044125401535456699914745876082047459812392122562460031611344154642406382436701361983114768023990405077450124649862159757605118611426368650203370143674925598905779061402007525955196464201496773278952462368223659263492419274489020447849336502432222101793313731259141617677580646998184158969477474527427664187763741360356528830301163614618231141541403007931347398186427059736520580903587497382362610721261644208653717495736748724114113311672504064943864203789205551568648546606356374830209356446449765364678719909024329058480379, + G = 2, + DHParameters = [P, G], + case crypto:compute_key(dh, OthersPublicKey, MyPrivateKey, DHParameters) of + ExpectedSecret -> + ok; + Others -> + ct:log("Got ~p",[Others]), + {fail, "crypto:compute_key(dh,...) failed for the bug test"} + end. + +%%-------------------------------------------------------------------- no_generate_compute() -> [{doc, "Test crypto:genarate_key and crypto:compute_key " "for disabled algorithms"}]. diff --git a/lib/debugger/src/dbg_debugged.erl b/lib/debugger/src/dbg_debugged.erl index e142af4ae0..8b64a60a9c 100644 --- a/lib/debugger/src/dbg_debugged.erl +++ b/lib/debugger/src/dbg_debugged.erl @@ -31,32 +31,25 @@ %% Called via the error handler. %%-------------------------------------------------------------------- eval(Mod, Func, Args) -> - SaveStacktrace = erlang:get_stacktrace(), Meta = dbg_ieval:eval(Mod, Func, Args), Mref = erlang:monitor(process, Meta), - msg_loop(Meta, Mref, SaveStacktrace). + msg_loop(Meta, Mref). %%==================================================================== %% Internal functions %%==================================================================== -msg_loop(Meta, Mref, SaveStacktrace) -> +msg_loop(Meta, Mref) -> receive %% Evaluated function has returned a value {sys, Meta, {ready, Val}} -> erlang:demonitor(Mref, [flush]), - - %% Restore original stacktrace and return the value - try erlang:raise(throw, stack, SaveStacktrace) - catch - throw:stack -> - case Val of - {dbg_apply,M,F,A} -> - apply(M, F, A); - _ -> - Val - end + case Val of + {dbg_apply,M,F,A} -> + apply(M, F, A); + _ -> + Val end; %% Evaluated function raised an (uncaught) exception @@ -74,32 +67,25 @@ msg_loop(Meta, Mref, SaveStacktrace) -> Meta ! {self(), rec_acked}, ok end, - msg_loop(Meta, Mref, SaveStacktrace); + msg_loop(Meta, Mref); %% Meta needs something evaluated within context of real process {sys, Meta, {command,Command}} -> Reply = handle_command(Command), Meta ! {sys, self(), Reply}, - msg_loop(Meta, Mref, SaveStacktrace); + msg_loop(Meta, Mref); %% Meta has terminated %% Must be due to int:stop() (or -heaven forbid- a debugger bug) {'DOWN', Mref, _, _, Reason} -> - - %% Restore original stacktrace and return a dummy value - try erlang:raise(throw, stack, SaveStacktrace) - catch - throw:stack -> - {interpreter_terminated, Reason} - end + {interpreter_terminated, Reason} end. handle_command(Command) -> try reply(Command) - catch Class:Reason -> - Stacktrace = stacktrace_f(erlang:get_stacktrace()), - {exception,{Class,Reason,Stacktrace}} + catch Class:Reason:Stacktrace -> + {exception,{Class,Reason,stacktrace_f(Stacktrace)}} end. reply({apply,M,F,As}) -> diff --git a/lib/debugger/src/dbg_ieval.erl b/lib/debugger/src/dbg_ieval.erl index 8009d62629..9840cebc1a 100644 --- a/lib/debugger/src/dbg_ieval.erl +++ b/lib/debugger/src/dbg_ieval.erl @@ -924,8 +924,7 @@ expr({dbg,Line,raise,As0}, Bs0, #ieval{level=Le}=Ieval0) -> trace(return, {Le,Error}), {value,Error,Bs} catch - _:_ -> - Stk = erlang:get_stacktrace(), %Possibly truncated. + _:_:Stk -> %Possibly truncated. StkFun = fun(_) -> Stk end, do_exception(Class, Reason, StkFun, Bs, Ieval) end; @@ -1034,7 +1033,7 @@ expr({send,Line,To0,Msg0}, Bs0, Ieval0) -> %% Binary expr({bin,Line,Fs}, Bs0, Ieval0) -> - Ieval = Ieval0#ieval{line=Line}, + Ieval = Ieval0#ieval{line=Line,top=false}, try eval_bits:expr_grp(Fs, Bs0, fun (E, B) -> expr(E, B, Ieval) end, diff --git a/lib/debugger/src/dbg_wx_mon.erl b/lib/debugger/src/dbg_wx_mon.erl index a32a6894b8..00aee62a87 100644 --- a/lib/debugger/src/dbg_wx_mon.erl +++ b/lib/debugger/src/dbg_wx_mon.erl @@ -119,9 +119,9 @@ init(CallingPid, Mode, SFile) -> init2(CallingPid, Mode, SFile, GS) catch exit:stop -> stop; - Error:Reason -> + Error:Reason:Stacktrace -> io:format("~p: Crashed {~p,~p} in~n ~p", - [?MODULE, Error, Reason, erlang:get_stacktrace()]) + [?MODULE, Error, Reason, Stacktrace]) end end. diff --git a/lib/debugger/src/dbg_wx_trace.erl b/lib/debugger/src/dbg_wx_trace.erl index b1e0e03b4c..505d53005f 100644 --- a/lib/debugger/src/dbg_wx_trace.erl +++ b/lib/debugger/src/dbg_wx_trace.erl @@ -95,9 +95,9 @@ start(Pid, Env, Parent, TraceWin, BackTrace, Strings) -> catch _:stop -> exit(stop); - E:R -> + E:R:S -> io:format("TraceWin Crashed ~p~n",[E]), - io:format(" ~p in ~p~n",[R, erlang:get_stacktrace()]), + io:format(" ~p in ~p~n",[R, S]), exit(R) end; error -> diff --git a/lib/debugger/src/i.erl b/lib/debugger/src/i.erl index 62ce8d0e20..853fa529a0 100644 --- a/lib/debugger/src/i.erl +++ b/lib/debugger/src/i.erl @@ -30,7 +30,7 @@ -import(lists, [sort/1,foreach/2]). iv() -> - Vsn = string:substr(filename:basename(code:lib_dir(debugger)), 10), + Vsn = string:slice(filename:basename(code:lib_dir(debugger)), 9), list_to_atom(Vsn). %% ------------------------------------------- diff --git a/lib/debugger/test/guard_SUITE.erl b/lib/debugger/test/guard_SUITE.erl index f7874f79df..e781ea932f 100644 --- a/lib/debugger/test/guard_SUITE.erl +++ b/lib/debugger/test/guard_SUITE.erl @@ -390,7 +390,7 @@ all_types() -> {atom, xxxx}, {ref, make_ref()}, {pid, self()}, - {port, open_port({spawn, efile}, [])}, + {port, make_port()}, {function, fun(X) -> X+1, "" end}, {binary, list_to_binary([])}]. @@ -435,6 +435,9 @@ type_test(binary, X) when binary(X) -> type_test(function, X) when function(X) -> function. +make_port() -> + hd(erlang:ports()). + const_guard(Config) when is_list(Config) -> if (0 == 0) and ((0 == 0) or (0 == 0)) -> diff --git a/lib/debugger/test/int_eval_SUITE.erl b/lib/debugger/test/int_eval_SUITE.erl index 27ca4852b5..da1d6734f8 100644 --- a/lib/debugger/test/int_eval_SUITE.erl +++ b/lib/debugger/test/int_eval_SUITE.erl @@ -29,7 +29,8 @@ bifs_outside_erlang/1, spawning/1, applying/1, catch_and_throw/1, external_call/1, test_module_info/1, apply_interpreted_fun/1, apply_uninterpreted_fun/1, - interpreted_exit/1, otp_8310/1, stacktrace/1, maps/1]). + interpreted_exit/1, otp_8310/1, stacktrace/1, maps/1, + call_inside_binary/1]). %% Helpers. -export([applier/3]). @@ -45,7 +46,8 @@ all() -> [bifs_outside_erlang, spawning, applying, catch_and_throw, external_call, test_module_info, apply_interpreted_fun, apply_uninterpreted_fun, - interpreted_exit, otp_8310, stacktrace, maps]. + interpreted_exit, otp_8310, stacktrace, maps, + call_inside_binary]. groups() -> []. @@ -275,6 +277,9 @@ maps(Config) when is_list(Config) -> [#{hello := 0, price := 0}] = spawn_eval(fun () -> ?IM:update_in_fun() end), ok. +call_inside_binary(Config) when is_list(Config) -> + <<"1">> = ?IM:call_inside_binary(fun erlang:integer_to_binary/1), + ok. do_eval(Config, Mod) -> DataDir = proplists:get_value(data_dir, Config), diff --git a/lib/debugger/test/int_eval_SUITE_data/my_int_eval_module.erl b/lib/debugger/test/int_eval_SUITE_data/my_int_eval_module.erl index ca7929c10b..384d61f051 100644 --- a/lib/debugger/test/int_eval_SUITE_data/my_int_eval_module.erl +++ b/lib/debugger/test/int_eval_SUITE_data/my_int_eval_module.erl @@ -31,6 +31,7 @@ -export([f/1, f_try/1, f_catch/1]). -export([otp_5837/1, otp_8310/0]). -export([empty_map_update/1, update_in_fun/0]). +-export([call_inside_binary/1]). %% Internal exports. -export([echo/2,my_subtract/2,catch_a_ball/0,throw_a_ball/0]). @@ -248,3 +249,6 @@ empty_map_update(Map) -> Map#{}. update_in_fun() -> lists:map(fun (X) -> X#{price := 0} end, [#{hello => 0, price => nil}]). + +call_inside_binary(Fun) -> + <<(Fun(1))/binary>>. diff --git a/lib/dialyzer/src/dialyzer_cl.erl b/lib/dialyzer/src/dialyzer_cl.erl index 0617be6435..1e06d6e974 100644 --- a/lib/dialyzer/src/dialyzer_cl.erl +++ b/lib/dialyzer/src/dialyzer_cl.erl @@ -672,7 +672,7 @@ failed_anal_msg(Reason, LogCache) -> %% format_log_cache(LogCache) -> Str = lists:append(lists:reverse(LogCache)), - string:join(string:tokens(Str, "\n"), "\n "). + lists:join("\n ", string:lexemes(Str, "\n")). -spec store_warnings(#cl_state{}, [raw_warning()]) -> #cl_state{}. diff --git a/lib/dialyzer/src/dialyzer_cl_parse.erl b/lib/dialyzer/src/dialyzer_cl_parse.erl index 80c10183cf..f21eaed087 100644 --- a/lib/dialyzer/src/dialyzer_cl_parse.erl +++ b/lib/dialyzer/src/dialyzer_cl_parse.erl @@ -41,8 +41,8 @@ start() -> Ret catch throw:{dialyzer_cl_parse_error, Msg} -> {error, Msg}; - _:R -> - Msg = io_lib:format("~tp\n~tp\n", [R, erlang:get_stacktrace()]), + _:R:S -> + Msg = io_lib:format("~tp\n~tp\n", [R, S]), {error, lists:flatten(Msg)} end. diff --git a/lib/dialyzer/src/dialyzer_contracts.erl b/lib/dialyzer/src/dialyzer_contracts.erl index e72c1aecfc..0df15e55f9 100644 --- a/lib/dialyzer/src/dialyzer_contracts.erl +++ b/lib/dialyzer/src/dialyzer_contracts.erl @@ -197,6 +197,10 @@ check_contracts(Contracts, Callgraph, FunTypes, ModOpaques) -> false -> [{MFA, Contract}|NewContracts] end; + {error, {extra_range, _, _}} -> + %% do not treat extra range as an error in this check + %% since that prevents discovering other actual errors + [{MFA, Contract}|NewContracts]; {error, _Error} -> NewContracts end; error -> NewContracts diff --git a/lib/dialyzer/src/dialyzer_dataflow.erl b/lib/dialyzer/src/dialyzer_dataflow.erl index ea3523a965..c5f93a3392 100644 --- a/lib/dialyzer/src/dialyzer_dataflow.erl +++ b/lib/dialyzer/src/dialyzer_dataflow.erl @@ -299,6 +299,7 @@ traverse(Tree, Map, State) -> match_fail -> t_none(); raise -> t_none(); bs_init_writable -> t_from_term(<<>>); + build_stacktrace -> erl_bif_types:type(erlang, build_stacktrace, 0); Other -> erlang:error({'Unsupported primop', Other}) end, {State, Map, Type}; diff --git a/lib/dialyzer/src/dialyzer_gui_wx.erl b/lib/dialyzer/src/dialyzer_gui_wx.erl index b4b1872c12..b8414b7d8b 100644 --- a/lib/dialyzer/src/dialyzer_gui_wx.erl +++ b/lib/dialyzer/src/dialyzer_gui_wx.erl @@ -475,7 +475,7 @@ gui_loop(#gui_state{backend_pid = BackendPid, doc_plt = DocPlt, gui_loop(State); {BackendPid, ext_types, ExtTypes} -> Map = fun({M,F,A}) -> io_lib:format("~tp:~tp/~p",[M,F,A]) end, - ExtTypeString = string:join(lists:map(Map, ExtTypes), "\n"), + ExtTypeString = lists:join("\n", lists:map(Map, ExtTypes)), Msg = io_lib:format("The following remote types are being used " "but information about them is not available.\n" "The analysis might get more precise by including " @@ -638,7 +638,7 @@ output_sms(#gui_state{frame = Frame}, Title, Message, Type) -> free_editor(#gui_state{gui = Wx, frame = Frame}, Title, Contents0) -> Contents = lists:flatten(Contents0), - Tokens = string:tokens(Contents, "\n"), + Tokens = string:lexemes(Contents, "\n"), NofLines = length(Tokens), LongestLine = lists:max([length(X) || X <- Tokens]), Height0 = NofLines * 25 + 80, diff --git a/lib/dialyzer/src/dialyzer_plt.erl b/lib/dialyzer/src/dialyzer_plt.erl index 95c8b5ebce..2af4534396 100644 --- a/lib/dialyzer/src/dialyzer_plt.erl +++ b/lib/dialyzer/src/dialyzer_plt.erl @@ -531,17 +531,19 @@ compute_md5_from_files(Files) -> lists:keysort(1, [{F, compute_md5_from_file(F)} || F <- Files]). compute_md5_from_file(File) -> - case filelib:is_regular(File) of - false -> + case beam_lib:all_chunks(File) of + {ok, _, Chunks} -> + %% We cannot use beam_lib:md5 because it does not consider + %% the debug_info chunk, where typespecs are likely stored. + %% So we consider almost all chunks except the useless ones. + Filtered = [[ID, Chunk] || {ID, Chunk} <- Chunks, ID =/= "CInf", ID =/= "Docs"], + erlang:md5(lists:sort(Filtered)); + {error, beam_lib, {file_error, _, enoent}} -> Msg = io_lib:format("Not a regular file: ~ts\n", [File]), throw({dialyzer_error, Msg}); - true -> - case dialyzer_utils:get_core_from_beam(File) of - {error, Error} -> - throw({dialyzer_error, Error}); - {ok, Core} -> - erlang:md5(term_to_binary(Core)) - end + {error, beam_lib, _} -> + Msg = io_lib:format("Could not compute MD5 for .beam: ~ts\n", [File]), + throw({dialyzer_error, Msg}) end. init_diff_list(RemoveFiles, AddFiles) -> diff --git a/lib/dialyzer/src/dialyzer_races.erl b/lib/dialyzer/src/dialyzer_races.erl index 7fe64c3e11..7602faa21d 100644 --- a/lib/dialyzer/src/dialyzer_races.erl +++ b/lib/dialyzer/src/dialyzer_races.erl @@ -1270,8 +1270,8 @@ filter_named_tables(NamesList) -> [] -> []; [Head|Tail] -> NewHead = - case string:rstr(Head, "()") of - 0 -> [Head]; + case string:find(Head, "()", trailing) of + nomatch -> [Head]; _Other -> [] end, NewHead ++ filter_named_tables(Tail) @@ -1558,8 +1558,8 @@ any_args(StrList) -> case StrList of [] -> false; [Head|Tail] -> - case string:rstr(Head, "()") of - 0 -> any_args(Tail); + case string:find(Head, "()", trailing) of + nomatch -> any_args(Tail); _Other -> true end end. @@ -1765,10 +1765,8 @@ ets_list_args(MaybeList) -> end. ets_list_argtypes(ListStr) -> - ListStr1 = string:strip(ListStr, left, $[), - ListStr2 = string:strip(ListStr1, right, $]), - ListStr3 = string:strip(ListStr2, right, $.), - string:strip(ListStr3, right, $,). + ListStr1 = string:trim(ListStr, leading, "$["), + string:trim(ListStr1, trailing, "$]$.$,"). ets_tuple_args(MaybeTuple) -> case is_tuple(MaybeTuple) of @@ -1810,7 +1808,7 @@ ets_tuple_argtypes2_helper(TupleStr, ElemStr, NestingLevel) -> {[H|ElemStr], NestingLevel, false} end, case Return of - true -> string:tokens(NewElemStr, " |"); + true -> string:lexemes(NewElemStr, " |"); false -> ets_tuple_argtypes2_helper(T, NewElemStr, NewNestingLevel) end @@ -1889,44 +1887,44 @@ format_args_2(StrArgList, Call) -> case Call of whereis -> lists_key_replace(2, StrArgList, - string:tokens(lists:nth(2, StrArgList), " |")); + string:lexemes(lists:nth(2, StrArgList), " |")); register -> lists_key_replace(2, StrArgList, - string:tokens(lists:nth(2, StrArgList), " |")); + string:lexemes(lists:nth(2, StrArgList), " |")); unregister -> lists_key_replace(2, StrArgList, - string:tokens(lists:nth(2, StrArgList), " |")); + string:lexemes(lists:nth(2, StrArgList), " |")); ets_new -> StrArgList1 = lists_key_replace(2, StrArgList, - string:tokens(lists:nth(2, StrArgList), " |")), + string:lexemes(lists:nth(2, StrArgList), " |")), lists_key_replace(4, StrArgList1, - string:tokens(ets_list_argtypes(lists:nth(4, StrArgList1)), " |")); + string:lexemes(ets_list_argtypes(lists:nth(4, StrArgList1)), " |")); ets_lookup -> StrArgList1 = lists_key_replace(2, StrArgList, - string:tokens(lists:nth(2, StrArgList), " |")), + string:lexemes(lists:nth(2, StrArgList), " |")), lists_key_replace(4, StrArgList1, - string:tokens(lists:nth(4, StrArgList1), " |")); + string:lexemes(lists:nth(4, StrArgList1), " |")); ets_insert -> StrArgList1 = lists_key_replace(2, StrArgList, - string:tokens(lists:nth(2, StrArgList), " |")), + string:lexemes(lists:nth(2, StrArgList), " |")), lists_key_replace(4, StrArgList1, ets_tuple_argtypes2( ets_tuple_argtypes1(lists:nth(4, StrArgList1), [], [], 0), [])); mnesia_dirty_read1 -> lists_key_replace(2, StrArgList, - [mnesia_tuple_argtypes(T) || T <- string:tokens( + [mnesia_tuple_argtypes(T) || T <- string:lexemes( lists:nth(2, StrArgList), " |")]); mnesia_dirty_read2 -> lists_key_replace(2, StrArgList, - string:tokens(lists:nth(2, StrArgList), " |")); + string:lexemes(lists:nth(2, StrArgList), " |")); mnesia_dirty_write1 -> lists_key_replace(2, StrArgList, - [mnesia_record_tab(R) || R <- string:tokens( + [mnesia_record_tab(R) || R <- string:lexemes( lists:nth(2, StrArgList), " |")]); mnesia_dirty_write2 -> lists_key_replace(2, StrArgList, - string:tokens(lists:nth(2, StrArgList), " |")); + string:lexemes(lists:nth(2, StrArgList), " |")); function_call -> StrArgList end. @@ -1943,18 +1941,16 @@ format_type(Type, State) -> erl_types:t_to_string(Type, R). mnesia_record_tab(RecordStr) -> - case string:str(RecordStr, "#") =:= 1 of - true -> - "'" ++ - string:sub_string(RecordStr, 2, string:str(RecordStr, "{") - 1) ++ - "'"; - false -> RecordStr + case erl_scan:string(RecordStr) of + {ok, [{'#', _}, {atom, _, Name}|_], _} -> + io_lib:write_string(atom_to_list(Name), $'); + _ -> RecordStr end. mnesia_tuple_argtypes(TupleStr) -> - TupleStr1 = string:strip(TupleStr, left, ${), - [TupleStr2|_T] = string:tokens(TupleStr1, " ,"), - lists:flatten(string:tokens(TupleStr2, " |")). + TupleStr1 = string:trim(TupleStr, leading, "${"), + [TupleStr2|_T] = string:lexemes(TupleStr1, " ,"), + lists:flatten(string:lexemes(TupleStr2, " |")). -spec race_var_map(var_to_map1(), var_to_map2(), dict:dict(), op()) -> dict:dict(). @@ -2237,7 +2233,7 @@ var_type_analysis(FunDefArgs, FunCallTypes, WarnVarArgs, RaceWarnTag, case lists_key_member_lists(Vars, FunVarArgs) of 0 -> [Vars, WVA2, WVA3, WVA4]; N when is_integer(N) -> - NewWVA2 = string:tokens(lists:nth(N + 1, FunVarArgs), " |"), + NewWVA2 = string:lexemes(lists:nth(N + 1, FunVarArgs), " |"), [Vars, NewWVA2, WVA3, WVA4] end; ?WARN_WHEREIS_UNREGISTER -> @@ -2246,7 +2242,7 @@ var_type_analysis(FunDefArgs, FunCallTypes, WarnVarArgs, RaceWarnTag, case lists_key_member_lists(Vars, FunVarArgs) of 0 -> [Vars, WVA2]; N when is_integer(N) -> - NewWVA2 = string:tokens(lists:nth(N + 1, FunVarArgs), " |"), + NewWVA2 = string:lexemes(lists:nth(N + 1, FunVarArgs), " |"), [Vars, NewWVA2] end; ?WARN_ETS_LOOKUP_INSERT -> @@ -2256,7 +2252,7 @@ var_type_analysis(FunDefArgs, FunCallTypes, WarnVarArgs, RaceWarnTag, case lists_key_member_lists(Vars1, FunVarArgs) of 0 -> [Vars1, WVA2]; N1 when is_integer(N1) -> - NewWVA2 = string:tokens(lists:nth(N1 + 1, FunVarArgs), " |"), + NewWVA2 = string:lexemes(lists:nth(N1 + 1, FunVarArgs), " |"), [Vars1, NewWVA2] end, Vars2 = @@ -2286,10 +2282,10 @@ var_type_analysis(FunDefArgs, FunCallTypes, WarnVarArgs, RaceWarnTag, NewWVA2 = case Arity of 1 -> - [mnesia_record_tab(R) || R <- string:tokens( + [mnesia_record_tab(R) || R <- string:lexemes( lists:nth(2, FunVarArgs), " |")]; 2 -> - string:tokens(lists:nth(N + 1, FunVarArgs), " |") + string:lexemes(lists:nth(N + 1, FunVarArgs), " |") end, [Vars, NewWVA2|T] end diff --git a/lib/dialyzer/src/dialyzer_typesig.erl b/lib/dialyzer/src/dialyzer_typesig.erl index d03326ec97..dede475f98 100644 --- a/lib/dialyzer/src/dialyzer_typesig.erl +++ b/lib/dialyzer/src/dialyzer_typesig.erl @@ -418,6 +418,11 @@ traverse(Tree, DefinedVars, State) -> match_fail -> throw(error); raise -> throw(error); bs_init_writable -> {State, t_from_term(<<>>)}; + build_stacktrace -> + V = mk_var(Tree), + Type = erl_bif_types:type(erlang, build_stacktrace, 0), + State1 = state__store_conj(V, sub, Type, State), + {State1, V}; Other -> erlang:error({'Unsupported primop', Other}) end; 'receive' -> @@ -1895,9 +1900,8 @@ solver(Solver, SolveFun) -> ?debug("Solver ~w returned unexpected result:\n ~P\n", [Solver, _R, 60]), throw(error) - catch E:R -> - io:format("Solver ~w failed: ~w:~p\n ~tp\n", - [Solver, E, R, erlang:get_stacktrace()]), + catch E:R:S -> + io:format("Solver ~w failed: ~w:~p\n ~tp\n", [Solver, E, R, S]), throw(error) end. diff --git a/lib/dialyzer/src/dialyzer_utils.erl b/lib/dialyzer/src/dialyzer_utils.erl index 9b8fbc67eb..abd89034f3 100644 --- a/lib/dialyzer/src/dialyzer_utils.erl +++ b/lib/dialyzer/src/dialyzer_utils.erl @@ -120,92 +120,10 @@ get_core_from_beam(File, Opts) -> {error, " Could not get Core Erlang code for: " ++ File ++ "\n"} end; _ -> - deprecated_get_core_from_beam(File, Opts) + {error, " Could not get Core Erlang code for: " ++ File ++ "\n" ++ + " Recompile with +debug_info or analyze starting from source code"} end. -deprecated_get_core_from_beam(File, Opts) -> - case get_abstract_code_from_beam(File) of - error -> - {error, " Could not get abstract code for: " ++ File ++ "\n" ++ - " Recompile with +debug_info or analyze starting from source code"}; - {ok, AbstrCode} -> - case get_compile_options_from_beam(File) of - error -> - {error, " Could not get compile options for: " ++ File ++ "\n" ++ - " Recompile or analyze starting from source code"}; - {ok, CompOpts} -> - case get_core_from_abstract_code(AbstrCode, Opts ++ CompOpts) of - error -> - {error, " Could not get core Erlang code for: " ++ File}; - {ok, _} = Core -> - Core - end - end - end. - -get_abstract_code_from_beam(File) -> - case beam_lib:chunks(File, [abstract_code]) of - {ok, {_, List}} -> - case lists:keyfind(abstract_code, 1, List) of - {abstract_code, {raw_abstract_v1, Abstr}} -> {ok, Abstr}; - _ -> error - end; - _ -> - %% No or unsuitable abstract code. - error - end. - -get_compile_options_from_beam(File) -> - case beam_lib:chunks(File, [compile_info]) of - {ok, {_, List}} -> - case lists:keyfind(compile_info, 1, List) of - {compile_info, CompInfo} -> compile_info_to_options(CompInfo); - _ -> error - end; - _ -> - %% No or unsuitable compile info. - error - end. - -compile_info_to_options(CompInfo) -> - case lists:keyfind(options, 1, CompInfo) of - {options, CompOpts} -> {ok, CompOpts}; - _ -> error - end. - -get_core_from_abstract_code(AbstrCode, Opts) -> - %% We do not want the parse_transforms around since we already - %% performed them. In some cases we end up in trouble when - %% performing them again. - AbstrCode1 = cleanup_parse_transforms(AbstrCode), - %% Remove parse_transforms (and other options) from compile options. - Opts2 = cleanup_compile_options(Opts), - try compile:noenv_forms(AbstrCode1, Opts2 ++ src_compiler_opts()) of - {ok, _, Core} -> {ok, Core}; - _What -> error - catch - error:_ -> error - end. - -cleanup_parse_transforms([{attribute, _, compile, {parse_transform, _}}|Left]) -> - cleanup_parse_transforms(Left); -cleanup_parse_transforms([Other|Left]) -> - [Other|cleanup_parse_transforms(Left)]; -cleanup_parse_transforms([]) -> - []. - -cleanup_compile_options(Opts) -> - lists:filter(fun keep_compile_option/1, Opts). - -%% Using abstract, not asm or core. -keep_compile_option(from_asm) -> false; -keep_compile_option(from_core) -> false; -%% The parse transform will already have been applied, may cause -%% problems if it is re-applied. -keep_compile_option({parse_transform, _}) -> false; -keep_compile_option(warnings_as_errors) -> false; -keep_compile_option(_) -> true. - %% ============================================================================ %% %% Typed Records diff --git a/lib/dialyzer/src/typer.erl b/lib/dialyzer/src/typer.erl index 16b9c8a94a..9d3d9ce438 100644 --- a/lib/dialyzer/src/typer.erl +++ b/lib/dialyzer/src/typer.erl @@ -164,9 +164,9 @@ get_type_info(#analysis{callgraph = CallGraph, CodeServer), Analysis#analysis{callgraph = StrippedCallGraph, trust_plt = NewPlt} catch - error:What -> + error:What:Stacktrace -> fatal_error(io_lib:format("Analysis failed with message: ~tp", - [{What, erlang:get_stacktrace()}])); + [{What, Stacktrace}])); throw:{dialyzer_succ_typing_error, Msg} -> fatal_error(io_lib:format("Analysis failed with message: ~ts", [Msg])) end. diff --git a/lib/dialyzer/test/behaviour_SUITE_data/results/gen_server_incorrect_args b/lib/dialyzer/test/behaviour_SUITE_data/results/gen_server_incorrect_args index 1eb8cd455b..1be0ce0d8c 100644 --- a/lib/dialyzer/test/behaviour_SUITE_data/results/gen_server_incorrect_args +++ b/lib/dialyzer/test/behaviour_SUITE_data/results/gen_server_incorrect_args @@ -1,5 +1,5 @@ gen_server_incorrect_args.erl:3: Undefined callback function handle_cast/2 (behaviour gen_server) gen_server_incorrect_args.erl:3: Undefined callback function init/1 (behaviour gen_server) -gen_server_incorrect_args.erl:7: The inferred return type of handle_call/3 ({'no'} | {'ok'}) has nothing in common with {'noreply',_} | {'noreply',_,'hibernate' | 'infinity' | non_neg_integer()} | {'reply',_,_} | {'stop',_,_} | {'reply',_,_,'hibernate' | 'infinity' | non_neg_integer()} | {'stop',_,_,_}, which is the expected return type for the callback of the gen_server behaviour +gen_server_incorrect_args.erl:7: The inferred return type of handle_call/3 ({'no'} | {'ok'}) has nothing in common with {'noreply',_} | {'noreply',_,'hibernate' | 'infinity' | non_neg_integer() | {'continue',_}} | {'reply',_,_} | {'stop',_,_} | {'reply',_,_,'hibernate' | 'infinity' | non_neg_integer() | {'continue',_}} | {'stop',_,_,_}, which is the expected return type for the callback of the gen_server behaviour gen_server_incorrect_args.erl:7: The inferred type for the 2nd argument of handle_call/3 ('boo' | 'foo') is not a supertype of {pid(),_}, which is expected type for this argument in the callback of the gen_server behaviour diff --git a/lib/dialyzer/test/behaviour_SUITE_data/src/proper/proper_typeserver.erl b/lib/dialyzer/test/behaviour_SUITE_data/src/proper/proper_typeserver.erl index b16075763f..12f6532c0c 100644 --- a/lib/dialyzer/test/behaviour_SUITE_data/src/proper/proper_typeserver.erl +++ b/lib/dialyzer/test/behaviour_SUITE_data/src/proper/proper_typeserver.erl @@ -539,7 +539,7 @@ apply_spec_test({Mod,Fun,_Arity}=MFA, {_Domain,Range}, SpecTimeout, FalsePositiv try apply(Mod, Fun, Args) of X -> {ok, X} catch - X:Y -> {X, Y} + X:Y:S -> {{X, Y}, S} end, case Result of {ok, Z} -> @@ -551,15 +551,15 @@ apply_spec_test({Mod,Fun,_Arity}=MFA, {_Domain,Range}, SpecTimeout, FalsePositiv false -> false end; - Exception when is_function(FalsePositiveMFAs) -> + {Exception, S2} when is_function(FalsePositiveMFAs) -> case FalsePositiveMFAs(MFA, Args, Exception) of true -> true; false -> - error(Exception, erlang:get_stacktrace()) + error(Exception, S2) end; - Exception -> - error(Exception, erlang:get_stacktrace()) + {Exception, S3} -> + error(Exception, S3) end end). diff --git a/lib/dialyzer/test/dialyzer_common.erl b/lib/dialyzer/test/dialyzer_common.erl index 48083a2731..1a8403f486 100644 --- a/lib/dialyzer/test/dialyzer_common.erl +++ b/lib/dialyzer/test/dialyzer_common.erl @@ -221,13 +221,9 @@ get_suites(Dir) -> end. suffix(String, Suffix) -> - case string:rstr(String, Suffix) of - 0 -> no; - Index -> - case string:substr(String, Index) =:= Suffix of - true -> {yes, string:sub_string(String,1,Index-1)}; - false -> no - end + case string:split(String, Suffix, trailing) of + [Prefix,[]] -> {yes, Prefix}; + _ -> no end. -spec create_suite(string()) -> 'ok'. diff --git a/lib/dialyzer/test/opaque_SUITE_data/src/proper/proper_typeserver.erl b/lib/dialyzer/test/opaque_SUITE_data/src/proper/proper_typeserver.erl index 1677b4efb8..529f9fba72 100644 --- a/lib/dialyzer/test/opaque_SUITE_data/src/proper/proper_typeserver.erl +++ b/lib/dialyzer/test/opaque_SUITE_data/src/proper/proper_typeserver.erl @@ -533,7 +533,7 @@ apply_spec_test({Mod,Fun,_Arity}=MFA, {_Domain,Range}, SpecTimeout, FalsePositiv try apply(Mod,Fun,Args) of X -> {ok, X} catch - X:Y -> {X, Y} + X:Y:S -> {{X, Y}, S} end, case Result of {ok, Z} -> @@ -545,15 +545,15 @@ apply_spec_test({Mod,Fun,_Arity}=MFA, {_Domain,Range}, SpecTimeout, FalsePositiv false -> false end; - Exception when is_function(FalsePositiveMFAs) -> + {Exception, S2} when is_function(FalsePositiveMFAs) -> case FalsePositiveMFAs(MFA, Args, Exception) of true -> true; false -> - error(Exception, erlang:get_stacktrace()) + error(Exception, S2) end; - Exception -> - error(Exception, erlang:get_stacktrace()) + {Exception, S3} -> + error(Exception, S3) end end). diff --git a/lib/dialyzer/test/options1_SUITE_data/src/compiler/beam_validator.erl b/lib/dialyzer/test/options1_SUITE_data/src/compiler/beam_validator.erl index 8fe43163f6..ea92613781 100644 --- a/lib/dialyzer/test/options1_SUITE_data/src/compiler/beam_validator.erl +++ b/lib/dialyzer/test/options1_SUITE_data/src/compiler/beam_validator.erl @@ -174,7 +174,7 @@ validate_error(Error, Name, Ar) -> -endif. validate_error_1(Error, Name, Ar) -> {{'_',Name,Ar}, - {internal_error,'_',{Error,erlang:get_stacktrace()}}}. + {internal_error,'_',{Error,[]}}}. -record(st, %Emulation state {x=init_regs(0, term), %x register info. 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 09e310530d..af49ceff72 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 @@ -2051,7 +2051,7 @@ display_pid_info(Pid) -> Other end, Reds = fetch(reductions, Info), - LM = length(fetch(messages, Info)), + LM = fetch(message_queue_len, Info), pformat(io_lib:format("~p", [Pid]), io_lib:format("~p", [Call]), io_lib:format("~p", [Curr]), Reds, LM) diff --git a/lib/dialyzer/test/small_SUITE_data/results/chars b/lib/dialyzer/test/small_SUITE_data/results/chars index 2c1f8f8d17..72fbdb4528 100644 --- a/lib/dialyzer/test/small_SUITE_data/results/chars +++ b/lib/dialyzer/test/small_SUITE_data/results/chars @@ -1,4 +1,4 @@ -chars.erl:29: Invalid type specification for function chars:f/1. The success typing is (#{'b':=50}) -> 'ok' -chars.erl:32: Function t1/0 has no local return -chars.erl:32: The call chars:f(#{'b':=50}) breaks the contract (#{'a':=49,'b'=>50,'c'=>51}) -> 'ok' +chars.erl:37: Invalid type specification for function chars:f/1. The success typing is (#{'b':=50}) -> 'ok' +chars.erl:40: Function t1/0 has no local return +chars.erl:40: The call chars:f(#{'b':=50}) breaks the contract (#{'a':=49,'b'=>50,'c'=>51}) -> 'ok' diff --git a/lib/dialyzer/test/small_SUITE_data/results/extra_range b/lib/dialyzer/test/small_SUITE_data/results/extra_range new file mode 100644 index 0000000000..ec50c95c4e --- /dev/null +++ b/lib/dialyzer/test/small_SUITE_data/results/extra_range @@ -0,0 +1,4 @@ + +extra_range.erl:29: The pattern 'ok' can never match the type 'error' +extra_range.erl:43: The pattern 'no' can never match the type 'maybe' | 'yes' +extra_range.erl:58: The pattern 'maybe' can never match the type 'no' | 'yes' diff --git a/lib/dialyzer/test/small_SUITE_data/results/fun_arity b/lib/dialyzer/test/small_SUITE_data/results/fun_arity index e916b2483f..8b7a538758 100644 --- a/lib/dialyzer/test/small_SUITE_data/results/fun_arity +++ b/lib/dialyzer/test/small_SUITE_data/results/fun_arity @@ -1,37 +1,37 @@ -fun_arity.erl:100: Fun application will fail since _@c1 :: fun(() -> any()) is not a function of arity 1 +fun_arity.erl:100: Fun application will fail since _1 :: fun(() -> any()) is not a function of arity 1 fun_arity.erl:100: Function 'Mfa_0_ko'/1 has no local return -fun_arity.erl:104: Fun application will fail since _@c1 :: fun((_) -> any()) is not a function of arity 0 +fun_arity.erl:104: Fun application will fail since _1 :: fun((_) -> any()) is not a function of arity 0 fun_arity.erl:104: Function 'Mfa_1_ko'/1 has no local return -fun_arity.erl:111: Fun application will fail since _@c1 :: fun(() -> any()) is not a function of arity 1 +fun_arity.erl:111: Fun application will fail since _1 :: fun(() -> any()) is not a function of arity 1 fun_arity.erl:111: Function mFa_0_ko/1 has no local return -fun_arity.erl:115: Fun application will fail since _@c1 :: fun((_) -> any()) is not a function of arity 0 +fun_arity.erl:115: Fun application will fail since _1 :: fun((_) -> any()) is not a function of arity 0 fun_arity.erl:115: Function mFa_1_ko/1 has no local return -fun_arity.erl:122: Fun application will fail since _@c2 :: fun(() -> any()) is not a function of arity 1 +fun_arity.erl:122: Fun application will fail since _2 :: fun(() -> any()) is not a function of arity 1 fun_arity.erl:122: Function 'MFa_0_ko'/2 has no local return -fun_arity.erl:126: Fun application will fail since _@c2 :: fun((_) -> any()) is not a function of arity 0 +fun_arity.erl:126: Fun application will fail since _2 :: fun((_) -> any()) is not a function of arity 0 fun_arity.erl:126: Function 'MFa_1_ko'/2 has no local return -fun_arity.erl:35: Fun application will fail since _@c0 :: fun(() -> 'ok') is not a function of arity 1 +fun_arity.erl:35: Fun application will fail since _0 :: fun(() -> 'ok') is not a function of arity 1 fun_arity.erl:35: Function f_0_ko/0 has no local return -fun_arity.erl:39: Fun application will fail since _@c0 :: fun((_) -> 'ok') is not a function of arity 0 +fun_arity.erl:39: Fun application will fail since _0 :: fun((_) -> 'ok') is not a function of arity 0 fun_arity.erl:39: Function f_1_ko/0 has no local return -fun_arity.erl:48: Fun application will fail since _@c0 :: fun(() -> 'ok') is not a function of arity 1 +fun_arity.erl:48: Fun application will fail since _0 :: fun(() -> 'ok') is not a function of arity 1 fun_arity.erl:48: Function fa_0_ko/0 has no local return -fun_arity.erl:53: Fun application will fail since _@c0 :: fun((_) -> 'ok') is not a function of arity 0 +fun_arity.erl:53: Fun application will fail since _0 :: fun((_) -> 'ok') is not a function of arity 0 fun_arity.erl:53: Function fa_1_ko/0 has no local return -fun_arity.erl:63: Fun application will fail since _@c0 :: fun(() -> any()) is not a function of arity 1 +fun_arity.erl:63: Fun application will fail since _0 :: fun(() -> any()) is not a function of arity 1 fun_arity.erl:63: Function mfa_0_ko/0 has no local return -fun_arity.erl:68: Fun application will fail since _@c0 :: fun((_) -> any()) is not a function of arity 0 +fun_arity.erl:68: Fun application will fail since _0 :: fun((_) -> any()) is not a function of arity 0 fun_arity.erl:68: Function mfa_1_ko/0 has no local return -fun_arity.erl:76: Fun application will fail since _@c0 :: fun(() -> any()) is not a function of arity 1 +fun_arity.erl:76: Fun application will fail since _0 :: fun(() -> any()) is not a function of arity 1 fun_arity.erl:76: Function mfa_ne_0_ko/0 has no local return fun_arity.erl:78: Function mf_ne/0 will never be called -fun_arity.erl:81: Fun application will fail since _@c0 :: fun((_) -> any()) is not a function of arity 0 +fun_arity.erl:81: Fun application will fail since _0 :: fun((_) -> any()) is not a function of arity 0 fun_arity.erl:81: Function mfa_ne_1_ko/0 has no local return fun_arity.erl:83: Function mf_ne/1 will never be called -fun_arity.erl:89: Fun application will fail since _@c0 :: fun(() -> any()) is not a function of arity 1 +fun_arity.erl:89: Fun application will fail since _0 :: fun(() -> any()) is not a function of arity 1 fun_arity.erl:89: Function mfa_nd_0_ko/0 has no local return fun_arity.erl:90: Call to missing or unexported function fun_arity:mf_nd/0 -fun_arity.erl:93: Fun application will fail since _@c0 :: fun((_) -> any()) is not a function of arity 0 +fun_arity.erl:93: Fun application will fail since _0 :: fun((_) -> any()) is not a function of arity 0 fun_arity.erl:93: Function mfa_nd_1_ko/0 has no local return fun_arity.erl:94: Call to missing or unexported function fun_arity:mf_nd/1 diff --git a/lib/dialyzer/test/small_SUITE_data/results/maps_sum b/lib/dialyzer/test/small_SUITE_data/results/maps_sum index bd192bdb93..b29ac77d88 100644 --- a/lib/dialyzer/test/small_SUITE_data/results/maps_sum +++ b/lib/dialyzer/test/small_SUITE_data/results/maps_sum @@ -1,4 +1,4 @@ -maps_sum.erl:15: Invalid type specification for function maps_sum:wrong1/1. The success typing is (map()) -> any() +maps_sum.erl:15: Invalid type specification for function maps_sum:wrong1/1. The success typing is (maps:iterator() | map()) -> any() maps_sum.erl:26: Function wrong2/1 has no local return maps_sum.erl:27: The call lists:foldl(fun((_,_,_) -> any()),0,Data::any()) will never return since it differs in the 1st argument from the success typing arguments: (fun((_,_) -> any()),any(),[any()]) diff --git a/lib/dialyzer/test/small_SUITE_data/results/stacktrace b/lib/dialyzer/test/small_SUITE_data/results/stacktrace new file mode 100644 index 0000000000..fd60881953 --- /dev/null +++ b/lib/dialyzer/test/small_SUITE_data/results/stacktrace @@ -0,0 +1,5 @@ + +stacktrace.erl:11: The pattern {'a', 'b'} can never match the type [{atom(),atom(),[any()] | byte(),[{'file',string()} | {'line',pos_integer()}]}] +stacktrace.erl:19: The pattern ['a', 'b'] can never match the type [{atom(),atom(),[any()] | byte(),[{'file',string()} | {'line',pos_integer()}]}] +stacktrace.erl:44: The pattern {'a', 'b'} can never match the type [{atom(),atom(),[any()] | byte(),[{'file',string()} | {'line',pos_integer()}]}] +stacktrace.erl:53: The pattern ['a', 'b'] can never match the type [{atom(),atom(),[any()] | byte(),[{'file',string()} | {'line',pos_integer()}]}] diff --git a/lib/dialyzer/test/small_SUITE_data/src/chars.erl b/lib/dialyzer/test/small_SUITE_data/src/chars.erl index 1e9c8ab6b9..62b90cf54d 100644 --- a/lib/dialyzer/test/small_SUITE_data/src/chars.erl +++ b/lib/dialyzer/test/small_SUITE_data/src/chars.erl @@ -12,17 +12,25 @@ -spec t() -> $0-$0..$9-$0| $?. t() -> - c(#r{f = $z - 3}), + r(#r{f = $z - 3}), + r(#r{f = 97}), + c($/), c($z - 3), c($B). -spec c(cs()) -> $3-$0..$9-$0. - -c($A + 1) -> 2; +c($A + 1) -> $9-$0; c(C) -> case C of - $z - 3 -> 3; - #r{f = $z - 3} -> 7 + $z - 3 -> $3-$0; + _ -> $7-$0 + end. + +-spec r(#r{f :: $a..$z}) -> ok | error. +r(R) -> + case R of + #r{f = $z - 3} -> error; + _ -> ok end. %% Display contract with character in warning: diff --git a/lib/dialyzer/test/small_SUITE_data/src/extra_range.erl b/lib/dialyzer/test/small_SUITE_data/src/extra_range.erl new file mode 100644 index 0000000000..9d6ba89c95 --- /dev/null +++ b/lib/dialyzer/test/small_SUITE_data/src/extra_range.erl @@ -0,0 +1,59 @@ +%% Test that a spec containing more items than actually returned +%% (whether by accident or by benign overspeccing) does not prevent +%% detection of impossible matches. + +-module(extra_range). + +-export([t1/2, t2/2, t3/2, t4/2]). + +-dialyzer([no_return]). + +%% this spec matches the behaviour of the code +-spec normal(integer()) -> ok | error. +normal(1) -> ok; +normal(2) -> error. + +t1(X, Y) when is_integer(X), is_integer(Y) -> + ok = normal(X), + error = normal(Y), + ok. + + +%% this spec has a typo, which should cause anyone trying to match on +%% `ok = typo(X)' to get a warning, because `ok' is not in the spec +-spec typo(integer()) -> ook | error. +typo(1) -> ok; +typo(2) -> error. + +t2(X, Y) when is_integer(X), is_integer(Y) -> + ok = typo(X), % warning expected - not allowed according to spec + error = typo(Y), + ok. + + +%% this is overspecified, and should cause a warning for trying +%% to match on `no = over(X)', because it cannot succeed and either +%% the spec should be updated or the code should be extended +-spec over(integer()) -> yes | no | maybe. +over(1) -> yes; +over(_) -> maybe. + +t3(X, Y) when is_integer(X), is_integer(Y) -> + yes = over(X), + no = over(Y), % warning expected - spec or code needs fixing + maybe = over(X + Y), + ok. + + +%% this is underspecified, which should cause anyone trying to match on +%% `maybe = under(X)' to get a warning, because `maybe' is not in the spec +-spec under(integer()) -> yes | no. +under(1) -> yes; +under(2) -> no; +under(_) -> maybe. + +t4(X, Y) when is_integer(X), is_integer(Y) -> + yes = under(X), + no = under(Y), + maybe = under(X + Y), % warning expected - not in spec + ok. diff --git a/lib/dialyzer/test/small_SUITE_data/src/stacktrace.erl b/lib/dialyzer/test/small_SUITE_data/src/stacktrace.erl new file mode 100644 index 0000000000..de79e710e9 --- /dev/null +++ b/lib/dialyzer/test/small_SUITE_data/src/stacktrace.erl @@ -0,0 +1,73 @@ +-module(stacktrace). + +%% Check the stacktrace variable introduced in Erlang/OTP 21.0 + +-export([t1/0, t2/0, t3/0, t4/0, s1/0, s2/0, s3/0, s4/0]). + +t1() -> + try foo:bar() + catch + E:P:S -> + {a,b} = S, % can never match + {E, P} + end. + +t2() -> + try foo:bar() + catch + E:P:S -> + [a,b] = S, % can never match + {E, P} + end. + +t3() -> + try foo:bar() + catch + E:P:S -> + [{m,f,[],[]}] = S, + {E, P} + end. + +t4() -> + try foo:bar() + catch + E:P:S -> + [{m,f,1,[{file,"tjo"},{line,95}]}] = S, + {E, P} + end. + +s1() -> + try foo:bar() + catch + E:P -> + S = erlang:get_stacktrace(), + {a,b} = S, % can never match + {E, P} + end. + +s2() -> + try foo:bar() + catch + E:P -> + S = erlang:get_stacktrace(), + [a,b] = S, % can never match + {E, P} + end. + +s3() -> + try foo:bar() + catch + E:P -> + S = erlang:get_stacktrace(), + [{m,f,[],[]}] = S, + {E, P} + end. + +s4() -> + try foo:bar() + catch + E:P -> + S = erlang:get_stacktrace(), + [{m,f,1,[{file,"tjo"},{line,95}]}] = S, + {E, P} + end. diff --git a/lib/edoc/doc/src/Makefile b/lib/edoc/doc/src/Makefile index ca9ea66e3c..71de42795a 100644 --- a/lib/edoc/doc/src/Makefile +++ b/lib/edoc/doc/src/Makefile @@ -54,9 +54,10 @@ XML_NOTES_FILES = notes.xml BOOK_FILES = book.xml XML_FILES=\ - $(BOOK_FILES) $(XML_CHAPTER_FILES) \ - $(XML_PART_FILES) $(XML_REF3_FILES) $(XML_APPLICATION_FILES) \ - $(XML_NOTES_FILES) + $(BOOK_FILES) $(XML_APPLICATION_FILES) \ + $(XML_PART_FILES) $(XML_NOTES_FILES) + +XML_GEN_FILES=$(XML_REF3_FILES:%=$(XMLDIR)/%) $(XML_CHAPTER_FILES:%=$(XMLDIR)/%) # ---------------------------------------------------- INFO_FILE = ../../info @@ -101,11 +102,11 @@ html: gifs $(HTML_REF_MAN_FILE) man: $(MAN3_FILES) -$(XML_REF3_FILES): - escript $(DOCGEN)/priv/bin/xml_from_edoc.escript -def vsn $(EDOC_VSN) -i $(ERL_TOP)/lib/edoc/include $(SRC_DIR)/$(@:%.xml=%.erl) +$(XML_REF3_FILES:%=$(XMLDIR)/%): + $(gen_verbose)escript $(DOCGEN)/priv/bin/xml_from_edoc.escript -def vsn $(EDOC_VSN) -i $(ERL_TOP)/lib/edoc/include -dir $(XMLDIR) $(SRC_DIR)/$(@:$(XMLDIR)/%.xml=%.erl) -$(XML_CHAPTER_FILES): ../overview.edoc - escript $(DOCGEN)/priv/bin/xml_from_edoc.escript -def vsn $(EDOC_VSN) -chapter ../overview.edoc +$(XML_CHAPTER_FILES:%=$(XMLDIR)/%): ../overview.edoc + $(gen_verbose)escript $(DOCGEN)/priv/bin/xml_from_edoc.escript -def vsn $(EDOC_VSN) -chapter -dir $(XMLDIR) $< gifs: $(GIF_FILES:%=$(HTMLDIR)/%) diff --git a/lib/edoc/src/edoc_doclet.erl b/lib/edoc/src/edoc_doclet.erl index 0e084e619e..f55cffe158 100644 --- a/lib/edoc/src/edoc_doclet.erl +++ b/lib/edoc/src/edoc_doclet.erl @@ -255,7 +255,7 @@ modules_frame(Dir, Ms, Title, CSS) -> ?NL, {table, [{width, "100%"}, {border, 0}, {summary, "list of modules"}], - lists:concat( + lists:append( [[?NL, {tr, [{td, [], [{a, [{href, module_ref(M)}, @@ -448,7 +448,7 @@ application_frame(Dir, Apps, Title, CSS) -> {h2, ["Applications"]}, ?NL, {table, [{width, "100%"}, {border, 0}], - lists:concat( + lists:append( [[{tr, [{td, [], [{a, [{href,app_ref(Path,App)}, {target,"_top"}], [App]}]}]}] diff --git a/lib/edoc/src/edoc_layout.erl b/lib/edoc/src/edoc_layout.erl index eafab0588e..baa147410b 100644 --- a/lib/edoc/src/edoc_layout.erl +++ b/lib/edoc/src/edoc_layout.erl @@ -608,7 +608,7 @@ etypef([Cs | L], St, O, R, Opts) -> app_fix(L, Opts) -> try {"//" ++ R1,L2} = app_fix1(L, 1), - [App, Mod] = string:tokens(R1, "/"), + [App, Mod] = string:lexemes(R1, "/"), "//" ++ atom(App, Opts) ++ "/" ++ atom(Mod, Opts) ++ L2 catch _:_ -> L end. @@ -1120,13 +1120,13 @@ ot_integer(E) -> {integer,0,list_to_integer(get_attrval(value, E))}. ot_range(E) -> - [I1, I2] = string:tokens(get_attrval(value, E), "."), + [I1, I2] = string:lexemes(get_attrval(value, E), "."), {type,0,range,[{integer,0,list_to_integer(I1)}, {integer,0,list_to_integer(I2)}]}. ot_binary(E) -> {Base, Unit} = - case string:tokens(get_attrval(value, E), ",:*><") of + case string:lexemes(get_attrval(value, E), ",:*><") of [] -> {0, 0}; ["_",B] -> diff --git a/lib/edoc/src/edoc_specs.erl b/lib/edoc/src/edoc_specs.erl index 4e45e42f20..7b451c43f8 100644 --- a/lib/edoc/src/edoc_specs.erl +++ b/lib/edoc/src/edoc_specs.erl @@ -83,7 +83,7 @@ spec(Form, Clause) -> %% the given Erlang spec and an empty list of arguments. dummy_spec(Form) -> {#t_name{name = Name}, Arity, TypeSpecs} = get_spec(Form), - As = string:join(lists:duplicate(Arity, "_X"), ","), + As = lists:join(",", lists:duplicate(Arity, "_X")), S = lists:flatten(io_lib:format("~p(~s) -> true\n", [Name, As])), #tag{name = spec, line = get_line(element(2, hd(TypeSpecs))), origin = code, data = S}. diff --git a/lib/eldap/src/eldap.erl b/lib/eldap/src/eldap.erl index 625309271b..2b84872b92 100644 --- a/lib/eldap/src/eldap.erl +++ b/lib/eldap/src/eldap.erl @@ -1368,9 +1368,9 @@ rm_leading_slash(Tail) -> Tail. parse_attributes([$?|Tail]) -> case split_string(Tail,$?) of {[],Attributes} -> - {[],{attributes,string:tokens(Attributes,",")}}; + {[],{attributes,string:lexemes(Attributes,",")}}; {Attributes,Rest} -> - {Rest,{attributes,string:tokens(Attributes,",")}} + {Rest,{attributes,string:lexemes(Attributes,",")}} end. parse_hostport(Str) -> diff --git a/lib/erl_docgen/priv/bin/codeline_preprocessing.escript b/lib/erl_docgen/priv/bin/codeline_preprocessing.escript index 8e1e35bcdd..67966b79e6 100755 --- a/lib/erl_docgen/priv/bin/codeline_preprocessing.escript +++ b/lib/erl_docgen/priv/bin/codeline_preprocessing.escript @@ -30,7 +30,7 @@ %% Function: main/1 %% Description: %%---------------------------------------------------------------------- -main([InFile, OutFile]) -> +main([CPath, InFile, OutFile]) -> InDev = case file:open(InFile, [read]) of {ok,ID} -> @@ -38,7 +38,6 @@ main([InFile, OutFile]) -> _ -> halt(5) end, - CPath=filename:dirname(InFile), OutDev = case file:open(OutFile, [write]) of {ok,OD} -> diff --git a/lib/erl_docgen/priv/bin/github_link.escript b/lib/erl_docgen/priv/bin/github_link.escript new file mode 100755 index 0000000000..1b36fca202 --- /dev/null +++ b/lib/erl_docgen/priv/bin/github_link.escript @@ -0,0 +1,51 @@ +#!/usr/bin/env escript +%% -*- erlang -*- +%% %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% +%%---------------------------------------------------------------------- +%% File : github_link.escript +%% +%% Created : 12 Dec 2017 by Lukas Larsson +%%---------------------------------------------------------------------- + +main([In, Filename, Sha, Out]) -> + {ok, Bin} = file:read_file(In), + + TagsToAnnotate = ["description", "func", "datatype", "section"], + + Subs = subs(TagsToAnnotate, Filename, Sha, re:split(Bin,[$\n])), + + file:write_file(Out, Subs). + +subs([], _, _, Bin) -> + lists:join("\n", Bin); +subs([Pat|Pats], Fn, Sha, Bin) -> + subs(Pats, Fn, Sha, sub(Bin, Pat, Fn, Sha)). + +sub(Bin, Pat, Fn, Sha) -> + sub(Bin, Pat, Fn, Sha, 1). +sub([], _Pat, _Fn, _Sha, _Cnt) -> + []; +sub([H|T], Pat, Fn, Sha, Cnt) -> + %% We use the maint branch here, it is not as exact as the tag, + %% but it is the best we can do as github does not allow doing + %% pullrequests on anything but branches. + [re:replace(H,["<",Pat,">"], + ["<",Pat," ghlink=\"maint/",Fn,"#L", + integer_to_list(Cnt),"\">"],[{return,list}]) | + sub(T, Pat, Fn, Sha, Cnt+1)]. diff --git a/lib/erl_docgen/priv/bin/xml_from_edoc.escript b/lib/erl_docgen/priv/bin/xml_from_edoc.escript index b930ae3818..b0e3764fae 100755 --- a/lib/erl_docgen/priv/bin/xml_from_edoc.escript +++ b/lib/erl_docgen/priv/bin/xml_from_edoc.escript @@ -28,6 +28,7 @@ %% Records %%====================================================================== -record(args, {suffix=".xml", + dir=".", layout=docgen_edoc_xml_cb, def=[], includes=[], @@ -85,7 +86,7 @@ module(File, Args) -> {app_default, "OTPROOT"}, {file_suffix, Args#args.suffix}, - {dir, "."}, + {dir, Args#args.dir}, {layout, Args#args.layout}], edoc:file(File, Opts); false -> @@ -118,7 +119,7 @@ users_guide(File, Args) -> Text = edoc_lib:run_layout(F, Opts), OutFile = "chapter" ++ Args#args.suffix, - edoc_lib:write_file(Text, ".", OutFile, Encoding); + edoc_lib:write_file(Text, Args#args.dir, OutFile, Encoding); false -> io:format("~s: not a regular file\n", [File]), usage() @@ -139,6 +140,8 @@ parse(["-def", Key, Val |RawOpts], Type, Args) -> parse(["-i", Dir |RawOpts], Type, Args) -> Args2 = Args#args{includes=Args#args.includes++[Dir]}, parse(RawOpts, Type, Args2); +parse(["-dir", Dir |RawOpts], Type, Args) -> + parse(RawOpts, Type, Args#args{dir=Dir}); parse(["-preprocess", Bool |RawOpts], Type, Args) when Bool == "true"; Bool == "false" -> parse(RawOpts, Type, Args#args{preprocess=list_to_atom(Bool)}); diff --git a/lib/erl_docgen/priv/css/otp_doc.css b/lib/erl_docgen/priv/css/otp_doc.css index 844aad2945..34c6befb0e 100644 --- a/lib/erl_docgen/priv/css/otp_doc.css +++ b/lib/erl_docgen/priv/css/otp_doc.css @@ -242,8 +242,25 @@ th { font-size: small; } -h3>a{ - color: #1a1a1a !important; +.title_link { + color: #1a1a1a !important; + outline: none; +} + +.ghlink { + margin-left: -2.7em; /* .pencil.font-size + .pencil.padding.left + .pencil.padding.right = 2.7 */ + visibility: hidden; +} + +.pencil:before { + transform: rotateZ(90deg); + content: "\270E"; + color: #1a1a1a !important; + font-weight: bold; + font-size: 1.5em; + padding: .3em .6em .6em; + line-height: 1em; + font-family: mono; } hr{ diff --git a/lib/erl_docgen/priv/dtd/chapter.dtd b/lib/erl_docgen/priv/dtd/chapter.dtd index 8d940b90f7..3e9113d798 100644 --- a/lib/erl_docgen/priv/dtd/chapter.dtd +++ b/lib/erl_docgen/priv/dtd/chapter.dtd @@ -35,3 +35,4 @@ <!ELEMENT section (marker*,title, (%block;|quote|warning|note|dont|do|br|image|marker| table|section)*) > +<!ATTLIST section ghlink CDATA #IMPLIED> diff --git a/lib/erl_docgen/priv/dtd/common.image.dtd b/lib/erl_docgen/priv/dtd/common.image.dtd index d97057590e..138da3609b 100644 --- a/lib/erl_docgen/priv/dtd/common.image.dtd +++ b/lib/erl_docgen/priv/dtd/common.image.dtd @@ -18,5 +18,7 @@ $Id$ --> <!ELEMENT image (icaption) > -<!ATTLIST image file CDATA #REQUIRED > +<!ATTLIST image + file CDATA #REQUIRED + width CDATA #IMPLIED > <!ELEMENT icaption (#PCDATA) > diff --git a/lib/erl_docgen/priv/dtd/common.refs.dtd b/lib/erl_docgen/priv/dtd/common.refs.dtd index 4f87007a09..07c876a17f 100644 --- a/lib/erl_docgen/priv/dtd/common.refs.dtd +++ b/lib/erl_docgen/priv/dtd/common.refs.dtd @@ -26,8 +26,10 @@ %common.header; <!ELEMENT description (%block;|quote|br|marker|warning|note|dont|do)* > +<!ATTLIST description ghlink CDATA #IMPLIED> <!ELEMENT funcs (func)+ > <!ELEMENT func (name+,fsummary,(type|type_desc)*,desc?) > +<!ATTLIST func ghlink CDATA #IMPLIED> <!-- ELEMENT name is defined in each ref dtd --> <!ELEMENT fsummary (#PCDATA|c|i|em|anno)* > <!ELEMENT type (v,d?)* > @@ -42,8 +44,11 @@ <!ELEMENT email (#PCDATA) > <!ELEMENT section (marker*,title,(%block;|quote|br|marker| warning|note|dont|do|section)*) > -<!ELEMENT datatypes (datatype)+ > +<!ATTLIST section ghlink CDATA #IMPLIED> +<!ELEMENT datatypes (datatype_title?,datatype)+ > +<!ELEMENT datatype_title (#PCDATA) > <!ELEMENT datatype (name+,desc?) > +<!ATTLIST datatype ghlink CDATA #IMPLIED> <!ELEMENT type_desc (#PCDATA|anno|c|seealso)* > <!ATTLIST type_desc variable CDATA #IMPLIED name CDATA #IMPLIED> diff --git a/lib/erl_docgen/priv/dtd/erlref.dtd b/lib/erl_docgen/priv/dtd/erlref.dtd index 615b88b61a..78d6771f52 100644 --- a/lib/erl_docgen/priv/dtd/erlref.dtd +++ b/lib/erl_docgen/priv/dtd/erlref.dtd @@ -33,4 +33,5 @@ <!ATTLIST name name CDATA #IMPLIED arity CDATA #IMPLIED clause_i CDATA #IMPLIED + anchor CDATA #IMPLIED n_vars CDATA #IMPLIED> diff --git a/lib/erl_docgen/priv/xsl/db_html.xsl b/lib/erl_docgen/priv/xsl/db_html.xsl index 75614392fb..a0a922216b 100644 --- a/lib/erl_docgen/priv/xsl/db_html.xsl +++ b/lib/erl_docgen/priv/xsl/db_html.xsl @@ -3,7 +3,7 @@ # # %CopyrightBegin% # - # Copyright Ericsson AB 2009-2017. All Rights Reserved. + # Copyright Ericsson AB 2009-2018. 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. @@ -54,6 +54,24 @@ <func:result select="$result"/> </func:function> + <func:function name="erl:lower-case"> + <xsl:param name="str"/> + + <xsl:variable name="uppercase" select="'ABCDEFGHIJKLMNOPQRSTUVWXYZ'"/> + <xsl:variable name="lowercase" select="'abcdefghijklmnopqrstuvwxyz'"/> + + <xsl:variable name="result"> + <xsl:value-of select="translate($str, $uppercase, $lowercase)"/> + </xsl:variable> + + <func:result select="$result"/> + </func:function> + + <func:function name="erl:to-link"> + <xsl:param name="text"/> + <func:result select="translate(erl:lower-case($text),'?: /()" ','--------')"/> + </func:function> + <!-- Used from template menu.funcs to sort a module's functions for the lefthand index list, from the module's .xml file. Returns a value on which to sort the entity in question (a <name> element). @@ -172,6 +190,7 @@ <xsl:template name="spec_name"> <xsl:variable name="name" select="@name"/> <xsl:variable name="arity" select="@arity"/> + <xsl:variable name="anchor" select="@anchor"/> <xsl:variable name="spec0"> <xsl:call-template name="find_spec"/> </xsl:variable> @@ -198,10 +217,16 @@ </xsl:otherwise> </xsl:choose> + <!-- Insert an anchor for "anchor" attribute --> + <xsl:if test="string-length($anchor) > 0"> + <a name="{$anchor}"></a> + </xsl:if> + <xsl:variable name="global_types" select="ancestor::erlref/datatypes"/> <xsl:variable name="local_types" select="../type[string-length(@name) > 0]"/> <xsl:apply-templates select="$spec/contract/clause/head"> + <xsl:with-param name="ghlink" select="ancestor-or-self::*[@ghlink]/@ghlink"/> <xsl:with-param name="local_types" select="$local_types"/> <xsl:with-param name="global_types" select="$global_types"/> </xsl:apply-templates> @@ -210,9 +235,17 @@ </xsl:template> <xsl:template match="head"> + <xsl:param name="ghlink"/> <xsl:param name="local_types"/> <xsl:param name="global_types"/> - <div class="bold_code func-head"> + <xsl:variable name="id" select="concat(concat(concat(concat(../../../name,'-'),../../../arity),'-'),generate-id(.))"/> + <div class="bold_code func-head" + onMouseOver="document.getElementById('ghlink-{$id}').style.visibility = 'visible';" + onMouseOut="document.getElementById('ghlink-{$id}').style.visibility = 'hidden';"> + <xsl:call-template name="ghlink"> + <xsl:with-param name="ghlink" select="$ghlink"/> + <xsl:with-param name="id" select="$id"/> + </xsl:call-template> <xsl:apply-templates mode="local_type"> <xsl:with-param name="local_types" select="$local_types"/> <xsl:with-param name="global_types" select="$global_types"/> @@ -397,18 +430,37 @@ <!-- Datatypes --> <xsl:template match="datatypes"> - <h3> - <a name="data-types" href="#data-types"><xsl:text>Data Types</xsl:text></a> - </h3> - <div class="data-types-body"> - <xsl:apply-templates/> - </div> + <xsl:call-template name="h3_title_link"> + <xsl:with-param name="title">Data Types</xsl:with-param> + </xsl:call-template> + <xsl:apply-templates/> + </xsl:template> + + <!-- Datatype Title, is the really needed? not used by anything --> + <xsl:template match="datatype_title"> + <xsl:variable name="title" select="."/> + <h4> + <xsl:call-template name="title_link"> + <xsl:with-param name="title"><xsl:apply-templates/></xsl:with-param> + <xsl:with-param name="link" select="$title"/> + </xsl:call-template> + </h4> </xsl:template> <!-- Datatype --> <xsl:template match="datatype"> - <div class="data-type-name"><xsl:apply-templates select="name"/></div> - <div class="data-type-desc"><xsl:apply-templates select="desc"/></div> + <xsl:variable name="id" select="concat('type-',name/@name)"/> + <div class="data-types-body"> + <div class="data-type-name" + onMouseOver="document.getElementById('ghlink-{$id}').style.visibility = 'visible';" + onMouseOut="document.getElementById('ghlink-{$id}').style.visibility = 'hidden';"> + <xsl:call-template name="ghlink"> + <xsl:with-param name="id" select="$id"/> + </xsl:call-template> + <xsl:apply-templates select="name"/> + </div> + <div class="data-type-desc"><xsl:apply-templates select="desc"/></div> + </div> </xsl:template> <!-- The "mode" attribute of apply has been used to separate the case @@ -890,7 +942,7 @@ <!-- Header --> <xsl:template match="header"/> - + <!-- Section/Title --> <xsl:template match="section/title"/> @@ -903,10 +955,12 @@ <xsl:for-each select="marker"> <xsl:call-template name="marker-before-title"/> </xsl:for-each> - <a name="{generate-id(title)}"> - <xsl:value-of select="$chapnum"/>.<xsl:number/>  - <xsl:value-of select="title"/> - </a> + <xsl:call-template name="title_link"> + <xsl:with-param name="title"> + <xsl:value-of select="$chapnum"/>.<xsl:number/>  + <xsl:value-of select="title"/> + </xsl:with-param> + </xsl:call-template> </h3> <xsl:apply-templates> <xsl:with-param name="chapnum" select="$chapnum"/> @@ -923,7 +977,9 @@ <xsl:call-template name="marker-before-title"/> </xsl:for-each> <!-- xsl:value-of select="$partnum"/>.<xsl:value-of select="$chapnum"/>.<xsl:value-of select="$sectnum"/>.<xsl:number/ --> - <xsl:value-of select="title"/> + <xsl:call-template name="title_link"> + <xsl:with-param name="title" select="title"/> + </xsl:call-template> </h4> <xsl:apply-templates> <xsl:with-param name="chapnum" select="$chapnum"/> @@ -953,9 +1009,9 @@ <xsl:for-each select="marker"> <xsl:call-template name="marker-before-title"/> </xsl:for-each> - <a name="{generate-id(title)}"> - <xsl:value-of select="title"/> - </a> + <xsl:call-template name="title_link"> + <xsl:with-param name="title" select="title"/> + </xsl:call-template> </h3> <div class="REFBODY rb-3"> <xsl:apply-templates> @@ -1208,7 +1264,14 @@ </xsl:variable> <div class="doc-image-wrapper"> - <img alt="IMAGE MISSING" src="{@file}" class="doc-image"/> + <xsl:choose> + <xsl:when test="@width"> + <img alt="IMAGE MISSING" width="{@width}" src="{@file}" class="doc-image"/> + </xsl:when> + <xsl:otherwise> + <img alt="IMAGE MISSING" src="{@file}" class="doc-image"/> + </xsl:otherwise> + </xsl:choose> <xsl:apply-templates> <xsl:with-param name="chapnum" select="$chapnum"/> @@ -1345,7 +1408,7 @@ <xsl:param name="chapter_file"/> <xsl:for-each select="$entries"> <li title="{title}"> - <a href="{$chapter_file}.html#{generate-id(title)}"> + <a href="{$chapter_file}.html#{erl:to-link(title)}"> <xsl:value-of select="title"/> </a> </li> @@ -1799,7 +1862,9 @@ <!-- Module --> <xsl:template match="module"> <xsl:param name="partnum"/> - <h3><a name="module" href="#module">Module</a></h3> + <xsl:call-template name="h3_title_link"> + <xsl:with-param name="title">Module</xsl:with-param> + </xsl:call-template> <div class="REFBODY module-body"> <xsl:apply-templates> <xsl:with-param name="partnum" select="$partnum"/> @@ -1811,7 +1876,9 @@ <!-- Modulesummary --> <xsl:template match="modulesummary"> <xsl:param name="partnum"/> - <h3><a name="module-summary" href="#module-summary">Module Summary</a></h3> + <xsl:call-template name="h3_title_link"> + <xsl:with-param name="title">Module Summary</xsl:with-param> + </xsl:call-template> <div class="REFBODY module-summary-body"> <xsl:apply-templates> <xsl:with-param name="partnum" select="$partnum"/> @@ -1822,7 +1889,9 @@ <!-- Lib --> <xsl:template match="lib"> <xsl:param name="partnum"/> - <h3><a name="c-library" href="#c-library">C Library</a></h3> + <xsl:call-template name="h3_title_link"> + <xsl:with-param name="title">C Library</xsl:with-param> + </xsl:call-template> <div class="REFBODY c-library-body"> <xsl:apply-templates> <xsl:with-param name="partnum" select="$partnum"/> @@ -1834,7 +1903,9 @@ <!-- Libsummary --> <xsl:template match="libsummary"> <xsl:param name="partnum"/> - <h3><a name="library-summary" href="#library-summary">Library Summary</a></h3> + <xsl:call-template name="h3_title_link"> + <xsl:with-param name="title">Library Summary</xsl:with-param> + </xsl:call-template> <div class="REFBODY library-summary-body"> <xsl:apply-templates> <xsl:with-param name="partnum" select="$partnum"/> @@ -1845,7 +1916,9 @@ <!-- Com --> <xsl:template match="com"> <xsl:param name="partnum"/> - <h3><a name="command" href="#command">Command</a></h3> + <xsl:call-template name="h3_title_link"> + <xsl:with-param name="title">Command</xsl:with-param> + </xsl:call-template> <div class="REFBODY command-body"> <xsl:apply-templates> <xsl:with-param name="partnum" select="$partnum"/> @@ -1857,7 +1930,9 @@ <!-- Comsummary --> <xsl:template match="comsummary"> <xsl:param name="partnum"/> - <h3><a name="command-summary" href="#command-summary">Command Summary</a></h3> + <xsl:call-template name="h3_title_link"> + <xsl:with-param name="title">Command Summary</xsl:with-param> + </xsl:call-template> <div class="REFBODY command-summary-body"> <xsl:apply-templates> <xsl:with-param name="partnum" select="$partnum"/> @@ -1868,7 +1943,9 @@ <!-- File --> <xsl:template match="file"> <xsl:param name="partnum"/> - <h3><a name="file" href="#file">File</a></h3> + <xsl:call-template name="h3_title_link"> + <xsl:with-param name="title">File</xsl:with-param> + </xsl:call-template> <div class="REFBODY file-body"> <xsl:apply-templates> <xsl:with-param name="partnum" select="$partnum"/> @@ -1880,7 +1957,9 @@ <!-- Filesummary --> <xsl:template match="filesummary"> <xsl:param name="partnum"/> - <h3><a name="file-summary" href="#file-summary">File Summary</a></h3> + <xsl:call-template name="h3_title_link"> + <xsl:with-param name="title">File Summary</xsl:with-param> + </xsl:call-template> <div class="REFBODY file-summary-body"> <xsl:apply-templates> <xsl:with-param name="partnum" select="$partnum"/> @@ -1892,7 +1971,9 @@ <!-- App --> <xsl:template match="app"> <xsl:param name="partnum"/> - <h3><a name="application" href="#application">Application</a></h3> + <xsl:call-template name="h3_title_link"> + <xsl:with-param name="title">Application</xsl:with-param> + </xsl:call-template> <div class="REFBODY application-body"> <xsl:apply-templates> <xsl:with-param name="partnum" select="$partnum"/> @@ -1904,7 +1985,9 @@ <!-- Appsummary --> <xsl:template match="appsummary"> <xsl:param name="partnum"/> - <h3><a name="application-summary" href="#application-summary">Application Summary</a></h3> + <xsl:call-template name="h3_title_link"> + <xsl:with-param name="title">Application Summary</xsl:with-param> + </xsl:call-template> <div class="REFBODY application-summary-body"> <xsl:apply-templates> <xsl:with-param name="partnum" select="$partnum"/> @@ -1915,7 +1998,9 @@ <!-- Description --> <xsl:template match="description"> <xsl:param name="partnum"/> - <h3><a name="description" href="#description">Description</a></h3> + <xsl:call-template name="h3_title_link"> + <xsl:with-param name="title">Description</xsl:with-param> + </xsl:call-template> <div class="REFBODY description-body"> <p> <xsl:apply-templates> @@ -1929,7 +2014,9 @@ <xsl:template match="funcs"> <xsl:param name="partnum"/> - <h3><a name="exports" href="#exports"><xsl:text>Exports</xsl:text></a></h3> + <xsl:call-template name="h3_title_link"> + <xsl:with-param name="title">Exports</xsl:with-param> + </xsl:call-template> <div class="exports-body"> <xsl:apply-templates> @@ -1946,7 +2033,8 @@ <p><xsl:apply-templates select="name"/> <xsl:apply-templates select="name[string-length(@arity) > 0 and position()=last()]" - mode="types"/></p> + mode="types"/> + </p> <xsl:apply-templates select="fsummary|type|desc"> <xsl:with-param name="partnum" select="$partnum"/> @@ -2005,14 +2093,19 @@ <xsl:choose> <xsl:when test="ancestor::cref"> - <a name="{substring-before(nametext, '(')}"> - <span class="bold_code bc-7"> - <xsl:value-of select="ret"/> - <xsl:call-template name="maybe-space-after-ret"> - <xsl:with-param name="s" select="ret"/> - </xsl:call-template> - <xsl:value-of select="nametext"/> - </span></a><br/> + <span class="bold_code bc-7"> + <xsl:call-template name="title_link"> + <xsl:with-param name="link" select="substring-before(nametext, '(')"/> + <xsl:with-param name="title"> + <xsl:value-of select="ret"/> + <xsl:call-template name="maybe-space-after-ret"> + <xsl:with-param name="s" select="ret"/> + </xsl:call-template> + <xsl:value-of select="nametext"/> + </xsl:with-param> + </xsl:call-template> + </span> + <br/> </xsl:when> <xsl:when test="ancestor::erlref"> <xsl:variable name="fname"> @@ -2033,15 +2126,29 @@ </xsl:variable> <xsl:choose> <xsl:when test="ancestor::datatype"> - <a name="type-{$fname}"></a><span class="bold_code bc-8"><xsl:apply-templates/></span><br/> + <div class="bold_code bc-8"> + <xsl:call-template name="title_link"> + <xsl:with-param name="link" select="concat('type-',$fname)"/> + <xsl:with-param name="title"> + <xsl:apply-templates/> + </xsl:with-param> + </xsl:call-template> + </div> </xsl:when> <xsl:otherwise> - <a name="{$fname}-{$arity}"></a><span class="bold_code fun-type"><xsl:apply-templates/></span><br/> + <div class="bold_code fun-type"> + <xsl:call-template name="title_link"> + <xsl:with-param name="link" select="concat(concat($fname,'-'),$arity)"/> + <xsl:with-param name="title"> + <xsl:apply-templates/> + </xsl:with-param> + </xsl:call-template> + </div> </xsl:otherwise> </xsl:choose> </xsl:when> <xsl:otherwise> - <span class="bold_code bc-10"><xsl:value-of select="."/></span> + <div class="bold_code bc-10"><xsl:value-of select="."/></div> </xsl:otherwise> </xsl:choose> @@ -2101,6 +2208,49 @@ </div> </xsl:template> + <xsl:template name="h3_title_link"> + <xsl:param name="title"/> + <h3> + <xsl:call-template name="title_link"> + <xsl:with-param name="title" select="$title"/> + <xsl:with-param name="link" select="erl:to-link($title)"/> + </xsl:call-template> + </h3> + </xsl:template> + + <xsl:template name="title_link"> + <xsl:param name="title"/> + <xsl:param name="link" select="erl:to-link(title)"/> + <xsl:param name="ghlink" select="ancestor-or-self::*[@ghlink][position() = 1]/@ghlink"/> + <xsl:variable name="id" select="concat(concat($link,'-'), generate-id(.))"/> + <span onMouseOver="document.getElementById('ghlink-{$id}').style.visibility = 'visible';" + onMouseOut="document.getElementById('ghlink-{$id}').style.visibility = 'hidden';"> + <xsl:call-template name="ghlink"> + <xsl:with-param name="id" select="$id"/> + <xsl:with-param name="ghlink" select="$ghlink"/> + </xsl:call-template> + <a class="title_link" name="{$link}" href="#{$link}"><xsl:value-of select="$title"/></a> + </span> + </xsl:template> + + <xsl:template name="ghlink"> + <xsl:param name="id"/> + <xsl:param name="ghlink" select="ancestor-or-self::*[@ghlink][position() = 1]/@ghlink"/> + <xsl:choose> + <xsl:when test="string-length($ghlink) > 0"> + <span id="ghlink-{$id}" class="ghlink"> + <a href="https://github.com/erlang/otp/edit/{$ghlink}" + title="Found an issue with the documentation? Fix it by clicking here!"> + <span class="pencil"/> + </a> + </span> + </xsl:when> + <xsl:otherwise> + <span id="ghlink-{$id}"/> + </xsl:otherwise> + </xsl:choose> + </xsl:template> + <!-- Desc --> <xsl:template match="desc"> <xsl:param name="partnum"/> diff --git a/lib/erl_docgen/priv/xsl/db_man.xsl b/lib/erl_docgen/priv/xsl/db_man.xsl index 03b6b0691d..a5ad7ed5ae 100644 --- a/lib/erl_docgen/priv/xsl/db_man.xsl +++ b/lib/erl_docgen/priv/xsl/db_man.xsl @@ -271,6 +271,12 @@ <xsl:apply-templates/> </xsl:template> + <!-- Datatype Title--> + <xsl:template match="datatype_title"> + <xsl:text> .SS </xsl:text> + <xsl:apply-templates/> + </xsl:template> + <!-- Datatype --> <xsl:template match="datatype"> <xsl:apply-templates/> diff --git a/lib/erl_docgen/priv/xsl/db_pdf.xsl b/lib/erl_docgen/priv/xsl/db_pdf.xsl index 46de66bcd8..1b91d768e3 100644 --- a/lib/erl_docgen/priv/xsl/db_pdf.xsl +++ b/lib/erl_docgen/priv/xsl/db_pdf.xsl @@ -3,7 +3,7 @@ # # %CopyrightBegin% # - # Copyright Ericsson AB 2009-2016. All Rights Reserved. + # Copyright Ericsson AB 2009-2018. 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. @@ -299,6 +299,13 @@ <xsl:apply-templates/> </xsl:template> + <!-- Datatype Title--> + <xsl:template match="datatype_title"> + <fo:block xsl:use-attribute-sets="h4"> + <xsl:apply-templates/> + </fo:block> + </xsl:template> + <!-- Datatype --> <xsl:template match="datatype"> <fo:block xsl:use-attribute-sets="function-name"> @@ -1649,8 +1656,14 @@ </xsl:variable> <fo:block xsl:use-attribute-sets="image"> - <fo:external-graphic content-width="scale-down-to-fit" inline-progression-dimension.maximum="100%" src="{@file}"/> - + <xsl:choose> + <xsl:when test="@width"> + <fo:external-graphic content-width="scale-to-fit" width="{@width}" inline-progression-dimension.maximum="100%" src="{@file}"/> + </xsl:when> + <xsl:otherwise> + <fo:external-graphic content-width="scale-down-to-fit" inline-progression-dimension.maximum="100%" src="{@file}"/> + </xsl:otherwise> + </xsl:choose> <xsl:apply-templates> <xsl:with-param name="chapnum" select="$chapnum"/> <xsl:with-param name="fignum" select="$fignum"/> diff --git a/lib/erl_docgen/priv/xsl/db_pdf_params.xsl b/lib/erl_docgen/priv/xsl/db_pdf_params.xsl index 99da29c2ac..9bfa991b54 100644 --- a/lib/erl_docgen/priv/xsl/db_pdf_params.xsl +++ b/lib/erl_docgen/priv/xsl/db_pdf_params.xsl @@ -3,7 +3,7 @@ # # %CopyrightBegin% # - # Copyright Ericsson AB 2009-2017. All Rights Reserved. + # Copyright Ericsson AB 2009-2018. 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,7 @@ <xsl:attribute-set name="image"> <xsl:attribute name="space-after">0.5em</xsl:attribute> <xsl:attribute name="space-before">0.5em</xsl:attribute> + <xsl:attribute name="text-align">center</xsl:attribute> </xsl:attribute-set> <xsl:attribute-set name="listblock"> diff --git a/lib/erl_docgen/src/docgen_edoc_xml_cb.erl b/lib/erl_docgen/src/docgen_edoc_xml_cb.erl index 91422c8910..b065c18cda 100644 --- a/lib/erl_docgen/src/docgen_edoc_xml_cb.erl +++ b/lib/erl_docgen/src/docgen_edoc_xml_cb.erl @@ -11,7 +11,7 @@ %% limitations under the License. %% %% Copyright (c) 2001-2016 Richard Carlsson. Parts written by Ericsson -%% are Copyright (c) Ericsson AB 2001-2012. All Rights Reserved. +%% are Copyright (c) Ericsson AB 2001-2017. All Rights Reserved. %% -module(docgen_edoc_xml_cb). @@ -113,7 +113,7 @@ root_attributes(Element, Opts) -> %% epp:default_encoding/0 returns 'utf8' reformat_encoding(utf8) -> "UTF-8"; reformat_encoding(List) when is_list(List) -> - case string:to_lower(List) of + case string:lowercase(List) of "utf8" -> "UTF-8"; _ -> List end; diff --git a/lib/erl_docgen/src/docgen_otp_specs.erl b/lib/erl_docgen/src/docgen_otp_specs.erl index 126229ecc9..9f2b401f93 100644 --- a/lib/erl_docgen/src/docgen_otp_specs.erl +++ b/lib/erl_docgen/src/docgen_otp_specs.erl @@ -297,7 +297,7 @@ indent(L) -> app_fix(L) -> try {"//" ++ R1,L2} = app_fix(L, 1), - [App, Mod] = string:tokens(R1, "/"), + [App, Mod] = string:lexemes(R1, "/"), "//" ++ atom(App) ++ "/" ++ atom(Mod) ++ L2 catch _:_ -> L end. @@ -585,13 +585,13 @@ ot_integer(E) -> {integer,0,list_to_integer(get_attrval(value, E))}. ot_range(E) -> - [I1, I2] = string:tokens(get_attrval(value, E), "."), + [I1, I2] = string:lexemes(get_attrval(value, E), "."), {type,0,range,[{integer,0,list_to_integer(I1)}, {integer,0,list_to_integer(I2)}]}. ot_binary(E) -> {Base, Unit} = - case string:tokens(get_attrval(value, E), ",:*><") of + case string:lexemes(get_attrval(value, E), ",:*><") of [] -> {0, 0}; ["_",B] -> diff --git a/lib/erl_interface/configure.in b/lib/erl_interface/configure.in index 0a8fbf513c..696ebf5ca0 100644 --- a/lib/erl_interface/configure.in +++ b/lib/erl_interface/configure.in @@ -106,6 +106,19 @@ if test $ac_cv_sizeof_long = 8; then CFLAGS="$CFLAGS -DEI_64BIT" fi +LM_HARDWARE_ARCH + +AC_MSG_CHECKING(for unaligned word access) +case "$ARCH" in + x86|amd64) + AC_MSG_RESULT(yes: x86 or amd64) + AC_DEFINE(HAVE_UNALIGNED_WORD_ACCESS, 1, [Define if hw supports unaligned word access]) + ;; + *) + AC_MSG_RESULT(no) + ;; +esac + AC_CHECK_TOOL(AR, ar, false) if test "$AR" = false; then AC_MSG_ERROR([No 'ar' command found in PATH]) diff --git a/lib/erl_interface/doc/src/notes.xml b/lib/erl_interface/doc/src/notes.xml index 641a3de13f..f165dde259 100644 --- a/lib/erl_interface/doc/src/notes.xml +++ b/lib/erl_interface/doc/src/notes.xml @@ -31,6 +31,29 @@ </header> <p>This document describes the changes made to the Erl_interface application.</p> +<section><title>Erl_Interface 3.10.2</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> + Fix bug in <c>ei_connect</c> functions that may cause + failure due to insufficient buffer space for + gethostbyname_r.</p> + <p> + Own Id: OTP-15022 Aux Id: ERIERL-163 </p> + </item> + <item> + <p> + Optimize encoding/decoding for pure 7-bit ascii atoms.</p> + <p> + Own Id: OTP-15023 Aux Id: ERIERL-150 </p> + </item> + </list> + </section> + +</section> + <section><title>Erl_Interface 3.10.1</title> <section><title>Fixed Bugs and Malfunctions</title> diff --git a/lib/erl_interface/src/connect/ei_connect.c b/lib/erl_interface/src/connect/ei_connect.c index ea9ecb31d5..5c01223e3d 100644 --- a/lib/erl_interface/src/connect/ei_connect.c +++ b/lib/erl_interface/src/connect/ei_connect.c @@ -583,6 +583,54 @@ static int cnct(uint16 port, struct in_addr *ip_addr, int addr_len, unsigned ms) return s; } /* cnct */ + +/* + * Same as ei_gethostbyname_r, but also handles ERANGE error + * and may allocate larger buffer with malloc. + */ +static +struct hostent *dyn_gethostbyname_r(const char *name, + struct hostent *hostp, + char **buffer_p, + int buflen, + int *h_errnop) +{ + char* buf = *buffer_p; + struct hostent *hp; + + while (1) { + hp = ei_gethostbyname_r(name, hostp, buf, buflen, h_errnop); + if (hp) { + *buffer_p = buf; + break; + } + + if (*h_errnop != ERANGE) { + if (buf != *buffer_p) + free(buf); + break; + } + + buflen *= 2; + if (buf == *buffer_p) + buf = malloc(buflen); + else { + char* buf2 = realloc(buf, buflen); + if (buf2) + buf = buf2; + else { + free(buf); + buf = NULL; + } + } + if (!buf) { + *h_errnop = ENOMEM; + break; + } + } + return hp; +} + /* * Set up a connection to a given Node, and * interchange hand shake messages with it. @@ -597,8 +645,10 @@ int ei_connect_tmo(ei_cnode* ec, char *nodename, unsigned ms) /* these are needed for the call to gethostbyname_r */ struct hostent host; char buffer[1024]; + char *buf = buffer; int ei_h_errno; #endif /* !win32 */ + int res; /* extract the host and alive parts from nodename */ if (!(hostname = strchr(nodename,'@'))) { @@ -611,7 +661,7 @@ int ei_connect_tmo(ei_cnode* ec, char *nodename, unsigned ms) } #ifndef __WIN32__ - hp = ei_gethostbyname_r(hostname,&host,buffer,1024,&ei_h_errno); + hp = dyn_gethostbyname_r(hostname,&host,&buf,sizeof(buffer),&ei_h_errno); if (hp == NULL) { char thishostname[EI_MAXHOSTNAMELEN+1]; /* gethostname requies len to be max(hostname) + 1*/ @@ -627,7 +677,7 @@ int ei_connect_tmo(ei_cnode* ec, char *nodename, unsigned ms) } if (strcmp(hostname,thishostname) == 0) /* Both nodes on same standalone host, use loopback */ - hp = ei_gethostbyname_r("localhost",&host,buffer,1024,&ei_h_errno); + hp = dyn_gethostbyname_r("localhost",&host,&buf,sizeof(buffer),&ei_h_errno); if (hp == NULL) { EI_TRACE_ERR2("ei_connect", "Can't find host for %s: %d\n",nodename,ei_h_errno); @@ -663,7 +713,14 @@ int ei_connect_tmo(ei_cnode* ec, char *nodename, unsigned ms) } } #endif /* win32 */ - return ei_xconnect_tmo(ec, (Erl_IpAddr) *hp->h_addr_list, alivename, ms); + + res = ei_xconnect_tmo(ec, (Erl_IpAddr) *hp->h_addr_list, alivename, ms); + +#ifndef __WIN32__ + if (buf != buffer) + free(buf); +#endif + return res; } /* ei_connect */ int ei_connect(ei_cnode* ec, char *nodename) diff --git a/lib/erl_interface/src/connect/ei_resolve.c b/lib/erl_interface/src/connect/ei_resolve.c index fd0c659373..2757735d39 100644 --- a/lib/erl_interface/src/connect/ei_resolve.c +++ b/lib/erl_interface/src/connect/ei_resolve.c @@ -645,8 +645,11 @@ struct hostent *ei_gethostbyname_r(const char *name, #else #if (defined(__GLIBC__) || defined(__linux__) || (__FreeBSD_version >= 602000) || defined(__DragonFly__) || defined(__ANDROID__)) struct hostent *result; + int err; - gethostbyname_r(name, hostp, buffer, buflen, &result, h_errnop); + err = gethostbyname_r(name, hostp, buffer, buflen, &result, h_errnop); + if (err == ERANGE) + *h_errnop = err; return result; #else diff --git a/lib/erl_interface/src/decode/decode_atom.c b/lib/erl_interface/src/decode/decode_atom.c index b3bba82434..87cd75b1be 100644 --- a/lib/erl_interface/src/decode/decode_atom.c +++ b/lib/erl_interface/src/decode/decode_atom.c @@ -92,6 +92,51 @@ int ei_decode_atom_as(const char *buf, int *index, char* p, int destlen, } + +#ifdef HAVE_UNALIGNED_WORD_ACCESS + +#if SIZEOF_VOID_P == SIZEOF_LONG +typedef unsigned long AsciiWord; +#elif SIZEOF_VOID_P == SIZEOF_LONG_LONG +typedef unsigned long long AsciiWord; +#else +# error "Uknown word type" +#endif + +#if SIZEOF_VOID_P == 4 +# define ASCII_CHECK_MASK ((AsciiWord)0x80808080U) +#elif SIZEOF_VOID_P == 8 +# define ASCII_CHECK_MASK ((AsciiWord)0x8080808080808080U) +#endif + +static int ascii_fast_track(char* dst, const char* src, int slen, int destlen) +{ + const AsciiWord* src_word = (AsciiWord*) src; + const AsciiWord* const src_word_end = src_word + (slen / sizeof(AsciiWord)); + + if (destlen < slen) + return 0; + + if (dst) { + AsciiWord* dst_word = (AsciiWord*)dst; + + while (src_word < src_word_end) { + if ((*src_word & ASCII_CHECK_MASK) != 0) + break; + *dst_word++ = *src_word++; + } + } + else { + while (src_word < src_word_end) { + if ((*src_word & ASCII_CHECK_MASK) != 0) + break; + src_word++; + } + } + return (char*)src_word - src; +} +#endif /* HAVE_UNALIGNED_WORD_ACCESS */ + int utf8_to_latin1(char* dst, const char* src, int slen, int destlen, erlang_char_encoding* res_encp) { @@ -99,6 +144,15 @@ int utf8_to_latin1(char* dst, const char* src, int slen, int destlen, const char* const dst_end = dst + destlen; int found_non_ascii = 0; +#ifdef HAVE_UNALIGNED_WORD_ACCESS + { + int aft = ascii_fast_track(dst, src, slen, destlen); + src += aft; + slen -= aft; + dst += aft; + } +#endif + while (slen > 0) { if (dst >= dst_end) return -1; if ((src[0] & 0x80) == 0) { @@ -136,6 +190,14 @@ int latin1_to_utf8(char* dst, const char* src, int slen, int destlen, const char* const dst_end = dst + destlen; int found_non_ascii = 0; +#ifdef HAVE_UNALIGNED_WORD_ACCESS + { + int aft = ascii_fast_track(dst, src, slen, destlen); + dst += aft; + src += aft; + } +#endif + while (src < src_end) { if (dst >= dst_end) return -1; if ((src[0] & 0x80) == 0) { diff --git a/lib/erl_interface/src/legacy/erl_marshal.c b/lib/erl_interface/src/legacy/erl_marshal.c index caa171858d..6435754823 100644 --- a/lib/erl_interface/src/legacy/erl_marshal.c +++ b/lib/erl_interface/src/legacy/erl_marshal.c @@ -107,7 +107,7 @@ static int init_cmp_num_class_p=1; /* initialize array, the first time */ void erl_init_marshal(void) { if (init_cmp_array_p) { - memset(cmp_array, 0, CMP_ARRAY_SIZE); + memset(cmp_array, 0, sizeof cmp_array); cmp_array[ERL_SMALL_INTEGER_EXT] = ERL_NUM_CMP; cmp_array[ERL_INTEGER_EXT] = ERL_NUM_CMP; cmp_array[ERL_FLOAT_EXT] = ERL_NUM_CMP; diff --git a/lib/erl_interface/test/ei_accept_SUITE.erl b/lib/erl_interface/test/ei_accept_SUITE.erl index e06ee762d7..6676e73e21 100644 --- a/lib/erl_interface/test/ei_accept_SUITE.erl +++ b/lib/erl_interface/test/ei_accept_SUITE.erl @@ -25,7 +25,8 @@ -include("ei_accept_SUITE_data/ei_accept_test_cases.hrl"). -export([all/0, suite/0, - ei_accept/1, ei_threaded_accept/1]). + ei_accept/1, ei_threaded_accept/1, + monitor_ei_process/1]). -import(runner, [get_term/1,send_term/2]). @@ -34,7 +35,8 @@ suite() -> {timetrap, {seconds, 30}}]. all() -> - [ei_accept, ei_threaded_accept]. + [ei_accept, ei_threaded_accept, + monitor_ei_process]. ei_accept(Config) when is_list(Config) -> P = runner:start(?interpret), @@ -44,33 +46,32 @@ ei_accept(Config) when is_list(Config) -> io:format("Myname ~p ~n", [Myname]), EINode = list_to_atom("c42@"++Myname), io:format("EINode ~p ~n", [EINode]), + + %% We take this opportunity to also test export-funs and bit-strings + %% with (ugly) tuple fallbacks. + %% Test both toward pending connection and established connection. + RealTerms = [<<1:1>>, fun lists:map/2], + Fallbacks = [{<<128>>,1}, {lists,map}], + Self = self(), - TermToSend= {call, Self, "Test"}, - F= fun() -> - case waitfornode("c42",20) of - true -> - {any, EINode} ! TermToSend, - Self ! sent_ok; - false -> - Self ! never_published - end, - ok - end, - - spawn(F), + Funny = fun() -> hello end, + TermToSend = {call, Self, "Test", Funny, RealTerms}, + TermToGet = {call, Self, "Test", Funny, Fallbacks}, Port = 6543, - {ok, Fd, _Node} = ei_accept(P, Port), - TermReceived= ei_receive(P, Fd), - io:format("Sent ~p received ~p ~n", [TermToSend, TermReceived]), - TermToSend= TermReceived, - receive - sent_ok -> - ok; - Unknown -> - io:format("~p ~n", [Unknown]) - after 1000 -> - io:format("timeout ~n") - end, + {ok, ListenFd} = ei_publish(P, Port), + {any, EINode} ! TermToSend, + + {ok, Fd, _Node} = ei_accept(P, ListenFd), + Got1 = ei_receive(P, Fd), + + %% Send again, now without auto-connect + {any, EINode} ! TermToSend, + Got2 = ei_receive(P, Fd), + + io:format("Sent ~p~nExp. ~p~nGot1 ~p~nGot2 ~p~n", [TermToSend, TermToGet, Got1, Got2]), + TermToGet = Got1, + TermToGet = Got2, + runner:finish(P), ok. @@ -87,6 +88,41 @@ ei_threaded_accept(Config) when is_list(Config) -> [receive I -> ok end || I <- lists:seq(0, N-1) ], ok. + +%% Test erlang:monitor toward erl_interface "processes" +monitor_ei_process(Config) when is_list(Config) -> + P = runner:start(?interpret), + 0 = ei_connect_init(P, 42, erlang:get_cookie(), 0), + + Myname = hd(tl(string:tokens(atom_to_list(node()), "@"))), + io:format("Myname ~p ~n", [Myname]), + EINode = list_to_atom("c42@"++Myname), + io:format("EINode ~p ~n", [EINode]), + + Self = self(), + Port = 6543, + {ok, ListenFd} = ei_publish(P, Port), + MRef1 = erlang:monitor(process, {any, EINode}), + {any, EINode} ! hello, + + {ok, Fd, _Node} = ei_accept(P, ListenFd), + hello = ei_receive(P, Fd), + + %% Again, now on an established connection. + MRef2 = erlang:monitor(process, {any, EINode}), + {any, EINode} ! hello, + hello = ei_receive(P, Fd), + + ok = receive M -> M after 0 -> ok end, + + runner:finish(P), + + [{'DOWN', MRef1, process, {any, EINode}, noconnection}, + {'DOWN', MRef2, process, {any, EINode}, noconnection} + ] = lists:sort(flush(2, 1000)), + + ok. + waitfornode(String,0) -> io:format("~s never published itself.~n",[String]), false; @@ -137,8 +173,15 @@ ei_connect_init(P, Num, Cookie, Creation) -> {term,Int} when is_integer(Int) -> Int end. -ei_accept(P, PortNo) -> - send_command(P, ei_accept, [PortNo]), +ei_publish(P, PortNo) -> + send_command(P, ei_publish, [PortNo]), + case get_term(P) of + {term,{ListenFd, EpmdFd, _}} when ListenFd >= 0, EpmdFd >= 0 -> {ok, ListenFd}; + {term,{_, _, Errno}} -> {error,Errno} + end. + +ei_accept(P, ListenFd) -> + send_command(P, ei_accept, [ListenFd]), case get_term(P) of {term,{Fd, _, Node}} when Fd >= 0 -> {ok, Fd, Node}; {term,{_Fd, Errno, _Node}} -> {error,Errno} @@ -151,3 +194,12 @@ ei_receive(P, Fd) -> send_command(P, Name, Args) -> runner:send_term(P, {Name,list_to_tuple(Args)}). + +flush(0, Timeout) -> + flush(1, Timeout div 10); +flush(Expected, Timeout) -> + receive M -> + [M | flush(Expected-1, Timeout)] + after Timeout -> + [] + end. diff --git a/lib/erl_interface/test/ei_accept_SUITE_data/ei_accept_test.c b/lib/erl_interface/test/ei_accept_SUITE_data/ei_accept_test.c index 7b81ee5491..2b62d7c3a4 100644 --- a/lib/erl_interface/test/ei_accept_SUITE_data/ei_accept_test.c +++ b/lib/erl_interface/test/ei_accept_SUITE_data/ei_accept_test.c @@ -43,6 +43,7 @@ #include "ei_runner.h" static void cmd_ei_connect_init(char* buf, int len); +static void cmd_ei_publish(char* buf, int len); static void cmd_ei_accept(char* buf, int len); static void cmd_ei_receive(char* buf, int len); static void cmd_ei_unpublish(char* buf, int len); @@ -58,6 +59,7 @@ static struct { void (*func)(char* buf, int len); } commands[] = { "ei_connect_init", 3, cmd_ei_connect_init, + "ei_publish", 1, cmd_ei_publish, "ei_accept", 1, cmd_ei_accept, "ei_receive", 1, cmd_ei_receive, "ei_unpublish", 0, cmd_ei_unpublish @@ -149,11 +151,10 @@ static int my_listen(int port) return listen_fd; } -static void cmd_ei_accept(char* buf, int len) +static void cmd_ei_publish(char* buf, int len) { int index = 0; int listen, r; - ErlConnect conn; long port; ei_x_buff x; int i; @@ -170,6 +171,29 @@ static void cmd_ei_accept(char* buf, int len) #ifdef VXWORKS save_fd(i); #endif + /* send listen-fd, result and errno */ + ei_x_new_with_version(&x); + ei_x_encode_tuple_header(&x, 3); + ei_x_encode_long(&x, listen); + ei_x_encode_long(&x, i); + ei_x_encode_long(&x, erl_errno); + send_bin_term(&x); + ei_x_free(&x); +} + +static void cmd_ei_accept(char* buf, int len) +{ + int index = 0; + int r; + ErlConnect conn; + long listen; + ei_x_buff x; + int i; + + /* get port */ + if (ei_decode_long(buf, &index, &listen) < 0) + fail("expected int (listen fd)"); + r = ei_accept(&ec, listen, &conn); #ifdef VXWORKS save_fd(r); @@ -200,7 +224,7 @@ static void cmd_ei_receive(char* buf, int len) if (got == ERL_TICK) continue; if (got == ERL_ERROR) - fail("ei_xreceive_msg"); + fail1("ei_xreceive_msg, got==%d", got); break; } index = 1; diff --git a/lib/erl_interface/test/ei_tmo_SUITE_data/ei_tmo_test.c b/lib/erl_interface/test/ei_tmo_SUITE_data/ei_tmo_test.c index 0079ef8c86..8e0f2807a4 100644 --- a/lib/erl_interface/test/ei_tmo_SUITE_data/ei_tmo_test.c +++ b/lib/erl_interface/test/ei_tmo_SUITE_data/ei_tmo_test.c @@ -19,6 +19,7 @@ */ #include <stdio.h> +#include <stdlib.h> #include <string.h> #ifdef VXWORKS #include "reclaim.h" diff --git a/lib/erl_interface/test/runner.erl b/lib/erl_interface/test/runner.erl index 1084eec2a3..cbdeb3c8a9 100644 --- a/lib/erl_interface/test/runner.erl +++ b/lib/erl_interface/test/runner.erl @@ -67,7 +67,12 @@ start({Prog, Tc}) when is_list(Prog), is_integer(Tc) -> finish(Port) when is_port(Port) -> send_eot(Port), - recv_eot(Port). + ok = recv_eot(Port), + 0 = receive + {Port,{exit_status,Status}} -> + Status + end, + ok. %% Sends an Erlang term to a C program. diff --git a/lib/erl_interface/vsn.mk b/lib/erl_interface/vsn.mk index d76d110afd..8b6e91757d 100644 --- a/lib/erl_interface/vsn.mk +++ b/lib/erl_interface/vsn.mk @@ -1,2 +1,2 @@ -EI_VSN = 3.10.1 +EI_VSN = 3.10.2 ERL_INTERFACE_VSN = $(EI_VSN) diff --git a/lib/et/doc/src/Makefile b/lib/et/doc/src/Makefile index 0257a8f817..162d36e274 100644 --- a/lib/et/doc/src/Makefile +++ b/lib/et/doc/src/Makefile @@ -45,8 +45,11 @@ include files.mk XML_FILES = $(BOOK_FILES) $(XML_APPLICATION_FILES) $(XML_REF3_FILES) \ $(XML_PART_FILES) $(XML_CHAPTER_FILES) +XML_GEN_FILES = $(GEN_XML:%=$(XMLDIR)/%) + HTML_FILES = $(XML_APPLICATION_FILES:%.xml=$(HTMLDIR)/%.html) \ - $(XML_PART_FILES:%.xml=$(HTMLDIR)/%.html) + $(XML_PART_FILES:%.xml=$(HTMLDIR)/%.html) \ + $(GEN_XML:%.xml=$(HTMLDIR)/%.html) INFO_FILE = ../../info diff --git a/lib/et/doc/src/files.mk b/lib/et/doc/src/files.mk index e0ea9b0b76..7437da7ce3 100644 --- a/lib/et/doc/src/files.mk +++ b/lib/et/doc/src/files.mk @@ -31,10 +31,13 @@ XML_PART_FILES = \ XML_CHAPTER_FILES = \ et_intro.xml \ + notes.xml + +GEN_XML = \ et_tutorial.xml \ et_desc.xml \ - et_examples.xml \ - notes.xml + et_examples.xml + BOOK_FILES = book.xml diff --git a/lib/et/src/et_collector.erl b/lib/et/src/et_collector.erl index b0f016a8ea..ffe244324c 100644 --- a/lib/et/src/et_collector.erl +++ b/lib/et/src/et_collector.erl @@ -1135,7 +1135,7 @@ handle_info(Info, S) -> noreply(S). listen_on_trace_port(Node, Port, S) -> - [_Name, Host] = string:tokens(atom_to_list(Node), [$@]), + [_Name, Host] = string:lexemes(atom_to_list(Node), [$@]), case catch start_trace_client(self(), ip, {Host, Port}) of {trace_client_pid, RemotePid} -> rpc:call(Node, et_selector, change_pattern, [S#state.trace_pattern]), diff --git a/lib/et/src/et_wx_contents_viewer.erl b/lib/et/src/et_wx_contents_viewer.erl index bca517317e..7ca41da3e8 100644 --- a/lib/et/src/et_wx_contents_viewer.erl +++ b/lib/et/src/et_wx_contents_viewer.erl @@ -93,8 +93,8 @@ start_link(Options) -> end, {ok, Pid} catch - error:Reason -> - {error, {'EXIT', Reason, erlang:get_stacktrace()}} + error:Reason:Stacktrace -> + {error, {'EXIT', Reason, Stacktrace}} end; {error, Reason} -> {error, Reason} diff --git a/lib/eunit/doc/src/Makefile b/lib/eunit/doc/src/Makefile index 610e575af6..e91d947592 100644 --- a/lib/eunit/doc/src/Makefile +++ b/lib/eunit/doc/src/Makefile @@ -70,9 +70,10 @@ HTML_STYLESHEET_FILES = \ BOOK_FILES = book.xml XML_FILES = \ - $(BOOK_FILES) $(XML_CHAPTER_FILES) $(XML_NOTES_FILES) \ - $(XML_PART_FILES) $(XML_REF3_FILES) $(XML_APPLICATION_FILES) + $(BOOK_FILES) $(XML_NOTES_FILES) \ + $(XML_PART_FILES) $(XML_APPLICATION_FILES) +XML_GEN_FILES = $(XML_REF3_FILES:%=$(XMLDIR)/%) $(XML_CHAPTER_FILES:%=$(XMLDIR)/%) # ---------------------------------------------------- INFO_FILE = ../../info @@ -122,11 +123,11 @@ man: $(MAN3_FILES) gifs: $(GIF_FILES:%=$(HTMLDIR)/%) -$(XML_REF3_FILES): - escript $(DOCGEN)/priv/bin/xml_from_edoc.escript -def vsn $(EUNIT_VSN) -i $(EUNIT_INC_DIR) $(EUNIT_DIR)/$(@:%.xml=%.erl) +$(XML_REF3_FILES:%=$(XMLDIR)/%): + $(gen_verbose)escript $(DOCGEN)/priv/bin/xml_from_edoc.escript -def vsn $(EUNIT_VSN) -i $(EUNIT_INC_DIR) -dir $(XMLDIR) $(EUNIT_DIR)/$(@:$(XMLDIR)/%.xml=%.erl) -$(XML_CHAPTER_FILES): - escript $(DOCGEN)/priv/bin/xml_from_edoc.escript -def vsn $(EUNIT_VSN) -chapter ../overview.edoc +$(XML_CHAPTER_FILES:%=$(XMLDIR)/%): + $(gen_verbose)escript $(DOCGEN)/priv/bin/xml_from_edoc.escript -def vsn $(EUNIT_VSN) -chapter -dir $(XMLDIR) ../overview.edoc info: @echo "XML_PART_FILES: $(XML_PART_FILES)" diff --git a/lib/eunit/src/eunit_lib.erl b/lib/eunit/src/eunit_lib.erl index e340f50a3c..771541354c 100644 --- a/lib/eunit/src/eunit_lib.erl +++ b/lib/eunit/src/eunit_lib.erl @@ -202,13 +202,13 @@ format_exception_test_() -> "\nymmud:rorre"++_, lists:reverse(lists:flatten( format_exception(try erlang:error(dummy) - catch C:R -> {C, R, erlang:get_stacktrace()} + catch C:R:S -> {C, R, S} end)))), ?_assertMatch( "\nymmud:rorre"++_, lists:reverse(lists:flatten( format_exception(try erlang:error(dummy, [a]) - catch C:R -> {C, R, erlang:get_stacktrace()} + catch C:R:S -> {C, R, S} end))))]. -endif. @@ -391,7 +391,7 @@ fun_parent(F) -> -ifdef(TEST). fun_parent_test() -> - {?MODULE,fun_parent_test,0} = fun_parent(fun () -> ok end). + {?MODULE,fun_parent_test,0} = fun_parent(fun (A) -> {ok,A} end). -endif. %% --------------------------------------------------------------------- diff --git a/lib/eunit/src/eunit_listener.erl b/lib/eunit/src/eunit_listener.erl index e652c5b2f6..75aa05c543 100644 --- a/lib/eunit/src/eunit_listener.erl +++ b/lib/eunit/src/eunit_listener.erl @@ -137,8 +137,7 @@ call(F, As, St) when is_atom(F) -> try apply(St#state.callback, F, As) of Substate -> St#state{state = Substate} catch - Class:Term -> - Trace = erlang:get_stacktrace(), + Class:Term:Trace -> if F =/= terminate -> call(terminate, [{error, {Class, Term, Trace}}, St#state.state], St); diff --git a/lib/eunit/src/eunit_proc.erl b/lib/eunit/src/eunit_proc.erl index e075005238..96bdcf88b6 100644 --- a/lib/eunit/src/eunit_proc.erl +++ b/lib/eunit/src/eunit_proc.erl @@ -628,7 +628,7 @@ io_request({put_chars, M, F, As}, Buf) -> try apply(M, F, As) of Chars -> {ok, [Chars | Buf]} catch - C:T -> {{error, {C,T,erlang:get_stacktrace()}}, Buf} + C:T:S -> {{error, {C,T,S}}, Buf} end; io_request({put_chars, _Enc, Chars}, Buf) -> io_request({put_chars, Chars}, Buf); diff --git a/lib/eunit/src/eunit_test.erl b/lib/eunit/src/eunit_test.erl index 6036537178..6fe85ae70a 100644 --- a/lib/eunit/src/eunit_test.erl +++ b/lib/eunit/src/eunit_test.erl @@ -39,11 +39,11 @@ %% somewhat, but you can't have everything.) Note that we assume that %% this particular module is the boundary between eunit and user code. -get_stacktrace() -> - get_stacktrace([]). +get_stacktrace(Trace) -> + get_stacktrace(Trace, []). -get_stacktrace(Ts) -> - eunit_lib:uniq(prune_trace(erlang:get_stacktrace(), Ts)). +get_stacktrace(Trace, Ts) -> + eunit_lib:uniq(prune_trace(Trace, Ts)). -dialyzer({no_match, prune_trace/2}). prune_trace([{eunit_data, _, _} | Rest], Tail) -> @@ -75,8 +75,8 @@ run_testfun(F) -> {eunit_internal, Term} -> %% Internally generated: re-throw Term (lose the trace) throw(Term); - Class:Reason -> - {error, {Class, Reason, get_stacktrace()}} + Class:Reason:Trace -> + {error, {Class, Reason, Trace}} end. @@ -272,7 +272,7 @@ mf_wrapper(M, F) -> fun () -> try M:F() catch - error:undef -> + error:undef:Trace -> %% Check if it was M:F/0 that was undefined case erlang:module_loaded(M) of false -> @@ -282,14 +282,14 @@ mf_wrapper(M, F) -> false -> fail({no_such_function, {M,F,0}}); true -> - rethrow(error, undef, [{M,F,0}]) + rethrow(error, undef, Trace, [{M,F,0}]) end end end end. -rethrow(Class, Reason, Trace) -> - erlang:raise(Class, Reason, get_stacktrace(Trace)). +rethrow(Class, Reason, Trace, Ts) -> + erlang:raise(Class, Reason, get_stacktrace(Trace, Ts)). fail(Term) -> throw({eunit_internal, Term}). @@ -332,12 +332,14 @@ enter_context(Setup, Cleanup, Instantiate, Callback) -> T -> case eunit_lib:is_not_test(T) of true -> - catch throw(error), % generate a stack trace + {_, Stacktrace} = + erlang:process_info(self(), + current_stacktrace), {module,M} = erlang:fun_info(Instantiate, module), {name,N} = erlang:fun_info(Instantiate, name), {arity,A} = erlang:fun_info(Instantiate, arity), context_error({bad_instantiator, {{M,N,A},T}}, - error, badarg); + error, Stacktrace, badarg); false -> ok end, @@ -346,21 +348,22 @@ enter_context(Setup, Cleanup, Instantiate, Callback) -> %% Always run cleanup; client may be an idiot try Cleanup(R) catch - Class:Term -> - context_error(cleanup_failed, Class, Term) + Class:Term:Trace -> + context_error(cleanup_failed, + Class, Trace, Term) end end catch - Class:Term -> - context_error(instantiation_failed, Class, Term) + Class:Term:Trace -> + context_error(instantiation_failed, Class, Trace, Term) end catch - Class:Term -> - context_error(setup_failed, Class, Term) + Class:Term:Trace -> + context_error(setup_failed, Class, Trace, Term) end. -context_error(Type, Class, Term) -> - throw({context_error, Type, {Class, Term, get_stacktrace()}}). +context_error(Type, Class, Trace, Term) -> + throw({context_error, Type, {Class, Term, get_stacktrace(Trace)}}). %% This generates single setup/cleanup functions from a list of tuples %% on the form {Tag, Setup, Cleanup}, where the setup function always @@ -378,8 +381,8 @@ multi_setup([{Tag, S, C} | Es], CleanupPrev) -> try C(R) of _ -> CleanupPrev(Rs) catch - Class:Term -> - throw({Tag, {Class, Term, get_stacktrace()}}) + Class:Term:Trace -> + throw({Tag, {Class, Term, Trace}}) end end, {SetupRest, CleanupAll} = multi_setup(Es, Cleanup), @@ -388,9 +391,9 @@ multi_setup([{Tag, S, C} | Es], CleanupPrev) -> R -> SetupRest([R|Rs]) catch - Class:Term -> + Class:Term:Trace -> CleanupPrev(Rs), - throw({Tag, {Class, Term, get_stacktrace()}}) + throw({Tag, {Class, Term, Trace}}) end end, CleanupAll}; diff --git a/lib/ftp/AUTHORS b/lib/ftp/AUTHORS new file mode 100644 index 0000000000..88dcbf602a --- /dev/null +++ b/lib/ftp/AUTHORS @@ -0,0 +1,11 @@ +Original Authors: + +Peter Högfeldt - first version of ftp + +Contributors: + +Ingela Anderton Andin +Martin Gustafsson +Johan Blom +Torbjörn Törnkvist +Joe Armstrong
\ No newline at end of file diff --git a/lib/ftp/Makefile b/lib/ftp/Makefile new file mode 100644 index 0000000000..555f8b0dea --- /dev/null +++ b/lib/ftp/Makefile @@ -0,0 +1,78 @@ +# +# %CopyrightBegin% +# +# Copyright Ericsson AB 1996-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 + +# ---------------------------------------------------- +# Macros +# ---------------------------------------------------- + +SUB_DIRECTORIES = src doc/src + +include vsn.mk +VSN = $(FTP_VSN) + +SPECIAL_TARGETS = + +DIA_PLT = ./priv/plt/$(APPLICATION).plt +DIA_ANALYSIS = $(basename $(DIA_PLT)).dialyzer_analysis + + +# ---------------------------------------------------- +# Default Subdir Targets +# ---------------------------------------------------- +include $(ERL_TOP)/make/otp_subdir.mk + +.PHONY: info gclean dialyzer dialyzer_plt dclean + +info: + @echo "OS: $(OS)" + @echo "DOCB: $(DOCB)" + @echo "" + @echo "FTP_VSN: $(FTP_VSN)" + @echo "APP_VSN: $(APP_VSN)" + @echo "" + @echo "DIA_PLT: $(DIA_PLT)" + @echo "DIA_ANALYSIS: $(DIA_ANALYSIS)" + @echo "" + +gclean: + git clean -fXd + +dclean: + rm -f $(DIA_PLT) + rm -f $(DIA_ANALYSIS) + +dialyzer_plt: $(DIA_PLT) + +$(DIA_PLT): + @echo "Building $(APPLICATION) plt file" + @dialyzer --build_plt \ + --output_plt $@ \ + -r ../$(APPLICATION)/ebin \ + --output $(DIA_ANALYSIS) \ + --verbose + +dialyzer: $(DIA_PLT) + @echo "Running dialyzer on $(APPLICATION)" + @dialyzer --plt $< \ + ../$(APPLICATION)/ebin \ + --verbose diff --git a/lib/inets/doc/archive/rfc2428.txt b/lib/ftp/doc/archive/rfc2428.txt index a6ec3535ed..a6ec3535ed 100644 --- a/lib/inets/doc/archive/rfc2428.txt +++ b/lib/ftp/doc/archive/rfc2428.txt diff --git a/lib/inets/doc/archive/rfc2577.txt b/lib/ftp/doc/archive/rfc2577.txt index 83ba203130..83ba203130 100644 --- a/lib/inets/doc/archive/rfc2577.txt +++ b/lib/ftp/doc/archive/rfc2577.txt diff --git a/lib/inets/doc/archive/rfc959.txt b/lib/ftp/doc/archive/rfc959.txt index 5c9f11af5d..5c9f11af5d 100644 --- a/lib/inets/doc/archive/rfc959.txt +++ b/lib/ftp/doc/archive/rfc959.txt diff --git a/lib/ftp/doc/html/.gitignore b/lib/ftp/doc/html/.gitignore new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/lib/ftp/doc/html/.gitignore diff --git a/lib/ftp/doc/man3/.gitignore b/lib/ftp/doc/man3/.gitignore new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/lib/ftp/doc/man3/.gitignore diff --git a/lib/ftp/doc/man6/.gitignore b/lib/ftp/doc/man6/.gitignore new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/lib/ftp/doc/man6/.gitignore diff --git a/lib/ftp/doc/pdf/.gitignore b/lib/ftp/doc/pdf/.gitignore new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/lib/ftp/doc/pdf/.gitignore diff --git a/lib/ftp/doc/src/Makefile b/lib/ftp/doc/src/Makefile new file mode 100644 index 0000000000..e96a9c032f --- /dev/null +++ b/lib/ftp/doc/src/Makefile @@ -0,0 +1,154 @@ +# +# %CopyrightBegin% +# +# Copyright Ericsson AB 1997-2018. 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=$(FTP_VSN) + +# ---------------------------------------------------- +# Release directory specification +# ---------------------------------------------------- +RELSYSDIR = $(RELEASE_PATH)/lib/$(APPLICATION)-$(VSN) + + +# ---------------------------------------------------- +# Target Specs +# ---------------------------------------------------- +XML_APPLICATION_FILES = ref_man.xml + +XML_CHAPTER_FILES = \ + introduction.xml \ + ftp_client.xml \ + notes.xml + +XML_REF3_FILES = \ + ftp.xml + +XML_PART_FILES = \ + part.xml + +BOOK_FILES = book.xml + +XML_FILES = \ + $(BOOK_FILES) \ + $(XML_CHAPTER_FILES) \ + $(XML_PART_FILES) \ + $(XML_REF6_FILES) \ + $(XML_REF3_FILES) \ + $(XML_APPLICATION_FILES) + +# GIF_FILES = ftp.gif + + +# ---------------------------------------------------- + +HTML_FILES = \ + $(XML_APPLICATION_FILES:%.xml=$(HTMLDIR)/%.html) \ + $(XML_PART_FILES:%.xml=$(HTMLDIR)/%.html) + +INFO_FILE = ../../info +EXTRA_FILES = \ + $(XML_REF3_FILES:%.xml=$(HTMLDIR)/%.html) \ + $(XML_REF6_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 += +DVIPS_FLAGS += + +# ---------------------------------------------------- +# Targets +# ---------------------------------------------------- +$(HTMLDIR)/%.gif: %.gif + $(INSTALL_DATA) $< $@ + +docs: pdf html man + +ldocs: local_docs + +$(TOP_PDF_FILE): $(XML_FILES) + +pdf: $(TOP_PDF_FILE) + +html: gifs $(HTML_REF_MAN_FILE) + +clean clean_docs: clean_html clean_man clean_pdf + rm -f errs core *~ + +man: $(MAN3_FILES) + +gifs: $(GIF_FILES:%=$(HTMLDIR)/%) + +debug opt: + +clean_pdf: + rm -f $(TOP_PDF_FILE) $(TOP_PDF_FILE:%.pdf=%.fo) + +clean_html: + rm -rf $(TOP_HTML_FILES) $(HTMLDIR)/* + +clean_man: + rm -f $(MAN3_FILES) + + +# ---------------------------------------------------- +# 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)" + $(INSTALL_DIR) "$(RELEASE_PATH)/man/man3" + $(INSTALL_DATA) $(MAN3DIR)/* "$(RELEASE_PATH)/man/man3" + +release_spec: + +info: + @echo "GIF_FILES:\n$(GIF_FILES)" + @echo "" + @echo "EXTRA_FILES:\n$(EXTRA_FILES)" + @echo "" + @echo "HTML_FILES:\n$(HTML_FILES)" + @echo "" + @echo "TOP_HTML_FILES:\n$(TOP_HTML_FILES)" + @echo "" + @echo "XML_REF3_FILES:\n$(XML_REF3_FILES)" + @echo "" + @echo "XML_REF6_FILES:\n$(XML_REF6_FILES)" + @echo "" + @echo "XML_CHAPTER_FILES:\n$(XML_CHAPTER_FILES)" + @echo "" diff --git a/lib/ftp/doc/src/book.xml b/lib/ftp/doc/src/book.xml new file mode 100644 index 0000000000..1268af64bf --- /dev/null +++ b/lib/ftp/doc/src/book.xml @@ -0,0 +1,49 @@ +<?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>1997</year><year>2018</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>FTP</title> + <prepared>Péter Dimitrov</prepared> + <docno></docno> + <date>2018-02-26</date> + <rev>1.0</rev> + <file>book.sgml</file> + </header> + <insidecover> + </insidecover> + <pagetext>FTP</pagetext> + <preamble> + <contents level="2"></contents> + </preamble> + <parts lift="no"> + <xi:include href="part.xml"/> + </parts> + <applications> + <xi:include href="ref_man.xml"/> + </applications> + <releasenotes> + <xi:include href="notes.xml"/> + </releasenotes> + <listofterms></listofterms> + <index></index> +</book> diff --git a/lib/inets/doc/src/ftp.xml b/lib/ftp/doc/src/ftp.xml index 42bece4d38..18770ebcb4 100644 --- a/lib/inets/doc/src/ftp.xml +++ b/lib/ftp/doc/src/ftp.xml @@ -38,20 +38,19 @@ according to a subset of the File Transfer Protocol (FTP), see <url href="http://www.ietf.org/rfc/rfc959.txt">RFC 959</url>.</p> - <p>As from <c>Inets</c> 4.4.1, the FTP - client always tries to use passive FTP mode and only resort + <p>The FTP client always tries to use passive FTP mode and only resort to active FTP mode if this fails. This default behavior can be changed by start option <seealso marker="#mode">mode</seealso>.</p> <marker id="two_start"></marker> <p>An FTP client can be started in two ways. One is using the - <seealso marker="#service_start">Inets service framework</seealso>, - the other is to start it directly as a standalone process + <seealso marker="#service_start">service_start</seealso> function, + the other is to start it directly as a standalone process using function <seealso marker="#open">open</seealso>.</p> <p>For a simple example of an FTP session, see - <seealso marker="ftp_client">Inets User's Guide</seealso>.</p> + <seealso marker="ftp_client">FTP User's Guide</seealso>.</p> <p>In addition to the ordinary functions for receiving and sending files (see <c>recv/2</c>, <c>recv/3</c>, <c>send/2</c>, and @@ -82,11 +81,9 @@ <title>FTP CLIENT SERVICE START/STOP</title> <p>The FTP client can be started and stopped dynamically in runtime by - calling the <c>Inets</c> application API - <c>inets:start(ftpc, ServiceConfig)</c>, - or <c>inets:start(ftpc, ServiceConfig, How)</c>, and - <c>inets:stop(ftpc, Pid)</c>. - For details, see <seealso marker="inets">inets(3)</seealso>.</p> + calling the <c>ftp</c> application API + <c>ftp:start_service(ServiceConfig)</c> and + <c>ftp:stop_service(Pid)</c>.</p> <p>The available configuration options are as follows:</p> @@ -273,6 +270,7 @@ </section> <funcs> + <func> <name>account(Pid, Account) -> ok | {error, Reason}</name> <fsummary>Specifies which account to use.</fsummary> @@ -564,7 +562,7 @@ <desc> <p>Starts a standalone FTP client process - (without the <c>Inets</c> service framework) and + (without the <c>ftp</c> service framework) and opens a session with the FTP server at <c>Host</c>. </p> <p>If option <c>{tls, tls_options()}</c> is present, the FTP session @@ -797,6 +795,37 @@ </func> <func> + <name>start_service(ServiceConfig) -> {ok, Pid} | {error, Reason}</name> + <fsummary>Dynamically starts an <c>FTP</c> + session after the <c>ftp</c> application has been started.</fsummary> + <type> + <v>ServiceConfig = [{Option, Value}]</v> + <v>Option = property()</v> + <v>Value = term()</v> + </type> + <desc> + <p>Dynamically starts an <c>FTP</c> session after the <c>ftp</c> + application has been started.</p> + <note> + <p>As long as the <c>ftp</c> application is operational, + the FTP sessions are supervised and can be soft code upgraded.</p> + </note> + </desc> + </func> + + <func> + <name>stop_service(Reference) -> ok | {error, Reason} </name> + <fsummary>Stops an FTP session.</fsummary> + <type> + <v>Reference = pid() | term() - service-specified reference</v> + <v>Reason = term()</v> + </type> + <desc> + <p>Stops a started FTP session.</p> + </desc> + </func> + + <func> <name>type(Pid, Type) -> ok | {error, Reason}</name> <fsummary>Sets transfer type to <c>ascii</c>or <c>binary</c>.</fsummary> <type> diff --git a/lib/inets/doc/src/ftp_client.xml b/lib/ftp/doc/src/ftp_client.xml index 990dd68604..047b055be7 100644 --- a/lib/inets/doc/src/ftp_client.xml +++ b/lib/ftp/doc/src/ftp_client.xml @@ -4,7 +4,7 @@ <chapter> <header> <copyright> - <year>2004</year><year>2016</year> + <year>2004</year><year>2018</year> <holder>Ericsson AB. All Rights Reserved.</holder> </copyright> <legalnotice> @@ -23,7 +23,7 @@ </legalnotice> <title>FTP Client</title> - <prepared>Ingela Anderton Andin</prepared> + <prepared>Péter Dimitrov</prepared> <responsible></responsible> <docno></docno> <approved></approved> @@ -53,9 +53,9 @@ the user <c>guest</c> with password <c>password</c> logs on to the remote host <c>erlang.org</c>:</p> <code type="erl"><![CDATA[ - 1> inets:start(). + 1> ftp:start(). ok - 2> {ok, Pid} = inets:start(ftpc, [{host, "erlang.org"}]). + 2> {ok, Pid} = ftp:start_service([{host, "erlang.org"}]). {ok,<0.22.0>} 3> ftp:user(Pid, "guest", "password"). ok @@ -69,7 +69,9 @@ ok 8> ftp:recv(Pid, "appl.erl"). ok - 9> inets:stop(ftpc, Pid). + 9> ftp:stop_service(Pid). + ok + 10> ftp:stop(). ok ]]></code> <p> The file @@ -82,5 +84,3 @@ <c>/home/guest/appl/examples</c>.</p> </section> </chapter> - - diff --git a/lib/ftp/doc/src/introduction.xml b/lib/ftp/doc/src/introduction.xml new file mode 100644 index 0000000000..cc3673a0fc --- /dev/null +++ b/lib/ftp/doc/src/introduction.xml @@ -0,0 +1,46 @@ +<?xml version="1.0" encoding="utf-8" ?> +<!DOCTYPE chapter SYSTEM "chapter.dtd"> + +<chapter> + <header> + <copyright> + <year>1997</year><year>2018</year> + <holder>Ericsson AB. All Rights Reserved.</holder> + </copyright> + <legalnotice> + The contents of this file are subject to the Erlang Public License, + Version 1.1, (the "License"); you may not use this file except in + compliance with the License. You should have received a copy of the + Erlang Public License along with this software. If not, it can be + retrieved online at http://www.erlang.org/. + + Software distributed under the License is distributed on an "AS IS" + basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + the License for the specific language governing rights and limitations + under the License. + + </legalnotice> + + <title>Introduction</title> + <prepared>Péter Dimitrov</prepared> + <responsible></responsible> + <docno></docno> + <approved></approved> + <checked></checked> + <date>2018-02-26</date> + <rev>A</rev> + <file>introduction.xml</file> + </header> + + <section> + <title>Purpose</title> + <p>An <c>FTP</c> client.</p> + </section> + + <section> + <title>Prerequisites</title> + <p>It is assumed that the reader is familiar with the Erlang + programming language, concepts of OTP, and has a basic + understanding of the FTP protocol.</p> + </section> +</chapter> diff --git a/lib/ftp/doc/src/notes.xml b/lib/ftp/doc/src/notes.xml new file mode 100644 index 0000000000..50f38941e5 --- /dev/null +++ b/lib/ftp/doc/src/notes.xml @@ -0,0 +1,53 @@ +<?xml version="1.0" encoding="utf-8" ?> +<!DOCTYPE chapter SYSTEM "chapter.dtd"> + +<chapter> + <header> + <copyright> + <year>2002</year><year>2018</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>FTP Release Notes</title> + <prepared></prepared> + <responsible></responsible> + <docno></docno> + <approved></approved> + <checked></checked> + <date>2018-02-26</date> + <rev>A</rev> + <file>notes.xml</file> + </header> + + <section><title>FTP 1.0</title> + + <section><title>First released version</title> + <list> + <item> + <p> + Inets application was split into multiple smaller protocol specific applications. + The FTP application is a standalone FTP client with the same functionality as + FTP client in Inets.</p> + <p> + Own Id: OTP-14113</p> + </item> + </list> + </section> + +</section> + +</chapter> diff --git a/lib/ftp/doc/src/part.xml b/lib/ftp/doc/src/part.xml new file mode 100644 index 0000000000..ec05f5ac76 --- /dev/null +++ b/lib/ftp/doc/src/part.xml @@ -0,0 +1,37 @@ +<?xml version="1.0" encoding="utf-8" ?> +<!DOCTYPE part SYSTEM "part.dtd"> + +<part xmlns:xi="http://www.w3.org/2001/XInclude"> + <header> + <copyright> + <year>2004</year><year>2018</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>FTP User's Guide</title> + <prepared>Péter Dimitrov</prepared> + <docno></docno> + <date>2018-02-26</date> + <rev>A</rev> + <file>part.sgml</file> + </header> + <description> + <p>The <c>FTP</c> application provides an FTP client.</p> + </description> + <xi:include href="introduction.xml"/> + <xi:include href="ftp_client.xml"/> +</part> diff --git a/lib/ftp/doc/src/ref_man.xml b/lib/ftp/doc/src/ref_man.xml new file mode 100644 index 0000000000..925842610d --- /dev/null +++ b/lib/ftp/doc/src/ref_man.xml @@ -0,0 +1,36 @@ +<?xml version="1.0" encoding="utf-8" ?> +<!DOCTYPE application SYSTEM "application.dtd"> + +<application xmlns:xi="http://www.w3.org/2001/XInclude"> + <header> + <copyright> + <year>1997</year><year>2018</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>FTP Reference Manual</title> + <prepared>Péter Dimitrov</prepared> + <docno></docno> + <date>2018-03-09</date> + <rev>1.0</rev> + <file>ref_man.xml</file> + </header> + <description> + <p>An <c>FTP</c> client.</p> + </description> + <xi:include href="ftp.xml"/> +</application> diff --git a/lib/ftp/ebin/.gitignore b/lib/ftp/ebin/.gitignore new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/lib/ftp/ebin/.gitignore diff --git a/lib/ftp/info b/lib/ftp/info new file mode 100644 index 0000000000..f6c62d19c2 --- /dev/null +++ b/lib/ftp/info @@ -0,0 +1,2 @@ +group: comm +short: FTP client diff --git a/lib/inets/src/ftp/Makefile b/lib/ftp/src/Makefile index 6b99694ea7..6a6df6bde4 100644 --- a/lib/inets/src/ftp/Makefile +++ b/lib/ftp/src/Makefile @@ -1,7 +1,7 @@ # # %CopyrightBegin% # -# Copyright Ericsson AB 2005-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. @@ -17,88 +17,102 @@ # # %CopyrightEnd% # + # include $(ERL_TOP)/make/target.mk -EBIN = ../../ebin include $(ERL_TOP)/make/$(TARGET)/otp.mk - # ---------------------------------------------------- # Application version # ---------------------------------------------------- -include ../../vsn.mk - -VSN = $(INETS_VSN) - +include ../vsn.mk +VSN=$(FTP_VSN) # ---------------------------------------------------- # Release directory specification # ---------------------------------------------------- -RELSYSDIR = $(RELEASE_PATH)/lib/$(APPLICATION)-$(VSN) - +RELSYSDIR = $(RELEASE_PATH)/lib/ftp-$(VSN) # ---------------------------------------------------- -# Target Specs +# Common Macros # ---------------------------------------------------- -MODULES = \ + +BEHAVIOUR_MODULES= + +MODULES= \ ftp \ + ftp_app \ ftp_progress \ ftp_response \ - ftp_sup + ftp_sup + + +INTERNAL_HRL_FILES = -HRL_FILES = ftp_internal.hrl +ERL_FILES= \ + $(MODULES:%=%.erl) \ + $(BEHAVIOUR_MODULES:%=%.erl) -ERL_FILES = $(MODULES:%=%.erl) TARGET_FILES= $(MODULES:%=$(EBIN)/%.$(EMULATOR)) +BEHAVIOUR_TARGET_FILES= $(BEHAVIOUR_MODULES:%=$(EBIN)/%.$(EMULATOR)) + +APP_FILE= ftp.app +APPUP_FILE= ftp.appup + +APP_SRC= $(APP_FILE).src +APP_TARGET= $(EBIN)/$(APP_FILE) +APPUP_SRC= $(APPUP_FILE).src +APPUP_TARGET= $(EBIN)/$(APPUP_FILE) # ---------------------------------------------------- # FLAGS # ---------------------------------------------------- - -include ../inets_app/inets.mk - -ifeq ($(FTP_DEBUG),true) - INETS_FLAGS += -Dftp_debug -endif - -ERL_COMPILE_FLAGS += \ - $(INETS_FLAGS) \ - $(INETS_ERL_COMPILE_FLAGS) \ - -I../../include \ - -I../inets_app +EXTRA_ERLC_FLAGS = +warn_unused_vars +ERL_COMPILE_FLAGS += -I$(ERL_TOP)/lib/kernel/src \ + -pz $(EBIN) \ + -pz $(ERL_TOP)/lib/public_key/ebin \ + $(EXTRA_ERLC_FLAGS) -DVSN=\"$(VSN)\" # ---------------------------------------------------- # Targets # ---------------------------------------------------- -debug opt: $(TARGET_FILES) +$(TARGET_FILES): $(BEHAVIOUR_TARGET_FILES) + +debug opt: $(TARGET_FILES) $(APP_TARGET) $(APPUP_TARGET) clean: - rm -f $(TARGET_FILES) - rm -f core + rm -f $(TARGET_FILES) $(APP_TARGET) $(APPUP_TARGET) $(BEHAVIOUR_TARGET_FILES) + rm -f errs core *~ + +$(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);' $< > $@ docs: + # ---------------------------------------------------- # Release Target # ---------------------------------------------------- include $(ERL_TOP)/make/otp_release_targets.mk release_spec: opt - $(INSTALL_DIR) "$(RELSYSDIR)/src" - $(INSTALL_DIR) "$(RELSYSDIR)/src/ftp" - $(INSTALL_DATA) $(HRL_FILES) $(ERL_FILES) "$(RELSYSDIR)/src/ftp" - $(INSTALL_DIR) "$(RELSYSDIR)/ebin" - $(INSTALL_DATA) $(TARGET_FILES) "$(RELSYSDIR)/ebin" + $(INSTALL_DIR) "$(RELSYSDIR)/src" + $(INSTALL_DATA) $(ERL_FILES) $(INTERNAL_HRL_FILES) "$(RELSYSDIR)/src" + $(INSTALL_DIR) "$(RELSYSDIR)/ebin" + $(INSTALL_DATA) $(BEHAVIOUR_TARGET_FILES) $(TARGET_FILES) $(APP_TARGET) \ + $(APPUP_TARGET) "$(RELSYSDIR)/ebin" release_docs_spec: -info: - @echo "APPLICATION = $(APPLICATION)" - @echo "INETS_DEBUG = $(INETS_DEBUG)" - @echo "INETS_FLAGS = $(INETS_FLAGS)" - @echo "ERL_COMPILE_FLAGS = $(ERL_COMPILE_FLAGS)" +# ---------------------------------------------------- +# Dependencies +# ---------------------------------------------------- + diff --git a/lib/ftp/src/ftp.app.src b/lib/ftp/src/ftp.app.src new file mode 100644 index 0000000000..237174358f --- /dev/null +++ b/lib/ftp/src/ftp.app.src @@ -0,0 +1,19 @@ +{application, ftp, + [{description, "FTP client"}, + {vsn, "1.0"}, + {registered, []}, + {mod, { ftp_app, []}}, + {applications, + [kernel, + stdlib + ]}, + {env,[]}, + {modules, [ + ftp, + ftp_app, + ftp_progress, + ftp_response, + ftp_sup + ]}, + {runtime_dependencies, ["erts-7.0","stdlib-3.5","kernel-6.0"]} + ]}. diff --git a/lib/compiler/src/v3_life.hrl b/lib/ftp/src/ftp.appup.src index 5c76312067..d79c7b60ff 100644 --- a/lib/compiler/src/v3_life.hrl +++ b/lib/ftp/src/ftp.appup.src @@ -1,8 +1,8 @@ -%% +%% -*- erlang -*- %% %CopyrightBegin% -%% -%% Copyright Ericsson AB 1999-2016. All Rights Reserved. -%% +%% +%% Copyright Ericsson AB 1999-2018. 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,16 +14,13 @@ %% 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 record contains variable life-time annotation for a -%% kernel expression. Added by v3_life, used by v3_codegen. - --type vdb_entry() :: {atom(),non_neg_integer(),non_neg_integer()}. - --record(l, {ke, %Kernel expression - i=0 :: non_neg_integer(), %Op number - vdb=[] :: [vdb_entry()], %Variable database - a=[] :: [term()]}). %Core annotation - +%% %CopyrightEnd% +{"%VSN%", + [ + {<<".*">>,[{restart_application, ftp}]} + ], + [ + {<<".*">>,[{restart_application, ftp}]} + ] +}. diff --git a/lib/inets/src/ftp/ftp.erl b/lib/ftp/src/ftp.erl index e0430654eb..8790bfec13 100644 --- a/lib/inets/src/ftp/ftp.erl +++ b/lib/ftp/src/ftp.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1997-2017. All Rights Reserved. +%% Copyright Ericsson AB 2002-2018. 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. @@ -18,14 +18,23 @@ %% %CopyrightEnd% %% %% -%% Description: This module implements an ftp client, RFC 959. -%% It also supports ipv6 RFC 2428 and starttls RFC 4217. -module(ftp). -behaviour(gen_server). --behaviour(inets_service). +-export([start/0, + start_service/1, + stop/0, + stop_service/1, + services/0, + service_info/1 + ]). + +%% Added for backward compatibility +-export([start_standalone/1]). + +-export([start_link/1, start_link/2]). %% API - Client interface -export([cd/2, close/1, delete/2, formaterror/1, @@ -47,13 +56,6 @@ -export([init/1, handle_call/3, handle_cast/2, handle_info/2, terminate/2, code_change/3]). -%% supervisor callbacks --export([start_link/1, start_link/2]). - -%% Behavior callbacks --export([start_standalone/1, start_service/1, - stop_service/1, services/0, service_info/1]). - -include("ftp_internal.hrl"). %% Constants used in internal state definition @@ -67,6 +69,11 @@ -define(FTP_PORT, 21). -define(FILE_BUFSIZE, 4096). + +%%%========================================================================= +%%% Data Types +%%%========================================================================= + %% Internal state -record(state, { csock = undefined, % socket() - Control connection socket @@ -116,6 +123,61 @@ %%-define(DBG(F,A), io:format(F,A)). %%-define(DBG(F,A), ct:pal("~p:~p " ++ if is_list(F) -> F; is_atom(F) -> atom_to_list(F) end, [?MODULE,?LINE|A])). + +%%%========================================================================= +%%% API +%%%========================================================================= + +start() -> + application:start(ftp). + +start_standalone(Options) -> + try + {ok, StartOptions} = start_options(Options), + {ok, OpenOptions} = open_options(Options), + case start_link(StartOptions, []) of + {ok, Pid} -> + call(Pid, {open, ip_comm, OpenOptions}, plain); + Error1 -> + Error1 + end + catch + throw:Error2 -> + Error2 + end. + +start_service(Options) -> + try + {ok, StartOptions} = start_options(Options), + {ok, OpenOptions} = open_options(Options), + case ftp_sup:start_child([[[{client, self()} | StartOptions], []]]) of + {ok, Pid} -> + call(Pid, {open, ip_comm, OpenOptions}, plain); + Error1 -> + Error1 + end + catch + throw:Error2 -> + Error2 + end. + +stop() -> + application:stop(ftp). + +stop_service(Pid) -> + close(Pid). + +services() -> + [{ftpc, Pid} || {_, Pid, _, _} <- + supervisor:which_children(ftp_sup)]. +service_info(Pid) -> + {ok, Info} = call(Pid, info, list), + {ok, [proplists:lookup(mode, Info), + proplists:lookup(local_port, Info), + proplists:lookup(peer, Info), + proplists:lookup(peer_port, Info)]}. + + %%%========================================================================= %%% API - CLIENT FUNCTIONS %%%========================================================================= @@ -162,22 +224,17 @@ open(Host, Port) when is_integer(Port) -> %% </BACKWARD-COMPATIBILLITY> open(Host, Opts) when is_list(Opts) -> - ?fcrt("open", [{host, Host}, {opts, Opts}]), try {ok, StartOptions} = start_options(Opts), - ?fcrt("open", [{start_options, StartOptions}]), {ok, OpenOptions} = open_options([{host, Host}|Opts]), - ?fcrt("open", [{open_options, OpenOptions}]), case start_link(StartOptions, []) of {ok, Pid} -> do_open(Pid, OpenOptions, tls_options(Opts)); Error1 -> - ?fcrt("open - error", [{error1, Error1}]), Error1 end catch throw:Error2 -> - ?fcrt("open - error", [{error2, Error2}]), Error2 end. @@ -872,219 +929,6 @@ info(Pid) -> latest_ctrl_response(Pid) -> call(Pid, latest_ctrl_response, string). -%%%======================================================================== -%%% Behavior callbacks -%%%======================================================================== -start_standalone(Options) -> - try - {ok, StartOptions} = start_options(Options), - {ok, OpenOptions} = open_options(Options), - case start_link(StartOptions, []) of - {ok, Pid} -> - call(Pid, {open, ip_comm, OpenOptions}, plain); - Error1 -> - Error1 - end - catch - throw:Error2 -> - Error2 - end. - -start_service(Options) -> - try - {ok, StartOptions} = start_options(Options), - {ok, OpenOptions} = open_options(Options), - case ftp_sup:start_child([[[{client, self()} | StartOptions], []]]) of - {ok, Pid} -> - call(Pid, {open, ip_comm, OpenOptions}, plain); - Error1 -> - Error1 - end - catch - throw:Error2 -> - Error2 - end. - -stop_service(Pid) -> - close(Pid). - -services() -> - [{ftpc, Pid} || {_, Pid, _, _} <- - supervisor:which_children(ftp_sup)]. -service_info(Pid) -> - {ok, Info} = call(Pid, info, list), - {ok, [proplists:lookup(mode, Info), - proplists:lookup(local_port, Info), - proplists:lookup(peer, Info), - proplists:lookup(peer_port, Info)]}. - - -%% This function extracts the start options from the -%% Valid options: -%% debug, -%% verbose -%% ipfamily -%% priority -%% flags (for backward compatibillity) -start_options(Options) -> - ?fcrt("start_options", [{options, Options}]), - case lists:keysearch(flags, 1, Options) of - {value, {flags, Flags}} -> - Verbose = lists:member(verbose, Flags), - IsTrace = lists:member(trace, Flags), - IsDebug = lists:member(debug, Flags), - DebugLevel = - if - (IsTrace =:= true) -> - trace; - IsDebug =:= true -> - debug; - true -> - disable - end, - {ok, [{verbose, Verbose}, - {debug, DebugLevel}, - {priority, low}]}; - false -> - ValidateVerbose = - fun(true) -> true; - (false) -> true; - (_) -> false - end, - ValidateDebug = - fun(trace) -> true; - (debug) -> true; - (disable) -> true; - (_) -> false - end, - ValidatePriority = - fun(low) -> true; - (normal) -> true; - (high) -> true; - (_) -> false - end, - ValidOptions = - [{verbose, ValidateVerbose, false, false}, - {debug, ValidateDebug, false, disable}, - {priority, ValidatePriority, false, low}], - validate_options(Options, ValidOptions, []) - end. - - -%% This function extracts and validates the open options from the -%% Valid options: -%% mode -%% host -%% port -%% timeout -%% dtimeout -%% progress -%% ftp_extension - -open_options(Options) -> - ?fcrt("open_options", [{options, Options}]), - ValidateMode = - fun(active) -> true; - (passive) -> true; - (_) -> false - end, - ValidateHost = - fun(Host) when is_list(Host) -> - true; - (Host) when is_tuple(Host) andalso - ((size(Host) =:= 4) orelse (size(Host) =:= 8)) -> - true; - (_) -> - false - end, - ValidatePort = - fun(Port) when is_integer(Port) andalso (Port > 0) -> true; - (_) -> false - end, - ValidateIpFamily = - fun(inet) -> true; - (inet6) -> true; - (inet6fb4) -> true; - (_) -> false - end, - ValidateTimeout = - fun(Timeout) when is_integer(Timeout) andalso (Timeout >= 0) -> true; - (_) -> false - end, - ValidateDTimeout = - fun(DTimeout) when is_integer(DTimeout) andalso (DTimeout >= 0) -> true; - (infinity) -> true; - (_) -> false - end, - ValidateProgress = - fun(ignore) -> - true; - ({Mod, Func, _InitProgress}) when is_atom(Mod) andalso - is_atom(Func) -> - true; - (_) -> - false - end, - ValidateFtpExtension = - fun(true) -> true; - (false) -> true; - (_) -> false - end, - ValidOptions = - [{mode, ValidateMode, false, ?DEFAULT_MODE}, - {host, ValidateHost, true, ehost}, - {port, ValidatePort, false, ?FTP_PORT}, - {ipfamily, ValidateIpFamily, false, inet}, - {timeout, ValidateTimeout, false, ?CONNECTION_TIMEOUT}, - {dtimeout, ValidateDTimeout, false, ?DATA_ACCEPT_TIMEOUT}, - {progress, ValidateProgress, false, ?PROGRESS_DEFAULT}, - {ftp_extension, ValidateFtpExtension, false, ?FTP_EXT_DEFAULT}], - validate_options(Options, ValidOptions, []). - -tls_options(Options) -> - %% Options will be validated by ssl application - proplists:get_value(tls, Options, undefined). - -validate_options([], [], Acc) -> - ?fcrt("validate_options -> done", [{acc, Acc}]), - {ok, lists:reverse(Acc)}; -validate_options([], ValidOptions, Acc) -> - ?fcrt("validate_options -> done", - [{valid_options, ValidOptions}, {acc, Acc}]), - %% Check if any mandatory options are missing! - case [{Key, Reason} || {Key, _, true, Reason} <- ValidOptions] of - [] -> - Defaults = - [{Key, Default} || {Key, _, _, Default} <- ValidOptions], - {ok, lists:reverse(Defaults ++ Acc)}; - [{_, Reason}|_Missing] -> - throw({error, Reason}) - end; -validate_options([{Key, Value}|Options], ValidOptions, Acc) -> - ?fcrt("validate_options -> check", - [{key, Key}, {value, Value}, {acc, Acc}]), - case lists:keysearch(Key, 1, ValidOptions) of - {value, {Key, Validate, _, Default}} -> - case (catch Validate(Value)) of - true -> - ?fcrt("validate_options -> check - accept", []), - NewValidOptions = lists:keydelete(Key, 1, ValidOptions), - validate_options(Options, NewValidOptions, - [{Key, Value} | Acc]); - _ -> - ?fcrt("validate_options -> check - reject", - [{default, Default}]), - NewValidOptions = lists:keydelete(Key, 1, ValidOptions), - validate_options(Options, NewValidOptions, - [{Key, Default} | Acc]) - end; - false -> - validate_options(Options, ValidOptions, Acc) - end; -validate_options([_|Options], ValidOptions, Acc) -> - validate_options(Options, ValidOptions, Acc). - - %%%======================================================================== %%% gen_server callback functions @@ -1183,7 +1027,6 @@ handle_call({Pid, _}, _, #state{owner = Owner} = State) when Owner =/= Pid -> {reply, {error, not_connection_owner}, State}; handle_call({_, {open, ip_comm, Opts}}, From, State) -> - ?fcrd("handle_call(open)", [{opts, Opts}]), case key_search(host, Opts, undefined) of undefined -> {stop, normal, {error, ehost}, State}; @@ -1203,16 +1046,10 @@ handle_call({_, {open, ip_comm, Opts}}, From, State) -> dtimeout = DTimeout, ftp_extension = FtpExt}, - ?fcrd("handle_call(open) -> setup ctrl connection with", - [{host, Host}, {port, Port}, {timeout, Timeout}]), case setup_ctrl_connection(Host, Port, Timeout, State2) of {ok, State3, WaitTimeout} -> - ?fcrd("handle_call(open) -> ctrl connection setup done", - [{waittimeout, WaitTimeout}]), {noreply, State3, WaitTimeout}; - {error, Reason} -> - ?fcrd("handle_call(open) -> ctrl connection setup failed", - [{reason, Reason}]), + {error, _Reason} -> gen_server:reply(From, {error, ehost}), {stop, normal, State2#state{client = undefined}} end @@ -1241,7 +1078,7 @@ handle_call({_, {open, ip_comm, Host, Opts}}, From, State) -> end; handle_call({_, {open, tls_upgrade, TLSOptions}}, From, State) -> - send_ctrl_message(State, mk_cmd("AUTH TLS", [])), + _ = send_ctrl_message(State, mk_cmd("AUTH TLS", [])), activate_ctrl_connection(State), {noreply, State#state{client = From, caller = open, tls_options = TLSOptions}}; @@ -1257,7 +1094,7 @@ handle_call({_, {account, Acc}}, From, State)-> handle_user_account(Acc, State#state{client = From}); handle_call({_, pwd}, From, #state{chunk = false} = State) -> - send_ctrl_message(State, mk_cmd("PWD", [])), + _ = send_ctrl_message(State, mk_cmd("PWD", [])), activate_ctrl_connection(State), {noreply, State#state{client = From, caller = pwd}}; @@ -1265,7 +1102,7 @@ handle_call({_, lpwd}, From, #state{ldir = LDir} = State) -> {reply, {ok, LDir}, State#state{client = From}}; handle_call({_, {cd, Dir}}, From, #state{chunk = false} = State) -> - send_ctrl_message(State, mk_cmd("CWD ~s", [Dir])), + _ = send_ctrl_message(State, mk_cmd("CWD ~s", [Dir])), activate_ctrl_connection(State), {noreply, State#state{client = From, caller = cd}}; @@ -1284,35 +1121,35 @@ handle_call({_, {dir, Len, Dir}}, {_Pid, _} = From, client = From}); handle_call({_, {rename, CurrFile, NewFile}}, From, #state{chunk = false} = State) -> - send_ctrl_message(State, mk_cmd("RNFR ~s", [CurrFile])), + _ = send_ctrl_message(State, mk_cmd("RNFR ~s", [CurrFile])), activate_ctrl_connection(State), {noreply, State#state{caller = {rename, NewFile}, client = From}}; handle_call({_, {delete, File}}, {_Pid, _} = From, #state{chunk = false} = State) -> - send_ctrl_message(State, mk_cmd("DELE ~s", [File])), + _ = send_ctrl_message(State, mk_cmd("DELE ~s", [File])), activate_ctrl_connection(State), {noreply, State#state{client = From}}; handle_call({_, {mkdir, Dir}}, From, #state{chunk = false} = State) -> - send_ctrl_message(State, mk_cmd("MKD ~s", [Dir])), + _ = send_ctrl_message(State, mk_cmd("MKD ~s", [Dir])), activate_ctrl_connection(State), {noreply, State#state{client = From}}; handle_call({_,{rmdir, Dir}}, From, #state{chunk = false} = State) -> - send_ctrl_message(State, mk_cmd("RMD ~s", [Dir])), + _ = send_ctrl_message(State, mk_cmd("RMD ~s", [Dir])), activate_ctrl_connection(State), {noreply, State#state{client = From}}; handle_call({_,{type, Type}}, From, #state{chunk = false} = State) -> case Type of ascii -> - send_ctrl_message(State, mk_cmd("TYPE A", [])), + _ = send_ctrl_message(State, mk_cmd("TYPE A", [])), activate_ctrl_connection(State), {noreply, State#state{caller = type, type = ascii, client = From}}; binary -> - send_ctrl_message(State, mk_cmd("TYPE I", [])), + _ = send_ctrl_message(State, mk_cmd("TYPE I", [])), activate_ctrl_connection(State), {noreply, State#state{caller = type, type = binary, client = From}}; @@ -1423,7 +1260,7 @@ handle_call({_, chunk_end}, _, #state{chunk = false} = State) -> {reply, {error, echunk}, State}; handle_call({_, {quote, Cmd}}, From, #state{chunk = false} = State) -> - send_ctrl_message(State, mk_cmd(Cmd, [])), + _ = send_ctrl_message(State, mk_cmd(Cmd, [])), activate_ctrl_connection(State), {noreply, State#state{client = From, caller = quote}}; @@ -1447,7 +1284,7 @@ handle_call(Request, _Timeout, State) -> %% Description: Handles cast messages. %%------------------------------------------------------------------------- handle_cast({Pid, close}, #state{owner = Pid} = State) -> - send_ctrl_message(State, mk_cmd("QUIT", [])), + _ = send_ctrl_message(State, mk_cmd("QUIT", [])), close_ctrl_connection(State), close_data_connection(State), {stop, normal, State#state{csock = undefined, dsock = undefined}}; @@ -1743,17 +1580,17 @@ start_link(Opts, GenServerOptions) -> %%-------------------------------------------------------------------------- %% User handling handle_user(User, Password, Acc, State) -> - send_ctrl_message(State, mk_cmd("USER ~s", [User])), + _ = send_ctrl_message(State, mk_cmd("USER ~s", [User])), activate_ctrl_connection(State), {noreply, State#state{caller = {handle_user, Password, Acc}}}. handle_user_passwd(Password, Acc, State) -> - send_ctrl_message(State, mk_cmd("PASS ~s", [Password])), + _ = send_ctrl_message(State, mk_cmd("PASS ~s", [Password])), activate_ctrl_connection(State), {noreply, State#state{caller = {handle_user_passwd, Acc}}}. handle_user_account(Acc, State) -> - send_ctrl_message(State, mk_cmd("ACCT ~s", [Acc])), + _ = send_ctrl_message(State, mk_cmd("ACCT ~s", [Acc])), activate_ctrl_connection(State), {noreply, State#state{caller = handle_user_account}}. @@ -1770,7 +1607,7 @@ handle_ctrl_result({tls_upgrade, _}, #state{csock = {tcp, Socket}, case ssl:connect(Socket, TLSOptions, Timeout) of {ok, TLSSocket} -> State = State0#state{csock = {ssl,TLSSocket}}, - send_ctrl_message(State, mk_cmd("PBSZ 0", [])), + _ = send_ctrl_message(State, mk_cmd("PBSZ 0", [])), activate_ctrl_connection(State), {noreply, State#state{tls_upgrading_data_connection = {true, pbsz}} }; {error, _} = Error -> @@ -1781,7 +1618,7 @@ handle_ctrl_result({tls_upgrade, _}, #state{csock = {tcp, Socket}, end; handle_ctrl_result({pos_compl, _}, #state{tls_upgrading_data_connection = {true, pbsz}} = State) -> - send_ctrl_message(State, mk_cmd("PROT P", [])), + _ = send_ctrl_message(State, mk_cmd("PROT P", [])), activate_ctrl_connection(State), {noreply, State#state{tls_upgrading_data_connection = {true, prot}}}; @@ -1975,7 +1812,7 @@ handle_ctrl_result({pos_compl, Lines}, #state{caller = {handle_dir_data, Dir, DirData}} = State) -> OldDir = pwd_result(Lines), - send_ctrl_message(State, mk_cmd("CWD ~s", [Dir])), + _ = send_ctrl_message(State, mk_cmd("CWD ~s", [Dir])), activate_ctrl_connection(State), {noreply, State#state{caller = {handle_dir_data_second_phase, OldDir, DirData}}}; @@ -1991,7 +1828,7 @@ handle_ctrl_result(S={_Status, _}, handle_ctrl_result({pos_compl, _}, #state{caller = {handle_dir_data_second_phase, OldDir, DirData}} = State) -> - send_ctrl_message(State, mk_cmd("CWD ~s", [OldDir])), + _ = send_ctrl_message(State, mk_cmd("CWD ~s", [OldDir])), activate_ctrl_connection(State), {noreply, State#state{caller = {handle_dir_data_third_phase, DirData}}}; handle_ctrl_result({Status, _}, @@ -2013,7 +1850,7 @@ handle_ctrl_result(Status={epath, _}, #state{caller = {dir,_}} = State) -> %% File renaming handle_ctrl_result({pos_interm, _}, #state{caller = {rename, NewFile}} = State) -> - send_ctrl_message(State, mk_cmd("RNTO ~s", [NewFile])), + _ = send_ctrl_message(State, mk_cmd("RNTO ~s", [NewFile])), activate_ctrl_connection(State), {noreply, State#state{caller = rename_second_phase}}; @@ -2190,28 +2027,28 @@ handle_caller(#state{caller = {dir, Dir, Len}} = State) -> short -> "NLST"; long -> "LIST" end, - case Dir of - "" -> - send_ctrl_message(State, mk_cmd(Cmd, "")); - _ -> - send_ctrl_message(State, mk_cmd(Cmd ++ " ~s", [Dir])) - end, + _ = case Dir of + "" -> + send_ctrl_message(State, mk_cmd(Cmd, "")); + _ -> + send_ctrl_message(State, mk_cmd(Cmd ++ " ~s", [Dir])) + end, activate_ctrl_connection(State), {noreply, State#state{caller = {dir, Dir}}}; handle_caller(#state{caller = {recv_bin, RemoteFile}} = State) -> - send_ctrl_message(State, mk_cmd("RETR ~s", [RemoteFile])), + _ = send_ctrl_message(State, mk_cmd("RETR ~s", [RemoteFile])), activate_ctrl_connection(State), {noreply, State#state{caller = recv_bin}}; handle_caller(#state{caller = {start_chunk_transfer, Cmd, RemoteFile}} = State) -> - send_ctrl_message(State, mk_cmd("~s ~s", [Cmd, RemoteFile])), + _ = send_ctrl_message(State, mk_cmd("~s ~s", [Cmd, RemoteFile])), activate_ctrl_connection(State), {noreply, State#state{caller = start_chunk_transfer}}; handle_caller(#state{caller = {recv_file, RemoteFile, Fd}} = State) -> - send_ctrl_message(State, mk_cmd("RETR ~s", [RemoteFile])), + _ = send_ctrl_message(State, mk_cmd("RETR ~s", [RemoteFile])), activate_ctrl_connection(State), {noreply, State#state{caller = {recv_file, Fd}}}; @@ -2219,7 +2056,7 @@ handle_caller(#state{caller = {transfer_file, {Cmd, LocalFile, RemoteFile}}, ldir = LocalDir, client = From} = State) -> case file_open(filename:absname(LocalFile, LocalDir), read) of {ok, Fd} -> - send_ctrl_message(State, mk_cmd("~s ~s", [Cmd, RemoteFile])), + _ = send_ctrl_message(State, mk_cmd("~s ~s", [Cmd, RemoteFile])), activate_ctrl_connection(State), {noreply, State#state{caller = {transfer_file, Fd}}}; {error, _} -> @@ -2230,7 +2067,7 @@ handle_caller(#state{caller = {transfer_file, {Cmd, LocalFile, RemoteFile}}, handle_caller(#state{caller = {transfer_data, {Cmd, Bin, RemoteFile}}} = State) -> - send_ctrl_message(State, mk_cmd("~s ~s", [Cmd, RemoteFile])), + _ = send_ctrl_message(State, mk_cmd("~s ~s", [Cmd, RemoteFile])), activate_ctrl_connection(State), {noreply, State#state{caller = {transfer_data, Bin}}}. @@ -2244,7 +2081,7 @@ setup_ctrl_connection(Host, Port, Timeout, State) -> {ok, IpFam, CSock} -> NewState = State#state{csock = {tcp, CSock}, ipfamily = IpFam}, activate_ctrl_connection(NewState), - case Timeout - inets_lib:millisec_passed(MsTime) of + case Timeout - millisec_passed(MsTime) of Timeout2 when (Timeout2 >= 0) -> {ok, NewState#state{caller = open}, Timeout2}; _ -> @@ -2267,7 +2104,7 @@ setup_data_connection(#state{mode = active, {ok, {_, Port}} = sockname({tcp,LSock}), IpAddress = inet_parse:ntoa(IP), Cmd = mk_cmd("EPRT |2|~s|~p|", [IpAddress, Port]), - send_ctrl_message(State, Cmd), + _ = send_ctrl_message(State, Cmd), activate_ctrl_connection(State), {noreply, State#state{caller = {setup_data_connection, {LSock, Caller}}}}; @@ -2275,18 +2112,18 @@ setup_data_connection(#state{mode = active, {ok, LSock} = gen_tcp:listen(0, [{ip, IP}, {active, false}, binary, {packet, 0}]), {ok, Port} = inet:port(LSock), - case FtpExt of - false -> - {IP1, IP2, IP3, IP4} = IP, - {Port1, Port2} = {Port div 256, Port rem 256}, - send_ctrl_message(State, - mk_cmd("PORT ~w,~w,~w,~w,~w,~w", - [IP1, IP2, IP3, IP4, Port1, Port2])); - true -> - IpAddress = inet_parse:ntoa(IP), - Cmd = mk_cmd("EPRT |1|~s|~p|", [IpAddress, Port]), - send_ctrl_message(State, Cmd) - end, + _ = case FtpExt of + false -> + {IP1, IP2, IP3, IP4} = IP, + {Port1, Port2} = {Port div 256, Port rem 256}, + send_ctrl_message(State, + mk_cmd("PORT ~w,~w,~w,~w,~w,~w", + [IP1, IP2, IP3, IP4, Port1, Port2])); + true -> + IpAddress = inet_parse:ntoa(IP), + Cmd = mk_cmd("EPRT |1|~s|~p|", [IpAddress, Port]), + send_ctrl_message(State, Cmd) + end, activate_ctrl_connection(State), {noreply, State#state{caller = {setup_data_connection, {LSock, Caller}}}} @@ -2294,21 +2131,21 @@ setup_data_connection(#state{mode = active, setup_data_connection(#state{mode = passive, ipfamily = inet6, caller = Caller} = State) -> - send_ctrl_message(State, mk_cmd("EPSV", [])), + _ = send_ctrl_message(State, mk_cmd("EPSV", [])), activate_ctrl_connection(State), {noreply, State#state{caller = {setup_data_connection, Caller}}}; setup_data_connection(#state{mode = passive, ipfamily = inet, caller = Caller, ftp_extension = false} = State) -> - send_ctrl_message(State, mk_cmd("PASV", [])), + _ = send_ctrl_message(State, mk_cmd("PASV", [])), activate_ctrl_connection(State), {noreply, State#state{caller = {setup_data_connection, Caller}}}; setup_data_connection(#state{mode = passive, ipfamily = inet, caller = Caller, ftp_extension = true} = State) -> - send_ctrl_message(State, mk_cmd("EPSV", [])), + _ = send_ctrl_message(State, mk_cmd("EPSV", [])), activate_ctrl_connection(State), {noreply, State#state{caller = {setup_data_connection, Caller}}}. @@ -2594,3 +2431,166 @@ start_chunk(#state{client = From} = State) -> State#state{chunk = true, client = undefined, caller = undefined}. + + +%% This function extracts the start options from the +%% Valid options: +%% debug, +%% verbose +%% ipfamily +%% priority +%% flags (for backward compatibillity) +start_options(Options) -> + case lists:keysearch(flags, 1, Options) of + {value, {flags, Flags}} -> + Verbose = lists:member(verbose, Flags), + IsTrace = lists:member(trace, Flags), + IsDebug = lists:member(debug, Flags), + DebugLevel = + if + (IsTrace =:= true) -> + trace; + IsDebug =:= true -> + debug; + true -> + disable + end, + {ok, [{verbose, Verbose}, + {debug, DebugLevel}, + {priority, low}]}; + false -> + ValidateVerbose = + fun(true) -> true; + (false) -> true; + (_) -> false + end, + ValidateDebug = + fun(trace) -> true; + (debug) -> true; + (disable) -> true; + (_) -> false + end, + ValidatePriority = + fun(low) -> true; + (normal) -> true; + (high) -> true; + (_) -> false + end, + ValidOptions = + [{verbose, ValidateVerbose, false, false}, + {debug, ValidateDebug, false, disable}, + {priority, ValidatePriority, false, low}], + validate_options(Options, ValidOptions, []) + end. + + +%% This function extracts and validates the open options from the +%% Valid options: +%% mode +%% host +%% port +%% timeout +%% dtimeout +%% progress +%% ftp_extension + +open_options(Options) -> + ValidateMode = + fun(active) -> true; + (passive) -> true; + (_) -> false + end, + ValidateHost = + fun(Host) when is_list(Host) -> + true; + (Host) when is_tuple(Host) andalso + ((size(Host) =:= 4) orelse (size(Host) =:= 8)) -> + true; + (_) -> + false + end, + ValidatePort = + fun(Port) when is_integer(Port) andalso (Port > 0) -> true; + (_) -> false + end, + ValidateIpFamily = + fun(inet) -> true; + (inet6) -> true; + (inet6fb4) -> true; + (_) -> false + end, + ValidateTimeout = + fun(Timeout) when is_integer(Timeout) andalso (Timeout >= 0) -> true; + (_) -> false + end, + ValidateDTimeout = + fun(DTimeout) when is_integer(DTimeout) andalso (DTimeout >= 0) -> true; + (infinity) -> true; + (_) -> false + end, + ValidateProgress = + fun(ignore) -> + true; + ({Mod, Func, _InitProgress}) when is_atom(Mod) andalso + is_atom(Func) -> + true; + (_) -> + false + end, + ValidateFtpExtension = + fun(true) -> true; + (false) -> true; + (_) -> false + end, + ValidOptions = + [{mode, ValidateMode, false, ?DEFAULT_MODE}, + {host, ValidateHost, true, ehost}, + {port, ValidatePort, false, ?FTP_PORT}, + {ipfamily, ValidateIpFamily, false, inet}, + {timeout, ValidateTimeout, false, ?CONNECTION_TIMEOUT}, + {dtimeout, ValidateDTimeout, false, ?DATA_ACCEPT_TIMEOUT}, + {progress, ValidateProgress, false, ?PROGRESS_DEFAULT}, + {ftp_extension, ValidateFtpExtension, false, ?FTP_EXT_DEFAULT}], + validate_options(Options, ValidOptions, []). + +tls_options(Options) -> + %% Options will be validated by ssl application + proplists:get_value(tls, Options, undefined). + +validate_options([], [], Acc) -> + {ok, lists:reverse(Acc)}; +validate_options([], ValidOptions, Acc) -> + %% Check if any mandatory options are missing! + case [{Key, Reason} || {Key, _, true, Reason} <- ValidOptions] of + [] -> + Defaults = + [{Key, Default} || {Key, _, _, Default} <- ValidOptions], + {ok, lists:reverse(Defaults ++ Acc)}; + [{_, Reason}|_Missing] -> + throw({error, Reason}) + end; +validate_options([{Key, Value}|Options], ValidOptions, Acc) -> + case lists:keysearch(Key, 1, ValidOptions) of + {value, {Key, Validate, _, Default}} -> + case (catch Validate(Value)) of + true -> + NewValidOptions = lists:keydelete(Key, 1, ValidOptions), + validate_options(Options, NewValidOptions, + [{Key, Value} | Acc]); + _ -> + NewValidOptions = lists:keydelete(Key, 1, ValidOptions), + validate_options(Options, NewValidOptions, + [{Key, Default} | Acc]) + end; + false -> + validate_options(Options, ValidOptions, Acc) + end; +validate_options([_|Options], ValidOptions, Acc) -> + validate_options(Options, ValidOptions, Acc). + +%% Help function, elapsed milliseconds since T0 +millisec_passed(T0) -> + %% OTP 18 + erlang:convert_time_unit(erlang:monotonic_time() - T0, + native, + micro_seconds) div 1000. diff --git a/lib/ftp/src/ftp_app.erl b/lib/ftp/src/ftp_app.erl new file mode 100644 index 0000000000..d647d9fce3 --- /dev/null +++ b/lib/ftp/src/ftp_app.erl @@ -0,0 +1,47 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2002-2018. 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% +%% +%% + +%%%------------------------------------------------------------------- +%% @doc ftp public API +%% @end +%%%------------------------------------------------------------------- + +-module(ftp_app). + +-behaviour(application). + +%% Application callbacks +-export([start/2, stop/1]). + +%%==================================================================== +%% API +%%==================================================================== + +start(_StartType, _StartArgs) -> + ftp_sup:start_link(). + +%%-------------------------------------------------------------------- +stop(_State) -> + ok. + +%%==================================================================== +%% Internal functions +%%==================================================================== diff --git a/lib/inets/src/ftp/ftp_internal.hrl b/lib/ftp/src/ftp_internal.hrl index f29bb4a099..84f980e8fd 100644 --- a/lib/inets/src/ftp/ftp_internal.hrl +++ b/lib/ftp/src/ftp_internal.hrl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2005-2016. All Rights Reserved. +%% Copyright Ericsson AB 2005-2018. 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. @@ -22,12 +22,14 @@ -ifndef(ftp_internal_hrl). -define(ftp_internal_hrl, true). --include_lib("inets/src/inets_app/inets_internal.hrl"). - --define(SERVICE, ftpc). --define(fcri(Label, Content), ?report_important(Label, ?SERVICE, Content)). --define(fcrv(Label, Content), ?report_verbose(Label, ?SERVICE, Content)). --define(fcrd(Label, Content), ?report_debug(Label, ?SERVICE, Content)). --define(fcrt(Label, Content), ?report_trace(Label, ?SERVICE, Content)). +-define(CR, $\r). +-define(LF, $\n). +-define(CRLF, [$\r,$\n]). +-define(SP, $\s). +-define(TAB, $\t). +-define(LEFT_PAREN, $(). +-define(RIGHT_PAREN, $)). +-define(WHITE_SPACE, $ ). +-define(DOUBLE_QUOTE, $"). -endif. % -ifdef(ftp_internal_hrl). diff --git a/lib/inets/src/ftp/ftp_progress.erl b/lib/ftp/src/ftp_progress.erl index a6263e5cd7..a6263e5cd7 100644 --- a/lib/inets/src/ftp/ftp_progress.erl +++ b/lib/ftp/src/ftp_progress.erl diff --git a/lib/inets/src/ftp/ftp_response.erl b/lib/ftp/src/ftp_response.erl index d54d97dc91..d54d97dc91 100644 --- a/lib/inets/src/ftp/ftp_response.erl +++ b/lib/ftp/src/ftp_response.erl diff --git a/lib/ftp/src/ftp_sup.erl b/lib/ftp/src/ftp_sup.erl new file mode 100644 index 0000000000..f30046802f --- /dev/null +++ b/lib/ftp/src/ftp_sup.erl @@ -0,0 +1,68 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2002-2018. 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% +%% +%% + +%%%------------------------------------------------------------------- +%% @doc ftp top level supervisor. +%% @end +%%%------------------------------------------------------------------- + +-module(ftp_sup). + +-behaviour(supervisor). + +%% API +-export([start_child/1, start_link/0]). + +%% Supervisor callbacks +-export([init/1]). + +-define(SERVER, ?MODULE). + +%%==================================================================== +%% API functions +%%==================================================================== + +start_link() -> + supervisor:start_link({local, ?SERVER}, ?MODULE, []). + +start_child(Args) -> + supervisor:start_child(?MODULE, Args). + +%%==================================================================== +%% Supervisor callbacks +%%==================================================================== +init(_) -> + SupFlags = #{strategy => simple_one_for_one, + intensity => 0, + period => 3600}, + {ok, {SupFlags, child_specs()}}. + + +%%==================================================================== +%% Internal functions +%%==================================================================== +child_specs() -> + [#{id => undefined, + start => {ftp, start_link, []}, + restart => temporary, + shutdown => 4000, + type => worker, + modules => [ftp]}]. diff --git a/lib/ftp/test/Makefile b/lib/ftp/test/Makefile new file mode 100644 index 0000000000..147f8e5dd6 --- /dev/null +++ b/lib/ftp/test/Makefile @@ -0,0 +1,251 @@ +# +# %CopyrightBegin% +# +# Copyright Ericsson AB 1997-2018. 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% +# +# +# For an outline of how this all_SUITE_data stuff works, see the +# make file ../../ssl/test/Makefile. +# +include $(ERL_TOP)/make/target.mk +include $(ERL_TOP)/make/$(TARGET)/otp.mk + +# ---------------------------------------------------- +# Application version +# ---------------------------------------------------- +include ../vsn.mk +VSN = $(FTP_VSN) + + +# ---------------------------------------------------- +# Release directory specification +# ---------------------------------------------------- +RELSYSDIR = $(RELEASE_PATH)/lib/$(APPLICATION)-$(VSN) + + +# ---------------------------------------------------- +# Target Specs +# ---------------------------------------------------- +INCLUDES = -I. \ + -I$(ERL_TOP)/lib/ftp/src + +CP = cp + +ifeq ($(TESTROOT_DIR),) +TESTROOT_DIR = /ldisk/tests/$(USER)/ftp +endif + +ifeq ($(FTP_DATA_DIR),) +FTP_DATA_DIR = $(TESTROOT_DIR)/data_dir +endif + +ifeq ($(FTP_PRIV_DIR),) +FTP_PRIV_DIR = $(TESTROOT_DIR)/priv_dir +endif + +FTP_FLAGS = -Dftp__data_dir='"$(FTP_DATA_DIR)"' \ + -Dftp_priv_dir='"$(FTP_PRIV_DIR)"' + + +### +### test suite debug flags +### +ifeq ($(FTP_DEBUG_CLIENT),) + FTP_DEBUG_CLIENT = y +endif + +ifeq ($(FTP_DEBUG_CLIENT),) + FTP_FLAGS += -Dftp_debug_client +endif + +ifeq ($(FTP_TRACE_CLIENT),) + FTP_DEBUG_CLIENT = y +endif + +ifeq ($(FTP_TRACE_CLIENT),y) + FTP_FLAGS += -Dftp_trace_client +endif + +ifneq ($(FTP_DEBUG),) + FTP_DEBUG = s +endif + +ifeq ($(FTP_DEBUG),l) + FTP_FLAGS += -Dftp_log +endif + +ifeq ($(FTP_DEBUG),d) + FTP_FLAGS += -Dftp_debug -Dftp_log +endif + + +FTP_FLAGS += -pa ../ftp/ebin + +FTP_ROOT = ../ftp + +MODULES = \ + erl_make_certs \ + ftp_SUITE \ + ftp_format_SUITE \ + ftp_test_lib + + +EBIN = . + +HRL_FILES = \ + ftp_internal.hrl + +ERL_FILES = $(MODULES:%=%.erl) + +SOURCE = $(ERL_FILES) $(HRL_FILES) + +TARGET_FILES = $(MODULES:%=$(EBIN)/%.$(EMULATOR)) + +FTP_SPECS = ftp.spec ftp_bench.spec +COVER_FILE = ftp.cover +FTP_FILES = ftp.config $(FTP_SPECS) + + +FTP_DATADIRS = ftp_SUITE_data + +DATADIRS = $(FTP_DATADIRS) + +EMAKEFILE = Emakefile +MAKE_EMAKE = $(wildcard $(ERL_TOP)/make/make_emakefile) + +ifeq ($(MAKE_EMAKE),) +BUILDTARGET = $(TARGET_FILES) +RELTEST_FILES = $(COVER_FILE) $(FTP_SPECS) $(SOURCE) +else +BUILDTARGET = emakebuild +RELTEST_FILES = $(EMAKEFILE) $(COVER_FILE) $(FTP_SPECS) $(SOURCE) +endif + + +# ---------------------------------------------------- +# Release directory specification +# ---------------------------------------------------- + +RELTESTSYSDIR = "$(RELEASE_PATH)/ftp_test" +RELTESTSYSALLDATADIR = $(RELTESTSYSDIR)/all_SUITE_data +RELTESTSYSBINDIR = $(RELTESTSYSALLDATADIR)/bin + + +# ---------------------------------------------------- +# FLAGS +# The path to the test_server ebin dir is needed when +# running the target "targets". +# ---------------------------------------------------- +ERL_COMPILE_FLAGS += \ + $(INCLUDES) \ + $(FTP_FLAGS) + +# ---------------------------------------------------- +# Targets +# erl -sname kalle -pa ../ebin +# If you intend to run the test suite locally (private), then +# there is some requirements: +# 1) FTP_PRIV_DIR must be created +# ---------------------------------------------------- + +tests debug opt: $(BUILDTARGET) + +targets: $(TARGET_FILES) + +.PHONY: emakebuild + +emakebuild: $(EMAKEFILE) + +$(EMAKEFILE): + $(MAKE_EMAKE) $(ERL_COMPILE_FLAGS) -o$(EBIN) '*_SUITE_make' | grep -v Warning > $(EMAKEFILE) + $(MAKE_EMAKE) $(ERL_COMPILE_FLAGS) -o$(EBIN) $(MODULES) | grep -v Warning >> $(EMAKEFILE) + +clean: + rm -f $(EMAKEFILE) + rm -f $(TARGET_FILES) + rm -f core *~ + +docs: + + +# ---------------------------------------------------- +# Release Target +# ---------------------------------------------------- +include $(ERL_TOP)/make/otp_release_targets.mk + +release_spec: opt + $(INSTALL_DIR) "$(RELSYSDIR)/test" + $(INSTALL_DATA) $(HRL_FILES) $(ERL_FILES) "$(RELSYSDIR)/test" + $(INSTALL_DATA) $(FTP_FILES) "$(RELSYSDIR)/test" + @for d in $(DATADIRS); do \ + echo "installing data dir $$d"; \ + if test -f $$d/TAR.exclude; then \ + echo $$d/TAR.exclude2 > $$d/TAR.exclude2; \ + cat $$d/TAR.exclude >> $$d/TAR.exclude2; \ + find $$d -name '*.contrib*' >> $$d/TAR.exclude2; \ + find $$d -name '*.keep*' >> $$d/TAR.exclude2; \ + find $$d -name '*.mkelem*' >> $$d/TAR.exclude2; \ + find $$d -name '*~' >> $$d/TAR.exclude2; \ + find $$d -name 'erl_crash.dump' >> $$d/TAR.exclude2; \ + find $$d -name 'core' >> $$d/TAR.exclude2; \ + find $$d -name '.cmake.state' >> $$d/TAR.exclude2; \ + tar cfX - $$d/TAR.exclude2 $$d | (cd "$(RELSYSDIR)/test"; tar xf -); \ + else \ + tar cf - $$d | (cd "$(RELSYSDIR)/test"; tar xf -); \ + fi; \ + done + +release_tests_spec: opt + $(INSTALL_DIR) $(RELTESTSYSDIR) + $(INSTALL_DATA) $(RELTEST_FILES) $(RELTESTSYSDIR) + chmod -R u+w $(RELTESTSYSDIR) + tar chf - $(DATADIRS) | (cd $(RELTESTSYSDIR); tar xf -) + $(INSTALL_DIR) $(RELTESTSYSALLDATADIR) + $(INSTALL_DIR) $(RELTESTSYSBINDIR) + chmod -R +x $(RELTESTSYSBINDIR) + $(INSTALL_DIR) $(RELTESTSYSALLDATADIR)/win32/lib + +release_docs_spec: + +info: + @echo "MAKE_EMAKE = $(MAKE_EMAKE)" + @echo "EMAKEFILE = $(EMAKEFILE)" + @echo "BUILDTARGET = $(BUILDTARGET)" + @echo "" + @echo "MODULES = $(MODULES)" + @echo "ERL_FILES = $(ERL_FILES)" + @echo "SOURCE = $(SOURCE)" + @echo "TARGET_FILES = $(TARGET_FILES)" + @echo "" + @echo "FTP_SPECS = $(FTP_SPECS)" + @echo "FTP_FILES = $(FTP_FILES)" + @echo "" + @echo "RELEASE_PATH = "$(RELEASE_PATH)"" + @echo "RELSYSDIR = "$(RELSYSDIR)"" + @echo "RELTESTSYSDIR = $(RELTESTSYSDIR)" + @echo "RELTESTSYSALLDATADIR = $(RELTESTSYSALLDATADIR)" + @echo "RELTESTSYSBINDIR = $(RELTESTSYSBINDIR)" + @echo "" + @echo "DATADIRS = $(DATADIRS)" + @echo "REL_DATADIRS = $(REL_DATADIRS)" + @echo "" + @echo "FTP_DATA_DIR = $(FTP_DATA_DIR)" + @echo "FTP_PRIV_DIR = $(FTP_PRIV_DIR)" + @echo "FTP_ROOT = $(FTP_ROOT)" + @echo "FTP_FLAGS = $(FTP_FLAGS)" + + diff --git a/lib/ftp/test/erl_make_certs.erl b/lib/ftp/test/erl_make_certs.erl new file mode 100644 index 0000000000..2db95825bc --- /dev/null +++ b/lib/ftp/test/erl_make_certs.erl @@ -0,0 +1,475 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2011-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% +%% + +%% Create test certificates + +-module(erl_make_certs). +-include_lib("public_key/include/public_key.hrl"). + +-export([make_cert/1, gen_rsa/1, verify_signature/3, write_pem/3]). +-compile(export_all). + +%%-------------------------------------------------------------------- +%% @doc Create and return a der encoded certificate +%% Option Default +%% ------------------------------------------------------- +%% digest sha1 +%% validity {date(), date() + week()} +%% version 3 +%% subject [] list of the following content +%% {name, Name} +%% {email, Email} +%% {city, City} +%% {state, State} +%% {org, Org} +%% {org_unit, OrgUnit} +%% {country, Country} +%% {serial, Serial} +%% {title, Title} +%% {dnQualifer, DnQ} +%% issuer = {Issuer, IssuerKey} true (i.e. a ca cert is created) +%% (obs IssuerKey migth be {Key, Password} +%% key = KeyFile|KeyBin|rsa|dsa|ec Subject PublicKey rsa, dsa or ec generates key +%% +%% +%% (OBS: The generated keys are for testing only) +%% @spec ([{::atom(), ::term()}]) -> {Cert::binary(), Key::binary()} +%% @end +%%-------------------------------------------------------------------- + +make_cert(Opts) -> + SubjectPrivateKey = get_key(Opts), + {TBSCert, IssuerKey} = make_tbs(SubjectPrivateKey, Opts), + Cert = public_key:pkix_sign(TBSCert, IssuerKey), + true = verify_signature(Cert, IssuerKey, undef), %% verify that the keys where ok + {Cert, encode_key(SubjectPrivateKey)}. + +%%-------------------------------------------------------------------- +%% @doc Writes pem files in Dir with FileName ++ ".pem" and FileName ++ "_key.pem" +%% @spec (::string(), ::string(), {Cert,Key}) -> ok +%% @end +%%-------------------------------------------------------------------- +write_pem(Dir, FileName, {Cert, Key = {_,_,not_encrypted}}) when is_binary(Cert) -> + ok = der_to_pem(filename:join(Dir, FileName ++ ".pem"), + [{'Certificate', Cert, not_encrypted}]), + ok = der_to_pem(filename:join(Dir, FileName ++ "_key.pem"), [Key]). + +%%-------------------------------------------------------------------- +%% @doc Creates a rsa key (OBS: for testing only) +%% the size are in bytes +%% @spec (::integer()) -> {::atom(), ::binary(), ::opaque()} +%% @end +%%-------------------------------------------------------------------- +gen_rsa(Size) when is_integer(Size) -> + Key = gen_rsa2(Size), + {Key, encode_key(Key)}. + +%%-------------------------------------------------------------------- +%% @doc Creates a dsa key (OBS: for testing only) +%% the sizes are in bytes +%% @spec (::integer()) -> {::atom(), ::binary(), ::opaque()} +%% @end +%%-------------------------------------------------------------------- +gen_dsa(LSize,NSize) when is_integer(LSize), is_integer(NSize) -> + Key = gen_dsa2(LSize, NSize), + {Key, encode_key(Key)}. + +%%-------------------------------------------------------------------- +%% @doc Creates a ec key (OBS: for testing only) +%% the sizes are in bytes +%% @spec (::integer()) -> {::atom(), ::binary(), ::opaque()} +%% @end +%%-------------------------------------------------------------------- +gen_ec(Curve) when is_atom(Curve) -> + Key = gen_ec2(Curve), + {Key, encode_key(Key)}. + +%%-------------------------------------------------------------------- +%% @doc Verifies cert signatures +%% @spec (::binary(), ::tuple()) -> ::boolean() +%% @end +%%-------------------------------------------------------------------- +verify_signature(DerEncodedCert, DerKey, _KeyParams) -> + Key = decode_key(DerKey), + case Key of + #'RSAPrivateKey'{modulus=Mod, publicExponent=Exp} -> + public_key:pkix_verify(DerEncodedCert, + #'RSAPublicKey'{modulus=Mod, publicExponent=Exp}); + #'DSAPrivateKey'{p=P, q=Q, g=G, y=Y} -> + public_key:pkix_verify(DerEncodedCert, {Y, #'Dss-Parms'{p=P, q=Q, g=G}}); + #'ECPrivateKey'{version = _Version, privateKey = _PrivKey, + parameters = Params, publicKey = {0, PubKey}} -> + public_key:pkix_verify(DerEncodedCert, {#'ECPoint'{point = PubKey}, Params}) + end. + +%%%%%%%%%%%%%%%%%%%%%%%%% Implementation %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +get_key(Opts) -> + case proplists:get_value(key, Opts) of + undefined -> make_key(rsa, Opts); + rsa -> make_key(rsa, Opts); + dsa -> make_key(dsa, Opts); + ec -> make_key(ec, Opts); + Key -> + Password = proplists:get_value(password, Opts, no_passwd), + decode_key(Key, Password) + end. + +decode_key({Key, Pw}) -> + decode_key(Key, Pw); +decode_key(Key) -> + decode_key(Key, no_passwd). + + +decode_key(#'RSAPublicKey'{} = Key,_) -> + Key; +decode_key(#'RSAPrivateKey'{} = Key,_) -> + Key; +decode_key(#'DSAPrivateKey'{} = Key,_) -> + Key; +decode_key(#'ECPrivateKey'{} = Key,_) -> + Key; +decode_key(PemEntry = {_,_,_}, Pw) -> + public_key:pem_entry_decode(PemEntry, Pw); +decode_key(PemBin, Pw) -> + [KeyInfo] = public_key:pem_decode(PemBin), + decode_key(KeyInfo, Pw). + +encode_key(Key = #'RSAPrivateKey'{}) -> + {ok, Der} = 'OTP-PUB-KEY':encode('RSAPrivateKey', Key), + {'RSAPrivateKey', Der, not_encrypted}; +encode_key(Key = #'DSAPrivateKey'{}) -> + {ok, Der} = 'OTP-PUB-KEY':encode('DSAPrivateKey', Key), + {'DSAPrivateKey', Der, not_encrypted}; +encode_key(Key = #'ECPrivateKey'{}) -> + {ok, Der} = 'OTP-PUB-KEY':encode('ECPrivateKey', Key), + {'ECPrivateKey', Der, not_encrypted}. + +make_tbs(SubjectKey, Opts) -> + Version = list_to_atom("v"++integer_to_list(proplists:get_value(version, Opts, 3))), + + IssuerProp = proplists:get_value(issuer, Opts, true), + {Issuer, IssuerKey} = issuer(IssuerProp, Opts, SubjectKey), + + {Algo, Parameters} = sign_algorithm(IssuerKey, Opts), + + SignAlgo = #'SignatureAlgorithm'{algorithm = Algo, + parameters = Parameters}, + Subject = case IssuerProp of + true -> %% Is a Root Ca + Issuer; + _ -> + subject(proplists:get_value(subject, Opts),false) + end, + + {#'OTPTBSCertificate'{serialNumber = trunc(random:uniform()*100000000)*10000 + 1, + signature = SignAlgo, + issuer = Issuer, + validity = validity(Opts), + subject = Subject, + subjectPublicKeyInfo = publickey(SubjectKey), + version = Version, + extensions = extensions(Opts) + }, IssuerKey}. + +issuer(true, Opts, SubjectKey) -> + %% Self signed + {subject(proplists:get_value(subject, Opts), true), SubjectKey}; +issuer({Issuer, IssuerKey}, _Opts, _SubjectKey) when is_binary(Issuer) -> + {issuer_der(Issuer), decode_key(IssuerKey)}; +issuer({File, IssuerKey}, _Opts, _SubjectKey) when is_list(File) -> + {ok, [{cert, Cert, _}|_]} = pem_to_der(File), + {issuer_der(Cert), decode_key(IssuerKey)}. + +issuer_der(Issuer) -> + Decoded = public_key:pkix_decode_cert(Issuer, otp), + #'OTPCertificate'{tbsCertificate=Tbs} = Decoded, + #'OTPTBSCertificate'{subject=Subject} = Tbs, + Subject. + +subject(undefined, IsRootCA) -> + User = if IsRootCA -> "RootCA"; true -> os:getenv("USER", "test_user") end, + Opts = [{email, User ++ "@erlang.org"}, + {name, User}, + {city, "Stockholm"}, + {country, "SE"}, + {org, "erlang"}, + {org_unit, "testing dep"}], + subject(Opts); +subject(Opts, _) -> + subject(Opts). + +subject(SubjectOpts) when is_list(SubjectOpts) -> + Encode = fun(Opt) -> + {Type,Value} = subject_enc(Opt), + [#'AttributeTypeAndValue'{type=Type, value=Value}] + end, + {rdnSequence, [Encode(Opt) || Opt <- SubjectOpts]}. + +%% Fill in the blanks +subject_enc({name, Name}) -> {?'id-at-commonName', {printableString, Name}}; +subject_enc({email, Email}) -> {?'id-emailAddress', Email}; +subject_enc({city, City}) -> {?'id-at-localityName', {printableString, City}}; +subject_enc({state, State}) -> {?'id-at-stateOrProvinceName', {printableString, State}}; +subject_enc({org, Org}) -> {?'id-at-organizationName', {printableString, Org}}; +subject_enc({org_unit, OrgUnit}) -> {?'id-at-organizationalUnitName', {printableString, OrgUnit}}; +subject_enc({country, Country}) -> {?'id-at-countryName', Country}; +subject_enc({serial, Serial}) -> {?'id-at-serialNumber', Serial}; +subject_enc({title, Title}) -> {?'id-at-title', {printableString, Title}}; +subject_enc({dnQualifer, DnQ}) -> {?'id-at-dnQualifier', DnQ}; +subject_enc(Other) -> Other. + + +extensions(Opts) -> + case proplists:get_value(extensions, Opts, []) of + false -> + asn1_NOVALUE; + Exts -> + lists:flatten([extension(Ext) || Ext <- default_extensions(Exts)]) + end. + +default_extensions(Exts) -> + Def = [{key_usage,undefined}, + {subject_altname, undefined}, + {issuer_altname, undefined}, + {basic_constraints, default}, + {name_constraints, undefined}, + {policy_constraints, undefined}, + {ext_key_usage, undefined}, + {inhibit_any, undefined}, + {auth_key_id, undefined}, + {subject_key_id, undefined}, + {policy_mapping, undefined}], + Filter = fun({Key, _}, D) -> lists:keydelete(Key, 1, D) end, + Exts ++ lists:foldl(Filter, Def, Exts). + +extension({_, undefined}) -> []; +extension({basic_constraints, Data}) -> + case Data of + default -> + #'Extension'{extnID = ?'id-ce-basicConstraints', + extnValue = #'BasicConstraints'{cA=true}, + critical=true}; + false -> + []; + Len when is_integer(Len) -> + #'Extension'{extnID = ?'id-ce-basicConstraints', + extnValue = #'BasicConstraints'{cA=true, pathLenConstraint=Len}, + critical=true}; + _ -> + #'Extension'{extnID = ?'id-ce-basicConstraints', + extnValue = Data} + end; +extension({Id, Data, Critical}) -> + #'Extension'{extnID = Id, extnValue = Data, critical = Critical}. + + +publickey(#'RSAPrivateKey'{modulus=N, publicExponent=E}) -> + Public = #'RSAPublicKey'{modulus=N, publicExponent=E}, + Algo = #'PublicKeyAlgorithm'{algorithm= ?rsaEncryption, parameters='NULL'}, + #'OTPSubjectPublicKeyInfo'{algorithm = Algo, + subjectPublicKey = Public}; +publickey(#'DSAPrivateKey'{p=P, q=Q, g=G, y=Y}) -> + Algo = #'PublicKeyAlgorithm'{algorithm= ?'id-dsa', + parameters={params, #'Dss-Parms'{p=P, q=Q, g=G}}}, + #'OTPSubjectPublicKeyInfo'{algorithm = Algo, subjectPublicKey = Y}; +publickey(#'ECPrivateKey'{version = _Version, + privateKey = _PrivKey, + parameters = Params, + publicKey = {0, PubKey}}) -> + Algo = #'PublicKeyAlgorithm'{algorithm= ?'id-ecPublicKey', parameters=Params}, + #'OTPSubjectPublicKeyInfo'{algorithm = Algo, + subjectPublicKey = #'ECPoint'{point = PubKey}}. + +validity(Opts) -> + DefFrom0 = calendar:gregorian_days_to_date(calendar:date_to_gregorian_days(date())-1), + DefTo0 = calendar:gregorian_days_to_date(calendar:date_to_gregorian_days(date())+7), + {DefFrom, DefTo} = proplists:get_value(validity, Opts, {DefFrom0, DefTo0}), + Format = fun({Y,M,D}) -> lists:flatten(io_lib:format("~w~2..0w~2..0w000000Z",[Y,M,D])) end, + #'Validity'{notBefore={generalTime, Format(DefFrom)}, + notAfter ={generalTime, Format(DefTo)}}. + +sign_algorithm(#'RSAPrivateKey'{}, Opts) -> + Type = case proplists:get_value(digest, Opts, sha1) of + sha1 -> ?'sha1WithRSAEncryption'; + sha512 -> ?'sha512WithRSAEncryption'; + sha384 -> ?'sha384WithRSAEncryption'; + sha256 -> ?'sha256WithRSAEncryption'; + md5 -> ?'md5WithRSAEncryption'; + md2 -> ?'md2WithRSAEncryption' + end, + {Type, 'NULL'}; +sign_algorithm(#'DSAPrivateKey'{p=P, q=Q, g=G}, _Opts) -> + {?'id-dsa-with-sha1', {params,#'Dss-Parms'{p=P, q=Q, g=G}}}; +sign_algorithm(#'ECPrivateKey'{}, Opts) -> + Type = case proplists:get_value(digest, Opts, sha1) of + sha1 -> ?'ecdsa-with-SHA1'; + sha512 -> ?'ecdsa-with-SHA512'; + sha384 -> ?'ecdsa-with-SHA384'; + sha256 -> ?'ecdsa-with-SHA256' + end, + {Type, 'NULL'}. + +make_key(rsa, _Opts) -> + %% (OBS: for testing only) + gen_rsa2(64); +make_key(dsa, _Opts) -> + gen_dsa2(128, 20); %% Bytes i.e. {1024, 160} +make_key(ec, _Opts) -> + %% (OBS: for testing only) + gen_ec2(secp256k1). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% RSA key generation (OBS: for testing only) +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +-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) -> + P = prime(Size), + Q = prime(Size), + N = P*Q, + Tot = (P - 1) * (Q - 1), + [E|_] = lists:dropwhile(fun(Candidate) -> (Tot rem Candidate) == 0 end, ?SMALL_PRIMES), + {D1,D2} = extended_gcd(E, Tot), + D = erlang:max(D1,D2), + case D < E of + true -> + gen_rsa2(Size); + false -> + {Co1,Co2} = extended_gcd(Q, P), + Co = erlang:max(Co1,Co2), + #'RSAPrivateKey'{version = 'two-prime', + modulus = N, + publicExponent = E, + privateExponent = D, + prime1 = P, + prime2 = Q, + exponent1 = D rem (P-1), + exponent2 = D rem (Q-1), + coefficient = Co + } + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% DSA key generation (OBS: for testing only) +%% See http://en.wikipedia.org/wiki/Digital_Signature_Algorithm +%% and the fips_186-3.pdf +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +gen_dsa2(LSize, NSize) -> + Q = prime(NSize), %% Choose N-bit prime Q + X0 = prime(LSize), + P0 = prime((LSize div 2) +1), + + %% Choose L-bit prime modulus P such that p-1 is a multiple of q. + case dsa_search(X0 div (2*Q*P0), P0, Q, 1000) of + error -> + gen_dsa2(LSize, NSize); + P -> + G = crypto:mod_pow(2, (P-1) div Q, P), % Choose G a number whose multiplicative order modulo p is q. + %% such that This may be done by setting g = h^(p-1)/q mod p, commonly h=2 is used. + + X = prime(20), %% Choose x by some random method, where 0 < x < q. + Y = crypto:mod_pow(G, X, P), %% Calculate y = g^x mod p. + + #'DSAPrivateKey'{version=0, p = P, q = Q, + g = crypto:bytes_to_integer(G), y = crypto:bytes_to_integer(Y), x = X} + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% EC key generation (OBS: for testing only) +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +gen_ec2(CurveId) -> + {PubKey, PrivKey} = crypto:generate_key(ecdh, CurveId), + + #'ECPrivateKey'{version = 1, + privateKey = binary_to_list(PrivKey), + parameters = {namedCurve, pubkey_cert_records:namedCurves(CurveId)}, + publicKey = {0, PubKey}}. + +%% See fips_186-3.pdf +dsa_search(T, P0, Q, Iter) when Iter > 0 -> + P = 2*T*Q*P0 + 1, + case is_prime(P, 50) of + true -> P; + false -> dsa_search(T+1, P0, Q, Iter-1) + end; +dsa_search(_,_,_,_) -> + error. + + +%%%%%%% Crypto Math %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +prime(ByteSize) -> + Rand = odd_rand(ByteSize), + prime_odd(Rand, 0). + +prime_odd(Rand, N) -> + case is_prime(Rand, 50) of + true -> + Rand; + false -> + prime_odd(Rand+2, N+1) + end. + +%% see http://en.wikipedia.org/wiki/Fermat_primality_test +is_prime(_, 0) -> true; +is_prime(Candidate, Test) -> + CoPrime = odd_rand(10000, Candidate), + Result = crypto:mod_pow(CoPrime, Candidate, Candidate) , + is_prime(CoPrime, crypto:bytes_to_integer(Result), Candidate, Test). + +is_prime(CoPrime, CoPrime, Candidate, Test) -> + is_prime(Candidate, Test-1); +is_prime(_,_,_,_) -> + false. + +odd_rand(Size) -> + Min = 1 bsl (Size*8-1), + Max = (1 bsl (Size*8))-1, + odd_rand(Min, Max). + +odd_rand(Min,Max) -> + Rand = crypto:rand_uniform(Min,Max), + case Rand rem 2 of + 0 -> + Rand + 1; + _ -> + Rand + end. + +extended_gcd(A, B) -> + case A rem B of + 0 -> + {0, 1}; + N -> + {X, Y} = extended_gcd(B, N), + {Y, X-Y*(A div B)} + end. + +pem_to_der(File) -> + {ok, PemBin} = file:read_file(File), + public_key:pem_decode(PemBin). + +der_to_pem(File, Entries) -> + PemBin = public_key:pem_encode(Entries), + file:write_file(File, PemBin). + diff --git a/lib/ftp/test/ftp.config b/lib/ftp/test/ftp.config new file mode 100644 index 0000000000..2600237da9 --- /dev/null +++ b/lib/ftp/test/ftp.config @@ -0,0 +1 @@ +[].
\ No newline at end of file diff --git a/lib/ftp/test/ftp.cover b/lib/ftp/test/ftp.cover new file mode 100644 index 0000000000..5b155991bc --- /dev/null +++ b/lib/ftp/test/ftp.cover @@ -0,0 +1,2 @@ +{incl_app,ftp,details}. + diff --git a/lib/ftp/test/ftp.spec b/lib/ftp/test/ftp.spec new file mode 100644 index 0000000000..faf1e532a8 --- /dev/null +++ b/lib/ftp/test/ftp.spec @@ -0,0 +1 @@ +{suites,"../ftp_test", all}. diff --git a/lib/inets/test/ftp_SUITE.erl b/lib/ftp/test/ftp_SUITE.erl index 3dfec01ba2..92d2c36a86 100644 --- a/lib/inets/test/ftp_SUITE.erl +++ b/lib/ftp/test/ftp_SUITE.erl @@ -18,16 +18,10 @@ %% %CopyrightEnd% %% %% - -%% -%% ct:run("../inets_test", ftp_SUITE). -%% - -module(ftp_SUITE). -include_lib("kernel/include/file.hrl"). -include_lib("common_test/include/ct.hrl"). --include("inets_test_lib.hrl"). %% Note: This directive should only be used in test suites. -compile(export_all). @@ -59,6 +53,9 @@ all() -> {group, ftp_active}, {group, ftps_passive}, {group, ftps_active}, + {group, ftp_sup}, + app, + appup, error_ehost, clean_shutdown ]. @@ -68,7 +65,8 @@ groups() -> {ftp_passive, [], ftp_tests()}, {ftp_active, [], ftp_tests()}, {ftps_passive, [], ftp_tests()}, - {ftps_active, [], ftp_tests()} + {ftps_active, [], ftp_tests()}, + {ftp_sup, [], ftp_sup_tests()} ]. ftp_tests()-> @@ -109,6 +107,12 @@ ftp_tests()-> unexpected_bang ]. +ftp_sup_tests() -> + [ + start_ftp, + ftp_worker + ]. + %%-------------------------------------------------------------------- %%% Config @@ -181,7 +185,8 @@ init_per_suite(Config) -> {ok,Data} -> TstDir = filename:join(proplists:get_value(priv_dir,Config), "test"), file:make_dir(TstDir), - make_cert_files(dsa, rsa, "server-", proplists:get_value(data_dir,Config)), + %% make_cert_files(dsa, rsa, "server-", proplists:get_value(data_dir,Config)), + ftp_test_lib:make_cert_files(proplists:get_value(data_dir,Config)), start_ftpd([{test_dir,TstDir}, {ftpd_data,Data} | Config]) @@ -204,17 +209,43 @@ init_per_group(Group, Config) when Group == ftps_active, _:_ -> {skip, "Crypto did not start"} end; - +init_per_group(ftp_sup, Config) -> + try ftp:start() of + ok -> + Config + catch + _:_ -> + {skip, "Ftp did not start"} + end; init_per_group(_Group, Config) -> Config. + +end_per_group(ftp_sup, Config) -> + ftp:stop(), + Config; end_per_group(_Group, Config) -> Config. %%-------------------------------------------------------------------- +init_per_testcase(T, Config0) when T =:= app; T =:= appup -> + Config0; init_per_testcase(Case, Config0) -> Group = proplists:get_value(name, proplists:get_value(tc_group_properties,Config0)), - TLS = [{tls,[{reuse_sessions,true}]}], + + %% Workaround for interoperability issues with vsftpd =< 3.0.2: + %% + %% vsftpd =< 3.0.2 does not support ECDHE ciphers and the ssl application + %% removed ciphers with RSA key exchange from its default cipher list. + %% To allow interoperability with old versions of vsftpd, cipher suites + %% with RSA key exchange are appended to the default cipher list. + All = ssl:cipher_suites(all, 'tlsv1.2'), + Default = ssl:cipher_suites(default, 'tlsv1.2'), + RSASuites = + ssl:filter_cipher_suites(All, [{key_exchange, fun(rsa) -> true; + (_) -> false end}]), + Suites = ssl:append_cipher_suites(RSASuites, Default), + TLS = [{tls,[{reuse_sessions,true},{ciphers, Suites}]}], ACTIVE = [{mode,active}], PASSIVE = [{mode,passive}], CaseOpts = case Case of @@ -229,6 +260,7 @@ init_per_testcase(Case, Config0) -> ftps_active -> ftp__open(Config0, TLS++ ACTIVE ++ ExtraOpts); ftp_passive -> ftp__open(Config0, PASSIVE ++ ExtraOpts); ftps_passive -> ftp__open(Config0, TLS++PASSIVE ++ ExtraOpts); + ftp_sup -> ftp_start_service(Config0, ACTIVE ++ ExtraOpts); undefined -> Config0 end, case Case of @@ -244,7 +276,7 @@ init_per_testcase(Case, Config0) -> Config end. - +end_per_testcase(T, _Config) when T =:= app; T =:= appup -> ok; end_per_testcase(user, _Config) -> ok; end_per_testcase(bad_user, _Config) -> ok; end_per_testcase(error_elogin, _Config) -> ok; @@ -261,11 +293,30 @@ end_per_testcase(_Case, Config) -> _:_ -> ok end end, - ftp__close(Config). + Group = proplists:get_value(name, proplists:get_value(tc_group_properties,Config)), + case Group of + ftp_sup -> + ftp_stop_service(Config); + _Else -> + ftp__close(Config) + end. %%-------------------------------------------------------------------- %% Test Cases -------------------------------------------------------- %%-------------------------------------------------------------------- +app() -> + [{doc, "Test that the ftp app file is ok"}]. +app(Config) when is_list(Config) -> + ok = ?t:app_test(ftp). + +%%-------------------------------------------------------------------- +appup() -> + [{doc, "Test that the ftp appup file is ok"}]. +appup(Config) when is_list(Config) -> + ok = ?t:appup_test(ftp). + +%%-------------------------------------------------------------------- + user() -> [ {doc, "Open an ftp connection to a host, and logon as anonymous ftp," " then logoff"}]. @@ -834,6 +885,43 @@ clean_shutdown(Config) -> end end. +%%------------------------------------------------------------------------- +start_ftp() -> + [{doc, "Start/stop of ftp service"}]. +start_ftp(Config) -> + Pid0 = proplists:get_value(ftp,Config), + Pids0 = [ServicePid || {_, ServicePid} <- ftp:services()], + true = lists:member(Pid0, Pids0), + {ok, [_|_]} = ftp:service_info(Pid0), + ftp:stop_service(Pid0), + ct:sleep(100), + Pids1 = [ServicePid || {_, ServicePid} <- ftp:services()], + false = lists:member(Pid0, Pids1), + + Host = proplists:get_value(ftpd_host,Config), + Port = proplists:get_value(ftpd_port,Config), + + {ok, Pid1} = ftp:start_standalone([{host, Host},{port, Port}]), + Pids2 = [ServicePid || {_, ServicePid} <- ftp:services()], + false = lists:member(Pid1, Pids2). + +%%------------------------------------------------------------------------- +ftp_worker() -> + [{doc, "Makes sure the ftp worker processes are added and removed " + "appropriatly to/from the supervison tree."}]. +ftp_worker(Config) -> + Pid = proplists:get_value(ftp,Config), + case supervisor:which_children(ftp_sup) of + [{_,_, worker, [ftp]}] -> + ftp:stop_service(Pid), + ct:sleep(5000), + [] = supervisor:which_children(ftp_sup), + ok; + Children -> + ct:fail("Unexpected children: ~p",[Children]) + end. + + %%%---------------------------------------------------------------- %%% Error codes not tested elsewhere @@ -867,22 +955,6 @@ error_ehost(_Config) -> %% Internal functions ----------------------------------------------- %%-------------------------------------------------------------------- -make_cert_files(Alg1, Alg2, Prefix, Dir) -> - CaInfo = {CaCert,_} = erl_make_certs:make_cert([{key,Alg1}]), - {Cert,CertKey} = erl_make_certs:make_cert([{key,Alg2},{issuer,CaInfo}]), - CaCertFile = filename:join(Dir, Prefix++"cacerts.pem"), - CertFile = filename:join(Dir, Prefix++"cert.pem"), - KeyFile = filename:join(Dir, Prefix++"key.pem"), - der_to_pem(CaCertFile, [{'Certificate', CaCert, not_encrypted}]), - der_to_pem(CertFile, [{'Certificate', Cert, not_encrypted}]), - der_to_pem(KeyFile, [CertKey]), - ok. - -der_to_pem(File, Entries) -> - PemBin = public_key:pem_encode(Entries), - file:write_file(File, PemBin). - -%%-------------------------------------------------------------------- chk_file(Path=[C|_], ExpectedContents, Config) when 0<C,C=<255 -> chk_file([Path], ExpectedContents, Config); @@ -1029,6 +1101,17 @@ ftp__close(Config) -> ok = ftp:close(proplists:get_value(ftp,Config)), Config. +ftp_start_service(Config, Options) -> + Host = proplists:get_value(ftpd_host,Config), + Port = proplists:get_value(ftpd_port,Config), + ct:log("Host=~p, Port=~p",[Host,Port]), + {ok,Pid} = ftp:start_service([{host, Host},{port,Port} | Options]), + [{ftp,Pid}|Config]. + +ftp_stop_service(Config) -> + ok = ftp:stop_service(proplists:get_value(ftp,Config)), + Config. + split(Cs) -> string:tokens(Cs, "\r\n"). find_diff(Bin1, Bin2) -> diff --git a/lib/inets/test/ftp_SUITE_data/ftpd_hosts.skel b/lib/ftp/test/ftp_SUITE_data/ftpd_hosts.skel index 75096ce687..75096ce687 100644 --- a/lib/inets/test/ftp_SUITE_data/ftpd_hosts.skel +++ b/lib/ftp/test/ftp_SUITE_data/ftpd_hosts.skel diff --git a/lib/ftp/test/ftp_SUITE_data/vsftpd.conf b/lib/ftp/test/ftp_SUITE_data/vsftpd.conf new file mode 100644 index 0000000000..4568fad147 --- /dev/null +++ b/lib/ftp/test/ftp_SUITE_data/vsftpd.conf @@ -0,0 +1,33 @@ + +### +### Some parameters are given in the vsftpd start command. +### +### Typical command-line paramters are such that has a file path +### component like cert files. +### + + +listen=YES +listen_port=9999 +run_as_launching_user=YES +ssl_enable=YES +ssl_ciphers=HIGH:!aNULL:!MD5 +allow_anon_ssl=YES + +background=YES + +write_enable=YES +anonymous_enable=YES +anon_upload_enable=YES +anon_mkdir_write_enable=YES +anon_other_write_enable=YES +anon_world_readable_only=NO + +### Shouldn't be necessary.... +require_ssl_reuse=NO + +### Logging +#vsftpd_log_file=/devel/otp/vsftpd.log +#xferlog_enable=YES +#xferlog_std_format=NO +#log_ftp_protocol=YES
\ No newline at end of file diff --git a/lib/ftp/test/ftp_bench.spec b/lib/ftp/test/ftp_bench.spec new file mode 100644 index 0000000000..4d1ecf8891 --- /dev/null +++ b/lib/ftp/test/ftp_bench.spec @@ -0,0 +1 @@ +{suites,"../ftp_test",[]}. diff --git a/lib/inets/test/ftp_format_SUITE.erl b/lib/ftp/test/ftp_format_SUITE.erl index 95d594a44b..95d594a44b 100644 --- a/lib/inets/test/ftp_format_SUITE.erl +++ b/lib/ftp/test/ftp_format_SUITE.erl diff --git a/lib/ftp/test/ftp_internal.hrl b/lib/ftp/test/ftp_internal.hrl new file mode 120000 index 0000000000..2ae5c46460 --- /dev/null +++ b/lib/ftp/test/ftp_internal.hrl @@ -0,0 +1 @@ +../src/ftp_internal.hrl
\ No newline at end of file diff --git a/lib/inets/test/ftp_property_test_SUITE.erl b/lib/ftp/test/ftp_property_test_SUITE.erl index b314882296..46ed6959a8 100644 --- a/lib/inets/test/ftp_property_test_SUITE.erl +++ b/lib/ftp/test/ftp_property_test_SUITE.erl @@ -41,9 +41,11 @@ all() -> [prop_ftp_case]. init_per_suite(Config) -> - inets:start(), + ftp:start(), ct_property_test:init_per_suite(Config). +end_per_suite(Config) -> + Config. %%%---- test case prop_ftp_case(Config) -> diff --git a/lib/ftp/test/ftp_test_lib.erl b/lib/ftp/test/ftp_test_lib.erl new file mode 100644 index 0000000000..f5fbc39037 --- /dev/null +++ b/lib/ftp/test/ftp_test_lib.erl @@ -0,0 +1,126 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2001-2018. 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(ftp_test_lib). + +-include_lib("public_key/include/public_key.hrl"). + +-export([make_cert_files/1]). + + +make_cert_files(Dir) -> + #{server_config := ServerConf, + client_config := _} = + public_key:pkix_test_data(#{server_chain => + #{root => [{key, hardcode_rsa_key(1)}], + intermediates => [[{key, hardcode_rsa_key(2)}]], + peer => [{key, hardcode_rsa_key(3)}]}, + client_chain => + #{root => [{key, hardcode_rsa_key(1)}], + intermediates => [[{key, hardcode_rsa_key(3)}]], + peer => [{key, hardcode_rsa_key(2)}]}}), + + CaCertFile = filename:join(Dir, "server-cacerts.pem"), + CertFile = filename:join(Dir, "server-cert.pem"), + KeyFile = filename:join(Dir, "server-key.pem"), + + CAs = proplists:get_value(cacerts, ServerConf), + Cert = proplists:get_value(cert, ServerConf), + Key = proplists:get_value(key, ServerConf), + der_to_pem(CertFile, [cert_entry(Cert)]), + der_to_pem(KeyFile, [key_entry(Key)]), + der_to_pem(CaCertFile, ca_entries(CAs)). + +cert_entry(Cert) -> + {'Certificate', Cert, not_encrypted}. + +key_entry({'RSAPrivateKey', DERKey}) -> + {'RSAPrivateKey', DERKey, not_encrypted}; +key_entry({'DSAPrivateKey', DERKey}) -> + {'DSAPrivateKey', DERKey, not_encrypted}; +key_entry({'ECPrivateKey', DERKey}) -> + {'ECPrivateKey', DERKey, not_encrypted}. + +ca_entries(CAs) -> + [{'Certificate', CACert, not_encrypted} || CACert <- CAs]. + +der_to_pem(File, Entries) -> + PemBin = public_key:pem_encode(Entries), + file:write_file(File, PemBin). + +hardcode_rsa_key(1) -> + #'RSAPrivateKey'{ + version = 'two-prime', + modulus = +23995666614853919027835084074500048897452890537492185072956789802729257783422306095699263934587064480357348855732149402060270996295002843755712064937715826848741191927820899197493902093529581182351132392364214171173881547273475904587683433713767834856230531387991145055273426806331200574039205571401702219159773947658558490957010003143162250693492642996408861265758000254664396313741422909188635443907373976005987612936763564996605457102336549804831742940035613780926178523017685712710473543251580072875247250504243621640157403744718833162626193206685233710319205099867303242759099560438381385658382486042995679707669, + publicExponent = 17, + privateExponent = +11292078406990079542510627799764728892919007311761028269626724613049062486316379339152594792746853873109340637991599718616598115903530750002688030558925094987642913848386305504703012749896273497577003478759630198199473669305165131570674557041773098755873191241407597673069847908861741446606684974777271632545629600685952292605647052193819136445675100211504432575554351515262198132231537860917084269870590492135731720141577986787033006338680118008484613510063003323516659048210893001173583018220214626635609151105287049126443102976056146630518124476470236027123782297108342869049542023328584384300970694412006494684657, +prime1 = +169371138592582642967021557955633494538845517070305333860805485424261447791289944610138334410987654265476540480228705481960508520379619587635662291973699651583489223555422528867090299996446070521801757353675026048850480903160224210802452555900007597342687137394192939372218903554801584969667104937092080815197, + prime2 = +141675062317286527042995673340952251894209529891636708844197799307963834958115010129693036021381525952081167155681637592199810112261679449166276939178032066869788822014115556349519329537177920752776047051833616197615329017439297361972726138285974555338480581117881706656603857310337984049152655480389797687577, + exponent1 = +119556097830058336212015217380447172615655659108450823901745048534772786676204666783627059584226579481512852103690850928442711896738555003036938088452023283470698275450886490965004917644550167427154181661417665446247398284583687678213495921811770068712485038160606780733330990744565824684470897602653233516609, + exponent2 = +41669135975672507953822256864985956439473391144599032012999352737636422046504414744027363535700448809435637398729893409470532385959317485048904982111185902020526124121798693043976273393287623750816484427009887116945685005129205106462566511260580751570141347387612266663707016855981760014456663376585234613993, + coefficient = +76837684977089699359024365285678488693966186052769523357232308621548155587515525857011429902602352279058920284048929101483304120686557782043616693940283344235057989514310975192908256494992960578961614059245280827077951132083993754797053182279229469590276271658395444955906108899267024101096069475145863928441, + otherPrimeInfos = asn1_NOVALUE}; + +hardcode_rsa_key(2) -> + #'RSAPrivateKey'{ + version = 'two-prime', + modulus = +21343679768589700771839799834197557895311746244621307033143551583788179817796325695589283169969489517156931770973490560582341832744966317712674900833543896521418422508485833901274928542544381247956820115082240721897193055368570146764204557110415281995205343662628196075590438954399631753508888358737971039058298703003743872818150364935790613286541190842600031570570099801682794056444451081563070538409720109449780410837763602317050353477918147758267825417201591905091231778937606362076129350476690460157227101296599527319242747999737801698427160817755293383890373574621116766934110792127739174475029121017282777887777, + publicExponent = 17, + privateExponent = +18832658619343853622211588088997845201745658451136447382185486691577805721584993260814073385267196632785528033211903435807948675951440868570007265441362261636545666919252206383477878125774454042314841278013741813438699754736973658909592256273895837054592950290554290654932740253882028017801960316533503857992358685308186680144968293076156011747178275038098868263178095174694099811498968993700538293188879611375604635940554394589807673542938082281934965292051746326331046224291377703201248790910007232374006151098976879987912446997911775904329728563222485791845480864283470332826504617837402078265424772379987120023773, + prime1 = +146807662748886761089048448970170315054939768171908279335181627815919052012991509112344782731265837727551849787333310044397991034789843793140419387740928103541736452627413492093463231242466386868459637115999163097726153692593711599245170083315894262154838974616739452594203727376460632750934355508361223110419, + prime2 = +145385325050081892763917667176962991350872697916072592966410309213561884732628046256782356731057378829876640317801978404203665761131810712267778698468684631707642938779964806354584156202882543264893826268426566901882487709510744074274965029453915224310656287149777603803201831202222853023280023478269485417083, + exponent1 = +51814469205489445090252393754177758254684624060673510353593515699736136004585238510239335081623236845018299924941168250963996835808180162284853901555621683602965806809675350150634081614988136541809283687999704622726877773856604093851236499993845033701707873394143336209718962603456693912094478414715725803677, + exponent2 = +51312467664734785681382706062457526359131540440966797517556579722433606376221663384746714140373192528191755406283051201483646739222992016094510128871300458249756331334105225772206172777487956446433115153562317730076172132768497908567634716277852432109643395464627389577600646306666889302334125933506877206029, + coefficient = +30504662229874176232343608562807118278893368758027179776313787938167236952567905398252901545019583024374163153775359371298239336609182249464886717948407152570850677549297935773605431024166978281486607154204888016179709037883348099374995148481968169438302456074511782717758301581202874062062542434218011141540, + otherPrimeInfos = asn1_NOVALUE}; + +hardcode_rsa_key(3) -> + #'RSAPrivateKey'{ + version = 'two-prime', + modulus = +25089040456112869869472694987833070928503703615633809313972554887193090845137746668197820419383804666271752525807484521370419854590682661809972833718476098189250708650325307850184923546875260207894844301992963978994451844985784504212035958130279304082438876764367292331581532569155681984449177635856426023931875082020262146075451989132180409962870105455517050416234175675478291534563995772675388370042873175344937421148321291640477650173765084699931690748536036544188863178325887393475703801759010864779559318631816411493486934507417755306337476945299570726975433250753415110141783026008347194577506976486290259135429, + publicExponent = 17, + privateExponent = +8854955455098659953931539407470495621824836570223697404931489960185796768872145882893348383311931058684147950284994536954265831032005645344696294253579799360912014817761873358888796545955974191021709753644575521998041827642041589721895044045980930852625485916835514940558187965584358347452650930302268008446431977397918214293502821599497633970075862760001650736520566952260001423171553461362588848929781360590057040212831994258783694027013289053834376791974167294527043946669963760259975273650548116897900664646809242902841107022557239712438496384819445301703021164043324282687280801738470244471443835900160721870265, + prime1 = +171641816401041100605063917111691927706183918906535463031548413586331728772311589438043965564336865070070922328258143588739626712299625805650832695450270566547004154065267940032684307994238248203186986569945677705100224518137694769557564475390859269797990555863306972197736879644001860925483629009305104925823, + prime2 +=146170909759497809922264016492088453282310383272504533061020897155289106805616042710009332510822455269704884883705830985184223718261139908416790475825625309815234508695722132706422885088219618698987115562577878897003573425367881351537506046253616435685549396767356003663417208105346307649599145759863108910523, + exponent1 = +60579464612132153154728441333538327425711971378777222246428851853999433684345266860486105493295364142377972586444050678378691780811632637288529186629507258781295583787741625893888579292084087601124818789392592131211843947578009918667375697196773859928702549128225990187436545756706539150170692591519448797349, + exponent2 = +137572620950115585809189662580789132500998007785886619351549079675566218169991569609420548245479957900898715184664311515467504676010484619686391036071176762179044243478326713135456833024206699951987873470661533079532774988581535389682358631768109586527575902839864474036157372334443583670210960715165278974609, + coefficient = +15068630434698373319269196003209754243798959461311186548759287649485250508074064775263867418602372588394608558985183294561315208336731894947137343239541687540387209051236354318837334154993136528453613256169847839789803932725339395739618592522865156272771578671216082079933457043120923342632744996962853951612, + otherPrimeInfos = asn1_NOVALUE}. diff --git a/lib/ftp/test/property_test/README b/lib/ftp/test/property_test/README new file mode 100644 index 0000000000..57602bf719 --- /dev/null +++ b/lib/ftp/test/property_test/README @@ -0,0 +1,12 @@ + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% %%% +%%% WARNING %%% +%%% %%% +%%% This is experimental code which may be changed or removed %%% +%%% anytime without any warning. %%% +%%% %%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +The test in this directory are written assuming that the user has a QuickCheck license. They are to be run manually. Some may be possible to be run with other tools, e.g. PropEr. + diff --git a/lib/ftp/test/property_test/ftp_simple_client_server.erl b/lib/ftp/test/property_test/ftp_simple_client_server.erl new file mode 100644 index 0000000000..1bc54128f6 --- /dev/null +++ b/lib/ftp/test/property_test/ftp_simple_client_server.erl @@ -0,0 +1,307 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2004-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(ftp_simple_client_server). + +-compile(export_all). + +-ifndef(EQC). +-ifndef(PROPER). +-define(EQC,true). +%%-define(PROPER,true). +-endif. +-endif. + + +-ifdef(EQC). + +-include_lib("eqc/include/eqc.hrl"). +-include_lib("eqc/include/eqc_statem.hrl"). +-define(MOD_eqc, eqc). +-define(MOD_eqc_gen, eqc_gen). +-define(MOD_eqc_statem, eqc_statem). + +-else. +-ifdef(PROPER). + +-include_lib("proper/include/proper.hrl"). +-define(MOD_eqc, proper). +-define(MOD_eqc_gen, proper_gen). +-define(MOD_eqc_statem, proper_statem). + +-endif. +-endif. + +-record(state, { + initialized = false, + priv_dir, + data_dir, + servers = [], % [ {IP,Port,Userid,Pwd} ] + clients = [], % [ client_ref() ] + store = [] % [ {Name,Contents} ] + }). + +-define(fmt(F,A), io:format(F,A)). +%%-define(fmt(F,A), ok). + +-define(v(K,L), proplists:get_value(K,L)). + +%%%================================================================ +%%% +%%% Properties +%%% + +%% This function is for normal eqc calls: +prop_ftp() -> + {ok,PWD} = file:get_cwd(), + prop_ftp(filename:join([PWD,?MODULE_STRING++"_data"]), + filename:join([PWD,?MODULE_STRING,"_files"])). + +%% This function is for calls from common_test test cases: +prop_ftp(Config) -> + prop_ftp(filename:join([?v(property_dir,Config), ?MODULE_STRING++"_data"]), + ?v(priv_dir,Config) ). + + +prop_ftp(DataDir, PrivDir) -> + S0 = #state{data_dir = DataDir, + priv_dir = PrivDir}, + ?FORALL(Cmds, more_commands(10,commands(?MODULE,S0)), + aggregate(command_names(Cmds), + begin {_H,S,Result} = run_commands(?MODULE,Cmds), + % io:format('**** Result=~p~n',[Result]), + % io:format('**** S=~p~n',[S]), + % io:format('**** _H=~p~n',[_H]), + % io:format('**** Cmds=~p~n',[Cmds]), + [cmnd_stop_server(X) || X <- S#state.servers], + [ftp:stop_service(X) || {ok,X} <- S#state.clients], + Result==ok + end) + ). + +%%%================================================================ +%%% +%%% State model +%%% + +%% @doc Returns the state in which each test case starts. (Unless a different +%% initial state is supplied explicitly to, e.g. commands/2.) +-spec initial_state() ->?MOD_eqc_statem:symbolic_state(). +initial_state() -> + ?fmt("Initial_state()~n",[]), + #state{}. + +%% @doc Command generator, S is the current state +-spec command(S :: ?MOD_eqc_statem:symbolic_state()) -> ?MOD_eqc_gen:gen(eqc_statem:call()). + +command(#state{initialized=false, + priv_dir=PrivDir}) -> + {call,?MODULE,cmnd_init,[PrivDir]}; + +command(#state{servers=[], + priv_dir=PrivDir, + data_dir=DataDir}) -> + {call,?MODULE,cmnd_start_server,[PrivDir,DataDir]}; + +command(#state{servers=Ss=[_|_], + clients=[]}) -> + {call,?MODULE,cmnd_start_client,[oneof(Ss)]}; + +command(#state{servers=Ss=[_|_], + clients=Cs=[_|_], + store=Store=[_|_] + }) -> + frequency([ + { 5, {call,?MODULE,cmnd_start_client,[oneof(Ss)]}}, + { 5, {call,?MODULE,cmnd_stop_client,[oneof(Cs)]}}, + {10, {call,?MODULE,cmnd_put,[oneof(Cs),file_path(),file_contents()]}}, + {20, {call,?MODULE,cmnd_get,[oneof(Cs),oneof(Store)]}}, + {10, {call,?MODULE,cmnd_delete,[oneof(Cs),oneof(Store)]}} + ]); + +command(#state{servers=Ss=[_|_], + clients=Cs=[_|_], + store=[] + }) -> + frequency([ + {5, {call,?MODULE,cmnd_start_client,[oneof(Ss)]}}, + {5, {call,?MODULE,cmnd_stop_client,[oneof(Cs)]}}, + {10, {call,?MODULE,cmnd_put,[oneof(Cs),file_path(),file_contents()]}} + ]). + +%% @doc Precondition, checked before command is added to the command sequence. +-spec precondition(S :: ?MOD_eqc_statem:symbolic_state(), C :: ?MOD_eqc_statem:call()) -> boolean(). + +precondition(#state{clients=Cs}, {call, _, cmnd_put, [C,_,_]}) -> lists:member(C,Cs); + +precondition(#state{clients=Cs, store=Store}, + {call, _, cmnd_get, [C,X]}) -> lists:member(C,Cs) andalso lists:member(X,Store); + +precondition(#state{clients=Cs, store=Store}, + {call, _, cmnd_delete, [C,X]}) -> lists:member(C,Cs) andalso lists:member(X,Store); + +precondition(#state{servers=Ss}, {call, _, cmnd_start_client, _}) -> Ss =/= []; + +precondition(#state{clients=Cs}, {call, _, cmnd_stop_client, [C]}) -> lists:member(C,Cs); + +precondition(#state{initialized=IsInit}, {call, _, cmnd_init, _}) -> IsInit==false; + +precondition(_S, {call, _, _, _}) -> true. + + +%% @doc Postcondition, checked after command has been evaluated +%% Note: S is the state before next_state(S,_,C) +-spec postcondition(S :: ?MOD_eqc_statem:dynamic_state(), C :: ?MOD_eqc_statem:call(), + Res :: term()) -> boolean(). + +postcondition(_S, {call, _, cmnd_get, [_,{_Name,Expected}]}, {ok,Value}) -> + Value == Expected; + +postcondition(S, {call, _, cmnd_delete, [_,{Name,_Expected}]}, ok) -> + ?fmt("file:read_file(..) = ~p~n",[file:read_file(filename:join(S#state.priv_dir,Name))]), + {error,enoent} == file:read_file(filename:join(S#state.priv_dir,Name)); + +postcondition(S, {call, _, cmnd_put, [_,Name,Value]}, ok) -> + {ok,Bin} = file:read_file(filename:join(S#state.priv_dir,Name)), + Bin == unicode:characters_to_binary(Value); + +postcondition(_S, {call, _, cmnd_stop_client, _}, ok) -> true; + +postcondition(_S, {call, _, cmnd_start_client, _}, {ok,_}) -> true; + +postcondition(_S, {call, _, cmnd_init, _}, ok) -> true; + +postcondition(_S, {call, _, cmnd_start_server, _}, {ok,_}) -> true. + + +%% @doc Next state transformation, S is the current state. Returns next state. +-spec next_state(S :: ?MOD_eqc_statem:symbolic_state(), + V :: ?MOD_eqc_statem:var(), + C :: ?MOD_eqc_statem:call()) -> ?MOD_eqc_statem:symbolic_state(). + +next_state(S, _V, {call, _, cmnd_put, [_,Name,Val]}) -> + S#state{store = [{Name,Val} | lists:keydelete(Name,1,S#state.store)]}; + +next_state(S, _V, {call, _, cmnd_delete, [_,{Name,_Val}]}) -> + S#state{store = lists:keydelete(Name,1,S#state.store)}; + +next_state(S, V, {call, _, cmnd_start_client, _}) -> + S#state{clients = [V | S#state.clients]}; + +next_state(S, V, {call, _, cmnd_start_server, _}) -> + S#state{servers = [V | S#state.servers]}; + +next_state(S, _V, {call, _, cmnd_stop_client, [C]}) -> + S#state{clients = S#state.clients -- [C]}; + +next_state(S, _V, {call, _, cmnd_init, _}) -> + S#state{initialized=true}; + +next_state(S, _V, {call, _, _, _}) -> + S. + +%%%================================================================ +%%% +%%% Data model +%%% + +file_path() -> non_empty(list(alphanum_char())). +%%file_path() -> non_empty( list(oneof([alphanum_char(), utf8_char()])) ). + +%%file_contents() -> list(alphanum_char()). +file_contents() -> list(oneof([alphanum_char(), utf8_char()])). + +alphanum_char() -> oneof(lists:seq($a,$z) ++ lists:seq($A,$Z) ++ lists:seq($0,$9)). + +utf8_char() -> oneof("åäöÅÄÖ話话カタカナひらがな"). + +%%%================================================================ +%%% +%%% Commands doing something with the System Under Test +%%% + +cmnd_init(PrivDir) -> + ?fmt('Call cmnd_init(~p)~n',[PrivDir]), + os:cmd("killall vsftpd"), + clear_files(PrivDir), + ok. + +cmnd_start_server(PrivDir, DataDir) -> + ?fmt('Call cmnd_start_server(~p, ~p)~n',[PrivDir,DataDir]), + Cmnd = ["vsftpd ", filename:join(DataDir,"vsftpd.conf"), + " -oftpd_banner=erlang_otp_testing" + " -oanon_root=",PrivDir + ], + ?fmt("Cmnd=~s~n",[Cmnd]), + case os:cmd(Cmnd) of + [] -> + {ok,{"localhost",9999,"ftp","[email protected]"}}; + Other -> + {error,Other} + end. + +cmnd_stop_server({ok,{_Host,Port,_Usr,_Pwd}}) -> + os:cmd("kill `netstat -tpln | grep "++integer_to_list(Port)++" | awk '{print $7}' | awk -F/ '{print $1}'`"). + +cmnd_start_client({ok,{Host,Port,Usr,Pwd}}) -> + ?fmt('Call cmnd_start_client(~p)...',[{Host,Port,Usr,Pwd}]), + case ftp:start_service([{host,Host},{port,Port}]) of + {ok,Client} -> + ?fmt("~p...",[{ok,Client}]), + case ftp:user(Client, Usr, Pwd) of + ok -> + ?fmt("OK!~n",[]), + {ok,Client}; + Other -> + ?fmt("Other1=~p~n",[Other]), + ftp:stop_service(Client), Other + end; + Other -> + ?fmt("Other2=~p~n",[Other]), + Other + end. + +cmnd_stop_client({ok,Client}) -> + ?fmt('Call cmnd_stop_client(~p)~n',[Client]), + ftp:stop_service(Client). %% -> ok | Other + +cmnd_delete({ok,Client}, {Name,_ExpectedValue}) -> + ?fmt('Call cmnd_delete(~p, ~p)~n',[Client,Name]), + R=ftp:delete(Client, Name), + ?fmt("R=~p~n",[R]), + R. + +cmnd_put({ok,Client}, Name, Value) -> + ?fmt('Call cmnd_put(~p, ~p, ~p)...',[Client, Name, Value]), + R = ftp:send_bin(Client, unicode:characters_to_binary(Value), Name), % ok | {error,Error} + ?fmt('~p~n',[R]), + R. + +cmnd_get({ok,Client}, {Name,_ExpectedValue}) -> + ?fmt('Call cmnd_get(~p, ~p)~n',[Client,Name]), + case ftp:recv_bin(Client, Name) of + {ok,Bin} -> {ok, unicode:characters_to_list(Bin)}; + Other -> Other + end. + + +clear_files(Dir) -> + os:cmd(["rm -fr ",filename:join(Dir,"*")]). diff --git a/lib/inets/test/ftp_SUITE_data/vsftpd.conf b/lib/ftp/test/property_test/ftp_simple_client_server_data/vsftpd.conf index a5584f5916..fd48e2abf0 100644 --- a/lib/inets/test/ftp_SUITE_data/vsftpd.conf +++ b/lib/ftp/test/property_test/ftp_simple_client_server_data/vsftpd.conf @@ -10,8 +10,8 @@ listen=YES listen_port=9999 run_as_launching_user=YES -ssl_enable=YES -allow_anon_ssl=YES +ssl_enable=NO +#allow_anon_ssl=YES background=YES diff --git a/lib/ftp/vsn.mk b/lib/ftp/vsn.mk new file mode 100644 index 0000000000..3099144a6e --- /dev/null +++ b/lib/ftp/vsn.mk @@ -0,0 +1,24 @@ +#-*-makefile-*- ; force emacs to enter makefile-mode + +# %CopyrightBegin% +# +# Copyright Ericsson AB 2001-2018. 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% + +APPLICATION = ftp +FTP_VSN = 1.0 +PRE_VSN = +APP_VSN = "$(APPLICATION)-$(FTP_VSN)$(PRE_VSN)" diff --git a/lib/hipe/cerl/Makefile b/lib/hipe/cerl/Makefile index 9f50d6bf91..b6116c4276 100644 --- a/lib/hipe/cerl/Makefile +++ b/lib/hipe/cerl/Makefile @@ -44,7 +44,7 @@ RELSYSDIR = $(RELEASE_PATH)/lib/hipe-$(VSN) # Target Specs # ---------------------------------------------------- MODULES = cerl_cconv cerl_closurean cerl_hipeify cerl_lib \ - cerl_messagean cerl_pmatch cerl_prettypr cerl_to_icode \ + cerl_pmatch cerl_prettypr cerl_to_icode \ cerl_typean erl_bif_types erl_types HRL_FILES= cerl_hipe_primops.hrl diff --git a/lib/hipe/cerl/cerl_messagean.erl b/lib/hipe/cerl/cerl_messagean.erl deleted file mode 100644 index c79e045bd0..0000000000 --- a/lib/hipe/cerl/cerl_messagean.erl +++ /dev/null @@ -1,1095 +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. -%% -%% @copyright 2002 Richard Carlsson -%% @author Richard Carlsson <[email protected]> -%% @doc Message analysis of Core Erlang programs. - -%% TODO: might need a "top" (`any') element for any-length value lists. - --module(cerl_messagean). - --export([annotate/1]). - --import(cerl, [alias_pat/1, alias_var/1, ann_c_var/2, ann_c_fun/3, - apply_args/1, apply_op/1, atom_val/1, bitstr_size/1, - bitstr_val/1, binary_segments/1, c_letrec/2, - ann_c_tuple/2, c_nil/0, call_args/1, call_module/1, - call_name/1, case_arg/1, case_clauses/1, catch_body/1, - clause_body/1, clause_guard/1, clause_pats/1, cons_hd/1, - cons_tl/1, fun_body/1, fun_vars/1, get_ann/1, int_val/1, - is_c_atom/1, is_c_int/1, let_arg/1, let_body/1, - let_vars/1, letrec_body/1, letrec_defs/1, module_defs/1, - module_defs/1, module_exports/1, pat_vars/1, - primop_args/1, primop_name/1, receive_action/1, - receive_clauses/1, receive_timeout/1, seq_arg/1, - seq_body/1, set_ann/2, try_arg/1, try_body/1, try_vars/1, - try_evars/1, try_handler/1, tuple_es/1, type/1, - values_es/1]). - --import(cerl_trees, [get_label/1]). - --define(DEF_LIMIT, 4). - -%% -export([test/1, test1/1, ttest/1]). - -%% ttest(F) -> -%% {T, _} = cerl_trees:label(user_default:read(F)), -%% {Time0, _} = erlang:statistics(runtime), -%% analyze(T), -%% {Time1, _} = erlang:statistics(runtime), -%% Time1 - Time0. - -%% test(F) -> -%% {T, _} = cerl_trees:label(user_default:read(F)), -%% {Time0, _} = erlang:statistics(runtime), -%% {Esc, _Vars} = analyze(T), -%% {Time1, _} = erlang:statistics(runtime), -%% io:fwrite("messages: ~p.\n", [Esc]), -%% Set = sets:from_list(Esc), -%% H = fun (Node, Ctxt, Cont) -> -%% Doc = case get_ann(Node) of -%% [{label, L} | _] -> -%% B = sets:is_element(L, Set), -%% bf(Node, Ctxt, Cont, B); -%% _ -> -%% bf(Node, Ctxt, Cont, false) -%% end, -%% case type(Node) of -%% cons -> color(Doc); -%% tuple -> color(Doc); -%% _ -> Doc -%% end -%% end, -%% {ok, FD} = file:open("out.html",[write]), -%% Txt = cerl_prettypr:format(T, [{hook, H},{user,false}]), -%% io:put_chars(FD, "<pre>\n"), -%% io:put_chars(FD, html(Txt)), -%% io:put_chars(FD, "</pre>\n"), -%% file:close(FD), -%% {ok, Time1 - Time0}. - -%% test1(F) -> -%% {T, _} = cerl_trees:label(user_default:read(F)), -%% {Time0, _} = erlang:statistics(runtime), -%% {T1, Esc, Vars} = annotate(T), -%% {Time1, _} = erlang:statistics(runtime), -%% io:fwrite("messages: ~p.\n", [Esc]), -%% %%% io:fwrite("vars: ~p.\n", [[X || X <- dict:to_list(Vars)]]), -%% T2 = hhl_transform:transform(T1, Vars), -%% Set = sets:from_list(Esc), -%% H = fun (Node, Ctxt, Cont) -> -%% case get_ann(Node) of -%% [{label, L} | _] -> -%% B = sets:is_element(L, Set), -%% bf(Node, Ctxt, Cont, B); -%% _ -> -%% bf(Node, Ctxt, Cont, false) -%% end -%% end, -%% {ok, FD} = file:open("out.html",[write]), -%% Txt = cerl_prettypr:format(T2, [{hook, H},{user,false}]), -%% io:put_chars(FD, "<pre>\n"), -%% io:put_chars(FD, html(Txt)), -%% io:put_chars(FD, "</pre>\n"), -%% file:close(FD), -%% {ok, Time1 - Time0}. - -%% html(Cs) -> -%% html(Cs, []). - -%% html([$#, $< | Cs], As) -> -%% html_1(Cs, [$< | As]); -%% html([$< | Cs], As) -> -%% html(Cs, ";tl&" ++ As); -%% html([$> | Cs], As) -> -%% html(Cs, ";tg&" ++ As); -%% html([$& | Cs], As) -> -%% html(Cs, ";pma&" ++ As); -%% html([C | Cs], As) -> -%% html(Cs, [C | As]); -%% html([], As) -> -%% lists:reverse(As). - -%% html_1([$> | Cs], As) -> -%% html(Cs, [$> | As]); -%% html_1([C | Cs], As) -> -%% html_1(Cs, [C | As]). - -%% bf(Node, Ctxt, Cont, B) -> -%% B0 = cerl_prettypr:get_ctxt_user(Ctxt), -%% if B /= B0 -> -%% Ctxt1 = cerl_prettypr:set_ctxt_user(Ctxt, B), -%% Doc = Cont(Node, Ctxt1), -%% case B of -%% true -> -%% Start = "<b>", -%% End = "</b>"; -%% false -> -%% Start = "</b>", -%% End = "<b>" -%% end, -%% markup(Doc, Start, End); -%% true -> -%% Cont(Node, Ctxt) -%% end. - -%% color(Doc) -> -%% % Doc. -%% markup(Doc, "<font color=blue>", "</font>"). - -%% markup(Doc, Start, End) -> -%% prettypr:beside( -%% prettypr:null_text([$# | Start]), -%% prettypr:beside(Doc, -%% prettypr:null_text([$# | End]))). - - -%% ===================================================================== -%% annotate(Tree) -> {Tree1, Escapes, Vars} -%% -%% Tree = cerl:cerl() -%% -%% Analyzes `Tree' (see `analyze') and appends a term 'escapes', to -%% the annotation list of each constructor expression node and of -%% `Tree', corresponding to the escape information derived by the -%% analysis. Any previous such annotations are removed from `Tree'. -%% `Tree1' is the modified tree; for details on `OutList', -%% `Outputs' , `Dependencies', `Escapes' and `Parents', see -%% `analyze'. -%% -%% Note: `Tree' must be annotated with labels in order to use this -%% function; see `analyze' for details. - --type label() :: integer() | 'external' | 'top'. --type ordset(X) :: [X]. % XXX: TAKE ME OUT - --spec annotate(cerl:cerl()) -> {cerl:cerl(), ordset(label()), dict:dict()}. - -annotate(Tree) -> - {Esc0, Vars} = analyze(Tree), - Esc = sets:from_list(Esc0), - F = fun (T) -> - case type(T) of - literal -> T; -%%% var -> -%%% L = get_label(T), -%%% T1 = ann_escape(T, L, Esc), -%%% X = dict:fetch(L, Vars), -%%% set_ann(T1, append_ann({s,X}, get_ann(T1))); - _ -> - L = get_label(T), - ann_escape(T, L, Esc) - end - end, - {cerl_trees:map(F, Tree), Esc0, Vars}. - -ann_escape(T, L, Esc) -> - case sets:is_element(L, Esc) of - true -> - set_ann(T, append_ann(escapes, get_ann(T))); - false -> - T - end. - -append_ann(Tag, [X | Xs]) -> - if tuple_size(X) >= 1, element(1, X) =:= Tag -> - append_ann(Tag, Xs); - true -> - [X | append_ann(Tag, Xs)] - end; -append_ann(Tag, []) -> - [Tag]. - - -%% ===================================================================== -%% analyze(Tree) -> Escapes -%% -%% Tree = cerl:cerl() -%% Escapes = ordset(Label) -%% Label = integer() | external | top -%% -%% Analyzes a module or an expression represented by `Tree'. -%% -%% `Escapes' is the set of labels of constructor expressions in -%% `Tree' such that the created values may be accessed from outside -%% `Tree'. -%% -%% Note: `Tree' must be annotated with labels (as done by the -%% function `cerl_trees:label/1') in order to use this function. -%% The label annotation `{label, L}' (where L should be an integer) -%% must be the first element of the annotation list of each node in -%% the tree. Instances of variables bound in `Tree' which denote -%% the same variable must have the same label; apart from this, -%% labels should be unique. Constant literals do not need to be -%% labeled. - --record(state, {vars, out, dep, work, funs, k}). - -%% Note: We assume that all remote calls and primops return a single -%% value. - -%% The analysis determines which objects (identified by the -%% corresponding "cons-point" labels in the code) are likely to be -%% passed in a message. (If so, we say that they "escape".) It is always -%% safe to assume either case, because the send operation will assure -%% that things are copied if necessary. This analysis tries to -%% anticipate that copying will be done. -%% -%% Rules: -%% 1) An object passed as message argument (or part of such an -%% argument) to a known send-operation, will probably be a message. -%% 2) A received value is always a message (safe). -%% 3) The external function can return any object (unsafe). -%% 4) A function called from the external function can receive any -%% object (unsafe) as argument. -%% 5) Unknown functions/operations can return any object (unsafe). - -%% We wrap the given syntax tree T in a fun-expression labeled `top', -%% which is initially in the set of escaped labels. `top' will be -%% visited at least once. -%% -%% We create a separate function labeled `external', defined as: -%% "'external'/1 = fun () -> Any", which will represent any and all -%% functions outside T, and which returns the 'unsafe' value. - -analyze(Tree) -> - analyze(Tree, ?DEF_LIMIT). - -analyze(Tree, Limit) -> - {_, _, Esc, Dep, _Par} = cerl_closurean:analyze(Tree), -%%% io:fwrite("dependencies: ~w.\n", [dict:to_list(Dep)]), - analyze(Tree, Limit, Dep, Esc). - -analyze(Tree, Limit, Dep0, Esc0) -> - %% Note that we use different name spaces for variable labels and - %% function/call site labels, so we can reuse some names here. We - %% assume that the labeling of Tree only uses integers, not atoms. - Any = ann_c_var([{label, any}], 'Any'), - External = ann_c_var([{label, external}], {external, 1}), - ExtFun = ann_c_fun([{label, external}], [], Any), -%%% io:fwrite("external fun:\n~s.\n", -%%% [cerl_prettypr:format(ExtFun, [noann, {paper, 80}])]), - Top = ann_c_var([{label, top}], {top, 0}), - TopFun = ann_c_fun([{label, top}], [], Tree), - - %% The "start fun" just makes the initialisation easier. It is not - %% itself in the call graph. - StartFun = ann_c_fun([{label, start}], [], - c_letrec([{External, ExtFun}, {Top, TopFun}], - c_nil())), -%%% io:fwrite("start fun:\n~s.\n", -%%% [cerl_prettypr:format(StartFun, [{paper, 80}])]), - - %% Initialise the Any and Escape variables. Gather a database of all - %% fun-expressions in Tree and initialise their outputs and parameter - %% variables. All escaping functions can receive any values as - %% inputs. Bind all module- and letrec-defined variables to their - %% corresponding labels. - Esc = sets:from_list(Esc0), - Unsafe = unsafe(), - Empty = empty(), - Funs0 = dict:new(), - Vars0 = dict:store(escape, empty(), - dict:store(any, Unsafe, dict:new())), - Out0 = dict:new(), - F = fun (T, S = {Fs, Vs, Os}) -> - case type(T) of - 'fun' -> - L = get_label(T), - As = fun_vars(T), - X = case sets:is_element(L, Esc) of - true -> Unsafe; - false -> Empty - end, - {dict:store(L, T, Fs), - bind_vars_single(As, X, Vs), - dict:store(L, none, Os)}; - letrec -> - {Fs, bind_defs(letrec_defs(T), Vs), Os}; - module -> - {Fs, bind_defs(module_defs(T), Vs), Os}; - _ -> - S - end - end, - {Funs, Vars, Out} = cerl_trees:fold(F, {Funs0, Vars0, Out0}, StartFun), - - %% Add the dependency for the loop in 'external': - Dep = add_dep(loop, external, Dep0), - - %% Enter the fixpoint iteration at the StartFun. - St = loop(StartFun, start, #state{vars = Vars, - out = Out, - dep = Dep, - work = init_work(), - funs = Funs, - k = Limit}), - Ms = labels(dict:fetch(escape, St#state.vars)), - {Ms, St#state.vars}. - -loop(T, L, St0) -> -%%% io:fwrite("analyzing: ~w.\n",[L]), -%%% io:fwrite("work: ~w.\n", [St0#state.work]), - Xs0 = dict:fetch(L, St0#state.out), - {Xs1, St1} = visit(fun_body(T), L, St0), - Xs = limit(Xs1, St1#state.k), - {W, M} = case equal(Xs0, Xs) of - true -> - {St1#state.work, St1#state.out}; - false -> -%%% io:fwrite("out (~w) changed: ~w <- ~w.\n", -%%% [L, Xs, Xs0]), - M1 = dict:store(L, Xs, St1#state.out), - case dict:find(L, St1#state.dep) of - {ok, S} -> - {add_work(set__to_list(S), St1#state.work), - M1}; - error -> - {St1#state.work, M1} - end - end, - St2 = St1#state{out = M}, - case take_work(W) of - {ok, L1, W1} -> - T1 = dict:fetch(L1, St2#state.funs), - loop(T1, L1, St2#state{work = W1}); - none -> - St2 - end. - -visit(T, L, St) -> -%%% io:fwrite("visiting: ~w.\n",[type(T)]), - case type(T) of - literal -> - %% This is (or should be) a constant, even if it's compound, - %% so it's bugger all whether it is sent or not. - case cerl:concrete(T) of - [] -> {[empty()], St}; - X when is_atom(X) -> {[empty()], St}; - X when is_integer(X) -> {[empty()], St}; - X when is_float(X) -> {[empty()], St}; - _ -> - exit({not_literal, T}) - end; - var -> - %% If a variable is not already in the store here, it must - %% be free in the program. - L1 = get_label(T), - Vars = St#state.vars, - case dict:find(L1, Vars) of - {ok, X} -> - {[X], St}; - error -> -%%% io:fwrite("free var: ~w.\n",[L1]), - X = unsafe(), - St1 = St#state{vars = dict:store(L1, X, Vars)}, - {[X], St1} - end; - 'fun' -> - %% Must revisit the fun also, because its environment might - %% have changed. (We don't keep track of such dependencies.) - L1 = get_label(T), - St1 = St#state{work = add_work([L1], St#state.work)}, - %% Currently, lambda expressions can only be locally - %% allocated, and therefore we have to force copying by - %% treating them as "unsafe" for now. - {[unsafe()], St1}; - %% {[singleton(L1)], St1}; - values -> - visit_list(values_es(T), L, St); - cons -> - {[X1, X2], St1} = visit_list([cons_hd(T), cons_tl(T)], L, St), - L1 = get_label(T), - X = make_cons(L1, X1, X2), - %% Also store the values of the elements. - Hd = get_hd(X), - Tl = get_tl(X), - St2 = St1#state{vars = dict:store(L1, [Hd, Tl], St1#state.vars)}, - {[X], St2}; - tuple -> - {Xs, St1} = visit_list(tuple_es(T), L, St), - L1 = get_label(T), - %% Also store the values of the elements. - St2 = St1#state{vars = dict:store(L1, Xs, St1#state.vars)}, - {[struct(L1, Xs)], St2}; - 'let' -> - {Xs, St1} = visit(let_arg(T), L, St), - Vars = bind_vars(let_vars(T), Xs, St1#state.vars), - visit(let_body(T), L, St1#state{vars = Vars}); - seq -> - {_, St1} = visit(seq_arg(T), L, St), - visit(seq_body(T), L, St1); - apply -> - {_F, St1} = visit(apply_op(T), L, St), - {As, St2} = visit_list(apply_args(T), L, St1), - L1 = get_label(T), - Ls = get_deps(L1, St#state.dep), - Out = St2#state.out, - Xs1 = join_list([dict:fetch(X, Out) || X <- Ls]), - {Xs1, call_site(Ls, As, St2)}; - call -> - M = call_module(T), - F = call_name(T), - As = call_args(T), - {_, St1} = visit(M, L, St), - {_, St2} = visit(F, L, St1), - {Xs, St3} = visit_list(As, L, St2), - L1 = get_label(T), - remote_call(M, F, Xs, As, L1, St3); - primop -> - As = primop_args(T), - {Xs, St1} = visit_list(As, L, St), - F = atom_val(primop_name(T)), - primop_call(F, length(Xs), Xs, As, St1); - 'case' -> - {Xs, St1} = visit(case_arg(T), L, St), - visit_clauses(Xs, case_clauses(T), L, St1); - 'receive' -> - %% The received value is of course a message, so it - %% is 'empty()', not 'unsafe()'. - X = empty(), - {Xs1, St1} = visit_clauses([X], receive_clauses(T), L, St), - {_, St2} = visit(receive_timeout(T), L, St1), - {Xs2, St3} = visit(receive_action(T), L, St2), - {join(Xs1, Xs2), St3}; - 'try' -> - {Xs1, St1} = visit(try_arg(T), L, St), - X = unsafe(), - Vars = bind_vars(try_vars(T), Xs1, St1#state.vars), - {Xs2, St2} = visit(try_body(T), L, St1#state{vars = Vars}), - EVars = bind_vars(try_evars(T), [X, X, X], St2#state.vars), - {Xs3, St3} = visit(try_handler(T), L, St2#state{vars = EVars}), - {join(Xs2, Xs3), St3}; - 'catch' -> - %% If we catch an exception, we can get unsafe data. - {Xs, St1} = visit(catch_body(T), L, St), - {join([unsafe()], Xs), St1}; - binary -> - %% Binaries are heap objects, but we don't have special - %% shared-heap allocation operators for them at the moment. - %% They must therefore be treated as unsafe. - {_, St1} = visit_list(binary_segments(T), L, St), - {[unsafe()], St1}; - bitstr -> - %% The other fields are constant literals. - {_, St1} = visit(bitstr_val(T), L, St), - {_, St2} = visit(bitstr_size(T), L, St1), - {none, St2}; - letrec -> - %% All the bound funs should be revisited, because the - %% environment might have changed. - Ls = [get_label(F) || {_, F} <- letrec_defs(T)], - St1 = St#state{work = add_work(Ls, St#state.work)}, - visit(letrec_body(T), L, St1); - module -> - %% We regard a module as a tuple of function variables in - %% the body of a `letrec'. - visit(c_letrec(module_defs(T), - ann_c_tuple([{label, get_label(T)}], - module_exports(T))), - L, St) - end. - -visit_clause(T, Xs, L, St) -> - Vars = bind_pats(clause_pats(T), Xs, St#state.vars), - {_, St1} = visit(clause_guard(T), L, St#state{vars = Vars}), - visit(clause_body(T), L, St1). - -%% We assume correct value-list typing. - -visit_list([T | Ts], L, St) -> - {Xs, St1} = visit(T, L, St), - {Xs1, St2} = visit_list(Ts, L, St1), - X = case Xs of - [X1] -> X1; - _ -> empty() - end, - {[X | Xs1], St2}; -visit_list([], _L, St) -> - {[], St}. - -visit_clauses(Xs, [T | Ts], L, St) -> - {Xs1, St1} = visit_clause(T, Xs, L, St), - {Xs2, St2} = visit_clauses(Xs, Ts, L, St1), - {join(Xs1, Xs2), St2}; -visit_clauses(_, [], _L, St) -> - {none, St}. - -bind_defs([{V, F} | Ds], Vars) -> - bind_defs(Ds, dict:store(get_label(V), singleton(get_label(F)), Vars)); -bind_defs([], Vars) -> - Vars. - -bind_pats(Ps, none, Vars) -> - bind_pats_single(Ps, empty(), Vars); -bind_pats(Ps, Xs, Vars) -> - if length(Xs) =:= length(Ps) -> - bind_pats_list(Ps, Xs, Vars); - true -> - bind_pats_single(Ps, empty(), Vars) - end. - -%% The lists might not be of the same length. - -bind_pats_list([P | Ps], [X | Xs], Vars) -> - bind_pats_list(Ps, Xs, bind_pat_vars(P, X, Vars)); -bind_pats_list(Ps, [], Vars) -> - bind_pats_single(Ps, empty(), Vars); -bind_pats_list([], _, Vars) -> - Vars. - -bind_pats_single([P | Ps], X, Vars) -> - bind_pats_single(Ps, X, bind_pat_vars(P, X, Vars)); -bind_pats_single([], _X, Vars) -> - Vars. - -bind_pat_vars(P, X, Vars) -> - case type(P) of - var -> - dict:store(get_label(P), X, Vars); - literal -> - Vars; - cons -> - bind_pats_list([cons_hd(P), cons_tl(P)], - [get_hd(X), get_tl(X)], Vars); - tuple -> - case elements(X) of - none -> - bind_vars_single(pat_vars(P), X, Vars); - Xs -> - bind_pats_list(tuple_es(P), Xs, Vars) - end; - binary -> - %% See the handling of binary-expressions. - bind_pats_single(binary_segments(P), unsafe(), Vars); - bitstr -> - %% See the handling of binary-expressions. - bind_pats_single([bitstr_val(P), bitstr_size(P)], - unsafe(), Vars); - alias -> - P1 = alias_pat(P), - Vars1 = bind_pat_vars(P1, X, Vars), - dict:store(get_label(alias_var(P)), X, Vars1) - end. - -%%% %% This is the "exact" version of list representation, which simply -%%% %% mimics the actual cons, head and tail operations. -%%% make_cons(L, X1, X2) -> -%%% struct(L1, [X1, X2]). -%%% get_hd(X) -> -%%% case elements(X) of -%%% none -> X; -%%% [X1 | _] -> X1; -%%% _ -> empty() -%%% end. -%%% get_tl(X) -> -%%% case elements(X) of -%%% none -> X; -%%% [_, X2 | _] -> X2; -%%% _ -> empty() -%%% end. - -%% This version does not unnecessarily confuse spine labels with element -%% labels, and is safe. However, it loses precision if cons cells are -%% used for other things than proper lists. - -make_cons(L, X1, X2) -> - %% join subtypes and cons locations - join_single(struct(L, [X1]), X2). - -get_hd(X) -> - case elements(X) of - none -> X; - [X1 | _] -> X1; % First element represents list subtype. - _ -> empty() - end. - -get_tl(X) -> X. % Tail of X has same type as X. - -bind_vars(Vs, none, Vars) -> - bind_vars_single(Vs, empty(), Vars); -bind_vars(Vs, Xs, Vars) -> - if length(Vs) =:= length(Xs) -> - bind_vars_list(Vs, Xs, Vars); - true -> - bind_vars_single(Vs, empty(), Vars) - end. - -bind_vars_list([V | Vs], [X | Xs], Vars) -> - bind_vars_list(Vs, Xs, dict:store(get_label(V), X, Vars)); -bind_vars_list([], [], Vars) -> - Vars. - -bind_vars_single([V | Vs], X, Vars) -> - bind_vars_single(Vs, X, dict:store(get_label(V), X, Vars)); -bind_vars_single([], _X, Vars) -> - Vars. - -%% This handles a call site, updating parameter variables with respect -%% to the actual parameters. The 'external' function is handled -%% specially, since it can get an arbitrary number of arguments. For our -%% purposes here, calls to the external function can be ignored. - -call_site(Ls, Xs, St) -> -%%% io:fwrite("call site: ~w -> ~w (~w).\n", [L, Ls, Xs]), - {W, V} = call_site(Ls, Xs, St#state.work, St#state.vars, - St#state.funs, St#state.k), - St#state{work = W, vars = V}. - -call_site([external | Ls], Xs, W, V, Fs, Limit) -> - call_site(Ls, Xs, W, V, Fs, Limit); -call_site([L | Ls], Xs, W, V, Fs, Limit) -> - Vs = fun_vars(dict:fetch(L, Fs)), - case bind_args(Vs, Xs, V, Limit) of - {V1, true} -> - call_site(Ls, Xs, add_work([L], W), V1, Fs, Limit); - {V1, false} -> - call_site(Ls, Xs, W, V1, Fs, Limit) - end; -call_site([], _, W, V, _, _) -> - {W, V}. - -add_dep(Source, Target, Deps) -> - case dict:find(Source, Deps) of - {ok, X} -> - case set__is_member(Target, X) of - true -> - Deps; - false -> -%%% io:fwrite("new dep: ~w <- ~w.\n", [Target, Source]), - dict:store(Source, set__add(Target, X), Deps) - end; - error -> -%%% io:fwrite("new dep: ~w <- ~w.\n", [Target, Source]), - dict:store(Source, set__singleton(Target), Deps) - end. - -%% If the arity does not match the call, nothing is done here. - -bind_args(Vs, Xs, Vars, Limit) -> - if length(Vs) =:= length(Xs) -> - bind_args(Vs, Xs, Vars, Limit, false); - true -> - {Vars, false} - end. - -bind_args([V | Vs], [X | Xs], Vars, Limit, Ch) -> - L = get_label(V), - {Vars1, Ch1} = bind_arg(L, X, Vars, Limit, Ch), - bind_args(Vs, Xs, Vars1, Limit, Ch1); -bind_args([], [], Vars, _Limit, Ch) -> - {Vars, Ch}. - -%% bind_arg(L, X, Vars, Limit) -> -%% bind_arg(L, X, Vars, Limit, false). - -bind_arg(L, X, Vars, Limit, Ch) -> - X0 = dict:fetch(L, Vars), - X1 = limit_single(join_single(X, X0), Limit), - case equal_single(X0, X1) of - true -> - {Vars, Ch}; - false -> -%%% io:fwrite("arg (~w) changed: ~w <- ~w + ~w.\n", -%%% [L, X1, X0, X]), - {dict:store(L, X1, Vars), true} - end. - -%% This handles escapes from things like primops and remote calls. - -escape(Xs, Ns, St) -> - escape(Xs, Ns, 1, St). - -escape([_ | Xs], Ns=[N1 | _], N, St) when is_integer(N1), N1 > N -> - escape(Xs, Ns, N + 1, St); -escape([X | Xs], [N | Ns], N, St) -> - Vars = St#state.vars, - X0 = dict:fetch(escape, Vars), - X1 = join_single(X, X0), - case equal_single(X0, X1) of - true -> - escape(Xs, Ns, N + 1, St); - false -> -%%% io:fwrite("escape changed: ~w <- ~w + ~w.\n", [X1, X0, X]), - Vars1 = dict:store(escape, X1, Vars), - escape(Xs, Ns, N + 1, St#state{vars = Vars1}) - end; -escape(Xs, [_ | Ns], N, St) -> - escape(Xs, Ns, N + 1, St); -escape(_, _, _, St) -> - St. - -%% Handle primop calls: (At present, we assume that all unknown calls -%% yield exactly one value. This might have to be changed.) - -primop_call(F, A, Xs, _As, St0) -> - %% St1 = case is_escape_op(F, A) of - %% [] -> St0; - %% Ns -> escape(Xs, Ns, St0) - %% end, - St1 = St0, - case is_imm_op(F, A) of - true -> - {[empty()], St1}; - false -> - call_unknown(Xs, St1) - end. - -%% Handle remote-calls: (At present, we assume that all unknown calls -%% yield exactly one value. This might have to be changed.) - -remote_call(M, F, Xs, As, L, St) -> - case is_c_atom(M) andalso is_c_atom(F) of - true -> - remote_call_1(atom_val(M), atom_val(F), length(Xs), - Xs, As, L, St); - false -> - %% Unknown function - call_unknown(Xs, St) - end. - -%% When calling an unknown function, we assume that the result does -%% *not* contain any of the constructors in its arguments (but it could -%% return locally allocated data that we don't know about). Note that -%% even a "pure" function can still cons up new data. - -call_unknown(_Xs, St) -> - {[unsafe()], St}. - -%% We need to handle some important standard functions in order to get -%% decent precision. -%% TODO: foldl, map, mapfoldl - -remote_call_1(erlang, hd, 1, [X], _As, _L, St) -> - {[get_hd(X)], St}; -remote_call_1(erlang, tl, 1, [X], _As, _L, St) -> - {[get_tl(X)], St}; -remote_call_1(erlang, element, 2, [_,X], [N|_], _L, St) -> - case elements(X) of - none -> {[X], St}; - Xs -> - case is_c_int(N) of - true -> - N1 = int_val(N), - if is_integer(N1), 1 =< N1, N1 =< length(Xs) -> - {[nth(N1, Xs)], St}; - true -> - {none, St} - end; - false -> - %% Even if we don't know which element is selected, - %% we know that the top level is never part of the - %% returned value. - {[join_single_list(Xs)], St} - end - end; -remote_call_1(erlang, setelement, 3, [_,X, Y], [N|_], L, St) -> - %% The constructor gets the label of the call operation. - case elements(X) of - none -> {[join_single(singleton(L), join_single(X, Y))], St}; - Xs -> - case is_c_int(N) of - true -> - N1 = int_val(N), - if is_integer(N1), 1 =< N1, N1 =< length(Xs) -> - Xs1 = set_nth(N1, Y, Xs), - {[struct(L, Xs1)], St}; - true -> - {none, St} - end; - false -> - %% Even if we don't know which element is selected, - %% we know that the top level is never part of the - %% returned value (a new tuple is always created). - Xs1 = [join_single(Y, X1) || X1 <- Xs], - {[struct(L, Xs1)], St} - end - end; -remote_call_1(erlang, '++', 2, [X1,X2], _As, _L, St) -> - %% Note: this is unsafe for non-proper lists! (See make_cons/3). - %% No safe version is implemented. - {[join_single(X1, X2)], St}; -remote_call_1(erlang, '--', 2, [X1,_X2], _As, _L, St) -> - {[X1], St}; -remote_call_1(lists, append, 2, Xs, As, L, St) -> - remote_call_1(erlang, '++', 2, Xs, As, L, St); -remote_call_1(lists, subtract, 2, Xs, As, L, St) -> - remote_call_1(erlang, '--', 2, Xs, As, L, St); -remote_call_1(M, F, A, Xs, _As, _L, St0) -> - St1 = case is_escape_op(M, F, A) of - [] -> St0; - Ns -> escape(Xs, Ns, St0) - end, - case is_imm_op(M, F, A) of - true -> - {[empty()], St1}; - false -> - call_unknown(Xs, St1) - end. - -%% 1-based n:th-element list selector and update function. - -nth(1, [X | _Xs]) -> X; -nth(N, [_X | Xs]) when N > 1 -> nth(N - 1, Xs). - -set_nth(1, Y, [_X | Xs]) -> [Y | Xs]; -set_nth(N, Y, [X | Xs]) when N > 1 -> [X | set_nth(N - 1, Y, Xs)]. - -%% Domain: none | [V], where V = {S, none} | {S, [V]}, S = set(integer()). - -join(none, Xs2) -> Xs2; -join(Xs1, none) -> Xs1; -join(Xs1, Xs2) -> - if length(Xs1) =:= length(Xs2) -> - join_1(Xs1, Xs2); - true -> - none - end. - -join_1([X1 | Xs1], [X2 | Xs2]) -> - [join_single(X1, X2) | join_1(Xs1, Xs2)]; -join_1([], []) -> - []. - -join_list([Xs | Xss]) -> - join(Xs, join_list(Xss)); -join_list([]) -> - none. - -empty() -> {set__new(), []}. - -singleton(X) -> {set__singleton(X), []}. - -struct(X, Xs) -> {set__singleton(X), Xs}. - -elements({_, Xs}) -> Xs. - -unsafe() -> {set__singleton(unsafe), none}. - -equal(none, none) -> true; -equal(none, _) -> false; -equal(_, none) -> false; -equal(X1, X2) -> equal_1(X1, X2). - -equal_1([X1 | Xs1], [X2 | Xs2]) -> - equal_single(X1, X2) andalso equal_1(Xs1, Xs2); -equal_1([], []) -> true; -equal_1(_, _) -> false. - -equal_single({S1, none}, {S2, none}) -> - set__equal(S1, S2); -equal_single({_, none}, _) -> - false; -equal_single(_, {_, none}) -> - false; -equal_single({S1, Vs1}, {S2, Vs2}) -> - set__equal(S1, S2) andalso equal_single_lists(Vs1, Vs2). - -equal_single_lists([X1 | Xs1], [X2 | Xs2]) -> - equal_single(X1, X2) andalso equal_single_lists(Xs1, Xs2); -equal_single_lists([], []) -> - true; -equal_single_lists(_, _) -> - false. - -join_single({S, none}, V) -> - {set__union(S, labels(V)), none}; -join_single(V, {S, none}) -> - {set__union(S, labels(V)), none}; -join_single({S1, Vs1}, {S2, Vs2}) -> - {set__union(S1, S2), join_single_lists(Vs1, Vs2)}. - -join_single_list([V | Vs]) -> - join_single(V, join_single_list(Vs)); -join_single_list([]) -> - empty(). - -%% If one list has more elements that the other, and N is the length of -%% the longer list, then the result has N elements. - -join_single_lists([V1], [V2]) -> - [join_single(V1, V2)]; -join_single_lists([V1 | Vs1], [V2 | Vs2]) -> - [join_single(V1, V2) | join_single_lists(Vs1, Vs2)]; -join_single_lists([], Vs) -> Vs; -join_single_lists(Vs, []) -> Vs. - -collapse(V) -> - {labels(V), none}. - -%% collapse_list([]) -> -%% empty(); -%% collapse_list(Vs) -> -%% {labels_list(Vs), none}. - -labels({S, none}) -> S; -labels({S, []}) -> S; -labels({S, Vs}) -> set__union(S, labels_list(Vs)). - -labels_list([V]) -> - labels(V); -labels_list([V | Vs]) -> - set__union(labels(V), labels_list(Vs)). - -limit(none, _K) -> none; -limit(X, K) -> limit_list(X, K). - -limit_list([X | Xs], K) -> - [limit_single(X, K) | limit_list(Xs, K)]; -limit_list([], _) -> - []. - -limit_single({_, none} = V, _K) -> - V; -limit_single({_, []} = V, _K) -> - V; -limit_single({S, Vs}, K) when K > 0 -> - {S, limit_list(Vs, K - 1)}; -limit_single(V, _K) -> - collapse(V). - -%% Set abstraction for label sets in the domain. - -%% set__is_empty([]) -> true; -%% set__is_empty(_) -> false. - -set__new() -> []. - -set__singleton(X) -> [X]. - -set__to_list(S) -> S. - -%% set__from_list(S) -> ordsets:from_list(S). - -set__union(X, Y) -> ordsets:union(X, Y). - -set__add(X, S) -> ordsets:add_element(X, S). - -set__is_member(X, S) -> ordsets:is_element(X, S). - -%% set__subtract(X, Y) -> ordsets:subtract(X, Y). - -set__equal(X, Y) -> X =:= Y. - -%% A simple but efficient functional queue. - -queue__new() -> {[], []}. - -queue__put(X, {In, Out}) -> {[X | In], Out}. - -queue__get({In, [X | Out]}) -> {ok, X, {In, Out}}; -queue__get({[], _}) -> empty; -queue__get({In, _}) -> - [X | In1] = lists:reverse(In), - {ok, X, {[], In1}}. - -%% The work list - a queue without repeated elements. - -init_work() -> - {queue__new(), sets:new()}. - -add_work(Ls, {Q, Set}) -> - add_work(Ls, Q, Set). - -%% Note that the elements are enqueued in order. - -add_work([L | Ls], Q, Set) -> - case sets:is_element(L, Set) of - true -> - add_work(Ls, Q, Set); - false -> - add_work(Ls, queue__put(L, Q), sets:add_element(L, Set)) - end; -add_work([], Q, Set) -> - {Q, Set}. - -take_work({Queue0, Set0}) -> - case queue__get(Queue0) of - {ok, L, Queue1} -> - Set1 = sets:del_element(L, Set0), - {ok, L, {Queue1, Set1}}; - empty -> - none - end. - -get_deps(L, Dep) -> - case dict:find(L, Dep) of - {ok, Ls} -> Ls; - error -> [] - end. - -%% Escape operators may let their arguments escape. For this analysis, -%% only send-operations are considered as causing escapement, and only -%% in specific arguments. - -%% is_escape_op(_F, _A) -> []. - --spec is_escape_op(atom(), atom(), arity()) -> [arity()]. - -is_escape_op(erlang, '!', 2) -> [2]; -is_escape_op(erlang, send, 2) -> [2]; -is_escape_op(erlang, spawn, 1) -> [1]; -is_escape_op(erlang, spawn, 3) -> [3]; -is_escape_op(erlang, spawn, 4) -> [4]; -is_escape_op(erlang, spawn_link, 3) -> [3]; -is_escape_op(erlang, spawn_link, 4) -> [4]; -is_escape_op(_M, _F, _A) -> []. - -%% "Immediate" operators will never return heap allocated data. This is -%% of course true for operators that never return, like 'exit/1'. (Note -%% that floats are always heap allocated objects, and that most integer -%% arithmetic can return a bignum on the heap.) - --spec is_imm_op(atom(), arity()) -> boolean(). - -is_imm_op(match_fail, 1) -> true; -is_imm_op(_, _) -> false. - --spec is_imm_op(atom(), atom(), arity()) -> boolean(). - -is_imm_op(erlang, self, 0) -> true; -is_imm_op(erlang, '=:=', 2) -> true; -is_imm_op(erlang, '==', 2) -> true; -is_imm_op(erlang, '=/=', 2) -> true; -is_imm_op(erlang, '/=', 2) -> true; -is_imm_op(erlang, '<', 2) -> true; -is_imm_op(erlang, '=<', 2) -> true; -is_imm_op(erlang, '>', 2) -> true; -is_imm_op(erlang, '>=', 2) -> true; -is_imm_op(erlang, 'and', 2) -> true; -is_imm_op(erlang, 'or', 2) -> true; -is_imm_op(erlang, 'xor', 2) -> true; -is_imm_op(erlang, 'not', 1) -> true; -is_imm_op(erlang, is_alive, 0) -> true; -is_imm_op(erlang, is_atom, 1) -> true; -is_imm_op(erlang, is_binary, 1) -> true; -is_imm_op(erlang, is_builtin, 3) -> true; -is_imm_op(erlang, is_float, 1) -> true; -is_imm_op(erlang, is_function, 1) -> true; -is_imm_op(erlang, is_integer, 1) -> true; -is_imm_op(erlang, is_list, 1) -> true; -is_imm_op(erlang, is_number, 1) -> true; -is_imm_op(erlang, is_pid, 1) -> true; -is_imm_op(erlang, is_port, 1) -> true; -is_imm_op(erlang, is_process_alive, 1) -> true; -is_imm_op(erlang, is_reference, 1) -> true; -is_imm_op(erlang, is_tuple, 1) -> true; -is_imm_op(erlang, length, 1) -> true; % never a bignum -is_imm_op(erlang, list_to_atom, 1) -> true; -is_imm_op(erlang, node, 0) -> true; -is_imm_op(erlang, node, 1) -> true; -is_imm_op(erlang, throw, 1) -> true; -is_imm_op(erlang, exit, 1) -> true; -is_imm_op(erlang, error, 1) -> true; -is_imm_op(erlang, error, 2) -> true; -is_imm_op(_M, _F, _A) -> false. diff --git a/lib/hipe/cerl/erl_bif_types.erl b/lib/hipe/cerl/erl_bif_types.erl index 518f67ee1b..fe6ab0659c 100644 --- a/lib/hipe/cerl/erl_bif_types.erl +++ b/lib/hipe/cerl/erl_bif_types.erl @@ -585,6 +585,13 @@ type(erlang, float, 1, Xs, Opaques) -> %% Guard bif, needs to be here. type(erlang, floor, 1, Xs, Opaques) -> strict(erlang, floor, 1, Xs, fun (_) -> t_integer() end, Opaques); +%% Primop, needs to be somewhere. +type(erlang, build_stacktrace, 0, _, _Opaques) -> + t_list(t_tuple([t_module(), + t_atom(), + t_sup([t_arity(),t_list()]), + t_list(t_sup([t_tuple([t_atom('file'),t_string()]), + t_tuple([t_atom('line'),t_pos_integer()])]))])); %% Guard bif, needs to be here. type(erlang, hd, 1, Xs, Opaques) -> strict(erlang, hd, 1, Xs, fun ([X]) -> t_cons_hd(X) end, Opaques); @@ -763,6 +770,9 @@ type(erlang, length, 1, Xs, Opaques) -> %% Guard bif, needs to be here. type(erlang, map_size, 1, Xs, Opaques) -> type(maps, size, 1, Xs, Opaques); +%% Guard bif, needs to be here. +type(erlang, map_get, 2, Xs, Opaques) -> + type(maps, get, 2, Xs, Opaques); type(erlang, make_fun, 3, Xs, Opaques) -> strict(erlang, make_fun, 3, Xs, fun ([_, _, Arity]) -> @@ -1701,24 +1711,6 @@ type(maps, size, 1, Xs, Opaques) -> t_from_range(LowerBound, UpperBound) end end, Opaques); -type(maps, to_list, 1, Xs, Opaques) -> - strict(maps, to_list, 1, Xs, - fun ([Map]) -> - DefK = t_map_def_key(Map, Opaques), - DefV = t_map_def_val(Map, Opaques), - Pairs = t_map_entries(Map, Opaques), - EType = lists:foldl( - fun({K,_,V},EType0) -> - case t_is_none(V) of - true -> t_subtract(EType0, t_tuple([K,t_any()])); - false -> t_sup(EType0, t_tuple([K,V])) - end - end, t_tuple([DefK, DefV]), Pairs), - case t_is_none(EType) of - true -> t_nil(); - false -> t_list(EType) - end - end, Opaques); type(maps, update, 3, Xs, Opaques) -> strict(maps, update, 3, Xs, fun ([Key, Value, Map]) -> @@ -2354,6 +2346,9 @@ arg_types(erlang, float, 1) -> %% Guard bif, needs to be here. arg_types(erlang, floor, 1) -> [t_number()]; +%% Primop, needs to be somewhere. +arg_types(erlang, build_stacktrace, 0) -> + []; %% Guard bif, needs to be here. arg_types(erlang, hd, 1) -> [t_cons()]; @@ -2399,6 +2394,9 @@ arg_types(erlang, length, 1) -> %% Guard bif, needs to be here. arg_types(erlang, map_size, 1) -> [t_map()]; +%% Guard bif, needs to be here. +arg_types(erlang, map_get, 2) -> + [t_map(), t_any()]; arg_types(erlang, make_fun, 3) -> [t_atom(), t_atom(), t_arity()]; arg_types(erlang, make_tuple, 2) -> @@ -2651,8 +2649,6 @@ arg_types(maps, put, 3) -> [t_any(), t_any(), t_map()]; arg_types(maps, size, 1) -> [t_map()]; -arg_types(maps, to_list, 1) -> - [t_map()]; arg_types(maps, update, 3) -> [t_any(), t_any(), t_map()]; arg_types(M, F, A) when is_atom(M), is_atom(F), diff --git a/lib/hipe/cerl/erl_types.erl b/lib/hipe/cerl/erl_types.erl index 2b290b2f23..a91da97f93 100644 --- a/lib/hipe/cerl/erl_types.erl +++ b/lib/hipe/cerl/erl_types.erl @@ -217,7 +217,7 @@ ]). %%-define(DO_ERL_TYPES_TEST, true). --compile({no_auto_import,[min/2,max/2]}). +-compile({no_auto_import,[min/2,max/2,map_get/2]}). -ifdef(DO_ERL_TYPES_TEST). -export([test/0]). @@ -4257,13 +4257,13 @@ t_to_string(?identifier(Set), _RecDict) -> case Set of ?any -> "identifier()"; _ -> - string:join([flat_format("~w()", [T]) || T <- set_to_list(Set)], " | ") + flat_join([flat_format("~w()", [T]) || T <- set_to_list(Set)], " | ") end; t_to_string(?opaque(Set), RecDict) -> - string:join([opaque_type(Mod, Name, Args, S, RecDict) || - #opaque{mod = Mod, name = Name, struct = S, args = Args} - <- set_to_list(Set)], - " | "); + flat_join([opaque_type(Mod, Name, Args, S, RecDict) || + #opaque{mod = Mod, name = Name, struct = S, args = Args} + <- set_to_list(Set)], + " | "); t_to_string(?matchstate(Pres, Slots), RecDict) -> flat_format("ms(~ts,~ts)", [t_to_string(Pres, RecDict), t_to_string(Slots,RecDict)]); @@ -4354,9 +4354,9 @@ t_to_string(?map(Pairs0,DefK,DefV), RecDict) -> end end, StrMand = [{Tos(K),Tos(V)}||{K,?mand,V}<-Pairs], StrOpt = [{Tos(K),Tos(V)}||{K,?opt,V}<-Pairs], - "#{" ++ string:join([K ++ ":=" ++ V||{K,V}<-StrMand] - ++ [K ++ "=>" ++ V||{K,V}<-StrOpt] - ++ ExtraEl, ", ") ++ "}"; + "#{" ++ flat_join([K ++ ":=" ++ V||{K,V}<-StrMand] + ++ [K ++ "=>" ++ V||{K,V}<-StrOpt] + ++ ExtraEl, ", ") ++ "}"; t_to_string(?tuple(?any, ?any, ?any), _RecDict) -> "tuple()"; t_to_string(?tuple(Elements, _Arity, ?any), RecDict) -> "{" ++ comma_sequence(Elements, RecDict) ++ "}"; @@ -4379,7 +4379,7 @@ t_to_string(?var(Id), _RecDict) when is_integer(Id) -> record_to_string(Tag, [_|Fields], FieldNames, RecDict) -> FieldStrings = record_fields_to_string(Fields, FieldNames, RecDict, []), - "#" ++ atom_to_string(Tag) ++ "{" ++ string:join(FieldStrings, ",") ++ "}". + "#" ++ atom_to_string(Tag) ++ "{" ++ flat_join(FieldStrings, ",") ++ "}". record_fields_to_string([F|Fs], [{FName, _Abstr, DefType}|FDefs], RecDict, Acc) -> @@ -4405,7 +4405,7 @@ record_field_diffs_to_string(?tuple([_|Fs], Arity, Tag), RecDict) -> {ok, FieldNames} = lookup_record(TagAtom, Arity-1, RecDict), %% io:format("RecCElems = ~p\nRecTypes = ~p\n", [Fs, FieldNames]), FieldDiffs = field_diffs(Fs, FieldNames, RecDict, []), - string:join(FieldDiffs, " and "). + flat_join(FieldDiffs, " and "). field_diffs([F|Fs], [{FName, _Abstr, DefType}|FDefs], RecDict, Acc) -> %% Don't care about opacity for now. @@ -4425,11 +4425,11 @@ comma_sequence(Types, RecDict) -> true -> "_"; false -> t_to_string(T, RecDict) end || T <- Types], - string:join(List, ","). + flat_join(List, ","). union_sequence(Types, RecDict) -> List = [t_to_string(T, RecDict) || T <- Types], - string:join(List, " | "). + flat_join(List, " | "). -ifdef(DEBUG). opaque_type(Mod, Name, _Args, S, RecDict) -> @@ -5269,7 +5269,7 @@ t_form_to_string({ann_type, _L, [Var, Type]}) -> t_form_to_string({paren_type, _L, [Type]}) -> flat_format("(~ts)", [t_form_to_string(Type)]); t_form_to_string({remote_type, _L, [{atom, _, Mod}, {atom, _, Name}, Args]}) -> - ArgString = "(" ++ string:join(t_form_to_string_list(Args), ",") ++ ")", + ArgString = "(" ++ flat_join(t_form_to_string_list(Args), ",") ++ ")", flat_format("~w:~tw", [Mod, Name]) ++ ArgString; t_form_to_string({type, _L, arity, []}) -> "arity()"; t_form_to_string({type, _L, binary, []}) -> "binary()"; @@ -5292,7 +5292,7 @@ t_form_to_string({type, _L, 'fun', []}) -> "fun()"; t_form_to_string({type, _L, 'fun', [{type, _, any}, Range]}) -> "fun(...) -> " ++ t_form_to_string(Range); t_form_to_string({type, _L, 'fun', [{type, _, product, Domain}, Range]}) -> - "fun((" ++ string:join(t_form_to_string_list(Domain), ",") ++ ") -> " + "fun((" ++ flat_join(t_form_to_string_list(Domain), ",") ++ ") -> " ++ t_form_to_string(Range) ++ ")"; t_form_to_string({type, _L, iodata, []}) -> "iodata()"; t_form_to_string({type, _L, iolist, []}) -> "iolist()"; @@ -5300,7 +5300,7 @@ t_form_to_string({type, _L, list, [Type]}) -> "[" ++ t_form_to_string(Type) ++ "]"; t_form_to_string({type, _L, map, any}) -> "map()"; t_form_to_string({type, _L, map, Args}) -> - "#{" ++ string:join(t_form_to_string_list(Args), ",") ++ "}"; + "#{" ++ flat_join(t_form_to_string_list(Args), ",") ++ "}"; t_form_to_string({type, _L, map_field_assoc, [Key, Val]}) -> t_form_to_string(Key) ++ "=>" ++ t_form_to_string(Val); t_form_to_string({type, _L, map_field_exact, [Key, Val]}) -> @@ -5312,7 +5312,7 @@ t_form_to_string({type, _L, nonempty_list, [Type]}) -> "[" ++ t_form_to_string(Type) ++ ",...]"; t_form_to_string({type, _L, nonempty_string, []}) -> "nonempty_string()"; t_form_to_string({type, _L, product, Elements}) -> - "<" ++ string:join(t_form_to_string_list(Elements), ",") ++ ">"; + "<" ++ flat_join(t_form_to_string_list(Elements), ",") ++ ">"; t_form_to_string({type, _L, range, [From, To]} = Type) -> case {erl_eval:partial_eval(From), erl_eval:partial_eval(To)} of {{integer, _, FromVal}, {integer, _, ToVal}} -> @@ -5322,7 +5322,7 @@ t_form_to_string({type, _L, range, [From, To]} = Type) -> t_form_to_string({type, _L, record, [{atom, _, Name}]}) -> flat_format("#~tw{}", [Name]); t_form_to_string({type, _L, record, [{atom, _, Name}|Fields]}) -> - FieldString = string:join(t_form_to_string_list(Fields), ","), + FieldString = flat_join(t_form_to_string_list(Fields), ","), flat_format("#~tw{~ts}", [Name, FieldString]); t_form_to_string({type, _L, field_type, [{atom, _, Name}, Type]}) -> flat_format("~tw::~ts", [Name, t_form_to_string(Type)]); @@ -5330,9 +5330,9 @@ t_form_to_string({type, _L, term, []}) -> "term()"; t_form_to_string({type, _L, timeout, []}) -> "timeout()"; t_form_to_string({type, _L, tuple, any}) -> "tuple()"; t_form_to_string({type, _L, tuple, Args}) -> - "{" ++ string:join(t_form_to_string_list(Args), ",") ++ "}"; + "{" ++ flat_join(t_form_to_string_list(Args), ",") ++ "}"; t_form_to_string({type, _L, union, Args}) -> - string:join(t_form_to_string_list(Args), " | "); + flat_join(t_form_to_string_list(Args), " | "); t_form_to_string({type, _L, Name, []} = T) -> try M = mod, @@ -5350,7 +5350,7 @@ t_form_to_string({type, _L, Name, []} = T) -> end; t_form_to_string({user_type, _L, Name, List}) -> flat_format("~tw(~ts)", - [Name, string:join(t_form_to_string_list(List), ",")]); + [Name, flat_join(t_form_to_string_list(List), ",")]); t_form_to_string({type, L, Name, List}) -> %% Compatibility: modules compiled before Erlang/OTP 18.0. t_form_to_string({user_type, L, Name, List}). @@ -5611,7 +5611,7 @@ set_to_string(Set) -> true -> io_lib:write_string(atom_to_list(X), $'); % stupid emacs ' false -> flat_format("~tw", [X]) end || X <- set_to_list(Set)], - string:join(L, " | "). + flat_join(L, " | "). set_min([H|_]) -> H. @@ -5621,6 +5621,9 @@ set_max(Set) -> flat_format(F, S) -> lists:flatten(io_lib:format(F, S)). +flat_join(List, Sep) -> + lists:flatten(lists:join(Sep, List)). + %%============================================================================= %% %% Utilities for the binary type diff --git a/lib/hipe/doc/src/hipe_app.xml b/lib/hipe/doc/src/hipe_app.xml index 9299c6d73f..fc42ecd97d 100644 --- a/lib/hipe/doc/src/hipe_app.xml +++ b/lib/hipe/doc/src/hipe_app.xml @@ -100,19 +100,43 @@ </item> <tag>Optimization for <c>receive</c> with unique references</tag> - <item><p>The BEAM compiler can do an optimization when - a <c>receive</c> statement is <em>only</em> waiting for messages - containing a reference created before the receive. All messages - that existed in the queue when the reference was created will be - bypassed, as they cannot possibly contain the reference. HiPE - does not implement this optimization.</p> - <p>An example of this is when - <c>gen_server:call()</c> waits for the reply message.</p> + <item> + <p> + The BEAM compiler can do an optimization when a receive + statement is only waiting for messages containing a reference + created before the receive. All messages that existed in the + queue when the reference was created will be bypassed, as they + cannot possibly contain the reference. HiPE currently has an + optimization similar this, but it is not guaranteed to + bypass all messages. In the worst case scenario it, cannot + bypass any messages at all. + </p> + <p> + An example of this is when <c>gen_server:call()</c> waits for + the reply message. + </p> </item> </taglist> </section> <section> + <title>Stability Issues</title> + <taglist> + <tag>Not yielding in <c>receive</c> statements</tag> + <item> + <p>HiPE will not yield in <c>receive</c> statements where + appropriate. If a process have lots of signals in its signal + queue and execute a HiPE compiled <c>receive</c> statement, + the scheduler thread performing the execution may be stuck + in the <c>receive</c> statement for a very long time. This + can in turn cause various severe issues such as for example + prevent the runtime system from being able to release + memory. + </p> + </item> + </taglist> + </section> + <section> <title>SEE ALSO</title> <p> <seealso marker="stdlib:c">c(3)</seealso>, diff --git a/lib/hipe/icode/hipe_beam_to_icode.erl b/lib/hipe/icode/hipe_beam_to_icode.erl index 2abecf7f18..f429d40272 100644 --- a/lib/hipe/icode/hipe_beam_to_icode.erl +++ b/lib/hipe/icode/hipe_beam_to_icode.erl @@ -415,11 +415,13 @@ trans_fun([{wait_timeout,{_,Lbl},Reg}|Instructions], Env) -> SuspTmout = hipe_icode:mk_if(suspend_msg_timeout,[], map_label(Lbl),hipe_icode:label_name(DoneLbl)), Movs ++ [SetTmout, SuspTmout, DoneLbl | trans_fun(Instructions,Env1)]; -%%--- recv_mark/1 & recv_set/1 --- XXX: Handle better?? +%%--- recv_mark/1 & recv_set/1 --- trans_fun([{recv_mark,{f,_}}|Instructions], Env) -> - trans_fun(Instructions,Env); + Mark = hipe_icode:mk_primop([],recv_mark,[]), + [Mark | trans_fun(Instructions,Env)]; trans_fun([{recv_set,{f,_}}|Instructions], Env) -> - trans_fun(Instructions,Env); + Set = hipe_icode:mk_primop([],recv_set,[]), + [Set | trans_fun(Instructions,Env)]; %%-------------------------------------------------------------------- %%--- Translation of arithmetics {bif,ArithOp, ...} --- %%-------------------------------------------------------------------- @@ -603,6 +605,16 @@ trans_fun([{get_list,List,Head,Tail}|Instructions], Env) -> ?error_msg("hd and tl regs identical in get_list~n",[]), erlang:error(not_handled) end; +%%--- get_hd --- +trans_fun([{get_hd,List,Head}|Instructions], Env) -> + TransList = [trans_arg(List)], + I = hipe_icode:mk_primop([mk_var(Head)],unsafe_hd,TransList), + [I | trans_fun(Instructions,Env)]; +%%--- get_tl --- +trans_fun([{get_tl,List,Tail}|Instructions], Env) -> + TransList = [trans_arg(List)], + I = hipe_icode:mk_primop([mk_var(Tail)],unsafe_tl,TransList), + [I | trans_fun(Instructions,Env)]; %%--- get_tuple_element --- trans_fun([{get_tuple_element,Xreg,Index,Dst}|Instructions], Env) -> I = hipe_icode:mk_primop([mk_var(Dst)], @@ -794,7 +806,7 @@ trans_fun([{bs_append,{f,Lbl},Size,W,R,U,Binary,{field_flags,F},Dst}| SizeArg = trans_arg(Size), BinArg = trans_arg(Binary), IcodeDst = mk_var(Dst), - Offset = mk_var(reg), + Offset = mk_var(reg_gcsafe), Base = mk_var(reg), trans_bin_call({hipe_bs_primop,{bs_append,W,R,U,F}},Lbl,[SizeArg,BinArg], [IcodeDst,Base,Offset], @@ -805,7 +817,7 @@ trans_fun([{bs_private_append,{f,Lbl},Size,U,Binary,{field_flags,F},Dst}| SizeArg = trans_arg(Size), BinArg = trans_arg(Binary), IcodeDst = mk_var(Dst), - Offset = mk_var(reg), + Offset = mk_var(reg_gcsafe), Base = mk_var(reg), trans_bin_call({hipe_bs_primop,{bs_private_append,U,F}}, Lbl,[SizeArg,BinArg], @@ -844,7 +856,7 @@ trans_fun([{bs_init2,{f,Lbl},Size,_Words,_LiveRegs,{field_flags,Flags0},X}| Instructions], Env) -> Dst = mk_var(X), Flags = resolve_native_endianess(Flags0), - Offset = mk_var(reg), + Offset = mk_var(reg_gcsafe), Base = mk_var(reg), {Name, Args} = case Size of @@ -860,7 +872,7 @@ trans_fun([{bs_init_bits,{f,Lbl},Size,_Words,_LiveRegs,{field_flags,Flags0},X}| Instructions], Env) -> Dst = mk_var(X), Flags = resolve_native_endianess(Flags0), - Offset = mk_var(reg), + Offset = mk_var(reg_gcsafe), Base = mk_var(reg), {Name, Args} = case Size of @@ -1157,6 +1169,17 @@ trans_fun([{put_map_exact,{f,Lbl},Map,Dst,_N,{list,Pairs}}|Instructions], Env) - gen_put_map_instrs(new, exact, TempMapVar, Dst, new, Pairs, Env1) end, [MapMove, TempMapMove, PutInstructions | trans_fun(Instructions, Env2)]; +%%--- build_stacktrace --- +trans_fun([build_stacktrace|Instructions], Env) -> + Vars = [mk_var({x,0})], %{x,0} is implict arg and dst + [hipe_icode:mk_primop(Vars,build_stacktrace,Vars), + trans_fun(Instructions, Env)]; +%%--- raw_raise --- +trans_fun([raw_raise|Instructions], Env) -> + Vars = [mk_var({x,0}),mk_var({x,1}),mk_var({x,2})], + Dst = [mk_var({x,0})], + [hipe_icode:mk_primop(Dst,raw_raise,Vars) | + trans_fun(Instructions, Env)]; %%-------------------------------------------------------------------- %%--- ERROR HANDLING --- %%-------------------------------------------------------------------- @@ -1505,7 +1528,10 @@ clone_dst(Dest) -> New = case hipe_icode:is_reg(Dest) of true -> - mk_var(reg); + case hipe_icode:reg_is_gcsafe(Dest) of + true -> mk_var(reg_gcsafe); + false -> mk_var(reg) + end; false -> true = hipe_icode:is_var(Dest), mk_var(new) @@ -2126,7 +2152,12 @@ mk_var(reg) -> T = hipe_gensym:new_var(icode), V = (5*T)+4, hipe_gensym:update_vrange(icode,V), - hipe_icode:mk_reg(V). + hipe_icode:mk_reg(V); +mk_var(reg_gcsafe) -> + T = hipe_gensym:new_var(icode), + V = (5*T)+4, % same namespace as 'reg' + hipe_gensym:update_vrange(icode,V), + hipe_icode:mk_reg_gcsafe(V). %%----------------------------------------------------------------------- %% Make an icode label of proper type @@ -2296,6 +2327,12 @@ split_code([First|Code], Label, Instr) -> split_code([Instr|Code], Label, Instr, Prev, As) when Prev =:= Label -> split_code_final(Code, As); % drop both label and instruction +split_code([{icode_end_try}|_]=Code, Label, {try_case,_}, Prev, As) + when Prev =:= Label -> + %% The try_case has been replaced with try_end as an optimization. + %% Keep this instruction, since it might be the only try_end instruction + %% for this try/catch block. + split_code_final(Code, As); % drop label split_code([Other|_Code], Label, Instr, Prev, _As) when Prev =:= Label -> ?EXIT({missing_instr_after_label, Label, Instr, [Other, Prev | _As]}); split_code([Other|Code], Label, Instr, Prev, As) -> diff --git a/lib/hipe/icode/hipe_icode.erl b/lib/hipe/icode/hipe_icode.erl index 24b7ac4783..bc3403b0c5 100644 --- a/lib/hipe/icode/hipe_icode.erl +++ b/lib/hipe/icode/hipe_icode.erl @@ -515,10 +515,12 @@ annotate_variable/2, %% annotate_var_or_reg(VarOrReg, Type) unannotate_variable/1,%% unannotate_var_or_reg(VarOrReg) mk_reg/1, %% mk_reg(Id) + mk_reg_gcsafe/1, %% mk_reg_gcsafe(Id) mk_fvar/1, %% mk_fvar(Id) mk_new_var/0, %% mk_new_var() mk_new_fvar/0, %% mk_new_fvar() mk_new_reg/0, %% mk_new_reg() + mk_new_reg_gcsafe/0, %% mk_new_reg_gcsafe() mk_phi/1, %% mk_phi(Id) mk_phi/2 %% mk_phi(Id, ArgList) ]). @@ -1260,14 +1262,22 @@ is_var(_) -> false. -spec mk_reg(non_neg_integer()) -> #icode_variable{kind::'reg'}. mk_reg(V) -> #icode_variable{name=V, kind=reg}. --spec reg_name(#icode_variable{kind::'reg'}) -> non_neg_integer(). -reg_name(#icode_variable{name=Name, kind=reg}) -> Name. +-spec mk_reg_gcsafe(non_neg_integer()) -> #icode_variable{kind::'reg_gcsafe'}. +mk_reg_gcsafe(V) -> #icode_variable{name=V, kind=reg_gcsafe}. --spec reg_is_gcsafe(#icode_variable{kind::'reg'}) -> 'false'. -reg_is_gcsafe(#icode_variable{kind=reg}) -> false. % for now +-spec reg_name(#icode_variable{kind::'reg'|'reg_gcsafe'}) + -> non_neg_integer(). +reg_name(#icode_variable{name=Name, kind=reg}) -> Name; +reg_name(#icode_variable{name=Name, kind=reg_gcsafe}) -> Name. + +-spec reg_is_gcsafe(#icode_variable{kind::'reg'}) -> 'false'; + (#icode_variable{kind::'reg_gcsafe'}) -> 'true'. +reg_is_gcsafe(#icode_variable{kind=reg}) -> false; +reg_is_gcsafe(#icode_variable{kind=reg_gcsafe}) -> true. -spec is_reg(icode_argument()) -> boolean(). -is_reg(#icode_variable{kind=reg}) -> true; +is_reg(#icode_variable{kind=reg}) -> true; +is_reg(#icode_variable{kind=reg_gcsafe}) -> true; is_reg(_) -> false. -spec mk_fvar(non_neg_integer()) -> #icode_variable{kind::'fvar'}. @@ -1676,6 +1686,16 @@ mk_new_reg() -> mk_reg(hipe_gensym:get_next_var(icode)). %% +%% @doc Makes a new gcsafe register; that is, a register that is allowed to be +%% live over calls and other operations that might cause GCs and thus move heap +%% data around. +%% + +-spec mk_new_reg_gcsafe() -> icode_reg(). +mk_new_reg_gcsafe() -> + mk_reg_gcsafe(hipe_gensym:get_next_var(icode)). + +%% %% @doc Makes a new label. %% diff --git a/lib/hipe/icode/hipe_icode.hrl b/lib/hipe/icode/hipe_icode.hrl index 380ddd8371..7ed80a9ed4 100644 --- a/lib/hipe/icode/hipe_icode.hrl +++ b/lib/hipe/icode/hipe_icode.hrl @@ -41,9 +41,9 @@ -type variable_annotation() :: {atom(), any(), fun((any()) -> string())}. --record(icode_variable, {name :: non_neg_integer(), - kind :: 'var' | 'reg' | 'fvar', - annotation = [] :: [] | variable_annotation()}). +-record(icode_variable, {name :: non_neg_integer(), + kind :: 'var' | 'reg' | 'reg_gcsafe' | 'fvar', + annotation = [] :: [] | variable_annotation()}). %%--------------------------------------------------------------------- %% Type declarations for Icode instructions @@ -66,7 +66,7 @@ -type icode_funcall() :: mfa() | icode_primop(). -type icode_var() :: #icode_variable{kind::'var'}. --type icode_reg() :: #icode_variable{kind::'reg'}. +-type icode_reg() :: #icode_variable{kind::'reg'|'reg_gcsafe'}. -type icode_fvar() :: #icode_variable{kind::'fvar'}. -type icode_argument() :: #icode_const{} | #icode_variable{}. -type icode_term_arg() :: icode_var() | #icode_const{}. diff --git a/lib/hipe/icode/hipe_icode_inline_bifs.erl b/lib/hipe/icode/hipe_icode_inline_bifs.erl index 7a6947f190..16a95991e7 100644 --- a/lib/hipe/icode/hipe_icode_inline_bifs.erl +++ b/lib/hipe/icode/hipe_icode_inline_bifs.erl @@ -24,8 +24,9 @@ %% Currently inlined BIFs: %% and, or, xor, not, <, >, >=, =<, ==, /=, =/=, =:= -%% is_atom, is_boolean, is_binary, is_float, is_function, -%% is_integer, is_list, is_pid, is_port, is_reference, is_tuple +%% is_atom, is_binary, is_bitstring, is_boolean, is_float, +%% is_function, is_integer, is_list, is_map, is_number, +%% is_pid, is_port, is_reference, is_tuple -module(hipe_icode_inline_bifs). @@ -116,17 +117,20 @@ try_type_tests(I) -> I. is_type_test(Name) -> case Name of - is_integer -> {true, integer}; + is_atom -> {true, atom}; + is_binary -> {true, binary}; + is_bitstring -> {true, bitstr}; + is_boolean -> {true, boolean}; is_float -> {true, float}; - is_tuple -> {true, tuple}; - is_binary -> {true, binary}; + is_function -> {true, function}; + is_integer -> {true, integer}; is_list -> {true, list}; + is_map -> {true, map}; + is_number -> {true, number}; is_pid -> {true, pid}; - is_atom -> {true, atom}; - is_boolean -> {true, boolean}; - is_function -> {true, function}; - is_reference -> {true, reference}; is_port -> {true, port}; + is_reference -> {true, reference}; + is_tuple -> {true, tuple}; _ -> false end. diff --git a/lib/hipe/icode/hipe_icode_liveness.erl b/lib/hipe/icode/hipe_icode_liveness.erl index 51e2855108..e61529a1bb 100644 --- a/lib/hipe/icode/hipe_icode_liveness.erl +++ b/lib/hipe/icode/hipe_icode_liveness.erl @@ -77,6 +77,7 @@ print_var(#icode_variable{name=V, kind=Kind, annotation=T}) -> case Kind of var -> io:format("v~p", [V]); reg -> io:format("r~p", [V]); + reg_gcsafe -> io:format("rs~p", [V]); fvar -> io:format("fv~p", [V]) end, case T of diff --git a/lib/hipe/icode/hipe_icode_pp.erl b/lib/hipe/icode/hipe_icode_pp.erl index 5b017dca32..33d1e62884 100644 --- a/lib/hipe/icode/hipe_icode_pp.erl +++ b/lib/hipe/icode/hipe_icode_pp.erl @@ -230,7 +230,10 @@ pp_arg(Dev, Arg) -> case hipe_icode:is_reg(Arg) of true -> N = hipe_icode:reg_name(Arg), - io:format(Dev, "r~p", [N]); + case hipe_icode:reg_is_gcsafe(Arg) of + true -> io:format(Dev, "rs~p", [N]); + false -> io:format(Dev, "r~p", [N]) + end; false -> N = hipe_icode:fvar_name(Arg), io:format(Dev, "fv~p", [N]) diff --git a/lib/hipe/icode/hipe_icode_primops.erl b/lib/hipe/icode/hipe_icode_primops.erl index 50ece05259..a1f1128124 100644 --- a/lib/hipe/icode/hipe_icode_primops.erl +++ b/lib/hipe/icode/hipe_icode_primops.erl @@ -67,6 +67,8 @@ is_safe(fp_mul) -> false; is_safe(fp_sub) -> false; is_safe(mktuple) -> true; is_safe(next_msg) -> false; +is_safe(recv_mark) -> false; +is_safe(recv_set) -> false; is_safe(redtest) -> false; is_safe(select_msg) -> false; is_safe(self) -> true; @@ -130,6 +132,7 @@ is_safe({hipe_bs_primop, {bs_match_string, _, _}}) -> false; is_safe({hipe_bs_primop, {bs_append, _, _, _, _}}) -> false; is_safe({hipe_bs_primop, {bs_private_append, _, _}}) -> false; is_safe({hipe_bs_primop, bs_init_writable}) -> true; +is_safe(build_stacktrace) -> true; is_safe(#mkfun{}) -> true; is_safe(#unsafe_element{}) -> true; is_safe(#unsafe_update_element{}) -> true; @@ -165,6 +168,8 @@ fails(fp_mul) -> false; fails(fp_sub) -> false; fails(mktuple) -> false; fails(next_msg) -> false; +fails(recv_mark) -> false; +fails(recv_set) -> false; fails(redtest) -> false; fails(select_msg) -> false; fails(self) -> false; @@ -230,6 +235,8 @@ fails({hipe_bs_primop, bs_final}) -> false; fails({hipe_bs_primop, {bs_append, _, _, _, _}}) -> true; fails({hipe_bs_primop, {bs_private_append, _, _}}) -> true; fails({hipe_bs_primop, bs_init_writable}) -> true; +fails(build_stacktrace) -> false; +fails(raw_raise) -> true; fails(#mkfun{}) -> false; fails(#unsafe_element{}) -> false; fails(#unsafe_update_element{}) -> false; @@ -709,6 +716,10 @@ type(Primop, Args) -> erl_types:t_any(); next_msg -> erl_types:t_any(); + recv_mark -> + erl_types:t_any(); + recv_set -> + erl_types:t_any(); select_msg -> erl_types:t_any(); set_timeout -> @@ -723,6 +734,10 @@ type(Primop, Args) -> erl_types:t_any(); debug_native_called -> erl_types:t_any(); + build_stacktrace -> + erl_types:t_list(); + raw_raise -> + erl_types:t_atom(); {M, F, A} -> erl_bif_types:type(M, F, A, Args) end. @@ -883,6 +898,10 @@ type(Primop) -> erl_types:t_any(); next_msg -> erl_types:t_any(); + recv_mark -> + erl_types:t_any(); + recv_set -> + erl_types:t_any(); select_msg -> erl_types:t_any(); set_timeout -> @@ -891,6 +910,10 @@ type(Primop) -> erl_types:t_any(); %%% ----------------------------------------------------- %%% Other + build_stacktrace -> + erl_types:t_any(); + raw_raise -> + erl_types:t_any(); #closure_element{} -> erl_types:t_any(); redtest -> diff --git a/lib/hipe/icode/hipe_icode_range.erl b/lib/hipe/icode/hipe_icode_range.erl index 287b1c80fe..34b18acccd 100644 --- a/lib/hipe/icode/hipe_icode_range.erl +++ b/lib/hipe/icode/hipe_icode_range.erl @@ -1160,6 +1160,8 @@ basic_type(#gc_test{}) -> not_analysed; %% Message handling basic_type(check_get_msg) -> not_analysed; basic_type(next_msg) -> not_analysed; +basic_type(recv_mark) -> not_analysed; +basic_type(recv_set) -> not_analysed; basic_type(select_msg) -> not_analysed; basic_type(suspend_msg) -> not_analysed; %% Functions @@ -1184,7 +1186,9 @@ basic_type(unsafe_hd) -> not_analysed; basic_type(unsafe_tl) -> not_int; basic_type(#element{}) -> not_analysed; basic_type(#unsafe_element{}) -> not_analysed; -basic_type(#unsafe_update_element{}) -> not_analysed. +basic_type(#unsafe_update_element{}) -> not_analysed; +basic_type(build_stacktrace) -> not_int; +basic_type(raw_raise) -> not_int. -spec analyse_bs_get_integer(integer(), integer(), boolean()) -> range_tuple(). diff --git a/lib/hipe/llvm/hipe_llvm.erl b/lib/hipe/llvm/hipe_llvm.erl index e04b171194..343ca94cb1 100644 --- a/lib/hipe/llvm/hipe_llvm.erl +++ b/lib/hipe/llvm/hipe_llvm.erl @@ -1005,11 +1005,12 @@ pp_ins(Dev, Ver, I) -> write(Dev, [" ", adj_stack_offset(I),")\n"]); #llvm_meta{} -> 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) -> - ["!", meta_id(Op)] - end || Op <- meta_operands(I)], ", ")), + write(Dev, lists:join(", ", + [if is_list(Op) -> ["!\"", Op, "\""]; + is_integer(Op) -> ["i32 ", integer_to_list(Op)]; + is_record(Op, llvm_meta) -> + ["!", meta_id(Op)] + end || Op <- meta_operands(I)])), write(Dev, " }\n"); Other -> exit({?MODULE, pp_ins, {"Unknown LLVM instruction", Other}}) diff --git a/lib/hipe/llvm/hipe_llvm_main.erl b/lib/hipe/llvm/hipe_llvm_main.erl index 4eec0c752b..54c435c127 100644 --- a/lib/hipe/llvm/hipe_llvm_main.erl +++ b/lib/hipe/llvm/hipe_llvm_main.erl @@ -154,7 +154,7 @@ compiler_target_opt() -> %% @doc Join options. fix_opts(Opts) -> - string:join(Opts, " "). + lists:flatten(lists:join(" ", Opts)). %% @doc Translate optimization-level flag (default is "O2"). trans_optlev_flag(Tool, Options) -> diff --git a/lib/hipe/llvm/hipe_rtl_to_llvm.erl b/lib/hipe/llvm/hipe_rtl_to_llvm.erl index 79e1bfd381..934717efc1 100644 --- a/lib/hipe/llvm/hipe_rtl_to_llvm.erl +++ b/lib/hipe/llvm/hipe_rtl_to_llvm.erl @@ -1537,7 +1537,7 @@ declare_switch_table({Name, {switch, {TableType, Labels, _, _}, _}}, FunName) -> LabelList = [mk_jump_label(L) || L <- Labels], Fun1 = fun(X) -> "i8* blockaddress(@" ++ FunName ++ ", " ++ X ++ ")" end, List2 = lists:map(Fun1, LabelList), - List3 = string:join(List2, ",\n"), + List3 = lists:flatten(lists:join(",\n", List2)), List4 = "[\n" ++ List3 ++ "\n]\n", hipe_llvm:mk_const_decl("@" ++ Name, "constant", TableType, List4). @@ -1553,7 +1553,7 @@ declare_closure_labels(ClosureLabels, Relocs, Fun) -> Relocs1 = relocs_store("table_closures", {table_closures, ArityList}, Relocs), List2 = ["i8* blockaddress(@" ++ FunName ++ ", " ++ L ++ ")" || L <- LabelList], - List3 = string:join(List2, ",\n"), + List3 = lists:flatten(lists:join(",\n", List2)), List4 = "[\n" ++ List3 ++ "\n]\n", NrLabels = length(LabelList), ByteTyPtr = hipe_llvm:mk_pointer(hipe_llvm:mk_int(?BITS_IN_BYTE)), diff --git a/lib/hipe/main/hipe.app.src b/lib/hipe/main/hipe.app.src index eef4b9a34f..7350e873aa 100644 --- a/lib/hipe/main/hipe.app.src +++ b/lib/hipe/main/hipe.app.src @@ -26,7 +26,6 @@ cerl_closurean, cerl_hipeify, cerl_lib, - cerl_messagean, cerl_pmatch, cerl_prettypr, cerl_to_icode, @@ -179,6 +178,7 @@ hipe_rtl_to_sparc, hipe_rtl_to_x86, hipe_rtl_varmap, + hipe_rtl_verify_gcsafe, hipe_segment_trees, hipe_sdi, hipe_sparc, diff --git a/lib/hipe/main/hipe.erl b/lib/hipe/main/hipe.erl index 19b4e8bfe2..97814fe217 100644 --- a/lib/hipe/main/hipe.erl +++ b/lib/hipe/main/hipe.erl @@ -669,8 +669,8 @@ run_compiler_1(Name, DisasmFun, IcodeFun, Options) -> {Icode, WholeModule} = IcodeFun(Code, Opts), CompRes = compile_finish(Icode, WholeModule, Opts), compiler_return(CompRes, Parent) - catch error:Error -> - print_crash_message(Name, Error), + catch error:Error:StackTrace -> + print_crash_message(Name, Error, StackTrace), exit(Error) end end), @@ -757,8 +757,8 @@ finalize(OrigList, Mod, Exports, WholeModule, Opts) -> TargetArch = get(hipe_target_arch), {ok, {TargetArch,Bin}} catch - error:Error -> - {error,Error,erlang:get_stacktrace()} + error:Error:StackTrace -> + {error,Error,StackTrace} end end. @@ -843,16 +843,16 @@ finalize_fun_sequential({MFA, Icode}, Opts, Servers) -> {llvm_binary, Binary} -> {MFA, Binary} catch - error:Error -> + error:Error:StackTrace -> ?when_option(verbose, Opts, ?debug_untagged_msg("\n", [])), - print_crash_message(MFA, Error), + print_crash_message(MFA, Error, StackTrace), exit(Error) end. -print_crash_message(What, Error) -> +print_crash_message(What, Error, StackTrace) -> StackFun = fun(_,_,_) -> false end, FormatFun = fun (Term, _) -> io_lib:format("~p", [Term]) end, - StackTrace = lib:format_stacktrace(1, erlang:get_stacktrace(), + StackTrace = lib:format_stacktrace(1, StackTrace, StackFun, FormatFun), WhatS = case What of {M,F,A} -> io_lib:format("~w:~w/~w", [M,F,A]); @@ -1414,6 +1414,7 @@ opt_keys() -> use_clusters, use_jumptable, verbose, + verify_gcsafe, %% verbose_spills, x87]. @@ -1510,7 +1511,8 @@ opt_negations() -> {no_use_callgraph, use_callgraph}, {no_use_clusters, use_clusters}, {no_use_inline_atom_search, use_inline_atom_search}, - {no_use_indexing, use_indexing}]. + {no_use_indexing, use_indexing}, + {no_verify_gcsafe, verify_gcsafe}]. %% Don't use negative forms in right-hand sides of aliases and expansions! %% We only expand negations once, before the other expansions are done. @@ -1616,11 +1618,11 @@ llvm_support_available() -> get_llvm_version() -> OptStr = os:cmd("opt -version"), SubStr = "LLVM version ", N = length(SubStr), - case string:str(OptStr, SubStr) of - 0 -> % No opt available + case string:find(OptStr, SubStr) of + nomatch -> % No opt available {0, 0}; S -> - case string:tokens(string:sub_string(OptStr, S + N), ".") of + case string:lexemes(string:slice(S, N), ".") of [MajorS, MinorS | _] -> case {string:to_integer(MajorS), string:to_integer(MinorS)} of {{Major, ""}, {Minor, _}} diff --git a/lib/hipe/main/hipe_main.erl b/lib/hipe/main/hipe_main.erl index dca6fddec3..6e48f0cffd 100644 --- a/lib/hipe/main/hipe_main.erl +++ b/lib/hipe/main/hipe_main.erl @@ -410,6 +410,11 @@ icode_to_rtl(MFA, Icode, Options, Servers) -> hipe_llvm_liveness:analyze(RtlCfg4) end, pp(RtlCfg5, MFA, rtl, pp_rtl, Options, Servers), + case proplists:get_bool(no_verify_gcsafe, Options) of + true -> ok; + false -> + ok = hipe_rtl_verify_gcsafe:check(RtlCfg5) + end, LinearRTL1 = hipe_rtl_cfg:linearize(RtlCfg5), LinearRTL2 = hipe_rtl_cleanup_const:cleanup(LinearRTL1), %% hipe_rtl:pp(standard_io, LinearRTL2), diff --git a/lib/hipe/rtl/Makefile b/lib/hipe/rtl/Makefile index 5abc9ec049..becdd0b7d8 100644 --- a/lib/hipe/rtl/Makefile +++ b/lib/hipe/rtl/Makefile @@ -50,7 +50,7 @@ HIPE_MODULES = hipe_rtl hipe_rtl_cfg \ hipe_rtl_ssa hipe_rtl_ssa_const_prop \ hipe_rtl_cleanup_const hipe_rtl_symbolic hipe_rtl_lcm \ hipe_rtl_ssapre hipe_rtl_binary hipe_rtl_ssa_avail_expr \ - hipe_rtl_arch hipe_tagscheme + hipe_rtl_arch hipe_tagscheme hipe_rtl_verify_gcsafe else HIPE_MODULES = endif diff --git a/lib/hipe/rtl/hipe_rtl.erl b/lib/hipe/rtl/hipe_rtl.erl index 04c9728d5c..33027f3259 100644 --- a/lib/hipe/rtl/hipe_rtl.erl +++ b/lib/hipe/rtl/hipe_rtl.erl @@ -1740,7 +1740,10 @@ pp_reg(Dev, Arg) -> true -> pp_hard_reg(Dev, reg_index(Arg)); false -> - io:format(Dev, "r~w", [reg_index(Arg)]) + case reg_is_gcsafe(Arg) of + true -> io:format(Dev, "rs~w", [reg_index(Arg)]); + false -> io:format(Dev, "r~w", [reg_index(Arg)]) + end end. pp_var(Dev, Arg) -> diff --git a/lib/hipe/rtl/hipe_rtl_binary_construct.erl b/lib/hipe/rtl/hipe_rtl_binary_construct.erl index ec7044a2b9..111dda3d82 100644 --- a/lib/hipe/rtl/hipe_rtl_binary_construct.erl +++ b/lib/hipe/rtl/hipe_rtl_binary_construct.erl @@ -363,7 +363,8 @@ not_writable_code(Bin, SizeReg, Dst, Base, Offset, Unit, allocate_writable(Dst, Base, UsedBytes, TotBytes, TotSize) -> Zero = hipe_rtl:mk_imm(0), [NextLbl] = create_lbls(1), - [EndSubSize, EndSubBitSize, ProcBin] = create_regs(3), + [EndSubSize, EndSubBitSize] = create_regs(2), + [ProcBin] = create_unsafe_regs(1), [hipe_rtl:mk_call([Base], bs_allocate, [UsedBytes], hipe_rtl:label_name(NextLbl), [], not_remote), NextLbl, @@ -590,12 +591,12 @@ const_init2(Size, Dst, Base, Offset, TrueLblName) -> false -> ByteSize = hipe_rtl:mk_new_reg(), [hipe_rtl:mk_gctest(?PROC_BIN_WORDSIZE+?SUB_BIN_WORDSIZE), - hipe_rtl:mk_move(Offset, hipe_rtl:mk_imm(0)), hipe_rtl:mk_move(ByteSize, hipe_rtl:mk_imm(Size)), hipe_rtl:mk_call([Base], bs_allocate, [ByteSize], hipe_rtl:label_name(NextLbl), [], not_remote), NextLbl, hipe_tagscheme:create_refc_binary(Base, ByteSize, Dst), + hipe_rtl:mk_move(Offset, hipe_rtl:mk_imm(0)), hipe_rtl:mk_goto(TrueLblName)] end. @@ -638,13 +639,12 @@ var_init2(Size, Dst, Base, Offset, TrueLblName, SystemLimitLblName, FalseLblName Log2WordSize = hipe_rtl_arch:log2_word_size(), WordSize = hipe_rtl_arch:word_size(), [ContLbl, HeapLbl, REFCLbl, NextLbl] = create_lbls(4), - [USize, Tmp] = create_unsafe_regs(2), + [USize, Tmp] = create_regs(2), [get_word_integer(Size, USize, SystemLimitLblName, FalseLblName), hipe_rtl:mk_branch(USize, leu, hipe_rtl:mk_imm(?MAX_BINSIZE), hipe_rtl:label_name(ContLbl), SystemLimitLblName), ContLbl, - hipe_rtl:mk_move(Offset, hipe_rtl:mk_imm(0)), hipe_rtl:mk_branch(USize, leu, hipe_rtl:mk_imm(?MAX_HEAP_BIN_SIZE), hipe_rtl:label_name(HeapLbl), hipe_rtl:label_name(REFCLbl)), @@ -654,6 +654,7 @@ var_init2(Size, Dst, Base, Offset, TrueLblName, SystemLimitLblName, FalseLblName hipe_rtl:mk_alu(Tmp, Tmp, add, hipe_rtl:mk_imm(?SUB_BIN_WORDSIZE)), hipe_rtl:mk_gctest(Tmp), hipe_tagscheme:create_heap_binary(Base, USize, Dst), + hipe_rtl:mk_move(Offset, hipe_rtl:mk_imm(0)), hipe_rtl:mk_goto(TrueLblName), REFCLbl, hipe_rtl:mk_gctest(?PROC_BIN_WORDSIZE+?SUB_BIN_WORDSIZE), @@ -661,6 +662,7 @@ var_init2(Size, Dst, Base, Offset, TrueLblName, SystemLimitLblName, FalseLblName hipe_rtl:label_name(NextLbl), [], not_remote), NextLbl, hipe_tagscheme:create_refc_binary(Base, USize, Dst), + hipe_rtl:mk_move(Offset, hipe_rtl:mk_imm(0)), hipe_rtl:mk_goto(TrueLblName)]. var_init_bits(Size, Dst, Base, Offset, TrueLblName, SystemLimitLblName, FalseLblName) -> @@ -867,7 +869,7 @@ get_base_offset_size(Binary, SrcBase, SrcOffset, SrcSize, FLName) -> JoinLbl, hipe_tagscheme:test_heap_binary(Orig, HeapLblName, REFCLblName), HeapLbl, - hipe_rtl:mk_alu(SrcBase, Orig, add, hipe_rtl:mk_imm(?HEAP_BIN_DATA-2)), + hipe_tagscheme:get_field_addr_from_term({heap_bin, {data, 0}}, Orig, SrcBase), hipe_rtl:mk_goto(EndLblName), REFCLbl, hipe_tagscheme:get_field_from_term({proc_bin,bytes}, Orig, SrcBase), @@ -1214,6 +1216,12 @@ is_divisible(Dividend, Divisor, SuccLbl, FailLbl) -> [hipe_rtl:mk_branch(Dividend, 'and', Mask, eq, SuccLbl, FailLbl, 0.99)]; false -> %% We need division, fall back to a primop - [hipe_rtl:mk_call([], is_divisible, [Dividend, hipe_rtl:mk_imm(Divisor)], - SuccLbl, FailLbl, not_remote)] + [Tmp] = create_regs(1), + RetLbl = hipe_rtl:mk_new_label(), + [hipe_rtl:mk_call([Tmp], is_divisible, + [Dividend, hipe_rtl:mk_imm(Divisor)], + hipe_rtl:label_name(RetLbl), [], not_remote), + RetLbl, + hipe_rtl:mk_branch(Tmp, ne, hipe_rtl:mk_imm(0), + SuccLbl, FailLbl, 0.99)] end. diff --git a/lib/hipe/rtl/hipe_rtl_binary_match.erl b/lib/hipe/rtl/hipe_rtl_binary_match.erl index 362a52f8fe..4575213838 100644 --- a/lib/hipe/rtl/hipe_rtl_binary_match.erl +++ b/lib/hipe/rtl/hipe_rtl_binary_match.erl @@ -730,7 +730,7 @@ get_base(Orig,Base) -> [hipe_tagscheme:test_heap_binary(Orig, hipe_rtl:label_name(HeapLbl), hipe_rtl:label_name(REFCLbl)), HeapLbl, - hipe_rtl:mk_alu(Base, Orig, 'add', hipe_rtl:mk_imm(?HEAP_BIN_DATA-2)), + hipe_tagscheme:get_field_addr_from_term({heap_bin, {data, 0}}, Orig, Base), hipe_rtl:mk_goto(hipe_rtl:label_name(EndLbl)), REFCLbl, get_field_from_term({proc_bin, flags}, Orig, Flags), @@ -740,7 +740,7 @@ get_base(Orig,Base) -> WritableLbl, hipe_rtl:mk_call([], emasculate_binary, [Orig], [], [], 'not_remote'), NotWritableLbl, - hipe_rtl:mk_load(Base, Orig, hipe_rtl:mk_imm(?PROC_BIN_BYTES-2)), + get_field_from_term({proc_bin, bytes}, Orig, Base), EndLbl]. extract_matchstate_var(binsize, Ms) -> @@ -842,12 +842,12 @@ make_dyn_prep(SizeReg, CCode) -> %%------------------------------------------------------------------------ get_unaligned_int(Dst1, Size, Base, Offset, Shiftr, Type, TrueLblName) -> - [Reg] = create_regs(1), + [Reg] = create_gcsafe_regs(1), [get_maybe_unaligned_int_to_reg(Reg, Size, Base, Offset, Shiftr, Type), do_bignum_code(Size, Type, Reg, Dst1, TrueLblName)]. get_maybe_unaligned_int_to_reg(Reg, Size, Base, Offset, Shiftr, Type) -> - [LowBits] = create_regs(1), + [LowBits] = create_gcsafe_regs(1), [AlignedLbl, UnAlignedLbl, EndLbl] = create_lbls(3), [hipe_rtl:mk_alub(LowBits, Offset, 'and', hipe_rtl:mk_imm(?LOW_BITS), eq, hipe_rtl:label_name(AlignedLbl), @@ -1001,7 +1001,7 @@ do_bignum_code(Size, {Signedness,_}, Src, Dst1, TrueLblName) end. signed_bignum(Dst1, Src, TrueLblName) -> - Tmp1 = hipe_rtl:mk_new_reg(), + Tmp1 = hipe_rtl:mk_new_reg_gcsafe(), BignumLabel = hipe_rtl:mk_new_label(), [hipe_tagscheme:realtag_fixnum(Dst1, Src), hipe_tagscheme:realuntag_fixnum(Tmp1, Dst1), diff --git a/lib/hipe/rtl/hipe_rtl_cleanup_const.erl b/lib/hipe/rtl/hipe_rtl_cleanup_const.erl index bfa6b9682e..00cc2bcb37 100644 --- a/lib/hipe/rtl/hipe_rtl_cleanup_const.erl +++ b/lib/hipe/rtl/hipe_rtl_cleanup_const.erl @@ -69,9 +69,9 @@ cleanup_instr([Const|Left], I, Acc) -> case I of X when is_record(X, fp_unop) orelse is_record(X, fp) -> Fdst = hipe_rtl:mk_new_fpreg(), - Fconv = hipe_tagscheme:unsafe_untag_float(Fdst, Dst), + Fconv = lists:flatten(hipe_tagscheme:unsafe_untag_float(Fdst, Dst)), NewI = hipe_rtl:subst_uses([{Const, Fdst}], I), - cleanup_instr(Left, NewI, Fconv ++ [Load|Acc]); + cleanup_instr(Left, NewI, lists:reverse(Fconv, [Load|Acc])); _ -> NewI = hipe_rtl:subst_uses([{Const, Dst}], I), cleanup_instr(Left, NewI, [Load|Acc]) diff --git a/lib/hipe/rtl/hipe_rtl_lcm.erl b/lib/hipe/rtl/hipe_rtl_lcm.erl index 9dcdd05fb1..af39c9a0a4 100644 --- a/lib/hipe/rtl/hipe_rtl_lcm.erl +++ b/lib/hipe/rtl/hipe_rtl_lcm.erl @@ -182,42 +182,41 @@ delete_exprs(Code, _, _, []) -> Code; delete_exprs(Code, ExprMap, IdMap, [ExprId|Exprs]) -> Expr = expr_id_map_get_expr(IdMap, ExprId), - %% Perform a foldl that goes through the code and deletes all - %% occurences of the expression. - NewCode = - lists:reverse - (lists:foldl(fun(CodeExpr, Acc) -> - case is_expr(CodeExpr) of - true -> - case expr_clear_dst(CodeExpr) =:= Expr of - true -> - pp_debug(" Deleting: ", []), - pp_debug_instr(CodeExpr), - %% Lookup expression entry. - Defines = - case expr_map_lookup(ExprMap, Expr) of - {value, {_, _, Defs}} -> - Defs; - none -> - exit({?MODULE, expr_map_lookup, - "expression missing"}) - end, - MoveCode = - mk_expr_move_instr(hipe_rtl:defines(CodeExpr), - Defines), - pp_debug(" Replacing with: ", []), - pp_debug_instr(MoveCode), - [MoveCode|Acc]; - false -> - [CodeExpr|Acc] - end; - false -> - [CodeExpr|Acc] - end - end, - [], Code)), + %% Lookup expression entry. + {value, {_, _, Defines}} = expr_map_lookup(ExprMap, Expr), + %% Go through the code and deletes all occurences of the expression. + NewCode = delete_expr(Code, Expr, Defines, []), delete_exprs(NewCode, ExprMap, IdMap, Exprs). +delete_expr([], _Expr, _Defines, Acc) -> lists:reverse(Acc); +delete_expr([CodeExpr|Code], Expr, Defines, Acc) -> + case exp_kill_expr(CodeExpr, [Expr]) of + [] -> % Expr was killed; deleting stops here + pp_debug(" Stopping before: ", []), + pp_debug_instr(CodeExpr), + lists:reverse(Acc, [CodeExpr|Code]); + [Expr] -> + NewCodeExpr = + case is_expr(CodeExpr) of + true -> + case expr_clear_dst(CodeExpr) =:= Expr of + true -> + pp_debug(" Deleting: ", []), + pp_debug_instr(CodeExpr), + MoveCode = mk_expr_move_instr(hipe_rtl:defines(CodeExpr), + Defines), + pp_debug(" Replacing with: ", []), + pp_debug_instr(MoveCode), + MoveCode; + false -> + CodeExpr + end; + false -> + CodeExpr + end, + delete_expr(Code, Expr, Defines, [NewCodeExpr|Acc]) + end. + %%============================================================================= %% Goes through the given list of expressions and inserts them at %% appropriate places in the code. @@ -226,13 +225,12 @@ insert_exprs(CFG, _, _, _, _, BetweenMap, []) -> insert_exprs(CFG, Pred, Succ, ExprMap, IdMap, BetweenMap, [ExprId|Exprs]) -> Expr = expr_id_map_get_expr(IdMap, ExprId), Instr = expr_map_get_instr(ExprMap, Expr), - case hipe_rtl_cfg:succ(CFG, Pred) of - [_] -> + case try_insert_expr_last(CFG, Pred, Instr) of + {ok, NewCFG} -> pp_debug(" Inserted last: ", []), pp_debug_instr(Instr), - NewCFG = insert_expr_last(CFG, Pred, Instr), insert_exprs(NewCFG, Pred, Succ, ExprMap, IdMap, BetweenMap, Exprs); - _ -> + not_safe -> case hipe_rtl_cfg:pred(CFG, Succ) of [_] -> pp_debug(" Inserted first: ", []), @@ -252,25 +250,31 @@ insert_exprs(CFG, Pred, Succ, ExprMap, IdMap, BetweenMap, [ExprId|Exprs]) -> %% Recursively goes through the code in a block and returns a new block %% with the new code inserted second to last (assuming the last expression %% is a branch operation). -insert_expr_last(CFG0, Label, Instr) -> - Code0 = hipe_bb:code(hipe_rtl_cfg:bb(CFG0, Label)), - %% FIXME: Use hipe_bb:butlast() instead? - Code1 = insert_expr_last_work(Label, Instr, Code0), - hipe_rtl_cfg:bb_add(CFG0, Label, hipe_bb:mk_bb(Code1)). +try_insert_expr_last(CFG0, Label, Instr) -> + case hipe_rtl_cfg:succ(CFG0, Label) of + [_] -> + Code0 = hipe_bb:code(hipe_rtl_cfg:bb(CFG0, Label)), + case insert_expr_last_work(Instr, Code0) of + not_safe -> not_safe; + Code1 -> + {ok, hipe_rtl_cfg:bb_add(CFG0, Label, hipe_bb:mk_bb(Code1))} + end; + _ -> not_safe + end. %%============================================================================= %% Recursively goes through the code in a block and returns a new block %% with the new code inserted second to last (assuming the last expression %% is a branch operation). -insert_expr_last_work(_, Instr, []) -> - %% This case should not happen since this means that block was completely - %% empty when the function was called. For compatibility we insert it last. - [Instr]; -insert_expr_last_work(_, Instr, [Code1]) -> +insert_expr_last_work(_Instr, [#call{}]) -> + %% Call instructions clobber all expressions; we musn't insert the expression + %% before it + not_safe; +insert_expr_last_work(Instr, [Code1]) -> %% We insert the code next to last. [Instr, Code1]; -insert_expr_last_work(Label, Instr, [Code|Codes]) -> - [Code|insert_expr_last_work(Label, Instr, Codes)]. +insert_expr_last_work(Instr, [Code|Codes]) -> + [Code|insert_expr_last_work(Instr, Codes)]. %%============================================================================= %% Inserts expression first in the block for the given label. @@ -305,7 +309,8 @@ insert_expr_between(CFG0, BetweenMap, Pred, Succ, Instr) -> {value, Label} -> pp_debug(" Using existing new bb for edge (~w,~w) with label ~w~n", [Pred, Succ, Label]), - {insert_expr_last(CFG0, Label, Instr), BetweenMap} + {ok, NewCfg} = try_insert_expr_last(CFG0, Label, Instr), + {NewCfg, BetweenMap} end. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% diff --git a/lib/hipe/rtl/hipe_rtl_primops.erl b/lib/hipe/rtl/hipe_rtl_primops.erl index 850a75f71b..ce5433379e 100644 --- a/lib/hipe/rtl/hipe_rtl_primops.erl +++ b/lib/hipe/rtl/hipe_rtl_primops.erl @@ -291,6 +291,10 @@ gen_primop({Op,Dst,Args,Cont,Fail}, IsGuard, ConstTab) -> gen_select_msg(Dst, Cont); clear_timeout -> gen_clear_timeout(Dst, GotoCont); + recv_mark -> + gen_recv_mark(Dst, GotoCont); + recv_set -> + gen_recv_set(Dst, Cont); set_timeout -> %% BIF call: am_set_timeout -> nbif_set_timeout -> hipe_set_timeout [hipe_rtl:mk_call(Dst, set_timeout, Args, Cont, Fail, not_remote)]; @@ -390,6 +394,10 @@ gen_primop({Op,Dst,Args,Cont,Fail}, IsGuard, ConstTab) -> end; debug_native_called -> [hipe_rtl:mk_call(Dst, Op, Args, Cont, Fail, not_remote)]; + build_stacktrace -> + [hipe_rtl:mk_call(Dst, Op, Args, Cont, Fail, not_remote)]; + raw_raise -> + [hipe_rtl:mk_call(Dst, Op, Args, Cont, Fail, not_remote)]; %% Only names listed above are accepted! MFA:s are not primops! _ -> @@ -1064,6 +1072,27 @@ gen_tuple_header(Ptr, Arity) -> %%% %%% Receives +%%% recv_mark is: +%%% p->msg.saved_last = p->msg.last; +gen_recv_mark([], GotoCont) -> + TmpLast = hipe_rtl:mk_new_reg(), + [load_p_field(TmpLast, ?P_MSG_LAST), + store_p_field(TmpLast, ?P_MSG_SAVED_LAST), + GotoCont]. + +%%% recv_set is: +%%% if (p->msg.saved_last) +%%% p->msg.save = p->msg.saved_last; +gen_recv_set([], Cont) -> + TmpSave = hipe_rtl:mk_new_reg(), + TrueLbl = hipe_rtl:mk_new_label(), + [load_p_field(TmpSave, ?P_MSG_SAVED_LAST), + hipe_rtl:mk_branch(TmpSave, ne, hipe_rtl:mk_imm(0), + hipe_rtl:label_name(TrueLbl), Cont), + TrueLbl, + store_p_field(TmpSave, ?P_MSG_SAVE), + hipe_rtl:mk_goto(Cont)]. + gen_check_get_msg(Dsts, GotoCont, Fail) -> gen_check_get_msg_outofline(Dsts, GotoCont, Fail). diff --git a/lib/hipe/rtl/hipe_rtl_varmap.erl b/lib/hipe/rtl/hipe_rtl_varmap.erl index 375a8f85c0..f34c66ab85 100644 --- a/lib/hipe/rtl/hipe_rtl_varmap.erl +++ b/lib/hipe/rtl/hipe_rtl_varmap.erl @@ -105,7 +105,7 @@ icode_var2rtl_var(Var, Map) -> {reg, IsGcSafe} -> NewVar = case IsGcSafe of - %% true -> hipe_rtl:mk_new_reg_gcsafe(); + true -> hipe_rtl:mk_new_reg_gcsafe(); false -> hipe_rtl:mk_new_reg() end, {NewVar, insert(Var, NewVar, Map)} diff --git a/lib/hipe/rtl/hipe_rtl_verify_gcsafe.erl b/lib/hipe/rtl/hipe_rtl_verify_gcsafe.erl new file mode 100644 index 0000000000..01d7e89ccd --- /dev/null +++ b/lib/hipe/rtl/hipe_rtl_verify_gcsafe.erl @@ -0,0 +1,89 @@ +%% -*- mode: erlang; 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. +%% +-module(hipe_rtl_verify_gcsafe). + +-export([check/1]). + +-include("../flow/cfg.hrl"). %% needed for the specs +-include("hipe_rtl.hrl"). + +check(CFG) -> + Liveness = hipe_rtl_liveness:analyze(CFG), + put({?MODULE, 'fun'}, CFG#cfg.info#cfg_info.'fun'), + lists:foreach( + fun(Lb) -> + put({?MODULE, label}, Lb), + Liveout = hipe_rtl_liveness:liveout(Liveness, Lb), + BB = hipe_rtl_cfg:bb(CFG, Lb), + check_instrs(lists:reverse(hipe_bb:code(BB)), Liveout) + end, hipe_rtl_cfg:labels(CFG)), + erase({?MODULE, 'fun'}), + erase({?MODULE, label}), + erase({?MODULE, instr}), + ok. + +check_instrs([], _Livein) -> ok; +check_instrs([I|Is], LiveOut) -> + Def = ordsets:from_list(hipe_rtl:defines(I)), + Use = ordsets:from_list(hipe_rtl:uses(I)), + LiveOver = ordsets:subtract(LiveOut, Def), + LiveIn = ordsets:union(LiveOver, Use), + case (hipe_rtl:is_call(I) + andalso not safe_primop(hipe_rtl:call_fun(I))) + orelse is_record(I, gctest) + of + false -> ok; + true -> + put({?MODULE, instr}, I), + lists:foreach(fun verify_live/1, LiveOver) + end, + check_instrs(Is, LiveIn). + +verify_live(T) -> + case hipe_rtl:is_reg(T) of + false -> ok; + true -> + case hipe_rtl:reg_is_gcsafe(T) of + true -> ok; + false -> + error({gcunsafe_live_over_call, + get({?MODULE, 'fun'}), + {label, get({?MODULE, label})}, + get({?MODULE, instr}), + T}) + end + end. + +%% Primops that can't gc +%% Note: This information is essentially duplicated from hipe_bif_list.m4 +safe_primop(is_divisible) -> true; +safe_primop(is_unicode) -> true; +safe_primop(cmp_2) -> true; +safe_primop(eq_2) -> true; +safe_primop(bs_allocate) -> true; +safe_primop(bs_reallocate) -> true; +safe_primop(bs_utf8_size) -> true; +safe_primop(bs_get_utf8) -> true; +safe_primop(bs_put_utf8) -> true; +safe_primop(bs_utf16_size) -> true; +safe_primop(bs_get_utf16) -> true; +safe_primop(bs_validate_unicode_retract) -> true; +safe_primop(bs_put_small_float) -> true; +safe_primop(bs_put_bits) -> true; +safe_primop(emasculate_binary) -> true; +safe_primop(atomic_inc) -> true; +%% Not noproc but manually verified +safe_primop(bs_put_big_integer) -> true; +safe_primop(_) -> false. diff --git a/lib/hipe/rtl/hipe_tagscheme.erl b/lib/hipe/rtl/hipe_tagscheme.erl index 68cbe75e85..737f0ec5e3 100644 --- a/lib/hipe/rtl/hipe_tagscheme.erl +++ b/lib/hipe/rtl/hipe_tagscheme.erl @@ -53,7 +53,8 @@ -export([test_subbinary/3, test_heap_binary/3]). -export([create_heap_binary/3, create_refc_binary/3, create_refc_binary/4]). -export([create_matchstate/6, convert_matchstate/1, compare_matchstate/4]). --export([get_field_from_term/3, get_field_from_pointer/3, +-export([get_field_addr_from_term/3, + get_field_from_term/3, get_field_from_pointer/3, set_field_from_term/3, set_field_from_pointer/3, extract_matchbuffer/2, extract_binary_bytes/2]). @@ -76,6 +77,10 @@ -define(TAG_PRIMARY_BOXED, 16#2). -define(TAG_PRIMARY_IMMED1, 16#3). +%% Only when ?ERTS_USE_LITERAL_TAG =:= 1 +-define(TAG_PTR_MASK__, 16#7). +-define(TAG_LITERAL_PTR, 16#4). + -define(TAG_IMMED1_SIZE, 4). -define(TAG_IMMED1_MASK, 16#F). -define(TAG_IMMED1_PID, ((16#0 bsl ?TAG_PRIMARY_SIZE) bor ?TAG_PRIMARY_IMMED1)). @@ -157,6 +162,38 @@ tag_cons(Res, X) -> %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +ptr_val(Res, X) -> + hipe_rtl:mk_alu(Res, X, 'and', hipe_rtl:mk_imm(bnot ?TAG_PTR_MASK__)). + +%% Returns {Base, Offset, Untag}. To be used like, for example: +%% {Base, Offset, Untag} = untag_ptr(X, ?TAG_PRIMARY_BOXED), +%% ... +%% [Untag, hipe_rtl:mk_load(Dst, Base, hipe_rtl:mk_imm(Offset))]. +%% +%% NB: Base might either be X or a new temp. It must thus not be modified. +untag_ptr(X, Tag) -> + case ?ERTS_USE_LITERAL_TAG of + 0 -> + {X, -Tag, []}; + 1 -> + Base = hipe_rtl:mk_new_reg(), + Untag = ptr_val(Base, X), + {Base, 0, Untag} + end. + +untag_ptr_nooffset(Dst, X, Tag) -> + %% We could just use ptr_val in all cases, but subtraction can use LEA on x86 + %% and can be inlined into effective address computations on several + %% architectures. + case ?ERTS_USE_LITERAL_TAG of + 0 -> + hipe_rtl:mk_alu(Dst, X, 'sub', hipe_rtl:mk_imm(Tag)); + 1 -> + ptr_val(Dst, X) + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + %%% Operations to test if an object has a known type T. test_nil(X, TrueLab, FalseLab, Pred) -> @@ -171,7 +208,8 @@ test_is_boxed(X, TrueLab, FalseLab, Pred) -> hipe_rtl:mk_branch(X, 'and', Mask, 'eq', TrueLab, FalseLab, Pred). get_header(Res, X) -> - hipe_rtl:mk_load(Res, X, hipe_rtl:mk_imm(-(?TAG_PRIMARY_BOXED))). + {Base, Offset, Untag} = untag_ptr(X, ?TAG_PRIMARY_BOXED), + [Untag, hipe_rtl:mk_load(Res, Base, hipe_rtl:mk_imm(Offset))]. mask_and_compare(X, Mask, Value, TrueLab, FalseLab, Pred) -> Tmp = hipe_rtl:mk_new_reg_gcsafe(), @@ -617,21 +655,25 @@ test_either_immed(Arg1, Arg2, TrueLab, FalseLab) -> %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% unsafe_car(Dst, Arg) -> - hipe_rtl:mk_load(Dst, Arg, hipe_rtl:mk_imm(-(?TAG_PRIMARY_LIST))). + {Base, Offset, Untag} = untag_ptr(Arg, ?TAG_PRIMARY_LIST), + [Untag, hipe_rtl:mk_load(Dst, Base, hipe_rtl:mk_imm(Offset))]. unsafe_cdr(Dst, Arg) -> + {Base, Offset, Untag} = untag_ptr(Arg, ?TAG_PRIMARY_LIST), WordSize = hipe_rtl_arch:word_size(), - hipe_rtl:mk_load(Dst, Arg, hipe_rtl:mk_imm(-(?TAG_PRIMARY_LIST)+WordSize)). + [Untag, hipe_rtl:mk_load(Dst, Base, hipe_rtl:mk_imm(Offset+WordSize))]. unsafe_constant_element(Dst, Index, Tuple) -> % Index is an immediate WordSize = hipe_rtl_arch:word_size(), - Offset = -(?TAG_PRIMARY_BOXED) + WordSize * hipe_rtl:imm_value(Index), - hipe_rtl:mk_load(Dst, Tuple, hipe_rtl:mk_imm(Offset)). + {Base, Offset0, Untag} = untag_ptr(Tuple, ?TAG_PRIMARY_BOXED), + Offset = Offset0 + WordSize * hipe_rtl:imm_value(Index), + [Untag, hipe_rtl:mk_load(Dst, Base, hipe_rtl:mk_imm(Offset))]. unsafe_update_element(Tuple, Index, Value) -> % Index is an immediate WordSize = hipe_rtl_arch:word_size(), - Offset = -(?TAG_PRIMARY_BOXED) + WordSize * hipe_rtl:imm_value(Index), - hipe_rtl:mk_store(Tuple, hipe_rtl:mk_imm(Offset), Value). + {Base, Offset0, Untag} = untag_ptr(Tuple, ?TAG_PRIMARY_BOXED), + Offset = Offset0 + WordSize * hipe_rtl:imm_value(Index), + [Untag, hipe_rtl:mk_store(Base, hipe_rtl:mk_imm(Offset), Value)]. %%% wrong semantics %% unsafe_variable_element(Dst, Index, Tuple) -> % Index is an unknown fixnum @@ -644,10 +686,12 @@ unsafe_update_element(Tuple, Index, Value) -> % Index is an immediate %% Tmp1 = hipe_rtl:mk_new_reg_gcsafe(), %% Tmp2 = hipe_rtl:mk_new_reg_gcsafe(), %% Shift = ?TAG_IMMED1_SIZE - 2, -%% OffAdj = (?TAG_IMMED1_SMALL bsr Shift) + ?TAG_PRIMARY_BOXED, +%% {Base, Off0, Untag} = untag_ptr(Tuple, ?TAG_PRIMARY_BOXED), +%% OffAdj = (?TAG_IMMED1_SMALL bsr Shift) - Off0, %% [hipe_rtl:mk_alu(Tmp1, Index, 'srl', hipe_rtl:mk_imm(Shift)), %% hipe_rtl:mk_alu(Tmp2, Tmp1, 'sub', hipe_rtl:mk_imm(OffAdj)), -%% hipe_rtl:mk_load(Dst, Tuple, Tmp2)]. +%% Untag, +%% hipe_rtl:mk_load(Base, Tuple, Tmp2)]. element(Dst, Index, Tuple, FailLabName, {tuple, A}, IndexInfo) -> FixnumOkLab = hipe_rtl:mk_new_label(), @@ -660,7 +704,7 @@ element(Dst, Index, Tuple, FailLabName, {tuple, A}, IndexInfo) -> 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)), + untag_ptr_nooffset(Ptr, Tuple, ?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)]; @@ -769,7 +813,7 @@ gen_element_tail(Dst, Tuple, Arity, UIndex, FailLabName, IndexOkLab) -> 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)), + untag_ptr_nooffset(Ptr, Tuple, ?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)]. @@ -777,11 +821,13 @@ gen_element_tail(Dst, Tuple, Arity, UIndex, FailLabName, IndexOkLab) -> %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% unsafe_closure_element(Dst, Index, Closure) -> % Index is an immediate - Offset = -(?TAG_PRIMARY_BOXED) %% Untag + %% XXX: Can there even be closure literals? + {Base, Offset0, Untag} = untag_ptr(Closure, ?TAG_PRIMARY_BOXED), + Offset = Offset0 %% Untag + ?EFT_ENV %% Field offset %% Index from 1 to N hence -1) + (hipe_rtl_arch:word_size() * (hipe_rtl:imm_value(Index)-1)), - hipe_rtl:mk_load(Dst, Closure, hipe_rtl:mk_imm(Offset)). + [Untag, hipe_rtl:mk_load(Dst, Base, hipe_rtl:mk_imm(Offset))]. mk_fun_header() -> hipe_rtl:mk_imm(?HEADER_FUN). @@ -790,7 +836,7 @@ tag_fun(Res, X) -> tag_boxed(Res, X). %% untag_fun(Res, X) -> -%% hipe_rtl:mk_alu(Res, X, 'sub', hipe_rtl:mk_imm(?TAG_PRIMARY_BOXED)). +%% untag_ptr_nooffset(Res, X, ?TAG_PRIMARY_BOXED). if_fun_get_arity_and_address(ArityReg, AddressReg, FunP, BadFunLab, Pred) -> %% EmuAddressPtrReg = hipe_rtl:mk_new_reg(), @@ -801,15 +847,15 @@ if_fun_get_arity_and_address(ArityReg, AddressReg, FunP, BadFunLab, Pred) -> TrueLab0 = hipe_rtl:mk_new_label(), %% TrueLab1 = hipe_rtl:mk_new_label(), IsFunCode = test_closure(FunP, hipe_rtl:label_name(TrueLab0), BadFunLab, Pred), + {Base, Offset, Untag} = untag_ptr(FunP, ?TAG_PRIMARY_BOXED), GetArityCode = [TrueLab0, %% Funp->arity contains the arity - hipe_rtl:mk_load(ArityReg, FunP, - hipe_rtl:mk_imm(-(?TAG_PRIMARY_BOXED)+ - ?EFT_ARITY)), - hipe_rtl:mk_load(FEPtrReg, FunP, - hipe_rtl:mk_imm(-(?TAG_PRIMARY_BOXED)+ - ?EFT_FE)), + Untag, + hipe_rtl:mk_load(ArityReg, Base, + hipe_rtl:mk_imm(Offset+?EFT_ARITY)), + hipe_rtl:mk_load(FEPtrReg, Base, + hipe_rtl:mk_imm(Offset+?EFT_FE)), hipe_rtl:mk_load(AddressReg, FEPtrReg, hipe_rtl:mk_imm(?EFE_NATIVE_ADDRESS))], IsFunCode ++ GetArityCode. @@ -927,20 +973,24 @@ test_subbinary(Binary, TrueLblName, FalseLblName) -> unsafe_load_float(DstLo, DstHi, Src) -> WordSize = hipe_rtl_arch:word_size(), - Offset1 = -(?TAG_PRIMARY_BOXED) + WordSize, + {Base, Offset0, Untag} = untag_ptr(Src, ?TAG_PRIMARY_BOXED), + Offset1 = Offset0 + WordSize, Offset2 = Offset1 + 4, %% This should really be 4 and not WordSize case hipe_rtl_arch:endianess() of little -> - [hipe_rtl:mk_load(DstLo, Src, hipe_rtl:mk_imm(Offset1), int32, unsigned), - hipe_rtl:mk_load(DstHi, Src, hipe_rtl:mk_imm(Offset2), int32, unsigned)]; + [Untag, + hipe_rtl:mk_load(DstLo, Base, hipe_rtl:mk_imm(Offset1), int32, unsigned), + hipe_rtl:mk_load(DstHi, Base, hipe_rtl:mk_imm(Offset2), int32, unsigned)]; big -> - [hipe_rtl:mk_load(DstHi, Src, hipe_rtl:mk_imm(Offset1), int32, unsigned), - hipe_rtl:mk_load(DstLo, Src, hipe_rtl:mk_imm(Offset2), int32, unsigned)] + [Untag, + hipe_rtl:mk_load(DstHi, Base, hipe_rtl:mk_imm(Offset1), int32, unsigned), + hipe_rtl:mk_load(DstLo, Base, hipe_rtl:mk_imm(Offset2), int32, unsigned)] end. unsafe_untag_float(Dst, Src) -> - Offset = -(?TAG_PRIMARY_BOXED) + hipe_rtl_arch:word_size(), - [hipe_rtl:mk_fload(Dst, Src, hipe_rtl:mk_imm(Offset))]. + {Base, Offset0, Untag} = untag_ptr(Src, ?TAG_PRIMARY_BOXED), + Offset = Offset0 + hipe_rtl_arch:word_size(), + [Untag, hipe_rtl:mk_fload(Dst, Base, hipe_rtl:mk_imm(Offset))]. unsafe_tag_float(Dst, Src) -> {GetHPInsn, HP, PutHPInsn} = hipe_rtl_arch:heap_pointer(), @@ -999,8 +1049,9 @@ get_one_word_pos_bignum(USize, Size, Fail) -> unsafe_get_one_word_pos_bignum(USize, Size) -> WordSize = hipe_rtl_arch:word_size(), - Imm = hipe_rtl:mk_imm(1*WordSize-?TAG_PRIMARY_BOXED), - [hipe_rtl:mk_load(USize, Size, Imm)]. + {Base, Offset, Untag} = untag_ptr(Size, ?TAG_PRIMARY_BOXED), + Imm = hipe_rtl:mk_imm(1*WordSize+Offset), + [Untag, hipe_rtl:mk_load(USize, Base, Imm)]. -spec bignum_sizeneed(non_neg_integer()) -> non_neg_integer(). @@ -1040,7 +1091,7 @@ create_matchstate(Max, BinSize, Base, Offset, Orig, Ms) -> SizeInWords = ((ByteSize div WordSize) - 1), Header = hipe_rtl:mk_imm(mk_header(SizeInWords, ?TAG_HEADER_BIN_MATCHSTATE)), [GetHPInsn, - hipe_rtl:mk_alu(Ms, HP, add, hipe_rtl:mk_imm(?TAG_PRIMARY_BOXED)), + tag_boxed(Ms, HP), set_field_from_term({matchstate,thing_word}, Ms, Header), set_field_from_term({matchstate,{matchbuffer,orig}}, Ms, Orig), set_field_from_term({matchstate,{matchbuffer,base}}, Ms, Base), @@ -1078,7 +1129,10 @@ convert_matchstate(Ms) -> size_from_header(SizeInWords, Header), hipe_rtl:mk_alu(Hole, SizeInWords, sub, hipe_rtl:mk_imm(?SUB_BIN_WORDSIZE)), mk_var_header(BigIntHeader, Hole, ?TAG_HEADER_POS_BIG), - hipe_rtl:mk_store(Ms, hipe_rtl:mk_imm(?SUB_BIN_WORDSIZE*WordSize-?TAG_PRIMARY_BOXED), + %% Matchstates can't be literals; so untagging with ?TAG_PRIMARY_BOXED is + %% fine here + hipe_rtl:mk_store(Ms, hipe_rtl:mk_imm(?SUB_BIN_WORDSIZE*WordSize + -?TAG_PRIMARY_BOXED), BigIntHeader)]. compare_matchstate(Max, Ms, LargeEnough, TooSmall) -> @@ -1087,8 +1141,10 @@ compare_matchstate(Max, Ms, LargeEnough, TooSmall) -> SizeInWords = ((ByteSize div WordSize) - 1), Header = hipe_rtl:mk_imm(mk_header(SizeInWords, ?TAG_HEADER_BIN_MATCHSTATE)), RealHeader = hipe_rtl:mk_new_reg_gcsafe(), - [hipe_rtl:mk_load(RealHeader, Ms, hipe_rtl:mk_imm(-?TAG_PRIMARY_BOXED)), - hipe_rtl:mk_branch(RealHeader, ge, Header, LargeEnough, TooSmall)]. + %% Matchstates can't be literals; so untagging with ?TAG_PRIMARY_BOXED is fine + %% here + [hipe_rtl:mk_load(RealHeader, Ms, hipe_rtl:mk_imm(-?TAG_PRIMARY_BOXED)), + hipe_rtl:mk_branch(RealHeader, ge, Header, LargeEnough, TooSmall)]. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% @@ -1207,15 +1263,22 @@ get_field_size1({matchbuffer, base}) -> get_field_size1({matchbuffer, binsize}) -> ?MB_SIZE_SIZE. +get_field_addr_from_term(Struct, Term, Dst) -> + {Base, Offset0, Untag} = untag_ptr(Term, ?TAG_PRIMARY_BOXED), + Offset = hipe_rtl:mk_imm(get_field_offset(Struct) + Offset0), + [Untag, hipe_rtl:mk_alu(Dst, Base, add, Offset)]. + get_field_from_term(Struct, Term, Dst) -> - Offset = hipe_rtl:mk_imm(get_field_offset(Struct) - ?TAG_PRIMARY_BOXED), + {Base, Offset0, Untag} = untag_ptr(Term, ?TAG_PRIMARY_BOXED), + Offset = hipe_rtl:mk_imm(get_field_offset(Struct) + Offset0), Size = get_field_size(Struct), - hipe_rtl:mk_load(Dst, Term, Offset, Size, unsigned). + [Untag, hipe_rtl:mk_load(Dst, Base, Offset, Size, unsigned)]. set_field_from_term(Struct, Term, Value) -> - Offset = hipe_rtl:mk_imm(get_field_offset(Struct) - ?TAG_PRIMARY_BOXED), + {Base, Offset0, Untag} = untag_ptr(Term, ?TAG_PRIMARY_BOXED), + Offset = hipe_rtl:mk_imm(get_field_offset(Struct) + Offset0), Size = get_field_size(Struct), - hipe_rtl:mk_store(Term, Offset, Value, Size). + [Untag, hipe_rtl:mk_store(Base, Offset, Value, Size)]. get_field_from_pointer(Struct, Term, Dst) -> Offset = hipe_rtl:mk_imm(get_field_offset(Struct)), @@ -1229,6 +1292,8 @@ set_field_from_pointer(Struct, Term, Value) -> extract_matchbuffer(Mb, Ms) -> What = {matchstate, matchbuffer}, + %% Matchstates can't be literals; so untagging with ?TAG_PRIMARY_BOXED is fine + %% here Offset = hipe_rtl:mk_imm(get_field_offset(What) - ?TAG_PRIMARY_BOXED), hipe_rtl:mk_alu(Mb, Ms, add, Offset). diff --git a/lib/hipe/ssa/hipe_ssa.inc b/lib/hipe/ssa/hipe_ssa.inc index c7c1a8e1d7..29e8b92266 100644 --- a/lib/hipe/ssa/hipe_ssa.inc +++ b/lib/hipe/ssa/hipe_ssa.inc @@ -463,20 +463,20 @@ updateStatementDefs([], Statement, Current, Acc) -> %%---------------------------------------------------------------------- updateIndices(Current, Variable) -> - case ?CODE:is_var(Variable) of - true -> - NewVar = ?CODE:mk_new_var(), - {NewVar,gb_trees:enter(Variable, NewVar, Current)}; - false -> - case is_fp_temp(Variable) of - true -> - NewFVar = mk_new_fp_temp(), - {NewFVar,gb_trees:enter(Variable, NewFVar, Current)}; - false -> - NewReg = ?CODE:mk_new_reg(), - {NewReg,gb_trees:enter(Variable, NewReg, Current)} - end - end. + New = + case ?CODE:is_var(Variable) of + true -> ?CODE:mk_new_var(); + false -> + case is_fp_temp(Variable) of + true -> mk_new_fp_temp(); + false -> + case ?CODE:reg_is_gcsafe(Variable) of + true -> ?CODE:mk_new_reg_gcsafe(); + false -> ?CODE:mk_new_reg() + end + end + end, + {New, gb_trees:enter(Variable, New, Current)}. %%---------------------------------------------------------------------- %% Procedure : updateSuccPhi/4 diff --git a/lib/hipe/test/basic_SUITE_data/basic_exceptions.erl b/lib/hipe/test/basic_SUITE_data/basic_exceptions.erl index 229a0516dc..ba9c03d4ba 100644 --- a/lib/hipe/test/basic_SUITE_data/basic_exceptions.erl +++ b/lib/hipe/test/basic_SUITE_data/basic_exceptions.erl @@ -6,12 +6,13 @@ %%%------------------------------------------------------------------- -module(basic_exceptions). --export([test/0, test_catches/0]). +-export([test/0]). %% functions used as arguments to spawn/3 -export([bad_guy/2]). test() -> + ok = test_catches(), ok = test_catch_exit(42), ok = test_catch_throw(42), ok = test_catch_element(), @@ -22,6 +23,8 @@ test() -> ok = test_pending_errors(), ok = test_bad_fun_call(), ok = test_guard_bif(), + ok = test_eclectic(), + ok = test_raise(), ok. %%-------------------------------------------------------------------- @@ -463,3 +466,213 @@ guard_bif('node/0', X, Y) when node() == Y -> {'node/0', X, Y}; guard_bif('node/1', X, Y) when node(X) == Y -> {'node/1', X, Y}. + +%%-------------------------------------------------------------------- +%% Taken from trycatch_SUITE.erl (compiler test suite). +%% +%% Cases that are commented out contain exception information that was +%% added to Erlang/OTP in commit e8d45ae14c6c3bdfcbbc7964228b004ef4f11ea6 +%% (May 2017) only in the BEAM emulator. Thus, part of this test fails +%% when compiled in native code. +%% The remaining cases are uncommented so that they are properly tested +%% in native code too. +%%-------------------------------------------------------------------- + +test_eclectic() -> + V = {make_ref(),3.1415926535,[[]|{}]}, + {{value,{value,V},V},V} = + eclectic_1({foo,{value,{value,V}}}, undefined, {value,V}), + {{'EXIT',{V,[{?MODULE,foo,1,_}|_]}},V} = + eclectic_1({catch_foo,{error,V}}, undefined, {value,V}), + {{error,{exit,V},{'EXIT',V}},V} = + eclectic_1({foo,{error,{exit,V}}}, error, {value,V}), + %% {{value,{value,V},V}, + %% {'EXIT',{badarith,[{erlang,'+',[0,a],_},{?MODULE,my_add,2,_}|_]}}} = + %% eclectic_1({foo,{value,{value,V}}}, undefined, {'add',{0,a}}), + {{'EXIT',V},V} = + eclectic_1({catch_foo,{exit,V}}, undefined, {throw,V}), + %% {{error,{'div',{1,0}},{'EXIT',{badarith,[{erlang,'div',[1,0],_},{?MODULE,my_div,2,_}|_]}}}, + %% {'EXIT',V}} = + %% eclectic_1({foo,{error,{'div',{1,0}}}}, error, {exit,V}), + {{{error,V},{'EXIT',{V,[{?MODULE,foo,1,_}|_]}}}, + {'EXIT',V}} = + eclectic_1({catch_foo,{throw,{error,V}}}, undefined, {exit,V}), + %% + {{value,{value,{value,V},V}},V} = + eclectic_2({value,{value,V}}, undefined, {value,V}), + {{value,{throw,{value,V},V}},V} = + eclectic_2({throw,{value,V}}, throw, {value,V}), + {{caught,{'EXIT',V}},undefined} = + eclectic_2({value,{value,V}}, undefined, {exit,V}), + {{caught,{'EXIT',{V,[{?MODULE,foo,1,_}|_]}}},undefined} = + eclectic_2({error,{value,V}}, throw, {error,V}), + %% The following fails in native code + %% %% {{caught,{'EXIT',{badarg,[{erlang,abs,[V],_}|_]}}},V} = + %% %% eclectic_2({value,{'abs',V}}, undefined, {value,V}), + %% {{caught,{'EXIT',{badarith,[{erlang,'+',[0,a],_},{?MODULE,my_add,2,_}|_]}}},V} = + %% eclectic_2({exit,{'add',{0,a}}}, exit, {value,V}), + {{caught,{'EXIT',V}},undefined} = + eclectic_2({value,{error,V}}, undefined, {exit,V}), + {{caught,{'EXIT',{V,[{?MODULE,foo,1,_}|_]}}},undefined} = + eclectic_2({throw,{'div',{1,0}}}, throw, {error,V}), + ok. + +eclectic_1(X, C, Y) -> + erase(eclectic), + Done = make_ref(), + Try = + try case X of + {catch_foo,V} -> catch {Done,foo(V)}; + {foo,V} -> {Done,foo(V)} + end of + {Done,D} -> {value,D,catch foo(D)}; + {'EXIT',_}=Exit -> Exit; + D -> {D,catch foo(D)} + catch + C:D -> {C,D,catch foo(D)} + after + put(eclectic, catch foo(Y)) + end, + {Try,erase(eclectic)}. + +eclectic_2(X, C, Y) -> + Done = make_ref(), + erase(eclectic), + Catch = + case + catch + {Done, + try foo(X) of + V -> {value,V,foo(V)} + catch + C:D -> {C,D,foo(D)} + after + put(eclectic, foo(Y)) + end} of + {Done,Z} -> {value,Z}; + Z -> {caught,Z} + end, + {Catch,erase(eclectic)}. + +foo({value,Value}) -> Value; +foo({'div',{A,B}}) -> + my_div(A, B); +foo({'add',{A,B}}) -> + my_add(A, B); +foo({'abs',X}) -> + my_abs(X); +foo({error,Error}) -> + erlang:error(Error); +foo({throw,Throw}) -> + erlang:throw(Throw); +foo({exit,Exit}) -> + erlang:exit(Exit); +foo({raise,{Class,Reason}}) -> + erlang:raise(Class, Reason); +foo(Term) when not is_atom(Term) -> Term. +%%foo(Atom) when is_atom(Atom) -> % must not be defined! + +my_div(A, B) -> + A div B. + +my_add(A, B) -> + A + B. + +my_abs(X) -> + abs(X). + +test_raise() -> + test_raise(fun() -> exit({exit,tuple}) end), + test_raise(fun() -> abs(id(x)) end), + test_raise(fun() -> throw({was,thrown}) end), + + badarg = bad_raise(fun() -> abs(id(x)) end), + + ok. + +bad_raise(Expr) -> + try + Expr() + catch + _:E:Stk -> + erlang:raise(bad_class, E, Stk) + end. + +test_raise(Expr) -> + test_raise_1(Expr), + test_raise_2(Expr), + test_raise_3(Expr). + +test_raise_1(Expr) -> + erase(exception), + try + do_test_raise_1(Expr) + catch + C:E:Stk -> + {C,E,Stk} = erase(exception) + end. + +do_test_raise_1(Expr) -> + try + Expr() + catch + C:E:Stk -> + %% Here the stacktrace must be built. + put(exception, {C,E,Stk}), + erlang:raise(C, E, Stk) + end. + +test_raise_2(Expr) -> + erase(exception), + try + do_test_raise_2(Expr) + catch + C:E:Stk -> + {C,E} = erase(exception), + try + Expr() + catch + _:_:S -> + [StkTop|_] = S, + [StkTop|_] = Stk + end + end. + +do_test_raise_2(Expr) -> + try + Expr() + catch + C:E:Stk -> + %% Here it is possible to replace erlang:raise/3 with + %% the raw_raise/3 instruction since the stacktrace is + %% not actually used. + put(exception, {C,E}), + erlang:raise(C, E, Stk) + end. + +test_raise_3(Expr) -> + try + do_test_raise_3(Expr) + catch + exit:{exception,C,E}:Stk -> + try + Expr() + catch + C:E:S -> + [StkTop|_] = S, + [StkTop|_] = Stk + end + end. + +do_test_raise_3(Expr) -> + try + Expr() + catch + C:E:Stk -> + %% Here it is possible to replace erlang:raise/3 with + %% the raw_raise/3 instruction since the stacktrace is + %% not actually used. + erlang:raise(exit, {exception,C,E}, Stk) + end. + +id(I) -> I. diff --git a/lib/hipe/test/basic_SUITE_data/basic_receive.erl b/lib/hipe/test/basic_SUITE_data/basic_receive.erl index 5f865d7b7a..20e3f350e8 100644 --- a/lib/hipe/test/basic_SUITE_data/basic_receive.erl +++ b/lib/hipe/test/basic_SUITE_data/basic_receive.erl @@ -12,6 +12,7 @@ test() -> ok = test_wait_timeout(), ok = test_double_timeout(), ok = test_reschedule(), + ok = test_recv_mark(), ok. %%-------------------------------------------------------------------- @@ -54,3 +55,91 @@ doit(First) -> erts_debug:set_internal_state(hipe_test_reschedule_suspend, 1). %%-------------------------------------------------------------------- +%% Check that we cannot cause a recv_mark,recv_set pair to misbehave and +%% deadlock the process. + +test_recv_mark() -> + ok = test_recv_mark(fun disturber_nop/0), + ok = test_recv_mark(fun disturber_receive/0), + ok = test_recv_mark(fun disturber_other/0), + ok = test_recv_mark(fun disturber_recurse/0), + ok = test_recv_mark_after(self(), fun disturber_after_recurse/0, false), + ok = test_recv_mark(fun disturber_other_recurse/0), + ok = test_recv_mark(fun disturber_other_after/0), + ok = test_recv_mark_nested(). + +test_recv_mark(Disturber) -> + Ref = make_ref(), + self() ! Ref, + Disturber(), + receive Ref -> ok + after 0 -> error(failure) + end. + +disturber_nop() -> ok. + +disturber_receive() -> + self() ! message, + receive message -> ok end. + +disturber_other() -> + Ref = make_ref(), + self() ! Ref, + receive Ref -> ok end. + +disturber_recurse() -> + aborted = (catch test_recv_mark(fun() -> throw(aborted) end)), + ok. + +test_recv_mark_after(Recipient, Disturber, IsInner) -> + Ref = make_ref(), + Recipient ! Ref, + Disturber(), + receive + Ref -> ok + after 0 -> + case IsInner of + true -> expected; + false -> error(failure) + end + end. + +disturber_after_recurse() -> + NoOp = fun() -> ok end, + BlackHole = spawn(NoOp), + expected = test_recv_mark_after(BlackHole, NoOp, true), + ok. + +disturber_other_recurse() -> + aborted = (catch disturber_other_recurse(fun() -> throw(aborted) end)), + ok. + +disturber_other_recurse(InnerD) -> + Ref = make_ref(), + self() ! Ref, + InnerD(), + receive Ref -> ok + after 0 -> error(failure) + end. + +disturber_other_after() -> + BlackHole = spawn(fun() -> ok end), + Ref = make_ref(), + BlackHole ! Ref, + receive Ref -> error(imposible) + after 0 -> ok + end. + +test_recv_mark_nested() -> + Ref1 = make_ref(), + self() ! Ref1, + begin + Ref2 = make_ref(), + self() ! Ref2, + receive Ref2 -> ok end + end, + receive Ref1 -> ok + after 0 -> error(failure) + end. + +%%-------------------------------------------------------------------- diff --git a/lib/hipe/test/hipe_testsuite_driver.erl b/lib/hipe/test/hipe_testsuite_driver.erl index 88576775ca..8813af5dfc 100644 --- a/lib/hipe/test/hipe_testsuite_driver.erl +++ b/lib/hipe/test/hipe_testsuite_driver.erl @@ -29,13 +29,9 @@ get_suites(SuitesWithSuiteSuffix) -> [S || {yes, S} <- Prefixes]. suffix(String, Suffix) -> - case string:rstr(String, Suffix) of - 0 -> no; - Index -> - case string:substr(String, Index) =:= Suffix of - true -> {yes, string:sub_string(String, 1, Index-1)}; - false -> no - end + case string:split(String, Suffix, trailing) of + [Prefix,[]] -> {yes, Prefix}; + _ -> no end. -spec file_type(file:filename()) -> {ok, file_type()} | {error, ext_posix()}. @@ -165,7 +161,8 @@ run(TestCase, Dir, _OutDir) -> %% end, DataFiles), %% try ok = TestCase:test(), - HiPEOpts = try TestCase:hipe_options() catch error:undef -> [] end, + HiPEOpts0 = try TestCase:hipe_options() catch error:undef -> [] end, + HiPEOpts = HiPEOpts0 ++ hipe_options(), {ok, TestCase} = hipe:c(TestCase, HiPEOpts), ok = TestCase:test(), {ok, TestCase} = hipe:c(TestCase, [o1|HiPEOpts]), @@ -183,3 +180,6 @@ run(TestCase, Dir, _OutDir) -> %% lists:foreach(fun (DF) -> ok end, % = file:delete(DF) end, %% [filename:join(OutDir, D) || D <- DataFiles]) %% end. + +hipe_options() -> + [verify_gcsafe]. diff --git a/lib/hipe/test/opt_verify_SUITE.erl b/lib/hipe/test/opt_verify_SUITE.erl index a323c10503..24f43af275 100644 --- a/lib/hipe/test/opt_verify_SUITE.erl +++ b/lib/hipe/test/opt_verify_SUITE.erl @@ -59,7 +59,7 @@ call_elim_test_file(Config, FileName, Option) -> substring_count(Icode, Substring) -> substring_count(Icode, Substring, 0). substring_count(Icode, Substring, N) -> - case string:str(Icode, Substring) of - 0 -> N; - I -> substring_count(lists:nthtail(I, Icode), Substring, N+1) + case string:find(Icode, Substring) of + nomatch -> N; + Prefix -> substring_count(string:prefix(Prefix, Substring), Substring, N+1) end. diff --git a/lib/hipe/x86/hipe_rtl_to_x86.erl b/lib/hipe/x86/hipe_rtl_to_x86.erl index 31e4f6e4ac..22947da148 100644 --- a/lib/hipe/x86/hipe_rtl_to_x86.erl +++ b/lib/hipe/x86/hipe_rtl_to_x86.erl @@ -646,7 +646,7 @@ conv_imm(Opnd, Map) -> is_imm64(Value) when is_integer(Value) -> (Value < -(1 bsl (32 - 1))) or (Value > (1 bsl (32 - 1)) - 1); is_imm64({_,atom}) -> false; % Atoms are 32 bits. -is_imm64({_,c_const}) -> false; % c_consts are 32 bits. +is_imm64({_,c_const}) -> true; % c_consts are 64 bits. is_imm64({_,_}) -> true . % Other relocs are 64 bits. -else. conv_imm(Opnd, Map) -> @@ -777,6 +777,18 @@ conv_fconv(Dst, Src) -> %%% Finalise the conversion of a 2-address FP operation. +-ifdef(HIPE_AMD64). +conv_fp_unary(Dst, Src, 'fchs') -> + Tmp = new_untagged_temp(), + case same_opnd(Dst, Src) of + true -> + []; + _ -> + [hipe_x86:mk_fmove(Src, Dst)] + end ++ + mk_load_address(c_const, hipe_x86:mk_imm({sse2_fnegate_mask, c_const}), Tmp) ++ + [hipe_x86:mk_fp_binop('xorpd', hipe_x86:mk_mem(Tmp, hipe_x86:mk_imm(0), double), Dst)]. +-else. conv_fp_unary(Dst, Src, FpUnOp) -> case same_opnd(Dst, Src) of true -> @@ -785,6 +797,7 @@ conv_fp_unary(Dst, Src, FpUnOp) -> [hipe_x86:mk_fmove(Src, Dst), hipe_x86:mk_fp_unop(FpUnOp, Dst)] end. +-endif. conv_fp_unop(RtlFpUnOp) -> case RtlFpUnOp of @@ -854,13 +867,8 @@ mk_jmp_switch(Index, JTabLab, Labels) -> %%% Finalise the translation of a load_address instruction. -ifdef(HIPE_AMD64). -mk_load_address(Type, Src, Dst) -> - case Type of - c_const -> % 32 bits - [hipe_x86:mk_move(Src, Dst)]; - _ -> - [hipe_x86:mk_move64(Src, Dst)] - end. +mk_load_address(_Type, Src, Dst) -> + [hipe_x86:mk_move64(Src, Dst)]. -else. mk_load_address(_Type, Src, Dst) -> [hipe_x86:mk_move(Src, Dst)]. diff --git a/lib/hipe/x86/hipe_x86_assemble.erl b/lib/hipe/x86/hipe_x86_assemble.erl index 50919bdf4e..9d2586a14d 100644 --- a/lib/hipe/x86/hipe_x86_assemble.erl +++ b/lib/hipe/x86/hipe_x86_assemble.erl @@ -735,6 +735,7 @@ resolve_sse2_op(Op) -> fdiv -> divsd; fmul -> mulsd; fsub -> subsd; + xorpd -> xorpd; _ -> exit({?MODULE, unknown_sse2_operator, Op}) end. diff --git a/lib/ic/c_src/oe_ei_encode_atom.c b/lib/ic/c_src/oe_ei_encode_atom.c index 758586d1d4..99a9fe26f0 100644 --- a/lib/ic/c_src/oe_ei_encode_atom.c +++ b/lib/ic/c_src/oe_ei_encode_atom.c @@ -20,28 +20,37 @@ */ #include <ic.h> +#include <string.h> + + +#define DIRTY_ATOM_ENC_MAX(LATIN1_CHARS) ((LATIN1_CHARS)*2 + 3) + int oe_ei_encode_atom(CORBA_Environment *ev, const char *p) { int size = ev->_iout; + size_t len = strlen(p); + + if (DIRTY_ATOM_ENC_MAX(len) >= ev->_outbufsz) { + + ei_encode_atom_len(0,&size,p,len); + + if (size >= ev->_outbufsz) { + char *buf = ev->_outbuf; + int bufsz = ev->_outbufsz + ev->_memchunk; + + while (size >= bufsz) + bufsz += ev->_memchunk; + + if ((buf = realloc(buf, bufsz)) == NULL) { + CORBA_exc_set(ev, CORBA_SYSTEM_EXCEPTION, NO_MEMORY, "End of heap memory while encoding"); + return -1; /* OUT OF MEMORY */ + } - ei_encode_atom(0,&size,p); - - if (size >= ev->_outbufsz) { - char *buf = ev->_outbuf; - int bufsz = ev->_outbufsz + ev->_memchunk; - - while (size >= bufsz) - bufsz += ev->_memchunk; - - if ((buf = realloc(buf, bufsz)) == NULL) { - CORBA_exc_set(ev, CORBA_SYSTEM_EXCEPTION, NO_MEMORY, "End of heap memory while encoding"); - return -1; /* OUT OF MEMORY */ - } - - ev->_outbuf = buf; - ev->_outbufsz = bufsz; + ev->_outbuf = buf; + ev->_outbufsz = bufsz; + } } - return ei_encode_atom(ev->_outbuf,&ev->_iout,p); + return ei_encode_atom_len(ev->_outbuf,&ev->_iout,p,len); } diff --git a/lib/ic/doc/src/notes.xml b/lib/ic/doc/src/notes.xml index fc68ec386c..38cc77ca98 100644 --- a/lib/ic/doc/src/notes.xml +++ b/lib/ic/doc/src/notes.xml @@ -31,7 +31,22 @@ <file>notes.xml</file> </header> - <section><title>IC 4.4.3</title> + <section><title>IC 4.4.4</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> + Optimize encoding/decoding for pure 7-bit ascii atoms.</p> + <p> + Own Id: OTP-15023 Aux Id: ERIERL-150 </p> + </item> + </list> + </section> + +</section> + +<section><title>IC 4.4.3</title> <section><title>Fixed Bugs and Malfunctions</title> <list> diff --git a/lib/ic/vsn.mk b/lib/ic/vsn.mk index b9f1ef7f20..d35d1dce1e 100644 --- a/lib/ic/vsn.mk +++ b/lib/ic/vsn.mk @@ -1 +1 @@ -IC_VSN = 4.4.3 +IC_VSN = 4.4.4 diff --git a/lib/inets/doc/src/Makefile b/lib/inets/doc/src/Makefile index cbfa5c9e30..90c1258d4a 100644 --- a/lib/inets/doc/src/Makefile +++ b/lib/inets/doc/src/Makefile @@ -43,13 +43,10 @@ XML_CHAPTER_FILES = \ inets_services.xml \ http_client.xml \ http_server.xml \ - ftp_client.xml \ notes.xml XML_REF3_FILES = \ inets.xml \ - ftp.xml \ - tftp.xml \ http_uri.xml\ httpc.xml\ httpd.xml \ diff --git a/lib/inets/doc/src/httpc.xml b/lib/inets/doc/src/httpc.xml index befcd83827..521ad6a015 100644 --- a/lib/inets/doc/src/httpc.xml +++ b/lib/inets/doc/src/httpc.xml @@ -288,8 +288,7 @@ {autoredirect, boolean()} | {proxy_auth, {userstring(), passwordstring()}} | {version, http_version()} | - {relaxed, boolean()} | - {url_encode, boolean()}</v> + {relaxed, boolean()}</v> <v>timeout() = integer() >= 0 | infinity</v> <v>Options = options()</v> <v>options() = [option()]</v> @@ -313,8 +312,7 @@ <v>Body = string() | binary()</v> <v>Profile = profile() | pid()</v> <d>When started <c>stand_alone</c> only the pid can be used.</d> - <v>Reason = {connect_failed, term()} | - {send_failed, term()} | term()</v> + <v>Reason = term()</v> </type> <desc> @@ -380,13 +378,6 @@ from the HTTP-standard are enabled.</p> <p>Default is <c>false</c>.</p> </item> - - <tag><c><![CDATA[url_encode]]></c></tag> - <item> - <p>Applies Percent-encoding, also known as URL encoding on the - URL.</p> - <p>Default is <c>false</c>.</p> - </item> </taglist> <p>Option (<c>option()</c>) details:</p> @@ -450,17 +441,22 @@ <tag><c><![CDATA[socket_opts]]></c></tag> <item> - <p>Socket options to be used for this and subsequent - requests.</p> + <p>Socket options to be used for this request.</p> <p>Overrides any value set by function <seealso marker="#set_options-1">set_options</seealso>.</p> <p>The validity of the options is <em>not</em> checked by the HTTP client they are assumed to be correct and passed on to ssl application and inet driver, which may reject - them if they are not correct. Note that the current - implementation assumes the requests to the same host, port - combination will use the same socket options. + them if they are not correct. </p> + <note> + <p> + Persistent connections are not supported when setting the + <c>socket_opts</c> option. When <c>socket_opts</c> is not + set the current implementation assumes the requests to the + same host, port combination will use the same socket options. + </p> + </note> <p>By default the socket options set by function <seealso marker="#set_options-1">set_options/[1,2]</seealso> @@ -633,8 +629,11 @@ to complete. The HTTP/1.1 specification suggests a limit of two persistent connections per server, which is the default value of option <c>max_sessions</c>.</p> + <p> + The current implementation assumes the requests to the same host, port + combination will use the same socket options. + </p> </note> - <marker id="get_options"></marker> </desc> </func> diff --git a/lib/inets/doc/src/inets.xml b/lib/inets/doc/src/inets.xml index 137381cbe9..eb4e51584f 100644 --- a/lib/inets/doc/src/inets.xml +++ b/lib/inets/doc/src/inets.xml @@ -188,10 +188,9 @@ <section> <title>SEE ALSO</title> - <p><seealso marker="ftp">ftp(3)</seealso>, - <seealso marker="httpc">httpc(3)</seealso>, - <seealso marker="httpd">httpd(3)</seealso>, - <seealso marker="tftp">tftp(3)</seealso></p> + <p><seealso marker="httpc">httpc(3)</seealso>, + <seealso marker="httpd">httpd(3)</seealso> + </p> </section> </erlref> diff --git a/lib/inets/doc/src/introduction.xml b/lib/inets/doc/src/introduction.xml index 1af2ef5dae..faf911f188 100644 --- a/lib/inets/doc/src/introduction.xml +++ b/lib/inets/doc/src/introduction.xml @@ -4,7 +4,7 @@ <chapter> <header> <copyright> - <year>1997</year><year>2016</year> + <year>1997</year><year>2018</year> <holder>Ericsson AB. All Rights Reserved.</holder> </copyright> <legalnotice> @@ -22,12 +22,12 @@ </legalnotice> <title>Introduction</title> - <prepared>Ingela Anderton Andin</prepared> + <prepared>Péter Dimitrov</prepared> <responsible></responsible> <docno></docno> <approved></approved> <checked></checked> - <date>2004-09-28</date> + <date>2018-02-28</date> <rev>A</rev> <file>introduction.xml</file> </header> @@ -37,8 +37,6 @@ <p><c>Inets</c> is a container for Internet clients and servers including the following:</p> <list type="bulleted"> - <item>An FTP client</item> - <item>A TFTP client and server</item> <item>An <term id="HTTP"></term> client and server</item> </list> <p>The HTTP client and server are HTTP 1.1 compliant as @@ -50,7 +48,7 @@ <title>Prerequisites</title> <p>It is assumed that the reader is familiar with the Erlang programming language, concepts of OTP, and has a basic - understanding of the FTP, TFTP, and HTTP protocols.</p> + understanding of and HTTP protocol.</p> </section> </chapter> diff --git a/lib/inets/doc/src/notes.xml b/lib/inets/doc/src/notes.xml index 0417e07de8..10dd26322c 100644 --- a/lib/inets/doc/src/notes.xml +++ b/lib/inets/doc/src/notes.xml @@ -33,7 +33,22 @@ <file>notes.xml</file> </header> - <section><title>Inets 6.5</title> + <section><title>Inets 6.5.1</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> + Fix broken options handling in httpc (ERL-441).</p> + <p> + Own Id: OTP-15007</p> + </item> + </list> + </section> + +</section> + +<section><title>Inets 6.5</title> <section><title>Fixed Bugs and Malfunctions</title> <list> @@ -1766,7 +1781,7 @@ <list> <item> <p>[ftpc] Add a config option to specify a - <seealso marker="ftp#dtimeout">data connect timeout</seealso>. + <seealso marker="ftp:ftp#dtimeout">data connect timeout</seealso>. That is how long the ftp client will wait for the server to connect to the data socket. If this timeout occurs, an error will be returned to the caller and the ftp client process will be @@ -2649,10 +2664,10 @@ <item> <p>It is now also possible to start a standalone FTP client process using the re-introduced - <seealso marker="ftp#open">ftp:open</seealso> + <seealso marker="ftp:ftp#open">ftp:open</seealso> function. </p> <p>This is an alternative to starting the client using the - <seealso marker="ftp#service_start">inets service framework</seealso>. </p> + <seealso marker="ftp:ftp#service_start">inets service framework</seealso>. </p> <p>The old <c>ftp:open/1</c>, undocumented, function, caused the client to be hooken into the inets service supervision framework. This is <em>no</em> longer the @@ -2665,10 +2680,10 @@ flag), and only used IPv4 if this did not work. This has now been <em>changed</em>. </p> <p>A new option, - <seealso marker="ftp#ipfamily">ipfamily</seealso>, + <seealso marker="ftp:ftp#ipfamily">ipfamily</seealso>, has been introduced, with the default value <c>inet</c> (IPv4). </p> - <p>See <seealso marker="ftp#open">ftp:open</seealso> + <p>See <seealso marker="ftp:ftp#open">ftp:open</seealso> for more info.</p> <p>*** POTENTIAL INCOMPATIBILITY ***</p> </item> @@ -2702,9 +2717,9 @@ <item> <p>[ftpc] - The - <seealso marker="ftp#ls2">ls/2</seealso> function (LIST command) + <seealso marker="ftp:ftp#ls2">ls/2</seealso> function (LIST command) and the - <seealso marker="ftp#nlist2">nlist/2</seealso> function + <seealso marker="ftp:ftp#nlist2">nlist/2</seealso> function (NLST command) with wildcards did not work properly. </p> diff --git a/lib/inets/doc/src/part.xml b/lib/inets/doc/src/part.xml index f777481b5c..b9c8ed674c 100644 --- a/lib/inets/doc/src/part.xml +++ b/lib/inets/doc/src/part.xml @@ -4,7 +4,7 @@ <part xmlns:xi="http://www.w3.org/2001/XInclude"> <header> <copyright> - <year>2004</year><year>2016</year> + <year>2004</year><year>2018</year> <holder>Ericsson AB. All Rights Reserved.</holder> </copyright> <legalnotice> @@ -23,9 +23,9 @@ </legalnotice> <title>Inets User's Guide</title> - <prepared>Ingela Anderton Andin</prepared> + <prepared>Péter Dimitrov</prepared> <docno></docno> - <date>2002-09-17</date> + <date>2018-02-28</date> <rev>A</rev> <file>part.sgml</file> </header> @@ -33,8 +33,6 @@ <p>The <c>Inets</c> application provides a set of Internet-related services as follows:</p> <list type="bulleted"> - <item>An FTP client</item> - <item>A TFTP client and server</item> <item>An <term id="HTTP"></term> client and server</item> </list> <p>The HTTP client and server are HTTP 1.1 compliant as @@ -43,7 +41,6 @@ </description> <xi:include href="introduction.xml"/> <xi:include href="inets_services.xml"/> - <xi:include href="ftp_client.xml"/> <xi:include href="http_client.xml"/> <xi:include href="http_server.xml"/> </part> diff --git a/lib/inets/doc/src/ref_man.xml b/lib/inets/doc/src/ref_man.xml index 27021ea09a..58c1a651f9 100644 --- a/lib/inets/doc/src/ref_man.xml +++ b/lib/inets/doc/src/ref_man.xml @@ -4,7 +4,7 @@ <application xmlns:xi="http://www.w3.org/2001/XInclude"> <header> <copyright> - <year>1997</year><year>2015</year> + <year>1997</year><year>2018</year> <holder>Ericsson AB. All Rights Reserved.</holder> </copyright> <legalnotice> @@ -23,20 +23,16 @@ </legalnotice> <title>Inets Reference Manual</title> - <prepared>Joakim Grebenö</prepared> + <prepared>Péter Dimitrov</prepared> <docno></docno> - <date>1997-07-16</date> + <date>2018-02-28</date> <rev>2.1</rev> <file>ref_man.xml</file> </header> <description> - <p><c>Inets</c> is a container for Internet clients and - servers. An FTP client, an HTTP client and server, and - a TFTP client and server are incorporated in <c>Inets</c>.</p> + <p><c>Inets</c> is a container for an HTTP client and server.</p> </description> <xi:include href="inets.xml"/> - <xi:include href="ftp.xml"/> - <xi:include href="tftp.xml"/> <xi:include href="httpc.xml"/> <xi:include href="httpd.xml"/> <xi:include href="httpd_custom_api.xml"/> diff --git a/lib/inets/src/ftp/ftp_sup.erl b/lib/inets/src/ftp/ftp_sup.erl deleted file mode 100644 index 21dcfb6ab2..0000000000 --- a/lib/inets/src/ftp/ftp_sup.erl +++ /dev/null @@ -1,60 +0,0 @@ -%% -%% %CopyrightBegin% -%% -%% Copyright Ericsson AB 2004-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: The top supervisor for the ftp hangs under inets_sup. -%%---------------------------------------------------------------------- --module(ftp_sup). - --behaviour(supervisor). - -%% API --export([start_link/0]). --export([start_child/1]). - -%% Supervisor callback --export([init/1]). - -%%%========================================================================= -%%% API -%%%========================================================================= -start_link() -> - supervisor:start_link({local, ?MODULE}, ?MODULE, []). - -start_child(Args) -> - supervisor:start_child(?MODULE, Args). - -%%%========================================================================= -%%% Supervisor callback -%%%========================================================================= -init(_) -> - RestartStrategy = simple_one_for_one, - MaxR = 0, - MaxT = 3600, - - Name = undefined, % As simple_one_for_one is used. - StartFunc = {ftp, start_link, []}, - Restart = temporary, % E.g. should not be restarted - Shutdown = 4000, - Modules = [ftp], - Type = worker, - - ChildSpec = {Name, StartFunc, Restart, Shutdown, Type, Modules}, - {ok, {{RestartStrategy, MaxR, MaxT}, [ChildSpec]}}. diff --git a/lib/inets/src/http_client/httpc.erl b/lib/inets/src/http_client/httpc.erl index dd493d7554..a73503a5ce 100644 --- a/lib/inets/src/http_client/httpc.erl +++ b/lib/inets/src/http_client/httpc.erl @@ -176,10 +176,10 @@ request(Method, (Method =:= delete) orelse (Method =:= trace) andalso (is_atom(Profile) orelse is_pid(Profile)) -> - case uri_parse(Url, Options) of - {error, Reason} -> + case uri_string:parse(uri_string:normalize(Url)) of + {error, Reason, _} -> {error, Reason}; - {ok, ParsedUrl} -> + ParsedUrl -> case header_parse(Headers) of {error, Reason} -> {error, Reason}; @@ -190,10 +190,10 @@ request(Method, end. do_request(Method, {Url, Headers, ContentType, Body}, HTTPOptions, Options, Profile) -> - case uri_parse(Url, Options) of - {error, Reason} -> + case uri_string:parse(uri_string:normalize(Url)) of + {error, Reason, _} -> {error, Reason}; - {ok, ParsedUrl} -> + ParsedUrl -> handle_request(Method, Url, ParsedUrl, Headers, ContentType, Body, HTTPOptions, Options, Profile) @@ -313,23 +313,28 @@ store_cookies(SetCookieHeaders, Url) -> store_cookies(SetCookieHeaders, Url, Profile) when is_atom(Profile) orelse is_pid(Profile) -> - try - begin + case uri_string:parse(uri_string:normalize(Url)) of + {error, Bad, _} -> + {error, {parse_failed, Bad}}; + URI -> + Scheme = scheme_to_atom(maps:get(scheme, URI, '')), + Host = maps:get(host, URI, ""), + Port = maps:get(port, URI, default_port(Scheme)), + Path = uri_string:recompose(#{path => maps:get(path, URI, "")}), %% Since the Address part is not actually used %% by the manager when storing cookies, we dont %% care about ipv6-host-with-brackets. - {ok, {_, _, Host, Port, Path, _}} = uri_parse(Url), Address = {Host, Port}, ProfileName = profile_name(Profile), Cookies = httpc_cookie:cookies(SetCookieHeaders, Path, Host), httpc_manager:store_cookies(Cookies, Address, ProfileName), ok - end - catch - error:{badmatch, Bad} -> - {error, {parse_failed, Bad}} end. +default_port(http) -> + 80; +default_port(https) -> + 443. %%-------------------------------------------------------------------------- %% cookie_header(Url) -> Header | {error, Reason} @@ -496,7 +501,7 @@ service_info(Pid) -> %%% Internal functions %%%======================================================================== handle_request(Method, Url, - {Scheme, UserInfo, Host, Port, Path, Query}, + URI, Headers0, ContentType, Body0, HTTPOptions0, Options0, Profile) -> @@ -521,39 +526,42 @@ handle_request(Method, Url, throw({error, {bad_body, Body0}}) end, - HTTPOptions = http_options(HTTPOptions0), - Options = request_options(Options0), - Sync = proplists:get_value(sync, Options), - Stream = proplists:get_value(stream, Options), - Host2 = http_request:normalize_host(Scheme, Host, Port), - HeadersRecord = header_record(NewHeaders, Host2, HTTPOptions), - Receiver = proplists:get_value(receiver, Options), - SocketOpts = proplists:get_value(socket_opts, Options), + HTTPOptions = http_options(HTTPOptions0), + Options = request_options(Options0), + Sync = proplists:get_value(sync, Options), + Stream = proplists:get_value(stream, Options), + Receiver = proplists:get_value(receiver, Options), + SocketOpts = proplists:get_value(socket_opts, Options), UnixSocket = proplists:get_value(unix_socket, Options), - BracketedHost = proplists:get_value(ipv6_host_with_brackets, - Options), - MaybeEscPath = maybe_encode_uri(HTTPOptions, Path), - MaybeEscQuery = maybe_encode_uri(HTTPOptions, Query), - AbsUri = maybe_encode_uri(HTTPOptions, Url), + BracketedHost = proplists:get_value(ipv6_host_with_brackets, + Options), + + Scheme = scheme_to_atom(maps:get(scheme, URI, '')), + Userinfo = maps:get(userinfo, URI, ""), + Host = http_util:maybe_add_brackets(maps:get(host, URI, ""), BracketedHost), + Port = maps:get(port, URI, default_port(Scheme)), + Host2 = http_request:normalize_host(Scheme, Host, Port), + Path = uri_string:recompose(#{path => maps:get(path, URI, "")}), + Query = add_question_mark(maps:get(query, URI, "")), + HeadersRecord = header_record(NewHeaders, Host2, HTTPOptions), Request = #request{from = Receiver, - scheme = Scheme, - address = {host_address(Host, BracketedHost), Port}, - path = MaybeEscPath, - pquery = MaybeEscQuery, + scheme = Scheme, + address = {Host, Port}, + path = Path, + pquery = Query, method = Method, headers = HeadersRecord, content = {ContentType, Body}, settings = HTTPOptions, - abs_uri = AbsUri, - userinfo = UserInfo, + abs_uri = Url, + userinfo = Userinfo, stream = Stream, headers_as_is = headers_as_is(Headers0, Options), socket_opts = SocketOpts, started = Started, unix_socket = UnixSocket, ipv6_host_with_brackets = BracketedHost}, - case httpc_manager:request(Request, profile_name(Profile)) of {ok, RequestId} -> handle_answer(RequestId, Sync, Options); @@ -568,14 +576,31 @@ handle_request(Method, Url, Error end. + +add_question_mark(<<>>) -> + <<>>; +add_question_mark([]) -> + []; +add_question_mark(Comp) when is_binary(Comp) -> + <<$?, Comp/binary>>; +add_question_mark(Comp) when is_list(Comp) -> + [$?|Comp]. + + +scheme_to_atom("http") -> + http; +scheme_to_atom("https") -> + https; +scheme_to_atom('') -> + ''; +scheme_to_atom(Scheme) -> + throw({error, {bad_scheme, Scheme}}). + + ensure_chunked_encoding(Hdrs) -> Key = "transfer-encoding", lists:keystore(Key, 1, Hdrs, {Key, "chunked"}). -maybe_encode_uri(#http_options{url_encode = true}, URI) -> - http_uri:encode(URI); -maybe_encode_uri(_, URI) -> - URI. mk_chunkify_fun(ProcessBody) -> fun(eof_body) -> @@ -1232,17 +1257,6 @@ validate_headers(RequestHeaders, _, _) -> %% These functions is just simple wrappers to parse specifically HTTP URIs %%-------------------------------------------------------------------------- -scheme_defaults() -> - [{http, 80}, {https, 443}]. - -uri_parse(URI) -> - http_uri:parse(URI, [{scheme_defaults, scheme_defaults()}]). - -uri_parse(URI, Opts) -> - http_uri:parse(URI, [{scheme_defaults, scheme_defaults()} | Opts]). - - -%%-------------------------------------------------------------------------- header_parse([]) -> ok; header_parse([{Field, Value}|T]) when is_list(Field), is_list(Value) -> @@ -1263,10 +1277,6 @@ child_name(Pid, [{Name, Pid} | _]) -> child_name(Pid, [_ | Children]) -> child_name(Pid, Children). -host_address(Host, false) -> - Host; -host_address(Host, true) -> - string:strip(string:strip(Host, right, $]), left, $[). check_body_gen({Fun, _}) when is_function(Fun) -> ok; diff --git a/lib/inets/src/http_client/httpc_handler.erl b/lib/inets/src/http_client/httpc_handler.erl index 26e4f4e699..eeb08ce0ee 100644 --- a/lib/inets/src/http_client/httpc_handler.erl +++ b/lib/inets/src/http_client/httpc_handler.erl @@ -48,19 +48,17 @@ queue_timer :: reference() | 'undefined' }). --type session_failed() :: {'connect_failed',term()} | {'send_failed',term()}. - -record(state, { request :: request() | 'undefined', - session :: session() | session_failed() | 'undefined', + session :: session() | 'undefined', status_line, % {Version, StatusCode, ReasonPharse} headers :: http_response_h() | 'undefined', body :: binary() | 'undefined', mfa, % {Module, Function, Args} pipeline = queue:new() :: queue:queue(), keep_alive = queue:new() :: queue:queue(), - status, % undefined | new | pipeline | keep_alive | close | {ssl_tunnel, Request} + status :: undefined | new | pipeline | keep_alive | close | {ssl_tunnel, request()}, canceled = [], % [RequestId] max_header_size = nolimit :: nolimit | integer(), max_body_size = nolimit :: nolimit | integer(), @@ -255,8 +253,8 @@ handle_call(Request, From, State) -> Result -> Result catch - _:Reason -> - {stop, {shutdown, Reason} , State} + Class:Reason:ST -> + {stop, {shutdown, {{Class, Reason}, ST}}, State} end. @@ -271,8 +269,8 @@ handle_cast(Msg, State) -> Result -> Result catch - _:Reason -> - {stop, {shutdown, Reason} , State} + Class:Reason:ST -> + {stop, {shutdown, {{Class, Reason}, ST}}, State} end. %%-------------------------------------------------------------------- @@ -286,8 +284,8 @@ handle_info(Info, State) -> Result -> Result catch - _:Reason -> - {stop, {shutdown, Reason} , State} + Class:Reason:ST -> + {stop, {shutdown, {{Class, Reason}, ST}}, State} end. %%-------------------------------------------------------------------- @@ -295,23 +293,6 @@ handle_info(Info, State) -> %% Description: Shutdown the httpc_handler %%-------------------------------------------------------------------- -%% Init error there is no socket to be closed. -terminate(normal, - #state{request = Request, - session = {send_failed, _} = Reason} = State) -> - maybe_send_answer(Request, - httpc_response:error(Request, Reason), - State), - ok; - -terminate(normal, - #state{request = Request, - session = {connect_failed, _} = Reason} = State) -> - maybe_send_answer(Request, - httpc_response:error(Request, Reason), - State), - ok; - terminate(normal, #state{session = undefined}) -> ok; @@ -588,11 +569,11 @@ do_handle_info({Proto, _Socket, Data}, activate_once(Session), {noreply, State#state{mfa = NewMFA}} catch - _:Reason -> + Class:Reason:ST -> ClientReason = {could_not_parse_as_http, Data}, ClientErrMsg = httpc_response:error(Request, ClientReason), NewState = answer_request(Request, ClientErrMsg, State), - {stop, {shutdown, Reason}, NewState} + {stop, {shutdown, {{Class, Reason}, ST}}, NewState} end; do_handle_info({Proto, Socket, Data}, @@ -1058,15 +1039,15 @@ handle_response(#state{status = new} = State) -> ?hcrd("handle response - status = new", []), handle_response(try_to_enable_pipeline_or_keep_alive(State)); -handle_response(#state{request = Request, - status = Status, - session = Session, - status_line = StatusLine, - headers = Headers, - body = Body, - options = Options, - profile_name = ProfileName} = State) - when Status =/= new -> +handle_response(#state{status = Status0} = State0) when Status0 =/= new -> + State = handle_server_closing(State0), + #state{request = Request, + session = Session, + status_line = StatusLine, + headers = Headers, + body = Body, + options = Options, + profile_name = ProfileName} = State, handle_cookies(Headers, Request, Options, ProfileName), case httpc_response:result({StatusLine, Headers, Body}, Request) of %% 100-continue @@ -1330,6 +1311,14 @@ try_to_enable_pipeline_or_keep_alive( State#state{status = close} end. +handle_server_closing(State = #state{status = close}) -> State; +handle_server_closing(State = #state{headers = undefined}) -> State; +handle_server_closing(State = #state{headers = Headers}) -> + case httpc_response:is_server_closing(Headers) of + true -> State#state{status = close}; + false -> State + end. + answer_request(#request{id = RequestId, from = From} = Request, Msg, #state{session = Session, timers = Timers, @@ -1711,9 +1700,8 @@ update_session(ProfileName, #session{id = SessionId} = Session, Pos, Value) -> insert_session(Session2, ProfileName); error:badarg -> {stop, normal}; - T:E -> + T:E:Stacktrace -> %% Unexpected this must be an error! - Stacktrace = erlang:get_stacktrace(), error_logger:error_msg("Failed updating session: " "~n ProfileName: ~p" "~n SessionId: ~p" diff --git a/lib/inets/src/http_client/httpc_manager.erl b/lib/inets/src/http_client/httpc_manager.erl index 7b8d7875de..c3404dbb37 100644 --- a/lib/inets/src/http_client/httpc_manager.erl +++ b/lib/inets/src/http_client/httpc_manager.erl @@ -750,8 +750,26 @@ handle_request(#request{settings = start_handler(NewRequest#request{headers = NewHeaders}, State), {reply, {ok, NewRequest#request.id}, State}; -handle_request(Request, State = #state{options = Options}) -> +%% Simple socket options handling (ERL-441). +%% +%% TODO: Refactor httpc to enable sending socket options in requests +%% using persistent connections. This workaround opens a new +%% connection for each request with non-empty socket_opts. +handle_request(Request0 = #request{socket_opts = SocketOpts}, + State0 = #state{options = Options0}) + when is_list(SocketOpts) andalso length(SocketOpts) > 0 -> + Request = handle_cookies(generate_request_id(Request0), State0), + Options = convert_options(SocketOpts, Options0), + State = State0#state{options = Options}, + Headers = + (Request#request.headers)#http_request_h{connection + = "close"}, + %% Reset socket_opts to avoid setopts failure. + start_handler(Request#request{headers = Headers, socket_opts = []}, State), + %% Do not change the state + {reply, {ok, Request#request.id}, State0}; +handle_request(Request, State = #state{options = Options}) -> NewRequest = handle_cookies(generate_request_id(Request), State), SessionType = session_type(Options), case select_session(Request#request.method, @@ -775,6 +793,18 @@ handle_request(Request, State = #state{options = Options}) -> {reply, {ok, NewRequest#request.id}, State}. +%% Convert Request options to State options +convert_options([], Options) -> + Options; +convert_options([{ipfamily, Value}|T], Options) -> + convert_options(T, Options#options{ipfamily = Value}); +convert_options([{ip, Value}|T], Options) -> + convert_options(T, Options#options{ip = Value}); +convert_options([{port, Value}|T], Options) -> + convert_options(T, Options#options{port = Value}); +convert_options([Option|T], Options = #options{socket_opts = SocketOpts}) -> + convert_options(T, Options#options{socket_opts = SocketOpts ++ [Option]}). + start_handler(#request{id = Id, from = From} = Request, #state{profile_name = ProfileName, diff --git a/lib/inets/src/http_client/httpc_request.erl b/lib/inets/src/http_client/httpc_request.erl index 89872a3831..641b6559de 100644 --- a/lib/inets/src/http_client/httpc_request.erl +++ b/lib/inets/src/http_client/httpc_request.erl @@ -190,35 +190,11 @@ is_client_closing(Headers) -> %%%======================================================================== post_data(Method, Headers, {ContentType, Body}, HeadersAsIs) when (Method =:= post) - orelse (Method =:= put) - orelse (Method =:= patch) - orelse (Method =:= delete) -> - - NewBody = case Headers#http_request_h.expect of - "100-continue" -> - ""; - _ -> - Body - end, - - NewHeaders = case HeadersAsIs of - [] -> - Headers#http_request_h{ - 'content-type' = ContentType, - 'content-length' = case body_length(Body) of - undefined -> - % on upload streaming the caller must give a - % value to the Content-Length header - % (or use chunked Transfer-Encoding) - Headers#http_request_h.'content-length'; - Len when is_list(Len) -> - Len - end - }; - _ -> - HeadersAsIs - end, - + orelse (Method =:= put) + orelse (Method =:= patch) + orelse (Method =:= delete) -> + NewBody = update_body(Headers, Body), + NewHeaders = update_headers(Headers, ContentType, Body, HeadersAsIs), {NewHeaders, NewBody}; post_data(_, Headers, _, []) -> @@ -226,14 +202,39 @@ post_data(_, Headers, _, []) -> post_data(_, _, _, HeadersAsIs = [_|_]) -> {HeadersAsIs, ""}. +update_body(Headers, Body) -> + case Headers#http_request_h.expect of + "100-continue" -> + ""; + _ -> + Body + end. + +update_headers(Headers, ContentType, Body, []) -> + case Body of + [] -> + Headers#http_request_h{'content-length' = "0"}; + <<>> -> + Headers#http_request_h{'content-length' = "0"}; + {Fun, _Acc} when is_function(Fun, 1) -> + %% A client MUST NOT generate a 100-continue expectation in a request + %% that does not include a message body. This implies that either the + %% Content-Length or the Transfer-Encoding header MUST be present. + %% DO NOT send content-type when Body is empty. + Headers#http_request_h{'content-type' = ContentType}; + _ -> + Headers#http_request_h{ + 'content-length' = body_length(Body), + 'content-type' = ContentType} + end; +update_headers(_, _, _, HeadersAsIs) -> + HeadersAsIs. + body_length(Body) when is_binary(Body) -> integer_to_list(size(Body)); body_length(Body) when is_list(Body) -> - integer_to_list(length(Body)); - -body_length({DataFun, _Acc}) when is_function(DataFun, 1) -> - undefined. + integer_to_list(length(Body)). method(Method) -> http_util:to_upper(atom_to_list(Method)). diff --git a/lib/inets/src/http_client/httpc_response.erl b/lib/inets/src/http_client/httpc_response.erl index 91638f5d2e..92dc9b0e02 100644 --- a/lib/inets/src/http_client/httpc_response.erl +++ b/lib/inets/src/http_client/httpc_response.erl @@ -83,7 +83,6 @@ whole_body(Body, Length) -> %% result(Response, Request) -> %% Response - {StatusLine, Headers, Body} %% Request - #request{} -%% Session - #tcp_session{} %% %% Description: Checks the status code ... %%------------------------------------------------------------------------- @@ -190,7 +189,7 @@ parse_status_code(<<?CR, ?LF, Rest/binary>>, StatusCodeStr, MaxHeaderSize, Result, true) -> parse_headers(Rest, [], [], MaxHeaderSize, [" ", list_to_integer(lists:reverse( - string:strip(StatusCodeStr))) + string:trim(StatusCodeStr))) | Result], true); parse_status_code(<<?SP, Rest/binary>>, StatusCodeStr, @@ -377,58 +376,173 @@ status_server_error_50x(Response, Request) -> {stop, {Request#request.id, Msg}}. -redirect(Response = {StatusLine, Headers, Body}, Request) -> +redirect(Response = {_, Headers, _}, Request) -> {_, Data} = format_response(Response), case Headers#http_response_h.location of - undefined -> - transparent(Response, Request); - RedirUrl -> - UrlParseOpts = [{ipv6_host_with_brackets, - Request#request.ipv6_host_with_brackets}], - case uri_parse(RedirUrl, UrlParseOpts) of - {error, no_scheme} when - (Request#request.settings)#http_options.relaxed -> - NewLocation = fix_relative_uri(Request, RedirUrl), - redirect({StatusLine, Headers#http_response_h{ - location = NewLocation}, - Body}, Request); - {error, Reason} -> - {ok, error(Request, Reason), Data}; - %% Automatic redirection - {ok, {Scheme, _, Host, Port, Path, Query}} -> - HostPort = http_request:normalize_host(Scheme, Host, Port), - NewHeaders = - (Request#request.headers)#http_request_h{host = HostPort}, - NewRequest = - Request#request{redircount = - Request#request.redircount+1, - scheme = Scheme, - headers = NewHeaders, - address = {Host,Port}, - path = Path, - pquery = Query, - abs_uri = - atom_to_list(Scheme) ++ "://" ++ - Host ++ ":" ++ - integer_to_list(Port) ++ - Path ++ Query}, - {redirect, NewRequest, Data} - end + undefined -> + transparent(Response, Request); + RedirUrl -> + Brackets = Request#request.ipv6_host_with_brackets, + case uri_string:parse(RedirUrl) of + {error, Reason, _} -> + {ok, error(Request, Reason), Data}; + %% Automatic redirection + URI -> + {Host, Port0} = Request#request.address, + Port = maybe_to_integer(Port0), + Path = Request#request.path, + Scheme = atom_to_list(Request#request.scheme), + Query = Request#request.pquery, + URIMap = resolve_uri(Scheme, Host, Port, Path, Query, URI), + TScheme = list_to_atom(maps:get(scheme, URIMap)), + THost = http_util:maybe_add_brackets(maps:get(host, URIMap), Brackets), + TPort = maps:get(port, URIMap), + TPath = maps:get(path, URIMap), + TQuery = maps:get(query, URIMap, ""), + NewURI = uri_string:normalize( + uri_string:recompose(URIMap)), + HostPort = http_request:normalize_host(TScheme, THost, TPort), + NewHeaders = + (Request#request.headers)#http_request_h{host = HostPort}, + NewRequest = + Request#request{redircount = + Request#request.redircount+1, + scheme = TScheme, + headers = NewHeaders, + address = {THost,TPort}, + path = TPath, + pquery = TQuery, + abs_uri = NewURI}, + {redirect, NewRequest, Data} + end + end. + + +%% RFC3986 - 5.2.2. Transform References +resolve_uri(Scheme, Host, Port, Path, Query, URI) -> + resolve_uri(Scheme, Host, Port, Path, Query, URI, #{}). +%% +resolve_uri(Scheme, Host, Port, Path, Query, URI, Map0) -> + case maps:is_key(scheme, URI) of + true -> + Port = get_port(URI), + maybe_add_query( + Map0#{scheme => maps:get(scheme, URI), + host => maps:get(host, URI), + port => Port, + path => maps:get(path, URI)}, + URI); + false -> + Map = Map0#{scheme => Scheme}, + resolve_authority(Host, Port, Path, Query, URI, Map) + end. + + +get_port(URI) -> + Scheme = maps:get(scheme, URI), + case maps:get(port, URI, undefined) of + undefined -> + get_default_port(Scheme); + Port -> + Port + end. + + +get_default_port("http") -> + 80; +get_default_port("https") -> + 443. + + +resolve_authority(Host, Port, Path, Query, RelURI, Map) -> + case maps:is_key(host, RelURI) of + true -> + Port = get_port(RelURI), + maybe_add_query( + Map#{host => maps:get(host, RelURI), + port => Port, + path => maps:get(path, RelURI)}, + RelURI); + false -> + Map1 = Map#{host => Host, + port => Port}, + resolve_path(Path, Query, RelURI, Map1) + end. + + +maybe_add_query(Map, RelURI) -> + case maps:is_key(query, RelURI) of + true -> + Map#{query => maps:get(query, RelURI)}; + false -> + Map + end. + + +resolve_path(Path, Query, RelURI, Map) -> + case maps:is_key(path, RelURI) of + true -> + Path1 = calculate_path(Path, maps:get(path, RelURI)), + maybe_add_query( + Map#{path => Path1}, + RelURI); + false -> + Map1 = Map#{path => Path}, + resolve_query(Query, RelURI, Map1) + end. + + +calculate_path(BaseP, RelP) -> + case starts_with_slash(RelP) of + true -> + RelP; + false -> + merge_paths(BaseP, RelP) + end. + + +starts_with_slash([$/|_]) -> + true; +starts_with_slash(<<$/,_/binary>>) -> + true; +starts_with_slash(_) -> + false. + + +%% RFC3986 - 5.2.3. Merge Paths +merge_paths("", RelP) -> + [$/|RelP]; +merge_paths(BaseP, RelP) when is_list(BaseP) -> + do_merge_paths(lists:reverse(BaseP), RelP); +merge_paths(BaseP, RelP) when is_binary(BaseP) -> + B = binary_to_list(BaseP), + R = binary_to_list(RelP), + Res = merge_paths(B, R), + list_to_binary(Res). + + +do_merge_paths([$/|_] = L, RelP) -> + lists:reverse(L) ++ RelP; +do_merge_paths([_|T], RelP) -> + do_merge_paths(T, RelP). + + +resolve_query(Query, RelURI, Map) -> + case maps:is_key(query, RelURI) of + true -> + Map#{query => maps:get(query, RelURI)}; + false -> + Map#{query => Query} end. -maybe_to_list(Port) when is_integer(Port) -> - integer_to_list(Port); -maybe_to_list(Port) when is_list(Port) -> + +maybe_to_integer(Port) when is_list(Port) -> + {Port1, _} = string:to_integer(Port), + Port1; +maybe_to_integer(Port) when is_integer(Port) -> Port. -%%% Guessing that we received a relative URI, fix it to become an absoluteURI -fix_relative_uri(Request, RedirUrl) -> - {Server, Port0} = Request#request.address, - Port = maybe_to_list(Port0), - Path = Request#request.path, - atom_to_list(Request#request.scheme) ++ "://" ++ Server ++ ":" ++ Port - ++ Path ++ RedirUrl. - + error(#request{id = Id}, Reason) -> {Id, {error, Reason}}. @@ -478,18 +592,3 @@ format_response({StatusLine, Headers, Body}) -> {Body, <<>>} end, {{StatusLine, http_response:header_list(Headers), NewBody}, Data}. - -%%-------------------------------------------------------------------------- -%% These functions is just simple wrappers to parse specifically HTTP URIs -%%-------------------------------------------------------------------------- - -scheme_defaults() -> - [{http, 80}, {https, 443}]. - -uri_parse(URI, Opts) -> - http_uri:parse(URI, [{scheme_defaults, scheme_defaults()} | Opts]). - - -%%-------------------------------------------------------------------------- - - diff --git a/lib/inets/src/http_lib/http_uri.erl b/lib/inets/src/http_lib/http_uri.erl index d02913121c..bc588fd390 100644 --- a/lib/inets/src/http_lib/http_uri.erl +++ b/lib/inets/src/http_lib/http_uri.erl @@ -197,7 +197,7 @@ extract_scheme(Str, Opts) -> {value, {scheme_validation_fun, Fun}} when is_function(Fun) -> case Fun(Str) of valid -> - {ok, list_to_atom(http_util:to_lower(Str))}; + {ok, to_atom(http_util:to_lower(Str))}; {error, Error} -> {error, Error} end; diff --git a/lib/inets/src/http_lib/http_util.erl b/lib/inets/src/http_lib/http_util.erl index 487d04f7aa..5577b00cc8 100644 --- a/lib/inets/src/http_lib/http_util.erl +++ b/lib/inets/src/http_lib/http_util.erl @@ -27,7 +27,8 @@ convert_month/1, is_hostname/1, timestamp/0, timeout/2, - html_encode/1 + html_encode/1, + maybe_add_brackets/2 ]). @@ -194,6 +195,24 @@ html_encode(Chars) -> lists:append([char_to_html_entity(Char, Reserved) || Char <- Chars]). +maybe_add_brackets(Addr, false) -> + Addr; +maybe_add_brackets(Addr, true) when is_list(Addr) -> + case is_ipv6_address(Addr) of + true -> + [$[|Addr] ++ "]"; + false -> + Addr + end; +maybe_add_brackets(Addr, true) when is_binary(Addr) -> + case is_ipv6_address(Addr) of + true -> + <<$[,Addr/binary,$]>>; + false -> + Addr + end. + + %%%======================================================================== %%% Internal functions %%%======================================================================== @@ -205,3 +224,14 @@ char_to_html_entity(Char, Reserved) -> false -> [Char] end. + +is_ipv6_address(Addr) when is_binary(Addr) -> + B = binary_to_list(Addr), + is_ipv6_address(B); +is_ipv6_address(Addr) when is_list(Addr) -> + case inet:parse_ipv6strict_address(Addr) of + {ok, _ } -> + true; + {error, _} -> + false + end. diff --git a/lib/inets/src/http_server/httpd.erl b/lib/inets/src/http_server/httpd.erl index 540e68e749..1eaa1c930a 100644 --- a/lib/inets/src/http_server/httpd.erl +++ b/lib/inets/src/http_server/httpd.erl @@ -36,7 +36,13 @@ ]). %% API --export([parse_query/1, reload_config/2, info/1, info/2, info/3]). +-export([ + parse_query/1, + reload_config/2, + info/1, + info/2, + info/3 + ]). %%%======================================================================== %%% API @@ -49,13 +55,24 @@ parse_query(String) -> reload_config(Config = [Value| _], Mode) when is_tuple(Value) -> do_reload_config(Config, Mode); reload_config(ConfigFile, Mode) -> - case httpd_conf:load(ConfigFile) of - {ok, ConfigList} -> - do_reload_config(ConfigList, Mode); - Error -> - Error + try file:consult(ConfigFile) of + {ok, [PropList]} -> + %% Erlang terms format + do_reload_config(PropList, Mode); + {error, _ } -> + %% Apache format + case httpd_conf:load(ConfigFile) of + {ok, ConfigList} -> + do_reload_config(ConfigList, Mode); + Error -> + Error + end + catch + exit:_ -> + throw({error, {could_not_consult_proplist_file, ConfigFile}}) end. + info(Pid) when is_pid(Pid) -> info(Pid, []). diff --git a/lib/inets/src/http_server/httpd_response.erl b/lib/inets/src/http_server/httpd_response.erl index 6b9053fda6..57ce162922 100644 --- a/lib/inets/src/http_server/httpd_response.erl +++ b/lib/inets/src/http_server/httpd_response.erl @@ -84,14 +84,14 @@ traverse_modules(ModData,[Module|Rest]) -> {proceed, NewData} -> traverse_modules(ModData#mod{data = NewData}, Rest) catch - T:E -> + T:E:Stacktrace -> String = lists:flatten( io_lib:format("module traverse failed: ~p:do => " "~n Error Type: ~p" "~n Error: ~p" "~n Stack trace: ~p", - [Module, T, E, ?STACK()])), + [Module, T, E, Stacktrace])), httpd_util:error_log(ModData#mod.config_db, String), send_status(ModData, 500, none), done diff --git a/lib/inets/src/http_server/mod_alias.erl b/lib/inets/src/http_server/mod_alias.erl index 0333076546..8f0b92710e 100644 --- a/lib/inets/src/http_server/mod_alias.erl +++ b/lib/inets/src/http_server/mod_alias.erl @@ -163,28 +163,24 @@ longest_match([], _RequestURI, _LongestNo, LongestAlias) -> real_script_name(_ConfigDB, _RequestURI, []) -> not_a_script; - -real_script_name(ConfigDB, RequestURI, [{MP,Replacement} | Rest]) - when element(1, MP) =:= re_pattern -> - case re:run(RequestURI, MP, [{capture, none}]) of - match -> - ActualName = - re:replace(RequestURI, MP, Replacement, [{return,list}]), - httpd_util:split_script_path(default_index(ConfigDB, ActualName)); - nomatch -> - real_script_name(ConfigDB, RequestURI, Rest) - end; - real_script_name(ConfigDB, RequestURI, [{FakeName,RealName} | Rest]) -> case re:run(RequestURI, "^" ++ FakeName, [{capture, none}]) of match -> - ActualName = + ActualName0 = re:replace(RequestURI, "^" ++ FakeName, RealName, [{return,list}]), + ActualName = abs_script_path(ConfigDB, ActualName0), httpd_util:split_script_path(default_index(ConfigDB, ActualName)); nomatch -> real_script_name(ConfigDB, RequestURI, Rest) end. +%% ERL-574: relative path in script_alias property results in malformed url +abs_script_path(ConfigDB, [$.|_] = RelPath) -> + Root = httpd_util:lookup(ConfigDB, server_root), + Root ++ "/" ++ RelPath; +abs_script_path(_, RelPath) -> + RelPath. + %% default_index default_index(ConfigDB, Path) -> diff --git a/lib/inets/src/inets_app/Makefile b/lib/inets/src/inets_app/Makefile index eb0098dbee..fad2fefe2f 100644 --- a/lib/inets/src/inets_app/Makefile +++ b/lib/inets/src/inets_app/Makefile @@ -48,7 +48,9 @@ MODULES = \ inets_app \ inets_sup \ inets_trace \ - inets_lib + inets_lib \ + inets_ftp_wrapper \ + inets_tftp_wrapper INTERNAL_HRL_FILES = inets_internal.hrl EXTERNAL_HRL_FILES = ../../include/httpd.hrl \ diff --git a/lib/inets/src/inets_app/inets.app.src b/lib/inets/src/inets_app/inets.app.src index eb4be932ac..dfe773e7fe 100644 --- a/lib/inets/src/inets_app/inets.app.src +++ b/lib/inets/src/inets_app/inets.app.src @@ -30,10 +30,7 @@ inets_lib, %% FTP - ftp, - ftp_progress, - ftp_response, - ftp_sup, + inets_ftp_wrapper, %% HTTP client: httpc, @@ -101,13 +98,7 @@ mod_trace, %% TFTP - tftp, - tftp_binary, - tftp_engine, - tftp_file, - tftp_lib, - tftp_logger, - tftp_sup + inets_tftp_wrapper ]}, {registered,[inets_sup, httpc_manager]}, %% If the "new" ssl is used then 'crypto' must be started before inets. diff --git a/lib/inets/src/inets_app/inets.erl b/lib/inets/src/inets_app/inets.erl index 2d380012d7..450adf1a02 100644 --- a/lib/inets/src/inets_app/inets.erl +++ b/lib/inets/src/inets_app/inets.erl @@ -465,13 +465,19 @@ call_service(Service, Call, Args) -> exit:{noproc, _} -> {error, inets_not_started} end. - + +%% Obsolete! Kept for backward compatiblity! +%% TFTP application has been moved out from inets service_module(tftpd) -> - tftp; + inets_tftp_wrapper; service_module(tftpc) -> - tftp; + inets_tftp_wrapper; +service_module(tftp) -> + inets_tftp_wrapper; +%% Obsolete! Kept for backward compatiblity! +%% FTP application has been moved out from inets service_module(ftpc) -> - ftp; + inets_ftp_wrapper; service_module(Service) -> Service. diff --git a/lib/ssh/src/ssh_server_key.erl b/lib/inets/src/inets_app/inets_ftp_wrapper.erl index 2ce0c7e3fe..e350a490f7 100644 --- a/lib/ssh/src/ssh_server_key.erl +++ b/lib/inets/src/inets_app/inets_ftp_wrapper.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2011-2016. All Rights Reserved. +%% Copyright Ericsson AB 2006-2018. 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,18 +17,32 @@ %% %% %CopyrightEnd% %% +-module(inets_ftp_wrapper). --module(ssh_server_key). --include_lib("public_key/include/public_key.hrl"). --include("ssh.hrl"). +-export([start_standalone/1, + start_service/1, + stop_service/1, + services/0, + service_info/1]). --type ssh_algorithm() :: string(). --callback host_key(Algorithm :: ssh_algorithm(), Options :: list()) -> - {ok, [{public_key(), Attributes::list()}]} | public_key() - | {error, string()}. +start_standalone(Options) -> + ftp:start_standalone(Options). --callback is_auth_key(Key :: public_key(), User :: string(), - Algorithm :: ssh_algorithm(), Options :: list()) -> - boolean(). + +start_service(Options) -> + application:ensure_started(ftp), + ftp:start_service(Options). + + +stop_service(Pid) -> + ftp:stop_service(Pid). + + +services() -> + []. + + +service_info(_) -> + []. diff --git a/lib/inets/src/inets_app/inets_internal.hrl b/lib/inets/src/inets_app/inets_internal.hrl index 079b415b56..e0f59bba5f 100644 --- a/lib/inets/src/inets_app/inets_internal.hrl +++ b/lib/inets/src/inets_app/inets_internal.hrl @@ -22,8 +22,6 @@ -ifndef(inets_internal_hrl). -define(inets_internal_hrl, true). --define(STACK(), erlang:get_stacktrace()). - %% Various trace macros -define(report(Severity, Label, Service, Content), diff --git a/lib/inets/src/inets_app/inets_sup.erl b/lib/inets/src/inets_app/inets_sup.erl index d8ae7eff26..22c928f9f9 100644 --- a/lib/inets/src/inets_app/inets_sup.erl +++ b/lib/inets/src/inets_app/inets_sup.erl @@ -61,19 +61,7 @@ children() -> Services = get_services(), HttpdServices = [Service || Service <- Services, is_httpd(Service)], HttpcServices = [Service || Service <- Services, is_httpc(Service)], - TftpdServices = [Service || Service <- Services, is_tftpd(Service)], - [ftp_child_spec(), httpc_child_spec(HttpcServices), - httpd_child_spec(HttpdServices), tftpd_child_spec(TftpdServices)]. - -ftp_child_spec() -> - Name = ftp_sup, - StartFunc = {ftp_sup, start_link, []}, - Restart = permanent, - Shutdown = infinity, - Modules = [ftp_sup], - Type = supervisor, - {Name, StartFunc, Restart, Shutdown, Type, Modules}. - + [httpc_child_spec(HttpcServices), httpd_child_spec(HttpdServices)]. httpc_child_spec(HttpcServices0) -> HttpcServices = default_profile(HttpcServices0, []), @@ -94,15 +82,6 @@ httpd_child_spec(HttpdServices) -> Type = supervisor, {Name, StartFunc, Restart, Shutdown, Type, Modules}. -tftpd_child_spec(TftpServices) -> - Name = tftp_sup, - StartFunc = {tftp_sup, start_link, [TftpServices]}, - Restart = permanent, - Shutdown = infinity, - Modules = [tftp_sup], - Type = supervisor, - {Name, StartFunc, Restart, Shutdown, Type, Modules}. - is_httpd({httpd, _}) -> true; is_httpd({httpd, _, _}) -> @@ -115,11 +94,6 @@ is_httpc({httpc, _}) -> is_httpc(_) -> false. -is_tftpd({tftpd, _}) -> - true; -is_tftpd(_) -> - false. - default_profile([], Acc) -> [{httpc, {default, only_session_cookies}} | Acc]; default_profile([{httpc, {default, _}} | _] = Profiles, Acc) -> diff --git a/lib/inets/src/inets_app/inets_tftp_wrapper.erl b/lib/inets/src/inets_app/inets_tftp_wrapper.erl new file mode 100644 index 0000000000..1e5deb234b --- /dev/null +++ b/lib/inets/src/inets_app/inets_tftp_wrapper.erl @@ -0,0 +1,48 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2006-2018. 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(inets_tftp_wrapper). + + +-export([start_standalone/1, + start_service/1, + stop_service/1, + services/0, + service_info/1]). + + +start_standalone(Options) -> + tftp:start_standalone(Options). + + +start_service(Options) -> + application:ensure_started(tftp), + tftp:start_service(Options). + + +stop_service(Pid) -> + tftp:stop_service(Pid). + + +services() -> + []. + + +service_info(_) -> + []. diff --git a/lib/inets/src/subdirs.mk b/lib/inets/src/subdirs.mk index 9f2a0079f2..e9f4de959c 100644 --- a/lib/inets/src/subdirs.mk +++ b/lib/inets/src/subdirs.mk @@ -1,3 +1,3 @@ #-*-makefile-*- ; force emacs to enter makefile-mode -SUB_DIRECTORIES = inets_app http_lib http_client http_server ftp tftp +SUB_DIRECTORIES = inets_app http_lib http_client http_server diff --git a/lib/inets/test/Makefile b/lib/inets/test/Makefile index 99a7e6a9db..0e33b72095 100644 --- a/lib/inets/test/Makefile +++ b/lib/inets/test/Makefile @@ -44,8 +44,7 @@ RELSYSDIR = $(RELEASE_PATH)/lib/$(APPLICATION)-$(VSN) INCLUDES = -I. \ -I$(ERL_TOP)/lib/inets/src/inets_app \ -I$(ERL_TOP)/lib/inets/src/http_lib \ - -I$(ERL_TOP)/lib/inets/src/http_client \ - -I$(ERL_TOP)/lib/inets/src/ftp + -I$(ERL_TOP)/lib/inets/src/http_client CP = cp @@ -68,34 +67,6 @@ INETS_FLAGS = -Dinets_data_dir='"$(INETS_DATA_DIR)"' \ ### ### test suite debug flags ### -ifeq ($(FTP_DEBUG_CLIENT),) - FTP_DEBUG_CLIENT = y -endif - -ifeq ($(FTP_DEBUG_CLIENT),) - FTP_FLAGS += -Dftp_debug_client -endif - -ifeq ($(FTP_TRACE_CLIENT),) - FTP_DEBUG_CLIENT = y -endif - -ifeq ($(FTP_TRACE_CLIENT),y) - FTP_FLAGS += -Dftp_trace_client -endif - -ifneq ($(FTP_DEBUG),) - FTP_DEBUG = s -endif - -ifeq ($(FTP_DEBUG),l) - FTP_FLAGS += -Dftp_log -endif - -ifeq ($(FTP_DEBUG),d) - FTP_FLAGS += -Dftp_debug -Dftp_log -endif - ifeq ($(INETS_DEBUG),) INETS_DEBUG = d endif @@ -151,8 +122,6 @@ MODULES = \ inets_test_lib \ erl_make_certs \ make_certs \ - ftp_SUITE \ - ftp_format_SUITE \ http_format_SUITE \ httpc_SUITE \ httpc_cookie_SUITE \ @@ -169,8 +138,6 @@ MODULES = \ httpd_test_lib \ inets_sup_SUITE \ inets_SUITE \ - tftp_test_lib \ - tftp_SUITE \ uri_SUITE \ inets_socketwrap_SUITE @@ -179,10 +146,8 @@ EBIN = . HRL_FILES = inets_test_lib.hrl \ inets_internal.hrl \ - ftp_internal.hrl \ httpc_internal.hrl \ - http_internal.hrl \ - tftp_test_lib.hrl + http_internal.hrl ERL_FILES = $(MODULES:%=%.erl) @@ -197,18 +162,15 @@ INETS_FILES = inets.config $(INETS_SPECS) # SUB_SUITES = \ # inets_sup_suite \ # inets_httpd_suite \ -# inets_httpc_suite \ -# inets_ftp_suite \ -# inets_tftp_suite +# inets_httpc_suite INETS_DATADIRS = inets_SUITE_data inets_socketwrap_SUITE_data HTTPD_DATADIRS = httpd_test_data httpd_SUITE_data httpd_basic_SUITE_data old_httpd_SUITE_data httpd_bench_SUITE_data HTTPC_DATADIRS = httpc_SUITE_data httpc_proxy_SUITE_data -FTP_DATADIRS = ftp_SUITE_data -DATADIRS = $(INETS_DATADIRS) $(HTTPD_DATADIRS) $(HTTPC_DATADIRS) $(FTP_DATADIRS) +DATADIRS = $(INETS_DATADIRS) $(HTTPD_DATADIRS) $(HTTPC_DATADIRS) EMAKEFILE = Emakefile MAKE_EMAKE = $(wildcard $(ERL_TOP)/make/make_emakefile) @@ -238,7 +200,6 @@ RELTESTSYSBINDIR = $(RELTESTSYSALLDATADIR)/bin # ---------------------------------------------------- ERL_COMPILE_FLAGS += \ $(INCLUDES) \ - $(FTP_FLAGS) \ $(INETS_FLAGS) # ---------------------------------------------------- @@ -334,11 +295,3 @@ info: @echo "INETS_PRIV_DIR = $(INETS_PRIV_DIR)" @echo "INETS_ROOT = $(INETS_ROOT)" @echo "INETS_FLAGS = $(INETS_FLAGS)" - @echo "FTP_FLAGS = $(FTP_FLAGS)" - -tftp: - erlc $(ERL_COMPILE_FLAGS) tftp_test_lib.erl tftp_SUITE.erl && erl -pa ../../inets/ebin -s tftp_SUITE t -s erlang halt - -tftp_work: - echo "tftp_test_lib:t([{tftp_SUITE, all}])." - erlc $(ERL_COMPILE_FLAGS) tftp_test_lib.erl tftp_SUITE.erl && erl -pa ../../inets/ebin diff --git a/lib/inets/test/ftp_internal.hrl b/lib/inets/test/ftp_internal.hrl deleted file mode 120000 index af57081f14..0000000000 --- a/lib/inets/test/ftp_internal.hrl +++ /dev/null @@ -1 +0,0 @@ -../src/ftp/ftp_internal.hrl
\ No newline at end of file diff --git a/lib/inets/test/httpc_SUITE.erl b/lib/inets/test/httpc_SUITE.erl index 9bf58f18e5..47c7ffd190 100644 --- a/lib/inets/test/httpc_SUITE.erl +++ b/lib/inets/test/httpc_SUITE.erl @@ -53,6 +53,7 @@ suite() -> all() -> [ {group, http}, + {group, http_ipv6}, {group, sim_http}, {group, http_internal}, {group, http_unix_socket}, @@ -64,7 +65,11 @@ all() -> groups() -> [ {http, [], real_requests()}, - {sim_http, [], only_simulated() ++ [process_leak_on_keepalive]}, + {http_ipv6, [], [request_options]}, + %% process_leak_on_keepalive is depending on stream_fun_server_close + %% and it shall be the last test case in the suite otherwise cookie + %% will fail. + {sim_http, [], only_simulated() ++ server_closing_connection() ++ [process_leak_on_keepalive]}, {http_internal, [], real_requests_esi()}, {http_unix_socket, [], simulated_unix_socket()}, {https, [], real_requests()}, @@ -76,6 +81,7 @@ real_requests()-> [ head, get, + get_query_string, post, delete, post_stream, @@ -141,13 +147,22 @@ only_simulated() -> redirect_found, redirect_see_other, redirect_temporary_redirect, + redirect_relative_uri, port_in_host_header, redirect_port_in_host_header, relaxed, multipart_chunks, + get_space, + delete_no_body, stream_fun_server_close ]. +server_closing_connection() -> + [ + server_closing_connection_on_first_response, + server_closing_connection_on_second_response + ]. + misc() -> [ server_does_not_exist, @@ -201,6 +216,16 @@ init_per_group(http_unix_socket = Group, Config0) -> Port = server_start(Group, server_config(Group, Config)), [{port, Port} | Config] end; +init_per_group(http_ipv6 = Group, Config0) -> + case is_ipv6_supported() of + true -> + start_apps(Group), + Config = proplists:delete(port, Config0), + Port = server_start(Group, server_config(Group, Config)), + [{port, Port} | Config]; + false -> + {skip, "Host does not support IPv6"} + end; init_per_group(Group, Config0) -> start_apps(Group), Config = proplists:delete(port, Config0), @@ -227,7 +252,7 @@ init_per_testcase(pipeline, Config) -> init_per_testcase(persistent_connection, Config) -> inets:start(httpc, [{profile, persistent}]), httpc:set_options([{keep_alive_timeout, 50000}, - {max_keep_alive_length, 3}], persistent_connection), + {max_keep_alive_length, 3}], persistent), Config; init_per_testcase(wait_for_whole_response, Config) -> @@ -246,10 +271,38 @@ end_per_testcase(pipeline, _Config) -> inets:stop(httpc, pipeline); end_per_testcase(persistent_connection, _Config) -> inets:stop(httpc, persistent); +end_per_testcase(Case, Config) + when Case == server_closing_connection_on_first_response; + Case == server_closing_connection_on_second_response -> + %% Test case uses at most one session. Ensure no leftover + %% sessions left behind. + {_, Status} = proplists:lookup(tc_status, Config), + ShallCleanup = case Status of + ok -> true; + {failed, _} -> true; + {skipped, _} -> false + end, + if ShallCleanup =:= true -> + httpc:request(url(group_name(Config), "/just_close.html", Config)), + ok; + true -> + ct:pal("Not cleaning up because test case status was ~p", [Status]), + ok + end; end_per_testcase(_Case, _Config) -> ok. +is_ipv6_supported() -> + case gen_udp:open(0, [inet6]) of + {ok, Socket} -> + gen_udp:close(Socket), + true; + _ -> + false + end. + + %%-------------------------------------------------------------------- %% Test Cases -------------------------------------------------------- %%-------------------------------------------------------------------- @@ -271,6 +324,25 @@ get(Config) when is_list(Config) -> {ok, {{_,200,_}, [_ | _], BinBody}} = httpc:request(get, Request, [], [{body_format, binary}]), true = is_binary(BinBody). + + +get_query_string() -> + [{doc, "Test http get request with query string against local server"}]. +get_query_string(Config) when is_list(Config) -> + Request = {url(group_name(Config), "/dummy.html?foo=bar", Config), []}, + {ok, {{_,200,_}, [_ | _], Body = [_ | _]}} = httpc:request(get, Request, [], []), + + inets_test_lib:check_body(Body). + +%%-------------------------------------------------------------------- +get_space() -> + [{"Test http get request with '%20' in the path of the URL."}]. +get_space(Config) when is_list(Config) -> + Request = {url(group_name(Config), "/space%20.html", Config), []}, + {ok, {{_,200,_}, [_ | _], Body = [_ | _]}} = httpc:request(get, Request, [], []), + + inets_test_lib:check_body(Body). + %%-------------------------------------------------------------------- post() -> [{"Test http post request against local server. We do in this case " @@ -604,7 +676,26 @@ redirect_temporary_redirect(Config) when is_list(Config) -> {ok, {{_,200,_}, [_ | _], [_|_]}} = httpc:request(post, {URL307, [],"text/plain", "foobar"}, [], []). +%%------------------------------------------------------------------------- +redirect_relative_uri() -> + [{doc, "The server SHOULD generate a Location header field in the response " + "containing a preferred URI reference for the new permanent URI. The user " + "agent MAY use the Location field value for automatic redirection. The server's " + "response payload usually contains a short hypertext note with a " + "hyperlink to the new URI(s)."}]. +redirect_relative_uri(Config) when is_list(Config) -> + + URL301 = url(group_name(Config), "/301_rel_uri.html", Config), + + {ok, {{_,200,_}, [_ | _], [_|_]}} + = httpc:request(get, {URL301, []}, [], []), + + {ok, {{_,200,_}, [_ | _], []}} + = httpc:request(head, {URL301, []}, [], []), + {ok, {{_,200,_}, [_ | _], [_|_]}} + = httpc:request(post, {URL301, [],"text/plain", "foobar"}, + [], []). %%------------------------------------------------------------------------- redirect_loop() -> [{"doc, Test redirect loop detection"}]. @@ -1082,8 +1173,6 @@ remote_socket_close_async(Config) when is_list(Config) -> %%------------------------------------------------------------------------- process_leak_on_keepalive(Config) -> - {ok, ClosedSocket} = gen_tcp:listen(6666, [{active, false}]), - ok = gen_tcp:close(ClosedSocket), Request = {url(group_name(Config), "/dummy.html", Config), []}, HttpcHandlers0 = supervisor:which_children(httpc_handler_sup), {ok, {{_, 200, _}, _, Body}} = httpc:request(get, Request, [], []), @@ -1095,11 +1184,10 @@ process_leak_on_keepalive(Config) -> ordsets:to_list( ordsets:subtract(ordsets:from_list(HttpcHandlers1), ordsets:from_list(HttpcHandlers0))), - sys:replace_state( - Pid, fun (State) -> - Session = element(3, State), - setelement(3, State, Session#session{socket=ClosedSocket}) - end), + State = sys:get_state(Pid), + #session{socket=Socket} = element(3, State), + gen_tcp:close(Socket), + {ok, {{_, 200, _}, _, Body}} = httpc:request(get, Request, [], []), %% bad handler with the closed socket should get replaced by %% the new one, so children count should stay the same @@ -1234,6 +1322,53 @@ stream_fun_server_close(Config) when is_list(Config) -> end. %%-------------------------------------------------------------------- +server_closing_connection_on_first_response() -> + [{doc, "Client receives \"Connection: close\" on first response." + "A client that receives a \"close\" connection option MUST cease sending" + "requests on that connection and close the connection after reading" + "the response message containing the \"close\""}]. +server_closing_connection_on_first_response(Config) when is_list(Config) -> + ReqSrvSendOctFun = + fun(V, U, S) -> + {ok, {{V, S, _}, Headers0, []}} = + httpc:request(get, {U, []}, [{version, V}], []), + {_, SendOctStr} = + proplists:lookup("x-socket-stat-send-oct", Headers0), + list_to_integer(SendOctStr) + end, + V = "HTTP/1.1", + Url0 = url(group_name(Config), "/http_1_1_send_oct.html", Config), + Url1 = url(group_name(Config), "/http_1_1_send_oct_and_connection_close.html", Config), + %% Test case assumes at most one reusable past session. + _ = ReqSrvSendOctFun(V, Url1, 204), + 0 = ReqSrvSendOctFun(V, Url0, 204), + ok. + +%%-------------------------------------------------------------------- +server_closing_connection_on_second_response() -> + [{doc, "Client receives \"Connection: close\" on second response." + "A client that receives a \"close\" connection option MUST cease sending" + "requests on that connection and close the connection after reading" + "the response message containing the \"close\""}]. +server_closing_connection_on_second_response(Config) when is_list(Config) -> + ReqSrvSendOctFun = + fun(V, U, S) -> + {ok, {{V, S, _}, Headers0, []}} = + httpc:request(get, {U, []}, [{version, V}], []), + {_, SendOctStr} = + proplists:lookup("x-socket-stat-send-oct", Headers0), + list_to_integer(SendOctStr) + end, + V = "HTTP/1.1", + Url0 = url(group_name(Config), "/http_1_1_send_oct.html", Config), + Url1 = url(group_name(Config), "/http_1_1_send_oct_and_connection_close.html", Config), + %% Test case assumes no reusable past sessions. + SendOct0 = 0 = ReqSrvSendOctFun(V, Url0, 204), + case ReqSrvSendOctFun(V, Url1, 204) of SendOct1 when SendOct1 > SendOct0 -> ok end, + 0 = ReqSrvSendOctFun(V, Url0, 204), + ok. + +%%-------------------------------------------------------------------- slow_connection() -> [{doc, "Test that a request on a slow keep-alive connection won't crash the httpc_manager"}]. slow_connection(Config) when is_list(Config) -> @@ -1264,6 +1399,26 @@ unix_domain_socket(Config) when is_list(Config) -> {ok, {{_,200,_}, [_ | _], _}} = httpc:request(get, {URL, []}, [], []). +%%------------------------------------------------------------------------- +delete_no_body(doc) -> + ["Test that a DELETE request without Body does not send a Content-Type header - Solves ERL-536"]; +delete_no_body(Config) when is_list(Config) -> + URL = url(group_name(Config), "/delete_no_body.html", Config), + %% Simulated server replies 500 if 'Content-Type' header is present + {ok, {{_,200,_}, _, _}} = + httpc:request(delete, {URL, []}, [], []), + {ok, {{_,500,_}, _, _}} = + httpc:request(delete, {URL, [], "text/plain", "TEST"}, [], []). + +%%-------------------------------------------------------------------- +request_options() -> + [{doc, "Test http get request with socket options against local server (IPv6)"}]. +request_options(Config) when is_list(Config) -> + Request = {url(group_name(Config), "/dummy.html", Config), []}, + {ok, {{_,200,_}, [_ | _], _ = [_ | _]}} = httpc:request(get, Request, [], + [{socket_opts,[{ipfamily, inet6}]}]), + {error,{failed_connect,_ }} = httpc:request(get, Request, [], []). + %%-------------------------------------------------------------------- @@ -1353,6 +1508,9 @@ url(http, End, Config) -> Port = proplists:get_value(port, Config), {ok,Host} = inet:gethostname(), ?URL_START ++ Host ++ ":" ++ integer_to_list(Port) ++ End; +url(http_ipv6, End, Config) -> + Port = proplists:get_value(port, Config), + ?URL_START ++ "[::1]" ++ ":" ++ integer_to_list(Port) ++ End; url(https, End, Config) -> Port = proplists:get_value(port, Config), {ok,Host} = inet:gethostname(), @@ -1397,7 +1555,11 @@ server_start(http_unix_socket, Config) -> {_Pid, Port} = http_test_lib:dummy_server(unix_socket, Inet, [{content_cb, ?MODULE}, {unix_socket, Socket}]), Port; - +server_start(http_ipv6, HttpdConfig) -> + {ok, Pid} = inets:start(httpd, HttpdConfig), + Serv = inets:services_info(), + {value, {_, _, Info}} = lists:keysearch(Pid, 2, Serv), + proplists:get_value(port, Info); server_start(_, HttpdConfig) -> {ok, Pid} = inets:start(httpd, HttpdConfig), Serv = inets:services_info(), @@ -1416,6 +1578,17 @@ server_config(http, Config) -> {mime_type, "text/plain"}, {script_alias, {"/cgi-bin/", filename:join(ServerRoot, "cgi-bin") ++ "/"}} ]; +server_config(http_ipv6, Config) -> + ServerRoot = proplists:get_value(server_root, Config), + [{port, 0}, + {server_name,"httpc_test"}, + {server_root, ServerRoot}, + {document_root, proplists:get_value(doc_root, Config)}, + {bind_address, {0,0,0,0,0,0,0,1}}, + {ipfamily, inet6}, + {mime_type, "text/plain"}, + {script_alias, {"/cgi-bin/", filename:join(ServerRoot, "cgi-bin") ++ "/"}} + ]; server_config(http_internal, Config) -> ServerRoot = proplists:get_value(server_root, Config), [{port, 0}, @@ -1770,6 +1943,13 @@ auth_header([{"authorization", Value} | _]) -> auth_header([_ | Tail]) -> auth_header(Tail). +content_type_header([]) -> + not_found; +content_type_header([{"content-type", Value}|_]) -> + {ok, string:strip(Value)}; +content_type_header([_|T]) -> + content_type_header(T). + handle_auth("Basic " ++ UserInfo, Challange, DefaultResponse) -> case string:tokens(base64:decode_to_string(UserInfo), ":") of ["alladin", "sesame"] = Auth -> @@ -1794,6 +1974,15 @@ content_length(["content-length:" ++ Value | _]) -> content_length([_Head | Tail]) -> content_length(Tail). +handle_uri("GET","/dummy.html?foo=bar",_,_,_,_) -> + "HTTP/1.0 200 OK\r\n\r\nTEST"; + +handle_uri("GET","/space%20.html",_,_,_,_) -> + Body = "<HTML><BODY>foobar</BODY></HTML>", + "HTTP/1.1 200 OK\r\n" ++ + "Content-Length:" ++ integer_to_list(length(Body)) ++ "\r\n\r\n" ++ + Body; + handle_uri(_,"/just_close.html",_,_,_,_) -> close; handle_uri(_,"/no_content.html",_,_,_,_) -> @@ -1859,6 +2048,23 @@ handle_uri(_,"/301.html",Port,_,Socket,_) -> "Content-Length:" ++ integer_to_list(length(Body)) ++ "\r\n\r\n" ++ Body; + +handle_uri("HEAD","/301_rel_uri.html",_,_,_,_) -> + NewUri = "/dummy.html", + "HTTP/1.1 301 Moved Permanently\r\n" ++ + "Location:" ++ NewUri ++ "\r\n" ++ + "Content-Length:0\r\n\r\n"; + +handle_uri(_,"/301_rel_uri.html",_,_,_,_) -> + NewUri = "/dummy.html", + Body = "<HTML><BODY><a href=" ++ NewUri ++ + ">New place</a></BODY></HTML>", + "HTTP/1.1 301 Moved Permanently\r\n" ++ + "Location:" ++ NewUri ++ "\r\n" ++ + "Content-Length:" ++ integer_to_list(length(Body)) + ++ "\r\n\r\n" ++ Body; + + handle_uri("HEAD","/302.html",Port,_,Socket,_) -> NewUri = url_start(Socket) ++ integer_to_list(Port) ++ "/dummy.html", @@ -2165,10 +2371,40 @@ handle_uri("GET","/v1/kv/foo",_,_,_,_) -> "Content-Length: 24\r\n" ++ "Content-Type: application/json\r\n\r\n" ++ "[{\"Value\": \"aGVsbG8=\"}]\n"; - +handle_uri(_,"/http_1_1_send_oct.html",_,_,Socket,_) -> + "HTTP/1.1 204 No Content\r\n" ++ + "X-Socket-Stat-Send-Oct: " ++ integer_to_list(get_stat(Socket, send_oct)) ++ "\r\n" ++ + "\r\n"; +handle_uri(_,"/http_1_1_send_oct_and_connection_close.html",_,_,Socket,_) -> + "HTTP/1.1 204 No Content\r\n" ++ + "X-Socket-Stat-Send-Oct: " ++ integer_to_list(get_stat(Socket, send_oct)) ++ "\r\n" ++ + "Connection: close\r\n" ++ + "\r\n"; +handle_uri(_,"/delete_no_body.html", _,Headers,_, DefaultResponse) -> + Error = "HTTP/1.1 500 Internal Server Error\r\n" ++ + "Content-Length:0\r\n\r\n", + case content_type_header(Headers) of + {ok, _} -> + Error; + not_found -> + DefaultResponse + end; handle_uri(_,_,_,_,_,DefaultResponse) -> DefaultResponse. +get_stat(S, Opt) -> + case getstat(S, [Opt]) of + {ok, [{Opt, V}]} when is_integer(V) -> + V; + {error, _} = E -> + E + end. + +getstat(#sslsocket{} = S, Opts) -> + ssl:getstat(S, Opts); +getstat(S, Opts) -> + inet:getstat(S, Opts). + url_start(#sslsocket{}) -> {ok,Host} = inet:gethostname(), ?TLS_URL_START ++ Host ++ ":"; diff --git a/lib/inets/test/httpd_SUITE.erl b/lib/inets/test/httpd_SUITE.erl index 9a85c51d24..5020b5a802 100644 --- a/lib/inets/test/httpd_SUITE.erl +++ b/lib/inets/test/httpd_SUITE.erl @@ -75,6 +75,7 @@ all() -> {group, http_mime_types}, {group, http_logging}, {group, http_post}, + {group, http_rel_path_script_alias}, mime_types_format ]. @@ -112,7 +113,8 @@ groups() -> non_disturbing_0_9, disturbing_1_1, disturbing_1_0, - disturbing_0_9 + disturbing_0_9, + reload_config_file ]}, {post, [], [chunked_post, chunked_chunked_encoded_post]}, {basic_auth, [], [basic_auth_1_1, basic_auth_1_0, basic_auth_0_9]}, @@ -131,7 +133,8 @@ groups() -> trace, range, if_modified_since, mod_esi_chunk_timeout, esi_put, esi_post] ++ http_head() ++ http_get() ++ load()}, {http_1_0, [], [host, cgi, trace] ++ http_head() ++ http_get() ++ load()}, - {http_0_9, [], http_head() ++ http_get() ++ load()} + {http_0_9, [], http_head() ++ http_get() ++ load()}, + {http_rel_path_script_alias, [], [cgi]} ]. basic_groups ()-> @@ -168,6 +171,7 @@ init_per_suite(Config) -> ServerRoot = filename:join(PrivDir, "server_root"), inets_test_lib:del_dirs(ServerRoot), DocRoot = filename:join(ServerRoot, "htdocs"), + setup_tmp_dir(PrivDir), setup_server_dirs(ServerRoot, DocRoot, DataDir), {ok, Hostname0} = inet:gethostname(), Inet = @@ -268,6 +272,9 @@ init_per_group(http_logging, Config) -> ServerRoot = proplists:get_value(server_root, Config1), Path = ServerRoot ++ "/httpd_log_transfer", [{transfer_log, Path} | Config1]; +init_per_group(http_rel_path_script_alias = Group, Config) -> + ok = start_apps(Group), + init_httpd(Group, [{type, ip_comm},{http_version, "HTTP/1.1"}| Config]); init_per_group(_, Config) -> Config. @@ -1536,6 +1543,45 @@ non_disturbing(Config) when is_list(Config)-> end, inets_test_lib:close(Type, Socket), [{server_name, "httpd_non_disturbing_" ++ Version}] = httpd:info(Server, [server_name]). +%%------------------------------------------------------------------------- +reload_config_file(Config) when is_list(Config) -> + ServerRoot = proplists:get_value(server_root, Config), + HttpdConf = filename:join(get_tmp_dir(Config), "inets_httpd_server.conf"), + ServerConfig = + "[\n" ++ + "{bind_address, \"localhost\"}," ++ + "{port,0}," ++ + "{server_name,\"httpd_test\"}," ++ + "{server_root,\"" ++ ServerRoot ++ "\"}," ++ + "{document_root,\"" ++ proplists:get_value(doc_root, Config) ++ "\"}" ++ + "].", + ok = file:write_file(HttpdConf, ServerConfig), + {ok, Server} = inets:start(httpd, [{proplist_file, HttpdConf}]), + Port = proplists:get_value(port, httpd:info(Server)), + NewConfig = + "[\n" ++ + "{bind_address, \"localhost\"}," ++ + "{port," ++ integer_to_list(Port) ++ "}," ++ + "{server_name,\"httpd_test_new\"}," ++ + "{server_root,\"" ++ ServerRoot ++ "\"}," ++ + "{document_root,\"" ++ proplists:get_value(doc_root, Config) ++ "\"}" ++ + "].", + NewConfigApache = + "BindAddress localhost\n" ++ + "Port " ++ integer_to_list(Port) ++ "\n" ++ + "ServerName httpd_test_new_apache\n" ++ + "ServerRoot " ++ ServerRoot ++ "\n" ++ + "DocumentRoot " ++ proplists:get_value(doc_root, Config) ++ "\n", + + %% Test Erlang term format + ok = file:write_file(HttpdConf, NewConfig), + ok = httpd:reload_config(HttpdConf, non_disturbing), + "httpd_test_new" = proplists:get_value(server_name, httpd:info(Server)), + + %% Test Apache format + ok = file:write_file(HttpdConf, NewConfigApache), + ok = httpd:reload_config(HttpdConf, non_disturbing), + "httpd_test_new_apache" = proplists:get_value(server_name, httpd:info(Server)). %%------------------------------------------------------------------------- mime_types_format(Config) when is_list(Config) -> @@ -1647,6 +1693,7 @@ mime_types_format(Config) when is_list(Config) -> {"cpt","application/mac-compactpro"}, {"hqx","application/mac-binhex40"}]} = httpd_conf:load_mime_types(MimeTypes). + %%-------------------------------------------------------------------- %% Internal functions ----------------------------------- %%-------------------------------------------------------------------- @@ -1728,7 +1775,15 @@ setup_server_dirs(ServerRoot, DocRoot, DataDir) -> {ok, FileInfo1} = file:read_file_info(EnvCGI), ok = file:write_file_info(EnvCGI, FileInfo1#file_info{mode = 8#00755}). - + +setup_tmp_dir(PrivDir) -> + TmpDir = filename:join(PrivDir, "tmp"), + ok = file:make_dir(TmpDir). + +get_tmp_dir(Config) -> + PrivDir = proplists:get_value(priv_dir, Config), + filename:join(PrivDir, "tmp"). + start_apps(Group) when Group == https_basic; Group == https_limit; Group == https_custom; @@ -1753,7 +1808,8 @@ start_apps(Group) when Group == http_basic; Group == http_logging; Group == http_reload; Group == http_post; - Group == http_mime_types-> + Group == http_mime_types; + Group == http_rel_path_script_alias -> inets_test_lib:start_apps([inets]). server_start(_, HttpdConfig) -> @@ -1878,7 +1934,27 @@ server_config(http, Config) -> {erl_script_alias, {"/cgi-bin/erl", [httpd_example, io]}}, {eval_script_alias, {"/eval", [httpd_example, io]}} ]; - +server_config(http_rel_path_script_alias, Config) -> + ServerRoot = proplists:get_value(server_root, Config), + [{port, 0}, + {socket_type, {ip_comm, [{nodelay, true}]}}, + {server_name,"httpd_test"}, + {server_root, ServerRoot}, + {document_root, proplists:get_value(doc_root, Config)}, + {bind_address, any}, + {ipfamily, proplists:get_value(ipfamily, Config)}, + {max_header_size, 256}, + {max_header_action, close}, + {directory_index, ["index.html", "welcome.html"]}, + {mime_types, [{"html","text/html"},{"htm","text/html"}, {"shtml","text/html"}, + {"gif", "image/gif"}]}, + {alias, {"/icons/", filename:join(ServerRoot,"icons") ++ "/"}}, + {alias, {"/pics/", filename:join(ServerRoot,"icons") ++ "/"}}, + {script_alias, {"/cgi-bin/", "./cgi-bin/"}}, + {script_alias, {"/htbin/", "./cgi-bin/"}}, + {erl_script_alias, {"/cgi-bin/erl", [httpd_example, io]}}, + {eval_script_alias, {"/eval", [httpd_example, io]}} + ]; server_config(https, Config) -> PrivDir = proplists:get_value(priv_dir, Config), [{socket_type, {essl, diff --git a/lib/inets/test/httpd_basic_SUITE.erl b/lib/inets/test/httpd_basic_SUITE.erl index 931cd076cc..94d22ea76c 100644 --- a/lib/inets/test/httpd_basic_SUITE.erl +++ b/lib/inets/test/httpd_basic_SUITE.erl @@ -303,7 +303,10 @@ escaped_url_in_error_body(Config) when is_list(Config) -> %% Ask for a non-existing page(1) Path = "/<b>this_is_bold<b>", HTMLEncodedPath = http_util:html_encode(Path), - URL2 = URL1 ++ Path, + URL2 = uri_string:recompose(#{scheme => "http", + host => "localhost", + port => Port, + path => Path}), {ok, {404, Body3}} = httpc:request(get, {URL2, []}, [{url_encode, true}, {version, "HTTP/1.0"}], diff --git a/lib/inets/test/inets_SUITE.erl b/lib/inets/test/inets_SUITE.erl index 1abd96a228..07ce594a1d 100644 --- a/lib/inets/test/inets_SUITE.erl +++ b/lib/inets/test/inets_SUITE.erl @@ -41,9 +41,7 @@ groups() -> [{services_test, [], [start_inets, start_httpc, - start_httpd, - start_ftpc, - start_tftpd + start_httpd ]}, {app_test, [], [app, appup]}]. @@ -298,79 +296,6 @@ start_httpd(Config) when is_list(Config) -> %%------------------------------------------------------------------------- -start_ftpc(doc) -> - [{doc, "Start/stop of ftpc service"}]; -start_ftpc(Config0) when is_list(Config0) -> - process_flag(trap_exit, true), - ok = inets:start(), - case ftp_SUITE:init_per_suite(Config0) of - {skip, _} = Skip -> - Skip; - Config -> - FtpdHost = proplists:get_value(ftpd_host,Config), - {ok, Pid0} = inets:start(ftpc, [{host, FtpdHost}]), - Pids0 = [ServicePid || {_, ServicePid} <- - inets:services()], - true = lists:member(Pid0, Pids0), - [_|_] = inets:services_info(), - inets:stop(ftpc, Pid0), - ct:sleep(100), - Pids1 = [ServicePid || {_, ServicePid} <- - inets:services()], - false = lists:member(Pid0, Pids1), - {ok, Pid1} = - inets:start(ftpc, [{host, FtpdHost}], stand_alone), - Pids2 = [ServicePid || {_, ServicePid} <- - inets:services()], - false = lists:member(Pid1, Pids2), - ok = inets:stop(stand_alone, Pid1), - receive - {'EXIT', Pid1, shutdown} -> - ok - after 100 -> - ct:fail(stand_alone_not_shutdown) - end, - ok = inets:stop(), - catch ftp_SUITE:end_per_SUITE(Config) - end. - -%%------------------------------------------------------------------------- - -start_tftpd() -> - [{doc, "Start/stop of tfpd service"}]. -start_tftpd(Config) when is_list(Config) -> - process_flag(trap_exit, true), - ok = inets:start(), - {ok, Pid0} = inets:start(tftpd, [{host, "localhost"}, {port, 0}]), - Pids0 = [ServicePid || {_, ServicePid} <- inets:services()], - true = lists:member(Pid0, Pids0), - [_|_] = inets:services_info(), - inets:stop(tftpd, Pid0), - ct:sleep(100), - Pids1 = [ServicePid || {_, ServicePid} <- inets:services()], - false = lists:member(Pid0, Pids1), - {ok, Pid1} = - inets:start(tftpd, [{host, "localhost"}, {port, 0}], stand_alone), - Pids2 = [ServicePid || {_, ServicePid} <- inets:services()], - false = lists:member(Pid1, Pids2), - ok = inets:stop(stand_alone, Pid1), - receive - {'EXIT', Pid1, shutdown} -> - ok - after 100 -> - ct:fail(stand_alone_not_shutdown) - end, - ok = inets:stop(), - application:load(inets), - application:set_env(inets, services, [{tftpd,[{host, "localhost"}, - {port, 0}]}]), - ok = inets:start(), - (?NUM_DEFAULT_SERVICES + 1) = length(inets:services()), - application:unset_env(inets, services), - ok = inets:stop(). - -%%------------------------------------------------------------------------- - httpd_reload() -> [{doc, "Reload httpd configuration without restarting service"}]. httpd_reload(Config) when is_list(Config) -> diff --git a/lib/inets/test/inets_socketwrap_SUITE.erl b/lib/inets/test/inets_socketwrap_SUITE.erl index 7ea7e08ed1..fc87c595a9 100644 --- a/lib/inets/test/inets_socketwrap_SUITE.erl +++ b/lib/inets/test/inets_socketwrap_SUITE.erl @@ -30,7 +30,7 @@ suite() -> [{ct_hooks,[ts_install_cth]}]. all() -> - [start_httpd_fd, start_tftpd_fd]. + [start_httpd_fd]. init_per_suite(Config) -> case os:type() of @@ -90,37 +90,7 @@ start_httpd_fd(Config) when is_list(Config) -> ct:fail(open_port_failed) end end. -%%------------------------------------------------------------------------- -start_tftpd_fd() -> - [{doc, "Start/stop of tfpd service with socket wrapper"}]. -start_tftpd_fd(Config) when is_list(Config) -> - DataDir = proplists:get_value(data_dir, Config), - case setup_node_info(node()) of - {skip, _} = Skip -> - Skip; - {Node, NodeArg} -> - InetPort = inets_test_lib:inet_port(node()), - ct:pal("Node: ~p~n", [Node]), - Wrapper = filename:join(DataDir, "setuid_socket_wrap"), - Cmd = Wrapper ++ - " -s -tftpd_69,0:" ++ integer_to_list(InetPort) - ++ " -p " ++ os:find_executable("erl") ++ - " -- " ++ NodeArg, - ct:pal("cmd: ~p~n", [Cmd]), - case open_port({spawn, Cmd}, [stderr_to_stdout]) of - Port when is_port(Port) -> - wait_node_up(Node, 10), - ct:pal("~p", [rpc:call(Node, init, get_argument, [tftpd_69])]), - ok = rpc:call(Node, inets, start, []), - {ok, Pid} = rpc:call(Node, inets, start, - [tftpd,[{host, "localhost"}]]), - {ok, Info} = rpc:call(Node, tftp, info, [Pid]), - {value,{port, InetPort}} = lists:keysearch(port, 1, Info), - rpc:call(Node, erlang, halt, []); - _ -> - ct:fail(open_port_failed) - end - end. + %%------------------------------------------------------------------------- %% Internal functions %%------------------------------------------------------------------------- diff --git a/lib/inets/test/inets_sup_SUITE.erl b/lib/inets/test/inets_sup_SUITE.erl index 1e664337e6..727e91e987 100644 --- a/lib/inets/test/inets_sup_SUITE.erl +++ b/lib/inets/test/inets_sup_SUITE.erl @@ -32,8 +32,7 @@ suite() -> ]. all() -> - [default_tree, ftpc_worker, tftpd_worker, - httpd_config, httpd_subtree, httpd_subtree_profile, + [default_tree, httpd_config, httpd_subtree, httpd_subtree_profile, httpc_subtree]. groups() -> @@ -147,15 +146,11 @@ default_tree() -> "in the default case."}]. default_tree(Config) when is_list(Config) -> TopSupChildren = supervisor:which_children(inets_sup), - 4 = length(TopSupChildren), + 2 = length(TopSupChildren), {value, {httpd_sup, _, supervisor,[httpd_sup]}} = lists:keysearch(httpd_sup, 1, TopSupChildren), {value, {httpc_sup, _,supervisor,[httpc_sup]}} = lists:keysearch(httpc_sup, 1, TopSupChildren), - {value, {ftp_sup,_,supervisor,[ftp_sup]}} = - lists:keysearch(ftp_sup, 1, TopSupChildren), - {value, {tftp_sup,_,supervisor,[tftp_sup]}} = - lists:keysearch(tftp_sup, 1, TopSupChildren), HttpcSupChildren = supervisor:which_children(httpc_sup), {value, {httpc_profile_sup,_, supervisor, [httpc_profile_sup]}} = @@ -163,8 +158,6 @@ default_tree(Config) when is_list(Config) -> {value, {httpc_handler_sup,_, supervisor, [httpc_handler_sup]}} = lists:keysearch(httpc_handler_sup, 1, HttpcSupChildren), - [] = supervisor:which_children(ftp_sup), - [] = supervisor:which_children(httpd_sup), %% Default profile @@ -172,48 +165,7 @@ default_tree(Config) when is_list(Config) -> = supervisor:which_children(httpc_profile_sup), [] = supervisor:which_children(httpc_handler_sup), - - [] = supervisor:which_children(tftp_sup), - - ok. -ftpc_worker() -> - [{doc, "Makes sure the ftp worker processes are added and removed " - "appropriatly to/from the supervison tree."}]. -ftpc_worker(Config0) when is_list(Config0) -> - [] = supervisor:which_children(ftp_sup), - case ftp_SUITE:init_per_suite(Config0) of - {skip, _} = Skip -> - Skip; - Config -> - FtpdHost = proplists:get_value(ftpd_host,Config), - {ok, Pid} = inets:start(ftpc, [{host, FtpdHost}]), - case supervisor:which_children(ftp_sup) of - [{_,_, worker, [ftp]}] -> - inets:stop(ftpc, Pid), - ct:sleep(5000), - [] = supervisor:which_children(ftp_sup), - catch ftp_SUITE:end_per_SUITE(Config), - ok; - Children -> - catch ftp_SUITE:end_per_SUITE(Config), - exit({unexpected_children, Children}) - end - end. - -tftpd_worker() -> - [{doc, "Makes sure the tftp sub tree is correct."}]. -tftpd_worker(Config) when is_list(Config) -> - [] = supervisor:which_children(tftp_sup), - {ok, Pid0} = inets:start(tftpd, [{host, inets_test_lib:hostname()}, - {port, 0}]), - {ok, _Pid1} = inets:start(tftpd, [{host, inets_test_lib:hostname()}, - {port, 0}], stand_alone), - - [{_,Pid0, worker, _}] = supervisor:which_children(tftp_sup), - inets:stop(tftpd, Pid0), - ct:sleep(5000), - [] = supervisor:which_children(tftp_sup), ok. httpd_config() -> diff --git a/lib/inets/test/uri_SUITE.erl b/lib/inets/test/uri_SUITE.erl index f973296af6..8e00e6f565 100644 --- a/lib/inets/test/uri_SUITE.erl +++ b/lib/inets/test/uri_SUITE.erl @@ -52,6 +52,7 @@ all() -> escaped, hexed_query, scheme_validation, + scheme_validation_bin, encode_decode ]. @@ -273,6 +274,26 @@ scheme_validation(Config) when is_list(Config) -> http_uri:parse("https://localhost#fragment", [{scheme_validation_fun, none}]). +scheme_validation_bin(Config) when is_list(Config) -> + {ok, {http,<<>>,<<"localhost">>,80,<<"/">>,<<>>}} = + http_uri:parse(<<"http://localhost#fragment">>), + + ValidationFun = + fun(<<"http">>) -> valid; + (_) -> {error, bad_scheme} + end, + + {ok, {http,<<>>,<<"localhost">>,80,<<"/">>,<<>>}} = + http_uri:parse(<<"http://localhost#fragment">>, + [{scheme_validation_fun, ValidationFun}]), + {error, bad_scheme} = + http_uri:parse(<<"https://localhost#fragment">>, + [{scheme_validation_fun, ValidationFun}]), + %% non-fun scheme_validation_fun works as no option passed + {ok, {https,<<>>,<<"localhost">>,443,<<"/">>,<<>>}} = + http_uri:parse(<<"https://localhost#fragment">>, + [{scheme_validation_fun, none}]). + encode_decode(Config) when is_list(Config) -> ?assertEqual("foo%20bar", http_uri:encode("foo bar")), ?assertEqual(<<"foo%20bar">>, http_uri:encode(<<"foo bar">>)), diff --git a/lib/inets/vsn.mk b/lib/inets/vsn.mk index 1fad9afe33..3a489357ff 100644 --- a/lib/inets/vsn.mk +++ b/lib/inets/vsn.mk @@ -19,6 +19,6 @@ # %CopyrightEnd% APPLICATION = inets -INETS_VSN = 6.5 +INETS_VSN = 6.5.1 PRE_VSN = APP_VSN = "$(APPLICATION)-$(INETS_VSN)$(PRE_VSN)" diff --git a/lib/jinterface/java_src/pom.xml.src b/lib/jinterface/java_src/pom.xml.src index 98232db78c..584bd81076 100644 --- a/lib/jinterface/java_src/pom.xml.src +++ b/lib/jinterface/java_src/pom.xml.src @@ -76,6 +76,17 @@ </plugin> <plugin> <groupId>org.apache.maven.plugins</groupId> + <artifactId>maven-jar-plugin</artifactId> + <configuration> + <archive> + <manifestEntries> + <Automatic-Module-Name>com.ericsson.otp.erlang</Automatic-Module-Name> + </manifestEntries> + </archive> + </configuration> + </plugin> + <plugin> + <groupId>org.apache.maven.plugins</groupId> <artifactId>maven-javadoc-plugin</artifactId> <version>2.10.3</version> <executions> diff --git a/lib/jinterface/test/nc_SUITE.erl b/lib/jinterface/test/nc_SUITE.erl index 81944f71d4..daa17195ee 100644 --- a/lib/jinterface/test/nc_SUITE.erl +++ b/lib/jinterface/test/nc_SUITE.erl @@ -651,11 +651,10 @@ do_echo(DataList, Config, OutTrans, InTrans, ExtraArgs) echo_loop([D|Ds], Echoer, OutTrans, InTrans, TermAcc) -> OutMsg = OutTrans(D), Echoer ! OutMsg, - io:format("echo_server ~p: ~p ! ~P~n", [self(),Echoer,OutMsg,10]), + %%io:format("echo_server ~p: ~p ! ~P~n", [self(),Echoer,OutMsg,10]), receive Reply -> - io:format("echo_server ~p: receive ~P~n", - [self(),Reply,10]), + %%io:format("echo_server ~p: receive ~P~n", [self(),Reply,10]), InTrans(Echoer, D, Reply) end, Term = case OutMsg of @@ -670,11 +669,10 @@ echo_loop(Cont, Echoer, OutTrans, InTrans, TermAcc) when is_function(Cont, 0) -> check_terms(Echoer, TermAcc), OutMsg = Echoer ! {self(),undefined,hash_clear}, - io:format("echo_server ~p: ~p ! ~P~n", [self(),Echoer,OutMsg,10]), + %%io:format("echo_server ~p: ~p ! ~P~n", [self(),Echoer,OutMsg,10]), receive {Echoer,hash_cleared,hash_clear}=Reply -> - io:format("echo_server ~p: receive ~P~n", - [self(),Reply,10]), + %%io:format("echo_server ~p: receive ~P~n", [self(),Reply,10]), ok; Other -> io:format("echo_server_terms unexpected ~p: receive ~P~n", @@ -686,11 +684,10 @@ echo_loop(Cont, Echoer, OutTrans, InTrans, TermAcc) check_terms(Echoer, [Term | Rest]) -> OutMsg = {self(),Term,hash_lookup}, Echoer ! OutMsg, - io:format("check_terms ~p: ~p ! ~P~n", [self(),Echoer,OutMsg,10]), + %%io:format("check_terms ~p: ~p ! ~P~n", [self(),Echoer,OutMsg,10]), receive {Echoer,true,hash_lookup} = ReplyMsg -> - io:format("check_terms ~p: receive ~P~n", - [self(),ReplyMsg,10]), + %%io:format("check_terms ~p: receive ~P~n", [self(),ReplyMsg,10]), check_terms(Echoer, Rest); Other -> io:format("check_terms unexpected ~p: receive ~P~n", diff --git a/lib/kernel/doc/src/Makefile b/lib/kernel/doc/src/Makefile index 0759f362d4..2413541082 100644 --- a/lib/kernel/doc/src/Makefile +++ b/lib/kernel/doc/src/Makefile @@ -137,16 +137,16 @@ clean clean_docs: rm -f errs core *~ $(SPECDIR)/specs_erl_prim_loader_stub.xml: - escript $(SPECS_EXTRACTOR) $(SPECS_FLAGS) \ + $(gen_verbose)escript $(SPECS_EXTRACTOR) $(SPECS_FLAGS) \ -o$(dir $@) -module erl_prim_loader_stub $(SPECDIR)/specs_erlang_stub.xml: - escript $(SPECS_EXTRACTOR) $(SPECS_FLAGS) \ + $(gen_verbose)escript $(SPECS_EXTRACTOR) $(SPECS_FLAGS) \ -o$(dir $@) -module erlang_stub $(SPECDIR)/specs_init_stub.xml: - escript $(SPECS_EXTRACTOR) $(SPECS_FLAGS) \ + $(gen_verbose)escript $(SPECS_EXTRACTOR) $(SPECS_FLAGS) \ -o$(dir $@) -module init_stub $(SPECDIR)/specs_zlib_stub.xml: - escript $(SPECS_EXTRACTOR) $(SPECS_FLAGS) \ + $(gen_verbose)escript $(SPECS_EXTRACTOR) $(SPECS_FLAGS) \ -o$(dir $@) -module zlib_stub # ---------------------------------------------------- diff --git a/lib/kernel/doc/src/code.xml b/lib/kernel/doc/src/code.xml index c94f612c01..bd95819636 100644 --- a/lib/kernel/doc/src/code.xml +++ b/lib/kernel/doc/src/code.xml @@ -34,26 +34,28 @@ <p>This module contains the interface to the Erlang <em>code server</em>, which deals with the loading of compiled code into a running Erlang runtime system.</p> - <p>The runtime system can be started in <em>embedded</em> or - <em>interactive</em> mode. Which one is decided by command-line + <p>The runtime system can be started in <em>interactive</em> or + <em>embedded</em> mode. Which one is decided by the command-line flag <c>-mode</c>:</p> <pre> % <input>erl -mode interactive</input></pre> <p>The modes are as follows:</p> <list type="bulleted"> <item> - <p>In embedded mode, all code is loaded during system startup - according to the boot script. (Code can also be loaded later - by explicitly ordering the code server to do so).</p> - </item> - <item> <p>In interactive mode, which is default, only some code is loaded - during system startup, basically the modules needed by the runtime + during system startup, basically the modules needed by the runtime system. Other code is dynamically loaded when first referenced. When a call to a function in a certain module is made, and the module is not loaded, the code server searches for and tries to load the module.</p> </item> + <item> + <p>In embedded mode, modules are not auto loaded. Trying to use + a module that has not been loaded results in an error. This mode is + recommended when the boot script loads all modules, as it is + typically done in OTP releases. (Code can still be loaded later + by explicitly ordering the code server to do so).</p> + </item> </list> <p>To prevent accidentally reloading of modules affecting the Erlang runtime system, directories <c>kernel</c>, <c>stdlib</c>, diff --git a/lib/kernel/doc/src/file.xml b/lib/kernel/doc/src/file.xml index b674b3ca93..1b72769ce3 100644 --- a/lib/kernel/doc/src/file.xml +++ b/lib/kernel/doc/src/file.xml @@ -33,15 +33,18 @@ <description> <p>This module provides an interface to the file system.</p> - <p>On operating systems with thread support, - file operations can be performed in threads of their own, allowing - other Erlang processes to continue executing in parallel with - the file operations. See command-line flag - <c>+A</c> in <seealso marker="erts:erl"><c>erl(1)</c></seealso>.</p> + <warning> + <p>File operations are only guaranteed to appear atomic when going + through the same file server. A NIF or other OS process may observe + intermediate steps on certain operations on some operating systems, + eg. renaming an existing file on Windows, or + <seealso marker="#write_file_info/2"><c>write_file_info/2</c> + </seealso> on any OS at the time of writing.</p> + </warning> <p>Regarding filename encoding, the Erlang VM can operate in two modes. The current mode can be queried using function - <seealso marker="#native_name_encoding"><c>native_name_encoding/0</c></seealso>. + <seealso marker="#native_name_encoding/0"><c>native_name_encoding/0</c></seealso>. It returns <c>latin1</c> or <c>utf8</c>.</p> <p>In <c>latin1</c> mode, the Erlang VM does not change the @@ -59,7 +62,7 @@ terminal supports UTF-8, otherwise <c>latin1</c>. The default can be overridden using <c>+fnl</c> (to force <c>latin1</c> mode) or <c>+fnu</c> (to force <c>utf8</c> mode) when starting - <seealso marker="erts:erl"><c>erts:erl</c></seealso>.</p> + <seealso marker="erts:erl"><c>erl</c></seealso>.</p> <p>On operating systems with transparent naming, files can be inconsistently named, for example, some files are encoded in UTF-8 while @@ -81,6 +84,16 @@ <p>See also section <seealso marker="stdlib:unicode_usage#notes-about-raw-filenames">Notes About Raw Filenames</seealso> in the STDLIB User's Guide.</p> + <note><p> + File operations used to accept filenames containing + null characters (integer value zero). This caused + the name to be truncated and in some cases arguments + to primitive operations to be mixed up. Filenames + containing null characters inside the filename + are now <em>rejected</em> and will cause primitive + file operations fail. + </p></note> + </description> <datatypes> @@ -96,9 +109,21 @@ </datatype> <datatype> <name name="filename"/> + <desc> + <p> + See also the documentation of the + <seealso marker="#type-name_all"><c>name_all()</c></seealso> type. + </p> + </desc> </datatype> <datatype> <name name="filename_all"/> + <desc> + <p> + See also the documentation of the + <seealso marker="#type-name_all"><c>name_all()</c></seealso> type. + </p> + </desc> </datatype> <datatype> <name name="io_device"/> @@ -112,21 +137,23 @@ <name name="name"/> <desc> <p>If VM is in Unicode filename mode, <c>string()</c> and <c>char()</c> - are allowed to be > 255. + are allowed to be > 255. See also the documentation of the + <seealso marker="#type-name_all"><c>name_all()</c></seealso> type. </p> </desc> </datatype> <datatype> <name name="name_all"/> <desc> - <p>If VM is in Unicode filename mode, <c>string()</c> and <c>char()</c> + <p>If VM is in Unicode filename mode, characters are allowed to be > 255. <c><anno>RawFilename</anno></c> is a filename not subject to Unicode translation, meaning that it can contain characters not conforming to the Unicode encoding expected from the file system (that is, non-UTF-8 characters although the VM is started - in Unicode filename mode). + in Unicode filename mode). Null characters (integer value zero) + are <em>not</em> allowed in filenames (not even at the end). </p> </desc> </datatype> @@ -954,8 +981,7 @@ f.txt: {person, "kalle", 25}. </item> <tag><c>eisdir</c></tag> <item> - <p>The named file is not a regular file. It can be a - directory, a FIFO, or a device.</p> + <p>The named file is a directory.</p> </item> <tag><c>enotdir</c></tag> <item> @@ -1407,8 +1433,12 @@ f.txt: {person, "kalle", 25}. which is 1970-01-01 00:00 UTC.</p></item> </taglist> <p>Default is <c>{time, local}</c>.</p> - <p>If the option <c>raw</c> is set, the file server is not called - and only information about local files is returned.</p> + <p>If the option <c>raw</c> is set, the file server is not called and + only information about local files is returned. Note that this will + break this module's atomicity guarantees as it can race with a + concurrent call to + <seealso marker="#write_file_info/2"><c>write_file_info/1,2</c> + </seealso></p> <note> <p>As file times are stored in POSIX time on most OS, it is faster to query file information with option <c>posix</c>.</p> @@ -1656,8 +1686,12 @@ f.txt: {person, "kalle", 25}. except that if <c><anno>Name</anno></c> is a symbolic link, information about the link is returned in the <c>file_info</c> record and the <c>type</c> field of the record is set to <c>symlink</c>.</p> - <p>If the option <c>raw</c> is set, the file server is not called - and only information about local files is returned.</p> + <p>If the option <c>raw</c> is set, the file server is not called and + only information about local files is returned. Note that this will + break this module's atomicity guarantees as it can race with a + concurrent call to + <seealso marker="#write_file_info/2"><c>write_file_info/1,2</c> + </seealso></p> <p>If <c><anno>Name</anno></c> is not a symbolic link, this function returns the same result as <c>read_file_info/1</c>. On platforms that do not support symbolic links, this function @@ -1795,24 +1829,16 @@ f.txt: {person, "kalle", 25}. <p>The file used must be opened using the <c>raw</c> flag, and the process calling <c>sendfile</c> must be the controlling process of the socket. See <seealso marker="gen_tcp#controlling_process-2"><c>gen_tcp:controlling_process/2</c></seealso>.</p> - <p>If the OS used does not support <c>sendfile</c>, an Erlang fallback - using - <seealso marker="#read/2"><c>read/2</c></seealso> and - <seealso marker="gen_tcp#send/2"><c>gen_tcp:send/2</c></seealso> is used.</p> + <p>If the OS used does not support non-blocking <c>sendfile</c>, an + Erlang fallback using <seealso marker="#read/2"><c>read/2</c></seealso> + and <seealso marker="gen_tcp#send/2"><c>gen_tcp:send/2</c></seealso> is + used.</p> <p>The option list can contain the following options:</p> <taglist> <tag><c>chunk_size</c></tag> <item><p>The chunk size used by the Erlang fallback to send data. If using the fallback, set this to a value that comfortably fits in the systems memory. Default is 20 MB.</p></item> - <tag><c>use_threads</c></tag> - <item><p>Instructs the emulator to use the <c>async</c> thread pool for the - <c>sendfile</c> system call. This can be useful if the OS you are running - on does not properly support non-blocking <c>sendfile</c> calls. Notice that - using <c>async</c> threads potentially makes your system vulnerable to slow - client attacks. If set to <c>true</c> and no <c>async</c> threads are available, - the <c>sendfile</c> call returns <c>{error,einval}</c>. - Introduced in Erlang/OTP 17.0. Default is <c>false</c>.</p></item> </taglist> </desc> </func> @@ -1825,7 +1851,7 @@ f.txt: {person, "kalle", 25}. <p>The functions in the module <c>file</c> usually treat binaries as raw filenames, that is, they are passed "as is" even when the encoding of the binary does not agree with - <seealso marker="#native_name_encoding"><c>native_name_encoding()</c></seealso>. + <seealso marker="#native_name_encoding/0"><c>native_name_encoding()</c></seealso>. However, this function expects binaries to be encoded according to the value returned by <c>native_name_encoding()</c>.</p> <p>Typical error reasons are:</p> @@ -2117,144 +2143,77 @@ f.txt: {person, "kalle", 25}. <section> <title>Performance</title> - <p>Some operating system file operations, for example, a - <c>sync/1</c> or <c>close/1</c> on a huge file, can block their - calling thread for seconds. If this affects the emulator main - thread, the response time is no longer in the order of - milliseconds, depending on the definition of "soft" in soft - real-time system.</p> - <p>If the device driver thread pool is active, file operations are - done through those threads instead, so the emulator can go on - executing Erlang processes. Unfortunately, the time for serving a - file operation increases because of the extra scheduling required - from the operating system.</p> - <p>If the device driver thread pool is disabled or of size 0, large - file reads and writes are segmented into many smaller, which - enable the emulator to serve other processes during the file - operation. This has the same effect as when using the thread - pool, but with larger overhead. Other file operations, for - example, <c>sync/1</c> or <c>close/1</c> on a huge file, still are - a problem.</p> - <p>For increased performance, raw files are recommended. Raw files - use the file system of the host machine of the node.</p> + <p>For increased performance, raw files are recommended.</p> + <p>A normal file is really a process so it can be used as an I/O + device (see <seealso marker="stdlib:io"><c>io</c></seealso>). + Therefore, when data is written to a normal file, the sending of the + data to the file process, copies all data that are not binaries. Opening + the file in binary mode and writing binaries is therefore recommended. + If the file is opened on another node, or if the file server runs as + slave to the file server of another node, also binaries are copied.</p> <note> - <p> - For normal files (non-raw), the file server is used to find the files, - and if the node is running its file server as slave to the file server - of another node, and the other node runs on some other host machine, - they can have different file systems. - However, this is seldom a problem.</p> + <p>Raw files use the file system of the host machine of the node. + For normal files (non-raw), the file server is used to find the files, + and if the node is running its file server as slave to the file server + of another node, and the other node runs on some other host machine, + they can have different file systems. + However, this is seldom a problem.</p> </note> - <p>A normal file is really a process so it can be used as an I/O - device (see - <seealso marker="stdlib:io"><c>io</c></seealso>). - Therefore, when data is written to a - normal file, the sending of the data to the file process, copies - all data that are not binaries. Opening the file in binary mode - and writing binaries is therefore recommended. If the file is - opened on another node, or if the file server runs as slave to - the file server of another node, also binaries are copied.</p> - <p>Caching data to reduce the number of file operations, or rather - the number of calls to the file driver, generally increases - performance. The following function writes 4 MBytes in 23 - seconds when tested:</p> + <p><seealso marker="#open/2"><c>open/2</c></seealso> can be given the + options <c>delayed_write</c> and <c>read_ahead</c> to turn on caching, + which will reduce the number of operating system calls and greatly + improve performance for small reads and writes. However, the overhead + won't disappear completely and it's best to keep the number of file + operations to a minimum. As a contrived example, the following function + writes 4MB in 2.5 seconds when tested:</p> + <code type="none"><![CDATA[ -create_file_slow(Name, N) when integer(N), N >= 0 -> - {ok, FD} = file:open(Name, [raw, write, delayed_write, binary]), - ok = create_file_slow(FD, 0, N), - ok = ?FILE_MODULE:close(FD), - ok. - -create_file_slow(FD, M, M) -> +create_file_slow(Name) -> + {ok, Fd} = file:open(Name, [raw, write, delayed_write, binary]), + create_file_slow_1(Fd, 4 bsl 20), + file:close(Fd). + +create_file_slow_1(_Fd, 0) -> ok; -create_file_slow(FD, M, N) -> - ok = file:write(FD, <<M:32/unsigned>>), - create_file_slow(FD, M+1, N).]]></code> +create_file_slow_1(Fd, M) -> + ok = file:write(Fd, <<0>>), + create_file_slow_1(Fd, M - 1).]]></code> + + <p>The following functionally equivalent code writes 128 bytes per call + to <seealso marker="#write/2"><c>write/2</c></seealso> and so does the + same work in 0.08 seconds, which is roughly 30 times faster:</p> - <p>The following, functionally equivalent, function collects 1024 - entries into a list of 128 32-byte binaries before each call to - <seealso marker="#write/2"><c>write/2</c></seealso> and so - does the same work in 0.52 seconds, - which is 44 times faster:</p> <code type="none"><![CDATA[ -create_file(Name, N) when integer(N), N >= 0 -> - {ok, FD} = file:open(Name, [raw, write, delayed_write, binary]), - ok = create_file(FD, 0, N), - ok = ?FILE_MODULE:close(FD), +create_file(Name) -> + {ok, Fd} = file:open(Name, [raw, write, delayed_write, binary]), + create_file_1(Fd, 4 bsl 20), + file:close(Fd), ok. - -create_file(FD, M, M) -> + +create_file_1(_Fd, 0) -> ok; -create_file(FD, M, N) when M + 1024 =< N -> - create_file(FD, M, M + 1024, []), - create_file(FD, M + 1024, N); -create_file(FD, M, N) -> - create_file(FD, M, N, []). - -create_file(FD, M, M, R) -> - ok = file:write(FD, R); -create_file(FD, M, N0, R) when M + 8 =< N0 -> - N1 = N0-1, N2 = N0-2, N3 = N0-3, N4 = N0-4, - N5 = N0-5, N6 = N0-6, N7 = N0-7, N8 = N0-8, - create_file(FD, M, N8, - [<<N8:32/unsigned, N7:32/unsigned, - N6:32/unsigned, N5:32/unsigned, - N4:32/unsigned, N3:32/unsigned, - N2:32/unsigned, N1:32/unsigned>> | R]); -create_file(FD, M, N0, R) -> - N1 = N0-1, - create_file(FD, M, N1, [<<N1:32/unsigned>> | R]).]]></code> +create_file_1(Fd, M) when M >= 128 -> + ok = file:write(Fd, <<0:(128)/unit:8>>), + create_file_1(Fd, M - 128); +create_file_1(Fd, M) -> + ok = file:write(Fd, <<0:(M)/unit:8>>), + create_file_1(Fd, M - 1).]]></code> - <note> - <p>Trust only your own benchmarks. If the list length in - <c>create_file/2</c> above is increased, it runs slightly - faster, but consumes more memory and causes more memory - fragmentation. How much this affects your application is - something that this simple benchmark cannot predict.</p> - <p>If the size of each binary is increased to 64 bytes, it - also runs slightly faster, but the code is then twice as clumsy. - In the current implementation, binaries larger than 64 bytes are - stored in memory common to all processes and not copied when - sent between processes, while these smaller binaries are stored - on the process heap and copied when sent like any other term.</p> - <p>So, with a binary size of 68 bytes, <c>create_file/2</c> runs - 30 percent slower than with 64 bytes, and causes much more - memory fragmentation. Notice that if the binaries were to be sent - between processes (for example, a non-raw file), the results - would probably be completely different.</p> - </note> - <p>A raw file is really a port. When writing data to a port, it is - efficient to write a list of binaries. It is not needed to - flatten a deep list before writing. On Unix hosts, scatter output, - which writes a set of buffers in one operation, is used when - possible. In this way <c>write(FD, [Bin1, Bin2 | Bin3])</c> - writes the contents of the binaries without copying the data - at all, except for perhaps deep down in the operating system - kernel.</p> - <p>For raw files, <c>pwrite/2</c> and <c>pread/2</c> are - efficiently implemented. The file driver is called only once for - the whole operation, and the list iteration is done in the file - driver.</p> - <p>The options <c>delayed_write</c> and <c>read_ahead</c> to - <seealso marker="#open/2"><c>open/2</c></seealso> - make the file driver cache data to reduce - the number of operating system calls. The function - <c>create_file/2</c> in the recent example takes 60 seconds - without option <c>delayed_write</c>, which is 2.6 - times slower.</p> - <p>As a bad example, <c>create_file_slow/2</c> - without options <c>raw</c>, <c>binary</c>, and <c>delayed_write</c>, - meaning it calls <c>open(Name, [write])</c>, needs - 1 min 20 seconds for the job, which is 3.5 times slower than - the first example, and 150 times slower than the optimized - <c>create_file/2</c>.</p> - <warning> - <p>If an error occurs when accessing an open file with module - <seealso marker="stdlib:io"><c>io</c></seealso>, - the process handling the file exits. The dead - file process can hang if a process tries to access it later. - This will be fixed in a future release.</p> - </warning> + <p>When writing data it's generally more efficient to write a list of + binaries rather than a list of integers. It is not needed to + flatten a deep list before writing. On Unix hosts, scatter output, + which writes a set of buffers in one operation, is used when + possible. In this way <c>write(FD, [Bin1, Bin2 | Bin3])</c> + writes the contents of the binaries without copying the data + at all, except for perhaps deep down in the operating system + kernel.</p> + <warning> + <p>If an error occurs when accessing an open file with module + <seealso marker="stdlib:io"><c>io</c></seealso>, the process + handling the file exits. The dead file process can hang if a process + tries to access it later. This will be fixed in a future release. + </p> + </warning> </section> <section> diff --git a/lib/kernel/doc/src/heart.xml b/lib/kernel/doc/src/heart.xml index 5b5b71e521..46c7ce60b6 100644 --- a/lib/kernel/doc/src/heart.xml +++ b/lib/kernel/doc/src/heart.xml @@ -59,8 +59,9 @@ <pre> % <input>erl -heart -env HEART_BEAT_TIMEOUT 30 ...</input></pre> <p>The value (in seconds) must be in the range 10 < X <= 65535.</p> - <p>Notice that if the system clock is adjusted with - more than <c>HEART_BEAT_TIMEOUT</c> seconds, <c>heart</c> + <p>When running on OSs lacking support for monotonic time, + <c>heart</c> is susceptible to system clock adjustments of more than + <c>HEART_BEAT_TIMEOUT</c> seconds. When this happens, <c>heart</c> times out and tries to reboot the system. This can occur, for example, if the system clock is adjusted automatically by use of the Network Time Protocol (NTP).</p> diff --git a/lib/kernel/doc/src/inet.xml b/lib/kernel/doc/src/inet.xml index 169a76463b..9552332948 100644 --- a/lib/kernel/doc/src/inet.xml +++ b/lib/kernel/doc/src/inet.xml @@ -4,7 +4,7 @@ <erlref> <header> <copyright> - <year>1997</year><year>2017</year> + <year>1997</year><year>2018</year> <holder>Ericsson AB. All Rights Reserved.</holder> </copyright> <legalnotice> @@ -197,6 +197,9 @@ fe80::204:acff:fe17:bf38 <datatype> <name name="address_family"/> </datatype> + <datatype> + <name name="socket_protocol"/> + </datatype> </datatypes> <funcs> @@ -274,9 +277,7 @@ fe80::204:acff:fe17:bf38 <p>Returns a <c>hostent</c> record for the host with the specified hostname.</p> <p>If resolver option <c>inet6</c> is <c>true</c>, - an IPv6 address is looked up. If that fails, - the IPv4 address is looked up and returned on - IPv6-mapped IPv4 format.</p> + an IPv6 address is looked up.</p> </desc> </func> @@ -461,6 +462,61 @@ get_tcpi_sacked(Sock) -> </func> <func> + <name name="i" arity="0" /> + <name name="i" arity="1" /> + <name name="i" arity="2" /> + <fsummary>Displays information and statistics about sockets on the terminal</fsummary> + <desc> + <p> + Lists all TCP, UDP and SCTP sockets, including those that the Erlang runtime system uses as well as + those created by the application. + </p> + <p> + The following options are available: + </p> + + <taglist> + <tag><c>port</c></tag> + <item> + <p>The internal index of the port.</p> + </item> + <tag><c>module</c></tag> + <item> + <p>The callback module of the socket.</p> + </item> + <tag><c>recv</c></tag> + <item> + <p>Number of bytes received by the socket.</p> + </item> + <tag><c>sent</c></tag> + <item> + <p>Number of bytes sent from the socket.</p> + </item> + <tag><c>owner</c></tag> + <item> + <p>The socket owner process.</p> + </item> + <tag><c>local_address</c></tag> + <item> + <p>The local address of the socket.</p> + </item> + <tag><c>foreign_address</c></tag> + <item> + <p>The address and port of the other end of the connection.</p> + </item> + <tag><c>state</c></tag> + <item> + <p>The connection state.</p> + </item> + <tag><c>type</c></tag> + <item> + <p>STREAM or DGRAM or SEQPACKET.</p> + </item> + </taglist> + </desc> + </func> + + <func> <name name="ntoa" arity="1" /> <fsummary>Convert IPv6/IPV4 address to ASCII.</fsummary> <desc> @@ -524,6 +580,19 @@ get_tcpi_sacked(Sock) -> </func> <func> + <name name="ipv4_mapped_ipv6_address" arity="1" /> + <fsummary>Convert to and from IPv4-mapped IPv6 address.</fsummary> + <desc> + <p> + Convert an IPv4 address to an IPv4-mapped IPv6 address + or the reverse. When converting from an IPv6 address + all but the 2 low words are ignored so this function also + works on some other types of addresses than IPv4-mapped. + </p> + </desc> + </func> + + <func> <name name="parse_strict_address" arity="1" /> <fsummary>Parse an IPv4 or IPv6 address strict.</fsummary> <desc> @@ -1214,7 +1283,7 @@ inet:setopts(Sock,[{raw,6,8,<<30:32/native>>}]),]]></code> For one-to-many style sockets, the special value <c>0</c> is defined to mean that the returned addresses must be without any particular association. - How different SCTP implementations interprets this varies somewhat. + How different SCTP implementations interpret this varies somewhat. </p> </desc> </func> diff --git a/lib/kernel/doc/src/inet_res.xml b/lib/kernel/doc/src/inet_res.xml index 4ada4203c0..351d86a93a 100644 --- a/lib/kernel/doc/src/inet_res.xml +++ b/lib/kernel/doc/src/inet_res.xml @@ -4,7 +4,7 @@ <erlref> <header> <copyright> - <year>2009</year><year>2015</year> + <year>2009</year><year>2018</year> <holder>Ericsson AB. All Rights Reserved.</holder> </copyright> <legalnotice> @@ -130,7 +130,7 @@ dns_header() = DnsHeader inet_dns:header(DnsHeader) -> [ {id, integer()} | {qr, boolean()} - | {opcode, 'query' | iquery | status | integer()} + | {opcode, query | iquery | status | integer()} | {aa, boolean()} | {tc, boolean()} | {rd, boolean()} @@ -230,9 +230,7 @@ inet_dns:record_type(_) -> undefined.</pre> <seealso marker="#getbyname/2"><c>getbyname/2,3</c></seealso>. </p> <p>If resolver option <c>inet6</c> is <c>true</c>, - an IPv6 address is looked up. If that fails, - the IPv4 address is looked up and returned on - IPv6-mapped IPv4 format.</p> + an IPv6 address is looked up.</p> </desc> </func> diff --git a/lib/kernel/doc/src/net_kernel.xml b/lib/kernel/doc/src/net_kernel.xml index 0b94fc0fa6..a30d28d55a 100644 --- a/lib/kernel/doc/src/net_kernel.xml +++ b/lib/kernel/doc/src/net_kernel.xml @@ -56,7 +56,7 @@ $ <input>erl -sname foobar</input></pre> <p>Normally, connections are established automatically when another node is referenced. This functionality can be disabled by setting Kernel configuration parameter - <c>dist_auto_connect</c> to <c>false</c>, see + <c>dist_auto_connect</c> to <c>never</c>, see <seealso marker="kernel_app"><c>kernel(6)</c></seealso>. In this case, connections must be established explicitly by calling <seealso marker="#connect_node/1"><c>connect_node/1</c></seealso>.</p> @@ -230,7 +230,12 @@ $ <input>erl -sname foobar</input></pre> <item> <p>The tuple <c>{nodedown_reason, Reason}</c> is included in <c>InfoList</c> in <c>nodedown</c> messages.</p> - <p><c>Reason</c> can be any of the following:</p> + <p> + <c>Reason</c> can, depending on which + distribution module or process that is used be any term, + but for the standard TCP distribution module it is + any of the following: + </p> <taglist> <tag><c>connection_setup_failed</c></tag> <item><p>The connection setup failed (after <c>nodeup</c> diff --git a/lib/kernel/doc/src/os.xml b/lib/kernel/doc/src/os.xml index 7ce2f54542..ef416ed233 100644 --- a/lib/kernel/doc/src/os.xml +++ b/lib/kernel/doc/src/os.xml @@ -36,11 +36,85 @@ only run on a specific platform. On the other hand, with careful use, these functions can be of help in enabling a program to run on most platforms.</p> + + <note> + <p> + File operations used to accept filenames containing + null characters (integer value zero). This caused + the name to be truncated and in some cases arguments + to primitive operations to be mixed up. Filenames + containing null characters inside the filename + are now <em>rejected</em> and will cause primitive + file operations to fail. + </p> + <p> + Also environment variable operations used to accept + names and values of environment variables containing + null characters (integer value zero). This caused + operations to silently produce erroneous results. + Environment variable names and values containing + null characters inside the name or value are now + <em>rejected</em> and will cause environment variable + operations to fail. + </p> + </note> </description> <datatypes> <datatype> + <name name="env_var_name"/> + <desc> + <p>A string containing valid characters on the specific + OS for environment variable names using + <seealso marker="file#native_name_encoding/0"><c>file:native_name_encoding()</c></seealso> + encoding. Note that specifically null characters (integer + value zero) and <c>$=</c> characters are not allowed. + However, note that not all invalid characters necessarily + will cause the primitiv operations to fail, but may instead + produce invalid results. + </p> + </desc> + </datatype> + <datatype> + <name name="env_var_value"/> + <desc> + <p>A string containing valid characters on the specific + OS for environment variable values using + <seealso marker="file#native_name_encoding/0"><c>file:native_name_encoding()</c></seealso> + encoding. Note that specifically null characters (integer + value zero) are not allowed. However, note that not all + invalid characters necessarily will cause the primitiv + operations to fail, but may instead produce invalid results. + </p> + </desc> + </datatype> + <datatype> + <name name="env_var_name_value"/> + <desc> + <p> + Assuming that environment variables has been correctly + set, a strings containing valid characters on the specific + OS for environment variable names and values using + <seealso marker="file#native_name_encoding/0"><c>file:native_name_encoding()</c></seealso> + encoding. The first <c>$=</c> characters appearing in + the string separates environment variable name (on the + left) from environment variable value (on the right). + </p> + </desc> + </datatype> + <datatype> <name name="os_command"/> + <desc> + <p>All characters needs to be valid characters on the + specific OS using + <seealso marker="file#native_name_encoding/0"><c>file:native_name_encoding()</c></seealso> + encoding. Note that specifically null characters (integer + value zero) are not allowed. However, note that not all + invalid characters not necessarily will cause + <seealso marker="#cmd/1"><c>os:cmd/1</c></seealso> + to fail, but may instead produce invalid results. + </p> + </desc> </datatype> <datatype> <name name="os_command_opts"/> @@ -65,8 +139,13 @@ <fsummary>Execute a command in a shell of the target OS.</fsummary> <desc> <p>Executes <c><anno>Command</anno></c> in a command shell of the - target OS, captures the standard output of the command, + target OS, captures the standard output of the command, and returns this result as a string.</p> + <warning><p>Previous implementation used to allow all characters + as long as they were integer values greater than or equal to zero. + This sometimes lead to unwanted results since null characters + (integer value zero) often are interpreted as string termination. The + current implementation rejects these.</p></warning> <p><em>Examples:</em></p> <code type="none"> LsOut = os:cmd("ls"), % on unix platform @@ -185,6 +264,15 @@ DirOut = os:cmd("dir"), % on Win32 platform</code> <p>On Unix platforms, the environment is set using UTF-8 encoding if Unicode filename translation is in effect. On Windows, the environment is set using wide character interfaces.</p> + <note> + <p> + <c><anno>VarName</anno></c> is not allowed to contain + an <c>$=</c> character. Previous implementations used + to just let the <c>$=</c> character through which + silently caused erroneous results. Current implementation + will instead throw a <c>badarg</c> exception. + </p> + </note> </desc> </func> diff --git a/lib/kernel/doc/src/rpc.xml b/lib/kernel/doc/src/rpc.xml index adec2d9520..fab616e630 100644 --- a/lib/kernel/doc/src/rpc.xml +++ b/lib/kernel/doc/src/rpc.xml @@ -4,7 +4,7 @@ <erlref> <header> <copyright> - <year>1996</year><year>2016</year> + <year>1996</year><year>2018</year> <holder>Ericsson AB. All Rights Reserved.</holder> </copyright> <legalnotice> @@ -217,7 +217,7 @@ <list type="bulleted"> <item>A list of the nodes that do not exist</item> <item>A list of the nodes where the server does not exist</item> - <item>A list of the nodes where the server terminatd before sending + <item>A list of the nodes where the server terminated before sending any reply.</item> </list> </desc> @@ -268,8 +268,9 @@ on the specified nodes and collects the answers. It returns <c>{<anno>ResL</anno>, <anno>BadNodes</anno>}</c>, where <c><anno>BadNodes</anno></c> is a list - of the nodes that terminated or timed out during computation, - and <c><anno>ResL</anno></c> is a list of the return values. + of the nodes that do not exist, + and <c><anno>ResL</anno></c> is a list of the return values, + or <c>{badrpc, <anno>Reason</anno>}</c> for failing calls. <c><anno>Timeout</anno></c> is a time (integer) in milliseconds, or <c>infinity</c>.</p> <p>The following example is useful when new object code is to @@ -347,7 +348,7 @@ <func> <name name="pmap" arity="3"/> - <fsummary>Parallell evaluation of mapping a function over a + <fsummary>Parallel evaluation of mapping a function over a list.</fsummary> <desc> <p>Evaluates <c>apply(<anno>Module</anno>, <anno>Function</anno>, diff --git a/lib/kernel/doc/src/seq_trace.xml b/lib/kernel/doc/src/seq_trace.xml index 197851021f..69eb12a8a0 100644 --- a/lib/kernel/doc/src/seq_trace.xml +++ b/lib/kernel/doc/src/seq_trace.xml @@ -80,13 +80,18 @@ seq_trace:set_token(OldToken), % activate the trace token again <p>Sets the individual <c><anno>Component</anno></c> of the trace token to <c><anno>Val</anno></c>. Returns the previous value of the component.</p> <taglist> - <tag><c>set_token(label, <anno>Integer</anno>)</c></tag> + <tag><c>set_token(label, <anno>Label</anno>)</c></tag> <item> - <p>The <c>label</c> component is an integer which + <p>The <c>label</c> component is a term which identifies all events belonging to the same sequential trace. If several sequential traces can be active simultaneously, <c>label</c> is used to identify the separate traces. Default is 0.</p> + <warning> + <p>Labels were restricted to small signed integers (28 bits) + prior to OTP 21. The trace token will be silenty dropped if it + crosses over to a node that does not support the label.</p> + </warning> </item> <tag><c>set_token(serial, SerialValue)</c></tag> <item> diff --git a/lib/kernel/examples/Makefile b/lib/kernel/examples/Makefile index 26ec58f571..f86e662838 100644 --- a/lib/kernel/examples/Makefile +++ b/lib/kernel/examples/Makefile @@ -45,7 +45,7 @@ RELSYSDIR = $(RELEASE_PATH)/lib/kernel-$(KERNEL_VSN)/examples # Pack and install the complete directory structure from # here (CWD) and down, for all examples. -EXAMPLES = uds_dist +EXAMPLES = uds_dist gen_tcp_dist release_spec: $(INSTALL_DIR) "$(RELSYSDIR)" diff --git a/lib/kernel/examples/gen_tcp_dist/Makefile b/lib/kernel/examples/gen_tcp_dist/Makefile new file mode 100644 index 0000000000..65513a1729 --- /dev/null +++ b/lib/kernel/examples/gen_tcp_dist/Makefile @@ -0,0 +1,20 @@ +RM=rm -f +CP=cp +EBIN=ebin +ERLC=erlc +# Works if building in open source source tree +KERNEL_INCLUDE=$(ERL_TOP)/lib/kernel/include +ERLCFLAGS+= -W -I$(KERNEL_INCLUDE) + +MODULES=gen_tcp_dist + +TARGET_FILES=$(MODULES:%=$(EBIN)/%.beam) + +opt: $(TARGET_FILES) + +$(EBIN)/%.beam: src/%.erl + $(ERLC) $(ERLCFLAGS) -o$(EBIN) $< + +clean: + $(RM) $(TARGET_FILES) + diff --git a/lib/kernel/examples/gen_tcp_dist/ebin/.gitignore b/lib/kernel/examples/gen_tcp_dist/ebin/.gitignore new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/lib/kernel/examples/gen_tcp_dist/ebin/.gitignore diff --git a/lib/kernel/examples/gen_tcp_dist/src/gen_tcp_dist.erl b/lib/kernel/examples/gen_tcp_dist/src/gen_tcp_dist.erl new file mode 100644 index 0000000000..98554ed805 --- /dev/null +++ b/lib/kernel/examples/gen_tcp_dist/src/gen_tcp_dist.erl @@ -0,0 +1,781 @@ +%% +%% %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% +%% +-module(gen_tcp_dist). + +%% +%% This is an example of how to plug in an arbitrary distribution +%% carrier for Erlang using distribution processes. +%% +%% This example uses gen_tcp for transportation of data, but +%% you can use whatever underlying protocol you want as long +%% as your implementation reliably delivers data chunks to the +%% receiving VM in the order they were sent from the sending +%% VM. +%% +%% This code is a rewrite of the lib/kernel/src/inet_tcp_dist.erl +%% distribution impementation for TCP used by default. That +%% implementation use distribution ports instead of distribution +%% processes and is more efficient compared to this implementation. +%% This since this implementation more or less gets the +%% distribution processes in between the VM and the ports without +%% any gain specific gain. +%% + +-export([listen/1, accept/1, accept_connection/5, + setup/5, close/1, select/1, is_node_name/1]). + +%% Optional +-export([setopts/2, getopts/2]). + +%% internal exports + +-export([dist_cntrlr_setup/1, dist_cntrlr_input_setup/3, + dist_cntrlr_tick_handler/1]). + +-export([accept_loop/2,do_accept/6,do_setup/6]). + +-import(error_logger,[error_msg/2]). + +-include("net_address.hrl"). + +-include("dist.hrl"). +-include("dist_util.hrl"). + +%% ------------------------------------------------------------ +%% Select this protocol based on node name +%% select(Node) => Bool +%% ------------------------------------------------------------ + +select(Node) -> + case split_node(atom_to_list(Node), $@, []) of + [_, Host] -> + case inet:getaddr(Host, inet) of + {ok,_} -> true; + _ -> false + end; + _ -> false + end. + +%% ------------------------------------------------------------ +%% Create the listen socket, i.e. the port that this erlang +%% node is accessible through. +%% ------------------------------------------------------------ + +listen(Name) -> + case do_listen([binary, {active, false}, {packet,2}, {reuseaddr, true}]) of + {ok, Socket} -> + TcpAddress = get_tcp_address(Socket), + {_,Port} = TcpAddress#net_address.address, + ErlEpmd = net_kernel:epmd_module(), + case ErlEpmd:register_node(Name, Port) of + {ok, Creation} -> + {ok, {Socket, TcpAddress, Creation}}; + Error -> + Error + end; + Error -> + Error + end. + +do_listen(Options) -> + {First,Last} = case application:get_env(kernel,inet_dist_listen_min) of + {ok,N} when is_integer(N) -> + case application:get_env(kernel, + inet_dist_listen_max) of + {ok,M} when is_integer(M) -> + {N,M}; + _ -> + {N,N} + end; + _ -> + {0,0} + end, + do_listen(First, Last, listen_options([{backlog,128}|Options])). + +do_listen(First,Last,_) when First > Last -> + {error,eaddrinuse}; +do_listen(First,Last,Options) -> + case gen_tcp:listen(First, Options) of + {error, eaddrinuse} -> + do_listen(First+1,Last,Options); + Other -> + Other + end. + +listen_options(Opts0) -> + Opts1 = + case application:get_env(kernel, inet_dist_use_interface) of + {ok, Ip} -> + [{ip, Ip} | Opts0]; + _ -> + Opts0 + end, + case application:get_env(kernel, inet_dist_listen_options) of + {ok,ListenOpts} -> + ListenOpts ++ Opts1; + _ -> + Opts1 + end. + + +%% ------------------------------------------------------------ +%% Accepts new connection attempts from other Erlang nodes. +%% ------------------------------------------------------------ + +accept(Listen) -> + spawn_opt(?MODULE, accept_loop, [self(), Listen], [link, {priority, max}]). + +accept_loop(Kernel, Listen) -> + ?trace("~p~n",[{?MODULE, accept_loop, self()}]), + case gen_tcp:accept(Listen) of + {ok, Socket} -> + DistCtrl = spawn_dist_cntrlr(Socket), + ?trace("~p~n",[{?MODULE, accept_loop, accepted, Socket, DistCtrl, self()}]), + flush_controller(DistCtrl, Socket), + gen_tcp:controlling_process(Socket, DistCtrl), + flush_controller(DistCtrl, Socket), + Kernel ! {accept,self(),DistCtrl,inet,tcp}, + receive + {Kernel, controller, Pid} -> + call_ctrlr(DistCtrl, {supervisor, Pid}), + Pid ! {self(), controller}; + {Kernel, unsupported_protocol} -> + exit(unsupported_protocol) + end, + accept_loop(Kernel, Listen); + Error -> + exit(Error) + end. + +flush_controller(Pid, Socket) -> + receive + {tcp, Socket, Data} -> + Pid ! {tcp, Socket, Data}, + flush_controller(Pid, Socket); + {tcp_closed, Socket} -> + Pid ! {tcp_closed, Socket}, + flush_controller(Pid, Socket) + after 0 -> + ok + end. + +%% ------------------------------------------------------------ +%% Accepts a new connection attempt from another Erlang node. +%% Performs the handshake with the other side. +%% ------------------------------------------------------------ + +accept_connection(AcceptPid, DistCtrl, MyNode, Allowed, SetupTime) -> + spawn_opt(?MODULE, do_accept, + [self(), AcceptPid, DistCtrl, MyNode, Allowed, SetupTime], + [link, {priority, max}]). + +do_accept(Kernel, AcceptPid, DistCtrl, MyNode, Allowed, SetupTime) -> + ?trace("~p~n",[{?MODULE, do_accept, self(), MyNode}]), + receive + {AcceptPid, controller} -> + Timer = dist_util:start_timer(SetupTime), + case check_ip(DistCtrl) of + true -> + HSData0 = hs_data_common(DistCtrl), + HSData = HSData0#hs_data{kernel_pid = Kernel, + this_node = MyNode, + socket = DistCtrl, + timer = Timer, + this_flags = 0, + allowed = Allowed}, + dist_util:handshake_other_started(HSData); + {false,IP} -> + error_msg("** Connection attempt from " + "disallowed IP ~w ** ~n", [IP]), + ?shutdown(no_node) + end + end. + +%% we may not always want the nodelay behaviour +%% for performance reasons + +nodelay() -> + case application:get_env(kernel, dist_nodelay) of + undefined -> + {nodelay, true}; + {ok, true} -> + {nodelay, true}; + {ok, false} -> + {nodelay, false}; + _ -> + {nodelay, true} + end. + +%% ------------------------------------------------------------ +%% Setup a new connection to another Erlang node. +%% Performs the handshake with the other side. +%% ------------------------------------------------------------ + +setup(Node, Type, MyNode, LongOrShortNames,SetupTime) -> + spawn_opt(?MODULE, do_setup, + [self(), Node, Type, MyNode, LongOrShortNames, SetupTime], + [link, {priority, max}]). + +do_setup(Kernel, Node, Type, MyNode, LongOrShortNames, SetupTime) -> + ?trace("~p~n",[{?MODULE, do_setup, self(), Node}]), + [Name, Address] = splitnode(Node, LongOrShortNames), + case inet:getaddr(Address, inet) of + {ok, Ip} -> + Timer = dist_util:start_timer(SetupTime), + ErlEpmd = net_kernel:epmd_module(), + case ErlEpmd:port_please(Name, Ip) of + {port, TcpPort, Version} -> + ?trace("port_please(~p) -> version ~p~n", + [Node,Version]), + dist_util:reset_timer(Timer), + case + gen_tcp:connect( + Ip, TcpPort, + connect_options([binary, {active, false}, {packet, 2}])) + of + {ok, Socket} -> + DistCtrl = spawn_dist_cntrlr(Socket), + call_ctrlr(DistCtrl, {supervisor, self()}), + flush_controller(DistCtrl, Socket), + gen_tcp:controlling_process(Socket, DistCtrl), + flush_controller(DistCtrl, Socket), + HSData0 = hs_data_common(DistCtrl), + HSData = HSData0#hs_data{kernel_pid = Kernel, + other_node = Node, + this_node = MyNode, + socket = DistCtrl, + timer = Timer, + this_flags = 0, + other_version = Version, + request_type = Type}, + dist_util:handshake_we_started(HSData); + _ -> + %% Other Node may have closed since + %% port_please ! + ?trace("other node (~p) " + "closed since port_please.~n", + [Node]), + ?shutdown(Node) + end; + _ -> + ?trace("port_please (~p) " + "failed.~n", [Node]), + ?shutdown(Node) + end; + _Other -> + ?trace("inet_getaddr(~p) " + "failed (~p).~n", [Node,_Other]), + ?shutdown(Node) + end. + +connect_options(Opts) -> + case application:get_env(kernel, inet_dist_connect_options) of + {ok,ConnectOpts} -> + ConnectOpts ++ Opts; + _ -> + Opts + end. + +%% +%% Close a socket. +%% +close(Listen) -> + gen_tcp:close(Listen). + + +%% If Node is illegal terminate the connection setup!! +splitnode(Node, LongOrShortNames) -> + case split_node(atom_to_list(Node), $@, []) of + [Name|Tail] when Tail =/= [] -> + Host = lists:append(Tail), + case split_node(Host, $., []) of + [_] when LongOrShortNames =:= longnames -> + case inet:parse_address(Host) of + {ok, _} -> + [Name, Host]; + _ -> + error_msg("** System running to use " + "fully qualified " + "hostnames **~n" + "** Hostname ~ts is illegal **~n", + [Host]), + ?shutdown(Node) + end; + L when length(L) > 1, LongOrShortNames =:= shortnames -> + error_msg("** System NOT running to use fully qualified " + "hostnames **~n" + "** Hostname ~ts is illegal **~n", + [Host]), + ?shutdown(Node); + _ -> + [Name, Host] + end; + [_] -> + error_msg("** Nodename ~p illegal, no '@' character **~n", + [Node]), + ?shutdown(Node); + _ -> + error_msg("** Nodename ~p illegal **~n", [Node]), + ?shutdown(Node) + end. + +split_node([Chr|T], Chr, Ack) -> [lists:reverse(Ack)|split_node(T, Chr, [])]; +split_node([H|T], Chr, Ack) -> split_node(T, Chr, [H|Ack]); +split_node([], _, Ack) -> [lists:reverse(Ack)]. + +%% ------------------------------------------------------------ +%% Fetch local information about a Socket. +%% ------------------------------------------------------------ +get_tcp_address(Socket) -> + {ok, Address} = inet:sockname(Socket), + {ok, Host} = inet:gethostname(), + #net_address { + address = Address, + host = Host, + protocol = tcp, + family = inet + }. + +%% ------------------------------------------------------------ +%% Do only accept new connection attempts from nodes at our +%% own LAN, if the check_ip environment parameter is true. +%% ------------------------------------------------------------ +check_ip(DistCtrl) -> + case application:get_env(check_ip) of + {ok, true} -> + case get_ifs(DistCtrl) of + {ok, IFs, IP} -> + check_ip(IFs, IP); + _ -> + ?shutdown(no_node) + end; + _ -> + true + end. + +get_ifs(DistCtrl) -> + Socket = call_ctrlr(DistCtrl, socket), + case inet:peername(Socket) of + {ok, {IP, _}} -> + case inet:getif(Socket) of + {ok, IFs} -> {ok, IFs, IP}; + Error -> Error + end; + Error -> + Error + end. + +check_ip([{OwnIP, _, Netmask}|IFs], PeerIP) -> + case {inet_tcp:mask(Netmask, PeerIP), inet_tcp:mask(Netmask, OwnIP)} of + {M, M} -> true; + _ -> check_ip(IFs, PeerIP) + end; +check_ip([], PeerIP) -> + {false, PeerIP}. + +is_node_name(Node) when is_atom(Node) -> + case split_node(atom_to_list(Node), $@, []) of + [_, _Host] -> true; + _ -> false + end; +is_node_name(_Node) -> + false. + +hs_data_common(DistCtrl) -> + TickHandler = call_ctrlr(DistCtrl, tick_handler), + Socket = call_ctrlr(DistCtrl, socket), + #hs_data{f_send = send_fun(), + f_recv = recv_fun(), + f_setopts_pre_nodeup = setopts_pre_nodeup_fun(), + f_setopts_post_nodeup = setopts_post_nodeup_fun(), + f_getll = getll_fun(), + f_handshake_complete = handshake_complete_fun(), + f_address = address_fun(), + mf_setopts = setopts_fun(DistCtrl, Socket), + mf_getopts = getopts_fun(DistCtrl, Socket), + mf_getstat = getstat_fun(DistCtrl, Socket), + mf_tick = tick_fun(DistCtrl, TickHandler)}. + +%%% ------------------------------------------------------------ +%%% Distribution controller processes +%%% ------------------------------------------------------------ + +%% +%% There will be five parties working together when the +%% connection is up: +%% - The gen_tcp socket. Providing a tcp/ip connection +%% to the other node. +%% - The output handler. It will dispatch all outgoing +%% traffic from the VM to the gen_tcp socket. This +%% process is registered as distribution controller +%% for this channel with the VM. +%% - The input handler. It will dispatch all incoming +%% traffic from the gen_tcp socket to the VM. This +%% process is also the socket owner and receives +%% incoming traffic using active-N. +%% - The tick handler. Dispatches asynchronous tick +%% requests to the socket. It executes on max priority +%% since it is important to get ticks through to the +%% other end. +%% - The channel supervisor (provided by dist_util). It +%% monitors traffic. Issue tick requests to the tick +%% handler when no outgoing traffic is seen and bring +%% the connection down if no incoming traffic is seen. +%% This process also executes on max priority. +%% +%% These parties are linked togheter so should one +%% of them fail, all of them are terminated and the +%% connection is taken down. +%% + +%% In order to avoid issues with lingering signal binaries +%% we enable off-heap message queue data as well as fullsweep +%% after 0. The fullsweeps will be cheap since we have more +%% or less no live data. +-define(DIST_CNTRL_COMMON_SPAWN_OPTS, + [{message_queue_data, off_heap}, + {fullsweep_after, 0}]). + +tick_fun(DistCtrl, TickHandler) -> + fun (Ctrl) when Ctrl == DistCtrl -> + TickHandler ! tick + end. + +getstat_fun(DistCtrl, Socket) -> + fun (Ctrl) when Ctrl == DistCtrl -> + case inet:getstat(Socket, [recv_cnt, send_cnt, send_pend]) of + {ok, Stat} -> + split_stat(Stat,0,0,0); + Error -> + Error + end + end. + +split_stat([{recv_cnt, R}|Stat], _, W, P) -> + split_stat(Stat, R, W, P); +split_stat([{send_cnt, W}|Stat], R, _, P) -> + split_stat(Stat, R, W, P); +split_stat([{send_pend, P}|Stat], R, W, _) -> + split_stat(Stat, R, W, P); +split_stat([], R, W, P) -> + {ok, R, W, P}. + +setopts_fun(DistCtrl, Socket) -> + fun (Ctrl, Opts) when Ctrl == DistCtrl -> + setopts(Socket, Opts) + end. + +getopts_fun(DistCtrl, Socket) -> + fun (Ctrl, Opts) when Ctrl == DistCtrl -> + getopts(Socket, Opts) + end. + +setopts(S, Opts) -> + case [Opt || {K,_}=Opt <- Opts, + K =:= active orelse K =:= deliver orelse K =:= packet] of + [] -> inet:setopts(S,Opts); + Opts1 -> {error, {badopts,Opts1}} + end. + +getopts(S, Opts) -> + inet:getopts(S, Opts). + +send_fun() -> + fun (Ctrlr, Packet) -> + call_ctrlr(Ctrlr, {send, Packet}) + end. + +recv_fun() -> + fun (Ctrlr, Length, Timeout) -> + case call_ctrlr(Ctrlr, {recv, Length, Timeout}) of + {ok, Bin} when is_binary(Bin) -> + {ok, binary_to_list(Bin)}; + Other -> + Other + end + end. + +getll_fun() -> + fun (Ctrlr) -> + call_ctrlr(Ctrlr, getll) + end. + +address_fun() -> + fun (Ctrlr, Node) -> + case call_ctrlr(Ctrlr, {address, Node}) of + {error, no_node} -> %% No '@' or more than one '@' in node name. + ?shutdown(no_node); + Res -> + Res + end + end. + +setopts_pre_nodeup_fun() -> + fun (Ctrlr) -> + call_ctrlr(Ctrlr, pre_nodeup) + end. + +setopts_post_nodeup_fun() -> + fun (Ctrlr) -> + call_ctrlr(Ctrlr, post_nodeup) + end. + +handshake_complete_fun() -> + fun (Ctrlr, Node, DHandle) -> + call_ctrlr(Ctrlr, {handshake_complete, Node, DHandle}) + end. + +call_ctrlr(Ctrlr, Msg) -> + Ref = erlang:monitor(process, Ctrlr), + Ctrlr ! {Ref, self(), Msg}, + receive + {Ref, Res} -> + erlang:demonitor(Ref, [flush]), + Res; + {'DOWN', Ref, process, Ctrlr, Reason} -> + exit({dist_controller_exit, Reason}) + end. + +%% +%% The tick handler process writes a tick to the +%% socket when it receives a 'tick' message from +%% the connection supervisor. +%% +%% We are not allowed to block the connection +%% superviser when writing a tick and we also want +%% the tick to go through even during a heavily +%% loaded system. gen_tcp does not have a +%% non-blocking send operation exposed in its API +%% and we don't want to run the distribution +%% controller under high priority. Therefore this +%% sparate process with max prio that dispatches +%% ticks. +%% +dist_cntrlr_tick_handler(Socket) -> + receive + tick -> + %% May block due to busy port... + sock_send(Socket, ""); + _ -> + ok + end, + dist_cntrlr_tick_handler(Socket). + +spawn_dist_cntrlr(Socket) -> + spawn_opt(?MODULE, dist_cntrlr_setup, [Socket], + [{priority, max}] ++ ?DIST_CNTRL_COMMON_SPAWN_OPTS). + +dist_cntrlr_setup(Socket) -> + TickHandler = spawn_opt(?MODULE, dist_cntrlr_tick_handler, + [Socket], + [link, {priority, max}] + ++ ?DIST_CNTRL_COMMON_SPAWN_OPTS), + dist_cntrlr_setup_loop(Socket, TickHandler, undefined). + +%% +%% During the handshake phase we loop in dist_cntrlr_setup(). +%% When the connection is up we spawn an input handler and +%% continue as output handler. +%% +dist_cntrlr_setup_loop(Socket, TickHandler, Sup) -> + receive + {tcp_closed, Socket} -> + exit(connection_closed); + + {Ref, From, {supervisor, Pid}} -> + Res = link(Pid), + From ! {Ref, Res}, + dist_cntrlr_setup_loop(Socket, TickHandler, Pid); + + {Ref, From, tick_handler} -> + From ! {Ref, TickHandler}, + dist_cntrlr_setup_loop(Socket, TickHandler, Sup); + + {Ref, From, socket} -> + From ! {Ref, Socket}, + dist_cntrlr_setup_loop(Socket, TickHandler, Sup); + + {Ref, From, {send, Packet}} -> + Res = gen_tcp:send(Socket, Packet), + From ! {Ref, Res}, + dist_cntrlr_setup_loop(Socket, TickHandler, Sup); + + {Ref, From, {recv, Length, Timeout}} -> + Res = gen_tcp:recv(Socket, Length, Timeout), + From ! {Ref, Res}, + dist_cntrlr_setup_loop(Socket, TickHandler, Sup); + + {Ref, From, getll} -> + From ! {Ref, {ok, self()}}, + dist_cntrlr_setup_loop(Socket, TickHandler, Sup); + + {Ref, From, {address, Node}} -> + Res = case inet:peername(Socket) of + {ok, Address} -> + case split_node(atom_to_list(Node), $@, []) of + [_,Host] -> + #net_address{address=Address,host=Host, + protocol=tcp, family=inet}; + _ -> + {error, no_node} + end + end, + From ! {Ref, Res}, + dist_cntrlr_setup_loop(Socket, TickHandler, Sup); + + {Ref, From, pre_nodeup} -> + Res = inet:setopts(Socket, + [{active, false}, + {packet, 4}, + nodelay()]), + From ! {Ref, Res}, + dist_cntrlr_setup_loop(Socket, TickHandler, Sup); + + {Ref, From, post_nodeup} -> + Res = inet:setopts(Socket, + [{active, false}, + {packet, 4}, + nodelay()]), + From ! {Ref, Res}, + dist_cntrlr_setup_loop(Socket, TickHandler, Sup); + + {Ref, From, {handshake_complete, _Node, DHandle}} -> + From ! {Ref, ok}, + %% Handshake complete! Begin dispatching traffic... + + %% We use separate process for dispatching input. This + %% is not necessary, but it enables parallel execution + %% of independent work loads at the same time as it + %% simplifies the the implementation... + InputHandler = spawn_opt(?MODULE, dist_cntrlr_input_setup, + [DHandle, Socket, Sup], + [link] ++ ?DIST_CNTRL_COMMON_SPAWN_OPTS), + + flush_controller(InputHandler, Socket), + gen_tcp:controlling_process(Socket, InputHandler), + flush_controller(InputHandler, Socket), + + ok = erlang:dist_ctrl_input_handler(DHandle, InputHandler), + + InputHandler ! DHandle, + + %% From now on we execute on normal priority + process_flag(priority, normal), + erlang:dist_ctrl_get_data_notification(DHandle), + dist_cntrlr_output_loop(DHandle, Socket) + end. + +%% We use active 10 for good throughput while still +%% maintaining back-pressure if the input controller +%% isn't able to handle all incoming messages... +-define(ACTIVE_INPUT, 10). + +dist_cntrlr_input_setup(DHandle, Socket, Sup) -> + link(Sup), + %% Ensure we don't try to put data before registerd + %% as input handler... + receive + DHandle -> + dist_cntrlr_input_loop(DHandle, Socket, 0) + end. + +dist_cntrlr_input_loop(DHandle, Socket, N) when N =< ?ACTIVE_INPUT/2 -> + inet:setopts(Socket, [{active, ?ACTIVE_INPUT - N}]), + dist_cntrlr_input_loop(DHandle, Socket, ?ACTIVE_INPUT); +dist_cntrlr_input_loop(DHandle, Socket, N) -> + receive + {tcp_closed, Socket} -> + %% Connection to remote node terminated... + exit(connection_closed); + + {tcp, Socket, Data} -> + %% Incoming data from remote node... + try erlang:dist_ctrl_put_data(DHandle, Data) + catch _ : _ -> death_row() + end, + dist_cntrlr_input_loop(DHandle, Socket, N-1); + + _ -> + %% Ignore... + dist_cntrlr_input_loop(DHandle, Socket, N) + end. + +dist_cntrlr_send_data(DHandle, Socket) -> + case erlang:dist_ctrl_get_data(DHandle) of + none -> + erlang:dist_ctrl_get_data_notification(DHandle); + Data -> + sock_send(Socket, Data), + dist_cntrlr_send_data(DHandle, Socket) + end. + + +dist_cntrlr_output_loop(DHandle, Socket) -> + receive + dist_data -> + %% Outgoing data from this node... + try dist_cntrlr_send_data(DHandle, Socket) + catch _ : _ -> death_row() + end, + dist_cntrlr_output_loop(DHandle, Socket); + + {send, From, Ref, Data} -> + %% This is for testing only! + %% + %% Needed by some OTP distribution + %% test suites... + sock_send(Socket, Data), + From ! {Ref, ok}, + dist_cntrlr_output_loop(DHandle, Socket); + + _ -> + %% Drop garbage message... + dist_cntrlr_output_loop(DHandle, Socket) + + end. + +sock_send(Socket, Data) -> + try gen_tcp:send(Socket, Data) of + ok -> ok; + {error, Reason} -> death_row({send_error, Reason}) + catch + Type : Reason -> death_row({send_error, {Type, Reason}}) + end. + +death_row() -> + death_row(connection_closed). + +death_row(normal) -> + %% We do not want to exit with normal + %% exit reason since it wont bring down + %% linked processes... + death_row(); +death_row(Reason) -> + %% When the connection is on its way down operations + %% begin to fail. We catch the failures and call + %% this function waiting for termination. We should + %% be terminated by one of our links to the other + %% involved parties that began bringing the + %% connection down. By waiting for termination we + %% avoid altering the exit reason for the connection + %% teardown. We however limit the wait to 5 seconds + %% and bring down the connection ourselves if not + %% terminated... + receive after 5000 -> exit(Reason) end. diff --git a/lib/kernel/include/dist.hrl b/lib/kernel/include/dist.hrl index d6bccdf474..6baaa35d72 100644 --- a/lib/kernel/include/dist.hrl +++ b/lib/kernel/include/dist.hrl @@ -40,3 +40,8 @@ -define(DFLAG_UTF8_ATOMS, 16#10000). -define(DFLAG_MAP_TAG, 16#20000). -define(DFLAG_BIG_CREATION, 16#40000). +-define(DFLAG_SEND_SENDER, 16#80000). +-define(DFLAG_BIG_SEQTRACE_LABELS, 16#100000). + +%% Also update dflag2str() in ../src/dist_util.erl +%% when adding flags... diff --git a/lib/kernel/include/dist_util.hrl b/lib/kernel/include/dist_util.hrl index e3d2fe0eb6..eeb0f8dd43 100644 --- a/lib/kernel/include/dist_util.hrl +++ b/lib/kernel/include/dist_util.hrl @@ -29,9 +29,9 @@ -endif. -ifdef(dist_trace). --define(trace(Fmt,Args), io:format("~p ~p:~s",[erlang:timestamp(),node(),lists:flatten(io_lib:format(Fmt, Args))])). +-define(trace(Fmt,Args), io:format("~p ~p:~s",[erlang:convert_time_unit(erlang:monotonic_time()-erlang:system_info(start_time), native, microsecond),node(),lists:flatten(io_lib:format(Fmt, Args))])). % Use the one below for config-file (early boot) connection tracing -%-define(trace(Fmt,Args), erlang:display([erlang:now(),node(),lists:flatten(io_lib:format(Fmt, Args))])). +%-define(trace(Fmt,Args), erlang:display([erlang:convert_time_unit(erlang:monotonic_time()-erlang:system_info(start_time), native, microsecond),node(),lists:flatten(io_lib:format(Fmt, Args))])). -define(trace_factor,8). -else. -define(trace(Fmt,Args), ok). @@ -78,7 +78,13 @@ %% New in kernel-5.1 (OTP 19.1): mf_setopts, %% netkernel:setopts on active connection - mf_getopts %% netkernel:getopts on active connection + mf_getopts, %% netkernel:getopts on active connection + + %% New in kernel-6.0 (OTP 21.0) + f_handshake_complete, %% Notify handshake complete + add_flags, %% dflags to add + reject_flags, %% dflags not to use (not all can be rejected) + require_flags %% dflags that are required }). diff --git a/lib/kernel/src/Makefile b/lib/kernel/src/Makefile index 5946620f0f..0bc9f121a0 100644 --- a/lib/kernel/src/Makefile +++ b/lib/kernel/src/Makefile @@ -106,6 +106,7 @@ MODULES = \ inet_sctp \ kernel \ kernel_config \ + kernel_refc \ local_udp \ local_tcp \ net \ @@ -120,6 +121,13 @@ MODULES = \ user \ user_drv \ user_sup \ + raw_file_io \ + raw_file_io_compressed \ + raw_file_io_inflate \ + raw_file_io_deflate \ + raw_file_io_delayed \ + raw_file_io_list \ + raw_file_io_raw \ wrap_log_reader HRL_FILES= ../include/file.hrl ../include/inet.hrl ../include/inet_sctp.hrl \ @@ -226,7 +234,8 @@ $(EBIN)/disk_log_server.beam: disk_log.hrl $(EBIN)/dist_util.beam: ../include/dist_util.hrl ../include/dist.hrl $(EBIN)/erl_boot_server.beam: inet_boot.hrl $(EBIN)/erl_epmd.beam: inet_int.hrl erl_epmd.hrl -$(EBIN)/file.beam: ../include/file.hrl +$(EBIN)/file.beam: ../include/file.hrl file_int.hrl +$(EBIN)/file_io_server.beam: ../include/file.hrl file_int.hrl $(EBIN)/gen_tcp.beam: inet_int.hrl $(EBIN)/gen_udp.beam: inet_int.hrl $(EBIN)/gen_sctp.beam: ../include/inet_sctp.hrl @@ -254,3 +263,10 @@ $(EBIN)/net_kernel.beam: ../include/net_address.hrl $(EBIN)/os.beam: ../include/file.hrl $(EBIN)/ram_file.beam: ../include/file.hrl $(EBIN)/wrap_log_reader.beam: disk_log.hrl ../include/file.hrl +$(EBIN)/raw_file_io.beam: ../include/file.hrl file_int.hrl +$(EBIN)/raw_file_io_compressed.beam: ../include/file.hrl file_int.hrl +$(EBIN)/raw_file_io_inflate.beam: ../include/file.hrl file_int.hrl +$(EBIN)/raw_file_io_deflate.beam: ../include/file.hrl file_int.hrl +$(EBIN)/raw_file_io_delayed.beam: ../include/file.hrl file_int.hrl +$(EBIN)/raw_file_io_list.beam: ../include/file.hrl file_int.hrl +$(EBIN)/raw_file_io_raw.beam: ../include/file.hrl file_int.hrl diff --git a/lib/kernel/src/auth.erl b/lib/kernel/src/auth.erl index 40feee6bf0..a2116d8e8a 100644 --- a/lib/kernel/src/auth.erl +++ b/lib/kernel/src/auth.erl @@ -107,7 +107,7 @@ get_cookie() -> get_cookie(_Node) when node() =:= nonode@nohost -> nocookie; get_cookie(Node) -> - gen_server:call(auth, {get_cookie, Node}). + gen_server:call(auth, {get_cookie, Node}, infinity). -spec set_cookie(Cookie :: cookie()) -> 'true'. @@ -119,12 +119,12 @@ set_cookie(Cookie) -> set_cookie(_Node, _Cookie) when node() =:= nonode@nohost -> erlang:error(distribution_not_started); set_cookie(Node, Cookie) -> - gen_server:call(auth, {set_cookie, Node, Cookie}). + gen_server:call(auth, {set_cookie, Node, Cookie}, infinity). -spec sync_cookie() -> any(). sync_cookie() -> - gen_server:call(auth, sync_cookie). + gen_server:call(auth, sync_cookie, infinity). -spec print(Node :: node(), Format :: string(), Args :: [_]) -> 'ok'. diff --git a/lib/kernel/src/code.erl b/lib/kernel/src/code.erl index 9969021a6c..f143a49d2f 100644 --- a/lib/kernel/src/code.erl +++ b/lib/kernel/src/code.erl @@ -149,8 +149,11 @@ load_file(Mod) when is_atom(Mod) -> -spec ensure_loaded(Module) -> {module, Module} | {error, What} when Module :: module(), What :: embedded | badfile | nofile | on_load_failure. -ensure_loaded(Mod) when is_atom(Mod) -> - call({ensure_loaded,Mod}). +ensure_loaded(Mod) when is_atom(Mod) -> + case erlang:module_loaded(Mod) of + true -> {module, Mod}; + false -> call({ensure_loaded,Mod}) + end. %% XXX File as an atom is allowed only for backwards compatibility. -spec load_abs(Filename) -> load_ret() when diff --git a/lib/kernel/src/disk_log_1.erl b/lib/kernel/src/disk_log_1.erl index 93856aa7b3..b456b53d20 100644 --- a/lib/kernel/src/disk_log_1.erl +++ b/lib/kernel/src/disk_log_1.erl @@ -630,7 +630,7 @@ is_head(Bin) when is_binary(Bin) -> %% Writes MaxB bytes on each file. %% Creates a file called Name.idx in the Dir. This %% file contains the last written FileName as one byte, and -%% follwing that, the sizes of each file (size 0 number of items). +%% following that, the sizes of each file (size 0 number of items). %% On startup, this file is read, and the next available %% filename is used as first log file. %% Reports can be browsed with Report Browser Tool (rb), or diff --git a/lib/kernel/src/dist_util.erl b/lib/kernel/src/dist_util.erl index b3507e5d13..781397e1ee 100644 --- a/lib/kernel/src/dist_util.erl +++ b/lib/kernel/src/dist_util.erl @@ -27,6 +27,7 @@ %%-compile(export_all). -export([handshake_we_started/1, handshake_other_started/1, + strict_order_flags/0, start_timer/1, setup_timer/2, reset_timer/1, cancel_timer/1, shutdown/3, shutdown/4]). @@ -74,22 +75,52 @@ ticked = 0 }). -remove_flag(Flag, Flags) -> - case Flags band Flag of - 0 -> - Flags; - _ -> - Flags - Flag - end. +dflag2str(?DFLAG_PUBLISHED) -> + "PUBLISHED"; +dflag2str(?DFLAG_ATOM_CACHE) -> + "ATOM_CACHE"; +dflag2str(?DFLAG_EXTENDED_REFERENCES) -> + "EXTENDED_REFERENCES"; +dflag2str(?DFLAG_DIST_MONITOR) -> + "DIST_MONITOR"; +dflag2str(?DFLAG_FUN_TAGS) -> + "FUN_TAGS"; +dflag2str(?DFLAG_DIST_MONITOR_NAME) -> + "DIST_MONITOR_NAME"; +dflag2str(?DFLAG_HIDDEN_ATOM_CACHE) -> + "HIDDEN_ATOM_CACHE"; +dflag2str(?DFLAG_NEW_FUN_TAGS) -> + "NEW_FUN_TAGS"; +dflag2str(?DFLAG_EXTENDED_PIDS_PORTS) -> + "EXTENDED_PIDS_PORTS"; +dflag2str(?DFLAG_EXPORT_PTR_TAG) -> + "EXPORT_PTR_TAG"; +dflag2str(?DFLAG_BIT_BINARIES) -> + "BIT_BINARIES"; +dflag2str(?DFLAG_NEW_FLOATS) -> + "NEW_FLOATS"; +dflag2str(?DFLAG_UNICODE_IO) -> + "UNICODE_IO"; +dflag2str(?DFLAG_DIST_HDR_ATOM_CACHE) -> + "DIST_HDR_ATOM_CACHE"; +dflag2str(?DFLAG_SMALL_ATOM_TAGS) -> + "SMALL_ATOM_TAGS"; +dflag2str(?DFLAG_UTF8_ATOMS) -> + "UTF8_ATOMS"; +dflag2str(?DFLAG_MAP_TAG) -> + "MAP_TAG"; +dflag2str(?DFLAG_BIG_CREATION) -> + "BIG_CREATION"; +dflag2str(?DFLAG_SEND_SENDER) -> + "SEND_SENDER"; +dflag2str(?DFLAG_BIG_SEQTRACE_LABELS) -> + "BIG_SEQTRACE_LABELS"; +dflag2str(_) -> + "UNKNOWN". + adjust_flags(ThisFlags, OtherFlags) -> - case (?DFLAG_PUBLISHED band ThisFlags) band OtherFlags of - 0 -> - {remove_flag(?DFLAG_PUBLISHED, ThisFlags), - remove_flag(?DFLAG_PUBLISHED, OtherFlags)}; - _ -> - {ThisFlags, OtherFlags} - end. + ThisFlags band OtherFlags. publish_flag(hidden, _) -> 0; @@ -101,37 +132,56 @@ publish_flag(_, OtherNode) -> 0 end. -make_this_flags(RequestType, OtherNode) -> - publish_flag(RequestType, OtherNode) bor - %% The parenthesis below makes the compiler generate better code. - (?DFLAG_EXPORT_PTR_TAG bor - ?DFLAG_EXTENDED_PIDS_PORTS bor - ?DFLAG_EXTENDED_REFERENCES bor - ?DFLAG_DIST_MONITOR bor - ?DFLAG_FUN_TAGS bor - ?DFLAG_DIST_MONITOR_NAME bor - ?DFLAG_HIDDEN_ATOM_CACHE bor - ?DFLAG_NEW_FUN_TAGS bor - ?DFLAG_BIT_BINARIES bor - ?DFLAG_NEW_FLOATS bor - ?DFLAG_UNICODE_IO bor - ?DFLAG_DIST_HDR_ATOM_CACHE bor - ?DFLAG_SMALL_ATOM_TAGS bor - ?DFLAG_UTF8_ATOMS bor - ?DFLAG_MAP_TAG bor - ?DFLAG_BIG_CREATION). - -handshake_other_started(#hs_data{request_type=ReqType}=HSData0) -> + +%% Sync with dist.c +-record(erts_dflags, { + default, % flags erts prefers + mandatory, % flags erts needs + addable, % flags local dist implementation is allowed to add + rejectable, % flags local dist implementation is allowed to reject + strict_order % flags for features needing strict order delivery +}). + +-spec strict_order_flags() -> integer(). +strict_order_flags() -> + EDF = erts_internal:get_dflags(), + EDF#erts_dflags.strict_order. + +make_this_flags(RequestType, AddFlags, RejectFlags, OtherNode, + #erts_dflags{}=EDF) -> + case RejectFlags band (bnot EDF#erts_dflags.rejectable) of + 0 -> ok; + Rerror -> exit({"Rejecting non rejectable flags", Rerror}) + end, + case AddFlags band (bnot EDF#erts_dflags.addable) of + 0 -> ok; + Aerror -> exit({"Adding non addable flags", Aerror}) + end, + Flgs0 = EDF#erts_dflags.default, + Flgs1 = Flgs0 bor publish_flag(RequestType, OtherNode), + Flgs2 = Flgs1 bor AddFlags, + Flgs2 band (bnot RejectFlags). + +handshake_other_started(#hs_data{request_type=ReqType, + add_flags=AddFlgs0, + reject_flags=RejFlgs0, + require_flags=ReqFlgs0}=HSData0) -> + AddFlgs = convert_flags(AddFlgs0), + RejFlgs = convert_flags(RejFlgs0), + ReqFlgs = convert_flags(ReqFlgs0), {PreOtherFlags,Node,Version} = recv_name(HSData0), - PreThisFlags = make_this_flags(ReqType, Node), - {ThisFlags, OtherFlags} = adjust_flags(PreThisFlags, - PreOtherFlags), - HSData = HSData0#hs_data{this_flags=ThisFlags, - other_flags=OtherFlags, + EDF = erts_internal:get_dflags(), + PreThisFlags = make_this_flags(ReqType, AddFlgs, RejFlgs, Node, EDF), + ChosenFlags = adjust_flags(PreThisFlags, PreOtherFlags), + HSData = HSData0#hs_data{this_flags=ChosenFlags, + other_flags=ChosenFlags, other_version=Version, other_node=Node, - other_started=true}, - check_dflags(HSData), + other_started=true, + add_flags=AddFlgs, + reject_flags=RejFlgs, + require_flags=ReqFlgs}, + check_dflags(HSData, EDF), is_allowed(HSData), ?debug({"MD5 connection from ~p (V~p)~n", [Node, HSData#hs_data.other_version]}), @@ -165,23 +215,16 @@ is_allowed(#hs_data{other_node = Node, end. %% -%% Check that both nodes can handle the same types of extended -%% node containers. If they can not, abort the connection. +%% Check mandatory flags... %% check_dflags(#hs_data{other_node = Node, other_flags = OtherFlags, - other_started = OtherStarted} = HSData) -> - - Mandatory = [{?DFLAG_EXTENDED_REFERENCES, "EXTENDED_REFERENCES"}, - {?DFLAG_EXTENDED_PIDS_PORTS, "EXTENDED_PIDS_PORTS"}, - {?DFLAG_UTF8_ATOMS, "UTF8_ATOMS"}], - Missing = lists:filtermap(fun({Bit, Str}) -> - case Bit band OtherFlags of - Bit -> false; - 0 -> {true, Str} - end - end, - Mandatory), + other_started = OtherStarted, + require_flags = RequiredFlags} = HSData, + #erts_dflags{}=EDF) -> + + Mandatory = (EDF#erts_dflags.mandatory bor RequiredFlags), + Missing = check_mandatory(Mandatory, OtherFlags, []), case Missing of [] -> ok; @@ -201,6 +244,21 @@ check_dflags(#hs_data{other_node = Node, ?shutdown2(Node, {check_dflags_failed, Missing}) end. +check_mandatory(0, _OtherFlags, Missing) -> + Missing; +check_mandatory(Mandatory, OtherFlags, Missing) -> + Left = Mandatory band (Mandatory - 1), % clear lowest set bit + DFlag = Mandatory bxor Left, % only lowest set bit + NewMissing = case DFlag band OtherFlags of + 0 -> + %% Mandatory and missing... + [dflag2str(DFlag) | Missing]; + _ -> + %% Mandatory and present... + Missing + end, + check_mandatory(Left, OtherFlags, NewMissing). + %% No nodedown will be sent if we fail before this process has %% succeeded to mark the node as pending. @@ -314,17 +372,27 @@ flush_down() -> end. handshake_we_started(#hs_data{request_type=ReqType, - other_node=Node}=PreHSData) -> - PreThisFlags = make_this_flags(ReqType, Node), - HSData = PreHSData#hs_data{this_flags=PreThisFlags}, + other_node=Node, + add_flags=AddFlgs0, + reject_flags=RejFlgs0, + require_flags=ReqFlgs0}=PreHSData) -> + AddFlgs = convert_flags(AddFlgs0), + RejFlgs = convert_flags(RejFlgs0), + ReqFlgs = convert_flags(ReqFlgs0), + EDF = erts_internal:get_dflags(), + PreThisFlags = make_this_flags(ReqType, AddFlgs, RejFlgs, Node, EDF), + HSData = PreHSData#hs_data{this_flags = PreThisFlags, + add_flags = AddFlgs, + reject_flags = RejFlgs, + require_flags = ReqFlgs}, send_name(HSData), recv_status(HSData), {PreOtherFlags,ChallengeA} = recv_challenge(HSData), - {ThisFlags,OtherFlags} = adjust_flags(PreThisFlags, PreOtherFlags), - NewHSData = HSData#hs_data{this_flags = ThisFlags, - other_flags = OtherFlags, + ChosenFlags = adjust_flags(PreThisFlags, PreOtherFlags), + NewHSData = HSData#hs_data{this_flags = ChosenFlags, + other_flags = ChosenFlags, other_started = false}, - check_dflags(NewHSData), + check_dflags(NewHSData, EDF), MyChallenge = gen_challenge(), {MyCookie,HisCookie} = get_cookies(Node), send_challenge_reply(NewHSData,MyChallenge, @@ -336,15 +404,16 @@ handshake_we_started(#hs_data{request_type=ReqType, handshake_we_started(OldHsData) when element(1,OldHsData) =:= hs_data -> handshake_we_started(convert_old_hsdata(OldHsData)). -convert_old_hsdata({hs_data, KP, ON, TN, S, T, TF, A, OV, OF, OS, FS, FR, - FS_PRE, FS_POST, FG, FA, MFT, MFG, RT}) -> - #hs_data{ - kernel_pid = KP, other_node = ON, this_node = TN, socket = S, timer = T, - this_flags = TF, allowed = A, other_version = OV, other_flags = OF, - other_started = OS, f_send = FS, f_recv = FR, f_setopts_pre_nodeup = FS_PRE, - f_setopts_post_nodeup = FS_POST, f_getll = FG, f_address = FA, - mf_tick = MFT, mf_getstat = MFG, request_type = RT}. +convert_old_hsdata(OldHsData) -> + OHSDL = tuple_to_list(OldHsData), + NoMissing = tuple_size(#hs_data{}) - tuple_size(OldHsData), + true = NoMissing > 0, + list_to_tuple(OHSDL ++ lists:duplicate(NoMissing, undefined)). +convert_flags(Flags) when is_integer(Flags) -> + Flags; +convert_flags(_Undefined) -> + 0. %% -------------------------------------------------------------- %% The connection has been established. @@ -359,15 +428,20 @@ connection(#hs_data{other_node = Node, PType = publish_type(HSData#hs_data.other_flags), case FPreNodeup(Socket) of ok -> - do_setnode(HSData), % Succeeds or exits the process. + DHandle = do_setnode(HSData), % Succeeds or exits the process. Address = FAddress(Socket,Node), mark_nodeup(HSData,Address), case FPostNodeup(Socket) of ok -> + case HSData#hs_data.f_handshake_complete of + undefined -> ok; + HsComplete -> HsComplete(Socket, Node, DHandle) + end, con_loop({HSData#hs_data.kernel_pid, Node, Socket, PType, + DHandle, HSData#hs_data.mf_tick, HSData#hs_data.mf_getstat, HSData#hs_data.mf_setopts, @@ -425,18 +499,16 @@ do_setnode(#hs_data{other_node = Node, socket = Socket, [Node, Port, {publish_type(Flags), '(', Flags, ')', Version}]), - case (catch - erlang:setnode(Node, Port, - {Flags, Version, '', ''})) of - {'EXIT', {system_limit, _}} -> + try + erlang:setnode(Node, Port, {Flags, Version, '', ''}) + catch + error:system_limit -> error_msg("** Distribution system limit reached, " "no table space left for node ~w ** ~n", [Node]), ?shutdown(Node); - {'EXIT', Other} -> - exit(Other); - _Else -> - ok + error:Other:Stacktrace -> + exit({Other, Stacktrace}) end; _ -> error_msg("** Distribution connection error, " @@ -468,7 +540,13 @@ mark_nodeup(#hs_data{kernel_pid = Kernel, ?shutdown(Node) end. -con_loop({Kernel, Node, Socket, Type, MFTick, MFGetstat, MFSetOpts, MFGetOpts}=ConData, +getstat(DHandle, _Socket, undefined) -> + erlang:dist_get_stat(DHandle); +getstat(_DHandle, Socket, MFGetstat) -> + MFGetstat(Socket). + +con_loop({Kernel, Node, Socket, Type, DHandle, MFTick, MFGetstat, + MFSetOpts, MFGetOpts}=ConData, Tick) -> receive {tcp_closed, Socket} -> @@ -476,15 +554,15 @@ con_loop({Kernel, Node, Socket, Type, MFTick, MFGetstat, MFSetOpts, MFGetOpts}=C {Kernel, disconnect} -> ?shutdown2(Node, disconnected); {Kernel, aux_tick} -> - case MFGetstat(Socket) of + case getstat(DHandle, Socket, MFGetstat) of {ok, _, _, PendWrite} -> - send_tick(Socket, PendWrite, MFTick); + send_aux_tick(Type, Socket, PendWrite, MFTick); _ -> ignore_it end, con_loop(ConData, Tick); {Kernel, tick} -> - case send_tick(Socket, Tick, Type, + case send_tick(DHandle, Socket, Tick, Type, MFTick, MFGetstat) of {ok, NewTick} -> con_loop(ConData, NewTick); @@ -497,7 +575,7 @@ con_loop({Kernel, Node, Socket, Type, MFTick, MFGetstat, MFSetOpts, MFGetOpts}=C ?shutdown2(Node, send_net_tick_failed) end; {From, get_status} -> - case MFGetstat(Socket) of + case getstat(DHandle, Socket, MFGetstat) of {ok, Read, Write, _} -> From ! {self(), get_status, {ok, Read, Write}}, con_loop(ConData, Tick); @@ -731,51 +809,57 @@ send_status(#hs_data{socket = Socket, other_node = Node, %% The detection time interval is thus, by default, 45s < DT < 75s -%% A HIDDEN node is always (if not a pending write) ticked if -%% we haven't read anything as a hidden node only ticks when it receives -%% a TICK !! +%% A HIDDEN node is always ticked if we haven't read anything +%% as a (primitive) hidden node only ticks when it receives a TICK !! -send_tick(Socket, Tick, Type, MFTick, MFGetstat) -> +send_tick(DHandle, Socket, Tick, Type, MFTick, MFGetstat) -> #tick{tick = T0, read = Read, write = Write, - ticked = Ticked} = Tick, + ticked = Ticked0} = Tick, T = T0 + 1, T1 = T rem 4, - case MFGetstat(Socket) of - {ok, Read, _, _} when Ticked =:= T -> + case getstat(DHandle, Socket, MFGetstat) of + {ok, Read, _, _} when Ticked0 =:= T -> {error, not_responding}; - {ok, Read, W, Pend} when Type =:= hidden -> - send_tick(Socket, Pend, MFTick), - {ok, Tick#tick{write = W + 1, - tick = T1}}; - {ok, Read, Write, Pend} -> - send_tick(Socket, Pend, MFTick), - {ok, Tick#tick{write = Write + 1, - tick = T1}}; - {ok, R, Write, Pend} -> - send_tick(Socket, Pend, MFTick), - {ok, Tick#tick{write = Write + 1, - read = R, - tick = T1, - ticked = T}}; - {ok, Read, W, _} -> - {ok, Tick#tick{write = W, - tick = T1}}; - {ok, R, W, _} -> - {ok, Tick#tick{write = W, - read = R, - tick = T1, - ticked = T}}; + + {ok, R, W1, Pend} -> + RDiff = R - Read, + W2 = case need_to_tick(Type, RDiff, W1-Write, Pend) of + true -> + MFTick(Socket), + W1 + 1; + false -> + W1 + end, + + Ticked1 = case RDiff of + 0 -> Ticked0; + _ -> T + end, + + {ok, Tick#tick{write = W2, + tick = T1, + read = R, + ticked = Ticked1}}; + Error -> Error end. -send_tick(Socket, 0, MFTick) -> - MFTick(Socket); -send_tick(_, _Pend, _) -> - %% Dont send tick if pending write. - ok. +need_to_tick(_, _, 0, 0) -> % nothing written and empty send queue + true; +need_to_tick(_, _, 0, false) -> % nothing written and empty send queue + true; +need_to_tick(hidden, 0, _, _) -> % nothing read from hidden + true; +need_to_tick(_, _, _, _) -> + false. + +send_aux_tick(normal, _, Pend, _) when Pend /= false, Pend /= 0 -> + ok; %% Dont send tick if pending write. +send_aux_tick(_Type, Socket, _Pend, MFTick) -> + MFTick(Socket). %% ------------------------------------------------------------ %% Connection setup timeout timer. diff --git a/lib/kernel/src/erl_boot_server.erl b/lib/kernel/src/erl_boot_server.erl index 2578b74428..4ac945ce01 100644 --- a/lib/kernel/src/erl_boot_server.erl +++ b/lib/kernel/src/erl_boot_server.erl @@ -252,9 +252,9 @@ handle_info({udp, U, IP, Port, Data}, S0) -> "~w is not a valid address ** ~n", [IP]), {noreply,S0}; {true,_,_} -> - case catch string:substr(Data, 1, length(?EBOOT_REQUEST)) of + case catch string:slice(Data, 0, length(?EBOOT_REQUEST)) of ?EBOOT_REQUEST -> - Vsn = string:substr(Data, length(?EBOOT_REQUEST)+1, length(Data)), + Vsn = string:slice(Data, length(?EBOOT_REQUEST), length(Data)), error_logger:error_msg("** Illegal boot server connection attempt: " "client version is ~s ** ~n", [Vsn]); _ -> diff --git a/lib/kernel/src/erl_epmd.erl b/lib/kernel/src/erl_epmd.erl index 7bc9e2ede3..f96bc88913 100644 --- a/lib/kernel/src/erl_epmd.erl +++ b/lib/kernel/src/erl_epmd.erl @@ -79,7 +79,13 @@ port_please(Node, EpmdAddr, Timeout) -> port_please1(Node,HostName, Timeout) -> - case inet:gethostbyname(HostName, inet, Timeout) of + Family = case inet_db:res_option(inet6) of + true -> + inet6; + false -> + inet + end, + case inet:gethostbyname(HostName, Family, Timeout) of {ok,{hostent, _Name, _ , _Af, _Size, [EpmdAddr | _]}} -> get_port(Node, EpmdAddr, Timeout); Else -> diff --git a/lib/kernel/src/erl_reply.erl b/lib/kernel/src/erl_reply.erl index e1e046cbb4..e1c4ffe839 100644 --- a/lib/kernel/src/erl_reply.erl +++ b/lib/kernel/src/erl_reply.erl @@ -1,7 +1,7 @@ %% %% %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. @@ -42,7 +42,7 @@ reply(_) -> %% convert ip number to tuple ip_string_to_tuple(Ip) -> - [Ip1,Ip2,Ip3,Ip4] = string:tokens(Ip,"."), + [Ip1,Ip2,Ip3,Ip4] = string:lexemes(Ip,"."), {list_to_integer(Ip1), list_to_integer(Ip2), list_to_integer(Ip3), diff --git a/lib/kernel/src/error_handler.erl b/lib/kernel/src/error_handler.erl index 59ca8e690d..a9582c6225 100644 --- a/lib/kernel/src/error_handler.erl +++ b/lib/kernel/src/error_handler.erl @@ -106,8 +106,8 @@ crash(M, F, A) -> crash(Tuple) -> try erlang:error(undef) catch - error:undef -> - Stk = [Tuple|tl(erlang:get_stacktrace())], + error:undef:Stacktrace -> + Stk = [Tuple|tl(Stacktrace)], erlang:raise(error, undef, Stk) end. diff --git a/lib/kernel/src/erts_debug.erl b/lib/kernel/src/erts_debug.erl index 9662f8fa90..1270de4144 100644 --- a/lib/kernel/src/erts_debug.erl +++ b/lib/kernel/src/erts_debug.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1999-2016. All Rights Reserved. +%% Copyright Ericsson AB 1999-2018. 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,7 @@ %% Low-level debugging support. EXPERIMENTAL! --export([size/1,df/1,df/2,df/3,df/4,ic/1]). +-export([size/1,df/1,df/2,df/3,dis_to_file/2,ic/1]). %% This module contains the following *experimental* BIFs: %% disassemble/1 @@ -32,11 +32,11 @@ %%% BIFs -export([breakpoint/2, disassemble/1, display/1, dist_ext_to_term/2, - dump_monitors/1, dump_links/1, flat_size/1, - get_internal_state/1, instructions/0, + flat_size/1, get_internal_state/1, instructions/0, map_info/1, same/2, set_internal_state/2, size_shared/1, copy_shared/1, dirty_cpu/2, dirty_io/2, dirty/3, - lcnt_control/1, lcnt_control/2, lcnt_collect/0, lcnt_clear/0]). + lcnt_control/1, lcnt_control/2, lcnt_collect/0, lcnt_clear/0, + lc_graph/0, lc_graph_to_dot/2, lc_graph_merge/2]). -spec breakpoint(MFA, Flag) -> non_neg_integer() when MFA :: {Module :: module(), @@ -70,18 +70,6 @@ display(_) -> dist_ext_to_term(_, _) -> erlang:nif_error(undef). --spec dump_monitors(Id) -> true when - Id :: pid() | atom(). - -dump_monitors(_) -> - erlang:nif_error(undef). - --spec dump_links(Id) -> true when - Id :: pid() | port() | atom(). - -dump_links(_) -> - erlang:nif_error(undef). - -spec flat_size(Term) -> non_neg_integer() when Term :: term(). @@ -347,55 +335,52 @@ is_term_seen(_, []) -> false. -spec df(module()) -> df_ret(). df(Mod) when is_atom(Mod) -> - df(lists:concat([Mod, ".dis"]), Mod). - --spec df(module(), atom()) -> df_ret(); - (file:io_device() | file:filename(), module()) -> df_ret(). - -df(Mod, Func) when is_atom(Mod), is_atom(Func) -> - df(lists:concat([Mod, "_", Func, ".dis"]), Mod, Func); -df(Name, Mod) when is_atom(Mod) -> try Mod:module_info(functions) of Fs0 when is_list(Fs0) -> + Name = lists:concat([Mod, ".dis"]), Fs = [{Mod,Func,Arity} || {Func,Arity} <- Fs0], dff(Name, Fs) catch _:_ -> {undef,Mod} end. +-spec df(module(), atom()) -> df_ret(). --spec df(module(), atom(), arity()) -> df_ret(); - (file:io_device() | file:filename(), module(), atom()) -> df_ret(). - -df(Mod, Func, Arity) when is_atom(Mod), is_atom(Func), is_integer(Arity) -> - df(lists:concat([Mod, "_", Func, "_", Arity, ".dis"]), Mod, Func, Arity); -df(Name, Mod, Func) when is_atom(Mod), is_atom(Func) -> +df(Mod, Func) when is_atom(Mod), is_atom(Func) -> try Mod:module_info(functions) of Fs0 when is_list(Fs0) -> + Name = lists:concat([Mod, "_", Func, ".dis"]), Fs = [{Mod,Func1,Arity} || {Func1,Arity} <- Fs0, Func1 =:= Func], dff(Name, Fs) catch _:_ -> {undef,Mod} end. --spec df(file:io_device() | file:filename(), module(), atom(), arity()) -> df_ret(). -df(Name, Mod, Func, Arity) when is_atom(Mod), is_atom(Func), is_integer(Arity) -> +-spec df(module(), atom(), arity()) -> df_ret(). + +df(Mod, Func, Arity) when is_atom(Mod), is_atom(Func) -> try Mod:module_info(functions) of Fs0 when is_list(Fs0) -> + Name = lists:concat([Mod, "_", Func, "_", Arity, ".dis"]), Fs = [{Mod,Func1,Arity1} || {Func1,Arity1} <- Fs0, Func1 =:= Func, Arity1 =:= Arity], dff(Name, Fs) catch _:_ -> {undef,Mod} end. -dff(File, Fs) when is_pid(File), is_list(Fs) -> - lists:foreach(fun(Mfa) -> - disassemble_function(File, Mfa), - io:nl(File) - end, Fs); -dff(Name, Fs) when is_list(Name) -> - case file:open(Name, [write]) of +-spec dis_to_file(module(), file:filename()) -> df_ret(). + +dis_to_file(Mod, Name) when is_atom(Mod) -> + try Mod:module_info(functions) of + Fs0 when is_list(Fs0) -> + Fs = [{Mod,Func,Arity} || {Func,Arity} <- Fs0], + dff(Name, Fs) + catch _:_ -> {undef,Mod} + end. + +dff(Name, Fs) -> + case file:open(Name, [write,raw,delayed_write]) of {ok,F} -> try - dff(F, Fs) + dff_1(F, Fs) after _ = file:close(F) end; @@ -403,12 +388,18 @@ dff(Name, Fs) when is_list(Name) -> {error,{badopen,Reason}} end. +dff_1(File, Fs) -> + lists:foreach(fun(Mfa) -> + disassemble_function(File, Mfa), + file:write(File, "\n") + end, Fs). + disassemble_function(File, {_,_,_}=MFA) -> cont_dis(File, erts_debug:disassemble(MFA), MFA). cont_dis(_, false, _) -> ok; cont_dis(File, {Addr,Str,MFA}, MFA) -> - io:put_chars(File, binary_to_list(Str)), + ok = file:write(File, Str), cont_dis(File, erts_debug:disassemble(Addr), MFA); cont_dis(_, {_,_,_}, _) -> ok. @@ -417,3 +408,90 @@ cont_dis(_, {_,_,_}, _) -> ok. map_info(_) -> erlang:nif_error(undef). + +%% Create file "lc_graph.<pid>" with all actual lock dependencies +%% recorded so far by the VM. +%% Needs debug VM or --enable-lock-checking config, returns 'notsup' otherwise. +lc_graph() -> + erts_debug:set_internal_state(available_internal_state, true), + erts_debug:get_internal_state(lc_graph). + +%% Convert "lc_graph.<pid>" file to https://www.graphviz.org dot format. +lc_graph_to_dot(OutFile, InFile) -> + {ok, [LL0]} = file:consult(InFile), + + [{"NO LOCK",0} | LL] = LL0, + Map = maps:from_list([{Id, Name} || {Name, Id, _, _} <- LL]), + + case file:open(OutFile, [exclusive]) of + {ok, Out} -> + ok = file:write(Out, "digraph G {\n"), + + [dot_print_lock(Out, Lck, Map) || Lck <- LL], + + ok = file:write(Out, "}\n"), + ok = file:close(Out); + + {error,eexist} -> + {"File already exists", OutFile} + end. + +dot_print_lock(Out, {_Name, Id, Lst, _}, Map) -> + [dot_print_edge(Out, From, Id, Map) || From <- Lst], + ok. + +dot_print_edge(_, 0, _, _) -> + ignore; % "NO LOCK" +dot_print_edge(Out, From, To, Map) -> + io:format(Out, "~p -> ~p;\n", [maps:get(From,Map), maps:get(To,Map)]). + + +%% Merge several "lc_graph" files into one file. +lc_graph_merge(OutFile, InFiles) -> + LLs = lists:map(fun(InFile) -> + {ok, [LL]} = file:consult(InFile), + LL + end, + InFiles), + + Res = lists:foldl(fun(A, B) -> lcg_merge(A, B) end, + hd(LLs), + tl(LLs)), + case file:open(OutFile, [exclusive]) of + {ok, Out} -> + try + lcg_print(Out, Res) + after + file:close(Out) + end, + ok; + {error, eexist} -> + {"File already exists", OutFile} + end. + +lcg_merge(A, B) -> + lists:zipwith(fun(LA, LB) -> lcg_merge_locks(LA, LB) end, + A, B). + +lcg_merge_locks(L, L) -> + L; +lcg_merge_locks({Name, Id, DA, IA}, {Name, Id, DB, IB}) -> + Direct = lists:umerge(DA, DB), + Indirect = lists:umerge(IA, IB), + {Name, Id, Direct, Indirect -- Direct}. + + +lcg_print(Out, LL) -> + io:format(Out, "[", []), + lcg_print_locks(Out, LL), + io:format(Out, "].\n", []), + ok. + +lcg_print_locks(Out, [{_,_}=NoLock | Rest]) -> + io:format(Out, "~p,\n", [NoLock]), + lcg_print_locks(Out, Rest); +lcg_print_locks(Out, [LastLock]) -> + io:format(Out, "~w", [LastLock]); +lcg_print_locks(Out, [Lock | Rest]) -> + io:format(Out, "~w,\n", [Lock]), + lcg_print_locks(Out, Rest). diff --git a/lib/kernel/src/file.erl b/lib/kernel/src/file.erl index 933f2d5f65..57d8fc7a15 100644 --- a/lib/kernel/src/file.erl +++ b/lib/kernel/src/file.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2017. All Rights Reserved. +%% Copyright Ericsson AB 1996-2018. 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,7 @@ io_device/0, name/0, name_all/0, posix/0]). %%% Includes and defines --include("file.hrl"). +-include("file_int.hrl"). -define(FILE_IO_SERVER_TABLE, file_io_servers). @@ -101,14 +101,25 @@ -type deep_list() :: [char() | atom() | deep_list()]. -type name() :: string() | atom() | deep_list(). -type name_all() :: string() | atom() | deep_list() | (RawFilename :: binary()). --type posix() :: 'eacces' | 'eagain' | 'ebadf' | 'ebusy' | 'edquot' - | 'eexist' | 'efault' | 'efbig' | 'eintr' | 'einval' - | 'eio' | 'eisdir' | 'eloop' | 'emfile' | 'emlink' - | 'enametoolong' - | 'enfile' | 'enodev' | 'enoent' | 'enomem' | 'enospc' - | 'enotblk' | 'enotdir' | 'enotsup' | 'enxio' | 'eperm' - | 'epipe' | 'erofs' | 'espipe' | 'esrch' | 'estale' - | 'exdev'. +-type posix() :: + 'eacces' | 'eagain' | + 'ebadf' | 'ebadmsg' | 'ebusy' | + 'edeadlk' | 'edeadlock' | 'edquot' | + 'eexist' | + 'efault' | 'efbig' | 'eftype' | + 'eintr' | 'einval' | 'eio' | 'eisdir' | + 'eloop' | + 'emfile' | 'emlink' | 'emultihop' | + 'enametoolong' | 'enfile' | + 'enobufs' | 'enodev' | 'enolck' | 'enolink' | 'enoent' | + 'enomem' | 'enospc' | 'enosr' | 'enostr' | 'enosys' | + 'enotblk' | 'enotdir' | 'enotsup' | 'enxio' | + 'eopnotsupp' | 'eoverflow' | + 'eperm' | 'epipe' | + 'erange' | 'erofs' | + 'espipe' | 'esrch' | 'estale' | + 'etxtbsy' | + 'exdev'. -type date_time() :: calendar:datetime(). -type posix_file_advise() :: 'normal' | 'sequential' | 'random' | 'no_reuse' | 'will_need' | 'dont_need'. @@ -454,41 +465,23 @@ raw_write_file_info(Name, #file_info{} = Info) -> Reason :: posix() | badarg | system_limit. open(Item, ModeList) when is_list(ModeList) -> - case lists:member(raw, ModeList) of - %% Raw file, use ?PRIM_FILE to handle this file - true -> + case {lists:member(raw, ModeList), lists:member(ram, ModeList)} of + {false, false} -> + %% File server file Args = [file_name(Item) | ModeList], case check_args(Args) of ok -> [FileName | _] = Args, - %% We rely on the returned Handle (in {ok, Handle}) - %% being a pid() or a #file_descriptor{} - ?PRIM_FILE:open(FileName, ModeList); + call(open, [FileName, ModeList]); Error -> Error - end; - false -> - case lists:member(ram, ModeList) of - %% RAM file, use ?RAM_FILE to handle this file - true -> - case check_args(ModeList) of - ok -> - ?RAM_FILE:open(Item, ModeList); - Error -> - Error - end; - %% File server file - false -> - Args = [file_name(Item) | ModeList], - case check_args(Args) of - ok -> - [FileName | _] = Args, - call(open, [FileName, ModeList]); - Error -> - Error - end - end + end; + {true, _Either} -> + raw_file_io:open(file_name(Item), ModeList); + {false, true} -> + ram_file:open(Item, ModeList) end; + %% Old obsolete mode specification in atom or 2-tuple format open(Item, Mode) -> open(Item, mode_list(Mode)). @@ -1254,15 +1247,18 @@ sendfile(File, _Sock, _Offet, _Bytes, _Opts) when is_pid(File) -> sendfile(File, Sock, Offset, Bytes, []) -> sendfile(File, Sock, Offset, Bytes, ?MAX_CHUNK_SIZE, [], [], []); sendfile(File, Sock, Offset, Bytes, Opts) -> - ChunkSize0 = proplists:get_value(chunk_size, Opts, ?MAX_CHUNK_SIZE), - ChunkSize = if ChunkSize0 > ?MAX_CHUNK_SIZE -> - ?MAX_CHUNK_SIZE; - true -> ChunkSize0 - end, - %% Support for headers, trailers and options has been removed because the - %% Darwin and BSD API for using it does not play nice with - %% non-blocking sockets. See unix_efile.c for more info. - sendfile(File, Sock, Offset, Bytes, ChunkSize, [], [], Opts). + try proplists:get_value(chunk_size, Opts, ?MAX_CHUNK_SIZE) of + ChunkSize0 when is_integer(ChunkSize0) -> + ChunkSize = erlang:min(ChunkSize0, ?MAX_CHUNK_SIZE), + %% Support for headers, trailers and options has been removed + %% because the Darwin and BSD API for using it does not play nice + %% with non-blocking sockets. See unix_efile.c for more info. + sendfile(File, Sock, Offset, Bytes, ChunkSize, [], [], Opts); + _Other -> + {error, badarg} + catch + error:_ -> {error, badarg} + end. %% sendfile/2 -spec sendfile(Filename, Socket) -> @@ -1397,8 +1393,8 @@ eval_stream2({ok,Form,EndLine}, Fd, H, Last, E, Bs0) -> try erl_eval:exprs(Form, Bs0) of {value,V,Bs} -> eval_stream(Fd, H, EndLine, {V}, E, Bs) - catch Class:Reason -> - Error = {EndLine,?MODULE,{Class,Reason,erlang:get_stacktrace()}}, + catch Class:Reason:StackTrace -> + Error = {EndLine,?MODULE,{Class,Reason,StackTrace}}, eval_stream(Fd, H, EndLine, Last, [Error|E], Bs0) end; eval_stream2({error,What,EndLine}, Fd, H, Last, E, Bs) -> diff --git a/lib/kernel/src/file_int.hrl b/lib/kernel/src/file_int.hrl new file mode 100644 index 0000000000..bafc330c04 --- /dev/null +++ b/lib/kernel/src/file_int.hrl @@ -0,0 +1,33 @@ +%% +%% %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% +%% + +%% +%% Internal definitions for the 'file' module and friends. +%% + +-ifndef(FILE_INTERNAL_HRL_). +-define(FILE_INTERNAL_HRL_, 1). + +-include("file.hrl"). + +-define(CALL_FD(Fd, Method, Args), + apply(Fd#file_descriptor.module, Method, [Fd | Args])). + +-endif. diff --git a/lib/kernel/src/file_io_server.erl b/lib/kernel/src/file_io_server.erl index deb7b315b1..34d5497a4a 100644 --- a/lib/kernel/src/file_io_server.erl +++ b/lib/kernel/src/file_io_server.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2000-2015. All Rights Reserved. +%% Copyright Ericsson AB 2000-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. @@ -28,7 +28,8 @@ -record(state, {handle,owner,mref,buf,read_mode,unic}). --define(PRIM_FILE, prim_file). +-include("file_int.hrl"). + -define(READ_SIZE_LIST, 128). -define(READ_SIZE_BINARY, (8*1024)). @@ -67,8 +68,9 @@ do_start(Spawn, Owner, FileName, ModeList) -> erlang:dt_restore_tag(Utag), %% process_flag(trap_exit, true), case parse_options(ModeList) of - {ReadMode, UnicodeMode, Opts} -> - case ?PRIM_FILE:open(FileName, Opts) of + {ReadMode, UnicodeMode, Opts0} -> + Opts = maybe_add_read_ahead(ReadMode, Opts0), + case raw_file_io:open(FileName, [raw | Opts]) of {error, Reason} = Error -> Self ! {Ref, Error}, exit(Reason); @@ -157,6 +159,24 @@ valid_enc({utf32,little}) -> valid_enc(_Other) -> {error,badarg}. +%% Add a small read_ahead buffer if the file is opened for reading +%% only in list mode and no read_ahead is already given. +maybe_add_read_ahead(binary, Opts) -> + Opts; +maybe_add_read_ahead(list, Opts) -> + P = fun(read_ahead) -> true; + ({read_ahead,_}) -> true; + (append) -> true; + (exclusive) -> true; + (write) -> true; + (_) -> false + end, + case lists:any(P, Opts) of + false -> + [{read_ahead, 4096}|Opts]; + true -> + Opts + end. server_loop(#state{mref = Mref} = State) -> receive @@ -205,7 +225,7 @@ io_reply(From, ReplyAs, Reply) -> file_request({advise,Offset,Length,Advise}, #state{handle=Handle}=State) -> - case ?PRIM_FILE:advise(Handle, Offset, Length, Advise) of + case ?CALL_FD(Handle, advise, [Offset, Length, Advise]) of {error,Reason}=Reply -> {stop,Reason,Reply,State}; Reply -> @@ -213,7 +233,7 @@ file_request({advise,Offset,Length,Advise}, end; file_request({allocate, Offset, Length}, #state{handle = Handle} = State) -> - Reply = ?PRIM_FILE:allocate(Handle, Offset, Length), + Reply = ?CALL_FD(Handle, allocate, [Offset, Length]), {reply, Reply, State}; file_request({pread,At,Sz}, State) when At =:= cur; @@ -256,7 +276,7 @@ file_request({pwrite,At,Data}, end; file_request(datasync, #state{handle=Handle}=State) -> - case ?PRIM_FILE:datasync(Handle) of + case ?CALL_FD(Handle, datasync, []) of {error,Reason}=Reply -> {stop,Reason,Reply,State}; Reply -> @@ -264,7 +284,7 @@ file_request(datasync, end; file_request(sync, #state{handle=Handle}=State) -> - case ?PRIM_FILE:sync(Handle) of + case ?CALL_FD(Handle, sync, []) of {error,Reason}=Reply -> {stop,Reason,Reply,State}; Reply -> @@ -272,7 +292,7 @@ file_request(sync, end; file_request(close, #state{handle=Handle}=State) -> - case ?PRIM_FILE:close(Handle) of + case ?CALL_FD(Handle, close, []) of {error,Reason}=Reply -> {stop,Reason,Reply,State#state{buf= <<>>}}; Reply -> @@ -288,7 +308,7 @@ file_request({position,At}, end; file_request(truncate, #state{handle=Handle}=State) -> - case ?PRIM_FILE:truncate(Handle) of + case ?CALL_FD(Handle, truncate, []) of {error,Reason}=Reply -> {stop,Reason,Reply,State#state{buf= <<>>}}; Reply -> @@ -398,7 +418,7 @@ io_request_loop([Request|Tail], %% put_chars(Chars, latin1, #state{handle=Handle, unic=latin1}=State) -> NewState = State#state{buf = <<>>}, - case ?PRIM_FILE:write(Handle, Chars) of + case ?CALL_FD(Handle, write, [Chars]) of {error,Reason}=Reply -> {stop,Reason,Reply,NewState}; Reply -> @@ -408,7 +428,7 @@ put_chars(Chars, InEncoding, #state{handle=Handle, unic=OutEncoding}=State) -> NewState = State#state{buf = <<>>}, case unicode:characters_to_binary(Chars,InEncoding,OutEncoding) of Bin when is_binary(Bin) -> - case ?PRIM_FILE:write(Handle, Bin) of + case ?CALL_FD(Handle, write, [Bin]) of {error,Reason}=Reply -> {stop,Reason,Reply,NewState}; Reply -> @@ -422,7 +442,7 @@ put_chars(Chars, InEncoding, #state{handle=Handle, unic=OutEncoding}=State) -> get_line(S, {<<>>, Cont}, OutEnc, #state{handle=Handle, read_mode=Mode, unic=InEnc}=State) -> - case ?PRIM_FILE:read(Handle, read_size(Mode)) of + case ?CALL_FD(Handle, read, [read_size(Mode)]) of {ok,Bin} -> get_line(S, convert_enc([Cont, Bin], InEnc, OutEnc), OutEnc, State); eof -> @@ -472,7 +492,7 @@ get_chars(N, OutEnc,#state{handle=Handle,buf=Buf,read_mode=ReadMode,unic=latin1} BufSize = byte_size(Buf), NeedSize = N-BufSize, Size = erlang:max(NeedSize, ?READ_SIZE_BINARY), - case ?PRIM_FILE:read(Handle, Size) of + case ?CALL_FD(Handle, read, [Size]) of {ok, B} -> if BufSize+byte_size(B) < N -> std_reply(cat(Buf, B, ReadMode,latin1,OutEnc), State); @@ -504,7 +524,7 @@ get_chars(N, OutEnc,#state{handle=Handle,buf=Buf,read_mode=ReadMode,unic=InEncod %% Need more, Try to read 4*needed in bytes... NeedSize = (N - BufCount) * 4, Size = erlang:max(NeedSize, ?READ_SIZE_BINARY), - case ?PRIM_FILE:read(Handle, Size) of + case ?CALL_FD(Handle, read, [Size]) of {ok, B} -> NewBuf = list_to_binary([Buf,B]), {NewCount,NewSplit} = count_and_find(NewBuf,N,InEncoding), @@ -544,7 +564,7 @@ get_chars(Mod, Func, XtraArg, OutEnc, #state{buf=Buf}=State) -> get_chars_empty(Mod, Func, XtraArg, S, latin1, #state{handle=Handle,read_mode=ReadMode, unic=latin1}=State) -> - case ?PRIM_FILE:read(Handle, read_size(ReadMode)) of + case ?CALL_FD(Handle, read, [read_size(ReadMode)]) of {ok,Bin} -> get_chars_apply(Mod, Func, XtraArg, S, latin1, State, Bin); eof -> @@ -554,7 +574,7 @@ get_chars_empty(Mod, Func, XtraArg, S, latin1, end; get_chars_empty(Mod, Func, XtraArg, S, OutEnc, #state{handle=Handle,read_mode=ReadMode}=State) -> - case ?PRIM_FILE:read(Handle, read_size(ReadMode)) of + case ?CALL_FD(Handle, read, [read_size(ReadMode)]) of {ok,Bin} -> get_chars_apply(Mod, Func, XtraArg, S, OutEnc, State, Bin); eof -> @@ -564,7 +584,7 @@ get_chars_empty(Mod, Func, XtraArg, S, OutEnc, end. get_chars_notempty(Mod, Func, XtraArg, S, OutEnc, #state{handle=Handle,read_mode=ReadMode,buf = B}=State) -> - case ?PRIM_FILE:read(Handle, read_size(ReadMode)) of + case ?CALL_FD(Handle, read, [read_size(ReadMode)]) of {ok,Bin} -> get_chars_apply(Mod, Func, XtraArg, S, OutEnc, State, list_to_binary([B,Bin])); eof -> @@ -918,13 +938,10 @@ cbv({utf32,little},_) -> %% Compensates ?PRIM_FILE:position/2 for the number of bytes %% we have buffered position(Handle, At, Buf) -> - ?PRIM_FILE:position( - Handle, - case At of - cur -> - {cur, -byte_size(Buf)}; - {cur, Offs} -> - {cur, Offs-byte_size(Buf)}; - _ -> - At - end). + SeekTo = + case At of + {cur, Offs} -> {cur, Offs-byte_size(Buf)}; + cur -> {cur, -byte_size(Buf)}; + _ -> At + end, + ?CALL_FD(Handle, position, [SeekTo]). diff --git a/lib/kernel/src/file_server.erl b/lib/kernel/src/file_server.erl index 6e8f64d932..ecc1ffbdd6 100644 --- a/lib/kernel/src/file_server.erl +++ b/lib/kernel/src/file_server.erl @@ -63,7 +63,7 @@ stop() -> %%% Callback functions from gen_server %%%---------------------------------------------------------------------- --type state() :: port(). % Internal type +-type state() :: term(). % Internal type %%---------------------------------------------------------------------- %% Func: init/1 @@ -77,14 +77,8 @@ stop() -> init([]) -> process_flag(trap_exit, true), - case ?PRIM_FILE:start() of - {ok, Handle} -> - ?FILE_IO_SERVER_TABLE = - ets:new(?FILE_IO_SERVER_TABLE, [named_table]), - {ok, Handle}; - {error, Reason} -> - {stop, Reason} - end. + ?FILE_IO_SERVER_TABLE = ets:new(?FILE_IO_SERVER_TABLE, [named_table]), + {ok, undefined}. %%---------------------------------------------------------------------- %% Func: handle_call/3 @@ -101,7 +95,7 @@ init([]) -> {'reply', 'eof' | 'ok' | {'error', term()} | {'ok', term()}, state()} | {'stop', 'normal', 'stopped', state()}. -handle_call({open, Name, ModeList}, {Pid, _Tag} = _From, Handle) +handle_call({open, Name, ModeList}, {Pid, _Tag} = _From, State) when is_list(ModeList) -> Child = ?FILE_IO_SERVER:start_link(Pid, Name, ModeList), case Child of @@ -110,78 +104,78 @@ handle_call({open, Name, ModeList}, {Pid, _Tag} = _From, Handle) _ -> ok end, - {reply, Child, Handle}; + {reply, Child, State}; -handle_call({open, _Name, _Mode}, _From, Handle) -> - {reply, {error, einval}, Handle}; +handle_call({open, _Name, _Mode}, _From, State) -> + {reply, {error, einval}, State}; -handle_call({read_file, Name}, _From, Handle) -> - {reply, ?PRIM_FILE:read_file(Name), Handle}; +handle_call({read_file, Name}, _From, State) -> + {reply, ?PRIM_FILE:read_file(Name), State}; -handle_call({write_file, Name, Bin}, _From, Handle) -> - {reply, ?PRIM_FILE:write_file(Name, Bin), Handle}; +handle_call({write_file, Name, Bin}, _From, State) -> + {reply, ?PRIM_FILE:write_file(Name, Bin), State}; -handle_call({set_cwd, Name}, _From, Handle) -> - {reply, ?PRIM_FILE:set_cwd(Handle, Name), Handle}; +handle_call({set_cwd, Name}, _From, State) -> + {reply, ?PRIM_FILE:set_cwd(Name), State}; -handle_call({delete, Name}, _From, Handle) -> - {reply, ?PRIM_FILE:delete(Handle, Name), Handle}; +handle_call({delete, Name}, _From, State) -> + {reply, ?PRIM_FILE:delete(Name), State}; -handle_call({rename, Fr, To}, _From, Handle) -> - {reply, ?PRIM_FILE:rename(Handle, Fr, To), Handle}; +handle_call({rename, Fr, To}, _From, State) -> + {reply, ?PRIM_FILE:rename(Fr, To), State}; -handle_call({make_dir, Name}, _From, Handle) -> - {reply, ?PRIM_FILE:make_dir(Handle, Name), Handle}; +handle_call({make_dir, Name}, _From, State) -> + {reply, ?PRIM_FILE:make_dir(Name), State}; -handle_call({del_dir, Name}, _From, Handle) -> - {reply, ?PRIM_FILE:del_dir(Handle, Name), Handle}; +handle_call({del_dir, Name}, _From, State) -> + {reply, ?PRIM_FILE:del_dir(Name), State}; -handle_call({list_dir, Name}, _From, Handle) -> - {reply, ?PRIM_FILE:list_dir(Handle, Name), Handle}; -handle_call({list_dir_all, Name}, _From, Handle) -> - {reply, ?PRIM_FILE:list_dir_all(Handle, Name), Handle}; +handle_call({list_dir, Name}, _From, State) -> + {reply, ?PRIM_FILE:list_dir(Name), State}; +handle_call({list_dir_all, Name}, _From, State) -> + {reply, ?PRIM_FILE:list_dir_all(Name), State}; -handle_call(get_cwd, _From, Handle) -> - {reply, ?PRIM_FILE:get_cwd(Handle), Handle}; -handle_call({get_cwd}, _From, Handle) -> - {reply, ?PRIM_FILE:get_cwd(Handle), Handle}; -handle_call({get_cwd, Name}, _From, Handle) -> - {reply, ?PRIM_FILE:get_cwd(Handle, Name), Handle}; +handle_call(get_cwd, _From, State) -> + {reply, ?PRIM_FILE:get_cwd(), State}; +handle_call({get_cwd}, _From, State) -> + {reply, ?PRIM_FILE:get_cwd(), State}; +handle_call({get_cwd, Name}, _From, State) -> + {reply, ?PRIM_FILE:get_cwd(Name), State}; -handle_call({read_file_info, Name}, _From, Handle) -> - {reply, ?PRIM_FILE:read_file_info(Handle, Name), Handle}; +handle_call({read_file_info, Name}, _From, State) -> + {reply, ?PRIM_FILE:read_file_info(Name), State}; -handle_call({read_file_info, Name, Opts}, _From, Handle) -> - {reply, ?PRIM_FILE:read_file_info(Handle, Name, Opts), Handle}; +handle_call({read_file_info, Name, Opts}, _From, State) -> + {reply, ?PRIM_FILE:read_file_info(Name, Opts), State}; -handle_call({altname, Name}, _From, Handle) -> - {reply, ?PRIM_FILE:altname(Handle, Name), Handle}; +handle_call({altname, Name}, _From, State) -> + {reply, ?PRIM_FILE:altname(Name), State}; -handle_call({write_file_info, Name, Info}, _From, Handle) -> - {reply, ?PRIM_FILE:write_file_info(Handle, Name, Info), Handle}; +handle_call({write_file_info, Name, Info}, _From, State) -> + {reply, ?PRIM_FILE:write_file_info(Name, Info), State}; -handle_call({write_file_info, Name, Info, Opts}, _From, Handle) -> - {reply, ?PRIM_FILE:write_file_info(Handle, Name, Info, Opts), Handle}; +handle_call({write_file_info, Name, Info, Opts}, _From, State) -> + {reply, ?PRIM_FILE:write_file_info(Name, Info, Opts), State}; -handle_call({read_link_info, Name}, _From, Handle) -> - {reply, ?PRIM_FILE:read_link_info(Handle, Name), Handle}; +handle_call({read_link_info, Name}, _From, State) -> + {reply, ?PRIM_FILE:read_link_info(Name), State}; -handle_call({read_link_info, Name, Opts}, _From, Handle) -> - {reply, ?PRIM_FILE:read_link_info(Handle, Name, Opts), Handle}; +handle_call({read_link_info, Name, Opts}, _From, State) -> + {reply, ?PRIM_FILE:read_link_info(Name, Opts), State}; -handle_call({read_link, Name}, _From, Handle) -> - {reply, ?PRIM_FILE:read_link(Handle, Name), Handle}; -handle_call({read_link_all, Name}, _From, Handle) -> - {reply, ?PRIM_FILE:read_link_all(Handle, Name), Handle}; +handle_call({read_link, Name}, _From, State) -> + {reply, ?PRIM_FILE:read_link(Name), State}; +handle_call({read_link_all, Name}, _From, State) -> + {reply, ?PRIM_FILE:read_link_all(Name), State}; -handle_call({make_link, Old, New}, _From, Handle) -> - {reply, ?PRIM_FILE:make_link(Handle, Old, New), Handle}; +handle_call({make_link, Old, New}, _From, State) -> + {reply, ?PRIM_FILE:make_link(Old, New), State}; -handle_call({make_symlink, Old, New}, _From, Handle) -> - {reply, ?PRIM_FILE:make_symlink(Handle, Old, New), Handle}; +handle_call({make_symlink, Old, New}, _From, State) -> + {reply, ?PRIM_FILE:make_symlink(Old, New), State}; handle_call({copy, SourceName, SourceOpts, DestName, DestOpts, Length}, - _From, Handle) -> + _From, State) -> Reply = case ?PRIM_FILE:open(SourceName, [read, binary | SourceOpts]) of {ok, Source} -> @@ -201,14 +195,14 @@ handle_call({copy, SourceName, SourceOpts, DestName, DestOpts, Length}, {error, _} = Error -> Error end, - {reply, Reply, Handle}; + {reply, Reply, State}; -handle_call(stop, _From, Handle) -> - {stop, normal, stopped, Handle}; +handle_call(stop, _From, State) -> + {stop, normal, stopped, State}; -handle_call(Request, From, Handle) -> +handle_call(Request, From, State) -> error_logger:error_msg("handle_call(~tp, ~tp, _)", [Request, From]), - {noreply, Handle}. + {noreply, State}. %%---------------------------------------------------------------------- %% Func: handle_cast/2 @@ -233,14 +227,9 @@ handle_cast(Msg, State) -> -spec handle_info(term(), state()) -> {'noreply', state()} | {'stop', 'normal', state()}. -handle_info({'EXIT', Pid, _Reason}, Handle) when is_pid(Pid) -> +handle_info({'EXIT', Pid, _Reason}, State) when is_pid(Pid) -> ets:delete(?FILE_IO_SERVER_TABLE, Pid), - {noreply, Handle}; - -handle_info({'EXIT', Handle, _Reason}, Handle) -> - error_logger:error_msg("Port controlling ~w terminated in ~w", - [?FILE_SERVER, ?MODULE]), - {stop, normal, Handle}; + {noreply, State}; handle_info(Info, State) -> error_logger:error_msg("handle_Info(~tp, _)", [Info]), @@ -254,8 +243,8 @@ handle_info(Info, State) -> -spec terminate(term(), state()) -> 'ok'. -terminate(_Reason, Handle) -> - ?PRIM_FILE:stop(Handle). +terminate(_Reason, _State) -> + ok. %%---------------------------------------------------------------------- %% Func: code_change/3 diff --git a/lib/kernel/src/group.erl b/lib/kernel/src/group.erl index bf785959ff..2c0518ccad 100644 --- a/lib/kernel/src/group.erl +++ b/lib/kernel/src/group.erl @@ -114,7 +114,7 @@ server_loop(Drv, Shell, Buf0) -> {io_request,From,ReplyAs,Req} when is_pid(From) -> %% This io_request may cause a transition to a couple of %% selective receive loops elsewhere in this module. - Buf = io_request(Req, From, ReplyAs, Drv, Buf0), + Buf = io_request(Req, From, ReplyAs, Drv, Shell, Buf0), server_loop(Drv, Shell, Buf); {reply,{{From,ReplyAs},Reply}} -> io_reply(From, ReplyAs, Reply), @@ -135,7 +135,7 @@ server_loop(Drv, Shell, Buf0) -> exit(R); %% We want to throw away any term that we don't handle (standard %% practice in receive loops), but not any {Drv,_} tuples which are - %% handled in io_request/5. + %% handled in io_request/6. NotDrvTuple when (not is_tuple(NotDrvTuple)) orelse (tuple_size(NotDrvTuple) =/= 2) orelse (element(1, NotDrvTuple) =/= Drv) -> @@ -177,8 +177,8 @@ set_unicode_state(Drv,Bool) -> end. -io_request(Req, From, ReplyAs, Drv, Buf0) -> - case io_request(Req, Drv, {From,ReplyAs}, Buf0) of +io_request(Req, From, ReplyAs, Drv, Shell, Buf0) -> + case io_request(Req, Drv, Shell, {From,ReplyAs}, Buf0) of {ok,Reply,Buf} -> io_reply(From, ReplyAs, Reply), Buf; @@ -208,7 +208,7 @@ io_request(Req, From, ReplyAs, Drv, Buf0) -> %% %% These put requests have to be synchronous to the driver as otherwise %% there is no guarantee that the data has actually been printed. -io_request({put_chars,unicode,Chars}, Drv, From, Buf) -> +io_request({put_chars,unicode,Chars}, Drv, _Shell, From, Buf) -> case catch unicode:characters_to_binary(Chars,utf8) of Binary when is_binary(Binary) -> send_drv(Drv, {put_chars_sync, unicode, Binary, {From,ok}}), @@ -216,7 +216,7 @@ io_request({put_chars,unicode,Chars}, Drv, From, Buf) -> _ -> {error,{error,{put_chars, unicode,Chars}},Buf} end; -io_request({put_chars,unicode,M,F,As}, Drv, From, Buf) -> +io_request({put_chars,unicode,M,F,As}, Drv, _Shell, From, Buf) -> case catch apply(M, F, As) of Binary when is_binary(Binary) -> send_drv(Drv, {put_chars_sync, unicode, Binary, {From,ok}}), @@ -230,12 +230,12 @@ io_request({put_chars,unicode,M,F,As}, Drv, From, Buf) -> {error,{error,F},Buf} end end; -io_request({put_chars,latin1,Binary}, Drv, From, Buf) when is_binary(Binary) -> +io_request({put_chars,latin1,Binary}, Drv, _Shell, From, Buf) when is_binary(Binary) -> send_drv(Drv, {put_chars_sync, unicode, unicode:characters_to_binary(Binary,latin1), {From,ok}}), {noreply,Buf}; -io_request({put_chars,latin1,Chars}, Drv, From, Buf) -> +io_request({put_chars,latin1,Chars}, Drv, _Shell, From, Buf) -> case catch unicode:characters_to_binary(Chars,latin1) of Binary when is_binary(Binary) -> send_drv(Drv, {put_chars_sync, unicode, Binary, {From,ok}}), @@ -243,7 +243,7 @@ io_request({put_chars,latin1,Chars}, Drv, From, Buf) -> _ -> {error,{error,{put_chars,latin1,Chars}},Buf} end; -io_request({put_chars,latin1,M,F,As}, Drv, From, Buf) -> +io_request({put_chars,latin1,M,F,As}, Drv, _Shell, From, Buf) -> case catch apply(M, F, As) of Binary when is_binary(Binary) -> send_drv(Drv, {put_chars_sync, unicode, @@ -260,30 +260,30 @@ io_request({put_chars,latin1,M,F,As}, Drv, From, Buf) -> end end; -io_request({get_chars,Encoding,Prompt,N}, Drv, _From, Buf) -> - get_chars(Prompt, io_lib, collect_chars, N, Drv, Buf, Encoding); -io_request({get_line,Encoding,Prompt}, Drv, _From, Buf) -> - get_chars(Prompt, io_lib, collect_line, [], Drv, Buf, Encoding); -io_request({get_until,Encoding, Prompt,M,F,As}, Drv, _From, Buf) -> - get_chars(Prompt, io_lib, get_until, {M,F,As}, Drv, Buf, Encoding); -io_request({get_password,_Encoding},Drv,_From,Buf) -> - get_password_chars(Drv, Buf); -io_request({setopts,Opts}, Drv, _From, Buf) when is_list(Opts) -> +io_request({get_chars,Encoding,Prompt,N}, Drv, Shell, _From, Buf) -> + get_chars_n(Prompt, io_lib, collect_chars, N, Drv, Shell, Buf, Encoding); +io_request({get_line,Encoding,Prompt}, Drv, Shell, _From, Buf) -> + get_chars_line(Prompt, io_lib, collect_line, [], Drv, Shell, Buf, Encoding); +io_request({get_until,Encoding, Prompt,M,F,As}, Drv, Shell, _From, Buf) -> + get_chars_line(Prompt, io_lib, get_until, {M,F,As}, Drv, Shell, Buf, Encoding); +io_request({get_password,_Encoding},Drv,Shell,_From,Buf) -> + get_password_chars(Drv, Shell, Buf); +io_request({setopts,Opts}, Drv, _Shell, _From, Buf) when is_list(Opts) -> setopts(Opts, Drv, Buf); -io_request(getopts, Drv, _From, Buf) -> +io_request(getopts, Drv, _Shell, _From, Buf) -> getopts(Drv, Buf); -io_request({requests,Reqs}, Drv, From, Buf) -> - io_requests(Reqs, {ok,ok,Buf}, From, Drv); +io_request({requests,Reqs}, Drv, Shell, From, Buf) -> + io_requests(Reqs, {ok,ok,Buf}, From, Drv, Shell); %% New in R12 -io_request({get_geometry,columns},Drv,_From,Buf) -> +io_request({get_geometry,columns},Drv,_Shell,_From,Buf) -> case get_tty_geometry(Drv) of {W,_H} -> {ok,W,Buf}; _ -> {error,{error,enotsup},Buf} end; -io_request({get_geometry,rows},Drv,_From,Buf) -> +io_request({get_geometry,rows},Drv,_Shell,_From,Buf) -> case get_tty_geometry(Drv) of {_W,H} -> {ok,H,Buf}; @@ -292,40 +292,40 @@ io_request({get_geometry,rows},Drv,_From,Buf) -> end; %% BC with pre-R13 -io_request({put_chars,Chars}, Drv, From, Buf) -> - io_request({put_chars,latin1,Chars}, Drv, From, Buf); -io_request({put_chars,M,F,As}, Drv, From, Buf) -> - io_request({put_chars,latin1,M,F,As}, Drv, From, Buf); -io_request({get_chars,Prompt,N}, Drv, From, Buf) -> - io_request({get_chars,latin1,Prompt,N}, Drv, From, Buf); -io_request({get_line,Prompt}, Drv, From, Buf) -> - io_request({get_line,latin1,Prompt}, Drv, From, Buf); -io_request({get_until, Prompt,M,F,As}, Drv, From, Buf) -> - io_request({get_until,latin1, Prompt,M,F,As}, Drv, From, Buf); -io_request(get_password,Drv,From,Buf) -> - io_request({get_password,latin1},Drv,From,Buf); - - - -io_request(_, _Drv, _From, Buf) -> +io_request({put_chars,Chars}, Drv, Shell, From, Buf) -> + io_request({put_chars,latin1,Chars}, Drv, Shell, From, Buf); +io_request({put_chars,M,F,As}, Drv, Shell, From, Buf) -> + io_request({put_chars,latin1,M,F,As}, Drv, Shell, From, Buf); +io_request({get_chars,Prompt,N}, Drv, Shell, From, Buf) -> + io_request({get_chars,latin1,Prompt,N}, Drv, Shell, From, Buf); +io_request({get_line,Prompt}, Drv, Shell, From, Buf) -> + io_request({get_line,latin1,Prompt}, Drv, Shell, From, Buf); +io_request({get_until, Prompt,M,F,As}, Drv, Shell, From, Buf) -> + io_request({get_until,latin1, Prompt,M,F,As}, Drv, Shell, From, Buf); +io_request(get_password,Drv,Shell,From,Buf) -> + io_request({get_password,latin1},Drv,Shell,From,Buf); + + + +io_request(_, _Drv, _Shell, _From, Buf) -> {error,{error,request},Buf}. -%% Status = io_requests(RequestList, PrevStat, From, Drv) +%% Status = io_requests(RequestList, PrevStat, From, Drv, Shell) %% Process a list of output requests as long as %% the previous status is 'ok' or noreply. %% %% We use undefined as the From for all but the last request %% in order to discards acknowledgements from those requests. %% -io_requests([R|Rs], {noreply,Buf}, From, Drv) -> +io_requests([R|Rs], {noreply,Buf}, From, Drv, Shell) -> ReqFrom = if Rs =:= [] -> From; true -> undefined end, - io_requests(Rs, io_request(R, Drv, ReqFrom, Buf), From, Drv); -io_requests([R|Rs], {ok,ok,Buf}, From, Drv) -> + io_requests(Rs, io_request(R, Drv, Shell, ReqFrom, Buf), From, Drv, Shell); +io_requests([R|Rs], {ok,ok,Buf}, From, Drv, Shell) -> ReqFrom = if Rs =:= [] -> From; true -> undefined end, - io_requests(Rs, io_request(R, Drv, ReqFrom, Buf), From, Drv); -io_requests([_|_], Error, _From, _Drv) -> + io_requests(Rs, io_request(R, Drv, Shell, ReqFrom, Buf), From, Drv, Shell); +io_requests([_|_], Error, _From, _Drv, _Shell) -> Error; -io_requests([], Stat, _From, _) -> +io_requests([], Stat, _From, _, _Shell) -> Stat. %% io_reply(From, ReplyAs, Reply) @@ -333,7 +333,7 @@ io_requests([], Stat, _From, _) -> %% The ACK contains the return value. io_reply(undefined, _ReplyAs, _Reply) -> - %% Ignore these replies as they are generated from io_requests/4. + %% Ignore these replies as they are generated from io_requests/5. ok; io_reply(From, ReplyAs, Reply) -> From ! {io_reply,ReplyAs,Reply}, @@ -434,7 +434,7 @@ getopts(Drv,Buf) -> {ok,[Exp,Echo,Bin,Uni],Buf}. -%% get_chars(Prompt, Module, Function, XtraArgument, Drv, Buffer) +%% get_chars_*(Prompt, Module, Function, XtraArgument, Drv, Buffer) %% Gets characters from the input Drv until as the applied function %% returns {stop,Result,Rest}. Does not block output until input has been %% received. @@ -442,8 +442,8 @@ getopts(Drv,Buf) -> %% {Result,NewSaveBuffer} %% {error,What,NewSaveBuffer} -get_password_chars(Drv,Buf) -> - case get_password_line(Buf, Drv) of +get_password_chars(Drv,Shell,Buf) -> + case get_password_line(Buf, Drv, Shell) of {done, Line, Buf1} -> {ok, Line, Buf1}; interrupted -> @@ -452,36 +452,62 @@ get_password_chars(Drv,Buf) -> {exit, terminated} end. -get_chars(Prompt, M, F, Xa, Drv, Buf, Encoding) -> +get_chars_n(Prompt, M, F, Xa, Drv, Shell, Buf, Encoding) -> Pbs = prompt_bytes(Prompt, Encoding), - get_chars_loop(Pbs, M, F, Xa, Drv, Buf, start, Encoding). + case get(echo) of + true -> + get_chars_loop(Pbs, M, F, Xa, Drv, Shell, Buf, start, Encoding); + false -> + get_chars_n_loop(Pbs, M, F, Xa, Drv, Shell, Buf, start, Encoding) + end. + +get_chars_line(Prompt, M, F, Xa, Drv, Shell, Buf, Encoding) -> + Pbs = prompt_bytes(Prompt, Encoding), + get_chars_loop(Pbs, M, F, Xa, Drv, Shell, Buf, start, Encoding). -get_chars_loop(Pbs, M, F, Xa, Drv, Buf0, State, Encoding) -> - Result = case get(echo) of +get_chars_loop(Pbs, M, F, Xa, Drv, Shell, Buf0, State, Encoding) -> + Result = case get(echo) of true -> - get_line(Buf0, Pbs, Drv, Encoding); + get_line(Buf0, Pbs, Drv, Shell, Encoding); false -> % get_line_echo_off only deals with lists % and does not need encoding... - get_line_echo_off(Buf0, Pbs, Drv) + get_line_echo_off(Buf0, Pbs, Drv, Shell) end, case Result of - {done,Line,Buf1} -> - get_chars_apply(Pbs, M, F, Xa, Drv, Buf1, State, Line, Encoding); + {done,Line,Buf} -> + get_chars_apply(Pbs, M, F, Xa, Drv, Shell, Buf, State, Line, Encoding); interrupted -> {error,{error,interrupted},[]}; terminated -> {exit,terminated} end. -get_chars_apply(Pbs, M, F, Xa, Drv, Buf, State0, Line, Encoding) -> +get_chars_apply(Pbs, M, F, Xa, Drv, Shell, Buf, State0, Line, Encoding) -> case catch M:F(State0, cast(Line,get(read_mode), Encoding), Encoding, Xa) of - {stop,Result,Rest} -> - {ok,Result,append(Rest, Buf, Encoding)}; - {'EXIT',_} -> - {error,{error,err_func(M, F, Xa)},[]}; - State1 -> - get_chars_loop(Pbs, M, F, Xa, Drv, Buf, State1, Encoding) + {stop,Result,Rest} -> + {ok,Result,append(Rest, Buf, Encoding)}; + {'EXIT',_} -> + {error,{error,err_func(M, F, Xa)},[]}; + State1 -> + get_chars_loop(Pbs, M, F, Xa, Drv, Shell, Buf, State1, Encoding) + end. + +get_chars_n_loop(Pbs, M, F, Xa, Drv, Shell, Buf0, State, Encoding) -> + try M:F(State, cast(Buf0, get(read_mode), Encoding), Encoding, Xa) of + {stop,Result,Rest} -> + {ok, Result, Rest}; + State1 -> + case get_chars_echo_off(Pbs, Drv, Shell) of + interrupted -> + {error,{error,interrupted},[]}; + terminated -> + {exit,terminated}; + Buf -> + get_chars_n_loop(Pbs, M, F, Xa, Drv, Shell, Buf, State1, Encoding) + end + catch _:_ -> + {error,{error,err_func(M, F, Xa)},[]} end. %% Convert error code to make it look as before @@ -497,24 +523,24 @@ err_func(_, F, _) -> %% {done,LineChars,RestChars} %% interrupted -get_line(Chars, Pbs, Drv, Encoding) -> +get_line(Chars, Pbs, Drv, Shell, Encoding) -> {more_chars,Cont,Rs} = edlin:start(Pbs), send_drv_reqs(Drv, Rs), - get_line1(edlin:edit_line(Chars, Cont), Drv, new_stack(get(line_buffer)), + get_line1(edlin:edit_line(Chars, Cont), Drv, Shell, new_stack(get(line_buffer)), Encoding). -get_line1({done,Line,Rest,Rs}, Drv, Ls, _Encoding) -> +get_line1({done,Line,Rest,Rs}, Drv, _Shell, Ls, _Encoding) -> send_drv_reqs(Drv, Rs), save_line_buffer(Line, get_lines(Ls)), {done,Line,Rest}; -get_line1({undefined,{_A,Mode,Char},Cs,Cont,Rs}, Drv, Ls0, Encoding) +get_line1({undefined,{_A,Mode,Char},Cs,Cont,Rs}, Drv, Shell, Ls0, Encoding) when ((Mode =:= none) and (Char =:= $\^P)) or ((Mode =:= meta_left_sq_bracket) and (Char =:= $A)) -> send_drv_reqs(Drv, Rs), case up_stack(save_line(Ls0, edlin:current_line(Cont))) of {none,_Ls} -> send_drv(Drv, beep), - get_line1(edlin:edit_line(Cs, Cont), Drv, Ls0, Encoding); + get_line1(edlin:edit_line(Cs, Cont), Drv, Shell, Ls0, Encoding); {Lcs,Ls} -> send_drv_reqs(Drv, edlin:erase_line(Cont)), {more_chars,Ncont,Nrs} = edlin:start(edlin:prompt(Cont)), @@ -522,16 +548,17 @@ get_line1({undefined,{_A,Mode,Char},Cs,Cont,Rs}, Drv, Ls0, Encoding) get_line1(edlin:edit_line1(lists:sublist(Lcs, 1, length(Lcs)-1), Ncont), Drv, + Shell, Ls, Encoding) end; -get_line1({undefined,{_A,Mode,Char},Cs,Cont,Rs}, Drv, Ls0, Encoding) +get_line1({undefined,{_A,Mode,Char},Cs,Cont,Rs}, Drv, Shell, Ls0, Encoding) when ((Mode =:= none) and (Char =:= $\^N)) or ((Mode =:= meta_left_sq_bracket) and (Char =:= $B)) -> send_drv_reqs(Drv, Rs), case down_stack(save_line(Ls0, edlin:current_line(Cont))) of {none,_Ls} -> send_drv(Drv, beep), - get_line1(edlin:edit_line(Cs, Cont), Drv, Ls0, Encoding); + get_line1(edlin:edit_line(Cs, Cont), Drv, Shell, Ls0, Encoding); {Lcs,Ls} -> send_drv_reqs(Drv, edlin:erase_line(Cont)), {more_chars,Ncont,Nrs} = edlin:start(edlin:prompt(Cont)), @@ -539,6 +566,7 @@ get_line1({undefined,{_A,Mode,Char},Cs,Cont,Rs}, Drv, Ls0, Encoding) get_line1(edlin:edit_line1(lists:sublist(Lcs, 1, length(Lcs)-1), Ncont), Drv, + Shell, Ls, Encoding) end; %% ^R = backward search, ^S = forward search. @@ -551,7 +579,7 @@ get_line1({undefined,{_A,Mode,Char},Cs,Cont,Rs}, Drv, Ls0, Encoding) %% new modes: search, search_quit, search_found. These are added to %% the regular ones (none, meta_left_sq_bracket) and handle special %% cases of history search. -get_line1({undefined,{_A,Mode,Char},Cs,Cont,Rs}, Drv, Ls, Encoding) +get_line1({undefined,{_A,Mode,Char},Cs,Cont,Rs}, Drv, Shell, Ls, Encoding) when ((Mode =:= none) and (Char =:= $\^R)) -> send_drv_reqs(Drv, Rs), %% drop current line, move to search mode. We store the current @@ -561,8 +589,8 @@ get_line1({undefined,{_A,Mode,Char},Cs,Cont,Rs}, Drv, Ls, Encoding) Pbs = prompt_bytes("(search)`': ", Encoding), {more_chars,Ncont,Nrs} = edlin:start(Pbs, search), send_drv_reqs(Drv, Nrs), - get_line1(edlin:edit_line1(Cs, Ncont), Drv, Ls, Encoding); -get_line1({expand, Before, Cs0, Cont,Rs}, Drv, Ls0, Encoding) -> + get_line1(edlin:edit_line1(Cs, Ncont), Drv, Shell, Ls, Encoding); +get_line1({expand, Before, Cs0, Cont,Rs}, Drv, Shell, Ls0, Encoding) -> send_drv_reqs(Drv, Rs), ExpandFun = get(expand_fun), {Found, Add, Matches} = ExpandFun(Before), @@ -577,37 +605,37 @@ get_line1({expand, Before, Cs0, Cont,Rs}, Drv, Ls0, Encoding) -> send_drv(Drv, {put_chars, unicode, unicode:characters_to_binary(MatchStr,unicode)}), [$\^L | Cs1] end, - get_line1(edlin:edit_line(Cs, Cont), Drv, Ls0, Encoding); -get_line1({undefined,_Char,Cs,Cont,Rs}, Drv, Ls, Encoding) -> + get_line1(edlin:edit_line(Cs, Cont), Drv, Shell, Ls0, Encoding); +get_line1({undefined,_Char,Cs,Cont,Rs}, Drv, Shell, Ls, Encoding) -> send_drv_reqs(Drv, Rs), send_drv(Drv, beep), - get_line1(edlin:edit_line(Cs, Cont), Drv, Ls, Encoding); + get_line1(edlin:edit_line(Cs, Cont), Drv, Shell, Ls, Encoding); %% The search item was found and accepted (new line entered on the exact %% result found) -get_line1({_What,Cont={line,_Prompt,_Chars,search_found},Rs}, Drv, Ls0, Encoding) -> +get_line1({_What,Cont={line,_Prompt,_Chars,search_found},Rs}, Drv, Shell, Ls0, Encoding) -> Line = edlin:current_line(Cont), %% this may create duplicate entries. Ls = save_line(new_stack(get_lines(Ls0)), Line), - get_line1({done, Line, "", Rs}, Drv, Ls, Encoding); + get_line1({done, Line, "", Rs}, Drv, Shell, Ls, Encoding); %% The search mode has been exited, but the user wants to remain in line %% editing mode wherever that was, but editing the search result. -get_line1({What,Cont={line,_Prompt,_Chars,search_quit},Rs}, Drv, Ls, Encoding) -> +get_line1({What,Cont={line,_Prompt,_Chars,search_quit},Rs}, Drv, Shell, Ls, Encoding) -> Line = edlin:current_chars(Cont), %% Load back the old prompt with the correct line number. case get(search_quit_prompt) of undefined -> % should not happen. Fallback. LsFallback = save_line(new_stack(get_lines(Ls)), Line), - get_line1({done, "\n", Line, Rs}, Drv, LsFallback, Encoding); + get_line1({done, "\n", Line, Rs}, Drv, Shell, LsFallback, Encoding); Prompt -> % redraw the line and keep going with the same stack position NCont = {line,Prompt,{lists:reverse(Line),[]},none}, send_drv_reqs(Drv, Rs), send_drv_reqs(Drv, edlin:erase_line(Cont)), send_drv_reqs(Drv, edlin:redraw_line(NCont)), - get_line1({What, NCont ,[]}, Drv, pad_stack(Ls), Encoding) + get_line1({What, NCont ,[]}, Drv, Shell, pad_stack(Ls), Encoding) end; %% Search mode is entered. get_line1({What,{line,Prompt,{RevCmd0,_Aft},search},Rs}, - Drv, Ls0, Encoding) -> + Drv, Shell, Ls0, Encoding) -> send_drv_reqs(Drv, Rs), %% Figure out search direction. ^S and ^R are returned through edlin %% whenever we received a search while being already in search mode. @@ -629,61 +657,90 @@ get_line1({What,{line,Prompt,{RevCmd0,_Aft},search},Rs}, {Ls2, {RevCmd, "': "++Line}} end, Cont = {line,Prompt,NewStack,search}, - more_data(What, Cont, Drv, Ls, Encoding); -get_line1({What,Cont0,Rs}, Drv, Ls, Encoding) -> + more_data(What, Cont, Drv, Shell, Ls, Encoding); +get_line1({What,Cont0,Rs}, Drv, Shell, Ls, Encoding) -> send_drv_reqs(Drv, Rs), - more_data(What, Cont0, Drv, Ls, Encoding). + more_data(What, Cont0, Drv, Shell, Ls, Encoding). -more_data(What, Cont0, Drv, Ls, Encoding) -> +more_data(What, Cont0, Drv, Shell, Ls, Encoding) -> receive {Drv,{data,Cs}} -> - get_line1(edlin:edit_line(Cs, Cont0), Drv, Ls, Encoding); + get_line1(edlin:edit_line(Cs, Cont0), Drv, Shell, Ls, Encoding); {Drv,eof} -> - get_line1(edlin:edit_line(eof, Cont0), Drv, Ls, Encoding); + get_line1(edlin:edit_line(eof, Cont0), Drv, Shell, Ls, Encoding); {io_request,From,ReplyAs,Req} when is_pid(From) -> {more_chars,Cont,_More} = edlin:edit_line([], Cont0), send_drv_reqs(Drv, edlin:erase_line(Cont)), - io_request(Req, From, ReplyAs, Drv, []), %WRONG!!! + io_request(Req, From, ReplyAs, Drv, Shell, []), %WRONG!!! send_drv_reqs(Drv, edlin:redraw_line(Cont)), - get_line1({more_chars,Cont,[]}, Drv, Ls, Encoding); + get_line1({more_chars,Cont,[]}, Drv, Shell, Ls, Encoding); {reply,{{From,ReplyAs},Reply}} -> %% We take care of replies from puts here as well io_reply(From, ReplyAs, Reply), - more_data(What, Cont0, Drv, Ls, Encoding); + more_data(What, Cont0, Drv, Shell, Ls, Encoding); {'EXIT',Drv,interrupt} -> interrupted; {'EXIT',Drv,_} -> - terminated + terminated; + {'EXIT',Shell,R} -> + exit(R) after get_line_timeout(What)-> - get_line1(edlin:edit_line([], Cont0), Drv, Ls, Encoding) + get_line1(edlin:edit_line([], Cont0), Drv, Shell, Ls, Encoding) end. -get_line_echo_off(Chars, Pbs, Drv) -> +get_line_echo_off(Chars, Pbs, Drv, Shell) -> send_drv_reqs(Drv, [{put_chars, unicode,Pbs}]), - get_line_echo_off1(edit_line(Chars,[]), Drv). + get_line_echo_off1(edit_line(Chars,[]), Drv, Shell). -get_line_echo_off1({Chars,[]}, Drv) -> +get_line_echo_off1({Chars,[]}, Drv, Shell) -> receive {Drv,{data,Cs}} -> - get_line_echo_off1(edit_line(Cs, Chars), Drv); + get_line_echo_off1(edit_line(Cs, Chars), Drv, Shell); {Drv,eof} -> - get_line_echo_off1(edit_line(eof, Chars), Drv); + get_line_echo_off1(edit_line(eof, Chars), Drv, Shell); {io_request,From,ReplyAs,Req} when is_pid(From) -> - io_request(Req, From, ReplyAs, Drv, []), - get_line_echo_off1({Chars,[]}, Drv); + io_request(Req, From, ReplyAs, Drv, Shell, []), + get_line_echo_off1({Chars,[]}, Drv, Shell); {reply,{{From,ReplyAs},Reply}} when From =/= undefined -> %% We take care of replies from puts here as well io_reply(From, ReplyAs, Reply), - get_line_echo_off1({Chars,[]},Drv); + get_line_echo_off1({Chars,[]},Drv, Shell); {'EXIT',Drv,interrupt} -> interrupted; {'EXIT',Drv,_} -> - terminated + terminated; + {'EXIT',Shell,R} -> + exit(R) end; -get_line_echo_off1({Chars,Rest}, _Drv) -> +get_line_echo_off1({Chars,Rest}, _Drv, _Shell) -> {done,lists:reverse(Chars),case Rest of done -> []; _ -> Rest end}. +get_chars_echo_off(Pbs, Drv, Shell) -> + send_drv_reqs(Drv, [{put_chars, unicode,Pbs}]), + get_chars_echo_off1(Drv, Shell). + +get_chars_echo_off1(Drv, Shell) -> + receive + {Drv, {data, Cs}} -> + Cs; + {Drv, eof} -> + eof; + {io_request,From,ReplyAs,Req} when is_pid(From) -> + io_request(Req, From, ReplyAs, Drv, Shell, []), + get_chars_echo_off1(Drv, Shell); + {reply,{{From,ReplyAs},Reply}} when From =/= undefined -> + %% We take care of replies from puts here as well + io_reply(From, ReplyAs, Reply), + get_chars_echo_off1(Drv, Shell); + {'EXIT',Drv,interrupt} -> + interrupted; + {'EXIT',Drv,_} -> + terminated; + {'EXIT',Shell,R} -> + exit(R) + end. + %% We support line editing for the ICANON mode except the following %% line editing characters, which already has another meaning in %% echo-on mode (See Advanced Programming in the Unix Environment, 2nd ed, @@ -793,9 +850,9 @@ search_up_stack(Stack, Substr) -> case up_stack(Stack) of {none,NewStack} -> {none,NewStack}; {L, NewStack} -> - case string:str(L, Substr) of - 0 -> search_up_stack(NewStack, Substr); - _ -> {string:strip(L,right,$\n), NewStack} + case string:find(L, Substr) of + nomatch -> search_up_stack(NewStack, Substr); + _ -> {string:trim(L, trailing, "$\n"), NewStack} end end. @@ -803,39 +860,41 @@ search_down_stack(Stack, Substr) -> case down_stack(Stack) of {none,NewStack} -> {none,NewStack}; {L, NewStack} -> - case string:str(L, Substr) of - 0 -> search_down_stack(NewStack, Substr); - _ -> {string:strip(L,right,$\n), NewStack} + case string:find(L, Substr) of + nomatch -> search_down_stack(NewStack, Substr); + _ -> {string:trim(L, trailing, "$\n"), NewStack} end end. %% This is get_line without line editing (except for backspace) and %% without echo. -get_password_line(Chars, Drv) -> - get_password1(edit_password(Chars,[]),Drv). +get_password_line(Chars, Drv, Shell) -> + get_password1(edit_password(Chars,[]),Drv,Shell). -get_password1({Chars,[]}, Drv) -> +get_password1({Chars,[]}, Drv, Shell) -> receive {Drv,{data,Cs}} -> - get_password1(edit_password(Cs,Chars),Drv); + get_password1(edit_password(Cs,Chars),Drv,Shell); {io_request,From,ReplyAs,Req} when is_pid(From) -> %send_drv_reqs(Drv, [{delete_chars, -length(Pbs)}]), - io_request(Req, From, ReplyAs, Drv, []), %WRONG!!! + io_request(Req, From, ReplyAs, Drv, Shell, []), %WRONG!!! %% I guess the reason the above line is wrong is that Buf is %% set to []. But do we expect anything but plain output? - get_password1({Chars, []}, Drv); + get_password1({Chars, []}, Drv, Shell); {reply,{{From,ReplyAs},Reply}} -> %% We take care of replies from puts here as well io_reply(From, ReplyAs, Reply), - get_password1({Chars, []},Drv); + get_password1({Chars, []},Drv, Shell); {'EXIT',Drv,interrupt} -> interrupted; {'EXIT',Drv,_} -> - terminated + terminated; + {'EXIT',Shell,R} -> + exit(R) end; -get_password1({Chars,Rest},Drv) -> +get_password1({Chars,Rest},Drv,_Shell) -> send_drv_reqs(Drv,[{put_chars, unicode, "\n"}]), {done,lists:reverse(Chars),case Rest of done -> []; _ -> Rest end}. diff --git a/lib/kernel/src/hipe_unified_loader.erl b/lib/kernel/src/hipe_unified_loader.erl index f8199fcf71..fd06f0f7d8 100644 --- a/lib/kernel/src/hipe_unified_loader.erl +++ b/lib/kernel/src/hipe_unified_loader.erl @@ -275,6 +275,7 @@ needs_trampolines(Architecture) -> arm -> true; powerpc -> true; ppc64 -> true; + amd64 -> true; _ -> false end. diff --git a/lib/kernel/src/inet.erl b/lib/kernel/src/inet.erl index dc20c21c77..73c53b9011 100644 --- a/lib/kernel/src/inet.erl +++ b/lib/kernel/src/inet.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1997-2017. All Rights Reserved. +%% Copyright Ericsson AB 1997-2018. 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,7 +34,8 @@ ip/1, stats/0, options/0, pushf/3, popf/1, close/1, gethostname/0, gethostname/1, parse_ipv4_address/1, parse_ipv6_address/1, parse_ipv4strict_address/1, - parse_ipv6strict_address/1, parse_address/1, parse_strict_address/1, ntoa/1]). + parse_ipv6strict_address/1, parse_address/1, parse_strict_address/1, + ntoa/1, ipv4_mapped_ipv6_address/1]). -export([connect_options/2, listen_options/2, udp_options/2, sctp_options/2]). -export([udp_module/1, tcp_module/1, tcp_module/2, sctp_module/1]). @@ -72,7 +73,7 @@ %% timer interface -export([start_timer/1, timeout/1, timeout/2, stop_timer/1]). --export_type([address_family/0, hostent/0, hostname/0, ip4_address/0, +-export_type([address_family/0, socket_protocol/0, hostent/0, hostname/0, ip4_address/0, ip6_address/0, ip_address/0, port_number/0, local_address/0, socket_address/0, returned_non_ip_address/0, socket_setopt/0, socket_getopt/0, @@ -104,7 +105,20 @@ {local, binary()} | {unspec, <<>>} | {undefined, any()}. --type posix() :: exbadport | exbadseq | file:posix(). +-type posix() :: + 'eaddrinuse' | 'eaddrnotavail' | 'eafnosupport' | 'ealready' | + 'econnaborted' | 'econnrefused' | 'econnreset' | + 'edestaddrreq' | + 'ehostdown' | 'ehostunreach' | + 'einprogress' | 'eisconn' | + 'emsgsize' | + 'enetdown' | 'enetunreach' | + 'enopkg' | 'enoprotoopt' | 'enotconn' | 'enotty' | 'enotsock' | + 'eproto' | 'eprotonosupport' | 'eprototype' | + 'esocktnosupport' | + 'etimedout' | + 'ewouldblock' | + 'exbadport' | 'exbadseq' | file:posix(). -type socket() :: port(). -type socket_setopt() :: @@ -675,6 +689,14 @@ parse_address(Addr) -> parse_strict_address(Addr) -> inet_parse:strict_address(Addr). +-spec ipv4_mapped_ipv6_address(ip_address()) -> ip_address(). +ipv4_mapped_ipv6_address({D1,D2,D3,D4}) + when (D1 bor D2 bor D3 bor D4) < 256 -> + {0,0,0,0,0,16#ffff,(D1 bsl 8) bor D2,(D3 bsl 8) bor D4}; +ipv4_mapped_ipv6_address({D1,D2,D3,D4,D5,D6,D7,D8}) + when (D1 bor D2 bor D3 bor D4 bor D5 bor D6 bor D7 bor D8) < 65536 -> + {D7 bsr 8,D7 band 255,D8 bsr 8,D8 band 255}. + %% Return a list of available options options() -> [ @@ -1244,9 +1266,7 @@ gethostbyname_string(Name, Type) inet -> inet_parse:ipv4_address(Name); inet6 -> - %% XXX should we really translate IPv4 addresses here - %% even if we do not know if this host can do IPv6? - inet_parse:ipv6_address(Name) + inet_parse:ipv6strict_address(Name) end of {ok,IP} -> {ok,make_hostent(Name, [IP], [], Type)}; @@ -1452,11 +1472,14 @@ fdopen(Fd, Addr, Port, Opts, Protocol, Family, Type, Module) -> %% socket stat %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +-spec i() -> ok. i() -> i(tcp), i(udp), i(sctp). +-spec i(socket_protocol()) -> ok. i(Proto) -> i(Proto, [port, module, recv, sent, owner, local_address, foreign_address, state, type]). +-spec i(socket_protocol(), [atom()]) -> ok. i(tcp, Fs) -> ii(tcp_sockets(), Fs, tcp); i(udp, Fs) -> diff --git a/lib/kernel/src/inet_config.erl b/lib/kernel/src/inet_config.erl index 4bbc520449..9f76360b8b 100644 --- a/lib/kernel/src/inet_config.erl +++ b/lib/kernel/src/inet_config.erl @@ -1,7 +1,7 @@ %% %% %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. @@ -369,7 +369,7 @@ win32_load1(Reg,Type,HFileKey) -> end. win32_split_line(Line,nt) -> inet_parse:split_line(Line); -win32_split_line(Line,windows) -> string:tokens(Line, ","). +win32_split_line(Line,windows) -> string:lexemes(Line, ","). win32_get_strings(Reg, Names) -> win32_get_strings(Reg, Names, []). diff --git a/lib/kernel/src/inet_dns.erl b/lib/kernel/src/inet_dns.erl index d5f982cc51..f1f58bc872 100644 --- a/lib/kernel/src/inet_dns.erl +++ b/lib/kernel/src/inet_dns.erl @@ -1,7 +1,7 @@ %% %% %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. @@ -29,7 +29,7 @@ -export([decode/1, encode/1]). --import(lists, [reverse/1, reverse/2, nthtail/2]). +-import(lists, [reverse/1]). -include("inet_int.hrl"). -include("inet_dns.hrl"). @@ -473,7 +473,7 @@ decode_data(<<Order:16,Preference:16,Data0/binary>>, _, ?S_NAPTR, Buffer) -> {Data2,Services} = decode_string(Data1), {Data,Regexp} = decode_characters(Data2, utf8), Replacement = decode_domain(Data, Buffer), - {Order,Preference,string:to_lower(Flags),string:to_lower(Services), + {Order,Preference,string:lowercase(Flags),string:lowercase(Services), Regexp,Replacement}; %% ?S_OPT falls through to default decode_data(Data, _, ?S_TXT, _) -> diff --git a/lib/kernel/src/inet_hosts.erl b/lib/kernel/src/inet_hosts.erl index 0bdf00ac30..fc653bf0d3 100644 --- a/lib/kernel/src/inet_hosts.erl +++ b/lib/kernel/src/inet_hosts.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1997-2016. All Rights Reserved. +%% Copyright Ericsson AB 1997-2018. 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,9 +72,6 @@ gethostbyname(Name, Type, Byname, Byaddr) -> gethostbyaddr({A,B,C,D}=IP) when ?ip(A,B,C,D) -> gethostbyaddr(IP, inet); -%% ipv4 only ipv6 address -gethostbyaddr({0,0,0,0,0,16#ffff=F,G,H}) when ?ip6(0,0,0,0,0,F,G,H) -> - gethostbyaddr({G bsr 8, G band 255, H bsr 8, H band 255}); gethostbyaddr({A,B,C,D,E,F,G,H}=IP) when ?ip6(A,B,C,D,E,F,G,H) -> gethostbyaddr(IP, inet6); gethostbyaddr(Addr) when is_list(Addr) -> diff --git a/lib/kernel/src/inet_int.hrl b/lib/kernel/src/inet_int.hrl index bc5b67f7bf..357e27826c 100644 --- a/lib/kernel/src/inet_int.hrl +++ b/lib/kernel/src/inet_int.hrl @@ -100,6 +100,8 @@ -define(TCP_REQ_RECV, 42). -define(TCP_REQ_UNRECV, 43). -define(TCP_REQ_SHUTDOWN, 44). +-define(TCP_REQ_SENDFILE, 45). + %% UDP and SCTP requests -define(PACKET_REQ_RECV, 60). %%-define(SCTP_REQ_LISTEN, 61). MERGED @@ -319,6 +321,12 @@ [((X) bsr 24) band 16#ff, ((X) bsr 16) band 16#ff, ((X) bsr 8) band 16#ff, (X) band 16#ff]). +-define(int64(X), + [((X) bsr 56) band 16#ff, ((X) bsr 48) band 16#ff, + ((X) bsr 40) band 16#ff, ((X) bsr 32) band 16#ff, + ((X) bsr 24) band 16#ff, ((X) bsr 16) band 16#ff, + ((X) bsr 8) band 16#ff, (X) band 16#ff]). + -define(intAID(X), % For SCTP AssocID ?int32(X)). diff --git a/lib/kernel/src/inet_parse.erl b/lib/kernel/src/inet_parse.erl index 29804dc50b..e9685c6554 100644 --- a/lib/kernel/src/inet_parse.erl +++ b/lib/kernel/src/inet_parse.erl @@ -95,7 +95,7 @@ hosts(Fname,File) -> %% interface with a %if suffix. These kind of %% addresses maybe need to be gracefully handled %% throughout inet* and inet_drv. - case string:tokens(Address, "%") of + case string:lexemes(Address, "%") of [Addr,_] -> {ok,_} = address(Addr), skip; @@ -407,7 +407,7 @@ is_dom1([C | Cs]) when C >= $a, C =< $z -> is_dom_ldh(Cs); is_dom1([C | Cs]) when C >= $A, C =< $Z -> is_dom_ldh(Cs); is_dom1([C | Cs]) when C >= $0, C =< $9 -> case is_dom_ldh(Cs) of - true -> is_dom2(string:tokens([C | Cs],".")); + true -> is_dom2(string:lexemes([C | Cs],".")); false -> false end; is_dom1(_) -> false. diff --git a/lib/kernel/src/inet_res.erl b/lib/kernel/src/inet_res.erl index 90e49ddfdf..6454802b04 100644 --- a/lib/kernel/src/inet_res.erl +++ b/lib/kernel/src/inet_res.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1997-2016. All Rights Reserved. +%% Copyright Ericsson AB 1997-2018. 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. @@ -349,9 +349,6 @@ gethostbyaddr_tm({A,B,C,D} = IP, Timer) when ?ip(A,B,C,D) -> {ok, HEnt} -> {ok, HEnt}; _ -> res_gethostbyaddr(dn_in_addr_arpa(A,B,C,D), IP, Timer) end; -%% ipv4 only ipv6 address -gethostbyaddr_tm({0,0,0,0,0,16#ffff,G,H},Timer) when is_integer(G+H) -> - gethostbyaddr_tm({G div 256, G rem 256, H div 256, H rem 256},Timer); gethostbyaddr_tm({A,B,C,D,E,F,G,H} = IP, Timer) when ?ip6(A,B,C,D,E,F,G,H) -> inet_db:res_update_conf(), case inet_db:gethostbyaddr(IP) of @@ -431,28 +428,7 @@ gethostbyname(Name,Family,Timeout) -> gethostbyname_tm(Name,inet,Timer) -> getbyname_tm(Name,?S_A,Timer); gethostbyname_tm(Name,inet6,Timer) -> - case getbyname_tm(Name,?S_AAAA,Timer) of - {ok,HEnt} -> {ok,HEnt}; - {error,nxdomain} -> - case getbyname_tm(Name, ?S_A,Timer) of - {ok, HEnt} -> - %% rewrite to a ipv4 only ipv6 address - {ok, - HEnt#hostent { - h_addrtype = inet6, - h_length = 16, - h_addr_list = - lists:map( - fun({A,B,C,D}) -> - {0,0,0,0,0,16#ffff,A*256+B,C*256+D} - end, HEnt#hostent.h_addr_list) - }}; - Error -> - Error - end; - Error -> - Error - end; + getbyname_tm(Name,?S_AAAA,Timer); gethostbyname_tm(_Name, _Family, _Timer) -> {error, einval}. @@ -859,15 +835,17 @@ query_ns(S0, Id, Buffer, IP, Port, Timer, Retry, I, {ok,S} -> Timeout = inet:timeout( (Tm * (1 bsl I)) div Retry, Timer), - {S, case query_udp( S, Id, Buffer, IP, Port, Timeout, Verbose) of {ok,#dns_rec{header=H}} when H#dns_header.tc -> TcpTimeout = inet:timeout(Tm*5, Timer), - query_tcp( - TcpTimeout, Id, Buffer, IP, Port, Verbose); - Reply -> Reply - end}; + {S, query_tcp( + TcpTimeout, Id, Buffer, IP, Port, Verbose)}; + {error, econnrefused} = Err -> + ok = udp_close(S), + {#sock{}, Err}; + Reply -> {S, Reply} + end; Error -> {S0,Error} end diff --git a/lib/kernel/src/kernel.app.src b/lib/kernel/src/kernel.app.src index 0eca6fef03..82a3571da9 100644 --- a/lib/kernel/src/kernel.app.src +++ b/lib/kernel/src/kernel.app.src @@ -57,6 +57,7 @@ inet_tcp_dist, kernel, kernel_config, + kernel_refc, local_tcp, local_udp, net, @@ -88,6 +89,13 @@ inet_udp, inet_sctp, pg2, + raw_file_io, + raw_file_io_compressed, + raw_file_io_deflate, + raw_file_io_delayed, + raw_file_io_inflate, + raw_file_io_list, + raw_file_io_raw, seq_trace, standard_error, wrap_log_reader]}, @@ -107,6 +115,7 @@ heart, init, kernel_config, + kernel_refc, kernel_sup, net_kernel, net_sup, @@ -120,6 +129,6 @@ {applications, []}, {env, [{error_logger, tty}]}, {mod, {kernel, []}}, - {runtime_dependencies, ["erts-9.3", "stdlib-3.4", "sasl-3.0"]} + {runtime_dependencies, ["erts-10.0", "stdlib-3.5", "sasl-3.0"]} ] }. diff --git a/lib/kernel/src/kernel.erl b/lib/kernel/src/kernel.erl index cba57088ec..0382764b39 100644 --- a/lib/kernel/src/kernel.erl +++ b/lib/kernel/src/kernel.erl @@ -111,6 +111,13 @@ init([]) -> type => worker, modules => [kernel_config]}, + RefC = #{id => kernel_refc, + start => {kernel_refc, start_link, []}, + restart => permanent, + shutdown => 2000, + type => worker, + modules => [kernel_refc]}, + Code = #{id => code_server, start => {code, start_link, []}, restart => permanent, @@ -148,7 +155,7 @@ init([]) -> case init:get_argument(mode) of {ok, [["minimal"]]} -> - {ok, {SupFlags, [Code, File, StdError, User, Config, SafeSup]}}; + {ok, {SupFlags, [Code, File, StdError, User, Config, RefC, SafeSup]}}; _ -> Rpc = #{id => rex, start => {rpc, start_link, []}, @@ -199,7 +206,7 @@ init([]) -> {ok, {SupFlags, [Code, Rpc, Global, InetDb | DistAC] ++ [NetSup, GlGroup, File, SigSrv, - StdError, User, Config, SafeSup] ++ Timer}} + StdError, User, Config, RefC, SafeSup] ++ Timer}} end; init(safe) -> SupFlags = #{strategy => one_for_one, diff --git a/lib/kernel/src/kernel_refc.erl b/lib/kernel/src/kernel_refc.erl new file mode 100644 index 0000000000..05076dc885 --- /dev/null +++ b/lib/kernel/src/kernel_refc.erl @@ -0,0 +1,139 @@ +%% +%% %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% +%% +-module(kernel_refc). + +-behaviour(gen_server). + +%% External exports +-export([start_link/0, scheduler_wall_time/1]). +%% Internal exports +-export([init/1, handle_info/2, terminate/2]). +-export([handle_call/3, handle_cast/2, code_change/3]). + +%%%----------------------------------------------------------------- +%%% This module implements a process that handles reference counters for +%%% various erts or other kernel resources which needs reference counting. +%%% +%%% Should not be documented nor used directly by user applications. +%%%----------------------------------------------------------------- +start_link() -> + gen_server:start_link({local,kernel_refc}, kernel_refc, [], []). + +-spec scheduler_wall_time(boolean()) -> boolean(). +scheduler_wall_time(Bool) -> + gen_server:call(kernel_refc, {scheduler_wall_time, self(), Bool}, infinity). + +%%----------------------------------------------------------------- +%% Callback functions from gen_server +%%----------------------------------------------------------------- + +-spec init([]) -> {'ok', map()} | {'stop', term()}. + +init([]) -> + resource(scheduler_wall_time, false), + {ok, #{scheduler_wall_time=>#{}}}. + +-spec handle_call(term(), term(), State) -> {'reply', term(), State}. +handle_call({What, Who, false}, _From, State) -> + {Reply, Cnt} = do_stop(What, maps:get(What, State), Who), + {reply, Reply, State#{What:=Cnt}}; +handle_call({What, Who, true}, _From, State) -> + {Reply, Cnt} = do_start(What, maps:get(What, State), Who), + {reply, Reply, State#{What:=Cnt}}; +handle_call(_, _From, State) -> + {reply, badarg, State}. + +-spec handle_cast(term(), State) -> {'noreply', State}. +handle_cast(_, State) -> + {noreply, State}. + +-spec handle_info(term(), State) -> {'noreply', State}. +handle_info({'DOWN', _Ref, process, Pid, _}, State) -> + Cleanup = fun(Resource, Cnts) -> + cleanup(Resource, Cnts, Pid) + end, + {noreply, maps:map(Cleanup, State)}; +handle_info(_, State) -> + {noreply, State}. + +-spec terminate(term(), term()) -> 'ok'. +terminate(_Reason, _State) -> + ok. + +-spec code_change(term(), State, term()) -> {'ok', State}. +code_change(_OldVsn, State, _Extra) -> + {ok, State}. + +%%----------------------------------------------------------------- +%% Internal functions +%%----------------------------------------------------------------- + +do_start(Resource, Cnt, Pid) -> + case maps:get(Pid, Cnt, undefined) of + undefined -> + Ref = erlang:monitor(process, Pid), + case any(Cnt) of + true -> + {true, Cnt#{Pid=>{1, Ref}}}; + false -> + resource(Resource, true), + {false, Cnt#{Pid=>{1, Ref}}} + end; + {N, Ref} -> + {true, Cnt#{Pid=>{N+1, Ref}}} + end. + +do_stop(Resource, Cnt0, Pid) -> + case maps:get(Pid, Cnt0, undefined) of + undefined -> + {any(Cnt0), Cnt0}; + {1, Ref} -> + erlang:demonitor(Ref, [flush]), + Cnt = maps:remove(Pid, Cnt0), + case any(Cnt) of + true -> + {true, Cnt}; + false -> + resource(Resource, false), + {true, Cnt} + end; + {N, Ref} -> + {true, Cnt0#{Pid=>{N-1, Ref}}} + end. + +cleanup(Resource, Cnt0, Pid) -> + case maps:is_key(Pid, Cnt0) of + true -> + Cnt = maps:remove(Pid, Cnt0), + case any(Cnt) of + true -> + Cnt; + false -> + resource(Resource, false), + Cnt + end; + false -> + Cnt0 + end. + +any(Cnt) -> maps:size(Cnt) > 0. + +resource(scheduler_wall_time, Enable) -> + _ = erts_internal:scheduler_wall_time(Enable). diff --git a/lib/kernel/src/net_kernel.erl b/lib/kernel/src/net_kernel.erl index 7da89dd7cb..669adefdf8 100644 --- a/lib/kernel/src/net_kernel.erl +++ b/lib/kernel/src/net_kernel.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2017. All Rights Reserved. +%% Copyright Ericsson AB 1996-2018. 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. @@ -70,8 +70,8 @@ protocol_childspecs/0, epmd_module/0]). --export([connect/1, disconnect/1, hidden_connect/1, passive_cnct/1]). --export([hidden_connect_node/1]). %% explicit connect +-export([disconnect/1, passive_cnct/1]). +-export([hidden_connect_node/1]). -export([set_net_ticktime/1, set_net_ticktime/2, get_net_ticktime/0]). -export([node_info/1, node_info/2, nodes_info/0, @@ -122,6 +122,7 @@ -record(connection, { node, %% remote node name + conn_id, %% Connection identity state, %% pending | up | up_pending owner, %% owner pid pending_owner, %% possible new owner @@ -221,8 +222,7 @@ get_net_ticktime() -> Error :: error | {error, term()}. monitor_nodes(Flag) -> case catch process_flag(monitor_nodes, Flag) of - true -> ok; - false -> ok; + N when is_integer(N) -> ok; _ -> mk_monitor_nodes_error(Flag, []) end. @@ -235,8 +235,7 @@ monitor_nodes(Flag) -> Error :: error | {error, term()}. monitor_nodes(Flag, Opts) -> case catch process_flag({monitor_nodes, Opts}, Flag) of - true -> ok; - false -> ok; + N when is_integer(N) -> ok; _ -> mk_monitor_nodes_error(Flag, Opts) end. @@ -247,14 +246,15 @@ ticktime_res(A) when is_atom(A) -> A. %% Called though BIF's -connect(Node) -> do_connect(Node, normal, false). %%% Long timeout if blocked (== barred), only affects nodes with %%% {dist_auto_connect, once} set. -passive_cnct(Node) -> do_connect(Node, normal, true). -disconnect(Node) -> request({disconnect, Node}). +passive_cnct(Node) -> + case request({passive_cnct, Node}) of + ignored -> false; + Other -> Other + end. -%% connect but not seen -hidden_connect(Node) -> do_connect(Node, hidden, false). +disconnect(Node) -> request({disconnect, Node}). %% Should this node publish itself on Node? publish_on_node(Node) when is_atom(Node) -> @@ -272,67 +272,30 @@ connect_node(Node) when is_atom(Node) -> hidden_connect_node(Node) when is_atom(Node) -> request({connect, hidden, Node}). -do_connect(Node, Type, WaitForBarred) -> %% Type = normal | hidden - case catch ets:lookup(sys_dist, Node) of - {'EXIT', _} -> - ?connect_failure(Node,{table_missing, sys_dist}), - false; - [#barred_connection{}] -> - case WaitForBarred of - false -> - false; - true -> - Pid = spawn(?MODULE,passive_connect_monitor,[self(),Node]), - receive - {Pid, true} -> - %%io:format("Net Kernel: barred connection (~p) " - %% "connected from other end.~n",[Node]), - true; - {Pid, false} -> - ?connect_failure(Node,{barred_connection, - ets:lookup(sys_dist, Node)}), - %%io:format("Net Kernel: barred connection (~p) " - %% "- failure.~n",[Node]), - false - end - end; - Else -> - case application:get_env(kernel, dist_auto_connect) of - {ok, never} -> - ?connect_failure(Node,{dist_auto_connect,never}), - false; - % This might happen due to connection close - % not beeing propagated to user space yet. - % Save the day by just not connecting... - {ok, once} when Else =/= [], - (hd(Else))#connection.state =:= up -> - ?connect_failure(Node,{barred_connection, - ets:lookup(sys_dist, Node)}), - false; - _ -> - request({connect, Type, Node}) - end - end. -passive_connect_monitor(Parent, Node) -> +passive_connect_monitor(From, Node) -> ok = monitor_nodes(true,[{node_type,all}]), - case lists:member(Node,nodes([connected])) of - true -> - ok = monitor_nodes(false,[{node_type,all}]), - Parent ! {self(),true}; - _ -> - Ref = make_ref(), - Tref = erlang:send_after(connecttime(),self(),Ref), - receive - Ref -> - ok = monitor_nodes(false,[{node_type,all}]), - Parent ! {self(), false}; - {nodeup,Node,_} -> - ok = monitor_nodes(false,[{node_type,all}]), - _ = erlang:cancel_timer(Tref), - Parent ! {self(),true} - end - end. + Reply = case lists:member(Node,nodes([connected])) of + true -> + io:format("~p: passive_connect_monitor ~p\n", [self(), ?LINE]), + true; + _ -> + receive + {nodeup,Node,_} -> + io:format("~p: passive_connect_monitor ~p\n", [self(), ?LINE]), + true + after connecttime() -> + io:format("~p: passive_connect_monitor ~p\n", [self(), ?LINE]), + false + end + end, + ok = monitor_nodes(false,[{node_type,all}]), + io:format("~p: passive_connect_monitor ~p\n", [self(), ?LINE]), + {Pid, Tag} = From, + io:format("~p: passive_connect_monitor ~p\n", [self(), ?LINE]), + erlang:send(Pid, {Tag, Reply}), + io:format("~p: passive_connect_monitor ~p\n", [self(), ?LINE]). + %% If the net_kernel isn't running we ignore all requests to the %% kernel, thus basically accepting them :-) @@ -394,40 +357,135 @@ init({Name, LongOrShortNames, TickT, CleanHalt}) -> end. +do_auto_connect(Type, Node, ConnId, WaitForBarred, From, State) -> + ConnLookup = ets:lookup(sys_dist, Node), + + case ConnLookup of + [#barred_connection{}] -> + case WaitForBarred of + false -> + {reply, false, State}; + true -> + spawn(?MODULE,passive_connect_monitor,[From,Node]), + {noreply, State} + end; + + [#connection{conn_id=ConnId, state = up}] -> + {reply, true, State}; + [#connection{conn_id=ConnId, waiting=Waiting}=Conn] -> + case From of + noreply -> ok; + _ -> ets:insert(sys_dist, Conn#connection{waiting = [From|Waiting]}) + end, + {noreply, State}; + + _ -> + case application:get_env(kernel, dist_auto_connect) of + {ok, never} -> + ?connect_failure(Node,{dist_auto_connect,never}), + {reply, false, State}; + + %% This might happen due to connection close + %% not beeing propagated to user space yet. + %% Save the day by just not connecting... + {ok, once} when ConnLookup =/= [], + (hd(ConnLookup))#connection.state =:= up -> + ?connect_failure(Node,{barred_connection, + ets:lookup(sys_dist, Node)}), + {reply, false, State}; + _ -> + case setup(ConnLookup, Node,ConnId,Type,From,State) of + {ok, SetupPid} -> + Owners = [{SetupPid, Node} | State#state.conn_owners], + {noreply,State#state{conn_owners=Owners}}; + _Error -> + ?connect_failure(Node, {setup_call, failed, _Error}), + {reply, false, State} + end + end + end. + + +do_explicit_connect([#connection{conn_id = ConnId, state = up}], _, _, ConnId, _From, State) -> + {reply, true, State}; +do_explicit_connect([#connection{conn_id = ConnId}=Conn], _, _, ConnId, From, State) + when Conn#connection.state =:= pending; + Conn#connection.state =:= up_pending -> + Waiting = Conn#connection.waiting, + ets:insert(sys_dist, Conn#connection{waiting = [From|Waiting]}), + {noreply, State}; +do_explicit_connect([#barred_connection{}], Type, Node, ConnId, From , State) -> + %% Barred connection only affects auto_connect, ignore it. + do_explicit_connect([], Type, Node, ConnId, From , State); +do_explicit_connect(ConnLookup, Type, Node, ConnId, From , State) -> + case setup(ConnLookup, Node,ConnId,Type,From,State) of + {ok, SetupPid} -> + Owners = [{SetupPid, Node} | State#state.conn_owners], + {noreply,State#state{conn_owners=Owners}}; + _Error -> + ?connect_failure(Node, {setup_call, failed, _Error}), + {reply, false, State} + end. + +-define(ERTS_DIST_CON_ID_MASK, 16#ffffff). % also in external.h + +verify_new_conn_id([], {Nr,_DHandle}) + when (Nr band (bnot ?ERTS_DIST_CON_ID_MASK)) =:= 0 -> + true; +verify_new_conn_id([#connection{conn_id = {Old,_}}], {New,_}) + when New =:= ((Old+1) band ?ERTS_DIST_CON_ID_MASK) -> + true; +verify_new_conn_id(_, _) -> + false. + + + %% ------------------------------------------------------------ %% handle_call. %% ------------------------------------------------------------ %% -%% Set up a connection to Node. -%% The response is delayed until the connection is up and -%% running. +%% Passive auto-connect to Node. +%% The response is delayed until the connection is up and running. %% -handle_call({connect, _, Node}, From, State) when Node =:= node() -> +handle_call({passive_cnct, Node}, From, State) when Node =:= node() -> + async_reply({reply, true, State}, From); +handle_call({passive_cnct, Node}, From, State) -> + verbose({passive_cnct, Node}, 1, State), + Type = normal, + WaitForBarred = true, + R = case (catch erts_internal:new_connection(Node)) of + {Nr,_DHandle}=ConnId when is_integer(Nr) -> + do_auto_connect(Type, Node, ConnId, WaitForBarred, From, State); + + _Error -> + error_logger:error_msg("~n** Cannot get connection id for node ~w~n", + [Node]), + {reply, false, State} + end, + + return_call(R, From); + +%% +%% Explicit connect +%% The response is delayed until the connection is up and running. +%% +handle_call({connect, _, Node, _, _}, From, State) when Node =:= node() -> async_reply({reply, true, State}, From); handle_call({connect, Type, Node}, From, State) -> verbose({connect, Type, Node}, 1, State), - case ets:lookup(sys_dist, Node) of - [Conn] when Conn#connection.state =:= up -> - async_reply({reply, true, State}, From); - [Conn] when Conn#connection.state =:= pending -> - Waiting = Conn#connection.waiting, - ets:insert(sys_dist, Conn#connection{waiting = [From|Waiting]}), - {noreply, State}; - [Conn] when Conn#connection.state =:= up_pending -> - Waiting = Conn#connection.waiting, - ets:insert(sys_dist, Conn#connection{waiting = [From|Waiting]}), - {noreply, State}; - _ -> - case setup(Node,Type,From,State) of - {ok, SetupPid} -> - Owners = [{SetupPid, Node} | State#state.conn_owners], - {noreply,State#state{conn_owners=Owners}}; - _ -> - ?connect_failure(Node, {setup_call, failed}), - async_reply({reply, false, State}, From) - end - end; + ConnLookup = ets:lookup(sys_dist, Node), + R = case (catch erts_internal:new_connection(Node)) of + {Nr,_DHandle}=ConnId when is_integer(Nr) -> + do_explicit_connect(ConnLookup, Type, Node, ConnId, From, State); + + _Error -> + error_logger:error_msg("~n** Cannot get connection id for node ~w~n", + [Node]), + {reply, false, State} + end, + return_call(R, From); + %% %% Close the connection to Node. @@ -634,6 +692,26 @@ terminate(_Reason, State) -> %% ------------------------------------------------------------ %% +%% Asynchronous auto connect request +%% +handle_info({auto_connect,Node, Nr, DHandle}, State) -> + verbose({auto_connect, Node, Nr, DHandle}, 1, State), + ConnId = {Nr, DHandle}, + NewState = + case do_auto_connect(normal, Node, ConnId, false, noreply, State) of + {noreply, S} -> %% Pending connection + S; + + {reply, true, S} -> %% Already connected + S; + + {reply, false, S} -> %% Connection refused + erts_internal:abort_connection(Node, ConnId), + S + end, + {noreply, NewState}; + +%% %% accept a new connection. %% handle_info({accept,AcceptPid,Socket,Family,Proto}, State) -> @@ -713,14 +791,23 @@ handle_info({AcceptPid, {accept_pending,MyNode,Node,Address,Type}}, State) -> AcceptPid ! {self(), {accept_pending, already_pending}}, {noreply, State}; _ -> - ets:insert(sys_dist, #connection{node = Node, - state = pending, - owner = AcceptPid, - address = Address, - type = Type}), - AcceptPid ! {self(),{accept_pending,ok}}, - Owners = [{AcceptPid,Node} | State#state.conn_owners], - {noreply, State#state{conn_owners = Owners}} + case (catch erts_internal:new_connection(Node)) of + {Nr,_DHandle}=ConnId when is_integer(Nr) -> + ets:insert(sys_dist, #connection{node = Node, + conn_id = ConnId, + state = pending, + owner = AcceptPid, + address = Address, + type = Type}), + AcceptPid ! {self(),{accept_pending,ok}}, + Owners = [{AcceptPid,Node} | State#state.conn_owners], + {noreply, State#state{conn_owners = Owners}}; + + _ -> + error_logger:error_msg("~n** Cannot get connection id for node ~w~n", + [Node]), + AcceptPid ! {self(),{accept_pending,nok_pending}} + end end; handle_info({SetupPid, {is_pending, Node}}, State) -> @@ -906,6 +993,7 @@ pending_nodedown(Conn, Node, Type, State) -> % Don't bar connections that have never been alive %mark_sys_dist_nodedown(Node), % - instead just delete the node: + erts_internal:abort_connection(Node, Conn#connection.conn_id), ets:delete(sys_dist, Node), reply_waiting(Node,Conn#connection.waiting, false), case Type of @@ -920,7 +1008,9 @@ up_pending_nodedown(Conn, Node, _Reason, _Type, State) -> AcceptPid = Conn#connection.pending_owner, Owners = State#state.conn_owners, Pend = lists:keydelete(AcceptPid, 1, State#state.pend_owners), + erts_internal:abort_connection(Node, Conn#connection.conn_id), Conn1 = Conn#connection { owner = AcceptPid, + conn_id = erts_internal:new_connection(Node), pending_owner = undefined, state = pending }, ets:insert(sys_dist, Conn1), @@ -928,15 +1018,16 @@ up_pending_nodedown(Conn, Node, _Reason, _Type, State) -> State#state{conn_owners = [{AcceptPid,Node}|Owners], pend_owners = Pend}. -up_nodedown(_Conn, Node, _Reason, Type, State) -> - mark_sys_dist_nodedown(Node), +up_nodedown(Conn, Node, _Reason, Type, State) -> + mark_sys_dist_nodedown(Conn, Node), case Type of normal -> ?nodedown(Node, State); _ -> ok end, State. -mark_sys_dist_nodedown(Node) -> +mark_sys_dist_nodedown(Conn, Node) -> + erts_internal:abort_connection(Node, Conn#connection.conn_id), case application:get_env(kernel, dist_auto_connect) of {ok, once} -> ets:insert(sys_dist, #barred_connection{node = Node}); @@ -1179,15 +1270,8 @@ spawn_func(_,{From,Tag},M,F,A,Gleader) -> %% Set up connection to a new node. %% ----------------------------------------------------------- -setup(Node,Type,From,State) -> - Allowed = State#state.allowed, - case lists:member(Node, Allowed) of - false when Allowed =/= [] -> - error_msg("** Connection attempt with " - "disallowed node ~w ** ~n", [Node]), - {error, bad_node}; - _ -> - case select_mod(Node, State#state.listen) of +setup(ConnLookup, Node,ConnId,Type,From,State) -> + case setup_check(ConnLookup, Node, ConnId, State) of {ok, L} -> Mod = L#listen.module, LAddr = L#listen.address, @@ -1200,18 +1284,45 @@ setup(Node,Type,From,State) -> Addr = LAddr#net_address { address = undefined, host = undefined }, + Waiting = case From of + noreply -> []; + _ -> [From] + end, ets:insert(sys_dist, #connection{node = Node, + conn_id = ConnId, state = pending, owner = Pid, - waiting = [From], + waiting = Waiting, address = Addr, type = normal}), {ok, Pid}; Error -> Error - end end. +setup_check(ConnLookup, Node, ConnId, State) -> + Allowed = State#state.allowed, + case lists:member(Node, Allowed) of + false when Allowed =/= [] -> + error_msg("** Connection attempt with " + "disallowed node ~w ** ~n", [Node]), + {error, bad_node}; + _ -> + case verify_new_conn_id(ConnLookup, ConnId) of + false -> + error_msg("** Connection attempt to ~w with " + "bad connection id ~w ** ~n", [Node, ConnId]), + {error, bad_conn_id}; + true -> + case select_mod(Node, State#state.listen) of + {ok, _L}=OK -> OK; + Error -> Error + end + end + end. + + + %% %% Find a module that is willing to handle connection setup to Node %% @@ -1652,6 +1763,11 @@ verbose(_, _, _) -> getnode(P) when is_pid(P) -> node(P); getnode(P) -> P. +return_call({noreply, _State}=R, _From) -> + R; +return_call(R, From) -> + async_reply(R, From). + async_reply({reply, Msg, State}, From) -> async_gen_server_reply(From, Msg), {noreply, State}. @@ -1659,16 +1775,16 @@ async_reply({reply, Msg, State}, From) -> async_gen_server_reply(From, Msg) -> {Pid, Tag} = From, M = {Tag, Msg}, - case catch erlang:send(Pid, M, [nosuspend, noconnect]) of + try erlang:send(Pid, M, [nosuspend, noconnect]) of ok -> ok; nosuspend -> _ = spawn(fun() -> catch erlang:send(Pid, M, [noconnect]) end), ok; noconnect -> - ok; % The gen module takes care of this case. - {'EXIT', _} -> - ok + ok % The gen module takes care of this case. + catch + _:_ -> ok end. call_owner(Owner, Msg) -> diff --git a/lib/kernel/src/os.erl b/lib/kernel/src/os.erl index a4b4f798f9..77c883f57f 100644 --- a/lib/kernel/src/os.erl +++ b/lib/kernel/src/os.erl @@ -25,41 +25,36 @@ -include("file.hrl"). +-export_type([env_var_name/0, env_var_value/0, env_var_name_value/0]). + +-export([getenv/0, getenv/1, getenv/2, putenv/2, unsetenv/1]). + %%% BIFs --export([getenv/0, getenv/1, getenv/2, getpid/0, - perf_counter/0, perf_counter/1, - putenv/2, set_signal/2, system_time/0, system_time/1, - timestamp/0, unsetenv/1]). +-export([get_env_var/1, getpid/0, list_env_vars/0, perf_counter/0, + perf_counter/1, set_env_var/2, set_signal/2, system_time/0, + system_time/1, timestamp/0, unset_env_var/1]). -type os_command() :: atom() | io_lib:chars(). -type os_command_opts() :: #{ max_size => non_neg_integer() | infinity }. -export_type([os_command/0, os_command_opts/0]). --spec getenv() -> [string()]. +-type env_var_name() :: nonempty_string(). -getenv() -> erlang:nif_error(undef). +-type env_var_value() :: string(). --spec getenv(VarName) -> Value | false when - VarName :: string(), - Value :: string(). +-type env_var_name_value() :: nonempty_string(). -getenv(_) -> +-spec list_env_vars() -> [{env_var_name(), env_var_value()}]. +list_env_vars() -> erlang:nif_error(undef). --spec getenv(VarName, DefaultValue) -> Value when - VarName :: string(), - DefaultValue :: string(), - Value :: string(). - -getenv(VarName, DefaultValue) -> - case os:getenv(VarName) of - false -> - DefaultValue; - Value -> - Value - end. +-spec get_env_var(VarName) -> Value | false when + VarName :: env_var_name(), + Value :: env_var_value(). +get_env_var(_VarName) -> + erlang:nif_error(undef). -spec getpid() -> Value when Value :: string(). @@ -79,11 +74,10 @@ perf_counter() -> perf_counter(Unit) -> erlang:convert_time_unit(os:perf_counter(), perf_counter, Unit). --spec putenv(VarName, Value) -> true when - VarName :: string(), - Value :: string(). - -putenv(_, _) -> +-spec set_env_var(VarName, Value) -> true when + VarName :: env_var_name(), + Value :: env_var_value(). +set_env_var(_, _) -> erlang:nif_error(undef). -spec system_time() -> integer(). @@ -103,10 +97,9 @@ system_time(_Unit) -> timestamp() -> erlang:nif_error(undef). --spec unsetenv(VarName) -> true when - VarName :: string(). - -unsetenv(_) -> +-spec unset_env_var(VarName) -> true when + VarName :: env_var_name(). +unset_env_var(_) -> erlang:nif_error(undef). -spec set_signal(Signal, Option) -> 'ok' when @@ -120,6 +113,39 @@ set_signal(_Signal, _Option) -> %%% End of BIFs +-spec getenv() -> [env_var_name_value()]. +getenv() -> + [lists:flatten([Key, $=, Value]) || {Key, Value} <- os:list_env_vars() ]. + +-spec getenv(VarName) -> Value | false when + VarName :: env_var_name(), + Value :: env_var_value(). +getenv(VarName) -> + os:get_env_var(VarName). + +-spec getenv(VarName, DefaultValue) -> Value when + VarName :: env_var_name(), + DefaultValue :: env_var_value(), + Value :: env_var_value(). +getenv(VarName, DefaultValue) -> + case os:getenv(VarName) of + false -> + DefaultValue; + Value -> + Value + end. + +-spec putenv(VarName, Value) -> true when + VarName :: env_var_name(), + Value :: env_var_value(). +putenv(VarName, Value) -> + os:set_env_var(VarName, Value). + +-spec unsetenv(VarName) -> true when + VarName :: env_var_name(). +unsetenv(VarName) -> + os:unset_env_var(VarName). + -spec type() -> {Osfamily, Osname} when Osfamily :: unix | win32, Osname :: atom(). @@ -183,7 +209,7 @@ verify_executable(Name0, [Ext|Rest], OrigExtensions) -> end; verify_executable(Name, [], OrigExtensions) when OrigExtensions =/= [""] -> %% Windows %% Will only happen on windows, hence case insensitivity - case can_be_full_name(string:to_lower(Name),OrigExtensions) of + case can_be_full_name(string:lowercase(Name),OrigExtensions) of true -> verify_executable(Name,[""],[""]); _ -> @@ -245,8 +271,7 @@ cmd(Cmd) -> Command :: os_command(), Options :: os_command_opts(). cmd(Cmd, Opts) -> - validate(Cmd), - {SpawnCmd, SpawnOpts, SpawnInput, Eot} = mk_cmd(os:type(), Cmd), + {SpawnCmd, SpawnOpts, SpawnInput, Eot} = mk_cmd(os:type(), validate(Cmd)), Port = open_port({spawn, SpawnCmd}, [binary, stderr_to_stdout, stream, in, hide | SpawnOpts]), MonRef = erlang:monitor(port, Port), @@ -266,8 +291,6 @@ mk_cmd({win32,Wtype}, Cmd) -> {Cspec,_} -> lists:concat([Cspec," /c",Cmd]) end, {Command, [], [], <<>>}; -mk_cmd(OsType,Cmd) when is_atom(Cmd) -> - mk_cmd(OsType, atom_to_list(Cmd)); mk_cmd(_,Cmd) -> %% Have to send command in like this in order to make sh commands like %% cd and ulimit available @@ -290,17 +313,33 @@ mk_cmd(_,Cmd) -> <<$\^D>>}. validate(Atom) when is_atom(Atom) -> - ok; + validate(atom_to_list(Atom)); validate(List) when is_list(List) -> - validate1(List). + case validate1(List) of + false -> + List; + true -> + %% Had zeros at end; remove them... + string:trim(List, trailing, [0]) + end. -validate1([C|Rest]) when is_integer(C) -> +validate1([0|Rest]) -> + validate2(Rest); +validate1([C|Rest]) when is_integer(C), C > 0 -> validate1(Rest); validate1([List|Rest]) when is_list(List) -> - validate1(List), - validate1(Rest); + validate1(List) or validate1(Rest); validate1([]) -> - ok. + false. + +%% Ensure that the rest is zero only... +validate2([]) -> + true; +validate2([0|Rest]) -> + validate2(Rest); +validate2([List|Rest]) when is_list(List) -> + validate2(List), + validate2(Rest). get_data(Port, MonRef, Eot, Sofar, Size, Max) -> receive diff --git a/lib/kernel/src/raw_file_io.erl b/lib/kernel/src/raw_file_io.erl new file mode 100644 index 0000000000..e3c07c8f78 --- /dev/null +++ b/lib/kernel/src/raw_file_io.erl @@ -0,0 +1,75 @@ +%% +%% %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% +%% +-module(raw_file_io). + +-export([open/2]). + +open(Filename, Modes) -> + %% Layers are applied in this order, and the listed modules will call this + %% function again as necessary. eg. a raw compressed delayed file in list + %% mode will walk through [_list -> _compressed -> _delayed -> _raw]. + ModuleOrder = [{raw_file_io_list, fun match_list/1}, + {raw_file_io_compressed, fun match_compressed/1}, + {raw_file_io_delayed, fun match_delayed/1}, + {raw_file_io_raw, fun match_raw/1}], + open_1(ModuleOrder, Filename, add_implicit_modes(Modes)). +open_1([], _Filename, _Modes) -> + error(badarg); +open_1([{Module, Match} | Rest], Filename, Modes) -> + case lists:any(Match, Modes) of + true -> + {Options, ChildModes} = + lists:partition(fun(Mode) -> Match(Mode) end, Modes), + Module:open_layer(Filename, ChildModes, Options); + false -> + open_1(Rest, Filename, Modes) + end. + +%% 'read' and 'list' mode are enabled unless disabled by another option, so +%% we'll explicitly add them to avoid duplicating this logic in child layers. +add_implicit_modes(Modes0) -> + Modes1 = add_unless_matched(Modes0, fun match_writable/1, read), + add_unless_matched(Modes1, fun match_binary/1, list). +add_unless_matched(Modes, Match, Default) -> + case lists:any(Match, Modes) of + false -> [Default | Modes]; + true -> Modes + end. + +match_list(list) -> true; +match_list(_Other) -> false. + +match_compressed(compressed) -> true; +match_compressed(_Other) -> false. + +match_delayed({delayed_write, _Size, _Timeout}) -> true; +match_delayed(delayed_write) -> true; +match_delayed(_Other) -> false. + +match_raw(raw) -> true; +match_raw(_Other) -> false. + +match_writable(write) -> true; +match_writable(append) -> true; +match_writable(exclusive) -> true; +match_writable(_Other) -> false. + +match_binary(binary) -> true; +match_binary(_Other) -> false. diff --git a/lib/kernel/src/raw_file_io_compressed.erl b/lib/kernel/src/raw_file_io_compressed.erl new file mode 100644 index 0000000000..d5ab042d25 --- /dev/null +++ b/lib/kernel/src/raw_file_io_compressed.erl @@ -0,0 +1,134 @@ +%% +%% %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% +%% +-module(raw_file_io_compressed). + +-export([close/1, sync/1, datasync/1, truncate/1, advise/4, allocate/3, + position/2, write/2, pwrite/2, pwrite/3, + read_line/1, read/2, pread/2, pread/3]). + +%% OTP internal. +-export([ipread_s32bu_p32bu/3, sendfile/8]). + +-export([open_layer/3]). + +-include("file_int.hrl"). + +open_layer(Filename, Modes, Options) -> + IsAppend = lists:member(append, Modes), + IsDeflate = lists:member(write, Modes), + IsInflate = lists:member(read, Modes), + if + IsDeflate, IsInflate; IsAppend -> + {error, einval}; + IsDeflate, not IsInflate -> + start_server_module(raw_file_io_deflate, Filename, Modes, Options); + IsInflate -> + start_server_module(raw_file_io_inflate, Filename, Modes, Options) + end. + +start_server_module(Module, Filename, Modes, Options) -> + Secret = make_ref(), + case gen_statem:start(Module, {self(), Secret, Options}, []) of + {ok, Pid} -> open_next_layer(Pid, Secret, Filename, Modes); + Other -> Other + end. + +open_next_layer(Pid, Secret, Filename, Modes) -> + case gen_statem:call(Pid, {'$open', Secret, Filename, Modes}, infinity) of + ok -> + PublicFd = #file_descriptor{ + module = raw_file_io_compressed, data = {self(), Pid} }, + {ok, PublicFd}; + Other -> Other + end. + +close(Fd) -> + wrap_call(Fd, [close]). + +sync(Fd) -> + wrap_call(Fd, [sync]). +datasync(Fd) -> + wrap_call(Fd, [datasync]). + +truncate(Fd) -> + wrap_call(Fd, [truncate]). + +advise(Fd, Offset, Length, Advise) -> + wrap_call(Fd, [advise, Offset, Length, Advise]). +allocate(Fd, Offset, Length) -> + wrap_call(Fd, [allocate, Offset, Length]). + +position(Fd, Mark) -> + wrap_call(Fd, [position, Mark]). + +write(Fd, IOData) -> + try + CompactedData = erlang:iolist_to_iovec(IOData), + wrap_call(Fd, [write, CompactedData]) + catch + error:badarg -> {error, badarg} + end. + +pwrite(Fd, Offset, IOData) -> + try + CompactedData = erlang:iolist_to_iovec(IOData), + wrap_call(Fd, [pwrite, Offset, CompactedData]) + catch + error:badarg -> {error, badarg} + end. +pwrite(Fd, LocBytes) -> + try + CompactedLocBytes = + [ {Offset, erlang:iolist_to_iovec(IOData)} || + {Offset, IOData} <- LocBytes ], + wrap_call(Fd, [pwrite, CompactedLocBytes]) + catch + error:badarg -> {error, badarg} + end. + +read_line(Fd) -> + wrap_call(Fd, [read_line]). +read(Fd, Size) -> + wrap_call(Fd, [read, Size]). +pread(Fd, Offset, Size) -> + wrap_call(Fd, [pread, Offset, Size]). +pread(Fd, LocNums) -> + wrap_call(Fd, [pread, LocNums]). + +ipread_s32bu_p32bu(Fd, Offset, MaxSize) -> + wrap_call(Fd, [ipread_s32bu_p32bu, Offset, MaxSize]). + +sendfile(_,_,_,_,_,_,_,_) -> + {error, enotsup}. + +wrap_call(Fd, Command) -> + {_Owner, Pid} = get_fd_data(Fd), + try gen_statem:call(Pid, Command, infinity) of + Result -> Result + catch + exit:{noproc, _StackTrace} -> {error, einval} + end. + +get_fd_data(#file_descriptor{ data = Data }) -> + {Owner, _ServerPid} = Data, + case self() of + Owner -> Data; + _ -> error(not_on_controlling_process) + end. diff --git a/lib/kernel/src/raw_file_io_deflate.erl b/lib/kernel/src/raw_file_io_deflate.erl new file mode 100644 index 0000000000..acfc546743 --- /dev/null +++ b/lib/kernel/src/raw_file_io_deflate.erl @@ -0,0 +1,159 @@ +%% +%% %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% +%% +-module(raw_file_io_deflate). + +-behavior(gen_statem). + +-export([init/1, callback_mode/0, terminate/3]). +-export([opening/3, opened/3]). + +-include("file_int.hrl"). + +-define(GZIP_WBITS, 16 + 15). + +callback_mode() -> state_functions. + +init({Owner, Secret, [compressed]}) -> + Monitor = monitor(process, Owner), + Z = zlib:open(), + ok = zlib:deflateInit(Z, default, deflated, ?GZIP_WBITS, 8, default), + Data = + #{ owner => Owner, + monitor => Monitor, + secret => Secret, + position => 0, + zlib => Z }, + {ok, opening, Data}. + +opening({call, From}, {'$open', Secret, Filename, Modes}, #{ secret := Secret } = Data) -> + case raw_file_io:open(Filename, Modes) of + {ok, PrivateFd} -> + NewData = Data#{ handle => PrivateFd }, + {next_state, opened, NewData, [{reply, From, ok}]}; + Other -> + {stop_and_reply, normal, [{reply, From, Other}]} + end; +opening(_Event, _Contents, _Data) -> + {keep_state_and_data, [postpone]}. + +%% + +opened(info, {'DOWN', Monitor, process, _Owner, Reason}, #{ monitor := Monitor } = Data) -> + if + Reason =/= kill -> flush_deflate_state(Data); + Reason =:= kill -> ignored + end, + {stop, shutdown}; + +opened(info, _Message, _Data) -> + keep_state_and_data; + +opened({call, {Owner, _Tag} = From}, [close], #{ owner := Owner } = Data) -> + #{ handle := PrivateFd } = Data, + Response = + case flush_deflate_state(Data) of + ok -> ?CALL_FD(PrivateFd, close, []); + Other -> Other + end, + {stop_and_reply, normal, [{reply, From, Response}]}; + +opened({call, {Owner, _Tag} = From}, [position, Mark], #{ owner := Owner } = Data) -> + case position(Data, Mark) of + {ok, NewData, Result} -> + Response = {ok, Result}, + {keep_state, NewData, [{reply, From, Response}]}; + Other -> + {keep_state_and_data, [{reply, From, Other}]} + end; + +opened({call, {Owner, _Tag} = From}, [write, IOVec], #{ owner := Owner } = Data) -> + case write(Data, IOVec) of + {ok, NewData} -> {keep_state, NewData, [{reply, From, ok}]}; + Other -> {keep_state_and_data, [{reply, From, Other}]} + end; + +opened({call, {Owner, _Tag} = From}, [read, _Size], #{ owner := Owner }) -> + Response = {error, ebadf}, + {keep_state_and_data, [{reply, From, Response}]}; + +opened({call, {Owner, _Tag} = From}, [read_line], #{ owner := Owner }) -> + Response = {error, ebadf}, + {keep_state_and_data, [{reply, From, Response}]}; + +opened({call, {Owner, _Tag} = From}, _Command, #{ owner := Owner }) -> + Response = {error, enotsup}, + {keep_state_and_data, [{reply, From, Response}]}; + +opened({call, _From}, _Command, _Data) -> + %% The client functions filter this out, so we'll crash if the user does + %% anything stupid on purpose. + {shutdown, protocol_violation}; + +opened(_Event, _Request, _Data) -> + keep_state_and_data. + +write(Data, IOVec) -> + #{ handle := PrivateFd, position := Position, zlib := Z } = Data, + UncompressedSize = iolist_size(IOVec), + case ?CALL_FD(PrivateFd, write, [zlib:deflate(Z, IOVec)]) of + ok -> {ok, Data#{ position := (Position + UncompressedSize) }}; + Other -> Other + end. + +%% +%% We support "seeking" forward as long as it isn't relative to EOF. +%% +%% Seeking is a bit of a misnomer as it's really just compressing zeroes until +%% we reach the desired point, but it has always behaved like this. +%% + +position(Data, Mark) when is_atom(Mark) -> + position(Data, {Mark, 0}); +position(Data, Offset) when is_integer(Offset) -> + position(Data, {bof, Offset}); +position(Data, {bof, Offset}) when is_integer(Offset) -> + position_1(Data, Offset); +position(Data, {cur, Offset}) when is_integer(Offset) -> + #{ position := Position } = Data, + position_1(Data, Position + Offset); +position(_Data, {eof, Offset}) when is_integer(Offset) -> + {error, einval}; +position(_Data, _Any) -> + {error, badarg}. + +position_1(#{ position := Desired } = Data, Desired) -> + {ok, Data, Desired}; +position_1(#{ position := Current } = Data, Desired) when Current < Desired -> + BytesToWrite = min(Desired - Current, 4 bsl 20), + case write(Data, <<0:(BytesToWrite)/unit:8>>) of + {ok, NewData} -> position_1(NewData, Desired); + Other -> Other + end; +position_1(#{ position := Current }, Desired) when Current > Desired -> + {error, einval}. + +flush_deflate_state(#{ handle := PrivateFd, zlib := Z }) -> + case ?CALL_FD(PrivateFd, write, [zlib:deflate(Z, [], finish)]) of + ok -> ok; + Other -> Other + end. + +terminate(_Reason, _State, _Data) -> + ok. diff --git a/lib/kernel/src/raw_file_io_delayed.erl b/lib/kernel/src/raw_file_io_delayed.erl new file mode 100644 index 0000000000..d2ad7550a1 --- /dev/null +++ b/lib/kernel/src/raw_file_io_delayed.erl @@ -0,0 +1,320 @@ +%% +%% %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% +%% +-module(raw_file_io_delayed). + +-behavior(gen_statem). + +-export([close/1, sync/1, datasync/1, truncate/1, advise/4, allocate/3, + position/2, write/2, pwrite/2, pwrite/3, + read_line/1, read/2, pread/2, pread/3]). + +%% OTP internal. +-export([ipread_s32bu_p32bu/3, sendfile/8]). + +-export([open_layer/3]). + +-export([init/1, callback_mode/0, terminate/3]). +-export([opening/3, opened/3]). + +-include("file_int.hrl"). + +open_layer(Filename, Modes, Options) -> + Secret = make_ref(), + case gen_statem:start(?MODULE, {self(), Secret, Options}, []) of + {ok, Pid} -> + gen_statem:call(Pid, {'$open', Secret, Filename, Modes}, infinity); + Other -> + Other + end. + +callback_mode() -> state_functions. + +init({Owner, Secret, Options}) -> + Monitor = monitor(process, Owner), + Defaults = + #{ owner => Owner, + monitor => Monitor, + secret => Secret, + timer => none, + pid => self(), + buffer => prim_buffer:new(), + delay_size => 64 bsl 10, + delay_time => 2000 }, + Data = fill_delay_values(Defaults, Options), + {ok, opening, Data}. + +fill_delay_values(Data, []) -> + Data; +fill_delay_values(Data, [{delayed_write, Size, Time} | Options]) -> + fill_delay_values(Data#{ delay_size => Size, delay_time => Time }, Options); +fill_delay_values(Data, [_ | Options]) -> + fill_delay_values(Data, Options). + +opening({call, From}, {'$open', Secret, Filename, Modes}, #{ secret := Secret } = Data) -> + case raw_file_io:open(Filename, Modes) of + {ok, PrivateFd} -> + PublicData = maps:with([owner, buffer, delay_size, pid], Data), + PublicFd = #file_descriptor{ module = ?MODULE, data = PublicData }, + + NewData = Data#{ handle => PrivateFd }, + Response = {ok, PublicFd}, + {next_state, opened, NewData, [{reply, From, Response}]}; + Other -> + {stop_and_reply, normal, [{reply, From, Other}]} + end; +opening(_Event, _Contents, _Data) -> + {keep_state_and_data, [postpone]}. + +%% + +opened(info, {'$timed_out', Secret}, #{ secret := Secret } = Data) -> + %% If the user writes something at this exact moment, the flush will fail + %% and the timer won't reset on the next write since the buffer won't be + %% empty (Unless we collided on a flush). We therefore reset the timeout to + %% ensure that data won't sit idle for extended periods of time. + case try_flush_write_buffer(Data) of + busy -> gen_statem:cast(self(), '$reset_timeout'); + ok -> ok + end, + {keep_state, Data#{ timer => none }, []}; + +opened(info, {'DOWN', Monitor, process, _Owner, Reason}, #{ monitor := Monitor } = Data) -> + if + Reason =/= kill -> try_flush_write_buffer(Data); + Reason =:= kill -> ignored + end, + {stop, shutdown}; + +opened(info, _Message, _Data) -> + keep_state_and_data; + +opened({call, {Owner, _Tag} = From}, [close], #{ owner := Owner } = Data) -> + case flush_write_buffer(Data) of + ok -> + #{ handle := PrivateFd } = Data, + Response = ?CALL_FD(PrivateFd, close, []), + {stop_and_reply, normal, [{reply, From, Response}]}; + Other -> + {stop_and_reply, normal, [{reply, From, Other}]} + end; + +opened({call, {Owner, _Tag} = From}, '$wait', #{ owner := Owner }) -> + %% Used in write/2 to synchronize writes on lock conflicts. + {keep_state_and_data, [{reply, From, ok}]}; + +opened({call, {Owner, _Tag} = From}, '$synchronous_flush', #{ owner := Owner } = Data) -> + cancel_flush_timeout(Data), + Response = flush_write_buffer(Data), + {keep_state_and_data, [{reply, From, Response}]}; + +opened({call, {Owner, _Tag} = From}, Command, #{ owner := Owner } = Data) -> + Response = + case flush_write_buffer(Data) of + ok -> dispatch_command(Data, Command); + Other -> Other + end, + {keep_state_and_data, [{reply, From, Response}]}; + +opened({call, _From}, _Command, _Data) -> + %% The client functions filter this out, so we'll crash if the user does + %% anything stupid on purpose. + {shutdown, protocol_violation}; + +opened(cast, '$reset_timeout', #{ delay_time := Timeout, secret := Secret } = Data) -> + cancel_flush_timeout(Data), + Timer = erlang:send_after(Timeout, self(), {'$timed_out', Secret}), + {keep_state, Data#{ timer => Timer }, []}; + +opened(cast, _Message, _Data) -> + {keep_state_and_data, []}. + +dispatch_command(Data, [Function | Args]) -> + #{ handle := Handle } = Data, + Module = Handle#file_descriptor.module, + apply(Module, Function, [Handle | Args]). + +cancel_flush_timeout(#{ timer := none }) -> + ok; +cancel_flush_timeout(#{ timer := Timer }) -> + _ = erlang:cancel_timer(Timer, [{async, true}]), + ok. + +try_flush_write_buffer(#{ buffer := Buffer, handle := PrivateFd }) -> + case prim_buffer:try_lock(Buffer) of + acquired -> + flush_write_buffer_1(Buffer, PrivateFd), + prim_buffer:unlock(Buffer), + ok; + busy -> + busy + end. + +%% This is only safe to use when there is no chance of conflict with the owner +%% process, or in other words, "during synchronous calls outside of the locked +%% section of write/2" +flush_write_buffer(#{ buffer := Buffer, handle := PrivateFd }) -> + acquired = prim_buffer:try_lock(Buffer), + Result = flush_write_buffer_1(Buffer, PrivateFd), + prim_buffer:unlock(Buffer), + Result. + +flush_write_buffer_1(Buffer, PrivateFd) -> + case prim_buffer:size(Buffer) of + Size when Size > 0 -> + ?CALL_FD(PrivateFd, write, [prim_buffer:read_iovec(Buffer, Size)]); + 0 -> + ok + end. + +terminate(_Reason, _State, _Data) -> + ok. + +%% Client functions + +write(Fd, IOData) -> + try + enqueue_write(Fd, erlang:iolist_to_iovec(IOData)) + catch + error:badarg -> {error, badarg} + end. +enqueue_write(_Fd, []) -> + ok; +enqueue_write(Fd, IOVec) -> + %% get_fd_data will reject everyone except the process that opened the Fd, + %% so we can't race with anyone except the wrapper process. + #{ delay_size := DelaySize, + buffer := Buffer, + pid := Pid } = get_fd_data(Fd), + case prim_buffer:try_lock(Buffer) of + acquired -> + %% (The wrapper process will exit without flushing if we're killed + %% while holding the lock). + enqueue_write_locked(Pid, Buffer, DelaySize, IOVec); + busy -> + %% This can only happen while we're processing a timeout in the + %% wrapper process, so we perform a bogus call to get a completion + %% notification before trying again. + gen_statem:call(Pid, '$wait'), + enqueue_write(Fd, IOVec) + end. +enqueue_write_locked(Pid, Buffer, DelaySize, IOVec) -> + %% The synchronous operations (write, forced flush) are safe since we're + %% running on the only process that can fill the buffer; a timeout being + %% processed just before $synchronous_flush will cause the flush to nop, + %% and a timeout sneaking in just before a synchronous write won't do + %% anything since the buffer is guaranteed to be empty at that point. + BufSize = prim_buffer:size(Buffer), + case is_iovec_smaller_than(IOVec, DelaySize - BufSize) of + true when BufSize > 0 -> + prim_buffer:write(Buffer, IOVec), + prim_buffer:unlock(Buffer); + true -> + prim_buffer:write(Buffer, IOVec), + prim_buffer:unlock(Buffer), + gen_statem:cast(Pid, '$reset_timeout'); + false when BufSize > 0 -> + prim_buffer:write(Buffer, IOVec), + prim_buffer:unlock(Buffer), + gen_statem:call(Pid, '$synchronous_flush'); + false -> + prim_buffer:unlock(Buffer), + gen_statem:call(Pid, [write, IOVec]) + end. + +%% iolist_size/1 will always look through the entire list to get a precise +%% amount, which is pretty inefficient since we only need to know whether we've +%% hit the buffer threshold or not. +%% +%% We only handle the binary case since write/2 forcibly translates input to +%% erlang:iovec(). +is_iovec_smaller_than(IOVec, Max) -> + is_iovec_smaller_than_1(IOVec, Max, 0). +is_iovec_smaller_than_1(_IOVec, Max, Acc) when Acc >= Max -> + false; +is_iovec_smaller_than_1([], _Max, _Acc) -> + true; +is_iovec_smaller_than_1([Binary | Rest], Max, Acc) when is_binary(Binary) -> + is_iovec_smaller_than_1(Rest, Max, Acc + byte_size(Binary)). + +close(Fd) -> + wrap_call(Fd, [close]). + +sync(Fd) -> + wrap_call(Fd, [sync]). +datasync(Fd) -> + wrap_call(Fd, [datasync]). + +truncate(Fd) -> + wrap_call(Fd, [truncate]). + +advise(Fd, Offset, Length, Advise) -> + wrap_call(Fd, [advise, Offset, Length, Advise]). +allocate(Fd, Offset, Length) -> + wrap_call(Fd, [allocate, Offset, Length]). + +position(Fd, Mark) -> + wrap_call(Fd, [position, Mark]). + +pwrite(Fd, Offset, IOData) -> + try + CompactedData = erlang:iolist_to_iovec(IOData), + wrap_call(Fd, [pwrite, Offset, CompactedData]) + catch + error:badarg -> {error, badarg} + end. +pwrite(Fd, LocBytes) -> + try + CompactedLocBytes = + [ {Offset, erlang:iolist_to_iovec(IOData)} || + {Offset, IOData} <- LocBytes ], + wrap_call(Fd, [pwrite, CompactedLocBytes]) + catch + error:badarg -> {error, badarg} + end. + +read_line(Fd) -> + wrap_call(Fd, [read_line]). +read(Fd, Size) -> + wrap_call(Fd, [read, Size]). +pread(Fd, Offset, Size) -> + wrap_call(Fd, [pread, Offset, Size]). +pread(Fd, LocNums) -> + wrap_call(Fd, [pread, LocNums]). + +ipread_s32bu_p32bu(Fd, Offset, MaxSize) -> + wrap_call(Fd, [ipread_s32bu_p32bu, Offset, MaxSize]). + +sendfile(_,_,_,_,_,_,_,_) -> + {error, enotsup}. + +wrap_call(Fd, Command) -> + #{ pid := Pid } = get_fd_data(Fd), + try gen_statem:call(Pid, Command, infinity) of + Result -> Result + catch + exit:{noproc, _StackTrace} -> {error, einval} + end. + +get_fd_data(#file_descriptor{ data = Data }) -> + #{ owner := Owner } = Data, + case self() of + Owner -> Data; + _ -> error(not_on_controlling_process) + end. diff --git a/lib/kernel/src/raw_file_io_inflate.erl b/lib/kernel/src/raw_file_io_inflate.erl new file mode 100644 index 0000000000..7e9780310c --- /dev/null +++ b/lib/kernel/src/raw_file_io_inflate.erl @@ -0,0 +1,261 @@ +%% +%% %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% +%% +-module(raw_file_io_inflate). + +-behavior(gen_statem). + +-export([init/1, callback_mode/0, terminate/3]). +-export([opening/3, opened_gzip/3, opened_passthrough/3]). + +-include("file_int.hrl"). + +-define(INFLATE_CHUNK_SIZE, (1 bsl 10)). +-define(GZIP_WBITS, (16 + 15)). + +callback_mode() -> state_functions. + +init({Owner, Secret, [compressed]}) -> + Monitor = monitor(process, Owner), + %% We're using the undocumented inflateInit/3 to open the stream in + %% 'reset mode', which resets the inflate state at the end of every stream, + %% allowing us to read concatenated gzip files. + Z = zlib:open(), + ok = zlib:inflateInit(Z, ?GZIP_WBITS, reset), + Data = + #{ owner => Owner, + monitor => Monitor, + secret => Secret, + position => 0, + buffer => prim_buffer:new(), + zlib => Z }, + {ok, opening, Data}. + +%% The old driver fell back to plain reads if the file didn't start with the +%% magic gzip bytes. +choose_decompression_state(PrivateFd) -> + State = + case ?CALL_FD(PrivateFd, read, [2]) of + {ok, <<16#1F, 16#8B>>} -> opened_gzip; + _Other -> opened_passthrough + end, + {ok, 0} = ?CALL_FD(PrivateFd, position, [0]), + State. + +opening({call, From}, {'$open', Secret, Filename, Modes}, #{ secret := Secret } = Data) -> + case raw_file_io:open(Filename, Modes) of + {ok, PrivateFd} -> + NextState = choose_decompression_state(PrivateFd), + NewData = Data#{ handle => PrivateFd }, + {next_state, NextState, NewData, [{reply, From, ok}]}; + Other -> + {stop_and_reply, normal, [{reply, From, Other}]} + end; +opening(_Event, _Contents, _Data) -> + {keep_state_and_data, [postpone]}. + +internal_close(From, Data) -> + #{ handle := PrivateFd } = Data, + Response = ?CALL_FD(PrivateFd, close, []), + {stop_and_reply, normal, [{reply, From, Response}]}. + +opened_passthrough(info, {'DOWN', Monitor, process, _Owner, _Reason}, #{ monitor := Monitor }) -> + {stop, shutdown}; + +opened_passthrough(info, _Message, _Data) -> + keep_state_and_data; + +opened_passthrough({call, {Owner, _Tag} = From}, [close], #{ owner := Owner } = Data) -> + internal_close(From, Data); + +opened_passthrough({call, {Owner, _Tag} = From}, [Method | Args], #{ owner := Owner } = Data) -> + #{ handle := PrivateFd } = Data, + Response = ?CALL_FD(PrivateFd, Method, Args), + {keep_state_and_data, [{reply, From, Response}]}; + +opened_passthrough({call, _From}, _Command, _Data) -> + %% The client functions filter this out, so we'll crash if the user does + %% anything stupid on purpose. + {shutdown, protocol_violation}; + +opened_passthrough(_Event, _Request, _Data) -> + keep_state_and_data. + +%% + +opened_gzip(info, {'DOWN', Monitor, process, _Owner, _Reason}, #{ monitor := Monitor }) -> + {stop, shutdown}; + +opened_gzip(info, _Message, _Data) -> + keep_state_and_data; + +opened_gzip({call, {Owner, _Tag} = From}, [close], #{ owner := Owner } = Data) -> + internal_close(From, Data); + +opened_gzip({call, {Owner, _Tag} = From}, [position, Mark], #{ owner := Owner } = Data) -> + case position(Data, Mark) of + {ok, NewData, Result} -> + Response = {ok, Result}, + {keep_state, NewData, [{reply, From, Response}]}; + Other -> + {keep_state_and_data, [{reply, From, Other}]} + end; + +opened_gzip({call, {Owner, _Tag} = From}, [read, Size], #{ owner := Owner } = Data) -> + case read(Data, Size) of + {ok, NewData, Result} -> + Response = {ok, Result}, + {keep_state, NewData, [{reply, From, Response}]}; + Other -> + {keep_state_and_data, [{reply, From, Other}]} + end; + +opened_gzip({call, {Owner, _Tag} = From}, [read_line], #{ owner := Owner } = Data) -> + case read_line(Data) of + {ok, NewData, Result} -> + Response = {ok, Result}, + {keep_state, NewData, [{reply, From, Response}]}; + Other -> + {keep_state_and_data, [{reply, From, Other}]} + end; + +opened_gzip({call, {Owner, _Tag} = From}, [write, _IOData], #{ owner := Owner }) -> + Response = {error, ebadf}, + {keep_state_and_data, [{reply, From, Response}]}; + +opened_gzip({call, {Owner, _Tag} = From}, _Request, #{ owner := Owner }) -> + Response = {error, enotsup}, + {keep_state_and_data, [{reply, From, Response}]}; + +opened_gzip({call, _From}, _Request, _Data) -> + %% The client functions filter this out, so we'll crash if the user does + %% anything stupid on purpose. + {shutdown, protocol_violation}; + +opened_gzip(_Event, _Request, _Data) -> + keep_state_and_data. + +%% + +read(#{ buffer := Buffer } = Data, Size) -> + try read_1(Data, Buffer, prim_buffer:size(Buffer), Size) of + Result -> Result + catch + error:badarg -> {error, badarg}; + error:_ -> {error, eio} + end. +read_1(Data, Buffer, BufferSize, ReadSize) when BufferSize >= ReadSize -> + #{ position := Position } = Data, + Decompressed = prim_buffer:read(Buffer, ReadSize), + {ok, Data#{ position => (Position + ReadSize) }, Decompressed}; +read_1(Data, Buffer, BufferSize, ReadSize) when BufferSize < ReadSize -> + #{ handle := PrivateFd } = Data, + case ?CALL_FD(PrivateFd, read, [?INFLATE_CHUNK_SIZE]) of + {ok, Compressed} -> + #{ zlib := Z } = Data, + Uncompressed = erlang:iolist_to_iovec(zlib:inflate(Z, Compressed)), + prim_buffer:write(Buffer, Uncompressed), + read_1(Data, Buffer, prim_buffer:size(Buffer), ReadSize); + eof when BufferSize > 0 -> + read_1(Data, Buffer, BufferSize, BufferSize); + Other -> + Other + end. + +read_line(#{ buffer := Buffer } = Data) -> + try read_line_1(Data, Buffer, prim_buffer:find_byte_index(Buffer, $\n)) of + {ok, NewData, Decompressed} -> {ok, NewData, Decompressed}; + Other -> Other + catch + error:badarg -> {error, badarg}; + error:_ -> {error, eio} + end. + +read_line_1(Data, Buffer, not_found) -> + #{ handle := PrivateFd, zlib := Z } = Data, + case ?CALL_FD(PrivateFd, read, [?INFLATE_CHUNK_SIZE]) of + {ok, Compressed} -> + Uncompressed = erlang:iolist_to_iovec(zlib:inflate(Z, Compressed)), + prim_buffer:write(Buffer, Uncompressed), + read_line_1(Data, Buffer, prim_buffer:find_byte_index(Buffer, $\n)); + eof -> + case prim_buffer:size(Buffer) of + Size when Size > 0 -> {ok, prim_buffer:read(Buffer, Size)}; + Size when Size =:= 0 -> eof + end; + Error -> + Error + end; +read_line_1(Data, Buffer, {ok, LFIndex}) -> + %% Translate CRLF into just LF, completely ignoring which encoding is used, + %% but treat the file position as including CR. + #{ position := Position } = Data, + NewData = Data#{ position => (Position + LFIndex + 1) }, + CRIndex = (LFIndex - 1), + TranslatedLine = + case prim_buffer:read(Buffer, LFIndex + 1) of + <<Line:CRIndex/binary, "\r\n">> -> <<Line/binary, "\n">>; + Line -> Line + end, + {ok, NewData, TranslatedLine}. + +%% +%% We support seeking in both directions as long as it isn't relative to EOF. +%% +%% Seeking backwards is extremely inefficient since we have to seek to the very +%% beginning and then decompress up to the desired point. +%% + +position(Data, Mark) when is_atom(Mark) -> + position(Data, {Mark, 0}); +position(Data, Offset) when is_integer(Offset) -> + position(Data, {bof, Offset}); +position(Data, {bof, Offset}) when is_integer(Offset) -> + position_1(Data, Offset); +position(Data, {cur, Offset}) when is_integer(Offset) -> + #{ position := Position } = Data, + position_1(Data, Position + Offset); +position(_Data, {eof, Offset}) when is_integer(Offset) -> + {error, einval}; +position(_Data, _Other) -> + {error, badarg}. + +position_1(_Data, Desired) when Desired < 0 -> + {error, einval}; +position_1(#{ position := Desired } = Data, Desired) -> + {ok, Data, Desired}; +position_1(#{ position := Current } = Data, Desired) when Current < Desired -> + case read(Data, min(Desired - Current, ?INFLATE_CHUNK_SIZE)) of + {ok, NewData, _Data} -> position_1(NewData, Desired); + eof -> {ok, Data, Current}; + Other -> Other + end; +position_1(#{ position := Current } = Data, Desired) when Current > Desired -> + #{ handle := PrivateFd, buffer := Buffer, zlib := Z } = Data, + case ?CALL_FD(PrivateFd, position, [bof]) of + {ok, 0} -> + ok = zlib:inflateReset(Z), + prim_buffer:wipe(Buffer), + position_1(Data#{ position => 0 }, Desired); + Other -> + Other + end. + +terminate(_Reason, _State, _Data) -> + ok. diff --git a/lib/kernel/src/raw_file_io_list.erl b/lib/kernel/src/raw_file_io_list.erl new file mode 100644 index 0000000000..2e16e63f0e --- /dev/null +++ b/lib/kernel/src/raw_file_io_list.erl @@ -0,0 +1,128 @@ +%% +%% %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% +%% +-module(raw_file_io_list). + +-export([close/1, sync/1, datasync/1, truncate/1, advise/4, allocate/3, + position/2, write/2, pwrite/2, pwrite/3, + read_line/1, read/2, pread/2, pread/3]). + +%% OTP internal. +-export([ipread_s32bu_p32bu/3, sendfile/8]). + +-export([open_layer/3]). + +-include("file_int.hrl"). + +open_layer(Filename, Modes, [list]) -> + case raw_file_io:open(Filename, [binary | Modes]) of + {ok, PrivateFd} -> {ok, make_public_fd(PrivateFd, Modes)}; + Other -> Other + end. + +%% We can skip wrapping the file if it's write-only since only read operations +%% are affected by list mode. Since raw_file_io fills in all implicit options +%% for us, all we need to do is check whether 'read' is among them. +make_public_fd(PrivateFd, Modes) -> + case lists:member(read, Modes) of + true -> #file_descriptor{ module = ?MODULE, data = PrivateFd }; + false -> PrivateFd + end. + +close(Fd) -> + PrivateFd = Fd#file_descriptor.data, + ?CALL_FD(PrivateFd, close, []). + +sync(Fd) -> + PrivateFd = Fd#file_descriptor.data, + ?CALL_FD(PrivateFd, sync, []). +datasync(Fd) -> + PrivateFd = Fd#file_descriptor.data, + ?CALL_FD(PrivateFd, datasync, []). + +truncate(Fd) -> + PrivateFd = Fd#file_descriptor.data, + ?CALL_FD(PrivateFd, truncate, []). + +advise(Fd, Offset, Length, Advise) -> + PrivateFd = Fd#file_descriptor.data, + ?CALL_FD(PrivateFd, advise, [Offset, Length, Advise]). +allocate(Fd, Offset, Length) -> + PrivateFd = Fd#file_descriptor.data, + ?CALL_FD(PrivateFd, allocate, [Offset, Length]). + +position(Fd, Mark) -> + PrivateFd = Fd#file_descriptor.data, + ?CALL_FD(PrivateFd, position, [Mark]). + +write(Fd, IOData) -> + PrivateFd = Fd#file_descriptor.data, + ?CALL_FD(PrivateFd, write, [IOData]). + +pwrite(Fd, Offset, IOData) -> + PrivateFd = Fd#file_descriptor.data, + ?CALL_FD(PrivateFd, pwrite, [Offset, IOData]). +pwrite(Fd, LocBytes) -> + PrivateFd = Fd#file_descriptor.data, + ?CALL_FD(PrivateFd, pwrite, [LocBytes]). + +read_line(Fd) -> + PrivateFd = Fd#file_descriptor.data, + case ?CALL_FD(PrivateFd, read_line, []) of + {ok, Binary} -> {ok, binary_to_list(Binary)}; + Other -> Other + end. +read(Fd, Size) -> + PrivateFd = Fd#file_descriptor.data, + case ?CALL_FD(PrivateFd, read, [Size]) of + {ok, Binary} -> {ok, binary_to_list(Binary)}; + Other -> Other + end. +pread(Fd, Offset, Size) -> + PrivateFd = Fd#file_descriptor.data, + case ?CALL_FD(PrivateFd, pread, [Offset, Size]) of + {ok, Binary} -> {ok, binary_to_list(Binary)}; + Other -> Other + end. +pread(Fd, LocNums) -> + PrivateFd = Fd#file_descriptor.data, + case ?CALL_FD(PrivateFd, pread, [LocNums]) of + {ok, LocResults} -> + TranslatedResults = + [ case Result of + Result when is_binary(Result) -> binary_to_list(Result); + eof -> eof + end || Result <- LocResults ], + {ok, TranslatedResults}; + Other -> Other + end. + +ipread_s32bu_p32bu(Fd, Offset, MaxSize) -> + PrivateFd = Fd#file_descriptor.data, + case ?CALL_FD(PrivateFd, ipread_s32bu_p32bu, [Offset, MaxSize]) of + {ok, {Size, Pointer, Binary}} when is_binary(Binary) -> + {ok, {Size, Pointer, binary_to_list(Binary)}}; + Other -> + Other + end. + +sendfile(Fd, Dest, Offset, Bytes, ChunkSize, Headers, Trailers, Flags) -> + Args = [Dest, Offset, Bytes, ChunkSize, Headers, Trailers, Flags], + PrivateFd = Fd#file_descriptor.data, + ?CALL_FD(PrivateFd, sendfile, Args). diff --git a/lib/ssh/src/ssh_dbg.hrl b/lib/kernel/src/raw_file_io_raw.erl index e94664737b..9a9fe78eb1 100644 --- a/lib/ssh/src/ssh_dbg.hrl +++ b/lib/kernel/src/raw_file_io_raw.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2004-2016. All Rights Reserved. +%% 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. @@ -17,11 +17,9 @@ %% %% %CopyrightEnd% %% +-module(raw_file_io_raw). --ifndef(SSH_DBG_HRL). --define(SSH_DBG_HRL, 1). +-export([open_layer/3]). --define(formatrec(RecName,R), - ssh_dbg:wr_record(R, record_info(fields,RecName), [])). - --endif. % SSH_DBG_HRL defined +open_layer(Filename, Modes, [raw]) -> + prim_file:open(Filename, [raw | Modes]). diff --git a/lib/kernel/src/rpc.erl b/lib/kernel/src/rpc.erl index 0e0b7dffa3..d197de942f 100644 --- a/lib/kernel/src/rpc.erl +++ b/lib/kernel/src/rpc.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2017. All Rights Reserved. +%% Copyright Ericsson AB 1996-2018. 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. @@ -418,10 +418,7 @@ abcast(Name, Mess) -> abcast([Node|Tail], Name, Mess) -> Dest = {Name,Node}, - case catch erlang:send(Dest, Mess, [noconnect]) of - noconnect -> spawn(erlang, send, [Dest,Mess]), ok; - _ -> ok - end, + try erlang:send(Dest, Mess) catch error:_ -> ok end, abcast(Tail, Name, Mess); abcast([], _,_) -> abcast. @@ -498,7 +495,7 @@ start_monitor(Node, Name) -> Module :: module(), Function :: atom(), Args :: [term()], - ResL :: [term()], + ResL :: [Res :: term() | {'badrpc', Reason :: term()}], BadNodes :: [node()]. multicall(M, F, A) -> @@ -509,14 +506,14 @@ multicall(M, F, A) -> Module :: module(), Function :: atom(), Args :: [term()], - ResL :: [term()], + ResL :: [Res :: term() | {'badrpc', Reason :: term()}], BadNodes :: [node()]; (Module, Function, Args, Timeout) -> {ResL, BadNodes} when Module :: module(), Function :: atom(), Args :: [term()], Timeout :: timeout(), - ResL :: [term()], + ResL :: [Res :: term() | {'badrpc', Reason :: term()}], BadNodes :: [node()]. multicall(Nodes, M, F, A) when is_list(Nodes) -> @@ -531,7 +528,7 @@ multicall(M, F, A, Timeout) -> Function :: atom(), Args :: [term()], Timeout :: timeout(), - ResL :: [term()], + ResL :: [Res :: term() | {'badrpc', Reason :: term()}], BadNodes :: [node()]. multicall(Nodes, M, F, A, infinity) diff --git a/lib/kernel/src/seq_trace.erl b/lib/kernel/src/seq_trace.erl index cc0c10909b..8d7aba0f27 100644 --- a/lib/kernel/src/seq_trace.erl +++ b/lib/kernel/src/seq_trace.erl @@ -41,7 +41,7 @@ -type flag() :: 'send' | 'receive' | 'print' | 'timestamp' | 'monotonic_timestamp' | 'strict_monotonic_timestamp'. -type component() :: 'label' | 'serial' | flag(). --type value() :: (Integer :: non_neg_integer()) +-type value() :: (Label :: term()) | {Previous :: non_neg_integer(), Current :: non_neg_integer()} | (Bool :: boolean()). @@ -59,10 +59,6 @@ set_token({Flags,Label,Serial,_From,Lastcnt}) -> F = decode_flags(Flags), set_token2([{label,Label},{serial,{Lastcnt, Serial}} | F]). -%% We limit the label type to always be a small integer because erl_interface -%% expects that, the BIF can however "unofficially" handle atoms as well, and -%% atoms can be used if only Erlang nodes are involved - -spec set_token(Component, Val) -> {Component, OldVal} when Component :: component(), Val :: value(), diff --git a/lib/kernel/test/Makefile b/lib/kernel/test/Makefile index efe3a68531..03b6355056 100644 --- a/lib/kernel/test/Makefile +++ b/lib/kernel/test/Makefile @@ -80,7 +80,8 @@ MODULES= \ loose_node \ sendfile_SUITE \ standard_error_SUITE \ - multi_load_SUITE + multi_load_SUITE \ + zzz_SUITE APP_FILES = \ appinc.app \ diff --git a/lib/kernel/test/code_SUITE.erl b/lib/kernel/test/code_SUITE.erl index 569753155f..902196def2 100644 --- a/lib/kernel/test/code_SUITE.erl +++ b/lib/kernel/test/code_SUITE.erl @@ -931,37 +931,34 @@ purge_stacktrace(Config) when is_list(Config) -> code:purge(code_b_test), try code_b_test:call(fun(b) -> ok end, a) catch - error:function_clause -> + error:function_clause:Stacktrace -> code:load_file(code_b_test), - case erlang:get_stacktrace() of + case Stacktrace of [{?MODULE,_,[a],_}, {code_b_test,call,2,_}, {?MODULE,purge_stacktrace,1,_}|_] -> - false = code:purge(code_b_test), - [] = erlang:get_stacktrace() + false = code:purge(code_b_test) end end, try code_b_test:call(nofun, 2) catch - error:function_clause -> + error:function_clause:Stacktrace2 -> code:load_file(code_b_test), - case erlang:get_stacktrace() of + case Stacktrace2 of [{code_b_test,call,[nofun,2],_}, {?MODULE,purge_stacktrace,1,_}|_] -> - false = code:purge(code_b_test), - [] = erlang:get_stacktrace() + false = code:purge(code_b_test) end end, Args = [erlang,error,[badarg]], try code_b_test:call(erlang, error, [badarg,Args]) catch - error:badarg -> + error:badarg:Stacktrace3 -> code:load_file(code_b_test), - case erlang:get_stacktrace() of + case Stacktrace3 of [{code_b_test,call,Args,_}, {?MODULE,purge_stacktrace,1,_}|_] -> - false = code:purge(code_b_test), - [] = erlang:get_stacktrace() + false = code:purge(code_b_test) end end, ok. diff --git a/lib/kernel/test/disk_log_SUITE.erl b/lib/kernel/test/disk_log_SUITE.erl index 12e2521939..0709a6e766 100644 --- a/lib/kernel/test/disk_log_SUITE.erl +++ b/lib/kernel/test/disk_log_SUITE.erl @@ -89,8 +89,6 @@ dist_terminate/1, dist_accessible/1, dist_deadlock/1, dist_open2/1, other_groups/1, - evil/1, - otp_6278/1, otp_10131/1]). -export([head_fun/1, hf/0, lserv/1, @@ -123,7 +121,7 @@ [halt_int, wrap_int, halt_ext, wrap_ext, read_mode, head, notif, new_idx_vsn, reopen, block, unblock, open, close, error, chunk, truncate, many_users, info, change_size, - change_attribute, distribution, evil, otp_6278, otp_10131]). + change_attribute, distribution, otp_6278, otp_10131]). %% These test cases should be skipped if the VxWorks card is %% configured without NFS cache. @@ -149,7 +147,7 @@ all() -> {group, open}, {group, close}, {group, error}, chunk, truncate, many_users, {group, info}, {group, change_size}, change_attribute, - {group, distribution}, evil, otp_6278, otp_10131]. + {group, distribution}, otp_6278, otp_10131]. groups() -> [{halt_int, [], [halt_int_inf, {group, halt_int_sz}]}, @@ -4676,119 +4674,6 @@ other_groups(Conf) when is_list(Conf) -> ok. --define(MAX, ?MAX_FWRITE_CACHE). % as in disk_log_1.erl -%% Evil cases such as closed file descriptor port. -evil(Conf) when is_list(Conf) -> - Dir = ?privdir(Conf), - File = filename:join(Dir, "n.LOG"), - Log = n, - - %% Not a very thorough test. - - ok = setup_evil_filled_cache_wrap(Log, Dir), - {error, {file_error,_,einval}} = disk_log:log(Log, apa), - ok = disk_log:close(Log), - - ok = setup_evil_filled_cache_halt(Log, Dir), - {error, {file_error,_,einval}} = disk_log:truncate(Log, apa), - ok = stop_evil(Log), - - %% White box test. - file:delete(File), - Ports0 = erlang:ports(), - {ok, Log} = disk_log:open([{name,Log},{file,File},{type,halt}, - {size,?MAX+50},{format,external}]), - [Fd] = erlang:ports() -- Ports0, - {B,_} = x_mk_bytes(30), - ok = disk_log:blog(Log, <<0:(?MAX-1)/unit:8>>), - exit(Fd, kill), - {error, {file_error,_,einval}} = disk_log:blog_terms(Log, [B,B]), - ok= disk_log:close(Log), - file:delete(File), - - ok = setup_evil_wrap(Log, Dir), - {error, {file_error,_,einval}} = disk_log:close(Log), - - ok = setup_evil_wrap(Log, Dir), - {error, {file_error,_,einval}} = disk_log:log(Log, apa), - ok = stop_evil(Log), - - ok = setup_evil_halt(Log, Dir), - {error, {file_error,_,einval}} = disk_log:log(Log, apa), - ok = stop_evil(Log), - - ok = setup_evil_wrap(Log, Dir), - {error, {file_error,_,einval}} = disk_log:reopen(Log, apa), - {error, {file_error,_,einval}} = disk_log:reopen(Log, apa), - ok = stop_evil(Log), - - ok = setup_evil_wrap(Log, Dir), - {error, {file_error,_,einval}} = disk_log:reopen(Log, apa), - ok = stop_evil(Log), - - ok = setup_evil_wrap(Log, Dir), - {error, {file_error,_,einval}} = disk_log:inc_wrap_file(Log), - ok = stop_evil(Log), - - ok = setup_evil_wrap(Log, Dir), - {error, {file_error,_,einval}} = disk_log:chunk(Log, start), - ok = stop_evil(Log), - - ok = setup_evil_wrap(Log, Dir), - {error, {file_error,_,einval}} = disk_log:truncate(Log), - ok = stop_evil(Log), - - ok = setup_evil_wrap(Log, Dir), - {error, {file_error,_,einval}} = disk_log:chunk_step(Log, start, 1), - ok = stop_evil(Log), - - io:format("messages: ~p~n", [erlang:process_info(self(), messages)]), - del(File, 2), - file:delete(File), - ok. - -setup_evil_wrap(Log, Dir) -> - setup_evil(Log, [{type,wrap},{size,{100,2}}], Dir). - -setup_evil_halt(Log, Dir) -> - setup_evil(Log, [{type,halt},{size,10000}], Dir). - -setup_evil(Log, Args, Dir) -> - File = filename:join(Dir, lists:concat([Log, ".LOG"])), - file:delete(File), - del(File, 2), - ok = disk_log:start(), - Ports0 = erlang:ports(), - {ok, Log} = disk_log:open([{name,Log},{file,File} | Args]), - [Fd] = erlang:ports() -- Ports0, - exit(Fd, kill), - ok = disk_log:log_terms(n, [<<0:10/unit:8>>]), - timer:sleep(2500), % TIMEOUT in disk_log_1.erl is 2000 - ok. - -stop_evil(Log) -> - {error, _} = disk_log:close(Log), - ok. - -setup_evil_filled_cache_wrap(Log, Dir) -> - setup_evil_filled_cache(Log, [{type,wrap},{size,{?MAX,2}}], Dir). - -setup_evil_filled_cache_halt(Log, Dir) -> - setup_evil_filled_cache(Log, [{type,halt},{size,infinity}], Dir). - -%% The cache is filled, and the file descriptor port gone. -setup_evil_filled_cache(Log, Args, Dir) -> - File = filename:join(Dir, lists:concat([Log, ".LOG"])), - file:delete(File), - del(File, 2), - ok = disk_log:start(), - Ports0 = erlang:ports(), - {ok, Log} = disk_log:open([{name,Log},{file,File} | Args]), - [Fd] = erlang:ports() -- Ports0, - ok = disk_log:log_terms(n, [<<0:?MAX/unit:8>>]), - exit(Fd, kill), - ok. - %% OTP-6278. open/1 creates no status or crash report. otp_6278(Conf) when is_list(Conf) -> Dir = ?privdir(Conf), diff --git a/lib/kernel/test/erl_distribution_SUITE.erl b/lib/kernel/test/erl_distribution_SUITE.erl index e34b4d77d2..0470f09f29 100644 --- a/lib/kernel/test/erl_distribution_SUITE.erl +++ b/lib/kernel/test/erl_distribution_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1997-2017. All Rights Reserved. +%% Copyright Ericsson AB 1997-2018. 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. @@ -463,9 +463,9 @@ run_remote_test([FuncStr, TestNodeStr | Args]) -> 1 end catch - C:E -> + C:E:S -> io:format("Node ~p got EXCEPTION ~p:~p\nat ~p\n", - [node(), C, E, erlang:get_stacktrace()]), + [node(), C, E, S]), 2 end, io:format("Node ~p doing halt(~p).\n",[node(), Status]), @@ -1144,17 +1144,16 @@ monitor_nodes_otp_6481_test(Config, TestType) when is_list(Config) -> TestMonNodeState = monitor_node_state(), %% io:format("~p~n", [TestMonNodeState]), TestMonNodeState = - MonNodeState + case TestType of + nodedown -> []; + nodeup -> [{self(), []}] + end + ++ lists:map(fun (_) -> {MN, []} end, Seq) ++ case TestType of nodedown -> [{self(), []}]; nodeup -> [] end - ++ lists:map(fun (_) -> {MN, []} end, Seq) - ++ case TestType of - nodedown -> []; - nodeup -> [{self(), []}] - end, - + ++ MonNodeState, {ok, Node} = start_node(Name, "", this), receive {nodeup, Node} -> ok end, diff --git a/lib/kernel/test/erl_distribution_wb_SUITE.erl b/lib/kernel/test/erl_distribution_wb_SUITE.erl index 03aaee56b7..8256444bdc 100644 --- a/lib/kernel/test/erl_distribution_wb_SUITE.erl +++ b/lib/kernel/test/erl_distribution_wb_SUITE.erl @@ -61,10 +61,13 @@ %% From R9 and forward extended references is compulsory %% From R10 and forward extended pids and ports are compulsory %% From R20 and forward UTF8 atoms are compulsory +%% From R21 and forward NEW_FUN_TAGS is compulsory (no more tuple fallback {fun, ...}) -define(COMPULSORY_DFLAGS, (?DFLAG_EXTENDED_REFERENCES bor ?DFLAG_EXTENDED_PIDS_PORTS bor - ?DFLAG_UTF8_ATOMS)). + ?DFLAG_UTF8_ATOMS bor + ?DFLAG_NEW_FUN_TAGS)). +-define(PASS_THROUGH, $p). -define(shutdown(X), exit(X)). -define(int16(X), [((X) bsr 8) band 16#ff, (X) band 16#ff]). @@ -674,15 +677,16 @@ build_rex_message(Cookie,OurName) -> %% Receive a distribution message recv_message(Socket) -> case gen_tcp:recv(Socket, 0) of + {ok,[]} -> + recv_message(Socket); %% a tick, ignore {ok,Data} -> B0 = list_to_binary(Data), - {_,B1} = erlang:split_binary(B0,1), - Header = binary_to_term(B1), - Siz = byte_size(term_to_binary(Header)), - {_,B2} = erlang:split_binary(B1,Siz), + <<?PASS_THROUGH, B1/binary>> = B0, + {Header,Siz} = binary_to_term(B1,[used]), + <<_:Siz/binary,B2/binary>> = B1, Message = case (catch binary_to_term(B2)) of {'EXIT', _} -> - could_not_digest_message; + {could_not_digest_message,B2}; Other -> Other end, diff --git a/lib/kernel/test/erl_prim_loader_SUITE.erl b/lib/kernel/test/erl_prim_loader_SUITE.erl index b6417210b9..3502a4ad08 100644 --- a/lib/kernel/test/erl_prim_loader_SUITE.erl +++ b/lib/kernel/test/erl_prim_loader_SUITE.erl @@ -33,6 +33,7 @@ primary_archive/1, virtual_dir_in_archive/1, get_modules/1]). +-define(PRIM_FILE, prim_file). %%----------------------------------------------------------------- %% Test suite for erl_prim_loader. (Most code is run during system start/stop.) @@ -461,7 +462,7 @@ primary_archive(Config) when is_list(Config) -> %% Set primary archive ExpectedEbins = [Archive, DictDir ++ "/ebin", DummyDir ++ "/ebin"], io:format("ExpectedEbins: ~p\n", [ExpectedEbins]), - {ok, FileInfo} = prim_file:read_file_info(Archive), + {ok, FileInfo} = ?PRIM_FILE:read_file_info(Archive), {ok, Ebins} = rpc:call(Node, erl_prim_loader, set_primary_archive, [Archive, ArchiveBin, FileInfo, fun escript:parse_file/1]), diff --git a/lib/kernel/test/file_SUITE.erl b/lib/kernel/test/file_SUITE.erl index 119e1f24bb..ff93f25e25 100644 --- a/lib/kernel/test/file_SUITE.erl +++ b/lib/kernel/test/file_SUITE.erl @@ -39,6 +39,8 @@ -define(FILE_FIN_PER_TESTCASE(Config), Config). -endif. +-define(PRIM_FILE, prim_file). + -module(?FILE_SUITE). -export([all/0, suite/0,groups/0,init_per_suite/1, end_per_suite/1, @@ -54,7 +56,8 @@ open1/1, old_modes/1, new_modes/1, path_open/1, open_errors/1]). -export([ file_info_basic_file/1, file_info_basic_directory/1, - file_info_bad/1, file_info_times/1, file_write_file_info/1]). + file_info_bad/1, file_info_times/1, file_write_file_info/1, + file_wfi_helpers/1]). -export([rename/1, access/1, truncate/1, datasync/1, sync/1, read_write/1, pread_write/1, append/1, exclusive/1]). -export([ e_delete/1, e_rename/1, e_make_dir/1, e_del_dir/1]). @@ -97,6 +100,12 @@ -export([unicode_mode/1]). +-export([volume_relative_paths/1]). + +-export([tiny_writes/1, tiny_writes_delayed/1, + large_writes/1, large_writes_delayed/1, + tiny_reads/1, tiny_reads_ahead/1]). + %% Debug exports -export([create_file_slow/2, create_file/2, create_bin/2]). -export([verify_file/2, verify_bin/3]). @@ -107,6 +116,8 @@ -export([disc_free/1, memsize/0]). -include_lib("common_test/include/ct.hrl"). +-include_lib("common_test/include/ct_event.hrl"). + -include_lib("kernel/include/file.hrl"). -define(THROW_ERROR(RES), throw({fail, ?LINE, RES})). @@ -118,13 +129,13 @@ suite() -> all() -> [unicode, altname, read_write_file, {group, dirs}, - {group, files}, delete, rename, names, {group, errors}, - {group, compression}, {group, links}, copy, + {group, files}, delete, rename, names, volume_relative_paths, + {group, errors}, {group, compression}, {group, links}, copy, delayed_write, read_ahead, segment_read, segment_write, ipread, pid2name, interleaved_read_write, otp_5814, otp_10852, large_file, large_write, read_line_1, read_line_2, read_line_3, read_line_4, standard_io, old_io_protocol, - unicode_mode + unicode_mode, {group, bench} ]. groups() -> @@ -142,7 +153,8 @@ groups() -> {pos, [], [pos1, pos2, pos3]}, {file_info, [], [file_info_basic_file, file_info_basic_directory, - file_info_bad, file_info_times, file_write_file_info]}, + file_info_bad, file_info_times, file_write_file_info, + file_wfi_helpers]}, {consult, [], [consult1, path_consult]}, {eval, [], [eval1, path_eval]}, {script, [], [script1, path_script]}, @@ -154,11 +166,19 @@ groups() -> write_compressed, compress_errors, catenated_gzips, compress_async_crash]}, {links, [], - [make_link, read_link_info_for_non_link, symlinks]}]. + [make_link, read_link_info_for_non_link, symlinks]}, + {bench, [], + [tiny_writes, tiny_writes_delayed, + large_writes, large_writes_delayed, + tiny_reads, tiny_reads_ahead]}]. init_per_group(_GroupName, Config) -> Config. +end_per_group(bench, Config) -> + ScratchDir = proplists:get_value(priv_dir, Config), + file:delete(filename:join(ScratchDir, "benchmark_scratch_file")), + Config; end_per_group(_GroupName, Config) -> Config. @@ -381,11 +401,11 @@ read_write_0(Str, {Func, ReadFun}, Options) -> io:format("~p:~p: ~p ERROR: ~ts vs~n ~w~n - ~p~n", [?MODULE, Line, Func, Str, ReadBytes, Options]), exit({error, ?LINE}); - error:What -> + error:What:Stacktrace -> io:format("~p:??: ~p ERROR: ~p from~n ~w~n ~p~n", [?MODULE, Func, What, Str, Options]), - io:format("\t~p~n", [erlang:get_stacktrace()]), + io:format("\t~p~n", [Stacktrace]), exit({error, ?LINE}) end. @@ -473,7 +493,7 @@ um_check_unicode(_Utf8Bin, {ok, _ListOrBin}, _, _UTF8_) -> um_filename(Bin, Dir, Options) when is_binary(Bin) -> um_filename(binary_to_list(Bin), Dir, Options); um_filename(Str = [_|_], Dir, Options) -> - Name = hd(string:tokens(Str, ":")), + Name = hd(string:lexemes(Str, ":")), Enc = atom_to_list(proplists:get_value(encoding, Options, latin1)), File = case lists:member(binary, Options) of true -> @@ -638,6 +658,10 @@ cur_dir_0(Config) when is_list(Config) -> {ok,NewDirFiles} = ?FILE_MODULE:list_dir("."), true = lists:member(UncommonName,NewDirFiles), + %% Ensure that we get the same result with a trailing slash; the + %% APIs used on Windows will choke on them if passed directly. + {ok,NewDirFiles} = ?FILE_MODULE:list_dir("./"), + %% Delete the directory and return to the old current directory %% and check that the created file isn't there (too!) expect({error, einval}, {error, eacces}, @@ -690,10 +714,15 @@ win_cur_dir_1(_Config) -> %% Get the drive letter from the current directory, %% and try to get current directory for that drive. - [Drive,$:|_] = BaseDir, - {ok,BaseDir} = ?FILE_MODULE:get_cwd([Drive,$:]), + [CurDrive,$:|_] = BaseDir, + {ok,BaseDir} = ?FILE_MODULE:get_cwd([CurDrive,$:]), io:format("BaseDir = ~s\n", [BaseDir]), + %% We should error out on non-existent drives. Any reasonable system will + %% have at least one. + CurDirs = [?FILE_MODULE:get_cwd([Drive,$:]) || Drive <- lists:seq($A, $Z)], + lists:member({error,eaccess}, CurDirs), + %% Unfortunately, there is no way to move away from the %% current drive as we can't use the "subst" command from %% a SSH connection. We can't test any more. @@ -831,7 +860,7 @@ no_untranslatable_names() -> end. start_node(Name, Args) -> - [_,Host] = string:tokens(atom_to_list(node()), "@"), + [_,Host] = string:lexemes(atom_to_list(node()), "@"), ct:log("Trying to start ~w@~s~n", [Name,Host]), case test_server:start_node(Name, peer, [{args,Args}]) of {error,Reason} -> @@ -1019,6 +1048,23 @@ close(Config) when is_list(Config) -> Val = ?FILE_MODULE:close(Fd1), io:format("Second close gave: ~p",[Val]), + %% All operations on a closed raw file should EINVAL, even if they're not + %% supported on the current platform. + {ok,Fd2} = ?FILE_MODULE:open(Name, [read, write, raw]), + ok = ?FILE_MODULE:close(Fd2), + + {error, einval} = ?FILE_MODULE:advise(Fd2, 5, 5, normal), + {error, einval} = ?FILE_MODULE:allocate(Fd2, 5, 5), + {error, einval} = ?FILE_MODULE:close(Fd2), + {error, einval} = ?FILE_MODULE:datasync(Fd2), + {error, einval} = ?FILE_MODULE:position(Fd2, 5), + {error, einval} = ?FILE_MODULE:pread(Fd2, 5, 1), + {error, einval} = ?FILE_MODULE:pwrite(Fd2, 5, "einval please"), + {error, einval} = ?FILE_MODULE:read(Fd2, 1), + {error, einval} = ?FILE_MODULE:sync(Fd2), + {error, einval} = ?FILE_MODULE:truncate(Fd2), + {error, einval} = ?FILE_MODULE:write(Fd2, "einval please"), + [] = flush(), ok. @@ -1132,8 +1178,8 @@ pread_write_test(File, Data) -> end, I = Size + 17, ok = ?FILE_MODULE:pwrite(File, 0, Data), - Res = ?FILE_MODULE:pread(File, 0, I), - {ok, Data} = Res, + {ok, Data} = ?FILE_MODULE:pread(File, 0, I), + {ok, [Data]} = ?FILE_MODULE:pread(File, [{0, I}]), eof = ?FILE_MODULE:pread(File, I, 1), ok = ?FILE_MODULE:pwrite(File, [{0, Data}, {I, Data}]), {ok, [Data, eof, Data]} = @@ -1564,6 +1610,39 @@ file_write_file_info(Config) when is_list(Config) -> [] = flush(), ok. +file_wfi_helpers(Config) when is_list(Config) -> + RootDir = get_good_directory(Config), + io:format("RootDir = ~p", [RootDir]), + + Name = filename:join(RootDir, + atom_to_list(?MODULE) ++ "_wfi_helpers"), + + ok = ?FILE_MODULE:write_file(Name, "hello again"), + NewTime = {{1997, 02, 15}, {13, 18, 20}}, + ok = ?FILE_MODULE:change_time(Name, NewTime, NewTime), + + {ok, #file_info{atime=NewActAtime, mtime=NewTime}} = + ?FILE_MODULE:read_file_info(Name), + + NewFilteredAtime = filter_atime(NewTime, Config), + NewFilteredAtime = filter_atime(NewActAtime, Config), + + %% Make the file unwritable + ok = ?FILE_MODULE:change_mode(Name, 8#400), + {error, eacces} = ?FILE_MODULE:write_file(Name, "hello again"), + + %% ... and writable again + ok = ?FILE_MODULE:change_mode(Name, 8#600), + ok = ?FILE_MODULE:write_file(Name, "hello again"), + + %% We have no idea which users will work, so all we can do is to check + %% that it returns enoent instead of crashing. + {error, enoent} = ?FILE_MODULE:change_group("bogus file name", 0), + {error, enoent} = ?FILE_MODULE:change_owner("bogus file name", 0), + + [] = flush(), + ok. + %% Returns a directory on a file system that has correct file times. get_good_directory(Config) -> @@ -2044,13 +2123,22 @@ names(Config) when is_list(Config) -> ok = ?FILE_MODULE:close(Fd2), {ok,Fd3} = ?FILE_MODULE:open(Name3,read), ok = ?FILE_MODULE:close(Fd3), + + %% Now try the same on raw files. + {ok,Fd4} = ?FILE_MODULE:open(Name2, [read, raw]), + ok = ?FILE_MODULE:close(Fd4), + {ok,Fd4f} = ?FILE_MODULE:open(lists:flatten(Name2), [read, raw]), + ok = ?FILE_MODULE:close(Fd4f), + {ok,Fd5} = ?FILE_MODULE:open(Name3, [read, raw]), + ok = ?FILE_MODULE:close(Fd5), + case length(Name1) > 255 of true -> io:format("Path too long for an atom:\n\n~p\n", [Name1]); false -> Name4 = list_to_atom(Name1), - {ok,Fd4} = ?FILE_MODULE:open(Name4,read), - ok = ?FILE_MODULE:close(Fd4) + {ok,Fd6} = ?FILE_MODULE:open(Name4,read), + ok = ?FILE_MODULE:close(Fd6) end, %% Try some path names @@ -2074,6 +2162,22 @@ names(Config) when is_list(Config) -> [] = flush(), ok. +volume_relative_paths(Config) when is_list(Config) -> + case os:type() of + {win32, _} -> + {ok, [Drive, $: | _]} = file:get_cwd(), + %% Relative to current device root. + {ok, RootInfo} = file:read_file_info([Drive, $:, $/]), + {ok, RootInfo} = file:read_file_info("/"), + %% Relative to current device directory. + {ok, DirContents} = file:list_dir([Drive, $:]), + {ok, DirContents} = file:list_dir("."), + [] = flush(), + ok; + _ -> + {skip, "This test is Windows-specific."} + end. + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -2108,7 +2212,7 @@ e_delete(Config) when is_list(Config) -> Base, #file_info {mode=0}), {error, eacces} = ?FILE_MODULE:delete(Afile), ?FILE_MODULE:write_file_info( - Base, #file_info {mode=8#600}) + Base, #file_info {mode=8#700}) end, [] = flush(), @@ -2239,7 +2343,7 @@ e_make_dir(Config) when is_list(Config) -> ?FILE_MODULE:write_file_info(Base, #file_info {mode=0}), {error, eacces} = ?FILE_MODULE:make_dir(filename:join(Base, "xxxx")), ?FILE_MODULE:write_file_info( - Base, #file_info {mode=8#600}) + Base, #file_info {mode=8#700}) end, ok. @@ -2285,7 +2389,7 @@ e_del_dir(Config) when is_list(Config) -> ok = ?FILE_MODULE:make_dir(ADirectory), ?FILE_MODULE:write_file_info( Base, #file_info {mode=0}), {error, eacces} = ?FILE_MODULE:del_dir(ADirectory), - ?FILE_MODULE:write_file_info( Base, #file_info {mode=8#600}) + ?FILE_MODULE:write_file_info( Base, #file_info {mode=8#700}) end, [] = flush(), ok. @@ -2641,8 +2745,8 @@ altname(Config) when is_list(Config) -> {skipped, "Altname not supported on this platform"}; {ok, "LONGAL~1"} -> {ok, "A_FILE~1"} = ?FILE_MODULE:altname(Name), - {ok, "C:/"} = ?FILE_MODULE:altname("C:/"), - {ok, "C:\\"} = ?FILE_MODULE:altname("C:\\"), + {ok, "c:/"} = ?FILE_MODULE:altname("C:/"), + {ok, "c:/"} = ?FILE_MODULE:altname("C:\\"), {error,enoent} = ?FILE_MODULE:altname(NonexName), {ok, "short"} = ?FILE_MODULE:altname(ShortName), ok @@ -2923,20 +3027,22 @@ delayed_write(Config) when is_list(Config) -> %% %% Test caching and normal close of non-raw file {ok, Fd1} = - ?FILE_MODULE:open(File, [write, {delayed_write, Size+1, 2000}]), + ?FILE_MODULE:open(File, [write, {delayed_write, Size+1, 400}]), ok = ?FILE_MODULE:write(Fd1, Data1), - timer:sleep(1000), % Just in case the file system is slow + %% Wait for a reasonable amount of time to check whether the write was + %% practically instantaneous or actually delayed. + timer:sleep(100), {ok, Fd2} = ?FILE_MODULE:open(File, [read]), eof = ?FILE_MODULE:read(Fd2, 1), ok = ?FILE_MODULE:write(Fd1, Data1), % Data flush on size - timer:sleep(1000), % Just in case the file system is slow + timer:sleep(100), {ok, Data1Data1} = ?FILE_MODULE:pread(Fd2, bof, 2*Size+1), ok = ?FILE_MODULE:write(Fd1, Data1), - timer:sleep(3000), % Wait until data flush on timeout + timer:sleep(500), % Wait until data flush on timeout {ok, Data1Data1Data1} = ?FILE_MODULE:pread(Fd2, bof, 3*Size+1), ok = ?FILE_MODULE:write(Fd1, Data1), ok = ?FILE_MODULE:close(Fd1), % Data flush on close - timer:sleep(1000), % Just in case the file system is slow + timer:sleep(100), {ok, Data1Data1Data1Data1} = ?FILE_MODULE:pread(Fd2, bof, 4*Size+1), ok = ?FILE_MODULE:close(Fd2), %% @@ -2970,7 +3076,7 @@ delayed_write(Config) when is_list(Config) -> {'DOWN', Mref1, _, _, _} = Down1a -> ct:fail(Down1a) end, - timer:sleep(1000), % Just in case the file system is slow + timer:sleep(100), % Just in case the file system is slow {ok, Fd3} = ?FILE_MODULE:open(File, [read]), eof = ?FILE_MODULE:read(Fd3, 1), Child1 ! {Parent, continue, normal}, @@ -2980,7 +3086,7 @@ delayed_write(Config) when is_list(Config) -> {'DOWN', Mref1, _, _, _} = Down1b -> ct:fail(Down1b) end, - timer:sleep(1000), % Just in case the file system is slow + timer:sleep(100), % Just in case the file system is slow {ok, Data1} = ?FILE_MODULE:pread(Fd3, bof, Size+1), ok = ?FILE_MODULE:close(Fd3), %% @@ -2993,7 +3099,7 @@ delayed_write(Config) when is_list(Config) -> {'DOWN', Mref2, _, _, _} = Down2a -> ct:fail(Down2a) end, - timer:sleep(1000), % Just in case the file system is slow + timer:sleep(100), % Just in case the file system is slow {ok, Fd4} = ?FILE_MODULE:open(File, [read]), eof = ?FILE_MODULE:read(Fd4, 1), Child2 ! {Parent, continue, kill}, @@ -3003,7 +3109,7 @@ delayed_write(Config) when is_list(Config) -> {'DOWN', Mref2, _, _, _} = Down2b -> ct:fail(Down2b) end, - timer:sleep(1000), % Just in case the file system is slow + timer:sleep(100), % Just in case the file system is slow eof = ?FILE_MODULE:pread(Fd4, bof, 1), ok = ?FILE_MODULE:close(Fd4), %% @@ -3095,6 +3201,16 @@ read_ahead(Config) when is_list(Config) -> Data1Data2Data3 = Data1++Data2++Data3, {ok, Data1Data2Data3} = ?FILE_MODULE:read(Fd5, 3*Size+1), ok = ?FILE_MODULE:close(Fd5), + + %% Ensure that a read that draws from both the buffer and the file won't + %% return anything wonky. + SplitData = << <<(I rem 256)>> || I <- lists:seq(1, 1024) >>, + file:write_file(File, SplitData), + {ok, Fd6} = ?FILE_MODULE:open(File, [raw, read, binary, {read_ahead, 256}]), + {ok, <<1>>} = file:read(Fd6, 1), + <<1, Shifted:512/binary, _Rest/binary>> = SplitData, + {ok, Shifted} = file:read(Fd6, 512), + %% [] = flush(), ok. @@ -3699,6 +3815,83 @@ do_large_write(Name) -> %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Benchmarks +%% +%% Note that we only measure the time it takes to run the isolated file +%% operations and that the actual test runtime can differ significantly, +%% especially on the write side as the files need to be truncated before +%% writing. + +large_writes(Config) when is_list(Config) -> + Modes = [raw, binary], + OpCount = 4096, + Data = <<0:(64 bsl 10)/unit:8>>, + run_write_benchmark(Config, Modes, OpCount, Data). + +large_writes_delayed(Config) when is_list(Config) -> + %% Each write is exactly as large as the delay buffer, causing the writes + %% to pass through each time, giving us a decent idea of how much overhead + %% delayed_write adds. + Modes = [raw, binary, {delayed_write, 64 bsl 10, 2000}], + OpCount = 4096, + Data = <<0:(64 bsl 10)/unit:8>>, + run_write_benchmark(Config, Modes, OpCount, Data). + +tiny_writes(Config) when is_list(Config) -> + Modes = [raw, binary], + OpCount = 512 bsl 10, + Data = <<0>>, + run_write_benchmark(Config, Modes, OpCount, Data). + +tiny_writes_delayed(Config) when is_list(Config) -> + Modes = [raw, binary, {delayed_write, 512 bsl 10, 2000}], + OpCount = 512 bsl 10, + Data = <<0>>, + run_write_benchmark(Config, Modes, OpCount, Data). + +%% The read benchmarks assume that "benchmark_scratch_file" has been filled by +%% the write benchmarks. + +tiny_reads(Config) when is_list(Config) -> + Modes = [raw, binary], + OpCount = 512 bsl 10, + run_read_benchmark(Config, Modes, OpCount, 1). + +tiny_reads_ahead(Config) when is_list(Config) -> + Modes = [raw, binary, {read_ahead, 512 bsl 10}], + OpCount = 512 bsl 10, + run_read_benchmark(Config, Modes, OpCount, 1). + +run_write_benchmark(Config, Modes, OpCount, Data) -> + run_benchmark(Config, [write | Modes], OpCount, fun file:write/2, Data). + +run_read_benchmark(Config, Modes, OpCount, OpSize) -> + run_benchmark(Config, [read | Modes], OpCount, fun file:read/2, OpSize). + +run_benchmark(Config, Modes, OpCount, Fun, Arg) -> + ScratchDir = proplists:get_value(priv_dir, Config), + Path = filename:join(ScratchDir, "benchmark_scratch_file"), + {ok, Fd} = file:open(Path, Modes), + submit_throughput_results(Fun, [Fd, Arg], OpCount). + +submit_throughput_results(Fun, Args, Times) -> + MSecs = measure_repeated_file_op(Fun, Args, Times, millisecond), + IOPS = trunc(Times * (1000 / MSecs)), + ct_event:notify(#event{ name = benchmark_data, data = [{value,IOPS}] }), + {comment, io_lib:format("~p IOPS, ~p ms", [IOPS, trunc(MSecs)])}. + +measure_repeated_file_op(Fun, Args, Times, Unit) -> + Start = os:perf_counter(Unit), + repeated_apply(Fun, Args, Times), + os:perf_counter(Unit) - Start. + +repeated_apply(_F, _Args, Times) when Times =< 0 -> + ok; +repeated_apply(F, Args, Times) -> + erlang:apply(F, Args), + repeated_apply(F, Args, Times - 1). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% response_analysis(Module, Function, Arguments) -> @@ -3934,7 +4127,7 @@ read_line_create_files(TestData) -> read_line_remove_files(TestData) -> [ file:delete(File) || {_Function,File,_,_} <- TestData ]. -%% read_line with prim_file. +%% read_line with ?PRIM_FILE. read_line_1(Config) when is_list(Config) -> PrivDir = proplists:get_value(priv_dir, Config), All = read_line_testdata(PrivDir), @@ -4103,9 +4296,9 @@ read_line_create7(Filename) -> file:close(F). read_line_all(Filename) -> - {ok,F} = prim_file:open(Filename,[read,binary]), + {ok,F} = ?PRIM_FILE:open(Filename,[read,binary]), X=read_rl_lines(F), - prim_file:close(F), + ?PRIM_FILE:close(F), Bin = list_to_binary([B || {ok,B} <- X]), Bin = re:replace(list_to_binary([element(2,file:read_file(Filename))]), "\r\n","\n",[global,{return,binary}]), @@ -4138,7 +4331,7 @@ read_line_all4(Filename) -> {length(X),Bin}. read_rl_lines(F) -> - case prim_file:read_line(F) of + case ?PRIM_FILE:read_line(F) of eof -> []; {error,X} -> @@ -4158,9 +4351,9 @@ read_rl_lines2(F) -> end. read_line_all_alternating(Filename) -> - {ok,F} = prim_file:open(Filename,[read,binary]), + {ok,F} = ?PRIM_FILE:open(Filename,[read,binary]), X=read_rl_lines(F,true), - prim_file:close(F), + ?PRIM_FILE:close(F), Bin = list_to_binary([B || {ok,B} <- X]), Bin = re:replace(list_to_binary([element(2,file:read_file(Filename))]), "\r\n","\n",[global,{return,binary}]), @@ -4194,8 +4387,8 @@ read_line_all_alternating4(Filename) -> read_rl_lines(F,Alternate) -> case begin case Alternate of - true -> prim_file:read(F,1); - false -> prim_file:read_line(F) + true -> ?PRIM_FILE:read(F,1); + false -> ?PRIM_FILE:read_line(F) end end of eof -> diff --git a/lib/kernel/test/file_name_SUITE.erl b/lib/kernel/test/file_name_SUITE.erl index 899102c908..3afc647081 100644 --- a/lib/kernel/test/file_name_SUITE.erl +++ b/lib/kernel/test/file_name_SUITE.erl @@ -77,6 +77,7 @@ init_per_testcase/2, end_per_testcase/2]). -export([normal/1,icky/1,very_icky/1,normalize/1,home_dir/1]). +-define(PRIM_FILE, prim_file). init_per_testcase(_Func, Config) -> Config. @@ -131,7 +132,7 @@ home_dir(Config) when is_list(Config) -> os:putenv("HOME",NewHome), {"HOME",Save}; _ -> - rm_rf(prim_file,NewHome), + rm_rf(?PRIM_FILE,NewHome), throw(unsupported_os) end, try @@ -145,7 +146,7 @@ home_dir(Config) when is_list(Config) -> _ -> os:putenv(SaveOldName,SaveOldValue) end, - rm_rf(prim_file,NewHome) + rm_rf(?PRIM_FILE,NewHome) end catch throw:need_unicode_mode -> @@ -190,7 +191,7 @@ normal(Config) when is_list(Config) -> try Priv = proplists:get_value(priv_dir, Config), file:set_cwd(Priv), - ok = check_normal(prim_file), + ok = check_normal(?PRIM_FILE), ok = check_normal(file), %% If all is good, delete dir again (avoid hanging dir on windows) rm_rf(file,"normal_dir"), @@ -210,7 +211,7 @@ icky(Config) when is_list(Config) -> try Priv = proplists:get_value(priv_dir, Config), file:set_cwd(Priv), - ok = check_icky(prim_file), + ok = check_icky(?PRIM_FILE), ok = check_icky(file), %% If all is good, delete dir again (avoid hanging dir on windows) rm_rf(file,"icky_dir"), @@ -229,7 +230,7 @@ very_icky(Config) when is_list(Config) -> try Priv = proplists:get_value(priv_dir, Config), file:set_cwd(Priv), - case check_very_icky(prim_file) of + case check_very_icky(?PRIM_FILE) of need_unicode_mode -> {skipped,"VM needs to be started in Unicode filename mode"}; ok -> @@ -292,17 +293,14 @@ check_normal(Mod) -> ok end, [ begin - {ok, FD} = Mod:open(Name,[read]), - {ok, Content} = Mod:read(FD,1024), - ok = file:close(FD) - end || {regular,Name,Content} <- NormalDir ], - [ begin {ok, FD} = Mod:open(Name,[read,binary]), BC = list_to_binary(Content), {ok, BC} = Mod:read(FD,1024), ok = file:close(FD) end || {regular,Name,Content} <- NormalDir ], + {error, badarg} = Mod:rename("fil1\0tmp_fil2","tmp_fil1"), Mod:rename("fil1","tmp_fil1"), + {error, badarg} = Mod:read_file("tmp_fil1\0.txt"), {ok, <<"fil1">>} = Mod:read_file("tmp_fil1"), {error,enoent} = Mod:read_file("fil1"), Mod:rename("tmp_fil1","fil1"), @@ -410,11 +408,6 @@ check_icky(Mod) -> ok end, [ begin - {ok, FD} = Mod:open(Name,[read]), - {ok, Content} = Mod:read(FD,1024), - ok = file:close(FD) - end || {regular,Name,Content} <- IckyDir ], - [ begin {ok, FD} = Mod:open(Name,[read,binary]), BC = list_to_binary([Content]), {ok, BC} = Mod:read(FD,1024), @@ -519,11 +512,6 @@ check_very_icky(Mod) -> ok end, [ begin - {ok, FD} = Mod:open(Name,[read]), - {ok, Content} = Mod:read(FD,1024), - ok = file:close(FD) - end || {regular,Name,Content} <- VeryIckyDir ], - [ begin {ok, FD} = Mod:open(Name,[read,binary]), BC = list_to_binary([Content]), {ok, BC} = Mod:read(FD,1024), diff --git a/lib/kernel/test/gen_sctp_SUITE.erl b/lib/kernel/test/gen_sctp_SUITE.erl index 620ab235a0..9dde00652c 100644 --- a/lib/kernel/test/gen_sctp_SUITE.erl +++ b/lib/kernel/test/gen_sctp_SUITE.erl @@ -1038,8 +1038,7 @@ do_from_other_process(Fun) -> Result -> Parent ! {Ref,Result} catch - Class:Reason -> - Stacktrace = erlang:get_stacktrace(), + Class:Reason:Stacktrace -> Parent ! {Ref,Class,Reason,Stacktrace} end end), @@ -1617,8 +1616,7 @@ s_start(Socket, Timeout, Parent) -> try s_loop(Socket, Timeout, Parent, Handler, gb_trees:empty()) catch - Class:Reason -> - Stacktrace = erlang:get_stacktrace(), + Class:Reason:Stacktrace -> io:format(?MODULE_STRING":socket exception ~w:~w at~n" "~p.~n", [Class,Reason,Stacktrace]), erlang:raise(Class, Reason, Stacktrace) diff --git a/lib/kernel/test/gen_tcp_api_SUITE.erl b/lib/kernel/test/gen_tcp_api_SUITE.erl index 12d22519ce..0fe44e8a88 100644 --- a/lib/kernel/test/gen_tcp_api_SUITE.erl +++ b/lib/kernel/test/gen_tcp_api_SUITE.erl @@ -605,9 +605,9 @@ ok({ok,V}) -> V; ok(NotOk) -> try throw(not_ok) catch - Thrown -> + throw:Thrown:Stacktrace -> erlang:raise( - error, {Thrown, NotOk}, tl(erlang:get_stacktrace())) + error, {Thrown, NotOk}, tl(Stacktrace)) end. get_localaddr() -> diff --git a/lib/kernel/test/gen_tcp_misc_SUITE.erl b/lib/kernel/test/gen_tcp_misc_SUITE.erl index 331864b5de..e47023d201 100644 --- a/lib/kernel/test/gen_tcp_misc_SUITE.erl +++ b/lib/kernel/test/gen_tcp_misc_SUITE.erl @@ -1572,52 +1572,56 @@ fill_sendq(Config) when is_list(Config) -> Master = self(), Server = spawn_link(fun () -> - {ok,L} = gen_tcp:listen - (0, [{active,false},binary, - {reuseaddr,true},{packet,0}]), + {ok,L} = gen_tcp:listen(0, [{active,false},binary, + {reuseaddr,true},{packet,0}]), {ok,Port} = inet:port(L), Master ! {self(),client, fill_sendq_client(Port, Master)}, fill_sendq_srv(L, Master) end), io:format("~p Server~n", [Server]), - receive {Server,client,Client} -> - io:format("~p Client~n", [Client]), - receive {Server,reader,Reader} -> - io:format("~p Reader~n", [Reader]), - fill_sendq_loop(Server, Client, Reader) + receive + {Server,client,Client} -> + io:format("~p Client~n", [Client]), + receive + {Server,reader,Reader} -> + io:format("~p Reader~n", [Reader]), + fill_sendq_loop(Server, Client, Reader) end end. fill_sendq_loop(Server, Client, Reader) -> %% Master %% - receive {Server,send} -> + receive + {Server,send} -> fill_sendq_loop(Server, Client, Reader) after 2000 -> %% Send queue full, sender blocked -> close client. io:format("Send timeout, closing Client...~n", []), Client ! {self(),close}, - receive {Server,[{error,closed}]} -> - io:format("Got server closed.~n"), - receive {Reader,[{error,closed}]} -> - io:format - ("Got reader closed.~n"), - ok - after 3000 -> - ct:fail({timeout,{closed,reader}}) - end; - {Reader,[{error,closed}]} -> - io:format("Got reader closed.~n"), - receive {Server,[{error,closed}]} -> - io:format("Got server closed~n"), - ok - after 3000 -> - ct:fail({timeout,{closed,server}}) - end - after 3000 -> - ct:fail({timeout,{closed,[server,reader]}}) - end + receive + {Server,[{error,closed}]} -> + io:format("Got server closed.~n"), + receive + {Reader,[{error,closed}]} -> + io:format("Got reader closed.~n"), + ok + after 3000 -> + ct:fail({timeout,{closed,reader}}) + end; + {Reader,[{error,closed}]} -> + io:format("Got reader closed.~n"), + receive + {Server,[{error,closed}]} -> + io:format("Got server closed~n"), + ok + after 3000 -> + ct:fail({timeout,{closed,server}}) + end + after 3000 -> + ct:fail({timeout,{closed,[server,reader]}}) + end end. fill_sendq_srv(L, Master) -> diff --git a/lib/kernel/test/gen_udp_SUITE.erl b/lib/kernel/test/gen_udp_SUITE.erl index aa616d43d6..6a50239c2a 100644 --- a/lib/kernel/test/gen_udp_SUITE.erl +++ b/lib/kernel/test/gen_udp_SUITE.erl @@ -288,58 +288,56 @@ bad_address(Config) when is_list(Config) -> %% %% Starts a slave node that on command sends a bunch of messages %% to our UDP port. The receiving process just receives and -%% ignores the incoming messages, but counts them. -%% A tracing process traces the receiving process for -%% 'receive' and scheduling events. From the trace, -%% message contents is verified; and, how many messages -%% are received per in/out scheduling, which should be -%% the same as the read_packets parameter. -%% -%% What happens on the SMP emulator remains to be seen... -%% +%% ignores the incoming messages. +%% A tracing process traces the receiving port for +%% 'send' and scheduling events. From the trace, +%% how many messages are received per in/out scheduling, +%% which should never be more than the read_packet parameter. %% OTP-6249 UDP option for number of packet reads. read_packets(Config) when is_list(Config) -> - case erlang:system_info(smp_support) of - false -> - read_packets_1(); - true -> - %% We would need some new sort of tracing to test this - %% option reliably in an SMP emulator. - {skip,"SMP emulator"} - end. - -read_packets_1() -> N1 = 5, - N2 = 7, + N2 = 1, + Msgs = 30000, {ok,R} = gen_udp:open(0, [{read_packets,N1}]), {ok,RP} = inet:port(R), {ok,Node} = start_node(gen_udp_SUITE_read_packets), Die = make_ref(), - Loop = erlang:spawn_link(fun () -> infinite_loop(Die) end), %% - Msgs1 = [erlang:integer_to_list(M) || M <- lists:seq(1, N1*3)], - [V1|_] = read_packets_test(R, RP, Msgs1, Node), + {V1, Trace1} = read_packets_test(R, RP, Msgs, Node), {ok,[{read_packets,N1}]} = inet:getopts(R, [read_packets]), %% ok = inet:setopts(R, [{read_packets,N2}]), - Msgs2 = [erlang:integer_to_list(M) || M <- lists:seq(1, N2*3)], - [V2|_] = read_packets_test(R, RP, Msgs2, Node), + {V2, Trace2} = read_packets_test(R, RP, Msgs, Node), {ok,[{read_packets,N2}]} = inet:getopts(R, [read_packets]), %% stop_node(Node), - Mref = erlang:monitor(process, Loop), - Loop ! Die, - receive - {'DOWN',Mref,_,_, normal} -> - case {V1,V2} of - {N1,N2} -> - ok; - _ when V1 =/= N1, V2 =/= N2 -> - ok - end + ct:log("N1=~p, V1=~p vs N2=~p, V2=~p",[N1,V1,N2,V2]), + + dump_terms(Config, "trace1.terms", Trace2), + dump_terms(Config, "trace2.terms", Trace2), + + %% Because of the inherit racy-ness of the feature it is + %% hard to test that it behaves correctly. + %% Right now (OTP 21) a port task takes 5% of the + %% allotted port task reductions to execute, so + %% the max number of executions a port is allowed to + %% do before being re-scheduled is N * 20 + + if + V1 > (N1 * 20) -> + ct:fail("Got ~p msgs, max was ~p", [V1, N1]); + V2 > (N2 * 20) -> + ct:fail("Got ~p msgs, max was ~p", [V2, N2]); + true -> + ok end. +dump_terms(Config, Name, Terms) -> + FName = filename:join(proplists:get_value(priv_dir, Config),Name), + file:write_file(FName, term_to_binary(Terms)), + ct:log("Logged terms to ~s",[FName]). + infinite_loop(Die) -> receive Die -> @@ -350,7 +348,6 @@ infinite_loop(Die) -> end. read_packets_test(R, RP, Msgs, Node) -> - Len = length(Msgs), Receiver = self(), Tracer = spawn_link( @@ -375,24 +372,24 @@ read_packets_test(R, RP, Msgs, Node) -> [link,{priority,high}]), receive {Sender,{port,SP}} -> - erlang:trace(self(), true, - [running,'receive',{tracer,Tracer}]), + erlang:trace(R, true, + [running_ports,'send',{tracer,Tracer}]), erlang:yield(), Sender ! {Receiver,go}, - read_packets_recv(Len), - erlang:trace(self(), false, [all]), + read_packets_recv(Msgs), + erlang:trace(R, false, [all]), Tracer ! {Receiver,get_trace}, receive {Tracer,{trace,Trace}} -> - read_packets_verify(R, SP, Msgs, Trace) + {read_packets_verify(R, SP, Trace), Trace} end end. -read_packets_send(S, RP, [Msg|Msgs]) -> - ok = gen_udp:send(S, localhost, RP, Msg), - read_packets_send(S, RP, Msgs); -read_packets_send(_S, _RP, []) -> - ok. +read_packets_send(_S, _RP, 0) -> + ok; +read_packets_send(S, RP, Msgs) -> + ok = gen_udp:send(S, localhost, RP, "UDP FLOOOOOOD"), + read_packets_send(S, RP, Msgs - 1). read_packets_recv(0) -> ok; @@ -404,23 +401,24 @@ read_packets_recv(N) -> timeout end. -read_packets_verify(R, SP, Msg, Trace) -> - lists:reverse( - lists:sort(read_packets_verify(R, SP, Msg, Trace, 0))). - -read_packets_verify(R, SP, Msgs, [{trace,Self,OutIn,_}|Trace], M) - when Self =:= self(), OutIn =:= out; - Self =:= self(), OutIn =:= in -> - push(M, read_packets_verify(R, SP, Msgs, Trace, 0)); -read_packets_verify(R, SP, [Msg|Msgs], - [{trace,Self,'receive',{udp,R,{127,0,0,1},SP,Msg}} - |Trace], M) +read_packets_verify(R, SP, Trace) -> + [Max | _] = Pkts = lists:reverse(lists:sort(read_packets_verify(R, SP, Trace, 0))), + ct:pal("~p",[lists:sublist(Pkts,10)]), + Max. + +read_packets_verify(R, SP, [{trace,R,OutIn,_}|Trace], M) + when OutIn =:= out; OutIn =:= in -> + push(M, read_packets_verify(R, SP, Trace, 0)); +read_packets_verify(R, SP, [{trace, R,'receive',timeout}|Trace], M) -> + push(M, read_packets_verify(R, SP, Trace, 0)); +read_packets_verify(R, SP, + [{trace,R,'send',{udp,R,{127,0,0,1},SP,_Msg}, Self} | Trace], M) when Self =:= self() -> - read_packets_verify(R, SP, Msgs, Trace, M+1); -read_packets_verify(_R, _SP, [], [], M) -> + read_packets_verify(R, SP, Trace, M+1); +read_packets_verify(_R, _SP, [], M) -> push(M, []); -read_packets_verify(_R, _SP, Msgs, Trace, M) -> - ct:fail({read_packets_verify,mismatch,Msgs,Trace,M}). +read_packets_verify(_R, _SP, Trace, M) -> + ct:fail({read_packets_verify,mismatch,Trace,M}). push(0, Vs) -> Vs; @@ -757,9 +755,9 @@ ok({ok,V}) -> V; ok(NotOk) -> try throw(not_ok) catch - Thrown -> + throw:Thrown:Stacktrace -> erlang:raise( - error, {Thrown, NotOk}, tl(erlang:get_stacktrace())) + error, {Thrown, NotOk}, tl(Stacktrace)) end. diff --git a/lib/kernel/test/inet_SUITE.erl b/lib/kernel/test/inet_SUITE.erl index ba0d075ef2..2e5f8c7d2c 100644 --- a/lib/kernel/test/inet_SUITE.erl +++ b/lib/kernel/test/inet_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1997-2017. All Rights Reserved. +%% Copyright Ericsson AB 1997-2018. 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. @@ -40,7 +40,8 @@ lookup_bad_search_option/1, getif/1, getif_ifr_name_overflow/1,getservbyname_overflow/1, getifaddrs/1, - parse_strict_address/1, simple_netns/1, simple_netns_open/1, + parse_strict_address/1, ipv4_mapped_ipv6_address/1, + simple_netns/1, simple_netns_open/1, simple_bind_to_device/1, simple_bind_to_device_open/1]). -export([get_hosts/1, get_ipv6_hosts/1, parse_hosts/1, parse_address/1, @@ -667,6 +668,26 @@ parse_strict_address(Config) when is_list(Config) -> {ok, {3089,3106,23603,50240,0,0,119,136}} = inet:parse_strict_address("c11:0c22:5c33:c440::077:0088"). +ipv4_mapped_ipv6_address(Config) when is_list(Config) -> + {D1,D2,D3,D4} = IPv4Address = + {rand:uniform(256) - 1, + rand:uniform(256) - 1, + rand:uniform(256) - 1, + rand:uniform(256) - 1}, + E7 = (D1 bsl 8) bor D2, + E8 = (D3 bsl 8) bor D4, + io:format("IPv4Address: ~p.~n", [IPv4Address]), + {0,0,0,0,0,65535,E7,E8} = inet:ipv4_mapped_ipv6_address(IPv4Address), + IPv6Address = + {rand:uniform(65536) - 1, + rand:uniform(65536) - 1, + rand:uniform(65536) - 1, + rand:uniform(65536) - 1, + rand:uniform(65536) - 1, + rand:uniform(65536) - 1, E7, E8}, + IPv4Address = inet:ipv4_mapped_ipv6_address(IPv6Address), + ok. + t_gethostnative(Config) when is_list(Config) -> %% this will result in 26 bytes sent which causes problem in Windows %% if the port-program has not assured stdin to be read in BINARY mode diff --git a/lib/kernel/test/inet_res_SUITE.erl b/lib/kernel/test/inet_res_SUITE.erl index 6691ad9c06..2a5b8d0044 100644 --- a/lib/kernel/test/inet_res_SUITE.erl +++ b/lib/kernel/test/inet_res_SUITE.erl @@ -217,10 +217,10 @@ proxy_start(TC, {NS,P}) -> spawn_link( fun () -> try proxy_start(TC, NS, P, Parent, Tag) - catch C:X -> + catch C:X:Stacktrace -> io:format( "~w: ~w:~p ~p~n", - [self(),C,X,erlang:get_stacktrace()]) + [self(),C,X,Stacktrace]) end end), receive {started,Tag,Port} -> diff --git a/lib/kernel/test/init_SUITE.erl b/lib/kernel/test/init_SUITE.erl index 2b59eb2bfe..c8415b34e5 100644 --- a/lib/kernel/test/init_SUITE.erl +++ b/lib/kernel/test/init_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2016. All Rights Reserved. +%% Copyright Ericsson AB 1996-2018. 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. @@ -365,7 +365,9 @@ restart(Config) when is_list(Config) -> %% Ok, the node is up, now the real test test begins. erlang:monitor_node(Node, true), SysProcs0 = rpc:call(Node, ?MODULE, find_system_processes, []), - [InitPid, PurgerPid, LitCollectorPid, DirtyCodePid] = SysProcs0, + io:format("SysProcs0=~p~n", [SysProcs0]), + [InitPid, PurgerPid, LitCollectorPid, + DirtySigNPid, DirtySigHPid, DirtySigMPid] = SysProcs0, InitPid = rpc:call(Node, erlang, whereis, [init]), PurgerPid = rpc:call(Node, erlang, whereis, [erts_code_purger]), Procs = rpc:call(Node, erlang, processes, []), @@ -381,7 +383,9 @@ restart(Config) when is_list(Config) -> ok = wait_restart(30, Node), SysProcs1 = rpc:call(Node, ?MODULE, find_system_processes, []), - [InitPid1, PurgerPid1, LitCollectorPid1, DirtyCodePid1] = SysProcs1, + io:format("SysProcs1=~p~n", [SysProcs1]), + [InitPid1, PurgerPid1, LitCollectorPid1, + DirtySigNPid1, DirtySigHPid1, DirtySigMPid1] = SysProcs1, %% Still the same init process! InitPid1 = rpc:call(Node, erlang, whereis, [init]), @@ -394,20 +398,18 @@ restart(Config) when is_list(Config) -> PurgerP = pid_to_list(PurgerPid1), %% and same literal area collector process! - case LitCollectorPid of - undefined -> undefined = LitCollectorPid1; - _ -> - LitCollectorP = pid_to_list(LitCollectorPid), - LitCollectorP = pid_to_list(LitCollectorPid1) - end, - - %% and same dirty process code checker process! - case DirtyCodePid of - undefined -> undefined = DirtyCodePid1; - _ -> - DirtyCodeP = pid_to_list(DirtyCodePid), - DirtyCodeP = pid_to_list(DirtyCodePid1) - end, + LitCollectorP = pid_to_list(LitCollectorPid), + LitCollectorP = pid_to_list(LitCollectorPid1), + + %% and same normal dirty signal handler process! + DirtySigNP = pid_to_list(DirtySigNPid), + DirtySigNP = pid_to_list(DirtySigNPid1), + %% and same high dirty signal handler process! + DirtySigHP = pid_to_list(DirtySigHPid), + DirtySigHP = pid_to_list(DirtySigHPid1), + %% and same max dirty signal handler process! + DirtySigMP = pid_to_list(DirtySigMPid), + DirtySigMP = pid_to_list(DirtySigMPid1), NewProcs0 = rpc:call(Node, erlang, processes, []), NewProcs = NewProcs0 -- SysProcs1, @@ -433,7 +435,9 @@ restart(Config) when is_list(Config) -> -record(sys_procs, {init, code_purger, literal_collector, - dirty_proc_checker}). + dirty_sig_handler_normal, + dirty_sig_handler_high, + dirty_sig_handler_max}). find_system_processes() -> find_system_procs(processes(), #sys_procs{}). @@ -442,21 +446,32 @@ find_system_procs([], SysProcs) -> [SysProcs#sys_procs.init, SysProcs#sys_procs.code_purger, SysProcs#sys_procs.literal_collector, - SysProcs#sys_procs.dirty_proc_checker]; + SysProcs#sys_procs.dirty_sig_handler_normal, + SysProcs#sys_procs.dirty_sig_handler_high, + SysProcs#sys_procs.dirty_sig_handler_max]; find_system_procs([P|Ps], SysProcs) -> - case process_info(P, initial_call) of - {initial_call,{otp_ring0,start,2}} -> + case process_info(P, [initial_call, priority]) of + [{initial_call,{otp_ring0,start,2}},_] -> undefined = SysProcs#sys_procs.init, find_system_procs(Ps, SysProcs#sys_procs{init = P}); - {initial_call,{erts_code_purger,start,0}} -> + [{initial_call,{erts_code_purger,start,0}},_] -> undefined = SysProcs#sys_procs.code_purger, find_system_procs(Ps, SysProcs#sys_procs{code_purger = P}); - {initial_call,{erts_literal_area_collector,start,0}} -> + [{initial_call,{erts_literal_area_collector,start,0}},_] -> undefined = SysProcs#sys_procs.literal_collector, find_system_procs(Ps, SysProcs#sys_procs{literal_collector = P}); - {initial_call,{erts_dirty_process_code_checker,start,0}} -> - undefined = SysProcs#sys_procs.dirty_proc_checker, - find_system_procs(Ps, SysProcs#sys_procs{dirty_proc_checker = P}); + [{initial_call,{erts_dirty_process_signal_handler,start,0}}, + {priority,normal}] -> + undefined = SysProcs#sys_procs.dirty_sig_handler_normal, + find_system_procs(Ps, SysProcs#sys_procs{dirty_sig_handler_normal = P}); + [{initial_call,{erts_dirty_process_signal_handler,start,0}}, + {priority,high}] -> + undefined = SysProcs#sys_procs.dirty_sig_handler_high, + find_system_procs(Ps, SysProcs#sys_procs{dirty_sig_handler_high = P}); + [{initial_call,{erts_dirty_process_signal_handler,start,0}}, + {priority,max}] -> + undefined = SysProcs#sys_procs.dirty_sig_handler_max, + find_system_procs(Ps, SysProcs#sys_procs{dirty_sig_handler_max = P}); _ -> find_system_procs(Ps, SysProcs) end. diff --git a/lib/kernel/test/kernel_SUITE.erl b/lib/kernel/test/kernel_SUITE.erl index da56359294..7898988dbe 100644 --- a/lib/kernel/test/kernel_SUITE.erl +++ b/lib/kernel/test/kernel_SUITE.erl @@ -30,14 +30,14 @@ -export([init_per_testcase/2, end_per_testcase/2]). %% Test cases must be exported. --export([app_test/1, appup_test/1]). +-export([app_test/1, appup_test/1, refc/1]). suite() -> [{ct_hooks,[ts_install_cth]}, {timetrap,{minutes,2}}]. all() -> - [app_test, appup_test]. + [app_test, appup_test, refc]. groups() -> []. @@ -163,3 +163,68 @@ check_appup([Vsn|Vsns],Instrs,Expected) -> end; check_appup([],_,_) -> ok. + +%%% Check that refc module handles the counters as expected +refc(_Config) -> + Enable = fun(Enable) -> erlang:system_flag(scheduler_wall_time, Enable) end, + IsOn = fun() -> undefined /= erlang:statistics(scheduler_wall_time) end, + Tester = self(), + Loop = fun Loop() -> + receive + die -> normal; + {apply, Bool} -> + Res = Enable(Bool), + Tester ! {self(), Res}, + Loop() + end + end, + + %% Counter should be 0 + false = Enable(false), + + false = Enable(true), + true = Enable(true), + true = Enable(false), + true = Enable(false), + + %% Counter should be 0 + false = IsOn(), + + P1 = spawn_link(Loop), + P1 ! {apply, true}, + receive {P1, R1} -> false = R1 end, + + %% P1 has turned it on counter should be one + true = IsOn(), + true = Enable(true), + true = Enable(false), + true = IsOn(), + + P1 ! {apply, false}, + receive {P1, R2} -> true = R2 end, + false = IsOn(), + + P1 ! {apply, true}, + receive {P1, R3} -> false = R3 end, + true = IsOn(), + true = Enable(false), + + + P1 ! die, + timer:sleep(100), + false = IsOn(), + false = Enable(false), + + P2 = spawn_link(Loop), + P2 ! {apply, true}, + receive {P2, R4} -> false = R4 end, + true = IsOn(), + P2 ! {apply, true}, + receive {P2, R5} -> true = R5 end, + true = IsOn(), + + P2 ! die, + timer:sleep(100), + false = IsOn(), + + ok. diff --git a/lib/kernel/test/kernel_bench.spec b/lib/kernel/test/kernel_bench.spec index 8de60dae31..4de133f21b 100644 --- a/lib/kernel/test/kernel_bench.spec +++ b/lib/kernel/test/kernel_bench.spec @@ -1 +1,2 @@ {groups,"../kernel_test",zlib_SUITE,[bench]}. +{groups,"../kernel_test",file_SUITE,[bench]}. diff --git a/lib/kernel/test/os_SUITE.erl b/lib/kernel/test/os_SUITE.erl index a0bcde68db..591fbb2125 100644 --- a/lib/kernel/test/os_SUITE.erl +++ b/lib/kernel/test/os_SUITE.erl @@ -22,7 +22,8 @@ -export([all/0, suite/0,groups/0,init_per_suite/1, end_per_suite/1, init_per_group/2,end_per_group/2, init_per_testcase/2,end_per_testcase/2]). --export([space_in_cwd/1, quoting/1, cmd_unicode/1, space_in_name/1, bad_command/1, +-export([space_in_cwd/1, quoting/1, cmd_unicode/1, + null_in_command/1, space_in_name/1, bad_command/1, find_executable/1, unix_comment_in_command/1, deep_list_command/1, large_output_command/1, background_command/0, background_command/1, message_leak/1, close_stdin/0, close_stdin/1, max_size_command/1, @@ -35,7 +36,8 @@ suite() -> {timetrap,{minutes,1}}]. all() -> - [space_in_cwd, quoting, cmd_unicode, space_in_name, bad_command, + [space_in_cwd, quoting, cmd_unicode, null_in_command, + space_in_name, bad_command, find_executable, unix_comment_in_command, deep_list_command, large_output_command, background_command, message_leak, close_stdin, max_size_command, perf_counter_api]. @@ -126,6 +128,14 @@ cmd_unicode(Config) when is_list(Config) -> [] = receive_all(), ok. +null_in_command(Config) -> + {Ok, Error} = case os:type() of + {win32,_} -> {"dir", "di\0r"}; + _ -> {"ls", "l\0s"} + end, + true = is_list(try os:cmd(Ok) catch Class0:_ -> Class0 end), + error = try os:cmd(Error) catch Class1:_ -> Class1 end, + ok. %% Test that program with a space in its name can be executed. space_in_name(Config) when is_list(Config) -> diff --git a/lib/kernel/test/pdict_SUITE.erl b/lib/kernel/test/pdict_SUITE.erl index d105952df9..a891451c82 100644 --- a/lib/kernel/test/pdict_SUITE.erl +++ b/lib/kernel/test/pdict_SUITE.erl @@ -33,6 +33,7 @@ init_per_group/2,end_per_group/2, mixed/1, literals/1, + destructive/1, simple/1, complicated/1, heavy/1, simple_all_keys/1, info/1]). -export([init_per_testcase/2, end_per_testcase/2]). -export([other_process/2]). @@ -52,6 +53,7 @@ suite() -> all() -> [simple, complicated, heavy, simple_all_keys, info, literals, + destructive, mixed]. groups() -> @@ -367,6 +369,36 @@ match_keys(All) -> ok. +%% Test destructive put optimization of immed values +%% does not affect get/0 or process_info. +destructive(_Config) -> + Keys = lists:seq(1,100), + [put(Key, 17) || Key <- Keys], + Get1 = get(), + {dictionary,PI1} = process_info(self(), dictionary), + + [begin + {Key, 17} = lists:keyfind(Key, 1, Get1), + {Key, 17} = lists:keyfind(Key, 1, PI1) + end + || Key <- Keys], + + [17 = put(Key, 42) || Key <- Keys], % Mutate + + Get2 = get(), + {dictionary,PI2} = process_info(self(), dictionary), + + [begin + {Key, 17} = lists:keyfind(Key, 1, Get1), + {Key, 17} = lists:keyfind(Key, 1, PI1), + {Key, 42} = lists:keyfind(Key, 1, Get2), + {Key, 42} = lists:keyfind(Key, 1, PI2) + + end + || Key <- Keys], + + ok. + %% Do random mixed put/erase to test grow/shrink %% Written for a temporary bug in gc during shrink mixed(_Config) -> diff --git a/lib/kernel/test/prim_file_SUITE.erl b/lib/kernel/test/prim_file_SUITE.erl index e88d42788f..5bb230d1c4 100644 --- a/lib/kernel/test/prim_file_SUITE.erl +++ b/lib/kernel/test/prim_file_SUITE.erl @@ -21,38 +21,23 @@ -export([all/0, suite/0,groups/0,init_per_suite/1, end_per_suite/1, init_per_group/2,end_per_group/2, init_per_testcase/2, end_per_testcase/2, read_write_file/1, free_memory/0]). --export([cur_dir_0a/1, cur_dir_0b/1, - cur_dir_1a/1, cur_dir_1b/1, - make_del_dir_a/1, make_del_dir_b/1, - pos1/1, pos2/1]). --export([close/1, - delete_a/1, delete_b/1]). --export([ open1/1, modes/1]). --export([ - file_info_basic_file_a/1, file_info_basic_file_b/1, - file_info_basic_directory_a/1, file_info_basic_directory_b/1, - file_info_bad_a/1, file_info_bad_b/1, - file_info_times_a/1, file_info_times_b/1, - file_write_file_info_a/1, file_write_file_info_b/1, - file_read_file_info_opts/1, file_write_file_info_opts/1, - file_write_read_file_info_opts/1 - ]). --export([rename_a/1, rename_b/1, - access/1, truncate/1, datasync/1, sync/1, +-export([cur_dir_0/1, cur_dir_1/1, + make_del_dir/1, pos1/1, pos2/1]). +-export([close/1, delete/1]). +-export([open1/1, modes/1]). +-export([file_info_basic_file/1, file_info_basic_directory/1, file_info_bad/1, + file_info_times/1, file_write_file_info/1, + file_read_file_info_opts/1, file_write_file_info_opts/1, + file_write_read_file_info_opts/1]). +-export([rename/1, access/1, truncate/1, datasync/1, sync/1, read_write/1, pread_write/1, append/1, exclusive/1]). --export([ e_delete/1, e_rename/1, e_make_dir/1, e_del_dir/1]). +-export([e_delete/1, e_rename/1, e_make_dir/1, e_del_dir/1]). --export([ read_not_really_compressed/1, - read_compressed/1, write_compressed/1, - compress_errors/1]). - --export([ - make_link_a/1, make_link_b/1, - read_link_info_for_non_link/1, - symlinks_a/1, symlinks_b/1, - list_dir_limit/1, - list_dir_error/1, - list_dir/1]). +-export([make_link/1, read_link_info_for_non_link/1, + symlinks/1, + list_dir_limit/1, + list_dir_error/1, + list_dir/1]). -export([advise/1]). -export([large_write/1]). @@ -67,29 +52,16 @@ -define(PRIM_FILE, prim_file). -%% Calls ?PRIM_FILE:F with arguments A and an optional handle H -%% as first argument, unless the handle is [], i.e no handle. -%% This is a macro to give the compiler and thereby -%% the cross reference tool the possibility to interprete -%% the call, since M, F, A (or [H | A]) can all be known at -%% compile time. --define(PRIM_FILE_call(F, H, A), - case H of - [] -> apply(?PRIM_FILE, F, A); - _ -> apply(?PRIM_FILE, F, [H | A]) - end). - suite() -> []. all() -> [read_write_file, {group, dirs}, {group, files}, - delete_a, delete_b, rename_a, rename_b, {group, errors}, - {group, compression}, {group, links}, list_dir_limit, list_dir]. + delete, rename, {group, errors}, {group, links}, + list_dir_limit, list_dir]. groups() -> [{dirs, [], - [make_del_dir_a, make_del_dir_b, cur_dir_0a, cur_dir_0b, - cur_dir_1a, cur_dir_1b]}, + [make_del_dir, cur_dir_0, cur_dir_1]}, {files, [], [{group, open}, {group, pos}, {group, file_info}, truncate, sync, datasync, advise, large_write, allocate]}, @@ -98,22 +70,14 @@ groups() -> append, exclusive]}, {pos, [], [pos1, pos2]}, {file_info, [], - [file_info_basic_file_a, file_info_basic_file_b, - file_info_basic_directory_a, - file_info_basic_directory_b, file_info_bad_a, - file_info_bad_b, file_info_times_a, file_info_times_b, - file_write_file_info_a, file_write_file_info_b, - file_read_file_info_opts, file_write_file_info_opts, - file_write_read_file_info_opts + [file_info_basic_file,file_info_basic_directory, file_info_bad, + file_info_times, file_write_file_info, file_read_file_info_opts, + file_write_file_info_opts, file_write_read_file_info_opts ]}, {errors, [], [e_delete, e_rename, e_make_dir, e_del_dir]}, - {compression, [], - [read_compressed, read_not_really_compressed, - write_compressed, compress_errors]}, {links, [], - [make_link_a, make_link_b, read_link_info_for_non_link, - symlinks_a, symlinks_b, list_dir_error]}]. + [make_link, read_link_info_for_non_link, symlinks, list_dir_error]}]. init_per_testcase(large_write, Config) -> {ok, Started} = application:ensure_all_started(os_mon), @@ -246,39 +210,27 @@ read_write_file(Config) when is_list(Config) -> %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -make_del_dir_a(Config) when is_list(Config) -> - make_del_dir(Config, [], "_a"). - -make_del_dir_b(Config) when is_list(Config) -> - {ok, Handle} = ?PRIM_FILE:start(), - Result = make_del_dir(Config, Handle, "_b"), - ok = ?PRIM_FILE:stop(Handle), - %% Just to make sure the state of the server makes a difference - {error, einval} = ?PRIM_FILE_call(get_cwd, Handle, []), - Result. - -make_del_dir(Config, Handle, Suffix) -> +make_del_dir(Config) when is_list(Config) -> RootDir = proplists:get_value(priv_dir,Config), NewDir = filename:join(RootDir, atom_to_list(?MODULE) - ++"_mk-dir"++Suffix), - ok = ?PRIM_FILE_call(make_dir, Handle, [NewDir]), - {error, eexist} = ?PRIM_FILE_call(make_dir, Handle, [NewDir]), - ok = ?PRIM_FILE_call(del_dir, Handle, [NewDir]), - {error, enoent} = ?PRIM_FILE_call(del_dir, Handle, [NewDir]), + ++"_mk-dir"), + ok = ?PRIM_FILE:make_dir(NewDir), + {error, eexist} = ?PRIM_FILE:make_dir(NewDir), + ok = ?PRIM_FILE:del_dir(NewDir), + {error, enoent} = ?PRIM_FILE:del_dir(NewDir), %% Make sure we are not in a directory directly under test_server %% as that would result in eacces errors when trying to delete '..', %% because there are processes having that directory as current. - ok = ?PRIM_FILE_call(make_dir, Handle, [NewDir]), - {ok, CurrentDir} = ?PRIM_FILE_call(get_cwd, Handle, []), + ok = ?PRIM_FILE:make_dir(NewDir), + {ok, CurrentDir} = ?PRIM_FILE:get_cwd(), case {os:type(), length(NewDir) >= 260 } of {{win32,_}, true} -> io:format("Skip set_cwd for windows path longer than 260 (MAX_PATH)\n", []), io:format("\nNewDir = ~p\n", [NewDir]); _ -> - ok = ?PRIM_FILE_call(set_cwd, Handle, [NewDir]) + ok = ?PRIM_FILE:set_cwd(NewDir) end, try %% Check that we get an error when trying to create... @@ -286,14 +238,14 @@ make_del_dir(Config, Handle, Suffix) -> NewDir2 = filename:join(RootDir, atom_to_list(?MODULE) ++"_mk-dir-noexist/foo"), - {error, enoent} = ?PRIM_FILE_call(make_dir, Handle, [NewDir2]), + {error, enoent} = ?PRIM_FILE:make_dir(NewDir2), %% a nameless directory - {error, enoent} = ?PRIM_FILE_call(make_dir, Handle, [""]), + {error, enoent} = ?PRIM_FILE:make_dir(""), %% a directory with illegal name - {error, badarg} = ?PRIM_FILE_call(make_dir, Handle, ['mk-dir']), + {error, badarg} = ?PRIM_FILE:make_dir('mk-dir'), %% a directory with illegal name, even if it's a (bad) list - {error, badarg} = ?PRIM_FILE_call(make_dir, Handle, [[1,2,3,{}]]), + {error, badarg} = ?PRIM_FILE:make_dir([1,2,3,{}]), %% Maybe this isn't an error, exactly, but worth mentioning anyway: %% ok = ?PRIM_FILE:make_dir([$f,$o,$o,0,$b,$a,$r])), @@ -306,125 +258,101 @@ make_del_dir(Config, Handle, Suffix) -> %% Try deleting some bad directories %% Deleting the parent directory to the current, sounds dangerous, huh? %% Don't worry ;-) the parent directory should never be empty, right? - case ?PRIM_FILE_call(del_dir, Handle, [".."]) of + case ?PRIM_FILE:del_dir("..") of {error, eexist} -> ok; {error, eacces} -> ok; %OpenBSD {error, einval} -> ok %FreeBSD end, - {error, enoent} = ?PRIM_FILE_call(del_dir, Handle, [""]), - {error, badarg} = ?PRIM_FILE_call(del_dir, Handle, [[3,2,1,{}]]) + {error, enoent} = ?PRIM_FILE:del_dir(""), + {error, badarg} = ?PRIM_FILE:del_dir([3,2,1,{}]) after - ok = ?PRIM_FILE_call(set_cwd, Handle, [CurrentDir]) + ok = ?PRIM_FILE:set_cwd(CurrentDir) end, ok. -cur_dir_0a(Config) when is_list(Config) -> - cur_dir_0(Config, []). - -cur_dir_0b(Config) when is_list(Config) -> - {ok, Handle} = ?PRIM_FILE:start(), - Result = cur_dir_0(Config, Handle), - ok = ?PRIM_FILE:stop(Handle), - Result. - -cur_dir_0(Config, Handle) -> +cur_dir_0(Config) when is_list(Config) -> %% Find out the current dir, and cd to it ;-) - {ok,BaseDir} = ?PRIM_FILE_call(get_cwd, Handle, []), + {ok,BaseDir} = ?PRIM_FILE:get_cwd(), Dir1 = BaseDir ++ "", %% Check that it's a string - ok = ?PRIM_FILE_call(set_cwd, Handle, [Dir1]), - DirName = atom_to_list(?MODULE) ++ - case Handle of - [] -> - "_curdir"; - _ -> - "_curdir_h" - end, + ok = ?PRIM_FILE:set_cwd(Dir1), + DirName = atom_to_list(?MODULE) ++ "_curdir", %% Make a new dir, and cd to that RootDir = proplists:get_value(priv_dir,Config), NewDir = filename:join(RootDir, DirName), - ok = ?PRIM_FILE_call(make_dir, Handle, [NewDir]), + ok = ?PRIM_FILE:make_dir(NewDir), case {os:type(), length(NewDir) >= 260} of {{win32,_}, true} -> io:format("Skip set_cwd for windows path longer than 260 (MAX_PATH):\n"), io:format("\nNewDir = ~p\n", [NewDir]); _ -> io:format("cd to ~s",[NewDir]), - ok = ?PRIM_FILE_call(set_cwd, Handle, [NewDir]), + ok = ?PRIM_FILE:set_cwd(NewDir), %% Create a file in the new current directory, and check that it %% really is created there UncommonName = "uncommon.fil", {ok,Fd} = ?PRIM_FILE:open(UncommonName, [read, write]), ok = ?PRIM_FILE:close(Fd), - {ok,NewDirFiles} = ?PRIM_FILE_call(list_dir, Handle, ["."]), + {ok,NewDirFiles} = ?PRIM_FILE:list_dir("."), true = lists:member(UncommonName,NewDirFiles), %% Delete the directory and return to the old current directory %% and check that the created file isn't there (too!) expect({error, einval}, {error, eacces}, {error, eexist}, - ?PRIM_FILE_call(del_dir, Handle, [NewDir])), - ?PRIM_FILE_call(delete, Handle, [UncommonName]), - {ok,[]} = ?PRIM_FILE_call(list_dir, Handle, ["."]), - ok = ?PRIM_FILE_call(set_cwd, Handle, [Dir1]), + ?PRIM_FILE:del_dir(NewDir)), + ?PRIM_FILE:delete(UncommonName), + {ok,[]} = ?PRIM_FILE:list_dir("."), + ok = ?PRIM_FILE:set_cwd(Dir1), io:format("cd back to ~s",[Dir1]), - ok = ?PRIM_FILE_call(del_dir, Handle, [NewDir]), - {error, enoent} = ?PRIM_FILE_call(set_cwd, Handle, [NewDir]), - ok = ?PRIM_FILE_call(set_cwd, Handle, [Dir1]), + ok = ?PRIM_FILE:del_dir(NewDir), + {error, enoent} = ?PRIM_FILE:set_cwd(NewDir), + ok = ?PRIM_FILE:set_cwd(Dir1), io:format("cd back to ~s",[Dir1]), - {ok,OldDirFiles} = ?PRIM_FILE_call(list_dir, Handle, ["."]), + {ok,OldDirFiles} = ?PRIM_FILE:list_dir("."), false = lists:member(UncommonName,OldDirFiles) end, %% Try doing some bad things {error, badarg} = - ?PRIM_FILE_call(set_cwd, Handle, [{foo,bar}]), + ?PRIM_FILE:set_cwd({foo,bar}), {error, enoent} = - ?PRIM_FILE_call(set_cwd, Handle, [""]), + ?PRIM_FILE:set_cwd(""), {error, enoent} = - ?PRIM_FILE_call(set_cwd, Handle, [".......a......"]), + ?PRIM_FILE:set_cwd(".......a......"), {ok,BaseDir} = - ?PRIM_FILE_call(get_cwd, Handle, []), %% Still there? + ?PRIM_FILE:get_cwd(), %% Still there? %% On Windows, there should only be slashes, no backslashes, %% in the return value of get_cwd(). %% (The test is harmless on Unix, because filenames usually %% don't contain backslashes.) - {ok, BaseDir} = ?PRIM_FILE_call(get_cwd, Handle, []), + {ok, BaseDir} = ?PRIM_FILE:get_cwd(), false = lists:member($\\, BaseDir), ok. %% Tests ?PRIM_FILE:get_cwd/1. -cur_dir_1a(Config) when is_list(Config) -> - cur_dir_1(Config, []). - -cur_dir_1b(Config) when is_list(Config) -> - {ok, Handle} = ?PRIM_FILE:start(), - Result = cur_dir_1(Config, Handle), - ok = ?PRIM_FILE:stop(Handle), - Result. - -cur_dir_1(Config, Handle) -> +cur_dir_1(Config) when is_list(Config) -> case os:type() of {win32, _} -> - win_cur_dir_1(Config, Handle); + win_cur_dir_1(Config); _ -> {error, enotsup} = - ?PRIM_FILE_call(get_cwd, Handle, ["d:"]) + ?PRIM_FILE:get_cwd("d:") end, ok. -win_cur_dir_1(_Config, Handle) -> - {ok, BaseDir} = ?PRIM_FILE_call(get_cwd, Handle, []), +win_cur_dir_1(_Config) -> + {ok, BaseDir} = ?PRIM_FILE:get_cwd(), %% Get the drive letter from the current directory, %% and try to get current directory for that drive. [Drive, $:|_] = BaseDir, - {ok, BaseDir} = ?PRIM_FILE_call(get_cwd, Handle, [[Drive, $:]]), + {ok, BaseDir} = ?PRIM_FILE:get_cwd([Drive, $:]), io:format("BaseDir = ~s\n", [BaseDir]), %% Unfortunately, there is no way to move away from the @@ -446,12 +374,12 @@ open1(Config) when is_list(Config) -> Name = filename:join(NewDir, "foo1.fil"), {ok,Fd1} = ?PRIM_FILE:open(Name, [read, write]), {ok,Fd2} = ?PRIM_FILE:open(Name, [read]), - Str = "{a,tuple}.\n", - Length = length(Str), - ?PRIM_FILE:write(Fd1,Str), + Bin = list_to_binary("{a,tuple}.\n"), + Length = byte_size(Bin), + ?PRIM_FILE:write(Fd1,Bin), {ok,0} = ?PRIM_FILE:position(Fd1,bof), - {ok, Str} = ?PRIM_FILE:read(Fd1,Length), - {ok, Str} = ?PRIM_FILE:read(Fd2,Length), + {ok, Bin} = ?PRIM_FILE:read(Fd1,Length), + {ok, Bin} = ?PRIM_FILE:read(Fd2,Length), ok = ?PRIM_FILE:close(Fd2), {ok,0} = ?PRIM_FILE:position(Fd1,bof), ok = ?PRIM_FILE:truncate(Fd1), @@ -471,13 +399,13 @@ modes(Config) when is_list(Config) -> ++"_open_modes"), ok = ?PRIM_FILE:make_dir(NewDir), Name1 = filename:join(NewDir, "foo1.fil"), - Marker = "hello, world", - Length = length(Marker), + Marker = <<"hello, world">>, + Length = byte_size(Marker), %% write {ok, Fd1} = ?PRIM_FILE:open(Name1, [write]), ok = ?PRIM_FILE:write(Fd1, Marker), - ok = ?PRIM_FILE:write(Fd1, ".\n"), + ok = ?PRIM_FILE:write(Fd1, <<".\n">>), ok = ?PRIM_FILE:close(Fd1), %% read @@ -496,12 +424,6 @@ modes(Config) when is_list(Config) -> {ok, Marker} = ?PRIM_FILE:read(Fd4, Length), ok = ?PRIM_FILE:close(Fd4), - %% read and binary - BinaryMarker = list_to_binary(Marker), - {ok, Fd5} = ?PRIM_FILE:open(Name1, [read, binary]), - {ok, BinaryMarker} = ?PRIM_FILE:read(Fd5, Length), - ok = ?PRIM_FILE:close(Fd5), - ok. close(Config) when is_list(Config) -> @@ -528,9 +450,9 @@ access(Config) when is_list(Config) -> Name = filename:join(RootDir, atom_to_list(?MODULE) ++"_access.fil"), - Str = "ABCDEFGH", + Bin = <<"ABCDEFGH">>, {ok,Fd1} = ?PRIM_FILE:open(Name, [write]), - ?PRIM_FILE:write(Fd1,Str), + ?PRIM_FILE:write(Fd1,Bin), ok = ?PRIM_FILE:close(Fd1), %% Check that we can't write when in read only mode {ok,Fd2} = ?PRIM_FILE:open(Name, [read]), @@ -542,7 +464,7 @@ access(Config) when is_list(Config) -> end, ok = ?PRIM_FILE:close(Fd2), {ok, Fd3} = ?PRIM_FILE:open(Name, [read]), - {ok, Str} = ?PRIM_FILE:read(Fd3,length(Str)), + {ok, Bin} = ?PRIM_FILE:read(Fd3,byte_size(Bin)), ok = ?PRIM_FILE:close(Fd3), ok. @@ -564,7 +486,7 @@ read_write(Config) when is_list(Config) -> ok. read_write_test(File) -> - Marker = "hello, world", + Marker = <<"hello, world">>, ok = ?PRIM_FILE:write(File, Marker), {ok, 0} = ?PRIM_FILE:position(File, 0), {ok, Marker} = ?PRIM_FILE:read(File, 100), @@ -590,15 +512,15 @@ pread_write(Config) when is_list(Config) -> ok. pread_write_test(File) -> - Marker = "hello, world", - Len = length(Marker), + Marker = <<"hello, world">>, + Len = byte_size(Marker), ok = ?PRIM_FILE:write(File, Marker), {ok, Marker} = ?PRIM_FILE:pread(File, 0, 100), eof = ?PRIM_FILE:pread(File, 100, 1), ok = ?PRIM_FILE:pwrite(File, Len, Marker), {ok, Marker} = ?PRIM_FILE:pread(File, Len, 100), eof = ?PRIM_FILE:pread(File, 100, 1), - MM = Marker ++ Marker, + MM = <<Marker/binary,Marker/binary>>, {ok, MM} = ?PRIM_FILE:pread(File, 0, 100), ok = ?PRIM_FILE:close(File), ok. @@ -655,24 +577,24 @@ pos1(Config) when is_list(Config) -> atom_to_list(?MODULE) ++"_pos1.fil"), {ok, Fd1} = ?PRIM_FILE:open(Name, [write]), - ?PRIM_FILE:write(Fd1,"ABCDEFGH"), + ?PRIM_FILE:write(Fd1,<<"ABCDEFGH">>), ok = ?PRIM_FILE:close(Fd1), {ok, Fd2} = ?PRIM_FILE:open(Name, [read]), %% Start pos is first char io:format("Relative positions"), - {ok, "A"} = ?PRIM_FILE:read(Fd2,1), + {ok, <<"A">>} = ?PRIM_FILE:read(Fd2,1), {ok, 2} = ?PRIM_FILE:position(Fd2,{cur,1}), - {ok, "C"} = ?PRIM_FILE:read(Fd2,1), + {ok, <<"C">>} = ?PRIM_FILE:read(Fd2,1), {ok, 0} = ?PRIM_FILE:position(Fd2,{cur,-3}), - {ok, "A"} = ?PRIM_FILE:read(Fd2,1), + {ok, <<"A">>} = ?PRIM_FILE:read(Fd2,1), %% Backwards from first char should be an error {ok,0} = ?PRIM_FILE:position(Fd2,{cur,-1}), {error, einval} = ?PRIM_FILE:position(Fd2,{cur,-1}), %% Reset position and move again {ok, 0} = ?PRIM_FILE:position(Fd2,0), {ok, 2} = ?PRIM_FILE:position(Fd2,{cur,2}), - {ok, "C"} = ?PRIM_FILE:read(Fd2,1), + {ok, <<"C">>} = ?PRIM_FILE:read(Fd2,1), %% Go a lot forwards {ok, 13} = ?PRIM_FILE:position(Fd2,{cur,10}), eof = ?PRIM_FILE:read(Fd2,1), @@ -684,27 +606,27 @@ pos1(Config) when is_list(Config) -> {ok, 8} = ?PRIM_FILE:position(Fd2,cur), eof = ?PRIM_FILE:read(Fd2,1), {ok, 7} = ?PRIM_FILE:position(Fd2,7), - {ok, "H"} = ?PRIM_FILE:read(Fd2,1), + {ok, <<"H">>} = ?PRIM_FILE:read(Fd2,1), {ok, 0} = ?PRIM_FILE:position(Fd2,0), - {ok, "A"} = ?PRIM_FILE:read(Fd2,1), + {ok, <<"A">>} = ?PRIM_FILE:read(Fd2,1), {ok, 3} = ?PRIM_FILE:position(Fd2,3), - {ok, "D"} = ?PRIM_FILE:read(Fd2,1), + {ok, <<"D">>} = ?PRIM_FILE:read(Fd2,1), {ok, 12} = ?PRIM_FILE:position(Fd2,12), eof = ?PRIM_FILE:read(Fd2,1), {ok, 3} = ?PRIM_FILE:position(Fd2,3), - {ok, "D"} = ?PRIM_FILE:read(Fd2,1), + {ok, <<"D">>} = ?PRIM_FILE:read(Fd2,1), %% Try the {bof,X} notation {ok, 3} = ?PRIM_FILE:position(Fd2,{bof,3}), - {ok, "D"} = ?PRIM_FILE:read(Fd2,1), + {ok, <<"D">>} = ?PRIM_FILE:read(Fd2,1), %% Try eof positions io:format("EOF positions"), {ok, 8} = ?PRIM_FILE:position(Fd2,{eof,0}), eof = ?PRIM_FILE:read(Fd2,1), {ok, 7} = ?PRIM_FILE:position(Fd2,{eof,-1}), - {ok, "H"} = ?PRIM_FILE:read(Fd2,1), + {ok, <<"H">>} = ?PRIM_FILE:read(Fd2,1), {ok, 0} = ?PRIM_FILE:position(Fd2,{eof,-8}), - {ok, "A"} = ?PRIM_FILE:read(Fd2,1), + {ok, <<"A">>} = ?PRIM_FILE:read(Fd2,1), {error, einval} = ?PRIM_FILE:position(Fd2,{eof,-9}), ok. @@ -714,7 +636,7 @@ pos2(Config) when is_list(Config) -> atom_to_list(?MODULE) ++"_pos2.fil"), {ok,Fd1} = ?PRIM_FILE:open(Name, [write]), - ?PRIM_FILE:write(Fd1,"ABCDEFGH"), + ?PRIM_FILE:write(Fd1,<<"ABCDEFGH">>), ok = ?PRIM_FILE:close(Fd1), {ok, Fd2} = ?PRIM_FILE:open(Name, [read]), {error, einval} = ?PRIM_FILE:position(Fd2,-1), @@ -722,35 +644,25 @@ pos2(Config) when is_list(Config) -> %% Make sure that we still can search after an error. {ok, 0} = ?PRIM_FILE:position(Fd2, 0), {ok, 3} = ?PRIM_FILE:position(Fd2, {bof,3}), - {ok, "D"} = ?PRIM_FILE:read(Fd2,1), + {ok, <<"D">>} = ?PRIM_FILE:read(Fd2,1), io:format("DONE"), ok. - -file_info_basic_file_a(Config) when is_list(Config) -> - file_info_basic_file(Config, [], "_a"). - -file_info_basic_file_b(Config) when is_list(Config) -> - {ok, Handle} = ?PRIM_FILE:start(), - Result = file_info_basic_file(Config, Handle, "_b"), - ok = ?PRIM_FILE:stop(Handle), - Result. - -file_info_basic_file(Config, Handle, Suffix) -> +file_info_basic_file(Config) when is_list(Config) -> RootDir = proplists:get_value(priv_dir, Config), %% Create a short file. Name = filename:join(RootDir, atom_to_list(?MODULE) - ++"_basic_test"++Suffix++".fil"), + ++"_basic_test"".fil"), {ok,Fd1} = ?PRIM_FILE:open(Name, [write]), ?PRIM_FILE:write(Fd1, "foo bar"), ok = ?PRIM_FILE:close(Fd1), %% Test that the file has the expected attributes. %% The times are tricky, so we will save them to a separate test case. - {ok, FileInfo} = ?PRIM_FILE_call(read_file_info, Handle, [Name]), + {ok, FileInfo} = ?PRIM_FILE:read_file_info(Name), #file_info{size = Size, type = Type, access = Access, atime = AccessTime, mtime = ModifyTime} = FileInfo, @@ -768,39 +680,30 @@ file_info_basic_file(Config, Handle, Suffix) -> ok. -file_info_basic_directory_a(Config) when is_list(Config) -> - file_info_basic_directory(Config, []). - -file_info_basic_directory_b(Config) when is_list(Config) -> - {ok, Handle} = ?PRIM_FILE:start(), - Result = file_info_basic_directory(Config, Handle), - ok = ?PRIM_FILE:stop(Handle), - Result. - -file_info_basic_directory(Config, Handle) -> +file_info_basic_directory(Config) when is_list(Config) -> %% Note: filename:join/1 removes any trailing slash, %% which is essential for ?PRIM_FILE:read_file_info/1 to work on %% platforms such as Windows95. RootDir = filename:join([proplists:get_value(priv_dir, Config)]), %% Test that the RootDir directory has the expected attributes. - test_directory(RootDir, read_write, Handle), + test_directory(RootDir, read_write), %% Note that on Windows file systems, "/" or "c:/" are *NOT* directories. %% Therefore, test that ?PRIM_FILE:read_file_info/1 behaves %% as if they were directories. case os:type() of {win32, _} -> - test_directory("/", read_write, Handle), - test_directory("c:/", read_write, Handle), - test_directory("c:\\", read_write, Handle); + test_directory("/", read_write), + test_directory("c:/", read_write), + test_directory("c:\\", read_write); _ -> - test_directory("/", read, Handle) + test_directory("/", read) end, ok. -test_directory(Name, ExpectedAccess, Handle) -> - {ok, FileInfo} = ?PRIM_FILE_call(read_file_info, Handle, [Name]), +test_directory(Name, ExpectedAccess) -> + {ok, FileInfo} = ?PRIM_FILE:read_file_info(Name), #file_info{size = Size, type = Type, access = Access, atime = AccessTime, mtime = ModifyTime} = FileInfo, @@ -824,45 +727,24 @@ all_integers([]) -> %% Try something nonexistent. -file_info_bad_a(Config) when is_list(Config) -> - file_info_bad(Config, []). - -file_info_bad_b(Config) when is_list(Config) -> - {ok, Handle} = ?PRIM_FILE:start(), - Result = file_info_bad(Config, Handle), - ok = ?PRIM_FILE:stop(Handle), - Result. - -file_info_bad(Config, Handle) -> +file_info_bad(Config) when is_list(Config) -> RootDir = filename:join([proplists:get_value(priv_dir, Config)]), - {error, enoent} = - ?PRIM_FILE_call( - read_file_info, Handle, - [filename:join(RootDir, - atom_to_list(?MODULE)++"_nonexistent")]), + NonExistent = filename:join(RootDir, atom_to_list(?MODULE)++"_nonexistent"), + {error, enoent} = ?PRIM_FILE:read_file_info(NonExistent), ok. %% Test that the file times behave as they should. -file_info_times_a(Config) when is_list(Config) -> - file_info_times(Config, [], "_a"). - -file_info_times_b(Config) when is_list(Config) -> - {ok, Handle} = ?PRIM_FILE:start(), - Result = file_info_times(Config, Handle, "_b"), - ok = ?PRIM_FILE:stop(Handle), - Result. - -file_info_times(Config, Handle, Suffix) -> +file_info_times(Config) when is_list(Config) -> %% We have to try this twice, since if the test runs across the change %% of a month the time diff calculations will fail. But it won't happen %% if you run it twice in succession. test_server:m_out_of_n( 1,2, - fun() -> file_info_int(Config, Handle, Suffix) end), + fun() -> file_info_int(Config) end), ok. -file_info_int(Config, Handle, Suffix) -> +file_info_int(Config) -> %% Note: filename:join/1 removes any trailing slash, %% which is essential for ?PRIM_FILE:read_file_info/1 to work on %% platforms such as Windows95. @@ -872,14 +754,14 @@ file_info_int(Config, Handle, Suffix) -> Name = filename:join(RootDir, atom_to_list(?MODULE) - ++"_file_info"++Suffix++".fil"), + ++"_file_info.fil"), {ok,Fd1} = ?PRIM_FILE:open(Name, [write]), ?PRIM_FILE:write(Fd1,"foo"), %% check that the file got a modify date max a few seconds away from now {ok, #file_info{type = regular, atime = AccTime1, mtime = ModTime1}} = - ?PRIM_FILE_call(read_file_info, Handle, [Name]), + ?PRIM_FILE:read_file_info(Name), Now = erlang:localtime(), io:format("Now ~p",[Now]), io:format("Open file Acc ~p Mod ~p",[AccTime1,ModTime1]), @@ -897,7 +779,7 @@ file_info_int(Config, Handle, Suffix) -> ok = ?PRIM_FILE:close(Fd1), {ok, #file_info{size = Size, type = regular, access = Access, atime = AccTime2, mtime = ModTime2}} = - ?PRIM_FILE_call(read_file_info, Handle, [Name]), + ?PRIM_FILE:read_file_info(Name), io:format("Closed file Acc ~p Mod ~p",[AccTime2,ModTime2]), true = time_dist(ModTime1, ModTime2) >= 0, @@ -909,7 +791,7 @@ file_info_int(Config, Handle, Suffix) -> {ok, #file_info{size = DSize, type = directory, access = DAccess, atime = AccTime3, mtime = ModTime3}} = - ?PRIM_FILE_call(read_file_info, Handle, [RootDir]), + ?PRIM_FILE:read_file_info(RootDir), %% this dir was modified only a few secs ago io:format("Dir Acc ~p; Mod ~p; Now ~p", [AccTime3, ModTime3, Now]), @@ -936,16 +818,7 @@ filter_atime(Atime, Config) -> %% Test the write_file_info/2 function. -file_write_file_info_a(Config) when is_list(Config) -> - file_write_file_info(Config, [], "_a"). - -file_write_file_info_b(Config) when is_list(Config) -> - {ok, Handle} = ?PRIM_FILE:start(), - Result = file_write_file_info(Config, Handle, "_b"), - ok = ?PRIM_FILE:stop(Handle), - Result. - -file_write_file_info(Config, Handle, Suffix) -> +file_write_file_info(Config) when is_list(Config) -> RootDir = get_good_directory(Config), io:format("RootDir = ~p", [RootDir]), @@ -955,16 +828,16 @@ file_write_file_info(Config, Handle, Suffix) -> Name = filename:join(RootDir, atom_to_list(?MODULE) - ++"_write_file_info_ro"++Suffix), + ++"_write_file_info_ro"), ok = ?PRIM_FILE:write_file(Name, "hello"), Time = {{1997, 01, 02}, {12, 35, 42}}, Info = #file_info{mode=8#400, atime=Time, mtime=Time, ctime=Time}, - ok = ?PRIM_FILE_call(write_file_info, Handle, [Name, Info]), + ok = ?PRIM_FILE:write_file_info(Name, Info), %% Read back the times. {ok, ActualInfo} = - ?PRIM_FILE_call(read_file_info, Handle, [Name]), + ?PRIM_FILE:read_file_info(Name), #file_info{mode=_Mode, atime=ActAtime, mtime=Time, ctime=ActCtime} = ActualInfo, FilteredAtime = filter_atime(Time, Config), @@ -980,14 +853,11 @@ file_write_file_info(Config, Handle, Suffix) -> {error, eacces} = ?PRIM_FILE:write_file(Name, "hello again"), %% Make the file writable again. - - ?PRIM_FILE_call(write_file_info, Handle, - [Name, #file_info{mode=8#600}]), + ?PRIM_FILE:write_file_info(Name, #file_info{mode=8#600}), ok = ?PRIM_FILE:write_file(Name, "hello again"), %% And unwritable. - ?PRIM_FILE_call(write_file_info, Handle, - [Name, #file_info{mode=8#400}]), + ?PRIM_FILE:write_file_info(Name, #file_info{mode=8#400}), {error, eacces} = ?PRIM_FILE:write_file(Name, "hello again"), %% Write the times again. @@ -995,9 +865,9 @@ file_write_file_info(Config, Handle, Suffix) -> NewTime = {{1997, 02, 15}, {13, 18, 20}}, NewInfo = #file_info{atime=NewTime, mtime=NewTime, ctime=NewTime}, - ok = ?PRIM_FILE_call(write_file_info, Handle, [Name, NewInfo]), + ok = ?PRIM_FILE:write_file_info(Name, NewInfo), {ok, ActualInfo2} = - ?PRIM_FILE_call(read_file_info, Handle, [Name]), + ?PRIM_FILE:read_file_info(Name), #file_info{atime=NewActAtime, mtime=NewTime, ctime=NewActCtime} = ActualInfo2, NewFilteredAtime = filter_atime(NewTime, Config), @@ -1012,14 +882,12 @@ file_write_file_info(Config, Handle, Suffix) -> %% Make the file writeable again, so that we can remove the %% test suites ... :-) - ?PRIM_FILE_call(write_file_info, Handle, - [Name, #file_info{mode=8#600}]), + ?PRIM_FILE:write_file_info(Name, #file_info{mode=8#600}), ok. %% Test the write_file_info/3 function. file_write_file_info_opts(Config) when is_list(Config) -> - {ok, Handle} = ?PRIM_FILE:start(), RootDir = get_good_directory(Config), io:format("RootDir = ~p", [RootDir]), @@ -1028,7 +896,7 @@ file_write_file_info_opts(Config) when is_list(Config) -> lists:foreach(fun ({FI, Opts}) -> - ok = ?PRIM_FILE_call(write_file_info, Handle, [Name, FI, Opts]) + ok = ?PRIM_FILE:write_file_info(Name, FI, Opts) end, [ {#file_info{ mode=8#600, atime = Time, mtime = Time, ctime = Time}, Opts} || Opts <- [[{time, posix}]], @@ -1038,7 +906,7 @@ file_write_file_info_opts(Config) when is_list(Config) -> %% REM: determine date range dependent on time_t = Uint32 | Sint32 | Sint64 | Uint64 %% Determine time_t on os:type()? lists:foreach(fun ({FI, Opts}) -> - ok = ?PRIM_FILE_call(write_file_info, Handle, [Name, FI, Opts]) + ok = ?PRIM_FILE:write_file_info(Name, FI, Opts) end, [ {#file_info{ mode=8#400, atime = Time, mtime = Time, ctime = Time}, Opts} || Opts <- [[{time, universal}],[{time, local}]], Time <- [ @@ -1050,11 +918,9 @@ file_write_file_info_opts(Config) when is_list(Config) -> {{2037,2,3},{23,59,59}}, erlang:localtime() ]]), - ok = ?PRIM_FILE:stop(Handle), ok. file_read_file_info_opts(Config) when is_list(Config) -> - {ok, Handle} = ?PRIM_FILE:start(), RootDir = get_good_directory(Config), io:format("RootDir = ~p", [RootDir]), @@ -1063,41 +929,38 @@ file_read_file_info_opts(Config) when is_list(Config) -> lists:foreach(fun (Opts) -> - {ok,_} = ?PRIM_FILE_call(read_file_info, Handle, [Name, Opts]) + {ok,_} = ?PRIM_FILE:read_file_info(Name, Opts) end, [[{time, Type}] || Type <- [local, universal, posix]]), - ok = ?PRIM_FILE:stop(Handle), ok. %% Test the write and read back *_file_info/3 functions. file_write_read_file_info_opts(Config) when is_list(Config) -> - {ok, Handle} = ?PRIM_FILE:start(), RootDir = get_good_directory(Config), io:format("RootDir = ~p", [RootDir]), Name = filename:join(RootDir, atom_to_list(?MODULE) ++"_read_write_file_info_opts"), ok = ?PRIM_FILE:write_file(Name, "hello_opts2"), - ok = file_write_read_file_info_opts(Handle, Name, {{1989, 04, 28}, {19,30,22}}, [{time, local}]), - ok = file_write_read_file_info_opts(Handle, Name, {{1989, 04, 28}, {19,30,22}}, [{time, universal}]), + ok = file_write_read_file_info_opts(Name, {{1989, 04, 28}, {19,30,22}}, [{time, local}]), + ok = file_write_read_file_info_opts(Name, {{1989, 04, 28}, {19,30,22}}, [{time, universal}]), %% will not work on platforms with unsigned time_t - %ok = file_write_read_file_info_opts(Handle, Name, {{1930, 04, 28}, {19,30,22}}, [{time, local}]), - %ok = file_write_read_file_info_opts(Handle, Name, {{1930, 04, 28}, {19,30,22}}, [{time, universal}]), - ok = file_write_read_file_info_opts(Handle, Name, 1, [{time, posix}]), + %ok = file_write_read_file_info_opts(Name, {{1930, 04, 28}, {19,30,22}}, [{time, local}]), + %ok = file_write_read_file_info_opts(Name, {{1930, 04, 28}, {19,30,22}}, [{time, universal}]), + ok = file_write_read_file_info_opts(Name, 1, [{time, posix}]), %% will not work on platforms with unsigned time_t - %ok = file_write_read_file_info_opts(Handle, Name, -1, [{time, posix}]), - %ok = file_write_read_file_info_opts(Handle, Name, -300000, [{time, posix}]), - ok = file_write_read_file_info_opts(Handle, Name, 300000, [{time, posix}]), - ok = file_write_read_file_info_opts(Handle, Name, 0, [{time, posix}]), + %ok = file_write_read_file_info_opts(Name, -1, [{time, posix}]), + %ok = file_write_read_file_info_opts(Name, -300000, [{time, posix}]), + ok = file_write_read_file_info_opts(Name, 300000, [{time, posix}]), + ok = file_write_read_file_info_opts(Name, 0, [{time, posix}]), - ok = ?PRIM_FILE:stop(Handle), ok. -file_write_read_file_info_opts(Handle, Name, Mtime, Opts) -> - {ok, FI} = ?PRIM_FILE_call(read_file_info, Handle, [Name, Opts]), +file_write_read_file_info_opts(Name, Mtime, Opts) -> + {ok, FI} = ?PRIM_FILE:read_file_info(Name, Opts), FI2 = FI#file_info{ mtime = Mtime }, - ok = ?PRIM_FILE_call(write_file_info, Handle, [Name, FI2, Opts]), - {ok, FI3} = ?PRIM_FILE_call(read_file_info, Handle, [Name, Opts]), + ok = ?PRIM_FILE:write_file_info(Name, FI2, Opts), + {ok, FI3} = ?PRIM_FILE:read_file_info(Name, Opts), io:format("Expecting mtime = ~p, got ~p~n", [FI2#file_info.mtime, FI3#file_info.mtime]), FI2 = FI3, ok. @@ -1175,8 +1038,8 @@ advise(Config) when is_list(Config) -> atom_to_list(?MODULE) ++"_advise.fil"), - Line1 = "Hello\n", - Line2 = "World!\n", + Line1 = <<"Hello\n">>, + Line2 = <<"World!\n">>, {ok, Fd} = ?PRIM_FILE:open(Advise, [write]), ok = ?PRIM_FILE:advise(Fd, 0, 0, normal), @@ -1226,7 +1089,7 @@ advise(Config) when is_list(Config) -> {ok, Fd9} = ?PRIM_FILE:open(Advise, [read]), Offset = 0, %% same as a 0 length in some implementations - Length = length(Line1) + length(Line2), + Length = byte_size(Line1) + byte_size(Line2), ok = ?PRIM_FILE:advise(Fd9, Offset, Length, sequential), {ok, Line1} = ?PRIM_FILE:read_line(Fd9), {ok, Line2} = ?PRIM_FILE:read_line(Fd9), @@ -1250,23 +1113,18 @@ do_large_write(Name) -> Chunk = <<0:ChunkSize/unit:8>>, Data = zip_data(lists:duplicate(Chunks, Chunk), Interleave), Size = Chunks * ChunkSize + Chunks, % 4 G + 32 - Wordsize = erlang:system_info(wordsize), - case prim_file:write_file(Name, Data) of - ok when Wordsize =:= 8 -> - {ok,#file_info{size=Size}} = file:read_file_info(Name), - {ok,Fd} = prim_file:open(Name, [read]), - check_large_write(Fd, ChunkSize, 0, Interleave); - {error,einval} when Wordsize =:= 4 -> - ok - end. + ok = ?PRIM_FILE:write_file(Name, Data), + {ok,#file_info{size=Size}} = file:read_file_info(Name), + {ok,Fd} = ?PRIM_FILE:open(Name, [read]), + check_large_write(Fd, ChunkSize, 0, Interleave). check_large_write(Fd, ChunkSize, Pos, [X|Interleave]) -> Pos1 = Pos + ChunkSize, - {ok,Pos1} = prim_file:position(Fd, {cur,ChunkSize}), - {ok,[X]} = prim_file:read(Fd, 1), + {ok,Pos1} = ?PRIM_FILE:position(Fd, {cur,ChunkSize}), + {ok,<<X>>} = ?PRIM_FILE:read(Fd, 1), check_large_write(Fd, ChunkSize, Pos1+1, Interleave); check_large_write(Fd, _, _, []) -> - eof = prim_file:read(Fd, 1), + eof = ?PRIM_FILE:read(Fd, 1), ok. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -1338,71 +1196,53 @@ allocate_and_assert(Fd, Offset, Length) -> %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -delete_a(Config) when is_list(Config) -> - delete(Config, [], "_a"). - -delete_b(Config) when is_list(Config) -> - {ok, Handle} = ?PRIM_FILE:start(), - Result = delete(Config, Handle, "_b"), - ok = ?PRIM_FILE:stop(Handle), - Result. - -delete(Config, Handle, Suffix) -> +delete(Config) when is_list(Config) -> RootDir = proplists:get_value(priv_dir,Config), Name = filename:join(RootDir, atom_to_list(?MODULE) - ++"_delete"++Suffix++".fil"), + ++"_delete.fil"), {ok, Fd1} = ?PRIM_FILE:open(Name, [write]), ?PRIM_FILE:write(Fd1,"ok.\n"), ok = ?PRIM_FILE:close(Fd1), %% Check that the file is readable {ok, Fd2} = ?PRIM_FILE:open(Name, [read]), ok = ?PRIM_FILE:close(Fd2), - ok = ?PRIM_FILE_call(delete, Handle, [Name]), + ok = ?PRIM_FILE:delete(Name), %% Check that the file is not readable anymore {error, _} = ?PRIM_FILE:open(Name, [read]), %% Try deleting a nonexistent file - {error, enoent} = ?PRIM_FILE_call(delete, Handle, [Name]), + {error, enoent} = ?PRIM_FILE:delete(Name), ok. -rename_a(Config) when is_list(Config) -> - rename(Config, [], "_a"). - -rename_b(Config) when is_list(Config) -> - {ok, Handle} = ?PRIM_FILE:start(), - Result = rename(Config, Handle, "_b"), - ok = ?PRIM_FILE:stop(Handle), - Result. - -rename(Config, Handle, Suffix) -> +rename(Config) when is_list(Config) -> RootDir = proplists:get_value(priv_dir,Config), - FileName1 = atom_to_list(?MODULE)++"_rename"++Suffix++".fil", - FileName2 = atom_to_list(?MODULE)++"_rename"++Suffix++".ful", + FileName1 = atom_to_list(?MODULE)++"_rename.fil", + FileName2 = atom_to_list(?MODULE)++"_rename.ful", Name1 = filename:join(RootDir, FileName1), Name2 = filename:join(RootDir, FileName2), {ok,Fd1} = ?PRIM_FILE:open(Name1, [write]), ok = ?PRIM_FILE:close(Fd1), %% Rename, and check that it really changed name - ok = ?PRIM_FILE_call(rename, Handle, [Name1, Name2]), + ok = ?PRIM_FILE:rename(Name1, Name2), {error, _} = ?PRIM_FILE:open(Name1, [read]), {ok, Fd2} = ?PRIM_FILE:open(Name2, [read]), ok = ?PRIM_FILE:close(Fd2), %% Try renaming something to itself - ok = ?PRIM_FILE_call(rename, Handle, [Name2, Name2]), + ok = ?PRIM_FILE:rename(Name2, Name2), %% Try renaming something that doesn't exist {error, enoent} = - ?PRIM_FILE_call(rename, Handle, [Name1, Name2]), + ?PRIM_FILE:rename(Name1, Name2), %% Try renaming to something else than a string {error, badarg} = - ?PRIM_FILE_call(rename, Handle, [Name1, foobar]), + ?PRIM_FILE:rename(Name1, foobar), %% Move between directories DirName1 = filename:join(RootDir, atom_to_list(?MODULE) - ++"_rename_dir"++Suffix), + ++"_rename_dir"), DirName2 = filename:join(RootDir, atom_to_list(?MODULE) - ++"_second_rename_dir"++Suffix), + ++"_second_rename_dir"), Name1foo = filename:join(DirName1, "foo.fil"), Name2foo = filename:join(DirName2, "foo.fil"), Name2bar = filename:join(DirName2, "bar.dir"), @@ -1410,21 +1250,21 @@ rename(Config, Handle, Suffix) -> %% The name has to include the full file name, path is not enough expect( {error, eexist}, {error, eisdir}, - ?PRIM_FILE_call(rename, Handle, [Name2, DirName1])), + ?PRIM_FILE:rename(Name2, DirName1)), ok = - ?PRIM_FILE_call(rename, Handle, [Name2, Name1foo]), + ?PRIM_FILE:rename(Name2, Name1foo), %% Now rename the directory - ok = ?PRIM_FILE_call(rename, Handle, [DirName1, DirName2]), + ok = ?PRIM_FILE:rename(DirName1, DirName2), %% And check that the file is there now {ok,Fd3} = ?PRIM_FILE:open(Name2foo, [read]), ok = ?PRIM_FILE:close(Fd3), %% Try some dirty things now: move the directory into itself {error, Msg1} = - ?PRIM_FILE_call(rename, Handle, [DirName2, Name2bar]), + ?PRIM_FILE:rename(DirName2, Name2bar), io:format("Errmsg1: ~p",[Msg1]), %% move dir into a file in itself {error, Msg2} = - ?PRIM_FILE_call(rename, Handle, [DirName2, Name2foo]), + ?PRIM_FILE:rename(DirName2, Name2foo), io:format("Errmsg2: ~p",[Msg2]), ok. @@ -1466,7 +1306,7 @@ e_delete(Config) when is_list(Config) -> Base, #file_info {mode=0}), {error, eacces} = ?PRIM_FILE:delete(Afile), ?PRIM_FILE:write_file_info( - Base, #file_info {mode=8#600}) + Base, #file_info {mode=8#700}) end, ok. @@ -1602,7 +1442,7 @@ e_make_dir(Config) when is_list(Config) -> ?PRIM_FILE:write_file_info(Base, #file_info {mode=0}), {error, eacces} = ?PRIM_FILE:make_dir(filename:join(Base, "xxxx")), - ?PRIM_FILE:write_file_info(Base, #file_info {mode=8#600}) + ?PRIM_FILE:write_file_info(Base, #file_info {mode=8#700}) end, ok. @@ -1652,170 +1492,24 @@ e_del_dir(Config) when is_list(Config) -> ?PRIM_FILE:write_file_info(Base, #file_info {mode=0}), {error, eacces} = ?PRIM_FILE:del_dir(ADirectory), ?PRIM_FILE:write_file_info( - Base, #file_info {mode=8#600}) + Base, #file_info {mode=8#700}) end, ok. -%% Trying reading and positioning from a compressed file. - -read_compressed(Config) when is_list(Config) -> - Data = proplists:get_value(data_dir, Config), - Real = filename:join(Data, "realmen.html.gz"), - {ok, Fd} = ?PRIM_FILE:open(Real, [read, compressed]), - try_read_file(Fd). - -%% Trying reading and positioning from an uncompressed file, -%% but with the compressed flag given. - -read_not_really_compressed(Config) when is_list(Config) -> - Data = proplists:get_value(data_dir, Config), - Priv = proplists:get_value(priv_dir, Config), - - %% The file realmen.html might have got CRs added (by WinZip). - %% Remove them, or the file positions will not be correct. - - Real = filename:join(Data, "realmen.html"), - RealPriv = filename:join(Priv, - atom_to_list(?MODULE)++"_realmen.html"), - {ok, RealDataBin} = ?PRIM_FILE:read_file(Real), - RealData = remove_crs(binary_to_list(RealDataBin), []), - ok = ?PRIM_FILE:write_file(RealPriv, RealData), - {ok, Fd} = ?PRIM_FILE:open(RealPriv, [read, compressed]), - try_read_file(Fd). - -remove_crs([$\r|Rest], Result) -> - remove_crs(Rest, Result); -remove_crs([C|Rest], Result) -> - remove_crs(Rest, [C|Result]); -remove_crs([], Result) -> - lists:reverse(Result). - -try_read_file(Fd) -> - %% Seek to the current position (nothing should happen). - - {ok, 0} = ?PRIM_FILE:position(Fd, 0), - {ok, 0} = ?PRIM_FILE:position(Fd, {cur, 0}), - - %% Read a few lines from a compressed file. - - ShouldBe = "<TITLE>Real Programmers Don't Use PASCAL</TITLE>\n", - {ok, ShouldBe} = ?PRIM_FILE:read(Fd, length(ShouldBe)), - - %% Now seek forward. - - {ok, 381} = ?PRIM_FILE:position(Fd, 381), - Back = "Back in the good old days -- the \"Golden Era\" " ++ - "of computers, it was\n", - {ok, Back} = ?PRIM_FILE:read(Fd, length(Back)), - - %% Try to search forward relative to the current position. - - {ok, CurPos} = ?PRIM_FILE:position(Fd, {cur, 0}), - RealPos = 4273, - {ok, RealPos} = ?PRIM_FILE:position(Fd, {cur, RealPos-CurPos}), - RealProg = "<LI> Real Programmers aren't afraid to use GOTOs.\n", - {ok, RealProg} = ?PRIM_FILE:read(Fd, length(RealProg)), - - %% Seek backward. - - AfterTitle = length("<TITLE>"), - {ok, AfterTitle} = ?PRIM_FILE:position(Fd, AfterTitle), - Title = "Real Programmers Don't Use PASCAL</TITLE>\n", - {ok, Title} = ?PRIM_FILE:read(Fd, length(Title)), - - %% Done. - - ?PRIM_FILE:close(Fd), - ok. - -write_compressed(Config) when is_list(Config) -> - Priv = proplists:get_value(priv_dir, Config), - MyFile = filename:join(Priv, - atom_to_list(?MODULE)++"_test.gz"), - - %% Write a file. - - {ok, Fd} = ?PRIM_FILE:open(MyFile, [write, compressed]), - {ok, 0} = ?PRIM_FILE:position(Fd, 0), - Prefix = "hello\n", - End = "end\n", - ok = ?PRIM_FILE:write(Fd, Prefix), - {ok, 143} = ?PRIM_FILE:position(Fd, 143), - ok = ?PRIM_FILE:write(Fd, End), - ok = ?PRIM_FILE:close(Fd), - - %% Read the file and verify the contents. - - {ok, Fd1} = ?PRIM_FILE:open(MyFile, [read, compressed]), - {ok, Prefix} = ?PRIM_FILE:read(Fd1, length(Prefix)), - Second = lists:duplicate(143-length(Prefix), 0) ++ End, - {ok, Second} = ?PRIM_FILE:read(Fd1, length(Second)), - ok = ?PRIM_FILE:close(Fd1), - - %% Ensure that the file is compressed. - - TotalSize = 143 + length(End), - case ?PRIM_FILE:read_file_info(MyFile) of - {ok, #file_info{size=Size}} when Size < TotalSize -> - ok; - {ok, #file_info{size=Size}} when Size == TotalSize -> - ct:fail(file_not_compressed) - end, - - %% Write again to ensure that the file is truncated. - - {ok, Fd2} = ?PRIM_FILE:open(MyFile, [write, compressed]), - NewString = "aaaaaaaaaaa", - ok = ?PRIM_FILE:write(Fd2, NewString), - ok = ?PRIM_FILE:close(Fd2), - {ok, Fd3} = ?PRIM_FILE:open(MyFile, [read, compressed]), - {ok, NewString} = ?PRIM_FILE:read(Fd3, 1024), - ok = ?PRIM_FILE:close(Fd3), - - ok. - -compress_errors(Config) when is_list(Config) -> - Data = proplists:get_value(data_dir, Config), - {error, enoent} = ?PRIM_FILE:open("non_existing__", - [compressed, read]), - {error, einval} = ?PRIM_FILE:open("non_existing__", - [compressed, read, write]), - - %% Read a corrupted .gz file. - - Corrupted = filename:join(Data, "corrupted.gz"), - {ok, Fd} = ?PRIM_FILE:open(Corrupted, [read, compressed]), - {error, eio} = ?PRIM_FILE:read(Fd, 100), - ?PRIM_FILE:close(Fd), - - ok. - - -%% Test creating a hard link. -make_link_a(Config) when is_list(Config) -> - make_link(Config, [], "_a"). - -%% Test creating a hard link. -make_link_b(Config) when is_list(Config) -> - {ok, Handle} = ?PRIM_FILE:start(), - Result = make_link(Config, Handle, "_b"), - ok = ?PRIM_FILE:stop(Handle), - Result. - -make_link(Config, Handle, Suffix) -> +make_link(Config) when is_list(Config) -> RootDir = proplists:get_value(priv_dir, Config), NewDir = filename:join(RootDir, atom_to_list(?MODULE) - ++"_make_link"++Suffix), - ok = ?PRIM_FILE_call(make_dir, Handle, [NewDir]), + ++"_make_link"), + ok = ?PRIM_FILE:make_dir(NewDir), Name = filename:join(NewDir, "a_file"), ok = ?PRIM_FILE:write_file(Name, "some contents\n"), Alias = filename:join(NewDir, "an_alias"), Result = - case ?PRIM_FILE_call(make_link, Handle, [Name, Alias]) of + case ?PRIM_FILE:make_link(Name, Alias) of {error, enotsup} -> {skipped, "Links not supported on this platform"}; ok -> @@ -1826,12 +1520,12 @@ make_link(Config, Handle, Suffix) -> %% since they are not used on symbolic links. {ok, Info} = - ?PRIM_FILE_call(read_link_info, Handle, [Name]), + ?PRIM_FILE:read_link_info(Name), {ok, Info} = - ?PRIM_FILE_call(read_link_info, Handle, [Alias]), + ?PRIM_FILE:read_link_info(Alias), #file_info{links = 2, type = regular} = Info, {error, eexist} = - ?PRIM_FILE_call(make_link, Handle, [Name, Alias]), + ?PRIM_FILE:make_link(Name, Alias), ok end, @@ -1843,30 +1537,19 @@ read_link_info_for_non_link(Config) when is_list(Config) -> {ok, #file_info{type=directory}} = ?PRIM_FILE:read_link_info("."), ok. -%% Test operations on symbolic links (for Unix). -symlinks_a(Config) when is_list(Config) -> - symlinks(Config, [], "_a"). - -%% Test operations on symbolic links (for Unix). -symlinks_b(Config) when is_list(Config) -> - {ok, Handle} = ?PRIM_FILE:start(), - Result = symlinks(Config, Handle, "_b"), - ok = ?PRIM_FILE:stop(Handle), - Result. - -symlinks(Config, Handle, Suffix) -> +symlinks(Config) when is_list(Config) -> RootDir = proplists:get_value(priv_dir, Config), NewDir = filename:join(RootDir, atom_to_list(?MODULE) - ++"_make_symlink"++Suffix), - ok = ?PRIM_FILE_call(make_dir, Handle, [NewDir]), + ++"_make_symlink"), + ok = ?PRIM_FILE:make_dir(NewDir), Name = filename:join(NewDir, "a_plain_file"), ok = ?PRIM_FILE:write_file(Name, "some stupid content\n"), Alias = filename:join(NewDir, "a_symlink_alias"), Result = - case ?PRIM_FILE_call(make_symlink, Handle, [Name, Alias]) of + case ?PRIM_FILE:make_symlink(Name, Alias) of {error, enotsup} -> {skipped, "Links not supported on this platform"}; {error, eperm} -> @@ -1874,20 +1557,20 @@ symlinks(Config, Handle, Suffix) -> {skipped, "Windows user not privileged to create links"}; ok -> {ok, Info1} = - ?PRIM_FILE_call(read_file_info, Handle, [Name]), + ?PRIM_FILE:read_file_info(Name), {ok, Info1} = - ?PRIM_FILE_call(read_file_info, Handle, [Alias]), + ?PRIM_FILE:read_file_info(Alias), {ok, Info1} = - ?PRIM_FILE_call(read_link_info, Handle, [Name]), + ?PRIM_FILE:read_link_info(Name), #file_info{links = 1, type = regular} = Info1, {ok, Info2} = - ?PRIM_FILE_call(read_link_info, Handle, [Alias]), + ?PRIM_FILE:read_link_info(Alias), #file_info{links=1, type=symlink} = Info2, {ok, Name} = - ?PRIM_FILE_call(read_link, Handle, [Alias]), + ?PRIM_FILE:read_link(Alias), {ok, Name} = - ?PRIM_FILE_call(read_link_all, Handle, [Alias]), + ?PRIM_FILE:read_link_all(Alias), %% If all is good, delete dir again (avoid hanging dir on windows) rm_rf(?PRIM_FILE,NewDir), ok @@ -1907,10 +1590,9 @@ list_dir_limit(Config) when is_list(Config) -> RootDir = proplists:get_value(priv_dir, Config), NewDir = filename:join(RootDir, atom_to_list(?MODULE)++"_list_dir_limit"), - {ok, Handle1} = ?PRIM_FILE:start(), - ok = ?PRIM_FILE_call(make_dir, Handle1, [NewDir]), + ok = ?PRIM_FILE:make_dir(NewDir), Ref = erlang:start_timer(MaxTime*1000, self(), []), - Result = list_dir_limit_loop(NewDir, Handle1, Ref, MaxNumber, 0), + Result = list_dir_limit_loop(NewDir, Ref, MaxNumber, 0), Time = case erlang:cancel_timer(Ref) of false -> MaxTime; T -> MaxTime - (T div 1000) @@ -1920,21 +1602,18 @@ list_dir_limit(Config) when is_list(Config) -> {error, _Reason, N} -> N; _ -> 0 end, - {ok, Handle2} = ?PRIM_FILE:start(), - list_dir_limit_cleanup(NewDir, Handle2, Number, 0), - ok = ?PRIM_FILE:stop(Handle1), - ok = ?PRIM_FILE:stop(Handle2), + list_dir_limit_cleanup(NewDir, Number, 0), {ok, Number} = Result, {comment, "Created " ++ integer_to_list(Number) ++ " files in " ++ integer_to_list(Time) ++ " seconds."}. -list_dir_limit_loop(Dir, Handle, _Ref, N, Cnt) when Cnt >= N -> - list_dir_check(Dir, Handle, Cnt); -list_dir_limit_loop(Dir, Handle, Ref, N, Cnt) -> +list_dir_limit_loop(Dir, _Ref, N, Cnt) when Cnt >= N -> + list_dir_check(Dir, Cnt); +list_dir_limit_loop(Dir, Ref, N, Cnt) -> receive {timeout, Ref, []} -> - list_dir_check(Dir, Handle, Cnt) + list_dir_check(Dir, Cnt) after 0 -> Name = integer_to_list(Cnt), case ?PRIM_FILE:write_file(filename:join(Dir, Name), Name) of @@ -1942,23 +1621,23 @@ list_dir_limit_loop(Dir, Handle, Ref, N, Cnt) -> Next = Cnt + 1, case Cnt rem 100 of 0 -> - case list_dir_check(Dir, Handle, Next) of + case list_dir_check(Dir, Next) of {ok, Next} -> list_dir_limit_loop( - Dir, Handle, Ref, N, Next); + Dir, Ref, N, Next); Other -> Other end; _ -> - list_dir_limit_loop(Dir, Handle, Ref, N, Next) + list_dir_limit_loop(Dir, Ref, N, Next) end; {error, Reason} -> {error, Reason, Cnt} end end. -list_dir_check(Dir, Handle, Cnt) -> - case ?PRIM_FILE:list_dir(Handle, Dir) of +list_dir_check(Dir, Cnt) -> + case ?PRIM_FILE:list_dir(Dir) of {ok, ListDir} -> case length(ListDir) of Cnt -> @@ -1975,18 +1654,18 @@ list_dir_check(Dir, Handle, Cnt) -> %% Deletes N files while ignoring errors, then continues deleting %% as long as they exist. -list_dir_limit_cleanup(Dir, Handle, N, Cnt) when Cnt >= N -> +list_dir_limit_cleanup(Dir, N, Cnt) when Cnt >= N -> Name = integer_to_list(Cnt), - case ?PRIM_FILE:delete(Handle, filename:join(Dir, Name)) of + case ?PRIM_FILE:delete(filename:join(Dir, Name)) of ok -> - list_dir_limit_cleanup(Dir, Handle, N, Cnt+1); + list_dir_limit_cleanup(Dir, N, Cnt+1); _ -> ok end; -list_dir_limit_cleanup(Dir, Handle, N, Cnt) -> +list_dir_limit_cleanup(Dir, N, Cnt) -> Name = integer_to_list(Cnt), - ?PRIM_FILE:delete(Handle, filename:join(Dir, Name)), - list_dir_limit_cleanup(Dir, Handle, N, Cnt+1). + ?PRIM_FILE:delete(filename:join(Dir, Name)), + list_dir_limit_cleanup(Dir, N, Cnt+1). %%% %%% Test list_dir() on a non-existing pathname. @@ -1995,7 +1674,7 @@ list_dir_limit_cleanup(Dir, Handle, N, Cnt) -> list_dir_error(Config) -> Priv = proplists:get_value(priv_dir, Config), NonExisting = filename:join(Priv, "non-existing-dir"), - {error,enoent} = prim_file:list_dir(NonExisting), + {error,enoent} = ?PRIM_FILE:list_dir(NonExisting), ok. %%% @@ -2063,7 +1742,7 @@ do_run_large_file_test(Config, Run, Name0) -> {'DOWN',Mref,_,_,_} -> ok; {Tester,done} -> ok end, - prim_file:delete(Name) + ?PRIM_FILE:delete(Name) end), %% Run the test case. diff --git a/lib/kernel/test/sendfile_SUITE.erl b/lib/kernel/test/sendfile_SUITE.erl index bfa564c32c..0c0b1cbcb6 100644 --- a/lib/kernel/test/sendfile_SUITE.erl +++ b/lib/kernel/test/sendfile_SUITE.erl @@ -23,30 +23,41 @@ -include_lib("common_test/include/ct.hrl"). -include_lib("kernel/include/file.hrl"). --compile(export_all). - -all() -> [{group,async_threads}, - {group,no_async_threads}]. - -groups() -> - [{async_threads,[],tcs()}, - {no_async_threads,[],tcs()}]. - -tcs() -> - [t_sendfile_small - ,t_sendfile_big_all - ,t_sendfile_big_size - ,t_sendfile_many_small - ,t_sendfile_partial - ,t_sendfile_offset - ,t_sendfile_sendafter - ,t_sendfile_recvafter - ,t_sendfile_recvafter_remoteclose - ,t_sendfile_sendduring - ,t_sendfile_recvduring - ,t_sendfile_closeduring - ,t_sendfile_crashduring - ]. +-export([all/0, init_per_suite/1, end_per_suite/1, init_per_testcase/2]). + +-export([sendfile_server/2, sendfile_do_recv/2, init/1, handle_event/2]). + +-export( + [t_sendfile_small/1, + t_sendfile_big_all/1, + t_sendfile_big_size/1, + t_sendfile_many_small/1, + t_sendfile_partial/1, + t_sendfile_offset/1, + t_sendfile_sendafter/1, + t_sendfile_recvafter/1, + t_sendfile_recvafter_remoteclose/1, + t_sendfile_sendduring/1, + t_sendfile_recvduring/1, + t_sendfile_closeduring/1, + t_sendfile_crashduring/1, + t_sendfile_arguments/1]). + +all() -> + [t_sendfile_small, + t_sendfile_big_all, + t_sendfile_big_size, + t_sendfile_many_small, + t_sendfile_partial, + t_sendfile_offset, + t_sendfile_sendafter, + t_sendfile_recvafter, + t_sendfile_recvafter_remoteclose, + t_sendfile_sendduring, + t_sendfile_recvduring, + t_sendfile_closeduring, + t_sendfile_crashduring, + t_sendfile_arguments]. init_per_suite(Config) -> case {os:type(),os:version()} of @@ -72,28 +83,18 @@ init_per_suite(Config) -> end_per_suite(Config) -> file:delete(proplists:get_value(big_file, Config)). -init_per_group(async_threads,Config) -> - case erlang:system_info(thread_pool_size) of - 0 -> - {skip,"No async threads"}; - _ -> - [{sendfile_opts,[{use_threads,true}]}|Config] - end; -init_per_group(no_async_threads,Config) -> - [{sendfile_opts,[{use_threads,false}]}|Config]. - -end_per_group(_,_Config) -> - ok. - init_per_testcase(TC,Config) when TC == t_sendfile_recvduring; TC == t_sendfile_sendduring -> Filename = proplists:get_value(small_file, Config), Send = fun(Sock) -> {_Size, Data} = sendfile_file_info(Filename), - {ok,D} = file:open(Filename, [raw,binary,read]), - prim_file:sendfile(D, Sock, 0, 0, 0, - [],[],[]), + {ok,Fd} = file:open(Filename, [raw,binary,read]), + %% Determine whether the driver has native support by + %% hitting the raw module directly; file:sendfile/5 will + %% land in the fallback if it doesn't. + RawModule = Fd#file_descriptor.module, + {ok, _Ignored} = RawModule:sendfile(Fd,Sock,0,0,0,[],[],[]), Data end, @@ -105,9 +106,8 @@ init_per_testcase(TC,Config) when TC == t_sendfile_recvduring; ct:log("Error: ~p",[Error]), {skip,"Not supported"} end; -init_per_testcase(_Tc,Config) -> - Config ++ [{sendfile_opts,[{use_threads,false}]}]. - +init_per_testcase(_TC,Config) -> + Config. t_sendfile_small(Config) when is_list(Config) -> Filename = proplists:get_value(small_file, Config), @@ -124,7 +124,7 @@ t_sendfile_small(Config) when is_list(Config) -> t_sendfile_many_small(Config) when is_list(Config) -> Filename = proplists:get_value(small_file, Config), FileOpts = proplists:get_value(file_opts, Config, []), - SendfileOpts = proplists:get_value(sendfile_opts, Config), + SendfileOpts = proplists:get_value(sendfile_opts, Config, []), error_logger:add_report_handler(?MODULE,[self()]), @@ -151,7 +151,7 @@ t_sendfile_many_small(Config) when is_list(Config) -> t_sendfile_big_all(Config) when is_list(Config) -> Filename = proplists:get_value(big_file, Config), - SendfileOpts = proplists:get_value(sendfile_opts, Config), + SendfileOpts = proplists:get_value(sendfile_opts, Config, []), Send = fun(Sock) -> {ok, #file_info{size = Size}} = @@ -165,7 +165,7 @@ t_sendfile_big_all(Config) when is_list(Config) -> t_sendfile_big_size(Config) -> Filename = proplists:get_value(big_file, Config), FileOpts = proplists:get_value(file_opts, Config, []), - SendfileOpts = proplists:get_value(sendfile_opts, Config), + SendfileOpts = proplists:get_value(sendfile_opts, Config, []), SendAll = fun(Sock) -> {ok, #file_info{size = Size}} = @@ -180,7 +180,7 @@ t_sendfile_big_size(Config) -> t_sendfile_partial(Config) -> Filename = proplists:get_value(small_file, Config), FileOpts = proplists:get_value(file_opts, Config, []), - SendfileOpts = proplists:get_value(sendfile_opts, Config), + SendfileOpts = proplists:get_value(sendfile_opts, Config, []), SendSingle = fun(Sock) -> {_Size, <<Data:5/binary,_/binary>>} = @@ -217,7 +217,7 @@ t_sendfile_partial(Config) -> t_sendfile_offset(Config) -> Filename = proplists:get_value(small_file, Config), FileOpts = proplists:get_value(file_opts, Config, []), - SendfileOpts = proplists:get_value(sendfile_opts, Config), + SendfileOpts = proplists:get_value(sendfile_opts, Config, []), Send = fun(Sock) -> {_Size, <<_:5/binary,Data:3/binary,_/binary>> = AllData} = @@ -233,7 +233,7 @@ t_sendfile_offset(Config) -> t_sendfile_sendafter(Config) -> Filename = proplists:get_value(small_file, Config), - SendfileOpts = proplists:get_value(sendfile_opts, Config), + SendfileOpts = proplists:get_value(sendfile_opts, Config, []), Send = fun(Sock) -> {Size, Data} = sendfile_file_info(Filename), @@ -246,7 +246,7 @@ t_sendfile_sendafter(Config) -> t_sendfile_recvafter(Config) -> Filename = proplists:get_value(small_file, Config), - SendfileOpts = proplists:get_value(sendfile_opts, Config), + SendfileOpts = proplists:get_value(sendfile_opts, Config, []), Send = fun(Sock) -> {Size, Data} = sendfile_file_info(Filename), @@ -279,7 +279,7 @@ t_sendfile_recvafter_remoteclose(Config) -> t_sendfile_sendduring(Config) -> Filename = proplists:get_value(big_file, Config), - SendfileOpts = proplists:get_value(sendfile_opts, Config), + SendfileOpts = proplists:get_value(sendfile_opts, Config, []), Send = fun(Sock) -> {ok, #file_info{size = Size}} = @@ -296,7 +296,7 @@ t_sendfile_sendduring(Config) -> t_sendfile_recvduring(Config) -> Filename = proplists:get_value(big_file, Config), - SendfileOpts = proplists:get_value(sendfile_opts, Config), + SendfileOpts = proplists:get_value(sendfile_opts, Config, []), Send = fun(Sock) -> {ok, #file_info{size = Size}} = @@ -315,7 +315,7 @@ t_sendfile_recvduring(Config) -> t_sendfile_closeduring(Config) -> Filename = proplists:get_value(big_file, Config), - SendfileOpts = proplists:get_value(sendfile_opts, Config), + SendfileOpts = proplists:get_value(sendfile_opts, Config, []), Send = fun(Sock,SFServPid) -> spawn_link(fun() -> @@ -345,7 +345,7 @@ t_sendfile_closeduring(Config) -> t_sendfile_crashduring(Config) -> Filename = proplists:get_value(big_file, Config), - SendfileOpts = proplists:get_value(sendfile_opts, Config), + SendfileOpts = proplists:get_value(sendfile_opts, Config, []), error_logger:add_report_handler(?MODULE,[self()]), @@ -373,6 +373,36 @@ t_sendfile_crashduring(Config) -> end end. +t_sendfile_arguments(Config) -> + Filename = proplists:get_value(small_file, Config), + + {ok, Listener} = gen_tcp:listen(0, + [{packet, 0}, {active, false}, {reuseaddr, true}]), + {ok, Port} = inet:port(Listener), + + ErrorCheck = + fun(Reason, Offset, Length, Opts) -> + {ok, Sender} = gen_tcp:connect({127, 0, 0, 1}, Port, + [{packet, 0}, {active, false}]), + {ok, Receiver} = gen_tcp:accept(Listener), + {ok, Fd} = file:open(Filename, [read, raw]), + {error, Reason} = file:sendfile(Fd, Sender, Offset, Length, Opts), + gen_tcp:close(Receiver), + gen_tcp:close(Sender), + file:close(Fd) + end, + + ErrorCheck(einval, -1, 0, []), + ErrorCheck(einval, 0, -1, []), + ErrorCheck(badarg, gurka, 0, []), + ErrorCheck(badarg, 0, gurka, []), + ErrorCheck(badarg, 0, 0, gurka), + ErrorCheck(badarg, 0, 0, [{chunk_size, gurka}]), + + gen_tcp:close(Listener), + + ok. + %% Generic sendfile server code sendfile_send(Send) -> sendfile_send({127,0,0,1},Send). diff --git a/lib/kernel/test/seq_trace_SUITE.erl b/lib/kernel/test/seq_trace_SUITE.erl index be23a1933f..aae8a83304 100644 --- a/lib/kernel/test/seq_trace_SUITE.erl +++ b/lib/kernel/test/seq_trace_SUITE.erl @@ -25,7 +25,7 @@ -export([token_set_get/1, tracer_set_get/1, print/1, send/1, distributed_send/1, recv/1, distributed_recv/1, trace_exit/1, distributed_exit/1, call/1, port/1, - match_set_seq_token/1, gc_seq_token/1]). + match_set_seq_token/1, gc_seq_token/1, label_capability_mismatch/1]). %% internal exports -export([simple_tracer/2, one_time_receiver/0, one_time_receiver/1, @@ -47,7 +47,7 @@ all() -> [token_set_get, tracer_set_get, print, send, distributed_send, recv, distributed_recv, trace_exit, distributed_exit, call, port, match_set_seq_token, - gc_seq_token]. + gc_seq_token, label_capability_mismatch]. groups() -> []. @@ -90,8 +90,8 @@ do_token_set_get(TsType) -> %% Test that initial seq_trace is disabled [] = seq_trace:get_token(), %% Test setting and reading the different fields - 0 = seq_trace:set_token(label,17), - {label,17} = seq_trace:get_token(label), + 0 = seq_trace:set_token(label,{my_label,1}), + {label,{my_label,1}} = seq_trace:get_token(label), false = seq_trace:set_token(print,true), {print,true} = seq_trace:get_token(print), false = seq_trace:set_token(send,true), @@ -101,12 +101,12 @@ do_token_set_get(TsType) -> false = seq_trace:set_token(TsType,true), {TsType,true} = seq_trace:get_token(TsType), %% Check the whole token - {Flags,17,0,Self,0} = seq_trace:get_token(), % all flags are set + {Flags,{my_label,1},0,Self,0} = seq_trace:get_token(), % all flags are set %% Test setting and reading the 'serial' field {0,0} = seq_trace:set_token(serial,{3,5}), {serial,{3,5}} = seq_trace:get_token(serial), %% Check the whole token, test that a whole token can be set and get - {Flags,17,5,Self,3} = seq_trace:get_token(), + {Flags,{my_label,1},5,Self,3} = seq_trace:get_token(), seq_trace:set_token({Flags,19,7,Self,5}), {Flags,19,7,Self,5} = seq_trace:get_token(), %% Check that receive timeout does not reset token @@ -166,11 +166,13 @@ do_send(TsType) -> seq_trace:reset_trace(), start_tracer(), Receiver = spawn(?MODULE,one_time_receiver,[]), + Label = make_ref(), + seq_trace:set_token(label,Label), set_token_flags([send, TsType]), Receiver ! send, Self = self(), seq_trace:reset_trace(), - [{0,{send,_,Self,Receiver,send}, Ts}] = stop_tracer(1), + [{Label,{send,_,Self,Receiver,send}, Ts}] = stop_tracer(1), check_ts(TsType, Ts). distributed_send(Config) when is_list(Config) -> @@ -184,14 +186,19 @@ do_distributed_send(TsType) -> seq_trace:reset_trace(), start_tracer(), Receiver = spawn(Node,?MODULE,one_time_receiver,[]), + + %% Make sure complex labels survive the trip. + Label = make_ref(), + seq_trace:set_token(label,Label), set_token_flags([send,TsType]), + Receiver ! send, Self = self(), seq_trace:reset_trace(), stop_node(Node), - [{0,{send,_,Self,Receiver,send}, Ts}] = stop_tracer(1), + [{Label,{send,_,Self,Receiver,send}, Ts}] = stop_tracer(1), check_ts(TsType, Ts). - + recv(Config) when is_list(Config) -> lists:foreach(fun do_recv/1, ?TIMESTAMP_MODES). @@ -220,7 +227,12 @@ do_distributed_recv(TsType) -> seq_trace:reset_trace(), rpc:call(Node,?MODULE,start_tracer,[]), Receiver = spawn(Node,?MODULE,one_time_receiver,[]), + + %% Make sure complex labels survive the trip. + Label = make_ref(), + seq_trace:set_token(label,Label), set_token_flags(['receive',TsType]), + Receiver ! 'receive', %% let the other process receive the message: receive after 1 -> ok end, @@ -229,7 +241,7 @@ do_distributed_recv(TsType) -> Result = rpc:call(Node,?MODULE,stop_tracer,[1]), stop_node(Node), ok = io:format("~p~n",[Result]), - [{0,{'receive',_,Self,Receiver,'receive'}, Ts}] = Result, + [{Label,{'receive',_,Self,Receiver,'receive'}, Ts}] = Result, check_ts(TsType, Ts). trace_exit(Config) when is_list(Config) -> @@ -240,7 +252,12 @@ do_trace_exit(TsType) -> start_tracer(), Receiver = spawn_link(?MODULE, one_time_receiver, [exit]), process_flag(trap_exit, true), + + %% Make sure complex labels survive the trip. + Label = make_ref(), + seq_trace:set_token(label,Label), set_token_flags([send, TsType]), + Receiver ! {before, exit}, %% let the other process receive the message: receive @@ -254,8 +271,8 @@ do_trace_exit(TsType) -> Result = stop_tracer(2), seq_trace:reset_trace(), ok = io:format("~p~n", [Result]), - [{0, {send, {0,1}, Self, Receiver, {before, exit}}, Ts0}, - {0, {send, {1,2}, Receiver, Self, + [{Label, {send, {0,1}, Self, Receiver, {before, exit}}, Ts0}, + {Label, {send, {1,2}, Receiver, Self, {'EXIT', Receiver, {exit, {before, exit}}}}, Ts1}] = Result, check_ts(TsType, Ts0), check_ts(TsType, Ts1). @@ -291,6 +308,74 @@ do_distributed_exit(TsType) -> {'EXIT', Receiver, {exit, {before, exit}}}}, Ts}] = Result, check_ts(TsType, Ts). +label_capability_mismatch(Config) when is_list(Config) -> + Releases = ["20_latest"], + Available = [Rel || Rel <- Releases, test_server:is_release_available(Rel)], + case Available of + [] -> {skipped, "No incompatible releases available"}; + _ -> + lists:foreach(fun do_incompatible_labels/1, Available), + lists:foreach(fun do_compatible_labels/1, Available), + ok + end. + +do_incompatible_labels(Rel) -> + Cookie = atom_to_list(erlang:get_cookie()), + {ok, Node} = test_server:start_node( + list_to_atom(atom_to_list(?MODULE)++"_"++Rel), peer, + [{args, " -setcookie "++Cookie}, {erl, [{release, Rel}]}]), + + {_,Dir} = code:is_loaded(?MODULE), + Mdir = filename:dirname(Dir), + true = rpc:call(Node,code,add_patha,[Mdir]), + seq_trace:reset_trace(), + rpc:call(Node,?MODULE,start_tracer,[]), + Receiver = spawn(Node,?MODULE,one_time_receiver,[]), + + %% This node does not support arbitrary labels, so it must fail with a + %% timeout as the token is dropped silently. + seq_trace:set_token(label,make_ref()), + seq_trace:set_token('receive',true), + + Receiver ! 'receive', + %% let the other process receive the message: + receive after 10 -> ok end, + seq_trace:reset_trace(), + + {error,timeout} = rpc:call(Node,?MODULE,stop_tracer,[1]), + stop_node(Node), + ok. + +do_compatible_labels(Rel) -> + Cookie = atom_to_list(erlang:get_cookie()), + {ok, Node} = test_server:start_node( + list_to_atom(atom_to_list(?MODULE)++"_"++Rel), peer, + [{args, " -setcookie "++Cookie}, {erl, [{release, Rel}]}]), + + {_,Dir} = code:is_loaded(?MODULE), + Mdir = filename:dirname(Dir), + true = rpc:call(Node,code,add_patha,[Mdir]), + seq_trace:reset_trace(), + rpc:call(Node,?MODULE,start_tracer,[]), + Receiver = spawn(Node,?MODULE,one_time_receiver,[]), + + %% This node does not support arbitrary labels, but small integers should + %% still work. + Label = 1234, + seq_trace:set_token(label,Label), + seq_trace:set_token('receive',true), + + Receiver ! 'receive', + %% let the other process receive the message: + receive after 10 -> ok end, + Self = self(), + seq_trace:reset_trace(), + Result = rpc:call(Node,?MODULE,stop_tracer,[1]), + stop_node(Node), + ok = io:format("~p~n",[Result]), + [{Label,{'receive',_,Self,Receiver,'receive'}, _}] = Result, + ok. + call(doc) -> "Tests special forms {is_seq_trace} and {get_seq_token} " "in trace match specs."; diff --git a/lib/kernel/test/zlib_SUITE.erl b/lib/kernel/test/zlib_SUITE.erl index 26602bdcda..f203ef878f 100644 --- a/lib/kernel/test/zlib_SUITE.erl +++ b/lib/kernel/test/zlib_SUITE.erl @@ -1061,32 +1061,27 @@ sub_heap_binaries(Config) when is_list(Config) -> %% Check concurrent access to zlib driver. smp(Config) -> - case erlang:system_info(smp_support) of - true -> - NumOfProcs = lists:min([8,erlang:system_info(schedulers)]), - io:format("smp starting ~p workers\n",[NumOfProcs]), - - %% Tests to run in parallel. - Funcs = - [zip_usage, gz_usage, compress_usage, dictionary_usage, - crc, adler], - - %% We get all function arguments here to avoid repeated parallel - %% file read access. - UsageArgs = - list_to_tuple([{F, ?MODULE:F({get_arg,Config})} || F <- Funcs]), - Parent = self(), - - WorkerFun = - fun() -> - worker(rand:uniform(9999), UsageArgs, Parent) - end, - - Pids = [spawn_link(WorkerFun) || _ <- lists:seq(1, NumOfProcs)], - wait_pids(Pids); - false -> - {skipped,"No smp support"} - end. + NumOfProcs = lists:min([8,erlang:system_info(schedulers)]), + io:format("smp starting ~p workers\n",[NumOfProcs]), + + %% Tests to run in parallel. + Funcs = + [zip_usage, gz_usage, compress_usage, dictionary_usage, + crc, adler], + + %% We get all function arguments here to avoid repeated parallel + %% file read access. + UsageArgs = + list_to_tuple([{F, ?MODULE:F({get_arg,Config})} || F <- Funcs]), + Parent = self(), + + WorkerFun = + fun() -> + worker(rand:uniform(9999), UsageArgs, Parent) + end, + + Pids = [spawn_link(WorkerFun) || _ <- lists:seq(1, NumOfProcs)], + wait_pids(Pids). worker(Seed, FnATpl, Parent) -> io:format("smp worker ~p, seed=~p~n",[self(),Seed]), diff --git a/lib/kernel/test/zzz_SUITE.erl b/lib/kernel/test/zzz_SUITE.erl new file mode 100644 index 0000000000..59c7fd7404 --- /dev/null +++ b/lib/kernel/test/zzz_SUITE.erl @@ -0,0 +1,37 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2006-2018. 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(zzz_SUITE). + +%% The sole purpose of this test suite is for things we want to run last +%% before the VM terminates. + +-export([all/0]). + +-export([lc_graph/1]). + + +all() -> + [lc_graph]. + +lc_graph(_Config) -> + %% Create "lc_graph" file in current working dir + %% if lock checker is enabled. + erts_debug:lc_graph(), + ok. diff --git a/lib/mnesia/doc/src/Makefile b/lib/mnesia/doc/src/Makefile index 82fcf66256..aed46d50db 100644 --- a/lib/mnesia/doc/src/Makefile +++ b/lib/mnesia/doc/src/Makefile @@ -49,16 +49,18 @@ XML_PART_FILES = \ XML_CHAPTER_FILES = \ Mnesia_chap1.xml \ Mnesia_overview.xml \ + Mnesia_chap8.xml \ + notes.xml + +XML_CHAPTER_GEN_FILES = \ Mnesia_chap2.xml \ Mnesia_chap3.xml \ Mnesia_chap4.xml \ Mnesia_chap5.xml \ Mnesia_chap7.xml \ - Mnesia_chap8.xml \ Mnesia_App_A.xml \ Mnesia_App_B.xml \ - Mnesia_App_C.xml \ - notes.xml + Mnesia_App_C.xml BOOK_FILES = book.xml @@ -66,6 +68,8 @@ XML_FILES = \ $(BOOK_FILES) $(XML_CHAPTER_FILES) \ $(XML_PART_FILES) $(XML_REF3_FILES) $(XML_APPLICATION_FILES) +XML_GEN_FILES = $(XML_CHAPTER_GEN_FILES:%=$(XMLDIR)/%) + GIF_FILES = \ company.gif diff --git a/lib/mnesia/doc/src/Mnesia_chap5.xmlsrc b/lib/mnesia/doc/src/Mnesia_chap5.xmlsrc index 62759c624b..0265e0efa0 100644 --- a/lib/mnesia/doc/src/Mnesia_chap5.xmlsrc +++ b/lib/mnesia/doc/src/Mnesia_chap5.xmlsrc @@ -226,8 +226,10 @@ not known beforehand, all fragments are searched for matching records.</p> <p>Notice that in <c>ordered_set</c> tables, the records - are ordered per fragment, and the the order is undefined in - results returned by <c>select</c> and <c>match_object</c>.</p> + are ordered per fragment, and the order is undefined in + results returned by <c>select</c> and <c>match_object</c>, + as well as <c>first</c>, <c>next</c>, <c>prev</c> and + <c>last</c>.</p> <p>The following code illustrates how a <c>Mnesia</c> table is converted to be a fragmented table and how more fragments are added later:</p> diff --git a/lib/mnesia/src/mnesia.erl b/lib/mnesia/src/mnesia.erl index 1842769778..6d87544bd2 100644 --- a/lib/mnesia/src/mnesia.erl +++ b/lib/mnesia/src/mnesia.erl @@ -177,8 +177,8 @@ %% Local function in order to avoid external function call val(Var) -> - case ?catch_val(Var) of - {'EXIT', _} -> mnesia_lib:other_val(Var); + case ?catch_val_and_stack(Var) of + {'EXIT', Stacktrace} -> mnesia_lib:other_val(Var, Stacktrace); Value -> Value end. @@ -2682,7 +2682,7 @@ del_table_index(Tab, Ix) -> -spec transform_table(Tab::table(), Fun, [Attr]) -> t_result(ok) when Attr :: atom(), - Fun:: fun((Record::tuple()) -> Transformed::tuple()). + Fun:: fun((Record::tuple()) -> Transformed::tuple()) | ignore. transform_table(Tab, Fun, NewA) -> try val({Tab, record_name}) of OldRN -> mnesia_schema:transform_table(Tab, Fun, NewA, OldRN) @@ -2693,7 +2693,7 @@ transform_table(Tab, Fun, NewA) -> -spec transform_table(Tab::table(), Fun, [Attr], RecName) -> t_result(ok) when RecName :: atom(), Attr :: atom(), - Fun:: fun((Record::tuple()) -> Transformed::tuple()). + Fun:: fun((Record::tuple()) -> Transformed::tuple()) | ignore. transform_table(Tab, Fun, NewA, NewRN) -> mnesia_schema:transform_table(Tab, Fun, NewA, NewRN). diff --git a/lib/mnesia/src/mnesia.hrl b/lib/mnesia/src/mnesia.hrl index da7e662288..e36222d098 100644 --- a/lib/mnesia/src/mnesia.hrl +++ b/lib/mnesia/src/mnesia.hrl @@ -47,6 +47,10 @@ -define(catch_val(Var), (try ?ets_lookup_element(mnesia_gvar, Var, 2) catch error:_ -> {'EXIT', {badarg, []}} end)). +-define(catch_val_and_stack(Var), + (try ?ets_lookup_element(mnesia_gvar, Var, 2) + catch error:_:_Stacktrace -> {'EXIT', _Stacktrace} end)). + %% It's important that counter is first, since we compare tid's -record(tid, diff --git a/lib/mnesia/src/mnesia_bup.erl b/lib/mnesia/src/mnesia_bup.erl index 34f16f178b..9dda340333 100644 --- a/lib/mnesia/src/mnesia_bup.erl +++ b/lib/mnesia/src/mnesia_bup.erl @@ -90,9 +90,9 @@ iterate(Mod, Fun, Opaque, Acc) -> catch throw:Err -> close_read(R2), Err; - _:Reason -> + _:Reason:Stacktrace -> close_read(R2), - {error, {Reason, erlang:get_stacktrace()}} + {error, {Reason, Stacktrace}} end catch throw:{error,_} = Err -> Err @@ -198,9 +198,9 @@ do_read_schema_section(R) -> try {R3, RawSchema} = safe_apply(R2, read, [R2#restore.bup_data]), do_read_schema_section(R3, verify_header(RawSchema), []) - catch T:E -> + catch T:E:S -> close_read(R2), - erlang:raise(T,E,erlang:get_stacktrace()) + erlang:raise(T,E,S) end. do_read_schema_section(R, {ok, B, C, []}, Acc) -> diff --git a/lib/mnesia/src/mnesia_checkpoint.erl b/lib/mnesia/src/mnesia_checkpoint.erl index 8112378ffd..8290237908 100644 --- a/lib/mnesia/src/mnesia_checkpoint.erl +++ b/lib/mnesia/src/mnesia_checkpoint.erl @@ -1269,9 +1269,9 @@ system_code_change(Cp, _Module, _OldVsn, _Extra) -> %%%%%%%%%%%%%%%%%%%%%%%%%% +%% Local function in order to avoid external function call val(Var) -> - case ?catch_val(Var) of - {'EXIT', _} -> mnesia_lib:other_val(Var); - _VaLuE_ -> _VaLuE_ + case ?catch_val_and_stack(Var) of + {'EXIT', Stacktrace} -> mnesia_lib:other_val(Var, Stacktrace); + Value -> Value end. - diff --git a/lib/mnesia/src/mnesia_controller.erl b/lib/mnesia/src/mnesia_controller.erl index 77013489b3..77e67a59db 100644 --- a/lib/mnesia/src/mnesia_controller.erl +++ b/lib/mnesia/src/mnesia_controller.erl @@ -185,9 +185,10 @@ max_loaders() -> worker_res }). +%% Local function in order to avoid external function call val(Var) -> - case ?catch_val(Var) of - {'EXIT', _} -> mnesia_lib:other_val(Var); + case ?catch_val_and_stack(Var) of + {'EXIT', Stacktrace} -> mnesia_lib:other_val(Var, Stacktrace); Value -> Value end. diff --git a/lib/mnesia/src/mnesia_dumper.erl b/lib/mnesia/src/mnesia_dumper.erl index f0ed7aef4a..31bcc1451f 100644 --- a/lib/mnesia/src/mnesia_dumper.erl +++ b/lib/mnesia/src/mnesia_dumper.erl @@ -191,8 +191,7 @@ do_perform_dump(Cont, InPlace, InitBy, Regulator, OldVersion) -> try insert_recs(Recs, InPlace, InitBy, Regulator, OldVersion) of Version -> do_perform_dump(C2, InPlace, InitBy, Regulator, Version) - catch _:R when R =/= fatal -> - ST = erlang:get_stacktrace(), + catch _:R:ST when R =/= fatal -> Reason = {"Transaction log dump error: ~tp~n", [{R, ST}]}, close_files(InPlace, {error, Reason}, InitBy), exit(Reason) @@ -325,8 +324,7 @@ perform_update(Tid, SchemaOps, _DumperMode, _UseDir) -> ?eval_debug_fun({?MODULE, post_dump}, [InitBy]), close_files(InPlace, ok, InitBy), ok - catch _:Reason when Reason =/= fatal -> - ST = erlang:get_stacktrace(), + catch _:Reason:ST when Reason =/= fatal -> Error = {error, {"Schema update error", {Reason, ST}}}, close_files(InPlace, Error, InitBy), fatal("Schema update error ~tp ~tp", [{Reason,ST}, SchemaOps]) @@ -1471,8 +1469,9 @@ regulate(RegulatorPid) -> {regulated, RegulatorPid} -> ok end. +%% Local function in order to avoid external function call val(Var) -> - case ?catch_val(Var) of - {'EXIT', _} -> mnesia_lib:other_val(Var); + case ?catch_val_and_stack(Var) of + {'EXIT', Stacktrace} -> mnesia_lib:other_val(Var, Stacktrace); Value -> Value end. diff --git a/lib/mnesia/src/mnesia_frag.erl b/lib/mnesia/src/mnesia_frag.erl index c39f30e140..63fb4981fe 100644 --- a/lib/mnesia/src/mnesia_frag.erl +++ b/lib/mnesia/src/mnesia_frag.erl @@ -1157,9 +1157,10 @@ remove_node(Node, Cs) -> %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% Helpers +%% Local function in order to avoid external function call val(Var) -> - case ?catch_val(Var) of - {'EXIT', _} -> mnesia_lib:other_val(Var); + case ?catch_val_and_stack(Var) of + {'EXIT', Stacktrace} -> mnesia_lib:other_val(Var, Stacktrace); Value -> Value end. diff --git a/lib/mnesia/src/mnesia_lib.erl b/lib/mnesia/src/mnesia_lib.erl index 53fdd76de8..56f6926df0 100644 --- a/lib/mnesia/src/mnesia_lib.erl +++ b/lib/mnesia/src/mnesia_lib.erl @@ -116,7 +116,7 @@ lock_table/1, mkcore/1, not_active_here/1, - other_val/1, + other_val/2, overload_read/0, overload_read/1, overload_set/2, @@ -435,8 +435,8 @@ validate_record(Tab, Obj) -> %% val(Var) -> - case ?catch_val(Var) of - {'EXIT', _} -> other_val(Var); + case ?catch_val_and_stack(Var) of + {'EXIT', Stacktrace} -> other_val(Var, Stacktrace); _VaLuE_ -> _VaLuE_ end. @@ -446,9 +446,9 @@ set(Var, Val) -> unset(Var) -> ?ets_delete(mnesia_gvar, Var). -other_val(Var) -> +other_val(Var, Stacktrace) -> case other_val_1(Var) of - error -> pr_other(Var); + error -> pr_other(Var, Stacktrace); Val -> Val end. @@ -460,8 +460,8 @@ other_val_1(Var) -> _ -> error end. --spec pr_other(_) -> no_return(). -pr_other(Var) -> +-spec pr_other(_, _) -> no_return(). +pr_other(Var, Stacktrace) -> Why = case is_running() of no -> {node_not_running, node()}; @@ -469,7 +469,7 @@ pr_other(Var) -> end, verbose("~p (~tp) val(mnesia_gvar, ~tw) -> ~p ~tp ~n", [self(), process_info(self(), registered_name), - Var, Why, erlang:get_stacktrace()]), + Var, Why, Stacktrace]), mnesia:abort(Why). %% Some functions for list valued variables diff --git a/lib/mnesia/src/mnesia_loader.erl b/lib/mnesia/src/mnesia_loader.erl index 4c6336cb73..bbceb9ba66 100644 --- a/lib/mnesia/src/mnesia_loader.erl +++ b/lib/mnesia/src/mnesia_loader.erl @@ -34,9 +34,10 @@ -include("mnesia.hrl"). +%% Local function in order to avoid external function call val(Var) -> - case ?catch_val(Var) of - {'EXIT', _} -> mnesia_lib:other_val(Var); + case ?catch_val_and_stack(Var) of + {'EXIT', Stacktrace} -> mnesia_lib:other_val(Var, Stacktrace); Value -> Value end. @@ -535,7 +536,7 @@ init_table(Tab, _, Fun, _DetsInfo,_) -> try true = ets:init_table(Tab, Fun), ok - catch _:Else -> {Else, erlang:get_stacktrace()} + catch _:Else:Stacktrace -> {Else, Stacktrace} end. @@ -777,9 +778,9 @@ do_send_table(Pid, Tab, Storage, RemoteS) -> throw:receiver_died -> cleanup_tab_copier(Pid, Storage, Tab), ok; - error:Reason -> %% Prepare failed + error:Reason:Stacktrace -> %% Prepare failed cleanup_tab_copier(Pid, Storage, Tab), - {error, {tab_copier, Tab, {Reason, erlang:get_stacktrace()}}} + {error, {tab_copier, Tab, {Reason, Stacktrace}}} after unlink(whereis(mnesia_tm)) end. diff --git a/lib/mnesia/src/mnesia_locker.erl b/lib/mnesia/src/mnesia_locker.erl index 073b48abc0..710bf38cb5 100644 --- a/lib/mnesia/src/mnesia_locker.erl +++ b/lib/mnesia/src/mnesia_locker.erl @@ -97,10 +97,11 @@ init(Parent) -> end, loop(#state{supervisor = Parent}). +%% Local function in order to avoid external function call val(Var) -> - case ?catch_val(Var) of - {'EXIT', _} -> mnesia_lib:other_val(Var); - _VaLuE_ -> _VaLuE_ + case ?catch_val_and_stack(Var) of + {'EXIT', Stacktrace} -> mnesia_lib:other_val(Var, Stacktrace); + Value -> Value end. reply(From, R) -> diff --git a/lib/mnesia/src/mnesia_recover.erl b/lib/mnesia/src/mnesia_recover.erl index d792070332..475bf3c327 100644 --- a/lib/mnesia/src/mnesia_recover.erl +++ b/lib/mnesia/src/mnesia_recover.erl @@ -177,10 +177,10 @@ disconnect(Node) -> log_decision(D) -> cast({log_decision, D}). +%% Local function in order to avoid external function call val(Var) -> - case ?catch_val(Var) of - {'EXIT', _Reason} -> - mnesia_lib:other_val(Var); + case ?catch_val_and_stack(Var) of + {'EXIT', Stacktrace} -> mnesia_lib:other_val(Var, Stacktrace); Value -> Value end. diff --git a/lib/mnesia/src/mnesia_schema.erl b/lib/mnesia/src/mnesia_schema.erl index 71952af31c..de6c3fb4ee 100644 --- a/lib/mnesia/src/mnesia_schema.erl +++ b/lib/mnesia/src/mnesia_schema.erl @@ -181,9 +181,10 @@ exit_on_error({error, Reason}) -> exit_on_error(GoodRes) -> GoodRes. +%% Local function in order to avoid external function call val(Var) -> - case ?catch_val(Var) of - {'EXIT', _} -> mnesia_lib:other_val(Var); + case ?catch_val_and_stack(Var) of + {'EXIT', Stacktrace} -> mnesia_lib:other_val(Var, Stacktrace); Value -> Value end. @@ -2695,10 +2696,10 @@ prepare_op(_Tid, {op, transform, Fun, TabDef}, _WaitFor) -> Objs -> mnesia_lib:db_fixtable(Storage, Tab, false), {true, Objs, mandatory} - catch _:Reason -> + catch _:Reason:Stacktrace -> mnesia_lib:db_fixtable(Storage, Tab, false), mnesia_lib:important("Transform function failed: '~tp' in '~tp'", - [Reason, erlang:get_stacktrace()]), + [Reason, Stacktrace]), exit({"Bad transform function", Tab, Fun, node(), Reason}) end end; diff --git a/lib/mnesia/src/mnesia_tm.erl b/lib/mnesia/src/mnesia_tm.erl index ebf580d09e..3f6f6c98d8 100644 --- a/lib/mnesia/src/mnesia_tm.erl +++ b/lib/mnesia/src/mnesia_tm.erl @@ -121,10 +121,11 @@ init(Parent) -> proc_lib:init_ack(Parent, {ok, self()}), doit_loop(#state{supervisor = Parent}). +%% Local function in order to avoid external function call val(Var) -> - case ?catch_val(Var) of - {'EXIT', _} -> mnesia_lib:other_val(Var); - _VaLuE_ -> _VaLuE_ + case ?catch_val_and_stack(Var) of + {'EXIT', Stacktrace} -> mnesia_lib:other_val(Var, Stacktrace); + Value -> Value end. reply({From,Ref}, R) -> @@ -597,9 +598,9 @@ recover_coordinator(Tid, Etabs) -> false -> %% When killed before store havn't been copied to ok %% to the new nested trans store. end - catch _:Reason -> + catch _:Reason:Stacktrace -> dbg_out("Recovery of coordinator ~p failed: ~tp~n", - [Tid, {Reason, erlang:get_stacktrace()}]), + [Tid, {Reason, Stacktrace}]), Protocol = asym_trans, tell_outcome(Tid, Protocol, node(), CheckNodes, TellNodes) end, @@ -825,8 +826,7 @@ execute_transaction(Fun, Args, Factor, Retries, Type) -> catch throw:Value -> %% User called throw Reason = {aborted, {throw, Value}}, return_abort(Fun, Args, Reason); - error:Reason -> - ST = erlang:get_stacktrace(), + error:Reason:ST -> check_exit(Fun, Args, Factor, Retries, {Reason,ST}, Type); _:Reason -> check_exit(Fun, Args, Factor, Retries, Reason, Type) @@ -1796,14 +1796,13 @@ do_update(Tid, Storage, [Op | Ops], OldRes) -> try do_update_op(Tid, Storage, Op) of ok -> do_update(Tid, Storage, Ops, OldRes); NewRes -> do_update(Tid, Storage, Ops, NewRes) - catch _:Reason -> + catch _:Reason:ST -> %% This may only happen when we recently have %% deleted our local replica, changed storage_type %% or transformed table %% BUGBUG: Updates may be lost if storage_type is changed. %% Determine actual storage type and try again. %% BUGBUG: Updates may be lost if table is transformed. - ST = erlang:get_stacktrace(), verbose("do_update in ~w failed: ~tp -> {'EXIT', ~tp}~n", [Tid, Op, {Reason, ST}]), do_update(Tid, Storage, Ops, OldRes) @@ -1914,11 +1913,10 @@ commit_clear([H|R], Tid, Storage, Tab, K, Obj) do_snmp(_, []) -> ok; do_snmp(Tid, [Head|Tail]) -> try mnesia_snmp_hook:update(Head) - catch _:Reason -> + catch _:Reason:ST -> %% This should only happen when we recently have %% deleted our local replica or recently deattached %% the snmp table - ST = erlang:get_stacktrace(), verbose("do_snmp in ~w failed: ~tp -> {'EXIT', ~tp}~n", [Tid, Head, {Reason, ST}]) end, @@ -2212,7 +2210,7 @@ display_pid_info(Pid) -> Other end, Reds = fetch(reductions, Info), - LM = length(fetch(messages, Info)), + LM = fetch(message_queue_len, Info), pformat(io_lib:format("~p", [Pid]), io_lib:format("~tp", [Call]), io_lib:format("~tp", [Curr]), Reds, LM) diff --git a/lib/mnesia/test/mnesia_recovery_test.erl b/lib/mnesia/test/mnesia_recovery_test.erl index 82d6e6ac6a..1783d2ae94 100644 --- a/lib/mnesia/test/mnesia_recovery_test.erl +++ b/lib/mnesia/test/mnesia_recovery_test.erl @@ -730,6 +730,7 @@ do_trans_loop2(Tab, Father) -> do_trans_loop2(Tab, Father); Else -> ?error("Transaction failed: ~p ~n", [Else]), + io:format("INFO: ~p~n",[erlang:process_info(self())]), Father ! test_done, exit(shutdown) end. diff --git a/lib/mnesia/test/mnesia_test_lib.erl b/lib/mnesia/test/mnesia_test_lib.erl index 0fabdc7929..db0e7beac6 100644 --- a/lib/mnesia/test/mnesia_test_lib.erl +++ b/lib/mnesia/test/mnesia_test_lib.erl @@ -470,9 +470,9 @@ get_suite(Mod, {group, Suite}) -> {_, _, TCList} = lists:keyfind(Suite, 1, Groups), TCList catch - _:Reason -> + _:Reason:Stacktrace -> io:format("Not implemented ~p ~p (~p ~p)~n", - [Mod,Suite,Reason, erlang:get_stacktrace()]), + [Mod,Suite,Reason,Stacktrace]), 'NYI' end; get_suite(Mod, all) -> @@ -774,7 +774,7 @@ init_nodes([], _File, _Line) -> %% Returns [Name, Host] node_to_name_and_host(Node) -> - string:tokens(atom_to_list(Node), [$@]). + string:lexemes(atom_to_list(Node), [$@]). lookup_config(Key,Config) -> case lists:keysearch(Key,1,Config) of diff --git a/lib/mnesia/test/mnesia_test_lib.hrl b/lib/mnesia/test/mnesia_test_lib.hrl index ba7eb10ea2..90a3c686b0 100644 --- a/lib/mnesia/test/mnesia_test_lib.hrl +++ b/lib/mnesia/test/mnesia_test_lib.hrl @@ -55,25 +55,25 @@ ?error("Not Matching Actual result was:~n ~p~n",[_AR_0]), {fail,_AR_0} catch - exit:{aborted, _ER_1} when + exit:{aborted, _ER_1}:Stacktrace when element(1, _ER_1) =:= node_not_running; element(1, _ER_1) =:= bad_commit; element(1, _ER_1) =:= cyclic -> %% Need to re-raise these to restart transaction - erlang:raise(exit, {aborted, _ER_1}, erlang:get_stacktrace()); - exit:_AR_1 -> + erlang:raise(exit, {aborted, _ER_1}, Stacktrace); + exit:_AR_1:Stacktrace -> case fun(_AR_EXIT_) -> {'EXIT', _AR_EXIT_} end(_AR_1) of _AR_2 = ExpectedRes -> ?verbose("ok, ~n Result as expected:~p~n",[_AR_2]), {success,_AR_2}; _AR_2 -> ?error("Not Matching Actual result was:~n ~p~n ~p~n", - [_AR_2, erlang:get_stacktrace()]), + [_AR_2, Stacktrace]), {fail,_AR_2} end; - _T1_:_AR_1 -> + _T1_:_AR_1:Stacktrace -> ?error("Not Matching Actual result was:~n ~p~n ~p~n", - [{_T1_,_AR_1}, erlang:get_stacktrace()]), + [{_T1_,_AR_1}, Stacktrace]), {fail,{_T1_,_AR_1}} end end()). diff --git a/lib/observer/src/cdv_dist_cb.erl b/lib/observer/src/cdv_dist_cb.erl index 2b4c9f56d1..aeb34e5baf 100644 --- a/lib/observer/src/cdv_dist_cb.erl +++ b/lib/observer/src/cdv_dist_cb.erl @@ -78,7 +78,7 @@ init_gen_page(Parent, Info) -> cdv_info_wx:start_link(Parent,{Fields,Info,[]}). format({creations,Creations}) -> - string:join([integer_to_list(C) || C <- Creations],","); + lists:flatten(lists:join(",",[integer_to_list(C) || C <- Creations])); format(D) -> D. diff --git a/lib/observer/src/cdv_html_wx.erl b/lib/observer/src/cdv_html_wx.erl index 4b43b6a840..77a9d3207b 100644 --- a/lib/observer/src/cdv_html_wx.erl +++ b/lib/observer/src/cdv_html_wx.erl @@ -94,21 +94,21 @@ handle_event(#wx{event=#wxHtmlLink{type=command_html_link_clicked, case Target of "#Binary?" ++ BinSpec -> [{"offset",Off},{"size",Size},{"pos",Pos}] = - httpd:parse_query(BinSpec), + uri_string:dissect_query(BinSpec), Id = {cdv, {list_to_integer(Off), list_to_integer(Size), list_to_integer(Pos)}}, expand(Id,cdv_bin_cb,State); "#OBSBinary?" ++ BinSpec -> [{"key1",Preview},{"key2",Size},{"key3",Hash}] = - httpd:parse_query(BinSpec), + uri_string:dissect_query(BinSpec), Id = {obs, {Tab, {list_to_integer(Preview), list_to_integer(Size), list_to_integer(Hash)}}}, expand(Id,cdv_bin_cb,State); "#Term?" ++ TermKeys -> [{"key1",Key1},{"key2",Key2},{"key3",Key3}] = - httpd:parse_query(TermKeys), + uri_string:dissect_query(TermKeys), Id = {cdv, {Tab,{list_to_integer(Key1), list_to_integer(Key2), list_to_integer(Key3)}}}, diff --git a/lib/observer/src/cdv_mem_cb.erl b/lib/observer/src/cdv_mem_cb.erl index abeddc7335..925487786c 100644 --- a/lib/observer/src/cdv_mem_cb.erl +++ b/lib/observer/src/cdv_mem_cb.erl @@ -49,9 +49,7 @@ gen_mem_info_fields([]) -> []. upper(Key) -> - string:join([string:to_upper([H]) ++ T || - [H|T] <- string:tokens(Key,"_")]," "). - + lists:join(" ", [string:titlecase(Word) || Word <- string:split(Key, "_", all)]). %%%----------------------------------------------------------------- %%% Allocated areas page diff --git a/lib/observer/src/cdv_wx.erl b/lib/observer/src/cdv_wx.erl index c3f36cd689..0e33c9e618 100644 --- a/lib/observer/src/cdv_wx.erl +++ b/lib/observer/src/cdv_wx.erl @@ -130,8 +130,9 @@ init(File0) -> {ok,File} -> %% Set window title T1 = "Crashdump Viewer: ", + FileLength = string:length(File), Title = - if length(File) > 70 -> + if FileLength > 70 -> T1 ++ filename:basename(File); true -> T1 ++ File @@ -428,8 +429,9 @@ do_load_dump(Frame,FileName) -> ok -> %% Set window title T1 = "Crashdump Viewer: ", + FileLength = string:length(FileName), Title = - if length(FileName) > 70 -> + if FileLength > 70 -> T1 ++ filename:basename(FileName); true -> T1 ++ FileName diff --git a/lib/observer/src/crashdump_viewer.erl b/lib/observer/src/crashdump_viewer.erl index d2a175d52d..d0c14db486 100644 --- a/lib/observer/src/crashdump_viewer.erl +++ b/lib/observer/src/crashdump_viewer.erl @@ -877,7 +877,7 @@ do_read_file(File) -> end. check_dump_version(Vsn) -> - DumpVsn = [list_to_integer(L) || L<-string:tokens(Vsn,".")], + DumpVsn = [list_to_integer(L) || L<-string:lexemes(Vsn,".")], if DumpVsn > ?max_dump_version -> Info = "This Crashdump Viewer is too old for the given " @@ -1643,7 +1643,7 @@ get_ports(File) -> %% Converting port string to tuple to secure correct sorting. This is %% converted back in cdv_port_cb:format/1. port_to_tuple("#Port<"++Port) -> - [I1,I2] = string:tokens(Port,".>"), + [I1,I2] = string:lexemes(Port,".>"), {list_to_integer(I1),list_to_integer(I2)}. get_portinfo(Fd,Port) -> @@ -1670,9 +1670,9 @@ get_portinfo(Fd,Port) -> "Registered as" -> get_portinfo(Fd,Port#port{name=string(Fd)}); "Monitors" -> - Monitors0 = string:tokens(bytes(Fd),"()"), + Monitors0 = string:lexemes(bytes(Fd),"()"), Monitors = [begin - [Pid,Ref] = string:tokens(Mon,","), + [Pid,Ref] = string:lexemes(Mon,","), {Pid,Pid++" ("++Ref++")"} end || Mon <- Monitors0], get_portinfo(Fd,Port#port{monitors=Monitors}); @@ -1746,7 +1746,7 @@ get_etsinfo(Fd,EtsTable = #ets_table{details=Ds},WS) -> "Buckets" -> %% A bug in erl_db_hash.c prints a space after the buckets %% - need to strip the string to make list_to_integer/1 happy. - Buckets = list_to_integer(string:strip(bytes(Fd))), + Buckets = list_to_integer(string:trim(bytes(Fd),both,"\s")), get_etsinfo(Fd,EtsTable#ets_table{buckets=Buckets},WS); "Objects" -> get_etsinfo(Fd,EtsTable#ets_table{size=list_to_integer(bytes(Fd))},WS); @@ -1764,7 +1764,9 @@ get_etsinfo(Fd,EtsTable = #ets_table{details=Ds},WS) -> Val = bytes(Fd), get_etsinfo(Fd,EtsTable#ets_table{details=Ds#{chain_min=>Val}},WS); "Chain Length Avg" -> - Val = try list_to_float(string:strip(bytes(Fd))) catch _:_ -> "-" end, + Val = try list_to_float(string:trim(bytes(Fd),both,"\s")) + catch _:_ -> "-" + end, get_etsinfo(Fd,EtsTable#ets_table{details=Ds#{chain_avg=>Val}},WS); "Chain Length Max" -> Val = bytes(Fd), @@ -1921,7 +1923,7 @@ get_nodeinfo(Fd,Nod) -> Creations = lists:flatmap(fun(C) -> try [list_to_integer(C)] catch error:badarg -> [] end - end, string:tokens(bytes(Fd)," ")), + end, string:lexemes(bytes(Fd)," ")), get_nodeinfo(Fd,Nod#nod{creation={creations,Creations}}); "Remote link" -> Procs = bytes(Fd), % e.g. "<0.31.0> <4322.54.0>" @@ -2359,7 +2361,7 @@ get_size_value(Key,Data) -> %% and Value is the sum over all allocator instances of each type. sort_allocator_types([{Name,Data}|Allocators],Acc,DoTotal) -> Type = - case string:tokens(Name,"[]") of + case string:lexemes(Name,"[]") of [T,_Id] -> T; [Name] -> Name; Other -> Other diff --git a/lib/observer/src/observer.app.src b/lib/observer/src/observer.app.src index f682e3dc7b..cd4aa2e299 100644 --- a/lib/observer/src/observer.app.src +++ b/lib/observer/src/observer.app.src @@ -65,8 +65,7 @@ {registered, []}, {applications, [kernel, stdlib]}, {env, []}, - {runtime_dependencies, ["wx-1.2","stdlib-3.4","runtime_tools-1.8.14", - "kernel-3.0","inets-5.10","et-1.5", - "erts-7.0"]}]}. + {runtime_dependencies, ["wx-1.2","stdlib-3.5","runtime_tools-1.8.14", + "kernel-3.0","et-1.5","erts-7.0"]}]}. diff --git a/lib/observer/src/observer_alloc_wx.erl b/lib/observer/src/observer_alloc_wx.erl index 7f4b3dd484..e0f319b6cc 100644 --- a/lib/observer/src/observer_alloc_wx.erl +++ b/lib/observer/src/observer_alloc_wx.erl @@ -79,8 +79,8 @@ init([Notebook, Parent, Config]) -> max = #{} } } - catch _:Err -> - io:format("~p crashed ~tp: ~tp~n",[?MODULE, Err, erlang:get_stacktrace()]), + catch _:Err:Stacktrace -> + io:format("~p crashed ~tp: ~tp~n",[?MODULE, Err, Stacktrace]), {stop, Err} end. diff --git a/lib/observer/src/observer_html_lib.erl b/lib/observer/src/observer_html_lib.erl index 22b4714d63..8202f91030 100644 --- a/lib/observer/src/observer_html_lib.erl +++ b/lib/observer/src/observer_html_lib.erl @@ -278,24 +278,24 @@ href_proc_port("['#CDVPort'"++T,Acc,LTB) -> %% Port written by crashdump_viewer:parse_term(...) {Port0,Rest} = split($],T), PortStr= - case string:tokens(Port0,",.|") of + case string:lexemes(Port0,",.|") of [X,Y] -> Port = "#Port<"++X++"."++Y++">", href(Port,Port); Ns -> - "#Port<" ++ string:join(Ns,".") ++"...>" + "#Port<" ++ lists:join($.,Ns) ++"...>" end, href_proc_port(Rest,[PortStr|Acc],LTB); href_proc_port("['#CDVPid'"++T,Acc,LTB) -> %% Pid written by crashdump_viewer:parse_term(...) {Pid0,Rest} = split($],T), PidStr = - case string:tokens(Pid0,",.|") of + case string:lexemes(Pid0,",.|") of [X,Y,Z] -> Pid = "<"++X++"."++Y++"."++Z++">", href(Pid,Pid); Ns -> - "<" ++ string:join(Ns,".") ++ "...>" + "<" ++ lists:join($.,Ns) ++ "...>" end, href_proc_port(Rest,[PidStr|Acc],LTB); href_proc_port("'#CDVIncompleteHeap'"++T,Acc,LTB)-> @@ -332,7 +332,7 @@ href_proc_port([],Acc,_) -> href_proc_bin(From, T, Acc, LTB) -> {OffsetSizePos,Rest} = split($],T), BinStr = - case string:tokens(OffsetSizePos,",.| \n") of + case string:lexemes(OffsetSizePos,",.| \n") of [Offset,SizeStr,Pos] when From =:= cdv -> Size = list_to_integer(SizeStr), PreviewSize = min(Size,10), diff --git a/lib/observer/src/observer_lib.erl b/lib/observer/src/observer_lib.erl index 0470e785d9..0678b64134 100644 --- a/lib/observer/src/observer_lib.erl +++ b/lib/observer/src/observer_lib.erl @@ -513,7 +513,7 @@ create_box(Parent, Data) -> link_entry(Panel,Value); _ -> Value = to_str(Value0), - case string:sub_word(lists:sublist(Value, 80),1,$\n) of + case string:nth_lexeme(lists:sublist(Value, 80),1, [$\n]) of Value -> %% Short string, no newlines - show all wxStaticText:new(Panel, ?wxID_ANY, Value); diff --git a/lib/observer/src/observer_perf_wx.erl b/lib/observer/src/observer_perf_wx.erl index 5adfadb16e..eddb9327f3 100644 --- a/lib/observer/src/observer_perf_wx.erl +++ b/lib/observer/src/observer_perf_wx.erl @@ -86,8 +86,8 @@ init([Notebook, Parent, Config]) -> secs=maps:get(secs, Config, ?DISP_SECONDS)} }, {Panel, State0} - catch _:Err -> - io:format("~p crashed ~tp: ~tp~n",[?MODULE, Err, erlang:get_stacktrace()]), + catch _:Err:Stacktrace -> + io:format("~p crashed ~tp: ~tp~n",[?MODULE, Err, Stacktrace]), {stop, Err} end. diff --git a/lib/observer/src/observer_pro_wx.erl b/lib/observer/src/observer_pro_wx.erl index 1c40afba46..e2372cde33 100644 --- a/lib/observer/src/observer_pro_wx.erl +++ b/lib/observer/src/observer_pro_wx.erl @@ -50,6 +50,7 @@ -define(ID_TRACE_NEW, 208). -define(ID_TRACE_ALL, 209). -define(ID_ACCUMULATE, 210). +-define(ID_GARBAGE_COLLECT, 211). -define(TRACE_PIDS_STR, "Trace selected process identifiers"). -define(TRACE_NAMES_STR, "Trace selected processes, " @@ -147,11 +148,11 @@ create_list_box(Panel, Holder) -> ListCtrl = wxListCtrl:new(Panel, [{style, Style}, {onGetItemText, fun(_, Row, Col) -> - call(Holder, {get_row, self(), Row, Col}) + safe_call(Holder, {get_row, self(), Row, Col}) end}, {onGetItemAttr, fun(_, Item) -> - call(Holder, {get_attr, self(), Item}) + safe_call(Holder, {get_attr, self(), Item}) end} ]), Li = wxListItem:new(), @@ -208,17 +209,26 @@ start_procinfo(Pid, Frame, Opened) -> Opened end. + +safe_call(Holder, What) -> + case call(Holder, What, 2000) of + Res when is_atom(Res) -> ""; + Res -> Res + end. + call(Holder, What) -> + call(Holder, What, infinity). + +call(Holder, What, TMO) -> Ref = erlang:monitor(process, Holder), Holder ! What, receive - {'DOWN', Ref, _, _, _} -> ""; + {'DOWN', Ref, _, _, _} -> holder_dead; {Holder, Res} -> erlang:demonitor(Ref), Res - after 2000 -> - io:format("Hanging call ~tp~n",[What]), - "" + after TMO -> + timeout end. %%%%%%%%%%%%%%%%%%%%%%% Callbacks %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -269,7 +279,10 @@ code_change(_, _, State) -> handle_call(get_config, _, #state{holder=Holder, timer=Timer}=State) -> Conf = observer_lib:timer_config(Timer), - Accum = call(Holder, {get_accum, self()}), + Accum = case safe_call(Holder, {get_accum, self()}) of + Bool when is_boolean(Bool) -> Bool; + _ -> false + end, {reply, Conf#{acc=>Accum}, State}; handle_call(Msg, _From, State) -> @@ -316,6 +329,9 @@ handle_event(#wx{id=?ID_KILL}, #state{right_clicked_pid=Pid, sel=Sel0}=State) -> Sel = rm_selected(Pid,Sel0), {noreply, State#state{sel=Sel}}; +handle_event(#wx{id=?ID_GARBAGE_COLLECT}, #state{sel={_, Pids}}=State) -> + _ = [rpc:call(node(Pid), erlang, garbage_collect, [Pid]) || Pid <- Pids], + {noreply, State}; handle_event(#wx{id=?ID_PROC}, #state{panel=Panel, right_clicked_pid=Pid, procinfo_menu_pids=Opened}=State) -> @@ -370,6 +386,7 @@ handle_event(#wx{event=#wxList{type=command_list_item_right_click, wxMenu:append(Menu, ?ID_TRACE_NAMES, "Trace selected processes by name (all nodes)", [{help, ?TRACE_NAMES_STR}]), + wxMenu:append(Menu, ?ID_GARBAGE_COLLECT, "Garbage collect processes"), wxMenu:append(Menu, ?ID_KILL, "Kill process " ++ pid_to_list(P)), wxWindow:popupMenu(Panel, Menu), wxMenu:destroy(Menu), @@ -465,7 +482,7 @@ init_table_holder(Parent, Accum0, Attrs) -> Backend = spawn_link(node(), observer_backend, procs_info, [self()]), Accum = case Accum0 of true -> true; - false -> [] + _ -> [] end, table_holder(#holder{parent=Parent, info=array:new(), diff --git a/lib/observer/src/observer_procinfo.erl b/lib/observer/src/observer_procinfo.erl index 5bc17e2aee..6a85d29c1e 100644 --- a/lib/observer/src/observer_procinfo.erl +++ b/lib/observer/src/observer_procinfo.erl @@ -148,7 +148,7 @@ handle_event(#wx{event=#wxHtmlLink{linkInfo=#wxHtmlLinkInfo{href=Href}}}, observer ! {open_link, Href}, {noreply, State}; Callback -> - [{"key1",Key1},{"key2",Key2},{"key3",Key3}] = httpd:parse_query(Rest), + [{"key1",Key1},{"key2",Key2},{"key3",Key3}] = uri_string:dissect_query(Rest), Id = {obs, {T,{list_to_integer(Key1), list_to_integer(Key2), list_to_integer(Key3)}}}, @@ -456,7 +456,8 @@ local_pid_str(Pid) -> global_pid_node_pref(Pid) -> %% Global PID node prefix : X of <X.Y.Z> - string:strip(string:sub_word(pid_to_list(Pid),1,$.),left,$<). + [NodePrefix|_] = string:lexemes(pid_to_list(Pid),"<."), + NodePrefix. io_get_data(Pid) -> Pid ! {self(), get_data_and_close}, diff --git a/lib/observer/src/observer_traceoptions_wx.erl b/lib/observer/src/observer_traceoptions_wx.erl index 4f46426cf6..ff8c40ce77 100644 --- a/lib/observer/src/observer_traceoptions_wx.erl +++ b/lib/observer/src/observer_traceoptions_wx.erl @@ -536,7 +536,7 @@ ms_from_string(Str) -> {error, List} -> throw([[Error, $\n] || {_, Error} <- List]) end catch error:_Reason -> - %% io:format("Bad term: ~ts~n ~tp in ~tp~n", [Str, _Reason, erlang:get_stacktrace()]), + %% io:format("Bad term: ~ts~n ~tp in ~tp~n", [Str, _Reason, Stacktrace]), throw("Invalid term") end. @@ -619,7 +619,7 @@ create_styled_txtctrl(Parent) -> keyWords() -> L = ["after","begin","case","try","cond","catch","andalso","orelse", - "end","fun","if","let","of","query","receive","when","bnot","not", + "end","fun","if","let","of","receive","when","bnot","not", "div","rem","band","and","bor","bxor","bsl","bsr","or","xor"], lists:flatten([K ++ " " || K <- L] ++ [0]). diff --git a/lib/observer/src/observer_wx.erl b/lib/observer/src/observer_wx.erl index be93b1d5f1..453e3bdc2d 100644 --- a/lib/observer/src/observer_wx.erl +++ b/lib/observer/src/observer_wx.erl @@ -732,7 +732,7 @@ get_nodes() -> {Nodes, lists:reverse(Menues)}. epmd_nodes(Names) -> - [_, Host] = string:tokens(atom_to_list(node()),"@"), + [_, Host] = string:lexemes(atom_to_list(node()),"@"), [list_to_atom(Name ++ [$@|Host]) || {Name, _} <- Names]. update_node_list(State = #state{menubar=MenuBar}) -> diff --git a/lib/observer/src/ttb.erl b/lib/observer/src/ttb.erl index 940fdc9818..29a572d7fe 100644 --- a/lib/observer/src/ttb.erl +++ b/lib/observer/src/ttb.erl @@ -100,7 +100,7 @@ do_tracer(Clients,PI,Traci) -> {ok, H} = inet:gethostname(), H; _ -> - [_,H] = string:tokens(atom_to_list(N),"@"), + [_,H] = string:lexemes(atom_to_list(N),"@"), H end, case catch dbg:tracer(N,port,dbg:trace_port(ip,IpPortSpec)) of @@ -976,7 +976,7 @@ decode_filename(3,Bin,latin1) -> File. host(Node) -> - [_name,Host] = string:tokens(atom_to_list(Node),"@"), + [_name,Host] = string:lexemes(atom_to_list(Node),"@"), Host. wait_for_fetch([]) -> @@ -1064,7 +1064,7 @@ collect_files(Dirs) -> lists:map(fun(Dir) -> MetaFiles = filelib:wildcard(filename:join(Dir,"*.ti")), lists:map(fun(M) -> - Sub = string:left(M,length(M)-3), + Sub = filename:rootname(M,".ti"), case filelib:is_file(Sub) of true -> Sub; false -> Sub++".*.wrp" diff --git a/lib/observer/test/crashdump_viewer_SUITE.erl b/lib/observer/test/crashdump_viewer_SUITE.erl index 41ca3f3ce9..8bd7ad387b 100644 --- a/lib/observer/test/crashdump_viewer_SUITE.erl +++ b/lib/observer/test/crashdump_viewer_SUITE.erl @@ -674,7 +674,7 @@ do_create_dumps(DataDir,Rel) -> end, case Rel of current -> - CD3 = dump_with_args(DataDir,Rel,"instr","+Mim true"), + CD3 = dump_with_args(DataDir,Rel,"instr","+Muatags true"), CD4 = dump_with_strange_module_name(DataDir,Rel,"strangemodname"), CD5 = dump_with_size_limit_reached(DataDir,Rel,"trunc_bytes"), CD6 = dump_with_unicode_atoms(DataDir,Rel,"unicode"), diff --git a/lib/observer/test/ttb_SUITE.erl b/lib/observer/test/ttb_SUITE.erl index e8c2f9e37d..ed62efbb58 100644 --- a/lib/observer/test/ttb_SUITE.erl +++ b/lib/observer/test/ttb_SUITE.erl @@ -222,7 +222,7 @@ file_fetch(Config) when is_list(Config) -> ?line ?t:capture_stop(), ?line [StoreString] = ?t:capture_get(), ?line UploadDir = - lists:last(string:tokens(lists:flatten(StoreString),"$ \n")), + lists:last(string:lexemes(lists:flatten(StoreString),"$ \n")), %% check that files are no longer in original directories... ?line ok = check_gone(ThisDir,atom_to_list(Node)++"-file_fetch"), @@ -1035,8 +1035,8 @@ logfile_name_in_fetch_dir(Config) when is_list(Config) -> ?line {ServerNode, ClientNode} = start_client_and_server(), ?line begin_trace(ServerNode, ClientNode, {local, ?FNAME}), ?line {_,Dir} = ttb:stop([return_fetch_dir]), - ?line P1 = lists:nth(3, string:tokens(filename:basename(Dir), "_")), - ?line P2 = hd(string:tokens(P1, "-")), + ?line P1 = lists:nth(3, string:lexemes(filename:basename(Dir), "_")), + ?line P2 = hd(string:lexemes(P1, "-")), ?line _File = P2. logfile_name_in_fetch_dir(cleanup,_Config) -> ?line stop_client_and_server(). diff --git a/lib/os_mon/src/cpu_sup.erl b/lib/os_mon/src/cpu_sup.erl index e758b63d19..c1c972b5b1 100644 --- a/lib/os_mon/src/cpu_sup.erl +++ b/lib/os_mon/src/cpu_sup.erl @@ -244,7 +244,7 @@ get_uint32_measurement(Request, #internal{os_type = {unix, Sys}}) when Sys == ir %% Get the load average using uptime. %% "8:01pm up 2 days, 22:12, 4 users, load average: 0.70, 0.58, 0.43" D = os:cmd("uptime") -- "\n", - Avg = lists:reverse(hd(string:tokens(lists:reverse(D), ":"))), + Avg = lists:reverse(hd(string:lexemes(lists:reverse(D), ":"))), {ok, [L1, L5, L15], _} = io_lib:fread("~f, ~f, ~f", Avg), case Request of ?avg1 -> sunify(L1); diff --git a/lib/os_mon/src/disksup.erl b/lib/os_mon/src/disksup.erl index 044604b000..5118d807e1 100644 --- a/lib/os_mon/src/disksup.erl +++ b/lib/os_mon/src/disksup.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2016. All Rights Reserved. +%% Copyright Ericsson AB 1996-2018. 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. @@ -32,7 +32,7 @@ terminate/2, code_change/3]). %% Other exports --export([format_status/2]). +-export([format_status/2, parse_df/2]). -record(state, {threshold, timeout, os, diskdata = [],port}). @@ -294,8 +294,8 @@ check_disks_solaris("", _Threshold) -> check_disks_solaris("\n", _Threshold) -> []; check_disks_solaris(Str, Threshold) -> - case io_lib:fread("~s~d~d~d~d%~s", Str) of - {ok, [_FS, KB, _Used, _Avail, Cap, MntOn], RestStr} -> + case parse_df(Str, posix) of + {ok, {KB, Cap, MntOn}, RestStr} -> if Cap >= Threshold -> set_alarm({disk_almost_full, MntOn}, []); @@ -308,14 +308,102 @@ check_disks_solaris(Str, Threshold) -> check_disks_solaris(skip_to_eol(Str),Threshold) end. +%% @private +%% @doc Predicate to take a word from the input string until a space or +%% a percent '%' sign (the Capacity field is followed by a %) +parse_df_is_not_space($ ) -> false; +parse_df_is_not_space($%) -> false; +parse_df_is_not_space(_) -> true. + +%% @private +%% @doc Predicate to take spaces away from string. Stops on a non-space +parse_df_is_space($ ) -> true; +parse_df_is_space(_) -> false. + +%% @private +%% @doc Predicate to consume remaining characters until end of line. +parse_df_is_not_eol($\r) -> false; +parse_df_is_not_eol($\n) -> false; +parse_df_is_not_eol(_) -> true. + +%% @private +%% @doc Trims leading non-spaces (the word) from the string then trims spaces. +parse_df_skip_word(Input) -> + Remaining = lists:dropwhile(fun parse_df_is_not_space/1, Input), + lists:dropwhile(fun parse_df_is_space/1, Remaining). + +%% @private +%% @doc Takes all non-spaces and then drops following spaces. +parse_df_take_word(Input) -> + {Word, Remaining0} = lists:splitwith(fun parse_df_is_not_space/1, Input), + Remaining1 = lists:dropwhile(fun parse_df_is_space/1, Remaining0), + {Word, Remaining1}. + +%% @private +%% @doc Takes all non-spaces and then drops the % after it and the spaces. +parse_df_take_word_percent(Input) -> + {Word, Remaining0} = lists:splitwith(fun parse_df_is_not_space/1, Input), + %% Drop the leading % or do nothing + Remaining1 = case Remaining0 of + [$% | R1] -> R1; + _ -> Remaining0 % Might be no % or empty list even + end, + Remaining2 = lists:dropwhile(fun parse_df_is_space/1, Remaining1), + {Word, Remaining2}. + +%% @private +%% @doc Given a line of 'df' POSIX/SUSv3 output split it into fields: +%% a string (mounted device), 4 integers (kilobytes, used, available +%% and capacity), skip % sign, (optionally for susv3 can also skip IUsed, IFree +%% and ICap% fields) then take remaining characters as the mount path +-spec parse_df(string(), posix | susv3) -> + {error, parse_df} | {ok, {integer(), integer(), list()}, string()}. +parse_df(Input0, Flavor) -> + %% Format of Posix/Linux df output looks like Header + Lines + %% Filesystem 1024-blocks Used Available Capacity Mounted on + %% udev 2467108 0 2467108 0% /dev + Input1 = parse_df_skip_word(Input0), % skip device path field + {KbStr, Input2} = parse_df_take_word(Input1), % take Kb field + Input3 = parse_df_skip_word(Input2), % skip Used field + Input4 = parse_df_skip_word(Input3), % skip Avail field + + % take Capacity% field; drop a % sign following the capacity + {CapacityStr, Input5} = parse_df_take_word_percent(Input4), + + %% Format of OS X/SUSv3 df looks similar to POSIX but has 3 extra columns + %% Filesystem 1024-blocks Used Available Capacity iused ifree %iused Mounted + %% /dev/disk1 243949060 2380 86690680 65% 2029724 37555 0% / + Input6 = case Flavor of + posix -> Input5; + susv3 -> % there are 3 extra integers we want to skip + Input5a = parse_df_skip_word(Input5), % skip IUsed field + Input5b = parse_df_skip_word(Input5a), % skip IFree field + %% skip the value of ICap + '%' field + {_, Input5c} = parse_df_take_word_percent(Input5b), + Input5c + end, + + % path is the remaining string till end of line + {MountPath, Input7} = lists:splitwith(fun parse_df_is_not_eol/1, Input6), + % Trim the newlines + Remaining = lists:dropwhile(fun(X) -> not parse_df_is_not_eol(X) end, + Input7), + try + Kb = erlang:list_to_integer(KbStr), + Capacity = erlang:list_to_integer(CapacityStr), + {ok, {Kb, Capacity, MountPath}, Remaining} + catch error:badarg -> + {error, parse_df} + end. + % Parse per SUSv3 specification, notably recent OS X check_disks_susv3("", _Threshold) -> []; check_disks_susv3("\n", _Threshold) -> []; check_disks_susv3(Str, Threshold) -> - case io_lib:fread("~s~d~d~d~d%~d~d~d%~s", Str) of - {ok, [_FS, KB, _Used, _Avail, Cap, _IUsed, _IFree, _ICap, MntOn], RestStr} -> + case parse_df(Str, susv3) of + {ok, {KB, Cap, MntOn}, RestStr} -> if Cap >= Threshold -> set_alarm({disk_almost_full, MntOn}, []); diff --git a/lib/os_mon/src/memsup.erl b/lib/os_mon/src/memsup.erl index 0a9a883390..a30d962ad4 100644 --- a/lib/os_mon/src/memsup.erl +++ b/lib/os_mon/src/memsup.erl @@ -705,7 +705,7 @@ get_os_wordsize_with_uname() -> _ -> 32 end. -clean_string(String) -> lists:flatten(string:tokens(String,"\r\n\t ")). +clean_string(String) -> lists:flatten(string:lexemes(String,[[$\r,$\n]|"\n\t "])). %%--Replying to pending clients----------------------------------------- diff --git a/lib/os_mon/test/disksup_SUITE.erl b/lib/os_mon/test/disksup_SUITE.erl index ad61985014..d7f2626160 100644 --- a/lib/os_mon/test/disksup_SUITE.erl +++ b/lib/os_mon/test/disksup_SUITE.erl @@ -30,7 +30,7 @@ -export([port/1]). -export([terminate/1, unavailable/1, restart/1]). -export([otp_5910/1]). --export([posix_only/1]). +-export([posix_only/1, parse_df_output_posix/1, parse_df_output_susv3/1]). init_per_suite(Config) when is_list(Config) -> ok = application:start(os_mon), @@ -59,7 +59,8 @@ suite() -> all() -> Bugs = [otp_5910], - Always = [api, config, alarm, port, posix_only, unavailable] ++ Bugs, + Always = [api, config, alarm, port, posix_only, unavailable, + parse_df_output_posix, parse_df_output_susv3] ++ Bugs, case test_server:os_type() of {unix, _OSname} -> Always; {win32, _OSname} -> Always; @@ -413,3 +414,36 @@ get_disk_data([{"none",0,0}=E]) -> [E]; get_disk_data([{_,_,0}|Es]) -> get_disk_data(Es); get_disk_data([E|Es]) -> [E|get_disk_data(Es)]; get_disk_data([]) -> []. + +%% @doc Test various expected inputs to 'df' command output (Linux/POSIX) +parse_df_output_posix(Config) when is_list(Config) -> + PosixHdr = "Filesystem 1K-blocks Used Available Use% Mounted on\n", + {error, _} = disksup:parse_df(PosixHdr, posix), + {error, _} = disksup:parse_df("", posix), + {error, _} = disksup:parse_df("\n\n", posix), + + %% Have a simple example with no funny spaces in mount path + Posix1 = "tmpfs 498048 7288 490760 2% /run\n", + {ok, {498048, 2, "/run"}, ""} = disksup:parse_df(Posix1, posix), + + %% Have a mount path with some spaces in it + Posix2 = "tmpfs 498048 7288 490760 2% /spaces 1 2\n", + {ok, {498048, 2, "/spaces 1 2"}, ""} = disksup:parse_df(Posix2, posix). + +%% @doc Test various expected inputs to 'df' command output (Darwin/SUSv3) +parse_df_output_susv3(Config) when is_list(Config) -> + DarwinHdr = "Filesystem 1024-blocks Used Available Capacity " ++ + "iused ifree %iused Mounted on", + {error, _} = disksup:parse_df(DarwinHdr, susv3), + {error, _} = disksup:parse_df("", susv3), + {error, _} = disksup:parse_df("\n\n", susv3), + + %% Have a simple example with no funny spaces in mount path + Darwin1 = "/dev/disk1 243949060 157002380 86690680 65% 2029724 " ++ + "4292937555 0% /\n", + {ok, {243949060, 65, "/"}, ""} = disksup:parse_df(Darwin1, susv3), + + %% Have a mount path with some spaces in it + Darwin2 = "/dev/disk1 243949060 157002380 86690680 65% 2029724 " ++ + "4292937555 0% /spaces 1 2\n", + {ok, {243949060, 65, "/spaces 1 2"}, ""} = disksup:parse_df(Darwin2, susv3). diff --git a/lib/parsetools/include/yeccpre.hrl b/lib/parsetools/include/yeccpre.hrl index 91d6cd49a6..53e8124aaa 100644 --- a/lib/parsetools/include/yeccpre.hrl +++ b/lib/parsetools/include/yeccpre.hrl @@ -56,8 +56,7 @@ return_error(Line, Message) -> yeccpars0(Tokens, Tzr, State, States, Vstack) -> try yeccpars1(Tokens, Tzr, State, States, Vstack) catch - error: Error -> - Stacktrace = erlang:get_stacktrace(), + error: Error: Stacktrace -> try yecc_error_type(Error, Stacktrace) of Desc -> erlang:raise(error, {yecc_bug, ?CODE_VERSION, Desc}, diff --git a/lib/parsetools/src/leex.erl b/lib/parsetools/src/leex.erl index e2e7d7359f..8a4a5e8d86 100644 --- a/lib/parsetools/src/leex.erl +++ b/lib/parsetools/src/leex.erl @@ -37,7 +37,6 @@ -import(lists, [member/2,reverse/1,sort/1,delete/2, keysort/2,keydelete/3, map/2,foldl/3,foreach/2,flatmap/2]). --import(string, [substr/2,substr/3,span/2]). -import(ordsets, [is_element/2,add_element/2,union/2]). -import(orddict, [store/3]). @@ -251,10 +250,10 @@ is_filename(T) -> shorten_filename(Name0) -> {ok,Cwd} = file:get_cwd(), - case lists:prefix(Cwd, Name0) of - false -> Name0; - true -> - case lists:nthtail(length(Cwd), Name0) of + case string:prefix(Name0, Cwd) of + nomatch -> Name0; + Rest -> + case unicode:characters_to_list(Rest) of "/"++N -> N; N -> N end @@ -490,12 +489,9 @@ parse_rules_end(_, NextLine, REAs, As, St) -> %% action has been read. Keep track of line number. collect_rule(Ifile, Chars, L0) -> - %% Erlang strings are 1 based, but re 0 :-( - {match,[{St0,Len}|_]} = re:run(Chars, "[^ \t\r\n]+", [unicode]), - St = St0 + 1, - %%io:fwrite("RE = ~p~n", [substr(Chars, St, Len)]), - case collect_action(Ifile, substr(Chars, St+Len), L0, []) of - {ok,[{':',_}|Toks],L1} -> {ok,substr(Chars, St, Len),Toks,L1}; + {RegExp,Rest} = string:take(Chars, " \t\r\n", true), + case collect_action(Ifile, Rest, L0, []) of + {ok,[{':',_}|Toks],L1} -> {ok,RegExp,Toks,L1}; {ok,_,_} -> {error,{L0,leex,bad_rule}}; {eof,L1} -> {error,{L1,leex,bad_rule}}; {error,E,_} -> {error,E} @@ -549,7 +545,7 @@ var_used(Name, Toks) -> parse_rule_regexp(RE0, [{M,Exp}|Ms], St) -> Split= re:split(RE0, "\\{" ++ M ++ "\\}", [{return,list},unicode]), - RE1 = string:join(Split, Exp), + RE1 = lists:append(lists:join(Exp, Split)), parse_rule_regexp(RE1, Ms, St); parse_rule_regexp(RE, [], St) -> %%io:fwrite("RE = ~p~n", [RE]), @@ -589,9 +585,9 @@ nextline(Ifile, L, St) -> eof -> {eof,L}; {error, _} -> add_error({L+1, leex, cannot_parse}, St); Chars -> - case substr(Chars, span(Chars, " \t\n")+1) of - [$%|_Rest] -> nextline(Ifile, L+1, St); - [] -> nextline(Ifile, L+1, St); + case string:take(Chars, " \t\n") of + {_, [$%|_Rest]} -> nextline(Ifile, L+1, St); + {_, []} -> nextline(Ifile, L+1, St); _Other -> {ok,Chars,L+1} end end. @@ -824,7 +820,7 @@ re_char_class(Cs, Cc, _) -> {reverse(Cc),Cs}. % Preserve order %% posix_cc("space" ++ Cs) -> {space,Cs}; %% posix_cc("upper" ++ Cs) -> {upper,Cs}; %% posix_cc("xdigit" ++ Cs) -> {xdigit,Cs}; -%% posix_cc(Cs) -> parse_error({posix_cc,substr(Cs, 1, 5)}). +%% posix_cc(Cs) -> parse_error({posix_cc,string:slice(Cs, 0, 5)}). escape_char($n) -> $\n; % \n = LF escape_char($r) -> $\r; % \r = CR @@ -863,7 +859,7 @@ escape_char(C) -> C. % Pass it straight through %% re_number(Cs, Acc) -> {Acc,Cs}. string_between(Cs1, Cs2) -> - substr(Cs1, 1, length(Cs1)-length(Cs2)). + string:slice(Cs1, 0, string:length(Cs1)-string:length(Cs2)). %% We use standard methods, Thompson's construction and subset %% construction, to create first an NFA and then a DFA from the @@ -1343,7 +1339,7 @@ out_file(Ifile, Ofile, St, DFA, DF, Actions, Code, L) -> eof -> output_file_directive(Ofile, St#leex.ifile, L); {error, _} -> add_error(St#leex.ifile, {L, leex, cannot_parse}, St); Line -> - case substr(Line, 1, 5) of + case string:slice(Line, 0, 5) of "##mod" -> out_module(Ofile, St); "##cod" -> out_erlang_code(Ofile, St, Code, L); "##dfa" -> out_dfa(Ofile, St, DFA, Code, DF, L); @@ -1523,7 +1519,7 @@ prep_out_actions(As) -> Name = list_to_atom(lists:concat([yyaction_,A])), [Chars,Len,Line,_,_] = Vars, Args = [V || V <- [Chars,Len,Line], V =/= "_"], - ArgsChars = string:join(Args, ", "), + ArgsChars = lists:join(", ", Args), {A,Code,Vars,Name,Args,ArgsChars} end, As). diff --git a/lib/parsetools/src/yecc.erl b/lib/parsetools/src/yecc.erl index 36e33b52a4..b4e1cfe5e3 100644 --- a/lib/parsetools/src/yecc.erl +++ b/lib/parsetools/src/yecc.erl @@ -365,10 +365,10 @@ is_filename(T) -> shorten_filename(Name0) -> {ok,Cwd} = file:get_cwd(), - case lists:prefix(Cwd, Name0) of - false -> Name0; - true -> - case lists:nthtail(length(Cwd), Name0) of + case string:prefix(Name0, Cwd) of + nomatch -> Name0; + Rest -> + case unicode:characters_to_list(Rest) of "/"++N -> N; N -> N end @@ -2196,8 +2196,8 @@ output_reduce(St0, State, Terminal, St20; true -> Ns = "Nss", - Tmp = string:join(lists:duplicate(NmbrOfDaughters - 1, "_"), - ","), + Tmp = lists:join(",", + lists:duplicate(NmbrOfDaughters - 1, "_")), fwrite(St20, <<" [~s|Nss] = Ss,\n">>, [Tmp]) end, St40 = case tokens(RuleNmbr, St30) of diff --git a/lib/parsetools/src/yeccparser.erl b/lib/parsetools/src/yeccparser.erl index 6f6f66d56c..45d91a83a3 100644 --- a/lib/parsetools/src/yeccparser.erl +++ b/lib/parsetools/src/yeccparser.erl @@ -72,8 +72,7 @@ return_error(Line, Message) -> yeccpars0(Tokens, Tzr, State, States, Vstack) -> try yeccpars1(Tokens, Tzr, State, States, Vstack) catch - error: Error -> - Stacktrace = erlang:get_stacktrace(), + error: Error: Stacktrace -> try yecc_error_type(Error, Stacktrace) of Desc -> erlang:raise(error, {yecc_bug, ?CODE_VERSION, Desc}, @@ -167,21 +166,20 @@ yecctoken_location(Token) -> end. -compile({nowarn_unused_function, yecctoken2string/1}). -yecctoken2string({atom, _, A}) -> io_lib:write(A); +yecctoken2string({atom, _, A}) -> io_lib:write_atom(A); yecctoken2string({integer,_,N}) -> io_lib:write(N); yecctoken2string({float,_,F}) -> io_lib:write(F); yecctoken2string({char,_,C}) -> io_lib:write_char(C); yecctoken2string({var,_,V}) -> io_lib:format("~s", [V]); yecctoken2string({string,_,S}) -> io_lib:write_string(S); yecctoken2string({reserved_symbol, _, A}) -> io_lib:write(A); -yecctoken2string({_Cat, _, Val}) -> io_lib:format("~p",[Val]); +yecctoken2string({_Cat, _, Val}) -> io_lib:format("~tp", [Val]); yecctoken2string({dot, _}) -> "'.'"; -yecctoken2string({'$end', _}) -> - []; +yecctoken2string({'$end', _}) -> []; yecctoken2string({Other, _}) when is_atom(Other) -> - io_lib:write(Other); + io_lib:write_atom(Other); yecctoken2string(Other) -> - io_lib:write(Other). + io_lib:format("~tp", [Other]). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% diff --git a/lib/parsetools/test/yecc_SUITE.erl b/lib/parsetools/test/yecc_SUITE.erl index a7166b91ed..2d3b15326b 100644 --- a/lib/parsetools/test/yecc_SUITE.erl +++ b/lib/parsetools/test/yecc_SUITE.erl @@ -1674,8 +1674,7 @@ format_error(Message) -> yeccpars0(Tokens, MFA) -> try yeccpars1(Tokens, MFA, 0, [], []) catch - error: Error -> - Stacktrace = erlang:get_stacktrace(), + error: Error : Stacktrace -> try yecc_error_type(Error, Stacktrace) of {syntax_error, Token} -> yeccerror(Token); diff --git a/lib/public_key/asn1/PKCS-7.asn1 b/lib/public_key/asn1/PKCS-7.asn1 index e76f928acb..e9c188be39 100644 --- a/lib/public_key/asn1/PKCS-7.asn1 +++ b/lib/public_key/asn1/PKCS-7.asn1 @@ -124,7 +124,7 @@ SignerInfoAuthenticatedAttributes ::= CHOICE { -- Also defined in X.509 -- Redeclared here as a parameterized type -AlgorithmIdentifierPKSC-7 {ALGORITHM:IOSet} ::= SEQUENCE { +AlgorithmIdentifierPKCS-7 {ALGORITHM:IOSet} ::= SEQUENCE { algorithm ALGORITHM.&id({IOSet}), parameters ALGORITHM.&Type({IOSet}{@algorithm}) OPTIONAL } @@ -146,21 +146,21 @@ CRLSequence ::= SEQUENCE OF CertificateList ContentEncryptionAlgorithmIdentifier ::= - AlgorithmIdentifierPKSC-7 {{ContentEncryptionAlgorithms}} + AlgorithmIdentifierPKCS-7 {{ContentEncryptionAlgorithms}} ContentEncryptionAlgorithms ALGORITHM ::= { ... -- add any application-specific algorithms here } DigestAlgorithmIdentifier ::= - AlgorithmIdentifierPKSC-7 {{DigestAlgorithms}} + AlgorithmIdentifierPKCS-7 {{DigestAlgorithms}} DigestAlgorithms ALGORITHM ::= { ... -- add any application-specific algorithms here } DigestEncryptionAlgorithmIdentifier ::= - AlgorithmIdentifierPKSC-7 {{DigestEncryptionAlgorithms}} + AlgorithmIdentifierPKCS-7 {{DigestEncryptionAlgorithms}} DigestEncryptionAlgorithms ALGORITHM ::= { ... -- add any application-specific algorithms here @@ -182,7 +182,7 @@ IssuerAndSerialNumber ::= SEQUENCE { } KeyEncryptionAlgorithmIdentifier ::= - AlgorithmIdentifierPKSC-7 {{KeyEncryptionAlgorithms}} + AlgorithmIdentifierPKCS-7 {{KeyEncryptionAlgorithms}} KeyEncryptionAlgorithms ALGORITHM ::= { ... -- add any application-specific algorithms here diff --git a/lib/public_key/doc/src/public_key.xml b/lib/public_key/doc/src/public_key.xml index dea35bc390..7284da0499 100644 --- a/lib/public_key/doc/src/public_key.xml +++ b/lib/public_key/doc/src/public_key.xml @@ -95,10 +95,12 @@ <p><c>| {#'PBEParameter{}, digest_type()} | #'PBES2-params'{}}</c></p> </item> - <tag><c>public_key() =</c></tag> + <tag><marker id="type-public_key"/> + <c>public_key() =</c></tag> <item><p><c>rsa_public_key() | dsa_public_key() | ec_public_key()</c></p></item> - <tag><c>private_key() =</c></tag> + <tag><marker id="type-private_key"/> + <c>private_key() =</c></tag> <item><p><c>rsa_private_key() | dsa_private_key() | ec_private_key()</c></p></item> <tag><c>rsa_public_key() =</c></tag> diff --git a/lib/public_key/src/pubkey_cert.erl b/lib/public_key/src/pubkey_cert.erl index c433a96585..c0d7b9be8e 100644 --- a/lib/public_key/src/pubkey_cert.erl +++ b/lib/public_key/src/pubkey_cert.erl @@ -371,23 +371,23 @@ match_name(directoryName, DirName, [PermittedName | Rest]) -> match_name(fun is_rdnSeq/2, DirName, PermittedName, Rest); match_name(uniformResourceIdentifier, URI, [PermittedName | Rest]) -> - case split_uri(URI) of - incomplete -> - false; - {_, _, Host, _, _} -> - PN = case split_uri(PermittedName) of - {_, _, PNhost, _, _} -> PNhost; + case uri_string:normalize(URI, [return_map]) of + #{host := Host} -> + PN = case uri_string:normalize(PermittedName, [return_map]) of + #{host := PNhost} -> PNhost; _X -> PermittedName end, - match_name(fun is_valid_host_or_domain/2, Host, PN, Rest) + match_name(fun is_valid_host_or_domain/2, Host, PN, Rest); + _ -> + false end; match_name(emailAddress, Name, [PermittedName | Rest]) -> Fun = fun(Email, PermittedEmail) -> - is_valid_email_address(Email, PermittedEmail, - string:tokens(PermittedEmail,"@")) - end, - match_name(Fun, Name, PermittedName, Rest); + is_valid_email_address(Email, PermittedEmail, + string:tokens(PermittedEmail,"@")) + end, + match_name(Fun, Name, PermittedName, Rest); match_name(dNSName, Name, [PermittedName | Rest]) -> Fun = fun(Domain, [$.|Domain]) -> true; @@ -868,75 +868,12 @@ is_valid_subject_alt_name({otherName, #'AnotherName'{}}) -> is_valid_subject_alt_name({_, _}) -> false. -is_ip_address(Address) -> - case inet_parse:address(Address) of - {ok, _} -> - true; - _ -> - false - end. - -is_fully_qualified_name(_Name) -> - true. - is_valid_uri(AbsURI) -> - case split_uri(AbsURI) of - incomplete -> - false; - {StrScheme, _, Host, _, _} -> - case string:to_lower(StrScheme) of - Scheme when Scheme =:= "http"; Scheme =:= "ftp" -> - is_valid_host(Host); - _ -> - false - end - end. - -is_valid_host(Host) -> - case is_ip_address(Host) of - true -> - true; - false -> - is_fully_qualified_name(Host) - end. - -%% Could have a more general split URI in stdlib? Maybe when -%% regexs are improved. Needed also in inets! -split_uri(Uri) -> - case split_uri(Uri, ":", {error, no_scheme}, 1, 1) of - {error, no_scheme} -> - incomplete; - {StrScheme, "//" ++ URIPart} -> - {Authority, PathQuery} = - split_auth_path(URIPart), - {UserInfo, HostPort} = - split_uri(Authority, "@", {"", Authority}, 1, 1), - {Host, Port} = - split_uri(HostPort, ":", {HostPort, dummy_port}, 1, 1), - {StrScheme, UserInfo, Host, Port, PathQuery} - end. - -split_auth_path(URIPart) -> - case split_uri(URIPart, "/", URIPart, 1, 0) of - Split = {_, _} -> - Split; - URIPart -> - case split_uri(URIPart, "\\?", URIPart, 1, 0) of - Split = {_, _} -> - Split; - URIPart -> - {URIPart,""} - end - end. - -split_uri(UriPart, SplitChar, NoMatchResult, SkipLeft, SkipRight) -> - case re:run(UriPart, SplitChar) of - {match,[{Start, _}]} -> - StrPos = Start + 1, - {string:substr(UriPart, 1, StrPos - SkipLeft), - string:substr(UriPart, StrPos + SkipRight, length(UriPart))}; - nomatch -> - NoMatchResult + case uri_string:normalize(AbsURI, [return_map]) of + #{scheme := _} -> + true; + _ -> + false end. is_rdnSeq({rdnSequence,[]}, {rdnSequence,[none]}) -> diff --git a/lib/public_key/src/pubkey_ssh.erl b/lib/public_key/src/pubkey_ssh.erl index a7d018e440..02c061efc9 100644 --- a/lib/public_key/src/pubkey_ssh.erl +++ b/lib/public_key/src/pubkey_ssh.erl @@ -38,6 +38,8 @@ -define(Empint(X), (mpint(X))/binary ). -define(Estring(X), (string(X))/binary ). +-define(b64enc(X), base64:encode(iolist_to_binary(X)) ). +-define(b64mime_dec(X), base64:mime_decode(iolist_to_binary(X)) ). %% Max encoded line length is 72, but conformance examples use 68 %% Comment from rfc 4716: "The following are some examples of public @@ -163,7 +165,7 @@ rfc4716_decode_line(Line, Lines, Acc) -> rfc4716_decode_lines(Lines, [{string_decode(Tag), unicode_decode(Value)} | Acc]); _ -> {Body, Rest} = join_entry([Line | Lines], []), - {lists:reverse(Acc), rfc4716_pubkey_decode(base64:mime_decode(Body)), Rest} + {lists:reverse(Acc), rfc4716_pubkey_decode(?b64mime_dec(Body)), Rest} end. join_entry([<<"---- END SSH2 PUBLIC KEY ----", _/binary>>| Lines], Entry) -> @@ -257,11 +259,11 @@ decode_comment(Comment) -> openssh_pubkey_decode(Type, Base64Enc) -> try - <<?DEC_BIN(Type,_TL), Bin/binary>> = base64:mime_decode(Base64Enc), + <<?DEC_BIN(Type,_TL), Bin/binary>> = ?b64mime_dec(Base64Enc), ssh2_pubkey_decode(Type, Bin) catch _:_ -> - {Type, base64:mime_decode(Base64Enc)} + {Type, ?b64mime_dec(Base64Enc)} end. @@ -292,12 +294,12 @@ do_encode(Type, Key, Attributes) -> rfc4716_encode(Key, [],[]) -> iolist_to_binary([begin_marker(),"\n", - split_lines(base64:encode(ssh2_pubkey_encode(Key))), + split_lines(?b64enc(ssh2_pubkey_encode(Key))), "\n", end_marker(), "\n"]); rfc4716_encode(Key, [], [_|_] = Acc) -> iolist_to_binary([begin_marker(), "\n", lists:reverse(Acc), - split_lines(base64:encode(ssh2_pubkey_encode(Key))), + split_lines(?b64enc(ssh2_pubkey_encode(Key))), "\n", end_marker(), "\n"]); rfc4716_encode(Key, [ Header | Headers], Acc) -> LinesStr = rfc4716_encode_header(Header), @@ -326,7 +328,7 @@ rfc4716_encode_value(Value) -> openssh_encode(openssh_public_key, Key, Attributes) -> Comment = proplists:get_value(comment, Attributes, ""), - Enc = base64:encode(ssh2_pubkey_encode(Key)), + Enc = ?b64enc(ssh2_pubkey_encode(Key)), iolist_to_binary([key_type(Key), " ", Enc, " ", Comment, "\n"]); openssh_encode(auth_keys, Key, Attributes) -> @@ -351,10 +353,10 @@ openssh_encode(known_hosts, Key, Attributes) -> end. openssh_ssh2_auth_keys_encode(undefined, Key, Comment) -> - iolist_to_binary([key_type(Key)," ", base64:encode(ssh2_pubkey_encode(Key)), line_end(Comment)]); + iolist_to_binary([key_type(Key)," ", ?b64enc(ssh2_pubkey_encode(Key)), line_end(Comment)]); openssh_ssh2_auth_keys_encode(Options, Key, Comment) -> iolist_to_binary([comma_list_encode(Options, []), " ", - key_type(Key)," ", base64:encode(ssh2_pubkey_encode(Key)), line_end(Comment)]). + key_type(Key)," ", ?b64enc(ssh2_pubkey_encode(Key)), line_end(Comment)]). openssh_ssh1_auth_keys_encode(undefined, Bits, #'RSAPublicKey'{modulus = N, publicExponent = E}, @@ -369,7 +371,7 @@ openssh_ssh1_auth_keys_encode(Options, Bits, openssh_ssh2_know_hosts_encode(Hostnames, Key, Comment) -> iolist_to_binary([comma_list_encode(Hostnames, []), " ", - key_type(Key)," ", base64:encode(ssh2_pubkey_encode(Key)), line_end(Comment)]). + key_type(Key)," ", ?b64enc(ssh2_pubkey_encode(Key)), line_end(Comment)]). openssh_ssh1_known_hosts_encode(Hostnames, Bits, #'RSAPublicKey'{modulus = N, publicExponent = E}, diff --git a/lib/public_key/src/public_key.app.src b/lib/public_key/src/public_key.app.src index dbd732c384..5833141e87 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.8", + {runtime_dependencies, ["stdlib-3.5","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 034126655c..931901640a 100644 --- a/lib/public_key/src/public_key.erl +++ b/lib/public_key/src/public_key.erl @@ -1456,7 +1456,7 @@ ascii_to_lower(String) -> verify_hostname_extract_fqdn_default({dns_id,S}) -> S; verify_hostname_extract_fqdn_default({uri_id,URI}) -> - {ok,{https,_,Host,_,_,_}} = http_uri:parse(URI), + #{scheme := "https", host := Host} = uri_string:normalize(URI, [return_map]), Host. diff --git a/lib/reltool/doc/src/reltool_examples.xml b/lib/reltool/doc/src/reltool_examples.xml index 30cb3c13b6..2a103119e6 100644 --- a/lib/reltool/doc/src/reltool_examples.xml +++ b/lib/reltool/doc/src/reltool_examples.xml @@ -5,7 +5,7 @@ <header> <copyright> <year>2009</year> - <year>2017</year> + <year>2018</year> <holder>Ericsson AB, All Rights Reserved</holder> </copyright> <legalnotice> @@ -150,13 +150,13 @@ Eshell V9.0 (abort with ^G) {mod_cond,all}, {incl_cond,derived}, {erts,[{app,erts, - [{vsn,"9.0"}, - {lib_dir,"/usr/local/lib/erlang/lib/erts-9.0"}, + [{vsn,"10.0"}, + {lib_dir,"/usr/local/lib/erlang/lib/erts-10.0"}, {mod,erl_prim_loader,[]}, {mod,erl_tracer,[]}, {mod,erlang,[]}, {mod,erts_code_purger,[]}, - {mod,erts_dirty_process_code_checker,[]}, + {mod,erts_dirty_process_signal_handler,[]}, {mod,erts_internal,[]}, {mod,erts_literal_area_collector,[]}, {mod,init,[]}, @@ -309,9 +309,9 @@ Eshell V9.0 (abort with ^G) <section> <title>Generate release and script files</title> <pre> -Erlang/OTP 20 [erts-9.0] [source-c13b302] [64-bit] [smp:4:4] [ds:4:4:10] [async-threads:10] +Erlang/OTP 20 [erts-10.0] [source-c13b302] [64-bit] [smp:4:4] [ds:4:4:10] [async-threads:10] [hipe] [kernel-poll:false] -Eshell V9.0 (abort with ^G) +Eshell V10.0 (abort with ^G) 1> 1> {ok, Server} = reltool:start_server([{config, {sys, [{boot_rel, "NAME"}, {rel, "NAME", "VSN", @@ -324,13 +324,13 @@ Eshell V9.0 (abort with ^G) 3> 3> reltool:get_rel(Server, "NAME"). {ok,{release,{"NAME","VSN"}, - {erts,"9.0"}, + {erts,"10.0"}, [{kernel,"5.2"},{stdlib,"3.3"},{sasl,"3.0.3"}]}} 4> 4> reltool:get_script(Server, "NAME"). {ok,{script,{"NAME","VSN"}, [{preLoaded,[erl_prim_loader,erl_tracer,erlang, - erts_code_purger,erts_dirty_process_code_checker, + erts_code_purger,erts_dirty_process_signal_handler, erts_internal,erts_literal_area_collector,init,otp_ring0, prim_eval,prim_file,prim_inet,prim_zip,zlib]}, {progress,preloaded}, @@ -374,9 +374,9 @@ ok <section> <title>Create a target system</title> <pre> -Erlang/OTP 20 [erts-9.0] [source-c13b302] [64-bit] [smp:4:4] [ds:4:4:10] [async-threads:10] +Erlang/OTP 20 [erts-10.0] [source-c13b302] [64-bit] [smp:4:4] [ds:4:4:10] [async-threads:10] [hipe] [kernel-poll:false] -Eshell V9.0 (abort with ^G) +Eshell V10.0 (abort with ^G) 1> 1> Config = {sys, [{escript, "examples/display_args", [{incl_cond, include}]}, {app, inets, [{incl_cond, include}]}, @@ -393,7 +393,7 @@ Eshell V9.0 (abort with ^G) 2> 2> {ok, Spec} = reltool:get_target_spec([Config]). {ok,[{create_dir,"releases", - [{write_file,"start_erl.data","9.0 1.0\n"}, + [{write_file,"start_erl.data","10.0 1.0\n"}, {create_dir,"1.0", [{write_file,"start_clean.rel", [37,37,32,114,101,108,32,103,101,110,101,114,97,116|...]}, @@ -410,17 +410,17 @@ Eshell V9.0 (abort with ^G) {create_dir,"bin", [{copy_file,"display_args.escript", "/usr/local/lib/erlang/lib/reltool-0.7.3/examples/display_args"}, - {copy_file,"display_args","erts-9.0/bin/escript"}, - {copy_file,"start","erts-9.0/bin/start"}, - {copy_file,"ct_run","erts-9.0/bin/ct_run"}, - {copy_file,"dialyzer","erts-9.0/bin/dialyzer"}, - {copy_file,"run_erl","erts-9.0/bin/run_erl"}, - {copy_file,"erl","erts-9.0/bin/dyn_erl"}, - {copy_file,"to_erl","erts-9.0/bin/to_erl"}, - {copy_file,"epmd","erts-9.0/bin/epmd"}, - {copy_file,"erlc","erts-9.0/bin/erlc"}, - {copy_file,"typer","erts-9.0/bin/typer"}, - {copy_file,"escript","erts-9.0/bin/escript"}, + {copy_file,"display_args","erts-10.0/bin/escript"}, + {copy_file,"start","erts-10.0/bin/start"}, + {copy_file,"ct_run","erts-10.0/bin/ct_run"}, + {copy_file,"dialyzer","erts-10.0/bin/dialyzer"}, + {copy_file,"run_erl","erts-10.0/bin/run_erl"}, + {copy_file,"erl","erts-10.0/bin/dyn_erl"}, + {copy_file,"to_erl","erts-10.0/bin/to_erl"}, + {copy_file,"epmd","erts-10.0/bin/epmd"}, + {copy_file,"erlc","erts-10.0/bin/erlc"}, + {copy_file,"typer","erts-10.0/bin/typer"}, + {copy_file,"escript","erts-10.0/bin/escript"}, {write_file,"start_clean.boot",<<131,104,3,119,6,115,...>>}, {write_file,"start_sasl.boot",<<131,104,3,119,6,...>>}, {write_file,"start.boot",<<131,104,3,119,...>>}]}, @@ -451,7 +451,7 @@ Eshell V9.0 (abort with ^G) {copy_file,[...]}, {copy_file,...}, {...}]}]}, - {create_dir,"erts-9.0", + {create_dir,"erts-10.0", [{create_dir,"bin", [{copy_file,"start"}, {copy_file,"ct_run"}, @@ -459,7 +459,7 @@ Eshell V9.0 (abort with ^G) {copy_file,"dialyzer"}, {copy_file,"beam.smp"}, {copy_file,"run_erl"}, - {copy_file,"erl","erts-9.0/bin/dyn_erl"}, + {copy_file,"erl","erts-10.0/bin/dyn_erl"}, {copy_file,"to_erl"}, {copy_file,"epmd"}, {copy_file,"erl_child_setup"}, @@ -511,8 +511,8 @@ Eshell V9.0 (abort with ^G) [{create_dir,"priv", [{create_dir,"lib",[{copy_file,[...]},{copy_file,...}]}, {create_dir,"obj",[{copy_file,...},{...}|...]}]}]}, - {archive,"erts-9.0.ez",[], - [{create_dir,"erts-9.0", + {archive,"erts-10.0.ez",[], + [{create_dir,"erts-10.0", [{create_dir,"src",[{...}|...]}, {create_dir,"ebin",[...]}]}]}, {archive,"hipe-3.15.4.ez",[], @@ -549,14 +549,14 @@ ok ok 7> 7> file:list_dir(TargetDir). -{ok,["bin","Install","lib","misc","usr","erts-9.0", +{ok,["bin","Install","lib","misc","usr","erts-10.0", "releases"]} 8> 8> file:list_dir(filename:join([TargetDir,"lib"])). {ok,["tools-2.9.1.ez","kernel-5.2.ez","inets-6.3.9.ez", "kernel-5.2","sasl-3.0.3.ez","hipe-3.15.4.ez","inets-6.3.9", "crypto-3.7.4","crypto-3.7.4.ez","stdlib-3.3.ez", - "erts-9.0.ez","stdlib-3.3","compiler-7.0.4.ez"]} + "erts-10.0.ez","stdlib-3.3","compiler-7.0.4.ez"]} 9> 9> file:make_dir("/tmp/yet_another_target_dir"). ok @@ -565,7 +565,7 @@ ok ok 11> 11> file:list_dir("/tmp/yet_another_target_dir"). -{ok,["bin","Install","lib","misc","usr","erts-9.0", +{ok,["bin","Install","lib","misc","usr","erts-10.0", "releases"]} </pre> diff --git a/lib/reltool/src/reltool.hrl b/lib/reltool/src/reltool.hrl index 9c8aae6b7e..d133762818 100644 --- a/lib/reltool/src/reltool.hrl +++ b/lib/reltool/src/reltool.hrl @@ -220,7 +220,8 @@ { name :: rel_name(), vsn :: rel_vsn(), - rel_apps :: [#rel_app{}] + rel_apps :: [#rel_app{}], + load_dot_erlang = true :: boolean() }). -record(sys, @@ -300,6 +301,7 @@ -define(STANDALONE_INCL_SYS_FILTERS, ["^bin/(erl|epmd)(|\\.exe|\\.ini)\$", "^bin/start(|_clean).boot\$", + "^bin/no_dot_erlang\\.boot\$", "^erts.*/bin", "^lib\$"]). -define(STANDALONE_EXCL_SYS_FILTERS, diff --git a/lib/reltool/src/reltool_app_win.erl b/lib/reltool/src/reltool_app_win.erl index 663144861f..335b40fa74 100644 --- a/lib/reltool/src/reltool_app_win.erl +++ b/lib/reltool/src/reltool_app_win.erl @@ -102,8 +102,8 @@ init(Parent, WxEnv, Xref, C, AppName) -> try do_init(Parent, WxEnv, Xref, C, AppName) catch - error:Reason -> - exit({Reason, erlang:get_stacktrace()}) + error:Reason:Stacktrace -> + exit({Reason, Stacktrace}) end. do_init(Parent, WxEnv, Xref, C, AppName) -> diff --git a/lib/reltool/src/reltool_mod_win.erl b/lib/reltool/src/reltool_mod_win.erl index 2d56d74563..8272d864c2 100644 --- a/lib/reltool/src/reltool_mod_win.erl +++ b/lib/reltool/src/reltool_mod_win.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2009-2016. All Rights Reserved. +%% Copyright Ericsson AB 2009-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. @@ -107,8 +107,8 @@ init(Parent, WxEnv, Xref, RelPid, C, ModName) -> try do_init(Parent, WxEnv, Xref, RelPid, C, ModName) catch - error:Reason -> - exit({Reason, erlang:get_stacktrace()}) + error:Reason:Stacktrace -> + exit({Reason, Stacktrace}) end. do_init(Parent, WxEnv, Xref, RelPid, C, ModName) -> @@ -833,7 +833,7 @@ load_code(Ed, Code) when is_binary(Code) -> keyWords() -> L = ["after","begin","case","try","cond","catch","andalso","orelse", - "end","fun","if","let","of","query","receive","when","bnot","not", + "end","fun","if","let","of","receive","when","bnot","not", "div","rem","band","and","bor","bxor","bsl","bsr","or","xor"], lists:flatten([K ++ " " || K <- L] ++ [0]). diff --git a/lib/reltool/src/reltool_server.erl b/lib/reltool/src/reltool_server.erl index 853191c696..66ee1a3742 100644 --- a/lib/reltool/src/reltool_server.erl +++ b/lib/reltool/src/reltool_server.erl @@ -135,8 +135,8 @@ init([{parent,Parent}|_] = Options) -> catch throw:{error,Reason} -> proc_lib:init_ack(Parent,{error,Reason}); - error:Reason -> - exit({Reason, erlang:get_stacktrace()}) + error:Reason:Stacktrace -> + exit({Reason, Stacktrace}) end. do_init(Options) -> diff --git a/lib/reltool/src/reltool_sys_win.erl b/lib/reltool/src/reltool_sys_win.erl index 92df270752..d87b1dc91f 100644 --- a/lib/reltool/src/reltool_sys_win.erl +++ b/lib/reltool/src/reltool_sys_win.erl @@ -135,9 +135,9 @@ init(Options) -> try do_init(Options) catch - error:Reason -> - io:format("~tp: ~tp~n",[Reason, erlang:get_stacktrace()]), - exit({Reason, erlang:get_stacktrace()}) + error:Reason:Stacktrace -> + io:format("~tp: ~tp~n",[Reason, Stacktrace]), + exit({Reason, Stacktrace}) end. do_init([{safe_config, Safe}, {parent, Parent} | Options]) -> diff --git a/lib/reltool/src/reltool_target.erl b/lib/reltool/src/reltool_target.erl index 1b1461178e..503e1971b9 100644 --- a/lib/reltool/src/reltool_target.erl +++ b/lib/reltool/src/reltool_target.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2009-2016. All Rights Reserved. +%% Copyright Ericsson AB 2009-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. @@ -424,7 +424,7 @@ gen_script(Rel, Sys, PathFlag, Variables) -> {error, Text} end. -do_gen_script(#rel{name = RelName, vsn = RelVsn}, +do_gen_script(#rel{name = RelName, vsn = RelVsn, load_dot_erlang=LoadErlangRc}, #sys{apps = Apps}, MergedApps, PathFlag, @@ -474,9 +474,11 @@ do_gen_script(#rel{name = RelName, vsn = RelVsn}, Type =/= none, Type =/= load, not lists:member(Name, InclApps)], - %% Apply user specific customizations - {apply, {c, erlangrc, []}}, + case LoadErlangRc of + true -> {apply, {c, erlangrc, []}}; + false -> [] + end, {progress, started} ], {ok, {script, {RelName, RelVsn}, lists:flatten(DeepList)}}. diff --git a/lib/reltool/src/reltool_utils.erl b/lib/reltool/src/reltool_utils.erl index 3891b5ae4d..060a0912f9 100644 --- a/lib/reltool/src/reltool_utils.erl +++ b/lib/reltool/src/reltool_utils.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2009-2016. All Rights Reserved. +%% Copyright Ericsson AB 2009-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. @@ -154,7 +154,12 @@ default_rels() -> rel_apps = []}, #rel{name = "start_sasl", vsn = "1.0", - rel_apps = [#rel_app{name = sasl}]} + rel_apps = [#rel_app{name = sasl}]}, + #rel{name = "no_dot_erlang", %% Needed by escript and erlc + vsn = "1.0", + rel_apps = [], + load_dot_erlang = false + } ]. choose_default(Tag, Profile, InclDefs) diff --git a/lib/reltool/test/reltool_server_SUITE.erl b/lib/reltool/test/reltool_server_SUITE.erl index 49efe5aeda..3622f6650c 100644 --- a/lib/reltool/test/reltool_server_SUITE.erl +++ b/lib/reltool/test/reltool_server_SUITE.erl @@ -247,6 +247,7 @@ get_config(_Config) -> {app,stdlib,[{incl_cond,include},{vsn,undefined}, {lib_dir,StdLibDir}]}, {boot_rel,"start_clean"}, + {rel,"no_dot_erlang","1.0",[]}, {rel,"start_clean","1.0",[]}, {rel,"start_sasl","1.0",[sasl]}, {emu_name,"beam"}, @@ -277,6 +278,7 @@ get_config(_Config) -> {app,stdlib,[{incl_cond,include},{vsn,StdVsn}, {lib_dir,StdLibDir},{mod,_,[]}|_]}, {boot_rel,"start_clean"}, + {rel,"no_dot_erlang","1.0",[]}, {rel,"start_clean","1.0",[]}, {rel,"start_sasl","1.0",[sasl]}, {emu_name,"beam"}, @@ -2104,6 +2106,7 @@ save_config(Config) -> {app,stdlib,[{incl_cond,include},{vsn,undefined}, {lib_dir,undefined}]}, {boot_rel,"start_clean"}, + {rel,"no_dot_erlang","1.0",[]}, {rel,"start_clean","1.0",[]}, {rel,"start_sasl","1.0",[sasl]}, {emu_name,"beam"}, @@ -2144,6 +2147,7 @@ save_config(Config) -> {app,stdlib,[{incl_cond,include},{vsn,StdVsn}, {lib_dir,StdLibDir},{mod,_,[]}|_]}, {boot_rel,"start_clean"}, + {rel,"no_dot_erlang","1.0",[]}, {rel,"start_clean","1.0",[]}, {rel,"start_sasl","1.0",[sasl]}, {emu_name,"beam"}, @@ -2545,7 +2549,7 @@ undefined_regexp(_Config) -> %% Library functions erl_libs() -> - string:tokens(os:getenv("ERL_LIBS", ""), ":;"). + string:lexemes(os:getenv("ERL_LIBS", ""), ":;"). datadir(Config) -> %% Removes the trailing slash... @@ -2555,7 +2559,7 @@ latest(App) -> AppStr = atom_to_list(App), AppDirs = filelib:wildcard(filename:join(code:lib_dir(),AppStr++"-*")), [LatestAppDir|_] = lists:reverse(AppDirs), - [_,Vsn] = string:tokens(filename:basename(LatestAppDir),"-"), + [_,Vsn] = string:lexemes(filename:basename(LatestAppDir),"-"), Vsn. rm_missing_app(Apps) -> @@ -2631,16 +2635,11 @@ os_cmd(Cmd) when is_list(Cmd) -> Return-> %% Find the position of the status code wich is last in the string %% prepended with # - case string:rchr(Return, $#) of - - %% This happens only if the sh command pipe is somehow interrupted - 0-> - {98, Return}; - - Position-> - Result = string:left(Return,Position - 1), - Status = string:substr(Return,Position + 1, length(Return) - Position - 1), - {list_to_integer(Status), Result} + case string:split(Return, "$#", trailing) of + [_] -> %% This happens only if the sh command pipe is somehow interrupted + {98, Return}; + [Result, Status0] -> + {list_to_integer(string:trim(Status0)), Result} end end. diff --git a/lib/runtime_tools/doc/src/LTTng.xml b/lib/runtime_tools/doc/src/LTTng.xml index 392d54857c..93937b3fdc 100644 --- a/lib/runtime_tools/doc/src/LTTng.xml +++ b/lib/runtime_tools/doc/src/LTTng.xml @@ -134,7 +134,7 @@ $ make </code> <p><em>port_open</em></p> <list type="bulleted"> <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> - <item><c>driver : string</c> :: Driver name. Ex. <c>"efile"</c></item> + <item><c>driver : string</c> :: Driver name. Ex. <c>"tcp_inet"</c></item> <item><c>port : string</c> :: Port ID. Ex. <c>"#Port<0.1031>"</c></item> </list> <p> @@ -323,7 +323,7 @@ $ make </code> <p><em>driver_init</em></p> <list type="bulleted"> - <item><c>driver : string</c> :: Driver name. Ex. <c>"efile"</c></item> + <item><c>driver : string</c> :: Driver name. Ex. <c>"tcp_inet"</c></item> <item><c>major : integer</c> :: Major version. Ex. <c>3</c></item> <item><c>minor : integer</c> :: Minor version. Ex. <c>1</c></item> <item><c>flags : integer</c> :: Flags. Ex. <c>1</c></item> @@ -334,7 +334,7 @@ $ make </code> <p><em>driver_start</em></p> <list type="bulleted"> <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> - <item><c>driver : string</c> :: Driver name. Ex. <c>"efile"</c></item> + <item><c>driver : string</c> :: Driver name. Ex. <c>"tcp_inet"</c></item> <item><c>port : string</c> :: Port ID. Ex. <c>"#Port<0.1031>"</c></item> </list> <p>Example:</p> @@ -344,7 +344,7 @@ $ make </code> <list type="bulleted"> <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> <item><c>port : string</c> :: Port ID. Ex. <c>"#Port<0.1031>"</c></item> - <item><c>driver : string</c> :: Driver name. Ex. <c>"efile"</c></item> + <item><c>driver : string</c> :: Driver name. Ex. <c>"tcp_inet"</c></item> <item><c>bytes : integer</c> :: Size of data returned. Ex. <c>82</c></item> </list> <p>Example:</p> @@ -354,7 +354,7 @@ $ make </code> <list type="bulleted"> <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> <item><c>port : string</c> :: Port ID. Ex. <c>"#Port<0.1031>"</c></item> - <item><c>driver : string</c> :: Driver name. Ex. <c>"efile"</c></item> + <item><c>driver : string</c> :: Driver name. Ex. <c>"tcp_inet"</c></item> <item><c>bytes : integer</c> :: Size of data returned. Ex. <c>82</c></item> </list> <p>Example:</p> @@ -364,7 +364,7 @@ $ make </code> <list type="bulleted"> <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> <item><c>port : string</c> :: Port ID. Ex. <c>"#Port<0.1031>"</c></item> - <item><c>driver : string</c> :: Driver name. Ex. <c>"efile"</c></item> + <item><c>driver : string</c> :: Driver name. Ex. <c>"tcp_inet"</c></item> </list> <p>Example:</p> <code type="none">driver_ready_input: { cpu_id = 5 }, { pid = "<0.189.0>", port = "#Port<0.3637>", driver = "inet_gethost 4 " }</code> @@ -373,7 +373,7 @@ $ make </code> <list type="bulleted"> <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> <item><c>port : string</c> :: Port ID. Ex. <c>"#Port<0.1031>"</c></item> - <item><c>driver : string</c> :: Driver name. Ex. <c>"efile"</c></item> + <item><c>driver : string</c> :: Driver name. Ex. <c>"tcp_inet"</c></item> </list> <p>Example:</p> <code type="none">driver_ready_output: { cpu_id = 5 }, { pid = "<0.194.0>", port = "#Port<0.3663>", driver = "tcp_inet" }</code> @@ -382,14 +382,14 @@ $ make </code> <list type="bulleted"> <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> <item><c>port : string</c> :: Port ID. Ex. <c>"#Port<0.1031>"</c></item> - <item><c>driver : string</c> :: Driver name. Ex. <c>"efile"</c></item> + <item><c>driver : string</c> :: Driver name. Ex. <c>"tcp_inet"</c></item> </list> <p>Example:</p> <code type="none">driver_timeout: { cpu_id = 5 }, { pid = "<0.196.0>", port = "#Port<0.3664>", driver = "tcp_inet" }</code> <p><em>driver_stop_select</em></p> <list type="bulleted"> - <item><c>driver : string</c> :: Driver name. Ex. <c>"efile"</c></item> + <item><c>driver : string</c> :: Driver name. Ex. <c>"tcp_inet"</c></item> </list> <p>Example:</p> <code type="none">driver_stop_select: { cpu_id = 5 }, { driver = "unknown" }</code> @@ -398,7 +398,7 @@ $ make </code> <list type="bulleted"> <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> <item><c>port : string</c> :: Port ID. Ex. <c>"#Port<0.1031>"</c></item> - <item><c>driver : string</c> :: Driver name. Ex. <c>"efile"</c></item> + <item><c>driver : string</c> :: Driver name. Ex. <c>"tcp_inet"</c></item> </list> <p>Example:</p> <code type="none">driver_flush: { cpu_id = 7 }, { pid = "<0.204.0>", port = "#Port<0.3686>", driver = "tcp_inet" }</code> @@ -407,32 +407,32 @@ $ make </code> <list type="bulleted"> <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> <item><c>port : string</c> :: Port ID. Ex. <c>"#Port<0.1031>"</c></item> - <item><c>driver : string</c> :: Driver name. Ex. <c>"efile"</c></item> + <item><c>driver : string</c> :: Driver name. Ex. <c>"tcp_inet"</c></item> </list> <p>Example:</p> - <code type="none">driver_stop: { cpu_id = 5 }, { pid = "[]", port = "#Port<0.3673>", driver = "efile" }</code> + <code type="none">driver_stop: { cpu_id = 5 }, { pid = "[]", port = "#Port<0.3673>", driver = "tcp_inet" }</code> <p><em>driver_process_exit</em></p> <list type="bulleted"> <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> <item><c>port : string</c> :: Port ID. Ex. <c>"#Port<0.1031>"</c></item> - <item><c>driver : string</c> :: Driver name. Ex. <c>"efile"</c></item> + <item><c>driver : string</c> :: Driver name. Ex. <c>"tcp_inet"</c></item> </list> <p><em>driver_ready_async</em></p> <list type="bulleted"> <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> <item><c>port : string</c> :: Port ID. Ex. <c>"#Port<0.1031>"</c></item> - <item><c>driver : string</c> :: Driver name. Ex. <c>"efile"</c></item> + <item><c>driver : string</c> :: Driver name. Ex. <c>"tcp_inet"</c></item> </list> <p>Example:</p> - <code type="none">driver_ready_async: { cpu_id = 3 }, { pid = "<0.181.0>", port = "#Port<0.3622>", driver = "efile" }</code> + <code type="none">driver_ready_async: { cpu_id = 3 }, { pid = "<0.181.0>", port = "#Port<0.3622>", driver = "tcp_inet" }</code> <p><em>driver_call</em></p> <list type="bulleted"> <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> <item><c>port : string</c> :: Port ID. Ex. <c>"#Port<0.1031>"</c></item> - <item><c>driver : string</c> :: Driver name. Ex. <c>"efile"</c></item> + <item><c>driver : string</c> :: Driver name. Ex. <c>"tcp_inet"</c></item> <item><c>command : integer</c> :: Command integer. Ex. <c>1</c></item> <item><c>bytes : integer</c> :: Size of data returned. Ex. <c>82</c></item> </list> @@ -443,7 +443,7 @@ $ make </code> <list type="bulleted"> <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> <item><c>port : string</c> :: Port ID. Ex. <c>"#Port<0.1031>"</c></item> - <item><c>driver : string</c> :: Driver name. Ex. <c>"efile"</c></item> + <item><c>driver : string</c> :: Driver name. Ex. <c>"tcp_inet"</c></item> <item><c>command : integer</c> :: Command integer. Ex. <c>1</c></item> <item><c>bytes : integer</c> :: Size of data returned. Ex. <c>82</c></item> </list> diff --git a/lib/runtime_tools/doc/src/Makefile b/lib/runtime_tools/doc/src/Makefile index ec19a4ce59..11583406b7 100644 --- a/lib/runtime_tools/doc/src/Makefile +++ b/lib/runtime_tools/doc/src/Makefile @@ -41,7 +41,13 @@ RELSYSDIR = $(RELEASE_PATH)/lib/$(APPLICATION)-$(VSN) # Target Specs # ---------------------------------------------------- XML_APPLICATION_FILES = ref_man.xml -XML_REF3_FILES = dbg.xml dyntrace.xml erts_alloc_config.xml system_information.xml msacc.xml +XML_REF3_FILES = \ + dbg.xml \ + dyntrace.xml \ + erts_alloc_config.xml \ + system_information.xml \ + msacc.xml \ + scheduler.xml XML_REF6_FILES = runtime_tools_app.xml XML_PART_FILES = part.xml @@ -54,8 +60,9 @@ BOOK_FILES = book.xml XML_FILES = \ $(BOOK_FILES) $(XML_CHAPTER_FILES) \ $(XML_PART_FILES) $(XML_REF3_FILES) \ - $(XML_REF6_FILES) $(XML_APPLICATION_FILES) \ - $(GENERATED_XML_FILES) + $(XML_REF6_FILES) $(XML_APPLICATION_FILES) + +XML_GEN_FILES = $(GENERATED_XML_FILES:%=$(XMLDIR)/%) GIF_FILES = @@ -91,7 +98,7 @@ SPECS_FLAGS = -I../../include -I../../../kernel/src # Targets # ---------------------------------------------------- -%.xml: $(ERL_TOP)/HOWTO/%.md $(ERL_TOP)/make/emd2exml +$(XMLDIR)/%.xml: $(ERL_TOP)/HOWTO/%.md $(ERL_TOP)/make/emd2exml $(ERL_TOP)/make/emd2exml $< $@ $(HTMLDIR)/%.gif: %.gif diff --git a/lib/runtime_tools/doc/src/dbg.xml b/lib/runtime_tools/doc/src/dbg.xml index 95f74d4607..276a41c415 100644 --- a/lib/runtime_tools/doc/src/dbg.xml +++ b/lib/runtime_tools/doc/src/dbg.xml @@ -815,7 +815,7 @@ Error: fun containing local erlang function calls ('is_atomm' called in guard)\ <v>HandlerSpec = {HandlerFun, InitialData}</v> <v>HandlerFun = fun() (two arguments)</v> <v>ModuleSpec = fun() (no arguments) | {TracerModule, TracerState}</v> - <v>ModuleModule = atom()</v> + <v>TracerModule = atom()</v> <v>InitialData = TracerState = term()</v> </type> <desc> diff --git a/lib/runtime_tools/doc/src/ref_man.xml b/lib/runtime_tools/doc/src/ref_man.xml index d2fb7a29af..eb3a6f0f5c 100644 --- a/lib/runtime_tools/doc/src/ref_man.xml +++ b/lib/runtime_tools/doc/src/ref_man.xml @@ -37,6 +37,7 @@ <xi:include href="dyntrace.xml"/> <xi:include href="erts_alloc_config.xml"/> <xi:include href="msacc.xml"/> + <xi:include href="scheduler.xml"/> <xi:include href="system_information.xml"/> </application> diff --git a/lib/runtime_tools/doc/src/scheduler.xml b/lib/runtime_tools/doc/src/scheduler.xml new file mode 100644 index 0000000000..dd8bf73bae --- /dev/null +++ b/lib/runtime_tools/doc/src/scheduler.xml @@ -0,0 +1,135 @@ +<?xml version="1.0" encoding="utf-8" ?> +<!DOCTYPE erlref SYSTEM "erlref.dtd"> + +<erlref> + <header> + <copyright> + <year>2018</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></title> + <prepared></prepared> + <responsible></responsible> + <docno>1</docno> + <approved></approved> + <checked></checked> + <date></date> + <rev></rev> + <file>scheduler.xml</file> + </header> + <module>scheduler</module> + <modulesummary>Measure scheduler utilization</modulesummary> + <description> + <p>This module contains utility functions for easier measurement and + calculation of scheduler utilization, otherwise obtained from calling the + more primitive <seealso marker="erts:erlang#statistics_scheduler_wall_time"> + <c>statistics(scheduler_wall_time)</c></seealso>.</p> + <p>The simplest usage is to call <seealso marker="#utilization-1"> + <c>scheduler:utilization(Seconds)</c></seealso>.</p> + </description> + + <datatypes> + <datatype> + <name name="sched_sample"/> + </datatype> + <datatype> + <name name="sched_type"/> + </datatype> + <datatype> + <name name="sched_id"/> + </datatype> + <datatype> + <name name="sched_util_result"/> + <desc> + <p>A list of tuples containing results for individual schedulers + as well as aggregated averages. <c>Util</c> is the scheduler utilization + as a floating point value between 0.0 and 1.0. <c>Percent</c> is the + same utilization as a more human readable string expressed in percent.</p> + <taglist> + <tag><c>{normal, SchedulerId, Util, Percent}</c></tag> + <item>Scheduler utilization of a normal scheduler with number + <c>SchedulerId</c>.</item> + <tag><c>{cpu, SchedulerId, Util, Percent}</c></tag> + <item>Scheduler utilization of a dirty-cpu scheduler with number + <c>SchedulerId</c>.</item> + <tag><c>{io, SchedulerId, Util, Percent}</c></tag> + <item>Scheduler utilization of a dirty-io scheduler with number + <c>SchedulerId</c>. This tuple will only exist if both samples were + taken with <seealso marker="#sample_all-0"><c>sample_all/0</c></seealso>.</item> + <tag><c>{total, Util, Percent}</c></tag> + <item>Total utilization of all normal and dirty-cpu schedulers.</item> + <tag><c>{weighted, Util, Percent}</c></tag> + <item>Total utilization of all normal and dirty-cpu schedulers, + weighted against maximum amount of available CPU time.</item> + </taglist> + </desc> + </datatype> + </datatypes> + + <funcs> + + <func> + <name name="sample" arity="0"/> + <fsummary>Get scheduler utilization sample.</fsummary> + <desc> + <p>Return a scheduler utilization sample for normal and dirty-cpu + schedulers.</p> + </desc> + </func> + + <func> + <name name="sample_all" arity="0"/> + <fsummary>Get scheduler utilization sample.</fsummary> + <desc> + <p>Return a scheduler utilization sample for all schedulers, + including dirty-io schedulers.</p> + </desc> + </func> + + <func> + <name name="utilization" arity="1" clause_i="1"/> + <fsummary>Measure scheduler utilizations during a period of time.</fsummary> + <desc> + <p>Measure utilization for normal and dirty-cpu schedulers during + <c><anno>Seconds</anno></c> seconds, and then return the result.</p> + </desc> + </func> + + <func> + <name name="utilization" arity="1" clause_i="2"/> + <fsummary>Measure scheduler utilizations since sample.</fsummary> + <desc> + <p>Calculate scheduler utilizations for the time interval from when + <c><anno>Sample</anno></c> was taken and "now". The same as calling + <c>scheduler:utilization(Sample, scheduler:sample_all())</c>.</p> + </desc> + </func> + + <func> + <name name="utilization" arity="2"/> + <fsummary>Measure scheduler utilizations between two samples.</fsummary> + <desc> + <p>Calculates scheduler utilizations for the time interval between + the two samples obtained from calling + <seealso marker="#sample-0"><c>sample/0</c></seealso> or + <seealso marker="#sample_all-0"><c>sample_all/0</c></seealso>.</p> + </desc> + </func> + + </funcs> + </erlref> diff --git a/lib/runtime_tools/doc/src/specs.xml b/lib/runtime_tools/doc/src/specs.xml index 978bd39e55..33fe7fa370 100644 --- a/lib/runtime_tools/doc/src/specs.xml +++ b/lib/runtime_tools/doc/src/specs.xml @@ -2,4 +2,5 @@ <specs xmlns:xi="http://www.w3.org/2001/XInclude"> <xi:include href="../specs/specs_system_information.xml"/> <xi:include href="../specs/specs_msacc.xml"/> + <xi:include href="../specs/specs_scheduler.xml"/> </specs> diff --git a/lib/runtime_tools/examples/efile_drv.d b/lib/runtime_tools/examples/efile_drv.d deleted file mode 100644 index a470518dd9..0000000000 --- a/lib/runtime_tools/examples/efile_drv.d +++ /dev/null @@ -1,105 +0,0 @@ -/* example usage: dtrace -q -s /path/to/efile_drv.d */ -/* - * %CopyrightBegin% - * - * Copyright Scott Lystig Fritchie 2011-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% - */ - -BEGIN -{ - op_map[1] = "OPEN"; - op_map[2] = "READ"; - op_map[3] = "LSEEK"; - op_map[4] = "WRITE"; - op_map[5] = "FSTAT"; - op_map[6] = "PWD"; - op_map[7] = "READDIR"; - op_map[8] = "CHDIR"; - op_map[9] = "FSYNC"; - op_map[10] = "MKDIR"; - op_map[11] = "DELETE"; - op_map[12] = "RENAME"; - op_map[13] = "RMDIR"; - op_map[14] = "TRUNCATE"; - op_map[15] = "READ_FILE"; - op_map[16] = "WRITE_INFO"; - op_map[19] = "LSTAT"; - op_map[20] = "READLINK"; - op_map[21] = "LINK"; - op_map[22] = "SYMLINK"; - op_map[23] = "CLOSE"; - op_map[24] = "PWRITEV"; - op_map[25] = "PREADV"; - op_map[26] = "SETOPT"; - op_map[27] = "IPREAD"; - op_map[28] = "ALTNAME"; - op_map[29] = "READ_LINE"; - op_map[30] = "FDATASYNC"; - op_map[31] = "FADVISE"; -} - -erlang*:::aio_pool-add -{ - printf("async I/O pool port %s queue len %d\n", copyinstr(arg0), arg1); -} - -erlang*:::aio_pool-get -{ - printf("async I/O pool port %s queue len %d\n", copyinstr(arg0), arg1); -} - -erlang*:::efile_drv-entry -{ - printf("efile_drv enter tag={%d,%d} %s%s | %s (%d) | args: %s %s , %d %d (port %s)\n", - arg0, arg1, - arg2 == NULL ? "" : "user tag ", - arg2 == NULL ? "" : copyinstr(arg2), - op_map[arg3], arg3, - arg4 == NULL ? "" : copyinstr(arg4), - arg5 == NULL ? "" : copyinstr(arg5), arg6, arg7, - /* NOTE: port name in args[10] is experimental */ - (args[10] == NULL) ? - "?" : copyinstr((user_addr_t) args[10])); -} - -erlang*:::efile_drv-int* -{ - printf("async I/O worker tag={%d,%d} | %s (%d) | %s\n", - arg0, arg1, op_map[arg2], arg2, probename); -} - -/* efile_drv-return error case */ -erlang*:::efile_drv-return -/arg4 == 0/ -{ - printf("efile_drv return tag={%d,%d} %s%s | %s (%d) | errno %d\n", - arg0, arg1, - arg2 == NULL ? "" : "user tag ", - arg2 == NULL ? "" : copyinstr(arg2), - op_map[arg3], arg3, - arg5); -} - -/* efile_drv-return success case */ -erlang*:::efile_drv-return -/arg4 != 0/ -{ - printf("efile_drv return tag={%d,%d} %s | %s (%d) ok\n", - arg0, arg1, - arg2 == NULL ? "" : copyinstr(arg2), - op_map[arg3], arg3); -} diff --git a/lib/runtime_tools/examples/efile_drv.systemtap b/lib/runtime_tools/examples/efile_drv.systemtap deleted file mode 100644 index 29c3637e10..0000000000 --- a/lib/runtime_tools/examples/efile_drv.systemtap +++ /dev/null @@ -1,113 +0,0 @@ -/* - * %CopyrightBegin% - * - * Copyright Scott Lystig Fritchie and Andreas Schultz, 2011-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% - */ -/* - * Note: This file assumes that you're using the non-SMP-enabled Erlang - * virtual machine, "beam". The SMP-enabled VM is called "beam.smp". - * Note that other variations of the virtual machine also have - * different names, e.g. the debug build of the SMP-enabled VM - * is "beam.debug.smp". - * - * To use a different virtual machine, replace each instance of - * "beam" with "beam.smp" or the VM name appropriate to your - * environment. - */ - -probe begin -{ - op_map[1] = "OPEN"; - op_map[2] = "READ"; - op_map[3] = "LSEEK"; - op_map[4] = "WRITE"; - op_map[5] = "FSTAT"; - op_map[6] = "PWD"; - op_map[7] = "READDIR"; - op_map[8] = "CHDIR"; - op_map[9] = "FSYNC"; - op_map[10] = "MKDIR"; - op_map[11] = "DELETE"; - op_map[12] = "RENAME"; - op_map[13] = "RMDIR"; - op_map[14] = "TRUNCATE"; - op_map[15] = "READ_FILE"; - op_map[16] = "WRITE_INFO"; - op_map[19] = "LSTAT"; - op_map[20] = "READLINK"; - op_map[21] = "LINK"; - op_map[22] = "SYMLINK"; - op_map[23] = "CLOSE"; - op_map[24] = "PWRITEV"; - op_map[25] = "PREADV"; - op_map[26] = "SETOPT"; - op_map[27] = "IPREAD"; - op_map[28] = "ALTNAME"; - op_map[29] = "READ_LINE"; - op_map[30] = "FDATASYNC"; - op_map[31] = "FADVISE"; -} - -probe process("beam").mark("aio_pool-add") -{ - printf("async I/O pool port %s queue len %d\n", user_string($arg1), $arg2); -} - -probe process("beam").mark("aio_pool-get") -{ - printf("async I/O pool port %s queue len %d\n", user_string($arg1), $arg2); -} - -probe process("beam").mark("efile_drv-entry") -{ - printf("efile_drv enter tag={%d,%d} %s%s | %s (%d) | args: %s %s , %d %d (port %s)\n", - $arg1, $arg2, - $arg3 == NULL ? "" : "user tag ", - $arg3 == NULL ? "" : user_string($arg3), - op_map[$arg4], $arg4, - $arg5 == NULL ? "" : user_string($arg5), - $arg6 == NULL ? "" : user_string($arg6), $arg7, $arg8, - /* NOTE: port name in $arg[11] is experimental */ - user_string($arg11)) -} - -probe process("beam").mark("efile_drv-int*") -{ - printf("async I/O worker tag={%d,%d} | %s (%d) | %s\n", - $arg1, $arg2, op_map[$arg3], $arg3, probefunc()); -} - -probe process("beam").mark("efile_drv-return") -{ - if ($arg5 == 0) { - /* efile_drv-return error case */ - printf("efile_drv return tag={%d,%d} %s%s | %s (%d) | errno %d\n", - $arg1, $arg2, - $arg3 == NULL ? "" : "user tag ", - $arg3 == NULL ? "" : user_string($arg3), - op_map[$arg4], $arg4, - $arg6); - } else { - /* efile_drv-return success case */ - printf("efile_drv return tag={%d,%d} %s | %s (%d) ok\n", - $arg1, $arg2, - $arg3 == NULL ? "" : user_string($arg3), - op_map[$arg4], $arg4); - } -} - -global op_map; diff --git a/lib/runtime_tools/src/Makefile b/lib/runtime_tools/src/Makefile index 5a99c6e240..6faa9c2e35 100644 --- a/lib/runtime_tools/src/Makefile +++ b/lib/runtime_tools/src/Makefile @@ -45,6 +45,7 @@ MODULES= \ system_information \ observer_backend \ ttb_autostart\ + scheduler\ msacc HRL_FILES= ../include/observer_backend.hrl diff --git a/lib/runtime_tools/src/erts_alloc_config.erl b/lib/runtime_tools/src/erts_alloc_config.erl index 4b028681a0..6c1a945484 100644 --- a/lib/runtime_tools/src/erts_alloc_config.erl +++ b/lib/runtime_tools/src/erts_alloc_config.erl @@ -627,7 +627,7 @@ format_header(FTO) -> [Y, Mo, D, H, Mi, S]), fcp(FTO, "~s was used when generating the configuration.", - [string:strip(erlang:system_info(system_version), both, $\n)]), + [string:trim(erlang:system_info(system_version), both, "$\n")]), case erlang:system_info(schedulers) of 1 -> ok; Schdlrs -> @@ -704,28 +704,32 @@ fc(IODev, Frmt, Args) -> fc(IODev, lists:flatten(io_lib:format(Frmt, Args))). fc(IODev, String) -> - fc_aux(IODev, string:tokens(String, " "), 0). + fc_aux(IODev, string:lexemes(String, " "), 0). fc_aux(_IODev, [], 0) -> ok; fc_aux(IODev, [], _Len) -> format(IODev, "~n"); fc_aux(IODev, [T|Ts], 0) -> - Len = 2 + length(T), + Len = 2 + string:length(T), format(IODev, "# ~s", [T]), fc_aux(IODev, Ts, Len); -fc_aux(IODev, [T|_Ts] = ATs, Len) when (length(T) + Len) >= ?PRINT_WITDH -> - format(IODev, "~n"), - fc_aux(IODev, ATs, 0); -fc_aux(IODev, [T|Ts], Len) -> - NewLen = Len + 1 + length(T), - format(IODev, " ~s", [T]), - fc_aux(IODev, Ts, NewLen). +fc_aux(IODev, [T|Ts] = ATs, Len) -> + TLength = string:length(T), + case (TLength + Len) >= ?PRINT_WITDH of + true -> + format(IODev, "~n"), + fc_aux(IODev, ATs, 0); + false -> + NewLen = Len + 1 + TLength, + format(IODev, " ~s", [T]), + fc_aux(IODev, Ts, NewLen) + end. %% fcl: format comment line fcl(FTO) -> EndStr = "# ", - Precision = length(EndStr), + Precision = string:length(EndStr), FieldWidth = -1*(?PRINT_WITDH), format(FTO, "~*.*.*s~n", [FieldWidth, Precision, $-, EndStr]). @@ -733,6 +737,6 @@ fcl(FTO, A) when is_atom(A) -> fcl(FTO, atom_to_list(A)); fcl(FTO, Str) when is_list(Str) -> Str2 = "# --- " ++ Str ++ " ", - Precision = length(Str2), + Precision = string:length(Str2), FieldWidth = -1*(?PRINT_WITDH), format(FTO, "~*.*.*s~n", [FieldWidth, Precision, $-, Str2]). diff --git a/lib/runtime_tools/src/msacc.erl b/lib/runtime_tools/src/msacc.erl index 0d9b2690e5..37887cee72 100644 --- a/lib/runtime_tools/src/msacc.erl +++ b/lib/runtime_tools/src/msacc.erl @@ -46,7 +46,8 @@ system := float()}}. --type msacc_type() :: scheduler | aux | async. +-type msacc_type() :: aux | async | dirty_cpu_scheduler + | dirty_io_scheduler | poll | scheduler. -type msacc_id() :: non_neg_integer(). -type msacc_state() :: alloc | aux | bif | busy_wait | check_io | emulator | ets | gc | gc_fullsweep | nif | diff --git a/lib/runtime_tools/src/observer_backend.erl b/lib/runtime_tools/src/observer_backend.erl index 1b075a507d..7ec3b38930 100644 --- a/lib/runtime_tools/src/observer_backend.erl +++ b/lib/runtime_tools/src/observer_backend.erl @@ -279,7 +279,7 @@ get_table_list(mnesia, Opts) -> end, [Tab|Acc] catch _:_What -> - %% io:format("Skipped ~p: ~p ~p ~n",[Id, _What, erlang:get_stacktrace()]), + %% io:format("Skipped ~p: ~p ~p ~n",[Id, _What, Stacktrace]), Acc end end, @@ -293,7 +293,7 @@ fetch_stats_loop(Parent, Time) -> erlang:system_flag(scheduler_wall_time, true), receive _Msg -> - %% erlang:system_flag(scheduler_wall_time, false) + erlang:system_flag(scheduler_wall_time, false), ok after Time -> _M = Parent ! {stats, 1, @@ -340,7 +340,6 @@ etop_collect(Collector) -> case SchedulerWallTime of undefined -> - erlang:system_flag(scheduler_wall_time,true), spawn(fun() -> flag_holder_proc(Collector) end), ok; _ -> @@ -348,10 +347,11 @@ etop_collect(Collector) -> end. flag_holder_proc(Collector) -> + erlang:system_flag(scheduler_wall_time,true), Ref = erlang:monitor(process,Collector), receive {'DOWN',Ref,_,_,_} -> - %% erlang:system_flag(scheduler_wall_time,false) + erlang:system_flag(scheduler_wall_time,false), ok end. diff --git a/lib/runtime_tools/src/runtime_tools.app.src b/lib/runtime_tools/src/runtime_tools.app.src index 449532e5c4..09a9b447c2 100644 --- a/lib/runtime_tools/src/runtime_tools.app.src +++ b/lib/runtime_tools/src/runtime_tools.app.src @@ -23,6 +23,7 @@ {modules, [appmon_info, dbg,observer_backend,runtime_tools, runtime_tools_sup,erts_alloc_config, ttb_autostart,dyntrace,system_information, + scheduler, msacc]}, {registered, [runtime_tools_sup]}, {applications, [kernel, stdlib]}, diff --git a/lib/runtime_tools/src/scheduler.erl b/lib/runtime_tools/src/scheduler.erl new file mode 100644 index 0000000000..c896b671ac --- /dev/null +++ b/lib/runtime_tools/src/scheduler.erl @@ -0,0 +1,152 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2018. 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% +%% + +%% @doc Utility functions for easier measurement of scheduler utilization +%% using erlang:statistics(scheduler_wall_time). + +-module(scheduler). + +-export([sample/0, + sample_all/0, + utilization/1, + utilization/2]). + +-export_type([sched_sample/0]). + + +-opaque sched_sample() :: + {scheduler_wall_time | scheduler_wall_time_all, + [{sched_type(), sched_id(), ActiveTime::integer(), TotalTime::integer()}]}. + +-type sched_type() :: normal | cpu | io. + +-type sched_id() :: integer(). + +-spec sample() -> sched_sample(). +sample() -> + sample(scheduler_wall_time). + +-spec sample_all() -> sched_sample(). +sample_all() -> + sample(scheduler_wall_time_all). + +sample(Stats) -> + case erlang:statistics(Stats) of + undefined -> + erlang:system_flag(scheduler_wall_time, true), + sample(Stats); + + List -> + Sorted = lists:sort(List), + Tagged = lists:map(fun({I, A, T}) -> {sched_tag(I), I, A, T} end, + Sorted), + {Stats, Tagged} + end. + +-type sched_util_result() :: + [{sched_type(), sched_id(), float(), string()} | + {total, float(), string()} | + {weighted, float(), string()}]. + +-spec utilization(Seconds) -> sched_util_result() when + Seconds :: pos_integer(); + (Sample) -> sched_util_result() when + Sample :: sched_sample(). +utilization(Seconds) when is_integer(Seconds), Seconds > 0 -> + OldFlag = erlang:system_flag(scheduler_wall_time, true), + T0 = sample(), + receive after Seconds*1000 -> ok end, + T1 = sample(), + case OldFlag of + false -> + erlang:system_flag(scheduler_wall_time, OldFlag); + true -> + ok + end, + utilization(T0,T1); + +utilization({Stats, _}=T0) when Stats =:= scheduler_wall_time; + Stats =:= scheduler_wall_time_all -> + utilization(T0, sample(Stats)). + +-spec utilization(Sample1, Sample2) -> sched_util_result() when + Sample1 :: sched_sample(), + Sample2 :: sched_sample(). +utilization({Stats, Ts0}, {Stats, Ts1}) -> + Diffs = lists:map(fun({{Tag, I, A0, T0}, {Tag, I, A1, T1}}) -> + {Tag, I, (A1 - A0), (T1 - T0)} + end, + lists:zip(Ts0,Ts1)), + + {Lst0, {A, T, N}} = lists:foldl(fun({Tag, I, Adiff, Tdiff}, {Lst, Acc}) -> + R = safe_div(Adiff, Tdiff), + {[{Tag, I, R, percent(R)} | Lst], + acc(Tag, Adiff, Tdiff, Acc)} + end, + {[], {0, 0, 0}}, + Diffs), + + Total = safe_div(A, T), + Lst1 = lists:reverse(Lst0), + Lst2 = case erlang:system_info(logical_processors_available) of + unknown -> Lst1; + LPA -> + Weighted = Total * (N / LPA), + [{weighted, Weighted, percent(Weighted)} | Lst1] + end, + [{total, Total, percent(Total)} | Lst2]; + +utilization({scheduler_wall_time, _}=T0, + {scheduler_wall_time_all, Ts1}) -> + utilization(T0, {scheduler_wall_time, remove_io(Ts1)}); + +utilization({scheduler_wall_time_all, Ts0}, + {scheduler_wall_time, _}=T1) -> + utilization({scheduler_wall_time, remove_io(Ts0)}, T1). + +%% Do not include dirty-io in totals +acc(io, _, _, Acc) -> + Acc; +acc(Tag, Adiff, Tdiff, {Asum, Tsum, N}) when Tag =:= normal; Tag =:= cpu -> + {Adiff+Asum, Tdiff+Tsum, N+1}. + + +remove_io(Ts) -> + lists:filter(fun({io,_,_,_}) -> false; + (_) -> true end, + Ts). + +safe_div(A, B) -> + if B == 0.0 -> 0.0; + true -> A / B + end. + +sched_tag(Nr) -> + Normal = erlang:system_info(schedulers), + Cpu = Normal + erlang:system_info(dirty_cpu_schedulers), + case Nr of + _ when Nr =< Normal -> normal; + _ when Nr =< Cpu -> cpu; + _ -> io + end. + + +percent(F) -> + float_to_list(F*100, [{decimals,1}]) ++ [$%]. diff --git a/lib/runtime_tools/src/system_information.erl b/lib/runtime_tools/src/system_information.erl index 3772fcd2f9..136ee55b54 100644 --- a/lib/runtime_tools/src/system_information.erl +++ b/lib/runtime_tools/src/system_information.erl @@ -674,12 +674,12 @@ vsnstr2vsn(VsnStr) -> list_to_tuple(lists:map(fun (Part) -> list_to_integer(Part) end, - string:tokens(VsnStr, "."))). + string:lexemes(VsnStr, "."))). rtdepstrs2rtdeps([]) -> []; rtdepstrs2rtdeps([RTDep | RTDeps]) -> - [AppStr, VsnStr] = string:tokens(RTDep, "-"), + [AppStr, VsnStr] = string:lexemes(RTDep, "-"), [{list_to_atom(AppStr), vsnstr2vsn(VsnStr)} | rtdepstrs2rtdeps(RTDeps)]. build_app_table([], AppTab) -> diff --git a/lib/runtime_tools/test/Makefile b/lib/runtime_tools/test/Makefile index 61377ea09e..29cf7545c9 100644 --- a/lib/runtime_tools/test/Makefile +++ b/lib/runtime_tools/test/Makefile @@ -9,7 +9,9 @@ MODULES = \ system_information_SUITE \ dbg_SUITE \ erts_alloc_config_SUITE \ - msacc_SUITE + scheduler_SUITE \ + msacc_SUITE \ + zzz_SUITE ERL_FILES= $(MODULES:%=%.erl) diff --git a/lib/runtime_tools/test/dbg_SUITE.erl b/lib/runtime_tools/test/dbg_SUITE.erl index 4b0864858c..c5dcccb887 100644 --- a/lib/runtime_tools/test/dbg_SUITE.erl +++ b/lib/runtime_tools/test/dbg_SUITE.erl @@ -23,7 +23,7 @@ -export([all/0, suite/0, big/1, tiny/1, simple/1, message/1, distributed/1, port/1, send/1, recv/1, - ip_port/1, file_port/1, file_port2/1, file_port_schedfix/1, + ip_port/1, file_port/1, file_port2/1, ip_port_busy/1, wrap_port/1, wrap_port_time/1, with_seq_trace/1, dead_suspend/1, local_trace/1, saved_patterns/1, tracer_exit_on_stop/1, @@ -41,7 +41,7 @@ suite() -> all() -> [big, tiny, simple, message, distributed, port, ip_port, send, recv, - file_port, file_port2, file_port_schedfix, ip_port_busy, + file_port, file_port2, ip_port_busy, wrap_port, wrap_port_time, with_seq_trace, dead_suspend, local_trace, saved_patterns, tracer_exit_on_stop, erl_tracer, distributed_erl_tracer]. @@ -478,8 +478,7 @@ port(Config) when is_list(Config) -> TraceFileDrv = list_to_atom(lists:flatten(["trace_file_drv n ",TestFile])), [{trace,Port,open,S,TraceFileDrv}, {trace,Port,getting_linked,S}, - {trace,Port,closed,normal}, - {trace,Port,unlink,S}] = flush() + {trace,Port,closed,normal}] = flush() after dbg:stop() end, @@ -623,99 +622,6 @@ file_port2(Config) when is_list(Config) -> end, ok. -%% Test that the scheduling timestamp fix for trace flag 'running' works. -file_port_schedfix(Config) when is_list(Config) -> - case (catch erlang:system_info(smp_support)) of - true -> - {skip, "No schedule fix on SMP"}; - _ -> - try - file_port_schedfix1(Config) - after - dbg:stop() - end - end. -file_port_schedfix1(Config) when is_list(Config) -> - stop(), - {A,B,C} = erlang:now(), - FTMP = atom_to_list(?MODULE) ++ integer_to_list(A) ++ - "-" ++ integer_to_list(B) ++ "-" ++ integer_to_list(C), - FName = filename:join([proplists:get_value(data_dir, Config), FTMP]), - %% - Port = dbg:trace_port(file, {FName, wrap, ".wraplog", 8*1024, 4}), - {ok, _} = dbg:tracer(port, Port), - {ok,[{matched,_node,0}]} = dbg:p(new,[running,procs,send,timestamp]), - %% - %% Generate the trace data - %% - %% This starts 3 processes that sends a message to each other in a ring, - %% 4 laps. Prior to sending the message to the next in the ring, each - %% process send 8 messages to itself, just to generate some trace data, - %% and to lower the possibility that the trace log wraps just after - %% a schedule out message (which would not burden any process and hence - %% not show up in the result) - %% - %% The wrap file trace is used because it burns a lot of time when the - %% driver swaps files, a lot more than the regular file trace. The test - %% case is dimensioned so that the log fills two files and just starts - %% on the third (out of four wrap files). This gives two file swaps, - %% and there are three processes, so one process will NOT be burdened. - %% The criterion for trace success is then that the max process - %% execution time must not be more than twice the min process - %% execution time. Wallclock. A normal result is about 10 times more - %% without schedule in - schedule out compensation (OTP-3938). - %% - ok = token_volleyball(3, 4, 8), - %% - {ok,[{matched,_,_}]} = dbg:p(all, [clear]), - stop(), - %% - %% Get the trace result - %% - Tag = make_ref(), - dbg:trace_client(file, {FName, wrap, ".wraplog"}, - {fun schedstat_handler/2, {self(), Tag, []}}), - Result = - receive - {Tag, D} -> - lists:map( - fun({Pid, {A1, B1, C1}}) -> - {Pid, C1/1000000 + B1 + A1*1000000} - end, - D) - end, - ok = io:format("Result=~p", [Result]), - % erlang:display({?MODULE, ?LINE, Result}), - %% - %% Analyze the result - %% - {Min, Max} = lists:foldl(fun({_Pid, M}, {Mi, Ma}) -> - {if M < Mi -> M; true -> Mi end, - if M > Ma -> M; true -> Ma end} - end, - {void, 0}, - Result), - % More PaN debug - io:format("Min = ~f, Max = ~f~n",[Min,Max]), - %% - %% Cleanup - %% - ToBeDeleted = filelib:wildcard(FName++"*"++".wraplog"), - lists:map(fun file:delete/1, ToBeDeleted), - % io:format("ToBeDeleted=~p", [ToBeDeleted]), - %% - %% Present the result - %% - P = (Max / Min - 1) * 100, - BottomLine = lists:flatten(io_lib:format("~.2f %", [P])), - if P > 100 -> - Reason = {BottomLine, '>', "100%"}, - erlang:display({file_port_schedfix, fail, Reason}), - ct:fail(Reason); - true -> - {comment, BottomLine} - end. - %% Test tracing to wrapping file port wrap_port(Config) when is_list(Config) -> Self = self(), diff --git a/lib/runtime_tools/test/dyntrace_SUITE.erl b/lib/runtime_tools/test/dyntrace_SUITE.erl index 7be2f49a8b..7ffbe54446 100644 --- a/lib/runtime_tools/test/dyntrace_SUITE.erl +++ b/lib/runtime_tools/test/dyntrace_SUITE.erl @@ -51,11 +51,7 @@ init_per_suite(Config) -> case erlang:system_info(debug_compiled) of false -> ""; true -> ".debug" - end ++ - case erlang:system_info(smp_support) of - false -> ""; - true -> ".smp" - end, + end ++ ".smp", [{emu_name,N}|Config]. end_per_suite(_Config) -> diff --git a/lib/runtime_tools/test/scheduler_SUITE.erl b/lib/runtime_tools/test/scheduler_SUITE.erl new file mode 100644 index 0000000000..1c80253371 --- /dev/null +++ b/lib/runtime_tools/test/scheduler_SUITE.erl @@ -0,0 +1,104 @@ +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2018. 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(scheduler_SUITE). + +-export([suite/0, all/0]). + +%% Test cases +-export([basic/1]). + +all() -> [basic]. + + +suite() -> [{ct_hooks,[ts_install_cth]}]. + + +basic(_Config) -> + S1 = scheduler:sample(), + S2 = scheduler:sample_all(), + + check(scheduler:utilization(1)), + + check(scheduler:utilization(S1)), + check(scheduler:utilization(S2)), + check(scheduler:utilization(S1, scheduler:sample())), + check(scheduler:utilization(S2, scheduler:sample())), + + S3 = scheduler:sample_all(), + U13 = scheduler:utilization(S1, S3), + U13 = scheduler:utilization(S1, remove_io(S3)), + check(U13), + + U23all = scheduler:utilization(S2, S3), + check(U23all), + U23 = scheduler:utilization(S2, remove_io(S3)), + U23 = scheduler:utilization(remove_io(S2), S3), + U23 = remove_io(U23all), + check(U23), + + ok. + + +check([{total, Tf, Ts} | List]=U) -> + io:format("\nU = ~p\n", [U]), + check_values(Tf, Ts, true), + + SchdList = case hd(List) of + {weighted, Wf, Ws} -> + check_values(Wf, Ws, false), + tl(List); + _ -> + unknown = erlang:system_info(logical_processors_available), + List + end, + + lists:foreach(fun({Type, Id, F, S}) when ((Type =:= normal) or (Type =:= cpu) or (Type =:= io)), + is_integer(Id) -> + check_values(F, S, true) + end, + SchdList), + ok. + +check_values(F, S, Max100) -> + true = is_float(F), + true = F >= 0.0, + + $% = lists:last(S), + Sf = list_to_float(lists:droplast(S)), + true = Sf >= 0.0, + true = case Max100 of + true -> + true = F =< 1.0, + true = Sf =< 100.0; + false -> + true + end, + MaxDiff = 0.055555555555555555, %% change to 0.05 when float_to_list/2 is fixed + true = abs(F*100 - Sf) =< MaxDiff, + ok. + + +remove_io({scheduler_wall_time_all,Lst}) -> + {scheduler_wall_time, remove_io(Lst)}; +remove_io(Lst) -> + lists:filter(fun({io,_,_,_}) -> false; + (_) -> true end, + Lst). diff --git a/lib/runtime_tools/test/zzz_SUITE.erl b/lib/runtime_tools/test/zzz_SUITE.erl new file mode 100644 index 0000000000..59c7fd7404 --- /dev/null +++ b/lib/runtime_tools/test/zzz_SUITE.erl @@ -0,0 +1,37 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2006-2018. 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(zzz_SUITE). + +%% The sole purpose of this test suite is for things we want to run last +%% before the VM terminates. + +-export([all/0]). + +-export([lc_graph/1]). + + +all() -> + [lc_graph]. + +lc_graph(_Config) -> + %% Create "lc_graph" file in current working dir + %% if lock checker is enabled. + erts_debug:lc_graph(), + ok. diff --git a/lib/sasl/doc/src/notes.xml b/lib/sasl/doc/src/notes.xml index e532c3cd6f..791e9c063a 100644 --- a/lib/sasl/doc/src/notes.xml +++ b/lib/sasl/doc/src/notes.xml @@ -31,6 +31,26 @@ </header> <p>This document describes the changes made to the SASL application.</p> +<section><title>SASL 3.1.2</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> + When upgrading with instruction 'restart_new_emulator', + the generated temporary boot file used 'kernelProcess' + statements from the old release instead of the new + release. This is now corrected.</p> + <p> + This correction is needed for upgrade to OTP-21.</p> + <p> + Own Id: OTP-15017</p> + </item> + </list> + </section> + +</section> + <section><title>SASL 3.1.1</title> <section><title>Fixed Bugs and Malfunctions</title> diff --git a/lib/sasl/doc/src/release_handler.xml b/lib/sasl/doc/src/release_handler.xml index 8f073807fb..975188f489 100644 --- a/lib/sasl/doc/src/release_handler.xml +++ b/lib/sasl/doc/src/release_handler.xml @@ -61,6 +61,7 @@ <list type="bulleted"> <item>A release upgrade file, <c>relup</c></item> <item>A system configuration file, <c>sys.config</c></item> + <item>A system configuration source file, <c>sys.config.src</c></item> </list> <p>The <c>relup</c> file contains instructions for how to upgrade to, or downgrade from, this version of the release.</p> @@ -819,4 +820,3 @@ release_handler:set_unpacked(RelFile, [{myapp,"1.0","/home/user"},...]). <seealso marker="systools"><c>systools(3)</c></seealso></p> </section> </erlref> - diff --git a/lib/sasl/doc/src/systools.xml b/lib/sasl/doc/src/systools.xml index e7c3c499da..4842c732b1 100644 --- a/lib/sasl/doc/src/systools.xml +++ b/lib/sasl/doc/src/systools.xml @@ -349,10 +349,11 @@ myapp-1/ebin/myapp.app the release version as specified in <c>Name.rel</c>.</p> <p><c>releases/RelVsn</c> contains the boot script <c>Name.boot</c> renamed to <c>start.boot</c> and, if found, - the files <c>relup</c> and <c>sys.config</c>. These files + the files <c>relup</c> and <c>sys.config</c> or <c>sys.config.src</c>. These files are searched for in the same directory as <c>Name.rel</c>, in the current working directory, and in any directories - specified using option <c>path</c>.</p> + specified using option <c>path</c>. In the case of <c>sys.config</c> + it is not included if <c>sys.config.src</c> is found.</p> <p>If the release package is to contain a new Erlang runtime system, the <c>bin</c> directory of the specified runtime system <c>{erts,Dir}</c> is copied to <c>erts-ErtsVsn/bin</c>.</p> @@ -397,4 +398,3 @@ myapp-1/ebin/myapp.app <seealso marker="script"><c>script(4)</c></seealso></p> </section> </erlref> - diff --git a/lib/sasl/src/Makefile b/lib/sasl/src/Makefile index ac7ee51100..45cd814bf8 100644 --- a/lib/sasl/src/Makefile +++ b/lib/sasl/src/Makefile @@ -37,7 +37,7 @@ RELSYSDIR = $(RELEASE_PATH)/lib/sasl-$(VSN) MODULES= alarm_handler sasl sasl_report \ sasl_report_file_h sasl_report_tty_h format_lib_supp \ misc_supp rb rb_format_supp release_handler \ - release_handler_1 si si_sasl_supp systools \ + release_handler_1 systools \ systools_make systools_rc systools_relup systools_lib \ erlsrv diff --git a/lib/sasl/src/erlsrv.erl b/lib/sasl/src/erlsrv.erl index 29d40d362f..e0bbd37ee3 100644 --- a/lib/sasl/src/erlsrv.erl +++ b/lib/sasl/src/erlsrv.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1998-2016. All Rights Reserved. +%% Copyright Ericsson AB 1998-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,7 +34,7 @@ erlsrv(EVer) -> filename:join([Root, "erts-" ++ EVer, "bin", "erlsrv.exe"]). current_version() -> - hd(string:tokens(erlang:system_info(version),"_ ")). + hd(string:lexemes(erlang:system_info(version),"_ ")). %%% Returns {ok, Output} | failed | {error, Reason} run_erlsrv(Command) -> @@ -107,7 +107,7 @@ get_all_services() -> []; {ok, [_H|T]} -> F = fun(X) -> - hd(string:tokens(X,"\t ")) + hd(string:lexemes(X,"\t ")) end, lists:map(F,T); _ -> @@ -191,8 +191,8 @@ get_service(EVer, ServiceName) -> %%% have in the environment list... EnvParts = lists:map( fun(S) -> - X = string:strip(S,left,$\t), - case hd(string:tokens(X,"=")) of + X = string:trim(S, leading, "$\t"), + case hd(string:lexemes(X,"=")) of X -> %% Can this happen? {X,""}; @@ -371,7 +371,7 @@ split_arglist([H|T]) -> parse_arglist(Str) -> lists:reverse(parse_arglist(Str,[])). parse_arglist(Str,Accum) -> - Stripped = string:strip(Str,left), + Stripped = string:trim(Str, leading), case length(Stripped) of 0 -> Accum; @@ -432,14 +432,9 @@ split_by_env(Data) -> splitline(Line) -> - case string:chr(Line,$:) of - 0 -> + case string:split(Line, ":") of + [_] -> {Line, ""}; - N -> - case length(string:substr(Line,N)) of - 1 -> - {string:substr(Line,1,N-1),""}; - _ -> - {string:substr(Line,1,N-1),string:substr(Line,N+2)} - end + [N, V] -> + {N, string:slice(V, 1)} end. diff --git a/lib/sasl/src/format_lib_supp.erl b/lib/sasl/src/format_lib_supp.erl index 00ce1b4e33..2d37dfe117 100644 --- a/lib/sasl/src/format_lib_supp.erl +++ b/lib/sasl/src/format_lib_supp.erl @@ -102,13 +102,13 @@ print_newlines(Device, N) when N > 0 -> print_one_line(Device, Line, Key, Value) -> Modifier = misc_supp:modifier(Device), StrKey = term_to_string(Key,Modifier), - KeyLen = lists:min([length(StrKey), Line]), + KeyLen = lists:min([string:length(StrKey), Line]), ValueLen = Line - KeyLen, Format1 = lists:concat(["~-", KeyLen, Modifier, "s"]), Format2 = lists:concat(["~", ValueLen, Modifier, "s~n"]), io:format(Device, Format1, [StrKey]), Try = term_to_string(Value,Modifier), - Length = length(Try), + Length = string:length(Try), if Length < ValueLen -> io:format(Device, Format2, [Try]); @@ -119,7 +119,7 @@ print_one_line(Device, Line, Key, Value) -> end. term_to_string(Value,Modifier) -> - lists:flatten(io_lib:format(get_format(Value,Modifier), [Value])). + io_lib:format(get_format(Value,Modifier), [Value]). get_format([],_) -> "~p"; diff --git a/lib/sasl/src/rb.erl b/lib/sasl/src/rb.erl index 6595d29a9c..28829132a1 100644 --- a/lib/sasl/src/rb.erl +++ b/lib/sasl/src/rb.erl @@ -586,14 +586,14 @@ find_widths([], _Modifier, DescrWidth, DateWidth, Data) -> {DescrWidth+1, DateWidth+1, lists:reverse(Data)}; find_widths([H|T], Modifier, DescrWidth, DateWidth, Data) -> DescrTerm = element(3,H), - Descr = lists:flatten(io_lib:format("~"++Modifier++"w", [DescrTerm])), - DescrTry = length(Descr), + Descr = io_lib:format("~"++Modifier++"w", [DescrTerm]), + DescrTry = string:length(Descr), NewDescrWidth = if DescrTry > DescrWidth -> DescrTry; true -> DescrWidth end, - DateTry = length(element(4, H)), + DateTry = string:length(element(4, H)), NewDateWitdh = if DateTry > DateWidth -> DateTry; diff --git a/lib/sasl/src/rb_format_supp.erl b/lib/sasl/src/rb_format_supp.erl index 1eda43dae4..b5b7aba151 100644 --- a/lib/sasl/src/rb_format_supp.erl +++ b/lib/sasl/src/rb_format_supp.erl @@ -108,7 +108,7 @@ print(Date, Report, Device) -> format_h(Line, Header, Pid, Date) -> NHeader = lists:flatten(io_lib:format("~s ~w", [Header, Pid])), - DateLen = length(Date), + DateLen = string:length(Date), HeaderLen = Line - DateLen, Format = lists:concat(["~-", HeaderLen, "s~", DateLen, "s"]), io_lib:format(Format, [NHeader, Date]). diff --git a/lib/sasl/src/release_handler.erl b/lib/sasl/src/release_handler.erl index d0a7c7332d..4fd3fc0d36 100644 --- a/lib/sasl/src/release_handler.erl +++ b/lib/sasl/src/release_handler.erl @@ -420,7 +420,7 @@ upgrade_app(App, NewDir) -> %% located in the ebin dir of the _current_ version %%----------------------------------------------------------------- downgrade_app(App, OldDir) -> - case string:tokens(filename:basename(OldDir), "-") of + case string:lexemes(filename:basename(OldDir), "-") of [_AppS, OldVsn] -> downgrade_app(App, OldVsn, OldDir); _ -> @@ -1052,8 +1052,8 @@ new_emulator_make_tmp_release(CurrentRelease,ToRelease,RelDir,Opts,Masters) -> ToVsn = ToRelease#release.vsn, TmpVsn = ?tmp_vsn(CurrentVsn), case get_base_libs(ToRelease#release.libs) of - {ok,{Kernel,Stdlib,Sasl}=BaseLibs,_} -> - case get_base_libs(ToRelease#release.libs) of + {ok,{Kernel,Stdlib,Sasl},_} -> + case get_base_libs(CurrentRelease#release.libs) of {ok,_,RestLibs} -> TmpErtsVsn = ToRelease#release.erts_vsn, TmpLibs = [Kernel,Stdlib,Sasl|RestLibs], @@ -1062,7 +1062,7 @@ new_emulator_make_tmp_release(CurrentRelease,ToRelease,RelDir,Opts,Masters) -> libs = TmpLibs, status = unpacked}, new_emulator_make_hybrid_boot(CurrentVsn,ToVsn,TmpVsn, - BaseLibs,RelDir,Opts,Masters), + RelDir,Opts,Masters), new_emulator_make_hybrid_config(CurrentVsn,ToVsn,TmpVsn, RelDir,Masters), {TmpVsn,TmpRelease}; @@ -1095,7 +1095,7 @@ get_base_libs([],_Kernel,_Stdlib,undefined,_Rest) -> get_base_libs([],Kernel,Stdlib,Sasl,Rest) -> {ok,{Kernel,Stdlib,Sasl},lists:reverse(Rest)}. -new_emulator_make_hybrid_boot(CurrentVsn,ToVsn,TmpVsn,BaseLibs,RelDir,Opts,Masters) -> +new_emulator_make_hybrid_boot(CurrentVsn,ToVsn,TmpVsn,RelDir,Opts,Masters) -> FromBootFile = filename:join([RelDir,CurrentVsn,"start.boot"]), ToBootFile = filename:join([RelDir,ToVsn,"start.boot"]), TmpBootFile = filename:join([RelDir,TmpVsn,"start.boot"]), @@ -1103,11 +1103,7 @@ new_emulator_make_hybrid_boot(CurrentVsn,ToVsn,TmpVsn,BaseLibs,RelDir,Opts,Maste Args = [ToVsn,Opts], {ok,FromBoot} = read_file(FromBootFile,Masters), {ok,ToBoot} = read_file(ToBootFile,Masters), - {{_,_,KernelPath},{_,_,StdlibPath},{_,_,SaslPath}} = BaseLibs, - Paths = {filename:join(KernelPath,"ebin"), - filename:join(StdlibPath,"ebin"), - filename:join(SaslPath,"ebin")}, - case systools_make:make_hybrid_boot(TmpVsn,FromBoot,ToBoot,Paths,Args) of + case systools_make:make_hybrid_boot(TmpVsn,FromBoot,ToBoot,Args) of {ok,TmpBoot} -> write_file(TmpBootFile,TmpBoot,Masters); {error,Reason} -> @@ -1174,8 +1170,8 @@ new_emulator_rm_tmp_release(_,_,_,_,Releases,_) -> %% Rename the tempoarary service (for erts ugprade) to the real ToVsn rename_tmp_service(EVsn,TmpVsn,NewVsn) -> - FromName = hd(string:tokens(atom_to_list(node()),"@")) ++ "_" ++ TmpVsn, - ToName = hd(string:tokens(atom_to_list(node()),"@")) ++ "_" ++ NewVsn, + FromName = hd(string:lexemes(atom_to_list(node()),"@")) ++ "_" ++ TmpVsn, + ToName = hd(string:lexemes(atom_to_list(node()),"@")) ++ "_" ++ NewVsn, case erlsrv:get_service(EVsn,ToName) of {error, _Error} -> ok; @@ -1207,9 +1203,9 @@ rename_service(EVsn,FromName,ToName) -> %%% in which case we try to rename the old service to the new name and try %%% to update heart's view of what service we are really running. do_make_services_permanent(PermanentVsn,Vsn, PermanentEVsn, EVsn) -> - PermName = hd(string:tokens(atom_to_list(node()),"@")) + PermName = hd(string:lexemes(atom_to_list(node()),"@")) ++ "_" ++ PermanentVsn, - Name = hd(string:tokens(atom_to_list(node()),"@")) + Name = hd(string:lexemes(atom_to_list(node()),"@")) ++ "_" ++ Vsn, case erlsrv:get_service(EVsn,Name) of {error, _Error} -> @@ -1296,7 +1292,7 @@ do_make_permanent(#state{releases = Releases, do_back_service(OldVersion, CurrentVersion,OldEVsn,CurrentEVsn) -> - NN = hd(string:tokens(atom_to_list(node()),"@")), + NN = hd(string:lexemes(atom_to_list(node()),"@")), OldName = NN ++ "_" ++ OldVersion, CurrentName = NN ++ "_" ++ CurrentVersion, UpdData = case erlsrv:get_service(CurrentEVsn,CurrentName) of @@ -1385,7 +1381,7 @@ do_remove_service(Vsn) -> %% Very unconditionally remove the service. %% Note that the service could already have been removed when %% making another release permanent. - ServiceName = hd(string:tokens(atom_to_list(node()),"@")) + ServiceName = hd(string:lexemes(atom_to_list(node()),"@")) ++ "_" ++ Vsn, case erlsrv:get_service(ServiceName) of {error, _Error} -> @@ -1670,9 +1666,9 @@ flush() -> prepare_restart_nt(#release{erts_vsn = EVsn, vsn = Vsn}, #release{erts_vsn = PermEVsn, vsn = PermVsn}, DataFileName) -> - CurrentServiceName = hd(string:tokens(atom_to_list(node()),"@")) + CurrentServiceName = hd(string:lexemes(atom_to_list(node()),"@")) ++ "_" ++ PermVsn, - FutureServiceName = hd(string:tokens(atom_to_list(node()),"@")) + FutureServiceName = hd(string:lexemes(atom_to_list(node()),"@")) ++ "_" ++ Vsn, CurrentService = case erlsrv:get_service(PermEVsn,CurrentServiceName) of {error, _} = Error1 -> diff --git a/lib/sasl/src/sasl.app.src b/lib/sasl/src/sasl.app.src index b7bb9133ff..1e8e58a978 100644 --- a/lib/sasl/src/sasl.app.src +++ b/lib/sasl/src/sasl.app.src @@ -32,8 +32,6 @@ sasl_report, sasl_report_tty_h, sasl_report_file_h, - si, - si_sasl_supp, systools, systools_make, systools_rc, diff --git a/lib/sasl/src/sasl.appup.src b/lib/sasl/src/sasl.appup.src index dcb568c413..94af164b20 100644 --- a/lib/sasl/src/sasl.appup.src +++ b/lib/sasl/src/sasl.appup.src @@ -18,11 +18,7 @@ %% %CopyrightEnd% {"%VSN%", %% Up from - max one major revision back - [{<<"3\\.0((\\.[0-3])(\\.[0-9]+)*)?">>,[restart_new_emulator]}, % OTP-19.* - {<<"3\\.0\\.[4-9](\\.[0-9]+)*">>,[restart_new_emulator]}, % OTP-20.0* - {<<"3\\.1(\\.[0-9]+)*">>,[restart_new_emulator]}], % OTP-20.1* + [{<<"3\\.0\\.4(\\.[0-9]+)*">>,[restart_new_emulator]}], % OTP-20.* %% Down to - max one major revision back - [{<<"3\\.0((\\.[0-3])(\\.[0-9]+)*)?">>,[restart_new_emulator]}, % OTP-19.* - {<<"3\\.0\\.[4-9](\\.[0-9]+)*">>,[restart_new_emulator]}, % OTP-20.0* - {<<"3\\.1(\\.[0-9]+)*">>,[restart_new_emulator]}] % OTP-20.1* + [{<<"3\\.0\\.4(\\.[0-9]+)*">>,[restart_new_emulator]}] % OTP-20.* }. diff --git a/lib/sasl/src/si.erl b/lib/sasl/src/si.erl deleted file mode 100644 index 275c6d508b..0000000000 --- a/lib/sasl/src/si.erl +++ /dev/null @@ -1,169 +0,0 @@ -%% -%% %CopyrightBegin% -%% -%% Copyright Ericsson AB 1996-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% -%% -%%----------------------------------------------------------------- -%% l(format_lib_supp), l(si_sasl_supp), l(si), l(si_ms_aos_supp), l(misc_supp). -%% c(format_lib_supp), c(si_sasl_supp), c(si), c(si_ms_aos_supp), c(misc_supp). -%%----------------------------------------------------------------- - - -%%-------------------------------------------------- -%% Description: -%% Status Inspection, main module. -%%-------------------------------------------------- - --module(si). - - -%% External exports --export([h/0, help/0, start/0, start/1, start_log/1, stop_log/0, - abbrevs/0, pi/1, pi/2, pi/3, pi/4, ppi/1, ppi/3, stop/0]). - -%% Internal exports --export([pi_impl/2, test/0]). - - -%%-------------------------------------------------- -%% Table of contents -%% 1. Interface -%% 2. Implementation - - --import(si_sasl_supp, [status_info/1, make_pid/1, p/1]). - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% 1. Interface -%%-------------------------------------------------- - -h() -> print_help(). -help() -> print_help(). - -start() -> si_sasl_supp:start(). -start(Options) -> si_sasl_supp:start(Options). - -stop() -> si_sasl_supp:stop(). - -start_log(FileName) -> - si_sasl_supp:start_log(FileName). - -stop_log() -> - si_sasl_supp:stop_log(). - -%%%----------------------------------------------------------------- -%%% All functions can be called with an option 'normal' or 'all'; -%%% default is 'normal'. -%%%----------------------------------------------------------------- - -abbrevs() -> - io:format("~p", [lists:append(si_sasl_supp:process_abbrevs(), - process_abbrevs())]). - -%%----------------------------------------------------------------- -%% Process Info that tries to determine processtype (=Module), then -%% it uses this Module:format_info to format data from status_info/1. -%%----------------------------------------------------------------- -pi(XPid) -> - si_sasl_supp:si_exec({si, pi_impl}, [normal, XPid]). - -pi(Opt, XPid) -> - si_sasl_supp:si_exec({si, pi_impl}, [si_sasl_supp:valid_opt(Opt), XPid]). - -pi(A, B, C) when is_integer(A), is_integer(B), is_integer(C) -> - si_sasl_supp:si_exec({si, pi_impl}, [normal, {A, B, C}]). - -pi(Opt, A, B, C) when is_integer(A), is_integer(B), is_integer(C) -> - si_sasl_supp:si_exec({si, pi_impl}, [si_sasl_supp:valid_opt(Opt), {A, B, C}]). - -%%----------------------------------------------------------------- -%% Pretty print Process_Info. -%%----------------------------------------------------------------- -ppi(XPid) -> - si_sasl_supp:ppi(XPid). -ppi(A, B, C) -> - si_sasl_supp:ppi(A, B, C). - - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% 2. Implementation -%%-------------------------------------------------- - -print_help() -> - p("~nStatus Inspection tool - usage"), - p("=============================="), - p(" For all these functions, Opt is an optional argument"), - p(" which can be 'normal' or 'all'; default is 'normal'."), - p(" If 'all', all information will be printed."), - p(" A Pid can be: \"<A.B.C>\", {A, B, C}, B, a registered_name or an abbrev."), - p("ANY PROCESS"), - p("si:pi([Opt,] Pid) - Formatted information about any process that"), - p(" SI recognises."), - p("si:pi([Opt,] A,B,C) - Same as si:pi({A, B, C})."), - p("si:ppi(Pid) - Pretty formating of process_info."), - p(" Works for any process."), - p("MISC"), - p("si:abbrevs() - Lists valid abbreviations."), - p("si:start_log(Filename) - Logging to file."), - p("si:stop_log()"), - p("si:start() - Starts Status Inspection (the si_server)."), - p("si:start([{start_log, FileName}])"), - p("si:stop() - Shut down SI."). - - -%%-------------------------------------------------- -%% Copied (and modified) code from si_sasl_supp. -%%-------------------------------------------------- -pi_impl(Opt, XPid) -> - case make_pid(try_local_expand_abbrev(XPid)) of - Pid when is_pid(Pid) -> - case status_info(Pid) of - {status_info, Pid, {module, Module}, Data} -> - si_sasl_supp:do_best_printout(Opt, Pid, Module, Data); - {error, Reason} -> - _ = si_sasl_supp:ppi_impl(Pid), - {error, {"can not get status info from process:", - XPid, - Reason}}; - Else -> - {error, {"unknown status info", Else}} - end; - {error, Reason} -> - {error, Reason} - end. - -%%-------------------------------------------------- -%% Functions for handling of abbreviations -%%-------------------------------------------------- -try_local_expand_abbrev(Abbrev) -> - case si_sasl_supp:expand_abbrev(Abbrev, process_abbrevs()) of - {value, {_, RealName}} -> RealName; - _ -> Abbrev - end. - -process_abbrevs() -> - []. - -%% Test get_status_info/format_status_info for all implemented servers. -test() -> - lists:foreach(fun test_all_registered/1, - lists:append(si_sasl_supp:process_abbrevs(), - process_abbrevs())). - -test_all_registered({Al, _Ful}) -> - si:pi(all, Al). diff --git a/lib/sasl/src/si_sasl_supp.erl b/lib/sasl/src/si_sasl_supp.erl deleted file mode 100644 index cce628f8c4..0000000000 --- a/lib/sasl/src/si_sasl_supp.erl +++ /dev/null @@ -1,380 +0,0 @@ -%% -%% %CopyrightBegin% -%% -%% Copyright Ericsson AB 1996-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(si_sasl_supp). - --behaviour(gen_server). - -%%%--------------------------------------------------------------------------- -%%% Description: -%%% This module contains the BOS specific parts of the Status Inspection Tool. -%%%--------------------------------------------------------------------------- - - -%% user interface --export([h/0, help/0, start_log/1, stop_log/0, abbrevs/0, pi/1, pi/2, pi/3, - pi/4, ppi/1, ppi/3, start/0, start/1, stop/0, start_link/1]). - -%% intermodule exports --export([make_pid/1, make_pid/3, process_abbrevs/0, expand_abbrev/2, - status_info/1, valid_opt/1, p/1, do_best_printout/4, - si_exec/2, handle_call/3, terminate/2]). - -%% exports for use within module --export([init/1, start_log_impl/1, pi_impl/2, ppi_impl/1]). - -%% other gen_server callbacks (not used) --export([handle_cast/2, handle_info/2, code_change/3]). - -%%-------------------------------------------------- -%% Table of contents -%% 1. Interface -%% 2. SI - Server -%% 3. Code -%% 4. Selectors -%%-------------------------------------------------- - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% 1. Interface -%% ----------------------------------------------------- - -h() -> print_help(). -help() -> print_help(). - -si_exec(Fun, Args) -> call({si_exec, Fun, Args}). - -start_log(FileName) -> - call({start_log, FileName}). - -stop_log() -> - call(stop_log). - -abbrevs() -> - io:format("~p", [process_abbrevs()]). - -%%----------------------------------------------------------------- -%% All functions can be called with an option 'normal' or 'all'; -%% default is 'normal'. -%%----------------------------------------------------------------- -%% Process Info that tries to determine processtype (=Module), then -%% it uses this Module:format_info to format data from status_info/1. -%%----------------------------------------------------------------- -pi(XPid) -> - si_exec({si_sasl_supp, pi_impl}, [normal, XPid]). - -pi(Opt, XPid) -> - si_exec({si_sasl_supp, pi_impl}, [valid_opt(Opt), XPid]). - -pi(A, B, C) when is_integer(A), is_integer(B), is_integer(C) -> - si_exec({si_sasl_supp, pi_impl}, [normal, {A, B, C}]). - -pi(Opt, A, B, C) when is_integer(A), is_integer(B), is_integer(C) -> - si_exec({si_sasl_supp, pi_impl}, [valid_opt(Opt), {A, B, C}]). - -%%----------------------------------------------------------------- -%% Pretty print Process_Info. -%%----------------------------------------------------------------- -ppi(XPid) -> - case whereis(si_server) of - undefined -> % You can always run ppi. - ppi_impl(XPid); % if si_server is down, use standard_io - _ -> - si_exec({si_sasl_supp, ppi_impl}, [XPid]) - end. -ppi(A, B, C) -> - case whereis(si_server) of - undefined -> % You can always run ppi. - ppi_impl({A, B, C}); % if si_server is down, use standard_io - _ -> - si_exec({si_sasl_supp, ppi_impl}, [{A, B, C}]) - end. - - - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% 2. SI - Server -%%-------------------------------------------------- --record(state, {}). - -start() -> start([]). -start(Options) -> - supervisor:start_child(sasl_sup, - {si_server, {si_sasl_supp, start_link, [Options]}, - temporary, brutal_kill, worker, [si_sasl_supp]}). - -start_link(_Options) -> - gen_server:start_link({local, si_server}, si_sasl_supp, [], []). - -stop() -> - call(stop), - supervisor:delete_child(sasl_sup, si_server). - - -init(Options) -> - process_flag(trap_exit, true), - start_log_impl(get_option(Options, start_log, standard_io)), - {ok, #state{}}. - -%%----------------------------------------------------------------- -%% If an error occurs and we're logging to file: write the error -%% to the file. -%% Always return the error. -%% The only data held by the si_server is the device in its process dictionary. -%%----------------------------------------------------------------- -handle_call({si_exec, Fun, Args}, _From, State) -> - case catch apply(Fun, Args) of - {'EXIT', Reason} -> - print_error(get(device), - "SI internal error. Reason: ~w~n", - [Reason]), - {stop, shutdown, {internal_error, Reason}, State}; - {error, Reason} -> - print_error(get(device), "~nSI error: ~w~n", [Reason]), - {reply, {error, Reason}, State}; - X -> - {reply, X, State} - end; -handle_call({start_log, FileName}, _From, State) -> - start_log_impl(FileName), - {reply, ok, State}; -handle_call(stop_log, _From, State) -> - start_log_impl(standard_io), - {reply, ok, State}; -handle_call(stop, _From, State) -> - start_log_impl(standard_io), - {stop, normal, stopped, State}. - -terminate(_Reason, _State) -> - _ = close_device(get(device)), - ok. - -handle_cast(_Msg, State) -> - {noreply, State}. -handle_info(_Info, State) -> - {noreply, State}. -code_change(_OldVsn, State, _Extra) -> - {ok, State}. - -close_device(standard_io) -> ok; -close_device(Fd) -> file:close(Fd). - -print_error(standard_io, _, _) -> ok; -print_error(Device, Format, Args) -> - io:format(Device, Format, Args). - -get_option(Options, Key, Default) -> - case lists:keysearch(Key, 1, Options) of - {value, {_Key, Value}} -> Value; - _ -> Default - end. - -open_log_file(undefined, NewFile) -> - open_log_file(NewFile); -open_log_file(standard_io, NewFile) -> - open_log_file(NewFile); -open_log_file(OldFile, NewFile) -> - _ = file:close(OldFile), - open_log_file(NewFile). - -open_log_file(standard_io) -> standard_io; -open_log_file(FileName) -> - case file:open(FileName, [write]) of - {ok, Fd} -> Fd; - Error -> - io:format("si_sasl_supp: Cannot open file '~s' (~w).~n", - [FileName, Error]), - io:format("si_sasl_supp: Using standard_io~n"), - standard_io - end. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% 3. Code -%%-------------------------------------------------- - -%%----------------------------------------------------------------- -%% call(Request) -> Term -%%----------------------------------------------------------------- -call(Req) -> - gen_server:call(si_server, Req, infinity). - -%%-------------------------------------------------- -%% Makes a Pid of almost anything. -%% Returns: Pid|{error, Reason} -%% Fails: Never. -%%-------------------------------------------------- -make_pid(A,B,C) when is_integer(A), is_integer(B), is_integer(C) -> - list_to_pid(lists:concat(["<",A,".",B,".",C,">"])). -make_pid(P) when is_pid(P) -> P; -make_pid(undefined) -> undefined; -make_pid(P) when is_atom(P) -> - case whereis(P) of - undefined -> - case expand_abbrev(P, process_abbrevs()) of - {error, Reason} -> {error, Reason}; - {value, {_Abbrev, FullName}} -> - case whereis(FullName) of - undefined -> - {error, {'process not registered', P}}; - Pid -> Pid - end - end; - Pid -> Pid - end; -make_pid(P) when is_list(P) -> list_to_pid(P); -make_pid({A, B, C}) -> make_pid(A, B, C); -make_pid(X) -> {error, {'can not make a pid of', X}}. - -process_abbrevs() -> - [{init, init}, - {fs, file_server}]. - -%%-------------------------------------------------- -%% Args: Abbrevs is an assoc-list of {Abbrev, RealName} -%% Returns: {value, {Abbrev, FullName}}|{error, Reason} -%%-------------------------------------------------- -expand_abbrev(ProcessName, Abbrevs) -> - case lists:keysearch(ProcessName, 1, Abbrevs) of - {value, {Abbrev, FullName}} -> - {value, {Abbrev, FullName}}; - _ -> - case lists:keysearch(ProcessName, 2, Abbrevs) of - {value, {Abbrev, FullName}} -> - {value, {Abbrev, FullName}}; - _ -> - {error, {'invalid process name', ProcessName}} - end - end. - -%%----------------------------------------------------------------- -%% This is the function that actually gets the information out -%% of the agent/server/... -%% Returns: {status_info, Pid, Type, Data} -%% | {error, Reason} -%%----------------------------------------------------------------- -status_info(Pid) when is_pid(Pid) -> - case catch sys:get_status(Pid, 5000) of - {status, Pid, Type, Info} -> - {status_info, Pid, Type, Info}; - _ -> - {error, {'process does not respond', Pid}} - end; - -status_info(X) -> - {error, {'not a pid', X}}. - -%%-------------------------------------------------- -%% Implementation starts here. -%%-------------------------------------------------- -start_log_impl(FileName) -> - put(device, open_log_file(get(device), FileName)). - -valid_opt(all) -> all; -valid_opt(_Opt) -> normal. - - -print_help() -> - p("- - - - - - - - PROCESSES - - - - - - - - - "), - p("si_sasl_supp:pi([Opt,] Pid) - Formatted information about any process that"), - p(" SI recognises."), - p("si_sasl_supp:pi([Opt,] A,B,C) - Same as si_sasl_supp:pi({A, B, C})."), - p("si_sasl_supp:ppi(Pid) - Pretty formating of process_info."), - p(" Works for any process."), - p("- - - - - - - - MISC - - - - - - - - - - - "), - p("si_sasl_supp:abbrevs() - Lists valid abbreviations."), - p("si_sasl_supp:start_log(FileNname)"), - p("si_sasl_supp:stop_log()"), - p("si_sasl_supp:start() - Starts Status Inspection (the si_server)."), - p("si_sasl_supp:start([{start_log, FileName}])"), - p("si_sasl_supp:stop() - Shut down SI."). - - - -%% Convenient shorthand -p(X) -> - io:format(lists:append(X, "~n")). - -pi_impl(Opt, XPid) -> - case make_pid(XPid) of - Pid when is_pid(Pid) -> - case status_info(Pid) of - {status_info, Pid, {module, Module}, Data} -> - do_best_printout(Opt, Pid, Module, Data); - {error, Reason} -> - _ = ppi_impl(Pid), - {error, {"can not get status info from process:", - XPid, - Reason}} - end; - {error, Reason} -> - {error, Reason} - end. - -%%-------------------------------------------------- -%% Is there a format_info for this process? In that case, run it! -%% Return ok|{error, Reason} -%% Fails: Never. -%%-------------------------------------------------- -do_best_printout(Opt, Pid, Mod, Data) when is_pid(Pid) -> - case print_info(get(device), Pid, {Mod, format_status}, Opt, Data) of - ok -> ok; - {error, Reason} -> - _ = ppi_impl(Pid), - {error, Reason} - end. - -ppi_impl(XPid) -> - case make_pid(XPid) of - P when is_pid(P) -> - case process_info(P) of - undefined -> - {error, {'dead process', P}}; - PI -> - Device = case get(device) of - undefined -> standard_io; - X -> X - end, - io:format(Device, "~nPretty Process Info~n", []), - io:format(Device, "-------------------~n", []), - io:format(Device, "~p~n", [PI]) - end; - _ -> {error, {no_pid, XPid}} - end. - -print_info(Device, Pid, {Module, Func}, Opt, Data) -> - case erlang:function_exported(Module, Func, 2) of - true -> - case catch apply(Module, Func, [Opt, Data]) of - Format when is_list(Format) -> - format_lib_supp:print_info(Device, 79, - add_pid_to_format(Pid, Format)), - ok; - Other -> {error, {'invalid format', Other}} - end; - _ -> - {error, {no_such_function, Module, Func}} - end. - -add_pid_to_format(Pid, [{header, H} | T]) -> - [{header, H}, {data, [{"Pid", Pid}]} | T]; -add_pid_to_format(Pid, List) -> - [{data, [{"Pid", Pid}]} | List]. - - diff --git a/lib/sasl/src/systools_make.erl b/lib/sasl/src/systools_make.erl index 391b1fb5cc..a9e8bcecfa 100644 --- a/lib/sasl/src/systools_make.erl +++ b/lib/sasl/src/systools_make.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2017. All Rights Reserved. +%% Copyright Ericsson AB 1996-2018. 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. @@ -32,7 +32,7 @@ -export([read_application/4]). --export([make_hybrid_boot/5]). +-export([make_hybrid_boot/4]). -import(lists, [filter/2, keysort/2, keysearch/3, map/2, reverse/1, append/1, foldl/3, member/2, foreach/2]). @@ -178,94 +178,153 @@ return({error,Mod,Error},_,Flags) -> %% and sasl. %% %% TmpVsn = string(), -%% Paths = {KernelPath,StdlibPath,SaslPath} %% Returns {ok,Boot} | {error,Reason} %% Boot1 = Boot2 = Boot = binary() %% Reason = {app_not_found,App} | {app_not_replaced,App} -%% App = kernel | stdlib | sasl -make_hybrid_boot(TmpVsn, Boot1, Boot2, Paths, Args) -> - catch do_make_hybrid_boot(TmpVsn, Boot1, Boot2, Paths, Args). -do_make_hybrid_boot(TmpVsn, Boot1, Boot2, Paths, Args) -> - {script,{_RelName1,_RelVsn1},Script1} = binary_to_term(Boot1), - {script,{RelName2,_RelVsn2},Script2} = binary_to_term(Boot2), - MatchPaths = get_regexp_path(Paths), - NewScript1 = replace_paths(Script1,MatchPaths), - {Kernel,Stdlib,Sasl} = get_apps(Script2,undefined,undefined,undefined), - NewScript2 = replace_apps(NewScript1,Kernel,Stdlib,Sasl), - NewScript3 = add_apply_upgrade(NewScript2,Args), - Boot = term_to_binary({script,{RelName2,TmpVsn},NewScript3}), +%% App = stdlib | sasl +make_hybrid_boot(TmpVsn, Boot1, Boot2, Args) -> + catch do_make_hybrid_boot(TmpVsn, Boot1, Boot2, Args). +do_make_hybrid_boot(TmpVsn, OldBoot, NewBoot, Args) -> + {script,{_RelName1,_RelVsn1},OldScript} = binary_to_term(OldBoot), + {script,{NewRelName,_RelVsn2},NewScript} = binary_to_term(NewBoot), + + %% Everyting upto kernel_load_completed must come from the new script + Fun1 = fun({progress,kernel_load_completed}) -> false; + (_) -> true + end, + {_OldKernelLoad,OldRest1} = lists:splitwith(Fun1,OldScript), + {NewKernelLoad,NewRest1} = lists:splitwith(Fun1,NewScript), + + Fun2 = fun({progress,modules_loaded}) -> false; + (_) -> true + end, + {OldModLoad,OldRest2} = lists:splitwith(Fun2,OldRest1), + {NewModLoad,NewRest2} = lists:splitwith(Fun2,NewRest1), + + Fun3 = fun({kernelProcess,_,_}) -> false; + (_) -> true + end, + {OldPaths,OldRest3} = lists:splitwith(Fun3,OldRest2), + {NewPaths,NewRest3} = lists:splitwith(Fun3,NewRest2), + + Fun4 = fun({progress,init_kernel_started}) -> false; + (_) -> true + end, + {_OldKernelProcs,OldApps} = lists:splitwith(Fun4,OldRest3), + {NewKernelProcs,NewApps} = lists:splitwith(Fun4,NewRest3), + + %% Then comes all module load, which for each app consist of: + %% {path,[AppPath]}, + %% {primLoad,ModuleList} + %% Replace kernel, stdlib and sasl here + MatchPaths = get_regexp_path(), + ModLoad = replace_module_load(OldModLoad,NewModLoad,MatchPaths), + Paths = replace_paths(OldPaths,NewPaths,MatchPaths), + + {Stdlib,Sasl} = get_apps(NewApps,undefined,undefined), + Apps0 = replace_apps(OldApps,Stdlib,Sasl), + Apps = add_apply_upgrade(Apps0,Args), + + Script = NewKernelLoad++ModLoad++Paths++NewKernelProcs++Apps, + Boot = term_to_binary({script,{NewRelName,TmpVsn},Script}), {ok,Boot}. %% For each app, compile a regexp that can be used for finding its path -get_regexp_path({KernelPath,StdlibPath,SaslPath}) -> +get_regexp_path() -> {ok,KernelMP} = re:compile("kernel-[0-9\.]+",[unicode]), {ok,StdlibMP} = re:compile("stdlib-[0-9\.]+",[unicode]), {ok,SaslMP} = re:compile("sasl-[0-9\.]+",[unicode]), - [{KernelMP,KernelPath},{StdlibMP,StdlibPath},{SaslMP,SaslPath}]. - -%% For each path in the script, check if it matches any of the MPs -%% found above, and if so replace it with the correct new path. -replace_paths([{path,Path}|Script],MatchPaths) -> - [{path,replace_path(Path,MatchPaths)}|replace_paths(Script,MatchPaths)]; -replace_paths([Stuff|Script],MatchPaths) -> - [Stuff|replace_paths(Script,MatchPaths)]; -replace_paths([],_) -> + [KernelMP,StdlibMP,SaslMP]. + +replace_module_load(Old,New,[MP|MatchPaths]) -> + replace_module_load(do_replace_module_load(Old,New,MP),New,MatchPaths); +replace_module_load(Script,_,[]) -> + Script. + +do_replace_module_load([{path,[OldAppPath]},{primLoad,OldMods}|OldRest],New,MP) -> + case re:run(OldAppPath,MP,[{capture,none}]) of + nomatch -> + [{path,[OldAppPath]},{primLoad,OldMods}| + do_replace_module_load(OldRest,New,MP)]; + match -> + get_module_load(New,MP) ++ OldRest + end; +do_replace_module_load([Other|Rest],New,MP) -> + [Other|do_replace_module_load(Rest,New,MP)]; +do_replace_module_load([],_,_) -> + []. + +get_module_load([{path,[AppPath]},{primLoad,Mods}|Rest],MP) -> + case re:run(AppPath,MP,[{capture,none}]) of + nomatch -> + get_module_load(Rest,MP); + match -> + [{path,[AppPath]},{primLoad,Mods}] + end; +get_module_load([_|Rest],MP) -> + get_module_load(Rest,MP); +get_module_load([],_) -> []. -replace_path([Path|Paths],MatchPaths) -> - [do_replace_path(Path,MatchPaths)|replace_path(Paths,MatchPaths)]; -replace_path([],_) -> +replace_paths([{path,OldPaths}|Old],New,MatchPaths) -> + {path,NewPath} = lists:keyfind(path,1,New), + [{path,do_replace_paths(OldPaths,NewPath,MatchPaths)}|Old]; +replace_paths([Other|Old],New,MatchPaths) -> + [Other|replace_paths(Old,New,MatchPaths)]. + +do_replace_paths(Old,New,[MP|MatchPaths]) -> + do_replace_paths(do_replace_paths1(Old,New,MP),New,MatchPaths); +do_replace_paths(Paths,_,[]) -> + Paths. + +do_replace_paths1([P|Ps],New,MP) -> + case re:run(P,MP,[{capture,none}]) of + nomatch -> + [P|do_replace_paths1(Ps,New,MP)]; + match -> + get_path(New,MP) ++ Ps + end; +do_replace_paths1([],_,_) -> []. -do_replace_path(Path,[{MP,ReplacePath}|MatchPaths]) -> - case re:run(Path,MP,[{capture,none}]) of - nomatch -> do_replace_path(Path,MatchPaths); - match -> ReplacePath +get_path([P|Ps],MP) -> + case re:run(P,MP,[{capture,none}]) of + nomatch -> + get_path(Ps,MP); + match -> + [P] end; -do_replace_path(Path,[]) -> - Path. - -%% Return the entries for loading the three base applications -get_apps([{kernelProcess,application_controller, - {application_controller,start,[{application,kernel,_}]}}=Kernel| - Script],_,Stdlib,Sasl) -> - get_apps(Script,Kernel,Stdlib,Sasl); +get_path([],_) -> + []. + + +%% Return the entries for loading stdlib and sasl get_apps([{apply,{application,load,[{application,stdlib,_}]}}=Stdlib|Script], - Kernel,_,Sasl) -> - get_apps(Script,Kernel,Stdlib,Sasl); + _,Sasl) -> + get_apps(Script,Stdlib,Sasl); get_apps([{apply,{application,load,[{application,sasl,_}]}}=Sasl|_Script], - Kernel,Stdlib,_) -> - {Kernel,Stdlib,Sasl}; -get_apps([_|Script],Kernel,Stdlib,Sasl) -> - get_apps(Script,Kernel,Stdlib,Sasl); -get_apps([],undefined,_,_) -> - throw({error,{app_not_found,kernel}}); -get_apps([],_,undefined,_) -> + Stdlib,_) -> + {Stdlib,Sasl}; +get_apps([_|Script],Stdlib,Sasl) -> + get_apps(Script,Stdlib,Sasl); +get_apps([],undefined,_) -> throw({error,{app_not_found,stdlib}}); -get_apps([],_,_,undefined) -> +get_apps([],_,undefined) -> throw({error,{app_not_found,sasl}}). - -%% Replace the entries for loading the base applications -replace_apps([{kernelProcess,application_controller, - {application_controller,start,[{application,kernel,_}]}}| - Script],Kernel,Stdlib,Sasl) -> - [Kernel|replace_apps(Script,undefined,Stdlib,Sasl)]; +%% Replace the entries for loading the stdlib and sasl replace_apps([{apply,{application,load,[{application,stdlib,_}]}}|Script], - Kernel,Stdlib,Sasl) -> - [Stdlib|replace_apps(Script,Kernel,undefined,Sasl)]; + Stdlib,Sasl) -> + [Stdlib|replace_apps(Script,undefined,Sasl)]; replace_apps([{apply,{application,load,[{application,sasl,_}]}}|Script], - _Kernel,_Stdlib,Sasl) -> + _Stdlib,Sasl) -> [Sasl|Script]; -replace_apps([Stuff|Script],Kernel,Stdlib,Sasl) -> - [Stuff|replace_apps(Script,Kernel,Stdlib,Sasl)]; -replace_apps([],undefined,undefined,_) -> +replace_apps([Stuff|Script],Stdlib,Sasl) -> + [Stuff|replace_apps(Script,Stdlib,Sasl)]; +replace_apps([],undefined,_) -> throw({error,{app_not_replaced,sasl}}); -replace_apps([],undefined,_,_) -> - throw({error,{app_not_replaced,stdlib}}); -replace_apps([],_,_,_) -> - throw({error,{app_not_replaced,kernel}}). - +replace_apps([],_,_) -> + throw({error,{app_not_replaced,stdlib}}). %% Finally add an apply of release_handler:new_emulator_upgrade - which will %% complete the execution of the upgrade script (relup). @@ -275,8 +334,6 @@ add_apply_upgrade(Script,Args) -> {apply,{release_handler,new_emulator_upgrade,Args}} | RevScript]). - - %%----------------------------------------------------------------- %% Create a release package from a release file. %% Options is a list of {path, Path} | silent | @@ -310,6 +367,7 @@ add_apply_upgrade(Script,Args) -> %% RelVsn/start.boot %% relup %% sys.config +%% sys.config.src %% erts-EVsn[/bin] %%----------------------------------------------------------------- @@ -1499,9 +1557,9 @@ mandatory_modules() -> preloaded() -> %% Sorted [erl_prim_loader,erl_tracer,erlang, - erts_code_purger,erts_dirty_process_code_checker, + erts_code_purger,erts_dirty_process_signal_handler, erts_internal,erts_literal_area_collector, - init,otp_ring0,prim_eval,prim_file, + init,otp_ring0,prim_buffer,prim_eval,prim_file, prim_inet,prim_zip,zlib]. %%______________________________________________________________________ @@ -1552,6 +1610,7 @@ create_kernel_procs(Appls) -> %% RelVsn/start.boot %% relup %% sys.config +%% sys.config.src %% erts-EVsn[/bin] %% %% The VariableN.tar.gz files can also be stored as own files not @@ -1707,14 +1766,18 @@ add_system_files(Tar, RelName, Release, Path1) -> add_to_tar(Tar, Relup, filename:join(RelVsnDir, "relup")) end, - case lookup_file("sys.config", Path) of - false -> - ignore; - Sys -> - check_sys_config(Sys), - add_to_tar(Tar, Sys, filename:join(RelVsnDir, "sys.config")) + case lookup_file("sys.config.src", Path) of + false -> + case lookup_file("sys.config", Path) of + false -> + ignore; + Sys -> + check_sys_config(Sys), + add_to_tar(Tar, Sys, filename:join(RelVsnDir, "sys.config")) + end; + SysSrc -> + add_to_tar(Tar, SysSrc, filename:join(RelVsnDir, "sys.config.src")) end, - ok. lookup_file(Name, [Dir|Path]) -> diff --git a/lib/sasl/test/release_handler_SUITE.erl b/lib/sasl/test/release_handler_SUITE.erl index 50932e89e4..edd2efdf05 100644 --- a/lib/sasl/test/release_handler_SUITE.erl +++ b/lib/sasl/test/release_handler_SUITE.erl @@ -22,7 +22,8 @@ -include_lib("common_test/include/ct.hrl"). -include("test_lib.hrl"). --compile(export_all). +-compile([export_all, nowarn_export_all]). +-export([scheduler_wall_time/0, garbage_collect/0]). %% rpc'ed % Default timetrap timeout (set in init_per_testcase). %-define(default_timeout, ?t:minutes(40)). @@ -1085,8 +1086,9 @@ otp_9395_update_many_mods(Conf) when is_list(Conf) -> Rel2Dir = filename:dirname(Rel2), %% Start a slave node + PA = filename:dirname(code:which(?MODULE)), {ok, Node} = t_start_node(otp_9395_update_many_mods, Rel1, - filename:join(Rel1Dir,"sys.config")), + filename:join(Rel1Dir,"sys.config"), "-pa " ++ PA), %% Start a lot of processes on the new node, all with refs to each %% module that will be updated @@ -1109,8 +1111,8 @@ otp_9395_update_many_mods(Conf) when is_list(Conf) -> [RelVsn2, filename:join(Rel2Dir, "sys.config")]), %% First, install release directly and check how much time it takes - rpc:call(Node,erlang,garbage_collect,[]), - rpc:call(Node,erlang,system_flag,[scheduler_wall_time,true]), + rpc:call(Node,?MODULE,garbage_collect,[]), + SWTFlag0 = spawn_link(Node, ?MODULE, scheduler_wall_time, []), {TInst0,{ok, _, []}} = timer:tc(rpc,call,[Node, release_handler, install_release, [RelVsn2]]), SWT0 = rpc:call(Node,erlang,statistics,[scheduler_wall_time]), @@ -1135,9 +1137,9 @@ otp_9395_update_many_mods(Conf) when is_list(Conf) -> %% Finally install release after check and purge, and check that %% this install was faster than the first. - rpc:call(Node,erlang,system_flag,[scheduler_wall_time,false]), - rpc:call(Node,erlang,garbage_collect,[]), - rpc:call(Node,erlang,system_flag,[scheduler_wall_time,true]), + SWTFlag0 ! die, + rpc:call(Node,?MODULE,garbage_collect,[]), + _SWTFlag1 = spawn_link(Node, ?MODULE, scheduler_wall_time, []), {TInst2,{ok, _RelVsn1, []}} = timer:tc(rpc,call,[Node, release_handler, install_release, [RelVsn2]]), SWT2 = rpc:call(Node,erlang,statistics,[scheduler_wall_time]), @@ -1161,6 +1163,15 @@ otp_9395_update_many_mods(Conf) when is_list(Conf) -> ok. +scheduler_wall_time() -> + erlang:system_flag(scheduler_wall_time,true), + receive _Msg -> normal end. + +garbage_collect() -> + Pids = processes(), + [erlang:garbage_collect(Pid) || Pid <- Pids]. + + otp_9395_update_many_mods(cleanup,_Conf) -> stop_node(node_name(otp_9395_update_many_mods)). @@ -1190,8 +1201,9 @@ otp_9395_rm_many_mods(Conf) when is_list(Conf) -> Rel2Dir = filename:dirname(Rel2), %% Start a slave node + PA = filename:dirname(code:which(?MODULE)), {ok, Node} = t_start_node(otp_9395_rm_many_mods, Rel1, - filename:join(Rel1Dir,"sys.config")), + filename:join(Rel1Dir,"sys.config"), "-pa " ++ PA), %% Start a lot of processes on the new node, all with refs to each %% module that will be updated @@ -1214,8 +1226,8 @@ otp_9395_rm_many_mods(Conf) when is_list(Conf) -> [RelVsn2, filename:join(Rel2Dir, "sys.config")]), %% First, install release directly and check how much time it takes - rpc:call(Node,erlang,garbage_collect,[]), - rpc:call(Node,erlang,system_flag,[scheduler_wall_time,true]), + rpc:call(Node,?MODULE,garbage_collect,[]), + SWTFlag0 = spawn_link(Node, ?MODULE, scheduler_wall_time, []), {TInst0,{ok, _, []}} = timer:tc(rpc,call,[Node, release_handler, install_release, [RelVsn2]]), SWT0 = rpc:call(Node,erlang,statistics,[scheduler_wall_time]), @@ -1240,9 +1252,9 @@ otp_9395_rm_many_mods(Conf) when is_list(Conf) -> %% Finally install release after check and purge, and check that %% this install was faster than the first. - rpc:call(Node,erlang,system_flag,[scheduler_wall_time,false]), - rpc:call(Node,erlang,garbage_collect,[]), - rpc:call(Node,erlang,system_flag,[scheduler_wall_time,true]), + SWTFlag0 ! die, + rpc:call(Node,?MODULE,garbage_collect,[]), + _SWTFlag1 = spawn_link(Node, ?MODULE, scheduler_wall_time, []), {TInst2,{ok, _RelVsn1, []}} = timer:tc(rpc,call,[Node, release_handler, install_release, [RelVsn2]]), SWT2 = rpc:call(Node,erlang,statistics,[scheduler_wall_time]), @@ -1384,9 +1396,9 @@ upgrade_supervisor(Conf) when is_list(Conf) -> %% Check that the restart strategy and child spec is updated {status, _, {module, _}, [_, _, _, _, [_,_,{data,[{"State",State}]}|_]]} = rpc:call(Node,sys,get_status,[a_sup]), - {state,_,RestartStrategy,[Child],_,_,_,_,_,_,_} = State, + {state,_,RestartStrategy,{[a],Db},_,_,_,_,_,_,_} = State, one_for_all = RestartStrategy, % changed from one_for_one - {child,_,_,_,_,brutal_kill,_,_} = Child, % changed from timeout 2000 + {child,_,_,_,_,brutal_kill,_,_} = maps:get(a,Db), % changed from timeout 2000 ok. @@ -1835,24 +1847,32 @@ otp_10463_upgrade_script_regexp(cleanup,Config) -> code:del_path(filename:join([DataDir,regexp_appup,app1,ebin])), ok. -no_dot_erlang(Conf) -> - PrivDir = ?config(data_dir,Conf), - {ok, OrigWd} = file:get_cwd(), - try - ok = file:set_cwd(PrivDir), - - {ok, Wd} = file:get_cwd(), - io:format("Dir ~ts~n", [Wd]), +no_dot_erlang(_Conf) -> + case init:get_argument(home) of + {ok,[[Home]]} when is_list(Home) -> + no_dot_erlang_1(Home); + _ -> ok + end. +no_dot_erlang_1(Home) -> + DotErlang = filename:join(Home, ".erlang"), + BupErlang = filename:join(Home, ".erlang_testbup"), + try + {ok, Wd} = file:get_cwd(), + case filelib:is_file(DotErlang) of + true -> {ok, _} = file:copy(DotErlang, BupErlang); + false -> ok + end, Erl0 = filename:join([code:root_dir(),"bin","erl"]), Erl = filename:nativename(Erl0), Quote = "\"", Args = " -noinput -run c pwd -run erlang halt", - ok = file:write_file(".erlang", <<"io:put_chars(\"DOT_ERLANG_READ\\n\").\n">>), + ok = file:write_file(DotErlang, <<"io:put_chars(\"DOT_ERLANG_READ\\n\").\n">>), CMD1 = Quote ++ Erl ++ Quote ++ Args , case os:cmd(CMD1) of - "DOT_ERLANG_READ" ++ _ -> ok; + "DOT_ERLANG_READ" ++ _ -> + io:format("~p: Success~n", [?LINE]); Other1 -> io:format("Failed: ~ts~n",[CMD1]), io:format("Expected: ~s ++ _~n",["DOT_ERLANG_READ "]), @@ -1862,7 +1882,7 @@ no_dot_erlang(Conf) -> NO_DOT_ERL = " -boot no_dot_erlang", CMD2 = Quote ++ Erl ++ Quote ++ NO_DOT_ERL ++ Args, case lists:prefix(Wd, Other2 = os:cmd(CMD2)) of - true -> ok; + true -> io:format("~p: Success~n", [?LINE]); false -> io:format("Failed: ~ts~n",[CMD2]), io:format("Expected: ~s~n",["TESTOK"]), @@ -1870,9 +1890,13 @@ no_dot_erlang(Conf) -> exit({failed_to_start, no_dot_erlang}) end after - _ = file:delete(".erlang"), - ok = file:set_cwd(OrigWd), - ok + case filelib:is_file(BupErlang) of + true -> + {ok, _} = file:copy(BupErlang, DotErlang), + _ = file:delete(BupErlang); + false -> + _ = file:delete(DotErlang) + end end. %%%----------------------------------------------------------------- @@ -2556,15 +2580,15 @@ check_gg_info(Node,OtherAlive,OtherDead,Synced,N) -> GGI = rpc:call(Node, global_group, info, []), GI = rpc:call(Node, global, info,[]), try do_check_gg_info(OtherAlive,OtherDead,Synced,GGI,GI) - catch _:E when N==0 -> + catch _:E:Stacktrace when N==0 -> ?t:format("~nERROR: check_gg_info failed for ~p:~n~p~n" "when GGI was: ~p~nand GI was: ~p~n", - [Node,{E,erlang:get_stacktrace()},GGI,GI]), + [Node,{E,Stacktrace},GGI,GI]), ?t:fail("check_gg_info failed"); - _:E -> + _:E:Stacktrace -> ?t:format("~nWARNING: check_gg_info failed for ~p:~n~p~n" "when GGI was: ~p~nand GI was: ~p~n", - [Node,{E,erlang:get_stacktrace()},GGI,GI]), + [Node,{E,Stacktrace},GGI,GI]), timer:sleep(1000), check_gg_info(Node,OtherAlive,OtherDead,Synced,N-1) end. diff --git a/lib/sasl/test/systools_SUITE.erl b/lib/sasl/test/systools_SUITE.erl index 07748d975f..ad61186921 100644 --- a/lib/sasl/test/systools_SUITE.erl +++ b/lib/sasl/test/systools_SUITE.erl @@ -67,7 +67,7 @@ groups() -> otp_3065_circular_dependenies, included_and_used_sort_script]}, {tar, [], [tar_options, normal_tar, no_mod_vsn_tar, system_files_tar, - invalid_system_files_tar, variable_tar, + system_src_file_tar, invalid_system_files_tar, variable_tar, src_tests_tar, var_tar, exref_tar, link_tar, no_sasl_tar, otp_9507_path_ebin]}, {relup, [], @@ -945,12 +945,47 @@ system_files_tar(Config) -> ok. + system_files_tar(cleanup,Config) -> Dir = ?privdir, file:delete(filename:join(Dir,"sys.config")), file:delete(filename:join(Dir,"relup")), ok. +%% make_tar: Check that sys.config.src and not sys.config is included +system_src_file_tar(Config) -> + {ok, OldDir} = file:get_cwd(), + + {LatestDir, LatestName} = create_script(latest,Config), + + DataDir = filename:absname(?copydir), + LibDir = fname([DataDir, d_normal, lib]), + P = [fname([LibDir, 'db-2.1', ebin]), + fname([LibDir, 'fe-3.1', ebin])], + + ok = file:set_cwd(LatestDir), + + %% Add dummy sys.config and sys.config.src + ok = file:write_file("sys.config.src","[${SOMETHING}].\n"), + ok = file:write_file("sys.config","[].\n"), + + {ok, _, _} = systools:make_script(LatestName, [silent, {path, P}]), + ok = systools:make_tar(LatestName, [{path, P}]), + ok = check_tar(fname(["releases","LATEST","sys.config.src"]), LatestName), + {error, _} = check_tar(fname(["releases","LATEST","sys.config"]), LatestName), + {ok, _, _} = systools:make_tar(LatestName, [{path, P}, silent]), + ok = check_tar(fname(["releases","LATEST","sys.config.src"]), LatestName), + {error, _} = check_tar(fname(["releases","LATEST","sys.config"]), LatestName), + + ok = file:set_cwd(OldDir), + + ok. + +system_src_file_tar(cleanup,Config) -> + Dir = ?privdir, + file:delete(filename:join(Dir,"sys.config")), + file:delete(filename:join(Dir,"sys.config.src")), + ok. %% make_tar: Check that make_tar fails if relup or sys.config exist %% but do not have valid content @@ -1760,27 +1795,28 @@ normal_hybrid(Config) -> ok = file:set_cwd(OldDir), - BasePaths = {"testkernelpath","teststdlibpath","testsaslpath"}, {ok,Hybrid} = systools_make:make_hybrid_boot("tmp_vsn",Boot1,Boot2, - BasePaths, [dummy,args]), + [dummy,args]), {script,{"Test release","tmp_vsn"},Script} = binary_to_term(Hybrid), ct:log("~p.~n",[Script]), %% Check that all paths to base apps are replaced by paths from BaseLib Boot1Str = io_lib:format("~p~n",[binary_to_term(Boot1)]), + Boot2Str = io_lib:format("~p~n",[binary_to_term(Boot2)]), HybridStr = io_lib:format("~p~n",[binary_to_term(Hybrid)]), ReOpts = [global,{capture,first,list},unicode], {match,OldKernelMatch} = re:run(Boot1Str,"kernel-[0-9\.]+",ReOpts), {match,OldStdlibMatch} = re:run(Boot1Str,"stdlib-[0-9\.]+",ReOpts), {match,OldSaslMatch} = re:run(Boot1Str,"sasl-[0-9\.]+",ReOpts), - nomatch = re:run(HybridStr,"kernel-[0-9\.]+",ReOpts), - nomatch = re:run(HybridStr,"stdlib-[0-9\.]+",ReOpts), - nomatch = re:run(HybridStr,"sasl-[0-9\.]+",ReOpts), - {match,NewKernelMatch} = re:run(HybridStr,"testkernelpath",ReOpts), - {match,NewStdlibMatch} = re:run(HybridStr,"teststdlibpath",ReOpts), - {match,NewSaslMatch} = re:run(HybridStr,"testsaslpath",ReOpts), + {match,NewKernelMatch} = re:run(Boot2Str,"kernel-[0-9\.]+",ReOpts), + {match,NewStdlibMatch} = re:run(Boot2Str,"stdlib-[0-9\.]+",ReOpts), + {match,NewSaslMatch} = re:run(Boot2Str,"sasl-[0-9\.]+",ReOpts), + + {match,NewKernelMatch} = re:run(HybridStr,"kernel-[0-9\.]+",ReOpts), + {match,NewStdlibMatch} = re:run(HybridStr,"stdlib-[0-9\.]+",ReOpts), + {match,NewSaslMatch} = re:run(HybridStr,"sasl-[0-9\.]+",ReOpts), NewKernelN = length(NewKernelMatch), NewKernelN = length(OldKernelMatch), @@ -1789,6 +1825,11 @@ normal_hybrid(Config) -> NewSaslN = length(NewSaslMatch), NewSaslN = length(OldSaslMatch), + %% Check that kernelProcesses are taken from new boot script + {script,_,Script2} = binary_to_term(Boot2), + NewKernelProcs = [KP || KP={kernelProcess,_,_} <- Script2], + NewKernelProcs = [KP || KP={kernelProcess,_,_} <- Script], + %% Check that application load instruction has correct versions Apps = application:loaded_applications(), {_,_,KernelVsn} = lists:keyfind(kernel,1,Apps), @@ -1859,10 +1900,8 @@ hybrid_no_old_sasl(Config) -> {ok,Boot1} = file:read_file(Name1 ++ ".boot"), {ok,Boot2} = file:read_file(Name2 ++ ".boot"), - BasePaths = {"testkernelpath","teststdlibpath","testsaslpath"}, {error,{app_not_replaced,sasl}} = - systools_make:make_hybrid_boot("tmp_vsn",Boot1,Boot2, - BasePaths,[dummy,args]), + systools_make:make_hybrid_boot("tmp_vsn",Boot1,Boot2,[dummy,args]), ok = file:set_cwd(OldDir), ok. @@ -1892,10 +1931,8 @@ hybrid_no_new_sasl(Config) -> {ok,Boot1} = file:read_file(Name1 ++ ".boot"), {ok,Boot2} = file:read_file(Name2 ++ ".boot"), - BasePaths = {"testkernelpath","teststdlibpath","testsaslpath"}, {error,{app_not_found,sasl}} = - systools_make:make_hybrid_boot("tmp_vsn",Boot1,Boot2, - BasePaths,[dummy,args]), + systools_make:make_hybrid_boot("tmp_vsn",Boot1,Boot2,[dummy,args]), ok = file:set_cwd(OldDir), ok. diff --git a/lib/sasl/test/test_lib.hrl b/lib/sasl/test/test_lib.hrl index 9a54937f96..f5210d4f27 100644 --- a/lib/sasl/test/test_lib.hrl +++ b/lib/sasl/test/test_lib.hrl @@ -1,3 +1,3 @@ -define(ertsvsn,"4.4"). --define(kernelvsn,"5.0"). --define(stdlibvsn,"3.0"). +-define(kernelvsn,"5.3"). +-define(stdlibvsn,"3.4"). diff --git a/lib/sasl/vsn.mk b/lib/sasl/vsn.mk index 2488197ec5..52b168598a 100644 --- a/lib/sasl/vsn.mk +++ b/lib/sasl/vsn.mk @@ -1 +1 @@ -SASL_VSN = 3.1.1 +SASL_VSN = 3.1.2 diff --git a/lib/ssh/doc/specs/.gitignore b/lib/ssh/doc/specs/.gitignore new file mode 100644 index 0000000000..322eebcb06 --- /dev/null +++ b/lib/ssh/doc/specs/.gitignore @@ -0,0 +1 @@ +specs_*.xml diff --git a/lib/ssh/doc/src/Makefile b/lib/ssh/doc/src/Makefile index f54f5e0708..0063484f72 100644 --- a/lib/ssh/doc/src/Makefile +++ b/lib/ssh/doc/src/Makefile @@ -84,12 +84,19 @@ HTML_REF_MAN_FILE = $(HTMLDIR)/index.html TOP_PDF_FILE = $(PDFDIR)/$(APPLICATION)-$(VSN).pdf +SPECS_FILES = $(XML_REF3_FILES:%.xml=$(SPECDIR)/specs_%.xml) + +TOP_SPECS_FILE = specs.xml + # ---------------------------------------------------- # FLAGS # ---------------------------------------------------- XML_FLAGS += DVIPS_FLAGS += +#SPECS_FLAGS = -I../../include -I../../../kernel/include +SPECS_FLAGS = -I../../../public_key/include -I../../../public_key/src -I../../.. + # ---------------------------------------------------- # Targets # ---------------------------------------------------- @@ -111,6 +118,7 @@ clean clean_docs: rm -rf $(HTMLDIR)/* rm -f $(MAN3DIR)/* rm -f $(TOP_PDF_FILE) $(TOP_PDF_FILE:%.pdf=%.fo) + rm -f $(SPECS_FILES) rm -f errs core *~ man: $(MAN3_FILES) $(MAN6_FILES) diff --git a/lib/ssh/doc/src/configure_algos.xml b/lib/ssh/doc/src/configure_algos.xml index dd60324851..15aece8968 100644 --- a/lib/ssh/doc/src/configure_algos.xml +++ b/lib/ssh/doc/src/configure_algos.xml @@ -117,6 +117,7 @@ <p>Due to this, it impossible to list in documentation what algorithms that are available in a certain installation.</p> <p>There is an important command to list the actual algorithms and their ordering: <seealso marker="ssh#default_algorithms-0">ssh:default_algorithms/0</seealso>.</p> + <marker id="example_default_algorithms"/> <code type="erl"> 0> ssh:default_algorithms(). [{kex,['ecdh-sha2-nistp384','ecdh-sha2-nistp521', @@ -156,7 +157,7 @@ <section> <title>Replacing the default set: preferred_algorithms</title> - <p>See the <seealso marker="ssh#option_preferred_algorithms">Reference Manual</seealso> for details</p> + <p>See the <seealso marker="ssh#type-preferred_algorithms_common_option">Reference Manual</seealso> for details</p> <p>Here follows a series of examples ranging from simple to more complex.</p> @@ -301,7 +302,7 @@ First one has to list them with <c>ssh:default_algorithms()</c> and then do changes in the lists.</p> <p>To facilitate addition or removal of algorithms the option <c>modify_algorithms</c> is available. - See the <seealso marker="ssh#option_modify_algorithms">Reference Manual</seealso> for details.</p> + See the <seealso marker="ssh#type-modify_algorithms_common_option">Reference Manual</seealso> for details.</p> <p>The option takes a list with instructions to append, prepend or remove algorithms:</p> <code type="erl"> diff --git a/lib/ssh/doc/src/notes.xml b/lib/ssh/doc/src/notes.xml index db60b4ab6f..d78309167a 100644 --- a/lib/ssh/doc/src/notes.xml +++ b/lib/ssh/doc/src/notes.xml @@ -30,6 +30,28 @@ <file>notes.xml</file> </header> +<section><title>Ssh 4.6.8</title> + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> + An ssh_sftp server (running version 6) could fail if it + is told to remove a file which in fact is a directory.</p> + <p> + Own Id: OTP-15004</p> + </item> + <item> + <p> + Fix rare spurios shutdowns of ssh servers when receiveing + <c>{'EXIT',_,normal}</c> messages.</p> + <p> + Own Id: OTP-15018</p> + </item> + </list> + </section> + +</section> + <section><title>Ssh 4.6.7</title> <section><title>Fixed Bugs and Malfunctions</title> @@ -59,8 +81,6 @@ </item> </list> </section> - - <section><title>Improvements and New Features</title> <list> <item> @@ -468,6 +488,20 @@ </section> +<section><title>Ssh 4.4.2.3</title> + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> + An ssh_sftp server (running version 6) could fail if it + is told to remove a file which in fact is a directory.</p> + <p> + Own Id: OTP-15004</p> + </item> + </list> + </section> +</section> + <section><title>Ssh 4.4.2.2</title> <section><title>Improvements and New Features</title> <list> @@ -871,6 +905,21 @@ </section> +<section><title>Ssh 4.2.2.6</title> + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> + Fix rare spurios shutdowns of ssh servers when receiveing + <c>{'EXIT',_,normal}</c> messages.</p> + <p> + Own Id: OTP-15018</p> + </item> + </list> + </section> +</section> + + <section><title>Ssh 4.2.2.5</title> <section><title>Improvements and New Features</title> <list> diff --git a/lib/ssh/doc/src/specs.xml b/lib/ssh/doc/src/specs.xml new file mode 100644 index 0000000000..3ab4f43aec --- /dev/null +++ b/lib/ssh/doc/src/specs.xml @@ -0,0 +1,12 @@ +<?xml version="1.0" encoding="utf-8" ?> +<specs xmlns:xi="http://www.w3.org/2001/XInclude"> + <xi:include href="../specs/specs_ssh_channel.xml"/> + <xi:include href="../specs/specs_ssh_client_key_api.xml"/> + <xi:include href="../specs/specs_ssh_connection.xml"/> + <xi:include href="../specs/specs_ssh_server_key_api.xml"/> + <xi:include href="../specs/specs_ssh_sftpd.xml"/> + <xi:include href="../specs/specs_ssh_sftp.xml"/> + <xi:include href="../specs/specs_ssh.xml"/> +</specs> + + diff --git a/lib/ssh/doc/src/ssh.xml b/lib/ssh/doc/src/ssh.xml index acf94ff6af..03078cfd83 100644 --- a/lib/ssh/doc/src/ssh.xml +++ b/lib/ssh/doc/src/ssh.xml @@ -11,8 +11,8 @@ 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 + + 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, @@ -31,185 +31,211 @@ <module>ssh</module> <modulesummary>Main API of the ssh application</modulesummary> <description> - <p>Interface module for the <c>ssh</c> application.</p> - <p>See <seealso marker="ssh:SSH_app#supported">ssh(6)</seealso> for details of supported version, - algorithms and unicode support.</p> + <p>This is the interface module for the <c>SSH</c> application. + The Secure Shell (SSH) Protocol is a protocol for secure remote login + and other secure network services over an insecure network. + See <seealso marker="ssh:SSH_app#supported">ssh(6)</seealso> for details of supported RFCs, versions, + algorithms and unicode handling. + </p> + <p>With the SSH application it is possible to start <i>clients</i> and to start <i>daemons</i> (servers). + </p> + <p>Clients are started with + <seealso marker="#connect/2">connect/2</seealso>, + <seealso marker="#connect/3">connect/3</seealso> or + <seealso marker="#connect/4">connect/4</seealso>. They open an encrypted connection on top of TCP/IP. + In that encrypted connection one or more channels could be opened with + <seealso marker="ssh_connection#session_channel/2">ssh_connection:session_channel/2,4</seealso>. + </p> + <p>Each channel is an isolated "pipe" between a client-side process and a server-side process. Thoose process + pairs could handle for example file transfers (sftp) or remote command execution (shell, exec and/or cli). + If a custom shell is implemented, the user of the client could execute the special commands remotely. Note that + the user is not necessarily a human but probably a system interfacing the SSH app. + </p> + <p>A server-side subssystem (channel) server is requested by the client with + <seealso marker="ssh_connection#subsystem/4">ssh_connection:subsystem/4</seealso>. + </p> + <p>A server (daemon) is started with + <seealso marker="#daemon/2">daemon/1</seealso>, + <seealso marker="#daemon/2">daemon/2</seealso> or + <seealso marker="#daemon/2">daemon/3</seealso>. + Possible channel handlers (subsystems) are declared with the + <seealso marker="#type-subsystem_daemon_option">subsystem</seealso> option when the daemon is started. + </p> + <p>To just run a shell on a remote machine, there are functions that bundles the needed + three steps needed into one: + <seealso marker="#shell/1">shell/1,2,3</seealso>. + Similarily, to just open an sftp (file transfer) connection to a remote machine, the simplest way is to use + <seealso marker="ssh_sftp#start_channel/1">ssh_sftp:start_channel/1,2,3</seealso>. + </p> + <p>To write your own client channel handler, use the behaviour + <seealso marker="ssh_channel">ssh_channel</seealso>. For own server channel handlers use the ssh_daemon_channel + behaviour: see the <seealso marker="ssh_channel#ssh_daemon_channel">note in ssh_channel</seealso>. + </p> + <p>Both clients and daemons accepts options that controls the exact behaviour. Some options are common to both. + The three sets are called + <seealso marker="#type-client_options">Client Options</seealso>, + <seealso marker="#type-daemon_options">Daemon Options</seealso> and + <seealso marker="#type-common_options">Common Options</seealso>. + </p> + <p>The descriptions of the options uses the + <seealso marker="doc/reference_manual:typespec">Erlang Type Language</seealso> with explaining text. + </p> + <note> + <p>The <seealso marker="users_guide">User's Guide</seealso> has examples and a + <seealso marker="using_ssh">Getting Started</seealso> + section. + </p> + </note> </description> <section> - <title>OPTIONS</title> - <p>The exact behaviour of some functions can be adjusted with the use of options which are documented together - with the functions. Generally could each option be used at most one time in each function call. If given two or more - times, the effect is not predictable unless explicitly documented.</p> - <p>The options are of different kinds:</p> - <taglist> - <tag>Limits</tag> - <item><p>which alters limits in the system, for example number of simultaneous login attempts.</p></item> - - <tag>Timeouts</tag> - <item><p>which give some defined behaviour if too long time elapses before a given event or action, - for example time to wait for an answer.</p></item> - - <tag>Callbacks</tag> - <item><p>which gives the caller of the function the possibility to execute own code on some events, - for example calling an own logging function or to perform an own login function</p></item> - - <tag>Behaviour</tag> - <item><p>which changes the systems behaviour.</p></item> - </taglist> + <title>Keys and files</title> + <p>A number of objects must be present for the SSH application to work. + Thoose objects are per default stored in files. + The default names, paths and file formats are the same as for + <url href="http://www.openssh.com">OpenSSH</url>. Keys could be generated with the <c>ssh-keygen</c> + program from OpenSSH. See the + <seealso marker="using_ssh#running-an-erlang-ssh-daemon">User's Guide</seealso>. + </p> + + <p>The paths could easily be changed by options: + <seealso marker="#type-user_dir_common_option"><c>user_dir</c></seealso> and + <seealso marker="#type-system_dir_daemon_option"><c>system_dir</c></seealso>. + </p> + <p>A completly different storage could be interfaced by writing call-back modules + using the behaviours + <seealso marker="ssh_client_key_api">ssh_client_key_api</seealso> and/or + <seealso marker="ssh_server_key_api">ssh_server_key_api</seealso>. + A callback module is installed with the option + <seealso marker="#type-key_cb_common_option"><c>key_cb</c></seealso> + to the client and/or the daemon. + </p> + + <section> + <title>Daemons</title> + <p>The keys are by default stored in files:</p> + <list> + <item>Mandatory: one or more <i>Host key(s)</i>, both private and public. Default is to + store them in the directory <c>/etc/ssh</c> in the files + <list> + <item><c>ssh_host_dsa_key</c> and <c>ssh_host_dsa_key.pub</c></item> + <item><c>ssh_host_rsa_key</c> and <c>ssh_host_rsa_key.pub</c></item> + <item><c>ssh_host_ecdsa_key</c> and <c>ssh_host_ecdsa_key.pub</c></item> + </list> + <p>The host keys directory could be changed with the option + <seealso marker="#type-system_dir_daemon_option"><c>system_dir</c></seealso>.</p> + </item> + <item>Optional: one or more <i>User's public key</i> in case of <c>publickey</c> authorization. + Default is to store them concatenated in the file <c>.ssh/authorized_keys</c> in the user's home directory. + <p>The user keys directory could be changed with the option + <seealso marker="#type-user_dir_common_option"><c>user_dir</c></seealso>.</p> + </item> + </list> + </section> + + <section> + <title>Clients</title> + <p>The keys and some other data are by default stored in files in the directory <c>.ssh</c> + in the user's home directory.</p> + <p>The directory could be changed with the option + <seealso marker="#type-user_dir_common_option"><c>user_dir</c></seealso>. + </p> + <list> + <item>Optional: a list of <i>Host public key(s)</i> for previously connected hosts. This list + is handled by the SSH application without any need of user assistance. The default + is to store them in the file <c>known_hosts</c>. + <p>The + <seealso marker="#type-host_accepting_client_options">host_accepting_client_options()</seealso> + are associated with this list of keys. + </p> + </item> + <item>Optional: one or more <i>User's private key(s)</i> in case of <c>publickey</c> authorization. + The default files are + <list> + <item><c>id_dsa</c> and <c>id_dsa.pub</c></item> + <item><c>id_rsa</c> and <c>id_rsa.pub</c></item> + <item><c>id_ecdsa</c> and <c>id_ecdsa.pub</c></item> + </list> + </item> + </list> + </section> + </section> - <section> - <title>DATA TYPES</title> - <p>Type definitions that are used more than once in - this module, or abstractions to indicate the intended use of the data - type, or both:</p> - <taglist> - <tag><c>boolean() =</c></tag> - <item><p><c>true | false</c></p></item> - <tag><c>string() =</c></tag> - <item><p><c>[byte()]</c></p></item> - <tag><c>ssh_daemon_ref() =</c></tag> - <item><p>opaque() - - as returned by <c>ssh:daemon/[1,2,3]</c></p></item> - <tag><c>ssh_connection_ref() =</c></tag> - <item><p>opaque() - as returned by <c>ssh:connect/3</c></p></item> - <tag><c>ip_address() =</c></tag> - <item><p><c>inet::ip_address</c></p></item> - <tag><c>subsystem_spec() =</c></tag> - <item><p><c>{subsystem_name(), - {channel_callback(), channel_init_args()}}</c></p></item> - <tag><c>subsystem_name() =</c></tag> - <item><p><c>string()</c></p></item> - <tag><c>channel_callback() =</c></tag> - <item><p><c>atom()</c> - Name of the Erlang module - implementing the subsystem using the <c>ssh_channel</c> behavior, see - <seealso marker="ssh_channel">ssh_channel(3)</seealso></p></item> - <tag><c>key_cb() =</c></tag> - <item> - <p><c>atom() | {atom(), list()}</c></p> - <p><c>atom()</c> - Name of the erlang module implementing the behaviours - <seealso marker="ssh_client_key_api">ssh_client_key_api</seealso> or - <seealso marker="ssh_client_key_api">ssh_client_key_api</seealso> as the - case maybe.</p> - <p><c>list()</c> - List of options that can be passed to the callback module.</p> - </item> - <tag><c>channel_init_args() =</c></tag> - <item><p><c>list()</c></p></item> - - <tag><c>algs_list() =</c></tag> - <item><p><c>list( alg_entry() )</c></p></item> - - <tag><c>alg_entry() =</c></tag> - <item><p><c>{kex, simple_algs()} | {public_key, simple_algs()} | {cipher, double_algs()} | {mac, double_algs()} | {compression, double_algs()}</c></p></item> - - <tag><c>simple_algs() =</c></tag> - <item><p><c>list( atom() )</c></p></item> - - <tag><c>double_algs() =</c></tag> - <item><p><c>[{client2serverlist,simple_algs()},{server2client,simple_algs()}] | simple_algs()</c></p></item> + <!-- + ================================================================ + = Data types = + ================================================================ + --> - <tag><c>modify_algs_list() =</c></tag> - <item><p><c>list( {append,algs_list()} | {prepend,algs_list()} | {rm,algs_list()} )</c></p></item> - </taglist> -</section> + <datatypes> - <funcs> - - <func> - <name>close(ConnectionRef) -> ok </name> - <fsummary>Closes an SSH connection.</fsummary> - <type> - <v>ConnectionRef = ssh_connection_ref()</v> - </type> - <desc><p>Closes an SSH connection.</p> + <datatype_title>Client Options</datatype_title> + + <datatype> + <name name="client_options"/> + <name name="client_option"/> + <desc> + <p>Options for <seealso marker="#connect/3">clients</seealso>. + The individual options are further explained below or by following the hyperlinks. + </p> </desc> - </func> - - <func> - <name>connect(Host, Port, Options) -> </name> - <name>connect(Host, Port, Options, Timeout) -> </name> - <name>connect(TcpSocket, Options) -> </name> - <name>connect(TcpSocket, Options, Timeout) -> - {ok, ssh_connection_ref()} | {error, Reason}</name> - <fsummary>Connects to an SSH server.</fsummary> - <type> - <v>Host = string()</v> - <v>Port = integer()</v> - <d><c><![CDATA[22]]></c> is default, the assigned well-known port - number for SSH.</d> - <v>Options = [{Option, Value}]</v> - <v>Timeout = infinity | integer()</v> - <d>Negotiation time-out in milli-seconds. The default value is <c>infinity</c>. - For connection time-out, use option <c>{connect_timeout, timeout()}</c>.</d> - <v>TcpSocket = port()</v> - <d>The socket is supposed to be from <seealso marker="kernel:gen_tcp#connect-3">gen_tcp:connect</seealso> or <seealso marker="kernel:gen_tcp#accept-1">gen_tcp:accept</seealso> with option <c>{active,false}</c></d> - </type> + </datatype> + + <datatype> + <name name="pref_public_key_algs_client_option"/> + <desc> + <p>List of user (client) public key algorithms to try to use.</p> + <p>The default value is the <c>public_key</c> entry in the list returned by + <seealso marker="#default_algorithms/0">ssh:default_algorithms/0</seealso>. + </p> + <p>If there is no public key of a specified type available, the corresponding entry is ignored. + Note that the available set is dependent on the underlying cryptolib and current user's public keys. + </p> + <p>See also the option <seealso marker="#type-user_dir_common_option"><c>user_dir</c></seealso> + for specifying the path to the user's keys. + </p> + </desc> + </datatype> + + <datatype> + <name name="pubkey_passphrase_client_options"/> + <desc> + <p>If the user's DSA, RSA or ECDSA key is protected by a passphrase, it can be + supplied with thoose options. + </p> + </desc> + </datatype> + + <datatype> + <name name="host_accepting_client_options"/> + <name name="accept_hosts"/> + <name name="fp_digest_alg"/> + <name name="accept_callback"/> + <name name="fingerprint"/> <desc> - <p>Connects to an SSH server. No channel is started. This is done - by calling - <seealso marker="ssh_connection#session_channel/2"> - ssh_connection:session_channel/[2, 4]</seealso>.</p> - <p>Options:</p> <taglist> - <tag><c><![CDATA[{inet, inet | inet6}]]></c></tag> - <item> - <p>IP version to use.</p> - </item> - <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 - <c><![CDATA[known_hosts]]></c>, <c><![CDATA[id_rsa, - id_dsa]]></c>, and - <c><![CDATA[authorized_key]]></c>. Defaults to the - directory normally referred to as - <c><![CDATA[~/.ssh]]></c>.</p> - </item> - <tag><c><![CDATA[{dsa_pass_phrase, string()}]]></c></tag> - <item> - <p>If the user DSA key is protected by a passphrase, it can be - supplied with this option. - </p> - </item> - <tag><c><![CDATA[{rsa_pass_phrase, string()}]]></c></tag> - <item> - <p>If the user RSA key is protected by a passphrase, it can be - supplied with this option. - </p> - </item> - <tag><c><![CDATA[{ecdsa_pass_phrase, string()}]]></c></tag> - <item> - <p>If the user ECDSA key is protected by a passphrase, it can be - supplied with this option. - </p> - </item> - <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> + <tag><c>silently_accept_hosts</c></tag> <item> - <p>This option guides the <c>connect</c> function how to act when the connected server presents a Host + <p>This option guides the <c>connect</c> function on 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> + See the option <seealso marker="#type-user_dir_common_option"><c>user_dir</c></seealso> + for specifying the path to the file <c>known_hosts</c> where previously accepted Host Keys are recorded. + See also the option + <seealso marker="#type-key_cb_common_option">key_cb</seealso> + for the general way to handle keys. + </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>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> preserves the default behaviour of asking 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: + <item>An <c>accept_callback()</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 as a + result 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 @@ -218,471 +244,334 @@ </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>A tuple <c>{HashAlgoSpec, accept_callback}</c>. The <c>HashAlgoSpec</c> + specifies which hash algorithm + shall be used to calculate the fingerprint used in the call of the <c>accept_callback()</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>accept_callback()</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[{save_accepted_host, boolean()}]]></c></tag> - <item> - <p>If <c>true</c>, the client saves an accepted host key to avoid the - accept question the next time the same host is connected. If the option - <c>key_cb</c> is not present, the key is saved in the file "known_hosts". - </p> - <p>If <c>false</c>, the key is not saved and the key will still be unknown - at the next access of the same host. - </p> - </item> - - <tag><c><![CDATA[{user_interaction, boolean()}]]></c></tag> + + <tag><c>user_interaction</c></tag> <item> <p>If <c>false</c>, disables the client to connect to the server if any user interaction is needed, such as accepting the server to be added to the <c>known_hosts</c> file, or - supplying a password. Defaults to <c>true</c>. - Even if user interaction is allowed it can be + supplying a password.</p> + <p>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 options are not always desirable to use from a security point of view.</p> + <p>Defaults to <c>true</c>.</p> </item> - <tag><c><![CDATA[{disconnectfun, fun(Reason:term()) -> _}]]></c></tag> + <tag><c>save_accepted_host</c></tag> <item> - <p>Provides a fun to implement your own logging when a server disconnects the client.</p> - </item> - - <tag><c><![CDATA[{unexpectedfun, fun(Message:term(), Peer) -> report | skip }]]></c></tag> - <item> - <p>Provides a fun to implement your own logging or other action when an unexpected message arrives. - If the fun returns <c>report</c> the usual info report is issued but if <c>skip</c> is returned no - report is generated.</p> - <p><c>Peer</c> is in the format of <c>{Host,Port}</c>.</p> - </item> - - <tag><c><![CDATA[{pref_public_key_algs, list()}]]></c></tag> - <item> - <p>List of user (client) public key algorithms to try to use.</p> - <p>The default value is the <c>public_key</c> entry in - <seealso marker="#default_algorithms/0">ssh:default_algorithms/0</seealso>. - </p> - <p>If there is no public key of a specified type available, the corresponding entry is ignored. - Note that the available set is dependent on the underlying cryptolib and current user's public keys. - </p> - </item> - - <tag><marker id="option_preferred_algorithms"></marker> - <c><![CDATA[{preferred_algorithms, algs_list()}]]></c></tag> - <item> - <p>List of algorithms to use in the algorithm negotiation. The default <c>algs_list()</c> can - be obtained from <seealso marker="#default_algorithms/0">default_algorithms/0</seealso>. + <p>If <c>true</c>, the client saves an accepted host key to avoid the + accept question the next time the same host is connected. If the option + <seealso marker="#type-key_cb_common_option"><c>key_cb</c></seealso> + is not present, the key is saved in the file "known_hosts". See option + <seealso marker="#type-user_dir_common_option"><c>user_dir</c></seealso> for + the location of that file. </p> - <p>If an alg_entry() is missing in the algs_list(), the default value is used for that entry.</p> - <p>Here is an example of this option:</p> - <code> -{preferred_algorithms, - [{public_key,['ssh-rsa','ssh-dss']}, - {cipher,[{client2server,['aes128-ctr']}, - {server2client,['aes128-cbc','3des-cbc']}]}, - {mac,['hmac-sha2-256','hmac-sha1']}, - {compression,[none,zlib]} - ] -} -</code> - <p>The example specifies different algorithms in the two directions (client2server and server2client), - for cipher but specifies the same algorithms for mac and compression in both directions. - The kex (key exchange) is implicit but public_key is set explicitly.</p> - - <p>For background and more examples see the <seealso marker="configure_algos#introduction">User's Guide</seealso>.</p> - - <warning> - <p>Changing the values can make a connection less secure. Do not change unless you - know exactly what you are doing. If you do not understand the values then you - are not supposed to change them.</p> - </warning> - </item> - - <tag><marker id="option_modify_algorithms"></marker> - <c><![CDATA[{modify_algorithms, modify_algs_list()}]]></c></tag> - <item> - <p>Modifies the list of algorithms to use in the algorithm negotiation. The modifications are - applied after the option <c>preferred_algorithms</c> (if existing) is applied.</p> - <p>The algoritm for modifications works like this:</p> - <list> - <item> - <p>Input is the <c>modify_algs_list()</c> and a set of algorithms <c>A</c> - obtained from the <c>preferred_algorithms</c> option if existing, or else from the - <seealso marker="ssh#default_algorithms-0">ssh:default_algorithms/0</seealso>. - </p> - </item> - <item> - <p>The head of the <c>modify_algs_list()</c> modifies <c>A</c> giving the result <c>A'</c>.</p> - <p>The possible modifications are:</p> - <list> - <item> - <p>Append or prepend supported but not enabled algorithm(s) to the list of - algorithms. If the wanted algorithms already are in <c>A</c> they will first - be removed and then appended or prepended, - </p> - </item> - <item> - <p>Remove (rm) one or more algorithms from <c>A</c>. - </p> - </item> - </list> - </item> - <item> - <p>Repeat the modification step with the tail of <c>modify_algs_list()</c> and the resulting - <c>A'</c>. - </p> - </item> - </list> - <p>If an unsupported algorithm is in the <c>modify_algs_list()</c>, it will be silently ignored</p> - <p>If there are more than one modify_algorithms options, the result is undefined.</p> - <p>Here is an example of this option:</p> - <code> -{modify_algorithms, - [{prepend, [{kex, ['diffie-hellman-group1-sha1']}], - {rm, [{compression, [none]}]} - ] -} -</code> - <p>The example specifies that:</p> - <list> - <item><p>the old key exchange algorithm 'diffie-hellman-group1-sha1' should be - the main alternative. It will be the main alternative since it is prepened to the list</p> - </item> - <item><p>The compression algorithm none (= no compression) is removed so compression is enforced</p> - </item> - </list> - <p>For background and more examples see the <seealso marker="configure_algos#introduction">User's Guide</seealso>.</p> - </item> - - <tag><c><![CDATA[{dh_gex_limits,{Min=integer(),I=integer(),Max=integer()}}]]></c></tag> - <item> - <p>Sets the three diffie-hellman-group-exchange parameters that guides the connected server in choosing a group. - See RFC 4419 for the function of thoose. The default value is <c>{1024, 6144, 8192}</c>. + <p>If <c>false</c>, the key is not saved and the key will still be unknown + at the next access of the same host. </p> + <p>Defaults to <c>true</c></p> </item> - <tag><c><![CDATA[{connect_timeout, timeout()}]]></c></tag> + <tag><c>quiet_mode</c></tag> <item> - <p>Sets a time-out on the transport layer - connection. For <c>gen_tcp</c> the time is in milli-seconds and the default value is - <c>infinity</c>.</p> + <p>If <c>true</c>, the client does not print anything on authorization.</p> + <p>Defaults to <c>false</c></p> </item> + </taglist> + </desc> + </datatype> - <tag><c><![CDATA[{auth_methods, string()}]]></c></tag> - <item> - <p>Comma-separated string that determines which - authentication methods that the client shall support and - in which order they are tried. Defaults to - <c><![CDATA["publickey,keyboard-interactive,password"]]></c></p> - </item> - - <tag><c><![CDATA[{user, string()}]]></c></tag> + <datatype> + <name name="authentication_client_options"/> + <desc> + <taglist> + <tag><c>user</c></tag> <item> - <p>Provides a username. If this option is not given, <c>ssh</c> + <p>Provides the username. If this option is not given, <c>ssh</c> reads from the environment (<c><![CDATA[LOGNAME]]></c> or <c><![CDATA[USER]]></c> on UNIX, <c><![CDATA[USERNAME]]></c> on Windows).</p> </item> - <tag><c><![CDATA[{password, string()}]]></c></tag> + <tag><c>password</c></tag> <item> <p>Provides a password for password authentication. If this option is not given, the user is asked for a password, if the password authentication method is attempted.</p> </item> - - <!--tag><c><![CDATA[{send_ext_info, boolean()}]]></c></tag> - <item> - <p>Send a list of extensions to the server if the server has asked for it. See - <url href="https://tools.ietf.org/html/draft-ietf-curdle-ssh-ext-info">Draft-ietf-curdle-ssh-ext-info (work in progress)</url> for details. - </p> - <p>Currently the client do not react on any extensions. - </p> - <p>Default value is <c>true</c>. - </p> - </item--> - - <tag><c><![CDATA[{recv_ext_info, boolean()}]]></c></tag> - <item> - <p>Tell the server that the client accepts extension negotiation. See - <url href="https://tools.ietf.org/html/draft-ietf-curdle-ssh-ext-info">Draft-ietf-curdle-ssh-ext-info (work in progress)</url> for details. - </p> - <p>Currently implemented extension is <c>server-sig-algs</c> which is the list of the server's preferred - user's public key algorithms. - </p> - <p>Default value is <c>true</c>. - </p> - </item> - - <tag><c><![CDATA[{key_cb, key_cb()}]]></c></tag> - <item> - <p>Module implementing the behaviour <seealso - marker="ssh_client_key_api">ssh_client_key_api</seealso>. Can be used to - customize the handling of public keys. If callback options are provided - along with the module name, they are made available to the callback - module via the options passed to it under the key 'key_cb_private'. - </p> - </item> - - <tag><c><![CDATA[{quiet_mode, atom() = boolean()}]]></c></tag> - <item> - <p>If <c>true</c>, the client does not print anything on authorization.</p> - </item> - - <tag><c><![CDATA[{id_string, random | string()}]]></c></tag> - <item> - <p>The string that the client presents to a connected server initially. The default value is "Erlang/VSN" where VSN is the ssh application version number. - </p> - <p>The value <c>random</c> will cause a random string to be created at each connection attempt. This is to make it a bit more difficult for a malicious peer to find the ssh software brand and version. - </p> - </item> - - <tag><c><![CDATA[{fd, file_descriptor()}]]></c></tag> - <item> - <p>Allows an existing file descriptor to be used - (by passing it on to the transport protocol).</p></item> - <tag><c><![CDATA[{rekey_limit, integer()}]]></c></tag> - <item> - <p>Provides, in bytes, when rekeying is to be initiated. - Defaults to once per each GB and once per hour.</p> - </item> - <tag><c><![CDATA[{idle_time, integer()}]]></c></tag> - <item> - <p>Sets a time-out on a connection when no channels are active. - Defaults to <c>infinity</c>.</p></item> - <tag><c><![CDATA[{ssh_msg_debug_fun, fun(ConnectionRef::ssh_connection_ref(), AlwaysDisplay::boolean(), Msg::binary(), LanguageTag::binary()) -> _}]]></c></tag> - <item> - <p>Provide a fun to implement your own logging of the SSH message SSH_MSG_DEBUG. The last three parameters are from the message, see RFC4253, section 11.3. The <c>ConnectionRef</c> is the reference to the connection on which the message arrived. The return value from the fun is not checked.</p> - <p>The default behaviour is ignore the message. - To get a printout for each message with <c>AlwaysDisplay = true</c>, use for example <c>{ssh_msg_debug_fun, fun(_,true,M,_)-> io:format("DEBUG: ~p~n", [M]) end}</c></p> - </item> - </taglist> - </desc> - </func> + </desc> + </datatype> - <func> - <name>connection_info(ConnectionRef, [Option]) ->[{Option, - Value}]</name> - <fsummary>Retrieves information about a connection.</fsummary> - <type> - <v>Option = client_version | server_version | user | peer | sockname </v> - <v>Value = [option_value()] </v> - <v>option_value() = {{Major::integer(), Minor::integer()}, VersionString::string()} | - User::string() | Peer::{inet:hostname(), {inet::ip_adress(), inet::port_number()}} | - Sockname::{inet::ip_adress(), inet::port_number()}</v> - </type> + <datatype> + <name name="diffie_hellman_group_exchange_client_option"/> <desc> - <p>Retrieves information about a connection.</p> + <p>Sets the three diffie-hellman-group-exchange parameters that guides the connected server in choosing a group. + See + <url href="https://tools.ietf.org/html/rfc4419">RFC 4419</url> + for the details. The default value is <c>{1024, 6144, 8192}</c>. + </p> </desc> - </func> - - <func> - <name>daemon(Port) -> </name> - <name>daemon(Port, Options) -> </name> - <name>daemon(HostAddress, Port, Options) -> </name> - <name>daemon(TcpSocket) -> </name> - <name>daemon(TcpSocket, Options) -> {ok, ssh_daemon_ref()} | {error, atom()}</name> - <fsummary>Starts a server listening for SSH connections - on the given port.</fsummary> - <type> - <v>Port = integer()</v> - <v>HostAddress = ip_address() | any | loopback</v> - <v>Options = [{Option, Value}]</v> - <v>Option = atom()</v> - <v>Value = term()</v> - <v>TcpSocket = port()</v> - <d>The socket is supposed to be from <seealso marker="kernel:gen_tcp#connect-3">gen_tcp:connect</seealso> or <seealso marker="kernel:gen_tcp#accept-1">gen_tcp:accept</seealso> with option <c>{active,false}</c></d> - </type> - <desc> - <p>Starts a server listening for SSH connections on the given - port. If the <c>Port</c> is 0, a random free port is selected. See - <seealso marker="#daemon_info/1">daemon_info/1</seealso> about how to find the selected port number.</p> + </datatype> - <p>Please note that by historical reasons both the <c>HostAddress</c> argument and the inet socket option - <c>ip</c> set the listening address. This is a source of possible inconsistent settings.</p> + <datatype> + <name name="connect_timeout_client_option"/> + <desc> + <p>Sets a timeout on the transport layer connect time. + For <seealso marker="kernel:gen_tcp"><c>gen_tcp</c></seealso> the time is in milli-seconds and the default + value is <c>infinity</c>. + </p> + <p>See the parameter <c>Timeout</c> in <seealso marker="#connect/4">connect/4</seealso> for + a timeout of the negotiation phase. + </p> + </desc> + </datatype> - <p>The rules for handling the two address passing options are:</p> - <list> - <item>if <c>HostAddress</c> is an IP-address, that IP-address is the listening address. - An 'ip'-option will be discarded if present.</item> + <datatype> + <name name="recv_ext_info_client_option"/> + <desc> + <p>Make the client tell the server that the client accepts extension negotiation, that is, + include <c>ext-info-c</c> in the kexinit message sent. See + <url href="https://tools.ietf.org/html/rfc8308">RFC 8308</url> + for details and <seealso marker="SSH_app#supported-ext-info">ssh(6)</seealso> + for a list of currently implemented extensions. + </p> + <p> + Default value is <c>true</c> which is compatible with other implementations not supporting ext-info. + </p> + </desc> + </datatype> - <item>if <c>HostAddress</c> is <c>loopback</c>, the listening address - is <c>loopback</c> and an loopback address will be choosen by the underlying layers. - An 'ip'-option will be discarded if present.</item> + <!--................................................................--> + <datatype_title>Daemon Options (Server Options)</datatype_title> - <item>if <c>HostAddress</c> is <c>any</c> and no 'ip'-option is present, the listening address is - <c>any</c> and the socket will listen to all addresses</item> + <datatype> + <name name="daemon_options"/> + <name name="daemon_option"/> + <desc> + <p>Options for <seealso marker="#daemon/1">daemons</seealso>. + The individual options are further explained below or by following the hyperlinks. + </p> + </desc> + </datatype> - <item>if <c>HostAddress</c> is <c>any</c> and an 'ip'-option is present, the listening address is - set to the value of the 'ip'-option</item> - </list> + + <datatype> + <name name="subsystem_daemon_option"/> + <name name="subsystem_spec"/> + <desc> + <p>Defines a subsystem in the daemon.</p> + <p>The <c>subsystem_name</c> is the name that a client requests to start with for example + <seealso marker="ssh_connection#subsystem/4">ssh_connection:subsystem/4</seealso>. + </p> + <p>The <c>channel_callback</c> is the module that implements the <c>ssh_daemon_channel</c> + behaviour in the daemon. See the section + <seealso marker="using_ssh#usersguide_creating_a_subsystem">Creating a Subsystem</seealso> + in the User's Guide for more information and an example. + </p> + <p>If the subsystems option is not present, the value of <c>ssh_sftpd:subsystem_spec([])</c> is used. + This enables the sftp subsystem by default. + The option can be set to the empty list if you do not want the daemon to run any subsystems.</p> + </desc> + </datatype> - <p>Options:</p> - <taglist> - <tag><c><![CDATA[{inet, inet | inet6}]]></c></tag> - <item><p>IP version to use when the host address is specified as <c>any</c>.</p></item> - <tag><c><![CDATA[{subsystems, [subsystem_spec()]}]]></c></tag> + <datatype> + <name name="shell_daemon_option"/> + <name name="'shell_fun/1'"/> + <name name="'shell_fun/2'"/> + <desc> + <p>Defines the read-eval-print loop used in a daemon when a shell is requested by the client. + The default is to use the Erlang shell: <c><![CDATA[{shell, start, []}]]></c> + </p> + <p>See the option <seealso marker="#type-exec_daemon_option"><c>exec</c></seealso> + for a description of how the daemon execute exec-requests depending on + the shell- and exec-options.</p> + </desc> + </datatype> + + <datatype> + <name name="exec_daemon_option"/> + <name name="'exec_fun/1'"/> + <name name="'exec_fun/2'"/> + <name name="'exec_fun/3'"/> + <name name="exec_result"/> + <desc> + <p>This option changes how the daemon execute exec-requests from clients. The term in the return value + is formatted to a string if it is a non-string type. No trailing newline is added in the ok-case but in the + error case.</p> + <p>Error texts are returned on channel-type 1 which usually is piped to <c>stderr</c> on e.g Linux systems. + Texts from a successful execution will in similar manner be piped to <c>stdout</c>. The exit-status code + is set to 0 for success and -1 for errors. The exact results presented on the client side depends on the + client and the client's operating system. + </p> + <p>The option cooperates with the daemon-option <seealso marker="#type-shell_daemon_option"><c>shell</c></seealso> + in the following way:</p> + <taglist> + <tag>1. If the exec-option is present (the shell-option may or may not be present):</tag> <item> - <p>Provides specifications for handling of subsystems. The - "sftp" subsystem specification is retrieved by calling - <c>ssh_sftpd:subsystem_spec/1</c>. If the subsystems option is - not present, the value of - <c>[ssh_sftpd:subsystem_spec([])]</c> is used. - The option can be set to the empty list if - you do not want the daemon to run any subsystems.</p> + <p>The exec-option fun is called with the same number of parameters as the arity of the fun, + and the result is returned to the client. + </p> </item> - <tag><c><![CDATA[{shell, {Module, Function, Args} | - fun(string() = User) - > pid() | fun(string() = User, - ip_address() = PeerAddr) -> pid()}]]></c></tag> + + <tag>2. If the exec-option is absent, but a shell-option is present with the default Erlang shell:</tag> <item> - <p>Defines the read-eval-print loop used when a shell is - requested by the client. The default is to use the Erlang shell: - <c><![CDATA[{shell, start, []}]]></c></p> + <p>The default Erlang evaluator is used and the result is returned to the client.</p> </item> - <tag><c><![CDATA[{ssh_cli, {channel_callback(), - channel_init_args()} | no_cli}]]></c></tag> + + <tag>3. If the exec-option is absent, but a shell-option is present that is not the default Erlang shell:</tag> <item> - <p>Provides your own CLI implementation, that is, a channel callback - module that implements a shell and command execution. The shell - read-eval-print loop can be customized, using the - option <c>shell</c>. This means less work than implementing - an own CLI channel. If set to <c>no_cli</c>, the CLI channels - are disabled and only subsystem channels are allowed.</p> + <p>The exec-request is not evaluated and an error message is returned to the client.</p> </item> - <tag><c><![CDATA[{user_dir, string()}]]></c></tag> + + <tag>4. If neither the exec-option nor the shell-option is present:</tag> <item> - <p>Sets the user directory. That is, the directory containing - <c>ssh</c> configuration files for the user, such as - <c><![CDATA[known_hosts]]></c>, <c><![CDATA[id_rsa, - id_dsa]]></c>, and - <c><![CDATA[authorized_key]]></c>. Defaults to the - directory normally referred to as - <c><![CDATA[~/.ssh]]></c>.</p> + <p>The default Erlang evaluator is used and the result is returned to the client.</p> </item> - <tag><c><![CDATA[{system_dir, string()}]]></c></tag> + </taglist> + <p>If a custom CLI is installed (see the option <seealso marker="#type-ssh_cli_daemon_option"><c>ssh_cli</c></seealso>) + the rules above are replaced by thoose implied by the custom CLI. + </p> + <note> + <p>The exec-option has existed for a long time but has not previously been documented. The old + definition and behaviour are retained but obey the rules 1-4 above if conflicting. + The old and undocumented style should not be used in new programs.</p> + </note> + </desc> + </datatype> + + <datatype> + <name name="ssh_cli_daemon_option"/> + <desc> + <p>Provides your own CLI implementation in a daemon.</p> + <p>It is a channel callback module that implements a shell + and command execution. The shell's read-eval-print loop can be customized, using the + option <seealso marker="#type-shell_daemon_option"><c>shell</c></seealso>. This means less work than implementing + an own CLI channel. If <c>ssh_cli</c> is set to <c>no_cli</c>, the CLI channels + like <seealso marker="#type-shell_daemon_option"><c>shell</c></seealso> + and <seealso marker="#type-exec_daemon_option"><c>exec</c></seealso> + are disabled and only subsystem channels are allowed.</p> + </desc> + </datatype> + + <datatype> + <name name="authentication_daemon_options"/> + <name name="prompt_texts"/> + <name name="kb_int_tuple"/> + <name name="kb_int_fun_3"/> + <name name="pwdfun_2"/> + <name name="pwdfun_4"/> + <desc> + <taglist> + <tag><marker id="type-system_dir_daemon_option"/><c>system_dir</c></tag> <item> <p>Sets the system directory, containing the host key files that identify the host keys for <c>ssh</c>. Defaults to - <c><![CDATA[/etc/ssh]]></c>. For security reasons, - this directory is normally accessible only to the root user.</p> + <c>/etc/ssh</c>.</p> + <p>For security reasons, this directory is normally accessible only to the root user.</p> + <p>See also the option + <seealso marker="#type-key_cb_common_option">key_cb</seealso> + for the general way to handle keys. + </p> </item> - <tag><c><![CDATA[{auth_methods, string()}]]></c></tag> + <tag><c>auth_method_kb_interactive_data</c></tag> <item> - <p>Comma-separated string that determines which - authentication methods that the server is to support and - in what order they are tried. Defaults to - <c><![CDATA["publickey,keyboard-interactive,password"]]></c></p> - <p>Note that the client is free to use any order and to exclude methods.</p> - </item> - - <tag><c><![CDATA[{auth_method_kb_interactive_data, PromptTexts}]]></c> - <br/><c>where:</c> - <br/><c>PromptTexts = kb_int_tuple() | fun(Peer::{IP::tuple(),Port::integer()}, User::string(), Service::string()) -> kb_int_tuple()</c> - <br/><c>kb_int_tuple() = {Name::string(), Instruction::string(), Prompt::string(), Echo::boolean()}</c> - </tag> - <item> - <p>Sets the text strings that the daemon sends to the client for presentation to the user when using <c>keyboar-interactive</c> authentication. If the fun/3 is used, it is called when the actual authentication occurs and may therefore return dynamic data like time, remote ip etc.</p> + <p>Sets the text strings that the daemon sends to the client for presentation to the user when + using <c>keyboard-interactive</c> authentication.</p> + <p>If the fun/3 is used, it is called when the actual authentication occurs and may therefore + return dynamic data like time, remote ip etc.</p> <p>The parameter <c>Echo</c> guides the client about need to hide the password.</p> <p>The default value is: - <c>{auth_method_kb_interactive_data, {"SSH server", "Enter password for \""++User++"\"", "password: ", false}></c></p> + <c>{auth_method_kb_interactive_data, {"SSH server", "Enter password for \""++User++"\"", "password: ", false}></c> + </p> </item> - <tag><c><![CDATA[{user_passwords, [{string() = User, - string() = Password}]}]]></c></tag> + <tag><c>user_passwords</c></tag> <item> - <p>Provides passwords for password authentication. The passwords - are used when someone tries to connect to the server and - public key user-authentication fails. The option provides + <p>Provides passwords for password authentication. The passwords are used when someone tries + to connect to the server and public key user-authentication fails. The option provides a list of valid usernames and the corresponding passwords. </p> </item> - <tag><c><![CDATA[{password, string()}]]></c></tag> + + <tag><c>password</c></tag> <item> - <p>Provides a global password that authenticates any - user. From a security perspective this option makes - the server very vulnerable.</p> + <p>Provides a global password that authenticates any user.</p> + <warning> + <p>Intended to facilitate testing.</p> + <p>From a security perspective this option makes the server very vulnerable.</p> + </warning> </item> - <tag><c><![CDATA[{preferred_algorithms, algs_list()}]]></c></tag> + <tag><c>pwdfun</c> with <c>pwdfun_4()</c></tag> <item> - <p>List of algorithms to use in the algorithm negotiation. The default <c>algs_list()</c> can - be obtained from <seealso marker="#default_algorithms/0">default_algorithms/0</seealso>. + <p>Provides a function for password validation. This could used for calling an external system or handeling + passwords stored as hash values. </p> - <p>If an alg_entry() is missing in the algs_list(), the default value is used for that entry.</p> - <p>Here is an example of this option:</p> - <code> -{preferred_algorithms, - [{public_key,['ssh-rsa','ssh-dss']}, - {cipher,[{client2server,['aes128-ctr']}, - {server2client,['aes128-cbc','3des-cbc']}]}, - {mac,['hmac-sha2-256','hmac-sha1']}, - {compression,[none,zlib]} - ] -} -</code> - <p>The example specifies different algorithms in the two directions (client2server and server2client), - for cipher but specifies the same algorithms for mac and compression in both directions. - The kex (key exchange) is implicit but public_key is set explicitly.</p> - - <p>For background and more examples see the <seealso marker="configure_algos#introduction">User's Guide</seealso>.</p> + <p>This fun can also be used to make delays in authentication tries for example by calling + <seealso marker="stdlib:timer#sleep/1">timer:sleep/1</seealso>.</p> + <p>To facilitate for instance counting of failed tries, + the <c>State</c> variable could be used. This state is per connection only. The first time the pwdfun + is called for a connection, the <c>State</c> variable has the value <c>undefined</c>. + </p> + + <p>The fun should return: + </p> + <list type="bulleted"> + <item><c>true</c> if the user and password is valid</item> + <item><c>false</c> if the user or password is invalid</item> + <item><c>disconnect</c> if a SSH_MSG_DISCONNECT message should be sent immediately. It will + be followed by a close of the underlying tcp connection.</item> + <item><c>{true, NewState:any()}</c> if the user and password is valid</item> + <item><c>{false, NewState:any()}</c> if the user or password is invalid</item> + </list> - <warning> - <p>Changing the values can make a connection less secure. Do not change unless you - know exactly what you are doing. If you do not understand the values then you - are not supposed to change them.</p> - </warning> + <p>A third usage is to block login attempts from a missbehaving peer. The <c>State</c> described above + can be used for this. The return value <c>disconnect</c> is useful for this.</p> </item> - <tag><marker id="option_modify_algorithms"></marker> - <c><![CDATA[{modify_algorithms, modify_algs_list()}]]></c></tag> + <tag><c>pwdfun</c> with <c>pwdfun_2()</c></tag> <item> - <p>Modifies the list of algorithms to use in the algorithm negotiation. The modifications are - applied after the option <c>preferred_algorithms</c> is applied (if existing)</p> - <p>The possible modifications are to:</p> - <list> - <item><p>Append or prepend supported but not enabled algorithm(s) to the list of - algorithms.</p><p>If the wanted algorithms already are in the list of algorithms, they will first - be removed and then appended or prepended. - </p> - </item> - <item><p>Remove (rm) one or more algorithms from the list of algorithms.</p></item> + <p>Provides a function for password validation. This function is called with user and password + as strings, and returns:</p> + <list type="bulleted"> + <item><c>true</c> if the user and password is valid</item> + <item><c>false</c> if the user or password is invalid</item> </list> - <p>If an unsupported algorithm is in the list, it will be silently ignored</p> - - <p>Here is an example of this option:</p> - <code> -{modify_algorithms, - [{prepend, [{kex, ['diffie-hellman-group1-sha1']}], - {rm, [{compression, [none]}]} - ] -} -</code> - <p>The example specifies that:</p> - <list> - <item><p>the old key exchange algorithm 'diffie-hellman-group1-sha1' should be - the main alternative. It will be the main alternative since it is prepened to the list</p> - </item> - <item><p>The compression algorithm none (= no compression) is removed so compression is enforced</p> - </item> - </list> - <p>For background and more examples see the <seealso marker="configure_algos#introduction">User's Guide</seealso>.</p> + <p>This variant is kept for compatibility.</p> </item> + </taglist> + </desc> + </datatype> - <tag><c><![CDATA[{dh_gex_groups, [{Size=integer(),G=integer(),P=integer()}] | {file,filename()} {ssh_moduli_file,filename()} }]]></c></tag> + <datatype> + <name name="diffie_hellman_group_exchange_daemon_option"/> + <name name="explicit_group"/> + <name name="explicit_group_file"/> + <name name="ssh_moduli_file"/> + <desc> + <taglist> + <tag><c>dh_gex_groups</c></tag> <item> <p>Defines the groups the server may choose among when diffie-hellman-group-exchange is negotiated. - See RFC 4419 for details. The three variants of this option are: + See + <url href="https://tools.ietf.org/html/rfc4419">RFC 4419</url> + for details. The three variants of this option are: </p> <taglist> <tag><c>{Size=integer(),G=integer(),P=integer()}</c></tag> @@ -704,7 +593,7 @@ </p> </item> - <tag><c><![CDATA[{dh_gex_limits,{Min=integer(),Max=integer()}}]]></c></tag> + <tag><c>dh_gex_limits</c></tag> <item> <p>Limits what a client can ask for in diffie-hellman-group-exchange. The limits will be @@ -715,57 +604,29 @@ </p> <p>If <c>MaxUsed < MinUsed</c> in a key exchange, it will fail with a disconnect. </p> - <p>See RFC 4419 for the function of the Max and Min values.</p> - </item> - - <tag><c><![CDATA[{pwdfun, fun(User::string(), Password::string(), PeerAddress::{ip_adress(),port_number()}, State::any()) -> boolean() | disconnect | {boolean(),any()} }]]></c></tag> - <item> - <p>Provides a function for password validation. This could used for calling an external system or if - passwords should be stored as a hash. The fun returns: - </p> - <list type="bulleted"> - <item><c>true</c> if the user and password is valid and</item> - <item><c>false</c> otherwise.</item> - </list> - <p>This fun can also be used to make delays in authentication tries for example by calling - <seealso marker="stdlib:timer#sleep/1">timer:sleep/1</seealso>. To facilitate counting of failed tries - the <c>State</c> variable could be used. This state is per connection only. The first time the pwdfun - is called for a connection, the <c>State</c> variable has the value <c>undefined</c>. - The pwdfun can return - in addition to the values above - a new state - as: - </p> - <list type="bulleted"> - <item><c>{true, NewState:any()}</c> if the user and password is valid or</item> - <item><c>{false, NewState:any()}</c> if the user or password is invalid</item> - </list> - <p>A third usage is to block login attempts from a missbehaving peer. The <c>State</c> described above - can be used for this. In addition to the responses above, the following return value is introduced: - </p> - <list type="bulleted"> - <item><c>disconnect</c> if the connection should be closed immediately after sending a SSH_MSG_DISCONNECT - message.</item> - </list> - </item> - - <tag><c><![CDATA[{pwdfun, fun(User::string(), Password::string()) -> boolean()}]]></c></tag> - <item> - <p>Provides a function for password validation. This function is called - with user and password as strings, and returns - <c><![CDATA[true]]></c> if the password is valid and - <c><![CDATA[false]]></c> otherwise.</p> - <p>This option (<c>{pwdfun,fun/2}</c>) is the same as a subset of the previous - (<c>{pwdfun,fun/4}</c>). It is kept for compatibility.</p> + <p>See + <url href="https://tools.ietf.org/html/rfc4419">RFC 4419</url> + for the function of the Max and Min values.</p> </item> + </taglist> + </desc> + </datatype> - <tag><c><![CDATA[{negotiation_timeout, integer()}]]></c></tag> - <item> - <p>Maximum time in milliseconds for the authentication negotiation. - Defaults to 120000 (2 minutes). If the client fails to log in within this time, - the connection is closed. - </p> - </item> + <datatype> + <name name="negotiation_timeout_daemon_option"/> + <desc> + <p>Maximum time in milliseconds for the authentication negotiation. + Defaults to 120000 ms (2 minutes). If the client fails to log in within this time, + the connection is closed. + </p> + </desc> + </datatype> - <tag><c><![CDATA[{max_sessions, pos_integer()}]]></c></tag> + <datatype> + <name name="hardening_daemon_options"/> + <desc> + <taglist> + <tag><c>max_sessions</c></tag> <item> <p>The maximum number of simultaneous sessions that are accepted at any time for this daemon. This includes sessions that are being authorized. @@ -785,7 +646,7 @@ </p> </item> - <tag><c><![CDATA[{max_channels, pos_integer()}]]></c></tag> + <tag><c>max_channels</c></tag> <item> <p>The maximum number of channels with active remote subsystem that are accepted for each connection to this daemon</p> @@ -793,8 +654,7 @@ </p> </item> - - <tag><c><![CDATA[{parallel_login, boolean()}]]></c></tag> + <tag><c>parallel_login</c></tag> <item> <p>If set to false (the default value), only one login is handled at a time. If set to true, an unlimited number of login attempts are allowed simultaneously. @@ -811,171 +671,543 @@ </warning> </item> - <tag><c><![CDATA[{minimal_remote_max_packet_size, non_negative_integer()}]]></c></tag> + <tag><c>minimal_remote_max_packet_size</c></tag> <item> - <p>The least maximum packet size that the daemon will accept in channel open requests from the client. The default value is 0. + <p>The least maximum packet size that the daemon will accept in channel open requests from the client. + The default value is 0. </p> </item> + + </taglist> + </desc> + </datatype> + + <datatype> + <name name="callbacks_daemon_options"/> + <desc> + <taglist> + <tag><c>connectfun</c></tag> + <item> + <p>Provides a fun to implement your own logging when a user authenticates to the server.</p> + </item> - <tag><c><![CDATA[{id_string, random | string()}]]></c></tag> + <tag><c>failfun</c></tag> <item> - <p>The string the daemon will present to a connecting peer initially. The default value is "Erlang/VSN" where VSN is the ssh application version number. - </p> - <p>The value <c>random</c> will cause a random string to be created at each connection attempt. This is to make it a bit more difficult for a malicious peer to find the ssh software brand and version. - </p> + <p>Provides a fun to implement your own logging when a user fails to authenticate.</p> </item> + </taglist> + </desc> + </datatype> - <tag><c><![CDATA[{send_ext_info, boolean()}]]></c></tag> - <item> - <p>Send a list of extensions to the client if the client has asked for it. See - <url href="https://tools.ietf.org/html/draft-ietf-curdle-ssh-ext-info">Draft-ietf-curdle-ssh-ext-info (work in progress)</url> for details. - </p> - <p>Currently implemented extension is sending <c>server-sig-algs</c> which is the list of the server's preferred - user's public key algorithms. - </p> - <p>Default value is <c>true</c>. - </p> - </item> + <datatype> + <name name="send_ext_info_daemon_option"/> + <desc> + <p>Make the server (daemon) tell the client that the server accepts extension negotiation, that is, + include <c>ext-info-s</c> in the kexinit message sent. See + <url href="https://tools.ietf.org/html/rfc8308">RFC 8308</url> + for details and <seealso marker="SSH_app#supported-ext-info">ssh(6)</seealso> + for a list of currently implemented extensions. + </p> + <p>Default value is <c>true</c> which is compatible with other implementations not supporting ext-info. + </p> + </desc> + </datatype> - <!--tag><c><![CDATA[{recv_ext_info, boolean()}]]></c></tag> - <item> - <p>Tell the client that the server accepts extension negotiation. See - <url href="https://tools.ietf.org/html/draft-ietf-curdle-ssh-ext-info">Draft-ietf-curdle-ssh-ext-info (work in progress)</url> for details. - </p> - <p>Default value is <c>true</c>. - </p> - </item--> - <tag><c><![CDATA[{key_cb, key_cb()}]]></c></tag> + <!--................................................................--> + <datatype_title>Options common to clients and daemons</datatype_title> + <datatype> + <name name="common_options"/> + <name name="common_option"/> + <desc><p>The options above can be used both in clients and in daemons (servers). They are further explained below.</p> + </desc> + </datatype> + + <datatype> + <name name="user_dir_common_option"/> + <desc> + <p>Sets the user directory. That is, the directory containing <c>ssh</c> configuration + files for the user, such as + <c>known_hosts</c>, <c>id_rsa</c>, <c>id_dsa</c>>, <c>id_ecdsa</c> and <c>authorized_key</c>. + Defaults to the directory normally referred to as <c>~/.ssh</c>. + </p> + <p>See also the option + <seealso marker="#type-key_cb_common_option">key_cb</seealso> + for the general way to handle keys. + </p> + </desc> + </datatype> + + <datatype> + <name name="profile_common_option"/> + <desc> + <p>Used together with <c>ip-address</c> and <c>port</c> to + uniquely identify a ssh daemon. This can be useful in a + virtualized environment, where there can be more that one + server that has the same <c>ip-address</c> and + <c>port</c>. If this property is not explicitly set, it is + assumed that the the <c>ip-address</c> and <c>port</c> + uniquely identifies the SSH daemon. + </p> + </desc> + </datatype> + + <datatype> + <name name="max_idle_time_common_option"/> + <desc> + <p>Sets a time-out on a connection when no channels are active. Defaults to <c>infinity</c>.</p> + </desc> + </datatype> + + <datatype> + <name name="rekey_limit_common_option"/> + <desc> + <p>Sets a limit, in bytes, when rekeying is to be initiated. + Defaults to once per each GB and once per hour.</p> + </desc> + </datatype> + + <datatype> + <name name="key_cb_common_option"/> + <desc> + <p>Module implementing the behaviour + <seealso marker="ssh_client_key_api">ssh_client_key_api</seealso> and/or + <seealso marker="ssh_server_key_api">ssh_server_key_api</seealso>. + Can be used to + customize the handling of public keys. If callback options are provided + along with the module name, they are made available to the callback + module via the options passed to it under the key 'key_cb_private'. + </p> + <p>The <c>Opts</c> defaults to <c>[]</c> when only the <c>Module</c> is specified. + </p> + <p>The default value of this option is <c>{ssh_file, []}</c>. + </p> + <p>A call to the call-back function <c>F</c> will be</p> + <code> + Module:F(..., [{key_cb_private,Opts}|UserOptions]) + </code> + <p>where <c>...</c> are arguments to <c>F</c> as in + <seealso marker="ssh_client_key_api">ssh_client_key_api</seealso> and/or + <seealso marker="ssh_server_key_api">ssh_server_key_api</seealso>. + The <c>UserOptions</c> are the options given to <c>ssh:connect</c>, <c>ssh:shell</c> or <c>ssh:daemon</c>. + </p> + + </desc> + </datatype> + + <datatype> + <name name="disconnectfun_common_option"/> + <desc> + <p>Provides a fun to implement your own logging when the peer disconnects.</p> + </desc> + </datatype> + + <datatype> + <name name="unexpectedfun_common_option"/> + <desc> + <p>Provides a fun to implement your own logging or other action when an unexpected message arrives. + If the fun returns <c>report</c> the usual info report is issued but if <c>skip</c> is returned no + report is generated.</p> + </desc> + </datatype> + + <datatype> + <name name="ssh_msg_debug_fun_common_option"/> + <desc> + <p>Provide a fun to implement your own logging of the SSH message SSH_MSG_DEBUG. + The last three parameters are from the message, see + <url href="https://tools.ietf.org/html/rfc4253#section-11.3">RFC 4253, section 11.3</url>. + The <seealso marker="#type-connection_ref"><c>connection_ref()</c></seealso> is the reference + to the connection on which the message arrived. + The return value from the fun is not checked. + </p> + <p>The default behaviour is ignore the message. + To get a printout for each message with <c>AlwaysDisplay = true</c>, + use for example <c>{ssh_msg_debug_fun, fun(_,true,M,_)-> io:format("DEBUG: ~p~n", [M]) end}</c></p> + </desc> + </datatype> + + <datatype> + <name name="id_string_common_option"/> + <desc> + <p>The string the daemon will present to a connecting peer initially. + The default value is "Erlang/VSN" where VSN is the ssh application version number. + </p> + <p>The value <c>random</c> will cause a random string to be created at each connection attempt. + This is to make it a bit more difficult for a malicious peer to find the ssh software brand and version. + </p> + <p>The value <c>{random, Nmin, Nmax}</c> will make a random string with at least <c>Nmin</c> characters and + at most <c>Nmax</c> characters. + </p> + </desc> + </datatype> + + <datatype> + <name name="preferred_algorithms_common_option"/> + <name name="algs_list"/> + <name name="alg_entry"/> + <name name="kex_alg"/> + <name name="pubkey_alg"/> + <name name="cipher_alg"/> + <name name="mac_alg"/> + <name name="compression_alg"/> + <name name="double_algs"/> + + <desc> + <p>List of algorithms to use in the algorithm negotiation. The default <c>algs_list()</c> can + be obtained from <seealso marker="#default_algorithms/0">default_algorithms/0</seealso>. + </p> + <p>If an alg_entry() is missing in the algs_list(), the default value is used for that entry.</p> + <p>Here is an example of this option:</p> + <code> + {preferred_algorithms, + [{public_key,['ssh-rsa','ssh-dss']}, + {cipher,[{client2server,['aes128-ctr']}, + {server2client,['aes128-cbc','3des-cbc']}]}, + {mac,['hmac-sha2-256','hmac-sha1']}, + {compression,[none,zlib]} + ] + } + </code> + <p>The example specifies different algorithms in the two directions (client2server and server2client), + for cipher but specifies the same algorithms for mac and compression in both directions. + The kex (key exchange) is implicit but public_key is set explicitly.</p> + + <p>For background and more examples see the <seealso marker="configure_algos#introduction">User's Guide</seealso>.</p> + + <p>If an algorithm name occurs more than once in a list, the behaviour is undefined. The tags in the property lists + are also assumed to occur at most one time. + </p> + + <warning> + <p>Changing the values can make a connection less secure. Do not change unless you + know exactly what you are doing. If you do not understand the values then you + are not supposed to change them.</p> + </warning> + </desc> + </datatype> + + <datatype> + <name name="modify_algorithms_common_option"/> + <name name="modify_algs_list"/> + <desc> + <p>Modifies the list of algorithms to use in the algorithm negotiation. The modifications are + applied after the option <c>preferred_algorithms</c> (if existing) is applied.</p> + <p>The algoritm for modifications works like this:</p> + <list> <item> - <p>Module implementing the behaviour <seealso - marker="ssh_server_key_api">ssh_server_key_api</seealso>. Can be used to - customize the handling of public keys. If callback options are provided - along with the module name, they are made available to the callback - module via the options passed to it under the key 'key_cb_private'. + <p>Input is the <c>modify_algs_list()</c> and a set of algorithms <c>A</c> + obtained from the <c>preferred_algorithms</c> option if existing, or else from the + <seealso marker="ssh#default_algorithms-0">ssh:default_algorithms/0</seealso>. </p> </item> - - <tag><c>{profile, atom()}</c></tag> <item> - <p>Used together with <c>ip-address</c> and <c>port</c> to - uniquely identify a ssh daemon. This can be useful in a - virtualized environment, where there can be more that one - server that has the same <c>ip-address</c> and - <c>port</c>. If this property is not explicitly set, it is - assumed that the the <c>ip-address</c> and <c>port</c> - uniquely identifies the SSH daemon. - </p> + <p>The head of the <c>modify_algs_list()</c> modifies <c>A</c> giving the result <c>A'</c>.</p> + <p>The possible modifications are:</p> + <list> + <item> + <p>Append or prepend supported but not enabled algorithm(s) to the list of + algorithms. If the wanted algorithms already are in <c>A</c> they will first + be removed and then appended or prepended, + </p> + </item> + <item> + <p>Remove (rm) one or more algorithms from <c>A</c>. + </p> + </item> + </list> </item> - - <tag><c><![CDATA[{fd, file_descriptor()}]]></c></tag> <item> - <p>Allows an existing file-descriptor to be used - (passed on to the transport protocol).</p></item> - <tag><c><![CDATA[{failfun, fun(User::string(), - PeerAddress::ip_address(), Reason::term()) -> _}]]></c></tag> - <item> - <p>Provides a fun to implement your own logging when a user fails to authenticate.</p> + <p>Repeat the modification step with the tail of <c>modify_algs_list()</c> and the resulting + <c>A'</c>. + </p> </item> - <tag><c><![CDATA[{connectfun, fun(User::string(), PeerAddress::ip_address(), - Method::string()) ->_}]]></c></tag> - <item> - <p>Provides a fun to implement your own logging when a user authenticates to the server.</p> + </list> + <p>If an unsupported algorithm is in the <c>modify_algs_list()</c>, it will be silently ignored</p> + <p>If there are more than one modify_algorithms options, the result is undefined.</p> + <p>Here is an example of this option:</p> + <code> + {modify_algorithms, + [{prepend, [{kex, ['diffie-hellman-group1-sha1']}], + {rm, [{compression, [none]}]} + ] + } + </code> + <p>The example specifies that:</p> + <list> + <item><p>the old key exchange algorithm 'diffie-hellman-group1-sha1' should be + the main alternative. It will be the main alternative since it is prepened to the list</p> </item> - <tag><c><![CDATA[{disconnectfun, fun(Reason:term()) -> _}]]></c></tag> - <item> - <p>Provides a fun to implement your own logging when a user disconnects from the server.</p> + <item><p>The compression algorithm none (= no compression) is removed so compression is enforced</p> </item> + </list> + <p>For background and more examples see the <seealso marker="configure_algos#introduction">User's Guide</seealso>.</p> + </desc> + </datatype> - <tag><c><![CDATA[{unexpectedfun, fun(Message:term(), Peer) -> report | skip }]]></c></tag> - <item> - <p>Provides a fun to implement your own logging or other action when an unexpected message arrives. - If the fun returns <c>report</c> the usual info report is issued but if <c>skip</c> is returned no - report is generated.</p> - <p><c>Peer</c> is in the format of <c>{Host,Port}</c>.</p> - </item> - <tag><c><![CDATA[{idle_time, integer()}]]></c></tag> - <item> - <p>Sets a time-out on a connection when no channels are active. - Defaults to <c>infinity</c>.</p> - </item> + <datatype> + <name name="inet_common_option"/> + <desc> + <p>IP version to use when the host address is specified as <c>any</c>.</p> + </desc> + </datatype> - <tag><c><![CDATA[{ssh_msg_debug_fun, fun(ConnectionRef::ssh_connection_ref(), AlwaysDisplay::boolean(), Msg::binary(), LanguageTag::binary()) -> _}]]></c></tag> - <item> - <p>Provide a fun to implement your own logging of the SSH message SSH_MSG_DEBUG. The last three parameters are from the message, see RFC4253, section 11.3. The <c>ConnectionRef</c> is the reference to the connection on which the message arrived. The return value from the fun is not checked.</p> - <p>The default behaviour is ignore the message. - To get a printout for each message with <c>AlwaysDisplay = true</c>, use for example <c>{ssh_msg_debug_fun, fun(_,true,M,_)-> io:format("DEBUG: ~p~n", [M]) end}</c></p> - </item> + <datatype> + <name name="auth_methods_common_option"/> + <desc> + <p>Comma-separated string that determines which authentication methods that the client shall + support and in which order they are tried. Defaults to <c>"publickey,keyboard-interactive,password"</c> + </p> + <p>Note that the client is free to use any order and to exclude methods. + </p> + </desc> + </datatype> - </taglist> - </desc> - </func> + <datatype> + <name name="fd_common_option"/> + <desc> + <p>Allows an existing file-descriptor to be used (passed on to the transport protocol).</p> + </desc> + </datatype> - <func> - <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> + <!--................................................................--> + <datatype_title>Other data types</datatype_title> + + <datatype> + <name name="host"/> + <desc> + </desc> + </datatype> + + <datatype> + <name name="ip_port"/> + <desc> + </desc> + </datatype> + + <datatype> + <name name="mod_args"/> + <desc> + </desc> + </datatype> + + <datatype> + <name name="mod_fun_args"/> + <desc> + </desc> + </datatype> + + <datatype> + <name name="open_socket"/> + <desc> + <p>The socket is supposed to be result of a <seealso marker="kernel:gen_tcp#connect-3">gen_tcp:connect</seealso> + or a <seealso marker="kernel:gen_tcp#accept-1">gen_tcp:accept</seealso>. The socket must be in passive + mode (that is, opened with the option <c>{active,false})</c>. + </p> + </desc> + </datatype> + + <datatype> + <name name="daemon_ref"/> + <desc> + <p>Opaque data type representing a daemon.</p> + <p>Returned by the functions <seealso marker="ssh#daemon-1"><c>daemon/1,2,3</c></seealso>.</p> + </desc> + </datatype> + + <datatype> + <name>connection_ref()</name> + <desc> + <p>Opaque data type representing a connection between a client and a server (daemon).</p> + <p>Returned by the functions + <seealso marker="ssh#connect-3"><c>connect/2,3,4</c></seealso> and + <seealso marker="ssh_sftp#start_channel-2"><c>ssh_sftp:start_channel/2,3</c></seealso>. + </p> + </desc> + </datatype> + + <datatype> + <name name="channel_id"/> + <desc> + <p>Opaque data type representing a channel inside a connection.</p> + <p>Returned by the functions + <seealso marker="ssh_connection#session_channel/2">ssh_connection:session_channel/2,4</seealso>. + </p> + </desc> + </datatype> + + + <datatype> + <name>opaque_client_options</name> + <name>opaque_daemon_options</name> + <name>opaque_common_options</name> <desc> - <p>Returns a key-value list with information about the daemon. For now, only the listening port is returned. This is intended for the case the daemon is started with the port set to 0.</p> + <marker id="type-opaque_client_options"/> + <marker id="type-opaque_daemon_options"/> + <marker id="type-opaque_common_options"/> + <p>Opaque types that define experimental options that are not to be used in products.</p> </desc> + </datatype> + </datatypes> + +<!-- + ================================================================ + = Function definitions = + ================================================================ +--> + + <funcs> + +<!-- CLOSE/1 --> + <func> + <name name="close" arity="1"/> + <fsummary>Closes an SSH connection.</fsummary> + <desc><p>Closes an SSH connection.</p></desc> </func> + +<!-- CONNECT/2 etc --> + <func> + <name>connect(Host, Port, Options) -> Result </name> + <name>connect(Host, Port, Options, NegotiationTimeout) -> Result </name> + <name>connect(TcpSocket, Options) -> Result</name> + <name>connect(TcpSocket, Options, NegotiationTimeout) -> Result</name> + <fsummary>Connects to an SSH server.</fsummary> + <type> + <v>Host = <seealso marker="#type-host">host()</seealso></v> + <v>Port = <seealso marker="kernel:inet#type-port_number">inet:port_number()</seealso></v> + <v>Options = <seealso marker="#type-client_options">client_options()</seealso></v> + <v>TcpSocket = <seealso marker="#type-open_socket">open_socket()</seealso></v> + <v>NegotiationTimeout = timeout()</v> + <v>Result = {ok, <seealso marker="#type-connection_ref">connection_ref()</seealso>} | {error, term()}</v> + </type> + <desc> + <p>Connects to an SSH server at the <c>Host</c> on <c>Port</c>. + </p> + <p>As an alternative, an already open TCP socket could be passed to the function in <c>TcpSocket</c>. + The SSH initiation and negotiation will be initiated on that one with the SSH that should be at the + other end. + </p> + <p>No channel is started. This is done by calling <seealso marker="ssh_connection#session_channel/2"> + ssh_connection:session_channel/[2, 4]</seealso>. + </p> + <p>The <c>NegotiationTimeout</c> is in milli-seconds. The default value is <c>infinity</c>. + For connection timeout, use the option + <seealso marker="#type-connect_timeout_client_option"><c>connect_timeout</c></seealso>. + </p> + </desc> + </func> + +<!-- CONNECTION_INFO/1, CONNECTION_INFO/2 --> + <func> + <name name="connection_info" arity="2"/> + <fsummary>Retrieves information about a connection.</fsummary> + <desc> + <p>Retrieves information about a connection. The list <c>Keys</c> defines which information that + is returned.</p> + </desc> + </func> + +<!-- DEAMON/1,2,3 --> + <func> + <name>daemon(Port | TcpSocket) -> Result</name> + <name>daemon(Port | TcpSocket, Options) -> Result</name> + <name>daemon(HostAddress, Port, Options) -> Result</name> + <fsummary>Starts a server listening for SSH connections.</fsummary> + <type> + <v>Port = integer()</v> + <v>TcpSocket = <seealso marker="#type-open_socket">open_socket()</seealso></v> + <v>Options = <seealso marker="#type-daemon_options">daemon_options()</seealso></v> + <v>HostAddress = <seealso marker="#type-host">host()</seealso> | any</v> + <v>Result = {ok, <seealso marker="#type-daemon_ref">daemon_ref()</seealso>} | {error, atom()}</v> + </type> + <desc> + <p>Starts a server listening for SSH connections on the given port. If the <c>Port</c> is 0, + a random free port is selected. See <seealso marker="#daemon_info/1">daemon_info/1</seealso> + about how to find the selected port number. + </p> + <p>As an alternative, an already open TCP socket could be passed to the function in <c>TcpSocket</c>. + The SSH initiation and negotiation will be initiated on that one when an SSH starts at the other end + of the TCP socket. + </p> + <p>For a description of the options, see <seealso marker="#type-daemon_options">Daemon Options</seealso>. + </p> + <p>Please note that by historical reasons both the <c>HostAddress</c> argument and the + <seealso marker="kernel:gen_tcp#type-connect_option">gen_tcp connect_option() <c>{ip,Address}</c></seealso> + set the listening address. This is a source of possible inconsistent settings. + </p> + <p>The rules for handling the two address passing options are:</p> + <list> + <item>if <c>HostAddress</c> is an IP-address, that IP-address is the listening address. + An 'ip'-option will be discarded if present.</item> + + <item>if <c>HostAddress</c> is the atom <c>loopback</c>, the listening address + is <c>loopback</c> and an loopback address will be choosen by the underlying layers. + An 'ip'-option will be discarded if present.</item> + + <item>if <c>HostAddress</c> is the atom <c>any</c> and no 'ip'-option is present, the listening address is + <c>any</c> and the socket will listen to all addresses</item> + + <item>if <c>HostAddress</c> is <c>any</c> and an 'ip'-option is present, the listening address is + set to the value of the 'ip'-option</item> + </list> + </desc> + </func> +<!-- DAEMON_INFO/1 --> + <func> + <name name="daemon_info" arity="1"/> + <fsummary>Get info about a daemon</fsummary> + <desc> + <p>Returns a key-value list with information about the daemon.</p> + </desc> + </func> + + +<!-- DEFAULT_ALGORITHMS/0 --> <func> - <name>default_algorithms() -> algs_list()</name> + <name name="default_algorithms" arity="0"/> <fsummary>Get a list declaring the supported algorithms</fsummary> <desc> <p>Returns a key-value list, where the keys are the different types of algorithms and the values are the - algorithms themselves. An example:</p> - <code> -20> ssh:default_algorithms(). -[{kex,['diffie-hellman-group1-sha1']}, - {public_key,['ssh-rsa','ssh-dss']}, - {cipher,[{client2server,['aes128-ctr','aes128-cbc','3des-cbc']}, - {server2client,['aes128-ctr','aes128-cbc','3des-cbc']}]}, - {mac,[{client2server,['hmac-sha2-256','hmac-sha1']}, - {server2client,['hmac-sha2-256','hmac-sha1']}]}, - {compression,[{client2server,[none,zlib]}, - {server2client,[none,zlib]}]}] -21> -</code> + algorithms themselves.</p> + <p>See the <seealso marker="configure_algos#example_default_algorithms">User's Guide</seealso> for + an example.</p> </desc> </func> +<!-- SHELL/1,2,3 --> <func> - <name>shell(Host) -> </name> - <name>shell(Host, Option) -> </name> - <name>shell(Host, Port, Option) -> </name> - <name>shell(TcpSocket) -> _</name> - <fsummary>Starts an interactive shell over an SSH server.</fsummary> + <name>shell(Host | TcpSocket) -> Result </name> + <name>shell(Host | TcpSocket, Options) -> Result </name> + <name>shell(Host, Port, Options) -> Result </name> + <fsummary>Starts an interactive shell on a remote SSH server.</fsummary> <type> - <v>Host = string()</v> - <v>Port = integer()</v> - <v>Options - see ssh:connect/3</v> - <v>TcpSocket = port()</v> - <d>The socket is supposed to be from <seealso marker="kernel:gen_tcp#connect-3">gen_tcp:connect</seealso> or <seealso marker="kernel:gen_tcp#accept-1">gen_tcp:accept</seealso> with option <c>{active,false}</c></d> + <v>Host = <seealso marker="#type-host">host()</seealso></v> + <v>TcpSocket = <seealso marker="#type-open_socket">open_socket()</seealso></v> + <v>Port = <seealso marker="kernel:inet#type-port_number">inet:port_number()</seealso></v> + <v>Options = <seealso marker="#type-client_options">client_options()</seealso></v> + <v>Result = ok | {error, Reason::term()}</v> </type> <desc> - <p>Starts an interactive shell over an SSH server on the - given <c>Host</c>. The function waits for user input, - and does not return until the remote shell is ended (that is, + <p>Connects to an SSH server at <c>Host</c> and <c>Port</c> (defaults to 22) and starts an + interactive shell on that remote host. + </p> + <p>As an alternative, an already open TCP socket could be passed to the function in <c>TcpSocket</c>. + The SSH initiation and negotiation will be initiated on that one and finaly a shell will be started + on the host at the other end of the TCP socket. + </p> + <p>For a description of the options, see <seealso marker="#type-client_options">Client Options</seealso>.</p> + <p>The function waits for user input, and does not return until the remote shell is ended (that is, exit from the shell). </p> </desc> </func> <func> - <name>start() -> </name> - <name>start(Type) -> ok | {error, Reason}</name> + <name name="start" arity="0"/> + <name name="start" arity="1"/> <fsummary>Starts the SSH application.</fsummary> - <type> - <v>Type = permanent | transient | temporary</v> - <v>Reason = term() </v> - </type> <desc> <p>Utility function that starts the applications <c>crypto</c>, <c>public_key</c>, and <c>ssh</c>. Default type is <c>temporary</c>. @@ -985,11 +1217,8 @@ </func> <func> - <name>stop() -> ok | {error, Reason}</name> + <name name="stop" arity="0"/> <fsummary>Stops the <c>ssh</c> application.</fsummary> - <type> - <v>Reason = term()</v> - </type> <desc> <p>Stops the <c>ssh</c> application. For more information, see the <seealso marker="kernel:application">application(3)</seealso> @@ -998,34 +1227,22 @@ </func> <func> - <name>stop_daemon(DaemonRef) -> </name> - <name>stop_daemon(Address, Port) -> ok </name> - <fsummary>Stops the listener and all connections started by - the listener.</fsummary> - <type> - <v>DaemonRef = ssh_daemon_ref()</v> - <v>Address = ip_address()</v> - <v>Port = integer()</v> - </type> + <name name="stop_daemon" arity="1"/> + <name name="stop_daemon" arity="2"/> + <name name="stop_daemon" arity="3"/> + <fsummary>Stops the listener and all connections started by the listener.</fsummary> <desc> - <p>Stops the listener and all connections started by - the listener.</p> + <p>Stops the listener and all connections started by the listener.</p> </desc> </func> <func> - <name>stop_listener(DaemonRef) -> </name> - <name>stop_listener(Address, Port) -> ok </name> - <fsummary>Stops the listener, but leaves existing connections started - by the listener operational.</fsummary> - <type> - <v>DaemonRef = ssh_daemon_ref()</v> - <v>Address = ip_address()</v> - <v>Port = integer()</v> - </type> + <name name="stop_listener" arity="1"/> + <name name="stop_listener" arity="2"/> + <name name="stop_listener" arity="3"/> + <fsummary>Stops the listener, but leaves existing connections started by the listener operational.</fsummary> <desc> - <p>Stops the listener, but leaves existing connections started - by the listener operational.</p> + <p>Stops the listener, but leaves existing connections started by the listener operational.</p> </desc> </func> diff --git a/lib/ssh/doc/src/ssh_app.xml b/lib/ssh/doc/src/ssh_app.xml index 1cbbdfcf38..6d180a5272 100644 --- a/lib/ssh/doc/src/ssh_app.xml +++ b/lib/ssh/doc/src/ssh_app.xml @@ -330,10 +330,11 @@ <p/> </item> - <item><url href="https://tools.ietf.org/html/draft-ietf-curdle-rsa-sha2">Draft-ietf-curdle-rsa-sha2 (work in progress)</url>, Use of RSA Keys with SHA-2 256 and 512 in Secure Shell (SSH). + <item><url href="https://tools.ietf.org/html/rfc8332">RFC 8332</url>, Use of RSA Keys with SHA-256 and SHA-512 in the Secure Shell (SSH) Protocol. </item> - <item><url href="https://tools.ietf.org/html/draft-ietf-curdle-ssh-ext-info">Draft-ietf-curdle-ssh-ext-info (work in progress)</url>, Extension Negotiation in Secure Shell (SSH). + <item><marker id="supported-ext-info"/> + <url href="https://tools.ietf.org/html/rfc8308">RFC 8308</url>, Extension Negotiation in the Secure Shell (SSH) Protocol. <p>Implemented are:</p> <list type="bulleted"> <item>The Extension Negotiation Mechanism</item> diff --git a/lib/ssh/doc/src/ssh_channel.xml b/lib/ssh/doc/src/ssh_channel.xml index 7b598494f7..0355f7bf52 100644 --- a/lib/ssh/doc/src/ssh_channel.xml +++ b/lib/ssh/doc/src/ssh_channel.xml @@ -46,6 +46,7 @@ the <c>ssh</c> applications supervisor tree. </p> + <marker id="ssh_daemon_channel"/> <note><p>When implementing an <c>ssh</c> subsystem, use <c>-behaviour(ssh_daemon_channel)</c> instead of <c>-behaviour(ssh_channel)</c>. The reason is that the only relevant callback functions for subsystems are @@ -55,33 +56,6 @@ </p></note> </description> - <section> - <title>DATA TYPES</title> - - <p>Type definitions that are used more than once in this module, - or abstractions to indicate the intended use of the data - type, or both:</p> - - <taglist> - <tag><c>boolean() =</c></tag> - <item><p><c>true | false</c></p></item> - <tag><c>string() =</c></tag> - <item><p>list of ASCII characters</p></item> - <tag><c>timeout() =</c></tag> - <item><p><c>infinity | integer()</c> in milliseconds</p></item> - <tag><c>ssh_connection_ref() =</c></tag> - <item><p>opaque() -as returned by - <c>ssh:connect/3</c> or sent to an SSH channel process</p></item> - <tag><c>ssh_channel_id() =</c></tag> - <item><p><c>integer()</c></p></item> - <tag><c>ssh_data_type_code() =</c></tag> - <item><p><c>1</c> ("stderr") | <c>0</c> ("normal") are - the valid values, - see <url href="http://www.ietf.org/rfc/rfc4254.txt">RFC 4254</url> - Section 5.2</p></item> - </taglist> - </section> - <funcs> <func> <name>call(ChannelRef, Msg) -></name> @@ -89,7 +63,7 @@ <fsummary>Makes a synchronous call to a channel.</fsummary> <type> <v>ChannelRef = pid() </v> - <d>As returned by <seealso marker = "#start_link-4">ssh_channel:start_link/4</seealso></d> + <d>As returned by <seealso marker = "#start_link-4">start_link/4</seealso></d> <v>Msg = term()</v> <v>Timeout = timeout()</v> <v>Reply = term()</v> @@ -113,7 +87,7 @@ ChannelRef and returns ok.</fsummary> <type> <v>ChannelRef = pid()</v> - <d>As returned by <seealso marker = "#start_link-4">ssh_channel:start_link/4</seealso></d> + <d>As returned by <seealso marker = "#start_link-4">start_link/4</seealso></d> <v>Msg = term()</v> </type> <desc> @@ -131,7 +105,7 @@ <fsummary>Makes an existing process an ssh_channel process.</fsummary> <type> <v>State = term()</v> - <d>as returned by <seealso marker = "#init-1">ssh_channel:init/1</seealso></d> + <d>as returned by <seealso marker = "#init-1">init/1</seealso></d> </type> <desc> <p>Makes an existing process an <c>ssh_channel</c> @@ -141,7 +115,7 @@ one of the start functions in <c>proc_lib</c>, see the <seealso marker="stdlib:proc_lib">proc_lib(3)</seealso> manual page in STDLIB. The user is responsible for any initialization of the process - and must call <seealso marker = "#init-1">ssh_channel:init/1</seealso>. + and must call <seealso marker = "#init-1">init/1</seealso>. </p> </desc> </func> @@ -160,18 +134,21 @@ The following options must be present: </p> <taglist> - <tag><c><![CDATA[{channel_cb, atom()}]]></c></tag> + <tag><c>{channel_cb, atom()}</c></tag> <item><p>The module that implements the channel behaviour.</p></item> - <tag><c><![CDATA[{init_args(), list()}]]></c></tag> + <tag><c>{init_args(), list()}</c></tag> <item><p>The list of arguments to the <c>init</c> function of the callback module.</p></item> - <tag><c><![CDATA[{cm, connection_ref()}]]></c></tag> - <item><p>Reference to the <c>ssh</c> connection as returned by <seealso - marker="ssh#connect-3">ssh:connect/3</seealso></p></item> + <tag><c>{cm, ssh:connection_ref()}</c></tag> + <item><p>Reference to the <c>ssh</c> connection as returned by + <seealso marker="ssh#connect-3">ssh:connect/3</seealso>. + </p></item> - <tag><c><![CDATA[{channel_id, channel_id()}]]></c></tag> - <item><p>Id of the <c>ssh</c> channel.</p></item> + <tag><c>{channel_id, ssh:channel_id()}</c></tag> + <item><p>Id of the <c>ssh</c> channel as returned by + <seealso marker="ssh_connection#session_channel/2">ssh_connection:session_channel/2,4</seealso>. + </p></item> </taglist> @@ -179,8 +156,8 @@ user. The user only needs to call if the channel process needs to be started with help of <c>proc_lib</c> instead of calling - <c>ssh_channel:start/4</c> or - <c>ssh_channel:start_link/4</c>.</p> + <c>start/4</c> or + <c>start_link/4</c>.</p> </note> </desc> </func> @@ -201,26 +178,31 @@ the callback function <c>handle_call/3</c>. <c>Reply</c> is an arbitrary term, which is given back to the client as the return value of - <seealso marker="#call-2">ssh_channel:call/[2,3].</seealso></p> + <seealso marker="#call-2">call/[2,3].</seealso></p> </desc> </func> - + <func> <name>start(SshConnection, ChannelId, ChannelCb, CbInitArgs) -> </name> <name>start_link(SshConnection, ChannelId, ChannelCb, CbInitArgs) -> {ok, ChannelRef} | {error, Reason}</name> <fsummary>Starts a process that handles an SSH channel.</fsummary> <type> - <v>SshConnection = ssh_connection_ref()</v> - <v>ChannelId = ssh_channel_id()</v> + <v>SshConnection = ssh:connection_ref()</v> + <d>As returned by <seealso marker="ssh#connect-3">ssh:connect/3</seealso></d> + + <v>ChannelId = <seealso marker="ssh#type-channel_id">ssh:channel_id()</seealso></v> <d>As returned by <seealso marker ="ssh_connection#session_channel/2"> ssh_connection:session_channel/[2,4]</seealso>.</d> + <v>ChannelCb = atom()</v> <d>Name of the module implementing the service-specific parts of the channel.</d> + <v>CbInitArgs = [term()]</v> <d>Argument list for the <c>init</c> function in the callback module.</d> + <v>ChannelRef = pid()</v> </type> <desc> @@ -295,7 +277,7 @@ initial channel state if the initializations succeed.</fsummary> <type> <v>Args = term()</v> - <d>Last argument to <c>ssh_channel:start_link/4</c>.</d> + <d>Last argument to <c>start_link/4</c>.</d> <v>State = term()</v> <v>Reason = term()</v> </type> @@ -311,24 +293,24 @@ <func> <name>Module:handle_call(Msg, From, State) -> Result</name> <fsummary>Handles messages sent by calling - <c>ssh_channel:call/[2,3]</c>.</fsummary> + <c>call/[2,3]</c>.</fsummary> <type> <v>Msg = term()</v> <v>From = opaque()</v> <d>Is to be used as argument to - <seealso marker="#reply-2">ssh_channel:reply/2</seealso></d> + <seealso marker="#reply-2">reply/2</seealso></d> <v>State = term()</v> <v>Result = {reply, Reply, NewState} | {reply, Reply, NewState, timeout()} | {noreply, NewState} | {noreply , NewState, timeout()} | {stop, Reason, Reply, NewState} | {stop, Reason, NewState} </v> <v>Reply = term()</v> - <d>Will be the return value of <seealso marker="#call-2">ssh_channel:call/[2,3]</seealso></d> + <d>Will be the return value of <seealso marker="#call-2">call/[2,3]</seealso></d> <v>NewState = term()</v> <v>Reason = term()</v> </type> <desc> <p>Handles messages sent by calling - <seealso marker="#call-2">ssh_channel:call/[2,3]</seealso> + <seealso marker="#call-2">call/[2,3]</seealso> </p> <p>For more detailed information on time-outs,, see Section <seealso marker="#cb_timeouts">CALLBACK TIME-OUTS</seealso>.</p> @@ -338,7 +320,7 @@ <func> <name>Module:handle_cast(Msg, State) -> Result</name> <fsummary>Handles messages sent by calling - <c>ssh_channel:cact/2</c>.</fsummary> + <c>cast/2</c>.</fsummary> <type> <v>Msg = term()</v> <v>State = term()</v> @@ -349,7 +331,7 @@ </type> <desc> <p>Handles messages sent by calling - <c>ssh_channel:cast/2</c>. + <c>cast/2</c>. </p> <p>For more detailed information on time-outs, see Section <seealso marker="#cb_timeouts">CALLBACK TIME-OUTS</seealso>.</p> @@ -364,7 +346,7 @@ call, or cast messages sent to the channel.</fsummary> <type> <v>Msg = timeout | term()</v> - <v>ChannelId = ssh_channel_id()</v> + <v>ChannelId = <seealso marker="ssh#type-channel_id">ssh:channel_id()</seealso></v> <v>State = term() </v> </type> <desc> @@ -376,11 +358,10 @@ function and all channels are to handle the following message.</p> <taglist> - <tag><c><![CDATA[{ssh_channel_up, ssh_channel_id(), - ssh_connection_ref()}]]></c></tag> + <tag><c>{ssh_channel_up, ssh:channel_id(), ssh:connection_ref()}</c></tag> <item><p>This is the first message that the channel receives. It is sent just before the <seealso - marker="#init-1">ssh_channel:init/1</seealso> function + marker="#init-1">init/1</seealso> function returns successfully. This is especially useful if the server wants to send a message to the client without first receiving a message from it. If the message is not @@ -397,7 +378,7 @@ <fsummary>Handles <c>ssh</c> connection protocol messages.</fsummary> <type> <v>Msg = ssh_connection:event()</v> - <v>ChannelId = ssh_channel_id()</v> + <v>ChannelId = <seealso marker="ssh#type-channel_id">ssh:channel_id()</seealso></v> <v>State = term()</v> </type> <desc> @@ -410,7 +391,7 @@ <c>ssh_channel</c> behavior.</p> <taglist> - <tag><c><![CDATA[{closed, ssh_channel_id()}]]></c></tag> + <tag><c>{closed, ssh:channel_id()}</c></tag> <item><p>The channel behavior sends a close message to the other side, if such a message has not already been sent. Then it terminates the channel with reason <c>normal</c>.</p></item> diff --git a/lib/ssh/doc/src/ssh_client_key_api.xml b/lib/ssh/doc/src/ssh_client_key_api.xml index 98a1676ca4..9fc54341ed 100644 --- a/lib/ssh/doc/src/ssh_client_key_api.xml +++ b/lib/ssh/doc/src/ssh_client_key_api.xml @@ -41,7 +41,7 @@ see the <seealso marker="SSH_app"> ssh(6)</seealso> application manual.</p> </description> - <section> + <!-- section> <title>DATA TYPES</title> <p>Type definitions that are used more than once in this module, @@ -68,23 +68,34 @@ | 'rsa-sha2-256' | 'rsa-sha2-384' | 'rsa-sha2-512' | 'ecdsa-sha2-nistp256' | 'ecdsa-sha2-nistp384' | 'ecdsa-sha2-nistp521' </c></p></item> </taglist> - </section> + </section --> + + <datatypes> + <datatype> + <name name="client_key_cb_options"/> + <desc> + <p>Options provided to <seealso marker="ssh#connect-3">ssh:connect/[3,4]</seealso>. + </p> + <p>The option list given in the + <seealso marker="ssh#type-key_cb_common_option"><c>key_cb</c></seealso> + option is available with the key <c>key_cb_private</c>. + </p> + </desc> + </datatype> + </datatypes> <funcs> <func> - <name>Module:add_host_key(HostNames, Key, ConnectOptions) -> ok | {error, Reason}</name> + <name>Module:add_host_key(HostNames, PublicHostKey, ConnectOptions) -> ok | {error, Reason}</name> <fsummary>Adds a host key to the set of trusted host keys.</fsummary> <type> - <v>HostNames = string()</v> - <d>Description of the host that owns the <c>PublicKey</c>.</d> + <v>HostNames = string()</v> + <d>Description of the host that owns the <c>PublicHostKey</c>.</d> - <v>Key = public_key()</v> - <d>Normally an RSA, DSA or ECDSA public key, but handling of other public keys can be added.</d> + <v>PublicHostKey = <seealso marker="public_key:public_key#type-public_key">public_key:public_key()</seealso></v> + <d>Of ECDSA keys, only the Normally an RSA, DSA or ECDSA public key, but handling of other public keys can be added.</d> - <v>ConnectOptions = proplists:proplist()</v> - <d>Options provided to <seealso marker="ssh#connect-3">ssh:connect/[3,4]</seealso>. The option list given in - the <c>key_cb</c> option is available with the key <c>key_cb_private</c>.</d> - <v>Reason = term().</v> + <v>ConnectOptions = <seealso marker="#type-client_key_cb_options">client_key_cb_options()</seealso></v> </type> <desc> <p>Adds a host key to the set of trusted host keys.</p> @@ -95,18 +106,16 @@ <name>Module:is_host_key(Key, Host, Algorithm, ConnectOptions) -> Result</name> <fsummary>Checks if a host key is trusted.</fsummary> <type> - <v>Key = public_key() </v> + <v>Key = <seealso marker="public_key:public_key#type-public_key">public_key:public_key()</seealso></v> <d>Normally an RSA, DSA or ECDSA public key, but handling of other public keys can be added.</d> <v>Host = string()</v> <d>Description of the host.</d> - <v>Algorithm = public_key_algorithm()</v> + <v>Algorithm = <seealso marker="ssh#type-pubkey_alg">ssh:pubkey_alg()</seealso></v> <d>Host key algorithm.</d> - <v>ConnectOptions = proplists:proplist() </v> - <d>Options provided to <seealso marker="ssh#connect-3">ssh:connect/[3,4]</seealso>. The option list given in - the <c>key_cb</c> option is available with the key <c>key_cb_private</c>.</d> + <v>ConnectOptions = <seealso marker="#type-client_key_cb_options">client_key_cb_options()</seealso></v> <v>Result = boolean()</v> </type> @@ -120,14 +129,12 @@ {ok, PrivateKey} | {error, Reason}</name> <fsummary>Fetches the users <em>public key</em> matching the <c>Algorithm</c>.</fsummary> <type> - <v>Algorithm = public_key_algorithm()</v> + <v>Algorithm = <seealso marker="ssh#type-pubkey_alg">ssh:pubkey_alg()</seealso></v> <d>Host key algorithm.</d> - <v>ConnectOptions = proplists:proplist()</v> - <d>Options provided to <seealso marker="ssh#connect-3">ssh:connect/[3,4]</seealso>. The option list given in - the <c>key_cb</c> option is available with the key <c>key_cb_private</c>.</d> + <v>ConnectOptions = <seealso marker="#type-client_key_cb_options">client_key_cb_options()</seealso></v> - <v>PrivateKey = private_key()</v> + <v>PrivateKey = <seealso marker="public_key:public_key#type-private_key">public_key:private_key()</seealso></v> <d>Private key of the user matching the <c>Algorithm</c>.</d> <v>Reason = term()</v> diff --git a/lib/ssh/doc/src/ssh_connection.xml b/lib/ssh/doc/src/ssh_connection.xml index 150d46a9a2..cfe5385eb4 100644 --- a/lib/ssh/doc/src/ssh_connection.xml +++ b/lib/ssh/doc/src/ssh_connection.xml @@ -43,7 +43,7 @@ which are received as messages by the remote channel. If the receiving channel is an Erlang process, the messages have the format - <c><![CDATA[{ssh_cm, ssh_connection_ref(), ssh_event_msg()}]]></c>. + <c><![CDATA[{ssh_cm, connection_ref(), ssh_event_msg()}]]></c>. If the <seealso marker="ssh_channel">ssh_channel</seealso> behavior is used to implement the channel process, these messages are handled by <seealso marker="ssh_channel#Module:handle_ssh_msg-2">handle_ssh_msg/2</seealso>.</p> @@ -63,10 +63,10 @@ <item><p>list of ASCII characters</p></item> <tag><c>timeout() =</c></tag> <item><p><c>infinity | integer()</c> in milliseconds</p></item> - <tag><c>ssh_connection_ref() =</c></tag> + <tag><c>connection_ref() =</c></tag> <item><p>opaque() -as returned by <c>ssh:connect/3</c> or sent to an SSH channel processes</p></item> - <tag><c>ssh_channel_id() =</c></tag> + <tag><c>channel_id() =</c></tag> <item><p><c>integer()</c></p></item> <tag><c>ssh_data_type_code() =</c></tag> <item><p><c>1</c> ("stderr") | <c>0</c> ("normal") are @@ -75,7 +75,7 @@ <tag><c>ssh_request_status() =</c></tag> <item><p> <c>success | failure</c></p></item> <tag><c>event() =</c></tag> - <item><p><c>{ssh_cm, ssh_connection_ref(), ssh_event_msg()}</c></p></item> + <item><p><c>{ssh_cm, connection_ref(), ssh_event_msg()}</c></p></item> <tag><c>ssh_event_msg() =</c></tag> <item><p><c>data_events() | status_events() | terminal_events()</c></p></item> <tag><c>reason() =</c></tag> @@ -86,12 +86,12 @@ <tag><em>data_events()</em></tag> <item> <taglist> - <tag><c><![CDATA[{data, ssh_channel_id(), ssh_data_type_code(), Data :: binary()}]]></c></tag> + <tag><c><![CDATA[{data, channel_id(), ssh_data_type_code(), Data :: binary()}]]></c></tag> <item><p>Data has arrived on the channel. This event is sent as a result of calling <seealso marker="ssh_connection#send-3"> ssh_connection:send/[3,4,5]</seealso>.</p></item> - <tag><c><![CDATA[{eof, ssh_channel_id()}]]></c></tag> + <tag><c><![CDATA[{eof, channel_id()}]]></c></tag> <item><p>Indicates that the other side sends no more data. This event is sent as a result of calling <seealso marker="ssh_connection#send_eof-2"> ssh_connection:send_eof/2</seealso>. @@ -103,7 +103,7 @@ <item> <taglist> - <tag><c><![CDATA[{signal, ssh_channel_id(), ssh_signal()}]]></c></tag> + <tag><c><![CDATA[{signal, channel_id(), ssh_signal()}]]></c></tag> <item><p>A signal can be delivered to the remote process/service using the following message. Some systems do not support signals, in which case they are to ignore this message. There is @@ -111,7 +111,7 @@ referred to are on OS-level and not something generated by an Erlang program.</p></item> - <tag><c><![CDATA[{exit_signal, ssh_channel_id(), ExitSignal :: string(), ErrorMsg ::string(), + <tag><c><![CDATA[{exit_signal, channel_id(), ExitSignal :: string(), ErrorMsg ::string(), LanguageString :: string()}]]></c></tag> <item><p>A remote execution can terminate violently because of a signal. @@ -119,7 +119,7 @@ values, see <url href="http://www.ietf.org/rfc/rfc4254.txt">RFC 4254</url> Section 6.10, which shows a special case of these signals.</p></item> - <tag><c><![CDATA[{exit_status, ssh_channel_id(), ExitStatus :: integer()}]]></c></tag> + <tag><c><![CDATA[{exit_status, channel_id(), ExitStatus :: integer()}]]></c></tag> <item><p>When the command running at the other end terminates, the following message can be sent to return the exit status of the command. A zero <c>exit_status</c> usually means that the command @@ -127,7 +127,7 @@ <seealso marker="ssh_connection#exit_status-3"> ssh_connection:exit_status/3</seealso>.</p></item> - <tag><c><![CDATA[{closed, ssh_channel_id()}]]></c></tag> + <tag><c><![CDATA[{closed, channel_id()}]]></c></tag> <item><p>This event is sent as a result of calling <seealso marker="ssh_connection#close-2">ssh_connection:close/2</seealso>. Both the handling of this event and sending it are taken care of by the @@ -149,14 +149,14 @@ with the boolean value of <c>WantReply</c> as the second argument.</p> <taglist> - <tag><c><![CDATA[{env, ssh_channel_id(), WantReply :: boolean(), + <tag><c><![CDATA[{env, channel_id(), WantReply :: boolean(), Var ::string(), Value :: string()}]]></c></tag> <item><p>Environment variables can be passed to the shell/command to be started later. This event is sent as a result of calling <seealso marker="ssh_connection#setenv-5"> ssh_connection:setenv/5</seealso>. </p></item> - <tag><c><![CDATA[{pty, ssh_channel_id(), + <tag><c><![CDATA[{pty, channel_id(), WantReply :: boolean(), {Terminal :: string(), CharWidth :: integer(), RowHeight :: integer(), PixelWidth :: integer(), PixelHeight :: integer(), TerminalModes :: [{Opcode :: atom() | integer(), @@ -181,13 +181,13 @@ <seealso marker="ssh_connection#shell-2"> ssh_connection:shell/2</seealso>. </p></item> - <tag><c><![CDATA[{window_change, ssh_channel_id(), CharWidth() :: integer(), + <tag><c><![CDATA[{window_change, channel_id(), CharWidth() :: integer(), RowHeight :: integer(), PixWidth :: integer(), PixHeight :: integer()}]]></c></tag> <item><p>When the window (terminal) size changes on the client side, it <em>can</em> send a message to the server side to inform it of the new dimensions. No API function generates this event.</p></item> - <tag><c><![CDATA[{exec, ssh_channel_id(), + <tag><c><![CDATA[{exec, channel_id(), WantReply :: boolean(), Cmd :: string()}]]></c></tag> <item><p>This message requests that the server starts execution of the given command. This event is sent as a result of calling <seealso @@ -204,8 +204,8 @@ <name>adjust_window(ConnectionRef, ChannelId, NumOfBytes) -> ok</name> <fsummary>Adjusts the SSH flow control window.</fsummary> <type> - <v>ConnectionRef = ssh_connection_ref()</v> - <v>ChannelId = ssh_channel_id()</v> + <v>ConnectionRef = connection_ref()</v> + <v>ChannelId = channel_id()</v> <v>NumOfBytes = integer()</v> </type> <desc> @@ -224,8 +224,8 @@ <name>close(ConnectionRef, ChannelId) -> ok</name> <fsummary>Sends a close message on the channel <c>ChannelId</c>.</fsummary> <type> - <v>ConnectionRef = ssh_connection_ref()</v> - <v>ChannelId = ssh_channel_id()</v> + <v>ConnectionRef = connection_ref()</v> + <v>ChannelId = channel_id()</v> </type> <desc> <p>A server- or client-channel process can choose to close their session by @@ -244,8 +244,8 @@ {error, reason()}</name> <fsummary>Requests that the server starts the execution of the given command.</fsummary> <type> - <v>ConnectionRef = ssh_connection_ref()</v> - <v>ChannelId = ssh_channel_id()</v> + <v>ConnectionRef = connection_ref()</v> + <v>ChannelId = channel_id()</v> <v>Command = string()</v> <v>Timeout = timeout()</v> </type> @@ -256,27 +256,27 @@ request is a one-time execution that closes the channel when it is done.</p> <taglist> - <tag><c>N x {ssh_cm, ssh_connection_ref(), - {data, ssh_channel_id(), ssh_data_type_code(), Data :: binary()}}</c></tag> + <tag><c>N x {ssh_cm, connection_ref(), + {data, channel_id(), ssh_data_type_code(), Data :: binary()}}</c></tag> <item><p>The result of executing the command can be only one line or thousands of lines depending on the command.</p></item> - <tag><c>0 or 1 x {ssh_cm, ssh_connection_ref(), {eof, ssh_channel_id()}}</c></tag> + <tag><c>0 or 1 x {ssh_cm, connection_ref(), {eof, channel_id()}}</c></tag> <item><p>Indicates that no more data is to be sent.</p></item> <tag><c>0 or 1 x {ssh_cm, - ssh_connection_ref(), {exit_signal, - ssh_channel_id(), ExitSignal :: string(), ErrorMsg :: string(), LanguageString :: string()}}</c></tag> + connection_ref(), {exit_signal, + channel_id(), ExitSignal :: string(), ErrorMsg :: string(), LanguageString :: string()}}</c></tag> <item><p>Not all systems send signals. For details on valid string values, see RFC 4254, Section 6.10</p></item> - <tag><c>0 or 1 x {ssh_cm, ssh_connection_ref(), {exit_status, - ssh_channel_id(), ExitStatus :: integer()}}</c></tag> + <tag><c>0 or 1 x {ssh_cm, connection_ref(), {exit_status, + channel_id(), ExitStatus :: integer()}}</c></tag> <item><p>It is recommended by the SSH Connection Protocol to send this message, but that is not always the case.</p></item> - <tag><c>1 x {ssh_cm, ssh_connection_ref(), - {closed, ssh_channel_id()}}</c></tag> + <tag><c>1 x {ssh_cm, connection_ref(), + {closed, channel_id()}}</c></tag> <item><p>Indicates that the <c>ssh_channel</c> started for the execution of the command has now been shut down.</p></item> </taglist> @@ -287,8 +287,8 @@ <name>exit_status(ConnectionRef, ChannelId, Status) -> ok</name> <fsummary>Sends the exit status of a command to the client.</fsummary> <type> - <v>ConnectionRef = ssh_connection_ref() </v> - <v>ChannelId = ssh_channel_id()</v> + <v>ConnectionRef = connection_ref() </v> + <v>ChannelId = channel_id()</v> <v>Status = integer()</v> </type> <desc> @@ -304,8 +304,8 @@ <fsummary>Sends an SSH Connection Protocol <c>pty_req</c>, to allocate a pseudo-terminal.</fsummary> <type> - <v>ConnectionRef = ssh_connection_ref()</v> - <v>ChannelId = ssh_channel_id()</v> + <v>ConnectionRef = connection_ref()</v> + <v>ChannelId = channel_id()</v> <v>Options = proplists:proplist()</v> </type> <desc> @@ -342,10 +342,10 @@ <name>reply_request(ConnectionRef, WantReply, Status, ChannelId) -> ok</name> <fsummary>Sends status replies to requests that want such replies.</fsummary> <type> - <v>ConnectionRef = ssh_connection_ref()</v> + <v>ConnectionRef = connection_ref()</v> <v>WantReply = boolean()</v> <v>Status = ssh_request_status()</v> - <v>ChannelId = ssh_channel_id()</v> + <v>ChannelId = channel_id()</v> </type> <desc> <p>Sends status replies to requests where the requester has @@ -364,8 +364,8 @@ ok | {error, timeout} | {error, closed}</name> <fsummary>Sends channel data.</fsummary> <type> - <v>ConnectionRef = ssh_connection_ref()</v> - <v>ChannelId = ssh_channel_id()</v> + <v>ConnectionRef = connection_ref()</v> + <v>ChannelId = channel_id()</v> <v>Data = binary()</v> <v>Type = ssh_data_type_code()</v> <v>Timeout = timeout()</v> @@ -383,8 +383,8 @@ <name>send_eof(ConnectionRef, ChannelId) -> ok | {error, closed}</name> <fsummary>Sends EOF on channel <c>ChannelId</c>.</fsummary> <type> - <v>ConnectionRef = ssh_connection_ref()</v> - <v>ChannelId = ssh_channel_id()</v> + <v>ConnectionRef = connection_ref()</v> + <v>ChannelId = channel_id()</v> </type> <desc> <p>Sends EOF on channel <c>ChannelId</c>.</p> @@ -394,10 +394,10 @@ <func> <name>session_channel(ConnectionRef, Timeout) -></name> <name>session_channel(ConnectionRef, InitialWindowSize, - MaxPacketSize, Timeout) -> {ok, ssh_channel_id()} | {error, reason()}</name> + MaxPacketSize, Timeout) -> {ok, channel_id()} | {error, reason()}</name> <fsummary>Opens a channel for an SSH session.</fsummary> <type> - <v>ConnectionRef = ssh_connection_ref()</v> + <v>ConnectionRef = connection_ref()</v> <v>InitialWindowSize = integer()</v> <v>MaxPacketSize = integer()</v> <v>Timeout = timeout()</v> @@ -415,8 +415,8 @@ <fsummary>Environment variables can be passed to the shell/command to be started later.</fsummary> <type> - <v>ConnectionRef = ssh_connection_ref()</v> - <v>ChannelId = ssh_channel_id()</v> + <v>ConnectionRef = connection_ref()</v> + <v>ChannelId = channel_id()</v> <v>Var = string()</v> <v>Value = string()</v> <v>Timeout = timeout()</v> @@ -428,18 +428,22 @@ </func> <func> - <name>shell(ConnectionRef, ChannelId) -> ssh_request_status() | {error, closed} + <name>shell(ConnectionRef, ChannelId) -> ok | failure | {error, closed} </name> <fsummary>Requests that the user default shell (typically defined in /etc/passwd in Unix systems) is to be executed at the server end.</fsummary> <type> - <v>ConnectionRef = ssh_connection_ref()</v> - <v>ChannelId = ssh_channel_id()</v> + <v>ConnectionRef = connection_ref()</v> + <v>ChannelId = channel_id()</v> </type> <desc> <p>Is to be called by a client channel process to request that the user default shell (typically defined in /etc/passwd in Unix systems) is executed at the server end.</p> + <p>Note: the return value is <c>ok</c> instead of <c>success</c> unlike in other + functions in this module. This is a fault that was introduced so long ago that + any change would break a large number of existing software. + </p> </desc> </func> @@ -448,8 +452,8 @@ {error, reason()}</name> <fsummary>Requests to execute a predefined subsystem on the server.</fsummary> <type> - <v>ConnectionRef = ssh_connection_ref()</v> - <v>ChannelId = ssh_channel_id()</v> + <v>ConnectionRef = connection_ref()</v> + <v>ChannelId = channel_id()</v> <v>Subsystem = string()</v> <v>Timeout = timeout()</v> </type> diff --git a/lib/ssh/doc/src/ssh_server_key_api.xml b/lib/ssh/doc/src/ssh_server_key_api.xml index c6808b95d1..cf3b1d319f 100644 --- a/lib/ssh/doc/src/ssh_server_key_api.xml +++ b/lib/ssh/doc/src/ssh_server_key_api.xml @@ -41,7 +41,7 @@ see the <seealso marker="SSH_app"> ssh(6)</seealso> application manual.</p> </description> - <section> + <!-- section> <title>DATA TYPES</title> <p>Type definitions that are used more than once in this module, @@ -69,22 +69,40 @@ | 'rsa-sha2-256' | 'rsa-sha2-384' | 'rsa-sha2-512' | 'ecdsa-sha2-nistp256' | 'ecdsa-sha2-nistp384' | 'ecdsa-sha2-nistp521' </c></p></item> </taglist> - </section> + </section --> + <datatypes> + <datatype> + <name name="daemon_key_cb_options"/> + <desc> + <p>Options provided to <seealso marker="ssh#daemon-2">ssh:daemon/2,3</seealso>. + </p> + <p>The option list given in the + <seealso marker="ssh#type-key_cb_common_option"><c>key_cb</c></seealso> + option is available with the key <c>key_cb_private</c>. + </p> + </desc> + </datatype> + </datatypes> + <funcs> <func> <name>Module:host_key(Algorithm, DaemonOptions) -> {ok, Key} | {error, Reason}</name> <fsummary>Fetches the host’s private key.</fsummary> <type> - <v>Algorithm = public_key_algorithm()</v> + <v>Algorithm = <seealso marker="ssh#type-pubkey_alg">ssh:pubkey_alg()</seealso></v> <d>Host key algorithm.</d> - <v>DaemonOptions = proplists:proplist()</v> - <d>Options provided to <seealso marker="ssh#daemon-2">ssh:daemon/[2,3]</seealso>. The option list given in - the <c>key_cb</c> option is available with the key <c>key_cb_private</c>.</d> - <v>Key = private_key() | crypto:engine_key_ref()</v> + + <v>DaemonOptions = <seealso marker="#type-daemon_key_cb_options">daemon_key_cb_options()</seealso></v> + + <v>PrivateKey = <seealso marker="public_key:public_key#type-private_key">public_key:private_key()</seealso> + | <seealso marker="crypto:crypto#type-engine_key_ref">crypto:engine_key_ref()</seealso> + </v> + <d>Private key of the host matching the <c>Algorithm</c>. It may be a reference to a 'ssh-rsa', rsa-sha2-* or 'ssh-dss' (NOT ecdsa) key stored in a loaded Engine.</d> + <v>Reason = term()</v> </type> <desc> @@ -93,16 +111,17 @@ </func> <func> - <name>Module:is_auth_key(Key, User, DaemonOptions) -> Result</name> + <name>Module:is_auth_key(PublicUserKey, User, DaemonOptions) -> Result</name> <fsummary>Checks if the user key is authorized.</fsummary> <type> - <v>Key = public_key()</v> + <v>PublicUserKey = <seealso marker="public_key:public_key#type-public_key">public_key:public_key()</seealso></v> <d>Normally an RSA, DSA or ECDSA public key, but handling of other public keys can be added</d> + <v>User = string()</v> <d>User owning the public key.</d> - <v>DaemonOptions = proplists:proplist()</v> - <d>Options provided to <seealso marker="ssh#daemon-2">ssh:daemon/[2,3]</seealso>. The option list given in - the <c>key_cb</c> option is available with the key <c>key_cb_private</c>.</d> + + <v>DaemonOptions = <seealso marker="#type-daemon_key_cb_options">daemon_key_cb_options()</seealso></v> + <v>Result = boolean()</v> </type> <desc> diff --git a/lib/ssh/doc/src/ssh_sftp.xml b/lib/ssh/doc/src/ssh_sftp.xml index 129426a6d5..60f643d052 100644 --- a/lib/ssh/doc/src/ssh_sftp.xml +++ b/lib/ssh/doc/src/ssh_sftp.xml @@ -59,7 +59,7 @@ </p> </item> - <tag><c>ssh_connection_ref() =</c></tag> + <tag><c>connection_ref() =</c></tag> <item><p><c>opaque()</c> - as returned by <seealso marker="ssh#connect-3"><c>ssh:connect/3</c></seealso></p></item> @@ -546,7 +546,7 @@ <fsummary>Starts an SFTP client.</fsummary> <type> <v>Host = string()</v> - <v>ConnectionRef = ssh_connection_ref()</v> + <v>ConnectionRef = connection_ref()</v> <v>Port = integer()</v> <v>TcpSocket = port()</v> <d>The socket is supposed to be from <seealso marker="kernel:gen_tcp#connect-3">gen_tcp:connect</seealso> or <seealso marker="kernel:gen_tcp#accept-1">gen_tcp:accept</seealso> with option <c>{active,false}</c></d> diff --git a/lib/ssh/doc/src/using_ssh.xml b/lib/ssh/doc/src/using_ssh.xml index ab307624e6..bde2aaaf99 100644 --- a/lib/ssh/doc/src/using_ssh.xml +++ b/lib/ssh/doc/src/using_ssh.xml @@ -298,6 +298,7 @@ ok = erl_tar:close(HandleRead), </section> <section> + <marker id="usersguide_creating_a_subsystem"/> <title>Creating a Subsystem</title> <p>A small <c>ssh</c> subsystem that echoes N bytes can be implemented as shown diff --git a/lib/ssh/src/Makefile b/lib/ssh/src/Makefile index 9e8d80c71f..bcd13213b3 100644 --- a/lib/ssh/src/Makefile +++ b/lib/ssh/src/Makefile @@ -97,7 +97,7 @@ APP_TARGET= $(EBIN)/$(APP_FILE) APPUP_SRC= $(APPUP_FILE).src APPUP_TARGET= $(EBIN)/$(APPUP_FILE) -INTERNAL_HRL_FILES = ssh_auth.hrl ssh_connect.hrl ssh_transport.hrl ssh.hrl ssh_userauth.hrl ssh_xfer.hrl ssh_dbg.hrl +INTERNAL_HRL_FILES = ssh_auth.hrl ssh_connect.hrl ssh_transport.hrl ssh.hrl ssh_userauth.hrl ssh_xfer.hrl # ---------------------------------------------------- # FLAGS diff --git a/lib/ssh/src/ssh.erl b/lib/ssh/src/ssh.erl index 25d537c624..209f53d249 100644 --- a/lib/ssh/src/ssh.erl +++ b/lib/ssh/src/ssh.erl @@ -41,35 +41,51 @@ shell/1, shell/2, shell/3 ]). +%%% "Deprecated" types export: +-export_type([ssh_daemon_ref/0, ssh_connection_ref/0, ssh_channel_id/0]). +-opaque ssh_daemon_ref() :: daemon_ref(). +-opaque ssh_connection_ref() :: connection_ref(). +-opaque ssh_channel_id() :: channel_id(). + + %%% Type exports --export_type([ssh_daemon_ref/0, - ssh_connection_ref/0, - ssh_channel_id/0, +-export_type([daemon_ref/0, + connection_ref/0, + channel_id/0, + client_options/0, client_option/0, + daemon_options/0, daemon_option/0, + common_options/0, role/0, subsystem_spec/0, - subsystem_name/0, - channel_callback/0, - channel_init_args/0, algs_list/0, + double_algs/1, + modify_algs_list/0, alg_entry/0, - simple_algs/0, - double_algs/0 + kex_alg/0, + pubkey_alg/0, + cipher_alg/0, + mac_alg/0, + compression_alg/0, + ip_port/0 ]). --opaque ssh_daemon_ref() :: daemon_ref() . --opaque ssh_connection_ref() :: connection_ref() . --opaque ssh_channel_id() :: channel_id(). + +-opaque daemon_ref() :: pid() . +-opaque channel_id() :: non_neg_integer(). +-type connection_ref() :: pid(). % should be -opaque, but that gives problems %%-------------------------------------------------------------------- --spec start() -> ok | {error, term()}. --spec start(permanent | transient | temporary) -> ok | {error, term()}. -%% %% Description: Starts the ssh application. Default type %% is temporary. see application(3) %%-------------------------------------------------------------------- +-spec start() -> ok | {error, term()}. + start() -> start(temporary). +-spec start(Type) -> ok | {error, term()} when + Type :: permanent | transient | temporary . + start(Type) -> case application:ensure_all_started(ssh, Type) of {ok, _} -> @@ -79,30 +95,32 @@ start(Type) -> end. %%-------------------------------------------------------------------- --spec stop() -> ok | {error, term()}. -%% %% Description: Stops the ssh application. %%-------------------------------------------------------------------- +-spec stop() -> ok | {error, term()}. + stop() -> application:stop(ssh). %%-------------------------------------------------------------------- --spec connect(inet:socket(), proplists:proplist()) -> ok_error(connection_ref()). +%% Description: Starts an ssh connection. +%%-------------------------------------------------------------------- +-spec connect(OpenTcpSocket, Options) -> {ok,connection_ref()} | {error,term()} when + OpenTcpSocket :: open_socket(), + Options :: client_options(). --spec connect(inet:socket(), proplists:proplist(), timeout()) -> ok_error(connection_ref()) - ; (string(), inet:port_number(), proplists:proplist()) -> ok_error(connection_ref()). +connect(OpenTcpSocket, Options) when is_port(OpenTcpSocket), + is_list(Options) -> + connect(OpenTcpSocket, Options, infinity). --spec connect(string(), inet:port_number(), proplists:proplist(), timeout()) -> ok_error(connection_ref()). -%% -%% Description: Starts an ssh connection. -%%-------------------------------------------------------------------- -connect(Socket, UserOptions) when is_port(Socket), - is_list(UserOptions) -> - connect(Socket, UserOptions, infinity). +-spec connect(open_socket(), client_options(), timeout()) -> + {ok,connection_ref()} | {error,term()} + ; (host(), inet:port_number(), client_options()) -> + {ok,connection_ref()} | {error,term()}. -connect(Socket, UserOptions, Timeout) when is_port(Socket), - is_list(UserOptions) -> +connect(Socket, UserOptions, NegotiationTimeout) when is_port(Socket), + is_list(UserOptions) -> case ssh_options:handle_options(client, UserOptions) of {error, Error} -> {error, Error}; @@ -111,16 +129,23 @@ connect(Socket, UserOptions, Timeout) when is_port(Socket), ok -> {ok, {Host,_Port}} = inet:sockname(Socket), Opts = ?PUT_INTERNAL_OPT([{user_pid,self()}, {host,Host}], Options), - ssh_connection_handler:start_connection(client, Socket, Opts, Timeout); + ssh_connection_handler:start_connection(client, Socket, Opts, NegotiationTimeout); {error,SockError} -> {error,SockError} end end; -connect(Host, Port, UserOptions) when is_integer(Port), - Port>0, - is_list(UserOptions) -> - connect(Host, Port, UserOptions, infinity). +connect(Host, Port, Options) when is_integer(Port), + Port>0, + is_list(Options) -> + connect(Host, Port, Options, infinity). + + +-spec connect(Host, Port, Options, NegotiationTimeout) -> {ok,connection_ref()} | {error,term()} when + Host :: host(), + Port :: inet:port_number(), + Options :: client_options(), + NegotiationTimeout :: timeout(). connect(Host0, Port, UserOptions, Timeout) when is_integer(Port), Port>0, @@ -148,7 +173,8 @@ connect(Host0, Port, UserOptions, Timeout) when is_integer(Port), end. %%-------------------------------------------------------------------- --spec close(pid()) -> ok. +-spec close(ConnectionRef) -> ok | {error,term()} when + ConnectionRef :: connection_ref() . %% %% Description: Closes an ssh connection. %%-------------------------------------------------------------------- @@ -156,15 +182,25 @@ close(ConnectionRef) -> ssh_connection_handler:stop(ConnectionRef). %%-------------------------------------------------------------------- --spec connection_info(pid(), [atom()]) -> [{atom(), term()}]. -%% %% Description: Retrieves information about a connection. %%-------------------------------------------------------------------- -connection_info(ConnectionRef, Options) -> - ssh_connection_handler:connection_info(ConnectionRef, Options). +-spec connection_info(ConnectionRef, Keys) -> ConnectionInfo when + ConnectionRef :: connection_ref(), + Keys :: [client_version | server_version | user | peer | sockname], + ConnectionInfo :: [{client_version, Version} + | {server_version, Version} + | {user,string()} + | {peer, {inet:hostname(), ip_port()}} + | {sockname, ip_port()} + ], + Version :: {ProtocolVersion, VersionString::string()}, + ProtocolVersion :: {Major::pos_integer(), Minor::non_neg_integer()} . + +connection_info(Connection, Options) -> + ssh_connection_handler:connection_info(Connection, Options). %%-------------------------------------------------------------------- --spec channel_info(pid(), channel_id(), [atom()]) -> [{atom(), term()}]. +-spec channel_info(connection_ref(), channel_id(), [atom()]) -> proplists:proplist(). %% %% Description: Retrieves information about a connection. %%-------------------------------------------------------------------- @@ -172,18 +208,17 @@ channel_info(ConnectionRef, ChannelId, Options) -> ssh_connection_handler:channel_info(ConnectionRef, ChannelId, Options). %%-------------------------------------------------------------------- --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. %%-------------------------------------------------------------------- +-spec daemon(inet:port_number()) -> {ok,daemon_ref()} | {error,term()}. + daemon(Port) -> daemon(Port, []). + +-spec daemon(inet:port_number()|open_socket(), daemon_options()) -> {ok,daemon_ref()} | {error,term()}. + daemon(Socket, UserOptions) when is_port(Socket) -> try #{} = Options = ssh_options:handle_options(server, UserOptions), @@ -226,6 +261,10 @@ daemon(Port, UserOptions) when 0 =< Port, Port =< 65535 -> daemon(any, Port, UserOptions). +-spec daemon(any | inet:ip_address(), inet:port_number(), daemon_options()) -> {ok,daemon_ref()} | {error,term()} + ;(socket, open_socket(), daemon_options()) -> {ok,daemon_ref()} | {error,term()} + . + daemon(Host0, Port0, UserOptions0) when 0 =< Port0, Port0 =< 65535, Host0 == any ; Host0 == loopback ; is_tuple(Host0) -> try @@ -267,7 +306,12 @@ daemon(_, _, _) -> {error, badarg}. %%-------------------------------------------------------------------- --spec daemon_info(daemon_ref()) -> ok_error( [{atom(), term()}] ). +-spec daemon_info(Daemon) -> {ok, DaemonInfo} | {error,term()} when + Daemon :: daemon_ref(), + DaemonInfo :: [ {ip, inet:ip_address()} + | {port, inet:port_number()} + | {profile, term()} + ]. daemon_info(Pid) -> case catch ssh_system_sup:acceptor_supervisor(Pid) of @@ -290,16 +334,23 @@ daemon_info(Pid) -> end. %%-------------------------------------------------------------------- --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. %%-------------------------------------------------------------------- +-spec stop_listener(daemon_ref()) -> ok. + stop_listener(SysSup) -> ssh_system_sup:stop_listener(SysSup). + + +-spec stop_listener(inet:ip_address(), inet:port_number()) -> ok. + stop_listener(Address, Port) -> stop_listener(Address, Port, ?DEFAULT_PROFILE). + + +-spec stop_listener(any|inet:ip_address(), inet:port_number(), term()) -> ok. + stop_listener(any, Port, Profile) -> map_ip(fun(IP) -> ssh_system_sup:stop_listener(IP, Port, Profile) @@ -310,17 +361,23 @@ stop_listener(Address, Port, Profile) -> end, {address,Address}). %%-------------------------------------------------------------------- --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. %%-------------------------------------------------------------------- +-spec stop_daemon(DaemonRef::daemon_ref()) -> ok. + stop_daemon(SysSup) -> ssh_system_sup:stop_system(SysSup). + + +-spec stop_daemon(inet:ip_address(), inet:port_number()) -> ok. + stop_daemon(Address, Port) -> stop_daemon(Address, Port, ?DEFAULT_PROFILE). + + +-spec stop_daemon(any|inet:ip_address(), inet:port_number(), atom()) -> ok. + stop_daemon(any, Port, Profile) -> map_ip(fun(IP) -> ssh_system_sup:stop_system(IP, Port, Profile) @@ -331,33 +388,37 @@ stop_daemon(Address, Port, Profile) -> end, {address,Address}). %%-------------------------------------------------------------------- --spec shell(inet:socket() | string()) -> _. --spec shell(inet:socket() | string(), proplists:proplist()) -> _. --spec shell(string(), inet:port_number(), proplists:proplist()) -> _. - -%% Host = string() -%% Port = integer() -%% Options = [{Option, Value}] -%% %% Description: Starts an interactive shell to an SSH server on the %% given <Host>. The function waits for user input, %% and will not return until the remote shell is ended.(e.g. on %% exit from the shell) %%-------------------------------------------------------------------- +-spec shell(open_socket() | host()) -> _. + shell(Socket) when is_port(Socket) -> shell(Socket, []); shell(Host) -> shell(Host, ?SSH_DEFAULT_PORT, []). + +-spec shell(open_socket() | host(), client_options()) -> _. + shell(Socket, Options) when is_port(Socket) -> start_shell( connect(Socket, Options) ); shell(Host, Options) -> shell(Host, ?SSH_DEFAULT_PORT, Options). + +-spec shell(Host, Port, Options) -> _ when + Host :: host(), + Port :: inet:port_number(), + Options :: client_options() . + shell(Host, Port, Options) -> start_shell( connect(Host, Port, Options) ). + start_shell({ok, ConnectionRef}) -> case ssh_connection:session_channel(ConnectionRef, infinity) of {ok,ChannelId} -> @@ -366,10 +427,16 @@ start_shell({ok, ConnectionRef}) -> {init_args,[ConnectionRef, ChannelId]}, {cm, ConnectionRef}, {channel_id, ChannelId}], {ok, State} = ssh_channel:init([Args]), - ssh_channel:enter_loop(State); + try + ssh_channel:enter_loop(State) + catch + exit:normal -> + ok + end; Error -> Error end; + start_shell(Error) -> Error. @@ -380,7 +447,7 @@ default_algorithms() -> ssh_transport:default_algorithms(). %%-------------------------------------------------------------------- --spec chk_algos_opts(list(any())) -> algs_list() . +-spec chk_algos_opts(client_options()|daemon_options()) -> internal_options() | {error,term()}. %%-------------------------------------------------------------------- chk_algos_opts(Opts) -> case lists:foldl( diff --git a/lib/ssh/src/ssh.hrl b/lib/ssh/src/ssh.hrl index 8d950eea3c..a3d9a1b1cb 100644 --- a/lib/ssh/src/ssh.hrl +++ b/lib/ssh/src/ssh.hrl @@ -98,35 +98,267 @@ %% Types --type role() :: client | server . --type ok_error(SuccessType) :: {ok, SuccessType} | {error, any()} . --type daemon_ref() :: pid() . +-type role() :: client | server . + +-type host() :: string() | inet:ip_address() | loopback . +-type open_socket() :: gen_tcp:socket(). + +-type subsystem_spec() :: {Name::string(), mod_args()} . + +-type algs_list() :: list( alg_entry() ). +-type alg_entry() :: {kex, [kex_alg()]} + | {public_key, [pubkey_alg()]} + | {cipher, double_algs(cipher_alg())} + | {mac, double_algs(mac_alg())} + | {compression, double_algs(compression_alg())} . + +-type kex_alg() :: 'diffie-hellman-group-exchange-sha1' | + 'diffie-hellman-group-exchange-sha256' | + 'diffie-hellman-group1-sha1' | + 'diffie-hellman-group14-sha1' | + 'diffie-hellman-group14-sha256' | + 'diffie-hellman-group16-sha512' | + 'diffie-hellman-group18-sha512' | + 'ecdh-sha2-nistp256' | + 'ecdh-sha2-nistp384' | + 'ecdh-sha2-nistp521' + . + +-type pubkey_alg() :: 'ecdsa-sha2-nistp256' | + 'ecdsa-sha2-nistp384' | + 'ecdsa-sha2-nistp521' | + 'rsa-sha2-256' | + 'rsa-sha2-512' | + 'ssh-dss' | + 'ssh-rsa' + . + +-type cipher_alg() :: '3des-cbc' | + 'AEAD_AES_128_GCM' | + 'AEAD_AES_256_GCM' | + 'aes128-cbc' | + 'aes128-ctr' | + '[email protected]' | + 'aes192-ctr' | + 'aes256-ctr' | + . + +-type mac_alg() :: 'AEAD_AES_128_GCM' | + 'AEAD_AES_256_GCM' | + 'hmac-sha1' | + 'hmac-sha2-256' | + 'hmac-sha2-512' + . + +-type compression_alg() :: 'none' | + 'zlib' | + . + +-type double_algs(AlgType) :: list( {client2server,[AlgType]} | {server2client,[AlgType]} ) + | [AlgType]. + +-type modify_algs_list() :: list( {append,algs_list()} | {prepend,algs_list()} | {rm,algs_list()} ) . + +-type internal_options() :: ssh_options:private_options(). +-type socket_options() :: [gen_tcp:connect_option() | gen_tcp:listen_option()]. + +-type client_options() :: [ client_option() ] . +-type daemon_options() :: [ daemon_option() ]. + + +-type common_options() :: [ common_option() ]. +-type common_option() :: + user_dir_common_option() + | profile_common_option() + | max_idle_time_common_option() + | key_cb_common_option() + | disconnectfun_common_option() + | unexpectedfun_common_option() + | ssh_msg_debug_fun_common_option() + | rekey_limit_common_option() + | id_string_common_option() + | preferred_algorithms_common_option() + | modify_algorithms_common_option() + | auth_methods_common_option() + | inet_common_option() + | fd_common_option() + . + +-define(COMMON_OPTION, common_option()). + + +-type user_dir_common_option() :: {user_dir, false | string()}. +-type profile_common_option() :: {profile, atom() }. +-type max_idle_time_common_option() :: {idle_time, timeout()}. +-type rekey_limit_common_option() :: {rekey_limit, non_neg_integer() }. + +-type key_cb_common_option() :: {key_cb, Module::atom() | {Module::atom(),Opts::[term()]} } . +-type disconnectfun_common_option() :: + {disconnectfun, fun((Reason::term()) -> void | any()) }. +-type unexpectedfun_common_option() :: + {unexpectedfun, fun((Message::term(),{Host::term(),Port::term()}) -> report | skip ) }. +-type ssh_msg_debug_fun_common_option() :: + {ssh_msg_debug_fun, fun((ssh:connection_ref(),AlwaysDisplay::boolean(),Msg::binary(),LanguageTag::binary()) -> any()) } . + +-type id_string_common_option() :: {id_string, string() | random | {random,Nmin::pos_integer(),Nmax::pos_integer()} }. +-type preferred_algorithms_common_option():: {preferred_algorithms, algs_list()}. +-type modify_algorithms_common_option() :: {modify_algorithms, modify_algs_list()}. +-type auth_methods_common_option() :: {auth_methods, string() }. + +-type inet_common_option() :: {inet, inet | inet6} . +-type fd_common_option() :: {fd, gen_tcp:socket()} . + + +-type opaque_common_options() :: + {transport, {atom(),atom(),atom()} } + | {vsn, {non_neg_integer(),non_neg_integer()} } + | {tstflg, list(term())} + | {user_dir_fun, fun()} + | {max_random_length_padding, non_neg_integer()} . + + + +-type client_option() :: + pref_public_key_algs_client_option() + | pubkey_passphrase_client_options() + | host_accepting_client_options() + | authentication_client_options() + | diffie_hellman_group_exchange_client_option() + | connect_timeout_client_option() + | recv_ext_info_client_option() + | opaque_client_options() + | gen_tcp:connect_option() + | ?COMMON_OPTION . + +-type opaque_client_options() :: + {keyboard_interact_fun, fun((term(),term(),term()) -> term())} + | opaque_common_options(). + +-type pref_public_key_algs_client_option() :: {pref_public_key_algs, [pubkey_alg()] } . + +-type pubkey_passphrase_client_options() :: {dsa_pass_phrase, string()} + | {rsa_pass_phrase, string()} + | {ecdsa_pass_phrase, string()} . + +-type host_accepting_client_options() :: + {silently_accept_hosts, accept_hosts()} + | {user_interaction, boolean()} + | {save_accepted_host, boolean()} + | {quiet_mode, boolean()} . + +-type accept_hosts() :: boolean() + | accept_callback() + | {HashAlgoSpec::fp_digest_alg(), accept_callback()}. + +-type fp_digest_alg() :: 'md5' | + 'sha' | + 'sha224' | + 'sha256' | + 'sha384' | + 'sha512' + . + +-type accept_callback() :: fun((PeerName::string(), fingerprint() ) -> boolean()) . +-type fingerprint() :: string() | [string()]. + +-type authentication_client_options() :: + {user, string()} + | {password, string()} . + +-type diffie_hellman_group_exchange_client_option() :: + {dh_gex_limits, {Min::pos_integer(), I::pos_integer(), Max::pos_integer()} } . + +-type connect_timeout_client_option() :: {connect_timeout, timeout()} . + +-type recv_ext_info_client_option() :: {recv_ext_info, boolean()} . + + + +-type daemon_option() :: + subsystem_daemon_option() + | shell_daemon_option() + | exec_daemon_option() + | ssh_cli_daemon_option() + | authentication_daemon_options() + | diffie_hellman_group_exchange_daemon_option() + | negotiation_timeout_daemon_option() + | hardening_daemon_options() + | callbacks_daemon_options() + | send_ext_info_daemon_option() + | opaque_daemon_options() + | gen_tcp:listen_option() + | ?COMMON_OPTION . --type subsystem_spec() :: {subsystem_name(), {channel_callback(), channel_init_args()}} . --type subsystem_name() :: string() . --type channel_callback() :: atom() . --type channel_init_args() :: list() . +-type subsystem_daemon_option() :: {subsystems, subsystem_spec()}. --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( {client2server,simple_algs()} | {server2client,simple_algs()} ) - | simple_algs() . +-type shell_daemon_option() :: {shell, mod_fun_args() | 'shell_fun/1'() | 'shell_fun/2'() }. +-type 'shell_fun/1'() :: fun((User::string()) -> pid()) . +-type 'shell_fun/2'() :: fun((User::string(), PeerAddr::inet:ip_address()) -> pid()). --type options() :: #{socket_options := socket_options(), - internal_options := internal_options(), - option_key() => any() - }. +-type exec_daemon_option() :: {exec, 'exec_fun/1'() | 'exec_fun/2'() | 'exec_fun/3'() }. --type socket_options() :: proplists:proplist(). --type internal_options() :: #{option_key() => any()}. +-type 'exec_fun/1'() :: fun((Cmd::string()) -> exec_result()) . +-type 'exec_fun/2'() :: fun((Cmd::string(), User::string()) -> exec_result()) . +-type 'exec_fun/3'() :: fun((Cmd::string(), User::string(), ClientAddr::ip_port()) -> exec_result()) . +-type exec_result() :: {ok,Result::term()} | {error,Reason::term()} . --type option_key() :: atom(). +-type ssh_cli_daemon_option() :: {ssh_cli, mod_args() | no_cli }. +-type send_ext_info_daemon_option() :: {send_ext_info, boolean()} . + +-type authentication_daemon_options() :: + {system_dir, string()} + | {auth_method_kb_interactive_data, prompt_texts() } + | {user_passwords, [{UserName::string(),Pwd::string()}]} + | {password, string()} + | {pwdfun, pwdfun_2() | pwdfun_4()} . + +-type prompt_texts() :: + kb_int_tuple() + | kb_int_fun_3() + . + +-type kb_int_fun_3() :: fun((Peer::ip_port(), User::string(), Service::string()) -> kb_int_tuple()). +-type kb_int_tuple() :: {Name::string(), Instruction::string(), Prompt::string(), Echo::boolean()}. + +-type pwdfun_2() :: fun((User::string(), Password::string()) -> boolean()) . +-type pwdfun_4() :: fun((User::string(), + Password::string(), + PeerAddress::ip_port(), + State::any()) -> + boolean() | disconnect | {boolean(),NewState::any()} + ) . + +-type diffie_hellman_group_exchange_daemon_option() :: + {dh_gex_groups, [explicit_group()] | explicit_group_file() | ssh_moduli_file()} + | {dh_gex_limits, {Min::pos_integer(), Max::pos_integer()} } . + +-type explicit_group() :: {Size::pos_integer(),G::pos_integer(),P::pos_integer()} . +-type explicit_group_file() :: {file,string()} . +-type ssh_moduli_file() :: {ssh_moduli_file,string()}. + +-type negotiation_timeout_daemon_option() :: {negotiation_timeout, timeout()} . + +-type hardening_daemon_options() :: + {max_sessions, pos_integer()} + | {max_channels, pos_integer()} + | {parallel_login, boolean()} + | {minimal_remote_max_packet_size, pos_integer()}. + +-type callbacks_daemon_options() :: + {failfun, fun((User::string(), PeerAddress::inet:ip_address(), Reason::term()) -> _)} + | {connectfun, fun((User::string(), PeerAddress::inet:ip_address(), Method::string()) ->_)} . + +-type opaque_daemon_options() :: + {infofun, fun()} + | opaque_common_options(). + +-type ip_port() :: {inet:ip_address(), inet:port_number()} . + +-type mod_args() :: {Module::atom(), Args::list()} . +-type mod_fun_args() :: {Module::atom(), Function::atom(), Args::list()} . %% Records @@ -134,8 +366,9 @@ { role :: client | role(), peer :: undefined | - {inet:hostname(), - {inet:ip_address(),inet:port_number()}}, %% string version of peer address + {inet:hostname(),ip_port()}, %% string version of peer address + + local, %% Local sockname. Need this AFTER a socket is closed by i.e. a crash c_vsn, %% client version {Major,Minor} s_vsn, %% server version {Major,Minor} @@ -151,8 +384,6 @@ algorithms, %% #alg{} - kex, %% key exchange algorithm - hkey, %% host key algorithm key_cb, %% Private/Public key callback module io_cb, %% Interaction callback module @@ -248,4 +479,13 @@ _ -> exit(Reason) end). + +%% dbg help macros +-define(wr_record(N,BlackList), + wr_record(R=#N{}) -> ssh_dbg:wr_record(R, record_info(fields,N), BlackList) + ). + +-define(wr_record(N), ?wr_record(N, [])). + + -endif. % SSH_HRL defined diff --git a/lib/ssh/src/ssh_acceptor.erl b/lib/ssh/src/ssh_acceptor.erl index d66a34c58a..516a9febaa 100644 --- a/lib/ssh/src/ssh_acceptor.erl +++ b/lib/ssh/src/ssh_acceptor.erl @@ -33,6 +33,8 @@ %% spawn export -export([acceptor_init/5, acceptor_loop/6]). +-export([dbg_trace/3]). + -define(SLEEP_TIME, 200). %%==================================================================== @@ -86,7 +88,8 @@ acceptor_init(Parent, Port, Address, Opts, AcceptTimeout) -> acceptor_loop(Callback, Port, Address, Opts, LSock, AcceptTimeout); {error,_} -> % Not open, a restart - {ok,NewLSock} = listen(Port, Opts), + %% Allow gen_tcp:listen to fail 4 times if eaddrinuse: + {ok,NewLSock} = try_listen(Port, Opts, 4), proc_lib:init_ack(Parent, {ok, self()}), Opts1 = ?DELETE_INTERNAL_OPT(lsocket, Opts), {_, Callback, _} = ?GET_OPT(transport, Opts1), @@ -98,6 +101,19 @@ acceptor_init(Parent, Port, Address, Opts, AcceptTimeout) -> end. +try_listen(Port, Opts, NtriesLeft) -> + try_listen(Port, Opts, 1, NtriesLeft). + +try_listen(Port, Opts, N, Nmax) -> + case listen(Port, Opts) of + {error,eaddrinuse} when N<Nmax -> + timer:sleep(10*N), % Sleep 10, 20, 30,... ms + try_listen(Port, Opts, N+1, Nmax); + Other -> + Other + end. + + request_ownership(LSock, SockOwner) -> SockOwner ! {request_control,LSock,self()}, receive @@ -181,3 +197,33 @@ handle_error(Reason) -> error_logger:error_report(String), exit({accept_failed, String}). +%%%################################################################ +%%%# +%%%# Tracing +%%%# + +dbg_trace(points, _, _) -> [connections]; + +dbg_trace(flags, connections, _) -> [c]; +dbg_trace(on, connections, _) -> dbg:tp(?MODULE, acceptor_init, 5, x), + dbg:tpl(?MODULE, handle_connection, 5, x); +dbg_trace(off, connections, _) -> dbg:ctp(?MODULE, acceptor_init, 5), + dbg:ctp(?MODULE, handle_connection, 5); +dbg_trace(format, connections, {call, {?MODULE,acceptor_init, + [_Parent, Port, Address, _Opts, _AcceptTimeout]}}) -> + [io_lib:format("Starting LISTENER on ~s:~p\n", [ntoa(Address),Port]) + ]; +dbg_trace(format, connections, {return_from, {?MODULE,handle_connection,5}, {error,Error}}) -> + ["Starting connection to server failed:\n", + io_lib:format("Error = ~p", [Error]) + ]. + + + +ntoa(A) -> + try inet:ntoa(A) + catch + _:_ when is_list(A) -> A; + _:_ -> io_lib:format('~p',[A]) + end. + diff --git a/lib/ssh/src/ssh_acceptor_sup.erl b/lib/ssh/src/ssh_acceptor_sup.erl index fc564a359b..10fd4452bf 100644 --- a/lib/ssh/src/ssh_acceptor_sup.erl +++ b/lib/ssh/src/ssh_acceptor_sup.erl @@ -36,8 +36,6 @@ -define(DEFAULT_TIMEOUT, 50000). --spec init( [term()] ) -> {ok,{supervisor:sup_flags(),[supervisor:child_spec()]}} | ignore . - %%%========================================================================= %%% API %%%========================================================================= diff --git a/lib/ssh/src/ssh_auth.erl b/lib/ssh/src/ssh_auth.erl index 03d264745b..bf3f5a68e4 100644 --- a/lib/ssh/src/ssh_auth.erl +++ b/lib/ssh/src/ssh_auth.erl @@ -40,15 +40,12 @@ %%-------------------------------------------------------------------- %%%---------------------------------------------------------------- userauth_request_msg(#ssh{userauth_methods = ServerMethods, - userauth_supported_methods = UserPrefMethods, % Note: this is not documented as supported for clients + userauth_supported_methods = UserPrefMethods, userauth_preference = ClientMethods0 } = Ssh0) -> case sort_select_mthds(ClientMethods0, UserPrefMethods, ServerMethods) of [] -> - Msg = #ssh_msg_disconnect{code = ?SSH_DISCONNECT_NO_MORE_AUTH_METHODS_AVAILABLE, - description = "Unable to connect using the available authentication methods", - language = "en"}, - {disconnect, Msg, ssh_transport:ssh_packet(Msg, Ssh0)}; + {send_disconnect, ?SSH_DISCONNECT_NO_MORE_AUTH_METHODS_AVAILABLE, Ssh0}; [{Pref,Module,Function,Args} | Prefs] -> Ssh = case Pref of @@ -196,11 +193,8 @@ init_userauth_request_msg(#ssh{opts = Opts} = Ssh) -> %% Client side 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}); - + ?DISCONNECT(?SSH_DISCONNECT_ILLEGAL_USER_NAME, + "Could not determine the users name"); User -> ssh_transport:ssh_packet( #ssh_msg_userauth_request{user = User, @@ -451,11 +445,8 @@ handle_userauth_info_response({extra,#ssh_msg_userauth_info_response{}}, handle_userauth_info_response(#ssh_msg_userauth_info_response{}, _Auth) -> - ssh_connection_handler:disconnect( - #ssh_msg_disconnect{code = ?SSH_DISCONNECT_SERVICE_NOT_AVAILABLE, - description = "Server does not support keyboard-interactive" - }). - + ?DISCONNECT(?SSH_DISCONNECT_SERVICE_NOT_AVAILABLE, + "Server does not support keyboard-interactive"). %%-------------------------------------------------------------------- %%% Internal functions @@ -492,10 +483,8 @@ check_password(User, Password, Opts, Ssh) -> {false,NewState} -> {false, Ssh#ssh{pwdfun_user_state=NewState}}; disconnect -> - ssh_connection_handler:disconnect( - #ssh_msg_disconnect{code = ?SSH_DISCONNECT_SERVICE_NOT_AVAILABLE, - description = "Unable to connect using the available authentication methods" - }) + ?DISCONNECT(?SSH_DISCONNECT_NO_MORE_AUTH_METHODS_AVAILABLE, + "") end end. @@ -591,16 +580,12 @@ keyboard_interact_fun(KbdInteractFun, Name, Instr, PromptInfos, NumPrompts) -> case KbdInteractFun(Name, Instr, Prompts) of Rs when length(Rs) == NumPrompts -> Rs; - Rs -> - throw({mismatching_number_of_responses, - {got,Rs}, - {expected, NumPrompts}, - #ssh_msg_disconnect{code = ?SSH_DISCONNECT_SERVICE_NOT_AVAILABLE, - description = "User interaction failed", - language = "en"}}) + _Rs -> + nok end. key_alg('rsa-sha2-256') -> 'ssh-rsa'; key_alg('rsa-sha2-512') -> 'ssh-rsa'; key_alg(Alg) -> Alg. + diff --git a/lib/ssh/src/ssh_channel.erl b/lib/ssh/src/ssh_channel.erl index 85b31f3669..359e29fdbe 100644 --- a/lib/ssh/src/ssh_channel.erl +++ b/lib/ssh/src/ssh_channel.erl @@ -22,6 +22,7 @@ -module(ssh_channel). +-include("ssh.hrl"). -include("ssh_connect.hrl"). -callback init(Args :: term()) -> @@ -49,11 +50,11 @@ {ok, NewState :: term()} | {error, Reason :: term()}. -callback handle_msg(Msg ::term(), State :: term()) -> - {ok, State::term()} | {stop, ChannelId::integer(), State::term()}. + {ok, State::term()} | {stop, ChannelId::ssh:channel_id(), State::term()}. --callback handle_ssh_msg({ssh_cm, ConnectionRef::term(), SshMsg::term()}, +-callback handle_ssh_msg({ssh_cm, ConnectionRef::ssh:connection_ref(), SshMsg::term()}, State::term()) -> {ok, State::term()} | - {stop, ChannelId::integer(), + {stop, ChannelId::ssh:channel_id(), State::term()}. -behaviour(gen_server). @@ -71,6 +72,8 @@ cache_info/2, cache_find/2, get_print_info/1]). +-export([dbg_trace/3]). + -record(state, { cm, channel_cb, @@ -159,14 +162,7 @@ init([Options]) -> ConnectionManager = proplists:get_value(cm, Options), ChannelId = proplists:get_value(channel_id, Options), process_flag(trap_exit, true), - InitArgs = - case proplists:get_value(exec, Options) of - undefined -> - proplists:get_value(init_args, Options); - Exec -> - proplists:get_value(init_args, Options) ++ [Exec] - end, - try Cb:init(InitArgs) of + try Cb:init(channel_cb_init_args(Options)) of {ok, ChannelState} -> State = #state{cm = ConnectionManager, channel_cb = Cb, @@ -188,6 +184,14 @@ init([Options]) -> {stop, Reason} end. +channel_cb_init_args(Options) -> + case proplists:get_value(exec, Options) of + undefined -> + proplists:get_value(init_args, Options); + Exec -> + proplists:get_value(init_args, Options) ++ [Exec] + end. + %%-------------------------------------------------------------------- %% Function: %% handle_call(Request, From, State) -> {reply, Reply, State} | %% {reply, Reply, State, Timeout} | @@ -377,3 +381,76 @@ adjust_window(_) -> ok. +%%%################################################################ +%%%# +%%%# Tracing +%%%# + +dbg_trace(points, _, _) -> [terminate, channels, channel_events]; + + +dbg_trace(flags, channels, A) -> [c] ++ dbg_trace(flags, terminate, A); +dbg_trace(on, channels, A) -> dbg:tp(?MODULE, init, 1, x), + dbg_trace(on, terminate, A); +dbg_trace(off, channels, A) -> dbg:ctpg(?MODULE, init, 1), + dbg_trace(off, terminate, A); +dbg_trace(format, channels, {call, {?MODULE,init, [[KVs]]}}) -> + ["Server Channel Starting:\n", + io_lib:format("Connection: ~p, ChannelId: ~p, CallBack: ~p\nCallBack init args = ~p", + [proplists:get_value(K,KVs) || K <- [cm, channel_id, channel_cb]] + ++ [channel_cb_init_args(KVs)]) + ]; +dbg_trace(format, channels, {return_from, {?MODULE,init,1}, {stop,Reason}}) -> + ["Server Channel Start FAILED!\n", + io_lib:format("Reason = ~p", [Reason]) + ]; +dbg_trace(format, channels, F) -> + dbg_trace(format, terminate, F); + + +dbg_trace(flags, terminate, _) -> [c]; +dbg_trace(on, terminate, _) -> dbg:tp(?MODULE, terminate, 2, x); +dbg_trace(off, terminate, _) -> dbg:ctpg(?MODULE, terminate, 2); +dbg_trace(format, terminate, {call, {?MODULE,terminate, [Reason, State]}}) -> + ["Server Channel Terminating:\n", + io_lib:format("Reason: ~p,~nState:~n~s", [Reason, wr_record(State)]) + ]; + +dbg_trace(flags, channel_events, _) -> [c]; +dbg_trace(on, channel_events, _) -> dbg:tp(?MODULE, handle_call, 3, x), + dbg:tp(?MODULE, handle_cast, 2, x), + dbg:tp(?MODULE, handle_info, 2, x); +dbg_trace(off, channel_events, _) -> dbg:ctpg(?MODULE, handle_call, 3), + dbg:ctpg(?MODULE, handle_cast, 2), + dbg:ctpg(?MODULE, handle_info, 2); +dbg_trace(format, channel_events, {call, {?MODULE,handle_call, [Call,From,State]}}) -> + [hdr("is called", State), + io_lib:format("From: ~p~nCall: ~p~n", [From, Call]) + ]; +dbg_trace(format, channel_events, {return_from, {?MODULE,handle_call,3}, Ret}) -> + ["Server Channel call returned:\n", + io_lib:format("~p~n", [ssh_dbg:reduce_state(Ret)]) + ]; +dbg_trace(format, channel_events, {call, {?MODULE,handle_cast, [Cast,State]}}) -> + [hdr("got cast", State), + io_lib:format("Cast: ~p~n", [Cast]) + ]; +dbg_trace(format, channel_events, {return_from, {?MODULE,handle_cast,2}, Ret}) -> + ["Server Channel cast returned:\n", + io_lib:format("~p~n", [ssh_dbg:reduce_state(Ret)]) + ]; +dbg_trace(format, channel_events, {call, {?MODULE,handle_info, [Info,State]}}) -> + [hdr("got info", State), + io_lib:format("Info: ~p~n", [Info]) + ]; +dbg_trace(format, channel_events, {return_from, {?MODULE,handle_info,2}, Ret}) -> + ["Server Channel info returned:\n", + io_lib:format("~p~n", [ssh_dbg:reduce_state(Ret)]) + ]. + +hdr(Title, S) -> + io_lib:format("Server Channel (Id=~p, CB=~p) ~s:\n", [S#state.channel_id, S#state.channel_cb, Title]). + +?wr_record(state). + + diff --git a/lib/ssh/src/ssh_channel_sup.erl b/lib/ssh/src/ssh_channel_sup.erl index 8444533fd1..7a12f34049 100644 --- a/lib/ssh/src/ssh_channel_sup.erl +++ b/lib/ssh/src/ssh_channel_sup.erl @@ -50,8 +50,6 @@ start_child(Sup, Callback, Id, Args, Exec) -> %%%========================================================================= %%% Supervisor callback %%%========================================================================= --spec init( [term()] ) -> {ok,{supervisor:sup_flags(),[supervisor:child_spec()]}} | ignore . - init(_Args) -> RestartStrategy = one_for_one, MaxR = 10, diff --git a/lib/ssh/src/ssh_cli.erl b/lib/ssh/src/ssh_cli.erl index 958c342f5f..382de90ae1 100644 --- a/lib/ssh/src/ssh_cli.erl +++ b/lib/ssh/src/ssh_cli.erl @@ -33,6 +33,8 @@ %% ssh_channel callbacks -export([init/1, handle_ssh_msg/2, handle_msg/2, terminate/2]). +-export([dbg_trace/3]). + %% state -record(state, { cm, @@ -47,21 +49,6 @@ %%==================================================================== %% ssh_channel callbacks %%==================================================================== --spec init(Args :: term()) -> - {ok, State :: term()} | {ok, State :: term(), timeout() | hibernate} | - {stop, Reason :: term()} | ignore. - --spec terminate(Reason :: (normal | shutdown | {shutdown, term()} | - term()), - State :: term()) -> - term(). - --spec handle_msg(Msg ::term(), State :: term()) -> - {ok, State::term()} | {stop, ChannelId::integer(), State::term()}. --spec handle_ssh_msg({ssh_cm, ConnectionRef::term(), SshMsg::term()}, - State::term()) -> {ok, State::term()} | - {stop, ChannelId::integer(), - State::term()}. %%-------------------------------------------------------------------- %% Function: init(Args) -> {ok, State} @@ -118,42 +105,53 @@ handle_ssh_msg({ssh_cm, ConnectionHandler, write_chars(ConnectionHandler, ChannelId, Chars), {ok, State#state{pty = Pty, buf = NewBuf}}; -handle_ssh_msg({ssh_cm, ConnectionHandler, - {shell, ChannelId, WantReply}}, State) -> +handle_ssh_msg({ssh_cm, ConnectionHandler, {shell, ChannelId, WantReply}}, State) -> NewState = start_shell(ConnectionHandler, State), - ssh_connection:reply_request(ConnectionHandler, WantReply, - success, ChannelId), - {ok, NewState#state{channel = ChannelId, - cm = ConnectionHandler}}; - -handle_ssh_msg({ssh_cm, ConnectionHandler, - {exec, ChannelId, WantReply, Cmd}}, #state{exec=undefined, - shell=?DEFAULT_SHELL} = State) -> - {Reply, Status} = exec(Cmd), - write_chars(ConnectionHandler, - ChannelId, io_lib:format("~p\n", [Reply])), - ssh_connection:reply_request(ConnectionHandler, WantReply, - success, ChannelId), - ssh_connection:exit_status(ConnectionHandler, ChannelId, Status), - ssh_connection:send_eof(ConnectionHandler, ChannelId), - {stop, ChannelId, State#state{channel = ChannelId, cm = ConnectionHandler}}; - -handle_ssh_msg({ssh_cm, ConnectionHandler, - {exec, ChannelId, WantReply, _Cmd}}, #state{exec = undefined} = State) -> - write_chars(ConnectionHandler, ChannelId, 1, "Prohibited.\n"), ssh_connection:reply_request(ConnectionHandler, WantReply, success, ChannelId), - ssh_connection:exit_status(ConnectionHandler, ChannelId, 255), - ssh_connection:send_eof(ConnectionHandler, ChannelId), - {stop, ChannelId, State#state{channel = ChannelId, cm = ConnectionHandler}}; - -handle_ssh_msg({ssh_cm, ConnectionHandler, - {exec, ChannelId, WantReply, Cmd}}, State) -> - NewState = start_shell(ConnectionHandler, Cmd, State), - ssh_connection:reply_request(ConnectionHandler, WantReply, - success, ChannelId), {ok, NewState#state{channel = ChannelId, cm = ConnectionHandler}}; +handle_ssh_msg({ssh_cm, ConnectionHandler, {exec, ChannelId, WantReply, Cmd}}, S0) -> + case + case S0#state.exec of + {direct,F} -> + %% Exec called and a Fun or MFA is defined to use. The F returns the + %% value to return. + exec_direct(ConnectionHandler, F, Cmd); + + undefined when S0#state.shell == ?DEFAULT_SHELL -> + %% Exec called and the shell is the default shell (= Erlang shell). + %% To be exact, eval the term as an Erlang term (but not using the + %% ?DEFAULT_SHELL directly). This disables banner, prompts and such. + exec_in_erlang_default_shell(Cmd); + + undefined -> + %% Exec called, but the a shell other than the default shell is defined. + %% No new exec shell is defined, so don't execute! + %% We don't know if it is intended to use the new shell or not. + {"Prohibited.", 255, 1}; + + _ -> + %% Exec called and a Fun or MFA is defined to use. The F communicates via + %% standard io:write/read. + %% Kept for compatibility. + S1 = start_exec_shell(ConnectionHandler, Cmd, S0), + ssh_connection:reply_request(ConnectionHandler, WantReply, success, ChannelId), + {ok, S1} + end + of + {Reply, Status, Type} -> + write_chars(ConnectionHandler, ChannelId, Type, Reply), + ssh_connection:reply_request(ConnectionHandler, WantReply, success, ChannelId), + ssh_connection:exit_status(ConnectionHandler, ChannelId, Status), + ssh_connection:send_eof(ConnectionHandler, ChannelId), + {stop, ChannelId, S0#state{channel = ChannelId, cm = ConnectionHandler}}; + + {ok, S} -> + {ok, S#state{channel = ChannelId, + cm = ConnectionHandler}} + end; + handle_ssh_msg({ssh_cm, _ConnectionHandler, {eof, _ChannelId}}, State) -> {ok, State}; @@ -259,35 +257,7 @@ to_group(Data, Group) -> end, to_group(Tail, Group). -exec(Cmd) -> - case eval(parse(scan(Cmd))) of - {error, _} -> - {Cmd, 0}; %% This should be an external call - Term -> - Term - end. - -scan(Cmd) -> - erl_scan:string(Cmd). - -parse({ok, Tokens, _}) -> - erl_parse:parse_exprs(Tokens); -parse(Error) -> - Error. - -eval({ok, Expr_list}) -> - case (catch erl_eval:exprs(Expr_list, - erl_eval:new_bindings())) of - {value, Value, _NewBindings} -> - {Value, 0}; - {'EXIT', {Error, _}} -> - {Error, -1}; - Error -> - {Error, -1} - end; -eval(Error) -> - {Error, -1}. - +%%-------------------------------------------------------------------- %%% io_request, handle io requests from the user process, %%% Note, this is not the real I/O-protocol, but the mockup version %%% used between edlin and a user_driver. The protocol tags are @@ -506,53 +476,130 @@ bin_to_list(L) when is_list(L) -> bin_to_list(I) when is_integer(I) -> I. + +%%-------------------------------------------------------------------- start_shell(ConnectionHandler, State) -> - Shell = State#state.shell, - ConnectionInfo = ssh_connection_handler:connection_info(ConnectionHandler, - [peer, user]), - ShellFun = case is_function(Shell) of - true -> - 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), - fun() -> Shell(User, PeerAddr) end; - _ -> - Shell - end; - _ -> - Shell - end, - Echo = get_echo(State#state.pty), - Group = group:start(self(), ShellFun, [{echo, Echo}]), - State#state{group = Group, buf = empty_buf()}. - -start_shell(_ConnectionHandler, Cmd, #state{exec={M, F, A}} = State) -> - Group = group:start(self(), {M, F, A++[Cmd]}, [{echo, false}]), - State#state{group = Group, buf = empty_buf()}; -start_shell(ConnectionHandler, Cmd, #state{exec=Shell} = State) when is_function(Shell) -> - - ConnectionInfo = ssh_connection_handler:connection_info(ConnectionHandler, - [peer, user]), - User = proplists:get_value(user, ConnectionInfo), - ShellFun = - case erlang:fun_info(Shell, arity) of - {arity, 1} -> - fun() -> Shell(Cmd) end; - {arity, 2} -> - fun() -> Shell(Cmd, User) end; - {arity, 3} -> - {_, PeerAddr} = proplists:get_value(peer, ConnectionInfo), - fun() -> Shell(Cmd, User, PeerAddr) end; - _ -> - Shell - end, - Echo = get_echo(State#state.pty), - Group = group:start(self(), ShellFun, [{echo,Echo}]), - State#state{group = Group, buf = empty_buf()}. + ShellSpawner = + case State#state.shell of + Shell when is_function(Shell, 1) -> + [{user,User}] = ssh_connection_handler:connection_info(ConnectionHandler, [user]), + fun() -> Shell(User) end; + Shell when is_function(Shell, 2) -> + ConnectionInfo = + ssh_connection_handler:connection_info(ConnectionHandler, [peer, user]), + User = proplists:get_value(user, ConnectionInfo), + {_, PeerAddr} = proplists:get_value(peer, ConnectionInfo), + fun() -> Shell(User, PeerAddr) end; + {_,_,_} = Shell -> + Shell + end, + State#state{group = group:start(self(), ShellSpawner, [{echo, get_echo(State#state.pty)}]), + buf = empty_buf()}. + +%%-------------------------------------------------------------------- +start_exec_shell(ConnectionHandler, Cmd, State) -> + ExecShellSpawner = + case State#state.exec of + ExecShell when is_function(ExecShell, 1) -> + fun() -> ExecShell(Cmd) end; + ExecShell when is_function(ExecShell, 2) -> + [{user,User}] = ssh_connection_handler:connection_info(ConnectionHandler, [user]), + fun() -> ExecShell(Cmd, User) end; + ExecShell when is_function(ExecShell, 3) -> + ConnectionInfo = + ssh_connection_handler:connection_info(ConnectionHandler, [peer, user]), + User = proplists:get_value(user, ConnectionInfo), + {_, PeerAddr} = proplists:get_value(peer, ConnectionInfo), + fun() -> ExecShell(Cmd, User, PeerAddr) end; + {M,F,A} -> + {M, F, A++[Cmd]} + end, + State#state{group = group:start(self(), ExecShellSpawner, [{echo,false}]), + buf = empty_buf()}. + +%%-------------------------------------------------------------------- +exec_in_erlang_default_shell(Cmd) -> + case eval(parse(scan(Cmd))) of + {ok, Term} -> + {io_lib:format("~p\n", [Term]), 0, 0}; + {error, Error} when is_atom(Error) -> + {io_lib:format("Error in ~p: ~p\n", [Cmd,Error]), -1, 1}; + _ -> + {io_lib:format("Error: ~p\n", [Cmd]), -1, 1} + end. + +scan(Cmd) -> + erl_scan:string(Cmd). + +parse({ok, Tokens, _}) -> + erl_parse:parse_exprs(Tokens); +parse(Error) -> + Error. +eval({ok, Expr_list}) -> + case (catch erl_eval:exprs(Expr_list, + erl_eval:new_bindings())) of + {value, Value, _NewBindings} -> + {ok, Value}; + {'EXIT', {Error, _}} -> + {error, Error}; + {error, Error} -> + {error, Error}; + Error -> + {error, Error} + end; +eval({error,Error}) -> + {error, Error}; +eval(Error) -> + {error, Error}. + +%%-------------------------------------------------------------------- +exec_direct(ConnectionHandler, ExecSpec, Cmd) -> + try + case ExecSpec of + _ when is_function(ExecSpec, 1) -> + ExecSpec(Cmd); + _ when is_function(ExecSpec, 2) -> + [{user,User}] = ssh_connection_handler:connection_info(ConnectionHandler, [user]), + ExecSpec(Cmd, User); + _ when is_function(ExecSpec, 3) -> + ConnectionInfo = + ssh_connection_handler:connection_info(ConnectionHandler, [peer, user]), + User = proplists:get_value(user, ConnectionInfo), + {_, PeerAddr} = proplists:get_value(peer, ConnectionInfo), + ExecSpec(Cmd, User, PeerAddr) + end + of + Reply -> + return_direct_exec_reply(Reply, Cmd) + catch + C:Error -> + {io_lib:format("Error in \"~s\": ~p ~p~n", [Cmd,C,Error]), -1, 1} + end. + + + +return_direct_exec_reply(Reply, Cmd) -> + case fmt_exec_repl(Reply) of + {ok,S} -> + {S, 0, 0}; + {error,S} -> + {io_lib:format("Error in \"~s\": ~s~n", [Cmd,S]), -1, 1} + end. + +fmt_exec_repl({T,A}) when T==ok ; T==error -> + try + {T, io_lib:format("~s",[A])} + catch + error:badarg -> + {T, io_lib:format("~p", [A])}; + C:Err -> + {error, io_lib:format("~p:~p~n",[C,Err])} + end; +fmt_exec_repl(Other) -> + {error, io_lib:format("Bad exec-plugin return: ~p",[Other])}. + +%%-------------------------------------------------------------------- % Pty can be undefined if the client never sets any pty options before % starting the shell. get_echo(undefined) -> @@ -578,3 +625,19 @@ not_zero(0, B) -> not_zero(A, _) -> A. +%%%################################################################ +%%%# +%%%# Tracing +%%%# + +dbg_trace(points, _, _) -> [terminate]; + +dbg_trace(flags, terminate, _) -> [c]; +dbg_trace(on, terminate, _) -> dbg:tp(?MODULE, terminate, 2, x); +dbg_trace(off, terminate, _) -> dbg:ctpg(?MODULE, terminate, 2); +dbg_trace(format, terminate, {call, {?MODULE,terminate, [Reason, State]}}) -> + ["Cli Terminating:\n", + io_lib:format("Reason: ~p,~nState:~n~s", [Reason, wr_record(State)]) + ]. + +?wr_record(state). diff --git a/lib/ssh/src/ssh_client_key_api.erl b/lib/ssh/src/ssh_client_key_api.erl index 6e994ff292..d0d8ab25d6 100644 --- a/lib/ssh/src/ssh_client_key_api.erl +++ b/lib/ssh/src/ssh_client_key_api.erl @@ -23,26 +23,25 @@ -include_lib("public_key/include/public_key.hrl"). -include("ssh.hrl"). --export_type([algorithm/0]). - --type algorithm() :: 'ssh-rsa' - | 'ssh-dss' - | 'ecdsa-sha2-nistp256' - | 'ecdsa-sha2-nistp384' - | 'ecdsa-sha2-nistp521' - . - --callback is_host_key(PublicKey :: public_key:public_key(), - Host :: string(), - Algorithm :: algorithm(), - ConnectOptions :: proplists:proplist()) -> +-export_type([client_key_cb_options/0]). + +-type client_key_cb_options() :: [{key_cb_private,term()} | ssh:client_option()]. + +-callback is_host_key(Key :: public_key:public_key(), + Host :: string(), + Algorithm :: ssh:pubkey_alg(), + Options :: client_key_cb_options() + ) -> boolean(). --callback user_key(Algorithm :: algorithm(), - ConnectOptions :: proplists:proplist()) -> - {ok, PrivateKey::public_key:private_key()} | {error, term()}. +-callback user_key(Algorithm :: ssh:pubkey_alg(), + Options :: client_key_cb_options() + ) -> + {ok, PrivateKey :: public_key:private_key()} | {error, string()}. --callback add_host_key(Host :: string(), PublicKey :: public_key:public_key(), - Options :: proplists:proplist()) -> +-callback add_host_key(Host :: string(), + PublicKey :: public_key:public_key(), + Options :: client_key_cb_options() + ) -> ok | {error, Error::term()}. diff --git a/lib/ssh/src/ssh_connect.hrl b/lib/ssh/src/ssh_connect.hrl index a8de5f9a2f..3c61638285 100644 --- a/lib/ssh/src/ssh_connect.hrl +++ b/lib/ssh/src/ssh_connect.hrl @@ -22,10 +22,6 @@ %%% Description : SSH connection protocol --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 946ae2967b..2261d37d6a 100644 --- a/lib/ssh/src/ssh_connection.erl +++ b/lib/ssh/src/ssh_connection.erl @@ -40,40 +40,56 @@ -export([window_change/4, window_change/6, signal/3, exit_status/3]). -%% Internal application API --export([channel_data/5, handle_msg/3, channel_eof_msg/1, - channel_close_msg/1, channel_success_msg/1, channel_failure_msg/1, +%% Internal SSH application API +-export([channel_data/5, + handle_msg/3, + handle_stop/1, + + channel_adjust_window_msg/2, + channel_close_msg/1, + channel_open_failure_msg/4, + channel_open_msg/5, channel_status_msg/1, - channel_adjust_window_msg/2, channel_data_msg/3, - channel_open_msg/5, channel_open_confirmation_msg/4, - channel_open_failure_msg/4, channel_request_msg/4, + channel_data_msg/3, + channel_eof_msg/1, + channel_failure_msg/1, + channel_open_confirmation_msg/4, + channel_request_msg/4, + channel_success_msg/1, + request_failure_msg/0, - request_success_msg/1, bind/4, unbind/3, unbind_channel/2, - bound_channel/3, encode_ip/1]). + request_success_msg/1, + + bind/4, unbind/3, unbind_channel/2, + bound_channel/3, encode_ip/1 + ]). + +-type connection_ref() :: ssh:connection_ref(). +-type channel_id() :: ssh:channel_id(). %%-------------------------------------------------------------------- %%% API %%-------------------------------------------------------------------- %%-------------------------------------------------------------------- --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 %% application, a system command, or some built-in subsystem. %% -------------------------------------------------------------------- +-spec session_channel(connection_ref(), timeout()) -> + {ok, channel_id()} | {error, timeout | closed}. + session_channel(ConnectionHandler, Timeout) -> - session_channel(ConnectionHandler, - ?DEFAULT_WINDOW_SIZE, ?DEFAULT_PACKET_SIZE, - Timeout). + session_channel(ConnectionHandler, ?DEFAULT_WINDOW_SIZE, ?DEFAULT_PACKET_SIZE, Timeout). -session_channel(ConnectionHandler, InitialWindowSize, - MaxPacketSize, Timeout) -> +-spec session_channel(connection_ref(), integer(), integer(), timeout()) -> + {ok, channel_id()} | {error, timeout | closed}. + +session_channel(ConnectionHandler, InitialWindowSize, MaxPacketSize, Timeout) -> case ssh_connection_handler:open_channel(ConnectionHandler, "session", <<>>, - InitialWindowSize, - MaxPacketSize, Timeout) of + InitialWindowSize, + MaxPacketSize, Timeout) of {open, Channel} -> {ok, Channel}; Error -> @@ -81,55 +97,63 @@ session_channel(ConnectionHandler, InitialWindowSize, end. %%-------------------------------------------------------------------- --spec exec(connection_ref(), channel_id(), string(), timeout()) -> - success | failure | {error, timeout | closed}. - %% Description: Will request that the server start the %% execution of the given command. %%-------------------------------------------------------------------- +-spec exec(connection_ref(), channel_id(), string(), timeout()) -> + success | failure | {error, timeout | closed}. + exec(ConnectionHandler, ChannelId, Command, TimeOut) -> ssh_connection_handler:request(ConnectionHandler, self(), ChannelId, "exec", true, [?string(Command)], TimeOut). %%-------------------------------------------------------------------- --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 %% end. %%-------------------------------------------------------------------- +-spec shell(connection_ref(), channel_id()) -> + ok | success | failure | {error, timeout}. + shell(ConnectionHandler, ChannelId) -> ssh_connection_handler:request(ConnectionHandler, self(), ChannelId, "shell", false, <<>>, 0). %%-------------------------------------------------------------------- --spec subsystem(connection_ref(), channel_id(), string(), timeout()) -> - success | failure | {error, timeout | closed}. %% %% Description: Executes a predefined subsystem. %%-------------------------------------------------------------------- +-spec subsystem(connection_ref(), channel_id(), string(), timeout()) -> + success | failure | {error, timeout | closed}. + subsystem(ConnectionHandler, ChannelId, SubSystem, TimeOut) -> ssh_connection_handler:request(ConnectionHandler, self(), ChannelId, "subsystem", true, [?string(SubSystem)], TimeOut). %%-------------------------------------------------------------------- --spec send(connection_ref(), channel_id(), iodata()) -> - ok | {error, closed}. --spec send(connection_ref(), channel_id(), integer()| iodata(), timeout() | iodata()) -> - ok | {error, timeout} | {error, closed}. --spec send(connection_ref(), channel_id(), integer(), iodata(), timeout()) -> - ok | {error, timeout} | {error, closed}. -%% -%% %% Description: Sends channel data. %%-------------------------------------------------------------------- +-spec send(connection_ref(), channel_id(), iodata()) -> + ok | {error, timeout | closed}. send(ConnectionHandler, ChannelId, Data) -> send(ConnectionHandler, ChannelId, 0, Data, infinity). + + +-spec send(connection_ref(), channel_id(), integer()| iodata(), timeout() | iodata()) -> + ok | {error, timeout | closed}. + send(ConnectionHandler, ChannelId, Data, TimeOut) when is_integer(TimeOut) -> send(ConnectionHandler, ChannelId, 0, Data, TimeOut); + send(ConnectionHandler, ChannelId, Data, infinity) -> send(ConnectionHandler, ChannelId, 0, Data, infinity); + send(ConnectionHandler, ChannelId, Type, Data) -> send(ConnectionHandler, ChannelId, Type, Data, infinity). + + +-spec send(connection_ref(), channel_id(), integer(), iodata(), timeout()) -> + ok | {error, timeout | closed}. + send(ConnectionHandler, ChannelId, Type, Data, TimeOut) -> ssh_connection_handler:send(ConnectionHandler, ChannelId, Type, Data, TimeOut). @@ -143,7 +167,7 @@ send_eof(ConnectionHandler, Channel) -> ssh_connection_handler:send_eof(ConnectionHandler, Channel). %%-------------------------------------------------------------------- --spec adjust_window(connection_ref(), channel_id(), integer()) -> ok | {error, closed}. +-spec adjust_window(connection_ref(), channel_id(), integer()) -> ok. %% %% %% Description: Adjusts the ssh flowcontrol window. @@ -185,17 +209,18 @@ reply_request(_,false, _, _) -> ok. %%-------------------------------------------------------------------- --spec ptty_alloc(connection_ref(), channel_id(), proplists:proplist()) -> - success | failiure | {error, closed}. --spec ptty_alloc(connection_ref(), channel_id(), proplists:proplist(), timeout()) -> - success | failiure | {error, timeout} | {error, closed}. - -%% -%% %% Description: Sends a ssh connection protocol pty_req. %%-------------------------------------------------------------------- +-spec ptty_alloc(connection_ref(), channel_id(), proplists:proplist()) -> + success | failure | {error, timeout}. + ptty_alloc(ConnectionHandler, Channel, Options) -> ptty_alloc(ConnectionHandler, Channel, Options, infinity). + + +-spec ptty_alloc(connection_ref(), channel_id(), proplists:proplist(), timeout()) -> + success | failure | {error, timeout | closed}. + ptty_alloc(ConnectionHandler, Channel, Options0, TimeOut) -> TermData = backwards_compatible(Options0, []), % FIXME {Width, PixWidth} = pty_default_dimensions(width, TermData), @@ -232,27 +257,15 @@ exit_status(ConnectionHandler, Channel, Status) -> "exit-status", false, [?uint32(Status)], 0). %%-------------------------------------------------------------------- -%%% Internal API +%%% Internal, that is, ssh application internal API %%-------------------------------------------------------------------- -l2b(L) when is_integer(hd(L)) -> - try list_to_binary(L) - of - B -> B - catch - _:_ -> - unicode:characters_to_binary(L) - end; -l2b([H|T]) -> - << (l2b(H))/binary, (l2b(T))/binary >>; -l2b(B) when is_binary(B) -> - B; -l2b([]) -> - <<>>. - +%%%---------------------------------------------------------------- +%%% Send data on a channel/connection as result of for example +%%% ssh_connection:send (executed in the ssh_connection_state machine) +%%% -channel_data(ChannelId, DataType, Data, Connection, From) - when is_list(Data)-> +channel_data(ChannelId, DataType, Data, Connection, From) when is_list(Data)-> channel_data(ChannelId, DataType, l2b(Data), Connection, From); channel_data(ChannelId, DataType, Data, @@ -271,11 +284,18 @@ channel_data(ChannelId, DataType, Data, SendData)} end, SendList), FlowCtrlMsgs = flow_control(Replies, Channel, Cache), - {{replies, Replies ++ FlowCtrlMsgs}, Connection}; + {Replies ++ FlowCtrlMsgs, Connection}; _ -> - {{replies,[{channel_request_reply,From,{error,closed}}]}, Connection} + {[{channel_request_reply,From,{error,closed}}], Connection} end. +%%%---------------------------------------------------------------- +%%% Handle the channel messages on behalf of the ssh_connection_handler +%%% state machine. +%%% +%%% Replies {Reply, UpdatedConnection} +%%% + handle_msg(#ssh_msg_channel_open_confirmation{recipient_channel = ChannelId, sender_channel = RemoteId, initial_window_size = WindowSz, @@ -292,8 +312,7 @@ handle_msg(#ssh_msg_channel_open_confirmation{recipient_channel = ChannelId, ), send_window_size = WindowSz, send_packet_size = PacketSz}), - {Reply, Connection} = reply_msg(Channel, Connection0, {open, ChannelId}), - {{replies, [Reply]}, Connection}; + reply_msg(Channel, Connection0, {open, ChannelId}); handle_msg(#ssh_msg_channel_open_failure{recipient_channel = ChannelId, reason = Reason, @@ -302,36 +321,16 @@ handle_msg(#ssh_msg_channel_open_failure{recipient_channel = ChannelId, #connection{channel_cache = Cache} = Connection0, _) -> Channel = ssh_channel:cache_lookup(Cache, ChannelId), ssh_channel:cache_delete(Cache, ChannelId), - {Reply, Connection} = - reply_msg(Channel, Connection0, {open_error, Reason, Descr, Lang}), - {{replies, [Reply]}, Connection}; + reply_msg(Channel, Connection0, {open_error, Reason, Descr, Lang}); -handle_msg(#ssh_msg_channel_success{recipient_channel = ChannelId}, - #connection{channel_cache = Cache} = Connection0, _) -> - Channel = ssh_channel:cache_lookup(Cache, ChannelId), - case reply_msg(Channel, Connection0, success) of - {[], Connection} -> - {noreply, Connection}; - {Reply, Connection} -> - {{replies, [Reply]}, Connection} - end; - -handle_msg(#ssh_msg_channel_failure{recipient_channel = ChannelId}, - #connection{channel_cache = Cache} = Connection0, _) -> - Channel = ssh_channel:cache_lookup(Cache, ChannelId), - case reply_msg(Channel, Connection0, failure) of - {[], Connection} -> - {noreply, Connection}; - {Reply, Connection} -> - {{replies, [Reply]}, Connection} - end; +handle_msg(#ssh_msg_channel_success{recipient_channel = ChannelId}, Connection, _) -> + reply_msg(ChannelId, Connection, success); +handle_msg(#ssh_msg_channel_failure{recipient_channel = ChannelId}, Connection, _) -> + reply_msg(ChannelId, Connection, failure); -handle_msg(#ssh_msg_channel_eof{recipient_channel = ChannelId}, - #connection{channel_cache = Cache} = Connection0, _) -> - Channel = ssh_channel:cache_lookup(Cache, ChannelId), - {Reply, Connection} = reply_msg(Channel, Connection0, {eof, ChannelId}), - {{replies, [Reply]}, Connection}; +handle_msg(#ssh_msg_channel_eof{recipient_channel = ChannelId}, Connection, _) -> + reply_msg(ChannelId, Connection, {eof, ChannelId}); handle_msg(#ssh_msg_channel_close{recipient_channel = ChannelId}, #connection{channel_cache = Cache} = Connection0, _) -> @@ -358,42 +357,23 @@ handle_msg(#ssh_msg_channel_close{recipient_channel = ChannelId}, [{flow_control, From, {error, closed}}] end, - Replies = ConnReplyMsgs ++ [CloseMsg] ++ SendReplyMsgs, - {{replies, Replies}, Connection}; + Replies = ConnReplyMsgs ++ CloseMsg ++ SendReplyMsgs, + {Replies, Connection}; undefined -> - {{replies, []}, Connection0} + {[], Connection0} end; handle_msg(#ssh_msg_channel_data{recipient_channel = ChannelId, data = Data}, - #connection{channel_cache = Cache} = Connection0, _) -> - - case ssh_channel:cache_lookup(Cache, ChannelId) of - #channel{recv_window_size = Size} = Channel -> - WantedSize = Size - size(Data), - ssh_channel:cache_update(Cache, Channel#channel{ - recv_window_size = WantedSize}), - {Replies, Connection} = - channel_data_reply(Cache, Channel, Connection0, 0, Data), - {{replies, Replies}, Connection}; - undefined -> - {noreply, Connection0} - end; + Connection, _) -> + channel_data_reply_msg(ChannelId, Connection, 0, Data); handle_msg(#ssh_msg_channel_extended_data{recipient_channel = ChannelId, data_type_code = DataType, data = Data}, - #connection{channel_cache = Cache} = Connection0, _) -> - - #channel{recv_window_size = Size} = Channel = - ssh_channel:cache_lookup(Cache, ChannelId), - WantedSize = Size - size(Data), - ssh_channel:cache_update(Cache, Channel#channel{ - recv_window_size = WantedSize}), - {Replies, Connection} = - channel_data_reply(Cache, Channel, Connection0, DataType, Data), - {{replies, Replies}, Connection}; + Connection, _) -> + channel_data_reply_msg(ChannelId, Connection, DataType, Data); handle_msg(#ssh_msg_channel_window_adjust{recipient_channel = ChannelId, bytes_to_add = Add}, @@ -409,7 +389,7 @@ handle_msg(#ssh_msg_channel_window_adjust{recipient_channel = ChannelId, {connection_reply, channel_data_msg(RemoteId, Type, Data)} end, SendList), FlowCtrlMsgs = flow_control(Channel, Cache), - {{replies, Replies ++ FlowCtrlMsgs}, Connection}; + {Replies ++ FlowCtrlMsgs, Connection}; handle_msg(#ssh_msg_channel_open{channel_type = "session" = Type, sender_channel = RemoteId, @@ -430,8 +410,7 @@ handle_msg(#ssh_msg_channel_open{channel_type = "session" = Type, FailMsg = channel_open_failure_msg(RemoteId, ?SSH_OPEN_CONNECT_FAILED, "Connection refused", "en"), - {{replies, [{connection_reply, FailMsg}]}, - Connection0} + {[{connection_reply, FailMsg}], Connection0} end; MinAcceptedPackSz > PacketSz -> @@ -439,7 +418,7 @@ handle_msg(#ssh_msg_channel_open{channel_type = "session" = Type, ?SSH_OPEN_ADMINISTRATIVELY_PROHIBITED, lists:concat(["Maximum packet size below ",MinAcceptedPackSz, " not supported"]), "en"), - {{replies, [{connection_reply, FailMsg}]}, Connection0} + {[{connection_reply, FailMsg}], Connection0} end; handle_msg(#ssh_msg_channel_open{channel_type = "session", @@ -452,34 +431,30 @@ handle_msg(#ssh_msg_channel_open{channel_type = "session", FailMsg = channel_open_failure_msg(RemoteId, ?SSH_OPEN_CONNECT_FAILED, "Connection refused", "en"), - {{replies, [{connection_reply, FailMsg}]}, - Connection}; + {[{connection_reply, FailMsg}], Connection}; handle_msg(#ssh_msg_channel_open{sender_channel = RemoteId}, Connection, _) -> FailMsg = channel_open_failure_msg(RemoteId, ?SSH_OPEN_ADMINISTRATIVELY_PROHIBITED, "Not allowed", "en"), - {{replies, [{connection_reply, FailMsg}]}, Connection}; + {[{connection_reply, FailMsg}], Connection}; handle_msg(#ssh_msg_channel_request{recipient_channel = ChannelId, request_type = "exit-status", data = Data}, - #connection{channel_cache = Cache} = Connection, _) -> + Connection, _) -> <<?UINT32(Status)>> = Data, - Channel = ssh_channel:cache_lookup(Cache, ChannelId), - {Reply, Connection} = - reply_msg(Channel, Connection, {exit_status, ChannelId, Status}), - {{replies, [Reply]}, Connection}; + reply_msg(ChannelId, Connection, {exit_status, ChannelId, Status}); handle_msg(#ssh_msg_channel_request{recipient_channel = ChannelId, request_type = "exit-signal", want_reply = false, data = Data}, - #connection{channel_cache = Cache} = Connection0, _) -> - <<?UINT32(SigLen), SigName:SigLen/binary, - ?BOOLEAN(_Core), - ?UINT32(ErrLen), Err:ErrLen/binary, - ?UINT32(LangLen), Lang:LangLen/binary>> = Data, + #connection{channel_cache = Cache} = Connection0, _) -> + <<?DEC_BIN(SigName, _SigLen), + ?BOOLEAN(_Core), + ?DEC_BIN(Err, _ErrLen), + ?DEC_BIN(Lang, _LangLen)>> = Data, Channel = ssh_channel:cache_lookup(Cache, ChannelId), RemoteId = Channel#channel.remote_id, {Reply, Connection} = reply_msg(Channel, Connection0, @@ -488,52 +463,41 @@ handle_msg(#ssh_msg_channel_request{recipient_channel = ChannelId, binary_to_list(Err), binary_to_list(Lang)}), CloseMsg = channel_close_msg(RemoteId), - {{replies, [{connection_reply, CloseMsg}, Reply]}, - Connection}; + {[{connection_reply, CloseMsg}|Reply], Connection}; handle_msg(#ssh_msg_channel_request{recipient_channel = ChannelId, request_type = "xon-xoff", want_reply = false, data = Data}, - #connection{channel_cache = Cache} = Connection, _) -> + Connection, _) -> <<?BOOLEAN(CDo)>> = Data, - Channel = ssh_channel:cache_lookup(Cache, ChannelId), - {Reply, Connection} = - reply_msg(Channel, Connection, {xon_xoff, ChannelId, CDo=/= 0}), - {{replies, [Reply]}, Connection}; + reply_msg(ChannelId, Connection, {xon_xoff, ChannelId, CDo=/= 0}); handle_msg(#ssh_msg_channel_request{recipient_channel = ChannelId, request_type = "window-change", want_reply = false, data = Data}, - #connection{channel_cache = Cache} = Connection0, _) -> + Connection0, _) -> <<?UINT32(Width),?UINT32(Height), - ?UINT32(PixWidth), ?UINT32(PixHeight)>> = Data, - Channel = ssh_channel:cache_lookup(Cache, ChannelId), - {Reply, Connection} = - reply_msg(Channel, Connection0, {window_change, ChannelId, - Width, Height, - PixWidth, PixHeight}), - {{replies, [Reply]}, Connection}; + ?UINT32(PixWidth), ?UINT32(PixHeight)>> = Data, + reply_msg(ChannelId, Connection0, {window_change, ChannelId, + Width, Height, + PixWidth, PixHeight}); handle_msg(#ssh_msg_channel_request{recipient_channel = ChannelId, request_type = "signal", data = Data}, - #connection{channel_cache = Cache} = Connection0, _) -> - <<?UINT32(SigLen), SigName:SigLen/binary>> = Data, - - Channel = ssh_channel:cache_lookup(Cache, ChannelId), - {Reply, Connection} = - reply_msg(Channel, Connection0, {signal, ChannelId, - binary_to_list(SigName)}), - {{replies, [Reply]}, Connection}; + Connection0, _) -> + <<?DEC_BIN(SigName, _SigLen)>> = Data, + reply_msg(ChannelId, Connection0, {signal, ChannelId, + binary_to_list(SigName)}); handle_msg(#ssh_msg_channel_request{recipient_channel = ChannelId, request_type = "subsystem", want_reply = WantReply, data = Data}, #connection{channel_cache = Cache} = Connection, server) -> - <<?UINT32(SsLen), SsName:SsLen/binary>> = Data, + <<?DEC_BIN(SsName,_SsLen)>> = Data, #channel{remote_id = RemoteId} = Channel0 = ssh_channel:cache_lookup(Cache, ChannelId), @@ -547,92 +511,77 @@ handle_msg(#ssh_msg_channel_request{recipient_channel = ChannelId, ssh_channel:cache_update(Cache, Channel), Reply = {connection_reply, channel_success_msg(RemoteId)}, - {{replies, [Reply]}, Connection} + {[Reply], Connection} catch _:_ -> - ErrorReply = {connection_reply, - channel_failure_msg(RemoteId)}, - {{replies, [ErrorReply]}, Connection} + ErrorReply = {connection_reply, channel_failure_msg(RemoteId)}, + {[ErrorReply], Connection} end; handle_msg(#ssh_msg_channel_request{request_type = "subsystem"}, Connection, client) -> %% The client SHOULD ignore subsystem requests. See RFC 4254 6.5. - {{replies, []}, Connection}; + {[], Connection}; handle_msg(#ssh_msg_channel_request{recipient_channel = ChannelId, request_type = "pty-req", want_reply = WantReply, data = Data}, - #connection{channel_cache = Cache} = Connection, server) -> - <<?UINT32(TermLen), BTermName:TermLen/binary, - ?UINT32(Width),?UINT32(Height), - ?UINT32(PixWidth), ?UINT32(PixHeight), - Modes/binary>> = Data, + Connection, server) -> + <<?DEC_BIN(BTermName,_TermLen), + ?UINT32(Width),?UINT32(Height), + ?UINT32(PixWidth), ?UINT32(PixHeight), + Modes/binary>> = Data, TermName = binary_to_list(BTermName), - PtyRequest = {TermName, Width, Height, PixWidth, PixHeight, decode_pty_opts(Modes)}, - - Channel = ssh_channel:cache_lookup(Cache, ChannelId), - handle_cli_msg(Connection, Channel, + handle_cli_msg(Connection, ChannelId, {pty, ChannelId, WantReply, PtyRequest}); handle_msg(#ssh_msg_channel_request{request_type = "pty-req"}, Connection, client) -> %% The client SHOULD ignore pty requests. See RFC 4254 6.2. - {{replies, []}, Connection}; + {[], Connection}; handle_msg(#ssh_msg_channel_request{recipient_channel = ChannelId, request_type = "shell", want_reply = WantReply}, - #connection{channel_cache = Cache} = Connection, server) -> - - Channel = ssh_channel:cache_lookup(Cache, ChannelId), - - handle_cli_msg(Connection, Channel, + Connection, server) -> + handle_cli_msg(Connection, ChannelId, {shell, ChannelId, WantReply}); handle_msg(#ssh_msg_channel_request{request_type = "shell"}, Connection, client) -> %% The client SHOULD ignore shell requests. See RFC 4254 6.5. - {{replies, []}, Connection}; + {[], Connection}; handle_msg(#ssh_msg_channel_request{recipient_channel = ChannelId, request_type = "exec", want_reply = WantReply, data = Data}, - #connection{channel_cache = Cache} = Connection, server) -> - <<?UINT32(Len), Command:Len/binary>> = Data, - - Channel = ssh_channel:cache_lookup(Cache, ChannelId), - - handle_cli_msg(Connection, Channel, + Connection, server) -> + <<?DEC_BIN(Command, _Len)>> = Data, + handle_cli_msg(Connection, ChannelId, {exec, ChannelId, WantReply, binary_to_list(Command)}); handle_msg(#ssh_msg_channel_request{request_type = "exec"}, Connection, client) -> %% The client SHOULD ignore exec requests. See RFC 4254 6.5. - {{replies, []}, Connection}; + {[], Connection}; handle_msg(#ssh_msg_channel_request{recipient_channel = ChannelId, request_type = "env", want_reply = WantReply, data = Data}, - #connection{channel_cache = Cache} = Connection, server) -> - - <<?UINT32(VarLen), - Var:VarLen/binary, ?UINT32(ValueLen), Value:ValueLen/binary>> = Data, - - Channel = ssh_channel:cache_lookup(Cache, ChannelId), - - handle_cli_msg(Connection, Channel, + Connection, server) -> + <<?DEC_BIN(Var,_VarLen), ?DEC_BIN(Value,_ValLen)>> = Data, + handle_cli_msg(Connection, ChannelId, {env, ChannelId, WantReply, Var, Value}); handle_msg(#ssh_msg_channel_request{request_type = "env"}, Connection, client) -> %% The client SHOULD ignore env requests. - {{replies, []}, Connection}; + {[], Connection}; handle_msg(#ssh_msg_channel_request{recipient_channel = ChannelId, request_type = _Other, @@ -642,13 +591,12 @@ handle_msg(#ssh_msg_channel_request{recipient_channel = ChannelId, case ssh_channel:cache_lookup(Cache, ChannelId) of #channel{remote_id = RemoteId} -> FailMsg = channel_failure_msg(RemoteId), - {{replies, [{connection_reply, FailMsg}]}, - Connection}; + {[{connection_reply, FailMsg}], Connection}; undefined -> %% Chanel has been closed - {noreply, Connection} + {[], Connection} end; true -> - {noreply, Connection} + {[], Connection} end; handle_msg(#ssh_msg_global_request{name = _Type, @@ -656,79 +604,54 @@ handle_msg(#ssh_msg_global_request{name = _Type, data = _Data}, Connection, _) -> if WantReply == true -> FailMsg = request_failure_msg(), - {{replies, [{connection_reply, FailMsg}]}, - Connection}; + {[{connection_reply, FailMsg}], Connection}; true -> - {noreply, Connection} + {[], Connection} end; handle_msg(#ssh_msg_request_failure{}, #connection{requests = [{_, From} | Rest]} = Connection, _) -> - {{replies, [{channel_request_reply, From, {failure, <<>>}}]}, + {[{channel_request_reply, From, {failure, <<>>}}], Connection#connection{requests = Rest}}; + handle_msg(#ssh_msg_request_success{data = Data}, #connection{requests = [{_, From} | Rest]} = Connection, _) -> - {{replies, [{channel_request_reply, From, {success, Data}}]}, + {[{channel_request_reply, From, {success, Data}}], Connection#connection{requests = Rest}}; handle_msg(#ssh_msg_disconnect{code = Code, - description = Description, - language = _Lang }, - #connection{channel_cache = Cache} = Connection0, _) -> - {Connection, Replies} = - ssh_channel:cache_foldl(fun(Channel, {Connection1, Acc}) -> - {Reply, Connection2} = - reply_msg(Channel, - Connection1, - {closed, Channel#channel.local_id}), - {Connection2, [Reply | Acc]} - end, {Connection0, []}, Cache), - - ssh_channel:cache_delete(Cache), - {disconnect, {Code, Description}, {{replies, Replies}, Connection}}. - -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), - Channel = Channel0#channel{user = Pid}, - ssh_channel:cache_update(Cache, Channel), - {Reply, Connection1} = reply_msg(Channel, Connection, Reply0), - {{replies, [Reply]}, Connection1}; - _Other -> - Reply = {connection_reply, - channel_failure_msg(RemoteId)}, - {{replies, [Reply]}, Connection} - end; - -handle_cli_msg(Connection0, Channel, Reply0) -> - {Reply, Connection} = reply_msg(Channel, Connection0, Reply0), - {{replies, [Reply]}, Connection}. - -channel_eof_msg(ChannelId) -> - #ssh_msg_channel_eof{recipient_channel = ChannelId}. - -channel_close_msg(ChannelId) -> - #ssh_msg_channel_close {recipient_channel = ChannelId}. - -channel_status_msg({success, ChannelId}) -> - channel_success_msg(ChannelId); -channel_status_msg({failure, ChannelId}) -> - channel_failure_msg(ChannelId). + description = Description}, + Connection, _) -> + {disconnect, {Code, Description}, handle_stop(Connection)}. -channel_success_msg(ChannelId) -> - #ssh_msg_channel_success{recipient_channel = ChannelId}. -channel_failure_msg(ChannelId) -> - #ssh_msg_channel_failure{recipient_channel = ChannelId}. +%%%---------------------------------------------------------------- +%%% Returns pending responses to be delivered to the peer when a +%%% Channel/Connection closes +%%% +handle_stop(#connection{channel_cache = Cache} = Connection0) -> + {Connection, Replies} = + ssh_channel:cache_foldl( + fun(Channel, {Connection1, Acc}) -> + {Reply, Connection2} = + reply_msg(Channel, Connection1, + {closed, Channel#channel.local_id}), + {Connection2, Reply ++ Acc} + end, {Connection0, []}, Cache), + ssh_channel:cache_delete(Cache), + {Replies, Connection}. +%%%---------------------------------------------------------------- +%%% channel_*_msg(...) +%%% Returns a #ssh_msg_....{} for channel operations. +%%% channel_adjust_window_msg(ChannelId, Bytes) -> #ssh_msg_channel_window_adjust{recipient_channel = ChannelId, bytes_to_add = Bytes}. +channel_close_msg(ChannelId) -> + #ssh_msg_channel_close {recipient_channel = ChannelId}. + channel_data_msg(ChannelId, 0, Data) -> #ssh_msg_channel_data{recipient_channel = ChannelId, data = Data}; @@ -737,6 +660,12 @@ channel_data_msg(ChannelId, Type, Data) -> data_type_code = Type, data = Data}. +channel_eof_msg(ChannelId) -> + #ssh_msg_channel_eof{recipient_channel = ChannelId}. + +channel_failure_msg(ChannelId) -> + #ssh_msg_channel_failure{recipient_channel = ChannelId}. + channel_open_msg(Type, ChannelId, WindowSize, MaxPacketSize, Data) -> #ssh_msg_channel_open{channel_type = Type, sender_channel = ChannelId, @@ -757,18 +686,34 @@ channel_open_failure_msg(RemoteId, Reason, Description, Lang) -> description = Description, lang = Lang}. +channel_status_msg({success, ChannelId}) -> + channel_success_msg(ChannelId); + +channel_status_msg({failure, ChannelId}) -> + channel_failure_msg(ChannelId). + channel_request_msg(ChannelId, Type, WantReply, Data) -> #ssh_msg_channel_request{recipient_channel = ChannelId, request_type = Type, want_reply = WantReply, data = Data}. +channel_success_msg(ChannelId) -> + #ssh_msg_channel_success{recipient_channel = ChannelId}. + +%%%---------------------------------------------------------------- +%%% request_*_msg(...) +%%% Returns a #ssh_msg_....{} for request responses. +%%% request_failure_msg() -> #ssh_msg_request_failure{}. request_success_msg(Data) -> #ssh_msg_request_success{data = Data}. +%%%---------------------------------------------------------------- +%%% +%%% bind(IP, Port, ChannelPid, Connection) -> Binds = [{{IP, Port}, ChannelPid} | lists:keydelete({IP, Port}, 1, @@ -808,6 +753,68 @@ encode_ip(Addr) when is_list(Addr) -> end end. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% +%%% Internal functions +%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%%---------------------------------------------------------------- +%%% Create the channel data when an ssh_msg_open_channel message +%%% of "session" typ is handled +%%% +setup_session(#connection{channel_cache = Cache, + channel_id_seed = NewChannelID + } = C, + RemoteId, Type, WindowSize, PacketSize) -> + NextChannelID = NewChannelID + 1, + Channel = + #channel{type = Type, + sys = "ssh", + local_id = NewChannelID, + recv_window_size = ?DEFAULT_WINDOW_SIZE, + recv_packet_size = ?DEFAULT_PACKET_SIZE, + send_window_size = WindowSize, + send_packet_size = PacketSize, + send_buf = queue:new(), + remote_id = RemoteId + }, + ssh_channel:cache_update(Cache, Channel), + OpenConfMsg = channel_open_confirmation_msg(RemoteId, NewChannelID, + ?DEFAULT_WINDOW_SIZE, + ?DEFAULT_PACKET_SIZE), + Reply = {connection_reply, OpenConfMsg}, + {[Reply], C#connection{channel_id_seed = NextChannelID}}. + + +%%%---------------------------------------------------------------- +%%% Start a cli or subsystem +%%% +start_cli(#connection{options = Options, + cli_spec = CliSpec, + exec = Exec, + sub_system_supervisor = SubSysSup}, ChannelId) -> + case CliSpec of + no_cli -> + {error, cli_disabled}; + {CbModule, Args} -> + start_channel(CbModule, ChannelId, Args, SubSysSup, Exec, Options) + end. + + +start_subsystem(BinName, #connection{options = Options, + sub_system_supervisor = SubSysSup}, + #channel{local_id = ChannelId}, _ReplyMsg) -> + Name = binary_to_list(BinName), + case check_subsystem(Name, Options) of + {Callback, Opts} when is_atom(Callback), Callback =/= none -> + start_channel(Callback, ChannelId, Opts, SubSysSup, Options); + {Other, _} when Other =/= none -> + {error, legacy_option_not_supported} + end. + + +%%% Helpers for starting cli/subsystems start_channel(Cb, Id, Args, SubSysSup, Opts) -> start_channel(Cb, Id, Args, SubSysSup, undefined, Opts). @@ -827,33 +834,6 @@ max_num_channels_not_exceeded(ChannelSup, Opts) -> %% Note that NumChannels is BEFORE starting a new one NumChannels < MaxNumChannels. -%%-------------------------------------------------------------------- -%%% Internal functions -%%-------------------------------------------------------------------- -setup_session(#connection{channel_cache = Cache - } = Connection0, - RemoteId, - Type, WindowSize, PacketSize) -> - {ChannelId, Connection} = new_channel_id(Connection0), - - Channel = #channel{type = Type, - sys = "ssh", - local_id = ChannelId, - recv_window_size = ?DEFAULT_WINDOW_SIZE, - recv_packet_size = ?DEFAULT_PACKET_SIZE, - send_window_size = WindowSize, - send_packet_size = PacketSize, - send_buf = queue:new(), - remote_id = RemoteId - }, - ssh_channel:cache_update(Cache, Channel), - OpenConfMsg = channel_open_confirmation_msg(RemoteId, ChannelId, - ?DEFAULT_WINDOW_SIZE, - ?DEFAULT_PACKET_SIZE), - - {{replies, [{connection_reply, OpenConfMsg}]}, Connection}. - - check_subsystem("sftp"= SsName, Options) -> case ?GET_OPT(subsystems, Options) of no_subsys -> % FIXME: Can 'no_subsys' ever be matched? @@ -872,64 +852,10 @@ check_subsystem(SsName, Options) -> Value end. -start_cli(#connection{cli_spec = no_cli}, _) -> - {error, cli_disabled}; -start_cli(#connection{options = Options, - cli_spec = {CbModule, Args}, - exec = Exec, - sub_system_supervisor = SubSysSup}, ChannelId) -> - start_channel(CbModule, ChannelId, Args, SubSysSup, Exec, Options). - -start_subsystem(BinName, #connection{options = Options, - sub_system_supervisor = SubSysSup}, - #channel{local_id = ChannelId}, _ReplyMsg) -> - Name = binary_to_list(BinName), - case check_subsystem(Name, Options) of - {Callback, Opts} when is_atom(Callback), Callback =/= none -> - start_channel(Callback, ChannelId, Opts, SubSysSup, Options); - {Other, _} when Other =/= none -> - {error, legacy_option_not_supported} - end. - -channel_data_reply(_, #channel{local_id = ChannelId} = Channel, - Connection0, DataType, Data) -> - {Reply, Connection} = - reply_msg(Channel, Connection0, {data, ChannelId, DataType, Data}), - {[Reply], Connection}. - -new_channel_id(Connection) -> - ID = Connection#connection.channel_id_seed, - {ID, Connection#connection{channel_id_seed = ID + 1}}. - -reply_msg(Channel, Connection, {open, _} = Reply) -> - request_reply_or_data(Channel, Connection, Reply); -reply_msg(Channel, Connection, {open_error, _, _, _} = Reply) -> - request_reply_or_data(Channel, Connection, Reply); -reply_msg(Channel, Connection, success = Reply) -> - request_reply_or_data(Channel, Connection, Reply); -reply_msg(Channel, Connection, failure = Reply) -> - request_reply_or_data(Channel, Connection, Reply); -reply_msg(Channel, Connection, {closed, _} = Reply) -> - request_reply_or_data(Channel, Connection, Reply); -reply_msg(undefined, Connection, _Reply) -> - {noreply, Connection}; -reply_msg(#channel{user = ChannelPid}, Connection, Reply) -> - {{channel_data, ChannelPid, Reply}, Connection}. - - -request_reply_or_data(#channel{local_id = ChannelId, user = ChannelPid}, - #connection{requests = Requests} = - Connection, Reply) -> - case lists:keysearch(ChannelId, 1, Requests) of - {value, {ChannelId, From}} -> - {{channel_request_reply, From, Reply}, - Connection#connection{requests = - lists:keydelete(ChannelId, 1, Requests)}}; - false when (Reply == success) or (Reply == failure) -> - {[], Connection}; - false -> - {{channel_data, ChannelPid, Reply}, Connection} - end. +%%%---------------------------------------------------------------- +%%% +%%% Send-window handling +%%% update_send_window(Channel, _, undefined, #connection{channel_cache = Cache}) -> @@ -984,6 +910,11 @@ handle_send_window({Type, Data}, _, PacketSize, WindowSize, Acc) -> <<Msg1:PacketSize/binary, Msg2/binary>> = Data, {WindowSize - PacketSize, [{Type, Msg1} | Acc], {Type, Msg2}}. +%%%---------------------------------------------------------------- +%%% +%%% Flow control +%%% + flow_control(Channel, Cache) -> flow_control([window_adjusted], Channel, Cache). @@ -1002,6 +933,11 @@ flow_control([_|_], #channel{flow_control = From, flow_control(_,_,_) -> []. +%%%---------------------------------------------------------------- +%%% +%%% Pseudo terminal stuff +%%% + pty_req(ConnectionHandler, Channel, Term, Width, Height, PixWidth, PixHeight, PtyOpts, TimeOut) -> ssh_connection_handler:request(ConnectionHandler, @@ -1027,8 +963,7 @@ pty_default_dimensions(Dimension, TermData) -> encode_pty_opts(Opts) -> Bin = list_to_binary(encode_pty_opts2(Opts)), - Len = size(Bin), - <<?UINT32(Len), Bin/binary>>. + <<?STRING(Bin)>>. encode_pty_opts2([]) -> [?TTY_OP_END]; @@ -1147,7 +1082,7 @@ decode_pty_opts(<<>>) -> []; decode_pty_opts(<<0, 0, 0, 0>>) -> []; -decode_pty_opts(<<?UINT32(Len), Modes:Len/binary>>) -> +decode_pty_opts(<<?DEC_BIN(Modes,_Len)>>) -> decode_pty_opts2(Modes); decode_pty_opts(Binary) -> decode_pty_opts2(Binary). @@ -1224,3 +1159,104 @@ backwards_compatible([{pixel_hight, Value} | Rest], Acc) -> backwards_compatible(Rest, [{height, Value} | Acc]); backwards_compatible([Value| Rest], Acc) -> backwards_compatible(Rest, [ Value | Acc]). + + +%%%---------------------------------------------------------------- +%%% +%%% Common part of handling channel messages meant for a cli (like "env", "exec" etc) +%%% Called at the finnish of handle_msg(#ssh_msg_channel_request,...) +%%% + +handle_cli_msg(C0, ChId, Reply0) -> + Cache = C0#connection.channel_cache, + Ch0 = ssh_channel:cache_lookup(Cache, ChId), + case Ch0#channel.user of + undefined -> + case (catch start_cli(C0, ChId)) of + {ok, Pid} -> + erlang:monitor(process, Pid), + Ch = Ch0#channel{user = Pid}, + ssh_channel:cache_update(Cache, Ch), + reply_msg(Ch, C0, Reply0); + _Other -> + Reply = {connection_reply, channel_failure_msg(Ch0#channel.remote_id)}, + {[Reply], C0} + end; + + _ -> + reply_msg(Ch0, C0, Reply0) + end. + +%%%---------------------------------------------------------------- +%%% +%%% Request response handling on return to the calling ssh_connection_handler +%%% state machine. +%%% + +channel_data_reply_msg(ChannelId, Connection, DataType, Data) -> + case ssh_channel:cache_lookup(Connection#connection.channel_cache, ChannelId) of + #channel{recv_window_size = Size} = Channel -> + WantedSize = Size - size(Data), + ssh_channel:cache_update(Connection#connection.channel_cache, + Channel#channel{recv_window_size = WantedSize}), + reply_msg(Channel, Connection, {data, ChannelId, DataType, Data}); + undefined -> + {[], Connection} + end. + + +reply_msg(ChId, C, Reply) when is_integer(ChId) -> + reply_msg(ssh_channel:cache_lookup(C#connection.channel_cache, ChId), C, Reply); + +reply_msg(Channel, Connection, {open, _} = Reply) -> + request_reply_or_data(Channel, Connection, Reply); +reply_msg(Channel, Connection, {open_error, _, _, _} = Reply) -> + request_reply_or_data(Channel, Connection, Reply); +reply_msg(Channel, Connection, success = Reply) -> + request_reply_or_data(Channel, Connection, Reply); +reply_msg(Channel, Connection, failure = Reply) -> + request_reply_or_data(Channel, Connection, Reply); +reply_msg(Channel, Connection, {closed, _} = Reply) -> + request_reply_or_data(Channel, Connection, Reply); +reply_msg(undefined, Connection, _Reply) -> + {[], Connection}; +reply_msg(#channel{user = ChannelPid}, Connection, Reply) -> + {[{channel_data, ChannelPid, Reply}], Connection}. + + +request_reply_or_data(#channel{local_id = ChannelId, user = ChannelPid}, + #connection{requests = Requests} = + Connection, Reply) -> + case lists:keysearch(ChannelId, 1, Requests) of + {value, {ChannelId, From}} -> + {[{channel_request_reply, From, Reply}], + Connection#connection{requests = + lists:keydelete(ChannelId, 1, Requests)}}; + false when (Reply == success) or (Reply == failure) -> + {[], Connection}; + false -> + {[{channel_data, ChannelPid, Reply}], Connection} + end. + + + +%%%---------------------------------------------------------------- +%%% l(ist)2b(inary) +%%% +l2b(L) when is_integer(hd(L)) -> + try list_to_binary(L) + of + B -> B + catch + _:_ -> + unicode:characters_to_binary(L) + end; +l2b([H|T]) -> + << (l2b(H))/binary, (l2b(T))/binary >>; +l2b(B) when is_binary(B) -> + B; +l2b([]) -> + <<>>. + + + diff --git a/lib/ssh/src/ssh_connection_handler.erl b/lib/ssh/src/ssh_connection_handler.erl index e11d3adee4..1b3763e9c7 100644 --- a/lib/ssh/src/ssh_connection_handler.erl +++ b/lib/ssh/src/ssh_connection_handler.erl @@ -56,10 +56,13 @@ connection_info/2, channel_info/3, adjust_window/3, close/2, - disconnect/1, disconnect/2, + disconnect/4, get_print_info/1 ]). +-type connection_ref() :: ssh:connection_ref(). +-type channel_id() :: ssh:channel_id(). + %%% Behaviour callbacks -export([init/1, callback_mode/0, handle_event/4, terminate/3, format_status/2, code_change/4]). @@ -68,16 +71,28 @@ -export([init_connection_handler/3, % proc_lib:spawn needs this init_ssh_record/3, % Export of this internal function % intended for low-level protocol test suites - renegotiate/1, renegotiate_data/1 % Export intended for test cases + renegotiate/1, renegotiate_data/1, alg/1 % Export intended for test cases ]). +-export([dbg_trace/3]). + + +-define(send_disconnect(Code, DetailedText, StateName, State), + send_disconnect(Code, DetailedText, ?MODULE, ?LINE, StateName, State)). + +-define(send_disconnect(Code, Reason, DetailedText, StateName, State), + send_disconnect(Code, Reason, DetailedText, ?MODULE, ?LINE, StateName, State)). + +-define(call_disconnectfun_and_log_cond(LogMsg, DetailedText, StateName, D), + call_disconnectfun_and_log_cond(LogMsg, DetailedText, ?MODULE, ?LINE, StateName, D)). + %%==================================================================== %% Start / stop %%==================================================================== %%-------------------------------------------------------------------- -spec start_link(role(), - inet:socket(), - ssh_options:options() + gen_tcp:socket(), + internal_options() ) -> {ok, pid()}. %% . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . start_link(Role, Socket, Options) -> @@ -106,8 +121,8 @@ stop(ConnectionHandler)-> %%-------------------------------------------------------------------- -spec start_connection(role(), - inet:socket(), - ssh_options:options(), + gen_tcp:socket(), + internal_options(), timeout() ) -> {ok, connection_ref()} | {error, term()}. %% . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . @@ -149,17 +164,16 @@ start_connection(server = Role, Socket, Options, Timeout) -> %%-------------------------------------------------------------------- %%% Some other module has decided to disconnect. --spec disconnect(#ssh_msg_disconnect{}) -> no_return(). --spec disconnect(#ssh_msg_disconnect{}, iodata()) -> no_return(). + +-spec disconnect(Code::integer(), Details::iodata(), + Module::atom(), Line::integer()) -> no_return(). %% . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . -disconnect(Msg = #ssh_msg_disconnect{}) -> - throw({keep_state_and_data, - [{next_event, internal, {disconnect, Msg, Msg#ssh_msg_disconnect.description}}]}). -disconnect(Msg = #ssh_msg_disconnect{}, ExtraInfo) -> - throw({keep_state_and_data, - [{next_event, internal, {disconnect, Msg, {Msg#ssh_msg_disconnect.description,ExtraInfo}}}]}). +% Preferable called with the macro ?DISCONNECT +disconnect(Code, DetailedText, Module, Line) -> + throw({keep_state_and_data, + [{next_event, internal, {send_disconnect, Code, DetailedText, Module, Line}}]}). %%-------------------------------------------------------------------- -spec open_channel(connection_ref(), @@ -320,6 +334,9 @@ renegotiate(ConnectionHandler) -> renegotiate_data(ConnectionHandler) -> cast(ConnectionHandler, data_size). +%%-------------------------------------------------------------------- +alg(ConnectionHandler) -> + call(ConnectionHandler, get_alg). %%==================================================================== %% Internal process state @@ -345,7 +362,7 @@ renegotiate_data(ConnectionHandler) -> | undefined, % ex: tcp_closed ssh_params :: #ssh{} | undefined, - socket :: inet:socket() + socket :: gen_tcp:socket() | undefined, decrypted_data_buffer = <<>> :: binary() | undefined, @@ -356,7 +373,6 @@ renegotiate_data(ConnectionHandler) -> | undefined, last_size_rekey = 0 :: non_neg_integer(), event_queue = [] :: list(), -% opts :: ssh_options:options(), inet_initial_recbuf_size :: pos_integer() | undefined }). @@ -366,8 +382,8 @@ renegotiate_data(ConnectionHandler) -> %%==================================================================== %%-------------------------------------------------------------------- -spec init_connection_handler(role(), - inet:socket(), - ssh_options:options() + gen_tcp:socket(), + internal_options() ) -> no_return(). %% . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . init_connection_handler(Role, Socket, Opts) -> @@ -442,7 +458,7 @@ init_ssh_record(Role, Socket, Opts) -> {ok,PeerAddr} = inet:peername(Socket), init_ssh_record(Role, Socket, PeerAddr, Opts). -init_ssh_record(Role, _Socket, PeerAddr, Opts) -> +init_ssh_record(Role, Socket, PeerAddr, Opts) -> AuthMethods = ?GET_OPT(auth_methods, Opts), S0 = #ssh{role = Role, key_cb = ?GET_OPT(key_cb, Opts), @@ -453,6 +469,10 @@ init_ssh_record(Role, _Socket, PeerAddr, Opts) -> }, {Vsn, Version} = ssh_transport:versions(Role, Opts), + LocalName = case inet:sockname(Socket) of + {ok,Local} -> Local; + _ -> undefined + end, case Role of client -> PeerName = case ?GET_INTERNAL_OPT(host, Opts) of @@ -471,7 +491,8 @@ init_ssh_record(Role, _Socket, PeerAddr, Opts) -> false -> ssh_no_io end, userauth_quiet_mode = ?GET_OPT(quiet_mode, Opts), - peer = {PeerName, PeerAddr} + peer = {PeerName, PeerAddr}, + local = LocalName }, S1#ssh{userauth_pubkeys = [K || K <- ?GET_OPT(pref_public_key_algs, Opts), is_usable_user_pubkey(K, S1) @@ -484,7 +505,8 @@ init_ssh_record(Role, _Socket, PeerAddr, Opts) -> io_cb = ?GET_INTERNAL_OPT(io_cb, Opts, ssh_io), userauth_methods = string:tokens(AuthMethods, ","), kb_tries_left = 3, - peer = {undefined, PeerAddr} + peer = {undefined, PeerAddr}, + local = LocalName } end. @@ -542,7 +564,7 @@ callback_mode() -> handle_event_function. -handle_event(_, _Event, {init_error,Error}, _) -> +handle_event(_, _Event, {init_error,Error}=StateName, D) -> case Error of enotconn -> %% Handles the abnormal sequence: @@ -550,6 +572,9 @@ handle_event(_, _Event, {init_error,Error}, _) -> %% <-SYNACK %% ACK-> %% RST-> + ?call_disconnectfun_and_log_cond("Protocol Error", + "TCP connenction to server was prematurely closed by the client", + StateName, D), {stop, {shutdown,"TCP connenction to server was prematurely closed by the client"}}; OtherError -> @@ -558,7 +583,7 @@ handle_event(_, _Event, {init_error,Error}, _) -> %%% ######## {hello, client|server} #### %% The very first event that is sent when the we are set as controlling process of Socket -handle_event(_, socket_control, {hello,_}, D) -> +handle_event(_, socket_control, {hello,_}=StateName, D) -> VsnMsg = ssh_transport:hello_version_msg(string_version(D#data.ssh_params)), send_bytes(VsnMsg, D), case inet:getopts(Socket=D#data.socket, [recbuf]) of @@ -573,10 +598,13 @@ handle_event(_, socket_control, {hello,_}, D) -> {keep_state, D#data{inet_initial_recbuf_size=Size}}; Other -> + ?call_disconnectfun_and_log_cond("Option return", + io_lib:format("Unexpected getopts return:~n ~p",[Other]), + StateName, D), {stop, {shutdown,{unexpected_getopts_return, Other}}} end; -handle_event(_, {info_line,_Line}, {hello,Role}, D) -> +handle_event(_, {info_line,_Line}, {hello,Role}=StateName, D) -> case Role of client -> %% The server may send info lines to the client before the version_exchange @@ -587,28 +615,33 @@ handle_event(_, {info_line,_Line}, {hello,Role}, D) -> %% But the client may NOT send them to the server. Openssh answers with cleartext, %% and so do we send_bytes("Protocol mismatch.", D), + ?call_disconnectfun_and_log_cond("Protocol mismatch.", + "Protocol mismatch in version exchange. Client sent info lines.", + StateName, D), {stop, {shutdown,"Protocol mismatch in version exchange. Client sent info lines."}} end; -handle_event(_, {version_exchange,Version}, {hello,Role}, D) -> +handle_event(_, {version_exchange,Version}, {hello,Role}, D0) -> {NumVsn, StrVsn} = ssh_transport:handle_hello_version(Version), - case handle_version(NumVsn, StrVsn, D#data.ssh_params) of + case handle_version(NumVsn, StrVsn, D0#data.ssh_params) of {ok, Ssh1} -> %% Since the hello part is finnished correctly, we set the %% socket to the packet handling mode (including recbuf size): - inet:setopts(D#data.socket, [{packet,0}, + inet:setopts(D0#data.socket, [{packet,0}, {mode,binary}, {active, once}, - {recbuf, D#data.inet_initial_recbuf_size}]), + {recbuf, D0#data.inet_initial_recbuf_size}]), {KeyInitMsg, SshPacket, Ssh} = ssh_transport:key_exchange_init_msg(Ssh1), - send_bytes(SshPacket, D), - {next_state, {kexinit,Role,init}, D#data{ssh_params = Ssh, + send_bytes(SshPacket, D0), + {next_state, {kexinit,Role,init}, D0#data{ssh_params = Ssh, key_exchange_init_msg = KeyInitMsg}}; not_supported -> - disconnect( - #ssh_msg_disconnect{code = ?SSH_DISCONNECT_PROTOCOL_VERSION_NOT_SUPPORTED, - description = ["Protocol version ",StrVsn," not supported"]}, - {next_state, {hello,Role}, D}) + {Shutdown, D} = + ?send_disconnect(?SSH_DISCONNECT_PROTOCOL_VERSION_NOT_SUPPORTED, + io_lib:format("Offending version is ~p",[string:chomp(Version)]), + {hello,Role}, + D0), + {stop, Shutdown, D} end; @@ -754,18 +787,20 @@ handle_event(internal, Msg, {ext_info,Role,_ReNegFlag}, D) when is_tuple(Msg) -> %%% ######## {service_request, client|server} #### -handle_event(_, Msg = #ssh_msg_service_request{name=ServiceName}, StateName = {service_request,server}, D) -> +handle_event(_, Msg = #ssh_msg_service_request{name=ServiceName}, StateName = {service_request,server}, D0) -> case ServiceName of "ssh-userauth" -> - Ssh0 = #ssh{session_id=SessionId} = D#data.ssh_params, + Ssh0 = #ssh{session_id=SessionId} = D0#data.ssh_params, {ok, {Reply, Ssh}} = ssh_auth:handle_userauth_request(Msg, SessionId, Ssh0), - send_bytes(Reply, D), - {next_state, {userauth,server}, D#data{ssh_params = Ssh}}; + send_bytes(Reply, D0), + {next_state, {userauth,server}, D0#data{ssh_params = Ssh}}; _ -> - disconnect(#ssh_msg_disconnect{code = ?SSH_DISCONNECT_SERVICE_NOT_AVAILABLE, - description = "Unknown service"}, - StateName, D) + {Shutdown, D} = + ?send_disconnect(?SSH_DISCONNECT_SERVICE_NOT_AVAILABLE, + io_lib:format("Unknown service: ~p",[ServiceName]), + StateName, D0), + {stop, Shutdown, D} end; handle_event(_, #ssh_msg_service_accept{name = "ssh-userauth"}, {service_request,client}, @@ -781,15 +816,15 @@ handle_event(_, #ssh_msg_service_accept{name = "ssh-userauth"}, {service_request handle_event(_, Msg = #ssh_msg_userauth_request{service = ServiceName, method = Method}, StateName = {userauth,server}, - D = #data{ssh_params=Ssh0}) -> + D0 = #data{ssh_params=Ssh0}) -> case {ServiceName, Ssh0#ssh.service, Method} of {"ssh-connection", "ssh-connection", "none"} -> %% Probably the very first userauth_request but we deny unauthorized login {not_authorized, _, {Reply,Ssh}} = ssh_auth:handle_userauth_request(Msg, Ssh0#ssh.session_id, Ssh0), - send_bytes(Reply, D), - {keep_state, D#data{ssh_params = Ssh}}; + send_bytes(Reply, D0), + {keep_state, D0#data{ssh_params = Ssh}}; {"ssh-connection", "ssh-connection", Method} -> %% Userauth request with a method like "password" or so @@ -798,20 +833,20 @@ handle_event(_, %% Yepp! we support this method case ssh_auth:handle_userauth_request(Msg, Ssh0#ssh.session_id, Ssh0) of {authorized, User, {Reply, Ssh}} -> - send_bytes(Reply, D), - D#data.starter ! ssh_connected, - connected_fun(User, Method, D), + send_bytes(Reply, D0), + D0#data.starter ! ssh_connected, + connected_fun(User, Method, D0), {next_state, {connected,server}, - D#data{auth_user = User, + D0#data{auth_user = User, ssh_params = Ssh#ssh{authenticated = true}}}; {not_authorized, {User, Reason}, {Reply, Ssh}} when Method == "keyboard-interactive" -> - retry_fun(User, Reason, D), - send_bytes(Reply, D), - {next_state, {userauth_keyboard_interactive,server}, D#data{ssh_params = Ssh}}; + retry_fun(User, Reason, D0), + send_bytes(Reply, D0), + {next_state, {userauth_keyboard_interactive,server}, D0#data{ssh_params = Ssh}}; {not_authorized, {User, Reason}, {Reply, Ssh}} -> - retry_fun(User, Reason, D), - send_bytes(Reply, D), - {keep_state, D#data{ssh_params = Ssh}} + retry_fun(User, Reason, D0), + send_bytes(Reply, D0), + {keep_state, D0#data{ssh_params = Ssh}} end; false -> %% No we do not support this method (=/= none) @@ -825,9 +860,11 @@ handle_event(_, %% {ServiceName, Expected, Method} when Expected =/= ServiceName -> Do what? {ServiceName, _, _} when ServiceName =/= "ssh-connection" -> - disconnect(#ssh_msg_disconnect{code = ?SSH_DISCONNECT_SERVICE_NOT_AVAILABLE, - description = "Unknown service"}, - StateName, D) + {Shutdown, D} = + ?send_disconnect(?SSH_DISCONNECT_SERVICE_NOT_AVAILABLE, + io_lib:format("Unknown service: ~p",[ServiceName]), + StateName, D0), + {stop, Shutdown, D} end; %%---- userauth success to client @@ -843,14 +880,14 @@ handle_event(_, #ssh_msg_userauth_success{}, {userauth,client}, D=#data{ssh_para %%---- userauth failure response to client handle_event(_, #ssh_msg_userauth_failure{}, {userauth,client}=StateName, - D = #data{ssh_params = #ssh{userauth_methods = []}}) -> - Msg = #ssh_msg_disconnect{code = ?SSH_DISCONNECT_NO_MORE_AUTH_METHODS_AVAILABLE, - description = "Unable to connect using the available" - " authentication methods"}, - disconnect(Msg, StateName, D); - + #data{ssh_params = #ssh{userauth_methods = []}} = D0) -> + {Shutdown, D} = + ?send_disconnect(?SSH_DISCONNECT_NO_MORE_AUTH_METHODS_AVAILABLE, + io_lib:format("User auth failed for: ~p",[D0#data.auth_user]), + StateName, D0), + {stop, Shutdown, D}; handle_event(_, #ssh_msg_userauth_failure{authentications = Methods}, StateName={userauth,client}, - D = #data{ssh_params = Ssh0}) -> + D0 = #data{ssh_params = Ssh0}) -> %% The prefered authentication method failed try next method Ssh1 = case Ssh0#ssh.userauth_methods of none -> @@ -861,15 +898,18 @@ handle_event(_, #ssh_msg_userauth_failure{authentications = Methods}, StateName= Ssh0 end, case ssh_auth:userauth_request_msg(Ssh1) of - {disconnect, DisconnectMsg, {Msg, Ssh}} -> - send_bytes(Msg, D), - disconnect(DisconnectMsg, StateName, D#data{ssh_params = Ssh}); + {send_disconnect, Code, Ssh} -> + {Shutdown, D} = + ?send_disconnect(Code, + io_lib:format("User auth failed for: ~p",[D0#data.auth_user]), + StateName, D0#data{ssh_params = Ssh}), + {stop, Shutdown, D}; {"keyboard-interactive", {Msg, Ssh}} -> - send_bytes(Msg, D), - {next_state, {userauth_keyboard_interactive,client}, D#data{ssh_params = Ssh}}; + send_bytes(Msg, D0), + {next_state, {userauth_keyboard_interactive,client}, D0#data{ssh_params = Ssh}}; {_Method, {Msg, Ssh}} -> - send_bytes(Msg, D), - {keep_state, D#data{ssh_params = Ssh}} + send_bytes(Msg, D0), + {keep_state, D0#data{ssh_params = Ssh}} end; %%---- banner to client @@ -960,10 +1000,10 @@ handle_event(_, {#ssh_msg_kexinit{},_}, {connected,Role}, D0) -> {next_state, {kexinit,Role,renegotiate}, D, [postpone]}; handle_event(_, #ssh_msg_disconnect{description=Desc} = Msg, StateName, D0) -> - {disconnect, _, {{replies,Replies}, _}} = + {disconnect, _, RepliesCon} = ssh_connection:handle_msg(Msg, D0#data.connection_state, role(StateName)), - {Actions,D} = send_replies(Replies, D0), - disconnect_fun(Desc, D), + {Actions,D} = send_replies(RepliesCon, D0), + disconnect_fun("Received disconnect: "++Desc, D), {stop_and_reply, {shutdown,Desc}, Actions, D}; handle_event(_, #ssh_msg_ignore{}, _, _) -> @@ -1030,6 +1070,10 @@ handle_event(cast, renegotiate, {connected,Role}, D) -> {next_state, {kexinit,Role,renegotiate}, D#data{ssh_params = Ssh, key_exchange_init_msg = KeyInitMsg}}; +handle_event({call,From}, get_alg, _, D) -> + #ssh{algorithms=Algs} = D#data.ssh_params, + {keep_state_and_data, [{reply,From,Algs}]}; + handle_event(cast, renegotiate, _, _) -> %% Already in key-exchange so safe to ignore timer:apply_after(?REKEY_TIMOUT, gen_statem, cast, [self(), renegotiate]), % FIXME: not here in original @@ -1159,15 +1203,9 @@ handle_event({call,From}, {info, ChannelPid}, _, D) -> end, [], cache(D)), {keep_state_and_data, [{reply, From, {ok,Result}}]}; -handle_event({call,From}, stop, StateName, D0) -> - {disconnect, _Reason, {{replies, Replies}, Connection}} = - ssh_connection:handle_msg(#ssh_msg_disconnect{code = ?SSH_DISCONNECT_BY_APPLICATION, - description = "User closed down connection"}, - D0#data.connection_state, - role(StateName)), - {Repls,D} = send_replies(Replies, D0), - {stop_and_reply, normal, [{reply,From,ok}|Repls], D#data{connection_state=Connection}}; - +handle_event({call,From}, stop, _StateName, D0) -> + {Repls,D} = send_replies(ssh_connection:handle_stop(D0#data.connection_state), D0), + {stop_and_reply, normal, [{reply,From,ok}|Repls], D}; handle_event({call,_}, _, StateName, _) when not ?CONNECTED(StateName) -> {keep_state_and_data, [postpone]}; @@ -1196,9 +1234,8 @@ handle_event({call,From}, {request, ChannelId, Type, Data, Timeout}, StateName, handle_event({call,From}, {data, ChannelId, Type, Data, Timeout}, StateName, D0) when ?CONNECTED(StateName) -> - {{replies, Replies}, Connection} = - ssh_connection:channel_data(ChannelId, Type, Data, D0#data.connection_state, From), - {Repls,D} = send_replies(Replies, D0#data{connection_state = Connection}), + {Repls,D} = send_replies(ssh_connection:channel_data(ChannelId, Type, Data, D0#data.connection_state, From), + D0), start_channel_request_timer(ChannelId, From, Timeout), % FIXME: No message exchange so why? {keep_state, D, Repls}; @@ -1288,29 +1325,32 @@ handle_event(info, {Proto, Sock, NewData}, StateName, D0 = #data{socket = Sock, D0#data.ssh_params) of {packet_decrypted, DecryptedBytes, EncryptedDataRest, Ssh1} -> - D = D0#data{ssh_params = + D1 = D0#data{ssh_params = Ssh1#ssh{recv_sequence = ssh_transport:next_seqnum(Ssh1#ssh.recv_sequence)}, decrypted_data_buffer = <<>>, undecrypted_packet_length = undefined, encrypted_data_buffer = EncryptedDataRest}, try - ssh_message:decode(set_kex_overload_prefix(DecryptedBytes,D)) + ssh_message:decode(set_kex_overload_prefix(DecryptedBytes,D1)) of Msg = #ssh_msg_kexinit{} -> - {keep_state, D, [{next_event, internal, prepare_next_packet}, + {keep_state, D1, [{next_event, internal, prepare_next_packet}, {next_event, internal, {Msg,DecryptedBytes}} ]}; Msg -> - {keep_state, D, [{next_event, internal, prepare_next_packet}, + {keep_state, D1, [{next_event, internal, prepare_next_packet}, {next_event, internal, Msg} ]} catch - _C:_E -> - disconnect(#ssh_msg_disconnect{code = ?SSH_DISCONNECT_PROTOCOL_ERROR, - description = "Bad packet"}, - StateName, D) + C:E -> + {Shutdown, D} = + ?send_disconnect(?SSH_DISCONNECT_PROTOCOL_ERROR, + io_lib:format("Bad packet: Decrypted, but can't decode~n~p:~p~n~p", + [C,E,erlang:get_stacktrace()]), + StateName, D1), + {stop, Shutdown, D} end; - + {get_more, DecryptedBytes, EncryptedDataRest, RemainingSshPacketLen, Ssh1} -> %% Here we know that there are not enough bytes in %% EncryptedDataRest to use. We must wait for more. @@ -1321,19 +1361,26 @@ handle_event(info, {Proto, Sock, NewData}, StateName, D0 = #data{socket = Sock, ssh_params = Ssh1}}; {bad_mac, Ssh1} -> - disconnect(#ssh_msg_disconnect{code = ?SSH_DISCONNECT_PROTOCOL_ERROR, - description = "Bad packet"}, - StateName, D0#data{ssh_params=Ssh1}); - - {error, {exceeds_max_size,_PacketLen}} -> - disconnect(#ssh_msg_disconnect{code = ?SSH_DISCONNECT_PROTOCOL_ERROR, - description = "Bad packet"}, - StateName, D0) + {Shutdown, D} = + ?send_disconnect(?SSH_DISCONNECT_PROTOCOL_ERROR, + "Bad packet: bad mac", + StateName, D0#data{ssh_params=Ssh1}), + {stop, Shutdown, D}; + + {error, {exceeds_max_size,PacketLen}} -> + {Shutdown, D} = + ?send_disconnect(?SSH_DISCONNECT_PROTOCOL_ERROR, + io_lib:format("Bad packet: Size (~p bytes) exceeds max size", + [PacketLen]), + StateName, D0), + {stop, Shutdown, D} catch - _C:_E -> - disconnect(#ssh_msg_disconnect{code = ?SSH_DISCONNECT_PROTOCOL_ERROR, - description = "Bad packet"}, - StateName, D0) + C:E -> + {Shutdown, D} = + ?send_disconnect(?SSH_DISCONNECT_PROTOCOL_ERROR, + io_lib:format("Bad packet: Couldn't decrypt~n~p:~p~n~p",[C,E,erlang:get_stacktrace()]), + StateName, D0), + {stop, Shutdown, D} end; @@ -1349,15 +1396,13 @@ handle_event(internal, prepare_next_packet, _, D) -> inet:setopts(D#data.socket, [{active, once}]), keep_state_and_data; -handle_event(info, {CloseTag,Socket}, StateName, - D = #data{socket = Socket, - transport_close_tag = CloseTag}) -> - %% Simulate a disconnect from the peer - handle_event(info, - #ssh_msg_disconnect{code = ?SSH_DISCONNECT_BY_APPLICATION, - description = "Connection closed"}, - StateName, - D); +handle_event(info, {CloseTag,Socket}, _StateName, + D0 = #data{socket = Socket, + transport_close_tag = CloseTag, + connection_state = C0}) -> + {Repls, D} = send_replies(ssh_connection:handle_stop(C0), D0), + disconnect_fun("Received a transport close", D), + {stop_and_reply, {shutdown,"Connection closed"}, Repls, D}; handle_event(info, {timeout, {_, From} = Request}, _, #data{connection_state = #connection{requests = Requests} = C0} = D) -> @@ -1374,13 +1419,24 @@ handle_event(info, {timeout, {_, From} = Request}, _, %%% Handle that ssh channels user process goes down handle_event(info, {'DOWN', _Ref, process, ChannelPid, _Reason}, _, D0) -> - {{replies, Replies}, D1} = handle_channel_down(ChannelPid, D0), - {Repls, D} = send_replies(Replies, D1), - {keep_state, D, Repls}; + {keep_state, handle_channel_down(ChannelPid, D0)}; %%% So that terminate will be run when supervisor is shutdown -handle_event(info, {'EXIT', _Sup, Reason}, _, _) -> - {stop, {shutdown, Reason}}; +handle_event(info, {'EXIT', _Sup, Reason}, StateName, _) -> + Role = role(StateName), + if + Role == client -> + %% OTP-8111 tells this function clause fixes a problem in + %% clients, but there were no check for that role. + {stop, {shutdown, Reason}}; + + Reason == normal -> + %% An exit normal should not cause a server to crash. This has happend... + keep_state_and_data; + + true -> + {stop, {shutdown, Reason}} + end; handle_event(info, check_cache, _, D) -> {keep_state, cache_check_set_idle_timer(D)}; @@ -1425,62 +1481,79 @@ handle_event(info, UnexpectedMessage, StateName, D = #data{ssh_params = Ssh}) -> keep_state_and_data end; -handle_event(internal, {disconnect,Msg,_Reason}, StateName, D) -> - disconnect(Msg, StateName, D); +handle_event(internal, {send_disconnect,Code,DetailedText,Module,Line}, StateName, D0) -> + {Shutdown, D} = + send_disconnect(Code, DetailedText, Module, Line, StateName, D0), + {stop, Shutdown, D}; handle_event(_Type, _Msg, {ext_info,Role,_ReNegFlag}, D) -> %% If something else arrives, goto next state and handle the event in that one {next_state, {connected,Role}, D, [postpone]}; -handle_event(Type, Ev, StateName, D) -> - Descr = +handle_event(Type, Ev, StateName, D0) -> + Details = case catch atom_to_list(element(1,Ev)) of "ssh_msg_" ++_ when Type==internal -> -%% "Message in wrong state"; lists:flatten(io_lib:format("Message ~p in wrong state (~p)", [element(1,Ev), StateName])); _ -> - "Internal error" + io_lib:format("Unhandled event in state ~p:~n~p", [StateName,Ev]) end, - disconnect(#ssh_msg_disconnect{code = ?SSH_DISCONNECT_PROTOCOL_ERROR, - description = Descr}, - StateName, D). + {Shutdown, D} = + ?send_disconnect(?SSH_DISCONNECT_PROTOCOL_ERROR, Details, StateName, D0), + {stop, Shutdown, D}. %%-------------------------------------------------------------------- -spec terminate(any(), state_name(), #data{} - ) -> finalize_termination_result() . + ) -> term(). %% . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . -terminate(normal, StateName, State) -> - finalize_termination(StateName, State); +terminate(normal, _StateName, D) -> + stop_subsystem(D), + close_transport(D); -terminate({shutdown,{init,Reason}}, StateName, State) -> - error_logger:info_report(io_lib:format("Erlang ssh in connection handler init: ~p~n",[Reason])), - finalize_termination(StateName, State); +terminate({shutdown,"Connection closed"}, _StateName, D) -> + %% Normal: terminated by a sent by peer + stop_subsystem(D), + close_transport(D); -terminate(shutdown, StateName, State0) -> - %% Terminated by supervisor - State = send_msg(#ssh_msg_disconnect{code = ?SSH_DISCONNECT_BY_APPLICATION, - description = "Application shutdown"}, - State0), - finalize_termination(StateName, State); - -terminate({shutdown,_R}, StateName, State) -> - finalize_termination(StateName, State); +terminate({shutdown,{init,Reason}}, StateName, D) -> + %% Error in initiation. "This error should not occur". + log(error, D, io_lib:format("Shutdown in init (StateName=~p): ~p~n",[StateName,Reason])), + stop_subsystem(D), + close_transport(D); -terminate(kill, StateName, State) -> - finalize_termination(StateName, State); +terminate({shutdown,_R}, _StateName, D) -> + %% Internal termination, usually already reported via ?send_disconnect resulting in a log entry + stop_subsystem(D), + close_transport(D); -terminate(Reason, StateName, State0) -> - %% Others, e.g undef, {badmatch,_} - log_error(Reason), - State = send_msg(#ssh_msg_disconnect{code = ?SSH_DISCONNECT_BY_APPLICATION, - description = "Internal error"}, - State0), - finalize_termination(StateName, State). +terminate(shutdown, _StateName, D0) -> + %% Terminated by supervisor + %% Use send_msg directly instead of ?send_disconnect to avoid filling the log + D = send_msg(#ssh_msg_disconnect{code = ?SSH_DISCONNECT_BY_APPLICATION, + description = "Terminated (shutdown) by supervisor"}, + D0), + stop_subsystem(D), + close_transport(D); + +terminate(kill, _StateName, D) -> + %% Got a kill signal + stop_subsystem(D), + close_transport(D); + +terminate(Reason, StateName, D0) -> + %% Others, e.g undef, {badmatch,_}, ... + log(error, D0, Reason), + {_ShutdownReason, D} = ?send_disconnect(?SSH_DISCONNECT_BY_APPLICATION, + "Internal error", + io_lib:format("Reason: ~p",[Reason]), + StateName, D0), + stop_subsystem(D), + close_transport(D). %%-------------------------------------------------------------------- @@ -1489,36 +1562,41 @@ terminate(Reason, StateName, State0) -> format_status(normal, [_, _StateName, D]) -> [{data, [{"State", D}]}]; format_status(terminate, [_, _StateName, D]) -> - DataPropList0 = fmt_stat_rec(record_info(fields, data), D, - [decrypted_data_buffer, - encrypted_data_buffer, - key_exchange_init_msg, - user_passwords, - opts, - inet_initial_recbuf_size]), - SshPropList = fmt_stat_rec(record_info(fields, ssh), D#data.ssh_params, - [c_keyinit, - s_keyinit, - send_mac_key, - send_mac_size, - recv_mac_key, - recv_mac_size, - encrypt_keys, - encrypt_ctx, - decrypt_keys, - decrypt_ctx, - compress_ctx, - decompress_ctx, - shared_secret, - exchanged_hash, - session_id, - keyex_key, - keyex_info, - available_host_keys]), - DataPropList = lists:keyreplace(ssh_params, 1, DataPropList0, - {ssh_params,SshPropList}), - [{data, [{"State", DataPropList}]}]. - + [{data, [{"State", state_data2proplist(D)}]}]. + + +state_data2proplist(D) -> + DataPropList0 = + fmt_stat_rec(record_info(fields, data), D, + [decrypted_data_buffer, + encrypted_data_buffer, + key_exchange_init_msg, + user_passwords, + opts, + inet_initial_recbuf_size]), + SshPropList = + fmt_stat_rec(record_info(fields, ssh), D#data.ssh_params, + [c_keyinit, + s_keyinit, + send_mac_key, + send_mac_size, + recv_mac_key, + recv_mac_size, + encrypt_keys, + encrypt_ctx, + decrypt_keys, + decrypt_ctx, + compress_ctx, + decompress_ctx, + shared_secret, + exchanged_hash, + session_id, + keyex_key, + keyex_info, + available_host_keys]), + lists:keyreplace(ssh_params, 1, DataPropList0, + {ssh_params,SshPropList}). + fmt_stat_rec(FieldNames, Rec, Exclude) -> Values = tl(tuple_to_list(Rec)), @@ -1555,21 +1633,25 @@ start_the_connection_child(UserPid, Role, Socket, Options0) -> %%-------------------------------------------------------------------- %% Stopping --type finalize_termination_result() :: ok . - -finalize_termination(_StateName, #data{transport_cb = Transport, - connection_state = Connection, - socket = Socket}) -> - case Connection of - #connection{system_supervisor = SysSup, - sub_system_supervisor = SubSysSup} when is_pid(SubSysSup) -> - ssh_system_sup:stop_subsystem(SysSup, SubSysSup); - _ -> - do_nothing - end, - (catch Transport:close(Socket)), + +stop_subsystem(#data{connection_state = + #connection{system_supervisor = SysSup, + sub_system_supervisor = SubSysSup}}) when is_pid(SubSysSup) -> + ssh_system_sup:stop_subsystem(SysSup, SubSysSup); +stop_subsystem(_) -> ok. + +close_transport(#data{transport_cb = Transport, + socket = Socket}) -> + try + Transport:close(Socket) + of + _ -> ok + catch + _:_ -> ok + end. + %%-------------------------------------------------------------------- %% "Invert" the Role peer_role(client) -> server; @@ -1668,7 +1750,20 @@ handle_connection_msg(Msg, StateName, D0 = #data{starter = User, Renegotiation = renegotiation(StateName), Role = role(StateName), try ssh_connection:handle_msg(Msg, Connection0, Role) of - {{replies, Replies}, Connection} -> + {disconnect, Reason0, RepliesConn} -> + {Repls, D} = send_replies(RepliesConn, D0), + case {Reason0,Role} of + {{_, Reason}, client} when ((StateName =/= {connected,client}) and (not Renegotiation)) -> + User ! {self(), not_connected, Reason}; + _ -> + ok + end, + {stop_and_reply, {shutdown,normal}, Repls, D}; + + {[], Connection} -> + {keep_state, D0#data{connection_state = Connection}}; + + {Replies, Connection} when is_list(Replies) -> {Repls, D} = case StateName of {connected,_} -> @@ -1677,30 +1772,15 @@ handle_connection_msg(Msg, StateName, D0 = #data{starter = User, {ConnReplies, NonConnReplies} = lists:splitwith(fun not_connected_filter/1, Replies), send_replies(NonConnReplies, D0#data{event_queue = Qev0 ++ ConnReplies}) end, - {keep_state, D, Repls}; - - {noreply, Connection} -> - {keep_state, D0#data{connection_state = Connection}}; - - {disconnect, Reason0, {{replies, Replies}, Connection}} -> - {Repls, D} = send_replies(Replies, D0#data{connection_state = Connection}), - case {Reason0,Role} of - {{_, Reason}, client} when ((StateName =/= {connected,client}) and (not Renegotiation)) -> - User ! {self(), not_connected, Reason}; - _ -> - ok - end, - {stop_and_reply, {shutdown,normal}, Repls, D#data{connection_state = Connection}} + {keep_state, D, Repls} catch - _:Error -> - {disconnect, _Reason, {{replies, Replies}, Connection}} = - ssh_connection:handle_msg( - #ssh_msg_disconnect{code = ?SSH_DISCONNECT_BY_APPLICATION, - description = "Internal error"}, - Connection0, Role), - {Repls, D} = send_replies(Replies, D0#data{connection_state = Connection}), - {stop_and_reply, {shutdown,Error}, Repls, D#data{connection_state = Connection}} + Class:Error -> + {Repls, D1} = send_replies(ssh_connection:handle_stop(Connection0), D0), + {Shutdown, D} = ?send_disconnect(?SSH_DISCONNECT_BY_APPLICATION, + io_lib:format("Internal error: ~p:~p",[Class,Error]), + StateName, D1), + {stop_and_reply, Shutdown, Repls, D} end. @@ -1810,15 +1890,16 @@ handle_request(ChannelId, Type, Data, WantReply, From, D) -> %%%---------------------------------------------------------------- handle_channel_down(ChannelPid, D) -> + Cache = cache(D), ssh_channel:cache_foldl( - fun(Channel, Acc) when Channel#channel.user == ChannelPid -> - ssh_channel:cache_delete(cache(D), - Channel#channel.local_id), - Acc; - (_,Acc) -> - Acc - end, [], cache(D)), - {{replies, []}, cache_check_set_idle_timer(D)}. + fun(#channel{user=U, + local_id=Id}, Acc) when U == ChannelPid -> + ssh_channel:cache_delete(Cache, Id), + Acc; + (_,Acc) -> + Acc + end, [], Cache), + cache_check_set_idle_timer(D). update_sys(Cache, Channel, Type, ChannelPid) -> @@ -1840,11 +1921,49 @@ new_channel_id(#data{connection_state = #connection{channel_id_seed = Id} = Connection#connection{channel_id_seed = Id + 1}}}. %%%---------------------------------------------------------------- -%% %%% This server/client has decided to disconnect via the state machine: -disconnect(Msg=#ssh_msg_disconnect{description=Description}, _StateName, State0) -> - State = send_msg(Msg, State0), - disconnect_fun(Description, State), - {stop, {shutdown,Description}, State}. +%%% This server/client has decided to disconnect via the state machine: +%%% The unused arguments are for debugging. + +send_disconnect(Code, DetailedText, Module, Line, StateName, D) -> + send_disconnect(Code, default_text(Code), DetailedText, Module, Line, StateName, D). + +send_disconnect(Code, Reason, DetailedText, Module, Line, StateName, D0) -> + Msg = #ssh_msg_disconnect{code = Code, + description = Reason}, + D = send_msg(Msg, D0), + LogMsg = io_lib:format("Disconnects with code = ~p [RFC4253 11.1]: ~s",[Code,Reason]), + call_disconnectfun_and_log_cond(LogMsg, DetailedText, Module, Line, StateName, D), + {{shutdown,Reason}, D}. + +call_disconnectfun_and_log_cond(LogMsg, DetailedText, Module, Line, StateName, D) -> + case disconnect_fun(LogMsg, D) of + void -> + log(info, D, + io_lib:format("~s~n" + "State = ~p~n" + "Module = ~p, Line = ~p.~n" + "Details:~n ~s~n", + [LogMsg, StateName, Module, Line, DetailedText])); + _ -> + ok + end. + + +default_text(?SSH_DISCONNECT_HOST_NOT_ALLOWED_TO_CONNECT) -> "Host not allowed to connect"; +default_text(?SSH_DISCONNECT_PROTOCOL_ERROR) -> "Protocol error"; +default_text(?SSH_DISCONNECT_KEY_EXCHANGE_FAILED) -> "Key exchange failed"; +default_text(?SSH_DISCONNECT_RESERVED) -> "Reserved"; +default_text(?SSH_DISCONNECT_MAC_ERROR) -> "Mac error"; +default_text(?SSH_DISCONNECT_COMPRESSION_ERROR) -> "Compression error"; +default_text(?SSH_DISCONNECT_SERVICE_NOT_AVAILABLE) -> "Service not available"; +default_text(?SSH_DISCONNECT_PROTOCOL_VERSION_NOT_SUPPORTED) -> "Protocol version not supported"; +default_text(?SSH_DISCONNECT_HOST_KEY_NOT_VERIFIABLE) -> "Host key not verifiable"; +default_text(?SSH_DISCONNECT_CONNECTION_LOST) -> "Connection lost"; +default_text(?SSH_DISCONNECT_BY_APPLICATION) -> "By application"; +default_text(?SSH_DISCONNECT_TOO_MANY_CONNECTIONS) -> "Too many connections"; +default_text(?SSH_DISCONNECT_AUTH_CANCELLED_BY_USER) -> "Auth cancelled by user"; +default_text(?SSH_DISCONNECT_NO_MORE_AUTH_METHODS_AVAILABLE) -> "Unable to connect using the available authentication methods"; +default_text(?SSH_DISCONNECT_ILLEGAL_USER_NAME) -> "Illegal user name". %%%---------------------------------------------------------------- counterpart_versions(NumVsn, StrVsn, #ssh{role = server} = Ssh) -> @@ -1857,8 +1976,7 @@ conn_info(client_version, #data{ssh_params=S}) -> {S#ssh.c_vsn, S#ssh.c_version} conn_info(server_version, #data{ssh_params=S}) -> {S#ssh.s_vsn, S#ssh.s_version}; conn_info(peer, #data{ssh_params=S}) -> S#ssh.peer; conn_info(user, D) -> D#data.auth_user; -conn_info(sockname, D) -> {ok, SockName} = inet:sockname(D#data.socket), - SockName; +conn_info(sockname, #data{ssh_params=S}) -> S#ssh.local; %% dbg options ( = not documented): conn_info(socket, D) -> D#data.socket; conn_info(chan_ids, D) -> @@ -1889,23 +2007,54 @@ fold_keys(Keys, Fun, Extra) -> end, [], Keys). %%%---------------------------------------------------------------- -log_error(Reason) -> - Report = io_lib:format("Erlang ssh connection handler failed with reason:~n" - " ~p~n" - "Stacktrace:~n" - " ~p~n", - [Reason, erlang:get_stacktrace()]), - error_logger:error_report(Report). +log(Tag, D, Reason) -> + case atom_to_list(Tag) of % Dialyzer-technical reasons... + "error" -> do_log(error_msg, Reason, D); + "warning" -> do_log(warning_msg, Reason, D); + "info" -> do_log(info_msg, Reason, D) + end. + +do_log(F, Reason, #data{ssh_params = #ssh{role = Role} = S + }) -> + VSN = + case application:get_key(ssh,vsn) of + {ok,Vsn} -> Vsn; + undefined -> "" + end, + PeerVersion = + case Role of + server -> S#ssh.c_version; + client -> S#ssh.s_version + end, + CryptoInfo = + try + [{_,_,CI}] = crypto:info_lib(), + <<"(",CI/binary,")">> + catch + _:_ -> "" + end, + Other = + case Role of + server -> "Client"; + client -> "Server" + end, + error_logger:F("Erlang SSH ~p ~s ~s.~n" + "~s: ~p~n" + "~s~n", + [Role, VSN, CryptoInfo, + Other, PeerVersion, + Reason]). %%%---------------------------------------------------------------- not_connected_filter({connection_reply, _Data}) -> true; not_connected_filter(_) -> false. %%%---------------------------------------------------------------- + +send_replies({Repls,C = #connection{}}, D) when is_list(Repls) -> + send_replies(Repls, D#data{connection_state=C}); send_replies(Repls, State) -> - lists:foldl(fun get_repl/2, - {[],State}, - Repls). + lists:foldl(fun get_repl/2, {[],State}, Repls). get_repl({connection_reply,Msg}, {CallRepls,S}) -> if is_record(Msg, ssh_msg_channel_success) -> @@ -1926,15 +2075,17 @@ get_repl({flow_control,Cache,Channel,From,Msg}, {CallRepls,S}) -> {[{reply,From,Msg}|CallRepls], S}; get_repl({flow_control,From,Msg}, {CallRepls,S}) -> {[{reply,From,Msg}|CallRepls], S}; -get_repl(noreply, Acc) -> - Acc; +%% get_repl(noreply, Acc) -> +%% Acc; +%% get_repl([], Acc) -> +%% Acc; get_repl(X, Acc) -> exit({get_repl,X,Acc}). %%%---------------------------------------------------------------- -define(CALL_FUN(Key,D), catch (?GET_OPT(Key, (D#data.ssh_params)#ssh.opts)) ). -disconnect_fun({disconnect,Msg}, D) -> ?CALL_FUN(disconnectfun,D)(Msg); +%%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) -> @@ -2089,3 +2240,137 @@ update_inet_buffers(Socket) -> catch _:_ -> ok end. + +%%%################################################################ +%%%# +%%%# Tracing +%%%# + +dbg_trace(points, _, _) -> [terminate, disconnect, connections, connection_events]; + +dbg_trace(flags, connections, A) -> [c] ++ dbg_trace(flags, terminate, A); +dbg_trace(on, connections, A) -> dbg:tp(?MODULE, init_connection_handler, 3, x), + dbg_trace(on, terminate, A); +dbg_trace(off, connections, A) -> dbg:ctpg(?MODULE, init_connection_handler, 3), + dbg_trace(off, terminate, A); +dbg_trace(format, connections, {call, {?MODULE,init_connection_handler, [Role, Sock, Opts]}}) -> + DefaultOpts = ssh_options:handle_options(Role,[]), + ExcludedKeys = [internal_options, user_options], + NonDefaultOpts = + maps:filter(fun(K,V) -> + case lists:member(K,ExcludedKeys) of + true -> + false; + false -> + V =/= (catch maps:get(K,DefaultOpts)) + end + end, + Opts), + {ok, {IPp,Portp}} = inet:peername(Sock), + {ok, {IPs,Ports}} = inet:sockname(Sock), + [io_lib:format("Starting ~p connection:\n",[Role]), + io_lib:format("Socket = ~p, Peer = ~s:~p, Local = ~s:~p,~n" + "Non-default options:~n~p", + [Sock,inet:ntoa(IPp),Portp,inet:ntoa(IPs),Ports, + NonDefaultOpts]) + ]; +dbg_trace(format, connections, F) -> + dbg_trace(format, terminate, F); + +dbg_trace(flags, connection_events, _) -> [c]; +dbg_trace(on, connection_events, _) -> dbg:tp(?MODULE, handle_event, 4, x); +dbg_trace(off, connection_events, _) -> dbg:ctpg(?MODULE, handle_event, 4); +dbg_trace(format, connection_events, {call, {?MODULE,handle_event, [EventType, EventContent, State, _Data]}}) -> + ["Connection event\n", + io_lib:format("EventType: ~p~nEventContent: ~p~nState: ~p~n", [EventType, EventContent, State]) + ]; +dbg_trace(format, connection_events, {return_from, {?MODULE,handle_event,4}, Ret}) -> + ["Connection event result\n", + io_lib:format("~p~n", [event_handler_result(Ret)]) + ]; + +dbg_trace(flags, terminate, _) -> [c]; +dbg_trace(on, terminate, _) -> dbg:tp(?MODULE, terminate, 3, x); +dbg_trace(off, terminate, _) -> dbg:ctpg(?MODULE, terminate, 3); +dbg_trace(format, terminate, {call, {?MODULE,terminate, [Reason, StateName, D]}}) -> + ExtraInfo = + try + {conn_info(peer,D), + conn_info(user,D), + conn_info(sockname,D)} + of + {{_,{IPp,Portp}}, Usr, {IPs,Ports}} when is_tuple(IPp), is_tuple(IPs), + is_integer(Portp), is_integer(Ports) -> + io_lib:format("Peer=~s:~p, Local=~s:~p, User=~p", + [inet:ntoa(IPp),Portp,inet:ntoa(IPs),Ports,Usr]); + {Peer,Usr,Sockname} -> + io_lib:format("Peer=~p, Local=~p, User=~p",[Peer,Sockname,Usr]) + catch + _:_ -> + "" + end, + if + Reason == normal ; + Reason == shutdown ; + element(1,Reason) == shutdown + -> + ["Connection Terminating:\n", + io_lib:format("Reason: ~p, StateName: ~p~n~s", [Reason, StateName, ExtraInfo]) + ]; + + true -> + ["Connection Terminating:\n", + io_lib:format("Reason: ~p, StateName: ~p~n~s~nStateData = ~p", + [Reason, StateName, ExtraInfo, state_data2proplist(D)]) + ] + end; + +dbg_trace(flags, disconnect, _) -> [c]; +dbg_trace(on, disconnect, _) -> dbg:tpl(?MODULE, send_disconnect, 7, x); +dbg_trace(off, disconnect, _) -> dbg:ctpl(?MODULE, send_disconnect, 7); +dbg_trace(format, disconnect, {call,{?MODULE,send_disconnect, + [Code, Reason, DetailedText, Module, Line, StateName, _D]}}) -> + ["Disconnecting:\n", + io_lib:format(" Module = ~p, Line = ~p, StateName = ~p,~n" + " Code = ~p, Reason = ~p,~n" + " DetailedText =~n" + " ~p", + [Module, Line, StateName, Code, Reason, lists:flatten(DetailedText)]) + ]. + + +event_handler_result({next_state, NextState, _NewData}) -> + {next_state, NextState, "#data{}"}; +event_handler_result({next_state, NextState, _NewData, Actions}) -> + {next_state, NextState, "#data{}", Actions}; +event_handler_result(R) -> + state_callback_result(R). + +state_callback_result({keep_state, _NewData}) -> + {keep_state, "#data{}"}; +state_callback_result({keep_state, _NewData, Actions}) -> + {keep_state, "#data{}", Actions}; +state_callback_result(keep_state_and_data) -> + keep_state_and_data; +state_callback_result({keep_state_and_data, Actions}) -> + {keep_state_and_data, Actions}; +state_callback_result({repeat_state, _NewData}) -> + {repeat_state, "#data{}"}; +state_callback_result({repeat_state, _NewData, Actions}) -> + {repeat_state, "#data{}", Actions}; +state_callback_result(repeat_state_and_data) -> + repeat_state_and_data; +state_callback_result({repeat_state_and_data, Actions}) -> + {repeat_state_and_data, Actions}; +state_callback_result(stop) -> + stop; +state_callback_result({stop, Reason}) -> + {stop, Reason}; +state_callback_result({stop, Reason, _NewData}) -> + {stop, Reason, "#data{}"}; +state_callback_result({stop_and_reply, Reason, Replies}) -> + {stop_and_reply, Reason, Replies}; +state_callback_result({stop_and_reply, Reason, Replies, _NewData}) -> + {stop_and_reply, Reason, Replies, "#data{}"}; +state_callback_result(R) -> + R. diff --git a/lib/ssh/src/ssh_daemon_channel.erl b/lib/ssh/src/ssh_daemon_channel.erl index 6ca93eff44..72853f2d6a 100644 --- a/lib/ssh/src/ssh_daemon_channel.erl +++ b/lib/ssh/src/ssh_daemon_channel.erl @@ -36,10 +36,10 @@ term(). -callback handle_msg(Msg ::term(), State :: term()) -> - {ok, State::term()} | {stop, ChannelId::integer(), State::term()}. --callback handle_ssh_msg({ssh_cm, ConnectionRef::term(), SshMsg::term()}, + {ok, State::term()} | {stop, ChannelId::ssh:channel_id(), State::term()}. +-callback handle_ssh_msg({ssh_cm, ConnectionRef::ssh:connection_ref(), SshMsg::term()}, State::term()) -> {ok, State::term()} | - {stop, ChannelId::integer(), + {stop, ChannelId::ssh:channel_id(), State::term()}. %%% API @@ -48,6 +48,7 @@ %% gen_server callbacks -export([init/1, terminate/2]). +-spec start(ssh:connection_ref(), ssh:channel_id(), atom(), term()) -> term(). start(ConnectionManager, ChannelId, CallBack, CbInitArgs) -> ssh_channel:start(ConnectionManager, ChannelId, CallBack, CbInitArgs, undefined). diff --git a/lib/ssh/src/ssh_dbg.erl b/lib/ssh/src/ssh_dbg.erl index eb2c2848f3..2ee4237e05 100644 --- a/lib/ssh/src/ssh_dbg.erl +++ b/lib/ssh/src/ssh_dbg.erl @@ -20,339 +20,110 @@ %% +%%% Purpose: +%%% This module implements support for using the Erlang trace in a simple way for ssh +%%% debugging. +%%% +%%% Begin the session with ssh_dbg:start(). This will do a dbg:start() if needed and +%%% then dbg:p/2 to set some flags. +%%% +%%% Next select trace points to activate: for example plain text printouts of messages +%%% sent or received. This is switched on and off with ssh_dbg:on(TracePoint(s)) and +%%% ssh_dbg:off(TracePoint(s)). For example: +%%% +%%% ssh_dbg:on(messages) -- switch on printing plain text messages +%%% ssh_dbg:on([alg,terminate]) -- switch on printing info about algorithm negotiation +%%% ssh_dbg:on() -- switch on all ssh debugging +%%% +%%% To switch, use the off/0 or off/1 function in the same way, for example: +%%% +%%% ssh_dbg:off(alg) -- switch off algorithm negotiation tracing, but keep all other +%%% ssh_dbg:off() -- switch off all ssh debugging +%%% +%%% Present the trace result with some other method than the default io:format/2: +%%% ssh_dbg:start(fun(Format,Args) -> +%%% my_special( io_lib:format(Format,Args) ) +%%% end) +%%% + -module(ssh_dbg). --export([messages/0, messages/1, messages/2, messages/3, - auth/0, auth/1, auth/2, auth/3, - algs/0, algs/1, algs/2, algs/3, - hostkey/0, hostkey/1, hostkey/2, hostkey/3, - stop/0 +-export([start/0, start/1, + stop/0, + start_server/0, + start_tracer/0, start_tracer/1, + on/1, on/0, + off/1, off/0, + go_on/0 ]). -export([shrink_bin/1, - wr_record/3]). + reduce_state/1, + wr_record/3]). + +-export([init/1, handle_call/3, handle_cast/2, handle_info/2]). -include("ssh.hrl"). -include("ssh_transport.hrl"). -include("ssh_connect.hrl"). -include("ssh_auth.hrl"). -%%%================================================================ -messages() -> start(msg). -messages(F) -> start(msg,F). -messages(F,X) -> start(msg,F,X). -messages(F,M,I) -> start(msg,F,M,I). - -auth() -> start(auth). -auth(F) -> start(auth,F). -auth(F,X) -> start(auth,F,X). -auth(F,M,I) -> start(auth,F,M,I). - -algs() -> start(algs). -algs(F) -> start(algs,F). -algs(F,X) -> start(algs,F,X). -algs(F,M,I) -> start(algs,F,M,I). - -hostkey() -> start(hostkey). -hostkey(F) -> start(hostkey,F). -hostkey(F,X) -> start(hostkey,F,X). -hostkey(F,M,I) -> start(hostkey,F,M,I). - -stop() -> dbg:stop(). - -%%%---------------------------------------------------------------- -start(Type) -> start(Type, fun io:format/2). +-behaviour(gen_server). +-define(SERVER, ?MODULE). -start(Type, F) when is_function(F,2) -> start(Type, fmt_fun(F)); -start(Type, F) when is_function(F,3) -> start(Type, F, id_fun()). - -start(Type, WriteFun, MangleArgFun) when is_function(WriteFun, 3), - is_function(MangleArgFun, 1) -> - start(Type, WriteFun, MangleArgFun, []); -start(Type, WriteFun, InitValue) -> - start(Type, WriteFun, id_fun(), InitValue). +%%%================================================================ -start(Type, WriteFun, MangleArgFun, InitValue) when is_function(WriteFun, 3), - is_function(MangleArgFun, 1) -> - cond_start(Type, WriteFun, MangleArgFun, InitValue), - dbg_ssh(Type). +-define(ALL_DBG_TYPES, get_all_dbg_types()). -%%%---------------------------------------------------------------- -fmt_fun(F) -> fun(Fmt,Args,Data) -> F(Fmt,Args), Data end. +start() -> start(fun io:format/2). -id_fun() -> fun(X) -> X end. +start(IoFmtFun) when is_function(IoFmtFun,2) ; is_function(IoFmtFun,3) -> + start_server(), + catch dbg:start(), + start_tracer(IoFmtFun), + dbg:p(all, get_all_trace_flags()), + ?ALL_DBG_TYPES. -%%%---------------------------------------------------------------- -dbg_ssh(What) -> - case [E || E <- lists:flatten(dbg_ssh0(What)), - element(1,E) =/= ok] of - [] -> ok; - Other -> Other - end. - - -dbg_ssh0(auth) -> - [dbg:tp(ssh_transport,hello_version_msg,1, x), - dbg:tp(ssh_transport,handle_hello_version,1, x), - dbg:tp(ssh_message,encode,1, x), - dbg:tpl(ssh_transport,select_algorithm,4, x), - dbg:tpl(ssh_connection_handler,ext_info,2, x), - lists:map(fun(F) -> dbg:tp(ssh_auth, F, x) end, - [publickey_msg, password_msg, keyboard_interactive_msg]) - ]; - -dbg_ssh0(algs) -> - [dbg:tpl(ssh_transport,select_algorithm,4, x), - dbg:tpl(ssh_connection_handler,ext_info,2, x) - ]; - -dbg_ssh0(hostkey) -> - [dbg:tpl(ssh_transport, verify_host_key, 4, x), - dbg:tp(ssh_transport, verify, 4, x), - dbg:tpl(ssh_transport, known_host_key, 3, x), -%% dbg:tpl(ssh_transport, accepted_host, 4, x), - dbg:tpl(ssh_transport, add_host_key, 4, x), - dbg:tpl(ssh_transport, is_host_key, 5, x) - ]; - -dbg_ssh0(msg) -> - [dbg_ssh0(hostkey), - dbg_ssh0(auth), - dbg:tp(ssh_message,encode,1, x), - dbg:tp(ssh_message,decode,1, x), - dbg:tpl(ssh_transport,select_algorithm,4, x), - dbg:tp(ssh_transport,hello_version_msg,1, x), - dbg:tp(ssh_transport,handle_hello_version,1, x), - dbg:tpl(ssh_connection_handler,ext_info,2, x) - ]. - - -%%%================================================================ -cond_start(Type, WriteFun, MangleArgFun, Init) -> +stop() -> try - dbg:start(), - setup_tracer(Type, WriteFun, MangleArgFun, Init), - dbg:p(new,[c,timestamp]) + dbg:stop_clear(), + gen_server:stop(?SERVER) catch _:_ -> ok end. +start_server() -> + gen_server:start({local,?SERVER}, ?MODULE, [], []). + -msg_formater(msg, {trace_ts,Pid,call,{ssh_message,encode,[Msg]},TS}, D) -> - fmt("~n~s SEND ~p ~s~n", [ts(TS),Pid,wr_record(shrink_bin(Msg))], D); -msg_formater(msg, {trace_ts,_Pid,return_from,{ssh_message,encode,1},_Res,_TS}, D) -> - D; - -msg_formater(msg, {trace_ts,_Pid,call,{ssh_message,decode,_},_TS}, D) -> - D; -msg_formater(msg, {trace_ts,Pid,return_from,{ssh_message,decode,1},Msg,TS}, D) -> - Extra = - case Msg of - #ssh_msg_userauth_info_request{data = D0} -> - try ssh_message:decode_keyboard_interactive_prompts(D0, []) - of - Acc -> - io_lib:format(" -- decoded data:~n", []) ++ - element(1, - lists:mapfoldl( - fun({Prompt,Echo}, N) -> - {io_lib:format(" prompt[~p]: \"~s\" (echo=~p)~n",[N,Prompt,Echo]), N+1} - end, 1, Acc)) - catch - _:_ -> - "" - end; - _ -> - "" +start_tracer() -> start_tracer(fun io:format/2). + +start_tracer(WriteFun) when is_function(WriteFun,2) -> + start_tracer(fun(F,A,S) -> WriteFun(F,A), S end); +start_tracer(WriteFun) when is_function(WriteFun,3) -> + start_tracer(WriteFun, undefined). + + +start_tracer(WriteFun, InitAcc) when is_function(WriteFun, 3) -> + Handler = + fun(Arg, Acc0) -> + try_all_types_in_all_modules(gen_server:call(?SERVER, get_on), + Arg, WriteFun, + Acc0) end, - fmt("~n~s ~p RECV ~s~s~n", [ts(TS),Pid,wr_record(shrink_bin(Msg)),Extra], D); - -msg_formater(_auth, {trace_ts,Pid,return_from,{ssh_message,decode,1},#ssh_msg_userauth_failure{authentications=As},TS}, D) -> - fmt("~n~s ~p Client login FAILURE. Try ~s~n", [ts(TS),Pid,As], D); - -msg_formater(_auth, {trace_ts,Pid,return_from,{ssh_message,decode,1},#ssh_msg_userauth_success{},TS}, D) -> - fmt("~n~s ~p Client login SUCCESS~n", [ts(TS),Pid], D); - - -msg_formater(_, {trace_ts,_Pid,call,{ssh_transport,select_algorithm,_},_TS}, D) -> - D; -msg_formater(_, {trace_ts,Pid,return_from,{ssh_transport,select_algorithm,_},{ok,Alg},TS}, D) -> - fmt("~n~s ~p ALGORITHMS~n~s~n", [ts(TS),Pid, wr_record(Alg)], D); - -msg_formater(_, {trace_ts,_Pid,call,{ssh_transport,hello_version_msg,_},_TS}, D) -> - D; -msg_formater(_, {trace_ts,Pid,return_from,{ssh_transport,hello_version_msg,1},Hello,TS}, D) -> - fmt("~n~s ~p TCP SEND HELLO~n ~p~n", [ts(TS),Pid,lists:flatten(Hello)], D); - -msg_formater(_, {trace_ts,Pid,call,{ssh_transport,handle_hello_version,[Hello]},TS}, D) -> - fmt("~n~s ~p RECV HELLO~n ~p~n", [ts(TS),Pid,lists:flatten(Hello)], D); -msg_formater(_, {trace_ts,_Pid,return_from,{ssh_transport,handle_hello_version,1},_,_TS}, D) -> - D; - -msg_formater(_, {trace_ts,Pid,call,{ssh_connection_handler,ext_info,[{"server-sig-algs",SigAlgs},State]},TS}, D) -> - try lists:keyfind(ssh, 1, tuple_to_list(State)) of - false -> - D; - #ssh{userauth_pubkeys = PKs} -> - fmt("~n~s ~p Client got suggestion to use user public key sig-algs~n ~p~n and can use~n ~p~n", - [ts(TS),Pid,string:tokens(SigAlgs,","),PKs], D) - catch - _:_ -> - D - end; - -msg_formater(_, {trace_ts,Pid,return_from,{ssh_connection_handler,ext_info,2},State,TS}, D) -> - try lists:keyfind(ssh, 1, tuple_to_list(State)) of - false -> - D; - #ssh{userauth_pubkeys = PKs} -> - fmt("~n~s ~p Client will try user public key sig-algs~n ~p~n", [ts(TS),Pid,PKs], D) - catch - _:_ -> - D - end; - -msg_formater(_, {trace_ts,Pid,call, {ssh_transport,verify_host_key,[_Ssh,_PK,_Dgst,{AlgStr,_Sign}]},TS}, D) -> - fmt("~n~s ~p Client got a ~s hostkey. Will try to verify it~n", [ts(TS),Pid,AlgStr], D); -msg_formater(_, {trace_ts,Pid,return_from, {ssh_transport,verify_host_key,4}, Result, TS}, D) -> - case Result of - ok -> fmt("~n~s ~p Hostkey verified.~n", [ts(TS),Pid], D); - {error,E} -> - fmt("~n~s ~p ***** Hostkey NOT verified: ~p ******!~n", [ts(TS),Pid,E], D); - _ -> fmt("~n~s ~p ***** Hostkey is NOT verified: ~p ******!~n", [ts(TS),Pid,Result], D) - end; - -msg_formater(_, {trace_ts,Pid,return_from, {ssh_transport,verify,4}, Result, TS}, D) -> - case Result of - true -> D; - _ -> fmt("~n~s ~p Couldn't verify the signature!~n", [ts(TS),Pid], D) - end; - -msg_formater(_, {trace_ts,_Pid,call, {ssh_transport,is_host_key,_}, _TS}, D) -> D; -msg_formater(_, {trace_ts,Pid,return_from, {ssh_transport,is_host_key,5}, {CbMod,Result}, TS}, D) -> - case Result of - true -> fmt("~n~s ~p Hostkey found by ~p.~n", [ts(TS),Pid,CbMod], D); - _ -> fmt("~n~s ~p Hostkey NOT found by ~p.~n", [ts(TS),Pid,CbMod], D) - end; - -msg_formater(_, {trace_ts,_Pid,call, {ssh_transport,add_host_key,_}, _TS}, D) -> D; -msg_formater(_, {trace_ts,Pid,return_from, {ssh_transport,add_host_key,4}, {CbMod,Result}, TS}, D) -> - case Result of - ok -> fmt("~n~s ~p New hostkey added by ~p.~n", [ts(TS),Pid,CbMod], D); - _ -> D - end; - -msg_formater(_, {trace_ts,_Pid,call,{ssh_transport,known_host_key,_},_TS}, D) -> D; -msg_formater(_, {trace_ts,Pid,return_from, {ssh_transport,known_host_key,3}, Result, TS}, D) -> - case Result of - ok -> D; - {error,E} -> fmt("~n~s ~p Hostkey addition failed: ~p~n", [ts(TS),Pid,E], D); - _ -> fmt("~n~s ~p Hostkey addition: ~p~n", [ts(TS),Pid,Result], D) - end; - -msg_formater(_, {trace_ts,Pid,call,{ssh_auth,publickey_msg,[[SigAlg,#ssh{user=User}]]},TS}, D) -> - fmt("~n~s ~p Client will try to login user ~p with method: public key algorithm ~p~n", [ts(TS),Pid,User,SigAlg], D); -msg_formater(_, {trace_ts,Pid,return_from,{ssh_auth,publickey_msg,1},{not_ok,#ssh{user=User}},TS}, D) -> - fmt("~s ~p User ~p can't use that kind of public key~n", [ts(TS),Pid,User], D); -msg_formater(_, {trace_ts,_Pid,return_from,{ssh_auth,publickey_msg,1},_,_TS}, D) -> D; - -msg_formater(_, {trace_ts,Pid,call,{ssh_auth,password_msg,[[#ssh{user=User}]]},TS}, D) -> - fmt("~n~s ~p Client will try to login user ~p with method: password~n", [ts(TS),Pid,User], D); -msg_formater(_, {trace_ts,Pid,return_from,{ssh_auth,password_msg,1},{not_ok,#ssh{user=User}},TS}, D) -> - fmt("~s ~p User ~p can't use method password as login method~n", [ts(TS),Pid,User], D); -msg_formater(_, {trace_ts,_Pid,return_from,{ssh_auth,password_msg,1},_Result,_TS}, D) -> D; - -msg_formater(_, {trace_ts,Pid,call,{ssh_auth,keyboard_interactive_msg,[[#ssh{user=User}]]},TS}, D) -> - fmt("~n~s ~p Client will try to login user ~p with method: keyboard-interactive~n", [ts(TS),Pid,User], D); -msg_formater(_, {trace_ts,Pid,return_from,{ssh_auth,keyboard_interactive_msg,1},{not_ok,#ssh{user=User}},TS}, D) -> - fmt("~s ~p User ~p can't use method keyboard-interactive as login method~n", [ts(TS),Pid,User], D); -msg_formater(_, {trace_ts,_Pid,return_from,{ssh_auth,keyboard_interactive_msg,1},_Result,_TS}, D) -> D; - -msg_formater(msg, {trace_ts,Pid,send,{tcp,Sock,Bytes},Pid,TS}, D) -> - fmt("~n~s ~p TCP SEND on ~p~n ~p~n", [ts(TS),Pid,Sock, shrink_bin(Bytes)], D); - -msg_formater(msg, {trace_ts,Pid,send,{tcp,Sock,Bytes},Dest,TS}, D) -> - fmt("~n~s ~p TCP SEND from ~p TO ~p~n ~p~n", [ts(TS),Pid,Sock,Dest, shrink_bin(Bytes)], D); - -msg_formater(msg, {trace_ts,Pid,send,ErlangMsg,Dest,TS}, D) -> - fmt("~n~s ~p ERL MSG SEND TO ~p~n ~p~n", [ts(TS),Pid,Dest, shrink_bin(ErlangMsg)], D); - - -msg_formater(msg, {trace_ts,Pid,'receive',{tcp,Sock,Bytes},TS}, D) -> - fmt("~n~s ~p TCP RECEIVE on ~p~n ~p~n", [ts(TS),Pid,Sock,shrink_bin(Bytes)], D); - -msg_formater(msg, {trace_ts,Pid,'receive',ErlangMsg,TS}, D) -> - fmt("~n~s ~p ERL MSG RECEIVE~n ~p~n", [ts(TS),Pid,shrink_bin(ErlangMsg)], D); - - -msg_formater(_, _M, D) -> - fmt("~nDBG other ~n~p~n", [shrink_bin(_M)], D), - D. + dbg:tracer(process, {Handler,InitAcc}). %%%---------------------------------------------------------------- --record(data, {writer, - initialized, - acc}). - -fmt(Fmt, Args, D=#data{initialized=false}) -> - fmt(Fmt, Args, - D#data{acc = (D#data.writer)("~s~n", [initial_info()], D#data.acc), - initialized = true} - ); -fmt(Fmt, Args, D=#data{writer=Write, acc=Acc}) -> - D#data{acc = Write(Fmt,Args,Acc)}. - -ts({_,_,Usec}=Now) -> - {_Date,{HH,MM,SS}} = calendar:now_to_local_time(Now), - io_lib:format("~.2.0w:~.2.0w:~.2.0w.~.6.0w",[HH,MM,SS,Usec]); -ts(_) -> - "-". +on() -> on(?ALL_DBG_TYPES). +on(Type) -> switch(on, Type). -setup_tracer(Type, WriteFun, MangleArgFun, Init) -> - Handler = fun(Arg, D) -> - msg_formater(Type, MangleArgFun(Arg), D) - end, - InitialData = #data{writer = WriteFun, - initialized = false, - acc = Init}, - {ok,_} = dbg:tracer(process, {Handler, InitialData}), - ok. - - -initial_info() -> - Lines = - [ts(erlang:timestamp()), - "", - "SSH:"] - ++ as_list_of_lines(case application:get_key(ssh,vsn) of - {ok,Vsn} -> Vsn; - _ -> "(ssh not started)" - end) - ++ ["", - "Cryptolib:"] - ++ as_list_of_lines(crypto:info_lib()) - ++ ["", - "Crypto app:"] - ++ as_list_of_lines(crypto:supports()), - W = max_len(Lines), - append_lines([line_of($*, W+4)] - ++ prepend_lines("* ", Lines) - ++ [line_of($-, W+4)], - io_lib:nl() - ). - + +off() -> off(?ALL_DBG_TYPES). % A bit overkill... +off(Type) -> switch(off, Type). -as_list_of_lines(Term) -> - prepend_lines(" ", - string:tokens(lists:flatten(io_lib:format("~p",[Term])), - io_lib:nl() % Get line endings in current OS - ) - ). - -line_of(Char,W) -> lists:duplicate(W,Char). -max_len(L) -> lists:max([length(S) || S<-L]). -append_lines(L, X) -> [S++X || S<-L]. -prepend_lines(X, L) -> [X++S || S<-L]. +go_on() -> + IsOn = gen_server:call(?SERVER, get_on), + on(IsOn). %%%---------------------------------------------------------------- shrink_bin(B) when is_binary(B), size(B)>256 -> {'*** SHRINKED BIN', @@ -365,69 +136,198 @@ shrink_bin(L) when is_list(L) -> lists:map(fun shrink_bin/1, L); shrink_bin(T) when is_tuple(T) -> list_to_tuple(shrink_bin(tuple_to_list(T))); shrink_bin(X) -> X. +%%%---------------------------------------------------------------- +%% Replace last element (the state) with "#<state-name>{}" +reduce_state(T) -> + try + erlang:setelement(size(T), + T, + lists:concat(['#',element(1,element(size(T),T)),'{}']) + ) + catch + _:_ -> + T + end. + +%%%================================================================ +-record(data, { + types_on = [] + }). + +%%%---------------------------------------------------------------- +init(_) -> + {ok, #data{}}. + +%%%---------------------------------------------------------------- +handle_call({switch,on,Types}, _From, D) -> + NowOn = lists:usort(Types ++ D#data.types_on), + call_modules(on, Types, NowOn), + {reply, {ok,NowOn}, D#data{types_on = NowOn}}; + +handle_call({switch,off,Types}, _From, D) -> + StillOn = D#data.types_on -- Types, + call_modules(off, Types, StillOn), + call_modules(on, StillOn, StillOn), + {reply, {ok,StillOn}, D#data{types_on = StillOn}}; + +handle_call(get_on, _From, D) -> + {reply, D#data.types_on, D}; + +handle_call(C, _From, D) -> + io:format('*** Unknown call: ~p~n',[C]), + {reply, {error,{unknown_call,C}}, D}. + + +handle_cast(C, D) -> + io:format('*** Unknown cast: ~p~n',[C]), + {noreply, D}. + +handle_info(C, D) -> + io:format('*** Unknown info: ~p~n',[C]), + {noreply, D}. + + +%%%================================================================ + +%%%---------------------------------------------------------------- +ssh_modules_with_trace() -> + {ok,AllSshModules} = application:get_key(ssh, modules), + [M || M <- AllSshModules, + lists:member({dbg_trace,3}, M:module_info(exports))]. + %%%---------------------------------------------------------------- --define(wr_record(N,BlackList), wr_record(R=#N{}) -> wr_record(R, record_info(fields,N), BlackList)). - --define(wr_record(N), ?wr_record(N, [])). - - -?wr_record(alg); - -?wr_record(ssh_msg_disconnect); -?wr_record(ssh_msg_ignore); -?wr_record(ssh_msg_unimplemented); -?wr_record(ssh_msg_debug); -?wr_record(ssh_msg_service_request); -?wr_record(ssh_msg_service_accept); -?wr_record(ssh_msg_kexinit); -?wr_record(ssh_msg_kexdh_init); -?wr_record(ssh_msg_kexdh_reply); -?wr_record(ssh_msg_newkeys); -?wr_record(ssh_msg_ext_info); -?wr_record(ssh_msg_kex_dh_gex_request); -?wr_record(ssh_msg_kex_dh_gex_request_old); -?wr_record(ssh_msg_kex_dh_gex_group); -?wr_record(ssh_msg_kex_dh_gex_init); -?wr_record(ssh_msg_kex_dh_gex_reply); -?wr_record(ssh_msg_kex_ecdh_init); -?wr_record(ssh_msg_kex_ecdh_reply); - -?wr_record(ssh_msg_userauth_request); -?wr_record(ssh_msg_userauth_failure); -?wr_record(ssh_msg_userauth_success); -?wr_record(ssh_msg_userauth_banner); -?wr_record(ssh_msg_userauth_passwd_changereq); -?wr_record(ssh_msg_userauth_pk_ok); -?wr_record(ssh_msg_userauth_info_request); -?wr_record(ssh_msg_userauth_info_response); - -?wr_record(ssh_msg_global_request); -?wr_record(ssh_msg_request_success); -?wr_record(ssh_msg_request_failure); -?wr_record(ssh_msg_channel_open); -?wr_record(ssh_msg_channel_open_confirmation); -?wr_record(ssh_msg_channel_open_failure); -?wr_record(ssh_msg_channel_window_adjust); -?wr_record(ssh_msg_channel_data); -?wr_record(ssh_msg_channel_extended_data); -?wr_record(ssh_msg_channel_eof); -?wr_record(ssh_msg_channel_close); -?wr_record(ssh_msg_channel_request); -?wr_record(ssh_msg_channel_success); -?wr_record(ssh_msg_channel_failure); - -wr_record(R) -> io_lib:format('~p~n',[R]). +get_all_trace_flags() -> + get_all_trace_flags(ssh_modules_with_trace()). +get_all_trace_flags(Modules) -> + lists:usort( + lists:flatten( + lists:foldl( + fun(Type, Acc) -> + call_modules(flags, Type, undefined, Acc, Modules) + end, [timestamp], ?ALL_DBG_TYPES))). +%%%---------------------------------------------------------------- +get_all_dbg_types() -> + lists:usort( + lists:flatten( + call_modules(points, undefined) )). + +%%%---------------------------------------------------------------- +call_modules(Cmnd, Type) -> + call_modules(Cmnd, Type, undefined). + +call_modules(Cmnd, Type, Arg) -> + call_modules(Cmnd, Type, Arg, []). + +call_modules(Cmnd, Type, Arg, Acc0) -> + call_modules(Cmnd, Type, Arg, Acc0, ssh_modules_with_trace()). + +call_modules(Cmnd, Types, Arg, Acc0, Modules) when is_list(Types) -> + lists:foldl( + fun(Type, Acc) -> + call_modules(Cmnd, Type, Arg, Acc, Modules) + end, Acc0, Types); + +call_modules(Cmnd, Type, Arg, Acc0, Modules) -> + lists:foldl( + fun(Mod, Acc) -> + try Mod:dbg_trace(Cmnd, Type, Arg) + of + Result -> [Result|Acc] + catch + _:_ -> Acc + end + end, Acc0, Modules). + +%%%---------------------------------------------------------------- +switch(X, Type) when is_atom(Type) -> + switch(X, [Type]); + +switch(X, Types) when is_list(Types) -> + case whereis(?SERVER) of + undefined -> + start(); + _ -> + ok + end, + case lists:usort(Types) -- ?ALL_DBG_TYPES of + [] -> + gen_server:call(?SERVER, {switch,X,Types}); + L -> + {error, {unknown, L}} + end. + +%%%---------------------------------------------------------------- +%%% Format of trace messages are described in reference manual for erlang:trace/4 +%%% {call,MFA} +%%% {return_from,{M,F,N},Result} +%%% {send,Msg,To} +%%% {'receive',Msg} + +trace_pid({trace,Pid,_}) -> Pid; +trace_pid({trace,Pid,_,_}) -> Pid; +trace_pid({trace,Pid,_,_,_}) -> Pid; +trace_pid({trace,Pid,_,_,_,_}) -> Pid; +trace_pid({trace,Pid,_,_,_,_,_}) -> Pid; +trace_pid({trace_ts,Pid,_,_TS}) -> Pid; +trace_pid({trace_ts,Pid,_,_,_TS}) -> Pid; +trace_pid({trace_ts,Pid,_,_,_,_TS}) -> Pid; +trace_pid({trace_ts,Pid,_,_,_,_,_TS}) -> Pid; +trace_pid({trace_ts,Pid,_,_,_,_,_,_TS}) -> Pid. + +trace_ts({trace_ts,_Pid,_,TS}) -> ts(TS); +trace_ts({trace_ts,_Pid,_,_,TS}) -> ts(TS); +trace_ts({trace_ts,_Pid,_,_,_,TS}) -> ts(TS); +trace_ts({trace_ts,_Pid,_,_,_,_,TS}) -> ts(TS); +trace_ts({trace_ts,_Pid,_,_,_,_,_,TS}) -> ts(TS); +trace_ts(_) -> "-". + +trace_info({trace,_Pid,A}) -> A; +trace_info({trace,_Pid,A,B}) -> {A,B}; +trace_info({trace,_Pid,A,B,C}) -> {A,B,C}; +trace_info({trace,_Pid,A,B,C,D}) -> {A,B,C,D}; +trace_info({trace,_Pid,A,B,C,D,E}) -> {A,B,C,D,E}; +trace_info({trace_ts,_Pid,A,_TS}) -> A; +trace_info({trace_ts,_Pid,A,B,_TS}) -> {A,B}; +trace_info({trace_ts,_Pid,A,B,C,_TS}) -> {A,B,C}; +trace_info({trace_ts,_Pid,A,B,C,D,_TS}) -> {A,B,C,D}; +trace_info({trace_ts,_Pid,A,B,C,D,E,_TS}) -> {A,B,C,D,E}. + + +try_all_types_in_all_modules(TypesOn, Arg, WriteFun, Acc0) -> + SshModules = ssh_modules_with_trace(), + TS = trace_ts(Arg), + PID = trace_pid(Arg), + INFO = trace_info(Arg), + lists:foldl( + fun(Type, Acc1) -> + lists:foldl( + fun(SshMod,Acc) -> + try WriteFun("~n~s ~p ~s~n", + [lists:flatten(TS), PID, lists:flatten(SshMod:dbg_trace(format,Type,INFO))], + Acc) + catch + _:_ -> Acc + end + end, Acc1, SshModules) + end, Acc0, TypesOn). + +%%%---------------------------------------------------------------- wr_record(T, Fs, BL) when is_tuple(T) -> wr_record(tuple_to_list(T), Fs, BL); -wr_record([Name|Values], Fields, BlackL) -> +wr_record([_Name|Values], Fields, BlackL) -> W = case Fields of [] -> 0; _ -> lists:max([length(atom_to_list(F)) || F<-Fields]) end, - [io_lib:format("~p:~n",[string:to_upper(atom_to_list(Name))]) - | [io_lib:format(" ~*p: ~p~n",[W,Tag,Value]) || {Tag,Value} <- lists:zip(Fields,Values), - not lists:member(Tag,BlackL) - ] + [io_lib:format(" ~*p: ~p~n",[W,Tag,Value]) || {Tag,Value} <- lists:zip(Fields,Values), + not lists:member(Tag,BlackL) ]. + +%%%---------------------------------------------------------------- +ts({_,_,Usec}=Now) when is_integer(Usec) -> + {_Date,{HH,MM,SS}} = calendar:now_to_local_time(Now), + io_lib:format("~.2.0w:~.2.0w:~.2.0w.~.6.0w",[HH,MM,SS,Usec]); +ts(_) -> + "-". diff --git a/lib/ssh/src/ssh_file.erl b/lib/ssh/src/ssh_file.erl index 33792da38f..9cab2fe0bd 100644 --- a/lib/ssh/src/ssh_file.erl +++ b/lib/ssh/src/ssh_file.erl @@ -45,27 +45,6 @@ %%% API -%%% client --spec add_host_key(string(), - public_key:public_key(), - proplists:proplist()) -> ok | {error,term()}. - --spec is_host_key(public_key:public_key(), - string(), - ssh_client_key_api:algorithm(), - proplists:proplist()) -> boolean(). - --spec user_key(ssh_client_key_api:algorithm(), - proplists:proplist()) -> {ok, public_key:private_key()} | {error,term()}. - -%%% server --spec host_key(ssh_server_key_api:algorithm(), - proplists:proplist()) -> {ok, public_key:private_key()} | {error,term()}. - --spec is_auth_key(public_key:public_key(), - string(), proplists:proplist()) -> boolean(). - - %% Used by server host_key(Algorithm, Opts) -> File = file_name(system, file_base_name(Algorithm), Opts), diff --git a/lib/ssh/src/ssh_message.erl b/lib/ssh/src/ssh_message.erl index eb06f05a4a..a2251eab97 100644 --- a/lib/ssh/src/ssh_message.erl +++ b/lib/ssh/src/ssh_message.erl @@ -32,6 +32,8 @@ -export([encode/1, decode/1, decode_keyboard_interactive_prompts/2]). +-export([dbg_trace/3]). + -define('2bin'(X), (if is_binary(X) -> X; is_list(X) -> list_to_binary(X); X==undefined -> <<>> @@ -611,3 +613,86 @@ encode_signature({#'ECPoint'{}, {namedCurve,OID}}, _SigAlg, Signature) -> CurveName = public_key:oid2ssh_curvename(OID), <<?Ebinary(<<"ecdsa-sha2-",CurveName/binary>>), ?Ebinary(Signature)>>. +%%%################################################################ +%%%# +%%%# Tracing +%%%# + +dbg_trace(points, _, _) -> [ssh_messages, raw_messages]; + +dbg_trace(flags, ssh_messages, _) -> [c]; +dbg_trace(on, ssh_messages, _) -> dbg:tp(?MODULE,encode,1,x), + dbg:tp(?MODULE,decode,1,x); +dbg_trace(off, ssh_messages, _) -> dbg:ctpg(?MODULE,encode,1), + dbg:ctpg(?MODULE,decode,1); + +dbg_trace(flags, raw_messages, A) -> dbg_trace(flags, ssh_messages, A); +dbg_trace(on, raw_messages, A) -> dbg_trace(on, ssh_messages, A); +dbg_trace(off, raw_messages, A) -> dbg_trace(off, ssh_messages, A); + +dbg_trace(format, ssh_messages, {call,{?MODULE,encode,[Msg]}}) -> + Name = string:to_upper(atom_to_list(element(1,Msg))), + ["Going to send ",Name,":\n", + wr_record(ssh_dbg:shrink_bin(Msg)) + ]; +dbg_trace(format, ssh_messages, {return_from,{?MODULE,decode,1},Msg}) -> + Name = string:to_upper(atom_to_list(element(1,Msg))), + ["Received ",Name,":\n", + wr_record(ssh_dbg:shrink_bin(Msg)) + ]; + +dbg_trace(format, raw_messages, {call,{?MODULE,decode,[BytesPT]}}) -> + ["Received plain text bytes (shown after decryption):\n", + io_lib:format("~p",[BytesPT]) + ]; +dbg_trace(format, raw_messages, {return_from,{?MODULE,encode,1},BytesPT}) -> + ["Going to send plain text bytes (shown before encryption):\n", + io_lib:format("~p",[BytesPT]) + ]. + + +?wr_record(ssh_msg_disconnect); +?wr_record(ssh_msg_ignore); +?wr_record(ssh_msg_unimplemented); +?wr_record(ssh_msg_debug); +?wr_record(ssh_msg_service_request); +?wr_record(ssh_msg_service_accept); +?wr_record(ssh_msg_kexinit); +?wr_record(ssh_msg_kexdh_init); +?wr_record(ssh_msg_kexdh_reply); +?wr_record(ssh_msg_newkeys); +?wr_record(ssh_msg_ext_info); +?wr_record(ssh_msg_kex_dh_gex_request); +?wr_record(ssh_msg_kex_dh_gex_request_old); +?wr_record(ssh_msg_kex_dh_gex_group); +?wr_record(ssh_msg_kex_dh_gex_init); +?wr_record(ssh_msg_kex_dh_gex_reply); +?wr_record(ssh_msg_kex_ecdh_init); +?wr_record(ssh_msg_kex_ecdh_reply); + +?wr_record(ssh_msg_userauth_request); +?wr_record(ssh_msg_userauth_failure); +?wr_record(ssh_msg_userauth_success); +?wr_record(ssh_msg_userauth_banner); +?wr_record(ssh_msg_userauth_passwd_changereq); +?wr_record(ssh_msg_userauth_pk_ok); +?wr_record(ssh_msg_userauth_info_request); +?wr_record(ssh_msg_userauth_info_response); + +?wr_record(ssh_msg_global_request); +?wr_record(ssh_msg_request_success); +?wr_record(ssh_msg_request_failure); +?wr_record(ssh_msg_channel_open); +?wr_record(ssh_msg_channel_open_confirmation); +?wr_record(ssh_msg_channel_open_failure); +?wr_record(ssh_msg_channel_window_adjust); +?wr_record(ssh_msg_channel_data); +?wr_record(ssh_msg_channel_extended_data); +?wr_record(ssh_msg_channel_eof); +?wr_record(ssh_msg_channel_close); +?wr_record(ssh_msg_channel_request); +?wr_record(ssh_msg_channel_success); +?wr_record(ssh_msg_channel_failure); + +wr_record(R) -> io_lib:format('~p~n',[R]). + diff --git a/lib/ssh/src/ssh_no_io.erl b/lib/ssh/src/ssh_no_io.erl index 1da257ed99..25be0023e9 100644 --- a/lib/ssh/src/ssh_no_io.erl +++ b/lib/ssh/src/ssh_no_io.erl @@ -31,35 +31,24 @@ -spec yes_no(any(), any()) -> no_return(). yes_no(_, _) -> - ssh_connection_handler:disconnect( - #ssh_msg_disconnect{code = ?SSH_DISCONNECT_SERVICE_NOT_AVAILABLE, - description = "User interaction is not allowed"}, - {no_io_allowed, yes_no}). + ?DISCONNECT(?SSH_DISCONNECT_SERVICE_NOT_AVAILABLE, + "User interaction is not allowed"). -spec read_password(any(), any()) -> no_return(). read_password(_, _) -> - ssh_connection_handler:disconnect( - #ssh_msg_disconnect{code = ?SSH_DISCONNECT_SERVICE_NOT_AVAILABLE, - description = "User interaction is not allowed"}, - {no_io_allowed, read_password}). - + ?DISCONNECT(?SSH_DISCONNECT_SERVICE_NOT_AVAILABLE, + "User interaction is not allowed"). -spec read_line(any(), any()) -> no_return(). read_line(_, _) -> - ssh_connection_handler:disconnect( - #ssh_msg_disconnect{code = ?SSH_DISCONNECT_SERVICE_NOT_AVAILABLE, - description = "User interaction is not allowed"}, - {no_io_allowed, read_line}). - + ?DISCONNECT(?SSH_DISCONNECT_SERVICE_NOT_AVAILABLE, + "User interaction is not allowed"). -spec format(any(), any()) -> no_return(). format(_, _) -> - ssh_connection_handler:disconnect( - #ssh_msg_disconnect{code = ?SSH_DISCONNECT_SERVICE_NOT_AVAILABLE, - description = "User interaction is not allowed"}, - {no_io_allowed, format}). - + ?DISCONNECT(?SSH_DISCONNECT_SERVICE_NOT_AVAILABLE, + "User interaction is not allowed"). diff --git a/lib/ssh/src/ssh_options.erl b/lib/ssh/src/ssh_options.erl index 1e10f72956..4dd9082250 100644 --- a/lib/ssh/src/ssh_options.erl +++ b/lib/ssh/src/ssh_options.erl @@ -32,7 +32,7 @@ handle_options/2 ]). --export_type([options/0 +-export_type([private_options/0 ]). %%%================================================================ @@ -47,16 +47,23 @@ default => any() }. +-type option_key() :: atom(). + -type option_declarations() :: #{ {option_key(),def} := option_declaration() }. -type error() :: {error,{eoptions,any()}} . +-type private_options() :: #{socket_options := socket_options(), + internal_options := internal_options(), + option_key() => any() + }. + %%%================================================================ %%% %%% Get an option %%% --spec get_value(option_class(), option_key(), options(), +-spec get_value(option_class(), option_key(), private_options(), atom(), non_neg_integer()) -> any() | no_return(). get_value(Class, Key, Opts, _CallerMod, _CallerLine) when is_map(Opts) -> @@ -69,7 +76,7 @@ get_value(Class, Key, Opts, _CallerMod, _CallerLine) -> error({bad_options,Class, Key, Opts, _CallerMod, _CallerLine}). --spec get_value(option_class(), option_key(), options(), fun(() -> any()), +-spec get_value(option_class(), option_key(), private_options(), fun(() -> any()), atom(), non_neg_integer()) -> any() | no_return(). get_value(socket_options, Key, Opts, DefFun, _CallerMod, _CallerLine) when is_map(Opts) -> @@ -91,8 +98,8 @@ get_value(Class, Key, Opts, _DefFun, _CallerMod, _CallerLine) -> %%% Put an option %%% --spec put_value(option_class(), option_in(), options(), - atom(), non_neg_integer()) -> options(). +-spec put_value(option_class(), option_in(), private_options(), + atom(), non_neg_integer()) -> private_options(). put_value(user_options, KeyVal, Opts, _CallerMod, _CallerLine) when is_map(Opts) -> put_user_value(KeyVal, Opts); @@ -131,8 +138,8 @@ put_socket_value(A, SockOpts) when is_atom(A) -> %%% Delete an option %%% --spec delete_key(option_class(), option_key(), options(), - atom(), non_neg_integer()) -> options(). +-spec delete_key(option_class(), option_key(), private_options(), + atom(), non_neg_integer()) -> private_options(). delete_key(internal_options, Key, Opts, _CallerMod, _CallerLine) when is_map(Opts) -> InternalOpts = maps:get(internal_options,Opts), @@ -144,9 +151,7 @@ delete_key(internal_options, Key, Opts, _CallerMod, _CallerLine) when is_map(Opt %%% Initialize the options %%% --spec handle_options(role(), proplists:proplist()) -> options() | error() . - --spec handle_options(role(), proplists:proplist(), options()) -> options() | error() . +-spec handle_options(role(), client_options()|daemon_options()) -> private_options() | error() . handle_options(Role, PropList0) -> handle_options(Role, PropList0, #{socket_options => [], @@ -155,7 +160,7 @@ handle_options(Role, PropList0) -> }). handle_options(Role, PropList0, Opts0) when is_map(Opts0), - is_list(PropList0) -> + is_list(PropList0) -> PropList1 = proplists:unfold(PropList0), try OptionDefinitions = default(Role), @@ -275,10 +280,12 @@ default(server) -> class => user_options }, - {exec, def} => % FIXME: need some archeology.... + {exec, def} => #{default => undefined, - chk => fun({M,F,_}) -> is_atom(M) andalso is_atom(F); - (V) -> is_function(V) + chk => fun({direct, V}) -> check_function1(V) orelse check_function2(V) orelse check_function3(V); + %% Compatibility (undocumented): + ({M,F,A}) -> is_atom(M) andalso is_atom(F) andalso is_list(A); + (V) -> check_function1(V) orelse check_function2(V) orelse check_function3(V) end, class => user_options }, diff --git a/lib/ssh/src/ssh_server_key_api.erl b/lib/ssh/src/ssh_server_key_api.erl index 3f1b886fa7..a285bf9475 100644 --- a/lib/ssh/src/ssh_server_key_api.erl +++ b/lib/ssh/src/ssh_server_key_api.erl @@ -23,16 +23,18 @@ -include_lib("public_key/include/public_key.hrl"). -include("ssh.hrl"). --export_type([algorithm/0]). +-export_type([daemon_key_cb_options/0]). --type algorithm() :: ssh_client_key_api:algorithm(). +-type daemon_key_cb_options() :: [{key_cb_private,term()} | ssh:daemon_option()]. --callback host_key(Algorithm :: algorithm(), - DaemonOptions :: proplists:proplist()) -> +-callback host_key(Algorithm :: ssh:pubkey_alg(), + DaemonOptions :: daemon_key_cb_options() + ) -> {ok, PrivateKey :: public_key:private_key()} | {error, term()}. -callback is_auth_key(PublicKey :: public_key:public_key(), User :: string(), - DaemonOptions :: proplists:proplist()) -> + DaemonOptions :: daemon_key_cb_options() + ) -> boolean(). diff --git a/lib/ssh/src/ssh_sftp.erl b/lib/ssh/src/ssh_sftp.erl index 9e1229dc85..f00c0aed1f 100644 --- a/lib/ssh/src/ssh_sftp.erl +++ b/lib/ssh/src/ssh_sftp.erl @@ -52,6 +52,8 @@ %% TODO: Should be placed elsewhere ssh_sftpd should not call functions in ssh_sftp! -export([info_to_attr/1, attr_to_info/1]). +-export([dbg_trace/3]). + -record(state, { xf, @@ -1460,3 +1462,21 @@ format_channel_start_error({shutdown, Reason}) -> Reason; format_channel_start_error(Reason) -> Reason. + +%%%################################################################ +%%%# +%%%# Tracing +%%%# + +dbg_trace(points, _, _) -> [terminate]; + +dbg_trace(flags, terminate, _) -> [c]; +dbg_trace(on, terminate, _) -> dbg:tp(?MODULE, terminate, 2, x); +dbg_trace(off, terminate, _) -> dbg:ctpg(?MODULE, terminate, 2); +dbg_trace(format, terminate, {call, {?MODULE,terminate, [Reason, State]}}) -> + ["Sftp Terminating:\n", + io_lib:format("Reason: ~p,~nState:~n~s", [Reason, wr_record(State)]) + ]. + +?wr_record(state). + diff --git a/lib/ssh/src/ssh_sftpd.erl b/lib/ssh/src/ssh_sftpd.erl index 427edf01ab..fda9a38a43 100644 --- a/lib/ssh/src/ssh_sftpd.erl +++ b/lib/ssh/src/ssh_sftpd.erl @@ -38,6 +38,8 @@ -export([init/1, handle_ssh_msg/2, handle_msg/2, terminate/2]). +-export([dbg_trace/3]). + -record(state, { xf, % [{channel,ssh_xfer states}...] cwd, % current dir (on first connect) @@ -56,21 +58,7 @@ %%==================================================================== %% API %%==================================================================== --spec init(Args :: term()) -> - {ok, State :: term()} | {ok, State :: term(), timeout() | hibernate} | - {stop, Reason :: term()} | ignore. - --spec terminate(Reason :: (normal | shutdown | {shutdown, term()} | - term()), - State :: term()) -> - term(). - --spec handle_msg(Msg ::term(), State :: term()) -> - {ok, State::term()} | {stop, ChannelId::integer(), State::term()}. --spec handle_ssh_msg({ssh_cm, ConnectionRef::term(), SshMsg::term()}, - State::term()) -> {ok, State::term()} | - {stop, ChannelId::integer(), - State::term()}. +-spec subsystem_spec(list()) -> subsystem_spec(). subsystem_spec(Options) -> {"sftp", {?MODULE, Options}}. @@ -360,10 +348,12 @@ handle_op(?SSH_FXP_REMOVE, ReqId, <<?UINT32(PLen), BPath:PLen/binary>>, case IsDir of %% This version 6 we still have ver 5 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 -> {Status, FS1} = FileMod:delete(Path, FS0), State1 = State0#state{file_state = FS1}, @@ -947,3 +937,20 @@ maybe_increase_recv_window(ConnectionManager, ChannelId, Options) -> Increment =< 0 -> do_nothing end. + +%%%################################################################ +%%%# +%%%# Tracing +%%%# + +dbg_trace(points, _, _) -> [terminate]; + +dbg_trace(flags, terminate, _) -> [c]; +dbg_trace(on, terminate, _) -> dbg:tp(?MODULE, terminate, 2, x); +dbg_trace(off, terminate, _) -> dbg:ctpg(?MODULE, terminate, 2); +dbg_trace(format, terminate, {call, {?MODULE,terminate, [Reason, State]}}) -> + ["SftpD Terminating:\n", + io_lib:format("Reason: ~p,~nState:~n~s", [Reason, wr_record(State)]) + ]. + +?wr_record(state). diff --git a/lib/ssh/src/ssh_shell.erl b/lib/ssh/src/ssh_shell.erl index 17224b6ef4..c7c63c5c43 100644 --- a/lib/ssh/src/ssh_shell.erl +++ b/lib/ssh/src/ssh_shell.erl @@ -22,6 +22,7 @@ -module(ssh_shell). +-include("ssh.hrl"). -include("ssh_connect.hrl"). %%% As this is an user interactive client it behaves like a daemon @@ -34,6 +35,8 @@ %% Spawn export -export([input_loop/2]). +-export([dbg_trace/3]). + -record(state, { io, %% Io process @@ -45,21 +48,6 @@ %%==================================================================== %% ssh_channel callbacks %%==================================================================== --spec init(Args :: term()) -> - {ok, State :: term()} | {ok, State :: term(), timeout() | hibernate} | - {stop, Reason :: term()} | ignore. - --spec terminate(Reason :: (normal | shutdown | {shutdown, term()} | - term()), - State :: term()) -> - term(). - --spec handle_msg(Msg ::term(), State :: term()) -> - {ok, State::term()} | {stop, ChannelId::integer(), State::term()}. --spec handle_ssh_msg({ssh_cm, ConnectionRef::term(), SshMsg::term()}, - State::term()) -> {ok, State::term()} | - {stop, ChannelId::integer(), - State::term()}. %%-------------------------------------------------------------------- %% Function: init(Args) -> {ok, State} @@ -194,3 +182,20 @@ get_ancestors() -> A when is_list(A) -> A; _ -> [] end. + +%%%################################################################ +%%%# +%%%# Tracing +%%%# + +dbg_trace(points, _, _) -> [terminate]; + +dbg_trace(flags, terminate, _) -> [c]; +dbg_trace(on, terminate, _) -> dbg:tp(?MODULE, terminate, 2, x); +dbg_trace(off, terminate, _) -> dbg:ctpg(?MODULE, terminate, 2); +dbg_trace(format, terminate, {call, {?MODULE,terminate, [Reason, State]}}) -> + ["Shell Terminating:\n", + io_lib:format("Reason: ~p,~nState:~n~s", [Reason, wr_record(State)]) + ]. + +?wr_record(state). diff --git a/lib/ssh/src/ssh_system_sup.erl b/lib/ssh/src/ssh_system_sup.erl index 17f990c5d8..469f9560e9 100644 --- a/lib/ssh/src/ssh_system_sup.erl +++ b/lib/ssh/src/ssh_system_sup.erl @@ -88,11 +88,11 @@ stop_listener(Address, Port, Profile) -> stop_system(SysSup) -> - spawn(fun() -> sshd_sup:stop_child(SysSup) end), + catch sshd_sup:stop_child(SysSup), ok. stop_system(Address, Port, Profile) -> - spawn(fun() -> sshd_sup:stop_child(Address, Port, Profile) end), + catch sshd_sup:stop_child(Address, Port, Profile), ok. diff --git a/lib/ssh/src/ssh_transport.erl b/lib/ssh/src/ssh_transport.erl index 975053d301..f5bba9f824 100644 --- a/lib/ssh/src/ssh_transport.erl +++ b/lib/ssh/src/ssh_transport.erl @@ -53,6 +53,8 @@ valid_key_sha_alg/2, sha/1, sign/3, verify/5]). +-export([dbg_trace/3]). + %%% For test suites -export([pack/3, adjust_algs_for_peer_version/2]). -export([decompress/2, decrypt_blocks/3, is_valid_mac/3 ]). % FIXME: remove @@ -319,10 +321,11 @@ handle_kexinit_msg(#ssh_msg_kexinit{} = CounterPart, #ssh_msg_kexinit{} = Own, key_exchange_first_msg(Algos#alg.kex, Ssh#ssh{algorithms = Algos}) catch - _:_ -> - ssh_connection_handler:disconnect( - #ssh_msg_disconnect{code = ?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, - description = "Selection of key exchange algorithm failed"}) + Class:Error -> + ?DISCONNECT(?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, + io_lib:format("Kexinit failed in client: ~p:~p", + [Class,Error]) + ) end; handle_kexinit_msg(#ssh_msg_kexinit{} = CounterPart, #ssh_msg_kexinit{} = Own, @@ -335,10 +338,11 @@ handle_kexinit_msg(#ssh_msg_kexinit{} = CounterPart, #ssh_msg_kexinit{} = Own, Algos -> {ok, Ssh#ssh{algorithms = Algos}} catch - _:_ -> - ssh_connection_handler:disconnect( - #ssh_msg_disconnect{code = ?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, - description = "Selection of key exchange algorithm failed"}) + Class:Error -> + ?DISCONNECT(?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, + io_lib:format("Kexinit failed in server: ~p:~p", + [Class,Error]) + ) end. @@ -439,12 +443,10 @@ handle_kexdh_init(#ssh_msg_kexdh_init{e = E}, session_id = sid(Ssh1, H)}}; true -> - ssh_connection_handler:disconnect( - #ssh_msg_disconnect{ - code = ?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, - description = "Key exchange failed, 'e' out of bounds"}, - {error,bad_e_from_peer} - ) + ?DISCONNECT(?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, + io_lib:format("Kexdh init failed, received 'e' out of bounds~n E=~p~n P=~p", + [E,P]) + ) end. handle_kexdh_reply(#ssh_msg_kexdh_reply{public_host_key = PeerPubHostKey, @@ -464,20 +466,16 @@ handle_kexdh_reply(#ssh_msg_kexdh_reply{public_host_key = PeerPubHostKey, exchanged_hash = H, session_id = sid(Ssh, H)})}; Error -> - ssh_connection_handler:disconnect( - #ssh_msg_disconnect{ - code = ?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, - description = "Key exchange failed"}, - Error) + ?DISCONNECT(?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, + io_lib:format("Kexdh init failed. Verify host key: ~p",[Error]) + ) end; true -> - ssh_connection_handler:disconnect( - #ssh_msg_disconnect{ - code = ?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, - description = "Key exchange failed, 'f' out of bounds"}, - bad_f_from_peer - ) + ?DISCONNECT(?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, + io_lib:format("Kexdh init failed, received 'f' out of bounds~n F=~p~n P=~p", + [F,P]) + ) end. @@ -501,11 +499,9 @@ handle_kex_dh_gex_request(#ssh_msg_kex_dh_gex_request{min = Min0, keyex_info = {Min0, Max0, NBits} }}; {error,_} -> - ssh_connection_handler:disconnect( - #ssh_msg_disconnect{ - code = ?SSH_DISCONNECT_PROTOCOL_ERROR, - description = "No possible diffie-hellman-group-exchange group found" - }) + ?DISCONNECT(?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, + io_lib:format("No possible diffie-hellman-group-exchange group found",[]) + ) end; handle_kex_dh_gex_request(#ssh_msg_kex_dh_gex_request_old{n = NBits}, @@ -535,20 +531,14 @@ handle_kex_dh_gex_request(#ssh_msg_kex_dh_gex_request_old{n = NBits}, keyex_info = {-1, -1, NBits} % flag for kex_hash calc }}; {error,_} -> - ssh_connection_handler:disconnect( - #ssh_msg_disconnect{ - code = ?SSH_DISCONNECT_PROTOCOL_ERROR, - description = "No possible diffie-hellman-group-exchange group found" - }) + ?DISCONNECT(?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, + io_lib:format("No possible diffie-hellman-group-exchange group found",[]) + ) end; handle_kex_dh_gex_request(_, _) -> - ssh_connection_handler:disconnect( - #ssh_msg_disconnect{ - code = ?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, - description = "Key exchange failed, bad values in ssh_msg_kex_dh_gex_request"}, - bad_ssh_msg_kex_dh_gex_request). - + ?DISCONNECT(?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, + "Key exchange failed, bad values in ssh_msg_kex_dh_gex_request"). adjust_gex_min_max(Min0, Max0, Opts) -> {Min1, Max1} = ?GET_OPT(dh_gex_limits, Opts), @@ -558,11 +548,8 @@ adjust_gex_min_max(Min0, Max0, Opts) -> 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" - }) + ?DISCONNECT(?SSH_DISCONNECT_PROTOCOL_ERROR, + "No possible diffie-hellman-group-exchange group possible") end. @@ -600,18 +587,15 @@ handle_kex_dh_gex_init(#ssh_msg_kex_dh_gex_init{e = E}, session_id = sid(Ssh, H) }}; true -> - ssh_connection_handler:disconnect( - #ssh_msg_disconnect{ - code = ?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, - description = "Key exchange failed, 'K' out of bounds"}, - bad_K) + ?DISCONNECT(?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, + "Kexdh init failed, received 'k' out of bounds" + ) end; true -> - ssh_connection_handler:disconnect( - #ssh_msg_disconnect{ - code = ?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, - description = "Key exchange failed, 'e' out of bounds"}, - bad_e_from_peer) + ?DISCONNECT(?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, + io_lib:format("Kexdh gex init failed, received 'e' out of bounds~n E=~p~n P=~p", + [E,P]) + ) end. handle_kex_dh_gex_reply(#ssh_msg_kex_dh_gex_reply{public_host_key = PeerPubHostKey, @@ -634,28 +618,22 @@ handle_kex_dh_gex_reply(#ssh_msg_kex_dh_gex_reply{public_host_key = PeerPubHostK {ok, SshPacket, install_alg(snd, Ssh#ssh{shared_secret = ssh_bits:mpint(K), exchanged_hash = H, session_id = sid(Ssh, H)})}; - _Error -> - ssh_connection_handler:disconnect( - #ssh_msg_disconnect{ - code = ?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, - description = "Key exchange failed" - }) + Error -> + ?DISCONNECT(?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, + io_lib:format("Kexdh gex reply failed. Verify host key: ~p",[Error]) + ) end; true -> - ssh_connection_handler:disconnect( - #ssh_msg_disconnect{ - code = ?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, - description = "Key exchange failed, 'K' out of bounds"}, - bad_K) + ?DISCONNECT(?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, + "Kexdh gex init failed, 'K' out of bounds" + ) end; true -> - ssh_connection_handler:disconnect( - #ssh_msg_disconnect{ - code = ?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, - description = "Key exchange failed, 'f' out of bounds"}, - bad_f_from_peer - ) + ?DISCONNECT(?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, + io_lib:format("Kexdh gex init failed, received 'f' out of bounds~n F=~p~n P=~p", + [F,P]) + ) end. %%%---------------------------------------------------------------- @@ -686,12 +664,11 @@ handle_kex_ecdh_init(#ssh_msg_kex_ecdh_init{q_c = PeerPublic}, exchanged_hash = H, session_id = sid(Ssh1, H)}} catch - _:_ -> - ssh_connection_handler:disconnect( - #ssh_msg_disconnect{ - code = ?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, - description = "Peer ECDH public key is invalid"}, - invalid_peer_public_key) + Class:Error -> + ?DISCONNECT(?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, + io_lib:format("ECDH compute key failed in server: ~p:~p", + [Class,Error]) + ) end. handle_kex_ecdh_reply(#ssh_msg_kex_ecdh_reply{public_host_key = PeerPubHostKey, @@ -713,19 +690,16 @@ handle_kex_ecdh_reply(#ssh_msg_kex_ecdh_reply{public_host_key = PeerPubHostKey, exchanged_hash = H, session_id = sid(Ssh, H)})}; Error -> - ssh_connection_handler:disconnect( - #ssh_msg_disconnect{ - code = ?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, - description = "Key exchange failed"}, - Error) + ?DISCONNECT(?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, + io_lib:format("ECDH reply failed. Verify host key: ~p",[Error]) + ) end catch - _:_ -> - ssh_connection_handler:disconnect( - #ssh_msg_disconnect{ - code = ?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, - description = "Peer ECDH public key is invalid"}, - invalid_peer_public_key) + Class:Error -> + ?DISCONNECT(?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, + io_lib:format("Peer ECDH public key seem invalid: ~p:~p", + [Class,Error]) + ) end. @@ -735,11 +709,11 @@ handle_new_keys(#ssh_msg_newkeys{}, Ssh0) -> #ssh{} = Ssh -> {ok, Ssh} catch - _C:_Error -> %% TODO: Throw earlier .... - ssh_connection_handler:disconnect( - #ssh_msg_disconnect{code = ?SSH_DISCONNECT_PROTOCOL_ERROR, - description = "Install alg failed" - }) + Class:Error -> %% TODO: Throw earlier ... + ?DISCONNECT(?SSH_DISCONNECT_PROTOCOL_ERROR, + io_lib:format("Install alg failed: ~p:~p", + [Class,Error]) + ) end. @@ -1057,9 +1031,7 @@ install_alg(Dir, SSH) -> alg_setup(snd, SSH) -> ALG = SSH#ssh.algorithms, - SSH#ssh{kex = ALG#alg.kex, - hkey = ALG#alg.hkey, - encrypt = ALG#alg.encrypt, + SSH#ssh{encrypt = ALG#alg.encrypt, send_mac = ALG#alg.send_mac, send_mac_size = mac_digest_size(ALG#alg.send_mac), compress = ALG#alg.compress, @@ -1071,9 +1043,7 @@ alg_setup(snd, SSH) -> alg_setup(rcv, SSH) -> ALG = SSH#ssh.algorithms, - SSH#ssh{kex = ALG#alg.kex, - hkey = ALG#alg.hkey, - decrypt = ALG#alg.decrypt, + SSH#ssh{decrypt = ALG#alg.decrypt, recv_mac = ALG#alg.recv_mac, recv_mac_size = mac_digest_size(ALG#alg.recv_mac), decompress = ALG#alg.decompress, @@ -1115,10 +1085,9 @@ select_all(CL, SL) when length(CL) + length(SL) < ?MAX_NUM_ALGORITHMS -> %% algorithms used by client and server (client pref) lists:map(fun(ALG) -> list_to_atom(ALG) end, (CL -- A)); select_all(CL, SL) -> - Err = lists:concat(["Received too many algorithms (",length(CL),"+",length(SL)," >= ",?MAX_NUM_ALGORITHMS,")."]), - ssh_connection_handler:disconnect( - #ssh_msg_disconnect{code = ?SSH_DISCONNECT_PROTOCOL_ERROR, - description = Err}). + Error = lists:concat(["Received too many algorithms (",length(CL),"+",length(SL)," >= ",?MAX_NUM_ALGORITHMS,")."]), + ?DISCONNECT(?SSH_DISCONNECT_PROTOCOL_ERROR, + Error). select([], []) -> @@ -1810,7 +1779,7 @@ mac('hmac-sha2-512', Key, SeqNum, Data) -> hash(_SSH, _Char, 0) -> <<>>; hash(SSH, Char, N) -> - HashAlg = sha(SSH#ssh.kex), + HashAlg = sha(SSH#ssh.algorithms#alg.kex), K = SSH#ssh.shared_secret, H = SSH#ssh.exchanged_hash, K1 = crypto:hash(HashAlg, [K, H, Char, SSH#ssh.session_id]), @@ -2041,3 +2010,40 @@ trim_tail(Str) -> lists:takewhile(fun(C) -> C=/=$\r andalso C=/=$\n end, Str). + +%%%################################################################ +%%%# +%%%# Tracing +%%%# + +dbg_trace(points, _, _) -> [alg, ssh_messages, raw_messages, hello]; + +dbg_trace(flags, hello, _) -> [c]; +dbg_trace(on, hello, _) -> dbg:tp(?MODULE,hello_version_msg,1,x), + dbg:tp(?MODULE,handle_hello_version,1,x); +dbg_trace(off, hello, _) -> dbg:ctpg(?MODULE,hello_version_msg,1), + dbg:ctpg(?MODULE,handle_hello_version,1); + +dbg_trace(C, raw_messages, A) -> dbg_trace(C, hello, A); +dbg_trace(C, ssh_messages, A) -> dbg_trace(C, hello, A); + +dbg_trace(flags, alg, _) -> [c]; +dbg_trace(on, alg, _) -> dbg:tpl(?MODULE,select_algorithm,4,x); +dbg_trace(off, alg, _) -> dbg:ctpl(?MODULE,select_algorithm,4); + + +dbg_trace(format, hello, {return_from,{?MODULE,hello_version_msg,1},Hello}) -> + ["Going to send hello message:\n", + Hello + ]; +dbg_trace(format, hello, {call,{?MODULE,handle_hello_version,[Hello]}}) -> + ["Received hello message:\n", + Hello + ]; + +dbg_trace(format, alg, {return_from,{?MODULE,select_algorithm,4},{ok,Alg}}) -> + ["Negotiated algorithms:\n", + wr_record(Alg) + ]. + +?wr_record(alg). diff --git a/lib/ssh/src/ssh_transport.hrl b/lib/ssh/src/ssh_transport.hrl index 87c3719514..7d5a4c153e 100644 --- a/lib/ssh/src/ssh_transport.hrl +++ b/lib/ssh/src/ssh_transport.hrl @@ -220,6 +220,9 @@ %% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +-define(DISCONNECT(Code, DetailedText), + ssh_connection_handler:disconnect(Code, DetailedText, ?MODULE, ?LINE)). + -define(SSH_DISCONNECT_HOST_NOT_ALLOWED_TO_CONNECT, 1). -define(SSH_DISCONNECT_PROTOCOL_ERROR, 2). -define(SSH_DISCONNECT_KEY_EXCHANGE_FAILED, 3). diff --git a/lib/ssh/src/sshc_sup.erl b/lib/ssh/src/sshc_sup.erl index fd4d8a3c07..f4b39dbbdc 100644 --- a/lib/ssh/src/sshc_sup.erl +++ b/lib/ssh/src/sshc_sup.erl @@ -27,7 +27,7 @@ -behaviour(supervisor). --export([start_link/0, start_child/1, stop_child/1]). +-export([start_link/0, start_child/1]). %% Supervisor callback -export([init/1]). @@ -43,13 +43,6 @@ start_link() -> start_child(Args) -> supervisor:start_child(?MODULE, Args). -stop_child(Client) -> - spawn(fun() -> - ClientSup = whereis(?SSHC_SUP), - supervisor:terminate_child(ClientSup, Client) - end), - ok. - %%%========================================================================= %%% Supervisor callback %%%========================================================================= diff --git a/lib/ssh/test/Makefile b/lib/ssh/test/Makefile index 21359a0386..0a99d31a63 100644 --- a/lib/ssh/test/Makefile +++ b/lib/ssh/test/Makefile @@ -34,11 +34,11 @@ VSN=$(GS_VSN) MODULES= \ ssh_algorithms_SUITE \ ssh_options_SUITE \ - ssh_renegotiate_SUITE \ ssh_basic_SUITE \ ssh_bench_SUITE \ ssh_compat_SUITE \ ssh_connection_SUITE \ + ssh_dbg_SUITE \ ssh_engine_SUITE \ ssh_protocol_SUITE \ ssh_property_test_SUITE \ diff --git a/lib/ssh/test/ssh_algorithms_SUITE.erl b/lib/ssh/test/ssh_algorithms_SUITE.erl index de6e448ebd..0ce4bd8699 100644 --- a/lib/ssh/test/ssh_algorithms_SUITE.erl +++ b/lib/ssh/test/ssh_algorithms_SUITE.erl @@ -35,7 +35,7 @@ suite() -> [{ct_hooks,[ts_install_cth]}, - {timetrap,{seconds,round(1.5*?TIMEOUT/1000)}}]. + {timetrap,{seconds,60}}]. all() -> %% [{group,kex},{group,cipher}... etc @@ -257,15 +257,14 @@ try_exec_simple_group(Group, Config) -> of _ -> ct:fail("Exec though no group available") catch - error:{badmatch,{error,"No possible diffie-hellman-group-exchange group found"}} -> ok; - error:{badmatch,{error,"Connection closed"}} -> ok + error:{badmatch,{error,"Key exchange failed"}} -> ok end. %%-------------------------------------------------------------------- %% Testing all default groups simple_exec_groups() -> - [{timetrap,{seconds,120}}]. + [{timetrap,{seconds,180}}]. simple_exec_groups(Config) -> Sizes = interpolate( public_key:dh_gex_group_sizes() ), diff --git a/lib/ssh/test/ssh_basic_SUITE.erl b/lib/ssh/test/ssh_basic_SUITE.erl index 365f25fabb..1fa94bef11 100644 --- a/lib/ssh/test/ssh_basic_SUITE.erl +++ b/lib/ssh/test/ssh_basic_SUITE.erl @@ -28,60 +28,12 @@ -include("ssh_test_lib.hrl"). %% Note: This directive should only be used in test suites. -%%-compile(export_all). - -%%% Test cases --export([ - app_test/1, - appup_test/1, - cli/1, - close/1, - daemon_already_started/1, - daemon_opt_fd/1, - multi_daemon_opt_fd/1, - double_close/1, - exec/1, - exec_compressed/1, - exec_key_differs1/1, - exec_key_differs2/1, - exec_key_differs3/1, - exec_key_differs_fail/1, - fail_daemon_start/1, - idle_time_client/1, - idle_time_server/1, - inet6_option/1, - inet_option/1, - internal_error/1, - known_hosts/1, - login_bad_pwd_no_retry1/1, - login_bad_pwd_no_retry2/1, - login_bad_pwd_no_retry3/1, - login_bad_pwd_no_retry4/1, - login_bad_pwd_no_retry5/1, - misc_ssh_options/1, - openssh_zlib_basic_test/1, - packet_size/1, - pass_phrase/1, - peername_sockname/1, - send/1, - shell/1, - shell_no_unicode/1, - shell_unicode_string/1, - ssh_info_print/1, - key_callback/1, - key_callback_options/1, - shell_exit_status/1 - ]). - -%%% Common test callbacks --export([suite/0, all/0, groups/0, - init_per_suite/1, end_per_suite/1, - init_per_group/2, end_per_group/2, - init_per_testcase/2, end_per_testcase/2 - ]). +-compile(export_all). -define(NEWLINE, <<"\r\n">>). +-define(REKEY_DATA_TMO, 65000). + %%-------------------------------------------------------------------- %% Common Test interface functions ----------------------------------- %%-------------------------------------------------------------------- @@ -91,76 +43,97 @@ suite() -> {timetrap,{seconds,40}}]. all() -> - [app_test, - appup_test, - {group, dsa_key}, - {group, rsa_key}, - {group, ecdsa_sha2_nistp256_key}, - {group, ecdsa_sha2_nistp384_key}, - {group, ecdsa_sha2_nistp521_key}, - {group, dsa_pass_key}, - {group, rsa_pass_key}, - {group, ecdsa_sha2_nistp256_pass_key}, - {group, ecdsa_sha2_nistp384_pass_key}, - {group, ecdsa_sha2_nistp521_pass_key}, - {group, host_user_key_differs}, - {group, key_cb}, - {group, internal_error}, - {group, rsa_host_key_is_actualy_ecdsa}, - daemon_already_started, - double_close, - daemon_opt_fd, - multi_daemon_opt_fd, - packet_size, - ssh_info_print, - {group, login_bad_pwd_no_retry}, - shell_exit_status - ]. + [{group, all_tests}]. + groups() -> - [{dsa_key, [], basic_tests()}, - {rsa_key, [], basic_tests()}, - {ecdsa_sha2_nistp256_key, [], basic_tests()}, - {ecdsa_sha2_nistp384_key, [], basic_tests()}, - {ecdsa_sha2_nistp521_key, [], basic_tests()}, + [{all_tests, [parallel], [{group, ssh_renegotiate_SUITE}, + {group, ssh_basic_SUITE} + ]}, + {ssh_basic_SUITE, [], [app_test, + appup_test, + {group, dsa_key}, + {group, rsa_key}, + {group, ecdsa_sha2_nistp256_key}, + {group, ecdsa_sha2_nistp384_key}, + {group, ecdsa_sha2_nistp521_key}, + {group, dsa_pass_key}, + {group, rsa_pass_key}, + {group, ecdsa_sha2_nistp256_pass_key}, + {group, ecdsa_sha2_nistp384_pass_key}, + {group, ecdsa_sha2_nistp521_pass_key}, + {group, host_user_key_differs}, + {group, key_cb}, + {group, internal_error}, + {group, rsa_host_key_is_actualy_ecdsa}, + daemon_already_started, + double_close, + daemon_opt_fd, + multi_daemon_opt_fd, + packet_size, + ssh_info_print, + {group, login_bad_pwd_no_retry}, + shell_exit_status + ]}, + + {ssh_renegotiate_SUITE, [parallel], [rekey, + rekey_limit, + renegotiate1, + renegotiate2]}, + + {dsa_key, [], [{group, basic}]}, + {rsa_key, [], [{group, basic}]}, + {ecdsa_sha2_nistp256_key, [], [{group, basic}]}, + {ecdsa_sha2_nistp384_key, [], [{group, basic}]}, + {ecdsa_sha2_nistp521_key, [], [{group, basic}]}, {rsa_host_key_is_actualy_ecdsa, [], [fail_daemon_start]}, - {host_user_key_differs, [], [exec_key_differs1, - exec_key_differs2, - exec_key_differs3, - exec_key_differs_fail]}, + {host_user_key_differs, [parallel], [exec_key_differs1, + exec_key_differs2, + exec_key_differs3, + exec_key_differs_fail]}, {dsa_pass_key, [], [pass_phrase]}, {rsa_pass_key, [], [pass_phrase]}, {ecdsa_sha2_nistp256_pass_key, [], [pass_phrase]}, {ecdsa_sha2_nistp384_pass_key, [], [pass_phrase]}, {ecdsa_sha2_nistp521_pass_key, [], [pass_phrase]}, - {key_cb, [], [key_callback, key_callback_options]}, + {key_cb, [parallel], [key_callback, key_callback_options]}, {internal_error, [], [internal_error]}, - {login_bad_pwd_no_retry, [], [login_bad_pwd_no_retry1, - login_bad_pwd_no_retry2, - login_bad_pwd_no_retry3, - login_bad_pwd_no_retry4, - login_bad_pwd_no_retry5 - ]} + {login_bad_pwd_no_retry, [parallel], [login_bad_pwd_no_retry1, + login_bad_pwd_no_retry2, + login_bad_pwd_no_retry3, + login_bad_pwd_no_retry4, + login_bad_pwd_no_retry5 + ]}, + + {basic, [], [{group,p_basic}, + shell, shell_no_unicode, shell_unicode_string, + close, + known_hosts + ]}, + {p_basic, [parallel], [send, peername_sockname, + exec, exec_compressed, + cli, + idle_time_client, idle_time_server, openssh_zlib_basic_test, + misc_ssh_options, inet_option, inet6_option]} ]. -basic_tests() -> - [send, close, peername_sockname, - exec, exec_compressed, - shell, shell_no_unicode, shell_unicode_string, - cli, known_hosts, - idle_time_client, idle_time_server, openssh_zlib_basic_test, - misc_ssh_options, inet_option, inet6_option]. + %%-------------------------------------------------------------------- init_per_suite(Config) -> - ?CHECK_CRYPTO(Config). + ?CHECK_CRYPTO(begin + ssh:start(), + Config + end). end_per_suite(_Config) -> ssh:stop(). %%-------------------------------------------------------------------- +init_per_group(ssh_renegotiate_SUITE, Config) -> + [{preferred_algorithms, ssh:default_algorithms()} | Config]; init_per_group(dsa_key, Config) -> case lists:member('ssh-dss', ssh_transport:default_algorithms(public_key)) of @@ -414,7 +387,6 @@ init_per_testcase(TC, Config) when TC==shell_no_unicode ; PrivDir = proplists:get_value(priv_dir, Config), UserDir = proplists:get_value(priv_dir, Config), SysDir = proplists:get_value(data_dir, Config), - ssh:start(), Sftpd = {_Pid, _Host, Port} = ssh_test_lib:daemon([{system_dir, SysDir}, {user_dir, PrivDir}, @@ -437,7 +409,6 @@ init_per_testcase(inet6_option, Config) -> {skip,"No ipv6 interface address"} end; init_per_testcase(_TestCase, Config) -> - ssh:start(), Config. end_per_testcase(TestCase, Config) when TestCase == server_password_option; @@ -458,7 +429,6 @@ end_per_testcase(_TestCase, Config) -> end_per_testcase(Config). end_per_testcase(_Config) -> - ssh:stop(), ok. %%-------------------------------------------------------------------- @@ -480,8 +450,8 @@ misc_ssh_options(Config) when is_list(Config) -> SystemDir = filename:join(proplists:get_value(priv_dir, Config), system), UserDir = proplists:get_value(priv_dir, Config), - CMiscOpt0 = [{connect_timeout, 1000}, {user_dir, UserDir}], - CMiscOpt1 = [{connect_timeout, infinity}, {user_dir, UserDir}], + CMiscOpt0 = [{connect_timeout, 1000}, {user_dir, UserDir}, {silently_accept_hosts, true}], + CMiscOpt1 = [{connect_timeout, infinity}, {user_dir, UserDir}, {silently_accept_hosts, true}], SMiscOpt0 = [{user_dir, UserDir}, {system_dir, SystemDir}], SMiscOpt1 = [{user_dir, UserDir}, {system_dir, SystemDir}], @@ -1124,11 +1094,14 @@ packet_size(Config) -> ct:log("Try max_packet_size=~p",[MaxPacketSize]), {ok,Ch} = ssh_connection:session_channel(Conn, 1000, MaxPacketSize, 60000), ok = ssh_connection:shell(Conn, Ch), - rec(Server, Conn, Ch, MaxPacketSize) + rec(Server, Conn, Ch, MaxPacketSize), + ssh_connection:close(Conn, Ch) end, [0, 1, 10, 25]), ssh:close(Conn), - ssh:stop_daemon(Server). + ssh:stop_daemon(Server), + ok. + rec(Server, Conn, Ch, MaxSz) -> receive @@ -1141,7 +1114,9 @@ rec(Server, Conn, Ch, MaxSz) -> ssh:stop_daemon(Server), ct:fail("Does not obey max_packet_size=~p",[MaxSz]) after - 2000 -> ok + 2000 -> + ct:log("~p: ok!",[MaxSz]), + ok end. %%-------------------------------------------------------------------- @@ -1350,6 +1325,156 @@ shell_exit_status(Config) when is_list(Config) -> ssh:stop_daemon(Pid). +%%% Idle timeout test +rekey() -> [{timetrap,{seconds,90}}]. + +rekey(Config) -> + {Pid, Host, Port} = + ssh_test_lib:std_daemon(Config, + [{rekey_limit, 0}]), + ConnectionRef = + ssh_test_lib:std_connect(Config, Host, Port, + [{rekey_limit, 0}]), + Kex1 = ssh_test_lib:get_kex_init(ConnectionRef), + receive + after ?REKEY_DATA_TMO -> + %%By this time rekeying would have been done + Kex2 = ssh_test_lib:get_kex_init(ConnectionRef), + false = (Kex2 == Kex1), + ssh:close(ConnectionRef), + ssh:stop_daemon(Pid) + end. + +%%-------------------------------------------------------------------- + +%%% Test rekeying by data volume + +rekey_limit() -> [{timetrap,{seconds,400}}]. + +rekey_limit(Config) -> + UserDir = proplists:get_value(priv_dir, Config), + DataFile = filename:join(UserDir, "rekey.data"), + + Algs = proplists:get_value(preferred_algorithms, Config), + {Pid, Host, Port} = ssh_test_lib:std_daemon(Config,[{max_random_length_padding,0}, + {preferred_algorithms,Algs}]), + + ConnectionRef = ssh_test_lib:std_connect(Config, Host, Port, [{rekey_limit, 6000}, + {max_random_length_padding,0}]), + {ok, SftpPid} = ssh_sftp:start_channel(ConnectionRef), + + Kex1 = ssh_test_lib:get_kex_init(ConnectionRef), + + timer:sleep(?REKEY_DATA_TMO), + Kex1 = ssh_test_lib:get_kex_init(ConnectionRef), + + Data = lists:duplicate(159000,1), + ok = ssh_sftp:write_file(SftpPid, DataFile, Data), + + timer:sleep(?REKEY_DATA_TMO), + Kex2 = ssh_test_lib:get_kex_init(ConnectionRef), + + false = (Kex2 == Kex1), + + timer:sleep(?REKEY_DATA_TMO), + Kex2 = ssh_test_lib:get_kex_init(ConnectionRef), + + ok = ssh_sftp:write_file(SftpPid, DataFile, "hi\n"), + + timer:sleep(?REKEY_DATA_TMO), + Kex2 = ssh_test_lib:get_kex_init(ConnectionRef), + + false = (Kex2 == Kex1), + + timer:sleep(?REKEY_DATA_TMO), + Kex2 = ssh_test_lib:get_kex_init(ConnectionRef), + + ssh_sftp:stop_channel(SftpPid), + ssh:close(ConnectionRef), + ssh:stop_daemon(Pid). + +%%-------------------------------------------------------------------- + +%%% Test rekeying with simulataneous send request + +renegotiate1(Config) -> + UserDir = proplists:get_value(priv_dir, Config), + DataFile = filename:join(UserDir, "renegotiate1.data"), + + Algs = proplists:get_value(preferred_algorithms, Config), + {Pid, Host, DPort} = ssh_test_lib:std_daemon(Config,[{max_random_length_padding,0}, + {preferred_algorithms,Algs}]), + + RPort = ssh_test_lib:inet_port(), + {ok,RelayPid} = ssh_relay:start_link({0,0,0,0}, RPort, Host, DPort), + + + ConnectionRef = ssh_test_lib:std_connect(Config, Host, RPort, [{max_random_length_padding,0}]), + {ok, SftpPid} = ssh_sftp:start_channel(ConnectionRef), + + Kex1 = ssh_test_lib:get_kex_init(ConnectionRef), + + {ok, Handle} = ssh_sftp:open(SftpPid, DataFile, [write]), + + ok = ssh_sftp:write(SftpPid, Handle, "hi\n"), + + ssh_relay:hold(RelayPid, rx, 20, 1000), + ssh_connection_handler:renegotiate(ConnectionRef), + spawn(fun() -> ok=ssh_sftp:write(SftpPid, Handle, "another hi\n") end), + + timer:sleep(2000), + + Kex2 = ssh_test_lib:get_kex_init(ConnectionRef), + + false = (Kex2 == Kex1), + + ssh_relay:stop(RelayPid), + ssh_sftp:stop_channel(SftpPid), + ssh:close(ConnectionRef), + ssh:stop_daemon(Pid). + +%%-------------------------------------------------------------------- + +%%% Test rekeying with inflight messages from peer + +renegotiate2(Config) -> + UserDir = proplists:get_value(priv_dir, Config), + DataFile = filename:join(UserDir, "renegotiate2.data"), + + Algs = proplists:get_value(preferred_algorithms, Config), + {Pid, Host, DPort} = ssh_test_lib:std_daemon(Config,[{max_random_length_padding,0}, + {preferred_algorithms,Algs}]), + + RPort = ssh_test_lib:inet_port(), + {ok,RelayPid} = ssh_relay:start_link({0,0,0,0}, RPort, Host, DPort), + + ConnectionRef = ssh_test_lib:std_connect(Config, Host, RPort, [{max_random_length_padding,0}]), + {ok, SftpPid} = ssh_sftp:start_channel(ConnectionRef), + + Kex1 = ssh_test_lib:get_kex_init(ConnectionRef), + + {ok, Handle} = ssh_sftp:open(SftpPid, DataFile, [write]), + + ok = ssh_sftp:write(SftpPid, Handle, "hi\n"), + + ssh_relay:hold(RelayPid, rx, 20, infinity), + spawn(fun() -> ok=ssh_sftp:write(SftpPid, Handle, "another hi\n") end), + %% need a small pause here to ensure ssh_sftp:write is executed + ct:sleep(10), + ssh_connection_handler:renegotiate(ConnectionRef), + ssh_relay:release(RelayPid, rx), + + timer:sleep(2000), + + Kex2 = ssh_test_lib:get_kex_init(ConnectionRef), + + false = (Kex2 == Kex1), + + ssh_relay:stop(RelayPid), + ssh_sftp:stop_channel(SftpPid), + ssh:close(ConnectionRef), + ssh:stop_daemon(Pid). + %%-------------------------------------------------------------------- %% Internal functions ------------------------------------------------ %%-------------------------------------------------------------------- diff --git a/lib/ssh/test/ssh_compat_SUITE.erl b/lib/ssh/test/ssh_compat_SUITE.erl index f7eda1dc08..6c0e010bf5 100644 --- a/lib/ssh/test/ssh_compat_SUITE.erl +++ b/lib/ssh/test/ssh_compat_SUITE.erl @@ -41,8 +41,7 @@ %%-------------------------------------------------------------------- suite() -> - [%%{ct_hooks,[ts_install_cth]}, - {timetrap,{seconds,40}}]. + [{timetrap,{seconds,60}}]. all() -> %% [check_docker_present] ++ diff --git a/lib/ssh/test/ssh_connection_SUITE.erl b/lib/ssh/test/ssh_connection_SUITE.erl index 9587c0c251..257f2f70d7 100644 --- a/lib/ssh/test/ssh_connection_SUITE.erl +++ b/lib/ssh/test/ssh_connection_SUITE.erl @@ -50,6 +50,13 @@ all() -> start_shell, start_shell_exec, start_shell_exec_fun, + start_shell_exec_fun2, + start_shell_exec_fun3, + start_shell_exec_direct_fun, + start_shell_exec_direct_fun2, + start_shell_exec_direct_fun3, + start_shell_exec_direct_fun1_error, + start_shell_exec_direct_fun1_error_type, start_shell_sock_exec_fun, start_shell_sock_daemon_exec, connect_sock_not_tcp, @@ -522,7 +529,7 @@ start_shell_exec(Config) when is_list(Config) -> {Pid, Host, Port} = ssh_test_lib:daemon([{system_dir, SysDir}, {user_dir, UserDir}, {password, "morot"}, - {exec, {?MODULE,ssh_exec,[]}} ]), + {exec, {?MODULE,ssh_exec_echo,[]}} ]), ConnectionRef = ssh_test_lib:connect(Host, Port, [{silently_accept_hosts, true}, {user, "foo"}, @@ -535,7 +542,7 @@ start_shell_exec(Config) when is_list(Config) -> success = ssh_connection:exec(ConnectionRef, ChannelId0, "testing", infinity), receive - {ssh_cm, ConnectionRef, {data, _ChannelId, 0, <<"testing\r\n">>}} -> + {ssh_cm, ConnectionRef, {data, _ChannelId, 0, <<"echo testing\r\n">>}} -> ok after 5000 -> ct:fail("Exec Timeout") @@ -618,10 +625,49 @@ exec_erlang_term_non_default_shell(Config) when is_list(Config) -> TestResult. %%-------------------------------------------------------------------- -start_shell_exec_fun() -> - [{doc, "start shell to exec command"}]. +start_shell_exec_fun(Config) -> + do_start_shell_exec_fun(fun ssh_exec_echo/1, + "testing", <<"echo testing\r\n">>, 0, + Config). + +start_shell_exec_fun2(Config) -> + do_start_shell_exec_fun(fun ssh_exec_echo/2, + "testing", <<"echo foo testing\r\n">>, 0, + Config). + +start_shell_exec_fun3(Config) -> + do_start_shell_exec_fun(fun ssh_exec_echo/3, + "testing", <<"echo foo testing\r\n">>, 0, + Config). + +start_shell_exec_direct_fun(Config) -> + do_start_shell_exec_fun({direct, fun ssh_exec_direct_echo/1}, + "testing", <<"echo testing\n">>, 0, + Config). + +start_shell_exec_direct_fun2(Config) -> + do_start_shell_exec_fun({direct, fun ssh_exec_direct_echo/2}, + "testing", <<"echo foo testing">>, 0, + Config). + +start_shell_exec_direct_fun3(Config) -> + do_start_shell_exec_fun({direct, fun ssh_exec_direct_echo/3}, + "testing", <<"echo foo testing">>, 0, + Config). + +start_shell_exec_direct_fun1_error(Config) -> + do_start_shell_exec_fun({direct, fun ssh_exec_direct_echo_error_return/1}, + "testing", <<"Error in \"testing\": {bad}\n">>, 1, + Config). + +start_shell_exec_direct_fun1_error_type(Config) -> + do_start_shell_exec_fun({direct, fun ssh_exec_direct_echo_error_return_type/1}, + "testing", <<"Error in \"testing\": Bad exec-plugin return: very_bad\n">>, 1, + Config). + + -start_shell_exec_fun(Config) when is_list(Config) -> +do_start_shell_exec_fun(Fun, Command, Expect, ExpectType, Config) -> PrivDir = proplists:get_value(priv_dir, Config), UserDir = filename:join(PrivDir, nopubkey), % to make sure we don't use public-key-auth file:make_dir(UserDir), @@ -629,7 +675,7 @@ start_shell_exec_fun(Config) when is_list(Config) -> {Pid, Host, Port} = ssh_test_lib:daemon([{system_dir, SysDir}, {user_dir, UserDir}, {password, "morot"}, - {exec, fun ssh_exec/1}]), + {exec, Fun}]), ConnectionRef = ssh_test_lib:connect(Host, Port, [{silently_accept_hosts, true}, {user, "foo"}, @@ -639,14 +685,19 @@ start_shell_exec_fun(Config) when is_list(Config) -> {ok, ChannelId0} = ssh_connection:session_channel(ConnectionRef, infinity), - success = ssh_connection:exec(ConnectionRef, ChannelId0, - "testing", infinity), + success = ssh_connection:exec(ConnectionRef, ChannelId0, Command, infinity), receive - {ssh_cm, ConnectionRef, {data, _ChannelId, 0, <<"testing\r\n">>}} -> + {ssh_cm, ConnectionRef, {data, _ChannelId, ExpectType, Expect}} -> ok after 5000 -> - ct:fail("Exec Timeout") + receive + Other -> + ct:pal("Received other:~n~p",[Other]), + ct:fail("Unexpected response") + after 0 -> + ct:fail("Exec Timeout") + end end, ssh:close(ConnectionRef), @@ -664,7 +715,7 @@ start_shell_sock_exec_fun(Config) when is_list(Config) -> {Pid, HostD, Port} = ssh_test_lib:daemon([{system_dir, SysDir}, {user_dir, UserDir}, {password, "morot"}, - {exec, fun ssh_exec/1}]), + {exec, fun ssh_exec_echo/1}]), Host = ssh_test_lib:ntoa(ssh_test_lib:mangle_connect_address(HostD)), {ok, Sock} = ssh_test_lib:gen_tcp_connect(Host, Port, [{active,false}]), @@ -680,7 +731,7 @@ start_shell_sock_exec_fun(Config) when is_list(Config) -> "testing", infinity), receive - {ssh_cm, ConnectionRef, {data, _ChannelId, 0, <<"testing\r\n">>}} -> + {ssh_cm, ConnectionRef, {data, _ChannelId, 0, <<"echo testing\r\n">>}} -> ok after 5000 -> ct:fail("Exec Timeout") @@ -704,7 +755,7 @@ start_shell_sock_daemon_exec(Config) -> {ok, _Pid} = ssh:daemon(Ss, [{system_dir, SysDir}, {user_dir, UserDir}, {password, "morot"}, - {exec, fun ssh_exec/1}]) + {exec, fun ssh_exec_echo/1}]) end), {ok,Sc} = gen_tcp:accept(Sl), {ok,ConnectionRef} = ssh:connect(Sc, [{silently_accept_hosts, true}, @@ -719,7 +770,7 @@ start_shell_sock_daemon_exec(Config) -> "testing", infinity), receive - {ssh_cm, ConnectionRef, {data, _ChannelId, 0, <<"testing\r\n">>}} -> + {ssh_cm, ConnectionRef, {data, _ChannelId, 0, <<"echo testing\r\n">>}} -> ok after 5000 -> ct:fail("Exec Timeout") @@ -830,7 +881,7 @@ stop_listener(Config) when is_list(Config) -> {Pid0, Host, Port} = ssh_test_lib:daemon([{system_dir, SysDir}, {user_dir, UserDir}, {password, "morot"}, - {exec, fun ssh_exec/1}]), + {exec, fun ssh_exec_echo/1}]), ConnectionRef0 = ssh_test_lib:connect(Host, Port, [{silently_accept_hosts, true}, {user, "foo"}, @@ -850,7 +901,7 @@ stop_listener(Config) when is_list(Config) -> success = ssh_connection:exec(ConnectionRef0, ChannelId0, "testing", infinity), receive - {ssh_cm, ConnectionRef0, {data, ChannelId0, 0, <<"testing\r\n">>}} -> + {ssh_cm, ConnectionRef0, {data, ChannelId0, 0, <<"echo testing\r\n">>}} -> ok after 5000 -> ct:fail("Exec Timeout") @@ -859,7 +910,7 @@ stop_listener(Config) when is_list(Config) -> case ssh_test_lib:daemon(Port, [{system_dir, SysDir}, {user_dir, UserDir}, {password, "potatis"}, - {exec, fun ssh_exec/1}]) of + {exec, fun ssh_exec_echo/1}]) of {Pid1, Host, Port} -> ConnectionRef1 = ssh_test_lib:connect(Host, Port, [{silently_accept_hosts, true}, {user, "foo"}, @@ -1070,7 +1121,22 @@ start_our_shell(_User, _Peer) -> %% Don't actually loop, just exit end). -ssh_exec(Cmd) -> + +ssh_exec_echo(Cmd) -> spawn(fun() -> - io:format(Cmd ++ "\n") + io:format("echo "++Cmd ++ "\n") end). + +ssh_exec_echo(Cmd, User) -> + spawn(fun() -> + io:format(io_lib:format("echo ~s ~s\n",[User,Cmd])) + end). +ssh_exec_echo(Cmd, User, _PeerAddr) -> + ssh_exec_echo(Cmd,User). + +ssh_exec_direct_echo(Cmd) -> {ok, io_lib:format("echo ~s~n",[Cmd])}. +ssh_exec_direct_echo(Cmd, User) -> {ok, io_lib:format("echo ~s ~s",[User,Cmd])}. +ssh_exec_direct_echo(Cmd, User, _PeerAddr) -> ssh_exec_direct_echo(Cmd,User). + +ssh_exec_direct_echo_error_return(_Cmd) -> {error, {bad}}. +ssh_exec_direct_echo_error_return_type(_Cmd) -> very_bad. diff --git a/lib/ssh/test/ssh_dbg_SUITE.erl b/lib/ssh/test/ssh_dbg_SUITE.erl new file mode 100644 index 0000000000..5439817d10 --- /dev/null +++ b/lib/ssh/test/ssh_dbg_SUITE.erl @@ -0,0 +1,409 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2018-2018. 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_dbg_SUITE). + +-include_lib("common_test/include/ct.hrl"). +-include_lib("ssh/src/ssh.hrl"). +-include("ssh_test_lib.hrl"). + +%% Note: This directive should only be used in test suites. +-compile(export_all). + +%%-------------------------------------------------------------------- +%% Common Test interface functions ----------------------------------- +%%-------------------------------------------------------------------- + +suite() -> + [{ct_hooks,[ts_install_cth]}, + {timetrap,{seconds,60}}]. + +all() -> + [basic, + dbg_alg_terminate, + dbg_ssh_messages, + dbg_connections, + dbg_channels + ]. + +%%-------------------------------------------------------------------- +init_per_suite(Config) -> + ?CHECK_CRYPTO(begin + ssh:start(), + Config + end). + +end_per_suite(_Config) -> + ssh:stop(). + +%%-------------------------------------------------------------------- +init_per_testcase(_TC, Config) -> + Config. + +end_per_testcase(_TC, Config) -> + ssh_dbg:stop(), + Config. + +%%-------------------------------------------------------------------- +-define(USR, "foo"). +-define(PWD, "bar"). + +-define(DBG_RECEIVE(ExpectPfx, Ref, C, Pid), + receive + {Ref, [_, C, ExpectPfx++_]} -> + ok + + after 5000 -> + ssh_dbg:stop(), + ssh:stop_daemon(Pid), + ct:fail("No '~s' debug message",[ExpectPfx]) + end + ). +%%-------------------------------------------------------------------- +%% Test Cases -------------------------------------------------------- +%%-------------------------------------------------------------------- + +basic(_Config) -> + L0 = ssh_dbg:start(), + true = is_pid(whereis(ssh_dbg)), + true = is_list(L0), + + {ok,L0} = ssh_dbg:on(), + {ok,L0} = ssh_dbg:on(), + + L1 = [hd(L0)], + {ok,L1} = ssh_dbg:off(tl(L0)), + + {ok,L1} = ssh_dbg:go_on(), + + {ok,[]} = ssh_dbg:off(), + {ok,[]} = ssh_dbg:off(), + + ok = ssh_dbg:stop(), + undefined = whereis(ssh_dbg). + + +%%-------------------------------------------------------------------- +dbg_alg_terminate(Config) -> + SystemDir = proplists:get_value(data_dir, Config), + UserDir = proplists:get_value(priv_dir, Config), + + Ref = ssh_dbg_start(), + {ok,[alg,connections,terminate]} = ssh_dbg:on([alg,terminate,connections]), + {ok,[alg,terminate]} = ssh_dbg:off(connections), % just testing that terminate is not canceled + + Parent = self(), + {Pid, Host, Port} = ssh_test_lib:daemon([{system_dir, SystemDir}, + {user_dir, UserDir}, + {user_passwords, [{?USR,?PWD}]}, + {connectfun, fun(_,_,_) -> + Parent ! {daemon_c,Ref,self()} + end}, + {failfun, fun ssh_test_lib:failfun/2}]), + C = ssh_test_lib:connect(Host, Port, [{silently_accept_hosts, true}, + {user_dir, UserDir}, + {user,?USR}, + {password,?PWD}, + {user_interaction, false}]), + + %% Daemon connection ref (D): + D = receive + {daemon_c,Ref,D0} -> D0 + end, + ct:log("~p:~p~nC = ~p, D=~p",[?MODULE,?LINE, C, D]), + + ?DBG_RECEIVE("Negotiated algorithms:", Ref, C, Pid), + ?DBG_RECEIVE("Negotiated algorithms:", Ref, D, Pid), + + ssh:close(C), + ?DBG_RECEIVE("Connection Terminating:", Ref, C, Pid), + ?DBG_RECEIVE("Connection Terminating:", Ref, D, Pid), + + stop_and_fail_if_unhandled_dbg_msgs(Ref, [C,D], Pid). + +%%-------------------------------------------------------------------- +dbg_connections(Config) -> + SystemDir = proplists:get_value(data_dir, Config), + UserDir = proplists:get_value(priv_dir, Config), + + Ref = ssh_dbg_start(), + {ok,[connections,terminate]} = ssh_dbg:on([connections, terminate]), + {ok,[connections]} = ssh_dbg:off(terminate), % Just testing that terminate doesn't cancel connections + + Parent = self(), + {Pid, Host, Port} = ssh_test_lib:daemon([{system_dir, SystemDir}, + {user_dir, UserDir}, + {user_passwords, [{?USR,?PWD}]}, + {connectfun, fun(_,_,_) -> + Parent ! {daemon_c,Ref,self()} + end}, + {failfun, fun ssh_test_lib:failfun/2}]), + + ?DBG_RECEIVE("Starting LISTENER on ", Ref, _, Pid), + + C = ssh_test_lib:connect(Host, Port, [{silently_accept_hosts, true}, + {user_dir, UserDir}, + {user,?USR}, + {password,?PWD}, + {user_interaction, false}]), + + %% Daemon connection ref (D): + D = receive + {daemon_c,Ref,D0} -> D0 + end, + ct:log("~p:~p~nC = ~p, D=~p",[?MODULE,?LINE, C, D]), + + ?DBG_RECEIVE("Starting server connection:", Ref, D, Pid), + ?DBG_RECEIVE("Starting client connection:", Ref, C, Pid), + + ssh:close(C), + ?DBG_RECEIVE("Connection Terminating:", Ref, C, Pid), + ?DBG_RECEIVE("Connection Terminating:", Ref, D, Pid), + + stop_and_fail_if_unhandled_dbg_msgs(Ref, [C,D], Pid). + +%%-------------------------------------------------------------------- +dbg_ssh_messages(Config) -> + SystemDir = proplists:get_value(data_dir, Config), + UserDir = proplists:get_value(priv_dir, Config), + + Parent = self(), + Ref = make_ref(), + {Pid, Host, Port} = ssh_test_lib:daemon([{system_dir, SystemDir}, + {user_dir, UserDir}, + {user_passwords, [{?USR,?PWD}]}, + {connectfun, fun(_,_,_) -> + Parent ! {daemon_c,Ref,self()} + end}, + {failfun, fun ssh_test_lib:failfun/2}]), + + ssh_dbg_start(Ref), + {ok,[ssh_messages]} = ssh_dbg:on([ssh_messages]), + + C = ssh_test_lib:connect(Host, Port, [{silently_accept_hosts, true}, + {user_dir, UserDir}, + {user,?USR}, + {password,?PWD}, + {user_interaction, false}]), + + %% Daemon connection ref (D): + D = receive + {daemon_c,Ref,D0} -> D0 + end, + ct:log("~p:~p~nC = ~p, D=~p",[?MODULE,?LINE, C, D]), + + ?DBG_RECEIVE("Going to send hello message:", Ref, C, Pid), + ?DBG_RECEIVE("Received hello message:", Ref, D, Pid), + + ?DBG_RECEIVE("Going to send hello message:", Ref, D, Pid), + ?DBG_RECEIVE("Received hello message:", Ref, C, Pid), + + ?DBG_RECEIVE("Going to send SSH_MSG_KEXINIT:", Ref, C, Pid), + ?DBG_RECEIVE("Received SSH_MSG_KEXINIT:", Ref, D, Pid), + + ?DBG_RECEIVE("Going to send SSH_MSG_KEXINIT:", Ref, D, Pid), + ?DBG_RECEIVE("Received SSH_MSG_KEXINIT:", Ref, C, Pid), + + case atom_to_list( (ssh_connection_handler:alg(C))#alg.kex ) of + "ecdh-"++_ -> + ?DBG_RECEIVE("Going to send SSH_MSG_KEX_ECDH_INIT:", Ref, C, Pid), + ?DBG_RECEIVE("Received SSH_MSG_KEX_ECDH_INIT:", Ref, D, Pid), + ?DBG_RECEIVE("Going to send SSH_MSG_KEX_ECDH_REPLY:", Ref, D, Pid), + ?DBG_RECEIVE("Received SSH_MSG_KEX_ECDH_REPLY:", Ref, C, Pid); + + "diffie-hellman-group-exchange-"++_ -> + ?DBG_RECEIVE("Going to send SSH_MSG_KEX_DH_GEX_REQUEST:", Ref, C, Pid), + ?DBG_RECEIVE("Received SSH_MSG_KEX_DH_GEX_REQUEST:", Ref, D, Pid), + ?DBG_RECEIVE("Going to send SSH_MSG_KEX_DH_GEX_GROUP:", Ref, D, Pid), + ?DBG_RECEIVE("Received SSH_MSG_KEX_DH_GEX_GROUP:", Ref, C, Pid), + ?DBG_RECEIVE("Going to send SSH_MSG_KEX_DH_GEX_INIT:", Ref, C, Pid), + ?DBG_RECEIVE("Received SSH_MSG_KEX_DH_GEX_INIT:", Ref, D, Pid), + ?DBG_RECEIVE("Going to send SSH_MSG_KEX_DH_GEX_REPLY:", Ref, D, Pid), + ?DBG_RECEIVE("Received SSH_MSG_KEX_DH_GEX_REPLY:", Ref, C, Pid); + + "diffie-hellman-group"++_ -> + ?DBG_RECEIVE("Going to send SSH_MSG_KEXDH_INIT:", Ref, C, Pid), + ?DBG_RECEIVE("Received SSH_MSG_KEXDH_INIT:", Ref, D, Pid), + ?DBG_RECEIVE("Going to send SSH_MSG_KEXDH_REPLY:", Ref, D, Pid), + ?DBG_RECEIVE("Received SSH_MSG_KEXDH_REPLY:", Ref, C, Pid) + end, + + + ?DBG_RECEIVE("Going to send SSH_MSG_NEWKEYS:", Ref, C, Pid), + ?DBG_RECEIVE("Received SSH_MSG_NEWKEYS:", Ref, D, Pid), + + ?DBG_RECEIVE("Going to send SSH_MSG_NEWKEYS:", Ref, D, Pid), + ?DBG_RECEIVE("Received SSH_MSG_NEWKEYS:", Ref, C, Pid), + + ?DBG_RECEIVE("Going to send SSH_MSG_SERVICE_REQUEST:", Ref, C, Pid), + ?DBG_RECEIVE("Received SSH_MSG_SERVICE_REQUEST:", Ref, D, Pid), + + ?DBG_RECEIVE("Going to send SSH_MSG_SERVICE_ACCEPT:", Ref, D, Pid), + ?DBG_RECEIVE("Received SSH_MSG_SERVICE_ACCEPT:", Ref, C, Pid), + + ?DBG_RECEIVE("Going to send SSH_MSG_USERAUTH_REQUEST:", Ref, C, Pid), + ?DBG_RECEIVE("Received SSH_MSG_USERAUTH_REQUEST:", Ref, D, Pid), + + ?DBG_RECEIVE("Going to send SSH_MSG_USERAUTH_FAILURE:", Ref, D, Pid), + ?DBG_RECEIVE("Received SSH_MSG_USERAUTH_FAILURE:", Ref, C, Pid), + + ?DBG_RECEIVE("Going to send SSH_MSG_USERAUTH_REQUEST:", Ref, C, Pid), + ?DBG_RECEIVE("Received SSH_MSG_USERAUTH_REQUEST:", Ref, D, Pid), + + ?DBG_RECEIVE("Going to send SSH_MSG_USERAUTH_SUCCESS:", Ref, D, Pid), + ?DBG_RECEIVE("Received SSH_MSG_USERAUTH_SUCCESS:", Ref, C, Pid), + + + UnexpectedMsgs = + dbg_SKIP(Ref, + [S_R ++ P ++ ":" || P <- ["SSH_MSG_USERAUTH_REQUEST", + "SSH_MSG_USERAUTH_INFO_REQUEST", + "SSH_MSG_USERAUTH_INFO_RESPONSE", + "SSH_MSG_USERAUTH_FAILURE", + "SSH_MSG_EXT_INFO" + ], + S_R <- ["Going to send ", + "Received " + ] + ]), + + ssh:close(C), + stop_and_fail_if_unhandled_dbg_msgs(UnexpectedMsgs, Ref, [C,D], Pid). + +%%-------------------------------------------------------------------- +dbg_channels(Config) -> + SystemDir = proplists:get_value(data_dir, Config), + UserDir = proplists:get_value(priv_dir, Config), + + Ref = ssh_dbg_start(), + {ok,[channels,connections]} = ssh_dbg:on([connections, channels]), + + Parent = self(), + TimeoutShell = + fun() -> + io:format("TimeoutShell started!~n",[]), + timer:sleep(1000), + Parent ! {daemon_channel,Ref,self()}, + ct:log("~p TIMEOUT!",[self()]) + end, + {Pid, Host, Port} = ssh_test_lib:daemon([{system_dir, SystemDir}, + {user_dir, UserDir}, + {user_passwords, [{?USR,?PWD}]}, + {connectfun, fun(_,_,_) -> + Parent ! {daemon_c,Ref,self()} + end}, + {shell, fun(_User) -> + spawn(TimeoutShell) + end + }, + {failfun, fun ssh_test_lib:failfun/2}]), + + ?DBG_RECEIVE("Starting LISTENER on ", Ref, _, Pid), + + C = ssh_test_lib:connect(Host, Port, [{silently_accept_hosts, true}, + {user_dir, UserDir}, + {user,?USR}, + {password,?PWD}, + {user_interaction, false}]), + {ok, Ch0} = ssh_connection:session_channel(C, infinity), + ok = ssh_connection:shell(C, Ch0), + + %% Daemon connection ref (D): + D = receive {daemon_c,Ref,D0} -> D0 end, + + %% Daemon channel (Dch): + Dch = receive {daemon_channel,Ref,Dch0} -> Dch0 end, + ct:log("~p:~p~nC = ~p, D=~p, Dch=~p~n~s",[?MODULE,?LINE, C, D, Dch, ssh_info:string()]), + + ?DBG_RECEIVE("Starting server connection:", Ref, D, Pid), + ?DBG_RECEIVE("Starting client connection:", Ref, C, Pid), + ?DBG_RECEIVE("Server Channel Starting:", Ref, _, Pid), + ?DBG_RECEIVE("Server Channel Terminating:", Ref, _, Pid), + + stop_and_fail_if_unhandled_dbg_msgs(Ref, [C,D], Pid). + +%%-------------------------------------------------------------------- +%%-------------------------------------------------------------------- +%%-------------------------------------------------------------------- + +ssh_dbg_start() -> + ssh_dbg_start(make_ref()). + +ssh_dbg_start(Ref) -> + Parent = self(), + [_|_] = ssh_dbg:start(fun(_F,A) -> + Parent ! {Ref,A} + end), + Ref. + +%%-------------------------------------------------------------------- +queued_msgs(Ref, Conns) -> + queued_msgs(Ref, Conns, []). + +queued_msgs(Ref, Conns, Acc) -> + receive + {Ref, [_, C, _]=Msg} -> + case is_list(Conns) andalso lists:member(C, Conns) of + true -> + queued_msgs(Ref, [Msg|Acc]); + false -> + queued_msgs(Ref, Conns, Acc) + end + after 0 -> + lists:reverse(Acc) + end. + +%%-------------------------------------------------------------------- +stop_and_fail_if_unhandled_dbg_msgs(Ref, Conns, DaemonPid) -> + stop_and_fail_if_unhandled_dbg_msgs(queued_msgs(Ref,Conns), Ref, Conns, DaemonPid). + +stop_and_fail_if_unhandled_dbg_msgs(Msgs, _Ref, _Conns, DaemonPid) -> + ssh:stop_daemon(DaemonPid), + case Msgs of + [] -> + ok; + _ -> + ct:log("Unexpected messages:~n~p",[Msgs]), + ct:fail("Unexpected messages") + end. + +%%-------------------------------------------------------------------- +dbg_SKIP(Ref, Prefixes) -> + dbg_SKIP(Ref, Prefixes, []). + +dbg_SKIP(Ref, Prefixes, UnexpectedAcc) -> + receive + {Ref, [_, _C, Msg]=M} -> + case lists:any( + fun(Pfx) -> + lists:prefix(Pfx, Msg) + end, Prefixes) of + true -> + ct:log("Skip:~n~p", [M]), + dbg_SKIP(Ref, Prefixes, UnexpectedAcc); + false -> + dbg_SKIP(Ref, Prefixes, [Msg|UnexpectedAcc]) + end + after 0 -> + lists:reverse(UnexpectedAcc) + end. + diff --git a/lib/ssh/test/ssh_renegotiate_SUITE_data/ssh_host_dsa_key b/lib/ssh/test/ssh_dbg_SUITE_data/ssh_host_dsa_key index 51ab6fbd88..51ab6fbd88 100644 --- a/lib/ssh/test/ssh_renegotiate_SUITE_data/ssh_host_dsa_key +++ b/lib/ssh/test/ssh_dbg_SUITE_data/ssh_host_dsa_key diff --git a/lib/ssh/test/ssh_renegotiate_SUITE_data/ssh_host_dsa_key.pub b/lib/ssh/test/ssh_dbg_SUITE_data/ssh_host_dsa_key.pub index 4dbb1305b0..4dbb1305b0 100644 --- a/lib/ssh/test/ssh_renegotiate_SUITE_data/ssh_host_dsa_key.pub +++ b/lib/ssh/test/ssh_dbg_SUITE_data/ssh_host_dsa_key.pub diff --git a/lib/ssh/test/ssh_dbg_SUITE_data/ssh_host_ecdsa_key256 b/lib/ssh/test/ssh_dbg_SUITE_data/ssh_host_ecdsa_key256 new file mode 100644 index 0000000000..2979ea88ed --- /dev/null +++ b/lib/ssh/test/ssh_dbg_SUITE_data/ssh_host_ecdsa_key256 @@ -0,0 +1,5 @@ +-----BEGIN EC PRIVATE KEY----- +MHcCAQEEIMe4MDoit0t8RzSVPwkCBemQ9fhXL+xnTSAWISw8HNCioAoGCCqGSM49 +AwEHoUQDQgAEo2q7U3P6r0W5WGOLtM78UQtofM9UalEhiZeDdiyylsR/RR17Op0s +VPGSADLmzzgcucLEKy17j2S+oz42VUJy5A== +-----END EC PRIVATE KEY----- diff --git a/lib/ssh/test/ssh_dbg_SUITE_data/ssh_host_ecdsa_key256.pub b/lib/ssh/test/ssh_dbg_SUITE_data/ssh_host_ecdsa_key256.pub new file mode 100644 index 0000000000..85dc419345 --- /dev/null +++ b/lib/ssh/test/ssh_dbg_SUITE_data/ssh_host_ecdsa_key256.pub @@ -0,0 +1 @@ +ecdsa-sha2-nistp256 AAAAE2VjZHNhLXNoYTItbmlzdHAyNTYAAAAIbmlzdHAyNTYAAABBBKNqu1Nz+q9FuVhji7TO/FELaHzPVGpRIYmXg3YsspbEf0UdezqdLFTxkgAy5s84HLnCxCste49kvqM+NlVCcuQ= uabhnil@elxadlj3q32 diff --git a/lib/ssh/test/ssh_dbg_SUITE_data/ssh_host_ecdsa_key384 b/lib/ssh/test/ssh_dbg_SUITE_data/ssh_host_ecdsa_key384 new file mode 100644 index 0000000000..fb1a862ded --- /dev/null +++ b/lib/ssh/test/ssh_dbg_SUITE_data/ssh_host_ecdsa_key384 @@ -0,0 +1,6 @@ +-----BEGIN EC PRIVATE KEY----- +MIGkAgEBBDArxbDfh3p1okrD9wQw6jJ4d4DdlBPD5GqXE8bIeRJiK41Sh40LgvPw +mkqEDSXK++CgBwYFK4EEACKhZANiAAScl43Ih2lWTDKrSox5ve5uiTXil4smsup3 +CfS1XPjKxgBAmlfBim8izbdrT0BFdQzz2joduNMtpt61wO4rGs6jm0UP7Kim9PC7 +Hneb/99fIYopdMH5NMnk60zGO1uZ2vc= +-----END EC PRIVATE KEY----- diff --git a/lib/ssh/test/ssh_dbg_SUITE_data/ssh_host_ecdsa_key384.pub b/lib/ssh/test/ssh_dbg_SUITE_data/ssh_host_ecdsa_key384.pub new file mode 100644 index 0000000000..428d5fb7d7 --- /dev/null +++ b/lib/ssh/test/ssh_dbg_SUITE_data/ssh_host_ecdsa_key384.pub @@ -0,0 +1 @@ +ecdsa-sha2-nistp384 AAAAE2VjZHNhLXNoYTItbmlzdHAzODQAAAAIbmlzdHAzODQAAABhBJyXjciHaVZMMqtKjHm97m6JNeKXiyay6ncJ9LVc+MrGAECaV8GKbyLNt2tPQEV1DPPaOh240y2m3rXA7isazqObRQ/sqKb08Lsed5v/318hiil0wfk0yeTrTMY7W5na9w== uabhnil@elxadlj3q32 diff --git a/lib/ssh/test/ssh_dbg_SUITE_data/ssh_host_ecdsa_key521 b/lib/ssh/test/ssh_dbg_SUITE_data/ssh_host_ecdsa_key521 new file mode 100644 index 0000000000..3e51ec2ecd --- /dev/null +++ b/lib/ssh/test/ssh_dbg_SUITE_data/ssh_host_ecdsa_key521 @@ -0,0 +1,7 @@ +-----BEGIN EC PRIVATE KEY----- +MIHcAgEBBEIB8O1BFkl2HQjQLRLonEZ97da/h39DMa9/0/hvPZWAI8gUPEQcHxRx +U7b09p3Zh+EBbMFq8+1ae9ds+ZTxE4WFSvKgBwYFK4EEACOhgYkDgYYABAAlWVjq +Bzg7Wt4gE6UNb1lRE2cnlmH2L/A5uo6qZRx5lPnSKOxEhxSb/Oay1+9d6KRdrh6/ +vlhd9SHDBhLcAPDvWgBnJIEj92Q3pXX4JtoitL0yl+SvvU+vUh966mzHShHzj8p5 +ccOgPkPNoA70yrpGzkIhPezpZOQdCaOXj/jFqNCTDg== +-----END EC PRIVATE KEY----- diff --git a/lib/ssh/test/ssh_dbg_SUITE_data/ssh_host_ecdsa_key521.pub b/lib/ssh/test/ssh_dbg_SUITE_data/ssh_host_ecdsa_key521.pub new file mode 100644 index 0000000000..017a29f4da --- /dev/null +++ b/lib/ssh/test/ssh_dbg_SUITE_data/ssh_host_ecdsa_key521.pub @@ -0,0 +1 @@ +ecdsa-sha2-nistp521 AAAAE2VjZHNhLXNoYTItbmlzdHA1MjEAAAAIbmlzdHA1MjEAAACFBAAlWVjqBzg7Wt4gE6UNb1lRE2cnlmH2L/A5uo6qZRx5lPnSKOxEhxSb/Oay1+9d6KRdrh6/vlhd9SHDBhLcAPDvWgBnJIEj92Q3pXX4JtoitL0yl+SvvU+vUh966mzHShHzj8p5ccOgPkPNoA70yrpGzkIhPezpZOQdCaOXj/jFqNCTDg== uabhnil@elxadlj3q32 diff --git a/lib/ssh/test/ssh_renegotiate_SUITE_data/ssh_host_rsa_key b/lib/ssh/test/ssh_dbg_SUITE_data/ssh_host_rsa_key index 79968bdd7d..79968bdd7d 100644 --- a/lib/ssh/test/ssh_renegotiate_SUITE_data/ssh_host_rsa_key +++ b/lib/ssh/test/ssh_dbg_SUITE_data/ssh_host_rsa_key diff --git a/lib/ssh/test/ssh_renegotiate_SUITE_data/ssh_host_rsa_key.pub b/lib/ssh/test/ssh_dbg_SUITE_data/ssh_host_rsa_key.pub index 75d2025c71..75d2025c71 100644 --- a/lib/ssh/test/ssh_renegotiate_SUITE_data/ssh_host_rsa_key.pub +++ b/lib/ssh/test/ssh_dbg_SUITE_data/ssh_host_rsa_key.pub diff --git a/lib/ssh/test/ssh_options_SUITE.erl b/lib/ssh/test/ssh_options_SUITE.erl index 12a85c40aa..86a8ac5aa8 100644 --- a/lib/ssh/test/ssh_options_SUITE.erl +++ b/lib/ssh/test/ssh_options_SUITE.erl @@ -1227,7 +1227,7 @@ max_sessions(Config, ParallelLogin, Connect0) when is_function(Connect0,2) -> [_|_] = Connections, %% Now try one more than alowed: - ct:log("Info Report might come here...",[]), + ct:pal("Info Report expected here (if not disabled) ...",[]), try Connect(Host,Port) of _ConnectionRef1 -> @@ -1235,8 +1235,7 @@ max_sessions(Config, ParallelLogin, Connect0) when is_function(Connect0,2) -> {fail,"Too many connections accepted"} catch error:{badmatch,{error,"Connection closed"}} -> - %% Step 2 ok: could not set up max_sessions+1 connections - %% This is expected + ct:log("Step 2 ok: could not set up too many connections. Good.",[]), %% Now stop one connection and try to open one more ok = ssh:close(hd(Connections)), try_to_connect(Connect, Host, Port, Pid) @@ -1249,16 +1248,15 @@ max_sessions(Config, ParallelLogin, Connect0) when is_function(Connect0,2) -> try_to_connect(Connect, Host, Port, Pid) -> - {ok,Tref} = timer:send_after(3000, timeout_no_connection), % give the supervisors some time... + {ok,Tref} = timer:send_after(30000, timeout_no_connection), % give the supervisors some time... try_to_connect(Connect, Host, Port, Pid, Tref, 1). % will take max 3300 ms after 11 tries try_to_connect(Connect, Host, Port, Pid, Tref, N) -> try Connect(Host,Port) of _ConnectionRef1 -> - %% Step 3 ok: could set up one more connection after killing one - %% Thats good. timer:cancel(Tref), + ct:log("Step 3 ok: could set up one more connection after killing one. Thats good.",[]), ssh:stop_daemon(Pid), receive % flush. timeout_no_connection -> ok diff --git a/lib/ssh/test/ssh_renegotiate_SUITE.erl b/lib/ssh/test/ssh_renegotiate_SUITE.erl deleted file mode 100644 index 74bbc291b2..0000000000 --- a/lib/ssh/test/ssh_renegotiate_SUITE.erl +++ /dev/null @@ -1,237 +0,0 @@ -%% -%% %CopyrightBegin% -%% -%% Copyright Ericsson AB 2008-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(ssh_renegotiate_SUITE). - --include_lib("common_test/include/ct.hrl"). --include("ssh_test_lib.hrl"). - -%% Note: This directive should only be used in test suites. --compile(export_all). - --define(REKEY_DATA_TMO, 65000). -%%-------------------------------------------------------------------- -%% Common Test interface functions ----------------------------------- -%%-------------------------------------------------------------------- - -suite() -> [{ct_hooks,[ts_install_cth]}, - {timetrap,{seconds,40}}]. - -all() -> [{group,default_algs}, - {group,aes_gcm} - ]. - -groups() -> [{default_algs, [], tests()}, - {aes_gcm, [], tests()} - ]. - -tests() -> [rekey, rekey_limit, renegotiate1, renegotiate2]. - -%%-------------------------------------------------------------------- -init_per_suite(Config) -> - ?CHECK_CRYPTO(Config). - -end_per_suite(_Config) -> - ssh:stop(). - -%%-------------------------------------------------------------------- -init_per_group(aes_gcm, Config) -> - case lists:member({client2server,['[email protected]']}, - ssh_transport:supported_algorithms(cipher)) of - true -> - [{preferred_algorithms, [{cipher,[{client2server,['[email protected]']}, - {server2client,['[email protected]']}]}]} - | Config]; - false -> - {skip, "aes_gcm not supported"} - end; -init_per_group(_, Config) -> - [{preferred_algorithms, ssh:default_algorithms()} | Config]. - - -end_per_group(_, Config) -> - Config. - -%%-------------------------------------------------------------------- -init_per_testcase(_TestCase, Config) -> - ssh:start(), - Config. - -end_per_testcase(_TestCase, _Config) -> - ssh:stop(), - ok. - -%%-------------------------------------------------------------------- -%% Test Cases -------------------------------------------------------- -%%-------------------------------------------------------------------- - -%%% Idle timeout test -rekey() -> [{timetrap,{seconds,90}}]. - -rekey(Config) -> - {Pid, Host, Port} = - ssh_test_lib:std_daemon(Config, - [{rekey_limit, 0}]), - ConnectionRef = - ssh_test_lib:std_connect(Config, Host, Port, - [{rekey_limit, 0}]), - Kex1 = ssh_test_lib:get_kex_init(ConnectionRef), - receive - after ?REKEY_DATA_TMO -> - %%By this time rekeying would have been done - Kex2 = ssh_test_lib:get_kex_init(ConnectionRef), - false = (Kex2 == Kex1), - ssh:close(ConnectionRef), - ssh:stop_daemon(Pid) - end. - -%%-------------------------------------------------------------------- - -%%% Test rekeying by data volume - -rekey_limit() -> [{timetrap,{seconds,400}}]. - -rekey_limit(Config) -> - UserDir = proplists:get_value(priv_dir, Config), - DataFile = filename:join(UserDir, "rekey.data"), - - Algs = proplists:get_value(preferred_algorithms, Config), - {Pid, Host, Port} = ssh_test_lib:std_daemon(Config,[{max_random_length_padding,0}, - {preferred_algorithms,Algs}]), - - ConnectionRef = ssh_test_lib:std_connect(Config, Host, Port, [{rekey_limit, 6000}, - {max_random_length_padding,0}]), - {ok, SftpPid} = ssh_sftp:start_channel(ConnectionRef), - - Kex1 = ssh_test_lib:get_kex_init(ConnectionRef), - - timer:sleep(?REKEY_DATA_TMO), - Kex1 = ssh_test_lib:get_kex_init(ConnectionRef), - - Data = lists:duplicate(159000,1), - ok = ssh_sftp:write_file(SftpPid, DataFile, Data), - - timer:sleep(?REKEY_DATA_TMO), - Kex2 = ssh_test_lib:get_kex_init(ConnectionRef), - - false = (Kex2 == Kex1), - - timer:sleep(?REKEY_DATA_TMO), - Kex2 = ssh_test_lib:get_kex_init(ConnectionRef), - - ok = ssh_sftp:write_file(SftpPid, DataFile, "hi\n"), - - timer:sleep(?REKEY_DATA_TMO), - Kex2 = ssh_test_lib:get_kex_init(ConnectionRef), - - false = (Kex2 == Kex1), - - timer:sleep(?REKEY_DATA_TMO), - Kex2 = ssh_test_lib:get_kex_init(ConnectionRef), - - ssh_sftp:stop_channel(SftpPid), - ssh:close(ConnectionRef), - ssh:stop_daemon(Pid). - -%%-------------------------------------------------------------------- - -%%% Test rekeying with simulataneous send request - -renegotiate1(Config) -> - UserDir = proplists:get_value(priv_dir, Config), - DataFile = filename:join(UserDir, "renegotiate1.data"), - - Algs = proplists:get_value(preferred_algorithms, Config), - {Pid, Host, DPort} = ssh_test_lib:std_daemon(Config,[{max_random_length_padding,0}, - {preferred_algorithms,Algs}]), - - RPort = ssh_test_lib:inet_port(), - {ok,RelayPid} = ssh_relay:start_link({0,0,0,0}, RPort, Host, DPort), - - - ConnectionRef = ssh_test_lib:std_connect(Config, Host, RPort, [{max_random_length_padding,0}]), - {ok, SftpPid} = ssh_sftp:start_channel(ConnectionRef), - - Kex1 = ssh_test_lib:get_kex_init(ConnectionRef), - - {ok, Handle} = ssh_sftp:open(SftpPid, DataFile, [write]), - - ok = ssh_sftp:write(SftpPid, Handle, "hi\n"), - - ssh_relay:hold(RelayPid, rx, 20, 1000), - ssh_connection_handler:renegotiate(ConnectionRef), - spawn(fun() -> ok=ssh_sftp:write(SftpPid, Handle, "another hi\n") end), - - timer:sleep(2000), - - Kex2 = ssh_test_lib:get_kex_init(ConnectionRef), - - false = (Kex2 == Kex1), - - ssh_relay:stop(RelayPid), - ssh_sftp:stop_channel(SftpPid), - ssh:close(ConnectionRef), - ssh:stop_daemon(Pid). - -%%-------------------------------------------------------------------- - -%%% Test rekeying with inflight messages from peer - -renegotiate2(Config) -> - UserDir = proplists:get_value(priv_dir, Config), - DataFile = filename:join(UserDir, "renegotiate2.data"), - - Algs = proplists:get_value(preferred_algorithms, Config), - {Pid, Host, DPort} = ssh_test_lib:std_daemon(Config,[{max_random_length_padding,0}, - {preferred_algorithms,Algs}]), - - RPort = ssh_test_lib:inet_port(), - {ok,RelayPid} = ssh_relay:start_link({0,0,0,0}, RPort, Host, DPort), - - ConnectionRef = ssh_test_lib:std_connect(Config, Host, RPort, [{max_random_length_padding,0}]), - {ok, SftpPid} = ssh_sftp:start_channel(ConnectionRef), - - Kex1 = ssh_test_lib:get_kex_init(ConnectionRef), - - {ok, Handle} = ssh_sftp:open(SftpPid, DataFile, [write]), - - ok = ssh_sftp:write(SftpPid, Handle, "hi\n"), - - ssh_relay:hold(RelayPid, rx, 20, infinity), - spawn(fun() -> ok=ssh_sftp:write(SftpPid, Handle, "another hi\n") end), - %% need a small pause here to ensure ssh_sftp:write is executed - ct:sleep(10), - ssh_connection_handler:renegotiate(ConnectionRef), - ssh_relay:release(RelayPid, rx), - - timer:sleep(2000), - - Kex2 = ssh_test_lib:get_kex_init(ConnectionRef), - - false = (Kex2 == Kex1), - - ssh_relay:stop(RelayPid), - ssh_sftp:stop_channel(SftpPid), - ssh:close(ConnectionRef), - ssh:stop_daemon(Pid). - -%%-------------------------------------------------------------------- -%% Internal functions ------------------------------------------------ -%%-------------------------------------------------------------------- diff --git a/lib/ssh/test/ssh_renegotiate_SUITE_data/id_dsa b/lib/ssh/test/ssh_renegotiate_SUITE_data/id_dsa deleted file mode 100644 index d306f8b26e..0000000000 --- a/lib/ssh/test/ssh_renegotiate_SUITE_data/id_dsa +++ /dev/null @@ -1,13 +0,0 @@ ------BEGIN DSA PRIVATE KEY----- -MIIBvAIBAAKBgQDfi2flSTZZofwT4yQT0NikX/LGNT7UPeB/XEWe/xovEYCElfaQ -APFixXvEgXwoojmZ5kiQRKzLM39wBP0jPERLbnZXfOOD0PDnw0haMh7dD7XKVMod -/EigVgHf/qBdM2M8yz1s/rRF7n1UpLSypziKjkzCm7JoSQ2zbWIPdmBIXwIVAMgP -kpr7Sq3O7sHdb8D601DRjoExAoGAMOQxDfB2Fd8ouz6G96f/UOzRMI/Kdv8kYYKW -JIGY+pRYrLPyYzUeJznwZreOJgrczAX+luHnKFWJ2Dnk5CyeXk67Wsr7pJ/4MBMD -OKeIS0S8qoSBN8+Krp79fgA+yS3IfqbkJLtLu4EBaCX4mKQIX4++k44d4U5lc8pt -+9hlEI8CgYEAznKxx9kyC6bVo7LUYKaGhofRFt0SYFc5PVmT2VUGRs1R6+6DPD+e -uEO6IhFct7JFSRbP9p0JD4Uk+3zlZF+XX6b2PsZkeV8f/02xlNGUSmEzCSiNg1AX -Cy/WusYhul0MncWCHMcOZB5rIvU/aP5EJJtn3xrRaz6u0SThF6AnT34CFQC63czE -ZU8w8Q+H7z0j+a+70x2iAw== ------END DSA PRIVATE KEY----- - diff --git a/lib/ssh/test/ssh_renegotiate_SUITE_data/id_rsa b/lib/ssh/test/ssh_renegotiate_SUITE_data/id_rsa deleted file mode 100644 index 9d7e0dd5fb..0000000000 --- a/lib/ssh/test/ssh_renegotiate_SUITE_data/id_rsa +++ /dev/null @@ -1,15 +0,0 @@ ------BEGIN RSA PRIVATE KEY----- -MIICXAIBAAKBgQD1OET+3O/Bvj/dtjxDTXmj1oiJt4sIph5kGy0RfjoPrZfaS+CU -DhakCmS6t2ivxWFgtpKWaoGMZMJqWj6F6ZsumyFl3FPBtujwY/35cgifrI9Ns4Tl -zR1uuengNBmV+WRQ5cd9F2qS6Z8aDQihzt0r8JUqLcK+VQbrmNzboCCQQwIDAQAB -AoGAPQEyqPTt8JUT7mRXuaacjFXiweAXhp9NEDpyi9eLOjtFe9lElZCrsUOkq47V -TGUeRKEm9qSodfTbKPoqc8YaBJGJPhUaTAcha+7QcDdfHBvIsgxvU7ePVnlpXRp3 -CCUEMPhlnx6xBoTYP+fRU0e3+xJIPVyVCqX1jAdUMkzfRoECQQD6ux7B1QJAIWyK -SGkbDUbBilNmzCFNgIpOP6PA+bwfi5d16diTpra5AX09keQABAo/KaP1PdV8Vg0p -z4P3A7G3AkEA+l+AKG6m0kQTTBMJDqOdVPYwe+5GxunMaqmhokpEbuGsrZBl5Dvd -WpcBjR7jmenrhKZRIuA+Fz5HPo/UQJPl1QJBAKxstDkeED8j/S2XoFhPKAJ+6t39 -sUVICVTIZQeXdmzHJXCcUSkw8+WEhakqw/3SyW0oaK2FSWQJFWJUZ+8eJj8CQEh3 -xeduB5kKnS9CvzdeghZqX6QvVosSdtlUmfUYW/BgH5PpHKTP8wTaeld3XldZTpMJ -dKiMkUw2+XYROVUrubUCQD+Na1LhULlpn4ISEtIEfqpdlUhxDgO15Wg8USmsng+x -ICliVOSQtwaZjm8kwaFt0W7XnpnDxbRs37vIEbIMWak= ------END RSA PRIVATE KEY----- diff --git a/lib/ssh/test/ssh_sup_SUITE.erl b/lib/ssh/test/ssh_sup_SUITE.erl index 1df55834b1..b145066c36 100644 --- a/lib/ssh/test/ssh_sup_SUITE.erl +++ b/lib/ssh/test/ssh_sup_SUITE.erl @@ -201,8 +201,6 @@ killed_acceptor_restarts(Config) -> Port2 = ssh_test_lib:daemon_port(DaemonPid2), true = (Port /= Port2), - ct:log("~s",[lists:flatten(ssh_info:string())]), - {ok,[{AccPid,ListenAddr,Port}]} = acceptor_pid(DaemonPid), {ok,[{AccPid2,ListenAddr,Port2}]} = acceptor_pid(DaemonPid2), @@ -216,23 +214,34 @@ killed_acceptor_restarts(Config) -> {user_dir, UserDir}]), [{client_version,_}] = ssh:connection_info(C1,[client_version]), + ct:log("~s",[lists:flatten(ssh_info:string())]), + %% Make acceptor restart: exit(AccPid, kill), ?wait_match(undefined, process_info(AccPid)), - %% Check it is a new acceptor: + %% Check it is a new acceptor and wait if it is not: ?wait_match({ok,[{AccPid1,ListenAddr,Port}]}, AccPid1=/=AccPid, acceptor_pid(DaemonPid), AccPid1, 500, 30), - AccPid1 =/= AccPid2, + + true = (AccPid1 =/= AccPid2), %% Connect second client and check it is alive: - {ok,C2} = ssh:connect("localhost", Port, [{silently_accept_hosts, true}, - {user_interaction, false}, - {user, ?USER}, - {password, ?PASSWD}, - {user_dir, UserDir}]), + C2 = + case ssh:connect("localhost", Port, [{silently_accept_hosts, true}, + {user_interaction, false}, + {user, ?USER}, + {password, ?PASSWD}, + {user_dir, UserDir}]) of + {ok,_C2} -> + _C2; + _Other -> + ct:log("new connect failed: ~p~n~n~s",[_Other,lists:flatten(ssh_info:string())]), + ct:fail("Re-connect failed!", []) + end, + [{client_version,_}] = ssh:connection_info(C2,[client_version]), ct:log("~s",[lists:flatten(ssh_info:string())]), diff --git a/lib/ssh/vsn.mk b/lib/ssh/vsn.mk index d5eed0b087..f327d2ec11 100644 --- a/lib/ssh/vsn.mk +++ b/lib/ssh/vsn.mk @@ -1,4 +1,4 @@ #-*-makefile-*- ; force emacs to enter makefile-mode -SSH_VSN = 4.6.7 +SSH_VSN = 4.6.8 APP_VSN = "ssh-$(SSH_VSN)" diff --git a/lib/ssl/doc/src/ssl.xml b/lib/ssl/doc/src/ssl.xml index 3db5aa19ac..029f29cdb3 100644 --- a/lib/ssl/doc/src/ssl.xml +++ b/lib/ssl/doc/src/ssl.xml @@ -32,7 +32,7 @@ <modulesummary>Interface Functions for Secure Socket Layer</modulesummary> <description> <p> - This module contains interface functions for the SSL/TLS protocol. + This module contains interface functions for the SSL/TLS/DTLS protocol. For detailed information about the supported standards see <seealso marker="ssl_app">ssl(6)</seealso>. </p> @@ -40,7 +40,7 @@ <section> <title>DATA TYPES</title> - <p>The following data types are used in the functions for SSL:</p> + <p>The following data types are used in the functions for SSL/TLS/DTLS:</p> <taglist> @@ -56,9 +56,11 @@ <p>The default socket options are <c>[{mode,list},{packet, 0},{header, 0},{active, true}]</c>.</p> <p>For valid options, see the - <seealso marker="kernel:inet">inet(3)</seealso> and - <seealso marker="kernel:gen_tcp">gen_tcp(3)</seealso> manual pages - in Kernel.</p></item> + <seealso marker="kernel:inet">inet(3)</seealso>, + <seealso marker="kernel:gen_tcp">gen_tcp(3)</seealso> and + <seealso marker="kernel:gen_tcp">gen_udp(3)</seealso> + manual pages + in Kernel. Note that stream oriented options such as packet are only relevant for SSL/TLS and not DTLS</p></item> <tag><marker id="type-ssloption"/><c>ssl_option() =</c></tag> <item> @@ -95,13 +97,14 @@ <item><p><c>{cb_info, {CallbackModule::atom(), DataTag::atom(), ClosedTag::atom(), ErrTag:atom()}}</c></p> - <p>Defaults to <c>{gen_tcp, tcp, tcp_closed, tcp_error}</c>. Can be used - to customize the transport layer. The callback module must implement a + <p>Defaults to <c>{gen_tcp, tcp, tcp_closed, tcp_error}</c> for TLS + and <c>{gen_udp, udp, udp_closed, udp_error}</c> for DTLS. Can be used + to customize the transport layer. For TLS the callback module must implement a reliable transport protocol, behave as <c>gen_tcp</c>, and have functions corresponding to <c>inet:setopts/2</c>, <c>inet:getopts/2</c>, <c>inet:peername/1</c>, <c>inet:sockname/1</c>, and <c>inet:port/1</c>. The callback <c>gen_tcp</c> is treated specially and calls <c>inet</c> - directly.</p> + directly. For DTLS this feature must be considered exprimental.</p> <taglist> <tag><c>CallbackModule =</c></tag> <item><p><c>atom()</c></p></item> @@ -137,10 +140,15 @@ <tag><c>sslsocket() =</c></tag> <item><p>opaque()</p></item> - - <tag><marker id="type-protocol"/><c>protocol_version() =</c></tag> + + <tag><marker id="type-protocol"/><c> protocol_version() =</c></tag> + <item><p><c> ssl_tls_protocol() | dtls_protocol() </c></p></item> + <item><p><c>sslv3 | tlsv1 | 'tlsv1.1' | 'tlsv1.2'</c></p></item> + <tag><marker id="type-protocol"/><c> dtls_protocol() =</c></tag> + <item><p><c>'dtlsv1' | 'dtlsv1.2'</c></p></item> + <tag><c>ciphers() =</c></tag> <item><p><c>= [ciphersuite()]</c></p> <p>Tuples and string formats accepted by versions @@ -189,11 +197,23 @@ | sect193r1 | sect193r2 | secp192k1 | secp192r1 | sect163k1 | sect163r1 | sect163r2 | secp160k1 | secp160r1 | secp160r2</c></p></item> + <tag><c>hello_extensions() =</c></tag> + <item><p><c>#{renegotiation_info => + signature_algs => [{hash(), ecsda| rsa| dsa}] | undefined + alpn => binary() | undefined, + next_protocol_negotiation, + srp => string() | undefined, + ec_point_formats , + elliptic_curves = [oid] | undefined + sni = string()} + }</c></p></item> + + </taglist> </section> <section> - <title>SSL OPTION DESCRIPTIONS - COMMON for SERVER and CLIENT</title> + <title>TLS/DTLS OPTION DESCRIPTIONS - COMMON for SERVER and CLIENT</title> <p>The following options have the same meaning in the client and the server:</p> @@ -203,8 +223,16 @@ <tag><c>{protocol, tls | dtls}</c></tag> <item><p>Choose TLS or DTLS protocol for the transport layer security. Defaults to <c>tls</c> Introduced in OTP 20, DTLS support is considered - experimental in this release. DTLS over other transports than UDP are not yet supported.</p></item> - + experimental in this release. Other transports than UDP are not yet supported.</p></item> + + <tag><c>{handshake, hello | full}</c></tag> + <item><p> Defaults to <c>full</c>. If hello is specified the handshake will + pause after the hello message and give the user a possibility make decisions + based on hello extensions before continuing or aborting the handshake by calling + <seealso marker="#handshake_continue-3"> handshake_continue/3</seealso> or + <seealso marker="#handshake_cancel-1"> handshake_cancel/1</seealso> + </p></item> + <tag><c>{cert, public_key:der_encoded()}</c></tag> <item><p>The DER-encoded users certificate. If this option is supplied, it overrides option <c>certfile</c>.</p></item> @@ -256,8 +284,9 @@ <item><p>Specifies if to reject renegotiation attempt that does not live up to <url href="http://www.ietf.org/rfc/rfc5746.txt">RFC 5746</url>. - By default <c>secure_renegotiate</c> is set to <c>false</c>, - that is, secure renegotiation is used if possible, + By default <c>secure_renegotiate</c> is set to <c>true</c>, + that is, secure renegotiation is enforced. If set to <c>false</c> secure renegotiation + will still be used if possible, but it falls back to insecure renegotiation if the peer does not support <url href="http://www.ietf.org/rfc/rfc5746.txt">RFC 5746</url>.</p> @@ -298,11 +327,11 @@ atom()}} | <list type="bulleted"> <item><p>If the verify callback fun returns <c>{fail, Reason}</c>, the verification process is immediately stopped, an alert is - sent to the peer, and the TLS/SSL handshake terminates.</p></item> + sent to the peer, and the TLS/DTLS handshake terminates.</p></item> <item><p>If the verify callback fun returns <c>{valid, UserState}</c>, the verification process continues.</p></item> <item><p>If the verify callback fun always returns - <c>{valid, UserState}</c>, the TLS/SSL handshake does not + <c>{valid, UserState}</c>, the TLS/DTLS handshake does not terminate regarding verification failures and the connection is established.</p></item> <item><p>If called with an extension unknown to the user application, @@ -466,14 +495,15 @@ marker="public_key:public_key#pkix_path_validation-3">public_key:pkix_path_valid with the selected CA as trusted anchor and the rest of the chain.</p></item> <tag><c>{versions, [protocol_version()]}</c></tag> + <item><p>TLS protocol versions supported by started clients and servers. This option overrides the application environment option - <c>protocol_version</c>. If the environment option is not set, it defaults + <c>protocol_version</c> and <c>dtls_protocol_version</c>. If the environment option is not set, it defaults to all versions, except SSL-3.0, supported by the SSL application. See also <seealso marker="ssl:ssl_app">ssl(6).</seealso></p></item> <tag><c>{hibernate_after, integer()|undefined}</c></tag> - <item><p>When an integer-value is specified, <c>ssl_connection</c> + <item><p>When an integer-value is specified, <c>TLS/DTLS-connection</c> goes into hibernation after the specified number of milliseconds of inactivity, thus reducing its memory footprint. When <c>undefined</c> is specified (this is the default), the process @@ -533,7 +563,7 @@ fun(srp, Username :: string(), UserState :: term()) -> </section> <section> - <title>SSL OPTION DESCRIPTIONS - CLIENT SIDE</title> + <title>TLS/DTLS OPTION DESCRIPTIONS - CLIENT SIDE</title> <p>The following options are client-specific or have a slightly different meaning in the client than in the server:</p> @@ -673,7 +703,7 @@ fun(srp, Username :: string(), UserState :: term()) -> </section> <section> - <title>SSL OPTION DESCRIPTIONS - SERVER SIDE</title> + <title>TLS/DTLS OPTION DESCRIPTIONS - SERVER SIDE</title> <p>The following options are server-specific or have a slightly different meaning in the server than in the client:</p> @@ -711,7 +741,7 @@ fun(srp, Username :: string(), UserState :: term()) -> </p></item> <tag><c>{fail_if_no_peer_cert, boolean()}</c></tag> - <item><p>Used together with <c>{verify, verify_peer}</c> by an SSL server. + <item><p>Used together with <c>{verify, verify_peer}</c> by an TLS/DTLS server. If set to <c>true</c>, the server fails if the client does not have a certificate to send, that is, sends an empty certificate. If set to <c>false</c>, it fails only if the client sends an invalid @@ -725,7 +755,7 @@ fun(srp, Username :: string(), UserState :: term()) -> <tag><c>{reuse_session, fun(SuggestedSessionId, PeerCert, Compression, CipherSuite) -> boolean()}</c></tag> - <item><p>Enables the SSL server to have a local policy + <item><p>Enables the TLS/DTLS server to have a local policy for deciding if a session is to be reused or not. Meaningful only if <c>reuse_sessions</c> is set to <c>true</c>. <c>SuggestedSessionId</c> is a <c>binary()</c>, <c>PeerCert</c> is @@ -811,19 +841,13 @@ fun(srp, Username :: string(), UserState :: term()) -> client certificate is requested. For more details see the <seealso marker="#client_signature_algs">corresponding client option</seealso>. </p> </item> - <tag><c>{v2_hello_compatible, boolean()}</c></tag> - <item>If true, the server accepts clients that send hello messages on SSL-2.0 format but offers - supported SSL/TLS versions. Defaults to false, that is the server will not interoperate with clients that - offers SSL-2.0. - </item> - </taglist> </section> <section> <title>General</title> - <p>When an SSL socket is in active mode (the default), data from the + <p>When an TLS/DTLS socket is in active mode (the default), data from the socket is delivered to the owner of the socket in the form of messages:</p> @@ -884,7 +908,8 @@ fun(srp, Username :: string(), UserState :: term()) -> <v> Supported = default | all | anonymous </v> <v> Version = protocol_version() </v> </type> - <desc><p>Returns all default or all supported (except anonymous), or all anonymous cipher suites for a + <desc><p>Returns all default or all supported (except anonymous), + or all anonymous cipher suites for a TLS version</p> </desc> </func> @@ -899,7 +924,7 @@ fun(srp, Username :: string(), UserState :: term()) -> supported protocols and then deduplicating the output.</p> </desc> </func> - + <func> <name>clear_pem_cache() -> ok </name> <fsummary> Clears the pem cache</fsummary> @@ -914,34 +939,46 @@ fun(srp, Username :: string(), UserState :: term()) -> <func> <name>connect(Socket, SslOptions) -> </name> - <name>connect(Socket, SslOptions, Timeout) -> {ok, SslSocket} + <name>connect(Socket, SslOptions, Timeout) -> {ok, TLSSocket} | {ok, TLSSocket, Ext} | {error, Reason}</name> <fsummary>Upgrades a <c>gen_tcp</c>, or - equivalent, connected socket to an SSL socket.</fsummary> + equivalent, connected socket to an TLS socket.</fsummary> <type> <v>Socket = socket()</v> - <v>SslOptions = [ssl_option()]</v> + <v>SslOptions = [{handshake, hello| full} | ssl_option()]</v> <v>Timeout = integer() | infinity</v> - <v>SslSocket = sslsocket()</v> + <v>TLSSocket = sslsocket()</v> + <v>Ext = hello_extensions()</v> <v>Reason = term()</v> </type> <desc><p>Upgrades a <c>gen_tcp</c>, or equivalent, - connected socket to an SSL socket, that is, performs the - client-side ssl handshake.</p> + connected socket to an TLS socket, that is, performs the + client-side TLS handshake.</p> <note><p>If the option <c>verify</c> is set to <c>verify_peer</c> the option <c>server_name_indication</c> shall also be specified, if it is not no Server Name Indication extension will be sent, and <seealso marker="public_key:public_key#pkix_verify_hostname-2">public_key:pkix_verify_hostname/2</seealso> - will be called with the IP-address of the connection as <c>ReferenceID</c>, which is proably not what you want.</p></note> + will be called with the IP-address of the connection as <c>ReferenceID</c>, which is proably not what you want.</p> + </note> + + <p> If the option <c>{handshake, hello}</c> is used the + handshake is paused after receiving the server hello message + and the success response is <c>{ok, TLSSocket, Ext}</c> + instead of <c>{ok, TLSSocket}</c>. Thereafter the handshake is continued or + canceled by calling <seealso marker="#handshake_continue-3"> + <c>handshake_continue/3</c></seealso> or <seealso + marker="#handshake_cancel-1"><c>handshake_cancel/1</c></seealso>. + </p> + </desc> </func> <func> <name>connect(Host, Port, Options) -></name> <name>connect(Host, Port, Options, Timeout) -> - {ok, SslSocket} | {error, Reason}</name> - <fsummary>Opens an SSL connection to <c>Host</c>, <c>Port</c>.</fsummary> + {ok, SslSocket}| {ok, TLSSocket, Ext} | {error, Reason}</name> + <fsummary>Opens an TLS/DTLS connection to <c>Host</c>, <c>Port</c>.</fsummary> <type> <v>Host = host()</v> <v>Port = integer()</v> @@ -950,13 +987,13 @@ fun(srp, Username :: string(), UserState :: term()) -> <v>SslSocket = sslsocket()</v> <v>Reason = term()</v> </type> - <desc><p>Opens an SSL connection to <c>Host</c>, <c>Port</c>.</p> + <desc><p>Opens an TLS/DTLS connection to <c>Host</c>, <c>Port</c>.</p> <p> When the option <c>verify</c> is set to <c>verify_peer</c> the check <seealso marker="public_key:public_key#pkix_verify_hostname-2">public_key:pkix_verify_hostname/2</seealso> will be performed in addition to the usual x509-path validation checks. If the check fails the error {bad_cert, hostname_check_failed} will be propagated to the path validation fun <seealso marker="#verify_fun">verify_fun</seealso>, where it is possible to do customized - checks by using the full possibilitis of the <seealso marker="public_key:public_key#pkix_verify_hostname-2">public_key:pkix_verify_hostname/2</seealso> API. + checks by using the full possibilities of the <seealso marker="public_key:public_key#pkix_verify_hostname-3">public_key:pkix_verify_hostname/3</seealso> API. When the option <c>server_name_indication</c> is provided, its value (the DNS name) will be used as <c>ReferenceID</c> to <seealso marker="public_key:public_key#pkix_verify_hostname-2">public_key:pkix_verify_hostname/2</seealso>. @@ -967,29 +1004,39 @@ fun(srp, Username :: string(), UserState :: term()) -> <c>dns_id</c> will be assumed with a fallback to <c>ip</c> if that fails. </p> <note><p>According to good practices certificates should not use IP-addresses as "server names". It would be very surprising if this happen outside a closed network. </p></note> + + + <p> If the option <c>{handshake, hello}</c> is used the + handshake is paused after receiving the server hello message + and the success response is <c>{ok, TLSSocket, Ext}</c> + instead of <c>{ok, TLSSocket}</c>. Thereafter the handshake is continued or + canceled by calling <seealso marker="#handshake_continue-3"> + <c>handshake_continue/3</c></seealso> or <seealso + marker="#handshake_cancel-1"><c>handshake_cancel/1</c></seealso>. + </p> </desc> </func> <func> <name>close(SslSocket) -> ok | {error, Reason}</name> - <fsummary>Closes an SSL connection.</fsummary> + <fsummary>Closes an TLS/DTLS connection.</fsummary> <type> <v>SslSocket = sslsocket()</v> <v>Reason = term()</v> </type> - <desc><p>Closes an SSL connection.</p> + <desc><p>Closes an TLS/DTLS connection.</p> </desc> </func> <func> <name>close(SslSocket, How) -> ok | {ok, port()} | {error, Reason}</name> - <fsummary>Closes an SSL connection.</fsummary> + <fsummary>Closes an TLS connection.</fsummary> <type> <v>SslSocket = sslsocket()</v> <v>How = timeout() | {NewController::pid(), timeout()} </v> <v>Reason = term()</v> </type> - <desc><p>Closes or downgrades an SSL connection. In the latter case the transport + <desc><p>Closes or downgrades an TLS connection. In the latter case the transport connection will be handed over to the <c>NewController</c> process after receiving the TLS close alert from the peer. The returned transport socket will have the following options set: <c>[{active, false}, {packet, 0}, {mode, binary}]</c></p> @@ -1000,7 +1047,7 @@ fun(srp, Username :: string(), UserState :: term()) -> <name>controlling_process(SslSocket, NewOwner) -> ok | {error, Reason}</name> <fsummary>Assigns a new controlling process to the - SSL socket.</fsummary> + TLS/DTLS socket.</fsummary> <type> <v>SslSocket = sslsocket()</v> <v>NewOwner = pid()</v> @@ -1108,6 +1155,85 @@ fun(srp, Username :: string(), UserState :: term()) -> </func> <func> + <name>handshake(Socket) -> </name> + <name>handshake(Socket, Timeout) -> {ok, Socket} | {error, Reason}</name> + <fsummary>Performs server-side SSL/TLS handshake.</fsummary> + <type> + <v>Socket = sslsocket()</v> + <v>Timeout = integer()</v> + <v>Reason = term()</v> + </type> + <desc> + <p>Performs the SSL/TLS/DTLS server-side handshake.</p> + <p><c>Socket</c> is a socket as returned by + <seealso marker="#transport_accept-2">ssl:transport_accept/[1,2]</seealso>. + </p> + </desc> + </func> + + <func> + <name>handshake(Socket, SslOptions) -> </name> + <name>handshake(Socket, SslOptions, Timeout) -> {ok, Socket} | {ok, Socket, Ext} | {error, Reason}</name> + <fsummary>Performs server-side SSL/TLS/DTLS handshake.</fsummary> + <type> + <v>Socket = socket() | sslsocket() </v> + <v>Ext = hello_extensions()</v> + <v>SslOptions = [{handshake, hello| full} | ssl_option()]</v> + <v>Timeout = integer()</v> + <v>Reason = term()</v> + </type> + <desc> + <p>If <c>Socket</c> is a ordinary <c>socket()</c>: upgrades a <c>gen_tcp</c>, + or equivalent, socket to an SSL socket, that is, performs + the SSL/TLS server-side handshake and returns the SSL socket.</p> + + <warning><p>The Socket shall be in passive mode ({active, + false}) before calling this function or the handshake can fail + due to a race condition.</p></warning> + + <p>If <c>Socket</c> is an <c>sslsocket()</c>: provides extra SSL/TLS/DTLS + options to those specified in + <seealso marker="#listen-2">ssl:listen/2 </seealso> and then performs + the SSL/TLS/DTLS handshake.</p> + + <p> + If option <c>{handshake, hello}</c> is specified the handshake is + paused after receiving the client hello message and the + sucess response is <c>{ok, TLSSocket, Ext}</c> instead of <c>{ok, + TLSSocket}</c>. Thereafter the handshake is continued or + canceled by calling <seealso marker="#handshake_continue-3"> + <c>handshake_continue/3</c></seealso> or <seealso + marker="#handshake_cancel-1"><c>handshake_cancel/1</c></seealso>. + </p> + </desc> + </func> + + <func> + <name>handshake_cancel(Socket) -> ok </name> + <fsummary>Cancel handshake with a fatal alert</fsummary> + <type> + <v>Socket = sslsocket()</v> + </type> + <desc> + <p>Cancel the handshake with a fatal <c>USER_CANCELED</c> alert.</p> + </desc> + </func> + + <func> + <name>handshake_continue(Socket, SSLOptions, Timeout) -> {ok, Socket} | {error, Reason}</name> + <fsummary>Continue the SSL/TLS handshake.</fsummary> + <type> + <v>Socket = sslsocket()</v> + <v>SslOptions = [ssl_option()]</v> + <v>Timeout = integer()</v> + <v>Reason = term()</v> + </type> + <desc> + <p>Continue the SSL/TLS handshake possiby with new, additional or changed options.</p> + </desc> + </func> + + <func> <name>listen(Port, Options) -> {ok, ListenSocket} | {error, Reason}</name> <fsummary>Creates an SSL listen socket.</fsummary> @@ -1194,7 +1320,7 @@ fun(srp, Username :: string(), UserState :: term()) -> extra key material. It either takes user-generated values for <c>Secret</c> and <c>Seed</c> or atoms directing it to use a specific value from the session security parameters.</p> - <p>Can only be used with TLS connections; <c>{error, undefined}</c> + <p>Can only be used with TLS/DTLS connections; <c>{error, undefined}</c> is returned for SSLv3 connections.</p> </desc> </func> @@ -1294,7 +1420,7 @@ fun(srp, Username :: string(), UserState :: term()) -> <v>Reason = term()</v> </type> <desc> - <p>Performs the SSL/TLS server-side handshake.</p> + <p>Performs the SSL/TLS/DTLS server-side handshake.</p> <p><c>Socket</c> is a socket as returned by <seealso marker="#transport_accept-2">ssl:transport_accept/[1,2]</seealso> </p> @@ -1304,7 +1430,7 @@ fun(srp, Username :: string(), UserState :: term()) -> <func> <name>ssl_accept(Socket, SslOptions) -> </name> <name>ssl_accept(Socket, SslOptions, Timeout) -> {ok, Socket} | ok | {error, Reason}</name> - <fsummary>Performs server-side SSL/TLS handshake.</fsummary> + <fsummary>Performs server-side SSL/TLS/DTLS handshake.</fsummary> <type> <v>Socket = socket() | sslsocket() </v> <v>SslOptions = [ssl_option()]</v> @@ -1321,10 +1447,10 @@ fun(srp, Username :: string(), UserState :: term()) -> by calling this function, else the upgrade succeeds or does not succeed depending on timing.</p></warning> - <p>If <c>Socket</c> is an <c>sslsocket()</c>: provides extra SSL/TLS + <p>If <c>Socket</c> is an <c>sslsocket()</c>: provides extra SSL/TLS/DTLS options to those specified in <seealso marker="#listen-2">ssl:listen/2 </seealso> and then performs - the SSL/TLS handshake. + the SSL/TLS/DTLS handshake. </p> </desc> </func> @@ -1383,7 +1509,7 @@ fun(srp, Username :: string(), UserState :: term()) -> The socket returned is to be passed to <seealso marker="#ssl_accept-2"> ssl:ssl_accept[2,3]</seealso> to complete handshaking, that is, - establishing the SSL/TLS connection.</p> + establishing the SSL/TLS/DTLS connection.</p> <warning> <p>The socket returned can only be used with <seealso marker="#ssl_accept-2"> ssl:ssl_accept[2,3]</seealso>. @@ -1405,7 +1531,8 @@ fun(srp, Username :: string(), UserState :: term()) -> <fsummary>Returns version information relevant for the SSL application.</fsummary> <type> - <v>versions_info() = {app_vsn, string()} | {supported | available, [protocol_version()] </v> + <v>versions_info() = {app_vsn, string()} | {supported | available, [ssl_tls_protocol()]} | + {supported_dtls | available_dtls, [dtls_protocol()]} </v> </type> <desc> <p>Returns version information relevant for the SSL @@ -1415,19 +1542,35 @@ fun(srp, Username :: string(), UserState :: term()) -> <item>The application version of the SSL application.</item> <tag><c>supported</c></tag> - <item>TLS/SSL versions supported by default. + <item>SSL/TLS versions supported by default. Overridden by a version option on <seealso marker="#connect-2"> connect/[2,3,4]</seealso>, <seealso marker="#listen-2"> listen/2</seealso>, and <seealso marker="#ssl_accept-2">ssl_accept/[1,2,3]</seealso>. - For the negotiated TLS/SSL version, see <seealso + For the negotiated SSL/TLS version, see <seealso marker="#connection_information-1">ssl:connection_information/1 </seealso>.</item> - + + <tag><c>supported_dtls</c></tag> + <item>DTLS versions supported by default. + Overridden by a version option on + <seealso marker="#connect-2"> connect/[2,3,4]</seealso>, + <seealso marker="#listen-2"> listen/2</seealso>, and <seealso + marker="#ssl_accept-2">ssl_accept/[1,2,3]</seealso>. + For the negotiated DTLS version, see <seealso + marker="#connection_information-1">ssl:connection_information/1 + </seealso>.</item> + <tag><c>available</c></tag> - <item>All TLS/SSL versions supported by the SSL application. + <item>All SSL/TLS versions supported by the SSL application. TLS 1.2 requires sufficient support from the Crypto application.</item> + + <tag><c>available_dtls</c></tag> + <item>All DTLS versions supported by the SSL application. + DTLS 1.2 requires sufficient support from the Crypto + application.</item> + </taglist> </desc> </func> @@ -1438,6 +1581,7 @@ fun(srp, Username :: string(), UserState :: term()) -> <title>SEE ALSO</title> <p><seealso marker="kernel:inet">inet(3)</seealso> and <seealso marker="kernel:gen_tcp">gen_tcp(3)</seealso> + <seealso marker="kernel:gen_udp">gen_udp(3)</seealso> </p> </section> diff --git a/lib/ssl/doc/src/ssl_app.xml b/lib/ssl/doc/src/ssl_app.xml index f317dfded4..e22d43db0e 100644 --- a/lib/ssl/doc/src/ssl_app.xml +++ b/lib/ssl/doc/src/ssl_app.xml @@ -35,16 +35,21 @@ <description> <p> - The ssl application is an implementation of the SSL/TLS protocol in Erlang. + The ssl application is an implementation of the SSL/TLS/DTLS protocol in Erlang. </p> <list type="bulleted"> - <item>Supported SSL/TLS-versions are SSL-3.0, TLS-1.0, - TLS-1.1, and TLS-1.2.</item> - <item>For security reasons SSL-2.0 is not supported.</item> + <item>Supported SSL/TLS/DTLS-versions are SSL-3.0, TLS-1.0, + TLS-1.1, TLS-1.2, DTLS-1.0 (based on TLS-1.1), DTLS-1.2 (based on TLS-1.2)</item> + <item>For security reasons SSL-2.0 is not supported. + Interoperability with SSL-2.0 enabled clients dropped. (OTP 21) </item> <item>For security reasons SSL-3.0 is no longer supported by default, - but can be configured.</item> + but can be configured. (OTP 19) </item> + <item>For security reasons RSA key exchange cipher suites are no longer supported by default, + but can be configured. (OTP 21) </item> <item>For security reasons DES cipher suites are no longer supported by default, - but can be configured.</item> + but can be configured. (OTP 20) </item> + <item>For security reasons 3DES cipher suites are no longer supported by default, + but can be configured. (OTP 21) </item> <item> Renegotiation Indication Extension <url href="http://www.ietf.org/rfc/rfc5746.txt">RFC 5746</url> is supported </item> <item>Ephemeral Diffie-Hellman cipher suites are supported, @@ -72,7 +77,7 @@ <section> <title>DEPENDENCIES</title> - <p>The SSL application uses the <c>public_key</c> and + <p>The SSL application uses the <c>public_key</c>, <c>asn1</c> and Crypto application to handle public keys and encryption, hence these applications must be loaded for the SSL application to work. In an embedded environment this means they must be started with @@ -94,13 +99,20 @@ <p><c>erl -ssl protocol_version "['tlsv1.2', 'tlsv1.1']"</c></p> <taglist> - <tag><c>protocol_version = </c><seealso marker="ssl#type-protocol">ssl:protocol()</seealso><c><![CDATA[<optional>]]></c></tag> + <tag><c>protocol_version = </c><seealso marker="ssl#type-protocol">ssl:ssl_tls_protocol()</seealso><c><![CDATA[<optional>]]></c></tag> <item><p>Protocol supported by started clients and servers. If this option is not set, it defaults to all - protocols currently supported by the SSL application. + TLS protocols currently supported by the SSL application. This option can be overridden by the version option to <c>ssl:connect/[2,3]</c> and <c>ssl:listen/2</c>.</p></item> + <tag><c>dtls_protocol_version = </c><seealso marker="ssl#type-protocol">ssl:dtls_protocol()</seealso><c><![CDATA[<optional>]]></c></tag> + <item><p>Protocol supported by started clients and + servers. If this option is not set, it defaults to all + DTLS protocols currently supported by the SSL application. + This option can be overridden by the version option + to <c>ssl:connect/[2,3]</c> and <c>ssl:listen/2</c>.</p></item> + <tag><c><![CDATA[session_lifetime = integer() <optional>]]></c></tag> <item><p>Maximum lifetime of the session data in seconds. Defaults to 24 hours which is the maximum recommended lifetime by <url href="http://www.ietf.org/rfc/5246rfc.txt">RFC 5246</url>. However @@ -123,14 +135,14 @@ new client connections. If the maximum number of sessions is reached, the current cache entries will be invalidated regardless of their remaining lifetime. Defaults to - 1000.</p></item> + 1000. Recommended ssl-8.2.1 or later for this option to work as intended.</p></item> <tag> <c><![CDATA[session_cache_server_max = integer() <optional>]]></c></tag> <item><p>Limits the growth of the servers session cache, that is how many client sessions are cached by the server. If the maximum number of sessions is reached, the current cache entries will be invalidated regardless of their remaining - lifetime. Defaults to 1000.</p></item> + lifetime. Defaults to 1000. Recommended ssl-8.2.1 or later for this option to work as intended.</p></item> <tag><c><![CDATA[ssl_pem_cache_clean = integer() <optional>]]></c></tag> <item> @@ -145,9 +157,8 @@ <tag><c><![CDATA[bypass_pem_cache = boolean() <optional>]]></c></tag> <item> <p>Introduced in ssl-8.0.2. Disables the PEM-cache. - The PEM cache has proven to be a bottleneck, until the - implementation has been improved this can be used as - a workaround. Defaults to false. + Can be used as a workaround for the PEM-cache bottleneck + before ssl-8.1.1. Defaults to false. </p> </item> @@ -167,7 +178,7 @@ <title>ERROR LOGGER AND EVENT HANDLERS</title> <p>The SSL application uses the default <seealso marker="kernel:error_logger">OTP error logger</seealso> to log - unexpected errors and TLS alerts. The logging of TLS alerts may be + unexpected errors and TLS/DTLS alerts. The logging of TLS/DTLS alerts may be turned off with the <c>log_alert</c> option. </p> </section> diff --git a/lib/ssl/doc/src/ssl_crl_cache.xml b/lib/ssl/doc/src/ssl_crl_cache.xml index 7a67de3971..738487759a 100644 --- a/lib/ssl/doc/src/ssl_crl_cache.xml +++ b/lib/ssl/doc/src/ssl_crl_cache.xml @@ -40,7 +40,7 @@ <name>delete(Entries) -> ok | {error, Reason} </name> <fsummary> </fsummary> <type> - <v> Entries = <seealso marker="inets:http_uri">http_uri:uri() </seealso> | {file, string()} | {der, [<seealso + <v> Entries = <seealso marker="stdlib:uri_string">uri_string:uri_string()</seealso> | {file, string()} | {der, [<seealso marker="public_key:public_key"> public_key:der_encoded() </seealso>]}</v> <v> Reason = term()</v> </type> @@ -55,7 +55,7 @@ <type> <v> CRLSrc = {file, string()} | {der, [ <seealso marker="public_key:public_key"> public_key:der_encoded() </seealso> ]}</v> - <v> URI = <seealso marker="inets:http_uri">http_uri:uri() </seealso> </v> + <v> URI = <seealso marker="stdlib:uri_string">uri_string:uri_string() </seealso> </v> <v> Reason = term()</v> </type> <desc> @@ -63,4 +63,4 @@ </desc> </func> </funcs> -</erlref>
\ No newline at end of file +</erlref> diff --git a/lib/ssl/doc/src/ssl_distribution.xml b/lib/ssl/doc/src/ssl_distribution.xml index 7f8a08f704..e14f3f90dc 100644 --- a/lib/ssl/doc/src/ssl_distribution.xml +++ b/lib/ssl/doc/src/ssl_distribution.xml @@ -22,7 +22,7 @@ </legalnotice> - <title>Using SSL for Erlang Distribution</title> + <title>Using TLS for Erlang Distribution</title> <prepared>P Nyblom</prepared> <responsible></responsible> <docno></docno> @@ -33,7 +33,7 @@ <file>ssl_distribution.xml</file> </header> <p>This section describes how the Erlang distribution can use - SSL to get extra verification and security.</p> + TLS to get extra verification and security.</p> <p>The Erlang distribution can in theory use almost any connection-based protocol as bearer. However, a module that @@ -45,16 +45,16 @@ <p>In the SSL application, an extra distribution module, <c>inet_tls_dist</c>, can be used as an - alternative. All distribution connections will use SSL and + alternative. All distribution connections will use TLS and all participating Erlang nodes in a distributed system must use this distribution module.</p> <p>The security level depends on the parameters provided to the - SSL connection setup. Erlang node cookies are however always + TLS connection setup. Erlang node cookies are however always used, as they can be used to differentiate between two different Erlang networks.</p> - <p>To set up Erlang distribution over SSL:</p> + <p>To set up Erlang distribution over TLS:</p> <list type="bulleted"> <item><em>Step 1:</em> Build boot scripts including the @@ -63,13 +63,13 @@ <c>net_kernel</c>.</item> <item><em>Step 3:</em> Specify the security options and other SSL options.</item> - <item><em>Step 4:</em> Set up the environment to always use SSL.</item> + <item><em>Step 4:</em> Set up the environment to always use TLS.</item> </list> <p>The following sections describe these steps.</p> <section> - <title>Building Boot Scripts Including the ssl Application</title> + <title>Building Boot Scripts Including the SSL Application</title> <p>Boot scripts are built using the <c>systools</c> utility in the SASL application. For more information on <c>systools</c>, see the SASL documentation. This is only an example of @@ -90,7 +90,7 @@ STDLIB application.</p></item> </list> - <p>The following shows an example <c>.rel</c> file with SSL + <p>The following shows an example <c>.rel</c> file with TLS added:</p> <code type="none"> {release, {"OTP APN 181 01","R15A"}, {erts, "5.9"}, @@ -154,7 +154,7 @@ Eshell V5.0 (abort with ^G) <section> <title>Specifying Distribution Module for net_kernel</title> - <p>The distribution module for SSL is named <c>inet_tls_dist</c> + <p>The distribution module for SSL/TLS is named <c>inet_tls_dist</c> and is specified on the command line with option <c>-proto_dist</c>. The argument to <c>-proto_dist</c> is to be the module name without suffix <c>_dist</c>. So, this distribution @@ -174,21 +174,21 @@ Eshell V5.0 (abort with ^G) (ssl_test@myhost)1> </code> <p>However, a node started in this way refuses to talk - to other nodes, as no SSL parameters are supplied + to other nodes, as no TLS parameters are supplied (see the next section).</p> </section> <section> - <title>Specifying SSL Options</title> + <title>Specifying SSL/TLS Options</title> <p> - The SSL distribution options can be written into a file + The SSL/TLS distribution options can be written into a file that is consulted when the node is started. This file name is then specified with the command line argument <c>-ssl_dist_optfile</c>. </p> <p> - Any available SSL option can be specified in an options file, + Any available SSL/TLS option can be specified in an options file, but note that options that take a <c>fun()</c> has to use the syntax <c>fun Mod:Func/Arity</c> since a function body can not be compiled when consulting a file. @@ -202,7 +202,7 @@ Eshell V5.0 (abort with ^G) interfere severely, so beware! </p> <p> - For SSL to work, at least a public key and a certificate + For SSL/TLS to work, at least a public key and a certificate must be specified for the server side. In the following example, the PEM file <c>"/home/me/ssl/erlserver.pem"</c> contains both @@ -257,13 +257,13 @@ $ erl -boot /home/me/ssl/start_ssl -proto_dist inet_tls still be accepted if it does not present any certificate. </p> <p> - A node started in this way is fully functional, using SSL + A node started in this way is fully functional, using TLS as the distribution protocol. </p> </section> <section> - <title>Specifying SSL Options (Legacy)</title> + <title>Specifying SSL/TLS Options (Legacy)</title> <p> As in the previous section the PEM file @@ -272,9 +272,9 @@ $ erl -boot /home/me/ssl/start_ssl -proto_dist inet_tls </p> <p>On the <c>erl</c> command line you can specify options that the - SSL distribution adds when creating a socket.</p> + SSL/TLS distribution adds when creating a socket.</p> - <p>The simplest SSL options in the following list can be specified + <p>The simplest SSL/TLS options in the following list can be specified by adding the prefix <c>server_</c> or <c>client_</c> to the option name:</p> <list type="bulleted"> @@ -294,7 +294,7 @@ $ erl -boot /home/me/ssl/start_ssl -proto_dist inet_tls </list> <p>Note that <c>verify_fun</c> needs to be written in a different - form than the corresponding SSL option, since funs are not + form than the corresponding SSL/TLS option, since funs are not accepted on the command line.</p> <p>The server can also take the options <c>dhfile</c> and @@ -307,7 +307,7 @@ $ erl -boot /home/me/ssl/start_ssl -proto_dist inet_tls <p>Raw socket options, such as <c>packet</c> and <c>size</c> must not be specified on the command line.</p> - <p>The command-line argument for specifying the SSL options is named + <p>The command-line argument for specifying the SSL/TLS options is named <c>-ssl_dist_opt</c> and is to be followed by pairs of SSL options and their values. Argument <c>-ssl_dist_opt</c> can be repeated any number of times.</p> @@ -331,10 +331,10 @@ Eshell V5.0 (abort with ^G) </section> <section> - <title>Setting up Environment to Always Use SSL (Legacy)</title> + <title>Setting up Environment to Always Use SSL/TLS (Legacy)</title> <p>A convenient way to specify arguments to Erlang is to use environment variable <c>ERL_FLAGS</c>. All the flags needed to - use the SSL distribution can be specified in that variable and are + use the SSL/TLS distribution can be specified in that variable and are then interpreted as command-line arguments for all subsequent invocations of Erlang.</p> @@ -365,8 +365,8 @@ Eshell V5.0 (abort with ^G) </section> <section> - <title>Using SSL distribution over IPv6</title> - <p>It is possible to use SSL distribution over IPv6 instead of + <title>Using SSL/TLS distribution over IPv6</title> + <p>It is possible to use SSL/TLS distribution over IPv6 instead of IPv4. To do this, pass the option <c>-proto_dist inet6_tls</c> instead of <c>-proto_dist inet_tls</c> when starting Erlang, either on the command line or in the <c>ERL_FLAGS</c> environment @@ -380,6 +380,6 @@ $ erl -boot /home/me/ssl/start_ssl -proto_dist inet6_tls </code> <p>A node started in this way will only be able to communicate with - other nodes using SSL distribution over IPv6.</p> + other nodes using SSL/TLS distribution over IPv6.</p> </section> </chapter> diff --git a/lib/ssl/doc/src/ssl_introduction.xml b/lib/ssl/doc/src/ssl_introduction.xml index 25b05a769d..a416924eb1 100644 --- a/lib/ssl/doc/src/ssl_introduction.xml +++ b/lib/ssl/doc/src/ssl_introduction.xml @@ -5,7 +5,7 @@ <header> <copyright> <year>2015</year> - <year>2015</year> + <year>2017</year> <holder>Ericsson AB, All Rights Reserved</holder> </copyright> <legalnotice> @@ -41,14 +41,15 @@ authenticate the counterpart with whom they communicate, and to exchange a symmetric key for payload encryption. The protocol provides data/message confidentiality (encryption), integrity (through message authentication code checks) - and host verification (through certificate path validation).</p> + and host verification (through certificate path validation). DTLS (Datagram Transport Layer Security) that + is based on TLS but datagram oriented instead of stream oriented.</p> </section> <section> <title>Prerequisites</title> <p>It is assumed that the reader is familiar with the Erlang programming language, the concepts of OTP, and has a basic - understanding of SSL/TLS.</p> + understanding of SSL/TLS/DTLS.</p> </section> </chapter> diff --git a/lib/ssl/doc/src/ssl_protocol.xml b/lib/ssl/doc/src/ssl_protocol.xml index 31a22db58b..0b12dc7dc5 100644 --- a/lib/ssl/doc/src/ssl_protocol.xml +++ b/lib/ssl/doc/src/ssl_protocol.xml @@ -22,7 +22,7 @@ </legalnotice> - <title>TLS and its Predecessor, SSL</title> + <title>TLS/DTLS and TLS Predecessor, SSL</title> <prepared></prepared> <responsible></responsible> <docno></docno> @@ -33,7 +33,7 @@ <file>ssl_protocol.xml</file> </header> - <p>The Erlang SSL application implements the SSL/TLS protocol + <p>The Erlang SSL application implements the SSL/TLS/DTLS protocol for the currently supported versions, see the <seealso marker="ssl">ssl(3)</seealso> manual page. </p> @@ -41,20 +41,22 @@ <p>By default SSL/TLS is run over the TCP/IP protocol even though you can plug in any other reliable transport protocol with the same Application Programming Interface (API) as the - <c>gen_tcp</c> module in Kernel.</p> + <c>gen_tcp</c> module in Kernel. DTLS is by default run over UDP/IP, + which means that application data has no delivery guarentees. Other + transports, such as SCTP, may be supported in future releases.</p> <p>If a client and a server wants to use an upgrade mechanism, such as - defined by RFC 2817, to upgrade a regular TCP/IP connection to an SSL + defined by RFC 2817, to upgrade a regular TCP/IP connection to an TLS connection, this is supported by the Erlang SSL application API. This can be useful for, for example, supporting HTTP and HTTPS on the same port and - implementing virtual hosting. + implementing virtual hosting. Note this is a TLS feature only. </p> <section> <title>Security Overview</title> <p>To achieve authentication and privacy, the client and server - perform a TLS handshake procedure before transmitting or receiving + perform a TLS/DTLS handshake procedure before transmitting or receiving any data. During the handshake, they agree on a protocol version and cryptographic algorithms, generate shared secrets using public key cryptographies, and optionally authenticate each other with @@ -73,10 +75,10 @@ <p>The keys for the symmetric encryption are generated uniquely for each connection and are based on a secret negotiated - in the TLS handshake.</p> + in the TLS/DTLS handshake.</p> - <p>The TLS handshake protocol and data transfer is run on top of - the TLS Record Protocol, which uses a keyed-hash Message + <p>The TLS/DTLS handshake protocol and data transfer is run on top of + the TLS/DTLS Record Protocol, which uses a keyed-hash Message Authenticity Code (MAC), or a Hash-based MAC (HMAC), to protect the message data integrity. From the TLS RFC: "A Message Authentication Code is a @@ -152,8 +154,8 @@ from it was saved, for security reasons. The amount of time the session data is to be saved can be configured.</p> - <p>By default the SSL clients try to reuse an available session and - by default the SSL servers agree to reuse sessions when clients + <p>By default the TLS/DTLS clients try to reuse an available session and + by default the TLS/DTLS servers agree to reuse sessions when clients ask for it.</p> </section> diff --git a/lib/ssl/doc/src/using_ssl.xml b/lib/ssl/doc/src/using_ssl.xml index 775066ef7d..3ef33df719 100644 --- a/lib/ssl/doc/src/using_ssl.xml +++ b/lib/ssl/doc/src/using_ssl.xml @@ -22,7 +22,7 @@ </legalnotice> - <title>Using SSL API</title> + <title>Using SSL application API</title> <prepared></prepared> <responsible></responsible> <docno></docno> @@ -51,7 +51,7 @@ <section> <title>Minimal Example</title> - <note><p> The minimal setup is not the most secure setup of SSL.</p> + <note><p> The minimal setup is not the most secure setup of SSL/TLS/DTLS.</p> </note> <p>To set up client/server connections:</p> @@ -60,27 +60,27 @@ <code type="erl">1 server> ssl:start(). ok</code> - <p><em>Step 2:</em> Create an SSL listen socket:</p> + <p><em>Step 2:</em> Create an TLS listen socket: (To run DTLS add the option {protocol, dtls})</p> <code type="erl">2 server> {ok, ListenSocket} = ssl:listen(9999, [{certfile, "cert.pem"}, {keyfile, "key.pem"},{reuseaddr, true}]). {ok,{sslsocket, [...]}}</code> - <p><em>Step 3:</em> Do a transport accept on the SSL listen socket:</p> + <p><em>Step 3:</em> Do a transport accept on the TLS listen socket:</p> <code type="erl">3 server> {ok, Socket} = ssl:transport_accept(ListenSocket). {ok,{sslsocket, [...]}}</code> - <p><em>Step 4:</em> Start the client side:</p> + <p><em>Step 4:</em> Start the client side: </p> <code type="erl">1 client> ssl:start(). ok</code> - + <p> To run DTLS add the option {protocol, dtls} to third argument.</p> <code type="erl">2 client> {ok, Socket} = ssl:connect("localhost", 9999, [], infinity). {ok,{sslsocket, [...]}}</code> - <p><em>Step 5:</em> Do the SSL handshake:</p> + <p><em>Step 5:</em> Do the TLS handshake:</p> <code type="erl">4 server> ok = ssl:ssl_accept(Socket). ok</code> - <p><em>Step 6:</em> Send a message over SSL:</p> + <p><em>Step 6:</em> Send a message over TLS:</p> <code type="erl">5 server> ssl:send(Socket, "foo"). ok</code> @@ -92,7 +92,7 @@ ok</code> </section> <section> - <title>Upgrade Example</title> + <title>Upgrade Example - TLS only </title> <note><p>To upgrade a TCP/IP connection to an SSL connection, the client and server must agree to do so. The agreement @@ -125,24 +125,24 @@ ok</code> <code type="erl">4 server> inet:setopts(Socket, [{active, false}]). ok</code> - <p><em>Step 6:</em> Do the SSL handshake:</p> - <code type="erl">5 server> {ok, SSLSocket} = ssl:ssl_accept(Socket, [{cacertfile, "cacerts.pem"}, + <p><em>Step 6:</em> Do the TLS handshake:</p> + <code type="erl">5 server> {ok, TLSSocket} = ssl:ssl_accept(Socket, [{cacertfile, "cacerts.pem"}, {certfile, "cert.pem"}, {keyfile, "key.pem"}]). {ok,{sslsocket,[...]}}</code> - <p><em>Step 7:</em> Upgrade to an SSL connection. The client and server + <p><em>Step 7:</em> Upgrade to an TLS connection. The client and server must agree upon the upgrade. The server must call <c>ssl:accept/2</c> before the client calls <c>ssl:connect/3.</c></p> - <code type="erl">3 client>{ok, SSLSocket} = ssl:connect(Socket, [{cacertfile, "cacerts.pem"}, + <code type="erl">3 client>{ok, TLSSocket} = ssl:connect(Socket, [{cacertfile, "cacerts.pem"}, {certfile, "cert.pem"}, {keyfile, "key.pem"}], infinity). {ok,{sslsocket,[...]}}</code> - <p><em>Step 8:</em> Send a message over SSL:</p> - <code type="erl">4 client> ssl:send(SSLSocket, "foo"). + <p><em>Step 8:</em> Send a message over TLS:</p> + <code type="erl">4 client> ssl:send(TLSSocket, "foo"). ok</code> - <p><em>Step 9:</em> Set <c>active true</c> on the SSL socket:</p> - <code type="erl">4 server> ssl:setopts(SSLSocket, [{active, true}]). + <p><em>Step 9:</em> Set <c>active true</c> on the TLS socket:</p> + <code type="erl">4 server> ssl:setopts(TLSSocket, [{active, true}]). ok</code> <p><em>Step 10:</em> Flush the shell message queue to see that the message diff --git a/lib/ssl/src/Makefile b/lib/ssl/src/Makefile index 2e7df9792e..11b3e65912 100644 --- a/lib/ssl/src/Makefile +++ b/lib/ssl/src/Makefile @@ -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. @@ -84,11 +84,9 @@ MODULES= \ tls_record \ dtls_record \ ssl_record \ - ssl_v2 \ ssl_v3 \ tls_v1 \ - dtls_v1 \ - ssl_tls_dist_proxy + dtls_v1 INTERNAL_HRL_FILES = \ ssl_alert.hrl ssl_cipher.hrl \ diff --git a/lib/ssl/src/dtls_connection.erl b/lib/ssl/src/dtls_connection.erl index 03725089dd..220da71123 100644 --- a/lib/ssl/src/dtls_connection.erl +++ b/lib/ssl/src/dtls_connection.erl @@ -55,7 +55,7 @@ %% gen_statem state functions -export([init/3, error/3, downgrade/3, %% Initiation and take down states - hello/3, certify/3, cipher/3, abbreviated/3, %% Handshake states + hello/3, user_hello/3, certify/3, cipher/3, abbreviated/3, %% Handshake states connection/3]). %% gen_statem callbacks -export([callback_mode/0, terminate/3, code_change/4, format_status/2]). @@ -73,8 +73,7 @@ start_fsm(Role, Host, Port, Socket, {#ssl_options{erl_dist = false},_, Tracker} {ok, Pid} = dtls_connection_sup:start_child([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} + ssl_connection:handshake(SslSocket, Timeout) catch error:{badmatch, {error, _} = Error} -> Error @@ -473,7 +472,8 @@ init(Type, Event, State) -> error(enter, _, State) -> {keep_state, State}; error({call, From}, {start, _Timeout}, {Error, State}) -> - {stop_and_reply, normal, {reply, From, {error, Error}}, State}; + ssl_connection:stop_and_reply( + normal, {reply, From, {error, Error}}, State); error({call, _} = Call, Msg, State) -> gen_handshake(?FUNCTION_NAME, Call, Msg, State); error(_, _, _) -> @@ -491,10 +491,11 @@ hello(enter, _, #state{role = client} = State0) -> {State, Actions} = handle_flight_timer(State0), {keep_state, State, Actions}; hello(internal, #client_hello{cookie = <<>>, - client_version = Version} = Hello, #state{role = server, - transport_cb = Transport, - socket = Socket, - protocol_specific = #{current_cookie_secret := Secret}} = State0) -> + client_version = Version} = Hello, + #state{role = server, + transport_cb = Transport, + socket = Socket, + protocol_specific = #{current_cookie_secret := Secret}} = State0) -> {ok, {IP, Port}} = dtls_socket:peername(Transport, Socket), Cookie = dtls_handshake:cookie(Secret, IP, Port, Hello), %% FROM RFC 6347 regarding HelloVerifyRequest message: @@ -508,24 +509,6 @@ hello(internal, #client_hello{cookie = <<>>, {State2, Actions} = send_handshake(VerifyRequest, State1), {Record, State} = next_record(State2), next_event(?FUNCTION_NAME, 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, - protocol_specific = #{current_cookie_secret := Secret, - previous_cookie_secret := PSecret}} = State0) -> - {ok, {IP, Port}} = dtls_socket:peername(Transport, Socket), - case dtls_handshake:cookie(Secret, IP, Port, Hello) of - Cookie -> - handle_client_hello(Hello, State0); - _ -> - case dtls_handshake:cookie(PSecret, IP, Port, Hello) of - Cookie -> - handle_client_hello(Hello, State0); - _ -> - %% Handle bad cookie as new cookie request RFC 6347 4.1.2 - hello(internal, Hello#client_hello{cookie = <<>>}, State0) - end - end; hello(internal, #hello_verify_request{cookie = Cookie}, #state{role = client, host = Host, port = Port, ssl_options = SslOpts, @@ -550,6 +533,34 @@ hello(internal, #hello_verify_request{cookie = Cookie}, #state{role = client, Hello#client_hello.session_id}}, {Record, State} = next_record(State3), next_event(?FUNCTION_NAME, Record, State, Actions); +hello(internal, #client_hello{extensions = Extensions} = Hello, #state{ssl_options = #ssl_options{handshake = hello}, + start_or_recv_from = From} = State) -> + {next_state, user_hello, State#state{start_or_recv_from = undefined, + hello = Hello}, + [{reply, From, {ok, ssl_connection:map_extensions(Extensions)}}]}; +hello(internal, #server_hello{extensions = Extensions} = Hello, #state{ssl_options = #ssl_options{handshake = hello}, + start_or_recv_from = From} = State) -> + {next_state, user_hello, State#state{start_or_recv_from = undefined, + hello = Hello}, + [{reply, From, {ok, ssl_connection:map_extensions(Extensions)}}]}; +hello(internal, #client_hello{cookie = Cookie} = Hello, #state{role = server, + transport_cb = Transport, + socket = Socket, + protocol_specific = #{current_cookie_secret := Secret, + previous_cookie_secret := PSecret}} = State0) -> + {ok, {IP, Port}} = dtls_socket:peername(Transport, Socket), + case dtls_handshake:cookie(Secret, IP, Port, Hello) of + Cookie -> + handle_client_hello(Hello, State0); + _ -> + case dtls_handshake:cookie(PSecret, IP, Port, Hello) of + Cookie -> + handle_client_hello(Hello, State0); + _ -> + %% Handle bad cookie as new cookie request RFC 6347 4.1.2 + hello(internal, Hello#client_hello{cookie = <<>>}, State0) + end + end; hello(internal, #server_hello{} = Hello, #state{connection_states = ConnectionStates0, negotiated_version = ReqVersion, @@ -576,6 +587,11 @@ hello(state_timeout, Event, State) -> hello(Type, Event, State) -> gen_handshake(?FUNCTION_NAME, Type, Event, State). +user_hello(enter, _, State) -> + {keep_state, State}; +user_hello(Type, Event, State) -> + gen_handshake(?FUNCTION_NAME, Type, Event, State). + %%-------------------------------------------------------------------- -spec abbreviated(gen_statem:event_type(), term(), #state{}) -> gen_statem:state_function_result(). @@ -840,7 +856,7 @@ handle_info({Protocol, _, _, _, Data}, StateName, next_event(StateName, Record, State); #alert{} = Alert -> ssl_connection:handle_normal_shutdown(Alert, StateName, State0), - {stop, {shutdown, own_alert}} + ssl_connection:stop({shutdown, own_alert}, State0) end; handle_info({CloseTag, Socket}, StateName, #state{socket = Socket, @@ -865,7 +881,7 @@ handle_info({CloseTag, Socket}, StateName, ok end, ssl_connection:handle_normal_shutdown(?ALERT_REC(?FATAL, ?CLOSE_NOTIFY), StateName, State), - {stop, {shutdown, transport_closed}}; + ssl_connection:stop({shutdown, transport_closed}, State); true -> %% Fixes non-delivery of final DTLS record in {active, once}. %% Basically allows the application the opportunity to set {active, once} again @@ -893,7 +909,7 @@ handle_state_timeout(flight_retransmission_timeout, StateName, handle_alerts([], Result) -> Result; -handle_alerts(_, {stop,_} = Stop) -> +handle_alerts(_, {stop, _, _} = Stop) -> Stop; handle_alerts([Alert | Alerts], {next_state, StateName, State}) -> handle_alerts(Alerts, ssl_connection:handle_alert(Alert, StateName, State)); @@ -969,8 +985,7 @@ unprocessed_events(Events) -> update_handshake_history(#hello_verify_request{}, _, Hist) -> Hist; update_handshake_history(_, Handshake, Hist) -> - %% DTLS never needs option "v2_hello_compatible" to be true - ssl_handshake:update_handshake_history(Hist, iolist_to_binary(Handshake), false). + ssl_handshake:update_handshake_history(Hist, iolist_to_binary(Handshake)). prepare_flight(#state{flight_buffer = Flight, connection_states = ConnectionStates0, protocol_buffers = diff --git a/lib/ssl/src/dtls_handshake.erl b/lib/ssl/src/dtls_handshake.erl index 6071eece13..1a415a5f76 100644 --- a/lib/ssl/src/dtls_handshake.erl +++ b/lib/ssl/src/dtls_handshake.erl @@ -174,7 +174,9 @@ handle_client_hello(Version, signature_algs = ClientHashSigns} = HelloExt}, #ssl_options{versions = Versions, - signature_algs = SupportedHashSigns} = SslOpts, + signature_algs = SupportedHashSigns, + eccs = SupportedECCs, + honor_ecc_order = ECCOrder} = SslOpts, {Port, Session0, Cache, CacheCb, ConnectionStates0, Cert, _}, Renegotiation) -> case dtls_record:is_acceptable_version(Version, Versions) of @@ -182,7 +184,7 @@ handle_client_hello(Version, TLSVersion = dtls_v1:corresponding_tls_version(Version), AvailableHashSigns = ssl_handshake:available_signature_algs( ClientHashSigns, SupportedHashSigns, Cert,TLSVersion), - ECCCurve = ssl_handshake:select_curve(Curves, ssl_handshake:supported_ecc(TLSVersion)), + ECCCurve = ssl_handshake:select_curve(Curves, SupportedECCs, ECCOrder), {Type, #session{cipher_suite = CipherSuite} = Session1} = ssl_handshake:select_session(SugesstedId, CipherSuites, AvailableHashSigns, Compressions, diff --git a/lib/ssl/src/dtls_record.erl b/lib/ssl/src/dtls_record.erl index 316de05532..2938fd460f 100644 --- a/lib/ssl/src/dtls_record.erl +++ b/lib/ssl/src/dtls_record.erl @@ -440,7 +440,6 @@ get_dtls_records_aux(<<?BYTE(?CHANGE_CIPHER_SPEC),?BYTE(MajVer),?BYTE(MinVer), version = {MajVer, MinVer}, epoch = Epoch, sequence_number = SequenceNumber, fragment = Data} | Acc]); - get_dtls_records_aux(<<?BYTE(_), ?BYTE(_MajVer), ?BYTE(_MinVer), ?UINT16(Length), _/binary>>, _Acc) when Length > ?MAX_CIPHER_TEXT_LENGTH -> diff --git a/lib/ssl/src/dtls_udp_listener.erl b/lib/ssl/src/dtls_udp_listener.erl index 12e54a0e51..0608c6bd2b 100644 --- a/lib/ssl/src/dtls_udp_listener.erl +++ b/lib/ssl/src/dtls_udp_listener.erl @@ -35,7 +35,7 @@ -record(state, {port, - listner, + listener, dtls_options, emulated_options, dtls_msq_queues = kv_new(), @@ -81,7 +81,7 @@ init([Port, EmOpts, InetOptions, DTLSOptions]) -> first = true, dtls_options = DTLSOptions, emulated_options = EmOpts, - listner = Socket, + listener = Socket, close = false}} catch _:_ -> {stop, {shutdown, {error, closed}}} @@ -91,7 +91,7 @@ handle_call({accept, _}, _, #state{close = true} = State) -> handle_call({accept, Accepter}, From, #state{first = true, accepters = Accepters, - listner = Socket} = State0) -> + listener = Socket} = State0) -> next_datagram(Socket), State = State0#state{first = false, accepters = queue:in({Accepter, From}, Accepters)}, @@ -100,7 +100,7 @@ handle_call({accept, Accepter}, From, #state{first = true, handle_call({accept, Accepter}, From, #state{accepters = Accepters} = State0) -> State = State0#state{accepters = queue:in({Accepter, From}, Accepters)}, {noreply, State}; -handle_call(sockname, _, #state{listner = Socket} = State) -> +handle_call(sockname, _, #state{listener = Socket} = State) -> Reply = inet:sockname(Socket), {reply, Reply, State}; handle_call(close, _, #state{dtls_processes = Processes, @@ -114,7 +114,7 @@ handle_call(close, _, #state{dtls_processes = Processes, end, queue:to_list(Accepters)), {reply, ok, State#state{close = true, accepters = queue:new()}} end; -handle_call({get_sock_opts, {SocketOptNames, EmOptNames}}, _, #state{listner = Socket, +handle_call({get_sock_opts, {SocketOptNames, EmOptNames}}, _, #state{listener = Socket, emulated_options = EmOpts} = State) -> case get_socket_opts(Socket, SocketOptNames) of {ok, Opts} -> @@ -125,7 +125,7 @@ handle_call({get_sock_opts, {SocketOptNames, EmOptNames}}, _, #state{listner = S handle_call(get_all_opts, _, #state{dtls_options = DTLSOptions, emulated_options = EmOpts} = State) -> {reply, {ok, EmOpts, DTLSOptions}, State}; -handle_call({set_sock_opts, {SocketOpts, NewEmOpts}}, _, #state{listner = Socket, emulated_options = EmOpts0} = State) -> +handle_call({set_sock_opts, {SocketOpts, NewEmOpts}}, _, #state{listener = Socket, emulated_options = EmOpts0} = State) -> set_socket_opts(Socket, SocketOpts), EmOpts = do_set_emulated_opts(NewEmOpts, EmOpts0), {reply, ok, State#state{emulated_options = EmOpts}}. @@ -134,7 +134,7 @@ handle_cast({active_once, Client, Pid}, State0) -> State = handle_active_once(Client, Pid, State0), {noreply, State}. -handle_info({udp, Socket, IP, InPortNo, _} = Msg, #state{listner = Socket} = State0) -> +handle_info({udp, Socket, IP, InPortNo, _} = Msg, #state{listener = Socket} = State0) -> State = handle_datagram({IP, InPortNo}, Msg, State0), next_datagram(Socket), {noreply, State}; @@ -142,11 +142,11 @@ handle_info({udp, Socket, IP, InPortNo, _} = Msg, #state{listner = Socket} = Sta %% UDP socket does not have a connection and should not receive an econnreset %% This does however happens on on some windows versions. Just ignoring it %% appears to make things work as expected! -handle_info({udp_error, Socket, econnreset = Error}, #state{listner = Socket} = State) -> +handle_info({udp_error, Socket, econnreset = Error}, #state{listener = Socket} = State) -> Report = io_lib:format("Ignore SSL UDP Listener: Socket error: ~p ~n", [Error]), error_logger:info_report(Report), {noreply, State}; -handle_info({udp_error, Socket, Error}, #state{listner = Socket} = State) -> +handle_info({udp_error, Socket, Error}, #state{listener = Socket} = State) -> Report = io_lib:format("SSL UDP Listener shutdown: Socket error: ~p ~n", [Error]), error_logger:info_report(Report), {noreply, State#state{close=true}}; @@ -228,10 +228,10 @@ setup_new_connection(User, From, Client, Msg, #state{dtls_processes = Processes, dtls_msq_queues = MsgQueues, dtls_options = DTLSOpts, port = Port, - listner = Socket, + listener = Socket, emulated_options = EmOpts} = State) -> ConnArgs = [server, "localhost", Port, {self(), {Client, Socket}}, - {DTLSOpts, EmOpts, udp_listner}, User, dtls_socket:default_cb_info()], + {DTLSOpts, EmOpts, udp_listener}, User, dtls_socket:default_cb_info()], case dtls_connection_sup:start_child(ConnArgs) of {ok, Pid} -> erlang:monitor(process, Pid), diff --git a/lib/ssl/src/inet6_tls_dist.erl b/lib/ssl/src/inet6_tls_dist.erl index ffd7296f93..96ce4d493a 100644 --- a/lib/ssl/src/inet6_tls_dist.erl +++ b/lib/ssl/src/inet6_tls_dist.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2015. All Rights Reserved. +%% Copyright Ericsson AB 2015-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 @@ %% -module(inet6_tls_dist). --export([childspecs/0, listen/1, accept/1, accept_connection/5, +-export([childspecs/0]). +-export([listen/1, accept/1, accept_connection/5, setup/5, close/1, select/1]). childspecs() -> @@ -43,4 +44,4 @@ setup(Node, Type, MyNode, LongOrShortNames,SetupTime) -> inet_tls_dist:gen_setup(inet6_tcp, Node, Type, MyNode, LongOrShortNames,SetupTime). close(Socket) -> - inet_tls_dist:close(Socket). + inet_tls_dist:gen_close(inet6_tcp, Socket). diff --git a/lib/ssl/src/inet_tls_dist.erl b/lib/ssl/src/inet_tls_dist.erl index 4c677b9c33..8e605bec65 100644 --- a/lib/ssl/src/inet_tls_dist.erl +++ b/lib/ssl/src/inet_tls_dist.erl @@ -21,17 +21,26 @@ %% -module(inet_tls_dist). --export([childspecs/0, listen/1, accept/1, accept_connection/5, +-export([childspecs/0]). +-export([listen/1, accept/1, accept_connection/5, setup/5, close/1, select/1, is_node_name/1]). %% Generalized dist API -export([gen_listen/2, gen_accept/2, gen_accept_connection/6, - gen_setup/6, gen_select/2]). + gen_setup/6, gen_close/2, gen_select/2]). + +-export([split_node/1, nodelay/0]). + +-export([dbg/0]). % Debug -include_lib("kernel/include/net_address.hrl"). -include_lib("kernel/include/dist.hrl"). -include_lib("kernel/include/dist_util.hrl"). +-include("ssl_api.hrl"). + +%% ------------------------------------------------------------------------- + childspecs() -> {ok, [{ssl_dist_sup,{ssl_dist_sup, start_link, []}, permanent, infinity, supervisor, [ssl_dist_sup]}]}. @@ -40,127 +49,398 @@ select(Node) -> gen_select(inet_tcp, Node). gen_select(Driver, Node) -> - case split_node(atom_to_list(Node), $@, []) of - [_, Host] -> - case inet:getaddr(Host, Driver:family()) of + case split_node(Node) of + false -> + false; + Host -> + case Driver:getaddr(Host) of {ok, _} -> true; _ -> false - end; - _ -> - false + end end. -is_node_name(Node) when is_atom(Node) -> - select(Node); -is_node_name(_) -> - false. +%% ------------------------------------------------------------------------- + +is_node_name(Node) -> + case split_node(Node) of + false -> + false; + _Host -> + true + end. + +%% ------------------------------------------------------------------------- + +hs_data_common(#sslsocket{pid = DistCtrl} = SslSocket) -> + #hs_data{ + f_send = + fun (Ctrl, Packet) when Ctrl == DistCtrl -> + f_send(SslSocket, Packet) + end, + f_recv = + fun (Ctrl, Length, Timeout) when Ctrl == DistCtrl -> + f_recv(SslSocket, Length, Timeout) + end, + f_setopts_pre_nodeup = + fun (Ctrl) when Ctrl == DistCtrl -> + f_setopts_pre_nodeup(SslSocket) + end, + f_setopts_post_nodeup = + fun (Ctrl) when Ctrl == DistCtrl -> +%%% sys:trace(Ctrl, true), + f_setopts_post_nodeup(SslSocket) + end, + f_getll = + fun (Ctrl) when Ctrl == DistCtrl -> + f_getll(DistCtrl) + end, + f_address = + fun (Ctrl, Node) when Ctrl == DistCtrl -> + f_address(SslSocket, Node) + end, + mf_tick = + fun (Ctrl) when Ctrl == DistCtrl -> + mf_tick(DistCtrl) + end, + mf_getstat = + fun (Ctrl) when Ctrl == DistCtrl -> + mf_getstat(SslSocket) + end, + mf_setopts = + fun (Ctrl, Opts) when Ctrl == DistCtrl -> + mf_setopts(SslSocket, Opts) + end, + mf_getopts = + fun (Ctrl, Opts) when Ctrl == DistCtrl -> + mf_getopts(SslSocket, Opts) + end, + f_handshake_complete = + fun (Ctrl, Node, DHandle) when Ctrl == DistCtrl -> + f_handshake_complete(DistCtrl, Node, DHandle) + end}. + +f_send(SslSocket, Packet) -> + ssl:send(SslSocket, Packet). + +f_recv(SslSocket, Length, Timeout) -> + case ssl:recv(SslSocket, Length, Timeout) of + {ok, Bin} when is_binary(Bin) -> + {ok, binary_to_list(Bin)}; + Other -> + Other + end. + +f_setopts_pre_nodeup(_SslSocket) -> + ok. + +f_setopts_post_nodeup(_SslSocket) -> + ok. + +f_getll(DistCtrl) -> + {ok, DistCtrl}. + +f_address(SslSocket, Node) -> + case ssl:peername(SslSocket) of + {ok, Address} -> + case split_node(Node) of + false -> + {error, no_node}; + Host -> + #net_address{ + address=Address, host=Host, + protocol=tls, family=inet} + end + end. + +mf_tick(DistCtrl) -> + DistCtrl ! tick, + ok. + +mf_getstat(SslSocket) -> + case ssl:getstat( + SslSocket, [recv_cnt, send_cnt, send_pend]) of + {ok, Stat} -> + split_stat(Stat,0,0,0); + Error -> + Error + end. + +mf_setopts(SslSocket, Opts) -> + case setopts_filter(Opts) of + [] -> + ssl:setopts(SslSocket, Opts); + Opts1 -> + {error, {badopts,Opts1}} + end. + +mf_getopts(SslSocket, Opts) -> + ssl:getopts(SslSocket, Opts). + +f_handshake_complete(DistCtrl, Node, DHandle) -> + ssl_connection:handshake_complete(DistCtrl, Node, DHandle). + + +setopts_filter(Opts) -> + [Opt || {K,_} = Opt <- Opts, + K =:= active orelse K =:= deliver orelse K =:= packet]. + +split_stat([{recv_cnt, R}|Stat], _, W, P) -> + split_stat(Stat, R, W, P); +split_stat([{send_cnt, W}|Stat], R, _, P) -> + split_stat(Stat, R, W, P); +split_stat([{send_pend, P}|Stat], R, W, _) -> + split_stat(Stat, R, W, P); +split_stat([], R, W, P) -> + {ok, R, W, P}. + +%% ------------------------------------------------------------------------- listen(Name) -> gen_listen(inet_tcp, Name). gen_listen(Driver, Name) -> - ssl_tls_dist_proxy:listen(Driver, Name). + case inet_tcp_dist:gen_listen(Driver, Name) of + {ok, {Socket, Address, Creation}} -> + inet:setopts(Socket, [{packet, 4}]), + {ok, {Socket, Address#net_address{protocol=tls}, Creation}}; + Other -> + Other + end. + +%% ------------------------------------------------------------------------- accept(Listen) -> gen_accept(inet_tcp, Listen). gen_accept(Driver, Listen) -> - ssl_tls_dist_proxy:accept(Driver, Listen). + Kernel = self(), + monitor_pid( + spawn_opt( + fun () -> + accept_loop(Driver, Listen, Kernel) + end, + [link, {priority, max}])). -accept_connection(AcceptPid, Socket, MyNode, Allowed, SetupTime) -> - gen_accept_connection(inet_tcp, AcceptPid, Socket, MyNode, Allowed, SetupTime). +accept_loop(Driver, Listen, Kernel) -> + case Driver:accept(Listen) of + {ok, Socket} -> + Opts = get_ssl_options(server), + wait_for_code_server(), + case ssl:ssl_accept( + Socket, [{active, false}, {packet, 4}] ++ Opts, + net_kernel:connecttime()) of + {ok, #sslsocket{pid = DistCtrl} = SslSocket} -> + monitor_pid(DistCtrl), + trace( + Kernel ! + {accept, self(), DistCtrl, + Driver:family(), tls}), + receive + {Kernel, controller, Pid} -> + ok = ssl:controlling_process(SslSocket, Pid), + trace( + Pid ! {self(), controller}); + {Kernel, unsupported_protocol} -> + exit(trace(unsupported_protocol)) + end, + accept_loop(Driver, Listen, Kernel); + {error, {options, _}} = Error -> + %% Bad options: that's probably our fault. + %% Let's log that. + error_logger:error_msg( + "Cannot accept TLS distribution connection: ~s~n", + [ssl:format_error(Error)]), + _ = trace(Error), + gen_tcp:close(Socket); + Other -> + _ = trace(Other), + gen_tcp:close(Socket) + end; + Error -> + exit(trace(Error)) + end, + accept_loop(Driver, Listen, Kernel). + +wait_for_code_server() -> + %% This is an ugly hack. Upgrading a socket to TLS requires the + %% crypto module to be loaded. Loading the crypto module triggers + %% its on_load function, which calls code:priv_dir/1 to find the + %% directory where its NIF library is. However, distribution is + %% started earlier than the code server, so the code server is not + %% necessarily started yet, and code:priv_dir/1 might fail because + %% of that, if we receive an incoming connection on the + %% distribution port early enough. + %% + %% If the on_load function of a module fails, the module is + %% unloaded, and the function call that triggered loading it fails + %% with 'undef', which is rather confusing. + %% + %% Thus, the accept process will terminate, and be + %% restarted by ssl_dist_sup. However, it won't have any memory + %% of being asked by net_kernel to listen for incoming + %% connections. Hence, the node will believe that it's open for + %% distribution, but it actually isn't. + %% + %% So let's avoid that by waiting for the code server to start. + case whereis(code_server) of + undefined -> + timer:sleep(10), + wait_for_code_server(); + Pid when is_pid(Pid) -> + ok + end. -gen_accept_connection(Driver, AcceptPid, Socket, MyNode, Allowed, SetupTime) -> +%% ------------------------------------------------------------------------- + +accept_connection(AcceptPid, DistCtrl, MyNode, Allowed, SetupTime) -> + gen_accept_connection( + inet_tcp, AcceptPid, DistCtrl, MyNode, Allowed, SetupTime). + +gen_accept_connection( + Driver, AcceptPid, DistCtrl, MyNode, Allowed, SetupTime) -> Kernel = self(), - spawn_link(fun() -> do_accept(Driver, Kernel, AcceptPid, Socket, - MyNode, Allowed, SetupTime) end). + monitor_pid( + spawn_opt( + fun() -> + do_accept( + Driver, Kernel, AcceptPid, DistCtrl, + MyNode, Allowed, SetupTime) + end, + [link, {priority, max}])). + +do_accept(Driver, Kernel, AcceptPid, DistCtrl, MyNode, Allowed, SetupTime) -> + SslSocket = ssl_connection:get_sslsocket(DistCtrl), + receive + {AcceptPid, controller} -> + Timer = dist_util:start_timer(SetupTime), + case check_ip(Driver, SslSocket) of + true -> + HSData0 = hs_data_common(SslSocket), + HSData = + HSData0#hs_data{ + kernel_pid = Kernel, + this_node = MyNode, + socket = DistCtrl, + timer = Timer, + this_flags = 0, + allowed = Allowed}, + link(DistCtrl), + dist_util:handshake_other_started(trace(HSData)); + {false,IP} -> + error_logger:error_msg( + "** Connection attempt from " + "disallowed IP ~w ** ~n", [IP]), + ?shutdown2(no_node, trace({disallowed, IP})) + end + end. -setup(Node, Type, MyNode, LongOrShortNames,SetupTime) -> - gen_setup(inet_tcp, Node, Type, MyNode, LongOrShortNames,SetupTime). -gen_setup(Driver, Node, Type, MyNode, LongOrShortNames,SetupTime) -> + +setup(Node, Type, MyNode, LongOrShortNames, SetupTime) -> + gen_setup(inet_tcp, Node, Type, MyNode, LongOrShortNames, SetupTime). + +gen_setup(Driver, Node, Type, MyNode, LongOrShortNames, SetupTime) -> Kernel = self(), - spawn_opt(fun() -> do_setup(Driver, Kernel, Node, Type, MyNode, LongOrShortNames, SetupTime) end, [link, {priority, max}]). - + monitor_pid( + spawn_opt( + fun() -> + do_setup( + Driver, Kernel, Node, Type, + MyNode, LongOrShortNames, SetupTime) + end, + [link, {priority, max}])). + do_setup(Driver, Kernel, Node, Type, MyNode, LongOrShortNames, SetupTime) -> [Name, Address] = splitnode(Driver, Node, LongOrShortNames), - case inet:getaddr(Address, Driver:family()) of + case Driver:getaddr(Address) of {ok, Ip} -> - Timer = dist_util:start_timer(SetupTime), + Timer = trace(dist_util:start_timer(SetupTime)), ErlEpmd = net_kernel:epmd_module(), case ErlEpmd:port_please(Name, Ip) of {port, TcpPort, Version} -> - ?trace("port_please(~p) -> version ~p~n", - [Node,Version]), + Opts = + trace( + connect_options( + [{server_name_indication, atom_to_list(Node)} + |get_ssl_options(client)])), dist_util:reset_timer(Timer), - case - ssl_tls_dist_proxy:connect( - Driver, Address, TcpPort, - [{server_name_indication, atom_to_list(Node)}]) - of - {ok, Socket} -> - HSData = connect_hs_data(Kernel, Node, MyNode, Socket, - Timer, Version, Ip, TcpPort, Address, - Type), - dist_util:handshake_we_started(HSData); + case ssl:connect( + Address, TcpPort, + [binary, {active, false}, {packet, 4}, + Driver:family(), nodelay()] ++ Opts, + net_kernel:connecttime()) of + {ok, #sslsocket{pid = DistCtrl} = SslSocket} -> + monitor_pid(DistCtrl), + ok = ssl:controlling_process(SslSocket, self()), + HSData0 = hs_data_common(SslSocket), + HSData = + HSData0#hs_data{ + kernel_pid = Kernel, + other_node = Node, + this_node = MyNode, + socket = DistCtrl, + timer = Timer, + this_flags = 0, + other_version = Version, + request_type = Type}, + link(DistCtrl), + dist_util:handshake_we_started(trace(HSData)); Other -> %% Other Node may have closed since %% port_please ! - ?trace("other node (~p) " - "closed since port_please.~n", - [Node]), - ?shutdown2(Node, {shutdown, {connect_failed, Other}}) + ?shutdown2( + Node, + trace( + {ssl_connect_failed, Ip, TcpPort, Other})) end; Other -> - ?trace("port_please (~p) " - "failed.~n", [Node]), - ?shutdown2(Node, {shutdown, {port_please_failed, Other}}) + ?shutdown2( + Node, + trace( + {port_please_failed, ErlEpmd, Name, Ip, Other})) end; Other -> - ?trace("inet_getaddr(~p) " - "failed (~p).~n", [Node,Other]), - ?shutdown2(Node, {shutdown, {inet_getaddr_failed, Other}}) + ?shutdown2( + Node, + trace({getaddr_failed, Driver, Address, Other})) end. close(Socket) -> - gen_tcp:close(Socket), - ok. + gen_close(inet, Socket). + +gen_close(Driver, Socket) -> + trace(Driver:close(Socket)). -do_accept(Driver, Kernel, AcceptPid, Socket, MyNode, Allowed, SetupTime) -> - process_flag(priority, max), - receive - {AcceptPid, controller} -> - Timer = dist_util:start_timer(SetupTime), - case check_ip(Driver, Socket) of - true -> - HSData = accept_hs_data(Kernel, MyNode, Socket, Timer, Allowed), - dist_util:handshake_other_started(HSData); - {false,IP} -> - error_logger:error_msg("** Connection attempt from " - "disallowed IP ~w ** ~n", [IP]), - ?shutdown(no_node) - end - end. %% ------------------------------------------------------------ %% Do only accept new connection attempts from nodes at our %% own LAN, if the check_ip environment parameter is true. %% ------------------------------------------------------------ -check_ip(Driver, Socket) -> +check_ip(Driver, SslSocket) -> case application:get_env(check_ip) of {ok, true} -> - case get_ifs(Socket) of + case get_ifs(SslSocket) of {ok, IFs, IP} -> check_ip(Driver, IFs, IP); - _ -> - ?shutdown(no_node) + Other -> + ?shutdown2( + no_node, trace({check_ip_failed, SslSocket, Other})) end; _ -> true end. -get_ifs(Socket) -> +check_ip(Driver, [{OwnIP, _, Netmask}|IFs], PeerIP) -> + case {Driver:mask(Netmask, PeerIP), Driver:mask(Netmask, OwnIP)} of + {M, M} -> true; + _ -> check_ip(IFs, PeerIP) + end; +check_ip(_Driver, [], PeerIP) -> + {false, PeerIP}. + +get_ifs(#sslsocket{fd = {gen_tcp, Socket, _}}) -> case inet:peername(Socket) of {ok, {IP, _}} -> + %% XXX this is seriously broken for IPv6 case inet:getif(Socket) of {ok, IFs} -> {ok, IFs, IP}; Error -> Error @@ -169,125 +449,217 @@ get_ifs(Socket) -> Error end. -check_ip(Driver, [{OwnIP, _, Netmask}|IFs], PeerIP) -> - case {Driver:mask(Netmask, PeerIP), Driver:mask(Netmask, OwnIP)} of - {M, M} -> true; - _ -> check_ip(IFs, PeerIP) - end; -check_ip(_Driver, [], PeerIP) -> - {false, PeerIP}. - %% If Node is illegal terminate the connection setup!! splitnode(Driver, Node, LongOrShortNames) -> - case split_node(atom_to_list(Node), $@, []) of - [Name|Tail] when Tail =/= [] -> - Host = lists:append(Tail), + case string:split(atom_to_list(Node), "@") of + [Name, Host] when Host =/= [] -> check_node(Driver, Name, Node, Host, LongOrShortNames); [_] -> - error_logger:error_msg("** Nodename ~p illegal, no '@' character **~n", - [Node]), - ?shutdown(Node); + error_logger:error_msg( + "** Nodename ~p illegal, no '@' character **~n", + [Node]), + ?shutdown2(Node, trace({illegal_node_n@me, Node})); _ -> - error_logger:error_msg("** Nodename ~p illegal **~n", [Node]), - ?shutdown(Node) + error_logger:error_msg( + "** Nodename ~p illegal **~n", [Node]), + ?shutdown2(Node, trace({illegal_node_name, Node})) end. check_node(Driver, Name, Node, Host, LongOrShortNames) -> - case split_node(Host, $., []) of + case string:split(Host, ".") of [_] when LongOrShortNames == longnames -> case Driver:parse_address(Host) of {ok, _} -> [Name, Host]; _ -> - error_logger:error_msg("** System running to use " - "fully qualified " - "hostnames **~n" - "** Hostname ~s is illegal **~n", - [Host]), - ?shutdown(Node) + error_logger:error_msg( + "** System running to use " + "fully qualified hostnames **~n" + "** Hostname ~s is illegal **~n", + [Host]), + ?shutdown2(Node, trace({not_longnames, Host})) end; - [_, _ | _] when LongOrShortNames == shortnames -> - error_logger:error_msg("** System NOT running to use fully qualified " - "hostnames **~n" - "** Hostname ~s is illegal **~n", - [Host]), - ?shutdown(Node); + [_, _] when LongOrShortNames == shortnames -> + error_logger:error_msg( + "** System NOT running to use " + "fully qualified hostnames **~n" + "** Hostname ~s is illegal **~n", + [Host]), + ?shutdown2(Node, trace({not_shortnames, Host})); _ -> [Name, Host] end. -split_node([Chr|T], Chr, Ack) -> - [lists:reverse(Ack)|split_node(T, Chr, [])]; -split_node([H|T], Chr, Ack) -> - split_node(T, Chr, [H|Ack]); -split_node([], _, Ack) -> - [lists:reverse(Ack)]. - -connect_hs_data(Kernel, Node, MyNode, Socket, Timer, Version, Ip, TcpPort, Address, Type) -> - common_hs_data(Kernel, MyNode, Socket, Timer, - #hs_data{other_node = Node, - other_version = Version, - f_address = - fun(_,_) -> - #net_address{address = {Ip,TcpPort}, - host = Address, - protocol = proxy, - family = inet} - end, - request_type = Type - }). - -accept_hs_data(Kernel, MyNode, Socket, Timer, Allowed) -> - common_hs_data(Kernel, MyNode, Socket, Timer, #hs_data{ - allowed = Allowed, - f_address = fun get_remote_id/2 - }). - -common_hs_data(Kernel, MyNode, Socket, Timer, HsData) -> - HsData#hs_data{ - kernel_pid = Kernel, - this_node = MyNode, - socket = Socket, - timer = Timer, - this_flags = 0, - f_send = - fun(S,D) -> - gen_tcp:send(S,D) - end, - f_recv = - fun(S,N,T) -> - gen_tcp:recv(S,N,T) - end, - f_setopts_pre_nodeup = - fun(S) -> - inet:setopts(S, [{active, false}, {packet, 4}]) - end, - f_setopts_post_nodeup = - fun(S) -> - inet:setopts(S, [{deliver, port},{active, true}]) - end, - f_getll = - fun(S) -> - inet:getll(S) - end, - mf_tick = - fun(S) -> - gen_tcp:send(S, <<>>) - end, - mf_getstat = - fun(S) -> - {ok, Stats} = inet:getstat(S, [recv_cnt, send_cnt, send_pend]), - R = proplists:get_value(recv_cnt, Stats, 0), - W = proplists:get_value(send_cnt, Stats, 0), - P = proplists:get_value(send_pend, Stats, 0), - {ok, R,W,P} - end}. - -get_remote_id(Socket, _Node) -> - case ssl_tls_dist_proxy:get_tcp_address(Socket) of - {ok, Address} -> - Address; - {error, _Reason} -> - ?shutdown(no_node) +split_node(Node) when is_atom(Node) -> + case string:split(atom_to_list(Node), "@") of + [Name, Host] when Name =/= [], Host =/= [] -> + Host; + _ -> + false + end; +split_node(_) -> + false. + +%% ------------------------------------------------------------------------- + +connect_options(Opts) -> + case application:get_env(kernel, inet_dist_connect_options) of + {ok,ConnectOpts} -> + lists:ukeysort(1, ConnectOpts ++ Opts); + _ -> + Opts + end. + +%% we may not always want the nodelay behaviour +%% for performance reasons +nodelay() -> + case application:get_env(kernel, dist_nodelay) of + undefined -> + {nodelay, true}; + {ok, true} -> + {nodelay, true}; + {ok, false} -> + {nodelay, false}; + _ -> + {nodelay, true} end. + + +get_ssl_options(Type) -> + try ets:lookup(ssl_dist_opts, Type) of + [{Type, Opts}] -> + [{erl_dist, true} | Opts]; + _ -> + get_ssl_dist_arguments(Type) + catch + error:badarg -> + get_ssl_dist_arguments(Type) + end. + +get_ssl_dist_arguments(Type) -> + case init:get_argument(ssl_dist_opt) of + {ok, Args} -> + [{erl_dist, true} | ssl_options(Type, lists:append(Args))]; + _ -> + [{erl_dist, true}] + end. + +ssl_options(_,[]) -> + []; +ssl_options(server, ["client_" ++ _, _Value |T]) -> + ssl_options(server,T); +ssl_options(client, ["server_" ++ _, _Value|T]) -> + ssl_options(client,T); +ssl_options(server, ["server_certfile", Value|T]) -> + [{certfile, Value} | ssl_options(server,T)]; +ssl_options(client, ["client_certfile", Value | T]) -> + [{certfile, Value} | ssl_options(client,T)]; +ssl_options(server, ["server_cacertfile", Value|T]) -> + [{cacertfile, Value} | ssl_options(server,T)]; +ssl_options(client, ["client_cacertfile", Value|T]) -> + [{cacertfile, Value} | ssl_options(client,T)]; +ssl_options(server, ["server_keyfile", Value|T]) -> + [{keyfile, Value} | ssl_options(server,T)]; +ssl_options(client, ["client_keyfile", Value|T]) -> + [{keyfile, Value} | ssl_options(client,T)]; +ssl_options(server, ["server_password", Value|T]) -> + [{password, Value} | ssl_options(server,T)]; +ssl_options(client, ["client_password", Value|T]) -> + [{password, Value} | ssl_options(client,T)]; +ssl_options(server, ["server_verify", Value|T]) -> + [{verify, atomize(Value)} | ssl_options(server,T)]; +ssl_options(client, ["client_verify", Value|T]) -> + [{verify, atomize(Value)} | ssl_options(client,T)]; +ssl_options(server, ["server_verify_fun", Value|T]) -> + [{verify_fun, verify_fun(Value)} | ssl_options(server,T)]; +ssl_options(client, ["client_verify_fun", Value|T]) -> + [{verify_fun, verify_fun(Value)} | ssl_options(client,T)]; +ssl_options(server, ["server_crl_check", Value|T]) -> + [{crl_check, atomize(Value)} | ssl_options(server,T)]; +ssl_options(client, ["client_crl_check", Value|T]) -> + [{crl_check, atomize(Value)} | ssl_options(client,T)]; +ssl_options(server, ["server_crl_cache", Value|T]) -> + [{crl_cache, termify(Value)} | ssl_options(server,T)]; +ssl_options(client, ["client_crl_cache", Value|T]) -> + [{crl_cache, termify(Value)} | ssl_options(client,T)]; +ssl_options(server, ["server_reuse_sessions", Value|T]) -> + [{reuse_sessions, atomize(Value)} | ssl_options(server,T)]; +ssl_options(client, ["client_reuse_sessions", Value|T]) -> + [{reuse_sessions, atomize(Value)} | ssl_options(client,T)]; +ssl_options(server, ["server_secure_renegotiate", Value|T]) -> + [{secure_renegotiate, atomize(Value)} | ssl_options(server,T)]; +ssl_options(client, ["client_secure_renegotiate", Value|T]) -> + [{secure_renegotiate, atomize(Value)} | ssl_options(client,T)]; +ssl_options(server, ["server_depth", Value|T]) -> + [{depth, list_to_integer(Value)} | ssl_options(server,T)]; +ssl_options(client, ["client_depth", Value|T]) -> + [{depth, list_to_integer(Value)} | ssl_options(client,T)]; +ssl_options(server, ["server_hibernate_after", Value|T]) -> + [{hibernate_after, list_to_integer(Value)} | ssl_options(server,T)]; +ssl_options(client, ["client_hibernate_after", Value|T]) -> + [{hibernate_after, list_to_integer(Value)} | ssl_options(client,T)]; +ssl_options(server, ["server_ciphers", Value|T]) -> + [{ciphers, Value} | ssl_options(server,T)]; +ssl_options(client, ["client_ciphers", Value|T]) -> + [{ciphers, Value} | ssl_options(client,T)]; +ssl_options(server, ["server_dhfile", Value|T]) -> + [{dhfile, Value} | ssl_options(server,T)]; +ssl_options(server, ["server_fail_if_no_peer_cert", Value|T]) -> + [{fail_if_no_peer_cert, atomize(Value)} | ssl_options(server,T)]; +ssl_options(Type, Opts) -> + error(malformed_ssl_dist_opt, [Type, Opts]). + +atomize(List) when is_list(List) -> + list_to_atom(List); +atomize(Atom) when is_atom(Atom) -> + Atom. + +termify(String) when is_list(String) -> + {ok, Tokens, _} = erl_scan:string(String ++ "."), + {ok, Term} = erl_parse:parse_term(Tokens), + Term. + +verify_fun(Value) -> + case termify(Value) of + {Mod, Func, State} when is_atom(Mod), is_atom(Func) -> + Fun = fun Mod:Func/3, + {Fun, State}; + _ -> + error(malformed_ssl_dist_opt, [Value]) + end. + +%% ------------------------------------------------------------------------- + +%% Trace point +trace(Term) -> Term. + +%% Keep an eye on distribution Pid:s we know of +monitor_pid(Pid) -> + %%spawn( + %% fun () -> + %% MRef = erlang:monitor(process, Pid), + %% receive + %% {'DOWN', MRef, _, _, normal} -> + %% error_logger:error_report( + %% [dist_proc_died, + %% {reason, normal}, + %% {pid, Pid}]); + %% {'DOWN', MRef, _, _, Reason} -> + %% error_logger:info_report( + %% [dist_proc_died, + %% {reason, Reason}, + %% {pid, Pid}]) + %% end + %% end), + Pid. + +dbg() -> + dbg:stop(), + dbg:tracer(), + dbg:p(all, c), + dbg:tpl(?MODULE, cx), + dbg:tpl(erlang, dist_ctrl_get_data_notification, cx), + dbg:tpl(erlang, dist_ctrl_get_data, cx), + dbg:tpl(erlang, dist_ctrl_put_data, cx), + ok. diff --git a/lib/ssl/src/ssl.app.src b/lib/ssl/src/ssl.app.src index 762aa2f8d8..2aecb6836e 100644 --- a/lib/ssl/src/ssl.app.src +++ b/lib/ssl/src/ssl.app.src @@ -9,7 +9,6 @@ tls_socket, tls_v1, ssl_v3, - ssl_v2, tls_connection_sup, %% DTLS dtls_connection, @@ -37,7 +36,6 @@ %% Erlang Distribution over SSL/TLS inet_tls_dist, inet6_tls_dist, - ssl_tls_dist_proxy, ssl_dist_sup, ssl_dist_connection_sup, ssl_dist_admin_sup, @@ -63,7 +61,5 @@ {applications, [crypto, public_key, kernel, stdlib]}, {env, []}, {mod, {ssl_app, []}}, - {runtime_dependencies, ["stdlib-3.2","public_key-1.5","kernel-3.0", - "erts-7.0","crypto-4.2", "inets-5.10.7"]}]}. - - + {runtime_dependencies, ["stdlib-3.5","public_key-1.5","kernel-6.0", + "erts-10.0","crypto-4.2", "inets-5.10.7"]}]}. diff --git a/lib/ssl/src/ssl.erl b/lib/ssl/src/ssl.erl index fb4448e180..5b6d92ebf4 100644 --- a/lib/ssl/src/ssl.erl +++ b/lib/ssl/src/ssl.erl @@ -32,7 +32,9 @@ %% Socket handling -export([connect/3, connect/2, connect/4, listen/2, transport_accept/1, transport_accept/2, - ssl_accept/1, ssl_accept/2, ssl_accept/3, + handshake/1, handshake/2, handshake/3, + handshake_continue/3, handshake_cancel/1, + ssl_accept/1, ssl_accept/2, ssl_accept/3, controlling_process/2, peername/1, peercert/1, sockname/1, close/1, close/2, shutdown/2, recv/2, recv/3, send/2, getopts/2, setopts/2, getstat/1, getstat/2 @@ -45,7 +47,7 @@ format_error/1, renegotiate/1, prf/5, negotiated_protocol/1, connection_information/1, connection_information/2]). %% Misc --export([handle_options/2, tls_version/1]). +-export([handle_options/2, tls_version/1, new_ssl_options/3]). -include("ssl_api.hrl"). -include("ssl_internal.hrl"). @@ -170,23 +172,54 @@ transport_accept(#sslsocket{pid = {ListenSocket, ok | {ok, #sslsocket{}} | {error, reason()}. -spec ssl_accept(#sslsocket{} | port(), [ssl_option()] | [ssl_option()| transport_option()], timeout()) -> - {ok, #sslsocket{}} | {error, reason()}. + ok | {ok, #sslsocket{}} | {error, reason()}. %% %% Description: Performs accept on an ssl listen socket. e.i. performs %% ssl handshake. %%-------------------------------------------------------------------- ssl_accept(ListenSocket) -> - ssl_accept(ListenSocket, infinity). + ssl_accept(ListenSocket, [], infinity). +ssl_accept(Socket, Timeout) when (is_integer(Timeout) andalso Timeout >= 0) or (Timeout == infinity) -> + ssl_accept(Socket, [], Timeout); +ssl_accept(ListenSocket, SslOptions) when is_port(ListenSocket) -> + ssl_accept(ListenSocket, SslOptions, infinity); +ssl_accept(Socket, Timeout) -> + ssl_accept(Socket, [], Timeout). +ssl_accept(Socket, SslOptions, Timeout) when is_port(Socket) -> + handshake(Socket, SslOptions, Timeout); +ssl_accept(Socket, SslOptions, Timeout) -> + case handshake(Socket, SslOptions, Timeout) of + {ok, _} -> + ok; + Error -> + Error + end. +%%-------------------------------------------------------------------- +-spec handshake(#sslsocket{}) -> {ok, #sslsocket{}} | {error, reason()}. +-spec handshake(#sslsocket{} | port(), timeout()| [ssl_option() + | transport_option()]) -> + {ok, #sslsocket{}} | {error, reason()}. + +-spec handshake(#sslsocket{} | port(), [ssl_option()] | [ssl_option()| transport_option()], timeout()) -> + {ok, #sslsocket{}} | {error, reason()}. +%% +%% Description: Performs accept on an ssl listen socket. e.i. performs +%% ssl handshake. +%%-------------------------------------------------------------------- +handshake(ListenSocket) -> + handshake(ListenSocket, infinity). -ssl_accept(#sslsocket{} = Socket, Timeout) when (is_integer(Timeout) andalso Timeout >= 0) or (Timeout == infinity) -> +handshake(#sslsocket{} = Socket, Timeout) when (is_integer(Timeout) andalso Timeout >= 0) or + (Timeout == infinity) -> ssl_connection:handshake(Socket, Timeout); -ssl_accept(ListenSocket, SslOptions) when is_port(ListenSocket) -> - ssl_accept(ListenSocket, SslOptions, infinity). +handshake(ListenSocket, SslOptions) when is_port(ListenSocket) -> + handshake(ListenSocket, SslOptions, infinity). -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, SslOpts, Timeout) when +handshake(#sslsocket{} = Socket, [], Timeout) when (is_integer(Timeout) andalso Timeout >= 0) or + (Timeout == infinity)-> + handshake(Socket, Timeout); +handshake(#sslsocket{fd = {_, _, _, Tracker}} = Socket, SslOpts, Timeout) when (is_integer(Timeout) andalso Timeout >= 0) or (Timeout == infinity)-> try {ok, EmOpts, _} = tls_socket:get_all_opts(Tracker), @@ -195,7 +228,7 @@ ssl_accept(#sslsocket{fd = {_, _, _, Tracker}} = Socket, SslOpts, Timeout) when catch Error = {error, _Reason} -> Error end; -ssl_accept(#sslsocket{pid = Pid, fd = {_, _, _}} = Socket, SslOpts, Timeout) when +handshake(#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), @@ -204,8 +237,8 @@ ssl_accept(#sslsocket{pid = Pid, fd = {_, _, _}} = Socket, SslOpts, Timeout) whe catch Error = {error, _Reason} -> Error end; -ssl_accept(Socket, SslOptions, Timeout) when is_port(Socket), - (is_integer(Timeout) andalso Timeout >= 0) or (Timeout == infinity) -> +handshake(Socket, SslOptions, Timeout) when is_port(Socket), + (is_integer(Timeout) andalso Timeout >= 0) or (Timeout == infinity) -> {Transport,_,_,_} = proplists:get_value(cb_info, SslOptions, {gen_tcp, tcp, tcp_closed, tcp_error}), EmulatedOptions = tls_socket:emulated_options(), @@ -215,13 +248,31 @@ ssl_accept(Socket, SslOptions, Timeout) when is_port(Socket), {ok, #config{transport_info = CbInfo, ssl = SslOpts, emulated = EmOpts}} -> ok = tls_socket:setopts(Transport, Socket, tls_socket:internal_inet_values()), {ok, Port} = tls_socket:port(Transport, Socket), - ssl_connection:ssl_accept(ConnetionCb, Port, Socket, - {SslOpts, - tls_socket:emulated_socket_options(EmOpts, #socket_options{}), undefined}, - self(), CbInfo, Timeout) + ssl_connection:handshake(ConnetionCb, Port, Socket, + {SslOpts, + tls_socket:emulated_socket_options(EmOpts, #socket_options{}), undefined}, + self(), CbInfo, Timeout) catch Error = {error, _Reason} -> Error end. + +%%-------------------------------------------------------------------- +-spec handshake_continue(#sslsocket{}, [ssl_option()], timeout()) -> + {ok, #sslsocket{}} | {error, reason()}. +%% +%% +%% Description: Continues the handshke possible with newly supplied options. +%%-------------------------------------------------------------------- +handshake_continue(Socket, SSLOptions, Timeout) -> + ssl_connection:handshake_continue(Socket, SSLOptions, Timeout). +%%-------------------------------------------------------------------- +-spec handshake_cancel(#sslsocket{}) -> term(). +%% +%% Description: Cancels the handshakes sending a close alert. +%%-------------------------------------------------------------------- +handshake_cancel(Socket) -> + ssl_connection:handshake_cancel(Socket). + %%-------------------------------------------------------------------- -spec close(#sslsocket{}) -> term(). %% @@ -476,8 +527,9 @@ eccs() -> eccs_filter_supported(Curves). %%-------------------------------------------------------------------- --spec eccs(tls_record:tls_version() | tls_record:tls_atom_version()) -> - tls_v1:curves(). +-spec eccs(tls_record:tls_version() | tls_record:tls_atom_version() | + dtls_record:dtls_version() | dtls_record:dtls_atom_version()) -> + tls_v1:curves(). %% Description: returns the curves supported for a given version of %% ssl/tls. %%-------------------------------------------------------------------- @@ -486,8 +538,16 @@ eccs({3,0}) -> eccs({3,_}) -> Curves = tls_v1:ecc_curves(all), eccs_filter_supported(Curves); -eccs(AtomVersion) when is_atom(AtomVersion) -> - eccs(tls_record:protocol_version(AtomVersion)). +eccs({254,_} = Version) -> + eccs(dtls_v1:corresponding_tls_version(Version)); +eccs(Version) when Version == 'tlsv1.2'; + Version == 'tlsv1.1'; + Version == tlsv1; + Version == sslv3 -> + eccs(tls_record:protocol_version(Version)); +eccs(Version) when Version == 'dtlsv1.2'; + Version == 'dtlsv1'-> + eccs(dtls_v1:corresponding_tls_version(dtls_record:protocol_version(Version))). eccs_filter_supported(Curves) -> CryptoCurves = crypto:ec_curves(), @@ -618,16 +678,23 @@ sockname(#sslsocket{pid = Pid, fd = {Transport, Socket, _, _}}) when is_pid(Pid) %%--------------------------------------------------------------- -spec versions() -> [{ssl_app, string()} | {supported, [tls_record:tls_atom_version()]} | - {available, [tls_record:tls_atom_version()]}]. + {supported_dtls, [dtls_record:dtls_atom_version()]} | + {available, [tls_record:tls_atom_version()]} | + {available_dtls, [dtls_record:dtls_atom_version()]}]. %% %% Description: Returns a list of relevant versions. %%-------------------------------------------------------------------- versions() -> - Vsns = tls_record:supported_protocol_versions(), - SupportedVsns = [tls_record:protocol_version(Vsn) || Vsn <- Vsns], - AvailableVsns = ?ALL_AVAILABLE_VERSIONS, - %% TODO Add DTLS versions when supported - [{ssl_app, ?VSN}, {supported, SupportedVsns}, {available, AvailableVsns}]. + TLSVsns = tls_record:supported_protocol_versions(), + DTLSVsns = dtls_record:supported_protocol_versions(), + SupportedTLSVsns = [tls_record:protocol_version(Vsn) || Vsn <- TLSVsns], + SupportedDTLSVsns = [dtls_record:protocol_version(Vsn) || Vsn <- DTLSVsns], + AvailableTLSVsns = ?ALL_AVAILABLE_VERSIONS, + AvailableDTLSVsns = ?ALL_AVAILABLE_DATAGRAM_VERSIONS, + [{ssl_app, ?VSN}, {supported, SupportedTLSVsns}, + {supported_dtls, SupportedDTLSVsns}, + {available, AvailableTLSVsns}, + {available_dtls, AvailableDTLSVsns}]. %%--------------------------------------------------------------- @@ -707,7 +774,6 @@ tls_version({254, _} = Version) -> %%%-------------------------------------------------------------- %%% Internal functions %%%-------------------------------------------------------------------- - %% Possible filters out suites not supported by crypto available_suites(default) -> Version = tls_record:highest_protocol_version([]), @@ -832,7 +898,7 @@ handle_options(Opts0, Role, Host) -> %% Server side option reuse_session = handle_option(reuse_session, Opts, ReuseSessionFun), reuse_sessions = handle_option(reuse_sessions, Opts, true), - secure_renegotiate = handle_option(secure_renegotiate, Opts, false), + secure_renegotiate = handle_option(secure_renegotiate, Opts, true), client_renegotiation = handle_option(client_renegotiation, Opts, default_option_role(server, true, Role), server, Role), @@ -870,8 +936,8 @@ handle_options(Opts0, Role, Host) -> client, Role), crl_check = handle_option(crl_check, Opts, false), crl_cache = handle_option(crl_cache, Opts, {ssl_crl_cache, {internal, []}}), - v2_hello_compatible = handle_option(v2_hello_compatible, Opts, false), - max_handshake_size = handle_option(max_handshake_size, Opts, ?DEFAULT_MAX_HANDSHAKE_SIZE) + max_handshake_size = handle_option(max_handshake_size, Opts, ?DEFAULT_MAX_HANDSHAKE_SIZE), + handshake = handle_option(handshake, Opts, full) }, CbInfo = proplists:get_value(cb_info, Opts, default_cb_info(Protocol)), @@ -886,9 +952,8 @@ handle_options(Opts0, Role, Host) -> alpn_preferred_protocols, next_protocols_advertised, client_preferred_next_protocols, log_alert, server_name_indication, honor_cipher_order, padding_check, crl_check, crl_cache, - fallback, signature_algs, eccs, honor_ecc_order, beast_mitigation, v2_hello_compatible, - max_handshake_size], - + fallback, signature_algs, eccs, honor_ecc_order, beast_mitigation, + max_handshake_size, handshake], SockOpts = lists:foldl(fun(Key, PropList) -> proplists:delete(Key, PropList) end, Opts, SslOptions), @@ -900,8 +965,6 @@ handle_options(Opts0, Role, Host) -> inet_user = Sock, transport_info = CbInfo, connection_cb = ConnetionCb }}. - - handle_option(OptionName, Opts, Default, Role, Role) -> handle_option(OptionName, Opts, Default); handle_option(_, _, undefined = Value, _, _) -> @@ -1123,14 +1186,16 @@ validate_option(beast_mitigation, Value) when Value == one_n_minus_one orelse Value == zero_n orelse Value == disabled -> Value; -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(handshake, hello = Value) -> + Value; +validate_option(handshake, full = Value) -> + Value; validate_option(Opt, Value) -> throw({error, {options, {Opt, Value}}}). diff --git a/lib/ssl/src/ssl_alert.erl b/lib/ssl/src/ssl_alert.erl index 95ab955ad0..fc7b1e6d1c 100644 --- a/lib/ssl/src/ssl_alert.erl +++ b/lib/ssl/src/ssl_alert.erl @@ -48,7 +48,9 @@ decode(Bin) -> decode(Bin, [], 0). %%-------------------------------------------------------------------- --spec reason_code(#alert{}, client | server) -> closed | {essl, string()}. +-spec reason_code(#alert{}, client | server) -> + closed | {tls_alert, unicode:chardata()}. +%-spec reason_code(#alert{}, client | server) -> closed | {essl, string()}. %% %% Description: Returns the error reason that will be returned to the %% user. diff --git a/lib/ssl/src/ssl_cipher.erl b/lib/ssl/src/ssl_cipher.erl index 59cf05fd42..28b26fd358 100644 --- a/lib/ssl/src/ssl_cipher.erl +++ b/lib/ssl/src/ssl_cipher.erl @@ -36,10 +36,11 @@ -export([security_parameters/2, security_parameters/3, suite_definition/1, erl_suite_definition/1, cipher_init/3, decipher/6, cipher/5, decipher_aead/6, cipher_aead/6, - suite/1, suites/1, all_suites/1, crypto_support_filters/0, - ec_keyed_suites/0, anonymous_suites/1, psk_suites/1, psk_suites_anon/1, srp_suites/0, - srp_suites_anon/0, rc4_suites/1, des_suites/1, openssl_suite/1, openssl_suite_name/1, - filter/2, filter_suites/1, filter_suites/2, + suite/1, suites/1, all_suites/1, crypto_support_filters/0, + ec_keyed_suites/0, chacha_suites/1, anonymous_suites/1, psk_suites/1, psk_suites_anon/1, + srp_suites/0, srp_suites_anon/0, + rc4_suites/1, des_suites/1, rsa_suites/1, openssl_suite/1, openssl_suite_name/1, + filter/2, filter_suites/1, filter_suites/2, hash_algorithm/1, sign_algorithm/1, is_acceptable_hash/2, is_fallback/1, random_bytes/1, calc_mac_hash/4, is_stream_ciphersuite/1]). @@ -238,7 +239,7 @@ decipher(?AES_CBC, HashSz, CipherState, Fragment, Version, PaddingCheck) -> %%-------------------------------------------------------------------- -spec decipher_aead(cipher_enum(), #cipher_state{}, integer(), binary(), binary(), ssl_record:ssl_version()) -> - {binary(), binary(), #cipher_state{}} | #alert{}. + {binary(), #cipher_state{}} | #alert{}. %% %% Description: Decrypts the data and checks the associated data (AAD) MAC using %% cipher described by cipher_enum() and updating the cipher state. @@ -321,12 +322,28 @@ suites({_, Minor}) -> all_suites({3, _} = Version) -> suites(Version) + ++ chacha_suites(Version) ++ psk_suites(Version) ++ srp_suites() ++ rc4_suites(Version) - ++ des_suites(Version); + ++ des_suites(Version) + ++ rsa_suites(Version); + all_suites(Version) -> dtls_v1:all_suites(Version). +%%-------------------------------------------------------------------- +-spec chacha_suites(ssl_record:ssl_version() | integer()) -> [cipher_suite()]. +%% +%% Description: Returns list of the chacha cipher suites, only supported +%% if explicitly set by user for now due to interop problems, proably need +%% to be fixed in crypto. +%%-------------------------------------------------------------------- +chacha_suites({3, _}) -> + [?TLS_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256, + ?TLS_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256, + ?TLS_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256]; +chacha_suites(_) -> + []. %%-------------------------------------------------------------------- -spec anonymous_suites(ssl_record:ssl_version() | integer()) -> [cipher_suite()]. @@ -334,7 +351,6 @@ all_suites(Version) -> %% Description: Returns a list of the anonymous cipher suites, only supported %% if explicitly set by user. Intended only for testing. %%-------------------------------------------------------------------- - anonymous_suites({3, N}) -> srp_suites_anon() ++ anonymous_suites(N); anonymous_suites({254, _} = Version) -> @@ -400,20 +416,26 @@ psk_suites_anon(N) [ ?TLS_DHE_PSK_WITH_AES_256_GCM_SHA384, ?TLS_PSK_WITH_AES_256_GCM_SHA384, + ?TLS_ECDHE_PSK_WITH_AES_256_CBC_SHA384, ?TLS_DHE_PSK_WITH_AES_256_CBC_SHA384, ?TLS_PSK_WITH_AES_256_CBC_SHA384, + ?TLS_ECDHE_PSK_WITH_AES_128_GCM_SHA256, ?TLS_DHE_PSK_WITH_AES_128_GCM_SHA256, ?TLS_PSK_WITH_AES_128_GCM_SHA256, + ?TLS_ECDHE_PSK_WITH_AES_128_CBC_SHA256, ?TLS_DHE_PSK_WITH_AES_128_CBC_SHA256, ?TLS_PSK_WITH_AES_128_CBC_SHA256 ] ++ psk_suites_anon(0); psk_suites_anon(_) -> [?TLS_DHE_PSK_WITH_AES_256_CBC_SHA, ?TLS_PSK_WITH_AES_256_CBC_SHA, + ?TLS_ECDHE_PSK_WITH_AES_128_CBC_SHA, ?TLS_DHE_PSK_WITH_AES_128_CBC_SHA, ?TLS_PSK_WITH_AES_128_CBC_SHA, + ?TLS_ECDHE_PSK_WITH_3DES_EDE_CBC_SHA, ?TLS_DHE_PSK_WITH_3DES_EDE_CBC_SHA, ?TLS_PSK_WITH_3DES_EDE_CBC_SHA, + ?TLS_ECDHE_PSK_WITH_RC4_128_SHA, ?TLS_DHE_PSK_WITH_RC4_128_SHA, ?TLS_PSK_WITH_RC4_128_SHA]. %%-------------------------------------------------------------------- @@ -470,9 +492,39 @@ rc4_suites(N) when N =< 3 -> %%-------------------------------------------------------------------- des_suites(_)-> [?TLS_DHE_RSA_WITH_DES_CBC_SHA, - ?TLS_RSA_WITH_DES_CBC_SHA]. + ?TLS_RSA_WITH_DES_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 + ]. %%-------------------------------------------------------------------- +-spec rsa_suites(Version::ssl_record:ssl_version() | integer()) -> [cipher_suite()]. +%% +%% Description: Returns a list of the RSA key exchange +%% cipher suites, only supported if explicitly set by user. +%% Are not considered secure any more. +%%-------------------------------------------------------------------- +rsa_suites({3, 0}) -> + rsa_suites(0); +rsa_suites({3, Minor}) -> + rsa_suites(Minor) ++ rsa_suites(0); +rsa_suites(0) -> + [?TLS_RSA_WITH_AES_256_CBC_SHA, + ?TLS_RSA_WITH_AES_128_CBC_SHA, + ?TLS_RSA_WITH_3DES_EDE_CBC_SHA + ]; +rsa_suites(N) when N =< 3 -> + [ + ?TLS_RSA_WITH_AES_256_GCM_SHA384, + ?TLS_RSA_WITH_AES_256_CBC_SHA256, + ?TLS_RSA_WITH_AES_128_GCM_SHA256, + ?TLS_RSA_WITH_AES_128_CBC_SHA256 + ]. +%%-------------------------------------------------------------------- -spec suite_definition(cipher_suite()) -> erl_cipher_suite(). %% %% Description: Return erlang cipher suite definition. @@ -700,6 +752,22 @@ suite_definition(?TLS_RSA_PSK_WITH_AES_256_CBC_SHA) -> cipher => aes_256_cbc, mac => sha, prf => default_prf}; +%%% PSK NULL Cipher Suites RFC 4785 +suite_definition(?TLS_PSK_WITH_NULL_SHA) -> + #{key_exchange => psk, + cipher => null, + mac => sha, + prf => default_prf}; +suite_definition(?TLS_DHE_PSK_WITH_NULL_SHA) -> + #{key_exchange => dhe_psk, + cipher => null, + mac => sha, + prf => default_prf}; +suite_definition(?TLS_RSA_PSK_WITH_NULL_SHA) -> + #{key_exchange => rsa_psk, + cipher => null, + mac => sha, + prf => default_prf}; %%% TLS 1.2 PSK Cipher Suites RFC 5487 suite_definition(?TLS_PSK_WITH_AES_128_GCM_SHA256) -> #{key_exchange => psk, @@ -791,6 +859,67 @@ suite_definition(?TLS_RSA_PSK_WITH_NULL_SHA384) -> cipher => null, mac => sha384, prf => default_prf}; +%%% ECDHE PSK Cipher Suites RFC 5489 +suite_definition(?TLS_ECDHE_PSK_WITH_RC4_128_SHA) -> + #{key_exchange => ecdhe_psk, + cipher => rc4_128, + mac => sha, + prf => default_prf}; +suite_definition(?TLS_ECDHE_PSK_WITH_3DES_EDE_CBC_SHA) -> + #{key_exchange => ecdhe_psk, + cipher => '3des_ede_cbc', + mac => sha, + prf => default_prf}; +suite_definition(?TLS_ECDHE_PSK_WITH_AES_128_CBC_SHA) -> + #{key_exchange => ecdhe_psk, + cipher => aes_128_cbc, + mac => sha, + prf => default_prf}; +suite_definition(?TLS_ECDHE_PSK_WITH_AES_256_CBC_SHA) -> + #{key_exchange => ecdhe_psk, + cipher => aes_256_cbc, + mac => sha, + prf => default_prf}; +suite_definition(?TLS_ECDHE_PSK_WITH_AES_128_CBC_SHA256) -> + #{key_exchange => ecdhe_psk, + cipher => aes_128_cbc, + mac => sha256, + prf => default_prf}; +suite_definition(?TLS_ECDHE_PSK_WITH_AES_256_CBC_SHA384) -> + #{key_exchange => ecdhe_psk, + cipher => aes_256_cbc, + mac => sha384, + prf => default_prf}; +suite_definition(?TLS_ECDHE_PSK_WITH_NULL_SHA256) -> + #{key_exchange => ecdhe_psk, + cipher => null, + mac => sha256, + prf => default_prf}; +suite_definition(?TLS_ECDHE_PSK_WITH_NULL_SHA384) -> + #{key_exchange => ecdhe_psk, + cipher => null, mac => sha384, + prf => default_prf}; +%%% ECDHE_PSK with AES-GCM and AES-CCM Cipher Suites, draft-ietf-tls-ecdhe-psk-aead-05 +suite_definition(?TLS_ECDHE_PSK_WITH_AES_128_GCM_SHA256) -> + #{key_exchange => ecdhe_psk, + cipher => aes_128_gcm, + mac => null, + prf => sha256}; +suite_definition(?TLS_ECDHE_PSK_WITH_AES_256_GCM_SHA384) -> + #{key_exchange => ecdhe_psk, + cipher => aes_256_gcm, + mac => null, + prf => sha384}; +%% suite_definition(?TLS_ECDHE_PSK_WITH_AES_128_CCM_8_SHA256) -> +%% #{key_exchange => ecdhe_psk, +%% cipher => aes_128_ccm, +%% mac => null, +%% prf =>sha256}; +%% suite_definition(?TLS_ECDHE_PSK_WITH_AES_128_CCM_SHA256) -> +%% #{key_exchange => ecdhe_psk, +%% cipher => aes_256_ccm, +%% mac => null, +%% prf => sha256}; %%% SRP Cipher Suites RFC 5054 suite_definition(?TLS_SRP_SHA_WITH_3DES_EDE_CBC_SHA) -> #{key_exchange => srp_anon, @@ -1305,6 +1434,19 @@ suite(#{key_exchange := rsa_psk, cipher := aes_256_cbc, mac := sha}) -> ?TLS_RSA_PSK_WITH_AES_256_CBC_SHA; +%%% PSK NULL Cipher Suites RFC 4785 +suite(#{key_exchange := psk, + cipher := null, + mac := sha}) -> + ?TLS_PSK_WITH_NULL_SHA; +suite(#{key_exchange := dhe_psk, + cipher := null, + mac := sha}) -> + ?TLS_DHE_PSK_WITH_NULL_SHA; +suite(#{key_exchange := rsa_psk, + cipher := null, + mac := sha}) -> + ?TLS_RSA_PSK_WITH_NULL_SHA; %%% TLS 1.2 PSK Cipher Suites RFC 5487 suite(#{key_exchange := psk, cipher := aes_128_gcm, @@ -1384,6 +1526,60 @@ suite(#{key_exchange := rsa_psk, cipher := null, mac := sha384}) -> ?TLS_RSA_PSK_WITH_NULL_SHA384; +%%% ECDHE PSK Cipher Suites RFC 5489 +suite(#{key_exchange := ecdhe_psk, + cipher := rc4_128, + mac := sha}) -> + ?TLS_ECDHE_PSK_WITH_RC4_128_SHA; +suite(#{key_exchange := ecdhe_psk, + cipher :='3des_ede_cbc', + mac := sha}) -> + ?TLS_ECDHE_PSK_WITH_3DES_EDE_CBC_SHA; +suite(#{key_exchange := ecdhe_psk, + cipher := aes_128_cbc, + mac := sha}) -> + ?TLS_ECDHE_PSK_WITH_AES_128_CBC_SHA; +suite(#{key_exchange := ecdhe_psk, + cipher := aes_256_cbc, + mac := sha}) -> + ?TLS_ECDHE_PSK_WITH_AES_256_CBC_SHA; +suite(#{key_exchange := ecdhe_psk, + cipher := aes_128_cbc, + mac := sha256}) -> + ?TLS_ECDHE_PSK_WITH_AES_128_CBC_SHA256; +suite(#{key_exchange := ecdhe_psk, + cipher := aes_256_cbc, + mac := sha384}) -> + ?TLS_ECDHE_PSK_WITH_AES_256_CBC_SHA384; +suite(#{key_exchange := ecdhe_psk, + cipher := null, + mac := sha256}) -> + ?TLS_ECDHE_PSK_WITH_NULL_SHA256; +suite(#{key_exchange := ecdhe_psk, + cipher := null, + mac := sha384}) -> + ?TLS_ECDHE_PSK_WITH_NULL_SHA384; +%%% ECDHE_PSK with AES-GCM and AES-CCM Cipher Suites, draft-ietf-tls-ecdhe-psk-aead-05 +suite(#{key_exchange := ecdhe_psk, + cipher := aes_128_gcm, + mac := null, + prf := sha256}) -> + ?TLS_ECDHE_PSK_WITH_AES_128_GCM_SHA256; +suite(#{key_exchange := ecdhe_psk, + cipher := aes_256_gcm, + mac := null, + prf := sha384}) -> + ?TLS_ECDHE_PSK_WITH_AES_256_GCM_SHA384; + %% suite(#{key_exchange := ecdhe_psk, + %% cipher := aes_128_ccm, + %% mac := null, + %% prf := sha256}) -> + %% ?TLS_ECDHE_PSK_WITH_AES_128_CCM_8_SHA256; + %% suite(#{key_exchange := ecdhe_psk, + %% cipher := aes_256_ccm, + %% mac := null, + %% prf := sha256}) -> + %% ?TLS_ECDHE_PSK_WITH_AES_128_CCM_SHA256; %%% SRP Cipher Suites RFC 5054 suite(#{key_exchange := srp_anon, cipher := '3des_ede_cbc', @@ -2130,7 +2326,8 @@ is_acceptable_keyexchange(dhe_dss, Algos) -> is_acceptable_keyexchange(dhe_rsa, Algos) -> proplists:get_bool(dh, Algos) andalso proplists:get_bool(rsa, Algos); -is_acceptable_keyexchange(ecdh_anon, Algos) -> +is_acceptable_keyexchange(KeyExchange, Algos) when KeyExchange == ecdh_anon; + KeyExchange == ecdhe_psk -> proplists:get_bool(ecdh, Algos); is_acceptable_keyexchange(KeyExchange, Algos) when KeyExchange == ecdh_ecdsa; KeyExchange == ecdhe_ecdsa -> diff --git a/lib/ssl/src/ssl_cipher.hrl b/lib/ssl/src/ssl_cipher.hrl index 8e8f3d9c67..e5462d8402 100644 --- a/lib/ssl/src/ssl_cipher.hrl +++ b/lib/ssl/src/ssl_cipher.hrl @@ -399,6 +399,17 @@ %% TLS_RSA_PSK_WITH_AES_256_CBC_SHA = { 0x00, 0x95 }; -define(TLS_RSA_PSK_WITH_AES_256_CBC_SHA, <<?BYTE(16#00), ?BYTE(16#95)>>). +%%% PSK NULL Cipher Suites RFC 4785 + +%% TLS_PSK_WITH_NULL_SHA = { 0x00, 0x2C }; +-define(TLS_PSK_WITH_NULL_SHA, <<?BYTE(16#00), ?BYTE(16#2C)>>). + +%% TLS_DHE_PSK_WITH_NULL_SHA = { 0x00, 0x2D }; +-define(TLS_DHE_PSK_WITH_NULL_SHA, <<?BYTE(16#00), ?BYTE(16#2D)>>). + +%% TLS_RSA_PSK_WITH_NULL_SHA = { 0x00, 0x2E }; +-define(TLS_RSA_PSK_WITH_NULL_SHA, <<?BYTE(16#00), ?BYTE(16#2E)>>). + %%% TLS 1.2 PSK Cipher Suites RFC 5487 %% TLS_PSK_WITH_AES_128_GCM_SHA256 = {0x00,0xA8}; @@ -455,6 +466,46 @@ %% TLS_RSA_PSK_WITH_NULL_SHA384 = {0x00,0xB9}; -define(TLS_RSA_PSK_WITH_NULL_SHA384, <<?BYTE(16#00), ?BYTE(16#B9)>>). +%%% ECDHE PSK Cipher Suites RFC 5489 + +%% TLS_ECDHE_PSK_WITH_RC4_128_SHA = {0xC0,0x33}; +-define(TLS_ECDHE_PSK_WITH_RC4_128_SHA, <<?BYTE(16#C0), ?BYTE(16#33)>>). + +%% TLS_ECDHE_PSK_WITH_3DES_EDE_CBC_SHA = {0xC0,0x34}; +-define(TLS_ECDHE_PSK_WITH_3DES_EDE_CBC_SHA, <<?BYTE(16#C0), ?BYTE(16#34)>>). + +%% TLS_ECDHE_PSK_WITH_AES_128_CBC_SHA = {0xC0,0x35}; +-define(TLS_ECDHE_PSK_WITH_AES_128_CBC_SHA, <<?BYTE(16#C0), ?BYTE(16#35)>>). + +%% TLS_ECDHE_PSK_WITH_AES_256_CBC_SHA = {0xC0,0x36}; +-define(TLS_ECDHE_PSK_WITH_AES_256_CBC_SHA, <<?BYTE(16#C0), ?BYTE(16#36)>>). + +%% TLS_ECDHE_PSK_WITH_AES_128_CBC_SHA256 = {0xC0,0x37}; +-define(TLS_ECDHE_PSK_WITH_AES_128_CBC_SHA256, <<?BYTE(16#C0), ?BYTE(16#37)>>). + +%% TLS_ECDHE_PSK_WITH_AES_256_CBC_SHA384 = {0xC0,0x38}; +-define(TLS_ECDHE_PSK_WITH_AES_256_CBC_SHA384, <<?BYTE(16#C0), ?BYTE(16#38)>>). + +%% TLS_ECDHE_PSK_WITH_NULL_SHA256 = {0xC0,0x3A}; +-define(TLS_ECDHE_PSK_WITH_NULL_SHA256, <<?BYTE(16#C0), ?BYTE(16#3A)>>). + +%% TLS_ECDHE_PSK_WITH_NULL_SHA384 = {0xC0,0x3B}; +-define(TLS_ECDHE_PSK_WITH_NULL_SHA384, <<?BYTE(16#C0), ?BYTE(16#3B)>>). + +%%% ECDHE_PSK with AES-GCM and AES-CCM Cipher Suites, draft-ietf-tls-ecdhe-psk-aead-05 + +%% TLS_ECDHE_PSK_WITH_AES_128_GCM_SHA256 = {0xTBD; 0xTBD} {0xD0,0x01}; +-define(TLS_ECDHE_PSK_WITH_AES_128_GCM_SHA256, <<?BYTE(16#D0), ?BYTE(16#01)>>). + +%% TLS_ECDHE_PSK_WITH_AES_256_GCM_SHA384 = {0xTBD; 0xTBD} {0xD0,0x02}; +-define(TLS_ECDHE_PSK_WITH_AES_256_GCM_SHA384, <<?BYTE(16#D0), ?BYTE(16#02)>>). + +%% TLS_ECDHE_PSK_WITH_AES_128_CCM_8_SHA256 = {0xTBD; 0xTBD} {0xD0,0x03}; +-define(TLS_ECDHE_PSK_WITH_AES_128_CCM_8_SHA256, <<?BYTE(16#D0), ?BYTE(16#03)>>). + +%% TLS_ECDHE_PSK_WITH_AES_128_CCM_SHA256 = {0xTBD; 0xTBD} {0xD0,0x05}; +-define(TLS_ECDHE_PSK_WITH_AES_128_CCM_SHA256, <<?BYTE(16#D0), ?BYTE(16#05)>>). + %%% SRP Cipher Suites RFC 5054 %% TLS_SRP_SHA_WITH_3DES_EDE_CBC_SHA = { 0xC0,0x1A }; diff --git a/lib/ssl/src/ssl_connection.erl b/lib/ssl/src/ssl_connection.erl index 63fae78195..f816979b9f 100644 --- a/lib/ssl/src/ssl_connection.erl +++ b/lib/ssl/src/ssl_connection.erl @@ -37,7 +37,9 @@ -include_lib("public_key/include/public_key.hrl"). %% Setup --export([connect/8, ssl_accept/7, handshake/2, handshake/3, + +-export([connect/8, handshake/7, handshake/2, handshake/3, + handshake_continue/3, handshake_cancel/1, socket_control/4, socket_control/5, start_or_recv_cancel_timer/2]). %% User Events @@ -49,7 +51,7 @@ %% Alert and close handling -export([handle_own_alert/4, handle_alert/3, - handle_normal_shutdown/3 + handle_normal_shutdown/3, stop/2, stop_and_reply/3 ]). %% Data handling @@ -57,15 +59,19 @@ %% Help functions for tls|dtls_connection.erl -export([handle_session/7, ssl_config/3, - prepare_connection/2, hibernate_after/3]). + prepare_connection/2, hibernate_after/3, map_extensions/1]). %% General gen_statem state functions with extra callback argument %% to determine if it is an SSL/TLS or DTLS gen_statem machine --export([init/4, error/4, hello/4, abbreviated/4, certify/4, cipher/4, connection/4, downgrade/4]). +-export([init/4, error/4, hello/4, user_hello/4, abbreviated/4, certify/4, cipher/4, + connection/4, death_row/4, downgrade/4]). %% gen_statem callbacks -export([terminate/3, format_status/2]). +%% Erlang Distribution export +-export([get_sslsocket/1, handshake_complete/3]). + %%==================================================================== %% Setup %%==================================================================== @@ -89,7 +95,7 @@ connect(Connection, Host, Port, Socket, Options, User, CbInfo, Timeout) -> {error, ssl_not_started} end. %%-------------------------------------------------------------------- --spec ssl_accept(tls_connection | dtls_connection, +-spec handshake(tls_connection | dtls_connection, inet:port_number(), port(), {#ssl_options{}, #socket_options{}, undefined | pid()}, pid(), tuple(), timeout()) -> @@ -98,7 +104,7 @@ connect(Connection, Host, Port, Socket, Options, User, CbInfo, Timeout) -> %% Description: Performs accept on an ssl listen socket. e.i. performs %% ssl handshake. %%-------------------------------------------------------------------- -ssl_accept(Connection, Port, Socket, Opts, User, CbInfo, Timeout) -> +handshake(Connection, Port, Socket, Opts, User, CbInfo, Timeout) -> try Connection:start_fsm(server, "localhost", Port, Socket, Opts, User, CbInfo, Timeout) catch @@ -107,32 +113,60 @@ ssl_accept(Connection, Port, Socket, Opts, User, CbInfo, Timeout) -> end. %%-------------------------------------------------------------------- --spec handshake(#sslsocket{}, timeout()) -> ok | {error, reason()}. +-spec handshake(#sslsocket{}, timeout()) -> {ok, #sslsocket{}} | + {ok, #sslsocket{}, map()}| {error, reason()}. %% %% Description: Starts ssl handshake. %%-------------------------------------------------------------------- -handshake(#sslsocket{pid = Pid}, Timeout) -> +handshake(#sslsocket{pid = Pid} = Socket, Timeout) -> case call(Pid, {start, Timeout}) of connected -> - ok; + {ok, Socket}; + {ok, Ext} -> + {ok, Socket, Ext}; Error -> Error end. %%-------------------------------------------------------------------- -spec handshake(#sslsocket{}, {#ssl_options{},#socket_options{}}, - timeout()) -> ok | {error, reason()}. + timeout()) -> {ok, #sslsocket{}} | {error, reason()}. %% %% Description: Starts ssl handshake with some new options %%-------------------------------------------------------------------- -handshake(#sslsocket{pid = Pid}, SslOptions, Timeout) -> +handshake(#sslsocket{pid = Pid} = Socket, SslOptions, Timeout) -> case call(Pid, {start, SslOptions, Timeout}) of connected -> - ok; + {ok, Socket}; Error -> Error end. +%%-------------------------------------------------------------------- +-spec handshake_continue(#sslsocket{}, [ssl_option()], + timeout()) -> {ok, #sslsocket{}}| {error, reason()}. +%% +%% Description: Continues handshake with new options +%%-------------------------------------------------------------------- +handshake_continue(#sslsocket{pid = Pid} = Socket, SslOptions, Timeout) -> + case call(Pid, {handshake_continue, SslOptions, Timeout}) of + connected -> + {ok, Socket}; + Error -> + Error + end. +%%-------------------------------------------------------------------- +-spec handshake_cancel(#sslsocket{}) -> ok | {error, reason()}. +%% +%% Description: Cancels connection +%%-------------------------------------------------------------------- +handshake_cancel(#sslsocket{pid = Pid}) -> + case call(Pid, cancel) of + closed -> + ok; + Error -> + Error + end. %-------------------------------------------------------------------- -spec socket_control(tls_connection | dtls_connection, port(), pid(), atom()) -> {ok, #sslsocket{}} | {error, reason()}. @@ -146,8 +180,8 @@ socket_control(Connection, Socket, Pid, Transport) -> -spec socket_control(tls_connection | dtls_connection, port(), pid(), atom(), pid()| undefined) -> {ok, #sslsocket{}} | {error, reason()}. %%-------------------------------------------------------------------- -socket_control(Connection, Socket, Pid, Transport, udp_listner) -> - %% dtls listner process must have the socket control +socket_control(Connection, Socket, Pid, Transport, udp_listener) -> + %% dtls listener process must have the socket control {ok, Connection:socket(Pid, Transport, Socket, Connection, undefined)}; socket_control(tls_connection = Connection, Socket, Pid, Transport, ListenTracker) -> @@ -272,6 +306,13 @@ peer_certificate(ConnectionPid) -> renegotiation(ConnectionPid) -> call(ConnectionPid, renegotiate). + +get_sslsocket(ConnectionPid) -> + call(ConnectionPid, get_sslsocket). + +handshake_complete(ConnectionPid, Node, DHandle) -> + call(ConnectionPid, {handshake_complete, Node, DHandle}). + %%-------------------------------------------------------------------- -spec prf(pid(), binary() | 'master_secret', binary(), [binary() | ssl:prf_random()], non_neg_integer()) -> @@ -305,7 +346,7 @@ handle_own_alert(Alert, Version, StateName, catch _:_ -> ok end, - {stop, {shutdown, own_alert}}. + stop({shutdown, own_alert}, State). handle_normal_shutdown(Alert, _, #state{socket = Socket, transport_cb = Transport, @@ -329,24 +370,24 @@ handle_alert(#alert{level = ?FATAL} = Alert, StateName, protocol_cb = Connection, ssl_options = SslOpts, start_or_recv_from = From, host = Host, port = Port, session = Session, user_application = {_Mon, Pid}, - role = Role, socket_options = Opts, tracker = Tracker}) -> + role = Role, socket_options = Opts, tracker = Tracker} = State) -> invalidate_session(Role, Host, Port, Session), log_alert(SslOpts#ssl_options.log_alert, Role, Connection:protocol_name(), StateName, Alert#alert{role = opposite_role(Role)}), alert_user(Transport, Tracker, Socket, StateName, Opts, Pid, From, Alert, Role, Connection), - {stop, normal}; + stop(normal, State); handle_alert(#alert{level = ?WARNING, description = ?CLOSE_NOTIFY} = Alert, StateName, State) -> handle_normal_shutdown(Alert, StateName, State), - {stop, {shutdown, peer_close}}; + stop({shutdown, peer_close}, State); handle_alert(#alert{level = ?WARNING, description = ?NO_RENEGOTIATION} = Alert, StateName, #state{role = Role, ssl_options = SslOpts, protocol_cb = Connection, renegotiation = {true, internal}} = State) -> log_alert(SslOpts#ssl_options.log_alert, Role, Connection:protocol_name(), StateName, Alert#alert{role = opposite_role(Role)}), handle_normal_shutdown(Alert, StateName, State), - {stop, {shutdown, peer_close}}; + stop({shutdown, peer_close}, State); handle_alert(#alert{level = ?WARNING, description = ?NO_RENEGOTIATION} = Alert, StateName, #state{role = Role, @@ -371,7 +412,7 @@ handle_alert(#alert{level = ?WARNING} = Alert, StateName, %%==================================================================== %% Data handling %%==================================================================== -write_application_data(Data0, From, +write_application_data(Data0, {FromPid, _} = From, #state{socket = Socket, negotiated_version = Version, protocol_cb = Connection, @@ -386,10 +427,19 @@ write_application_data(Data0, From, Connection:renegotiate(State#state{renegotiation = {true, internal}}, [{next_event, {call, From}, {application_data, Data0}}]); false -> - {Msgs, ConnectionStates} = Connection:encode_data(Data, Version, ConnectionStates0), - Result = Connection:send(Transport, Socket, Msgs), - ssl_connection:hibernate_after(connection, State#state{connection_states = ConnectionStates}, - [{reply, From, Result}]) + {Msgs, ConnectionStates} = + Connection:encode_data(Data, Version, ConnectionStates0), + NewState = State#state{connection_states = ConnectionStates}, + case Connection:send(Transport, Socket, Msgs) of + ok when FromPid =:= self() -> + hibernate_after(connection, NewState, []); + Error when FromPid =:= self() -> + stop({shutdown, Error}, NewState); + ok -> + hibernate_after(connection, NewState, [{reply, From, ok}]); + Result -> + hibernate_after(connection, NewState, [{reply, From, Result}]) + end end. read_application_data(Data, #state{user_application = {_Mon, Pid}, @@ -409,30 +459,57 @@ read_application_data(Data, #state{user_application = {_Mon, Pid}, end, case get_data(SOpts, BytesToRead, Buffer1) of {ok, ClientData, Buffer} -> % Send data - SocketOpt = deliver_app_data(Transport, Socket, SOpts, - ClientData, Pid, RecvFrom, Tracker, Connection), - cancel_timer(Timer), - State = State0#state{user_data_buffer = Buffer, - start_or_recv_from = undefined, - timer = undefined, - bytes_to_read = undefined, - socket_options = SocketOpt - }, - if - SocketOpt#socket_options.active =:= false; Buffer =:= <<>> -> - %% Passive mode, wait for active once or recv - %% Active and empty, get more data - Connection:next_record_if_active(State); - true -> %% We have more data - read_application_data(<<>>, State) - end; + case State0 of + #state{ + ssl_options = #ssl_options{erl_dist = true}, + protocol_specific = #{d_handle := DHandle}} -> + State = + State0#state{ + user_data_buffer = Buffer, + bytes_to_read = undefined}, + try erlang:dist_ctrl_put_data(DHandle, ClientData) of + _ + when SOpts#socket_options.active =:= false; + Buffer =:= <<>> -> + %% Passive mode, wait for active once or recv + %% Active and empty, get more data + Connection:next_record_if_active(State); + _ -> %% We have more data + read_application_data(<<>>, State) + catch error:_ -> + death_row(State, disconnect) + end; + _ -> + SocketOpt = + deliver_app_data( + Transport, Socket, SOpts, + ClientData, Pid, RecvFrom, Tracker, Connection), + cancel_timer(Timer), + State = + State0#state{ + user_data_buffer = Buffer, + start_or_recv_from = undefined, + timer = undefined, + bytes_to_read = undefined, + socket_options = SocketOpt + }, + if + SocketOpt#socket_options.active =:= false; + Buffer =:= <<>> -> + %% Passive mode, wait for active once or recv + %% Active and empty, get more data + Connection:next_record_if_active(State); + true -> %% We have more data + read_application_data(<<>>, State) + end + end; {more, Buffer} -> % no reply, we need more data Connection:next_record(State0#state{user_data_buffer = Buffer}); {passive, Buffer} -> Connection:next_record_if_active(State0#state{user_data_buffer = Buffer}); {error,_Reason} -> %% Invalid packet in packet mode deliver_packet_error(Transport, Socket, SOpts, Buffer1, Pid, RecvFrom, Tracker, Connection), - {stop, normal, State0} + stop(normal, State0) end. %%==================================================================== %% Help functions for tls|dtls_connection.erl @@ -480,6 +557,9 @@ handle_session(#server_hello{cipher_suite = CipherSuite, -spec ssl_config(#ssl_options{}, client | server, #state{}) -> #state{}. %%-------------------------------------------------------------------- ssl_config(Opts, Role, State) -> + ssl_config(Opts, Role, State, new). + +ssl_config(Opts, Role, State0, Type) -> {ok, #{cert_db_ref := Ref, cert_db_handle := CertDbHandle, fileref_db_handle := FileRefHandle, @@ -489,20 +569,26 @@ ssl_config(Opts, Role, State) -> dh_params := DHParams, own_certificate := OwnCert}} = ssl_config:init(Opts, Role), - Handshake = ssl_handshake:init_handshake_history(), TimeStamp = erlang:monotonic_time(), - Session = State#state.session, - State#state{tls_handshake_history = Handshake, - session = Session#session{own_certificate = OwnCert, - time_stamp = TimeStamp}, - file_ref_db = FileRefHandle, - cert_db_ref = Ref, - cert_db = CertDbHandle, - crl_db = CRLDbHandle, - session_cache = CacheHandle, - private_key = Key, - diffie_hellman_params = DHParams, - ssl_options = Opts}. + Session = State0#state.session, + State = State0#state{session = Session#session{own_certificate = OwnCert, + time_stamp = TimeStamp}, + file_ref_db = FileRefHandle, + cert_db_ref = Ref, + cert_db = CertDbHandle, + crl_db = CRLDbHandle, + session_cache = CacheHandle, + private_key = Key, + diffie_hellman_params = DHParams, + ssl_options = Opts}, + case Type of + new -> + Handshake = ssl_handshake:init_handshake_history(), + State#state{tls_handshake_history = Handshake}; + continue -> + State + end. + %%==================================================================== %% gen_statem general state functions with connection cb argument @@ -524,11 +610,18 @@ init({call, From}, {start, {Opts, EmOpts}, Timeout}, socket_options = SockOpts} = State0, Connection) -> try SslOpts = ssl:handle_options(Opts, OrigSSLOptions), + case SslOpts of + #ssl_options{erl_dist = true} -> + process_flag(priority, max); + _ -> + ok + end, State = ssl_config(SslOpts, Role, State0), init({call, From}, {start, Timeout}, - State#state{ssl_options = SslOpts, socket_options = new_emulated(EmOpts, SockOpts)}, Connection) + State#state{ssl_options = SslOpts, + socket_options = new_emulated(EmOpts, SockOpts)}, Connection) catch throw:Error -> - {stop_and_reply, normal, {reply, From, {error, Error}}} + stop_and_reply(normal, {reply, From, {error, Error}}, State0) end; init({call, From}, Msg, State, Connection) -> handle_call(Msg, From, ?FUNCTION_NAME, State, Connection); @@ -559,6 +652,23 @@ hello(info, Msg, State, _) -> hello(Type, Msg, State, Connection) -> handle_common_event(Type, Msg, ?FUNCTION_NAME, State, Connection). +user_hello({call, From}, cancel, #state{negotiated_version = Version} = State, _) -> + gen_statem:reply(From, ok), + handle_own_alert(?ALERT_REC(?FATAL, ?USER_CANCELED, user_canceled), + Version, ?FUNCTION_NAME, State); +user_hello({call, From}, {handshake_continue, NewOptions, Timeout}, #state{hello = Hello, + role = Role, + start_or_recv_from = RecvFrom, + ssl_options = Options0} = State0, _Connection) -> + Timer = start_or_recv_cancel_timer(Timeout, RecvFrom), + Options = ssl:handle_options(NewOptions, Options0#ssl_options{handshake = full}), + State = ssl_config(Options, Role, State0, continue), + {next_state, hello, State#state{start_or_recv_from = From, + timer = Timer}, + [{next_event, internal, Hello}]}; +user_hello(_, _, _, _) -> + {keep_state_and_data, [postpone]}. + %%-------------------------------------------------------------------- -spec abbreviated(gen_statem:event_type(), #hello_request{} | #finished{} | term(), @@ -685,7 +795,7 @@ certify(internal, #server_key_exchange{exchange_keys = Keys}, when Alg == dhe_dss; Alg == dhe_rsa; Alg == ecdhe_rsa; Alg == ecdhe_ecdsa; Alg == dh_anon; Alg == ecdh_anon; - Alg == psk; Alg == dhe_psk; Alg == rsa_psk; + Alg == psk; Alg == dhe_psk; Alg == ecdhe_psk; Alg == rsa_psk; Alg == srp_dss; Alg == srp_rsa; Alg == srp_anon -> Params = ssl_handshake:decode_server_key(Keys, Alg, ssl:tls_version(Version)), @@ -709,6 +819,14 @@ certify(internal, #server_key_exchange{exchange_keys = Keys}, Version, ?FUNCTION_NAME, State) end end; +certify(internal, #certificate_request{}, + #state{role = client, negotiated_version = Version, + key_algorithm = Alg} = State, _) + when Alg == dh_anon; Alg == ecdh_anon; + Alg == psk; Alg == dhe_psk; Alg == ecdhe_psk; Alg == rsa_psk; + Alg == srp_dss; Alg == srp_rsa; Alg == srp_anon -> + handle_own_alert(?ALERT_REC(?FATAL, ?HANDSHAKE_FAILURE), + Version, ?FUNCTION_NAME, State); certify(internal, #certificate_request{} = CertRequest, #state{session = #session{own_certificate = Cert}, role = client, @@ -895,7 +1013,7 @@ cipher(Type, Msg, State, Connection) -> #state{}, tls_connection | dtls_connection) -> gen_statem:state_function_result(). %%-------------------------------------------------------------------- -connection({call, From}, {application_data, Data}, +connection({call, {FromPid, _} = From}, {application_data, Data}, #state{protocol_cb = Connection} = State, Connection) -> %% We should look into having a worker process to do this to %% parallize send and receive decoding and not block the receiver @@ -903,7 +1021,13 @@ connection({call, From}, {application_data, Data}, try write_application_data(Data, From, State) catch throw:Error -> - hibernate_after(?FUNCTION_NAME, State, [{reply, From, Error}]) + case self() of + FromPid -> + stop({shutdown, Error}, State); + _ -> + hibernate_after( + ?FUNCTION_NAME, State, [{reply, From, Error}]) + end end; connection({call, RecvFrom}, {recv, N, Timeout}, #state{protocol_cb = Connection, socket_options = @@ -931,8 +1055,64 @@ connection({call, From}, negotiated_protocol, #state{negotiated_protocol = SelectedProtocol} = State, _) -> hibernate_after(?FUNCTION_NAME, State, [{reply, From, {ok, SelectedProtocol}}]); +connection( + {call, From}, {handshake_complete, _Node, DHandle}, + #state{ + ssl_options = #ssl_options{erl_dist = true}, + socket_options = SockOpts, + protocol_specific = ProtocolSpecific} = State, + Connection) -> + %% From now on we execute on normal priority + process_flag(priority, normal), + try erlang:dist_ctrl_get_data_notification(DHandle) of + _ -> + NewState = + State#state{ + socket_options = + SockOpts#socket_options{active = true}, + protocol_specific = + ProtocolSpecific#{d_handle => DHandle}}, + {Record, NewerState} = Connection:next_record_if_active(NewState), + Connection:next_event(connection, Record, NewerState, [{reply, From, ok}]) + catch error:_ -> + death_row(State, disconnect) + end; connection({call, From}, Msg, State, Connection) -> handle_call(Msg, From, ?FUNCTION_NAME, State, Connection); +connection( + info, dist_data = Msg, + #state{ + ssl_options = #ssl_options{erl_dist = true}, + protocol_specific = #{d_handle := DHandle}} = State, + _) -> + eat_msgs(Msg), + try send_dist_data(?FUNCTION_NAME, State, DHandle, []) + catch error:_ -> + death_row(State, disconnect) + end; +connection( + info, {send, From, Ref, Data}, + #state{ + ssl_options = #ssl_options{erl_dist = true}, + protocol_specific = #{d_handle := _}}, + _) -> + %% This is for testing only! + %% + %% Needed by some OTP distribution + %% test suites... + From ! {Ref, ok}, + {keep_state_and_data, + [{next_event, {call, {self(), undefined}}, + {application_data, iolist_to_binary(Data)}}]}; +connection( + info, tick = Msg, + #state{ + ssl_options = #ssl_options{erl_dist = true}, + protocol_specific = #{d_handle := _}}, + _) -> + eat_msgs(Msg), + {keep_state_and_data, + [{next_event, {call, {self(), undefined}}, {application_data, <<>>}}]}; connection(info, Msg, State, _) -> handle_info(Msg, ?FUNCTION_NAME, State); connection(internal, {recv, _}, State, Connection) -> @@ -941,6 +1121,32 @@ connection(Type, Msg, State, Connection) -> handle_common_event(Type, Msg, ?FUNCTION_NAME, State, Connection). %%-------------------------------------------------------------------- +-spec death_row(gen_statem:event_type(), term(), + #state{}, tls_connection | dtls_connection) -> + gen_statem:state_function_result(). +%%-------------------------------------------------------------------- +%% We just wait for the owner to die which triggers the monitor, +%% or the socket may die too +death_row( + info, {'DOWN', MonitorRef, _, _, Reason}, + #state{user_application={MonitorRef,_Pid}}, + _) -> + {stop, {shutdown, Reason}}; +death_row( + info, {'EXIT', Socket, Reason}, #state{socket = Socket}, _) -> + {stop, {shutdown, Reason}}; +death_row(state_timeout, Reason, _State, _Connection) -> + {stop, {shutdown,Reason}}; +death_row(_Type, _Msg, _State, _Connection) -> + %% Waste all other events + keep_state_and_data. + +%% State entry function +death_row(State, Reason) -> + {next_state, death_row, State, + [{state_timeout, 5000, Reason}]}. + +%%-------------------------------------------------------------------- -spec downgrade(gen_statem:event_type(), term(), #state{}, tls_connection | dtls_connection) -> gen_statem:state_function_result(). @@ -951,10 +1157,10 @@ downgrade(internal, #alert{description = ?CLOSE_NOTIFY}, tls_socket:setopts(Transport, Socket, [{active, false}, {packet, 0}, {mode, binary}]), Transport:controlling_process(Socket, Pid), gen_statem:reply(From, {ok, Socket}), - {stop, normal, State}; + stop(normal, State); downgrade(timeout, downgrade, #state{downgrade = {_, From}} = State, _) -> gen_statem:reply(From, {error, timeout}), - {stop, normal, State}; + stop(normal, State); downgrade(Type, Event, State, Connection) -> handle_common_event(Type, Event, ?FUNCTION_NAME, State, Connection). @@ -969,9 +1175,8 @@ handle_common_event(internal, {handshake, {#hello_request{} = Handshake, _}}, co handle_common_event(internal, {handshake, {#hello_request{}, _}}, StateName, #state{role = client}, _) when StateName =/= connection -> {keep_state_and_data}; -handle_common_event(internal, {handshake, {Handshake, Raw}}, StateName, - #state{tls_handshake_history = Hs0, - ssl_options = #ssl_options{v2_hello_compatible = V2HComp}} = State0, +handle_common_event(internal, {handshake, {Handshake, Raw}}, StateName, + #state{tls_handshake_history = Hs0} = State0, Connection) -> PossibleSNI = Connection:select_sni_extension(Handshake), @@ -979,7 +1184,7 @@ handle_common_event(internal, {handshake, {Handshake, Raw}}, StateName, %% a client_hello, which needs to be determined by the connection callback. %% In other cases this is a noop State = handle_sni_extension(PossibleSNI, State0), - HsHist = ssl_handshake:update_handshake_history(Hs0, iolist_to_binary(Raw), V2HComp), + HsHist = ssl_handshake:update_handshake_history(Hs0, iolist_to_binary(Raw)), {next_state, StateName, State#state{tls_handshake_history = HsHist}, [{next_event, internal, Handshake}]}; handle_common_event(internal, {protocol_record, TLSorDTLSRecord}, StateName, State, Connection) -> @@ -988,8 +1193,8 @@ handle_common_event(timeout, hibernate, _, _, _) -> {keep_state_and_data, [hibernate]}; handle_common_event(internal, {application_data, Data}, StateName, State0, Connection) -> case read_application_data(Data, State0) of - {stop, Reason, State} -> - {stop, Reason, State}; + {stop, _, _} = Stop-> + Stop; {Record, State} -> Connection:next_event(StateName, Record, State) end; @@ -1018,13 +1223,14 @@ handle_call({close, _} = Close, From, StateName, State, Connection) -> %% Run terminate before returning so that the reuseaddr %% inet-option works properly Result = Connection:terminate(Close, StateName, State#state{terminated = true}), - {stop_and_reply, {shutdown, normal}, - {reply, From, Result}, State}; + stop_and_reply( + {shutdown, normal}, + {reply, From, Result}, State); handle_call({shutdown, How0}, From, _, #state{transport_cb = Transport, negotiated_version = Version, connection_states = ConnectionStates, - socket = Socket}, Connection) -> + socket = Socket} = State, Connection) -> case How0 of How when How == write; How == both -> Alert = ?ALERT_REC(?WARNING, ?CLOSE_NOTIFY), @@ -1040,7 +1246,7 @@ handle_call({shutdown, How0}, From, _, {keep_state_and_data, [{reply, From, ok}]}; Error -> gen_statem:reply(From, {error, Error}), - {stop, normal} + stop(normal, State) end; handle_call({recv, _N, _Timeout}, From, _, #state{socket_options = @@ -1075,6 +1281,15 @@ handle_call({set_opts, Opts0}, From, StateName, handle_call(renegotiate, From, StateName, _, _) when StateName =/= connection -> {keep_state_and_data, [{reply, From, {error, already_renegotiating}}]}; + +handle_call( + get_sslsocket, From, _StateName, + #state{transport_cb = Transport, socket = Socket, tracker = Tracker}, + Connection) -> + SslSocket = + Connection:socket(self(), Transport, Socket, Connection, Tracker), + {keep_state_and_data, [{reply, From, SslSocket}]}; + handle_call({prf, Secret, Label, Seed, WantedLength}, From, _, #state{connection_states = ConnectionStates, negotiated_version = Version}, _) -> @@ -1111,29 +1326,50 @@ handle_info({ErrorTag, Socket, econnaborted}, StateName, tracker = Tracker} = State) when StateName =/= connection -> alert_user(Transport, Tracker,Socket, StartFrom, ?ALERT_REC(?FATAL, ?CLOSE_NOTIFY), Role, Connection), - {stop, normal, State}; + stop(normal, State); + handle_info({ErrorTag, Socket, Reason}, StateName, #state{socket = Socket, error_tag = ErrorTag} = State) -> Report = io_lib:format("SSL: Socket error: ~p ~n", [Reason]), - error_logger:info_report(Report), + error_logger:error_report(Report), handle_normal_shutdown(?ALERT_REC(?FATAL, ?CLOSE_NOTIFY), StateName, State), - {stop, normal, State}; -handle_info({'DOWN', MonitorRef, _, _, _}, _, - State = #state{user_application={MonitorRef,_Pid}}) -> - {stop, normal, State}; + stop(normal, State); + +handle_info( + {'DOWN', MonitorRef, _, _, Reason}, _, + #state{ + user_application = {MonitorRef, _Pid}, + ssl_options = #ssl_options{erl_dist = true}}) -> + {stop, {shutdown, Reason}}; +handle_info( + {'DOWN', MonitorRef, _, _, _}, _, + #state{user_application = {MonitorRef, _Pid}}) -> + {stop, normal}; +handle_info( + {'EXIT', Pid, _Reason}, StateName, + #state{user_application = {_MonitorRef, Pid}} = State) -> + %% It seems the user application has linked to us + %% - ignore that and let the monitor handle this + {next_state, StateName, State}; + %%% So that terminate will be run when supervisor issues shutdown handle_info({'EXIT', _Sup, shutdown}, _StateName, State) -> - {stop, shutdown, State}; + stop(shutdown, State); handle_info({'EXIT', Socket, normal}, _StateName, #state{socket = Socket} = State) -> %% Handle as transport close" - {stop, {shutdown, transport_closed}, State}; + stop({shutdown, transport_closed}, State); +handle_info({'EXIT', Socket, Reason}, _StateName, #state{socket = Socket} = State) -> + stop({shutdown, Reason}, State); + handle_info(allow_renegotiate, StateName, State) -> {next_state, StateName, State#state{allow_renegotiate = true}}; handle_info({cancel_start_or_recv, StartFrom}, StateName, #state{renegotiation = {false, first}} = State) when StateName =/= connection -> - {stop_and_reply, {shutdown, user_timeout}, - {reply, StartFrom, {error, timeout}}, State#state{timer = undefined}}; + stop_and_reply( + {shutdown, user_timeout}, + {reply, StartFrom, {error, timeout}}, + State#state{timer = undefined}); handle_info({cancel_start_or_recv, RecvFrom}, StateName, #state{start_or_recv_from = RecvFrom} = State) when RecvFrom =/= undefined -> {next_state, StateName, State#state{start_or_recv_from = undefined, @@ -1447,6 +1683,14 @@ certify_client_key_exchange(#client_dhe_psk_identity{} = ClientKey, PremasterSecret = ssl_handshake:premaster_secret(ClientKey, ServerDhPrivateKey, Params, PSKLookup), calculate_master_secret(PremasterSecret, State0, Connection, certify, cipher); +certify_client_key_exchange(#client_ecdhe_psk_identity{} = ClientKey, + #state{diffie_hellman_keys = ServerEcDhPrivateKey, + ssl_options = + #ssl_options{user_lookup_fun = PSKLookup}} = State, + Connection) -> + PremasterSecret = + ssl_handshake:premaster_secret(ClientKey, ServerEcDhPrivateKey, PSKLookup), + calculate_master_secret(PremasterSecret, State, Connection, certify, cipher); certify_client_key_exchange(#client_rsa_psk_identity{} = ClientKey, #state{private_key = Key, ssl_options = @@ -1465,6 +1709,7 @@ certify_server(#state{key_algorithm = Algo} = State, _) when Algo == dh_anon; Algo == ecdh_anon; Algo == psk; Algo == dhe_psk; + Algo == ecdhe_psk; Algo == srp_anon -> State; certify_server(#state{cert_db = CertDbHandle, @@ -1566,6 +1811,27 @@ key_exchange(#state{role = server, key_algorithm = dhe_psk, PrivateKey}), State = Connection:queue_handshake(Msg, State0), State#state{diffie_hellman_keys = DHKeys}; +key_exchange(#state{role = server, key_algorithm = ecdhe_psk, + ssl_options = #ssl_options{psk_identity = PskIdentityHint}, + hashsign_algorithm = HashSignAlgo, + private_key = PrivateKey, + session = #session{ecc = ECCCurve}, + connection_states = ConnectionStates0, + negotiated_version = Version + } = State0, Connection) -> + ECDHKeys = public_key:generate_key(ECCCurve), + #{security_parameters := SecParams} = + ssl_record:pending_connection_state(ConnectionStates0, read), + #security_parameters{client_random = ClientRandom, + server_random = ServerRandom} = SecParams, + Msg = ssl_handshake:key_exchange(server, ssl:tls_version(Version), + {ecdhe_psk, + PskIdentityHint, ECDHKeys, + HashSignAlgo, ClientRandom, + ServerRandom, + PrivateKey}), + State = Connection:queue_handshake(Msg, State0), + State#state{diffie_hellman_keys = ECDHKeys}; key_exchange(#state{role = server, key_algorithm = rsa_psk, ssl_options = #ssl_options{psk_identity = undefined}} = State, _) -> State; @@ -1659,6 +1925,17 @@ key_exchange(#state{role = client, {dhe_psk, SslOpts#ssl_options.psk_identity, DhPubKey}), Connection:queue_handshake(Msg, State0); + +key_exchange(#state{role = client, + ssl_options = SslOpts, + key_algorithm = ecdhe_psk, + negotiated_version = Version, + diffie_hellman_keys = ECDHKeys} = State0, Connection) -> + Msg = ssl_handshake:key_exchange(client, ssl:tls_version(Version), + {ecdhe_psk, + SslOpts#ssl_options.psk_identity, ECDHKeys}), + Connection:queue_handshake(Msg, State0); + key_exchange(#state{role = client, ssl_options = SslOpts, key_algorithm = rsa_psk, @@ -1713,6 +1990,12 @@ rsa_psk_key_exchange(Version, PskIdentity, PremasterSecret, rsa_psk_key_exchange(_, _, _, _) -> throw (?ALERT_REC(?FATAL,?HANDSHAKE_FAILURE, pub_key_is_not_rsa)). +request_client_cert(#state{key_algorithm = Alg} = State, _) + when Alg == dh_anon; Alg == ecdh_anon; + Alg == psk; Alg == dhe_psk; Alg == ecdhe_psk; Alg == rsa_psk; + Alg == srp_dss; Alg == srp_rsa; Alg == srp_anon -> + State; + request_client_cert(#state{ssl_options = #ssl_options{verify = verify_peer, signature_algs = SupportedHashSigns}, connection_states = ConnectionStates0, @@ -1834,6 +2117,18 @@ calculate_secret(#server_dhe_psk_params{ calculate_master_secret(PremasterSecret, State#state{diffie_hellman_keys = Keys}, Connection, certify, certify); +calculate_secret(#server_ecdhe_psk_params{ + dh_params = #server_ecdh_params{curve = ECCurve}} = ServerKey, + #state{ssl_options = #ssl_options{user_lookup_fun = PSKLookup}} = + State=#state{session=Session}, Connection) -> + ECDHKeys = public_key:generate_key(ECCurve), + + PremasterSecret = ssl_handshake:premaster_secret(ServerKey, ECDHKeys, PSKLookup), + calculate_master_secret(PremasterSecret, + State#state{diffie_hellman_keys = ECDHKeys, + session = Session#session{ecc = ECCurve}}, + Connection, certify, certify); + calculate_secret(#server_srp_params{srp_n = Prime, srp_g = Generator} = ServerKey, #state{ssl_options = #ssl_options{srp_identity = SRPId}} = State, Connection) -> @@ -1918,6 +2213,7 @@ is_anonymous(Algo) when Algo == dh_anon; Algo == ecdh_anon; Algo == psk; Algo == dhe_psk; + Algo == ecdhe_psk; Algo == rsa_psk; Algo == srp_anon -> true; @@ -2046,7 +2342,24 @@ hibernate_after(connection = StateName, {next_state, StateName, State, [{timeout, HibernateAfter, hibernate} | Actions]}; hibernate_after(StateName, State, Actions) -> {next_state, StateName, State, Actions}. - + +map_extensions(#hello_extensions{renegotiation_info = RenegotiationInfo, + signature_algs = SigAlg, + alpn = Alpn, + next_protocol_negotiation = Next, + srp = SRP, + ec_point_formats = ECPointFmt, + elliptic_curves = ECCCurves, + sni = SNI}) -> + #{renegotiation_info => ssl_handshake:extension_value(RenegotiationInfo), + signature_algs => ssl_handshake:extension_value(SigAlg), + alpn => ssl_handshake:extension_value(Alpn), + srp => ssl_handshake:extension_value(SRP), + next_protocol => ssl_handshake:extension_value(Next), + ec_point_formats => ssl_handshake:extension_value(ECPointFmt), + elliptic_curves => ssl_handshake:extension_value(ECCCurves), + sni => ssl_handshake:extension_value(SNI)}. + terminate_alert(normal, Version, ConnectionStates, Connection) -> Connection:encode_alert(?ALERT_REC(?WARNING, ?CLOSE_NOTIFY), Version, ConnectionStates); @@ -2217,8 +2530,8 @@ handle_active_option(_, connection = StateName0, To, Reply, #state{protocol_cb = hibernate_after(StateName, State, [{reply, To, Reply}]); {next_state, StateName, State, Actions} -> hibernate_after(StateName, State, [{reply, To, Reply} | Actions]); - {stop, Reason, State} -> - {stop, Reason, State} + {stop, _, _} = Stop -> + Stop end; handle_active_option(_, StateName, To, Reply, #state{user_data_buffer = <<>>} = State) -> %% Active once already set @@ -2227,8 +2540,8 @@ handle_active_option(_, StateName, To, Reply, #state{user_data_buffer = <<>>} = %% user_data_buffer =/= <<>> handle_active_option(_, StateName0, To, Reply, #state{protocol_cb = Connection} = State0) -> case read_application_data(<<>>, State0) of - {stop, Reason, State} -> - {stop, Reason, State}; + {stop, _, _} = Stop -> + Stop; {Record, State1} -> %% Note: Renogotiation may cause StateName0 =/= StateName case Connection:next_event(StateName0, Record, State1) of @@ -2386,7 +2699,8 @@ send_or_reply(_, Pid, _From, Data) -> send_user(Pid, Data). send_user(Pid, Msg) -> - Pid ! Msg. + Pid ! Msg, + ok. alert_user(Transport, Tracker, Socket, connection, Opts, Pid, From, Alert, Role, Connection) -> alert_user(Transport, Tracker, Socket, Opts#socket_options.active, Pid, From, Alert, Role, Connection); @@ -2479,3 +2793,42 @@ new_emulated([], EmOpts) -> EmOpts; new_emulated(NewEmOpts, _) -> NewEmOpts. +%%---------------Erlang distribution -------------------------------------- + +send_dist_data(StateName, State, DHandle, Acc) -> + case erlang:dist_ctrl_get_data(DHandle) of + none -> + erlang:dist_ctrl_get_data_notification(DHandle), + hibernate_after(StateName, State, lists:reverse(Acc)); + Data -> + send_dist_data( + StateName, State, DHandle, + [{next_event, {call, {self(), undefined}}, {application_data, Data}} + |Acc]) + end. + +%% Overload mitigation +eat_msgs(Msg) -> + receive Msg -> eat_msgs(Msg) + after 0 -> ok + end. + +%% When acting as distribution controller map the exit reason +%% to follow the documented nodedown_reason for net_kernel +stop(Reason, State) -> + {stop, erl_dist_stop_reason(Reason, State), State}. + +stop_and_reply(Reason, Replies, State) -> + {stop_and_reply, erl_dist_stop_reason(Reason, State), Replies, State}. + +erl_dist_stop_reason( + Reason, #state{ssl_options = #ssl_options{erl_dist = true}}) -> + case Reason of + normal -> + %% We can not exit with normal since that will not bring + %% down the rest of the distribution processes + {shutdown, normal}; + _ -> Reason + end; +erl_dist_stop_reason(Reason, _State) -> + Reason. diff --git a/lib/ssl/src/ssl_connection.hrl b/lib/ssl/src/ssl_connection.hrl index f9d2149170..d315c393b4 100644 --- a/lib/ssl/src/ssl_connection.hrl +++ b/lib/ssl/src/ssl_connection.hrl @@ -77,7 +77,8 @@ renegotiation :: undefined | {boolean(), From::term() | internal | peer}, start_or_recv_from :: term(), timer :: undefined | reference(), % start_or_recive_timer - %%send_queue :: queue:queue(), + %%send_queue :: queue:queue(), + hello, %%:: #client_hello{} | #server_hello{}, terminated = false ::boolean(), allow_renegotiate = true ::boolean(), expecting_next_protocol_negotiation = false ::boolean(), @@ -88,11 +89,11 @@ sni_hostname = undefined, downgrade, flight_buffer = [] :: list() | map(), %% Buffer of TLS/DTLS records, used during the TLS handshake - %% to when possible pack more than on TLS record into the - %% underlaying packet format. Introduced by DTLS - RFC 4347. - %% The mecahnism is also usefull in TLS although we do not - %% need to worry about packet loss in TLS. In DTLS we need to track DTLS handshake seqnr - flight_state = reliable, %% reliable | {retransmit, integer()}| {waiting, ref(), integer()} - last two is used in DTLS over udp. + %% to when possible pack more than one TLS record into the + %% underlaying packet format. Introduced by DTLS - RFC 4347. + %% The mecahnism is also usefull in TLS although we do not + %% need to worry about packet loss in TLS. In DTLS we need to track DTLS handshake seqnr + flight_state = reliable, %% reliable | {retransmit, integer()}| {waiting, ref(), integer()} - last two is used in DTLS over udp. protocol_specific = #{} :: map() }). -define(DEFAULT_DIFFIE_HELLMAN_PARAMS, diff --git a/lib/ssl/src/ssl_crl_cache.erl b/lib/ssl/src/ssl_crl_cache.erl index 8817b0c884..66f46da75f 100644 --- a/lib/ssl/src/ssl_crl_cache.erl +++ b/lib/ssl/src/ssl_crl_cache.erl @@ -92,8 +92,8 @@ delete({der, CRLs}) -> ssl_manager:delete_crls({?NO_DIST_POINT, CRLs}); delete(URI) -> - case http_uri:parse(URI) of - {ok, {http, _, _ , _, Path,_}} -> + case uri_string:normalize(URI, [return_map]) of + #{scheme := "http", path := Path} -> ssl_manager:delete_crls(string:trim(Path, leading, "/")); _ -> {error, {only_http_distribution_points_supported, URI}} @@ -103,8 +103,8 @@ delete(URI) -> %%% Internal functions %%-------------------------------------------------------------------- do_insert(URI, CRLs) -> - case http_uri:parse(URI) of - {ok, {http, _, _ , _, Path,_}} -> + case uri_string:normalize(URI, [return_map]) of + #{scheme := "http", path := Path} -> ssl_manager:insert_crls(string:trim(Path, leading, "/"), CRLs); _ -> {error, {only_http_distribution_points_supported, URI}} @@ -161,7 +161,7 @@ http_get(URL, Rest, CRLDbInfo, Timeout) -> cache_lookup(_, undefined) -> []; cache_lookup(URL, {{Cache, _}, _}) -> - {ok, {_, _, _ , _, Path,_}} = http_uri:parse(URL), + #{path := Path} = uri_string:normalize(URL, [return_map]), case ssl_pkix_db:lookup(string:trim(Path, leading, "/"), Cache) of undefined -> []; diff --git a/lib/ssl/src/ssl_dist_sup.erl b/lib/ssl/src/ssl_dist_sup.erl index e92f3d3979..bea67935d8 100644 --- a/lib/ssl/src/ssl_dist_sup.erl +++ b/lib/ssl/src/ssl_dist_sup.erl @@ -60,8 +60,7 @@ start_link() -> init([]) -> AdminSup = ssl_admin_child_spec(), ConnectionSup = ssl_connection_sup(), - ProxyServer = proxy_server_child_spec(), - {ok, {{one_for_all, 10, 3600}, [AdminSup, ProxyServer, ConnectionSup]}}. + {ok, {{one_for_all, 10, 3600}, [AdminSup, ConnectionSup]}}. %%-------------------------------------------------------------------- %%% Internal functions @@ -84,15 +83,6 @@ ssl_connection_sup() -> Type = supervisor, {Name, StartFunc, Restart, Shutdown, Type, Modules}. -proxy_server_child_spec() -> - Name = ssl_tls_dist_proxy, - StartFunc = {ssl_tls_dist_proxy, start_link, []}, - Restart = permanent, - Shutdown = 4000, - Modules = [ssl_tls_dist_proxy], - Type = worker, - {Name, StartFunc, Restart, Shutdown, Type, Modules}. - consult(File) -> case erl_prim_loader:get_file(File) of {ok, Binary, _FullName} -> diff --git a/lib/ssl/src/ssl_handshake.erl b/lib/ssl/src/ssl_handshake.erl index 7efb89bfae..54eb920bda 100644 --- a/lib/ssl/src/ssl_handshake.erl +++ b/lib/ssl/src/ssl_handshake.erl @@ -52,8 +52,8 @@ %% Handle handshake messages -export([certify/7, certificate_verify/6, verify_signature/5, master_secret/4, server_key_exchange_hash/2, verify_connection/6, - init_handshake_history/0, update_handshake_history/3, verify_server_key/5, - select_version/3 + init_handshake_history/0, update_handshake_history/2, verify_server_key/5, + select_version/3, extension_value/1 ]). %% Encode @@ -139,8 +139,8 @@ certificate(OwnCert, CertDbHandle, CertDbRef, server) -> case ssl_certificate:certificate_chain(OwnCert, CertDbHandle, CertDbRef) of {ok, _, Chain} -> #certificate{asn1_certificates = Chain}; - {error, _} -> - ?ALERT_REC(?FATAL, ?INTERNAL_ERROR, server_has_no_suitable_certificates) + {error, Error} -> + ?ALERT_REC(?FATAL, ?INTERNAL_ERROR, {server_has_no_suitable_certificates, Error}) end. %%-------------------------------------------------------------------- @@ -189,11 +189,18 @@ certificate_request(CipherSuite, CertDbHandle, CertDbRef, HashSigns, Version) -> {dh, binary()} | {dh, {binary(), binary()}, #'DHParameter'{}, {HashAlgo::atom(), SignAlgo::atom()}, binary(), binary(), public_key:private_key()} | + {ecdh, _, _, _, _, _} | {ecdh, #'ECPrivateKey'{}} | + {psk, _, _, _, _, _} | {psk, binary()} | + {dhe_psk, _, _, _, _, _, _, _} | {dhe_psk, binary(), binary()} | + {ecdhe_psk, _, _, _, _, _, _} | + {ecdhe_psk, binary(), #'ECPrivateKey'{}} | {srp, {binary(), binary()}, #srp_user{}, {HashAlgo::atom(), SignAlgo::atom()}, - binary(), binary(), public_key:private_key()}) -> + binary(), binary(), public_key:private_key()} | + {srp, _} | + {psk_premaster_secret, _, _, _}) -> #client_key_exchange{} | #server_key_exchange{}. %% @@ -229,6 +236,13 @@ key_exchange(client, _Version, {dhe_psk, Identity, PublicKey}) -> dh_public = PublicKey} }; +key_exchange(client, _Version, {ecdhe_psk, Identity, #'ECPrivateKey'{publicKey = ECPublicKey}}) -> + #client_key_exchange{ + exchange_keys = #client_ecdhe_psk_identity{ + identity = Identity, + dh_public = ECPublicKey} + }; + key_exchange(client, _Version, {psk_premaster_secret, PskIdentity, Secret, {_, PublicKey, _}}) -> EncPremasterSecret = encrypted_premaster_secret(Secret, PublicKey), @@ -275,6 +289,16 @@ key_exchange(server, Version, {dhe_psk, PskIdentityHint, {PublicKey, _}, enc_server_key_exchange(Version, ServerEDHPSKParams, HashSign, ClientRandom, ServerRandom, PrivateKey); +key_exchange(server, Version, {ecdhe_psk, PskIdentityHint, + #'ECPrivateKey'{publicKey = ECPublicKey, + parameters = ECCurve}, + HashSign, ClientRandom, ServerRandom, PrivateKey}) -> + ServerECDHEPSKParams = #server_ecdhe_psk_params{ + hint = PskIdentityHint, + dh_params = #server_ecdh_params{curve = ECCurve, public = ECPublicKey}}, + enc_server_key_exchange(Version, ServerECDHEPSKParams, HashSign, + ClientRandom, ServerRandom, PrivateKey); + key_exchange(server, Version, {srp, {PublicKey, _}, #srp_user{generator = Generator, prime = Prime, salt = Salt}, @@ -455,24 +479,12 @@ init_handshake_history() -> {[], []}. %%-------------------------------------------------------------------- --spec update_handshake_history(ssl_handshake:ssl_handshake_history(), Data ::term(), boolean()) -> +-spec update_handshake_history(ssl_handshake:ssl_handshake_history(), Data ::term()) -> ssl_handshake:ssl_handshake_history(). %% %% Description: Update the handshake history buffer with Data. %%-------------------------------------------------------------------- -update_handshake_history(Handshake, % special-case SSL2 client hello - <<?CLIENT_HELLO, ?UINT24(_), ?BYTE(Major), ?BYTE(Minor), - ?UINT16(CSLength), ?UINT16(0), - ?UINT16(CDLength), - CipherSuites:CSLength/binary, - ChallengeData:CDLength/binary>>, true) -> - update_handshake_history(Handshake, - <<?CLIENT_HELLO, ?BYTE(Major), ?BYTE(Minor), - ?UINT16(CSLength), ?UINT16(0), - ?UINT16(CDLength), - CipherSuites:CSLength/binary, - ChallengeData:CDLength/binary>>, true); -update_handshake_history({Handshake0, _Prev}, Data, _) -> +update_handshake_history({Handshake0, _Prev}, Data) -> {[Data|Handshake0], Handshake0}. verify_server_key(#server_key_params{params_bin = EncParams, @@ -732,6 +744,7 @@ decode_server_key(ServerKey, Type, Version) -> | #client_ec_diffie_hellman_public{} | #client_psk_identity{} | #client_dhe_psk_identity{} + | #client_ecdhe_psk_identity{} | #client_rsa_psk_identity{} | #client_srp_public{}. %% @@ -875,9 +888,21 @@ premaster_secret(#server_dhe_psk_params{ LookupFun) -> PremasterSecret = premaster_secret(PublicDhKey, PrivateDhKey, Params), psk_secret(IdentityHint, LookupFun, PremasterSecret); +premaster_secret(#server_ecdhe_psk_params{ + hint = IdentityHint, + dh_params = #server_ecdh_params{ + public = ECServerPubKey}}, + PrivateEcDhKey, + LookupFun) -> + PremasterSecret = premaster_secret(#'ECPoint'{point = ECServerPubKey}, PrivateEcDhKey), + psk_secret(IdentityHint, LookupFun, PremasterSecret); premaster_secret({rsa_psk, PSKIdentity}, PSKLookup, RSAPremasterSecret) -> - psk_secret(PSKIdentity, PSKLookup, RSAPremasterSecret). - + psk_secret(PSKIdentity, PSKLookup, RSAPremasterSecret); +premaster_secret(#client_ecdhe_psk_identity{ + identity = PSKIdentity, + dh_public = PublicEcDhPoint}, PrivateEcDhKey, PSKLookup) -> + PremasterSecret = premaster_secret(#'ECPoint'{point = PublicEcDhPoint}, PrivateEcDhKey), + psk_secret(PSKIdentity, PSKLookup, PremasterSecret). premaster_secret(#client_dhe_psk_identity{ identity = PSKIdentity, dh_public = PublicDhKey}, PrivateKey, #'DHParameter'{} = Params, PSKLookup) -> @@ -1136,12 +1161,30 @@ select_hashsign_algs(undefined, ?rsaEncryption, _) -> select_hashsign_algs(undefined, ?'id-dsa', _) -> {sha, dsa}. - srp_user(#ssl_options{srp_identity = {UserName, _}}) -> #srp{username = UserName}; srp_user(_) -> undefined. +extension_value(undefined) -> + undefined; +extension_value(#sni{hostname = HostName}) -> + HostName; +extension_value(#ec_point_formats{ec_point_format_list = List}) -> + List; +extension_value(#elliptic_curves{elliptic_curve_list = List}) -> + List; +extension_value(#hash_sign_algos{hash_sign_algos = Algos}) -> + Algos; +extension_value(#alpn{extension_data = Data}) -> + Data; +extension_value(#next_protocol_negotiation{extension_data = Data}) -> + Data; +extension_value(#srp{username = Name}) -> + Name; +extension_value(#renegotiation_info{renegotiated_connection = Data}) -> + Data. + %%-------------------------------------------------------------------- %%% Internal functions %%-------------------------------------------------------------------- @@ -1176,7 +1219,6 @@ certificate_types(#{key_exchange := KeyExchange}, _) when KeyExchange == dh_ecds KeyExchange == ecdh_ecdsa; KeyExchange == ecdhe_ecdsa -> <<?BYTE(?ECDSA_SIGN)>>; - certificate_types(_, _) -> <<?BYTE(?RSA_SIGN)>>. @@ -1573,6 +1615,18 @@ encode_server_key(#server_dhe_psk_params{ YLen = byte_size(Y), <<?UINT16(Len), PskIdentityHint/binary, ?UINT16(PLen), P/binary, ?UINT16(GLen), G/binary, ?UINT16(YLen), Y/binary>>; +encode_server_key(Params = #server_ecdhe_psk_params{hint = undefined}) -> + encode_server_key(Params#server_ecdhe_psk_params{hint = <<>>}); +encode_server_key(#server_ecdhe_psk_params{ + hint = PskIdentityHint, + dh_params = #server_ecdh_params{ + curve = {namedCurve, ECCurve}, public = ECPubKey}}) -> + %%TODO: support arbitrary keys + Len = byte_size(PskIdentityHint), + KLen = size(ECPubKey), + <<?UINT16(Len), PskIdentityHint/binary, + ?BYTE(?NAMED_CURVE), ?UINT16((tls_v1:oid_to_enum(ECCurve))), + ?BYTE(KLen), ECPubKey/binary>>; encode_server_key(#server_srp_params{srp_n = N, srp_g = G, srp_s = S, srp_b = B}) -> NLen = byte_size(N), GLen = byte_size(G), @@ -1605,6 +1659,12 @@ encode_client_key(#client_dhe_psk_identity{identity = Id, dh_public = DHPublic}, Len = byte_size(Id), DHLen = byte_size(DHPublic), <<?UINT16(Len), Id/binary, ?UINT16(DHLen), DHPublic/binary>>; +encode_client_key(Identity = #client_ecdhe_psk_identity{identity = undefined}, Version) -> + encode_client_key(Identity#client_ecdhe_psk_identity{identity = <<"psk_identity">>}, Version); +encode_client_key(#client_ecdhe_psk_identity{identity = Id, dh_public = DHPublic}, _) -> + Len = byte_size(Id), + DHLen = byte_size(DHPublic), + <<?UINT16(Len), Id/binary, ?BYTE(DHLen), DHPublic/binary>>; encode_client_key(Identity = #client_rsa_psk_identity{identity = undefined}, Version) -> encode_client_key(Identity#client_rsa_psk_identity{identity = <<"psk_identity">>}, Version); encode_client_key(#client_rsa_psk_identity{identity = Id, exchange_keys = ExchangeKeys}, Version) -> @@ -1725,6 +1785,22 @@ dec_server_key(<<?UINT16(Len), IdentityHint:Len/binary, params_bin = BinMsg, hashsign = HashSign, signature = Signature}; +dec_server_key(<<?UINT16(Len), IdentityHint:Len/binary, + ?BYTE(?NAMED_CURVE), ?UINT16(CurveID), + ?BYTE(PointLen), ECPoint:PointLen/binary, + _/binary>> = KeyStruct, + ?KEY_EXCHANGE_EC_DIFFIE_HELLMAN_PSK, Version) -> + DHParams = #server_ecdh_params{ + curve = {namedCurve, tls_v1:enum_to_oid(CurveID)}, + public = ECPoint}, + Params = #server_ecdhe_psk_params{ + hint = IdentityHint, + dh_params = DHParams}, + {BinMsg, HashSign, Signature} = dec_server_key_params(Len + 2 + PointLen + 4, KeyStruct, Version), + #server_key_params{params = Params, + params_bin = BinMsg, + hashsign = HashSign, + signature = Signature}; dec_server_key(<<?UINT16(NLen), N:NLen/binary, ?UINT16(GLen), G:GLen/binary, ?BYTE(SLen), S:SLen/binary, @@ -1760,6 +1836,10 @@ dec_client_key(<<?UINT16(Len), Id:Len/binary, ?UINT16(DH_YLen), DH_Y:DH_YLen/binary>>, ?KEY_EXCHANGE_DHE_PSK, _) -> #client_dhe_psk_identity{identity = Id, dh_public = DH_Y}; +dec_client_key(<<?UINT16(Len), Id:Len/binary, + ?BYTE(DH_YLen), DH_Y:DH_YLen/binary>>, + ?KEY_EXCHANGE_EC_DIFFIE_HELLMAN_PSK, _) -> + #client_ecdhe_psk_identity{identity = Id, dh_public = DH_Y}; dec_client_key(<<?UINT16(Len), Id:Len/binary, PKEPMS/binary>>, ?KEY_EXCHANGE_RSA_PSK, {3, 0}) -> #client_rsa_psk_identity{identity = Id, @@ -1943,6 +2023,8 @@ key_exchange_alg(psk) -> ?KEY_EXCHANGE_PSK; key_exchange_alg(dhe_psk) -> ?KEY_EXCHANGE_DHE_PSK; +key_exchange_alg(ecdhe_psk) -> + ?KEY_EXCHANGE_EC_DIFFIE_HELLMAN_PSK; key_exchange_alg(rsa_psk) -> ?KEY_EXCHANGE_RSA_PSK; key_exchange_alg(Alg) @@ -2032,7 +2114,8 @@ filter_hashsigns([Suite | Suites], [#{key_exchange := KeyExchange} | Algos], Has KeyExchange == ecdh_anon; KeyExchange == srp_anon; KeyExchange == psk; - KeyExchange == dhe_psk -> + KeyExchange == dhe_psk; + KeyExchange == ecdhe_psk -> %% In this case hashsigns is not used as the kexchange is anonaymous filter_hashsigns(Suites, Algos, HashSigns, [Suite| Acc]). @@ -2171,6 +2254,7 @@ is_acceptable_hash_sign({_, ecdsa} = Algos, ecdsa, ecdsa, ecdhe_ecdsa, Supported is_acceptable_hash_sign(_, _, _, KeyExAlgo, _) when KeyExAlgo == psk; KeyExAlgo == dhe_psk; + KeyExAlgo == ecdhe_psk; KeyExAlgo == srp_anon; KeyExAlgo == dh_anon; KeyExAlgo == ecdhe_anon @@ -2241,6 +2325,8 @@ advertises_ec_ciphers([#{key_exchange := ecdhe_rsa} | _]) -> true; advertises_ec_ciphers([#{key_exchange := ecdh_anon} | _]) -> true; +advertises_ec_ciphers([{ecdhe_psk, _,_,_} | _]) -> + true; advertises_ec_ciphers([_| Rest]) -> advertises_ec_ciphers(Rest). diff --git a/lib/ssl/src/ssl_handshake.hrl b/lib/ssl/src/ssl_handshake.hrl index 324b7dbde3..a191fcf766 100644 --- a/lib/ssl/src/ssl_handshake.hrl +++ b/lib/ssl/src/ssl_handshake.hrl @@ -133,6 +133,7 @@ -define(KEY_EXCHANGE_DIFFIE_HELLMAN, 1). -define(KEY_EXCHANGE_EC_DIFFIE_HELLMAN, 6). -define(KEY_EXCHANGE_PSK, 2). +-define(KEY_EXCHANGE_EC_DIFFIE_HELLMAN_PSK, 7). -define(KEY_EXCHANGE_DHE_PSK, 3). -define(KEY_EXCHANGE_RSA_PSK, 4). -define(KEY_EXCHANGE_SRP, 5). @@ -162,6 +163,11 @@ dh_params }). +-record(server_ecdhe_psk_params, { + hint, + dh_params + }). + -record(server_srp_params, { srp_n, %% opaque srp_N<1..2^16-1> srp_g, %% opaque srp_g<1..2^16-1> @@ -254,6 +260,11 @@ dh_public }). +-record(client_ecdhe_psk_identity, { + identity, + dh_public + }). + -record(client_rsa_psk_identity, { identity, exchange_keys diff --git a/lib/ssl/src/ssl_internal.hrl b/lib/ssl/src/ssl_internal.hrl index 9bb1cbaeb0..5df00de0e5 100644 --- a/lib/ssl/src/ssl_internal.hrl +++ b/lib/ssl/src/ssl_internal.hrl @@ -73,6 +73,7 @@ %% sslv3 is considered insecure due to lack of padding check (Poodle attack) %% Keep as interop with legacy software but do not support as default -define(ALL_AVAILABLE_VERSIONS, ['tlsv1.2', 'tlsv1.1', tlsv1, sslv3]). +-define(ALL_AVAILABLE_DATAGRAM_VERSIONS, ['dtlsv1.2', dtlsv1]). -define(ALL_SUPPORTED_VERSIONS, ['tlsv1.2', 'tlsv1.1', tlsv1]). -define(MIN_SUPPORTED_VERSIONS, ['tlsv1.1', tlsv1]). -define(ALL_DATAGRAM_SUPPORTED_VERSIONS, ['dtlsv1.2', dtlsv1]). @@ -143,8 +144,8 @@ signature_algs, eccs, honor_ecc_order :: boolean(), - v2_hello_compatible :: boolean(), - max_handshake_size :: integer() + max_handshake_size :: integer(), + handshake }). -record(socket_options, diff --git a/lib/ssl/src/ssl_record.erl b/lib/ssl/src/ssl_record.erl index dd6a3e8521..c0eee466ae 100644 --- a/lib/ssl/src/ssl_record.erl +++ b/lib/ssl/src/ssl_record.erl @@ -326,7 +326,7 @@ cipher_aead(Version, Fragment, %%-------------------------------------------------------------------- -spec decipher(ssl_version(), binary(), connection_state(), boolean()) -> - {binary(), binary(), connection_state} | #alert{}. + {binary(), binary(), connection_state()} | #alert{}. %% %% Description: Payload decryption %%-------------------------------------------------------------------- diff --git a/lib/ssl/src/ssl_tls_dist_proxy.erl b/lib/ssl/src/ssl_tls_dist_proxy.erl deleted file mode 100644 index 12a057fd22..0000000000 --- a/lib/ssl/src/ssl_tls_dist_proxy.erl +++ /dev/null @@ -1,493 +0,0 @@ -%% -%% %CopyrightBegin% -%% -%% Copyright Ericsson AB 2011-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(ssl_tls_dist_proxy). - - --export([listen/2, accept/2, connect/4, get_tcp_address/1]). --export([init/1, start_link/0, handle_call/3, handle_cast/2, handle_info/2, - terminate/2, code_change/3, ssl_options/2]). - --include_lib("kernel/include/net_address.hrl"). - --record(state, - {listen, - accept_loop - }). - --define(PPRE, 4). --define(PPOST, 4). - - -%%==================================================================== -%% Internal application API -%%==================================================================== - -listen(Driver, Name) -> - gen_server:call(?MODULE, {listen, Driver, Name}, infinity). - -accept(Driver, Listen) -> - gen_server:call(?MODULE, {accept, Driver, Listen}, infinity). - -connect(Driver, Ip, Port, ExtraOpts) -> - gen_server:call( - ?MODULE, {connect, Driver, Ip, Port, ExtraOpts}, infinity). - - -do_listen(Options) -> - {First,Last} = case application:get_env(kernel,inet_dist_listen_min) of - {ok,N} when is_integer(N) -> - case application:get_env(kernel, - inet_dist_listen_max) of - {ok,M} when is_integer(M) -> - {N,M}; - _ -> - {N,N} - end; - _ -> - {0,0} - end, - do_listen(First, Last, listen_options([{backlog,128}|Options])). - -do_listen(First,Last,_) when First > Last -> - {error,eaddrinuse}; -do_listen(First,Last,Options) -> - case gen_tcp:listen(First, Options) of - {error, eaddrinuse} -> - do_listen(First+1,Last,Options); - Other -> - Other - end. - -listen_options(Opts0) -> - Opts1 = - case application:get_env(kernel, inet_dist_use_interface) of - {ok, Ip} -> - [{ip, Ip} | Opts0]; - _ -> - Opts0 - end, - case application:get_env(kernel, inet_dist_listen_options) of - {ok,ListenOpts} -> - ListenOpts ++ Opts1; - _ -> - Opts1 - end. - -connect_options(Opts) -> - case application:get_env(kernel, inet_dist_connect_options) of - {ok,ConnectOpts} -> - lists:ukeysort(1, ConnectOpts ++ Opts); - _ -> - Opts - end. - -%%==================================================================== -%% gen_server callbacks -%%==================================================================== - -start_link() -> - gen_server:start_link({local, ?MODULE}, ?MODULE, [], []). - -init([]) -> - process_flag(priority, max), - {ok, #state{}}. - -handle_call({listen, Driver, Name}, _From, State) -> - case gen_tcp:listen(0, [{active, false}, {packet,?PPRE}, {ip, loopback}]) of - {ok, Socket} -> - {ok, World} = do_listen([{active, false}, binary, {packet,?PPRE}, {reuseaddr, true}, - Driver:family()]), - {ok, TcpAddress} = get_tcp_address(Socket), - {ok, WorldTcpAddress} = get_tcp_address(World), - {_,Port} = WorldTcpAddress#net_address.address, - ErlEpmd = net_kernel:epmd_module(), - case ErlEpmd:register_node(Name, Port, Driver) of - {ok, Creation} -> - {reply, {ok, {Socket, TcpAddress, Creation}}, - State#state{listen={Socket, World}}}; - {error, _} = Error -> - {reply, Error, State} - end; - Error -> - {reply, Error, State} - end; - -handle_call({accept, _Driver, Listen}, {From, _}, State = #state{listen={_, World}}) -> - Self = self(), - ErtsPid = spawn_link(fun() -> accept_loop(Self, erts, Listen, From) end), - WorldPid = spawn_link(fun() -> accept_loop(Self, world, World, Listen) end), - {reply, ErtsPid, State#state{accept_loop={ErtsPid, WorldPid}}}; - -handle_call({connect, Driver, Ip, Port, ExtraOpts}, {From, _}, State) -> - Me = self(), - Pid = - spawn_link( - fun() -> setup_proxy(Driver, Ip, Port, ExtraOpts, Me) end), - receive - {Pid, go_ahead, LPort} -> - Res = {ok, Socket} = try_connect(LPort), - case gen_tcp:controlling_process(Socket, From) of - {error, badarg} = Error -> {reply, Error, State}; % From is dead anyway. - ok -> - flush_old_controller(From, Socket), - {reply, Res, State} - end; - {Pid, Error} -> - {reply, Error, State} - end; - -handle_call(_What, _From, State) -> - {reply, ok, State}. - -handle_cast(_What, State) -> - {noreply, State}. - -handle_info(_What, State) -> - {noreply, State}. - -terminate(_Reason, _St) -> - ok. - -code_change(_OldVsn, St, _Extra) -> - {ok, St}. - -%%-------------------------------------------------------------------- -%%% Internal functions -%%-------------------------------------------------------------------- -get_tcp_address(Socket) -> - case inet:sockname(Socket) of - {ok, Address} -> - {ok, Host} = inet:gethostname(), - NetAddress = #net_address{ - address = Address, - host = Host, - protocol = proxy, - family = inet - }, - {ok, NetAddress}; - {error, _} = Error -> Error - end. - -accept_loop(Proxy, erts = Type, Listen, Extra) -> - process_flag(priority, max), - case gen_tcp:accept(Listen) of - {ok, Socket} -> - Extra ! {accept,self(),Socket,inet,proxy}, - receive - {_Kernel, controller, Pid} -> - inet:setopts(Socket, [nodelay()]), - ok = gen_tcp:controlling_process(Socket, Pid), - flush_old_controller(Pid, Socket), - Pid ! {self(), controller}; - {_Kernel, unsupported_protocol} -> - exit(unsupported_protocol) - end; - {error, closed} -> - %% The listening socket is closed: the proxy process is - %% shutting down. Exit normally, to avoid generating a - %% spurious error report. - exit(normal); - Error -> - exit(Error) - end, - accept_loop(Proxy, Type, Listen, Extra); - -accept_loop(Proxy, world = Type, Listen, Extra) -> - process_flag(priority, max), - case gen_tcp:accept(Listen) of - {ok, Socket} -> - Opts = get_ssl_options(server), - wait_for_code_server(), - case ssl:ssl_accept(Socket, Opts) of - {ok, SslSocket} -> - PairHandler = - spawn_link(fun() -> - setup_connection(SslSocket, Extra) - end), - ok = ssl:controlling_process(SslSocket, PairHandler), - flush_old_controller(PairHandler, SslSocket); - {error, {options, _}} = Error -> - %% Bad options: that's probably our fault. Let's log that. - error_logger:error_msg("Cannot accept TLS distribution connection: ~s~n", - [ssl:format_error(Error)]), - gen_tcp:close(Socket); - _ -> - gen_tcp:close(Socket) - end; - Error -> - exit(Error) - end, - accept_loop(Proxy, Type, Listen, Extra). - -wait_for_code_server() -> - %% This is an ugly hack. Upgrading a socket to TLS requires the - %% crypto module to be loaded. Loading the crypto module triggers - %% its on_load function, which calls code:priv_dir/1 to find the - %% directory where its NIF library is. However, distribution is - %% started earlier than the code server, so the code server is not - %% necessarily started yet, and code:priv_dir/1 might fail because - %% of that, if we receive an incoming connection on the - %% distribution port early enough. - %% - %% If the on_load function of a module fails, the module is - %% unloaded, and the function call that triggered loading it fails - %% with 'undef', which is rather confusing. - %% - %% Thus, the ssl_tls_dist_proxy process will terminate, and be - %% restarted by ssl_dist_sup. However, it won't have any memory - %% of being asked by net_kernel to listen for incoming - %% connections. Hence, the node will believe that it's open for - %% distribution, but it actually isn't. - %% - %% So let's avoid that by waiting for the code server to start. - case whereis(code_server) of - undefined -> - timer:sleep(10), - wait_for_code_server(); - Pid when is_pid(Pid) -> - ok - end. - -try_connect(Port) -> - case gen_tcp:connect({127,0,0,1}, Port, [{active, false}, {packet,?PPRE}, nodelay()]) of - R = {ok, _S} -> - R; - {error, _R} -> - try_connect(Port) - end. - -setup_proxy(Driver, Ip, Port, ExtraOpts, Parent) -> - process_flag(trap_exit, true), - Opts = connect_options(ExtraOpts ++ get_ssl_options(client)), - case ssl:connect(Ip, Port, [{active, true}, binary, {packet,?PPRE}, nodelay(), - Driver:family()] ++ Opts) of - {ok, World} -> - {ok, ErtsL} = gen_tcp:listen(0, [{active, true}, {ip, loopback}, binary, {packet,?PPRE}]), - {ok, #net_address{address={_,LPort}}} = get_tcp_address(ErtsL), - Parent ! {self(), go_ahead, LPort}, - case gen_tcp:accept(ErtsL) of - {ok, Erts} -> - %% gen_tcp:close(ErtsL), - loop_conn_setup(World, Erts); - Err -> - Parent ! {self(), Err} - end; - {error, {options, _}} = Err -> - %% Bad options: that's probably our fault. Let's log that. - error_logger:error_msg("Cannot open TLS distribution connection: ~s~n", - [ssl:format_error(Err)]), - Parent ! {self(), Err}; - Err -> - Parent ! {self(), Err} - end. - - -%% we may not always want the nodelay behaviour -%% %% for performance reasons - -nodelay() -> - case application:get_env(kernel, dist_nodelay) of - undefined -> - {nodelay, true}; - {ok, true} -> - {nodelay, true}; - {ok, false} -> - {nodelay, false}; - _ -> - {nodelay, true} - end. - -setup_connection(World, ErtsListen) -> - process_flag(trap_exit, true), - {ok, TcpAddress} = get_tcp_address(ErtsListen), - {_Addr,Port} = TcpAddress#net_address.address, - {ok, Erts} = gen_tcp:connect({127,0,0,1}, Port, [{active, true}, binary, {packet,?PPRE}, nodelay()]), - ssl:setopts(World, [{active,true}, {packet,?PPRE}, nodelay()]), - loop_conn_setup(World, Erts). - -loop_conn_setup(World, Erts) -> - receive - {ssl, World, Data = <<$a, _/binary>>} -> - gen_tcp:send(Erts, Data), - ssl:setopts(World, [{packet,?PPOST}, nodelay()]), - inet:setopts(Erts, [{packet,?PPOST}, nodelay()]), - loop_conn(World, Erts); - {tcp, Erts, Data = <<$a, _/binary>>} -> - ssl:send(World, Data), - ssl:setopts(World, [{packet,?PPOST}, nodelay()]), - inet:setopts(Erts, [{packet,?PPOST}, nodelay()]), - loop_conn(World, Erts); - {ssl, World, Data = <<_, _/binary>>} -> - gen_tcp:send(Erts, Data), - loop_conn_setup(World, Erts); - {tcp, Erts, Data = <<_, _/binary>>} -> - ssl:send(World, Data), - loop_conn_setup(World, Erts); - {ssl, World, Data} -> - gen_tcp:send(Erts, Data), - loop_conn_setup(World, Erts); - {tcp, Erts, Data} -> - ssl:send(World, Data), - loop_conn_setup(World, Erts); - {tcp_closed, Erts} -> - ssl:close(World); - {ssl_closed, World} -> - gen_tcp:close(Erts); - {ssl_error, World, _} -> - - ssl:close(World) - end. - -loop_conn(World, Erts) -> - receive - {ssl, World, Data} -> - gen_tcp:send(Erts, Data), - loop_conn(World, Erts); - {tcp, Erts, Data} -> - ssl:send(World, Data), - loop_conn(World, Erts); - {tcp_closed, Erts} -> - ssl:close(World); - {ssl_closed, World} -> - gen_tcp:close(Erts); - {ssl_error, World, _} -> - ssl:close(World) - end. - -get_ssl_options(Type) -> - try ets:lookup(ssl_dist_opts, Type) of - [{Type, Opts}] -> - [{erl_dist, true} | Opts]; - _ -> - get_ssl_dist_arguments(Type) - catch - error:badarg -> - get_ssl_dist_arguments(Type) - end. - -get_ssl_dist_arguments(Type) -> - case init:get_argument(ssl_dist_opt) of - {ok, Args} -> - [{erl_dist, true} | ssl_options(Type, lists:append(Args))]; - _ -> - [{erl_dist, true}] - end. - -ssl_options(_,[]) -> - []; -ssl_options(server, ["client_" ++ _, _Value |T]) -> - ssl_options(server,T); -ssl_options(client, ["server_" ++ _, _Value|T]) -> - ssl_options(client,T); -ssl_options(server, ["server_certfile", Value|T]) -> - [{certfile, Value} | ssl_options(server,T)]; -ssl_options(client, ["client_certfile", Value | T]) -> - [{certfile, Value} | ssl_options(client,T)]; -ssl_options(server, ["server_cacertfile", Value|T]) -> - [{cacertfile, Value} | ssl_options(server,T)]; -ssl_options(client, ["client_cacertfile", Value|T]) -> - [{cacertfile, Value} | ssl_options(client,T)]; -ssl_options(server, ["server_keyfile", Value|T]) -> - [{keyfile, Value} | ssl_options(server,T)]; -ssl_options(client, ["client_keyfile", Value|T]) -> - [{keyfile, Value} | ssl_options(client,T)]; -ssl_options(server, ["server_password", Value|T]) -> - [{password, Value} | ssl_options(server,T)]; -ssl_options(client, ["client_password", Value|T]) -> - [{password, Value} | ssl_options(client,T)]; -ssl_options(server, ["server_verify", Value|T]) -> - [{verify, atomize(Value)} | ssl_options(server,T)]; -ssl_options(client, ["client_verify", Value|T]) -> - [{verify, atomize(Value)} | ssl_options(client,T)]; -ssl_options(server, ["server_verify_fun", Value|T]) -> - [{verify_fun, verify_fun(Value)} | ssl_options(server,T)]; -ssl_options(client, ["client_verify_fun", Value|T]) -> - [{verify_fun, verify_fun(Value)} | ssl_options(client,T)]; -ssl_options(server, ["server_crl_check", Value|T]) -> - [{crl_check, atomize(Value)} | ssl_options(server,T)]; -ssl_options(client, ["client_crl_check", Value|T]) -> - [{crl_check, atomize(Value)} | ssl_options(client,T)]; -ssl_options(server, ["server_crl_cache", Value|T]) -> - [{crl_cache, termify(Value)} | ssl_options(server,T)]; -ssl_options(client, ["client_crl_cache", Value|T]) -> - [{crl_cache, termify(Value)} | ssl_options(client,T)]; -ssl_options(server, ["server_reuse_sessions", Value|T]) -> - [{reuse_sessions, atomize(Value)} | ssl_options(server,T)]; -ssl_options(client, ["client_reuse_sessions", Value|T]) -> - [{reuse_sessions, atomize(Value)} | ssl_options(client,T)]; -ssl_options(server, ["server_secure_renegotiate", Value|T]) -> - [{secure_renegotiate, atomize(Value)} | ssl_options(server,T)]; -ssl_options(client, ["client_secure_renegotiate", Value|T]) -> - [{secure_renegotiate, atomize(Value)} | ssl_options(client,T)]; -ssl_options(server, ["server_depth", Value|T]) -> - [{depth, list_to_integer(Value)} | ssl_options(server,T)]; -ssl_options(client, ["client_depth", Value|T]) -> - [{depth, list_to_integer(Value)} | ssl_options(client,T)]; -ssl_options(server, ["server_hibernate_after", Value|T]) -> - [{hibernate_after, list_to_integer(Value)} | ssl_options(server,T)]; -ssl_options(client, ["client_hibernate_after", Value|T]) -> - [{hibernate_after, list_to_integer(Value)} | ssl_options(client,T)]; -ssl_options(server, ["server_ciphers", Value|T]) -> - [{ciphers, Value} | ssl_options(server,T)]; -ssl_options(client, ["client_ciphers", Value|T]) -> - [{ciphers, Value} | ssl_options(client,T)]; -ssl_options(server, ["server_dhfile", Value|T]) -> - [{dhfile, Value} | ssl_options(server,T)]; -ssl_options(server, ["server_fail_if_no_peer_cert", Value|T]) -> - [{fail_if_no_peer_cert, atomize(Value)} | ssl_options(server,T)]; -ssl_options(Type, Opts) -> - error(malformed_ssl_dist_opt, [Type, Opts]). - -atomize(List) when is_list(List) -> - list_to_atom(List); -atomize(Atom) when is_atom(Atom) -> - Atom. - -termify(String) when is_list(String) -> - {ok, Tokens, _} = erl_scan:string(String ++ "."), - {ok, Term} = erl_parse:parse_term(Tokens), - Term. - -verify_fun(Value) -> - case termify(Value) of - {Mod, Func, State} when is_atom(Mod), is_atom(Func) -> - Fun = fun Mod:Func/3, - {Fun, State}; - _ -> - error(malformed_ssl_dist_opt, [Value]) - end. - -flush_old_controller(Pid, Socket) -> - receive - {tcp, Socket, Data} -> - Pid ! {tcp, Socket, Data}, - flush_old_controller(Pid, Socket); - {tcp_closed, Socket} -> - Pid ! {tcp_closed, Socket}, - flush_old_controller(Pid, Socket); - {ssl, Socket, Data} -> - Pid ! {ssl, Socket, Data}, - flush_old_controller(Pid, Socket); - {ssl_closed, Socket} -> - Pid ! {ssl_closed, Socket}, - flush_old_controller(Pid, Socket) - after 0 -> - ok - end. diff --git a/lib/ssl/src/ssl_v2.erl b/lib/ssl/src/ssl_v2.erl deleted file mode 100644 index 37134cbe5d..0000000000 --- a/lib/ssl/src/ssl_v2.erl +++ /dev/null @@ -1,38 +0,0 @@ -%% -%% %CopyrightBegin% -%% -%% Copyright Ericsson AB 2007-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: Handles sslv2 hello as clients supporting sslv2 and higher -%% will send an sslv2 hello. -%%---------------------------------------------------------------------- - --module(ssl_v2). - --export([client_random/2]). - -client_random(ChallengeData, 32) -> - ChallengeData; -client_random(ChallengeData, N) when N > 32 -> - <<NewChallengeData:32/binary, _/binary>> = ChallengeData, - NewChallengeData; -client_random(ChallengeData, N) -> - Pad = list_to_binary(lists:duplicate(N, 0)), - <<Pad/binary, ChallengeData/binary>>. diff --git a/lib/ssl/src/tls_connection.erl b/lib/ssl/src/tls_connection.erl index 914ee9f22f..ef84c5320e 100644 --- a/lib/ssl/src/tls_connection.erl +++ b/lib/ssl/src/tls_connection.erl @@ -62,8 +62,8 @@ %% gen_statem state functions -export([init/3, error/3, downgrade/3, %% Initiation and take down states - hello/3, certify/3, cipher/3, abbreviated/3, %% Handshake states - connection/3]). + hello/3, user_hello/3, certify/3, cipher/3, abbreviated/3, %% Handshake states + connection/3, death_row/3]). %% gen_statem callbacks -export([callback_mode/0, terminate/3, code_change/4, format_status/2]). @@ -80,8 +80,7 @@ start_fsm(Role, Host, Port, Socket, {#ssl_options{erl_dist = false},_, Tracker} {ok, Pid} = tls_connection_sup:start_child([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} + ssl_connection:handshake(SslSocket, Timeout) catch error:{badmatch, {error, _} = Error} -> Error @@ -94,8 +93,7 @@ start_fsm(Role, Host, Port, Socket, {#ssl_options{erl_dist = true},_, Tracker} = {ok, Pid} = tls_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} + ssl_connection:handshake(SslSocket, Timeout) catch error:{badmatch, {error, _} = Error} -> Error @@ -266,10 +264,9 @@ send_handshake(Handshake, State) -> queue_handshake(Handshake, #state{negotiated_version = Version, tls_handshake_history = Hist0, flight_buffer = Flight0, - ssl_options = #ssl_options{v2_hello_compatible = V2HComp}, connection_states = ConnectionStates0} = State0) -> {BinHandshake, ConnectionStates, Hist} = - encode_handshake(Handshake, Version, ConnectionStates0, Hist0, V2HComp), + encode_handshake(Handshake, Version, ConnectionStates0, Hist0), State0#state{connection_states = ConnectionStates, tls_handshake_history = Hist, flight_buffer = Flight0 ++ [BinHandshake]}. @@ -400,7 +397,7 @@ getopts(Transport, Socket, Tag) -> init({call, From}, {start, Timeout}, #state{host = Host, port = Port, role = client, - ssl_options = #ssl_options{v2_hello_compatible = V2HComp} = SslOpts, + ssl_options = SslOpts, session = #session{own_certificate = Cert} = Session0, transport_cb = Transport, socket = Socket, connection_states = ConnectionStates0, @@ -416,7 +413,7 @@ init({call, From}, {start, Timeout}, HelloVersion = tls_record:hello_version(Version, SslOpts#ssl_options.versions), Handshake0 = ssl_handshake:init_handshake_history(), {BinMsg, ConnectionStates, Handshake} = - encode_handshake(Hello, HelloVersion, ConnectionStates0, Handshake0, V2HComp), + encode_handshake(Hello, HelloVersion, ConnectionStates0, Handshake0), send(Transport, Socket, BinMsg), State1 = State0#state{connection_states = ConnectionStates, negotiated_version = Version, %% Requested version @@ -437,11 +434,15 @@ init(Type, Event, State) -> %%-------------------------------------------------------------------- error({call, From}, {start, _Timeout}, {Error, State}) -> - {stop_and_reply, normal, {reply, From, {error, Error}}, State}; -error({call, From}, {start, _Timeout}, #state{protocol_specific = #{error := Error}} = State) -> - {stop_and_reply, normal, {reply, From, {error, Error}}, State}; + ssl_connection:stop_and_reply( + normal, {reply, From, {error, Error}}, State); +error({call, From}, {start, _Timeout}, + #state{protocol_specific = #{error := Error}} = State) -> + ssl_connection:stop_and_reply( + normal, {reply, From, {error, Error}}, State); error({call, _} = Call, Msg, {Error, #state{protocol_specific = Map} = State}) -> - gen_handshake(?FUNCTION_NAME, Call, Msg, State#state{protocol_specific = Map#{error => Error}}); + gen_handshake(?FUNCTION_NAME, Call, Msg, + State#state{protocol_specific = Map#{error => Error}}); error(_, _, _) -> {keep_state_and_data, [postpone]}. @@ -451,6 +452,16 @@ error(_, _, _) -> #state{}) -> gen_statem:state_function_result(). %%-------------------------------------------------------------------- +hello(internal, #client_hello{extensions = Extensions} = Hello, #state{ssl_options = #ssl_options{handshake = hello}, + start_or_recv_from = From} = State) -> + {next_state, user_hello, State#state{start_or_recv_from = undefined, + hello = Hello}, + [{reply, From, {ok, ssl_connection:map_extensions(Extensions)}}]}; +hello(internal, #server_hello{extensions = Extensions} = Hello, #state{ssl_options = #ssl_options{handshake = hello}, + start_or_recv_from = From} = State) -> + {next_state, user_hello, State#state{start_or_recv_from = undefined, + hello = Hello}, + [{reply, From, {ok, ssl_connection:map_extensions(Extensions)}}]}; hello(internal, #client_hello{client_version = ClientVersion} = Hello, #state{connection_states = ConnectionStates0, port = Port, session = #session{own_certificate = Cert} = Session0, @@ -460,7 +471,6 @@ hello(internal, #client_hello{client_version = ClientVersion} = Hello, negotiated_protocol = CurrentProtocol, key_algorithm = KeyExAlg, ssl_options = SslOpts} = State) -> - case tls_handshake:hello(Hello, SslOpts, {Port, Session0, Cache, CacheCb, ConnectionStates0, Cert, KeyExAlg}, Renegotiation) of #alert{} = Alert -> @@ -479,7 +489,7 @@ hello(internal, #client_hello{client_version = ClientVersion} = Hello, session = Session, negotiated_protocol = Protocol}) end; -hello(internal, #server_hello{} = Hello, +hello(internal, #server_hello{} = Hello, #state{connection_states = ConnectionStates0, negotiated_version = ReqVersion, role = client, @@ -497,6 +507,9 @@ hello(info, Event, State) -> hello(Type, Event, State) -> gen_handshake(?FUNCTION_NAME, Type, Event, State). +user_hello(Type, Event, State) -> + gen_handshake(?FUNCTION_NAME, Type, Event, State). + %%-------------------------------------------------------------------- -spec abbreviated(gen_statem:event_type(), term(), #state{}) -> gen_statem:state_function_result(). @@ -567,6 +580,13 @@ connection(Type, Event, State) -> ssl_connection:?FUNCTION_NAME(Type, Event, State, ?MODULE). %%-------------------------------------------------------------------- +-spec death_row(gen_statem:event_type(), term(), #state{}) -> + gen_statem:state_function_result(). +%%-------------------------------------------------------------------- +death_row(Type, Event, State) -> + ssl_connection:death_row(Type, Event, State, ?MODULE). + +%%-------------------------------------------------------------------- -spec downgrade(gen_statem:event_type(), term(), #state{}) -> gen_statem:state_function_result(). %%-------------------------------------------------------------------- @@ -645,15 +665,11 @@ next_tls_record(Data, StateName, #state{protocol_buffers = handle_record_alert(Alert, State0) end. -acceptable_record_versions(hello, #state{ssl_options = #ssl_options{v2_hello_compatible = true}}) -> - [tls_record:protocol_version(Vsn) || Vsn <- ?ALL_AVAILABLE_VERSIONS ++ ['sslv2']]; + acceptable_record_versions(hello, _) -> [tls_record:protocol_version(Vsn) || Vsn <- ?ALL_AVAILABLE_VERSIONS]; acceptable_record_versions(_, #state{negotiated_version = Version}) -> [Version]. -handle_record_alert(#alert{description = ?BAD_RECORD_MAC}, - #state{ssl_options = #ssl_options{v2_hello_compatible = true}}) -> - ?ALERT_REC(?FATAL, ?PROTOCOL_VERSION); handle_record_alert(Alert, _) -> Alert. @@ -670,7 +686,7 @@ handle_info({Protocol, _, Data}, StateName, next_event(StateName, Record, State); #alert{} = Alert -> ssl_connection:handle_normal_shutdown(Alert, StateName, State0), - {stop, {shutdown, own_alert}} + ssl_connection:stop({shutdown, own_alert}, State0) end; handle_info({CloseTag, Socket}, StateName, #state{socket = Socket, close_tag = CloseTag, @@ -697,7 +713,7 @@ handle_info({CloseTag, Socket}, StateName, end, ssl_connection:handle_normal_shutdown(?ALERT_REC(?FATAL, ?CLOSE_NOTIFY), StateName, State), - {stop, {shutdown, transport_closed}}; + ssl_connection:stop({shutdown, transport_closed}, State); true -> %% Fixes non-delivery of final TLS record in {active, once}. %% Basically allows the application the opportunity to set {active, once} again @@ -709,16 +725,16 @@ handle_info(Msg, StateName, State) -> handle_alerts([], Result) -> Result; -handle_alerts(_, {stop,_} = Stop) -> +handle_alerts(_, {stop, _, _} = Stop) -> Stop; handle_alerts([Alert | Alerts], {next_state, StateName, State}) -> handle_alerts(Alerts, ssl_connection:handle_alert(Alert, StateName, State)); handle_alerts([Alert | Alerts], {next_state, StateName, State, _Actions}) -> handle_alerts(Alerts, ssl_connection:handle_alert(Alert, StateName, State)). -encode_handshake(Handshake, Version, ConnectionStates0, Hist0, V2HComp) -> +encode_handshake(Handshake, Version, ConnectionStates0, Hist0) -> Frag = tls_handshake:encode_handshake(Handshake, Version), - Hist = ssl_handshake:update_handshake_history(Hist0, Frag, V2HComp), + Hist = ssl_handshake:update_handshake_history(Hist0, Frag), {Encoded, ConnectionStates} = tls_record:encode_handshake(Frag, Version, ConnectionStates0), {Encoded, ConnectionStates, Hist}. @@ -740,7 +756,7 @@ gen_handshake(StateName, Type, Event, malformed_handshake_data), Version, StateName, State) end. - + gen_info(Event, connection = StateName, #state{negotiated_version = Version} = State) -> try handle_info(Event, StateName, State) of Result -> diff --git a/lib/ssl/src/tls_handshake.erl b/lib/ssl/src/tls_handshake.erl index 8817418fb0..0058b9c8ae 100644 --- a/lib/ssl/src/tls_handshake.erl +++ b/lib/ssl/src/tls_handshake.erl @@ -39,7 +39,7 @@ -export([encode_handshake/2]). %% Handshake decodeing --export([get_tls_handshake/4, decode_handshake/4]). +-export([get_tls_handshake/4, decode_handshake/3]). -type tls_handshake() :: #client_hello{} | ssl_handshake:ssl_handshake(). @@ -268,9 +268,9 @@ enc_handshake(HandshakeMsg, Version) -> %%-------------------------------------------------------------------- get_tls_handshake_aux(Version, <<?BYTE(Type), ?UINT24(Length), Body:Length/binary,Rest/binary>>, - #ssl_options{v2_hello_compatible = V2Hello} = Opts, Acc) -> + Opts, Acc) -> Raw = <<?BYTE(Type), ?UINT24(Length), Body/binary>>, - try decode_handshake(Version, Type, Body, V2Hello) of + try decode_handshake(Version, Type, Body) of Handshake -> get_tls_handshake_aux(Version, Rest, Opts, [{Handshake,Raw} | Acc]) catch @@ -280,29 +280,15 @@ get_tls_handshake_aux(Version, <<?BYTE(Type), ?UINT24(Length), get_tls_handshake_aux(_Version, Data, _, Acc) -> {lists:reverse(Acc), Data}. -decode_handshake(_, ?HELLO_REQUEST, <<>>, _) -> +decode_handshake(_, ?HELLO_REQUEST, <<>>) -> #hello_request{}; - -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, ?BYTE(Cm_length), Comp_methods:Cm_length/binary, - Extensions/binary>>, _) -> - + Extensions/binary>>) -> DecodedExtensions = ssl_handshake:decode_hello_extensions({client, Extensions}), - #client_hello{ client_version = {Major,Minor}, random = Random, @@ -311,36 +297,7 @@ decode_handshake(_Version, ?CLIENT_HELLO, compression_methods = Comp_methods, extensions = DecodedExtensions }; -decode_handshake(Version, Tag, Msg, _) -> +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{} - }. diff --git a/lib/ssl/src/tls_record.erl b/lib/ssl/src/tls_record.erl index 188ec6809d..aa70508f1e 100644 --- a/lib/ssl/src/tls_record.erl +++ b/lib/ssl/src/tls_record.erl @@ -394,16 +394,6 @@ initial_connection_state(ConnectionEnd, BeastMitigation) -> server_verify_data => undefined }. -assert_version(<<1:1, Length0:15, Data0:Length0/binary, _/binary>>, Versions) -> - case Data0 of - <<?BYTE(?CLIENT_HELLO), ?BYTE(Major), ?BYTE(Minor), _/binary>> -> - %% First check v2_hello_compatible mode is active - lists:member({2,0}, Versions) andalso - %% andalso we want to negotiate higher version - lists:member({Major, Minor}, Versions -- [{2,0}]); - _ -> - false - end; assert_version(<<?BYTE(_), ?BYTE(MajVer), ?BYTE(MinVer), _/binary>>, Versions) -> is_acceptable_version({MajVer, MinVer}, Versions). @@ -431,32 +421,10 @@ get_tls_records_aux(<<?BYTE(?CHANGE_CIPHER_SPEC),?BYTE(MajVer),?BYTE(MinVer), get_tls_records_aux(Rest, [#ssl_tls{type = ?CHANGE_CIPHER_SPEC, version = {MajVer, MinVer}, fragment = Data} | Acc]); -%% Matches an ssl v2 client hello message. -%% 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. -get_tls_records_aux(<<1:1, Length0:15, Data0:Length0/binary, Rest/binary>>, - Acc) -> - case Data0 of - <<?BYTE(?CLIENT_HELLO), ?BYTE(MajVer), ?BYTE(MinVer), _/binary>> -> - Length = Length0-1, - <<?BYTE(_), Data1:Length/binary>> = Data0, - Data = <<?BYTE(?CLIENT_HELLO), ?UINT24(Length), Data1/binary>>, - get_tls_records_aux(Rest, [#ssl_tls{type = ?HANDSHAKE, - version = {MajVer, MinVer}, - fragment = Data} | Acc]); - _ -> - ?ALERT_REC(?FATAL, ?HANDSHAKE_FAILURE) - - end; - get_tls_records_aux(<<0:1, _CT:7, ?BYTE(_MajVer), ?BYTE(_MinVer), ?UINT16(Length), _/binary>>, _Acc) when Length > ?MAX_CIPHER_TEXT_LENGTH -> ?ALERT_REC(?FATAL, ?RECORD_OVERFLOW); -get_tls_records_aux(<<1:1, Length0:15, _/binary>>,_Acc) - when Length0 > ?MAX_CIPHER_TEXT_LENGTH -> - ?ALERT_REC(?FATAL, ?RECORD_OVERFLOW); - get_tls_records_aux(Data, Acc) -> case size(Data) =< ?MAX_CIPHER_TEXT_LENGTH + ?INITIAL_BYTES of true -> diff --git a/lib/ssl/src/tls_v1.erl b/lib/ssl/src/tls_v1.erl index a8fe119bf8..a31ab8d044 100644 --- a/lib/ssl/src/tls_v1.erl +++ b/lib/ssl/src/tls_v1.erl @@ -202,23 +202,13 @@ suites(Minor) when Minor == 1; Minor == 2 -> ?TLS_DHE_DSS_WITH_AES_256_CBC_SHA, ?TLS_ECDH_ECDSA_WITH_AES_256_CBC_SHA, ?TLS_ECDH_RSA_WITH_AES_256_CBC_SHA, - ?TLS_RSA_WITH_AES_256_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_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_ECDH_RSA_WITH_AES_128_CBC_SHA ]; suites(3) -> [?TLS_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384, @@ -230,16 +220,10 @@ suites(3) -> ?TLS_ECDH_ECDSA_WITH_AES_256_CBC_SHA384, ?TLS_ECDH_RSA_WITH_AES_256_CBC_SHA384, - ?TLS_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256, - ?TLS_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256, - ?TLS_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256, - ?TLS_DHE_RSA_WITH_AES_256_GCM_SHA384, ?TLS_DHE_DSS_WITH_AES_256_GCM_SHA384, ?TLS_DHE_RSA_WITH_AES_256_CBC_SHA256, ?TLS_DHE_DSS_WITH_AES_256_CBC_SHA256, - ?TLS_RSA_WITH_AES_256_GCM_SHA384, - ?TLS_RSA_WITH_AES_256_CBC_SHA256, ?TLS_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256, ?TLS_ECDHE_RSA_WITH_AES_128_GCM_SHA256, @@ -253,9 +237,7 @@ suites(3) -> ?TLS_DHE_RSA_WITH_AES_128_GCM_SHA256, ?TLS_DHE_DSS_WITH_AES_128_GCM_SHA256, ?TLS_DHE_RSA_WITH_AES_128_CBC_SHA256, - ?TLS_DHE_DSS_WITH_AES_128_CBC_SHA256, - ?TLS_RSA_WITH_AES_128_GCM_SHA256, - ?TLS_RSA_WITH_AES_128_CBC_SHA256 + ?TLS_DHE_DSS_WITH_AES_128_CBC_SHA256 %% not supported %% ?TLS_DH_RSA_WITH_AES_256_GCM_SHA384, @@ -264,8 +246,6 @@ suites(3) -> %% ?TLS_DH_DSS_WITH_AES_128_GCM_SHA256 ] ++ suites(2). - - signature_algs({3, 3}, HashSigns) -> CryptoSupports = crypto:supports(), Hashes = proplists:get_value(hashs, CryptoSupports), diff --git a/lib/ssl/test/Makefile b/lib/ssl/test/Makefile index aa01552c39..845f5bee2e 100644 --- a/lib/ssl/test/Makefile +++ b/lib/ssl/test/Makefile @@ -37,6 +37,8 @@ VSN=$(GS_VSN) MODULES = \ ssl_test_lib \ + ssl_bench_test_lib \ + ssl_dist_test_lib \ ssl_alpn_handshake_SUITE \ ssl_basic_SUITE \ ssl_bench_SUITE \ @@ -44,6 +46,7 @@ MODULES = \ ssl_certificate_verify_SUITE\ ssl_crl_SUITE\ ssl_dist_SUITE \ + ssl_dist_bench_SUITE \ ssl_engine_SUITE\ ssl_handshake_SUITE \ ssl_npn_hello_SUITE \ @@ -54,6 +57,8 @@ MODULES = \ ssl_session_cache_SUITE \ ssl_to_openssl_SUITE \ ssl_ECC_SUITE \ + ssl_ECC_openssl_SUITE \ + ssl_ECC\ ssl_upgrade_SUITE\ ssl_sni_SUITE \ make_certs\ @@ -62,7 +67,8 @@ MODULES = \ ERL_FILES = $(MODULES:%=%.erl) -HRL_FILES = +HRL_FILES = \ + ssl_dist_test_lib.hrl HRL_FILES_SRC = \ ssl_api.hrl\ diff --git a/lib/ssl/test/ssl.spec b/lib/ssl/test/ssl.spec index 0ad94e22bc..cb54168d36 100644 --- a/lib/ssl/test/ssl.spec +++ b/lib/ssl/test/ssl.spec @@ -1,5 +1,4 @@ {suites,"../ssl_test",all}. -{skip_cases, "../ssl_test", - ssl_bench_SUITE, [setup_sequential, setup_concurrent, payload_simple, - use_pem_cache, bypass_pem_cache], - "Benchmarks run separately"}. +{skip_suites, "../ssl_test", + [ssl_bench_SUITE, ssl_dist_bench_SUITE], + "Benchmarks run separately"}. diff --git a/lib/ssl/test/ssl_ECC.erl b/lib/ssl/test/ssl_ECC.erl new file mode 100644 index 0000000000..489a72e50e --- /dev/null +++ b/lib/ssl/test/ssl_ECC.erl @@ -0,0 +1,154 @@ + +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2018-2018. 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(ssl_ECC). + +%% Note: This directive should only be used in test suites. +-compile(export_all). + +-include_lib("common_test/include/ct.hrl"). +-include_lib("public_key/include/public_key.hrl"). + +%% Test diffrent certificate chain types, note that it is the servers +%% chain that affect what cipher suit that will be choosen + +%% ECDH_RSA +client_ecdh_rsa_server_ecdh_rsa(Config) when is_list(Config) -> + Suites = all_rsa_suites(Config), + Default = ssl_test_lib:default_cert_chain_conf(), + {COpts, SOpts} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, + {client_chain, Default}], + ecdh_rsa, ecdh_rsa, Config), + ssl_test_lib:basic_test(ssl_test_lib:ssl_options(COpts, Config), + ssl_test_lib:ssl_options(SOpts, Config), + [{check_keyex, ecdh_rsa}, {ciphers, Suites} | proplists:delete(check_keyex, Config)]). +client_ecdhe_rsa_server_ecdh_rsa(Config) when is_list(Config) -> + Suites = all_rsa_suites(Config), + Default = ssl_test_lib:default_cert_chain_conf(), + {COpts, SOpts} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, + {client_chain, Default}], + ecdhe_rsa, ecdh_rsa, Config), + ssl_test_lib:basic_test(ssl_test_lib:ssl_options(COpts, Config), + ssl_test_lib:ssl_options(SOpts, Config), + [{check_keyex, ecdh_rsa}, {ciphers, Suites} | proplists:delete(check_keyex, Config)]). +client_ecdhe_ecdsa_server_ecdh_rsa(Config) when is_list(Config) -> + Suites = all_rsa_suites(Config), + Default = ssl_test_lib:default_cert_chain_conf(), + {COpts, SOpts} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, + {client_chain, Default}], + ecdhe_ecdsa, ecdh_rsa, Config), + ssl_test_lib:basic_test(ssl_test_lib:ssl_options(COpts, Config), + ssl_test_lib:ssl_options(SOpts, Config), + [{check_keyex, ecdh_rsa}, {ciphers, Suites} | proplists:delete(check_keyex, Config)]). + +%% ECDHE_RSA +client_ecdh_rsa_server_ecdhe_rsa(Config) when is_list(Config) -> + Default = ssl_test_lib:default_cert_chain_conf(), + {COpts, SOpts} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, + {client_chain, Default}], + ecdh_rsa, ecdhe_rsa, Config), + ssl_test_lib:basic_test(ssl_test_lib:ssl_options(COpts, Config), + ssl_test_lib:ssl_options(SOpts, Config), + [{check_keyex, ecdhe_rsa} | proplists:delete(check_keyex, Config)]). +client_ecdhe_rsa_server_ecdhe_rsa(Config) when is_list(Config) -> + Default = ssl_test_lib:default_cert_chain_conf(), + {COpts, SOpts} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, + {client_chain, Default}], + ecdhe_rsa, ecdhe_rsa, Config), + ssl_test_lib:basic_test(ssl_test_lib:ssl_options(COpts, Config), + ssl_test_lib:ssl_options(SOpts, Config), + [{check_keyex, ecdhe_rsa} | proplists:delete(check_keyex, Config)]). +client_ecdhe_ecdsa_server_ecdhe_rsa(Config) when is_list(Config) -> + Default = ssl_test_lib:default_cert_chain_conf(), + {COpts, SOpts} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, + {client_chain, Default}], + ecdh_ecdsa, ecdhe_rsa, Config), + ssl_test_lib:basic_test(ssl_test_lib:ssl_options(COpts, Config), + ssl_test_lib:ssl_options(SOpts, Config), + [{check_keyex, ecdhe_rsa} | proplists:delete(check_keyex, Config)]). + +%% ECDH_ECDSA +client_ecdh_ecdsa_server_ecdh_ecdsa(Config) when is_list(Config) -> + Ext = x509_test:extensions([{key_usage, [keyEncipherment]}]), + {COpts, SOpts} = ssl_test_lib:make_ec_cert_chains([{server_chain, + [[], [], [{extensions, Ext}]]}, + {client_chain, + ssl_test_lib:default_cert_chain_conf()}], + ecdh_ecdsa, ecdh_ecdsa, Config), + ssl_test_lib:basic_test(ssl_test_lib:ssl_options(COpts, Config), + ssl_test_lib:ssl_options(SOpts, Config), + [{check_keyex, ecdh_ecdsa} | proplists:delete(check_keyex, Config)]). +client_ecdhe_rsa_server_ecdh_ecdsa(Config) when is_list(Config) -> + Ext = x509_test:extensions([{key_usage, [keyEncipherment]}]), + {COpts, SOpts} = ssl_test_lib:make_ec_cert_chains([{server_chain, + [[], [], [{extensions, Ext}]]}, + {client_chain, + ssl_test_lib:default_cert_chain_conf()}], + ecdhe_rsa, ecdh_ecdsa, Config), + ssl_test_lib:basic_test(ssl_test_lib:ssl_options(COpts, Config), + ssl_test_lib:ssl_options(SOpts, Config), + [{check_keyex, ecdh_ecdsa} | proplists:delete(check_keyex, Config)]). + +client_ecdhe_ecdsa_server_ecdh_ecdsa(Config) when is_list(Config) -> + Ext = x509_test:extensions([{key_usage, [keyEncipherment]}]), + {COpts, SOpts} = ssl_test_lib:make_ec_cert_chains([{server_chain, + [[], [], [{extensions, Ext}]]}, + {client_chain, + ssl_test_lib:default_cert_chain_conf()}], + ecdhe_ecdsa, ecdh_ecdsa, Config), + ssl_test_lib:basic_test(ssl_test_lib:ssl_options(COpts, Config), + ssl_test_lib:ssl_options(SOpts, Config), + [{check_keyex, ecdh_ecdsa} | proplists:delete(check_keyex, Config)]). + +%% ECDHE_ECDSA +client_ecdh_rsa_server_ecdhe_ecdsa(Config) when is_list(Config) -> + Default = ssl_test_lib:default_cert_chain_conf(), + {COpts, SOpts} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, + {client_chain, Default}], + ecdh_rsa, ecdhe_ecdsa, Config), + ssl_test_lib:basic_test(ssl_test_lib:ssl_options(COpts, Config), + ssl_test_lib:ssl_options(SOpts, Config), + [{check_keyex, ecdhe_ecdsa} | proplists:delete(check_keyex, Config)]). +client_ecdh_ecdsa_server_ecdhe_ecdsa(Config) when is_list(Config) -> + Default = ssl_test_lib:default_cert_chain_conf(), + {COpts, SOpts} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, + {client_chain, Default}], + ecdh_ecdsa, ecdhe_ecdsa, Config), + ssl_test_lib:basic_test(ssl_test_lib:ssl_options(COpts, Config), + ssl_test_lib:ssl_options(SOpts, Config), + [{check_keyex, ecdhe_ecdsa} | proplists:delete(check_keyex, Config)]). +client_ecdhe_ecdsa_server_ecdhe_ecdsa(Config) when is_list(Config) -> + Default = ssl_test_lib:default_cert_chain_conf(), + {COpts, SOpts} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, + {client_chain, Default}], + ecdhe_ecdsa, ecdhe_ecdsa, Config), + ssl_test_lib:basic_test(ssl_test_lib:ssl_options(COpts, Config), + ssl_test_lib:ssl_options(SOpts, Config), + [{check_keyex, ecdhe_ecdsa} | proplists:delete(check_keyex, Config)]). + +all_rsa_suites(Config) -> + Version = proplists:get_value(tls_version, Config), + All = ssl:cipher_suites(all, Version), + Default = ssl:cipher_suites(default, Version), + RSASuites = ssl:filter_cipher_suites(All,[{key_exchange, fun(rsa) -> true;(_) -> false end}]), + ssl:append_cipher_suites(RSASuites, Default). diff --git a/lib/ssl/test/ssl_ECC_SUITE.erl b/lib/ssl/test/ssl_ECC_SUITE.erl index f38c0a7416..6e2d86571a 100644 --- a/lib/ssl/test/ssl_ECC_SUITE.erl +++ b/lib/ssl/test/ssl_ECC_SUITE.erl @@ -43,52 +43,17 @@ all() -> groups() -> [ - {'tlsv1.2', [], all_versions_groups()}, - {'tlsv1.1', [], all_versions_groups()}, - {'tlsv1', [], all_versions_groups()}, - {'dtlsv1.2', [], all_versions_groups()}, - {'dtlsv1', [], all_versions_groups()}, - {'erlang_server', [], openssl_key_cert_combinations()}, - %%{'erlang_client', [], openssl_key_cert_combinations()}, - {'erlang', [], key_cert_combinations() ++ misc() - ++ ecc_negotiation()} + {'tlsv1.2', [], test_cases()}, + {'tlsv1.1', [], test_cases()}, + {'tlsv1', [], test_cases()}, + {'dtlsv1.2', [], test_cases()}, + {'dtlsv1', [], test_cases()} ]. -all_versions_groups ()-> - [{group, 'erlang_server'}, - %%{group, 'erlang_client'}, - {group, 'erlang'} - ]. - - -openssl_key_cert_combinations() -> - ECDH_RSA = case ssl_test_lib:openssl_filter("ECDH-RSA") of - [] -> - []; - _ -> - server_ecdh_rsa() - end, - - ECDHE_RSA = case ssl_test_lib:openssl_filter("ECDHE-RSA") of - [] -> - []; - _ -> - server_ecdhe_rsa() - end, - ECDH_ECDSA = case ssl_test_lib:openssl_filter("ECDH-ECDSA") of - [] -> - []; - _ -> - server_ecdhe_ecdsa() - end, - - ECDHE_ECDSA = case ssl_test_lib:openssl_filter("ECDHE-ECDSA") of - [] -> - []; - _ -> - server_ecdhe_ecdsa() - end, - ECDH_RSA ++ ECDHE_RSA ++ ECDH_ECDSA ++ ECDHE_ECDSA. +test_cases()-> + key_cert_combinations() + ++ misc() + ++ ecc_negotiation(). key_cert_combinations() -> server_ecdh_rsa() ++ @@ -116,7 +81,6 @@ server_ecdhe_ecdsa() -> client_ecdh_ecdsa_server_ecdhe_ecdsa, client_ecdhe_ecdsa_server_ecdhe_ecdsa]. - misc()-> [client_ecdsa_server_ecdsa_with_raw_key]. @@ -142,9 +106,14 @@ init_per_suite(Config0) -> end_per_suite(Config0), try crypto:start() of ok -> - Config0 + case ssl_test_lib:sufficient_crypto_support(cipher_ec) of + true -> + Config0; + false -> + {skip, "Crypto does not support ECC"} + end catch _:_ -> - {skip, "Crypto did not start"} + {skip, "Crypto did not start"} end. end_per_suite(_Config) -> @@ -152,52 +121,14 @@ end_per_suite(_Config) -> application:stop(crypto). %%-------------------------------------------------------------------- -init_per_group(erlang_client = Group, Config) -> - case ssl_test_lib:is_sane_ecc(openssl) of - true -> - common_init_per_group(Group, [{server_type, openssl}, - {client_type, erlang} | Config]); - false -> - {skip, "Known ECC bug in openssl"} - end; - -init_per_group(erlang_server = Group, Config) -> - case ssl_test_lib:is_sane_ecc(openssl) of - true -> - common_init_per_group(Group, [{server_type, erlang}, - {client_type, openssl} | Config]); - false -> - {skip, "Known ECC bug in openssl"} - end; - -init_per_group(erlang = Group, Config) -> - case ssl_test_lib:sufficient_crypto_support(Group) of - true -> - common_init_per_group(Group, [{server_type, erlang}, - {client_type, erlang} | Config]); - false -> - {skip, "Crypto does not support ECC"} - end; - -init_per_group(openssl = Group, Config) -> - case ssl_test_lib:sufficient_crypto_support(Group) of - true -> - common_init_per_group(Group, [{server_type, openssl}, - {client_type, openssl} | Config]); - false -> - {skip, "Crypto does not support ECC"} - end; - -init_per_group(Group, Config) -> - common_init_per_group(Group, Config). - -common_init_per_group(GroupName, Config) -> +init_per_group(GroupName, Config) -> case ssl_test_lib:is_tls_version(GroupName) of true -> - Config0 = ssl_test_lib:init_tls_version(GroupName, Config), - [{tls_version, GroupName} | Config0]; - _ -> - openssl_check(GroupName, Config) + [{tls_version, GroupName}, + {server_type, erlang}, + {client_type, erlang} | ssl_test_lib:init_tls_version(GroupName, Config)]; + _ -> + Config end. end_per_group(GroupName, Config0) -> @@ -215,7 +146,7 @@ init_per_testcase(TestCase, Config) -> ssl_test_lib:ct_log_supported_protocol_versions(Config), ct:log("Ciphers: ~p~n ", [ ssl:cipher_suites()]), end_per_testcase(TestCase, Config), - ssl_test_lib:clean_start(), + ssl:start(), ct:timetrap({seconds, 15}), Config. @@ -226,104 +157,45 @@ end_per_testcase(_TestCase, Config) -> %%-------------------------------------------------------------------- %% Test Cases -------------------------------------------------------- %%-------------------------------------------------------------------- - %% Test diffrent certificate chain types, note that it is the servers %% chain that affect what cipher suit that will be choosen %% ECDH_RSA client_ecdh_rsa_server_ecdh_rsa(Config) when is_list(Config) -> - Default = ssl_test_lib:default_cert_chain_conf(), - {COpts, SOpts} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, - {client_chain, Default}], - ecdh_rsa, ecdh_rsa, Config), - basic_test(COpts, SOpts, [{check_keyex, ecdh_rsa} | proplists:delete(check_keyex, Config)]). -client_ecdhe_rsa_server_ecdh_rsa(Config) when is_list(Config) -> - Default = ssl_test_lib:default_cert_chain_conf(), - {COpts, SOpts} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, - {client_chain, Default}], - ecdhe_rsa, ecdh_rsa, Config), - basic_test(COpts, SOpts, [{check_keyex, ecdh_rsa} | proplists:delete(check_keyex, Config)]). -client_ecdhe_ecdsa_server_ecdh_rsa(Config) when is_list(Config) -> - Default = ssl_test_lib:default_cert_chain_conf(), - {COpts, SOpts} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, - {client_chain, Default}], - ecdhe_ecdsa, ecdh_rsa, Config), - basic_test(COpts, SOpts, [{check_keyex, ecdh_rsa} | proplists:delete(check_keyex, Config)]). - + ssl_ECC:client_ecdh_rsa_server_ecdh_rsa(Config). +client_ecdhe_rsa_server_ecdh_rsa(Config) when is_list(Config) -> + ssl_ECC:client_ecdhe_rsa_server_ecdh_rsa(Config). +client_ecdhe_ecdsa_server_ecdh_rsa(Config) when is_list(Config) -> + ssl_ECC:client_ecdhe_ecdsa_server_ecdh_rsa(Config). %% ECDHE_RSA client_ecdh_rsa_server_ecdhe_rsa(Config) when is_list(Config) -> - Default = ssl_test_lib:default_cert_chain_conf(), - {COpts, SOpts} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, - {client_chain, Default}], - ecdh_rsa, ecdhe_rsa, Config), - basic_test(COpts, SOpts, [{check_keyex, ecdhe_rsa} | proplists:delete(check_keyex, Config)]). -client_ecdhe_rsa_server_ecdhe_rsa(Config) when is_list(Config) -> - Default = ssl_test_lib:default_cert_chain_conf(), - {COpts, SOpts} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, - {client_chain, Default}], - ecdhe_rsa, ecdhe_rsa, Config), - basic_test(COpts, SOpts, [{check_keyex, ecdhe_rsa} | proplists:delete(check_keyex, Config)]). -client_ecdhe_ecdsa_server_ecdhe_rsa(Config) when is_list(Config) -> - Default = ssl_test_lib:default_cert_chain_conf(), - {COpts, SOpts} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, - {client_chain, Default}], - ecdh_ecdsa, ecdhe_rsa, Config), - basic_test(COpts, SOpts, [{check_keyex, ecdhe_rsa} | proplists:delete(check_keyex, Config)]). - + ssl_ECC:client_ecdh_rsa_server_ecdhe_rsa(Config). +client_ecdhe_rsa_server_ecdhe_rsa(Config) when is_list(Config) -> + ssl_ECC:client_ecdhe_rsa_server_ecdhe_rsa(Config). +client_ecdhe_ecdsa_server_ecdhe_rsa(Config) when is_list(Config) -> + ssl_ECC:client_ecdhe_ecdsa_server_ecdhe_rsa(Config). %% ECDH_ECDSA -client_ecdh_ecdsa_server_ecdh_ecdsa(Config) when is_list(Config) -> - Ext = x509_test:extensions([{key_usage, [keyEncipherment]}]), - {COpts, SOpts} = ssl_test_lib:make_ec_cert_chains([{server_chain, - [[], [], [{extensions, Ext}]]}, - {client_chain, - ssl_test_lib:default_cert_chain_conf()}], - ecdh_ecdsa, ecdh_ecdsa, Config), - basic_test(COpts, SOpts, - [{check_keyex, ecdh_ecdsa} | proplists:delete(check_keyex, Config)]). -client_ecdhe_rsa_server_ecdh_ecdsa(Config) when is_list(Config) -> - Ext = x509_test:extensions([{key_usage, [keyEncipherment]}]), - {COpts, SOpts} = ssl_test_lib:make_ec_cert_chains([{server_chain, - [[], [], [{extensions, Ext}]]}, - {client_chain, - ssl_test_lib:default_cert_chain_conf()}], - ecdhe_rsa, ecdh_ecdsa, Config), - basic_test(COpts, SOpts, [{check_keyex, ecdh_ecdsa} | proplists:delete(check_keyex, Config)]). - -client_ecdhe_ecdsa_server_ecdh_ecdsa(Config) when is_list(Config) -> - Ext = x509_test:extensions([{key_usage, [keyEncipherment]}]), - {COpts, SOpts} = ssl_test_lib:make_ec_cert_chains([{server_chain, - [[], [], [{extensions, Ext}]]}, - {client_chain, - ssl_test_lib:default_cert_chain_conf()}], - ecdhe_ecdsa, ecdh_ecdsa, Config), - basic_test(COpts, SOpts, - [{check_keyex, ecdh_ecdsa} | proplists:delete(check_keyex, Config)]). - +client_ecdh_ecdsa_server_ecdh_ecdsa(Config) when is_list(Config) -> + ssl_ECC:client_ecdh_ecdsa_server_ecdh_ecdsa(Config). +client_ecdhe_rsa_server_ecdh_ecdsa(Config) when is_list(Config) -> + ssl_ECC:client_ecdhe_rsa_server_ecdh_ecdsa(Config). +client_ecdhe_ecdsa_server_ecdh_ecdsa(Config) when is_list(Config) -> + ssl_ECC:client_ecdhe_ecdsa_server_ecdh_ecdsa(Config). %% ECDHE_ECDSA -client_ecdh_rsa_server_ecdhe_ecdsa(Config) when is_list(Config) -> - Default = ssl_test_lib:default_cert_chain_conf(), - {COpts, SOpts} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, - {client_chain, Default}], - ecdh_rsa, ecdhe_ecdsa, Config), - basic_test(COpts, SOpts, [{check_keyex, ecdhe_ecdsa} | proplists:delete(check_keyex, Config)]). -client_ecdh_ecdsa_server_ecdhe_ecdsa(Config) when is_list(Config) -> - Default = ssl_test_lib:default_cert_chain_conf(), - {COpts, SOpts} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, - {client_chain, Default}], - ecdh_ecdsa, ecdhe_ecdsa, Config), - basic_test(COpts, SOpts, [{check_keyex, ecdhe_ecdsa} | proplists:delete(check_keyex, Config)]). -client_ecdhe_ecdsa_server_ecdhe_ecdsa(Config) when is_list(Config) -> - Default = ssl_test_lib:default_cert_chain_conf(), - {COpts, SOpts} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, - {client_chain, Default}], - ecdhe_ecdsa, ecdhe_ecdsa, Config), - basic_test(COpts, SOpts, [{check_keyex, ecdhe_ecdsa} | proplists:delete(check_keyex, Config)]). +client_ecdh_rsa_server_ecdhe_ecdsa(Config) when is_list(Config) -> + ssl_ECC:client_ecdh_rsa_server_ecdhe_ecdsa(Config). +client_ecdh_ecdsa_server_ecdhe_ecdsa(Config) when is_list(Config) -> + ssl_ECC:client_ecdh_ecdsa_server_ecdhe_ecdsa(Config). +client_ecdhe_ecdsa_server_ecdhe_ecdsa(Config) when is_list(Config) -> + ssl_ECC:client_ecdhe_ecdsa_server_ecdhe_ecdsa(Config). client_ecdsa_server_ecdsa_with_raw_key(Config) when is_list(Config) -> Default = ssl_test_lib:default_cert_chain_conf(), - {COpts, SOpts} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, + {COpts0, SOpts0} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, {client_chain, Default}] , ecdhe_ecdsa, ecdhe_ecdsa, Config), + COpts = ssl_test_lib:ssl_options(COpts0, Config), + SOpts = ssl_test_lib:ssl_options(SOpts0, Config), ServerKeyFile = proplists:get_value(keyfile, SOpts), {ok, PemBin} = file:read_file(ServerKeyFile), PemEntries = public_key:pem_decode(PemBin), @@ -331,331 +203,192 @@ client_ecdsa_server_ecdsa_with_raw_key(Config) when is_list(Config) -> ServerKey = {'ECPrivateKey', Key}, SType = proplists:get_value(server_type, Config), CType = proplists:get_value(client_type, Config), - {Server, Port} = start_server_with_raw_key(SType, - [{key, ServerKey} | proplists:delete(keyfile, SOpts)], - Config), - Client = start_client(CType, Port, COpts, Config), - check_result(Server, SType, Client, CType), - close(Server, Client). + {Server, Port} = ssl_test_lib:start_server_with_raw_key(SType, + [{key, ServerKey} | proplists:delete(keyfile, SOpts)], + Config), + Client = ssl_test_lib:start_client(CType, Port, COpts, Config), + ssl_test_lib:gen_check_result(Server, SType, Client, CType), + ssl_test_lib:stop(Server, Client). ecc_default_order(Config) -> Default = ssl_test_lib:default_cert_chain_conf(), - {COpts, SOpts} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, - {client_chain, Default}], - ecdhe_ecdsa, ecdhe_ecdsa, Config), + {COpts0, SOpts0} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, + {client_chain, Default}], + ecdhe_ecdsa, ecdhe_ecdsa, Config), + COpts = ssl_test_lib:ssl_options(COpts0, Config), + SOpts = ssl_test_lib:ssl_options(SOpts0, Config), ECCOpts = [], - case supported_eccs([{eccs, [sect571r1]}]) of - true -> ecc_test(sect571r1, COpts, SOpts, [], ECCOpts, Config); + case ssl_test_lib:supported_eccs([{eccs, [sect571r1]}]) of + true -> ssl_test_lib:ecc_test(sect571r1, COpts, SOpts, [], ECCOpts, Config); false -> {skip, "unsupported named curves"} end. ecc_default_order_custom_curves(Config) -> Default = ssl_test_lib:default_cert_chain_conf(), - {COpts, SOpts} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, - {client_chain, Default}], - ecdhe_ecdsa, ecdhe_ecdsa, Config), + {COpts0, SOpts0} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, + {client_chain, Default}], + ecdhe_ecdsa, ecdhe_ecdsa, Config), + COpts = ssl_test_lib:ssl_options(COpts0, Config), + SOpts = ssl_test_lib:ssl_options(SOpts0, Config), ECCOpts = [{eccs, [secp256r1, sect571r1]}], - case supported_eccs(ECCOpts) of - true -> ecc_test(sect571r1, COpts, SOpts, [], ECCOpts, Config); + case ssl_test_lib:supported_eccs(ECCOpts) of + true -> ssl_test_lib:ecc_test(sect571r1, COpts, SOpts, [], ECCOpts, Config); false -> {skip, "unsupported named curves"} end. ecc_client_order(Config) -> Default = ssl_test_lib:default_cert_chain_conf(), - {COpts, SOpts} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, - {client_chain, Default}], - ecdhe_ecdsa, ecdhe_ecdsa, Config), + {COpts0, SOpts0} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, + {client_chain, Default}], + ecdhe_ecdsa, ecdhe_ecdsa, Config), + COpts = ssl_test_lib:ssl_options(COpts0, Config), + SOpts = ssl_test_lib:ssl_options(SOpts0, Config), ECCOpts = [{honor_ecc_order, false}], - case supported_eccs([{eccs, [sect571r1]}]) of - true -> ecc_test(sect571r1, COpts, SOpts, [], ECCOpts, Config); + case ssl_test_lib:supported_eccs([{eccs, [sect571r1]}]) of + true -> ssl_test_lib:ecc_test(sect571r1, COpts, SOpts, [], ECCOpts, Config); false -> {skip, "unsupported named curves"} end. ecc_client_order_custom_curves(Config) -> Default = ssl_test_lib:default_cert_chain_conf(), - {COpts, SOpts} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, + {COpts0, SOpts0} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, {client_chain, Default}], ecdhe_ecdsa, ecdhe_ecdsa, Config), + COpts = ssl_test_lib:ssl_options(COpts0, Config), + SOpts = ssl_test_lib:ssl_options(SOpts0, Config), ECCOpts = [{honor_ecc_order, false}, {eccs, [secp256r1, sect571r1]}], - case supported_eccs(ECCOpts) of - true -> ecc_test(sect571r1, COpts, SOpts, [], ECCOpts, Config); + case ssl_test_lib:supported_eccs(ECCOpts) of + true -> ssl_test_lib:ecc_test(sect571r1, COpts, SOpts, [], ECCOpts, Config); false -> {skip, "unsupported named curves"} end. ecc_unknown_curve(Config) -> Default = ssl_test_lib:default_cert_chain_conf(), - {COpts, SOpts} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, + {COpts0, SOpts0} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, {client_chain, Default}], ecdhe_ecdsa, ecdhe_ecdsa, Config), + COpts = ssl_test_lib:ssl_options(COpts0, Config), + SOpts = ssl_test_lib:ssl_options(SOpts0, Config), ECCOpts = [{eccs, ['123_fake_curve']}], - ecc_test_error(COpts, SOpts, [], ECCOpts, Config). + ssl_test_lib:ecc_test_error(COpts, SOpts, [], ECCOpts, Config). client_ecdh_rsa_server_ecdhe_ecdsa_server_custom(Config) -> Default = ssl_test_lib:default_cert_chain_conf(), - {COpts, SOpts} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, + {COpts0, SOpts0} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, {client_chain, Default}], - ecdh_rsa, ecdhe_ecdsa, Config), + ecdh_rsa, ecdhe_ecdsa, Config), + COpts = ssl_test_lib:ssl_options(COpts0, Config), + SOpts = ssl_test_lib:ssl_options(SOpts0, Config), ECCOpts = [{honor_ecc_order, true}, {eccs, [secp256r1, sect571r1]}], - case supported_eccs(ECCOpts) of - true -> ecc_test(secp256r1, COpts, SOpts, [], ECCOpts, Config); + case ssl_test_lib:supported_eccs(ECCOpts) of + true -> ssl_test_lib:ecc_test(secp256r1, COpts, SOpts, [], ECCOpts, Config); false -> {skip, "unsupported named curves"} end. client_ecdh_rsa_server_ecdhe_rsa_server_custom(Config) -> Default = ssl_test_lib:default_cert_chain_conf(), - {COpts, SOpts} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, + {COpts0, SOpts0} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, {client_chain, Default}], ecdh_rsa, ecdhe_rsa, Config), + COpts = ssl_test_lib:ssl_options(COpts0, Config), + SOpts = ssl_test_lib:ssl_options(SOpts0, Config), ECCOpts = [{honor_ecc_order, true}, {eccs, [secp256r1, sect571r1]}], - case supported_eccs(ECCOpts) of - true -> ecc_test(undefined, COpts, SOpts, [], ECCOpts, Config); + + case ssl_test_lib:supported_eccs(ECCOpts) of + true -> ssl_test_lib:ecc_test(undefined, COpts, SOpts, [], ECCOpts, Config); false -> {skip, "unsupported named curves"} end. client_ecdhe_rsa_server_ecdhe_ecdsa_server_custom(Config) -> Default = ssl_test_lib:default_cert_chain_conf(), - {COpts, SOpts} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, + {COpts0, SOpts0} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, {client_chain, Default}], ecdhe_rsa, ecdhe_ecdsa, Config), + COpts = ssl_test_lib:ssl_options(COpts0, Config), + SOpts = ssl_test_lib:ssl_options(SOpts0, Config), ECCOpts = [{honor_ecc_order, true}, {eccs, [secp256r1, sect571r1]}], - case supported_eccs(ECCOpts) of - true -> ecc_test(secp256r1, COpts, SOpts, [], ECCOpts, Config); + case ssl_test_lib:supported_eccs(ECCOpts) of + true -> ssl_test_lib:ecc_test(secp256r1, COpts, SOpts, [], ECCOpts, Config); false -> {skip, "unsupported named curves"} end. client_ecdhe_rsa_server_ecdhe_rsa_server_custom(Config) -> Default = ssl_test_lib:default_cert_chain_conf(), - {COpts, SOpts} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, + {COpts0, SOpts0} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, {client_chain, Default}], ecdhe_rsa, ecdhe_rsa, Config), + + COpts = ssl_test_lib:ssl_options(COpts0, Config), + SOpts = ssl_test_lib:ssl_options(SOpts0, Config), ECCOpts = [{honor_ecc_order, true}, {eccs, [secp256r1, sect571r1]}], - case supported_eccs(ECCOpts) of - true -> ecc_test(undefined, COpts, SOpts, [], ECCOpts, Config); + case ssl_test_lib:supported_eccs(ECCOpts) of + true -> ssl_test_lib:ecc_test(undefined, COpts, SOpts, [], ECCOpts, Config); false -> {skip, "unsupported named curves"} end. client_ecdhe_rsa_server_ecdh_rsa_server_custom(Config) -> Default = ssl_test_lib:default_cert_chain_conf(), Ext = x509_test:extensions([{key_usage, [keyEncipherment]}]), - {COpts, SOpts} = ssl_test_lib:make_ec_cert_chains([{server_chain, [[], [], [{extensions, Ext}]]}, + {COpts0, SOpts0} = ssl_test_lib:make_ec_cert_chains([{server_chain, [[], [], [{extensions, Ext}]]}, {client_chain, Default}], ecdhe_rsa, ecdh_rsa, Config), + + COpts = ssl_test_lib:ssl_options(COpts0, Config), + SOpts = ssl_test_lib:ssl_options(SOpts0, Config), ECCOpts = [{honor_ecc_order, true}, {eccs, [secp256r1, sect571r1]}], - case supported_eccs(ECCOpts) of - true -> ecc_test(undefined, COpts, SOpts, [], ECCOpts, Config); + + case ssl_test_lib:supported_eccs(ECCOpts) of + true -> ssl_test_lib:ecc_test(undefined, COpts, SOpts, [], ECCOpts, Config); false -> {skip, "unsupported named curves"} end. client_ecdhe_ecdsa_server_ecdhe_ecdsa_server_custom(Config) -> Default = ssl_test_lib:default_cert_chain_conf(), - {COpts, SOpts} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, + {COpts0, SOpts0} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, {client_chain, Default}], ecdhe_ecdsa, ecdhe_ecdsa, Config), + COpts = ssl_test_lib:ssl_options(COpts0, Config), + SOpts = ssl_test_lib:ssl_options(SOpts0, Config), ECCOpts = [{honor_ecc_order, true}, {eccs, [secp256r1, sect571r1]}], - case supported_eccs(ECCOpts) of - true -> ecc_test(secp256r1, COpts, SOpts, [], ECCOpts, Config); + case ssl_test_lib:supported_eccs(ECCOpts) of + true -> ssl_test_lib:ecc_test(secp256r1, COpts, SOpts, [], ECCOpts, Config); false -> {skip, "unsupported named curves"} end. client_ecdhe_ecdsa_server_ecdhe_rsa_server_custom(Config) -> Default = ssl_test_lib:default_cert_chain_conf(), - {COpts, SOpts} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, + {COpts0, SOpts0} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, {client_chain, Default}], ecdhe_ecdsa, ecdhe_rsa, Config), + COpts = ssl_test_lib:ssl_options(COpts0, Config), + SOpts = ssl_test_lib:ssl_options(SOpts0, Config), ECCOpts = [{honor_ecc_order, true}, {eccs, [secp256r1, sect571r1]}], - case supported_eccs(ECCOpts) of - true -> ecc_test(undefined, COpts, SOpts, [], ECCOpts, Config); + case ssl_test_lib:supported_eccs(ECCOpts) of + true -> ssl_test_lib:ecc_test(undefined, COpts, SOpts, [], ECCOpts, Config); false -> {skip, "unsupported named curves"} end. client_ecdhe_ecdsa_server_ecdhe_ecdsa_client_custom(Config) -> Default = ssl_test_lib:default_cert_chain_conf(), - {COpts, SOpts} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, + {COpts0, SOpts0} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, {client_chain, Default}], ecdhe_ecdsa, ecdhe_ecdsa, Config), + COpts = ssl_test_lib:ssl_options(COpts0, Config), + SOpts = ssl_test_lib:ssl_options(SOpts0, Config), ECCOpts = [{eccs, [secp256r1, sect571r1]}], - case supported_eccs(ECCOpts) of - true -> ecc_test(secp256r1, COpts, SOpts, ECCOpts, [], Config); + case ssl_test_lib:supported_eccs(ECCOpts) of + true -> ssl_test_lib:ecc_test(secp256r1, COpts, SOpts, ECCOpts, [], Config); false -> {skip, "unsupported named curves"} end. client_ecdhe_rsa_server_ecdhe_ecdsa_client_custom(Config) -> Default = ssl_test_lib:default_cert_chain_conf(), - {COpts, SOpts} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, + {COpts0, SOpts0} = ssl_test_lib:make_ec_cert_chains([{server_chain, Default}, {client_chain, Default}], ecdhe_rsa, ecdhe_ecdsa, Config), + COpts = ssl_test_lib:ssl_options(COpts0, Config), + SOpts = ssl_test_lib:ssl_options(SOpts0, Config), ECCOpts = [{eccs, [secp256r1, sect571r1]}], - case supported_eccs(ECCOpts) of - true -> ecc_test(secp256r1, COpts, SOpts, ECCOpts, [], Config); + case ssl_test_lib:supported_eccs(ECCOpts) of + true -> ssl_test_lib:ecc_test(secp256r1, COpts, SOpts, ECCOpts, [], Config); false -> {skip, "unsupported named curves"} end. - -%%-------------------------------------------------------------------- -%% Internal functions ------------------------------------------------ -%%-------------------------------------------------------------------- -basic_test(COpts, SOpts, Config) -> - SType = proplists:get_value(server_type, Config), - CType = proplists:get_value(client_type, Config), - {Server, Port} = start_server(SType, SOpts, Config), - Client = start_client(CType, Port, COpts, Config), - check_result(Server, SType, Client, CType), - close(Server, Client). - - -ecc_test(Expect, COpts, SOpts, CECCOpts, SECCOpts, Config) -> - {Server, Port} = start_server_ecc(erlang, SOpts, Expect, SECCOpts, Config), - Client = start_client_ecc(erlang, Port, COpts, Expect, CECCOpts, Config), - ssl_test_lib:check_result(Server, ok, Client, ok), - close(Server, Client). - -ecc_test_error(COpts, SOpts, CECCOpts, SECCOpts, Config) -> - {Server, Port} = start_server_ecc_error(erlang, SOpts, SECCOpts, Config), - Client = start_client_ecc_error(erlang, Port, COpts, CECCOpts, Config), - Error = {error, {tls_alert, "insufficient security"}}, - ssl_test_lib:check_result(Server, Error, Client, Error). - - -start_client(openssl, Port, ClientOpts, _Config) -> - Cert = proplists:get_value(certfile, ClientOpts), - Key = proplists:get_value(keyfile, ClientOpts), - CA = proplists:get_value(cacertfile, ClientOpts), - Version = tls_record:protocol_version(tls_record:highest_protocol_version([])), - Exe = "openssl", - Args = ["s_client", "-verify", "2", "-port", integer_to_list(Port), - ssl_test_lib:version_flag(Version), - "-cert", Cert, "-CAfile", CA, - "-key", Key, "-host","localhost", "-msg", "-debug"], - - OpenSslPort = ssl_test_lib:portable_open_port(Exe, Args), - true = port_command(OpenSslPort, "Hello world"), - OpenSslPort; - -start_client(erlang, Port, ClientOpts, Config) -> - {ClientNode, _, Hostname} = ssl_test_lib:run_where(Config), - KeyEx = proplists:get_value(check_keyex, Config, false), - ssl_test_lib:start_client([{node, ClientNode}, {port, Port}, - {host, Hostname}, - {from, self()}, - {mfa, {ssl_test_lib, check_key_exchange_send_active, [KeyEx]}}, - {options, [{verify, verify_peer} | ClientOpts]}]). - - -start_client_ecc(erlang, Port, ClientOpts, Expect, ECCOpts, Config) -> - {ClientNode, _, Hostname} = ssl_test_lib:run_where(Config), - ssl_test_lib:start_client([{node, ClientNode}, {port, Port}, - {host, Hostname}, - {from, self()}, - {mfa, {?MODULE, check_ecc, [client, Expect]}}, - {options, - ECCOpts ++ - [{verify, verify_peer} | ClientOpts]}]). - -start_client_ecc_error(erlang, Port, ClientOpts, ECCOpts, Config) -> - {ClientNode, _, Hostname} = ssl_test_lib:run_where(Config), - ssl_test_lib:start_client_error([{node, ClientNode}, {port, Port}, - {host, Hostname}, - {from, self()}, - {options, - ECCOpts ++ - [{verify, verify_peer} | ClientOpts]}]). - - -start_server(openssl, ServerOpts, _Config) -> - Cert = proplists:get_value(certfile, ServerOpts), - Key = proplists:get_value(keyfile, ServerOpts), - CA = proplists:get_value(cacertfile, ServerOpts), - Port = ssl_test_lib:inet_port(node()), - Version = tls_record:protocol_version(tls_record:highest_protocol_version([])), - Exe = "openssl", - Args = ["s_server", "-accept", integer_to_list(Port), ssl_test_lib:version_flag(Version), - "-verify", "2", "-cert", Cert, "-CAfile", CA, - "-key", Key, "-msg", "-debug"], - OpenSslPort = ssl_test_lib:portable_open_port(Exe, Args), - true = port_command(OpenSslPort, "Hello world"), - {OpenSslPort, Port}; -start_server(erlang, ServerOpts, Config) -> - {_, ServerNode, _} = ssl_test_lib:run_where(Config), - KeyEx = proplists:get_value(check_keyex, Config, false), - Server = ssl_test_lib:start_server([{node, ServerNode}, {port, 0}, - {from, self()}, - {mfa, {ssl_test_lib, - check_key_exchange_send_active, - [KeyEx]}}, - {options, [{verify, verify_peer} | ServerOpts]}]), - {Server, ssl_test_lib:inet_port(Server)}. - -start_server_with_raw_key(erlang, ServerOpts, Config) -> - {_, ServerNode, _} = ssl_test_lib:run_where(Config), - Server = ssl_test_lib:start_server([{node, ServerNode}, {port, 0}, - {from, self()}, - {mfa, {ssl_test_lib, - send_recv_result_active, - []}}, - {options, - [{verify, verify_peer} | ServerOpts]}]), - {Server, ssl_test_lib:inet_port(Server)}. - -start_server_ecc(erlang, ServerOpts, Expect, ECCOpts, Config) -> - {_, ServerNode, _} = ssl_test_lib:run_where(Config), - Server = ssl_test_lib:start_server([{node, ServerNode}, {port, 0}, - {from, self()}, - {mfa, {?MODULE, check_ecc, [server, Expect]}}, - {options, - ECCOpts ++ - [{verify, verify_peer} | ServerOpts]}]), - {Server, ssl_test_lib:inet_port(Server)}. - -start_server_ecc_error(erlang, ServerOpts, ECCOpts, Config) -> - {_, ServerNode, _} = ssl_test_lib:run_where(Config), - Server = ssl_test_lib:start_server_error([{node, ServerNode}, {port, 0}, - {from, self()}, - {options, - ECCOpts ++ - [{verify, verify_peer} | ServerOpts]}]), - {Server, ssl_test_lib:inet_port(Server)}. - -check_result(Server, erlang, Client, erlang) -> - ssl_test_lib:check_result(Server, ok, Client, ok); -check_result(Server, erlang, _, _) -> - ssl_test_lib:check_result(Server, ok); -check_result(_, _, Client, erlang) -> - ssl_test_lib:check_result(Client, ok); -check_result(_,openssl, _, openssl) -> - ok. - -openssl_check(erlang, Config) -> - Config; -openssl_check(_, Config) -> - TLSVersion = proplists:get_value(tls_version, Config), - case ssl_test_lib:check_sane_openssl_version(TLSVersion) of - true -> - Config; - false -> - {skip, "TLS version not supported by openssl"} - end. - -close(Port1, Port2) when is_port(Port1), is_port(Port2) -> - ssl_test_lib:close_port(Port1), - ssl_test_lib:close_port(Port2); -close(Port, Pid) when is_port(Port) -> - ssl_test_lib:close_port(Port), - ssl_test_lib:close(Pid); -close(Pid, Port) when is_port(Port) -> - ssl_test_lib:close_port(Port), - ssl_test_lib:close(Pid); -close(Client, Server) -> - ssl_test_lib:close(Server), - ssl_test_lib:close(Client). - -supported_eccs(Opts) -> - ToCheck = proplists:get_value(eccs, Opts, []), - Supported = ssl:eccs(), - lists:all(fun(Curve) -> lists:member(Curve, Supported) end, ToCheck). - -check_ecc(SSL, Role, Expect) -> - {ok, Data} = ssl:connection_information(SSL), - case lists:keyfind(ecc, 1, Data) of - {ecc, {named_curve, Expect}} -> ok; - false when Expect =:= undefined -> ok; - Other -> {error, Role, Expect, Other} - end. - diff --git a/lib/ssl/test/ssl_ECC_openssl_SUITE.erl b/lib/ssl/test/ssl_ECC_openssl_SUITE.erl new file mode 100644 index 0000000000..ba609aa0dc --- /dev/null +++ b/lib/ssl/test/ssl_ECC_openssl_SUITE.erl @@ -0,0 +1,185 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2018-2018. 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(ssl_ECC_openssl_SUITE). + +%% Note: This directive should only be used in test suites. +-compile(export_all). + +-include_lib("common_test/include/ct.hrl"). +-include_lib("public_key/include/public_key.hrl"). + +%%-------------------------------------------------------------------- +%% Common Test interface functions ----------------------------------- +%%-------------------------------------------------------------------- + +all() -> + [ + {group, 'tlsv1.2'}, + {group, 'tlsv1.1'}, + {group, 'tlsv1'}, + {group, 'dtlsv1.2'}, + {group, 'dtlsv1'} + ]. + +groups() -> + [ + {'tlsv1.2', [], test_cases()}, + {'tlsv1.1', [], test_cases()}, + {'tlsv1', [], test_cases()}, + {'dtlsv1.2', [], test_cases()}, + {'dtlsv1', [], test_cases()} + ]. + +test_cases()-> + %% cert_combinations(). + server_ecdh_rsa(). +cert_combinations() -> + lists:append(lists:filtermap(fun({Name, Suites}) -> + case ssl_test_lib:openssl_filter(Name) of + [] -> + false; + [_|_] -> + {true, Suites} + end + end, [{"ECDH-RSA", server_ecdh_rsa()}, + {"ECDHE-RSA", server_ecdhe_rsa()}, + {"ECDH-ECDSA", server_ecdh_ecdsa()}, + {"ECDHE-ECDSA", server_ecdhe_ecdsa()} + ])). +server_ecdh_rsa() -> + [client_ecdh_rsa_server_ecdh_rsa, + client_ecdhe_rsa_server_ecdh_rsa, + client_ecdhe_ecdsa_server_ecdh_rsa]. + +server_ecdhe_rsa() -> + [client_ecdh_rsa_server_ecdhe_rsa, + client_ecdhe_rsa_server_ecdhe_rsa, + client_ecdhe_ecdsa_server_ecdhe_rsa]. + +server_ecdh_ecdsa() -> + [client_ecdh_ecdsa_server_ecdh_ecdsa, + client_ecdhe_rsa_server_ecdh_ecdsa, + client_ecdhe_ecdsa_server_ecdh_ecdsa]. + +server_ecdhe_ecdsa() -> + [client_ecdh_rsa_server_ecdhe_ecdsa, + client_ecdh_ecdsa_server_ecdhe_ecdsa, + client_ecdhe_ecdsa_server_ecdhe_ecdsa]. + +%%-------------------------------------------------------------------- +init_per_suite(Config0) -> + end_per_suite(Config0), + try crypto:start() of + ok -> + case ssl_test_lib:sufficient_crypto_support(cipher_ec) of + true -> + Config0; + false -> + {skip, "Crypto does not support ECC"} + end + catch _:_ -> + {skip, "Crypto did not start"} + end. + +end_per_suite(_Config) -> + application:stop(ssl), + application:stop(crypto). + +%%-------------------------------------------------------------------- +init_per_group(GroupName, Config) -> + case ssl_test_lib:is_tls_version(GroupName) of + true -> + case ssl_test_lib:check_sane_openssl_version(GroupName) of + true -> + [{tls_version, GroupName}, + {server_type, erlang}, + {client_type, openssl} | ssl_test_lib:init_tls_version(GroupName, Config)]; + false -> + {skip, openssl_does_not_support_version} + end; + _ -> + Config + end. + +end_per_group(GroupName, Config0) -> + case ssl_test_lib:is_tls_version(GroupName) of + true -> + Config = ssl_test_lib:clean_tls_version(Config0), + proplists:delete(tls_version, Config); + false -> + Config0 + end. + +%%-------------------------------------------------------------------- + +init_per_testcase(TestCase, Config) -> + ssl_test_lib:ct_log_supported_protocol_versions(Config), + Version = proplists:get_value(tls_version, Config), + ct:log("Ciphers: ~p~n ", [ssl:cipher_suites(default, Version)]), + end_per_testcase(TestCase, Config), + ssl:start(), + ct:timetrap({seconds, 15}), + Config. + +end_per_testcase(_TestCase, Config) -> + application:stop(ssl), + Config. + +%%-------------------------------------------------------------------- +%% Test Cases -------------------------------------------------------- +%%-------------------------------------------------------------------- + +%% Test diffrent certificate chain types, note that it is the servers +%% chain that affect what cipher suit that will be choosen + +%% ECDH_RSA +client_ecdh_rsa_server_ecdh_rsa(Config) when is_list(Config) -> + ssl_ECC:client_ecdh_rsa_server_ecdh_rsa(Config). +client_ecdhe_rsa_server_ecdh_rsa(Config) when is_list(Config) -> + ssl_ECC:client_ecdhe_rsa_server_ecdh_rsa(Config). +client_ecdhe_ecdsa_server_ecdh_rsa(Config) when is_list(Config) -> + ssl_ECC:client_ecdhe_ecdsa_server_ecdh_rsa(Config). +%% ECDHE_RSA +client_ecdh_rsa_server_ecdhe_rsa(Config) when is_list(Config) -> + ssl_ECC:client_ecdh_rsa_server_ecdhe_rsa(Config). +client_ecdhe_rsa_server_ecdhe_rsa(Config) when is_list(Config) -> + ssl_ECC:client_ecdhe_rsa_server_ecdhe_rsa(Config). +client_ecdhe_ecdsa_server_ecdhe_rsa(Config) when is_list(Config) -> + ssl_ECC:client_ecdhe_ecdsa_server_ecdhe_rsa(Config). +%% ECDH_ECDSA +client_ecdh_ecdsa_server_ecdh_ecdsa(Config) when is_list(Config) -> + ssl_ECC:client_ecdh_ecdsa_server_ecdh_ecdsa(Config). +client_ecdhe_rsa_server_ecdh_ecdsa(Config) when is_list(Config) -> + ssl_ECC:client_ecdhe_rsa_server_ecdh_ecdsa(Config). +client_ecdhe_ecdsa_server_ecdh_ecdsa(Config) when is_list(Config) -> + ssl_ECC:client_ecdhe_ecdsa_server_ecdh_ecdsa(Config). +%% ECDHE_ECDSA +client_ecdh_rsa_server_ecdhe_ecdsa(Config) when is_list(Config) -> + ssl_ECC:client_ecdh_rsa_server_ecdhe_ecdsa(Config). +client_ecdh_ecdsa_server_ecdhe_ecdsa(Config) when is_list(Config) -> + ssl_ECC:client_ecdh_ecdsa_server_ecdhe_ecdsa(Config). +client_ecdhe_ecdsa_server_ecdhe_ecdsa(Config) when is_list(Config) -> + ssl_ECC:client_ecdhe_ecdsa_server_ecdhe_ecdsa(Config). +%%-------------------------------------------------------------------- +%% Internal functions ------------------------------------------------ +%%-------------------------------------------------------------------- diff --git a/lib/ssl/test/ssl_basic_SUITE.erl b/lib/ssl/test/ssl_basic_SUITE.erl index ce62017a7e..fe4f02f100 100644 --- a/lib/ssl/test/ssl_basic_SUITE.erl +++ b/lib/ssl/test/ssl_basic_SUITE.erl @@ -164,7 +164,10 @@ api_tests() -> accept_pool, prf, socket_options, - cipher_suites + cipher_suites, + handshake_continue, + hello_client_cancel, + hello_server_cancel ]. api_tests_tls() -> @@ -194,6 +197,7 @@ renegotiate_tests() -> [client_renegotiate, server_renegotiate, client_secure_renegotiate, + client_secure_renegotiate_fallback, client_renegotiate_reused_session, server_renegotiate_reused_session, client_no_wrap_sequence_number, @@ -214,6 +218,8 @@ cipher_tests() -> ciphers_rsa_signed_certs_openssl_names, ciphers_dsa_signed_certs, ciphers_dsa_signed_certs_openssl_names, + chacha_rsa_cipher_suites, + chacha_ecdsa_cipher_suites, anonymous_cipher_suites, psk_cipher_suites, psk_with_hint_cipher_suites, @@ -288,6 +294,7 @@ init_per_group(GroupName, Config) when GroupName == basic_tls; -> ssl_test_lib:clean_tls_version(Config); init_per_group(GroupName, Config) -> + ssl_test_lib:clean_tls_version(Config), case ssl_test_lib:is_tls_version(GroupName) andalso ssl_test_lib:sufficient_crypto_support(GroupName) of true -> ssl_test_lib:init_tls_version(GroupName, Config); @@ -626,6 +633,84 @@ new_options_in_accept(Config) when is_list(Config) -> ssl_test_lib:close(Server), ssl_test_lib:close(Client). + +%%-------------------------------------------------------------------- +handshake_continue() -> + [{doc, "Test API function ssl:handshake_continue/3"}]. +handshake_continue(Config) when is_list(Config) -> + ClientOpts = ssl_test_lib:ssl_options(client_verification_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()}, + {mfa, {ssl_test_lib, send_recv_result_active, []}}, + {options, ssl_test_lib:ssl_options([{reuseaddr, true}, {handshake, hello}], + Config)}, + {continue_options, proplists:delete(reuseaddr, ServerOpts)} + ]), + + Port = ssl_test_lib:inet_port(Server), + + Client = ssl_test_lib:start_client([{node, ClientNode}, {port, Port}, + {host, Hostname}, + {from, self()}, + {mfa, {ssl_test_lib, send_recv_result_active, []}}, + {options, ssl_test_lib:ssl_options([{handshake, hello}], + Config)}, + {continue_options, proplists:delete(reuseaddr, ClientOpts)}]), + + ssl_test_lib:check_result(Server, ok, Client, ok), + + ssl_test_lib:close(Server), + ssl_test_lib:close(Client). + +%%-------------------------------------------------------------------- +hello_client_cancel() -> + [{doc, "Test API function ssl:handshake_cancel/1 on the client side"}]. +hello_client_cancel(Config) when is_list(Config) -> + ServerOpts = ssl_test_lib:ssl_options(server_verification_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()}, + {options, ssl_test_lib:ssl_options([{handshake, hello}], Config)}, + {continue_options, proplists:delete(reuseaddr, ServerOpts)}]), + + Port = ssl_test_lib:inet_port(Server), + + %% That is ssl:handshake_cancel returns ok + {connect_failed, ok} = ssl_test_lib:start_client([{node, ClientNode}, {port, Port}, + {host, Hostname}, + {from, self()}, + {options, ssl_test_lib:ssl_options([{handshake, hello}], Config)}, + {continue_options, cancel}]), + + ssl_test_lib:check_result(Server, {error, {tls_alert, "user canceled"}}). +%%-------------------------------------------------------------------- + +hello_server_cancel() -> + [{doc, "Test API function ssl:handshake_cancel/1 on the server side"}]. +hello_server_cancel(Config) when is_list(Config) -> + ClientOpts = ssl_test_lib:ssl_options(client_verification_opts, Config), + {ClientNode, ServerNode, Hostname} = ssl_test_lib:run_where(Config), + + Server = ssl_test_lib:start_server([{node, ServerNode}, {port, 0}, + {from, self()}, + {options, ssl_test_lib:ssl_options([{handshake, hello}], Config)}, + {continue_options, cancel}]), + + Port = ssl_test_lib:inet_port(Server), + + {connect_failed, _} = ssl_test_lib:start_client([{node, ClientNode}, {port, Port}, + {host, Hostname}, + {from, self()}, + {options, ssl_test_lib:ssl_options([{handshake, hello}], Config)}, + {continue_options, proplists:delete(reuseaddr, ClientOpts)}]), + + ssl_test_lib:check_result(Server, ok). + %%-------------------------------------------------------------------- prf() -> [{doc,"Test that ssl:prf/5 uses the negotiated PRF."}]. @@ -665,7 +750,7 @@ connection_info(Config) when is_list(Config) -> {from, self()}, {mfa, {?MODULE, connection_info_result, []}}, {options, - [{ciphers,[{rsa, aes_128_cbc, sha}]} | + [{ciphers,[{dhe_rsa, aes_128_cbc, sha}]} | ClientOpts]}]), ct:log("Testcase ~p, Client ~p Server ~p ~n", @@ -673,7 +758,7 @@ connection_info(Config) when is_list(Config) -> Version = ssl_test_lib:protocol_version(Config), - ServerMsg = ClientMsg = {ok, {Version, {rsa, aes_128_cbc, sha}}}, + ServerMsg = ClientMsg = {ok, {Version, {dhe_rsa, aes_128_cbc, sha}}}, ssl_test_lib:check_result(Server, ServerMsg, Client, ClientMsg), @@ -959,7 +1044,7 @@ controller_dies(Config) when is_list(Config) -> {mfa, {?MODULE, controller_dies_result, [self(), ClientMsg]}}, - {options, [{reuseaddr,true}|ClientOpts]}]), + {options, ClientOpts}]), ct:sleep(?SLEEP), %% so that they are connected exit(Server, killed), @@ -984,7 +1069,7 @@ tls_client_closes_socket(Config) when is_list(Config) -> Connect = fun() -> {ok, _Socket} = rpc:call(ClientNode, gen_tcp, connect, - [Hostname, Port, TcpOpts]), + [Hostname, Port, [binary]]), %% Make sure that ssl_accept is called before %% client process ends and closes socket. ct:sleep(?SLEEP) @@ -1293,6 +1378,14 @@ cipher_suites() -> " and prepend|append_cipher_suites/2"}]. cipher_suites(Config) when is_list(Config) -> + MandatoryCipherSuiteTLS1_0TLS1_1 = #{key_exchange => rsa, + cipher => '3des_ede_cbc', + mac => sha, + prf => default_prf}, + MandatoryCipherSuiteTLS1_0TLS1_2 = #{key_exchange =>rsa, + cipher => 'aes_128_cbc', + mac => sha, + prf => default_prf}, Version = ssl_test_lib:protocol_version(Config), All = [_|_] = ssl:cipher_suites(all, Version), Default = [_|_] = ssl:cipher_suites(default, Version), @@ -1334,8 +1427,9 @@ cipher_suites(Config) when is_list(Config) -> true = lists:member(Cipher, Default), false = lists:member(Cipher, Rest1), [] = lists:dropwhile(fun(X) -> not lists:member(X, Default) end, Anonymous), - [] = lists:dropwhile(fun(X) -> not lists:member(X, All) end, Anonymous). - + [] = lists:dropwhile(fun(X) -> not lists:member(X, All) end, Anonymous), + true = lists:member(MandatoryCipherSuiteTLS1_0TLS1_1, All), + true = lists:member(MandatoryCipherSuiteTLS1_0TLS1_2, All). %%-------------------------------------------------------------------- @@ -1343,18 +1437,18 @@ old_cipher_suites() -> [{doc,"Test API function cipher_suites/0"}]. old_cipher_suites(Config) when is_list(Config) -> - MandatoryCipherSuite = {rsa,'3des_ede_cbc',sha}, + MandatoryCipherSuite = {rsa, '3des_ede_cbc', sha}, [_|_] = Suites = ssl:cipher_suites(), - true = lists:member(MandatoryCipherSuite, Suites), Suites = ssl:cipher_suites(erlang), - [_|_] =ssl:cipher_suites(openssl). + [_|_] = ssl:cipher_suites(openssl), + true = lists:member(MandatoryCipherSuite, ssl:cipher_suites(all)). %%-------------------------------------------------------------------- cipher_suites_mix() -> [{doc,"Test to have old and new cipher suites at the same time"}]. cipher_suites_mix(Config) when is_list(Config) -> - CipherSuites = [{ecdh_rsa,aes_128_cbc,sha256,sha256}, {rsa,aes_128_cbc,sha}], + CipherSuites = [{dhe_rsa,aes_128_cbc,sha256,sha256}, {dhe_rsa,aes_128_cbc,sha}], ClientOpts = ssl_test_lib:ssl_options(client_verification_opts, Config), ServerOpts = ssl_test_lib:ssl_options(server_verification_opts, Config), @@ -1799,7 +1893,7 @@ tls_send_close(Config) when is_list(Config) -> {options, [{active, false} | ServerOpts]}]), Port = ssl_test_lib:inet_port(Server), {ok, TcpS} = rpc:call(ClientNode, gen_tcp, connect, - [Hostname,Port,[binary, {active, false}, {reuseaddr, true}]]), + [Hostname,Port,[binary, {active, false}]]), {ok, SslS} = rpc:call(ClientNode, ssl, connect, [TcpS,[{active, false}|ClientOpts]]), @@ -1943,7 +2037,7 @@ tls_upgrade(Config) when is_list(Config) -> {host, Hostname}, {from, self()}, {mfa, {?MODULE, upgrade_result, []}}, - {tcp_options, TcpOpts}, + {tcp_options, [binary]}, {ssl_options, ClientOpts}]), ct:log("Testcase ~p, Client ~p Server ~p ~n", @@ -2422,7 +2516,24 @@ ciphers_dsa_signed_certs_openssl_names() -> ciphers_dsa_signed_certs_openssl_names(Config) when is_list(Config) -> Ciphers = ssl_test_lib:openssl_dsa_suites(), run_suites(Ciphers, Config, dsa). + %%------------------------------------------------------------------- +chacha_rsa_cipher_suites()-> + [{doc,"Test the cacha with ECDSA signed certs ciphersuites"}]. +chacha_rsa_cipher_suites(Config) when is_list(Config) -> + NVersion = ssl_test_lib:protocol_version(Config, tuple), + Ciphers = [S || {KeyEx,_,_} = S <- ssl_test_lib:chacha_suites(NVersion), + KeyEx == ecdhe_rsa, KeyEx == dhe_rsa], + run_suites(Ciphers, Config, chacha_ecdsa). + +%%------------------------------------------------------------------- +chacha_ecdsa_cipher_suites()-> + [{doc,"Test the cacha with ECDSA signed certs ciphersuites"}]. +chacha_ecdsa_cipher_suites(Config) when is_list(Config) -> + NVersion = ssl_test_lib:protocol_version(Config, tuple), + Ciphers = [S || {ecdhe_ecdsa,_,_} = S <- ssl_test_lib:chacha_suites(NVersion)], + run_suites(Ciphers, Config, chacha_rsa). +%%----------------------------------------------------------------- anonymous_cipher_suites()-> [{doc,"Test the anonymous ciphersuites"}]. anonymous_cipher_suites(Config) when is_list(Config) -> @@ -2502,14 +2613,15 @@ rc4_ecdsa_cipher_suites(Config) when is_list(Config) -> des_rsa_cipher_suites()-> [{doc, "Test the des_rsa ciphersuites"}]. des_rsa_cipher_suites(Config) when is_list(Config) -> - Ciphers = ssl_test_lib:des_suites(Config), + NVersion = tls_record:highest_protocol_version([]), + Ciphers = [S || {rsa,_,_} = S <- ssl_test_lib:des_suites(NVersion)], run_suites(Ciphers, Config, des_rsa). %------------------------------------------------------------------- des_ecdh_rsa_cipher_suites()-> [{doc, "Test ECDH rsa signed ciphersuites"}]. des_ecdh_rsa_cipher_suites(Config) when is_list(Config) -> NVersion = ssl_test_lib:protocol_version(Config, tuple), - Ciphers = ssl_test_lib:des_suites(NVersion), + Ciphers = [S || {dhe_rsa,_,_} = S <- ssl_test_lib:des_suites(NVersion)], run_suites(Ciphers, Config, des_dhe_rsa). %%-------------------------------------------------------------------- @@ -2869,6 +2981,36 @@ client_secure_renegotiate(Config) when is_list(Config) -> ssl_test_lib:close(Server), ssl_test_lib:close(Client). +%%-------------------------------------------------------------------- +client_secure_renegotiate_fallback() -> + [{doc,"Test that we can set secure_renegotiate to false that is " + "fallback option, we however do not have a insecure server to test against!"}]. +client_secure_renegotiate_fallback(Config) when is_list(Config) -> + ServerOpts = ssl_test_lib:ssl_options(server_opts, Config), + ClientOpts = ssl_test_lib:ssl_options(client_opts, Config), + + {ClientNode, ServerNode, Hostname} = ssl_test_lib:run_where(Config), + + Data = "From erlang to erlang", + + Server = + ssl_test_lib:start_server([{node, ServerNode}, {port, 0}, + {from, self()}, + {mfa, {?MODULE, erlang_ssl_receive, [Data]}}, + {options, [{secure_renegotiate, false} | ServerOpts]}]), + Port = ssl_test_lib:inet_port(Server), + + Client = ssl_test_lib:start_client([{node, ClientNode}, {port, Port}, + {host, Hostname}, + {from, self()}, + {mfa, {?MODULE, + renegotiate, [Data]}}, + {options, [{reuse_sessions, false}, + {secure_renegotiate, false}| ClientOpts]}]), + + ssl_test_lib:check_result(Client, ok, Server, ok), + ssl_test_lib:close(Server), + ssl_test_lib:close(Client). %%-------------------------------------------------------------------- server_renegotiate() -> @@ -3202,18 +3344,25 @@ no_reuses_session_server_restart_new_cert_file(Config) when is_list(Config) -> %%-------------------------------------------------------------------- defaults(Config) when is_list(Config)-> - [_, - {supported, Supported}, - {available, Available}] - = ssl:versions(), - true = lists:member(sslv3, Available), - false = lists:member(sslv3, Supported), + Versions = ssl:versions(), + true = lists:member(sslv3, proplists:get_value(available, Versions)), + false = lists:member(sslv3, proplists:get_value(supported, Versions)), + true = lists:member('tlsv1', proplists:get_value(available, Versions)), + true = lists:member('tlsv1', proplists:get_value(supported, Versions)), + true = lists:member('tlsv1.1', proplists:get_value(available, Versions)), + true = lists:member('tlsv1.1', proplists:get_value(supported, Versions)), + true = lists:member('tlsv1.2', proplists:get_value(available, Versions)), + true = lists:member('tlsv1.2', proplists:get_value(supported, Versions)), false = lists:member({rsa,rc4_128,sha}, ssl:cipher_suites()), true = lists:member({rsa,rc4_128,sha}, ssl:cipher_suites(all)), false = lists:member({rsa,des_cbc,sha}, ssl:cipher_suites()), true = lists:member({rsa,des_cbc,sha}, ssl:cipher_suites(all)), false = lists:member({dhe_rsa,des_cbc,sha}, ssl:cipher_suites()), - true = lists:member({dhe_rsa,des_cbc,sha}, ssl:cipher_suites(all)). + true = lists:member({dhe_rsa,des_cbc,sha}, ssl:cipher_suites(all)), + true = lists:member('dtlsv1.2', proplists:get_value(available_dtls, Versions)), + true = lists:member('dtlsv1', proplists:get_value(available_dtls, Versions)), + true = lists:member('dtlsv1.2', proplists:get_value(supported_dtls, Versions)), + true = lists:member('dtlsv1', proplists:get_value(supported_dtls, Versions)). %%-------------------------------------------------------------------- reuseaddr() -> @@ -3299,16 +3448,16 @@ tls_tcp_reuseaddr(Config) when is_list(Config) -> honor_server_cipher_order() -> [{doc,"Test API honor server cipher order."}]. honor_server_cipher_order(Config) when is_list(Config) -> - ClientCiphers = [{rsa, aes_128_cbc, sha}, {rsa, aes_256_cbc, sha}], - ServerCiphers = [{rsa, aes_256_cbc, sha}, {rsa, aes_128_cbc, sha}], -honor_cipher_order(Config, true, ServerCiphers, ClientCiphers, {rsa, aes_256_cbc, sha}). + ClientCiphers = [{dhe_rsa, aes_128_cbc, sha}, {dhe_rsa, aes_256_cbc, sha}], + ServerCiphers = [{dhe_rsa, aes_256_cbc, sha}, {dhe_rsa, aes_128_cbc, sha}], +honor_cipher_order(Config, true, ServerCiphers, ClientCiphers, {dhe_rsa, aes_256_cbc, sha}). honor_client_cipher_order() -> [{doc,"Test API honor server cipher order."}]. honor_client_cipher_order(Config) when is_list(Config) -> - ClientCiphers = [{rsa, aes_128_cbc, sha}, {rsa, aes_256_cbc, sha}], - ServerCiphers = [{rsa, aes_256_cbc, sha}, {rsa, aes_128_cbc, sha}], -honor_cipher_order(Config, false, ServerCiphers, ClientCiphers, {rsa, aes_128_cbc, sha}). + ClientCiphers = [{dhe_rsa, aes_128_cbc, sha}, {dhe_rsa, aes_256_cbc, sha}], + ServerCiphers = [{dhe_rsa, aes_256_cbc, sha}, {dhe_rsa, aes_128_cbc, sha}], +honor_cipher_order(Config, false, ServerCiphers, ClientCiphers, {dhe_rsa, aes_128_cbc, sha}). honor_cipher_order(Config, Honor, ServerCiphers, ClientCiphers, Expected) -> ClientOpts = ssl_test_lib:ssl_options(client_opts, Config), @@ -3364,7 +3513,7 @@ tls_ciphersuite_vs_version(Config) when is_list(Config) -> >>), {ok, <<22, RecMajor:8, RecMinor:8, _RecLen:16, 2, HelloLen:24>>} = gen_tcp:recv(Socket, 9, 10000), {ok, <<HelloBin:HelloLen/binary>>} = gen_tcp:recv(Socket, HelloLen, 5000), - ServerHello = tls_handshake:decode_handshake({RecMajor, RecMinor}, 2, HelloBin, false), + ServerHello = tls_handshake:decode_handshake({RecMajor, RecMinor}, 2, HelloBin), case ServerHello of #server_hello{server_version = {3,0}, cipher_suite = <<0,57>>} -> ok; @@ -4709,38 +4858,39 @@ client_server_opts(#{key_exchange := KeyAlgo}, Config) when KeyAlgo == ecdh_rsa ssl_test_lib:ssl_options(server_ecdh_rsa_opts, Config)}. run_suites(Ciphers, Config, Type) -> - NVersion = ssl_test_lib:protocol_version(Config, tuple), Version = ssl_test_lib:protocol_version(Config), ct:log("Running cipher suites ~p~n", [Ciphers]), {ClientOpts, ServerOpts} = case Type of rsa -> {ssl_test_lib:ssl_options(client_verification_opts, Config), - ssl_test_lib:ssl_options(server_verification_opts, Config)}; + [{ciphers, Ciphers} | + ssl_test_lib:ssl_options(server_verification_opts, Config)]}; dsa -> {ssl_test_lib:ssl_options(client_verification_opts, Config), - ssl_test_lib:ssl_options(server_dsa_opts, Config)}; + [{ciphers, Ciphers} | + ssl_test_lib:ssl_options(server_dsa_opts, Config)]}; anonymous -> %% No certs in opts! {ssl_test_lib:ssl_options(client_verification_opts, Config), - [{reuseaddr, true}, {ciphers, ssl_test_lib:anonymous_suites(NVersion)} | + [{ciphers, Ciphers} | ssl_test_lib:ssl_options([], Config)]}; psk -> {ssl_test_lib:ssl_options(client_psk, Config), - [{ciphers, ssl_test_lib:psk_suites(NVersion)} | + [{ciphers, Ciphers} | ssl_test_lib:ssl_options(server_psk, Config)]}; psk_with_hint -> {ssl_test_lib:ssl_options(client_psk, Config), - [{ciphers, ssl_test_lib:psk_suites(NVersion)} | + [{ciphers, Ciphers} | ssl_test_lib:ssl_options(server_psk_hint, Config) ]}; psk_anon -> {ssl_test_lib:ssl_options(client_psk, Config), - [{ciphers, ssl_test_lib:psk_anon_suites(NVersion)} | + [{ciphers, Ciphers} | ssl_test_lib:ssl_options(server_psk_anon, Config)]}; psk_anon_with_hint -> {ssl_test_lib:ssl_options(client_psk, Config), - [{ciphers, ssl_test_lib:psk_anon_suites(NVersion)} | + [{ciphers, Ciphers} | ssl_test_lib:ssl_options(server_psk_anon_hint, Config)]}; srp -> {ssl_test_lib:ssl_options(client_srp, Config), @@ -4753,7 +4903,8 @@ run_suites(Ciphers, Config, Type) -> ssl_test_lib:ssl_options(server_srp_dsa, Config)}; ecdsa -> {ssl_test_lib:ssl_options(client_verification_opts, Config), - ssl_test_lib:ssl_options(server_ecdsa_opts, Config)}; + [{ciphers, Ciphers} | + ssl_test_lib:ssl_options(server_ecdsa_opts, Config)]}; ecdh_rsa -> {ssl_test_lib:ssl_options(client_verification_opts, Config), ssl_test_lib:ssl_options(server_ecdh_rsa_opts, Config)}; @@ -4776,9 +4927,16 @@ run_suites(Ciphers, Config, Type) -> des_rsa -> {ssl_test_lib:ssl_options(client_verification_opts, Config), [{ciphers, Ciphers} | - ssl_test_lib:ssl_options(server_verification_opts, Config)]} + ssl_test_lib:ssl_options(server_verification_opts, Config)]}; + chacha_rsa -> + {ssl_test_lib:ssl_options(client_verification_opts, Config), + [{ciphers, Ciphers} | + ssl_test_lib:ssl_options(server_verification_opts, Config)]}; + chacha_ecdsa -> + {ssl_test_lib:ssl_options(client_verification_opts, Config), + [{ciphers, Ciphers} | + ssl_test_lib:ssl_options(server_ecdsa_opts, Config)]} end, - Result = lists:map(fun(Cipher) -> cipher(Cipher, Version, Config, ClientOpts, ServerOpts) end, ssl_test_lib:filter_suites(Ciphers, Version)), diff --git a/lib/ssl/test/ssl_bench.spec b/lib/ssl/test/ssl_bench.spec index d2f75b4203..8b746c5ca9 100644 --- a/lib/ssl/test/ssl_bench.spec +++ b/lib/ssl/test/ssl_bench.spec @@ -1 +1 @@ -{suites,"../ssl_test",[ssl_bench_SUITE]}. +{suites,"../ssl_test",[ssl_bench_SUITE, ssl_dist_bench_SUITE]}. diff --git a/lib/ssl/test/ssl_bench_SUITE.erl b/lib/ssl/test/ssl_bench_SUITE.erl index ae2928b1c3..3fe6338d69 100644 --- a/lib/ssl/test/ssl_bench_SUITE.erl +++ b/lib/ssl/test/ssl_bench_SUITE.erl @@ -40,11 +40,11 @@ end_per_group(_GroupName, _Config) -> ok. init_per_suite(Config) -> - try - Server = setup(ssl, node()), - [{server_node, Server}|Config] - catch _:_ -> - {skipped, "Benchmark machines only"} + case node() of + nonode@nohost -> + {skipped, "Node not distributed"}; + _ -> + [{server_node, ssl_bench_test_lib:setup(perf_server)}|Config] end. end_per_suite(_Config) -> @@ -132,10 +132,10 @@ bypass_pem_cache(_Config) -> ssl() -> - test(ssl, ?COUNT, node()). + test(ssl, ?COUNT). -test(Type, Count, Host) -> - Server = setup(Type, Host), +test(Type, Count) -> + Server = ssl_bench_test_lib:setup(perf_server), (do_test(Type, setup_connection, Count * 20, 1, Server)), (do_test(Type, setup_connection, Count, 100, Server)), (do_test(Type, payload, Count*300, 10, Server)), @@ -294,47 +294,6 @@ msg() -> "asdlkjsafsdfoierwlejsdlkfjsdf">>. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -setup(_Type, nonode@nohost) -> - exit(dist_not_enabled); -setup(Type, _This) -> - Host = case os:getenv(?remote_host) of - false -> - {ok, This} = inet:gethostname(), - This; - RemHost -> - RemHost - end, - Node = list_to_atom("perf_server@" ++ Host), - SlaveArgs = case init:get_argument(pa) of - {ok, PaPaths} -> - lists:append([" -pa " ++ P || [P] <- PaPaths]); - _ -> [] - end, - %% io:format("Slave args: ~p~n",[SlaveArgs]), - Prog = - case os:find_executable("erl") of - false -> "erl"; - P -> P - end, - io:format("Prog = ~p~n", [Prog]), - - case net_adm:ping(Node) of - pong -> ok; - pang -> - {ok, Node} = slave:start(Host, perf_server, SlaveArgs, no_link, Prog) - end, - Path = code:get_path(), - true = rpc:call(Node, code, set_path, [Path]), - ok = rpc:call(Node, ?MODULE, setup_server, [Type, node()]), - io:format("Client (~p) using ~s~n",[node(), code:which(ssl)]), - (Node =:= node()) andalso restrict_schedulers(client), - Node. - -setup_server(_Type, ClientNode) -> - (ClientNode =:= node()) andalso restrict_schedulers(server), - io:format("Server (~p) using ~s~n",[node(), code:which(ssl)]), - ok. - ensure_all_started(App, Ack) -> case application:start(App) of @@ -358,13 +317,6 @@ setup_server_init(Type, Tc, Loop, PC) -> unlink(Pid), Res. -restrict_schedulers(Type) -> - %% We expect this to run on 8 core machine - Extra0 = 1, - Extra = if (Type =:= server) -> -Extra0; true -> Extra0 end, - Scheds = erlang:system_info(schedulers), - erlang:system_flag(schedulers_online, (Scheds div 2) + Extra). - tc(Fun, Mod, Line) -> case timer:tc(Fun) of {_,{'EXIT',Reason}} -> diff --git a/lib/ssl/test/ssl_bench_test_lib.erl b/lib/ssl/test/ssl_bench_test_lib.erl new file mode 100644 index 0000000000..e5cbb911bd --- /dev/null +++ b/lib/ssl/test/ssl_bench_test_lib.erl @@ -0,0 +1,75 @@ +%%%------------------------------------------------------------------- +%% %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% +%% +-module(ssl_bench_test_lib). + +%% API +-export([setup/1]). + +%% Internal exports +-export([setup_server/1]). + +-define(remote_host, "NETMARKS_REMOTE_HOST"). + +setup(Name) -> + Host = case os:getenv(?remote_host) of + false -> + {ok, This} = inet:gethostname(), + This; + RemHost -> + RemHost + end, + Node = list_to_atom(atom_to_list(Name) ++ "@" ++ Host), + SlaveArgs = case init:get_argument(pa) of + {ok, PaPaths} -> + lists:append([" -pa " ++ P || [P] <- PaPaths]); + _ -> [] + end, + %% io:format("Slave args: ~p~n",[SlaveArgs]), + Prog = + case os:find_executable("erl") of + false -> "erl"; + P -> P + end, + io:format("Prog = ~p~n", [Prog]), + + case net_adm:ping(Node) of + pong -> ok; + pang -> + {ok, Node} = + slave:start(Host, Name, SlaveArgs, no_link, Prog) + end, + Path = code:get_path(), + true = rpc:call(Node, code, set_path, [Path]), + ok = rpc:call(Node, ?MODULE, setup_server, [node()]), + io:format("Client (~p) using ~s~n",[node(), code:which(ssl)]), + (Node =:= node()) andalso restrict_schedulers(client), + Node. + +setup_server(ClientNode) -> + (ClientNode =:= node()) andalso restrict_schedulers(server), + io:format("Server (~p) using ~s~n",[node(), code:which(ssl)]), + ok. + +restrict_schedulers(Type) -> + %% We expect this to run on 8 core machine + Extra0 = 1, + Extra = if (Type =:= server) -> -Extra0; true -> Extra0 end, + Scheds = erlang:system_info(schedulers), + erlang:system_flag(schedulers_online, (Scheds div 2) + Extra). diff --git a/lib/ssl/test/ssl_dist_SUITE.erl b/lib/ssl/test/ssl_dist_SUITE.erl index 8740e8c8f0..c822a52d1f 100644 --- a/lib/ssl/test/ssl_dist_SUITE.erl +++ b/lib/ssl/test/ssl_dist_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2007-2016. All Rights Reserved. +%% Copyright Ericsson AB 2007-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. @@ -22,6 +22,7 @@ -include_lib("common_test/include/ct.hrl"). -include_lib("public_key/include/public_key.hrl"). +-include("ssl_dist_test_lib.hrl"). %% Note: This directive should only be used in test suites. -compile(export_all). @@ -30,12 +31,12 @@ -define(AWAIT_SSL_NODE_UP_TIMEOUT, 30000). --record(node_handle, - {connection_handler, - socket, - name, - nodename} - ). +-import(ssl_dist_test_lib, + [tstsrvr_format/2, send_to_tstcntrl/1, + apply_on_ssl_node/4, apply_on_ssl_node/2, + stop_ssl_node/1]). +start_ssl_node_name(Name, Args) -> + ssl_dist_test_lib:start_ssl_node(Name, Args). %%-------------------------------------------------------------------- %% Common Test interface functions ----------------------------------- @@ -140,11 +141,14 @@ basic_test(NH1, NH2, _) -> apply_on_ssl_node( NH1, fun () -> - tstsrvr_format("Hi from ~p!~n", [node()]), - send_to_tstcntrl({Ref, self()}), + tstsrvr_format( + "Hi from ~p!~n", [node()]), + send_to_tstcntrl( + {Ref, self()}), receive {From, ping} -> - tstsrvr_format("Received ping ~p!~n", [node()]), + tstsrvr_format( + "Received ping ~p!~n", [node()]), From ! {self(), pong} end end) @@ -154,7 +158,8 @@ basic_test(NH1, NH2, _) -> ok = apply_on_ssl_node( NH2, fun () -> - tstsrvr_format("Hi from ~p!~n", [node()]), + tstsrvr_format( + "Hi from ~p!~n", [node()]), SslPid ! {self(), ping}, receive {SslPid, pong} -> @@ -183,7 +188,8 @@ payload_test(NH1, NH2, _) -> apply_on_ssl_node( NH1, fun () -> - send_to_tstcntrl({Ref, self()}), + send_to_tstcntrl( + {Ref, self()}), receive {From, Msg} -> From ! {self(), Msg} @@ -616,12 +622,6 @@ gen_dist_test(Test, Config) -> %% ssl_node side api %% -tstsrvr_format(Fmt, ArgList) -> - send_to_tstsrvr({format, Fmt, ArgList}). - -send_to_tstcntrl(Message) -> - send_to_tstsrvr({message, Message}). - try_setting_priority(TestFun, Config) -> Prio = 1, case gen_udp:open(0, [{priority,Prio}]) of @@ -653,44 +653,6 @@ inet_ports() -> %% test_server side api %% -apply_on_ssl_node(Node, M, F, A) when is_atom(M), is_atom(F), is_list(A) -> - Ref = make_ref(), - send_to_ssl_node(Node, {apply, self(), Ref, M, F, A}), - receive - {Ref, Result} -> - Result - end. - -apply_on_ssl_node(Node, Fun) when is_function(Fun, 0) -> - Ref = make_ref(), - send_to_ssl_node(Node, {apply, self(), Ref, Fun}), - receive - {Ref, Result} -> - Result - end. - -stop_ssl_node(#node_handle{connection_handler = Handler, - socket = Socket, - name = Name}) -> - ?t:format("Trying to stop ssl node ~s.~n", [Name]), - Mon = erlang:monitor(process, Handler), - unlink(Handler), - case gen_tcp:send(Socket, term_to_binary(stop)) of - ok -> - receive - {'DOWN', Mon, process, Handler, Reason} -> - case Reason of - normal -> - ok; - _ -> - ct:pal("Down ~p ~n", [Reason]) - end - end; - Error -> - erlang:demonitor(Mon, [flush]), - ct:pal("Warning ~p ~n", [Error]) - end. - start_ssl_node(Config) -> start_ssl_node(Config, ""). @@ -698,29 +660,8 @@ start_ssl_node(Config, XArgs) -> Name = mk_node_name(Config), SSL = proplists:get_value(ssl_opts, Config), SSLDistOpts = setup_dist_opts(Config), - start_ssl_node_raw(Name, SSL ++ " " ++ SSLDistOpts ++ XArgs). - -start_ssl_node_raw(Name, Args) -> - {ok, LSock} = gen_tcp:listen(0, - [binary, {packet, 4}, {active, false}]), - {ok, ListenPort} = inet:port(LSock), - CmdLine = mk_node_cmdline(ListenPort, Name, Args), - ?t:format("Attempting to start ssl node ~ts: ~ts~n", [Name, CmdLine]), - case open_port({spawn, CmdLine}, []) of - Port when is_port(Port) -> - unlink(Port), - erlang:port_close(Port), - case await_ssl_node_up(Name, LSock) of - #node_handle{} = NodeHandle -> - ?t:format("Ssl node ~s started.~n", [Name]), - NodeName = list_to_atom(Name ++ "@" ++ host_name()), - NodeHandle#node_handle{nodename = NodeName}; - Error -> - exit({failed_to_start_node, Name, Error}) - end; - Error -> - exit({failed_to_start_node, Name, Error}) - end. + start_ssl_node_name( + Name, SSL ++ " " ++ SSLDistOpts ++ XArgs). cache_crls_on_ssl_nodes(PrivDir, CANames, NHs) -> [begin @@ -739,11 +680,6 @@ cache_crls_on_ssl_nodes(PrivDir, CANames, NHs) -> %% command line creation %% -host_name() -> - [$@ | Host] = lists:dropwhile(fun ($@) -> false; (_) -> true end, - atom_to_list(node())), - Host. - mk_node_name(Config) -> N = erlang:unique_integer([positive]), Case = proplists:get_value(testcase, Config), @@ -753,225 +689,6 @@ mk_node_name(Config) -> ++ "_" ++ integer_to_list(N). -mk_node_cmdline(ListenPort, Name, Args) -> - Static = "-detached -noinput", - Pa = filename:dirname(code:which(?MODULE)), - Prog = case catch init:get_argument(progname) of - {ok,[[P]]} -> P; - _ -> exit(no_progname_argument_found) - end, - NameSw = case net_kernel:longnames() of - false -> "-sname "; - _ -> "-name " - end, - {ok, Pwd} = file:get_cwd(), - "\"" ++ Prog ++ "\" " - ++ Static ++ " " - ++ NameSw ++ " " ++ Name ++ " " - ++ "-pa " ++ Pa ++ " " - ++ "-run application start crypto -run application start public_key " - ++ "-eval 'net_kernel:verbose(1)' " - ++ "-run " ++ atom_to_list(?MODULE) ++ " cnct2tstsrvr " - ++ host_name() ++ " " - ++ integer_to_list(ListenPort) ++ " " - ++ Args ++ " " - ++ "-env ERL_CRASH_DUMP " ++ Pwd ++ "/erl_crash_dump." ++ Name ++ " " - ++ "-kernel error_logger \"{file,\\\"" ++ Pwd ++ "/error_log." ++ Name ++ "\\\"}\" " - ++ "-setcookie " ++ atom_to_list(erlang:get_cookie()). - -%% -%% Connection handler test_server side -%% - -await_ssl_node_up(Name, LSock) -> - case gen_tcp:accept(LSock, ?AWAIT_SSL_NODE_UP_TIMEOUT) of - timeout -> - gen_tcp:close(LSock), - ?t:format("Timeout waiting for ssl node ~s to come up~n", - [Name]), - timeout; - {ok, Socket} -> - gen_tcp:close(LSock), - case gen_tcp:recv(Socket, 0) of - {ok, Bin} -> - check_ssl_node_up(Socket, Name, Bin); - {error, closed} -> - gen_tcp:close(Socket), - exit({lost_connection_with_ssl_node_before_up, Name}) - end; - {error, Error} -> - gen_tcp:close(LSock), - exit({accept_failed, Error}) - end. - -check_ssl_node_up(Socket, Name, Bin) -> - case catch binary_to_term(Bin) of - {'EXIT', _} -> - gen_tcp:close(Socket), - exit({bad_data_received_from_ssl_node, Name, Bin}); - {ssl_node_up, NodeName} -> - case list_to_atom(Name++"@"++host_name()) of - NodeName -> - Parent = self(), - Go = make_ref(), - %% Spawn connection handler on test server side - Pid = spawn_link( - fun () -> - receive Go -> ok end, - tstsrvr_con_loop(Name, Socket, Parent) - end), - ok = gen_tcp:controlling_process(Socket, Pid), - Pid ! Go, - #node_handle{connection_handler = Pid, - socket = Socket, - name = Name}; - _ -> - exit({unexpected_ssl_node_connected, NodeName}) - end; - Msg -> - exit({unexpected_msg_instead_of_ssl_node_up, Name, Msg}) - end. - -send_to_ssl_node(#node_handle{connection_handler = Hndlr}, Term) -> - Hndlr ! {relay_to_ssl_node, term_to_binary(Term)}, - ok. - -tstsrvr_con_loop(Name, Socket, Parent) -> - inet:setopts(Socket,[{active,once}]), - receive - {relay_to_ssl_node, Data} when is_binary(Data) -> - case gen_tcp:send(Socket, Data) of - ok -> - ok; - _Error -> - gen_tcp:close(Socket), - exit({failed_to_relay_data_to_ssl_node, Name, Data}) - end; - {tcp, Socket, Bin} -> - case catch binary_to_term(Bin) of - {'EXIT', _} -> - gen_tcp:close(Socket), - exit({bad_data_received_from_ssl_node, Name, Bin}); - {format, FmtStr, ArgList} -> - ?t:format(FmtStr, ArgList); - {message, Msg} -> - ?t:format("Got message ~p", [Msg]), - Parent ! Msg; - {apply_res, To, Ref, Res} -> - To ! {Ref, Res}; - bye -> - ?t:format("Ssl node ~s stopped.~n", [Name]), - gen_tcp:close(Socket), - exit(normal); - Unknown -> - exit({unexpected_message_from_ssl_node, Name, Unknown}) - end; - {tcp_closed, Socket} -> - gen_tcp:close(Socket), - exit({lost_connection_with_ssl_node, Name}) - end, - tstsrvr_con_loop(Name, Socket, Parent). - -%% -%% Connection handler ssl_node side -%% - -% cnct2tstsrvr() is called via command line arg -run ... -cnct2tstsrvr([Host, Port]) when is_list(Host), is_list(Port) -> - %% Spawn connection handler on ssl node side - ConnHandler - = spawn(fun () -> - case catch gen_tcp:connect(Host, - list_to_integer(Port), - [binary, - {packet, 4}, - {active, false}]) of - {ok, Socket} -> - notify_ssl_node_up(Socket), - ets:new(test_server_info, - [set, - public, - named_table, - {keypos, 1}]), - ets:insert(test_server_info, - {test_server_handler, self()}), - ssl_node_con_loop(Socket); - Error -> - halt("Failed to connect to test server " ++ - lists:flatten(io_lib:format("Host:~p ~n Port:~p~n Error:~p~n", - [Host, Port, Error]))) - end - end), - spawn(fun () -> - Mon = erlang:monitor(process, ConnHandler), - receive - {'DOWN', Mon, process, ConnHandler, Reason} -> - receive after 1000 -> ok end, - halt("test server connection handler terminated: " ++ - lists:flatten(io_lib:format("~p", [Reason]))) - end - end). - -notify_ssl_node_up(Socket) -> - case catch gen_tcp:send(Socket, - term_to_binary({ssl_node_up, node()})) of - ok -> ok; - _ -> halt("Failed to notify test server that I'm up") - end. - -send_to_tstsrvr(Term) -> - case catch ets:lookup_element(test_server_info, test_server_handler, 2) of - Hndlr when is_pid(Hndlr) -> - Hndlr ! {relay_to_test_server, term_to_binary(Term)}, ok; - _ -> - receive after 200 -> ok end, - send_to_tstsrvr(Term) - end. - -ssl_node_con_loop(Socket) -> - inet:setopts(Socket,[{active,once}]), - receive - {relay_to_test_server, Data} when is_binary(Data) -> - case gen_tcp:send(Socket, Data) of - ok -> - ok; - _Error -> - gen_tcp:close(Socket), - halt("Failed to relay data to test server") - end; - {tcp, Socket, Bin} -> - case catch binary_to_term(Bin) of - {'EXIT', _} -> - gen_tcp:close(Socket), - halt("test server sent me bad data"); - {apply, From, Ref, M, F, A} -> - spawn_link( - fun () -> - send_to_tstsrvr({apply_res, - From, - Ref, - (catch apply(M, F, A))}) - end); - {apply, From, Ref, Fun} -> - spawn_link(fun () -> - send_to_tstsrvr({apply_res, - From, - Ref, - (catch Fun())}) - end); - stop -> - gen_tcp:send(Socket, term_to_binary(bye)), - gen_tcp:close(Socket), - init:stop(), - receive after infinity -> ok end; - _Unknown -> - halt("test server sent me an unexpected message") - end; - {tcp_closed, Socket} -> - halt("Lost connection to test server") - end, - ssl_node_con_loop(Socket). - %% %% Setup ssl dist info %% diff --git a/lib/ssl/test/ssl_dist_bench_SUITE.erl b/lib/ssl/test/ssl_dist_bench_SUITE.erl new file mode 100644 index 0000000000..4d27564319 --- /dev/null +++ b/lib/ssl/test/ssl_dist_bench_SUITE.erl @@ -0,0 +1,481 @@ +%%%------------------------------------------------------------------- +%% %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% +%% +-module(ssl_dist_bench_SUITE). + +-include_lib("common_test/include/ct_event.hrl"). +-include_lib("public_key/include/public_key.hrl"). + +%% CT meta +-export([suite/0, all/0, groups/0, + init_per_suite/1, end_per_suite/1, + init_per_group/2, end_per_group/2, + init_per_testcase/2, end_per_testcase/2]). + +%% Test cases +-export( + [setup/1, + roundtrip/1, + throughput_1024/1, + throughput_4096/1, + throughput_16384/1, + throughput_65536/1, + throughput_262144/1, + throughput_1048576/1]). + +%% Debug +-export([payload/1]). + +%%%------------------------------------------------------------------- + +suite() -> [{ct_hooks, [{ts_install_cth, [{nodenames, 2}]}]}]. + +all() -> [{group, ssl}, {group, plain}]. + +groups() -> + [{ssl, all_groups()}, + {plain, all_groups()}, + %% + {setup, [{repeat, 1}], [setup]}, + {roundtrip, [{repeat, 1}], [roundtrip]}, + {throughput, [{repeat, 1}], + [throughput_1024, + throughput_4096, + throughput_16384, + throughput_65536, + throughput_262144, + throughput_1048576]}]. + +all_groups() -> + [{group, setup}, + {group, roundtrip}, + {group, throughput}]. + +init_per_suite(Config) -> + Digest = sha1, + ECCurve = secp521r1, + TLSVersion = 'tlsv1.2', + TLSCipher = {ecdhe_ecdsa,aes_128_cbc,sha256,sha256}, + %% + Node = node(), + try + Node =/= nonode@nohost orelse + throw({skipped,"Node not distributed"}), + {supported, SSLVersions} = + lists:keyfind(supported, 1, ssl:versions()), + lists:member(TLSVersion, SSLVersions) orelse + throw( + {skipped, + "SSL does not support " ++ term_to_string(TLSVersion)}), + lists:member(ECCurve, ssl:eccs(TLSVersion)) orelse + throw( + {skipped, + "SSL does not support " ++ term_to_string(ECCurve)}), + lists:member(TLSCipher, ssl:cipher_suites()) orelse + throw( + {skipped, + "SSL does not support " ++ term_to_string(TLSCipher)}) + of + _ -> + PrivDir = proplists:get_value(priv_dir, Config), + %% + [_, HostA] = string:split(atom_to_list(Node), "@"), + NodeAName = ?MODULE_STRING ++ "_node_a", + NodeAString = NodeAName ++ "@" ++ HostA, + NodeAConfFile = filename:join(PrivDir, NodeAString ++ ".conf"), + NodeA = list_to_atom(NodeAString), + %% + ServerNode = ssl_bench_test_lib:setup(dist_server), + [_, HostB] = string:split(atom_to_list(ServerNode), "@"), + NodeBName = ?MODULE_STRING ++ "_node_b", + NodeBString = NodeBName ++ "@" ++ HostB, + NodeBConfFile = filename:join(PrivDir, NodeBString ++ ".conf"), + NodeB = list_to_atom(NodeBString), + %% + CertOptions = + [{digest, Digest}, + {key, {namedCurve, ECCurve}}], + RootCert = + public_key:pkix_test_root_cert( + ?MODULE_STRING ++ " ROOT CA", CertOptions), + SSLConf = + [{verify, verify_peer}, + {versions, [TLSVersion]}, + {ciphers, [TLSCipher]}], + %% + write_node_conf( + NodeAConfFile, NodeA, + [{fail_if_no_peer_cert, true} | SSLConf], SSLConf, + CertOptions, RootCert), + write_node_conf( + NodeBConfFile, NodeB, + [{fail_if_no_peer_cert, true} | SSLConf], SSLConf, + CertOptions, RootCert), + %% + [{node_a_name, NodeAName}, + {node_a, NodeA}, + {node_a_dist_args, + "-proto_dist inet_tls " + "-ssl_dist_optfile " ++ NodeAConfFile ++ " "}, + {node_b_name, NodeBName}, + {node_b, NodeB}, + {node_b_dist_args, + "-proto_dist inet_tls " + "-ssl_dist_optfile " ++ NodeBConfFile ++ " "}, + {server_node, ServerNode} + |Config] + catch + throw:Result -> + Result + end. + +end_per_suite(Config) -> + ServerNode = proplists:get_value(server_node, Config), + slave:stop(ServerNode). + +init_per_group(ssl, Config) -> + [{ssl_dist, true}, {ssl_dist_prefix, "SSL"}|Config]; +init_per_group(plain, Config) -> + [{ssl_dist, false}, {ssl_dist_prefix, "Plain"}|Config]; +init_per_group(_GroupName, Config) -> + Config. + +end_per_group(_GroupName, _Config) -> + ok. + +init_per_testcase(_Func, Conf) -> + Conf. + +end_per_testcase(_Func, _Conf) -> + ok. + +-define(COUNT, 400). + +%%%------------------------------------------------------------------- +%%% CommonTest API helpers + +write_node_conf( + ConfFile, Node, ServerConf, ClientConf, CertOptions, RootCert) -> + Conf = + public_key:pkix_test_data( + #{root => RootCert, + peer => + [{extensions, + [#'Extension'{ + extnID = ?'id-ce-subjectAltName', + extnValue = [{dNSName, atom_to_list(Node)}], + critical = false}]} | CertOptions]}), + NodeConf = + [{server, ServerConf ++ Conf}, {client, ClientConf ++ Conf}], + {ok, Fd} = file:open(ConfFile, [write]), + ok = file:change_mode(ConfFile, 8#400), + io:format(Fd, "~p.~n", [NodeConf]), + ok = file:close(Fd). + + +%%%------------------------------------------------------------------- +%%% Test cases + +%%----------------------- +%% Connection setup speed + +setup(Config) -> + run_nodepair_test(fun setup/5, Config). + +setup(A, B, Prefix, HA, HB) -> + Rounds = 10, + [] = ssl_apply(HA, erlang, nodes, []), + [] = ssl_apply(HB, erlang, nodes, []), + {SetupTime, CycleTime} = + ssl_apply(HA, fun () -> setup_runner(A, B, Rounds) end), + [] = ssl_apply(HA, erlang, nodes, []), + [] = ssl_apply(HB, erlang, nodes, []), + SetupSpeed = round((Rounds*1000000*1000) / SetupTime), + CycleSpeed = round((Rounds*1000000*1000) / CycleTime), + _ = report(Prefix++" Setup", SetupSpeed, "setups/1000s"), + report(Prefix++" Setup Cycle", CycleSpeed, "cycles/1000s"). + +%% Runs on node A against rex in node B +setup_runner(A, B, Rounds) -> + StartTime = start_time(), + SetupTime = setup_loop(A, B, 0, Rounds), + {microseconds(SetupTime), microseconds(elapsed_time(StartTime))}. + +setup_loop(_A, _B, T, 0) -> + T; +setup_loop(A, B, T, N) -> + StartTime = start_time(), + [A] = rpc:block_call(B, erlang, nodes, []), + Time = elapsed_time(StartTime), + [B] = erlang:nodes(), + Mref = erlang:monitor(process, {rex,B}), + true = net_kernel:disconnect(B), + receive + {'DOWN',Mref,process,_,_} -> + [] = erlang:nodes(), + setup_loop(A, B, Time + T, N - 1) + end. + + +%%---------------- +%% Roundtrip speed + +roundtrip(Config) -> + run_nodepair_test(fun roundtrip/5, Config). + +roundtrip(A, B, Prefix, HA, HB) -> + Rounds = 40000, + [] = ssl_apply(HA, erlang, nodes, []), + [] = ssl_apply(HB, erlang, nodes, []), + Time = ssl_apply(HA, fun () -> roundtrip_runner(A, B, Rounds) end), + [B] = ssl_apply(HA, erlang, nodes, []), + [A] = ssl_apply(HB, erlang, nodes, []), + Speed = round((Rounds*1000000) / Time), + report(Prefix++" Roundtrip", Speed, "pings/s"). + +%% Runs on node A and spawns a server on node B +roundtrip_runner(A, B, Rounds) -> + ClientPid = self(), + [A] = rpc:call(B, erlang, nodes, []), + ServerPid = + erlang:spawn( + B, + fun () -> roundtrip_server(ClientPid, Rounds) end), + ServerMon = erlang:monitor(process, ServerPid), + microseconds( + roundtrip_client(ServerPid, ServerMon, start_time(), Rounds)). + +roundtrip_server(_Pid, 0) -> + ok; +roundtrip_server(Pid, N) -> + receive + N -> + Pid ! N, + roundtrip_server(Pid, N-1) + end. + +roundtrip_client(_Pid, Mon, StartTime, 0) -> + Time = elapsed_time(StartTime), + receive + {'DOWN', Mon, _, _, normal} -> + Time; + {'DOWN', Mon, _, _, Other} -> + exit(Other) + end; +roundtrip_client(Pid, Mon, StartTime, N) -> + Pid ! N, + receive + N -> + roundtrip_client(Pid, Mon, StartTime, N - 1) + end. + + +%%----------------- +%% Throughput speed + +throughput_1024(Config) -> + run_nodepair_test( + fun (A, B, Prefix, HA, HB) -> + throughput(A, B, Prefix, HA, HB, 100000, 1024) + end, Config). + +throughput_4096(Config) -> + run_nodepair_test( + fun (A, B, Prefix, HA, HB) -> + throughput(A, B, Prefix, HA, HB, 50000, 4096) + end, Config). + +throughput_16384(Config) -> + run_nodepair_test( + fun (A, B, Prefix, HA, HB) -> + throughput(A, B, Prefix, HA, HB, 10000, 16384) + end, Config). + +throughput_65536(Config) -> + run_nodepair_test( + fun (A, B, Prefix, HA, HB) -> + throughput(A, B, Prefix, HA, HB, 2000, 65536) + end, Config). + +throughput_262144(Config) -> + run_nodepair_test( + fun (A, B, Prefix, HA, HB) -> + throughput(A, B, Prefix, HA, HB, 500, 262144) + end, Config). + +throughput_1048576(Config) -> + run_nodepair_test( + fun (A, B, Prefix, HA, HB) -> + throughput(A, B, Prefix, HA, HB, 200, 1048576) + end, Config). + +throughput(A, B, Prefix, HA, HB, Packets, Size) -> + [] = ssl_apply(HA, erlang, nodes, []), + [] = ssl_apply(HB, erlang, nodes, []), + Time = + ssl_apply(HA, fun () -> throughput_runner(A, B, Packets, Size) end), + [B] = ssl_apply(HA, erlang, nodes, []), + [A] = ssl_apply(HB, erlang, nodes, []), + Speed = round((Packets*Size*1000000) / (1024*Time)), + report(Prefix++" Throughput_"++integer_to_list(Size), Speed, "kB/s"). + +%% Runs on node A and spawns a server on node B +throughput_runner(A, B, Rounds, Size) -> + Payload = payload(Size), + ClientPid = self(), + [A] = rpc:call(B, erlang, nodes, []), + ServerPid = + erlang:spawn( + B, + fun () -> throughput_server(ClientPid, Rounds) end), + ServerMon = erlang:monitor(process, ServerPid), + microseconds( + throughput_client( + ServerPid, ServerMon, Payload, start_time(), Rounds)). + +throughput_server(_Pid, 0) -> + ok; +throughput_server(Pid, N) -> + receive + [N|_] -> + throughput_server(Pid, N-1) + end. + +throughput_client(_Pid, Mon, _Payload, StartTime, 0) -> + receive + {'DOWN', Mon, _, _, normal} -> + elapsed_time(StartTime); + {'DOWN', Mon, _, _, Other} -> + exit(Other) + end; +throughput_client(Pid, Mon, Payload, StartTime, N) -> + Pid ! [N|Payload], + throughput_client(Pid, Mon, Payload, StartTime, N - 1). + +%%%------------------------------------------------------------------- +%%% Test cases helpers + +run_nodepair_test(TestFun, Config) -> + A = proplists:get_value(node_a, Config), + B = proplists:get_value(node_b, Config), + Prefix = proplists:get_value(ssl_dist_prefix, Config), + HA = start_ssl_node_a(Config), + HB = start_ssl_node_b(Config), + try TestFun(A, B, Prefix, HA, HB) + after + stop_ssl_node_a(HA), + stop_ssl_node_b(HB, Config), + ok + end. + +ssl_apply(Handle, M, F, Args) -> + case ssl_dist_test_lib:apply_on_ssl_node(Handle, M, F, Args) of + {'EXIT',Reason} -> + error(Reason); + Result -> + Result + end. + +ssl_apply(Handle, Fun) -> + case ssl_dist_test_lib:apply_on_ssl_node(Handle, Fun) of + {'EXIT',Reason} -> + error(Reason); + Result -> + Result + end. + +start_ssl_node_a(Config) -> + Name = proplists:get_value(node_a_name, Config), + Args = get_node_args(node_a_dist_args, Config), + ssl_dist_test_lib:start_ssl_node(Name, Args). + +start_ssl_node_b(Config) -> + Name = proplists:get_value(node_b_name, Config), + Args = get_node_args(node_b_dist_args, Config), + ServerNode = proplists:get_value(server_node, Config), + rpc:call( + ServerNode, ssl_dist_test_lib, start_ssl_node, [Name, Args]). + +stop_ssl_node_a(HA) -> + ssl_dist_test_lib:stop_ssl_node(HA). + +stop_ssl_node_b(HB, Config) -> + ServerNode = proplists:get_value(server_node, Config), + rpc:call(ServerNode, ssl_dist_test_lib, stop_ssl_node, [HB]). + +get_node_args(Tag, Config) -> + case proplists:get_value(ssl_dist, Config) of + true -> + proplists:get_value(Tag, Config); + false -> + "" + end. + + + +payload(Size) -> + iolist_to_binary( + [case Size bsr 8 of + 0 -> + []; + Blocks -> + payload(Blocks, create_binary(256)) + end | create_binary(Size band 255)]). +%% +payload(0, _) -> + []; +payload(Blocks, Block) -> + Half = payload(Blocks bsr 1, Block), + [Half, Half | + if + Blocks band 1 =:= 1 -> + Block; + true -> + [] + end]. + +create_binary(Size) -> + create_binary(Size, <<>>). +%% +create_binary(0, Bin) -> + Bin; +create_binary(Size, Bin) -> + NextSize = Size - 1, + create_binary(NextSize, <<Bin/binary, NextSize>>). + +start_time() -> + erlang:system_time(). + +elapsed_time(StartTime) -> + erlang:system_time() - StartTime. + +microseconds(Time) -> + erlang:convert_time_unit(Time, native, microsecond). + +report(Name, Value, Unit) -> + ct:pal("~s: ~w ~s", [Name, Value, Unit]), + ct_event:notify( + #event{ + name = benchmark_data, + data = [{value, Value}, {suite, "ssl_dist"}, {name, Name}]}), + {comment, term_to_string(Value) ++ " " ++ Unit}. + +term_to_string(Term) -> + unicode:characters_to_list( + io_lib:write(Term, [{encoding, unicode}])). diff --git a/lib/ssl/test/ssl_dist_test_lib.erl b/lib/ssl/test/ssl_dist_test_lib.erl new file mode 100644 index 0000000000..1b9c853fc4 --- /dev/null +++ b/lib/ssl/test/ssl_dist_test_lib.erl @@ -0,0 +1,343 @@ +%% +%% %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% +%% + +-module(ssl_dist_test_lib). + +-include_lib("common_test/include/ct.hrl"). +-include_lib("public_key/include/public_key.hrl"). +-include("ssl_dist_test_lib.hrl"). + +-export([tstsrvr_format/2, send_to_tstcntrl/1]). +-export([apply_on_ssl_node/4, apply_on_ssl_node/2]). +-export([stop_ssl_node/1, start_ssl_node/2]). +%% +-export([cnct2tstsrvr/1]). + +-define(AWAIT_SSL_NODE_UP_TIMEOUT, 30000). + + + +%% ssl_node side api +%% + +tstsrvr_format(Fmt, ArgList) -> + send_to_tstsrvr({format, Fmt, ArgList}). + +send_to_tstcntrl(Message) -> + send_to_tstsrvr({message, Message}). + + +%% +%% test_server side api +%% + +apply_on_ssl_node( + #node_handle{connection_handler = Hndlr} = Node, + M, F, A) when is_atom(M), is_atom(F), is_list(A) -> + Ref = erlang:monitor(process, Hndlr), + apply_on_ssl_node(Node, Ref, {apply, self(), Ref, M, F, A}). + +apply_on_ssl_node( + #node_handle{connection_handler = Hndlr} = Node, + Fun) when is_function(Fun, 0) -> + Ref = erlang:monitor(process, Hndlr), + apply_on_ssl_node(Node, Ref, {apply, self(), Ref, Fun}). + +apply_on_ssl_node(Node, Ref, Msg) -> + send_to_ssl_node(Node, Msg), + receive + {'DOWN', Ref, process, Hndlr, Reason} -> + exit({handler_died, Hndlr, Reason}); + {Ref, Result} -> + Result + end. + +stop_ssl_node(#node_handle{connection_handler = Handler, + socket = Socket, + name = Name}) -> + ?t:format("Trying to stop ssl node ~s.~n", [Name]), + Mon = erlang:monitor(process, Handler), + unlink(Handler), + case gen_tcp:send(Socket, term_to_binary(stop)) of + ok -> + receive + {'DOWN', Mon, process, Handler, Reason} -> + case Reason of + normal -> + ok; + _ -> + ct:pal( + "stop_ssl_node/1 ~s Down ~p ~n", + [Name,Reason]) + end + end; + Error -> + erlang:demonitor(Mon, [flush]), + ct:pal("stop_ssl_node/1 ~s Warning ~p ~n", [Name,Error]) + end. + +start_ssl_node(Name, Args) -> + {ok, LSock} = gen_tcp:listen(0, + [binary, {packet, 4}, {active, false}]), + {ok, ListenPort} = inet:port(LSock), + CmdLine = mk_node_cmdline(ListenPort, Name, Args), + ?t:format("Attempting to start ssl node ~ts: ~ts~n", [Name, CmdLine]), + case open_port({spawn, CmdLine}, []) of + Port when is_port(Port) -> + unlink(Port), + erlang:port_close(Port), + case await_ssl_node_up(Name, LSock) of + #node_handle{} = NodeHandle -> + ?t:format("Ssl node ~s started.~n", [Name]), + NodeName = list_to_atom(Name ++ "@" ++ host_name()), + NodeHandle#node_handle{nodename = NodeName}; + Error -> + exit({failed_to_start_node, Name, Error}) + end; + Error -> + exit({failed_to_start_node, Name, Error}) + end. + +host_name() -> + [_, Host] = string:split(atom_to_list(node()), "@"), + %% [$@ | Host] = lists:dropwhile(fun ($@) -> false; (_) -> true end, + %% atom_to_list(node())), + Host. + +mk_node_cmdline(ListenPort, Name, Args) -> + Static = "-detached -noinput", + Pa = filename:dirname(code:which(?MODULE)), + Prog = case catch init:get_argument(progname) of + {ok,[[P]]} -> P; + _ -> exit(no_progname_argument_found) + end, + NameSw = case net_kernel:longnames() of + false -> "-sname "; + _ -> "-name " + end, + {ok, Pwd} = file:get_cwd(), + "\"" ++ Prog ++ "\" " + ++ Static ++ " " + ++ NameSw ++ " " ++ Name ++ " " + ++ "-pa " ++ Pa ++ " " + ++ "-run application start crypto -run application start public_key " + ++ "-eval 'net_kernel:verbose(1)' " + ++ "-run " ++ atom_to_list(?MODULE) ++ " cnct2tstsrvr " + ++ host_name() ++ " " + ++ integer_to_list(ListenPort) ++ " " + ++ Args ++ " " + ++ "-env ERL_CRASH_DUMP " ++ Pwd ++ "/erl_crash_dump." ++ Name ++ " " + ++ "-kernel error_logger \"{file,\\\"" ++ Pwd ++ "/error_log." ++ Name ++ "\\\"}\" " + ++ "-setcookie " ++ atom_to_list(erlang:get_cookie()). + +%% +%% Connection handler test_server side +%% + +await_ssl_node_up(Name, LSock) -> + case gen_tcp:accept(LSock, ?AWAIT_SSL_NODE_UP_TIMEOUT) of + {ok, Socket} -> + gen_tcp:close(LSock), + case gen_tcp:recv(Socket, 0) of + {ok, Bin} -> + check_ssl_node_up(Socket, Name, Bin); + {error, closed} -> + gen_tcp:close(Socket), + exit({lost_connection_with_ssl_node_before_up, Name}) + end; + {error, Error} -> + gen_tcp:close(LSock), + ?t:format("Accept failed for ssl node ~s: ~p~n", [Name,Error]), + exit({accept_failed, Error}) + end. + +check_ssl_node_up(Socket, Name, Bin) -> + case catch binary_to_term(Bin) of + {'EXIT', _} -> + gen_tcp:close(Socket), + exit({bad_data_received_from_ssl_node, Name, Bin}); + {ssl_node_up, NodeName} -> + case list_to_atom(Name++"@"++host_name()) of + NodeName -> + Parent = self(), + Go = make_ref(), + %% Spawn connection handler on test server side + Pid = spawn_link( + fun () -> + receive Go -> ok end, + process_flag(trap_exit, true), + tstsrvr_con_loop(Name, Socket, Parent) + end), + ok = gen_tcp:controlling_process(Socket, Pid), + Pid ! Go, + #node_handle{connection_handler = Pid, + socket = Socket, + name = Name}; + _ -> + exit({unexpected_ssl_node_connected, NodeName}) + end; + Msg -> + exit({unexpected_msg_instead_of_ssl_node_up, Name, Msg}) + end. + +send_to_ssl_node(#node_handle{connection_handler = Hndlr}, Term) -> + Hndlr ! {relay_to_ssl_node, term_to_binary(Term)}, + ok. + +tstsrvr_con_loop(Name, Socket, Parent) -> + ok = inet:setopts(Socket,[{active,once}]), + receive + {relay_to_ssl_node, Data} when is_binary(Data) -> + case gen_tcp:send(Socket, Data) of + ok -> + ok; + _Error -> + gen_tcp:close(Socket), + exit({failed_to_relay_data_to_ssl_node, Name, Data}) + end; + {tcp, Socket, Bin} -> + try binary_to_term(Bin) of + {format, FmtStr, ArgList} -> + ?t:format(FmtStr, ArgList); + {message, Msg} -> + ?t:format("Got message ~p", [Msg]), + Parent ! Msg; + {apply_res, To, Ref, Res} -> + To ! {Ref, Res}; + bye -> + {error, closed} = gen_tcp:recv(Socket, 0), + ?t:format("Ssl node ~s stopped.~n", [Name]), + gen_tcp:close(Socket), + exit(normal); + Unknown -> + exit({unexpected_message_from_ssl_node, Name, Unknown}) + catch + error : _ -> + gen_tcp:close(Socket), + exit({bad_data_received_from_ssl_node, Name, Bin}) + end; + {tcp_closed, Socket} -> + gen_tcp:close(Socket), + exit({lost_connection_with_ssl_node, Name}); + {'EXIT', Parent, Reason} -> + exit({'EXIT', parent, Reason}); + Unknown -> + exit({unknown, Unknown}) + end, + tstsrvr_con_loop(Name, Socket, Parent). + +%% +%% Connection handler ssl_node side +%% + +% cnct2tstsrvr() is called via command line arg -run ... +cnct2tstsrvr([Host, Port]) when is_list(Host), is_list(Port) -> + %% Spawn connection handler on ssl node side + ConnHandler + = spawn(fun () -> + case catch gen_tcp:connect(Host, + list_to_integer(Port), + [binary, + {packet, 4}, + {active, false}]) of + {ok, Socket} -> + notify_ssl_node_up(Socket), + ets:new(test_server_info, + [set, + public, + named_table, + {keypos, 1}]), + ets:insert(test_server_info, + {test_server_handler, self()}), + ssl_node_con_loop(Socket); + Error -> + halt("Failed to connect to test server " ++ + lists:flatten(io_lib:format("Host:~p ~n Port:~p~n Error:~p~n", + [Host, Port, Error]))) + end + end), + spawn(fun () -> + Mon = erlang:monitor(process, ConnHandler), + receive + {'DOWN', Mon, process, ConnHandler, Reason} -> + receive after 1000 -> ok end, + halt("test server connection handler terminated: " ++ + lists:flatten(io_lib:format("~p", [Reason]))) + end + end). + +notify_ssl_node_up(Socket) -> + case catch gen_tcp:send(Socket, + term_to_binary({ssl_node_up, node()})) of + ok -> ok; + _ -> halt("Failed to notify test server that I'm up") + end. + +send_to_tstsrvr(Term) -> + case catch ets:lookup_element(test_server_info, test_server_handler, 2) of + Hndlr when is_pid(Hndlr) -> + Hndlr ! {relay_to_test_server, term_to_binary(Term)}, ok; + _ -> + receive after 200 -> ok end, + send_to_tstsrvr(Term) + end. + +ssl_node_con_loop(Socket) -> + inet:setopts(Socket,[{active,once}]), + receive + {relay_to_test_server, Data} when is_binary(Data) -> + case gen_tcp:send(Socket, Data) of + ok -> + ok; + _Error -> + gen_tcp:close(Socket), + halt("Failed to relay data to test server") + end; + {tcp, Socket, Bin} -> + case catch binary_to_term(Bin) of + {'EXIT', _} -> + gen_tcp:close(Socket), + halt("test server sent me bad data"); + {apply, From, Ref, M, F, A} -> + spawn_link( + fun () -> + send_to_tstsrvr({apply_res, + From, + Ref, + (catch apply(M, F, A))}) + end); + {apply, From, Ref, Fun} -> + spawn_link(fun () -> + send_to_tstsrvr({apply_res, + From, + Ref, + (catch Fun())}) + end); + stop -> + gen_tcp:send(Socket, term_to_binary(bye)), + init:stop(), + receive after infinity -> ok end; + _Unknown -> + halt("test server sent me an unexpected message") + end; + {tcp_closed, Socket} -> + halt("Lost connection to test server") + end, + ssl_node_con_loop(Socket). diff --git a/lib/ssl/test/ssl_dist_test_lib.hrl b/lib/ssl/test/ssl_dist_test_lib.hrl new file mode 100644 index 0000000000..86b9b37026 --- /dev/null +++ b/lib/ssl/test/ssl_dist_test_lib.hrl @@ -0,0 +1,26 @@ +%% +%% %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% +%% + +-record(node_handle, + {connection_handler, + socket, + name, + nodename} + ). diff --git a/lib/ssl/test/ssl_handshake_SUITE.erl b/lib/ssl/test/ssl_handshake_SUITE.erl index 9658cb5f56..cd3d972c07 100644 --- a/lib/ssl/test/ssl_handshake_SUITE.erl +++ b/lib/ssl/test/ssl_handshake_SUITE.erl @@ -33,7 +33,6 @@ %% 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, @@ -101,20 +100,13 @@ decode_hello_handshake(_Config) -> Version = {3, 0}, {Records, _Buffer} = tls_handshake:get_tls_handshake(Version, HelloPacket, <<>>, - #ssl_options{v2_hello_compatible = false}), + #ssl_options{}), {Hello, _Data} = hd(Records), #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_test_lib.erl b/lib/ssl/test/ssl_test_lib.erl index f9cc976815..a9f7dd9675 100644 --- a/lib/ssl/test/ssl_test_lib.erl +++ b/lib/ssl/test/ssl_test_lib.erl @@ -79,17 +79,21 @@ run_server(ListenSocket, Opts, N) -> Pid ! {accepter, N, Server}, run_server(ListenSocket, Opts, N-1). -do_run_server(_, {error, timeout} = Result, Opts) -> +do_run_server(_, {error, _} = Result, Opts) -> + ct:log("Server error result ~p~n", [Result]), + Pid = proplists:get_value(from, Opts), + Pid ! {self(), Result}; +do_run_server(_, ok = Result, Opts) -> + ct:log("Server cancel result ~p~n", [Result]), Pid = proplists:get_value(from, Opts), Pid ! {self(), Result}; - do_run_server(ListenSocket, AcceptSocket, Opts) -> Node = proplists:get_value(node, Opts), Pid = proplists:get_value(from, Opts), Transport = proplists:get_value(transport, Opts, ssl), {Module, Function, Args} = proplists:get_value(mfa, Opts), ct:log("~p:~p~nServer: apply(~p,~p,~p)~n", - [?MODULE,?LINE, Module, Function, [AcceptSocket | Args]]), + [?MODULE,?LINE, Module, Function, [AcceptSocket | Args]]), case rpc:call(Node, Module, Function, [AcceptSocket | Args]) of no_result_msg -> ok; @@ -117,7 +121,8 @@ connect(#sslsocket{} = ListenSocket, Opts) -> ReconnectTimes = proplists:get_value(reconnect_times, Opts, 0), Timeout = proplists:get_value(timeout, Opts, infinity), SslOpts = proplists:get_value(ssl_extra_opts, Opts, []), - AcceptSocket = connect(ListenSocket, Node, 1 + ReconnectTimes, dummy, Timeout, SslOpts), + ContOpts = proplists:get_value(continue_options, Opts, []), + AcceptSocket = connect(ListenSocket, Node, 1 + ReconnectTimes, dummy, Timeout, SslOpts, ContOpts), case ReconnectTimes of 0 -> AcceptSocket; @@ -132,10 +137,45 @@ connect(ListenSocket, Opts) -> [ListenSocket]), AcceptSocket. -connect(_, _, 0, AcceptSocket, _, _) -> +connect(_, _, 0, AcceptSocket, _, _, _) -> AcceptSocket; - -connect(ListenSocket, Node, N, _, Timeout, []) -> +connect(ListenSocket, Node, _N, _, Timeout, SslOpts, cancel) -> + ct:log("ssl:transport_accept(~p)~n", [ListenSocket]), + {ok, AcceptSocket} = rpc:call(Node, ssl, transport_accept, + [ListenSocket]), + ct:log("~p:~p~nssl:handshake(~p,~p,~p)~n", [?MODULE,?LINE, AcceptSocket, SslOpts,Timeout]), + + case rpc:call(Node, ssl, handshake, [AcceptSocket, SslOpts, Timeout]) of + {ok, Socket0, Ext} -> + ct:log("Ext ~p:~n", [Ext]), + ct:log("~p:~p~nssl:handshake_cancel(~p)~n", [?MODULE,?LINE, Socket0]), + rpc:call(Node, ssl, handshake_cancel, [Socket0]); + Result -> + ct:log("~p:~p~nssl:handshake@~p ret ~p",[?MODULE,?LINE, Node,Result]), + Result + end; +connect(ListenSocket, Node, N, _, Timeout, SslOpts, [_|_] =ContOpts) -> + ct:log("ssl:transport_accept(~p)~n", [ListenSocket]), + {ok, AcceptSocket} = rpc:call(Node, ssl, transport_accept, + [ListenSocket]), + ct:log("~p:~p~nssl:handshake(~p,~p,~p)~n", [?MODULE,?LINE, AcceptSocket, SslOpts,Timeout]), + + case rpc:call(Node, ssl, handshake, [AcceptSocket, SslOpts, Timeout]) of + {ok, Socket0, Ext} -> + ct:log("Ext ~p:~n", [Ext]), + ct:log("~p:~p~nssl:handshake_continue(~p,~p,~p)~n", [?MODULE,?LINE, Socket0, ContOpts,Timeout]), + case rpc:call(Node, ssl, handshake_continue, [Socket0, ContOpts, Timeout]) of + {ok, Socket} -> + connect(ListenSocket, Node, N-1, Socket, Timeout, SslOpts, ContOpts); + Error -> + ct:log("~p:~p~nssl:handshake_continue@~p ret ~p",[?MODULE,?LINE, Node,Error]), + Error + end; + Result -> + ct:log("~p:~p~nssl:handshake@~p ret ~p",[?MODULE,?LINE, Node,Result]), + Result + end; +connect(ListenSocket, Node, N, _, Timeout, [], ContOpts) -> ct:log("ssl:transport_accept(~p)~n", [ListenSocket]), {ok, AcceptSocket} = rpc:call(Node, ssl, transport_accept, [ListenSocket]), @@ -143,12 +183,12 @@ connect(ListenSocket, Node, N, _, Timeout, []) -> case rpc:call(Node, ssl, ssl_accept, [AcceptSocket, Timeout]) of ok -> - connect(ListenSocket, Node, N-1, AcceptSocket, Timeout, []); + connect(ListenSocket, Node, N-1, AcceptSocket, Timeout, [], ContOpts); Result -> ct:log("~p:~p~nssl:ssl_accept@~p ret ~p",[?MODULE,?LINE, Node,Result]), Result end; -connect(ListenSocket, Node, _, _, Timeout, Opts) -> +connect(ListenSocket, Node, _, _, Timeout, Opts, _) -> ct:log("ssl:transport_accept(~p)~n", [ListenSocket]), {ok, AcceptSocket} = rpc:call(Node, ssl, transport_accept, [ListenSocket]), @@ -187,8 +227,17 @@ run_client(Opts) -> Pid = proplists:get_value(from, Opts), Transport = proplists:get_value(transport, Opts, ssl), Options = proplists:get_value(options, Opts), + ContOpts = proplists:get_value(continue_options, Opts, []), ct:log("~p:~p~n~p:connect(~p, ~p)@~p~n", [?MODULE,?LINE, Transport, Host, Port, Node]), ct:log("SSLOpts: ~p", [Options]), + case ContOpts of + [] -> + client_loop(Node, Host, Port, Pid, Transport, Options, Opts); + _ -> + client_cont_loop(Node, Host, Port, Pid, Transport, Options, ContOpts, Opts) + end. + +client_loop(Node, Host, Port, Pid, Transport, Options, Opts) -> case rpc:call(Node, Transport, connect, [Host, Port, Options]) of {ok, Socket} -> Pid ! {connected, Socket}, @@ -245,6 +294,40 @@ run_client(Opts) -> Pid ! {connect_failed, {badrpc,BadRPC}} end. +client_cont_loop(Node, Host, Port, Pid, Transport, Options, cancel, _Opts) -> + case rpc:call(Node, Transport, connect, [Host, Port, Options]) of + {ok, Socket, _} -> + Result = rpc:call(Node, Transport, handshake_cancel, [Socket]), + ct:log("~p:~p~nClient: Cancel: ~p ~n", [?MODULE,?LINE, Result]), + Pid ! {connect_failed, Result}; + {error, Reason} -> + ct:log("~p:~p~nClient: connection failed: ~p ~n", [?MODULE,?LINE, Reason]), + Pid ! {connect_failed, Reason} + end; + +client_cont_loop(Node, Host, Port, Pid, Transport, Options, ContOpts, Opts) -> + case rpc:call(Node, Transport, connect, [Host, Port, Options]) of + {ok, Socket0, _} -> + ct:log("~p:~p~nClient: handshake_continue(~p, ~p, infinity) ~n", [?MODULE, ?LINE, Socket0, ContOpts]), + case rpc:call(Node, Transport, handshake_continue, [Socket0, ContOpts, infinity]) of + {ok, Socket} -> + Pid ! {connected, Socket}, + {Module, Function, Args} = proplists:get_value(mfa, Opts), + ct:log("~p:~p~nClient: apply(~p,~p,~p)~n", + [?MODULE,?LINE, Module, Function, [Socket | Args]]), + case rpc:call(Node, Module, Function, [Socket | Args]) of + no_result_msg -> + ok; + Msg -> + ct:log("~p:~p~nClient Msg: ~p ~n", [?MODULE,?LINE, Msg]), + Pid ! {self(), Msg} + end + end; + {error, Reason} -> + ct:log("~p:~p~nClient: connection failed: ~p ~n", [?MODULE,?LINE, Reason]), + Pid ! {connect_failed, Reason} + end. + close(Pid) -> ct:log("~p:~p~nClose ~p ~n", [?MODULE,?LINE, Pid]), Monitor = erlang:monitor(process, Pid), @@ -862,6 +945,163 @@ accepters(Acc, N) -> accepters([Server| Acc], N-1) end. + +basic_test(COpts, SOpts, Config) -> + SType = proplists:get_value(server_type, Config), + CType = proplists:get_value(client_type, Config), + {Server, Port} = start_server(SType, SOpts, Config), + Client = start_client(CType, Port, COpts, Config), + gen_check_result(Server, SType, Client, CType), + stop(Server, Client). + +ecc_test(Expect, COpts, SOpts, CECCOpts, SECCOpts, Config) -> + {Server, Port} = start_server_ecc(erlang, SOpts, Expect, SECCOpts, Config), + Client = start_client_ecc(erlang, Port, COpts, Expect, CECCOpts, Config), + check_result(Server, ok, Client, ok), + stop(Server, Client). + +ecc_test_error(COpts, SOpts, CECCOpts, SECCOpts, Config) -> + {Server, Port} = start_server_ecc_error(erlang, SOpts, SECCOpts, Config), + Client = start_client_ecc_error(erlang, Port, COpts, CECCOpts, Config), + Error = {error, {tls_alert, "insufficient security"}}, + check_result(Server, Error, Client, Error). + + +start_client(openssl, Port, ClientOpts, Config) -> + Cert = proplists:get_value(certfile, ClientOpts), + Key = proplists:get_value(keyfile, ClientOpts), + CA = proplists:get_value(cacertfile, ClientOpts), + Version = ssl_test_lib:protocol_version(Config), + Exe = "openssl", + Args = ["s_client", "-verify", "2", "-port", integer_to_list(Port), + ssl_test_lib:version_flag(Version), + "-cert", Cert, "-CAfile", CA, + "-key", Key, "-host","localhost", "-msg", "-debug"], + + OpenSslPort = ssl_test_lib:portable_open_port(Exe, Args), + true = port_command(OpenSslPort, "Hello world"), + OpenSslPort; + +start_client(erlang, Port, ClientOpts, Config) -> + {ClientNode, _, Hostname} = ssl_test_lib:run_where(Config), + KeyEx = proplists:get_value(check_keyex, Config, false), + ssl_test_lib:start_client([{node, ClientNode}, {port, Port}, + {host, Hostname}, + {from, self()}, + {mfa, {ssl_test_lib, check_key_exchange_send_active, [KeyEx]}}, + {options, [{verify, verify_peer} | ClientOpts]}]). + + +start_client_ecc(erlang, Port, ClientOpts, Expect, ECCOpts, Config) -> + {ClientNode, _, Hostname} = ssl_test_lib:run_where(Config), + ssl_test_lib:start_client([{node, ClientNode}, {port, Port}, + {host, Hostname}, + {from, self()}, + {mfa, {?MODULE, check_ecc, [client, Expect]}}, + {options, + ECCOpts ++ + [{verify, verify_peer} | ClientOpts]}]). + +start_client_ecc_error(erlang, Port, ClientOpts, ECCOpts, Config) -> + {ClientNode, _, Hostname} = ssl_test_lib:run_where(Config), + ssl_test_lib:start_client_error([{node, ClientNode}, {port, Port}, + {host, Hostname}, + {from, self()}, + {options, + ECCOpts ++ + [{verify, verify_peer} | ClientOpts]}]). + + +start_server(openssl, ServerOpts, Config) -> + Cert = proplists:get_value(certfile, ServerOpts), + Key = proplists:get_value(keyfile, ServerOpts), + CA = proplists:get_value(cacertfile, ServerOpts), + Port = inet_port(node()), + Version = protocol_version(Config), + Exe = "openssl", + Args = ["s_server", "-accept", integer_to_list(Port), ssl_test_lib:version_flag(Version), + "-verify", "2", "-cert", Cert, "-CAfile", CA, + "-key", Key, "-msg", "-debug"], + OpenSslPort = portable_open_port(Exe, Args), + true = port_command(OpenSslPort, "Hello world"), + {OpenSslPort, Port}; +start_server(erlang, ServerOpts, Config) -> + {_, ServerNode, _} = ssl_test_lib:run_where(Config), + KeyEx = proplists:get_value(check_keyex, Config, false), + Server = start_server([{node, ServerNode}, {port, 0}, + {from, self()}, + {mfa, {ssl_test_lib, + check_key_exchange_send_active, + [KeyEx]}}, + {options, [{verify, verify_peer} | ServerOpts]}]), + {Server, inet_port(Server)}. + +start_server_with_raw_key(erlang, ServerOpts, Config) -> + {_, ServerNode, _} = ssl_test_lib:run_where(Config), + Server = start_server([{node, ServerNode}, {port, 0}, + {from, self()}, + {mfa, {ssl_test_lib, + send_recv_result_active, + []}}, + {options, + [{verify, verify_peer} | ServerOpts]}]), + {Server, inet_port(Server)}. + +start_server_ecc(erlang, ServerOpts, Expect, ECCOpts, Config) -> + {_, ServerNode, _} = run_where(Config), + Server = start_server([{node, ServerNode}, {port, 0}, + {from, self()}, + {mfa, {?MODULE, check_ecc, [server, Expect]}}, + {options, + ECCOpts ++ + [{verify, verify_peer} | ServerOpts]}]), + {Server, inet_port(Server)}. + +start_server_ecc_error(erlang, ServerOpts, ECCOpts, Config) -> + {_, ServerNode, _} = run_where(Config), + Server = start_server_error([{node, ServerNode}, {port, 0}, + {from, self()}, + {options, + ECCOpts ++ + [{verify, verify_peer} | ServerOpts]}]), + {Server, inet_port(Server)}. + +gen_check_result(Server, erlang, Client, erlang) -> + check_result(Server, ok, Client, ok); +gen_check_result(Server, erlang, _, _) -> + check_result(Server, ok); +gen_check_result(_, _, Client, erlang) -> + check_result(Client, ok); +gen_check_result(_,openssl, _, openssl) -> + ok. + +stop(Port1, Port2) when is_port(Port1), is_port(Port2) -> + close_port(Port1), + close_port(Port2); +stop(Port, Pid) when is_port(Port) -> + close_port(Port), + close(Pid); +stop(Pid, Port) when is_port(Port) -> + close_port(Port), + close(Pid); +stop(Client, Server) -> + close(Server), + close(Client). + +supported_eccs(Opts) -> + ToCheck = proplists:get_value(eccs, Opts, []), + Supported = ssl:eccs(), + lists:all(fun(Curve) -> lists:member(Curve, Supported) end, ToCheck). + +check_ecc(SSL, Role, Expect) -> + {ok, Data} = ssl:connection_information(SSL), + case lists:keyfind(ecc, 1, Data) of + {ecc, {named_curve, Expect}} -> ok; + false when Expect == undefined -> ok; + false when Expect == secp256r1 andalso Role == client_no_ecc -> ok; + Other -> {error, Role, Expect, Other} + end. + inet_port(Pid) when is_pid(Pid)-> receive {Pid, {port, Port}} -> @@ -1059,6 +1299,10 @@ srp_dss_suites() -> (_) -> false end}]). +chacha_suites(Version) -> + [ssl_cipher:erl_suite_definition(S) || S <- ssl_cipher:filter_suites(ssl_cipher:chacha_suites(Version))]. + + rc4_suites(Version) -> ssl:filter_cipher_suites([ssl_cipher:suite_definition(S) || S <-ssl_cipher:rc4_suites(Version)], []). @@ -1181,10 +1425,7 @@ sufficient_crypto_support(Version) when Version == 'tlsv1.2'; Version == 'dtlsv1.2' -> CryptoSupport = crypto:supports(), proplists:get_bool(sha256, proplists:get_value(hashs, CryptoSupport)); -sufficient_crypto_support(Group) when Group == ciphers_ec; %% From ssl_basic_SUITE - Group == erlang_server; %% From ssl_ECC_SUITE - Group == erlang_client; %% From ssl_ECC_SUITE - Group == erlang -> %% From ssl_ECC_SUITE +sufficient_crypto_support(cipher_ec) -> CryptoSupport = crypto:supports(), proplists:get_bool(ecdh, proplists:get_value(public_keys, CryptoSupport)); sufficient_crypto_support(_) -> @@ -1555,10 +1796,14 @@ is_psk_anon_suite({psk, _,_}) -> true; is_psk_anon_suite({dhe_psk,_,_}) -> true; +is_psk_anon_suite({ecdhe_psk,_,_}) -> + true; is_psk_anon_suite({psk, _,_,_}) -> true; is_psk_anon_suite({dhe_psk, _,_,_}) -> true; +is_psk_anon_suite({ecdhe_psk, _,_,_}) -> + true; is_psk_anon_suite(_) -> false. diff --git a/lib/ssl/test/ssl_to_openssl_SUITE.erl b/lib/ssl/test/ssl_to_openssl_SUITE.erl index dcdea6beb5..e8cbf857ef 100644 --- a/lib/ssl/test/ssl_to_openssl_SUITE.erl +++ b/lib/ssl/test/ssl_to_openssl_SUITE.erl @@ -51,17 +51,16 @@ groups() -> [{basic, [], basic_tests()}, {'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()}, - {'dtlsv1.2', [], dtls_all_versions_tests()}, - {'dtlsv1', [], dtls_all_versions_tests()} - ]. + {'tlsv1', [], all_versions_tests()++ alpn_tests() ++ npn_tests() ++ sni_server_tests()}, + {'sslv3', [], all_versions_tests()}, + {'dtlsv1.2', [], dtls_all_versions_tests()}, + {'dtlsv1', [], dtls_all_versions_tests()} + ]. basic_tests() -> [basic_erlang_client_openssl_server, basic_erlang_server_openssl_client, - expired_session, - ssl2_erlang_server_openssl_client_comp + expired_session ]. all_versions_tests() -> @@ -141,13 +140,13 @@ sni_server_tests() -> init_per_suite(Config0) -> case os:find_executable("openssl") of - false -> - {skip, "Openssl not found"}; - _ -> - ct:pal("Version: ~p", [os:cmd("openssl version")]), - catch crypto:stop(), - try crypto:start() of - ok -> + false -> + {skip, "Openssl not found"}; + _ -> + ct:pal("Version: ~p", [os:cmd("openssl version")]), + catch crypto:stop(), + try crypto:start() of + ok -> ssl_test_lib:clean_start(), Config = case ssl_test_lib:openssl_dsa_support() of @@ -158,9 +157,9 @@ init_per_suite(Config0) -> ssl_test_lib:make_rsa_cert(Config0) end, ssl_test_lib:cipher_restriction(Config) - catch _:_ -> - {skip, "Crypto did not start"} - end + catch _:_ -> + {skip, "Crypto did not start"} + end end. end_per_suite(_Config) -> @@ -168,39 +167,34 @@ end_per_suite(_Config) -> application:stop(crypto). init_per_group(basic, Config0) -> - Config = ssl_test_lib:clean_tls_version(Config0), - case ssl_test_lib:supports_ssl_tls_version(sslv2) of - true -> - [{v2_hello_compatible, true} | Config]; - false -> - [{v2_hello_compatible, false} | Config] - end; + ssl_test_lib:clean_tls_version(Config0); + init_per_group(GroupName, Config) -> case ssl_test_lib:is_tls_version(GroupName) of - true -> + true -> case ssl_test_lib:supports_ssl_tls_version(GroupName) of - true -> + true -> case ssl_test_lib:check_sane_openssl_version(GroupName) of - true -> + true -> ssl_test_lib:init_tls_version(GroupName, Config); - false -> + false -> {skip, openssl_does_not_support_version} end; false -> {skip, openssl_does_not_support_version} end; - _ -> - ssl:start(), - Config + _ -> + ssl:start(), + Config end. end_per_group(GroupName, Config) -> - case ssl_test_lib:is_tls_version(GroupName) of - true -> - ssl_test_lib:clean_tls_version(Config); - false -> - Config - end. + case ssl_test_lib:is_tls_version(GroupName) of + true -> + ssl_test_lib:clean_tls_version(Config); + false -> + Config + end. init_per_testcase(expired_session, Config) -> ct:timetrap(?EXPIRE * 1000 * 5), @@ -208,19 +202,19 @@ init_per_testcase(expired_session, Config) -> application:load(ssl), application:set_env(ssl, session_lifetime, ?EXPIRE), ssl:start(), - Config; + Config; init_per_testcase(TestCase, Config) when TestCase == ciphers_dsa_signed_certs; TestCase == erlang_client_openssl_server_dsa_cert; TestCase == erlang_server_openssl_client_dsa_cert; - TestCase == erlang_client_openssl_server_dsa_cert; + TestCase == erlang_client_openssl_server_dsa_cert; TestCase == erlang_server_openssl_client_dsa_cert -> case ssl_test_lib:openssl_dsa_support() of true -> special_init(TestCase, Config); false -> - {skip, "DSA not supported by OpenSSL"} + {skip, "DSA not supported by OpenSSL"} end; init_per_testcase(TestCase, Config) -> ct:timetrap({seconds, 35}), @@ -233,70 +227,69 @@ special_init(TestCase, Config) when Config; special_init(TestCase, Config) when TestCase == erlang_client_openssl_server_renegotiate; - TestCase == erlang_client_openssl_server_nowrap_seqnum; + TestCase == erlang_client_openssl_server_nowrap_seqnum; TestCase == erlang_server_openssl_client_nowrap_seqnum - -> + -> {ok, Version} = application:get_env(ssl, protocol_version), check_sane_openssl_renegotaite(Config, Version); -special_init(Case, Config) when Case == ssl2_erlang_server_openssl_client; - Case == ssl2_erlang_server_openssl_client_comp -> +special_init(ssl2_erlang_server_openssl_client, Config) -> case ssl_test_lib:supports_ssl_tls_version(sslv2) of - true -> - Config; - false -> - {skip, "sslv2 not supported by openssl"} - end; + true -> + Config; + false -> + {skip, "sslv2 not supported by openssl"} + end; special_init(TestCase, Config) - when TestCase == erlang_client_alpn_openssl_server_alpn; - TestCase == erlang_server_alpn_openssl_client_alpn; - TestCase == erlang_client_alpn_openssl_server; - TestCase == erlang_client_openssl_server_alpn; - TestCase == erlang_server_alpn_openssl_client; - TestCase == erlang_server_openssl_client_alpn -> + when TestCase == erlang_client_alpn_openssl_server_alpn; + TestCase == erlang_server_alpn_openssl_client_alpn; + TestCase == erlang_client_alpn_openssl_server; + TestCase == erlang_client_openssl_server_alpn; + TestCase == erlang_server_alpn_openssl_client; + TestCase == erlang_server_openssl_client_alpn -> check_openssl_alpn_support(Config); special_init(TestCase, Config) - when TestCase == erlang_client_alpn_openssl_server_alpn_renegotiate; - TestCase == erlang_server_alpn_openssl_client_alpn_renegotiate -> - {ok, Version} = application:get_env(ssl, protocol_version), - case check_sane_openssl_renegotaite(Config, Version) of - {skip, _} = Skip -> - Skip; - _ -> - check_openssl_alpn_support(Config) - end; + when TestCase == erlang_client_alpn_openssl_server_alpn_renegotiate; + TestCase == erlang_server_alpn_openssl_client_alpn_renegotiate -> + {ok, Version} = application:get_env(ssl, protocol_version), + case check_sane_openssl_renegotaite(Config, Version) of + {skip, _} = Skip -> + Skip; + _ -> + check_openssl_alpn_support(Config) + end; special_init(TestCase, Config) - when TestCase == erlang_client_alpn_npn_openssl_server_alpn_npn; - TestCase == erlang_server_alpn_npn_openssl_client_alpn_npn -> + when TestCase == erlang_client_alpn_npn_openssl_server_alpn_npn; + TestCase == erlang_server_alpn_npn_openssl_client_alpn_npn -> case check_openssl_alpn_support(Config) of {skip, _} = Skip -> Skip; _ -> - check_openssl_npn_support(Config) + check_openssl_npn_support(Config) end; special_init(TestCase, Config) - when TestCase == erlang_client_openssl_server_npn; - TestCase == erlang_server_openssl_client_npn; - TestCase == erlang_server_openssl_client_npn_only_server; - TestCase == erlang_server_openssl_client_npn_only_client; - TestCase == erlang_client_openssl_server_npn_only_client; - TestCase == erlang_client_openssl_server_npn_only_server -> + when TestCase == erlang_client_openssl_server_npn; + TestCase == erlang_server_openssl_client_npn; + TestCase == erlang_server_openssl_client_npn_only_server; + TestCase == erlang_server_openssl_client_npn_only_client; + TestCase == erlang_client_openssl_server_npn_only_client; + TestCase == erlang_client_openssl_server_npn_only_server -> check_openssl_npn_support(Config); special_init(TestCase, Config) when TestCase == erlang_server_openssl_client_npn_renegotiate; TestCase == erlang_client_openssl_server_npn_renegotiate -> {ok, Version} = application:get_env(ssl, protocol_version), - case check_sane_openssl_renegotaite(Config, Version) of - {skip, _} = Skip -> - Skip; - _ -> - check_openssl_npn_support(Config) - end; + case check_sane_openssl_renegotaite(Config, Version) of + {skip, _} = Skip -> + Skip; + _ -> + check_openssl_npn_support(Config) + end; special_init(TestCase, Config0) when TestCase == erlang_server_openssl_client_sni_match; @@ -305,25 +298,25 @@ special_init(TestCase, Config0) TestCase == erlang_server_openssl_client_sni_match_fun; TestCase == erlang_server_openssl_client_sni_no_match_fun; TestCase == erlang_server_openssl_client_sni_no_header_fun -> - RsaOpts = ssl_test_lib:ssl_options(server_rsa_opts, Config0), + RsaOpts = ssl_test_lib:ssl_options(server_rsa_opts, Config0), Config = [{sni_server_opts, [{sni_hosts, [{"a.server", [ {certfile, proplists:get_value(certfile, RsaOpts)}, {keyfile, proplists:get_value(keyfile, RsaOpts)} ]}, {"b.server", [ - {certfile, proplists:get_value(certfile, RsaOpts)}, + {certfile, proplists:get_value(certfile, RsaOpts)}, {keyfile, proplists:get_value(keyfile, RsaOpts)} ]} ]}]} | Config0], check_openssl_sni_support(Config); special_init(_, Config) -> - Config. + Config. end_per_testcase(reuse_session_expired, Config) -> application:unset_env(ssl, session_lifetime), - Config; + Config; end_per_testcase(_, Config) -> Config. @@ -346,8 +339,8 @@ basic_erlang_client_openssl_server(Config) when is_list(Config) -> KeyFile = proplists:get_value(keyfile, ServerOpts), Exe = "openssl", - Args = ["s_server", "-accept", integer_to_list(Port), - "-cert", CertFile, "-key", KeyFile], + Args = ["s_server", "-accept", integer_to_list(Port), + "-cert", CertFile, "-key", KeyFile], OpensslPort = ssl_test_lib:portable_open_port(Exe, Args), @@ -355,15 +348,15 @@ basic_erlang_client_openssl_server(Config) when is_list(Config) -> ssl_test_lib:wait_for_openssl_server(Port, tls), Client = ssl_test_lib:start_client([{node, ClientNode}, {port, Port}, - {host, Hostname}, - {from, self()}, - {mfa, {?MODULE, - erlang_ssl_receive, [Data]}}, - {options, ClientOpts}]), + {host, Hostname}, + {from, self()}, + {mfa, {?MODULE, + erlang_ssl_receive, [Data]}}, + {options, ClientOpts}]), true = port_command(OpensslPort, Data), ssl_test_lib:check_result(Client, ok), - + %% Clean close down! Server needs to be closed first !! ssl_test_lib:close_port(OpensslPort), ssl_test_lib:close(Client), @@ -375,23 +368,20 @@ basic_erlang_server_openssl_client() -> basic_erlang_server_openssl_client(Config) when is_list(Config) -> process_flag(trap_exit, true), ServerOpts = ssl_test_lib:ssl_options(server_rsa_opts, Config), - V2Compat = proplists:get_value(v2_hello_compatible, Config), {_, ServerNode, Hostname} = ssl_test_lib:run_where(Config), Data = "From openssl to erlang", - ct:pal("v2_hello_compatible: ~p", [V2Compat]), - Server = ssl_test_lib:start_server([{node, ServerNode}, {port, 0}, - {from, self()}, - {mfa, {?MODULE, erlang_ssl_receive, [Data]}}, - {options,[{v2_hello_compatible, V2Compat} | ServerOpts]}]), + {from, self()}, + {mfa, {?MODULE, erlang_ssl_receive, [Data]}}, + {options,ServerOpts}]), Port = ssl_test_lib:inet_port(Server), Exe = "openssl", Args = ["s_client", "-connect", hostname_format(Hostname) ++ - ":" ++ integer_to_list(Port) | workaround_openssl_s_clinent()], + ":" ++ integer_to_list(Port) ++ no_v2_flag() | workaround_openssl_s_clinent()], OpenSslPort = ssl_test_lib:portable_open_port(Exe, Args), true = port_command(OpenSslPort, Data), @@ -421,19 +411,19 @@ erlang_client_openssl_server(Config) when is_list(Config) -> Version = ssl_test_lib:protocol_version(Config), Exe = "openssl", Args = ["s_server", "-accept", integer_to_list(Port), - ssl_test_lib:version_flag(Version), - "-cert", CertFile, "-key", KeyFile], - + 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, proplists:get_value(protocol, Config)), Client = ssl_test_lib:start_client([{node, ClientNode}, {port, Port}, - {host, Hostname}, - {from, self()}, - {mfa, {?MODULE, - erlang_ssl_receive, [Data]}}, - {options, ClientOpts}]), + {host, Hostname}, + {from, self()}, + {mfa, {?MODULE, + erlang_ssl_receive, [Data]}}, + {options, ClientOpts}]), true = port_command(OpensslPort, Data), ssl_test_lib:check_result(Client, ok), @@ -449,24 +439,24 @@ erlang_server_openssl_client() -> erlang_server_openssl_client(Config) when is_list(Config) -> process_flag(trap_exit, true), ServerOpts = ssl_test_lib:ssl_options(server_rsa_opts, Config), - - {_, ServerNode, Hostname} = ssl_test_lib:run_where(Config), + {_, ServerNode, Hostname} = ssl_test_lib:run_where(Config), + Data = "From openssl to erlang", Server = ssl_test_lib:start_server([{node, ServerNode}, {port, 0}, - {from, self()}, - {mfa, {?MODULE, erlang_ssl_receive, [Data]}}, - {options, ServerOpts}]), + {from, self()}, + {mfa, {?MODULE, erlang_ssl_receive, [Data]}}, + {options, ServerOpts}]), Port = ssl_test_lib:inet_port(Server), Version = ssl_test_lib:protocol_version(Config), Exe = "openssl", Args = ["s_client", "-connect", hostname_format(Hostname) ++":" ++ integer_to_list(Port), - ssl_test_lib:version_flag(Version)], - - OpenSslPort = ssl_test_lib:portable_open_port(Exe, Args), + ssl_test_lib:version_flag(Version)], + OpenSslPort = ssl_test_lib:portable_open_port(Exe, Args), + true = port_command(OpenSslPort, Data), ssl_test_lib:check_result(Server, ok), @@ -483,8 +473,8 @@ erlang_client_openssl_server_dsa_cert(Config) when is_list(Config) -> ClientOpts = ssl_test_lib:ssl_options(client_dsa_opts, Config), ServerOpts = ssl_test_lib:ssl_options(server_dsa_verify_opts, Config), - {ClientNode, _, Hostname} = ssl_test_lib:run_where(Config), - + {ClientNode, _, Hostname} = ssl_test_lib:run_where(Config), + Data = "From openssl to erlang", Port = ssl_test_lib:inet_port(node()), @@ -494,27 +484,27 @@ erlang_client_openssl_server_dsa_cert(Config) when is_list(Config) -> Version = ssl_test_lib:protocol_version(Config), Exe = "openssl", Args = ["s_server", "-accept", integer_to_list(Port), - ssl_test_lib:version_flag(Version), - "-cert", CertFile, "-CAfile", CaCertFile, - "-key", KeyFile, "-Verify", "2", "-msg"], + ssl_test_lib:version_flag(Version), + "-cert", CertFile, "-CAfile", CaCertFile, + "-key", KeyFile, "-Verify", "2", "-msg"], OpensslPort = ssl_test_lib:portable_open_port(Exe, Args), 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}, - {from, self()}, - {mfa, {?MODULE, - erlang_ssl_receive, [Data]}}, - {options, ClientOpts}]), + {host, Hostname}, + {from, self()}, + {mfa, {?MODULE, + erlang_ssl_receive, [Data]}}, + {options, ClientOpts}]), true = port_command(OpensslPort, Data), - ssl_test_lib:check_result(Client, ok), - + ssl_test_lib:check_result(Client, ok), + %% Clean close down! Server needs to be closed first !! - ssl_test_lib:close_port(OpensslPort), + ssl_test_lib:close_port(OpensslPort), ssl_test_lib:close(Client), process_flag(trap_exit, false), ok. @@ -534,17 +524,17 @@ erlang_server_openssl_client_dsa_cert(Config) when is_list(Config) -> KeyFile = proplists:get_value(keyfile, ClientOpts), Server = ssl_test_lib:start_server([{node, ServerNode}, {port, 0}, - {from, self()}, - {mfa, {?MODULE, erlang_ssl_receive, [Data]}}, - {options, ServerOpts}]), + {from, self()}, + {mfa, {?MODULE, erlang_ssl_receive, [Data]}}, + {options, ServerOpts}]), Port = ssl_test_lib:inet_port(Server), Version = ssl_test_lib:protocol_version(Config), Exe = "openssl", Args = ["s_client", "-connect", hostname_format(Hostname) ++ ":" ++ integer_to_list(Port), - ssl_test_lib:version_flag(Version), - "-cert", CertFile, - "-CAfile", CaCertFile, - "-key", KeyFile, "-msg"], + ssl_test_lib:version_flag(Version), + "-cert", CertFile, + "-CAfile", CaCertFile, + "-key", KeyFile, "-msg"], OpenSslPort = ssl_test_lib:portable_open_port(Exe, Args), true = port_command(OpenSslPort, Data), @@ -556,11 +546,11 @@ erlang_server_openssl_client_dsa_cert(Config) when is_list(Config) -> ssl_test_lib:close_port(OpenSslPort), process_flag(trap_exit, false). -%%-------------------------------------------------------------------- + %%-------------------------------------------------------------------- erlang_client_openssl_server_anon() -> - [{doc,"Test erlang client with openssl server, anonymous"}]. + [{doc,"Test erlang client with openssl server, anonymous"}]. erlang_client_openssl_server_anon(Config) when is_list(Config) -> - process_flag(trap_exit, true), + process_flag(trap_exit, true), %% OpenSSL expects a certificate and key, even if the cipher spec %% is restructed to aNULL, so we use 'server_rsa_opts' here ServerOpts = ssl_test_lib:ssl_options(server_rsa_opts, Config), @@ -578,27 +568,27 @@ erlang_client_openssl_server_anon(Config) when is_list(Config) -> Version = ssl_test_lib:protocol_version(Config), Exe = "openssl", Args = ["s_server", "-accept", integer_to_list(Port), - ssl_test_lib:version_flag(Version), + ssl_test_lib:version_flag(Version), "-cert", CertFile, "-key", KeyFile, - "-cipher", "aNULL", "-msg"], + "-cipher", "aNULL", "-msg"], OpensslPort = ssl_test_lib:portable_open_port(Exe, Args), 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}, - {from, self()}, - {mfa, {?MODULE, - erlang_ssl_receive, [Data]}}, - {options, [{ciphers, Ciphers} | ClientOpts]}]), + Client = ssl_test_lib:start_client([{node, ClientNode}, {port, Port}, + {host, Hostname}, + {from, self()}, + {mfa, {?MODULE, + erlang_ssl_receive, [Data]}}, + {options, [{ciphers, Ciphers} | ClientOpts]}]), true = port_command(OpensslPort, Data), ssl_test_lib:check_result(Client, ok), %% Clean close down! Server needs to be closed first !! - ssl_test_lib:close_port(OpensslPort), + ssl_test_lib:close_port(OpensslPort), ssl_test_lib:close(Client), process_flag(trap_exit, false), ok. @@ -616,30 +606,30 @@ erlang_server_openssl_client_anon(Config) when is_list(Config) -> Data = "From openssl to erlang", Server = ssl_test_lib:start_server([{node, ServerNode}, {port, 0}, - {from, self()}, - {mfa, {?MODULE, erlang_ssl_receive, [Data]}}, - {options, [{ciphers, Ciphers} | ServerOpts]}]), + {from, self()}, + {mfa, {?MODULE, erlang_ssl_receive, [Data]}}, + {options, [{ciphers, Ciphers} | ServerOpts]}]), Port = ssl_test_lib:inet_port(Server), Version = ssl_test_lib:protocol_version(Config), Exe = "openssl", Args = ["s_client", "-connect", hostname_format(Hostname) ++ ":" ++ integer_to_list(Port), - ssl_test_lib:version_flag(Version), - "-cipher", "aNULL", "-msg"], + ssl_test_lib:version_flag(Version), + "-cipher", "aNULL", "-msg"], OpenSslPort = ssl_test_lib:portable_open_port(Exe, Args), true = port_command(OpenSslPort, Data), - ssl_test_lib:check_result(Server, ok), + ssl_test_lib:check_result(Server, ok), %% Clean close down! Server needs to be closed first !! - ssl_test_lib:close(Server), + ssl_test_lib:close(Server), ssl_test_lib:close_port(OpenSslPort), process_flag(trap_exit, false). - %%-------------------------------------------------------------------- - erlang_server_openssl_client_anon_with_cert() -> - [{doc,"Test erlang server with openssl client, anonymous (with cert)"}]. - erlang_server_openssl_client_anon_with_cert(Config) when is_list(Config) -> +%%-------------------------------------------------------------------- +erlang_server_openssl_client_anon_with_cert() -> + [{doc,"Test erlang server with openssl client, anonymous (with cert)"}]. +erlang_server_openssl_client_anon_with_cert(Config) when is_list(Config) -> process_flag(trap_exit, true), ServerOpts = ssl_test_lib:ssl_options(server_rsa_opts, Config), VersionTuple = ssl_test_lib:protocol_version(Config, tuple), @@ -650,15 +640,15 @@ erlang_server_openssl_client_anon(Config) when is_list(Config) -> Data = "From openssl to erlang", Server = ssl_test_lib:start_server([{node, ServerNode}, {port, 0}, - {from, self()}, - {mfa, {?MODULE, erlang_ssl_receive, [Data]}}, - {options, [{ciphers, Ciphers} | ServerOpts]}]), + {from, self()}, + {mfa, {?MODULE, erlang_ssl_receive, [Data]}}, + {options, [{ciphers, Ciphers} | ServerOpts]}]), Port = ssl_test_lib:inet_port(Server), Version = ssl_test_lib:protocol_version(Config), Exe = "openssl", Args = ["s_client", "-connect", hostname_format(Hostname) ++ ":" ++ integer_to_list(Port), - ssl_test_lib:version_flag(Version), - "-cipher", "aNULL", "-msg"], + ssl_test_lib:version_flag(Version), + "-cipher", "aNULL", "-msg"], OpenSslPort = ssl_test_lib:portable_open_port(Exe, Args), true = port_command(OpenSslPort, Data), @@ -670,11 +660,10 @@ erlang_server_openssl_client_anon(Config) when is_list(Config) -> ssl_test_lib:close_port(OpenSslPort), process_flag(trap_exit, false). -%%-------------------------------------------------------------------- - + %%-------------------------------------------------------------------- erlang_server_openssl_client_reuse_session() -> [{doc, "Test erlang server with openssl client that reconnects with the" - "same session id, to test reusing of sessions."}]. + "same session id, to test reusing of sessions."}]. erlang_server_openssl_client_reuse_session(Config) when is_list(Config) -> process_flag(trap_exit, true), ServerOpts = ssl_test_lib:ssl_options(server_rsa_opts, Config), @@ -684,18 +673,18 @@ erlang_server_openssl_client_reuse_session(Config) when is_list(Config) -> Data = "From openssl to erlang", Server = ssl_test_lib:start_server([{node, ServerNode}, {port, 0}, - {from, self()}, - {mfa, {?MODULE, erlang_ssl_receive, [Data]}}, - {reconnect_times, 5}, - {options, ServerOpts}]), + {from, self()}, + {mfa, {?MODULE, erlang_ssl_receive, [Data]}}, + {reconnect_times, 5}, + {options, ServerOpts}]), Port = ssl_test_lib:inet_port(Server), Version = ssl_test_lib:protocol_version(Config), - + Exe = "openssl", Args = ["s_client", "-connect", hostname_format(Hostname) ++ ":" ++ integer_to_list(Port), - ssl_test_lib:version_flag(Version), - "-reconnect"], + ssl_test_lib:version_flag(Version), + "-reconnect"], OpenSslPort = ssl_test_lib:portable_open_port(Exe, Args), @@ -706,7 +695,7 @@ erlang_server_openssl_client_reuse_session(Config) when is_list(Config) -> %% Clean close down! Server needs to be closed first !! ssl_test_lib:close(Server), ssl_test_lib:close_port(OpenSslPort), - process_flag(trap_exit, false), + process_flag(trap_exit, false), ok. %%-------------------------------------------------------------------- @@ -730,46 +719,46 @@ erlang_client_openssl_server_renegotiate(Config) when is_list(Config) -> Exe = "openssl", Args = ["s_server", "-accept", integer_to_list(Port), - ssl_test_lib:version_flag(Version), - "-cert", CertFile, "-key", KeyFile, "-msg"], + ssl_test_lib:version_flag(Version), + "-cert", CertFile, "-key", KeyFile, "-msg"], OpensslPort = ssl_test_lib:portable_open_port(Exe, Args), 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}, - {from, self()}, - {mfa, {?MODULE, - delayed_send, [[ErlData, OpenSslData]]}}, - {options, ClientOpts}]), + {host, Hostname}, + {from, self()}, + {mfa, {?MODULE, + delayed_send, [[ErlData, OpenSslData]]}}, + {options, ClientOpts}]), true = port_command(OpensslPort, ?OPENSSL_RENEGOTIATE), ct:sleep(?SLEEP), true = port_command(OpensslPort, OpenSslData), ssl_test_lib:check_result(Client, ok), - - %% Clean close down! Server needs to be closed first !! + + %% Clean close down! Server needs to be closed first !! ssl_test_lib:close_port(OpensslPort), ssl_test_lib:close(Client), - process_flag(trap_exit, false), + process_flag(trap_exit, false), ok. %%-------------------------------------------------------------------- erlang_client_openssl_server_nowrap_seqnum() -> [{doc, "Test that erlang client will renegotiate session when", - "max sequence number celing is about to be reached. Although" - "in the testcase we use the test option renegotiate_at" - " to lower treashold substantially."}]. + "max sequence number celing is about to be reached. Although" + "in the testcase we use the test option renegotiate_at" + " to lower treashold substantially."}]. erlang_client_openssl_server_nowrap_seqnum(Config) when is_list(Config) -> process_flag(trap_exit, true), ServerOpts = ssl_test_lib:ssl_options(server_rsa_opts, Config), ClientOpts = ssl_test_lib:ssl_options(client_rsa_opts, Config), {ClientNode, _, Hostname} = ssl_test_lib:run_where(Config), - + ErlData = "From erlang to openssl\n", N = 10, @@ -779,21 +768,21 @@ erlang_client_openssl_server_nowrap_seqnum(Config) when is_list(Config) -> Version = ssl_test_lib:protocol_version(Config), Exe = "openssl", Args = ["s_server", "-accept", integer_to_list(Port), - ssl_test_lib:version_flag(Version), - "-cert", CertFile, "-key", KeyFile, "-msg"], - + ssl_test_lib:version_flag(Version), + "-cert", CertFile, "-key", KeyFile, "-msg"], + OpensslPort = ssl_test_lib:portable_open_port(Exe, Args), 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}, - {from, self()}, - {mfa, {ssl_test_lib, - trigger_renegotiate, [[ErlData, N+2]]}}, - {options, [{reuse_sessions, false}, - {renegotiate_at, N} | ClientOpts]}]), - + {host, Hostname}, + {from, self()}, + {mfa, {ssl_test_lib, + trigger_renegotiate, [[ErlData, N+2]]}}, + {options, [{reuse_sessions, false}, + {renegotiate_at, N} | ClientOpts]}]), + ssl_test_lib:check_result(Client, ok), %% Clean close down! Server needs to be closed first !! @@ -803,37 +792,37 @@ erlang_client_openssl_server_nowrap_seqnum(Config) when is_list(Config) -> %%-------------------------------------------------------------------- erlang_server_openssl_client_nowrap_seqnum() -> [{doc, "Test that erlang client will renegotiate session when", - "max sequence number celing is about to be reached. Although" - "in the testcase we use the test option renegotiate_at" - " to lower treashold substantially."}]. + "max sequence number celing is about to be reached. Although" + "in the testcase we use the test option renegotiate_at" + " to lower treashold substantially."}]. erlang_server_openssl_client_nowrap_seqnum(Config) when is_list(Config) -> process_flag(trap_exit, true), ServerOpts = ssl_test_lib:ssl_options(server_rsa_opts, Config), {_, ServerNode, Hostname} = ssl_test_lib:run_where(Config), - + Data = "From openssl to erlang", - + N = 10, Server = ssl_test_lib:start_server([{node, ServerNode}, {port, 0}, - {from, self()}, - {mfa, {ssl_test_lib, - trigger_renegotiate, [[Data, N+2]]}}, - {options, [{renegotiate_at, N}, {reuse_sessions, false} | ServerOpts]}]), + {from, self()}, + {mfa, {ssl_test_lib, + trigger_renegotiate, [[Data, N+2]]}}, + {options, [{renegotiate_at, N}, {reuse_sessions, false} | ServerOpts]}]), Port = ssl_test_lib:inet_port(Server), Version = ssl_test_lib:protocol_version(Config), Exe = "openssl", Args = ["s_client","-connect", hostname_format(Hostname) ++ ":" ++ integer_to_list(Port), - ssl_test_lib:version_flag(Version), - "-msg"], - + ssl_test_lib:version_flag(Version), + "-msg"], + OpenSslPort = ssl_test_lib:portable_open_port(Exe, Args), true = port_command(OpenSslPort, Data), - + ssl_test_lib:check_result(Server, ok), - + %% Clean close down! Server needs to be closed first !! ssl_test_lib:close(Server), ssl_test_lib:close_port(OpenSslPort), @@ -843,15 +832,15 @@ erlang_server_openssl_client_nowrap_seqnum(Config) when is_list(Config) -> erlang_client_openssl_server_no_server_ca_cert() -> [{doc, "Test erlang client when openssl server sends a cert chain not" - "including the ca cert. Explicitly test this even if it is" - "implicitly tested eleswhere."}]. + "including the ca cert. Explicitly test this even if it is" + "implicitly tested eleswhere."}]. erlang_client_openssl_server_no_server_ca_cert(Config) when is_list(Config) -> process_flag(trap_exit, true), ServerOpts = ssl_test_lib:ssl_options(server_rsa_opts, Config), ClientOpts = ssl_test_lib:ssl_options(client_rsa_opts, Config), {ClientNode, _, Hostname} = ssl_test_lib:run_where(Config), - + Data = "From openssl to erlang", Port = ssl_test_lib:inet_port(node()), @@ -860,22 +849,22 @@ erlang_client_openssl_server_no_server_ca_cert(Config) when is_list(Config) -> Version = ssl_test_lib:protocol_version(Config), Exe = "openssl", Args = ["s_server", "-accept", integer_to_list(Port), - ssl_test_lib:version_flag(Version), - "-cert", CertFile, "-key", KeyFile, "-msg"], - + ssl_test_lib:version_flag(Version), + "-cert", CertFile, "-key", KeyFile, "-msg"], + OpensslPort = ssl_test_lib:portable_open_port(Exe, Args), - + 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}, - {from, self()}, - {mfa, {?MODULE, - erlang_ssl_receive, [Data]}}, - {options, ClientOpts}]), + {host, Hostname}, + {from, self()}, + {mfa, {?MODULE, + erlang_ssl_receive, [Data]}}, + {options, ClientOpts}]), true = port_command(OpensslPort, Data), - + ssl_test_lib:check_result(Client, ok), %% Clean close down! Server needs to be closed first !! @@ -892,9 +881,9 @@ erlang_client_openssl_server_client_cert(Config) when is_list(Config) -> ClientOpts = ssl_test_lib:ssl_options(client_rsa_verify_opts, Config), {ClientNode, _, Hostname} = ssl_test_lib:run_where(Config), - + Data = "From openssl to erlang", - + Port = ssl_test_lib:inet_port(node()), CertFile = proplists:get_value(certfile, ServerOpts), CaCertFile = proplists:get_value(cacertfile, ServerOpts), @@ -902,31 +891,30 @@ erlang_client_openssl_server_client_cert(Config) when is_list(Config) -> Version = ssl_test_lib:protocol_version(Config), Exe = "openssl", Args = ["s_server", "-accept", integer_to_list(Port), - ssl_test_lib:version_flag(Version), - "-cert", CertFile, "-CAfile", CaCertFile, - "-key", KeyFile, "-Verify", "2"], - + ssl_test_lib:version_flag(Version), + "-cert", CertFile, "-CAfile", CaCertFile, + "-key", KeyFile, "-Verify", "2"], + OpensslPort = ssl_test_lib:portable_open_port(Exe, Args), 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}, - {from, self()}, - {mfa, {?MODULE, - erlang_ssl_receive, [Data]}}, - {options, ClientOpts}]), + {host, Hostname}, + {from, self()}, + {mfa, {?MODULE, + erlang_ssl_receive, [Data]}}, + {options, ClientOpts}]), true = port_command(OpensslPort, Data), - + ssl_test_lib:check_result(Client, ok), - + %% Clean close down! Server needs to be closed first !! ssl_test_lib:close_port(OpensslPort), ssl_test_lib:close(Client), process_flag(trap_exit, false). %%-------------------------------------------------------------------- - erlang_server_openssl_client_client_cert() -> [{doc,"Test erlang server with openssl client when client sends cert"}]. erlang_server_openssl_client_client_cert(Config) when is_list(Config) -> @@ -935,39 +923,38 @@ erlang_server_openssl_client_client_cert(Config) when is_list(Config) -> ClientOpts = ssl_test_lib:ssl_options(client_rsa_verify_opts, Config), {_, ServerNode, Hostname} = ssl_test_lib:run_where(Config), - + Data = "From openssl to erlang", Server = ssl_test_lib:start_server([{node, ServerNode}, {port, 0}, - {from, self()}, - {mfa, {?MODULE, - erlang_ssl_receive, [Data]}}, - {options, - [{verify , verify_peer} - | ServerOpts]}]), + {from, self()}, + {mfa, {?MODULE, + erlang_ssl_receive, [Data]}}, + {options, + [{verify , verify_peer} + | ServerOpts]}]), Port = ssl_test_lib:inet_port(Server), - + CaCertFile = proplists:get_value(cacertfile, ClientOpts), CertFile = proplists:get_value(certfile, ClientOpts), KeyFile = proplists:get_value(keyfile, ClientOpts), Version = ssl_test_lib:protocol_version(Config), Exe = "openssl", Args = ["s_client", "-cert", CertFile, - "-CAfile", CaCertFile, - "-key", KeyFile,"-connect", hostname_format(Hostname) ++ ":" ++ integer_to_list(Port), - ssl_test_lib:version_flag(Version)], + "-CAfile", CaCertFile, + "-key", KeyFile,"-connect", hostname_format(Hostname) ++ ":" ++ integer_to_list(Port), + ssl_test_lib:version_flag(Version)], OpenSslPort = ssl_test_lib:portable_open_port(Exe, Args), true = port_command(OpenSslPort, Data), ssl_test_lib:check_result(Server, ok), - + %% Clean close down! Server needs to be closed first !! ssl_test_lib:close_port(OpenSslPort), ssl_test_lib:close(Server), process_flag(trap_exit, false). %%-------------------------------------------------------------------- - erlang_server_erlang_client_client_cert() -> [{doc,"Test erlang server with erlang client when client sends cert"}]. erlang_server_erlang_client_client_cert(Config) when is_list(Config) -> @@ -976,30 +963,30 @@ erlang_server_erlang_client_client_cert(Config) when is_list(Config) -> ClientOpts = proplists:get_value(client_rsa_verify_opts, Config), Version = ssl_test_lib:protocol_version(Config), {ClientNode, ServerNode, Hostname} = ssl_test_lib:run_where(Config), - + Data = "From erlang to erlang", Server = ssl_test_lib:start_server([{node, ServerNode}, {port, 0}, - {from, self()}, - {mfa, {?MODULE, - erlang_ssl_receive, - %% Due to 1/n-1 splitting countermeasure Rizzo/Duong-Beast - [Data]}}, - {options, - [{verify , verify_peer} - | ServerOpts]}]), + {from, self()}, + {mfa, {?MODULE, + erlang_ssl_receive, + %% Due to 1/n-1 splitting countermeasure Rizzo/Duong-Beast + [Data]}}, + {options, + [{verify , verify_peer} + | ServerOpts]}]), Port = ssl_test_lib:inet_port(Server), - + Client = ssl_test_lib:start_client([{node, ClientNode}, {port, Port}, - {host, Hostname}, - {from, self()}, - %% Due to 1/n-1 splitting countermeasure Rizzo/Duong-Beast - {mfa, {ssl, send, [Data]}}, - {options, - [{versions, [Version]} | ClientOpts]}]), - + {host, Hostname}, + {from, self()}, + %% Due to 1/n-1 splitting countermeasure Rizzo/Duong-Beast + {mfa, {ssl, send, [Data]}}, + {options, + [{versions, [Version]} | ClientOpts]}]), + ssl_test_lib:check_result(Server, ok, Client, ok), - + ssl_test_lib:close(Server), ssl_test_lib:close(Client), process_flag(trap_exit, false). @@ -1031,43 +1018,43 @@ erlang_client_bad_openssl_server(Config) when is_list(Config) -> ClientOpts = ssl_test_lib:ssl_options(client_rsa_opts, Config), {ClientNode, _, Hostname} = ssl_test_lib:run_where(Config), - + Port = ssl_test_lib:inet_port(node()), CertFile = proplists:get_value(certfile, ServerOpts), KeyFile = proplists:get_value(keyfile, ServerOpts), Version = ssl_test_lib:protocol_version(Config), Exe = "openssl", Args = ["s_server", "-accept", integer_to_list(Port), ssl_test_lib:version_flag(Version), - "-cert", CertFile, "-key", KeyFile], + "-cert", CertFile, "-key", KeyFile], OpensslPort = ssl_test_lib:portable_open_port(Exe, Args), - + 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}, - {from, self()}, - {mfa, {?MODULE, server_sent_garbage, []}}, - {options, - [{versions, [Version]} | ClientOpts]}]), - + {host, Hostname}, + {from, self()}, + {mfa, {?MODULE, server_sent_garbage, []}}, + {options, + [{versions, [Version]} | ClientOpts]}]), + %% Send garbage true = port_command(OpensslPort, ?OPENSSL_GARBAGE), ct:sleep(?SLEEP), Client0 ! server_sent_garbage, - + ssl_test_lib:check_result(Client0, true), - + ssl_test_lib:close(Client0), - + %% Make sure openssl does not hang and leave zombie process Client1 = ssl_test_lib:start_client([{node, ClientNode}, {port, Port}, - {host, Hostname}, - {from, self()}, - {mfa, {ssl_test_lib, no_result_msg, []}}, - {options, - [{versions, [Version]} | ClientOpts]}]), + {host, Hostname}, + {from, self()}, + {mfa, {ssl_test_lib, no_result_msg, []}}, + {options, + [{versions, [Version]} | ClientOpts]}]), %% Clean close down! Server needs to be closed first !! ssl_test_lib:close_port(OpensslPort), @@ -1092,38 +1079,38 @@ expired_session(Config) when is_list(Config) -> Exe = "openssl", Args = ["s_server", "-accept", integer_to_list(Port), - "-cert", CertFile,"-key", KeyFile], - + "-cert", CertFile,"-key", KeyFile], + OpensslPort = ssl_test_lib:portable_open_port(Exe, Args), ssl_test_lib:wait_for_openssl_server(Port, tls), - + Client0 = - ssl_test_lib:start_client([{node, ClientNode}, - {port, Port}, {host, Hostname}, - {mfa, {ssl_test_lib, no_result, []}}, - {from, self()}, {options, ClientOpts}]), - + ssl_test_lib:start_client([{node, ClientNode}, + {port, Port}, {host, Hostname}, + {mfa, {ssl_test_lib, no_result, []}}, + {from, self()}, {options, ClientOpts}]), + ssl_test_lib:close(Client0), %% Make sure session is registered ct:sleep(?SLEEP), Client1 = - ssl_test_lib:start_client([{node, ClientNode}, - {port, Port}, {host, Hostname}, - {mfa, {ssl_test_lib, no_result, []}}, - {from, self()}, {options, ClientOpts}]), - + ssl_test_lib:start_client([{node, ClientNode}, + {port, Port}, {host, Hostname}, + {mfa, {ssl_test_lib, no_result, []}}, + {from, self()}, {options, ClientOpts}]), + ssl_test_lib:close(Client1), %% Make sure session is unregistered due to expiration ct:sleep((?EXPIRE+1) * 1000), - + Client2 = - ssl_test_lib:start_client([{node, ClientNode}, - {port, Port}, {host, Hostname}, - {mfa, {ssl_test_lib, no_result, []}}, - {from, self()}, {options, ClientOpts}]), + ssl_test_lib:start_client([{node, ClientNode}, + {port, Port}, {host, Hostname}, + {mfa, {ssl_test_lib, no_result, []}}, + {from, self()}, {options, ClientOpts}]), %% Clean close down! Server needs to be closed first !! ssl_test_lib:close_port(OpensslPort), @@ -1139,52 +1126,21 @@ ssl2_erlang_server_openssl_client(Config) when is_list(Config) -> ServerOpts = ssl_test_lib:ssl_options(server_rsa_opts, Config), {_, ServerNode, Hostname} = ssl_test_lib:run_where(Config), - - Server = ssl_test_lib:start_server_error([{node, ServerNode}, {port, 0}, - {from, self()}, - {options, ServerOpts}]), - Port = ssl_test_lib:inet_port(Server), - - Exe = "openssl", - Args = ["s_client", "-connect", hostname_format(Hostname) ++ ":" ++ integer_to_list(Port), - "-ssl2", "-msg"], - - OpenSslPort = ssl_test_lib:portable_open_port(Exe, Args), - - ct:log("Ports ~p~n", [[erlang:port_info(P) || P <- erlang:ports()]]), - consume_port_exit(OpenSslPort), - ssl_test_lib:check_result(Server, {error, {tls_alert, "bad record mac"}}), - process_flag(trap_exit, false). -%%-------------------------------------------------------------------- -ssl2_erlang_server_openssl_client_comp() -> - [{doc,"Test that ssl v2 clients are rejected"}]. - -ssl2_erlang_server_openssl_client_comp(Config) when is_list(Config) -> - process_flag(trap_exit, true), - ServerOpts = ssl_test_lib:ssl_options(server_rsa_opts, Config), - V2Compat = proplists:get_value(v2_hello_compatible, Config), - - ServerOpts = ssl_test_lib:ssl_options(server_rsa_opts, Config), - - {_, ServerNode, Hostname} = ssl_test_lib:run_where(Config), - - Data = "From openssl to erlang", Server = ssl_test_lib:start_server_error([{node, ServerNode}, {port, 0}, - {from, self()}, - {options, [{v2_hello_compatible, V2Compat} | ServerOpts]}]), + {from, self()}, + {options, ServerOpts}]), Port = ssl_test_lib:inet_port(Server), - + Exe = "openssl", Args = ["s_client", "-connect", hostname_format(Hostname) ++ ":" ++ integer_to_list(Port), - "-ssl2", "-msg"], - + "-ssl2", "-msg"], + OpenSslPort = ssl_test_lib:portable_open_port(Exe, Args), - true = port_command(OpenSslPort, Data), - + ct:log("Ports ~p~n", [[erlang:port_info(P) || P <- erlang:ports()]]), consume_port_exit(OpenSslPort), - ssl_test_lib:check_result(Server, {error, {tls_alert, "protocol version"}}), + ssl_test_lib:check_result(Server, {error, {tls_alert, "bad record mac"}}), process_flag(trap_exit, false). %%-------------------------------------------------------------------- @@ -2012,3 +1968,11 @@ hostname_format(Hostname) -> false -> "localhost" end. + +no_v2_flag() -> + case ssl_test_lib:supports_ssl_tls_version(sslv2) of + true -> + " -no_ssl2 "; + false -> + "" + end. diff --git a/lib/stdlib/doc/src/Makefile b/lib/stdlib/doc/src/Makefile index e7ea38c5c3..508a4fa2de 100644 --- a/lib/stdlib/doc/src/Makefile +++ b/lib/stdlib/doc/src/Makefile @@ -98,6 +98,7 @@ XML_REF3_FILES = \ sys.xml \ timer.xml \ unicode.xml \ + uri_string.xml \ win32reg.xml \ zip.xml @@ -162,7 +163,7 @@ clean clean_docs: rm -f errs core *~ $(SPECDIR)/specs_erl_id_trans.xml: - escript $(SPECS_EXTRACTOR) $(SPECS_FLAGS) \ + $(gen_verbose)escript $(SPECS_EXTRACTOR) $(SPECS_FLAGS) \ -o$(dir $@) -module erl_id_trans # ---------------------------------------------------- diff --git a/lib/stdlib/doc/src/c.xml b/lib/stdlib/doc/src/c.xml index 7666699183..697e1715e7 100644 --- a/lib/stdlib/doc/src/c.xml +++ b/lib/stdlib/doc/src/c.xml @@ -94,6 +94,15 @@ </func> <func> + <name name="erlangrc" arity="1"/> + <fsummary>Load an erlang resource file.</fsummary> + <desc> + <p>Search <c>PathList</c> and load <c>.erlang</c> resource file if + found.</p> + </desc> + </func> + + <func> <name name="flush" arity="0"/> <fsummary>Flush any messages sent to the shell.</fsummary> <desc> diff --git a/lib/stdlib/doc/src/calendar.xml b/lib/stdlib/doc/src/calendar.xml index 65b3edcdf6..0c4a30ce16 100644 --- a/lib/stdlib/doc/src/calendar.xml +++ b/lib/stdlib/doc/src/calendar.xml @@ -4,7 +4,7 @@ <erlref> <header> <copyright> - <year>1996</year><year>2016</year> + <year>1996</year><year>2018</year> <holder>Ericsson AB. All Rights Reserved.</holder> </copyright> <legalnotice> @@ -339,6 +339,22 @@ </func> <func> + <name name="system_time_to_local_time" arity="2"/> + <fsummary>Convert system time to local date and time.</fsummary> + <desc> + <p>Converts a specified system time into local date and time.</p> + </desc> + </func> + + <func> + <name name="system_time_to_universal_time" arity="2"/> + <fsummary>Convert system time to universal date and time.</fsummary> + <desc> + <p>Converts a specified system time into universal date and time.</p> + </desc> + </func> + + <func> <name name="time_difference" arity="2"/> <fsummary>Compute the difference between two times (deprecated). </fsummary> diff --git a/lib/stdlib/doc/src/erl_tar.xml b/lib/stdlib/doc/src/erl_tar.xml index 337028568a..68fa071090 100644 --- a/lib/stdlib/doc/src/erl_tar.xml +++ b/lib/stdlib/doc/src/erl_tar.xml @@ -4,7 +4,7 @@ <erlref> <header> <copyright> - <year>2003</year><year>2017</year> + <year>2003</year><year>2018</year> <holder>Ericsson AB. All Rights Reserved.</holder> </copyright> <legalnotice> @@ -90,8 +90,8 @@ <section> <title>Other Storage Media</title> - <p>The <seealso marker="inets:ftp"><c>ftp</c></seealso> - module (Inets) normally accesses the tar file on disk using + <p>The <seealso marker="ftp:ftp"><c>ftp</c></seealso> + module normally accesses the tar file on disk using the <seealso marker="kernel:file"><c>file</c></seealso> module. When other needs arise, you can define your own low-level Erlang functions to perform the writing and reading on the storage media; @@ -136,6 +136,9 @@ <v>Filename = filename()|{NameInArchive,FilenameOrBin}</v> <v>Options = [Option]</v> <v>Option = dereference|verbose|{chunks,ChunkSize}</v> + <v>|{atime,non_neg_integer()}|{mtime,non_neg_integer()}</v> + <v>|{ctime,non_neg_integer()}|{uid,non_neg_integer()}</v> + <v>|{gid,non_neg_integer()}</v> <v>ChunkSize = positive_integer()</v> <v>RetValue = ok|{error,{Filename,Reason}}</v> <v>Reason = term()</v> @@ -167,6 +170,42 @@ <seealso marker="ssh:ssh_sftp#open_tar/3"> <c>ssh_sftp:open_tar/3</c></seealso>.</p> </item> + <tag><c>{atime,non_neg_integer()}</c></tag> + <item> + <p>Sets the last time, as + <seealso marker="erts:time_correction#POSIX_Time"> + POSIX time</seealso>, when the file was read. See also + <seealso marker="kernel:file#read_file_info/1"> + <c>file:read_file_info/1</c></seealso>.</p> + </item> + <tag><c>{mtime,non_neg_integer()}</c></tag> + <item> + <p>Sets the last time, as + <seealso marker="erts:time_correction#POSIX_Time"> + POSIX time</seealso>, when the file was written. See also + <seealso marker="kernel:file#read_file_info/1"> + <c>file:read_file_info/1</c></seealso>.</p> + </item> + <tag><c>{ctime,non_neg_integer()}</c></tag> + <item> + <p>Sets the time, as + <seealso marker="erts:time_correction#POSIX_Time"> + POSIX time</seealso>, when the file was created. See also + <seealso marker="kernel:file#read_file_info/1"> + <c>file:read_file_info/1</c></seealso>.</p> + </item> + <tag><c>{uid,non_neg_integer()}</c></tag> + <item> + <p>Sets the file owner. + <seealso marker="kernel:file#read_file_info/1"> + <c>file:read_file_info/1</c></seealso>.</p> + </item> + <tag><c>{gid,non_neg_integer()}</c></tag> + <item> + <p>Sets the group that the file owner belongs to. + <seealso marker="kernel:file#read_file_info/1"> + <c>file:read_file_info/1</c></seealso>.</p> + </item> </taglist> </desc> </func> @@ -378,7 +417,7 @@ <v>Reason = term()</v> </type> <desc> - <p>Cconverts an error reason term to a human-readable error message + <p>Converts an error reason term to a human-readable error message string.</p> </desc> </func> diff --git a/lib/stdlib/doc/src/ets.xml b/lib/stdlib/doc/src/ets.xml index 51e35cd2df..305376a425 100644 --- a/lib/stdlib/doc/src/ets.xml +++ b/lib/stdlib/doc/src/ets.xml @@ -487,6 +487,11 @@ Error: fun containing local Erlang function calls <p>The pid of the heir of the table, or <c>none</c> if no heir is set.</p> </item> + <tag><c>{id,</c><seealso marker="#type-tid"> + <c>tid()</c></seealso><c>}</c></tag> + <item> + <p>The table identifier.</p> + </item> <tag><c>{keypos, integer() >= 1}</c></tag> <item> <p>The key position.</p> @@ -1074,10 +1079,13 @@ ets:select(Table, MatchSpec),</code> </item> <tag><c>named_table</c></tag> <item> - <p>If this option is present, name <c><anno>Name</anno></c> is - associated with the table identifier. The name can then - be used instead of the table identifier in subsequent - operations.</p> + <p>If this option is present, the table is registered under its + <c><anno>Name</anno></c> which can then be used instead of the + table identifier in subsequent operations.</p> + <p>The function will also return the <c><anno>Name</anno></c> + instead of the table identifier. To get the table identifier of a + named table, use + <seealso marker="#whereis/1"><c>whereis/1</c></seealso>.</p> </item> <tag><c>{keypos,<anno>Pos</anno>}</c></tag> <item> @@ -1961,7 +1969,7 @@ true</pre> The return value is a list of the new counter values from each update operation in the same order as in the operation list. If an empty list is specified, nothing is updated and an empty list is - returned. If the function fails, no updates is done.</p> + returned. If the function fails, no updates are done.</p> <p>The specified <c><anno>Key</anno></c> is used to identify the object by either <em>matching</em> the key of an object in a <c>set</c> table, or <em>compare equal</em> to the key of an object in an @@ -2037,6 +2045,21 @@ true</pre> </list> </desc> </func> + + <func> + <name name="whereis" arity="1"/> + <fsummary>Retrieves the tid() of a named table.</fsummary> + <desc> + <p>This function returns the + <seealso marker="#type-tid"><c>tid()</c></seealso> of the named table + identified by <c><anno>TableName</anno></c>, or <c>undefined</c> if + no such table exists. The <c>tid()</c> can be used in place of the + table name in all operations, which is slightly faster since the name + does not have to be resolved on each call.</p> + <p>If the table is deleted, the <c>tid()</c> will be invalid even if + another named table is created with the same name.</p> + </desc> + </func> </funcs> </erlref> diff --git a/lib/stdlib/doc/src/filelib.xml b/lib/stdlib/doc/src/filelib.xml index 11762a3c5a..3b5be75bc0 100644 --- a/lib/stdlib/doc/src/filelib.xml +++ b/lib/stdlib/doc/src/filelib.xml @@ -45,6 +45,30 @@ <p>For more information about raw filenames, see the <seealso marker="kernel:file"><c>file</c></seealso> module.</p> + + <note> + <p> + Functionality in this module generally assumes valid input and + does not necessarily fail on input that does not use a valid + encoding, but may instead very likely produce invalid output. + </p> + <p> + File operations used to accept filenames containing + null characters (integer value zero). This caused + the name to be truncated and in some cases arguments + to primitive operations to be mixed up. Filenames + containing null characters inside the filename + are now <em>rejected</em> and will cause primitive + file operations to fail. + </p> + </note> + <warning><p> + Currently null characters at the end of the filename + will be accepted by primitive file operations. Such + filenames are however still documented as invalid. The + implementation will also change in the future and + reject such filenames. + </p></warning> </description> <datatypes> @@ -193,6 +217,11 @@ <p>Other characters represent themselves. Only filenames that have exactly the same character in the same position match. Matching is case-sensitive, for example, "a" does not match "A".</p> + <p>Directory separators must always be written as <c>/</c>, even on + Windows.</p> + <p>A character preceded by <c>\</c> loses its special meaning. Note + that <c>\</c> must be written as <c>\\</c> in a string literal. + For example, "\\?*" will match any filename starting with <c>?</c>.</p> <p>Notice that multiple "*" characters are allowed (as in Unix wildcards, but opposed to Windows/DOS wildcards).</p> <p><em>Examples:</em></p> diff --git a/lib/stdlib/doc/src/filename.xml b/lib/stdlib/doc/src/filename.xml index 1135a6dd80..ce19f70df0 100644 --- a/lib/stdlib/doc/src/filename.xml +++ b/lib/stdlib/doc/src/filename.xml @@ -46,7 +46,10 @@ filename by removing redundant directory separators, use <seealso marker="#join/1"><c>join/1</c></seealso>.</p> - <p>The module supports raw filenames in the way that if a binary is + <p> + The module supports + <seealso marker="unicode_usage#notes-about-raw-filenames">raw + filenames</seealso> in the way that if a binary is present, or the filename cannot be interpreted according to the return value of <seealso marker="kernel:file#native_name_encoding/0"> <c>file:native_name_encoding/0</c></seealso>, a raw filename is also @@ -56,6 +59,30 @@ (the join operation is performed of course). For more information about raw filenames, see the <seealso marker="kernel:file"><c>file</c></seealso> module.</p> + + <note> + <p> + Functionality in this module generally assumes valid input and + does not necessarily fail on input that does not use a valid + encoding, but may instead very likely produce invalid output. + </p> + <p> + File operations used to accept filenames containing + null characters (integer value zero). This caused + the name to be truncated and in some cases arguments + to primitive operations to be mixed up. Filenames + containing null characters inside the filename + are now <em>rejected</em> and will cause primitive + file operations to fail. + </p> + </note> + <warning><p> + Currently null characters at the end of the filename + will be accepted by primitive file operations. Such + filenames are however still documented as invalid. The + implementation will also change in the future and + reject such filenames. + </p></warning> </description> <datatypes> <datatype> @@ -558,6 +585,7 @@ unsafe</pre> ["a:/","msdev","include"]</pre> </desc> </func> + </funcs> </erlref> diff --git a/lib/stdlib/doc/src/gb_sets.xml b/lib/stdlib/doc/src/gb_sets.xml index 7bfe477a11..2a3785dc27 100644 --- a/lib/stdlib/doc/src/gb_sets.xml +++ b/lib/stdlib/doc/src/gb_sets.xml @@ -83,6 +83,8 @@ </item> <item><seealso marker="#is_element/2"><c>is_element/2</c></seealso> </item> + <item><seealso marker="#is_empty/1"><c>is_empty/1</c></seealso> + </item> <item><seealso marker="#is_set/1"><c>is_set/1</c></seealso> </item> <item><seealso marker="#is_subset/2"><c>is_subset/2</c></seealso> diff --git a/lib/stdlib/doc/src/gen_server.xml b/lib/stdlib/doc/src/gen_server.xml index 7d137fc772..da74e793e6 100644 --- a/lib/stdlib/doc/src/gen_server.xml +++ b/lib/stdlib/doc/src/gen_server.xml @@ -60,6 +60,8 @@ gen_server:abcast -----> Module:handle_cast/2 - -----> Module:handle_info/2 +- -----> Module:handle_continue/2 + - -----> Module:terminate/2 - -----> Module:code_change/3</pre> @@ -88,6 +90,13 @@ gen_server:abcast -----> Module:handle_cast/2 implies at least two garbage collections (when hibernating and shortly after waking up) and is not something you want to do between each call to a busy server.</p> + + <p>If the <c>gen_server</c> process needs to perform an action + immediately after initialization or to break the execution of a + callback into multiple steps, it can return <c>{continue,Continue}</c> + in place of the time-out or hibernation value, which will immediately + invoke the <c>handle_continue/2</c> callback.</p> + </description> <funcs> @@ -610,12 +619,15 @@ gen_server:abcast -----> Module:handle_cast/2 <v>State = term()</v> <v>Result = {reply,Reply,NewState} | {reply,Reply,NewState,Timeout}</v> <v> | {reply,Reply,NewState,hibernate}</v> + <v> | {reply,Reply,NewState,{continue,Continue}}</v> <v> | {noreply,NewState} | {noreply,NewState,Timeout}</v> <v> | {noreply,NewState,hibernate}</v> + <v> | {noreply,NewState,{continue,Continue}}</v> <v> | {stop,Reason,Reply,NewState} | {stop,Reason,NewState}</v> <v> Reply = term()</v> <v> NewState = term()</v> <v> Timeout = int()>=0 | infinity</v> + <v> Continue = term()</v> <v> Reason = term()</v> </type> <desc> @@ -673,9 +685,11 @@ gen_server:abcast -----> Module:handle_cast/2 <v>State = term()</v> <v>Result = {noreply,NewState} | {noreply,NewState,Timeout}</v> <v> | {noreply,NewState,hibernate}</v> + <v> | {noreply,NewState,{continue,Continue}}</v> <v> | {stop,Reason,NewState}</v> <v> NewState = term()</v> <v> Timeout = int()>=0 | infinity</v> + <v> Continue = term()</v> <v> Reason = term()</v> </type> <desc> @@ -690,6 +704,41 @@ gen_server:abcast -----> Module:handle_cast/2 </func> <func> + <name>Module:handle_continue(Continue, State) -> Result</name> + <fsummary>Handle a continue instruction.</fsummary> + <type> + <v>Continue = term()</v> + <v>State = term()</v> + <v>Result = {noreply,NewState} | {noreply,NewState,Timeout}</v> + <v> | {noreply,NewState,hibernate}</v> + <v> | {noreply,NewState,{continue,Continue}}</v> + <v> | {stop,Reason,NewState}</v> + <v> NewState = term()</v> + <v> Timeout = int()>=0 | infinity</v> + <v> Continue = term()</v> + <v> Reason = normal | term()</v> + </type> + <desc> + <note> + <p>This callback is optional, so callback modules need to + export it only if they return <c>{continue,Continue}</c> + from another callback. If continue is used and the callback + is not implemented, the process will exit with <c>undef</c> + error.</p> + </note> + <p>This function is called by a <c>gen_server</c> process whenever + a previous callback returns <c>{continue, Continue}</c>. + <c>handle_continue/2</c> is invoked immediately after the previous + callback, which makes it useful for performing work after + initialization or for splitting the work in a callback in + multiple steps, updating the process state along the way.</p> + <p>For a description of the other arguments and possible return values, + see <seealso marker="#Module:handle_call/3"> + <c>Module:handle_call/3</c></seealso>.</p> + </desc> + </func> + + <func> <name>Module:handle_info(Info, State) -> Result</name> <fsummary>Handle an incoming message.</fsummary> <type> @@ -697,6 +746,7 @@ gen_server:abcast -----> Module:handle_cast/2 <v>State = term()</v> <v>Result = {noreply,NewState} | {noreply,NewState,Timeout}</v> <v> | {noreply,NewState,hibernate}</v> + <v> | {noreply,NewState,{continue,Continue}}</v> <v> | {stop,Reason,NewState}</v> <v> NewState = term()</v> <v> Timeout = int()>=0 | infinity</v> @@ -726,7 +776,7 @@ gen_server:abcast -----> Module:handle_cast/2 <type> <v>Args = term()</v> <v>Result = {ok,State} | {ok,State,Timeout} | {ok,State,hibernate}</v> - <v> | {stop,Reason} | ignore</v> + <v> | {ok,State,{continue,Continue}} | {stop,Reason} | ignore</v> <v> State = term()</v> <v> Timeout = int()>=0 | infinity</v> <v> Reason = term()</v> diff --git a/lib/stdlib/doc/src/gen_statem.xml b/lib/stdlib/doc/src/gen_statem.xml index 574f488e91..e918e83df7 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>2017</year> + <year>2016</year><year>2018</year> <holder>Ericsson AB. All Rights Reserved.</holder> </copyright> <legalnotice> @@ -32,7 +32,68 @@ <modulesummary>Generic state machine behavior.</modulesummary> <description> <p> - This behavior module provides a state machine. Two + <c>gen_statem</c> provides a generic state machine behaviour + and replaces its predecessor + <seealso marker="gen_fsm"><c>gen_fsm</c></seealso> + since Erlang/OTP 20.0. + </p> + <p> + This reference manual describes types generated from the types + in the <c>gen_statem</c> source code, so they are correct. + However, the generated descriptions also reflect the type hiearchy, + which makes them kind of hard to read. + </p> + <p> + To get an overview of the concepts and operation of <c>gen_statem</c>, + do read the + <seealso marker="doc/design_principles:statem"> + <c>gen_statem</c> Behaviour + </seealso> + in + <seealso marker="doc/design_principles:users_guide"> + OTP Design Principles + </seealso> + which frequently links back to this reference manual to avoid + containing detailed facts that may rot by age. + </p> + <note> + <p> + This behavior appeared in Erlang/OTP 19.0. + In OTP 19.1 a backwards incompatible change of + the return tuple from + <seealso marker="#Module:init/1"><c>Module:init/1</c></seealso> + was made and the mandatory callback function + <seealso marker="#Module:callback_mode/0"> + <c>Module:callback_mode/0</c> + </seealso> + was introduced. In OTP 20.0 the + <seealso marker="#type-generic_timeout"><c>generic timeouts</c></seealso> + were added. + </p> + </note> + <p> + <c>gen_statem</c> has got the same features that + <seealso marker="gen_fsm"><c>gen_fsm</c></seealso> + had and adds some really useful: + </p> + <list type="bulleted"> + <item>Co-located state code</item> + <item>Arbitrary term state</item> + <item>Event postponing</item> + <item>Self-generated events</item> + <item>State time-out</item> + <item>Multiple generic named time-outs</item> + <item>Absolute time-out time</item> + <item>Automatic state enter calls</item> + <item> + Reply from other state than the request, <c>sys</c> traceable + </item> + <item>Multiple <c>sys</c> traceable replies</item> + </list> + + + <p> + Two <seealso marker="#type-callback_mode"><em>callback modes</em></seealso> are supported: </p> @@ -50,34 +111,6 @@ </p> </item> </list> - <note> - <p> - This is a new behavior in Erlang/OTP 19.0. - It has been thoroughly reviewed, is stable enough - to be used by at least two heavy OTP applications, - and is here to stay. - Depending on user feedback, we do not expect - but can find it necessary to make minor - not backward compatible changes into Erlang/OTP 20.0. - </p> - </note> - <p> - The <c>gen_statem</c> behavior replaces - <seealso marker="gen_fsm"><c>gen_fsm</c> </seealso> in Erlang/OTP 20.0. - It has the same features and adds some really useful: - </p> - <list type="bulleted"> - <item>Gathered state code.</item> - <item>Arbitrary term state.</item> - <item>Event postponing.</item> - <item>Self-generated events.</item> - <item>State time-out.</item> - <item>Multiple generic named time-outs.</item> - <item>Absolute time-out time.</item> - <item>Automatic state enter calls.</item> - <item>Reply from other state than the request.</item> - <item>Multiple <c>sys</c> traceable replies.</item> - </list> <p> The callback model(s) for <c>gen_statem</c> differs from the one for <seealso marker="gen_fsm"><c>gen_fsm</c></seealso>, @@ -148,7 +181,7 @@ erlang:'!' -----> Module:StateName/3 is <c>state_functions</c>, the state must be an atom and is used as the state callback name; see <seealso marker="#Module:StateName/3"><c>Module:StateName/3</c></seealso>. - This gathers all code for a specific state + This co-locates all code for a specific state in one function as the <c>gen_statem</c> engine branches depending on state name. Note the fact that the callback function @@ -207,8 +240,10 @@ erlang:'!' -----> Module:StateName/3 whenever a new state is entered; see <seealso marker="#type-state_enter"><c>state_enter()</c></seealso>. This is for writing code common to all state entries. - Another way to do it is to insert events at state transitions, - but you have to do so everywhere it is needed. + Another way to do it is to insert an event at the state transition, + and/or to use a dedicated state transition function, + but that is something you will have to remember + at every state transition to the state(s) that need it. </p> <note> <p>If you in <c>gen_statem</c>, for example, postpone @@ -252,6 +287,16 @@ erlang:'!' -----> Module:StateName/3 to use after every event; see <seealso marker="erts:erlang#hibernate/3"><c>erlang:hibernate/3</c></seealso>. </p> + <p> + There is also a server start option + <seealso marker="#type-hibernate_after_opt"> + <c>{hibernate_after, Timeout}</c> + </seealso> + for + <seealso marker="#start/3"><c>start/3,4</c></seealso> or + <seealso marker="#start_link/3"><c>start_link/3,4</c></seealso> + that may be used to automatically hibernate the server. + </p> </description> <section> @@ -668,9 +713,9 @@ handle_event(_, _, State, Data) -> <p> If <seealso marker="#Module:code_change/4"><c>Module:code_change/4</c></seealso> - should transform the state to a state with a different - name it is still regarded as the same state so this - does not cause a state enter call. + should transform the state, + it is regarded as a state rename and not a state change, + which will not cause a state enter call. </p> <p> Note that a state enter call <em>will</em> be done @@ -688,12 +733,19 @@ handle_event(_, _, State, Data) -> <p> Transition options can be set by <seealso marker="#type-action">actions</seealso> - and they modify how the state transition is done: + and modify the state transition. + Here are the sequence of steps for a state transition: </p> <list type="ordered"> <item> <p> - If the state changes, is the initial state, + If + <seealso marker="#type-state_enter"> + <em>state enter calls</em> + </seealso> + are used, and either: + the state changes, it is the initial state, + or one of the callback results <seealso marker="#type-state_callback_result"> <c>repeat_state</c> </seealso> @@ -701,16 +753,21 @@ handle_event(_, _, State, Data) -> <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 + is used; the <c>gen_statem</c> calls the new state callback with arguments - <seealso marker="#type-state_enter">(enter, OldState, Data)</seealso>. + <seealso marker="#type-state_enter"><c>(enter, OldState, Data)</c></seealso>. + </p> + <p> Any - <seealso marker="#type-enter_action"><c>actions</c></seealso> + <seealso marker="#type-enter_action">actions</seealso> returned from this call are handled as if they were - appended to the actions - returned by the state callback that changed states. + appended to the actions + returned by the state callback that caused the state entry. + </p> + <p> + Should this state enter call return any of + the mentioned <c>repeat_*</c> callback results + it is repeated again, with the updated <c>Data</c>. </p> </item> <item> @@ -739,7 +796,7 @@ handle_event(_, _, State, Data) -> All events stored with <seealso marker="#type-action"><c>action()</c></seealso> <c>next_event</c> - are inserted to be processed before the other queued events. + are inserted to be processed before previously queued events. </p> </item> <item> @@ -753,7 +810,9 @@ handle_event(_, _, State, Data) -> delivered to the state machine before any external not yet received event so if there is such a time-out requested, the corresponding time-out zero event is enqueued as - the newest event. + the newest received event; + that is after already queued events + such as inserted and postponed events. </p> <p> Any event cancels an @@ -791,7 +850,7 @@ handle_event(_, _, State, Data) -> When a new message arrives the <seealso marker="#state callback">state callback</seealso> is called with the corresponding event, - and we start again from the top of this list. + and we start again from the top of this sequence. </p> </item> </list> @@ -816,13 +875,19 @@ handle_event(_, _, State, Data) -> <seealso marker="proc_lib#hibernate/3"><c>proc_lib:hibernate/3</c></seealso> before going into <c>receive</c> to wait for a new external event. - If there are enqueued events, - to prevent receiving any new event, an - <seealso marker="erts:erlang#garbage_collect/0"><c>erlang:garbage_collect/0</c></seealso> - is done instead to simulate - that the <c>gen_statem</c> entered hibernation - and immediately got awakened by the oldest enqueued event. </p> + <note> + <p> + If there are enqueued events to process + when hibrnation is requested, + this is optimized by not hibernating but instead calling + <seealso marker="erts:erlang#garbage_collect/0"> + <c>erlang:garbage_collect/0</c> + </seealso> + to simulate that the <c>gen_statem</c> entered hibernation + and immediately got awakened by an enqueued event. + </p> + </note> </desc> </datatype> <datatype> @@ -857,7 +922,7 @@ handle_event(_, _, State, Data) -> no timer is actually started, instead the the time-out event is enqueued to ensure that it gets processed before any not yet - received external event. + received external event, but after already queued events. </p> <p> Note that it is not possible nor needed to cancel this time-out, @@ -943,7 +1008,9 @@ handle_event(_, _, State, Data) -> If <c>Abs</c> is <c>true</c> an absolute timer is started, and if it is <c>false</c> a relative, which is the default. See - <seealso marker="erts:erlang#start_timer/4"><c>erlang:start_timer/4</c></seealso> + <seealso marker="erts:erlang#start_timer/4"> + <c>erlang:start_timer/4</c> + </seealso> for details. </p> <p> @@ -969,7 +1036,9 @@ handle_event(_, _, State, Data) -> </p> <p> Actions that set - <seealso marker="#type-transition_option">transition options</seealso> + <seealso marker="#type-transition_option"> + transition options + </seealso> override any previous of the same type, so the last in the containing list wins. For example, the last @@ -981,7 +1050,9 @@ handle_event(_, _, State, Data) -> <item> <p> Sets the - <seealso marker="#type-transition_option"><c>transition_option()</c></seealso> + <seealso marker="#type-transition_option"> + <c>transition_option()</c> + </seealso> <seealso marker="#type-postpone"><c>postpone()</c></seealso> for this state transition. This action is ignored when returned from @@ -994,7 +1065,11 @@ handle_event(_, _, State, Data) -> <tag><c>next_event</c></tag> <item> <p> - Stores the specified <c><anno>EventType</anno></c> + This action does not set any + <seealso marker="#type-transition_option"> + <c>transition_option()</c> + </seealso> + but instead stores the specified <c><anno>EventType</anno></c> and <c><anno>EventContent</anno></c> for insertion after all actions have been executed. </p> @@ -1066,15 +1141,15 @@ handle_event(_, _, State, Data) -> <seealso marker="#type-transition_option">transition options</seealso>. </p> <taglist> - <tag><c>Timeout</c></tag> + <tag><c>Time</c></tag> <item> <p> - Short for <c>{timeout,Timeout,Timeout}</c>, that is, + Short for <c>{timeout,Time,Time}</c>, that is, the time-out message is the time-out time. This form exists to make the <seealso marker="#state callback">state callback</seealso> - return value <c>{next_state,NextState,NewData,Timeout}</c> - allowed like for <c>gen_fsm</c>'s + return value <c>{next_state,NextState,NewData,Time}</c> + allowed like for <c>gen_fsm</c>. </p> </item> <tag><c>timeout</c></tag> @@ -1126,7 +1201,11 @@ handle_event(_, _, State, Data) -> <seealso marker="#enter_loop/5"><c>enter_loop/5,6</c></seealso>. </p> <p> - It replies to a caller waiting for a reply in + It does not set any + <seealso marker="#type-transition_option"> + <c>transition_option()</c> + </seealso> + but instead replies to a caller waiting for a reply in <seealso marker="#call/2"><c>call/2</c></seealso>. <c><anno>From</anno></c> must be the term from argument <seealso marker="#type-event_type"><c>{call,<anno>From</anno>}</c></seealso> @@ -1369,7 +1448,7 @@ handle_event(_, _, State, Data) -> <c><anno>T</anno></c> is the time-out time. <c>{clean_timeout,<anno>T</anno>}</c> works like just <c>T</c> described in the note above - and uses a proxy process for <c>T < infinity</c>, + and uses a proxy process while <c>{dirty_timeout,<anno>T</anno>}</c> bypasses the proxy process which is more lightweight. </p> @@ -1379,8 +1458,12 @@ handle_event(_, _, State, Data) -> with <c>{dirty_timeout,<anno>T</anno>}</c> to avoid that the calling process dies when the call times out, you will have to be prepared to handle - a late reply. - So why not just let the calling process die? + a late reply. Note that there is an odd chance + to get a late reply even with + <c>{dirty_timeout,infinity}</c> or <c>infinity</c> + for example in the event of network problems. + So why not just let the calling process die + by not catching the exception? </p> </note> <p> @@ -1891,7 +1974,7 @@ handle_event(_, _, State, Data) -> </p> <note> <p> - Note that if the <c>gen_statem</c> is started trough + Note that if the <c>gen_statem</c> is started through <seealso marker="proc_lib"><c>proc_lib</c></seealso> and <seealso marker="#enter_loop/4"><c>enter_loop/4-6</c></seealso>, @@ -2105,16 +2188,20 @@ init(Args) -> erlang:error(not_implemented, [Args]).</pre> 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. - 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 + Note that it is actually allowed to use + <c>{repeat_state, NewData, ...}</c> although it 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. + If you do not update <c>NewData</c> and have some + loop termination condition, or if you use + <c>{repeat_state_and_data, _}</c> or + <c>repeat_state_and_data</c> you have an infinite loop! 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. + <c>keep_state_and_data</c> + since changing states from a <em>state enter call</em> + is not possible anyway. </p> <p> Note the fact that you can use diff --git a/lib/stdlib/doc/src/io.xml b/lib/stdlib/doc/src/io.xml index 64fcf4379f..f1037ec76b 100644 --- a/lib/stdlib/doc/src/io.xml +++ b/lib/stdlib/doc/src/io.xml @@ -137,11 +137,11 @@ Hello world! ok</pre> <p>The general format of a control sequence is <c>~F.P.PadModC</c>.</p> - <p>Character <c>C</c> determines the type of control sequence - to be used, <c>F</c> and <c>P</c> are optional numeric - arguments. If <c>F</c>, <c>P</c>, or <c>Pad</c> is <c>*</c>, - the next argument in <c>Data</c> is used as the numeric value - of <c>F</c> or <c>P</c>.</p> + <p>The character <c>C</c> determines the type of control sequence + to be used. It is the only required field. All of <c>F</c>, + <c>P</c>, <c>Pad</c>, and <c>Mod</c> are optional. For example, + to use a <c>#</c> for <c>Pad</c> but use the default values for + <c>F</c> and <c>P</c>, you can write <c>~..#C</c>.</p> <list type="bulleted"> <item> <p><c>F</c> is the <c>field width</c> of the printed argument. A @@ -167,13 +167,26 @@ ok</pre> The default padding character is <c>' '</c> (space).</p> </item> <item> - <p><c>Mod</c> is the control sequence modifier. It is either a - single character (<c>t</c>, for Unicode - translation, and <c>l</c>, for stopping <c>p</c> and - <c>P</c> from detecting printable characters) - that changes the interpretation of <c>Data</c>.</p> + <p><c>Mod</c> is the control sequence modifier. This is + one or more characters that change the interpretation of + <c>Data</c>. The current modifiers are <c>t</c>, for Unicode + translation, and <c>l</c>, for stopping <c>p</c> and <c>P</c> + from detecting printable characters.</p> </item> </list> + <p>If <c>F</c>, <c>P</c>, or <c>Pad</c> is a <c>*</c> character, + the next argument in <c>Data</c> is used as the value. + For example:</p> + <pre> +1> <input>io:fwrite("~*.*.0f~n",[9, 5, 3.14159265]).</input> +003.14159 +ok</pre> + <p>To use a literal <c>*</c> character as <c>Pad</c>, it must be + passed as an argument:</p> + <pre> +2> <input>io:fwrite("~*.*.*f~n",[9, 5, $*, 3.14159265]).</input> +**3.14159 +ok</pre> <p><em>Available control sequences:</em></p> <taglist> <tag><c>~</c></tag> @@ -257,8 +270,9 @@ ok</pre> \x{400} ok 5> <input>io:fwrite("~s~n",[[1024]]).</input> -** exception exit: {badarg,[{io,format,[<0.26.0>,"~s~n",[[1024]]]}, - ...</pre> +** exception error: bad argument + in function io:format/3 + called as io:format(<0.53.0>,"~s~n",[[1024]])</pre> </item> <tag><c>w</c></tag> <item> @@ -276,10 +290,9 @@ ok <c>~w</c>, but breaks terms whose printed representation is longer than one line into many lines and indents each line sensibly. Left-justification is not supported. - It also tries to detect lists of - printable characters and to output these as strings. The - Unicode translation modifier is used for determining - what characters are printable, for example:</p> + It also tries to detect flat lists of + printable characters and output these as strings. + For example:</p> <pre> 1> <input>T = [{attributes,[[{id,age,1.50000},{mode,explicit},</input> <input>{typename,"INTEGER"}], [{id,cho},{mode,explicit},{typename,'Cho'}]]},</input> @@ -301,7 +314,7 @@ ok {mode,implicit}] ok</pre> <p>The field width specifies the maximum line length. - Defaults to 80. The precision specifies the initial + It defaults to 80. The precision specifies the initial indentation of the term. It defaults to the number of characters printed on this line in the <em>same</em> call to <seealso marker="#write/1"><c>write/1</c></seealso> or @@ -331,18 +344,53 @@ ok [{a,[97]}, {b,[98]}] ok</pre> - <p>Binaries that look like UTF-8 encoded strings are - output with the string syntax if the Unicode translation - modifier is specified:</p> + <p>The Unicode translation modifier <c>t</c> specifies how to treat + characters outside the Latin-1 range of codepoints, in + atoms, strings, and binaries. For example, printing an atom + containing a character > 255:</p> + <pre> +8> <input>io:fwrite("~p~n",[list_to_atom([1024])]).</input> +'\x{400}' +ok +9> <input>io:fwrite("~tp~n",[list_to_atom([1024])]).</input> +'Ѐ' +ok</pre> + <p>By default, Erlang only detects lists of characters + in the Latin-1 range as strings, but the <c>+pc unicode</c> + flag can be used to change this (see <seealso + marker="#printable_range/0"> + <c>printable_range/0</c></seealso> for details). For example:</p> + <pre> +10> <input>io:fwrite("~p~n",[[214]]).</input> +"Ö" +ok +11> <input>io:fwrite("~p~n",[[1024]]).</input> +[1024] +ok +12> <input>io:fwrite("~tp~n",[[1024]]).</input> +[1024] +ok +</pre> + <p>but if Erlang was started with <c>+pc unicode</c>:</p> <pre> -9> <input>io:fwrite("~p~n",[[1024]]).</input> +13> <input>io:fwrite("~p~n",[[1024]]).</input> [1024] -10> <input>io:fwrite("~tp~n",[[1024]]).</input> -"\x{400}" -11> <input>io:fwrite("~tp~n", [<<128,128>>]).</input> +ok +14> <input>io:fwrite("~tp~n",[[1024]]).</input> +"Ѐ" +ok</pre> + <p>Similarly, binaries that look like UTF-8 encoded strings + are output with the binary string syntax if the <c>t</c> + modifier is specified:</p> + <pre> +15> <input>io:fwrite("~p~n", [<<208,128>>]).</input> +<<208,128>> +ok +16> <input>io:fwrite("~tp~n", [<<208,128>>]).</input> +<<"Ѐ"/utf8>> +ok +17> <input>io:fwrite("~tp~n", [<<128,128>>]).</input> <<128,128>> -12> <input>io:fwrite("~tp~n", [<<208,128>>]).</input> -<<"\x{400}"/utf8>> ok</pre> </item> <tag><c>W</c></tag> @@ -454,12 +502,9 @@ ok</pre> abc def 'abc def' {foo,1} A ok 2> <input>io:fwrite("~s", [65]).</input> -** exception exit: {badarg,[{io,format,[<0.22.0>,"~s","A"]}, - {erl_eval,do_apply,5}, - {shell,exprs,6}, - {shell,eval_exprs,6}, - {shell,eval_loop,3}]} - in function io:o_request/2</pre> +** exception error: bad argument + in function io:format/3 + called as io:format(<0.53.0>,"~s","A")</pre> <p>In this example, an attempt was made to output the single character 65 with the aid of the string formatting directive <c>"~s"</c>.</p> diff --git a/lib/stdlib/doc/src/io_lib.xml b/lib/stdlib/doc/src/io_lib.xml index bc1d77ac83..4a2b425e8e 100644 --- a/lib/stdlib/doc/src/io_lib.xml +++ b/lib/stdlib/doc/src/io_lib.xml @@ -4,7 +4,7 @@ <erlref> <header> <copyright> - <year>1996</year><year>2017</year> + <year>1996</year><year>2018</year> <holder>Ericsson AB. All Rights Reserved.</holder> </copyright> <legalnotice> @@ -52,6 +52,9 @@ </desc> </datatype> <datatype> + <name name="chars_limit"/> + </datatype> + <datatype> <name name="depth"/> </datatype> <datatype> @@ -153,6 +156,27 @@ </func> <func> + <name name="format" arity="3"/> + <name name="fwrite" arity="3"/> + <fsummary>Write formatted output.</fsummary> + <desc> + <p>Returns a character list that represents <c><anno>Data</anno></c> + formatted in accordance with <c><anno>Format</anno></c> in + the same way as + <seealso marker="#fwrite/2"><c>fwrite/2</c></seealso> and + <seealso marker="#format/2"><c>format/2</c></seealso>, + but takes an extra argument, a list of options.</p> + <p>Available options:</p> + <taglist> + <tag><c><anno>CharsLimit</anno></c></tag> + <item> + <p>A soft limit on the number of characters returned.</p> + </item> + </taglist> + </desc> + </func> + + <func> <name name="fread" arity="2"/> <fsummary>Read formatted input.</fsummary> <desc> @@ -361,17 +385,24 @@ <fsummary>Write a term.</fsummary> <desc> <p>Returns a character list that represents <c><anno>Term</anno></c>. - Argument <c><anno>Depth</anno></c> controls the depth of the + Option <c><anno>Depth</anno></c> controls the depth of the structures written. When the specified depth is reached, everything below this level is replaced by "<c>...</c>". <c><anno>Depth</anno></c> defaults to -1, which means - no limitation.</p> + no limitation. Option <c><anno>CharsLimit</anno></c> puts a + soft limit on the number of characters returned. When the + number of characters is reached, remaining structures are + replaced by "<c>...</c>". <c><anno>CharsLimit</anno></c> + defaults to -1, which means no limit on the number of + characters returned.</p> <p><em>Example:</em></p> <pre> 1> <input>lists:flatten(io_lib:write({1,[2],[3],[4,5],6,7,8,9})).</input> "{1,[2],[3],[4,5],6,7,8,9}" 2> <input>lists:flatten(io_lib:write({1,[2],[3],[4,5],6,7,8,9}, 5)).</input> -"{1,[2],[3],[...],...}"</pre> +"{1,[2],[3],[...],...}" +3> <input>lists:flatten(io_lib:write({[1,2,3],[4,5],6,7,8,9}, [{chars_limit,20}])).</input> +"{[1,2|...],[4|...],...}"</pre> </desc> </func> diff --git a/lib/stdlib/doc/src/lists.xml b/lib/stdlib/doc/src/lists.xml index 7efafedc82..c3d5d7e07a 100644 --- a/lib/stdlib/doc/src/lists.xml +++ b/lib/stdlib/doc/src/lists.xml @@ -4,7 +4,7 @@ <erlref> <header> <copyright> - <year>1996</year><year>2017</year> + <year>1996</year><year>2018</year> <holder>Ericsson AB. All Rights Reserved.</holder> </copyright> <legalnotice> @@ -771,6 +771,18 @@ length(lists:seq(From, To, Incr)) =:= (To - From + Incr) div Incr</code> </func> <func> + <name name="search" arity="2"/> + <fsummary>Find the first element that satisfies a predicate.</fsummary> + <desc> + <p>If there is a <c><anno>Value</anno></c> in <c><anno>List</anno></c> + such that <c><anno>Pred</anno>(<anno>Value</anno>)</c> returns + <c>true</c>, returns <c>{value, <anno>Value</anno>}</c> + for the first such <c><anno>Value</anno></c>, + otherwise returns <c>false</c>.</p> + </desc> + </func> + + <func> <name name="splitwith" arity="2"/> <fsummary>Split a list into two lists based on a predicate.</fsummary> <desc> diff --git a/lib/stdlib/doc/src/maps.xml b/lib/stdlib/doc/src/maps.xml index 8c7270816b..987d92989d 100644 --- a/lib/stdlib/doc/src/maps.xml +++ b/lib/stdlib/doc/src/maps.xml @@ -33,16 +33,31 @@ <p>This module contains functions for maps processing.</p> </description> + <datatypes> + <datatype> + <name name="iterator"/> + <desc> + <p>An iterator representing the key value associations in a map.</p> + <p>Created using <seealso marker="#iterator-1"><c>maps:iterator/1</c></seealso>.</p> + <p>Consumed by <seealso marker="#next-1"><c>maps:next/1</c></seealso>, + <seealso marker="#filter-2"><c>maps:filter/2</c></seealso>, + <seealso marker="#fold-3"><c>maps:fold/3</c></seealso> and + <seealso marker="#map-2"><c>maps:map/2</c></seealso>.</p> + </desc> + </datatype> + </datatypes> + <funcs> <func> <name name="filter" arity="2"/> <fsummary>Select pairs that satisfy a predicate.</fsummary> <desc> - <p>Returns a map <c><anno>Map2</anno></c> for which predicate - <c><anno>Pred</anno></c> holds true in <c><anno>Map1</anno></c>.</p> + <p>Returns a map <c><anno>Map</anno></c> for which predicate + <c><anno>Pred</anno></c> holds true in <c><anno>MapOrIter</anno></c>.</p> <p>The call fails with a <c>{badmap,Map}</c> exception if - <c><anno>Map1</anno></c> is not a map, or with <c>badarg</c> if - <c><anno>Pred</anno></c> is not a function of arity 2.</p> + <c><anno>MapOrIter</anno></c> is not a map or valid iterator, + or with <c>badarg</c> if <c><anno>Pred</anno></c> is not a + function of arity 2.</p> <p><em>Example:</em></p> <code type="none"> > M = #{a => 2, b => 3, c=> 4, "a" => 1, "b" => 2, "c" => 4}, @@ -76,12 +91,16 @@ <fsummary></fsummary> <desc> <p>Calls <c>F(K, V, AccIn)</c> for every <c><anno>K</anno></c> to value - <c><anno>V</anno></c> association in <c><anno>Map</anno></c> in + <c><anno>V</anno></c> association in <c><anno>MapOrIter</anno></c> in any order. Function <c>fun F/3</c> must return a new accumulator, which is passed to the next successive call. This function returns the final value of the accumulator. The initial accumulator value <c><anno>Init</anno></c> is returned if the map is empty.</p> + <p>The call fails with a <c>{badmap,Map}</c> exception if + <c><anno>MapOrIter</anno></c> is not a map or valid iterator, + or with <c>badarg</c> if <c><anno>Fun</anno></c> is not a + function of arity 3.</p> <p><em>Example:</em></p> <code type="none"> > Fun = fun(K,V,AccIn) when is_list(K) -> AccIn + V end, @@ -169,6 +188,32 @@ false</code> </func> <func> + <name name="iterator" arity="1"/> + <fsummary>Create a map iterator.</fsummary> + <desc> + <p>Returns a map iterator <c><anno>Iterator</anno></c> that can + be used by <seealso marker="#next-1"><c>maps:next/1</c></seealso> + to traverse the key-value associations in a map. When iterating + over a map, the memory usage is guaranteed to be bounded no matter + the size of the map.</p> + <p>The call fails with a <c>{badmap,Map}</c> exception if + <c><anno>Map</anno></c> is not a map.</p> + <p><em>Example:</em></p> + <code type="none"> +> M = #{ a => 1, b => 2 }. +#{a => 1,b => 2} +> I = maps:iterator(M). +[{a,1},{b,2}] +> {K1, V1, I2} = maps:next(I). +{a,1,[{b,2}]} +> {K2, V2, I3} = maps:next(I2). +{b,2,[]} +> maps:next(I3). +none</code> + </desc> + </func> + + <func> <name name="keys" arity="1"/> <fsummary></fsummary> <desc> @@ -188,12 +233,16 @@ false</code> <name name="map" arity="2"/> <fsummary></fsummary> <desc> - <p>Produces a new map <c><anno>Map2</anno></c> by calling function + <p>Produces a new map <c><anno>Map</anno></c> by calling function <c>fun F(K, V1)</c> for every <c><anno>K</anno></c> to value - <c><anno>V1</anno></c> association in <c><anno>Map1</anno></c> in + <c><anno>V1</anno></c> association in <c><anno>MapOrIter</anno></c> in any order. Function <c>fun F/2</c> must return value <c><anno>V2</anno></c> to be associated with key <c><anno>K</anno></c> - for the new map <c><anno>Map2</anno></c>.</p> + for the new map <c><anno>Map</anno></c>.</p> + <p>The call fails with a <c>{badmap,Map}</c> exception if + <c><anno>MapOrIter</anno></c> is not a map or valid iterator, + or with <c>badarg</c> if <c><anno>Fun</anno></c> is not a + function of arity 2.</p> <p><em>Example:</em></p> <code type="none"> > Fun = fun(K,V1) when is_list(K) -> V1*2 end, @@ -234,6 +283,35 @@ false</code> </func> <func> + <name name="next" arity="1"/> + <fsummary>Get the next key and value from an iterator.</fsummary> + <desc> + <p>Returns the next key-value association in + <c><anno>Iterator</anno></c> and a new iterator for the + remaining associations in the iterator. + </p> + <p> + If there are no more associations in the iterator, + <c>none</c> is returned. + </p> + <p><em>Example:</em></p> + <code type="none"> +> Map = #{a => 1, b => 2, c => 3}. +#{a => 1,b => 2,c => 3} +> Iter = maps:iterator(Map). +[{a,1},{b,2},{c,3}] +> {_, _, Iter1} = maps:next(Iter). +{a,1,[{b,2},{c,3}]} +> {_, _, Iter2} = maps:next(Iter1). +{b,2,[{c,3}]} +> {_, _, Iter3} = maps:next(Iter2). +{c,3,[]} +> maps:next(Iter3). +none</code> + </desc> + </func> + + <func> <name name="put" arity="3"/> <fsummary></fsummary> <desc> diff --git a/lib/stdlib/doc/src/ordsets.xml b/lib/stdlib/doc/src/ordsets.xml index 7b590932e4..2d891d7a5a 100644 --- a/lib/stdlib/doc/src/ordsets.xml +++ b/lib/stdlib/doc/src/ordsets.xml @@ -142,6 +142,15 @@ </func> <func> + <name name="is_empty" arity="1"/> + <fsummary>Test for empty set.</fsummary> + <desc> + <p>Returns <c>true</c> if <c><anno>Ordset</anno></c> is an empty set, + otherwise <c>false</c>.</p> + </desc> + </func> + + <func> <name name="is_set" arity="1"/> <fsummary>Test for an <c>Ordset</c>.</fsummary> <desc> diff --git a/lib/stdlib/doc/src/rand.xml b/lib/stdlib/doc/src/rand.xml index 89fb858823..21f680a0ee 100644 --- a/lib/stdlib/doc/src/rand.xml +++ b/lib/stdlib/doc/src/rand.xml @@ -133,8 +133,9 @@ variable <c>rand_seed</c> to remember the current state.</p> <p>If a process calls - <seealso marker="#uniform-0"><c>uniform/0</c></seealso> or - <seealso marker="#uniform-1"><c>uniform/1</c></seealso> without + <seealso marker="#uniform-0"><c>uniform/0</c></seealso>, + <seealso marker="#uniform-1"><c>uniform/1</c></seealso> or + <seealso marker="#uniform_real-0"><c>uniform_real/0</c></seealso> without setting a seed first, <seealso marker="#seed-1"><c>seed/1</c></seealso> is called automatically with the default algorithm and creates a non-constant seed.</p> @@ -168,10 +169,17 @@ R3 = rand:uniform(),</pre> S0 = rand:seed_s(exrop), {R4, S1} = rand:uniform_s(S0),</pre> + <p>Textbook basic form Box-Muller standard normal deviate</p> + + <pre> +R5 = rand:uniform_real(), +R6 = rand:uniform(), +SND0 = math:sqrt(-2 * math:log(R5)) * math:cos(math:pi() * R6)</pre> + <p>Create a standard normal deviate:</p> <pre> -{SND0, S2} = rand:normal_s(S1),</pre> +{SND1, S2} = rand:normal_s(S1),</pre> <p>Create a normal deviate with mean -3 and variance 0.5:</p> @@ -414,7 +422,8 @@ tests. We suggest to use a sign test to extract a random Boolean value.</pre> This function may return exactly <c>0.0</c> which can be fatal for certain applications. If that is undesired you can use <c>(1.0 - rand:uniform())</c> to get the - interval <c>0.0 < <anno>X</anno> =< 1.0</c>. + interval <c>0.0 < <anno>X</anno> =< 1.0</c>, or instead use + <seealso marker="#uniform_real-0"><c>uniform_real/0</c></seealso>. </p> <p> If neither endpoint is desired you can test and re-try @@ -432,6 +441,42 @@ end.</pre> </func> <func> + <name name="uniform_real" arity="0"/> + <fsummary>Return a random float.</fsummary> + <desc><marker id="uniform_real-0"/> + <p> + Returns a random float + uniformly distributed in the value range + <c>DBL_MIN =< <anno>X</anno> < 1.0</c> + and updates the state in the process dictionary. + </p> + <p> + Conceptually, a random real number <c>R</c> is generated + from the interval <c>0 =< R < 1</c> and then the + closest rounded down normalized number + in the IEEE 754 Double precision format + is returned. + </p> + <note> + <p> + The generated numbers from this function has got better + granularity for small numbers than the regular + <seealso marker="#uniform-0"><c>uniform/0</c></seealso> + because all bits in the mantissa are random. + This property, in combination with the fact that exactly zero + is never returned is useful for algoritms doing for example + <c>1.0 / <anno>X</anno></c> or <c>math:log(<anno>X</anno>)</c>. + </p> + </note> + <p> + See + <seealso marker="#uniform_real_s-1"><c>uniform_real_s/1</c></seealso> + for more explanation. + </p> + </desc> + </func> + + <func> <name name="uniform" arity="1"/> <fsummary>Return a random integer.</fsummary> <desc><marker id="uniform-1"/> @@ -460,7 +505,8 @@ end.</pre> This function may return exactly <c>0.0</c> which can be fatal for certain applications. If that is undesired you can use <c>(1.0 - rand:uniform(State))</c> to get the - interval <c>0.0 < <anno>X</anno> =< 1.0</c>. + interval <c>0.0 < <anno>X</anno> =< 1.0</c>, or instead use + <seealso marker="#uniform_real_s-1"><c>uniform_real_s/1</c></seealso>. </p> <p> If neither endpoint is desired you can test and re-try @@ -478,6 +524,68 @@ end.</pre> </func> <func> + <name name="uniform_real_s" arity="1"/> + <fsummary>Return a random float.</fsummary> + <desc> + <p> + Returns, for a specified state, a random float + uniformly distributed in the value range + <c>DBL_MIN =< <anno>X</anno> < 1.0</c> + and updates the state in the process dictionary. + </p> + <p> + Conceptually, a random real number <c>R</c> is generated + from the interval <c>0 =< R < 1</c> and then the + closest rounded down normalized number + in the IEEE 754 Double precision format + is returned. + </p> + <note> + <p> + The generated numbers from this function has got better + granularity for small numbers than the regular + <seealso marker="#uniform_s-1"><c>uniform_s/1</c></seealso> + because all bits in the mantissa are random. + This property, in combination with the fact that exactly zero + is never returned is useful for algoritms doing for example + <c>1.0 / <anno>X</anno></c> or <c>math:log(<anno>X</anno>)</c>. + </p> + </note> + <p> + The concept implicates that the probability to get + exactly zero is extremely low; so low that this function + is in fact guaranteed to never return zero. The smallest + number that it might return is <c>DBL_MIN</c>, which is + 2.0^(-1022). + </p> + <p> + The value range stated at the top of this function + description is technically correct, but + <c>0.0 =< <anno>X</anno> < 1.0</c> + is a better description of the generated numbers' + statistical distribution. Except that exactly 0.0 + is never returned, which is not possible to observe + statistically. + </p> + <p> + For example; for all sub ranges + <c>N*2.0^(-53) =< X < (N+1)*2.0^(-53)</c> + where + <c>0 =< integer(N) < 2.0^53</c> + the probability is the same. + Compare that with the form of the numbers generated by + <seealso marker="#uniform_s-1"><c>uniform_s/1</c></seealso>. + </p> + <p> + Having to generate extra random bits for + small numbers costs a little performance. + This function is about 20% slower than the regular + <seealso marker="#uniform_s-1"><c>uniform_s/1</c></seealso> + </p> + </desc> + </func> + + <func> <name name="uniform_s" arity="2"/> <fsummary>Return a random integer.</fsummary> <desc> diff --git a/lib/stdlib/doc/src/ref_man.xml b/lib/stdlib/doc/src/ref_man.xml index 878a3babc5..68bfddbc71 100644 --- a/lib/stdlib/doc/src/ref_man.xml +++ b/lib/stdlib/doc/src/ref_man.xml @@ -93,6 +93,7 @@ <xi:include href="sys.xml"/> <xi:include href="timer.xml"/> <xi:include href="unicode.xml"/> + <xi:include href="uri_string.xml"/> <xi:include href="win32reg.xml"/> <xi:include href="zip.xml"/> </application> diff --git a/lib/stdlib/doc/src/sets.xml b/lib/stdlib/doc/src/sets.xml index 4934bed365..1ed96ddc3f 100644 --- a/lib/stdlib/doc/src/sets.xml +++ b/lib/stdlib/doc/src/sets.xml @@ -140,6 +140,15 @@ </func> <func> + <name name="is_empty" arity="1"/> + <fsummary>Test for empty set.</fsummary> + <desc> + <p>Returns <c>true</c> if <c><anno>Set</anno></c> is an empty set, + otherwise <c>false</c>.</p> + </desc> + </func> + + <func> <name name="is_set" arity="1"/> <fsummary>Test for a <c>Set</c>.</fsummary> <desc> diff --git a/lib/stdlib/doc/src/specs.xml b/lib/stdlib/doc/src/specs.xml index 45b207b13d..d559adf9b6 100644 --- a/lib/stdlib/doc/src/specs.xml +++ b/lib/stdlib/doc/src/specs.xml @@ -60,6 +60,7 @@ <xi:include href="../specs/specs_sys.xml"/> <xi:include href="../specs/specs_timer.xml"/> <xi:include href="../specs/specs_unicode.xml"/> + <xi:include href="../specs/specs_uri_string.xml"/> <xi:include href="../specs/specs_win32reg.xml"/> <xi:include href="../specs/specs_zip.xml"/> </specs> diff --git a/lib/stdlib/doc/src/string.xml b/lib/stdlib/doc/src/string.xml index 9d5edd9ecf..c7772d63a3 100644 --- a/lib/stdlib/doc/src/string.xml +++ b/lib/stdlib/doc/src/string.xml @@ -111,8 +111,8 @@ <c>unicode:chardata()</c></seealso> and operate on grapheme clusters. The <seealso marker="#oldapi"> <c>old functions</c></seealso> that only work on Latin-1 lists as input - are still available but should not be - used. They will be deprecated in Erlang/OTP 21. + are still available but should not be used, they will be + deprecated in a future release. </p> </description> @@ -594,7 +594,7 @@ ÖÄÅ</pre> or <c>both</c>, indicates from which direction characters are to be removed. </p> - <p> Default <c><anno>Characters</anno></c> are the set of + <p> Default <c><anno>Characters</anno></c> is the set of nonbreakable whitespace codepoints, defined as Pattern_White_Space in <url href="http://unicode.org/reports/tr31/">Unicode Standard Annex #31</url>. diff --git a/lib/stdlib/doc/src/timer.xml b/lib/stdlib/doc/src/timer.xml index 350847bf7d..53107ade2c 100644 --- a/lib/stdlib/doc/src/timer.xml +++ b/lib/stdlib/doc/src/timer.xml @@ -270,8 +270,8 @@ <item> <p>Evaluates <c>apply(<anno>Module</anno>, <anno>Function</anno>, <anno>Arguments</anno>)</c> and measures the elapsed real time as - reported by <seealso marker="kernel:os#timestamp/0"> - <c>os:timestamp/0</c></seealso>.</p> + reported by <seealso marker="erts:erlang#monotonic_time/0"> + <c>erlang:monotonic_time/0</c></seealso>.</p> <p>Returns <c>{<anno>Time</anno>, <anno>Value</anno>}</c>, where <c><anno>Time</anno></c> is the elapsed real time in <em>microseconds</em>, and <c><anno>Value</anno></c> is what is diff --git a/lib/stdlib/doc/src/unicode_usage.xml b/lib/stdlib/doc/src/unicode_usage.xml index 26dc46719e..789e063c12 100644 --- a/lib/stdlib/doc/src/unicode_usage.xml +++ b/lib/stdlib/doc/src/unicode_usage.xml @@ -719,8 +719,8 @@ Eshell V5.10.1 (abort with ^G) </section> <section> - <title>Unicode Filenames</title> <marker id="unicode_file_names"/> + <title>Unicode Filenames</title> <p>Most modern operating systems support Unicode filenames in some way. There are many different ways to do this and Erlang by default treats the different approaches differently:</p> @@ -855,8 +855,12 @@ Eshell V5.10.1 (abort with ^G) </note> <section> - <title>Notes About Raw Filenames</title> <marker id="notes-about-raw-filenames"/> + <title>Notes About Raw Filenames</title> + <note><p> + Note that raw filenames <em>not</em> necessarily are encoded the + same way as on the OS level. + </p></note> <p>Raw filenames were introduced together with Unicode filename support in ERTS 5.8.2 (Erlang/OTP R14B01). The reason "raw filenames" were introduced in the system was diff --git a/lib/stdlib/doc/src/uri_string.xml b/lib/stdlib/doc/src/uri_string.xml new file mode 100644 index 0000000000..88d4600611 --- /dev/null +++ b/lib/stdlib/doc/src/uri_string.xml @@ -0,0 +1,359 @@ +<?xml version="1.0" encoding="utf-8" ?> +<!DOCTYPE erlref SYSTEM "erlref.dtd"> + +<erlref> + <header> + <copyright> + <year>2017</year><year>2018</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>uri_string</title> + <prepared>Péter Dimitrov</prepared> + <docno>1</docno> + <date>2018-02-07</date> + <rev>A</rev> + </header> + <module>uri_string</module> + <modulesummary>URI processing functions.</modulesummary> + <description> + <p>This module contains functions for parsing and handling URIs + (<url href="https://www.ietf.org/rfc/rfc3986.txt">RFC 3986</url>) and + form-urlencoded query strings (<url href="https://www.w3.org/TR/html52/">HTML 5.2</url>). + </p> + <p> + Parsing and serializing non-UTF-8 form-urlencoded query strings are also supported + (<url href="https://www.w3.org/TR/html50/">HTML 5.0</url>). + </p> + <p>A URI is an identifier consisting of a sequence of characters matching the syntax + rule named <em>URI</em> in <url href="https://www.ietf.org/rfc/rfc3986.txt">RFC 3986</url>. + </p> + <p> The generic URI syntax consists of a hierarchical sequence of components referred + to as the scheme, authority, path, query, and fragment:</p> + <pre> + URI = scheme ":" hier-part [ "?" query ] [ "#" fragment ] + hier-part = "//" authority path-abempty + / path-absolute + / path-rootless + / path-empty + scheme = ALPHA *( ALPHA / DIGIT / "+" / "-" / "." ) + authority = [ userinfo "@" ] host [ ":" port ] + userinfo = *( unreserved / pct-encoded / sub-delims / ":" ) + + reserved = gen-delims / sub-delims + gen-delims = ":" / "/" / "?" / "#" / "[" / "]" / "@" + sub-delims = "!" / "$" / "&" / "'" / "(" / ")" + / "*" / "+" / "," / ";" / "=" + + unreserved = ALPHA / DIGIT / "-" / "." / "_" / "~" + </pre><br></br> + <p>The interpretation of a URI depends only on the characters used and not on how those + characters are represented in a network protocol.</p> + <p>The functions implemented by this module cover the following use cases:</p> + <list type="bulleted"> + <item>Parsing URIs into its components and returing a map<br></br> + <seealso marker="#parse/1"><c>parse/1</c></seealso> + </item> + <item>Recomposing a map of URI components into a URI string<br></br> + <seealso marker="#recompose/1"><c>recompose/1</c></seealso> + </item> + <item>Changing inbound binary and percent-encoding of URIs<br></br> + <seealso marker="#transcode/2"><c>transcode/2</c></seealso> + </item> + <item>Transforming URIs into a normalized form<br></br> + <seealso marker="#normalize/1"><c>normalize/1</c></seealso><br></br> + <seealso marker="#normalize/2"><c>normalize/2</c></seealso> + </item> + <item>Composing form-urlencoded query strings from a list of key-value pairs<br></br> + <seealso marker="#compose_query/1"><c>compose_query/1</c></seealso><br></br> + <seealso marker="#compose_query/2"><c>compose_query/2</c></seealso> + </item> + <item>Dissecting form-urlencoded query strings into a list of key-value pairs<br></br> + <seealso marker="#dissect_query/1"><c>dissect_query/1</c></seealso> + </item> + </list> + <p>There are four different encodings present during the handling of URIs:</p> + <list type="bulleted"> + <item>Inbound binary encoding in binaries</item> + <item>Inbound percent-encoding in lists and binaries</item> + <item>Outbound binary encoding in binaries</item> + <item>Outbound percent-encoding in lists and binaries</item> + </list> + <p>Functions with <c>uri_string()</c> argument accept lists, binaries and + mixed lists (lists with binary elements) as input type. All of the functions but + <c>transcode/2</c> expects input as lists of unicode codepoints, UTF-8 encoded binaries + and UTF-8 percent-encoded URI parts ("%C3%B6" corresponds to the unicode character "ö").</p> + <p>Unless otherwise specified the return value type and encoding are the same as the input + type and encoding. That is, binary input returns binary output, list input returns a list + output but mixed input returns list output.</p> + <p>In case of lists there is only percent-encoding. In binaries, however, both binary encoding + and percent-encoding shall be considered. <c>transcode/2</c> provides the means to convert + between the supported encodings, it takes a <c>uri_string()</c> and a list of options + specifying inbound and outbound encodings.</p> + <p><url href="https://www.ietf.org/rfc/rfc3986.txt">RFC 3986</url> does not mandate any specific + character encoding and it is usually defined by the protocol or surrounding text. This library + takes the same assumption, binary and percent-encoding are handled as one configuration unit, + they cannot be set to different values.</p> + </description> + + <datatypes> + <datatype> + <name name="error"/> + <desc> + <p>Error tuple indicating the type of error. Possible values of the second component:</p> + <list type="bulleted"> + <item><c>invalid_character</c></item> + <item><c>invalid_encoding</c></item> + <item><c>invalid_input</c></item> + <item><c>invalid_map</c></item> + <item><c>invalid_percent_encoding</c></item> + <item><c>invalid_scheme</c></item> + <item><c>invalid_uri</c></item> + <item><c>invalid_utf8</c></item> + <item><c>missing_value</c></item> + </list> + <p>The third component is a term providing additional information about the + cause of the error.</p> + </desc> + </datatype> + <datatype> + <name name="uri_map"/> + <desc> + <p>Map holding the main components of a URI.</p> + </desc> + </datatype> + <datatype> + <name name="uri_string"/> + <desc> + <p>List of unicode codepoints, a UTF-8 encoded binary, or a mix of the two, + representing an <url href="https://www.ietf.org/rfc/rfc3986.txt">RFC 3986</url> + compliant URI (<em>percent-encoded form</em>). + A URI is a sequence of characters from a very limited set: the letters of + the basic Latin alphabet, digits, and a few special characters.</p> + </desc> + </datatype> + </datatypes> + + <funcs> + + <func> + <name name="compose_query" arity="1"/> + <fsummary>Compose urlencoded query string.</fsummary> + <desc> + <p>Composes a form-urlencoded <c><anno>QueryString</anno></c> based on a + <c><anno>QueryList</anno></c>, a list of non-percent-encoded key-value pairs. + Form-urlencoding is defined in section + 4.10.21.6 of the <url href="https://www.w3.org/TR/html52/">HTML 5.2</url> + specification and in section 4.10.22.6 of the + <url href="https://www.w3.org/TR/html50/">HTML 5.0</url> specification for + non-UTF-8 encodings. + </p> + <p>See also the opposite operation <seealso marker="#dissect_query/1"> + <c>dissect_query/1</c></seealso>. + </p> + <p><em>Example:</em></p> + <pre> +1> <input>uri_string:compose_query([{"foo bar","1"},{"city","örebro"}]).</input> +<![CDATA["foo+bar=1&city=%C3%B6rebro"]]> +2> <![CDATA[uri_string:compose_query([{<<"foo bar">>,<<"1">>}, +2> {<<"city">>,<<"örebro"/utf8>>}]).]]> +<![CDATA[<<"foo+bar=1&city=%C3%B6rebro">>]]> + </pre> + </desc> + </func> + + <func> + <name name="compose_query" arity="2"/> + <fsummary>Compose urlencoded query string.</fsummary> + <desc> + <p>Same as <c>compose_query/1</c> but with an additional + <c><anno>Options</anno></c> parameter, that controls the encoding ("charset") + used by the encoding algorithm. There are two supported encodings: <c>utf8</c> + (or <c>unicode</c>) and <c>latin1</c>. + </p> + <p>Each character in the entry's name and value that cannot be expressed using + the selected character encoding, is replaced by a string consisting of a U+0026 + AMPERSAND character (<![CDATA[&]]>), a "#" (U+0023) character, one or more ASCII + digits representing the Unicode code point of the character in base ten, and + finally a ";" (U+003B) character. + </p> + <p>Bytes that are out of the range 0x2A, 0x2D, 0x2E, 0x30 to 0x39, 0x41 to 0x5A, 0x5F, + 0x61 to 0x7A, are percent-encoded (U+0025 PERCENT SIGN character (%) followed by + uppercase ASCII hex digits representing the hexadecimal value of the byte). + </p> + <p>See also the opposite operation <seealso marker="#dissect_query/1"> + <c>dissect_query/1</c></seealso>. + </p> + <p><em>Example:</em></p> + <pre> +1> <input>uri_string:compose_query([{"foo bar","1"},{"city","örebro"}],</input> +1> [{encoding, latin1}]). +<![CDATA["foo+bar=1&city=%F6rebro" +2> uri_string:compose_query([{<<"foo bar">>,<<"1">>}, +2> {<<"city">>,<<"東京"/utf8>>}], [{encoding, latin1}]).]]> +<![CDATA[<<"foo+bar=1&city=%26%2326481%3B%26%2320140%3B">>]]> + </pre> + </desc> + </func> + + <func> + <name name="dissect_query" arity="1"/> + <fsummary>Dissect query string.</fsummary> + <desc> + <p>Dissects an urlencoded <c><anno>QueryString</anno></c> and returns a + <c><anno>QueryList</anno></c>, a list of non-percent-encoded key-value pairs. + Form-urlencoding is defined in section + 4.10.21.6 of the <url href="https://www.w3.org/TR/html52/">HTML 5.2</url> + specification and in section 4.10.22.6 of the + <url href="https://www.w3.org/TR/html50/">HTML 5.0</url> specification for + non-UTF-8 encodings. + </p> + <p>See also the opposite operation <seealso marker="#compose_query/1"> + <c>compose_query/1</c></seealso>. + </p> + <p><em>Example:</em></p> + <pre> +1> <input><![CDATA[uri_string:dissect_query("foo+bar=1&city=%C3%B6rebro").]]></input> +[{"foo bar","1"},{"city","örebro"}] +2> <![CDATA[uri_string:dissect_query(<<"foo+bar=1&city=%26%2326481%3B%26%2320140%3B">>).]]> +<![CDATA[[{<<"foo bar">>,<<"1">>}, + {<<"city">>,<<230,157,177,228,186,172>>}] ]]> + </pre> + </desc> + </func> + + <func> + <name name="normalize" arity="1"/> + <fsummary>Syntax-based normalization.</fsummary> + <desc> + <p>Transforms an <c><anno>URI</anno></c> into a normalized form + using Syntax-Based Normalization as defined by + <url href="https://www.ietf.org/rfc/rfc3986.txt">RFC 3986</url>.</p> + <p>This function implements case normalization, percent-encoding + normalization, path segment normalization and scheme based normalization + for HTTP(S) with basic support for FTP, SSH, SFTP and TFTP.</p> + <p><em>Example:</em></p> + <pre> +1> <input>uri_string:normalize("/a/b/c/./../../g").</input> +"/a/g" +2> <![CDATA[uri_string:normalize(<<"mid/content=5/../6">>).]]> +<![CDATA[<<"mid/6">>]]> +3> uri_string:normalize("http://localhost:80"). +"https://localhost/" +4> <input>uri_string:normalize(#{scheme => "http",port => 80,path => "/a/b/c/./../../g",</input> +4> host => "localhost-örebro"}). +"http://localhost-%C3%B6rebro/a/g" + </pre> + </desc> + </func> + + <func> + <name name="normalize" arity="2"/> + <fsummary>Syntax-based normalization.</fsummary> + <desc> + <p>Same as <c>normalize/1</c> but with an additional + <c><anno>Options</anno></c> parameter, that controls if the normalized URI + shall be returned as an uri_map(). + There is one supported option: <c>return_map</c>. + </p> + <p><em>Example:</em></p> + <pre> +1> <input>uri_string:normalize("/a/b/c/./../../g", [return_map]).</input> +#{path => "/a/g"} +2> <![CDATA[uri_string:normalize(<<"mid/content=5/../6">>, [return_map]).]]> +<![CDATA[#{path => <<"mid/6">>}]]> +3> uri_string:normalize("http://localhost:80", [return_map]). +#{scheme => "http",path => "/",host => "localhost"} +4> <input>uri_string:normalize(#{scheme => "http",port => 80,path => "/a/b/c/./../../g",</input> +4> host => "localhost-örebro"}, [return_map]). +#{scheme => "http",path => "/a/g",host => "localhost-örebro"} + </pre> + </desc> + </func> + + <func> + <name name="parse" arity="1"/> + <fsummary>Parse URI into a map.</fsummary> + <desc> + <p>Parses an <url href="https://www.ietf.org/rfc/rfc3986.txt">RFC 3986</url> + compliant <c>uri_string()</c> into a <c>uri_map()</c>, that holds the parsed + components of the <c>URI</c>. + If parsing fails, an error tuple is returned.</p> + <p>See also the opposite operation <seealso marker="#recompose/1"> + <c>recompose/1</c></seealso>.</p> + <p><em>Example:</em></p> + <pre> +1> <input>uri_string:parse("foo://[email protected]:8042/over/there?name=ferret#nose").</input> +#{fragment => "nose",host => "example.com", + path => "/over/there",port => 8042,query => "name=ferret", + scheme => foo,userinfo => "user"} +2> <![CDATA[uri_string:parse(<<"foo://[email protected]:8042/over/there?name=ferret">>).]]> +<![CDATA[#{host => <<"example.com">>,path => <<"/over/there">>, + port => 8042,query => <<"name=ferret">>,scheme => <<"foo">>, + userinfo => <<"user">>}]]> + </pre> + </desc> + </func> + + <func> + <name name="recompose" arity="1"/> + <fsummary>Recompose URI.</fsummary> + <desc> + <p>Creates an <url href="https://www.ietf.org/rfc/rfc3986.txt">RFC 3986</url> compliant + <c><anno>URIString</anno></c> (percent-encoded), based on the components of + <c><anno>URIMap</anno></c>. + If the <c><anno>URIMap</anno></c> is invalid, an error tuple is returned.</p> + <p>See also the opposite operation <seealso marker="#parse/1"> + <c>parse/1</c></seealso>.</p> + <p><em>Example:</em></p> + <pre> +1> <input>URIMap = #{fragment => "nose", host => "example.com", path => "/over/there",</input> +1> port => 8042, query => "name=ferret", scheme => "foo", userinfo => "user"}. +#{fragment => "top",host => "example.com", + path => "/over/there",port => 8042,query => "?name=ferret", + scheme => foo,userinfo => "user"} + +2> <input>uri_string:recompose(URIMap).</input> +"foo://example.com:8042/over/there?name=ferret#nose"</pre> + </desc> + </func> + + <func> + <name name="transcode" arity="2"/> + <fsummary>Transcode URI.</fsummary> + <desc> + <p>Transcodes an <url href="https://www.ietf.org/rfc/rfc3986.txt">RFC 3986</url> + compliant <c><anno>URIString</anno></c>, + where <c><anno>Options</anno></c> is a list of tagged tuples, specifying the inbound + (<c>in_encoding</c>) and outbound (<c>out_encoding</c>) encodings. <c>in_encoding</c> + and <c>out_encoding</c> specifies both binary encoding and percent-encoding for the + input and output data. Mixed encoding, where binary encoding is not the same as + percent-encoding, is not supported. + If an argument is invalid, an error tuple is returned.</p> + <p><em>Example:</em></p> + <pre> +1> <input><![CDATA[uri_string:transcode(<<"foo%00%00%00%F6bar"/utf32>>,]]></input> +1> [{in_encoding, utf32},{out_encoding, utf8}]). +<![CDATA[<<"foo%C3%B6bar"/utf8>>]]> +2> uri_string:transcode("foo%F6bar", [{in_encoding, latin1}, +2> {out_encoding, utf8}]). +"foo%C3%B6bar" + </pre> + </desc> + </func> + + </funcs> +</erlref> diff --git a/lib/stdlib/include/assert.hrl b/lib/stdlib/include/assert.hrl index 2fbaeba0b2..2ec89e7d8a 100644 --- a/lib/stdlib/include/assert.hrl +++ b/lib/stdlib/include/assert.hrl @@ -309,7 +309,7 @@ {unexpected_success, __V}]}) catch Class:Term -> ok; - __C:__T -> + __C:__T:__S -> erlang:error({assertException, [{module, ?MODULE}, {line, ?LINE}, @@ -318,8 +318,7 @@ "{ "++(??Class)++" , "++(??Term) ++" , [...] }"}, {unexpected_exception, - {__C, __T, - erlang:get_stacktrace()}}]}) + {__C, __T, __S}}]}) end end)()) end). @@ -338,7 +337,7 @@ {unexpected_success, __V}]}) catch Class:Term -> ok; - __C:__T -> + __C:__T:__S -> erlang:error({assertException, [{module, ?MODULE}, {line, ?LINE}, @@ -348,8 +347,7 @@ "{ "++(??Class)++" , "++(??Term) ++" , [...] }"}, {unexpected_exception, - {__C, __T, - erlang:get_stacktrace()}}]}) + {__C, __T, __S}}]}) end end)()) end). @@ -378,7 +376,7 @@ try (Expr) of _ -> ok catch - __C:__T -> + __C:__T:__S -> case __C of Class -> case __T of @@ -391,9 +389,7 @@ "{ "++(??Class)++" , " ++(??Term)++" , [...] }"}, {unexpected_exception, - {__C, __T, - erlang:get_stacktrace() - }}]}); + {__C, __T, __S}}]}); _ -> ok end; _ -> ok @@ -407,7 +403,7 @@ try (Expr) of _ -> ok catch - __C:__T -> + __C:__T:__S -> case __C of Class -> case __T of @@ -421,9 +417,7 @@ "{ "++(??Class)++" , " ++(??Term)++" , [...] }"}, {unexpected_exception, - {__C, __T, - erlang:get_stacktrace() - }}]}); + {__C, __T, __S}}]}); _ -> ok end; _ -> ok diff --git a/lib/stdlib/src/Makefile b/lib/stdlib/src/Makefile index bf836203ec..8b156929d7 100644 --- a/lib/stdlib/src/Makefile +++ b/lib/stdlib/src/Makefile @@ -121,6 +121,7 @@ MODULES= \ timer \ unicode \ unicode_util \ + uri_string \ win32reg \ zip diff --git a/lib/stdlib/src/base64.erl b/lib/stdlib/src/base64.erl index 5885745fb1..6ea4147abf 100644 --- a/lib/stdlib/src/base64.erl +++ b/lib/stdlib/src/base64.erl @@ -24,22 +24,11 @@ -export([encode/1, decode/1, mime_decode/1, encode_to_string/1, decode_to_string/1, mime_decode_to_string/1]). -%%------------------------------------------------------------------------- %% The following type is a subtype of string() for return values %% of (some) functions of this module. -%%------------------------------------------------------------------------- - -type ascii_string() :: [1..255]. -type ascii_binary() :: binary(). -%%------------------------------------------------------------------------- -%% encode_to_string(ASCII) -> Base64String -%% ASCII - string() | binary() -%% Base64String - string() -%% -%% Description: Encodes a plain ASCII string (or binary) into base64. -%%------------------------------------------------------------------------- - -spec encode_to_string(Data) -> Base64String when Data :: ascii_string() | ascii_binary(), Base64String :: ascii_string(). @@ -47,107 +36,89 @@ encode_to_string(Bin) when is_binary(Bin) -> encode_to_string(binary_to_list(Bin)); encode_to_string(List) when is_list(List) -> - encode_l(List). - -%%------------------------------------------------------------------------- -%% encode(ASCII) -> Base64 -%% ASCII - string() | binary() -%% Base64 - binary() -%% -%% Description: Encodes a plain ASCII string (or binary) into base64. -%%------------------------------------------------------------------------- + encode_list_to_string(List). -spec encode(Data) -> Base64 when Data :: ascii_string() | ascii_binary(), Base64 :: ascii_binary(). encode(Bin) when is_binary(Bin) -> - encode_binary(Bin); + encode_binary(Bin, <<>>); encode(List) when is_list(List) -> - list_to_binary(encode_l(List)). + encode_list(List, <<>>). --spec encode_l(ascii_string()) -> ascii_string(). - -encode_l([]) -> +encode_list_to_string([]) -> []; -encode_l([A]) -> - [b64e(A bsr 2), - b64e((A band 3) bsl 4), $=, $=]; -encode_l([A,B]) -> - [b64e(A bsr 2), - b64e(((A band 3) bsl 4) bor (B bsr 4)), - b64e((B band 15) bsl 2), $=]; -encode_l([A,B,C|Ls]) -> - BB = (A bsl 16) bor (B bsl 8) bor C, +encode_list_to_string([B1]) -> + [b64e(B1 bsr 2), + b64e((B1 band 3) bsl 4), $=, $=]; +encode_list_to_string([B1,B2]) -> + [b64e(B1 bsr 2), + b64e(((B1 band 3) bsl 4) bor (B2 bsr 4)), + b64e((B2 band 15) bsl 2), $=]; +encode_list_to_string([B1,B2,B3|Ls]) -> + BB = (B1 bsl 16) bor (B2 bsl 8) bor B3, [b64e(BB bsr 18), b64e((BB bsr 12) band 63), b64e((BB bsr 6) band 63), - b64e(BB band 63) | encode_l(Ls)]. - -encode_binary(Bin) -> - Split = 3*(byte_size(Bin) div 3), - <<Main0:Split/binary,Rest/binary>> = Bin, - Main = << <<(b64e(C)):8>> || <<C:6>> <= Main0 >>, - case Rest of - <<A:6,B:6,C:4>> -> - <<Main/binary,(b64e(A)):8,(b64e(B)):8,(b64e(C bsl 2)):8,$=:8>>; - <<A:6,B:2>> -> - <<Main/binary,(b64e(A)):8,(b64e(B bsl 4)):8,$=:8,$=:8>>; - <<>> -> - Main - end. + b64e(BB band 63) | encode_list_to_string(Ls)]. -%%------------------------------------------------------------------------- -%% mime_decode(Base64) -> ASCII -%% decode(Base64) -> ASCII -%% Base64 - string() | binary() -%% ASCII - binary() -%% -%% Description: Decodes an base64 encoded string to plain ASCII. -%% mime_decode strips away all characters not Base64 before converting, -%% whereas decode crashes if an illegal character is found -%%------------------------------------------------------------------------- +encode_binary(<<>>, A) -> + A; +encode_binary(<<B1:8>>, A) -> + <<A/bits,(b64e(B1 bsr 2)):8,(b64e((B1 band 3) bsl 4)):8,$=:8,$=:8>>; +encode_binary(<<B1:8, B2:8>>, A) -> + <<A/bits,(b64e(B1 bsr 2)):8, + (b64e(((B1 band 3) bsl 4) bor (B2 bsr 4))):8, + (b64e((B2 band 15) bsl 2)):8, $=:8>>; +encode_binary(<<B1:8, B2:8, B3:8, Ls/bits>>, A) -> + BB = (B1 bsl 16) bor (B2 bsl 8) bor B3, + encode_binary(Ls, + <<A/bits,(b64e(BB bsr 18)):8, + (b64e((BB bsr 12) band 63)):8, + (b64e((BB bsr 6) band 63)):8, + (b64e(BB band 63)):8>>). + +encode_list([], A) -> + A; +encode_list([B1], A) -> + <<A/bits,(b64e(B1 bsr 2)):8,(b64e((B1 band 3) bsl 4)):8,$=:8,$=:8>>; +encode_list([B1,B2], A) -> + <<A/bits,(b64e(B1 bsr 2)):8, + (b64e(((B1 band 3) bsl 4) bor (B2 bsr 4))):8, + (b64e((B2 band 15) bsl 2)):8, $=:8>>; +encode_list([B1,B2,B3|Ls], A) -> + BB = (B1 bsl 16) bor (B2 bsl 8) bor B3, + encode_list(Ls, + <<A/bits,(b64e(BB bsr 18)):8, + (b64e((BB bsr 12) band 63)):8, + (b64e((BB bsr 6) band 63)):8, + (b64e(BB band 63)):8>>). + +%% mime_decode strips away all characters not Base64 before +%% converting, whereas decode crashes if an illegal character is found -spec decode(Base64) -> Data when Base64 :: ascii_string() | ascii_binary(), Data :: ascii_binary(). decode(Bin) when is_binary(Bin) -> - decode_binary(<<>>, Bin); + decode_binary(Bin, <<>>); decode(List) when is_list(List) -> - list_to_binary(decode_l(List)). + decode_list(List, <<>>). -spec mime_decode(Base64) -> Data when Base64 :: ascii_string() | ascii_binary(), Data :: ascii_binary(). mime_decode(Bin) when is_binary(Bin) -> - mime_decode_binary(<<>>, Bin); + mime_decode_binary(Bin, <<>>); mime_decode(List) when is_list(List) -> - mime_decode(list_to_binary(List)). - --spec decode_l(ascii_string()) -> ascii_string(). - -decode_l(List) -> - L = strip_spaces(List, []), - decode(L, []). - --spec mime_decode_l(ascii_string()) -> ascii_string(). + mime_decode_list(List, <<>>). -mime_decode_l(List) -> - L = strip_illegal(List, [], 0), - decode(L, []). - -%%------------------------------------------------------------------------- -%% mime_decode_to_string(Base64) -> ASCII -%% decode_to_string(Base64) -> ASCII -%% Base64 - string() | binary() -%% ASCII - binary() -%% -%% Description: Decodes an base64 encoded string to plain ASCII. -%% mime_decode strips away all characters not Base64 before converting, -%% whereas decode crashes if an illegal character is found -%%------------------------------------------------------------------------- +%% mime_decode_to_string strips away all characters not Base64 before +%% converting, whereas decode_to_string crashes if an illegal +%% character is found -spec decode_to_string(Base64) -> DataString when Base64 :: ascii_string() | ascii_binary(), @@ -156,7 +127,7 @@ mime_decode_l(List) -> decode_to_string(Bin) when is_binary(Bin) -> decode_to_string(binary_to_list(Bin)); decode_to_string(List) when is_list(List) -> - decode_l(List). + decode_list_to_string(List). -spec mime_decode_to_string(Base64) -> DataString when Base64 :: ascii_string() | ascii_binary(), @@ -165,202 +136,326 @@ decode_to_string(List) when is_list(List) -> mime_decode_to_string(Bin) when is_binary(Bin) -> mime_decode_to_string(binary_to_list(Bin)); mime_decode_to_string(List) when is_list(List) -> - mime_decode_l(List). - -%% One-based decode map. --define(DECODE_MAP, - {bad,bad,bad,bad,bad,bad,bad,bad,ws,ws,bad,bad,ws,bad,bad, %1-15 - bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, %16-31 - ws,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,62,bad,bad,bad,63, %32-47 - 52,53,54,55,56,57,58,59,60,61,bad,bad,bad,eq,bad,bad, %48-63 - bad,0,1,2,3,4,5,6,7,8,9,10,11,12,13,14, - 15,16,17,18,19,20,21,22,23,24,25,bad,bad,bad,bad,bad, - bad,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40, - 41,42,43,44,45,46,47,48,49,50,51,bad,bad,bad,bad,bad, - bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, - bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, - bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, - bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, - bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, - bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, - bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, - bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad}). - -decode_binary(Result0, <<C:8,T0/bits>>) -> - case element(C, ?DECODE_MAP) of - bad -> - erlang:error({badarg,C}); - ws -> - decode_binary(Result0, T0); - eq -> - case strip_ws(T0) of - <<$=:8,T/binary>> -> - <<>> = strip_ws(T), - Split = byte_size(Result0) - 1, - <<Result:Split/bytes,_:4>> = Result0, - Result; - T -> - <<>> = strip_ws(T), - Split = byte_size(Result0) - 1, - <<Result:Split/bytes,_:2>> = Result0, - Result - end; - Bits -> - decode_binary(<<Result0/bits,Bits:6>>, T0) - end; -decode_binary(Result, <<>>) -> - true = is_binary(Result), - Result. + mime_decode_list_to_string(List). %% Skipping pad character if not at end of string. Also liberal about %% excess padding and skipping of other illegal (non-base64 alphabet) %% characters. See section 3.3 of RFC4648 -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); +mime_decode_list([0 | Cs], A) -> + mime_decode_list(Cs, A); +mime_decode_list([C1 | Cs], A) -> + case b64d(C1) of + B1 when is_integer(B1) -> mime_decode_list(Cs, A, B1); + _ -> mime_decode_list(Cs, A) % eq is padding + end; +mime_decode_list([], A) -> + A. + +mime_decode_list([0 | Cs], A, B1) -> + mime_decode_list(Cs, A, B1); +mime_decode_list([C2 | Cs], A, B1) -> + case b64d(C2) of + B2 when is_integer(B2) -> + mime_decode_list(Cs, A, B1, B2); + _ -> mime_decode_list(Cs, A, B1) % eq is padding + end. + +mime_decode_list([0 | Cs], A, B1, B2) -> + mime_decode_list(Cs, A, B1, B2); +mime_decode_list([C3 | Cs], A, B1, B2) -> + case b64d(C3) of + B3 when is_integer(B3) -> + mime_decode_list(Cs, A, B1, B2, B3); + eq=B3 -> + mime_decode_list_after_eq(Cs, A, B1, B2, B3); + _ -> mime_decode_list(Cs, A, B1, B2) + end. + +mime_decode_list([0 | Cs], A, B1, B2, B3) -> + mime_decode_list(Cs, A, B1, B2, B3); +mime_decode_list([C4 | Cs], A, B1, B2, B3) -> + case b64d(C4) of + B4 when is_integer(B4) -> + mime_decode_list(Cs, <<A/bits,B1:6,B2:6,B3:6,B4:6>>); eq -> - mime_decode_binary_after_eq(Result0, T, false); - _ -> - mime_decode_binary(Result0, T) + mime_decode_list_after_eq(Cs, A, B1, B2, B3); + _ -> mime_decode_list(Cs, A, B1, B2, B3) + end. + +mime_decode_list_after_eq([0 | Cs], A, B1, B2, B3) -> + mime_decode_list_after_eq(Cs, A, B1, B2, B3); +mime_decode_list_after_eq([C | Cs], A, B1, B2, B3) -> + case b64d(C) of + B when is_integer(B) -> + %% More valid data, skip the eq as invalid + case B3 of + eq -> mime_decode_list(Cs, A, B1, B2, B); + _ -> mime_decode_list(Cs, <<A/bits,B1:6,B2:6,B3:6,B:6>>) + end; + _ -> mime_decode_list_after_eq(Cs, A, B1, B2, B3) end; -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); +mime_decode_list_after_eq([], A, B1, B2, eq) -> + <<A/bits,B1:6,(B2 bsr 4):2>>; +mime_decode_list_after_eq([], A, B1, B2, B3) -> + <<A/bits,B1:6,B2:6,(B3 bsr 2):4>>. + +mime_decode_binary(<<0:8, Cs/bits>>, A) -> + mime_decode_binary(Cs, A); +mime_decode_binary(<<C1:8, Cs/bits>>, A) -> + case b64d(C1) of + B1 when is_integer(B1) -> mime_decode_binary(Cs, A, B1); + _ -> mime_decode_binary(Cs, A) % eq is padding + end; +mime_decode_binary(<<>>, A) -> + A. + +mime_decode_binary(<<0:8, Cs/bits>>, A, B1) -> + mime_decode_binary(Cs, A, B1); +mime_decode_binary(<<C2:8, Cs/bits>>, A, B1) -> + case b64d(C2) of + B2 when is_integer(B2) -> + mime_decode_binary(Cs, A, B1, B2); + _ -> mime_decode_binary(Cs, A, B1) % eq is padding + end. + +mime_decode_binary(<<0:8, Cs/bits>>, A, B1, B2) -> + mime_decode_binary(Cs, A, B1, B2); +mime_decode_binary(<<C3:8, Cs/bits>>, A, B1, B2) -> + case b64d(C3) of + B3 when is_integer(B3) -> + mime_decode_binary(Cs, A, B1, B2, B3); + eq=B3 -> + mime_decode_binary_after_eq(Cs, A, B1, B2, B3); + _ -> mime_decode_binary(Cs, A, B1, B2) + end. + +mime_decode_binary(<<0:8, Cs/bits>>, A, B1, B2, B3) -> + mime_decode_binary(Cs, A, B1, B2, B3); +mime_decode_binary(<<C4:8, Cs/bits>>, A, B1, B2, B3) -> + case b64d(C4) of + B4 when is_integer(B4) -> + mime_decode_binary(Cs, <<A/bits,B1:6,B2:6,B3:6,B4:6>>); eq -> - mime_decode_binary_after_eq(Result0, T, true); - Bits when is_integer(Bits) -> + mime_decode_binary_after_eq(Cs, A, B1, B2, B3); + _ -> mime_decode_binary(Cs, A, B1, B2, B3) + end. + +mime_decode_binary_after_eq(<<0:8, Cs/bits>>, A, B1, B2, B3) -> + mime_decode_binary_after_eq(Cs, A, B1, B2, B3); +mime_decode_binary_after_eq(<<C:8, Cs/bits>>, A, B1, B2, B3) -> + case b64d(C) of + B when is_integer(B) -> %% More valid data, skip the eq as invalid - mime_decode_binary(<<Result0/bits,Bits:6>>, T) + case B3 of + eq -> mime_decode_binary(Cs, A, B1, B2, B); + _ -> mime_decode_binary(Cs, <<A/bits,B1:6,B2:6,B3:6,B:6>>) + end; + _ -> mime_decode_binary_after_eq(Cs, A, B1, B2, B3) + end; +mime_decode_binary_after_eq(<<>>, A, B1, B2, eq) -> + <<A/bits,B1:6,(B2 bsr 4):2>>; +mime_decode_binary_after_eq(<<>>, A, B1, B2, B3) -> + <<A/bits,B1:6,B2:6,(B3 bsr 2):4>>. + +mime_decode_list_to_string([0 | Cs]) -> + mime_decode_list_to_string(Cs); +mime_decode_list_to_string([C1 | Cs]) -> + case b64d(C1) of + B1 when is_integer(B1) -> mime_decode_list_to_string(Cs, B1); + _ -> mime_decode_list_to_string(Cs) % eq is padding 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 +mime_decode_list_to_string([]) -> + []. + +mime_decode_list_to_string([0 | Cs], B1) -> + mime_decode_list_to_string(Cs, B1); +mime_decode_list_to_string([C2 | Cs], B1) -> + case b64d(C2) of + B2 when is_integer(B2) -> + mime_decode_list_to_string(Cs, B1, B2); + _ -> mime_decode_list_to_string(Cs, B1) % eq is padding end. -decode([], A) -> A; -decode([$=,$=,C2,C1|Cs], A) -> - Bits2x6 = (b64d(C1) bsl 18) bor (b64d(C2) bsl 12), - Octet1 = Bits2x6 bsr 16, - decode(Cs, [Octet1|A]); -decode([$=,C3,C2,C1|Cs], A) -> - Bits3x6 = (b64d(C1) bsl 18) bor (b64d(C2) bsl 12) - bor (b64d(C3) bsl 6), - Octet1 = Bits3x6 bsr 16, - Octet2 = (Bits3x6 bsr 8) band 16#ff, - decode(Cs, [Octet1,Octet2|A]); -decode([C4,C3,C2,C1| Cs], A) -> - Bits4x6 = (b64d(C1) bsl 18) bor (b64d(C2) bsl 12) - bor (b64d(C3) bsl 6) bor b64d(C4), - Octet1 = Bits4x6 bsr 16, - Octet2 = (Bits4x6 bsr 8) band 16#ff, - Octet3 = Bits4x6 band 16#ff, - decode(Cs, [Octet1,Octet2,Octet3|A]). +mime_decode_list_to_string([0 | Cs], B1, B2) -> + mime_decode_list_to_string(Cs, B1, B2); +mime_decode_list_to_string([C3 | Cs], B1, B2) -> + case b64d(C3) of + B3 when is_integer(B3) -> + mime_decode_list_to_string(Cs, B1, B2, B3); + eq=B3 -> mime_decode_list_to_string_after_eq(Cs, B1, B2, B3); + _ -> mime_decode_list_to_string(Cs, B1, B2) + end. -%%%======================================================================== -%%% Internal functions -%%%======================================================================== +mime_decode_list_to_string([0 | Cs], B1, B2, B3) -> + mime_decode_list_to_string(Cs, B1, B2, B3); +mime_decode_list_to_string([C4 | Cs], B1, B2, B3) -> + case b64d(C4) of + B4 when is_integer(B4) -> + Bits4x6 = (B1 bsl 18) bor (B2 bsl 12) bor (B3 bsl 6) bor B4, + Octet1 = Bits4x6 bsr 16, + Octet2 = (Bits4x6 bsr 8) band 16#ff, + Octet3 = Bits4x6 band 16#ff, + [Octet1, Octet2, Octet3 | mime_decode_list_to_string(Cs)]; + eq -> + mime_decode_list_to_string_after_eq(Cs, B1, B2, B3); + _ -> mime_decode_list_to_string(Cs, B1, B2, B3) + end. -strip_spaces([], A) -> A; -strip_spaces([$\s|Cs], A) -> strip_spaces(Cs, A); -strip_spaces([$\t|Cs], A) -> strip_spaces(Cs, A); -strip_spaces([$\r|Cs], A) -> strip_spaces(Cs, A); -strip_spaces([$\n|Cs], A) -> strip_spaces(Cs, A); -strip_spaces([C|Cs], A) -> strip_spaces(Cs, [C | A]). - -strip_ws(<<$\t,T/binary>>) -> - strip_ws(T); -strip_ws(<<$\n,T/binary>>) -> - strip_ws(T); -strip_ws(<<$\r,T/binary>>) -> - strip_ws(T); -strip_ws(<<$\s,T/binary>>) -> - strip_ws(T); -strip_ws(T) -> T. +mime_decode_list_to_string_after_eq([0 | Cs], B1, B2, B3) -> + mime_decode_list_to_string_after_eq(Cs, B1, B2, B3); +mime_decode_list_to_string_after_eq([C | Cs], B1, B2, B3) -> + case b64d(C) of + B when is_integer(B) -> + %% More valid data, skip the eq as invalid + case B3 of + eq -> mime_decode_list_to_string(Cs, B1, B2, B); + _ -> + Bits4x6 = (B1 bsl 18) bor (B2 bsl 12) bor (B3 bsl 6) bor B, + Octet1 = Bits4x6 bsr 16, + Octet2 = (Bits4x6 bsr 8) band 16#ff, + Octet3 = Bits4x6 band 16#ff, + [Octet1, Octet2, Octet3 | mime_decode_list_to_string(Cs)] + end; + _ -> mime_decode_list_to_string_after_eq(Cs, B1, B2, B3) + end; +mime_decode_list_to_string_after_eq([], B1, B2, eq) -> + binary_to_list(<<B1:6,(B2 bsr 4):2>>); +mime_decode_list_to_string_after_eq([], B1, B2, B3) -> + binary_to_list(<<B1:6,B2:6,(B3 bsr 2):4>>). + +decode_list([C1 | Cs], A) -> + case b64d(C1) of + ws -> decode_list(Cs, A); + B1 -> decode_list(Cs, A, B1) + end; +decode_list([], A) -> + A. -%% Skipping pad character if not at end of string. Also liberal about -%% excess padding and skipping of other illegal (non-base64 alphabet) -%% characters. See section 3.3 of RFC4648 -strip_illegal([], A, _Cnt) -> +decode_list([C2 | Cs], A, B1) -> + case b64d(C2) of + ws -> decode_list(Cs, A, B1); + B2 -> decode_list(Cs, A, B1, B2) + end. + +decode_list([C3 | Cs], A, B1, B2) -> + case b64d(C3) of + ws -> decode_list(Cs, A, B1, B2); + B3 -> decode_list(Cs, A, B1, B2, B3) + end. + +decode_list([C4 | Cs], A, B1, B2, B3) -> + case b64d(C4) of + ws -> decode_list(Cs, A, B1, B2, B3); + eq when B3 =:= eq -> only_ws(Cs, <<A/bits,B1:6,(B2 bsr 4):2>>); + eq -> only_ws(Cs, <<A/bits,B1:6,B2:6,(B3 bsr 2):4>>); + B4 -> decode_list(Cs, <<A/bits,B1:6,B2:6,B3:6,B4:6>>) + end. + +decode_binary(<<C1:8, Cs/bits>>, A) -> + case b64d(C1) of + ws -> decode_binary(Cs, A); + B1 -> decode_binary(Cs, A, B1) + end; +decode_binary(<<>>, A) -> + A. + +decode_binary(<<C2:8, Cs/bits>>, A, B1) -> + case b64d(C2) of + ws -> decode_binary(Cs, A, B1); + B2 -> decode_binary(Cs, A, B1, B2) + end. + +decode_binary(<<C3:8, Cs/bits>>, A, B1, B2) -> + case b64d(C3) of + ws -> decode_binary(Cs, A, B1, B2); + B3 -> decode_binary(Cs, A, B1, B2, B3) + end. + +decode_binary(<<C4:8, Cs/bits>>, A, B1, B2, B3) -> + case b64d(C4) of + ws -> decode_binary(Cs, A, B1, B2, B3); + eq when B3 =:= eq -> only_ws_binary(Cs, <<A/bits,B1:6,(B2 bsr 4):2>>); + eq -> only_ws_binary(Cs, <<A/bits,B1:6,B2:6,(B3 bsr 2):4>>); + B4 -> decode_binary(Cs, <<A/bits,B1:6,B2:6,B3:6,B4:6>>) + end. + +only_ws_binary(<<>>, A) -> A; -strip_illegal([0|Cs], A, Cnt) -> - strip_illegal(Cs, A, Cnt); -strip_illegal([C|Cs], A, Cnt) -> - case element(C, ?DECODE_MAP) of - bad -> - strip_illegal(Cs, A, Cnt); - ws -> - strip_illegal(Cs, A, Cnt); - eq -> - case {tail_contains_more(Cs, false), Cnt rem 4} of - {{[], _}, 0} -> - A; %% Ignore extra = - {{[], true}, 2} -> - [$=|[$=|A]]; %% 'XX==' - {{[], _}, 3} -> - [$=|A]; %% 'XXX=' - {{[H|T], _}, _} -> - %% more data, skip equals - strip_illegal(T, [H|A], Cnt+1) - end; - _ -> - strip_illegal(Cs, [C|A], Cnt+1) +only_ws_binary(<<C:8, Cs/bits>>, A) -> + case b64d(C) of + ws -> only_ws_binary(Cs, A) end. -%% Search the tail for more valid data and remember if we saw -%% another equals along the way. -tail_contains_more([], Eq) -> - {[], Eq}; -tail_contains_more(<<>>, Eq) -> - {<<>>, Eq}; -tail_contains_more([C|T]=More, Eq) -> - case element(C, ?DECODE_MAP) of - bad -> - tail_contains_more(T, Eq); - ws -> - tail_contains_more(T, Eq); - eq -> - tail_contains_more(T, true); - _ -> - {More, Eq} +decode_list_to_string([C1 | Cs]) -> + case b64d(C1) of + ws -> decode_list_to_string(Cs); + B1 -> decode_list_to_string(Cs, B1) end; -tail_contains_more(<<C:8,T/bits>> =More, Eq) -> - case element(C, ?DECODE_MAP) of - bad -> - tail_contains_more(T, Eq); - ws -> - tail_contains_more(T, Eq); - eq -> - tail_contains_more(T, true); - _ -> - {More, Eq} +decode_list_to_string([]) -> + []. + +decode_list_to_string([C2 | Cs], B1) -> + case b64d(C2) of + ws -> decode_list_to_string(Cs, B1); + B2 -> decode_list_to_string(Cs, B1, B2) end. - + +decode_list_to_string([C3 | Cs], B1, B2) -> + case b64d(C3) of + ws -> decode_list_to_string(Cs, B1, B2); + B3 -> decode_list_to_string(Cs, B1, B2, B3) + end. + +decode_list_to_string([C4 | Cs], B1, B2, B3) -> + case b64d(C4) of + ws -> + decode_list_to_string(Cs, B1, B2, B3); + eq when B3 =:= eq -> + only_ws(Cs, binary_to_list(<<B1:6,(B2 bsr 4):2>>)); + eq -> + only_ws(Cs, binary_to_list(<<B1:6,B2:6,(B3 bsr 2):4>>)); + B4 -> + Bits4x6 = (B1 bsl 18) bor (B2 bsl 12) bor (B3 bsl 6) bor B4, + Octet1 = Bits4x6 bsr 16, + Octet2 = (Bits4x6 bsr 8) band 16#ff, + Octet3 = Bits4x6 band 16#ff, + [Octet1, Octet2, Octet3 | decode_list_to_string(Cs)] + end. + +only_ws([], A) -> + A; +only_ws([C | Cs], A) -> + case b64d(C) of + ws -> only_ws(Cs, A) + end. + +%%%======================================================================== +%%% Internal functions +%%%======================================================================== + %% accessors +-compile({inline, [{b64d, 1}]}). +%% One-based decode map. +b64d(X) -> + element(X, + {bad,bad,bad,bad,bad,bad,bad,bad,ws,ws,bad,bad,ws,bad,bad, %1-15 + bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, %16-31 + ws,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,62,bad,bad,bad,63, %32-47 + 52,53,54,55,56,57,58,59,60,61,bad,bad,bad,eq,bad,bad, %48-63 + bad,0,1,2,3,4,5,6,7,8,9,10,11,12,13,14, + 15,16,17,18,19,20,21,22,23,24,25,bad,bad,bad,bad,bad, + bad,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40, + 41,42,43,44,45,46,47,48,49,50,51,bad,bad,bad,bad,bad, + bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, + bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, + bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, + bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, + bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, + bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, + bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, + bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad}). + +-compile({inline, [{b64e, 1}]}). b64e(X) -> element(X+1, {$A, $B, $C, $D, $E, $F, $G, $H, $I, $J, $K, $L, $M, $N, @@ -368,9 +463,3 @@ b64e(X) -> $a, $b, $c, $d, $e, $f, $g, $h, $i, $j, $k, $l, $m, $n, $o, $p, $q, $r, $s, $t, $u, $v, $w, $x, $y, $z, $0, $1, $2, $3, $4, $5, $6, $7, $8, $9, $+, $/}). - - -b64d(X) -> - b64d_ok(element(X, ?DECODE_MAP)). - -b64d_ok(I) when is_integer(I) -> I. diff --git a/lib/stdlib/src/beam_lib.erl b/lib/stdlib/src/beam_lib.erl index 06c15fceda..24349c74e8 100644 --- a/lib/stdlib/src/beam_lib.erl +++ b/lib/stdlib/src/beam_lib.erl @@ -148,7 +148,8 @@ chunks(File, Chunks, Options) -> try read_chunk_data(File, Chunks, Options) catch Error -> Error end. --spec all_chunks(beam()) -> {'ok', 'beam_lib', [{chunkid(), dataB()}]}. +-spec all_chunks(beam()) -> + {'ok', 'beam_lib', [{chunkid(), dataB()}]} | {'error', 'beam_lib', info_rsn()}. all_chunks(File) -> read_all_chunks(File). diff --git a/lib/stdlib/src/binary.erl b/lib/stdlib/src/binary.erl index 6a64133b45..7d0e42489e 100644 --- a/lib/stdlib/src/binary.erl +++ b/lib/stdlib/src/binary.erl @@ -47,23 +47,39 @@ at(_, _) -> -spec bin_to_list(Subject) -> [byte()] when Subject :: binary(). -bin_to_list(_) -> - erlang:nif_error(undef). +bin_to_list(Subject) -> + binary_to_list(Subject). -spec bin_to_list(Subject, PosLen) -> [byte()] when Subject :: binary(), PosLen :: part(). -bin_to_list(_, _) -> - erlang:nif_error(undef). +bin_to_list(Subject, {Pos, Len}) -> + bin_to_list(Subject, Pos, Len); +bin_to_list(_Subject, _BadArg) -> + erlang:error(badarg). -spec bin_to_list(Subject, Pos, Len) -> [byte()] when Subject :: binary(), Pos :: non_neg_integer(), Len :: integer(). -bin_to_list(_, _, _) -> - erlang:nif_error(undef). +bin_to_list(Subject, Pos, Len) when not is_binary(Subject); + not is_integer(Pos); + not is_integer(Len) -> + %% binary_to_list/3 allows bitstrings as long as the slice fits, and we + %% want to badarg when Pos/Len aren't integers instead of raising badarith + %% when adjusting args for binary_to_list/3. + erlang:error(badarg); +bin_to_list(Subject, Pos, 0) when Pos >= 0, Pos =< byte_size(Subject) -> + %% binary_to_list/3 doesn't handle this case. + []; +bin_to_list(_Subject, _Pos, 0) -> + erlang:error(badarg); +bin_to_list(Subject, Pos, Len) when Len < 0 -> + bin_to_list(Subject, Pos + Len, -Len); +bin_to_list(Subject, Pos, Len) when Len > 0 -> + binary_to_list(Subject, Pos + 1, Pos + Len). -spec compile_pattern(Pattern) -> cp() when Pattern :: binary() | [binary()]. diff --git a/lib/stdlib/src/c.erl b/lib/stdlib/src/c.erl index c04a201ce1..13f78841aa 100644 --- a/lib/stdlib/src/c.erl +++ b/lib/stdlib/src/c.erl @@ -564,7 +564,7 @@ display_info(Pid) -> Other end, Reds = fetch(reductions, Info), - LM = length(fetch(messages, Info)), + LM = fetch(message_queue_len, Info), HS = fetch(heap_size, Info), SS = fetch(stack_size, Info), iformat(w(Pid), mfa_string(Call), @@ -668,19 +668,23 @@ lm() -> [l(M) || M <- mm()]. %% erlangrc(Home) -%% Try to run a ".erlang" file, first in the current directory -%% else in home directory. +%% Try to run a ".erlang" file in home directory. + +-spec erlangrc() -> {ok, file:filename()} | {error, term()}. erlangrc() -> case init:get_argument(home) of {ok,[[Home]]} -> erlangrc([Home]); _ -> - f_p_e(["."], ".erlang") + {error, enoent} end. -erlangrc([Home]) -> - f_p_e([".",Home], ".erlang"). +-spec erlangrc(PathList) -> {ok, file:filename()} | {error, term()} + when PathList :: [Dir :: file:name()]. + +erlangrc([Home|_]=Paths) when is_list(Home) -> + f_p_e(Paths, ".erlang"). error(Fmt, Args) -> error_logger:error_msg(Fmt, Args). @@ -692,11 +696,11 @@ f_p_e(P, F) -> {error, E={Line, _Mod, _Term}} -> error("file:path_eval(~tp,~tp): error on line ~p: ~ts~n", [P, F, Line, file:format_error(E)]), - ok; + {error, E}; {error, E} -> error("file:path_eval(~tp,~tp): ~ts~n", [P, F, file:format_error(E)]), - ok; + {error, E}; Other -> Other end. @@ -882,7 +886,7 @@ portinfo(Id) -> procline(Name, Info, Pid) -> Call = initial_call(Info), Reds = fetch(reductions, Info), - LM = length(fetch(messages, Info)), + LM = fetch(message_queue_len, Info), procformat(io_lib:format("~tw",[Name]), io_lib:format("~w",[Pid]), io_lib:format("~ts",[mfa_string(Call)]), @@ -1030,8 +1034,8 @@ appcall(App, M, F, Args) -> try apply(M, F, Args) catch - error:undef -> - case erlang:get_stacktrace() of + error:undef:S -> + case S of [{M,F,Args,_}|_] -> Arity = length(Args), io:format("Call to ~w:~w/~w in application ~w failed.\n", diff --git a/lib/stdlib/src/calendar.erl b/lib/stdlib/src/calendar.erl index 55a0cfc9a1..2e24e8c133 100644 --- a/lib/stdlib/src/calendar.erl +++ b/lib/stdlib/src/calendar.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2016. All Rights Reserved. +%% Copyright Ericsson AB 1996-2018. 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. @@ -41,6 +41,8 @@ now_to_universal_time/1, seconds_to_daystime/1, seconds_to_time/1, + system_time_to_local_time/2, + system_time_to_universal_time/2, time_difference/2, time_to_seconds/1, universal_time/0, @@ -59,6 +61,7 @@ -define(DAYS_PER_100YEARS, 36524). -define(DAYS_PER_400YEARS, 146097). -define(DAYS_FROM_0_TO_1970, 719528). +-define(SECONDS_FROM_0_TO_1970, (?DAYS_FROM_0_TO_1970*?SECONDS_PER_DAY)). %%---------------------------------------------------------------------- %% Types @@ -309,7 +312,7 @@ local_time_to_universal_time_dst(DateTime) -> -spec now_to_datetime(Now) -> datetime1970() when Now :: erlang:timestamp(). now_to_datetime({MSec, Sec, _uSec}) -> - Sec0 = MSec*1000000 + Sec + ?DAYS_FROM_0_TO_1970*?SECONDS_PER_DAY, + Sec0 = MSec*1000000 + Sec + ?SECONDS_FROM_0_TO_1970, gregorian_seconds_to_datetime(Sec0). -spec now_to_universal_time(Now) -> datetime1970() when @@ -363,6 +366,22 @@ seconds_to_time(Secs) when Secs >= 0, Secs < ?SECONDS_PER_DAY -> Second = Secs1 rem ?SECONDS_PER_MINUTE, {Hour, Minute, Second}. +-spec system_time_to_local_time(Time, TimeUnit) -> datetime() when + Time :: integer(), + TimeUnit :: erlang:time_unit(). + +system_time_to_local_time(Time, TimeUnit) -> + UniversalDate = system_time_to_universal_time(Time, TimeUnit), + erlang:universaltime_to_localtime(UniversalDate). + +-spec system_time_to_universal_time(Time, TimeUnit) -> datetime() when + Time :: integer(), + TimeUnit :: erlang:time_unit(). + +system_time_to_universal_time(Time, TimeUnit) -> + Secs = erlang:convert_time_unit(Time, TimeUnit, second), + gregorian_seconds_to_datetime(Secs + ?SECONDS_FROM_0_TO_1970). + %% time_difference(T1, T2) = Tdiff %% %% Returns the difference between two {Date, Time} structures. diff --git a/lib/stdlib/src/dets.erl b/lib/stdlib/src/dets.erl index 4e3fe0e5c1..e1a36abc70 100644 --- a/lib/stdlib/src/dets.erl +++ b/lib/stdlib/src/dets.erl @@ -1288,8 +1288,8 @@ init(Parent, Server) -> catch exit:normal -> exit(normal); - _:Bad -> - bug_found(no_name, Op, Bad, From), + _:Bad:Stacktrace -> + bug_found(no_name, Op, Bad, Stacktrace, From), exit(Bad) % give up end end. @@ -1371,8 +1371,8 @@ do_apply_op(Op, From, Head, N) -> catch exit:normal -> exit(normal); - _:Bad -> - bug_found(Head#head.name, Op, Bad, From), + _:Bad:Stacktrace -> + bug_found(Head#head.name, Op, Bad, Stacktrace, From), open_file_loop(Head, N) end. @@ -1581,7 +1581,7 @@ apply_op(Op, From, Head, N) -> ok end. -bug_found(Name, Op, Bad, From) -> +bug_found(Name, Op, Bad, Stacktrace, From) -> case dets_utils:debug_mode() of true -> %% If stream_op/5 found more requests, this is not @@ -1590,7 +1590,7 @@ bug_found(Name, Op, Bad, From) -> ("** dets: Bug was found when accessing table ~tw,~n" "** dets: operation was ~tp and reply was ~tw.~n" "** dets: Stacktrace: ~tw~n", - [Name, Op, Bad, erlang:get_stacktrace()]); + [Name, Op, Bad, Stacktrace]); false -> error_logger:format ("** dets: Bug was found when accessing table ~tw~n", diff --git a/lib/stdlib/src/dets_utils.erl b/lib/stdlib/src/dets_utils.erl index 17f55ebdc2..4c8ea9e82b 100644 --- a/lib/stdlib/src/dets_utils.erl +++ b/lib/stdlib/src/dets_utils.erl @@ -377,7 +377,8 @@ corrupt_reason(Head, Reason0) -> no_disk_map -> Reason0; DM -> - ST = erlang:get_stacktrace(), + {current_stacktrace, ST} = + erlang:process_info(self(), current_stacktrace), PD = get(), {Reason0, ST, PD, DM} end, diff --git a/lib/stdlib/src/epp.erl b/lib/stdlib/src/epp.erl index b8e48bff6c..77cc88eb08 100644 --- a/lib/stdlib/src/epp.erl +++ b/lib/stdlib/src/epp.erl @@ -479,7 +479,7 @@ com_enc(_B, _Fun, _N, L, Ps) -> com_enc_end([L | Ps]). com_enc_end(Ps0) -> - Ps = lists:reverse([lists:reverse(string:to_lower(P)) || P <- Ps0]), + Ps = lists:reverse([lists:reverse(lowercase(P)) || P <- Ps0]), com_encoding(Ps). com_encoding(["latin","1"|_]) -> @@ -489,6 +489,9 @@ com_encoding(["utf","8"|_]) -> com_encoding(_) -> throw(no). % Don't try any further +lowercase(S) -> + unicode:characters_to_list(string:lowercase(S)). + normalize_typed_record_fields([]) -> {typed, []}; normalize_typed_record_fields(Fields) -> diff --git a/lib/stdlib/src/erl_compile.erl b/lib/stdlib/src/erl_compile.erl index 18d7548fdc..f781312ca2 100644 --- a/lib/stdlib/src/erl_compile.erl +++ b/lib/stdlib/src/erl_compile.erl @@ -188,6 +188,8 @@ parse_dep_option("", T) -> {[makedep,{makedep_output,standard_io}],T}; parse_dep_option("D", T) -> {[makedep],T}; +parse_dep_option("MD", T) -> + {[makedep_side_effect],T}; parse_dep_option("F"++Opt, T0) -> {File,T} = get_option("MF", Opt, T0), {[makedep,{makedep_output,File}],T}; @@ -221,6 +223,7 @@ usage() -> "the dependencies"}, {"-MP","add a phony target for each dependency"}, {"-MD","same as -M -MT file (with default 'file')"}, + {"-MMD","generate dependencies as a side-effect"}, {"-o name","name output directory or file"}, {"-pa path","add path to the front of Erlang's code path"}, {"-pz path","add path to the end of Erlang's code path"}, diff --git a/lib/stdlib/src/erl_eval.erl b/lib/stdlib/src/erl_eval.erl index eafee346eb..4ee11383da 100644 --- a/lib/stdlib/src/erl_eval.erl +++ b/lib/stdlib/src/erl_eval.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2016. All Rights Reserved. +%% Copyright Ericsson AB 1996-2018. 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. @@ -69,6 +69,9 @@ -type(non_local_function_handler() :: {value, nlfun_handler()} | none). +-define(STACKTRACE, + element(2, erlang:process_info(self(), current_stacktrace))). + %% exprs(ExpressionSeq, Bindings) %% exprs(ExpressionSeq, Bindings, LocalFuncHandler) %% exprs(ExpressionSeq, Bindings, LocalFuncHandler, ExternalFuncHandler) @@ -90,7 +93,7 @@ exprs(Exprs, Bs) -> ok -> exprs(Exprs, Bs, none, none, none); {error,{_Line,_Mod,Error}} -> - erlang:raise(error, Error, [{?MODULE,exprs,2}]) + erlang:raise(error, Error, ?STACKTRACE) end. -spec(exprs(Expressions, Bindings, LocalFunctionHandler) -> @@ -141,7 +144,7 @@ expr(E, Bs) -> ok -> expr(E, Bs, none, none, none); {error,{_Line,_Mod,Error}} -> - erlang:raise(error, Error, [{?MODULE,expr,2}]) + erlang:raise(error, Error, ?STACKTRACE) end. -spec(expr(Expression, Bindings, LocalFunctionHandler) -> @@ -182,7 +185,7 @@ check_command(Es, Bs) -> fun_data(F) when is_function(F) -> case erlang:fun_info(F, module) of - {module,erl_eval} -> + {module,?MODULE} -> case erlang:fun_info(F, env) of {env,[{FBs,_FLf,_FEf,FCs}]} -> {fun_data,FBs,FCs}; @@ -209,8 +212,8 @@ expr({var,_,V}, Bs, _Lf, _Ef, RBs) -> case binding(V, Bs) of {value,Val} -> ret_expr(Val, Bs, RBs); - unbound -> % Should not happen. - erlang:raise(error, {unbound,V}, stacktrace()) + unbound -> % Cannot not happen if checked by erl_lint + erlang:raise(error, {unbound,V}, ?STACKTRACE) end; expr({char,_,C}, Bs, _Lf, _Ef, RBs) -> ret_expr(C, Bs, RBs); @@ -236,13 +239,13 @@ expr({tuple,_,Es}, Bs0, Lf, Ef, RBs) -> {Vs,Bs} = expr_list(Es, Bs0, Lf, Ef), ret_expr(list_to_tuple(Vs), Bs, RBs); expr({record_field,_,_,Name,_}, _Bs, _Lf, _Ef, _RBs) -> - erlang:raise(error, {undef_record,Name}, stacktrace()); + erlang:raise(error, {undef_record,Name}, ?STACKTRACE); expr({record_index,_,Name,_}, _Bs, _Lf, _Ef, _RBs) -> - erlang:raise(error, {undef_record,Name}, stacktrace()); + erlang:raise(error, {undef_record,Name}, ?STACKTRACE); expr({record,_,Name,_}, _Bs, _Lf, _Ef, _RBs) -> - erlang:raise(error, {undef_record,Name}, stacktrace()); + erlang:raise(error, {undef_record,Name}, ?STACKTRACE); expr({record,_,_,Name,_}, _Bs, _Lf, _Ef, _RBs) -> - erlang:raise(error, {undef_record,Name}, stacktrace()); + erlang:raise(error, {undef_record,Name}, ?STACKTRACE); %% map expr({map,_,Binding,Es}, Bs0, Lf, Ef, RBs) -> @@ -281,7 +284,7 @@ expr({'fun',_Line,{function,Mod0,Name0,Arity0}}, Bs0, Lf, Ef, RBs) -> ret_expr(F, Bs, RBs); expr({'fun',_Line,{function,Name,Arity}}, _Bs0, _Lf, _Ef, _RBs) -> % R8 %% Don't know what to do... - erlang:raise(error, undef, [{erl_eval,Name,Arity}|stacktrace()]); + erlang:raise(error, undef, [{?MODULE,Name,Arity}|?STACKTRACE]); expr({'fun',Line,{clauses,Cs}} = Ex, Bs, Lf, Ef, RBs) -> %% Save only used variables in the function environment. %% {value,L,V} are hidden while lint finds used variables. @@ -326,7 +329,7 @@ expr({'fun',Line,{clauses,Cs}} = Ex, Bs, Lf, Ef, RBs) -> eval_fun([A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T], Info) end; _Other -> erlang:raise(error, {'argument_limit',{'fun',Line,Cs}}, - stacktrace()) + ?STACKTRACE) end, ret_expr(F, Bs, RBs); expr({named_fun,Line,Name,Cs} = Ex, Bs, Lf, Ef, RBs) -> @@ -378,7 +381,7 @@ expr({named_fun,Line,Name,Cs} = Ex, Bs, Lf, Ef, RBs) -> RF, Info) end; _Other -> erlang:raise(error, {'argument_limit',{named_fun,Line,Name,Cs}}, - stacktrace()) + ?STACKTRACE) end, ret_expr(F, Bs, RBs); expr({call,_,{remote,_,{atom,_,qlc},{atom,_,q}},[{lc,_,_E,_Qs}=LC | As0]}, @@ -422,25 +425,28 @@ expr({call,_,Func0,As0}, Bs0, Lf, Ef, RBs) -> % function or {Mod,Fun} {As,Bs2} = expr_list(As0, Bs1, Lf, Ef), case Func of {M,F} when is_atom(M), is_atom(F) -> - erlang:raise(error, {badfun,Func}, stacktrace()); + erlang:raise(error, {badfun,Func}, ?STACKTRACE); _ -> do_apply(Func, As, Bs2, Ef, RBs) end; expr({'catch',_,Expr}, Bs0, Lf, Ef, RBs) -> - Ref = make_ref(), - case catch {Ref,expr(Expr, Bs0, Lf, Ef, none)} of - {Ref,{value,V,Bs}} -> % Nothing was thrown (guaranteed). - ret_expr(V, Bs, RBs); - Other -> - ret_expr(Other, Bs0, RBs) + try expr(Expr, Bs0, Lf, Ef, none) of + {value,V,Bs} -> + ret_expr(V, Bs, RBs) + catch + throw:Term -> + ret_expr(Term, Bs0, RBs); + exit:Reason -> + ret_expr({'EXIT',Reason}, Bs0, RBs); + error:Reason:Stacktrace -> + ret_expr({'EXIT',{Reason,Stacktrace}}, Bs0, RBs) end; expr({match,_,Lhs,Rhs0}, Bs0, Lf, Ef, RBs) -> {value,Rhs,Bs1} = expr(Rhs0, Bs0, Lf, Ef, none), case match(Lhs, Rhs, Bs1) of {match,Bs} -> ret_expr(Rhs, Bs, RBs); - nomatch -> - erlang:raise(error, {badmatch,Rhs}, stacktrace()) + nomatch -> erlang:raise(error, {badmatch,Rhs}, ?STACKTRACE) end; expr({op,_,Op,A0}, Bs0, Lf, Ef, RBs) -> {value,A,Bs} = expr(A0, Bs0, Lf, Ef, none), @@ -452,7 +458,7 @@ expr({op,_,'andalso',L0,R0}, Bs0, Lf, Ef, RBs) -> {value,R,_} = expr(R0, Bs1, Lf, Ef, none), R; false -> false; - _ -> erlang:raise(error, {badarg,L}, stacktrace()) + _ -> erlang:raise(error, {badarg,L}, ?STACKTRACE) end, ret_expr(V, Bs1, RBs); expr({op,_,'orelse',L0,R0}, Bs0, Lf, Ef, RBs) -> @@ -462,7 +468,7 @@ expr({op,_,'orelse',L0,R0}, Bs0, Lf, Ef, RBs) -> false -> {value,R,_} = expr(R0, Bs1, Lf, Ef, none), R; - _ -> erlang:raise(error, {badarg,L}, stacktrace()) + _ -> erlang:raise(error, {badarg,L}, ?STACKTRACE) end, ret_expr(V, Bs1, RBs); expr({op,_,Op,L0,R0}, Bs0, Lf, Ef, RBs) -> @@ -474,7 +480,7 @@ expr({bin,_,Fs}, Bs0, Lf, Ef, RBs) -> {value,V,Bs} = eval_bits:expr_grp(Fs, Bs0, EvalFun), ret_expr(V, Bs, RBs); expr({remote,_,_,_}, _Bs, _Lf, _Ef, _RBs) -> - erlang:raise(error, {badexpr,':'}, stacktrace()); + erlang:raise(error, {badexpr,':'}, ?STACKTRACE); expr({value,_,Val}, Bs, _Lf, _Ef, RBs) -> % Special case straight values. ret_expr(Val, Bs, RBs). @@ -570,7 +576,7 @@ local_func(Func, As, _Bs, {M,F,Eas}, _Ef, RBs) -> local_func2(apply(M, F, [Func,As|Eas]), RBs); %% Default unknown function handler to undefined function. local_func(Func, As0, _Bs0, none, _Ef, _RBs) -> - erlang:raise(error, undef, [{erl_eval,Func,length(As0)}|stacktrace()]). + erlang:raise(error, undef, [{?MODULE,Func,length(As0)}|?STACKTRACE]). local_func2({value,V,Bs}, RBs) -> ret_expr(V, Bs, RBs); @@ -637,7 +643,7 @@ do_apply(Func, As, Bs0, Ef, RBs) -> {{arity, Arity}, Arity} -> eval_fun(FCs, As, FBs, FLf, FEf, NRBs); _ -> - erlang:raise(error, {badarity,{Func,As}},stacktrace()) + erlang:raise(error, {badarity,{Func,As}},?STACKTRACE) end; {{env,[{FBs,FLf,FEf,FCs,FName}]},_} -> NRBs = if @@ -648,7 +654,7 @@ do_apply(Func, As, Bs0, Ef, RBs) -> {{arity, Arity}, Arity} -> eval_named_fun(FCs, As, FBs, FLf, FEf, FName, Func, NRBs); _ -> - erlang:raise(error, {badarity,{Func,As}},stacktrace()) + erlang:raise(error, {badarity,{Func,As}},?STACKTRACE) end; {no_env,none} when RBs =:= value -> %% Make tail recursive calls when possible. @@ -730,7 +736,7 @@ eval_generate([V|Rest], P, Bs0, Lf, Ef, CompFun, Acc) -> eval_generate([], _P, _Bs0, _Lf, _Ef, _CompFun, Acc) -> Acc; eval_generate(Term, _P, _Bs0, _Lf, _Ef, _CompFun, _Acc) -> - erlang:raise(error, {bad_generator,Term}, stacktrace()). + erlang:raise(error, {bad_generator,Term}, ?STACKTRACE). eval_b_generate(<<_/bitstring>>=Bin, P, Bs0, Lf, Ef, CompFun, Acc) -> Mfun = match_fun(Bs0), @@ -746,7 +752,7 @@ eval_b_generate(<<_/bitstring>>=Bin, P, Bs0, Lf, Ef, CompFun, Acc) -> Acc end; eval_b_generate(Term, _P, _Bs0, _Lf, _Ef, _CompFun, _Acc) -> - erlang:raise(error, {bad_generator,Term}, stacktrace()). + erlang:raise(error, {bad_generator,Term}, ?STACKTRACE). eval_filter(F, Bs0, Lf, Ef, CompFun, Acc) -> case erl_lint:is_guard_test(F) of @@ -760,7 +766,7 @@ eval_filter(F, Bs0, Lf, Ef, CompFun, Acc) -> {value,true,Bs1} -> CompFun(Bs1); {value,false,_} -> Acc; {value,V,_} -> - erlang:raise(error, {bad_filter,V}, stacktrace()) + erlang:raise(error, {bad_filter,V}, ?STACKTRACE) end end. @@ -816,7 +822,7 @@ eval_fun([{clause,_,H,G,B}|Cs], As, Bs0, Lf, Ef, RBs) -> end; eval_fun([], As, _Bs, _Lf, _Ef, _RBs) -> erlang:raise(error, function_clause, - [{?MODULE,'-inside-an-interpreted-fun-',As}|stacktrace()]). + [{?MODULE,'-inside-an-interpreted-fun-',As}|?STACKTRACE]). eval_named_fun(As, Fun, {Bs0,Lf,Ef,Cs,Name}) -> @@ -836,7 +842,7 @@ eval_named_fun([{clause,_,H,G,B}|Cs], As, Bs0, Lf, Ef, Name, Fun, RBs) -> end; eval_named_fun([], As, _Bs, _Lf, _Ef, _Name, _Fun, _RBs) -> erlang:raise(error, function_clause, - [{?MODULE,'-inside-an-interpreted-fun-',As}|stacktrace()]). + [{?MODULE,'-inside-an-interpreted-fun-',As}|?STACKTRACE]). %% expr_list(ExpressionList, Bindings) @@ -894,13 +900,13 @@ if_clauses([{clause,_,[],G,B}|Cs], Bs, Lf, Ef, RBs) -> false -> if_clauses(Cs, Bs, Lf, Ef, RBs) end; if_clauses([], _Bs, _Lf, _Ef, _RBs) -> - erlang:raise(error, if_clause, stacktrace()). + erlang:raise(error, if_clause, ?STACKTRACE). %% try_clauses(Body, CaseClauses, CatchClauses, AfterBody, Bindings, %% LocalFuncHandler, ExtFuncHandler, RBs) -%% When/if variable bindings between the different parts of a -%% try-catch expression are introduced this will have to be rewritten. + try_clauses(B, Cases, Catches, AB, Bs, Lf, Ef, RBs) -> + check_stacktrace_vars(Catches, Bs), try exprs(B, Bs, Lf, Ef, none) of {value,V,Bs1} when Cases =:= [] -> ret_expr(V, Bs1, RBs); @@ -909,23 +915,18 @@ try_clauses(B, Cases, Catches, AB, Bs, Lf, Ef, RBs) -> {B2,Bs2} -> exprs(B2, Bs2, Lf, Ef, RBs); nomatch -> - erlang:raise(error, {try_clause,V}, stacktrace()) + erlang:raise(error, {try_clause,V}, ?STACKTRACE) end catch - Class:Reason when Catches =:= [] -> - %% Rethrow - erlang:raise(Class, Reason, stacktrace()); - Class:Reason -> -%%% %% Set stacktrace -%%% try erlang:raise(Class, Reason, stacktrace()) -%%% catch _:_ -> ok -%%% end, - V = {Class,Reason,erlang:get_stacktrace()}, - case match_clause(Catches, [V],Bs, Lf, Ef) of + Class:Reason:Stacktrace when Catches =:= [] -> + erlang:raise(Class, Reason, Stacktrace); + Class:Reason:Stacktrace -> + V = {Class,Reason,Stacktrace}, + case match_clause(Catches, [V], Bs, Lf, Ef) of {B2,Bs2} -> exprs(B2, Bs2, Lf, Ef, RBs); nomatch -> - erlang:raise(Class, Reason, stacktrace()) + erlang:raise(Class, Reason, Stacktrace) end after if AB =:= [] -> @@ -935,6 +936,23 @@ try_clauses(B, Cases, Catches, AB, Bs, Lf, Ef, RBs) -> end end. +check_stacktrace_vars([{clause,_,[{tuple,_,[_,_,STV]}],_,_}|Cs], Bs) -> + case STV of + {var,_,V} -> + case binding(V, Bs) of + {value, _} -> + erlang:raise(error, stacktrace_bound, ?STACKTRACE); + unbound -> + check_stacktrace_vars(Cs, Bs) + end; + _ -> + erlang:raise(error, + {illegal_stacktrace_variable,STV}, + ?STACKTRACE) + end; +check_stacktrace_vars([], _Bs) -> + ok. + %% case_clauses(Value, Clauses, Bindings, LocalFuncHandler, ExtFuncHandler, %% RBs) @@ -943,7 +961,7 @@ case_clauses(Val, Cs, Bs, Lf, Ef, RBs) -> {B, Bs1} -> exprs(B, Bs1, Lf, Ef, RBs); nomatch -> - erlang:raise(error, {case_clause,Val}, stacktrace()) + erlang:raise(error, {case_clause,Val}, ?STACKTRACE) end. %% @@ -1018,7 +1036,7 @@ guard0([G|Gs], Bs0, Lf, Ef) -> {value,false,_} -> false end; false -> - erlang:raise(error, guard_expr, stacktrace()) + erlang:raise(error, guard_expr, ?STACKTRACE) end; guard0([], _Bs, _Lf, _Ef) -> true. @@ -1073,7 +1091,7 @@ match(Pat, Term, Bs) -> match(Pat, Term, Bs, BBs) -> case catch match1(Pat, Term, Bs, BBs) of invalid -> - erlang:raise(error, {illegal_pattern,Pat}, stacktrace()); + erlang:raise(error, {illegal_pattern,Pat}, ?STACKTRACE); Other -> Other end. @@ -1254,7 +1272,7 @@ merge_bindings(Bs1, Bs2) -> case orddict:find(Name, Bs) of {ok,Val} -> Bs; %Already with SAME value {ok,V1} -> - erlang:raise(error, {badmatch,V1}, stacktrace()); + erlang:raise(error, {badmatch,V1}, ?STACKTRACE); error -> orddict:store(Name, Val, Bs) end end, Bs2, orddict:to_list(Bs1)). @@ -1264,7 +1282,7 @@ merge_bindings(Bs1, Bs2) -> %% fun (Name, Val, Bs) -> %% case orddict:find(Name, Bs) of %% {ok,Val} -> orddict:erase(Name, Bs); -%% {ok,V1} -> erlang:raise(error,{badmatch,V1},stacktrace()); +%% {ok,V1} -> erlang:raise(error,{badmatch,V1},?STACKTRACE); %% error -> Bs %% end %% end, Bs2, Bs1). @@ -1326,7 +1344,3 @@ ret_expr(_Old, New) -> New. line(Expr) -> element(2, Expr). - -%% {?MODULE,expr,3} is still the stacktrace, despite the -%% fact that expr() now takes two, three or four arguments... -stacktrace() -> [{?MODULE,expr,3}]. diff --git a/lib/stdlib/src/erl_internal.erl b/lib/stdlib/src/erl_internal.erl index 89b97b901e..6d3d5baa23 100644 --- a/lib/stdlib/src/erl_internal.erl +++ b/lib/stdlib/src/erl_internal.erl @@ -76,6 +76,7 @@ guard_bif(floor, 1) -> true; guard_bif(hd, 1) -> true; guard_bif(length, 1) -> true; guard_bif(map_size, 1) -> true; +guard_bif(map_get, 2) -> true; guard_bif(node, 0) -> true; guard_bif(node, 1) -> true; guard_bif(round, 1) -> true; @@ -337,6 +338,7 @@ bif(list_to_tuple, 1) -> true; bif(load_module, 2) -> true; bif(make_ref, 0) -> true; bif(map_size,1) -> true; +bif(map_get,2) -> true; bif(max,2) -> true; bif(min,2) -> true; bif(module_loaded, 1) -> true; diff --git a/lib/stdlib/src/erl_lint.erl b/lib/stdlib/src/erl_lint.erl index 9cd4727dc3..e9ac2fcdff 100644 --- a/lib/stdlib/src/erl_lint.erl +++ b/lib/stdlib/src/erl_lint.erl @@ -2,7 +2,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2017. All Rights Reserved. +%% Copyright Ericsson AB 1996-2018. 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. @@ -93,13 +93,6 @@ value_option(Flag, Default, On, OnVal, Off, OffVal, Opts) -> }). -%% Are we outside or inside a catch or try/catch? --type catch_scope() :: 'none' - | 'after_old_catch' - | 'after_try' - | 'wrong_part_of_try' - | 'try_catch'. - %% Define the lint state record. %% 'called' and 'exports' contain {Line, {Function, Arity}}, %% the other function collections contain {Function, Arity}. @@ -144,8 +137,7 @@ value_option(Flag, Default, On, OnVal, Off, OffVal, Opts) -> :: dict:dict(ta(), #typeinfo{}), exp_types=gb_sets:empty() %Exported types :: gb_sets:set(ta()), - catch_scope = none %Inside/outside try or catch - :: catch_scope() + in_try_head=false :: boolean() %In a try head. }). -type lint_state() :: #lint{}. @@ -232,15 +224,6 @@ format_error({redefine_old_bif_import,{F,A}}) -> format_error({redefine_bif_import,{F,A}}) -> io_lib:format("import directive overrides auto-imported BIF ~w/~w~n" " - use \"-compile({no_auto_import,[~w/~w]}).\" to resolve name clash", [F,A,F,A]); -format_error({get_stacktrace,wrong_part_of_try}) -> - "erlang:get_stacktrace/0 used in the wrong part of 'try' expression. " - "(Use it in the block between 'catch' and 'end'.)"; -format_error({get_stacktrace,after_old_catch}) -> - "erlang:get_stacktrace/0 used following an old-style 'catch' " - "may stop working in a future release. (Use it inside 'try'.)"; -format_error({get_stacktrace,after_try}) -> - "erlang:get_stacktrace/0 used following a 'try' expression " - "may stop working in a future release. (Use it inside 'try'.)"; format_error({deprecated, MFA, ReplacementMFA, Rel}) -> io_lib:format("~s is deprecated and will be removed in ~s; use ~s", [format_mfa(MFA), Rel, format_mfa(ReplacementMFA)]); @@ -312,6 +295,10 @@ format_error({unused_var, V}) -> io_lib:format("variable ~w is unused", [V]); format_error({variable_in_record_def,V}) -> io_lib:format("variable ~w in record definition", [V]); +format_error({stacktrace_guard,V}) -> + io_lib:format("stacktrace variable ~w must not be used in a guard", [V]); +format_error({stacktrace_bound,V}) -> + io_lib:format("stacktrace variable ~w must not be previously bound", [V]); %% --- binaries --- format_error({undefined_bittype,Type}) -> io_lib:format("bit type ~tw undefined", [Type]); @@ -586,10 +573,7 @@ start(File, Opts) -> false, Opts)}, {missing_spec_all, bool_option(warn_missing_spec_all, nowarn_missing_spec_all, - false, Opts)}, - {get_stacktrace, - bool_option(warn_get_stacktrace, nowarn_get_stacktrace, - true, Opts)} + false, Opts)} ], Enabled1 = [Category || {Category,true} <- Enabled0], Enabled = ordsets:from_list(Enabled1), @@ -1421,7 +1405,7 @@ call_function(Line, F, A, #lint{usage=Usage0,called=Cd,func=Func,file=File}=St) %% function(Line, Name, Arity, Clauses, State) -> State. function(Line, Name, Arity, Cs, St0) -> - St1 = St0#lint{func={Name,Arity},catch_scope=none}, + St1 = St0#lint{func={Name,Arity}}, St2 = define_function(Line, Name, Arity, St1), clauses(Cs, St2). @@ -2111,6 +2095,10 @@ is_gexpr({cons,_L,H,T}, Info) -> is_gexpr_list([H,T], Info); is_gexpr({tuple,_L,Es}, Info) -> is_gexpr_list(Es, Info); %%is_gexpr({struct,_L,_Tag,Es}, Info) -> %% is_gexpr_list(Es, Info); +is_gexpr({map,_L,Es}, Info) -> + is_map_fields(Es, Info); +is_gexpr({map,_L,Src,Es}, Info) -> + is_gexpr(Src, Info) andalso is_map_fields(Es, Info); is_gexpr({record_index,_L,_Name,Field}, Info) -> is_gexpr(Field, Info); is_gexpr({record_field,_L,Rec,_Name,Field}, Info) -> @@ -2153,6 +2141,14 @@ is_gexpr_op(Op, A) -> is_gexpr_list(Es, Info) -> all(fun (E) -> is_gexpr(E, Info) end, Es). +is_map_fields([{Tag,_,K,V}|Fs], Info) when Tag =:= map_field_assoc; + Tag =:= map_field_exact -> + is_gexpr(K, Info) andalso + is_gexpr(V, Info) andalso + is_map_fields(Fs, Info); +is_map_fields([], _Info) -> true; +is_map_fields(_T, _Info) -> false. + is_gexpr_fields(Fs, L, Name, {RDs,_}=Info) -> IFs = case dict:find(Name, RDs) of {ok,{_Line,Fields}} -> Fs ++ init_fields(Fs, L, Fields); @@ -2362,7 +2358,7 @@ expr({call,Line,F,As}, Vt, St0) -> expr({'try',Line,Es,Scs,Ccs,As}, Vt, St0) -> %% Currently, we don't allow any exports because later %% passes cannot handle exports in combination with 'after'. - {Evt0,St1} = exprs(Es, Vt, St0#lint{catch_scope=wrong_part_of_try}), + {Evt0,St1} = exprs(Es, Vt, St0), TryLine = {'try',Line}, Uvt = vtunsafe(TryLine, Evt0, Vt), Evt1 = vtupdate(Uvt, Evt0), @@ -2374,12 +2370,11 @@ expr({'try',Line,Es,Scs,Ccs,As}, Vt, St0) -> {Avt0,St} = exprs(As, vtupdate(Evt2, Vt), St2), Avt1 = vtupdate(vtunsafe(TryLine, Avt0, Vt), Avt0), Avt = vtmerge(Evt2, Avt1), - {Avt,St#lint{catch_scope=after_try}}; + {Avt,St}; expr({'catch',Line,E}, Vt, St0) -> %% No new variables added, flag new variables as unsafe. {Evt,St} = expr(E, Vt, St0), - {vtupdate(vtunsafe({'catch',Line}, Evt, Vt), Evt), - St#lint{catch_scope=after_old_catch}}; + {vtupdate(vtunsafe({'catch',Line}, Evt, Vt), Evt),St}; expr({match,_Line,P,E}, Vt, St0) -> {Evt,St1} = expr(E, Vt, St0), {Pvt,Bvt,St2} = pattern(P, vtupdate(Evt, Vt), St1), @@ -3218,11 +3213,11 @@ is_module_dialyzer_option(Option) -> try_clauses(Scs, Ccs, In, Vt, St0) -> {Csvt0,St1} = icrt_clauses(Scs, Vt, St0), - St2 = St1#lint{catch_scope=try_catch}, + St2 = St1#lint{in_try_head=true}, {Csvt1,St3} = icrt_clauses(Ccs, Vt, St2), Csvt = Csvt0 ++ Csvt1, UpdVt = icrt_export(Csvt, Vt, In, St3), - {UpdVt,St3}. + {UpdVt,St3#lint{in_try_head=false}}. %% icrt_clauses(Clauses, In, ImportVarTable, State) -> %% {UpdVt,State}. @@ -3238,13 +3233,30 @@ icrt_clauses(Cs, In, Vt, St0) -> icrt_clauses(Cs, Vt, St) -> mapfoldl(fun (C, St0) -> icrt_clause(C, Vt, St0) end, St, Cs). -icrt_clause({clause,_Line,H,G,B}, Vt0, #lint{catch_scope=Scope}=St0) -> - {Hvt,Binvt,St1} = head(H, Vt0, St0), - Vt1 = vtupdate(Hvt, Binvt), - {Gvt,St2} = guard(G, vtupdate(Vt1, Vt0), St1), - Vt2 = vtupdate(Gvt, Vt1), - {Bvt,St3} = exprs(B, vtupdate(Vt2, Vt0), St2), - {vtupdate(Bvt, Vt2),St3#lint{catch_scope=Scope}}. +icrt_clause({clause,_Line,H,G,B}, Vt0, St0) -> + Vt1 = taint_stack_var(Vt0, H, St0), + {Hvt,Binvt,St1} = head(H, Vt1, St0), + Vt2 = vtupdate(Hvt, Binvt), + Vt3 = taint_stack_var(Vt2, H, St0), + {Gvt,St2} = guard(G, vtupdate(Vt3, Vt0), St1#lint{in_try_head=false}), + Vt4 = vtupdate(Gvt, Vt2), + {Bvt,St3} = exprs(B, vtupdate(Vt4, Vt0), St2), + {vtupdate(Bvt, Vt4),St3}. + +taint_stack_var(Vt, Pat, #lint{in_try_head=true}) -> + [{tuple,_,[_,_,{var,_,Stk}]}] = Pat, + case Stk of + '_' -> + Vt; + _ -> + lists:map(fun({V,{bound,Used,Lines}}) when V =:= Stk -> + {V,{stacktrace,Used,Lines}}; + (B) -> + B + end, Vt) + end; +taint_stack_var(Vt, _Pat, #lint{in_try_head=false}) -> + Vt. icrt_export(Vts, Vt, {Tag,Attrs}, St) -> {_File,Loc} = loc(Attrs, St), @@ -3484,6 +3496,9 @@ pat_var(V, Line, Vt, Bvt, St) -> {[{V,{bound,used,Ls}}],[], %% As this is matching, exported vars are risky. add_warning(Line, {exported_var,V,From}, St)}; + {ok,{stacktrace,_Usage,Ls}} -> + {[{V,{bound,used,Ls}}],[], + add_error(Line, {stacktrace_bound,V}, St)}; error when St#lint.recdef_top -> {[],[{V,{bound,unused,[Line]}}], add_error(Line, {variable_in_record_def,V}, St)}; @@ -3541,6 +3556,9 @@ expr_var(V, Line, Vt, St) -> false -> {[{V,{{export,From},used,Ls}}],St} end; + {ok,{stacktrace,_Usage,Ls}} -> + {[{V,{bound,used,Ls}}], + add_error(Line, {stacktrace_guard,V}, St)}; error -> {[{V,{bound,used,[Line]}}], add_error(Line, {unbound_var,V}, St)} @@ -3708,8 +3726,7 @@ has_wildcard_field([]) -> false. check_remote_function(Line, M, F, As, St0) -> St1 = deprecated_function(Line, M, F, As, St0), St2 = check_qlc_hrl(Line, M, F, As, St1), - St3 = check_get_stacktrace(Line, M, F, As, St2), - format_function(Line, M, F, As, St3). + format_function(Line, M, F, As, St2). %% check_qlc_hrl(Line, ModName, FuncName, [Arg], State) -> State %% Add warning if qlc:q/1,2 has been called but qlc.hrl has not @@ -3758,23 +3775,6 @@ deprecated_function(Line, M, F, As, St) -> St end. -check_get_stacktrace(Line, erlang, get_stacktrace, [], St) -> - case St of - #lint{catch_scope=none} -> - St; - #lint{catch_scope=try_catch} -> - St; - #lint{catch_scope=Scope} -> - case is_warn_enabled(get_stacktrace, St) of - false -> - St; - true -> - add_warning(Line, {get_stacktrace,Scope}, St) - end - end; -check_get_stacktrace(_, _, _, _, St) -> - St. - -dialyzer({no_match, deprecated_type/5}). deprecated_type(L, M, N, As, St) -> @@ -3910,10 +3910,9 @@ check_format_string(Fmt) -> extract_sequences(Fmt, []). extract_sequences(Fmt, Need0) -> - case string:chr(Fmt, $~) of - 0 -> {ok,lists:reverse(Need0)}; %That's it - Pos -> - Fmt1 = string:substr(Fmt, Pos+1), %Skip ~ + case string:find(Fmt, [$~]) of + nomatch -> {ok,lists:reverse(Need0)}; %That's it + [$~|Fmt1] -> case extract_sequence(1, Fmt1, Need0) of {ok,Need1,Rest} -> extract_sequences(Rest, Need1); Error -> Error @@ -3944,6 +3943,8 @@ extract_sequence(3, [$.,_|Fmt], Need) -> extract_sequence(4, Fmt, Need); extract_sequence(3, Fmt, Need) -> extract_sequence(4, Fmt, Need); +extract_sequence(4, [$t, $l | Fmt], Need) -> + extract_sequence(4, [$l, $t | Fmt], Need); extract_sequence(4, [$t, $c | Fmt], Need) -> extract_sequence(5, [$c|Fmt], Need); extract_sequence(4, [$t, $s | Fmt], Need) -> @@ -3960,8 +3961,14 @@ extract_sequence(4, [$t, C | _Fmt], _Need) -> {error,"invalid control ~t" ++ [C]}; extract_sequence(4, [$l, $p | Fmt], Need) -> extract_sequence(5, [$p|Fmt], Need); +extract_sequence(4, [$l, $t, $p | Fmt], Need) -> + extract_sequence(5, [$p|Fmt], Need); extract_sequence(4, [$l, $P | Fmt], Need) -> extract_sequence(5, [$P|Fmt], Need); +extract_sequence(4, [$l, $t, $P | Fmt], Need) -> + extract_sequence(5, [$P|Fmt], Need); +extract_sequence(4, [$l, $t, C | _Fmt], _Need) -> + {error,"invalid control ~lt" ++ [C]}; extract_sequence(4, [$l, C | _Fmt], _Need) -> {error,"invalid control ~l" ++ [C]}; extract_sequence(4, Fmt, Need) -> diff --git a/lib/stdlib/src/erl_parse.yrl b/lib/stdlib/src/erl_parse.yrl index 6e72d64acc..0c338b5952 100644 --- a/lib/stdlib/src/erl_parse.yrl +++ b/lib/stdlib/src/erl_parse.yrl @@ -29,6 +29,10 @@ clause_args clause_guard clause_body expr expr_100 expr_150 expr_160 expr_200 expr_300 expr_400 expr_500 expr_600 expr_700 expr_800 expr_max +pat_expr pat_expr_200 pat_expr_300 pat_expr_400 pat_expr_500 +pat_expr_600 pat_expr_700 pat_expr_800 +pat_expr_max map_pat_expr record_pat_expr +pat_argument_list pat_exprs list tail list_comprehension lc_expr lc_exprs binary_comprehension @@ -37,7 +41,7 @@ record_expr record_tuple record_field record_fields map_expr map_tuple map_field map_field_assoc map_field_exact map_fields map_key if_expr if_clause if_clauses case_expr cr_clause cr_clauses receive_expr fun_expr fun_clause fun_clauses atom_or_var integer_or_var -try_expr try_catch try_clause try_clauses +try_expr try_catch try_clause try_clauses try_opt_stacktrace function_call argument_list exprs guard atomic strings @@ -66,7 +70,7 @@ char integer float atom string var 'spec' 'callback' % helper dot. -Expect 2. +Expect 0. Rootsymbol form. @@ -210,7 +214,7 @@ function_clause -> atom clause_args clause_guard clause_body : {clause,?anno('$1'),element(3, '$1'),'$2','$3','$4'}. -clause_args -> argument_list : element(1, '$1'). +clause_args -> pat_argument_list : element(1, '$1'). clause_guard -> 'when' guard : '$2'. clause_guard -> '$empty' : []. @@ -275,6 +279,53 @@ expr_max -> receive_expr : '$1'. expr_max -> fun_expr : '$1'. expr_max -> try_expr : '$1'. +pat_expr -> pat_expr_200 '=' pat_expr : {match,?anno('$2'),'$1','$3'}. +pat_expr -> pat_expr_200 : '$1'. + +pat_expr_200 -> pat_expr_300 comp_op pat_expr_300 : + ?mkop2('$1', '$2', '$3'). +pat_expr_200 -> pat_expr_300 : '$1'. + +pat_expr_300 -> pat_expr_400 list_op pat_expr_300 : + ?mkop2('$1', '$2', '$3'). +pat_expr_300 -> pat_expr_400 : '$1'. + +pat_expr_400 -> pat_expr_400 add_op pat_expr_500 : + ?mkop2('$1', '$2', '$3'). +pat_expr_400 -> pat_expr_500 : '$1'. + +pat_expr_500 -> pat_expr_500 mult_op pat_expr_600 : + ?mkop2('$1', '$2', '$3'). +pat_expr_500 -> pat_expr_600 : '$1'. + +pat_expr_600 -> prefix_op pat_expr_700 : + ?mkop1('$1', '$2'). +pat_expr_600 -> map_pat_expr : '$1'. +pat_expr_600 -> pat_expr_700 : '$1'. + +pat_expr_700 -> record_pat_expr : '$1'. +pat_expr_700 -> pat_expr_800 : '$1'. + +pat_expr_800 -> pat_expr_max : '$1'. + +pat_expr_max -> var : '$1'. +pat_expr_max -> atomic : '$1'. +pat_expr_max -> list : '$1'. +pat_expr_max -> binary : '$1'. +pat_expr_max -> tuple : '$1'. +pat_expr_max -> '(' pat_expr ')' : '$2'. + +map_pat_expr -> '#' map_tuple : + {map, ?anno('$1'),'$2'}. +map_pat_expr -> pat_expr_max '#' map_tuple : + {map, ?anno('$2'),'$1','$3'}. +map_pat_expr -> map_pat_expr '#' map_tuple : + {map, ?anno('$2'),'$1','$3'}. + +record_pat_expr -> '#' atom '.' atom : + {record_index,?anno('$1'),element(3, '$2'),'$4'}. +record_pat_expr -> '#' atom record_tuple : + {record,?anno('$1'),element(3, '$2'),'$3'}. list -> '[' ']' : {nil,?anno('$1')}. list -> '[' expr tail : {cons,?anno('$1'),'$2','$3'}. @@ -397,6 +448,10 @@ case_expr -> 'case' expr 'of' cr_clauses 'end' : cr_clauses -> cr_clause : ['$1']. cr_clauses -> cr_clause ';' cr_clauses : ['$1' | '$3']. +%% FIXME: merl in syntax_tools depends on patterns in a 'case' being +%% full expressions. Therefore, we can't use pat_expr here. There +%% should be a better way. + cr_clause -> expr clause_guard clause_body : {clause,?anno('$1'),['$1'],'$2','$3'}. @@ -424,11 +479,11 @@ integer_or_var -> var : '$1'. fun_clauses -> fun_clause : ['$1']. fun_clauses -> fun_clause ';' fun_clauses : ['$1' | '$3']. -fun_clause -> argument_list clause_guard clause_body : +fun_clause -> pat_argument_list clause_guard clause_body : {Args,Anno} = '$1', {clause,Anno,'fun',Args,'$2','$3'}. -fun_clause -> var argument_list clause_guard clause_body : +fun_clause -> var pat_argument_list clause_guard clause_body : {clause,element(2, '$1'),element(3, '$1'),element(1, '$2'),'$3','$4'}. try_expr -> 'try' exprs 'of' cr_clauses try_catch : @@ -446,24 +501,31 @@ try_catch -> 'after' exprs 'end' : try_clauses -> try_clause : ['$1']. try_clauses -> try_clause ';' try_clauses : ['$1' | '$3']. -try_clause -> expr clause_guard clause_body : +try_clause -> pat_expr clause_guard clause_body : A = ?anno('$1'), {clause,A,[{tuple,A,[{atom,A,throw},'$1',{var,A,'_'}]}],'$2','$3'}. -try_clause -> atom ':' expr clause_guard clause_body : +try_clause -> atom ':' pat_expr try_opt_stacktrace clause_guard clause_body : A = ?anno('$1'), - {clause,A,[{tuple,A,['$1','$3',{var,A,'_'}]}],'$4','$5'}. -try_clause -> var ':' expr clause_guard clause_body : + {clause,A,[{tuple,A,['$1','$3',{var,A,'$4'}]}],'$5','$6'}. +try_clause -> var ':' pat_expr try_opt_stacktrace clause_guard clause_body : A = ?anno('$1'), - {clause,A,[{tuple,A,['$1','$3',{var,A,'_'}]}],'$4','$5'}. + {clause,A,[{tuple,A,['$1','$3',{var,A,'$4'}]}],'$5','$6'}. +try_opt_stacktrace -> ':' var : element(3, '$2'). +try_opt_stacktrace -> '$empty' : '_'. argument_list -> '(' ')' : {[],?anno('$1')}. argument_list -> '(' exprs ')' : {'$2',?anno('$1')}. +pat_argument_list -> '(' ')' : {[],?anno('$1')}. +pat_argument_list -> '(' pat_exprs ')' : {'$2',?anno('$1')}. exprs -> expr : ['$1']. exprs -> expr ',' exprs : ['$1' | '$3']. +pat_exprs -> pat_expr : ['$1']. +pat_exprs -> pat_expr ',' pat_exprs : ['$1' | '$3']. + guard -> exprs : ['$1']. guard -> exprs ';' guard : ['$1'|'$3']. @@ -1315,6 +1377,8 @@ normalise({map,_,Pairs}=M) -> ({map_field_assoc,_,K,V}) -> {normalise(K),normalise(V)}; (_) -> erlang:error({badarg,M}) end, Pairs)); +normalise({'fun',_,{function,{atom,_,M},{atom,_,F},{integer,_,A}}}) -> + fun M:F/A; %% Special case for unary +/-. normalise({op,_,'+',{char,_,I}}) -> I; normalise({op,_,'+',{integer,_,I}}) -> I; diff --git a/lib/stdlib/src/erl_posix_msg.erl b/lib/stdlib/src/erl_posix_msg.erl index bfafca1ff7..8959fea498 100644 --- a/lib/stdlib/src/erl_posix_msg.erl +++ b/lib/stdlib/src/erl_posix_msg.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1997-2016. All Rights Reserved. +%% Copyright Ericsson AB 1997-2018. 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. @@ -64,6 +64,7 @@ message_1(eduppkg) -> <<"duplicate package name">>; message_1(eexist) -> <<"file already exists">>; message_1(efault) -> <<"bad address in system call argument">>; message_1(efbig) -> <<"file too large">>; +message_1(eftype) -> <<"EFTYPE">>; message_1(ehostdown) -> <<"host is down">>; message_1(ehostunreach) -> <<"host is unreachable">>; message_1(eidrm) -> <<"identifier removed">>; @@ -115,6 +116,7 @@ message_1(enopkg) -> <<"package not installed">>; message_1(enoprotoopt) -> <<"bad proocol option">>; message_1(enospc) -> <<"no space left on device">>; message_1(enosr) -> <<"out of stream resources or not a stream device">>; +message_1(enostr) -> <<"not a stream">>; message_1(enosym) -> <<"unresolved symbol name">>; message_1(enosys) -> <<"function not implemented">>; message_1(enotblk) -> <<"block device required">>; @@ -128,6 +130,7 @@ message_1(enotty) -> <<"inappropriate device for ioctl">>; message_1(enotuniq) -> <<"name not unique on network">>; message_1(enxio) -> <<"no such device or address">>; message_1(eopnotsupp) -> <<"operation not supported on socket">>; +message_1(eoverflow) -> <<"offset too large for file system">>; message_1(eperm) -> <<"not owner">>; message_1(epfnosupport) -> <<"protocol family not supported">>; message_1(epipe) -> <<"broken pipe">>; @@ -167,4 +170,6 @@ message_1(ewouldblock) -> <<"operation would block">>; message_1(exdev) -> <<"cross-domain link">>; message_1(exfull) -> <<"message tables full">>; message_1(nxdomain) -> <<"non-existing domain">>; +message_1(exbadport) -> <<"inet_drv bad port state">>; +message_1(exbadseq) -> <<"inet_drv bad request sequence">>; message_1(_) -> <<"unknown POSIX error">>. diff --git a/lib/stdlib/src/erl_pp.erl b/lib/stdlib/src/erl_pp.erl index ee5e7a11bf..367dbefb82 100644 --- a/lib/stdlib/src/erl_pp.erl +++ b/lib/stdlib/src/erl_pp.erl @@ -237,13 +237,20 @@ lform({attribute,Line,Name,Arg}, Opts) -> lform({function,Line,Name,Arity,Clauses}, Opts) -> lfunction({function,Line,Name,Arity,Clauses}, Opts); %% These are specials to make it easier for the compiler. -lform({error,E}, _Opts) -> - leaf(format("~p\n", [{error,E}])); -lform({warning,W}, _Opts) -> - leaf(format("~p\n", [{warning,W}])); +lform({error,_}=E, Opts) -> + message(E, Opts); +lform({warning,_}=W, Opts) -> + message(W, Opts); lform({eof,_Line}, _Opts) -> $\n. +message(M, #options{encoding = Encoding}) -> + F = case Encoding of + latin1 -> "~p\n"; + unicode -> "~tp\n" + end, + leaf(format(F, [M])). + lattribute({attribute,_Line,type,Type}, Opts) -> [typeattr(type, Type, Opts),leaf(".\n")]; lattribute({attribute,_Line,opaque,Type}, Opts) -> @@ -598,8 +605,6 @@ lexpr({'fun',_,{clauses,Cs},Extra}, _Prec, Opts) -> lexpr({named_fun,_,Name,Cs,Extra}, _Prec, Opts) -> {force_nl,fun_info(Extra), {list,[{first,['fun', " "],fun_clauses(Cs, Opts, {named, Name})},'end']}}; -lexpr({'query',_,Lc}, _Prec, Opts) -> - {list,[{step,leaf("query"),lexpr(Lc, 0, Opts)},'end']}; lexpr({call,_,{remote,_,{atom,_,M},{atom,_,F}=N}=Name,Args}, Prec, Opts) -> case erl_internal:bif(M, F, length(Args)) of true -> @@ -904,7 +909,7 @@ maybe_paren(_P, _Prec, Expr) -> Expr. leaf(S) -> - {leaf,chars_size(S),S}. + {leaf,string:length(S),S}. %%% Do the formatting. Currently nothing fancy. Could probably have %%% done it in one single pass. @@ -964,7 +969,7 @@ f({seq,Before,After,Sep,LItems}, I0, ST, WT, PP) -> Sizes = BSizeL ++ SizeL, NSepChars = if is_list(Sep), Sep =/= [] -> - erlang:max(0, length(CharsL)-1); + erlang:max(0, length(CharsL)-1); % not string:length true -> 0 end, @@ -1120,7 +1125,7 @@ incr(I, Incr) -> I+Incr. indentation(E, I) when I < 0 -> - chars_size(E); + string:length(E); indentation(E, I0) -> I = io_lib_format:indentation(E, I0), case has_nl(E) of @@ -1157,19 +1162,19 @@ write_a_string(S, I, PP) -> write_a_string([], _N, _Len, _PP) -> []; write_a_string(S, N, Len, PP) -> - SS = string:sub_string(S, 1, N), + SS = string:slice(S, 0, N), Sl = write_string(SS, PP), - case (chars_size(Sl) > Len) and (N > ?MIN_SUBSTRING) of + case (string:length(Sl) > Len) and (N > ?MIN_SUBSTRING) of true -> write_a_string(S, N-1, Len, PP); false -> [flat_leaf(Sl) | - write_a_string(lists:nthtail(length(SS), S), Len, Len, PP)] + write_a_string(string:slice(S, string:length(SS)), Len, Len, PP)] end. flat_leaf(S) -> L = lists:flatten(S), - {leaf,length(L),L}. + {leaf,string:length(L),L}. write_value(V, PP) -> (PP#pp.value_fun)(V). @@ -1190,15 +1195,6 @@ write_char(C, PP) -> a0() -> erl_anno:new(0). -chars_size([C | Es]) when is_integer(C) -> - 1 + chars_size(Es); -chars_size([E | Es]) -> - chars_size(E) + chars_size(Es); -chars_size([]) -> - 0; -chars_size(B) when is_binary(B) -> - byte_size(B). - -define(N_SPACES, 30). spacetab() -> diff --git a/lib/stdlib/src/erl_scan.erl b/lib/stdlib/src/erl_scan.erl index 47223b129c..4774c4bf19 100644 --- a/lib/stdlib/src/erl_scan.erl +++ b/lib/stdlib/src/erl_scan.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2015. 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. @@ -752,7 +752,7 @@ scan_string(Cs, St, Line, Col, Toks, {Wcs,Str,Line0,Col0}) -> {char_error,Ncs,Error,Nline,Ncol,EndCol} -> scan_error(Error, Nline, Ncol, Nline, EndCol, Ncs); {error,Nline,Ncol,Nwcs,Ncs} -> - Estr = string:substr(Nwcs, 1, 16), % Expanded escape chars. + Estr = string:slice(Nwcs, 0, 16), % Expanded escape chars. scan_error({string,$\",Estr}, Line0, Col0, Nline, Ncol, Ncs); %" {Ncs,Nline,Ncol,Nstr,Nwcs} -> Anno = anno(Line0, Col0, St, Nstr), @@ -767,7 +767,7 @@ scan_qatom(Cs, St, Line, Col, Toks, {Wcs,Str,Line0,Col0}) -> {char_error,Ncs,Error,Nline,Ncol,EndCol} -> scan_error(Error, Nline, Ncol, Nline, EndCol, Ncs); {error,Nline,Ncol,Nwcs,Ncs} -> - Estr = string:substr(Nwcs, 1, 16), % Expanded escape chars. + Estr = string:slice(Nwcs, 0, 16), % Expanded escape chars. scan_error({string,$\',Estr}, Line0, Col0, Nline, Ncol, Ncs); %' {Ncs,Nline,Ncol,Nstr,Nwcs} -> case catch list_to_atom(Nwcs) of diff --git a/lib/stdlib/src/erl_tar.erl b/lib/stdlib/src/erl_tar.erl index 5ee584d612..d8b8f466b1 100644 --- a/lib/stdlib/src/erl_tar.erl +++ b/lib/stdlib/src/erl_tar.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1997-2017. All Rights Reserved. +%% Copyright Ericsson AB 1997-2018. 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. @@ -457,26 +457,61 @@ add(Reader, NameOrBin, NameInArchive, Options) do_add(#reader{access=write}=Reader, Name, NameInArchive, Options) when is_list(NameInArchive), is_list(Options) -> - RF = fun(F) -> file:read_link_info(F, [{time, posix}]) end, + RF = apply_file_info_opts_fun(Options, read_link_info), Opts = #add_opts{read_info=RF}, - add1(Reader, Name, NameInArchive, add_opts(Options, Opts)); + add1(Reader, Name, NameInArchive, add_opts(Options, Options, Opts)); do_add(#reader{access=read},_,_,_) -> {error, eacces}; do_add(Reader,_,_,_) -> {error, {badarg, Reader}}. -add_opts([dereference|T], Opts) -> - RF = fun(F) -> file:read_file_info(F, [{time, posix}]) end, - add_opts(T, Opts#add_opts{read_info=RF}); -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) -> +add_opts([dereference|T], AllOptions, Opts) -> + RF = apply_file_info_opts_fun(AllOptions, read_file_info), + add_opts(T, AllOptions, Opts#add_opts{read_info=RF}); +add_opts([verbose|T], AllOptions, Opts) -> + add_opts(T, AllOptions, Opts#add_opts{verbose=true}); +add_opts([{chunks,N}|T], AllOptions, Opts) -> + add_opts(T, AllOptions, Opts#add_opts{chunk_size=N}); +add_opts([{atime,Value}|T], AllOptions, Opts) -> + add_opts(T, AllOptions, Opts#add_opts{atime=Value}); +add_opts([{mtime,Value}|T], AllOptions, Opts) -> + add_opts(T, AllOptions, Opts#add_opts{mtime=Value}); +add_opts([{ctime,Value}|T], AllOptions, Opts) -> + add_opts(T, AllOptions, Opts#add_opts{ctime=Value}); +add_opts([{uid,Value}|T], AllOptions, Opts) -> + add_opts(T, AllOptions, Opts#add_opts{uid=Value}); +add_opts([{gid,Value}|T], AllOptions, Opts) -> + add_opts(T, AllOptions, Opts#add_opts{gid=Value}); +add_opts([_|T], AllOptions, Opts) -> + add_opts(T, AllOptions, Opts); +add_opts([], _AllOptions, Opts) -> Opts. +apply_file_info_opts(Opts, {ok, FileInfo}) -> + {ok, do_apply_file_info_opts(Opts, FileInfo)}; +apply_file_info_opts(_Opts, Other) -> + Other. + +do_apply_file_info_opts([{atime,Value}|T], FileInfo) -> + do_apply_file_info_opts(T, FileInfo#file_info{atime=Value}); +do_apply_file_info_opts([{mtime,Value}|T], FileInfo) -> + do_apply_file_info_opts(T, FileInfo#file_info{mtime=Value}); +do_apply_file_info_opts([{ctime,Value}|T], FileInfo) -> + do_apply_file_info_opts(T, FileInfo#file_info{ctime=Value}); +do_apply_file_info_opts([{uid,Value}|T], FileInfo) -> + do_apply_file_info_opts(T, FileInfo#file_info{uid=Value}); +do_apply_file_info_opts([{gid,Value}|T], FileInfo) -> + do_apply_file_info_opts(T, FileInfo#file_info{gid=Value}); +do_apply_file_info_opts([_|T], FileInfo) -> + do_apply_file_info_opts(T, FileInfo); +do_apply_file_info_opts([], FileInfo) -> + FileInfo. + +apply_file_info_opts_fun(Options, InfoFunction) -> + fun(F) -> + apply_file_info_opts(Options, file:InfoFunction(F, [{time, posix}])) + end. + add1(#reader{}=Reader, Name, NameInArchive, #add_opts{read_info=ReadInfo}=Opts) when is_list(Name) -> Res = case ReadInfo(Name) of @@ -515,9 +550,11 @@ add1(Reader, Bin, NameInArchive, Opts) when is_binary(Bin) -> name = NameInArchive, size = byte_size(Bin), typeflag = ?TYPE_REGULAR, - atime = Now, - mtime = Now, - ctime = Now, + atime = add_opts_time(Opts#add_opts.atime, Now), + mtime = add_opts_time(Opts#add_opts.mtime, Now), + ctime = add_opts_time(Opts#add_opts.ctime, Now), + uid = Opts#add_opts.uid, + gid = Opts#add_opts.gid, mode = 8#100644}, {ok, Reader2} = add_header(Reader, Header, Opts), Padding = skip_padding(byte_size(Bin)), @@ -527,6 +564,9 @@ add1(Reader, Bin, NameInArchive, Opts) when is_binary(Bin) -> {error, Reason} -> {error, {NameInArchive, Reason}} end. +add_opts_time(undefined, Now) -> Now; +add_opts_time(Time, _Now) -> Time. + add_directory(Reader, DirName, NameInArchive, Info, Opts) -> case file:list_dir(DirName) of {ok, []} -> @@ -1650,8 +1690,12 @@ write_file(Name, Bin) -> case file:write_file(Name, Bin) of ok -> ok; {error,enoent} -> - ok = make_dirs(Name, file), - write_file(Name, Bin); + case make_dirs(Name, file) of + ok -> + write_file(Name, Bin); + {error,Reason} -> + throw({error, Reason}) + end; {error,Reason} -> throw({error, Reason}) end. diff --git a/lib/stdlib/src/erl_tar.hrl b/lib/stdlib/src/erl_tar.hrl index cff0c2f500..5d6cecbb66 100644 --- a/lib/stdlib/src/erl_tar.hrl +++ b/lib/stdlib/src/erl_tar.hrl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2017. All Rights Reserved. +%% Copyright Ericsson AB 1997-2018. 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,12 @@ -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. + verbose = false, %% Verbose on/off. + atime = undefined, + mtime = undefined, + ctime = undefined, + uid = 0, + gid = 0}). -type add_opts() :: #add_opts{}. %% Options used when reading a tar archive. @@ -36,7 +41,12 @@ -type add_opt() :: dereference | verbose | - {chunks, pos_integer()}. + {chunks, pos_integer()} | + {atime, non_neg_integer()} | + {mtime, non_neg_integer()} | + {ctime, non_neg_integer()} | + {uid, non_neg_integer()} | + {gid, non_neg_integer()}. -type extract_opt() :: {cwd, string()} | {files, [string()]} | diff --git a/lib/stdlib/src/escript.erl b/lib/stdlib/src/escript.erl index 2b9d8ff65b..beea9927d2 100644 --- a/lib/stdlib/src/escript.erl +++ b/lib/stdlib/src/escript.erl @@ -224,8 +224,8 @@ return_sections(S, Bin) -> normalize_section(Name, undefined) -> {Name, undefined}; normalize_section(shebang, "#!" ++ Chars) -> - Chopped = string:strip(Chars, right, $\n), - Stripped = string:strip(Chopped, both), + Chopped = string:trim(Chars, trailing, "$\n"), + Stripped = string:trim(Chopped, both), if Stripped =:= ?SHEBANG -> {shebang, default}; @@ -233,8 +233,8 @@ normalize_section(shebang, "#!" ++ Chars) -> {shebang, Stripped} end; normalize_section(comment, Chars) -> - Chopped = string:strip(Chars, right, $\n), - Stripped = string:strip(string:strip(Chopped, left, $%), both), + Chopped = string:trim(Chars, trailing, "$\n"), + Stripped = string:trim(string:trim(Chopped, leading, "$%"), both), if Stripped =:= ?COMMENT -> {comment, default}; @@ -242,8 +242,8 @@ normalize_section(comment, Chars) -> {comment, Stripped} end; normalize_section(emu_args, "%%!" ++ Chars) -> - Chopped = string:strip(Chars, right, $\n), - Stripped = string:strip(Chopped, both), + Chopped = string:trim(Chars, trailing, "$\n"), + Stripped = string:trim(Chopped, both), {emu_args, Stripped}; normalize_section(Name, Chars) -> {Name, Chars}. @@ -283,8 +283,7 @@ start(EscriptOptions) -> throw:Str -> io:format("escript: ~ts\n", [Str]), my_halt(127); - _:Reason -> - Stk = erlang:get_stacktrace(), + _:Reason:Stk -> io:format("escript: Internal error: ~tp\n", [Reason]), io:format("~tp\n", [Stk]), my_halt(127) @@ -759,8 +758,8 @@ run(Module, Args) -> Module:main(Args), my_halt(0) catch - Class:Reason -> - fatal(format_exception(Class, Reason)) + Class:Reason:StackTrace -> + fatal(format_exception(Class, Reason, StackTrace)) end. -spec interpret(_, _, _, _) -> no_return(). @@ -793,8 +792,8 @@ interpret(Forms, HasRecs, File, Args) -> end}), my_halt(0) catch - Class:Reason -> - fatal(format_exception(Class, Reason)) + Class:Reason:StackTrace -> + fatal(format_exception(Class, Reason, StackTrace)) end. report_errors(Errors) -> @@ -873,7 +872,7 @@ eval_exprs([E|Es], Bs0, Lf, Ef, RBs) -> {value,_V,Bs} = erl_eval:expr(E, Bs0, Lf, Ef, RBs1), eval_exprs(Es, Bs, Lf, Ef, RBs). -format_exception(Class, Reason) -> +format_exception(Class, Reason, StackTrace) -> Enc = encoding(), P = case Enc of latin1 -> "P"; @@ -882,7 +881,6 @@ format_exception(Class, Reason) -> PF = fun(Term, I) -> io_lib:format("~." ++ integer_to_list(I) ++ P, [Term, 50]) end, - StackTrace = erlang:get_stacktrace(), StackFun = fun(M, _F, _A) -> (M =:= erl_eval) or (M =:= ?MODULE) end, lib:format_exception(1, Class, Reason, StackTrace, StackFun, PF, Enc). @@ -916,8 +914,8 @@ hidden_apply(App, M, F, Args) -> try apply(fun() -> M end(), F, Args) catch - error:undef -> - case erlang:get_stacktrace() of + error:undef:StackTrace -> + case StackTrace of [{M,F,Args,_} | _] -> Arity = length(Args), Text = io_lib:format("Call to ~w:~w/~w in application ~w failed.\n", diff --git a/lib/stdlib/src/ets.erl b/lib/stdlib/src/ets.erl index 42fa8ede92..6a559f0be5 100644 --- a/lib/stdlib/src/ets.erl +++ b/lib/stdlib/src/ets.erl @@ -73,7 +73,8 @@ select_count/2, select_delete/2, select_replace/2, select_reverse/1, select_reverse/2, select_reverse/3, setopts/2, slot/2, take/2, - update_counter/3, update_counter/4, update_element/3]). + update_counter/3, update_counter/4, update_element/3, + whereis/1]). %% internal exports -export([internal_request_all/0]). @@ -145,6 +146,7 @@ give_away(_, _, _) -> InfoList :: [InfoTuple], InfoTuple :: {compressed, boolean()} | {heir, pid() | none} + | {id, tid()} | {keypos, pos_integer()} | {memory, non_neg_integer()} | {name, atom()} @@ -162,7 +164,7 @@ info(_) -> -spec info(Tab, Item) -> Value | undefined when Tab :: tab(), - Item :: compressed | fixed | heir | keypos | memory + Item :: compressed | fixed | heir | id | keypos | memory | name | named_table | node | owner | protection | safe_fixed | safe_fixed_monotonic_time | size | stats | type | write_concurrency | read_concurrency, @@ -512,6 +514,11 @@ update_counter(_, _, _, _) -> update_element(_, _, _) -> erlang:nif_error(undef). +-spec whereis(TableName) -> tid() | undefined when + TableName :: atom(). +whereis(_) -> + erlang:nif_error(undef). + %%% End of BIFs -opaque comp_match_spec() :: reference(). @@ -882,10 +889,10 @@ tab2file(Tab, File, Options) -> _ = disk_log:close(Name), _ = file:delete(File), exit(ExReason); - error:ErReason -> + error:ErReason:StackTrace -> _ = disk_log:close(Name), _ = file:delete(File), - erlang:raise(error,ErReason,erlang:get_stacktrace()) + erlang:raise(error,ErReason,StackTrace) end catch throw:TReason2 -> @@ -1060,9 +1067,9 @@ file2tab(File, Opts) -> exit:ExReason -> ets:delete(Tab), exit(ExReason); - error:ErReason -> + error:ErReason:StackTrace -> ets:delete(Tab), - erlang:raise(error,ErReason,erlang:get_stacktrace()) + erlang:raise(error,ErReason,StackTrace) end after _ = disk_log:close(Name) @@ -1719,7 +1726,7 @@ get_line(P, Default) -> line_string(Binary) when is_binary(Binary) -> unicode:characters_to_list(Binary); line_string(Other) -> Other. -nonl(S) -> string:strip(S, right, $\n). +nonl(S) -> string:trim(S, trailing, "$\n"). print_number(Tab, Key, Num) -> Os = ets:lookup(Tab, Key), @@ -1748,7 +1755,7 @@ do_display_item(_Height, Width, I, Opos) -> L = to_string(I), L2 = if length(L) > Width - 8 -> - string:substr(L, 1, Width-13) ++ " ..."; + string:slice(L, 0, Width-13) ++ " ..."; true -> L end, diff --git a/lib/stdlib/src/eval_bits.erl b/lib/stdlib/src/eval_bits.erl index 631faa3be5..bb86a65c72 100644 --- a/lib/stdlib/src/eval_bits.erl +++ b/lib/stdlib/src/eval_bits.erl @@ -2,7 +2,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1999-2016. All Rights Reserved. +%% Copyright Ericsson AB 1999-2018. 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. @@ -25,6 +25,9 @@ -export([expr_grp/3,expr_grp/5,match_bits/6, match_bits/7,bin_gen/6]). +-define(STACKTRACE, + element(2, erlang:process_info(self(), current_stacktrace))). + %% Types used in this module: %% @type bindings(). An abstract structure for bindings between %% variables and values (the environment) @@ -93,9 +96,9 @@ eval_exp_field1(V, Size, Unit, Type, Endian, Sign) -> eval_exp_field(V, Size, Unit, Type, Endian, Sign) catch error:system_limit -> - error(system_limit); + erlang:raise(error, system_limit, ?STACKTRACE); error:_ -> - error(badarg) + erlang:raise(error, badarg, ?STACKTRACE) end. eval_exp_field(Val, Size, Unit, integer, little, signed) -> @@ -131,7 +134,7 @@ eval_exp_field(Val, all, Unit, binary, _, _) -> Size when Size rem Unit =:= 0 -> <<Val:Size/binary-unit:1>>; _ -> - error(badarg) + erlang:raise(error, badarg, ?STACKTRACE) end; eval_exp_field(Val, Size, Unit, binary, _, _) -> <<Val:(Size*Unit)/binary-unit:1>>. @@ -377,12 +380,12 @@ make_bit_type(Line, default, Type0) -> {ok,all,Bt} -> {{atom,Line,all},erl_bits:as_list(Bt)}; {ok,undefined,Bt} -> {{atom,Line,undefined},erl_bits:as_list(Bt)}; {ok,Size,Bt} -> {{integer,Line,Size},erl_bits:as_list(Bt)}; - {error,Reason} -> error(Reason) + {error,Reason} -> erlang:raise(error, Reason, ?STACKTRACE) end; make_bit_type(_Line, Size, Type0) -> %Size evaluates to an integer or 'all' case erl_bits:set_bit_type(Size, Type0) of {ok,Size,Bt} -> {Size,erl_bits:as_list(Bt)}; - {error,Reason} -> error(Reason) + {error,Reason} -> erlang:raise(error, Reason, ?STACKTRACE) end. match_check_size(Mfun, Size, Bs) -> @@ -405,9 +408,3 @@ match_check_size(_, {value,_,_}, _Bs, _AllowAll) -> ok; %From the debugger. match_check_size(_, _, _Bs, _AllowAll) -> throw(invalid). - -%% error(Reason) -> exception thrown -%% Throw a nice-looking exception, similar to exceptions from erl_eval. -error(Reason) -> - erlang:raise(error, Reason, [{erl_eval,expr,3}]). - diff --git a/lib/stdlib/src/file_sorter.erl b/lib/stdlib/src/file_sorter.erl index 3aeaff8dc4..7f74e71136 100644 --- a/lib/stdlib/src/file_sorter.erl +++ b/lib/stdlib/src/file_sorter.erl @@ -1314,9 +1314,9 @@ infun(W) -> {cont, W#w{in = NFun}, Objs}; Error -> error(Error, W1) - catch Class:Reason -> + catch Class:Reason:Stacktrace -> cleanup(W1), - erlang:raise(Class, Reason, erlang:get_stacktrace()) + erlang:raise(Class, Reason, Stacktrace) end. outfun(A, #w{inout_value = Val} = W) when Val =/= no_value -> @@ -1336,9 +1336,9 @@ outfun(A, W) -> W#w{out = NF}; Error -> error(Error, W1) - catch Class:Reason -> + catch Class:Reason:Stacktrace -> cleanup(W1), - erlang:raise(Class, Reason, erlang:get_stacktrace()) + erlang:raise(Class, Reason, Stacktrace) end. is_keypos(Keypos) when is_integer(Keypos), Keypos > 0 -> diff --git a/lib/stdlib/src/filelib.erl b/lib/stdlib/src/filelib.erl index a9c055f72d..de839be5cf 100644 --- a/lib/stdlib/src/filelib.erl +++ b/lib/stdlib/src/filelib.erl @@ -365,11 +365,18 @@ do_list_dir(Dir, Mod) -> eval_list_dir(Dir, Mod). %%% Compiling a wildcard. + +%% Define characters used for escaping a \. +-define(ESCAPE_PREFIX, $@). +-define(ESCAPE_CHARACTER, [?ESCAPE_PREFIX,$e]). +-define(ESCAPED_ESCAPE_PREFIX, [?ESCAPE_PREFIX,?ESCAPE_PREFIX]). + %% Only for debugging. compile_wildcard(Pattern) when is_list(Pattern) -> {compiled_wildcard,?HANDLE_ERROR(compile_wildcard(Pattern, "."))}. -compile_wildcard(Pattern, Cwd0) -> +compile_wildcard(Pattern0, Cwd0) -> + Pattern = convert_escapes(Pattern0), [Root|Rest] = filename:split(Pattern), case filename:pathtype(Root) of relative -> @@ -409,7 +416,8 @@ compile_join({cwd,Cwd}, File0) -> compile_join({root,PrefixLen,Root}, File) -> {root,PrefixLen,filename:join(Root, File)}. -compile_part(Part) -> +compile_part(Part0) -> + Part = wrap_escapes(Part0), compile_part(Part, false, []). compile_part_to_sep(Part) -> @@ -445,6 +453,8 @@ compile_part([${|Rest], Upto, Result) -> error -> compile_part(Rest, Upto, [${|Result]) end; +compile_part([{escaped,X}|Rest], Upto, Result) -> + compile_part(Rest, Upto, [X|Result]); compile_part([X|Rest], Upto, Result) -> compile_part(Rest, Upto, [X|Result]); compile_part([], _Upto, Result) -> @@ -461,6 +471,8 @@ compile_charset1([Lower, $-, Upper|Rest], Ordset) when Lower =< Upper -> compile_charset1(Rest, compile_range(Lower, Upper, Ordset)); compile_charset1([$]|Rest], Ordset) -> {ok, {one_of, gb_sets:from_ordset(Ordset)}, Rest}; +compile_charset1([{escaped,X}|Rest], Ordset) -> + compile_charset1(Rest, ordsets:add_element(X, Ordset)); compile_charset1([X|Rest], Ordset) -> compile_charset1(Rest, ordsets:add_element(X, Ordset)); compile_charset1([], _Ordset) -> @@ -486,6 +498,32 @@ compile_alt(Pattern, Result) -> error end. +%% Convert backslashes to an illegal Unicode character to +%% protect in from filename:split/1. + +convert_escapes([?ESCAPE_PREFIX|T]) -> + ?ESCAPED_ESCAPE_PREFIX ++ convert_escapes(T); +convert_escapes([$\\|T]) -> + ?ESCAPE_CHARACTER ++ convert_escapes(T); +convert_escapes([H|T]) -> + [H|convert_escapes(T)]; +convert_escapes([]) -> + []. + +%% Wrap each escape in a tuple to remove the special meaning for +%% the character that follows. + +wrap_escapes(?ESCAPED_ESCAPE_PREFIX ++ T) -> + [?ESCAPE_PREFIX|wrap_escapes(T)]; +wrap_escapes(?ESCAPE_CHARACTER ++ [C|T]) -> + [{escaped,C}|wrap_escapes(T)]; +wrap_escapes(?ESCAPE_CHARACTER) -> + []; +wrap_escapes([H|T]) -> + [H|wrap_escapes(T)]; +wrap_escapes([]) -> + []. + badpattern(Reason) -> error({badpattern,Reason}). diff --git a/lib/stdlib/src/filename.erl b/lib/stdlib/src/filename.erl index ee807dfd09..a322bd002d 100644 --- a/lib/stdlib/src/filename.erl +++ b/lib/stdlib/src/filename.erl @@ -34,6 +34,38 @@ %% we flatten the arguments immediately on function entry as that makes %% it easier to ensure that the code works. +%% +%% *** Requirements on Raw Filename Format *** +%% +%% These requirements are due to the 'filename' module +%% in stdlib. This since it is documented that it +%% should be able to operate on raw filenames as well +%% as ordinary filenames. +%% +%% A raw filename *must* be a byte sequence where: +%% 1. Codepoints 0-127 (7-bit ascii) *must* be encoded +%% as a byte with the corresponding value. That is, +%% the most significant bit in the byte encoding the +%% codepoint is never set. +%% 2. Codepoints greater than 127 *must* be encoded +%% with the most significant bit set in *every* byte +%% encoding it. +%% +%% Latin1 and UTF-8 meet these requirements while +%% UTF-16 and UTF-32 don't. +%% +%% On Windows filenames are natively stored as malformed +%% UTF-16LE (lonely surrogates may appear). A more correct +%% description than UTF-16 would be an array of 16-bit +%% words... In order to meet the requirements of the +%% raw file format we convert the malformed UTF-16LE to +%% malformed UTF-8 which meet the requirements. +%% +%% Note that these requirements are today only OTP +%% internal (erts-stdlib internal) requirements that +%% could be changed. +%% + -export([absname/1, absname/2, absname_join/2, basename/1, basename/2, dirname/1, extension/1, join/1, join/2, pathtype/1, @@ -41,6 +73,7 @@ safe_relative_path/1]). -export([find_src/1, find_src/2]). % deprecated -export([basedir/2, basedir/3]). +-export([validate/1]). %% Undocumented and unsupported exports. -export([append/2]). @@ -1053,10 +1086,10 @@ basedir_linux(Type) -> user_log -> getenv("XDG_CACHE_HOME", ?basedir_linux_user_log, true); site_data -> Base = getenv("XDG_DATA_DIRS",?basedir_linux_site_data,false), - string:tokens(Base,":"); + string:lexemes(Base, ":"); site_config -> Base = getenv("XDG_CONFIG_DIRS",?basedir_linux_site_config,false), - string:tokens(Base,":") + string:lexemes(Base, ":") end. -define(basedir_darwin_user_data, "Library/Application Support"). @@ -1152,3 +1185,72 @@ basedir_os_type() -> {win32,_} -> windows; _ -> linux end. + +%% +%% validate/1 +%% + +-spec validate(FileName) -> boolean() when + FileName :: file:name_all(). + +validate(FileName) when is_binary(FileName) -> + %% Raw filename... + validate_bin(FileName); +validate(FileName) when is_list(FileName); + is_atom(FileName) -> + validate_list(FileName, + file:native_name_encoding(), + os:type()). + +validate_list(FileName, Enc, Os) -> + try + true = validate_list(FileName, Enc, Os, 0) > 0 + catch + _ : _ -> false + end. + +validate_list([], _Enc, _Os, Chars) -> + Chars; +validate_list(C, Enc, Os, Chars) when is_integer(C) -> + validate_char(C, Enc, Os), + Chars+1; +validate_list(A, Enc, Os, Chars) when is_atom(A) -> + validate_list(atom_to_list(A), Enc, Os, Chars); +validate_list([H|T], Enc, Os, Chars) -> + NewChars = validate_list(H, Enc, Os, Chars), + validate_list(T, Enc, Os, NewChars). + +%% C is always an integer... +% validate_char(C, _, _) when not is_integer(C) -> +% throw(invalid); +validate_char(C, _, _) when C < 1 -> + throw(invalid); %% No negative or null characters... +validate_char(C, latin1, _) when C > 255 -> + throw(invalid); +validate_char(C, utf8, _) when C >= 16#110000 -> + throw(invalid); +validate_char(C, utf8, {win32, _}) when C > 16#ffff -> + throw(invalid); %% invalid win wchar... +validate_char(_C, utf8, {win32, _}) -> + ok; %% Range below is accepted on windows... +validate_char(C, utf8, _) when 16#D800 =< C, C =< 16#DFFF -> + throw(invalid); %% invalid unicode range... +validate_char(_, _, _) -> + ok. + +validate_bin(Bin) -> + %% Raw filename. That is, we do not interpret + %% the encoding, but we still do not accept + %% null characters... + try + true = validate_bin(Bin, 0) > 0 + catch + _ : _ -> false + end. + +validate_bin(<<>>, Bs) -> + Bs; +validate_bin(<<0, _Rest/binary>>, _Bs) -> + throw(invalid); %% No null characters allowed... +validate_bin(<<_B, Rest/binary>>, Bs) -> + validate_bin(Rest, Bs+1). diff --git a/lib/stdlib/src/gen.erl b/lib/stdlib/src/gen.erl index 33af0aed8f..2e6223d2bb 100644 --- a/lib/stdlib/src/gen.erl +++ b/lib/stdlib/src/gen.erl @@ -49,6 +49,7 @@ | {'logfile', string()}. -type option() :: {'timeout', timeout()} | {'debug', [debug_flag()]} + | {'hibernate_after', timeout()} | {'spawn_opt', [proc_lib:spawn_option()]}. -type options() :: [option()]. @@ -147,57 +148,36 @@ init_it2(GenMod, Starter, Parent, Name, Mod, Args, Options) -> call(Process, Label, Request) -> call(Process, Label, Request, ?default_timeout). +%% Optimize a common case. +call(Process, Label, Request, Timeout) when is_pid(Process), + Timeout =:= infinity orelse is_integer(Timeout) andalso Timeout >= 0 -> + do_call(Process, Label, Request, Timeout); call(Process, Label, Request, Timeout) when Timeout =:= infinity; is_integer(Timeout), Timeout >= 0 -> Fun = fun(Pid) -> do_call(Pid, Label, Request, Timeout) end, do_for_proc(Process, Fun). -do_call(Process, Label, Request, Timeout) -> - try erlang:monitor(process, Process) of - Mref -> - %% If the monitor/2 call failed to set up a connection to a - %% remote node, we don't want the '!' operator to attempt - %% to set up the connection again. (If the monitor/2 call - %% failed due to an expired timeout, '!' too would probably - %% have to wait for the timeout to expire.) Therefore, - %% use erlang:send/3 with the 'noconnect' option so that it - %% will fail immediately if there is no connection to the - %% remote node. - - catch erlang:send(Process, {Label, {self(), Mref}, Request}, - [noconnect]), - receive - {Mref, Reply} -> - erlang:demonitor(Mref, [flush]), - {ok, Reply}; - {'DOWN', Mref, _, _, noconnection} -> - Node = get_node(Process), - exit({nodedown, Node}); - {'DOWN', Mref, _, _, Reason} -> - exit(Reason) - after Timeout -> - erlang:demonitor(Mref, [flush]), - exit(timeout) - end - catch - error:_ -> - %% Node (C/Java?) is not supporting the monitor. - %% The other possible case -- this node is not distributed - %% -- should have been handled earlier. - %% Do the best possible with monitor_node/2. - %% This code may hang indefinitely if the Process - %% does not exist. It is only used for featureweak remote nodes. - Node = get_node(Process), - monitor_node(Node, true), - receive - {nodedown, Node} -> - monitor_node(Node, false), - exit({nodedown, Node}) - after 0 -> - Tag = make_ref(), - Process ! {Label, {self(), Tag}, Request}, - wait_resp(Node, Tag, Timeout) - end +do_call(Process, Label, Request, Timeout) when is_atom(Process) =:= false -> + Mref = erlang:monitor(process, Process), + + %% OTP-21: + %% Auto-connect is asynchronous. But we still use 'noconnect' to make sure + %% we send on the monitored connection, and not trigger a new auto-connect. + %% + erlang:send(Process, {Label, {self(), Mref}, Request}, [noconnect]), + + receive + {Mref, Reply} -> + erlang:demonitor(Mref, [flush]), + {ok, Reply}; + {'DOWN', Mref, _, _, noconnection} -> + Node = get_node(Process), + exit({nodedown, Node}); + {'DOWN', Mref, _, _, Reason} -> + exit(Reason) + after Timeout -> + erlang:demonitor(Mref, [flush]), + exit(timeout) end. get_node(Process) -> @@ -212,19 +192,6 @@ get_node(Process) -> node(Process) end. -wait_resp(Node, Tag, Timeout) -> - receive - {Tag, Reply} -> - monitor_node(Node, false), - {ok, Reply}; - {nodedown, Node} -> - monitor_node(Node, false), - exit({nodedown, Node}) - after Timeout -> - monitor_node(Node, false), - exit(timeout) - end. - %% %% Send a reply to the client. %% diff --git a/lib/stdlib/src/gen_server.erl b/lib/stdlib/src/gen_server.erl index 7daa7a9fe4..f29314d0a2 100644 --- a/lib/stdlib/src/gen_server.erl +++ b/lib/stdlib/src/gen_server.erl @@ -109,30 +109,34 @@ -define( STACKTRACE(), - try throw(ok) catch _ -> erlang:get_stacktrace() end). + element(2, erlang:process_info(self(), current_stacktrace))). %%%========================================================================= %%% API %%%========================================================================= -callback init(Args :: term()) -> - {ok, State :: term()} | {ok, State :: term(), timeout() | hibernate} | + {ok, State :: term()} | {ok, State :: term(), timeout() | hibernate | {continue, term()}} | {stop, Reason :: term()} | ignore. -callback handle_call(Request :: term(), From :: {pid(), Tag :: term()}, State :: term()) -> {reply, Reply :: term(), NewState :: term()} | - {reply, Reply :: term(), NewState :: term(), timeout() | hibernate} | + {reply, Reply :: term(), NewState :: term(), timeout() | hibernate | {continue, term()}} | {noreply, NewState :: term()} | - {noreply, NewState :: term(), timeout() | hibernate} | + {noreply, NewState :: term(), timeout() | hibernate | {continue, term()}} | {stop, Reason :: term(), Reply :: term(), NewState :: term()} | {stop, Reason :: term(), NewState :: term()}. -callback handle_cast(Request :: term(), State :: term()) -> {noreply, NewState :: term()} | - {noreply, NewState :: term(), timeout() | hibernate} | + {noreply, NewState :: term(), timeout() | hibernate | {continue, term()}} | {stop, Reason :: term(), NewState :: term()}. -callback handle_info(Info :: timeout | term(), State :: term()) -> {noreply, NewState :: term()} | - {noreply, NewState :: term(), timeout() | hibernate} | + {noreply, NewState :: term(), timeout() | hibernate | {continue, term()}} | + {stop, Reason :: term(), NewState :: term()}. +-callback handle_continue(Info :: term(), State :: term()) -> + {noreply, NewState :: term()} | + {noreply, NewState :: term(), timeout() | hibernate | {continue, term()}} | {stop, Reason :: term(), NewState :: term()}. -callback terminate(Reason :: (normal | shutdown | {shutdown, term()} | term()), @@ -149,7 +153,7 @@ Status :: term(). -optional_callbacks( - [handle_info/2, terminate/2, code_change/3, format_status/2]). + [handle_info/2, handle_continue/2, terminate/2, code_change/3, format_status/2]). %%% ----------------------------------------------------------------- %%% Starts a generic server. @@ -309,7 +313,7 @@ enter_loop(Mod, Options, State, ServerName, Timeout) -> Name = gen:get_proc_name(ServerName), Parent = gen:get_parent(), Debug = gen:debug_options(Name, Options), - HibernateAfterTimeout = gen:hibernate_after(Options), + HibernateAfterTimeout = gen:hibernate_after(Options), loop(Parent, Name, State, Mod, Timeout, HibernateAfterTimeout, Debug). %%%======================================================================== @@ -365,7 +369,7 @@ init_it(Mod, Args) -> {ok, Mod:init(Args)} catch throw:R -> {ok, R}; - Class:R -> {'EXIT', Class, R, erlang:get_stacktrace()} + Class:R:S -> {'EXIT', Class, R, S} end. %%%======================================================================== @@ -374,6 +378,19 @@ init_it(Mod, Args) -> %%% --------------------------------------------------- %%% The MAIN loop. %%% --------------------------------------------------- + +loop(Parent, Name, State, Mod, {continue, Continue} = Msg, HibernateAfterTimeout, Debug) -> + Reply = try_dispatch(Mod, handle_continue, Continue, State), + case Debug of + [] -> + handle_common_reply(Reply, Parent, Name, undefined, Msg, Mod, + HibernateAfterTimeout, State); + _ -> + Debug1 = sys:handle_debug(Debug, fun print_event/3, Name, Msg), + handle_common_reply(Reply, Parent, Name, undefined, Msg, Mod, + HibernateAfterTimeout, State, Debug1) + end; + loop(Parent, Name, State, Mod, hibernate, HibernateAfterTimeout, Debug) -> proc_lib:hibernate(?MODULE,wake_hib,[Parent, Name, State, Mod, HibernateAfterTimeout, Debug]); @@ -420,12 +437,11 @@ decode_msg(Msg, Parent, Name, State, Mod, Time, HibernateAfterTimeout, Debug, Hi %%% Send/receive functions %%% --------------------------------------------------- do_send(Dest, Msg) -> - case catch erlang:send(Dest, Msg, [noconnect]) of - noconnect -> - spawn(erlang, send, [Dest,Msg]); - Other -> - Other - end. + try erlang:send(Dest, Msg) + catch + error:_ -> ok + end, + ok. do_multi_call(Nodes, Name, Req, infinity) -> Tag = make_ref(), @@ -617,7 +633,7 @@ try_dispatch(Mod, Func, Msg, State) -> catch throw:R -> {ok, R}; - error:undef = R when Func == handle_info -> + error:undef = R:Stacktrace when Func == handle_info -> case erlang:function_exported(Mod, handle_info, 2) of false -> error_logger:warning_msg("** Undefined handle_info in ~p~n" @@ -625,10 +641,10 @@ try_dispatch(Mod, Func, Msg, State) -> [Mod, Msg]), {ok, {noreply, State}}; true -> - {'EXIT', error, R, erlang:get_stacktrace()} + {'EXIT', error, R, Stacktrace} end; - Class:R -> - {'EXIT', Class, R, erlang:get_stacktrace()} + Class:R:Stacktrace -> + {'EXIT', Class, R, Stacktrace} end. try_handle_call(Mod, Msg, From, State) -> @@ -637,8 +653,8 @@ try_handle_call(Mod, Msg, From, State) -> catch throw:R -> {ok, R}; - Class:R -> - {'EXIT', Class, R, erlang:get_stacktrace()} + Class:R:Stacktrace -> + {'EXIT', Class, R, Stacktrace} end. try_terminate(Mod, Reason, State) -> @@ -649,8 +665,8 @@ try_terminate(Mod, Reason, State) -> catch throw:R -> {ok, R}; - Class:R -> - {'EXIT', Class, R, erlang:get_stacktrace()} + Class:R:Stacktrace -> + {'EXIT', Class, R, Stacktrace} end; false -> {ok, ok} diff --git a/lib/stdlib/src/gen_statem.erl b/lib/stdlib/src/gen_statem.erl index eb0d6bd742..f7dc0050b3 100644 --- a/lib/stdlib/src/gen_statem.erl +++ b/lib/stdlib/src/gen_statem.erl @@ -143,7 +143,7 @@ timeout_action() | reply_action(). -type timeout_action() :: - (Timeout :: event_timeout()) | % {timeout,Timeout} + (Time :: event_timeout()) | % {timeout,Time,Time} {'timeout', % Set the event_timeout option Time :: event_timeout(), EventContent :: term()} | {'timeout', % Set the event_timeout option @@ -298,7 +298,7 @@ (Reason :: term()). %% Format the callback module state in some sensible that is -%% often condensed way. For StatusOption =:= 'normal' the perferred +%% often condensed way. For StatusOption =:= 'normal' the preferred %% return term is [{data,[{"State",FormattedState}]}], and for %% StatusOption =:= 'terminate' it is just FormattedState. -callback format_status( @@ -327,7 +327,8 @@ %% Type validation functions -compile( {inline, - [callback_mode/1, state_enter/1, from/1, event_type/1]}). + [callback_mode/1, state_enter/1, + event_type/1, from/1, timeout_event_type/1]}). %% callback_mode(CallbackMode) -> case CallbackMode of @@ -344,28 +345,31 @@ state_enter(StateEnter) -> false end. %% -from({Pid,_}) when is_pid(Pid) -> true; -from(_) -> false. -%% -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; - {timeout,_} -> true; - _ -> false + _ -> timeout_event_type(Type) + end. +%% +from({Pid,_}) when is_pid(Pid) -> true; +from(_) -> false. +%% +timeout_event_type(Type) -> + case Type of + timeout -> true; + state_timeout -> true; + {timeout,_Name} -> true; + _ -> false end. - -define( STACKTRACE(), - try throw(ok) catch _ -> erlang:get_stacktrace() end). + element(2, erlang:process_info(self(), current_stacktrace))). -define(not_sys_debug, []). %% @@ -517,8 +521,6 @@ call(ServerRef, Request, infinity = T = Timeout) -> call_dirty(ServerRef, Request, Timeout, T); call(ServerRef, Request, {dirty_timeout, T} = Timeout) -> call_dirty(ServerRef, Request, Timeout, T); -call(ServerRef, Request, {clean_timeout, infinity = T} = Timeout) -> - call_dirty(ServerRef, Request, Timeout, T); call(ServerRef, Request, {clean_timeout, T} = Timeout) -> call_clean(ServerRef, Request, Timeout, T); call(ServerRef, Request, {_, _} = Timeout) -> @@ -592,11 +594,11 @@ call_dirty(ServerRef, Request, Timeout, T) -> {ok,Reply} -> Reply catch - Class:Reason -> + Class:Reason:Stacktrace -> erlang:raise( Class, {Reason,{?MODULE,call,[ServerRef,Request,Timeout]}}, - erlang:get_stacktrace()) + Stacktrace) end. call_clean(ServerRef, Request, Timeout, T) -> @@ -610,9 +612,8 @@ call_clean(ServerRef, Request, Timeout, T) -> ServerRef, '$gen_call', Request, T) of Result -> {Ref,Result} - catch Class:Reason -> - {Ref,Class,Reason, - erlang:get_stacktrace()} + catch Class:Reason:Stacktrace -> + {Ref,Class,Reason,Stacktrace} end end), Mref = monitor(process, Pid), @@ -644,16 +645,11 @@ replies([]) -> %% Might actually not send the message in case of caught exception send(Proc, Msg) -> - try erlang:send(Proc, Msg, [noconnect]) of - noconnect -> - _ = spawn(erlang, send, [Proc,Msg]), - ok; - ok -> - ok + try erlang:send(Proc, Msg) catch - _:_ -> - ok - end. + error:_ -> ok + end, + ok. %% Here the init_it/6 and enter_loop/5,6,7 functions converge enter(Module, Opts, State, Data, Server, Actions, Parent) -> @@ -699,8 +695,7 @@ init_it(Starter, Parent, ServerRef, Module, Args, Opts) -> catch Result -> init_result(Starter, Parent, ServerRef, Module, Result, Opts); - Class:Reason -> - Stacktrace = erlang:get_stacktrace(), + Class:Reason:Stacktrace -> Name = gen:get_proc_name(ServerRef), gen:unregister_name(ServerRef), proc_lib:init_ack(Starter, {error,Reason}), @@ -1065,6 +1060,15 @@ loop_event_result( Parent, Debug, S, Events, Event, NextState, NewData, TransOpts, [], true); + {next_state,_NextState,_NewData} -> + terminate( + error, + {bad_state_enter_return_from_state_function,Result}, + ?STACKTRACE(), Debug, + S#state{ + state = State, data = Data, + hibernate = hibernate_in_trans_opts(TransOpts)}, + [Event|Events]); {next_state,State,NewData,Actions} -> loop_event_actions( Parent, Debug, S, @@ -1076,6 +1080,15 @@ loop_event_result( Parent, Debug, S, Events, Event, NextState, NewData, TransOpts, Actions, true); + {next_state,_NextState,_NewData,_Actions} -> + terminate( + error, + {bad_state_enter_return_from_state_function,Result}, + ?STACKTRACE(), Debug, + S#state{ + state = State, data = Data, + hibernate = hibernate_in_trans_opts(TransOpts)}, + [Event|Events]); %% {keep_state,NewData} -> loop_event_actions( @@ -1169,12 +1182,6 @@ loop_event_result( [Event|Events]) end. --compile({inline, [hibernate_in_trans_opts/1]}). -hibernate_in_trans_opts(false) -> - (#trans_opts{})#trans_opts.hibernate; -hibernate_in_trans_opts(#trans_opts{hibernate = Hibernate}) -> - Hibernate. - %% Ensure that Actions are a list loop_event_actions( Parent, Debug, S, @@ -1207,10 +1214,16 @@ loop_event_actions_list( S#state{ state = NextState, data = NewerData, - hibernate = TransOpts#trans_opts.hibernate}, + hibernate = hibernate_in_trans_opts(TransOpts)}, [Event|Events]) end. +-compile({inline, [hibernate_in_trans_opts/1]}). +hibernate_in_trans_opts(false) -> + (#trans_opts{})#trans_opts.hibernate; +hibernate_in_trans_opts(#trans_opts{hibernate = Hibernate}) -> + Hibernate. + parse_actions(false, Debug, S, Actions) -> parse_actions(true, Debug, S, Actions, #trans_opts{}); parse_actions(TransOpts, Debug, S, Actions) -> @@ -1243,6 +1256,11 @@ parse_actions(StateCall, Debug, S, [Action|Actions], TransOpts) -> parse_actions( StateCall, Debug, S, Actions, TransOpts#trans_opts{postpone = true}); + postpone -> + [error, + {bad_state_enter_action_from_state_function,Action}, + ?STACKTRACE(), + Debug]; %% {next_event,Type,Content} -> parse_actions_next_event( @@ -1295,7 +1313,8 @@ parse_actions_next_event( next_events_r = [{Type,Content}|NextEventsR]}); _ -> [error, - {bad_action_from_state_function,{next_event,Type,Content}}, + {bad_state_enter_action_from_state_function, + {next_event,Type,Content}}, ?STACKTRACE(), ?not_sys_debug] end; @@ -1312,22 +1331,23 @@ parse_actions_next_event( next_events_r = [{Type,Content}|NextEventsR]}); _ -> [error, - {bad_action_from_state_function,{next_event,Type,Content}}, + {bad_state_enter_action_from_state_function, + {next_event,Type,Content}}, ?STACKTRACE(), Debug] end. parse_actions_timeout( StateCall, Debug, S, Actions, TransOpts, - {TimerType,Time,TimerMsg,TimerOpts} = AbsoluteTimeout) -> + {TimeoutType,Time,TimerMsg,TimerOpts} = AbsoluteTimeout) -> %% - case classify_timer(Time, listify(TimerOpts)) of + case classify_timeout(TimeoutType, Time, listify(TimerOpts)) of absolute -> parse_actions_timeout_add( StateCall, Debug, S, Actions, TransOpts, AbsoluteTimeout); relative -> - RelativeTimeout = {TimerType,Time,TimerMsg}, + RelativeTimeout = {TimeoutType,Time,TimerMsg}, parse_actions_timeout_add( StateCall, Debug, S, Actions, TransOpts, RelativeTimeout); @@ -1339,8 +1359,8 @@ parse_actions_timeout( end; parse_actions_timeout( StateCall, Debug, S, Actions, TransOpts, - {_,Time,_} = RelativeTimeout) -> - case classify_timer(Time, []) of + {TimeoutType,Time,_} = RelativeTimeout) -> + case classify_timeout(TimeoutType, Time, []) of relative -> parse_actions_timeout_add( StateCall, Debug, S, Actions, @@ -1353,14 +1373,16 @@ parse_actions_timeout( end; parse_actions_timeout( StateCall, Debug, S, Actions, TransOpts, - Timeout) -> - case classify_timer(Timeout, []) of + Time) -> + case classify_timeout(timeout, Time, []) of relative -> + RelativeTimeout = {timeout,Time,Time}, parse_actions_timeout_add( - StateCall, Debug, S, Actions, TransOpts, Timeout); + StateCall, Debug, S, Actions, + TransOpts, RelativeTimeout); badarg -> [error, - {bad_action_from_state_function,Timeout}, + {bad_action_from_state_function,Time}, ?STACKTRACE(), Debug] end. @@ -1586,8 +1608,8 @@ call_callback_mode(#state{module = Module} = S) -> catch CallbackMode -> callback_mode_result(S, CallbackMode); - Class:Reason -> - [Class,Reason,erlang:get_stacktrace()] + Class:Reason:Stacktrace -> + [Class,Reason,Stacktrace] end. callback_mode_result(S, CallbackMode) -> @@ -1640,16 +1662,21 @@ call_state_function( catch Result -> {Result,S}; - Class:Reason -> - [Class,Reason,erlang:get_stacktrace()] + Class:Reason:Stacktrace -> + [Class,Reason,Stacktrace] end. %% -> absolute | relative | badarg -classify_timer(Time, Opts) -> - classify_timer(Time, Opts, false). -%% -classify_timer(Time, [], Abs) -> +classify_timeout(TimeoutType, Time, Opts) -> + case timeout_event_type(TimeoutType) of + true -> + classify_time(false, Time, Opts); + false -> + badarg + end. + +classify_time(Abs, Time, []) -> case Abs of true when is_integer(Time); @@ -1662,9 +1689,9 @@ classify_timer(Time, [], Abs) -> _ -> badarg end; -classify_timer(Time, [{abs,Abs}|Opts], _) when is_boolean(Abs) -> - classify_timer(Time, Opts, Abs); -classify_timer(_, Opts, _) when is_list(Opts) -> +classify_time(_, Time, [{abs,Abs}|Opts]) when is_boolean(Abs) -> + classify_time(Abs, Time, Opts); +classify_time(_, _, Opts) when is_list(Opts) -> badarg. %% Stop and start timers as well as create timeout zero events @@ -1695,15 +1722,7 @@ parse_timers( {TimerType,Time,TimerMsg} -> parse_timers( TimerRefs, Timers, TimeoutsR, Seen, TimeoutEvents, - TimerType, Time, TimerMsg, []); - 0 -> - parse_timers( - TimerRefs, Timers, TimeoutsR, Seen, TimeoutEvents, - timeout, zero, 0, []); - Time -> - parse_timers( - TimerRefs, Timers, TimeoutsR, Seen, TimeoutEvents, - timeout, Time, Time, []) + TimerType, Time, TimerMsg, []) end. parse_timers( @@ -1829,8 +1848,7 @@ terminate( _ -> ok catch _ -> ok; - C:R -> - ST = erlang:get_stacktrace(), + C:R:ST -> error_info( C, R, ST, S, Q, format_status(terminate, get(), S)), diff --git a/lib/stdlib/src/io_lib.erl b/lib/stdlib/src/io_lib.erl index 50bf959db5..3a5aba60b4 100644 --- a/lib/stdlib/src/io_lib.erl +++ b/lib/stdlib/src/io_lib.erl @@ -60,11 +60,12 @@ -module(io_lib). --export([fwrite/2,fread/2,fread/3,format/2]). --export([scan_format/2,unscan_format/1,build_text/1]). +-export([fwrite/2,fwrite/3,fread/2,fread/3,format/2,format/3]). +-export([scan_format/2,unscan_format/1,build_text/1,build_text/2]). -export([print/1,print/4,indentation/2]). -export([write/1,write/2,write/3,nl/0,format_prompt/1,format_prompt/2]). +-export([write_binary/3]). -export([write_atom/1,write_string/1,write_string/2,write_latin1_string/1, write_latin1_string/2, write_char/1, write_latin1_char/1]). @@ -87,7 +88,7 @@ -export([limit_term/2]). -export_type([chars/0, latin1_string/0, continuation/0, - fread_error/0, fread_item/0, format_spec/0]). + fread_error/0, fread_item/0, format_spec/0, chars_limit/0]). %%---------------------------------------------------------------------- @@ -135,6 +136,18 @@ fwrite(Format, Args) -> format(Format, Args). +-type chars_limit() :: integer(). + +-spec fwrite(Format, Data, Options) -> chars() when + Format :: io:format(), + Data :: [term()], + Options :: [Option], + Option :: {'chars_limit', CharsLimit}, + CharsLimit :: chars_limit(). + +fwrite(Format, Args, Options) -> + format(Format, Args, Options). + -spec fread(Format, String) -> Result when Format :: string(), String :: string(), @@ -172,6 +185,21 @@ format(Format, Args) -> Other end. +-spec format(Format, Data, Options) -> chars() when + Format :: io:format(), + Data :: [term()], + Options :: [Option], + Option :: {'chars_limit', CharsLimit}, + CharsLimit :: chars_limit(). + +format(Format, Args, Options) -> + case catch io_lib_format:fwrite(Format, Args, Options) of + {'EXIT',_} -> + erlang:error(badarg, [Format, Args, Options]); + Other -> + Other + end. + -spec scan_format(Format, Data) -> FormatList when Format :: io:format(), Data :: [term()], @@ -197,6 +225,15 @@ unscan_format(FormatList) -> build_text(FormatList) -> io_lib_format:build(FormatList). +-spec build_text(FormatList, Options) -> chars() when + FormatList :: [char() | format_spec()], + Options :: [Option], + Option :: {'chars_limit', CharsLimit}, + CharsLimit :: chars_limit(). + +build_text(FormatList, Options) -> + io_lib_format:build(FormatList, Options). + -spec print(Term) -> chars() when Term :: term(). @@ -240,7 +277,7 @@ format_prompt(Prompt, Encoding) -> do_format_prompt(add_modifier(Encoding, "p"), [Prompt]). do_format_prompt(Format, Args) -> - case catch io_lib:format(Format, Args) of + case catch format(Format, Args) of {'EXIT',_} -> "???"; List -> List end. @@ -259,7 +296,8 @@ add_modifier(_, C) -> -spec write(Term) -> chars() when Term :: term(). -write(Term) -> write(Term, -1). +write(Term) -> + write1(Term, -1, latin1). -spec write(term(), depth(), boolean()) -> chars(). @@ -274,16 +312,29 @@ write(Term, D, false) -> (Term, Options) -> chars() when Term :: term(), Options :: [Option], - Option :: {'depth', Depth} + Option :: {'chars_limit', CharsLimit} + | {'depth', Depth} | {'encoding', 'latin1' | 'utf8' | 'unicode'}, + CharsLimit :: chars_limit(), Depth :: depth(). write(Term, Options) when is_list(Options) -> Depth = get_option(depth, Options, -1), Encoding = get_option(encoding, Options, epp:default_encoding()), - write1(Term, Depth, Encoding); + CharsLimit = get_option(chars_limit, Options, -1), + if + Depth =:= 0; CharsLimit =:= 0 -> + "..."; + CharsLimit < 0 -> + write1(Term, Depth, Encoding); + CharsLimit > 0 -> + RecDefFun = fun(_, _) -> no end, + If = io_lib_pretty:intermediate + (Term, Depth, CharsLimit, RecDefFun, Encoding, _Str=false), + io_lib_pretty:write(If) + end; write(Term, Depth) -> - write1(Term, Depth, latin1). + write(Term, [{depth, Depth}, {encoding, latin1}]). write1(_Term, 0, _E) -> "..."; write1(Term, _D, _E) when is_integer(Term) -> integer_to_list(Term); @@ -300,7 +351,7 @@ write1([H|T], D, E) -> if D =:= 1 -> "[...]"; true -> - [$[,[write1(H, D-1, E)|write_tail(T, D-1, E, $|)],$]] + [$[,[write1(H, D-1, E)|write_tail(T, D-1, E)],$]] end; write1(F, _D, _E) when is_function(F) -> erlang:fun_to_list(F); @@ -311,20 +362,24 @@ write1(T, D, E) when is_tuple(T) -> D =:= 1 -> "{...}"; true -> [${, - [write1(element(1, T), D-1, E)| - write_tail(tl(tuple_to_list(T)), D-1, E, $,)], + [write1(element(1, T), D-1, E)|write_tuple(T, 2, D-1, E)], $}] end. -%% write_tail(List, Depth, CharacterBeforeDots) +%% write_tail(List, Depth, Encoding) %% Test the terminating case first as this looks better with depth. -write_tail([], _D, _E, _S) -> ""; -write_tail(_, 1, _E, S) -> [S | "..."]; -write_tail([H|T], D, E, S) -> - [$,,write1(H, D-1, E)|write_tail(T, D-1, E, S)]; -write_tail(Other, D, E, S) -> - [S,write1(Other, D-1, E)]. +write_tail([], _D, _E) -> ""; +write_tail(_, 1, _E) -> [$| | "..."]; +write_tail([H|T], D, E) -> + [$,,write1(H, D-1, E)|write_tail(T, D-1, E)]; +write_tail(Other, D, E) -> + [$|,write1(Other, D-1, E)]. + +write_tuple(T, I, _D, _E) when I > tuple_size(T) -> ""; +write_tuple(_, _I, 1, _E) -> [$, | "..."]; +write_tuple(T, I, D, E) -> + [$,,write1(element(I, T), D-1, E)|write_tuple(T, I+1, D-1, E)]. write_port(Port) -> erlang:port_to_list(Port). @@ -333,32 +388,43 @@ write_ref(Ref) -> erlang:ref_to_list(Ref). write_map(Map, D, E) when is_integer(D) -> - [$#,${,write_map_body(maps:to_list(Map), D, E),$}]. + [$#,${,write_map_body(maps:to_list(Map), D, D - 1, E),$}]. -write_map_body(_, 0, _E) -> "..."; -write_map_body([], _, _E) -> []; -write_map_body([{K,V}], D, E) -> write_map_assoc(K, V, D, E); -write_map_body([{K,V}|KVs], D, E) -> - [write_map_assoc(K, V, D, E),$, | write_map_body(KVs, D-1, E)]. +write_map_body(_, 1, _D0, _E) -> "..."; +write_map_body([], _, _D0, _E) -> []; +write_map_body([{K,V}], _D, D0, E) -> write_map_assoc(K, V, D0, E); +write_map_body([{K,V}|KVs], D, D0, E) -> + [write_map_assoc(K, V, D0, E),$, | write_map_body(KVs, D - 1, D0, E)]. write_map_assoc(K, V, D, E) -> - [write1(K, D - 1, E),"=>",write1(V, D-1, E)]. + [write1(K, D, E)," => ",write1(V, D, E)]. write_binary(B, D) when is_integer(D) -> - [$<,$<,write_binary_body(B, D),$>,$>]. - -write_binary_body(<<>>, _D) -> - ""; -write_binary_body(_B, 1) -> - "..."; -write_binary_body(<<X:8>>, _D) -> - [integer_to_list(X)]; -write_binary_body(<<X:8,Rest/bitstring>>, D) -> - [integer_to_list(X),$,|write_binary_body(Rest, D-1)]; -write_binary_body(B, _D) -> + {S, _} = write_binary(B, D, -1), + S. + +write_binary(B, D, T) -> + {S, Rest} = write_binary_body(B, D, tsub(T, 4), []), + {[$<,$<,lists:reverse(S),$>,$>], Rest}. + +write_binary_body(<<>> = B, _D, _T, Acc) -> + {Acc, B}; +write_binary_body(B, D, T, Acc) when D =:= 1; T =:= 0-> + {["..."|Acc], B}; +write_binary_body(<<X:8>>, _D, _T, Acc) -> + {[integer_to_list(X)|Acc], <<>>}; +write_binary_body(<<X:8,Rest/bitstring>>, D, T, Acc) -> + S = integer_to_list(X), + write_binary_body(Rest, D-1, tsub(T, length(S) + 1), [$,,S|Acc]); +write_binary_body(B, _D, _T, Acc) -> L = bit_size(B), <<X:L>> = B, - [integer_to_list(X),$:,integer_to_list(L)]. + {[integer_to_list(L),$:,integer_to_list(X)|Acc], <<>>}. + +%% Make sure T does not change sign. +tsub(T, _) when T < 0 -> T; +tsub(T, E) when T >= E -> T - E; +tsub(_, _) -> 0. get_option(Key, TupleList, Default) -> case lists:keyfind(Key, 1, TupleList) of @@ -931,7 +997,7 @@ limit_term(Term, Depth) -> limit(_, 0) -> '...'; limit([H|T]=L, D) -> if - D =:= 1 -> '...'; + D =:= 1 -> ['...']; true -> case printable_list(L) of true -> L; @@ -944,10 +1010,10 @@ limit(Term, D) when is_map(Term) -> limit({}=T, _D) -> T; limit(T, D) when is_tuple(T) -> if - D =:= 1 -> '...'; + D =:= 1 -> {'...'}; true -> list_to_tuple([limit(element(1, T), D-1)| - limit_tail(tl(tuple_to_list(T)), D-1)]) + limit_tuple(T, 2, D-1)]) end; limit(<<_/bitstring>>=Term, D) -> limit_bitstring(Term, D); limit(Term, _D) -> Term. @@ -959,23 +1025,36 @@ limit_tail([H|T], D) -> limit_tail(Other, D) -> limit(Other, D-1). +limit_tuple(T, I, _D) when I > tuple_size(T) -> []; +limit_tuple(_, _I, 1) -> ['...']; +limit_tuple(T, I, D) -> + [limit(element(I, T), D-1)|limit_tuple(T, I+1, D-1)]. + %% Cannot limit maps properly since there is no guarantee that %% maps:from_list() creates a map with the same internal ordering of -%% the selected associations as in Map. +%% the selected associations as in Map. Instead of subtracting one +%% from the depth as the map associations are traversed (as is done +%% for tuples and lists), the same depth is applied to each and every +%% (returned) association. limit_map(Map, D) -> - maps:from_list(erts_internal:maps_to_list(Map, D)). -%% maps:from_list(limit_map_body(erts_internal:maps_to_list(Map, D), D)). - -%% limit_map_body(_, 0) -> [{'...', '...'}]; -%% limit_map_body([], _) -> []; -%% limit_map_body([{K,V}], D) -> [limit_map_assoc(K, V, D)]; -%% limit_map_body([{K,V}|KVs], D) -> -%% [limit_map_assoc(K, V, D) | limit_map_body(KVs, D-1)]. + %% Keep one extra association to make sure the final ',...' is included. + limit_map_body(maps:iterator(Map), D + 1, D, []). + +limit_map_body(_I, 0, _D0, Acc) -> + maps:from_list(Acc); +limit_map_body(I, D, D0, Acc) -> + case maps:next(I) of + {K, V, NextI} -> + limit_map_body(NextI, D-1, D0, [limit_map_assoc(K, V, D0) | Acc]); + none -> + maps:from_list(Acc) + end. -%% limit_map_assoc(K, V, D) -> -%% {limit(K, D-1), limit(V, D-1)}. +limit_map_assoc(K, V, D) -> + %% Keep keys as are to avoid creating duplicated keys. + {K, limit(V, D - 1)}. -limit_bitstring(B, _D) -> B. %% Keeps all printable binaries. +limit_bitstring(B, _D) -> B. % Keeps all printable binaries. test_limit(_, 0) -> throw(limit); test_limit([H|T]=L, D) when is_integer(D) -> @@ -1011,18 +1090,21 @@ test_limit_tuple(T, I, Sz, D) -> test_limit(element(I, T), D-1), test_limit_tuple(T, I+1, Sz, D-1). -test_limit_map(_Map, _D) -> ok. -%% test_limit_map_body(erts_internal:maps_to_list(Map, D), D). - -%% test_limit_map_body(_, 0) -> throw(limit); -%% test_limit_map_body([], _) -> ok; -%% test_limit_map_body([{K,V}], D) -> test_limit_map_assoc(K, V, D); -%% test_limit_map_body([{K,V}|KVs], D) -> -%% test_limit_map_assoc(K, V, D), -%% test_limit_map_body(KVs, D-1). +test_limit_map(Map, D) -> + test_limit_map_body(maps:iterator(Map), D). + +test_limit_map_body(_I, 0) -> throw(limit); % cannot happen +test_limit_map_body(I, D) -> + case maps:next(I) of + {K, V, NextI} -> + test_limit_map_assoc(K, V, D), + test_limit_map_body(NextI, D-1); + none -> + ok + end. -%% test_limit_map_assoc(K, V, D) -> -%% test_limit(K, D-1), -%% test_limit(V, D-1). +test_limit_map_assoc(K, V, D) -> + test_limit(K, D - 1), + test_limit(V, D - 1). test_limit_bitstring(_, _) -> ok. diff --git a/lib/stdlib/src/io_lib_format.erl b/lib/stdlib/src/io_lib_format.erl index 4b2d15c8b3..c814ab50d4 100644 --- a/lib/stdlib/src/io_lib_format.erl +++ b/lib/stdlib/src/io_lib_format.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2017. All Rights Reserved. +%% Copyright Ericsson AB 1996-2018. 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 @@ %% Formatting functions of io library. --export([fwrite/2,fwrite_g/1,indentation/2,scan/2,unscan/1,build/1]). +-export([fwrite/2,fwrite/3,fwrite_g/1,indentation/2,scan/2,unscan/1, + build/1, build/2]). %% Format the arguments in Args after string Format. Just generate %% an error if there is an error in the arguments. @@ -45,14 +46,42 @@ fwrite(Format, Args) -> build(scan(Format, Args)). +-spec fwrite(Format, Data, Options) -> FormatList when + Format :: io:format(), + Data :: [term()], + FormatList :: [char() | io_lib:format_spec()], + Options :: [Option], + Option :: {'chars_limit', CharsLimit}, + CharsLimit :: io_lib:chars_limit(). + +fwrite(Format, Args, Options) -> + build(scan(Format, Args), Options). + %% Build the output text for a pre-parsed format list. -spec build(FormatList) -> io_lib:chars() when FormatList :: [char() | io_lib:format_spec()]. build(Cs) -> - Pc = pcount(Cs), - build(Cs, Pc, 0). + build(Cs, []). + +-spec build(FormatList, Options) -> io_lib:chars() when + FormatList :: [char() | io_lib:format_spec()], + Options :: [Option], + Option :: {'chars_limit', CharsLimit}, + CharsLimit :: io_lib:chars_limit(). + +build(Cs, Options) -> + CharsLimit = get_option(chars_limit, Options, -1), + Res1 = build_small(Cs), + {P, S, W, Other} = count_small(Res1), + case P + S + W of + 0 -> + Res1; + NumOfLimited -> + RemainingChars = sub(CharsLimit, Other), + build_limited(Res1, P, NumOfLimited, RemainingChars, 0) + end. %% Parse all control sequences in the format string. @@ -95,7 +124,7 @@ print([]) -> []. print(C, F, Ad, P, Pad, Encoding, Strings) -> - [$~] ++ print_field_width(F, Ad) ++ print_precision(P) ++ + [$~] ++ print_field_width(F, Ad) ++ print_precision(P, Pad) ++ print_pad_char(Pad) ++ print_encoding(Encoding) ++ print_strings(Strings) ++ [C]. @@ -103,8 +132,9 @@ print_field_width(none, _Ad) -> ""; print_field_width(F, left) -> integer_to_list(-F); print_field_width(F, right) -> integer_to_list(F). -print_precision(none) -> ""; -print_precision(P) -> [$. | integer_to_list(P)]. +print_precision(none, $\s) -> ""; +print_precision(none, _Pad) -> "."; % pad must be second dot +print_precision(P, _Pad) -> [$. | integer_to_list(P)]. print_pad_char($\s) -> ""; % default, no need to make explicit print_pad_char(Pad) -> [$., Pad]. @@ -126,25 +156,23 @@ collect_cseq(Fmt0, Args0) -> {F,Ad,Fmt1,Args1} = field_width(Fmt0, Args0), {P,Fmt2,Args2} = precision(Fmt1, Args1), {Pad,Fmt3,Args3} = pad_char(Fmt2, Args2), - {Encoding,Fmt4,Args4} = encoding(Fmt3, Args3), - {Strings,Fmt5,Args5} = strings(Fmt4, Args4), - {C,As,Fmt6,Args6} = collect_cc(Fmt5, Args5), - FormatSpec = #{control_char => C, args => As, width => F, adjust => Ad, - precision => P, pad_char => Pad, encoding => Encoding, - strings => Strings}, - {FormatSpec,Fmt6,Args6}. - -encoding([$t|Fmt],Args) -> - true = hd(Fmt) =/= $l, - {unicode,Fmt,Args}; -encoding(Fmt,Args) -> - {latin1,Fmt,Args}. - -strings([$l|Fmt],Args) -> - true = hd(Fmt) =/= $t, - {false,Fmt,Args}; -strings(Fmt,Args) -> - {true,Fmt,Args}. + Spec0 = #{width => F, + adjust => Ad, + precision => P, + pad_char => Pad, + encoding => latin1, + strings => true}, + {Spec1,Fmt4} = modifiers(Fmt3, Spec0), + {C,As,Fmt5,Args4} = collect_cc(Fmt4, Args3), + Spec2 = Spec1#{control_char => C, args => As}, + {Spec2,Fmt5,Args4}. + +modifiers([$t|Fmt], Spec) -> + modifiers(Fmt, Spec#{encoding => unicode}); +modifiers([$l|Fmt], Spec) -> + modifiers(Fmt, Spec#{strings => false}); +modifiers(Fmt, Spec) -> + {Spec, Fmt}. field_width([$-|Fmt0], Args0) -> {F,Fmt,Args} = field_value(Fmt0, Args0), @@ -203,40 +231,77 @@ collect_cc([$~|Fmt], Args) when is_list(Args) -> {$~,[],Fmt,Args}; collect_cc([$n|Fmt], Args) when is_list(Args) -> {$n,[],Fmt,Args}; collect_cc([$i|Fmt], [A|Args]) -> {$i,[A],Fmt,Args}. -%% pcount([ControlC]) -> Count. -%% Count the number of print requests. - -pcount(Cs) -> pcount(Cs, 0). - -pcount([#{control_char := $p}|Cs], Acc) -> pcount(Cs, Acc+1); -pcount([#{control_char := $P}|Cs], Acc) -> pcount(Cs, Acc+1); -pcount([_|Cs], Acc) -> pcount(Cs, Acc); -pcount([], Acc) -> Acc. - -%% build([Control], Pc, Indentation) -> io_lib:chars(). +%% count_small([ControlC]) -> Count. +%% Count the number of big (pPwWsS) print requests and +%% number of characters of other print (small) requests. + +count_small(Cs) -> + count_small(Cs, #{p => 0, s => 0, w => 0, other => 0}). + +count_small([#{control_char := $p}|Cs], #{p := P} = Cnts) -> + count_small(Cs, Cnts#{p := P + 1}); +count_small([#{control_char := $P}|Cs], #{p := P} = Cnts) -> + count_small(Cs, Cnts#{p := P + 1}); +count_small([#{control_char := $w}|Cs], #{w := W} = Cnts) -> + count_small(Cs, Cnts#{w := W + 1}); +count_small([#{control_char := $W}|Cs], #{w := W} = Cnts) -> + count_small(Cs, Cnts#{w := W + 1}); +count_small([#{control_char := $s}|Cs], #{w := W} = Cnts) -> + count_small(Cs, Cnts#{w := W + 1}); +count_small([S|Cs], #{other := Other} = Cnts) when is_list(S) -> + count_small(Cs, Cnts#{other := Other + string:length(S)}); +count_small([C|Cs], #{other := Other} = Cnts) when is_integer(C) -> + count_small(Cs, Cnts#{other := Other + 1}); +count_small([], #{p := P, s := S, w := W, other := Other}) -> + {P, S, W, Other}. + +%% build_small([Control]) -> io_lib:chars(). +%% Interpret the control structures, but only the small ones. +%% The big ones are saved for later. +%% build_limited([Control], NumberOfPps, NumberOfLimited, +%% CharsLimit, Indentation) %% Interpret the control structures. Count the number of print %% remaining and only calculate indentation when necessary. Must also %% be smart when calculating indentation for characters in format. -build([#{control_char := C, args := As, width := F, adjust := Ad, - precision := P, pad_char := Pad, encoding := Enc, - strings := Str} | Cs], Pc0, I) -> - S = control(C, As, F, Ad, P, Pad, Enc, Str, I), - Pc1 = decr_pc(C, Pc0), +build_small([#{control_char := C, args := As, width := F, adjust := Ad, + precision := P, pad_char := Pad, encoding := Enc}=CC | Cs]) -> + case control_small(C, As, F, Ad, P, Pad, Enc) of + not_small -> [CC | build_small(Cs)]; + S -> lists:flatten(S) ++ build_small(Cs) + end; +build_small([C|Cs]) -> [C|build_small(Cs)]; +build_small([]) -> []. + +build_limited([#{control_char := C, args := As, width := F, adjust := Ad, + precision := P, pad_char := Pad, encoding := Enc, + strings := Str} | Cs], NumOfPs0, Count0, MaxLen0, I) -> + MaxChars = if + MaxLen0 < 0 -> MaxLen0; + true -> MaxLen0 div Count0 + end, + S = control_limited(C, As, F, Ad, P, Pad, Enc, Str, MaxChars, I), + Len = string:length(S), + NumOfPs = decr_pc(C, NumOfPs0), + Count = Count0 - 1, + MaxLen = sub(MaxLen0, Len), if - Pc1 > 0 -> [S|build(Cs, Pc1, indentation(S, I))]; - true -> [S|build(Cs, Pc1, I)] + NumOfPs > 0 -> [S|build_limited(Cs, NumOfPs, Count, + MaxLen, indentation(S, I))]; + true -> [S|build_limited(Cs, NumOfPs, Count, MaxLen, I)] end; -build([$\n|Cs], Pc, _I) -> [$\n|build(Cs, Pc, 0)]; -build([$\t|Cs], Pc, I) -> [$\t|build(Cs, Pc, ((I + 8) div 8) * 8)]; -build([C|Cs], Pc, I) -> [C|build(Cs, Pc, I+1)]; -build([], _Pc, _I) -> []. +build_limited([$\n|Cs], NumOfPs, Count, MaxLen, _I) -> + [$\n|build_limited(Cs, NumOfPs, Count, MaxLen, 0)]; +build_limited([$\t|Cs], NumOfPs, Count, MaxLen, I) -> + [$\t|build_limited(Cs, NumOfPs, Count, MaxLen, ((I + 8) div 8) * 8)]; +build_limited([C|Cs], NumOfPs, Count, MaxLen, I) -> + [C|build_limited(Cs, NumOfPs, Count, MaxLen, I+1)]; +build_limited([], _, _, _, _) -> []. decr_pc($p, Pc) -> Pc - 1; decr_pc($P, Pc) -> Pc - 1; decr_pc(_, Pc) -> Pc. - %% Calculate the indentation of the end of a string given its start %% indentation. We assume tabs at 8 cols. @@ -252,67 +317,74 @@ indentation([C|Cs], I) -> indentation(Cs, indentation(C, I)); indentation([], I) -> I. -%% control(FormatChar, [Argument], FieldWidth, Adjust, Precision, PadChar, -%% Encoding, Indentation) -> String -%% This is the main dispatch function for the various formatting commands. -%% Field widths and precisions have already been calculated. - -control($w, [A], F, Adj, P, Pad, Enc, _Str, _I) -> - term(io_lib:write(A, [{depth,-1}, {encoding, Enc}]), F, Adj, P, Pad); -control($p, [A], F, Adj, P, Pad, Enc, Str, I) -> - print(A, -1, F, Adj, P, Pad, Enc, Str, I); -control($W, [A,Depth], F, Adj, P, Pad, Enc, _Str, _I) when is_integer(Depth) -> - term(io_lib:write(A, [{depth,Depth}, {encoding, Enc}]), 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, latin1, _Str, _I) when is_atom(A) -> +%% control_small(FormatChar, [Argument], FieldWidth, Adjust, Precision, +%% PadChar, Encoding) -> String +%% control_limited(FormatChar, [Argument], FieldWidth, Adjust, Precision, +%% PadChar, Encoding, StringP, ChrsLim, Indentation) -> String +%% These are the dispatch functions for the various formatting controls. + +control_small($s, [A], F, Adj, P, Pad, latin1) 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) -> +control_small($s, [A], F, Adj, P, Pad, unicode) 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), - string(L, F, Adj, P, Pad); -control($s, [L0], F, Adj, P, Pad, unicode, _Str, _I) -> - L = cdata_to_chars(L0), - uniconv(string(L, F, Adj, P, Pad)); -control($e, [A], F, Adj, P, Pad, _Enc, _Str, _I) when is_float(A) -> +control_small($e, [A], F, Adj, P, Pad, _Enc) when is_float(A) -> fwrite_e(A, F, Adj, P, Pad); -control($f, [A], F, Adj, P, Pad, _Enc, _Str, _I) when is_float(A) -> +control_small($f, [A], F, Adj, P, Pad, _Enc) when is_float(A) -> fwrite_f(A, F, Adj, P, Pad); -control($g, [A], F, Adj, P, Pad, _Enc, _Str, _I) when is_float(A) -> +control_small($g, [A], F, Adj, P, Pad, _Enc) when is_float(A) -> fwrite_g(A, F, Adj, P, Pad); -control($b, [A], F, Adj, P, Pad, _Enc, _Str, _I) when is_integer(A) -> +control_small($b, [A], F, Adj, P, Pad, _Enc) when is_integer(A) -> unprefixed_integer(A, F, Adj, base(P), Pad, true); -control($B, [A], F, Adj, P, Pad, _Enc, _Str, _I) when is_integer(A) -> +control_small($B, [A], F, Adj, P, Pad, _Enc) when is_integer(A) -> unprefixed_integer(A, F, Adj, base(P), Pad, false); -control($x, [A,Prefix], F, Adj, P, Pad, _Enc, _Str, _I) when is_integer(A), - is_atom(Prefix) -> +control_small($x, [A,Prefix], F, Adj, P, Pad, _Enc) when is_integer(A), + is_atom(Prefix) -> prefixed_integer(A, F, Adj, base(P), Pad, atom_to_list(Prefix), true); -control($x, [A,Prefix], F, Adj, P, Pad, _Enc, _Str, _I) when is_integer(A) -> +control_small($x, [A,Prefix], F, Adj, P, Pad, _Enc) when is_integer(A) -> true = io_lib:deep_char_list(Prefix), %Check if Prefix a character list prefixed_integer(A, F, Adj, base(P), Pad, Prefix, true); -control($X, [A,Prefix], F, Adj, P, Pad, _Enc, _Str, _I) when is_integer(A), - is_atom(Prefix) -> +control_small($X, [A,Prefix], F, Adj, P, Pad, _Enc) when is_integer(A), + is_atom(Prefix) -> prefixed_integer(A, F, Adj, base(P), Pad, atom_to_list(Prefix), false); -control($X, [A,Prefix], F, Adj, P, Pad, _Enc, _Str, _I) when is_integer(A) -> +control_small($X, [A,Prefix], F, Adj, P, Pad, _Enc) when is_integer(A) -> true = io_lib:deep_char_list(Prefix), %Check if Prefix a character list prefixed_integer(A, F, Adj, base(P), Pad, Prefix, false); -control($+, [A], F, Adj, P, Pad, _Enc, _Str, _I) when is_integer(A) -> +control_small($+, [A], F, Adj, P, Pad, _Enc) when is_integer(A) -> Base = base(P), Prefix = [integer_to_list(Base), $#], prefixed_integer(A, F, Adj, Base, Pad, Prefix, true); -control($#, [A], F, Adj, P, Pad, _Enc, _Str, _I) when is_integer(A) -> +control_small($#, [A], F, Adj, P, Pad, _Enc) when is_integer(A) -> Base = base(P), Prefix = [integer_to_list(Base), $#], prefixed_integer(A, F, Adj, Base, Pad, Prefix, false); -control($c, [A], F, Adj, P, Pad, unicode, _Str, _I) when is_integer(A) -> +control_small($c, [A], F, Adj, P, Pad, unicode) when is_integer(A) -> char(A, F, Adj, P, Pad); -control($c, [A], F, Adj, P, Pad, _Enc, _Str, _I) when is_integer(A) -> +control_small($c, [A], F, Adj, P, Pad, _Enc) when is_integer(A) -> char(A band 255, F, Adj, P, Pad); -control($~, [], F, Adj, P, Pad, _Enc, _Str, _I) -> char($~, F, Adj, P, Pad); -control($n, [], F, Adj, P, Pad, _Enc, _Str, _I) -> newline(F, Adj, P, Pad); -control($i, [_A], _F, _Adj, _P, _Pad, _Enc, _Str, _I) -> []. +control_small($~, [], F, Adj, P, Pad, _Enc) -> char($~, F, Adj, P, Pad); +control_small($n, [], F, Adj, P, Pad, _Enc) -> newline(F, Adj, P, Pad); +control_small($i, [_A], _F, _Adj, _P, _Pad, _Enc) -> []; +control_small(_C, _As, _F, _Adj, _P, _Pad, _Enc) -> not_small. + +control_limited($s, [L0], F, Adj, P, Pad, latin1, _Str, CL, _I) -> + L = iolist_to_chars(L0), + string(limit_string(L, F, CL), limit_field(F, CL), Adj, P, Pad); +control_limited($s, [L0], F, Adj, P, Pad, unicode, _Str, CL, _I) -> + L = cdata_to_chars(L0), + uniconv(string(limit_string(L, F, CL), limit_field(F, CL), Adj, P, Pad)); +control_limited($w, [A], F, Adj, P, Pad, Enc, _Str, CL, _I) -> + Chars = io_lib:write(A, [{depth, -1}, {encoding, Enc}, {chars_limit, CL}]), + term(Chars, F, Adj, P, Pad); +control_limited($p, [A], F, Adj, P, Pad, Enc, Str, CL, I) -> + print(A, -1, F, Adj, P, Pad, Enc, Str, CL, I); +control_limited($W, [A,Depth], F, Adj, P, Pad, Enc, _Str, CL, _I) + when is_integer(Depth) -> + Chars = io_lib:write(A, [{depth, Depth}, {encoding, Enc}, {chars_limit, CL}]), + term(Chars, F, Adj, P, Pad); +control_limited($P, [A,Depth], F, Adj, P, Pad, Enc, Str, CL, I) + when is_integer(Depth) -> + print(A, Depth, F, Adj, P, Pad, Enc, Str, CL, I). -ifdef(UNICODE_AS_BINARIES). uniconv(C) -> @@ -349,12 +421,13 @@ term(T, F, Adj, P0, Pad) -> %% Print a term. Field width sets maximum line length, Precision sets %% initial indentation. -print(T, D, none, Adj, P, Pad, E, Str, I) -> - print(T, D, 80, Adj, P, Pad, E, Str, I); -print(T, D, F, Adj, none, Pad, E, Str, I) -> - print(T, D, F, Adj, I+1, Pad, E, Str, I); -print(T, D, F, right, P, _Pad, Enc, Str, _I) -> - Options = [{column, P}, +print(T, D, none, Adj, P, Pad, E, Str, ChLim, I) -> + print(T, D, 80, Adj, P, Pad, E, Str, ChLim, I); +print(T, D, F, Adj, none, Pad, E, Str, ChLim, I) -> + print(T, D, F, Adj, I+1, Pad, E, Str, ChLim, I); +print(T, D, F, right, P, _Pad, Enc, Str, ChLim, _I) -> + Options = [{chars_limit, ChLim}, + {column, P}, {line_length, F}, {depth, D}, {encoding, Enc}, @@ -380,7 +453,7 @@ float_e(_Fl, {Ds,E}, P) -> {Fs,false} -> [Fs|float_exp(E-1)] end. -%% float_man([Digit], Icount, Dcount) -> {[Chars],CarryFlag}. +%% float_man([Digit], Icount, Dcount) -> {[Char],CarryFlag}. %% Generate the characters in the mantissa from the digits with Icount %% characters before the '.' and Dcount decimals. Handle carry and let %% caller decide what to do at top. @@ -395,7 +468,7 @@ float_man([D|Ds], I, Dc) -> {Cs,false} -> {[D|Cs],false} end; float_man([], I, Dc) -> %Pad with 0's - {string:chars($0, I, [$.|string:chars($0, Dc)]),false}. + {lists:duplicate(I, $0) ++ [$.|lists:duplicate(Dc, $0)],false}. float_man([D|_], 0) when D >= $5 -> {[],true}; float_man([_|_], 0) -> {[],false}; @@ -405,7 +478,7 @@ float_man([D|Ds], Dc) -> {Cs,true} -> {[D+1|Cs],false}; {Cs,false} -> {[D|Cs],false} end; -float_man([], Dc) -> {string:chars($0, Dc),false}. %Pad with 0's +float_man([], Dc) -> {lists:duplicate(Dc, $0),false}. %Pad with 0's %% float_exp(Exponent) -> [Char]. %% Generate the exponent of a floating point number. Always include sign. @@ -429,7 +502,7 @@ fwrite_f(Fl, F, Adj, P, Pad) when P >= 1 -> float_f(Fl, Fd, P) when Fl < 0.0 -> [$-|float_f(-Fl, Fd, P)]; float_f(Fl, {Ds,E}, P) when E =< 0 -> - float_f(Fl, {string:chars($0, -E+1, Ds),1}, P); %Prepend enough 0's + float_f(Fl, {lists:duplicate(-E+1, $0)++Ds,1}, P); %Prepend enough 0's float_f(_Fl, {Ds,E}, P) -> case float_man(Ds, E, P) of {Fs,true} -> "1" ++ Fs; %Handle carry @@ -671,6 +744,18 @@ cdata_to_chars(B) when is_binary(B) -> _ -> binary_to_list(B) end. +limit_string(S, F, CharsLimit) when CharsLimit < 0; CharsLimit >= F -> S; +limit_string(S, _F, CharsLimit) -> + case string:length(S) =< CharsLimit of + true -> S; + false -> [string:slice(S, 0, sub(CharsLimit, 3)), "..."] + end. + +limit_field(F, CharsLimit) when CharsLimit < 0; F =:= none -> + F; +limit_field(F, CharsLimit) -> + max(3, min(F, CharsLimit)). + %% string(String, Field, Adjust, Precision, PadChar) string(S, none, _Adj, none, _Pad) -> S; @@ -751,7 +836,7 @@ adjust(Data, Pad, right) -> [Pad|Data]. flat_trunc(List, N) when is_integer(N), N >= 0 -> string:slice(List, 0, N). -%% A deep version of string:chars/2,3 +%% A deep version of lists:duplicate/2 chars(_C, 0) -> []; @@ -784,3 +869,15 @@ lowercase([H|T]) -> [H|lowercase(T)]; lowercase([]) -> []. + +%% Make sure T does change sign. +sub(T, _) when T < 0 -> T; +sub(T, E) when T >= E -> T - E; +sub(_, _) -> 0. + +get_option(Key, TupleList, Default) -> + case lists:keyfind(Key, 1, TupleList) of + false -> Default; + {Key, Value} -> Value; + _ -> Default + end. diff --git a/lib/stdlib/src/io_lib_pretty.erl b/lib/stdlib/src/io_lib_pretty.erl index 505613b80e..3d5a979b3e 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-2017. All Rights Reserved. +%% Copyright Ericsson AB 1996-2018. 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. @@ -26,6 +26,9 @@ -export([print/1,print/2,print/3,print/4,print/5,print/6]). +%% To be used by io_lib only. +-export([intermediate/6, write/1]). + %%% %%% Exported functions %%% @@ -45,20 +48,23 @@ print(Term) -> %% Used by the shell for printing records and for Unicode. -type rec_print_fun() :: fun((Tag :: atom(), NFields :: non_neg_integer()) -> - no | [FieldName :: atom()]). + 'no' | [FieldName :: atom()]). -type column() :: integer(). +-type encoding() :: epp:source_encoding() | 'unicode'. -type line_length() :: pos_integer(). -type depth() :: integer(). --type max_chars() :: integer(). +-type line_max_chars() :: integer(). +-type chars_limit() :: integer(). -type chars() :: io_lib:chars(). --type option() :: {column, column()} - | {line_length, line_length()} - | {depth, depth()} - | {max_chars, max_chars()} - | {record_print_fun, rec_print_fun()} - | {strings, boolean()} - | {encoding, latin1 | utf8 | unicode}. +-type option() :: {'chars_limit', chars_limit()} + | {'column', column()} + | {'depth', depth()} + | {'encoding', encoding()} + | {'line_length', line_length()} + | {'line_max_chars', line_max_chars()} + | {'record_print_fun', rec_print_fun()} + | {'strings', boolean()}. -type options() :: [option()]. -spec print(term(), rec_print_fun()) -> chars(); @@ -68,11 +74,12 @@ print(Term, Options) when is_list(Options) -> Col = get_option(column, Options, 1), Ll = get_option(line_length, Options, 80), D = get_option(depth, Options, -1), - M = get_option(max_chars, Options, -1), + M = get_option(line_max_chars, Options, -1), + T = get_option(chars_limit, Options, -1), RecDefFun = get_option(record_print_fun, Options, no_fun), Encoding = get_option(encoding, Options, epp:default_encoding()), Strings = get_option(strings, Options, true), - print(Term, Col, Ll, D, M, RecDefFun, Encoding, Strings); + print(Term, Col, Ll, D, M, T, RecDefFun, Encoding, Strings); print(Term, RecDefFun) -> print(Term, -1, RecDefFun). @@ -84,35 +91,43 @@ print(Term, Depth, RecDefFun) -> -spec print(term(), column(), line_length(), depth()) -> chars(). print(Term, Col, Ll, D) -> - print(Term, Col, Ll, D, _M=-1, no_fun, latin1, true). + print(Term, Col, Ll, D, _M=-1, _T=-1, no_fun, latin1, true). -spec print(term(), column(), line_length(), depth(), rec_print_fun()) -> chars(). print(Term, Col, Ll, D, RecDefFun) -> print(Term, Col, Ll, D, _M=-1, RecDefFun). --spec print(term(), column(), line_length(), depth(), max_chars(), +-spec print(term(), column(), line_length(), depth(), line_max_chars(), rec_print_fun()) -> chars(). print(Term, Col, Ll, D, M, RecDefFun) -> - print(Term, Col, Ll, D, M, RecDefFun, latin1, true). + print(Term, Col, Ll, D, M, _T=-1, RecDefFun, latin1, true). %% D = Depth, default -1 (infinite), or LINEMAX=30 when printing from shell +%% T = chars_limit, that is, maximal number of characters, default -1 +%% Used together with D to limit the output. It is possible that +%% more than T characters are returned. %% Col = current column, default 1 %% Ll = line length/~p field width, default 80 %% M = CHAR_MAX (-1 if no max, 60 when printing from shell) -print(_, _, _, 0, _M, _RF, _Enc, _Str) -> "..."; -print(Term, Col, Ll, D, M, RecDefFun, Enc, Str) when Col =< 0 -> +print(_, _, _, 0, _M, _T, _RF, _Enc, _Str) -> "..."; +print(_, _, _, _D, _M, 0, _RF, _Enc, _Str) -> "..."; +print(Term, Col, Ll, D, M, T, RecDefFun, Enc, Str) when Col =< 0 -> %% ensure Col is at least 1 - print(Term, 1, Ll, D, M, RecDefFun, Enc, Str); -print(Atom, _Col, _Ll, _D, _M, _RF, Enc, _Str) when is_atom(Atom) -> + print(Term, 1, Ll, D, M, T, RecDefFun, Enc, Str); +print(Atom, _Col, _Ll, _D, _M, _T, _RF, Enc, _Str) when is_atom(Atom) -> write_atom(Atom, Enc); -print(Term, Col, Ll, D, M0, RecDefFun, Enc, Str) when is_tuple(Term); - is_list(Term); - is_map(Term); - is_bitstring(Term) -> +print(Term, Col, Ll, D, M0, T, RecDefFun, Enc, Str) when is_tuple(Term); + is_list(Term); + is_map(Term); + is_bitstring(Term) -> %% preprocess and compute total number of chars - If = {_S, Len} = print_length(Term, D, RecDefFun, Enc, Str), + {_, Len, _Dots, _} = If = + case T < 0 of + true -> print_length(Term, D, T, RecDefFun, Enc, Str); + false -> intermediate(Term, D, T, RecDefFun, Enc, Str) + end, %% use Len as CHAR_MAX if M0 = -1 M = max_cs(M0, Len), if @@ -126,7 +141,7 @@ print(Term, Col, Ll, D, M0, RecDefFun, Enc, Str) when is_tuple(Term); 1), pp(If, Col, Ll, M, TInd, indent(Col), 0, 0) end; -print(Term, _Col, _Ll, _D, _M, _RF, _Enc, _Str) -> +print(Term, _Col, _Ll, _D, _M, _T, _RF, _Enc, _Str) -> %% atomic data types (bignums, atoms, ...) are never truncated io_lib:write(Term). @@ -147,28 +162,28 @@ max_cs(M, _Len) -> ?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) +pp({_S,Len,_,_} = If, Col, Ll, M, _TInd, _Ind, LD, W) when Len < Ll - Col - LD, Len + W + LD =< M -> write(If); -pp({{list,L}, _Len}, Col, Ll, M, TInd, Ind, LD, W) -> +pp({{list,L}, _Len, _, _}, Col, Ll, M, TInd, Ind, LD, W) -> [$[, pp_list(L, Col + 1, Ll, M, TInd, indent(1, Ind), LD, $|, W + 1), $]]; -pp({{tuple,true,L}, _Len}, Col, Ll, M, TInd, Ind, LD, W) -> +pp({{tuple,true,L}, _Len, _, _}, Col, Ll, M, TInd, Ind, LD, W) -> [${, pp_tag_tuple(L, Col, Ll, M, TInd, Ind, LD, W + 1), $}]; -pp({{tuple,false,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({{map,Pairs}, _Len, _, _}, 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) -> +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) -> +pp({{bin,S}, _Len, _, _}, Col, Ll, M, _TInd, Ind, LD, W) -> pp_binary(S, Col + 2, Ll, M, indent(2, Ind), LD, W); -pp({S, _Len}, _Col, _Ll, _M, _TInd, _Ind, _LD, _W) -> +pp({S,_Len,_,_}, _Col, _Ll, _M, _TInd, _Ind, _LD, _W) -> S. %% Print a tagged tuple by indenting the rest of the elements %% differently to the tag. Tuple has size >= 2. -pp_tag_tuple([{Tag,Tlen} | L], Col, Ll, M, TInd, Ind, LD, W) -> +pp_tag_tuple([{Tag,Tlen,_,_} | L], Col, Ll, M, TInd, Ind, LD, W) -> %% this uses TInd TagInd = Tlen + 2, Tcol = Col + TagInd, @@ -184,18 +199,18 @@ pp_tag_tuple([{Tag,Tlen} | L], Col, Ll, M, TInd, Ind, LD, W) -> end. pp_map([], _Col, _Ll, _M, _TInd, _Ind, _LD, _W) -> - ""; -pp_map({dots, _}, _Col, _Ll, _M, _TInd, _Ind, _LD, _W) -> - "..."; + ""; % cannot happen +pp_map({dots, _, _, _}, _Col, _Ll, _M, _TInd, _Ind, _LD, _W) -> + "..."; % cannot happen 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({dots, _, _, _}, _Col0, _Col, _M, _Ll, _TInd, _Ind, _LD, _W) -> ",..."; -pp_pairs_tail([{_, Len}=P | Ps], Col0, Col, Ll, M, 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 @@ -209,7 +224,7 @@ pp_pairs_tail([{_, Len}=P | Ps], Col0, Col, Ll, M, TInd, Ind, LD, W) -> 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) +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) -> @@ -217,7 +232,7 @@ pp_pair({_, Len}=Pair, Col, Ll, M, _TInd, _Ind, LD, W) true -> Ll % force nl end}; -pp_pair({{map_pair, K, V}, _Len}, Col0, Ll, M, TInd, Ind0, LD, W) -> +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", @@ -225,7 +240,7 @@ pp_pair({{map_pair, K, V}, _Len}, Col0, Ll, M, TInd, Ind0, LD, W) -> pp_record([], _Nlen, _Col, _Ll, _M, _TInd, _Ind, _LD, _W) -> ""; -pp_record({dots, _}, _Nlen, _Col, _Ll, _M, _TInd, _Ind, _LD, _W) -> +pp_record({dots, _, _, _}, _Nlen, _Col, _Ll, _M, _TInd, _Ind, _LD, _W) -> "..."; pp_record([F | Fs], Nlen, Col0, Ll, M, TInd, Ind0, LD, W0) -> Nind = Nlen + 1, @@ -235,9 +250,9 @@ pp_record([F | Fs], Nlen, Col0, Ll, M, TInd, Ind0, LD, W0) -> pp_fields_tail([], _Col0, _Col, _Ll, _M, _TInd, _Ind, _LD, _W) -> ""; -pp_fields_tail({dots, _}, _Col0, _Col, _M, _Ll, _TInd, _Ind, _LD, _W) -> +pp_fields_tail({dots, _, _ ,_}, _Col0, _Col, _M, _Ll, _TInd, _Ind, _LD, _W) -> ",..."; -pp_fields_tail([{_, Len}=F | Fs], Col0, Col, Ll, M, TInd, Ind, LD, W) -> +pp_fields_tail([{_, Len, _, _}=F | Fs], Col0, Col, Ll, M, TInd, Ind, LD, W) -> LD1 = last_depth(Fs, LD), ELen = 1 + Len, if @@ -251,7 +266,7 @@ pp_fields_tail([{_, Len}=F | Fs], Col0, Col, Ll, M, TInd, Ind, LD, W) -> pp_fields_tail(Fs, Col0, Col0 + FW, Ll, M, TInd, Ind, LD, FW)] end. -pp_field({_, Len}=Fl, Col, Ll, M, _TInd, _Ind, LD, W) +pp_field({_, Len, _, _}=Fl, Col, Ll, M, _TInd, _Ind, LD, W) when Len < Ll - Col - LD, Len + W + LD =< M -> {write_field(Fl), if ?ATM_FLD(Fl) -> @@ -259,7 +274,7 @@ pp_field({_, Len}=Fl, Col, Ll, M, _TInd, _Ind, LD, W) true -> Ll % force nl end}; -pp_field({{field, Name, NameL, F}, _Len}, Col0, Ll, M, TInd, Ind0, LD, W0) -> +pp_field({{field, Name, NameL, F},_,_, _}, Col0, Ll, M, TInd, Ind0, LD, W0) -> {Col, Ind, S, W} = rec_indent(NameL, TInd, Col0, Ind0, W0 + NameL), Sep = case S of [$\n | _] -> " ="; @@ -286,15 +301,15 @@ rec_indent(RInd, TInd, Col0, Ind0, W0) -> end, {Col, Ind, S, W}. -pp_list({dots, _}, _Col0, _Ll, _M, _TInd, _Ind, _LD, _S, _W) -> +pp_list({dots, _, _, _}, _Col0, _Ll, _M, _TInd, _Ind, _LD, _S, _W) -> "..."; pp_list([E | Es], Col0, Ll, M, TInd, Ind, LD, S, W) -> {ES, WE} = pp_element(E, Col0, Ll, M, TInd, Ind, last_depth(Es, LD), W), [ES | pp_tail(Es, Col0, Col0 + WE, Ll, M, TInd, Ind, LD, S, W + WE)]. pp_tail([], _Col0, _Col, _Ll, _M, _TInd, _Ind, _LD, _S, _W) -> - ""; -pp_tail([{_, Len}=E | Es], Col0, Col, Ll, M, TInd, Ind, LD, S, W) -> + []; +pp_tail([{_, Len, _, _}=E | Es], Col0, Col, Ll, M, TInd, Ind, LD, S, W) -> LD1 = last_depth(Es, LD), ELen = 1 + Len, if @@ -307,9 +322,9 @@ pp_tail([{_, Len}=E | Es], Col0, Col, Ll, M, TInd, Ind, LD, S, W) -> [$,, $\n, Ind, ES | pp_tail(Es, Col0, Col0 + WE, Ll, M, TInd, Ind, LD, S, WE)] end; -pp_tail({dots, _}, _Col0, _Col, _Ll, _M, _TInd, _Ind, _LD, S, _W) -> +pp_tail({dots, _, _, _}, _Col0, _Col, _Ll, _M, _TInd, _Ind, _LD, S, _W) -> [S | "..."]; -pp_tail({_, Len}=E, _Col0, Col, Ll, M, _TInd, _Ind, LD, S, W) +pp_tail({_, Len, _, _}=E, _Col0, Col, Ll, M, _TInd, _Ind, LD, S, W) when Len + 1 < Ll - Col - (LD + 1), Len + 1 + W + (LD + 1) =< M, ?ATM(E) -> @@ -317,7 +332,7 @@ pp_tail({_, Len}=E, _Col0, Col, Ll, M, _TInd, _Ind, LD, S, W) pp_tail(E, Col0, _Col, Ll, M, TInd, Ind, LD, S, _W) -> [S, $\n, Ind | pp(E, Col0, Ll, M, TInd, Ind, LD + 1, 0)]. -pp_element({_, Len}=E, Col, Ll, M, _TInd, _Ind, LD, W) +pp_element({_, Len, _, _}=E, Col, Ll, M, _TInd, _Ind, LD, W) when Len < Ll - Col - LD, Len + W + LD =< M, ?ATM(E) -> {write(E), Len}; pp_element(E, Col, Ll, M, TInd, Ind, LD, W) -> @@ -348,42 +363,42 @@ pp_binary(S, N, _N0, Ind) -> end. %% write the whole thing on a single line -write({{tuple, _IsTagged, L}, _}) -> +write({{tuple, _IsTagged, L}, _, _, _}) -> [${, write_list(L, $,), $}]; -write({{list, L}, _}) -> +write({{list, L}, _, _, _}) -> [$[, write_list(L, $|), $]]; -write({{map, Pairs}, _}) -> +write({{map, Pairs}, _, _, _}) -> [$#,${, write_list(Pairs, $,), $}]; -write({{map_pair, _K, _V}, _}=Pair) -> +write({{map_pair, _K, _V}, _, _, _}=Pair) -> write_pair(Pair); -write({{record, [{Name,_} | L]}, _}) -> +write({{record, [{Name,_} | L]}, _, _, _}) -> [Name, ${, write_fields(L), $}]; -write({{bin, S}, _}) -> +write({{bin, S}, _, _, _}) -> S; -write({S, _}) -> +write({S, _, _, _}) -> S. -write_pair({{map_pair, K, V}, _}) -> +write_pair({{map_pair, K, V}, _, _, _}) -> [write(K), " => ", write(V)]. write_fields([]) -> ""; -write_fields({dots, _}) -> +write_fields({dots, _, _, _}) -> "..."; write_fields([F | Fs]) -> [write_field(F) | write_fields_tail(Fs)]. write_fields_tail([]) -> ""; -write_fields_tail({dots, _}) -> +write_fields_tail({dots, _, _, _}) -> ",..."; write_fields_tail([F | Fs]) -> [$,, write_field(F) | write_fields_tail(Fs)]. -write_field({{field, Name, _NameL, F}, _}) -> +write_field({{field, Name, _NameL, F}, _, _, _}) -> [Name, " = " | write(F)]. -write_list({dots, _}, _S) -> +write_list({dots, _, _, _}, _S) -> "..."; write_list([E | Es], S) -> [write(E) | write_tail(Es, S)]. @@ -392,182 +407,359 @@ write_tail([], _S) -> []; write_tail([E | Es], S) -> [$,, write(E) | write_tail(Es, S)]; -write_tail({dots, _}, S) -> +write_tail({dots, _, _, _}, S) -> [S | "..."]; write_tail(E, S) -> [S | write(E)]. +-type more() :: fun((chars_limit(), DeltaDepth :: non_neg_integer()) -> + intermediate_format()). + +-type if_list() :: maybe_improper_list(intermediate_format(), + {'dots', non_neg_integer(), + non_neg_integer(), more()}). + +-type intermediate_format() :: + {chars() + | {'bin', chars()} + | 'dots' + | {'field', Name :: chars(), NameLen :: non_neg_integer(), + intermediate_format()} + | {'list', if_list()} + | {'map', if_list()} + | {'map_pair', K :: intermediate_format(), + V :: intermediate_format()} + | {'record', [{Name :: chars(), NameLen :: non_neg_integer()} + | if_list()]} + | {'tuple', IsTagged :: boolean(), if_list()}, + Len :: non_neg_integer(), + NumOfDots :: non_neg_integer(), + More :: more() | 'no_more' + }. + +-spec intermediate(term(), depth(), pos_integer(), rec_print_fun(), + encoding(), boolean()) -> intermediate_format(). + +intermediate(Term, D, T, RF, Enc, Str) when T > 0 -> + D0 = 1, + If = print_length(Term, D0, T, RF, Enc, Str), + case If of + {_, Len, Dots, _} when Dots =:= 0; Len > T; D =:= 1 -> + If; + _ -> + find_upper(If, Term, T, D0, 2, D, RF, Enc, Str) + end. + +find_upper(Lower, Term, T, Dl, Dd, D, RF, Enc, Str) -> + Dd2 = Dd * 2, + D1 = case D < 0 of + true -> Dl + Dd2; + false -> min(Dl + Dd2, D) + end, + If = expand(Lower, T, D1 - Dl), + case If of + {_, _, _Dots=0, _} -> % even if Len > T + If; + {_, Len, _, _} when Len =< T, D1 < D orelse D < 0 -> + find_upper(If, Term, T, D1, Dd2, D, RF, Enc, Str); + _ -> + search_depth(Lower, If, Term, T, Dl, D1, RF, Enc, Str) + end. + +%% Lower has NumOfDots > 0 and Len =< T. +%% Upper has NumOfDots > 0 and Len > T. +search_depth(Lower, Upper, _Term, T, Dl, Du, _RF, _Enc, _Str) + when Du - Dl =:= 1 -> + %% The returned intermediate format has Len >= T. + case Lower of + {_, T, _, _} -> + Lower; + _ -> + Upper + end; +search_depth(Lower, Upper, Term, T, Dl, Du, RF, Enc, Str) -> + D1 = (Dl + Du) div 2, + If = expand(Lower, T, D1 - Dl), + case If of + {_, Len, _, _} when Len > T -> + %% Len can be greater than Upper's length. + %% This is a bit expensive since the work to + %% crate Upper is wasted. It is the price + %% to pay to get a more balanced output. + search_depth(Lower, If, Term, T, Dl, D1, RF, Enc, Str); + _ -> + search_depth(If, Upper, Term, T, D1, Du, RF, Enc, Str) + end. + %% 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, map) are %% counted but need to be added later. %% D =/= 0 -print_length([], _D, _RF, _Enc, _Str) -> - {"[]", 2}; -print_length({}, _D, _RF, _Enc, _Str) -> - {"{}", 2}; -print_length(#{}=M, _D, _RF, _Enc, _Str) when map_size(M) =:= 0 -> - {"#{}", 3}; -print_length(Atom, _D, _RF, Enc, _Str) when is_atom(Atom) -> +print_length([], _D, _T, _RF, _Enc, _Str) -> + {"[]", 2, 0, no_more}; +print_length({}, _D, _T, _RF, _Enc, _Str) -> + {"{}", 2, 0, no_more}; +print_length(#{}=M, _D, _T, _RF, _Enc, _Str) when map_size(M) =:= 0 -> + {"#{}", 3, 0, no_more}; +print_length(Atom, _D, _T, _RF, Enc, _Str) when is_atom(Atom) -> S = write_atom(Atom, Enc), - {S, lists:flatlength(S)}; -print_length(List, D, RF, Enc, Str) when is_list(List) -> + {S, string:length(S), 0, no_more}; +print_length(List, D, T, RF, Enc, Str) when is_list(List) -> %% only flat lists are "printable" - case Str andalso printable_list(List, D, Enc) of + case Str andalso printable_list(List, D, T, Enc) of true -> %% print as string, escaping double-quotes in the list S = write_string(List, Enc), - {S, length(S)}; - %% Truncated lists could break some existing code. - % {true, Prefix} -> - % S = write_string(Prefix, Enc), - % {[S | "..."], 3 + length(S)}; + {S, string:length(S), 0, no_more}; + {true, Prefix} -> + %% Truncated lists when T < 0 could break some existing code. + S = write_string(Prefix, Enc), + %% NumOfDots = 0 to avoid looping--increasing the depth + %% does not make Prefix longer. + {[S | "..."], 3 + string:length(S), 0, no_more}; false -> - print_length_list(List, D, RF, Enc, Str) + case print_length_list(List, D, T, RF, Enc, Str) of + {What, Len, Dots, _More} when Dots > 0 -> + More = fun(T1, Dd) -> + ?FUNCTION_NAME(List, D+Dd, T1, RF, Enc, Str) + end, + {What, Len, Dots, More}; + If -> + If + end end; -print_length(Fun, _D, _RF, _Enc, _Str) when is_function(Fun) -> +print_length(Fun, _D, _T, _RF, _Enc, _Str) when is_function(Fun) -> S = io_lib:write(Fun), - {S, iolist_size(S)}; -print_length(R, D, RF, Enc, Str) when is_atom(element(1, R)), - is_function(RF) -> + {S, iolist_size(S), 0, no_more}; +print_length(R, D, T, RF, Enc, Str) when is_atom(element(1, R)), + is_function(RF) -> case RF(element(1, R), tuple_size(R) - 1) of no -> - print_length_tuple(R, D, RF, Enc, Str); + print_length_tuple(R, D, T, RF, Enc, Str); RDefs -> - print_length_record(R, D, RF, RDefs, Enc, Str) + print_length_record(R, D, T, RF, RDefs, Enc, Str) end; -print_length(Tuple, D, RF, Enc, Str) when is_tuple(Tuple) -> - print_length_tuple(Tuple, D, RF, Enc, Str); -print_length(Map, D, RF, Enc, Str) when is_map(Map) -> - print_length_map(Map, D, RF, Enc, Str); -print_length(<<>>, _D, _RF, _Enc, _Str) -> - {"<<>>", 4}; -print_length(<<_/bitstring>>, 1, _RF, _Enc, _Str) -> - {"<<...>>", 7}; -print_length(<<_/bitstring>>=Bin, D, _RF, Enc, Str) -> - case bit_size(Bin) rem 8 of - 0 -> - D1 = D - 1, - case Str andalso printable_bin(Bin, D1, Enc) of - {true, List} when is_list(List) -> - S = io_lib:write_string(List, $"), %" - {[$<,$<,S,$>,$>], 4 + length(S)}; - {false, List} when is_list(List) -> - S = io_lib:write_string(List, $"), %" - {[$<,$<,S,"/utf8>>"], 9 + length(S)}; - {true, true, Prefix} -> - S = io_lib:write_string(Prefix, $"), %" - {[$<,$<, S | "...>>"], 7 + length(S)}; - {false, true, Prefix} -> - S = io_lib:write_string(Prefix, $"), %" - {[$<,$<, S | "/utf8...>>"], 12 + length(S)}; - false -> - S = io_lib:write(Bin, D), - {{bin,S}, iolist_size(S)} - end; - _ -> - S = io_lib:write(Bin, D), - {{bin,S}, iolist_size(S)} +print_length(Tuple, D, T, RF, Enc, Str) when is_tuple(Tuple) -> + print_length_tuple(Tuple, D, T, RF, Enc, Str); +print_length(Map, D, T, RF, Enc, Str) when is_map(Map) -> + print_length_map(Map, D, T, RF, Enc, Str); +print_length(<<>>, _D, _T, _RF, _Enc, _Str) -> + {"<<>>", 4, 0, no_more}; +print_length(<<_/bitstring>> = Bin, 1, _T, RF, Enc, Str) -> + More = fun(T1, Dd) -> ?FUNCTION_NAME(Bin, 1+Dd, T1, RF, Enc, Str) end, + {"<<...>>", 7, 3, More}; +print_length(<<_/bitstring>> = Bin, D, T, RF, Enc, Str) -> + D1 = D - 1, + case + Str andalso + (bit_size(Bin) rem 8) =:= 0 andalso + printable_bin0(Bin, D1, tsub(T, 6), Enc) + of + {true, List} when is_list(List) -> + S = io_lib:write_string(List, $"), %" + {[$<,$<,S,$>,$>], 4 + length(S), 0, no_more}; + {false, List} when is_list(List) -> + S = io_lib:write_string(List, $"), %" + {[$<,$<,S,"/utf8>>"], 9 + string:length(S), 0, no_more}; + {true, true, Prefix} -> + S = io_lib:write_string(Prefix, $"), %" + More = fun(T1, Dd) -> + ?FUNCTION_NAME(Bin, D+Dd, T1, RF, Enc, Str) + end, + {[$<,$<,S|"...>>"], 7 + length(S), 3, More}; + {false, true, Prefix} -> + S = io_lib:write_string(Prefix, $"), %" + More = fun(T1, Dd) -> + ?FUNCTION_NAME(Bin, D+Dd, T1, RF, Enc, Str) + end, + {[$<,$<,S|"/utf8...>>"], 12 + string:length(S), 3, More}; + false -> + case io_lib:write_binary(Bin, D, T) of + {S, <<>>} -> + {{bin, S}, iolist_size(S), 0, no_more}; + {S, _Rest} -> + More = fun(T1, Dd) -> + ?FUNCTION_NAME(Bin, D+Dd, T1, RF, Enc, Str) + end, + {{bin, S}, iolist_size(S), 3, More} + end end; -print_length(Term, _D, _RF, _Enc, _Str) -> +print_length(Term, _D, _T, _RF, _Enc, _Str) -> S = io_lib:write(Term), %% S can contain unicode, so iolist_size(S) cannot be used here - {S, string:length(S)}. - -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(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) -> + {S, string:length(S), 0, no_more}. + +print_length_map(Map, 1, _T, RF, Enc, Str) -> + More = fun(T1, Dd) -> ?FUNCTION_NAME(Map, 1+Dd, T1, RF, Enc, Str) end, + {"#{...}", 6, 3, More}; +print_length_map(Map, D, T, RF, Enc, Str) when is_map(Map) -> + Next = maps:next(maps:iterator(Map)), + PairsS = print_length_map_pairs(Next, D, D - 1, tsub(T, 3), RF, Enc, Str), + {Len, Dots} = list_length(PairsS, 3, 0), + {{map, PairsS}, Len, Dots, no_more}. + +print_length_map_pairs(none, _D, _D0, _T, _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_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), +print_length_map_pairs(Term, D, D0, T, RF, Enc, Str) when D =:= 1; T =:= 0-> + More = fun(T1, Dd) -> + ?FUNCTION_NAME(Term, D+Dd, D0, T1, RF, Enc, Str) + end, + {dots, 3, 3, More}; +print_length_map_pairs({K, V, Iter}, D, D0, T, RF, Enc, Str) -> + Pair1 = print_length_map_pair(K, V, D0, tsub(T, 1), RF, Enc, Str), + {_, Len1, _, _} = Pair1, + Next = maps:next(Iter), + [Pair1 | + print_length_map_pairs(Next, D - 1, D0, tsub(T, Len1+1), RF, Enc, Str)]. + +print_length_map_pair(K, V, D, T, RF, Enc, Str) -> + {_, KL, KD, _} = P1 = print_length(K, D, T, RF, Enc, Str), KL1 = KL + 4, - {{map_pair, {KS, KL1}, {VS, VL}}, KL1 + VL}. - -print_length_tuple(_Tuple, 1, _RF, _Enc, _Str) -> - {"{...}", 5}; -print_length_tuple(Tuple, D, RF, Enc, Str) -> - L = print_length_list1(tuple_to_list(Tuple), D, RF, Enc, Str), + {_, VL, VD, _} = P2 = print_length(V, D, tsub(T, KL1), RF, Enc, Str), + {{map_pair, P1, P2}, KL1 + VL, KD + VD, no_more}. + +print_length_tuple(Tuple, 1, _T, RF, Enc, Str) -> + More = fun(T1, Dd) -> ?FUNCTION_NAME(Tuple, 1+Dd, T1, RF, Enc, Str) end, + {"{...}", 5, 3, More}; +print_length_tuple(Tuple, D, T, RF, Enc, Str) -> + L = print_length_tuple1(Tuple, 1, D, tsub(T, 2), RF, Enc, Str), IsTagged = is_atom(element(1, Tuple)) and (tuple_size(Tuple) > 1), - {{tuple,IsTagged,L}, list_length(L, 2)}. + {Len, Dots} = list_length(L, 2, 0), + {{tuple,IsTagged,L}, Len, Dots, no_more}. -print_length_record(_Tuple, 1, _RF, _RDefs, _Enc, _Str) -> - {"{...}", 5}; -print_length_record(Tuple, D, RF, RDefs, Enc, Str) -> +print_length_tuple1(Tuple, I, _D, _T, _RF, _Enc, _Str) + when I > tuple_size(Tuple) -> + []; +print_length_tuple1(Tuple, I, D, T, RF, Enc, Str) when D =:= 1; T =:= 0-> + More = fun(T1, Dd) -> ?FUNCTION_NAME(Tuple, I, D+Dd, T1, RF, Enc, Str) end, + {dots, 3, 3, More}; +print_length_tuple1(Tuple, I, D, T, RF, Enc, Str) -> + E = element(I, Tuple), + T1 = tsub(T, 1), + {_, Len1, _, _} = Elem1 = print_length(E, D - 1, T1, RF, Enc, Str), + T2 = tsub(T1, Len1), + [Elem1 | print_length_tuple1(Tuple, I + 1, D - 1, T2, RF, Enc, Str)]. + +print_length_record(Tuple, 1, _T, RF, RDefs, Enc, Str) -> + More = fun(T1, Dd) -> + ?FUNCTION_NAME(Tuple, 1+Dd, T1, RF, RDefs, Enc, Str) + end, + {"{...}", 5, 3, More}; +print_length_record(Tuple, D, T, RF, RDefs, Enc, Str) -> Name = [$# | write_atom(element(1, Tuple), Enc)], - NameL = length(Name), - Elements = tl(tuple_to_list(Tuple)), - L = print_length_fields(RDefs, D - 1, Elements, RF, Enc, Str), - {{record, [{Name,NameL} | L]}, list_length(L, NameL + 2)}. - -print_length_fields([], _D, [], _RF, _Enc, _Str) -> + NameL = string:length(Name), + T1 = tsub(T, NameL+2), + L = print_length_fields(RDefs, D - 1, T1, Tuple, 2, RF, Enc, Str), + {Len, Dots} = list_length(L, NameL + 2, 0), + {{record, [{Name,NameL} | L]}, Len, Dots, no_more}. + +print_length_fields([], _D, _T, Tuple, I, _RF, _Enc, _Str) + when I > tuple_size(Tuple) -> []; -print_length_fields(_, 1, _, _RF, _Enc, _Str) -> - {dots, 3}; -print_length_fields([Def | Defs], D, [E | Es], RF, Enc, Str) -> - [print_length_field(Def, D - 1, E, RF, Enc, Str) | - print_length_fields(Defs, D - 1, Es, RF, Enc, Str)]. - -print_length_field(Def, D, E, RF, Enc, Str) -> +print_length_fields(Term, D, T, Tuple, I, RF, Enc, Str) + when D =:= 1; T =:= 0 -> + More = fun(T1, Dd) -> + ?FUNCTION_NAME(Term, D+Dd, T1, Tuple, I, RF, Enc, Str) + end, + {dots, 3, 3, More}; +print_length_fields([Def | Defs], D, T, Tuple, I, RF, Enc, Str) -> + E = element(I, Tuple), + T1 = tsub(T, 1), + Field1 = print_length_field(Def, D - 1, T1, E, RF, Enc, Str), + {_, Len1, _, _} = Field1, + T2 = tsub(T1, Len1), + [Field1 | + print_length_fields(Defs, D - 1, T2, Tuple, I + 1, RF, Enc, Str)]. + +print_length_field(Def, D, T, E, RF, Enc, Str) -> Name = write_atom(Def, Enc), - {S, L} = print_length(E, D, RF, Enc, Str), - NameL = length(Name) + 3, - {{field, Name, NameL, {S, L}}, NameL + L}. + NameL = string:length(Name) + 3, + {_, Len, Dots, _} = + Field = print_length(E, D, tsub(T, NameL), RF, Enc, Str), + {{field, Name, NameL, Field}, NameL + Len, Dots, no_more}. -print_length_list(List, D, RF, Enc, Str) -> - L = print_length_list1(List, D, RF, Enc, Str), - {{list, L}, list_length(L, 2)}. +print_length_list(List, D, T, RF, Enc, Str) -> + L = print_length_list1(List, D, tsub(T, 2), RF, Enc, Str), + {Len, Dots} = list_length(L, 2, 0), + {{list, L}, Len, Dots, no_more}. -print_length_list1([], _D, _RF, _Enc, _Str) -> +print_length_list1([], _D, _T, _RF, _Enc, _Str) -> []; -print_length_list1(_, 1, _RF, _Enc, _Str) -> - {dots, 3}; -print_length_list1([E | Es], D, RF, Enc, Str) -> - [print_length(E, D - 1, RF, Enc, Str) | - print_length_list1(Es, D - 1, RF, Enc, Str)]; -print_length_list1(E, D, RF, Enc, Str) -> - print_length(E, D - 1, RF, Enc, Str). - -list_length([], Acc) -> - Acc; -list_length([{_, Len} | Es], Acc) -> - list_length_tail(Es, Acc + Len); -list_length({_, Len}, Acc) -> - Acc + Len. - -list_length_tail([], Acc) -> - Acc; -list_length_tail([{_,Len} | Es], Acc) -> - list_length_tail(Es, Acc + 1 + Len); -list_length_tail({_, Len}, Acc) -> - Acc + 1 + Len. +print_length_list1(Term, D, T, RF, Enc, Str) when D =:= 1; T =:= 0-> + More = fun(T1, Dd) -> ?FUNCTION_NAME(Term, D+Dd, T1, RF, Enc, Str) end, + {dots, 3, 3, More}; +print_length_list1([E | Es], D, T, RF, Enc, Str) -> + {_, Len1, _, _} = Elem1 = print_length(E, D - 1, tsub(T, 1), RF, Enc, Str), + [Elem1 | print_length_list1(Es, D - 1, tsub(T, Len1 + 1), RF, Enc, Str)]; +print_length_list1(E, D, T, RF, Enc, Str) -> + print_length(E, D - 1, T, RF, Enc, Str). + +list_length([], Acc, DotsAcc) -> + {Acc, DotsAcc}; +list_length([{_, Len, Dots, _} | Es], Acc, DotsAcc) -> + list_length_tail(Es, Acc + Len, DotsAcc + Dots); +list_length({_, Len, Dots, _}, Acc, DotsAcc) -> + {Acc + Len, DotsAcc + Dots}. + +list_length_tail([], Acc, DotsAcc) -> + {Acc, DotsAcc}; +list_length_tail([{_, Len, Dots, _} | Es], Acc, DotsAcc) -> + list_length_tail(Es, Acc + 1 + Len, DotsAcc + Dots); +list_length_tail({_, Len, Dots, _}, Acc, DotsAcc) -> + {Acc + 1 + Len, DotsAcc + Dots}. %% ?CHARS printable characters has depth 1. -define(CHARS, 4). %% only flat lists are "printable" -printable_list(_L, 1, _Enc) -> +printable_list(_L, 1, _T, _Enc) -> false; -printable_list(L, _D, latin1) -> +printable_list(L, _D, T, latin1) when T < 0 -> io_lib:printable_latin1_list(L); -printable_list(L, _D, _Uni) -> +printable_list(L, _D, T, Enc) when T >= 0 -> + case slice(L, tsub(T, 2)) of + {prefix, ""} -> + false; + {prefix, Prefix} when Enc =:= latin1 -> + io_lib:printable_latin1_list(Prefix) andalso {true, Prefix}; + {prefix, Prefix} -> + %% Probably an overestimation. + io_lib:printable_list(Prefix) andalso {true, Prefix}; + all when Enc =:= latin1 -> + io_lib:printable_latin1_list(L); + all -> + io_lib:printable_list(L) + end; +printable_list(L, _D, T, _Uni) when T < 0-> io_lib:printable_list(L). -printable_bin(Bin, D, Enc) when D >= 0, ?CHARS * D =< byte_size(Bin) -> - printable_bin(Bin, erlang:min(?CHARS * D, byte_size(Bin)), D, Enc); -printable_bin(Bin, D, Enc) -> - printable_bin(Bin, byte_size(Bin), D, Enc). +slice(L, N) -> + case string:length(L) =< N of + true -> + all; + false -> + {prefix, string:slice(L, 0, N)} + end. + +printable_bin0(Bin, D, T, Enc) -> + Len = case D >= 0 of + true -> + %% Use byte_size() also if Enc =/= latin1. + DChars = erlang:min(?CHARS * D, byte_size(Bin)), + case T >= 0 of + true -> + erlang:min(T, DChars); + false -> + DChars + end; + false when T < 0 -> + byte_size(Bin); + false when T >= 0 -> % cannot happen + T + end, + printable_bin(Bin, Len, D, Enc). printable_bin(Bin, Len, D, latin1) -> N = erlang:min(20, Len), @@ -679,28 +871,70 @@ write_string(S, latin1) -> write_string(S, _Uni) -> io_lib:write_string(S, $"). %" +expand({_, _, _Dots=0, no_more} = If, _T, _Dd) -> If; +%% expand({{list,L}, _Len, _, no_more}, T, Dd) -> +%% {NL, NLen, NDots} = expand_list(L, T, Dd, 2), +%% {{list,NL}, NLen, NDots, no_more}; +expand({{tuple,IsTagged,L}, _Len, _, no_more}, T, Dd) -> + {NL, NLen, NDots} = expand_list(L, T, Dd, 2), + {{tuple,IsTagged,NL}, NLen, NDots, no_more}; +expand({{map, Pairs}, _Len, _, no_more}, T, Dd) -> + {NPairs, NLen, NDots} = expand_list(Pairs, T, Dd, 3), + {{map, NPairs}, NLen, NDots, no_more}; +expand({{map_pair, K, V}, _Len, _, no_more}, T, Dd) -> + {_, KL, KD, _} = P1 = expand(K, tsub(T, 1), Dd), + KL1 = KL + 4, + {_, VL, VD, _} = P2 = expand(V, tsub(T, KL1), Dd), + {{map_pair, P1, P2}, KL1 + VL, KD + VD, no_more}; +expand({{record, [{Name,NameL} | L]}, _Len, _, no_more}, T, Dd) -> + {NL, NLen, NDots} = expand_list(L, T, Dd, NameL + 2), + {{record, [{Name,NameL} | NL]}, NLen, NDots, no_more}; +expand({{field, Name, NameL, Field}, _Len, _, no_more}, T, Dd) -> + F = {_S, L, Dots, _} = expand(Field, tsub(T, NameL), Dd), + {{field, Name, NameL, F}, NameL + L, Dots, no_more}; +expand({_, _, _, More}, T, Dd) -> + More(T, Dd). + +expand_list(Ifs, T, Dd, L0) -> + L = expand_list(Ifs, tsub(T, L0), Dd), + {Len, Dots} = list_length(L, L0, 0), + {L, Len, Dots}. + +expand_list([], _T, _Dd) -> + []; +expand_list([If | Ifs], T, Dd) -> + {_, Len1, _, _} = Elem1 = expand(If, tsub(T, 1), Dd), + [Elem1 | expand_list(Ifs, tsub(T, Len1 + 1), Dd)]; +expand_list({_, _, _, More}, T, Dd) -> + More(T, Dd). + +%% Make sure T does not change sign. +tsub(T, _) when T < 0 -> T; +tsub(T, E) when T >= E -> T - E; +tsub(_, _) -> 0. + %% Throw 'no_good' if the indentation exceeds half the line length %% unless there is room for M characters on the line. -cind({_S, Len}, Col, Ll, M, Ind, LD, W) when Len < Ll - Col - LD, - Len + W + LD =< M -> +cind({_S, Len, _, _}, Col, Ll, M, Ind, LD, W) when Len < Ll - Col - LD, + Len + W + LD =< M -> Ind; -cind({{list,L}, _Len}, Col, Ll, M, Ind, LD, W) -> +cind({{list,L}, _Len, _, _}, Col, Ll, M, Ind, LD, W) -> cind_list(L, Col + 1, Ll, M, Ind, LD, W + 1); -cind({{tuple,true,L}, _Len}, Col, Ll, M, Ind, LD, W) -> +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({{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}, _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,[{_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) -> +cind({{bin,_S}, _Len, _, _}, _Col, _Ll, _M, Ind, _LD, _W) -> Ind; -cind({_S, _Len}, _Col, _Ll, _M, Ind, _LD, _W) -> +cind({_S,_Len,_,_}, _Col, _Ll, _M, Ind, _LD, _W) -> Ind. -cind_tag_tuple([{_Tag,Tlen} | L], Col, Ll, M, Ind, LD, W) -> +cind_tag_tuple([{_Tag,Tlen,_,_} | L], Col, Ll, M, Ind, LD, W) -> TagInd = Tlen + 2, Tcol = Col + TagInd, if @@ -722,9 +956,9 @@ 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. + Ind. % cannot happen -cind_pairs_tail([{_, Len}=P | Ps], Col0, Col, Ll, M, Ind, LD, W) -> +cind_pairs_tail([{_, Len, _, _} = P | Ps], Col0, Col, Ll, M, Ind, LD, W) -> LD1 = last_depth(Ps, LD), ELen = 1 + Len, if @@ -738,7 +972,7 @@ cind_pairs_tail([{_, Len}=P | Ps], Col0, Col, Ll, M, Ind, LD, W) -> 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) +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) -> @@ -746,7 +980,7 @@ cind_pair({{map_pair, _Key, _Value}, Len}=Pair, Col, Ll, M, _Ind, LD, W) true -> Ll end; -cind_pair({{map_pair, K, V}, _Len}, Col0, Ll, M, Ind, LD, W0) -> +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), @@ -768,7 +1002,7 @@ cind_record([F | Fs], Nlen, Col0, Ll, M, Ind, LD, W0) -> cind_record(_, _Nlen, _Col, _Ll, _M, Ind, _LD, _W) -> Ind. -cind_fields_tail([{_, Len}=F | Fs], Col0, Col, Ll, M, Ind, LD, W) -> +cind_fields_tail([{_, Len, _, _} = F | Fs], Col0, Col, Ll, M, Ind, LD, W) -> LD1 = last_depth(Fs, LD), ELen = 1 + Len, if @@ -782,7 +1016,7 @@ cind_fields_tail([{_, Len}=F | Fs], Col0, Col, Ll, M, Ind, LD, W) -> cind_fields_tail(_, _Col0, _Col, _Ll, _M, Ind, _LD, _W) -> Ind. -cind_field({{field, _N, _NL, _F}, Len}=Fl, Col, Ll, M, _Ind, LD, W) +cind_field({{field, _N, _NL, _F}, Len, _, _}=Fl, Col, Ll, M, _Ind, LD, W) when Len < Ll - Col - LD, Len + W + LD =< M -> if ?ATM_FLD(Fl) -> @@ -790,7 +1024,7 @@ cind_field({{field, _N, _NL, _F}, Len}=Fl, Col, Ll, M, _Ind, LD, W) true -> Ll end; -cind_field({{field, _Name, NameL, F}, _Len}, Col0, Ll, M, Ind, LD, W0) -> +cind_field({{field, _Name, NameL, F},_Len,_,_}, Col0, Ll, M, Ind, LD, W0) -> {Col, W} = cind_rec(NameL, Col0, Ll, M, Ind, W0 + NameL), cind(F, Col, Ll, M, Ind, LD, W), Ll. @@ -813,7 +1047,7 @@ cind_rec(RInd, Col0, Ll, M, Ind, W0) -> throw(no_good) end. -cind_list({dots, _}, _Col0, _Ll, _M, Ind, _LD, _W) -> +cind_list({dots, _, _, _}, _Col0, _Ll, _M, Ind, _LD, _W) -> Ind; cind_list([E | Es], Col0, Ll, M, Ind, LD, W) -> WE = cind_element(E, Col0, Ll, M, Ind, last_depth(Es, LD), W), @@ -821,7 +1055,7 @@ cind_list([E | Es], Col0, Ll, M, Ind, LD, W) -> cind_tail([], _Col0, _Col, _Ll, _M, Ind, _LD, _W) -> Ind; -cind_tail([{_, Len}=E | Es], Col0, Col, Ll, M, Ind, LD, W) -> +cind_tail([{_, Len, _, _} = E | Es], Col0, Col, Ll, M, Ind, LD, W) -> LD1 = last_depth(Es, LD), ELen = 1 + Len, if @@ -832,9 +1066,9 @@ cind_tail([{_, Len}=E | Es], Col0, Col, Ll, M, Ind, LD, W) -> WE = cind_element(E, Col0, Ll, M, Ind, LD1, 0), cind_tail(Es, Col0, Col0 + WE, Ll, M, Ind, LD, WE) end; -cind_tail({dots, _}, _Col0, _Col, _Ll, _M, Ind, _LD, _W) -> +cind_tail({dots, _, _, _}, _Col0, _Col, _Ll, _M, Ind, _LD, _W) -> Ind; -cind_tail({_, Len}=E, _Col0, Col, Ll, M, Ind, LD, W) +cind_tail({_, Len, _, _}=E, _Col0, Col, Ll, M, Ind, LD, W) when Len + 1 < Ll - Col - (LD + 1), Len + 1 + W + (LD + 1) =< M, ?ATM(E) -> @@ -842,7 +1076,7 @@ cind_tail({_, Len}=E, _Col0, Col, Ll, M, Ind, LD, W) cind_tail(E, _Col0, Col, Ll, M, Ind, LD, _W) -> cind(E, Col, Ll, M, Ind, LD + 1, 0). -cind_element({_, Len}=E, Col, Ll, M, _Ind, LD, W) +cind_element({_, Len, _, _}=E, Col, Ll, M, _Ind, LD, W) when Len < Ll - Col - LD, Len + W + LD =< M, ?ATM(E) -> Len; cind_element(E, Col, Ll, M, Ind, LD, W) -> diff --git a/lib/stdlib/src/lib.erl b/lib/stdlib/src/lib.erl index be11e86100..51e0c3f77e 100644 --- a/lib/stdlib/src/lib.erl +++ b/lib/stdlib/src/lib.erl @@ -646,7 +646,7 @@ pp_arguments(PF, As, I, Enc) -> Ll = length(L), A = list_to_atom(lists:duplicate(Ll, $a)), S0 = unicode:characters_to_list(PF([A | T], I+1), Enc), - brackets_to_parens([$[,L,string:sub_string(S0, 2+Ll)], Enc); + brackets_to_parens([$[,L,string:slice(S0, 1+Ll)], Enc); _ -> brackets_to_parens(PF(As, I+1), Enc) end. diff --git a/lib/stdlib/src/lists.erl b/lib/stdlib/src/lists.erl index af9d63ddd6..06c90c0280 100644 --- a/lib/stdlib/src/lists.erl +++ b/lib/stdlib/src/lists.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2016. All Rights Reserved. +%% Copyright Ericsson AB 1996-2018. 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. @@ -38,8 +38,8 @@ -export([all/2,any/2,map/2,flatmap/2,foldl/3,foldr/3,filter/2, partition/2,zf/2,filtermap/2, - mapfoldl/3,mapfoldr/3,foreach/2,takewhile/2,dropwhile/2,splitwith/2, - split/2, + mapfoldl/3,mapfoldr/3,foreach/2,takewhile/2,dropwhile/2, + search/2, splitwith/2,split/2, join/2]). %%% BIFs @@ -1399,6 +1399,19 @@ dropwhile(Pred, [Hd|Tail]=Rest) -> end; dropwhile(Pred, []) when is_function(Pred, 1) -> []. +-spec search(Pred, List) -> {value, Value} | false when + Pred :: fun((T) -> boolean()), + List :: [T], + Value :: T. + +search(Pred, [Hd|Tail]) -> + case Pred(Hd) of + true -> {value, Hd}; + false -> search(Pred, Tail) + end; +search(Pred, []) when is_function(Pred, 1) -> + false. + -spec splitwith(Pred, List) -> {List1, List2} when Pred :: fun((T) -> boolean()), List :: [T], diff --git a/lib/stdlib/src/maps.erl b/lib/stdlib/src/maps.erl index 5dafdb282a..a13f340709 100644 --- a/lib/stdlib/src/maps.erl +++ b/lib/stdlib/src/maps.erl @@ -23,7 +23,8 @@ -export([get/3, filter/2,fold/3, map/2, size/1, update_with/3, update_with/4, - without/2, with/2]). + without/2, with/2, + iterator/1, next/1]). %% BIFs -export([get/2, find/2, from_list/1, @@ -31,6 +32,15 @@ new/0, put/3, remove/2, take/2, to_list/1, update/3, values/1]). +-opaque iterator() :: {term(), term(), iterator()} + | none | nonempty_improper_list(integer(),map()). + +-export_type([iterator/0]). + +-dialyzer({no_improper_lists, iterator/1}). + +-define(IS_ITERATOR(I), is_tuple(I) andalso tuple_size(I) == 3; I == none; is_integer(hd(I)) andalso is_map(tl(I))). + %% Shadowed by erl_bif_types: maps:get/2 -spec get(Key,Map) -> Value when Key :: term(), @@ -39,7 +49,6 @@ get(_,_) -> erlang:nif_error(undef). - -spec find(Key,Map) -> {ok, Value} | error when Key :: term(), Map :: map(), @@ -114,14 +123,20 @@ remove(_,_) -> erlang:nif_error(undef). take(_,_) -> erlang:nif_error(undef). -%% Shadowed by erl_bif_types: maps:to_list/1 -spec to_list(Map) -> [{Key,Value}] when Map :: map(), Key :: term(), Value :: term(). -to_list(_) -> erlang:nif_error(undef). +to_list(Map) when is_map(Map) -> + to_list_internal(erts_internal:map_next(0, Map, [])); +to_list(Map) -> + erlang:error({badmap,Map},[Map]). +to_list_internal([Iter, Map | Acc]) when is_integer(Iter) -> + to_list_internal(erts_internal:map_next(Iter, Map, Acc)); +to_list_internal(Acc) -> + Acc. %% Shadowed by erl_bif_types: maps:update/3 -spec update(Key,Value,Map1) -> Map2 when @@ -192,47 +207,80 @@ get(Key,Map,Default) -> erlang:error({badmap,Map},[Key,Map,Default]). --spec filter(Pred,Map1) -> Map2 when +-spec filter(Pred,MapOrIter) -> Map when Pred :: fun((Key, Value) -> boolean()), Key :: term(), Value :: term(), - Map1 :: map(), - Map2 :: map(). + MapOrIter :: map() | iterator(), + Map :: map(). filter(Pred,Map) when is_function(Pred,2), is_map(Map) -> - maps:from_list([{K,V}||{K,V}<-maps:to_list(Map),Pred(K,V)]); + maps:from_list(filter_1(Pred, iterator(Map))); +filter(Pred,Iterator) when is_function(Pred,2), ?IS_ITERATOR(Iterator) -> + maps:from_list(filter_1(Pred, Iterator)); filter(Pred,Map) -> erlang:error(error_type(Map),[Pred,Map]). - --spec fold(Fun,Init,Map) -> Acc when +filter_1(Pred, Iter) -> + case next(Iter) of + {K, V, NextIter} -> + case Pred(K,V) of + true -> + [{K,V} | filter_1(Pred, NextIter)]; + false -> + filter_1(Pred, NextIter) + end; + none -> + [] + end. + +-spec fold(Fun,Init,MapOrIter) -> Acc when Fun :: fun((K, V, AccIn) -> AccOut), Init :: term(), Acc :: term(), AccIn :: term(), AccOut :: term(), - Map :: map(), + MapOrIter :: map() | iterator(), K :: term(), V :: term(). fold(Fun,Init,Map) when is_function(Fun,3), is_map(Map) -> - lists:foldl(fun({K,V},A) -> Fun(K,V,A) end,Init,maps:to_list(Map)); + fold_1(Fun,Init,iterator(Map)); +fold(Fun,Init,Iterator) when is_function(Fun,3), ?IS_ITERATOR(Iterator) -> + fold_1(Fun,Init,Iterator); fold(Fun,Init,Map) -> erlang:error(error_type(Map),[Fun,Init,Map]). --spec map(Fun,Map1) -> Map2 when +fold_1(Fun, Acc, Iter) -> + case next(Iter) of + {K, V, NextIter} -> + fold_1(Fun, Fun(K,V,Acc), NextIter); + none -> + Acc + end. + +-spec map(Fun,MapOrIter) -> Map when Fun :: fun((K, V1) -> V2), - Map1 :: map(), - Map2 :: map(), + MapOrIter :: map() | iterator(), + Map :: map(), K :: term(), V1 :: term(), V2 :: term(). map(Fun,Map) when is_function(Fun, 2), is_map(Map) -> - maps:from_list([{K,Fun(K,V)}||{K,V}<-maps:to_list(Map)]); + maps:from_list(map_1(Fun, iterator(Map))); +map(Fun,Iterator) when is_function(Fun, 2), ?IS_ITERATOR(Iterator) -> + maps:from_list(map_1(Fun, Iterator)); map(Fun,Map) -> erlang:error(error_type(Map),[Fun,Map]). +map_1(Fun, Iter) -> + case next(Iter) of + {K, V, NextIter} -> + [{K, Fun(K, V)} | map_1(Fun, NextIter)]; + none -> + [] + end. -spec size(Map) -> non_neg_integer() when Map :: map(). @@ -242,6 +290,26 @@ size(Map) when is_map(Map) -> size(Val) -> erlang:error({badmap,Val},[Val]). +-spec iterator(Map) -> Iterator when + Map :: map(), + Iterator :: iterator(). + +iterator(M) when is_map(M) -> [0 | M]; +iterator(M) -> erlang:error({badmap, M}, [M]). + +-spec next(Iterator) -> {Key, Value, NextIterator} | 'none' when + Iterator :: iterator(), + Key :: term(), + Value :: term(), + NextIterator :: iterator(). +next({K, V, I}) -> + {K, V, I}; +next([Path | Map]) when is_integer(Path), is_map(Map) -> + erts_internal:map_next(Path, Map, iterator); +next(none) -> + none; +next(Iter) -> + erlang:error(badarg, [Iter]). -spec without(Ks,Map1) -> Map2 when Ks :: [K], @@ -250,11 +318,10 @@ size(Val) -> K :: term(). without(Ks,M) when is_list(Ks), is_map(M) -> - lists:foldl(fun(K, M1) -> ?MODULE:remove(K, M1) end, M, Ks); + lists:foldl(fun(K, M1) -> maps:remove(K, M1) end, M, Ks); without(Ks,M) -> erlang:error(error_type(M),[Ks,M]). - -spec with(Ks, Map1) -> Map2 when Ks :: [K], Map1 :: map(), @@ -263,17 +330,17 @@ without(Ks,M) -> with(Ks,Map1) when is_list(Ks), is_map(Map1) -> Fun = fun(K, List) -> - case ?MODULE:find(K, Map1) of - {ok, V} -> - [{K, V} | List]; - error -> - List - end - end, - ?MODULE:from_list(lists:foldl(Fun, [], Ks)); + case maps:find(K, Map1) of + {ok, V} -> + [{K, V} | List]; + error -> + List + end + end, + maps:from_list(lists:foldl(Fun, [], Ks)); with(Ks,M) -> erlang:error(error_type(M),[Ks,M]). -error_type(M) when is_map(M) -> badarg; +error_type(M) when is_map(M); ?IS_ITERATOR(M) -> badarg; error_type(V) -> {badmap, V}. diff --git a/lib/stdlib/src/ms_transform.erl b/lib/stdlib/src/ms_transform.erl index 6616e957c0..ec8cfd56c2 100644 --- a/lib/stdlib/src/ms_transform.erl +++ b/lib/stdlib/src/ms_transform.erl @@ -944,6 +944,7 @@ real_guard_function(node,1) -> true; real_guard_function(round,1) -> true; real_guard_function(size,1) -> true; real_guard_function(map_size,1) -> true; +real_guard_function(map_get,2) -> true; real_guard_function(tl,1) -> true; real_guard_function(trunc,1) -> true; real_guard_function(self,0) -> true; @@ -1115,5 +1116,3 @@ normalise_list([H|T]) -> [normalise(H)|normalise_list(T)]; normalise_list([]) -> []. - - diff --git a/lib/stdlib/src/ordsets.erl b/lib/stdlib/src/ordsets.erl index 569407f5ef..939e147ad8 100644 --- a/lib/stdlib/src/ordsets.erl +++ b/lib/stdlib/src/ordsets.erl @@ -19,7 +19,7 @@ -module(ordsets). --export([new/0,is_set/1,size/1,to_list/1,from_list/1]). +-export([new/0,is_set/1,size/1,is_empty/1,to_list/1,from_list/1]). -export([is_element/2,add_element/2,del_element/2]). -export([union/2,union/1,intersection/2,intersection/1]). -export([is_disjoint/2]). @@ -60,6 +60,13 @@ is_set([], _) -> true. size(S) -> length(S). +%% is_empty(OrdSet) -> boolean(). +%% Return 'true' if OrdSet is an empty set, otherwise 'false'. +-spec is_empty(Ordset) -> boolean() when + Ordset :: ordset(_). + +is_empty(S) -> S=:=[]. + %% to_list(OrdSet) -> [Elem]. %% Return the elements in OrdSet as a list. diff --git a/lib/stdlib/src/otp_internal.erl b/lib/stdlib/src/otp_internal.erl index 5b488cc677..a17addcc42 100644 --- a/lib/stdlib/src/otp_internal.erl +++ b/lib/stdlib/src/otp_internal.erl @@ -604,6 +604,9 @@ obsolete_1(filename, find_src, 1) -> obsolete_1(filename, find_src, 2) -> {deprecated, "deprecated; use filelib:find_source/3 instead"}; +obsolete_1(erlang, get_stacktrace, 0) -> + {deprecated, "deprecated; use the new try/catch syntax for retrieving the stack backtrace"}; + %% Removed in OTP 20. obsolete_1(erlang, hash, 2) -> diff --git a/lib/stdlib/src/pool.erl b/lib/stdlib/src/pool.erl index 05950a1d7c..b12ff205b1 100644 --- a/lib/stdlib/src/pool.erl +++ b/lib/stdlib/src/pool.erl @@ -25,7 +25,7 @@ %% with the least load !!!! %% This function is callable from any node including the master %% That is part of the pool -%% nodes are scheduled on a per usgae basis and per load basis, +%% nodes are scheduled on a per usage basis and per load basis, %% Whenever we use a node, we put at the end of the queue, and whenever %% a node report a change in load, we insert it accordingly @@ -197,7 +197,7 @@ pure_insert({Load,Node},[{L,N}|Tail]) when Load < L -> pure_insert(L,[H|T]) -> [H|pure_insert(L,T)]. %% Really should not measure the contributions from -%% the back ground processes here .... which we do :-( +%% the background processes here .... which we do :-( %% We don't have to monitor the master, since we're slaves anyway statistic_collector() -> @@ -213,7 +213,7 @@ statistic_collector(I) -> stat_loop(M, 999999) end. -%% Do not tell the master about our load if it has not changed +%% Do not tell the master about our load if it has not changed stat_loop(M, Old) -> sleep(2000), diff --git a/lib/stdlib/src/proc_lib.erl b/lib/stdlib/src/proc_lib.erl index 8e10cbe93b..1991585c13 100644 --- a/lib/stdlib/src/proc_lib.erl +++ b/lib/stdlib/src/proc_lib.erl @@ -231,8 +231,8 @@ init_p(Parent, Ancestors, Fun) when is_function(Fun) -> try Fun() catch - Class:Reason -> - exit_p(Class, Reason, erlang:get_stacktrace()) + Class:Reason:Stacktrace -> + exit_p(Class, Reason, Stacktrace) end. -spec init_p(pid(), [pid()], atom(), atom(), [term()]) -> term(). @@ -246,8 +246,8 @@ init_p_do_apply(M, F, A) -> try apply(M, F, A) catch - Class:Reason -> - exit_p(Class, Reason, erlang:get_stacktrace()) + Class:Reason:Stacktrace -> + exit_p(Class, Reason, Stacktrace) end. -spec wake_up(atom(), atom(), [term()]) -> term(). @@ -256,8 +256,8 @@ wake_up(M, F, A) when is_atom(M), is_atom(F), is_list(A) -> try apply(M, F, A) catch - Class:Reason -> - exit_p(Class, Reason, erlang:get_stacktrace()) + Class:Reason:Stacktrace -> + exit_p(Class, Reason, Stacktrace) end. exit_p(Class, Reason, Stacktrace) -> diff --git a/lib/stdlib/src/qlc.erl b/lib/stdlib/src/qlc.erl index f11f9d0a0b..3a66f6930b 100644 --- a/lib/stdlib/src/qlc.erl +++ b/lib/stdlib/src/qlc.erl @@ -301,11 +301,11 @@ eval(QH, Options) -> post_funs(Post) end end - catch Term -> - case erlang:get_stacktrace() of + catch throw:Term:Stacktrace -> + case Stacktrace of [?THROWN_ERROR | _] -> Term; - Stacktrace -> + _ -> erlang:raise(throw, Term, Stacktrace) end end @@ -359,11 +359,11 @@ fold(Fun, Acc0, QH, Options) -> post_funs(Post) end end - catch Term -> - case erlang:get_stacktrace() of + catch throw:Term:Stacktrace -> + case Stacktrace of [?THROWN_ERROR | _] -> Term; - Stacktrace -> + _ -> erlang:raise(throw, Term, Stacktrace) end end @@ -457,11 +457,11 @@ info(QH, Options) -> debug -> % Not documented. Intended for testing only. Info end - catch Term -> - case erlang:get_stacktrace() of + catch throw:Term:Stacktrace -> + case Stacktrace of [?THROWN_ERROR | _] -> Term; - Stacktrace -> + _ -> erlang:raise(throw, Term, Stacktrace) end end @@ -1056,9 +1056,9 @@ cursor_process(H, GUnique, GCache, TmpDir, SpawnOptions, MaxList, TmpUsage) -> Prep = prepare_qlc(H, not_a_list, GUnique, GCache, TmpDir, MaxList, TmpUsage), setup_qlc(Prep, Setup) - catch Class:Reason -> - Parent ! {self(), {caught, Class, Reason, - erlang:get_stacktrace()}}, + catch Class:Reason:Stacktrace -> + Parent ! {self(), + {caught, Class, Reason, Stacktrace}}, exit(normal) end, Parent ! {self(), ok}, @@ -1075,8 +1075,8 @@ parent_fun(Pid, Parent) -> {TPid, {parent_fun, Fun}} -> V = try {value, Fun()} - catch Class:Reason -> - {parent_fun_caught, Class, Reason, erlang:get_stacktrace()} + catch Class:Reason:Stacktrace -> + {parent_fun_caught, Class, Reason, Stacktrace} end, TPid ! {Parent, V}, parent_fun(Pid, Parent); @@ -1101,9 +1101,9 @@ reply(Parent, MonRef, Post, Cont) -> throw_error(Cont) end catch - Class:Reason -> + Class:Reason:Stacktrace -> post_funs(Post), - Message = {caught, Class, Reason, erlang:get_stacktrace()}, + Message = {caught, Class, Reason, Stacktrace}, Parent ! {self(), Message}, exit(normal) end, @@ -1392,9 +1392,8 @@ next_loop(Pid, L, N) when N =/= 0 -> {caught, throw, Error, [?THROWN_ERROR | _]} -> Error; {caught, Class, Reason, Stacktrace} -> - CurrentStacktrace = try erlang:error(foo) - catch error:_ -> erlang:get_stacktrace() - end, + {current_stacktrace, CurrentStacktrace} = + erlang:process_info(self(), current_stacktrace), erlang:raise(Class, Reason, Stacktrace ++ CurrentStacktrace); error -> erlang:error({qlc_cursor_pid_no_longer_exists, Pid}) @@ -2627,9 +2626,9 @@ table_handle(#qlc_table{trav_fun = TraverseFun, trav_MS = TravMS, Parent =:= self() -> try ParentFun() - catch Class:Reason -> + catch Class:Reason:Stacktrace -> post_funs(Post), - erlang:raise(Class, Reason, erlang:get_stacktrace()) + erlang:raise(Class, Reason, Stacktrace) end; true -> case monitor_request(Parent, {parent_fun, ParentFun}) of @@ -3033,9 +3032,9 @@ file_sort_handle(H, Kp, SortOptions, TmpDir, Compressed, Post, LocalPost) -> {terms, BTerms} -> try {[binary_to_term(B) || B <- BTerms], Post, LocalPost} - catch Class:Reason -> + catch Class:Reason:Stacktrace -> post_funs(Post), - erlang:raise(Class, Reason, erlang:get_stacktrace()) + erlang:raise(Class, Reason, Stacktrace) end end. @@ -3045,9 +3044,9 @@ do_sort(In, Out, Sort, SortOptions, Post) -> {error, Reason} -> throw_reason(Reason); Reply -> Reply end - catch Class:Term -> + catch Class:Term:Stacktrace -> post_funs(Post), - erlang:raise(Class, Term, erlang:get_stacktrace()) + erlang:raise(Class, Term, Stacktrace) end. do_sort(In, Out, sort, SortOptions) -> @@ -3797,9 +3796,9 @@ call(undefined, _Arg, Default, _Post) -> call(Fun, Arg, _Default, Post) -> try Fun(Arg) - catch Class:Reason -> + catch Class:Reason:Stacktrace -> post_funs(Post), - erlang:raise(Class, Reason, erlang:get_stacktrace()) + erlang:raise(Class, Reason, Stacktrace) end. grd(undefined, _Arg) -> diff --git a/lib/stdlib/src/rand.erl b/lib/stdlib/src/rand.erl index 7a8a5e6d4a..362e98006e 100644 --- a/lib/stdlib/src/rand.erl +++ b/lib/stdlib/src/rand.erl @@ -21,8 +21,8 @@ %% Multiple PRNG module for Erlang/OTP %% Copyright (c) 2015-2016 Kenji Rikitake %% -%% exrop (xoroshiro116+) added and statistical distribution -%% improvements by the Erlang/OTP team 2017 +%% exrop (xoroshiro116+) added, statistical distribution +%% improvements and uniform_real added by the Erlang/OTP team 2017 %% ===================================================================== -module(rand). @@ -30,10 +30,14 @@ -export([seed_s/1, seed_s/2, seed/1, seed/2, export_seed/0, export_seed_s/1, uniform/0, uniform/1, uniform_s/1, uniform_s/2, + uniform_real/0, uniform_real_s/1, jump/0, jump/1, normal/0, normal/2, normal_s/1, normal_s/3 ]). +%% Debug +-export([make_float/3, float2str/1, bc64/1]). + -compile({inline, [exs64_next/1, exsplus_next/1, exs1024_next/1, exs1024_calc/2, exrop_next/1, exrop_next_s/2, @@ -60,6 +64,10 @@ %% N i evaluated 3 times (?BSL((Bits), (X), (N)) bor ((X) bsr ((Bits)-(N))))). +-define( + BC(V, N), + bc((V), ?BIT((N) - 1), N)). + %%-define(TWO_POW_MINUS53, (math:pow(2, -53))). -define(TWO_POW_MINUS53, 1.11022302462515657e-16). @@ -84,14 +92,21 @@ %% The 'bits' field indicates how many bits the integer %% returned from 'next' has got, i.e 'next' shall return %% an random integer in the range 0..(2^Bits - 1). -%% At least 53 bits is required for the floating point -%% producing fallbacks. This field is only used when -%% the 'uniform' or 'uniform_n' fields are not defined. +%% At least 55 bits is required for the floating point +%% producing fallbacks, but 56 bits would be more future proof. %% %% The fields 'next', 'uniform' and 'uniform_n' -%% implement the algorithm. If 'uniform' or 'uinform_n' +%% implement the algorithm. If 'uniform' or 'uniform_n' %% is not present there is a fallback using 'next' and either -%% 'bits' or the deprecated 'max'. +%% 'bits' or the deprecated 'max'. The 'next' function +%% must generate a word with at least 56 good random bits. +%% +%% The 'weak_low_bits' field indicate how many bits are of +%% lesser quality and they will not be used by the floating point +%% producing functions, nor by the range producing functions +%% when more bits are needed, to avoid weak bits in the middle +%% of the generated bits. The lowest bits from the range +%% functions still have the generator's quality. %% -type alg_handler() :: #{type := alg(), @@ -148,11 +163,7 @@ %% For ranges larger than the algorithm bit size uniform_range(Range, #{next:=Next, bits:=Bits} = Alg, R, V) -> - WeakLowBits = - case Alg of - #{weak_low_bits:=WLB} -> WLB; - #{} -> 0 - end, + WeakLowBits = maps:get(weak_low_bits, Alg, 0), %% Maybe waste the lowest bit(s) when shifting in new bits Shift = Bits - WeakLowBits, ShiftMask = bnot ?MASK(WeakLowBits), @@ -297,7 +308,7 @@ uniform_s({#{bits:=Bits, next:=Next} = Alg, R0}) -> {(V bsr (Bits - 53)) * ?TWO_POW_MINUS53, {Alg, R1}}; uniform_s({#{max:=Max, next:=Next} = Alg, R0}) -> {V, R1} = Next(R0), - %% Old broken algorithm with non-uniform density + %% Old algorithm with non-uniform density {V / (Max + 1), {Alg, R1}}. @@ -317,7 +328,7 @@ uniform_s(N, {#{bits:=Bits, next:=Next} = Alg, R0}) ?uniform_range(N, Alg, R1, V, MaxMinusN, I); uniform_s(N, {#{max:=Max, next:=Next} = Alg, R0}) when is_integer(N), 1 =< N -> - %% Old broken algorithm with skewed probability + %% Old algorithm with skewed probability %% and gap in ranges > Max {V, R1} = Next(R0), if @@ -328,6 +339,189 @@ uniform_s(N, {#{max:=Max, next:=Next} = Alg, R0}) {trunc(F * N) + 1, {Alg, R1}} end. +%% uniform_real/0: returns a random float X where 0.0 < X =< 1.0, +%% updating the state in the process dictionary. + +-spec uniform_real() -> X :: float(). +uniform_real() -> + {X, Seed} = uniform_real_s(seed_get()), + _ = seed_put(Seed), + X. + +%% uniform_real_s/1: given a state, uniform_s/1 +%% returns a random float X where 0.0 < X =< 1.0, +%% and a new state. +%% +%% This function does not use the same form of uniformity +%% as the uniform_s/1 function. +%% +%% Instead, this function does not generate numbers with equal +%% distance in the interval, but rather tries to keep all mantissa +%% bits random also for small numbers, meaning that the distance +%% between possible numbers decreases when the numbers +%% approaches 0.0, as does the possibility for a particular +%% number. Hence uniformity is preserved. +%% +%% To generate 56 bits at the time instead of 53 is actually +%% a speed optimization since the probability to have to +%% generate a second word decreases by 1/2 for every extra bit. +%% +%% This function generates normalized numbers, so the smallest number +%% that can be generated is 2^-1022 with the distance 2^-1074 +%% to the next to smallest number, compared to 2^-53 for uniform_s/1. +%% +%% This concept of uniformity should work better for applications +%% where you need to calculate 1.0/X or math:log(X) since those +%% operations benefits from larger precision approaching 0.0, +%% and that this function does not return 0.0 nor denormalized +%% numbers very close to 0.0. The log() operation in The Box-Muller +%% transformation for normal distribution is an example of this. +%% +%%-define(TWO_POW_MINUS55, (math:pow(2, -55))). +%%-define(TWO_POW_MINUS110, (math:pow(2, -110))). +%%-define(TWO_POW_MINUS55, 2.7755575615628914e-17). +%%-define(TWO_POW_MINUS110, 7.7037197775489436e-34). +%% +-spec uniform_real_s(State :: state()) -> {X :: float(), NewState :: state()}. +uniform_real_s({#{bits:=Bits, next:=Next} = Alg, R0}) -> + %% Generate a 56 bit number without using the weak low bits. + %% + %% Be sure to use only 53 bits when multiplying with + %% math:pow(2.0, -N) to avoid rounding which would make + %% "even" floats more probable than "odd". + %% + {V1, R1} = Next(R0), + M1 = V1 bsr (Bits - 56), + if + ?BIT(55) =< M1 -> + %% We have 56 bits - waste 3 + {(M1 bsr 3) * math:pow(2.0, -53), {Alg, R1}}; + ?BIT(54) =< M1 -> + %% We have 55 bits - waste 2 + {(M1 bsr 2) * math:pow(2.0, -54), {Alg, R1}}; + ?BIT(53) =< M1 -> + %% We have 54 bits - waste 1 + {(M1 bsr 1) * math:pow(2.0, -55), {Alg, R1}}; + ?BIT(52) =< M1 -> + %% We have 53 bits - use all + {M1 * math:pow(2.0, -56), {Alg, R1}}; + true -> + %% Need more bits + {V2, R2} = Next(R1), + uniform_real_s(Alg, Next, M1, -56, R2, V2, Bits) + end; +uniform_real_s({#{max:=_, next:=Next} = Alg, R0}) -> + %% Generate a 56 bit number. + %% Ignore the weak low bits for these old algorithms, + %% just produce something reasonable. + %% + %% Be sure to use only 53 bits when multiplying with + %% math:pow(2.0, -N) to avoid rounding which would make + %% "even" floats more probable than "odd". + %% + {V1, R1} = Next(R0), + M1 = ?MASK(56, V1), + if + ?BIT(55) =< M1 -> + %% We have 56 bits - waste 3 + {(M1 bsr 3) * math:pow(2.0, -53), {Alg, R1}}; + ?BIT(54) =< M1 -> + %% We have 55 bits - waste 2 + {(M1 bsr 2) * math:pow(2.0, -54), {Alg, R1}}; + ?BIT(53) =< M1 -> + %% We have 54 bits - waste 1 + {(M1 bsr 1) * math:pow(2.0, -55), {Alg, R1}}; + ?BIT(52) =< M1 -> + %% We have 53 bits - use all + {M1 * math:pow(2.0, -56), {Alg, R1}}; + true -> + %% Need more bits + {V2, R2} = Next(R1), + uniform_real_s(Alg, Next, M1, -56, R2, V2, 56) + end. + +uniform_real_s(Alg, _Next, M0, -1064, R1, V1, Bits) -> % 19*56 + %% This is a very theoretical bottom case. + %% The odds of getting here is about 2^-1008, + %% through a white box test case, or thanks to + %% a malfunctioning PRNG producing 18 56-bit zeros in a row. + %% + %% Fill up to 53 bits, we have at most 52 + B0 = (53 - ?BC(M0, 52)), % Missing bits + {(((M0 bsl B0) bor (V1 bsr (Bits - B0))) * math:pow(2.0, -1064 - B0)), + {Alg, R1}}; +uniform_real_s(Alg, Next, M0, BitNo, R1, V1, Bits) -> + if + %% Optimize the most probable. + %% Fill up to 53 bits. + ?BIT(51) =< M0 -> + %% We have 52 bits in M0 - need 1 + {(((M0 bsl 1) bor (V1 bsr (Bits - 1))) + * math:pow(2.0, BitNo - 1)), + {Alg, R1}}; + ?BIT(50) =< M0 -> + %% We have 51 bits in M0 - need 2 + {(((M0 bsl 2) bor (V1 bsr (Bits - 2))) + * math:pow(2.0, BitNo - 2)), + {Alg, R1}}; + ?BIT(49) =< M0 -> + %% We have 50 bits in M0 - need 3 + {(((M0 bsl 3) bor (V1 bsr (Bits - 3))) + * math:pow(2.0, BitNo - 3)), + {Alg, R1}}; + M0 == 0 -> + M1 = V1 bsr (Bits - 56), + if + ?BIT(55) =< M1 -> + %% We have 56 bits - waste 3 + {(M1 bsr 3) * math:pow(2.0, BitNo - 53), {Alg, R1}}; + ?BIT(54) =< M1 -> + %% We have 55 bits - waste 2 + {(M1 bsr 2) * math:pow(2.0, BitNo - 54), {Alg, R1}}; + ?BIT(53) =< M1 -> + %% We have 54 bits - waste 1 + {(M1 bsr 1) * math:pow(2.0, BitNo - 55), {Alg, R1}}; + ?BIT(52) =< M1 -> + %% We have 53 bits - use all + {M1 * math:pow(2.0, BitNo - 56), {Alg, R1}}; + BitNo =:= -1008 -> + %% Endgame + %% For the last round we can not have 14 zeros or more + %% at the top of M1 because then we will underflow, + %% so we need at least 43 bits + if + ?BIT(42) =< M1 -> + %% We have 43 bits - get the last bits + uniform_real_s(Alg, Next, M1, BitNo - 56, R1); + true -> + %% Would underflow 2^-1022 - start all over + %% + %% We could just crash here since the odds for + %% the PRNG being broken is much higher than + %% for a good PRNG generating this many zeros + %% in a row. Maybe we should write an error + %% report or call this a system limit...? + uniform_real_s({Alg, R1}) + end; + true -> + %% Need more bits + uniform_real_s(Alg, Next, M1, BitNo - 56, R1) + end; + true -> + %% Fill up to 53 bits + B0 = 53 - ?BC(M0, 49), % Number of bits we need to append + {(((M0 bsl B0) bor (V1 bsr (Bits - B0))) + * math:pow(2.0, BitNo - B0)), + {Alg, R1}} + end. +%% +uniform_real_s(#{bits:=Bits} = Alg, Next, M0, BitNo, R0) -> + {V1, R1} = Next(R0), + uniform_real_s(Alg, Next, M0, BitNo, R1, V1, Bits); +uniform_real_s(#{max:=_} = Alg, Next, M0, BitNo, R0) -> + {V1, R1} = Next(R0), + uniform_real_s(Alg, Next, M0, BitNo, R1, ?MASK(56, V1), 56). + %% jump/1: given a state, jump/1 %% returns a new state which is equivalent to that %% after a large number of call defined for each algorithm. @@ -1025,3 +1219,42 @@ normal_fi(Indx) -> 1.0214971439701471e-02,8.6165827693987316e-03,7.0508754713732268e-03, 5.5224032992509968e-03,4.0379725933630305e-03,2.6090727461021627e-03, 1.2602859304985975e-03}). + +%%%bitcount64(0) -> 0; +%%%bitcount64(V) -> 1 + bitcount(V, 64). +%%% +%%%-define( +%%% BITCOUNT(V, N), +%%% bitcount(V, N) -> +%%% if +%%% (1 bsl ((N) bsr 1)) =< (V) -> +%%% ((N) bsr 1) + bitcount((V) bsr ((N) bsr 1), ((N) bsr 1)); +%%% true -> +%%% bitcount((V), ((N) bsr 1)) +%%% end). +%%%?BITCOUNT(V, 64); +%%%?BITCOUNT(V, 32); +%%%?BITCOUNT(V, 16); +%%%?BITCOUNT(V, 8); +%%%?BITCOUNT(V, 4); +%%%?BITCOUNT(V, 2); +%%%bitcount(_, 1) -> 0. + +bc64(V) -> ?BC(V, 64). + +%% Linear from high bit - higher probability first gives faster execution +bc(V, B, N) when B =< V -> N; +bc(V, B, N) -> bc(V, B bsr 1, N - 1). + +make_float(S, E, M) -> + <<F/float>> = <<S:1, E:11, M:52>>, + F. + +float2str(N) -> + <<S:1, E:11, M:52>> = <<(float(N))/float>>, + lists:flatten( + io_lib:format( + "~c~c.~13.16.0bE~b", + [case S of 1 -> $-; 0 -> $+ end, + case E of 0 -> $0; _ -> $1 end, + M, E - 16#3ff])). diff --git a/lib/stdlib/src/sets.erl b/lib/stdlib/src/sets.erl index c65a13b22e..ac0fc80526 100644 --- a/lib/stdlib/src/sets.erl +++ b/lib/stdlib/src/sets.erl @@ -37,7 +37,7 @@ -module(sets). %% Standard interface. --export([new/0,is_set/1,size/1,to_list/1,from_list/1]). +-export([new/0,is_set/1,size/1,is_empty/1,to_list/1,from_list/1]). -export([is_element/2,add_element/2,del_element/2]). -export([union/2,union/1,intersection/2,intersection/1]). -export([is_disjoint/2]). @@ -96,6 +96,12 @@ is_set(_) -> false. Set :: set(). size(S) -> S#set.size. +%% is_empty(Set) -> boolean(). +%% Return 'true' if Set is an empty set, otherwise 'false'. +-spec is_empty(Set) -> boolean() when + Set :: set(). +is_empty(S) -> S#set.size=:=0. + %% to_list(Set) -> [Elem]. %% Return the elements in Set as a list. -spec to_list(Set) -> List when diff --git a/lib/stdlib/src/shell.erl b/lib/stdlib/src/shell.erl index ad4984b64c..1be37672e7 100644 --- a/lib/stdlib/src/shell.erl +++ b/lib/stdlib/src/shell.erl @@ -645,8 +645,7 @@ eval_exprs(Es, Shell, Bs0, RT, Lf, Ef, W) -> catch exit:normal -> exit(normal); - Class:Reason -> - Stacktrace = erlang:get_stacktrace(), + Class:Reason:Stacktrace -> M = {self(),Class,{Reason,Stacktrace}}, case do_catch(Class, Reason) of true -> @@ -807,8 +806,8 @@ restrict_handlers(RShMod, Shell, RT) -> -define(BAD_RETURN(M, F, V), try erlang:error(reason) - catch _:_ -> erlang:raise(exit, {restricted_shell_bad_return,V}, - [{M,F,3} | erlang:get_stacktrace()]) + catch _:_:S -> erlang:raise(exit, {restricted_shell_bad_return,V}, + [{M,F,3} | S]) end). local_allowed(F, As, RShMod, Bs, Shell, RT) when is_atom(F) -> @@ -1417,7 +1416,7 @@ pp(V, I, D, RT) -> true end, io_lib_pretty:print(V, ([{column, I}, {line_length, columns()}, - {depth, D}, {max_chars, ?CHAR_MAX}, + {depth, D}, {line_max_chars, ?CHAR_MAX}, {strings, Strings}, {record_print_fun, record_print_fun(RT)}] ++ enc())). diff --git a/lib/stdlib/src/slave.erl b/lib/stdlib/src/slave.erl index d7cf6386f5..b3f3206d67 100644 --- a/lib/stdlib/src/slave.erl +++ b/lib/stdlib/src/slave.erl @@ -320,7 +320,7 @@ mk_cmd(Host, Name, Args, Waiter, Prog0) -> %% emulator and flags as the test node. The return from lib:progname() %% could then typically be '/<full_path_to>/cerl -gcov'). quote_progname(Progname) -> - do_quote_progname(string:tokens(to_list(Progname)," ")). + do_quote_progname(string:lexemes(to_list(Progname)," ")). do_quote_progname([Prog]) -> "\""++Prog++"\""; diff --git a/lib/stdlib/src/stdlib.app.src b/lib/stdlib/src/stdlib.app.src index 3c449d3cb9..5fb48acfab 100644 --- a/lib/stdlib/src/stdlib.app.src +++ b/lib/stdlib/src/stdlib.app.src @@ -101,13 +101,14 @@ timer, unicode, unicode_util, + uri_string, win32reg, zip]}, {registered,[timer_server,rsh_starter,take_over_monitor,pool_master, dets]}, {applications, [kernel]}, {env, []}, - {runtime_dependencies, ["sasl-3.0","kernel-5.0","erts-9.0","crypto-3.3", + {runtime_dependencies, ["sasl-3.0","kernel-6.0","erts-10.0","crypto-3.3", "compiler-5.0"]} ]}. diff --git a/lib/stdlib/src/stdlib.appup.src b/lib/stdlib/src/stdlib.appup.src index 800c2c61f3..e4e3fb83e9 100644 --- a/lib/stdlib/src/stdlib.appup.src +++ b/lib/stdlib/src/stdlib.appup.src @@ -18,9 +18,7 @@ %% %CopyrightEnd% {"%VSN%", %% Up from - max one major revision back - [{<<"3\\.[0-3](\\.[0-9]+)*">>,[restart_new_emulator]}, % OTP-19.* - {<<"3\\.4(\\.[0-9]+)*">>,[restart_new_emulator]}], % OTP-20.* + [{<<"3\\.4(\\.[0-9]+)*">>,[restart_new_emulator]}], % OTP-20.* %% Down to - max one major revision back - [{<<"3\\.[0-3](\\.[0-9]+)*">>,[restart_new_emulator]}, % OTP-19.* - {<<"3\\.4(\\.[0-9]+)*">>,[restart_new_emulator]}] % OTP-20.* + [{<<"3\\.4(\\.[0-9]+)*">>,[restart_new_emulator]}] % OTP-20.* }. diff --git a/lib/stdlib/src/string.erl b/lib/stdlib/src/string.erl index 6f5e617230..0736374f21 100644 --- a/lib/stdlib/src/string.erl +++ b/lib/stdlib/src/string.erl @@ -88,7 +88,6 @@ %%% May be removed -export([list_to_float/1, list_to_integer/1]). - %% Uses bifs: string:list_to_float/1 and string:list_to_integer/1 -spec list_to_float(String) -> {Float, Rest} | {'error', Reason} when String :: string(), diff --git a/lib/stdlib/src/supervisor.erl b/lib/stdlib/src/supervisor.erl index 7920e55930..e56415650f 100644 --- a/lib/stdlib/src/supervisor.erl +++ b/lib/stdlib/src/supervisor.erl @@ -31,7 +31,6 @@ %% Internal exports -export([init/1, handle_call/3, handle_cast/2, handle_info/2, terminate/2, code_change/3, format_status/2]). --export([try_again_restart/2]). %% For release_handler only -export([get_callback_module/1]). @@ -79,6 +78,7 @@ | {RestartStrategy :: strategy(), Intensity :: non_neg_integer(), Period :: pos_integer()}. +-type children() :: {Ids :: [child_id()], Db :: #{child_id() => child_rec()}}. %%-------------------------------------------------------------------------- %% Defaults @@ -96,7 +96,7 @@ pid = undefined :: child() | {restarting, pid() | undefined} | [pid()], - name :: child_id(), + id :: child_id(), mfargs :: mfargs(), restart_type :: restart(), shutdown :: shutdown(), @@ -104,16 +104,11 @@ modules = [] :: modules()}). -type child_rec() :: #child{}. --define(DICTS, dict). --define(DICT, dict:dict). --define(SETS, sets). --define(SET, sets:set). - -record(state, {name, strategy :: strategy() | 'undefined', - children = [] :: [child_rec()], - dynamics :: {'dict', ?DICT(pid(), list())} - | {'set', ?SET(pid())} + children = {[],#{}} :: children(), % Ids in start order + dynamics :: {'maps', #{pid() => list()}} + | {'sets', sets:set(pid())} | 'undefined', intensity :: non_neg_integer() | 'undefined', period :: pos_integer() | 'undefined', @@ -124,6 +119,9 @@ -type state() :: #state{}. -define(is_simple(State), State#state.strategy =:= simple_one_for_one). +-define(is_temporary(_Child_), _Child_#child.restart_type=:=temporary). +-define(is_transient(_Child_), _Child_#child.restart_type=:=transient). +-define(is_permanent(_Child_), _Child_#child.restart_type=:=permanent). -callback init(Args :: term()) -> {ok, {SupFlags :: sup_flags(), [ChildSpec :: child_spec()]}} @@ -179,16 +177,16 @@ start_child(Supervisor, ChildSpec) -> | {'error', Error}, Error :: 'running' | 'restarting' | 'not_found' | 'simple_one_for_one' | term(). -restart_child(Supervisor, Name) -> - call(Supervisor, {restart_child, Name}). +restart_child(Supervisor, Id) -> + call(Supervisor, {restart_child, Id}). -spec delete_child(SupRef, Id) -> Result when SupRef :: sup_ref(), Id :: child_id(), Result :: 'ok' | {'error', Error}, Error :: 'running' | 'restarting' | 'not_found' | 'simple_one_for_one'. -delete_child(Supervisor, Name) -> - call(Supervisor, {delete_child, Name}). +delete_child(Supervisor, Id) -> + call(Supervisor, {delete_child, Id}). %%----------------------------------------------------------------- %% Func: terminate_child/2 @@ -202,16 +200,16 @@ delete_child(Supervisor, Name) -> Id :: pid() | child_id(), Result :: 'ok' | {'error', Error}, Error :: 'not_found' | 'simple_one_for_one'. -terminate_child(Supervisor, Name) -> - call(Supervisor, {terminate_child, Name}). +terminate_child(Supervisor, Id) -> + call(Supervisor, {terminate_child, Id}). -spec get_childspec(SupRef, Id) -> Result when SupRef :: sup_ref(), Id :: pid() | child_id(), Result :: {'ok', child_spec()} | {'error', Error}, Error :: 'not_found'. -get_childspec(Supervisor, Name) -> - call(Supervisor, {get_childspec, Name}). +get_childspec(Supervisor, Id) -> + call(Supervisor, {get_childspec, Id}). -spec which_children(SupRef) -> [{Id,Child,Type,Modules}] when SupRef :: sup_ref(), @@ -246,17 +244,6 @@ check_childspecs(ChildSpecs) when is_list(ChildSpecs) -> check_childspecs(X) -> {error, {badarg, X}}. %%%----------------------------------------------------------------- -%%% Called by restart/2 --spec try_again_restart(SupRef, Child) -> ok when - SupRef :: sup_ref(), - Child :: child_id() | pid(). -try_again_restart(Supervisor, Child) -> - cast(Supervisor, {try_again_restart, Child}). - -cast(Supervisor, Req) -> - gen_server:cast(Supervisor, Req). - -%%%----------------------------------------------------------------- %%% Called by release_handler during upgrade -spec get_callback_module(Pid) -> Module when Pid :: pid(), @@ -325,7 +312,7 @@ init_children(State, StartSpec) -> init_dynamic(State, [StartSpec]) -> case check_startspec([StartSpec]) of {ok, Children} -> - {ok, State#state{children = Children}}; + {ok, dyn_init(State#state{children = Children})}; Error -> {stop, {start_spec, Error}} end; @@ -334,35 +321,34 @@ init_dynamic(_State, StartSpec) -> %%----------------------------------------------------------------- %% Func: start_children/2 -%% Args: Children = [child_rec()] in start order +%% Args: Children = children() % Ids in start order %% SupName = {local, atom()} | {global, atom()} | {pid(), Mod} -%% Purpose: Start all children. The new list contains #child's +%% Purpose: Start all children. The new map contains #child's %% with pids. %% Returns: {ok, NChildren} | {error, NChildren, Reason} -%% NChildren = [child_rec()] in termination order (reversed -%% start order) +%% NChildren = children() % Ids in termination order +%% (reversed start order) %%----------------------------------------------------------------- -start_children(Children, SupName) -> start_children(Children, [], SupName). - -start_children([Child|Chs], NChildren, SupName) -> - case do_start_child(SupName, Child) of - {ok, undefined} when Child#child.restart_type =:= temporary -> - start_children(Chs, NChildren, SupName); - {ok, Pid} -> - start_children(Chs, [Child#child{pid = Pid}|NChildren], SupName); - {ok, Pid, _Extra} -> - start_children(Chs, [Child#child{pid = Pid}|NChildren], SupName); - {error, Reason} -> - report_error(start_error, Reason, Child, SupName), - {error, lists:reverse(Chs) ++ [Child | NChildren], - {failed_to_start_child,Child#child.name,Reason}} - end; -start_children([], NChildren, _SupName) -> - {ok, NChildren}. +start_children(Children, SupName) -> + Start = + fun(Id,Child) -> + case do_start_child(SupName, Child) of + {ok, undefined} when ?is_temporary(Child) -> + remove; + {ok, Pid} -> + {update,Child#child{pid = Pid}}; + {ok, Pid, _Extra} -> + {update,Child#child{pid = Pid}}; + {error, Reason} -> + report_error(start_error, Reason, Child, SupName), + {abort,{failed_to_start_child,Id,Reason}} + end + end, + children_map(Start,Children). do_start_child(SupName, Child) -> #child{mfargs = {M, F, Args}} = Child, - case catch apply(M, F, Args) of + case do_start_child_i(M, F, Args) of {ok, Pid} when is_pid(Pid) -> NChild = Child#child{pid = Pid}, report_progress(NChild, SupName), @@ -371,10 +357,8 @@ do_start_child(SupName, Child) -> NChild = Child#child{pid = Pid}, report_progress(NChild, SupName), {ok, Pid, Extra}; - ignore -> - {ok, undefined}; - {error, What} -> {error, What}; - What -> {error, What} + Other -> + Other end. do_start_child_i(M, F, A) -> @@ -400,17 +384,17 @@ do_start_child_i(M, F, A) -> -spec handle_call(call(), term(), state()) -> {'reply', term(), state()}. handle_call({start_child, EArgs}, _From, State) when ?is_simple(State) -> - Child = hd(State#state.children), + Child = get_dynamic_child(State), #child{mfargs = {M, F, A}} = Child, Args = A ++ EArgs, case do_start_child_i(M, F, Args) of {ok, undefined} -> {reply, {ok, undefined}, State}; {ok, Pid} -> - NState = save_dynamic_child(Child#child.restart_type, Pid, Args, State), + NState = dyn_store(Pid, Args, State), {reply, {ok, Pid}, NState}; {ok, Pid, Extra} -> - NState = save_dynamic_child(Child#child.restart_type, Pid, Args, State), + NState = dyn_store(Pid, Args, State), {reply, {ok, Pid, Extra}, NState}; What -> {reply, What, State} @@ -426,121 +410,94 @@ handle_call({start_child, ChildSpec}, _From, State) -> end; %% terminate_child for simple_one_for_one can only be done with pid -handle_call({terminate_child, Name}, _From, State) when not is_pid(Name), - ?is_simple(State) -> +handle_call({terminate_child, Id}, _From, State) when not is_pid(Id), + ?is_simple(State) -> {reply, {error, simple_one_for_one}, State}; -handle_call({terminate_child, Name}, _From, State) -> - case get_child(Name, State, ?is_simple(State)) of - {value, Child} -> - case do_terminate(Child, State#state.name) of - #child{restart_type=RT} when RT=:=temporary; ?is_simple(State) -> - {reply, ok, state_del_child(Child, State)}; - NChild -> - {reply, ok, replace_child(NChild, State)} - end; - false -> +handle_call({terminate_child, Id}, _From, State) -> + case find_child(Id, State) of + {ok, Child} -> + do_terminate(Child, State#state.name), + {reply, ok, del_child(Child, State)}; + error -> {reply, {error, not_found}, State} end; %% restart_child request is invalid for simple_one_for_one supervisors -handle_call({restart_child, _Name}, _From, State) when ?is_simple(State) -> +handle_call({restart_child, _Id}, _From, State) when ?is_simple(State) -> {reply, {error, simple_one_for_one}, State}; -handle_call({restart_child, Name}, _From, State) -> - case get_child(Name, State) of - {value, Child} when Child#child.pid =:= undefined -> +handle_call({restart_child, Id}, _From, State) -> + case find_child(Id, State) of + {ok, Child} when Child#child.pid =:= undefined -> case do_start_child(State#state.name, Child) of {ok, Pid} -> - NState = replace_child(Child#child{pid = Pid}, State), + NState = set_pid(Pid, Id, State), {reply, {ok, Pid}, NState}; {ok, Pid, Extra} -> - NState = replace_child(Child#child{pid = Pid}, State), + NState = set_pid(Pid, Id, State), {reply, {ok, Pid, Extra}, NState}; Error -> {reply, Error, State} end; - {value, #child{pid=?restarting(_)}} -> + {ok, #child{pid=?restarting(_)}} -> {reply, {error, restarting}, State}; - {value, _} -> + {ok, _} -> {reply, {error, running}, State}; _ -> {reply, {error, not_found}, State} end; %% delete_child request is invalid for simple_one_for_one supervisors -handle_call({delete_child, _Name}, _From, State) when ?is_simple(State) -> +handle_call({delete_child, _Id}, _From, State) when ?is_simple(State) -> {reply, {error, simple_one_for_one}, State}; -handle_call({delete_child, Name}, _From, State) -> - case get_child(Name, State) of - {value, Child} when Child#child.pid =:= undefined -> - NState = remove_child(Child, State), +handle_call({delete_child, Id}, _From, State) -> + case find_child(Id, State) of + {ok, Child} when Child#child.pid =:= undefined -> + NState = remove_child(Id, State), {reply, ok, NState}; - {value, #child{pid=?restarting(_)}} -> + {ok, #child{pid=?restarting(_)}} -> {reply, {error, restarting}, State}; - {value, _} -> + {ok, _} -> {reply, {error, running}, State}; _ -> {reply, {error, not_found}, State} end; -handle_call({get_childspec, Name}, _From, State) -> - case get_child(Name, State, ?is_simple(State)) of - {value, Child} -> +handle_call({get_childspec, Id}, _From, State) -> + case find_child(Id, State) of + {ok, Child} -> {reply, {ok, child_to_spec(Child)}, State}; - false -> + error -> {reply, {error, not_found}, State} end; -handle_call(which_children, _From, #state{children = [#child{restart_type = temporary, - child_type = CT, - modules = Mods}]} = - State) when ?is_simple(State) -> - Reply = lists:map(fun(Pid) -> {undefined, Pid, CT, Mods} end, - ?SETS:to_list(dynamics_db(temporary, State#state.dynamics))), - {reply, Reply, State}; - -handle_call(which_children, _From, #state{children = [#child{restart_type = RType, - child_type = CT, - modules = Mods}]} = - State) when ?is_simple(State) -> - Reply = lists:map(fun({?restarting(_),_}) -> {undefined,restarting,CT,Mods}; - ({Pid, _}) -> {undefined, Pid, CT, Mods} end, - ?DICTS:to_list(dynamics_db(RType, State#state.dynamics))), +handle_call(which_children, _From, State) when ?is_simple(State) -> + #child{child_type = CT,modules = Mods} = get_dynamic_child(State), + Reply = dyn_map(fun(?restarting(_)) -> {undefined, restarting, CT, Mods}; + (Pid) -> {undefined, Pid, CT, Mods} + end, State), {reply, Reply, State}; handle_call(which_children, _From, State) -> Resp = - lists:map(fun(#child{pid = ?restarting(_), name = Name, - child_type = ChildType, modules = Mods}) -> - {Name, restarting, ChildType, Mods}; - (#child{pid = Pid, name = Name, - child_type = ChildType, modules = Mods}) -> - {Name, Pid, ChildType, Mods} - end, - State#state.children), + children_to_list( + fun(Id,#child{pid = ?restarting(_), + child_type = ChildType, modules = Mods}) -> + {Id, restarting, ChildType, Mods}; + (Id,#child{pid = Pid, + child_type = ChildType, modules = Mods}) -> + {Id, Pid, ChildType, Mods} + end, + State#state.children), {reply, Resp, State}; - -handle_call(count_children, _From, #state{children = [#child{restart_type = temporary, - child_type = CT}]} = State) - when ?is_simple(State) -> - Sz = ?SETS:size(dynamics_db(temporary, State#state.dynamics)), - Reply = case CT of - supervisor -> [{specs, 1}, {active, Sz}, - {supervisors, Sz}, {workers, 0}]; - worker -> [{specs, 1}, {active, Sz}, - {supervisors, 0}, {workers, Sz}] - end, - {reply, Reply, State}; - -handle_call(count_children, _From, #state{dynamic_restarts = Restarts, - children = [#child{restart_type = RType, - child_type = CT}]} = State) +handle_call(count_children, _From, #state{dynamic_restarts = Restarts} = State) when ?is_simple(State) -> - Sz = ?DICTS:size(dynamics_db(RType, State#state.dynamics)), - Active = Sz - Restarts, + #child{child_type = CT} = get_dynamic_child(State), + Sz = dyn_size(State), + Active = Sz - Restarts, % Restarts is always 0 for temporary children Reply = case CT of supervisor -> [{specs, 1}, {active, Active}, {supervisors, Sz}, {workers, 0}]; @@ -552,16 +509,15 @@ handle_call(count_children, _From, #state{dynamic_restarts = Restarts, handle_call(count_children, _From, State) -> %% Specs and children are together on the children list... {Specs, Active, Supers, Workers} = - lists:foldl(fun(Child, Counts) -> - count_child(Child, Counts) - end, {0,0,0,0}, State#state.children), + children_fold(fun(_Id, Child, Counts) -> + count_child(Child, Counts) + end, {0,0,0,0}, State#state.children), %% Reformat counts to a property list. Reply = [{specs, Specs}, {active, Active}, {supervisors, Supers}, {workers, Workers}], {reply, Reply, State}. - count_child(#child{pid = Pid, child_type = worker}, {Specs, Active, Supers, Workers}) -> case is_pid(Pid) andalso is_process_alive(Pid) of @@ -575,34 +531,15 @@ count_child(#child{pid = Pid, child_type = supervisor}, false -> {Specs+1, Active, Supers+1, Workers} end. - %%% If a restart attempt failed, this message is cast %%% from restart/2 in order to give gen_server the chance to %%% check it's inbox before trying again. --spec handle_cast({try_again_restart, child_id() | pid()}, state()) -> +-spec handle_cast({try_again_restart, child_id() | {'restarting',pid()}}, state()) -> {'noreply', state()} | {stop, shutdown, state()}. -handle_cast({try_again_restart,Pid}, #state{children=[Child]}=State) - when ?is_simple(State) -> - RT = Child#child.restart_type, - RPid = restarting(Pid), - case dynamic_child_args(RPid, RT, State#state.dynamics) of - {ok, Args} -> - {M, F, _} = Child#child.mfargs, - NChild = Child#child{pid = RPid, mfargs = {M, F, Args}}, - case restart(NChild,State) of - {ok, State1} -> - {noreply, State1}; - {shutdown, State1} -> - {stop, shutdown, State1} - end; - error -> - {noreply, State} - end; - -handle_cast({try_again_restart,Name}, State) -> - case lists:keyfind(Name,#child.name,State#state.children) of - Child = #child{pid=?restarting(_)} -> +handle_cast({try_again_restart,TryAgainId}, State) -> + case find_child_and_args(TryAgainId, State) of + {ok, Child = #child{pid=?restarting(_)}} -> case restart(Child,State) of {ok, State1} -> {noreply, State1}; @@ -637,10 +574,8 @@ handle_info(Msg, State) -> %% -spec terminate(term(), state()) -> 'ok'. -terminate(_Reason, #state{children=[Child]} = State) when ?is_simple(State) -> - terminate_dynamic_children(Child, dynamics_db(Child#child.restart_type, - State#state.dynamics), - State#state.name); +terminate(_Reason, State) when ?is_simple(State) -> + terminate_dynamic_children(State); terminate(_Reason, State) -> terminate_children(State#state.children, State#state.name). @@ -675,8 +610,8 @@ code_change(_, State, _) -> update_childspec(State, StartSpec) when ?is_simple(State) -> case check_startspec(StartSpec) of - {ok, [Child]} -> - {ok, State#state{children = [Child]}}; + {ok, {[_],_}=Children} -> + {ok, State#state{children = Children}}; Error -> {error, Error} end; @@ -690,39 +625,36 @@ update_childspec(State, StartSpec) -> {error, Error} end. -update_childspec1([Child|OldC], Children, KeepOld) -> - case update_chsp(Child, Children) of - {ok,NewChildren} -> - update_childspec1(OldC, NewChildren, KeepOld); +update_childspec1({[Id|OldIds], OldDb}, {Ids,Db}, KeepOld) -> + case update_chsp(maps:get(Id,OldDb), Db) of + {ok,NewDb} -> + update_childspec1({OldIds,OldDb}, {Ids,NewDb}, KeepOld); false -> - update_childspec1(OldC, Children, [Child|KeepOld]) + update_childspec1({OldIds,OldDb}, {Ids,Db}, [Id|KeepOld]) end; -update_childspec1([], Children, KeepOld) -> +update_childspec1({[],OldDb}, {Ids,Db}, KeepOld) -> + KeepOldDb = maps:with(KeepOld,OldDb), %% Return them in (kept) reverse start order. - lists:reverse(Children ++ KeepOld). - -update_chsp(OldCh, Children) -> - case lists:map(fun(Ch) when OldCh#child.name =:= Ch#child.name -> - Ch#child{pid = OldCh#child.pid}; - (Ch) -> - Ch - end, - Children) of - Children -> - false; % OldCh not found in new spec. - NewC -> - {ok, NewC} + {lists:reverse(Ids ++ KeepOld),maps:merge(KeepOldDb,Db)}. + +update_chsp(#child{id=Id}=OldChild, NewDb) -> + case maps:find(Id, NewDb) of + {ok,Child} -> + {ok,NewDb#{Id => Child#child{pid = OldChild#child.pid}}}; + error -> % Id not found in new spec. + false end. + %%% --------------------------------------------------- %%% Start a new child. %%% --------------------------------------------------- handle_start_child(Child, State) -> - case get_child(Child#child.name, State) of - false -> + case find_child(Child#child.id, State) of + error -> case do_start_child(State#state.name, Child) of - {ok, undefined} when Child#child.restart_type =:= temporary -> + {ok, undefined} when ?is_temporary(Child) -> {{ok, undefined}, State}; {ok, Pid} -> {{ok, Pid}, save_child(Child#child{pid = Pid}, State)}; @@ -731,9 +663,9 @@ handle_start_child(Child, State) -> {error, What} -> {{error, {What, Child}}, State} end; - {value, OldChild} when is_pid(OldChild#child.pid) -> + {ok, OldChild} when is_pid(OldChild#child.pid) -> {{error, {already_started, OldChild#child.pid}}, State}; - {value, _OldChild} -> + {ok, _OldChild} -> {{error, already_present}, State} end. @@ -742,63 +674,45 @@ handle_start_child(Child, State) -> %%% Returns: {ok, state()} | {shutdown, state()} %%% --------------------------------------------------- -restart_child(Pid, Reason, #state{children = [Child]} = State) when ?is_simple(State) -> - RestartType = Child#child.restart_type, - case dynamic_child_args(Pid, RestartType, State#state.dynamics) of - {ok, Args} -> - {M, F, _} = Child#child.mfargs, - NChild = Child#child{pid = Pid, mfargs = {M, F, Args}}, - do_restart(RestartType, Reason, NChild, State); - error -> - {ok, State} - end; - restart_child(Pid, Reason, State) -> - Children = State#state.children, - case lists:keyfind(Pid, #child.pid, Children) of - #child{restart_type = RestartType} = Child -> - do_restart(RestartType, Reason, Child, State); - false -> + case find_child_and_args(Pid, State) of + {ok, Child} -> + do_restart(Reason, Child, State); + error -> {ok, State} end. -do_restart(permanent, Reason, Child, State) -> +do_restart(Reason, Child, State) when ?is_permanent(Child) -> report_error(child_terminated, Reason, Child, State#state.name), restart(Child, State); -do_restart(_, normal, Child, State) -> - NState = state_del_child(Child, State), +do_restart(normal, Child, State) -> + NState = del_child(Child, State), {ok, NState}; -do_restart(_, shutdown, Child, State) -> - NState = state_del_child(Child, State), +do_restart(shutdown, Child, State) -> + NState = del_child(Child, State), {ok, NState}; -do_restart(_, {shutdown, _Term}, Child, State) -> - NState = state_del_child(Child, State), +do_restart({shutdown, _Term}, Child, State) -> + NState = del_child(Child, State), {ok, NState}; -do_restart(transient, Reason, Child, State) -> +do_restart(Reason, Child, State) when ?is_transient(Child) -> report_error(child_terminated, Reason, Child, State#state.name), restart(Child, State); -do_restart(temporary, Reason, Child, State) -> +do_restart(Reason, Child, State) when ?is_temporary(Child) -> report_error(child_terminated, Reason, Child, State#state.name), - NState = state_del_child(Child, State), + NState = del_child(Child, State), {ok, NState}. restart(Child, State) -> case add_restart(State) of {ok, NState} -> case restart(NState#state.strategy, Child, NState) of - {try_again,NState2} -> + {{try_again, TryAgainId}, NState2} -> %% Leaving control back to gen_server before %% trying again. This way other incoming requsts %% for the supervisor can be handled - e.g. a %% shutdown request for the supervisor or the %% child. - Id = if ?is_simple(State) -> Child#child.pid; - true -> Child#child.name - end, - ok = try_again_restart(self(), Id), - {ok,NState2}; - {try_again, NState2, #child{name=ChName}} -> - ok = try_again_restart(self(), ChName), + try_again_restart(TryAgainId), {ok,NState2}; Other -> Other @@ -806,124 +720,111 @@ restart(Child, State) -> {terminate, NState} -> report_error(shutdown, reached_max_restart_intensity, Child, State#state.name), - {shutdown, remove_child(Child, NState)} + {shutdown, del_child(Child, NState)} end. restart(simple_one_for_one, Child, State0) -> #child{pid = OldPid, mfargs = {M, F, A}} = Child, - State = case OldPid of + State1 = case OldPid of ?restarting(_) -> NRes = State0#state.dynamic_restarts - 1, State0#state{dynamic_restarts = NRes}; _ -> State0 end, - Dynamics = ?DICTS:erase(OldPid, dynamics_db(Child#child.restart_type, - State#state.dynamics)), + State2 = dyn_erase(OldPid, State1), case do_start_child_i(M, F, A) of {ok, Pid} -> - DynamicsDb = {dict, ?DICTS:store(Pid, A, Dynamics)}, - NState = State#state{dynamics = DynamicsDb}, + NState = dyn_store(Pid, A, State2), {ok, NState}; {ok, Pid, _Extra} -> - DynamicsDb = {dict, ?DICTS:store(Pid, A, Dynamics)}, - NState = State#state{dynamics = DynamicsDb}, + NState = dyn_store(Pid, A, State2), {ok, NState}; {error, Error} -> - NRestarts = State#state.dynamic_restarts + 1, - DynamicsDb = {dict, ?DICTS:store(restarting(OldPid), A, Dynamics)}, - NState = State#state{dynamic_restarts = NRestarts, - dynamics = DynamicsDb}, - report_error(start_error, Error, Child, State#state.name), - {try_again, NState} + ROldPid = restarting(OldPid), + NRestarts = State2#state.dynamic_restarts + 1, + State3 = State2#state{dynamic_restarts = NRestarts}, + NState = dyn_store(ROldPid, A, State3), + report_error(start_error, Error, Child, NState#state.name), + {{try_again, ROldPid}, NState} end; -restart(one_for_one, Child, State) -> +restart(one_for_one, #child{id=Id} = Child, State) -> OldPid = Child#child.pid, case do_start_child(State#state.name, Child) of {ok, Pid} -> - NState = replace_child(Child#child{pid = Pid}, State), + NState = set_pid(Pid, Id, State), {ok, NState}; {ok, Pid, _Extra} -> - NState = replace_child(Child#child{pid = Pid}, State), + NState = set_pid(Pid, Id, State), {ok, NState}; {error, Reason} -> - NState = replace_child(Child#child{pid = restarting(OldPid)}, State), + NState = set_pid(restarting(OldPid), Id, State), report_error(start_error, Reason, Child, State#state.name), - {try_again, NState} - end; -restart(rest_for_one, Child, State) -> - {ChAfter, ChBefore} = split_child(Child#child.pid, State#state.children), - ChAfter2 = terminate_children(ChAfter, State#state.name), - case start_children(ChAfter2, State#state.name) of - {ok, ChAfter3} -> - {ok, State#state{children = ChAfter3 ++ ChBefore}}; - {error, ChAfter3, {failed_to_start_child, ChName, _Reason}} - when ChName =:= Child#child.name -> - NChild = Child#child{pid=restarting(Child#child.pid)}, - NState = State#state{children = ChAfter3 ++ ChBefore}, - {try_again, replace_child(NChild,NState)}; - {error, ChAfter3, {failed_to_start_child, ChName, _Reason}} -> - NChild = lists:keyfind(ChName, #child.name, ChAfter3), - NChild2 = NChild#child{pid=?restarting(undefined)}, - NState = State#state{children = ChAfter3 ++ ChBefore}, - {try_again, replace_child(NChild2,NState), NChild2} + {{try_again,Id}, NState} end; -restart(one_for_all, Child, State) -> - Children1 = del_child(Child#child.pid, State#state.children), - Children2 = terminate_children(Children1, State#state.name), - case start_children(Children2, State#state.name) of - {ok, NChs} -> - {ok, State#state{children = NChs}}; - {error, NChs, {failed_to_start_child, ChName, _Reason}} - when ChName =:= Child#child.name -> - NChild = Child#child{pid=restarting(Child#child.pid)}, - NState = State#state{children = NChs}, - {try_again, replace_child(NChild,NState)}; - {error, NChs, {failed_to_start_child, ChName, _Reason}} -> - NChild = lists:keyfind(ChName, #child.name, NChs), - NChild2 = NChild#child{pid=?restarting(undefined)}, - NState = State#state{children = NChs}, - {try_again, replace_child(NChild2,NState), NChild2} +restart(rest_for_one, #child{id=Id} = Child, #state{name=SupName} = State) -> + {ChAfter, ChBefore} = split_child(Id, State#state.children), + {Return, ChAfter2} = restart_multiple_children(Child, ChAfter, SupName), + {Return, State#state{children = append(ChAfter2,ChBefore)}}; +restart(one_for_all, Child, #state{name=SupName} = State) -> + Children1 = del_child(Child#child.id, State#state.children), + {Return, NChildren} = restart_multiple_children(Child, Children1, SupName), + {Return, State#state{children = NChildren}}. + +restart_multiple_children(Child, Children, SupName) -> + Children1 = terminate_children(Children, SupName), + case start_children(Children1, SupName) of + {ok, NChildren} -> + {ok, NChildren}; + {error, NChildren, {failed_to_start_child, FailedId, _Reason}} -> + NewPid = if FailedId =:= Child#child.id -> + restarting(Child#child.pid); + true -> + ?restarting(undefined) + end, + {{try_again, FailedId}, set_pid(NewPid,FailedId,NChildren)} end. restarting(Pid) when is_pid(Pid) -> ?restarting(Pid); restarting(RPid) -> RPid. +-spec try_again_restart(child_id() | {'restarting',pid()}) -> 'ok'. +try_again_restart(TryAgainId) -> + gen_server:cast(self(), {try_again_restart, TryAgainId}). + %%----------------------------------------------------------------- %% Func: terminate_children/2 -%% Args: Children = [child_rec()] in termination order +%% Args: Children = children() % Ids in termination order %% SupName = {local, atom()} | {global, atom()} | {pid(),Mod} -%% Returns: NChildren = [child_rec()] in -%% startup order (reversed termination order) +%% Returns: NChildren = children() % Ids in startup order +%% % (reversed termination order) %%----------------------------------------------------------------- terminate_children(Children, SupName) -> - terminate_children(Children, SupName, []). - -%% Temporary children should not be restarted and thus should -%% be skipped when building the list of terminated children, although -%% we do want them to be shut down as many functions from this module -%% use this function to just clear everything. -terminate_children([Child = #child{restart_type=temporary} | Children], SupName, Res) -> - _ = do_terminate(Child, SupName), - terminate_children(Children, SupName, Res); -terminate_children([Child | Children], SupName, Res) -> - NChild = do_terminate(Child, SupName), - terminate_children(Children, SupName, [NChild | Res]); -terminate_children([], _SupName, Res) -> - Res. + Terminate = + fun(_Id,Child) when ?is_temporary(Child) -> + %% Temporary children should not be restarted and thus should + %% be skipped when building the list of terminated children. + do_terminate(Child, SupName), + remove; + (_Id,Child) -> + do_terminate(Child, SupName), + {update,Child#child{pid=undefined}} + end, + {ok,NChildren} = children_map(Terminate, Children), + NChildren. do_terminate(Child, SupName) when is_pid(Child#child.pid) -> case shutdown(Child#child.pid, Child#child.shutdown) of ok -> ok; - {error, normal} when Child#child.restart_type =/= permanent -> + {error, normal} when not (?is_permanent(Child)) -> ok; {error, OtherReason} -> report_error(shutdown_error, OtherReason, Child, SupName) end, - Child#child{pid = undefined}; -do_terminate(Child, _SupName) -> - Child#child{pid = undefined}. + ok; +do_terminate(_Child, _SupName) -> + ok. %%----------------------------------------------------------------- %% Shutdowns a child. We must check the EXIT value @@ -996,66 +897,50 @@ monitor_child(Pid) -> ok end. - %%----------------------------------------------------------------- -%% Func: terminate_dynamic_children/3 -%% Args: Child = child_rec() -%% Dynamics = ?DICT() | ?SET() -%% SupName = {local, atom()} | {global, atom()} | {pid(),Mod} +%% Func: terminate_dynamic_children/1 +%% Args: State %% Returns: ok %% -%% %% Shutdown all dynamic children. This happens when the supervisor is %% stopped. Because the supervisor can have millions of dynamic children, we -%% can have an significative overhead here. +%% can have a significative overhead here. %%----------------------------------------------------------------- -terminate_dynamic_children(Child, Dynamics, SupName) -> - {Pids, EStack0} = monitor_dynamic_children(Child, Dynamics), - Sz = ?SETS:size(Pids), +terminate_dynamic_children(State) -> + Child = get_dynamic_child(State), + {Pids, EStack0} = monitor_dynamic_children(Child,State), + Sz = sets:size(Pids), EStack = case Child#child.shutdown of brutal_kill -> - ?SETS:fold(fun(P, _) -> exit(P, kill) end, ok, Pids), + sets:fold(fun(P, _) -> exit(P, kill) end, ok, Pids), wait_dynamic_children(Child, Pids, Sz, undefined, EStack0); infinity -> - ?SETS:fold(fun(P, _) -> exit(P, shutdown) end, ok, Pids), + sets:fold(fun(P, _) -> exit(P, shutdown) end, ok, Pids), wait_dynamic_children(Child, Pids, Sz, undefined, EStack0); Time -> - ?SETS:fold(fun(P, _) -> exit(P, shutdown) end, ok, Pids), + sets:fold(fun(P, _) -> exit(P, shutdown) end, ok, Pids), TRef = erlang:start_timer(Time, self(), kill), wait_dynamic_children(Child, Pids, Sz, TRef, EStack0) end, %% Unroll stacked errors and report them - ?DICTS:fold(fun(Reason, Ls, _) -> - report_error(shutdown_error, Reason, - Child#child{pid=Ls}, SupName) - end, ok, EStack). - - -monitor_dynamic_children(#child{restart_type=temporary}, Dynamics) -> - ?SETS:fold(fun(P, {Pids, EStack}) -> - case monitor_child(P) of - ok -> - {?SETS:add_element(P, Pids), EStack}; - {error, normal} -> - {Pids, EStack}; - {error, Reason} -> - {Pids, ?DICTS:append(Reason, P, EStack)} - end - end, {?SETS:new(), ?DICTS:new()}, Dynamics); -monitor_dynamic_children(#child{restart_type=RType}, Dynamics) -> - ?DICTS:fold(fun(P, _, {Pids, EStack}) when is_pid(P) -> - case monitor_child(P) of - ok -> - {?SETS:add_element(P, Pids), EStack}; - {error, normal} when RType =/= permanent -> - {Pids, EStack}; - {error, Reason} -> - {Pids, ?DICTS:append(Reason, P, EStack)} - end; - (?restarting(_), _, {Pids, EStack}) -> - {Pids, EStack} - end, {?SETS:new(), ?DICTS:new()}, Dynamics). - + dict:fold(fun(Reason, Ls, _) -> + report_error(shutdown_error, Reason, + Child#child{pid=Ls}, State#state.name) + end, ok, EStack). + +monitor_dynamic_children(Child,State) -> + dyn_fold(fun(P,{Pids, EStack}) when is_pid(P) -> + case monitor_child(P) of + ok -> + {sets:add_element(P, Pids), EStack}; + {error, normal} when not (?is_permanent(Child)) -> + {Pids, EStack}; + {error, Reason} -> + {Pids, dict:append(Reason, P, EStack)} + end; + (?restarting(_), {Pids, EStack}) -> + {Pids, EStack} + end, {sets:new(), dict:new()}, State). wait_dynamic_children(_Child, _Pids, 0, undefined, EStack) -> EStack; @@ -1073,39 +958,38 @@ wait_dynamic_children(#child{shutdown=brutal_kill} = Child, Pids, Sz, TRef, EStack) -> receive {'DOWN', _MRef, process, Pid, killed} -> - wait_dynamic_children(Child, ?SETS:del_element(Pid, Pids), Sz-1, + wait_dynamic_children(Child, sets:del_element(Pid, Pids), Sz-1, TRef, EStack); {'DOWN', _MRef, process, Pid, Reason} -> - wait_dynamic_children(Child, ?SETS:del_element(Pid, Pids), Sz-1, - TRef, ?DICTS:append(Reason, Pid, EStack)) + wait_dynamic_children(Child, sets:del_element(Pid, Pids), Sz-1, + TRef, dict:append(Reason, Pid, EStack)) end; -wait_dynamic_children(#child{restart_type=RType} = Child, Pids, Sz, - TRef, EStack) -> +wait_dynamic_children(Child, Pids, Sz, TRef, EStack) -> receive {'DOWN', _MRef, process, Pid, shutdown} -> - wait_dynamic_children(Child, ?SETS:del_element(Pid, Pids), Sz-1, + wait_dynamic_children(Child, sets:del_element(Pid, Pids), Sz-1, TRef, EStack); {'DOWN', _MRef, process, Pid, {shutdown, _}} -> - wait_dynamic_children(Child, ?SETS:del_element(Pid, Pids), Sz-1, + wait_dynamic_children(Child, sets:del_element(Pid, Pids), Sz-1, TRef, EStack); - {'DOWN', _MRef, process, Pid, normal} when RType =/= permanent -> - wait_dynamic_children(Child, ?SETS:del_element(Pid, Pids), Sz-1, + {'DOWN', _MRef, process, Pid, normal} when not (?is_permanent(Child)) -> + wait_dynamic_children(Child, sets:del_element(Pid, Pids), Sz-1, TRef, EStack); {'DOWN', _MRef, process, Pid, Reason} -> - wait_dynamic_children(Child, ?SETS:del_element(Pid, Pids), Sz-1, - TRef, ?DICTS:append(Reason, Pid, EStack)); + wait_dynamic_children(Child, sets:del_element(Pid, Pids), Sz-1, + TRef, dict:append(Reason, Pid, EStack)); {timeout, TRef, kill} -> - ?SETS:fold(fun(P, _) -> exit(P, kill) end, ok, Pids), + sets:fold(fun(P, _) -> exit(P, kill) end, ok, Pids), wait_dynamic_children(Child, Pids, Sz, undefined, EStack) end. %%----------------------------------------------------------------- -%% Child/State manipulating functions. +%% Access #state.children %%----------------------------------------------------------------- %% Note we do not want to save the parameter list for temporary processes as @@ -1113,114 +997,184 @@ wait_dynamic_children(#child{restart_type=RType} = Child, Pids, Sz, %% Especially for dynamic children to simple_one_for_one supervisors %% it could become very costly as it is not uncommon to spawn %% very many such processes. -save_child(#child{restart_type = temporary, - mfargs = {M, F, _}} = Child, #state{children = Children} = State) -> - State#state{children = [Child#child{mfargs = {M, F, undefined}} |Children]}; -save_child(Child, #state{children = Children} = State) -> - State#state{children = [Child |Children]}. - -save_dynamic_child(temporary, Pid, _, #state{dynamics = Dynamics} = State) -> - DynamicsDb = dynamics_db(temporary, Dynamics), - State#state{dynamics = {set, ?SETS:add_element(Pid, DynamicsDb)}}; -save_dynamic_child(RestartType, Pid, Args, #state{dynamics = Dynamics} = State) -> - DynamicsDb = dynamics_db(RestartType, Dynamics), - State#state{dynamics = {dict, ?DICTS:store(Pid, Args, DynamicsDb)}}. - -dynamics_db(temporary, undefined) -> - ?SETS:new(); -dynamics_db(_, undefined) -> - ?DICTS:new(); -dynamics_db(_, {_Tag, DynamicsDb}) -> - DynamicsDb. - -dynamic_child_args(_Pid, temporary, _DynamicsDb) -> - {ok, undefined}; -dynamic_child_args(Pid, _RT, {dict, DynamicsDb}) -> - ?DICTS:find(Pid, DynamicsDb); -dynamic_child_args(_Pid, _RT, undefined) -> - error. - -state_del_child(#child{pid = Pid, restart_type = temporary}, State) when ?is_simple(State) -> - NDynamics = ?SETS:del_element(Pid, dynamics_db(temporary, State#state.dynamics)), - State#state{dynamics = {set, NDynamics}}; -state_del_child(#child{pid = Pid, restart_type = RType}, State) when ?is_simple(State) -> - NDynamics = ?DICTS:erase(Pid, dynamics_db(RType, State#state.dynamics)), - State#state{dynamics = {dict, NDynamics}}; -state_del_child(Child, State) -> - NChildren = del_child(Child#child.name, State#state.children), - State#state{children = NChildren}. - -del_child(Name, [Ch|Chs]) when Ch#child.name =:= Name, Ch#child.restart_type =:= temporary -> - Chs; -del_child(Name, [Ch|Chs]) when Ch#child.name =:= Name -> - [Ch#child{pid = undefined} | Chs]; -del_child(Pid, [Ch|Chs]) when Ch#child.pid =:= Pid, Ch#child.restart_type =:= temporary -> - Chs; -del_child(Pid, [Ch|Chs]) when Ch#child.pid =:= Pid -> - [Ch#child{pid = undefined} | Chs]; -del_child(Name, [Ch|Chs]) -> - [Ch|del_child(Name, Chs)]; -del_child(_, []) -> - []. +-spec save_child(child_rec(), state()) -> state(). +save_child(#child{mfargs = {M, F, _}} = Child, State) when ?is_temporary(Child) -> + do_save_child(Child#child{mfargs = {M, F, undefined}}, State); +save_child(Child, State) -> + do_save_child(Child, State). + +-spec do_save_child(child_rec(), state()) -> state(). +do_save_child(#child{id = Id} = Child, #state{children = {Ids,Db}} = State) -> + State#state{children = {[Id|Ids],Db#{Id => Child}}}. + +-spec del_child(child_rec(), state()) -> state(); + (child_id(), children()) -> children(). +del_child(#child{pid = Pid}, State) when ?is_simple(State) -> + dyn_erase(Pid,State); +del_child(Child, State) when is_record(Child,child), is_record(State,state) -> + NChildren = del_child(Child#child.id, State#state.children), + State#state{children = NChildren}; +del_child(Id, {Ids,Db}) -> + case maps:get(Id, Db) of + Child when Child#child.restart_type =:= temporary -> + {lists:delete(Id, Ids), maps:remove(Id, Db)}; + Child -> + {Ids, Db#{Id=>Child#child{pid=undefined}}} + end. -%% Chs = [S4, S3, Ch, S1, S0] -%% Ret: {[S4, S3, Ch], [S1, S0]} -split_child(Name, Chs) -> - split_child(Name, Chs, []). - -split_child(Name, [Ch|Chs], After) when Ch#child.name =:= Name -> - {lists:reverse([Ch#child{pid = undefined} | After]), Chs}; -split_child(Pid, [Ch|Chs], After) when Ch#child.pid =:= Pid -> - {lists:reverse([Ch#child{pid = undefined} | After]), Chs}; -split_child(Name, [Ch|Chs], After) -> - split_child(Name, Chs, [Ch | After]); -split_child(_, [], After) -> - {lists:reverse(After), []}. - -get_child(Name, State) -> - get_child(Name, State, false). - -get_child(Pid, State, AllowPid) when AllowPid, is_pid(Pid) -> - get_dynamic_child(Pid, State); -get_child(Name, State, _) -> - lists:keysearch(Name, #child.name, State#state.children). - -get_dynamic_child(Pid, #state{children=[Child], dynamics=Dynamics}) -> - case is_dynamic_pid(Pid, Dynamics) of - true -> - {value, Child#child{pid=Pid}}; - false -> - RPid = restarting(Pid), - case is_dynamic_pid(RPid, Dynamics) of - true -> - {value, Child#child{pid=RPid}}; - false -> +%% In: {[S4, S3, Ch, S1, S0],Db} +%% Ret: {{[S4, S3, Ch],Db1}, {[S1, S0],Db2}} +%% Db1 and Db2 contain the keys in the lists they are associated with. +-spec split_child(child_id(), children()) -> {children(), children()}. +split_child(Id, {Ids,Db}) -> + {IdsAfter,IdsBefore} = split_ids(Id, Ids, []), + DbBefore = maps:with(IdsBefore,Db), + #{Id:=Ch} = DbAfter = maps:with(IdsAfter,Db), + {{IdsAfter,DbAfter#{Id=>Ch#child{pid=undefined}}},{IdsBefore,DbBefore}}. + +split_ids(Id, [Id|Ids], After) -> + {lists:reverse([Id|After]), Ids}; +split_ids(Id, [Other|Ids], After) -> + split_ids(Id, Ids, [Other | After]). + +%% Find the child record for a given Pid (dynamic child) or Id +%% (non-dynamic child). This is called from the API functions. +-spec find_child(pid() | child_id(), state()) -> {ok,child_rec()} | error. +find_child(Pid, State) when is_pid(Pid), ?is_simple(State) -> + case find_dynamic_child(Pid, State) of + error -> + case find_dynamic_child(restarting(Pid), State) of + error -> case erlang:is_process_alive(Pid) of - true -> false; - false -> {value, Child} - end - end + true -> error; + false -> {ok, get_dynamic_child(State)} + end; + Other -> + Other + end; + Other -> + Other + end; +find_child(Id, #state{children = {_Ids,Db}}) -> + maps:find(Id, Db). + +%% Get the child record - either by child id or by pid. If +%% simple_one_for_one, then insert the pid and args into the returned +%% child record. This is called when trying to restart the child. +-spec find_child_and_args(IdOrPid, state()) -> {ok, child_rec()} | error when + IdOrPid :: pid() | {restarting,pid()} | child_id(). +find_child_and_args(Pid, State) when ?is_simple(State) -> + case find_dynamic_child(Pid, State) of + {ok,#child{mfargs={M,F,_}} = Child} -> + {ok, Args} = dyn_args(Pid, State), + {ok, Child#child{mfargs = {M, F, Args}}}; + error -> + error + end; +find_child_and_args(Pid, State) when is_pid(Pid) -> + find_child_by_pid(Pid, State); +find_child_and_args(Id, #state{children={_Ids,Db}}) -> + maps:find(Id, Db). + +%% Given the pid, find the child record for a dynamic child, and +%% include the pid in the returned record. +-spec find_dynamic_child(IdOrPid, state()) -> {ok, child_rec()} | error when + IdOrPid :: pid() | {restarting,pid()} | child_id(). +find_dynamic_child(Pid, State) -> + case dyn_exists(Pid, State) of + true -> + Child = get_dynamic_child(State), + {ok, Child#child{pid=Pid}}; + false -> + error end. -is_dynamic_pid(Pid, {dict, Dynamics}) -> - ?DICTS:is_key(Pid, Dynamics); -is_dynamic_pid(Pid, {set, Dynamics}) -> - ?SETS:is_element(Pid, Dynamics); -is_dynamic_pid(_Pid, undefined) -> - false. - -replace_child(Child, State) -> - Chs = do_replace_child(Child, State#state.children), - State#state{children = Chs}. - -do_replace_child(Child, [Ch|Chs]) when Ch#child.name =:= Child#child.name -> - [Child | Chs]; -do_replace_child(Child, [Ch|Chs]) -> - [Ch|do_replace_child(Child, Chs)]. +%% Given the pid, find the child record for a non-dyanamic child. +-spec find_child_by_pid(IdOrPid, state()) -> {ok,child_rec()} | error when + IdOrPid :: pid() | {restarting,pid()}. +find_child_by_pid(Pid,#state{children={_Ids,Db}}) -> + Fun = fun(_Id,#child{pid=P}=Ch,_) when P =:= Pid -> + throw(Ch); + (_,_,error) -> + error + end, + try maps:fold(Fun,error,Db) + catch throw:Child -> {ok,Child} + end. -remove_child(Child, State) -> - Chs = lists:keydelete(Child#child.name, #child.name, State#state.children), - State#state{children = Chs}. +%% Get the child record from a simple_one_for_one supervisor - no pid +%% It is assumed that the child can always be found +-spec get_dynamic_child(state()) -> child_rec(). +get_dynamic_child(#state{children={[Id],Db}}) -> + #{Id := Child} = Db, + Child. + +%% Update pid in the given child record and store it in the process state +-spec set_pid(term(), child_id(), state()) -> state(); + (term(), child_id(), children()) -> children(). +set_pid(Pid, Id, #state{children=Children} = State) -> + State#state{children = set_pid(Pid, Id, Children)}; +set_pid(Pid, Id, {Ids, Db}) -> + NewDb = maps:update_with(Id, fun(Child) -> Child#child{pid=Pid} end, Db), + {Ids,NewDb}. + +%% Remove the Id and the child record from the process state +-spec remove_child(child_id(), state()) -> state(). +remove_child(Id, #state{children={Ids,Db}} = State) -> + NewIds = lists:delete(Id,Ids), + NewDb = maps:remove(Id,Db), + State#state{children = {NewIds,NewDb}}. + +%% In the order of Ids, traverse the children and update each child +%% according to the return value of the Fun. +%% On error, abort and return the merge of the old and the updated map. +%% NOTE: The returned list of Ids is reverted compared to the input. +-spec children_map(Fun, children()) -> {ok, children()} | + {error,children(),Reason} when + Fun :: fun((child_id(),child_rec()) -> {update,child_rec()} | + remove | + {abort, Reason}), + Reason :: term(). +children_map(Fun,{Ids,Db}) -> + children_map(Fun, Ids, Db, []). + +children_map(Fun,[Id|Ids],Db,Acc) -> + case Fun(Id,maps:get(Id,Db)) of + {update,Child} -> + children_map(Fun,Ids,Db#{Id => Child},[Id|Acc]); + remove -> + children_map(Fun,Ids,maps:remove(Id,Db),Acc); + {abort,Reason} -> + {error,{lists:reverse(Ids)++[Id|Acc],Db},Reason} + end; +children_map(_Fun,[],Db,Acc) -> + {ok,{Acc,Db}}. + +%% In the order of Ids, map over all children and return the list +-spec children_to_list(Fun, children()) -> List when + Fun :: fun((child_id(), child_rec()) -> Elem), + List :: list(Elem), + Elem :: term(). +children_to_list(Fun,{Ids,Db}) -> + children_to_list(Fun, Ids, Db, []). +children_to_list(Fun,[Id|Ids],Db,Acc) -> + children_to_list(Fun,Ids,Db,[Fun(Id,maps:get(Id,Db))|Acc]); +children_to_list(_Fun,[],_Db,Acc) -> + lists:reverse(Acc). + +%% The order is not important - so ignore Ids +-spec children_fold(Fun, Acc0, children()) -> Acc1 when + Fun :: fun((child_id(), child_rec(), AccIn) -> AccOut), + Acc0 :: term(), + Acc1 :: term(), + AccIn :: term(), + AccOut :: term(). +children_fold(Fun,Init,{_Ids,Db}) -> + maps:fold(Fun, Init, Db). + +-spec append(children(), children()) -> children(). +append({Ids1,Db1},{Ids2,Db2}) -> + {Ids1++Ids2,maps:merge(Db1,Db2)}. %%----------------------------------------------------------------- %% Func: init_state/4 @@ -1290,27 +1244,27 @@ supname(N, _) -> N. %%% Returns: {ok, [child_rec()]} | Error %%% ------------------------------------------------------ -check_startspec(Children) -> check_startspec(Children, []). +check_startspec(Children) -> check_startspec(Children, [], #{}). -check_startspec([ChildSpec|T], Res) -> +check_startspec([ChildSpec|T], Ids, Db) -> case check_childspec(ChildSpec) of - {ok, Child} -> - case lists:keymember(Child#child.name, #child.name, Res) of + {ok, #child{id=Id}=Child} -> + case maps:is_key(Id, Db) of %% The error message duplicate_child_name is kept for %% backwards compatibility, although %% duplicate_child_id would be more correct. - true -> {duplicate_child_name, Child#child.name}; - false -> check_startspec(T, [Child | Res]) + true -> {duplicate_child_name, Id}; + false -> check_startspec(T, [Id | Ids], Db#{Id=>Child}) end; Error -> Error end; -check_startspec([], Res) -> - {ok, lists:reverse(Res)}. +check_startspec([], Ids, Db) -> + {ok, {lists:reverse(Ids),Db}}. check_childspec(ChildSpec) when is_map(ChildSpec) -> catch do_check_childspec(maps:merge(?default_child_spec,ChildSpec)); -check_childspec({Name, Func, RestartType, Shutdown, ChildType, Mods}) -> - check_childspec(#{id => Name, +check_childspec({Id, Func, RestartType, Shutdown, ChildType, Mods}) -> + check_childspec(#{id => Id, start => Func, restart => RestartType, shutdown => Shutdown, @@ -1320,15 +1274,15 @@ check_childspec(X) -> {invalid_child_spec, X}. do_check_childspec(#{restart := RestartType, type := ChildType} = ChildSpec)-> - Name = case ChildSpec of - #{id := N} -> N; + Id = case ChildSpec of + #{id := I} -> I; _ -> throw(missing_id) end, Func = case ChildSpec of #{start := F} -> F; _ -> throw(missing_start) end, - validName(Name), + validId(Id), validFunc(Func), validRestartType(RestartType), validChildType(ChildType), @@ -1343,14 +1297,14 @@ do_check_childspec(#{restart := RestartType, _ -> {M,_,_} = Func, [M] end, validMods(Mods), - {ok, #child{name = Name, mfargs = Func, restart_type = RestartType, + {ok, #child{id = Id, mfargs = Func, restart_type = RestartType, shutdown = Shutdown, child_type = ChildType, modules = Mods}}. validChildType(supervisor) -> true; validChildType(worker) -> true; validChildType(What) -> throw({invalid_child_type, What}). -validName(_Name) -> true. +validId(_Id) -> true. validFunc({M, F, A}) when is_atom(M), is_atom(F), @@ -1379,13 +1333,13 @@ validMods(Mods) when is_list(Mods) -> Mods); validMods(Mods) -> throw({invalid_modules, Mods}). -child_to_spec(#child{name = Name, +child_to_spec(#child{id = Id, mfargs = Func, restart_type = RestartType, shutdown = Shutdown, child_type = ChildType, modules = Mods}) -> - #{id => Name, + #{id => Id, start => Func, restart => RestartType, shutdown => Shutdown, @@ -1439,17 +1393,16 @@ report_error(Error, Reason, Child, SupName) -> {offender, extract_child(Child)}], error_logger:error_report(supervisor_report, ErrorMsg). - extract_child(Child) when is_list(Child#child.pid) -> [{nb_children, length(Child#child.pid)}, - {id, Child#child.name}, + {id, Child#child.id}, {mfargs, Child#child.mfargs}, {restart_type, Child#child.restart_type}, {shutdown, Child#child.shutdown}, {child_type, Child#child.child_type}]; extract_child(Child) -> [{pid, Child#child.pid}, - {id, Child#child.name}, + {id, Child#child.id}, {mfargs, Child#child.mfargs}, {restart_type, Child#child.restart_type}, {shutdown, Child#child.shutdown}, @@ -1465,3 +1418,46 @@ format_status(terminate, [_PDict, State]) -> format_status(_, [_PDict, State]) -> [{data, [{"State", State}]}, {supervisor, [{"Callback", State#state.module}]}]. + +%%%----------------------------------------------------------------- +%%% Dynamics database access +dyn_size(#state{dynamics = {Mod,Db}}) -> + Mod:size(Db). + +dyn_erase(Pid,#state{dynamics={sets,Db}}=State) -> + State#state{dynamics={sets,sets:del_element(Pid,Db)}}; +dyn_erase(Pid,#state{dynamics={maps,Db}}=State) -> + State#state{dynamics={maps,maps:remove(Pid,Db)}}. + +dyn_store(Pid,_,#state{dynamics={sets,Db}}=State) -> + State#state{dynamics={sets,sets:add_element(Pid,Db)}}; +dyn_store(Pid,Args,#state{dynamics={maps,Db}}=State) -> + State#state{dynamics={maps,Db#{Pid => Args}}}. + +dyn_fold(Fun,Init,#state{dynamics={sets,Db}}) -> + sets:fold(Fun,Init,Db); +dyn_fold(Fun,Init,#state{dynamics={maps,Db}}) -> + maps:fold(fun(Pid,_,Acc) -> Fun(Pid,Acc) end, Init, Db). + +dyn_map(Fun, #state{dynamics={sets,Db}}) -> + lists:map(Fun, sets:to_list(Db)); +dyn_map(Fun, #state{dynamics={maps,Db}}) -> + lists:map(Fun, maps:keys(Db)). + +dyn_exists(Pid, #state{dynamics={sets, Db}}) -> + sets:is_element(Pid, Db); +dyn_exists(Pid, #state{dynamics={maps, Db}}) -> + maps:is_key(Pid, Db). + +dyn_args(_Pid, #state{dynamics={sets, _Db}}) -> + {ok,undefined}; +dyn_args(Pid, #state{dynamics={maps, Db}}) -> + maps:find(Pid, Db). + +dyn_init(State) -> + dyn_init(get_dynamic_child(State),State). + +dyn_init(Child,State) when ?is_temporary(Child) -> + State#state{dynamics={sets,sets:new()}}; +dyn_init(_Child,State) -> + State#state{dynamics={maps,maps:new()}}. diff --git a/lib/stdlib/src/uri_string.erl b/lib/stdlib/src/uri_string.erl new file mode 100644 index 0000000000..28d36ea229 --- /dev/null +++ b/lib/stdlib/src/uri_string.erl @@ -0,0 +1,2096 @@ +%% +%% %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% +%% +%% +%% [RFC 3986, Chapter 2.2. Reserved Characters] +%% +%% reserved = gen-delims / sub-delims +%% +%% gen-delims = ":" / "/" / "?" / "#" / "[" / "]" / "@" +%% +%% sub-delims = "!" / "$" / "&" / "'" / "(" / ")" +%% / "*" / "+" / "," / ";" / "=" +%% +%% +%% [RFC 3986, Chapter 2.3. Unreserved Characters] +%% +%% unreserved = ALPHA / DIGIT / "-" / "." / "_" / "~" +%% +%% +%% [RFC 3986, Chapter 3. Syntax Components] +%% +%% The generic URI syntax consists of a hierarchical sequence of +%% components referred to as the scheme, authority, path, query, and +%% fragment. +%% +%% URI = scheme ":" hier-part [ "?" query ] [ "#" fragment ] +%% +%% hier-part = "//" authority path-abempty +%% / path-absolute +%% / path-rootless +%% / path-empty +%% +%% The scheme and path components are required, though the path may be +%% empty (no characters). When authority is present, the path must +%% either be empty or begin with a slash ("/") character. When +%% authority is not present, the path cannot begin with two slash +%% characters ("//"). These restrictions result in five different ABNF +%% rules for a path (Section 3.3), only one of which will match any +%% given URI reference. +%% +%% The following are two example URIs and their component parts: +%% +%% foo://example.com:8042/over/there?name=ferret#nose +%% \_/ \______________/\_________/ \_________/ \__/ +%% | | | | | +%% scheme authority path query fragment +%% | _____________________|__ +%% / \ / \ +%% urn:example:animal:ferret:nose +%% +%% +%% [RFC 3986, Chapter 3.1. Scheme] +%% +%% Each URI begins with a scheme name that refers to a specification for +%% assigning identifiers within that scheme. +%% +%% scheme = ALPHA *( ALPHA / DIGIT / "+" / "-" / "." ) +%% +%% +%% [RFC 3986, Chapter 3.2. Authority] +%% +%% Many URI schemes include a hierarchical element for a naming +%% authority so that governance of the name space defined by the +%% remainder of the URI is delegated to that authority (which may, in +%% turn, delegate it further). +%% +%% authority = [ userinfo "@" ] host [ ":" port ] +%% +%% +%% [RFC 3986, Chapter 3.2.1. User Information] +%% +%% The userinfo subcomponent may consist of a user name and, optionally, +%% scheme-specific information about how to gain authorization to access +%% the resource. The user information, if present, is followed by a +%% commercial at-sign ("@") that delimits it from the host. +%% +%% userinfo = *( unreserved / pct-encoded / sub-delims / ":" ) +%% +%% +%% [RFC 3986, Chapter 3.2.2. Host] +%% +%% The host subcomponent of authority is identified by an IP literal +%% encapsulated within square brackets, an IPv4 address in dotted- +%% decimal form, or a registered name. +%% +%% host = IP-literal / IPv4address / reg-name +%% +%% IP-literal = "[" ( IPv6address / IPvFuture ) "]" +%% +%% IPvFuture = "v" 1*HEXDIG "." 1*( unreserved / sub-delims / ":" ) +%% +%% IPv6address = 6( h16 ":" ) ls32 +%% / "::" 5( h16 ":" ) ls32 +%% / [ h16 ] "::" 4( h16 ":" ) ls32 +%% / [ *1( h16 ":" ) h16 ] "::" 3( h16 ":" ) ls32 +%% / [ *2( h16 ":" ) h16 ] "::" 2( h16 ":" ) ls32 +%% / [ *3( h16 ":" ) h16 ] "::" h16 ":" ls32 +%% / [ *4( h16 ":" ) h16 ] "::" ls32 +%% / [ *5( h16 ":" ) h16 ] "::" h16 +%% / [ *6( h16 ":" ) h16 ] "::" +%% +%% ls32 = ( h16 ":" h16 ) / IPv4address +%% ; least-significant 32 bits of address +%% +%% h16 = 1*4HEXDIG +%% ; 16 bits of address represented in hexadecimal +%% +%% IPv4address = dec-octet "." dec-octet "." dec-octet "." dec-octet +%% +%% dec-octet = DIGIT ; 0-9 +%% / %x31-39 DIGIT ; 10-99 +%% / "1" 2DIGIT ; 100-199 +%% / "2" %x30-34 DIGIT ; 200-249 +%% / "25" %x30-35 ; 250-255 +%% +%% reg-name = *( unreserved / pct-encoded / sub-delims ) +%% +%% +%% [RFC 3986, Chapter 3.2.2. Port] +%% +%% The port subcomponent of authority is designated by an optional port +%% number in decimal following the host and delimited from it by a +%% single colon (":") character. +%% +%% port = *DIGIT +%% +%% +%% [RFC 3986, Chapter 3.3. Path] +%% +%% The path component contains data, usually organized in hierarchical +%% form, that, along with data in the non-hierarchical query component +%% (Section 3.4), serves to identify a resource within the scope of the +%% URI's scheme and naming authority (if any). The path is terminated +%% by the first question mark ("?") or number sign ("#") character, or +%% by the end of the URI. +%% +%% path = path-abempty ; begins with "/" or is empty +%% / path-absolute ; begins with "/" but not "//" +%% / path-noscheme ; begins with a non-colon segment +%% / path-rootless ; begins with a segment +%% / path-empty ; zero characters +%% +%% path-abempty = *( "/" segment ) +%% path-absolute = "/" [ segment-nz *( "/" segment ) ] +%% path-noscheme = segment-nz-nc *( "/" segment ) +%% path-rootless = segment-nz *( "/" segment ) +%% path-empty = 0<pchar> +%% segment = *pchar +%% segment-nz = 1*pchar +%% segment-nz-nc = 1*( unreserved / pct-encoded / sub-delims / "@" ) +%% ; non-zero-length segment without any colon ":" +%% +%% pchar = unreserved / pct-encoded / sub-delims / ":" / "@" +%% +%% +%% [RFC 3986, Chapter 3.4. Query] +%% +%% The query component contains non-hierarchical data that, along with +%% data in the path component (Section 3.3), serves to identify a +%% resource within the scope of the URI's scheme and naming authority +%% (if any). The query component is indicated by the first question +%% mark ("?") character and terminated by a number sign ("#") character +%% or by the end of the URI. +%% +%% query = *( pchar / "/" / "?" ) +%% +%% +%% [RFC 3986, Chapter 3.5. Fragment] +%% +%% The fragment identifier component of a URI allows indirect +%% identification of a secondary resource by reference to a primary +%% resource and additional identifying information. +%% +%% fragment = *( pchar / "/" / "?" ) +%% +%% +%% [RFC 3986, Chapter 4.1. URI Reference] +%% +%% URI-reference is used to denote the most common usage of a resource +%% identifier. +%% +%% URI-reference = URI / relative-ref +%% +%% +%% [RFC 3986, Chapter 4.2. Relative Reference] +%% +%% A relative reference takes advantage of the hierarchical syntax +%% (Section 1.2.3) to express a URI reference relative to the name space +%% of another hierarchical URI. +%% +%% relative-ref = relative-part [ "?" query ] [ "#" fragment ] +%% +%% relative-part = "//" authority path-abempty +%% / path-absolute +%% / path-noscheme +%% / path-empty +%% +%% +%% [RFC 3986, Chapter 4.3. Absolute URI] +%% +%% Some protocol elements allow only the absolute form of a URI without +%% a fragment identifier. For example, defining a base URI for later +%% use by relative references calls for an absolute-URI syntax rule that +%% does not allow a fragment. +%% +%% absolute-URI = scheme ":" hier-part [ "?" query ] +%% +-module(uri_string). + +%%------------------------------------------------------------------------- +%% External API +%%------------------------------------------------------------------------- +-export([compose_query/1, compose_query/2, + dissect_query/1, normalize/1, normalize/2, parse/1, + recompose/1, transcode/2]). +-export_type([error/0, uri_map/0, uri_string/0]). + + +%%------------------------------------------------------------------------- +%% Internal API +%%------------------------------------------------------------------------- +-export([is_host/1, is_path/1]). % suppress warnings + + +%%------------------------------------------------------------------------- +%% Macros +%%------------------------------------------------------------------------- +-define(CHAR(Char), <<Char/utf8>>). +-define(STRING_EMPTY, <<>>). +-define(STRING(MatchStr), <<MatchStr/binary>>). +-define(STRING_REST(MatchStr, Rest), <<MatchStr/utf8, Rest/binary>>). + +-define(DEC2HEX(X), + if ((X) >= 0) andalso ((X) =< 9) -> (X) + $0; + ((X) >= 10) andalso ((X) =< 15) -> (X) + $A - 10 + end). + +-define(HEX2DEC(X), + if ((X) >= $0) andalso ((X) =< $9) -> (X) - $0; + ((X) >= $A) andalso ((X) =< $F) -> (X) - $A + 10; + ((X) >= $a) andalso ((X) =< $f) -> (X) - $a + 10 + end). + + +%%%========================================================================= +%%% API +%%%========================================================================= + +%%------------------------------------------------------------------------- +%% URI compliant with RFC 3986 +%% ASCII %x21 - %x7A ("!" - "z") except +%% %x34 " double quote +%% %x60 < less than +%% %x62 > greater than +%% %x92 \ backslash +%% %x94 ^ caret / circumflex +%% %x96 ` grave / accent +%%------------------------------------------------------------------------- +-type uri_string() :: iodata(). +-type error() :: {error, atom(), term()}. + + +%%------------------------------------------------------------------------- +%% RFC 3986, Chapter 3. Syntax Components +%%------------------------------------------------------------------------- +-type uri_map() :: + #{fragment => unicode:chardata(), + host => unicode:chardata(), + path => unicode:chardata(), + port => non_neg_integer() | undefined, + query => unicode:chardata(), + scheme => unicode:chardata(), + userinfo => unicode:chardata()} | #{}. + + +%%------------------------------------------------------------------------- +%% Normalize URIs +%%------------------------------------------------------------------------- +-spec normalize(URI) -> NormalizedURI when + URI :: uri_string() | uri_map(), + NormalizedURI :: uri_string() + | error(). +normalize(URIMap) -> + normalize(URIMap, []). + + +-spec normalize(URI, Options) -> NormalizedURI when + URI :: uri_string() | uri_map(), + Options :: [return_map], + NormalizedURI :: uri_string() | uri_map(). +normalize(URIMap, []) when is_map(URIMap) -> + recompose(normalize_map(URIMap)); +normalize(URIMap, [return_map]) when is_map(URIMap) -> + normalize_map(URIMap); +normalize(URIString, []) -> + case parse(URIString) of + Value when is_map(Value) -> + recompose(normalize_map(Value)); + Error -> + Error + end; +normalize(URIString, [return_map]) -> + case parse(URIString) of + Value when is_map(Value) -> + normalize_map(Value); + Error -> + Error + end. + + +%%------------------------------------------------------------------------- +%% Parse URIs +%%------------------------------------------------------------------------- +-spec parse(URIString) -> URIMap when + URIString :: uri_string(), + URIMap :: uri_map() + | error(). +parse(URIString) when is_binary(URIString) -> + try parse_uri_reference(URIString, #{}) + catch + throw:{error, Atom, RestData} -> {error, Atom, RestData} + end; +parse(URIString) when is_list(URIString) -> + try + Binary = unicode:characters_to_binary(URIString), + Map = parse_uri_reference(Binary, #{}), + convert_mapfields_to_list(Map) + catch + throw:{error, Atom, RestData} -> {error, Atom, RestData} + end. + + +%%------------------------------------------------------------------------- +%% Recompose URIs +%%------------------------------------------------------------------------- +-spec recompose(URIMap) -> URIString when + URIMap :: uri_map(), + URIString :: uri_string() + | error(). +recompose(Map) -> + case is_valid_map(Map) of + false -> + {error, invalid_map, Map}; + true -> + try + T0 = update_scheme(Map, empty), + T1 = update_userinfo(Map, T0), + T2 = update_host(Map, T1), + T3 = update_port(Map, T2), + T4 = update_path(Map, T3), + T5 = update_query(Map, T4), + update_fragment(Map, T5) + catch + throw:{error, Atom, RestData} -> {error, Atom, RestData} + end + end. + + +%%------------------------------------------------------------------------- +%% Transcode URIs +%%------------------------------------------------------------------------- +-spec transcode(URIString, Options) -> Result when + URIString :: uri_string(), + Options :: [{in_encoding, unicode:encoding()}|{out_encoding, unicode:encoding()}], + Result :: uri_string() + | error(). +transcode(URIString, Options) when is_binary(URIString) -> + try + InEnc = proplists:get_value(in_encoding, Options, utf8), + OutEnc = proplists:get_value(out_encoding, Options, utf8), + List = convert_to_list(URIString, InEnc), + Output = transcode(List, [], InEnc, OutEnc), + convert_to_binary(Output, utf8, OutEnc) + catch + throw:{error, Atom, RestData} -> {error, Atom, RestData} + end; +transcode(URIString, Options) when is_list(URIString) -> + InEnc = proplists:get_value(in_encoding, Options, utf8), + OutEnc = proplists:get_value(out_encoding, Options, utf8), + Flattened = flatten_list(URIString, InEnc), + try transcode(Flattened, [], InEnc, OutEnc) + catch + throw:{error, Atom, RestData} -> {error, Atom, RestData} + end. + + +%%------------------------------------------------------------------------- +%% Functions for working with the query part of a URI as a list +%% of key/value pairs. +%% HTML 5.2 - 4.10.21.6 URL-encoded form data - WHATWG URL (10 Jan 2018) - UTF-8 +%% HTML 5.0 - 4.10.22.6 URL-encoded form data - non UTF-8 +%%------------------------------------------------------------------------- + +%%------------------------------------------------------------------------- +%% Compose urlencoded query string from a list of unescaped key/value pairs. +%% (application/x-www-form-urlencoded encoding algorithm) +%%------------------------------------------------------------------------- +-spec compose_query(QueryList) -> QueryString when + QueryList :: [{unicode:chardata(), unicode:chardata()}], + QueryString :: uri_string() + | error(). +compose_query(List) -> + compose_query(List, [{encoding, utf8}]). + + +-spec compose_query(QueryList, Options) -> QueryString when + QueryList :: [{unicode:chardata(), unicode:chardata()}], + Options :: [{encoding, atom()}], + QueryString :: uri_string() + | error(). +compose_query([],_Options) -> + []; +compose_query(List, Options) -> + try compose_query(List, Options, false, <<>>) + catch + throw:{error, Atom, RestData} -> {error, Atom, RestData} + end. +%% +compose_query([{Key,Value}|Rest], Options, IsList, Acc) -> + Separator = get_separator(Rest), + K = form_urlencode(Key, Options), + V = form_urlencode(Value, Options), + IsListNew = IsList orelse is_list(Key) orelse is_list(Value), + compose_query(Rest, Options, IsListNew, <<Acc/binary,K/binary,"=",V/binary,Separator/binary>>); +compose_query([], _Options, IsList, Acc) -> + case IsList of + true -> convert_to_list(Acc, utf8); + false -> Acc + end. + + +%%------------------------------------------------------------------------- +%% Dissect a query string into a list of unescaped key/value pairs. +%% (application/x-www-form-urlencoded decoding algorithm) +%%------------------------------------------------------------------------- +-spec dissect_query(QueryString) -> QueryList when + QueryString :: uri_string(), + QueryList :: [{unicode:chardata(), unicode:chardata()}] + | error(). +dissect_query(<<>>) -> + []; +dissect_query([]) -> + []; +dissect_query(QueryString) when is_list(QueryString) -> + try + B = convert_to_binary(QueryString, utf8, utf8), + dissect_query_key(B, true, [], <<>>, <<>>) + catch + throw:{error, Atom, RestData} -> {error, Atom, RestData} + end; +dissect_query(QueryString) -> + try dissect_query_key(QueryString, false, [], <<>>, <<>>) + catch + throw:{error, Atom, RestData} -> {error, Atom, RestData} + end. + + +%%%======================================================================== +%%% Internal functions +%%%======================================================================== + +%%------------------------------------------------------------------------- +%% Converts Map fields to lists +%%------------------------------------------------------------------------- +convert_mapfields_to_list(Map) -> + Fun = fun (_, V) when is_binary(V) -> unicode:characters_to_list(V); + (_, V) -> V end, + maps:map(Fun, Map). + + +%%------------------------------------------------------------------------- +%% [RFC 3986, Chapter 4.1. URI Reference] +%% +%% URI-reference is used to denote the most common usage of a resource +%% identifier. +%% +%% URI-reference = URI / relative-ref +%%------------------------------------------------------------------------- +-spec parse_uri_reference(binary(), uri_map()) -> uri_map(). +parse_uri_reference(<<>>, _) -> #{path => <<>>}; +parse_uri_reference(URIString, URI) -> + try parse_scheme_start(URIString, URI) + catch + throw:{_,_,_} -> + parse_relative_part(URIString, URI) + end. + + +%%------------------------------------------------------------------------- +%% [RFC 3986, Chapter 4.2. Relative Reference] +%% +%% A relative reference takes advantage of the hierarchical syntax +%% (Section 1.2.3) to express a URI reference relative to the name space +%% of another hierarchical URI. +%% +%% relative-ref = relative-part [ "?" query ] [ "#" fragment ] +%% +%% relative-part = "//" authority path-abempty +%% / path-absolute +%% / path-noscheme +%% / path-empty +%%------------------------------------------------------------------------- +-spec parse_relative_part(binary(), uri_map()) -> uri_map(). +parse_relative_part(?STRING_REST("//", Rest), URI) -> + %% Parse userinfo - "//" is NOT part of authority + try parse_userinfo(Rest, URI) of + {T, URI1} -> + Userinfo = calculate_parsed_userinfo(Rest, T), + URI2 = maybe_add_path(URI1), + URI2#{userinfo => decode_userinfo(Userinfo)} + catch + throw:{_,_,_} -> + {T, URI1} = parse_host(Rest, URI), + Host = calculate_parsed_host_port(Rest, T), + URI2 = maybe_add_path(URI1), + URI2#{host => decode_host(remove_brackets(Host))} + end; +parse_relative_part(?STRING_REST($/, Rest), URI) -> + {T, URI1} = parse_segment(Rest, URI), % path-absolute + Path = calculate_parsed_part(Rest, T), + URI1#{path => decode_path(?STRING_REST($/, Path))}; +parse_relative_part(?STRING_REST($?, Rest), URI) -> + {T, URI1} = parse_query(Rest, URI), % path-empty ?query + Query = calculate_parsed_query_fragment(Rest, T), + URI2 = maybe_add_path(URI1), + URI2#{query => decode_query(Query)}; +parse_relative_part(?STRING_REST($#, Rest), URI) -> + {T, URI1} = parse_fragment(Rest, URI), % path-empty + Fragment = calculate_parsed_query_fragment(Rest, T), + URI2 = maybe_add_path(URI1), + URI2#{fragment => decode_fragment(Fragment)}; +parse_relative_part(?STRING_REST(Char, Rest), URI) -> + case is_segment_nz_nc(Char) of + true -> + {T, URI1} = parse_segment_nz_nc(Rest, URI), % path-noscheme + Path = calculate_parsed_part(Rest, T), + URI1#{path => decode_path(?STRING_REST(Char, Path))}; + false -> throw({error,invalid_uri,[Char]}) + end. + + +%%------------------------------------------------------------------------- +%% [RFC 3986, Chapter 3.3. Path] +%% +%% The path component contains data, usually organized in hierarchical +%% form, that, along with data in the non-hierarchical query component +%% (Section 3.4), serves to identify a resource within the scope of the +%% URI's scheme and naming authority (if any). The path is terminated +%% by the first question mark ("?") or number sign ("#") character, or +%% by the end of the URI. +%% +%% path = path-abempty ; begins with "/" or is empty +%% / path-absolute ; begins with "/" but not "//" +%% / path-noscheme ; begins with a non-colon segment +%% / path-rootless ; begins with a segment +%% / path-empty ; zero characters +%% +%% path-abempty = *( "/" segment ) +%% path-absolute = "/" [ segment-nz *( "/" segment ) ] +%% path-noscheme = segment-nz-nc *( "/" segment ) +%% path-rootless = segment-nz *( "/" segment ) +%% path-empty = 0<pchar> +%% segment = *pchar +%% segment-nz = 1*pchar +%% segment-nz-nc = 1*( unreserved / pct-encoded / sub-delims / "@" ) +%% ; non-zero-length segment without any colon ":" +%% +%% pchar = unreserved / pct-encoded / sub-delims / ":" / "@" +%%------------------------------------------------------------------------- + +%%------------------------------------------------------------------------- +%% path-abempty +%%------------------------------------------------------------------------- +-spec parse_segment(binary(), uri_map()) -> {binary(), uri_map()}. +parse_segment(?STRING_REST($/, Rest), URI) -> + parse_segment(Rest, URI); % segment +parse_segment(?STRING_REST($?, Rest), URI) -> + {T, URI1} = parse_query(Rest, URI), % ?query + Query = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{query => decode_query(Query)}}; +parse_segment(?STRING_REST($#, Rest), URI) -> + {T, URI1} = parse_fragment(Rest, URI), + Fragment = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{fragment => decode_fragment(Fragment)}}; +parse_segment(?STRING_REST(Char, Rest), URI) -> + case is_pchar(Char) of + true -> parse_segment(Rest, URI); + false -> throw({error,invalid_uri,[Char]}) + end; +parse_segment(?STRING_EMPTY, URI) -> + {?STRING_EMPTY, URI}. + + +%%------------------------------------------------------------------------- +%% path-noscheme +%%------------------------------------------------------------------------- +-spec parse_segment_nz_nc(binary(), uri_map()) -> {binary(), uri_map()}. +parse_segment_nz_nc(?STRING_REST($/, Rest), URI) -> + parse_segment(Rest, URI); % segment +parse_segment_nz_nc(?STRING_REST($?, Rest), URI) -> + {T, URI1} = parse_query(Rest, URI), % ?query + Query = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{query => decode_query(Query)}}; +parse_segment_nz_nc(?STRING_REST($#, Rest), URI) -> + {T, URI1} = parse_fragment(Rest, URI), + Fragment = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{fragment => decode_fragment(Fragment)}}; +parse_segment_nz_nc(?STRING_REST(Char, Rest), URI) -> + case is_segment_nz_nc(Char) of + true -> parse_segment_nz_nc(Rest, URI); + false -> throw({error,invalid_uri,[Char]}) + end; +parse_segment_nz_nc(?STRING_EMPTY, URI) -> + {?STRING_EMPTY, URI}. + + +%% Check if char is pchar. +-spec is_pchar(char()) -> boolean(). +is_pchar($%) -> true; % pct-encoded +is_pchar($:) -> true; +is_pchar($@) -> true; +is_pchar(Char) -> is_unreserved(Char) orelse is_sub_delim(Char). + +%% Check if char is segment_nz_nc. +-spec is_segment_nz_nc(char()) -> boolean(). +is_segment_nz_nc($%) -> true; % pct-encoded +is_segment_nz_nc($@) -> true; +is_segment_nz_nc(Char) -> is_unreserved(Char) orelse is_sub_delim(Char). + + +%%------------------------------------------------------------------------- +%% [RFC 3986, Chapter 3.1. Scheme] +%% +%% Each URI begins with a scheme name that refers to a specification for +%% assigning identifiers within that scheme. +%% +%% scheme = ALPHA *( ALPHA / DIGIT / "+" / "-" / "." ) +%%------------------------------------------------------------------------- +-spec parse_scheme_start(binary(), uri_map()) -> uri_map(). +parse_scheme_start(?STRING_REST(Char, Rest), URI) -> + case is_alpha(Char) of + true -> {T, URI1} = parse_scheme(Rest, URI), + Scheme = calculate_parsed_scheme(Rest, T), + URI2 = maybe_add_path(URI1), + URI2#{scheme => ?STRING_REST(Char, Scheme)}; + false -> throw({error,invalid_uri,[Char]}) + end. + +%% Add path component if it missing after parsing the URI. +%% According to the URI specification there is always a +%% path component in every URI-reference and it can be +%% empty. +maybe_add_path(Map) -> + case maps:is_key(path, Map) of + false -> + Map#{path => <<>>}; + _Else -> + Map + end. + + + +-spec parse_scheme(binary(), uri_map()) -> {binary(), uri_map()}. +parse_scheme(?STRING_REST($:, Rest), URI) -> + {_, URI1} = parse_hier(Rest, URI), + {Rest, URI1}; +parse_scheme(?STRING_REST(Char, Rest), URI) -> + case is_scheme(Char) of + true -> parse_scheme(Rest, URI); + false -> throw({error,invalid_uri,[Char]}) + end; +parse_scheme(?STRING_EMPTY, _URI) -> + throw({error,invalid_uri,<<>>}). + + +%% Check if char is allowed in scheme +-spec is_scheme(char()) -> boolean(). +is_scheme($+) -> true; +is_scheme($-) -> true; +is_scheme($.) -> true; +is_scheme(Char) -> is_alpha(Char) orelse is_digit(Char). + + +%%------------------------------------------------------------------------- +%% hier-part = "//" authority path-abempty +%% / path-absolute +%% / path-rootless +%% / path-empty +%%------------------------------------------------------------------------- +-spec parse_hier(binary(), uri_map()) -> {binary(), uri_map()}. +parse_hier(?STRING_REST("//", Rest), URI) -> + % Parse userinfo - "//" is NOT part of authority + try parse_userinfo(Rest, URI) of + {T, URI1} -> + Userinfo = calculate_parsed_userinfo(Rest, T), + {Rest, URI1#{userinfo => decode_userinfo(Userinfo)}} + catch + throw:{_,_,_} -> + {T, URI1} = parse_host(Rest, URI), + Host = calculate_parsed_host_port(Rest, T), + {Rest, URI1#{host => decode_host(remove_brackets(Host))}} + end; +parse_hier(?STRING_REST($/, Rest), URI) -> + {T, URI1} = parse_segment(Rest, URI), % path-absolute + Path = calculate_parsed_part(Rest, T), + {Rest, URI1#{path => decode_path(?STRING_REST($/, Path))}}; +parse_hier(?STRING_REST($?, Rest), URI) -> + {T, URI1} = parse_query(Rest, URI), % path-empty ?query + Query = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{query => decode_query(Query)}}; +parse_hier(?STRING_REST($#, Rest), URI) -> + {T, URI1} = parse_fragment(Rest, URI), % path-empty + Fragment = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{fragment => decode_fragment(Fragment)}}; +parse_hier(?STRING_REST(Char, Rest), URI) -> % path-rootless + case is_pchar(Char) of + true -> % segment_nz + {T, URI1} = parse_segment(Rest, URI), + Path = calculate_parsed_part(Rest, T), + {Rest, URI1#{path => decode_path(?STRING_REST(Char, Path))}}; + false -> throw({error,invalid_uri,[Char]}) + end; +parse_hier(?STRING_EMPTY, URI) -> + {<<>>, URI}. + + +%%------------------------------------------------------------------------- +%% [RFC 3986, Chapter 3.2. Authority] +%% +%% Many URI schemes include a hierarchical element for a naming +%% authority so that governance of the name space defined by the +%% remainder of the URI is delegated to that authority (which may, in +%% turn, delegate it further). +%% +%% The authority component is preceded by a double slash ("//") and is +%% terminated by the next slash ("/"), question mark ("?"), or number +%% sign ("#") character, or by the end of the URI. +%% +%% authority = [ userinfo "@" ] host [ ":" port ] +%% +%% +%% [RFC 3986, Chapter 3.2.1. User Information] +%% +%% The userinfo subcomponent may consist of a user name and, optionally, +%% scheme-specific information about how to gain authorization to access +%% the resource. The user information, if present, is followed by a +%% commercial at-sign ("@") that delimits it from the host. +%% +%% userinfo = *( unreserved / pct-encoded / sub-delims / ":" ) +%%------------------------------------------------------------------------- +-spec parse_userinfo(binary(), uri_map()) -> {binary(), uri_map()}. +parse_userinfo(?CHAR($@), URI) -> + {?STRING_EMPTY, URI#{host => <<>>}}; +parse_userinfo(?STRING_REST($@, Rest), URI) -> + {T, URI1} = parse_host(Rest, URI), + Host = calculate_parsed_host_port(Rest, T), + {Rest, URI1#{host => decode_host(remove_brackets(Host))}}; +parse_userinfo(?STRING_REST(Char, Rest), URI) -> + case is_userinfo(Char) of + true -> parse_userinfo(Rest, URI); + false -> throw({error,invalid_uri,[Char]}) + end; +parse_userinfo(?STRING_EMPTY, _URI) -> + %% URI cannot end in userinfo state + throw({error,invalid_uri,<<>>}). + + +%% Check if char is allowed in userinfo +-spec is_userinfo(char()) -> boolean(). +is_userinfo($%) -> true; % pct-encoded +is_userinfo($:) -> true; +is_userinfo(Char) -> is_unreserved(Char) orelse is_sub_delim(Char). + + +%%------------------------------------------------------------------------- +%% [RFC 3986, Chapter 3.2.2. Host] +%% +%% The host subcomponent of authority is identified by an IP literal +%% encapsulated within square brackets, an IPv4 address in dotted- +%% decimal form, or a registered name. +%% +%% host = IP-literal / IPv4address / reg-name +%% +%% IP-literal = "[" ( IPv6address / IPvFuture ) "]" +%% +%% IPvFuture = "v" 1*HEXDIG "." 1*( unreserved / sub-delims / ":" ) +%% +%% IPv6address = 6( h16 ":" ) ls32 +%% / "::" 5( h16 ":" ) ls32 +%% / [ h16 ] "::" 4( h16 ":" ) ls32 +%% / [ *1( h16 ":" ) h16 ] "::" 3( h16 ":" ) ls32 +%% / [ *2( h16 ":" ) h16 ] "::" 2( h16 ":" ) ls32 +%% / [ *3( h16 ":" ) h16 ] "::" h16 ":" ls32 +%% / [ *4( h16 ":" ) h16 ] "::" ls32 +%% / [ *5( h16 ":" ) h16 ] "::" h16 +%% / [ *6( h16 ":" ) h16 ] "::" +%% +%% ls32 = ( h16 ":" h16 ) / IPv4address +%% ; least-significant 32 bits of address +%% +%% h16 = 1*4HEXDIG +%% ; 16 bits of address represented in hexadecimal +%% +%% IPv4address = dec-octet "." dec-octet "." dec-octet "." dec-octet +%% +%% dec-octet = DIGIT ; 0-9 +%% / %x31-39 DIGIT ; 10-99 +%% / "1" 2DIGIT ; 100-199 +%% / "2" %x30-34 DIGIT ; 200-249 +%% / "25" %x30-35 ; 250-255 +%% +%% reg-name = *( unreserved / pct-encoded / sub-delims ) +%%------------------------------------------------------------------------- +-spec parse_host(binary(), uri_map()) -> {binary(), uri_map()}. +parse_host(?STRING_REST($:, Rest), URI) -> + {T, URI1} = parse_port(Rest, URI), + H = calculate_parsed_host_port(Rest, T), + Port = get_port(H), + {Rest, URI1#{port => Port}}; +parse_host(?STRING_REST($/, Rest), URI) -> + {T, URI1} = parse_segment(Rest, URI), % path-abempty + Path = calculate_parsed_part(Rest, T), + {Rest, URI1#{path => decode_path(?STRING_REST($/, Path))}}; +parse_host(?STRING_REST($?, Rest), URI) -> + {T, URI1} = parse_query(Rest, URI), % path-empty ?query + Query = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{query => decode_query(Query)}}; +parse_host(?STRING_REST($[, Rest), URI) -> + parse_ipv6_bin(Rest, [], URI); +parse_host(?STRING_REST($#, Rest), URI) -> + {T, URI1} = parse_fragment(Rest, URI), % path-empty + Fragment = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{fragment => decode_fragment(Fragment)}}; +parse_host(?STRING_REST(Char, Rest), URI) -> + case is_digit(Char) of + true -> parse_ipv4_bin(Rest, [Char], URI); + false -> parse_reg_name(?STRING_REST(Char, Rest), URI) + end; +parse_host(?STRING_EMPTY, URI) -> + {?STRING_EMPTY, URI}. + + +-spec parse_reg_name(binary(), uri_map()) -> {binary(), uri_map()}. +parse_reg_name(?STRING_REST($:, Rest), URI) -> + {T, URI1} = parse_port(Rest, URI), + H = calculate_parsed_host_port(Rest, T), + Port = get_port(H), + {Rest, URI1#{port => Port}}; +parse_reg_name(?STRING_REST($/, Rest), URI) -> + {T, URI1} = parse_segment(Rest, URI), % path-abempty + Path = calculate_parsed_part(Rest, T), + {Rest, URI1#{path => decode_path(?STRING_REST($/, Path))}}; +parse_reg_name(?STRING_REST($?, Rest), URI) -> + {T, URI1} = parse_query(Rest, URI), % path-empty ?query + Query = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{query => decode_query(Query)}}; +parse_reg_name(?STRING_REST($#, Rest), URI) -> + {T, URI1} = parse_fragment(Rest, URI), % path-empty + Fragment = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{fragment => decode_fragment(Fragment)}}; +parse_reg_name(?STRING_REST(Char, Rest), URI) -> + case is_reg_name(Char) of + true -> parse_reg_name(Rest, URI); + false -> throw({error,invalid_uri,[Char]}) + end; +parse_reg_name(?STRING_EMPTY, URI) -> + {?STRING_EMPTY, URI}. + +%% Check if char is allowed in reg-name +-spec is_reg_name(char()) -> boolean(). +is_reg_name($%) -> true; +is_reg_name(Char) -> is_unreserved(Char) orelse is_sub_delim(Char). + + +-spec parse_ipv4_bin(binary(), list(), uri_map()) -> {binary(), uri_map()}. +parse_ipv4_bin(?STRING_REST($:, Rest), Acc, URI) -> + _ = validate_ipv4_address(lists:reverse(Acc)), + {T, URI1} = parse_port(Rest, URI), + H = calculate_parsed_host_port(Rest, T), + Port = get_port(H), + {Rest, URI1#{port => Port}}; +parse_ipv4_bin(?STRING_REST($/, Rest), Acc, URI) -> + _ = validate_ipv4_address(lists:reverse(Acc)), + {T, URI1} = parse_segment(Rest, URI), % path-abempty + Path = calculate_parsed_part(Rest, T), + {Rest, URI1#{path => decode_path(?STRING_REST($/, Path))}}; +parse_ipv4_bin(?STRING_REST($?, Rest), Acc, URI) -> + _ = validate_ipv4_address(lists:reverse(Acc)), + {T, URI1} = parse_query(Rest, URI), % path-empty ?query + Query = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{query => decode_query(Query)}}; +parse_ipv4_bin(?STRING_REST($#, Rest), Acc, URI) -> + _ = validate_ipv4_address(lists:reverse(Acc)), + {T, URI1} = parse_fragment(Rest, URI), % path-empty + Fragment = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{fragment => decode_fragment(Fragment)}}; +parse_ipv4_bin(?STRING_REST(Char, Rest), Acc, URI) -> + case is_ipv4(Char) of + true -> parse_ipv4_bin(Rest, [Char|Acc], URI); + false -> throw({error,invalid_uri,[Char]}) + end; +parse_ipv4_bin(?STRING_EMPTY, Acc, URI) -> + _ = validate_ipv4_address(lists:reverse(Acc)), + {?STRING_EMPTY, URI}. + + +%% Check if char is allowed in IPv4 addresses +-spec is_ipv4(char()) -> boolean(). +is_ipv4($.) -> true; +is_ipv4(Char) -> is_digit(Char). + +-spec validate_ipv4_address(list()) -> list(). +validate_ipv4_address(Addr) -> + case inet:parse_ipv4strict_address(Addr) of + {ok, _} -> Addr; + {error, _} -> throw({error,invalid_uri,Addr}) + end. + + +-spec parse_ipv6_bin(binary(), list(), uri_map()) -> {binary(), uri_map()}. +parse_ipv6_bin(?STRING_REST($], Rest), Acc, URI) -> + _ = validate_ipv6_address(lists:reverse(Acc)), + parse_ipv6_bin_end(Rest, URI); +parse_ipv6_bin(?STRING_REST(Char, Rest), Acc, URI) -> + case is_ipv6(Char) of + true -> parse_ipv6_bin(Rest, [Char|Acc], URI); + false -> throw({error,invalid_uri,[Char]}) + end; +parse_ipv6_bin(?STRING_EMPTY, _Acc, _URI) -> + throw({error,invalid_uri,<<>>}). + +%% Check if char is allowed in IPv6 addresses +-spec is_ipv6(char()) -> boolean(). +is_ipv6($:) -> true; +is_ipv6($.) -> true; +is_ipv6(Char) -> is_hex_digit(Char). + + +-spec parse_ipv6_bin_end(binary(), uri_map()) -> {binary(), uri_map()}. +parse_ipv6_bin_end(?STRING_REST($:, Rest), URI) -> + {T, URI1} = parse_port(Rest, URI), + H = calculate_parsed_host_port(Rest, T), + Port = get_port(H), + {Rest, URI1#{port => Port}}; +parse_ipv6_bin_end(?STRING_REST($/, Rest), URI) -> + {T, URI1} = parse_segment(Rest, URI), % path-abempty + Path = calculate_parsed_part(Rest, T), + {Rest, URI1#{path => decode_path(?STRING_REST($/, Path))}}; +parse_ipv6_bin_end(?STRING_REST($?, Rest), URI) -> + {T, URI1} = parse_query(Rest, URI), % path-empty ?query + Query = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{query => decode_query(Query)}}; +parse_ipv6_bin_end(?STRING_REST($#, Rest), URI) -> + {T, URI1} = parse_fragment(Rest, URI), % path-empty + Fragment = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{fragment => decode_fragment(Fragment)}}; +parse_ipv6_bin_end(?STRING_REST(Char, Rest), URI) -> + case is_ipv6(Char) of + true -> parse_ipv6_bin_end(Rest, URI); + false -> throw({error,invalid_uri,[Char]}) + end; +parse_ipv6_bin_end(?STRING_EMPTY, URI) -> + {?STRING_EMPTY, URI}. + +-spec validate_ipv6_address(list()) -> list(). +validate_ipv6_address(Addr) -> + case inet:parse_ipv6strict_address(Addr) of + {ok, _} -> Addr; + {error, _} -> throw({error,invalid_uri,Addr}) + end. + + +%%------------------------------------------------------------------------- +%% [RFC 3986, Chapter 3.2.2. Port] +%% +%% The port subcomponent of authority is designated by an optional port +%% number in decimal following the host and delimited from it by a +%% single colon (":") character. +%% +%% port = *DIGIT +%%------------------------------------------------------------------------- +-spec parse_port(binary(), uri_map()) -> {binary(), uri_map()}. +parse_port(?STRING_REST($/, Rest), URI) -> + {T, URI1} = parse_segment(Rest, URI), % path-abempty + Path = calculate_parsed_part(Rest, T), + {Rest, URI1#{path => decode_path(?STRING_REST($/, Path))}}; +parse_port(?STRING_REST($?, Rest), URI) -> + {T, URI1} = parse_query(Rest, URI), % path-empty ?query + Query = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{query => decode_query(Query)}}; +parse_port(?STRING_REST($#, Rest), URI) -> + {T, URI1} = parse_fragment(Rest, URI), % path-empty + Fragment = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{fragment => decode_fragment(Fragment)}}; +parse_port(?STRING_REST(Char, Rest), URI) -> + case is_digit(Char) of + true -> parse_port(Rest, URI); + false -> throw({error,invalid_uri,[Char]}) + end; +parse_port(?STRING_EMPTY, URI) -> + {?STRING_EMPTY, URI}. + + +%%------------------------------------------------------------------------- +%% [RFC 3986, Chapter 3.4. Query] +%% +%% The query component contains non-hierarchical data that, along with +%% data in the path component (Section 3.3), serves to identify a +%% resource within the scope of the URI's scheme and naming authority +%% (if any). The query component is indicated by the first question +%% mark ("?") character and terminated by a number sign ("#") character +%% or by the end of the URI. +%% +%% query = *( pchar / "/" / "?" ) +%%------------------------------------------------------------------------- +-spec parse_query(binary(), uri_map()) -> {binary(), uri_map()}. +parse_query(?STRING_REST($#, Rest), URI) -> + {T, URI1} = parse_fragment(Rest, URI), + Fragment = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{fragment => decode_fragment(Fragment)}}; +parse_query(?STRING_REST(Char, Rest), URI) -> + case is_query(Char) of + true -> parse_query(Rest, URI); + false -> throw({error,invalid_uri,[Char]}) + end; +parse_query(?STRING_EMPTY, URI) -> + {?STRING_EMPTY, URI}. + + +%% Check if char is allowed in query +-spec is_query(char()) -> boolean(). +is_query($/) -> true; +is_query($?) -> true; +is_query(Char) -> is_pchar(Char). + + +%%------------------------------------------------------------------------- +%% [RFC 3986, Chapter 3.5. Fragment] +%% +%% The fragment identifier component of a URI allows indirect +%% identification of a secondary resource by reference to a primary +%% resource and additional identifying information. +%% +%% fragment = *( pchar / "/" / "?" ) +%%------------------------------------------------------------------------- +-spec parse_fragment(binary(), uri_map()) -> {binary(), uri_map()}. +parse_fragment(?STRING_REST(Char, Rest), URI) -> + case is_fragment(Char) of + true -> parse_fragment(Rest, URI); + false -> throw({error,invalid_uri,[Char]}) + end; +parse_fragment(?STRING_EMPTY, URI) -> + {?STRING_EMPTY, URI}. + + +%% Check if char is allowed in fragment +-spec is_fragment(char()) -> boolean(). +is_fragment($/) -> true; +is_fragment($?) -> true; +is_fragment(Char) -> is_pchar(Char). + + +%%------------------------------------------------------------------------- +%% [RFC 3986, Chapter 2.2. Reserved Characters] +%% +%% reserved = gen-delims / sub-delims +%% +%% gen-delims = ":" / "/" / "?" / "#" / "[" / "]" / "@" +%% +%% sub-delims = "!" / "$" / "&" / "'" / "(" / ")" +%% / "*" / "+" / "," / ";" / "=" +%% +%%------------------------------------------------------------------------- + +%% Check if char is sub-delim. +-spec is_sub_delim(char()) -> boolean(). +is_sub_delim($!) -> true; +is_sub_delim($$) -> true; +is_sub_delim($&) -> true; +is_sub_delim($') -> true; +is_sub_delim($() -> true; +is_sub_delim($)) -> true; + +is_sub_delim($*) -> true; +is_sub_delim($+) -> true; +is_sub_delim($,) -> true; +is_sub_delim($;) -> true; +is_sub_delim($=) -> true; +is_sub_delim(_) -> false. + + +%%------------------------------------------------------------------------- +%% [RFC 3986, Chapter 2.3. Unreserved Characters] +%% +%% unreserved = ALPHA / DIGIT / "-" / "." / "_" / "~" +%% +%%------------------------------------------------------------------------- +-spec is_unreserved(char()) -> boolean(). +is_unreserved($-) -> true; +is_unreserved($.) -> true; +is_unreserved($_) -> true; +is_unreserved($~) -> true; +is_unreserved(Char) -> is_alpha(Char) orelse is_digit(Char). + +-spec is_alpha(char()) -> boolean(). +is_alpha(C) + when $A =< C, C =< $Z; + $a =< C, C =< $z -> true; +is_alpha(_) -> false. + +-spec is_digit(char()) -> boolean(). +is_digit(C) + when $0 =< C, C =< $9 -> true; +is_digit(_) -> false. + +-spec is_hex_digit(char()) -> boolean(). +is_hex_digit(C) + when $0 =< C, C =< $9;$a =< C, C =< $f;$A =< C, C =< $F -> true; +is_hex_digit(_) -> false. + + +%% Remove enclosing brackets from binary +-spec remove_brackets(binary()) -> binary(). +remove_brackets(<<$[/utf8, Rest/binary>>) -> + {H,T} = split_binary(Rest, byte_size(Rest) - 1), + case T =:= <<$]/utf8>> of + true -> H; + false -> Rest + end; +remove_brackets(Addr) -> Addr. + + +%%------------------------------------------------------------------------- +%% Helper functions for calculating the parsed binary. +%%------------------------------------------------------------------------- +-spec calculate_parsed_scheme(binary(), binary()) -> binary(). +calculate_parsed_scheme(Input, <<>>) -> + strip_last_char(Input, [$:]); +calculate_parsed_scheme(Input, Unparsed) -> + get_parsed_binary(Input, Unparsed). + + +-spec calculate_parsed_part(binary(), binary()) -> binary(). +calculate_parsed_part(Input, <<>>) -> + strip_last_char(Input, [$?,$#]); +calculate_parsed_part(Input, Unparsed) -> + get_parsed_binary(Input, Unparsed). + + +-spec calculate_parsed_userinfo(binary(), binary()) -> binary(). +calculate_parsed_userinfo(Input, <<>>) -> + strip_last_char(Input, [$?,$#,$@]); +calculate_parsed_userinfo(Input, Unparsed) -> + get_parsed_binary(Input, Unparsed). + + +-spec calculate_parsed_host_port(binary(), binary()) -> binary(). +calculate_parsed_host_port(Input, <<>>) -> + strip_last_char(Input, [$:,$?,$#,$/]); +calculate_parsed_host_port(Input, Unparsed) -> + get_parsed_binary(Input, Unparsed). + + +calculate_parsed_query_fragment(Input, <<>>) -> + strip_last_char(Input, [$#]); +calculate_parsed_query_fragment(Input, Unparsed) -> + get_parsed_binary(Input, Unparsed). + + +get_port(<<>>) -> + undefined; +get_port(B) -> + try binary_to_integer(B) + catch + error:badarg -> + throw({error, invalid_uri, B}) + end. + + +%% Strip last char if it is in list +%% +%% This function is optimized for speed: parse/1 is about 10% faster than +%% with an alternative implementation based on lists and sets. +strip_last_char(<<>>, _) -> <<>>; +strip_last_char(Input, [C0]) -> + case binary:last(Input) of + C0 -> + init_binary(Input); + _Else -> + Input + end; +strip_last_char(Input, [C0,C1]) -> + case binary:last(Input) of + C0 -> + init_binary(Input); + C1 -> + init_binary(Input); + _Else -> + Input + end; +strip_last_char(Input, [C0,C1,C2]) -> + case binary:last(Input) of + C0 -> + init_binary(Input); + C1 -> + init_binary(Input); + C2 -> + init_binary(Input); + _Else -> + Input + end; +strip_last_char(Input, [C0,C1,C2,C3]) -> + case binary:last(Input) of + C0 -> + init_binary(Input); + C1 -> + init_binary(Input); + C2 -> + init_binary(Input); + C3 -> + init_binary(Input); + _Else -> + Input + end. + + +%% Get parsed binary +get_parsed_binary(Input, Unparsed) -> + {First, _} = split_binary(Input, byte_size(Input) - byte_size_exl_head(Unparsed)), + First. + + +%% Return all bytes of the binary except the last one. The binary must be non-empty. +init_binary(B) -> + {Init, _} = + split_binary(B, byte_size(B) - 1), + Init. + + +%% Returns the size of a binary exluding the first element. +%% Used in calls to split_binary(). +-spec byte_size_exl_head(binary()) -> number(). +byte_size_exl_head(<<>>) -> 0; +byte_size_exl_head(Binary) -> byte_size(Binary) + 1. + + +%%------------------------------------------------------------------------- +%% [RFC 3986, Chapter 2.1. Percent-Encoding] +%% +%% A percent-encoding mechanism is used to represent a data octet in a +%% component when that octet's corresponding character is outside the +%% allowed set or is being used as a delimiter of, or within, the +%% component. A percent-encoded octet is encoded as a character +%% triplet, consisting of the percent character "%" followed by the two +%% hexadecimal digits representing that octet's numeric value. For +%% example, "%20" is the percent-encoding for the binary octet +%% "00100000" (ABNF: %x20), which in US-ASCII corresponds to the space +%% character (SP). Section 2.4 describes when percent-encoding and +%% decoding is applied. +%% +%% pct-encoded = "%" HEXDIG HEXDIG +%%------------------------------------------------------------------------- +-spec decode_userinfo(binary()) -> binary(). +decode_userinfo(Cs) -> + check_utf8(decode(Cs, fun is_userinfo/1, <<>>)). + +-spec decode_host(binary()) -> binary(). +decode_host(Cs) -> + check_utf8(decode(Cs, fun is_host/1, <<>>)). + +-spec decode_path(binary()) -> binary(). +decode_path(Cs) -> + check_utf8(decode(Cs, fun is_path/1, <<>>)). + +-spec decode_query(binary()) -> binary(). +decode_query(Cs) -> + check_utf8(decode(Cs, fun is_query/1, <<>>)). + +-spec decode_fragment(binary()) -> binary(). +decode_fragment(Cs) -> + check_utf8(decode(Cs, fun is_fragment/1, <<>>)). + + +%% Returns Cs if it is utf8 encoded. +check_utf8(Cs) -> + case unicode:characters_to_list(Cs) of + {incomplete,_,_} -> + throw({error,invalid_utf8,Cs}); + {error,_,_} -> + throw({error,invalid_utf8,Cs}); + _ -> Cs + end. + +%%------------------------------------------------------------------------- +%% Percent-encode +%%------------------------------------------------------------------------- + +%% Only validates as scheme cannot have percent-encoded characters +-spec encode_scheme(list()|binary()) -> list() | binary(). +encode_scheme([]) -> + throw({error,invalid_scheme,""}); +encode_scheme(<<>>) -> + throw({error,invalid_scheme,<<>>}); +encode_scheme(Scheme) -> + case validate_scheme(Scheme) of + true -> Scheme; + false -> throw({error,invalid_scheme,Scheme}) + end. + +-spec encode_userinfo(list()|binary()) -> list() | binary(). +encode_userinfo(Cs) -> + encode(Cs, fun is_userinfo/1). + +-spec encode_host(list()|binary()) -> list() | binary(). +encode_host(Cs) -> + case classify_host(Cs) of + regname -> Cs; + ipv4 -> Cs; + ipv6 -> bracket_ipv6(Cs); + other -> encode(Cs, fun is_reg_name/1) + end. + +-spec encode_path(list()|binary()) -> list() | binary(). +encode_path(Cs) -> + encode(Cs, fun is_path/1). + +-spec encode_query(list()|binary()) -> list() | binary(). +encode_query(Cs) -> + encode(Cs, fun is_query/1). + +-spec encode_fragment(list()|binary()) -> list() | binary(). +encode_fragment(Cs) -> + encode(Cs, fun is_fragment/1). + +%%------------------------------------------------------------------------- +%% Helper funtions for percent-decode +%%------------------------------------------------------------------------- +decode(<<$%,C0,C1,Cs/binary>>, Fun, Acc) -> + case is_hex_digit(C0) andalso is_hex_digit(C1) of + true -> + B = ?HEX2DEC(C0)*16+?HEX2DEC(C1), + decode(Cs, Fun, <<Acc/binary, B>>); + false -> throw({error,invalid_percent_encoding,<<$%,C0,C1>>}) + end; +decode(<<C,Cs/binary>>, Fun, Acc) -> + case Fun(C) of + true -> decode(Cs, Fun, <<Acc/binary, C>>); + false -> throw({error,invalid_percent_encoding,<<C,Cs/binary>>}) + end; +decode(<<>>, _Fun, Acc) -> + Acc. + +%% Check if char is allowed in host +-spec is_host(char()) -> boolean(). +is_host($:) -> true; +is_host(Char) -> is_unreserved(Char) orelse is_sub_delim(Char). + +%% Check if char is allowed in path +-spec is_path(char()) -> boolean(). +is_path($/) -> true; +is_path(Char) -> is_pchar(Char). + + +%%------------------------------------------------------------------------- +%% Helper functions for percent-encode +%%------------------------------------------------------------------------- +-spec encode(list()|binary(), fun()) -> list() | binary(). +encode(Component, Fun) when is_list(Component) -> + B = unicode:characters_to_binary(Component), + unicode:characters_to_list(encode(B, Fun, <<>>)); +encode(Component, Fun) when is_binary(Component) -> + encode(Component, Fun, <<>>). +%% +encode(<<Char/utf8, Rest/binary>>, Fun, Acc) -> + C = encode_codepoint_binary(Char, Fun), + encode(Rest, Fun, <<Acc/binary,C/binary>>); +encode(<<Char, Rest/binary>>, _Fun, _Acc) -> + throw({error,invalid_input,<<Char,Rest/binary>>}); +encode(<<>>, _Fun, Acc) -> + Acc. + + +-spec encode_codepoint_binary(integer(), fun()) -> binary(). +encode_codepoint_binary(C, Fun) -> + case Fun(C) of + false -> percent_encode_binary(C); + true -> <<C>> + end. + + +-spec percent_encode_binary(integer()) -> binary(). +percent_encode_binary(Code) -> + percent_encode_binary(<<Code/utf8>>, <<>>). + + +percent_encode_binary(<<A:4,B:4,Rest/binary>>, Acc) -> + percent_encode_binary(Rest, <<Acc/binary,$%,(?DEC2HEX(A)),(?DEC2HEX(B))>>); +percent_encode_binary(<<>>, Acc) -> + Acc. + + +%%------------------------------------------------------------------------- +%%------------------------------------------------------------------------- +validate_scheme([]) -> true; +validate_scheme([H|T]) -> + case is_scheme(H) of + true -> validate_scheme(T); + false -> false + end; +validate_scheme(<<>>) -> true; +validate_scheme(<<H, Rest/binary>>) -> + case is_scheme(H) of + true -> validate_scheme(Rest); + false -> false + end. + + +%%------------------------------------------------------------------------- +%% Classifies hostname into the following categories: +%% regname, ipv4 - address does not contain reserved characters to be +%% percent-encoded +%% ipv6 - address does not contain reserved characters but it shall be +%% encolsed in brackets +%% other - address shall be percent-encoded +%%------------------------------------------------------------------------- +classify_host([]) -> other; +classify_host(Addr) when is_binary(Addr) -> + A = unicode:characters_to_list(Addr), + classify_host_ipv6(A); +classify_host(Addr) -> + classify_host_ipv6(Addr). + +classify_host_ipv6(Addr) -> + case is_ipv6_address(Addr) of + true -> ipv6; + false -> classify_host_ipv4(Addr) + end. + +classify_host_ipv4(Addr) -> + case is_ipv4_address(Addr) of + true -> ipv4; + false -> classify_host_regname(Addr) + end. + +classify_host_regname([]) -> regname; +classify_host_regname([H|T]) -> + case is_reg_name(H) of + true -> classify_host_regname(T); + false -> other + end. + +is_ipv4_address(Addr) -> + case inet:parse_ipv4strict_address(Addr) of + {ok, _} -> true; + {error, _} -> false + end. + +is_ipv6_address(Addr) -> + case inet:parse_ipv6strict_address(Addr) of + {ok, _} -> true; + {error, _} -> false + end. + +bracket_ipv6(Addr) when is_binary(Addr) -> + concat(<<$[,Addr/binary>>,<<$]>>); +bracket_ipv6(Addr) when is_list(Addr) -> + [$[|Addr] ++ "]". + + +%%------------------------------------------------------------------------- +%% Helper funtions for recompose +%%------------------------------------------------------------------------- + +%%------------------------------------------------------------------------- +%% Checks if input Map has valid combination of fields that can be +%% recomposed into a URI. +%% +%% The implementation is based on a decision tree that fulfills the +%% following rules: +%% - 'path' shall always be present in the input map +%% URI = scheme ":" hier-part [ "?" query ] [ "#" fragment ] +%% hier-part = "//" authority path-abempty +%% / path-absolute +%% / path-rootless +%% / path-empty +%% - 'host' shall be present in the input map when 'path' starts with +%% two slashes ("//") +%% path = path-abempty ; begins with "/" or is empty +%% / path-absolute ; begins with "/" but not "//" +%% / path-noscheme ; begins with a non-colon segment +%% / path-rootless ; begins with a segment +%% / path-empty ; zero characters +%% path-abempty = *( "/" segment ) +%% segment = *pchar +%% - 'host' shall be present if userinfo or port is present in input map +%% authority = [ userinfo "@" ] host [ ":" port ] +%% - All fields shall be valid (scheme, userinfo, host, port, path, query +%% or fragment). +%%------------------------------------------------------------------------- +is_valid_map(#{path := Path} = Map) -> + ((starts_with_two_slash(Path) andalso is_valid_map_host(Map)) + orelse + (maps:is_key(userinfo, Map) andalso is_valid_map_host(Map)) + orelse + (maps:is_key(port, Map) andalso is_valid_map_host(Map)) + orelse + all_fields_valid(Map)); +is_valid_map(#{}) -> + false. + + +is_valid_map_host(Map) -> + maps:is_key(host, Map) andalso all_fields_valid(Map). + + +all_fields_valid(Map) -> + Fun = fun(scheme, _, Acc) -> Acc; + (userinfo, _, Acc) -> Acc; + (host, _, Acc) -> Acc; + (port, _, Acc) -> Acc; + (path, _, Acc) -> Acc; + (query, _, Acc) -> Acc; + (fragment, _, Acc) -> Acc; + (_, _, _) -> false + end, + maps:fold(Fun, true, Map). + + +starts_with_two_slash([$/,$/|_]) -> + true; +starts_with_two_slash(?STRING_REST("//", _)) -> + true; +starts_with_two_slash(_) -> false. + + +update_scheme(#{scheme := Scheme}, _) -> + add_colon_postfix(encode_scheme(Scheme)); +update_scheme(#{}, _) -> + empty. + + +update_userinfo(#{userinfo := Userinfo}, empty) -> + add_auth_prefix(encode_userinfo(Userinfo)); +update_userinfo(#{userinfo := Userinfo}, URI) -> + concat(URI,add_auth_prefix(encode_userinfo(Userinfo))); +update_userinfo(#{}, empty) -> + empty; +update_userinfo(#{}, URI) -> + URI. + + +update_host(#{host := Host}, empty) -> + add_auth_prefix(encode_host(Host)); +update_host(#{host := Host} = Map, URI) -> + concat(URI,add_host_prefix(Map, encode_host(Host))); +update_host(#{}, empty) -> + empty; +update_host(#{}, URI) -> + URI. + + +%% URI cannot be empty for ports. E.g. ":8080" is not a valid URI +update_port(#{port := undefined}, URI) -> + concat(URI, <<":">>); +update_port(#{port := Port}, URI) -> + concat(URI,add_colon(encode_port(Port))); +update_port(#{}, URI) -> + URI. + + +update_path(#{path := Path}, empty) -> + encode_path(Path); +update_path(#{path := Path}, URI) -> + concat(URI,encode_path(Path)); +update_path(#{}, empty) -> + empty; +update_path(#{}, URI) -> + URI. + + +update_query(#{query := Query}, empty) -> + encode_query(Query); +update_query(#{query := Query}, URI) -> + concat(URI,add_question_mark(encode_query(Query))); +update_query(#{}, empty) -> + empty; +update_query(#{}, URI) -> + URI. + + +update_fragment(#{fragment := Fragment}, empty) -> + add_hashmark(encode_fragment(Fragment)); +update_fragment(#{fragment := Fragment}, URI) -> + concat(URI,add_hashmark(encode_fragment(Fragment))); +update_fragment(#{}, empty) -> + ""; +update_fragment(#{}, URI) -> + URI. + +%%------------------------------------------------------------------------- +%% Concatenates its arguments that can be lists and binaries. +%% The result is a list if at least one of its argument is a list and +%% binary otherwise. +%%------------------------------------------------------------------------- +concat(A, B) when is_binary(A), is_binary(B) -> + <<A/binary, B/binary>>; +concat(A, B) when is_binary(A), is_list(B) -> + unicode:characters_to_list(A) ++ B; +concat(A, B) when is_list(A) -> + A ++ maybe_to_list(B). + +add_hashmark(Comp) when is_binary(Comp) -> + <<$#, Comp/binary>>; +add_hashmark(Comp) when is_list(Comp) -> + [$#|Comp]. + +add_question_mark(Comp) when is_binary(Comp) -> + <<$?, Comp/binary>>; +add_question_mark(Comp) when is_list(Comp) -> + [$?|Comp]. + +add_colon(Comp) when is_binary(Comp) -> + <<$:, Comp/binary>>. + +add_colon_postfix(Comp) when is_binary(Comp) -> + <<Comp/binary,$:>>; +add_colon_postfix(Comp) when is_list(Comp) -> + Comp ++ ":". + +add_auth_prefix(Comp) when is_binary(Comp) -> + <<"//", Comp/binary>>; +add_auth_prefix(Comp) when is_list(Comp) -> + [$/,$/|Comp]. + +add_host_prefix(#{userinfo := _}, Host) when is_binary(Host) -> + <<$@,Host/binary>>; +add_host_prefix(#{}, Host) when is_binary(Host) -> + <<"//",Host/binary>>; +add_host_prefix(#{userinfo := _}, Host) when is_list(Host) -> + [$@|Host]; +add_host_prefix(#{}, Host) when is_list(Host) -> + [$/,$/|Host]. + +maybe_to_list(Comp) when is_binary(Comp) -> unicode:characters_to_list(Comp); +maybe_to_list(Comp) -> Comp. + +encode_port(Port) -> + integer_to_binary(Port). + +%%------------------------------------------------------------------------- +%% Helper functions for transcode +%%------------------------------------------------------------------------- + +%%------------------------------------------------------------------------- +%% uri_string:transcode(<<"x%00%00%00%F6"/utf32>>). +%% 1. Convert (transcode/2) input to list form (list of unicode codepoints) +%% "x%00%00%00%F6" +%% 2. Accumulate characters until percent-encoded segment (transcode/4). +%% Acc = "x" +%% 3. Convert percent-encoded triplets to binary form (transcode_pct/4) +%% <<0,0,0,246>> +%% 4. Transcode in-encoded binary to out-encoding (utf32 -> utf8): +%% <<195,182>> +%% 5. Percent-encode out-encoded binary: +%% <<"%C3%B6"/utf8>> = <<37,67,51,37,66,54>> +%% 6. Convert binary to list form, reverse it and append the accumulator +%% "6B%3C%" + "x" +%% 7. Reverse Acc and return it +%%------------------------------------------------------------------------- +transcode([$%,_C0,_C1|_Rest] = L, Acc, InEnc, OutEnc) -> + transcode_pct(L, Acc, <<>>, InEnc, OutEnc); +transcode([_C|_Rest] = L, Acc, InEnc, OutEnc) -> + transcode(L, Acc, [], InEnc, OutEnc). +%% +transcode([$%,_C0,_C1|_Rest] = L, Acc, List, InEncoding, OutEncoding) -> + transcode_pct(L, List ++ Acc, <<>>, InEncoding, OutEncoding); +transcode([C|Rest], Acc, List, InEncoding, OutEncoding) -> + transcode(Rest, Acc, [C|List], InEncoding, OutEncoding); +transcode([], Acc, List, _InEncoding, _OutEncoding) -> + lists:reverse(List ++ Acc). + + +%% Transcode percent-encoded segment +transcode_pct([$%,C0,C1|Rest] = L, Acc, B, InEncoding, OutEncoding) -> + case is_hex_digit(C0) andalso is_hex_digit(C1) of + true -> + Int = ?HEX2DEC(C0)*16+?HEX2DEC(C1), + transcode_pct(Rest, Acc, <<B/binary, Int>>, InEncoding, OutEncoding); + false -> throw({error, invalid_percent_encoding,L}) + end; +transcode_pct([_C|_Rest] = L, Acc, B, InEncoding, OutEncoding) -> + OutBinary = convert_to_binary(B, InEncoding, OutEncoding), + PctEncUtf8 = percent_encode_segment(OutBinary), + Out = lists:reverse(convert_to_list(PctEncUtf8, utf8)), + transcode(L, Out ++ Acc, [], InEncoding, OutEncoding); +transcode_pct([], Acc, B, InEncoding, OutEncoding) -> + OutBinary = convert_to_binary(B, InEncoding, OutEncoding), + PctEncUtf8 = percent_encode_segment(OutBinary), + Out = convert_to_list(PctEncUtf8, utf8), + lists:reverse(Acc) ++ Out. + + +%% Convert to binary +convert_to_binary(Binary, InEncoding, OutEncoding) -> + case unicode:characters_to_binary(Binary, InEncoding, OutEncoding) of + {error, _List, RestData} -> + throw({error, invalid_input, RestData}); + {incomplete, _List, RestData} -> + throw({error, invalid_input, RestData}); + Result -> + Result + end. + + +%% Convert to list +convert_to_list(Binary, InEncoding) -> + case unicode:characters_to_list(Binary, InEncoding) of + {error, _List, RestData} -> + throw({error, invalid_input, RestData}); + {incomplete, _List, RestData} -> + throw({error, invalid_input, RestData}); + Result -> + Result + end. + + +%% Flatten input list +flatten_list([], _) -> + []; +flatten_list(L, InEnc) -> + flatten_list(L, InEnc, []). +%% +flatten_list([H|T], InEnc, Acc) when is_binary(H) -> + L = convert_to_list(H, InEnc), + flatten_list(T, InEnc, lists:reverse(L) ++ Acc); +flatten_list([H|T], InEnc, Acc) when is_list(H) -> + flatten_list(H ++ T, InEnc, Acc); +flatten_list([H|T], InEnc, Acc) -> + flatten_list(T, InEnc, [H|Acc]); +flatten_list([], _InEnc, Acc) -> + lists:reverse(Acc); +flatten_list(Arg, _, _) -> + throw({error, invalid_input, Arg}). + + +percent_encode_segment(Segment) -> + percent_encode_binary(Segment, <<>>). + + +%%------------------------------------------------------------------------- +%% Helper functions for compose_query +%%------------------------------------------------------------------------- + +%% Returns separator to be used between key-value pairs +get_separator(L) when length(L) =:= 0 -> + <<>>; +get_separator(_L) -> + <<"&">>. + + +%% HTML 5.2 - 4.10.21.6 URL-encoded form data - WHATWG URL (10 Jan 2018) - UTF-8 +%% HTML 5.0 - 4.10.22.6 URL-encoded form data - encoding (non UTF-8) +form_urlencode(Cs, [{encoding, latin1}]) when is_list(Cs) -> + B = convert_to_binary(Cs, utf8, utf8), + html5_byte_encode(base10_encode(B)); +form_urlencode(Cs, [{encoding, latin1}]) when is_binary(Cs) -> + html5_byte_encode(base10_encode(Cs)); +form_urlencode(Cs, [{encoding, Encoding}]) + when is_list(Cs), Encoding =:= utf8; Encoding =:= unicode -> + B = convert_to_binary(Cs, utf8, Encoding), + html5_byte_encode(B); +form_urlencode(Cs, [{encoding, Encoding}]) + when is_binary(Cs), Encoding =:= utf8; Encoding =:= unicode -> + html5_byte_encode(Cs); +form_urlencode(Cs, [{encoding, Encoding}]) when is_list(Cs); is_binary(Cs) -> + throw({error,invalid_encoding, Encoding}); +form_urlencode(Cs, _) -> + throw({error,invalid_input, Cs}). + + +%% For each character in the entry's name and value that cannot be expressed using +%% the selected character encoding, replace the character by a string consisting of +%% a U+0026 AMPERSAND character (&), a "#" (U+0023) character, one or more ASCII +%% digits representing the Unicode code point of the character in base ten, and +%% finally a ";" (U+003B) character. +base10_encode(Cs) -> + base10_encode(Cs, <<>>). +%% +base10_encode(<<>>, Acc) -> + Acc; +base10_encode(<<H/utf8,T/binary>>, Acc) when H > 255 -> + Base10 = convert_to_binary(integer_to_list(H,10), utf8, utf8), + base10_encode(T, <<Acc/binary,"&#",Base10/binary,$;>>); +base10_encode(<<H/utf8,T/binary>>, Acc) -> + base10_encode(T, <<Acc/binary,H>>). + + +html5_byte_encode(B) -> + html5_byte_encode(B, <<>>). +%% +html5_byte_encode(<<>>, Acc) -> + Acc; +html5_byte_encode(<<$ ,T/binary>>, Acc) -> + html5_byte_encode(T, <<Acc/binary,$+>>); +html5_byte_encode(<<H,T/binary>>, Acc) -> + case is_url_char(H) of + true -> + html5_byte_encode(T, <<Acc/binary,H>>); + false -> + <<A:4,B:4>> = <<H>>, + html5_byte_encode(T, <<Acc/binary,$%,(?DEC2HEX(A)),(?DEC2HEX(B))>>) + end; +html5_byte_encode(H, _Acc) -> + throw({error,invalid_input, H}). + + +%% Return true if input char can appear in form-urlencoded string +%% Allowed chararacters: +%% 0x2A, 0x2D, 0x2E, 0x30 to 0x39, 0x41 to 0x5A, +%% 0x5F, 0x61 to 0x7A +is_url_char(C) + when C =:= 16#2A; C =:= 16#2D; + C =:= 16#2E; C =:= 16#5F; + 16#30 =< C, C =< 16#39; + 16#41 =< C, C =< 16#5A; + 16#61 =< C, C =< 16#7A -> true; +is_url_char(_) -> false. + + +%%------------------------------------------------------------------------- +%% Helper functions for dissect_query +%%------------------------------------------------------------------------- +dissect_query_key(<<$=,T/binary>>, IsList, Acc, Key, Value) -> + dissect_query_value(T, IsList, Acc, Key, Value); +dissect_query_key(<<"&#",T/binary>>, IsList, Acc, Key, Value) -> + dissect_query_key(T, IsList, Acc, <<Key/binary,"&#">>, Value); +dissect_query_key(<<$&,_T/binary>>, _IsList, _Acc, _Key, _Value) -> + throw({error, missing_value, "&"}); +dissect_query_key(<<H,T/binary>>, IsList, Acc, Key, Value) -> + dissect_query_key(T, IsList, Acc, <<Key/binary,H>>, Value); +dissect_query_key(B, _, _, _, _) -> + throw({error, missing_value, B}). + + +dissect_query_value(<<$&,T/binary>>, IsList, Acc, Key, Value) -> + K = form_urldecode(IsList, Key), + V = form_urldecode(IsList, Value), + dissect_query_key(T, IsList, [{K,V}|Acc], <<>>, <<>>); +dissect_query_value(<<H,T/binary>>, IsList, Acc, Key, Value) -> + dissect_query_value(T, IsList, Acc, Key, <<Value/binary,H>>); +dissect_query_value(<<>>, IsList, Acc, Key, Value) -> + K = form_urldecode(IsList, Key), + V = form_urldecode(IsList, Value), + lists:reverse([{K,V}|Acc]). + + +%% HTML 5.2 - 4.10.21.6 URL-encoded form data - WHATWG URL (10 Jan 2018) - UTF-8 +%% HTML 5.0 - 4.10.22.6 URL-encoded form data - decoding (non UTF-8) +form_urldecode(true, B) -> + Result = base10_decode(form_urldecode(B, <<>>)), + convert_to_list(Result, utf8); +form_urldecode(false, B) -> + base10_decode(form_urldecode(B, <<>>)); +form_urldecode(<<>>, Acc) -> + Acc; +form_urldecode(<<$+,T/binary>>, Acc) -> + form_urldecode(T, <<Acc/binary,$ >>); +form_urldecode(<<$%,C0,C1,T/binary>>, Acc) -> + case is_hex_digit(C0) andalso is_hex_digit(C1) of + true -> + V = ?HEX2DEC(C0)*16+?HEX2DEC(C1), + form_urldecode(T, <<Acc/binary, V>>); + false -> + L = convert_to_list(<<$%,C0,C1,T/binary>>, utf8), + throw({error, invalid_percent_encoding, L}) + end; +form_urldecode(<<H/utf8,T/binary>>, Acc) -> + form_urldecode(T, <<Acc/binary,H/utf8>>); +form_urldecode(<<H,_/binary>>, _Acc) -> + throw({error, invalid_character, [H]}). + +base10_decode(Cs) -> + base10_decode(Cs, <<>>). +% +base10_decode(<<>>, Acc) -> + Acc; +base10_decode(<<"&#",T/binary>>, Acc) -> + base10_decode_unicode(T, Acc); +base10_decode(<<H/utf8,T/binary>>, Acc) -> + base10_decode(T,<<Acc/binary,H/utf8>>); +base10_decode(<<H,_/binary>>, _) -> + throw({error, invalid_input, [H]}). + + +base10_decode_unicode(B, Acc) -> + base10_decode_unicode(B, 0, Acc). +%% +base10_decode_unicode(<<H/utf8,T/binary>>, Codepoint, Acc) when $0 =< H, H =< $9 -> + Res = Codepoint * 10 + (H - $0), + base10_decode_unicode(T, Res, Acc); +base10_decode_unicode(<<$;,T/binary>>, Codepoint, Acc) -> + base10_decode(T, <<Acc/binary,Codepoint/utf8>>); +base10_decode_unicode(<<H,_/binary>>, _, _) -> + throw({error, invalid_input, [H]}). + + +%%------------------------------------------------------------------------- +%% Helper functions for normalize +%%------------------------------------------------------------------------- + +normalize_map(URIMap) -> + normalize_path_segment( + normalize_scheme_based( + normalize_case(URIMap))). + + +%% 6.2.2.1. Case Normalization +normalize_case(#{scheme := Scheme, host := Host} = Map) -> + Map#{scheme => to_lower(Scheme), + host => to_lower(Host)}; +normalize_case(#{host := Host} = Map) -> + Map#{host => to_lower(Host)}; +normalize_case(#{scheme := Scheme} = Map) -> + Map#{scheme => to_lower(Scheme)}; +normalize_case(#{} = Map) -> + Map. + + +to_lower(Cs) when is_list(Cs) -> + B = convert_to_binary(Cs, utf8, utf8), + convert_to_list(to_lower(B), utf8); +to_lower(Cs) when is_binary(Cs) -> + to_lower(Cs, <<>>). +%% +to_lower(<<C,Cs/binary>>, Acc) when $A =< C, C =< $Z -> + to_lower(Cs, <<Acc/binary,(C + 32)>>); +to_lower(<<C,Cs/binary>>, Acc) -> + to_lower(Cs, <<Acc/binary,C>>); +to_lower(<<>>, Acc) -> + Acc. + + +%% 6.2.2.3. Path Segment Normalization +%% 5.2.4. Remove Dot Segments +normalize_path_segment(Map) -> + Path = maps:get(path, Map, undefined), + Map#{path => remove_dot_segments(Path)}. + + +remove_dot_segments(Path) when is_binary(Path) -> + remove_dot_segments(Path, <<>>); +remove_dot_segments(Path) when is_list(Path) -> + B = convert_to_binary(Path, utf8, utf8), + B1 = remove_dot_segments(B, <<>>), + convert_to_list(B1, utf8). +%% +remove_dot_segments(<<>>, Output) -> + Output; +remove_dot_segments(<<"../",T/binary>>, Output) -> + remove_dot_segments(T, Output); +remove_dot_segments(<<"./",T/binary>>, Output) -> + remove_dot_segments(T, Output); +remove_dot_segments(<<"/./",T/binary>>, Output) -> + remove_dot_segments(<<$/,T/binary>>, Output); +remove_dot_segments(<<"/.">>, Output) -> + remove_dot_segments(<<$/>>, Output); +remove_dot_segments(<<"/../",T/binary>>, Output) -> + Out1 = remove_last_segment(Output), + remove_dot_segments(<<$/,T/binary>>, Out1); +remove_dot_segments(<<"/..">>, Output) -> + Out1 = remove_last_segment(Output), + remove_dot_segments(<<$/>>, Out1); +remove_dot_segments(<<$.>>, Output) -> + remove_dot_segments(<<>>, Output); +remove_dot_segments(<<"..">>, Output) -> + remove_dot_segments(<<>>, Output); +remove_dot_segments(Input, Output) -> + {First, Rest} = first_path_segment(Input), + remove_dot_segments(Rest, <<Output/binary,First/binary>>). + + +first_path_segment(Input) -> + F = first_path_segment(Input, <<>>), + split_binary(Input, byte_size(F)). +%% +first_path_segment(<<$/,T/binary>>, Acc) -> + first_path_segment_end(<<T/binary>>, <<Acc/binary,$/>>); +first_path_segment(<<C,T/binary>>, Acc) -> + first_path_segment_end(<<T/binary>>, <<Acc/binary,C>>). + + +first_path_segment_end(<<>>, Acc) -> + Acc; +first_path_segment_end(<<$/,_/binary>>, Acc) -> + Acc; +first_path_segment_end(<<C,T/binary>>, Acc) -> + first_path_segment_end(<<T/binary>>, <<Acc/binary,C>>). + + +remove_last_segment(<<>>) -> + <<>>; +remove_last_segment(B) -> + {Init, Last} = split_binary(B, byte_size(B) - 1), + case Last of + <<$/>> -> + Init; + _Char -> + remove_last_segment(Init) + end. + + +%% RFC 3986, 6.2.3. Scheme-Based Normalization +normalize_scheme_based(Map) -> + Scheme = maps:get(scheme, Map, undefined), + Port = maps:get(port, Map, undefined), + Path= maps:get(path, Map, undefined), + normalize_scheme_based(Map, Scheme, Port, Path). +%% +normalize_scheme_based(Map, Scheme, Port, Path) + when Scheme =:= "http"; Scheme =:= <<"http">> -> + normalize_http(Map, Port, Path); +normalize_scheme_based(Map, Scheme, Port, Path) + when Scheme =:= "https"; Scheme =:= <<"https">> -> + normalize_https(Map, Port, Path); +normalize_scheme_based(Map, Scheme, Port, _Path) + when Scheme =:= "ftp"; Scheme =:= <<"ftp">> -> + normalize_ftp(Map, Port); +normalize_scheme_based(Map, Scheme, Port, _Path) + when Scheme =:= "ssh"; Scheme =:= <<"ssh">> -> + normalize_ssh_sftp(Map, Port); +normalize_scheme_based(Map, Scheme, Port, _Path) + when Scheme =:= "sftp"; Scheme =:= <<"sftp">> -> + normalize_ssh_sftp(Map, Port); +normalize_scheme_based(Map, Scheme, Port, _Path) + when Scheme =:= "tftp"; Scheme =:= <<"tftp">> -> + normalize_tftp(Map, Port); +normalize_scheme_based(Map, _, _, _) -> + Map. + + +normalize_http(Map, Port, Path) -> + M1 = normalize_port(Map, Port, 80), + normalize_http_path(M1, Path). + + +normalize_https(Map, Port, Path) -> + M1 = normalize_port(Map, Port, 443), + normalize_http_path(M1, Path). + + +normalize_ftp(Map, Port) -> + normalize_port(Map, Port, 21). + + +normalize_ssh_sftp(Map, Port) -> + normalize_port(Map, Port, 22). + + +normalize_tftp(Map, Port) -> + normalize_port(Map, Port, 69). + + +normalize_port(Map, Port, Default) -> + case Port of + Default -> + maps:remove(port, Map); + _Else -> + Map + end. + + +normalize_http_path(Map, Path) -> + case Path of + "" -> + Map#{path => "/"}; + <<>> -> + Map#{path => <<"/">>}; + _Else -> + Map + end. diff --git a/lib/stdlib/src/zip.erl b/lib/stdlib/src/zip.erl index 81f927f399..39be2abff6 100644 --- a/lib/stdlib/src/zip.erl +++ b/lib/stdlib/src/zip.erl @@ -457,8 +457,7 @@ do_zip(F, Files, Options) -> Out3 = Output({close, F}, Out2), {ok, Out3} catch - C:R -> - Stk = erlang:get_stacktrace(), + C:R:Stk -> zlib:close(Z), Output({close, F}, Out0), erlang:raise(C, R, Stk) diff --git a/lib/stdlib/test/Makefile b/lib/stdlib/test/Makefile index 7b79dcf04d..ae2e3d0e2b 100644 --- a/lib/stdlib/test/Makefile +++ b/lib/stdlib/test/Makefile @@ -69,6 +69,7 @@ MODULES= \ sets_test_lib \ sofs_SUITE \ stdlib_SUITE \ + stdlib_bench_SUITE \ string_SUITE \ supervisor_1 \ supervisor_2 \ @@ -86,6 +87,7 @@ MODULES= \ timer_simple_SUITE \ unicode_SUITE \ unicode_util_SUITE \ + uri_string_SUITE \ win32reg_SUITE \ y2k_SUITE \ select_SUITE \ @@ -93,7 +95,8 @@ MODULES= \ random_unicode_list \ random_iolist \ error_logger_forwarder \ - maps_SUITE + maps_SUITE \ + zzz_SUITE ERL_FILES= $(MODULES:%=%.erl) @@ -146,7 +149,7 @@ release_spec: opt release_tests_spec: make_emakefile $(INSTALL_DIR) "$(RELSYSDIR)" - $(INSTALL_DATA) stdlib.spec $(EMAKEFILE) \ + $(INSTALL_DATA) stdlib.spec stdlib_bench.spec $(EMAKEFILE) \ $(ERL_FILES) $(COVERFILE) "$(RELSYSDIR)" chmod -R u+w "$(RELSYSDIR)" @tar cf - *_SUITE_data | (cd "$(RELSYSDIR)"; tar xf -) diff --git a/lib/stdlib/test/array_SUITE.erl b/lib/stdlib/test/array_SUITE.erl index 5836f275ba..956582c4fd 100644 --- a/lib/stdlib/test/array_SUITE.erl +++ b/lib/stdlib/test/array_SUITE.erl @@ -141,10 +141,10 @@ t(What) -> io:format("Test ~p ~n",[T]), try ?MODULE:T([]) - catch _E:_R -> + catch _E:_R:_S -> Line = get(test_server_loc), io:format("Failed ~p:~p ~p ~p~n ~p~n", - [T,Line,_E,_R, erlang:get_stacktrace()]) + [T,Line,_E,_R,_S]) end end, What). @@ -161,8 +161,8 @@ extract_tests() -> end, [Call(Test) || Test <- Tests], io:format("Tests ~p~n", [Tests]) - catch _:Err -> - io:format("Error: ~p ~p~n", [Err, erlang:get_stacktrace()]) + catch _:Err:Stacktrace -> + io:format("Error: ~p ~p~n", [Err, Stacktrace]) end, file:close(In), file:close(Out). diff --git a/lib/stdlib/test/base64_SUITE.erl b/lib/stdlib/test/base64_SUITE.erl index 48b3f5f959..1fc4c3fc0e 100644 --- a/lib/stdlib/test/base64_SUITE.erl +++ b/lib/stdlib/test/base64_SUITE.erl @@ -97,10 +97,9 @@ base64_otp_5635(Config) when is_list(Config) -> <<"===">> = base64:decode(base64:encode("===")), ok. %%------------------------------------------------------------------------- -%% OTP-6279: Guard needed so that function fails in a correct -%% way for faulty input, i.e. function_clause. +%% OTP-6279: Make sure illegal characters are rejected when decoding. base64_otp_6279(Config) when is_list(Config) -> - {'EXIT',{function_clause, _}} = (catch base64:decode("dGVzda==a")), + {'EXIT',_} = (catch base64:decode("dGVzda==a")), ok. %%------------------------------------------------------------------------- %% Encode and decode big binaries. @@ -115,48 +114,61 @@ big(Config) when is_list(Config) -> %%------------------------------------------------------------------------- %% Make sure illegal characters are rejected when decoding. illegal(Config) when is_list(Config) -> - {'EXIT',{function_clause, _}} = (catch base64:decode("()")), + %% A few samples with different error reasons. Nothing can be + %% assumed about the reason for the crash. + {'EXIT',_} = (catch base64:decode("()")), + {'EXIT',_} = (catch base64:decode(<<19:8,20:8,21:8,22:8>>)), + {'EXIT',_} = (catch base64:decode([19,20,21,22])), + {'EXIT',_} = (catch base64:decode_to_string(<<19:8,20:8,21:8,22:8>>)), + {'EXIT',_} = (catch base64:decode_to_string([19,20,21,22])), ok. %%------------------------------------------------------------------------- %% mime_decode and mime_decode_to_string have different implementations -%% so test both with the same input separately. Both functions have -%% the same implementation for binary/string arguments. +%% so test both with the same input separately. %% %% Test base64:mime_decode/1. mime_decode(Config) when is_list(Config) -> + MimeDecode = fun(In) -> + Out = base64:mime_decode(In), + Out = base64:mime_decode(binary_to_list(In)) + end, %% Test correct padding - <<"one">> = base64:mime_decode(<<"b25l">>), - <<"on">> = base64:mime_decode(<<"b24=">>), - <<"o">> = base64:mime_decode(<<"bw==">>), + <<"one">> = MimeDecode(<<"b25l">>), + <<"on">> = MimeDecode(<<"b24=">>), + <<"o">> = MimeDecode(<<"bw==">>), %% Test 1 extra padding - <<"one">> = base64:mime_decode(<<"b25l= =">>), - <<"on">> = base64:mime_decode(<<"b24== =">>), - <<"o">> = base64:mime_decode(<<"bw=== =">>), + <<"one">> = MimeDecode(<<"b25l= =">>), + <<"on">> = MimeDecode(<<"b24== =">>), + <<"o">> = MimeDecode(<<"bw=== =">>), %% Test 2 extra padding - <<"one">> = base64:mime_decode(<<"b25l===">>), - <<"on">> = base64:mime_decode(<<"b24====">>), - <<"o">> = base64:mime_decode(<<"bw=====">>), + <<"one">> = MimeDecode(<<"b25l===">>), + <<"on">> = MimeDecode(<<"b24====">>), + <<"o">> = MimeDecode(<<"bw=====">>), %% Test misc embedded padding - <<"one">> = base64:mime_decode(<<"b2=5l===">>), - <<"on">> = base64:mime_decode(<<"b=24====">>), - <<"o">> = base64:mime_decode(<<"b=w=====">>), + <<"one">> = MimeDecode(<<"b2=5l===">>), + <<"on">> = MimeDecode(<<"b=24====">>), + <<"o">> = MimeDecode(<<"b=w=====">>), %% Test misc white space and illegals with embedded padding - <<"one">> = base64:mime_decode(<<" b~2=\r\n5()l===">>), - <<"on">> = base64:mime_decode(<<"\tb =2\"¤4=¤= ==">>), - <<"o">> = base64:mime_decode(<<"\nb=w=====">>), + <<"one">> = MimeDecode(<<" b~2=\r\n5()l===">>), + <<"on">> = MimeDecode(<<"\tb =2\"¤4=¤= ==">>), + <<"o">> = MimeDecode(<<"\nb=w=====">>), %% Two pads <<"Aladdin:open sesame">> = - base64:mime_decode("QWxhZGRpbjpvc()GVuIHNlc2FtZQ=="), + MimeDecode(<<"QWxhZGRpbjpvc()GVuIHNlc2FtZQ==">>), %% One pad to ignore, followed by more text - <<"Hello World!!">> = base64:mime_decode(<<"SGVsb)(G8gV29ybGQ=h IQ= =">>), + <<"Hello World!!">> = MimeDecode(<<"SGVsb)(G8gV29ybGQ=h IQ= =">>), %% No pad <<"Aladdin:open sesam">> = - base64:mime_decode("QWxhZGRpbjpvcG¤\")(VuIHNlc2Ft"), + MimeDecode(<<"QWxhZGRpbjpvcG¤\")(VuIHNlc2Ft">>), %% Encoded base 64 strings may be divided by non base 64 chars. %% In this cases whitespaces. <<"0123456789!@#0^&*();:<>,. []{}">> = - base64:mime_decode( + MimeDecode( <<"MDEy MzQ1Njc4 \tOSFAIzBeJ \nio)(oKTs6 PD4sLi \r\nBbXXt9">>), + %% Zeroes + <<"012">> = MimeDecode(<<"\000M\000D\000E\000y=\000">>), + <<"o">> = MimeDecode(<<"bw==\000">>), + <<"o">> = MimeDecode(<<"bw=\000=">>), ok. %%------------------------------------------------------------------------- @@ -165,39 +177,48 @@ mime_decode(Config) when is_list(Config) -> %% Test base64:mime_decode_to_string/1. mime_decode_to_string(Config) when is_list(Config) -> + MimeDecodeToString = + fun(In) -> + Out = base64:mime_decode_to_string(In), + Out = base64:mime_decode_to_string(binary_to_list(In)) + end, %% Test correct padding - "one" = base64:mime_decode_to_string(<<"b25l">>), - "on" = base64:mime_decode_to_string(<<"b24=">>), - "o" = base64:mime_decode_to_string(<<"bw==">>), + "one" = MimeDecodeToString(<<"b25l">>), + "on" = MimeDecodeToString(<<"b24=">>), + "o" = MimeDecodeToString(<<"bw==">>), %% Test 1 extra padding - "one" = base64:mime_decode_to_string(<<"b25l= =">>), - "on" = base64:mime_decode_to_string(<<"b24== =">>), - "o" = base64:mime_decode_to_string(<<"bw=== =">>), + "one" = MimeDecodeToString(<<"b25l= =">>), + "on" = MimeDecodeToString(<<"b24== =">>), + "o" = MimeDecodeToString(<<"bw=== =">>), %% Test 2 extra padding - "one" = base64:mime_decode_to_string(<<"b25l===">>), - "on" = base64:mime_decode_to_string(<<"b24====">>), - "o" = base64:mime_decode_to_string(<<"bw=====">>), + "one" = MimeDecodeToString(<<"b25l===">>), + "on" = MimeDecodeToString(<<"b24====">>), + "o" = MimeDecodeToString(<<"bw=====">>), %% Test misc embedded padding - "one" = base64:mime_decode_to_string(<<"b2=5l===">>), - "on" = base64:mime_decode_to_string(<<"b=24====">>), - "o" = base64:mime_decode_to_string(<<"b=w=====">>), + "one" = MimeDecodeToString(<<"b2=5l===">>), + "on" = MimeDecodeToString(<<"b=24====">>), + "o" = MimeDecodeToString(<<"b=w=====">>), %% Test misc white space and illegals with embedded padding - "one" = base64:mime_decode_to_string(<<" b~2=\r\n5()l===">>), - "on" = base64:mime_decode_to_string(<<"\tb =2\"¤4=¤= ==">>), - "o" = base64:mime_decode_to_string(<<"\nb=w=====">>), + "one" = MimeDecodeToString(<<" b~2=\r\n5()l===">>), + "on" = MimeDecodeToString(<<"\tb =2\"¤4=¤= ==">>), + "o" = MimeDecodeToString(<<"\nb=w=====">>), %% Two pads "Aladdin:open sesame" = - base64:mime_decode_to_string("QWxhZGRpbjpvc()GVuIHNlc2FtZQ=="), + MimeDecodeToString(<<"QWxhZGRpbjpvc()GVuIHNlc2FtZQ==">>), %% One pad to ignore, followed by more text - "Hello World!!" = base64:mime_decode_to_string(<<"SGVsb)(G8gV29ybGQ=h IQ= =">>), + "Hello World!!" = MimeDecodeToString(<<"SGVsb)(G8gV29ybGQ=h IQ= =">>), %% No pad "Aladdin:open sesam" = - base64:mime_decode_to_string("QWxhZGRpbjpvcG¤\")(VuIHNlc2Ft"), + MimeDecodeToString(<<"QWxhZGRpbjpvcG¤\")(VuIHNlc2Ft">>), %% Encoded base 64 strings may be divided by non base 64 chars. %% In this cases whitespaces. "0123456789!@#0^&*();:<>,. []{}" = - base64:mime_decode_to_string( + MimeDecodeToString( <<"MDEy MzQ1Njc4 \tOSFAIzBeJ \nio)(oKTs6 PD4sLi \r\nBbXXt9">>), + %% Zeroes + "012" = MimeDecodeToString(<<"\000M\000D\000E\000y=\000">>), + "o" = MimeDecodeToString(<<"bw==\000">>), + "o" = MimeDecodeToString(<<"bw=\000=">>), ok. %%------------------------------------------------------------------------- diff --git a/lib/stdlib/test/calendar_SUITE.erl b/lib/stdlib/test/calendar_SUITE.erl index 20053dfe54..52c3cc68eb 100644 --- a/lib/stdlib/test/calendar_SUITE.erl +++ b/lib/stdlib/test/calendar_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1997-2016. All Rights Reserved. +%% Copyright Ericsson AB 1997-2018. 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,8 @@ leap_years/1, last_day_of_the_month/1, local_time_to_universal_time_dst/1, - iso_week_number/1]). + iso_week_number/1, + system_time/1]). -define(START_YEAR, 1947). -define(END_YEAR, 2012). @@ -40,7 +41,8 @@ suite() -> [{ct_hooks,[ts_install_cth]}]. all() -> [gregorian_days, gregorian_seconds, day_of_the_week, day_of_the_week_calibrate, leap_years, - last_day_of_the_month, local_time_to_universal_time_dst, iso_week_number]. + last_day_of_the_month, local_time_to_universal_time_dst, + iso_week_number, system_time]. groups() -> []. @@ -157,6 +159,22 @@ local_time_to_universal_time_dst_x(Config) when is_list(Config) -> iso_week_number(Config) when is_list(Config) -> check_iso_week_number(). +system_time(Config) when is_list(Config) -> + EpochDate = {{1970,1,1}, {0,0,0}}, + Epoch = calendar:datetime_to_gregorian_seconds(EpochDate), + Y0 = {{0,1,1},{0,0,0}}, + + EpochDate = calendar:system_time_to_universal_time(0, second), + 0 = calendar:datetime_to_gregorian_seconds(Y0), + Y0 = calendar:system_time_to_universal_time(-Epoch, second), + + T = erlang:system_time(second), + UDate = calendar:system_time_to_universal_time(T, second), + LDate = erlang:universaltime_to_localtime(UDate), + LDate = calendar:system_time_to_local_time(T, second), + + ok. + %% %% LOCAL FUNCTIONS %% diff --git a/lib/stdlib/test/dets_SUITE.erl b/lib/stdlib/test/dets_SUITE.erl index d667bd82a2..7d82790b82 100644 --- a/lib/stdlib/test/dets_SUITE.erl +++ b/lib/stdlib/test/dets_SUITE.erl @@ -3275,16 +3275,16 @@ otp_8856(Config) when is_list(Config) -> {ok, _} = dets:open_file(Tab, [{type, bag}, {file, File}]), spawn(fun()-> Me ! {1, dets:insert(Tab, [])} end), spawn(fun()-> Me ! {2, dets:insert_new(Tab, [])} end), - ok = dets:close(Tab), receive {1, ok} -> ok end, receive {2, true} -> ok end, + ok = dets:close(Tab), file:delete(File), {ok, _} = dets:open_file(Tab, [{type, set}, {file, File}]), spawn(fun() -> dets:delete(Tab, 0) end), spawn(fun() -> Me ! {3, dets:insert_new(Tab, {0,0})} end), - ok = dets:close(Tab), receive {3, true} -> ok end, + ok = dets:close(Tab), file:delete(File), ok. diff --git a/lib/stdlib/test/erl_eval_SUITE.erl b/lib/stdlib/test/erl_eval_SUITE.erl index c3ef4eb051..f4019d477b 100644 --- a/lib/stdlib/test/erl_eval_SUITE.erl +++ b/lib/stdlib/test/erl_eval_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1998-2016. All Rights Reserved. +%% Copyright Ericsson AB 1998-2018. 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. @@ -41,12 +41,14 @@ otp_8133/1, otp_10622/1, otp_13228/1, + otp_14826/1, funs/1, try_catch/1, eval_expr_5/1, zero_width/1, eep37/1, - eep43/1]). + eep43/1, + otp_15035/1]). %% %% Define to run outside of test server @@ -57,6 +59,7 @@ -export([count_down/2, count_down_fun/0, do_apply/2, local_func/3, local_func_value/2]). +-export([simple/0]). -ifdef(STANDALONE). -define(config(A,B),config(A,B)). @@ -83,9 +86,9 @@ all() -> pattern_expr, match_bin, guard_3, guard_4, guard_5, lc, simple_cases, unary_plus, apply_atom, otp_5269, otp_6539, otp_6543, otp_6787, otp_6977, otp_7550, - otp_8133, otp_10622, otp_13228, + otp_8133, otp_10622, otp_13228, otp_14826, funs, try_catch, eval_expr_5, zero_width, - eep37, eep43]. + eep37, eep43, otp_15035]. groups() -> []. @@ -988,6 +991,173 @@ otp_13228(_Config) -> EFH = {value, fun({io, fwrite}, [atom]) -> io_fwrite end}, {value, worked, []} = parse_and_run("foo(io:fwrite(atom)).", LFH, EFH). +%% OTP-14826: more accurate stacktrace. +otp_14826(_Config) -> + backtrace_check("fun(P) when is_pid(P) -> true end(a).", + function_clause, + [{erl_eval,'-inside-an-interpreted-fun-',[a],[]}, + {erl_eval,eval_fun,6}, + ?MODULE]), + backtrace_check("B.", + {unbound_var, 'B'}, + [{erl_eval,expr,2}, ?MODULE]), + backtrace_check("B.", + {unbound, 'B'}, + [{erl_eval,expr,5}, ?MODULE], + none, none), + backtrace_check("1/0.", + badarith, + [{erlang,'/',[1,0],[]}, + {erl_eval,do_apply,6}]), + backtrace_catch("catch 1/0.", + badarith, + [{erlang,'/',[1,0],[]}, + {erl_eval,do_apply,6}]), + check(fun() -> catch exit(foo) end, + "catch exit(foo).", + {'EXIT', foo}), + check(fun() -> catch throw(foo) end, + "catch throw(foo).", + foo), + backtrace_check("try 1/0 after foo end.", + badarith, + [{erlang,'/',[1,0],[]}, + {erl_eval,do_apply,6}]), + backtrace_catch("catch (try 1/0 after foo end).", + badarith, + [{erlang,'/',[1,0],[]}, + {erl_eval,do_apply,6}]), + backtrace_catch("try catch 1/0 after foo end.", + badarith, + [{erlang,'/',[1,0],[]}, + {erl_eval,do_apply,6}]), + backtrace_check("try a of b -> bar after foo end.", + {try_clause,a}, + [{erl_eval,try_clauses,8}]), + check(fun() -> X = try foo:bar() catch A:B:C -> {A,B} end, X end, + "try foo:bar() catch A:B:C -> {A,B} end.", + {error, undef}), + backtrace_check("C = 4, try foo:bar() catch A:B:C -> {A,B,C} end.", + stacktrace_bound, + [{erl_eval,check_stacktrace_vars,2}, + {erl_eval,try_clauses,8}], + none, none), + backtrace_catch("catch (try a of b -> bar after foo end).", + {try_clause,a}, + [{erl_eval,try_clauses,8}]), + backtrace_check("try 1/0 catch exit:a -> foo end.", + badarith, + [{erlang,'/',[1,0],[]}, + {erl_eval,do_apply,6}]), + Es = [{'try',1,[{call,1,{remote,1,{atom,1,foo},{atom,1,bar}},[]}], + [], + [{clause,1,[{tuple,1,[{var,1,'A'},{var,1,'B'},{atom,1,'C'}]}], + [],[{tuple,1,[{var,1,'A'},{var,1,'B'},{atom,1,'C'}]}]}],[]}], + try + erl_eval:exprs(Es, [], none, none), + ct:fail(stacktrace_variable) + catch + error:{illegal_stacktrace_variable,{atom,1,'C'}}:S -> + [{erl_eval,check_stacktrace_vars,2,_}, + {erl_eval,try_clauses,8,_}|_] = S + end, + backtrace_check("{1,1} = {A = 1, A = 2}.", + {badmatch, 1}, + [erl_eval, {lists,foldl,3}]), + backtrace_check("case a of a when foo:bar() -> x end.", + guard_expr, + [{erl_eval,guard0,4}], none, none), + backtrace_check("case a of foo() -> ok end.", + {illegal_pattern,{call,1,{atom,1,foo},[]}}, + [{erl_eval,match,4}], none, none), + backtrace_check("case a of b -> ok end.", + {case_clause,a}, + [{erl_eval,case_clauses,6}, ?MODULE]), + backtrace_check("if a =:= b -> ok end.", + if_clause, + [{erl_eval,if_clauses,5}, ?MODULE]), + backtrace_check("fun A(b) -> ok end(a).", + function_clause, + [{erl_eval,'-inside-an-interpreted-fun-',[a],[]}, + {erl_eval,eval_named_fun,8}, + ?MODULE]), + backtrace_check("[A || A <- a].", + {bad_generator, a}, + [{erl_eval,eval_generate,7}, {erl_eval, eval_lc, 6}]), + backtrace_check("<< <<A>> || <<A>> <= a>>.", + {bad_generator, a}, + [{erl_eval,eval_b_generate,7}, {erl_eval, eval_bc, 6}]), + backtrace_check("[A || A <- [1], begin a end].", + {bad_filter, a}, + [{erl_eval,eval_filter,6}, {erl_eval, eval_generate, 7}]), + fun() -> + {'EXIT', {{badarity, {_Fun, []}}, BT}} = + (catch parse_and_run("fun(A) -> A end().")), + check_backtrace([{erl_eval,do_apply,5}, ?MODULE], BT) + end(), + fun() -> + {'EXIT', {{badarity, {_Fun, []}}, BT}} = + (catch parse_and_run("fun F(A) -> A end().")), + check_backtrace([{erl_eval,do_apply,5}, ?MODULE], BT) + end(), + backtrace_check("foo().", + undef, + [{erl_eval,foo,0},{erl_eval,local_func,6}], + none, none), + backtrace_check("a orelse false.", + {badarg, a}, + [{erl_eval,expr,5}, ?MODULE]), + backtrace_check("a andalso false.", + {badarg, a}, + [{erl_eval,expr,5}, ?MODULE]), + backtrace_check("t = u.", + {badmatch, u}, + [{erl_eval,expr,5}, ?MODULE]), + backtrace_check("{math,sqrt}(2).", + {badfun, {math,sqrt}}, + [{erl_eval,expr,5}, ?MODULE]), + backtrace_check("erl_eval_SUITE:simple().", + simple, + [{?MODULE,simple1,0},{?MODULE,simple,0},erl_eval]), + Args = [{integer,1,I} || I <- lists:seq(1, 30)], + backtrace_check("fun(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18," + "19,20,21,22,23,24,25,26,27,28,29,30) -> a end.", + {argument_limit, + {'fun',1,[{clause,1,Args,[],[{atom,1,a}]}]}}, + [{erl_eval,expr,5}, ?MODULE]), + backtrace_check("fun F(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18," + "19,20,21,22,23,24,25,26,27,28,29,30) -> a end.", + {argument_limit, + {named_fun,1,'F',[{clause,1,Args,[],[{atom,1,a}]}]}}, + [{erl_eval,expr,5}, ?MODULE]), + backtrace_check("#r{}.", + {undef_record,r}, + [{erl_eval,expr,5}, ?MODULE], + none, none), + %% eval_bits + backtrace_check("<<100:8/bitstring>>.", + badarg, + [{eval_bits,eval_exp_field1,6}, + eval_bits,eval_bits,erl_eval]), + backtrace_check("<<100:8/foo>>.", + {undefined_bittype,foo}, + [{eval_bits,make_bit_type,3},eval_bits, + eval_bits,erl_eval], + none, none), + backtrace_check("B = <<\"foo\">>, <<B/binary-unit:7>>.", + badarg, + [{eval_bits,eval_exp_field1,6}, + eval_bits,eval_bits,erl_eval], + none, none), + ok. + +simple() -> + A = simple1(), + {A}. + +simple1() -> + erlang:error(simple). + %% Simple cases, just to cover some code. funs(Config) when is_list(Config) -> do_funs(none, none), @@ -1437,6 +1607,55 @@ eep43(Config) when is_list(Config) -> error_check("(#{})#{nonexisting:=value}.", {badkey,nonexisting}), ok. +otp_15035(Config) when is_list(Config) -> + check(fun() -> + fun() when #{} -> + a; + () when #{a => b} -> + b; + () when #{a => b} =:= #{a => b} -> + c + end() + end, + "fun() when #{} -> + a; + () when #{a => b} -> + b; + () when #{a => b} =:= #{a => b} -> + c + end().", + c), + check(fun() -> + F = fun(M) when M#{} -> + a; + (M) when M#{a => b} -> + b; + (M) when M#{a := b} -> + c; + (M) when M#{a := b} =:= M#{a := b} -> + d; + (M) when M#{a => b} =:= M#{a => b} -> + e + end, + {F(#{}), F(#{a => b})} + end, + "fun() -> + F = fun(M) when M#{} -> + a; + (M) when M#{a => b} -> + b; + (M) when M#{a := b} -> + c; + (M) when M#{a := b} =:= M#{a := b} -> + d; + (M) when M#{a => b} =:= M#{a => b} -> + e + end, + {F(#{}), F(#{a => b})} + end().", + {e, d}), + ok. + %% Check the string in different contexts: as is; in fun; from compiled code. check(F, String, Result) -> check1(F, String, Result), @@ -1488,6 +1707,43 @@ error_check(String, Result, LFH, EFH) -> ct:fail({eval, Other, Result}) end. +backtrace_check(String, Result, Backtrace) -> + case catch parse_and_run(String) of + {'EXIT', {Result, BT}} -> + check_backtrace(Backtrace, BT); + Other -> + ct:fail({eval, Other, Result}) + end. + +backtrace_check(String, Result, Backtrace, LFH, EFH) -> + case catch parse_and_run(String, LFH, EFH) of + {'EXIT', {Result, BT}} -> + check_backtrace(Backtrace, BT); + Other -> + ct:fail({eval, Other, Result}) + end. + +backtrace_catch(String, Result, Backtrace) -> + case parse_and_run(String) of + {value, {'EXIT', {Result, BT}}, _Bindings} -> + check_backtrace(Backtrace, BT); + Other -> + ct:fail({eval, Other, Result}) + end. + +check_backtrace([B1|Backtrace], [B2|BT]) -> + case {B1, B2} of + {M, {M,_,_,_}} -> + ok; + {{M,F,A}, {M,F,A,_}} -> + ok; + {B, B} -> + ok + end, + check_backtrace(Backtrace, BT); +check_backtrace([], _) -> + ok. + eval_string(String) -> {value, Result, _} = parse_and_run(String), Result. @@ -1499,8 +1755,8 @@ parse_and_run(String) -> parse_and_run(String, LFH, EFH) -> {ok,Tokens,_} = erl_scan:string(String), - {ok, [Expr]} = erl_parse:parse_exprs(Tokens), - erl_eval:expr(Expr, [], LFH, EFH). + {ok, Exprs} = erl_parse:parse_exprs(Tokens), + erl_eval:exprs(Exprs, [], LFH, EFH). no_final_dot(S) -> case lists:reverse(S) of diff --git a/lib/stdlib/test/erl_internal_SUITE.erl b/lib/stdlib/test/erl_internal_SUITE.erl index 789a9d4363..7d9df1f989 100644 --- a/lib/stdlib/test/erl_internal_SUITE.erl +++ b/lib/stdlib/test/erl_internal_SUITE.erl @@ -80,7 +80,7 @@ callbacks(application) -> callbacks(gen_server) -> [{init,1}, {handle_call,3}, {handle_cast,2}, {handle_info,2}, {terminate,2}, {code_change,3}, - {format_status,2}]; + {format_status,2}, {handle_continue, 2}]; callbacks(gen_fsm) -> [{init,1}, {handle_event,3}, {handle_sync_event,4}, {handle_info,3}, {terminate,3}, {code_change,4}, @@ -101,7 +101,7 @@ callbacks(supervisor) -> optional_callbacks(application) -> []; optional_callbacks(gen_server) -> - [{handle_info, 2}, {terminate, 2}, {code_change, 3}, {format_status, 2}]; + [{handle_info, 2}, {handle_continue, 2}, {terminate, 2}, {code_change, 3}, {format_status, 2}]; optional_callbacks(gen_fsm) -> [{handle_info, 3}, {terminate, 3}, {code_change, 4}, {format_status, 2}]; optional_callbacks(gen_event) -> diff --git a/lib/stdlib/test/erl_lint_SUITE.erl b/lib/stdlib/test/erl_lint_SUITE.erl index 272a71432a..f9ab83a120 100644 --- a/lib/stdlib/test/erl_lint_SUITE.erl +++ b/lib/stdlib/test/erl_lint_SUITE.erl @@ -66,7 +66,8 @@ otp_11851/1,otp_11879/1,otp_13230/1, record_errors/1, otp_11879_cont/1, non_latin1_module/1, otp_14323/1, - get_stacktrace/1, otp_14285/1, otp_14378/1]). + stacktrace_syntax/1, + otp_14285/1, otp_14378/1]). suite() -> [{ct_hooks,[ts_install_cth]}, @@ -87,7 +88,7 @@ all() -> maps, maps_type, maps_parallel_match, otp_11851, otp_11879, otp_13230, record_errors, otp_11879_cont, non_latin1_module, otp_14323, - get_stacktrace, otp_14285, otp_14378]. + stacktrace_syntax, otp_14285, otp_14378]. groups() -> [{unused_vars_warn, [], @@ -4054,82 +4055,40 @@ otp_14323(Config) -> [] = run(Config, Ts), ok. -get_stacktrace(Config) -> - Ts = [{old_catch, +stacktrace_syntax(Config) -> + Ts = [{guard, <<"t1() -> - catch error(foo), - erlang:get_stacktrace(). + try error(foo) + catch _:_:Stk when is_number(Stk) -> ok + end. ">>, [], - {warnings,[{3,erl_lint,{get_stacktrace,after_old_catch}}]}}, - {nowarn_get_stacktrace, + {errors,[{3,erl_lint,{stacktrace_guard,'Stk'}}],[]}}, + {bound, <<"t1() -> - catch error(foo), - erlang:get_stacktrace(). - ">>, - [nowarn_get_stacktrace], - []}, - {try_catch, - <<"t1(X) -> - try abs(X) of - _ -> - erlang:get_stacktrace() - catch - _:_ -> ok - end. - - t2() -> - try error(foo) - catch _:_ -> ok - end, - erlang:get_stacktrace(). - - t3() -> + Stk = [], try error(foo) - catch _:_ -> - try error(bar) - catch _:_ -> - ok - end, - erlang:get_stacktrace() - end. - - no_warning(X) -> - try - abs(X) - catch - _:_ -> - erlang:get_stacktrace() + catch _:_:Stk -> ok end. ">>, [], - {warnings,[{4,erl_lint,{get_stacktrace,wrong_part_of_try}}, - {13,erl_lint,{get_stacktrace,after_try}}, - {22,erl_lint,{get_stacktrace,after_try}}]}}, - {multiple_catch_clauses, - <<"maybe_error(Arg) -> - try 5 / Arg - catch - error:badarith -> - _Stacktrace = erlang:get_stacktrace(), - try io:nl() - catch - error:_ -> io:format('internal error') - end; - error:badarg -> - _Stacktrace = erlang:get_stacktrace(), - try io:format(qwe) - catch - error:_ -> io:format('internal error') - end - end. - ">>, + {errors,[{4,erl_lint,{stacktrace_bound,'Stk'}}],[]}}, + {guard_and_bound, + <<"t1() -> + Stk = [], + try error(foo) + catch _:_:Stk when is_integer(Stk) -> ok + end. + ">>, [], - []}], + {errors,[{4,erl_lint,{stacktrace_bound,'Stk'}}, + {4,erl_lint,{stacktrace_guard,'Stk'}}],[]}} + ], run(Config, Ts), ok. + %% Unicode atoms. otp_14285(Config) -> %% A small sample of all the errors and warnings in module erl_lint. diff --git a/lib/stdlib/test/error_logger_h_SUITE.erl b/lib/stdlib/test/error_logger_h_SUITE.erl index 1f2a9fda0b..9dc04f27a1 100644 --- a/lib/stdlib/test/error_logger_h_SUITE.erl +++ b/lib/stdlib/test/error_logger_h_SUITE.erl @@ -257,8 +257,7 @@ match_output([Item|T], Lines0, AtNode, Depth) -> Lines -> match_output(T, Lines, AtNode, Depth) catch - C:E -> - Stk = erlang:get_stacktrace(), + C:E:Stk -> io:format("ITEM: ~p", [Item]), io:format("LINES: ~p", [Lines0]), erlang:raise(C, E, Stk) diff --git a/lib/stdlib/test/ets_SUITE.erl b/lib/stdlib/test/ets_SUITE.erl index 1a8260b041..02211fa8df 100644 --- a/lib/stdlib/test/ets_SUITE.erl +++ b/lib/stdlib/test/ets_SUITE.erl @@ -55,6 +55,7 @@ -export([t_repair_continuation/1]). -export([t_match_spec_run/1]). -export([t_bucket_disappears/1]). +-export([t_named_select/1]). -export([otp_5340/1]). -export([otp_6338/1]). -export([otp_6842_select_1000/1]). @@ -78,6 +79,7 @@ -export([ets_all/1]). -export([massive_ets_all/1]). -export([take/1]). +-export([whereis_table/1]). -export([init_per_testcase/2, end_per_testcase/2]). %% Convenience for manual testing @@ -123,6 +125,7 @@ all() -> t_init_table, t_whitebox, t_delete_all_objects, t_insert_list, t_test_ms, t_select_delete, t_select_replace, t_ets_dets, memory, t_select_reverse, t_bucket_disappears, + t_named_select, select_fail, t_insert_new, t_repair_continuation, otp_5340, otp_6338, otp_6842_select_1000, otp_7665, otp_8732, meta_wb, grow_shrink, grow_pseudo_deleted, @@ -137,7 +140,8 @@ all() -> otp_9423, ets_all, massive_ets_all, - take]. + take, + whereis_table]. groups() -> [{new, [], @@ -203,6 +207,38 @@ t_bucket_disappears_do(Opts) -> true = ets:delete(abcd), verify_etsmem(EtsMem). +%% OTP-21: Test that select/1 fails if named table was deleted and recreated +%% and succeeds if table was renamed. +t_named_select(_Config) -> + repeat_for_opts(fun t_named_select_do/1). + +t_named_select_do(Opts) -> + EtsMem = etsmem(), + T = t_name_tid_select, + ets_new(T, [named_table | Opts]), + ets:insert(T, {1,11}), + ets:insert(T, {2,22}), + ets:insert(T, {3,33}), + MS = [{{'$1', 22}, [], ['$1']}], + {[2], Cont1} = ets:select(T, MS, 1), + ets:delete(T), + {'EXIT',{badarg,_}} = (catch ets:select(Cont1)), + ets_new(T, [named_table | Opts]), + {'EXIT',{badarg,_}} = (catch ets:select(Cont1)), + + true = ets:insert_new(T, {1,22}), + true = ets:insert_new(T, {2,22}), + true = ets:insert_new(T, {4,22}), + {[A,B], Cont2} = ets:select(T, MS, 2), + ets:rename(T, abcd), + {[C], '$end_of_table'} = ets:select(Cont2), + 7 = A + B + C, + + true = ets:delete(abcd), + verify_etsmem(EtsMem). + + + %% Check ets:match_spec_run/2. t_match_spec_run(Config) when is_list(Config) -> @@ -698,7 +734,7 @@ whitebox_2(Opts) -> ets:delete(T2), ok. -select_bound_chunk(Config) -> +select_bound_chunk(_Config) -> repeat_for_opts(fun select_bound_chunk_do/1, [all_types]). select_bound_chunk_do(Opts) -> @@ -1682,7 +1718,7 @@ do_random_test() -> ets:delete(Set), verify_etsmem(EtsMem). -%% Ttest various variants of update_element. +%% Test various variants of update_element. update_element(Config) when is_list(Config) -> EtsMem = etsmem(), repeat_for_opts(fun update_element_opts/1), @@ -2283,13 +2319,8 @@ write_concurrency(Config) when is_list(Config) -> NoHashMem = ets:info(No7,memory), NoHashMem = ets:info(No8,memory), - case erlang:system_info(smp_support) of - true -> - true = YesMem > NoHashMem, - true = YesMem > NoTreeMem; - false -> - true = YesMem =:= NoHashMem - end, + true = YesMem > NoHashMem, + true = YesMem > NoTreeMem, {'EXIT',{badarg,_}} = (catch ets_new(foo,[public,{write_concurrency,foo}])), {'EXIT',{badarg,_}} = (catch ets_new(foo,[public,{write_concurrency}])), @@ -3652,7 +3683,7 @@ verify_rescheduling_exit(Config, ForEachData, Flags, Fix, NOTabs, NOProcs) -> XScheds = count_exit_sched(TP), io:format("~p XScheds=~p~n", [TP, XScheds]), - true = XScheds >= 5 + true = XScheds >= 3 end, TPs), stop_loopers(LPs), @@ -4104,6 +4135,7 @@ info_do(Opts) -> {value, {keypos, 2}} = lists:keysearch(keypos, 1, Res), {value, {protection, protected}} = lists:keysearch(protection, 1, Res), + {value, {id, Tab}} = lists:keysearch(id, 1, Res), true = ets:delete(Tab), undefined = ets:info(non_existing_table_xxyy), undefined = ets:info(non_existing_table_xxyy,type), @@ -5897,6 +5929,36 @@ take(Config) when is_list(Config) -> ets:delete(T3), ok. +whereis_table(Config) when is_list(Config) -> + %% Do we return 'undefined' when the named table doesn't exist? + undefined = ets:whereis(whereis_test), + + %% Does the tid() refer to the same table as the name? + whereis_test = ets:new(whereis_test, [named_table]), + Tid = ets:whereis(whereis_test), + + ets:insert(whereis_test, [{hello}, {there}]), + + [[{hello}],[{there}]] = ets:match(whereis_test, '$1'), + [[{hello}],[{there}]] = ets:match(Tid, '$1'), + + true = ets:delete_all_objects(Tid), + + [] = ets:match(whereis_test, '$1'), + [] = ets:match(Tid, '$1'), + + %% Does the name disappear when deleted through the tid()? + true = ets:delete(Tid), + undefined = ets:info(whereis_test), + {'EXIT',{badarg, _}} = (catch ets:match(whereis_test, '$1')), + + %% Is the old tid() broken when the table is re-created with the same + %% name? + whereis_test = ets:new(whereis_test, [named_table]), + [] = ets:match(whereis_test, '$1'), + {'EXIT',{badarg, _}} = (catch ets:match(Tid, '$1')), + + ok. %% %% Utility functions: @@ -5912,16 +5974,11 @@ add_lists([E1|T1], [E2|T2], Acc) -> run_smp_workers(InitF,ExecF,FiniF,Laps) -> run_smp_workers(InitF,ExecF,FiniF,Laps, 0). run_smp_workers(InitF,ExecF,FiniF,Laps, Exclude) -> - case erlang:system_info(smp_support) of - true -> - case erlang:system_info(schedulers_online) of - N when N > Exclude -> - run_workers_do(InitF,ExecF,FiniF,Laps, N - Exclude); - _ -> - {skipped, "Too few schedulers online"} - end; - false -> - {skipped,"No smp support"} + case erlang:system_info(schedulers_online) of + N when N > Exclude -> + run_workers_do(InitF,ExecF,FiniF,Laps, N - Exclude); + _ -> + {skipped, "Too few schedulers online"} end. run_sched_workers(InitF,ExecF,FiniF,Laps) -> @@ -6245,11 +6302,9 @@ spawn_monitor_with_pid(Pid, Fun, N) -> only_if_smp(Func) -> only_if_smp(2, Func). only_if_smp(Schedulers, Func) -> - case {erlang:system_info(smp_support), - erlang:system_info(schedulers_online)} of - {false,_} -> {skip,"No smp support"}; - {true,N} when N < Schedulers -> {skip,"Too few schedulers online"}; - {true,_} -> Func() + case erlang:system_info(schedulers_online) of + N when N < Schedulers -> {skip,"Too few schedulers online"}; + _ -> Func() end. %% Copy-paste from emulator/test/binary_SUITE.erl @@ -6395,7 +6450,7 @@ very_big_num(0, Result) -> Result. make_port() -> - open_port({spawn, "efile"}, [eof]). + hd(erlang:ports()). make_pid() -> spawn_link(fun sleeper/0). diff --git a/lib/stdlib/test/filelib_SUITE.erl b/lib/stdlib/test/filelib_SUITE.erl index afaf2404fa..7403d52881 100644 --- a/lib/stdlib/test/filelib_SUITE.erl +++ b/lib/stdlib/test/filelib_SUITE.erl @@ -33,6 +33,8 @@ -include_lib("common_test/include/ct.hrl"). -include_lib("kernel/include/file.hrl"). +-define(PRIM_FILE, prim_file). + init_per_testcase(_Case, Config) -> Config. @@ -120,7 +122,7 @@ wcc(Wc, Error) -> do_wildcard_1(Dir, Wcf0) -> do_wildcard_2(Dir, Wcf0), Wcf = fun(Wc0) -> - Wc = filename:join(Dir, Wc0), + Wc = Dir ++ "/" ++ Wc0, L = Wcf0(Wc), [subtract_dir(N, Dir) || N <- L] end, @@ -268,8 +270,37 @@ do_wildcard_9(Dir, Wcf) -> %% Cleanup. del(Files), [ok = file:del_dir(D) || D <- lists:reverse(Dirs)], - ok. + do_wildcard_10(Dir, Wcf). + +%% ERL-451/OTP-14577: Escape characters using \\. +do_wildcard_10(Dir, Wcf) -> + All0 = ["{abc}","abc","def","---","z--","@a,b","@c"], + All = case os:type() of + {unix,_} -> + %% '?' is allowed in file names on Unix, but + %% not on Windows. + ["?q"|All0]; + _ -> + All0 + end, + Files = mkfiles(lists:reverse(All), Dir), + ["{abc}"] = Wcf("\\{a*"), + ["{abc}"] = Wcf("\\{abc}"), + ["abc","def","z--"] = Wcf("[a-z]*"), + ["---","abc","z--"] = Wcf("[a\\-z]*"), + ["@a,b","@c"] = Wcf("@{a\\,b,c}"), + ["@c"] = Wcf("@{a,b,c}"), + + case os:type() of + {unix,_} -> + ["?q"] = Wcf("\\?q"); + _ -> + [] = Wcf("\\?q") + end, + + del(Files), + ok. fold_files(Config) when is_list(Config) -> Dir = filename:join(proplists:get_value(priv_dir, Config), "fold_files"), @@ -417,10 +448,10 @@ wildcard_symlink(Config) when is_list(Config) -> erl_prim_loader)), ["sub","symlink"] = basenames(Dir, filelib:wildcard(filename:join(Dir, "*"), - prim_file)), + ?PRIM_FILE)), ["symlink"] = basenames(Dir, filelib:wildcard(filename:join(Dir, "symlink"), - prim_file)), + ?PRIM_FILE)), ok = file:delete(AFile), %% The symlink should still be visible even when its target %% has been deleted. @@ -436,10 +467,10 @@ wildcard_symlink(Config) when is_list(Config) -> erl_prim_loader)), ["sub","symlink"] = basenames(Dir, filelib:wildcard(filename:join(Dir, "*"), - prim_file)), + ?PRIM_FILE)), ["symlink"] = basenames(Dir, filelib:wildcard(filename:join(Dir, "symlink"), - prim_file)), + ?PRIM_FILE)), ok end. @@ -468,17 +499,17 @@ is_file_symlink(Config) -> ok -> true = filelib:is_dir(DirAlias), true = filelib:is_dir(DirAlias, erl_prim_loader), - true = filelib:is_dir(DirAlias, prim_file), + true = filelib:is_dir(DirAlias, ?PRIM_FILE), true = filelib:is_file(DirAlias), true = filelib:is_file(DirAlias, erl_prim_loader), - true = filelib:is_file(DirAlias, prim_file), + true = filelib:is_file(DirAlias, ?PRIM_FILE), ok = file:make_symlink(AFile,FileAlias), true = filelib:is_file(FileAlias), true = filelib:is_file(FileAlias, erl_prim_loader), - true = filelib:is_file(FileAlias, prim_file), + true = filelib:is_file(FileAlias, ?PRIM_FILE), true = filelib:is_regular(FileAlias), true = filelib:is_regular(FileAlias, erl_prim_loader), - true = filelib:is_regular(FileAlias, prim_file), + true = filelib:is_regular(FileAlias, ?PRIM_FILE), ok end. @@ -499,11 +530,11 @@ file_props_symlink(Config) -> {_,_} = LastMod = filelib:last_modified(AFile), LastMod = filelib:last_modified(Alias), LastMod = filelib:last_modified(Alias, erl_prim_loader), - LastMod = filelib:last_modified(Alias, prim_file), + LastMod = filelib:last_modified(Alias, ?PRIM_FILE), FileSize = filelib:file_size(AFile), FileSize = filelib:file_size(Alias), FileSize = filelib:file_size(Alias, erl_prim_loader), - FileSize = filelib:file_size(Alias, prim_file) + FileSize = filelib:file_size(Alias, ?PRIM_FILE) end. find_source(Config) when is_list(Config) -> diff --git a/lib/stdlib/test/gen_server_SUITE.erl b/lib/stdlib/test/gen_server_SUITE.erl index 7d9561db24..e29195e895 100644 --- a/lib/stdlib/test/gen_server_SUITE.erl +++ b/lib/stdlib/test/gen_server_SUITE.erl @@ -27,7 +27,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([start/1, crash/1, call/1, cast/1, cast_fast/1, - info/1, abcast/1, multicall/1, multicall_down/1, + continue/1, info/1, abcast/1, multicall/1, multicall_down/1, call_remote1/1, call_remote2/1, call_remote3/1, call_remote_n1/1, call_remote_n2/1, call_remote_n3/1, spec_init/1, spec_init_local_registered_parent/1, @@ -37,7 +37,8 @@ get_state/1, replace_state/1, call_with_huge_message_queue/1, undef_handle_call/1, undef_handle_cast/1, undef_handle_info/1, undef_init/1, undef_code_change/1, undef_terminate1/1, - undef_terminate2/1, undef_in_terminate/1, undef_in_handle_info/1 + undef_terminate2/1, undef_in_terminate/1, undef_in_handle_info/1, + undef_handle_continue/1 ]). -export([stop1/1, stop2/1, stop3/1, stop4/1, stop5/1, stop6/1, stop7/1, @@ -52,7 +53,7 @@ %% The gen_server behaviour --export([init/1, handle_call/3, handle_cast/2, +-export([init/1, handle_call/3, handle_cast/2, handle_continue/2, handle_info/2, code_change/3, terminate/2, format_status/2]). suite() -> @@ -61,7 +62,7 @@ suite() -> all() -> [start, {group,stop}, crash, call, cast, cast_fast, info, abcast, - multicall, multicall_down, call_remote1, call_remote2, + continue, multicall, multicall_down, call_remote1, call_remote2, call_remote3, call_remote_n1, call_remote_n2, call_remote_n3, spec_init, spec_init_local_registered_parent, @@ -76,7 +77,7 @@ groups() -> [{stop, [], [stop1, stop2, stop3, stop4, stop5, stop6, stop7, stop8, stop9, stop10]}, {undef_callbacks, [], - [undef_handle_call, undef_handle_cast, undef_handle_info, + [undef_handle_call, undef_handle_cast, undef_handle_info, undef_handle_continue, undef_init, undef_code_change, undef_terminate1, undef_terminate2]}]. @@ -458,6 +459,47 @@ call(Config) when is_list(Config) -> ok. %% -------------------------------------- +%% Test handle_continue. +%% -------------------------------------- + +continue(Config) when is_list(Config) -> + {ok, Pid} = gen_server:start_link(gen_server_SUITE, {continue, self()}, []), + [{Pid, continue}, {Pid, after_continue}] = read_replies(Pid), + + gen_server:call(Pid, {continue_reply, self()}), + [{Pid, continue}, {Pid, after_continue}] = read_replies(Pid), + + gen_server:call(Pid, {continue_noreply, self()}), + [{Pid, continue}, {Pid, after_continue}] = read_replies(Pid), + + gen_server:cast(Pid, {continue_noreply, self()}), + [{Pid, continue}, {Pid, after_continue}] = read_replies(Pid), + + Pid ! {continue_noreply, self()}, + [{Pid, continue}, {Pid, after_continue}] = read_replies(Pid), + + Pid ! {continue_continue, self()}, + [{Pid, before_continue}, {Pid, continue}, {Pid, after_continue}] = read_replies(Pid), + + Ref = monitor(process, Pid), + Pid ! continue_stop, + verify_down_reason(Ref, Pid, normal). + +read_replies(Pid) -> + receive + {Pid, ack} -> read_replies() + after + 1000 -> ct:fail({continue, ack}) + end. + +read_replies() -> + receive + Msg -> [Msg | read_replies()] + after + 0 -> [] + end. + +%% -------------------------------------- %% Test call to nonexisting processes on remote nodes %% -------------------------------------- @@ -1346,7 +1388,7 @@ echo_loop() -> %% Test the default implementation of terminate if the callback module %% does not export it undef_terminate1(Config) when is_list(Config) -> - {ok, Server} = gen_server:start(oc_server, [], []), + {ok, Server} = oc_server:start(), MRef = monitor(process, Server), ok = gen_server:stop(Server), ok = verify_down_reason(MRef, Server, normal). @@ -1354,7 +1396,7 @@ undef_terminate1(Config) when is_list(Config) -> %% Test the default implementation of terminate if the callback module %% does not export it undef_terminate2(Config) when is_list(Config) -> - {ok, Server} = gen_server:start(oc_server, [], []), + {ok, Server} = oc_server:start(), MRef = monitor(process, Server), ok = gen_server:stop(Server, {error, test}, infinity), ok = verify_down_reason(MRef, Server, {error, test}). @@ -1377,7 +1419,7 @@ undef_init(_Config) -> %% The upgrade should fail if code_change is expected in the callback module %% but not exported, but the server should continue with the old code undef_code_change(Config) when is_list(Config) -> - {ok, Server} = gen_server:start(oc_server, [], []), + {ok, Server} = oc_server:start(), {error, {'EXIT', {undef, [{oc_server, code_change, [_, _, _], _}|_]}}} = fake_upgrade(Server, ?MODULE), true = is_process_alive(Server). @@ -1385,7 +1427,7 @@ undef_code_change(Config) when is_list(Config) -> %% The server should crash if the handle_call callback is %% not exported in the callback module undef_handle_call(_Config) -> - {ok, Server} = gen_server:start(oc_server, [], []), + {ok, Server} = oc_server:start(), try gen_server:call(Server, call_msg), ct:fail(should_crash) @@ -1397,17 +1439,25 @@ undef_handle_call(_Config) -> %% The server should crash if the handle_cast callback is %% not exported in the callback module undef_handle_cast(_Config) -> - {ok, Server} = gen_server:start(oc_server, [], []), + {ok, Server} = oc_server:start(), MRef = monitor(process, Server), gen_server:cast(Server, cast_msg), verify_undef_down(MRef, Server, oc_server, handle_cast), ok. +%% The server should crash if the handle_continue callback is +%% not exported in the callback module +undef_handle_continue(_Config) -> + {ok, Server} = oc_server:start(continue), + MRef = monitor(process, Server), + verify_undef_down(MRef, Server, oc_server, handle_continue), + ok. + %% The server should log but not crash if the handle_info callback is %% calling an undefined function undef_handle_info(Config) when is_list(Config) -> error_logger_forwarder:register(), - {ok, Server} = gen_server:start(oc_server, [], []), + {ok, Server} = oc_server:start(), Server ! hej, wait_until_processed(Server, hej, 10), true = is_process_alive(Server), @@ -1570,8 +1620,11 @@ init(hibernate) -> init(sleep) -> ct:sleep(1000), {ok, []}; +init({continue, Pid}) -> + self() ! {after_continue, Pid}, + {ok, [], {continue, {message, Pid}}}; init({state,State}) -> - {ok, State}. + {ok,State}. handle_call(started_p, _From, State) -> io:format("FROZ"), @@ -1604,6 +1657,12 @@ handle_call(shutdown_reason, _From, _State) -> handle_call({call_undef_fun, Mod, Fun}, _From, State) -> Mod:Fun(), {reply, ok, State}; +handle_call({continue_reply, Pid}, _From, State) -> + self() ! {after_continue, Pid}, + {reply, ok, State, {continue, {message, Pid}}}; +handle_call({continue_noreply, Pid}, From, State) -> + self() ! {after_continue, Pid}, + {noreply, State, {continue, {message, Pid, From}}}; handle_call(stop_shutdown_reason, _From, State) -> {stop,{shutdown,stop_reason},State}. @@ -1620,6 +1679,9 @@ handle_cast(hibernate_later, _State) -> handle_cast({call_undef_fun, Mod, Fun}, State) -> Mod:Fun(), {noreply, State}; +handle_cast({continue_noreply, Pid}, State) -> + self() ! {after_continue, Pid}, + {noreply, State, {continue, {message, Pid}}}; handle_cast({From, stop}, State) -> io:format("BAZ"), {stop, {From,stopped}, State}. @@ -1657,9 +1719,34 @@ handle_info(continue, From) -> {noreply, []}; handle_info({From, stop}, State) -> {stop, {From,stopped_info}, State}; +handle_info({after_continue, Pid}, State) -> + Pid ! {self(), after_continue}, + Pid ! {self(), ack}, + {noreply, State}; +handle_info({continue_noreply, Pid}, State) -> + self() ! {after_continue, Pid}, + {noreply, State, {continue, {message, Pid}}}; +handle_info({continue_continue, Pid}, State) -> + {noreply, State, {continue, {continue, Pid}}}; +handle_info(continue_stop, State) -> + {noreply, State, {continue, stop}}; handle_info(_Info, State) -> {noreply, State}. +handle_continue({continue, Pid}, State) -> + Pid ! {self(), before_continue}, + self() ! {after_continue, Pid}, + {noreply, State, {continue, {message, Pid}}}; +handle_continue(stop, State) -> + {stop, normal, State}; +handle_continue({message, Pid}, State) -> + Pid ! {self(), continue}, + {noreply, State}; +handle_continue({message, Pid, From}, State) -> + Pid ! {self(), continue}, + gen_server:reply(From, ok), + {noreply, State}. + code_change(_OldVsn, {new, {undef_in_code_change, {Mod, Fun}}} = State, _Extra) -> diff --git a/lib/stdlib/test/gen_server_SUITE_data/oc_server.erl b/lib/stdlib/test/gen_server_SUITE_data/oc_server.erl index 4ba37987f3..7b92a49bf6 100644 --- a/lib/stdlib/test/gen_server_SUITE_data/oc_server.erl +++ b/lib/stdlib/test/gen_server_SUITE_data/oc_server.erl @@ -22,7 +22,7 @@ -behaviour(gen_server). %% API --export([start/0]). +-export([start/0, start/1]). %% gen_server callbacks -export([init/1]). @@ -30,8 +30,12 @@ -record(state, {}). start() -> - gen_server:start({local, ?MODULE}, ?MODULE, [], []). + gen_server:start(?MODULE, ok, []). -init([]) -> - {ok, #state{}}. +start(continue) -> + gen_server:start(?MODULE, continue, []). +init(ok) -> + {ok, #state{}}; +init(continue) -> + {ok, #state{}, {continue, continue}}. diff --git a/lib/stdlib/test/gen_statem_SUITE.erl b/lib/stdlib/test/gen_statem_SUITE.erl index 270f1c294a..053233df9b 100644 --- a/lib/stdlib/test/gen_statem_SUITE.erl +++ b/lib/stdlib/test/gen_statem_SUITE.erl @@ -60,7 +60,8 @@ tcs(start) -> tcs(stop) -> [stop1, stop2, stop3, stop4, stop5, stop6, stop7, stop8, stop9, stop10]; tcs(abnormal) -> - [abnormal1, abnormal1clean, abnormal1dirty, abnormal2]; + [abnormal1, abnormal1clean, abnormal1dirty, + abnormal2, abnormal3, abnormal4]; tcs(sys) -> [sys1, call_format_status, error_format_status, terminate_crash_format, @@ -524,6 +525,43 @@ abnormal2(Config) -> process_flag(trap_exit, OldFl), ok = verify_empty_msgq(). +%% Check that bad return actions makes the stm crash. Note that we must +%% trap exit since we must link to get the real bad_return_ error +abnormal3(Config) -> + OldFl = process_flag(trap_exit, true), + {ok,Pid} = gen_statem:start_link(?MODULE, start_arg(Config, []), []), + + %% bad return value in the gen_statem loop + {{{bad_action_from_state_function,badaction},_},_} = + ?EXPECT_FAILURE(gen_statem:call(Pid, badaction), Reason), + receive + {'EXIT',Pid,{{bad_action_from_state_function,badaction},_}} -> ok + after 5000 -> + ct:fail(gen_statem_did_not_die) + end, + + process_flag(trap_exit, OldFl), + ok = verify_empty_msgq(). + +%% Check that bad timeout actions makes the stm crash. Note that we must +%% trap exit since we must link to get the real bad_return_ error +abnormal4(Config) -> + OldFl = process_flag(trap_exit, true), + {ok,Pid} = gen_statem:start_link(?MODULE, start_arg(Config, []), []), + + %% bad return value in the gen_statem loop + BadTimeout = {badtimeout,4711,ouch}, + {{{bad_action_from_state_function,BadTimeout},_},_} = + ?EXPECT_FAILURE(gen_statem:call(Pid, BadTimeout), Reason), + receive + {'EXIT',Pid,{{bad_action_from_state_function,BadTimeout},_}} -> ok + after 5000 -> + ct:fail(gen_statem_did_not_die) + end, + + process_flag(trap_exit, OldFl), + ok = verify_empty_msgq(). + shutdown(Config) -> process_flag(trap_exit, true), @@ -1806,10 +1844,12 @@ idle(cast, {connect,Pid}, Data) -> idle({call,From}, connect, Data) -> gen_statem:reply(From, accept), {next_state,wfor_conf,Data,infinity}; % NoOp timeout just to test API -idle(cast, badreturn, _Data) -> - badreturn; idle({call,_From}, badreturn, _Data) -> badreturn; +idle({call,_From}, badaction, Data) -> + {keep_state, Data, [badaction]}; +idle({call,_From}, {badtimeout,_,_} = BadTimeout, Data) -> + {keep_state, Data, BadTimeout}; idle({call,From}, {delayed_answer,T}, Data) -> receive after T -> @@ -2045,9 +2085,9 @@ handle_event(Type, Event, State, Data) -> Result -> wrap_result(Result) catch - throw:Result -> + throw:Result:Stacktrace -> erlang:raise( - throw, wrap_result(Result), erlang:get_stacktrace()) + throw, wrap_result(Result), Stacktrace) end. unwrap_state([State]) -> diff --git a/lib/stdlib/test/io_SUITE.erl b/lib/stdlib/test/io_SUITE.erl index 16e3dba969..9f48fbf5e3 100644 --- a/lib/stdlib/test/io_SUITE.erl +++ b/lib/stdlib/test/io_SUITE.erl @@ -31,9 +31,9 @@ otp_10836/1, io_lib_width_too_small/1, io_with_huge_message_queue/1, format_string/1, maps/1, coverage/1, otp_14178_unicode_atoms/1, otp_14175/1, - otp_14285/1, limit_term/1]). + otp_14285/1, limit_term/1, otp_14983/1]). --export([pretty/2]). +-export([pretty/2, trf/3]). %%-define(debug, true). @@ -63,7 +63,7 @@ all() -> 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, otp_14178_unicode_atoms, otp_14175, - otp_14285, limit_term]. + otp_14285, limit_term, otp_14983]. %% Error cases for output. error_1(Config) when is_list(Config) -> @@ -1750,7 +1750,7 @@ printable_range(Suite) when is_list(Suite) -> PrettyOptions = [{column,1}, {line_length,109}, {depth,30}, - {max_chars,60}, + {line_max_chars,60}, {record_print_fun, fun(_,_) -> no end}, {encoding,unicode}], @@ -1886,7 +1886,7 @@ otp_10302(Suite) when is_list(Suite) -> pretty(Term, Depth) when is_integer(Depth) -> Opts = [{column, 1}, {line_length, 20}, - {depth, Depth}, {max_chars, 60}, + {depth, Depth}, {line_max_chars, 60}, {record_print_fun, fun rfd/2}, {encoding, unicode}], pretty(Term, Opts); @@ -1905,29 +1905,61 @@ otp_10836(Suite) when is_list(Suite) -> %% OTP-10755. The 'l' modifier otp_10755(Suite) when is_list(Suite) -> + %% printing plain ascii characters S = "string", "\"string\"" = fmt("~p", [S]), "[115,116,114,105,110,103]" = fmt("~lp", [S]), "\"string\"" = fmt("~P", [S, 2]), "[115|...]" = fmt("~lP", [S, 2]), - {'EXIT',{badarg,_}} = (catch fmt("~ltp", [S])), - {'EXIT',{badarg,_}} = (catch fmt("~tlp", [S])), - {'EXIT',{badarg,_}} = (catch fmt("~ltP", [S])), - {'EXIT',{badarg,_}} = (catch fmt("~tlP", [S])), + %% printing latin1 chars, with and without modifiers + T = {[255],list_to_atom([255]),[a,b,c]}, + "{\"ÿ\",ÿ,[a,b,c]}" = fmt("~p", [T]), + "{\"ÿ\",ÿ,[a,b,c]}" = fmt("~tp", [T]), + "{[255],ÿ,[a,b,c]}" = fmt("~lp", [T]), + "{[255],ÿ,[a,b,c]}" = fmt("~ltp", [T]), + "{[255],ÿ,[a,b,c]}" = fmt("~tlp", [T]), + "{\"ÿ\",ÿ,...}" = fmt("~P", [T,3]), + "{\"ÿ\",ÿ,...}" = fmt("~tP", [T,3]), + "{[255],ÿ,...}" = fmt("~lP", [T,3]), + "{[255],ÿ,...}" = fmt("~ltP", [T,3]), + "{[255],ÿ,...}" = fmt("~tlP", [T,3]), + %% printing unicode chars, with and without modifiers + U = {[666],list_to_atom([666]),[a,b,c]}, + "{[666],'\\x{29A}',[a,b,c]}" = fmt("~p", [U]), + case io:printable_range() of + unicode -> + "{\"ʚ\",'ʚ',[a,b,c]}" = fmt("~tp", [U]), + "{\"ʚ\",'ʚ',...}" = fmt("~tP", [U,3]); + latin1 -> + "{[666],'ʚ',[a,b,c]}" = fmt("~tp", [U]), + "{[666],'ʚ',...}" = fmt("~tP", [U,3]) + end, + "{[666],'\\x{29A}',[a,b,c]}" = fmt("~lp", [U]), + "{[666],'ʚ',[a,b,c]}" = fmt("~ltp", [U]), + "{[666],'ʚ',[a,b,c]}" = fmt("~tlp", [U]), + "{[666],'\\x{29A}',...}" = fmt("~P", [U,3]), + "{[666],'\\x{29A}',...}" = fmt("~lP", [U,3]), + "{[666],'ʚ',...}" = fmt("~ltP", [U,3]), + "{[666],'ʚ',...}" = fmt("~tlP", [U,3]), + %% the compiler should catch uses of ~l with other than pP Text = "-module(l_mod).\n" "-export([t/0]).\n" "t() ->\n" " S = \"string\",\n" - " io:format(\"~ltp\", [S]),\n" - " io:format(\"~tlp\", [S]),\n" - " io:format(\"~ltP\", [S, 1]),\n" - " io:format(\"~tlP\", [S, 1]).\n", + " io:format(\"~lw\", [S]),\n" + " io:format(\"~lW\", [S, 1]),\n" + " io:format(\"~ltw\", [S]),\n" + " io:format(\"~tlw\", [S]),\n" + " io:format(\"~ltW\", [S, 1]),\n" + " io:format(\"~tlW\", [S, 1]).\n", {ok,l_mod,[{_File,Ws}]} = compile_file("l_mod.erl", Text, Suite), - ["format string invalid (invalid control ~lt)", - "format string invalid (invalid control ~tl)", - "format string invalid (invalid control ~lt)", - "format string invalid (invalid control ~tl)"] = + ["format string invalid (invalid control ~lw)", + "format string invalid (invalid control ~lW)", + "format string invalid (invalid control ~ltw)", + "format string invalid (invalid control ~ltw)", + "format string invalid (invalid control ~ltW)", + "format string invalid (invalid control ~ltW)"] = [lists:flatten(M:format_error(E)) || {_L,M,E} <- Ws], ok. @@ -2005,6 +2037,7 @@ writes(N, F1) -> format_string(_Config) -> %% All but padding is tested by fmt/2. + "xxxxxxxsss" = fmt("~10..xs", ["sss"]), "xxxxxxsssx" = fmt("~10.4.xs", ["sss"]), "xxxxxxsssx" = fmt("~10.4.*s", [$x, "sss"]), ok. @@ -2020,19 +2053,19 @@ maps(_Config) -> %% in a map with more than one element. "#{}" = fmt("~w", [#{}]), - "#{a=>b}" = fmt("~w", [#{a=>b}]), - re_fmt(<<"#\\{(a=>b|c=>d),[.][.][.]=>[.][.][.]\\}">>, - "~W", [#{a=>b,c=>d},2]), - re_fmt(<<"#\\{(a=>b|c=>d|e=>f),[.][.][.]=>[.][.][.],[.][.][.]\\}">>, - "~W", [#{a=>b,c=>d,e=>f},2]), + "#{a => b}" = fmt("~w", [#{a=>b}]), + re_fmt(<<"#\\{(a => b),[.][.][.]\\}">>, + "~W", [#{a => b,c => d},2]), + re_fmt(<<"#\\{(a => b),[.][.][.]\\}">>, + "~W", [#{a => b,c => d,e => f},2]), "#{}" = fmt("~p", [#{}]), - "#{a => b}" = fmt("~p", [#{a=>b}]), - "#{...}" = fmt("~P", [#{a=>b},1]), + "#{a => b}" = fmt("~p", [#{a => b}]), + "#{...}" = fmt("~P", [#{a => b},1]), re_fmt(<<"#\\{(a => b|c => d),[.][.][.]\\}">>, - "~P", [#{a=>b,c=>d},2]), + "~P", [#{a => b,c => d},2]), re_fmt(<<"#\\{(a => b|c => d|e => f),[.][.][.]\\}">>, - "~P", [#{a=>b,c=>d,e=>f},2]), + "~P", [#{a => b,c => d,e => f},2]), List = [{I,I*I} || I <- lists:seq(1, 20)], Map = maps:from_list(List), @@ -2140,8 +2173,8 @@ otp_14175(_Config) -> "#{}" = 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), + mt("#{a => 1,...}", p(#{a => 1, b => 2}, 2)), + mt("#{a => 1,b => 2}", p(#{a => 1, b => 2}, -1)), M = #{kaaaaaaaaaaaaaaaaaaa => v1,kbbbbbbbbbbbbbbbbbbb => v2, kccccccccccccccccccc => v3,kddddddddddddddddddd => v4, @@ -2384,19 +2417,36 @@ limit_term(_Config) -> {_, 2} = limt({a,b,c,[d,e]}, 2), {_, 2} = limt({a,b,c,[d,e]}, 3), {_, 2} = limt({a,b,c,[d,e]}, 4), + T0 = [1|{a,b,c}], + {_, 2} = limt(T0, 2), + {_, 2} = limt(T0, 3), + {_, 2} = limt(T0, 4), {_, 1} = limt(<<"foo">>, 18), + {_, 2} = limt({"",[1,2]}, 3), + {_, 2} = limt({"",{1,2}}, 3), + true = limt_pp({"123456789012345678901234567890",{1,2}}, 3), ok = blimt(<<"123456789012345678901234567890">>), + true = limt_pp(<<"123456789012345678901234567890">>, 3), + {_, 2} = limt({<<"kljlkjsl">>,[1,2,3,4]}, 4), {_, 1} = limt(<<7:3>>, 2), {_, 1} = limt(<<7:21>>, 2), {_, 1} = limt([], 2), {_, 1} = limt({}, 2), + {_, 1} = limt({"", ""}, 4), {_, 1} = limt(#{}, 2), - {_, 1} = limt(#{[] => {}}, 2), + {_, 2} = limt(#{[] => {}}, 1), + {_, 2} = limt(#{[] => {}}, 2), {_, 1} = limt(#{[] => {}}, 3), T = #{[] => {},[a] => [b]}, - {_, 1} = limt(T, 2), - {_, 1} = limt(T, 3), + {_, 1} = limt(T, 0), + {_, 2} = limt(T, 1), + {_, 2} = limt(T, 2), + {_, 2} = limt(T, 3), {_, 1} = limt(T, 4), + T2 = #{[] => {},{} => []}, + {_, 2} = limt(T2, 1), + {_, 2} = limt(T2, 2), + {_, 1} = limt(T2, 3), ok. blimt(Binary) -> @@ -2430,3 +2480,138 @@ limt(Term, Depth) when is_integer(Depth) -> form(Term, Depth) -> lists:flatten(io_lib:format("~W", [Term, Depth])). + +limt_pp(Term, Depth) when is_integer(Depth) -> + T1 = io_lib:limit_term(Term, Depth), + S = pp(Term, Depth), + S1 = pp(T1, Depth), + S1 =:= S. + +pp(Term, Depth) -> + lists:flatten(io_lib:format("~P", [Term, Depth])). + +otp_14983(_Config) -> + trunc_depth(-1, fun trp/3), + trunc_depth(10, fun trp/3), + trunc_depth(-1, fun trw/3), + trunc_depth(10, fun trw/3), + trunc_depth_p(-1), + trunc_depth_p(10), + trunc_string(), + ok. + +trunc_string() -> + "str " = trf("str ", [], 10), + "str ..." = trf("str ~s", ["str"], 6), + "str str" = trf("str ~s", ["str"], 7), + "str ..." = trf("str ~8s", ["str"], 6), + Pa = filename:dirname(code:which(?MODULE)), + {ok, UNode} = test_server:start_node(printable_range_unicode, slave, + [{args, " +pc unicode -pa " ++ Pa}]), + U = "кирилли́ческий атом", + UFun = fun(Format, Args, CharsLimit) -> + rpc:call(UNode, + ?MODULE, trf, [Format, Args, CharsLimit]) + end, + "str кир" = UFun("str ~3ts", [U], 7), + "str ..." = UFun("str ~3ts", [U], 6), + "str ..." = UFun("str ~30ts", [U], 6), + "str кир..." = UFun("str ~30ts", [U], 10), + "str кирилл..." = UFun("str ~30ts", [U], 13), + "str кирилли́..." = UFun("str ~30ts", [U], 14), + "str кирилли́ч..." = UFun("str ~30ts", [U], 15), + "\"кирилли́ческ\"..." = UFun("~tp", [U], 13), + BU = <<"кирилли́ческий атом"/utf8>>, + "<<\"кирилли́\"/utf8...>>" = UFun("~tp", [BU], 20), + "<<\"кирилли́\"/utf8...>>" = UFun("~tp", [BU], 21), + "<<\"кирилли́ческ\"/utf8...>>" = UFun("~tp", [BU], 22), + test_server:stop_node(UNode). + +trunc_depth(D, Fun) -> + "..." = Fun("", D, 0), + "[]" = Fun("", D, 1), + + "#{}" = Fun(#{}, D, 1), + "#{a => 1}" = Fun(#{a => 1}, D, 7), + "#{...}" = Fun(#{a => 1}, D, 5), + "#{a => 1}" = Fun(#{a => 1}, D, 6), + A = lists:seq(1, 1000), + M = #{A => A, {A,A} => {A,A}}, + "#{...}" = Fun(M, D, 6), + "#{{...} => {...},...}" = Fun(M, D, 7), + "#{{[...],...} => {[...],...},...}" = Fun(M, D, 22), + "#{{[...],...} => {[...],...},[...] => [...]}" = Fun(M, D, 31), + "#{{[...],...} => {[...],...},[...] => [...]}" = Fun(M, D, 33), + "#{{[1|...],[...]} => {[1|...],[...]},[1,2|...] => [...]}" = + Fun(M, D, 50), + + "..." = Fun({c, 1, 2}, D, 0), + "{...}" = Fun({c, 1, 2}, D, 1), + + "..." = Fun({}, D, 0), + "{}" = Fun({}, D, 1), + T = {A, A, A}, + "{...}" = Fun(T, D, 5), + "{[...],...}" = Fun(T, D, 6), + "{[1|...],[...],...}" = Fun(T, D, 12), + "{[1,2|...],[1|...],...}" = Fun(T, D, 20), + "{[1,2|...],[1|...],[...]}" = Fun(T, D, 21), + "{[1,2,3|...],[1,2|...],[1|...]}" = Fun(T, D, 28), + + "{[1],[1,2|...]}" = Fun({[1],[1,2,3,4]}, D, 14). + +trunc_depth_p(D) -> + UOpts = [{record_print_fun, fun rfd/2}, + {encoding, unicode}], + LOpts = [{record_print_fun, fun rfd/2}, + {encoding, latin1}], + trunc_depth_p(D, UOpts), + trunc_depth_p(D, LOpts). + +trunc_depth_p(D, Opts) -> + "[...]" = trp("abcdefg", D, 4, Opts), + "\"abc\"..." = trp("abcdefg", D, 5, Opts), + "\"abcdef\"..." = trp("abcdefg", D, 8, Opts), + "\"abcdefg\"" = trp("abcdefg", D, 9, Opts), + "\"abcdefghijkl\"" = trp("abcdefghijkl", D, -1, Opts), + AZ = lists:seq($A, $Z), + AZb = list_to_binary(AZ), + AZbS = "<<\"" ++ AZ ++ "\">>", + AZbS = trp(AZb, D, -1), + "<<\"ABCDEFGH\"...>>" = trp(AZb, D, 17, Opts), % 4 chars even if D = -1... + "<<\"ABCDEFGHIJKL\"...>>" = trp(AZb, D, 18, Opts), + B1 = <<"abcdef",0:8>>, + "<<\"ab\"...>>" = trp(B1, D, 8, Opts), + "<<\"abcdef\"...>>" = trp(B1, D, 14, Opts), + "<<97,98,99,100,...>>" = trp(B1, D, 16, Opts), + "<<97,98,99,100,101,102,0>>" = trp(B1, D, -1, Opts), + B2 = <<AZb/binary,0:8>>, + "<<\"AB\"...>>" = trp(B2, D, 8, Opts), + "<<\"ABCDEFGH\"...>>" = trp(B2, D, 14, Opts), + "<<65,66,67,68,69,70,71,72,0>>" = trp(<<"ABCDEFGH",0:8>>, D, -1, Opts), + "<<97,0,107,108,...>>" = trp(<<"a",0:8,"kllkjlksdjfsj">>, D, 20, Opts), + + A = lists:seq(1, 1000), + "#c{...}" = trp({c, 1, 2}, D, 6), + "#c{...}" = trp({c, 1, 2}, D, 7), + "#c{f1 = [...],...}" = trp({c, A, A}, D, 18), + "#c{f1 = [1|...],f2 = [...]}" = trp({c, A, A}, D, 19), + "#c{f1 = [1,2|...],f2 = [1|...]}" = trp({c, A, A}, D, 31), + "#c{f1 = [1,2,3|...],f2 = [1,2|...]}" = trp({c, A, A}, D, 32). + +trp(Term, D, T) -> + trp(Term, D, T, [{record_print_fun, fun rfd/2}]). + +trp(Term, D, T, Opts) -> + R = io_lib_pretty:print(Term, [{depth, D}, + {chars_limit, T}|Opts]), + lists:flatten(io_lib:format("~s", [R])). + +trw(Term, D, T) -> + lists:flatten(io_lib:format("~W", [Term, D], [{chars_limit, T}])). + +trf(Format, Args, T) -> + trf(Format, Args, T, [{record_print_fun, fun rfd/2}]). + +trf(Format, Args, T, Opts) -> + lists:flatten(io_lib:format(Format, Args, [{chars_limit, T}|Opts])). diff --git a/lib/stdlib/test/lists_SUITE.erl b/lib/stdlib/test/lists_SUITE.erl index 7c99244b36..837ab4e97e 100644 --- a/lib/stdlib/test/lists_SUITE.erl +++ b/lib/stdlib/test/lists_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1997-2017. All Rights Reserved. +%% Copyright Ericsson AB 1997-2018. 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. @@ -57,7 +57,7 @@ filter_partition/1, join/1, otp_5939/1, otp_6023/1, otp_6606/1, otp_7230/1, - suffix/1, subtract/1, droplast/1, hof/1]). + suffix/1, subtract/1, droplast/1, search/1, hof/1]). %% Sort randomized lists until stopped. %% @@ -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, droplast]} + hof, droplast, search]} ]. init_per_suite(Config) -> @@ -2615,6 +2615,20 @@ droplast(Config) when is_list(Config) -> ok. +%% Test lists:search/2 +search(Config) when is_list(Config) -> + F = fun(I) -> I rem 2 =:= 0 end, + F2 = fun(A, B) -> A > B end, + + {value, 2} = lists:search(F, [1,2,3,4]), + false = lists:search(F, [1,3,5,7]), + false = lists:search(F, []), + + %% Error cases. + {'EXIT',{function_clause,_}} = (catch lists:search(badfun, [])), + {'EXIT',{function_clause,_}} = (catch lists:search(F2, [])), + ok. + %% Briefly test the common high-order functions to ensure they %% are covered. hof(Config) when is_list(Config) -> diff --git a/lib/stdlib/test/maps_SUITE.erl b/lib/stdlib/test/maps_SUITE.erl index 42e669a799..a75751b31d 100644 --- a/lib/stdlib/test/maps_SUITE.erl +++ b/lib/stdlib/test/maps_SUITE.erl @@ -30,6 +30,7 @@ -export([t_update_with_3/1, t_update_with_4/1, t_get_3/1, t_filter_2/1, t_fold_3/1,t_map_2/1,t_size_1/1, + t_iterator_1/1, t_with_2/1,t_without_2/1]). %%-define(badmap(V,F,Args), {'EXIT', {{badmap,V}, [{maps,F,Args,_}|_]}}). @@ -47,6 +48,7 @@ all() -> [t_update_with_3,t_update_with_4, t_get_3,t_filter_2, t_fold_3,t_map_2,t_size_1, + t_iterator_1, t_with_2,t_without_2]. t_update_with_3(Config) when is_list(Config) -> @@ -127,6 +129,8 @@ t_filter_2(Config) when is_list(Config) -> Pred2 = fun(K,V) -> is_list(K) andalso (V rem 2) =:= 0 end, #{a := 2,c := 4} = maps:filter(Pred1,M), #{"b" := 2,"c" := 4} = maps:filter(Pred2,M), + #{a := 2,c := 4} = maps:filter(Pred1,maps:iterator(M)), + #{"b" := 2,"c" := 4} = maps:filter(Pred2,maps:iterator(M)), %% error case ?badmap(a,filter,[_,a]) = (catch maps:filter(fun(_,_) -> ok end,id(a))), ?badarg(filter,[<<>>,#{}]) = (catch maps:filter(id(<<>>),#{})), @@ -139,6 +143,8 @@ t_fold_3(Config) when is_list(Config) -> Tot0 = lists:sum(Vs), Tot1 = maps:fold(fun({k,_},V,A) -> A + V end, 0, M0), true = Tot0 =:= Tot1, + Tot2 = maps:fold(fun({k,_},V,A) -> A + V end, 0, maps:iterator(M0)), + true = Tot0 =:= Tot2, %% error case ?badmap(a,fold,[_,0,a]) = (catch maps:fold(fun(_,_,_) -> ok end,0,id(a))), @@ -151,12 +157,48 @@ t_map_2(Config) when is_list(Config) -> #{ {k,1} := 1, {k,200} := 200} = M0, M1 = maps:map(fun({k,_},V) -> V + 42 end, M0), #{ {k,1} := 43, {k,200} := 242} = M1, + M2 = maps:map(fun({k,_},V) -> V + 42 end, maps:iterator(M0)), + #{ {k,1} := 43, {k,200} := 242} = M2, %% error case ?badmap(a,map,[_,a]) = (catch maps:map(fun(_,_) -> ok end, id(a))), ?badarg(map,[<<>>,#{}]) = (catch maps:map(id(<<>>),#{})), ok. +t_iterator_1(Config) when is_list(Config) -> + + %% Small map test + M0 = #{ a => 1, b => 2 }, + I0 = maps:iterator(M0), + {K1,V1,I1} = maps:next(I0), + {K2,V2,I2} = maps:next(I1), + none = maps:next(I2), + + KVList = lists:sort([{K1,V1},{K2,V2}]), + KVList = lists:sort(maps:to_list(M0)), + + %% Large map test + + Vs2 = lists:seq(1,200), + M2 = maps:from_list([{{k,I},I}||I<-Vs2]), + KVList2 = lists:sort(iter_kv(maps:iterator(M2))), + KVList2 = lists:sort(maps:to_list(M2)), + + %% Larger map test + + Vs3 = lists:seq(1,10000), + M3 = maps:from_list([{{k,I},I}||I<-Vs3]), + KVList3 = lists:sort(iter_kv(maps:iterator(M3))), + KVList3 = lists:sort(maps:to_list(M3)), + ok. + +iter_kv(I) -> + case maps:next(I) of + none -> + []; + {K,V,NI} -> + [{K,V} | iter_kv(NI)] + end. t_size_1(Config) when is_list(Config) -> 0 = maps:size(#{}), diff --git a/lib/stdlib/test/proc_lib_SUITE.erl b/lib/stdlib/test/proc_lib_SUITE.erl index 7686889360..fbdcb518b2 100644 --- a/lib/stdlib/test/proc_lib_SUITE.erl +++ b/lib/stdlib/test/proc_lib_SUITE.erl @@ -446,8 +446,8 @@ init_dont_hang(Config) when is_list(Config) -> StartLinkRes = proc_lib:start(?MODULE, init_dont_hang_init, [self()], 1000), StartLinkRes = proc_lib:start(?MODULE, init_dont_hang_init, [self()], 1000, []), ok - catch _:Error -> - io:format("Error ~p /= ~p ~n",[erlang:get_stacktrace(), StartLinkRes]), + catch _:Error:Stacktrace -> + io:format("Error ~p /= ~p ~n",[Stacktrace, StartLinkRes]), exit(Error) end. diff --git a/lib/stdlib/test/property_test/README b/lib/stdlib/test/property_test/README new file mode 100644 index 0000000000..57602bf719 --- /dev/null +++ b/lib/stdlib/test/property_test/README @@ -0,0 +1,12 @@ + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% %%% +%%% WARNING %%% +%%% %%% +%%% This is experimental code which may be changed or removed %%% +%%% anytime without any warning. %%% +%%% %%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +The test in this directory are written assuming that the user has a QuickCheck license. They are to be run manually. Some may be possible to be run with other tools, e.g. PropEr. + diff --git a/lib/stdlib/test/property_test/uri_string_recompose.erl b/lib/stdlib/test/property_test/uri_string_recompose.erl new file mode 100644 index 0000000000..e51a671172 --- /dev/null +++ b/lib/stdlib/test/property_test/uri_string_recompose.erl @@ -0,0 +1,361 @@ +%% +%% %CopyrightBegin% +%% +%% 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. +%% 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(uri_string_recompose). + +-compile(export_all). + +-proptest(eqc). +-proptest([triq,proper]). + +-ifndef(EQC). +-ifndef(PROPER). +-ifndef(TRIQ). +-define(EQC,true). +-endif. +-endif. +-endif. + +-ifdef(EQC). +-include_lib("eqc/include/eqc.hrl"). +-define(MOD_eqc,eqc). + +-else. +-ifdef(PROPER). +-include_lib("proper/include/proper.hrl"). +-define(MOD_eqc,proper). + +-else. +-ifdef(TRIQ). +-define(MOD_eqc,triq). +-include_lib("triq/include/triq.hrl"). + +-endif. +-endif. +-endif. + + +-define(STRING_REST(MatchStr, Rest), <<MatchStr/utf8, Rest/binary>>). + +-define(SCHEME, {scheme, scheme()}). +-define(USER, {userinfo, unicode()}). +-define(HOST, {host, host_map()}). +-define(PORT, {port, port()}). +-define(PATH_ABE, {path, path_abempty_map()}). +-define(PATH_ABS, {path, path_absolute_map()}). +-define(PATH_NOS, {path, path_noscheme_map()}). +-define(PATH_ROO, {path, path_rootless_map()}). +-define(PATH_EMP, {path, path_empty_map()}). +-define(QUERY, {query, query_map()}). +-define(FRAGMENT, {fragment, fragment_map()}). + + +%%%======================================================================== +%%% Properties +%%%======================================================================== + +prop_recompose() -> + ?FORALL(Map, map(), + Map =:= uri_string:parse(uri_string:recompose(Map)) + ). + +%% Stats +prop_map_key_length_collect() -> + ?FORALL(List, map(), + collect(length(maps:keys(List)), true)). + +prop_map_collect() -> + ?FORALL(List, map(), + collect(lists:sort(maps:keys(List)), true)). + +prop_scheme_collect() -> + ?FORALL(List, scheme(), + collect(length(List), true)). + + +%%%======================================================================== +%%% Generators +%%%======================================================================== + +map() -> + ?LET(Gen, comp_proplist(), proplist_to_map(Gen)). + +comp_proplist() -> + frequency([ + {2, [?SCHEME,?PATH_ABS]}, + {2, [?SCHEME,?PATH_ROO]}, + {2, [?SCHEME,?PATH_EMP]}, + {2, [?SCHEME,?HOST,?PATH_ABE]}, + {2, [?SCHEME,?USER,?HOST,?PATH_ABE]}, + {2, [?SCHEME,?HOST,?PORT,?PATH_ABE]}, + {2, [?SCHEME,?USER,?HOST,?PORT,?PATH_ABE]}, + + {2, [?PATH_ABS]}, + {2, [?PATH_NOS]}, + {2, [?PATH_EMP]}, + {2, [?HOST,?PATH_ABE]}, + {2, [?USER,?HOST,?PATH_ABE]}, + {2, [?HOST,?PORT,?PATH_ABE]}, + {2, [?USER,?HOST,?PORT,?PATH_ABE]}, + + + {2, [?SCHEME,?PATH_ABS,?QUERY]}, + {2, [?SCHEME,?PATH_ROO,?QUERY]}, + {2, [?SCHEME,?PATH_EMP,?QUERY]}, + {2, [?SCHEME,?HOST,?PATH_ABE,?QUERY]}, + {2, [?SCHEME,?USER,?HOST,?PATH_ABE,?QUERY]}, + {2, [?SCHEME,?HOST,?PORT,?PATH_ABE,?QUERY]}, + {2, [?SCHEME,?USER,?HOST,?PORT,?PATH_ABE,?QUERY]}, + + {2, [?PATH_ABS,?QUERY]}, + {2, [?PATH_NOS,?QUERY]}, + {2, [?PATH_EMP,?QUERY]}, + {2, [?HOST,?PATH_ABE,?QUERY]}, + {2, [?USER,?HOST,?PATH_ABE,?QUERY]}, + {2, [?HOST,?PORT,?PATH_ABE,?QUERY]}, + {2, [?USER,?HOST,?PORT,?PATH_ABE,?QUERY]}, + + + {2, [?SCHEME,?PATH_ABS,?FRAGMENT]}, + {2, [?SCHEME,?PATH_ROO,?FRAGMENT]}, + {2, [?SCHEME,?PATH_EMP,?FRAGMENT]}, + {2, [?SCHEME,?HOST,?PATH_ABE,?FRAGMENT]}, + {2, [?SCHEME,?USER,?HOST,?PATH_ABE,?FRAGMENT]}, + {2, [?SCHEME,?HOST,?PORT,?PATH_ABE,?FRAGMENT]}, + {2, [?SCHEME,?USER,?HOST,?PORT,?PATH_ABE,?FRAGMENT]}, + + {2, [?PATH_ABS,?FRAGMENT]}, + {2, [?PATH_NOS,?FRAGMENT]}, + {2, [?PATH_EMP,?FRAGMENT]}, + {2, [?HOST,?PATH_ABE,?FRAGMENT]}, + {2, [?USER,?HOST,?PATH_ABE,?FRAGMENT]}, + {2, [?HOST,?PORT,?PATH_ABE,?FRAGMENT]}, + {2, [?USER,?HOST,?PORT,?PATH_ABE,?FRAGMENT]}, + + + {2, [?SCHEME,?PATH_ABS,?QUERY,?FRAGMENT]}, + {2, [?SCHEME,?PATH_ROO,?QUERY,?FRAGMENT]}, + {2, [?SCHEME,?PATH_EMP,?QUERY,?FRAGMENT]}, + {2, [?SCHEME,?HOST,?PATH_ABE,?QUERY,?FRAGMENT]}, + {2, [?SCHEME,?USER,?HOST,?PATH_ABE,?QUERY,?FRAGMENT]}, + {2, [?SCHEME,?HOST,?PORT,?PATH_ABE,?QUERY,?FRAGMENT]}, + {2, [?SCHEME,?USER,?HOST,?PORT,?PATH_ABE,?QUERY,?FRAGMENT]}, + + {2, [?PATH_ABS,?QUERY,?FRAGMENT]}, + {2, [?PATH_NOS,?QUERY,?FRAGMENT]}, + {2, [?PATH_EMP,?QUERY,?FRAGMENT]}, + {2, [?HOST,?PATH_ABE,?QUERY,?FRAGMENT]}, + {2, [?USER,?HOST,?PATH_ABE,?QUERY,?FRAGMENT]}, + {2, [?HOST,?PORT,?PATH_ABE,?QUERY,?FRAGMENT]}, + {2, [?USER,?HOST,?PORT,?PATH_ABE,?QUERY,?FRAGMENT]} + ]). + + +%%------------------------------------------------------------------------- +%% Path +%%------------------------------------------------------------------------- +path_abempty_map() -> + frequency([{90, path_abe_map()}, + {10, path_empty_map()}]). + +path_abe_map() -> + ?SIZED(Length, path_abe_map(Length, [])). +%% +path_abe_map(0, Segments) -> + ?LET(Gen, Segments, lists:append(Gen)); +path_abe_map(N, Segments) -> + path_abe_map(N-1, [slash(),segment()|Segments]). + + +path_absolute_map() -> + ?SIZED(Length, path_absolute_map(Length, [])). +%% +path_absolute_map(0, Segments) -> + ?LET(Gen, [slash(),segment_nz()|Segments], lists:append(Gen)); +path_absolute_map(N, Segments) -> + path_absolute_map(N-1, [slash(),segment()|Segments]). + + +path_noscheme_map() -> + ?SIZED(Length, path_noscheme_map(Length, [])). +%% +path_noscheme_map(0, Segments) -> + ?LET(Gen, [segment_nz_nc()|Segments], lists:append(Gen)); +path_noscheme_map(N, Segments) -> + path_noscheme_map(N-1, [slash(),segment()|Segments]). + +path_rootless_map() -> + ?SIZED(Length, path_rootless_map(Length, [])). +%% +path_rootless_map(0, Segments) -> + ?LET(Gen, [segment_nz()|Segments], lists:append(Gen)); +path_rootless_map(N, Segments) -> + path_rootless_map(N-1, [slash(),segment()|Segments]). + + +segment_nz() -> + non_empty(segment()). + +segment_nz_nc() -> + non_empty(list(frequency([{30, unreserved()}, + {10, sub_delims()}, + {10, unicode_char()}, + {5, oneof([$@])} + ]))). + + +segment() -> + list(frequency([{30, unreserved()}, + {10, sub_delims()}, + {10, unicode_char()}, + {5, oneof([$:, $@])} + ])). + +slash() -> + "/". + +path_empty_map() -> + "". + + +%%------------------------------------------------------------------------- +%% Path +%%------------------------------------------------------------------------- +host_map() -> + frequency([{30, reg_name()}, + {30, ip_address()} + ]). + + +reg_name() -> + list(frequency([{30, alpha()}, + {10, sub_delims()}, + {10, unicode_char()} + ])). + +ip_address() -> + oneof(["127.0.0.1", "::127.0.0.1", + "2001:0db8:0000:0000:0000:0000:1428:07ab", + "2001:0db8:0000:0000:0000::1428:07ab", + "2001:0db8:0:0:0:0:1428:07ab", + "2001:0db8:0::0:1428:07ab"]). + +%% Generating only reg-names +host_uri() -> + non_empty(list(frequency([{30, unreserved()}, + {10, sub_delims()}, + {10, pct_encoded()} + ]))). + +%%------------------------------------------------------------------------- +%% Port, Query, Fragment +%%------------------------------------------------------------------------- +port() -> + frequency([{10, undefined}, + {10, range(1,65535)} + ]). + +query_map() -> + unicode(). + + +query_uri() -> + [$?| non_empty(list(frequency([{20, pchar()}, + {5, oneof([$/, $?])} % punctuation + ])))]. + +fragment_map() -> + unicode(). + +fragment_uri() -> + [$?| non_empty(list(frequency([{20, pchar()}, + {5, oneof([$/, $?])} % punctuation + ])))]. + + +%%------------------------------------------------------------------------- +%% Scheme +%%------------------------------------------------------------------------- +scheme() -> + ?SIZED(Length, scheme_start(Length, [])). +%% +scheme_start(0, L) -> + ?LET(Gen, L, lists:reverse(Gen)); +scheme_start(N, L) -> + scheme(N-1,[alpha()|L]). + +scheme(0, L) -> + ?LET(Gen, L, lists:reverse(Gen)); +scheme(N, L) -> + scheme(N-1, [scheme_char()|L]). + + +%%------------------------------------------------------------------------- +%% Misc +%%------------------------------------------------------------------------- +unicode() -> + list(frequency([{20, alpha()}, % alpha + {10, digit()}, % digit + {10, unicode_char()} % unicode + ])). + +scheme_char() -> + frequency([{20, alpha()}, % alpha + {20, digit()}, % digit + {5, oneof([$+, $-, $.])} % punctuation + ]). + +sub_delims() -> + oneof([$!, $$, $&, $', $(, $), + $*, $+, $,,$;, $=]). + +pchar() -> + frequency([{20, unreserved()}, + {5, pct_encoded()}, + {5, sub_delims()}, + {1, oneof([$:, $@])} % punctuation + ]). + +unreserved() -> + frequency([{20, alpha()}, + {5, digit()}, + {1, oneof([$-, $., $_, $~])} % punctuation + ]). + +unicode_char() -> + range(913, 1023). + +alpha() -> + frequency([{20, range($a, $z)}, % letters + {20, range($A, $Z)}]). % letters + +digit() -> + range($0, $9). % numbers + +pct_encoded() -> + oneof(["%C3%A4", "%C3%A5", "%C3%B6"]). + + +%%%======================================================================== +%%% Helpers +%%%======================================================================== +proplist_to_map(L) -> + lists:foldl(fun({K,V},M) -> M#{K => V}; + (_,M) -> M + end, #{}, L). diff --git a/lib/stdlib/test/qlc_SUITE.erl b/lib/stdlib/test/qlc_SUITE.erl index 949142ec77..8f8a0f6e73 100644 --- a/lib/stdlib/test/qlc_SUITE.erl +++ b/lib/stdlib/test/qlc_SUITE.erl @@ -1695,28 +1695,7 @@ sort(Config) when is_list(Config) -> [true || I <- lists:seq(1, 50000), not ets:insert(E, {I, I})], H = qlc:q([{X,Y} || X <- [a,b], Y <- qlc:sort(ets:table(E))]), 100000 = length(qlc:e(H)), - ets:delete(E)">>, - - begin - TmpDir = ?privdir, - [<<"TE = process_flag(trap_exit, true), - E = ets:new(foo, []), - [true || I <- lists:seq(1, 50000), not ets:insert(E, {I, I})], - Ports = erlang:ports(), - H = qlc:q([{X,Y} || X <- [a,b], - begin - [P] = erlang:ports() -- Ports, - exit(P, port_exit), - true - end, - Y <- qlc:sort(ets:table(E), - [{tmpdir,\"">>, - TmpDir, <<"\"}])]), - {error, qlc, {file_error, _, _}} = (catch qlc:e(H)), - receive {'EXIT', _, port_exit} -> ok end, - ets:delete(E), - process_flag(trap_exit, TE)">>] - end + ets:delete(E)">> ], run(Config, Ts), diff --git a/lib/stdlib/test/rand_SUITE.erl b/lib/stdlib/test/rand_SUITE.erl index 432293b656..d753d929f5 100644 --- a/lib/stdlib/test/rand_SUITE.erl +++ b/lib/stdlib/test/rand_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2000-2017. All Rights Reserved. +%% Copyright Ericsson AB 2000-2018. 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. @@ -29,11 +29,17 @@ basic_stats_uniform_1/1, basic_stats_uniform_2/1, basic_stats_standard_normal/1, basic_stats_normal/1, + stats_standard_normal_box_muller/1, + stats_standard_normal_box_muller_2/1, + stats_standard_normal/1, + uniform_real_conv/1, plugin/1, measure/1, reference_jump_state/1, reference_jump_procdict/1]). -export([test/0, gen/1]). +-export([uniform_real_gen/1, uniform_gen/2]). + -include_lib("common_test/include/ct.hrl"). -define(LOOP, 1000000). @@ -47,6 +53,8 @@ all() -> api_eq, reference, {group, basic_stats}, + {group, distr_stats}, + uniform_real_conv, plugin, measure, {group, reference_jump} ]. @@ -55,12 +63,19 @@ groups() -> [{basic_stats, [parallel], [basic_stats_uniform_1, basic_stats_uniform_2, basic_stats_standard_normal]}, + {distr_stats, [parallel], + [stats_standard_normal_box_muller, + stats_standard_normal_box_muller_2, + stats_standard_normal]}, {reference_jump, [parallel], [reference_jump_state, reference_jump_procdict]}]. group(basic_stats) -> %% valgrind needs a lot of time [{timetrap,{minutes,10}}]; +group(distr_stats) -> + %% valgrind needs a lot of time + [{timetrap,{minutes,10}}]; group(reference_jump) -> %% valgrind needs a lot of time [{timetrap,{minutes,10}}]. @@ -73,14 +88,14 @@ test() -> try ok = ?MODULE:Test([]), io:format("~p: ok~n", [Test]) - catch _:Reason -> + catch _:Reason:Stacktrace -> io:format("Failed: ~p: ~p ~p~n", - [Test, Reason, erlang:get_stacktrace()]) + [Test, Reason, Stacktrace]) end end, Tests). algs() -> - [exs64, exsplus, exsp, exrop, exs1024, exs1024s]. + [exrop, exsp, exs1024s, exs64, exsplus, exs1024]. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -89,8 +104,8 @@ seed(Config) when is_list(Config) -> Algs = algs(), Test = fun(Alg) -> try seed_1(Alg) - catch _:Reason -> - ct:fail({Alg, Reason, erlang:get_stacktrace()}) + catch _:Reason:Stacktrace -> + ct:fail({Alg, Reason, Stacktrace}) end end, [Test(Alg) || Alg <- Algs], @@ -101,7 +116,7 @@ seed_1(Alg) -> _ = rand:uniform(), S00 = get(rand_seed), erase(), - _ = rand:uniform(), + _ = rand:uniform_real(), false = S00 =:= get(rand_seed), %% hopefully %% Choosing algo and seed @@ -228,11 +243,13 @@ interval_float(Config) when is_list(Config) -> interval_float_1(0) -> ok; interval_float_1(N) -> X = rand:uniform(), + Y = rand:uniform_real(), if - 0.0 =< X, X < 1.0 -> + 0.0 =< X, X < 1.0, 0.0 < Y, Y < 1.0 -> ok; true -> - io:format("X=~p 0=<~p<1.0~n", [X,X]), + io:format("X=~p 0.0=<~p<1.0~n", [X,X]), + io:format("Y=~p 0.0<~p<1.0~n", [Y,Y]), exit({X, rand:export_seed()}) end, interval_float_1(N-1). @@ -334,7 +351,13 @@ basic_stats_normal(Config) when is_list(Config) -> IntendedMeanVariancePairs). basic_uniform_1(N, S0, Sum, A0) when N > 0 -> - {X,S} = rand:uniform_s(S0), + {X,S} = + case N band 1 of + 0 -> + rand:uniform_s(S0); + 1 -> + rand:uniform_real_s(S0) + end, I = trunc(X*100), A = array:set(I, 1+array:get(I,A0), A0), basic_uniform_1(N-1, S, Sum+X, A); @@ -399,6 +422,351 @@ normal_s(Mean, Variance, State0) when Mean == 0, Variance == 1 -> normal_s(Mean, Variance, State0) -> rand:normal_s(Mean, Variance, State0). + + +-dialyzer({no_improper_lists, stats_standard_normal_box_muller/1}). +stats_standard_normal_box_muller(Config) when is_list(Config) -> + try math:erfc(1.0) of + _ -> + TwoPi = 2.0 * math:pi(), + NormalS = + fun + ([S0]) -> + {U1, S1} = rand:uniform_real_s(S0), + R = math:sqrt(-2.0 * math:log(U1)), + {U2, S2} = rand:uniform_s(S1), + T = TwoPi * U2, + Z0 = R * math:cos(T), + Z1 = R * math:sin(T), + {Z0, [S2|Z1]}; + ([S|Z]) -> + {Z, [S]} + end, + State = [rand:seed(exrop)], + stats_standard_normal(NormalS, State, 3) + catch error:_ -> + {skip, "math:erfc/1 not supported"} + end. + +-dialyzer({no_improper_lists, stats_standard_normal_box_muller_2/1}). +stats_standard_normal_box_muller_2(Config) when is_list(Config) -> + try math:erfc(1.0) of + _ -> + TwoPi = 2.0 * math:pi(), + NormalS = + fun + ([S0]) -> + {U0, S1} = rand:uniform_s(S0), + U1 = 1.0 - U0, + R = math:sqrt(-2.0 * math:log(U1)), + {U2, S2} = rand:uniform_s(S1), + T = TwoPi * U2, + Z0 = R * math:cos(T), + Z1 = R * math:sin(T), + {Z0, [S2|Z1]}; + ([S|Z]) -> + {Z, [S]} + end, + State = [rand:seed(exrop)], + stats_standard_normal(NormalS, State, 3) + catch error:_ -> + {skip, "math:erfc/1 not supported"} + end. + + +stats_standard_normal(Config) when is_list(Config) -> + try math:erfc(1.0) of + _ -> + stats_standard_normal( + fun rand:normal_s/1, rand:seed_s(exrop), 3) + catch error:_ -> + {skip, "math:erfc/1 not supported"} + end. +%% +stats_standard_normal(Fun, S, Retries) -> +%%% +%%% ct config: +%%% {rand_SUITE, [{stats_standard_normal,[{seconds, 8}, {std_devs, 4.0}]}]}. +%%% + Seconds = ct:get_config({?MODULE, ?FUNCTION_NAME, seconds}, 8), + StdDevs = + ct:get_config( + {?MODULE, ?FUNCTION_NAME, std_devs}, + 4.0), % probability erfc(4.0/sqrt(2)) (1/15787) to fail a bucket +%%% + ct:timetrap({seconds, Seconds + 120}), + %% Buckets is chosen to get a range where the the probability to land + %% in the top catch-all bucket is not vanishingly low, but with + %% these values it is about 1/25 of the probability for the low bucket + %% (closest to 0). + %% + %% Rounds is calculated so the expected value for the low + %% bucket will be at least TargetHits. + %% + InvDelta = 512, + Buckets = 4 * InvDelta, % 4 std devs range + TargetHits = 1024, + Sqrt2 = math:sqrt(2.0), + W = InvDelta * Sqrt2, + P0 = math:erf(1 / W), + Rounds = TargetHits * ceil(1.0 / P0), + Histogram = array:new({default, 0}), + ct:pal( + "Running standard normal test against ~w std devs for ~w seconds...", + [StdDevs, Seconds]), + StopTime = erlang:monotonic_time(second) + Seconds, + {PositiveHistogram, NegativeHistogram, Outlier, TotalRounds, NewS} = + stats_standard_normal( + InvDelta, Buckets, Histogram, Histogram, 0.0, + Fun, S, Rounds, StopTime, Rounds, 0), + Precision = math:sqrt(TotalRounds * P0) / StdDevs, + TopP = math:erfc(Buckets / W), + TopPrecision = math:sqrt(TotalRounds * TopP) / StdDevs, + OutlierProbability = math:erfc(Outlier / Sqrt2) * TotalRounds, + InvOP = 1.0 / OutlierProbability, + ct:pal( + "Total rounds: ~w, tolerance: 1/~.2f..1/~.2f, " + "outlier: ~.2f, probability 1/~.2f.", + [TotalRounds, Precision, TopPrecision, Outlier, InvOP]), + case + {bucket_error, TotalRounds, + check_histogram( + W, TotalRounds, StdDevs, PositiveHistogram, Buckets), + check_histogram( + W, TotalRounds, StdDevs, NegativeHistogram, Buckets)} + of + {_, _, [], []} when InvOP < 100 -> + {comment, {tp, TopPrecision, op, InvOP}}; + {_, _, [], []} -> + %% If the probability for getting this Outlier is lower than + %% 1/100, then this is fishy! + stats_standard_normal( + Fun, NewS, Retries, {outlier_fishy, InvOP}); + BucketErrors -> + stats_standard_normal( + Fun, NewS, Retries, BucketErrors) + end. +%% +stats_standard_normal(Fun, S, Retries, Failure) -> + case Retries - 1 of + 0 -> + ct:fail(Failure); + NewRetries -> + ct:pal("Retry due to TC glitch: ~p", [Failure]), + stats_standard_normal(Fun, S, NewRetries) + end. +%% +stats_standard_normal( + InvDelta, Buckets, PositiveHistogram, NegativeHistogram, Outlier, + Fun, S, 0, StopTime, Rounds, TotalRounds) -> + case erlang:monotonic_time(second) of + Now when Now < StopTime -> + stats_standard_normal( + InvDelta, Buckets, + PositiveHistogram, NegativeHistogram, Outlier, + Fun, S, Rounds, StopTime, Rounds, TotalRounds + Rounds); + _ -> + {PositiveHistogram, NegativeHistogram, + Outlier, TotalRounds + Rounds, S} + end; +stats_standard_normal( + InvDelta, Buckets, PositiveHistogram, NegativeHistogram, Outlier, + Fun, S, Count, StopTime, Rounds, TotalRounds) -> + case Fun(S) of + {X, NewS} when 0.0 =< X -> + Bucket = min(Buckets, floor(X * InvDelta)), + stats_standard_normal( + InvDelta, Buckets, + increment_bucket(Bucket, PositiveHistogram), + NegativeHistogram, max(Outlier, X), + Fun, NewS, Count - 1, StopTime, Rounds, TotalRounds); + {MinusX, NewS} -> + X = -MinusX, + Bucket = min(Buckets, floor(X * InvDelta)), + stats_standard_normal( + InvDelta, Buckets, + PositiveHistogram, + increment_bucket(Bucket, NegativeHistogram), max(Outlier, X), + Fun, NewS, Count - 1, StopTime, Rounds, TotalRounds) + end. + +increment_bucket(Bucket, Array) -> + array:set(Bucket, array:get(Bucket, Array) + 1, Array). + +check_histogram(W, Rounds, StdDevs, Histogram, Buckets) -> + TargetP = 0.5 * math:erfc(Buckets / W), + P = 0.0, + N = 0, + check_histogram( + W, Rounds, StdDevs, Histogram, TargetP, + Buckets, Buckets, P, N). +%% +check_histogram( + _W, _Rounds, _StdDevs, _Histogram, _TargetP, + 0, _PrevBucket, _PrevP, _PrevN) -> + []; +check_histogram( + W, Rounds, StdDevs, Histogram, TargetP, + Bucket, PrevBucket, PrevP, PrevN) -> + N = PrevN + array:get(Bucket, Histogram), + P = 0.5 * math:erfc(Bucket / W), + BucketP = P - PrevP, + if + BucketP < TargetP -> + check_histogram( + W, Rounds, StdDevs, Histogram, TargetP, + Bucket - 1, PrevBucket, PrevP, N); + true -> + Exp = BucketP * Rounds, + Var = Rounds * BucketP*(1.0 - BucketP), + Threshold = StdDevs * math:sqrt(Var), + LowerLimit = floor(Exp - Threshold), + UpperLimit = ceil(Exp + Threshold), + if + N < LowerLimit; UpperLimit < N -> + [#{bucket => {Bucket, PrevBucket}, n => N, + lower => LowerLimit, upper => UpperLimit} | + check_histogram( + W, Rounds, StdDevs, Histogram, TargetP, + Bucket - 1, Bucket, P, 0)]; + true -> + check_histogram( + W, Rounds, StdDevs, Histogram, TargetP, + Bucket - 1, Bucket, P, 0) + end + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% White box test of the conversion to float + +uniform_real_conv(Config) when is_list(Config) -> + [begin +%% ct:pal("~13.16.0bx~3.16.0b: ~p~n", [M,E,Gen]), + uniform_real_conv_check(M, E, Gen) + end || {M, E, Gen} <- uniform_real_conv_data()], + uniform_real_scan(0), + uniform_real_scan(3). + +uniform_real_conv_data() -> + [{16#fffffffffffff, -1, [16#3ffffffffffffff]}, + {16#fffffffffffff, -1, [16#3ffffffffffffe0]}, + {16#ffffffffffffe, -1, [16#3ffffffffffffdf]}, + %% + {16#0000000000000, -1, [16#200000000000000]}, + {16#fffffffffffff, -2, [16#1ffffffffffffff]}, + {16#fffffffffffff, -2, [16#1fffffffffffff0]}, + {16#ffffffffffffe, -2, [16#1ffffffffffffef]}, + %% + {16#0000000000000, -2, [16#100000000000000]}, + {16#fffffffffffff, -3, [16#0ffffffffffffff]}, + {16#fffffffffffff, -3, [16#0fffffffffffff8]}, + {16#ffffffffffffe, -3, [16#0fffffffffffff7]}, + %% + {16#0000000000000, -3, [16#080000000000000]}, + {16#fffffffffffff, -4, [16#07fffffffffffff]}, + {16#fffffffffffff, -4, [16#07ffffffffffffc]}, + {16#ffffffffffffe, -4, [16#07ffffffffffffb]}, + %% + {16#0000000000000, -4, [16#040000000000000]}, + {16#fffffffffffff, -5, [16#03fffffffffffff,16#3ffffffffffffff]}, + {16#fffffffffffff, -5, [16#03ffffffffffffe,16#200000000000000]}, + {16#ffffffffffffe, -5, [16#03fffffffffffff,16#1ffffffffffffff]}, + {16#ffffffffffffe, -5, [16#03fffffffffffff,16#100000000000000]}, + %% + {16#0000000000001, -56, [16#000000000000007,16#00000000000007f]}, + {16#0000000000001, -56, [16#000000000000004,16#000000000000040]}, + {16#0000000000000, -57, [16#000000000000003,16#20000000000001f]}, + {16#0000000000000, -57, [16#000000000000000,16#200000000000000]}, + {16#fffffffffffff, -58, [16#000000000000003,16#1ffffffffffffff]}, + {16#fffffffffffff, -58, [16#000000000000000,16#1fffffffffffff0]}, + {16#ffffffffffffe, -58, [16#000000000000000,16#1ffffffffffffef]}, + {16#ffffffffffffe, -58, [16#000000000000000,16#1ffffffffffffe0]}, + %% + {16#0000000000000, -58, [16#000000000000000,16#10000000000000f]}, + {16#0000000000000, -58, [16#000000000000000,16#100000000000000]}, + {2#11001100000000000000000000000000000000000011000000011, % 53 bits + -1022, + [0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, % 18 zeros + 2#1100110000000000000000000000000000000000001 bsl 2, % 43 bits + 2#1000000011 bsl (56-10+2)]}, % 10 bits + {0, -1, % 0.5 after retry + [0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, % 18 zeros + 2#111111111111111111111111111111111111111111 bsl 2, % 42 bits - retry + 16#200000000000003]}]. % 0.5 + +-define(UNIFORM_REAL_SCAN_PATTERN, (16#19000000000009)). % 53 bits +-define(UNIFORM_REAL_SCAN_NUMBER, (1021)). + +uniform_real_scan_template(K) -> + <<0:?UNIFORM_REAL_SCAN_NUMBER, + ?UNIFORM_REAL_SCAN_PATTERN:53,K:2,0:1>>. + +uniform_real_scan(K) -> + Templ = uniform_real_scan_template(K), + N = ?UNIFORM_REAL_SCAN_NUMBER, + uniform_real_scan(Templ, N, K). + +uniform_real_scan(Templ, N, K) when 0 =< N -> + <<_:N/bits,T/bits>> = Templ, + Data = uniform_real_scan_data(T, K), + uniform_real_conv_check( + ?UNIFORM_REAL_SCAN_PATTERN, N - 1 - ?UNIFORM_REAL_SCAN_NUMBER, Data), + uniform_real_scan(Templ, N - 1, K); +uniform_real_scan(_, _, _) -> + ok. + +uniform_real_scan_data(Templ, K) -> + case Templ of + <<X:56, T/bits>> -> + B = rand:bc64(X), + [(X bsl 2) bor K | + if + 53 =< B -> + []; + true -> + uniform_real_scan_data(T, K) + end]; + _ -> + <<X:56, _/bits>> = <<Templ/bits, 0:56>>, + [(X bsl 2) bor K] + end. + +uniform_real_conv_check(M, E, Gen) -> + <<F/float>> = <<0:1, (E + 16#3ff):11, M:52>>, + try uniform_real_gen(Gen) of + F -> F; + FF -> + ct:pal( + "~s =/= ~s: ~s~n", + [rand:float2str(FF), rand:float2str(F), + [["16#",integer_to_list(G,16),$\s]||G<-Gen]]), + ct:fail({neq, FF, F}) + catch + Error:Reason:Stacktrace -> + ct:pal( + "~w:~p ~s: ~s~n", + [Error, Reason, rand:float2str(F), + [["16#",integer_to_list(G,16),$\s]||G<-Gen]]), + ct:fail({Error, Reason, F, Stacktrace}) + end. + + +uniform_real_gen(Gen) -> + State = rand_state(Gen), + {F, {#{type := rand_SUITE_list},[]}} = rand:uniform_real_s(State), + F. + +uniform_gen(Range, Gen) -> + State = rand_state(Gen), + {N, {#{type := rand_SUITE_list},[]}} = rand:uniform_s(Range, State), + N. + +%% Loaded dice for white box tests +rand_state(Gen) -> + {#{type => rand_SUITE_list, bits => 58, weak_low_bits => 1, + next => fun ([H|T]) -> {H, T} end}, + Gen}. + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% Test that the user can write algorithms. @@ -459,213 +827,289 @@ measure(Config) -> {skip,{will_not_run_in_scaled_time,Scale}} end. +-define(CHECK_UNIFORM_RANGE(Gen, Range, X, St), + case (Gen) of + {(X), (St)} when is_integer(X), 1 =< (X), (X) =< (Range) -> + St + end). +-define(CHECK_UNIFORM(Gen, X, St), + case (Gen) of + {(X), (St)} when is_float(X), 0.0 =< (X), (X) < 1.0 -> + St + end). +-define(CHECK_UNIFORM_NZ(Gen, X, St), + case (Gen) of + {(X), (St)} when is_float(X), 0.0 < (X), (X) =< 1.0 -> + St + end). +-define(CHECK_NORMAL(Gen, X, St), + case (Gen) of + {(X), (St)} when is_float(X) -> + St + end). + do_measure(_Config) -> - Algos = + Algs = + algs() ++ try crypto:strong_rand_bytes(1) of - <<_>> -> [crypto64, crypto] + <<_>> -> [crypto64, crypto_cache, crypto] catch error:low_entropy -> []; error:undef -> [] - end ++ algs(), + end, %% - ct:pal("RNG uniform integer performance~n",[]), - TMark1 = + ct:pal("~nRNG uniform integer range 10000 performance~n",[]), + _ = measure_1( - random, fun (_) -> 10000 end, - undefined, - fun (Range, State) -> - {int, random:uniform_s(Range, State)} - end), + fun (State, Range, Mod) -> + measure_loop( + fun (St0) -> + ?CHECK_UNIFORM_RANGE( + Mod:uniform_s(Range, St0), Range, + X, St1) + end, + State) + end, + Algs), + %% + ct:pal("~nRNG uniform integer 32 bit performance~n",[]), _ = - [measure_1( - Algo, - fun (_) -> 10000 end, - TMark1, - fun (Range, State) -> - {int, rand:uniform_s(Range, State)} - end) || Algo <- Algos], + measure_1( + fun (_) -> 1 bsl 32 end, + fun (State, Range, Mod) -> + measure_loop( + fun (St0) -> + ?CHECK_UNIFORM_RANGE( + Mod:uniform_s(Range, St0), Range, + X, St1) + end, + State) + end, + Algs), %% ct:pal("~nRNG uniform integer half range performance~n",[]), - HalfRangeFun = fun (State) -> half_range(State) end, - TMark2 = - measure_1( - random, - HalfRangeFun, - undefined, - fun (Range, State) -> - {int, random:uniform_s(Range, State)} - end), _ = - [measure_1( - Algo, - HalfRangeFun, - TMark2, - fun (Range, State) -> - {int, rand:uniform_s(Range, State)} - end) || Algo <- Algos], - %% - ct:pal("~nRNG uniform integer half range + 1 performance~n",[]), - HalfRangePlus1Fun = fun (State) -> half_range(State) + 1 end, - TMark3 = measure_1( - random, - HalfRangePlus1Fun, - undefined, - fun (Range, State) -> - {int, random:uniform_s(Range, State)} - end), + fun (State) -> half_range(State) end, + fun (State, Range, Mod) -> + measure_loop( + fun (St0) -> + ?CHECK_UNIFORM_RANGE( + Mod:uniform_s(Range, St0), Range, + X, St1) + end, + State) + end, + Algs), + %% + ct:pal("~nRNG uniform integer half range + 1 performance~n",[]), _ = - [measure_1( - Algo, - HalfRangePlus1Fun, - TMark3, - fun (Range, State) -> - {int, rand:uniform_s(Range, State)} - end) || Algo <- Algos], + measure_1( + fun (State) -> half_range(State) + 1 end, + fun (State, Range, Mod) -> + measure_loop( + fun (St0) -> + ?CHECK_UNIFORM_RANGE( + Mod:uniform_s(Range, St0), Range, + X, St1) + end, + State) + end, + Algs), %% ct:pal("~nRNG uniform integer full range - 1 performance~n",[]), - FullRangeMinus1Fun = fun (State) -> (half_range(State) bsl 1) - 1 end, - TMark4 = - measure_1( - random, - FullRangeMinus1Fun, - undefined, - fun (Range, State) -> - {int, random:uniform_s(Range, State)} - end), _ = - [measure_1( - Algo, - FullRangeMinus1Fun, - TMark4, - fun (Range, State) -> - {int, rand:uniform_s(Range, State)} - end) || Algo <- Algos], + measure_1( + fun (State) -> (half_range(State) bsl 1) - 1 end, + fun (State, Range, Mod) -> + measure_loop( + fun (St0) -> + ?CHECK_UNIFORM_RANGE( + Mod:uniform_s(Range, St0), Range, + X, St1) + end, + State) + end, + Algs), %% ct:pal("~nRNG uniform integer full range performance~n",[]), - FullRangeFun = fun (State) -> half_range(State) bsl 1 end, - TMark5 = - measure_1( - random, - FullRangeFun, - undefined, - fun (Range, State) -> - {int, random:uniform_s(Range, State)} - end), _ = - [measure_1( - Algo, - FullRangeFun, - TMark5, - fun (Range, State) -> - {int, rand:uniform_s(Range, State)} - end) || Algo <- Algos], + measure_1( + fun (State) -> half_range(State) bsl 1 end, + fun (State, Range, Mod) -> + measure_loop( + fun (St0) -> + ?CHECK_UNIFORM_RANGE( + Mod:uniform_s(Range, St0), Range, + X, St1) + end, + State) + end, + Algs), %% ct:pal("~nRNG uniform integer full range + 1 performance~n",[]), - FullRangePlus1Fun = fun (State) -> (half_range(State) bsl 1) + 1 end, - TMark6 = - measure_1( - random, - FullRangePlus1Fun, - undefined, - fun (Range, State) -> - {int, random:uniform_s(Range, State)} - end), _ = - [measure_1( - Algo, - FullRangePlus1Fun, - TMark6, - fun (Range, State) -> - {int, rand:uniform_s(Range, State)} - end) || Algo <- Algos], + measure_1( + fun (State) -> (half_range(State) bsl 1) + 1 end, + fun (State, Range, Mod) -> + measure_loop( + fun (St0) -> + ?CHECK_UNIFORM_RANGE( + Mod:uniform_s(Range, St0), Range, + X, St1) + end, + State) + end, + Algs), %% ct:pal("~nRNG uniform integer double range performance~n",[]), - DoubleRangeFun = fun (State) -> half_range(State) bsl 2 end, - TMark7 = - measure_1( - random, - DoubleRangeFun, - undefined, - fun (Range, State) -> - {int, random:uniform_s(Range, State)} - end), _ = - [measure_1( - Algo, - DoubleRangeFun, - TMark7, - fun (Range, State) -> - {int, rand:uniform_s(Range, State)} - end) || Algo <- Algos], + measure_1( + fun (State) -> + half_range(State) bsl 2 + end, + fun (State, Range, Mod) -> + measure_loop( + fun (St0) -> + ?CHECK_UNIFORM_RANGE( + Mod:uniform_s(Range, St0), Range, + X, St1) + end, + State) + end, + Algs), %% ct:pal("~nRNG uniform integer double range + 1 performance~n",[]), - DoubleRangePlus1Fun = fun (State) -> (half_range(State) bsl 2) + 1 end, - TMark8 = + _ = measure_1( - random, - DoubleRangePlus1Fun, - undefined, - fun (Range, State) -> - {int, random:uniform_s(Range, State)} - end), + fun (State) -> + (half_range(State) bsl 2) + 1 + end, + fun (State, Range, Mod) -> + measure_loop( + fun (St0) -> + ?CHECK_UNIFORM_RANGE( + Mod:uniform_s(Range, St0), Range, + X, St1) + end, + State) + end, + Algs), + %% + ct:pal("~nRNG uniform integer 64 bit performance~n",[]), _ = - [measure_1( - Algo, - DoubleRangePlus1Fun, - TMark8, - fun (Range, State) -> - {int, rand:uniform_s(Range, State)} - end) || Algo <- Algos], + measure_1( + fun (_) -> 1 bsl 64 end, + fun (State, Range, Mod) -> + measure_loop( + fun (St0) -> + ?CHECK_UNIFORM_RANGE( + Mod:uniform_s(Range, St0), Range, + X, St1) + end, + State) + end, + Algs), %% ct:pal("~nRNG uniform float performance~n",[]), - TMark9 = + _ = measure_1( - random, fun (_) -> 0 end, - undefined, - fun (_, State) -> - {uniform, random:uniform_s(State)} - end), + fun (State, _, Mod) -> + measure_loop( + fun (St0) -> + ?CHECK_UNIFORM(Mod:uniform_s(St0), X, St) + end, + State) + end, + Algs), + %% + ct:pal("~nRNG uniform_real float performance~n",[]), _ = - [measure_1( - Algo, - fun (_) -> 0 end, - TMark9, - fun (_, State) -> - {uniform, rand:uniform_s(State)} - end) || Algo <- Algos], + measure_1( + fun (_) -> 0 end, + fun (State, _, Mod) -> + measure_loop( + fun (St0) -> + ?CHECK_UNIFORM(Mod:uniform_real_s(St0), X, St) + end, + State) + end, + Algs), %% ct:pal("~nRNG normal float performance~n",[]), - io:format("~.12w: not implemented (too few bits)~n", [random]), - _ = [measure_1( - Algo, - fun (_) -> 0 end, - TMark9, - fun (_, State) -> - {normal, rand:normal_s(State)} - end) || Algo <- Algos], + [TMarkNormalFloat|_] = + measure_1( + fun (_) -> 0 end, + fun (State, _, Mod) -> + measure_loop( + fun (St0) -> + ?CHECK_NORMAL(Mod:normal_s(St0), X, St1) + end, + State) + end, + Algs), + %% Just for fun try an implementation of the Box-Muller + %% transformation for creating normal distribution floats + %% to compare with our Ziggurat implementation. + %% Generates two numbers per call that we add so they + %% will not be optimized away. Hence the benchmark time + %% is twice what it should be. + TwoPi = 2 * math:pi(), + _ = + measure_1( + fun (_) -> 0 end, + fun (State, _, Mod) -> + measure_loop( + fun (State0) -> + {U1, State1} = Mod:uniform_real_s(State0), + {U2, State2} = Mod:uniform_s(State1), + R = math:sqrt(-2.0 * math:log(U1)), + T = TwoPi * U2, + Z0 = R * math:cos(T), + Z1 = R * math:sin(T), + ?CHECK_NORMAL({Z0 + Z1, State2}, X, State3) + end, + State) + end, + exrop, TMarkNormalFloat), ok. -measure_1(Algo, RangeFun, TMark, Gen) -> +-define(LOOP_MEASURE, (?LOOP div 5)). + +measure_loop(Fun, State) -> + measure_loop(Fun, State, ?LOOP_MEASURE). +%% +measure_loop(Fun, State, N) when 0 < N -> + measure_loop(Fun, Fun(State), N-1); +measure_loop(_, _, _) -> + ok. + +measure_1(RangeFun, Fun, Algs) -> + TMark = measure_1(RangeFun, Fun, hd(Algs), undefined), + [TMark] ++ + [measure_1(RangeFun, Fun, Alg, TMark) || Alg <- tl(Algs)]. + +measure_1(RangeFun, Fun, Alg, TMark) -> Parent = self(), - Seed = - case Algo of + {Mod, State} = + case Alg of crypto64 -> - crypto64_seed(); + {rand, crypto64_seed()}; + crypto_cache -> + {rand, crypto:rand_seed_alg(crypto_cache)}; crypto -> - crypto:rand_seed_s(); + {rand, crypto:rand_seed_s()}; random -> - random:seed(os:timestamp()), get(random_seed); + {random, random:seed(os:timestamp()), get(random_seed)}; _ -> - rand:seed_s(Algo) + {rand, rand:seed_s(Alg)} end, - Range = RangeFun(Seed), + Range = RangeFun(State), Pid = spawn_link( fun() -> - Fun = fun() -> measure_2(?LOOP, Range, Seed, Gen) end, - {Time, ok} = timer:tc(Fun), + {Time, ok} = timer:tc(fun () -> Fun(State, Range, Mod) end), Percent = case TMark of undefined -> 100; @@ -673,7 +1117,8 @@ measure_1(Algo, RangeFun, TMark, Gen) -> end, io:format( "~.12w: ~p ns ~p% [16#~.16b]~n", - [Algo, (Time * 1000 + 500) div ?LOOP, Percent, Range]), + [Alg, (Time * 1000 + 500) div ?LOOP_MEASURE, + Percent, Range]), Parent ! {self(), Time}, normal end), @@ -681,21 +1126,6 @@ measure_1(Algo, RangeFun, TMark, Gen) -> {Pid, Msg} -> Msg end. -measure_2(N, Range, State0, Fun) when N > 0 -> - case Fun(Range, State0) of - {int, {Random, State}} - when is_integer(Random), Random >= 1, Random =< Range -> - measure_2(N-1, Range, State, Fun); - {uniform, {Random, State}} - when is_float(Random), 0.0 =< Random, Random < 1.0 -> - measure_2(N-1, Range, State, Fun); - {normal, {Random, State}} when is_float(Random) -> - measure_2(N-1, Range, State, Fun); - Res -> - exit({error, Res, State0}) - end; -measure_2(0, _, _, _) -> ok. - %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% The jump sequence tests has two parts %% for those with the functional API (jump/1) diff --git a/lib/stdlib/test/sets_SUITE.erl b/lib/stdlib/test/sets_SUITE.erl index bec38000b2..7066d07e19 100644 --- a/lib/stdlib/test/sets_SUITE.erl +++ b/lib/stdlib/test/sets_SUITE.erl @@ -28,7 +28,7 @@ init_per_testcase/2,end_per_testcase/2, create/1,add_element/1,del_element/1, subtract/1,intersection/1,union/1,is_subset/1, - is_set/1,fold/1,filter/1, + is_set/1,is_empty/1,fold/1,filter/1, take_smallest/1,take_largest/1, iterate/1]). -include_lib("common_test/include/ct.hrl"). @@ -48,7 +48,7 @@ suite() -> all() -> [create, add_element, del_element, subtract, intersection, union, is_subset, is_set, fold, filter, - take_smallest, take_largest, iterate]. + take_smallest, take_largest, iterate, is_empty]. groups() -> []. @@ -345,6 +345,17 @@ is_set_1(M) -> false = M(is_set, {}), M(empty, []). +is_empty(Config) when is_list(Config) -> + test_all(fun is_empty_1/1). + +is_empty_1(M) -> + S = M(from_list, [blurf]), + Empty = M(empty, []), + + true = M(is_empty, Empty), + false = M(is_empty, S), + M(empty, []). + fold(Config) when is_list(Config) -> test_all([{0,71},{125,129},{254,259},{510,513},{1023,1025},{9999,10001}], fun fold_1/2). diff --git a/lib/stdlib/test/sets_test_lib.erl b/lib/stdlib/test/sets_test_lib.erl index 9f153822a2..93d027704b 100644 --- a/lib/stdlib/test/sets_test_lib.erl +++ b/lib/stdlib/test/sets_test_lib.erl @@ -32,7 +32,7 @@ new(Mod, Eq) -> (from_list, L) -> Mod:from_list(L); (intersection, {S1,S2}) -> intersection(Mod, Eq, S1, S2); (intersection, Ss) -> intersection(Mod, Eq, Ss); - (is_empty, S) -> is_empty(Mod, S); + (is_empty, S) -> Mod:is_empty(S); (is_set, S) -> Mod:is_set(S); (is_subset, {S,Set}) -> is_subset(Mod, Eq, S, Set); (iterator, S) -> Mod:iterator(S); @@ -56,7 +56,7 @@ singleton(Mod, E) -> add_element(Mod, El, S0) -> S = Mod:add_element(El, S0), true = Mod:is_element(El, S), - false = is_empty(Mod, S), + false = Mod:is_empty(S), true = Mod:is_set(S), S. @@ -66,17 +66,10 @@ del_element(Mod, El, S0) -> true = Mod:is_set(S), S. -is_empty(Mod, S) -> - true = Mod:is_set(S), - case erlang:function_exported(Mod, is_empty, 1) of - true -> Mod:is_empty(S); - false -> Mod:size(S) == 0 - end. - intersection(Mod, Equal, S1, S2) -> S = Mod:intersection(S1, S2), true = Equal(S, Mod:intersection(S2, S1)), - Disjoint = is_empty(Mod, S), + Disjoint = Mod:is_empty(S), Disjoint = Mod:is_disjoint(S1, S2), Disjoint = Mod:is_disjoint(S2, S1), S. diff --git a/lib/stdlib/test/stdlib.spec b/lib/stdlib/test/stdlib.spec index 3768e494b2..9c625091a8 100644 --- a/lib/stdlib/test/stdlib.spec +++ b/lib/stdlib/test/stdlib.spec @@ -1 +1,4 @@ {suites,"../stdlib_test",all}. +{skip_groups,"../stdlib_test",stdlib_bench_SUITE, + [base64,gen_server,gen_statem,unicode], + "Benchmark only"}. diff --git a/lib/stdlib/test/stdlib_bench.spec b/lib/stdlib/test/stdlib_bench.spec new file mode 100644 index 0000000000..7a0da811a0 --- /dev/null +++ b/lib/stdlib/test/stdlib_bench.spec @@ -0,0 +1,10 @@ +%% Needed to compile ,unicode_util_SUITE and string_SUITE... +{cases,"../stdlib_test",unicode_util_SUITE, []}. +{cases,"../stdlib_test",string_SUITE, []}. +{skip_suites,"../stdlib_test",unicode_util_SUITE, "bench only"}. +{skip_suites,"../stdlib_test",string_SUITE, "bench only"}. + +{suites,"../stdlib_test",[stdlib_bench_SUITE]}. +{skip_groups,"../stdlib_test",stdlib_bench_SUITE, + [gen_server_comparison,gen_statem_comparison], + "Not a benchmark"}. diff --git a/lib/stdlib/test/stdlib_bench_SUITE.erl b/lib/stdlib/test/stdlib_bench_SUITE.erl new file mode 100644 index 0000000000..2364e8376f --- /dev/null +++ b/lib/stdlib/test/stdlib_bench_SUITE.erl @@ -0,0 +1,546 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2012-2018. 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(stdlib_bench_SUITE). +-compile([export_all, nowarn_export_all]). +-include_lib("common_test/include/ct.hrl"). +-include_lib("common_test/include/ct_event.hrl"). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +suite() -> [{ct_hooks,[{ts_install_cth,[{nodenames,2}]}]}]. + + +all() -> + [{group,unicode},{group,base64}, + {group,gen_server},{group,gen_statem}, + {group,gen_server_comparison},{group,gen_statem_comparison}]. + +groups() -> + [{unicode,[{repeat,5}], + [norm_nfc_list, norm_nfc_deep_l, norm_nfc_binary, + string_lexemes_list, string_lexemes_binary + ]}, + {base64,[{repeat,5}], + [decode_binary, decode_binary_to_string, + decode_list, decode_list_to_string, + encode_binary, encode_binary_to_string, + encode_list, encode_list_to_string, + mime_binary_decode, mime_binary_decode_to_string, + mime_list_decode, mime_list_decode_to_string]}, + {gen_server, [{repeat,5}], cases(gen_server)}, + {gen_statem, [{repeat,3}], cases(gen_statem)}, + {gen_server_comparison, [], + [single_small, single_medium, single_big, + sched_small, sched_medium, sched_big, + multi_small, multi_medium, multi_big]}, + {gen_statem_comparison, [], + [single_small, single_big, + sched_small, sched_big, + multi_small, multi_big]}]. + +cases(gen_server) -> + [simple, simple_timer, simple_mon, simple_timer_mon, + generic, generic_timer]; +cases(gen_statem) -> + [generic, generic_fsm, generic_fsm_transit, + generic_statem, generic_statem_transit, + generic_statem_complex]. + +init_per_group(gen_server, Config) -> + compile_servers(Config), + [{benchmark_suite,"stdlib_gen_server"}|Config]; +init_per_group(gen_statem, Config) -> + compile_servers(Config), + [{benchmark_suite,"stdlib_gen_statem"}|Config]; +init_per_group(gen_server_comparison, Config) -> + compile_servers(Config), + [{cases,cases(gen_server)}, + {benchmark_suite,"stdlib_gen_server"}|Config]; +init_per_group(gen_statem_comparison, Config) -> + compile_servers(Config), + [{cases,cases(gen_statem)}, + {benchmark_suite,"stdlib_gen_statem"}|Config]; +init_per_group(_GroupName, Config) -> + Config. + +end_per_group(_GroupName, Config) -> + Config. + +init_per_suite(Config) -> + Config. + +end_per_suite(Config) -> + Config. + +init_per_testcase(_Func, Conf) -> + Conf. + +end_per_testcase(_Func, _Conf) -> + ok. + + +compile_servers(Config) -> + DataDir = ?config(data_dir, Config), + Files = filelib:wildcard(filename:join(DataDir, "{simple,generic}*.erl")), + _ = [{ok, _} = compile:file(File) || File <- Files], + ok. + +comment(Value) -> + C = lists:flatten(io_lib:format("~p", [Value])), + {comment, C}. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +-define(REPEAT_NORM, 5). + +norm_nfc_list(Config) -> + Bin = norm_data(Config), + {_N, Mean, _Stddev, Res} = unicode_util_SUITE:time_count(nfc, list, Bin, ?REPEAT_NORM), + comment(report(1000.0*Res / Mean)). + +norm_nfc_deep_l(Config) -> + Bin = norm_data(Config), + {_N, Mean, _Stddev, Res} = unicode_util_SUITE:time_count(nfc, deep_l, Bin, ?REPEAT_NORM), + comment(report(1000.0*Res / Mean)). + +norm_nfc_binary(Config) -> + Bin = norm_data(Config), + {_N, Mean, _Stddev, Res} = unicode_util_SUITE:time_count(nfc, binary, Bin, ?REPEAT_NORM), + comment(report(1000.0*Res / Mean)). + + +string_lexemes_list(Config) -> + %% Use nth_lexeme instead of lexemes to avoid building a result of + %% large lists which causes large differences between test runs, gc? + Bin = norm_data(Config), + Fun = fun(Str) -> string:nth_lexeme(Str, 200000, [$;,$\n,$\r]), 200000 end, + {_N, Mean, _Stddev, Res} = string_SUITE:time_func(Fun, list, Bin, 15), + comment(report(1000.0*Res / Mean)). + +string_lexemes_binary(Config) -> + %% Use nth_lexeme instead of lexemes to avoid building a result of + %% large lists which causes large differences between test runs, gc? + Bin = norm_data(Config), + Fun = fun(Str) -> string:nth_lexeme(Str, 200000, [$;,$\n,$\r]), 200000 end, + {_N, Mean, _Stddev, Res} = string_SUITE:time_func(Fun, binary, Bin, ?REPEAT_NORM), + comment(report(1000.0*Res / Mean)). + +%%% +report(Tps) -> + ct_event:notify(#event{name = benchmark_data, + data = [{suite,"stdlib_unicode"},{value,round(Tps)}]}), + Tps. + +norm_data(Config) -> + DataDir0 = proplists:get_value(data_dir, Config), + DataDir = filename:join(lists:droplast(filename:split(DataDir0))), + File = filename:join([DataDir,"unicode_util_SUITE_data","NormalizationTest.txt"]), + {ok, Bin} = file:read_file(File), + Bin. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +decode_binary(_Config) -> + comment(test(decode, encoded_binary())). + +decode_binary_to_string(_Config) -> + comment(test(decode_to_string, encoded_binary())). + +decode_list(_Config) -> + comment(test(decode, encoded_list())). + +decode_list_to_string(_Config) -> + comment(test(decode_to_string, encoded_list())). + +encode_binary(_Config) -> + comment(test(encode, binary())). + +encode_binary_to_string(_Config) -> + comment(test(encode_to_string, binary())). + +encode_list(_Config) -> + comment(test(encode, list())). + +encode_list_to_string(_Config) -> + comment(test(encode_to_string, list())). + +mime_binary_decode(_Config) -> + comment(test(mime_decode, encoded_binary())). + +mime_binary_decode_to_string(_Config) -> + comment(test(mime_decode_to_string, encoded_binary())). + +mime_list_decode(_Config) -> + comment(test(mime_decode, encoded_list())). + +mime_list_decode_to_string(_Config) -> + comment(test(mime_decode_to_string, encoded_list())). + +-define(SIZE, 10000). +-define(N, 1000). + +encoded_binary() -> + list_to_binary(encoded_list()). + +encoded_list() -> + L = random_byte_list(round(?SIZE*0.75)), + base64:encode_to_string(L). + +binary() -> + list_to_binary(list()). + +list() -> + random_byte_list(?SIZE). + +test(Func, Data) -> + F = fun() -> loop(?N, Func, Data) end, + {Time, ok} = timer:tc(fun() -> lspawn(F) end), + report_base64(Time). + +loop(0, _F, _D) -> garbage_collect(), ok; +loop(N, F, D) -> + _ = base64:F(D), + loop(N - 1, F, D). + +lspawn(Fun) -> + {Pid, Ref} = spawn_monitor(fun() -> exit(Fun()) end), + receive + {'DOWN', Ref, process, Pid, Rep} -> Rep + end. + +report_base64(Time) -> + Tps = round((?N*1000000)/Time), + ct_event:notify(#event{name = benchmark_data, + data = [{suite, "stdlib_base64"}, + {value, Tps}]}), + Tps. + +%% Copied from base64_SUITE.erl. + +random_byte_list(N) -> + random_byte_list(N, []). + +random_byte_list(0, Acc) -> + Acc; +random_byte_list(N, Acc) -> + random_byte_list(N-1, [rand:uniform(255)|Acc]). + +make_big_binary(N) -> + list_to_binary(mbb(N, [])). + +mbb(N, Acc) when N > 256 -> + B = list_to_binary(lists:seq(0, 255)), + mbb(N - 256, [B | Acc]); +mbb(N, Acc) -> + B = list_to_binary(lists:seq(0, N-1)), + lists:reverse(Acc, B). + +simple(Config) when is_list(Config) -> + comment(do_tests(simple, single_small, Config)). + +simple_timer(Config) when is_list(Config) -> + comment(do_tests(simple_timer, single_small, Config)). + +simple_mon(Config) when is_list(Config) -> + comment(do_tests(simple_mon, single_small, Config)). + +simple_timer_mon(Config) when is_list(Config) -> + comment(do_tests(simple_timer_mon, single_small, Config)). + +generic(Config) when is_list(Config) -> + comment(do_tests(generic, single_small, Config)). + +generic_timer(Config) when is_list(Config) -> + comment(do_tests(generic_timer, single_small, Config)). + +generic_statem(Config) when is_list(Config) -> + comment(do_tests(generic_statem, single_small, Config)). + +generic_statem_transit(Config) when is_list(Config) -> + comment(do_tests(generic_statem_transit, single_small, Config)). + +generic_statem_complex(Config) when is_list(Config) -> + comment(do_tests(generic_statem_complex, single_small, Config)). + +generic_fsm(Config) when is_list(Config) -> + comment(do_tests(generic_fsm, single_small, Config)). + +generic_fsm_transit(Config) when is_list(Config) -> + comment(do_tests(generic_fsm_transit, single_small, Config)). + +single_small(Config) when is_list(Config) -> + comparison(?config(cases, Config), single_small, Config). + +single_medium(Config) when is_list(Config) -> + comparison(?config(cases, Config), single_medium, Config). + +single_big(Config) when is_list(Config) -> + comparison(?config(cases, Config), single_big, Config). + +sched_small(Config) when is_list(Config) -> + comparison(?config(cases, Config), sched_small, Config). + +sched_medium(Config) when is_list(Config) -> + comparison(?config(cases, Config), sched_medium, Config). + +sched_big(Config) when is_list(Config) -> + comparison(?config(cases, Config), sched_big, Config). + +multi_small(Config) when is_list(Config) -> + comparison(?config(cases, Config), multi_small, Config). + +multi_medium(Config) when is_list(Config) -> + comparison(?config(cases, Config), multi_medium, Config). + +multi_big(Config) when is_list(Config) -> + comparison(?config(cases, Config), multi_big, Config). + +comparison(Cases, Kind, Config) -> + Cases = ?config(cases, Config), + [RefResult|_] = Results = + [do_tests(Case, Kind, Config) || Case <- Cases], + Normalized = [norm(Result, RefResult) || Result <- Results], + {Parallelism, Message} = bench_params(Kind), + Wordsize = erlang:system_info(wordsize), + MSize = Wordsize * erts_debug:flat_size(Message), + What = io_lib:format("#parallel gen_server instances: ~.4w, " + "message flat size: ~.5w bytes", + [Parallelism, MSize]), + Format = + lists:flatten( + ["~s: "] ++ + [[atom_to_list(Case),": ~s "] || Case <- Cases]), + C = lists:flatten(io_lib:format(Format, [What] ++ Normalized)), + {comment, C}. + +norm(T, Ref) -> + try Ref / T of + Norm -> + io_lib:format("~.2f", [Norm]) + catch error:badarith -> + "---" + end. + +-define(MAX_TIME_SECS, 3). % s +-define(MAX_TIME, 1000 * ?MAX_TIME_SECS). % ms +-define(CALLS_PER_LOOP, 5). + +do_tests(Test, ParamSet, Config) -> + BenchmarkSuite = ?config(benchmark_suite, Config), + {Client, ServerMod} = bench(Test), + {Parallelism, Message} = bench_params(ParamSet), + Fun = create_clients(Message, ServerMod, Client, Parallelism), + {TotalLoops, AllPidTime} = run_test(Fun), + try ?CALLS_PER_LOOP * round((1000 * TotalLoops) / AllPidTime) of + PerSecond -> + ct_event:notify( + #event{ + name = benchmark_data, + data = [{suite,BenchmarkSuite},{value,PerSecond}]}), + PerSecond + catch error:badarith -> + "Time measurement is not working" + end. + +-define(COUNTER, n). + +simple_client(N, M, P) -> + put(?COUNTER, N), + _ = simple_server:reply(P, M), + _ = simple_server:reply(P, M), + _ = simple_server:reply(P, M), + _ = simple_server:reply(P, M), + _ = simple_server:reply(P, M), + simple_client(N+1, M, P). + +simple_client_timer(N, M, P) -> + put(?COUNTER, N), + _ = simple_server_timer:reply(P, M), + _ = simple_server_timer:reply(P, M), + _ = simple_server_timer:reply(P, M), + _ = simple_server_timer:reply(P, M), + _ = simple_server_timer:reply(P, M), + simple_client_timer(N+1, M, P). + +simple_client_mon(N, M, P) -> + put(?COUNTER, N), + _ = simple_server_mon:reply(P, M), + _ = simple_server_mon:reply(P, M), + _ = simple_server_mon:reply(P, M), + _ = simple_server_mon:reply(P, M), + _ = simple_server_mon:reply(P, M), + simple_client_mon(N+1, M, P). + +simple_client_timer_mon(N, M, P) -> + put(?COUNTER, N), + _ = simple_server_timer_mon:reply(P, M), + _ = simple_server_timer_mon:reply(P, M), + _ = simple_server_timer_mon:reply(P, M), + _ = simple_server_timer_mon:reply(P, M), + _ = simple_server_timer_mon:reply(P, M), + simple_client_timer_mon(N+1, M, P). + +generic_client(N, M, P) -> + put(?COUNTER, N), + _ = generic_server:reply(P, M), + _ = generic_server:reply(P, M), + _ = generic_server:reply(P, M), + _ = generic_server:reply(P, M), + _ = generic_server:reply(P, M), + generic_client(N+1, M, P). + +generic_timer_client(N, M, P) -> + put(?COUNTER, N), + _ = generic_server_timer:reply(P, M), + _ = generic_server_timer:reply(P, M), + _ = generic_server_timer:reply(P, M), + _ = generic_server_timer:reply(P, M), + _ = generic_server_timer:reply(P, M), + generic_timer_client(N+1, M, P). + +generic_statem_client(N, M, P) -> + put(?COUNTER, N), + _ = generic_statem:reply(P, M), + _ = generic_statem:reply(P, M), + _ = generic_statem:reply(P, M), + _ = generic_statem:reply(P, M), + _ = generic_statem:reply(P, M), + generic_statem_client(N+1, M, P). + +generic_statem_transit_client(N, M, P) -> + put(?COUNTER, N), + _ = generic_statem:transit(P, M), + _ = generic_statem:transit(P, M), + _ = generic_statem:transit(P, M), + _ = generic_statem:transit(P, M), + _ = generic_statem:transit(P, M), + generic_statem_transit_client(N+1, M, P). + +generic_statem_complex_client(N, M, P) -> + put(?COUNTER, N), + _ = generic_statem:reply(P, M), + _ = generic_statem:reply(P, M), + _ = generic_statem:reply(P, M), + _ = generic_statem:reply(P, M), + _ = generic_statem:reply(P, M), + generic_statem_complex_client(N+1, M, P). + +generic_fsm_client(N, M, P) -> + put(?COUNTER, N), + _ = generic_fsm:reply(P, M), + _ = generic_fsm:reply(P, M), + _ = generic_fsm:reply(P, M), + _ = generic_fsm:reply(P, M), + _ = generic_fsm:reply(P, M), + generic_fsm_client(N+1, M, P). + +generic_fsm_transit_client(N, M, P) -> + put(?COUNTER, N), + _ = generic_fsm:transit(P, M), + _ = generic_fsm:transit(P, M), + _ = generic_fsm:transit(P, M), + _ = generic_fsm:transit(P, M), + _ = generic_fsm:transit(P, M), + generic_fsm_transit_client(N+1, M, P). + +bench(simple) -> + {fun simple_client/3, simple_server}; +bench(simple_timer) -> + {fun simple_client_timer/3, simple_server_timer}; +bench(simple_mon) -> + {fun simple_client_mon/3, simple_server_mon}; +bench(simple_timer_mon) -> + {fun simple_client_timer_mon/3, simple_server_timer_mon}; +bench(generic) -> + {fun generic_client/3, generic_server}; +bench(generic_timer) -> + {fun generic_timer_client/3, generic_server_timer}; +bench(generic_statem) -> + {fun generic_statem_client/3, generic_statem}; +bench(generic_statem_transit) -> + {fun generic_statem_transit_client/3, generic_statem}; +bench(generic_statem_complex) -> + {fun generic_statem_complex_client/3, generic_statem_complex}; +bench(generic_fsm) -> + {fun generic_fsm_client/3, generic_fsm}; +bench(generic_fsm_transit) -> + {fun generic_fsm_transit_client/3, generic_fsm}. + +%% -> {Parallelism, MessageTerm} +bench_params(single_small) -> {1, small()}; +bench_params(single_medium) -> {1, medium()}; +bench_params(single_big) -> {1, big()}; +bench_params(sched_small) -> {parallelism(), small()}; +bench_params(sched_medium) -> {parallelism(), medium()}; +bench_params(sched_big) -> {parallelism(), big()}; +bench_params(multi_small) -> {400, small()}; +bench_params(multi_medium) -> {400, medium()}; +bench_params(multi_big) -> {400, big()}. + +small() -> + small. + +medium() -> + lists:seq(1, 50). + +big() -> + lists:seq(1, 1000). + +parallelism() -> + case erlang:system_info(multi_scheduling) of + enabled -> erlang:system_info(schedulers_online); + _ -> 1 + end. + +create_clients(M, ServerMod, Client, Parallel) -> + fun() -> + State = term, + ServerPid = ServerMod:start(State), + PidRefs = [spawn_monitor(fun() -> Client(0, M, ServerPid) end) || + _ <- lists:seq(1, Parallel)], + timer:sleep(?MAX_TIME), + try + AllPidsN = collect(PidRefs, []), + TotalLoops = lists:sum(AllPidsN), + TotalLoops + after + ok = ServerMod:stop(ServerPid) + end + end. + +collect([], Result) -> + Result; +collect([{Pid, Ref}|PidRefs], Result) -> + N = case erlang:process_info(Pid, dictionary) of + {dictionary, Dict} -> + {?COUNTER, N0} = lists:keyfind(?COUNTER, 1, Dict), + N0; + undefined -> % Process did not start in ?MAX_TIME_SECS. + 0 + end, + exit(Pid, kill), + receive {'DOWN', Ref, _, _, _} -> ok end, + collect(PidRefs, [N|Result]). + +run_test(Test) -> + {T1, _} = statistics(runtime), + Result = Test(), + {T2, _} = statistics(runtime), + {Result, T2 - T1}. diff --git a/lib/stdlib/test/stdlib_bench_SUITE_data/generic_fsm.erl b/lib/stdlib/test/stdlib_bench_SUITE_data/generic_fsm.erl new file mode 100644 index 0000000000..50f7df7a2a --- /dev/null +++ b/lib/stdlib/test/stdlib_bench_SUITE_data/generic_fsm.erl @@ -0,0 +1,59 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2017-2018. 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(generic_fsm). + +-export([start/1, reply/2, transit/2, stop/1]). + +-export([init/1, terminate/3]). +-export([state1/3, state2/3]). + +-behaivour(gen_fsm). + + +%% API + +start(Data) -> + {ok, Pid} = gen_fsm:start(?MODULE, Data, []), + Pid. + +stop(P) -> + ok = gen_fsm:stop(P). + +reply(S, M) -> + gen_fsm:sync_send_event(S, {reply, M}, infinity). + +transit(S, M) -> + gen_fsm:sync_send_event(S, {transit, M}, infinity). + +%% Implementation + +init(Data) -> + {ok, state1, Data}. + +terminate(_Reason, _State, _Data) -> + ok. + +state1({reply, M}, _From, Data) -> + {reply, M, ?FUNCTION_NAME, Data}; +state1({transit, M}, _From, Data) -> + {reply, M, state2, Data}. + +state2({transit, M}, _From, Data) -> + {reply, M, state1, Data}. diff --git a/lib/stdlib/test/stdlib_bench_SUITE_data/generic_server.erl b/lib/stdlib/test/stdlib_bench_SUITE_data/generic_server.erl new file mode 100644 index 0000000000..abd61dcdef --- /dev/null +++ b/lib/stdlib/test/stdlib_bench_SUITE_data/generic_server.erl @@ -0,0 +1,31 @@ +-module(generic_server). + +-export([start/1, reply/2, stop/1]). + +-export([handle_call/3, handle_cast/2, init/1, terminate/2]). + +-behaviour(gen_server). + +-define(GEN_SERVER, gen_server). + +start(State) -> + {ok, Pid} = ?GEN_SERVER:start(?MODULE, State, []), + Pid. + +init(State) -> + {ok, State}. + +stop(P) -> + ok = ?GEN_SERVER:stop(P). + +reply(S, M) -> + _M = ?GEN_SERVER:call(S, {reply, M}, infinity). + +handle_call({reply, M}, _From, State) -> + {reply, M, State}. + +handle_cast(_Msg, State) -> + {noreply, State}. + +terminate(_Reason, _State) -> + ok. diff --git a/lib/stdlib/test/stdlib_bench_SUITE_data/generic_server_timer.erl b/lib/stdlib/test/stdlib_bench_SUITE_data/generic_server_timer.erl new file mode 100644 index 0000000000..0faa30207d --- /dev/null +++ b/lib/stdlib/test/stdlib_bench_SUITE_data/generic_server_timer.erl @@ -0,0 +1,31 @@ +-module(generic_server_timer). + +-export([start/1, reply/2, stop/1]). + +-export([handle_call/3, handle_cast/2, init/1, terminate/2]). + +-behaviour(gen_server). + +-define(GEN_SERVER, gen_server). + +start(State) -> + {ok, Pid} = ?GEN_SERVER:start(?MODULE, State, []), + Pid. + +init(State) -> + {ok, State}. + +stop(P) -> + ok = ?GEN_SERVER:stop(P). + +reply(S, M) -> + ?GEN_SERVER:call(S, {reply, M}). + +handle_call({reply, M}, _From, State) -> + {reply, M, State}. + +handle_cast(_Msg, State) -> + {noreply, State}. + +terminate(_Reason, _State) -> + ok. diff --git a/lib/stdlib/test/stdlib_bench_SUITE_data/generic_statem.erl b/lib/stdlib/test/stdlib_bench_SUITE_data/generic_statem.erl new file mode 100644 index 0000000000..2e0491f060 --- /dev/null +++ b/lib/stdlib/test/stdlib_bench_SUITE_data/generic_statem.erl @@ -0,0 +1,58 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2017-2018. 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(generic_statem). + +-export([start/1, reply/2, transit/2, stop/1]). + +-export([callback_mode/0, init/1]). +-export([state1/3, state2/3]). + +-behaviour(gen_statem). + +%% API + +start(Data) -> + {ok, Pid} = gen_statem:start(?MODULE, Data, []), + Pid. + +stop(P) -> + ok = gen_statem:stop(P). + +reply(S, M) -> + gen_statem:call(S, {reply, M}, infinity). + +transit(S, M) -> + gen_statem:call(S, {transit, M}, infinity). + +%% Implementation + +callback_mode() -> + state_functions. + +init(Data) -> + {ok, state1, Data}. + +state1({call, From}, {reply, M}, Data) -> + {keep_state, Data, {reply, From, M}}; +state1({call, From}, {transit, M}, Data) -> + {next_state, state2, Data, {reply, From, M}}. + +state2({call, From}, {transit, M}, Data) -> + {next_state, state1, Data, {reply, From, M}}. diff --git a/lib/stdlib/test/stdlib_bench_SUITE_data/generic_statem_complex.erl b/lib/stdlib/test/stdlib_bench_SUITE_data/generic_statem_complex.erl new file mode 100644 index 0000000000..983227d281 --- /dev/null +++ b/lib/stdlib/test/stdlib_bench_SUITE_data/generic_statem_complex.erl @@ -0,0 +1,66 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2017-2018. 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(generic_statem_complex). + +-export([start/1, reply/2, stop/1]). + +-export([callback_mode/0, init/1]). +-export([state1/3, state2/3, state3/3]). + +-behaviour(gen_statem). + +%% API + +start(Data) -> + {ok, Pid} = gen_statem:start(?MODULE, Data, []), + Pid. + +stop(P) -> + ok = gen_statem:stop(P). + +reply(S, M) -> + gen_statem:call(S, {reply, M}, infinity). + +%% Implementation + +callback_mode() -> + [state_functions,state_enter]. + +init(Data) -> + {ok, state1, Data}. + +state1(enter, _, Data) -> + {keep_state, Data, + {state_timeout, 5000, t1}}; +state1({call, _From}, {reply, _M}, Data) -> + {next_state, state2, Data, + [postpone,{next_event,internal,e}]}. + +state2(enter, _, _Data) -> + keep_state_and_data; +state2(internal, e, Data) -> + {next_state, state3, Data}. + +state3(enter, _, Data) -> + {keep_state, Data, + {state_timeout, 5000, t3}}; +state3({call, From}, {reply, M}, Data) -> + {next_state, state1, Data, + {reply, From, M}}. diff --git a/lib/stdlib/test/stdlib_bench_SUITE_data/simple_server.erl b/lib/stdlib/test/stdlib_bench_SUITE_data/simple_server.erl new file mode 100644 index 0000000000..bd43f686e8 --- /dev/null +++ b/lib/stdlib/test/stdlib_bench_SUITE_data/simple_server.erl @@ -0,0 +1,31 @@ +-module(simple_server). + +%% Local process. No timer. No monitor. + +-export([start/1, reply/2, stop/1]). + +start(State) -> + spawn(fun() -> loop(State) end). + +stop(P) -> + P ! {stop, self()}, + receive + ok -> + ok + end. + +loop(S) -> + receive + {reply, P, M} -> + P ! M, + loop(S); + {stop, P} -> + P ! ok + end. + +reply(P, M) -> + P ! {reply, self(), M}, + receive + M -> + M + end. diff --git a/lib/stdlib/test/stdlib_bench_SUITE_data/simple_server_mon.erl b/lib/stdlib/test/stdlib_bench_SUITE_data/simple_server_mon.erl new file mode 100644 index 0000000000..9b5ace5586 --- /dev/null +++ b/lib/stdlib/test/stdlib_bench_SUITE_data/simple_server_mon.erl @@ -0,0 +1,33 @@ +-module(simple_server_mon). + +%% Local process. No timer. Monitor. + +-export([start/1, reply/2, stop/1]). + +start(State) -> + spawn(fun() -> loop(State) end). + +stop(P) -> + P ! {stop, self()}, + receive + ok -> + ok + end. + +loop(S) -> + receive + {reply, P, Mref, M} -> + P ! {ok, Mref, M}, + loop(S); + {stop, P} -> + P ! ok + end. + +reply(P, M) -> + Mref = erlang:monitor(process, P), + P ! {reply, self(), Mref, M}, + receive + {ok, Mref, M} -> + erlang:demonitor(Mref, [flush]), + ok + end. diff --git a/lib/stdlib/test/stdlib_bench_SUITE_data/simple_server_timer.erl b/lib/stdlib/test/stdlib_bench_SUITE_data/simple_server_timer.erl new file mode 100644 index 0000000000..82381e1fdf --- /dev/null +++ b/lib/stdlib/test/stdlib_bench_SUITE_data/simple_server_timer.erl @@ -0,0 +1,33 @@ +-module(simple_server_timer). + +%% Local process. Timer. No monitor. + +-export([start/1, reply/2, stop/1]). + +start(State) -> + spawn(fun() -> loop(State) end). + +stop(P) -> + P ! {stop, self()}, + receive + ok -> + ok + end. + +loop(S) -> + receive + {reply, P, M} -> + P ! M, + loop(S); + {stop, P} -> + P ! ok + end. + +reply(P, M) -> + P ! {reply, self(), M}, + receive + M -> + M + after 100 -> + exit(fel) + end. diff --git a/lib/stdlib/test/stdlib_bench_SUITE_data/simple_server_timer_mon.erl b/lib/stdlib/test/stdlib_bench_SUITE_data/simple_server_timer_mon.erl new file mode 100644 index 0000000000..6124ca29c2 --- /dev/null +++ b/lib/stdlib/test/stdlib_bench_SUITE_data/simple_server_timer_mon.erl @@ -0,0 +1,35 @@ +-module(simple_server_timer_mon). + +%% Local process. Timer. Monitor. + +-export([start/1, reply/2, stop/1]). + +start(State) -> + spawn(fun() -> loop(State) end). + +stop(P) -> + P ! {stop, self()}, + receive + ok -> + ok + end. + +loop(S) -> + receive + {reply, P, Mref, M} -> + P ! {ok, Mref, M}, + loop(S); + {stop, P} -> + P ! ok + end. + +reply(P, M) -> + Mref = erlang:monitor(process, P), + P ! {reply, self(), Mref, M}, + receive + {ok, Mref, M} -> + erlang:demonitor(Mref, [flush]), + ok + after 100 -> + exit(fel) + end. diff --git a/lib/stdlib/test/string_SUITE.erl b/lib/stdlib/test/string_SUITE.erl index 17714b8d4d..fdff2d24b8 100644 --- a/lib/stdlib/test/string_SUITE.erl +++ b/lib/stdlib/test/string_SUITE.erl @@ -47,7 +47,8 @@ -export([to_upper_to_lower/1]). %% Run tests when debugging them --export([debug/0]). +-export([debug/0, time_func/4]). +-compile([nowarn_deprecated_function]). suite() -> [{ct_hooks,[ts_install_cth]}, @@ -752,12 +753,12 @@ do_measure(DataDir) -> {ok, Bin} = file:read_file(File), io:format("~p~n",[byte_size(Bin)]), Do = fun(Name, Func, Mode) -> - {N, Mean, Stddev, _} = time_func(Func, Mode, Bin), + {N, Mean, Stddev, _} = time_func(Func, Mode, Bin, 20), io:format("~15w ~6w ~6.2fms ±~5.2fms #~.2w gc included~n", [Name, Mode, Mean/1000, Stddev/1000, N]) end, Do2 = fun(Name, Func, Mode) -> - {N, Mean, Stddev, _} = time_func(Func, binary, <<>>), + {N, Mean, Stddev, _} = time_func(Func, binary, <<>>, 20), io:format("~15w ~6w ~6.2fms ±~5.2fms #~.2w gc included~n", [Name, Mode, Mean/1000, Stddev/1000, N]) end, @@ -880,9 +881,9 @@ test_1(Line, Func, Str, Args, Exp) -> catch error:Exp -> ok; - error:Reason -> + error:Reason:Stacktrace -> io:format("~p:~p: Crash ~p ~p~n", - [?MODULE,Line, Reason, erlang:get_stacktrace()]), + [?MODULE,Line, Reason, Stacktrace]), exit({error, Func}) end. @@ -947,10 +948,10 @@ check_types(Line, Func, [Str|_], Res) -> io:format("Failed: ~p ~p: ~p ~p~n",[Line, Func, T1, T2]), io:format(" ~p => ~p~n", [Str, Res]), error; - _:Reason -> - io:format("Crash: ~p in~n ~p~n",[Reason, erlang:get_stacktrace()]), + _:Reason:Stacktrace -> + io:format("Crash: ~p in~n ~p~n",[Reason, Stacktrace]), io:format("Failed: ~p ~p: ~p => ~p~n", [Line, Func, Str, Res]), - exit({Reason, erlang:get_stacktrace()}) + exit({Reason, Stacktrace}) end. check_types_1(T, T) -> @@ -1033,19 +1034,19 @@ needs_check(_) -> true. %%%% Timer stuff -time_func(Fun, Mode, Bin) -> +time_func(Fun, Mode, Bin, Repeat) -> timer:sleep(100), %% Let emulator catch up and clean things before test runs Self = self(), Pid = spawn_link(fun() -> Str = mode(Mode, Bin), - Self ! {self(),time_func(0,0,0, Fun, Str, undefined)} + Self ! {self(),time_func(0,0,0, Fun, Str, undefined, Repeat)} end), receive {Pid,Msg} -> Msg end. -time_func(N,Sum,SumSq, Fun, Str, _) when N < 20 -> +time_func(N,Sum,SumSq, Fun, Str, _, Repeat) when N < Repeat -> {Time, Res} = timer:tc(fun() -> Fun(Str) end), - time_func(N+1,Sum+Time,SumSq+Time*Time, Fun, Str, Res); -time_func(N,Sum,SumSq, _, _, Res) -> + time_func(N+1,Sum+Time,SumSq+Time*Time, Fun, Str, Res, Repeat); +time_func(N,Sum,SumSq, _, _, Res, _) -> Mean = round(Sum / N), Stdev = round(math:sqrt((SumSq - (Sum*Sum/N))/(N - 1))), {N, Mean, Stdev, Res}. diff --git a/lib/stdlib/test/supervisor_1.erl b/lib/stdlib/test/supervisor_1.erl index 419026749b..c3ccacc587 100644 --- a/lib/stdlib/test/supervisor_1.erl +++ b/lib/stdlib/test/supervisor_1.erl @@ -42,6 +42,8 @@ start_child(error) -> set -> gen_server:start_link(?MODULE, error, []) end; +start_child({return, Term}) -> + Term; start_child(Extra) -> {ok, Pid} = gen_server:start_link(?MODULE, normal, []), diff --git a/lib/stdlib/test/supervisor_SUITE.erl b/lib/stdlib/test/supervisor_SUITE.erl index cd2c6b0cbb..761df8eb40 100644 --- a/lib/stdlib/test/supervisor_SUITE.erl +++ b/lib/stdlib/test/supervisor_SUITE.erl @@ -39,6 +39,9 @@ sup_start_ignore_temporary_child_start_child_simple/1, sup_start_ignore_permanent_child_start_child_simple/1, sup_start_error_return/1, sup_start_fail/1, + sup_start_child_returns_error/1, + sup_start_restart_child_returns_error/1, + sup_start_child_returns_error_simple/1, sup_start_map/1, sup_start_map_simple/1, sup_start_map_faulty_specs/1, sup_stop_infinity/1, sup_stop_timeout/1, sup_stop_brutal_kill/1, @@ -65,14 +68,16 @@ simple_one_for_one_extra/1, simple_one_for_one_shutdown/1]). %% Misc tests --export([child_unlink/1, tree/1, count_children/1, +-export([child_unlink/1, tree/1, count_children/1, count_children_supervisor/1, count_restarting_children/1, get_callback_module/1, do_not_save_start_parameters_for_temporary_children/1, do_not_save_child_specs_for_temporary_children/1, simple_one_for_one_scale_many_temporary_children/1, simple_global_supervisor/1, hanging_restart_loop/1, + hanging_restart_loop_rest_for_one/1, hanging_restart_loop_simple/1, code_change/1, code_change_map/1, - code_change_simple/1, code_change_simple_map/1]). + code_change_simple/1, code_change_simple_map/1, + order_of_children/1, scale_start_stop_many_children/1]). %%------------------------------------------------------------------------- @@ -91,12 +96,15 @@ all() -> {group, normal_termination}, {group, shutdown_termination}, {group, abnormal_termination}, child_unlink, tree, - count_children, count_restarting_children, get_callback_module, + count_children, count_children_supervisor, count_restarting_children, + get_callback_module, do_not_save_start_parameters_for_temporary_children, do_not_save_child_specs_for_temporary_children, simple_one_for_one_scale_many_temporary_children, temporary_bystander, - simple_global_supervisor, hanging_restart_loop, hanging_restart_loop_simple, - code_change, code_change_map, code_change_simple, code_change_simple_map]. + simple_global_supervisor, hanging_restart_loop, + hanging_restart_loop_rest_for_one, hanging_restart_loop_simple, + code_change, code_change_map, code_change_simple, code_change_simple_map, + order_of_children, scale_start_stop_many_children]. groups() -> [{sup_start, [], @@ -105,7 +113,10 @@ groups() -> sup_start_ignore_temporary_child_start_child, sup_start_ignore_temporary_child_start_child_simple, sup_start_ignore_permanent_child_start_child_simple, - sup_start_error_return, sup_start_fail]}, + sup_start_error_return, sup_start_fail, + sup_start_child_returns_error, sup_start_restart_child_returns_error, + sup_start_child_returns_error_simple + ]}, {sup_start_map, [], [sup_start_map, sup_start_map_simple, sup_start_map_faulty_specs]}, {sup_stop, [], @@ -147,6 +158,15 @@ init_per_testcase(_Case, Config) -> Config. end_per_testcase(_Case, _Config) -> + %% Clean up to avoid unnecessary error reports in the shell + case whereis(sup_test) of + SupPid when is_pid(SupPid) -> + unlink(SupPid), + exit(SupPid,shutdown), + ok; + _ -> + error + end, ok. start_link(InitResult) -> @@ -274,6 +294,7 @@ sup_start_ignore_permanent_child_start_child_simple(Config) %% Regression test: check that the supervisor terminates without error. exit(Pid, shutdown), check_exit_reason(Pid, shutdown). + %%------------------------------------------------------------------------- %% Tests what happens if init-callback returns a invalid value. sup_start_error_return(Config) when is_list(Config) -> @@ -289,6 +310,53 @@ sup_start_fail(Config) when is_list(Config) -> check_exit_reason(Term). %%------------------------------------------------------------------------- +%% Test what happens when the start function for a child returns +%% {error,Reason} or some other term(). +sup_start_restart_child_returns_error(_Config) -> + process_flag(trap_exit, true), + Child = {child1, {supervisor_1, start_child, [error]}, + permanent, 1000, worker, []}, + {ok, _Pid} = start_link({ok, {{one_for_one, 2, 3600}, [Child]}}), + + ok = supervisor:terminate_child(sup_test, child1), + {error,{function_clause,_}} = supervisor:restart_child(sup_test,child1), + + [{child1,undefined,worker,[]}] = supervisor:which_children(sup_test), + ok. + +%%------------------------------------------------------------------------- +%% Test what happens when the start function for a child returns +%% {error,Reason} or some other term(). +sup_start_child_returns_error(_Config) -> + process_flag(trap_exit, true), + Child1 = {child1, {supervisor_1, start_child, [{return,{error,reason}}]}, + permanent, 1000, worker, []}, + Child2 = {child2, {supervisor_1, start_child, [{return,error_reason}]}, + permanent, 1000, worker, []}, + {ok, _Pid} = start_link({ok, {{one_for_one, 2, 3600}, []}}), + + {error,{reason,_}} = supervisor:start_child(sup_test,Child1), + {error,{error_reason,_}} = supervisor:start_child(sup_test,Child2), + + [] = supervisor:which_children(sup_test), + ok. + +%%------------------------------------------------------------------------- +%% Test what happens when the start function for a child returns +%% {error,Reason} - simple_one_for_one +sup_start_child_returns_error_simple(_Config) -> + process_flag(trap_exit, true), + Child = {child1, {supervisor_1, start_child, []}, + permanent, 1000, worker, []}, + {ok, _Pid} = start_link({ok, {{simple_one_for_one, 2, 3600}, [Child]}}), + + {error,reason} = supervisor:start_child(sup_test,[{return,{error,reason}}]), + {error,error_reason} = supervisor:start_child(sup_test,[{return,error_reason}]), + + [] = supervisor:which_children(sup_test), + ok. + +%%------------------------------------------------------------------------- %% Tests that the supervisor process starts correctly with map %% startspec, and that the full childspec can be read. sup_start_map(Config) when is_list(Config) -> @@ -468,7 +536,16 @@ extra_return(Config) when is_list(Config) -> [{child1, CPid3, worker, []}] = supervisor:which_children(sup_test), [1,1,0,1] = get_child_counts(sup_test), - ok. + %% Check that it can be automatically restarted + terminate(CPid3, abnormal), + [{child1, CPid4, worker, []}] = supervisor:which_children(sup_test), + [1,1,0,1] = get_child_counts(sup_test), + if (not is_pid(CPid4)) orelse CPid4=:=CPid3 -> + ct:fail({not_restarted,CPid3,CPid4}); + true -> + ok + end. + %%------------------------------------------------------------------------- %% Test API functions start_child/2, terminate_child/2, delete_child/2 %% restart_child/2, which_children/1, count_children/1. Only correct @@ -1140,7 +1217,7 @@ simple_one_for_one(Config) when is_list(Config) -> [{Id4, Pid4, _, _}|_] = supervisor:which_children(sup_test), terminate(SupPid, Pid4, Id4, abnormal), - check_exit([SupPid]). + check_exit_reason(SupPid,shutdown). %%------------------------------------------------------------------------- @@ -1378,6 +1455,11 @@ tree(Config) when is_list(Config) -> [?MODULE, {ok, {{one_for_one, 4, 3600}, []}}]}, permanent, infinity, supervisor, []}, + ChildSup3 = {supchild3, + {supervisor, start_link, + [?MODULE, {ok, {{one_for_one, 4, 3600}, []}}]}, + transient, infinity, + supervisor, []}, %% Top supervisor {ok, SupPid} = start_link({ok, {{one_for_all, 4, 3600}, []}}), @@ -1385,7 +1467,9 @@ tree(Config) when is_list(Config) -> %% Child supervisors {ok, Sup1} = supervisor:start_child(SupPid, ChildSup1), {ok, Sup2} = supervisor:start_child(SupPid, ChildSup2), - [2,2,2,0] = get_child_counts(SupPid), + {ok, _Sup3} = supervisor:start_child(SupPid, ChildSup3), + ok = supervisor:terminate_child(SupPid, supchild3), + [3,2,3,0] = get_child_counts(SupPid), %% Workers [{_, CPid2, _, _},{_, CPid1, _, _}] = @@ -1417,16 +1501,21 @@ tree(Config) when is_list(Config) -> timer:sleep(1000), - [{supchild2, NewSup2, _, _},{supchild1, NewSup1, _, _}] = + [{supchild3, NewSup3, _, _}, + {supchild2, NewSup2, _, _}, + {supchild1, NewSup1, _, _}] = supervisor:which_children(SupPid), - [2,2,2,0] = get_child_counts(SupPid), + [3,3,3,0] = get_child_counts(SupPid), [{child2, _, _, _},{child1, _, _, _}] = supervisor:which_children(NewSup1), [2,2,0,2] = get_child_counts(NewSup1), [] = supervisor:which_children(NewSup2), - [0,0,0,0] = get_child_counts(NewSup2). + [0,0,0,0] = get_child_counts(NewSup2), + + [] = supervisor:which_children(NewSup3), + [0,0,0,0] = get_child_counts(NewSup3). %%------------------------------------------------------------------------- %% Test count_children @@ -1459,6 +1548,36 @@ count_children(Config) when is_list(Config) -> [1,0,0,0] = get_child_counts(sup_test). %%------------------------------------------------------------------------- +%% Test count_children for simple_one_for_one, when children are supervisors +count_children_supervisor(Config) when is_list(Config) -> + process_flag(trap_exit, true), + Child = {child, {supervisor_1, start_child, []}, temporary, infinity, + supervisor, []}, + {ok, SupPid} = start_link({ok, {{simple_one_for_one, 2, 3600}, [Child]}}), + [supervisor:start_child(sup_test, []) || _Ignore <- lists:seq(1,1000)], + + Children = supervisor:which_children(sup_test), + ChildCount = get_child_counts(sup_test), + + [supervisor:start_child(sup_test, []) || _Ignore2 <- lists:seq(1,1000)], + + ChildCount2 = get_child_counts(sup_test), + Children2 = supervisor:which_children(sup_test), + + ChildCount3 = get_child_counts(sup_test), + Children3 = supervisor:which_children(sup_test), + + 1000 = length(Children), + [1,1000,1000,0] = ChildCount, + 2000 = length(Children2), + [1,2000,2000,0] = ChildCount2, + Children3 = Children2, + ChildCount3 = ChildCount2, + + [terminate(SupPid, Pid, child, kill) || {undefined, Pid, supervisor, _Modules} <- Children3], + [1,0,0,0] = get_child_counts(sup_test). + +%%------------------------------------------------------------------------- %% Test count_children when some children are restarting count_restarting_children(Config) when is_list(Config) -> process_flag(trap_exit, true), @@ -1577,11 +1696,11 @@ dont_save_start_parameters_for_temporary_children(simple_one_for_one = Type) -> start_children(Sup2, [LargeList], 100), start_children(Sup3, [LargeList], 100), - [{memory,Mem1}] = process_info(Sup1, [memory]), - [{memory,Mem2}] = process_info(Sup2, [memory]), - [{memory,Mem3}] = process_info(Sup3, [memory]), + Size1 = erts_debug:flat_size(sys:get_status(Sup1)), + Size2 = erts_debug:flat_size(sys:get_status(Sup2)), + Size3 = erts_debug:flat_size(sys:get_status(Sup3)), - true = (Mem3 < Mem1) and (Mem3 < Mem2), + true = (Size3 < Size1) and (Size3 < Size2), terminate(Sup1, shutdown), terminate(Sup2, shutdown), @@ -1605,11 +1724,11 @@ dont_save_start_parameters_for_temporary_children(Type) -> start_children(Sup2, Transient, 100), start_children(Sup3, Temporary, 100), - [{memory,Mem1}] = process_info(Sup1, [memory]), - [{memory,Mem2}] = process_info(Sup2, [memory]), - [{memory,Mem3}] = process_info(Sup3, [memory]), + Size1 = erts_debug:flat_size(sys:get_status(Sup1)), + Size2 = erts_debug:flat_size(sys:get_status(Sup2)), + Size3 = erts_debug:flat_size(sys:get_status(Sup3)), - true = (Mem3 < Mem1) and (Mem3 < Mem2), + true = (Size3 < Size1) and (Size3 < Size2), terminate(Sup1, shutdown), terminate(Sup2, shutdown), @@ -1847,6 +1966,61 @@ hanging_restart_loop(Config) when is_list(Config) -> undefined = whereis(sup_test), ok. +hanging_restart_loop_rest_for_one(Config) when is_list(Config) -> + process_flag(trap_exit, true), + {ok, Pid} = start_link({ok, {{rest_for_one, 8, 10}, []}}), + Child1 = {child1, {supervisor_1, start_child, []}, + permanent, brutal_kill, worker, []}, + Child2 = {child2, {supervisor_deadlock, start_child, []}, + permanent, brutal_kill, worker, []}, + Child3 = {child3, {supervisor_1, start_child, []}, + permanent, brutal_kill, worker, []}, + + %% Ets table with state read by supervisor_deadlock.erl + ets:new(supervisor_deadlock,[set,named_table,public]), + ets:insert(supervisor_deadlock,{fail_start,false}), + + {ok, CPid1} = supervisor:start_child(sup_test, Child1), + {ok, CPid2} = supervisor:start_child(sup_test, Child2), + link(CPid2), + {ok, _CPid3} = supervisor:start_child(sup_test, Child3), + + ets:insert(supervisor_deadlock,{fail_start,true}), + supervisor_deadlock:restart_child(), + timer:sleep(2000), % allow restart to happen before proceeding + + {error, already_present} = supervisor:start_child(sup_test, Child2), + {error, restarting} = supervisor:restart_child(sup_test, child2), + {error, restarting} = supervisor:delete_child(sup_test, child2), + [{child3,undefined,worker,[]}, + {child2,restarting,worker,[]}, + {child1,CPid1,worker,[]}] = supervisor:which_children(sup_test), + [3,1,0,3] = get_child_counts(sup_test), + + ok = supervisor:terminate_child(sup_test, child2), + check_exit_reason(CPid2, error), + [{child3,undefined,worker,[]}, + {child2,undefined,worker,[]}, + {child1,CPid1,worker,[]}] = supervisor:which_children(sup_test), + + ets:insert(supervisor_deadlock,{fail_start,false}), + {ok, CPid22} = supervisor:restart_child(sup_test, child2), + link(CPid22), + + ets:insert(supervisor_deadlock,{fail_start,true}), + supervisor_deadlock:restart_child(), + timer:sleep(2000), % allow restart to happen before proceeding + + %% Terminating supervisor. + %% OTP-9549 fixes so this does not give a timetrap timeout - + %% i.e. that supervisor does not hang in restart loop. + terminate(Pid,shutdown), + + %% Check that child died with reason from 'restart' request above + check_exit_reason(CPid22, error), + undefined = whereis(sup_test), + ok. + %%------------------------------------------------------------------------- %% Test that child and supervisor can be shutdown while hanging in %% restart loop, simple_one_for_one. @@ -2022,11 +2196,11 @@ code_change_simple(_Config) -> SimpleChild2 = {child2,{supervisor_1, start_child, []}, permanent, brutal_kill, worker, []}, - {error, {error, {ok,[_,_]}}} = + {error, {error, {ok,{[_,_],_}}}} = fake_upgrade(SimplePid,{ok,{SimpleFlags,[SimpleChild1,SimpleChild2]}}), %% Attempt to remove child - {error, {error, {ok,[]}}} = fake_upgrade(SimplePid,{ok,{SimpleFlags,[]}}), + {error, {error, {ok,{[],_}}}} = fake_upgrade(SimplePid,{ok,{SimpleFlags,[]}}), terminate(SimplePid,shutdown), ok. @@ -2047,11 +2221,11 @@ code_change_simple_map(_Config) -> %% Attempt to add child SimpleChild2 = #{id=>child2, start=>{supervisor_1, start_child, []}}, - {error, {error, {ok, [_,_]}}} = + {error, {error, {ok, {[_,_],_}}}} = fake_upgrade(SimplePid,{ok,{SimpleFlags,[SimpleChild1,SimpleChild2]}}), %% Attempt to remove child - {error, {error, {ok, []}}} = + {error, {error, {ok, {[],_}}}} = fake_upgrade(SimplePid,{ok,{SimpleFlags,[]}}), terminate(SimplePid,shutdown), @@ -2075,6 +2249,148 @@ fake_upgrade(Pid,NewInitReturn) -> ok = sys:resume(Pid), R. +%% Test that children are started in the order they are given, and +%% terminated in the opposite order +order_of_children(_Config) -> + process_flag(trap_exit, true), + %% Use child ids that are not alphabetically storted + Id1 = ch7, + Id2 = ch3, + Id3 = ch10, + Id4 = ch2, + Id5 = ch5, + Children = + [{Id, {supervisor_1, start_child, []}, permanent, 1000, worker, []} || + Id <- [Id1,Id2,Id3,Id4,Id5]], + + {ok, SupPid} = start_link({ok, {{rest_for_one, 2, 3600}, Children}}), + + + %% Check start order (pids are growing) + Which1 = supervisor:which_children(sup_test), + IsPid = fun({_,P,_,_}) when is_pid(P) -> true; (_) -> false end, + true = lists:all(IsPid,Which1), + SortedOnPid1 = lists:keysort(2,Which1), + [{Id1,Pid1,_,_}, + {Id2,Pid2,_,_}, + {Id3,Pid3,_,_}, + {Id4,Pid4,_,_}, + {Id5,Pid5,_,_}] = SortedOnPid1, + + TPid = self(), + TraceHandler = fun({trace,P,exit,_},{Last,Ps}) when P=:=Last -> + TPid ! {exited,lists:reverse([P|Ps])}, + {Last,Ps}; + ({trace,P,exit,_},{Last,Ps}) -> + {Last,[P|Ps]}; + (_T,Acc) -> + Acc + end, + + %% Terminate Pid3 and check that Pid4 and Pid5 are terminated in + %% expected order. + Expected1 = [Pid5,Pid4], + {ok,_} = dbg:tracer(process,{TraceHandler,{Pid4,[]}}), + [{ok,[_]} = dbg:p(P,procs) || P <- Expected1], + terminate(Pid3, abnormal), + receive {exited,ExitedPids1} -> + dbg:stop_clear(), + case ExitedPids1 of + Expected1 -> ok; + _ -> ct:fail({faulty_termination_order, + {expected,Expected1}, + {got,ExitedPids1}}) + end + after 3000 -> + dbg:stop_clear(), + ct:fail({shutdown_fail,timeout}) + end, + + %% Then check that Id3-5 are started again in correct order + Which2 = supervisor:which_children(sup_test), + true = lists:all(IsPid,Which2), + SortedOnPid2 = lists:keysort(2,Which2), + [{Id1,Pid1,_,_}, + {Id2,Pid2,_,_}, + {Id3,Pid32,_,_}, + {Id4,Pid42,_,_}, + {Id5,Pid52,_,_}] = SortedOnPid2, + + %% Terminate supervisor and check that all children are terminated + %% in opposite start order + Expected2 = [Pid52,Pid42,Pid32,Pid2,Pid1], + {ok,_} = dbg:tracer(process,{TraceHandler,{Pid1,[]}}), + [{ok,[_]} = dbg:p(P,procs) || P <- Expected2], + exit(SupPid,shutdown), + receive {exited,ExitedPids2} -> + dbg:stop_clear(), + case ExitedPids2 of + Expected2 -> ok; + _ -> ct:fail({faulty_termination_order, + {expected,Expected2}, + {got,ExitedPids2}}) + end + after 3000 -> + dbg:stop_clear(), + ct:fail({shutdown_fail,timeout}) + end, + ok. + +%% Test that a non-simple supervisor scales well for starting and +%% stopping many children. +scale_start_stop_many_children(_Config) -> + process_flag(trap_exit, true), + {ok, _Pid} = start_link({ok, {{one_for_one, 2, 3600}, []}}), + N1 = 1000, + N2 = 100000, + Ids1 = lists:seq(1,N1), + Ids2 = lists:seq(1,N2), + Children1 = [{Id,{supervisor_1,start_child,[]},permanent,1000,worker,[]} || + Id <- Ids1], + Children2 = [{Id,{supervisor_1,start_child,[]},permanent,1000,worker,[]} || + Id <- Ids2], + + {StartT1,_} = + timer:tc(fun() -> + [supervisor:start_child(sup_test,C) || C <- Children1] + end), + {StopT1,_} = + timer:tc(fun() -> + [supervisor:terminate_child(sup_test,I) || I <- Ids1] + end), + ct:log("~w children, start time: ~w ms, stop time: ~w ms", + [N1, StartT1 div 1000, StopT1 div 1000]), + + {StartT2,_} = + timer:tc(fun() -> + [supervisor:start_child(sup_test,C) || C <- Children2] + end), + {StopT2,_} = + timer:tc(fun() -> + [supervisor:terminate_child(sup_test,I) || I <- Ids2] + end), + ct:log("~w children, start time: ~w ms, stop time: ~w ms", + [N2, StartT2 div 1000, StopT2 div 1000]), + + %% Scaling should be more or less linear, but allowing a bit more + %% to avoid false alarms + ScaleLimit = (N2 div N1) * 10, + StartScale = StartT2 div StartT1, + StopScale = StopT2 div StopT1, + + ct:log("Scale limit: ~w~nStart scale: ~w~nStop scale: ~w", + [ScaleLimit, StartScale, StopScale]), + + if StartScale > ScaleLimit -> + ct:fail({bad_start_scale,StartScale}); + StopScale > ScaleLimit -> + ct:fail({bad_stop_scale,StopScale}); + true -> + ok + end, + + ok. + %%------------------------------------------------------------------------- terminate(Pid, Reason) when Reason =/= supervisor -> terminate(dummy, Pid, dummy, Reason). diff --git a/lib/stdlib/test/supervisor_deadlock.erl b/lib/stdlib/test/supervisor_deadlock.erl index 8d3d1c6f30..f51aecccb2 100644 --- a/lib/stdlib/test/supervisor_deadlock.erl +++ b/lib/stdlib/test/supervisor_deadlock.erl @@ -1,5 +1,5 @@ -module(supervisor_deadlock). --compile(export_all). +-compile([export_all,nowarn_export_all]). %%%----------------------------------------------------------------- diff --git a/lib/stdlib/test/tar_SUITE.erl b/lib/stdlib/test/tar_SUITE.erl index 4061008812..32a33283d1 100644 --- a/lib/stdlib/test/tar_SUITE.erl +++ b/lib/stdlib/test/tar_SUITE.erl @@ -28,7 +28,7 @@ extract_from_open_file/1, symlinks/1, open_add_close/1, cooked_compressed/1, memory/1,unicode/1,read_other_implementations/1, sparse/1, init/1, leading_slash/1, dotdot/1, - roundtrip_metadata/1]). + roundtrip_metadata/1, apply_file_info_opts/1]). -include_lib("common_test/include/ct.hrl"). -include_lib("kernel/include/file.hrl"). @@ -42,7 +42,8 @@ all() -> extract_filtered, symlinks, open_add_close, cooked_compressed, memory, unicode, read_other_implementations, - sparse,init,leading_slash,dotdot,roundtrip_metadata]. + sparse,init,leading_slash,dotdot,roundtrip_metadata, + apply_file_info_opts]. groups() -> []. @@ -989,6 +990,31 @@ do_roundtrip_metadata(Dir, File) -> ok end. +apply_file_info_opts(Config) when is_list(Config) -> + ok = file:set_cwd(proplists:get_value(priv_dir, Config)), + + ok = file:make_dir("empty_directory"), + ok = file:write_file("file", "contents"), + + Opts = [{atime, 0}, {mtime, 0}, {ctime, 0}, {uid, 0}, {gid, 0}], + TarFile = "reproducible.tar", + {ok, Tar} = erl_tar:open(TarFile, [write]), + ok = erl_tar:add(Tar, "file", Opts), + ok = erl_tar:add(Tar, "empty_directory", Opts), + ok = erl_tar:add(Tar, <<"contents">>, "memory_file", Opts), + erl_tar:close(Tar), + + ok = file:make_dir("extracted"), + erl_tar:extract(TarFile, [{cwd, "extracted"}]), + + {ok, #file_info{mtime=0}} = + file:read_file_info("extracted/empty_directory", [{time, posix}]), + {ok, #file_info{mtime=0}} = + file:read_file_info("extracted/file", [{time, posix}]), + {ok, #file_info{mtime=0}} = + file:read_file_info("extracted/memory_file", [{time, posix}]), + + ok. %% Delete the given list of files. delete_files([]) -> ok; diff --git a/lib/stdlib/test/unicode_util_SUITE.erl b/lib/stdlib/test/unicode_util_SUITE.erl index a89627eba5..40b1c260a5 100644 --- a/lib/stdlib/test/unicode_util_SUITE.erl +++ b/lib/stdlib/test/unicode_util_SUITE.erl @@ -29,7 +29,9 @@ get/1, count/1]). --export([debug/0, id/1, bin_split/1, uc_loaded_size/0]). +-export([debug/0, id/1, bin_split/1, uc_loaded_size/0, + time_count/4 %% Used by stdlib_bench_SUITE + ]). suite() -> [{ct_hooks,[ts_install_cth]}, @@ -134,10 +136,10 @@ verify_gc(Line0, N, Acc) -> io:format("Expected: ~p~n", [Res]), io:format("Got: ~w~n", [Other]), Acc+1; - Cl:R -> + Cl:R:Stacktrace -> io:format("~p: ~ts => |~tp|~n",[N, Line, Str]), io:format("Expected: ~p~n", [Res]), - erlang:raise(Cl,R,erlang:get_stacktrace()) + erlang:raise(Cl,R,Stacktrace) end. gc_test_data([[247]|Rest], Str, [First|GCs]) -> @@ -173,29 +175,29 @@ verify_nfd(Data0, LineNo, _Acc) -> C3GC = fetch(C1, fun unicode_util:nfd/1), C3GC = fetch(C2, fun unicode_util:nfd/1), C3GC = fetch(C3, fun unicode_util:nfd/1) - catch _Cl:{badmatch, Other} = _R-> + catch _Cl:{badmatch, Other} = _R: Stacktrace -> io:format("Failed: ~p~nInput: ~ts~n\t=> ~w |~ts|~n",[LineNo, Data1, C1, C1]), io:format("Expected: ~ts ~w~n", [C3GC, C3GC]), io:format("Got: ~ts ~w~n", [Other, Other]), - erlang:raise(_Cl,_R,erlang:get_stacktrace()); - Cl:R -> + erlang:raise(_Cl,_R,Stacktrace); + Cl:R:Stacktrace -> io:format("~p: ~ts => |~tp|~n",[LineNo, Data1, C1]), io:format("Expected: ~p~n", [C3]), - erlang:raise(Cl,R,erlang:get_stacktrace()) + erlang:raise(Cl,R,Stacktrace) end, C5GC = fetch(C5, fun unicode_util:gc/1), try C5GC = fetch(C4, fun unicode_util:nfd/1), C5GC = fetch(C5, fun unicode_util:nfd/1) - catch _Cl2:{badmatch, Other2} = _R2-> + catch _Cl2:{badmatch, Other2} = _R2:Stacktrace2 -> io:format("Failed: ~p~nInput: ~ts~n\t=> ~w |~ts|~n",[LineNo, Data1, C1, C1]), io:format("Expected: ~ts ~w~n", [C5GC, C5GC]), io:format("Got: ~ts ~w~n", [Other2, Other2]), - erlang:raise(_Cl2,_R2,erlang:get_stacktrace()); - Cl2:R2 -> + erlang:raise(_Cl2,_R2,Stacktrace2); + Cl2:R2:Stacktrace2 -> io:format("~p: ~ts => |~tp|~n",[LineNo, Data1, C1]), io:format("Expected: ~p~n", [C5]), - erlang:raise(Cl2,R2,erlang:get_stacktrace()) + erlang:raise(Cl2,R2,Stacktrace2) end, ok. @@ -216,29 +218,29 @@ verify_nfc(Data0, LineNo, _Acc) -> C2GC = fetch(C1, fun unicode_util:nfc/1), C2GC = fetch(C2, fun unicode_util:nfc/1), C2GC = fetch(C3, fun unicode_util:nfc/1) - catch _Cl:{badmatch, Other} = _R-> + catch _Cl:{badmatch, Other} = _R:Stacktrace -> io:format("Failed: ~p~nInput: ~ts~n\t=> ~w |~ts|~n",[LineNo, Data1, C1, C1]), io:format("Expected: ~ts ~w~n", [C2GC, C2GC]), io:format("Got: ~ts ~w~n", [Other, Other]), - erlang:raise(_Cl,_R,erlang:get_stacktrace()); - Cl:R -> + erlang:raise(_Cl,_R,Stacktrace); + Cl:R:Stacktrace -> io:format("~p: ~ts => |~tp|~n",[LineNo, Data1, C1]), io:format("Expected: ~p~n", [C3]), - erlang:raise(Cl,R,erlang:get_stacktrace()) + erlang:raise(Cl,R,Stacktrace) end, C4GC = fetch(C4, fun unicode_util:gc/1), try C4GC = fetch(C4, fun unicode_util:nfc/1), C4GC = fetch(C5, fun unicode_util:nfc/1) - catch _Cl2:{badmatch, Other2} = _R2-> + catch _Cl2:{badmatch, Other2} = _R2:Stacktrace2 -> io:format("Failed: ~p~nInput: ~ts~n\t=> ~w |~ts|~n",[LineNo, Data1, C1, C1]), io:format("Expected: ~ts ~w~n", [C4GC, C4GC]), io:format("Got: ~ts ~w~n", [Other2, Other2]), - erlang:raise(_Cl2,_R2,erlang:get_stacktrace()); - Cl2:R2 -> + erlang:raise(_Cl2,_R2,Stacktrace2); + Cl2:R2:Stacktrace2 -> io:format("~p: ~ts => |~tp|~n",[LineNo, Data1, C1]), io:format("Expected: ~p~n", [C5]), - erlang:raise(Cl2,R2,erlang:get_stacktrace()) + erlang:raise(Cl2,R2,Stacktrace2) end, ok. @@ -261,15 +263,15 @@ verify_nfkd(Data0, LineNo, _Acc) -> C5GC = lists:flatten(fetch(C3, fun unicode_util:nfkd/1)), C5GC = lists:flatten(fetch(C4, fun unicode_util:nfkd/1)), C5GC = lists:flatten(fetch(C5, fun unicode_util:nfkd/1)) - catch _Cl:{badmatch, Other} = _R-> + catch _Cl:{badmatch, Other} = _R:Stacktrace -> io:format("Failed: ~p~nInput: ~ts~n\t=> ~w |~ts|~n",[LineNo, Data1, C5, C5]), io:format("Expected: ~ts ~w~n", [C5GC, C5GC]), io:format("Got: ~ts ~w~n", [Other, Other]), - erlang:raise(_Cl,_R,erlang:get_stacktrace()); - Cl:R -> + erlang:raise(_Cl,_R,Stacktrace); + Cl:R:Stacktrace -> io:format("~p: ~ts => |~tp|~n",[LineNo, Data1, C1]), io:format("Expected: ~p~n", [C3]), - erlang:raise(Cl,R,erlang:get_stacktrace()) + erlang:raise(Cl,R,Stacktrace) end, ok. @@ -294,15 +296,15 @@ verify_nfkc(Data0, LineNo, _Acc) -> C4GC = lists:flatten(fetch(C4, fun unicode_util:nfkc/1)), C4GC = lists:flatten(fetch(C5, fun unicode_util:nfkc/1)) - catch _Cl:{badmatch, Other} = _R-> + catch _Cl:{badmatch, Other} = _R:Stacktrace -> io:format("Failed: ~p~nInput: ~ts~n\t=> ~w |~ts|~n",[LineNo, Data1, C4, C4]), io:format("Expected: ~ts ~w~n", [C4GC, C4GC]), io:format("Got: ~ts ~w~n", [Other, Other]), - erlang:raise(_Cl,_R,erlang:get_stacktrace()); - Cl:R -> + erlang:raise(_Cl,_R,Stacktrace); + Cl:R:Stacktrace -> io:format("~p: ~ts => |~tp|~n",[LineNo, Data1, C1]), io:format("Expected: ~p~n", [C3]), - erlang:raise(Cl,R,erlang:get_stacktrace()) + erlang:raise(Cl,R,Stacktrace) end, ok. @@ -334,7 +336,7 @@ do_measure(Config) -> File = DataDir ++ "/NormalizationTest.txt", {ok, Bin} = file:read_file(File), Do = fun(Func, Mode) -> - {N, Mean, Stddev, Res} = time_count(Func, Mode, Bin), + {N, Mean, Stddev, Res} = time_count(Func, Mode, Bin, 10), io:format("~4w ~6w ~.10w ~.6wms ±~.2wms #~.2w~n", [Func, Mode, Res, Mean div 1000, Stddev div 1000, N]) end, @@ -356,19 +358,19 @@ uc_loaded_size([_|Rest]) -> %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -time_count(Fun, Mode, Bin) -> +time_count(Fun, Mode, Bin, Repeat) -> timer:sleep(100), %% Let emulator catch up and clean things before test runs Self = self(), Pid = spawn_link(fun() -> Str = mode(Mode, Bin), - Self ! {self(),do_count(0,0,0, Fun, Str, undefined)} + Self ! {self(),do_count(0,0,0, Fun, Str, undefined, Repeat)} end), receive {Pid,Msg} -> Msg end. -do_count(N,Sum,SumSq, Fun, Str, _) when N < 10 -> +do_count(N,Sum,SumSq, Fun, Str, _, Repeat) when N < Repeat -> {Time, Res} = do_count(Fun, Str), - do_count(N+1,Sum+Time,SumSq+Time*Time, Fun, Str, Res); -do_count(N,Sum,SumSq, _, _, Res) -> + do_count(N+1,Sum+Time,SumSq+Time*Time, Fun, Str, Res, Repeat); +do_count(N,Sum,SumSq, _, _, Res, _) -> Mean = round(Sum / N), Stdev = round(math:sqrt((SumSq - (Sum*Sum/N))/(N - 1))), {N, Mean, Stdev, Res}. diff --git a/lib/stdlib/test/unicode_util_SUITE_data/GraphemeBreakTest.txt b/lib/stdlib/test/unicode_util_SUITE_data/GraphemeBreakTest.txt index 4bb4b1369b..d7d8f90de0 100644 --- a/lib/stdlib/test/unicode_util_SUITE_data/GraphemeBreakTest.txt +++ b/lib/stdlib/test/unicode_util_SUITE_data/GraphemeBreakTest.txt @@ -1,23 +1,24 @@ -# GraphemeBreakTest-9.0.0.txt -# Date: 2016-06-02, 18:28:17 GMT -# © 2016 Unicode®, Inc. +# GraphemeBreakTest-10.0.0.txt +# Date: 2017-04-14, 05:40:29 GMT +# © 2017 Unicode®, Inc. # Unicode and the Unicode Logo are registered trademarks of Unicode, Inc. in the U.S. and other countries. # For terms of use, see http://www.unicode.org/terms_of_use.html # # Unicode Character Database # For documentation, see http://www.unicode.org/reports/tr44/ # -# Default Grapheme Break Test +# Default Grapheme_Cluster_Break Test # # Format: -# <string> (# <comment>)? -# <string> contains hex Unicode code points, with -# ÷ wherever there is a break opportunity, and +# <string> (# <comment>)? +# <string> contains hex Unicode code points, with +# ÷ wherever there is a break opportunity, and # × wherever there is not. # <comment> the format can change, but currently it shows: # - the sample character name # - (x) the Grapheme_Cluster_Break property value for the sample character -# - [x] the rule that determines whether there is a break or not +# - [x] the rule that determines whether there is a break or not, +# as listed in the Rules section of GraphemeBreakTest.html # # These samples may be extended or changed in the future. # @@ -53,8 +54,8 @@ ÷ 0020 × 0308 ÷ 1F3FB ÷ # ÷ [0.2] SPACE (Other) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] EMOJI MODIFIER FITZPATRICK TYPE-1-2 (E_Modifier) ÷ [0.3] ÷ 0020 × 200D ÷ # ÷ [0.2] SPACE (Other) × [9.0] ZERO WIDTH JOINER (ZWJ) ÷ [0.3] ÷ 0020 × 0308 × 200D ÷ # ÷ [0.2] SPACE (Other) × [9.0] COMBINING DIAERESIS (Extend) × [9.0] ZERO WIDTH JOINER (ZWJ) ÷ [0.3] -÷ 0020 ÷ 2764 ÷ # ÷ [0.2] SPACE (Other) ÷ [999.0] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [0.3] -÷ 0020 × 0308 ÷ 2764 ÷ # ÷ [0.2] SPACE (Other) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [0.3] +÷ 0020 ÷ 2640 ÷ # ÷ [0.2] SPACE (Other) ÷ [999.0] FEMALE SIGN (Glue_After_Zwj) ÷ [0.3] +÷ 0020 × 0308 ÷ 2640 ÷ # ÷ [0.2] SPACE (Other) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] FEMALE SIGN (Glue_After_Zwj) ÷ [0.3] ÷ 0020 ÷ 1F466 ÷ # ÷ [0.2] SPACE (Other) ÷ [999.0] BOY (EBG) ÷ [0.3] ÷ 0020 × 0308 ÷ 1F466 ÷ # ÷ [0.2] SPACE (Other) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] BOY (EBG) ÷ [0.3] ÷ 0020 ÷ 0378 ÷ # ÷ [0.2] SPACE (Other) ÷ [999.0] <reserved-0378> (Other) ÷ [0.3] @@ -93,8 +94,8 @@ ÷ 000D ÷ 0308 ÷ 1F3FB ÷ # ÷ [0.2] <CARRIAGE RETURN (CR)> (CR) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [999.0] EMOJI MODIFIER FITZPATRICK TYPE-1-2 (E_Modifier) ÷ [0.3] ÷ 000D ÷ 200D ÷ # ÷ [0.2] <CARRIAGE RETURN (CR)> (CR) ÷ [4.0] ZERO WIDTH JOINER (ZWJ) ÷ [0.3] ÷ 000D ÷ 0308 × 200D ÷ # ÷ [0.2] <CARRIAGE RETURN (CR)> (CR) ÷ [4.0] COMBINING DIAERESIS (Extend) × [9.0] ZERO WIDTH JOINER (ZWJ) ÷ [0.3] -÷ 000D ÷ 2764 ÷ # ÷ [0.2] <CARRIAGE RETURN (CR)> (CR) ÷ [4.0] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [0.3] -÷ 000D ÷ 0308 ÷ 2764 ÷ # ÷ [0.2] <CARRIAGE RETURN (CR)> (CR) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [0.3] +÷ 000D ÷ 2640 ÷ # ÷ [0.2] <CARRIAGE RETURN (CR)> (CR) ÷ [4.0] FEMALE SIGN (Glue_After_Zwj) ÷ [0.3] +÷ 000D ÷ 0308 ÷ 2640 ÷ # ÷ [0.2] <CARRIAGE RETURN (CR)> (CR) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [999.0] FEMALE SIGN (Glue_After_Zwj) ÷ [0.3] ÷ 000D ÷ 1F466 ÷ # ÷ [0.2] <CARRIAGE RETURN (CR)> (CR) ÷ [4.0] BOY (EBG) ÷ [0.3] ÷ 000D ÷ 0308 ÷ 1F466 ÷ # ÷ [0.2] <CARRIAGE RETURN (CR)> (CR) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [999.0] BOY (EBG) ÷ [0.3] ÷ 000D ÷ 0378 ÷ # ÷ [0.2] <CARRIAGE RETURN (CR)> (CR) ÷ [4.0] <reserved-0378> (Other) ÷ [0.3] @@ -133,8 +134,8 @@ ÷ 000A ÷ 0308 ÷ 1F3FB ÷ # ÷ [0.2] <LINE FEED (LF)> (LF) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [999.0] EMOJI MODIFIER FITZPATRICK TYPE-1-2 (E_Modifier) ÷ [0.3] ÷ 000A ÷ 200D ÷ # ÷ [0.2] <LINE FEED (LF)> (LF) ÷ [4.0] ZERO WIDTH JOINER (ZWJ) ÷ [0.3] ÷ 000A ÷ 0308 × 200D ÷ # ÷ [0.2] <LINE FEED (LF)> (LF) ÷ [4.0] COMBINING DIAERESIS (Extend) × [9.0] ZERO WIDTH JOINER (ZWJ) ÷ [0.3] -÷ 000A ÷ 2764 ÷ # ÷ [0.2] <LINE FEED (LF)> (LF) ÷ [4.0] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [0.3] -÷ 000A ÷ 0308 ÷ 2764 ÷ # ÷ [0.2] <LINE FEED (LF)> (LF) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [0.3] +÷ 000A ÷ 2640 ÷ # ÷ [0.2] <LINE FEED (LF)> (LF) ÷ [4.0] FEMALE SIGN (Glue_After_Zwj) ÷ [0.3] +÷ 000A ÷ 0308 ÷ 2640 ÷ # ÷ [0.2] <LINE FEED (LF)> (LF) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [999.0] FEMALE SIGN (Glue_After_Zwj) ÷ [0.3] ÷ 000A ÷ 1F466 ÷ # ÷ [0.2] <LINE FEED (LF)> (LF) ÷ [4.0] BOY (EBG) ÷ [0.3] ÷ 000A ÷ 0308 ÷ 1F466 ÷ # ÷ [0.2] <LINE FEED (LF)> (LF) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [999.0] BOY (EBG) ÷ [0.3] ÷ 000A ÷ 0378 ÷ # ÷ [0.2] <LINE FEED (LF)> (LF) ÷ [4.0] <reserved-0378> (Other) ÷ [0.3] @@ -173,8 +174,8 @@ ÷ 0001 ÷ 0308 ÷ 1F3FB ÷ # ÷ [0.2] <START OF HEADING> (Control) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [999.0] EMOJI MODIFIER FITZPATRICK TYPE-1-2 (E_Modifier) ÷ [0.3] ÷ 0001 ÷ 200D ÷ # ÷ [0.2] <START OF HEADING> (Control) ÷ [4.0] ZERO WIDTH JOINER (ZWJ) ÷ [0.3] ÷ 0001 ÷ 0308 × 200D ÷ # ÷ [0.2] <START OF HEADING> (Control) ÷ [4.0] COMBINING DIAERESIS (Extend) × [9.0] ZERO WIDTH JOINER (ZWJ) ÷ [0.3] -÷ 0001 ÷ 2764 ÷ # ÷ [0.2] <START OF HEADING> (Control) ÷ [4.0] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [0.3] -÷ 0001 ÷ 0308 ÷ 2764 ÷ # ÷ [0.2] <START OF HEADING> (Control) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [0.3] +÷ 0001 ÷ 2640 ÷ # ÷ [0.2] <START OF HEADING> (Control) ÷ [4.0] FEMALE SIGN (Glue_After_Zwj) ÷ [0.3] +÷ 0001 ÷ 0308 ÷ 2640 ÷ # ÷ [0.2] <START OF HEADING> (Control) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [999.0] FEMALE SIGN (Glue_After_Zwj) ÷ [0.3] ÷ 0001 ÷ 1F466 ÷ # ÷ [0.2] <START OF HEADING> (Control) ÷ [4.0] BOY (EBG) ÷ [0.3] ÷ 0001 ÷ 0308 ÷ 1F466 ÷ # ÷ [0.2] <START OF HEADING> (Control) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [999.0] BOY (EBG) ÷ [0.3] ÷ 0001 ÷ 0378 ÷ # ÷ [0.2] <START OF HEADING> (Control) ÷ [4.0] <reserved-0378> (Other) ÷ [0.3] @@ -213,8 +214,8 @@ ÷ 0300 × 0308 ÷ 1F3FB ÷ # ÷ [0.2] COMBINING GRAVE ACCENT (Extend) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] EMOJI MODIFIER FITZPATRICK TYPE-1-2 (E_Modifier) ÷ [0.3] ÷ 0300 × 200D ÷ # ÷ [0.2] COMBINING GRAVE ACCENT (Extend) × [9.0] ZERO WIDTH JOINER (ZWJ) ÷ [0.3] ÷ 0300 × 0308 × 200D ÷ # ÷ [0.2] COMBINING GRAVE ACCENT (Extend) × [9.0] COMBINING DIAERESIS (Extend) × [9.0] ZERO WIDTH JOINER (ZWJ) ÷ [0.3] -÷ 0300 ÷ 2764 ÷ # ÷ [0.2] COMBINING GRAVE ACCENT (Extend) ÷ [999.0] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [0.3] -÷ 0300 × 0308 ÷ 2764 ÷ # ÷ [0.2] COMBINING GRAVE ACCENT (Extend) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [0.3] +÷ 0300 ÷ 2640 ÷ # ÷ [0.2] COMBINING GRAVE ACCENT (Extend) ÷ [999.0] FEMALE SIGN (Glue_After_Zwj) ÷ [0.3] +÷ 0300 × 0308 ÷ 2640 ÷ # ÷ [0.2] COMBINING GRAVE ACCENT (Extend) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] FEMALE SIGN (Glue_After_Zwj) ÷ [0.3] ÷ 0300 ÷ 1F466 ÷ # ÷ [0.2] COMBINING GRAVE ACCENT (Extend) ÷ [999.0] BOY (EBG) ÷ [0.3] ÷ 0300 × 0308 ÷ 1F466 ÷ # ÷ [0.2] COMBINING GRAVE ACCENT (Extend) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] BOY (EBG) ÷ [0.3] ÷ 0300 ÷ 0378 ÷ # ÷ [0.2] COMBINING GRAVE ACCENT (Extend) ÷ [999.0] <reserved-0378> (Other) ÷ [0.3] @@ -253,8 +254,8 @@ ÷ 0600 × 0308 ÷ 1F3FB ÷ # ÷ [0.2] ARABIC NUMBER SIGN (Prepend) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] EMOJI MODIFIER FITZPATRICK TYPE-1-2 (E_Modifier) ÷ [0.3] ÷ 0600 × 200D ÷ # ÷ [0.2] ARABIC NUMBER SIGN (Prepend) × [9.0] ZERO WIDTH JOINER (ZWJ) ÷ [0.3] ÷ 0600 × 0308 × 200D ÷ # ÷ [0.2] ARABIC NUMBER SIGN (Prepend) × [9.0] COMBINING DIAERESIS (Extend) × [9.0] ZERO WIDTH JOINER (ZWJ) ÷ [0.3] -÷ 0600 × 2764 ÷ # ÷ [0.2] ARABIC NUMBER SIGN (Prepend) × [9.2] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [0.3] -÷ 0600 × 0308 ÷ 2764 ÷ # ÷ [0.2] ARABIC NUMBER SIGN (Prepend) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [0.3] +÷ 0600 × 2640 ÷ # ÷ [0.2] ARABIC NUMBER SIGN (Prepend) × [9.2] FEMALE SIGN (Glue_After_Zwj) ÷ [0.3] +÷ 0600 × 0308 ÷ 2640 ÷ # ÷ [0.2] ARABIC NUMBER SIGN (Prepend) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] FEMALE SIGN (Glue_After_Zwj) ÷ [0.3] ÷ 0600 × 1F466 ÷ # ÷ [0.2] ARABIC NUMBER SIGN (Prepend) × [9.2] BOY (EBG) ÷ [0.3] ÷ 0600 × 0308 ÷ 1F466 ÷ # ÷ [0.2] ARABIC NUMBER SIGN (Prepend) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] BOY (EBG) ÷ [0.3] ÷ 0600 × 0378 ÷ # ÷ [0.2] ARABIC NUMBER SIGN (Prepend) × [9.2] <reserved-0378> (Other) ÷ [0.3] @@ -293,8 +294,8 @@ ÷ 0903 × 0308 ÷ 1F3FB ÷ # ÷ [0.2] DEVANAGARI SIGN VISARGA (SpacingMark) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] EMOJI MODIFIER FITZPATRICK TYPE-1-2 (E_Modifier) ÷ [0.3] ÷ 0903 × 200D ÷ # ÷ [0.2] DEVANAGARI SIGN VISARGA (SpacingMark) × [9.0] ZERO WIDTH JOINER (ZWJ) ÷ [0.3] ÷ 0903 × 0308 × 200D ÷ # ÷ [0.2] DEVANAGARI SIGN VISARGA (SpacingMark) × [9.0] COMBINING DIAERESIS (Extend) × [9.0] ZERO WIDTH JOINER (ZWJ) ÷ [0.3] -÷ 0903 ÷ 2764 ÷ # ÷ [0.2] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [999.0] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [0.3] -÷ 0903 × 0308 ÷ 2764 ÷ # ÷ [0.2] DEVANAGARI SIGN VISARGA (SpacingMark) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [0.3] +÷ 0903 ÷ 2640 ÷ # ÷ [0.2] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [999.0] FEMALE SIGN (Glue_After_Zwj) ÷ [0.3] +÷ 0903 × 0308 ÷ 2640 ÷ # ÷ [0.2] DEVANAGARI SIGN VISARGA (SpacingMark) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] FEMALE SIGN (Glue_After_Zwj) ÷ [0.3] ÷ 0903 ÷ 1F466 ÷ # ÷ [0.2] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [999.0] BOY (EBG) ÷ [0.3] ÷ 0903 × 0308 ÷ 1F466 ÷ # ÷ [0.2] DEVANAGARI SIGN VISARGA (SpacingMark) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] BOY (EBG) ÷ [0.3] ÷ 0903 ÷ 0378 ÷ # ÷ [0.2] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [999.0] <reserved-0378> (Other) ÷ [0.3] @@ -333,8 +334,8 @@ ÷ 1100 × 0308 ÷ 1F3FB ÷ # ÷ [0.2] HANGUL CHOSEONG KIYEOK (L) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] EMOJI MODIFIER FITZPATRICK TYPE-1-2 (E_Modifier) ÷ [0.3] ÷ 1100 × 200D ÷ # ÷ [0.2] HANGUL CHOSEONG KIYEOK (L) × [9.0] ZERO WIDTH JOINER (ZWJ) ÷ [0.3] ÷ 1100 × 0308 × 200D ÷ # ÷ [0.2] HANGUL CHOSEONG KIYEOK (L) × [9.0] COMBINING DIAERESIS (Extend) × [9.0] ZERO WIDTH JOINER (ZWJ) ÷ [0.3] -÷ 1100 ÷ 2764 ÷ # ÷ [0.2] HANGUL CHOSEONG KIYEOK (L) ÷ [999.0] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [0.3] -÷ 1100 × 0308 ÷ 2764 ÷ # ÷ [0.2] HANGUL CHOSEONG KIYEOK (L) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [0.3] +÷ 1100 ÷ 2640 ÷ # ÷ [0.2] HANGUL CHOSEONG KIYEOK (L) ÷ [999.0] FEMALE SIGN (Glue_After_Zwj) ÷ [0.3] +÷ 1100 × 0308 ÷ 2640 ÷ # ÷ [0.2] HANGUL CHOSEONG KIYEOK (L) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] FEMALE SIGN (Glue_After_Zwj) ÷ [0.3] ÷ 1100 ÷ 1F466 ÷ # ÷ [0.2] HANGUL CHOSEONG KIYEOK (L) ÷ [999.0] BOY (EBG) ÷ [0.3] ÷ 1100 × 0308 ÷ 1F466 ÷ # ÷ [0.2] HANGUL CHOSEONG KIYEOK (L) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] BOY (EBG) ÷ [0.3] ÷ 1100 ÷ 0378 ÷ # ÷ [0.2] HANGUL CHOSEONG KIYEOK (L) ÷ [999.0] <reserved-0378> (Other) ÷ [0.3] @@ -373,8 +374,8 @@ ÷ 1160 × 0308 ÷ 1F3FB ÷ # ÷ [0.2] HANGUL JUNGSEONG FILLER (V) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] EMOJI MODIFIER FITZPATRICK TYPE-1-2 (E_Modifier) ÷ [0.3] ÷ 1160 × 200D ÷ # ÷ [0.2] HANGUL JUNGSEONG FILLER (V) × [9.0] ZERO WIDTH JOINER (ZWJ) ÷ [0.3] ÷ 1160 × 0308 × 200D ÷ # ÷ [0.2] HANGUL JUNGSEONG FILLER (V) × [9.0] COMBINING DIAERESIS (Extend) × [9.0] ZERO WIDTH JOINER (ZWJ) ÷ [0.3] -÷ 1160 ÷ 2764 ÷ # ÷ [0.2] HANGUL JUNGSEONG FILLER (V) ÷ [999.0] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [0.3] -÷ 1160 × 0308 ÷ 2764 ÷ # ÷ [0.2] HANGUL JUNGSEONG FILLER (V) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [0.3] +÷ 1160 ÷ 2640 ÷ # ÷ [0.2] HANGUL JUNGSEONG FILLER (V) ÷ [999.0] FEMALE SIGN (Glue_After_Zwj) ÷ [0.3] +÷ 1160 × 0308 ÷ 2640 ÷ # ÷ [0.2] HANGUL JUNGSEONG FILLER (V) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] FEMALE SIGN (Glue_After_Zwj) ÷ [0.3] ÷ 1160 ÷ 1F466 ÷ # ÷ [0.2] HANGUL JUNGSEONG FILLER (V) ÷ [999.0] BOY (EBG) ÷ [0.3] ÷ 1160 × 0308 ÷ 1F466 ÷ # ÷ [0.2] HANGUL JUNGSEONG FILLER (V) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] BOY (EBG) ÷ [0.3] ÷ 1160 ÷ 0378 ÷ # ÷ [0.2] HANGUL JUNGSEONG FILLER (V) ÷ [999.0] <reserved-0378> (Other) ÷ [0.3] @@ -413,8 +414,8 @@ ÷ 11A8 × 0308 ÷ 1F3FB ÷ # ÷ [0.2] HANGUL JONGSEONG KIYEOK (T) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] EMOJI MODIFIER FITZPATRICK TYPE-1-2 (E_Modifier) ÷ [0.3] ÷ 11A8 × 200D ÷ # ÷ [0.2] HANGUL JONGSEONG KIYEOK (T) × [9.0] ZERO WIDTH JOINER (ZWJ) ÷ [0.3] ÷ 11A8 × 0308 × 200D ÷ # ÷ [0.2] HANGUL JONGSEONG KIYEOK (T) × [9.0] COMBINING DIAERESIS (Extend) × [9.0] ZERO WIDTH JOINER (ZWJ) ÷ [0.3] -÷ 11A8 ÷ 2764 ÷ # ÷ [0.2] HANGUL JONGSEONG KIYEOK (T) ÷ [999.0] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [0.3] -÷ 11A8 × 0308 ÷ 2764 ÷ # ÷ [0.2] HANGUL JONGSEONG KIYEOK (T) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [0.3] +÷ 11A8 ÷ 2640 ÷ # ÷ [0.2] HANGUL JONGSEONG KIYEOK (T) ÷ [999.0] FEMALE SIGN (Glue_After_Zwj) ÷ [0.3] +÷ 11A8 × 0308 ÷ 2640 ÷ # ÷ [0.2] HANGUL JONGSEONG KIYEOK (T) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] FEMALE SIGN (Glue_After_Zwj) ÷ [0.3] ÷ 11A8 ÷ 1F466 ÷ # ÷ [0.2] HANGUL JONGSEONG KIYEOK (T) ÷ [999.0] BOY (EBG) ÷ [0.3] ÷ 11A8 × 0308 ÷ 1F466 ÷ # ÷ [0.2] HANGUL JONGSEONG KIYEOK (T) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] BOY (EBG) ÷ [0.3] ÷ 11A8 ÷ 0378 ÷ # ÷ [0.2] HANGUL JONGSEONG KIYEOK (T) ÷ [999.0] <reserved-0378> (Other) ÷ [0.3] @@ -453,8 +454,8 @@ ÷ AC00 × 0308 ÷ 1F3FB ÷ # ÷ [0.2] HANGUL SYLLABLE GA (LV) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] EMOJI MODIFIER FITZPATRICK TYPE-1-2 (E_Modifier) ÷ [0.3] ÷ AC00 × 200D ÷ # ÷ [0.2] HANGUL SYLLABLE GA (LV) × [9.0] ZERO WIDTH JOINER (ZWJ) ÷ [0.3] ÷ AC00 × 0308 × 200D ÷ # ÷ [0.2] HANGUL SYLLABLE GA (LV) × [9.0] COMBINING DIAERESIS (Extend) × [9.0] ZERO WIDTH JOINER (ZWJ) ÷ [0.3] -÷ AC00 ÷ 2764 ÷ # ÷ [0.2] HANGUL SYLLABLE GA (LV) ÷ [999.0] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [0.3] -÷ AC00 × 0308 ÷ 2764 ÷ # ÷ [0.2] HANGUL SYLLABLE GA (LV) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [0.3] +÷ AC00 ÷ 2640 ÷ # ÷ [0.2] HANGUL SYLLABLE GA (LV) ÷ [999.0] FEMALE SIGN (Glue_After_Zwj) ÷ [0.3] +÷ AC00 × 0308 ÷ 2640 ÷ # ÷ [0.2] HANGUL SYLLABLE GA (LV) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] FEMALE SIGN (Glue_After_Zwj) ÷ [0.3] ÷ AC00 ÷ 1F466 ÷ # ÷ [0.2] HANGUL SYLLABLE GA (LV) ÷ [999.0] BOY (EBG) ÷ [0.3] ÷ AC00 × 0308 ÷ 1F466 ÷ # ÷ [0.2] HANGUL SYLLABLE GA (LV) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] BOY (EBG) ÷ [0.3] ÷ AC00 ÷ 0378 ÷ # ÷ [0.2] HANGUL SYLLABLE GA (LV) ÷ [999.0] <reserved-0378> (Other) ÷ [0.3] @@ -493,8 +494,8 @@ ÷ AC01 × 0308 ÷ 1F3FB ÷ # ÷ [0.2] HANGUL SYLLABLE GAG (LVT) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] EMOJI MODIFIER FITZPATRICK TYPE-1-2 (E_Modifier) ÷ [0.3] ÷ AC01 × 200D ÷ # ÷ [0.2] HANGUL SYLLABLE GAG (LVT) × [9.0] ZERO WIDTH JOINER (ZWJ) ÷ [0.3] ÷ AC01 × 0308 × 200D ÷ # ÷ [0.2] HANGUL SYLLABLE GAG (LVT) × [9.0] COMBINING DIAERESIS (Extend) × [9.0] ZERO WIDTH JOINER (ZWJ) ÷ [0.3] -÷ AC01 ÷ 2764 ÷ # ÷ [0.2] HANGUL SYLLABLE GAG (LVT) ÷ [999.0] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [0.3] -÷ AC01 × 0308 ÷ 2764 ÷ # ÷ [0.2] HANGUL SYLLABLE GAG (LVT) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [0.3] +÷ AC01 ÷ 2640 ÷ # ÷ [0.2] HANGUL SYLLABLE GAG (LVT) ÷ [999.0] FEMALE SIGN (Glue_After_Zwj) ÷ [0.3] +÷ AC01 × 0308 ÷ 2640 ÷ # ÷ [0.2] HANGUL SYLLABLE GAG (LVT) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] FEMALE SIGN (Glue_After_Zwj) ÷ [0.3] ÷ AC01 ÷ 1F466 ÷ # ÷ [0.2] HANGUL SYLLABLE GAG (LVT) ÷ [999.0] BOY (EBG) ÷ [0.3] ÷ AC01 × 0308 ÷ 1F466 ÷ # ÷ [0.2] HANGUL SYLLABLE GAG (LVT) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] BOY (EBG) ÷ [0.3] ÷ AC01 ÷ 0378 ÷ # ÷ [0.2] HANGUL SYLLABLE GAG (LVT) ÷ [999.0] <reserved-0378> (Other) ÷ [0.3] @@ -533,8 +534,8 @@ ÷ 1F1E6 × 0308 ÷ 1F3FB ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER A (RI) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] EMOJI MODIFIER FITZPATRICK TYPE-1-2 (E_Modifier) ÷ [0.3] ÷ 1F1E6 × 200D ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER A (RI) × [9.0] ZERO WIDTH JOINER (ZWJ) ÷ [0.3] ÷ 1F1E6 × 0308 × 200D ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER A (RI) × [9.0] COMBINING DIAERESIS (Extend) × [9.0] ZERO WIDTH JOINER (ZWJ) ÷ [0.3] -÷ 1F1E6 ÷ 2764 ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER A (RI) ÷ [999.0] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [0.3] -÷ 1F1E6 × 0308 ÷ 2764 ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER A (RI) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [0.3] +÷ 1F1E6 ÷ 2640 ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER A (RI) ÷ [999.0] FEMALE SIGN (Glue_After_Zwj) ÷ [0.3] +÷ 1F1E6 × 0308 ÷ 2640 ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER A (RI) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] FEMALE SIGN (Glue_After_Zwj) ÷ [0.3] ÷ 1F1E6 ÷ 1F466 ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER A (RI) ÷ [999.0] BOY (EBG) ÷ [0.3] ÷ 1F1E6 × 0308 ÷ 1F466 ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER A (RI) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] BOY (EBG) ÷ [0.3] ÷ 1F1E6 ÷ 0378 ÷ # ÷ [0.2] REGIONAL INDICATOR SYMBOL LETTER A (RI) ÷ [999.0] <reserved-0378> (Other) ÷ [0.3] @@ -573,8 +574,8 @@ ÷ 261D × 0308 × 1F3FB ÷ # ÷ [0.2] WHITE UP POINTING INDEX (E_Base) × [9.0] COMBINING DIAERESIS (Extend) × [10.0] EMOJI MODIFIER FITZPATRICK TYPE-1-2 (E_Modifier) ÷ [0.3] ÷ 261D × 200D ÷ # ÷ [0.2] WHITE UP POINTING INDEX (E_Base) × [9.0] ZERO WIDTH JOINER (ZWJ) ÷ [0.3] ÷ 261D × 0308 × 200D ÷ # ÷ [0.2] WHITE UP POINTING INDEX (E_Base) × [9.0] COMBINING DIAERESIS (Extend) × [9.0] ZERO WIDTH JOINER (ZWJ) ÷ [0.3] -÷ 261D ÷ 2764 ÷ # ÷ [0.2] WHITE UP POINTING INDEX (E_Base) ÷ [999.0] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [0.3] -÷ 261D × 0308 ÷ 2764 ÷ # ÷ [0.2] WHITE UP POINTING INDEX (E_Base) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [0.3] +÷ 261D ÷ 2640 ÷ # ÷ [0.2] WHITE UP POINTING INDEX (E_Base) ÷ [999.0] FEMALE SIGN (Glue_After_Zwj) ÷ [0.3] +÷ 261D × 0308 ÷ 2640 ÷ # ÷ [0.2] WHITE UP POINTING INDEX (E_Base) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] FEMALE SIGN (Glue_After_Zwj) ÷ [0.3] ÷ 261D ÷ 1F466 ÷ # ÷ [0.2] WHITE UP POINTING INDEX (E_Base) ÷ [999.0] BOY (EBG) ÷ [0.3] ÷ 261D × 0308 ÷ 1F466 ÷ # ÷ [0.2] WHITE UP POINTING INDEX (E_Base) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] BOY (EBG) ÷ [0.3] ÷ 261D ÷ 0378 ÷ # ÷ [0.2] WHITE UP POINTING INDEX (E_Base) ÷ [999.0] <reserved-0378> (Other) ÷ [0.3] @@ -613,8 +614,8 @@ ÷ 1F3FB × 0308 ÷ 1F3FB ÷ # ÷ [0.2] EMOJI MODIFIER FITZPATRICK TYPE-1-2 (E_Modifier) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] EMOJI MODIFIER FITZPATRICK TYPE-1-2 (E_Modifier) ÷ [0.3] ÷ 1F3FB × 200D ÷ # ÷ [0.2] EMOJI MODIFIER FITZPATRICK TYPE-1-2 (E_Modifier) × [9.0] ZERO WIDTH JOINER (ZWJ) ÷ [0.3] ÷ 1F3FB × 0308 × 200D ÷ # ÷ [0.2] EMOJI MODIFIER FITZPATRICK TYPE-1-2 (E_Modifier) × [9.0] COMBINING DIAERESIS (Extend) × [9.0] ZERO WIDTH JOINER (ZWJ) ÷ [0.3] -÷ 1F3FB ÷ 2764 ÷ # ÷ [0.2] EMOJI MODIFIER FITZPATRICK TYPE-1-2 (E_Modifier) ÷ [999.0] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [0.3] -÷ 1F3FB × 0308 ÷ 2764 ÷ # ÷ [0.2] EMOJI MODIFIER FITZPATRICK TYPE-1-2 (E_Modifier) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [0.3] +÷ 1F3FB ÷ 2640 ÷ # ÷ [0.2] EMOJI MODIFIER FITZPATRICK TYPE-1-2 (E_Modifier) ÷ [999.0] FEMALE SIGN (Glue_After_Zwj) ÷ [0.3] +÷ 1F3FB × 0308 ÷ 2640 ÷ # ÷ [0.2] EMOJI MODIFIER FITZPATRICK TYPE-1-2 (E_Modifier) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] FEMALE SIGN (Glue_After_Zwj) ÷ [0.3] ÷ 1F3FB ÷ 1F466 ÷ # ÷ [0.2] EMOJI MODIFIER FITZPATRICK TYPE-1-2 (E_Modifier) ÷ [999.0] BOY (EBG) ÷ [0.3] ÷ 1F3FB × 0308 ÷ 1F466 ÷ # ÷ [0.2] EMOJI MODIFIER FITZPATRICK TYPE-1-2 (E_Modifier) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] BOY (EBG) ÷ [0.3] ÷ 1F3FB ÷ 0378 ÷ # ÷ [0.2] EMOJI MODIFIER FITZPATRICK TYPE-1-2 (E_Modifier) ÷ [999.0] <reserved-0378> (Other) ÷ [0.3] @@ -653,54 +654,54 @@ ÷ 200D × 0308 ÷ 1F3FB ÷ # ÷ [0.2] ZERO WIDTH JOINER (ZWJ) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] EMOJI MODIFIER FITZPATRICK TYPE-1-2 (E_Modifier) ÷ [0.3] ÷ 200D × 200D ÷ # ÷ [0.2] ZERO WIDTH JOINER (ZWJ) × [9.0] ZERO WIDTH JOINER (ZWJ) ÷ [0.3] ÷ 200D × 0308 × 200D ÷ # ÷ [0.2] ZERO WIDTH JOINER (ZWJ) × [9.0] COMBINING DIAERESIS (Extend) × [9.0] ZERO WIDTH JOINER (ZWJ) ÷ [0.3] -÷ 200D × 2764 ÷ # ÷ [0.2] ZERO WIDTH JOINER (ZWJ) × [11.0] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [0.3] -÷ 200D × 0308 ÷ 2764 ÷ # ÷ [0.2] ZERO WIDTH JOINER (ZWJ) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [0.3] +÷ 200D × 2640 ÷ # ÷ [0.2] ZERO WIDTH JOINER (ZWJ) × [11.0] FEMALE SIGN (Glue_After_Zwj) ÷ [0.3] +÷ 200D × 0308 ÷ 2640 ÷ # ÷ [0.2] ZERO WIDTH JOINER (ZWJ) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] FEMALE SIGN (Glue_After_Zwj) ÷ [0.3] ÷ 200D × 1F466 ÷ # ÷ [0.2] ZERO WIDTH JOINER (ZWJ) × [11.0] BOY (EBG) ÷ [0.3] ÷ 200D × 0308 ÷ 1F466 ÷ # ÷ [0.2] ZERO WIDTH JOINER (ZWJ) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] BOY (EBG) ÷ [0.3] ÷ 200D ÷ 0378 ÷ # ÷ [0.2] ZERO WIDTH JOINER (ZWJ) ÷ [999.0] <reserved-0378> (Other) ÷ [0.3] ÷ 200D × 0308 ÷ 0378 ÷ # ÷ [0.2] ZERO WIDTH JOINER (ZWJ) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] <reserved-0378> (Other) ÷ [0.3] ÷ 200D ÷ D800 ÷ # ÷ [0.2] ZERO WIDTH JOINER (ZWJ) ÷ [5.0] <surrogate-D800> (Control) ÷ [0.3] ÷ 200D × 0308 ÷ D800 ÷ # ÷ [0.2] ZERO WIDTH JOINER (ZWJ) × [9.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <surrogate-D800> (Control) ÷ [0.3] -÷ 2764 ÷ 0020 ÷ # ÷ [0.2] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [999.0] SPACE (Other) ÷ [0.3] -÷ 2764 × 0308 ÷ 0020 ÷ # ÷ [0.2] HEAVY BLACK HEART (Glue_After_Zwj) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] SPACE (Other) ÷ [0.3] -÷ 2764 ÷ 000D ÷ # ÷ [0.2] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [5.0] <CARRIAGE RETURN (CR)> (CR) ÷ [0.3] -÷ 2764 × 0308 ÷ 000D ÷ # ÷ [0.2] HEAVY BLACK HEART (Glue_After_Zwj) × [9.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <CARRIAGE RETURN (CR)> (CR) ÷ [0.3] -÷ 2764 ÷ 000A ÷ # ÷ [0.2] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [5.0] <LINE FEED (LF)> (LF) ÷ [0.3] -÷ 2764 × 0308 ÷ 000A ÷ # ÷ [0.2] HEAVY BLACK HEART (Glue_After_Zwj) × [9.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <LINE FEED (LF)> (LF) ÷ [0.3] -÷ 2764 ÷ 0001 ÷ # ÷ [0.2] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [5.0] <START OF HEADING> (Control) ÷ [0.3] -÷ 2764 × 0308 ÷ 0001 ÷ # ÷ [0.2] HEAVY BLACK HEART (Glue_After_Zwj) × [9.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <START OF HEADING> (Control) ÷ [0.3] -÷ 2764 × 0300 ÷ # ÷ [0.2] HEAVY BLACK HEART (Glue_After_Zwj) × [9.0] COMBINING GRAVE ACCENT (Extend) ÷ [0.3] -÷ 2764 × 0308 × 0300 ÷ # ÷ [0.2] HEAVY BLACK HEART (Glue_After_Zwj) × [9.0] COMBINING DIAERESIS (Extend) × [9.0] COMBINING GRAVE ACCENT (Extend) ÷ [0.3] -÷ 2764 ÷ 0600 ÷ # ÷ [0.2] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [999.0] ARABIC NUMBER SIGN (Prepend) ÷ [0.3] -÷ 2764 × 0308 ÷ 0600 ÷ # ÷ [0.2] HEAVY BLACK HEART (Glue_After_Zwj) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] ARABIC NUMBER SIGN (Prepend) ÷ [0.3] -÷ 2764 × 0903 ÷ # ÷ [0.2] HEAVY BLACK HEART (Glue_After_Zwj) × [9.1] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [0.3] -÷ 2764 × 0308 × 0903 ÷ # ÷ [0.2] HEAVY BLACK HEART (Glue_After_Zwj) × [9.0] COMBINING DIAERESIS (Extend) × [9.1] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [0.3] -÷ 2764 ÷ 1100 ÷ # ÷ [0.2] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [999.0] HANGUL CHOSEONG KIYEOK (L) ÷ [0.3] -÷ 2764 × 0308 ÷ 1100 ÷ # ÷ [0.2] HEAVY BLACK HEART (Glue_After_Zwj) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL CHOSEONG KIYEOK (L) ÷ [0.3] -÷ 2764 ÷ 1160 ÷ # ÷ [0.2] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [999.0] HANGUL JUNGSEONG FILLER (V) ÷ [0.3] -÷ 2764 × 0308 ÷ 1160 ÷ # ÷ [0.2] HEAVY BLACK HEART (Glue_After_Zwj) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL JUNGSEONG FILLER (V) ÷ [0.3] -÷ 2764 ÷ 11A8 ÷ # ÷ [0.2] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [999.0] HANGUL JONGSEONG KIYEOK (T) ÷ [0.3] -÷ 2764 × 0308 ÷ 11A8 ÷ # ÷ [0.2] HEAVY BLACK HEART (Glue_After_Zwj) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL JONGSEONG KIYEOK (T) ÷ [0.3] -÷ 2764 ÷ AC00 ÷ # ÷ [0.2] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [999.0] HANGUL SYLLABLE GA (LV) ÷ [0.3] -÷ 2764 × 0308 ÷ AC00 ÷ # ÷ [0.2] HEAVY BLACK HEART (Glue_After_Zwj) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL SYLLABLE GA (LV) ÷ [0.3] -÷ 2764 ÷ AC01 ÷ # ÷ [0.2] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [999.0] HANGUL SYLLABLE GAG (LVT) ÷ [0.3] -÷ 2764 × 0308 ÷ AC01 ÷ # ÷ [0.2] HEAVY BLACK HEART (Glue_After_Zwj) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL SYLLABLE GAG (LVT) ÷ [0.3] -÷ 2764 ÷ 1F1E6 ÷ # ÷ [0.2] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [999.0] REGIONAL INDICATOR SYMBOL LETTER A (RI) ÷ [0.3] -÷ 2764 × 0308 ÷ 1F1E6 ÷ # ÷ [0.2] HEAVY BLACK HEART (Glue_After_Zwj) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] REGIONAL INDICATOR SYMBOL LETTER A (RI) ÷ [0.3] -÷ 2764 ÷ 261D ÷ # ÷ [0.2] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [999.0] WHITE UP POINTING INDEX (E_Base) ÷ [0.3] -÷ 2764 × 0308 ÷ 261D ÷ # ÷ [0.2] HEAVY BLACK HEART (Glue_After_Zwj) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] WHITE UP POINTING INDEX (E_Base) ÷ [0.3] -÷ 2764 ÷ 1F3FB ÷ # ÷ [0.2] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [999.0] EMOJI MODIFIER FITZPATRICK TYPE-1-2 (E_Modifier) ÷ [0.3] -÷ 2764 × 0308 ÷ 1F3FB ÷ # ÷ [0.2] HEAVY BLACK HEART (Glue_After_Zwj) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] EMOJI MODIFIER FITZPATRICK TYPE-1-2 (E_Modifier) ÷ [0.3] -÷ 2764 × 200D ÷ # ÷ [0.2] HEAVY BLACK HEART (Glue_After_Zwj) × [9.0] ZERO WIDTH JOINER (ZWJ) ÷ [0.3] -÷ 2764 × 0308 × 200D ÷ # ÷ [0.2] HEAVY BLACK HEART (Glue_After_Zwj) × [9.0] COMBINING DIAERESIS (Extend) × [9.0] ZERO WIDTH JOINER (ZWJ) ÷ [0.3] -÷ 2764 ÷ 2764 ÷ # ÷ [0.2] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [999.0] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [0.3] -÷ 2764 × 0308 ÷ 2764 ÷ # ÷ [0.2] HEAVY BLACK HEART (Glue_After_Zwj) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [0.3] -÷ 2764 ÷ 1F466 ÷ # ÷ [0.2] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [999.0] BOY (EBG) ÷ [0.3] -÷ 2764 × 0308 ÷ 1F466 ÷ # ÷ [0.2] HEAVY BLACK HEART (Glue_After_Zwj) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] BOY (EBG) ÷ [0.3] -÷ 2764 ÷ 0378 ÷ # ÷ [0.2] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [999.0] <reserved-0378> (Other) ÷ [0.3] -÷ 2764 × 0308 ÷ 0378 ÷ # ÷ [0.2] HEAVY BLACK HEART (Glue_After_Zwj) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] <reserved-0378> (Other) ÷ [0.3] -÷ 2764 ÷ D800 ÷ # ÷ [0.2] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [5.0] <surrogate-D800> (Control) ÷ [0.3] -÷ 2764 × 0308 ÷ D800 ÷ # ÷ [0.2] HEAVY BLACK HEART (Glue_After_Zwj) × [9.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <surrogate-D800> (Control) ÷ [0.3] +÷ 2640 ÷ 0020 ÷ # ÷ [0.2] FEMALE SIGN (Glue_After_Zwj) ÷ [999.0] SPACE (Other) ÷ [0.3] +÷ 2640 × 0308 ÷ 0020 ÷ # ÷ [0.2] FEMALE SIGN (Glue_After_Zwj) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] SPACE (Other) ÷ [0.3] +÷ 2640 ÷ 000D ÷ # ÷ [0.2] FEMALE SIGN (Glue_After_Zwj) ÷ [5.0] <CARRIAGE RETURN (CR)> (CR) ÷ [0.3] +÷ 2640 × 0308 ÷ 000D ÷ # ÷ [0.2] FEMALE SIGN (Glue_After_Zwj) × [9.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <CARRIAGE RETURN (CR)> (CR) ÷ [0.3] +÷ 2640 ÷ 000A ÷ # ÷ [0.2] FEMALE SIGN (Glue_After_Zwj) ÷ [5.0] <LINE FEED (LF)> (LF) ÷ [0.3] +÷ 2640 × 0308 ÷ 000A ÷ # ÷ [0.2] FEMALE SIGN (Glue_After_Zwj) × [9.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <LINE FEED (LF)> (LF) ÷ [0.3] +÷ 2640 ÷ 0001 ÷ # ÷ [0.2] FEMALE SIGN (Glue_After_Zwj) ÷ [5.0] <START OF HEADING> (Control) ÷ [0.3] +÷ 2640 × 0308 ÷ 0001 ÷ # ÷ [0.2] FEMALE SIGN (Glue_After_Zwj) × [9.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <START OF HEADING> (Control) ÷ [0.3] +÷ 2640 × 0300 ÷ # ÷ [0.2] FEMALE SIGN (Glue_After_Zwj) × [9.0] COMBINING GRAVE ACCENT (Extend) ÷ [0.3] +÷ 2640 × 0308 × 0300 ÷ # ÷ [0.2] FEMALE SIGN (Glue_After_Zwj) × [9.0] COMBINING DIAERESIS (Extend) × [9.0] COMBINING GRAVE ACCENT (Extend) ÷ [0.3] +÷ 2640 ÷ 0600 ÷ # ÷ [0.2] FEMALE SIGN (Glue_After_Zwj) ÷ [999.0] ARABIC NUMBER SIGN (Prepend) ÷ [0.3] +÷ 2640 × 0308 ÷ 0600 ÷ # ÷ [0.2] FEMALE SIGN (Glue_After_Zwj) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] ARABIC NUMBER SIGN (Prepend) ÷ [0.3] +÷ 2640 × 0903 ÷ # ÷ [0.2] FEMALE SIGN (Glue_After_Zwj) × [9.1] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [0.3] +÷ 2640 × 0308 × 0903 ÷ # ÷ [0.2] FEMALE SIGN (Glue_After_Zwj) × [9.0] COMBINING DIAERESIS (Extend) × [9.1] DEVANAGARI SIGN VISARGA (SpacingMark) ÷ [0.3] +÷ 2640 ÷ 1100 ÷ # ÷ [0.2] FEMALE SIGN (Glue_After_Zwj) ÷ [999.0] HANGUL CHOSEONG KIYEOK (L) ÷ [0.3] +÷ 2640 × 0308 ÷ 1100 ÷ # ÷ [0.2] FEMALE SIGN (Glue_After_Zwj) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL CHOSEONG KIYEOK (L) ÷ [0.3] +÷ 2640 ÷ 1160 ÷ # ÷ [0.2] FEMALE SIGN (Glue_After_Zwj) ÷ [999.0] HANGUL JUNGSEONG FILLER (V) ÷ [0.3] +÷ 2640 × 0308 ÷ 1160 ÷ # ÷ [0.2] FEMALE SIGN (Glue_After_Zwj) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL JUNGSEONG FILLER (V) ÷ [0.3] +÷ 2640 ÷ 11A8 ÷ # ÷ [0.2] FEMALE SIGN (Glue_After_Zwj) ÷ [999.0] HANGUL JONGSEONG KIYEOK (T) ÷ [0.3] +÷ 2640 × 0308 ÷ 11A8 ÷ # ÷ [0.2] FEMALE SIGN (Glue_After_Zwj) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL JONGSEONG KIYEOK (T) ÷ [0.3] +÷ 2640 ÷ AC00 ÷ # ÷ [0.2] FEMALE SIGN (Glue_After_Zwj) ÷ [999.0] HANGUL SYLLABLE GA (LV) ÷ [0.3] +÷ 2640 × 0308 ÷ AC00 ÷ # ÷ [0.2] FEMALE SIGN (Glue_After_Zwj) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL SYLLABLE GA (LV) ÷ [0.3] +÷ 2640 ÷ AC01 ÷ # ÷ [0.2] FEMALE SIGN (Glue_After_Zwj) ÷ [999.0] HANGUL SYLLABLE GAG (LVT) ÷ [0.3] +÷ 2640 × 0308 ÷ AC01 ÷ # ÷ [0.2] FEMALE SIGN (Glue_After_Zwj) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HANGUL SYLLABLE GAG (LVT) ÷ [0.3] +÷ 2640 ÷ 1F1E6 ÷ # ÷ [0.2] FEMALE SIGN (Glue_After_Zwj) ÷ [999.0] REGIONAL INDICATOR SYMBOL LETTER A (RI) ÷ [0.3] +÷ 2640 × 0308 ÷ 1F1E6 ÷ # ÷ [0.2] FEMALE SIGN (Glue_After_Zwj) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] REGIONAL INDICATOR SYMBOL LETTER A (RI) ÷ [0.3] +÷ 2640 ÷ 261D ÷ # ÷ [0.2] FEMALE SIGN (Glue_After_Zwj) ÷ [999.0] WHITE UP POINTING INDEX (E_Base) ÷ [0.3] +÷ 2640 × 0308 ÷ 261D ÷ # ÷ [0.2] FEMALE SIGN (Glue_After_Zwj) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] WHITE UP POINTING INDEX (E_Base) ÷ [0.3] +÷ 2640 ÷ 1F3FB ÷ # ÷ [0.2] FEMALE SIGN (Glue_After_Zwj) ÷ [999.0] EMOJI MODIFIER FITZPATRICK TYPE-1-2 (E_Modifier) ÷ [0.3] +÷ 2640 × 0308 ÷ 1F3FB ÷ # ÷ [0.2] FEMALE SIGN (Glue_After_Zwj) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] EMOJI MODIFIER FITZPATRICK TYPE-1-2 (E_Modifier) ÷ [0.3] +÷ 2640 × 200D ÷ # ÷ [0.2] FEMALE SIGN (Glue_After_Zwj) × [9.0] ZERO WIDTH JOINER (ZWJ) ÷ [0.3] +÷ 2640 × 0308 × 200D ÷ # ÷ [0.2] FEMALE SIGN (Glue_After_Zwj) × [9.0] COMBINING DIAERESIS (Extend) × [9.0] ZERO WIDTH JOINER (ZWJ) ÷ [0.3] +÷ 2640 ÷ 2640 ÷ # ÷ [0.2] FEMALE SIGN (Glue_After_Zwj) ÷ [999.0] FEMALE SIGN (Glue_After_Zwj) ÷ [0.3] +÷ 2640 × 0308 ÷ 2640 ÷ # ÷ [0.2] FEMALE SIGN (Glue_After_Zwj) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] FEMALE SIGN (Glue_After_Zwj) ÷ [0.3] +÷ 2640 ÷ 1F466 ÷ # ÷ [0.2] FEMALE SIGN (Glue_After_Zwj) ÷ [999.0] BOY (EBG) ÷ [0.3] +÷ 2640 × 0308 ÷ 1F466 ÷ # ÷ [0.2] FEMALE SIGN (Glue_After_Zwj) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] BOY (EBG) ÷ [0.3] +÷ 2640 ÷ 0378 ÷ # ÷ [0.2] FEMALE SIGN (Glue_After_Zwj) ÷ [999.0] <reserved-0378> (Other) ÷ [0.3] +÷ 2640 × 0308 ÷ 0378 ÷ # ÷ [0.2] FEMALE SIGN (Glue_After_Zwj) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] <reserved-0378> (Other) ÷ [0.3] +÷ 2640 ÷ D800 ÷ # ÷ [0.2] FEMALE SIGN (Glue_After_Zwj) ÷ [5.0] <surrogate-D800> (Control) ÷ [0.3] +÷ 2640 × 0308 ÷ D800 ÷ # ÷ [0.2] FEMALE SIGN (Glue_After_Zwj) × [9.0] COMBINING DIAERESIS (Extend) ÷ [5.0] <surrogate-D800> (Control) ÷ [0.3] ÷ 1F466 ÷ 0020 ÷ # ÷ [0.2] BOY (EBG) ÷ [999.0] SPACE (Other) ÷ [0.3] ÷ 1F466 × 0308 ÷ 0020 ÷ # ÷ [0.2] BOY (EBG) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] SPACE (Other) ÷ [0.3] ÷ 1F466 ÷ 000D ÷ # ÷ [0.2] BOY (EBG) ÷ [5.0] <CARRIAGE RETURN (CR)> (CR) ÷ [0.3] @@ -733,8 +734,8 @@ ÷ 1F466 × 0308 × 1F3FB ÷ # ÷ [0.2] BOY (EBG) × [9.0] COMBINING DIAERESIS (Extend) × [10.0] EMOJI MODIFIER FITZPATRICK TYPE-1-2 (E_Modifier) ÷ [0.3] ÷ 1F466 × 200D ÷ # ÷ [0.2] BOY (EBG) × [9.0] ZERO WIDTH JOINER (ZWJ) ÷ [0.3] ÷ 1F466 × 0308 × 200D ÷ # ÷ [0.2] BOY (EBG) × [9.0] COMBINING DIAERESIS (Extend) × [9.0] ZERO WIDTH JOINER (ZWJ) ÷ [0.3] -÷ 1F466 ÷ 2764 ÷ # ÷ [0.2] BOY (EBG) ÷ [999.0] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [0.3] -÷ 1F466 × 0308 ÷ 2764 ÷ # ÷ [0.2] BOY (EBG) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [0.3] +÷ 1F466 ÷ 2640 ÷ # ÷ [0.2] BOY (EBG) ÷ [999.0] FEMALE SIGN (Glue_After_Zwj) ÷ [0.3] +÷ 1F466 × 0308 ÷ 2640 ÷ # ÷ [0.2] BOY (EBG) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] FEMALE SIGN (Glue_After_Zwj) ÷ [0.3] ÷ 1F466 ÷ 1F466 ÷ # ÷ [0.2] BOY (EBG) ÷ [999.0] BOY (EBG) ÷ [0.3] ÷ 1F466 × 0308 ÷ 1F466 ÷ # ÷ [0.2] BOY (EBG) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] BOY (EBG) ÷ [0.3] ÷ 1F466 ÷ 0378 ÷ # ÷ [0.2] BOY (EBG) ÷ [999.0] <reserved-0378> (Other) ÷ [0.3] @@ -773,8 +774,8 @@ ÷ 0378 × 0308 ÷ 1F3FB ÷ # ÷ [0.2] <reserved-0378> (Other) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] EMOJI MODIFIER FITZPATRICK TYPE-1-2 (E_Modifier) ÷ [0.3] ÷ 0378 × 200D ÷ # ÷ [0.2] <reserved-0378> (Other) × [9.0] ZERO WIDTH JOINER (ZWJ) ÷ [0.3] ÷ 0378 × 0308 × 200D ÷ # ÷ [0.2] <reserved-0378> (Other) × [9.0] COMBINING DIAERESIS (Extend) × [9.0] ZERO WIDTH JOINER (ZWJ) ÷ [0.3] -÷ 0378 ÷ 2764 ÷ # ÷ [0.2] <reserved-0378> (Other) ÷ [999.0] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [0.3] -÷ 0378 × 0308 ÷ 2764 ÷ # ÷ [0.2] <reserved-0378> (Other) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [0.3] +÷ 0378 ÷ 2640 ÷ # ÷ [0.2] <reserved-0378> (Other) ÷ [999.0] FEMALE SIGN (Glue_After_Zwj) ÷ [0.3] +÷ 0378 × 0308 ÷ 2640 ÷ # ÷ [0.2] <reserved-0378> (Other) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] FEMALE SIGN (Glue_After_Zwj) ÷ [0.3] ÷ 0378 ÷ 1F466 ÷ # ÷ [0.2] <reserved-0378> (Other) ÷ [999.0] BOY (EBG) ÷ [0.3] ÷ 0378 × 0308 ÷ 1F466 ÷ # ÷ [0.2] <reserved-0378> (Other) × [9.0] COMBINING DIAERESIS (Extend) ÷ [999.0] BOY (EBG) ÷ [0.3] ÷ 0378 ÷ 0378 ÷ # ÷ [0.2] <reserved-0378> (Other) ÷ [999.0] <reserved-0378> (Other) ÷ [0.3] @@ -813,8 +814,8 @@ ÷ D800 ÷ 0308 ÷ 1F3FB ÷ # ÷ [0.2] <surrogate-D800> (Control) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [999.0] EMOJI MODIFIER FITZPATRICK TYPE-1-2 (E_Modifier) ÷ [0.3] ÷ D800 ÷ 200D ÷ # ÷ [0.2] <surrogate-D800> (Control) ÷ [4.0] ZERO WIDTH JOINER (ZWJ) ÷ [0.3] ÷ D800 ÷ 0308 × 200D ÷ # ÷ [0.2] <surrogate-D800> (Control) ÷ [4.0] COMBINING DIAERESIS (Extend) × [9.0] ZERO WIDTH JOINER (ZWJ) ÷ [0.3] -÷ D800 ÷ 2764 ÷ # ÷ [0.2] <surrogate-D800> (Control) ÷ [4.0] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [0.3] -÷ D800 ÷ 0308 ÷ 2764 ÷ # ÷ [0.2] <surrogate-D800> (Control) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [999.0] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [0.3] +÷ D800 ÷ 2640 ÷ # ÷ [0.2] <surrogate-D800> (Control) ÷ [4.0] FEMALE SIGN (Glue_After_Zwj) ÷ [0.3] +÷ D800 ÷ 0308 ÷ 2640 ÷ # ÷ [0.2] <surrogate-D800> (Control) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [999.0] FEMALE SIGN (Glue_After_Zwj) ÷ [0.3] ÷ D800 ÷ 1F466 ÷ # ÷ [0.2] <surrogate-D800> (Control) ÷ [4.0] BOY (EBG) ÷ [0.3] ÷ D800 ÷ 0308 ÷ 1F466 ÷ # ÷ [0.2] <surrogate-D800> (Control) ÷ [4.0] COMBINING DIAERESIS (Extend) ÷ [999.0] BOY (EBG) ÷ [0.3] ÷ D800 ÷ 0378 ÷ # ÷ [0.2] <surrogate-D800> (Control) ÷ [4.0] <reserved-0378> (Other) ÷ [0.3] @@ -840,7 +841,7 @@ ÷ 261D × 1F3FB ÷ 261D ÷ # ÷ [0.2] WHITE UP POINTING INDEX (E_Base) × [10.0] EMOJI MODIFIER FITZPATRICK TYPE-1-2 (E_Modifier) ÷ [999.0] WHITE UP POINTING INDEX (E_Base) ÷ [0.3] ÷ 1F466 × 1F3FB ÷ # ÷ [0.2] BOY (EBG) × [10.0] EMOJI MODIFIER FITZPATRICK TYPE-1-2 (E_Modifier) ÷ [0.3] ÷ 200D × 1F466 × 1F3FB ÷ # ÷ [0.2] ZERO WIDTH JOINER (ZWJ) × [11.0] BOY (EBG) × [10.0] EMOJI MODIFIER FITZPATRICK TYPE-1-2 (E_Modifier) ÷ [0.3] -÷ 200D × 2764 ÷ # ÷ [0.2] ZERO WIDTH JOINER (ZWJ) × [11.0] HEAVY BLACK HEART (Glue_After_Zwj) ÷ [0.3] +÷ 200D × 2640 ÷ # ÷ [0.2] ZERO WIDTH JOINER (ZWJ) × [11.0] FEMALE SIGN (Glue_After_Zwj) ÷ [0.3] ÷ 200D × 1F466 ÷ # ÷ [0.2] ZERO WIDTH JOINER (ZWJ) × [11.0] BOY (EBG) ÷ [0.3] ÷ 1F466 ÷ 1F466 ÷ # ÷ [0.2] BOY (EBG) ÷ [999.0] BOY (EBG) ÷ [0.3] # diff --git a/lib/stdlib/test/unicode_util_SUITE_data/LineBreakTest.txt b/lib/stdlib/test/unicode_util_SUITE_data/LineBreakTest.txt index 05efcf5a44..6715446aba 100644 --- a/lib/stdlib/test/unicode_util_SUITE_data/LineBreakTest.txt +++ b/lib/stdlib/test/unicode_util_SUITE_data/LineBreakTest.txt @@ -1,25 +1,28 @@ -# LineBreakTest-9.0.0.txt -# Date: 2016-06-18, 00:42:06 GMT -# © 2016 Unicode®, Inc. +# LineBreakTest-10.0.0.txt +# Date: 2017-04-14, 05:40:30 GMT +# © 2017 Unicode®, Inc. # Unicode and the Unicode Logo are registered trademarks of Unicode, Inc. in the U.S. and other countries. # For terms of use, see http://www.unicode.org/terms_of_use.html # # Unicode Character Database # For documentation, see http://www.unicode.org/reports/tr44/ # -# Default Line Break Test +# Default Line_Break Test # # Format: -# <string> (# <comment>)? -# <string> contains hex Unicode code points, with -# ÷ wherever there is a break opportunity, and +# <string> (# <comment>)? +# <string> contains hex Unicode code points, with +# ÷ wherever there is a break opportunity, and # × wherever there is not. # <comment> the format can change, but currently it shows: # - the sample character name # - (x) the Line_Break property value for the sample character -# - [x] the rule that determines whether there is a break or not -# Note: The Line Break tests use tailoring of numbers described in Example 7 of Section 8.2 Examples of Customization. -# They also differ from the results produced by a pair table implementation in sequences like: ZW SP CL. +# - [x] the rule that determines whether there is a break or not, +# as listed in the Rules section of LineBreakTest.html +# +# Note: +# The Line_Break tests use tailoring of numbers described in +# Example 7 of Section 8.2, "Examples of Customization" of UAX #14. # # These samples may be extended or changed in the future. # diff --git a/lib/stdlib/test/unicode_util_SUITE_data/NormalizationTest.txt b/lib/stdlib/test/unicode_util_SUITE_data/NormalizationTest.txt index e133fa8a78..71f2371c5e 100644 --- a/lib/stdlib/test/unicode_util_SUITE_data/NormalizationTest.txt +++ b/lib/stdlib/test/unicode_util_SUITE_data/NormalizationTest.txt @@ -1,6 +1,6 @@ -# NormalizationTest-9.0.0.txt -# Date: 2016-04-04, 11:41:55 GMT -# © 2016 Unicode®, Inc. +# NormalizationTest-10.0.0.txt +# Date: 2017-03-08, 08:41:55 GMT +# © 2017 Unicode®, Inc. # Unicode and the Unicode Logo are registered trademarks of Unicode, Inc. in the U.S. and other countries. # For terms of use, see http://www.unicode.org/terms_of_use.html # @@ -17653,6 +17653,10 @@ FFEE;FFEE;FFEE;25CB;25CB; # (￮; ￮; ￮; ○; ○; ) HALFWIDTH WHITE CIRCLE 0061 0CBC 3099 093C 0334 0062;0061 0334 0CBC 093C 3099 0062;0061 0334 0CBC 093C 3099 0062;0061 0334 0CBC 093C 3099 0062;0061 0334 0CBC 093C 3099 0062; # (a◌಼◌゙◌़◌̴b; a◌̴◌಼◌़◌゙b; a◌̴◌಼◌़◌゙b; a◌̴◌಼◌़◌゙b; a◌̴◌಼◌़◌゙b; ) LATIN SMALL LETTER A, KANNADA SIGN NUKTA, COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK, DEVANAGARI SIGN NUKTA, COMBINING TILDE OVERLAY, LATIN SMALL LETTER B 0061 05B0 094D 3099 0CCD 0062;0061 3099 094D 0CCD 05B0 0062;0061 3099 094D 0CCD 05B0 0062;0061 3099 094D 0CCD 05B0 0062;0061 3099 094D 0CCD 05B0 0062; # (a◌ְ◌्◌゙◌್b; a◌゙◌्◌್◌ְb; a◌゙◌्◌್◌ְb; a◌゙◌्◌್◌ְb; a◌゙◌्◌್◌ְb; ) LATIN SMALL LETTER A, HEBREW POINT SHEVA, DEVANAGARI SIGN VIRAMA, COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK, KANNADA SIGN VIRAMA, LATIN SMALL LETTER B 0061 0CCD 05B0 094D 3099 0062;0061 3099 0CCD 094D 05B0 0062;0061 3099 0CCD 094D 05B0 0062;0061 3099 0CCD 094D 05B0 0062;0061 3099 0CCD 094D 05B0 0062; # (a◌್◌ְ◌्◌゙b; a◌゙◌್◌्◌ְb; a◌゙◌್◌्◌ְb; a◌゙◌್◌्◌ְb; a◌゙◌್◌्◌ְb; ) LATIN SMALL LETTER A, KANNADA SIGN VIRAMA, HEBREW POINT SHEVA, DEVANAGARI SIGN VIRAMA, COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK, LATIN SMALL LETTER B +0061 05B0 094D 3099 0D3B 0062;0061 3099 094D 0D3B 05B0 0062;0061 3099 094D 0D3B 05B0 0062;0061 3099 094D 0D3B 05B0 0062;0061 3099 094D 0D3B 05B0 0062; # (a◌ְ◌्◌゙◌഻b; a◌゙◌्◌഻◌ְb; a◌゙◌्◌഻◌ְb; a◌゙◌्◌഻◌ְb; a◌゙◌्◌഻◌ְb; ) LATIN SMALL LETTER A, HEBREW POINT SHEVA, DEVANAGARI SIGN VIRAMA, COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK, MALAYALAM SIGN VERTICAL BAR VIRAMA, LATIN SMALL LETTER B +0061 0D3B 05B0 094D 3099 0062;0061 3099 0D3B 094D 05B0 0062;0061 3099 0D3B 094D 05B0 0062;0061 3099 0D3B 094D 05B0 0062;0061 3099 0D3B 094D 05B0 0062; # (a◌഻◌ְ◌्◌゙b; a◌゙◌഻◌्◌ְb; a◌゙◌഻◌्◌ְb; a◌゙◌഻◌्◌ְb; a◌゙◌഻◌्◌ְb; ) LATIN SMALL LETTER A, MALAYALAM SIGN VERTICAL BAR VIRAMA, HEBREW POINT SHEVA, DEVANAGARI SIGN VIRAMA, COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK, LATIN SMALL LETTER B +0061 05B0 094D 3099 0D3C 0062;0061 3099 094D 0D3C 05B0 0062;0061 3099 094D 0D3C 05B0 0062;0061 3099 094D 0D3C 05B0 0062;0061 3099 094D 0D3C 05B0 0062; # (a◌ְ◌्◌゙◌഼b; a◌゙◌्◌഼◌ְb; a◌゙◌्◌഼◌ְb; a◌゙◌्◌഼◌ְb; a◌゙◌्◌഼◌ְb; ) LATIN SMALL LETTER A, HEBREW POINT SHEVA, DEVANAGARI SIGN VIRAMA, COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK, MALAYALAM SIGN CIRCULAR VIRAMA, LATIN SMALL LETTER B +0061 0D3C 05B0 094D 3099 0062;0061 3099 0D3C 094D 05B0 0062;0061 3099 0D3C 094D 05B0 0062;0061 3099 0D3C 094D 05B0 0062;0061 3099 0D3C 094D 05B0 0062; # (a◌഼◌ְ◌्◌゙b; a◌゙◌഼◌्◌ְb; a◌゙◌഼◌्◌ְb; a◌゙◌഼◌्◌ְb; a◌゙◌഼◌्◌ְb; ) LATIN SMALL LETTER A, MALAYALAM SIGN CIRCULAR VIRAMA, HEBREW POINT SHEVA, DEVANAGARI SIGN VIRAMA, COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK, LATIN SMALL LETTER B 0061 05B0 094D 3099 0D4D 0062;0061 3099 094D 0D4D 05B0 0062;0061 3099 094D 0D4D 05B0 0062;0061 3099 094D 0D4D 05B0 0062;0061 3099 094D 0D4D 05B0 0062; # (a◌ְ◌्◌゙◌്b; a◌゙◌्◌്◌ְb; a◌゙◌्◌്◌ְb; a◌゙◌्◌്◌ְb; a◌゙◌्◌്◌ְb; ) LATIN SMALL LETTER A, HEBREW POINT SHEVA, DEVANAGARI SIGN VIRAMA, COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK, MALAYALAM SIGN VIRAMA, LATIN SMALL LETTER B 0061 0D4D 05B0 094D 3099 0062;0061 3099 0D4D 094D 05B0 0062;0061 3099 0D4D 094D 05B0 0062;0061 3099 0D4D 094D 05B0 0062;0061 3099 0D4D 094D 05B0 0062; # (a◌്◌ְ◌्◌゙b; a◌゙◌്◌्◌ְb; a◌゙◌്◌्◌ְb; a◌゙◌്◌्◌ְb; a◌゙◌്◌्◌ְb; ) LATIN SMALL LETTER A, MALAYALAM SIGN VIRAMA, HEBREW POINT SHEVA, DEVANAGARI SIGN VIRAMA, COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK, LATIN SMALL LETTER B 0061 05B0 094D 3099 0DCA 0062;0061 3099 094D 0DCA 05B0 0062;0061 3099 094D 0DCA 05B0 0062;0061 3099 094D 0DCA 05B0 0062;0061 3099 094D 0DCA 05B0 0062; # (a◌ְ◌्◌゙◌්b; a◌゙◌्◌්◌ְb; a◌゙◌्◌්◌ְb; a◌゙◌्◌්◌ְb; a◌゙◌्◌්◌ְb; ) LATIN SMALL LETTER A, HEBREW POINT SHEVA, DEVANAGARI SIGN VIRAMA, COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK, SINHALA SIGN AL-LAKUNA, LATIN SMALL LETTER B @@ -17999,6 +18003,14 @@ FFEE;FFEE;FFEE;25CB;25CB; # (￮; ￮; ￮; ○; ○; ) HALFWIDTH WHITE CIRCLE 0061 1DF4 0315 0300 05AE 0062;0061 05AE 1DF4 0300 0315 0062;0061 05AE 1DF4 0300 0315 0062;0061 05AE 1DF4 0300 0315 0062;0061 05AE 1DF4 0300 0315 0062; # (a◌ᷴ◌̕◌̀◌֮b; a◌֮◌ᷴ◌̀◌̕b; a◌֮◌ᷴ◌̀◌̕b; a◌֮◌ᷴ◌̀◌̕b; a◌֮◌ᷴ◌̀◌̕b; ) LATIN SMALL LETTER A, COMBINING LATIN SMALL LETTER U WITH DIAERESIS, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, LATIN SMALL LETTER B 0061 0315 0300 05AE 1DF5 0062;00E0 05AE 1DF5 0315 0062;0061 05AE 0300 1DF5 0315 0062;00E0 05AE 1DF5 0315 0062;0061 05AE 0300 1DF5 0315 0062; # (a◌̕◌̀◌֮◌᷵b; à◌֮◌᷵◌̕b; a◌֮◌̀◌᷵◌̕b; à◌֮◌᷵◌̕b; a◌֮◌̀◌᷵◌̕b; ) LATIN SMALL LETTER A, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, COMBINING UP TACK ABOVE, LATIN SMALL LETTER B 0061 1DF5 0315 0300 05AE 0062;0061 05AE 1DF5 0300 0315 0062;0061 05AE 1DF5 0300 0315 0062;0061 05AE 1DF5 0300 0315 0062;0061 05AE 1DF5 0300 0315 0062; # (a◌᷵◌̕◌̀◌֮b; a◌֮◌᷵◌̀◌̕b; a◌֮◌᷵◌̀◌̕b; a◌֮◌᷵◌̀◌̕b; a◌֮◌᷵◌̀◌̕b; ) LATIN SMALL LETTER A, COMBINING UP TACK ABOVE, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, LATIN SMALL LETTER B +0061 035C 0315 0300 1DF6 0062;00E0 0315 1DF6 035C 0062;0061 0300 0315 1DF6 035C 0062;00E0 0315 1DF6 035C 0062;0061 0300 0315 1DF6 035C 0062; # (a◌͜◌̕◌̀◌᷶b; à◌̕◌᷶◌͜b; a◌̀◌̕◌᷶◌͜b; à◌̕◌᷶◌͜b; a◌̀◌̕◌᷶◌͜b; ) LATIN SMALL LETTER A, COMBINING DOUBLE BREVE BELOW, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, COMBINING KAVYKA ABOVE RIGHT, LATIN SMALL LETTER B +0061 1DF6 035C 0315 0300 0062;00E0 1DF6 0315 035C 0062;0061 0300 1DF6 0315 035C 0062;00E0 1DF6 0315 035C 0062;0061 0300 1DF6 0315 035C 0062; # (a◌᷶◌͜◌̕◌̀b; à◌᷶◌̕◌͜b; a◌̀◌᷶◌̕◌͜b; à◌᷶◌̕◌͜b; a◌̀◌᷶◌̕◌͜b; ) LATIN SMALL LETTER A, COMBINING KAVYKA ABOVE RIGHT, COMBINING DOUBLE BREVE BELOW, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, LATIN SMALL LETTER B +0061 0300 05AE 1D16D 1DF7 0062;00E0 1D16D 05AE 1DF7 0062;0061 1D16D 05AE 1DF7 0300 0062;00E0 1D16D 05AE 1DF7 0062;0061 1D16D 05AE 1DF7 0300 0062; # (a◌̀◌𝅭֮◌᷷b; à𝅭◌֮◌᷷b; a𝅭◌֮◌᷷◌̀b; à𝅭◌֮◌᷷b; a𝅭◌֮◌᷷◌̀b; ) LATIN SMALL LETTER A, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, MUSICAL SYMBOL COMBINING AUGMENTATION DOT, COMBINING KAVYKA ABOVE LEFT, LATIN SMALL LETTER B +0061 1DF7 0300 05AE 1D16D 0062;00E0 1D16D 1DF7 05AE 0062;0061 1D16D 1DF7 05AE 0300 0062;00E0 1D16D 1DF7 05AE 0062;0061 1D16D 1DF7 05AE 0300 0062; # (a◌᷷◌̀◌𝅭֮b; à𝅭◌᷷◌֮b; a𝅭◌᷷◌֮◌̀b; à𝅭◌᷷◌֮b; a𝅭◌᷷◌֮◌̀b; ) LATIN SMALL LETTER A, COMBINING KAVYKA ABOVE LEFT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, MUSICAL SYMBOL COMBINING AUGMENTATION DOT, LATIN SMALL LETTER B +0061 0300 05AE 1D16D 1DF8 0062;00E0 1D16D 05AE 1DF8 0062;0061 1D16D 05AE 1DF8 0300 0062;00E0 1D16D 05AE 1DF8 0062;0061 1D16D 05AE 1DF8 0300 0062; # (a◌̀◌𝅭֮◌᷸b; à𝅭◌֮◌᷸b; a𝅭◌֮◌᷸◌̀b; à𝅭◌֮◌᷸b; a𝅭◌֮◌᷸◌̀b; ) LATIN SMALL LETTER A, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, MUSICAL SYMBOL COMBINING AUGMENTATION DOT, COMBINING DOT ABOVE LEFT, LATIN SMALL LETTER B +0061 1DF8 0300 05AE 1D16D 0062;00E0 1D16D 1DF8 05AE 0062;0061 1D16D 1DF8 05AE 0300 0062;00E0 1D16D 1DF8 05AE 0062;0061 1D16D 1DF8 05AE 0300 0062; # (a◌᷸◌̀◌𝅭֮b; à𝅭◌᷸◌֮b; a𝅭◌᷸◌֮◌̀b; à𝅭◌᷸◌֮b; a𝅭◌᷸◌֮◌̀b; ) LATIN SMALL LETTER A, COMBINING DOT ABOVE LEFT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, MUSICAL SYMBOL COMBINING AUGMENTATION DOT, LATIN SMALL LETTER B +0061 059A 0316 302A 1DF9 0062;0061 302A 0316 1DF9 059A 0062;0061 302A 0316 1DF9 059A 0062;0061 302A 0316 1DF9 059A 0062;0061 302A 0316 1DF9 059A 0062; # (a◌֚◌̖◌〪◌᷹b; a◌〪◌̖◌᷹◌֚b; a◌〪◌̖◌᷹◌֚b; a◌〪◌̖◌᷹◌֚b; a◌〪◌̖◌᷹◌֚b; ) LATIN SMALL LETTER A, HEBREW ACCENT YETIV, COMBINING GRAVE ACCENT BELOW, IDEOGRAPHIC LEVEL TONE MARK, COMBINING WIDE INVERTED BRIDGE BELOW, LATIN SMALL LETTER B +0061 1DF9 059A 0316 302A 0062;0061 302A 1DF9 0316 059A 0062;0061 302A 1DF9 0316 059A 0062;0061 302A 1DF9 0316 059A 0062;0061 302A 1DF9 0316 059A 0062; # (a◌᷹◌֚◌̖◌〪b; a◌〪◌᷹◌̖◌֚b; a◌〪◌᷹◌̖◌֚b; a◌〪◌᷹◌̖◌֚b; a◌〪◌᷹◌̖◌֚b; ) LATIN SMALL LETTER A, COMBINING WIDE INVERTED BRIDGE BELOW, HEBREW ACCENT YETIV, COMBINING GRAVE ACCENT BELOW, IDEOGRAPHIC LEVEL TONE MARK, LATIN SMALL LETTER B 0061 0315 0300 05AE 1DFB 0062;00E0 05AE 1DFB 0315 0062;0061 05AE 0300 1DFB 0315 0062;00E0 05AE 1DFB 0315 0062;0061 05AE 0300 1DFB 0315 0062; # (a◌̕◌̀◌֮◌᷻b; à◌֮◌᷻◌̕b; a◌֮◌̀◌᷻◌̕b; à◌֮◌᷻◌̕b; a◌֮◌̀◌᷻◌̕b; ) LATIN SMALL LETTER A, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, COMBINING DELETION MARK, LATIN SMALL LETTER B 0061 1DFB 0315 0300 05AE 0062;0061 05AE 1DFB 0300 0315 0062;0061 05AE 1DFB 0300 0315 0062;0061 05AE 1DFB 0300 0315 0062;0061 05AE 1DFB 0300 0315 0062; # (a◌᷻◌̕◌̀◌֮b; a◌֮◌᷻◌̀◌̕b; a◌֮◌᷻◌̀◌̕b; a◌֮◌᷻◌̀◌̕b; a◌֮◌᷻◌̀◌̕b; ) LATIN SMALL LETTER A, COMBINING DELETION MARK, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, LATIN SMALL LETTER B 0061 035D 035C 0315 1DFC 0062;0061 0315 035C 1DFC 035D 0062;0061 0315 035C 1DFC 035D 0062;0061 0315 035C 1DFC 035D 0062;0061 0315 035C 1DFC 035D 0062; # (a◌͝◌͜◌̕◌᷼b; a◌̕◌͜◌᷼◌͝b; a◌̕◌͜◌᷼◌͝b; a◌̕◌͜◌᷼◌͝b; a◌̕◌͜◌᷼◌͝b; ) LATIN SMALL LETTER A, COMBINING DOUBLE BREVE, COMBINING DOUBLE BREVE BELOW, COMBINING COMMA ABOVE RIGHT, COMBINING DOUBLE INVERTED BREVE BELOW, LATIN SMALL LETTER B @@ -18397,8 +18409,20 @@ FFEE;FFEE;FFEE;25CB;25CB; # (￮; ￮; ￮; ○; ○; ) HALFWIDTH WHITE CIRCLE 0061 116B7 3099 093C 0334 0062;0061 0334 116B7 093C 3099 0062;0061 0334 116B7 093C 3099 0062;0061 0334 116B7 093C 3099 0062;0061 0334 116B7 093C 3099 0062; # (a◌𑚷◌゙◌़◌̴b; a◌̴◌𑚷◌़◌゙b; a◌̴◌𑚷◌़◌゙b; a◌̴◌𑚷◌़◌゙b; a◌̴◌𑚷◌़◌゙b; ) LATIN SMALL LETTER A, TAKRI SIGN NUKTA, COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK, DEVANAGARI SIGN NUKTA, COMBINING TILDE OVERLAY, LATIN SMALL LETTER B 0061 05B0 094D 3099 1172B 0062;0061 3099 094D 1172B 05B0 0062;0061 3099 094D 1172B 05B0 0062;0061 3099 094D 1172B 05B0 0062;0061 3099 094D 1172B 05B0 0062; # (a◌ְ◌्◌゙◌𑜫b; a◌゙◌्◌𑜫◌ְb; a◌゙◌्◌𑜫◌ְb; a◌゙◌्◌𑜫◌ְb; a◌゙◌्◌𑜫◌ְb; ) LATIN SMALL LETTER A, HEBREW POINT SHEVA, DEVANAGARI SIGN VIRAMA, COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK, AHOM SIGN KILLER, LATIN SMALL LETTER B 0061 1172B 05B0 094D 3099 0062;0061 3099 1172B 094D 05B0 0062;0061 3099 1172B 094D 05B0 0062;0061 3099 1172B 094D 05B0 0062;0061 3099 1172B 094D 05B0 0062; # (a◌𑜫◌ְ◌्◌゙b; a◌゙◌𑜫◌्◌ְb; a◌゙◌𑜫◌्◌ְb; a◌゙◌𑜫◌्◌ְb; a◌゙◌𑜫◌्◌ְb; ) LATIN SMALL LETTER A, AHOM SIGN KILLER, HEBREW POINT SHEVA, DEVANAGARI SIGN VIRAMA, COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK, LATIN SMALL LETTER B +0061 05B0 094D 3099 11A34 0062;0061 3099 094D 11A34 05B0 0062;0061 3099 094D 11A34 05B0 0062;0061 3099 094D 11A34 05B0 0062;0061 3099 094D 11A34 05B0 0062; # (a◌ְ◌्◌゙◌𑨴b; a◌゙◌्◌𑨴◌ְb; a◌゙◌्◌𑨴◌ְb; a◌゙◌्◌𑨴◌ְb; a◌゙◌्◌𑨴◌ְb; ) LATIN SMALL LETTER A, HEBREW POINT SHEVA, DEVANAGARI SIGN VIRAMA, COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK, ZANABAZAR SQUARE SIGN VIRAMA, LATIN SMALL LETTER B +0061 11A34 05B0 094D 3099 0062;0061 3099 11A34 094D 05B0 0062;0061 3099 11A34 094D 05B0 0062;0061 3099 11A34 094D 05B0 0062;0061 3099 11A34 094D 05B0 0062; # (a◌𑨴◌ְ◌्◌゙b; a◌゙◌𑨴◌्◌ְb; a◌゙◌𑨴◌्◌ְb; a◌゙◌𑨴◌्◌ְb; a◌゙◌𑨴◌्◌ְb; ) LATIN SMALL LETTER A, ZANABAZAR SQUARE SIGN VIRAMA, HEBREW POINT SHEVA, DEVANAGARI SIGN VIRAMA, COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK, LATIN SMALL LETTER B +0061 05B0 094D 3099 11A47 0062;0061 3099 094D 11A47 05B0 0062;0061 3099 094D 11A47 05B0 0062;0061 3099 094D 11A47 05B0 0062;0061 3099 094D 11A47 05B0 0062; # (a◌ְ◌्◌゙◌𑩇b; a◌゙◌्◌𑩇◌ְb; a◌゙◌्◌𑩇◌ְb; a◌゙◌्◌𑩇◌ְb; a◌゙◌्◌𑩇◌ְb; ) LATIN SMALL LETTER A, HEBREW POINT SHEVA, DEVANAGARI SIGN VIRAMA, COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK, ZANABAZAR SQUARE SUBJOINER, LATIN SMALL LETTER B +0061 11A47 05B0 094D 3099 0062;0061 3099 11A47 094D 05B0 0062;0061 3099 11A47 094D 05B0 0062;0061 3099 11A47 094D 05B0 0062;0061 3099 11A47 094D 05B0 0062; # (a◌𑩇◌ְ◌्◌゙b; a◌゙◌𑩇◌्◌ְb; a◌゙◌𑩇◌्◌ְb; a◌゙◌𑩇◌्◌ְb; a◌゙◌𑩇◌्◌ְb; ) LATIN SMALL LETTER A, ZANABAZAR SQUARE SUBJOINER, HEBREW POINT SHEVA, DEVANAGARI SIGN VIRAMA, COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK, LATIN SMALL LETTER B +0061 05B0 094D 3099 11A99 0062;0061 3099 094D 11A99 05B0 0062;0061 3099 094D 11A99 05B0 0062;0061 3099 094D 11A99 05B0 0062;0061 3099 094D 11A99 05B0 0062; # (a◌ְ◌्◌゙◌𑪙b; a◌゙◌्◌𑪙◌ְb; a◌゙◌्◌𑪙◌ְb; a◌゙◌्◌𑪙◌ְb; a◌゙◌्◌𑪙◌ְb; ) LATIN SMALL LETTER A, HEBREW POINT SHEVA, DEVANAGARI SIGN VIRAMA, COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK, SOYOMBO SUBJOINER, LATIN SMALL LETTER B +0061 11A99 05B0 094D 3099 0062;0061 3099 11A99 094D 05B0 0062;0061 3099 11A99 094D 05B0 0062;0061 3099 11A99 094D 05B0 0062;0061 3099 11A99 094D 05B0 0062; # (a◌𑪙◌ְ◌्◌゙b; a◌゙◌𑪙◌्◌ְb; a◌゙◌𑪙◌्◌ְb; a◌゙◌𑪙◌्◌ְb; a◌゙◌𑪙◌्◌ְb; ) LATIN SMALL LETTER A, SOYOMBO SUBJOINER, HEBREW POINT SHEVA, DEVANAGARI SIGN VIRAMA, COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK, LATIN SMALL LETTER B 0061 05B0 094D 3099 11C3F 0062;0061 3099 094D 11C3F 05B0 0062;0061 3099 094D 11C3F 05B0 0062;0061 3099 094D 11C3F 05B0 0062;0061 3099 094D 11C3F 05B0 0062; # (a◌ְ◌्◌゙◌𑰿b; a◌゙◌्◌𑰿◌ְb; a◌゙◌्◌𑰿◌ְb; a◌゙◌्◌𑰿◌ְb; a◌゙◌्◌𑰿◌ְb; ) LATIN SMALL LETTER A, HEBREW POINT SHEVA, DEVANAGARI SIGN VIRAMA, COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK, BHAIKSUKI SIGN VIRAMA, LATIN SMALL LETTER B 0061 11C3F 05B0 094D 3099 0062;0061 3099 11C3F 094D 05B0 0062;0061 3099 11C3F 094D 05B0 0062;0061 3099 11C3F 094D 05B0 0062;0061 3099 11C3F 094D 05B0 0062; # (a◌𑰿◌ְ◌्◌゙b; a◌゙◌𑰿◌्◌ְb; a◌゙◌𑰿◌्◌ְb; a◌゙◌𑰿◌्◌ְb; a◌゙◌𑰿◌्◌ְb; ) LATIN SMALL LETTER A, BHAIKSUKI SIGN VIRAMA, HEBREW POINT SHEVA, DEVANAGARI SIGN VIRAMA, COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK, LATIN SMALL LETTER B +0061 3099 093C 0334 11D42 0062;0061 0334 093C 11D42 3099 0062;0061 0334 093C 11D42 3099 0062;0061 0334 093C 11D42 3099 0062;0061 0334 093C 11D42 3099 0062; # (a◌゙◌़◌̴◌𑵂b; a◌̴◌़◌𑵂◌゙b; a◌̴◌़◌𑵂◌゙b; a◌̴◌़◌𑵂◌゙b; a◌̴◌़◌𑵂◌゙b; ) LATIN SMALL LETTER A, COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK, DEVANAGARI SIGN NUKTA, COMBINING TILDE OVERLAY, MASARAM GONDI SIGN NUKTA, LATIN SMALL LETTER B +0061 11D42 3099 093C 0334 0062;0061 0334 11D42 093C 3099 0062;0061 0334 11D42 093C 3099 0062;0061 0334 11D42 093C 3099 0062;0061 0334 11D42 093C 3099 0062; # (a◌𑵂◌゙◌़◌̴b; a◌̴◌𑵂◌़◌゙b; a◌̴◌𑵂◌़◌゙b; a◌̴◌𑵂◌़◌゙b; a◌̴◌𑵂◌़◌゙b; ) LATIN SMALL LETTER A, MASARAM GONDI SIGN NUKTA, COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK, DEVANAGARI SIGN NUKTA, COMBINING TILDE OVERLAY, LATIN SMALL LETTER B +0061 05B0 094D 3099 11D44 0062;0061 3099 094D 11D44 05B0 0062;0061 3099 094D 11D44 05B0 0062;0061 3099 094D 11D44 05B0 0062;0061 3099 094D 11D44 05B0 0062; # (a◌ְ◌्◌゙◌𑵄b; a◌゙◌्◌𑵄◌ְb; a◌゙◌्◌𑵄◌ְb; a◌゙◌्◌𑵄◌ְb; a◌゙◌्◌𑵄◌ְb; ) LATIN SMALL LETTER A, HEBREW POINT SHEVA, DEVANAGARI SIGN VIRAMA, COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK, MASARAM GONDI SIGN HALANTA, LATIN SMALL LETTER B +0061 11D44 05B0 094D 3099 0062;0061 3099 11D44 094D 05B0 0062;0061 3099 11D44 094D 05B0 0062;0061 3099 11D44 094D 05B0 0062;0061 3099 11D44 094D 05B0 0062; # (a◌𑵄◌ְ◌्◌゙b; a◌゙◌𑵄◌्◌ְb; a◌゙◌𑵄◌्◌ְb; a◌゙◌𑵄◌्◌ְb; a◌゙◌𑵄◌्◌ְb; ) LATIN SMALL LETTER A, MASARAM GONDI SIGN HALANTA, HEBREW POINT SHEVA, DEVANAGARI SIGN VIRAMA, COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK, LATIN SMALL LETTER B +0061 05B0 094D 3099 11D45 0062;0061 3099 094D 11D45 05B0 0062;0061 3099 094D 11D45 05B0 0062;0061 3099 094D 11D45 05B0 0062;0061 3099 094D 11D45 05B0 0062; # (a◌ְ◌्◌゙◌𑵅b; a◌゙◌्◌𑵅◌ְb; a◌゙◌्◌𑵅◌ְb; a◌゙◌्◌𑵅◌ְb; a◌゙◌्◌𑵅◌ְb; ) LATIN SMALL LETTER A, HEBREW POINT SHEVA, DEVANAGARI SIGN VIRAMA, COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK, MASARAM GONDI VIRAMA, LATIN SMALL LETTER B +0061 11D45 05B0 094D 3099 0062;0061 3099 11D45 094D 05B0 0062;0061 3099 11D45 094D 05B0 0062;0061 3099 11D45 094D 05B0 0062;0061 3099 11D45 094D 05B0 0062; # (a◌𑵅◌ְ◌्◌゙b; a◌゙◌𑵅◌्◌ְb; a◌゙◌𑵅◌्◌ְb; a◌゙◌𑵅◌्◌ְb; a◌゙◌𑵅◌्◌ְb; ) LATIN SMALL LETTER A, MASARAM GONDI VIRAMA, HEBREW POINT SHEVA, DEVANAGARI SIGN VIRAMA, COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK, LATIN SMALL LETTER B 0061 093C 0334 16AF0 0062;0061 0334 16AF0 093C 0062;0061 0334 16AF0 093C 0062;0061 0334 16AF0 093C 0062;0061 0334 16AF0 093C 0062; # (a◌़◌̴◌𖫰b; a◌̴◌𖫰◌़b; a◌̴◌𖫰◌़b; a◌̴◌𖫰◌़b; a◌̴◌𖫰◌़b; ) LATIN SMALL LETTER A, DEVANAGARI SIGN NUKTA, COMBINING TILDE OVERLAY, BASSA VAH COMBINING HIGH TONE, LATIN SMALL LETTER B 0061 16AF0 093C 0334 0062;0061 16AF0 0334 093C 0062;0061 16AF0 0334 093C 0062;0061 16AF0 0334 093C 0062;0061 16AF0 0334 093C 0062; # (a◌𖫰◌़◌̴b; a◌𖫰◌̴◌़b; a◌𖫰◌̴◌़b; a◌𖫰◌̴◌़b; a◌𖫰◌̴◌़b; ) LATIN SMALL LETTER A, BASSA VAH COMBINING HIGH TONE, DEVANAGARI SIGN NUKTA, COMBINING TILDE OVERLAY, LATIN SMALL LETTER B 0061 093C 0334 16AF1 0062;0061 0334 16AF1 093C 0062;0061 0334 16AF1 093C 0062;0061 0334 16AF1 093C 0062;0061 0334 16AF1 093C 0062; # (a◌़◌̴◌𖫱b; a◌̴◌𖫱◌़b; a◌̴◌𖫱◌़b; a◌̴◌𖫱◌़b; a◌̴◌𖫱◌़b; ) LATIN SMALL LETTER A, DEVANAGARI SIGN NUKTA, COMBINING TILDE OVERLAY, BASSA VAH COMBINING LOW TONE, LATIN SMALL LETTER B diff --git a/lib/stdlib/test/uri_string_SUITE.erl b/lib/stdlib/test/uri_string_SUITE.erl new file mode 100644 index 0000000000..92f8bb3292 --- /dev/null +++ b/lib/stdlib/test/uri_string_SUITE.erl @@ -0,0 +1,979 @@ +%% +%% %CopyrightBegin% +%% +%% 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. +%% 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(uri_string_SUITE). + +-include_lib("common_test/include/ct.hrl"). + +-export([all/0, suite/0,groups/0, + normalize/1, normalize_map/1, normalize_return_map/1, normalize_negative/1, + parse_binary_fragment/1, parse_binary_host/1, parse_binary_host_ipv4/1, + parse_binary_host_ipv6/1, + parse_binary_path/1, parse_binary_pct_encoded_fragment/1, parse_binary_pct_encoded_query/1, + parse_binary_pct_encoded_userinfo/1, parse_binary_port/1, + parse_binary_query/1, parse_binary_scheme/1, parse_binary_userinfo/1, + parse_fragment/1, parse_host/1, parse_host_ipv4/1, parse_host_ipv6/1, + parse_path/1, parse_pct_encoded_fragment/1, parse_pct_encoded_query/1, + parse_pct_encoded_userinfo/1, parse_port/1, + parse_query/1, parse_scheme/1, parse_userinfo/1, + parse_list/1, parse_binary/1, parse_mixed/1, parse_relative/1, + parse_special/1, parse_special2/1, parse_negative/1, + recompose_fragment/1, recompose_parse_fragment/1, + recompose_query/1, recompose_parse_query/1, + recompose_path/1, recompose_parse_path/1, + recompose_autogen/1, parse_recompose_autogen/1, + transcode_basic/1, transcode_options/1, transcode_mixed/1, transcode_negative/1, + compose_query/1, compose_query_latin1/1, compose_query_negative/1, + dissect_query/1, dissect_query_negative/1, + interop_query_latin1/1, interop_query_utf8/1 + ]). + + +-define(SCHEME, "foo"). +-define(USERINFO, "åsa"). +-define(USERINFO_ENC, "%C3%A5sa"). +-define(HOST, "älvsjö"). +-define(HOST_ENC, "%C3%A4lvsj%C3%B6"). +-define(IPV6, "::127.0.0.1"). +-define(IPV6_ENC, "[::127.0.0.1]"). +-define(PORT, 8042). +-define(PORT_ENC, ":8042"). +-define(PATH, "/där"). +-define(PATH_ENC, "/d%C3%A4r"). +-define(QUERY, "name=örn"). +-define(QUERY_ENC, "?name=%C3%B6rn"). +-define(FRAGMENT, "näsa"). +-define(FRAGMENT_ENC, "#n%C3%A4sa"). + + +suite() -> + [{timetrap,{minutes,1}}]. + +all() -> + [ + normalize, + normalize_map, + normalize_return_map, + normalize_negative, + parse_binary_scheme, + parse_binary_userinfo, + parse_binary_pct_encoded_userinfo, + parse_binary_host, + parse_binary_host_ipv4, + parse_binary_host_ipv6, + parse_binary_port, + parse_binary_path, + parse_binary_query, + parse_binary_pct_encoded_query, + parse_binary_fragment, + parse_binary_pct_encoded_fragment, + parse_scheme, + parse_userinfo, + parse_pct_encoded_userinfo, + parse_host, + parse_host_ipv4, + parse_host_ipv6, + parse_port, + parse_path, + parse_query, + parse_pct_encoded_query, + parse_fragment, + parse_pct_encoded_fragment, + parse_list, + parse_binary, + parse_mixed, + parse_relative, + parse_special, + parse_special2, + parse_negative, + recompose_fragment, + recompose_parse_fragment, + recompose_query, + recompose_parse_query, + recompose_path, + recompose_parse_path, + recompose_autogen, + parse_recompose_autogen, + transcode_basic, + transcode_options, + transcode_mixed, + transcode_negative, + compose_query, + compose_query_latin1, + compose_query_negative, + dissect_query, + dissect_query_negative, + interop_query_latin1, + interop_query_utf8 + ]. + +groups() -> + []. + + +%%------------------------------------------------------------------------- +%% Helper functions +%%------------------------------------------------------------------------- +uri_combinations() -> + [[Sch,Usr,Hst,Prt,Pat,Qry,Frg] || + Sch <- [fun update_scheme/1, fun update_scheme_binary/1, none], + Usr <- [fun update_userinfo/1, fun update_userinfo_binary/1, none], + Hst <- [fun update_host/1, fun update_host_binary/1, + fun update_ipv6/1, fun update_ipv6_binary/1, none], + Prt <- [fun update_port/1, none], + Pat <- [fun update_path/1, fun update_path_binary/1], + Qry <- [fun update_query/1,fun update_query_binary/1, none], + Frg <- [fun update_fragment/1, fun update_fragment_binary/1, none], + not (Usr =:= none andalso Hst =:= none andalso Prt =/= none), + not (Usr =/= none andalso Hst =:= none andalso Prt =:= none), + not (Usr =/= none andalso Hst =:= none andalso Prt =/= none)]. + + +generate_test_vector(Comb) -> + Fun = fun (F, {Map, URI}) when is_function(F) -> F({Map, URI}); + (_, Map) -> Map + end, + lists:foldl(Fun, {#{}, empty}, Comb). + +generate_test_vectors(L) -> + lists:map(fun generate_test_vector/1, L). + +update_fragment({In, empty}) -> + {In#{fragment => ?FRAGMENT}, ?FRAGMENT_ENC}; +update_fragment({In, Out}) when is_list(Out) -> + {In#{fragment => ?FRAGMENT}, Out ++ ?FRAGMENT_ENC}; +update_fragment({In, Out}) when is_binary(Out) -> + {In#{fragment => ?FRAGMENT}, binary_to_list(Out) ++ ?FRAGMENT_ENC}. + +update_fragment_binary({In, empty}) -> + {In#{fragment => <<?FRAGMENT/utf8>>}, <<?FRAGMENT_ENC>>}; +update_fragment_binary({In, Out}) when is_list(Out) -> + {In#{fragment => <<?FRAGMENT/utf8>>}, Out ++ ?FRAGMENT_ENC}; +update_fragment_binary({In, Out}) when is_binary(Out) -> + {In#{fragment => <<?FRAGMENT/utf8>>}, <<Out/binary,?FRAGMENT_ENC>>}. + + +update_query({In, empty}) -> + {In#{query => ?QUERY}, ?QUERY_ENC}; +update_query({In, Out}) when is_list(Out) -> + {In#{query => ?QUERY}, Out ++ ?QUERY_ENC}; +update_query({In, Out}) when is_binary(Out) -> + {In#{query => ?QUERY}, binary_to_list(Out) ++ ?QUERY_ENC}. + +update_query_binary({In, empty}) -> + {In#{query => <<?QUERY/utf8>>}, <<?QUERY_ENC>>}; +update_query_binary({In, Out}) when is_list(Out) -> + {In#{query => <<?QUERY/utf8>>}, Out ++ ?QUERY_ENC}; +update_query_binary({In, Out}) when is_binary(Out) -> + {In#{query => <<?QUERY/utf8>>}, <<Out/binary,?QUERY_ENC>>}. + +update_path({In, empty}) -> + {In#{path => ?PATH}, ?PATH_ENC}; +update_path({In, Out}) when is_list(Out) -> + {In#{path => ?PATH}, Out ++ ?PATH_ENC}; +update_path({In, Out}) when is_binary(Out) -> + {In#{path => ?PATH}, binary_to_list(Out) ++ ?PATH_ENC}. + +update_path_binary({In, empty}) -> + {In#{path => <<?PATH/utf8>>}, <<?PATH_ENC>>}; +update_path_binary({In, Out}) when is_list(Out) -> + {In#{path => <<?PATH/utf8>>}, Out ++ ?PATH_ENC}; +update_path_binary({In, Out}) when is_binary(Out) -> + {In#{path => <<?PATH/utf8>>}, <<Out/binary,?PATH_ENC>>}. + +update_port({In, Out}) when is_list(Out) -> + {In#{port => ?PORT}, Out ++ ?PORT_ENC}; +update_port({In, Out}) when is_binary(Out) -> + {In#{port => ?PORT}, <<Out/binary,?PORT_ENC>>}. + +update_host({In, empty}) -> + {In#{host => ?HOST}, "//" ++ ?HOST_ENC}; +update_host({In, Out}) when is_list(Out) -> + case maps:is_key(userinfo, In) of + true -> {In#{host => ?HOST}, Out ++ [$@|?HOST_ENC]}; + false -> {In#{host => ?HOST}, Out ++ [$/,$/|?HOST_ENC]} + end; +update_host({In, Out}) when is_binary(Out) -> + case maps:is_key(userinfo, In) of + true -> {In#{host => ?HOST}, binary_to_list(Out) ++ [$@|?HOST_ENC]}; + false -> {In#{host => ?HOST}, binary_to_list(Out) ++ [$/,$/|?HOST_ENC]} + end. + +update_host_binary({In, empty}) -> + {In#{host => <<?HOST/utf8>>}, <<"//",?HOST_ENC>>}; +update_host_binary({In, Out}) when is_list(Out) -> + case maps:is_key(userinfo, In) of + true -> {In#{host => <<?HOST/utf8>>}, Out ++ [$@|?HOST_ENC]}; + false -> {In#{host => <<?HOST/utf8>>}, Out ++ [$/,$/|?HOST_ENC]} + end; +update_host_binary({In, Out}) when is_binary(Out) -> + case maps:is_key(userinfo, In) of + true -> {In#{host => <<?HOST/utf8>>}, <<Out/binary,$@,?HOST_ENC>>}; + false-> {In#{host => <<?HOST/utf8>>}, <<Out/binary,"//",?HOST_ENC>>} + end. + +update_ipv6({In, empty}) -> + {In#{host => ?IPV6}, "//" ++ ?IPV6_ENC}; +update_ipv6({In, Out}) when is_list(Out) -> + case maps:is_key(userinfo, In) of + true -> {In#{host => ?IPV6}, Out ++ [$@|?IPV6_ENC]}; + false -> {In#{host => ?IPV6}, Out ++ [$/,$/|?IPV6_ENC]} + end; +update_ipv6({In, Out}) when is_binary(Out) -> + case maps:is_key(userinfo, In) of + true -> {In#{host => ?IPV6}, binary_to_list(Out) ++ [$@|?IPV6_ENC]}; + false -> {In#{host => ?IPV6}, binary_to_list(Out) ++ [$/,$/|?IPV6_ENC]} + end. + +update_ipv6_binary({In, empty}) -> + {In#{host => <<?IPV6/utf8>>}, <<"//",?IPV6_ENC>>}; +update_ipv6_binary({In, Out}) when is_list(Out) -> + case maps:is_key(userinfo, In) of + true -> {In#{host => <<?IPV6/utf8>>}, Out ++ [$@|?IPV6_ENC]}; + false -> {In#{host => <<?IPV6/utf8>>}, Out ++ [$/,$/|?IPV6_ENC]} + end; +update_ipv6_binary({In, Out}) when is_binary(Out) -> + case maps:is_key(userinfo, In) of + true -> {In#{host => <<?IPV6/utf8>>}, <<Out/binary,$@,?IPV6_ENC>>}; + false-> {In#{host => <<?IPV6/utf8>>}, <<Out/binary,"//",?IPV6_ENC>>} + end. + +update_userinfo({In, empty}) -> + {In#{userinfo => ?USERINFO}, "//" ++ ?USERINFO_ENC}; +update_userinfo({In, Out}) when is_list(Out) -> + {In#{userinfo => ?USERINFO}, Out ++ "//" ++ ?USERINFO_ENC}; +update_userinfo({In, Out}) when is_binary(Out) -> + {In#{userinfo => ?USERINFO}, binary_to_list(Out) ++ "//" ++ ?USERINFO_ENC}. + +update_userinfo_binary({In, empty}) -> + {In#{userinfo => <<?USERINFO/utf8>>}, <<"//",?USERINFO_ENC>>}; +update_userinfo_binary({In, Out}) when is_list(Out) -> + {In#{userinfo => <<?USERINFO/utf8>>}, Out ++ "//" ++ ?USERINFO_ENC}; +update_userinfo_binary({In, Out}) when is_binary(Out) -> + {In#{userinfo => <<?USERINFO/utf8>>}, <<Out/binary,"//",?USERINFO_ENC>>}. + +update_scheme({In, empty}) -> + {In#{scheme => ?SCHEME}, ?SCHEME ++ ":"}. + +update_scheme_binary({In, empty}) -> + {In#{scheme => <<?SCHEME/utf8>>}, <<?SCHEME,$:>>}. + + +%% Test recompose on a generated test vector +run_test_recompose({#{}, empty}) -> + try "" = uri_string:recompose(#{}) of + _ -> ok + catch + _:_ -> error({test_failed, #{}, ""}) + end; +run_test_recompose({Map, URI}) -> + try URI = uri_string:recompose(Map) of + URI -> ok + catch + _:_ -> error({test_failed, Map, URI}) + end. + +%% Test parse - recompose on a generated test vector +run_test_parse_recompose({#{}, empty}) -> + try "" = uri_string:recompose(uri_string:parse("")) of + _ -> ok + catch + _:_ -> error({test_failed, #{}, ""}) + end; +run_test_parse_recompose({Map, URI}) -> + try URI = uri_string:recompose(uri_string:parse(URI)) of + URI -> ok + catch + _:_ -> error({test_failed, Map, URI}) + end. + + +%%------------------------------------------------------------------------- +%% Parse tests +%%------------------------------------------------------------------------- + +parse_binary_scheme(_Config) -> + #{} = uri_string:parse(<<>>), + #{path := <<"foo">>} = uri_string:parse(<<"foo">>), + #{scheme := <<"foo">>} = uri_string:parse(<<"foo:">>), + #{scheme := <<"foo">>, path := <<"bar:nisse">>} = uri_string:parse(<<"foo:bar:nisse">>), + #{scheme := <<"foo">>, host := <<"">>} = uri_string:parse(<<"foo://">>), + #{scheme := <<"foo">>, host := <<"">>, path := <<"/">>} = uri_string:parse(<<"foo:///">>), + #{scheme := <<"foo">>, host := <<"">>, path := <<"//">>} = uri_string:parse(<<"foo:////">>), + + #{path := <<"/">>} = uri_string:parse(<<"/">>), + #{host := <<>>} = uri_string:parse(<<"//">>), + #{host := <<>>, path := <<"/">>} = uri_string:parse(<<"///">>). + +parse_binary_userinfo(_Config) -> + #{scheme := <<"user">>, path := <<"password@localhost">>} = + uri_string:parse(<<"user:password@localhost">>), + #{path := <<"user@">>} = uri_string:parse(<<"user@">>), + #{path := <<"/user@">>} = uri_string:parse(<<"/user@">>), + #{path := <<"user@localhost">>} = uri_string:parse(<<"user@localhost">>), + #{userinfo := <<"user">>, host := <<"localhost">>} = uri_string:parse(<<"//user@localhost">>), + #{userinfo := <<"user:password">>, host := <<"localhost">>} = + uri_string:parse(<<"//user:password@localhost">>), + #{scheme := <<"foo">>, path := <<"/user@">>} = + uri_string:parse(<<"foo:/user@">>), + #{scheme := <<"foo">>, userinfo := <<"user">>, host := <<"localhost">>} = + uri_string:parse(<<"foo://user@localhost">>), + #{scheme := <<"foo">>, userinfo := <<"user:password">>, host := <<"localhost">>} = + uri_string:parse(<<"foo://user:password@localhost">>). + +parse_binary_pct_encoded_userinfo(_Config) -> + #{scheme := <<"user">>, path := <<"合@気道"/utf8>>} = + uri_string:parse(<<"user:%E5%90%88@%E6%B0%97%E9%81%93">>), + #{path := <<"合気道@"/utf8>>} = uri_string:parse(<<"%E5%90%88%E6%B0%97%E9%81%93@">>), + #{path := <<"/合気道@"/utf8>>} = uri_string:parse(<<"/%E5%90%88%E6%B0%97%E9%81%93@">>), + #{path := <<"合@気道"/utf8>>} = uri_string:parse(<<"%E5%90%88@%E6%B0%97%E9%81%93">>), + #{userinfo := <<"合"/utf8>>, host := <<"気道"/utf8>>} = + uri_string:parse(<<"//%E5%90%88@%E6%B0%97%E9%81%93">>), + #{userinfo := <<"合:気"/utf8>>, host := <<"道"/utf8>>} = + uri_string:parse(<<"//%E5%90%88:%E6%B0%97@%E9%81%93">>), + #{scheme := <<"foo">>, path := <<"/合気道@"/utf8>>} = + uri_string:parse(<<"foo:/%E5%90%88%E6%B0%97%E9%81%93@">>), + #{scheme := <<"foo">>, userinfo := <<"合"/utf8>>, host := <<"気道"/utf8>>} = + uri_string:parse(<<"foo://%E5%90%88@%E6%B0%97%E9%81%93">>), + #{scheme := <<"foo">>, userinfo := <<"合:気"/utf8>>, host := <<"道"/utf8>>} = + uri_string:parse(<<"foo://%E5%90%88:%E6%B0%97@%E9%81%93">>), + {error,invalid_uri,"@"} = uri_string:parse(<<"//%E5%90%88@%E6%B0%97%E9%81%93@">>), + {error,invalid_uri,":"} = uri_string:parse(<<"foo://%E5%90%88@%E6%B0%97%E9%81%93@">>). + +parse_binary_host(_Config) -> + #{host := <<"hostname">>} = uri_string:parse(<<"//hostname">>), + #{host := <<"hostname">>,scheme := <<"foo">>} = uri_string:parse(<<"foo://hostname">>), + #{host := <<"hostname">>,scheme := <<"foo">>, userinfo := <<"user">>} = + uri_string:parse(<<"foo://user@hostname">>). + +parse_binary_host_ipv4(_Config) -> + #{host := <<"127.0.0.1">>} = uri_string:parse(<<"//127.0.0.1">>), + #{host := <<"127.0.0.1">>, path := <<"/over/there">>} = + uri_string:parse(<<"//127.0.0.1/over/there">>), + #{host := <<"127.0.0.1">>, query := <<"name=ferret">>} = + uri_string:parse(<<"//127.0.0.1?name=ferret">>), + #{host := <<"127.0.0.1">>, fragment := <<"nose">>} = uri_string:parse(<<"//127.0.0.1#nose">>), + {error,invalid_uri,"x"} = uri_string:parse(<<"//127.0.0.x">>), + {error,invalid_uri,"1227.0.0.1"} = uri_string:parse(<<"//1227.0.0.1">>). + +parse_binary_host_ipv6(_Config) -> + #{host := <<"::127.0.0.1">>} = uri_string:parse(<<"//[::127.0.0.1]">>), + #{host := <<"2001:0db8:0000:0000:0000:0000:1428:07ab">>} = + uri_string:parse(<<"//[2001:0db8:0000:0000:0000:0000:1428:07ab]">>), + #{host := <<"::127.0.0.1">>, path := <<"/over/there">>} = + uri_string:parse(<<"//[::127.0.0.1]/over/there">>), + #{host := <<"::127.0.0.1">>, query := <<"name=ferret">>} = + uri_string:parse(<<"//[::127.0.0.1]?name=ferret">>), + #{host := <<"::127.0.0.1">>, fragment := <<"nose">>} = + uri_string:parse(<<"//[::127.0.0.1]#nose">>), + {error,invalid_uri,"x"} = uri_string:parse(<<"//[::127.0.0.x]">>), + {error,invalid_uri,"::1227.0.0.1"} = uri_string:parse(<<"//[::1227.0.0.1]">>), + {error,invalid_uri,"G"} = uri_string:parse(<<"//[2001:0db8:0000:0000:0000:0000:1428:G7ab]">>). + +parse_binary_port(_Config) -> + #{path:= <<"/:8042">>} = + uri_string:parse(<<"/:8042">>), + #{host:= <<>>, port := 8042} = + uri_string:parse(<<"//:8042">>), + #{host := <<"example.com">>, port:= 8042} = + uri_string:parse(<<"//example.com:8042">>), + #{scheme := <<"foo">>, path := <<"/:8042">>} = + uri_string:parse(<<"foo:/:8042">>), + #{scheme := <<"foo">>, host := <<>>, port := 8042} = + uri_string:parse(<<"foo://:8042">>), + #{scheme := <<"foo">>, host := <<"example.com">>, port := 8042} = + uri_string:parse(<<"foo://example.com:8042">>), + {error,invalid_uri,":"} = uri_string:parse(":600"), + {error,invalid_uri,"x"} = uri_string:parse("//:8042x"). + +parse_binary_path(_Config) -> + #{path := <<"over/there">>} = uri_string:parse(<<"over/there">>), + #{path := <<"/over/there">>} = uri_string:parse(<<"/over/there">>), + #{scheme := <<"foo">>, path := <<"/over/there">>} = + uri_string:parse(<<"foo:/over/there">>), + #{scheme := <<"foo">>, host := <<"example.com">>, path := <<"/over/there">>} = + uri_string:parse(<<"foo://example.com/over/there">>), + #{scheme := <<"foo">>, host := <<"example.com">>, path := <<"/over/there">>, port := 8042} = + uri_string:parse(<<"foo://example.com:8042/over/there">>). + +parse_binary_query(_Config) -> + #{scheme := <<"foo">>, query := <<"name=ferret">>} = + uri_string:parse(<<"foo:?name=ferret">>), + #{scheme := <<"foo">>, path:= <<"over/there">>, query := <<"name=ferret">>} = + uri_string:parse(<<"foo:over/there?name=ferret">>), + #{scheme := <<"foo">>, path:= <<"/over/there">>, query := <<"name=ferret">>} = + uri_string:parse(<<"foo:/over/there?name=ferret">>), + #{scheme := <<"foo">>, host := <<"example.com">>, query := <<"name=ferret">>} = + uri_string:parse(<<"foo://example.com?name=ferret">>), + #{scheme := <<"foo">>, host := <<"example.com">>, path := <<"/">>, query := <<"name=ferret">>} = + uri_string:parse(<<"foo://example.com/?name=ferret">>), + + #{path := <<>>, query := <<"name=ferret">>} = + uri_string:parse(<<"?name=ferret">>), + #{path := <<"over/there">>, query := <<"name=ferret">>} = + uri_string:parse(<<"over/there?name=ferret">>), + #{path := <<"/">>, query := <<"name=ferret">>} = + uri_string:parse(<<"/?name=ferret">>), + #{path := <<"/over/there">>, query := <<"name=ferret">>} = + uri_string:parse(<<"/over/there?name=ferret">>), + #{host := <<"example.com">>, query := <<"name=ferret">>} = + uri_string:parse(<<"//example.com?name=ferret">>), + #{host := <<"example.com">>, path := <<"/">>, query := <<"name=ferret">>} = + uri_string:parse(<<"//example.com/?name=ferret">>). + +parse_binary_pct_encoded_query(_Config) -> + #{scheme := <<"foo">>, host := <<"example.com">>, path := <<"/">>, + query := <<"name=合気道"/utf8>>} = + uri_string:parse(<<"foo://example.com/?name=%E5%90%88%E6%B0%97%E9%81%93">>), + #{host := <<"example.com">>, path := <<"/">>, query := <<"name=合気道"/utf8>>} = + uri_string:parse(<<"//example.com/?name=%E5%90%88%E6%B0%97%E9%81%93">>). + +parse_binary_fragment(_Config) -> + #{scheme := <<"foo">>, fragment := <<"nose">>} = + uri_string:parse(<<"foo:#nose">>), + #{scheme := <<"foo">>, path:= <<"over/there">>, fragment := <<"nose">>} = + uri_string:parse(<<"foo:over/there#nose">>), + #{scheme := <<"foo">>, path:= <<"/over/there">>, fragment := <<"nose">>} = + uri_string:parse(<<"foo:/over/there#nose">>), + #{scheme := <<"foo">>, host := <<"example.com">>, fragment := <<"nose">>} = + uri_string:parse(<<"foo://example.com#nose">>), + #{scheme := <<"foo">>, host := <<"example.com">>, path := <<"/">>, fragment := <<"nose">>} = + uri_string:parse(<<"foo://example.com/#nose">>), + #{scheme := <<"foo">>, host := <<"example.com">>, fragment := <<"nose">>} = + uri_string:parse(<<"foo://example.com#nose">>), + + #{fragment := <<"nose">>} = + uri_string:parse(<<"#nose">>), + #{path := <<"over/there">>, fragment := <<"nose">>} = + uri_string:parse(<<"over/there#nose">>), + #{path := <<"/">>, fragment := <<"nose">>} = + uri_string:parse(<<"/#nose">>), + #{path := <<"/over/there">>, fragment := <<"nose">>} = + uri_string:parse(<<"/over/there#nose">>), + #{host := <<"example.com">>, fragment := <<"nose">>} = + uri_string:parse(<<"//example.com#nose">>), + #{host := <<"example.com">>, path := <<"/">>, fragment := <<"nose">>} = + uri_string:parse(<<"//example.com/#nose">>). + +parse_binary_pct_encoded_fragment(_Config) -> + #{scheme := <<"foo">>, host := <<"example.com">>, fragment := <<"合気道"/utf8>>} = + uri_string:parse(<<"foo://example.com#%E5%90%88%E6%B0%97%E9%81%93">>), + #{host := <<"example.com">>, path := <<"/">>, fragment := <<"合気道"/utf8>>} = + uri_string:parse(<<"//example.com/#%E5%90%88%E6%B0%97%E9%81%93">>). + +parse_scheme(_Config) -> + #{} = uri_string:parse(""), + #{path := "foo"} = uri_string:parse("foo"), + #{scheme := "foo"} = uri_string:parse("foo:"), + #{scheme := "foo", path := "bar:nisse"} = uri_string:parse("foo:bar:nisse"), + #{scheme := "foo", host := ""} = uri_string:parse("foo://"), + #{scheme := "foo", host := "", path := "/"} = uri_string:parse("foo:///"), + #{scheme := "foo", host := "", path := "//"} = uri_string:parse("foo:////"), + + #{path := "/"} = uri_string:parse("/"), + #{host := ""} = uri_string:parse("//"), + #{host := "", path := "/"} = uri_string:parse("///"). + +parse_userinfo(_Config) -> + #{scheme := "user", path := "password@localhost"} = uri_string:parse("user:password@localhost"), + #{path := "user@"} = uri_string:parse("user@"), + #{path := "/user@"} = uri_string:parse("/user@"), + #{path := "user@localhost"} = uri_string:parse("user@localhost"), + #{userinfo := "user", host := "localhost"} = uri_string:parse("//user@localhost"), + #{userinfo := "user:password", host := "localhost"} = + uri_string:parse("//user:password@localhost"), + #{scheme := "foo", path := "/user@"} = + uri_string:parse("foo:/user@"), + #{scheme := "foo", userinfo := "user", host := "localhost"} = + uri_string:parse("foo://user@localhost"), + #{scheme := "foo", userinfo := "user:password", host := "localhost"} = + uri_string:parse("foo://user:password@localhost"). + +parse_pct_encoded_userinfo(_Config) -> + #{scheme := "user", path := "合@気道"} = + uri_string:parse("user:%E5%90%88@%E6%B0%97%E9%81%93"), + #{path := "合気道@"} = uri_string:parse("%E5%90%88%E6%B0%97%E9%81%93@"), + #{path := "/合気道@"} = uri_string:parse("/%E5%90%88%E6%B0%97%E9%81%93@"), + #{path := "合@気道"} = uri_string:parse("%E5%90%88@%E6%B0%97%E9%81%93"), + #{userinfo := "合", host := "気道"} = + uri_string:parse("//%E5%90%88@%E6%B0%97%E9%81%93"), + #{userinfo := "合:気", host := "道"} = + uri_string:parse("//%E5%90%88:%E6%B0%97@%E9%81%93"), + #{scheme := "foo", path := "/合気道@"} = + uri_string:parse("foo:/%E5%90%88%E6%B0%97%E9%81%93@"), + #{scheme := "foo", userinfo := "合", host := "気道"} = + uri_string:parse("foo://%E5%90%88@%E6%B0%97%E9%81%93"), + #{scheme := "foo", userinfo := "合:気", host := "道"} = + uri_string:parse("foo://%E5%90%88:%E6%B0%97@%E9%81%93"), + {error,invalid_uri,"@"} = uri_string:parse("//%E5%90%88@%E6%B0%97%E9%81%93@"), + {error,invalid_uri,":"} = uri_string:parse("foo://%E5%90%88@%E6%B0%97%E9%81%93@"). + + +parse_host(_Config) -> + #{host := "hostname"} = uri_string:parse("//hostname"), + #{host := "hostname",scheme := "foo"} = uri_string:parse("foo://hostname"), + #{host := "hostname",scheme := "foo", userinfo := "user"} = + uri_string:parse("foo://user@hostname"). + +parse_host_ipv4(_Config) -> + #{host := "127.0.0.1"} = uri_string:parse("//127.0.0.1"), + #{host := "2001:0db8:0000:0000:0000:0000:1428:07ab"} = + uri_string:parse("//[2001:0db8:0000:0000:0000:0000:1428:07ab]"), + #{host := "127.0.0.1", path := "/over/there"} = uri_string:parse("//127.0.0.1/over/there"), + #{host := "127.0.0.1", query := "name=ferret"} = uri_string:parse("//127.0.0.1?name=ferret"), + #{host := "127.0.0.1", fragment := "nose"} = uri_string:parse("//127.0.0.1#nose"), + {error,invalid_uri,"x"} = uri_string:parse("//127.0.0.x"), + {error,invalid_uri,"1227.0.0.1"} = uri_string:parse("//1227.0.0.1"). + +parse_host_ipv6(_Config) -> + #{host := "::127.0.0.1"} = uri_string:parse("//[::127.0.0.1]"), + #{host := "::127.0.0.1", path := "/over/there"} = uri_string:parse("//[::127.0.0.1]/over/there"), + #{host := "::127.0.0.1", query := "name=ferret"} = + uri_string:parse("//[::127.0.0.1]?name=ferret"), + #{host := "::127.0.0.1", fragment := "nose"} = uri_string:parse("//[::127.0.0.1]#nose"), + {error,invalid_uri,"x"} = uri_string:parse("//[::127.0.0.x]"), + {error,invalid_uri,"::1227.0.0.1"} = uri_string:parse("//[::1227.0.0.1]"), + {error,invalid_uri,"G"} = uri_string:parse("//[2001:0db8:0000:0000:0000:0000:1428:G7ab]"). + +parse_port(_Config) -> + #{path:= "/:8042"} = + uri_string:parse("/:8042"), + #{host:= "", port := 8042} = + uri_string:parse("//:8042"), + #{host := "example.com", port:= 8042} = + uri_string:parse("//example.com:8042"), + #{scheme := "foo", path := "/:8042"} = + uri_string:parse("foo:/:8042"), + #{scheme := "foo", host := "", port := 8042} = + uri_string:parse("foo://:8042"), + #{scheme := "foo", host := "example.com", port := 8042} = + uri_string:parse("foo://example.com:8042"). + +parse_path(_Config) -> + #{path := "over/there"} = uri_string:parse("over/there"), + #{path := "/over/there"} = uri_string:parse("/over/there"), + #{scheme := "foo", path := "/over/there"} = + uri_string:parse("foo:/over/there"), + #{scheme := "foo", host := "example.com", path := "/over/there"} = + uri_string:parse("foo://example.com/over/there"), + #{scheme := "foo", host := "example.com", path := "/over/there", port := 8042} = + uri_string:parse("foo://example.com:8042/over/there"). + +parse_query(_Config) -> + #{scheme := "foo", query := "name=ferret"} = + uri_string:parse("foo:?name=ferret"), + #{scheme := "foo", path:= "over/there", query := "name=ferret"} = + uri_string:parse("foo:over/there?name=ferret"), + #{scheme := "foo", path:= "/over/there", query := "name=ferret"} = + uri_string:parse("foo:/over/there?name=ferret"), + #{scheme := "foo", host := "example.com", query := "name=ferret"} = + uri_string:parse("foo://example.com?name=ferret"), + #{scheme := "foo", host := "example.com", path := "/", query := "name=ferret"} = + uri_string:parse("foo://example.com/?name=ferret"), + + #{path := "", query := "name=ferret"} = + uri_string:parse("?name=ferret"), + #{path := "over/there", query := "name=ferret"} = + uri_string:parse("over/there?name=ferret"), + #{path := "/", query := "name=ferret"} = + uri_string:parse("/?name=ferret"), + #{path := "/over/there", query := "name=ferret"} = + uri_string:parse("/over/there?name=ferret"), + #{host := "example.com", query := "name=ferret"} = + uri_string:parse("//example.com?name=ferret"), + #{host := "example.com", path := "/", query := "name=ferret"} = + uri_string:parse("//example.com/?name=ferret"). + +parse_pct_encoded_query(_Config) -> + #{scheme := "foo", host := "example.com", path := "/", + query := "name=合気道"} = + uri_string:parse("foo://example.com/?name=%E5%90%88%E6%B0%97%E9%81%93"), + #{host := "example.com", path := "/", query := "name=合気道"} = + uri_string:parse("//example.com/?name=%E5%90%88%E6%B0%97%E9%81%93"). + +parse_fragment(_Config) -> + #{scheme := "foo", fragment := "nose"} = + uri_string:parse("foo:#nose"), + #{scheme := "foo", path:= "over/there", fragment := "nose"} = + uri_string:parse("foo:over/there#nose"), + #{scheme := "foo", path:= "/over/there", fragment := "nose"} = + uri_string:parse("foo:/over/there#nose"), + #{scheme := "foo", host := "example.com", fragment := "nose"} = + uri_string:parse("foo://example.com#nose"), + #{scheme := "foo", host := "example.com", path := "/", fragment := "nose"} = + uri_string:parse("foo://example.com/#nose"), + #{scheme := "foo", host := "example.com", fragment := "nose"} = + uri_string:parse("foo://example.com#nose"), + + #{fragment := "nose"} = + uri_string:parse("#nose"), + #{path := "over/there", fragment := "nose"} = + uri_string:parse("over/there#nose"), + #{path := "/", fragment := "nose"} = + uri_string:parse("/#nose"), + #{path := "/over/there", fragment := "nose"} = + uri_string:parse("/over/there#nose"), + #{host := "example.com", fragment := "nose"} = + uri_string:parse("//example.com#nose"), + #{host := "example.com", path := "/", fragment := "nose"} = + uri_string:parse("//example.com/#nose"). + +parse_pct_encoded_fragment(_Config) -> + #{scheme := "foo", host := "example.com", fragment := "合気道"} = + uri_string:parse("foo://example.com#%E5%90%88%E6%B0%97%E9%81%93"), + #{host := "example.com", path := "/", fragment := "合気道"} = + uri_string:parse("//example.com/#%E5%90%88%E6%B0%97%E9%81%93"). + +parse_list(_Config) -> + #{scheme := "foo", path := "bar:nisse"} = uri_string:parse("foo:bar:nisse"), + #{scheme := "foo", host := "example.com", port := 8042, + path := "/over/there", query := "name=ferret", fragment := "nose"} = + uri_string:parse("foo://example.com:8042/over/there?name=ferret#nose"), + #{scheme := "foo", userinfo := "admin:admin", host := "example.com", port := 8042, + path := "/over/there", query := "name=ferret", fragment := "nose"} = + uri_string:parse("foo://admin:[email protected]:8042/over/there?name=ferret#nose"). + +parse_binary(_Config) -> + #{scheme := <<"foo">>, path := <<"bar:nisse">>} = uri_string:parse(<<"foo:bar:nisse">>), + #{scheme := <<"foo">>, host := <<"example.com">>, port := 8042, + path := <<"/over/there">>, query := <<"name=ferret">>, fragment := <<"nose">>} = + uri_string:parse(<<"foo://example.com:8042/over/there?name=ferret#nose">>), + #{scheme := <<"foo">>, userinfo := <<"admin:admin">>, host := <<"example.com">>, port := 8042, + path := <<"/over/there">>, query := <<"name=ferret">>, fragment := <<"nose">>} = + uri_string:parse(<<"foo://admin:[email protected]:8042/over/there?name=ferret#nose">>). + + +parse_mixed(_Config) -> + #{scheme := "foo", path := "bar"} = + uri_string:parse(lists:append("fo",<<"o:bar">>)), + #{scheme := "foo", path := "bar"} = + uri_string:parse(lists:append("foo:b",<<"ar">>)), + #{scheme := "foo", path := "bar:bar"} = + uri_string:parse([[102],[111,111],<<":bar">>,58,98,97,114]). + +parse_relative(_Config) -> + #{path := "/path"} = + uri_string:parse(lists:append("/pa",<<"th">>)), + #{path := "foo"} = + uri_string:parse(lists:append("fo",<<"o">>)). + +parse_special(_Config) -> + #{host := [],query := []} = uri_string:parse("//?"), + #{fragment := [],host := []} = uri_string:parse("//#"), + #{host := [],query := [],scheme := "foo"} = uri_string:parse("foo://?"), + #{fragment := [],host := [],scheme := "foo"} = uri_string:parse("foo://#"), + #{host := <<>>, path := <<"/">>} = uri_string:parse(<<"///">>), + #{host := <<"hostname">>} = uri_string:parse(<<"//hostname">>), + #{host := <<>>, path := <<"/hostname">>} = uri_string:parse(<<"///hostname">>), + #{host := [],path := "/",query := []} = uri_string:parse("///?"), + #{fragment := [],host := [],path := "/"} = uri_string:parse("///#"), + #{host := "foo",query := []} = uri_string:parse("//foo?"), + #{fragment := [],host := "foo"} = uri_string:parse("//foo#"), + #{host := "foo",path := "/"} = uri_string:parse("//foo/"), + #{host := "foo",query := [],scheme := "http"} = uri_string:parse("http://foo?"), + #{fragment := [],host := "foo",scheme := "http"} = uri_string:parse("http://foo#"), + #{host := "foo",path := "/",scheme := "http"} = uri_string:parse("http://foo/"), + #{fragment := [],host := "host",port := 80,scheme := "http"} = uri_string:parse("http://host:80#"), + #{host := "host",port := 80,query := [],scheme := "http"} = uri_string:parse("http://host:80?"), + #{path := [],query := []} = uri_string:parse("?"), + #{path := [],query := "?"} = uri_string:parse("??"), + #{path := [],query := "??"} = uri_string:parse("???"). + +parse_special2(_Config) -> + #{host := [],path := "/",port := 1,scheme := "a"} = uri_string:parse("a://:1/"), + #{path := "/a/",scheme := "a"} = uri_string:parse("a:/a/"), + #{host := [],path := [],userinfo := []} = uri_string:parse("//@"), + #{host := [],path := [],scheme := "foo",userinfo := []} = uri_string:parse("foo://@"), + #{host := [],path := "/",userinfo := []} = uri_string:parse("//@/"), + #{host := [],path := "/",scheme := "foo",userinfo := []} = uri_string:parse("foo://@/"), + #{host := "localhost",path := "/",port := undefined} = uri_string:parse("//localhost:/"), + #{host := [],path := [],port := undefined} = uri_string:parse("//:"). + +parse_negative(_Config) -> + {error,invalid_uri,"å"} = uri_string:parse("å"), + {error,invalid_uri,"å"} = uri_string:parse("aå:/foo"), + {error,invalid_uri,":"} = uri_string:parse("foo://usär@host"), + {error,invalid_uri,"ö"} = uri_string:parse("//host/path?foö=bar"), + {error,invalid_uri,"ö"} = uri_string:parse("//host/path#foö"), + {error,invalid_uri,"127.256.0.1"} = uri_string:parse("//127.256.0.1"), + {error,invalid_uri,":::127.0.0.1"} = uri_string:parse("//[:::127.0.0.1]"), + {error,invalid_utf8,<<0,0,0,246>>} = uri_string:parse("//%00%00%00%F6"), + {error,invalid_uri,"A"} = uri_string:parse("//localhost:A8"). + + +%%------------------------------------------------------------------------- +%% Recompose tests +%%------------------------------------------------------------------------- +recompose_fragment(_Config) -> + <<?FRAGMENT_ENC>> = uri_string:recompose(#{fragment => <<?FRAGMENT/utf8>>, path => <<>>}), + ?FRAGMENT_ENC = uri_string:recompose(#{fragment => ?FRAGMENT, path => ""}). + +recompose_parse_fragment(_Config) -> + <<?FRAGMENT_ENC>> = uri_string:recompose(uri_string:parse(<<?FRAGMENT_ENC>>)), + ?FRAGMENT_ENC = uri_string:recompose(uri_string:parse(?FRAGMENT_ENC)). + +recompose_query(_Config) -> + <<?QUERY_ENC>> = + uri_string:recompose(#{query => <<?QUERY/utf8>>, path => <<>>}), + <<?QUERY_ENC?FRAGMENT_ENC>> = + uri_string:recompose(#{query => <<?QUERY/utf8>>, + fragment => <<?FRAGMENT/utf8>>, + path => <<>>}), + "?name=%C3%B6rn" = + uri_string:recompose(#{query => "name=örn", path => ""}), + "?name=%C3%B6rn#n%C3%A4sa" = + uri_string:recompose(#{query => "name=örn", + fragment => "näsa", + path => ""}). + +recompose_parse_query(_Config) -> + <<"?name=%C3%B6rn">> = uri_string:recompose(uri_string:parse(<<"?name=%C3%B6rn">>)), + <<"?name=%C3%B6rn#n%C3%A4sa">> = + uri_string:recompose(uri_string:parse(<<"?name=%C3%B6rn#n%C3%A4sa">>)), + "?name=%C3%B6rn" = uri_string:recompose(uri_string:parse("?name=%C3%B6rn")), + "?name=%C3%B6rn#n%C3%A4sa" = uri_string:recompose(uri_string:parse("?name=%C3%B6rn#n%C3%A4sa")). + +recompose_path(_Config) -> + <<"/d%C3%A4r">> = + uri_string:recompose(#{path => <<"/där"/utf8>>}), + <<"/d%C3%A4r#n%C3%A4sa">> = + uri_string:recompose(#{path => <<"/där"/utf8>>, + fragment => <<"näsa"/utf8>>}), + <<"/d%C3%A4r?name=%C3%B6rn">> = + uri_string:recompose(#{path => <<"/där"/utf8>>, + query => <<"name=örn"/utf8>>}), + <<"/d%C3%A4r?name=%C3%B6rn#n%C3%A4sa">> = + uri_string:recompose(#{path => <<"/där"/utf8>>, + query => <<"name=örn"/utf8>>, + fragment => <<"näsa"/utf8>>}), + + + "/d%C3%A4r" = + uri_string:recompose(#{path => "/där"}), + "/d%C3%A4r#n%C3%A4sa" = + uri_string:recompose(#{path => "/där", + fragment => "näsa"}), + "/d%C3%A4r?name=%C3%B6rn" = + uri_string:recompose(#{path => "/där", + query => "name=örn"}), + "/d%C3%A4r?name=%C3%B6rn#n%C3%A4sa" = + uri_string:recompose(#{path => "/där", + query => "name=örn", + fragment => "näsa"}). + + +recompose_parse_path(_Config) -> + <<"/d%C3%A4r">> = + uri_string:recompose(uri_string:parse(<<"/d%C3%A4r">>)), + <<"/d%C3%A4r#n%C3%A4sa">> = + uri_string:recompose(uri_string:parse(<<"/d%C3%A4r#n%C3%A4sa">>)), + <<"/d%C3%A4r?name=%C3%B6rn">> = + uri_string:recompose(uri_string:parse(<<"/d%C3%A4r?name=%C3%B6rn">>)), + + "/d%C3%A4r" = + uri_string:recompose(uri_string:parse("/d%C3%A4r")), + "/d%C3%A4r#n%C3%A4sa" = + uri_string:recompose(uri_string:parse("/d%C3%A4r#n%C3%A4sa")), + "/d%C3%A4r?name=%C3%B6rn" = + uri_string:recompose(uri_string:parse("/d%C3%A4r?name=%C3%B6rn")). + + +recompose_autogen(_Config) -> + Tests = generate_test_vectors(uri_combinations()), + lists:map(fun run_test_recompose/1, Tests). + +parse_recompose_autogen(_Config) -> + Tests = generate_test_vectors(uri_combinations()), + lists:map(fun run_test_parse_recompose/1, Tests). + +transcode_basic(_Config) -> + <<"foo%C3%B6bar"/utf8>> = + uri_string:transcode(<<"foo%00%00%00%F6bar"/utf32>>, [{in_encoding, utf32},{out_encoding, utf8}]), + "foo%C3%B6bar" = + uri_string:transcode("foo%00%00%00%F6bar", [{in_encoding, utf32},{out_encoding, utf8}]), + <<"foo%00%00%00%F6bar"/utf32>> = + uri_string:transcode(<<"foo%C3%B6bar"/utf8>>, [{in_encoding, utf8},{out_encoding, utf32}]), + "foo%00%00%00%F6bar" = + uri_string:transcode("foo%C3%B6bar", [{in_encoding, utf8},{out_encoding, utf32}]), + "foo%C3%B6bar" = + uri_string:transcode("foo%F6bar", [{in_encoding, latin1},{out_encoding, utf8}]). + +transcode_options(_Config) -> + <<"foo%C3%B6bar"/utf8>> = + uri_string:transcode(<<"foo%C3%B6bar"/utf8>>, []), + <<"foo%C3%B6bar"/utf8>> = + uri_string:transcode(<<"foo%00%00%00%F6bar"/utf32>>, [{in_encoding, utf32}]), + <<"foo%00%00%00%F6bar"/utf32>> = + uri_string:transcode(<<"foo%C3%B6bar"/utf8>>, [{out_encoding, utf32}]). + +transcode_mixed(_Config) -> + "foo%00%00%00%F6bar" = + uri_string:transcode(["foo",<<"%C3%B6"/utf8>>,<<"ba"/utf8>>,"r"], [{out_encoding, utf32}]), + "foo%00%00%00%F6bar" = + uri_string:transcode(["foo",<<"%C3%"/utf8>>,<<"B6ba"/utf8>>,"r"], [{out_encoding, utf32}]), + "foo%C3%B6bar" = + uri_string:transcode(["foo%00", <<"%00%0"/utf32>>,<<"0%F"/utf32>>,"6bar"], [{in_encoding, utf32},{out_encoding, utf8}]). + +transcode_negative(_Config) -> + {error,invalid_percent_encoding,"%BXbar"} = + uri_string:transcode(<<"foo%C3%BXbar"/utf8>>, [{in_encoding, utf8},{out_encoding, utf32}]), + {error,invalid_input,<<"ö">>} = + uri_string:transcode("foo%F6bar", [{in_encoding, utf8},{out_encoding, utf8}]). + +compose_query(_Config) -> + [] = uri_string:compose_query([]), + "foo=1&bar=2" = uri_string:compose_query([{<<"foo">>,"1"}, {"bar", "2"}]), + "foo=1&b%C3%A4r=2" = uri_string:compose_query([{"foo","1"}, {"bär", "2"}],[{encoding,utf8}]), + "foo=1&b%C3%A4r=2" = uri_string:compose_query([{"foo","1"}, {"bär", "2"}],[{encoding,unicode}]), + "foo=1&b%E4r=2" = uri_string:compose_query([{"foo","1"}, {"bär", "2"}],[{encoding,latin1}]), + "foo+bar=1&%E5%90%88=2" = uri_string:compose_query([{"foo bar","1"}, {"合", "2"}]), + "foo+bar=1&%26%2321512%3B=2" = + uri_string:compose_query([{"foo bar","1"}, {"合", "2"}],[{encoding,latin1}]), + "foo+bar=1&%C3%B6=2" = uri_string:compose_query([{<<"foo bar">>,<<"1">>}, {"ö", <<"2">>}]), + <<"foo+bar=1&%C3%B6=2">> = + uri_string:compose_query([{<<"foo bar">>,<<"1">>}, {<<"ö"/utf8>>, <<"2">>}]). + +compose_query_latin1(_Config) -> + Q = uri_string:compose_query([{"合foö bar","1"}, {"合", "合"}],[{encoding,latin1}]), + Q1 = uri_string:transcode(Q, [{in_encoding, latin1}]), + [{"合foö bar","1"}, {"合", "合"}] = uri_string:dissect_query(Q1), + Q2 = uri_string:compose_query([{<<"合foö bar"/utf8>>,<<"1">>}, {<<"合"/utf8>>, <<"合"/utf8>>}], + [{encoding,latin1}]), + Q3 = uri_string:transcode(Q2, [{in_encoding, latin1}]), + [{<<"合foö bar"/utf8>>,<<"1">>}, {<<"合"/utf8>>, <<"合"/utf8>>}] = + uri_string:dissect_query(Q3). + +compose_query_negative(_Config) -> + {error,invalid_input,4} = uri_string:compose_query([{"",4}]), + {error,invalid_input,5} = uri_string:compose_query([{5,""}]), + {error,invalid_encoding,utf16} = + uri_string:compose_query([{"foo bar","1"}, {<<"ö">>, "2"}],[{encoding,utf16}]). + +dissect_query(_Config) -> + [] = uri_string:dissect_query(""), + [{"foo","1"}, {"amp;bar", "2"}] = uri_string:dissect_query("foo=1&bar=2"), + [{"foo","1"}, {"bar", "2"}] = uri_string:dissect_query("foo=1&bar=2"), + [{"foo","1;bar=2"}] = uri_string:dissect_query("foo=1;bar=2"), + [{"foo","1"}, {"bar", "222"}] = uri_string:dissect_query([<<"foo=1&bar=2">>,"22"]), + [{"foo","ö"}, {"bar", "2"}] = uri_string:dissect_query("foo=%C3%B6&bar=2"), + [{<<"foo">>,<<"ö"/utf8>>}, {<<"bar">>, <<"2">>}] = + uri_string:dissect_query(<<"foo=%C3%B6&bar=2">>), + [{"foo bar","1"},{"ö","2"}] = + uri_string:dissect_query([<<"foo+bar=1&">>,<<"%C3%B6=2">>]), + [{"foo bar","1"},{[21512],"2"}] = + uri_string:dissect_query("foo+bar=1&%26%2321512%3B=2"), + [{<<"foo bar">>,<<"1">>},{<<"合"/utf8>>,<<"2">>}] = + uri_string:dissect_query(<<"foo+bar=1&%26%2321512%3B=2">>), + [{"föo bar","1"},{"ö","2"}] = + uri_string:dissect_query("föo+bar=1&%C3%B6=2"), + [{<<"föo bar"/utf8>>,<<"1">>},{<<"ö"/utf8>>,<<"2">>}] = + uri_string:dissect_query(<<"föo+bar=1&%C3%B6=2"/utf8>>). + +dissect_query_negative(_Config) -> + {error,missing_value,"&"} = + uri_string:dissect_query("foo1&bar=2"), + {error,invalid_percent_encoding,"%XX%B6"} = uri_string:dissect_query("foo=%XX%B6&bar=2"), + {error,invalid_input,[153]} = + uri_string:dissect_query("foo=%99%B6&bar=2"), + {error,invalid_character,"ö"} = uri_string:dissect_query(<<"föo+bar=1&%C3%B6=2">>), + {error,invalid_input,<<"ö">>} = + uri_string:dissect_query([<<"foo+bar=1&">>,<<"%C3%B6=2ö">>]). + +normalize(_Config) -> + "/a/g" = uri_string:normalize("/a/b/c/./../../g"), + <<"mid/6">> = uri_string:normalize(<<"mid/content=5/../6">>), + "http://localhost-%C3%B6rebro/a/g" = + uri_string:normalize("http://localhos%74-%c3%b6rebro:80/a/b/c/./../../g"), + <<"http://localhost-%C3%B6rebro/a/g">> = + uri_string:normalize(<<"http://localhos%74-%c3%b6rebro:80/a/b/c/./../../g">>), + <<"https://localhost/">> = + uri_string:normalize(<<"https://localhost:443">>), + <<"https://localhost:445/">> = + uri_string:normalize(<<"https://localhost:445">>), + <<"ftp://localhost">> = + uri_string:normalize(<<"ftp://localhost:21">>), + <<"ssh://localhost">> = + uri_string:normalize(<<"ssh://localhost:22">>), + <<"sftp://localhost">> = + uri_string:normalize(<<"sftp://localhost:22">>), + <<"tftp://localhost">> = + uri_string:normalize(<<"tftp://localhost:69">>). + +normalize_map(_Config) -> + "/a/g" = uri_string:normalize(#{path => "/a/b/c/./../../g"}), + <<"mid/6">> = uri_string:normalize(#{path => <<"mid/content=5/../6">>}), + "http://localhost-%C3%B6rebro/a/g" = + uri_string:normalize(#{scheme => "http",port => 80,path => "/a/b/c/./../../g", + host => "localhost-örebro"}), + <<"http://localhost-%C3%B6rebro/a/g">> = + uri_string:normalize(#{scheme => <<"http">>,port => 80, + path => <<"/a/b/c/./../../g">>, + host => <<"localhost-örebro"/utf8>>}), + <<"https://localhost/">> = + uri_string:normalize(#{scheme => <<"https">>,port => 443,path => <<>>, + host => <<"localhost">>}), + <<"https://localhost:445/">> = + uri_string:normalize(#{scheme => <<"https">>,port => 445,path => <<>>, + host => <<"localhost">>}), + <<"ftp://localhost">> = + uri_string:normalize(#{scheme => <<"ftp">>,port => 21,path => <<>>, + host => <<"localhost">>}), + <<"ssh://localhost">> = + uri_string:normalize(#{scheme => <<"ssh">>,port => 22,path => <<>>, + host => <<"localhost">>}), + <<"sftp://localhost">> = + uri_string:normalize(#{scheme => <<"sftp">>,port => 22,path => <<>>, + host => <<"localhost">>}), + <<"tftp://localhost">> = + uri_string:normalize(#{scheme => <<"tftp">>,port => 69,path => <<>>, + host => <<"localhost">>}). + +normalize_return_map(_Config) -> + #{scheme := "http",path := "/a/g",host := "localhost-örebro"} = + uri_string:normalize("http://localhos%74-%c3%b6rebro:80/a/b/c/./../../g", + [return_map]), + #{scheme := <<"http">>,path := <<"/a/g">>, host := <<"localhost-örebro"/utf8>>} = + uri_string:normalize(<<"http://localhos%74-%c3%b6rebro:80/a/b/c/./../../g">>, + [return_map]), + #{scheme := <<"https">>,path := <<"/">>, host := <<"localhost">>} = + uri_string:normalize(#{scheme => <<"https">>,port => 443,path => <<>>, + host => <<"localhost">>}, [return_map]). + +normalize_negative(_Config) -> + {error,invalid_uri,":"} = + uri_string:normalize("http://local>host"), + {error,invalid_uri,":"} = + uri_string:normalize(<<"http://local>host">>), + {error,invalid_uri,":"} = + uri_string:normalize("http://[192.168.0.1]", [return_map]), + {error,invalid_uri,":"} = + uri_string:normalize(<<"http://[192.168.0.1]">>, [return_map]). + +interop_query_utf8(_Config) -> + Q = uri_string:compose_query([{"foo bar","1"}, {"合", "2"}]), + Uri = uri_string:recompose(#{path => "/", query => Q}), + #{query := Q1} = uri_string:parse(Uri), + [{"foo bar","1"}, {"合", "2"}] = uri_string:dissect_query(Q1). + +interop_query_latin1(_Config) -> + Q = uri_string:compose_query([{"foo bar","1"}, {"合", "2"}], [{encoding,latin1}]), + Uri = uri_string:recompose(#{path => "/", query => Q}), + Uri1 = uri_string:transcode(Uri, [{in_encoding, latin1}]), + #{query := Q1} = uri_string:parse(Uri1), + [{"foo bar","1"}, {"合", "2"}] = uri_string:dissect_query(Q1). diff --git a/lib/ssh/src/ssh_client_key.erl b/lib/stdlib/test/uri_string_property_test_SUITE.erl index 5296ac2a02..ae2c61c7aa 100644 --- a/lib/ssh/src/ssh_client_key.erl +++ b/lib/stdlib/test/uri_string_property_test_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2011-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. @@ -17,19 +17,23 @@ %% %% %CopyrightEnd% %% +-module(uri_string_property_test_SUITE). --module(ssh_client_key). +-include_lib("common_test/include/ct.hrl"). +-compile(export_all). --include_lib("public_key/include/public_key.hrl"). --include("ssh.hrl"). +all() -> [recompose]. --callback is_host_key(Key :: public_key(), Host :: string(), - Algorithm :: 'ssh-rsa'| 'ssh-dsa'| atom(), Options :: proplists:proplist()) -> - boolean(). +init_per_suite(Config) -> + ct_property_test:init_per_suite(Config). --callback user_key(Algorithm :: 'ssh-rsa'| 'ssh-dsa'| atom(), Options :: list()) -> - {ok, PrivateKey :: term()} | {error, string()}. +end_per_suite(Config) -> + Config. - --callback add_host_key(Host :: string(), PublicKey :: term(), Options :: list()) -> - ok | {error, Error::term()}. +%%%======================================================================== +%%% Test suites +%%%======================================================================== +recompose(Config) -> + ct_property_test:quickcheck( + uri_string_recompose:prop_recompose(), + Config). diff --git a/lib/stdlib/test/zip_SUITE.erl b/lib/stdlib/test/zip_SUITE.erl index 1dfcda4ed0..e5ba629c55 100644 --- a/lib/stdlib/test/zip_SUITE.erl +++ b/lib/stdlib/test/zip_SUITE.erl @@ -909,8 +909,7 @@ do_fd_leak(Bad, N) -> ok -> do_fd_leak(Bad, N + 1) catch - C:R -> - Stk = erlang:get_stacktrace(), + C:R:Stk -> io:format("Bad error after ~p attempts\n", [N]), erlang:raise(C, R, Stk) end. diff --git a/lib/stdlib/test/zzz_SUITE.erl b/lib/stdlib/test/zzz_SUITE.erl new file mode 100644 index 0000000000..59c7fd7404 --- /dev/null +++ b/lib/stdlib/test/zzz_SUITE.erl @@ -0,0 +1,37 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2006-2018. 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(zzz_SUITE). + +%% The sole purpose of this test suite is for things we want to run last +%% before the VM terminates. + +-export([all/0]). + +-export([lc_graph/1]). + + +all() -> + [lc_graph]. + +lc_graph(_Config) -> + %% Create "lc_graph" file in current working dir + %% if lock checker is enabled. + erts_debug:lc_graph(), + ok. diff --git a/lib/stdlib/uc_spec/CaseFolding.txt b/lib/stdlib/uc_spec/CaseFolding.txt index 372ee68bd8..efdf18e441 100644 --- a/lib/stdlib/uc_spec/CaseFolding.txt +++ b/lib/stdlib/uc_spec/CaseFolding.txt @@ -1,6 +1,6 @@ -# CaseFolding-9.0.0.txt -# Date: 2016-03-02, 18:54:54 GMT -# © 2016 Unicode®, Inc. +# CaseFolding-10.0.0.txt +# Date: 2017-04-14, 05:40:18 GMT +# © 2017 Unicode®, Inc. # Unicode and the Unicode Logo are registered trademarks of Unicode, Inc. in the U.S. and other countries. # For terms of use, see http://www.unicode.org/terms_of_use.html # @@ -24,7 +24,7 @@ # # NOTE: case folding does not preserve normalization formats! # -# For information on case folding, including how to have case folding +# For information on case folding, including how to have case folding # preserve normalization formats, see Section 3.13 Default Case Algorithms in # The Unicode Standard. # diff --git a/lib/stdlib/uc_spec/CompositionExclusions.txt b/lib/stdlib/uc_spec/CompositionExclusions.txt index 1999ed1328..ff42508686 100644 --- a/lib/stdlib/uc_spec/CompositionExclusions.txt +++ b/lib/stdlib/uc_spec/CompositionExclusions.txt @@ -1,6 +1,6 @@ -# CompositionExclusions-9.0.0.txt -# Date: 2016-01-21, 22:00:00 GMT [KW, LI] -# © 2016 Unicode®, Inc. +# CompositionExclusions-10.0.0.txt +# Date: 2017-02-15, 00:00:00 GMT [KW, LI] +# © 2017 Unicode®, Inc. # For terms of use, see http://www.unicode.org/terms_of_use.html # # Unicode Character Database diff --git a/lib/stdlib/uc_spec/GraphemeBreakProperty.txt b/lib/stdlib/uc_spec/GraphemeBreakProperty.txt index c5e94a3762..32bb12e47e 100644 --- a/lib/stdlib/uc_spec/GraphemeBreakProperty.txt +++ b/lib/stdlib/uc_spec/GraphemeBreakProperty.txt @@ -1,6 +1,6 @@ -# GraphemeBreakProperty-9.0.0.txt -# Date: 2016-06-03, 22:23:55 GMT -# © 2016 Unicode®, Inc. +# GraphemeBreakProperty-10.0.0.txt +# Date: 2017-03-12, 07:03:41 GMT +# © 2017 Unicode®, Inc. # Unicode and the Unicode Logo are registered trademarks of Unicode, Inc. in the U.S. and other countries. # For terms of use, see http://www.unicode.org/terms_of_use.html # @@ -25,8 +25,11 @@ 0D4E ; Prepend # Lo MALAYALAM LETTER DOT REPH 110BD ; Prepend # Cf KAITHI NUMBER SIGN 111C2..111C3 ; Prepend # Lo [2] SHARADA SIGN JIHVAMULIYA..SHARADA SIGN UPADHMANIYA +11A3A ; Prepend # Lo ZANABAZAR SQUARE CLUSTER-INITIAL LETTER RA +11A86..11A89 ; Prepend # Lo [4] SOYOMBO CLUSTER-INITIAL LETTER RA..SOYOMBO CLUSTER-INITIAL LETTER SA +11D46 ; Prepend # Lo MASARAM GONDI REPHA -# Total code points: 13 +# Total code points: 19 # ================================================ @@ -126,6 +129,7 @@ E01F0..E0FFF ; Control # Cn [3600] <reserved-E01F0>..<reserved-E0FFF> 0AC7..0AC8 ; Extend # Mn [2] GUJARATI VOWEL SIGN E..GUJARATI VOWEL SIGN AI 0ACD ; Extend # Mn GUJARATI SIGN VIRAMA 0AE2..0AE3 ; Extend # Mn [2] GUJARATI VOWEL SIGN VOCALIC L..GUJARATI VOWEL SIGN VOCALIC LL +0AFA..0AFF ; Extend # Mn [6] GUJARATI SIGN SUKUN..GUJARATI SIGN TWO-CIRCLE NUKTA ABOVE 0B01 ; Extend # Mn ORIYA SIGN CANDRABINDU 0B3C ; Extend # Mn ORIYA SIGN NUKTA 0B3E ; Extend # Mc ORIYA VOWEL SIGN AA @@ -154,7 +158,8 @@ E01F0..E0FFF ; Control # Cn [3600] <reserved-E01F0>..<reserved-E0FFF> 0CCC..0CCD ; Extend # Mn [2] KANNADA VOWEL SIGN AU..KANNADA SIGN VIRAMA 0CD5..0CD6 ; Extend # Mc [2] KANNADA LENGTH MARK..KANNADA AI LENGTH MARK 0CE2..0CE3 ; Extend # Mn [2] KANNADA VOWEL SIGN VOCALIC L..KANNADA VOWEL SIGN VOCALIC LL -0D01 ; Extend # Mn MALAYALAM SIGN CANDRABINDU +0D00..0D01 ; Extend # Mn [2] MALAYALAM SIGN COMBINING ANUSVARA ABOVE..MALAYALAM SIGN CANDRABINDU +0D3B..0D3C ; Extend # Mn [2] MALAYALAM SIGN VERTICAL BAR VIRAMA..MALAYALAM SIGN CIRCULAR VIRAMA 0D3E ; Extend # Mc MALAYALAM VOWEL SIGN AA 0D41..0D44 ; Extend # Mn [4] MALAYALAM VOWEL SIGN U..MALAYALAM VOWEL SIGN VOCALIC RR 0D4D ; Extend # Mn MALAYALAM SIGN VIRAMA @@ -243,7 +248,7 @@ E01F0..E0FFF ; Control # Cn [3600] <reserved-E01F0>..<reserved-E0FFF> 1CED ; Extend # Mn VEDIC SIGN TIRYAK 1CF4 ; Extend # Mn VEDIC TONE CANDRA ABOVE 1CF8..1CF9 ; Extend # Mn [2] VEDIC TONE RING ABOVE..VEDIC TONE DOUBLE RING ABOVE -1DC0..1DF5 ; Extend # Mn [54] COMBINING DOTTED GRAVE ACCENT..COMBINING UP TACK ABOVE +1DC0..1DF9 ; Extend # Mn [58] COMBINING DOTTED GRAVE ACCENT..COMBINING WIDE INVERTED BRIDGE BELOW 1DFB..1DFF ; Extend # Mn [5] COMBINING DELETION MARK..COMBINING RIGHT ARROWHEAD AND DOWN ARROWHEAD BELOW 200C ; Extend # Cf ZERO WIDTH NON-JOINER 20D0..20DC ; Extend # Mn [13] COMBINING LEFT HARPOON ABOVE..COMBINING FOUR DOTS ABOVE @@ -353,6 +358,15 @@ FF9E..FF9F ; Extend # Lm [2] HALFWIDTH KATAKANA VOICED SOUND MARK..HALFWIDT 1171D..1171F ; Extend # Mn [3] AHOM CONSONANT SIGN MEDIAL LA..AHOM CONSONANT SIGN MEDIAL LIGATING RA 11722..11725 ; Extend # Mn [4] AHOM VOWEL SIGN I..AHOM VOWEL SIGN UU 11727..1172B ; Extend # Mn [5] AHOM VOWEL SIGN AW..AHOM SIGN KILLER +11A01..11A06 ; Extend # Mn [6] ZANABAZAR SQUARE VOWEL SIGN I..ZANABAZAR SQUARE VOWEL SIGN O +11A09..11A0A ; Extend # Mn [2] ZANABAZAR SQUARE VOWEL SIGN REVERSED I..ZANABAZAR SQUARE VOWEL LENGTH MARK +11A33..11A38 ; Extend # Mn [6] ZANABAZAR SQUARE FINAL CONSONANT MARK..ZANABAZAR SQUARE SIGN ANUSVARA +11A3B..11A3E ; Extend # Mn [4] ZANABAZAR SQUARE CLUSTER-FINAL LETTER YA..ZANABAZAR SQUARE CLUSTER-FINAL LETTER VA +11A47 ; Extend # Mn ZANABAZAR SQUARE SUBJOINER +11A51..11A56 ; Extend # Mn [6] SOYOMBO VOWEL SIGN I..SOYOMBO VOWEL SIGN OE +11A59..11A5B ; Extend # Mn [3] SOYOMBO VOWEL SIGN VOCALIC R..SOYOMBO VOWEL LENGTH MARK +11A8A..11A96 ; Extend # Mn [13] SOYOMBO FINAL CONSONANT SIGN G..SOYOMBO SIGN ANUSVARA +11A98..11A99 ; Extend # Mn [2] SOYOMBO GEMINATION MARK..SOYOMBO SUBJOINER 11C30..11C36 ; Extend # Mn [7] BHAIKSUKI VOWEL SIGN I..BHAIKSUKI VOWEL SIGN VOCALIC L 11C38..11C3D ; Extend # Mn [6] BHAIKSUKI VOWEL SIGN E..BHAIKSUKI SIGN ANUSVARA 11C3F ; Extend # Mn BHAIKSUKI SIGN VIRAMA @@ -360,6 +374,11 @@ FF9E..FF9F ; Extend # Lm [2] HALFWIDTH KATAKANA VOICED SOUND MARK..HALFWIDT 11CAA..11CB0 ; Extend # Mn [7] MARCHEN SUBJOINED LETTER RA..MARCHEN VOWEL SIGN AA 11CB2..11CB3 ; Extend # Mn [2] MARCHEN VOWEL SIGN U..MARCHEN VOWEL SIGN E 11CB5..11CB6 ; Extend # Mn [2] MARCHEN SIGN ANUSVARA..MARCHEN SIGN CANDRABINDU +11D31..11D36 ; Extend # Mn [6] MASARAM GONDI VOWEL SIGN AA..MASARAM GONDI VOWEL SIGN VOCALIC R +11D3A ; Extend # Mn MASARAM GONDI VOWEL SIGN E +11D3C..11D3D ; Extend # Mn [2] MASARAM GONDI VOWEL SIGN AI..MASARAM GONDI VOWEL SIGN O +11D3F..11D45 ; Extend # Mn [7] MASARAM GONDI VOWEL SIGN AU..MASARAM GONDI VIRAMA +11D47 ; Extend # Mn MASARAM GONDI RA-KARA 16AF0..16AF4 ; Extend # Mn [5] BASSA VAH COMBINING HIGH TONE..BASSA VAH COMBINING HIGH-LOW TONE 16B30..16B36 ; Extend # Mn [7] PAHAWH HMONG MARK CIM TUB..PAHAWH HMONG MARK CIM TAUM 16F8F..16F92 ; Extend # Mn [4] MIAO TONE RIGHT..MIAO TONE BELOW @@ -387,7 +406,7 @@ FF9E..FF9F ; Extend # Lm [2] HALFWIDTH KATAKANA VOICED SOUND MARK..HALFWIDT E0020..E007F ; Extend # Cf [96] TAG SPACE..CANCEL TAG E0100..E01EF ; Extend # Mn [240] VARIATION SELECTOR-17..VARIATION SELECTOR-256 -# Total code points: 1828 +# Total code points: 1901 # ================================================ @@ -472,6 +491,7 @@ E0100..E01EF ; Extend # Mn [240] VARIATION SELECTOR-17..VARIATION SELECTOR-256 1C34..1C35 ; SpacingMark # Mc [2] LEPCHA CONSONANT SIGN NYIN-DO..LEPCHA CONSONANT SIGN KANG 1CE1 ; SpacingMark # Mc VEDIC TONE ATHARVAVEDIC INDEPENDENT SVARITA 1CF2..1CF3 ; SpacingMark # Mc [2] VEDIC SIGN ARDHAVISARGA..VEDIC SIGN ROTATED ARDHAVISARGA +1CF7 ; SpacingMark # Mc VEDIC SIGN ATIKRAMA A823..A824 ; SpacingMark # Mc [2] SYLOTI NAGRI VOWEL SIGN A..SYLOTI NAGRI VOWEL SIGN I A827 ; SpacingMark # Mc SYLOTI NAGRI VOWEL SIGN OO A880..A881 ; SpacingMark # Mc [2] SAURASHTRA SIGN ANUSVARA..SAURASHTRA SIGN VISARGA @@ -529,6 +549,10 @@ ABEC ; SpacingMark # Mc MEETEI MAYEK LUM IYEK 116B6 ; SpacingMark # Mc TAKRI SIGN VIRAMA 11720..11721 ; SpacingMark # Mc [2] AHOM VOWEL SIGN A..AHOM VOWEL SIGN AA 11726 ; SpacingMark # Mc AHOM VOWEL SIGN E +11A07..11A08 ; SpacingMark # Mc [2] ZANABAZAR SQUARE VOWEL SIGN AI..ZANABAZAR SQUARE VOWEL SIGN AU +11A39 ; SpacingMark # Mc ZANABAZAR SQUARE SIGN VISARGA +11A57..11A58 ; SpacingMark # Mc [2] SOYOMBO VOWEL SIGN AI..SOYOMBO VOWEL SIGN AU +11A97 ; SpacingMark # Mc SOYOMBO SIGN VISARGA 11C2F ; SpacingMark # Mc BHAIKSUKI VOWEL SIGN AA 11C3E ; SpacingMark # Mc BHAIKSUKI SIGN VISARGA 11CA9 ; SpacingMark # Mc MARCHEN SUBJOINED LETTER YA @@ -538,7 +562,7 @@ ABEC ; SpacingMark # Mc MEETEI MAYEK LUM IYEK 1D166 ; SpacingMark # Mc MUSICAL SYMBOL COMBINING SPRECHGESANG STEM 1D16D ; SpacingMark # Mc MUSICAL SYMBOL COMBINING AUGMENTATION DOT -# Total code points: 341 +# Total code points: 348 # ================================================ @@ -1375,8 +1399,9 @@ D789..D7A3 ; LVT # Lo [27] HANGUL SYLLABLE HIG..HANGUL SYLLABLE HIH 26F9 ; E_Base # So PERSON WITH BALL 270A..270D ; E_Base # So [4] RAISED FIST..WRITING HAND 1F385 ; E_Base # So FATHER CHRISTMAS -1F3C3..1F3C4 ; E_Base # So [2] RUNNER..SURFER -1F3CA..1F3CB ; E_Base # So [2] SWIMMER..WEIGHT LIFTER +1F3C2..1F3C4 ; E_Base # So [3] SNOWBOARDER..SURFER +1F3C7 ; E_Base # So HORSE RACING +1F3CA..1F3CC ; E_Base # So [3] SWIMMER..GOLFER 1F442..1F443 ; E_Base # So [2] EAR..NOSE 1F446..1F450 ; E_Base # So [11] WHITE UP POINTING BACKHAND INDEX..OPEN HANDS SIGN 1F46E ; E_Base # So POLICE OFFICER @@ -1385,7 +1410,7 @@ D789..D7A3 ; LVT # Lo [27] HANGUL SYLLABLE HIG..HANGUL SYLLABLE HIH 1F481..1F483 ; E_Base # So [3] INFORMATION DESK PERSON..DANCER 1F485..1F487 ; E_Base # So [3] NAIL POLISH..HAIRCUT 1F4AA ; E_Base # So FLEXED BICEPS -1F575 ; E_Base # So SLEUTH OR SPY +1F574..1F575 ; E_Base # So [2] MAN IN BUSINESS SUIT LEVITATING..SLEUTH OR SPY 1F57A ; E_Base # So MAN DANCING 1F590 ; E_Base # So RAISED HAND WITH FINGERS SPLAYED 1F595..1F596 ; E_Base # So [2] REVERSED HAND WITH MIDDLE FINGER EXTENDED..RAISED HAND WITH PART BETWEEN MIDDLE AND RING FINGERS @@ -1394,13 +1419,15 @@ D789..D7A3 ; LVT # Lo [27] HANGUL SYLLABLE HIG..HANGUL SYLLABLE HIH 1F6A3 ; E_Base # So ROWBOAT 1F6B4..1F6B6 ; E_Base # So [3] BICYCLIST..PEDESTRIAN 1F6C0 ; E_Base # So BATH -1F918..1F91E ; E_Base # So [7] SIGN OF THE HORNS..HAND WITH INDEX AND MIDDLE FINGERS CROSSED +1F6CC ; E_Base # So SLEEPING ACCOMMODATION +1F918..1F91C ; E_Base # So [5] SIGN OF THE HORNS..RIGHT-FACING FIST +1F91E..1F91F ; E_Base # So [2] HAND WITH INDEX AND MIDDLE FINGERS CROSSED..I LOVE YOU HAND SIGN 1F926 ; E_Base # So FACE PALM -1F930 ; E_Base # So PREGNANT WOMAN -1F933..1F939 ; E_Base # So [7] SELFIE..JUGGLING -1F93C..1F93E ; E_Base # So [3] WRESTLERS..HANDBALL +1F930..1F939 ; E_Base # So [10] PREGNANT WOMAN..JUGGLING +1F93D..1F93E ; E_Base # So [2] WATER POLO..HANDBALL +1F9D1..1F9DD ; E_Base # So [13] ADULT..ELF -# Total code points: 79 +# Total code points: 98 # ================================================ @@ -1416,11 +1443,28 @@ D789..D7A3 ; LVT # Lo [27] HANGUL SYLLABLE HIG..HANGUL SYLLABLE HIH # ================================================ +2640 ; Glue_After_Zwj # So FEMALE SIGN +2642 ; Glue_After_Zwj # So MALE SIGN +2695..2696 ; Glue_After_Zwj # So [2] STAFF OF AESCULAPIUS..SCALES +2708 ; Glue_After_Zwj # So AIRPLANE 2764 ; Glue_After_Zwj # So HEAVY BLACK HEART +1F308 ; Glue_After_Zwj # So RAINBOW +1F33E ; Glue_After_Zwj # So EAR OF RICE +1F373 ; Glue_After_Zwj # So COOKING +1F393 ; Glue_After_Zwj # So GRADUATION CAP +1F3A4 ; Glue_After_Zwj # So MICROPHONE +1F3A8 ; Glue_After_Zwj # So ARTIST PALETTE +1F3EB ; Glue_After_Zwj # So SCHOOL +1F3ED ; Glue_After_Zwj # So FACTORY 1F48B ; Glue_After_Zwj # So KISS MARK +1F4BB..1F4BC ; Glue_After_Zwj # So [2] PERSONAL COMPUTER..BRIEFCASE +1F527 ; Glue_After_Zwj # So WRENCH +1F52C ; Glue_After_Zwj # So MICROSCOPE 1F5E8 ; Glue_After_Zwj # So LEFT SPEECH BUBBLE +1F680 ; Glue_After_Zwj # So ROCKET +1F692 ; Glue_After_Zwj # So FIRE ENGINE -# Total code points: 3 +# Total code points: 22 # ================================================ diff --git a/lib/stdlib/uc_spec/PropList.txt b/lib/stdlib/uc_spec/PropList.txt index a8c0da7135..9a2d0e4b1c 100644 --- a/lib/stdlib/uc_spec/PropList.txt +++ b/lib/stdlib/uc_spec/PropList.txt @@ -1,6 +1,6 @@ -# PropList-9.0.0.txt -# Date: 2016-06-01, 10:34:30 GMT -# © 2016 Unicode®, Inc. +# PropList-10.0.0.txt +# Date: 2017-03-10, 08:25:30 GMT +# © 2017 Unicode®, Inc. # Unicode and the Unicode Logo are registered trademarks of Unicode, Inc. in the U.S. and other countries. # For terms of use, see http://www.unicode.org/terms_of_use.html # @@ -199,6 +199,9 @@ FF64 ; Terminal_Punctuation # Po HALFWIDTH IDEOGRAPHIC COMMA 115C9..115D7 ; Terminal_Punctuation # Po [15] SIDDHAM END OF TEXT MARK..SIDDHAM SECTION MARK WITH CIRCLES AND FOUR ENCLOSURES 11641..11642 ; Terminal_Punctuation # Po [2] MODI DANDA..MODI DOUBLE DANDA 1173C..1173E ; Terminal_Punctuation # Po [3] AHOM SIGN SMALL SECTION..AHOM SIGN RULAI +11A42..11A43 ; Terminal_Punctuation # Po [2] ZANABAZAR SQUARE MARK SHAD..ZANABAZAR SQUARE MARK DOUBLE SHAD +11A9B..11A9C ; Terminal_Punctuation # Po [2] SOYOMBO MARK SHAD..SOYOMBO MARK DOUBLE SHAD +11AA1..11AA2 ; Terminal_Punctuation # Po [2] SOYOMBO TERMINAL MARK-1..SOYOMBO TERMINAL MARK-2 11C41..11C43 ; Terminal_Punctuation # Po [3] BHAIKSUKI DANDA..BHAIKSUKI WORD SEPARATOR 11C71 ; Terminal_Punctuation # Po MARCHEN MARK SHAD 12470..12474 ; Terminal_Punctuation # Po [5] CUNEIFORM PUNCTUATION SIGN OLD ASSYRIAN WORD DIVIDER..CUNEIFORM PUNCTUATION SIGN DIAGONAL QUADCOLON @@ -209,7 +212,7 @@ FF64 ; Terminal_Punctuation # Po HALFWIDTH IDEOGRAPHIC COMMA 1BC9F ; Terminal_Punctuation # Po DUPLOYAN PUNCTUATION CHINOOK FULL STOP 1DA87..1DA8A ; Terminal_Punctuation # Po [4] SIGNWRITING COMMA..SIGNWRITING COLON -# Total code points: 246 +# Total code points: 252 # ================================================ @@ -471,6 +474,7 @@ FF41..FF46 ; Hex_Digit # L& [6] FULLWIDTH LATIN SMALL LETTER A..FULLWIDTH L 0AC9 ; Other_Alphabetic # Mc GUJARATI VOWEL SIGN CANDRA O 0ACB..0ACC ; Other_Alphabetic # Mc [2] GUJARATI VOWEL SIGN O..GUJARATI VOWEL SIGN AU 0AE2..0AE3 ; Other_Alphabetic # Mn [2] GUJARATI VOWEL SIGN VOCALIC L..GUJARATI VOWEL SIGN VOCALIC LL +0AFA..0AFC ; Other_Alphabetic # Mn [3] GUJARATI SIGN SUKUN..GUJARATI SIGN MADDAH 0B01 ; Other_Alphabetic # Mn ORIYA SIGN CANDRABINDU 0B02..0B03 ; Other_Alphabetic # Mc [2] ORIYA SIGN ANUSVARA..ORIYA SIGN VISARGA 0B3E ; Other_Alphabetic # Mc ORIYA VOWEL SIGN AA @@ -508,7 +512,7 @@ FF41..FF46 ; Hex_Digit # L& [6] FULLWIDTH LATIN SMALL LETTER A..FULLWIDTH L 0CCC ; Other_Alphabetic # Mn KANNADA VOWEL SIGN AU 0CD5..0CD6 ; Other_Alphabetic # Mc [2] KANNADA LENGTH MARK..KANNADA AI LENGTH MARK 0CE2..0CE3 ; Other_Alphabetic # Mn [2] KANNADA VOWEL SIGN VOCALIC L..KANNADA VOWEL SIGN VOCALIC LL -0D01 ; Other_Alphabetic # Mn MALAYALAM SIGN CANDRABINDU +0D00..0D01 ; Other_Alphabetic # Mn [2] MALAYALAM SIGN COMBINING ANUSVARA ABOVE..MALAYALAM SIGN CANDRABINDU 0D02..0D03 ; Other_Alphabetic # Mc [2] MALAYALAM SIGN ANUSVARA..MALAYALAM SIGN VISARGA 0D3E..0D40 ; Other_Alphabetic # Mc [3] MALAYALAM VOWEL SIGN AA..MALAYALAM VOWEL SIGN II 0D41..0D44 ; Other_Alphabetic # Mn [4] MALAYALAM VOWEL SIGN U..MALAYALAM VOWEL SIGN VOCALIC RR @@ -726,6 +730,17 @@ FB1E ; Other_Alphabetic # Mn HEBREW POINT JUDEO-SPANISH VARIKA 11722..11725 ; Other_Alphabetic # Mn [4] AHOM VOWEL SIGN I..AHOM VOWEL SIGN UU 11726 ; Other_Alphabetic # Mc AHOM VOWEL SIGN E 11727..1172A ; Other_Alphabetic # Mn [4] AHOM VOWEL SIGN AW..AHOM VOWEL SIGN AM +11A01..11A06 ; Other_Alphabetic # Mn [6] ZANABAZAR SQUARE VOWEL SIGN I..ZANABAZAR SQUARE VOWEL SIGN O +11A07..11A08 ; Other_Alphabetic # Mc [2] ZANABAZAR SQUARE VOWEL SIGN AI..ZANABAZAR SQUARE VOWEL SIGN AU +11A09..11A0A ; Other_Alphabetic # Mn [2] ZANABAZAR SQUARE VOWEL SIGN REVERSED I..ZANABAZAR SQUARE VOWEL LENGTH MARK +11A35..11A38 ; Other_Alphabetic # Mn [4] ZANABAZAR SQUARE SIGN CANDRABINDU..ZANABAZAR SQUARE SIGN ANUSVARA +11A39 ; Other_Alphabetic # Mc ZANABAZAR SQUARE SIGN VISARGA +11A3B..11A3E ; Other_Alphabetic # Mn [4] ZANABAZAR SQUARE CLUSTER-FINAL LETTER YA..ZANABAZAR SQUARE CLUSTER-FINAL LETTER VA +11A51..11A56 ; Other_Alphabetic # Mn [6] SOYOMBO VOWEL SIGN I..SOYOMBO VOWEL SIGN OE +11A57..11A58 ; Other_Alphabetic # Mc [2] SOYOMBO VOWEL SIGN AI..SOYOMBO VOWEL SIGN AU +11A59..11A5B ; Other_Alphabetic # Mn [3] SOYOMBO VOWEL SIGN VOCALIC R..SOYOMBO VOWEL LENGTH MARK +11A8A..11A96 ; Other_Alphabetic # Mn [13] SOYOMBO FINAL CONSONANT SIGN G..SOYOMBO SIGN ANUSVARA +11A97 ; Other_Alphabetic # Mc SOYOMBO SIGN VISARGA 11C2F ; Other_Alphabetic # Mc BHAIKSUKI VOWEL SIGN AA 11C30..11C36 ; Other_Alphabetic # Mn [7] BHAIKSUKI VOWEL SIGN I..BHAIKSUKI VOWEL SIGN VOCALIC L 11C38..11C3D ; Other_Alphabetic # Mn [6] BHAIKSUKI VOWEL SIGN E..BHAIKSUKI SIGN ANUSVARA @@ -737,6 +752,12 @@ FB1E ; Other_Alphabetic # Mn HEBREW POINT JUDEO-SPANISH VARIKA 11CB2..11CB3 ; Other_Alphabetic # Mn [2] MARCHEN VOWEL SIGN U..MARCHEN VOWEL SIGN E 11CB4 ; Other_Alphabetic # Mc MARCHEN VOWEL SIGN O 11CB5..11CB6 ; Other_Alphabetic # Mn [2] MARCHEN SIGN ANUSVARA..MARCHEN SIGN CANDRABINDU +11D31..11D36 ; Other_Alphabetic # Mn [6] MASARAM GONDI VOWEL SIGN AA..MASARAM GONDI VOWEL SIGN VOCALIC R +11D3A ; Other_Alphabetic # Mn MASARAM GONDI VOWEL SIGN E +11D3C..11D3D ; Other_Alphabetic # Mn [2] MASARAM GONDI VOWEL SIGN AI..MASARAM GONDI VOWEL SIGN O +11D3F..11D41 ; Other_Alphabetic # Mn [3] MASARAM GONDI VOWEL SIGN AU..MASARAM GONDI SIGN VISARGA +11D43 ; Other_Alphabetic # Mn MASARAM GONDI SIGN CANDRA +11D47 ; Other_Alphabetic # Mn MASARAM GONDI RA-KARA 16B30..16B36 ; Other_Alphabetic # Mn [7] PAHAWH HMONG MARK CIM TUB..PAHAWH HMONG MARK CIM TAUM 16F51..16F7E ; Other_Alphabetic # Mc [46] MIAO SIGN ASPIRATION..MIAO VOWEL SIGN NG 1BC9E ; Other_Alphabetic # Mn DUPLOYAN DOUBLE MARK @@ -750,7 +771,7 @@ FB1E ; Other_Alphabetic # Mn HEBREW POINT JUDEO-SPANISH VARIKA 1F150..1F169 ; Other_Alphabetic # So [26] NEGATIVE CIRCLED LATIN CAPITAL LETTER A..NEGATIVE CIRCLED LATIN CAPITAL LETTER Z 1F170..1F189 ; Other_Alphabetic # So [26] NEGATIVE SQUARED LATIN CAPITAL LETTER A..NEGATIVE SQUARED LATIN CAPITAL LETTER Z -# Total code points: 1238 +# Total code points: 1300 # ================================================ @@ -759,18 +780,20 @@ FB1E ; Other_Alphabetic # Mn HEBREW POINT JUDEO-SPANISH VARIKA 3021..3029 ; Ideographic # Nl [9] HANGZHOU NUMERAL ONE..HANGZHOU NUMERAL NINE 3038..303A ; Ideographic # Nl [3] HANGZHOU NUMERAL TEN..HANGZHOU NUMERAL THIRTY 3400..4DB5 ; Ideographic # Lo [6582] CJK UNIFIED IDEOGRAPH-3400..CJK UNIFIED IDEOGRAPH-4DB5 -4E00..9FD5 ; Ideographic # Lo [20950] CJK UNIFIED IDEOGRAPH-4E00..CJK UNIFIED IDEOGRAPH-9FD5 +4E00..9FEA ; Ideographic # Lo [20971] CJK UNIFIED IDEOGRAPH-4E00..CJK UNIFIED IDEOGRAPH-9FEA F900..FA6D ; Ideographic # Lo [366] CJK COMPATIBILITY IDEOGRAPH-F900..CJK COMPATIBILITY IDEOGRAPH-FA6D FA70..FAD9 ; Ideographic # Lo [106] CJK COMPATIBILITY IDEOGRAPH-FA70..CJK COMPATIBILITY IDEOGRAPH-FAD9 17000..187EC ; Ideographic # Lo [6125] TANGUT IDEOGRAPH-17000..TANGUT IDEOGRAPH-187EC 18800..18AF2 ; Ideographic # Lo [755] TANGUT COMPONENT-001..TANGUT COMPONENT-755 +1B170..1B2FB ; Ideographic # Lo [396] NUSHU CHARACTER-1B170..NUSHU CHARACTER-1B2FB 20000..2A6D6 ; Ideographic # Lo [42711] CJK UNIFIED IDEOGRAPH-20000..CJK UNIFIED IDEOGRAPH-2A6D6 2A700..2B734 ; Ideographic # Lo [4149] CJK UNIFIED IDEOGRAPH-2A700..CJK UNIFIED IDEOGRAPH-2B734 2B740..2B81D ; Ideographic # Lo [222] CJK UNIFIED IDEOGRAPH-2B740..CJK UNIFIED IDEOGRAPH-2B81D 2B820..2CEA1 ; Ideographic # Lo [5762] CJK UNIFIED IDEOGRAPH-2B820..CJK UNIFIED IDEOGRAPH-2CEA1 +2CEB0..2EBE0 ; Ideographic # Lo [7473] CJK UNIFIED IDEOGRAPH-2CEB0..CJK UNIFIED IDEOGRAPH-2EBE0 2F800..2FA1D ; Ideographic # Lo [542] CJK COMPATIBILITY IDEOGRAPH-2F800..CJK COMPATIBILITY IDEOGRAPH-2FA1D -# Total code points: 88284 +# Total code points: 96174 # ================================================ @@ -826,12 +849,14 @@ FA70..FAD9 ; Ideographic # Lo [106] CJK COMPATIBILITY IDEOGRAPH-FA70..CJK COM 0A4D ; Diacritic # Mn GURMUKHI SIGN VIRAMA 0ABC ; Diacritic # Mn GUJARATI SIGN NUKTA 0ACD ; Diacritic # Mn GUJARATI SIGN VIRAMA +0AFD..0AFF ; Diacritic # Mn [3] GUJARATI SIGN THREE-DOT NUKTA ABOVE..GUJARATI SIGN TWO-CIRCLE NUKTA ABOVE 0B3C ; Diacritic # Mn ORIYA SIGN NUKTA 0B4D ; Diacritic # Mn ORIYA SIGN VIRAMA 0BCD ; Diacritic # Mn TAMIL SIGN VIRAMA 0C4D ; Diacritic # Mn TELUGU SIGN VIRAMA 0CBC ; Diacritic # Mn KANNADA SIGN NUKTA 0CCD ; Diacritic # Mn KANNADA SIGN VIRAMA +0D3B..0D3C ; Diacritic # Mn [2] MALAYALAM SIGN VERTICAL BAR VIRAMA..MALAYALAM SIGN CIRCULAR VIRAMA 0D4D ; Diacritic # Mn MALAYALAM SIGN VIRAMA 0DCA ; Diacritic # Mn SINHALA SIGN AL-LAKUNA 0E47..0E4C ; Diacritic # Mn [6] THAI CHARACTER MAITAIKHU..THAI CHARACTER THANTHAKHAT @@ -871,10 +896,11 @@ FA70..FAD9 ; Ideographic # Lo [106] CJK COMPATIBILITY IDEOGRAPH-FA70..CJK COM 1CE2..1CE8 ; Diacritic # Mn [7] VEDIC SIGN VISARGA SVARITA..VEDIC SIGN VISARGA ANUDATTA WITH TAIL 1CED ; Diacritic # Mn VEDIC SIGN TIRYAK 1CF4 ; Diacritic # Mn VEDIC TONE CANDRA ABOVE +1CF7 ; Diacritic # Mc VEDIC SIGN ATIKRAMA 1CF8..1CF9 ; Diacritic # Mn [2] VEDIC TONE RING ABOVE..VEDIC TONE DOUBLE RING ABOVE 1D2C..1D6A ; Diacritic # Lm [63] MODIFIER LETTER CAPITAL A..GREEK SUBSCRIPT SMALL LETTER CHI 1DC4..1DCF ; Diacritic # Mn [12] COMBINING MACRON-ACUTE..COMBINING ZIGZAG BELOW -1DF5 ; Diacritic # Mn COMBINING UP TACK ABOVE +1DF5..1DF9 ; Diacritic # Mn [5] COMBINING UP TACK ABOVE..COMBINING WIDE INVERTED BRIDGE BELOW 1DFD..1DFF ; Diacritic # Mn [3] COMBINING ALMOST EQUAL TO BELOW..COMBINING RIGHT ARROWHEAD AND DOWN ARROWHEAD BELOW 1FBD ; Diacritic # Sk GREEK KORONIS 1FBF..1FC1 ; Diacritic # Sk [3] GREEK PSILI..GREEK DIALYTIKA AND PERISPOMENI @@ -947,7 +973,12 @@ FFE3 ; Diacritic # Sk FULLWIDTH MACRON 116B6 ; Diacritic # Mc TAKRI SIGN VIRAMA 116B7 ; Diacritic # Mn TAKRI SIGN NUKTA 1172B ; Diacritic # Mn AHOM SIGN KILLER +11A34 ; Diacritic # Mn ZANABAZAR SQUARE SIGN VIRAMA +11A47 ; Diacritic # Mn ZANABAZAR SQUARE SUBJOINER +11A99 ; Diacritic # Mn SOYOMBO SUBJOINER 11C3F ; Diacritic # Mn BHAIKSUKI SIGN VIRAMA +11D42 ; Diacritic # Mn MASARAM GONDI SIGN NUKTA +11D44..11D45 ; Diacritic # Mn [2] MASARAM GONDI SIGN HALANTA..MASARAM GONDI VIRAMA 16AF0..16AF4 ; Diacritic # Mn [5] BASSA VAH COMBINING HIGH TONE..BASSA VAH COMBINING HIGH-LOW TONE 16F8F..16F92 ; Diacritic # Mn [4] MIAO TONE RIGHT..MIAO TONE BELOW 16F93..16F9F ; Diacritic # Lm [13] MIAO LETTER TONE-2..MIAO LETTER REFORMED TONE-8 @@ -960,7 +991,7 @@ FFE3 ; Diacritic # Sk FULLWIDTH MACRON 1E944..1E946 ; Diacritic # Mn [3] ADLAM ALIF LENGTHENER..ADLAM GEMINATION MARK 1E948..1E94A ; Diacritic # Mn [3] ADLAM CONSONANT MODIFIER..ADLAM NUKTA -# Total code points: 782 +# Total code points: 798 # ================================================ @@ -989,11 +1020,12 @@ AAF3..AAF4 ; Extender # Lm [2] MEETEI MAYEK SYLLABLE REPETITION MARK..MEETE FF70 ; Extender # Lm HALFWIDTH KATAKANA-HIRAGANA PROLONGED SOUND MARK 1135D ; Extender # Lo GRANTHA SIGN PLUTA 115C6..115C8 ; Extender # Po [3] SIDDHAM REPETITION MARK-1..SIDDHAM REPETITION MARK-3 +11A98 ; Extender # Mn SOYOMBO GEMINATION MARK 16B42..16B43 ; Extender # Lm [2] PAHAWH HMONG SIGN VOS NRUA..PAHAWH HMONG SIGN IB YAM -16FE0 ; Extender # Lm TANGUT ITERATION MARK +16FE0..16FE1 ; Extender # Lm [2] TANGUT ITERATION MARK..NUSHU ITERATION MARK 1E944..1E946 ; Extender # Mn [3] ADLAM ALIF LENGTHENER..ADLAM GEMINATION MARK -# Total code points: 42 +# Total code points: 44 # ================================================ @@ -1105,7 +1137,7 @@ E0020..E007F ; Other_Grapheme_Extend # Cf [96] TAG SPACE..CANCEL TAG # ================================================ 3400..4DB5 ; Unified_Ideograph # Lo [6582] CJK UNIFIED IDEOGRAPH-3400..CJK UNIFIED IDEOGRAPH-4DB5 -4E00..9FD5 ; Unified_Ideograph # Lo [20950] CJK UNIFIED IDEOGRAPH-4E00..CJK UNIFIED IDEOGRAPH-9FD5 +4E00..9FEA ; Unified_Ideograph # Lo [20971] CJK UNIFIED IDEOGRAPH-4E00..CJK UNIFIED IDEOGRAPH-9FEA FA0E..FA0F ; Unified_Ideograph # Lo [2] CJK COMPATIBILITY IDEOGRAPH-FA0E..CJK COMPATIBILITY IDEOGRAPH-FA0F FA11 ; Unified_Ideograph # Lo CJK COMPATIBILITY IDEOGRAPH-FA11 FA13..FA14 ; Unified_Ideograph # Lo [2] CJK COMPATIBILITY IDEOGRAPH-FA13..CJK COMPATIBILITY IDEOGRAPH-FA14 @@ -1117,8 +1149,9 @@ FA27..FA29 ; Unified_Ideograph # Lo [3] CJK COMPATIBILITY IDEOGRAPH-FA27..C 2A700..2B734 ; Unified_Ideograph # Lo [4149] CJK UNIFIED IDEOGRAPH-2A700..CJK UNIFIED IDEOGRAPH-2B734 2B740..2B81D ; Unified_Ideograph # Lo [222] CJK UNIFIED IDEOGRAPH-2B740..CJK UNIFIED IDEOGRAPH-2B81D 2B820..2CEA1 ; Unified_Ideograph # Lo [5762] CJK UNIFIED IDEOGRAPH-2B820..CJK UNIFIED IDEOGRAPH-2CEA1 +2CEB0..2EBE0 ; Unified_Ideograph # Lo [7473] CJK UNIFIED IDEOGRAPH-2CEB0..CJK UNIFIED IDEOGRAPH-2EBE0 -# Total code points: 80388 +# Total code points: 87882 # ================================================ @@ -1277,6 +1310,8 @@ FF61 ; Sentence_Terminal # Po HALFWIDTH IDEOGRAPHIC FULL STOP 115C9..115D7 ; Sentence_Terminal # Po [15] SIDDHAM END OF TEXT MARK..SIDDHAM SECTION MARK WITH CIRCLES AND FOUR ENCLOSURES 11641..11642 ; Sentence_Terminal # Po [2] MODI DANDA..MODI DOUBLE DANDA 1173C..1173E ; Sentence_Terminal # Po [3] AHOM SIGN SMALL SECTION..AHOM SIGN RULAI +11A42..11A43 ; Sentence_Terminal # Po [2] ZANABAZAR SQUARE MARK SHAD..ZANABAZAR SQUARE MARK DOUBLE SHAD +11A9B..11A9C ; Sentence_Terminal # Po [2] SOYOMBO MARK SHAD..SOYOMBO MARK DOUBLE SHAD 11C41..11C42 ; Sentence_Terminal # Po [2] BHAIKSUKI DANDA..BHAIKSUKI DOUBLE DANDA 16A6E..16A6F ; Sentence_Terminal # Po [2] MRO DANDA..MRO DOUBLE DANDA 16AF5 ; Sentence_Terminal # Po BASSA VAH FULL STOP @@ -1285,7 +1320,7 @@ FF61 ; Sentence_Terminal # Po HALFWIDTH IDEOGRAPHIC FULL STOP 1BC9F ; Sentence_Terminal # Po DUPLOYAN PUNCTUATION CHINOOK FULL STOP 1DA88 ; Sentence_Terminal # Po SIGNWRITING FULL STOP -# Total code points: 124 +# Total code points: 128 # ================================================ @@ -1402,9 +1437,7 @@ E0100..E01EF ; Variation_Selector # Mn [240] VARIATION SELECTOR-17..VARIATION S 239B..23B3 ; Pattern_Syntax # Sm [25] LEFT PARENTHESIS UPPER HOOK..SUMMATION BOTTOM 23B4..23DB ; Pattern_Syntax # So [40] TOP SQUARE BRACKET..FUSE 23DC..23E1 ; Pattern_Syntax # Sm [6] TOP PARENTHESIS..BOTTOM TORTOISE SHELL BRACKET -23E2..23FE ; Pattern_Syntax # So [29] WHITE TRAPEZIUM..POWER SLEEP SYMBOL -23FF ; Pattern_Syntax # Cn <reserved-23FF> -2400..2426 ; Pattern_Syntax # So [39] SYMBOL FOR NULL..SYMBOL FOR SUBSTITUTE FORM TWO +23E2..2426 ; Pattern_Syntax # So [69] WHITE TRAPEZIUM..SYMBOL FOR SUBSTITUTE FORM TWO 2427..243F ; Pattern_Syntax # Cn [25] <reserved-2427>..<reserved-243F> 2440..244A ; Pattern_Syntax # So [11] OCR HOOK..OCR DOUBLE BACKSLASH 244B..245F ; Pattern_Syntax # Cn [21] <reserved-244B>..<reserved-245F> @@ -1492,8 +1525,8 @@ E0100..E01EF ; Variation_Selector # Mn [240] VARIATION SELECTOR-17..VARIATION S 2BBA..2BBC ; Pattern_Syntax # Cn [3] <reserved-2BBA>..<reserved-2BBC> 2BBD..2BC8 ; Pattern_Syntax # So [12] BALLOT BOX WITH LIGHT X..BLACK MEDIUM RIGHT-POINTING TRIANGLE CENTRED 2BC9 ; Pattern_Syntax # Cn <reserved-2BC9> -2BCA..2BD1 ; Pattern_Syntax # So [8] TOP HALF BLACK CIRCLE..UNCERTAINTY SIGN -2BD2..2BEB ; Pattern_Syntax # Cn [26] <reserved-2BD2>..<reserved-2BEB> +2BCA..2BD2 ; Pattern_Syntax # So [9] TOP HALF BLACK CIRCLE..GROUP MARK +2BD3..2BEB ; Pattern_Syntax # Cn [25] <reserved-2BD3>..<reserved-2BEB> 2BEC..2BEF ; Pattern_Syntax # So [4] LEFTWARDS TWO-HEADED ARROW WITH TRIANGLE ARROWHEADS..DOWNWARDS TWO-HEADED ARROW WITH TRIANGLE ARROWHEADS 2BF0..2BFF ; Pattern_Syntax # Cn [16] <reserved-2BF0>..<reserved-2BFF> 2E00..2E01 ; Pattern_Syntax # Po [2] RIGHT ANGLE SUBSTITUTION MARKER..RIGHT ANGLE DOTTED SUBSTITUTION MARKER @@ -1533,8 +1566,8 @@ E0100..E01EF ; Variation_Selector # Mn [240] VARIATION SELECTOR-17..VARIATION S 2E40 ; Pattern_Syntax # Pd DOUBLE HYPHEN 2E41 ; Pattern_Syntax # Po REVERSED COMMA 2E42 ; Pattern_Syntax # Ps DOUBLE LOW-REVERSED-9 QUOTATION MARK -2E43..2E44 ; Pattern_Syntax # Po [2] DASH WITH LEFT UPTURN..DOUBLE SUSPENSION MARK -2E45..2E7F ; Pattern_Syntax # Cn [59] <reserved-2E45>..<reserved-2E7F> +2E43..2E49 ; Pattern_Syntax # Po [7] DASH WITH LEFT UPTURN..DOUBLE STACKED COMMA +2E4A..2E7F ; Pattern_Syntax # Cn [54] <reserved-2E4A>..<reserved-2E7F> 3001..3003 ; Pattern_Syntax # Po [3] IDEOGRAPHIC COMMA..DITTO MARK 3008 ; Pattern_Syntax # Ps LEFT ANGLE BRACKET 3009 ; Pattern_Syntax # Pe RIGHT ANGLE BRACKET @@ -1576,4 +1609,10 @@ FE45..FE46 ; Pattern_Syntax # Po [2] SESAME DOT..WHITE SESAME DOT # Total code points: 10 +# ================================================ + +1F1E6..1F1FF ; Regional_Indicator # So [26] REGIONAL INDICATOR SYMBOL LETTER A..REGIONAL INDICATOR SYMBOL LETTER Z + +# Total code points: 26 + # EOF diff --git a/lib/stdlib/uc_spec/SpecialCasing.txt b/lib/stdlib/uc_spec/SpecialCasing.txt index b23fa7f768..b9ba0d81c1 100644 --- a/lib/stdlib/uc_spec/SpecialCasing.txt +++ b/lib/stdlib/uc_spec/SpecialCasing.txt @@ -1,6 +1,6 @@ -# SpecialCasing-9.0.0.txt -# Date: 2016-03-02, 18:55:13 GMT -# © 2016 Unicode®, Inc. +# SpecialCasing-10.0.0.txt +# Date: 2017-04-14, 05:40:43 GMT +# © 2017 Unicode®, Inc. # Unicode and the Unicode Logo are registered trademarks of Unicode, Inc. in the U.S. and other countries. # For terms of use, see http://www.unicode.org/terms_of_use.html # @@ -197,7 +197,7 @@ FB17; FB17; 0544 056D; 0544 053D; # ARMENIAN SMALL LIGATURE MEN XEH # ================================================================================ # Conditional Mappings -# The remainder of this file provides conditional casing data used to produce +# The remainder of this file provides conditional casing data used to produce # full case mappings. # ================================================================================ # Language-Insensitive Mappings diff --git a/lib/stdlib/uc_spec/UnicodeData.txt b/lib/stdlib/uc_spec/UnicodeData.txt index a756976461..d89c64f526 100644 --- a/lib/stdlib/uc_spec/UnicodeData.txt +++ b/lib/stdlib/uc_spec/UnicodeData.txt @@ -2072,6 +2072,17 @@ 085A;MANDAIC VOCALIZATION MARK;Mn;220;NSM;;;;;N;;;;; 085B;MANDAIC GEMINATION MARK;Mn;220;NSM;;;;;N;;;;; 085E;MANDAIC PUNCTUATION;Po;0;R;;;;;N;;;;; +0860;SYRIAC LETTER MALAYALAM NGA;Lo;0;AL;;;;;N;;;;; +0861;SYRIAC LETTER MALAYALAM JA;Lo;0;AL;;;;;N;;;;; +0862;SYRIAC LETTER MALAYALAM NYA;Lo;0;AL;;;;;N;;;;; +0863;SYRIAC LETTER MALAYALAM TTA;Lo;0;AL;;;;;N;;;;; +0864;SYRIAC LETTER MALAYALAM NNA;Lo;0;AL;;;;;N;;;;; +0865;SYRIAC LETTER MALAYALAM NNNA;Lo;0;AL;;;;;N;;;;; +0866;SYRIAC LETTER MALAYALAM BHA;Lo;0;AL;;;;;N;;;;; +0867;SYRIAC LETTER MALAYALAM RA;Lo;0;AL;;;;;N;;;;; +0868;SYRIAC LETTER MALAYALAM LLA;Lo;0;AL;;;;;N;;;;; +0869;SYRIAC LETTER MALAYALAM LLLA;Lo;0;AL;;;;;N;;;;; +086A;SYRIAC LETTER MALAYALAM SSA;Lo;0;AL;;;;;N;;;;; 08A0;ARABIC LETTER BEH WITH SMALL V BELOW;Lo;0;AL;;;;;N;;;;; 08A1;ARABIC LETTER BEH WITH HAMZA ABOVE;Lo;0;AL;;;;;N;;;;; 08A2;ARABIC LETTER JEEM WITH TWO DOTS ABOVE;Lo;0;AL;;;;;N;;;;; @@ -2366,6 +2377,8 @@ 09F9;BENGALI CURRENCY DENOMINATOR SIXTEEN;No;0;L;;;;16;N;;;;; 09FA;BENGALI ISSHAR;So;0;L;;;;;N;;;;; 09FB;BENGALI GANDA MARK;Sc;0;ET;;;;;N;;;;; +09FC;BENGALI LETTER VEDIC ANUSVARA;Lo;0;L;;;;;N;;;;; +09FD;BENGALI ABBREVIATION SIGN;Po;0;L;;;;;N;;;;; 0A01;GURMUKHI SIGN ADAK BINDI;Mn;0;NSM;;;;;N;;;;; 0A02;GURMUKHI SIGN BINDI;Mn;0;NSM;;;;;N;;;;; 0A03;GURMUKHI SIGN VISARGA;Mc;0;L;;;;;N;;;;; @@ -2530,6 +2543,12 @@ 0AF0;GUJARATI ABBREVIATION SIGN;Po;0;L;;;;;N;;;;; 0AF1;GUJARATI RUPEE SIGN;Sc;0;ET;;;;;N;;;;; 0AF9;GUJARATI LETTER ZHA;Lo;0;L;;;;;N;;;;; +0AFA;GUJARATI SIGN SUKUN;Mn;0;NSM;;;;;N;;;;; +0AFB;GUJARATI SIGN SHADDA;Mn;0;NSM;;;;;N;;;;; +0AFC;GUJARATI SIGN MADDAH;Mn;0;NSM;;;;;N;;;;; +0AFD;GUJARATI SIGN THREE-DOT NUKTA ABOVE;Mn;0;NSM;;;;;N;;;;; +0AFE;GUJARATI SIGN CIRCLE NUKTA ABOVE;Mn;0;NSM;;;;;N;;;;; +0AFF;GUJARATI SIGN TWO-CIRCLE NUKTA ABOVE;Mn;0;NSM;;;;;N;;;;; 0B01;ORIYA SIGN CANDRABINDU;Mn;0;NSM;;;;;N;;;;; 0B02;ORIYA SIGN ANUSVARA;Mc;0;L;;;;;N;;;;; 0B03;ORIYA SIGN VISARGA;Mc;0;L;;;;;N;;;;; @@ -2876,6 +2895,7 @@ 0CEF;KANNADA DIGIT NINE;Nd;0;L;;9;9;9;N;;;;; 0CF1;KANNADA SIGN JIHVAMULIYA;Lo;0;L;;;;;N;;;;; 0CF2;KANNADA SIGN UPADHMANIYA;Lo;0;L;;;;;N;;;;; +0D00;MALAYALAM SIGN COMBINING ANUSVARA ABOVE;Mn;0;NSM;;;;;N;;;;; 0D01;MALAYALAM SIGN CANDRABINDU;Mn;0;NSM;;;;;N;;;;; 0D02;MALAYALAM SIGN ANUSVARA;Mc;0;L;;;;;N;;;;; 0D03;MALAYALAM SIGN VISARGA;Mc;0;L;;;;;N;;;;; @@ -2931,6 +2951,8 @@ 0D38;MALAYALAM LETTER SA;Lo;0;L;;;;;N;;;;; 0D39;MALAYALAM LETTER HA;Lo;0;L;;;;;N;;;;; 0D3A;MALAYALAM LETTER TTTA;Lo;0;L;;;;;N;;;;; +0D3B;MALAYALAM SIGN VERTICAL BAR VIRAMA;Mn;9;NSM;;;;;N;;;;; +0D3C;MALAYALAM SIGN CIRCULAR VIRAMA;Mn;9;NSM;;;;;N;;;;; 0D3D;MALAYALAM SIGN AVAGRAHA;Lo;0;L;;;;;N;;;;; 0D3E;MALAYALAM VOWEL SIGN AA;Mc;0;L;;;;;N;;;;; 0D3F;MALAYALAM VOWEL SIGN I;Mc;0;L;;;;;N;;;;; @@ -6413,6 +6435,7 @@ 1CF4;VEDIC TONE CANDRA ABOVE;Mn;230;NSM;;;;;N;;;;; 1CF5;VEDIC SIGN JIHVAMULIYA;Lo;0;L;;;;;N;;;;; 1CF6;VEDIC SIGN UPADHMANIYA;Lo;0;L;;;;;N;;;;; +1CF7;VEDIC SIGN ATIKRAMA;Mc;0;L;;;;;N;;;;; 1CF8;VEDIC TONE RING ABOVE;Mn;230;NSM;;;;;N;;;;; 1CF9;VEDIC TONE DOUBLE RING ABOVE;Mn;230;NSM;;;;;N;;;;; 1D00;LATIN LETTER SMALL CAPITAL A;Ll;0;L;;;;;N;;;;; @@ -6661,6 +6684,10 @@ 1DF3;COMBINING LATIN SMALL LETTER O WITH DIAERESIS;Mn;230;NSM;;;;;N;;;;; 1DF4;COMBINING LATIN SMALL LETTER U WITH DIAERESIS;Mn;230;NSM;;;;;N;;;;; 1DF5;COMBINING UP TACK ABOVE;Mn;230;NSM;;;;;N;;;;; +1DF6;COMBINING KAVYKA ABOVE RIGHT;Mn;232;NSM;;;;;N;;;;; +1DF7;COMBINING KAVYKA ABOVE LEFT;Mn;228;NSM;;;;;N;;;;; +1DF8;COMBINING DOT ABOVE LEFT;Mn;228;NSM;;;;;N;;;;; +1DF9;COMBINING WIDE INVERTED BRIDGE BELOW;Mn;220;NSM;;;;;N;;;;; 1DFB;COMBINING DELETION MARK;Mn;230;NSM;;;;;N;;;;; 1DFC;COMBINING DOUBLE INVERTED BREVE BELOW;Mn;233;NSM;;;;;N;;;;; 1DFD;COMBINING ALMOST EQUAL TO BELOW;Mn;220;NSM;;;;;N;;;;; @@ -7339,6 +7366,7 @@ 20BC;MANAT SIGN;Sc;0;ET;;;;;N;;;;; 20BD;RUBLE SIGN;Sc;0;ET;;;;;N;;;;; 20BE;LARI SIGN;Sc;0;ET;;;;;N;;;;; +20BF;BITCOIN SIGN;Sc;0;ET;;;;;N;;;;; 20D0;COMBINING LEFT HARPOON ABOVE;Mn;230;NSM;;;;;N;NON-SPACING LEFT HARPOON ABOVE;;;; 20D1;COMBINING RIGHT HARPOON ABOVE;Mn;230;NSM;;;;;N;NON-SPACING RIGHT HARPOON ABOVE;;;; 20D2;COMBINING LONG VERTICAL LINE OVERLAY;Mn;1;NSM;;;;;N;NON-SPACING LONG VERTICAL BAR OVERLAY;;;; @@ -8135,6 +8163,7 @@ 23FC;POWER ON-OFF SYMBOL;So;0;ON;;;;;N;;;;; 23FD;POWER ON SYMBOL;So;0;ON;;;;;N;;;;; 23FE;POWER SLEEP SYMBOL;So;0;ON;;;;;N;;;;; +23FF;OBSERVER EYE SYMBOL;So;0;ON;;;;;N;;;;; 2400;SYMBOL FOR NULL;So;0;ON;;;;;N;GRAPHIC FOR NULL;;;; 2401;SYMBOL FOR START OF HEADING;So;0;ON;;;;;N;GRAPHIC FOR START OF HEADING;;;; 2402;SYMBOL FOR START OF TEXT;So;0;ON;;;;;N;GRAPHIC FOR START OF TEXT;;;; @@ -10083,6 +10112,7 @@ 2BCF;ROTATED WHITE FOUR POINTED CUSP;So;0;ON;;;;;N;;;;; 2BD0;SQUARE POSITION INDICATOR;So;0;ON;;;;;N;;;;; 2BD1;UNCERTAINTY SIGN;So;0;ON;;;;;N;;;;; +2BD2;GROUP MARK;So;0;ON;;;;;N;;;;; 2BEC;LEFTWARDS TWO-HEADED ARROW WITH TRIANGLE ARROWHEADS;So;0;ON;;;;;N;;;;; 2BED;UPWARDS TWO-HEADED ARROW WITH TRIANGLE ARROWHEADS;So;0;ON;;;;;N;;;;; 2BEE;RIGHTWARDS TWO-HEADED ARROW WITH TRIANGLE ARROWHEADS;So;0;ON;;;;;N;;;;; @@ -10615,6 +10645,11 @@ 2E42;DOUBLE LOW-REVERSED-9 QUOTATION MARK;Ps;0;ON;;;;;N;;;;; 2E43;DASH WITH LEFT UPTURN;Po;0;ON;;;;;N;;;;; 2E44;DOUBLE SUSPENSION MARK;Po;0;ON;;;;;N;;;;; +2E45;INVERTED LOW KAVYKA;Po;0;ON;;;;;N;;;;; +2E46;INVERTED LOW KAVYKA WITH KAVYKA ABOVE;Po;0;ON;;;;;N;;;;; +2E47;LOW KAVYKA;Po;0;ON;;;;;N;;;;; +2E48;LOW KAVYKA WITH DOT;Po;0;ON;;;;;N;;;;; +2E49;DOUBLE STACKED COMMA;Po;0;ON;;;;;N;;;;; 2E80;CJK RADICAL REPEAT;So;0;ON;;;;;N;;;;; 2E81;CJK RADICAL CLIFF;So;0;ON;;;;;N;;;;; 2E82;CJK RADICAL SECOND ONE;So;0;ON;;;;;N;;;;; @@ -11250,6 +11285,7 @@ 312B;BOPOMOFO LETTER NG;Lo;0;L;;;;;N;;;;; 312C;BOPOMOFO LETTER GN;Lo;0;L;;;;;N;;;;; 312D;BOPOMOFO LETTER IH;Lo;0;L;;;;;N;;;;; +312E;BOPOMOFO LETTER O WITH DOT ABOVE;Lo;0;L;;;;;N;;;;; 3131;HANGUL LETTER KIYEOK;Lo;0;L;<compat> 1100;;;;N;HANGUL LETTER GIYEOG;;;; 3132;HANGUL LETTER SSANGKIYEOK;Lo;0;L;<compat> 1101;;;;N;HANGUL LETTER SSANG GIYEOG;;;; 3133;HANGUL LETTER KIYEOK-SIOS;Lo;0;L;<compat> 11AA;;;;N;HANGUL LETTER GIYEOG SIOS;;;; @@ -12016,7 +12052,7 @@ 4DFE;HEXAGRAM FOR AFTER COMPLETION;So;0;ON;;;;;N;;;;; 4DFF;HEXAGRAM FOR BEFORE COMPLETION;So;0;ON;;;;;N;;;;; 4E00;<CJK Ideograph, First>;Lo;0;L;;;;;N;;;;; -9FD5;<CJK Ideograph, Last>;Lo;0;L;;;;;N;;;;; +9FEA;<CJK Ideograph, Last>;Lo;0;L;;;;;N;;;;; A000;YI SYLLABLE IT;Lo;0;L;;;;;N;;;;; A001;YI SYLLABLE IX;Lo;0;L;;;;;N;;;;; A002;YI SYLLABLE I;Lo;0;L;;;;;N;;;;; @@ -17093,6 +17129,9 @@ FFFD;REPLACEMENT CHARACTER;So;0;ON;;;;;N;;;;; 10321;OLD ITALIC NUMERAL FIVE;No;0;L;;;;5;N;;;;; 10322;OLD ITALIC NUMERAL TEN;No;0;L;;;;10;N;;;;; 10323;OLD ITALIC NUMERAL FIFTY;No;0;L;;;;50;N;;;;; +1032D;OLD ITALIC LETTER YE;Lo;0;L;;;;;N;;;;; +1032E;OLD ITALIC LETTER NORTHERN TSE;Lo;0;L;;;;;N;;;;; +1032F;OLD ITALIC LETTER SOUTHERN TSE;Lo;0;L;;;;;N;;;;; 10330;GOTHIC LETTER AHSA;Lo;0;L;;;;;N;;;;; 10331;GOTHIC LETTER BAIRKAN;Lo;0;L;;;;;N;;;;; 10332;GOTHIC LETTER GIBA;Lo;0;L;;;;;N;;;;; @@ -20068,6 +20107,158 @@ FFFD;REPLACEMENT CHARACTER;So;0;ON;;;;;N;;;;; 118F1;WARANG CITI NUMBER EIGHTY;No;0;L;;;;80;N;;;;; 118F2;WARANG CITI NUMBER NINETY;No;0;L;;;;90;N;;;;; 118FF;WARANG CITI OM;Lo;0;L;;;;;N;;;;; +11A00;ZANABAZAR SQUARE LETTER A;Lo;0;L;;;;;N;;;;; +11A01;ZANABAZAR SQUARE VOWEL SIGN I;Mn;0;NSM;;;;;N;;;;; +11A02;ZANABAZAR SQUARE VOWEL SIGN UE;Mn;0;NSM;;;;;N;;;;; +11A03;ZANABAZAR SQUARE VOWEL SIGN U;Mn;0;NSM;;;;;N;;;;; +11A04;ZANABAZAR SQUARE VOWEL SIGN E;Mn;0;NSM;;;;;N;;;;; +11A05;ZANABAZAR SQUARE VOWEL SIGN OE;Mn;0;NSM;;;;;N;;;;; +11A06;ZANABAZAR SQUARE VOWEL SIGN O;Mn;0;NSM;;;;;N;;;;; +11A07;ZANABAZAR SQUARE VOWEL SIGN AI;Mc;0;L;;;;;N;;;;; +11A08;ZANABAZAR SQUARE VOWEL SIGN AU;Mc;0;L;;;;;N;;;;; +11A09;ZANABAZAR SQUARE VOWEL SIGN REVERSED I;Mn;0;NSM;;;;;N;;;;; +11A0A;ZANABAZAR SQUARE VOWEL LENGTH MARK;Mn;0;NSM;;;;;N;;;;; +11A0B;ZANABAZAR SQUARE LETTER KA;Lo;0;L;;;;;N;;;;; +11A0C;ZANABAZAR SQUARE LETTER KHA;Lo;0;L;;;;;N;;;;; +11A0D;ZANABAZAR SQUARE LETTER GA;Lo;0;L;;;;;N;;;;; +11A0E;ZANABAZAR SQUARE LETTER GHA;Lo;0;L;;;;;N;;;;; +11A0F;ZANABAZAR SQUARE LETTER NGA;Lo;0;L;;;;;N;;;;; +11A10;ZANABAZAR SQUARE LETTER CA;Lo;0;L;;;;;N;;;;; +11A11;ZANABAZAR SQUARE LETTER CHA;Lo;0;L;;;;;N;;;;; +11A12;ZANABAZAR SQUARE LETTER JA;Lo;0;L;;;;;N;;;;; +11A13;ZANABAZAR SQUARE LETTER NYA;Lo;0;L;;;;;N;;;;; +11A14;ZANABAZAR SQUARE LETTER TTA;Lo;0;L;;;;;N;;;;; +11A15;ZANABAZAR SQUARE LETTER TTHA;Lo;0;L;;;;;N;;;;; +11A16;ZANABAZAR SQUARE LETTER DDA;Lo;0;L;;;;;N;;;;; +11A17;ZANABAZAR SQUARE LETTER DDHA;Lo;0;L;;;;;N;;;;; +11A18;ZANABAZAR SQUARE LETTER NNA;Lo;0;L;;;;;N;;;;; +11A19;ZANABAZAR SQUARE LETTER TA;Lo;0;L;;;;;N;;;;; +11A1A;ZANABAZAR SQUARE LETTER THA;Lo;0;L;;;;;N;;;;; +11A1B;ZANABAZAR SQUARE LETTER DA;Lo;0;L;;;;;N;;;;; +11A1C;ZANABAZAR SQUARE LETTER DHA;Lo;0;L;;;;;N;;;;; +11A1D;ZANABAZAR SQUARE LETTER NA;Lo;0;L;;;;;N;;;;; +11A1E;ZANABAZAR SQUARE LETTER PA;Lo;0;L;;;;;N;;;;; +11A1F;ZANABAZAR SQUARE LETTER PHA;Lo;0;L;;;;;N;;;;; +11A20;ZANABAZAR SQUARE LETTER BA;Lo;0;L;;;;;N;;;;; +11A21;ZANABAZAR SQUARE LETTER BHA;Lo;0;L;;;;;N;;;;; +11A22;ZANABAZAR SQUARE LETTER MA;Lo;0;L;;;;;N;;;;; +11A23;ZANABAZAR SQUARE LETTER TSA;Lo;0;L;;;;;N;;;;; +11A24;ZANABAZAR SQUARE LETTER TSHA;Lo;0;L;;;;;N;;;;; +11A25;ZANABAZAR SQUARE LETTER DZA;Lo;0;L;;;;;N;;;;; +11A26;ZANABAZAR SQUARE LETTER DZHA;Lo;0;L;;;;;N;;;;; +11A27;ZANABAZAR SQUARE LETTER ZHA;Lo;0;L;;;;;N;;;;; +11A28;ZANABAZAR SQUARE LETTER ZA;Lo;0;L;;;;;N;;;;; +11A29;ZANABAZAR SQUARE LETTER -A;Lo;0;L;;;;;N;;;;; +11A2A;ZANABAZAR SQUARE LETTER YA;Lo;0;L;;;;;N;;;;; +11A2B;ZANABAZAR SQUARE LETTER RA;Lo;0;L;;;;;N;;;;; +11A2C;ZANABAZAR SQUARE LETTER LA;Lo;0;L;;;;;N;;;;; +11A2D;ZANABAZAR SQUARE LETTER VA;Lo;0;L;;;;;N;;;;; +11A2E;ZANABAZAR SQUARE LETTER SHA;Lo;0;L;;;;;N;;;;; +11A2F;ZANABAZAR SQUARE LETTER SSA;Lo;0;L;;;;;N;;;;; +11A30;ZANABAZAR SQUARE LETTER SA;Lo;0;L;;;;;N;;;;; +11A31;ZANABAZAR SQUARE LETTER HA;Lo;0;L;;;;;N;;;;; +11A32;ZANABAZAR SQUARE LETTER KSSA;Lo;0;L;;;;;N;;;;; +11A33;ZANABAZAR SQUARE FINAL CONSONANT MARK;Mn;0;NSM;;;;;N;;;;; +11A34;ZANABAZAR SQUARE SIGN VIRAMA;Mn;9;NSM;;;;;N;;;;; +11A35;ZANABAZAR SQUARE SIGN CANDRABINDU;Mn;0;NSM;;;;;N;;;;; +11A36;ZANABAZAR SQUARE SIGN CANDRABINDU WITH ORNAMENT;Mn;0;NSM;;;;;N;;;;; +11A37;ZANABAZAR SQUARE SIGN CANDRA WITH ORNAMENT;Mn;0;NSM;;;;;N;;;;; +11A38;ZANABAZAR SQUARE SIGN ANUSVARA;Mn;0;NSM;;;;;N;;;;; +11A39;ZANABAZAR SQUARE SIGN VISARGA;Mc;0;L;;;;;N;;;;; +11A3A;ZANABAZAR SQUARE CLUSTER-INITIAL LETTER RA;Lo;0;L;;;;;N;;;;; +11A3B;ZANABAZAR SQUARE CLUSTER-FINAL LETTER YA;Mn;0;NSM;;;;;N;;;;; +11A3C;ZANABAZAR SQUARE CLUSTER-FINAL LETTER RA;Mn;0;NSM;;;;;N;;;;; +11A3D;ZANABAZAR SQUARE CLUSTER-FINAL LETTER LA;Mn;0;NSM;;;;;N;;;;; +11A3E;ZANABAZAR SQUARE CLUSTER-FINAL LETTER VA;Mn;0;NSM;;;;;N;;;;; +11A3F;ZANABAZAR SQUARE INITIAL HEAD MARK;Po;0;L;;;;;N;;;;; +11A40;ZANABAZAR SQUARE CLOSING HEAD MARK;Po;0;L;;;;;N;;;;; +11A41;ZANABAZAR SQUARE MARK TSHEG;Po;0;L;;;;;N;;;;; +11A42;ZANABAZAR SQUARE MARK SHAD;Po;0;L;;;;;N;;;;; +11A43;ZANABAZAR SQUARE MARK DOUBLE SHAD;Po;0;L;;;;;N;;;;; +11A44;ZANABAZAR SQUARE MARK LONG TSHEG;Po;0;L;;;;;N;;;;; +11A45;ZANABAZAR SQUARE INITIAL DOUBLE-LINED HEAD MARK;Po;0;L;;;;;N;;;;; +11A46;ZANABAZAR SQUARE CLOSING DOUBLE-LINED HEAD MARK;Po;0;L;;;;;N;;;;; +11A47;ZANABAZAR SQUARE SUBJOINER;Mn;9;NSM;;;;;N;;;;; +11A50;SOYOMBO LETTER A;Lo;0;L;;;;;N;;;;; +11A51;SOYOMBO VOWEL SIGN I;Mn;0;NSM;;;;;N;;;;; +11A52;SOYOMBO VOWEL SIGN UE;Mn;0;NSM;;;;;N;;;;; +11A53;SOYOMBO VOWEL SIGN U;Mn;0;NSM;;;;;N;;;;; +11A54;SOYOMBO VOWEL SIGN E;Mn;0;NSM;;;;;N;;;;; +11A55;SOYOMBO VOWEL SIGN O;Mn;0;NSM;;;;;N;;;;; +11A56;SOYOMBO VOWEL SIGN OE;Mn;0;NSM;;;;;N;;;;; +11A57;SOYOMBO VOWEL SIGN AI;Mc;0;L;;;;;N;;;;; +11A58;SOYOMBO VOWEL SIGN AU;Mc;0;L;;;;;N;;;;; +11A59;SOYOMBO VOWEL SIGN VOCALIC R;Mn;0;NSM;;;;;N;;;;; +11A5A;SOYOMBO VOWEL SIGN VOCALIC L;Mn;0;NSM;;;;;N;;;;; +11A5B;SOYOMBO VOWEL LENGTH MARK;Mn;0;NSM;;;;;N;;;;; +11A5C;SOYOMBO LETTER KA;Lo;0;L;;;;;N;;;;; +11A5D;SOYOMBO LETTER KHA;Lo;0;L;;;;;N;;;;; +11A5E;SOYOMBO LETTER GA;Lo;0;L;;;;;N;;;;; +11A5F;SOYOMBO LETTER GHA;Lo;0;L;;;;;N;;;;; +11A60;SOYOMBO LETTER NGA;Lo;0;L;;;;;N;;;;; +11A61;SOYOMBO LETTER CA;Lo;0;L;;;;;N;;;;; +11A62;SOYOMBO LETTER CHA;Lo;0;L;;;;;N;;;;; +11A63;SOYOMBO LETTER JA;Lo;0;L;;;;;N;;;;; +11A64;SOYOMBO LETTER JHA;Lo;0;L;;;;;N;;;;; +11A65;SOYOMBO LETTER NYA;Lo;0;L;;;;;N;;;;; +11A66;SOYOMBO LETTER TTA;Lo;0;L;;;;;N;;;;; +11A67;SOYOMBO LETTER TTHA;Lo;0;L;;;;;N;;;;; +11A68;SOYOMBO LETTER DDA;Lo;0;L;;;;;N;;;;; +11A69;SOYOMBO LETTER DDHA;Lo;0;L;;;;;N;;;;; +11A6A;SOYOMBO LETTER NNA;Lo;0;L;;;;;N;;;;; +11A6B;SOYOMBO LETTER TA;Lo;0;L;;;;;N;;;;; +11A6C;SOYOMBO LETTER THA;Lo;0;L;;;;;N;;;;; +11A6D;SOYOMBO LETTER DA;Lo;0;L;;;;;N;;;;; +11A6E;SOYOMBO LETTER DHA;Lo;0;L;;;;;N;;;;; +11A6F;SOYOMBO LETTER NA;Lo;0;L;;;;;N;;;;; +11A70;SOYOMBO LETTER PA;Lo;0;L;;;;;N;;;;; +11A71;SOYOMBO LETTER PHA;Lo;0;L;;;;;N;;;;; +11A72;SOYOMBO LETTER BA;Lo;0;L;;;;;N;;;;; +11A73;SOYOMBO LETTER BHA;Lo;0;L;;;;;N;;;;; +11A74;SOYOMBO LETTER MA;Lo;0;L;;;;;N;;;;; +11A75;SOYOMBO LETTER TSA;Lo;0;L;;;;;N;;;;; +11A76;SOYOMBO LETTER TSHA;Lo;0;L;;;;;N;;;;; +11A77;SOYOMBO LETTER DZA;Lo;0;L;;;;;N;;;;; +11A78;SOYOMBO LETTER ZHA;Lo;0;L;;;;;N;;;;; +11A79;SOYOMBO LETTER ZA;Lo;0;L;;;;;N;;;;; +11A7A;SOYOMBO LETTER -A;Lo;0;L;;;;;N;;;;; +11A7B;SOYOMBO LETTER YA;Lo;0;L;;;;;N;;;;; +11A7C;SOYOMBO LETTER RA;Lo;0;L;;;;;N;;;;; +11A7D;SOYOMBO LETTER LA;Lo;0;L;;;;;N;;;;; +11A7E;SOYOMBO LETTER VA;Lo;0;L;;;;;N;;;;; +11A7F;SOYOMBO LETTER SHA;Lo;0;L;;;;;N;;;;; +11A80;SOYOMBO LETTER SSA;Lo;0;L;;;;;N;;;;; +11A81;SOYOMBO LETTER SA;Lo;0;L;;;;;N;;;;; +11A82;SOYOMBO LETTER HA;Lo;0;L;;;;;N;;;;; +11A83;SOYOMBO LETTER KSSA;Lo;0;L;;;;;N;;;;; +11A86;SOYOMBO CLUSTER-INITIAL LETTER RA;Lo;0;L;;;;;N;;;;; +11A87;SOYOMBO CLUSTER-INITIAL LETTER LA;Lo;0;L;;;;;N;;;;; +11A88;SOYOMBO CLUSTER-INITIAL LETTER SHA;Lo;0;L;;;;;N;;;;; +11A89;SOYOMBO CLUSTER-INITIAL LETTER SA;Lo;0;L;;;;;N;;;;; +11A8A;SOYOMBO FINAL CONSONANT SIGN G;Mn;0;NSM;;;;;N;;;;; +11A8B;SOYOMBO FINAL CONSONANT SIGN K;Mn;0;NSM;;;;;N;;;;; +11A8C;SOYOMBO FINAL CONSONANT SIGN NG;Mn;0;NSM;;;;;N;;;;; +11A8D;SOYOMBO FINAL CONSONANT SIGN D;Mn;0;NSM;;;;;N;;;;; +11A8E;SOYOMBO FINAL CONSONANT SIGN N;Mn;0;NSM;;;;;N;;;;; +11A8F;SOYOMBO FINAL CONSONANT SIGN B;Mn;0;NSM;;;;;N;;;;; +11A90;SOYOMBO FINAL CONSONANT SIGN M;Mn;0;NSM;;;;;N;;;;; +11A91;SOYOMBO FINAL CONSONANT SIGN R;Mn;0;NSM;;;;;N;;;;; +11A92;SOYOMBO FINAL CONSONANT SIGN L;Mn;0;NSM;;;;;N;;;;; +11A93;SOYOMBO FINAL CONSONANT SIGN SH;Mn;0;NSM;;;;;N;;;;; +11A94;SOYOMBO FINAL CONSONANT SIGN S;Mn;0;NSM;;;;;N;;;;; +11A95;SOYOMBO FINAL CONSONANT SIGN -A;Mn;0;NSM;;;;;N;;;;; +11A96;SOYOMBO SIGN ANUSVARA;Mn;0;NSM;;;;;N;;;;; +11A97;SOYOMBO SIGN VISARGA;Mc;0;L;;;;;N;;;;; +11A98;SOYOMBO GEMINATION MARK;Mn;0;NSM;;;;;N;;;;; +11A99;SOYOMBO SUBJOINER;Mn;9;NSM;;;;;N;;;;; +11A9A;SOYOMBO MARK TSHEG;Po;0;L;;;;;N;;;;; +11A9B;SOYOMBO MARK SHAD;Po;0;L;;;;;N;;;;; +11A9C;SOYOMBO MARK DOUBLE SHAD;Po;0;L;;;;;N;;;;; +11A9E;SOYOMBO HEAD MARK WITH MOON AND SUN AND TRIPLE FLAME;Po;0;L;;;;;N;;;;; +11A9F;SOYOMBO HEAD MARK WITH MOON AND SUN AND FLAME;Po;0;L;;;;;N;;;;; +11AA0;SOYOMBO HEAD MARK WITH MOON AND SUN;Po;0;L;;;;;N;;;;; +11AA1;SOYOMBO TERMINAL MARK-1;Po;0;L;;;;;N;;;;; +11AA2;SOYOMBO TERMINAL MARK-2;Po;0;L;;;;;N;;;;; 11AC0;PAU CIN HAU LETTER PA;Lo;0;L;;;;;N;;;;; 11AC1;PAU CIN HAU LETTER KA;Lo;0;L;;;;;N;;;;; 11AC2;PAU CIN HAU LETTER LA;Lo;0;L;;;;;N;;;;; @@ -20290,6 +20481,81 @@ FFFD;REPLACEMENT CHARACTER;So;0;ON;;;;;N;;;;; 11CB4;MARCHEN VOWEL SIGN O;Mc;0;L;;;;;N;;;;; 11CB5;MARCHEN SIGN ANUSVARA;Mn;0;NSM;;;;;N;;;;; 11CB6;MARCHEN SIGN CANDRABINDU;Mn;0;NSM;;;;;N;;;;; +11D00;MASARAM GONDI LETTER A;Lo;0;L;;;;;N;;;;; +11D01;MASARAM GONDI LETTER AA;Lo;0;L;;;;;N;;;;; +11D02;MASARAM GONDI LETTER I;Lo;0;L;;;;;N;;;;; +11D03;MASARAM GONDI LETTER II;Lo;0;L;;;;;N;;;;; +11D04;MASARAM GONDI LETTER U;Lo;0;L;;;;;N;;;;; +11D05;MASARAM GONDI LETTER UU;Lo;0;L;;;;;N;;;;; +11D06;MASARAM GONDI LETTER E;Lo;0;L;;;;;N;;;;; +11D08;MASARAM GONDI LETTER AI;Lo;0;L;;;;;N;;;;; +11D09;MASARAM GONDI LETTER O;Lo;0;L;;;;;N;;;;; +11D0B;MASARAM GONDI LETTER AU;Lo;0;L;;;;;N;;;;; +11D0C;MASARAM GONDI LETTER KA;Lo;0;L;;;;;N;;;;; +11D0D;MASARAM GONDI LETTER KHA;Lo;0;L;;;;;N;;;;; +11D0E;MASARAM GONDI LETTER GA;Lo;0;L;;;;;N;;;;; +11D0F;MASARAM GONDI LETTER GHA;Lo;0;L;;;;;N;;;;; +11D10;MASARAM GONDI LETTER NGA;Lo;0;L;;;;;N;;;;; +11D11;MASARAM GONDI LETTER CA;Lo;0;L;;;;;N;;;;; +11D12;MASARAM GONDI LETTER CHA;Lo;0;L;;;;;N;;;;; +11D13;MASARAM GONDI LETTER JA;Lo;0;L;;;;;N;;;;; +11D14;MASARAM GONDI LETTER JHA;Lo;0;L;;;;;N;;;;; +11D15;MASARAM GONDI LETTER NYA;Lo;0;L;;;;;N;;;;; +11D16;MASARAM GONDI LETTER TTA;Lo;0;L;;;;;N;;;;; +11D17;MASARAM GONDI LETTER TTHA;Lo;0;L;;;;;N;;;;; +11D18;MASARAM GONDI LETTER DDA;Lo;0;L;;;;;N;;;;; +11D19;MASARAM GONDI LETTER DDHA;Lo;0;L;;;;;N;;;;; +11D1A;MASARAM GONDI LETTER NNA;Lo;0;L;;;;;N;;;;; +11D1B;MASARAM GONDI LETTER TA;Lo;0;L;;;;;N;;;;; +11D1C;MASARAM GONDI LETTER THA;Lo;0;L;;;;;N;;;;; +11D1D;MASARAM GONDI LETTER DA;Lo;0;L;;;;;N;;;;; +11D1E;MASARAM GONDI LETTER DHA;Lo;0;L;;;;;N;;;;; +11D1F;MASARAM GONDI LETTER NA;Lo;0;L;;;;;N;;;;; +11D20;MASARAM GONDI LETTER PA;Lo;0;L;;;;;N;;;;; +11D21;MASARAM GONDI LETTER PHA;Lo;0;L;;;;;N;;;;; +11D22;MASARAM GONDI LETTER BA;Lo;0;L;;;;;N;;;;; +11D23;MASARAM GONDI LETTER BHA;Lo;0;L;;;;;N;;;;; +11D24;MASARAM GONDI LETTER MA;Lo;0;L;;;;;N;;;;; +11D25;MASARAM GONDI LETTER YA;Lo;0;L;;;;;N;;;;; +11D26;MASARAM GONDI LETTER RA;Lo;0;L;;;;;N;;;;; +11D27;MASARAM GONDI LETTER LA;Lo;0;L;;;;;N;;;;; +11D28;MASARAM GONDI LETTER VA;Lo;0;L;;;;;N;;;;; +11D29;MASARAM GONDI LETTER SHA;Lo;0;L;;;;;N;;;;; +11D2A;MASARAM GONDI LETTER SSA;Lo;0;L;;;;;N;;;;; +11D2B;MASARAM GONDI LETTER SA;Lo;0;L;;;;;N;;;;; +11D2C;MASARAM GONDI LETTER HA;Lo;0;L;;;;;N;;;;; +11D2D;MASARAM GONDI LETTER LLA;Lo;0;L;;;;;N;;;;; +11D2E;MASARAM GONDI LETTER KSSA;Lo;0;L;;;;;N;;;;; +11D2F;MASARAM GONDI LETTER JNYA;Lo;0;L;;;;;N;;;;; +11D30;MASARAM GONDI LETTER TRA;Lo;0;L;;;;;N;;;;; +11D31;MASARAM GONDI VOWEL SIGN AA;Mn;0;NSM;;;;;N;;;;; +11D32;MASARAM GONDI VOWEL SIGN I;Mn;0;NSM;;;;;N;;;;; +11D33;MASARAM GONDI VOWEL SIGN II;Mn;0;NSM;;;;;N;;;;; +11D34;MASARAM GONDI VOWEL SIGN U;Mn;0;NSM;;;;;N;;;;; +11D35;MASARAM GONDI VOWEL SIGN UU;Mn;0;NSM;;;;;N;;;;; +11D36;MASARAM GONDI VOWEL SIGN VOCALIC R;Mn;0;NSM;;;;;N;;;;; +11D3A;MASARAM GONDI VOWEL SIGN E;Mn;0;NSM;;;;;N;;;;; +11D3C;MASARAM GONDI VOWEL SIGN AI;Mn;0;NSM;;;;;N;;;;; +11D3D;MASARAM GONDI VOWEL SIGN O;Mn;0;NSM;;;;;N;;;;; +11D3F;MASARAM GONDI VOWEL SIGN AU;Mn;0;NSM;;;;;N;;;;; +11D40;MASARAM GONDI SIGN ANUSVARA;Mn;0;NSM;;;;;N;;;;; +11D41;MASARAM GONDI SIGN VISARGA;Mn;0;NSM;;;;;N;;;;; +11D42;MASARAM GONDI SIGN NUKTA;Mn;7;NSM;;;;;N;;;;; +11D43;MASARAM GONDI SIGN CANDRA;Mn;0;NSM;;;;;N;;;;; +11D44;MASARAM GONDI SIGN HALANTA;Mn;9;NSM;;;;;N;;;;; +11D45;MASARAM GONDI VIRAMA;Mn;9;NSM;;;;;N;;;;; +11D46;MASARAM GONDI REPHA;Lo;0;L;;;;;N;;;;; +11D47;MASARAM GONDI RA-KARA;Mn;0;NSM;;;;;N;;;;; +11D50;MASARAM GONDI DIGIT ZERO;Nd;0;L;;0;0;0;N;;;;; +11D51;MASARAM GONDI DIGIT ONE;Nd;0;L;;1;1;1;N;;;;; +11D52;MASARAM GONDI DIGIT TWO;Nd;0;L;;2;2;2;N;;;;; +11D53;MASARAM GONDI DIGIT THREE;Nd;0;L;;3;3;3;N;;;;; +11D54;MASARAM GONDI DIGIT FOUR;Nd;0;L;;4;4;4;N;;;;; +11D55;MASARAM GONDI DIGIT FIVE;Nd;0;L;;5;5;5;N;;;;; +11D56;MASARAM GONDI DIGIT SIX;Nd;0;L;;6;6;6;N;;;;; +11D57;MASARAM GONDI DIGIT SEVEN;Nd;0;L;;7;7;7;N;;;;; +11D58;MASARAM GONDI DIGIT EIGHT;Nd;0;L;;8;8;8;N;;;;; +11D59;MASARAM GONDI DIGIT NINE;Nd;0;L;;9;9;9;N;;;;; 12000;CUNEIFORM SIGN A;Lo;0;L;;;;;N;;;;; 12001;CUNEIFORM SIGN A TIMES A;Lo;0;L;;;;;N;;;;; 12002;CUNEIFORM SIGN A TIMES BAD;Lo;0;L;;;;;N;;;;; @@ -24087,6 +24353,7 @@ FFFD;REPLACEMENT CHARACTER;So;0;ON;;;;;N;;;;; 16F9E;MIAO LETTER REFORMED TONE-6;Lm;0;L;;;;;N;;;;; 16F9F;MIAO LETTER REFORMED TONE-8;Lm;0;L;;;;;N;;;;; 16FE0;TANGUT ITERATION MARK;Lm;0;L;;;;;N;;;;; +16FE1;NUSHU ITERATION MARK;Lm;0;L;;;;;N;;;;; 17000;<Tangut Ideograph, First>;Lo;0;L;;;;;N;;;;; 187EC;<Tangut Ideograph, Last>;Lo;0;L;;;;;N;;;;; 18800;TANGUT COMPONENT-001;Lo;0;L;;;;;N;;;;; @@ -24846,6 +25113,687 @@ FFFD;REPLACEMENT CHARACTER;So;0;ON;;;;;N;;;;; 18AF2;TANGUT COMPONENT-755;Lo;0;L;;;;;N;;;;; 1B000;KATAKANA LETTER ARCHAIC E;Lo;0;L;;;;;N;;;;; 1B001;HIRAGANA LETTER ARCHAIC YE;Lo;0;L;;;;;N;;;;; +1B002;HENTAIGANA LETTER A-1;Lo;0;L;;;;;N;;;;; +1B003;HENTAIGANA LETTER A-2;Lo;0;L;;;;;N;;;;; +1B004;HENTAIGANA LETTER A-3;Lo;0;L;;;;;N;;;;; +1B005;HENTAIGANA LETTER A-WO;Lo;0;L;;;;;N;;;;; +1B006;HENTAIGANA LETTER I-1;Lo;0;L;;;;;N;;;;; +1B007;HENTAIGANA LETTER I-2;Lo;0;L;;;;;N;;;;; +1B008;HENTAIGANA LETTER I-3;Lo;0;L;;;;;N;;;;; +1B009;HENTAIGANA LETTER I-4;Lo;0;L;;;;;N;;;;; +1B00A;HENTAIGANA LETTER U-1;Lo;0;L;;;;;N;;;;; +1B00B;HENTAIGANA LETTER U-2;Lo;0;L;;;;;N;;;;; +1B00C;HENTAIGANA LETTER U-3;Lo;0;L;;;;;N;;;;; +1B00D;HENTAIGANA LETTER U-4;Lo;0;L;;;;;N;;;;; +1B00E;HENTAIGANA LETTER U-5;Lo;0;L;;;;;N;;;;; +1B00F;HENTAIGANA LETTER E-2;Lo;0;L;;;;;N;;;;; +1B010;HENTAIGANA LETTER E-3;Lo;0;L;;;;;N;;;;; +1B011;HENTAIGANA LETTER E-4;Lo;0;L;;;;;N;;;;; +1B012;HENTAIGANA LETTER E-5;Lo;0;L;;;;;N;;;;; +1B013;HENTAIGANA LETTER E-6;Lo;0;L;;;;;N;;;;; +1B014;HENTAIGANA LETTER O-1;Lo;0;L;;;;;N;;;;; +1B015;HENTAIGANA LETTER O-2;Lo;0;L;;;;;N;;;;; +1B016;HENTAIGANA LETTER O-3;Lo;0;L;;;;;N;;;;; +1B017;HENTAIGANA LETTER KA-1;Lo;0;L;;;;;N;;;;; +1B018;HENTAIGANA LETTER KA-2;Lo;0;L;;;;;N;;;;; +1B019;HENTAIGANA LETTER KA-3;Lo;0;L;;;;;N;;;;; +1B01A;HENTAIGANA LETTER KA-4;Lo;0;L;;;;;N;;;;; +1B01B;HENTAIGANA LETTER KA-5;Lo;0;L;;;;;N;;;;; +1B01C;HENTAIGANA LETTER KA-6;Lo;0;L;;;;;N;;;;; +1B01D;HENTAIGANA LETTER KA-7;Lo;0;L;;;;;N;;;;; +1B01E;HENTAIGANA LETTER KA-8;Lo;0;L;;;;;N;;;;; +1B01F;HENTAIGANA LETTER KA-9;Lo;0;L;;;;;N;;;;; +1B020;HENTAIGANA LETTER KA-10;Lo;0;L;;;;;N;;;;; +1B021;HENTAIGANA LETTER KA-11;Lo;0;L;;;;;N;;;;; +1B022;HENTAIGANA LETTER KA-KE;Lo;0;L;;;;;N;;;;; +1B023;HENTAIGANA LETTER KI-1;Lo;0;L;;;;;N;;;;; +1B024;HENTAIGANA LETTER KI-2;Lo;0;L;;;;;N;;;;; +1B025;HENTAIGANA LETTER KI-3;Lo;0;L;;;;;N;;;;; +1B026;HENTAIGANA LETTER KI-4;Lo;0;L;;;;;N;;;;; +1B027;HENTAIGANA LETTER KI-5;Lo;0;L;;;;;N;;;;; +1B028;HENTAIGANA LETTER KI-6;Lo;0;L;;;;;N;;;;; +1B029;HENTAIGANA LETTER KI-7;Lo;0;L;;;;;N;;;;; +1B02A;HENTAIGANA LETTER KI-8;Lo;0;L;;;;;N;;;;; +1B02B;HENTAIGANA LETTER KU-1;Lo;0;L;;;;;N;;;;; +1B02C;HENTAIGANA LETTER KU-2;Lo;0;L;;;;;N;;;;; +1B02D;HENTAIGANA LETTER KU-3;Lo;0;L;;;;;N;;;;; +1B02E;HENTAIGANA LETTER KU-4;Lo;0;L;;;;;N;;;;; +1B02F;HENTAIGANA LETTER KU-5;Lo;0;L;;;;;N;;;;; +1B030;HENTAIGANA LETTER KU-6;Lo;0;L;;;;;N;;;;; +1B031;HENTAIGANA LETTER KU-7;Lo;0;L;;;;;N;;;;; +1B032;HENTAIGANA LETTER KE-1;Lo;0;L;;;;;N;;;;; +1B033;HENTAIGANA LETTER KE-2;Lo;0;L;;;;;N;;;;; +1B034;HENTAIGANA LETTER KE-3;Lo;0;L;;;;;N;;;;; +1B035;HENTAIGANA LETTER KE-4;Lo;0;L;;;;;N;;;;; +1B036;HENTAIGANA LETTER KE-5;Lo;0;L;;;;;N;;;;; +1B037;HENTAIGANA LETTER KE-6;Lo;0;L;;;;;N;;;;; +1B038;HENTAIGANA LETTER KO-1;Lo;0;L;;;;;N;;;;; +1B039;HENTAIGANA LETTER KO-2;Lo;0;L;;;;;N;;;;; +1B03A;HENTAIGANA LETTER KO-3;Lo;0;L;;;;;N;;;;; +1B03B;HENTAIGANA LETTER KO-KI;Lo;0;L;;;;;N;;;;; +1B03C;HENTAIGANA LETTER SA-1;Lo;0;L;;;;;N;;;;; +1B03D;HENTAIGANA LETTER SA-2;Lo;0;L;;;;;N;;;;; +1B03E;HENTAIGANA LETTER SA-3;Lo;0;L;;;;;N;;;;; +1B03F;HENTAIGANA LETTER SA-4;Lo;0;L;;;;;N;;;;; +1B040;HENTAIGANA LETTER SA-5;Lo;0;L;;;;;N;;;;; +1B041;HENTAIGANA LETTER SA-6;Lo;0;L;;;;;N;;;;; +1B042;HENTAIGANA LETTER SA-7;Lo;0;L;;;;;N;;;;; +1B043;HENTAIGANA LETTER SA-8;Lo;0;L;;;;;N;;;;; +1B044;HENTAIGANA LETTER SI-1;Lo;0;L;;;;;N;;;;; +1B045;HENTAIGANA LETTER SI-2;Lo;0;L;;;;;N;;;;; +1B046;HENTAIGANA LETTER SI-3;Lo;0;L;;;;;N;;;;; +1B047;HENTAIGANA LETTER SI-4;Lo;0;L;;;;;N;;;;; +1B048;HENTAIGANA LETTER SI-5;Lo;0;L;;;;;N;;;;; +1B049;HENTAIGANA LETTER SI-6;Lo;0;L;;;;;N;;;;; +1B04A;HENTAIGANA LETTER SU-1;Lo;0;L;;;;;N;;;;; +1B04B;HENTAIGANA LETTER SU-2;Lo;0;L;;;;;N;;;;; +1B04C;HENTAIGANA LETTER SU-3;Lo;0;L;;;;;N;;;;; +1B04D;HENTAIGANA LETTER SU-4;Lo;0;L;;;;;N;;;;; +1B04E;HENTAIGANA LETTER SU-5;Lo;0;L;;;;;N;;;;; +1B04F;HENTAIGANA LETTER SU-6;Lo;0;L;;;;;N;;;;; +1B050;HENTAIGANA LETTER SU-7;Lo;0;L;;;;;N;;;;; +1B051;HENTAIGANA LETTER SU-8;Lo;0;L;;;;;N;;;;; +1B052;HENTAIGANA LETTER SE-1;Lo;0;L;;;;;N;;;;; +1B053;HENTAIGANA LETTER SE-2;Lo;0;L;;;;;N;;;;; +1B054;HENTAIGANA LETTER SE-3;Lo;0;L;;;;;N;;;;; +1B055;HENTAIGANA LETTER SE-4;Lo;0;L;;;;;N;;;;; +1B056;HENTAIGANA LETTER SE-5;Lo;0;L;;;;;N;;;;; +1B057;HENTAIGANA LETTER SO-1;Lo;0;L;;;;;N;;;;; +1B058;HENTAIGANA LETTER SO-2;Lo;0;L;;;;;N;;;;; +1B059;HENTAIGANA LETTER SO-3;Lo;0;L;;;;;N;;;;; +1B05A;HENTAIGANA LETTER SO-4;Lo;0;L;;;;;N;;;;; +1B05B;HENTAIGANA LETTER SO-5;Lo;0;L;;;;;N;;;;; +1B05C;HENTAIGANA LETTER SO-6;Lo;0;L;;;;;N;;;;; +1B05D;HENTAIGANA LETTER SO-7;Lo;0;L;;;;;N;;;;; +1B05E;HENTAIGANA LETTER TA-1;Lo;0;L;;;;;N;;;;; +1B05F;HENTAIGANA LETTER TA-2;Lo;0;L;;;;;N;;;;; +1B060;HENTAIGANA LETTER TA-3;Lo;0;L;;;;;N;;;;; +1B061;HENTAIGANA LETTER TA-4;Lo;0;L;;;;;N;;;;; +1B062;HENTAIGANA LETTER TI-1;Lo;0;L;;;;;N;;;;; +1B063;HENTAIGANA LETTER TI-2;Lo;0;L;;;;;N;;;;; +1B064;HENTAIGANA LETTER TI-3;Lo;0;L;;;;;N;;;;; +1B065;HENTAIGANA LETTER TI-4;Lo;0;L;;;;;N;;;;; +1B066;HENTAIGANA LETTER TI-5;Lo;0;L;;;;;N;;;;; +1B067;HENTAIGANA LETTER TI-6;Lo;0;L;;;;;N;;;;; +1B068;HENTAIGANA LETTER TI-7;Lo;0;L;;;;;N;;;;; +1B069;HENTAIGANA LETTER TU-1;Lo;0;L;;;;;N;;;;; +1B06A;HENTAIGANA LETTER TU-2;Lo;0;L;;;;;N;;;;; +1B06B;HENTAIGANA LETTER TU-3;Lo;0;L;;;;;N;;;;; +1B06C;HENTAIGANA LETTER TU-4;Lo;0;L;;;;;N;;;;; +1B06D;HENTAIGANA LETTER TU-TO;Lo;0;L;;;;;N;;;;; +1B06E;HENTAIGANA LETTER TE-1;Lo;0;L;;;;;N;;;;; +1B06F;HENTAIGANA LETTER TE-2;Lo;0;L;;;;;N;;;;; +1B070;HENTAIGANA LETTER TE-3;Lo;0;L;;;;;N;;;;; +1B071;HENTAIGANA LETTER TE-4;Lo;0;L;;;;;N;;;;; +1B072;HENTAIGANA LETTER TE-5;Lo;0;L;;;;;N;;;;; +1B073;HENTAIGANA LETTER TE-6;Lo;0;L;;;;;N;;;;; +1B074;HENTAIGANA LETTER TE-7;Lo;0;L;;;;;N;;;;; +1B075;HENTAIGANA LETTER TE-8;Lo;0;L;;;;;N;;;;; +1B076;HENTAIGANA LETTER TE-9;Lo;0;L;;;;;N;;;;; +1B077;HENTAIGANA LETTER TO-1;Lo;0;L;;;;;N;;;;; +1B078;HENTAIGANA LETTER TO-2;Lo;0;L;;;;;N;;;;; +1B079;HENTAIGANA LETTER TO-3;Lo;0;L;;;;;N;;;;; +1B07A;HENTAIGANA LETTER TO-4;Lo;0;L;;;;;N;;;;; +1B07B;HENTAIGANA LETTER TO-5;Lo;0;L;;;;;N;;;;; +1B07C;HENTAIGANA LETTER TO-6;Lo;0;L;;;;;N;;;;; +1B07D;HENTAIGANA LETTER TO-RA;Lo;0;L;;;;;N;;;;; +1B07E;HENTAIGANA LETTER NA-1;Lo;0;L;;;;;N;;;;; +1B07F;HENTAIGANA LETTER NA-2;Lo;0;L;;;;;N;;;;; +1B080;HENTAIGANA LETTER NA-3;Lo;0;L;;;;;N;;;;; +1B081;HENTAIGANA LETTER NA-4;Lo;0;L;;;;;N;;;;; +1B082;HENTAIGANA LETTER NA-5;Lo;0;L;;;;;N;;;;; +1B083;HENTAIGANA LETTER NA-6;Lo;0;L;;;;;N;;;;; +1B084;HENTAIGANA LETTER NA-7;Lo;0;L;;;;;N;;;;; +1B085;HENTAIGANA LETTER NA-8;Lo;0;L;;;;;N;;;;; +1B086;HENTAIGANA LETTER NA-9;Lo;0;L;;;;;N;;;;; +1B087;HENTAIGANA LETTER NI-1;Lo;0;L;;;;;N;;;;; +1B088;HENTAIGANA LETTER NI-2;Lo;0;L;;;;;N;;;;; +1B089;HENTAIGANA LETTER NI-3;Lo;0;L;;;;;N;;;;; +1B08A;HENTAIGANA LETTER NI-4;Lo;0;L;;;;;N;;;;; +1B08B;HENTAIGANA LETTER NI-5;Lo;0;L;;;;;N;;;;; +1B08C;HENTAIGANA LETTER NI-6;Lo;0;L;;;;;N;;;;; +1B08D;HENTAIGANA LETTER NI-7;Lo;0;L;;;;;N;;;;; +1B08E;HENTAIGANA LETTER NI-TE;Lo;0;L;;;;;N;;;;; +1B08F;HENTAIGANA LETTER NU-1;Lo;0;L;;;;;N;;;;; +1B090;HENTAIGANA LETTER NU-2;Lo;0;L;;;;;N;;;;; +1B091;HENTAIGANA LETTER NU-3;Lo;0;L;;;;;N;;;;; +1B092;HENTAIGANA LETTER NE-1;Lo;0;L;;;;;N;;;;; +1B093;HENTAIGANA LETTER NE-2;Lo;0;L;;;;;N;;;;; +1B094;HENTAIGANA LETTER NE-3;Lo;0;L;;;;;N;;;;; +1B095;HENTAIGANA LETTER NE-4;Lo;0;L;;;;;N;;;;; +1B096;HENTAIGANA LETTER NE-5;Lo;0;L;;;;;N;;;;; +1B097;HENTAIGANA LETTER NE-6;Lo;0;L;;;;;N;;;;; +1B098;HENTAIGANA LETTER NE-KO;Lo;0;L;;;;;N;;;;; +1B099;HENTAIGANA LETTER NO-1;Lo;0;L;;;;;N;;;;; +1B09A;HENTAIGANA LETTER NO-2;Lo;0;L;;;;;N;;;;; +1B09B;HENTAIGANA LETTER NO-3;Lo;0;L;;;;;N;;;;; +1B09C;HENTAIGANA LETTER NO-4;Lo;0;L;;;;;N;;;;; +1B09D;HENTAIGANA LETTER NO-5;Lo;0;L;;;;;N;;;;; +1B09E;HENTAIGANA LETTER HA-1;Lo;0;L;;;;;N;;;;; +1B09F;HENTAIGANA LETTER HA-2;Lo;0;L;;;;;N;;;;; +1B0A0;HENTAIGANA LETTER HA-3;Lo;0;L;;;;;N;;;;; +1B0A1;HENTAIGANA LETTER HA-4;Lo;0;L;;;;;N;;;;; +1B0A2;HENTAIGANA LETTER HA-5;Lo;0;L;;;;;N;;;;; +1B0A3;HENTAIGANA LETTER HA-6;Lo;0;L;;;;;N;;;;; +1B0A4;HENTAIGANA LETTER HA-7;Lo;0;L;;;;;N;;;;; +1B0A5;HENTAIGANA LETTER HA-8;Lo;0;L;;;;;N;;;;; +1B0A6;HENTAIGANA LETTER HA-9;Lo;0;L;;;;;N;;;;; +1B0A7;HENTAIGANA LETTER HA-10;Lo;0;L;;;;;N;;;;; +1B0A8;HENTAIGANA LETTER HA-11;Lo;0;L;;;;;N;;;;; +1B0A9;HENTAIGANA LETTER HI-1;Lo;0;L;;;;;N;;;;; +1B0AA;HENTAIGANA LETTER HI-2;Lo;0;L;;;;;N;;;;; +1B0AB;HENTAIGANA LETTER HI-3;Lo;0;L;;;;;N;;;;; +1B0AC;HENTAIGANA LETTER HI-4;Lo;0;L;;;;;N;;;;; +1B0AD;HENTAIGANA LETTER HI-5;Lo;0;L;;;;;N;;;;; +1B0AE;HENTAIGANA LETTER HI-6;Lo;0;L;;;;;N;;;;; +1B0AF;HENTAIGANA LETTER HI-7;Lo;0;L;;;;;N;;;;; +1B0B0;HENTAIGANA LETTER HU-1;Lo;0;L;;;;;N;;;;; +1B0B1;HENTAIGANA LETTER HU-2;Lo;0;L;;;;;N;;;;; +1B0B2;HENTAIGANA LETTER HU-3;Lo;0;L;;;;;N;;;;; +1B0B3;HENTAIGANA LETTER HE-1;Lo;0;L;;;;;N;;;;; +1B0B4;HENTAIGANA LETTER HE-2;Lo;0;L;;;;;N;;;;; +1B0B5;HENTAIGANA LETTER HE-3;Lo;0;L;;;;;N;;;;; +1B0B6;HENTAIGANA LETTER HE-4;Lo;0;L;;;;;N;;;;; +1B0B7;HENTAIGANA LETTER HE-5;Lo;0;L;;;;;N;;;;; +1B0B8;HENTAIGANA LETTER HE-6;Lo;0;L;;;;;N;;;;; +1B0B9;HENTAIGANA LETTER HE-7;Lo;0;L;;;;;N;;;;; +1B0BA;HENTAIGANA LETTER HO-1;Lo;0;L;;;;;N;;;;; +1B0BB;HENTAIGANA LETTER HO-2;Lo;0;L;;;;;N;;;;; +1B0BC;HENTAIGANA LETTER HO-3;Lo;0;L;;;;;N;;;;; +1B0BD;HENTAIGANA LETTER HO-4;Lo;0;L;;;;;N;;;;; +1B0BE;HENTAIGANA LETTER HO-5;Lo;0;L;;;;;N;;;;; +1B0BF;HENTAIGANA LETTER HO-6;Lo;0;L;;;;;N;;;;; +1B0C0;HENTAIGANA LETTER HO-7;Lo;0;L;;;;;N;;;;; +1B0C1;HENTAIGANA LETTER HO-8;Lo;0;L;;;;;N;;;;; +1B0C2;HENTAIGANA LETTER MA-1;Lo;0;L;;;;;N;;;;; +1B0C3;HENTAIGANA LETTER MA-2;Lo;0;L;;;;;N;;;;; +1B0C4;HENTAIGANA LETTER MA-3;Lo;0;L;;;;;N;;;;; +1B0C5;HENTAIGANA LETTER MA-4;Lo;0;L;;;;;N;;;;; +1B0C6;HENTAIGANA LETTER MA-5;Lo;0;L;;;;;N;;;;; +1B0C7;HENTAIGANA LETTER MA-6;Lo;0;L;;;;;N;;;;; +1B0C8;HENTAIGANA LETTER MA-7;Lo;0;L;;;;;N;;;;; +1B0C9;HENTAIGANA LETTER MI-1;Lo;0;L;;;;;N;;;;; +1B0CA;HENTAIGANA LETTER MI-2;Lo;0;L;;;;;N;;;;; +1B0CB;HENTAIGANA LETTER MI-3;Lo;0;L;;;;;N;;;;; +1B0CC;HENTAIGANA LETTER MI-4;Lo;0;L;;;;;N;;;;; +1B0CD;HENTAIGANA LETTER MI-5;Lo;0;L;;;;;N;;;;; +1B0CE;HENTAIGANA LETTER MI-6;Lo;0;L;;;;;N;;;;; +1B0CF;HENTAIGANA LETTER MI-7;Lo;0;L;;;;;N;;;;; +1B0D0;HENTAIGANA LETTER MU-1;Lo;0;L;;;;;N;;;;; +1B0D1;HENTAIGANA LETTER MU-2;Lo;0;L;;;;;N;;;;; +1B0D2;HENTAIGANA LETTER MU-3;Lo;0;L;;;;;N;;;;; +1B0D3;HENTAIGANA LETTER MU-4;Lo;0;L;;;;;N;;;;; +1B0D4;HENTAIGANA LETTER ME-1;Lo;0;L;;;;;N;;;;; +1B0D5;HENTAIGANA LETTER ME-2;Lo;0;L;;;;;N;;;;; +1B0D6;HENTAIGANA LETTER ME-MA;Lo;0;L;;;;;N;;;;; +1B0D7;HENTAIGANA LETTER MO-1;Lo;0;L;;;;;N;;;;; +1B0D8;HENTAIGANA LETTER MO-2;Lo;0;L;;;;;N;;;;; +1B0D9;HENTAIGANA LETTER MO-3;Lo;0;L;;;;;N;;;;; +1B0DA;HENTAIGANA LETTER MO-4;Lo;0;L;;;;;N;;;;; +1B0DB;HENTAIGANA LETTER MO-5;Lo;0;L;;;;;N;;;;; +1B0DC;HENTAIGANA LETTER MO-6;Lo;0;L;;;;;N;;;;; +1B0DD;HENTAIGANA LETTER YA-1;Lo;0;L;;;;;N;;;;; +1B0DE;HENTAIGANA LETTER YA-2;Lo;0;L;;;;;N;;;;; +1B0DF;HENTAIGANA LETTER YA-3;Lo;0;L;;;;;N;;;;; +1B0E0;HENTAIGANA LETTER YA-4;Lo;0;L;;;;;N;;;;; +1B0E1;HENTAIGANA LETTER YA-5;Lo;0;L;;;;;N;;;;; +1B0E2;HENTAIGANA LETTER YA-YO;Lo;0;L;;;;;N;;;;; +1B0E3;HENTAIGANA LETTER YU-1;Lo;0;L;;;;;N;;;;; +1B0E4;HENTAIGANA LETTER YU-2;Lo;0;L;;;;;N;;;;; +1B0E5;HENTAIGANA LETTER YU-3;Lo;0;L;;;;;N;;;;; +1B0E6;HENTAIGANA LETTER YU-4;Lo;0;L;;;;;N;;;;; +1B0E7;HENTAIGANA LETTER YO-1;Lo;0;L;;;;;N;;;;; +1B0E8;HENTAIGANA LETTER YO-2;Lo;0;L;;;;;N;;;;; +1B0E9;HENTAIGANA LETTER YO-3;Lo;0;L;;;;;N;;;;; +1B0EA;HENTAIGANA LETTER YO-4;Lo;0;L;;;;;N;;;;; +1B0EB;HENTAIGANA LETTER YO-5;Lo;0;L;;;;;N;;;;; +1B0EC;HENTAIGANA LETTER YO-6;Lo;0;L;;;;;N;;;;; +1B0ED;HENTAIGANA LETTER RA-1;Lo;0;L;;;;;N;;;;; +1B0EE;HENTAIGANA LETTER RA-2;Lo;0;L;;;;;N;;;;; +1B0EF;HENTAIGANA LETTER RA-3;Lo;0;L;;;;;N;;;;; +1B0F0;HENTAIGANA LETTER RA-4;Lo;0;L;;;;;N;;;;; +1B0F1;HENTAIGANA LETTER RI-1;Lo;0;L;;;;;N;;;;; +1B0F2;HENTAIGANA LETTER RI-2;Lo;0;L;;;;;N;;;;; +1B0F3;HENTAIGANA LETTER RI-3;Lo;0;L;;;;;N;;;;; +1B0F4;HENTAIGANA LETTER RI-4;Lo;0;L;;;;;N;;;;; +1B0F5;HENTAIGANA LETTER RI-5;Lo;0;L;;;;;N;;;;; +1B0F6;HENTAIGANA LETTER RI-6;Lo;0;L;;;;;N;;;;; +1B0F7;HENTAIGANA LETTER RI-7;Lo;0;L;;;;;N;;;;; +1B0F8;HENTAIGANA LETTER RU-1;Lo;0;L;;;;;N;;;;; +1B0F9;HENTAIGANA LETTER RU-2;Lo;0;L;;;;;N;;;;; +1B0FA;HENTAIGANA LETTER RU-3;Lo;0;L;;;;;N;;;;; +1B0FB;HENTAIGANA LETTER RU-4;Lo;0;L;;;;;N;;;;; +1B0FC;HENTAIGANA LETTER RU-5;Lo;0;L;;;;;N;;;;; +1B0FD;HENTAIGANA LETTER RU-6;Lo;0;L;;;;;N;;;;; +1B0FE;HENTAIGANA LETTER RE-1;Lo;0;L;;;;;N;;;;; +1B0FF;HENTAIGANA LETTER RE-2;Lo;0;L;;;;;N;;;;; +1B100;HENTAIGANA LETTER RE-3;Lo;0;L;;;;;N;;;;; +1B101;HENTAIGANA LETTER RE-4;Lo;0;L;;;;;N;;;;; +1B102;HENTAIGANA LETTER RO-1;Lo;0;L;;;;;N;;;;; +1B103;HENTAIGANA LETTER RO-2;Lo;0;L;;;;;N;;;;; +1B104;HENTAIGANA LETTER RO-3;Lo;0;L;;;;;N;;;;; +1B105;HENTAIGANA LETTER RO-4;Lo;0;L;;;;;N;;;;; +1B106;HENTAIGANA LETTER RO-5;Lo;0;L;;;;;N;;;;; +1B107;HENTAIGANA LETTER RO-6;Lo;0;L;;;;;N;;;;; +1B108;HENTAIGANA LETTER WA-1;Lo;0;L;;;;;N;;;;; +1B109;HENTAIGANA LETTER WA-2;Lo;0;L;;;;;N;;;;; +1B10A;HENTAIGANA LETTER WA-3;Lo;0;L;;;;;N;;;;; +1B10B;HENTAIGANA LETTER WA-4;Lo;0;L;;;;;N;;;;; +1B10C;HENTAIGANA LETTER WA-5;Lo;0;L;;;;;N;;;;; +1B10D;HENTAIGANA LETTER WI-1;Lo;0;L;;;;;N;;;;; +1B10E;HENTAIGANA LETTER WI-2;Lo;0;L;;;;;N;;;;; +1B10F;HENTAIGANA LETTER WI-3;Lo;0;L;;;;;N;;;;; +1B110;HENTAIGANA LETTER WI-4;Lo;0;L;;;;;N;;;;; +1B111;HENTAIGANA LETTER WI-5;Lo;0;L;;;;;N;;;;; +1B112;HENTAIGANA LETTER WE-1;Lo;0;L;;;;;N;;;;; +1B113;HENTAIGANA LETTER WE-2;Lo;0;L;;;;;N;;;;; +1B114;HENTAIGANA LETTER WE-3;Lo;0;L;;;;;N;;;;; +1B115;HENTAIGANA LETTER WE-4;Lo;0;L;;;;;N;;;;; +1B116;HENTAIGANA LETTER WO-1;Lo;0;L;;;;;N;;;;; +1B117;HENTAIGANA LETTER WO-2;Lo;0;L;;;;;N;;;;; +1B118;HENTAIGANA LETTER WO-3;Lo;0;L;;;;;N;;;;; +1B119;HENTAIGANA LETTER WO-4;Lo;0;L;;;;;N;;;;; +1B11A;HENTAIGANA LETTER WO-5;Lo;0;L;;;;;N;;;;; +1B11B;HENTAIGANA LETTER WO-6;Lo;0;L;;;;;N;;;;; +1B11C;HENTAIGANA LETTER WO-7;Lo;0;L;;;;;N;;;;; +1B11D;HENTAIGANA LETTER N-MU-MO-1;Lo;0;L;;;;;N;;;;; +1B11E;HENTAIGANA LETTER N-MU-MO-2;Lo;0;L;;;;;N;;;;; +1B170;NUSHU CHARACTER-1B170;Lo;0;L;;;;;N;;;;; +1B171;NUSHU CHARACTER-1B171;Lo;0;L;;;;;N;;;;; +1B172;NUSHU CHARACTER-1B172;Lo;0;L;;;;;N;;;;; +1B173;NUSHU CHARACTER-1B173;Lo;0;L;;;;;N;;;;; +1B174;NUSHU CHARACTER-1B174;Lo;0;L;;;;;N;;;;; +1B175;NUSHU CHARACTER-1B175;Lo;0;L;;;;;N;;;;; +1B176;NUSHU CHARACTER-1B176;Lo;0;L;;;;;N;;;;; +1B177;NUSHU CHARACTER-1B177;Lo;0;L;;;;;N;;;;; +1B178;NUSHU CHARACTER-1B178;Lo;0;L;;;;;N;;;;; +1B179;NUSHU CHARACTER-1B179;Lo;0;L;;;;;N;;;;; +1B17A;NUSHU CHARACTER-1B17A;Lo;0;L;;;;;N;;;;; +1B17B;NUSHU CHARACTER-1B17B;Lo;0;L;;;;;N;;;;; +1B17C;NUSHU CHARACTER-1B17C;Lo;0;L;;;;;N;;;;; +1B17D;NUSHU CHARACTER-1B17D;Lo;0;L;;;;;N;;;;; +1B17E;NUSHU CHARACTER-1B17E;Lo;0;L;;;;;N;;;;; +1B17F;NUSHU CHARACTER-1B17F;Lo;0;L;;;;;N;;;;; +1B180;NUSHU CHARACTER-1B180;Lo;0;L;;;;;N;;;;; +1B181;NUSHU CHARACTER-1B181;Lo;0;L;;;;;N;;;;; +1B182;NUSHU CHARACTER-1B182;Lo;0;L;;;;;N;;;;; +1B183;NUSHU CHARACTER-1B183;Lo;0;L;;;;;N;;;;; +1B184;NUSHU CHARACTER-1B184;Lo;0;L;;;;;N;;;;; +1B185;NUSHU CHARACTER-1B185;Lo;0;L;;;;;N;;;;; +1B186;NUSHU CHARACTER-1B186;Lo;0;L;;;;;N;;;;; +1B187;NUSHU CHARACTER-1B187;Lo;0;L;;;;;N;;;;; +1B188;NUSHU CHARACTER-1B188;Lo;0;L;;;;;N;;;;; +1B189;NUSHU CHARACTER-1B189;Lo;0;L;;;;;N;;;;; +1B18A;NUSHU CHARACTER-1B18A;Lo;0;L;;;;;N;;;;; +1B18B;NUSHU CHARACTER-1B18B;Lo;0;L;;;;;N;;;;; +1B18C;NUSHU CHARACTER-1B18C;Lo;0;L;;;;;N;;;;; +1B18D;NUSHU CHARACTER-1B18D;Lo;0;L;;;;;N;;;;; +1B18E;NUSHU CHARACTER-1B18E;Lo;0;L;;;;;N;;;;; +1B18F;NUSHU CHARACTER-1B18F;Lo;0;L;;;;;N;;;;; +1B190;NUSHU CHARACTER-1B190;Lo;0;L;;;;;N;;;;; +1B191;NUSHU CHARACTER-1B191;Lo;0;L;;;;;N;;;;; +1B192;NUSHU CHARACTER-1B192;Lo;0;L;;;;;N;;;;; +1B193;NUSHU CHARACTER-1B193;Lo;0;L;;;;;N;;;;; +1B194;NUSHU CHARACTER-1B194;Lo;0;L;;;;;N;;;;; +1B195;NUSHU CHARACTER-1B195;Lo;0;L;;;;;N;;;;; +1B196;NUSHU CHARACTER-1B196;Lo;0;L;;;;;N;;;;; +1B197;NUSHU CHARACTER-1B197;Lo;0;L;;;;;N;;;;; +1B198;NUSHU CHARACTER-1B198;Lo;0;L;;;;;N;;;;; +1B199;NUSHU CHARACTER-1B199;Lo;0;L;;;;;N;;;;; +1B19A;NUSHU CHARACTER-1B19A;Lo;0;L;;;;;N;;;;; +1B19B;NUSHU CHARACTER-1B19B;Lo;0;L;;;;;N;;;;; +1B19C;NUSHU CHARACTER-1B19C;Lo;0;L;;;;;N;;;;; +1B19D;NUSHU CHARACTER-1B19D;Lo;0;L;;;;;N;;;;; +1B19E;NUSHU CHARACTER-1B19E;Lo;0;L;;;;;N;;;;; +1B19F;NUSHU CHARACTER-1B19F;Lo;0;L;;;;;N;;;;; +1B1A0;NUSHU CHARACTER-1B1A0;Lo;0;L;;;;;N;;;;; +1B1A1;NUSHU CHARACTER-1B1A1;Lo;0;L;;;;;N;;;;; +1B1A2;NUSHU CHARACTER-1B1A2;Lo;0;L;;;;;N;;;;; +1B1A3;NUSHU CHARACTER-1B1A3;Lo;0;L;;;;;N;;;;; +1B1A4;NUSHU CHARACTER-1B1A4;Lo;0;L;;;;;N;;;;; +1B1A5;NUSHU CHARACTER-1B1A5;Lo;0;L;;;;;N;;;;; +1B1A6;NUSHU CHARACTER-1B1A6;Lo;0;L;;;;;N;;;;; +1B1A7;NUSHU CHARACTER-1B1A7;Lo;0;L;;;;;N;;;;; +1B1A8;NUSHU CHARACTER-1B1A8;Lo;0;L;;;;;N;;;;; +1B1A9;NUSHU CHARACTER-1B1A9;Lo;0;L;;;;;N;;;;; +1B1AA;NUSHU CHARACTER-1B1AA;Lo;0;L;;;;;N;;;;; +1B1AB;NUSHU CHARACTER-1B1AB;Lo;0;L;;;;;N;;;;; +1B1AC;NUSHU CHARACTER-1B1AC;Lo;0;L;;;;;N;;;;; +1B1AD;NUSHU CHARACTER-1B1AD;Lo;0;L;;;;;N;;;;; +1B1AE;NUSHU CHARACTER-1B1AE;Lo;0;L;;;;;N;;;;; +1B1AF;NUSHU CHARACTER-1B1AF;Lo;0;L;;;;;N;;;;; +1B1B0;NUSHU CHARACTER-1B1B0;Lo;0;L;;;;;N;;;;; +1B1B1;NUSHU CHARACTER-1B1B1;Lo;0;L;;;;;N;;;;; +1B1B2;NUSHU CHARACTER-1B1B2;Lo;0;L;;;;;N;;;;; +1B1B3;NUSHU CHARACTER-1B1B3;Lo;0;L;;;;;N;;;;; +1B1B4;NUSHU CHARACTER-1B1B4;Lo;0;L;;;;;N;;;;; +1B1B5;NUSHU CHARACTER-1B1B5;Lo;0;L;;;;;N;;;;; +1B1B6;NUSHU CHARACTER-1B1B6;Lo;0;L;;;;;N;;;;; +1B1B7;NUSHU CHARACTER-1B1B7;Lo;0;L;;;;;N;;;;; +1B1B8;NUSHU CHARACTER-1B1B8;Lo;0;L;;;;;N;;;;; +1B1B9;NUSHU CHARACTER-1B1B9;Lo;0;L;;;;;N;;;;; +1B1BA;NUSHU CHARACTER-1B1BA;Lo;0;L;;;;;N;;;;; +1B1BB;NUSHU CHARACTER-1B1BB;Lo;0;L;;;;;N;;;;; +1B1BC;NUSHU CHARACTER-1B1BC;Lo;0;L;;;;;N;;;;; +1B1BD;NUSHU CHARACTER-1B1BD;Lo;0;L;;;;;N;;;;; +1B1BE;NUSHU CHARACTER-1B1BE;Lo;0;L;;;;;N;;;;; +1B1BF;NUSHU CHARACTER-1B1BF;Lo;0;L;;;;;N;;;;; +1B1C0;NUSHU CHARACTER-1B1C0;Lo;0;L;;;;;N;;;;; +1B1C1;NUSHU CHARACTER-1B1C1;Lo;0;L;;;;;N;;;;; +1B1C2;NUSHU CHARACTER-1B1C2;Lo;0;L;;;;;N;;;;; +1B1C3;NUSHU CHARACTER-1B1C3;Lo;0;L;;;;;N;;;;; +1B1C4;NUSHU CHARACTER-1B1C4;Lo;0;L;;;;;N;;;;; +1B1C5;NUSHU CHARACTER-1B1C5;Lo;0;L;;;;;N;;;;; +1B1C6;NUSHU CHARACTER-1B1C6;Lo;0;L;;;;;N;;;;; +1B1C7;NUSHU CHARACTER-1B1C7;Lo;0;L;;;;;N;;;;; +1B1C8;NUSHU CHARACTER-1B1C8;Lo;0;L;;;;;N;;;;; +1B1C9;NUSHU CHARACTER-1B1C9;Lo;0;L;;;;;N;;;;; +1B1CA;NUSHU CHARACTER-1B1CA;Lo;0;L;;;;;N;;;;; +1B1CB;NUSHU CHARACTER-1B1CB;Lo;0;L;;;;;N;;;;; +1B1CC;NUSHU CHARACTER-1B1CC;Lo;0;L;;;;;N;;;;; +1B1CD;NUSHU CHARACTER-1B1CD;Lo;0;L;;;;;N;;;;; +1B1CE;NUSHU CHARACTER-1B1CE;Lo;0;L;;;;;N;;;;; +1B1CF;NUSHU CHARACTER-1B1CF;Lo;0;L;;;;;N;;;;; +1B1D0;NUSHU CHARACTER-1B1D0;Lo;0;L;;;;;N;;;;; +1B1D1;NUSHU CHARACTER-1B1D1;Lo;0;L;;;;;N;;;;; +1B1D2;NUSHU CHARACTER-1B1D2;Lo;0;L;;;;;N;;;;; +1B1D3;NUSHU CHARACTER-1B1D3;Lo;0;L;;;;;N;;;;; +1B1D4;NUSHU CHARACTER-1B1D4;Lo;0;L;;;;;N;;;;; +1B1D5;NUSHU CHARACTER-1B1D5;Lo;0;L;;;;;N;;;;; +1B1D6;NUSHU CHARACTER-1B1D6;Lo;0;L;;;;;N;;;;; +1B1D7;NUSHU CHARACTER-1B1D7;Lo;0;L;;;;;N;;;;; +1B1D8;NUSHU CHARACTER-1B1D8;Lo;0;L;;;;;N;;;;; +1B1D9;NUSHU CHARACTER-1B1D9;Lo;0;L;;;;;N;;;;; +1B1DA;NUSHU CHARACTER-1B1DA;Lo;0;L;;;;;N;;;;; +1B1DB;NUSHU CHARACTER-1B1DB;Lo;0;L;;;;;N;;;;; +1B1DC;NUSHU CHARACTER-1B1DC;Lo;0;L;;;;;N;;;;; +1B1DD;NUSHU CHARACTER-1B1DD;Lo;0;L;;;;;N;;;;; +1B1DE;NUSHU CHARACTER-1B1DE;Lo;0;L;;;;;N;;;;; +1B1DF;NUSHU CHARACTER-1B1DF;Lo;0;L;;;;;N;;;;; +1B1E0;NUSHU CHARACTER-1B1E0;Lo;0;L;;;;;N;;;;; +1B1E1;NUSHU CHARACTER-1B1E1;Lo;0;L;;;;;N;;;;; +1B1E2;NUSHU CHARACTER-1B1E2;Lo;0;L;;;;;N;;;;; +1B1E3;NUSHU CHARACTER-1B1E3;Lo;0;L;;;;;N;;;;; +1B1E4;NUSHU CHARACTER-1B1E4;Lo;0;L;;;;;N;;;;; +1B1E5;NUSHU CHARACTER-1B1E5;Lo;0;L;;;;;N;;;;; +1B1E6;NUSHU CHARACTER-1B1E6;Lo;0;L;;;;;N;;;;; +1B1E7;NUSHU CHARACTER-1B1E7;Lo;0;L;;;;;N;;;;; +1B1E8;NUSHU CHARACTER-1B1E8;Lo;0;L;;;;;N;;;;; +1B1E9;NUSHU CHARACTER-1B1E9;Lo;0;L;;;;;N;;;;; +1B1EA;NUSHU CHARACTER-1B1EA;Lo;0;L;;;;;N;;;;; +1B1EB;NUSHU CHARACTER-1B1EB;Lo;0;L;;;;;N;;;;; +1B1EC;NUSHU CHARACTER-1B1EC;Lo;0;L;;;;;N;;;;; +1B1ED;NUSHU CHARACTER-1B1ED;Lo;0;L;;;;;N;;;;; +1B1EE;NUSHU CHARACTER-1B1EE;Lo;0;L;;;;;N;;;;; +1B1EF;NUSHU CHARACTER-1B1EF;Lo;0;L;;;;;N;;;;; +1B1F0;NUSHU CHARACTER-1B1F0;Lo;0;L;;;;;N;;;;; +1B1F1;NUSHU CHARACTER-1B1F1;Lo;0;L;;;;;N;;;;; +1B1F2;NUSHU CHARACTER-1B1F2;Lo;0;L;;;;;N;;;;; +1B1F3;NUSHU CHARACTER-1B1F3;Lo;0;L;;;;;N;;;;; +1B1F4;NUSHU CHARACTER-1B1F4;Lo;0;L;;;;;N;;;;; +1B1F5;NUSHU CHARACTER-1B1F5;Lo;0;L;;;;;N;;;;; +1B1F6;NUSHU CHARACTER-1B1F6;Lo;0;L;;;;;N;;;;; +1B1F7;NUSHU CHARACTER-1B1F7;Lo;0;L;;;;;N;;;;; +1B1F8;NUSHU CHARACTER-1B1F8;Lo;0;L;;;;;N;;;;; +1B1F9;NUSHU CHARACTER-1B1F9;Lo;0;L;;;;;N;;;;; +1B1FA;NUSHU CHARACTER-1B1FA;Lo;0;L;;;;;N;;;;; +1B1FB;NUSHU CHARACTER-1B1FB;Lo;0;L;;;;;N;;;;; +1B1FC;NUSHU CHARACTER-1B1FC;Lo;0;L;;;;;N;;;;; +1B1FD;NUSHU CHARACTER-1B1FD;Lo;0;L;;;;;N;;;;; +1B1FE;NUSHU CHARACTER-1B1FE;Lo;0;L;;;;;N;;;;; +1B1FF;NUSHU CHARACTER-1B1FF;Lo;0;L;;;;;N;;;;; +1B200;NUSHU CHARACTER-1B200;Lo;0;L;;;;;N;;;;; +1B201;NUSHU CHARACTER-1B201;Lo;0;L;;;;;N;;;;; +1B202;NUSHU CHARACTER-1B202;Lo;0;L;;;;;N;;;;; +1B203;NUSHU CHARACTER-1B203;Lo;0;L;;;;;N;;;;; +1B204;NUSHU CHARACTER-1B204;Lo;0;L;;;;;N;;;;; +1B205;NUSHU CHARACTER-1B205;Lo;0;L;;;;;N;;;;; +1B206;NUSHU CHARACTER-1B206;Lo;0;L;;;;;N;;;;; +1B207;NUSHU CHARACTER-1B207;Lo;0;L;;;;;N;;;;; +1B208;NUSHU CHARACTER-1B208;Lo;0;L;;;;;N;;;;; +1B209;NUSHU CHARACTER-1B209;Lo;0;L;;;;;N;;;;; +1B20A;NUSHU CHARACTER-1B20A;Lo;0;L;;;;;N;;;;; +1B20B;NUSHU CHARACTER-1B20B;Lo;0;L;;;;;N;;;;; +1B20C;NUSHU CHARACTER-1B20C;Lo;0;L;;;;;N;;;;; +1B20D;NUSHU CHARACTER-1B20D;Lo;0;L;;;;;N;;;;; +1B20E;NUSHU CHARACTER-1B20E;Lo;0;L;;;;;N;;;;; +1B20F;NUSHU CHARACTER-1B20F;Lo;0;L;;;;;N;;;;; +1B210;NUSHU CHARACTER-1B210;Lo;0;L;;;;;N;;;;; +1B211;NUSHU CHARACTER-1B211;Lo;0;L;;;;;N;;;;; +1B212;NUSHU CHARACTER-1B212;Lo;0;L;;;;;N;;;;; +1B213;NUSHU CHARACTER-1B213;Lo;0;L;;;;;N;;;;; +1B214;NUSHU CHARACTER-1B214;Lo;0;L;;;;;N;;;;; +1B215;NUSHU CHARACTER-1B215;Lo;0;L;;;;;N;;;;; +1B216;NUSHU CHARACTER-1B216;Lo;0;L;;;;;N;;;;; +1B217;NUSHU CHARACTER-1B217;Lo;0;L;;;;;N;;;;; +1B218;NUSHU CHARACTER-1B218;Lo;0;L;;;;;N;;;;; +1B219;NUSHU CHARACTER-1B219;Lo;0;L;;;;;N;;;;; +1B21A;NUSHU CHARACTER-1B21A;Lo;0;L;;;;;N;;;;; +1B21B;NUSHU CHARACTER-1B21B;Lo;0;L;;;;;N;;;;; +1B21C;NUSHU CHARACTER-1B21C;Lo;0;L;;;;;N;;;;; +1B21D;NUSHU CHARACTER-1B21D;Lo;0;L;;;;;N;;;;; +1B21E;NUSHU CHARACTER-1B21E;Lo;0;L;;;;;N;;;;; +1B21F;NUSHU CHARACTER-1B21F;Lo;0;L;;;;;N;;;;; +1B220;NUSHU CHARACTER-1B220;Lo;0;L;;;;;N;;;;; +1B221;NUSHU CHARACTER-1B221;Lo;0;L;;;;;N;;;;; +1B222;NUSHU CHARACTER-1B222;Lo;0;L;;;;;N;;;;; +1B223;NUSHU CHARACTER-1B223;Lo;0;L;;;;;N;;;;; +1B224;NUSHU CHARACTER-1B224;Lo;0;L;;;;;N;;;;; +1B225;NUSHU CHARACTER-1B225;Lo;0;L;;;;;N;;;;; +1B226;NUSHU CHARACTER-1B226;Lo;0;L;;;;;N;;;;; +1B227;NUSHU CHARACTER-1B227;Lo;0;L;;;;;N;;;;; +1B228;NUSHU CHARACTER-1B228;Lo;0;L;;;;;N;;;;; +1B229;NUSHU CHARACTER-1B229;Lo;0;L;;;;;N;;;;; +1B22A;NUSHU CHARACTER-1B22A;Lo;0;L;;;;;N;;;;; +1B22B;NUSHU CHARACTER-1B22B;Lo;0;L;;;;;N;;;;; +1B22C;NUSHU CHARACTER-1B22C;Lo;0;L;;;;;N;;;;; +1B22D;NUSHU CHARACTER-1B22D;Lo;0;L;;;;;N;;;;; +1B22E;NUSHU CHARACTER-1B22E;Lo;0;L;;;;;N;;;;; +1B22F;NUSHU CHARACTER-1B22F;Lo;0;L;;;;;N;;;;; +1B230;NUSHU CHARACTER-1B230;Lo;0;L;;;;;N;;;;; +1B231;NUSHU CHARACTER-1B231;Lo;0;L;;;;;N;;;;; +1B232;NUSHU CHARACTER-1B232;Lo;0;L;;;;;N;;;;; +1B233;NUSHU CHARACTER-1B233;Lo;0;L;;;;;N;;;;; +1B234;NUSHU CHARACTER-1B234;Lo;0;L;;;;;N;;;;; +1B235;NUSHU CHARACTER-1B235;Lo;0;L;;;;;N;;;;; +1B236;NUSHU CHARACTER-1B236;Lo;0;L;;;;;N;;;;; +1B237;NUSHU CHARACTER-1B237;Lo;0;L;;;;;N;;;;; +1B238;NUSHU CHARACTER-1B238;Lo;0;L;;;;;N;;;;; +1B239;NUSHU CHARACTER-1B239;Lo;0;L;;;;;N;;;;; +1B23A;NUSHU CHARACTER-1B23A;Lo;0;L;;;;;N;;;;; +1B23B;NUSHU CHARACTER-1B23B;Lo;0;L;;;;;N;;;;; +1B23C;NUSHU CHARACTER-1B23C;Lo;0;L;;;;;N;;;;; +1B23D;NUSHU CHARACTER-1B23D;Lo;0;L;;;;;N;;;;; +1B23E;NUSHU CHARACTER-1B23E;Lo;0;L;;;;;N;;;;; +1B23F;NUSHU CHARACTER-1B23F;Lo;0;L;;;;;N;;;;; +1B240;NUSHU CHARACTER-1B240;Lo;0;L;;;;;N;;;;; +1B241;NUSHU CHARACTER-1B241;Lo;0;L;;;;;N;;;;; +1B242;NUSHU CHARACTER-1B242;Lo;0;L;;;;;N;;;;; +1B243;NUSHU CHARACTER-1B243;Lo;0;L;;;;;N;;;;; +1B244;NUSHU CHARACTER-1B244;Lo;0;L;;;;;N;;;;; +1B245;NUSHU CHARACTER-1B245;Lo;0;L;;;;;N;;;;; +1B246;NUSHU CHARACTER-1B246;Lo;0;L;;;;;N;;;;; +1B247;NUSHU CHARACTER-1B247;Lo;0;L;;;;;N;;;;; +1B248;NUSHU CHARACTER-1B248;Lo;0;L;;;;;N;;;;; +1B249;NUSHU CHARACTER-1B249;Lo;0;L;;;;;N;;;;; +1B24A;NUSHU CHARACTER-1B24A;Lo;0;L;;;;;N;;;;; +1B24B;NUSHU CHARACTER-1B24B;Lo;0;L;;;;;N;;;;; +1B24C;NUSHU CHARACTER-1B24C;Lo;0;L;;;;;N;;;;; +1B24D;NUSHU CHARACTER-1B24D;Lo;0;L;;;;;N;;;;; +1B24E;NUSHU CHARACTER-1B24E;Lo;0;L;;;;;N;;;;; +1B24F;NUSHU CHARACTER-1B24F;Lo;0;L;;;;;N;;;;; +1B250;NUSHU CHARACTER-1B250;Lo;0;L;;;;;N;;;;; +1B251;NUSHU CHARACTER-1B251;Lo;0;L;;;;;N;;;;; +1B252;NUSHU CHARACTER-1B252;Lo;0;L;;;;;N;;;;; +1B253;NUSHU CHARACTER-1B253;Lo;0;L;;;;;N;;;;; +1B254;NUSHU CHARACTER-1B254;Lo;0;L;;;;;N;;;;; +1B255;NUSHU CHARACTER-1B255;Lo;0;L;;;;;N;;;;; +1B256;NUSHU CHARACTER-1B256;Lo;0;L;;;;;N;;;;; +1B257;NUSHU CHARACTER-1B257;Lo;0;L;;;;;N;;;;; +1B258;NUSHU CHARACTER-1B258;Lo;0;L;;;;;N;;;;; +1B259;NUSHU CHARACTER-1B259;Lo;0;L;;;;;N;;;;; +1B25A;NUSHU CHARACTER-1B25A;Lo;0;L;;;;;N;;;;; +1B25B;NUSHU CHARACTER-1B25B;Lo;0;L;;;;;N;;;;; +1B25C;NUSHU CHARACTER-1B25C;Lo;0;L;;;;;N;;;;; +1B25D;NUSHU CHARACTER-1B25D;Lo;0;L;;;;;N;;;;; +1B25E;NUSHU CHARACTER-1B25E;Lo;0;L;;;;;N;;;;; +1B25F;NUSHU CHARACTER-1B25F;Lo;0;L;;;;;N;;;;; +1B260;NUSHU CHARACTER-1B260;Lo;0;L;;;;;N;;;;; +1B261;NUSHU CHARACTER-1B261;Lo;0;L;;;;;N;;;;; +1B262;NUSHU CHARACTER-1B262;Lo;0;L;;;;;N;;;;; +1B263;NUSHU CHARACTER-1B263;Lo;0;L;;;;;N;;;;; +1B264;NUSHU CHARACTER-1B264;Lo;0;L;;;;;N;;;;; +1B265;NUSHU CHARACTER-1B265;Lo;0;L;;;;;N;;;;; +1B266;NUSHU CHARACTER-1B266;Lo;0;L;;;;;N;;;;; +1B267;NUSHU CHARACTER-1B267;Lo;0;L;;;;;N;;;;; +1B268;NUSHU CHARACTER-1B268;Lo;0;L;;;;;N;;;;; +1B269;NUSHU CHARACTER-1B269;Lo;0;L;;;;;N;;;;; +1B26A;NUSHU CHARACTER-1B26A;Lo;0;L;;;;;N;;;;; +1B26B;NUSHU CHARACTER-1B26B;Lo;0;L;;;;;N;;;;; +1B26C;NUSHU CHARACTER-1B26C;Lo;0;L;;;;;N;;;;; +1B26D;NUSHU CHARACTER-1B26D;Lo;0;L;;;;;N;;;;; +1B26E;NUSHU CHARACTER-1B26E;Lo;0;L;;;;;N;;;;; +1B26F;NUSHU CHARACTER-1B26F;Lo;0;L;;;;;N;;;;; +1B270;NUSHU CHARACTER-1B270;Lo;0;L;;;;;N;;;;; +1B271;NUSHU CHARACTER-1B271;Lo;0;L;;;;;N;;;;; +1B272;NUSHU CHARACTER-1B272;Lo;0;L;;;;;N;;;;; +1B273;NUSHU CHARACTER-1B273;Lo;0;L;;;;;N;;;;; +1B274;NUSHU CHARACTER-1B274;Lo;0;L;;;;;N;;;;; +1B275;NUSHU CHARACTER-1B275;Lo;0;L;;;;;N;;;;; +1B276;NUSHU CHARACTER-1B276;Lo;0;L;;;;;N;;;;; +1B277;NUSHU CHARACTER-1B277;Lo;0;L;;;;;N;;;;; +1B278;NUSHU CHARACTER-1B278;Lo;0;L;;;;;N;;;;; +1B279;NUSHU CHARACTER-1B279;Lo;0;L;;;;;N;;;;; +1B27A;NUSHU CHARACTER-1B27A;Lo;0;L;;;;;N;;;;; +1B27B;NUSHU CHARACTER-1B27B;Lo;0;L;;;;;N;;;;; +1B27C;NUSHU CHARACTER-1B27C;Lo;0;L;;;;;N;;;;; +1B27D;NUSHU CHARACTER-1B27D;Lo;0;L;;;;;N;;;;; +1B27E;NUSHU CHARACTER-1B27E;Lo;0;L;;;;;N;;;;; +1B27F;NUSHU CHARACTER-1B27F;Lo;0;L;;;;;N;;;;; +1B280;NUSHU CHARACTER-1B280;Lo;0;L;;;;;N;;;;; +1B281;NUSHU CHARACTER-1B281;Lo;0;L;;;;;N;;;;; +1B282;NUSHU CHARACTER-1B282;Lo;0;L;;;;;N;;;;; +1B283;NUSHU CHARACTER-1B283;Lo;0;L;;;;;N;;;;; +1B284;NUSHU CHARACTER-1B284;Lo;0;L;;;;;N;;;;; +1B285;NUSHU CHARACTER-1B285;Lo;0;L;;;;;N;;;;; +1B286;NUSHU CHARACTER-1B286;Lo;0;L;;;;;N;;;;; +1B287;NUSHU CHARACTER-1B287;Lo;0;L;;;;;N;;;;; +1B288;NUSHU CHARACTER-1B288;Lo;0;L;;;;;N;;;;; +1B289;NUSHU CHARACTER-1B289;Lo;0;L;;;;;N;;;;; +1B28A;NUSHU CHARACTER-1B28A;Lo;0;L;;;;;N;;;;; +1B28B;NUSHU CHARACTER-1B28B;Lo;0;L;;;;;N;;;;; +1B28C;NUSHU CHARACTER-1B28C;Lo;0;L;;;;;N;;;;; +1B28D;NUSHU CHARACTER-1B28D;Lo;0;L;;;;;N;;;;; +1B28E;NUSHU CHARACTER-1B28E;Lo;0;L;;;;;N;;;;; +1B28F;NUSHU CHARACTER-1B28F;Lo;0;L;;;;;N;;;;; +1B290;NUSHU CHARACTER-1B290;Lo;0;L;;;;;N;;;;; +1B291;NUSHU CHARACTER-1B291;Lo;0;L;;;;;N;;;;; +1B292;NUSHU CHARACTER-1B292;Lo;0;L;;;;;N;;;;; +1B293;NUSHU CHARACTER-1B293;Lo;0;L;;;;;N;;;;; +1B294;NUSHU CHARACTER-1B294;Lo;0;L;;;;;N;;;;; +1B295;NUSHU CHARACTER-1B295;Lo;0;L;;;;;N;;;;; +1B296;NUSHU CHARACTER-1B296;Lo;0;L;;;;;N;;;;; +1B297;NUSHU CHARACTER-1B297;Lo;0;L;;;;;N;;;;; +1B298;NUSHU CHARACTER-1B298;Lo;0;L;;;;;N;;;;; +1B299;NUSHU CHARACTER-1B299;Lo;0;L;;;;;N;;;;; +1B29A;NUSHU CHARACTER-1B29A;Lo;0;L;;;;;N;;;;; +1B29B;NUSHU CHARACTER-1B29B;Lo;0;L;;;;;N;;;;; +1B29C;NUSHU CHARACTER-1B29C;Lo;0;L;;;;;N;;;;; +1B29D;NUSHU CHARACTER-1B29D;Lo;0;L;;;;;N;;;;; +1B29E;NUSHU CHARACTER-1B29E;Lo;0;L;;;;;N;;;;; +1B29F;NUSHU CHARACTER-1B29F;Lo;0;L;;;;;N;;;;; +1B2A0;NUSHU CHARACTER-1B2A0;Lo;0;L;;;;;N;;;;; +1B2A1;NUSHU CHARACTER-1B2A1;Lo;0;L;;;;;N;;;;; +1B2A2;NUSHU CHARACTER-1B2A2;Lo;0;L;;;;;N;;;;; +1B2A3;NUSHU CHARACTER-1B2A3;Lo;0;L;;;;;N;;;;; +1B2A4;NUSHU CHARACTER-1B2A4;Lo;0;L;;;;;N;;;;; +1B2A5;NUSHU CHARACTER-1B2A5;Lo;0;L;;;;;N;;;;; +1B2A6;NUSHU CHARACTER-1B2A6;Lo;0;L;;;;;N;;;;; +1B2A7;NUSHU CHARACTER-1B2A7;Lo;0;L;;;;;N;;;;; +1B2A8;NUSHU CHARACTER-1B2A8;Lo;0;L;;;;;N;;;;; +1B2A9;NUSHU CHARACTER-1B2A9;Lo;0;L;;;;;N;;;;; +1B2AA;NUSHU CHARACTER-1B2AA;Lo;0;L;;;;;N;;;;; +1B2AB;NUSHU CHARACTER-1B2AB;Lo;0;L;;;;;N;;;;; +1B2AC;NUSHU CHARACTER-1B2AC;Lo;0;L;;;;;N;;;;; +1B2AD;NUSHU CHARACTER-1B2AD;Lo;0;L;;;;;N;;;;; +1B2AE;NUSHU CHARACTER-1B2AE;Lo;0;L;;;;;N;;;;; +1B2AF;NUSHU CHARACTER-1B2AF;Lo;0;L;;;;;N;;;;; +1B2B0;NUSHU CHARACTER-1B2B0;Lo;0;L;;;;;N;;;;; +1B2B1;NUSHU CHARACTER-1B2B1;Lo;0;L;;;;;N;;;;; +1B2B2;NUSHU CHARACTER-1B2B2;Lo;0;L;;;;;N;;;;; +1B2B3;NUSHU CHARACTER-1B2B3;Lo;0;L;;;;;N;;;;; +1B2B4;NUSHU CHARACTER-1B2B4;Lo;0;L;;;;;N;;;;; +1B2B5;NUSHU CHARACTER-1B2B5;Lo;0;L;;;;;N;;;;; +1B2B6;NUSHU CHARACTER-1B2B6;Lo;0;L;;;;;N;;;;; +1B2B7;NUSHU CHARACTER-1B2B7;Lo;0;L;;;;;N;;;;; +1B2B8;NUSHU CHARACTER-1B2B8;Lo;0;L;;;;;N;;;;; +1B2B9;NUSHU CHARACTER-1B2B9;Lo;0;L;;;;;N;;;;; +1B2BA;NUSHU CHARACTER-1B2BA;Lo;0;L;;;;;N;;;;; +1B2BB;NUSHU CHARACTER-1B2BB;Lo;0;L;;;;;N;;;;; +1B2BC;NUSHU CHARACTER-1B2BC;Lo;0;L;;;;;N;;;;; +1B2BD;NUSHU CHARACTER-1B2BD;Lo;0;L;;;;;N;;;;; +1B2BE;NUSHU CHARACTER-1B2BE;Lo;0;L;;;;;N;;;;; +1B2BF;NUSHU CHARACTER-1B2BF;Lo;0;L;;;;;N;;;;; +1B2C0;NUSHU CHARACTER-1B2C0;Lo;0;L;;;;;N;;;;; +1B2C1;NUSHU CHARACTER-1B2C1;Lo;0;L;;;;;N;;;;; +1B2C2;NUSHU CHARACTER-1B2C2;Lo;0;L;;;;;N;;;;; +1B2C3;NUSHU CHARACTER-1B2C3;Lo;0;L;;;;;N;;;;; +1B2C4;NUSHU CHARACTER-1B2C4;Lo;0;L;;;;;N;;;;; +1B2C5;NUSHU CHARACTER-1B2C5;Lo;0;L;;;;;N;;;;; +1B2C6;NUSHU CHARACTER-1B2C6;Lo;0;L;;;;;N;;;;; +1B2C7;NUSHU CHARACTER-1B2C7;Lo;0;L;;;;;N;;;;; +1B2C8;NUSHU CHARACTER-1B2C8;Lo;0;L;;;;;N;;;;; +1B2C9;NUSHU CHARACTER-1B2C9;Lo;0;L;;;;;N;;;;; +1B2CA;NUSHU CHARACTER-1B2CA;Lo;0;L;;;;;N;;;;; +1B2CB;NUSHU CHARACTER-1B2CB;Lo;0;L;;;;;N;;;;; +1B2CC;NUSHU CHARACTER-1B2CC;Lo;0;L;;;;;N;;;;; +1B2CD;NUSHU CHARACTER-1B2CD;Lo;0;L;;;;;N;;;;; +1B2CE;NUSHU CHARACTER-1B2CE;Lo;0;L;;;;;N;;;;; +1B2CF;NUSHU CHARACTER-1B2CF;Lo;0;L;;;;;N;;;;; +1B2D0;NUSHU CHARACTER-1B2D0;Lo;0;L;;;;;N;;;;; +1B2D1;NUSHU CHARACTER-1B2D1;Lo;0;L;;;;;N;;;;; +1B2D2;NUSHU CHARACTER-1B2D2;Lo;0;L;;;;;N;;;;; +1B2D3;NUSHU CHARACTER-1B2D3;Lo;0;L;;;;;N;;;;; +1B2D4;NUSHU CHARACTER-1B2D4;Lo;0;L;;;;;N;;;;; +1B2D5;NUSHU CHARACTER-1B2D5;Lo;0;L;;;;;N;;;;; +1B2D6;NUSHU CHARACTER-1B2D6;Lo;0;L;;;;;N;;;;; +1B2D7;NUSHU CHARACTER-1B2D7;Lo;0;L;;;;;N;;;;; +1B2D8;NUSHU CHARACTER-1B2D8;Lo;0;L;;;;;N;;;;; +1B2D9;NUSHU CHARACTER-1B2D9;Lo;0;L;;;;;N;;;;; +1B2DA;NUSHU CHARACTER-1B2DA;Lo;0;L;;;;;N;;;;; +1B2DB;NUSHU CHARACTER-1B2DB;Lo;0;L;;;;;N;;;;; +1B2DC;NUSHU CHARACTER-1B2DC;Lo;0;L;;;;;N;;;;; +1B2DD;NUSHU CHARACTER-1B2DD;Lo;0;L;;;;;N;;;;; +1B2DE;NUSHU CHARACTER-1B2DE;Lo;0;L;;;;;N;;;;; +1B2DF;NUSHU CHARACTER-1B2DF;Lo;0;L;;;;;N;;;;; +1B2E0;NUSHU CHARACTER-1B2E0;Lo;0;L;;;;;N;;;;; +1B2E1;NUSHU CHARACTER-1B2E1;Lo;0;L;;;;;N;;;;; +1B2E2;NUSHU CHARACTER-1B2E2;Lo;0;L;;;;;N;;;;; +1B2E3;NUSHU CHARACTER-1B2E3;Lo;0;L;;;;;N;;;;; +1B2E4;NUSHU CHARACTER-1B2E4;Lo;0;L;;;;;N;;;;; +1B2E5;NUSHU CHARACTER-1B2E5;Lo;0;L;;;;;N;;;;; +1B2E6;NUSHU CHARACTER-1B2E6;Lo;0;L;;;;;N;;;;; +1B2E7;NUSHU CHARACTER-1B2E7;Lo;0;L;;;;;N;;;;; +1B2E8;NUSHU CHARACTER-1B2E8;Lo;0;L;;;;;N;;;;; +1B2E9;NUSHU CHARACTER-1B2E9;Lo;0;L;;;;;N;;;;; +1B2EA;NUSHU CHARACTER-1B2EA;Lo;0;L;;;;;N;;;;; +1B2EB;NUSHU CHARACTER-1B2EB;Lo;0;L;;;;;N;;;;; +1B2EC;NUSHU CHARACTER-1B2EC;Lo;0;L;;;;;N;;;;; +1B2ED;NUSHU CHARACTER-1B2ED;Lo;0;L;;;;;N;;;;; +1B2EE;NUSHU CHARACTER-1B2EE;Lo;0;L;;;;;N;;;;; +1B2EF;NUSHU CHARACTER-1B2EF;Lo;0;L;;;;;N;;;;; +1B2F0;NUSHU CHARACTER-1B2F0;Lo;0;L;;;;;N;;;;; +1B2F1;NUSHU CHARACTER-1B2F1;Lo;0;L;;;;;N;;;;; +1B2F2;NUSHU CHARACTER-1B2F2;Lo;0;L;;;;;N;;;;; +1B2F3;NUSHU CHARACTER-1B2F3;Lo;0;L;;;;;N;;;;; +1B2F4;NUSHU CHARACTER-1B2F4;Lo;0;L;;;;;N;;;;; +1B2F5;NUSHU CHARACTER-1B2F5;Lo;0;L;;;;;N;;;;; +1B2F6;NUSHU CHARACTER-1B2F6;Lo;0;L;;;;;N;;;;; +1B2F7;NUSHU CHARACTER-1B2F7;Lo;0;L;;;;;N;;;;; +1B2F8;NUSHU CHARACTER-1B2F8;Lo;0;L;;;;;N;;;;; +1B2F9;NUSHU CHARACTER-1B2F9;Lo;0;L;;;;;N;;;;; +1B2FA;NUSHU CHARACTER-1B2FA;Lo;0;L;;;;;N;;;;; +1B2FB;NUSHU CHARACTER-1B2FB;Lo;0;L;;;;;N;;;;; 1BC00;DUPLOYAN LETTER H;Lo;0;L;;;;;N;;;;; 1BC01;DUPLOYAN LETTER X;Lo;0;L;;;;;N;;;;; 1BC02;DUPLOYAN LETTER P;Lo;0;L;;;;;N;;;;; @@ -28269,6 +29217,12 @@ FFFD;REPLACEMENT CHARACTER;So;0;ON;;;;;N;;;;; 1F248;TORTOISE SHELL BRACKETED CJK UNIFIED IDEOGRAPH-6557;So;0;L;<compat> 3014 6557 3015;;;;N;;;;; 1F250;CIRCLED IDEOGRAPH ADVANTAGE;So;0;L;<circle> 5F97;;;;N;;;;; 1F251;CIRCLED IDEOGRAPH ACCEPT;So;0;L;<circle> 53EF;;;;N;;;;; +1F260;ROUNDED SYMBOL FOR FU;So;0;ON;;;;;N;;;;; +1F261;ROUNDED SYMBOL FOR LU;So;0;ON;;;;;N;;;;; +1F262;ROUNDED SYMBOL FOR SHOU;So;0;ON;;;;;N;;;;; +1F263;ROUNDED SYMBOL FOR XI;So;0;ON;;;;;N;;;;; +1F264;ROUNDED SYMBOL FOR SHUANGXI;So;0;ON;;;;;N;;;;; +1F265;ROUNDED SYMBOL FOR CAI;So;0;ON;;;;;N;;;;; 1F300;CYCLONE;So;0;ON;;;;;N;;;;; 1F301;FOGGY;So;0;ON;;;;;N;;;;; 1F302;CLOSED UMBRELLA;So;0;ON;;;;;N;;;;; @@ -29248,6 +30202,8 @@ FFFD;REPLACEMENT CHARACTER;So;0;ON;;;;;N;;;;; 1F6D0;PLACE OF WORSHIP;So;0;ON;;;;;N;;;;; 1F6D1;OCTAGONAL SIGN;So;0;ON;;;;;N;;;;; 1F6D2;SHOPPING TROLLEY;So;0;ON;;;;;N;;;;; +1F6D3;STUPA;So;0;ON;;;;;N;;;;; +1F6D4;PAGODA;So;0;ON;;;;;N;;;;; 1F6E0;HAMMER AND WRENCH;So;0;ON;;;;;N;;;;; 1F6E1;SHIELD;So;0;ON;;;;;N;;;;; 1F6E2;OIL DRUM;So;0;ON;;;;;N;;;;; @@ -29268,6 +30224,8 @@ FFFD;REPLACEMENT CHARACTER;So;0;ON;;;;;N;;;;; 1F6F4;SCOOTER;So;0;ON;;;;;N;;;;; 1F6F5;MOTOR SCOOTER;So;0;ON;;;;;N;;;;; 1F6F6;CANOE;So;0;ON;;;;;N;;;;; +1F6F7;SLED;So;0;ON;;;;;N;;;;; +1F6F8;FLYING SAUCER;So;0;ON;;;;;N;;;;; 1F700;ALCHEMICAL SYMBOL FOR QUINTESSENCE;So;0;ON;;;;;N;;;;; 1F701;ALCHEMICAL SYMBOL FOR AIR;So;0;ON;;;;;N;;;;; 1F702;ALCHEMICAL SYMBOL FOR FIRE;So;0;ON;;;;;N;;;;; @@ -29617,6 +30575,18 @@ FFFD;REPLACEMENT CHARACTER;So;0;ON;;;;;N;;;;; 1F8AB;RIGHTWARDS FRONT-TILTED SHADOWED WHITE ARROW;So;0;ON;;;;;N;;;;; 1F8AC;WHITE ARROW SHAFT WIDTH ONE;So;0;ON;;;;;N;;;;; 1F8AD;WHITE ARROW SHAFT WIDTH TWO THIRDS;So;0;ON;;;;;N;;;;; +1F900;CIRCLED CROSS FORMEE WITH FOUR DOTS;So;0;ON;;;;;N;;;;; +1F901;CIRCLED CROSS FORMEE WITH TWO DOTS;So;0;ON;;;;;N;;;;; +1F902;CIRCLED CROSS FORMEE;So;0;ON;;;;;N;;;;; +1F903;LEFT HALF CIRCLE WITH FOUR DOTS;So;0;ON;;;;;N;;;;; +1F904;LEFT HALF CIRCLE WITH THREE DOTS;So;0;ON;;;;;N;;;;; +1F905;LEFT HALF CIRCLE WITH TWO DOTS;So;0;ON;;;;;N;;;;; +1F906;LEFT HALF CIRCLE WITH DOT;So;0;ON;;;;;N;;;;; +1F907;LEFT HALF CIRCLE;So;0;ON;;;;;N;;;;; +1F908;DOWNWARD FACING HOOK;So;0;ON;;;;;N;;;;; +1F909;DOWNWARD FACING NOTCHED HOOK;So;0;ON;;;;;N;;;;; +1F90A;DOWNWARD FACING HOOK WITH DOT;So;0;ON;;;;;N;;;;; +1F90B;DOWNWARD FACING NOTCHED HOOK WITH DOT;So;0;ON;;;;;N;;;;; 1F910;ZIPPER-MOUTH FACE;So;0;ON;;;;;N;;;;; 1F911;MONEY-MOUTH FACE;So;0;ON;;;;;N;;;;; 1F912;FACE WITH THERMOMETER;So;0;ON;;;;;N;;;;; @@ -29632,6 +30602,7 @@ FFFD;REPLACEMENT CHARACTER;So;0;ON;;;;;N;;;;; 1F91C;RIGHT-FACING FIST;So;0;ON;;;;;N;;;;; 1F91D;HANDSHAKE;So;0;ON;;;;;N;;;;; 1F91E;HAND WITH INDEX AND MIDDLE FINGERS CROSSED;So;0;ON;;;;;N;;;;; +1F91F;I LOVE YOU HAND SIGN;So;0;ON;;;;;N;;;;; 1F920;FACE WITH COWBOY HAT;So;0;ON;;;;;N;;;;; 1F921;CLOWN FACE;So;0;ON;;;;;N;;;;; 1F922;NAUSEATED FACE;So;0;ON;;;;;N;;;;; @@ -29640,7 +30611,17 @@ FFFD;REPLACEMENT CHARACTER;So;0;ON;;;;;N;;;;; 1F925;LYING FACE;So;0;ON;;;;;N;;;;; 1F926;FACE PALM;So;0;ON;;;;;N;;;;; 1F927;SNEEZING FACE;So;0;ON;;;;;N;;;;; +1F928;FACE WITH ONE EYEBROW RAISED;So;0;ON;;;;;N;;;;; +1F929;GRINNING FACE WITH STAR EYES;So;0;ON;;;;;N;;;;; +1F92A;GRINNING FACE WITH ONE LARGE AND ONE SMALL EYE;So;0;ON;;;;;N;;;;; +1F92B;FACE WITH FINGER COVERING CLOSED LIPS;So;0;ON;;;;;N;;;;; +1F92C;SERIOUS FACE WITH SYMBOLS COVERING MOUTH;So;0;ON;;;;;N;;;;; +1F92D;SMILING FACE WITH SMILING EYES AND HAND COVERING MOUTH;So;0;ON;;;;;N;;;;; +1F92E;FACE WITH OPEN MOUTH VOMITING;So;0;ON;;;;;N;;;;; +1F92F;SHOCKED FACE WITH EXPLODING HEAD;So;0;ON;;;;;N;;;;; 1F930;PREGNANT WOMAN;So;0;ON;;;;;N;;;;; +1F931;BREAST-FEEDING;So;0;ON;;;;;N;;;;; +1F932;PALMS UP TOGETHER;So;0;ON;;;;;N;;;;; 1F933;SELFIE;So;0;ON;;;;;N;;;;; 1F934;PRINCE;So;0;ON;;;;;N;;;;; 1F935;MAN IN TUXEDO;So;0;ON;;;;;N;;;;; @@ -29665,6 +30646,7 @@ FFFD;REPLACEMENT CHARACTER;So;0;ON;;;;;N;;;;; 1F949;THIRD PLACE MEDAL;So;0;ON;;;;;N;;;;; 1F94A;BOXING GLOVE;So;0;ON;;;;;N;;;;; 1F94B;MARTIAL ARTS UNIFORM;So;0;ON;;;;;N;;;;; +1F94C;CURLING STONE;So;0;ON;;;;;N;;;;; 1F950;CROISSANT;So;0;ON;;;;;N;;;;; 1F951;AVOCADO;So;0;ON;;;;;N;;;;; 1F952;CUCUMBER;So;0;ON;;;;;N;;;;; @@ -29680,6 +30662,19 @@ FFFD;REPLACEMENT CHARACTER;So;0;ON;;;;;N;;;;; 1F95C;PEANUTS;So;0;ON;;;;;N;;;;; 1F95D;KIWIFRUIT;So;0;ON;;;;;N;;;;; 1F95E;PANCAKES;So;0;ON;;;;;N;;;;; +1F95F;DUMPLING;So;0;ON;;;;;N;;;;; +1F960;FORTUNE COOKIE;So;0;ON;;;;;N;;;;; +1F961;TAKEOUT BOX;So;0;ON;;;;;N;;;;; +1F962;CHOPSTICKS;So;0;ON;;;;;N;;;;; +1F963;BOWL WITH SPOON;So;0;ON;;;;;N;;;;; +1F964;CUP WITH STRAW;So;0;ON;;;;;N;;;;; +1F965;COCONUT;So;0;ON;;;;;N;;;;; +1F966;BROCCOLI;So;0;ON;;;;;N;;;;; +1F967;PIE;So;0;ON;;;;;N;;;;; +1F968;PRETZEL;So;0;ON;;;;;N;;;;; +1F969;CUT OF MEAT;So;0;ON;;;;;N;;;;; +1F96A;SANDWICH;So;0;ON;;;;;N;;;;; +1F96B;CANNED FOOD;So;0;ON;;;;;N;;;;; 1F980;CRAB;So;0;ON;;;;;N;;;;; 1F981;LION FACE;So;0;ON;;;;;N;;;;; 1F982;SCORPION;So;0;ON;;;;;N;;;;; @@ -29698,7 +30693,36 @@ FFFD;REPLACEMENT CHARACTER;So;0;ON;;;;;N;;;;; 1F98F;RHINOCEROS;So;0;ON;;;;;N;;;;; 1F990;SHRIMP;So;0;ON;;;;;N;;;;; 1F991;SQUID;So;0;ON;;;;;N;;;;; +1F992;GIRAFFE FACE;So;0;ON;;;;;N;;;;; +1F993;ZEBRA FACE;So;0;ON;;;;;N;;;;; +1F994;HEDGEHOG;So;0;ON;;;;;N;;;;; +1F995;SAUROPOD;So;0;ON;;;;;N;;;;; +1F996;T-REX;So;0;ON;;;;;N;;;;; +1F997;CRICKET;So;0;ON;;;;;N;;;;; 1F9C0;CHEESE WEDGE;So;0;ON;;;;;N;;;;; +1F9D0;FACE WITH MONOCLE;So;0;ON;;;;;N;;;;; +1F9D1;ADULT;So;0;ON;;;;;N;;;;; +1F9D2;CHILD;So;0;ON;;;;;N;;;;; +1F9D3;OLDER ADULT;So;0;ON;;;;;N;;;;; +1F9D4;BEARDED PERSON;So;0;ON;;;;;N;;;;; +1F9D5;PERSON WITH HEADSCARF;So;0;ON;;;;;N;;;;; +1F9D6;PERSON IN STEAMY ROOM;So;0;ON;;;;;N;;;;; +1F9D7;PERSON CLIMBING;So;0;ON;;;;;N;;;;; +1F9D8;PERSON IN LOTUS POSITION;So;0;ON;;;;;N;;;;; +1F9D9;MAGE;So;0;ON;;;;;N;;;;; +1F9DA;FAIRY;So;0;ON;;;;;N;;;;; +1F9DB;VAMPIRE;So;0;ON;;;;;N;;;;; +1F9DC;MERPERSON;So;0;ON;;;;;N;;;;; +1F9DD;ELF;So;0;ON;;;;;N;;;;; +1F9DE;GENIE;So;0;ON;;;;;N;;;;; +1F9DF;ZOMBIE;So;0;ON;;;;;N;;;;; +1F9E0;BRAIN;So;0;ON;;;;;N;;;;; +1F9E1;ORANGE HEART;So;0;ON;;;;;N;;;;; +1F9E2;BILLED CAP;So;0;ON;;;;;N;;;;; +1F9E3;SCARF;So;0;ON;;;;;N;;;;; +1F9E4;GLOVES;So;0;ON;;;;;N;;;;; +1F9E5;COAT;So;0;ON;;;;;N;;;;; +1F9E6;SOCKS;So;0;ON;;;;;N;;;;; 20000;<CJK Ideograph Extension B, First>;Lo;0;L;;;;;N;;;;; 2A6D6;<CJK Ideograph Extension B, Last>;Lo;0;L;;;;;N;;;;; 2A700;<CJK Ideograph Extension C, First>;Lo;0;L;;;;;N;;;;; @@ -29707,6 +30731,8 @@ FFFD;REPLACEMENT CHARACTER;So;0;ON;;;;;N;;;;; 2B81D;<CJK Ideograph Extension D, Last>;Lo;0;L;;;;;N;;;;; 2B820;<CJK Ideograph Extension E, First>;Lo;0;L;;;;;N;;;;; 2CEA1;<CJK Ideograph Extension E, Last>;Lo;0;L;;;;;N;;;;; +2CEB0;<CJK Ideograph Extension F, First>;Lo;0;L;;;;;N;;;;; +2EBE0;<CJK Ideograph Extension F, Last>;Lo;0;L;;;;;N;;;;; 2F800;CJK COMPATIBILITY IDEOGRAPH-2F800;Lo;0;L;4E3D;;;;N;;;;; 2F801;CJK COMPATIBILITY IDEOGRAPH-2F801;Lo;0;L;4E38;;;;N;;;;; 2F802;CJK COMPATIBILITY IDEOGRAPH-2F802;Lo;0;L;4E41;;;;N;;;;; diff --git a/lib/stdlib/uc_spec/gen_unicode_mod.escript b/lib/stdlib/uc_spec/gen_unicode_mod.escript index 73c351e1af..fe5a860d45 100755 --- a/lib/stdlib/uc_spec/gen_unicode_mod.escript +++ b/lib/stdlib/uc_spec/gen_unicode_mod.escript @@ -65,7 +65,7 @@ main(_) -> %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% parse_unicode_data(Line0, Acc) -> - Line = string:strip(Line0, right, $\n), + Line = string:chomp(Line0), [CodePoint,Name,_Cat,Class,_BiDi,Decomp, _N1,_N2,_N3,_BDMirror,_Uni1,_Iso|Case] = tokens(Line, ";"), {Dec,Comp} = case to_decomp(Decomp) of @@ -78,14 +78,14 @@ parse_unicode_data(Line0, Acc) -> |Acc]. to_class(String) -> - list_to_integer(string:strip(String, both)). + list_to_integer(string:trim(String, both)). to_decomp("") -> []; to_decomp("<" ++ Str) -> - [Tag,Rest] = string:tokens(Str, ">"), + [Tag,Rest] = string:lexemes(Str, ">"), {list_to_atom(Tag), to_decomp(Rest)}; to_decomp(CodePoints) -> - CPL = string:tokens(CodePoints, " "), + CPL = string:lexemes(CodePoints, " "), [hex_to_int(CP) || CP <- CPL]. to_case(["","",""]) -> []; @@ -105,20 +105,20 @@ parse_special_casing(Line, Table) -> array:set(CP, Entry#cp{cs=Case}, Table). to_scase([Lower,Title,Upper|_]) -> - {unlist([hex_to_int(CP) || CP <- string:strip(string:tokens(Upper, " "), both)]), - unlist([hex_to_int(CP) || CP <- string:strip(string:tokens(Lower, " "), both)]), - unlist([hex_to_int(CP) || CP <- string:strip(string:tokens(Title, " "), both)]), + {unlist([hex_to_int(CP) || CP <- string:lexemes(Upper, " ")]), + unlist([hex_to_int(CP) || CP <- string:lexemes(Lower, " ")]), + unlist([hex_to_int(CP) || CP <- string:lexemes(Title, " ")]), []}. parse_case_folding(Line, Table) -> [CodePoint, Class0, CaseStr |_Comments] = tokens(Line, ";"), - Class = string:strip(Class0, both), + Class = string:trim(Class0, both), if Class =:= "T" -> Table; %% Do not support localization yet Class =:= "S" -> Table; %% Ignore simple true -> CP = hex_to_int(CodePoint), Case = unlist([hex_to_int(CPC) || - CPC <- string:strip(string:tokens(CaseStr, " "), both)]), + CPC <- string:lexemes(CaseStr, " ")]), #cp{cs={U,L,T,_}} = Entry = array:get(CP, Table), array:set(CP, Entry#cp{cs={U,L,T,Case}}, Table) end. @@ -186,7 +186,7 @@ gen_static(Fd) -> " {U,L} -> #{upper=>U,lower=>L,title=>U,fold=>L};\n" " {U,L,T,F} -> #{upper=>U,lower=>L,title=>T,fold=>F}\n" " end.\n\n"), - io:put_chars(Fd, "spec_version() -> {9,0}.\n\n\n"), + io:put_chars(Fd, "spec_version() -> {10,0}.\n\n\n"), io:put_chars(Fd, "class(Codepoint) -> {CCC,_,_} = unicode_table(Codepoint),\n CCC.\n\n"), io:put_chars(Fd, "-spec uppercase(unicode:chardata()) -> " "maybe_improper_list(gc(),unicode:chardata()).\n"), @@ -886,10 +886,10 @@ optimize_ranges_1(Rs) -> hex_to_int([]) -> []; hex_to_int(HexStr) -> - list_to_integer(string:strip(HexStr, both), 16). + list_to_integer(string:trim(HexStr, both), 16). to_atom(Str) -> - list_to_atom(string:to_lower(string:strip(Str, both))). + list_to_atom(string:lowercase(string:trim(Str, both))). foldl(Fun, Acc, Fd) -> Get = fun() -> file:read_line(Fd) end, @@ -909,7 +909,7 @@ foldl_1(Fun, Acc, Get) -> -%% Differs from string:tokens, it returns empty string as token between two delimiters +%% Differs from string:lexemes, it returns empty string as token between two delimiters tokens(S, [C]) -> tokens(lists:reverse(S), C, []). diff --git a/lib/syntax_tools/doc/src/Makefile b/lib/syntax_tools/doc/src/Makefile index 1ce620b3d6..a346b9a0bd 100644 --- a/lib/syntax_tools/doc/src/Makefile +++ b/lib/syntax_tools/doc/src/Makefile @@ -63,10 +63,11 @@ BOOK_FILES = book.xml XML_FILES=\ - $(BOOK_FILES) $(XML_CHAPTER_FILES) \ - $(XML_PART_FILES) $(XML_REF3_FILES) $(XML_APPLICATION_FILES) \ + $(BOOK_FILES) $(XML_PART_FILES) $(XML_APPLICATION_FILES) \ $(XML_NOTES_FILES) +XML_GEN_FILES = $(XML_REF3_FILES:%=$(XMLDIR)/%) $(XML_CHAPTER_FILES:%=$(XMLDIR)/%) + # ---------------------------------------------------- INFO_FILE = ../../info @@ -108,11 +109,13 @@ html: gifs $(HTML_REF_MAN_FILE) man: $(MAN3_FILES) -$(XML_REF3_FILES): - escript $(DOCGEN)/priv/bin/xml_from_edoc.escript $(SRC_DIR)/$(@:%.xml=%.erl) +$(XML_REF3_FILES:%=$(XMLDIR)/%): + $(gen_verbose)escript $(DOCGEN)/priv/bin/xml_from_edoc.escript \ + -dir $(XMLDIR) $(SRC_DIR)/$(@:$(XMLDIR)/%.xml=%.erl) -$(XML_CHAPTER_FILES): - escript $(DOCGEN)/priv/bin/xml_from_edoc.escript -def vsn $(VSN) -chapter ../overview.edoc +$(XML_CHAPTER_FILES:%=$(XMLDIR)/%): + $(gen_verbose)escript $(DOCGEN)/priv/bin/xml_from_edoc.escript -def vsn $(VSN) \ + -chapter -dir $(XMLDIR) ../overview.edoc gifs: $(GIF_FILES:%=$(HTMLDIR)/%) diff --git a/lib/syntax_tools/src/Makefile b/lib/syntax_tools/src/Makefile index 8325db45a8..c21d2f49c8 100644 --- a/lib/syntax_tools/src/Makefile +++ b/lib/syntax_tools/src/Makefile @@ -75,7 +75,7 @@ $(EBIN)/%.$(EMULATOR):%.erl # special rules and dependencies to apply the transform to itself $(EBIN)/merl_transform.beam: $(EBIN)/merl.beam ./merl_transform.beam \ - ../include/merl.hrl \ + ../include/merl.hrl $(EBIN)/erl_comment_scan.beam \ $(EBIN)/erl_syntax.beam $(EBIN)/erl_syntax_lib.beam ./merl_transform.beam: ./merl_transform.erl $(EBIN)/merl.beam \ ../include/merl.hrl diff --git a/lib/syntax_tools/src/erl_comment_scan.erl b/lib/syntax_tools/src/erl_comment_scan.erl index 07e501e553..e3eb95b819 100644 --- a/lib/syntax_tools/src/erl_comment_scan.erl +++ b/lib/syntax_tools/src/erl_comment_scan.erl @@ -208,7 +208,7 @@ scan_comment([], Cs1, L, Col, M, Ack) -> seen_comment(Cs, Cs1, L, Col, M, Ack) -> %% Compute indentation and strip trailing spaces N = Col - M, - Text = lists:reverse(string:strip(Cs1, left)), + Text = lists:reverse(string:trim(Cs1, leading)), Ack1 = [{L, Col + 1, N, Text} | Ack], scan_lines(Cs, L + 1, 0, 0, Ack1). diff --git a/lib/syntax_tools/src/erl_prettypr.erl b/lib/syntax_tools/src/erl_prettypr.erl index 40ddd2b22a..60a15c8e3f 100644 --- a/lib/syntax_tools/src/erl_prettypr.erl +++ b/lib/syntax_tools/src/erl_prettypr.erl @@ -774,9 +774,16 @@ lay_2(Node, Ctxt) -> class_qualifier -> Ctxt1 = set_prec(Ctxt, max_prec()), D1 = lay(erl_syntax:class_qualifier_argument(Node), Ctxt1), - D2 = lay(erl_syntax:class_qualifier_body(Node), Ctxt1), - beside(D1, beside(text(":"), D2)); - + D2 = lay(erl_syntax:class_qualifier_body(Node), Ctxt1), + Stacktrace = erl_syntax:class_qualifier_stacktrace(Node), + case erl_syntax:variable_name(Stacktrace) of + '_' -> + beside(D1, beside(text(":"), D2)); + _ -> + D3 = lay(Stacktrace, Ctxt1), + beside(D1, beside(beside(text(":"), D2), + beside(text(":"), D3))) + end; comment -> D = stack_comment_lines( erl_syntax:comment_text(Node)), diff --git a/lib/syntax_tools/src/erl_syntax.erl b/lib/syntax_tools/src/erl_syntax.erl index 9b2b503762..b816c0699c 100644 --- a/lib/syntax_tools/src/erl_syntax.erl +++ b/lib/syntax_tools/src/erl_syntax.erl @@ -342,8 +342,10 @@ typed_record_field_body/1, typed_record_field_type/1, class_qualifier/2, + class_qualifier/3, class_qualifier_argument/1, class_qualifier_body/1, + class_qualifier_stacktrace/1, tuple/1, tuple_elements/1, tuple_size/1, @@ -3884,7 +3886,7 @@ fold_try_clause({clause, Pos, [P], Guard, Body}) -> class_qualifier -> {tuple, Pos, [class_qualifier_argument(P), class_qualifier_body(P), - {var, Pos, '_'}]}; + class_qualifier_stacktrace(P)]}; _ -> {tuple, Pos, [{atom, Pos, throw}, P, {var, Pos, '_'}]} end, @@ -3893,12 +3895,14 @@ fold_try_clause({clause, Pos, [P], Guard, Body}) -> unfold_try_clauses(Cs) -> [unfold_try_clause(C) || C <- Cs]. -unfold_try_clause({clause, Pos, [{tuple, _, [{atom, _, throw}, V, _]}], +unfold_try_clause({clause, Pos, [{tuple, _, [{atom, _, throw}, + V, + [{var, _, '_'}]]}], Guard, Body}) -> {clause, Pos, [V], Guard, Body}; -unfold_try_clause({clause, Pos, [{tuple, _, [C, V, _]}], +unfold_try_clause({clause, Pos, [{tuple, _, [C, V, Stacktrace]}], Guard, Body}) -> - {clause, Pos, [class_qualifier(C, V)], Guard, Body}. + {clause, Pos, [class_qualifier(C, V, Stacktrace)], Guard, Body}. %% ===================================================================== @@ -6725,9 +6729,12 @@ try_expr_after(Node) -> %% %% @see class_qualifier_argument/1 %% @see class_qualifier_body/1 +%% @see class_qualifier_stacktrace/1 %% @see try_expr/4 --record(class_qualifier, {class :: syntaxTree(), body :: syntaxTree()}). +-record(class_qualifier, {class :: syntaxTree(), + body :: syntaxTree(), + stacktrace :: syntaxTree()}). %% type(Node) = class_qualifier %% data(Node) = #class_qualifier{class :: Class, body :: Body} @@ -6737,8 +6744,27 @@ try_expr_after(Node) -> -spec class_qualifier(syntaxTree(), syntaxTree()) -> syntaxTree(). class_qualifier(Class, Body) -> + Underscore = {var, get_pos(Body), '_'}, tree(class_qualifier, - #class_qualifier{class = Class, body = Body}). + #class_qualifier{class = Class, body = Body, + stacktrace = Underscore}). + +%% ===================================================================== +%% @doc Creates an abstract class qualifier. The result represents +%% "<code><em>Class</em>:<em>Body</em>:<em>Stacktrace</em></code>". +%% +%% @see class_qualifier_argument/1 +%% @see class_qualifier_body/1 +%% @see try_expr/4 + +-spec class_qualifier(syntaxTree(), syntaxTree(), syntaxTree()) -> + syntaxTree(). + +class_qualifier(Class, Body, Stacktrace) -> + tree(class_qualifier, + #class_qualifier{class = Class, + body = Body, + stacktrace = Stacktrace}). %% ===================================================================== @@ -6763,6 +6789,16 @@ class_qualifier_argument(Node) -> class_qualifier_body(Node) -> (data(Node))#class_qualifier.body. +%% ===================================================================== +%% @doc Returns the stacktrace subtree of a `class_qualifier' node. +%% +%% @see class_qualifier/2 + +-spec class_qualifier_stacktrace(syntaxTree()) -> syntaxTree(). + +class_qualifier_stacktrace(Node) -> + (data(Node))#class_qualifier.stacktrace. + %% ===================================================================== %% @doc Creates an abstract "implicit fun" expression. If @@ -7727,8 +7763,9 @@ subtrees(T) -> catch_expr -> [[catch_expr_body(T)]]; class_qualifier -> - [[class_qualifier_argument(T)], - [class_qualifier_body(T)]]; + [[class_qualifier_argument(T)], + [class_qualifier_body(T)], + [class_qualifier_stacktrace(T)]]; clause -> case clause_guard(T) of none -> @@ -7949,6 +7986,7 @@ make_tree(block_expr, [B]) -> block_expr(B); make_tree(case_expr, [[A], C]) -> case_expr(A, C); make_tree(catch_expr, [[B]]) -> catch_expr(B); make_tree(class_qualifier, [[A], [B]]) -> class_qualifier(A, B); +make_tree(class_qualifier, [[A], [B], [C]]) -> class_qualifier(A, B, C); make_tree(clause, [P, B]) -> clause(P, none, B); make_tree(clause, [P, [G], B]) -> clause(P, G, B); make_tree(cond_expr, [C]) -> cond_expr(C); diff --git a/lib/syntax_tools/src/merl_transform.erl b/lib/syntax_tools/src/merl_transform.erl index b298bc407f..571d7e4d86 100644 --- a/lib/syntax_tools/src/merl_transform.erl +++ b/lib/syntax_tools/src/merl_transform.erl @@ -196,7 +196,7 @@ var_name(V) -> V. var_to_tag(V) when is_integer(V) -> V; var_to_tag(V) -> - list_to_atom(string:to_lower(atom_to_list(V))). + list_to_atom(string:lowercase(atom_to_list(V))). pre_expand_case(Expr, Clauses, Line) -> merl:qquote(Line, "merl:switch(_@expr, _@clauses)", diff --git a/lib/tftp/AUTHORS b/lib/tftp/AUTHORS new file mode 100644 index 0000000000..71fc97c4e0 --- /dev/null +++ b/lib/tftp/AUTHORS @@ -0,0 +1,11 @@ +Original Authors: + +Håkan Mattsson - tftp + +Contributors: + +Ingela Anderton Andin +Martin Gustafsson +Johan Blom +Torbjörn Törnkvist +Joe Armstrong
\ No newline at end of file diff --git a/lib/tftp/Makefile b/lib/tftp/Makefile new file mode 100644 index 0000000000..5c3ed52b28 --- /dev/null +++ b/lib/tftp/Makefile @@ -0,0 +1,78 @@ +# +# %CopyrightBegin% +# +# Copyright Ericsson AB 1996-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 + +# ---------------------------------------------------- +# Macros +# ---------------------------------------------------- + +SUB_DIRECTORIES = src doc/src + +include vsn.mk +VSN = $(TFTP_VSN) + +SPECIAL_TARGETS = + +DIA_PLT = ./priv/plt/$(APPLICATION).plt +DIA_ANALYSIS = $(basename $(DIA_PLT)).dialyzer_analysis + + +# ---------------------------------------------------- +# Default Subdir Targets +# ---------------------------------------------------- +include $(ERL_TOP)/make/otp_subdir.mk + +.PHONY: info gclean dialyzer dialyzer_plt dclean + +info: + @echo "OS: $(OS)" + @echo "DOCB: $(DOCB)" + @echo "" + @echo "TFTP_VSN: $(TFTP_VSN)" + @echo "APP_VSN: $(APP_VSN)" + @echo "" + @echo "DIA_PLT: $(DIA_PLT)" + @echo "DIA_ANALYSIS: $(DIA_ANALYSIS)" + @echo "" + +gclean: + git clean -fXd + +dclean: + rm -f $(DIA_PLT) + rm -f $(DIA_ANALYSIS) + +dialyzer_plt: $(DIA_PLT) + +$(DIA_PLT): + @echo "Building $(APPLICATION) plt file" + @dialyzer --build_plt \ + --output_plt $@ \ + -r ../$(APPLICATION)/ebin \ + --output $(DIA_ANALYSIS) \ + --verbose + +dialyzer: $(DIA_PLT) + @echo "Running dialyzer on $(APPLICATION)" + @dialyzer --plt $< \ + ../$(APPLICATION)/ebin \ + --verbose diff --git a/lib/tftp/doc/html/.gitignore b/lib/tftp/doc/html/.gitignore new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/lib/tftp/doc/html/.gitignore diff --git a/lib/tftp/doc/man3/.gitignore b/lib/tftp/doc/man3/.gitignore new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/lib/tftp/doc/man3/.gitignore diff --git a/lib/tftp/doc/man6/.gitignore b/lib/tftp/doc/man6/.gitignore new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/lib/tftp/doc/man6/.gitignore diff --git a/lib/tftp/doc/pdf/.gitignore b/lib/tftp/doc/pdf/.gitignore new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/lib/tftp/doc/pdf/.gitignore diff --git a/lib/tftp/doc/src/Makefile b/lib/tftp/doc/src/Makefile new file mode 100644 index 0000000000..a2fdcf6325 --- /dev/null +++ b/lib/tftp/doc/src/Makefile @@ -0,0 +1,154 @@ +# +# %CopyrightBegin% +# +# Copyright Ericsson AB 1997-2018. 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=$(TFTP_VSN) + +# ---------------------------------------------------- +# Release directory specification +# ---------------------------------------------------- +RELSYSDIR = $(RELEASE_PATH)/lib/$(APPLICATION)-$(VSN) + + +# ---------------------------------------------------- +# Target Specs +# ---------------------------------------------------- +XML_APPLICATION_FILES = ref_man.xml + +XML_CHAPTER_FILES = \ + introduction.xml \ + getting_started.xml \ + notes.xml + +XML_REF3_FILES = \ + tftp.xml + +XML_PART_FILES = \ + usersguide.xml + +BOOK_FILES = book.xml + +XML_FILES = \ + $(BOOK_FILES) \ + $(XML_CHAPTER_FILES) \ + $(XML_PART_FILES) \ + $(XML_REF6_FILES) \ + $(XML_REF3_FILES) \ + $(XML_APPLICATION_FILES) + +# GIF_FILES = tftp.gif + + +# ---------------------------------------------------- + +HTML_FILES = \ + $(XML_APPLICATION_FILES:%.xml=$(HTMLDIR)/%.html) \ + $(XML_PART_FILES:%.xml=$(HTMLDIR)/%.html) + +INFO_FILE = ../../info +EXTRA_FILES = \ + $(XML_REF3_FILES:%.xml=$(HTMLDIR)/%.html) \ + $(XML_REF6_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 += +DVIPS_FLAGS += + +# ---------------------------------------------------- +# Targets +# ---------------------------------------------------- +$(HTMLDIR)/%.gif: %.gif + $(INSTALL_DATA) $< $@ + +docs: pdf html man + +ldocs: local_docs + +$(TOP_PDF_FILE): $(XML_FILES) + +pdf: $(TOP_PDF_FILE) + +html: gifs $(HTML_REF_MAN_FILE) + +clean clean_docs: clean_html clean_man clean_pdf + rm -f errs core *~ + +man: $(MAN3_FILES) + +gifs: $(GIF_FILES:%=$(HTMLDIR)/%) + +debug opt: + +clean_pdf: + rm -f $(TOP_PDF_FILE) $(TOP_PDF_FILE:%.pdf=%.fo) + +clean_html: + rm -rf $(TOP_HTML_FILES) $(HTMLDIR)/* + +clean_man: + rm -f $(MAN3_FILES) + + +# ---------------------------------------------------- +# 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)" + $(INSTALL_DIR) "$(RELEASE_PATH)/man/man3" + $(INSTALL_DATA) $(MAN3DIR)/* "$(RELEASE_PATH)/man/man3" + +release_spec: + +info: + @echo "GIF_FILES:\n$(GIF_FILES)" + @echo "" + @echo "EXTRA_FILES:\n$(EXTRA_FILES)" + @echo "" + @echo "HTML_FILES:\n$(HTML_FILES)" + @echo "" + @echo "TOP_HTML_FILES:\n$(TOP_HTML_FILES)" + @echo "" + @echo "XML_REF3_FILES:\n$(XML_REF3_FILES)" + @echo "" + @echo "XML_REF6_FILES:\n$(XML_REF6_FILES)" + @echo "" + @echo "XML_CHAPTER_FILES:\n$(XML_CHAPTER_FILES)" + @echo "" diff --git a/lib/tftp/doc/src/book.xml b/lib/tftp/doc/src/book.xml new file mode 100644 index 0000000000..c0b551d517 --- /dev/null +++ b/lib/tftp/doc/src/book.xml @@ -0,0 +1,49 @@ +<?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>1997</year><year>2018</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>TFTP</title> + <prepared>Péter Dimitrov</prepared> + <docno></docno> + <date>2018-03-22</date> + <rev>1.0</rev> + <file>book.sgml</file> + </header> + <insidecover> + </insidecover> + <pagetext>TFTP</pagetext> + <preamble> + <contents level="2"></contents> + </preamble> + <parts lift="no"> + <xi:include href="usersguide.xml"/> + </parts> + <applications> + <xi:include href="ref_man.xml"/> + </applications> + <releasenotes> + <xi:include href="notes.xml"/> + </releasenotes> + <listofterms></listofterms> + <index></index> +</book> diff --git a/lib/tftp/doc/src/getting_started.xml b/lib/tftp/doc/src/getting_started.xml new file mode 100644 index 0000000000..9bce52dbe0 --- /dev/null +++ b/lib/tftp/doc/src/getting_started.xml @@ -0,0 +1,81 @@ +<?xml version="1.0" encoding="utf-8" ?> +<!DOCTYPE chapter SYSTEM "chapter.dtd"> + +<chapter> + <header> + <copyright> + <year>1997</year> + <year>2018</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>Getting Started</title> + <prepared></prepared> + <docno></docno> + <approved></approved> + <date></date> + <rev></rev> + <file>getting_started.xml</file> + </header> + + <section> + <title>General Information</title> + <p>The <seealso marker="tftp#start/1">start/1</seealso> function starts + a daemon process listening for UDP packets on a port. When it + receives a request for read or write, it spawns a temporary server + process handling the transfer.</p> + <p>On the client side, + function <seealso marker="tftp#read_file/3">read_file/3</seealso> + and <seealso marker="tftp#write_file/3">write_file/3</seealso> + spawn a temporary client process establishing + contact with a TFTP daemon and perform the file transfer.</p> + <p><c>tftp</c> uses a callback module to handle the file + transfer. Two such callback modules are provided, + <c>tftp_binary</c> and <c>tftp_file</c>. See + <seealso marker="tftp#read_file/3">read_file/3</seealso> and + <seealso marker="tftp#write_file/3">write_file/3</seealso> for details. + You can also implement your own callback modules, see + <seealso marker="tftp#tftp_callback">CALLBACK FUNCTIONS</seealso>. + A callback module provided by + the user is registered using option <c>callback</c>, see + <seealso marker="tftp#options">DATA TYPES</seealso>.</p> + </section> + + <section> + <title>Using the TFTP client and server</title> + <p>This is a simple example of starting the TFTP server and reading the content + of a sample file using the TFTP client.</p> + + <p><em>Step 1.</em> Create a sample file to be used for the transfer:</p> + <code> + $ echo "Erlang/OTP 21" > file.txt + </code> + + <p><em>Step 2.</em> Start the TFTP server:</p> + <code type="erl" > + 1> {ok, Pid} = tftp:start([{port, 19999}]). + <![CDATA[{ok,<0.65.0>}]]> + </code> + + <p><em>Step 3.</em> Start the TFTP client (in another shell):</p> + <code type="erl" > + 1> tftp:read_file("file.txt", binary, [{port, 19999}]). + <![CDATA[{ok,<<"Erlang/OTP 21\n">>}]]> + </code> + </section> + +</chapter> diff --git a/lib/tftp/doc/src/introduction.xml b/lib/tftp/doc/src/introduction.xml new file mode 100644 index 0000000000..70761db0dc --- /dev/null +++ b/lib/tftp/doc/src/introduction.xml @@ -0,0 +1,62 @@ +<?xml version="1.0" encoding="utf-8" ?> +<!DOCTYPE chapter SYSTEM "chapter.dtd"> + +<chapter> + <header> + <copyright> + <year>1997</year><year>2018</year> + <holder>Ericsson AB. All Rights Reserved.</holder> + </copyright> + <legalnotice> + The contents of this file are subject to the Erlang Public License, + Version 1.1, (the "License"); you may not use this file except in + compliance with the License. You should have received a copy of the + Erlang Public License along with this software. If not, it can be + retrieved online at http://www.erlang.org/. + + Software distributed under the License is distributed on an "AS IS" + basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + the License for the specific language governing rights and limitations + under the License. + + </legalnotice> + + <title>Introduction</title> + <prepared>Péter Dimitrov</prepared> + <responsible></responsible> + <docno></docno> + <approved></approved> + <checked></checked> + <date>2018-03-22</date> + <rev>A</rev> + <file>introduction.xml</file> + </header> + + <section> + <title>Purpose</title> + <p>The Trivial File Transfer Protocol or TFTP is a very simple protocol + used to transfer files.</p> + <p>It has been implemented on top of the User Datagram protocol (UDP) so + it may be used to move files between machines on different networks + implementing UDP. It is designed to be small and easy to implement. + Therefore, it lacks most of the features of a regular FTP. The only + thing it can do is read and write files (or mail) from/to a remote server. + It cannot list directories, and currently has no provisions for user + authentication.</p> + <p>The <c>tftp</c> application implements the following IETF standards:</p> + <list type="bulleted"> + <item>RFC 1350, The TFTP Protocol (revision 2)</item> + <item>RFC 2347, TFTP Option Extension</item> + <item>RFC 2348, TFTP Blocksize Option</item> + <item>RFC 2349, TFTP Timeout Interval and Transfer Size Options</item> + </list> + <p>The only feature that not is implemented is the <c>netascii</c> transfer mode.</p> + </section> + + <section> + <title>Prerequisites</title> + <p>It is assumed that the reader is familiar with the Erlang + programming language, concepts of OTP, and has a basic + understanding of the TFTP protocol.</p> + </section> +</chapter> diff --git a/lib/tftp/doc/src/notes.xml b/lib/tftp/doc/src/notes.xml new file mode 100644 index 0000000000..3a4d97a008 --- /dev/null +++ b/lib/tftp/doc/src/notes.xml @@ -0,0 +1,53 @@ +<?xml version="1.0" encoding="utf-8" ?> +<!DOCTYPE chapter SYSTEM "chapter.dtd"> + +<chapter> + <header> + <copyright> + <year>2002</year><year>2018</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>TFTP Release Notes</title> + <prepared></prepared> + <responsible></responsible> + <docno></docno> + <approved></approved> + <checked></checked> + <date>2018-03-22</date> + <rev>A</rev> + <file>notes.xml</file> + </header> + + <section><title>TFTP 1.0</title> + + <section><title>First released version</title> + <list> + <item> + <p> + Inets application was split into multiple smaller protocol specific applications. + The TFTP application is a standalone TFTP client and server with the same functionality as + TFTP in Inets.</p> + <p> + Own Id: OTP-14113</p> + </item> + </list> + </section> + +</section> + +</chapter> diff --git a/lib/tftp/doc/src/ref_man.xml b/lib/tftp/doc/src/ref_man.xml new file mode 100644 index 0000000000..41a6cc6d52 --- /dev/null +++ b/lib/tftp/doc/src/ref_man.xml @@ -0,0 +1,36 @@ +<?xml version="1.0" encoding="utf-8" ?> +<!DOCTYPE application SYSTEM "application.dtd"> + +<application xmlns:xi="http://www.w3.org/2001/XInclude"> + <header> + <copyright> + <year>1997</year><year>2018</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>TFTP Reference Manual</title> + <prepared>Péter Dimitrov</prepared> + <docno></docno> + <date>2018-03-22</date> + <rev>1.0</rev> + <file>ref_man.xml</file> + </header> + <description> + <p>The <c>TFTP</c> application.</p> + </description> + <xi:include href="tftp.xml"/> +</application> diff --git a/lib/inets/doc/src/tftp.xml b/lib/tftp/doc/src/tftp.xml index 10398f5088..481e5446ad 100644 --- a/lib/inets/doc/src/tftp.xml +++ b/lib/tftp/doc/src/tftp.xml @@ -4,7 +4,7 @@ <erlref> <header> <copyright> - <year>2006</year><year>2015</year> + <year>2006</year><year>2018</year> <holder>Ericsson AB. All Rights Reserved.</holder> </copyright> <legalnotice> @@ -31,57 +31,9 @@ <module>tftp</module> <modulesummary>Trivial FTP.</modulesummary> <description> - <p>This is a complete implementation of the following IETF standards:</p> - <list type="bulleted"> - <item>RFC 1350, The TFTP Protocol (revision 2)</item> - <item>RFC 2347, TFTP Option Extension</item> - <item>RFC 2348, TFTP Blocksize Option</item> - <item>RFC 2349, TFTP Timeout Interval and Transfer Size Options</item> - </list> - <p>The only feature that not is implemented is - the "netascii" transfer mode.</p> - <p>The <seealso marker="#start/1">start/1</seealso> function starts - a daemon process listening for UDP packets on a port. When it - receives a request for read or write, it spawns a temporary server - process handling the transfer.</p> - <p>On the client side, - function <seealso marker="#read_file/3">read_file/3</seealso> - and <seealso marker="#write_file/3">write_file/3</seealso> - spawn a temporary client process establishing - contact with a TFTP daemon and perform the file transfer.</p> - <p><c>tftp</c> uses a callback module to handle the file - transfer. Two such callback modules are provided, - <c>tftp_binary</c> and <c>tftp_file</c>. See - <seealso marker="#read_file/3">read_file/3</seealso> and - <seealso marker="#write_file/3">write_file/3</seealso> for details. - You can also implement your own callback modules, see - <seealso marker="#tftp_callback">CALLBACK FUNCTIONS</seealso>. - A callback module provided by - the user is registered using option <c>callback</c>, see - <seealso marker="#options">DATA TYPES</seealso>.</p> + <p>Interface module for the <c>tftp</c> application.</p> </description> - - <section> - <title>TFTP SERVER SERVICE START/STOP</title> - - <p>A TFTP server can be configured to start statically when starting - the <c>Inets</c> application. Alternatively, it can be started dynamically - (when <c>Inets</c> is already started) by calling the <c>Inets</c> application - API <c>inets:start(tftpd, ServiceConfig)</c> or - <c>inets:start(tftpd, ServiceConfig, How)</c>, - see <seealso marker="inets">inets(3)</seealso> for details. - The <c>ServiceConfig</c> for TFTP is described in - the <seealso marker="#options">DATA TYPES</seealso> - section.</p> - - <p>The TFTP server can be stopped using <c>inets:stop(tftpd, Pid)</c>, - see <seealso marker="inets">inets(3)</seealso> for details.</p> - <p>The TPFT client is of such a temporary nature that it is not - handled as a service in the <c>Inets</c> service framework.</p> - - </section> - <section> <marker id="options"></marker> <title>DATA TYPES</title> diff --git a/lib/tftp/doc/src/usersguide.xml b/lib/tftp/doc/src/usersguide.xml new file mode 100644 index 0000000000..eb7f7d17c3 --- /dev/null +++ b/lib/tftp/doc/src/usersguide.xml @@ -0,0 +1,37 @@ +<?xml version="1.0" encoding="utf-8" ?> +<!DOCTYPE part SYSTEM "part.dtd"> + +<part xmlns:xi="http://www.w3.org/2001/XInclude"> + <header> + <copyright> + <year>2004</year><year>2018</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>TFTP User's Guide</title> + <prepared>Péter Dimitrov</prepared> + <docno></docno> + <date>2018-03-22</date> + <rev>A</rev> + <file>part.sgml</file> + </header> + <description> + <p>The <c>TFTP</c> application provides a TFTP client and server.</p> + </description> + <xi:include href="introduction.xml"/> + <xi:include href="getting_started.xml"/> +</part> diff --git a/lib/tftp/ebin/.gitignore b/lib/tftp/ebin/.gitignore new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/lib/tftp/ebin/.gitignore diff --git a/lib/tftp/info b/lib/tftp/info new file mode 100644 index 0000000000..1220454351 --- /dev/null +++ b/lib/tftp/info @@ -0,0 +1,2 @@ +group: comm +short: TFTP application diff --git a/lib/inets/src/tftp/Makefile b/lib/tftp/src/Makefile index 4eaa959cce..ed1551ba04 100644 --- a/lib/inets/src/tftp/Makefile +++ b/lib/tftp/src/Makefile @@ -20,30 +20,27 @@ # include $(ERL_TOP)/make/target.mk -EBIN = ../../ebin include $(ERL_TOP)/make/$(TARGET)/otp.mk # ---------------------------------------------------- # Application version # ---------------------------------------------------- -include ../../vsn.mk - -VSN = $(INETS_VSN) - +include ../vsn.mk +VSN = $(TFTP_VSN) # ---------------------------------------------------- # Release directory specification # ---------------------------------------------------- RELSYSDIR = $(RELEASE_PATH)/lib/$(APPLICATION)-$(VSN) - # ---------------------------------------------------- # Target Specs # ---------------------------------------------------- -BEHAVIOUR_MODULES= \ - tftp +BEHAVIOUR_MODULES= MODULES = \ + tftp \ + tftp_app \ tftp_binary \ tftp_engine \ tftp_file \ @@ -61,18 +58,18 @@ TARGET_FILES= $(MODULES:%=$(EBIN)/%.$(EMULATOR)) BEHAVIOUR_TARGET_FILES= $(BEHAVIOUR_MODULES:%=$(EBIN)/%.$(EMULATOR)) +APP_FILE= tftp.app +APPUP_FILE= tftp.appup + +APP_SRC= $(APP_FILE).src +APP_TARGET= $(EBIN)/$(APP_FILE) +APPUP_SRC= $(APPUP_FILE).src +APPUP_TARGET= $(EBIN)/$(APPUP_FILE) + # ---------------------------------------------------- # FLAGS # ---------------------------------------------------- -include ../inets_app/inets.mk - -ERL_COMPILE_FLAGS += \ - $(INETS_FLAGS) \ - $(INETS_ERL_COMPILE_FLAGS) \ - -I../../include \ - -I../inets_app - # ---------------------------------------------------- # Targets @@ -80,12 +77,18 @@ ERL_COMPILE_FLAGS += \ $(TARGET_FILES): $(BEHAVIOUR_TARGET_FILES) -debug opt: $(TARGET_FILES) +debug opt: $(TARGET_FILES) $(APP_TARGET) $(APPUP_TARGET) clean: - rm -f $(TARGET_FILES) $(BEHAVIOUR_TARGET_FILES) + rm -f $(TARGET_FILES) $(APP_TARGET) $(APPUP_TARGET) $(BEHAVIOUR_TARGET_FILES) rm -f core +$(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);' $< > $@ + docs: # ---------------------------------------------------- @@ -94,16 +97,14 @@ docs: include $(ERL_TOP)/make/otp_release_targets.mk release_spec: opt - $(INSTALL_DIR) "$(RELSYSDIR)/src" - $(INSTALL_DIR) "$(RELSYSDIR)/src/tftp" - $(INSTALL_DATA) $(HRL_FILES) $(ERL_FILES) "$(RELSYSDIR)/src/tftp" - $(INSTALL_DIR) "$(RELSYSDIR)/ebin" - $(INSTALL_DATA) $(TARGET_FILES) $(BEHAVIOUR_TARGET_FILES) "$(RELSYSDIR)/ebin" + $(INSTALL_DIR) "$(RELSYSDIR)/src" + $(INSTALL_DATA) $(ERL_FILES) $(HRL_FILES) "$(RELSYSDIR)/src" + $(INSTALL_DIR) "$(RELSYSDIR)/ebin" + $(INSTALL_DATA) $(BEHAVIOUR_TARGET_FILES) $(TARGET_FILES) $(APP_TARGET) \ + $(APPUP_TARGET) "$(RELSYSDIR)/ebin" release_docs_spec: info: @echo "APPLICATION = $(APPLICATION)" - @echo "INETS_DEBUG = $(INETS_DEBUG)" - @echo "INETS_FLAGS = $(INETS_FLAGS)" @echo "ERL_COMPILE_FLAGS = $(ERL_COMPILE_FLAGS)" diff --git a/lib/tftp/src/tftp.app.src b/lib/tftp/src/tftp.app.src new file mode 100644 index 0000000000..2a87d39ada --- /dev/null +++ b/lib/tftp/src/tftp.app.src @@ -0,0 +1,22 @@ +{application, tftp, + [{description, "TFTP application"}, + {vsn, "1.0"}, + {registered, []}, + {mod, { tftp_app, []}}, + {applications, + [kernel, + stdlib + ]}, + {env,[]}, + {modules, [ + tftp, + tftp_app, + tftp_binary, + tftp_engine, + tftp_file, + tftp_lib, + tftp_logger, + tftp_sup + ]}, + {runtime_dependencies, ["stdlib-3.5","kernel-6.0"]} + ]}. diff --git a/lib/tftp/src/tftp.appup.src b/lib/tftp/src/tftp.appup.src new file mode 100644 index 0000000000..06a0f0f9dc --- /dev/null +++ b/lib/tftp/src/tftp.appup.src @@ -0,0 +1,26 @@ +%% -*- erlang -*- +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1999-2018. 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% +{"%VSN%", + [ + {<<".*">>,[{restart_application, tftp}]} + ], + [ + {<<".*">>,[{restart_application, tftp}]} + ] +}. diff --git a/lib/inets/src/tftp/tftp.erl b/lib/tftp/src/tftp.erl index c8804ea55f..27ed13694b 100644 --- a/lib/inets/src/tftp/tftp.erl +++ b/lib/tftp/src/tftp.erl @@ -213,7 +213,8 @@ start/1, info/1, change_config/2, - start/0 + start/0, + stop/0 ]). %% Application local functions @@ -373,7 +374,17 @@ change_config(Pid, Options) -> %%------------------------------------------------------------------- start() -> - application:start(inets). + application:start(tftp). + +%%------------------------------------------------------------------- +%% stop() -> ok | {error, Reason} +%% +%% Reason = term() +%% +%% Stop the application +%%------------------------------------------------------------------- +stop() -> + application:stop(tftp). %%------------------------------------------------------------------- %% Inets service behavior diff --git a/lib/inets/src/tftp/tftp.hrl b/lib/tftp/src/tftp.hrl index 25543e0b9e..25543e0b9e 100644 --- a/lib/inets/src/tftp/tftp.hrl +++ b/lib/tftp/src/tftp.hrl diff --git a/lib/tftp/src/tftp_app.erl b/lib/tftp/src/tftp_app.erl new file mode 100644 index 0000000000..80d54c6cbe --- /dev/null +++ b/lib/tftp/src/tftp_app.erl @@ -0,0 +1,56 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2002-2018. 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% +%% +%% + +%%%------------------------------------------------------------------- +%% @doc ftp public API +%% @end +%%%------------------------------------------------------------------- + +-module(tftp_app). + +-behaviour(application). + +%% Application callbacks +-export([start/2, stop/1]). + +%%==================================================================== +%% API +%%==================================================================== + +start(_StartType, _StartArgs) -> + Config = get_configuration(), + tftp_sup:start_link(Config). + +%%-------------------------------------------------------------------- +stop(_State) -> + ok. + +%%==================================================================== +%% Internal functions +%%==================================================================== + +get_configuration() -> + case (catch application:get_env(tftp, services)) of + {ok, Services} -> + Services; + _ -> + [] + end. diff --git a/lib/inets/src/tftp/tftp_binary.erl b/lib/tftp/src/tftp_binary.erl index 09adcfc41f..09adcfc41f 100644 --- a/lib/inets/src/tftp/tftp_binary.erl +++ b/lib/tftp/src/tftp_binary.erl diff --git a/lib/inets/src/tftp/tftp_engine.erl b/lib/tftp/src/tftp_engine.erl index fb2c9749e5..f14354ad6a 100644 --- a/lib/inets/src/tftp/tftp_engine.erl +++ b/lib/tftp/src/tftp_engine.erl @@ -203,19 +203,19 @@ daemon_loop(#daemon_state{config = DaemonConfig, Fun = fun(#server_info{pid = Pid}, Acc) -> [{server, Pid} | Acc] end, ServerInfo = ets:foldl(Fun, [], ServerTab), Info = internal_info(DaemonConfig, daemon) ++ [{n_conn, N}] ++ ServerInfo, - reply({ok, Info}, Ref, FromPid), + _ = reply({ok, Info}, Ref, FromPid), ?MODULE:daemon_loop(State); {{change_config, Options}, Ref, FromPid} when is_pid(FromPid) -> case catch tftp_lib:parse_config(Options, DaemonConfig) of {'EXIT', Reason} -> - reply({error, Reason}, Ref, FromPid), + _ = reply({error, Reason}, Ref, FromPid), ?MODULE:daemon_loop(State); DaemonConfig2 when is_record(DaemonConfig2, config) -> - reply(ok, Ref, FromPid), + _ = reply(ok, Ref, FromPid), ?MODULE:daemon_loop(State#daemon_state{config = DaemonConfig2}) end; {udp, Socket, RemoteHost, RemotePort, Bin} when is_binary(Bin) -> - inet:setopts(Socket, [{active, once}]), + _ = inet:setopts(Socket, [{active, once}]), ServerConfig = DaemonConfig#config{parent_pid = self(), udp_host = RemoteHost, udp_port = RemotePort}, @@ -449,14 +449,14 @@ client_prepare(Config, Callback, Req) when is_record(Req, tftp_msg_req) -> transfer(Config2, Callback2, Req2, Req2, LocalAccess, BlockNo, #prepared{}), client_open(Config3, Callback3, Req2, BlockNo, TransferRes); {error, {Code, Text}} -> - callback({abort, {Code, Text}}, Config, Callback2, Req), + _ = callback({abort, {Code, Text}}, Config, Callback2, Req), terminate(Config, Req, ?ERROR(post_verify_options, Code, Text, Req#tftp_msg_req.filename)) end; {undefined, #tftp_msg_error{code = Code, text = Text}} -> terminate(Config, Req, ?ERROR(client_prepare, Code, Text, Req#tftp_msg_req.filename)) end; {error, {Code, Text}} -> - callback({abort, {Code, Text}}, Config, Callback, Req), + _ = callback({abort, {Code, Text}}, Config, Callback, Req), terminate(Config, Req, ?ERROR(pre_verify_options, Code, Text, Req#tftp_msg_req.filename)) end. @@ -500,10 +500,10 @@ client_open(Config, Callback, Req, BlockNo, #transfer_res{status = Status, decod %% Req2 = Req#tftp_msg_req{options = []}, %% client_prepare(Config, Callback, Req2); #tftp_msg_error{code = Code, text = Text} -> - callback({abort, {Code, Text}}, Config, Callback, Req), + _ = callback({abort, {Code, Text}}, Config, Callback, Req), terminate(Config, Req, ?ERROR(client_open, Code, Text, Req#tftp_msg_req.filename)); {'EXIT', #tftp_msg_error{code = Code, text = Text}} -> - callback({abort, {Code, Text}}, Config, Callback, Req), + _ = callback({abort, {Code, Text}}, Config, Callback, Req), terminate(Config, Req, ?ERROR(client_open, Code, Text, Req#tftp_msg_req.filename)); Msg when is_tuple(Msg) -> Code = badop, @@ -516,7 +516,7 @@ client_open(Config, Callback, Req, BlockNo, #transfer_res{status = Status, decod end; error when is_record(Prepared, tftp_msg_error) -> #tftp_msg_error{code = Code, text = Text} = Prepared, - callback({abort, {Code, Text}}, Config, Callback, Req), + _ = callback({abort, {Code, Text}}, Config, Callback, Req), terminate(Config, Req, ?ERROR(client_open, Code, Text, Req#tftp_msg_req.filename)) end. @@ -568,10 +568,10 @@ common_loop(Config, Callback, Req, #transfer_res{status = Status, decoded_msg = #tftp_msg_data{block_no = ActualBlockNo, data = Data} when LocalAccess =:= write -> common_write(Config, Callback, Req, LocalAccess, ExpectedBlockNo, ActualBlockNo, Data, Prepared); #tftp_msg_error{code = Code, text = Text} -> - callback({abort, {Code, Text}}, Config, Callback, Req), + _ = callback({abort, {Code, Text}}, Config, Callback, Req), terminate(Config, Req, ?ERROR(common_loop, Code, Text, Req#tftp_msg_req.filename)); {'EXIT', #tftp_msg_error{code = Code, text = Text} = Error} -> - callback({abort, {Code, Text}}, Config, Callback, Req), + _ = callback({abort, {Code, Text}}, Config, Callback, Req), send_msg(Config, Req, Error), terminate(Config, Req, ?ERROR(common_loop, Code, Text, Req#tftp_msg_req.filename)); Msg when is_tuple(Msg) -> @@ -918,7 +918,7 @@ wait_for_msg(Config, Callback, Req) -> {udp, Socket, RemoteHost, RemotePort, Bin} when is_binary(Bin), Callback#callback.block_no =:= undefined -> %% Client prepare - inet:setopts(Socket, [{active, once}]), + _ = inet:setopts(Socket, [{active, once}]), Config2 = Config#config{udp_host = RemoteHost, udp_port = RemotePort}, DecodedMsg = (catch tftp_lib:decode_msg(Bin)), @@ -927,7 +927,7 @@ wait_for_msg(Config, Callback, Req) -> {udp, Socket, Host, Port, Bin} when is_binary(Bin), Config#config.udp_host =:= Host, Config#config.udp_port =:= Port -> - inet:setopts(Socket, [{active, once}]), + _ = inet:setopts(Socket, [{active, once}]), DecodedMsg = (catch tftp_lib:decode_msg(Bin)), print_debug_info(Config, Req, recv, DecodedMsg), {Config, DecodedMsg}; @@ -938,15 +938,15 @@ wait_for_msg(Config, Callback, Req) -> false -> server end, Info = internal_info(Config, Type), - reply({ok, Info}, Ref, FromPid), + _ = reply({ok, Info}, Ref, FromPid), wait_for_msg(Config, Callback, Req); {{change_config, Options}, Ref, FromPid} when is_pid(FromPid) -> case catch tftp_lib:parse_config(Options, Config) of {'EXIT', Reason} -> - reply({error, Reason}, Ref, FromPid), + _ = reply({error, Reason}, Ref, FromPid), wait_for_msg(Config, Callback, Req); Config2 when is_record(Config2, config) -> - reply(ok, Ref, FromPid), + _ = reply(ok, Ref, FromPid), wait_for_msg(Config2, Callback, Req) end; {system, From, Msg} -> @@ -1076,7 +1076,7 @@ do_callback({open, Type}, Config, Callback, Req) Req#tftp_msg_req.options, Callback#callback.state], PeerInfo = peer_info(Config), - fast_ensure_loaded(Mod), + _ = fast_ensure_loaded(Mod), Args2 = case erlang:function_exported(Mod, Fun, length(Args)) of true -> Args; @@ -1295,7 +1295,7 @@ info_msg(#config{logger = Logger}, F, A) -> safe_apply(Logger, info_msg, [F, A]). safe_apply(Mod, Fun, Args) -> - fast_ensure_loaded(Mod), + _ = fast_ensure_loaded(Mod), apply(Mod, Fun, Args). fast_ensure_loaded(Mod) -> diff --git a/lib/inets/src/tftp/tftp_file.erl b/lib/tftp/src/tftp_file.erl index 7664324808..43b588f71a 100644 --- a/lib/inets/src/tftp/tftp_file.erl +++ b/lib/tftp/src/tftp_file.erl @@ -215,13 +215,13 @@ read(#state{access = read} = State) -> Count = State#state.count + size(Bin), {more, Bin, State#state{count = Count}}; {ok, Bin} when is_binary(Bin), size(Bin) < BlkSize -> - file:close(State#state.fd), + _ = file:close(State#state.fd), Count = State#state.count + size(Bin), {last, Bin, Count}; eof -> {last, <<>>, State#state.count}; {error, Reason} -> - file:close(State#state.fd), + _ = file:close(State#state.fd), {error, file_error(Reason)} end; read(State) -> @@ -255,12 +255,12 @@ write(Bin, #state{access = write} = State) when is_binary(Bin) -> Count = State#state.count + Size, {more, State#state{count = Count}}; ok when Size < BlkSize-> - file:close(State#state.fd), + _ = file:close(State#state.fd), Count = State#state.count + Size, {last, Count}; {error, Reason} -> - file:close(State#state.fd), - file:delete(State#state.filename), + _ = file:close(State#state.fd), + _ = file:delete(State#state.filename), {error, file_error(Reason)} end; write(Bin, State) -> @@ -281,7 +281,7 @@ write(Bin, State) -> %%------------------------------------------------------------------- abort(_Code, _Text, #state{fd = Fd, access = Access} = State) -> - file:close(Fd), + _ = file:close(Fd), case Access of write -> ok = file:delete(State#state.filename); diff --git a/lib/inets/src/tftp/tftp_lib.erl b/lib/tftp/src/tftp_lib.erl index 454754f0a3..454754f0a3 100644 --- a/lib/inets/src/tftp/tftp_lib.erl +++ b/lib/tftp/src/tftp_lib.erl diff --git a/lib/inets/src/tftp/tftp_logger.erl b/lib/tftp/src/tftp_logger.erl index a869958484..a869958484 100644 --- a/lib/inets/src/tftp/tftp_logger.erl +++ b/lib/tftp/src/tftp_logger.erl diff --git a/lib/inets/src/tftp/tftp_sup.erl b/lib/tftp/src/tftp_sup.erl index 40b67c499c..0475e53e42 100644 --- a/lib/inets/src/tftp/tftp_sup.erl +++ b/lib/tftp/src/tftp_sup.erl @@ -19,7 +19,7 @@ %% %% %%---------------------------------------------------------------------- -%% Purpose: The top supervisor for tftp hangs under inets_sup. +%% Purpose: The top supervisor for tftp %%---------------------------------------------------------------------- -module(tftp_sup). diff --git a/lib/tftp/test/Makefile b/lib/tftp/test/Makefile new file mode 100644 index 0000000000..99f36256b0 --- /dev/null +++ b/lib/tftp/test/Makefile @@ -0,0 +1,250 @@ +# +# %CopyrightBegin% +# +# Copyright Ericsson AB 1997-2018. 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% +# +# +# For an outline of how this all_SUITE_data stuff works, see the +# make file ../../ssl/test/Makefile. +# +include $(ERL_TOP)/make/target.mk +include $(ERL_TOP)/make/$(TARGET)/otp.mk + +# ---------------------------------------------------- +# Application version +# ---------------------------------------------------- +include ../vsn.mk +VSN = $(TFTP_VSN) + + +# ---------------------------------------------------- +# Release directory specification +# ---------------------------------------------------- +RELSYSDIR = $(RELEASE_PATH)/lib/$(APPLICATION)-$(VSN) + + +# ---------------------------------------------------- +# Target Specs +# ---------------------------------------------------- +INCLUDES = -I. \ + -I$(ERL_TOP)/lib/tftp/src + +CP = cp + +ifeq ($(TESTROOT_DIR),) +TESTROOT_DIR = /ldisk/tests/$(USER)/tftp +endif + +ifeq ($(TFTP_DATA_DIR),) +TFTP_DATA_DIR = $(TESTROOT_DIR)/data_dir +endif + +ifeq ($(TFTP_PRIV_DIR),) +TFTP_PRIV_DIR = $(TESTROOT_DIR)/priv_dir +endif + +TFTP_FLAGS = -Dtftp__data_dir='"$(TFTP_DATA_DIR)"' \ + -Dtftp_priv_dir='"$(TFTP_PRIV_DIR)"' + + +### +### test suite debug flags +### +ifeq ($(TFTP_DEBUG_CLIENT),) + TFTP_DEBUG_CLIENT = y +endif + +ifeq ($(TFTP_DEBUG_CLIENT),) + TFTP_FLAGS += -Dtftp_debug_client +endif + +ifeq ($(TFTP_TRACE_CLIENT),) + TFTP_DEBUG_CLIENT = y +endif + +ifeq ($(TFTP_TRACE_CLIENT),y) + TFTP_FLAGS += -Dtftp_trace_client +endif + +ifneq ($(TFTP_DEBUG),) + TFTP_DEBUG = s +endif + +ifeq ($(TFTP_DEBUG),l) + TFTP_FLAGS += -Dtftp_log +endif + +ifeq ($(TFTP_DEBUG),d) + TFTP_FLAGS += -Dtftp_debug -Dtftp_log +endif + + +TFTP_FLAGS += -pa ../tftp/ebin + +TFTP_ROOT = ../tftp + +MODULES = \ + tftp_SUITE \ + tftp_test_lib + + +EBIN = . + +HRL_FILES = \ + ../src/tftp.hrl \ + tftp_test_lib.hrl + +ERL_FILES = $(MODULES:%=%.erl) + +SOURCE = $(ERL_FILES) $(HRL_FILES) + +TARGET_FILES = $(MODULES:%=$(EBIN)/%.$(EMULATOR)) + +TFTP_SPECS = tftp.spec tftp_bench.spec +COVER_FILE = tftp.cover +TFTP_FILES = tftp.config $(TFTP_SPECS) + + +TFTP_DATADIRS = tftp_SUITE_data + +DATADIRS = $(TFTP_DATADIRS) + +EMAKEFILE = Emakefile +MAKE_EMAKE = $(wildcard $(ERL_TOP)/make/make_emakefile) + +ifeq ($(MAKE_EMAKE),) +BUILDTARGET = $(TARGET_FILES) +RELTEST_FILES = $(COVER_FILE) $(TFTP_SPECS) $(SOURCE) +else +BUILDTARGET = emakebuild +RELTEST_FILES = $(EMAKEFILE) $(COVER_FILE) $(TFTP_SPECS) $(SOURCE) +endif + + +# ---------------------------------------------------- +# Release directory specification +# ---------------------------------------------------- + +RELTESTSYSDIR = "$(RELEASE_PATH)/tftp_test" +RELTESTSYSALLDATADIR = $(RELTESTSYSDIR)/all_SUITE_data +RELTESTSYSBINDIR = $(RELTESTSYSALLDATADIR)/bin + + +# ---------------------------------------------------- +# FLAGS +# The path to the test_server ebin dir is needed when +# running the target "targets". +# ---------------------------------------------------- +ERL_COMPILE_FLAGS += \ + $(INCLUDES) \ + $(TFTP_FLAGS) + +# ---------------------------------------------------- +# Targets +# erl -sname kalle -pa ../ebin +# If you intend to run the test suite locally (private), then +# there is some requirements: +# 1) TFTP_PRIV_DIR must be created +# ---------------------------------------------------- + +tests debug opt: $(BUILDTARGET) + +targets: $(TARGET_FILES) + +.PHONY: emakebuild + +emakebuild: $(EMAKEFILE) + +$(EMAKEFILE): + $(MAKE_EMAKE) $(ERL_COMPILE_FLAGS) -o$(EBIN) '*_SUITE_make' | grep -v Warning > $(EMAKEFILE) + $(MAKE_EMAKE) $(ERL_COMPILE_FLAGS) -o$(EBIN) $(MODULES) | grep -v Warning >> $(EMAKEFILE) + +clean: + rm -f $(EMAKEFILE) + rm -f $(TARGET_FILES) + rm -f core *~ + +docs: + + +# ---------------------------------------------------- +# Release Target +# ---------------------------------------------------- +include $(ERL_TOP)/make/otp_release_targets.mk + +release_spec: opt + $(INSTALL_DIR) "$(RELSYSDIR)/test" + $(INSTALL_DATA) $(HRL_FILES) $(ERL_FILES) "$(RELSYSDIR)/test" + $(INSTALL_DATA) $(TFTP_FILES) "$(RELSYSDIR)/test" + @for d in $(DATADIRS); do \ + echo "installing data dir $$d"; \ + if test -f $$d/TAR.exclude; then \ + echo $$d/TAR.exclude2 > $$d/TAR.exclude2; \ + cat $$d/TAR.exclude >> $$d/TAR.exclude2; \ + find $$d -name '*.contrib*' >> $$d/TAR.exclude2; \ + find $$d -name '*.keep*' >> $$d/TAR.exclude2; \ + find $$d -name '*.mkelem*' >> $$d/TAR.exclude2; \ + find $$d -name '*~' >> $$d/TAR.exclude2; \ + find $$d -name 'erl_crash.dump' >> $$d/TAR.exclude2; \ + find $$d -name 'core' >> $$d/TAR.exclude2; \ + find $$d -name '.cmake.state' >> $$d/TAR.exclude2; \ + tar cfX - $$d/TAR.exclude2 $$d | (cd "$(RELSYSDIR)/test"; tar xf -); \ + else \ + tar cf - $$d | (cd "$(RELSYSDIR)/test"; tar xf -); \ + fi; \ + done + +release_tests_spec: opt + $(INSTALL_DIR) $(RELTESTSYSDIR) + $(INSTALL_DATA) $(RELTEST_FILES) $(RELTESTSYSDIR) + chmod -R u+w $(RELTESTSYSDIR) + tar chf - $(DATADIRS) | (cd $(RELTESTSYSDIR); tar xf -) + $(INSTALL_DIR) $(RELTESTSYSALLDATADIR) + $(INSTALL_DIR) $(RELTESTSYSBINDIR) + chmod -R +x $(RELTESTSYSBINDIR) + $(INSTALL_DIR) $(RELTESTSYSALLDATADIR)/win32/lib + +release_docs_spec: + +info: + @echo "MAKE_EMAKE = $(MAKE_EMAKE)" + @echo "EMAKEFILE = $(EMAKEFILE)" + @echo "BUILDTARGET = $(BUILDTARGET)" + @echo "" + @echo "MODULES = $(MODULES)" + @echo "ERL_FILES = $(ERL_FILES)" + @echo "SOURCE = $(SOURCE)" + @echo "TARGET_FILES = $(TARGET_FILES)" + @echo "" + @echo "TFTP_SPECS = $(TFTP_SPECS)" + @echo "TFTP_FILES = $(TFTP_FILES)" + @echo "" + @echo "RELEASE_PATH = "$(RELEASE_PATH)"" + @echo "RELSYSDIR = "$(RELSYSDIR)"" + @echo "RELTESTSYSDIR = $(RELTESTSYSDIR)" + @echo "RELTESTSYSALLDATADIR = $(RELTESTSYSALLDATADIR)" + @echo "RELTESTSYSBINDIR = $(RELTESTSYSBINDIR)" + @echo "" + @echo "DATADIRS = $(DATADIRS)" + @echo "REL_DATADIRS = $(REL_DATADIRS)" + @echo "" + @echo "TFTP_DATA_DIR = $(TFTP_DATA_DIR)" + @echo "TFTP_PRIV_DIR = $(TFTP_PRIV_DIR)" + @echo "TFTP_ROOT = $(TFTP_ROOT)" + @echo "TFTP_FLAGS = $(TFTP_FLAGS)" + + diff --git a/lib/tftp/test/tftp.config b/lib/tftp/test/tftp.config new file mode 100644 index 0000000000..2600237da9 --- /dev/null +++ b/lib/tftp/test/tftp.config @@ -0,0 +1 @@ +[].
\ No newline at end of file diff --git a/lib/tftp/test/tftp.cover b/lib/tftp/test/tftp.cover new file mode 100644 index 0000000000..22ef5d0dda --- /dev/null +++ b/lib/tftp/test/tftp.cover @@ -0,0 +1,2 @@ +{incl_app,tftp,details}. + diff --git a/lib/tftp/test/tftp.spec b/lib/tftp/test/tftp.spec new file mode 100644 index 0000000000..f3537bc652 --- /dev/null +++ b/lib/tftp/test/tftp.spec @@ -0,0 +1 @@ +{suites,"../tftp_test", all}. diff --git a/lib/inets/test/tftp_SUITE.erl b/lib/tftp/test/tftp_SUITE.erl index 09049e36af..fd1d209c25 100644 --- a/lib/inets/test/tftp_SUITE.erl +++ b/lib/tftp/test/tftp_SUITE.erl @@ -26,21 +26,22 @@ %% Includes and defines %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +-include_lib("common_test/include/ct.hrl"). -include("tftp_test_lib.hrl"). --define(START_DAEMON(PortX, OptionsX), - fun(Port, Options) -> - {ok, Pid} = ?VERIFY({ok, _Pid}, tftp:start([{port, Port} | Options])), - if - Port == 0 -> - {ok, ActualOptions} = ?IGNORE(tftp:info(Pid)), - {value, {port, ActualPort}} = - lists:keysearch(port, 1, ActualOptions), - {ActualPort, Pid}; - true -> - {Port, Pid} - end - end(PortX, OptionsX)). +-define(START_DAEMON(Port, Options), + begin + {ok, Pid} = ?VERIFY({ok, _Pid}, tftp:start([{port, Port} | Options])), + if + Port == 0 -> + {ok, ActualOptions} = ?IGNORE(tftp:info(Pid)), + {value, {port, ActualPort}} = + lists:keysearch(port, 1, ActualOptions), + {ActualPort, Pid}; + true -> + {Port, Pid} + end + end). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% API @@ -74,9 +75,18 @@ end_per_testcase(Case, Config) when is_list(Config) -> suite() -> [{ct_hooks,[ts_install_cth]}]. -all() -> - [simple, extra, reuse_connection, resend_client, - resend_server, large_file]. +all() -> + [ + simple, + extra, + reuse_connection, + resend_client, + resend_server, + large_file, + app, + appup, + start_tftpd + ]. groups() -> []. @@ -94,6 +104,48 @@ end_per_group(_GroupName, Config) -> Config. +app() -> + [{doc, "Test that the tftp app file is ok"}]. +app(Config) when is_list(Config) -> + ok = ?t:app_test(tftp). + +%%-------------------------------------------------------------------- +appup() -> + [{doc, "Test that the tftp appup file is ok"}]. +appup(Config) when is_list(Config) -> + ok = ?t:appup_test(tftp). + +start_tftpd() -> + [{doc, "Start/stop of tfpd service"}]. +start_tftpd(Config) when is_list(Config) -> + process_flag(trap_exit, true), + ok = tftp:start(), + {ok, Pid0} = tftp:start_service([{host, "localhost"}, {port, 0}]), + Pids0 = [ServicePid || {_, ServicePid} <- tftp:services()], + true = lists:member(Pid0, Pids0), + {ok, [_|_]} = tftp:service_info(Pid0), + tftp:stop_service(Pid0), + ct:sleep(100), + Pids1 = [ServicePid || {_, ServicePid} <- tftp:services()], + false = lists:member(Pid0, Pids1), + + {ok, Pid1} = + tftp:start_standalone([{host, "localhost"}, {port, 0}]), + Pids2 = [ServicePid || {_, ServicePid} <- tftp:services()], + false = lists:member(Pid1, Pids2), + %% Standalone service is not supervised + {error,not_found} = tftp:stop_service(Pid1), + ok = tftp:stop(), + + application:load(tftp), + application:set_env(tftp, services, [{tftpd, [{host, "localhost"}, + {port, 0}]}]), + ok = tftp:start(), + 1 = length(tftp:services()), + application:unset_env(tftp, services), + ok = tftp:stop(). + + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% Simple %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -103,7 +155,7 @@ simple(doc) -> simple(suite) -> []; simple(Config) when is_list(Config) -> - ?VERIFY(ok, application:start(inets)), + ?VERIFY(ok, application:start(tftp)), {Port, DaemonPid} = ?IGNORE(?START_DAEMON(0, [{debug, brief}])), @@ -128,7 +180,7 @@ simple(Config) when is_list(Config) -> exit(DaemonPid, kill), ?VERIFY(ok, file:delete(LocalFilename)), ?VERIFY(ok, file:delete(RemoteFilename)), - ?VERIFY(ok, application:stop(inets)), + ?VERIFY(ok, application:stop(tftp)), ok. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -910,7 +962,7 @@ large_file(doc) -> large_file(suite) -> []; large_file(Config) when is_list(Config) -> - ?VERIFY(ok, application:start(inets)), + ?VERIFY(ok, application:start(tftp)), {Port, DaemonPid} = ?IGNORE(?START_DAEMON(0, [{debug, brief}])), @@ -933,7 +985,7 @@ large_file(Config) when is_list(Config) -> exit(DaemonPid, kill), ?VERIFY(ok, file:delete(LocalFilename)), ?VERIFY(ok, file:delete(RemoteFilename)), - ?VERIFY(ok, application:stop(inets)), + ?VERIFY(ok, application:stop(tftp)), ok. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% diff --git a/lib/tftp/test/tftp_bench.spec b/lib/tftp/test/tftp_bench.spec new file mode 100644 index 0000000000..43fa385c85 --- /dev/null +++ b/lib/tftp/test/tftp_bench.spec @@ -0,0 +1 @@ +{suites,"../tftp_test",[]}. diff --git a/lib/inets/test/tftp_test_lib.erl b/lib/tftp/test/tftp_test_lib.erl index f07795324f..45386389cb 100644 --- a/lib/inets/test/tftp_test_lib.erl +++ b/lib/tftp/test/tftp_test_lib.erl @@ -30,11 +30,11 @@ init_per_testcase(_Case, Config) when is_list(Config) -> io:format("\n ", []), - ?IGNORE(application:stop(inets)), + ?IGNORE(application:stop(tftp)), Config. end_per_testcase(_Case, Config) when is_list(Config) -> - ?IGNORE(application:stop(inets)), + ?IGNORE(application:stop(tftp)), Config. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% diff --git a/lib/inets/test/tftp_test_lib.hrl b/lib/tftp/test/tftp_test_lib.hrl index e7a5a37d2c..e7a5a37d2c 100644 --- a/lib/inets/test/tftp_test_lib.hrl +++ b/lib/tftp/test/tftp_test_lib.hrl diff --git a/lib/tftp/vsn.mk b/lib/tftp/vsn.mk new file mode 100644 index 0000000000..f1b0851a8f --- /dev/null +++ b/lib/tftp/vsn.mk @@ -0,0 +1,24 @@ +#-*-makefile-*- ; force emacs to enter makefile-mode + +# %CopyrightBegin% +# +# Copyright Ericsson AB 2001-2018. 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% + +APPLICATION = tftp +TFTP_VSN = 1.0 +PRE_VSN = +APP_VSN = "$(APPLICATION)-$(TFTP_VSN)$(PRE_VSN)" diff --git a/lib/tools/doc/specs/.gitignore b/lib/tools/doc/specs/.gitignore new file mode 100644 index 0000000000..322eebcb06 --- /dev/null +++ b/lib/tools/doc/specs/.gitignore @@ -0,0 +1 @@ +specs_*.xml diff --git a/lib/tools/doc/src/Makefile b/lib/tools/doc/src/Makefile index b554781382..4b663106a0 100644 --- a/lib/tools/doc/src/Makefile +++ b/lib/tools/doc/src/Makefile @@ -84,11 +84,20 @@ HTML_REF_MAN_FILE = $(HTMLDIR)/index.html TOP_PDF_FILE = $(PDFDIR)/$(APPLICATION)-$(VSN).pdf +SPECS_FILES = $(XML_REF3_FILES:%.xml=$(SPECDIR)/specs_%.xml) + +TOP_SPECS_FILE = specs.xml + # ---------------------------------------------------- # FLAGS # ---------------------------------------------------- XML_FLAGS += +TOOLS_SRC=$(ERL_TOP)/lib/tools/src +TOOLS_INCLUDE=$(ERL_TOP)/lib/tools/include + +SPECS_FLAGS = -I$(TOOLS_SRC) -I$(TOOLS_INCLUDE) + # ---------------------------------------------------- # Targets # ---------------------------------------------------- @@ -113,8 +122,13 @@ clean clean_docs: rm -rf $(HTMLDIR)/* rm -f $(MAN3DIR)/* rm -f $(TOP_PDF_FILE) $(TOP_PDF_FILE:%.pdf=%.fo) + rm -f $(SPECDIR)/* rm -f errs core *~ +# erlang_mode doesn't have erlang source so we generate a dummy file for it. +$(SPECDIR)/specs_erlang_mode.xml: + echo '<module name="erlang_mode"/>' > $(SPECDIR)/specs_erlang_mode.xml + # ---------------------------------------------------- # Release Target # ---------------------------------------------------- diff --git a/lib/tools/doc/src/instrument.xml b/lib/tools/doc/src/instrument.xml index bb6f9b6100..9fd9332373 100644 --- a/lib/tools/doc/src/instrument.xml +++ b/lib/tools/doc/src/instrument.xml @@ -4,7 +4,7 @@ <erlref> <header> <copyright> - <year>1998</year><year>2016</year> + <year>1998</year><year>2018</year> <holder>Ericsson AB. All Rights Reserved.</holder> </copyright> <legalnotice> @@ -41,387 +41,190 @@ <note> <p>Note that this whole module is experimental, and the representations used as well as the functionality is likely to change in the future.</p> - <p>The <c>instrument</c> module interface was slightly changed in - Erlang/OTP R9C.</p> </note> - <p>To start an Erlang runtime system with instrumentation, use the - <c>+Mi*</c> set of command-line arguments to the <c>erl</c> command (see - the erts_alloc(3) and erl(1) man pages).</p> - <p>The basic object of study in the case of memory allocation is a memory - allocation map. A memory allocation map contains a list of descriptors - for each allocated memory block. Currently, a descriptor is a 4-tuple</p> - <pre> - {TypeNo, Address, Size, PidDesc} </pre> - <p>where <c>TypeNo</c> is the memory block type number, <c>Address</c> - is its place in memory, and <c>Size</c> is its size, in bytes. - <c>PidDesc</c> is either a tuple <c>{X,Y,Z}</c> identifying the - process which was executing when the block was allocated, or - <c>undefined</c> if no process was executing. The pid tuple - <c>{X,Y,Z}</c> can be transformed into a real pid by usage of the - <c>c:pid/3</c> function.</p> - <p>Various details about memory allocation:</p> - <p>Memory blocks are allocated both on the heap segment and on other memory - segments. This can cause the instrumentation functionality to report - very large holes. Currently the instrumentation functionality doesn't - provide any support for distinguishing between holes between memory - segments, and holes between allocated blocks inside memory segments. - The current size of the process cannot be obtained from within Erlang, - but can be seen with one of the system statistics tools, e.g., - <c>ps</c> or <c>top</c>. The Solaris utility <c>pmap</c> can be - useful. It reports currently mapped memory segments. </p> - <p>Overhead for instrumentation: When the emulator has been started with - the <seealso marker="erts:erts_alloc#Mim">"+Mim true"</seealso> - flag, each block is preceded by a 24 bytes large - header on a 32-bit machine and a 48 bytes large header on a 64-bit - machine. When the emulator has been started with the - <seealso marker="erts:erts_alloc#Mis">"+Mis true"</seealso> - flag, each block is preceded by an 8 bytes large header. These are the header - sizes used by the Erlang 5.3/OTP R9C emulator. Other versions of the - emulator may use other header sizes. The function - <seealso marker="#block_header_size/1">block_header_size/1</seealso> - can be used for retrieving the header size used for a specific memory - allocation map. The time overhead for managing the instrumentation - data is small.</p> - <p>Sizes presented by the instrumentation functionality are (by the - emulator) requested sizes, i.e. neither instrumentation headers nor - headers used by allocators are included.</p> </description> + <datatypes> + <datatype> + <name name="block_histogram"/> + <desc> + <p>A histogram of block sizes where each interval's upper bound is + twice as high as the one before it.</p> + <p>The upper bound of the first interval is provided by the function + that returned the histogram, and the last interval has no upper + bound.</p> + </desc> + </datatype> + <datatype> + <name name="allocation_summary"/> + <desc> + <p>A summary of allocated block sizes (including their headers) grouped + by their <c><anno>Origin</anno></c> and <c><anno>Type</anno></c>.</p> + <p><c><anno>Origin</anno></c> is generally which NIF or driver that + allocated the blocks, or 'system' if it could not be determined.</p> + <p><c><anno>Type</anno></c> is the allocation category that the blocks + belong to, e.g. <c>db_term</c>, <c>message</c> or <c>binary</c>.</p> + <p>If one or more carriers could not be scanned in full without harming + the responsiveness of the system, <c><anno>UnscannedSize</anno></c> + is the number of bytes that had to be skipped.</p> + </desc> + </datatype> + <datatype> + <name name="carrier_info_list"/> + <desc> + <p><c><anno>AllocatorType</anno></c> is the type of the allocator that + employs this carrier.</p> + <p><c><anno>TotalSize</anno></c> is the total size of the carrier, + including its header.</p> + <p><c><anno>AllocatedSize</anno></c> is the combined size of the + carrier's allocated blocks, including their headers.</p> + <p><c><anno>AllocatedCount</anno></c> is the number of allocated + blocks in the carrier.</p> + <p><c><anno>InPool</anno></c> is whether the carrier is in the + migration pool.</p> + <p><c><anno>FreeBlocks</anno></c> is a histogram of the free block + sizes in the carrier.</p> + <p>If the carrier could not be scanned in full without harming the + responsiveness of the system, <c><anno>UnscannedSize</anno></c> is + the number of bytes that had to be skipped.</p> + </desc> + </datatype> + </datatypes> <funcs> + <func> - <name>allocator_descr(MemoryData, TypeNo) -> AllocDescr | invalid_type | "unknown"</name> - <fsummary>Returns a allocator description</fsummary> - <type> - <v>MemoryData = {term(), AllocList}</v> - <v>AllocList = [Desc]</v> - <v>Desc = {int(), int(), int(), PidDesc}</v> - <v>PidDesc = {int(), int(), int()} | undefined</v> - <v>TypeNo = int()</v> - <v>AllocDescr = atom() | string()</v> - </type> - <desc> - <p>Returns the allocator description of the allocator that - manages memory blocks of type number <c>TypeNo</c> used in - <c>MemoryData</c>. - Valid <c>TypeNo</c>s are in the range returned by - <seealso marker="#type_no_range/1">type_no_range/1</seealso> on - this specific memory allocation map. If <c>TypeNo</c> is an - invalid integer, <c>invalid_type</c> is returned.</p> - </desc> - </func> - <func> - <name>block_header_size(MemoryData) -> int()</name> - <fsummary>Returns the memory block header size used by the emulator that generated the memory allocation map</fsummary> - <type> - <v>MemoryData = {term(), AllocList}</v> - <v>AllocList = [Desc]</v> - <v>Desc = {int(), int(), int(), PidDesc}</v> - <v>PidDesc = {int(), int(), int()} | undefined</v> - </type> - <desc> - <marker id="block_header_size_1"></marker> - <p>Returns the memory block header size used by the - emulator that generated the memory allocation map. The block - header size may differ between different emulators.</p> - </desc> - </func> - <func> - <name>class_descr(MemoryData, TypeNo) -> ClassDescr | invalid_type | "unknown"</name> - <fsummary>Returns a allocator description</fsummary> - <type> - <v>MemoryData = {term(), AllocList}</v> - <v>AllocList = [Desc]</v> - <v>Desc = {int(), int(), int(), PidDesc}</v> - <v>PidDesc = {int(), int(), int()} | undefined</v> - <v>TypeNo = int()</v> - <v>ClassDescr = atom() | string()</v> - </type> - <desc> - <p>Returns the class description of the class that - the type number <c>TypeNo</c> used in <c>MemoryData</c> belongs - to. - Valid <c>TypeNo</c>s are in the range returned by - <seealso marker="#type_no_range/1">type_no_range/1</seealso> on - this specific memory allocation map. If <c>TypeNo</c> is an - invalid integer, <c>invalid_type</c> is returned.</p> - </desc> - </func> - <func> - <name>descr(MemoryData) -> DescrMemoryData</name> - <fsummary>Replace type numbers in memory allocation map with type descriptions</fsummary> - <type> - <v>MemoryData = {term(), AllocList}</v> - <v>AllocList = [Desc]</v> - <v>Desc = {int(), int(), int(), PidDesc}</v> - <v>PidDesc = {int(), int(), int()} | undefined</v> - <v>DescrMemoryData = {term(), DescrAllocList}</v> - <v>DescrAllocList = [DescrDesc]</v> - <v>DescrDesc = {TypeDescr, int(), int(), DescrPidDesc}</v> - <v>TypeDescr = atom() | string()</v> - <v>DescrPidDesc = pid() | undefined</v> - </type> - <desc> - <p>Returns a memory allocation map where the type numbers (first - element of <c>Desc</c>) have been replaced by type descriptions, - and pid tuples (fourth element of <c>Desc</c>) have been - replaced by real pids.</p> - </desc> - </func> - <func> - <name>holes(MemoryData) -> ok</name> - <fsummary>Print out the sizes of unused memory blocks</fsummary> - <type> - <v>MemoryData = {term(), AllocList}</v> - <v>AllocList = [Desc]</v> - <v>Desc = {int(), int(), int(), PidDesc}</v> - <v>PidDesc = {int(), int(), int()} | undefined</v> - </type> - <desc> - <p>Prints out the size of each hole (i.e., the space between - allocated blocks) on the terminal. <em>NOTE:</em> Really large holes - are probably holes between memory segments. - The memory allocation map has to be sorted (see - <seealso marker="#sort/1">sort/1</seealso>).</p> - </desc> - </func> - <func> - <name>mem_limits(MemoryData) -> {Low, High}</name> - <fsummary>Return lowest and highest memory address used</fsummary> - <type> - <v>MemoryData = {term(), AllocList}</v> - <v>AllocList = [Desc]</v> - <v>Desc = {int(), int(), int(), PidDesc}</v> - <v>PidDesc = {int(), int(), int()} | undefined</v> - <v>Low = High = int()</v> - </type> - <desc> - <p>Returns a tuple <c>{Low, High}</c> indicating - the lowest and highest address used. - The memory allocation map has to be sorted (see - <seealso marker="#sort/1">sort/1</seealso>).</p> - </desc> - </func> - <func> - <name>memory_data() -> MemoryData | false</name> - <fsummary>Return the current memory allocation map</fsummary> - <type> - <v>MemoryData = {term(), AllocList}</v> - <v>AllocList = [Desc]</v> - <v>Desc = {int(), int(), int(), PidDesc}</v> - <v>PidDesc = {int(), int(), int()} | undefined</v> - </type> - <desc> - <p>Returns <c>MemoryData</c> (a the memory allocation map) - if the emulator has been started with the "<c>+Mim true</c>" - command-line argument; otherwise, <c>false</c>. <em>NOTE:</em><c>memory_data/0</c> blocks execution of other processes while - the data is collected. The time it takes to collect the data can - be substantial.</p> - </desc> - </func> - <func> - <name>memory_status(StatusType) -> [StatusInfo] | false</name> - <fsummary>Return current memory allocation status</fsummary> - <type> - <v>StatusType = total | allocators | classes | types</v> - <v>StatusInfo = {About, [Info]}</v> - <v>About = atom()</v> - <v>Info = {InfoName, Current, MaxSinceLast, MaxEver}</v> - <v>InfoName = sizes|blocks</v> - <v>Current = int()</v> - <v>MaxSinceLast = int()</v> - <v>MaxEver = int()</v> - </type> - <desc> - <p>Returns a list of <c>StatusInfo</c> if the emulator has been - started with the "<c>+Mis true</c>" or "<c>+Mim true</c>" - command-line argument; otherwise, <c>false</c>. </p> - <p>See the - <seealso marker="#read_memory_status/1">read_memory_status/1</seealso> - function for a description of the <c>StatusInfo</c> term.</p> - </desc> - </func> - <func> - <name>read_memory_data(File) -> MemoryData | {error, Reason}</name> - <fsummary>Read memory allocation map</fsummary> - <type> - <v>File = string()</v> - <v>MemoryData = {term(), AllocList}</v> - <v>AllocList = [Desc]</v> - <v>Desc = {int(), int(), int(), PidDesc}</v> - <v>PidDesc = {int(), int(), int()} | undefined</v> - </type> + <name name="allocations" arity="0"/> + <fsummary>Return a summary of all allocations in the system.</fsummary> <desc> - <marker id="read_memory_data_1"></marker> - <p>Reads a memory allocation map from the file <c>File</c> and - returns it. The file is assumed to have been created by - <c>store_memory_data/1</c>. The error codes are the same as for - <c>file:consult/1</c>.</p> + <p>Shorthand for + <seealso marker="#allocations/1"><c>allocations(#{})</c>.</seealso></p> </desc> </func> + <func> - <name>read_memory_status(File) -> MemoryStatus | {error, Reason}</name> - <fsummary>Read memory allocation status from a file</fsummary> - <type> - <v>File = string()</v> - <v>MemoryStatus = [{StatusType, [StatusInfo]}]</v> - <v>StatusType = total | allocators | classes | types</v> - <v>StatusInfo = {About, [Info]}</v> - <v>About = atom()</v> - <v>Info = {InfoName, Current, MaxSinceLast, MaxEver}</v> - <v>InfoName = sizes|blocks</v> - <v>Current = int()</v> - <v>MaxSinceLast = int()</v> - <v>MaxEver = int()</v> - </type> - <desc> - <marker id="read_memory_status_1"></marker> - <p>Reads memory allocation status from the file <c>File</c> and - returns it. The file is assumed to have been created by - <c>store_memory_status/1</c>. The error codes are the same as - for <c>file:consult/1</c>.</p> - <p>When <c>StatusType</c> is <c>allocators</c>, <c>About</c> is - the allocator that the information is about. When - <c>StatusType</c> is <c>types</c>, <c>About</c> is - the memory block type that the information is about. Memory - block types are not described other than by their name and may - vary between emulators. When <c>StatusType</c> is <c>classes</c>, - <c>About</c> is the memory block type class that information is - presented about. Memory block types are classified after their - use. Currently the following classes exist:</p> + <name name="allocations" arity="1"/> + <fsummary>Return a summary of all allocations filtered by allocator type + and scheduler id.</fsummary> + <desc> + <p>Returns a summary of all tagged allocations in the system, + optionally filtered by allocator type and scheduler id.</p> + <p>Only binaries and allocations made by NIFs and drivers are tagged by + default, but this can be configured an a per-allocator basis with the + <seealso marker="erts:erts_alloc#M_atags"><c>+M<S>atags</c> + </seealso> emulator option.</p> + <p>If tagged allocations are not enabled on any of the specified + allocator types, the call will fail with + <c>{error, not_enabled}</c>.</p> + <p>The following options can be used:</p> <taglist> - <tag><c>process_data</c></tag> - <item>Erlang process specific data.</item> - <tag><c>binary_data</c></tag> - <item>Erlang binaries.</item> - <tag><c>atom_data</c></tag> - <item>Erlang atoms.</item> - <tag><c>code_data</c></tag> - <item>Erlang code.</item> - <tag><c>system_data</c></tag> - <item>Other data used by the system</item> + <tag><c>allocator_types</c></tag> + <item> + <p>The allocator types that will be searched. Defaults to all + <c>alloc_util</c> allocators.</p> + </item> + <tag><c>scheduler_ids</c></tag> + <item> + <p>The scheduler ids whose allocator instances will be searched. A + scheduler id of 0 will refer to the global instance that is not + tied to any particular scheduler. Defaults to all schedulers and + the global instance.</p> + </item> + <tag><c>histogram_start</c></tag> + <item> + <p>The upper bound of the first interval in the allocated block + size histograms. Defaults to 128.</p> + </item> + <tag><c>histogram_width</c></tag> + <item> + <p>The number of intervals in the allocated block size histograms. + Defaults to 18.</p> + </item> </taglist> - <p>When <c>InfoName</c> is <c>sizes</c>, <c>Current</c>, - <c>MaxSinceLast</c>, and <c>MaxEver</c> are, respectively, current - size, maximum size since last call to - <c>store_memory_status/1</c> or <c>memory_status/1</c> with the - specific <c>StatusType</c>, and maximum size since the emulator - was started. When <c>InfoName</c> is <c>blocks</c>, <c>Current</c>, - <c>MaxSinceLast</c>, and <c>MaxEver</c> are, respectively, current - number of blocks, maximum number of blocks since last call to - <c>store_memory_status/1</c> or <c>memory_status/1</c> with the - specific <c>StatusType</c>, and maximum number of blocks since the - emulator was started. </p> - <p><em>NOTE:</em>A memory block is accounted for at - "the first level" allocator. E.g. <c>fix_alloc</c> allocates its - memory pools via <c>ll_alloc</c>. When a <c>fix_alloc</c> block - is allocated, neither the block nor the pool in which it resides - are accounted for as memory allocated via <c>ll_alloc</c> even - though it is.</p> - </desc> - </func> - <func> - <name>sort(MemoryData) -> MemoryData</name> - <fsummary>Sort the memory allocation list</fsummary> - <type> - <v>MemoryData = {term(), AllocList}</v> - <v>AllocList = [Desc]</v> - <v>Desc = {int(), int(), int(), PidDesc}</v> - <v>PidDesc = {int(), int(), int()} | undefined</v> - </type> - <desc> - <marker id="sort_1"></marker> - <p>Sorts a memory allocation map so that the addresses are in - ascending order.</p> - </desc> - </func> - <func> - <name>store_memory_data(File) -> true|false</name> - <fsummary>Store the current memory allocation map on a file</fsummary> - <type> - <v>File = string()</v> - </type> - <desc> - <p>Stores the current memory allocation map on the file - <c>File</c>. Returns <c>true</c> if the emulator has been - started with the "<c>+Mim true</c>" command-line argument, and - the map was successfully stored; otherwise, <c>false</c>. The - contents of the file can later be read using - <seealso marker="#read_memory_data/1">read_memory_data/1</seealso>. - <em>NOTE:</em><c>store_memory_data/0</c> blocks execution of - other processes while the data is collected. The time it takes - to collect the data can be substantial.</p> - </desc> - </func> - <func> - <name>store_memory_status(File) -> true|false</name> - <fsummary>Store the current memory allocation status on a file</fsummary> - <type> - <v>File = string()</v> - </type> - <desc> - <p>Stores the current memory status on the file - <c>File</c>. Returns <c>true</c> if the emulator has been - started with the "<c>+Mis true</c>", or "<c>+Mim true</c>" - command-line arguments, and the data was successfully stored; - otherwise, <c>false</c>. The contents of the file can later be - read using - <seealso marker="#read_memory_status/1">read_memory_status/1</seealso>.</p> - </desc> - </func> - <func> - <name>sum_blocks(MemoryData) -> int()</name> - <fsummary>Return the total amount of memory used</fsummary> - <type> - <v>MemoryData = {term(), AllocList}</v> - <v>AllocList = [Desc]</v> - <v>Desc = {int(), int(), int(), PidDesc}</v> - <v>PidDesc = {int(), int(), int()} | undefined</v> - </type> - <desc> - <p>Returns the total size of the memory blocks in the list.</p> + <p><em>Example:</em></p> + <code type="none"><![CDATA[ +> instrument:allocations(#{ histogram_start => 128, histogram_width => 15 }). +{ok,{128,0, + #{udp_inet => + #{driver_event_state => {0,0,0,0,0,0,0,0,0,1,0,0,0,0,0}}, + system => + #{heap => {0,0,0,0,20,4,2,2,2,3,0,1,0,0,1}, + db_term => {271,3,1,52,80,1,0,0,0,0,0,0,0,0,0}, + code => {0,0,0,5,3,6,11,22,19,20,10,2,1,0,0}, + binary => {18,0,0,0,7,0,0,1,0,0,0,0,0,0,0}, + message => {0,40,78,2,2,0,0,0,0,0,0,0,0,0,0}, + ... } + spawn_forker => + #{driver_select_data_state => + {1,0,0,0,0,0,0,0,0,0,0,0,0,0,0}}, + ram_file_drv => #{drv_binary => {0,0,0,0,0,0,1,0,0,0,0,0,0,0,0}}, + prim_file => + #{process_specific_data => {2,0,0,0,0,0,0,0,0,0,0,0,0,0,0}, + nif_trap_export_entry => {0,4,0,0,0,0,0,0,0,0,0,0,0,0,0}, + monitor_extended => {0,1,0,0,0,0,0,0,0,0,0,0,0,0,0}, + drv_binary => {0,0,0,0,0,0,1,0,3,5,0,0,0,1,0}, + binary => {0,4,0,0,0,0,0,0,0,0,0,0,0,0,0}}, + prim_buffer => + #{nif_internal => {0,4,0,0,0,0,0,0,0,0,0,0,0,0,0}, + binary => {0,4,0,0,0,0,0,0,0,0,0,0,0,0,0}}}}} + ]]></code> </desc> </func> + <func> - <name>type_descr(MemoryData, TypeNo) -> TypeDescr | invalid_type</name> - <fsummary>Returns a type description</fsummary> - <type> - <v>MemoryData = {term(), AllocList}</v> - <v>AllocList = [Desc]</v> - <v>Desc = {int(), int(), int(), PidDesc}</v> - <v>PidDesc = {int(), int(), int()} | undefined</v> - <v>TypeNo = int()</v> - <v>TypeDescr = atom() | string()</v> - </type> + <name name="carriers" arity="0"/> + <fsummary>Return a list of all carriers in the system.</fsummary> <desc> - <p>Returns the type description of a type number used in - <c>MemoryData</c>. - Valid <c>TypeNo</c>s are in the range returned by - <seealso marker="#type_no_range/1">type_no_range/1</seealso> on - this specific memory allocation map. If <c>TypeNo</c> is an - invalid integer, <c>invalid_type</c> is returned.</p> + <p>Shorthand for + <seealso marker="#carriers/1"><c>carriers(#{})</c>.</seealso></p> </desc> </func> + <func> - <name>type_no_range(MemoryData) -> {Min, Max}</name> - <fsummary>Returns the memory block type numbers</fsummary> - <type> - <v>MemoryData = {term(), AllocList}</v> - <v>AllocList = [Desc]</v> - <v>Desc = {int(), int(), int(), PidDesc}</v> - <v>PidDesc = {int(), int(), int()} | undefined</v> - <v>Min = int()</v> - <v>Max = int()</v> - </type> + <name name="carriers" arity="1"/> + <fsummary>Return a list of all carriers filtered by allocator type and + scheduler id.</fsummary> <desc> - <marker id="type_no_range_1"></marker> - <p>Returns the memory block type number range used in - <c>MemoryData</c>. When the memory allocation map was generated - by an Erlang 5.3/OTP R9C or newer emulator, all integers <c>T</c> - that satisfy <c>Min</c> <= <c>T</c> <= <c>Max</c> are - valid type numbers. When the memory allocation map was generated - by a pre Erlang 5.3/OTP R9C emulator, all integers in the - range are <em>not</em> valid type numbers.</p> + <p>Returns a summary of all carriers in the system, optionally filtered + by allocator type and scheduler id.</p> + <p>If the specified allocator types are not enabled, the call will fail + with <c>{error, not_enabled}</c>.</p> + <p>The following options can be used:</p> + <taglist> + <tag><c>allocator_types</c></tag> + <item> + <p>The allocator types that will be searched. Defaults to all + <c>alloc_util</c> allocators.</p> + </item> + <tag><c>scheduler_ids</c></tag> + <item> + <p>The scheduler ids whose allocator instances will be searched. A + scheduler id of 0 will refer to the global instance that is not + tied to any particular scheduler. Defaults to all schedulers and + the global instance.</p> + </item> + <tag><c>histogram_start</c></tag> + <item> + <p>The upper bound of the first interval in the free block size + histograms. Defaults to 512.</p> + </item> + <tag><c>histogram_width</c></tag> + <item> + <p>The number of intervals in the free block size histograms. + Defaults to 14.</p> + </item> + </taglist> + <p><em>Example:</em></p> + <code type="none"><![CDATA[ +> instrument:carriers(#{ histogram_start => 512, histogram_width => 8 }). +{ok,{512, + [{ll_alloc,1048576,0,1048344,71,false,{0,0,0,0,0,0,0,0}}, + {binary_alloc,1048576,0,324640,13,false,{3,0,0,1,0,0,0,2}}, + {eheap_alloc,2097152,0,1037200,45,false,{2,1,1,3,4,3,2,2}}, + {fix_alloc,32768,0,29544,82,false,{22,0,0,0,0,0,0,0}}, + {...}|...]}} + ]]></code> </desc> </func> + </funcs> <section> diff --git a/lib/tools/doc/src/specs.xml b/lib/tools/doc/src/specs.xml new file mode 100644 index 0000000000..0b5b7b171c --- /dev/null +++ b/lib/tools/doc/src/specs.xml @@ -0,0 +1,12 @@ +<?xml version="1.0" encoding="utf-8" ?> +<specs xmlns:xi="http://www.w3.org/2001/XInclude"> + <xi:include href="../specs/specs_fprof.xml"/> + <xi:include href="../specs/specs_make.xml"/> + <xi:include href="../specs/specs_lcnt.xml"/> + <xi:include href="../specs/specs_eprof.xml"/> + <xi:include href="../specs/specs_tags.xml"/> + <xi:include href="../specs/specs_cover.xml"/> + <xi:include href="../specs/specs_xref.xml"/> + <xi:include href="../specs/specs_instrument.xml"/> + <xi:include href="../specs/specs_erlang_mode.xml"/> +</specs> diff --git a/lib/tools/emacs/erlang.el b/lib/tools/emacs/erlang.el index e4166053d5..fd51aca861 100644 --- a/lib/tools/emacs/erlang.el +++ b/lib/tools/emacs/erlang.el @@ -825,6 +825,7 @@ resulting regexp is surrounded by \\_< and \\_>." "list_to_tuple" "load_module" "make_ref" + "map_get" "map_size" "max" "min" @@ -884,8 +885,6 @@ resulting regexp is surrounded by \\_< and \\_>." "alloc_sizes" "append" "append_element" - "await_proc_exit" - "await_sched_wall_time_modifications" "bump_reductions" "call_on_load_function" "cancel_timer" @@ -895,16 +894,15 @@ resulting regexp is surrounded by \\_< and \\_>." "decode_packet" "delay_trap" "delete_element" - "dexit" - "dgroup_leader" "display" "display_nl" "display_string" - "dist_exit" - "dlink" + "dist_get_stat" + "dist_ctrl_get_data" + "dist_ctrl_get_data_notification" + "dist_ctrl_input_handler" + "dist_ctrl_put_data" "dmonitor_node" - "dmonitor_p" - "dsend" "dt_append_vm_tag_data" "dt_get_tag" "dt_get_tag_data" @@ -912,8 +910,8 @@ resulting regexp is surrounded by \\_< and \\_>." "dt_put_tag" "dt_restore_tag" "dt_spread_tag" - "dunlink" "convert_time_unit" + "exit_signal" "external_size" "finish_after_on_load" "finish_loading" @@ -924,7 +922,6 @@ resulting regexp is surrounded by \\_< and \\_>." "function_exported" "garbage_collect_message_area" "gather_gc_info_result" - "gather_sched_wall_time_result" "get_cookie" "get_module_info" "get_stacktrace" diff --git a/lib/tools/src/cover.erl b/lib/tools/src/cover.erl index 4e64d7aa4e..bf5faa165d 100644 --- a/lib/tools/src/cover.erl +++ b/lib/tools/src/cover.erl @@ -2439,11 +2439,11 @@ do_analyse_to_file1(Module, OutFile, ErlFile, HTML) -> Timestamp = io_lib:format("~p-~s-~s at ~s:~s:~s", [Y, - string:right(integer_to_list(Mo), 2, $0), - string:right(integer_to_list(D), 2, $0), - string:right(integer_to_list(H), 2, $0), - string:right(integer_to_list(Mi), 2, $0), - string:right(integer_to_list(S), 2, $0)]), + string:pad(integer_to_list(Mo), 2, leading, $0), + string:pad(integer_to_list(D), 2, leading, $0), + string:pad(integer_to_list(H), 2, leading, $0), + string:pad(integer_to_list(Mi), 2, leading, $0), + string:pad(integer_to_list(S), 2, leading, $0)]), H2Bin = unicode:characters_to_binary( ["File generated from ",ErlFile," by COVER ", @@ -2499,12 +2499,12 @@ print_lines(Module, CovLines, InFd, OutFd, L, HTML) -> if N=:=0, HTML=:=true -> LineNoNL = Line -- "\n", Str = " 0", - %%Str = string:right("0", 6, 32), + %%Str = string:pad("0", 6, leading, $\s), RedLine = ["<font color=red>",Str,fill1(), LineNoNL,"</font>\n"], ok = file:write(OutFd, RedLine); N < 1000000 -> - Str = string:right(integer_to_list(N), 6, 32), + Str = string:pad(integer_to_list(N), 6, leading, $\s), ok = file:write(OutFd, [Str,fill1(),Line]); N < 10000000 -> Str = integer_to_list(N), diff --git a/lib/tools/src/fprof.erl b/lib/tools/src/fprof.erl index fb657c2928..a3b4bfdddf 100644 --- a/lib/tools/src/fprof.erl +++ b/lib/tools/src/fprof.erl @@ -1242,8 +1242,7 @@ spawn_3step(Spawn, FunPrelude, FunAck, FunBody) catch Child ! {Parent, Ref, Go}, Result catch - Class:Reason -> - Stacktrace = erlang:get_stacktrace(), + Class:Reason:Stacktrace -> catch exit(Child, kill), erlang:raise(Class, Reason, Stacktrace) end; diff --git a/lib/tools/src/instrument.erl b/lib/tools/src/instrument.erl index 055f4a7afb..0203fefe13 100644 --- a/lib/tools/src/instrument.erl +++ b/lib/tools/src/instrument.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1998-2016. All Rights Reserved. +%% Copyright Ericsson AB 1998-2018. 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. @@ -19,410 +19,140 @@ %% -module(instrument). --export([holes/1, mem_limits/1, memory_data/0, read_memory_data/1, - sort/1, store_memory_data/1, sum_blocks/1, - descr/1, type_descr/2, allocator_descr/2, class_descr/2, - type_no_range/1, block_header_size/1, store_memory_status/1, - read_memory_status/1, memory_status/1]). - - --define(OLD_INFO_SIZE, 32). %% (sizeof(mem_link) in pre R9C utils.c) - --define(IHMARKER(H), element(1, H)). --define(VSN(H), element(2, H)). --define(INFO_SIZE(H), element(3, H)). --define(TYPEMAP(H), element(4, H)). - --define(IHDR(H), is_tuple(H), ?IHMARKER(H) =:= instr_hdr). --define(IHDRVSN(H, V), ?IHDR(H), ?VSN(H) =:= V). - -memory_data() -> - case catch erlang:system_info(allocated) of - {'EXIT',{Error,_}} -> - erlang:error(Error, []); - {'EXIT',Error} -> - erlang:error(Error, []); - Res -> - Res +-export([allocations/0, allocations/1, + carriers/0, carriers/1]). + +-type block_histogram() :: tuple(). + +-type allocation_summary() :: + {HistogramStart :: non_neg_integer(), + UnscannedSize :: non_neg_integer(), + Allocations :: #{ Origin :: atom() => + #{ Type :: atom() => block_histogram() }}}. + +-spec allocations() -> {ok, Result} | {error, Reason} when + Result :: allocation_summary(), + Reason :: not_enabled. +allocations() -> + allocations(#{}). + +-spec allocations(Options) -> {ok, Result} | {error, Reason} when + Result :: allocation_summary(), + Reason :: not_enabled, + Options :: #{ scheduler_ids => list(non_neg_integer()), + allocator_types => list(atom()), + histogram_start => pos_integer(), + histogram_width => pos_integer() }. +allocations(Options) -> + Ref = make_ref(), + + Defaults = #{ scheduler_ids => lists:seq(0, erlang:system_info(schedulers)), + allocator_types => erlang:system_info(alloc_util_allocators), + histogram_start => 128, + histogram_width => 18 }, + + {HistStart, MsgCount} = + dispatch_gather(maps:merge(Defaults, Options), Ref, + fun erts_internal:gather_alloc_histograms/1), + + alloc_hist_receive(HistStart, MsgCount, Ref). + +alloc_hist_receive(_HistStart, 0, _Ref) -> + {error, not_enabled}; +alloc_hist_receive(HistStart, MsgCount, Ref) when MsgCount > 0 -> + {Unscanned, Histograms} = alloc_hist_receive_1(MsgCount, Ref, 0, #{}), + {ok, {HistStart, Unscanned, Histograms}}. + +alloc_hist_receive_1(0, _Ref, Unscanned, Result) -> + {Unscanned, Result}; +alloc_hist_receive_1(MsgCount, Ref, Unscanned0, Result0) -> + receive + {Ref, Unscanned, Tags} -> + Result = lists:foldl(fun alloc_hist_fold_result/2, Result0, Tags), + alloc_hist_receive_1(MsgCount - 1, Ref, Unscanned0 + Unscanned, Result) end. -store_memory_data(File) -> - case catch erlang:system_info({allocated, File}) of - {'EXIT',{Error,_}} -> - erlang:error(Error, [File]); - {'EXIT',Error} -> - erlang:error(Error, [File]); - Res -> - Res +alloc_hist_fold_result({Id, Type, BlockHist}, Result0) -> + IdAllocs0 = maps:get(Id, Result0, #{}), + MergedHists = case maps:find(Type, IdAllocs0) of + {ok, PrevHist} -> + alloc_hist_merge_hist(tuple_size(BlockHist), + BlockHist, + PrevHist); + error -> + BlockHist + end, + IdAllocs = IdAllocs0#{ Type => MergedHists }, + Result0#{ Id => IdAllocs }. + +alloc_hist_merge_hist(0, A, _B) -> + A; +alloc_hist_merge_hist(Index, A, B) -> + Merged = setelement(Index, A, element(Index, A) + element(Index, B)), + alloc_hist_merge_hist(Index - 1, Merged, B). + +-type carrier_info_list() :: + {HistogramStart :: non_neg_integer(), + Carriers :: [{AllocatorType :: atom(), + TotalSize :: non_neg_integer(), + UnscannedSize :: non_neg_integer(), + AllocatedSize :: non_neg_integer(), + AllocatedCount :: non_neg_integer(), + InPool :: boolean(), + FreeBlocks :: block_histogram()}]}. + +-spec carriers() -> {ok, Result} | {error, Reason} when + Result :: carrier_info_list(), + Reason :: not_enabled. +carriers() -> + carriers(#{}). + +-spec carriers(Options) -> {ok, Result} | {error, Reason} when + Result :: carrier_info_list(), + Reason :: not_enabled, + Options :: #{ scheduler_ids => list(non_neg_integer()), + allocator_types => list(atom()), + histogram_start => pos_integer(), + histogram_width => pos_integer() }. +carriers(Options) -> + Ref = make_ref(), + + Defaults = #{ scheduler_ids => lists:seq(0, erlang:system_info(schedulers)), + allocator_types => erlang:system_info(alloc_util_allocators), + histogram_start => 512, + histogram_width => 14 }, + + {HistStart, MsgCount} = + dispatch_gather(maps:merge(Defaults, Options), Ref, + fun erts_internal:gather_carrier_info/1), + + carrier_info_receive(HistStart, MsgCount, Ref). + +carrier_info_receive(_HistStart, 0, _Ref) -> + {error, not_enabled}; +carrier_info_receive(HistStart, MsgCount, Ref) -> + {ok, {HistStart, carrier_info_receive_1(MsgCount, Ref, [])}}. + +carrier_info_receive_1(0, _Ref, Result) -> + lists:flatten(Result); +carrier_info_receive_1(MsgCount, Ref, Result0) -> + receive + {Ref, Carriers} -> + carrier_info_receive_1(MsgCount - 1, Ref, [Carriers, Result0]) end. -memory_status(Type) when is_atom(Type) -> - case catch erlang:system_info({allocated, status, Type}) of - {'EXIT',{Error,_}} -> - erlang:error(Error, [Type]); - {'EXIT',Error} -> - erlang:error(Error, [Type]); - Res -> - Res - end; -memory_status(Type) -> - erlang:error(badarg, [Type]). - -store_memory_status(File) when is_list(File) -> - case catch erlang:system_info({allocated, status, File}) of - {'EXIT',{Error,_}} -> - erlang:error(Error, [File]); - {'EXIT',Error} -> - erlang:error(Error, [File]); - Res -> - Res - end; -store_memory_status(File) -> - erlang:error(badarg, [File]). - -read_memory_data(File) when is_list(File) -> - case file:consult(File) of - {ok, [Hdr|MD]} when ?IHDR(Hdr) -> - {Hdr, MD}; - {ok, [{T,A,S,undefined}|_] = MD} when is_integer(T), - is_integer(A), - is_integer(S) -> - {{instr_hdr, 1, ?OLD_INFO_SIZE}, MD}; - {ok, [{T,A,S,{X,Y,Z}}|_] = MD} when is_integer(T), - is_integer(A), - is_integer(S), - is_integer(X), - is_integer(Y), - is_integer(Z) -> - {{instr_hdr, 1, ?OLD_INFO_SIZE}, MD}; - {ok, _} -> - {error, eio}; - Error -> - Error - end; -read_memory_data(File) -> - erlang:error(badarg, [File]). - -read_memory_status(File) when is_list(File) -> - case file:consult(File) of - {ok, [{instr_vsn, _}|Stat]} -> - Stat; - {ok, _} -> - {error, eio}; - Error -> - Error - end; -read_memory_status(File) -> - erlang:error(badarg, [File]). - -holes({Hdr, MD}) when ?IHDR(Hdr) -> - check_holes(?INFO_SIZE(Hdr), MD). - -check_holes(_ISz, []) -> - ok; -check_holes(ISz, [E | L]) -> - check_holes(ISz, E, L). - -check_holes(_ISz, _E1, []) -> - io:format("~n"); -check_holes(ISz, E1, [E2 | Rest]) -> - check_hole(ISz, E1, E2), - check_holes(ISz, E2, Rest). - -check_hole(ISz, {_,P1,S1,_}, {_,P2,_,_}) -> - End = P1+S1, - Hole = P2 - (End + ISz), - if - Hole =< 7 -> - ok; - true -> - io:format(" ~p", [Hole]) - end. - -sum_blocks({Hdr, L}) when ?IHDR(Hdr) -> - lists:foldl(fun({_,_,S,_}, Sum) -> S+Sum end, - 0, - L). - -mem_limits({Hdr, L}) when ?IHDR(Hdr) -> - {_, P1, _, _} = hd(L), - {_, P2, S2, _} = lists:last(L), - {P1, P2+S2}. - -sort({Hdr, MD}) when ?IHDR(Hdr) -> - {Hdr, lists:keysort(2, MD)}. - -descr({Hdr, MD} = ID) when ?IHDR(Hdr) -> - {Hdr, lists:map(fun ({TN, Addr, Sz, {0, N, S}}) -> - {type_descr(ID, TN), - Addr, - Sz, - list_to_pid("<0." - ++ integer_to_list(N) - ++ "." - ++ integer_to_list(S) - ++ ">")}; - ({TN, Addr, Sz, undefined}) -> - {type_descr(ID, TN), - Addr, - Sz, - undefined} - end, - MD)}. - -block_header_size({Hdr, _}) when ?IHDR(Hdr) -> - ?INFO_SIZE(Hdr). - -type_descr({Hdr, _}, TypeNo) when ?IHDRVSN(Hdr, 2), - is_integer(TypeNo) -> - case catch element(1, element(TypeNo, ?TYPEMAP(Hdr))) of - {'EXIT', _} -> invalid_type; - Type -> Type - end; -type_descr({Hdr, _}, TypeNo) when ?IHDRVSN(Hdr, 1), - is_integer(TypeNo) -> - type_string(TypeNo). - - -allocator_descr({Hdr, _}, TypeNo) when ?IHDRVSN(Hdr, 2), is_integer(TypeNo) -> - case catch element(2, element(TypeNo, ?TYPEMAP(Hdr))) of - {'EXIT', _} -> invalid_type; - Type -> Type - end; -allocator_descr({Hdr, _}, TypeNo) when ?IHDRVSN(Hdr, 1), is_integer(TypeNo) -> - "unknown". - -class_descr({Hdr, _}, TypeNo) when ?IHDRVSN(Hdr, 2), is_integer(TypeNo) -> - case catch element(3, element(TypeNo, ?TYPEMAP(Hdr))) of - {'EXIT', _} -> invalid_type; - Type -> Type - end; -class_descr({Hdr, _}, TypeNo) when ?IHDRVSN(Hdr, 1), is_integer(TypeNo) -> - "unknown". - -type_no_range({Hdr, _}) when ?IHDRVSN(Hdr, 2) -> - {1, tuple_size(?TYPEMAP(Hdr))}; -type_no_range({Hdr, _}) when ?IHDRVSN(Hdr, 1) -> - {-1, 1000}. - -type_string(-1) -> - "unknown"; -type_string(1) -> - "atom text"; -type_string(11) -> - "atom desc"; -type_string(2) -> - "bignum (big_to_list)"; -type_string(31) -> - "fixalloc"; -type_string(32) -> - "unknown fixalloc block"; -type_string(33) -> - "message buffer"; -type_string(34) -> - "message link"; -type_string(4) -> - "estack"; -type_string(40) -> - "db table vec"; -type_string(41) -> - "db tree select buffer"; -type_string(43) -> - "db hash select buffer"; -type_string(44) -> - "db hash select list"; -type_string(45) -> - "db match prog stack"; -type_string(46) -> - "db match prog heap data"; -type_string(47) -> - "db temp buffer"; -type_string(48) -> - "db error"; -type_string(49) -> - "db error info"; -type_string(50) -> - "db trans tab"; -type_string(51) -> - "db segment"; -type_string(52) -> - "db term"; -type_string(53) -> - "db add_counter"; -type_string(54) -> - "db segment table"; -type_string(55) -> - "db table (fix)"; -type_string(56) -> - "db bindings"; -type_string(57) -> - "db counter"; -type_string(58) -> - "db trace vec"; -type_string(59) -> - "db fixed deletion"; -type_string(60) -> - "binary (external.c)"; -type_string(61) -> - "binary"; -type_string(62) -> - "procbin (fix)"; -type_string(70) -> - "driver alloc (io.c)"; -type_string(71) -> - "binary (io.c)"; -type_string(72) -> - "binary vec (io.c)"; -type_string(73) -> - "binary vec 2 (io.c)"; -type_string(74) -> - "io vec (io.c)"; -type_string(75) -> - "io vec 2 (io.c)"; -type_string(76) -> - "temp io buffer (io.c)"; -type_string(77) -> - "temp io buffer 2 (io.c)"; -type_string(78) -> - "line buffer (io.c)"; -type_string(8) -> - "heap"; -type_string(801) -> - "heap (1)"; -type_string(802) -> - "heap (2)"; -type_string(803) -> - "heap (3)"; -type_string(804) -> - "heap (4)"; -type_string(805) -> - "heap (5)"; -type_string(821) -> - "heap fragment (1)"; -type_string(822) -> - "heap fragment (2)"; -type_string(830) -> - "sequential store buffer (for vectors)"; -type_string(91) -> - "process table"; -type_string(92) -> - "process desc"; -type_string(110) -> - "hash buckets"; -type_string(111) -> - "hash table"; -type_string(120) -> - "index init"; -type_string(121) -> - "index table"; -type_string(130) -> - "temp buffer"; -type_string(140) -> - "timer wheel"; -type_string(150) -> - "distribution cache"; -type_string(151) -> - "dmem"; -type_string(152) -> - "distribution table"; -type_string(153) -> - "distribution table buckets"; -type_string(154) -> - "distribution table entry"; -type_string(155) -> - "node table"; -type_string(156) -> - "node table buckets"; -type_string(157) -> - "node table entry"; -type_string(160) -> - "port table"; -type_string(161) -> - "driver entry"; -type_string(162) -> - "port setup"; -type_string(163) -> - "port wait"; -type_string(170) -> - "module"; -type_string(171) -> - "fundef"; -type_string(180) -> - "file table"; -type_string(181) -> - "driver table"; -type_string(182) -> - "poll struct"; -type_string(190) -> - "inet driver"; -type_string(200) -> - "efile driver"; -type_string(210) -> - "gc root set"; -type_string(220) -> - "breakpoint data"; -type_string(230) -> - "async queue"; -type_string(231) -> - "async (exit)"; -type_string(232) -> - "async (driver)"; -type_string(240) -> - "bits buffer"; -type_string(241) -> - "bits temp buffer"; -type_string(250) -> - "modules (loader)"; -type_string(251) -> - "code (loader)"; -type_string(252) -> - "atom tab (loader)"; -type_string(253) -> - "import tab (loader)"; -type_string(254) -> - "export tab (loader)"; -type_string(255) -> - "lable tab (loader)"; -type_string(256) -> - "gen op (loader)"; -type_string(257) -> - "gen op args (loader)"; -type_string(258) -> - "gen op args 2 (loader)"; -type_string(259) -> - "gen op args 3 (loader)"; -type_string(260) -> - "lambdas (loader)"; -type_string(261) -> - "temp int buffer (loader)"; -type_string(262) -> - "temp heap (loader)"; -type_string(280) -> - "dist ctrl msg buffer"; -type_string(281) -> - "dist_buf"; -type_string(290) -> - "call trace buffer"; -type_string(300) -> - "bif timer rec"; -type_string(310) -> - "argument registers"; -type_string(320) -> - "compressed binary temp buffer"; -type_string(330) -> - "term_to_binary temp buffer"; -type_string(340) -> - "proc dict"; -type_string(350) -> - "trace to port temp buffer"; -type_string(360) -> - "lists subtract temp buffer"; -type_string(370) -> - "link (lh)"; -type_string(380) -> - "port call buffer"; -type_string(400) -> - "definite_alloc block"; -type_string(_) -> - invalid_type. - +dispatch_gather(#{ allocator_types := AllocatorTypes, + scheduler_ids := SchedulerIds, + histogram_start := HistStart, + histogram_width := HistWidth }, Ref, Gather) + when is_list(AllocatorTypes), + is_list(SchedulerIds), + HistStart >= 1, HistStart =< (1 bsl 28), + HistWidth >= 1, HistWidth =< 32 -> + MsgCount = lists:sum( + [Gather({AllocatorType, SchedId, HistWidth, HistStart, Ref}) || + SchedId <- SchedulerIds, + AllocatorType <- AllocatorTypes]), + {HistStart, MsgCount}; +dispatch_gather(_, _, _) -> + error(badarg). diff --git a/lib/tools/src/xref_utils.erl b/lib/tools/src/xref_utils.erl index 02e207d40c..eca751337b 100644 --- a/lib/tools/src/xref_utils.erl +++ b/lib/tools/src/xref_utils.erl @@ -557,12 +557,9 @@ subdir(Dir, SubDir, true) -> %% Avoid "App-01.01" - the zeroes will be lost. filename2appl(File) -> - Pos = string:rstr(File, "-"), - true = Pos > 1, - V = string:sub_string(File, Pos+1), - true = string:len(V) > 0, - VsnT = string:tokens(V, "."), - ApplName = string:sub_string(File, 1, Pos-1), + [ApplName, V] = string:split(File, "-", trailing), + true = string:length(V) > 0, + VsnT = string:lexemes(V, "."), Vsn = [list_to_integer(Vsn) || Vsn <- VsnT], {list_to_atom(ApplName),Vsn}. diff --git a/lib/tools/test/fprof_SUITE.erl b/lib/tools/test/fprof_SUITE.erl index 8fd164a4b3..ae0e7253ad 100644 --- a/lib/tools/test/fprof_SUITE.erl +++ b/lib/tools/test/fprof_SUITE.erl @@ -51,7 +51,7 @@ suite() -> [{ct_hooks,[ts_install_cth]}, - {timetrap,{seconds,60}}]. + {timetrap,{seconds,240}}]. all() -> case test_server:is_native(fprof_SUITE) of @@ -571,7 +571,7 @@ seq_r(Start, Stop, Succ, R) -> create_file_slow(Name, N) when is_integer(N), N >= 0 -> {ok, FD} = - file:open(Name, [raw, write, delayed_write, binary]), + file:open(Name, [raw, write, binary]), if N > 256 -> ok = file:write(FD, lists:map(fun (X) -> <<X:32/unsigned>> end, diff --git a/lib/tools/test/instrument_SUITE.erl b/lib/tools/test/instrument_SUITE.erl index f37d28c277..8c521b2e1a 100644 --- a/lib/tools/test/instrument_SUITE.erl +++ b/lib/tools/test/instrument_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1998-2016. All Rights Reserved. +%% Copyright Ericsson AB 1998-2018. 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. @@ -20,89 +20,274 @@ -module(instrument_SUITE). -export([all/0, suite/0]). --export(['+Mim true'/1, '+Mis true'/1]). + +-export([allocations_enabled/1, allocations_disabled/1, allocations_ramv/1, + carriers_enabled/1, carriers_disabled/1]). + +-export([test_all_alloc/2, test_per_alloc/2, test_format/3, test_abort/1, + generate_test_blocks/0, churn_memory/0]). -include_lib("common_test/include/ct.hrl"). suite() -> [{ct_hooks,[ts_install_cth]}, - {timetrap,{seconds,10}}]. + {timetrap,{minutes,5}}]. all() -> - ['+Mim true', '+Mis true']. - - -%% Check that memory data can be read and processed -'+Mim true'(Config) when is_list(Config) -> - Node = start_slave("+Mim true"), - MD = rpc:call(Node, instrument, memory_data, []), - [{total,[{sizes,S1,S2,S3},{blocks,B1,B2,B3}]}] - = rpc:call(Node, instrument, memory_status, [total]), - stop_slave(Node), - true = S1 =< S2, - true = S2 =< S3, - true = B1 =< B2, - true = B2 =< B3, - MDS = instrument:sort(MD), - {Low, High} = instrument:mem_limits(MDS), - true = Low < High, - {_, AL} = MDS, - SumBlocks = instrument:sum_blocks(MD), - case SumBlocks of - N when is_integer(N) -> - N = lists:foldl(fun ({_,_,Size,_}, Sum) -> - Size+Sum - end, 0, AL), - true = N =< S3; - Other -> - ct:fail(Other) + [allocations_enabled, allocations_disabled, allocations_ramv, + carriers_enabled, carriers_disabled]. + +-define(GENERATED_SBC_BLOCK_COUNT, 1000). +-define(GENERATED_MBC_BLOCK_COUNT, ?GENERATED_SBC_BLOCK_COUNT). + +-define(GENERATED_BLOCK_COUNT, (?GENERATED_SBC_BLOCK_COUNT + + ?GENERATED_MBC_BLOCK_COUNT)). +-define(GENERATED_CARRIER_COUNT, ?GENERATED_SBC_BLOCK_COUNT). + +allocations_test(Args, Plain, PerAlloc) -> + run_test(Args, fun(Node) -> + ok = rpc:call(Node, ?MODULE, test_all_alloc, + [fun instrument:allocations/0, Plain]), + ok = rpc:call(Node, ?MODULE, test_per_alloc, + [fun instrument:allocations/1, PerAlloc]), + ok = rpc:call(Node, ?MODULE, test_format, + [#{ histogram_start => 512, + histogram_width => 4 }, + fun instrument:allocations/1, + fun verify_allocations_output/2]), + ok = rpc:call(Node, ?MODULE, test_abort, + [fun erts_internal:gather_alloc_histograms/1]) + end). + +allocations_enabled(Config) when is_list(Config) -> + allocations_test("+Meamax +Muatags true", + fun verify_allocations_enabled/1, + fun verify_allocations_enabled/2). + +allocations_disabled(Config) when is_list(Config) -> + allocations_test("+Meamax +Muatags false", + fun verify_allocations_disabled/1, + fun verify_allocations_disabled/2). + +allocations_ramv(Config) when is_list(Config) -> + allocations_test("+Meamax +Muatags true +Muramv true", + fun verify_allocations_enabled/1, + fun verify_allocations_enabled/2). + +verify_allocations_disabled(_AllocType, Result) -> + verify_allocations_disabled(Result). + +verify_allocations_disabled({error, not_enabled}) -> + ok. + +%% Skip types that have unstable results or are unaffected by +Muatags +verify_allocations_enabled(literal_alloc, _Result) -> ok; +verify_allocations_enabled(exec_alloc, _Result) -> ok; +verify_allocations_enabled(temp_alloc, _Result) -> ok; +verify_allocations_enabled(sl_alloc, _Result) -> ok; +verify_allocations_enabled(_AllocType, Result) -> + verify_allocations_enabled(Result). + +verify_allocations_enabled({ok, {_HistStart, _UnscannedBytes, Allocs}}) -> + true = Allocs =/= #{}. + +verify_allocations_output(#{ histogram_start := HistStart, + histogram_width := HistWidth }, + {ok, {HistStart, _UnscannedBytes, ByOrigin}}) -> + AllHistograms = lists:flatten([maps:values(ByType) || + ByType <- maps:values(ByOrigin)]), + + %% Do the histograms look alright? + HistogramSet = ordsets:from_list(AllHistograms), + Verified = [H || H <- HistogramSet, + tuple_size(H) =:= HistWidth, + hist_sum(H) >= 1], + [] = ordsets:subtract(HistogramSet, Verified), + + %% Do we have at least as many blocks as we've generated? + BlockCount = lists:foldl(fun(Hist, Acc) -> + hist_sum(Hist) + Acc + end, 0, AllHistograms), + GenTotalBlockCount = ?GENERATED_BLOCK_COUNT, + GenSBCBlockCount = ?GENERATED_SBC_BLOCK_COUNT, + if + BlockCount < GenSBCBlockCount -> + ct:fail("Found ~p blocks, required at least ~p (SB)." , + [BlockCount, GenSBCBlockCount]); + BlockCount >= GenTotalBlockCount -> + ct:pal("Found ~p blocks, expected at least ~p (SB + MB).", + [BlockCount, GenTotalBlockCount]); + BlockCount < GenTotalBlockCount -> + ct:pal("Found ~p blocks, expected at least ~p (SB + MB), but this " + "may be due to MBCs being skipped if they're about to be " + "scanned just as they're fetched from the carrier pool.", + [BlockCount, GenTotalBlockCount]) + end, + + ok; +verify_allocations_output(#{}, {error, not_enabled}) -> + ok. + +%% %% %% %% %% %% + +carriers_test(Args, Plain, PerAlloc) -> + run_test(Args, fun(Node) -> + ok = rpc:call(Node, ?MODULE, test_all_alloc, + [fun instrument:carriers/0, Plain]), + ok = rpc:call(Node, ?MODULE, test_per_alloc, + [fun instrument:carriers/1, PerAlloc]), + ok = rpc:call(Node, ?MODULE, test_format, + [#{ histogram_start => 1024, + histogram_width => 4 }, + fun instrument:carriers/1, + fun verify_carriers_output/2]), + ok = rpc:call(Node, ?MODULE, test_abort, + [fun erts_internal:gather_carrier_info/1]) + end). + +carriers_enabled(Config) when is_list(Config) -> + carriers_test("+Meamax", + fun verify_carriers_enabled/1, + fun verify_carriers_enabled/2). + +carriers_disabled(Config) when is_list(Config) -> + carriers_test("+Meamin", + fun verify_carriers_disabled/1, + fun verify_carriers_disabled/2). + +verify_carriers_disabled(_AllocType, Result) -> + verify_carriers_disabled(Result). + +verify_carriers_disabled({error, not_enabled}) -> + ok; +verify_carriers_disabled({ok, {_HistStart, Carriers}}) -> + verify_carriers_disabled_1(Carriers). + +verify_carriers_disabled_1([]) -> + ok; +%% literal_alloc, exec_alloc, and temp_alloc can't be disabled, so we have to +%% accept their presence in carriers_disabled/test_all_alloc. +verify_carriers_disabled_1([Carrier | Rest]) when + element(1, Carrier) =:= literal_alloc; + element(1, Carrier) =:= exec_alloc; + element(1, Carrier) =:= temp_alloc -> + verify_carriers_disabled_1(Rest). + +%% exec_alloc only has a carrier if it's actually used. +verify_carriers_enabled(exec_alloc, _Result) -> ok; +verify_carriers_enabled(_AllocType, Result) -> verify_carriers_enabled(Result). + +verify_carriers_enabled({ok, {_HistStart, Carriers}}) when Carriers =/= [] -> + ok. + +verify_carriers_output(#{ histogram_start := HistStart, + histogram_width := HistWidth }, + {ok, {HistStart, AllCarriers}}) -> + + %% Do the carriers look alright? + CarrierSet = ordsets:from_list(AllCarriers), + Verified = [C || {AllocType, + TotalSize, + UnscannedSize, + AllocatedSize, + AllocatedCount, + InPool, + FreeBlockHist} = C <- CarrierSet, + is_atom(AllocType), + is_integer(TotalSize), TotalSize >= 1, + is_integer(UnscannedSize), UnscannedSize < TotalSize, + UnscannedSize >= 0, + is_integer(AllocatedSize), AllocatedSize < TotalSize, + AllocatedSize >= 0, + is_integer(AllocatedCount), AllocatedCount =< AllocatedSize, + AllocatedCount >= 0, + is_boolean(InPool), + tuple_size(FreeBlockHist) =:= HistWidth, + carrier_block_check(AllocatedCount, FreeBlockHist)], + [] = ordsets:subtract(CarrierSet, Verified), + + %% Do we have at least as many carriers as we've generated? + CarrierCount = length(AllCarriers), + GenSBCCount = ?GENERATED_SBC_BLOCK_COUNT, + if + CarrierCount < GenSBCCount -> + ct:fail("Carrier count is ~p, expected at least ~p (SBC).", + [CarrierCount, GenSBCCount]); + CarrierCount >= GenSBCCount -> + ok end, - lists:foldl( - fun ({TDescr,Addr,Size,Proc}, MinAddr) -> - true = TDescr /= invalid_type, - true = is_integer(TDescr), - true = is_integer(Addr), - true = is_integer(Size), - true = Addr >= MinAddr, - case Proc of - {0, Number, Serial} -> - true = is_integer(Number), - true = is_integer(Serial); - undefined -> - ok; - BadProc -> - ct:fail({badproc, BadProc}) - end, - NextMinAddr = Addr+Size, - true = NextMinAddr =< High, - NextMinAddr - end, Low, AL), - {_, DAL} = instrument:descr(MDS), - lists:foreach( - fun ({TDescr,_,_,Proc}) -> - true = TDescr /= invalid_type, - true = is_atom(TDescr) orelse is_list(TDescr), - true = is_pid(Proc) orelse Proc == undefined - end, DAL), - ASL = lists:map(fun ({_,A,S,_}) -> {A,S} end, AL), - ASL = lists:map(fun ({_,A,S,_}) -> {A,S} end, DAL), - instrument:holes(MDS), - {comment, "total status - sum of blocks = " ++ integer_to_list(S1-SumBlocks)}. - -%% Check that memory data can be read and processed -'+Mis true'(Config) when is_list(Config) -> - Node = start_slave("+Mis true"), - [{total,[{sizes,S1,S2,S3},{blocks,B1,B2,B3}]}] - = rpc:call(Node, instrument, memory_status, [total]), - true = S1 =< S2, - true = S2 =< S3, - true = B1 =< B2, - true = B2 =< B3, - true = is_list(rpc:call(Node,instrument,memory_status,[allocators])), - true = is_list(rpc:call(Node,instrument,memory_status,[classes])), - true = is_list(rpc:call(Node,instrument,memory_status,[types])), + + ok; +verify_carriers_output(#{}, {error, not_enabled}) -> + ok. + +carrier_block_check(AllocCount, FreeHist) -> + %% A carrier must contain at least one block, and th. number of free blocks + %% must not exceed the number of allocated blocks + 1. + FreeCount = hist_sum(FreeHist), + + (AllocCount + FreeCount) >= 1 andalso FreeCount =< (AllocCount + 1). + +%% %% %% %% %% %% + +test_all_alloc(Gather, Verify) -> + Verify(Gather()), ok. +test_per_alloc(Gather, Verify) -> + [begin + Verify(T, Gather(#{ allocator_types => [T] })) + end || T <- erlang:system_info(alloc_util_allocators)], + ok. + +test_format(#{ allocator_types := _ }, _, _) -> + error(badarg); +test_format(Options0, Gather, Verify) -> + %% We limit format checking to binary_alloc since we generated the test + %% vectors there. + Options = Options0#{ allocator_types => [binary_alloc] }, + Verify(Options, Gather(Options)), + ok. + +test_abort(Gather) -> + %% There's no way for us to tell whether this actually aborted or ran to + %% completion, but it might catch a few segfaults. + Runner = self(), + Ref = make_ref(), + spawn_opt(fun() -> + [Gather({Type, SchedId, 1, 1, Ref}) || + Type <- erlang:system_info(alloc_util_allocators), + SchedId <- lists:seq(0, erlang:system_info(schedulers))], + Runner ! Ref + end, [{priority, max}]), + receive + Ref -> ok + end. + +hist_sum(H) -> hist_sum_1(H, tuple_size(H), 0). +hist_sum_1(_H, 0, A) -> A; +hist_sum_1(H, N, A) -> hist_sum_1(H, N - 1, element(N, H) + A). + +%% + +run_test(Args0, Test) -> + %% Override single-block carrier threshold for binaries to ensure we have + %% coverage for that path. generate_test_blocks builds a few binaries that + %% crosses this threshold. + %% + %% We also set the abandon carrier threshold to 70% to provoke more + %% activity in the carrier pool. + Args = Args0 ++ " +MBsbct 1 +Muacul 70", + Node = start_slave(Args), + + ok = rpc:call(Node, ?MODULE, generate_test_blocks, []), + ok = Test(Node), + + ok = rpc:call(Node, ?MODULE, churn_memory, []), + ok = Test(Node), + + true = test_server:stop_node(Node). + start_slave(Args) -> MicroSecs = erlang:monotonic_time(), Name = "instr" ++ integer_to_list(MicroSecs), @@ -112,6 +297,60 @@ start_slave(Args) -> [{args, "-pa " ++ Pa ++ " " ++ Args}]), Node. +generate_test_blocks() -> + Runner = self(), + Ref = make_ref(), + spawn(fun() -> + %% We've set the single-block carrier threshold to 1KB so one + %% ought to land in a SBC and the other in a MBC. Both are kept + %% alive forever. + SBCs = [<<I, 0:(1 bsl 10)/unit:8>> || + I <- lists:seq(1, ?GENERATED_SBC_BLOCK_COUNT)], + MBCs = [<<I, 0:64/unit:8>> || + I <- lists:seq(1, ?GENERATED_MBC_BLOCK_COUNT)], + Runner ! Ref, + receive after infinity -> ok end, + unreachable ! {SBCs, MBCs} + end), + receive + Ref -> ok + end. -stop_slave(Node) -> - true = test_server:stop_node(Node). +churn_memory() -> + %% All processes spawned from here on have 'low' priority to avoid starving + %% others (e.g. the rpc process) which could cause the test to time out. + [begin + churn_list_to_binary(), + churn_processes(), + churn_ets() + end || _ <- lists:seq(1, erlang:system_info(schedulers))], + ok. + +churn_processes() -> + Pid = spawn_opt(fun churn_processes/0, [{priority, low}]), + [Pid ! <<I, 0:128/unit:8>> || I <- lists:seq(1, 128)]. + +%% Nearly all types have a few allocations at all times but sl_alloc is +%% often empty. list_to_binary on large inputs will yield and spill the +%% state into an 'estack' which is allocated through sl_alloc. +%% +%% This is inherently unstable so we skip the verification step for this +%% type, but there's still a point to hammering it. +churn_list_to_binary() -> + List = binary_to_list(<<0:(1 bsl 20)/unit:8>>), + spawn_opt(fun() -> churn_list_to_binary_1(List) end, [{priority, low}]). + +churn_list_to_binary_1(List) -> + _ = id(list_to_binary(List)), + churn_list_to_binary_1(List). + +churn_ets() -> + spawn_opt(fun() -> churn_ets_1(ets:new(gurka, [])) end, [{priority, low}]). + +churn_ets_1(Tab) -> + ets:insert(Tab, {gaffel, lists:seq(1, 16)}), + ets:delete_all_objects(Tab), + churn_ets_1(Tab). + +id(I) -> + I. diff --git a/lib/tools/test/xref_SUITE.erl b/lib/tools/test/xref_SUITE.erl index d651cbcfee..018f632948 100644 --- a/lib/tools/test/xref_SUITE.erl +++ b/lib/tools/test/xref_SUITE.erl @@ -1112,27 +1112,16 @@ read_expected(Version) -> {POS7+2,{FF,{erlang,spawn_opt,4}}}, {POS8+1,{FF,{hej,san,1}}}, {POS8+4,{FF,{a,b,1}}}, - {POS8+4,{FF,{erlang,apply,2}}}, - {POS8+5,{FF,{erlang,apply,2}}}, {POS8+6,{FF,{m,f,1}}}, {POS9+1,{FF,{read,bi,0}}}, {POS9+2,{FF,{a,b,1}}}, - {POS9+2,{FF,{erlang,apply,2}}}, - {POS9+3,{FF,{erlang,apply,2}}}, - {POS9+4,{FF,{erlang,apply,2}}}, {POS9+4,{FF,{erlang,not_a_function,1}}}, {POS9+5,{FF,{mod,func,2}}}, {POS9+6,{FF,{erlang,apply,1}}}, - {POS9+7,{FF,{erlang,apply,2}}}, {POS9+7,{FF,{math,add3,1}}}, {POS9+8,{FF,{q,f,1}}}, - {POS10+4,{FF,{erlang,apply,2}}}, {POS10+5,{FF,{mod1,fun1,1}}}, - {POS11+6,{FF,{erlang,apply,2}}}, - {POS12+1,{FF,{erlang,apply,2}}}, - {POS12+4,{FF,{erlang,apply,2}}}, {POS12+5,{FF,{m3,f3,2}}}, - {POS12+7,{FF,{erlang,apply,2}}}, {POS13+1,{FF,{dm,df,1}}}, {POS13+6,{{read,bi,0},{foo,module_info,0}}}, {POS13+7,{{read,bi,0},{read,module_info,0}}}, @@ -1162,15 +1151,26 @@ read_expected(Version) -> {POS3+3, {FF,{erlang,spawn_link,3}}}, {POS3+4, {FF,{erlang,spawn_link,3}}}, {POS6+4, {FF,{erlang,spawn,3}}}, + {POS8+4,{FF,{erlang,apply,2}}}, + {POS8+5,{FF,{erlang,apply,2}}}, {POS8+6,{FF,{erlang,apply,3}}}, {POS8+7,{FF,{erlang,apply,3}}}, {POS9+1,{FF,{erlang,apply,3}}}, + {POS9+2,{FF,{erlang,apply,2}}}, + {POS9+3,{FF,{erlang,apply,2}}}, + {POS9+4,{FF,{erlang,apply,2}}}, {POS9+5,{FF,{erlang,apply,3}}}, + {POS9+7,{FF,{erlang,apply,2}}}, + {POS10+4,{FF,{erlang,apply,2}}}, {POS11+1,{FF,{erlang,apply,3}}}, {POS11+2,{FF,{erlang,apply,3}}}, {POS11+3,{FF,{erlang,apply,3}}}, {POS11+4,{FF,{erlang,apply,3}}}, + {POS11+6,{FF,{erlang,apply,2}}}, + {POS12+1,{FF,{erlang,apply,2}}}, + {POS12+4,{FF,{erlang,apply,2}}}, {POS12+5,{FF,{erlang,apply,3}}}, + {POS12+7,{FF,{erlang,apply,2}}}, {POS12+8,{FF,{erlang,apply,3}}}, {POS13+5, {{read,bi,0},{erlang,length,1}}}, {POS14+3, {{read,bi,0},{erlang,length,1}}}], diff --git a/lib/wx/api_gen/gen_util.erl b/lib/wx/api_gen/gen_util.erl index 5e2f405498..3068a2f4ea 100644 --- a/lib/wx/api_gen/gen_util.erl +++ b/lib/wx/api_gen/gen_util.erl @@ -106,8 +106,8 @@ check_diff(Diff) -> throw:_ -> diff; error:{badmatch,_} -> diff; - _:What -> - io:format("~p:~p: ~p ~p~n", [?MODULE,?LINE, What, erlang:get_stacktrace()]), + _:What:Stacktrace -> + io:format("~p:~p: ~p ~p~n", [?MODULE,?LINE, What, Stacktrace]), diff end. diff --git a/lib/wx/api_gen/gl_gen.erl b/lib/wx/api_gen/gl_gen.erl index 7e3766a43b..6f68517c16 100644 --- a/lib/wx/api_gen/gl_gen.erl +++ b/lib/wx/api_gen/gl_gen.erl @@ -47,9 +47,9 @@ safe(What, QuitOnErr) -> What(), io:format("Completed successfully~n~n", []), QuitOnErr andalso gen_util:halt(0) - catch Err:Reason -> + catch Err:Reason:Stacktrace -> io:format("Error ~p: ~p:~p~n ~p~n", - [get(current_func),Err,Reason,erlang:get_stacktrace()]), + [get(current_func),Err,Reason,Stacktrace]), (catch gen_util:close()), timer:sleep(1999), QuitOnErr andalso gen_util:halt(1) diff --git a/lib/wx/api_gen/gl_gen_erl.erl b/lib/wx/api_gen/gl_gen_erl.erl index 45f5fd8f4c..7e673c2987 100644 --- a/lib/wx/api_gen/gl_gen_erl.erl +++ b/lib/wx/api_gen/gl_gen_erl.erl @@ -246,8 +246,8 @@ gen_types(Where) -> gen_export(F) -> try gen_export_1(F) - catch E:R -> - io:format("Crash ~p:~p in ~p ~n",[E,R, erlang:get_stacktrace()]), + catch E:R:S -> + io:format("Crash ~p:~p in ~p ~n",[E,R,S]), io:format("Func = ~p~n ~p", [F, get(F)]) end. @@ -489,8 +489,8 @@ doc_return_types2(T, Ps) -> doc_arg_type(#arg{name=Name,type=T}) -> try erl_arg_name(Name) ++ " :: " ++ doc_arg_type2(T) - catch _:Error -> - io:format("Error spec: ~p ~p~n~p~n",[Name, Error, erlang:get_stacktrace()]), + catch _:Error:Stacktrace -> + io:format("Error spec: ~p ~p~n~p~n",[Name, Error, Stacktrace]), exit(error) end. diff --git a/lib/wx/api_gen/wx_extra/wxGraphicsRenderer.c_src b/lib/wx/api_gen/wx_extra/wxGraphicsRenderer.c_src new file mode 100644 index 0000000000..4718525dd6 --- /dev/null +++ b/lib/wx/api_gen/wx_extra/wxGraphicsRenderer.c_src @@ -0,0 +1,58 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2018. 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% +%% + + +<<CreatePen +case ~s: { // wxGraphicsRenderer::CreatePen taylormade + wxGraphicsRenderer *This = (wxGraphicsRenderer *) getPtr(bp,memenv); bp += 4; + wxPen *pen = (wxPen *) getPtr(bp,memenv); bp += 4; + if(!This) throw wxe_badarg(0); +#if !wxCHECK_VERSION(3,1,1) + wxGraphicsPen * Result = new wxGraphicsPen(This->CreatePen(*pen)); newPtr((void *) Result,4, memenv); + rt.addRef(getRef((void *)Result,memenv), "wxGraphicsPen"); + break; +#else + wxGraphicsPenInfo info = wxGraphicsPenInfo() + .Colour(pen->GetColour()) + .Width(pen->GetWidth()) + .Style(pen->GetStyle()) + .Join(pen->GetJoin()) + .Cap(pen->GetCap()) + ; + + if ( info.GetStyle() == wxPENSTYLE_USER_DASH ) + { + wxDash *dashes; + if ( int nb_dashes = pen->GetDashes(&dashes) ) + info.Dashes(nb_dashes, dashes); + } + + if ( info.GetStyle() == wxPENSTYLE_STIPPLE ) + { + if ( wxBitmap* const stipple = pen->GetStipple() ) + info.Stipple(*stipple); + } + wxGraphicsPen * Result = new wxGraphicsPen(This->CreatePen(info)); + newPtr((void *) Result,4, memenv); + rt.addRef(getRef((void *)Result,memenv), "wxGraphicsPen"); + break; +#endif +} +CreatePen>> diff --git a/lib/wx/api_gen/wx_gen.erl b/lib/wx/api_gen/wx_gen.erl index aadfe4b111..4ba57501a5 100644 --- a/lib/wx/api_gen/wx_gen.erl +++ b/lib/wx/api_gen/wx_gen.erl @@ -47,9 +47,9 @@ safe(What, QuitOnErr) -> What(), io:format("Completed successfully~n~n", []), QuitOnErr andalso gen_util:halt(0) - catch Err:Reason -> + catch Err:Reason:Stacktrace -> io:format("Error in ~p ~p~n", [get(current_class),get(current_func)]), - erlang:display({Err,Reason, erlang:get_stacktrace()}), + erlang:display({Err,Reason,Stacktrace}), catch gen_util:close(), QuitOnErr andalso gen_util:halt(1) end. @@ -93,9 +93,10 @@ mangle_info(E={not_const,List}) -> put(not_const, [atom_to_list(M) || M <- List]), E; mangle_info(E={gvars,List}) -> - A2L = fun({N,{T,C}}) -> {atom_to_list(N), {T,atom_to_list(C)}}; + A2L = fun({N,{test_if,C}}) -> {atom_to_list(N), {test_if,C}}; + ({N,{T,C}}) -> {atom_to_list(N), {T,atom_to_list(C)}}; ({N,C}) -> {atom_to_list(N), atom_to_list(C)} - end, + end, put(gvars, map(A2L,List)), E; mangle_info({class,CN,P,O,FL}) -> diff --git a/lib/wx/api_gen/wx_gen_cpp.erl b/lib/wx/api_gen/wx_gen_cpp.erl index 573abfa9b8..cc4e1b5301 100644 --- a/lib/wx/api_gen/wx_gen_cpp.erl +++ b/lib/wx/api_gen/wx_gen_cpp.erl @@ -1127,6 +1127,15 @@ build_gvar({Name, {address,Class}, _Id}, Cnt) -> w(" rt.addAtom(\"~s\"); rt.addRef(getRef((void *)&~s,memenv), \"~s\");~n",[Name,Name,Class]), w(" rt.addTupleCount(2);~n"), Cnt+1; +build_gvar({Name, {test_if,Test}, _Id}, Cnt) -> + w("#if ~s~n", [Test]), + w(" rt.addAtom(\"~s\"); rt.addInt(~s);~n", [Name, Name]), + w(" rt.addTupleCount(2);~n"), + w("#else~n", []), + w(" rt.addAtom(\"~s\"); rt.addAtom(\"undefined\");~n", [Name]), + w(" rt.addTupleCount(2);~n"), + w("#endif~n", []), + Cnt+1; build_gvar({Name, Class, _Id}, Cnt) -> w(" rt.addAtom(\"~s\"); rt.addRef(getRef((void *)~s,memenv),\"~s\");~n",[Name,Name,Class]), w(" rt.addTupleCount(2);~n"), diff --git a/lib/wx/api_gen/wx_gen_erl.erl b/lib/wx/api_gen/wx_gen_erl.erl index e272c08d90..dfee7270b4 100644 --- a/lib/wx/api_gen/wx_gen_erl.erl +++ b/lib/wx/api_gen/wx_gen_erl.erl @@ -1106,7 +1106,7 @@ gen_enums_ints() -> w("-define(wxDefaultSize, {-1,-1}).~n", []), w("-define(wxDefaultPosition, {-1,-1}).~n", []), w("~n%% Global Variables~n", []), - [w("-define(~s, wxe_util:get_const(~s)).~n", [Gvar, Gvar]) || + [w("-define(~s, wxe_util:get_const(~s)).~n", [qoute_atom(Gvar), qoute_atom(Gvar)]) || {Gvar,_,_Id} <- get(gvars)], w("~n%% Enum and defines~n", []), foldl(fun(Enum= #enum{vals=Vals}, Done) when Vals =/= [] -> @@ -1115,6 +1115,11 @@ gen_enums_ints() -> end, gb_sets:empty(), lists:sort(Enums)), close(). +qoute_atom([Char|_]=Str) when Char < $a -> + "'" ++ Str ++ "'"; +qoute_atom(Str) -> + Str. + build_enum_ints(#enum{from=From, vals=Vals},Done) -> case From of {File, undefined, [$@|_]} -> diff --git a/lib/wx/api_gen/wxapi.conf b/lib/wx/api_gen/wxapi.conf index 146c9fecc7..e2ef2d890a 100644 --- a/lib/wx/api_gen/wxapi.conf +++ b/lib/wx/api_gen/wxapi.conf @@ -87,7 +87,27 @@ {wxNullPen, {address,wxPen}}, {wxNullBrush, {address,wxBrush}}, {wxNullPalette, {address,wxPalette}}, - {wxNullFont, {address,wxFont}}]}. + {wxNullFont, {address,wxFont}}, + + %% New enums needed for gl contexts not static numbers + {'WX_GL_SAMPLE_BUFFERS', {test_if, "wxCHECK_VERSION(3,0,0)"}}, + {'WX_GL_SAMPLES', {test_if, "wxCHECK_VERSION(3,0,0)"}}, + {'WX_GL_FRAMEBUFFER_SRGB', {test_if, "wxCHECK_VERSION(3,1,0)"}}, + {'WX_GL_CORE_PROFILE', {test_if, "wxCHECK_VERSION(3,0,3)"}}, + {'WX_GL_MAJOR_VERSION', {test_if, "wxCHECK_VERSION(3,0,3)"}}, + {'WX_GL_MINOR_VERSION', {test_if, "wxCHECK_VERSION(3,0,3)"}}, + {'wx_GL_COMPAT_PROFILE', {test_if, "wxCHECK_VERSION(3,1,0)"}}, + {'WX_GL_FORWARD_COMPAT', {test_if, "wxCHECK_VERSION(3,1,0)"}}, + {'WX_GL_ES2', {test_if, "wxCHECK_VERSION(3,1,0)"}}, + {'WX_GL_DEBUG', {test_if, "wxCHECK_VERSION(3,1,0)"}}, + {'WX_GL_ROBUST_ACCESS', {test_if, "wxCHECK_VERSION(3,1,0)"}}, + {'WX_GL_NO_RESET_NOTIFY', {test_if, "wxCHECK_VERSION(3,1,0)"}}, + {'WX_GL_LOSE_ON_RESET', {test_if, "wxCHECK_VERSION(3,1,0)"}}, + {'WX_GL_RESET_ISOLATION', {test_if, "wxCHECK_VERSION(3,1,0)"}}, + {'WX_GL_RELEASE_FLUSH', {test_if, "wxCHECK_VERSION(3,1,0)"}}, + {'WX_GL_RELEASE_NONE', {test_if, "wxCHECK_VERSION(3,1,0)"}} + ]}. + {enum, wxBackgroundStyle, "wxBG_STYLE_"}. {enum, wxWindowVariant, "wxWINDOW_VARIANT_"}. {enum, wxBitmapType, "wxBITMAP_TYPE_"}. @@ -433,7 +453,8 @@ {class, wxGraphicsRenderer, object, [{ifdef, wxUSE_GRAPHICS_CONTEXT}], ['GetDefaultRenderer','CreateContext', %%'CreateContextFromNativeContext', 'CreateContextFromNativeWindow', - 'CreatePen','CreateBrush', + {'CreatePen', [{where, taylormade}]}, + 'CreateBrush', {'CreateLinearGradientBrush', [{deprecated, "!wxCHECK_VERSION(2,9,0)"}]}, {'CreateRadialGradientBrush', [{deprecated, "!wxCHECK_VERSION(2,9,0)"}]}, 'CreateFont', diff --git a/lib/wx/c_src/gen/wxe_funcs.cpp b/lib/wx/c_src/gen/wxe_funcs.cpp index a47d602337..a7bac4cf9d 100644 --- a/lib/wx/c_src/gen/wxe_funcs.cpp +++ b/lib/wx/c_src/gen/wxe_funcs.cpp @@ -1,7 +1,7 @@ /* * %CopyrightBegin% * - * Copyright Ericsson AB 2008-2017. All Rights Reserved. + * Copyright Ericsson AB 2008-2018. 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. @@ -7010,13 +7010,41 @@ case wxGraphicsRenderer_CreateContext_1_0: { // wxGraphicsRenderer::CreateContex rt.addRef(getRef((void *)Result,memenv), "wxGraphicsContext"); break; } -case wxGraphicsRenderer_CreatePen: { // wxGraphicsRenderer::CreatePen + +case wxGraphicsRenderer_CreatePen: { // wxGraphicsRenderer::CreatePen taylormade wxGraphicsRenderer *This = (wxGraphicsRenderer *) getPtr(bp,memenv); bp += 4; wxPen *pen = (wxPen *) getPtr(bp,memenv); bp += 4; if(!This) throw wxe_badarg(0); - wxGraphicsPen * Result = new wxGraphicsPen(This->CreatePen(*pen)); newPtr((void *) Result,4, memenv);; +#if !wxCHECK_VERSION(3,1,1) + wxGraphicsPen * Result = new wxGraphicsPen(This->CreatePen(*pen)); newPtr((void *) Result,4, memenv); rt.addRef(getRef((void *)Result,memenv), "wxGraphicsPen"); break; +#else + wxGraphicsPenInfo info = wxGraphicsPenInfo() + .Colour(pen->GetColour()) + .Width(pen->GetWidth()) + .Style(pen->GetStyle()) + .Join(pen->GetJoin()) + .Cap(pen->GetCap()) + ; + + if ( info.GetStyle() == wxPENSTYLE_USER_DASH ) + { + wxDash *dashes; + if ( int nb_dashes = pen->GetDashes(&dashes) ) + info.Dashes(nb_dashes, dashes); + } + + if ( info.GetStyle() == wxPENSTYLE_STIPPLE ) + { + if ( wxBitmap* const stipple = pen->GetStipple() ) + info.Stipple(*stipple); + } + wxGraphicsPen * Result = new wxGraphicsPen(This->CreatePen(info)); + newPtr((void *) Result,4, memenv); + rt.addRef(getRef((void *)Result,memenv), "wxGraphicsPen"); + break; +#endif } case wxGraphicsRenderer_CreateBrush: { // wxGraphicsRenderer::CreateBrush wxGraphicsRenderer *This = (wxGraphicsRenderer *) getPtr(bp,memenv); bp += 4; diff --git a/lib/wx/c_src/gen/wxe_init.cpp b/lib/wx/c_src/gen/wxe_init.cpp index 1e432e34ce..6ce33a5449 100644 --- a/lib/wx/c_src/gen/wxe_init.cpp +++ b/lib/wx/c_src/gen/wxe_init.cpp @@ -1,7 +1,7 @@ /* * %CopyrightBegin% * - * Copyright Ericsson AB 2008-2015. All Rights Reserved. + * Copyright Ericsson AB 2008-2018. 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. @@ -529,6 +529,111 @@ void WxeApp::init_nonconsts(wxeMemEnv *memenv, ErlDrvTermData caller) { rt.addTupleCount(2); rt.addAtom("wxCURSOR_MAX"); rt.addInt(wxCURSOR_MAX); rt.addTupleCount(2); +#if wxCHECK_VERSION(3,0,3) + rt.addAtom("WX_GL_CORE_PROFILE"); rt.addInt(WX_GL_CORE_PROFILE); + rt.addTupleCount(2); +#else + rt.addAtom("WX_GL_CORE_PROFILE"); rt.addAtom("undefined"); + rt.addTupleCount(2); +#endif +#if wxCHECK_VERSION(3,1,0) + rt.addAtom("WX_GL_DEBUG"); rt.addInt(WX_GL_DEBUG); + rt.addTupleCount(2); +#else + rt.addAtom("WX_GL_DEBUG"); rt.addAtom("undefined"); + rt.addTupleCount(2); +#endif +#if wxCHECK_VERSION(3,1,0) + rt.addAtom("WX_GL_ES2"); rt.addInt(WX_GL_ES2); + rt.addTupleCount(2); +#else + rt.addAtom("WX_GL_ES2"); rt.addAtom("undefined"); + rt.addTupleCount(2); +#endif +#if wxCHECK_VERSION(3,1,0) + rt.addAtom("WX_GL_FORWARD_COMPAT"); rt.addInt(WX_GL_FORWARD_COMPAT); + rt.addTupleCount(2); +#else + rt.addAtom("WX_GL_FORWARD_COMPAT"); rt.addAtom("undefined"); + rt.addTupleCount(2); +#endif +#if wxCHECK_VERSION(3,1,0) + rt.addAtom("WX_GL_FRAMEBUFFER_SRGB"); rt.addInt(WX_GL_FRAMEBUFFER_SRGB); + rt.addTupleCount(2); +#else + rt.addAtom("WX_GL_FRAMEBUFFER_SRGB"); rt.addAtom("undefined"); + rt.addTupleCount(2); +#endif +#if wxCHECK_VERSION(3,1,0) + rt.addAtom("WX_GL_LOSE_ON_RESET"); rt.addInt(WX_GL_LOSE_ON_RESET); + rt.addTupleCount(2); +#else + rt.addAtom("WX_GL_LOSE_ON_RESET"); rt.addAtom("undefined"); + rt.addTupleCount(2); +#endif +#if wxCHECK_VERSION(3,0,3) + rt.addAtom("WX_GL_MAJOR_VERSION"); rt.addInt(WX_GL_MAJOR_VERSION); + rt.addTupleCount(2); +#else + rt.addAtom("WX_GL_MAJOR_VERSION"); rt.addAtom("undefined"); + rt.addTupleCount(2); +#endif +#if wxCHECK_VERSION(3,0,3) + rt.addAtom("WX_GL_MINOR_VERSION"); rt.addInt(WX_GL_MINOR_VERSION); + rt.addTupleCount(2); +#else + rt.addAtom("WX_GL_MINOR_VERSION"); rt.addAtom("undefined"); + rt.addTupleCount(2); +#endif +#if wxCHECK_VERSION(3,1,0) + rt.addAtom("WX_GL_NO_RESET_NOTIFY"); rt.addInt(WX_GL_NO_RESET_NOTIFY); + rt.addTupleCount(2); +#else + rt.addAtom("WX_GL_NO_RESET_NOTIFY"); rt.addAtom("undefined"); + rt.addTupleCount(2); +#endif +#if wxCHECK_VERSION(3,1,0) + rt.addAtom("WX_GL_RELEASE_FLUSH"); rt.addInt(WX_GL_RELEASE_FLUSH); + rt.addTupleCount(2); +#else + rt.addAtom("WX_GL_RELEASE_FLUSH"); rt.addAtom("undefined"); + rt.addTupleCount(2); +#endif +#if wxCHECK_VERSION(3,1,0) + rt.addAtom("WX_GL_RELEASE_NONE"); rt.addInt(WX_GL_RELEASE_NONE); + rt.addTupleCount(2); +#else + rt.addAtom("WX_GL_RELEASE_NONE"); rt.addAtom("undefined"); + rt.addTupleCount(2); +#endif +#if wxCHECK_VERSION(3,1,0) + rt.addAtom("WX_GL_RESET_ISOLATION"); rt.addInt(WX_GL_RESET_ISOLATION); + rt.addTupleCount(2); +#else + rt.addAtom("WX_GL_RESET_ISOLATION"); rt.addAtom("undefined"); + rt.addTupleCount(2); +#endif +#if wxCHECK_VERSION(3,1,0) + rt.addAtom("WX_GL_ROBUST_ACCESS"); rt.addInt(WX_GL_ROBUST_ACCESS); + rt.addTupleCount(2); +#else + rt.addAtom("WX_GL_ROBUST_ACCESS"); rt.addAtom("undefined"); + rt.addTupleCount(2); +#endif +#if wxCHECK_VERSION(3,0,0) + rt.addAtom("WX_GL_SAMPLES"); rt.addInt(WX_GL_SAMPLES); + rt.addTupleCount(2); +#else + rt.addAtom("WX_GL_SAMPLES"); rt.addAtom("undefined"); + rt.addTupleCount(2); +#endif +#if wxCHECK_VERSION(3,0,0) + rt.addAtom("WX_GL_SAMPLE_BUFFERS"); rt.addInt(WX_GL_SAMPLE_BUFFERS); + rt.addTupleCount(2); +#else + rt.addAtom("WX_GL_SAMPLE_BUFFERS"); rt.addAtom("undefined"); + rt.addTupleCount(2); +#endif rt.addAtom("wxBLACK"); rt.add(*(wxBLACK)); rt.addTupleCount(2); rt.addAtom("wxBLACK_BRUSH"); rt.addRef(getRef((void *)wxBLACK_BRUSH,memenv),"wxBrush"); @@ -611,7 +716,14 @@ void WxeApp::init_nonconsts(wxeMemEnv *memenv, ErlDrvTermData caller) { rt.addTupleCount(2); rt.addAtom("wxWHITE_PEN"); rt.addRef(getRef((void *)wxWHITE_PEN,memenv),"wxPen"); rt.addTupleCount(2); - rt.endList(293); +#if wxCHECK_VERSION(3,1,0) + rt.addAtom("wx_GL_COMPAT_PROFILE"); rt.addInt(wx_GL_COMPAT_PROFILE); + rt.addTupleCount(2); +#else + rt.addAtom("wx_GL_COMPAT_PROFILE"); rt.addAtom("undefined"); + rt.addTupleCount(2); +#endif + rt.endList(309); rt.addTupleCount(2); rt.send(); } diff --git a/lib/wx/c_src/wxe_ps_init.c b/lib/wx/c_src/wxe_ps_init.c index e6b677d469..277f3ac25f 100644 --- a/lib/wx/c_src/wxe_ps_init.c +++ b/lib/wx/c_src/wxe_ps_init.c @@ -61,13 +61,20 @@ int is_packaged_app() { void * wxe_ps_init2() { NSAutoreleasePool *pool; ProcessSerialNumber psn; - + size_t app_len = 127; + char app_title_buf[128]; + char * app_title; // Setup and enable gui pool = [[NSAutoreleasePool alloc] init]; - + if( !is_packaged_app() ) { // Undocumented function (but no documented way of doing this exists) - char *app_title = getenv("WX_APP_TITLE"); + int res = erl_drv_getenv("WX_APP_TITLE", app_title_buf, &app_len); + if (res >= 0) { + app_title = app_title_buf; + } else { + app_title = NULL; + } if(!GetCurrentProcess(&psn)) { CPSSetProcessName(&psn, app_title?app_title:"Erlang"); } diff --git a/lib/wx/doc/src/Makefile b/lib/wx/doc/src/Makefile index a76740adf1..c132c628f7 100644 --- a/lib/wx/doc/src/Makefile +++ b/lib/wx/doc/src/Makefile @@ -46,9 +46,13 @@ XML_NOTES_FILES = notes.xml BOOK_FILES = book.xml XML_FILES = \ - $(BOOK_FILES) $(XML_CHAPTER_FILES) \ - $(XML_PART_FILES) $(XML_REF3_FILES) \ - $(XML_NOTES_FILES) $(XML_APPLICATION_FILES) + $(BOOK_FILES) \ + $(XML_PART_FILES) $(XML_NOTES_FILES) + +XML_GEN_FILES = \ + $(XML_CHAPTER_FILES:%=$(XMLDIR)/%) \ + $(XML_REF3_FILES:%=$(XMLDIR)/%) \ + $(XML_APPLICATION_FILES:%=$(XMLDIR)/%) # ---------------------------------------------------- INFO_FILE = ../../info @@ -93,22 +97,26 @@ gifs: $(GIF_FILES:%=$(HTMLDIR)/%) xml: $(XML_REF3_FILES) $(XML_CHAPTER_FILES) ref_man.xml: ref_man.xml.src - @echo Preparing ref_man.xml - @cat ref_man.xml.src > ref_man.xml + @echo Preparing $@ + @cat ref_man.xml.src > $@ @for d in $(ModsNoExt); do \ - echo " <xi:include href=\"$$d.xml\"/>" >> ref_man.xml ; \ + echo " <xi:include href=\"$$d.xml\"/>" >> $@ ; \ done - @echo "</application>" >> ref_man.xml - @echo + @echo "</application>" >> $@ -$(ErlMods:%.erl=%.xml): ../../src/$(@:%.xml=%.erl) - escript $(DOCGEN)/priv/bin/xml_from_edoc.escript -def vsn $(VSN) -preprocess true -sort_functions false ../../src/$(@:%.xml=%.erl) +$(ErlMods:%.erl=$(XMLDIR)/%.xml): + $(gen_verbose)escript $(DOCGEN)/priv/bin/xml_from_edoc.escript \ + -def vsn $(VSN) -preprocess true -sort_functions false -dir $(XMLDIR) \ + ../../src/$(@:$(XMLDIR)/%.xml=%.erl) -$(GenMods:%.erl=%.xml): ../../src/gen/$(@:%.xml=%.erl) - escript $(DOCGEN)/priv/bin/xml_from_edoc.escript -def vsn $(VSN) -i ../../src -preprocess true -sort_functions false ../../src/gen/$(@:%.xml=%.erl) +$(GenMods:%.erl=$(XMLDIR)/%.xml): + $(gen_verbose)escript $(DOCGEN)/priv/bin/xml_from_edoc.escript \ + -def vsn $(VSN) -i ../../src -preprocess true -sort_functions false -dir $(XMLDIR) \ + ../../src/gen/$(@:$(XMLDIR)/%.xml=%.erl) -$(XML_CHAPTER_FILES): ../overview.edoc - escript $(DOCGEN)/priv/bin/xml_from_edoc.escript -def vsn $(VSN) -chapter ../overview.edoc +$(XML_CHAPTER_FILES:%=$(XMLDIR)/%): ../overview.edoc + $(gen_verbose)escript $(DOCGEN)/priv/bin/xml_from_edoc.escript \ + -def vsn $(VSN) -chapter -dir $(XMLDIR) $< debug opt: @@ -118,7 +126,7 @@ clean clean_docs: rm -f $(TOP_PDF_FILE) $(TOP_PDF_FILE:%.pdf=%.fo) rm -f $(SPECDIR)/* rm -f errs core *~ ../html/edoc-info - rm -f $(XML_REF3_FILES) $(XML_CHAPTER_FILES) *.html + rm -f $(XML_GEN_FILES) *.html # ---------------------------------------------------- # Release Target diff --git a/lib/wx/examples/demo/demo.erl b/lib/wx/examples/demo/demo.erl index 8fb70ad7b0..8f3291305b 100644 --- a/lib/wx/examples/demo/demo.erl +++ b/lib/wx/examples/demo/demo.erl @@ -411,7 +411,7 @@ find(Ed) -> keyWords() -> L = ["after","begin","case","try","cond","catch","andalso","orelse", - "end","fun","if","let","of","query","receive","when","bnot","not", + "end","fun","if","let","of","receive","when","bnot","not", "div","rem","band","and","bor","bxor","bsl","bsr","or","xor"], lists:flatten([K ++ " " || K <- L] ++ [0]). diff --git a/lib/wx/examples/demo/ex_aui.erl b/lib/wx/examples/demo/ex_aui.erl index d8fc0021f1..97805621ed 100644 --- a/lib/wx/examples/demo/ex_aui.erl +++ b/lib/wx/examples/demo/ex_aui.erl @@ -87,8 +87,7 @@ do_init(Config) -> wxAuiManager:update(Manager), process_flag(trap_exit, true), {Panel, #state{parent=Panel, config=Config, aui=Manager}} - catch Class:Reason -> - ST = erlang:get_stacktrace(), + catch Class:Reason:ST -> io:format("AUI Crashed ~p ~p~n",[Reason, ST]), wxAuiManager:unInit(Manager), wxAuiManager:destroy(Manager), diff --git a/lib/wx/include/wx.hrl b/lib/wx/include/wx.hrl index a14cc89cee..23f3b95403 100644 --- a/lib/wx/include/wx.hrl +++ b/lib/wx/include/wx.hrl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2008-2016. All Rights Reserved. +%% Copyright Ericsson AB 2008-2018. 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. @@ -373,6 +373,21 @@ -define(wxDefaultPosition, {-1,-1}). %% Global Variables +-define('WX_GL_CORE_PROFILE', wxe_util:get_const('WX_GL_CORE_PROFILE')). +-define('WX_GL_DEBUG', wxe_util:get_const('WX_GL_DEBUG')). +-define('WX_GL_ES2', wxe_util:get_const('WX_GL_ES2')). +-define('WX_GL_FORWARD_COMPAT', wxe_util:get_const('WX_GL_FORWARD_COMPAT')). +-define('WX_GL_FRAMEBUFFER_SRGB', wxe_util:get_const('WX_GL_FRAMEBUFFER_SRGB')). +-define('WX_GL_LOSE_ON_RESET', wxe_util:get_const('WX_GL_LOSE_ON_RESET')). +-define('WX_GL_MAJOR_VERSION', wxe_util:get_const('WX_GL_MAJOR_VERSION')). +-define('WX_GL_MINOR_VERSION', wxe_util:get_const('WX_GL_MINOR_VERSION')). +-define('WX_GL_NO_RESET_NOTIFY', wxe_util:get_const('WX_GL_NO_RESET_NOTIFY')). +-define('WX_GL_RELEASE_FLUSH', wxe_util:get_const('WX_GL_RELEASE_FLUSH')). +-define('WX_GL_RELEASE_NONE', wxe_util:get_const('WX_GL_RELEASE_NONE')). +-define('WX_GL_RESET_ISOLATION', wxe_util:get_const('WX_GL_RESET_ISOLATION')). +-define('WX_GL_ROBUST_ACCESS', wxe_util:get_const('WX_GL_ROBUST_ACCESS')). +-define('WX_GL_SAMPLES', wxe_util:get_const('WX_GL_SAMPLES')). +-define('WX_GL_SAMPLE_BUFFERS', wxe_util:get_const('WX_GL_SAMPLE_BUFFERS')). -define(wxBLACK, wxe_util:get_const(wxBLACK)). -define(wxBLACK_BRUSH, wxe_util:get_const(wxBLACK_BRUSH)). -define(wxBLACK_DASHED_PEN, wxe_util:get_const(wxBLACK_DASHED_PEN)). @@ -414,6 +429,7 @@ -define(wxWHITE, wxe_util:get_const(wxWHITE)). -define(wxWHITE_BRUSH, wxe_util:get_const(wxWHITE_BRUSH)). -define(wxWHITE_PEN, wxe_util:get_const(wxWHITE_PEN)). +-define(wx_GL_COMPAT_PROFILE, wxe_util:get_const(wx_GL_COMPAT_PROFILE)). %% Enum and defines % From class wxAuiManager diff --git a/lib/wx/src/wx.erl b/lib/wx/src/wx.erl index 34bf06cf46..6dd3c148db 100644 --- a/lib/wx/src/wx.erl +++ b/lib/wx/src/wx.erl @@ -183,7 +183,7 @@ batch(Fun) -> ok = wxe_util:cast(?BATCH_BEGIN, <<>>), try Fun() catch - error:W -> erlang:exit({W, erlang:get_stacktrace()}); + error:W:S -> erlang:exit({W, S}); throw:W -> erlang:throw(W); exit:W -> erlang:exit(W) after @@ -196,7 +196,7 @@ foreach(Fun, List) -> ok = wxe_util:cast(?BATCH_BEGIN, <<>>), try lists:foreach(Fun, List) catch - error:W -> erlang:exit({W, erlang:get_stacktrace()}); + error:W:S -> erlang:exit({W, S}); throw:W -> erlang:throw(W); exit:W -> erlang:exit(W) after @@ -209,7 +209,7 @@ map(Fun, List) -> ok = wxe_util:cast(?BATCH_BEGIN, <<>>), try lists:map(Fun, List) catch - error:W -> erlang:exit({W, erlang:get_stacktrace()}); + error:W:S -> erlang:exit({W, S}); throw:W -> erlang:throw(W); exit:W -> erlang:exit(W) after @@ -222,7 +222,7 @@ foldl(Fun, Acc, List) -> ok = wxe_util:cast(?BATCH_BEGIN, <<>>), try lists:foldl(Fun, Acc, List) catch - error:W -> erlang:exit({W, erlang:get_stacktrace()}); + error:W:S -> erlang:exit({W, S}); throw:W -> erlang:throw(W); exit:W -> erlang:exit(W) after @@ -235,7 +235,7 @@ foldr(Fun, Acc, List) -> ok = wxe_util:cast(?BATCH_BEGIN, <<>>), try lists:foldr(Fun, Acc, List) catch - error:W -> erlang:exit({W, erlang:get_stacktrace()}); + error:W:S -> erlang:exit({W, S}); throw:W -> erlang:throw(W); exit:W -> erlang:exit(W) after diff --git a/lib/wx/src/wxe_master.erl b/lib/wx/src/wxe_master.erl index ce859b3eb3..a55917f0aa 100644 --- a/lib/wx/src/wxe_master.erl +++ b/lib/wx/src/wxe_master.erl @@ -122,16 +122,9 @@ init([SilentStart]) -> erlang:error(not_smp) end, - case os:type() of - {win32,_} -> %% Needed for mingwm10.dll - Path = os:getenv("PATH"), - os:putenv("PATH", PrivDir ++ ";" ++ Path); - _ -> ok - end, - case erl_ddll:load_driver(PrivDir,DriverName) of ok -> ok; - {error, What} -> + {error, What} -> wxe_util:opt_error_log(SilentStart, "WX Failed loading ~p@~p ~n", [DriverName,PrivDir]), @@ -139,8 +132,8 @@ init([SilentStart]) -> erlang:error({load_driver,Str}) end, process_flag(trap_exit, true), - DriverWithArgs = DriverName ++ " " ++ code:priv_dir(wx) ++ [0], - + DriverWithArgs = DriverName ++ " " ++ code:priv_dir(wx), + try Port = open_port({spawn, DriverWithArgs},[binary]), wx_debug_info = ets:new(wx_debug_info, [named_table]), diff --git a/lib/wx/src/wxe_server.erl b/lib/wx/src/wxe_server.erl index 58fcaf8f23..d6d9dbd629 100644 --- a/lib/wx/src/wxe_server.erl +++ b/lib/wx/src/wxe_server.erl @@ -283,10 +283,10 @@ invoke_callback(Pid, Ev, Ref) -> Return -> exit({bad_return, Return}) end end - catch _:Reason -> + catch _:Reason:Stacktrace -> wxEvent:skip(Ref), ?log("Callback fun crashed with {'EXIT, ~p, ~p}~n", - [Reason, erlang:get_stacktrace()]) + [Reason, Stacktrace]) end, wxe_util:cast(?WXE_CB_RETURN, <<>>) end, @@ -299,9 +299,9 @@ invoke_callback_fun(Fun) -> Return = Fun(), true = is_binary(Return), Return - catch _:Reason -> + catch _:Reason:Stacktrace -> ?log("Callback fun crashed with {'EXIT, ~p, ~p}~n", - [Reason, erlang:get_stacktrace()]), + [Reason, Stacktrace]), <<>> end, wxe_util:cast(?WXE_CB_RETURN, Res). diff --git a/lib/wx/test/wx_class_SUITE.erl b/lib/wx/test/wx_class_SUITE.erl index 6d314ab8fc..c610b9c4f4 100644 --- a/lib/wx/test/wx_class_SUITE.erl +++ b/lib/wx/test/wx_class_SUITE.erl @@ -618,7 +618,7 @@ lang_env() -> Env0 = os:getenv(), Env = [[R,"\n"]||R <- Env0], %%io:format("~p~n",[lists:sort(Env)]), - Opts = [global, multiline, {capture, all, list}], + Opts = [global, multiline, {capture, all, list}, unicode], format_env(re:run(Env, "LC_ALL.*", Opts)), format_env(re:run(Env, "^LANG.*=.*$", Opts)), ok. diff --git a/lib/xmerl/doc/src/Makefile b/lib/xmerl/doc/src/Makefile index 7d0b0b2392..94100910ef 100644 --- a/lib/xmerl/doc/src/Makefile +++ b/lib/xmerl/doc/src/Makefile @@ -54,10 +54,9 @@ XMERL_MODULES = \ XML_APPLICATION_FILES = ref_man.xml -XMERL_XML_FILES = $(XMERL_MODULES:=.xml) +XMERL_XML_FILES = $(XMERL_MODULES:%=$(XMLDIR)/%.xml) -XML_REF3_FILES = $(XMERL_XML_FILES) \ - xmerl_sax_parser.xml +XML_REF3_FILES = xmerl_sax_parser.xml XML_PART_FILES = \ part.xml @@ -65,9 +64,10 @@ XML_PART_FILES = \ XML_REF6_FILES = XML_CHAPTER_FILES = \ - xmerl_ug.xml \ notes.xml +XML_CHAPTER_GEN_FILES = \ + $(XMLDIR)/xmerl_ug.xml HTML_EXAMPLE_FILES = \ xmerl_examples.html \ @@ -89,6 +89,8 @@ XML_FILES= \ $(BOOK_FILES) $(XML_CHAPTER_FILES) \ $(XML_PART_FILES) $(XML_REF3_FILES) $(XML_APPLICATION_FILES) +XML_GEN_FILES = $(XMERL_XML_FILES) $(XML_CHAPTER_GEN_FILES) + # ---------------------------------------------------- INFO_FILE = ../../info @@ -97,7 +99,7 @@ HTML_FILES = $(XML_REF_MAN:%.xml=$(HTMLDIR)/%.html) \ $(XML_PART_FILES:%.xml=$(HTMLDIR)/%.html) -MAN3_FILES = $(XML_REF3_FILES:%.xml=$(MAN3DIR)/%.3) +MAN3_FILES = $(XML_REF3_FILES:%.xml=$(MAN3DIR)/%.3) $(XMERL_MODULES:%=$(MAN3DIR)/%.3) MAN6_FILES = $(XML_REF6_FILES:%_app.xml=$(MAN6DIR)/%.6) HTML_REF_MAN_FILE = $(HTMLDIR)/index.html @@ -126,7 +128,7 @@ pdf: $(TOP_PDF_FILE) html: gifs $(HTML_REF_MAN_FILE) $(XMERL_XML_FILES): - escript $(DOCGEN)/priv/bin/xml_from_edoc.escript $(XMERL_DIR)/$(@:%.xml=%.erl) + $(gen_verbose)escript $(DOCGEN)/priv/bin/xml_from_edoc.escript -dir $(XMLDIR) $(XMERL_DIR)/$(@:$(XMLDIR)/%.xml=%.erl) man: $(MAN3_FILES) $(MAN6_FILES) diff --git a/lib/xmerl/src/xmerl_xsd.erl b/lib/xmerl/src/xmerl_xsd.erl index a89b3159ec..d727084175 100644 --- a/lib/xmerl/src/xmerl_xsd.erl +++ b/lib/xmerl/src/xmerl_xsd.erl @@ -18,7 +18,7 @@ %% %CopyrightEnd% %% -%% @doc Interface module for XML Schema vlidation. +%% @doc Interface module for XML Schema validation. %% It handles the W3.org %% <a href="http://www.w3.org/XML/Schema#dev">specifications</a> %% of XML Schema second edition 28 october 2004. For an introduction to diff --git a/lib/xmerl/test/xmerl_SUITE_data/eventp/CMOM.xml b/lib/xmerl/test/xmerl_SUITE_data/eventp/CMOM.xml index 7c64046897..c2533248d1 100644 --- a/lib/xmerl/test/xmerl_SUITE_data/eventp/CMOM.xml +++ b/lib/xmerl/test/xmerl_SUITE_data/eventp/CMOM.xml @@ -10264,7 +10264,7 @@ Note! This attribute cannot have a value larger than for 'egressAtmPcr'.</descri <attribute name="ingressAtmMcr"> <description>Ingress minimum desired cell rate (cells/s). -Only positive vaues allowed. This attribute is mandatory only when serviceCategory is UBR+. +Only positive values allowed. This attribute is mandatory only when serviceCategory is UBR+. Note! When 'serviceCategory' is set to CBR or UBR this attribute has no relevance and the value submitted is ignored by the system. diff --git a/lib/xmerl/test/xmerl_SUITE_data/eventp/CelloMOM.xml b/lib/xmerl/test/xmerl_SUITE_data/eventp/CelloMOM.xml index 8f8cf54505..3b5d8ae2ad 100644 --- a/lib/xmerl/test/xmerl_SUITE_data/eventp/CelloMOM.xml +++ b/lib/xmerl/test/xmerl_SUITE_data/eventp/CelloMOM.xml @@ -10264,7 +10264,7 @@ Note! This attribute cannot have a value larger than for 'egressAtmPcr'.</descri <attribute name="ingressAtmMcr">
<description>Ingress minimum desired cell rate (cells/s).
-Only positive vaues allowed. This attribute is mandatory only when serviceCategory is UBR+.
+Only positive values allowed. This attribute is mandatory only when serviceCategory is UBR+.
Note! When 'serviceCategory' is set to CBR or UBR this attribute has no relevance and the value submitted is ignored by the system.
|