diff options
Diffstat (limited to 'lib')
130 files changed, 5433 insertions, 778 deletions
diff --git a/lib/.gitignore b/lib/.gitignore index 4125111ebd..58c49adce0 100644 --- a/lib/.gitignore +++ b/lib/.gitignore @@ -546,6 +546,8 @@ snmp/doc/intex.html /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 diff --git a/lib/asn1/doc/src/asn1ct.xml b/lib/asn1/doc/src/asn1ct.xml index 4e0bf055fc..30808a5ead 100644 --- a/lib/asn1/doc/src/asn1ct.xml +++ b/lib/asn1/doc/src/asn1ct.xml @@ -371,6 +371,15 @@ File3.asn</pre> representation of a value of the <c>ASN.1</c> type <c>Type</c>. The value is a random value and subsequent calls to this function will for most types return different values.</p> + <note> + <p>Currently, the <c>value</c> function has many limitations. + Essentially, it will mostly work for old specifications based + on the 1997 standard for ASN.1, but not for most modern-style + applications. Another limitation is that the <c>value</c> function + may not work if options that change code generations strategies + such as the options <c>macro_name_prefix</c> and + <c>record_name_prefix</c> have been used.</p> + </note> </desc> </func> @@ -391,6 +400,15 @@ File3.asn</pre> This function is useful during test to secure that the generated encode and decode functions as well as the general runtime support work as expected.</p> + <note> + <p>Currently, the <c>test</c> functions have many limitations. + Essentially, they will mostly work for old specifications based + on the 1997 standard for ASN.1, but not for most modern-style + applications. Another limitation is that the <c>test</c> functions + may not work if options that change code generations strategies + such as the options <c>macro_name_prefix</c> and + <c>record_name_prefix</c> have been used.</p> + </note> <list type="bulleted"> <item> <p><c>test/1</c> iterates over all types in <c>Module</c>.</p> diff --git a/lib/common_test/src/common_test.app.src b/lib/common_test/src/common_test.app.src index 580d5dbd7b..0be1466fc9 100644 --- a/lib/common_test/src/common_test.app.src +++ b/lib/common_test/src/common_test.app.src @@ -63,9 +63,10 @@ ct_master_logs]}, {applications, [kernel,stdlib]}, {env, []}, - {runtime_dependencies,["xmerl-1.3.7","webtool-0.8.10","tools-2.6.14", - "test_server-3.7.1","stdlib-2.0","ssh-3.0.1", - "snmp-4.25.1","sasl-2.4","runtime_tools-1.8.14", - "kernel-3.0","inets-5.10","erts-6.0", - "debugger-4.0","crypto-3.3","compiler-5.0"]}]}. + {runtime_dependencies,["xmerl-1.3.8","tools-2.8", + "test_server-3.9","stdlib-2.5","ssh-4.0", + "snmp-5.1.2","sasl-2.4.2","runtime_tools-1.8.16", + "kernel-4.0","inets-6.0","erts-7.0", + "debugger-4.1","crypto-3.6","compiler-6.0", + "observer-2.1"]}]}. diff --git a/lib/common_test/vsn.mk b/lib/common_test/vsn.mk index e2d921729c..ff2bd20ab3 100644 --- a/lib/common_test/vsn.mk +++ b/lib/common_test/vsn.mk @@ -1 +1 @@ -COMMON_TEST_VSN = 1.10.1 +COMMON_TEST_VSN = 1.11 diff --git a/lib/compiler/src/beam_bsm.erl b/lib/compiler/src/beam_bsm.erl index 2a15c1ddf3..ee3e88959d 100644 --- a/lib/compiler/src/beam_bsm.erl +++ b/lib/compiler/src/beam_bsm.erl @@ -242,6 +242,12 @@ btb_reaches_match_2([{bif,_,{f,F},Ss,Dst}=I|Is], Regs0, D0) -> Regs = btb_kill([Dst], Regs0), D = btb_follow_branch(F, Regs, D0), btb_reaches_match_1(Is, Regs, D); +btb_reaches_match_2([{get_map_elements,{f,F},Src,{list,Ls}}=I|Is], Regs0, D0) -> + {Ss,Ds} = beam_utils:split_even(Ls), + btb_ensure_not_used([Src|Ss], I, Regs0), + Regs = btb_kill(Ds, Regs0), + D = btb_follow_branch(F, Regs, D0), + btb_reaches_match_1(Is, Regs, D); btb_reaches_match_2([{test,bs_start_match2,{f,F},Live,[Ctx,_],Ctx}=I|Is], Regs0, D0) -> CtxRegs = btb_context_regs(Regs0), diff --git a/lib/compiler/src/compile.erl b/lib/compiler/src/compile.erl index 22810c910c..0158cf64db 100644 --- a/lib/compiler/src/compile.erl +++ b/lib/compiler/src/compile.erl @@ -342,10 +342,10 @@ run_tc({Name,Fun}, St) -> run_eprof({Name,Fun}, Name, St) -> io:format("~p: Running eprof\n", [Name]), - eprof:start_profiling([self()]), + c:appcall(tools, eprof, start_profiling, [[self()]]), Val = (catch Fun(St)), - eprof:stop_profiling(), - eprof:analyze(), + c:appcall(tools, eprof, stop_profiling, []), + c:appcall(tools, eprof, analyze, []), Val; run_eprof({_,Fun}, _, St) -> catch Fun(St). diff --git a/lib/compiler/src/compiler.app.src b/lib/compiler/src/compiler.app.src index 2a40c1c379..17d1bd91ce 100644 --- a/lib/compiler/src/compiler.app.src +++ b/lib/compiler/src/compiler.app.src @@ -69,5 +69,5 @@ {registered, []}, {applications, [kernel, stdlib]}, {env, []}, - {runtime_dependencies, ["stdlib-2.0","kernel-3.0","hipe-3.10.3","erts-7.0", - "crypto-3.3"]}]}. + {runtime_dependencies, ["stdlib-2.5","kernel-4.0","hipe-3.12","erts-7.0", + "crypto-3.6"]}]}. diff --git a/lib/compiler/test/warnings_SUITE.erl b/lib/compiler/test/warnings_SUITE.erl index f6ba75577d..5742b7e6cf 100644 --- a/lib/compiler/test/warnings_SUITE.erl +++ b/lib/compiler/test/warnings_SUITE.erl @@ -38,7 +38,8 @@ -export([pattern/1,pattern2/1,pattern3/1,pattern4/1, guard/1,bad_arith/1,bool_cases/1,bad_apply/1, files/1,effect/1,bin_opt_info/1,bin_construction/1, - comprehensions/1,maps/1,redundant_boolean_clauses/1, + comprehensions/1,maps/1,maps_bin_opt_info/1, + redundant_boolean_clauses/1, latin1_fallback/1,underscore/1,no_warnings/1]). % Default timetrap timeout (set in init_per_testcase). @@ -64,6 +65,7 @@ groups() -> [pattern,pattern2,pattern3,pattern4,guard, bad_arith,bool_cases,bad_apply,files,effect, bin_opt_info,bin_construction,comprehensions,maps, + maps_bin_opt_info, redundant_boolean_clauses,latin1_fallback, underscore,no_warnings]}]. @@ -619,6 +621,19 @@ maps(Config) when is_list(Config) -> run(Config, Ts), ok. +maps_bin_opt_info(Config) when is_list(Config) -> + Ts = [{map_bsm, + <<" + t1(<<0:8,7:8,T/binary>>,#{val := I}=M) -> + t1(T, M#{val := I+1}); + t1(<<_:8>>,M) -> + M. + ">>, + [bin_opt_info], + {warnings,[{2,beam_bsm,bin_opt}]}}], + [] = run(Config, Ts), + ok. + redundant_boolean_clauses(Config) when is_list(Config) -> Ts = [{redundant_boolean_clauses, <<" diff --git a/lib/cosNotification/src/cosNotification.app.src b/lib/cosNotification/src/cosNotification.app.src index 09bf8f01fc..52ce164d46 100644 --- a/lib/cosNotification/src/cosNotification.app.src +++ b/lib/cosNotification/src/cosNotification.app.src @@ -117,6 +117,6 @@ {applications, [orber, stdlib, kernel]}, {env, []}, {mod, {cosNotificationApp, []}}, - {runtime_dependencies, ["stdlib-2.0","orber-3.6.27","kernel-3.0","erts-7.0", + {runtime_dependencies, ["stdlib-2.5","orber-3.6.27","kernel-3.0","erts-7.0", "cosTime-1.1.14","cosEvent-2.1.15"]} ]}. diff --git a/lib/debugger/src/debugger.app.src b/lib/debugger/src/debugger.app.src index f102385d39..a013c5c11f 100644 --- a/lib/debugger/src/debugger.app.src +++ b/lib/debugger/src/debugger.app.src @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1997-2013. All Rights Reserved. +%% Copyright Ericsson AB 1997-2015. All Rights Reserved. %% %% The contents of this file are subject to the Erlang Public License, %% Version 1.1, (the "License"); you may not use this file except in @@ -47,5 +47,5 @@ ]}, {registered, [dbg_iserver, dbg_wx_mon, dbg_wx_winman]}, {applications, [kernel, stdlib]}, - {runtime_dependencies, ["wx-1.2","stdlib-2.0","kernel-3.0","erts-6.0", + {runtime_dependencies, ["wx-1.2","stdlib-2.5","kernel-3.0","erts-6.0", "compiler-5.0"]}]}. diff --git a/lib/dialyzer/doc/src/dialyzer.xml b/lib/dialyzer/doc/src/dialyzer.xml index 2a8bf6edcc..5f52906625 100644 --- a/lib/dialyzer/doc/src/dialyzer.xml +++ b/lib/dialyzer/doc/src/dialyzer.xml @@ -368,6 +368,7 @@ Option :: {files, [Filename :: string()]} | {include_dirs, [DirName :: string()]} | {output_file, FileName :: string()} | {output_plt, FileName :: string()} + | {check_plt, boolean()}, | {analysis_type, 'succ_typings' | 'plt_add' | 'plt_build' | diff --git a/lib/dialyzer/src/dialyzer.app.src b/lib/dialyzer/src/dialyzer.app.src index 7b2e1d4a9d..b6b9173a84 100644 --- a/lib/dialyzer/src/dialyzer.app.src +++ b/lib/dialyzer/src/dialyzer.app.src @@ -2,7 +2,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2006-2014. All Rights Reserved. +%% Copyright Ericsson AB 2006-2015. All Rights Reserved. %% %% The contents of this file are subject to the Erlang Public License, %% Version 1.1, (the "License"); you may not use this file except in @@ -45,6 +45,6 @@ {registered, []}, {applications, [compiler, gs, hipe, kernel, stdlib, wx]}, {env, []}, - {runtime_dependencies, ["wx-1.2","syntax_tools-1.6.14","stdlib-2.0", + {runtime_dependencies, ["wx-1.2","syntax_tools-1.6.14","stdlib-2.5", "kernel-3.0","hipe-3.10.3","erts-7.0", "compiler-5.0"]}]}. diff --git a/lib/dialyzer/src/dialyzer.erl b/lib/dialyzer/src/dialyzer.erl index c9e7da9ef0..c8537e3bd8 100644 --- a/lib/dialyzer/src/dialyzer.erl +++ b/lib/dialyzer/src/dialyzer.erl @@ -2,7 +2,7 @@ %%----------------------------------------------------------------------- %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2006-2014. All Rights Reserved. +%% Copyright Ericsson AB 2006-2015. All Rights Reserved. %% %% The contents of this file are subject to the Erlang Public License, %% Version 1.1, (the "License"); you may not use this file except in @@ -162,14 +162,7 @@ run(Opts) -> {error, Msg} -> throw({dialyzer_error, Msg}); OptsRecord -> - case OptsRecord#options.check_plt of - true -> - case cl_check_init(OptsRecord) of - {ok, ?RET_NOTHING_SUSPICIOUS} -> ok; - {error, ErrorMsg1} -> throw({dialyzer_error, ErrorMsg1}) - end; - false -> ok - end, + ok = check_init(OptsRecord), case dialyzer_cl:start(OptsRecord) of {?RET_DISCREPANCIES, Warnings} -> Warnings; {?RET_NOTHING_SUSPICIOUS, _} -> [] @@ -179,6 +172,16 @@ run(Opts) -> erlang:error({dialyzer_error, lists:flatten(ErrorMsg)}) end. +check_init(#options{analysis_type = plt_check}) -> + ok; +check_init(#options{check_plt = true} = OptsRecord) -> + case cl_check_init(OptsRecord) of + {ok, _} -> ok; + {error, Msg} -> throw({dialyzer_error, Msg}) + end; +check_init(#options{check_plt = false}) -> + ok. + internal_gui(OptsRecord) -> F = fun() -> dialyzer_gui_wx:start(OptsRecord), @@ -199,17 +202,13 @@ gui(Opts) -> throw({dialyzer_error, Msg}); OptsRecord -> ok = check_gui_options(OptsRecord), - case cl_check_init(OptsRecord) of - {ok, ?RET_NOTHING_SUSPICIOUS} -> - F = fun() -> - dialyzer_gui_wx:start(OptsRecord) - end, - case doit(F) of - {ok, _} -> ok; - {error, Msg} -> throw({dialyzer_error, Msg}) - end; - {error, ErrorMsg1} -> - throw({dialyzer_error, ErrorMsg1}) + ok = check_init(OptsRecord), + F = fun() -> + dialyzer_gui_wx:start(OptsRecord) + end, + case doit(F) of + {ok, _} -> ok; + {error, Msg} -> throw({dialyzer_error, Msg}) end catch throw:{dialyzer_error, ErrorMsg} -> diff --git a/lib/dialyzer/test/plt_SUITE.erl b/lib/dialyzer/test/plt_SUITE.erl index ef4cdc57f0..ecbac14e5d 100644 --- a/lib/dialyzer/test/plt_SUITE.erl +++ b/lib/dialyzer/test/plt_SUITE.erl @@ -6,12 +6,13 @@ -include_lib("common_test/include/ct.hrl"). -include("dialyzer_test_constants.hrl"). --export([suite/0, all/0, build_plt/1, beam_tests/1, update_plt/1]). +-export([suite/0, all/0, build_plt/1, beam_tests/1, update_plt/1, + run_plt_check/1, run_succ_typings/1]). suite() -> [{timetrap, ?plt_timeout}]. -all() -> [build_plt, beam_tests, update_plt]. +all() -> [build_plt, beam_tests, update_plt, run_plt_check, run_succ_typings]. build_plt(Config) -> OutDir = ?config(priv_dir, Config), @@ -37,14 +38,76 @@ beam_tests(Config) when is_list(Config) -> ">>, Opts = [no_auto_import], {ok, BeamFile} = compile(Config, Prog, no_auto_import, Opts), - [] = run_dialyzer([BeamFile]), + [] = run_dialyzer(plt_build, [BeamFile], []), ok. -run_dialyzer(Files) -> - dialyzer:run([{analysis_type, plt_build}, - {files, Files}, - {from, byte_code}, - {check_plt, false}]). +run_plt_check(Config) when is_list(Config) -> + Mod1 = <<" + -module(run_plt_check1). + ">>, + + Mod2A = <<" + -module(run_plt_check2). + ">>, + + {ok, BeamFile1} = compile(Config, Mod1, run_plt_check1, []), + {ok, BeamFile2} = compile(Config, Mod2A, run_plt_check2, []), + [] = run_dialyzer(plt_build, [BeamFile1, BeamFile2], []), + + Mod2B = <<" + -module(run_plt_check2). + + -export([call/1]). + + call(X) -> run_plt_check1:call(X). + ">>, + + {ok, BeamFile2} = compile(Config, Mod2B, run_plt_check2, []), + + % callgraph warning as run_plt_check2:call/1 makes a call to unexported + % function run_plt_check1:call/1. + [_] = run_dialyzer(plt_check, [], []), + + ok. + +run_succ_typings(Config) when is_list(Config) -> + Mod1A = <<" + -module(run_succ_typings1). + + -export([call/0]). + + call() -> a. + ">>, + + {ok, BeamFile1} = compile(Config, Mod1A, run_succ_typings1, []), + [] = run_dialyzer(plt_build, [BeamFile1], []), + + Mod1B = <<" + -module(run_succ_typings1). + + -export([call/0]). + + call() -> b. + ">>, + + Mod2 = <<" + -module(run_succ_typings2). + + -export([call/0]). + + -spec call() -> b. + call() -> run_succ_typings1:call(). + ">>, + + {ok, BeamFile1} = compile(Config, Mod1B, run_succ_typings1, []), + {ok, BeamFile2} = compile(Config, Mod2, run_succ_typings2, []), + % contract types warning as run_succ_typings2:call/0 makes a call to + % run_succ_typings1:call/0, which returns a (not b) in the PLT. + [_] = run_dialyzer(succ_typings, [BeamFile2], [{check_plt, false}]), + % warning not returned as run_succ_typings1 is updated in the PLT. + [] = run_dialyzer(succ_typings, [BeamFile2], [{check_plt, true}]), + + ok. %%% [James Fish:] %%% If a function is removed from a module and the module has previously @@ -103,3 +166,9 @@ compile(Config, Prog, Module, CompileOpts) -> Opts = [{outdir, PrivDir}, debug_info | CompileOpts], {ok, Module} = compile:file(Filename, Opts), {ok, filename:join([PrivDir, lists:concat([Module, ".beam"])])}. + +run_dialyzer(Analysis, Files, Opts) -> + dialyzer:run([{analysis_type, Analysis}, + {files, Files}, + {from, byte_code} | + Opts]). diff --git a/lib/edoc/src/edoc.app.src b/lib/edoc/src/edoc.app.src index 9e1155d3e8..e4b9040c78 100644 --- a/lib/edoc/src/edoc.app.src +++ b/lib/edoc/src/edoc.app.src @@ -23,5 +23,5 @@ {registered,[]}, {applications, [compiler,kernel,stdlib,syntax_tools]}, {env, []}, - {runtime_dependencies, ["xmerl-1.3.7","syntax_tools-1.6.14","stdlib-2.0", + {runtime_dependencies, ["xmerl-1.3.7","syntax_tools-1.6.14","stdlib-2.5", "kernel-3.0","inets-5.10","erts-6.0"]}]}. diff --git a/lib/eldap/doc/src/eldap.xml b/lib/eldap/doc/src/eldap.xml index a6fad8a857..253ba7c2ff 100644 --- a/lib/eldap/doc/src/eldap.xml +++ b/lib/eldap/doc/src/eldap.xml @@ -121,7 +121,7 @@ filter() See present/1, substrings/2, <item>Any error responded from ssl:connect/3</item> </taglist> <p>The <c>Timeout</c> parameter is for the actual tls upgrade (phase 2) while the timeout in - <seealso marker="#open/2">erl_tar:open/2</seealso> is used for the initial negotiation about + <seealso marker="#open/2">eldap:open/2</seealso> is used for the initial negotiation about upgrade (phase 1). </p> </desc> @@ -298,7 +298,7 @@ filter() See present/1, substrings/2, search(Handle, [{base, "dc=example, dc=com"}, {filter, Filter}, {attributes, ["cn"]}]), </pre> <p>The <c>timeout</c> option in the <c>SearchOptions</c> is for the ldap server, while - the timeout in <seealso marker="#open/2">erl_tar:open/2</seealso> is used for each + the timeout in <seealso marker="#open/2">eldap:open/2</seealso> is used for each individual request in the search operation. </p> </desc> diff --git a/lib/erl_docgen/src/erl_docgen.app.src b/lib/erl_docgen/src/erl_docgen.app.src index e2830b2692..d63d880d89 100644 --- a/lib/erl_docgen/src/erl_docgen.app.src +++ b/lib/erl_docgen/src/erl_docgen.app.src @@ -9,6 +9,6 @@ {registered,[]}, {applications, [kernel,stdlib]}, {env, []}, - {runtime_dependencies, ["xmerl-1.3.7","stdlib-2.0","edoc-0.7.13","erts-6.0"]} + {runtime_dependencies, ["xmerl-1.3.7","stdlib-2.5","edoc-0.7.13","erts-6.0"]} ] }. diff --git a/lib/erl_docgen/vsn.mk b/lib/erl_docgen/vsn.mk index 5823c96253..2abd3d2b7e 100644 --- a/lib/erl_docgen/vsn.mk +++ b/lib/erl_docgen/vsn.mk @@ -1 +1 @@ -ERL_DOCGEN_VSN = 0.3.8 +ERL_DOCGEN_VSN = 0.4 diff --git a/lib/eunit/doc/overview.edoc b/lib/eunit/doc/overview.edoc index df716cdeea..eb60f673ef 100644 --- a/lib/eunit/doc/overview.edoc +++ b/lib/eunit/doc/overview.edoc @@ -572,6 +572,21 @@ Examples: <dt>`assertNotMatch(GuardedPattern, Expr)'</dt> <dd>The inverse case of assertMatch, for convenience. </dd> +<dt>`assertReceive(GuardedPattern, Timeout)'</dt> +<dd>Waits for up to the `Timeout' milliseconds for a message to arrive +in the mailbox of the current process that matches against the +`GuardedPattern' if testing is enabled. +If no message matching the `GuardedPattern' is received in the specified +`Timeout' interval, the assertion fails and an informative exception will +be generated; see the `assert' macro for further details. `GuardedPattern' +can be anything that you can write on the left hand side of the `->' +symbol in a case-clause, except that it cannot contain comma-separated +guard tests. + +Examples: +```?assertReceive(done, 1000)''' +```?assertReceive(Bin when byte_size(Bin) > 10, 1000)''' +</dd> <dt>`assertEqual(Expect, Expr)'</dt> <dd>Evaluates the expressions `Expect' and `Expr' and compares the results for equality, if testing is enabled. If the values are not diff --git a/lib/eunit/include/eunit.hrl b/lib/eunit/include/eunit.hrl index 53d291430d..8a829396ec 100644 --- a/lib/eunit/include/eunit.hrl +++ b/lib/eunit/include/eunit.hrl @@ -166,6 +166,26 @@ %% This is mostly a convenience which gives more detailed reports. %% Note: Guard is a guarded pattern, and can not be used for value. -ifdef(NOASSERT). +-define(assertReceive(Guard, Timeout), ok). +-else. +-define(assertReceive(Guard, Timeout), + begin + ((fun () -> + receive (Guard) -> ok + after Timeout -> erlang:error({assertReceive_timedout, + [{module, ?MODULE}, + {line, ?LINE}, + {pattern, (??Guard)}, + {timeout, __V}]}) + end + end)()) + end). +-endif. +-define(_assertReceive(Guard, Timeout), ?_test(?assertReceive(Guard, Timeout))). + +%% This is mostly a convenience which gives more detailed reports. +%% Note: Guard is a guarded pattern, and can not be used for value. +-ifdef(NOASSERT). -define(assertMatch(Guard, Expr), ok). -else. -define(assertMatch(Guard, Expr), diff --git a/lib/eunit/src/eunit.app.src b/lib/eunit/src/eunit.app.src index 7a3978e200..b4ff6c9242 100644 --- a/lib/eunit/src/eunit.app.src +++ b/lib/eunit/src/eunit.app.src @@ -19,4 +19,4 @@ {registered,[]}, {applications, [kernel,stdlib]}, {env, []}, - {runtime_dependencies, ["stdlib-2.0","kernel-3.0","erts-6.0"]}]}. + {runtime_dependencies, ["stdlib-2.5","kernel-3.0","erts-6.0"]}]}. diff --git a/lib/hipe/main/hipe.app.src b/lib/hipe/main/hipe.app.src index 22ea71b4e6..7b6d9e30e3 100644 --- a/lib/hipe/main/hipe.app.src +++ b/lib/hipe/main/hipe.app.src @@ -2,7 +2,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2002-2012. All Rights Reserved. +%% Copyright Ericsson AB 2002-2015. All Rights Reserved. %% %% The contents of this file are subject to the Erlang Public License, %% Version 1.1, (the "License"); you may not use this file except in @@ -223,5 +223,5 @@ {registered,[]}, {applications, [kernel,stdlib]}, {env, []}, - {runtime_dependencies, ["syntax_tools-1.6.14","stdlib-2.0","kernel-3.0", + {runtime_dependencies, ["syntax_tools-1.6.14","stdlib-2.5","kernel-3.0", "erts-7.0","compiler-5.0"]}]}. diff --git a/lib/inets/doc/src/notes.xml b/lib/inets/doc/src/notes.xml index 12bbc2b736..bae8e327a3 100644 --- a/lib/inets/doc/src/notes.xml +++ b/lib/inets/doc/src/notes.xml @@ -32,7 +32,22 @@ <file>notes.xml</file> </header> - <section><title>Inets 5.10.7</title> + <section><title>Inets 5.10.8</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> + Reject messages with a Content-Length less than 0</p> + <p> + Own Id: OTP-12739 Aux Id: seq12860 </p> + </item> + </list> + </section> + +</section> + +<section><title>Inets 5.10.7</title> <section><title>Improvements and New Features</title> <list> diff --git a/lib/inets/src/http_server/httpd_request.erl b/lib/inets/src/http_server/httpd_request.erl index 6985065c3e..3ff07616f9 100644 --- a/lib/inets/src/http_server/httpd_request.erl +++ b/lib/inets/src/http_server/httpd_request.erl @@ -417,8 +417,12 @@ check_header({"content-length", Value}, Maxsizes) -> case length(Value) =< MaxLen of true -> try - _ = list_to_integer(Value), - ok + list_to_integer(Value) + of + I when I>= 0 -> + ok; + _ -> + {error, {size_error, Max, 411, "negative content-length"}} catch _:_ -> {error, {size_error, Max, 411, "content-length not an integer"}} end; diff --git a/lib/inets/vsn.mk b/lib/inets/vsn.mk index e9ecb2632a..ecb84e447c 100644 --- a/lib/inets/vsn.mk +++ b/lib/inets/vsn.mk @@ -18,6 +18,6 @@ # %CopyrightEnd% APPLICATION = inets -INETS_VSN = 5.10.7 +INETS_VSN = 5.10.8 PRE_VSN = APP_VSN = "$(APPLICATION)-$(INETS_VSN)$(PRE_VSN)" diff --git a/lib/jinterface/java_src/com/ericsson/otp/erlang/OtpSelf.java b/lib/jinterface/java_src/com/ericsson/otp/erlang/OtpSelf.java index 5b9d13ad81..74afbbcca6 100644 --- a/lib/jinterface/java_src/com/ericsson/otp/erlang/OtpSelf.java +++ b/lib/jinterface/java_src/com/ericsson/otp/erlang/OtpSelf.java @@ -153,9 +153,6 @@ public class OtpSelf extends OtpLocalNode { * the port number you wish to use for incoming connections. * Specifying 0 lets the system choose an available port. * - * @param transportFactory - * the transport factory to use when creating connections. - * * @exception IOException * in case of server transport failure */ diff --git a/lib/kernel/src/application_controller.erl b/lib/kernel/src/application_controller.erl index 6635885aaf..a1a99a4e18 100644 --- a/lib/kernel/src/application_controller.erl +++ b/lib/kernel/src/application_controller.erl @@ -490,7 +490,8 @@ init(Init, Kernel) -> %% called during start-up of any app. case check_conf_data(ConfData) of ok -> - _ = ets:new(ac_tab, [set, public, named_table]), + _ = ets:new(ac_tab, [set, public, named_table, + {read_concurrency,true}]), S = #state{conf_data = ConfData}, {ok, KAppl} = make_appl(Kernel), case catch load(S, KAppl) of diff --git a/lib/kernel/src/code.erl b/lib/kernel/src/code.erl index d73d1ff281..65045666ec 100644 --- a/lib/kernel/src/code.erl +++ b/lib/kernel/src/code.erl @@ -107,7 +107,7 @@ is_module_native(_) -> -spec make_stub_module(Module, Beam, Info) -> Module when Module :: module(), Beam :: binary(), - Info :: {list(), list()}. + Info :: {list(), list(), binary()}. make_stub_module(_, _, _) -> erlang:nif_error(undef). @@ -560,12 +560,12 @@ load_native_code_for_all_loaded() -> try hipe_unified_loader:chunk_name(Architecture) of ChunkTag -> Loaded = all_loaded(), - spawn(fun() -> load_all_native(Loaded, ChunkTag) end) + _ = spawn(fun() -> load_all_native(Loaded, ChunkTag) end), + ok catch _:_ -> ok - end, - ok. + end. load_all_native(Loaded, ChunkTag) -> catch load_all_native_1(Loaded, ChunkTag). @@ -582,7 +582,8 @@ load_all_native_1([{Mod,BeamFilename}|T], ChunkTag) -> undefined -> ok; NativeCode when is_binary(NativeCode) -> - load_native_partial(Mod, NativeCode) + _ = load_native_partial(Mod, NativeCode), + ok end; true -> ok end, diff --git a/lib/kernel/src/inet_tcp_dist.erl b/lib/kernel/src/inet_tcp_dist.erl index 835dcf2705..fb60a14afb 100644 --- a/lib/kernel/src/inet_tcp_dist.erl +++ b/lib/kernel/src/inet_tcp_dist.erl @@ -112,7 +112,6 @@ listen_options(Opts0) -> end, case application:get_env(kernel, inet_dist_listen_options) of {ok,ListenOpts} -> - erlang:display({inet_dist_listen_options, ListenOpts}), ListenOpts ++ Opts1; _ -> Opts1 @@ -340,7 +339,6 @@ do_setup(Kernel, Node, Type, MyNode, LongOrShortNames,SetupTime) -> connect_options(Opts) -> case application:get_env(kernel, inet_dist_connect_options) of {ok,ConnectOpts} -> - erlang:display({inet_dist_listen_options, ConnectOpts}), ConnectOpts ++ Opts; _ -> Opts diff --git a/lib/kernel/src/kernel.app.src b/lib/kernel/src/kernel.app.src index 0cb10791d7..9787dca162 100644 --- a/lib/kernel/src/kernel.app.src +++ b/lib/kernel/src/kernel.app.src @@ -115,6 +115,6 @@ {applications, []}, {env, [{error_logger, tty}]}, {mod, {kernel, []}}, - {runtime_dependencies, ["erts-7.0", "stdlib-2.0", "sasl-2.4"]} + {runtime_dependencies, ["erts-7.0", "stdlib-2.5", "sasl-2.4"]} ] }. diff --git a/lib/kernel/src/user_drv.erl b/lib/kernel/src/user_drv.erl index 380c685869..d3deca3a20 100644 --- a/lib/kernel/src/user_drv.erl +++ b/lib/kernel/src/user_drv.erl @@ -135,7 +135,7 @@ server1(Iport, Oport, Shell) -> Iport, Oport), %% Enter the server loop. - server_loop(Iport, Oport, Curr, User, Gr, queue:new()). + server_loop(Iport, Oport, Curr, User, Gr, {false, queue:new()}). rem_sh_opts(Node) -> [{expand_fun,fun(B)-> rpc:call(Node,edlin_expand,expand,[B]) end}]. @@ -165,7 +165,7 @@ server_loop(Iport, Oport, User, Gr, IOQueue) -> put(current_group, Curr), server_loop(Iport, Oport, Curr, User, Gr, IOQueue). -server_loop(Iport, Oport, Curr, User, Gr, IOQueue) -> +server_loop(Iport, Oport, Curr, User, Gr, {Resp, IOQ} = IOQueue) -> receive {Iport,{data,Bs}} -> BsBin = list_to_binary(Bs), @@ -182,9 +182,9 @@ server_loop(Iport, Oport, Curr, User, Gr, IOQueue) -> {Oport,ok} -> %% We get this ok from the port, in io_request we store %% info about where to send reply at head of queue - {{value,{Origin,Reply}},ReplyQ} = queue:out(IOQueue), + {Origin,Reply} = Resp, Origin ! {reply,Reply}, - NewQ = handle_req(next, Iport, Oport, ReplyQ), + NewQ = handle_req(next, Iport, Oport, {false, IOQ}), server_loop(Iport, Oport, Curr, User, Gr, NewQ); {'EXIT',Iport,_R} -> server_loop(Iport, Oport, Curr, User, Gr, IOQueue); @@ -238,28 +238,30 @@ handle_req({Curr,get_unicode_state},Iport,_Oport,IOQueue) -> handle_req({Curr,set_unicode_state, Bool},Iport,_Oport,IOQueue) -> Curr ! {self(),set_unicode_state,set_unicode_state(Iport,Bool)}, IOQueue; -handle_req(next,Iport,Oport,IOQueue) -> - case queue:out(IOQueue) of - {{value,Next},ExecQ} -> - NewQ = handle_req(Next,Iport,Oport,queue:new()), - queue:join(NewQ,ExecQ); +handle_req(next,Iport,Oport,{false,IOQ}=IOQueue) -> + case queue:out(IOQ) of {empty,_} -> - IOQueue - end; -handle_req(Msg,Iport,Oport,IOQueue) -> - case queue:peek(IOQueue) of - empty -> - {Origin,Req} = Msg, + IOQueue; + {{value,{Origin,Req}},ExecQ} -> case io_request(Req, Iport, Oport) of - ok -> IOQueue; + ok -> + handle_req(next,Iport,Oport,{false,ExecQ}); Reply -> - %% Push reply info to front of queue - queue:in_r({Origin,Reply},IOQueue) - end; - _Else -> - %% All requests are queued when we have outstanding sync put_chars - queue:in(Msg,IOQueue) - end. + {{Origin,Reply}, ExecQ} + end + end; +handle_req(Msg,Iport,Oport,{false,IOQ}=IOQueue) -> + empty = queue:peek(IOQ), + {Origin,Req} = Msg, + case io_request(Req, Iport, Oport) of + ok -> + IOQueue; + Reply -> + {{Origin,Reply}, IOQ} + end; +handle_req(Msg,_Iport,_Oport,{Resp, IOQ}) -> + %% All requests are queued when we have outstanding sync put_chars + {Resp, queue:in(Msg,IOQ)}. %% port_bytes(Bytes, InPort, OutPort, CurrentProcess, UserProcess, Group) %% Check the Bytes from the port to see if it contains a ^G. If so, diff --git a/lib/kernel/test/error_logger_SUITE.erl b/lib/kernel/test/error_logger_SUITE.erl index 05bf5aae18..1c2e56f083 100644 --- a/lib/kernel/test/error_logger_SUITE.erl +++ b/lib/kernel/test/error_logger_SUITE.erl @@ -32,7 +32,7 @@ error_report/1, info_report/1, error/1, info/1, emulator/1, tty/1, logfile/1, add/1, delete/1]). --export([generate_error/0]). +-export([generate_error/2]). -export([init/1, handle_event/2, handle_call/2, handle_info/2, @@ -210,13 +210,16 @@ emulator(suite) -> []; emulator(doc) -> []; emulator(Config) when is_list(Config) -> ?line error_logger:add_report_handler(?MODULE, self()), - spawn(?MODULE, generate_error, []), - reported(emulator), + Msg = "Error in process ~p on node ~p with exit value:~n~p~n", + Error = {badmatch,4}, + Stack = [{module, function, 2, []}], + Pid = spawn(?MODULE, generate_error, [Error, Stack]), + reported(error, Msg, [Pid, node(), {Error, Stack}]), ?line my_yes = error_logger:delete_report_handler(?MODULE), ok. -generate_error() -> - erlang:error({badmatch,4}). +generate_error(Error, Stack) -> + erlang:raise(error, Error, Stack). %%----------------------------------------------------------------- %% We don't enables or disables tty error logging here. We do not @@ -283,15 +286,6 @@ reported(Tag, Type, Report) -> test_server:fail(no_report_received) end. -reported(emulator) -> - receive - {error, "~s~n", String} when is_list(String) -> - test_server:messages_get(), - ok - after 1000 -> - test_server:fail(no_report_received) - end. - %%----------------------------------------------------------------- %% The error_logger handler (gen_event behaviour). %% Sends a notification to the Tester process about the events diff --git a/lib/megaco/src/app/megaco.app.src b/lib/megaco/src/app/megaco.app.src index 6ab85a1bbc..3720b1109e 100644 --- a/lib/megaco/src/app/megaco.app.src +++ b/lib/megaco/src/app/megaco.app.src @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1999-2013. All Rights Reserved. +%% Copyright Ericsson AB 1999-2015. All Rights Reserved. %% %% The contents of this file are subject to the Erlang Public License, %% Version 1.1, (the "License"); you may not use this file except in @@ -113,7 +113,7 @@ {applications, [stdlib, kernel]}, {env, []}, {mod, {megaco_sup, []}}, - {runtime_dependencies, ["stdlib-2.0","runtime_tools-1.8.14","kernel-3.0", + {runtime_dependencies, ["stdlib-2.5","runtime_tools-1.8.14","kernel-3.0", "et-1.5","erts-6.0","debugger-4.0", "asn1-3.0"]} ]}. diff --git a/lib/megaco/vsn.mk b/lib/megaco/vsn.mk index 8687d622e9..ede36e3fe6 100644 --- a/lib/megaco/vsn.mk +++ b/lib/megaco/vsn.mk @@ -2,7 +2,7 @@ # %CopyrightBegin% # -# Copyright Ericsson AB 1997-2014. All Rights Reserved. +# Copyright Ericsson AB 1997-2015. All Rights Reserved. # # The contents of this file are subject to the Erlang Public License, # Version 1.1, (the "License"); you may not use this file except in @@ -18,6 +18,6 @@ # %CopyrightEnd% APPLICATION = megaco -MEGACO_VSN = 3.17.3 +MEGACO_VSN = 3.18 PRE_VSN = APP_VSN = "$(APPLICATION)-$(MEGACO_VSN)$(PRE_VSN)" diff --git a/lib/mnesia/src/mnesia.erl b/lib/mnesia/src/mnesia.erl index f501a4485b..b9c2fd915c 100644 --- a/lib/mnesia/src/mnesia.erl +++ b/lib/mnesia/src/mnesia.erl @@ -306,6 +306,8 @@ ms() -> -spec abort(_) -> no_return(). +abort(Reason = {aborted, _}) -> + exit(Reason); abort(Reason) -> exit({aborted, Reason}). @@ -1626,13 +1628,7 @@ dirty_read(Oid) -> dirty_read(Tab, Key) when is_atom(Tab), Tab /= schema -> -%% case catch ?ets_lookup(Tab, Key) of -%% {'EXIT', _} -> - %% Bad luck, we have to perform a real lookup - dirty_rpc(Tab, mnesia_lib, db_get, [Tab, Key]); -%% Val -> -%% Val -%% end; + dirty_rpc(Tab, mnesia_lib, db_get, [Tab, Key]); dirty_read(Tab, _Key) -> abort({bad_type, Tab}). diff --git a/lib/mnesia/src/mnesia_lib.erl b/lib/mnesia/src/mnesia_lib.erl index 7bd207f816..fc7362a31d 100644 --- a/lib/mnesia/src/mnesia_lib.erl +++ b/lib/mnesia/src/mnesia_lib.erl @@ -411,7 +411,7 @@ pr_other(Var) -> verbose("~p (~p) val(mnesia_gvar, ~w) -> ~p ~n", [self(), process_info(self(), registered_name), Var, Why]), - exit(Why). + mnesia:abort(Why). %% Some functions for list valued variables add(Var, Val) -> diff --git a/lib/mnesia/test/mnesia_evil_coverage_test.erl b/lib/mnesia/test/mnesia_evil_coverage_test.erl index 2d1623b6ca..430c1f1d84 100644 --- a/lib/mnesia/test/mnesia_evil_coverage_test.erl +++ b/lib/mnesia/test/mnesia_evil_coverage_test.erl @@ -1338,11 +1338,11 @@ user_properties(Config) when is_list(Config) -> ?match([], mnesia:table_info(Tab2, user_properties)), ?match([], mnesia:table_info(Tab3, user_properties)), - ?match({'EXIT', {no_exists, {Tab1, user_property, PropKey}}}, + ?match({'EXIT', {aborted, {no_exists, {Tab1, user_property, PropKey}}}}, mnesia:read_table_property(Tab1, PropKey)), - ?match({'EXIT', {no_exists, {Tab2, user_property, PropKey}}}, + ?match({'EXIT', {aborted, {no_exists, {Tab2, user_property, PropKey}}}}, mnesia:read_table_property(Tab2, PropKey)), - ?match({'EXIT', {no_exists, {Tab3, user_property, PropKey}}}, + ?match({'EXIT', {aborted, {no_exists, {Tab3, user_property, PropKey}}}}, mnesia:read_table_property(Tab3, PropKey)), ?match({atomic, ok}, mnesia:write_table_property(Tab1, Prop)), diff --git a/lib/orber/src/orber.app.src b/lib/orber/src/orber.app.src index 5dda63982f..217c1b247f 100644 --- a/lib/orber/src/orber.app.src +++ b/lib/orber/src/orber.app.src @@ -104,7 +104,7 @@ {applications, [stdlib, kernel, mnesia]}, {env, []}, {mod, {orber, []}}, - {runtime_dependencies, ["stdlib-2.0","ssl-5.3.4","mnesia-4.12","kernel-3.0", + {runtime_dependencies, ["stdlib-2.5","ssl-5.3.4","mnesia-4.12","kernel-3.0", "inets-5.10","erts-7.0"]} ]}. diff --git a/lib/parsetools/src/parsetools.app.src b/lib/parsetools/src/parsetools.app.src index 9eeb8fcc05..a7b258820a 100644 --- a/lib/parsetools/src/parsetools.app.src +++ b/lib/parsetools/src/parsetools.app.src @@ -12,7 +12,7 @@ {env, [{file_util_search_methods,[{"", ""}, {"ebin", "esrc"}, {"ebin", "src"}]} ] }, - {runtime_dependencies, ["stdlib-2.0","kernel-3.0","erts-6.0"]} + {runtime_dependencies, ["stdlib-2.5","kernel-3.0","erts-6.0"]} ] }. diff --git a/lib/public_key/doc/src/Makefile b/lib/public_key/doc/src/Makefile index 2adc13a5cf..d04819b5aa 100644 --- a/lib/public_key/doc/src/Makefile +++ b/lib/public_key/doc/src/Makefile @@ -42,7 +42,7 @@ XML_REF6_FILES = XML_PART_FILES = part.xml part_notes.xml XML_CHAPTER_FILES = \ introduction.xml \ - records.xml \ + public_key_records.xml \ using_public_key.xml \ notes.xml diff --git a/lib/public_key/doc/src/part.xml b/lib/public_key/doc/src/part.xml index d3cc9303bd..465f311946 100644 --- a/lib/public_key/doc/src/part.xml +++ b/lib/public_key/doc/src/part.xml @@ -38,7 +38,7 @@ PKCS</url> standard.</p> </description> <xi:include href="introduction.xml"/> - <xi:include href="records.xml"/> + <xi:include href="public_key_records.xml"/> <xi:include href="using_public_key.xml"/> </part> diff --git a/lib/public_key/doc/src/public_key.xml b/lib/public_key/doc/src/public_key.xml index 6d220c9b69..883c52393f 100644 --- a/lib/public_key/doc/src/public_key.xml +++ b/lib/public_key/doc/src/public_key.xml @@ -87,104 +87,109 @@ <tag><c>oid()</c></tag> <item><p>Object identifier, a tuple of integers as generated by the <c>ASN.1</c> compiler.</p></item> - <tag><c>boolean()</c></tag> - <item><p>= <c>true | false</c></p></item> - - <tag><c>string()</c></tag> - <item><p>= <c>[bytes()]</c></p></item> - - <tag><c>der_encoded()</c></tag> - <item><p>= <c>binary()</c></p></item> - - <tag><c>pki_asn1_type()</c></tag> - <item>= <p><c>'Certificate'</c></p> - <p><c>| 'RSAPrivateKey'</c></p> - <p><c>| 'RSAPublicKey'</c></p> - <p><c>| 'DSAPrivateKey'</c></p> - <p><c>| 'DSAPublicKey'</c></p> - <p><c>| 'DHParameter'</c></p> - <p><c>| 'SubjectPublicKeyInfo'</c></p> - <p><c>| 'PrivateKeyInfo'</c></p> - <p><c>| 'CertificationRequest'</c></p> - <p><c>| 'ECPrivateKey'</c></p> - <p><c>| 'EcpkParameters'</c></p></item> - - <tag><c>pem_entry ()</c></tag> - <item><p>= <c>{pki_asn1_type(), binary(), %% DER or encrypted DER not_encrypted</c></p> - <p><c>| cipher_info()}</c></p></item> + <tag><c>boolean() =</c></tag> + <item><p><c>true | false</c></p></item> + + <tag><c>string() =</c></tag> + <item><p><c>[bytes()]</c></p></item> + + <tag><c>der_encoded() =</c></tag> + <item><p><c>binary()</c></p></item> + + <tag><c>pki_asn1_type() =</c></tag> + <item> + <p><c>'Certificate'</c></p> + <p><c>| 'RSAPrivateKey'</c></p> + <p><c>| 'RSAPublicKey'</c></p> + <p><c>| 'DSAPrivateKey'</c></p> + <p><c>| 'DSAPublicKey'</c></p> + <p><c>| 'DHParameter'</c></p> + <p><c>| 'SubjectPublicKeyInfo'</c></p> + <p><c>| 'PrivateKeyInfo'</c></p> + <p><c>| 'CertificationRequest'</c></p> + <p><c>| 'ECPrivateKey'</c></p> + <p><c>| 'EcpkParameters'</c></p> + </item> - <tag><c>cipher_info()</c></tag> - <item><p>= <c>{"RC2-CBC" | "DES-CBC" | "DES-EDE3-CBC", crypto:rand_bytes(8)</c></p> + <tag><c>pem_entry () =</c></tag> + <item><p><c>{pki_asn1_type(), binary(), %% DER or encrypted DER not_encrypted</c></p> + <p><c>| cipher_info()}</c></p></item> + + <tag><c>cipher_info() = </c></tag> + <item><p><c>{"RC2-CBC" | "DES-CBC" | "DES-EDE3-CBC", crypto:rand_bytes(8)</c></p> <p><c>| {#'PBEParameter{}, digest_type()} | #'PBES2-params'{}}</c></p> </item> - <tag><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> - <item><p>= <c>rsa_private_key() | dsa_private_key() | ec_private_key()</c></p></item> + <tag><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> + <item><p><c>rsa_private_key() | dsa_private_key() | ec_private_key()</c></p></item> - <tag><c>rsa_public_key()</c></tag> - <item><p>= <c>#'RSAPublicKey'{}</c></p></item> + <tag><c>rsa_public_key() =</c></tag> + <item><p><c>#'RSAPublicKey'{}</c></p></item> - <tag><c>rsa_private_key()</c></tag> - <item><p>= <c>#'RSAPrivateKey'{}</c></p></item> + <tag><c>rsa_private_key() =</c></tag> + <item><p><c>#'RSAPrivateKey'{}</c></p></item> - <tag><c>dsa_public_key()</c></tag> - <item><p>= <c>{integer(), #'Dss-Parms'{}}</c></p></item> + <tag><c>dsa_public_key() =</c></tag> + <item><p><c>{integer(), #'Dss-Parms'{}}</c></p></item> - <tag><c>dsa_private_key()</c></tag> - <item><p>= <c>#'DSAPrivateKey'{}</c></p></item> + <tag><c>dsa_private_key() =</c></tag> + <item><p><c>#'DSAPrivateKey'{}</c></p></item> <tag><c>ec_public_key()</c></tag> <item><p>= <c>{#'ECPoint'{}, #'EcpkParameters'{} | {namedCurve, oid()}}</c></p></item> - <tag><c>ec_private_key()</c></tag> - <item><p>= <c>#'ECPrivateKey'{}</c></p></item> + <tag><c>ec_private_key() =</c></tag> + <item><p><c>#'ECPrivateKey'{}</c></p></item> - <tag><c>public_crypt_options()</c></tag> - <item><p>= <c>[{rsa_pad, rsa_padding()}]</c></p></item> + <tag><c>public_crypt_options() =</c></tag> + <item><p><c>[{rsa_pad, rsa_padding()}]</c></p></item> - <tag><c>rsa_padding()</c></tag> - <item><p>= <c>'rsa_pkcs1_padding'</c></p> - <p><c>| 'rsa_pkcs1_oaep_padding'</c></p> - <p><c>| 'rsa_no_padding'</c></p> + <tag><c>rsa_padding() =</c></tag> + <item> + <p><c>'rsa_pkcs1_padding'</c></p> + <p><c>| 'rsa_pkcs1_oaep_padding'</c></p> + <p><c>| 'rsa_no_padding'</c></p> </item> - <tag><c>digest_type()</c></tag> + <tag><c>digest_type() = </c></tag> <item><p>Union of <c>rsa_digest_type()</c>, <c>dss_digest_type()</c>, and <c>ecdsa_digest_type()</c>.</p></item> - <tag><c>rsa_digest_type()</c></tag> - <item><p>= <c>'md5' | 'sha' | 'sha224' | 'sha256' | 'sha384' | 'sha512'</c></p></item> - - <tag><c>dss_digest_type()</c></tag> - <item><p>= <c>'sha'</c></p></item> - - <tag><c>ecdsa_digest_type()</c></tag> - <item><p>= <c>'sha'| 'sha224' | 'sha256' | 'sha384' | 'sha512'</c></p></item> - - <tag><c>crl_reason()</c></tag> - <item><p>= <c>unspecified</c></p> - <p><c>| keyCompromise</c></p> - <p><c>| cACompromise</c></p> - <p><c>| affiliationChanged</c></p> - <p><c>| superseded</c></p> - <p><c>| cessationOfOperation</c></p> - <p><c>| certificateHold</c></p> - <p><c>| privilegeWithdrawn</c></p> - <p><c>| aACompromise</c></p> - </item> + <tag><c>rsa_digest_type() = </c></tag> + <item><p><c>'md5' | 'sha' | 'sha224' | 'sha256' | 'sha384' | 'sha512'</c></p></item> + + <tag><c>dss_digest_type() = </c></tag> + <item><p><c>'sha'</c></p></item> - <tag><c>issuer_name()</c></tag> - <item><p>= <c>{rdnSequence,[#'AttributeTypeAndValue'{}]}</c></p> + <tag><c>ecdsa_digest_type() = </c></tag> + <item><p><c>'sha'| 'sha224' | 'sha256' | 'sha384' | 'sha512'</c></p></item> + + <tag><c>crl_reason() = </c></tag> + <item> + <p><c>unspecified</c></p> + <p><c>| keyCompromise</c></p> + <p><c>| cACompromise</c></p> + <p><c>| affiliationChanged</c></p> + <p><c>| superseded</c></p> + <p><c>| cessationOfOperation</c></p> + <p><c>| certificateHold</c></p> + <p><c>| privilegeWithdrawn</c></p> + <p><c>| aACompromise</c></p> </item> - <tag><c>ssh_file()</c></tag> - <item><p>= <c>openssh_public_key</c></p> - <p><c>| rfc4716_public_key</c></p> - <p><c>| known_hosts</c></p> - <p><c>| auth_keys</c></p> + <tag><c>issuer_name() =</c></tag> + <item><p><c>{rdnSequence,[#'AttributeTypeAndValue'{}]}</c></p> + </item> + + <tag><c>ssh_file() =</c></tag> + <item> + <p><c>openssh_public_key</c></p> + <p><c>| rfc4716_public_key</c></p> + <p><c>| known_hosts</c></p> + <p><c>| auth_keys</c></p> </item> </taglist> diff --git a/lib/public_key/doc/src/records.xml b/lib/public_key/doc/src/public_key_records.xml index 9536167839..fc2a74a353 100644 --- a/lib/public_key/doc/src/records.xml +++ b/lib/public_key/doc/src/public_key_records.xml @@ -55,17 +55,17 @@ follows here:</p> <taglist> - <tag><c>time()</c></tag> - <item><p>= <c>uct_time() | general_time()</c></p></item> + <tag><c>time() =</c></tag> + <item><p><c>uct_time() | general_time()</c></p></item> - <tag><c>uct_time()</c></tag> - <item><p>= <c>{utcTime, "YYMMDDHHMMSSZ"}</c></p></item> + <tag><c>uct_time() =</c></tag> + <item><p><c>{utcTime, "YYMMDDHHMMSSZ"}</c></p></item> - <tag><c>general_time()</c></tag> - <item><p>= <c>{generalTime, "YYYYMMDDHHMMSSZ"}</c></p></item> + <tag><c>general_time() =</c></tag> + <item><p><c>{generalTime, "YYYYMMDDHHMMSSZ"}</c></p></item> - <tag><c>general_name()</c></tag> - <item>= <p><c>{rfc822Name, string()}</c></p> + <tag><c>general_name() =</c></tag> + <item><p><c>{rfc822Name, string()}</c></p> <p><c>| {dNSName, string()}</c></p> <p><c>| {x400Address, string()}</c></p> <p><c>| {directoryName, {rdnSequence, [#AttributeTypeAndValue'{}]}}</c></p> @@ -77,16 +77,16 @@ <p><c>| {otherName, term()}</c></p> </item> - <tag><c>special_string()</c></tag> - <item>= <p><c>{teletexString, string()}</c></p> + <tag><c>special_string() =</c></tag> + <item><p><c>{teletexString, string()}</c></p> <p><c>| {printableString, string()}</c></p> <p><c>| {universalString, string()}</c></p> <p><c>| {utf8String, binary()}</c></p> <p><c>| {bmpString, string()}</c></p> </item> - <tag><c>dist_reason()</c></tag> - <item>= <p><c>unused</c></p> + <tag><c>dist_reason() =</c></tag> + <item><p><c>unused</c></p> <p><c>| keyCompromise</c></p> <p><c>| cACompromise</c></p> <p><c>| affiliationChanged</c></p> @@ -97,12 +97,12 @@ <p><c>| aACompromise</c></p> </item> - <tag><c>OID_macro()</c></tag> - <item>= <p><c>?OID_name() </c></p> + <tag><c>OID_macro() =</c></tag> + <item><p><c>?OID_name()</c></p> </item> - <tag><c>OID_name()</c></tag> - <item>= <p><c>atom()</c></p> + <tag><c>OID_name() =</c></tag> + <item><p><c>atom()</c></p> </item> </taglist> diff --git a/lib/snmp/src/app/snmp.app.src b/lib/snmp/src/app/snmp.app.src index cbd292e4c3..a55bb389ba 100644 --- a/lib/snmp/src/app/snmp.app.src +++ b/lib/snmp/src/app/snmp.app.src @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2013. All Rights Reserved. +%% Copyright Ericsson AB 1996-2015. All Rights Reserved. %% %% The contents of this file are subject to the Erlang Public License, %% Version 1.1, (the "License"); you may not use this file except in @@ -137,5 +137,5 @@ %% before snmp. {applications, [kernel, stdlib]}, {mod, {snmp_app, []}}, - {runtime_dependencies, ["stdlib-2.0","runtime_tools-1.8.14","mnesia-4.12", + {runtime_dependencies, ["stdlib-2.5","runtime_tools-1.8.14","mnesia-4.12", "kernel-3.0","erts-6.0","crypto-3.3"]}]}. diff --git a/lib/snmp/vsn.mk b/lib/snmp/vsn.mk index 67adf0a34f..14da37a225 100644 --- a/lib/snmp/vsn.mk +++ b/lib/snmp/vsn.mk @@ -18,6 +18,6 @@ # %CopyrightEnd% APPLICATION = snmp -SNMP_VSN = 5.1.2 +SNMP_VSN = 5.2 PRE_VSN = APP_VSN = "$(APPLICATION)-$(SNMP_VSN)$(PRE_VSN)" diff --git a/lib/ssh/doc/src/notes.xml b/lib/ssh/doc/src/notes.xml index 41885c684c..579a3ae4a8 100644 --- a/lib/ssh/doc/src/notes.xml +++ b/lib/ssh/doc/src/notes.xml @@ -29,6 +29,25 @@ <file>notes.xml</file> </header> +<section><title>Ssh 3.2.3</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> + A new option for handling the SSH_MSG_DEBUG message's + printouts. A fun could be given in the options that will + be called whenever the SSH_MSG_DEBUG message arrives. + This enables the user to format the printout or just + discard it.</p> + <p> + Own Id: OTP-12738 Aux Id: seq12860 </p> + </item> + </list> + </section> + +</section> + <section><title>Ssh 3.2.2</title> <section><title>Improvements and New Features</title> diff --git a/lib/ssh/doc/src/ssh.xml b/lib/ssh/doc/src/ssh.xml index d49d3ac2a7..df13442fc6 100644 --- a/lib/ssh/doc/src/ssh.xml +++ b/lib/ssh/doc/src/ssh.xml @@ -57,29 +57,28 @@ 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 to the user, - returned by <c>ssh:daemon/[1,2,3]</c></p></item> - <tag><c>ssh_connection_ref()</c></tag> - <item><p>Opaque to the user, - returned by <c>ssh:connect/3</c></p></item> - <tag><c>ip_address()</c></tag> + <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>channel_init_args()</c></tag> - <item><p>= <c>list()</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>channel_init_args() =</c></tag> + <item><p><c>list()</c></p></item> </taglist> </section> @@ -227,6 +226,13 @@ <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> @@ -427,8 +433,16 @@ <item> <p>Provides a fun to implement your own logging when a user disconnects from the server.</p> </item> - </taglist> - </desc> + + <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> diff --git a/lib/ssh/doc/src/ssh_channel.xml b/lib/ssh/doc/src/ssh_channel.xml index b8a03c350a..2fdecf9072 100644 --- a/lib/ssh/doc/src/ssh_channel.xml +++ b/lib/ssh/doc/src/ssh_channel.xml @@ -62,22 +62,22 @@ 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 to the user, 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> + <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> diff --git a/lib/ssh/doc/src/ssh_client_key_api.xml b/lib/ssh/doc/src/ssh_client_key_api.xml index a8dda042c9..9a892d71fd 100644 --- a/lib/ssh/doc/src/ssh_client_key_api.xml +++ b/lib/ssh/doc/src/ssh_client_key_api.xml @@ -50,16 +50,16 @@ <seealso marker="public_key:public_key_records"> public_key user's guide:</seealso> </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>public_key()</c></tag> - <item><p>= <c>#'RSAPublicKey'{}| {integer(), #'Dss-Parms'{}}| term()</c></p></item> - <tag><c>private_key()</c></tag> - <item><p>= <c>#'RSAPrivateKey'{} | #'DSAPrivateKey'{} | term()</c></p></item> - <tag><c>public_key_algorithm()</c></tag> - <item><p>= <c>'ssh-rsa'| 'ssh-dss' | atom()</c></p></item> + <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>public_key() =</c></tag> + <item><p><c>#'RSAPublicKey'{}| {integer(), #'Dss-Parms'{}}| term()</c></p></item> + <tag><c>private_key() =</c></tag> + <item><p><c>#'RSAPrivateKey'{} | #'DSAPrivateKey'{} | term()</c></p></item> + <tag><c>public_key_algorithm() =</c></tag> + <item><p><c>'ssh-rsa'| 'ssh-dss' | atom()</c></p></item> </taglist> </section> diff --git a/lib/ssh/doc/src/ssh_connection.xml b/lib/ssh/doc/src/ssh_connection.xml index 669a361db9..5422633dc3 100644 --- a/lib/ssh/doc/src/ssh_connection.xml +++ b/lib/ssh/doc/src/ssh_connection.xml @@ -56,29 +56,29 @@ 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 to the user, returned by - <c>ssh:connect/3</c> or sent to an SSH channel processes</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 + <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 processes</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 valid values, see <url href="http://www.ietf.org/rfc/rfc4254.txt">RFC 4254</url> Section 5.2.</p></item> - <tag><c>ssh_request_status() 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> - <tag><c>ssh_event_msg()</c></tag> - <item><p>= <c>data_events() | status_events() | terminal_events()</c></p></item> - <tag><c>reason()</c></tag> - <item><p>= <c>timeout | closed</c></p></item> + <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> + <tag><c>ssh_event_msg() =</c></tag> + <item><p><c>data_events() | status_events() | terminal_events()</c></p></item> + <tag><c>reason() =</c></tag> + <item><p><c>timeout | closed</c></p></item> </taglist> <taglist> diff --git a/lib/ssh/doc/src/ssh_server_key_api.xml b/lib/ssh/doc/src/ssh_server_key_api.xml index 34ce7f7660..73dd90c962 100644 --- a/lib/ssh/doc/src/ssh_server_key_api.xml +++ b/lib/ssh/doc/src/ssh_server_key_api.xml @@ -50,20 +50,20 @@ <seealso marker="public_key:public_key_records"> public_key user's guide</seealso>. </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>public_key()</c></tag> - <item><p>= <c>#'RSAPublicKey'{}| {integer(), #'Dss-Parms'{}}| term()</c></p></item> - <tag><c>private_key()</c></tag> - <item><p>= <c>#'RSAPrivateKey'{} | #'DSAPrivateKey'{} | term()</c></p></item> - <tag><c>public_key_algorithm()</c></tag> - <item><p>= <c>'ssh-rsa'| 'ssh-dss' | atom()</c></p></item> + <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>public_key() =</c></tag> + <item><p><c>#'RSAPublicKey'{}| {integer(), #'Dss-Parms'{}}| term()</c></p></item> + <tag><c>private_key() =</c></tag> + <item><p><c>#'RSAPrivateKey'{} | #'DSAPrivateKey'{} | term()</c></p></item> + <tag><c>public_key_algorithm() =</c></tag> + <item><p><c>'ssh-rsa'| 'ssh-dss' | atom()</c></p></item> </taglist> </section> - + <funcs> <func> <name>Module:host_key(Algorithm, DaemonOptions) -> diff --git a/lib/ssh/doc/src/ssh_sftp.xml b/lib/ssh/doc/src/ssh_sftp.xml index 643130fe6b..fc418bc934 100644 --- a/lib/ssh/doc/src/ssh_sftp.xml +++ b/lib/ssh/doc/src/ssh_sftp.xml @@ -43,8 +43,8 @@ </p> <taglist> - <tag><c>ssh_connection_ref()</c></tag> - <item><p>Opaque to the user, returned by <c>ssh:connect/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>timeout()</c></tag> <item><p>= <c>infinity | integer() in milliseconds. Default infinity.</c></p></item> </taglist> diff --git a/lib/ssh/doc/src/ssh_sftpd.xml b/lib/ssh/doc/src/ssh_sftpd.xml index bc2660f595..8b2497e6a3 100644 --- a/lib/ssh/doc/src/ssh_sftpd.xml +++ b/lib/ssh/doc/src/ssh_sftpd.xml @@ -37,16 +37,16 @@ <section> <title>DATA TYPES</title> <taglist> - <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>"sftp"</c></p></item> - <tag><c>channel_callback()</c></tag> - <item><p>= <c>atom()</c> - Name of the Erlang module implementing the subsystem using the + <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>"sftp"</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 the <seealso marker="ssh_channel">ssh_channel(3)</seealso> manual page.</p></item> - <tag><c>channel_init_args()</c></tag> - <item><p>= <c>list()</c> - The one given as argument to function <c>subsystem_spec/1</c>.</p></item> + <tag><c>channel_init_args() =</c></tag> + <item><p><c>list()</c> - The one given as argument to function <c>subsystem_spec/1</c>.</p></item> </taglist> </section> <funcs> diff --git a/lib/ssh/src/ssh.erl b/lib/ssh/src/ssh.erl index d4b02a024e..71e7d77475 100644 --- a/lib/ssh/src/ssh.erl +++ b/lib/ssh/src/ssh.erl @@ -312,6 +312,8 @@ handle_option([{disconnectfun, _} = Opt | Rest], SocketOptions, SshOptions) -> handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); handle_option([{failfun, _} = Opt | Rest], SocketOptions, SshOptions) -> handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); +handle_option([{ssh_msg_debug_fun, _} = Opt | Rest], SocketOptions, SshOptions) -> + handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]); %%Backwards compatibility should not be underscore between ip and v6 in API handle_option([{ip_v6_disabled, Value} | Rest], SocketOptions, SshOptions) -> handle_option(Rest, SocketOptions, [handle_ssh_option({ipv6_disabled, Value}) | SshOptions]); @@ -417,6 +419,8 @@ handle_ssh_option({disconnectfun , Value} = Opt) when is_function(Value) -> Opt; handle_ssh_option({failfun, Value} = Opt) when is_function(Value) -> Opt; +handle_ssh_option({ssh_msg_debug_fun, Value} = Opt) when is_function(Value,4) -> + Opt; handle_ssh_option({ipv6_disabled, Value} = Opt) when is_boolean(Value) -> throw({error, {{ipv6_disabled, Opt}, option_no_longer_valid_use_inet_option_instead}}); diff --git a/lib/ssh/src/ssh_connection.erl b/lib/ssh/src/ssh_connection.erl index 388c080d99..d532d41009 100644 --- a/lib/ssh/src/ssh_connection.erl +++ b/lib/ssh/src/ssh_connection.erl @@ -196,15 +196,16 @@ reply_request(_,false, _, _) -> %%-------------------------------------------------------------------- ptty_alloc(ConnectionHandler, Channel, Options) -> ptty_alloc(ConnectionHandler, Channel, Options, infinity). -ptty_alloc(ConnectionHandler, Channel, Options, TimeOut) -> +ptty_alloc(ConnectionHandler, Channel, Options0, TimeOut) -> + Options = backwards_compatible(Options0, []), {Width, PixWidth} = pty_default_dimensions(width, Options), - {Hight, PixHight} = pty_default_dimensions(hight, Options), + {Height, PixHeight} = pty_default_dimensions(height, Options), pty_req(ConnectionHandler, Channel, proplists:get_value(term, Options, os:getenv("TERM", ?DEFAULT_TERMINAL)), proplists:get_value(width, Options, Width), - proplists:get_value(hight, Options, Hight), + proplists:get_value(height, Options, Height), proplists:get_value(pixel_widh, Options, PixWidth), - proplists:get_value(pixel_hight, Options, PixHight), + proplists:get_value(pixel_height, Options, PixHeight), proplists:get_value(pty_opts, Options, []), TimeOut ). %%-------------------------------------------------------------------- @@ -1339,3 +1340,12 @@ decode_ip(Addr) when is_binary(Addr) -> {error,_} -> Addr; {ok,A} -> A end. + +backwards_compatible([], Acc) -> + Acc; +backwards_compatible([{hight, Value} | Rest], Acc) -> + backwards_compatible(Rest, [{height, Value} | Acc]); +backwards_compatible([{pixel_hight, Value} | Rest], Acc) -> + backwards_compatible(Rest, [{height, Value} | Acc]); +backwards_compatible([Value| Rest], Acc) -> + backwards_compatible(Rest, [ Value | Acc]). diff --git a/lib/ssh/src/ssh_connection_handler.erl b/lib/ssh/src/ssh_connection_handler.erl index 4dea284071..65208ae158 100644 --- a/lib/ssh/src/ssh_connection_handler.erl +++ b/lib/ssh/src/ssh_connection_handler.erl @@ -71,6 +71,7 @@ key_exchange_init_msg, % #ssh_msg_kexinit{} renegotiate = false, % boolean() last_size_rekey = 0, + event_queue = [], connection_queue, address, port, @@ -83,6 +84,11 @@ {next_state, state_name(), term(), timeout()} | {stop, term(), term()}. +-type gen_fsm_sync_return() :: {next_state, state_name(), term()} | + {next_state, state_name(), term(), timeout()} | + {reply, term(), state_name(), term()} | + {stop, term(), term(), term()}. + %%==================================================================== %% Internal application API %%==================================================================== @@ -433,9 +439,7 @@ key_exchange(#ssh_msg_kex_dh_gex_reply{} = Msg, new_keys(#ssh_msg_newkeys{} = Msg, #state{ssh_params = Ssh0} = State0) -> {ok, Ssh} = ssh_transport:handle_new_keys(Msg, Ssh0), - {NextStateName, State} = - after_new_keys(State0#state{ssh_params = Ssh}), - {next_state, NextStateName, next_packet(State)}. + after_new_keys(next_packet(State0#state{ssh_params = Ssh})). %%-------------------------------------------------------------------- -spec userauth(#ssh_msg_service_request{} | #ssh_msg_service_accept{} | @@ -559,11 +563,13 @@ userauth(#ssh_msg_userauth_banner{message = Msg}, -spec connected({#ssh_msg_kexinit{}, binary()}, %%| %% #ssh_msg_kexdh_init{}, #state{}) -> gen_fsm_state_return(). %%-------------------------------------------------------------------- -connected({#ssh_msg_kexinit{}, _Payload} = Event, State) -> - kexinit(Event, State#state{renegotiate = true}). -%% ; -%% connected(#ssh_msg_kexdh_init{} = Event, State) -> -%% key_exchange(Event, State#state{renegotiate = true}). +connected({#ssh_msg_kexinit{}, _Payload} = Event, #state{ssh_params = Ssh0} = State0) -> + {KeyInitMsg, SshPacket, Ssh} = ssh_transport:key_exchange_init_msg(Ssh0), + State = State0#state{ssh_params = Ssh, + key_exchange_init_msg = KeyInitMsg, + renegotiate = true}, + send_msg(SshPacket, State), + kexinit(Event, State). %%-------------------------------------------------------------------- -spec handle_event(#ssh_msg_disconnect{} | #ssh_msg_ignore{} | #ssh_msg_debug{} | @@ -581,44 +587,17 @@ handle_event(#ssh_msg_disconnect{description = Desc} = DisconnectMsg, _StateName handle_event(#ssh_msg_ignore{}, StateName, State) -> {next_state, StateName, next_packet(State)}; -handle_event(#ssh_msg_debug{always_display = true, message = DbgMsg}, - StateName, State) -> - io:format("DEBUG: ~p\n", [DbgMsg]), - {next_state, StateName, next_packet(State)}; - -handle_event(#ssh_msg_debug{}, StateName, State) -> +handle_event(#ssh_msg_debug{always_display = Display, message = DbgMsg, language=Lang}, + StateName, #state{opts = Opts} = State) -> + F = proplists:get_value(ssh_msg_debug_fun, Opts, + fun(_ConnRef, _AlwaysDisplay, _Msg, _Language) -> ok end + ), + catch F(self(), Display, DbgMsg, Lang), {next_state, StateName, next_packet(State)}; handle_event(#ssh_msg_unimplemented{}, StateName, State) -> {next_state, StateName, next_packet(State)}; -handle_event({adjust_window, ChannelId, Bytes}, StateName, - #state{connection_state = - #connection{channel_cache = Cache}} = State0) -> - State = - case ssh_channel:cache_lookup(Cache, ChannelId) of - #channel{recv_window_size = WinSize, remote_id = Id} = Channel -> - ssh_channel:cache_update(Cache, Channel#channel{recv_window_size = - WinSize + Bytes}), - Msg = ssh_connection:channel_adjust_window_msg(Id, Bytes), - send_replies([{connection_reply, Msg}], State0); - undefined -> - State0 - end, - {next_state, StateName, next_packet(State)}; - -handle_event({reply_request, success, ChannelId}, StateName, - #state{connection_state = - #connection{channel_cache = Cache}} = State0) -> - State = case ssh_channel:cache_lookup(Cache, ChannelId) of - #channel{remote_id = RemoteId} -> - Msg = ssh_connection:channel_success_msg(RemoteId), - send_replies([{connection_reply, Msg}], State0); - undefined -> - State0 - end, - {next_state, StateName, State}; - handle_event(renegotiate, connected, #state{ssh_params = Ssh0} = State) -> {KeyInitMsg, SshPacket, Ssh} = ssh_transport:key_exchange_init_msg(Ssh0), @@ -630,8 +609,7 @@ handle_event(renegotiate, connected, #state{ssh_params = Ssh0} renegotiate = true})}; handle_event(renegotiate, StateName, State) -> - timer:apply_after(?REKEY_TIMOUT, gen_fsm, send_all_state_event, [self(), renegotiate]), - %% Allready in keyexcahange so ignore + %% Already in key-exchange so safe to ignore {next_state, StateName, State}; %% Rekey due to sent data limit reached? @@ -653,6 +631,38 @@ handle_event(data_size, connected, #state{ssh_params = Ssh0} = State) -> {next_state, connected, next_packet(State)} end; handle_event(data_size, StateName, State) -> + %% Already in key-exchange so safe to ignore + {next_state, StateName, State}; + +handle_event(Event, StateName, State) when StateName /= connected -> + Events = [{event, Event} | State#state.event_queue], + {next_state, StateName, State#state{event_queue = Events}}; + +handle_event({adjust_window, ChannelId, Bytes}, StateName, + #state{connection_state = + #connection{channel_cache = Cache}} = State0) -> + State = + case ssh_channel:cache_lookup(Cache, ChannelId) of + #channel{recv_window_size = WinSize, remote_id = Id} = Channel -> + ssh_channel:cache_update(Cache, Channel#channel{recv_window_size = + WinSize + Bytes}), + Msg = ssh_connection:channel_adjust_window_msg(Id, Bytes), + send_replies([{connection_reply, Msg}], State0); + undefined -> + State0 + end, + {next_state, StateName, next_packet(State)}; + +handle_event({reply_request, success, ChannelId}, StateName, + #state{connection_state = + #connection{channel_cache = Cache}} = State0) -> + State = case ssh_channel:cache_lookup(Cache, ChannelId) of + #channel{remote_id = RemoteId} -> + Msg = ssh_connection:channel_success_msg(RemoteId), + send_replies([{connection_reply, Msg}], State0); + undefined -> + State0 + end, {next_state, StateName, State}; handle_event({request, ChannelPid, ChannelId, Type, Data}, StateName, State0) -> @@ -683,8 +693,65 @@ handle_event({unknown, Data}, StateName, State) -> sockname]} | {channel_info, channel_id(), [recv_window | send_window]} | {close, channel_id()} | stop, term(), state_name(), #state{}) - -> gen_fsm_state_return(). + -> gen_fsm_sync_return(). %%-------------------------------------------------------------------- +handle_sync_event(get_print_info, _From, StateName, State) -> + Reply = + try + {inet:sockname(State#state.socket), + inet:peername(State#state.socket) + } + of + {{ok,Local}, {ok,Remote}} -> {{Local,Remote},io_lib:format("statename=~p",[StateName])}; + _ -> {{"-",0},"-"} + catch + _:_ -> {{"?",0},"?"} + end, + {reply, Reply, StateName, State}; + +handle_sync_event({connection_info, Options}, _From, StateName, State) -> + Info = ssh_info(Options, State, []), + {reply, Info, StateName, State}; + +handle_sync_event({channel_info, ChannelId, Options}, _From, StateName, + #state{connection_state = #connection{channel_cache = Cache}} = State) -> + case ssh_channel:cache_lookup(Cache, ChannelId) of + #channel{} = Channel -> + Info = ssh_channel_info(Options, Channel, []), + {reply, Info, StateName, State}; + undefined -> + {reply, [], StateName, State} + end; + +handle_sync_event({info, ChannelPid}, _From, StateName, + #state{connection_state = + #connection{channel_cache = Cache}} = State) -> + Result = ssh_channel:cache_foldl( + fun(Channel, Acc) when ChannelPid == all; + Channel#channel.user == ChannelPid -> + [Channel | Acc]; + (_, Acc) -> + Acc + end, [], Cache), + {reply, {ok, Result}, StateName, State}; + +handle_sync_event(stop, _, _StateName, #state{connection_state = Connection0, + role = Role, + opts = Opts} = State0) -> + {disconnect, Reason, {{replies, Replies}, Connection}} = + ssh_connection:handle_msg(#ssh_msg_disconnect{code = ?SSH_DISCONNECT_BY_APPLICATION, + description = "User closed down connection", + language = "en"}, Connection0, Role), + State = send_replies(Replies, State0), + SSHOpts = proplists:get_value(ssh_opts, Opts), + disconnect_fun(Reason, SSHOpts), + {stop, normal, ok, State#state{connection_state = Connection}}; + + +handle_sync_event(Event, From, StateName, State) when StateName /= connected -> + Events = [{sync, Event, From} | State#state.event_queue], + {next_state, StateName, State#state{event_queue = Events}}; + handle_sync_event({request, ChannelPid, ChannelId, Type, Data, Timeout}, From, StateName, State0) -> {{replies, Replies}, State1} = handle_request(ChannelPid, ChannelId, Type, Data, @@ -787,46 +854,6 @@ handle_sync_event({recv_window, ChannelId}, _From, StateName, end, {reply, Reply, StateName, next_packet(State)}; -handle_sync_event(get_print_info, _From, StateName, State) -> - Reply = - try - {inet:sockname(State#state.socket), - inet:peername(State#state.socket) - } - of - {{ok,Local}, {ok,Remote}} -> {{Local,Remote},io_lib:format("statename=~p",[StateName])}; - _ -> {{"-",0},"-"} - catch - _:_ -> {{"?",0},"?"} - end, - {reply, Reply, StateName, State}; - -handle_sync_event({connection_info, Options}, _From, StateName, State) -> - Info = ssh_info(Options, State, []), - {reply, Info, StateName, State}; - -handle_sync_event({channel_info, ChannelId, Options}, _From, StateName, - #state{connection_state = #connection{channel_cache = Cache}} = State) -> - case ssh_channel:cache_lookup(Cache, ChannelId) of - #channel{} = Channel -> - Info = ssh_channel_info(Options, Channel, []), - {reply, Info, StateName, State}; - undefined -> - {reply, [], StateName, State} - end; - -handle_sync_event({info, ChannelPid}, _From, StateName, - #state{connection_state = - #connection{channel_cache = Cache}} = State) -> - Result = ssh_channel:cache_foldl( - fun(Channel, Acc) when ChannelPid == all; - Channel#channel.user == ChannelPid -> - [Channel | Acc]; - (_, Acc) -> - Acc - end, [], Cache), - {reply, {ok, Result}, StateName, State}; - handle_sync_event({close, ChannelId}, _, StateName, #state{connection_state = #connection{channel_cache = Cache}} = State0) -> @@ -841,19 +868,7 @@ handle_sync_event({close, ChannelId}, _, StateName, undefined -> State0 end, - {reply, ok, StateName, next_packet(State)}; - -handle_sync_event(stop, _, _StateName, #state{connection_state = Connection0, - role = Role, - opts = Opts} = State0) -> - {disconnect, Reason, {{replies, Replies}, Connection}} = - ssh_connection:handle_msg(#ssh_msg_disconnect{code = ?SSH_DISCONNECT_BY_APPLICATION, - description = "User closed down connection", - language = "en"}, Connection0, Role), - State = send_replies(Replies, State0), - SSHOpts = proplists:get_value(ssh_opts, Opts), - disconnect_fun(Reason, SSHOpts), - {stop, normal, ok, State#state{connection_state = Connection}}. + {reply, ok, StateName, next_packet(State)}. %%-------------------------------------------------------------------- -spec handle_info({atom(), port(), binary()} | {atom(), port()} | @@ -1282,8 +1297,17 @@ generate_event(<<?BYTE(Byte), _/binary>> = Msg, StateName, ConnectionMsg = ssh_message:decode(Msg), State1 = generate_event_new_state(State0, EncData), try ssh_connection:handle_msg(ConnectionMsg, Connection0, Role) of - {{replies, Replies}, Connection} -> - State = send_replies(Replies, State1#state{connection_state = Connection}), + {{replies, Replies0}, Connection} -> + if StateName == connected -> + Replies = Replies0, + State2 = State1; + true -> + {ConnReplies, Replies} = + lists:splitwith(fun not_connected_filter/1, Replies0), + Q = State1#state.event_queue ++ ConnReplies, + State2 = State1#state{ event_queue = Q } + end, + State = send_replies(Replies, State2#state{connection_state = Connection}), {next_state, StateName, next_packet(State)}; {noreply, Connection} -> {next_state, StateName, next_packet(State1#state{connection_state = Connection})}; @@ -1456,15 +1480,43 @@ next_packet(#state{socket = Socket} = State) -> State. after_new_keys(#state{renegotiate = true} = State) -> - {connected, State#state{renegotiate = false}}; + State1 = State#state{renegotiate = false, event_queue = []}, + lists:foldr(fun after_new_keys_events/2, {next_state, connected, State1}, State#state.event_queue); after_new_keys(#state{renegotiate = false, ssh_params = #ssh{role = client} = Ssh0} = State) -> {Msg, Ssh} = ssh_auth:service_request_msg(Ssh0), send_msg(Msg, State), - {userauth, State#state{ssh_params = Ssh}}; + {next_state, userauth, State#state{ssh_params = Ssh}}; after_new_keys(#state{renegotiate = false, ssh_params = #ssh{role = server}} = State) -> - {userauth, State}. + {next_state, userauth, State}. + +after_new_keys_events({sync, _Event, From}, {stop, _Reason, _StateData}=Terminator) -> + gen_fsm:reply(From, {error, closed}), + Terminator; +after_new_keys_events(_, {stop, _Reason, _StateData}=Terminator) -> + Terminator; +after_new_keys_events({sync, Event, From}, {next_state, StateName, StateData}) -> + case handle_sync_event(Event, From, StateName, StateData) of + {reply, Reply, NextStateName, NewStateData} -> + gen_fsm:reply(From, Reply), + {next_state, NextStateName, NewStateData}; + {next_state, NextStateName, NewStateData}-> + {next_state, NextStateName, NewStateData}; + {stop, Reason, Reply, NewStateData} -> + gen_fsm:reply(From, Reply), + {stop, Reason, NewStateData} + end; +after_new_keys_events({event, Event}, {next_state, StateName, StateData}) -> + case handle_event(Event, StateName, StateData) of + {next_state, NextStateName, NewStateData}-> + {next_state, NextStateName, NewStateData}; + {stop, Reason, NewStateData} -> + {stop, Reason, NewStateData} + end; +after_new_keys_events({connection_reply, _Data} = Reply, {StateName, State}) -> + NewState = send_replies([Reply], State), + {next_state, StateName, NewState}. handle_ssh_packet_data(RemainingSshPacketLen, DecData, EncData, StateName, State) -> @@ -1625,6 +1677,11 @@ log_error(Reason) -> error_logger:error_report(Report), "Internal error". +not_connected_filter({connection_reply, _Data}) -> + true; +not_connected_filter(_) -> + false. + send_replies([], State) -> State; send_replies([{connection_reply, Data} | Rest], #state{ssh_params = Ssh0} = State) -> diff --git a/lib/ssh/test/Makefile b/lib/ssh/test/Makefile index 740dbd0235..39b2f57d26 100644 --- a/lib/ssh/test/Makefile +++ b/lib/ssh/test/Makefile @@ -40,7 +40,8 @@ MODULES= \ ssh_connection_SUITE \ ssh_echo_server \ ssh_peername_sockname_server \ - ssh_test_cli + ssh_test_cli \ + ssh_relay HRL_FILES_NEEDED_IN_TEST= \ $(ERL_TOP)/lib/ssh/src/ssh.hrl \ diff --git a/lib/ssh/test/ssh_basic_SUITE.erl b/lib/ssh/test/ssh_basic_SUITE.erl index bd029ad420..aaf0fa9905 100644 --- a/lib/ssh/test/ssh_basic_SUITE.erl +++ b/lib/ssh/test/ssh_basic_SUITE.erl @@ -29,6 +29,7 @@ -define(NEWLINE, <<"\r\n">>). +-define(REKEY_DATA_TMO, 65000). %%-------------------------------------------------------------------- %% Common Test interface functions ----------------------------------- %%-------------------------------------------------------------------- @@ -44,6 +45,7 @@ all() -> {group, dsa_pass_key}, {group, rsa_pass_key}, {group, internal_error}, + {group, renegotiate}, daemon_already_started, server_password_option, server_userpassword_option, @@ -52,6 +54,8 @@ all() -> ssh_connect_arg4_timeout, packet_size_zero, ssh_daemon_minimal_remote_max_packet_size_option, + ssh_msg_debug_fun_option_client, + ssh_msg_debug_fun_option_server, id_string_no_opt_client, id_string_own_string_client, id_string_random_client, @@ -67,6 +71,7 @@ groups() -> {dsa_pass_key, [], [pass_phrase]}, {rsa_pass_key, [], [pass_phrase]}, {internal_error, [], [internal_error]}, + {renegotiate, [], [rekey, rekey_limit, renegotiate1, renegotiate2]}, {hardening_tests, [], [ssh_connect_nonegtimeout_connected_parallel, ssh_connect_nonegtimeout_connected_sequential, ssh_connect_negtimeout_parallel, @@ -82,8 +87,7 @@ groups() -> basic_tests() -> [send, close, peername_sockname, exec, exec_compressed, shell, cli, known_hosts, - idle_time, rekey, openssh_zlib_basic_test, - misc_ssh_options, inet_option]. + idle_time, openssh_zlib_basic_test, misc_ssh_options, inet_option]. %%-------------------------------------------------------------------- @@ -331,25 +335,175 @@ idle_time(Config) -> rekey() -> [{doc, "Idle timeout test"}]. rekey(Config) -> - SystemDir = filename:join(?config(priv_dir, Config), system), + SystemDir = ?config(data_dir, Config), UserDir = ?config(priv_dir, Config), {Pid, Host, Port} = ssh_test_lib:daemon([{system_dir, SystemDir}, - {user_dir, UserDir}, + {user_dir, UserDir}, {failfun, fun ssh_test_lib:failfun/2}, + {user_passwords, + [{"simon", "says"}]}, {rekey_limit, 0}]), + ConnectionRef = ssh_test_lib:connect(Host, Port, [{silently_accept_hosts, true}, {user_dir, UserDir}, + {user, "simon"}, + {password, "says"}, {user_interaction, false}, {rekey_limit, 0}]), receive - after 200000 -> + after ?REKEY_DATA_TMO -> %%By this time rekeying would have been done ssh:close(ConnectionRef), ssh:stop_daemon(Pid) end. %%-------------------------------------------------------------------- +rekey_limit() -> + [{doc, "Test rekeying by data volume"}]. +rekey_limit(Config) -> + SystemDir = ?config(data_dir, Config), + UserDir = ?config(priv_dir, Config), + DataFile = filename:join(UserDir, "rekey.data"), + + {Pid, Host, Port} = ssh_test_lib:daemon([{system_dir, SystemDir}, + {user_dir, UserDir}, + {user_passwords, + [{"simon", "says"}]}]), + {ok, SftpPid, ConnectionRef} = + ssh_sftp:start_channel(Host, Port, [{system_dir, SystemDir}, + {user_dir, UserDir}, + {user, "simon"}, + {password, "says"}, + {rekey_limit, 2500}, + {user_interaction, false}, + {silently_accept_hosts, true}]), + + Kex1 = get_kex_init(ConnectionRef), + + ct:sleep(?REKEY_DATA_TMO), + Kex1 = get_kex_init(ConnectionRef), + + Data = lists:duplicate(9000,1), + ok = ssh_sftp:write_file(SftpPid, DataFile, Data), + + ct:sleep(?REKEY_DATA_TMO), + Kex2 = get_kex_init(ConnectionRef), + + false = (Kex2 == Kex1), + + ct:sleep(?REKEY_DATA_TMO), + Kex2 = get_kex_init(ConnectionRef), + + ok = ssh_sftp:write_file(SftpPid, DataFile, "hi\n"), + + ct:sleep(?REKEY_DATA_TMO), + Kex2 = get_kex_init(ConnectionRef), + + false = (Kex2 == Kex1), + + ct:sleep(?REKEY_DATA_TMO), + Kex2 = get_kex_init(ConnectionRef), + + + ssh_sftp:stop_channel(SftpPid), + ssh:close(ConnectionRef), + ssh:stop_daemon(Pid). + +%%-------------------------------------------------------------------- +renegotiate1() -> + [{doc, "Test rekeying with simulataneous send request"}]. +renegotiate1(Config) -> + SystemDir = ?config(data_dir, Config), + UserDir = ?config(priv_dir, Config), + DataFile = filename:join(UserDir, "renegotiate1.data"), + + {Pid, Host, DPort} = ssh_test_lib:daemon([{system_dir, SystemDir}, + {user_dir, UserDir}, + {user_passwords, + [{"simon", "says"}]}]), + RPort = ssh_test_lib:inet_port(), + + {ok,RelayPid} = ssh_relay:start_link({0,0,0,0}, RPort, Host, DPort), + + {ok, SftpPid, ConnectionRef} = + ssh_sftp:start_channel(Host, RPort, [{system_dir, SystemDir}, + {user_dir, UserDir}, + {user, "simon"}, + {password, "says"}, + {user_interaction, false}, + {silently_accept_hosts, true}]), + + Kex1 = 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), + + ct:sleep(2000), + + Kex2 = get_kex_init(ConnectionRef), + + false = (Kex2 == Kex1), + + ssh_relay:stop(RelayPid), + ssh_sftp:stop_channel(SftpPid), + ssh:close(ConnectionRef), + ssh:stop_daemon(Pid). + +%%-------------------------------------------------------------------- +renegotiate2() -> + [{doc, "Test rekeying with inflight messages from peer"}]. +renegotiate2(Config) -> + SystemDir = ?config(data_dir, Config), + UserDir = ?config(priv_dir, Config), + DataFile = filename:join(UserDir, "renegotiate1.data"), + + {Pid, Host, DPort} = ssh_test_lib:daemon([{system_dir, SystemDir}, + {user_dir, UserDir}, + {user_passwords, + [{"simon", "says"}]}]), + RPort = ssh_test_lib:inet_port(), + + {ok,RelayPid} = ssh_relay:start_link({0,0,0,0}, RPort, Host, DPort), + + {ok, SftpPid, ConnectionRef} = + ssh_sftp:start_channel(Host, RPort, [{system_dir, SystemDir}, + {user_dir, UserDir}, + {user, "simon"}, + {password, "says"}, + {user_interaction, false}, + {silently_accept_hosts, true}]), + + Kex1 = 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), + + ct:sleep(2000), + + Kex2 = get_kex_init(ConnectionRef), + + false = (Kex2 == Kex1), + + ssh_relay:stop(RelayPid), + ssh_sftp:stop_channel(SftpPid), + ssh:close(ConnectionRef), + ssh:stop_daemon(Pid). + +%%-------------------------------------------------------------------- shell() -> [{doc, "Test that ssh:shell/2 works"}]. shell(Config) when is_list(Config) -> @@ -494,6 +648,94 @@ server_userpassword_option(Config) when is_list(Config) -> ssh:stop_daemon(Pid). %%-------------------------------------------------------------------- +ssh_msg_debug_fun_option_client() -> + [{doc, "validate client that uses the 'ssh_msg_debug_fun' option"}]. +ssh_msg_debug_fun_option_client(Config) -> + PrivDir = ?config(priv_dir, Config), + UserDir = filename:join(PrivDir, nopubkey), % to make sure we don't use public-key-auth + file:make_dir(UserDir), + SysDir = ?config(data_dir, Config), + + {Pid, Host, Port} = ssh_test_lib:daemon([{system_dir, SysDir}, + {user_dir, UserDir}, + {password, "morot"}, + {failfun, fun ssh_test_lib:failfun/2}]), + Parent = self(), + DbgFun = fun(ConnRef,Displ,Msg,Lang) -> Parent ! {msg_dbg,{ConnRef,Displ,Msg,Lang}} end, + + ConnectionRef = + ssh_test_lib:connect(Host, Port, [{silently_accept_hosts, true}, + {user, "foo"}, + {password, "morot"}, + {user_dir, UserDir}, + {user_interaction, false}, + {ssh_msg_debug_fun,DbgFun}]), + %% Beware, implementation knowledge: + gen_fsm:send_all_state_event(ConnectionRef,{ssh_msg_debug,false,<<"Hello">>,<<>>}), + receive + {msg_dbg,X={ConnectionRef,false,<<"Hello">>,<<>>}} -> + ct:log("Got expected dbg msg ~p",[X]), + ssh:stop_daemon(Pid); + {msg_dbg,X={_,false,<<"Hello">>,<<>>}} -> + ct:log("Got dbg msg but bad ConnectionRef (~p expected) ~p",[ConnectionRef,X]), + ssh:stop_daemon(Pid), + {fail, "Bad ConnectionRef received"}; + {msg_dbg,X} -> + ct:log("Got bad dbg msg ~p",[X]), + ssh:stop_daemon(Pid), + {fail,"Bad msg received"} + after 1000 -> + ssh:stop_daemon(Pid), + {fail,timeout} + end. + +%%-------------------------------------------------------------------- +ssh_msg_debug_fun_option_server() -> + [{doc, "validate client that uses the 'ssh_msg_debug_fun' option"}]. +ssh_msg_debug_fun_option_server(Config) -> + PrivDir = ?config(priv_dir, Config), + UserDir = filename:join(PrivDir, nopubkey), % to make sure we don't use public-key-auth + file:make_dir(UserDir), + SysDir = ?config(data_dir, Config), + + Parent = self(), + DbgFun = fun(ConnRef,Displ,Msg,Lang) -> Parent ! {msg_dbg,{ConnRef,Displ,Msg,Lang}} end, + ConnFun = fun(_,_,_) -> Parent ! {connection_pid,self()} end, + + {Pid, Host, Port} = ssh_test_lib:daemon([{system_dir, SysDir}, + {user_dir, UserDir}, + {password, "morot"}, + {failfun, fun ssh_test_lib:failfun/2}, + {connectfun, ConnFun}, + {ssh_msg_debug_fun, DbgFun}]), + _ConnectionRef = + ssh_test_lib:connect(Host, Port, [{silently_accept_hosts, true}, + {user, "foo"}, + {password, "morot"}, + {user_dir, UserDir}, + {user_interaction, false}]), + receive + {connection_pid,Server} -> + %% Beware, implementation knowledge: + gen_fsm:send_all_state_event(Server,{ssh_msg_debug,false,<<"Hello">>,<<>>}), + receive + {msg_dbg,X={_,false,<<"Hello">>,<<>>}} -> + ct:log("Got expected dbg msg ~p",[X]), + ssh:stop_daemon(Pid); + {msg_dbg,X} -> + ct:log("Got bad dbg msg ~p",[X]), + ssh:stop_daemon(Pid), + {fail,"Bad msg received"} + after 3000 -> + ssh:stop_daemon(Pid), + {fail,timeout2} + end + after 3000 -> + ssh:stop_daemon(Pid), + {fail,timeout1} + end. + +%%-------------------------------------------------------------------- known_hosts() -> [{doc, "check that known_hosts is updated correctly"}]. known_hosts(Config) when is_list(Config) -> @@ -823,56 +1065,62 @@ ssh_daemon_minimal_remote_max_packet_size_option(Config) -> %%-------------------------------------------------------------------- id_string_no_opt_client(Config) -> - {Server, Host, Port} = fake_daemon(Config), - {error,_} = ssh:connect(Host, Port, []), + {Server, _Host, Port} = fake_daemon(Config), + {error,_} = ssh:connect("localhost", Port, [], 1000), receive {id,Server,"SSH-2.0-Erlang/"++Vsn} -> true = expected_ssh_vsn(Vsn); {id,Server,Other} -> ct:fail("Unexpected id: ~s.",[Other]) + after 5000 -> + {fail,timeout} end. %%-------------------------------------------------------------------- id_string_own_string_client(Config) -> - {Server, Host, Port} = fake_daemon(Config), - {error,_} = ssh:connect(Host, Port, [{id_string,"Pelle"}]), + {Server, _Host, Port} = fake_daemon(Config), + {error,_} = ssh:connect("localhost", Port, [{id_string,"Pelle"}], 1000), receive {id,Server,"SSH-2.0-Pelle\r\n"} -> ok; {id,Server,Other} -> ct:fail("Unexpected id: ~s.",[Other]) + after 5000 -> + {fail,timeout} end. %%-------------------------------------------------------------------- id_string_random_client(Config) -> - {Server, Host, Port} = fake_daemon(Config), - {error,_} = ssh:connect(Host, Port, [{id_string,random}]), + {Server, _Host, Port} = fake_daemon(Config), + {error,_} = ssh:connect("localhost", Port, [{id_string,random}], 1000), receive {id,Server,Id="SSH-2.0-Erlang"++_} -> ct:fail("Unexpected id: ~s.",[Id]); {id,Server,Rnd="SSH-2.0-"++_} -> - ct:log("Got ~s.",[Rnd]); + ct:log("Got correct ~s",[Rnd]); {id,Server,Id} -> ct:fail("Unexpected id: ~s.",[Id]) + after 5000 -> + {fail,timeout} end. %%-------------------------------------------------------------------- id_string_no_opt_server(Config) -> {_Server, Host, Port} = std_daemon(Config, []), - {ok,S1}=gen_tcp:connect(Host,Port,[{active,false}]), + {ok,S1}=gen_tcp:connect(Host,Port,[{active,false},{packet,line}]), {ok,"SSH-2.0-Erlang/"++Vsn} = gen_tcp:recv(S1, 0, 2000), true = expected_ssh_vsn(Vsn). %%-------------------------------------------------------------------- id_string_own_string_server(Config) -> {_Server, Host, Port} = std_daemon(Config, [{id_string,"Olle"}]), - {ok,S1}=gen_tcp:connect(Host,Port,[{active,false}]), + {ok,S1}=gen_tcp:connect(Host,Port,[{active,false},{packet,line}]), {ok,"SSH-2.0-Olle\r\n"} = gen_tcp:recv(S1, 0, 2000). %%-------------------------------------------------------------------- id_string_random_server(Config) -> {_Server, Host, Port} = std_daemon(Config, [{id_string,random}]), - {ok,S1}=gen_tcp:connect(Host,Port,[{active,false}]), + {ok,S1}=gen_tcp:connect(Host,Port,[{active,false},{packet,line}]), {ok,"SSH-2.0-"++Rnd} = gen_tcp:recv(S1, 0, 2000), case Rnd of "Erlang"++_ -> ct:log("Id=~p",[Rnd]), @@ -1183,13 +1431,14 @@ expected_ssh_vsn(Str) -> _:_ -> true %% ssh not started so we dont't know end. - + fake_daemon(_Config) -> Parent = self(), %% start the server Server = spawn(fun() -> - {ok,Sl} = gen_tcp:listen(0,[]), + {ok,Sl} = gen_tcp:listen(0,[{packet,line}]), {ok,{Host,Port}} = inet:sockname(Sl), + ct:log("fake_daemon listening on ~p:~p~n",[Host,Port]), Parent ! {sockname,self(),Host,Port}, Rsa = gen_tcp:accept(Sl), ct:log("Server gen_tcp:accept got ~p",[Rsa]), @@ -1203,3 +1452,18 @@ fake_daemon(_Config) -> {sockname,Server,ServerHost,ServerPort} -> {Server, ServerHost, ServerPort} end. +%% get_kex_init - helper function to get key_exchange_init_msg +get_kex_init(Conn) -> + %% First, validate the key exchange is complete (StateName == connected) + {connected,S} = sys:get_state(Conn), + %% Next, walk through the elements of the #state record looking + %% for the #ssh_msg_kexinit record. This method is robust against + %% changes to either record. The KEXINIT message contains a cookie + %% unique to each invocation of the key exchange procedure (RFC4253) + SL = tuple_to_list(S), + case lists:keyfind(ssh_msg_kexinit, 1, SL) of + false -> + throw(not_found); + KexInit -> + KexInit + end. diff --git a/lib/ssh/test/ssh_connection_SUITE.erl b/lib/ssh/test/ssh_connection_SUITE.erl index 6fc09876ad..db51f65509 100644 --- a/lib/ssh/test/ssh_connection_SUITE.erl +++ b/lib/ssh/test/ssh_connection_SUITE.erl @@ -271,7 +271,7 @@ ptty_alloc(Config) when is_list(Config) -> {user_interaction, false}]), {ok, ChannelId} = ssh_connection:session_channel(ConnectionRef, infinity), success = ssh_connection:ptty_alloc(ConnectionRef, ChannelId, - [{term, os:getenv("TERM", ?DEFAULT_TERMINAL)}, {width, 70}, {high, 20}]), + [{term, os:getenv("TERM", ?DEFAULT_TERMINAL)}, {width, 70}, {height, 20}]), ssh:close(ConnectionRef). diff --git a/lib/ssh/test/ssh_relay.erl b/lib/ssh/test/ssh_relay.erl new file mode 100644 index 0000000000..a4f2bad2e2 --- /dev/null +++ b/lib/ssh/test/ssh_relay.erl @@ -0,0 +1,407 @@ +%%%------------------------------------------------------------------- +%%% @author Simon Cornish <[email protected]> +%%% @copyright (C) 2015, Simon Cornish +%%% @doc +%%% Provide manipulatable TCP-level relaying for testing SSH +%%% @end +%%% Created : 7 May 2015 by Simon Cornish <[email protected]> +%%%------------------------------------------------------------------- +-module(ssh_relay). + +-behaviour(gen_server). + +%% API +-export([start_link/4]). +-export([stop/1]). +-export([hold/4, release/2, release_next/3]). + +%% gen_server callbacks +-export([init/1, handle_call/3, handle_cast/2, handle_info/2, + terminate/2, code_change/3]). + +-record(hold, { + port, + n, + tmo, + tref, + q = [] + }). + +-record(state, { + local_addr, + local_port, + peer_addr, + peer_port, + lpid, + local, + peer, + tx_hold, + rx_hold + }). + +-define(ACCEPT_TMO, 200). +%%%=================================================================== +%%% API +%%%=================================================================== +%%-------------------------------------------------------------------- +%% @doc +%% Hold N (or 'all') messages in given direction. +%% Messages will be released after the N+1th message or +%% Tmo ms or 'infinity' +%% +%% Dir is 'tx' for direction local -> peer +%% and 'rx' for direction peer -> local +%% +%% An Error, ealready, is returned if there is already a hold +%% in the given direction +%% +%% @spec hold(Srv, Dir, N, Tmo) -> ok | {error, Error} +%% @end +%%-------------------------------------------------------------------- +hold(Srv, Dir, N, Tmo) -> + gen_server:call(Srv, {hold, Dir, N, Tmo}). + +%%-------------------------------------------------------------------- +%% @doc +%% Release all held messages in given direction. +%% +%% An Error, enoent, is returned if there is no hold +%% in the given direction +%% +%% @spec release(Srv, Dir) -> ok | {error, Error} +%% @end +%%-------------------------------------------------------------------- +release(Srv, Dir) -> + gen_server:call(Srv, {release, Dir}). + +%%-------------------------------------------------------------------- +%% @doc +%% Release all held messages in given direction after the +%% next message in the trigger direction +%% +%% An Error, enoent, is returned if there is no hold +%% in the given direction +%% +%% @spec release_next(Srv, Dir, TriggerDir) -> ok | {error, Error} +%% @end +%%-------------------------------------------------------------------- +release_next(Srv, Dir, TriggerDir) -> + gen_server:call(Srv, {release_next, Dir, TriggerDir}). + +%%-------------------------------------------------------------------- +%% @doc +%% Starts the server +%% +%% @spec start_link() -> {ok, Pid} | ignore | {error, Error} +%% @end +%%-------------------------------------------------------------------- +start_link(ListenAddr, ListenPort, PeerAddr, PeerPort) -> + gen_server:start_link(?MODULE, [ListenAddr, ListenPort, PeerAddr, PeerPort], []). + +stop(Srv) -> + unlink(Srv), + Srv ! stop. + +%%%=================================================================== +%%% gen_server callbacks +%%%=================================================================== + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% Initializes the server +%% +%% @spec init(Args) -> {ok, State} | +%% {ok, State, Timeout} | +%% ignore | +%% {stop, Reason} +%% @end +%%-------------------------------------------------------------------- +init([ListenAddr, ListenPort, PeerAddr, PeerPort | Options]) -> + IfAddr = case ListenAddr of + {0,0,0,0} -> + []; + _ -> + [{ifaddr, ListenAddr}] + end, + case gen_tcp:listen(ListenPort, [{reuseaddr, true}, {backlog, 1}, {active, false}, binary | IfAddr]) of + {ok, LSock} -> + Parent = self(), + {LPid, _LMod} = spawn_monitor(fun() -> listen(Parent, LSock) end), + S = #state{local_addr = ListenAddr, + local_port = ListenPort, + lpid = LPid, + peer_addr = PeerAddr, + peer_port = PeerPort + }, + {ok, S}; + Error -> + {stop, Error} + end. + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% Handling call messages +%% +%% @spec handle_call(Request, From, State) -> +%% {reply, Reply, State} | +%% {reply, Reply, State, Timeout} | +%% {noreply, State} | +%% {noreply, State, Timeout} | +%% {stop, Reason, Reply, State} | +%% {stop, Reason, State} +%% @end +%%-------------------------------------------------------------------- +handle_call({hold, Dir, N, Tmo}, _From, State) -> + case Dir of + tx -> + do_hold(#state.tx_hold, State#state.peer, N, Tmo, State); + rx -> + do_hold(#state.rx_hold, State#state.local, N, Tmo, State); + _ -> + {reply, {error, einval}, State} + end; +handle_call({release, Dir}, _From, State) -> + case Dir of + tx -> + do_release(#state.tx_hold, State); + rx -> + do_release(#state.rx_hold, State); + _ -> + {reply, {error, einval}, State} + end; +handle_call({release_next, _Dir, _TriggerDir}, _From, State) -> + {reply, {error, nyi}, State}; + +handle_call(Request, _From, State) -> + Reply = {unhandled, Request}, + {reply, Reply, State}. + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% Handling cast messages +%% +%% @spec handle_cast(Msg, State) -> {noreply, State} | +%% {noreply, State, Timeout} | +%% {stop, Reason, State} +%% @end +%%-------------------------------------------------------------------- +handle_cast(_Msg, State) -> + {noreply, State}. + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% Handling all non call/cast messages +%% +%% @spec handle_info(Info, State) -> {noreply, State} | +%% {noreply, State, Timeout} | +%% {stop, Reason, State} +%% @end +%%-------------------------------------------------------------------- +handle_info({tcp, Local, Data}, S) when S#state.local == Local -> + S1 = do_local(Data, S), + {noreply, S1}; + +handle_info({tcp_error, Local, Error}, S) when S#state.local == Local -> + S1 = do_local({error, Error}, S), + {noreply, S1}; + +handle_info({tcp_closed, Local}, S) when S#state.local == Local -> + S1 = do_local(closed, S), + {noreply, S1}; + +handle_info({tcp, Peer, Data}, S) when S#state.peer == Peer -> + S1 = do_peer(Data, S), + {noreply, S1}; + +handle_info({tcp_error, Peer, Error}, S) when S#state.peer == Peer -> + S1 = do_peer({error, Error}, S), + {noreply, S1}; + +handle_info({tcp_closed, Peer}, S) when S#state.peer == Peer -> + S1 = do_peer(closed, S), + {noreply, S1}; + +handle_info({accept, Local}, S) -> + S1 = do_accept(Local, S), + {noreply, S1}; + +handle_info({activate, Local}, State) -> + inet:setopts(Local, [{active, true}]), + {noreply, State}; + +handle_info({release, Pos}, S) -> + {reply, _, S1} = do_release(Pos,S), + {noreply, S1}; + +handle_info(stop, State) -> + {stop, normal, State}; + +handle_info({'DOWN', _Ref, _process, LPid, Reason}, S) when S#state.lpid == LPid -> + io:format("Acceptor has finished: ~p~n", [Reason]), + {noreply, S}; + +handle_info(_Info, State) -> + io:format("Unhandled info: ~p~n", [_Info]), + {noreply, State}. + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% This function is called by a gen_server when it is about to +%% terminate. It should be the opposite of Module:init/1 and do any +%% necessary cleaning up. When it returns, the gen_server terminates +%% with Reason. The return value is ignored. +%% +%% @spec terminate(Reason, State) -> void() +%% @end +%%-------------------------------------------------------------------- +terminate(_Reason, _State) -> + ok. + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% Convert process state when code is changed +%% +%% @spec code_change(OldVsn, State, Extra) -> {ok, NewState} +%% @end +%%-------------------------------------------------------------------- +code_change(_OldVsn, State, _Extra) -> + {ok, State}. + +%%%=================================================================== +%%% Internal functions +%%%=================================================================== +do_hold(Pos, _Port, _N, _Tmo, S) when element(Pos, S) /= undefined -> + {reply, {error, ealready}, S}; +do_hold(Pos, Port, N, Tmo, S) -> + TRef = if is_integer(Tmo) andalso Tmo > 0 -> + erlang:send_after(Tmo, self(), {release, Pos}); + true -> + undefined + end, + Hold = #hold{port = Port, n = N, tmo = Tmo, tref = TRef}, + {reply, ok, setelement(Pos, S, Hold)}. + +do_release(HPos, S) when element(HPos, S) == undefined -> + {reply, {error, enoent}, S}; +do_release(HPos, S) -> + #hold{port = Port, tref = TRef, q = Q} = element(HPos, S), + lists:foreach(fun(M) -> gen_tcp:send(Port, M), erlang:yield() end, Q), + catch erlang:cancel_timer(TRef), + receive + {release, HPos} -> ok + after 0 -> + ok + end, + {reply, ok, setelement(HPos, S, undefined)}. + +listen(Parent, LSock) -> + monitor(process, Parent), + do_listen(Parent, LSock). + +do_listen(Parent, LSock) -> + %% So annoying there is no select-like sematic for this + case gen_tcp:accept(LSock, ?ACCEPT_TMO) of + {ok, Sock} -> + Parent ! {accept, Sock}, + gen_tcp:controlling_process(Sock, Parent), + Parent ! {activate, Sock}, + do_flush(Parent, Sock), + gen_tcp:close(LSock); + {error, timeout} -> + receive + DOWN when element(1, DOWN) == 'DOWN' -> + ok; + stop -> + ok + after 1 -> + do_listen(Parent, LSock) + end; + Error -> + gen_tcp:close(LSock), + exit({accept,Error}) + end. + +do_flush(Parent, Sock) -> + receive + {Tcp, Sock, _} = Msg when Tcp == tcp; Tcp == tcp_error -> + Parent ! Msg, + do_flush(Parent, Sock); + {tcp_closed, Sock} = Msg -> + Parent ! Msg, + do_flush(Parent, Sock) + after 1 -> + ok + end. + +do_accept(Local, S) -> + case gen_tcp:connect(S#state.peer_addr, S#state.peer_port, [{active, true}, binary]) of + {ok, Peer} -> + S#state{local = Local, peer = Peer}; + Error -> + exit({connect, Error}) + end. + +do_local(Data, S) when is_binary(Data) -> + TxH = S#state.tx_hold, + if TxH == undefined -> + gen_tcp:send(S#state.peer, Data), + S; + TxH#hold.n == 0 -> + lists:foreach(fun(M) -> gen_tcp:send(S#state.peer, M) end, TxH#hold.q), + gen_tcp:send(S#state.peer, Data), + catch erlang:cancel_timer(TxH#hold.tref), + TxP = #state.tx_hold, + receive + {release, TxP} -> + ok + after 0 -> + ok + end, + S#state{tx_hold = undefined}; + true -> + Q = TxH#hold.q ++ [Data], + N = if is_integer(TxH#hold.n) -> + TxH#hold.n -1; + true -> + TxH#hold.n + end, + S#state{tx_hold = TxH#hold{q = Q, n = N}} + end; +do_local(Error, _S) -> + exit({local, Error}). + +do_peer(Data, S) when is_binary(Data) -> + RxH = S#state.rx_hold, + if RxH == undefined -> + gen_tcp:send(S#state.local, Data), + S; + RxH#hold.n == 0 -> + lists:foreach(fun(M) -> gen_tcp:send(S#state.local, M) end, RxH#hold.q), + gen_tcp:send(S#state.local, Data), + catch erlang:cancel_timer(RxH#hold.tref), + RxP = #state.rx_hold, + receive + {release, RxP} -> + ok + after 0 -> + ok + end, + S#state{rx_hold = undefined}; + true -> + Q = RxH#hold.q ++ [Data], + N = if is_integer(RxH#hold.n) -> + RxH#hold.n -1; + true -> + RxH#hold.n + end, + S#state{rx_hold = RxH#hold{q = Q, n = N}} + end; +do_peer(Error, _S) -> + exit({peer, Error}). + diff --git a/lib/ssl/doc/src/ssl.xml b/lib/ssl/doc/src/ssl.xml index cdf6870c25..18d98e5efb 100644 --- a/lib/ssl/doc/src/ssl.xml +++ b/lib/ssl/doc/src/ssl.xml @@ -67,15 +67,15 @@ <taglist> - <tag><c>boolean()</c></tag> - <item><p><c>= true | false</c></p></item> + <tag><c>boolean() =</c></tag> + <item><p><c>true | false</c></p></item> - <tag><c>option()</c></tag> - <item><p><c>= socketoption() | ssloption() | transportoption()</c></p> + <tag><c>option() =</c></tag> + <item><p><c>socketoption() | ssloption() | transportoption()</c></p> </item> - <tag><c>socketoption()</c></tag> - <item><p><c>= proplists:property()</c></p> + <tag><c>socketoption() =</c></tag> + <item><p><c>proplists:property()</c></p> <p>The default socket options are <c>[{mode,list},{packet, 0},{header, 0},{active, true}]</c>.</p> <p>For valid options, see the @@ -83,32 +83,37 @@ <seealso marker="kernel:gen_tcp">gen_tcp(3)</seealso> manual pages in Kernel.</p></item> - <tag><marker id="type-ssloption"></marker><c>ssloption()</c></tag> - <item><p><c>= {verify, verify_type()}</c></p> - <p><c>| {verify_fun, {fun(), term()}}</c></p> - <p><c>| {fail_if_no_peer_cert, boolean()} {depth, integer()}</c></p> - <p><c>| {cert, public_key:der_encoded()}</c></p> - <p><c>| {certfile, path()}</c></p> - <p><c>| {key, {'RSAPrivateKey'| 'DSAPrivateKey' | 'ECPrivateKey' - | 'PrivateKeyInfo', public_key:der_encoded()}}</c></p> - <p><c>| {keyfile, path()}</c></p> - <p><c>| {password, string()}</c></p> - <p><c>| {cacerts, [public_key:der_encoded()]}</c></p> - <p><c>| {cacertfile, path()}</c></p> - <p><c>| {dh, public_key:der_encoded()}</c></p> - <p><c>| {dhfile, path()}</c></p> - <p><c>| {ciphers, ciphers()}</c></p> - <p><c>| {user_lookup_fun, {fun(), term()}}, {psk_identity, string()}, - {srp_identity, {string(), string()}}</c></p> - <p><c>| {reuse_sessions, boolean()}</c></p> - <p><c>| {reuse_session, fun()} {next_protocols_advertised, [binary()]}</c></p> - <p><c>| {client_preferred_next_protocols, {client | server, - [binary()]} | {client | server, [binary()], binary()}}</c></p> - <p><c>| {log_alert, boolean()}</c></p> - <p><c>| {server_name_indication, hostname() | disable}</c></p></item> - - <tag><c>transportoption()</c></tag> - <item><p><c>= {cb_info, {CallbackModule::atom(), DataTag::atom(), + <tag><marker id="type-ssloption"></marker><c>ssloption() =</c></tag> + <item> + <p><c>{verify, verify_type()}</c></p> + <p><c>| {verify_fun, {fun(), term()}}</c></p> + <p><c>| {fail_if_no_peer_cert, boolean()} {depth, integer()}</c></p> + <p><c>| {cert, public_key:der_encoded()}</c></p> + <p><c>| {certfile, path()}</c></p> + <p><c>| {key, {'RSAPrivateKey'| 'DSAPrivateKey' | 'ECPrivateKey' + | 'PrivateKeyInfo', public_key:der_encoded()}}</c></p> + <p><c>| {keyfile, path()}</c></p> + <p><c>| {password, string()}</c></p> + <p><c>| {cacerts, [public_key:der_encoded()]}</c></p> + <p><c>| {cacertfile, path()}</c></p> + <p><c>| {dh, public_key:der_encoded()}</c></p> + <p><c>| {dhfile, path()}</c></p> + <p><c>| {ciphers, ciphers()}</c></p> + <p><c>| {user_lookup_fun, {fun(), term()}}, {psk_identity, string()}, + {srp_identity, {string(), string()}}</c></p> + <p><c>| {reuse_sessions, boolean()}</c></p> + <p><c>| {reuse_session, fun()} {next_protocols_advertised, [binary()]}</c></p> + <p><c>| {client_preferred_next_protocols, {client | server, + [binary()]} | {client | server, [binary()], binary()}}</c></p> + <p><c>| {log_alert, boolean()}</c></p> + <p><c>| {server_name_indication, hostname() | disable}</c></p> + <p><c>| {sni_hosts, [{hostname(), ssloptions()}]}</c></p> + <p><c>| {sni_fun, SNIfun::fun()}</c></p> + </item> + + <tag><c>transportoption() =</c></tag> + <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 @@ -118,70 +123,73 @@ The callback <c>gen_tcp</c> is treated specially and calls <c>inet</c> directly.</p> <taglist> - <tag><c>CallbackModule</c></tag> - <item><p><c>= atom()</c></p></item> - <tag><c>DataTag</c></tag> - <item><p><c>= atom()</c></p> + <tag><c>CallbackModule =</c></tag> + <item><p><c>atom()</c></p></item> + <tag><c>DataTag =</c></tag> + <item><p><c>atom()</c></p> <p>Used in socket data message.</p></item> - <tag><c>ClosedTag</c></tag> - <item><p><c>= atom()</c></p> + <tag><c>ClosedTag =</c></tag> + <item><p><c>atom()</c></p> <p>Used in socket close message.</p></item> </taglist> </item> - <tag><c>verify_type()</c></tag> - <item><p><c>= verify_none | verify_peer</c></p></item> + <tag><c>verify_type() =</c></tag> + <item><p><c>verify_none | verify_peer</c></p></item> - <tag><c>path()</c></tag> - <item><p><c>= string()</c></p> + <tag><c>path() =</c></tag> + <item><p><c>string()</c></p> <p>Represents a file path.</p></item> - <tag><c>public_key:der_encoded()</c></tag> - <item><p><c>= binary()</c></p> + <tag><c>public_key:der_encoded() =</c></tag> + <item><p><c>binary()</c></p> <p>ASN.1 DER-encoded entity as an Erlang binary.</p></item> - <tag><c>host()</c></tag> - <item><p><c>= hostname() | ipaddress()</c></p></item> + <tag><c>host() =</c></tag> + <item><p><c>hostname() | ipaddress()</c></p></item> - <tag><c>hostname()</c></tag> - <item><p><c>= string()</c></p></item> + <tag><c>hostname() =</c></tag> + <item><p><c>string()</c></p></item> - <tag><c>ip_address()</c></tag> - <item><p><c>= {N1,N2,N3,N4} % IPv4 | {K1,K2,K3,K4,K5,K6,K7,K8} % IPv6 + <tag><c>ip_address() =</c></tag> + <item><p><c>{N1,N2,N3,N4} % IPv4 | {K1,K2,K3,K4,K5,K6,K7,K8} % IPv6 </c></p></item> - <tag><c>sslsocket()</c></tag> - <item><p>Opaque to the user.</p></item> + <tag><c>sslsocket() =</c></tag> + <item><p>opaque()</p></item> - <tag><c>protocol()</c></tag> - <item><p><c>= sslv3 | tlsv1 | 'tlsv1.1' | 'tlsv1.2'</c></p></item> + <tag><c>protocol() =</c></tag> + <item><p><c>sslv3 | tlsv1 | 'tlsv1.1' | 'tlsv1.2'</c></p></item> - <tag><c>ciphers()</c></tag> + <tag><c>ciphers() =</c></tag> <item><p><c>= [ciphersuite()] | string()</c></p> <p>According to old API.</p></item> - <tag><c>ciphersuite()</c></tag> - <item><p><c>= {key_exchange(), cipher(), hash()}</c></p></item> + <tag><c>ciphersuite() =</c></tag> + <item><p><c>{key_exchange(), cipher(), hash()}</c></p></item> - <tag><c>key_exchange()</c></tag> - <item><p><c>= rsa | dhe_dss | dhe_rsa | dh_anon | psk | dhe_psk + <tag><c>key_exchange()=</c></tag> + <item><p><c>rsa | dhe_dss | dhe_rsa | dh_anon | psk | dhe_psk | rsa_psk | srp_anon | srp_dss | srp_rsa | ecdh_anon | ecdh_ecdsa | ecdhe_ecdsa | ecdh_rsa | ecdhe_rsa</c></p></item> - <tag><c>cipher()</c></tag> - <item><p><c>= rc4_128 | des_cbc | '3des_ede_cbc' + <tag><c>cipher() =</c></tag> + <item><p><c>rc4_128 | des_cbc | '3des_ede_cbc' | aes_128_cbc | aes_256_cbc | aes_128_gcm | aes_256_gcm</c></p></item> - <tag><c>hash()</c></tag> - <item><p><c>= md5 | sha</c></p></item> + <tag><c>hash() =</c></tag> + <item><p><c>md5 | sha</c></p></item> - <tag><c>prf_random()</c></tag> - <item><p><c>= client_random | server_random</c></p></item> + <tag><c>prf_random() =</c></tag> + <item><p><c>client_random | server_random</c></p></item> - <tag><c>srp_param_type()</c></tag> - <item><p><c>= srp_1024 | srp_1536 | srp_2048 | srp_3072 + <tag><c>srp_param_type() =</c></tag> + <item><p><c>srp_1024 | srp_1536 | srp_2048 | srp_3072 | srp_4096 | srp_6144 | srp_8192</c></p></item> + <tag><c>SNIfun::fun()</c></tag> + <item><p><c>= fun(ServerName :: string()) -> ssloptions()</c></p></item> + </taglist> </section> @@ -268,7 +276,7 @@ atom()}} | application. It differentiates between the peer certificate and the CA certificates by using <c>valid_peer</c> or <c>valid</c> as second argument to the verification fun. See the - <seealso marker="public_key:cert_records">public_key User's + <seealso marker="public_key:public_key_records">public_key User's Guide</seealso> for definition of <c>#'OTPCertificate'{}</c> and <c>#'Extension'{}</c>.</p> @@ -364,10 +372,10 @@ marker="public_key:public_key#pkix_path_validation-3">public_key:pkix_path_valid empty argument list. The following arguments may be specified for the internal cache.</p> <taglist> <tag><c>{http, timeout()}</c></tag> - <item> + <item><p> Enables fetching of CRLs specified as http URIs in<seealso - marker="public_key:cert_records"> X509 cerificate extensions.</seealso> - Requires the OTP inets application. + marker="public_key:public_key_records"> X509 cerificate extensions.</seealso> + Requires the OTP inets application.</p> </item> </taglist> </item> @@ -624,7 +632,24 @@ fun(srp, Username :: string(), UserState :: term()) -> selection. If set to <c>false</c> (the default), use the client preference.</p></item> - + <tag><c>{sni_hosts, [{hostname(), ssloptions()}]}</c></tag> + <item><p>If the server receives a SNI (Server Name Indication) from the client + matching a host listed in the <c>sni_hosts</c> option, the speicific options for + that host will override previously specified options. + + The option <c>sni_fun</c>, and <c>sni_hosts</c> are mutually exclusive.</p></item> + + <tag><c>{sni_fun, SNIfun::fun()}</c></tag> + <item><p>If the server receives a SNI (Server Name Indication) from the client, + the given function will be called to retrive <c>ssloptions()</c> for indicated server. + These options will be merged into predefined <c>ssloptions()</c>. + + The function should be defined as: + <c>fun(ServerName :: string()) -> ssloptions()</c> + and can be specified as a fun or as named <c>fun module:function/1</c> + + The option <c>sni_fun</c>, and <c>sni_hosts</c> are mutually exclusive.</p></item> + </taglist> </section> @@ -752,6 +777,45 @@ fun(srp, Username :: string(), UserState :: term()) -> </func> <func> + <name>connection_information(SslSocket) -> + {ok, Info} | {error, Reason} </name> + <fsummary>Returns all the connection information. + </fsummary> + <type> + <v>Info = [InfoTuple]</v> + <v>InfoTuple = {protocol, Protocol} | {cipher_suite, CipherSuite} | {sni_hostname, SNIHostname}</v> + <v>CipherSuite = ciphersuite()</v> + <v>ProtocolVersion = protocol()</v> + <v>SNIHostname = string()</v> + <v>Reason = term()</v> + </type> + <desc><p>Return all the connection information containing negotiated protocol version, cipher suite, and the hostname of SNI extension. + Info will be a proplists containing all the connection information on success, otherwise <c>{error, Reason}</c> will be returned.</p> + </desc> + </func> + + <func> + <name>connection_information(SslSocket, Items) -> + {ok, Info} | {error, Reason} </name> + <fsummary>Returns the requested connection information. + </fsummary> + <type> + <v>Items = [Item]</v> + <v>Item = protocol | cipher_suite | sni_hostname</v> + <v>Info = [InfoTuple]</v> + <v>InfoTuple = {protocol, Protocol} | {cipher_suite, CipherSuite} | {sni_hostname, SNIHostname}</v> + <v>CipherSuite = ciphersuite()</v> + <v>ProtocolVersion = protocol()</v> + <v>SNIHostname = string()</v> + <v>Reason = term()</v> + </type> + <desc><p>Returns the connection information you requested. The connection information you can request contains protocol, cipher_suite, and sni_hostname. + <c>{ok, Info}</c> will be returned if it executes sucessfully. The Info is a proplists containing the information you requested. + Otherwise, <c>{error, Reason}</c> will be returned.</p> + </desc> + </func> + + <func> <name>format_error(Reason) -> string()</name> <fsummary>Returns an error string.</fsummary> <type> diff --git a/lib/ssl/doc/src/ssl_crl_cache_api.xml b/lib/ssl/doc/src/ssl_crl_cache_api.xml index 1d9353a2cc..9230442ae0 100644 --- a/lib/ssl/doc/src/ssl_crl_cache_api.xml +++ b/lib/ssl/doc/src/ssl_crl_cache_api.xml @@ -47,11 +47,11 @@ <taglist> - <tag><c>cache_ref()</c></tag> - <item> = opaque()</item> - <tag><c>dist_point()</c></tag> - <item> = #'DistributionPoint'{} see <seealso - marker="public_key:cert_records"> X509 certificates records</seealso></item> + <tag><c>cache_ref() =</c></tag> + <item>opaque()</item> + <tag><c>dist_point() =</c></tag> + <item><p>#'DistributionPoint'{} see <seealso + marker="public_key:public_key_records"> X509 certificates records</seealso></p></item> </taglist> diff --git a/lib/ssl/doc/src/ssl_session_cache_api.xml b/lib/ssl/doc/src/ssl_session_cache_api.xml index c89d3874a1..28b5f4ce23 100644 --- a/lib/ssl/doc/src/ssl_session_cache_api.xml +++ b/lib/ssl/doc/src/ssl_session_cache_api.xml @@ -40,20 +40,20 @@ <c>ssl_session_cache_api</c>:</p> <taglist> - <tag><c>cache_ref()</c></tag> - <item><p>= <c>opaque()</c></p></item> + <tag><c>cache_ref() =</c></tag> + <item><p><c>opaque()</c></p></item> - <tag><c>key()</c></tag> - <item><p>= <c>{partialkey(), session_id()}</c></p></item> + <tag><c>key() =</c></tag> + <item><p><c>{partialkey(), session_id()}</c></p></item> - <tag><c>partialkey()</c></tag> - <item><p>= <c>opaque()</c></p></item> + <tag><c>partialkey() =</c></tag> + <item><p><c>opaque()</c></p></item> - <tag><c>session_id()</c></tag> - <item><p>= <c>binary()</c></p></item> + <tag><c>session_id() =</c></tag> + <item><p><c>binary()</c></p></item> - <tag><c>session()</c></tag> - <item><p>= <c>opaque()</c></p></item> + <tag><c>session()</c> =</tag> + <item><p><c>opaque()</c></p></item> </taglist> </section> diff --git a/lib/ssl/src/ssl.erl b/lib/ssl/src/ssl.erl index 6461f64c1c..225a9be66f 100644 --- a/lib/ssl/src/ssl.erl +++ b/lib/ssl/src/ssl.erl @@ -38,11 +38,13 @@ %% SSL/TLS protocol handling -export([cipher_suites/0, cipher_suites/1, suite_definition/1, connection_info/1, versions/0, session_info/1, format_error/1, - renegotiate/1, prf/5, negotiated_protocol/1, negotiated_next_protocol/1]). + renegotiate/1, prf/5, negotiated_protocol/1, negotiated_next_protocol/1, + connection_information/1, connection_information/2]). %% Misc --export([random_bytes/1]). +-export([random_bytes/1, handle_options/2]). -deprecated({negotiated_next_protocol, 1, next_major_release}). +-deprecated({connection_info, 1, next_major_release}). -include("ssl_api.hrl"). -include("ssl_internal.hrl"). @@ -286,16 +288,42 @@ controlling_process(#sslsocket{pid = {Listen, is_pid(NewOwner) -> Transport:controlling_process(Listen, NewOwner). + +%%-------------------------------------------------------------------- +-spec connection_information(#sslsocket{}) -> {ok, list()} | {error, reason()}. +%% +%% Description: Return SSL information for the connection +%%-------------------------------------------------------------------- +connection_information(#sslsocket{pid = Pid}) when is_pid(Pid) -> ssl_connection:connection_information(Pid); +connection_information(#sslsocket{pid = {Listen, _}}) when is_port(Listen) -> {error, enotconn}. + + +%%-------------------------------------------------------------------- +-spec connection_information(#sslsocket{}, [atom]) -> {ok, list()} | {error, reason()}. +%% +%% Description: Return SSL information for the connection +%%-------------------------------------------------------------------- +connection_information(#sslsocket{} = SSLSocket, Items) -> + case connection_information(SSLSocket) of + {ok, I} -> + {ok, lists:filter(fun({K, _}) -> lists:foldl(fun(K1, Acc) when K1 =:= K -> Acc + 1; (_, Acc) -> Acc end, 0, Items) > 0 end, I)}; + E -> + E + end. + %%-------------------------------------------------------------------- -spec connection_info(#sslsocket{}) -> {ok, {tls_record:tls_atom_version(), ssl_cipher:erl_cipher_suite()}} | {error, reason()}. %% %% Description: Returns ssl protocol and cipher used for the connection %%-------------------------------------------------------------------- -connection_info(#sslsocket{pid = Pid}) when is_pid(Pid) -> - ssl_connection:info(Pid); -connection_info(#sslsocket{pid = {Listen, _}}) when is_port(Listen) -> - {error, enotconn}. +connection_info(#sslsocket{} = SSLSocket) -> + case connection_information(SSLSocket) of + {ok, Result} -> + {ok, {proplists:get_value(protocol, Result), proplists:get_value(cipher_suite, Result)}}; + Error -> + Error + end. %%-------------------------------------------------------------------- -spec peername(#sslsocket{}) -> {ok, {inet:ip_address(), inet:port_number()}} | {error, reason()}. @@ -671,6 +699,8 @@ handle_options(Opts0) -> handle_option(client_preferred_next_protocols, Opts, undefined)), log_alert = handle_option(log_alert, Opts, true), server_name_indication = handle_option(server_name_indication, Opts, undefined), + sni_hosts = handle_option(sni_hosts, Opts, []), + sni_fun = handle_option(sni_fun, Opts, undefined), honor_cipher_order = handle_option(honor_cipher_order, Opts, false), protocol = proplists:get_value(protocol, Opts, tls), padding_check = proplists:get_value(padding_check, Opts, true), @@ -687,7 +717,7 @@ handle_options(Opts0) -> user_lookup_fun, psk_identity, srp_identity, ciphers, reuse_session, reuse_sessions, ssl_imp, cb_info, renegotiate_at, secure_renegotiate, hibernate_after, - erl_dist, alpn_advertised_protocols, + erl_dist, alpn_advertised_protocols, sni_hosts, sni_fun, alpn_preferred_protocols, next_protocols_advertised, client_preferred_next_protocols, log_alert, server_name_indication, honor_cipher_order, padding_check, crl_check, crl_cache, @@ -704,6 +734,18 @@ handle_options(Opts0) -> inet_user = SockOpts, transport_info = CbInfo, connection_cb = ConnetionCb }}. +handle_option(sni_fun, Opts, Default) -> + OptFun = validate_option(sni_fun, + proplists:get_value(sni_fun, Opts, Default)), + OptHosts = proplists:get_value(sni_hosts, Opts, undefined), + case {OptFun, OptHosts} of + {Default, _} -> + Default; + {_, undefined} -> + OptFun; + _ -> + throw({error, {conflict_options, [sni_fun, sni_hosts]}}) + end; handle_option(OptionName, Opts, Default) -> validate_option(OptionName, proplists:get_value(OptionName, Opts, Default)). @@ -881,6 +923,20 @@ validate_option(server_name_indication, disable) -> disable; validate_option(server_name_indication, undefined) -> undefined; +validate_option(sni_hosts, []) -> + []; +validate_option(sni_hosts, [{Hostname, SSLOptions} | Tail]) when is_list(Hostname) -> + RecursiveSNIOptions = proplists:get_value(sni_hosts, SSLOptions, undefined), + case RecursiveSNIOptions of + undefined -> + [{Hostname, validate_options(SSLOptions)} | validate_option(sni_hosts, Tail)]; + _ -> + throw({error, {options, {sni_hosts, RecursiveSNIOptions}}}) + end; +validate_option(sni_fun, undefined) -> + undefined; +validate_option(sni_fun, Fun) when is_function(Fun) -> + Fun; validate_option(honor_cipher_order, Value) when is_boolean(Value) -> Value; validate_option(padding_check, Value) when is_boolean(Value) -> @@ -896,6 +952,12 @@ validate_option(crl_cache, {Cb, {_Handle, Options}} = Value) when is_atom(Cb) an validate_option(Opt, Value) -> throw({error, {options, {Opt, Value}}}). + +validate_options([]) -> + []; +validate_options([{Opt, Value} | Tail]) -> + [{Opt, validate_option(Opt, Value)} | validate_options(Tail)]. + validate_npn_ordering(client) -> ok; validate_npn_ordering(server) -> diff --git a/lib/ssl/src/ssl_connection.erl b/lib/ssl/src/ssl_connection.erl index 4a839872a6..64fa7bab0d 100644 --- a/lib/ssl/src/ssl_connection.erl +++ b/lib/ssl/src/ssl_connection.erl @@ -41,8 +41,9 @@ %% User Events -export([send/2, recv/3, close/1, shutdown/2, - new_user/2, get_opts/2, set_opts/2, info/1, session_info/1, - peer_certificate/1, renegotiation/1, negotiated_protocol/1, prf/5 + new_user/2, get_opts/2, set_opts/2, session_info/1, + peer_certificate/1, renegotiation/1, negotiated_protocol/1, prf/5, + connection_information/1 ]). -export([handle_session/7]). @@ -161,6 +162,14 @@ recv(Pid, Length, Timeout) -> sync_send_all_state_event(Pid, {recv, Length, Timeout}). %%-------------------------------------------------------------------- +-spec connection_information(pid()) -> {ok, list()} | {error, reason()}. +%% +%% Description: Get the SNI hostname +%%-------------------------------------------------------------------- +connection_information(Pid) when is_pid(Pid) -> + sync_send_all_state_event(Pid, connection_information). + +%%-------------------------------------------------------------------- -spec close(pid()) -> ok | {error, reason()}. %% %% Description: Close an ssl connection @@ -214,14 +223,6 @@ set_opts(ConnectionPid, Options) -> sync_send_all_state_event(ConnectionPid, {set_opts, Options}). %%-------------------------------------------------------------------- --spec info(pid()) -> {ok, {atom(), tuple()}} | {error, reason()}. -%% -%% Description: Returns ssl protocol and cipher used for the connection -%%-------------------------------------------------------------------- -info(ConnectionPid) -> - sync_send_all_state_event(ConnectionPid, info). - -%%-------------------------------------------------------------------- -spec session_info(pid()) -> {ok, list()} | {error, reason()}. %% %% Description: Returns info about the ssl session @@ -829,13 +830,6 @@ handle_sync_event({prf, Secret, Label, Seed, WantedLength}, _, StateName, error:Reason -> {error, Reason} end, {reply, Reply, StateName, State, get_timeout(State)}; -handle_sync_event(info, _, StateName, - #state{negotiated_version = Version, - session = #session{cipher_suite = Suite}} = State) -> - - AtomVersion = tls_record:protocol_version(Version), - {reply, {ok, {AtomVersion, ssl:suite_definition(Suite)}}, - StateName, State, get_timeout(State)}; handle_sync_event(session_info, _, StateName, #state{session = #session{session_id = Id, cipher_suite = Suite}} = State) -> @@ -845,7 +839,10 @@ handle_sync_event(session_info, _, StateName, handle_sync_event(peer_certificate, _, StateName, #state{session = #session{peer_certificate = Cert}} = State) -> - {reply, {ok, Cert}, StateName, State, get_timeout(State)}. + {reply, {ok, Cert}, StateName, State, get_timeout(State)}; +handle_sync_event(connection_information, _, StateName, #state{sni_hostname = SNIHostname, session = #session{cipher_suite = CipherSuite}, negotiated_version = Version} = State) -> + {reply, {ok, [{protocol, tls_record:protocol_version(Version)}, {cipher_suite, ssl:suite_definition(CipherSuite)}, {sni_hostname, SNIHostname}]}, StateName, State, get_timeout(State)}. + handle_info({ErrorTag, Socket, econnaborted}, StateName, #state{socket = Socket, transport_cb = Transport, diff --git a/lib/ssl/src/ssl_connection.hrl b/lib/ssl/src/ssl_connection.hrl index e569d706af..d95b51132a 100644 --- a/lib/ssl/src/ssl_connection.hrl +++ b/lib/ssl/src/ssl_connection.hrl @@ -80,7 +80,8 @@ expecting_finished = false ::boolean(), negotiated_protocol = undefined :: undefined | binary(), client_ecc, % {Curves, PointFmt} - tracker :: pid() %% Tracker process for listen socket + tracker :: pid(), %% Tracker process for listen socket + sni_hostname = undefined }). -define(DEFAULT_DIFFIE_HELLMAN_PARAMS, diff --git a/lib/ssl/src/ssl_internal.hrl b/lib/ssl/src/ssl_internal.hrl index 90f8b8a412..baeae68bc4 100644 --- a/lib/ssl/src/ssl_internal.hrl +++ b/lib/ssl/src/ssl_internal.hrl @@ -122,6 +122,8 @@ next_protocol_selector = undefined, %% fun([binary()]) -> binary()) log_alert :: boolean(), server_name_indication = undefined, + sni_hosts :: [{inet:hostname(), [tuple()]}], + sni_fun :: function() | undefined, %% Should the server prefer its own cipher order over the one provided by %% the client? honor_cipher_order = false :: boolean(), diff --git a/lib/ssl/src/tls_connection.erl b/lib/ssl/src/tls_connection.erl index 0577222980..3304ffcddb 100644 --- a/lib/ssl/src/tls_connection.erl +++ b/lib/ssl/src/tls_connection.erl @@ -398,6 +398,23 @@ initial_state(Role, Host, Port, Socket, {SSLOptions, SocketOptions, Tracker}, Us tracker = Tracker }. + +update_ssl_options_from_sni(OrigSSLOptions, SNIHostname) -> + SSLOption = + case OrigSSLOptions#ssl_options.sni_fun of + undefined -> + proplists:get_value(SNIHostname, + OrigSSLOptions#ssl_options.sni_hosts); + SNIFun -> + SNIFun(SNIHostname) + end, + case SSLOption of + undefined -> + undefined; + _ -> + ssl:handle_options(SSLOption, OrigSSLOptions) + end. + next_state(Current,_, #alert{} = Alert, #state{negotiated_version = Version} = State) -> handle_own_alert(Alert, Version, Current, State); @@ -426,15 +443,17 @@ next_state(Current, Next, #ssl_tls{type = ?HANDSHAKE, fragment = Data}, %% This message should not be included in handshake %% message hashes. Already in negotiation so it will be ignored! ?MODULE:SName(Packet, State); - ({#client_hello{} = Packet, Raw}, {next_state, connection = SName, State}) -> + ({#client_hello{} = Packet, Raw}, {next_state, connection = SName, HState0}) -> + HState = handle_sni_extension(Packet, HState0), Version = Packet#client_hello.client_version, Hs0 = ssl_handshake:init_handshake_history(), Hs1 = ssl_handshake:update_handshake_history(Hs0, Raw), - ?MODULE:SName(Packet, State#state{tls_handshake_history=Hs1, - renegotiation = {true, peer}}); - ({Packet, Raw}, {next_state, SName, State = #state{tls_handshake_history=Hs0}}) -> + ?MODULE:SName(Packet, HState#state{tls_handshake_history=Hs1, + renegotiation = {true, peer}}); + ({Packet, Raw}, {next_state, SName, HState0 = #state{tls_handshake_history=Hs0}}) -> + HState = handle_sni_extension(Packet, HState0), Hs1 = ssl_handshake:update_handshake_history(Hs0, Raw), - ?MODULE:SName(Packet, State#state{tls_handshake_history=Hs1}); + ?MODULE:SName(Packet, HState#state{tls_handshake_history=Hs1}); (_, StopState) -> StopState end, try @@ -981,3 +1000,32 @@ convert_options_partial_chain(Options, up) -> list_to_tuple(Head ++ [{partial_chain, fun(_) -> unknown_ca end}] ++ Tail); convert_options_partial_chain(Options, down) -> list_to_tuple(proplists:delete(partial_chain, tuple_to_list(Options))). + +handle_sni_extension(#client_hello{extensions = HelloExtensions}, State0) -> + case HelloExtensions#hello_extensions.sni of + undefined -> + State0; + #sni{hostname = Hostname} -> + NewOptions = update_ssl_options_from_sni(State0#state.ssl_options, Hostname), + case NewOptions of + undefined -> + State0; + _ -> + {ok, Ref, CertDbHandle, FileRefHandle, CacheHandle, CRLDbHandle, OwnCert, Key, DHParams} = + ssl_config:init(NewOptions, State0#state.role), + State0#state{ + session = State0#state.session#session{own_certificate = OwnCert}, + 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 = NewOptions, + sni_hostname = Hostname + } + end + end; +handle_sni_extension(_, State0) -> + State0. diff --git a/lib/ssl/test/Makefile b/lib/ssl/test/Makefile index 8c45a788a4..886cc7726b 100644 --- a/lib/ssl/test/Makefile +++ b/lib/ssl/test/Makefile @@ -53,6 +53,7 @@ MODULES = \ ssl_to_openssl_SUITE \ ssl_ECC_SUITE \ ssl_upgrade_SUITE\ + ssl_sni_SUITE \ make_certs\ erl_make_certs diff --git a/lib/ssl/test/make_certs.erl b/lib/ssl/test/make_certs.erl index 77631f62d3..4a193d48fe 100644 --- a/lib/ssl/test/make_certs.erl +++ b/lib/ssl/test/make_certs.erl @@ -81,7 +81,7 @@ all(DataDir, PrivDir, C = #config{}) -> create_rnd(DataDir, PrivDir), % For all requests rootCA(PrivDir, "erlangCA", C), intermediateCA(PrivDir, "otpCA", "erlangCA", C), - endusers(PrivDir, "otpCA", ["client", "server", "revoked"], C), + endusers(PrivDir, "otpCA", ["client", "server", "revoked", "a.server", "b.server"], C), endusers(PrivDir, "erlangCA", ["localhost"], C), %% Create keycert files SDir = filename:join([PrivDir, "server"]), diff --git a/lib/ssl/test/ssl_alpn_handshake_SUITE.erl b/lib/ssl/test/ssl_alpn_handshake_SUITE.erl index ccd70fa605..ae76f5849e 100644 --- a/lib/ssl/test/ssl_alpn_handshake_SUITE.erl +++ b/lib/ssl/test/ssl_alpn_handshake_SUITE.erl @@ -384,7 +384,7 @@ ssl_receive_and_assert_alpn(Socket, Protocol, Data) -> ssl_send(Socket, Data) -> ct:log("Connection info: ~p~n", - [ssl:connection_info(Socket)]), + [ssl:connection_information(Socket)]), ssl:send(Socket, Data). ssl_receive(Socket, Data) -> @@ -392,7 +392,7 @@ ssl_receive(Socket, Data) -> ssl_receive(Socket, Data, Buffer) -> ct:log("Connection info: ~p~n", - [ssl:connection_info(Socket)]), + [ssl:connection_information(Socket)]), receive {ssl, Socket, MoreData} -> ct:log("Received ~p~n",[MoreData]), @@ -411,4 +411,4 @@ ssl_receive(Socket, Data, Buffer) -> end. connection_info_result(Socket) -> - ssl:connection_info(Socket). + ssl:connection_information(Socket). diff --git a/lib/ssl/test/ssl_basic_SUITE.erl b/lib/ssl/test/ssl_basic_SUITE.erl index 50d5fb411f..e1a36dbbd4 100644 --- a/lib/ssl/test/ssl_basic_SUITE.erl +++ b/lib/ssl/test/ssl_basic_SUITE.erl @@ -384,7 +384,7 @@ new_options_in_accept(Config) when is_list(Config) -> %%-------------------------------------------------------------------- connection_info() -> - [{doc,"Test the API function ssl:connection_info/1"}]. + [{doc,"Test the API function ssl:connection_information/1"}]. connection_info(Config) when is_list(Config) -> ClientOpts = ?config(client_opts, Config), ServerOpts = ?config(server_opts, Config), @@ -2831,7 +2831,7 @@ listen_socket(Config) -> {error, enotconn} = ssl:send(ListenSocket, <<"data">>), {error, enotconn} = ssl:recv(ListenSocket, 0), - {error, enotconn} = ssl:connection_info(ListenSocket), + {error, enotconn} = ssl:connection_information(ListenSocket), {error, enotconn} = ssl:peername(ListenSocket), {error, enotconn} = ssl:peercert(ListenSocket), {error, enotconn} = ssl:session_info(ListenSocket), @@ -3445,7 +3445,7 @@ renegotiate_immediately(Socket) -> end, ok = ssl:renegotiate(Socket), {error, renegotiation_rejected} = ssl:renegotiate(Socket), - ct:sleep(?RENEGOTIATION_DISABLE_TIME +1), + ct:sleep(?RENEGOTIATION_DISABLE_TIME + ?SLEEP), ok = ssl:renegotiate(Socket), ct:log("Renegotiated again"), ssl:send(Socket, "Hello world"), @@ -3836,10 +3836,10 @@ cipher(CipherSuite, Version, Config, ClientOpts, ServerOpts) -> end. connection_info_result(Socket) -> - ssl:connection_info(Socket). - + {ok, Info} = ssl:connection_information(Socket, [protocol, cipher_suite]), + {ok, {proplists:get_value(protocol, Info), proplists:get_value(cipher_suite, Info)}}. version_info_result(Socket) -> - {ok, {Version, _}} = ssl:connection_info(Socket), + {ok, [{version, Version}]} = ssl:connection_information(Socket, [version]), {ok, Version}. connect_dist_s(S) -> diff --git a/lib/ssl/test/ssl_npn_handshake_SUITE.erl b/lib/ssl/test/ssl_npn_handshake_SUITE.erl index 326f907e66..8e95679306 100644 --- a/lib/ssl/test/ssl_npn_handshake_SUITE.erl +++ b/lib/ssl/test/ssl_npn_handshake_SUITE.erl @@ -332,7 +332,7 @@ ssl_receive_and_assert_npn(Socket, Protocol, Data) -> ssl_send(Socket, Data) -> ct:log("Connection info: ~p~n", - [ssl:connection_info(Socket)]), + [ssl:connection_information(Socket)]), ssl:send(Socket, Data). ssl_receive(Socket, Data) -> @@ -340,7 +340,7 @@ ssl_receive(Socket, Data) -> ssl_receive(Socket, Data, Buffer) -> ct:log("Connection info: ~p~n", - [ssl:connection_info(Socket)]), + [ssl:connection_information(Socket)]), receive {ssl, Socket, MoreData} -> ct:log("Received ~p~n",[MoreData]), @@ -360,4 +360,4 @@ ssl_receive(Socket, Data, Buffer) -> connection_info_result(Socket) -> - ssl:connection_info(Socket). + ssl:connection_information(Socket). diff --git a/lib/ssl/test/ssl_sni_SUITE.erl b/lib/ssl/test/ssl_sni_SUITE.erl new file mode 100644 index 0000000000..b059ff991b --- /dev/null +++ b/lib/ssl/test/ssl_sni_SUITE.erl @@ -0,0 +1,179 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2015-2015. All Rights Reserved. +%% +%% The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% +%% + +-module(ssl_sni_SUITE). + +-compile(export_all). + +-include_lib("common_test/include/ct.hrl"). +-include_lib("public_key/include/public_key.hrl"). + +%%-------------------------------------------------------------------- +%% Common Test interface functions ----------------------------------- +%%-------------------------------------------------------------------- +suite() -> [{ct_hooks,[ts_install_cth]}]. + +all() -> [no_sni_header, + sni_match, + sni_no_match, + no_sni_header_fun, + sni_match_fun, + sni_no_match_fun]. + +init_per_suite(Config0) -> + catch crypto:stop(), + try crypto:start() of + ok -> + ssl:start(), + Result = + (catch make_certs:all(?config(data_dir, Config0), + ?config(priv_dir, Config0))), + ct:log("Make certs ~p~n", [Result]), + ssl_test_lib:cert_options(Config0) + catch _:_ -> + {skip, "Crypto did not start"} + end. + +end_per_suite(_) -> + ssl:stop(), + application:stop(crypto). + +%%-------------------------------------------------------------------- +%% Test Cases -------------------------------------------------------- +%%-------------------------------------------------------------------- +no_sni_header(Config) -> + run_handshake(Config, undefined, undefined, "server"). + +no_sni_header_fun(Config) -> + run_sni_fun_handshake(Config, undefined, undefined, "server"). + +sni_match(Config) -> + run_handshake(Config, "a.server", "a.server", "a.server"). + +sni_match_fun(Config) -> + run_sni_fun_handshake(Config, "a.server", "a.server", "a.server"). + +sni_no_match(Config) -> + run_handshake(Config, "c.server", undefined, "server"). + +sni_no_match_fun(Config) -> + run_sni_fun_handshake(Config, "c.server", undefined, "server"). + + +%%-------------------------------------------------------------------- +%% Internal Functions ------------------------------------------------ +%%-------------------------------------------------------------------- +ssl_recv(SSLSocket, Expect) -> + ssl_recv(SSLSocket, "", Expect). + +ssl_recv(SSLSocket, CurrentData, ExpectedData) -> + receive + {ssl, SSLSocket, Data} -> + NeweData = CurrentData ++ Data, + case NeweData of + ExpectedData -> + ok; + _ -> + ssl_recv(SSLSocket, NeweData, ExpectedData) + end; + Other -> + ct:fail({unexpected_message, Other}) + after 4000 -> + ct:fail({timeout, CurrentData, ExpectedData}) + end. + +send_and_hostname(SSLSocket) -> + ssl:send(SSLSocket, "OK"), + {ok, [{sni_hostname, Hostname}]} = ssl:connection_information(SSLSocket, [sni_hostname]), + Hostname. + +rdnPart([[#'AttributeTypeAndValue'{type=Type, value=Value} | _] | _], Type) -> + Value; +rdnPart([_ | Tail], Type) -> + rdnPart(Tail, Type); +rdnPart([], _) -> + unknown. + +rdn_to_string({utf8String, Binary}) -> + erlang:binary_to_list(Binary); +rdn_to_string({printableString, String}) -> + String. + +recv_and_certificate(SSLSocket) -> + ssl_recv(SSLSocket, "OK"), + {ok, PeerCert} = ssl:peercert(SSLSocket), + #'OTPCertificate'{tbsCertificate = #'OTPTBSCertificate'{subject = {rdnSequence, Subject}}} + = public_key:pkix_decode_cert(PeerCert, otp), + ct:log("Subject of certificate received from server: ~p", [Subject]), + rdn_to_string(rdnPart(Subject, ?'id-at-commonName')). + +run_sni_fun_handshake(Config, SNIHostname, ExpectedSNIHostname, ExpectedCN) -> + ct:log("Start running handshake for sni_fun, Config: ~p, SNIHostname: ~p, " + "ExpectedSNIHostname: ~p, ExpectedCN: ~p", + [Config, SNIHostname, ExpectedSNIHostname, ExpectedCN]), + [{sni_hosts, ServerSNIConf}] = ?config(sni_server_opts, Config), + SNIFun = fun(Domain) -> proplists:get_value(Domain, ServerSNIConf, undefined) end, + ServerOptions = ?config(server_opts, Config) ++ [{sni_fun, SNIFun}], + ClientOptions = + case SNIHostname of + undefined -> + ?config(client_opts, Config); + _ -> + [{server_name_indication, SNIHostname}] ++ ?config(client_opts, Config) + end, + ct:log("Options: ~p", [[ServerOptions, ClientOptions]]), + {ClientNode, ServerNode, Hostname} = ssl_test_lib:run_where(Config), + Server = ssl_test_lib:start_server([{node, ServerNode}, {port, 0}, + {from, self()}, {mfa, {?MODULE, send_and_hostname, []}}, + {options, ServerOptions}]), + Port = ssl_test_lib:inet_port(Server), + Client = ssl_test_lib:start_client([{node, ClientNode}, {port, Port}, + {host, Hostname}, {from, self()}, + {mfa, {?MODULE, recv_and_certificate, []}}, + {options, ClientOptions}]), + ssl_test_lib:check_result(Server, ExpectedSNIHostname, Client, ExpectedCN), + ssl_test_lib:close(Server), + ssl_test_lib:close(Client). + +run_handshake(Config, SNIHostname, ExpectedSNIHostname, ExpectedCN) -> + ct:log("Start running handshake, Config: ~p, SNIHostname: ~p, " + "ExpectedSNIHostname: ~p, ExpectedCN: ~p", + [Config, SNIHostname, ExpectedSNIHostname, ExpectedCN]), + ServerOptions = ?config(sni_server_opts, Config) ++ ?config(server_opts, Config), + ClientOptions = + case SNIHostname of + undefined -> + ?config(client_opts, Config); + _ -> + [{server_name_indication, SNIHostname}] ++ ?config(client_opts, Config) + end, + ct:log("Options: ~p", [[ServerOptions, ClientOptions]]), + {ClientNode, ServerNode, Hostname} = ssl_test_lib:run_where(Config), + Server = ssl_test_lib:start_server([{node, ServerNode}, {port, 0}, + {from, self()}, {mfa, {?MODULE, send_and_hostname, []}}, + {options, ServerOptions}]), + Port = ssl_test_lib:inet_port(Server), + Client = ssl_test_lib:start_client([{node, ClientNode}, {port, Port}, + {host, Hostname}, {from, self()}, + {mfa, {?MODULE, recv_and_certificate, []}}, + {options, ClientOptions}]), + ssl_test_lib:check_result(Server, ExpectedSNIHostname, Client, ExpectedCN), + ssl_test_lib:close(Server), + ssl_test_lib:close(Client). diff --git a/lib/ssl/test/ssl_test_lib.erl b/lib/ssl/test/ssl_test_lib.erl index d19e3b7fdb..a3bfdf8893 100644 --- a/lib/ssl/test/ssl_test_lib.erl +++ b/lib/ssl/test/ssl_test_lib.erl @@ -354,6 +354,11 @@ cert_options(Config) -> BadKeyFile = filename:join([?config(priv_dir, Config), "badkey.pem"]), PskSharedSecret = <<1,2,3,4,5,6,7,8,9,10,11,12,13,14,15>>, + + SNIServerACertFile = filename:join([?config(priv_dir, Config), "a.server", "cert.pem"]), + SNIServerAKeyFile = filename:join([?config(priv_dir, Config), "a.server", "key.pem"]), + SNIServerBCertFile = filename:join([?config(priv_dir, Config), "b.server", "cert.pem"]), + SNIServerBKeyFile = filename:join([?config(priv_dir, Config), "b.server", "key.pem"]), [{client_opts, [{ssl_imp, new},{reuseaddr, true}]}, {client_verification_opts, [{cacertfile, ClientCaCertFile}, {certfile, ClientCertFile}, @@ -414,7 +419,17 @@ cert_options(Config) -> {server_bad_cert, [{ssl_imp, new},{cacertfile, ServerCaCertFile}, {certfile, BadCertFile}, {keyfile, ServerKeyFile}]}, {server_bad_key, [{ssl_imp, new},{cacertfile, ServerCaCertFile}, - {certfile, ServerCertFile}, {keyfile, BadKeyFile}]} + {certfile, ServerCertFile}, {keyfile, BadKeyFile}]}, + {sni_server_opts, [{sni_hosts, [ + {"a.server", [ + {certfile, SNIServerACertFile}, + {keyfile, SNIServerAKeyFile} + ]}, + {"b.server", [ + {certfile, SNIServerBCertFile}, + {keyfile, SNIServerBKeyFile} + ]} + ]}]} | Config]. @@ -934,7 +949,8 @@ der_to_pem(File, Entries) -> file:write_file(File, PemBin). cipher_result(Socket, Result) -> - Result = ssl:connection_info(Socket), + {ok, Info} = ssl:connection_information(Socket), + Result = {ok, {proplists:get_value(protocol, Info), proplists:get_value(cipher_suite, Info)}}, ct:log("~p:~p~nSuccessfull connect: ~p~n", [?MODULE,?LINE, Result]), %% Importante to send two packets here %% to properly test "cipher state" handling diff --git a/lib/ssl/test/ssl_to_openssl_SUITE.erl b/lib/ssl/test/ssl_to_openssl_SUITE.erl index 94426a3061..aca34cb6e9 100644 --- a/lib/ssl/test/ssl_to_openssl_SUITE.erl +++ b/lib/ssl/test/ssl_to_openssl_SUITE.erl @@ -50,9 +50,9 @@ all() -> groups() -> [{basic, [], basic_tests()}, - {'tlsv1.2', [], all_versions_tests() ++ alpn_tests() ++ npn_tests()}, - {'tlsv1.1', [], all_versions_tests() ++ alpn_tests() ++ npn_tests()}, - {'tlsv1', [], all_versions_tests()++ alpn_tests() ++ npn_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()}]. basic_tests() -> @@ -101,6 +101,14 @@ npn_tests() -> erlang_client_openssl_server_npn_only_client, erlang_client_openssl_server_npn_only_server]. +sni_server_tests() -> + [erlang_server_openssl_client_sni_match, + erlang_server_openssl_client_sni_match_fun, + erlang_server_openssl_client_sni_no_match, + erlang_server_openssl_client_sni_no_match_fun, + erlang_server_openssl_client_sni_no_header, + erlang_server_openssl_client_sni_no_header_fun]. + init_per_suite(Config0) -> Dog = ct:timetrap(?LONG_TIMEOUT *2), @@ -222,6 +230,15 @@ special_init(TestCase, Config) check_openssl_npn_support(Config) end; +special_init(TestCase, Config) + when TestCase == erlang_server_openssl_client_sni_match; + TestCase == erlang_server_openssl_client_sni_no_match; + TestCase == erlang_server_openssl_client_sni_no_header; + 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 -> + check_openssl_sni_support(Config); + special_init(_, Config) -> Config. @@ -1181,6 +1198,25 @@ erlang_server_openssl_client_npn_only_client(Config) when is_list(Config) -> ssl_test_lib:check_result(Server, ok) end), ok. +%-------------------------------------------------------------------------- +erlang_server_openssl_client_sni_no_header(Config) when is_list(Config) -> + erlang_server_openssl_client_sni_test(Config, undefined, undefined, "server"). + +erlang_server_openssl_client_sni_no_header_fun(Config) when is_list(Config) -> + erlang_server_openssl_client_sni_test_sni_fun(Config, undefined, undefined, "server"). + +erlang_server_openssl_client_sni_match(Config) when is_list(Config) -> + erlang_server_openssl_client_sni_test(Config, "a.server", "a.server", "a.server"). + +erlang_server_openssl_client_sni_match_fun(Config) when is_list(Config) -> + erlang_server_openssl_client_sni_test_sni_fun(Config, "a.server", "a.server", "a.server"). + +erlang_server_openssl_client_sni_no_match(Config) when is_list(Config) -> + erlang_server_openssl_client_sni_test(Config, "c.server", undefined, "server"). + +erlang_server_openssl_client_sni_no_match_fun(Config) when is_list(Config) -> + erlang_server_openssl_client_sni_test_sni_fun(Config, "c.server", undefined, "server"). + %%-------------------------------------------------------------------- %% Internal functions ------------------------------------------------ @@ -1207,6 +1243,94 @@ run_suites(Ciphers, Version, Config, Type) -> ct:fail(cipher_suite_failed_see_test_case_log) end. +client_read_check([], _Data) -> + ok; +client_read_check([Hd | T], Data) -> + case binary:match(Data, list_to_binary(Hd)) of + nomatch -> + nomatch; + _ -> + client_read_check(T, Data) + end. +client_check_result(Port, DataExpected, DataReceived) -> + receive + {Port, {data, TheData}} -> + Data = list_to_binary(TheData), + NewData = <<DataReceived/binary, Data/binary>>, + ct:log("New Data: ~p", [NewData]), + case client_read_check(DataExpected, NewData) of + ok -> + ok; + _ -> + client_check_result(Port, DataExpected, NewData) + end + after 3000 -> + ct:fail({"Time out on opensssl Client", {expected, DataExpected}, + {got, DataReceived}}) + end. +client_check_result(Port, DataExpected) -> + client_check_result(Port, DataExpected, <<"">>). + +send_and_hostname(SSLSocket) -> + ssl:send(SSLSocket, "OK"), + {ok, [{sni_hostname, Hostname}]} = ssl:connection_information(SSLSocket, [sni_hostname]), + Hostname. + +erlang_server_openssl_client_sni_test(Config, SNIHostname, ExpectedSNIHostname, ExpectedCN) -> + ct:log("Start running handshake, Config: ~p, SNIHostname: ~p, ExpectedSNIHostname: ~p, ExpectedCN: ~p", [Config, SNIHostname, ExpectedSNIHostname, ExpectedCN]), + ServerOptions = ?config(sni_server_opts, Config) ++ ?config(server_opts, Config), + {_, ServerNode, Hostname} = ssl_test_lib:run_where(Config), + Server = ssl_test_lib:start_server([{node, ServerNode}, {port, 0}, + {from, self()}, {mfa, {?MODULE, send_and_hostname, []}}, + {options, ServerOptions}]), + Port = ssl_test_lib:inet_port(Server), + ClientCommand = case SNIHostname of + undefined -> + "openssl s_client -connect " ++ Hostname ++ ":" ++ integer_to_list(Port); + _ -> + "openssl s_client -connect " ++ Hostname ++ ":" ++ integer_to_list(Port) ++ " -servername " ++ SNIHostname + end, + ct:log("Options: ~p", [[ServerOptions, ClientCommand]]), + ClientPort = open_port({spawn, ClientCommand}, [stderr_to_stdout]), + + %% Client check needs to be done befor server check, + %% or server check might consume client messages + ExpectedClientOutput = ["OK", "/CN=" ++ ExpectedCN ++ "/"], + client_check_result(ClientPort, ExpectedClientOutput), + ssl_test_lib:check_result(Server, ExpectedSNIHostname), + ssl_test_lib:close_port(ClientPort), + ssl_test_lib:close(Server), + ok. + + +erlang_server_openssl_client_sni_test_sni_fun(Config, SNIHostname, ExpectedSNIHostname, ExpectedCN) -> + ct:log("Start running handshake for sni_fun, Config: ~p, SNIHostname: ~p, ExpectedSNIHostname: ~p, ExpectedCN: ~p", [Config, SNIHostname, ExpectedSNIHostname, ExpectedCN]), + [{sni_hosts, ServerSNIConf}] = ?config(sni_server_opts, Config), + SNIFun = fun(Domain) -> proplists:get_value(Domain, ServerSNIConf, undefined) end, + ServerOptions = ?config(server_opts, Config) ++ [{sni_fun, SNIFun}], + {_, ServerNode, Hostname} = ssl_test_lib:run_where(Config), + Server = ssl_test_lib:start_server([{node, ServerNode}, {port, 0}, + {from, self()}, {mfa, {?MODULE, send_and_hostname, []}}, + {options, ServerOptions}]), + Port = ssl_test_lib:inet_port(Server), + ClientCommand = case SNIHostname of + undefined -> + "openssl s_client -connect " ++ Hostname ++ ":" ++ integer_to_list(Port); + _ -> + "openssl s_client -connect " ++ Hostname ++ ":" ++ integer_to_list(Port) ++ " -servername " ++ SNIHostname + end, + ct:log("Options: ~p", [[ServerOptions, ClientCommand]]), + ClientPort = open_port({spawn, ClientCommand}, [stderr_to_stdout]), + + %% Client check needs to be done befor server check, + %% or server check might consume client messages + ExpectedClientOutput = ["OK", "/CN=" ++ ExpectedCN ++ "/"], + client_check_result(ClientPort, ExpectedClientOutput), + ssl_test_lib:check_result(Server, ExpectedSNIHostname), + ssl_test_lib:close_port(ClientPort), + ssl_test_lib:close(Server). + + cipher(CipherSuite, Version, Config, ClientOpts, ServerOpts) -> process_flag(trap_exit, true), ct:log("Testing CipherSuite ~p~n", [CipherSuite]), @@ -1545,7 +1669,7 @@ erlang_ssl_receive_and_assert_negotiated_protocol(Socket, Protocol, Data) -> erlang_ssl_receive(Socket, Data) -> ct:log("Connection info: ~p~n", - [ssl:connection_info(Socket)]), + [ssl:connection_information(Socket)]), receive {ssl, Socket, Data} -> io:format("Received ~p~n",[Data]), @@ -1564,16 +1688,16 @@ erlang_ssl_receive(Socket, Data) -> end. connection_info(Socket, Version) -> - case ssl:connection_info(Socket) of - {ok, {Version, _} = Info} -> + case ssl:connection_information(Socket, [version]) of + {ok, [{version, Version}] = Info} -> ct:log("Connection info: ~p~n", [Info]), ok; - {ok, {OtherVersion, _}} -> + {ok, [{version, OtherVersion}]} -> {wrong_version, OtherVersion} end. connection_info_result(Socket) -> - ssl:connection_info(Socket). + ssl:connection_information(Socket). delayed_send(Socket, [ErlData, OpenSslData]) -> @@ -1588,6 +1712,14 @@ server_sent_garbage(Socket) -> end. +check_openssl_sni_support(Config) -> + HelpText = os:cmd("openssl s_client --help"), + case string:str(HelpText, "-servername") of + 0 -> + {skip, "Current openssl doesn't support SNI"}; + _ -> + Config + end. check_openssl_npn_support(Config) -> HelpText = os:cmd("openssl s_client --help"), diff --git a/lib/stdlib/doc/src/c.xml b/lib/stdlib/doc/src/c.xml index b49fa6ad67..b43d4786ae 100644 --- a/lib/stdlib/doc/src/c.xml +++ b/lib/stdlib/doc/src/c.xml @@ -232,6 +232,14 @@ compile:file(<anno>File</anno>, <anno>Options</anno> ++ [report_errors, report_w </desc> </func> <func> + <name name="uptime" arity="0"/> + <fsummary>Print node uptime</fsummary> + <desc> + <p>Prints the node uptime (as given by + <c>erlang:statistics(wall_clock)</c>), in human-readable form.</p> + </desc> + </func> + <func> <name>xm(ModSpec) -> void()</name> <fsummary>Cross reference check a module</fsummary> <type> diff --git a/lib/stdlib/doc/src/ets.xml b/lib/stdlib/doc/src/ets.xml index 6b9524ef63..2bfe074c3e 100644 --- a/lib/stdlib/doc/src/ets.xml +++ b/lib/stdlib/doc/src/ets.xml @@ -1435,7 +1435,9 @@ is_integer(X), is_integer(Y), X + Y < 4711]]></code> <p>Whenever the <c>extended_info</c> option is used, it results in a file not readable by versions of ets prior to that in stdlib-1.15.1</p> - + <p>The <c>sync</c> option, if set to <c>true</c>, ensures that + the content of the file is actually written to the disk before + <c>tab2file</c> returns. Default is <c>{sync, false}</c>.</p> </desc> </func> <func> diff --git a/lib/stdlib/doc/src/gb_sets.xml b/lib/stdlib/doc/src/gb_sets.xml index ea96c14472..405bae5698 100644 --- a/lib/stdlib/doc/src/gb_sets.xml +++ b/lib/stdlib/doc/src/gb_sets.xml @@ -4,7 +4,7 @@ <erlref> <header> <copyright> - <year>2001</year><year>2014</year> + <year>2001</year><year>2015</year> <holder>Ericsson AB. All Rights Reserved.</holder> </copyright> <legalnotice> @@ -306,6 +306,17 @@ </desc> </func> <func> + <name name="iterator_from" arity="2"/> + <fsummary>Return an iterator for a set starting from a specified element</fsummary> + <desc> + <p>Returns an iterator that can be used for traversing the + entries of <c><anno>Set</anno></c>; see <c>next/1</c>. + The difference as compared to the iterator returned by + <c>iterator/1</c> is that the first element greater than + or equal to <c><anno>Element</anno></c> is returned.</p> + </desc> + </func> + <func> <name name="largest" arity="1"/> <fsummary>Return largest element</fsummary> <desc> diff --git a/lib/stdlib/doc/src/gb_trees.xml b/lib/stdlib/doc/src/gb_trees.xml index b2f237e1d7..82167e1083 100644 --- a/lib/stdlib/doc/src/gb_trees.xml +++ b/lib/stdlib/doc/src/gb_trees.xml @@ -4,7 +4,7 @@ <erlref> <header> <copyright> - <year>2001</year><year>2014</year> + <year>2001</year><year>2015</year> <holder>Ericsson AB. All Rights Reserved.</holder> </copyright> <legalnotice> @@ -183,6 +183,17 @@ </desc> </func> <func> + <name name="iterator_from" arity="2"/> + <fsummary>Return an iterator for a tree starting from specified key</fsummary> + <desc> + <p>Returns an iterator that can be used for traversing the + entries of <c><anno>Tree</anno></c>; see <c>next/1</c>. + The difference as compared to the iterator returned by + <c>iterator/1</c> is that the first key greater than + or equal to <c><anno>Key</anno></c> is returned.</p> + </desc> + </func> + <func> <name name="keys" arity="1"/> <fsummary>Return a list of the keys in a tree</fsummary> <desc> diff --git a/lib/stdlib/doc/src/maps.xml b/lib/stdlib/doc/src/maps.xml index e46068230a..7345a9357a 100644 --- a/lib/stdlib/doc/src/maps.xml +++ b/lib/stdlib/doc/src/maps.xml @@ -33,6 +33,28 @@ <funcs> <func> + <name name="filter" arity="2"/> + <fsummary>Choose pairs which 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> + The call will fail 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> + <p>Example:</p> + <code type="none"> +> M = #{a => 2, b => 3, c=> 4, "a" => 1, "b" => 2, "c" => 4}, + Pred = fun(K,V) -> is_atom(K) andalso (V rem 2) =:= 0 end, + maps:filter(Pred,M). +#{a => 2,c => 4} </code> + </desc> + </func> + + <func> <name name="find" arity="2"/> <fsummary></fsummary> <desc> diff --git a/lib/stdlib/src/c.erl b/lib/stdlib/src/c.erl index 9860adf04d..d5b24d3c32 100644 --- a/lib/stdlib/src/c.erl +++ b/lib/stdlib/src/c.erl @@ -27,7 +27,7 @@ lc_batch/0, lc_batch/1, i/3,pid/3,m/0,m/1, bt/1, q/0, - erlangrc/0,erlangrc/1,bi/1, flush/0, regs/0, + erlangrc/0,erlangrc/1,bi/1, flush/0, regs/0, uptime/0, nregs/0,pwd/0,ls/0,ls/1,cd/1,memory/1,memory/0, xm/1]). -export([display_info/1]). @@ -65,6 +65,7 @@ help() -> "q() -- quit - shorthand for init:stop()\n" "regs() -- information about registered processes\n" "nregs() -- information about all registered processes\n" + "uptime() -- print node uptime\n" "xm(M) -- cross reference check a module\n" "y(File) -- generate a Yecc parser\n">>). @@ -774,6 +775,26 @@ memory() -> erlang:memory(). memory(TypeSpec) -> erlang:memory(TypeSpec). %% +%% uptime/0 +%% + +-spec uptime() -> 'ok'. + +uptime() -> + io:format("~s~n", [uptime(get_uptime())]). + +uptime({D, {H, M, S}}) -> + lists:flatten( + [[ io_lib:format("~p days, ", [D]) || D > 0 ], + [ io_lib:format("~p hours, ", [H]) || D+H > 0 ], + [ io_lib:format("~p minutes and ", [M]) || D+H+M > 0 ], + io_lib:format("~p seconds", [S])]). + +get_uptime() -> + {UpTime, _} = erlang:statistics(wall_clock), + calendar:seconds_to_daystime(UpTime div 1000). + +%% %% Cross Reference Check %% %%-spec xm(module() | file:filename()) -> xref:m/1 return diff --git a/lib/stdlib/src/erl_anno.erl b/lib/stdlib/src/erl_anno.erl index 963b7278a6..9fb767fc93 100644 --- a/lib/stdlib/src/erl_anno.erl +++ b/lib/stdlib/src/erl_anno.erl @@ -147,7 +147,7 @@ is_anno2(_, _) -> false. is_filename(T) -> - is_string(T) orelse is_binary(T). + is_list(T) orelse is_binary(T). is_string(T) -> try lists:all(fun(C) when is_integer(C), C >= 0 -> true end, T) diff --git a/lib/stdlib/src/erl_lint.erl b/lib/stdlib/src/erl_lint.erl index 821d81a6b4..714c260bda 100644 --- a/lib/stdlib/src/erl_lint.erl +++ b/lib/stdlib/src/erl_lint.erl @@ -120,13 +120,13 @@ value_option(Flag, Default, On, OnVal, Off, OffVal, Opts) -> func=[], %Current function warn_format=0, %Warn format calls enabled_warnings=[], %All enabled warnings (ordset). + nowarn_bif_clash=[], %All no warn bif clashes (ordset). errors=[], %Current errors warnings=[], %Current warnings file = "" :: string(), %From last file attribute recdef_top=false :: boolean(), %true in record initialisation %outside any fun or lc xqlc= false :: boolean(), %true if qlc.hrl included - new = false :: boolean(), %Has user-defined 'new/N' called= [] :: [{fa(),line()}], %Called functions usage = #usage{} :: #usage{}, specs = dict:new() %Type specifications @@ -569,6 +569,7 @@ start(File, Opts) -> warn_format = value_option(warn_format, 1, warn_format, 1, nowarn_format, 0, Opts), enabled_warnings = Enabled, + nowarn_bif_clash = nowarn_function(nowarn_bif_clash, Opts), file = File }. @@ -640,8 +641,6 @@ forms(Forms0, St0) -> St4 = foldl(fun form/2, pre_scan(Forms, St3), Forms), post_traversal_check(Forms, St4). -pre_scan([{function,_L,new,_A,_Cs} | Fs], St) -> - pre_scan(Fs, St#lint{new=true}); pre_scan([{attribute,L,compile,C} | Fs], St) -> case is_warn_enabled(export_all, St) andalso member(export_all, lists:flatten([C])) of @@ -772,8 +771,7 @@ eof(_Line, St0) -> %% bif_clashes(Forms, State0) -> State. -bif_clashes(Forms, St) -> - Nowarn = nowarn_function(nowarn_bif_clash, St#lint.compile), +bif_clashes(Forms, #lint{nowarn_bif_clash=Nowarn} = St) -> Clashes0 = [{Name,Arity} || {function,_L,Name,Arity,_Cs} <- Forms, erl_internal:bif(Name, Arity)], Clashes = ordsets:subtract(ordsets:from_list(Clashes0), Nowarn), @@ -3781,8 +3779,7 @@ is_autoimport_suppressed(NoAutoSet,{Func,Arity}) -> gb_sets:is_element({Func,Arity},NoAutoSet). %% Predicate to find out if a function specific bif-clash suppression (old deprecated) is present bif_clash_specifically_disabled(St,{F,A}) -> - Nowarn = nowarn_function(nowarn_bif_clash, St#lint.compile), - lists:member({F,A},Nowarn). + lists:member({F,A},St#lint.nowarn_bif_clash). %% Predicate to find out if an autoimported guard_bif is not overriden in some way %% Guard Bif without module name is disallowed if diff --git a/lib/stdlib/src/ets.erl b/lib/stdlib/src/ets.erl index 1df069755d..0e2d59d0c3 100644 --- a/lib/stdlib/src/ets.erl +++ b/lib/stdlib/src/ets.erl @@ -739,7 +739,8 @@ do_filter(Tab, Key, F, A, Ack) -> -record(filetab_options, { object_count = false :: boolean(), - md5sum = false :: boolean() + md5sum = false :: boolean(), + sync = false :: boolean() }). -spec tab2file(Tab, Filename) -> 'ok' | {'error', Reason} when @@ -754,7 +755,7 @@ tab2file(Tab, File) -> Tab :: tab(), Filename :: file:name(), Options :: [Option], - Option :: {'extended_info', [ExtInfo]}, + Option :: {'extended_info', [ExtInfo]} | {'sync', boolean()}, ExtInfo :: 'md5sum' | 'object_count', Reason :: term(). @@ -835,6 +836,15 @@ tab2file(Tab, File, Options) -> List -> LogFun(NewState1,[['$end_of_table',List]]) end, + case FtOptions#filetab_options.sync of + true -> + case disk_log:sync(Name) of + ok -> ok; + {error, Reason2} -> throw(Reason2) + end; + false -> + ok + end, disk_log:close(Name) catch throw:TReason -> @@ -887,23 +897,24 @@ md5terms(State, [H|T]) -> {FinState, [B|TL]}. parse_ft_options(Options) when is_list(Options) -> - {Opt,Rest} = case (catch lists:keytake(extended_info,1,Options)) of - false -> - {[],Options}; - {value,{extended_info,L},R} when is_list(L) -> - {L,R} - end, - case Rest of - [] -> - parse_ft_info_options(#filetab_options{}, Opt); - Other -> - throw({unknown_option, Other}) - end; -parse_ft_options(Malformed) -> + {ok, parse_ft_options(Options, #filetab_options{}, false)}. + +parse_ft_options([], FtOpt, _) -> + FtOpt; +parse_ft_options([{sync,true} | Rest], FtOpt, EI) -> + parse_ft_options(Rest, FtOpt#filetab_options{sync = true}, EI); +parse_ft_options([{sync,false} | Rest], FtOpt, EI) -> + parse_ft_options(Rest, FtOpt, EI); +parse_ft_options([{extended_info,L} | Rest], FtOpt0, false) -> + FtOpt1 = parse_ft_info_options(FtOpt0, L), + parse_ft_options(Rest, FtOpt1, true); +parse_ft_options([Other | _], _, _) -> + throw({unknown_option, Other}); +parse_ft_options(Malformed, _, _) -> throw({malformed_option, Malformed}). parse_ft_info_options(FtOpt,[]) -> - {ok,FtOpt}; + FtOpt; parse_ft_info_options(FtOpt,[object_count | T]) -> parse_ft_info_options(FtOpt#filetab_options{object_count = true}, T); parse_ft_info_options(FtOpt,[md5sum | T]) -> diff --git a/lib/stdlib/src/gb_sets.erl b/lib/stdlib/src/gb_sets.erl index 393fb07229..d3fbd542f7 100644 --- a/lib/stdlib/src/gb_sets.erl +++ b/lib/stdlib/src/gb_sets.erl @@ -137,6 +137,10 @@ %% approach is that it does not require the complete list of all %% elements to be built in memory at one time. %% +%% - iterator_from(X, S): returns an iterator that can be used for +%% traversing the elements of set S greater than or equal to X; +%% see `next'. +%% %% - next(T): returns {X, T1} where X is the smallest element referred %% to by the iterator T, and T1 is the new iterator to be used for %% traversing the remaining elements, or the atom `none' if no @@ -157,8 +161,8 @@ insert/2, add/2, delete/2, delete_any/2, balance/1, union/2, union/1, intersection/2, intersection/1, is_disjoint/2, difference/2, is_subset/2, to_list/1, from_list/1, from_ordset/1, smallest/1, - largest/1, take_smallest/1, take_largest/1, iterator/1, next/1, - filter/2, fold/3, is_set/1]). + largest/1, take_smallest/1, take_largest/1, iterator/1, + iterator_from/2, next/1, filter/2, fold/3, is_set/1]). %% `sets' compatibility aliases: @@ -500,6 +504,22 @@ iterator({_, L, _} = T, As) -> iterator(nil, As) -> As. +-spec iterator_from(Element, Set) -> Iter when + Set :: set(Element), + Iter :: iter(Element). + +iterator_from(S, {_, T}) -> + iterator_from(S, T, []). + +iterator_from(S, {K, _, T}, As) when K < S -> + iterator_from(S, T, As); +iterator_from(_, {_, nil, _} = T, As) -> + [T | As]; +iterator_from(S, {_, L, _} = T, As) -> + iterator_from(S, L, [T | As]); +iterator_from(_, nil, As) -> + As. + -spec next(Iter1) -> {Element, Iter2} | 'none' when Iter1 :: iter(Element), Iter2 :: iter(Element). diff --git a/lib/stdlib/src/gb_trees.erl b/lib/stdlib/src/gb_trees.erl index 7069b61873..259e8f718b 100644 --- a/lib/stdlib/src/gb_trees.erl +++ b/lib/stdlib/src/gb_trees.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2001-2014. All Rights Reserved. +%% Copyright Ericsson AB 2001-2015. All Rights Reserved. %% %% The contents of this file are subject to the Erlang Public License, %% Version 1.1, (the "License"); you may not use this file except in @@ -102,6 +102,10 @@ %% approach is that it does not require the complete list of all %% elements to be built in memory at one time. %% +%% - iterator_from(K, T): returns an iterator that can be used for +%% traversing the entries of tree T with key greater than or +%% equal to K; see `next'. +%% %% - next(S): returns {X, V, S1} where X is the smallest key referred to %% by the iterator S, and S1 is the new iterator to be used for %% traversing the remaining entries, or the atom `none' if no entries @@ -117,7 +121,7 @@ update/3, enter/3, delete/2, delete_any/2, balance/1, is_defined/2, keys/1, values/1, to_list/1, from_orddict/1, smallest/1, largest/1, take_smallest/1, take_largest/1, - iterator/1, next/1, map/2]). + iterator/1, iterator_from/2, next/1, map/2]). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -529,6 +533,29 @@ iterator({_, _, L, _} = T, As) -> iterator(nil, As) -> As. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +-spec iterator_from(Key, Tree) -> Iter when + Tree :: tree(Key, Value), + Iter :: iter(Key, Value). + +iterator_from(S, {_, T}) -> + iterator_1_from(S, T). + +iterator_1_from(S, T) -> + iterator_from(S, T, []). + +iterator_from(S, {K, _, _, T}, As) when K < S -> + iterator_from(S, T, As); +iterator_from(_, {_, _, nil, _} = T, As) -> + [T | As]; +iterator_from(S, {_, _, L, _} = T, As) -> + iterator_from(S, L, [T | As]); +iterator_from(_, nil, As) -> + As. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + -spec next(Iter1) -> 'none' | {Key, Value, Iter2} when Iter1 :: iter(Key, Value), Iter2 :: iter(Key, Value). diff --git a/lib/stdlib/src/maps.erl b/lib/stdlib/src/maps.erl index 3877c150ec..533ff08726 100644 --- a/lib/stdlib/src/maps.erl +++ b/lib/stdlib/src/maps.erl @@ -19,7 +19,8 @@ -module(maps). --export([get/3,fold/3, map/2, size/1, +-export([get/3,filter/2,fold/3, map/2, + size/1, without/2, with/2]). @@ -145,6 +146,19 @@ get(Key,Map,Default) -> erlang:error({badmap,Map},[Key,Map,Default]). +-spec filter(Pred,Map1) -> Map2 when + Pred :: fun((Key, Value) -> boolean()), + Key :: term(), + Value :: term(), + Map1 :: map(), + Map2 :: 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)]); +filter(Pred,Map) -> + erlang:error(error_type(Map),[Pred,Map]). + + -spec fold(Fun,Init,Map) -> Acc when Fun :: fun((K, V, AccIn) -> AccOut), Init :: term(), @@ -169,10 +183,7 @@ fold(Fun,Init,Map) -> V2 :: term(). map(Fun,Map) when is_function(Fun, 2), is_map(Map) -> - maps:from_list(lists:map(fun - ({K,V}) -> - {K,Fun(K,V)} - end,maps:to_list(Map))); + maps:from_list([{K,Fun(K,V)}||{K,V}<-maps:to_list(Map)]); map(Fun,Map) -> erlang:error(error_type(Map),[Fun,Map]). diff --git a/lib/stdlib/src/otp_internal.erl b/lib/stdlib/src/otp_internal.erl index 24721da187..0340015c35 100644 --- a/lib/stdlib/src/otp_internal.erl +++ b/lib/stdlib/src/otp_internal.erl @@ -631,6 +631,9 @@ obsolete_1(erl_lint, modify_line, 2) -> obsolete_1(ssl, negotiated_next_protocol, 1) -> {deprecated,{ssl,negotiated_protocol,1}}; +obsolete_1(ssl, connection_info, 1) -> + {deprecated, "deprecated; use connection_information/[1,2] instead"}; + obsolete_1(_, _, _) -> no. diff --git a/lib/stdlib/src/shell_default.erl b/lib/stdlib/src/shell_default.erl index 3fe359af0e..0fca7ff8c7 100644 --- a/lib/stdlib/src/shell_default.erl +++ b/lib/stdlib/src/shell_default.erl @@ -23,7 +23,7 @@ -module(shell_default). -export([help/0,lc/1,c/1,c/2,nc/1,nl/1,l/1,i/0,pid/3,i/3,m/0,m/1, - memory/0,memory/1, + memory/0,memory/1,uptime/0, erlangrc/1,bi/1, regs/0, flush/0,pwd/0,ls/0,ls/1,cd/1, y/1, y/2, xm/1, bt/1, q/0, @@ -92,6 +92,7 @@ pid(X,Y,Z) -> c:pid(X,Y,Z). pwd() -> c:pwd(). q() -> c:q(). regs() -> c:regs(). +uptime() -> c:uptime(). xm(Mod) -> c:xm(Mod). y(File) -> c:y(File). y(File, Opts) -> c:y(File, Opts). diff --git a/lib/stdlib/src/stdlib.app.src b/lib/stdlib/src/stdlib.app.src index a27a35dca2..c33130cf8c 100644 --- a/lib/stdlib/src/stdlib.app.src +++ b/lib/stdlib/src/stdlib.app.src @@ -104,7 +104,7 @@ dets]}, {applications, [kernel]}, {env, []}, - {runtime_dependencies, ["sasl-2.4","kernel-3.0.2","erts-7.0","crypto-3.3", + {runtime_dependencies, ["sasl-2.4","kernel-4.0","erts-7.0","crypto-3.3", "compiler-5.0"]} ]}. diff --git a/lib/stdlib/test/dict_SUITE.erl b/lib/stdlib/test/dict_SUITE.erl index 69814e12ce..ab624e8dd2 100644 --- a/lib/stdlib/test/dict_SUITE.erl +++ b/lib/stdlib/test/dict_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2008-2013. All Rights Reserved. +%% Copyright Ericsson AB 2008-2015. All Rights Reserved. %% %% The contents of this file are subject to the Erlang Public License, %% Version 1.1, (the "License"); you may not use this file except in @@ -25,16 +25,16 @@ -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, - create/1,store/1]). + create/1,store/1,iterate/1]). -include_lib("test_server/include/test_server.hrl"). --import(lists, [foldl/3,reverse/1]). +-import(lists, [foldl/3]). suite() -> [{ct_hooks,[ts_install_cth]}]. all() -> - [create, store]. + [create, store, iterate]. groups() -> []. @@ -93,6 +93,48 @@ store_1(List, M) -> D0. %%% +%%% Test specifics for gb_trees. +%%% + +iterate(Config) when is_list(Config) -> + test_all(fun iterate_1/1). + +iterate_1(M) -> + case M(module, []) of + gb_trees -> iterate_2(M); + _ -> ok + end, + M(empty, []). + +iterate_2(M) -> + random:seed(1, 2, 42), + iter_tree(M, 1000). + +iter_tree(_M, 0) -> + ok; +iter_tree(M, N) -> + L = [{I, I} || I <- lists:seq(1, N)], + T = M(from_list, L), + L = lists:reverse(iterate_tree(M, T)), + R = random:uniform(N), + KV = lists:reverse(iterate_tree_from(M, R, T)), + KV = [P || P={K,_} <- L, K >= R], + iter_tree(M, N-1). + +iterate_tree(M, Tree) -> + I = M(iterator, Tree), + iterate_tree_1(M, M(next, I), []). + +iterate_tree_from(M, Start, Tree) -> + I = M(iterator_from, {Start, Tree}), + iterate_tree_1(M, M(next, I), []). + +iterate_tree_1(_, none, R) -> + R; +iterate_tree_1(M, {K, V, I}, R) -> + iterate_tree_1(M, M(next, I), [{K, V} | R]). + +%%% %%% Helper functions. %%% diff --git a/lib/stdlib/test/dict_test_lib.erl b/lib/stdlib/test/dict_test_lib.erl index 4fdb4fa0bd..81d26ce5f8 100644 --- a/lib/stdlib/test/dict_test_lib.erl +++ b/lib/stdlib/test/dict_test_lib.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2008-2013. All Rights Reserved. +%% Copyright Ericsson AB 2008-2015. All Rights Reserved. %% %% The contents of this file are subject to the Erlang Public License, %% Version 1.1, (the "License"); you may not use this file except in @@ -29,6 +29,9 @@ new(Mod, Eq) -> (module, []) -> Mod; (size, D) -> Mod:size(D); (is_empty, D) -> Mod:is_empty(D); + (iterator, S) -> Mod:iterator(S); + (iterator_from, {Start, S}) -> Mod:iterator_from(Start, S); + (next, I) -> Mod:next(I); (to_list, D) -> to_list(Mod, D) end. diff --git a/lib/stdlib/test/ets_SUITE.erl b/lib/stdlib/test/ets_SUITE.erl index 41bd4af241..a88843bb6e 100644 --- a/lib/stdlib/test/ets_SUITE.erl +++ b/lib/stdlib/test/ets_SUITE.erl @@ -4078,12 +4078,22 @@ tab2file(doc) -> ["Check the ets:tab2file function on an empty " "ets table."]; tab2file(suite) -> []; tab2file(Config) when is_list(Config) -> + ?line FName = filename:join([?config(priv_dir, Config),"tab2file_case"]), + tab2file_do(FName, []), + tab2file_do(FName, [{sync,true}]), + tab2file_do(FName, [{sync,false}]), + {'EXIT',{{badmatch,{error,_}},_}} = (catch tab2file_do(FName, [{sync,yes}])), + {'EXIT',{{badmatch,{error,_}},_}} = (catch tab2file_do(FName, [sync])), + ok. + +tab2file_do(FName, Opts) -> %% Write an empty ets table to a file, read back and check properties. ?line Tab = ets_new(ets_SUITE_foo_tab, [named_table, set, private, {keypos, 2}]), - ?line FName = filename:join([?config(priv_dir, Config),"tab2file_case"]), - ?line ok = ets:tab2file(Tab, FName), - ?line true = ets:delete(Tab), + catch file:delete(FName), + Res = ets:tab2file(Tab, FName, Opts), + true = ets:delete(Tab), + ok = Res, % ?line EtsMem = etsmem(), ?line {ok, Tab2} = ets:file2tab(FName), @@ -4093,6 +4103,7 @@ tab2file(Config) when is_list(Config) -> ?line set = ets:info(Tab2, type), ?line true = ets:delete(Tab2), ?line verify_etsmem(EtsMem). + tab2file2(doc) -> ["Check the ets:tab2file function on a ", "filled set/bag type ets table."]; diff --git a/lib/stdlib/test/maps_SUITE.erl b/lib/stdlib/test/maps_SUITE.erl index 1d9c041a74..f8f241d834 100644 --- a/lib/stdlib/test/maps_SUITE.erl +++ b/lib/stdlib/test/maps_SUITE.erl @@ -34,18 +34,21 @@ -export([init_per_testcase/2]). -export([end_per_testcase/2]). --export([t_get_3/1, +-export([t_get_3/1, t_filter_2/1, t_fold_3/1,t_map_2/1,t_size_1/1, t_with_2/1,t_without_2/1]). --define(badmap(V,F,Args), {'EXIT', {{badmap,V}, [{maps,F,Args,_}|_]}}). --define(badarg(F,Args), {'EXIT', {badarg, [{maps,F,Args,_}|_]}}). +%-define(badmap(V,F,Args), {'EXIT', {{badmap,V}, [{maps,F,Args,_}|_]}}). +%-define(badarg(F,Args), {'EXIT', {badarg, [{maps,F,Args,_}|_]}}). +% silly broken hipe +-define(badmap(V,F,_Args), {'EXIT', {{badmap,V}, [{maps,F,_,_}|_]}}). +-define(badarg(F,_Args), {'EXIT', {badarg, [{maps,F,_,_}|_]}}). suite() -> [{ct_hooks, [ts_install_cth]}]. all() -> - [t_get_3, + [t_get_3,t_filter_2, t_fold_3,t_map_2,t_size_1, t_with_2,t_without_2]. @@ -99,6 +102,16 @@ t_with_2(_Config) -> ?badarg(with,[a,#{}]) = (catch maps:with(a,#{})), ok. +t_filter_2(Config) when is_list(Config) -> + M = #{a => 2, b => 3, c=> 4, "a" => 1, "b" => 2, "c" => 4}, + Pred1 = fun(K,V) -> is_atom(K) andalso (V rem 2) =:= 0 end, + 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), + %% error case + ?badmap(a,filter,[_,a]) = (catch maps:filter(fun(_,_) -> ok end,id(a))), + ?badarg(filter,[<<>>,#{}]) = (catch maps:filter(id(<<>>),#{})), + ok. t_fold_3(Config) when is_list(Config) -> Vs = lists:seq(1,200), diff --git a/lib/stdlib/test/sets_SUITE.erl b/lib/stdlib/test/sets_SUITE.erl index c0cf1fc7e8..24f5d65f82 100644 --- a/lib/stdlib/test/sets_SUITE.erl +++ b/lib/stdlib/test/sets_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2004-2013. All Rights Reserved. +%% Copyright Ericsson AB 2004-2015. All Rights Reserved. %% %% The contents of this file are subject to the Erlang Public License, %% Version 1.1, (the "License"); you may not use this file except in @@ -28,7 +28,7 @@ create/1,add_element/1,del_element/1, subtract/1,intersection/1,union/1,is_subset/1, is_set/1,fold/1,filter/1, - take_smallest/1,take_largest/1]). + take_smallest/1,take_largest/1, iterate/1]). -include_lib("test_server/include/test_server.hrl"). @@ -48,7 +48,7 @@ suite() -> [{ct_hooks,[ts_install_cth]}]. all() -> [create, add_element, del_element, subtract, intersection, union, is_subset, is_set, fold, filter, - take_smallest, take_largest]. + take_smallest, take_largest, iterate]. groups() -> []. @@ -426,6 +426,44 @@ take_largest_3(S0, List0, M) -> take_largest_3(S, List, M) end. +iterate(Config) when is_list(Config) -> + test_all(fun iterate_1/1). + +iterate_1(M) -> + case M(module, []) of + gb_sets -> iterate_2(M); + _ -> ok + end, + M(empty, []). + +iterate_2(M) -> + random:seed(1, 2, 42), + iter_set(M, 1000). + +iter_set(_M, 0) -> + ok; +iter_set(M, N) -> + L = [I || I <- lists:seq(1, N)], + T = M(from_list, L), + L = lists:reverse(iterate_set(M, T)), + R = random:uniform(N), + S = lists:reverse(iterate_set(M, R, T)), + S = [E || E <- L, E >= R], + iter_set(M, N-1). + +iterate_set(M, Set) -> + I = M(iterator, Set), + iterate_set_1(M, M(next, I), []). + +iterate_set(M, Start, Set) -> + I = M(iterator_from, {Start, Set}), + iterate_set_1(M, M(next, I), []). + +iterate_set_1(_, none, R) -> + R; +iterate_set_1(M, {E, I}, R) -> + iterate_set_1(M, M(next, I), [E | R]). + %%% %%% Helper functions. %%% diff --git a/lib/stdlib/test/sets_test_lib.erl b/lib/stdlib/test/sets_test_lib.erl index 86f009a8f9..772139406d 100644 --- a/lib/stdlib/test/sets_test_lib.erl +++ b/lib/stdlib/test/sets_test_lib.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2004-2013. All Rights Reserved. +%% Copyright Ericsson AB 2004-2015. All Rights Reserved. %% %% The contents of this file are subject to the Erlang Public License, %% Version 1.1, (the "License"); you may not use this file except in @@ -34,7 +34,10 @@ new(Mod, Eq) -> (is_empty, S) -> is_empty(Mod, S); (is_set, S) -> Mod:is_set(S); (is_subset, {S,Set}) -> is_subset(Mod, Eq, S, Set); + (iterator, S) -> Mod:iterator(S); + (iterator_from, {Start, S}) -> Mod:iterator_from(Start, S); (module, []) -> Mod; + (next, I) -> Mod:next(I); (singleton, E) -> singleton(Mod, E); (size, S) -> Mod:size(S); (subtract, {S1,S2}) -> subtract(Mod, S1, S2); diff --git a/lib/syntax_tools/doc/overview.edoc b/lib/syntax_tools/doc/overview.edoc index df02ad0b3a..3111633a99 100644 --- a/lib/syntax_tools/doc/overview.edoc +++ b/lib/syntax_tools/doc/overview.edoc @@ -2,79 +2,34 @@ Syntax Tools overview page - @author Richard Carlsson <[email protected]> -@copyright 1997-2004 Richard Carlsson +@copyright 1997-2014 Richard Carlsson @version {@version} -@title Erlang Syntax Tools +@title Erlang Syntax and Metaprogramming tools -@doc This package contains modules for handling abstract Erlang syntax -trees, in a way that is compatible with the "parse trees" of the -standard library module `erl_parse', together with utilities for reading -source files in unusual ways and pretty-printing syntax trees. Also -included is an amazing module merger and renamer called Igor, as well as -an automatic code-cleaner. +@doc This package contains modules for handling abstract syntax trees (ASTs) +in Erlang, in a way that is compatible with the "abstract format" parse +trees of the stdlib module `erl_parse', together with utilities for reading +source files, {@link erl_prettypr. pretty-printing syntax trees}, {@link +igor. merging and renaming modules}, {@link erl_tidy. cleaning up obsolete +constructs}, and doing {@link merl. metaprogramming} in Erlang. -<p>The abstract layer (defined in {@link erl_syntax}) is nicely +The abstract layer (defined in {@link erl_syntax}) is nicely structured and the node types are context-independent. The layer makes it possible to transparently attach source-code comments and user annotations to nodes of the tree. Using the abstract layer makes applications less sensitive to changes in the {@link //stdlib/erl_parse} -data structures, only requiring the {@link erl_syntax} module to be -up-to-date.</p> +data structures, only requiring the `erl_syntax' module to be up-to-date. -<p>The pretty printer {@link erl_prettypr} is implemented on top of the +The pretty printer {@link erl_prettypr} is implemented on top of the library module {@link prettypr}: this is a powerful and flexible generic -pretty printing library, which is also distributed separately.</p> - -<p>For a short demonstration of parsing and pretty-printing, simply -compile the included module <a -href="../examples/demo.erl"><code>demo.erl</code></a>, and execute -<code>demo:run()</code> from the Erlang shell. It will compile the -remaining modules and give you further instructions.</p> - -<p>Also try the {@link erl_tidy} module, as follows: -<pre> - erl_tidy:dir("any-erlang-source-dir", [test, old_guard_tests]).</pre> -("<code>test</code>" assures that no files are modified).</p> - -<p>News in 1.4: -<ul> - <li>Added support for {@link erl_syntax:cond_expr/1. cond-expressions}, - {@link erl_syntax:try_expr/4. try-expressions} and - {@link erl_syntax:class_qualifier/2. class-qualifier patterns}.</li> - <li>Added support for parameterized modules.</li> - <li>{@link igor. Igor} is officially included.</li> - <li>Quick-parse functionality added to {@link epp_dodger}.</li> -</ul> -</p> - -<p>News in 1.3: -<ul> - <li>Added support for qualified names (as used by "packages").</li> - <li>Various internal changes.</li> -</ul> -</p> +pretty printing library, which is also distributed separately. -<p>News in 1.2: -<ul> - <li>HTML Documentation (generated with EDoc).</li> - <li>A few bug fixes and some minor interface changes (sorry for any - inconvenience).</li> -</ul> -</p> +For a short demonstration of parsing and pretty-printing, simply +compile the included module <a href="../examples/demo.erl">`demo.erl'</a>, +and execute `demo:run()' from the Erlang shell. It will compile the +remaining modules and give you further instructions. -<p>News in 1.1: -<ul> - <li>Module {@link erl_tidy}: check or tidy either a single module, or a - whole directory tree recursively. Rewrites and reformats the code - without losing comments or expanding macros. Safe mode allows - generating reports without modifying files.</li> - <li>Module {@link erl_syntax_lib}: contains support functions for easier - analysis of the source code structure.</li> - <li>Module {@link epp_dodger}: Bypasses the Erlang preprocessor - avoids - macro expansion, file inclusion, conditional compilation, etc. - Allows you to find/modify particular definitions/applications of - macros, and other things previously not possible.</li> -</ul> -</p> +Also try the {@link erl_tidy} module, as follows: +```erl_tidy:dir("any-erlang-source-dir", [test, old_guard_tests]).''' +(the `test' option assures that no files are modified). diff --git a/lib/syntax_tools/doc/src/Makefile b/lib/syntax_tools/doc/src/Makefile index 2502bf877a..b7c599a9b9 100644 --- a/lib/syntax_tools/doc/src/Makefile +++ b/lib/syntax_tools/doc/src/Makefile @@ -50,6 +50,8 @@ XML_REF3_FILES = \ erl_syntax_lib.xml \ erl_tidy.xml \ igor.xml \ + merl.xml \ + merl_transform.xml \ prettypr.xml XML_PART_FILES = part.xml part_notes.xml diff --git a/lib/syntax_tools/doc/src/ref_man.xml b/lib/syntax_tools/doc/src/ref_man.xml index 598f656011..2b114c8528 100644 --- a/lib/syntax_tools/doc/src/ref_man.xml +++ b/lib/syntax_tools/doc/src/ref_man.xml @@ -29,12 +29,11 @@ </header> <description> <p><em>Syntax_Tools</em> contains modules for handling abstract - Erlang syntax trees, in a way that is compatible with the "parse - trees" of the STDLIB module <c>erl_parse</c>, together with - utilities for reading source files in unusual ways and - pretty-printing syntax trees. Also included is an amazing module - merger and renamer called Igor, as well as an automatic - code-cleaner.</p> + Erlang syntax trees, in a way that is compatible with the "external + format" parse trees of the STDLIB module <c>erl_parse</c>, together + with utilities for reading source files, pretty-printing syntax trees, + merging and renaming modules, cleaning up obsolete constructs, and + doing metaprogramming in Erlang.</p> </description> <xi:include href="epp_dodger.xml"/> <xi:include href="erl_comment_scan.xml"/> @@ -44,6 +43,8 @@ <xi:include href="erl_syntax_lib.xml"/> <xi:include href="erl_tidy.xml"/> <xi:include href="igor.xml"/> + <xi:include href="merl.xml"/> + <xi:include href="merl_transform.xml"/> <xi:include href="prettypr.xml"/> </application> diff --git a/lib/syntax_tools/examples/merl/Makefile b/lib/syntax_tools/examples/merl/Makefile new file mode 100644 index 0000000000..13a9703733 --- /dev/null +++ b/lib/syntax_tools/examples/merl/Makefile @@ -0,0 +1,22 @@ +EBIN=../../ebin +INCLUDES=../../include +SOURCES=merl_build.erl lisp.erl lispc.erl basic.erl basicc.erl +HEADERS=$(INCLUDES)/merl.hrl +OBJECTS=$(SOURCES:%.erl=%.beam) +ERLC_FLAGS=+debug_info -I$(INCLUDES) -pa $(EBIN) + +all: $(OBJECTS) test + +%.beam: %.erl $(HEADERS) Makefile + erlc $(ERLC_FLAGS) -o ./ $< + +# additional dependencies due to the parse transform +lispc.beam basicc.beam: $(EBIN)/merl_transform.beam $(EBIN)/merl.beam + +clean: + -rm -f $(OBJECTS) + +test: + erl -noshell -pa $(EBIN) \ + -eval 'eunit:test([lisp, lispc, basic, basicc],[])' \ + -s init stop diff --git a/lib/syntax_tools/examples/merl/basic.erl b/lib/syntax_tools/examples/merl/basic.erl new file mode 100644 index 0000000000..9030059d11 --- /dev/null +++ b/lib/syntax_tools/examples/merl/basic.erl @@ -0,0 +1,77 @@ +%% --------------------------------------------------------------------- +%% 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. +%% +%% @author Richard Carlsson <[email protected]> +%% @copyright 2012 Richard Carlsson +%% @doc Trivial Basic interpreter in Erlang + +-module(basic). + +-export([run/2]). + +-include_lib("eunit/include/eunit.hrl"). + +-define(INTERPRETED, true). +-include("basic_test.erl"). + +run(N, Prog) -> + ets:new(var, [private, named_table]), + ets:new(line, [private, named_table, ordered_set]), + lists:foreach(fun (T) -> ets:insert(line, T) end, Prog), + goto(N). + +stop(N) -> + ets:delete(var), + ets:delete(line), + N. + +goto('$end_of_table') -> stop(0); +goto(L) -> + L1 = ets:next(line, L), + %% user-supplied line numbers might not exist + case ets:lookup(line, L) of + [{_, X}] -> + stmt(X, L1); + _ -> + goto(L1) + end. + +stmt({print, S, As}, L) -> io:format(S, [expr(A) || A <- As]), goto(L); +stmt({set, V, X}, L) -> ets:insert(var, {V, expr(X)}), goto(L); +stmt({goto, X}, _L) -> goto(expr(X)); +stmt({stop, X}, _L) -> stop(expr(X)); +stmt({iff, X, A, B}, _L) -> + case expr(X) of + 0 -> goto(B); + _ -> goto(A) + end. + +expr(X) when is_number(X) ; is_list(X) -> + X; +expr(X) when is_atom(X) -> + case ets:lookup(var, X) of + [] -> 0; + [{_,V}] -> V + end; +expr({plus, X, Y}) -> + expr(X) + expr(Y); +expr({equal, X, Y}) -> + bool(expr(X) == expr(Y)); +expr({gt, X, Y}) -> + bool(expr(X) > expr(Y)); +expr({knot, X}) -> + case expr(X) of + 0 -> 1; + _ -> 0 + end. + +bool(true) -> 1; +bool(false) -> 0. diff --git a/lib/syntax_tools/examples/merl/basic_test.erl b/lib/syntax_tools/examples/merl/basic_test.erl new file mode 100644 index 0000000000..ff35de6325 --- /dev/null +++ b/lib/syntax_tools/examples/merl/basic_test.erl @@ -0,0 +1,77 @@ +%% --------------------------------------------------------------------- +%% 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. +%% +%% @author Richard Carlsson <[email protected]> +%% @copyright 2012 Richard Carlsson +%% @doc Tests. For including in another module. + +%-module(basic_test). +%-import(basic, run/1) + +-export([basic_fib/1]). + +-include_lib("eunit/include/eunit.hrl"). + +basics_test_() -> + [?_assertEqual(42, run(1,[{1,{stop, 42}}])), + ?_assertEqual("hello", run(1,[{1,{stop,"hello"}}])), + ?_assertEqual(0, run(1,[{1,{print, "hello ~w", [42]}}])), + ?_assertEqual(5, run(1,[{1,{stop, {plus, 2, 3}}}])), + ?_assertEqual(5, run(1,[{1,{stop,{plus, 8, -3}}}])), + ?_assertEqual(0, run(1,[{1,{stop,{equal, 0, 1}}}])), + ?_assertEqual(1, run(1,[{1,{stop,{equal, 1, 1}}}])), + ?_assertEqual(0, run(1,[{1,{stop,{gt, 0, 1}}}])), + ?_assertEqual(0, run(1,[{1,{stop,{gt, 1, 1}}}])), + ?_assertEqual(1, run(1,[{1,{stop,{gt, 2, 1}}}])), + ?_assertEqual(0, run(1,[{1,{stop,{knot, 42}}}])), + ?_assertEqual(1, run(1,[{1,{stop,{knot, 0}}}])), + ?_assertEqual(42, run(1,[{1,{set, x, 42}}, {2,{stop,x}}])), + ?_assertEqual(17, run(1,[{1,{iff, 1, 2, 3}}, + {2,{stop, 17}}, + {3,{stop, 42}}])), + ?_assertEqual(42, run(1,[{1,{iff, 0, 2, 3}}, + {2,{stop, 17}}, + {3,{stop, 42}}])), + ?_assertEqual(17, run(1,[{1,{iff, 1, 2, 3}}, + {2,{stop, 17}}, + {3,{stop, -1}}])), + ?_assertEqual(42, run(1,[{1,{iff, 0, 2, 3}}, + {2,{stop, -1}}, + {3,{stop, 42}}])) + + + ]. + + +fib_test_() -> + [?_assertEqual(fib(N), basic_fib(N)) || N <- lists:seq(1,15) + ]. + + +fib(N) when N > 1 -> + fib(N-1) + fib(N-2); +fib(_) -> + 1. + +basic_fib(N) -> + run(1, + [{1,{set,x,0}}, + {2,{set,a,1}}, + {3,{set,b,0}}, + {10,{iff, {equal, x, N}, 20, 30}}, + {20,{stop,a}}, + {30,{print,"~w, ~w, ~w\n",[x,a,b]}}, + {31,{set,t,a}}, + {32,{set,a,{plus,a,b}}}, + {33,{set,b,t}}, + {34,{set,x,{plus,x,1}}}, + {40,{goto,10}} + ]). diff --git a/lib/syntax_tools/examples/merl/basicc.erl b/lib/syntax_tools/examples/merl/basicc.erl new file mode 100644 index 0000000000..531ac51538 --- /dev/null +++ b/lib/syntax_tools/examples/merl/basicc.erl @@ -0,0 +1,149 @@ +%% --------------------------------------------------------------------- +%% 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. +%% +%% @author Richard Carlsson <[email protected]> +%% @copyright 2012 Richard Carlsson +%% @doc Basic compiler in Erlang. + +-module(basicc). + +-export([run/2, make_lines/1, bool/1]). + +-include_lib("eunit/include/eunit.hrl"). + +-define(INTERPRETED, true). +-include("basic_test.erl"). + +-include("merl.hrl"). + +run(N, Prog) -> + compile(Prog, tmp), + tmp:run(N, Prog). + +make_lines(Prog) -> + ets:new(line, [private, named_table, ordered_set]), + lists:foreach(fun ({L,_}) -> ets:insert(line, {L,label(L)}) end, Prog). + +compile(Prog, ModName) -> + make_lines(Prog), + Fs0 = lists:map(fun ({L, X}) -> + {true, label(L), + case stmt(X) of + {Stmt, false} -> + [?Q("() -> _@Stmt")]; + {Stmt, true} -> + Next = case ets:next(line, L) of + '$end_of_table' -> + ?Q("stop(0)"); + L1 -> + Label = label(L1), + ?Q("_@Label@()") + end, + [?Q("() -> _@Stmt, _@Next")] + end} + end, Prog), + ets:delete(line), + Run = ?Q(["(N, Prog) ->", + " ets:new(var, [private, named_table]),", + " basicc:make_lines(Prog),", + " goto(N)" + ]), + Stop = ?Q(["(R) ->", + " ets:delete(var),", + " ets:delete(line),", + " R" + ]), + Goto = ?Q(["(L) ->", + " case ets:lookup(line, L) of", + " [{_, X}] -> apply(tmp, X, []);", + " _ ->", + " case ets:next(line, L) of", + " '$end_of_table' -> stop(0);", + " L1 -> goto(L1)", + " end", + " end"]), + Fs = [{true, run, [Run]}, + {false, stop, [Stop]}, + {true, goto, [Goto]} + | Fs0], + Forms = merl_build:module_forms( + lists:foldl(fun ({X, Name, Cs}, S) -> + merl_build:add_function(X, Name, Cs, S) + end, + merl_build:init_module(ModName), + Fs)), + %% %% Write source to file for debugging + %% file:write_file(lists:concat([ModName, "_gen.erl"]), + %% erl_prettypr:format(erl_syntax:form_list(Forms), + %% [{paper,160},{ribbon,80}])), + merl:compile_and_load(Forms, [verbose]). + +label(L) -> + list_to_atom("label_" ++ integer_to_list(L)). + +stmt({print, S, As}) -> + Exprs = [expr(A) || A <- As], + {[?Q(["io:format(_@S@, [_@Exprs])"])], true}; +stmt({set, V, X}) -> + Expr = expr(X), + {[?Q(["ets:insert(var, {_@V@, _@Expr})"])], true}; +stmt({goto, X}) -> + {[jump(X)], false}; +stmt({stop, X}) -> + Expr = expr(X), + {[?Q(["stop(_@Expr)"])], false}; +stmt({iff, X, A, B}) -> + Cond = expr(X), + True = jump(A), + False = jump(B), + {?Q(["case _@Cond of", + " 0 -> _@False;", + " _ -> _@True", + "end"]), + false}. + +jump(X) -> + case ets:lookup(line, X) of + [{_, F}] -> + ?Q(["_@F@()"]); + true -> + Expr = expr(X), + [?Q(["goto(_@Expr)"])] + end. + +expr(X) when is_number(X) ; is_list(X) -> + ?Q("_@X@"); +expr(X) when is_atom(X) -> + ?Q(["case ets:lookup(var, _@X@) of", + " [] -> 0;", + " [{_,V}] -> V", + "end"]); +expr({plus, X, Y}) -> + ExprX = expr(X), + ExprY = expr(Y), + ?Q("_@ExprX + _@ExprY"); +expr({equal, X, Y}) -> + ExprX = expr(X), + ExprY = expr(Y), + ?Q("basicc:bool(_@ExprX == _@ExprY)"); +expr({gt, X, Y}) -> + ExprX = expr(X), + ExprY = expr(Y), + ?Q("basicc:bool(_@ExprX > _@ExprY)"); +expr({knot, X}) -> + Expr = expr(X), + ?Q(["case _@Expr of", + " 0 -> 1;", + " _ -> 0", + "end"]). + +bool(true) -> 1; +bool(false) -> 0. diff --git a/lib/syntax_tools/examples/merl/lisp.erl b/lib/syntax_tools/examples/merl/lisp.erl new file mode 100644 index 0000000000..371dc6b261 --- /dev/null +++ b/lib/syntax_tools/examples/merl/lisp.erl @@ -0,0 +1,160 @@ +%% --------------------------------------------------------------------- +%% 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. +%% +%% @author Richard Carlsson <[email protected]> +%% @copyright 2012 Richard Carlsson +%% @doc Trivial Lisp interpreter in Erlang. + +-module(lisp). + +-export([eval/1]). + +-export([init/0, equal/2, gt/2, knot/1]). + +-record(st, {env}). + +-define(INTERPRETED, true). +-include("lisp_test.erl"). + +eval(P) -> + {X, _} = eval(P, init()), + X. + +init() -> + Env = [{print, {builtin, fun do_print/2}} + ,{list, {builtin, fun do_list/2}} + ,{apply, {builtin, fun do_apply/2}} + ,{plus, {builtin, fun do_plus/2}} + ,{equal, {builtin, fun do_equal/2}} + ,{gt, {builtin, fun do_gt/2}} + ,{knot, {builtin, fun do_knot/2}} + ,{y, y()} + ], + #st{env=dict:from_list(Env)}. + +eval([lambda, Ps, B], #st{env=E}=St) when is_list(Ps) -> + case lists:all(fun is_atom/1, Ps) andalso + (length(Ps) =:= length(lists:usort(Ps))) of + true -> {{lambda, Ps, B, E}, St}; + false -> throw(bad_lambda) + end; +eval([lambda | _], _) -> + throw(bad_lambda); +eval([def, A, V, B], #st{env=E0}=St) when is_atom(A) -> + {V1, St1} = eval(V, St), + E1 = bind(A, V1, E0), + {X, St2} = eval(B, St1#st{env=E1}), + {X, St2#st{env=E0}}; +eval([def | _], _) -> + throw(bad_def); +eval([quote, A], St) -> + {A, St}; +eval([quote | _], _) -> + throw(bad_quote); +eval([iff, X, A, B], St) -> + case eval(X, St) of + {[], St1} -> eval(B, St1); + {_, St1} -> eval(A, St1) + end; +eval([do], _St0) -> + throw(bad_do); +eval([do | As], St0) -> + lists:foldl(fun (X, {_,St}) -> eval(X, St) end, {[],St0}, As); +eval([_|_]=L, St) -> + {[F | As], St1} = lists:mapfoldl(fun eval/2, St, L), + call(F, As, St1); +eval(A, St) when is_atom(A) -> + {deref(A, St), St}; +eval(C, St) -> + {C, St}. + +%% UTILITY FUNCTIONS + +deref(A, #st{env=E}) -> + case dict:find(A, E) of + {ok, V} -> V; + error -> throw({undefined, A}) + end. + +bind(A, V, E) -> + dict:store(A, V, E). + +bind_args([P | Ps], [A | As], E) -> + bind_args(Ps, As, dict:store(P, A, E)); +bind_args([], [], E) -> + E; +bind_args(_, _, _) -> + throw(bad_arity). + +call({lambda, Ps, B, E}, As, #st{env=E0}=St) -> + {X, St1} = eval(B, St#st{env=bind_args(Ps, As, E)}), + {X, St1#st{env=E0}}; +call({builtin, F}, As, St) -> + F(As, St); +call(X, _, _) -> + throw({bad_fun, X}). + +bool(true) -> 1; +bool(false) -> []. + +%% BUILTINS + +y() -> + {Y, _} = eval([lambda, [f], + [[lambda, [x], [f, [lambda, [y], [[x, x], y]]]], + [lambda, [x], [f, [lambda, [y], [[x, x], y]]]]]], + #st{env=dict:new()}), + Y. + +do_print([S | Xs], St) -> + io:format(S, Xs), + {[], St}; +do_print(_, _) -> + throw(bad_print). + +do_list(As, St) -> + {As, St}. + +do_apply([F, As], St) -> + call(F, As, St); +do_apply(_, _) -> + throw(bad_apply). + +do_plus([X, Y], St) when is_number(X), is_number(Y) -> + {X + Y, St}; +do_plus(As, _) -> + throw({bad_plus, As}). + +do_equal([X, Y], St) -> + {equal(X, Y), St}; +do_equal(As, _) -> + throw({bad_equal, As}). + +equal(X, Y) -> + bool(X =:= Y). + +do_gt([X, Y], St) -> + {gt(X, Y), St}; +do_gt(As, _) -> + throw({bad_gt, As}). + +gt(X, Y) -> + bool(X > Y). + +do_knot([X], St) -> + {knot(X), St}; +do_knot(As, _) -> + throw({bad_gt, As}). + +knot([]) -> + 1; +knot(_) -> + []. diff --git a/lib/syntax_tools/examples/merl/lisp_test.erl b/lib/syntax_tools/examples/merl/lisp_test.erl new file mode 100644 index 0000000000..cab8134b8f --- /dev/null +++ b/lib/syntax_tools/examples/merl/lisp_test.erl @@ -0,0 +1,98 @@ +%% --------------------------------------------------------------------- +%% 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. +%% +%% @author Richard Carlsson <[email protected]> +%% @copyright 2012 Richard Carlsson +%% @doc Tests. For including in another module. + +%-module(lisp_test). +%-import(lisp, eval/1) + +-export([fib/1, lisp_fib/1]). + +-include_lib("eunit/include/eunit.hrl"). + +basics_test_() -> + [?_assertEqual(42, eval(42)), + ?_assertEqual("hello", eval([quote, "hello"])), + ?_assertEqual(print, eval([quote, print])), + ?_assertMatch([17,[1,2],42], eval([list,17,[list,1,2],42])), + ?_assertEqual([], eval([print, [quote, "hello ~w"], [list, 42]])), + ?_assertEqual(5, eval([plus, 2, 3])), + ?_assertEqual(5, eval([plus, 8, -3])), + ?_assertEqual([], eval([equal, 0, 1])), + ?_assertEqual(1, eval([equal, 1, 1])), + ?_assertEqual([], eval([gt, 0, 1])), + ?_assertEqual([], eval([gt, 1, 1])), + ?_assertEqual(1, eval([gt, 2, 1])), + ?_assertEqual([], eval([knot, 42])), + ?_assertEqual(1, eval([knot, []])), + ?_assertEqual(42, eval([do, 17, 42])), + ?_assertEqual([], eval([apply, print, [quote, ["~p", [42]]]])), + ?_assertEqual(42, eval([iff, [], 17, 42])), + ?_assertEqual(17, eval([iff, 1, 17, 42])), + ?_assertEqual(42, eval([iff, [], [apply], 42])), + ?_assertEqual(17, eval([iff, 1, 17, [apply]])), + ?_assertEqual(17, eval([def, foo, 17, foo])), + ?_assertEqual(17, eval([def, bar, 42, [def, foo, 17, foo]])), + ?_assertEqual(42, eval([def, bar, 42, [def, foo, 17, bar]])), + ?_assertEqual(17, eval([def, foo, 42, [def, foo, 17, foo]])) + ]. + +-ifdef(INTERPRETED). +interpreter_basics_test_() -> + [?_assertThrow({undefined, foo}, eval(foo)), + ?_assertMatch({builtin,_}, eval(print)), + ?_assertThrow(bad_do, eval([do])), + ?_assertThrow(bad_apply, eval([apply])), + ?_assertThrow({undefined, foo}, eval([def, bar, 17, foo])) + ]. + +interpreter_lambda_test_() -> + [?_assertMatch({lambda,_,_,_}, eval([lambda, [], 42])), + ?_assertMatch({lambda,_,_,_}, eval([lambda, [x], x])), + ?_assertMatch({lambda,_,_,_}, eval([lambda, [x,y], 42])) + ]. +-endif. + +lambda_test_() -> + [?_assertThrow(bad_lambda, eval([lambda])), + ?_assertThrow(bad_lambda, eval([lambda, []])), + ?_assertThrow(bad_lambda, eval([lambda, [], 17, 42])), + ?_assertThrow(bad_lambda, eval([lambda, 17, 42])), + ?_assertThrow(bad_lambda, eval([lambda, [17], 42])), + ?_assertThrow(bad_lambda, eval([lambda, [foo, foo], 42])), + ?_assertEqual(42, eval([[lambda, [x], x], 42])), + ?_assertEqual([42, 17], eval([[lambda, [x], [list, x, 17]], 42])), + ?_assertEqual([42, 17], eval([def, f, [def, y, 42, + [lambda, [x], [list, y, x]]], + [f, 17]])) + ]. + +fib_test_() -> + [?_assertEqual(fib(N), lisp_fib(N)) || N <- lists:seq(1,15) + ]. + + +fib(N) when N > 1 -> + fib(N-1) + fib(N-2); +fib(_) -> + 1. + +lisp_fib(N) -> + eval([def, fib, + [y, [lambda, [f], [lambda, [x], + [iff, [gt, x, 1], + [plus, [f, [plus,x,-1]], [f, [plus,x,-2]]], + 1] + ]]], + [fib, N] + ]). diff --git a/lib/syntax_tools/examples/merl/lispc.erl b/lib/syntax_tools/examples/merl/lispc.erl new file mode 100644 index 0000000000..97072cdab7 --- /dev/null +++ b/lib/syntax_tools/examples/merl/lispc.erl @@ -0,0 +1,102 @@ +%% --------------------------------------------------------------------- +%% 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. +%% +%% @author Richard Carlsson <[email protected]> +%% @copyright 2012 Richard Carlsson +%% @doc Lisp compiler in Erlang. + +-module(lispc). + +-export([eval/1]). + +-record(st, {}). + +-include("lisp_test.erl"). + +-include("merl.hrl"). + +eval(Lisp) -> + compile(Lisp, tmp), + tmp:eval(). + +compile(Lisp, ModName) -> + {Code, _} = gen(Lisp, #st{}), + Main = ?Q(["() ->", + " __print = fun (S, Xs) -> io:format(S,Xs), [] end,", + " __apply = fun erlang:apply/2,", + " __plus = fun erlang:'+'/2,", + " __equal = fun lisp:equal/2,", + " __gt = fun lisp:gt/2,", + " __knot = fun lisp:knot/1,", + " __y = fun (F) ->", + " (fun (X) -> F(fun (Y) -> (X(X))(Y) end) end)", + " (fun (X) -> F(fun (Y) -> (X(X))(Y) end) end)", + " end,", + " _@Code"]), + Forms = merl_build:module_forms( + merl_build:add_function(true, eval, [Main], + merl_build:init_module(ModName))), + %% %% Write source to file for debugging + %% file:write_file(lists:concat([ModName, "_gen.erl"]), + %% erl_prettypr:format(erl_syntax:form_list(Forms), + %% [{paper,160},{ribbon,80}])), + merl:compile_and_load(Forms, [verbose]). + +var(Atom) -> + merl:var(list_to_atom("__" ++ atom_to_list(Atom))). + +gen([lambda, Ps, B], St) when is_list(Ps) -> + case lists:all(fun is_atom/1, Ps) andalso + (length(Ps) =:= length(lists:usort(Ps))) of + true -> + Vars = [var(P) || P <- Ps], + {Body, St1} = gen(B, St), + {?Q("fun (_@Vars) -> _@Body end"), St1}; + false -> + throw(bad_lambda) + end; +gen([lambda | _], _) -> + throw(bad_lambda); +gen([def, A, V, B], St) when is_atom(A) -> + Var = var(A), + {Val, St1} = gen(V, St), + {Body, St2} = gen(B, St1), + {?Q("(fun (_@Var) -> _@Body end)(_@Val)"), St2}; +gen([def | _], _) -> + throw(bad_def); +gen([quote, A], St) -> + {merl:term(A), St}; +gen([quote | _], _) -> + throw(bad_quote); +gen([iff, X, A, B], St) -> + {Cond, St1} = gen(X, St), + {True, St2} = gen(A, St1), + {False, St3} = gen(B, St2), + {?Q(["case _@Cond of", + " [] -> _@False;", + " _ -> _@True", + "end"]), + St3}; +gen([do], _) -> + throw(bad_do); +gen([do | As], St0) -> + {Body, St1} = lists:mapfoldl(fun gen/2, St0, As), + {?Q("begin _@Body end"), St1}; +gen([list | As], St0) -> + {Elem, St1} = lists:mapfoldl(fun gen/2, St0, As), + {?Q("[ _@Elem ]"), St1}; +gen([_|_]=L, St) -> + {[F | As], St1} = lists:mapfoldl(fun gen/2, St, L), + {?Q("((_@F)(_@As))"), St1}; +gen(A, St) when is_atom(A) -> + {var(A), St}; +gen(C, St) -> + {merl:term(C), St}. diff --git a/lib/syntax_tools/examples/merl/merl_build.erl b/lib/syntax_tools/examples/merl/merl_build.erl new file mode 100644 index 0000000000..c539f8e2af --- /dev/null +++ b/lib/syntax_tools/examples/merl/merl_build.erl @@ -0,0 +1,104 @@ +%% --------------------------------------------------------------------- +%% 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. +%% +%% @author Richard Carlsson <[email protected]> +%% @copyright 2012 Richard Carlsson +%% @doc Making it simple to build a module with merl + +-module(merl_build). + +-export([init_module/1, module_forms/1, add_function/4, add_record/3, + add_import/3, add_attribute/3, set_file/2]). + +-import(merl, [term/1]). + +-include("merl.hrl"). + +-type filename() :: string(). + +-record(module, { name :: atom() + , file :: filename() + , exports=[] :: [{atom(), integer()}] + , imports=[] :: [{atom(), [{atom(), integer()}]}] + , attributes=[] :: [{filename(), atom(), [term()]}] + , records=[] :: [{filename(), atom(), + [{atom(), merl:tree()}]}] + , functions=[] :: [{filename(), atom(), [merl:tree()]}] + }). + +%% TODO: init module from a list of forms (from various sources) + +%% @doc Create a new module representation, using the given module name. +init_module(Name) when is_atom(Name) -> + %% use the module name as the default file name - better than nothing + #module{name=Name, file=atom_to_list(Name)}. + +%% @doc Get the list of syntax tree forms for a module representation. This can +%% be passed to compile/2. +module_forms(#module{name=Name, + exports=Xs, + imports=Is, + records=Rs, + attributes=As, + functions=Fs}) + when is_atom(Name), Name =/= undefined -> + Module = ?Q("-module('@Name@')."), + Exported = [erl_syntax:arity_qualifier(term(N), term(A)) + || {N,A} <- ordsets:from_list(Xs)], + Export = ?Q("-export(['@_Exported'/1])."), + Imports = [?Q("-import('@M@', ['@_NAs'/1]).") + || {M, Ns} <- Is, + NAs <- [[erl_syntax:arity_qualifier(term(N), term(A)) + || {N,A} <- ordsets:from_list(Ns)]] + ], + Attrs = [?Q("-file(\"'@File@\",1). -'@N@'('@T@').") + || {File, N, T} <- lists:reverse(As)], + Records = [?Q("-file(\"'@File@\",1). -record('@N@',{'@_RFs'=[]}).") + || {File, N, Es} <- lists:reverse(Rs), + RFs <- [[erl_syntax:record_field(term(F), V) + || {F,V} <- Es]] + ], + Functions = [?Q("-file(\"'@File@\",1). '@_F'() -> [].") + || {File, N, Cs} <- lists:reverse(Fs), + F <- [erl_syntax:function(term(N), Cs)]], + lists:flatten([Module, Export, Imports, Attrs, Records, Functions]). + +%% @doc Set the source file name for all subsequently added functions, +%% records, and attributes. +set_file(Filename, #module{}=M) -> + M#module{file=filename:flatten(Filename)}. + +%% @doc Add a function to a module representation. +add_function(Exported, Name, Clauses, + #module{file=File, exports=Xs, functions=Fs}=M) + when is_boolean(Exported), is_atom(Name), Clauses =/= [] -> + Arity = length(erl_syntax:clause_patterns(hd(Clauses))), + Xs1 = case Exported of + true -> [{Name,Arity} | Xs]; + false -> Xs + end, + M#module{exports=Xs1, functions=[{File, Name, Clauses} | Fs]}. + +%% @doc Add a record declaration to a module representation. +add_record(Name, Fields, #module{file=File, records=Rs}=M) + when is_atom(Name) -> + M#module{records=[{File, Name, Fields} | Rs]}. + +%% @doc Add a "wild" attribute, such as `-compile(Opts)' to a module +%% representation. Note that such attributes can only have a single argument. +add_attribute(Name, Term, #module{file=File, attributes=As}=M) + when is_atom(Name) -> + M#module{attributes=[{File, Name, Term} | As]}. + +%% @doc Add an import declaration to a module representation. +add_import(From, Names, #module{imports=Is}=M) + when is_atom(From), is_list(Names) -> + M#module{imports=[{From, Names} | Is]}. diff --git a/lib/syntax_tools/include/merl.hrl b/lib/syntax_tools/include/merl.hrl new file mode 100644 index 0000000000..e44a78dece --- /dev/null +++ b/lib/syntax_tools/include/merl.hrl @@ -0,0 +1,29 @@ +%% --------------------------------------------------------------------- +%% Header file for merl +%% +%% 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. + +-ifndef(MERL_HRL). + + +%% Quoting a piece of code +-define(Q(Text), merl:quote(?LINE, Text)). + +%% Quasi-quoting code, substituting metavariables listed in Env +-define(Q(Text, Env), merl:qquote(?LINE, Text, Env)). + + +-ifndef(MERL_NO_TRANSFORM). +-compile({parse_transform, merl_transform}). +-endif. + + +-endif. diff --git a/lib/syntax_tools/src/Makefile b/lib/syntax_tools/src/Makefile index c9fbad8f9a..2c565cee7f 100644 --- a/lib/syntax_tools/src/Makefile +++ b/lib/syntax_tools/src/Makefile @@ -22,6 +22,9 @@ RELSYSDIR = $(RELEASE_PATH)/lib/syntax_tools-$(VSN) # EBIN = ../ebin +INCLUDE=../include + +ERL_COMPILE_FLAGS += -pa $(EBIN) -pa ./ -I$(INCLUDE) ifeq ($(NATIVE_LIBS_ENABLED),yes) ERL_COMPILE_FLAGS += +native @@ -30,10 +33,15 @@ ERL_COMPILE_FLAGS += +nowarn_shadow_vars +warn_unused_import -Werror # +warn_mis SOURCES=erl_syntax.erl erl_prettypr.erl erl_syntax_lib.erl \ erl_comment_scan.erl erl_recomment.erl erl_tidy.erl \ - epp_dodger.erl prettypr.erl igor.erl + epp_dodger.erl prettypr.erl igor.erl \ + merl.erl merl_transform.erl + +INCLUDE_FILES = merl.hrl OBJECTS=$(SOURCES:%.erl=$(EBIN)/%.$(EMULATOR)) $(APP_TARGET) $(APPUP_TARGET) +INCLUDE_DELIVERABLES = $(INCLUDE_FILES:%=$(INCLUDE)/%) + APP_FILE= syntax_tools.app APP_SRC= $(APP_FILE).src APP_TARGET= $(EBIN)/$(APP_FILE) @@ -52,6 +60,7 @@ all: $(OBJECTS) clean: + rm -f ./merl_transform.beam rm -f $(OBJECTS) rm -f core *~ @@ -64,6 +73,14 @@ realclean: clean $(EBIN)/%.$(EMULATOR):%.erl $(erlc_verbose)erlc -W $(ERL_COMPILE_FLAGS) -o$(EBIN) $< +# special rules and dependencies to apply the transform to itself +$(EBIN)/merl_transform.beam: $(EBIN)/merl.beam ./merl_transform.beam \ + ../include/merl.hrl +./merl_transform.beam: ./merl_transform.erl $(EBIN)/merl.beam \ + ../include/merl.hrl + $(V_ERLC) -DMERL_NO_TRANSFORM $(ERL_COMPILE_FLAGS) -o ./ $< + + # ---------------------------------------------------- # Special Build Targets # ---------------------------------------------------- @@ -84,6 +101,8 @@ release_spec: opt $(INSTALL_DATA) $(OBJECTS) "$(RELSYSDIR)/ebin" $(INSTALL_DIR) "$(RELSYSDIR)/src" $(INSTALL_DATA) $(SOURCES) "$(RELSYSDIR)/src" + $(INSTALL_DIR) "$(RELSYSDIR)/include" + $(INSTALL_DATA) $(INCLUDE_DELIVERABLES) "$(RELSYSDIR)/include" release_docs_spec: diff --git a/lib/syntax_tools/src/merl.erl b/lib/syntax_tools/src/merl.erl new file mode 100644 index 0000000000..690306c17b --- /dev/null +++ b/lib/syntax_tools/src/merl.erl @@ -0,0 +1,1230 @@ +%% --------------------------------------------------------------------- +%% 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. +%% +%% Note: EDoc uses @@ and @} as escape sequences, so in the doc text below, +%% `@@' must be written `@@@@' and `@}' must be written `@@}'. +%% +%% @author Richard Carlsson <[email protected]> +%% @copyright 2010-2015 Richard Carlsson +%% +%% @doc Metaprogramming in Erlang. +%% Merl is a more user friendly interface to the `erl_syntax' module, making +%% it easy both to build new ASTs from scratch and to +%% match and decompose existing ASTs. For details that are outside the scope +%% of Merl itself, please see the documentation of {@link erl_syntax}. +%% +%% == Quick start == +%% +%% To enable the full power of Merl, your module needs to include the Merl +%% header file: +%% ```-include_lib("syntax_tools/include/merl.hrl").''' +%% +%% Then, you can use the `?Q(Text)' macros in your code to create ASTs or match +%% on existing ASTs. For example: +%% ```Tuple = ?Q("{foo, 42}"), +%% ?Q("{foo, _@Number}") = Tuple, +%% Call = ?Q("foo:bar(_@Number)")''' +%% +%% Calling `merl:print(Call)' will then print the following code: +%% ```foo:bar(42)''' +%% +%% The `?Q' macros turn the quoted code fragments into ASTs, and lifts +%% metavariables such as `_@Tuple' and `_@Number' to the level of your Erlang +%% code, so you can use the corresponding Erlang variables `Tuple' and `Number' +%% directly. This is the most straightforward way to use Merl, and in many +%% cases it's all you need. +%% +%% You can even write case switches using `?Q' macros as patterns. For example: +%% ```case AST of +%% ?Q("{foo, _@Foo}") -> handle(Foo); +%% ?Q("{bar, _@Bar}") when erl_syntax:is_integer(Bar) -> handle(Bar); +%% _ -> handle_default() +%% end''' +%% +%% These case switches only allow `?Q(...)' or `_' as clause patterns, and the +%% guards may contain any expressions, not just Erlang guard expressions. +%% +%% If the macro `MERL_NO_TRANSFORM' is defined before the `merl.hrl' header +%% file is included, the parse transform used by Merl will be disabled, and in +%% that case, the match expressions `?Q(...) = ...', case switches using +%% `?Q(...)' patterns, and automatic metavariables like `_@Tuple' cannot be +%% used in your code, but the Merl macros and functions still work. To do +%% metavariable substitution, you need to use the `?Q(Text, Map)' macro, e.g.: +%% ```Tuple = ?Q("{foo, _@bar, _@baz}", [{bar, Bar}, {baz,Baz}])''' +%% +%% The text given to a `?Q(Text)' macro can be either a single string, or a +%% list of strings. The latter is useful when you need to split a long +%% expression over multiple lines, e.g.: +%% ```?Q(["case _@Expr of", +%% " {foo, X} -> f(X);", +%% " {bar, X} -> g(X)", +%% " _ -> h(X)" +%% "end"])''' +%% If there is a syntax error somewhere in the text (like the missing semicolon +%% in the second clause above) this allows Merl to generate an error message +%% pointing to the exact line in your source code. (Just remember to +%% comma-separate the strings in the list, otherwise Erlang will concatenate +%% the string fragments as if they were a single string.) +%% +%% == Metavariable syntax == +%% +%% There are several ways to write a metavariable in your quoted code: +%% <ul> +%% <li>Atoms starting with `@', for example `` '@foo' '' or `` '@Foo' ''</li> +%% <li>Variables starting with `_@', for example `_@bar' or `_@Bar'</li> +%% <li>Strings starting with ``"'@'', for example ``"'@File"''</li> +%% <li>Integers starting with 909, for example `9091' or `909123'</li> +%% </ul> +%% Following the prefix, one or more `_' or `0' characters may be used to +%% indicate "lifting" of the variable one or more levels, and after that, a `@' +%% or `9' character indicates a glob metavariable (matching zero or more +%% elements in a sequence) rather than a normal metavariable. For example: +%% <ul> +%% <li>`` '@_foo' '' is lifted one level, and `_@__foo' is lifted two +%% levels</li> +%% <li>`_@@@@bar' is a glob variable, and `_@_@bar' is a lifted glob +%% variable</li> +%% <li>`90901' is a lifted variable,`90991' is a glob variable, and `9090091' +%% is a glob variable lifted two levels</li> +%% </ul> +%% (Note that the last character in the name is never considered to be a lift +%% or glob marker, hence, `_@__' and `90900' are only lifted one level, not +%% two. Also note that globs only matter for matching; when doing +%% substitutions, a non-glob variable can be used to inject a sequence of +%% elements, and vice versa.) +%% +%% If the name after the prefix and any lift and glob markers is `_' or `0', +%% the variable is treated as an anonymous catch-all pattern in matches. For +%% example, `_@_', `_@@@@_', `_@__', or even `_@__@_'. +%% +%% Finally, if the name without any prefixes or lift/glob markers begins with +%% an uppercase character, as in `_@Foo' or `_@_@Foo', it will become a +%% variable on the Erlang level, and can be used to easily deconstruct and +%% construct syntax trees: +%% ```case Input of +%% ?Q("{foo, _@Number}") -> ?Q("foo:bar(_@Number)"); +%% ...''' +%% We refer to these as "automatic metavariables". If in addition the name ends +%% with `@', as in `_@Foo@', the value of the variable as an Erlang term will +%% be automatically converted to the corresponding abstract syntax tree when +%% used to construct a larger tree. For example, in: +%% ```Bar = {bar, 42}, +%% Foo = ?Q("{foo, _@Bar@@}")''' +%% (where Bar is just some term, not a syntax tree) the result `Foo' will be a +%% syntax tree representing `{foo, {bar, 42}}'. This avoids the need for +%% temporary variables in order to inject data, as in +%% ```TmpBar = erl_syntax:abstract(Bar), +%% Foo = ?Q("{foo, _@TmpBar}")''' +%% +%% If the context requires an integer rather than a variable, an atom, or a +%% string, you cannot use the uppercase convention to mark an automatic +%% metavariable. Instead, if the integer (without the `909'-prefix and +%% lift/glob markers) ends in a `9', the integer will become an Erlang-level +%% variable prefixed with `Q', and if it ends with `99' it will also be +%% automatically abstracted. For example, the following will increment the +%% arity of the exported function f: +%% ```case Form of +%% ?Q("-export([f/90919]).") -> +%% Q2 = erl_syntax:concrete(Q1) + 1, +%% ?Q("-export([f/909299])."); +%% ...''' +%% +%% == When to use the various forms of metavariables == +%% +%% Merl can only parse a fragment of text if it follows the basic syntactical +%% rules of Erlang. In most places, a normal Erlang variable can be used as +%% metavariable, for example: +%% ```?Q("f(_@Arg)") = Expr''' +%% but if you want to match on something like the name of a function, you have +%% to use an atom as metavariable: +%% ```?Q("'@Name'() -> _@@@@_." = Function''' +%% (note the anonymous glob variable `_@@@@_' to ignore the function body). +%% +%% In some contexts, only a string or an integer is allowed. For example, the +%% directive `-file(Name, Line)' requires that `Name' is a string literal and +%% `Line' an integer literal: +%% +%% ```?Q("-file(\"'@File\", 9090).") = ?Q("-file(\"foo.erl\", 42).")).''' +%% This will extract the string literal `"foo.erl"' into the variable `Foo'. +%% Note the use of the anonymous variable `9090' to ignore the line number. To +%% match and also bind a metavariable that must be an integer literal, we can +%% use the convention of ending the integer with a 9, turning it into a +%% Q-prefixed variable on the Erlang level (see the previous section). +%% +%% === Globs === +%% +%% Whenever you want to match out a number of elements in a sequence (zero or +%% more) rather than a fixed set of elements, you need to use a glob. For +%% example: +%% ```?Q("{_@@@@Elements}") = ?Q({a, b, c})''' +%% will bind Elements to the list of individual syntax trees representing the +%% atoms `a', `b', and `c'. This can also be used with static prefix and suffix +%% elements in the sequence. For example: +%% ```?Q("{a, b, _@@@@Elements}") = ?Q({a, b, c, d})''' +%% will bind Elements to the list of the `c' and `d' subtrees, and +%% ```?Q("{_@@@@Elements, c, d}") = ?Q({a, b, c, d})''' +%% will bind Elements to the list of the `a' and `b' subtrees. You can even use +%% plain metavariables in the prefix or suffix: +%% ```?Q("{_@First, _@@@@Rest}") = ?Q({a, b, c})''' +%% or +%% ```?Q("{_@@@@_, _@Last}") = ?Q({a, b, c})''' +%% (ignoring all but the last element). You cannot however have two globs as +%% part of the same sequence. +%% +%% === Lifted metavariables === +%% +%% In some cases, the Erlang syntax rules make it impossible to place a +%% metavariable directly where you would like it. For example, you cannot +%% write: +%% ```?Q("-export([_@@@@Name]).")''' +%% to match out all name/arity pairs in the export list, or to insert a list of +%% exports in a declaration, because the Erlang parser only allows elements on +%% the form `A/I' (where `A' is an atom and `I' an integer) in the export list. +%% A variable like the above is not allowed, but neither is a single atom or +%% integer, so `` '@@@@Name' '' or `909919' wouldn't work either. +%% +%% What you have to do in such cases is to write your metavariable in a +%% syntactically valid position, and use lifting markers to denote where it +%% should really apply, as in: +%% ```?Q("-export(['@@_@@Name'/0]).")''' +%% This causes the variable to be lifted (after parsing) to the next higher +%% level in the syntax tree, replacing that entire subtree. In this case, the +%% `` '@@_@@Name'/0 '' will be replaced with `` '@@@@Name' '', and the ``/0'' +%% part was just used as dummy notation and will be discarded. +%% +%% You may even need to apply lifting more than once. To match the entire +%% export list as a single syntax tree, you can write: +%% ```?Q("-export(['@@__Name'/0]).")''' +%% using two underscores, but with no glob marker this time. This will make the +%% entire ``['@@__Name'/0]'' part be replaced with `` '@@Name' ''. +%% +%% Sometimes, the tree structure of a code fragment isn't very obvious, and +%% parts of the structure may be invisible when printed as source code. For +%% instance, a simple function definition like the following: +%% ```zero() -> 0.''' +%% consists of the name (the atom `zero'), and a list of clauses containing the +%% single clause `() -> 0'. The clause consists of an argument list (empty), a +%% guard (empty), and a body (which is always a list of expressions) containing +%% the single expression `0'. This means that to match out the name and the +%% list of clauses of any function, you'll need to use a pattern like +%% ``?Q("'@Name'() -> _@_@Body.")'', using a dummy clause whose body is a glob +%% lifted one level. +%% +%% To visualize the structure of a syntax tree, you can use the function +%% `merl:show(T)', which prints a summary. For example, entering +%% ```merl:show(merl:quote("inc(X, Y) when Y > 0 -> X + Y."))''' +%% in the Erlang shell will print the following (where the `+' signs separate +%% groups of subtrees on the same level): +%% ```function: inc(X, Y) when ... -> X + Y. +%% atom: inc +%% + +%% clause: (X, Y) when ... -> X + Y +%% variable: X +%% variable: Y +%% + +%% disjunction: Y > 0 +%% conjunction: Y > 0 +%% infix_expr: Y > 0 +%% variable: Y +%% + +%% operator: > +%% + +%% integer: 0 +%% + +%% infix_expr: X + Y +%% variable: X +%% + +%% operator: + +%% + +%% variable: Y''' +%% +%% This shows another important non-obvious case: a clause guard, even if it's +%% as simple as `Y > 0', always consists of a single disjunction of one or more +%% conjunctions of tests, much like a tuple of tuples. Thus: +%% <ul> +%% <li>``"when _@Guard ->"'' will only match a guard with exactly one +%% test</li> +%% <li>``"when _@@@@Guard ->"'' will match a guard with one or more +%% comma-separated tests (but no semicolons), binding `Guard' to the list +%% of tests</li> +%% <li>``"when _@_Guard ->"'' will match just like the previous pattern, but +%% binds `Guard' to the conjunction subtree</li> +%% <li>``"when _@_@Guard ->"'' will match an arbitrary nonempty guard, +%% binding `Guard' to the list of conjunction subtrees</li> +%% <li>``"when _@__Guard ->"'' will match like the previous pattern, but +%% binds `Guard' to the whole disjunction subtree</li> +%% <li>and finally, ``"when _@__@Guard ->"'' will match any clause, +%% binding `Guard' to `[]' if the guard is empty and to `[Disjunction]' +%% otherwise</li> +%% </ul> +%% +%% Thus, the following pattern matches all possible clauses: +%% ```"(_@@Args) when _@__@Guard -> _@@Body"''' +%% @end + +-module(merl). + +-export([term/1, var/1, print/1, show/1]). + +-export([quote/1, quote/2, qquote/2, qquote/3]). + +-export([template/1, tree/1, subst/2, tsubst/2, alpha/2, match/2, switch/2]). + +-export([template_vars/1, meta_template/1]). + +-export([compile/1, compile/2, compile_and_load/1, compile_and_load/2]). + +%% NOTE: this module may not include merl.hrl! + +-type tree() :: erl_syntax:syntaxTree(). + +-type tree_or_trees() :: tree() | [tree()]. + +-type pattern() :: tree() | template(). + +-type pattern_or_patterns() :: pattern() | [pattern()]. + +-type env() :: [{Key::id(), pattern_or_patterns()}]. + +-type id() :: atom() | integer(). + +%% A list of strings or binaries is assumed to represent individual lines, +%% while a flat string or binary represents source code containing newlines. +-type text() :: string() | binary() | [string()] | [binary()]. + +-type location() :: erl_anno:location(). + + +%% ------------------------------------------------------------------------ +%% Compiling and loading code directly to memory + +%% @equiv compile(Code, []) +compile(Code) -> + compile(Code, []). + +%% @doc Compile a syntax tree or list of syntax trees representing a module +%% into a binary BEAM object. +%% @see compile_and_load/2 +%% @see compile/1 +compile(Code, Options) when not is_list(Code)-> + case type(Code) of + form_list -> compile(erl_syntax:form_list_elements(Code)); + _ -> compile([Code], Options) + end; +compile(Code, Options0) when is_list(Options0) -> + Forms = [erl_syntax:revert(F) || F <- Code], + Options = [verbose, report_errors, report_warnings, binary | Options0], + compile:noenv_forms(Forms, Options). + + +%% @equiv compile_and_load(Code, []) +compile_and_load(Code) -> + compile_and_load(Code, []). + +%% @doc Compile a syntax tree or list of syntax trees representing a module +%% and load the resulting module into memory. +%% @see compile/2 +%% @see compile_and_load/1 +compile_and_load(Code, Options) -> + case compile(Code, Options) of + {ok, ModuleName, Binary} -> + _ = code:load_binary(ModuleName, "", Binary), + {ok, Binary}; + Other -> Other + end. + + +%% ------------------------------------------------------------------------ +%% Utility functions + + +-spec var(atom()) -> tree(). + +%% @doc Create a variable. + +var(Name) -> + erl_syntax:variable(Name). + + +-spec term(term()) -> tree(). + +%% @doc Create a syntax tree for a constant term. + +term(Term) -> + erl_syntax:abstract(Term). + + +%% @doc Pretty-print a syntax tree or template to the standard output. This +%% is a utility function for development and debugging. + +print(Ts) when is_list(Ts) -> + lists:foreach(fun print/1, Ts); +print(T) -> + io:put_chars(erl_prettypr:format(tree(T))), + io:nl(). + +%% @doc Print the structure of a syntax tree or template to the standard +%% output. This is a utility function for development and debugging. + +show(Ts) when is_list(Ts) -> + lists:foreach(fun show/1, Ts); +show(T) -> + io:put_chars(pp(tree(T), 0)), + io:nl(). + +pp(T, I) -> + [lists:duplicate(I, $\s), + limit(lists:flatten([atom_to_list(type(T)), ": ", + erl_prettypr:format(erl_syntax_lib:limit(T,3))]), + 79-I), + $\n, + pp_1(lists:filter(fun (X) -> X =/= [] end, subtrees(T)), I+2) + ]. + +pp_1([G], I) -> + pp_2(G, I); +pp_1([G | Gs], I) -> + [pp_2(G, I), lists:duplicate(I, $\s), "+\n" | pp_1(Gs, I)]; +pp_1([], _I) -> + []. + +pp_2(G, I) -> + [pp(E, I) || E <- G]. + +%% limit string to N characters, stay on a single line and compact whitespace +limit([$\n | Cs], N) -> limit([$\s | Cs], N); +limit([$\r | Cs], N) -> limit([$\s | Cs], N); +limit([$\v | Cs], N) -> limit([$\s | Cs], N); +limit([$\t | Cs], N) -> limit([$\s | Cs], N); +limit([$\s, $\s | Cs], N) -> limit([$\s | Cs], N); +limit([C | Cs], N) when C < 32 -> limit(Cs, N); +limit([C | Cs], N) when N > 3 -> [C | limit(Cs, N-1)]; +limit([_C1, _C2, _C3, _C4 | _Cs], 3) -> "..."; +limit(Cs, 3) -> Cs; +limit([_C1, _C2, _C3 | _], 2) -> ".."; +limit(Cs, 2) -> Cs; +limit([_C1, _C2 | _], 1) -> "."; +limit(Cs, 1) -> Cs; +limit(_, _) -> []. + +%% ------------------------------------------------------------------------ +%% Parsing and instantiating code fragments + + +-spec qquote(Text::text(), Env::env()) -> tree_or_trees(). + +%% @doc Parse text and substitute meta-variables. +%% +%% @equiv qquote(1, Text, Env) + +qquote(Text, Env) -> + qquote(1, Text, Env). + + +-spec qquote(StartPos::location(), Text::text(), Env::env()) -> tree_or_trees(). + +%% @doc Parse text and substitute meta-variables. Takes an initial scanner +%% starting position as first argument. +%% +%% The macro `?Q(Text, Env)' expands to `merl:qquote(?LINE, Text, Env)'. +%% +%% @see quote/2 + +qquote(StartPos, Text, Env) -> + subst(quote(StartPos, Text), Env). + + +-spec quote(Text::text()) -> tree_or_trees(). + +%% @doc Parse text. +%% +%% @equiv quote(1, Text) + +quote(Text) -> + quote(1, Text). + + +-spec quote(StartPos::location(), Text::text()) -> tree_or_trees(). + +%% @doc Parse text. Takes an initial scanner starting position as first +%% argument. +%% +%% The macro `?Q(Text)' expands to `merl:quote(?LINE, Text, Env)'. +%% +%% @see quote/1 + +quote({Line, Col}, Text) + when is_integer(Line), is_integer(Col) -> + quote_1(Line, Col, Text); +quote(StartPos, Text) when is_integer(StartPos) -> + quote_1(StartPos, undefined, Text). + +quote_1(StartLine, StartCol, Text) -> + %% be backwards compatible as far as R12, ignoring any starting column + StartPos = case erlang:system_info(version) of + "5.6" ++ _ -> StartLine; + "5.7" ++ _ -> StartLine; + "5.8" ++ _ -> StartLine; + _ when StartCol =:= undefined -> StartLine; + _ -> {StartLine, StartCol} + end, + FlatText = flatten_text(Text), + {ok, Ts, _} = erl_scan:string(FlatText, StartPos), + merge_comments(StartLine, erl_comment_scan:string(FlatText), parse_1(Ts)). + +parse_1(Ts) -> + %% if dot tokens are present, it is assumed that the text represents + %% complete forms, not dot-terminated expressions or similar + case split_forms(Ts) of + {ok, Fs} -> parse_forms(Fs); + error -> + parse_2(Ts) + end. + +split_forms(Ts) -> + split_forms(Ts, [], []). + +split_forms([{dot,_}=T|Ts], Fs, As) -> + split_forms(Ts, [lists:reverse(As, [T]) | Fs], []); +split_forms([T|Ts], Fs, As) -> + split_forms(Ts, Fs, [T|As]); +split_forms([], Fs, []) -> + {ok, lists:reverse(Fs)}; +split_forms([], [], _) -> + error; % no dot tokens found - not representing form(s) +split_forms([], _, [T|_]) -> + fail("incomplete form after ~p", [T]). + +parse_forms([Ts | Tss]) -> + case erl_parse:parse_form(Ts) of + {ok, Form} -> [Form | parse_forms(Tss)]; + {error, R} -> parse_error(R) + end; +parse_forms([]) -> + []. + +parse_2(Ts) -> + %% one or more comma-separated expressions? + %% (recall that Ts has no dot tokens if we get to this stage) + case erl_parse:parse_exprs(Ts ++ [{dot,0}]) of + {ok, Exprs} -> Exprs; + {error, E} -> + parse_3(Ts ++ [{'end',0}, {dot,0}], [E]) + end. + +parse_3(Ts, Es) -> + %% try-clause or clauses? + case erl_parse:parse_exprs([{'try',0}, {atom,0,true}, {'catch',0} | Ts]) of + {ok, [{'try',_,_,_,_,_}=X]} -> + %% get the right kind of qualifiers in the clause patterns + erl_syntax:try_expr_handlers(X); + {error, E} -> + parse_4(Ts, [E|Es]) + end. + +parse_4(Ts, Es) -> + %% fun-clause or clauses? (`(a)' is also a pattern, but `(a,b)' isn't, + %% so fun-clauses must be tried before normal case-clauses + case erl_parse:parse_exprs([{'fun',0} | Ts]) of + {ok, [{'fun',_,{clauses,Cs}}]} -> Cs; + {error, E} -> + parse_5(Ts, [E|Es]) + end. + +parse_5(Ts, Es) -> + %% case-clause or clauses? + case erl_parse:parse_exprs([{'case',0}, {atom,0,true}, {'of',0} | Ts]) of + {ok, [{'case',_,_,Cs}]} -> Cs; + {error, E} -> + %% select the best error to report + parse_error(lists:last(lists:sort([E|Es]))) + end. + +-dialyzer({nowarn_function, parse_error/1}). % no local return + +parse_error({L, M, R}) when is_atom(M), is_integer(L) -> + fail("~w: ~s", [L, M:format_error(R)]); +parse_error({{L,C}, M, R}) when is_atom(M), is_integer(L), is_integer(C) -> + fail("~w:~w: ~s", [L,C,M:format_error(R)]); +parse_error({_, M, R}) when is_atom(M) -> + fail(M:format_error(R)); +parse_error(R) -> + fail("unknown parse error: ~p", [R]). + +%% ------------------------------------------------------------------------ +%% Templates, substitution and matching + +%% Leaves are normal syntax trees, and inner nodes are tuples +%% {template,Type,Attrs,Groups} where Groups are lists of lists of nodes. +%% Metavariables are 1-tuples {VarName}, where VarName is an atom or an +%% integer. {'_'} and {0} work as anonymous variables in matching. Glob +%% metavariables are tuples {'*',VarName}, and {'*','_'} and {'*',0} are +%% anonymous globs. + +%% Note that although template() :: tree() | ..., it is implied that these +%% syntax trees are free from metavariables, so pattern() :: tree() | +%% template() is in fact a wider type than template(). + +-type template() :: tree() + | {id()} + | {'*',id()} + | {template, atom(), term(), [[template()]]}. + +-type template_or_templates() :: template() | [template()]. + +-spec template(pattern_or_patterns()) -> template_or_templates(). + +%% @doc Turn a syntax tree or list of trees into a template or templates. +%% Templates can be instantiated or matched against, and reverted back to +%% normal syntax trees using {@link tree/1}. If the input is already a +%% template, it is not modified further. +%% +%% @see subst/2 +%% @see match/2 +%% @see tree/1 + +template(Trees) when is_list(Trees) -> + [template_0(T) || T <- Trees]; +template(Tree) -> + template_0(Tree). + +template_0({template, _, _, _}=Template) -> Template; +template_0({'*',_}=Template) -> Template; +template_0({_}=Template) -> Template; +template_0(Tree) -> + case template_1(Tree) of + false -> Tree; + {Name} when is_list(Name) -> + fail("bad metavariable: '~s'", [tl(Name)]); % drop v/n from name + Template -> Template + end. + +%% returns either a template or a lifted metavariable {String}, or 'false' +%% if Tree contained no metavariables +template_1(Tree) -> + case subtrees(Tree) of + [] -> + case metavar(Tree) of + {"v_"++Cs}=V when Cs =/= [] -> V; % to be lifted + {"n0"++Cs}=V when Cs =/= [] -> V; % to be lifted + {"v@"++Cs} when Cs =/= [] -> {'*',list_to_atom(Cs)}; + {"n9"++Cs} when Cs =/= [] -> {'*',list_to_integer(Cs)}; + {"v"++Cs} -> {list_to_atom(Cs)}; + {"n"++Cs} -> {list_to_integer(Cs)}; + false -> false + end; + Gs -> + case template_2(Gs, [], false) of + Gs1 when is_list(Gs1) -> + {template, type(Tree), erl_syntax:get_attrs(Tree), Gs1}; + Other -> + Other + end + end. + +template_2([G | Gs], As, Bool) -> + case template_3(G, [], false) of + {"v_"++Cs}=V when Cs =/= [] -> V; % lift further + {"n0"++Cs}=V when Cs =/= [] -> V; % lift further + {"v@"++Cs} when Cs =/= [] -> {'*',list_to_atom(Cs)}; % stop + {"n9"++Cs} when Cs =/= [] -> {'*',list_to_integer(Cs)}; % stop + {"v"++Cs} when is_list(Cs) -> {list_to_atom(Cs)}; % stop + {"n"++Cs} when is_list(Cs) -> {list_to_integer(Cs)}; % stop + false -> template_2(Gs, [G | As], Bool); + G1 -> template_2(Gs, [G1 | As], true) + end; +template_2([], _As, false) -> false; +template_2([], As, true) -> lists:reverse(As). + +template_3([T | Ts], As, Bool) -> + case template_1(T) of + {"v_"++Cs} when Cs =/= [] -> {"v"++Cs}; % lift + {"n0"++Cs} when Cs =/= [] -> {"n"++Cs}; % lift + false -> template_3(Ts, [T | As], Bool); + T1 -> template_3(Ts, [T1 | As], true) + end; +template_3([], _As, false) -> false; +template_3([], As, true) -> lists:reverse(As). + + +%% @doc Turn a template into a syntax tree representing the template. +%% Meta-variables in the template are turned into normal Erlang variables if +%% their names (after the metavariable prefix characters) begin with an +%% uppercase character. E.g., `_@Foo' in the template becomes the variable +%% `Foo' in the meta-template. Furthermore, variables ending with `@' are +%% automatically wrapped in a call to merl:term/1, so e.g. `_@Foo@ in the +%% template becomes `merl:term(Foo)' in the meta-template. + +-spec meta_template(template_or_templates()) -> tree_or_trees(). + +meta_template(Templates) when is_list(Templates) -> + [meta_template_1(T) || T <- Templates]; +meta_template(Template) -> + meta_template_1(Template). + +meta_template_1({template, Type, Attrs, Groups}) -> + erl_syntax:tuple( + [erl_syntax:atom(template), + erl_syntax:atom(Type), + erl_syntax:abstract(Attrs), + erl_syntax:list([erl_syntax:list([meta_template_1(T) || T <- G]) + || G <- Groups])]); +meta_template_1({Var}=V) -> + meta_template_2(Var, V); +meta_template_1({'*',Var}=V) -> + meta_template_2(Var, V); +meta_template_1(Leaf) -> + erl_syntax:abstract(Leaf). + +meta_template_2(Var, V) when is_atom(Var) -> + case atom_to_list(Var) of + [C|_]=Name when C >= $A, C =< $Z ; C >= $À, C =< $Þ, C /= $× -> + case lists:reverse(Name) of + "@"++([_|_]=RevRealName) -> % don't allow empty RealName + RealName = lists:reverse(RevRealName), + erl_syntax:application(erl_syntax:atom(merl), + erl_syntax:atom(term), + [erl_syntax:variable(RealName)]); + _ -> + %% plain automatic metavariable + erl_syntax:variable(Name) + end; + _ -> + erl_syntax:abstract(V) + end; +meta_template_2(Var, V) when is_integer(Var) -> + if Var > 9, (Var rem 10) =:= 9 -> + %% at least 2 digits, ends in 9: make it a Q-variable + if Var > 99, (Var rem 100) =:= 99 -> + %% at least 3 digits, ends in 99: wrap in merl:term/1 + Name = "Q" ++ integer_to_list(Var div 100), + erl_syntax:application(erl_syntax:atom(merl), + erl_syntax:atom(term), + [erl_syntax:variable(Name)]); + true -> + %% plain automatic Q-variable + Name = integer_to_list(Var div 10), + erl_syntax:variable("Q" ++ Name) + end; + true -> + erl_syntax:abstract(V) + end. + + + +-spec template_vars(template_or_templates()) -> [id()]. + +%% @doc Return an ordered list of the metavariables in the template. + +template_vars(Template) -> + template_vars(Template, []). + +template_vars(Templates, Vars) when is_list(Templates) -> + lists:foldl(fun template_vars_1/2, Vars, Templates); +template_vars(Template, Vars) -> + template_vars_1(Template, Vars). + +template_vars_1({template, _, _, Groups}, Vars) -> + lists:foldl(fun (G, V) -> lists:foldl(fun template_vars_1/2, V, G) end, + Vars, Groups); +template_vars_1({Var}, Vars) -> + ordsets:add_element(Var, Vars); +template_vars_1({'*',Var}, Vars) -> + ordsets:add_element(Var, Vars); +template_vars_1(_, Vars) -> + Vars. + + +-spec tree(template_or_templates()) -> tree_or_trees(). + +%% @doc Revert a template to a normal syntax tree. Any remaining +%% metavariables are turned into `@'-prefixed atoms or `909'-prefixed +%% integers. +%% @see template/1 + +tree(Templates) when is_list(Templates) -> + [tree_1(T) || T <- Templates]; +tree(Template) -> + tree_1(Template). + +tree_1({template, Type, Attrs, Groups}) -> + %% flattening here is needed for templates created via source transforms + Gs = [lists:flatten([tree_1(T) || T <- G]) || G <- Groups], + erl_syntax:set_attrs(make_tree(Type, Gs), Attrs); +tree_1({Var}) when is_atom(Var) -> + erl_syntax:atom(list_to_atom("@"++atom_to_list(Var))); +tree_1({Var}) when is_integer(Var) -> + erl_syntax:integer(list_to_integer("909"++integer_to_list(Var))); +tree_1({'*',Var}) when is_atom(Var) -> + erl_syntax:atom(list_to_atom("@@"++atom_to_list(Var))); +tree_1({'*',Var}) when is_integer(Var) -> + erl_syntax:integer(list_to_integer("9099"++integer_to_list(Var))); +tree_1(Leaf) -> + Leaf. % any syntax tree, not necessarily atomic (due to substitutions) + + +-spec subst(pattern_or_patterns(), env()) -> tree_or_trees(). + +%% @doc Substitute metavariables in a pattern or list of patterns, yielding +%% a syntax tree or list of trees as result. Both for normal metavariables +%% and glob metavariables, the substituted value may be a single element or +%% a list of elements. For example, if a list representing `1, 2, 3' is +%% substituted for `var' in either of `[foo, _@var, bar]' or `[foo, _@@var, +%% bar]', the result represents `[foo, 1, 2, 3, bar]'. + +subst(Trees, Env) when is_list(Trees) -> + [subst_0(T, Env) || T <- Trees]; +subst(Tree, Env) -> + subst_0(Tree, Env). + +subst_0(Tree, Env) -> + tree_1(subst_1(template(Tree), Env)). + + +-spec tsubst(pattern_or_patterns(), env()) -> template_or_templates(). + +%% @doc Like subst/2, but does not convert the result from a template back +%% to a tree. Useful if you want to do multiple separate substitutions. +%% @see subst/2 +%% @see tree/1 + +tsubst(Trees, Env) when is_list(Trees) -> + [subst_1(template(T), Env) || T <- Trees]; +tsubst(Tree, Env) -> + subst_1(template(Tree), Env). + +subst_1({template, Type, Attrs, Groups}, Env) -> + Gs1 = [lists:flatten([subst_1(T, Env) || T <- G]) || G <- Groups], + {template, Type, Attrs, Gs1}; +subst_1({Var}=V, Env) -> + case lists:keyfind(Var, 1, Env) of + {Var, TreeOrTrees} -> TreeOrTrees; + false -> V + end; +subst_1({'*',Var}=V, Env) -> + case lists:keyfind(Var, 1, Env) of + {Var, TreeOrTrees} -> TreeOrTrees; + false -> V + end; +subst_1(Leaf, _Env) -> + Leaf. + + +-spec alpha(pattern_or_patterns(), [{id(), id()}]) -> template_or_templates(). + +%% @doc Alpha converts a pattern (renames variables). Similar to tsubst/1, +%% but only renames variables (including globs). +%% @see tsubst/2 + +alpha(Trees, Env) when is_list(Trees) -> + [alpha_1(template(T), Env) || T <- Trees]; +alpha(Tree, Env) -> + alpha_1(template(Tree), Env). + +alpha_1({template, Type, Attrs, Groups}, Env) -> + Gs1 = [lists:flatten([alpha_1(T, Env) || T <- G]) || G <- Groups], + {template, Type, Attrs, Gs1}; +alpha_1({Var}=V, Env) -> + case lists:keyfind(Var, 1, Env) of + {Var, NewVar} -> {NewVar}; + false -> V + end; +alpha_1({'*',Var}=V, Env) -> + case lists:keyfind(Var, 1, Env) of + {Var, NewVar} -> {'*',NewVar}; + false -> V + end; +alpha_1(Leaf, _Env) -> + Leaf. + + +-spec match(pattern_or_patterns(), tree_or_trees()) -> + {ok, env()} | error. + +%% @doc Match a pattern against a syntax tree (or patterns against syntax +%% trees) returning an environment mapping variable names to subtrees; the +%% environment is always sorted on keys. Note that multiple occurrences of +%% metavariables in the pattern is not allowed, but is not checked. +%% +%% @see template/1 +%% @see switch/2 + +match(Patterns, Trees) when is_list(Patterns), is_list(Trees) -> + try {ok, match_1(Patterns, Trees, [])} + catch + error -> error + end; +match(Patterns, Tree) when is_list(Patterns) -> match(Patterns, [Tree]); +match(Pattern, Trees) when is_list(Trees) -> match([Pattern], Trees); +match(Pattern, Tree) -> + try {ok, match_template(template(Pattern), Tree, [])} + catch + error -> error + end. + +match_1([P|Ps], [T | Ts], Dict) -> + match_1(Ps, Ts, match_template(template(P), T, Dict)); +match_1([], [], Dict) -> + Dict; +match_1(_, _, _Dict) -> + erlang:error(merl_match_arity). + +%% match a template against a syntax tree +match_template({template, Type, _, Gs}, Tree, Dict) -> + case type(Tree) of + Type -> match_template_1(Gs, subtrees(Tree), Dict); + _ -> throw(error) % type mismatch + end; +match_template({Var}, _Tree, Dict) + when Var =:= '_' ; Var =:= 0 -> + Dict; % anonymous variable +match_template({Var}, Tree, Dict) -> + orddict:store(Var, Tree, Dict); +match_template(Tree1, Tree2, Dict) -> + %% if Tree1 is not a template, Tree1 and Tree2 are both syntax trees + case compare_trees(Tree1, Tree2) of + true -> Dict; + false -> throw(error) % different trees + end. + +match_template_1([G1 | Gs1], [G2 | Gs2], Dict) -> + match_template_2(G1, G2, match_template_1(Gs1, Gs2, Dict)); +match_template_1([], [], Dict) -> + Dict; +match_template_1(_, _, _Dict) -> + throw(error). % shape mismatch + +match_template_2([{Var} | Ts1], [_ | Ts2], Dict) + when Var =:= '_' ; Var =:= 0 -> + match_template_2(Ts1, Ts2, Dict); % anonymous variable +match_template_2([{Var} | Ts1], [Tree | Ts2], Dict) -> + match_template_2(Ts1, Ts2, orddict:store(Var, Tree, Dict)); +match_template_2([{'*',Var} | Ts1], Ts2, Dict) -> + match_glob(lists:reverse(Ts1), lists:reverse(Ts2), Var, Dict); +match_template_2([T1 | Ts1], [T2 | Ts2], Dict) -> + match_template_2(Ts1, Ts2, match_template(T1, T2, Dict)); +match_template_2([], [], Dict) -> + Dict; +match_template_2(_, _, _Dict) -> + throw(error). % shape mismatch + +%% match the tails in reverse order; no further globs allowed +match_glob([{'*',Var} | _], _, _, _) -> + fail("multiple glob variables in same match group: ~w", [Var]); +match_glob([T1 | Ts1], [T2 | Ts2], Var, Dict) -> + match_glob(Ts1, Ts2, Var, match_template(T1, T2, Dict)); +match_glob([], _Group, Var, Dict) when Var =:= '_' ; Var =:= 0 -> + Dict; % anonymous glob variable +match_glob([], Group, Var, Dict) -> + orddict:store(Var, lists:reverse(Group), Dict); +match_glob(_, _, _, _Dict) -> + throw(error). % shape mismatch + + +%% compare two syntax trees for equivalence +compare_trees(T1, T2) -> + Type1 = type(T1), + case type(T2) of + Type1 -> + case subtrees(T1) of + [] -> + case subtrees(T2) of + [] -> compare_leaves(Type1, T1, T2); + _Gs2 -> false % shape mismatch + end; + Gs1 -> + case subtrees(T2) of + [] -> false; % shape mismatch + Gs2 -> compare_trees_1(Gs1, Gs2) + end + end; + _Type2 -> + false % different tree types + end. + +compare_trees_1([G1 | Gs1], [G2 | Gs2]) -> + compare_trees_2(G1, G2) andalso compare_trees_1(Gs1, Gs2); +compare_trees_1([], []) -> + true; +compare_trees_1(_, _) -> + false. % shape mismatch + +compare_trees_2([T1 | Ts1], [T2 | Ts2]) -> + compare_trees(T1, T2) andalso compare_trees_2(Ts1, Ts2); +compare_trees_2([], []) -> + true; +compare_trees_2(_, _) -> + false. % shape mismatch + +compare_leaves(Type, T1, T2) -> + case Type of + atom -> + erl_syntax:atom_value(T1) + =:= erl_syntax:atom_value(T2); + char -> + erl_syntax:char_value(T1) + =:= erl_syntax:char_value(T2); + float -> + erl_syntax:float_value(T1) + =:= erl_syntax:float_value(T2); + integer -> + erl_syntax:integer_value(T1) + =:= erl_syntax:integer_value(T2); + string -> + erl_syntax:string_value(T1) + =:= erl_syntax:string_value(T2); + operator -> + erl_syntax:operator_name(T1) + =:= erl_syntax:operator_name(T2); + text -> + erl_syntax:text_string(T1) + =:= erl_syntax:text_string(T2); + variable -> + erl_syntax:variable_name(T1) + =:= erl_syntax:variable_name(T2); + _ -> + true % trivially equal nodes + end. + + +%% @doc Match against one or more clauses with patterns and optional guards. +%% +%% Note that clauses following a default action will be ignored. +%% +%% @see match/2 + +-type switch_clause() :: + {pattern_or_patterns(), guarded_actions()} + | {pattern_or_patterns(), guard_test(), switch_action()} + | default_action(). + +-type guarded_actions() :: guarded_action() | [guarded_action()]. + +-type guarded_action() :: switch_action() | {guard_test(), switch_action()}. + +-type switch_action() :: fun( (env()) -> any() ). + +-type guard_test() :: fun( (env()) -> boolean() ). + +-type default_action() :: fun( () -> any() ). + + +-spec switch(tree_or_trees(), [switch_clause()]) -> any(). + +switch(Trees, [{Patterns, GuardedActions} | Cs]) when is_list(GuardedActions) -> + switch_1(Trees, Patterns, GuardedActions, Cs); +switch(Trees, [{Patterns, GuardedAction} | Cs]) -> + switch_1(Trees, Patterns, [GuardedAction], Cs); +switch(Trees, [{Patterns, Guard, Action} | Cs]) -> + switch_1(Trees, Patterns, [{Guard, Action}], Cs); +switch(_Trees, [Default | _Cs]) when is_function(Default, 0) -> + Default(); +switch(_Trees, []) -> + erlang:error(merl_switch_clause); +switch(_Tree, _) -> + erlang:error(merl_switch_badarg). + +switch_1(Trees, Patterns, GuardedActions, Cs) -> + case match(Patterns, Trees) of + {ok, Env} -> + switch_2(Env, GuardedActions, Trees, Cs); + error -> + switch(Trees, Cs) + end. + +switch_2(Env, [{Guard, Action} | Bs], Trees, Cs) + when is_function(Guard, 1), is_function(Action, 1) -> + case Guard(Env) of + true -> Action(Env); + false -> switch_2(Env, Bs, Trees, Cs) + end; +switch_2(Env, [Action | _Bs], _Trees, _Cs) when is_function(Action, 1) -> + Action(Env); +switch_2(_Env, [], Trees, Cs) -> + switch(Trees, Cs); +switch_2(_Env, _, _Trees, _Cs) -> + erlang:error(merl_switch_badarg). + + +%% ------------------------------------------------------------------------ +%% Internal utility functions + +-dialyzer({nowarn_function, fail/1}). % no local return + +fail(Text) -> + fail(Text, []). + +fail(Fs, As) -> + throw({error, lists:flatten(io_lib:format(Fs, As))}). + +flatten_text([L | _]=Lines) when is_list(L) -> + lists:foldr(fun(S, T) -> S ++ [$\n | T] end, "", Lines); +flatten_text([B | _]=Lines) when is_binary(B) -> + lists:foldr(fun(S, T) -> binary_to_list(S) ++ [$\n | T] end, "", Lines); +flatten_text(Text) when is_binary(Text) -> + binary_to_list(Text); +flatten_text(Text) -> + Text. + +-spec metavar(tree()) -> {string()} | false. + +%% Check if a syntax tree represents a metavariable. If not, 'false' is +%% returned; otherwise, this returns a 1-tuple with a string containing the +%% variable name including lift/glob prefixes but without any leading +%% metavariable prefix, and instead prefixed with "v" for a variable or "i" +%% for an integer. +%% +%% Metavariables are atoms starting with @, variables starting with _@, +%% strings starting with "'@, or integers starting with 909. Following the +%% prefix, one or more _ or 0 characters (unless it's the last character in +%% the name) may be used to indicate "lifting" of the variable one or more +%% levels , and after that, a @ or 9 character indicates a glob metavariable +%% rather than a normal metavariable. If the name after the prefix is _ or +%% 0, the variable is treated as an anonymous catch-all pattern in matches. + +metavar(Tree) -> + case type(Tree) of + atom -> + case erl_syntax:atom_name(Tree) of + "@" ++ Cs when Cs =/= [] -> {"v"++Cs}; + _ -> false + end; + variable -> + case erl_syntax:variable_literal(Tree) of + "_@" ++ Cs when Cs =/= [] -> {"v"++Cs}; + _ -> false + end; + integer -> + case erl_syntax:integer_value(Tree) of + N when N >= 9090 -> + case integer_to_list(N) of + "909" ++ Cs -> {"n"++Cs}; + _ -> false + end; + _ -> false + end; + string -> + case erl_syntax:string_value(Tree) of + "'@" ++ Cs -> {"v"++Cs}; + _ -> false + end; + _ -> + false + end. + +%% wrappers around erl_syntax functions to provide more uniform shape of +%% generic subtrees (maybe this can be fixed in syntax_tools one day) + +type(T) -> + case erl_syntax:type(T) of + nil -> list; + Type -> Type + end. + +subtrees(T) -> + case erl_syntax:type(T) of + tuple -> + [erl_syntax:tuple_elements(T)]; %% don't treat {} as a leaf + nil -> + [[], []]; %% don't treat [] as a leaf, but as a list + list -> + case erl_syntax:list_suffix(T) of + none -> + [erl_syntax:list_prefix(T), []]; + S -> + [erl_syntax:list_prefix(T), [S]] + end; + binary_field -> + [[erl_syntax:binary_field_body(T)], + erl_syntax:binary_field_types(T)]; + clause -> + case erl_syntax:clause_guard(T) of + none -> + [erl_syntax:clause_patterns(T), [], + erl_syntax:clause_body(T)]; + G -> + [erl_syntax:clause_patterns(T), [G], + erl_syntax:clause_body(T)] + end; + receive_expr -> + case erl_syntax:receive_expr_timeout(T) of + none -> + [erl_syntax:receive_expr_clauses(T), [], []]; + E -> + [erl_syntax:receive_expr_clauses(T), [E], + erl_syntax:receive_expr_action(T)] + end; + record_expr -> + case erl_syntax:record_expr_argument(T) of + none -> + [[], [erl_syntax:record_expr_type(T)], + erl_syntax:record_expr_fields(T)]; + V -> + [[V], [erl_syntax:record_expr_type(T)], + erl_syntax:record_expr_fields(T)] + end; + record_field -> + case erl_syntax:record_field_value(T) of + none -> + [[erl_syntax:record_field_name(T)], []]; + V -> + [[erl_syntax:record_field_name(T)], [V]] + end; + _ -> + erl_syntax:subtrees(T) + end. + +make_tree(list, [P, []]) -> erl_syntax:list(P); +make_tree(list, [P, [S]]) -> erl_syntax:list(P, S); +make_tree(tuple, [E]) -> erl_syntax:tuple(E); +make_tree(binary_field, [[B], Ts]) -> erl_syntax:binary_field(B, Ts); +make_tree(clause, [P, [], B]) -> erl_syntax:clause(P, none, B); +make_tree(clause, [P, [G], B]) -> erl_syntax:clause(P, G, B); +make_tree(receive_expr, [C, [], _A]) -> erl_syntax:receive_expr(C); +make_tree(receive_expr, [C, [E], A]) -> erl_syntax:receive_expr(C, E, A); +make_tree(record_expr, [[], [T], F]) -> erl_syntax:record_expr(T, F); +make_tree(record_expr, [[E], [T], F]) -> erl_syntax:record_expr(E, T, F); +make_tree(record_field, [[N], []]) -> erl_syntax:record_field(N); +make_tree(record_field, [[N], [E]]) -> erl_syntax:record_field(N, E); +make_tree(Type, Groups) -> + erl_syntax:make_tree(Type, Groups). + +merge_comments(_StartLine, [], [T]) -> T; +merge_comments(_StartLine, [], Ts) -> Ts; +merge_comments(StartLine, Comments, Ts) -> + merge_comments(StartLine, Comments, Ts, []). + +merge_comments(_StartLine, [], [], [T]) -> T; +merge_comments(_StartLine, [], [T], []) -> T; +merge_comments(_StartLine, [], Ts, Acc) -> + lists:reverse(Acc, Ts); +merge_comments(StartLine, Cs, [], Acc) -> + merge_comments(StartLine, [], [], + [erl_syntax:set_pos( + erl_syntax:comment(Indent, Text), + StartLine + Line - 1) + || {Line, _, Indent, Text} <- Cs] ++ Acc); +merge_comments(StartLine, [C|Cs], [T|Ts], Acc) -> + {Line, _Col, Indent, Text} = C, + CommentLine = StartLine + Line - 1, + case erl_syntax:get_pos(T) of + Pos when Pos < CommentLine -> + %% TODO: traverse sub-tree rather than only the top level nodes + merge_comments(StartLine, [C|Cs], Ts, [T|Acc]); + CommentLine -> + Tc = erl_syntax:add_postcomments( + [erl_syntax:comment(Indent, Text)], T), + merge_comments(StartLine, Cs, [Tc|Ts], Acc); + _ -> + Tc = erl_syntax:add_precomments( + [erl_syntax:comment(Indent, Text)], T), + merge_comments(StartLine, Cs, [Tc|Ts], Acc) + end. diff --git a/lib/syntax_tools/src/merl_tests.erl b/lib/syntax_tools/src/merl_tests.erl new file mode 100644 index 0000000000..c1aae3100e --- /dev/null +++ b/lib/syntax_tools/src/merl_tests.erl @@ -0,0 +1,539 @@ +%% --------------------------------------------------------------------- +%% 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. +%% +%% @author Richard Carlsson <[email protected]> +%% @copyright 2012-2015 Richard Carlsson +%% @doc Unit tests for merl. +%% @private + +-module(merl_tests). + +%-define(MERL_NO_TRANSFORM, true). +-include("merl.hrl"). + +-include_lib("eunit/include/eunit.hrl"). + + +%% utilities + +f(Ts) when is_list(Ts) -> + lists:flatmap(fun erl_prettypr:format/1, Ts); +f(T) -> + erl_prettypr:format(T). + +fe(Env) -> [{Key, f(T)} || {Key, T} <- Env]. + +g_exported_() -> + %% for testing the parse transform, autoexported to avoid complaints + {ok, merl:quote(?LINE, "42")}. + + +ok({ok, X}) -> X. + + +%% +%% tests +%% + +parse_error_test_() -> + [?_assertThrow({error, "1: syntax error before: '{'" ++ _}, + f(merl:quote("{"))) + ]. + +term_test_() -> + [?_assertEqual(tuple, erl_syntax:type(merl:term({}))), + ?_assertEqual("{foo, 42}", f(merl:term({foo, 42}))) + ]. + +quote_form_test_() -> + [?_assertEqual("f(X) -> {ok, X}.", + f(?Q("f(X) -> {ok, X}."))), + ?_assertEqual("-module(foo).", + f(?Q("-module(foo)."))), + ?_assertEqual("-import(bar, [f/1, g/2]).", + f(?Q("-import(bar, [f/1, g/2])."))), + ?_assertEqual(("-module(foo)." + "-export([f/1])." + "f(X) -> {ok, X}."), + f(?Q(["-module(foo).", + "-export([f/1]).", + "f(X) -> {ok, X}."]))) + ]. + +quote_term_test_() -> + [?_assertEqual("foo", + f(?Q("foo"))), + ?_assertEqual("42", + f(?Q("42"))), + ?_assertEqual("{foo, 42}", + f(?Q("{foo, 42}"))), + ?_assertEqual(("1" ++ "2" ++ "3"), + f(?Q("1, 2, 3"))), + ?_assertEqual(("foo" "42" "{}" "true"), + f(?Q("foo, 42, {}, (true)"))) + ]. + +quote_expr_test_() -> + [?_assertEqual("2 + 2", + f(?Q("2 + 2"))), + ?_assertEqual("f(foo, 42)", + f(?Q("f(foo, 42)"))), + ?_assertEqual("case X of\n a -> 1;\n b -> 2\nend", + f(?Q("case X of a -> 1; b -> 2 end"))), + ?_assertEqual(("2 + 2" ++ "f(42)" ++ "catch 22"), + f(?Q("2 + 2, f(42), catch 22"))) + ]. + +quote_try_clause_test_() -> + [?_assertEqual("(error:R) when R =/= foo -> ok", + f(?Q("error:R when R =/= foo -> ok"))), + %% note that without any context, clauses are printed as fun-clauses + ?_assertEqual(("(error:badarg) -> badarg" + "(exit:normal) -> normal" + "(_) -> other"), + f(?Q(["error:badarg -> badarg;", + "exit:normal -> normal;" + "_ -> other"]))) + ]. + +quote_fun_clause_test_() -> + [?_assertEqual("(X, Y) when X < Y -> {ok, X}", + f(?Q("(X, Y) when X < Y -> {ok, X}"))), + ?_assertEqual(("(X, Y) when X < Y -> less" + "(X, Y) when X > Y -> greater" + "(_, _) -> equal"), + f(?Q(["(X, Y) when X < Y -> less;", + "(X, Y) when X > Y -> greater;" + "(_, _) -> equal"])))]. + +quote_case_clause_test_() -> + [?_assertEqual("({X, Y}) when X < Y -> X", + f(?Q("{X, Y} when X < Y -> X"))), + ?_assertEqual(("({X, Y}) when X < Y -> -1" + "({X, Y}) when X > Y -> 1" + "(_) -> 0"), + f(?Q(["{X, Y} when X < Y -> -1;", + "{X, Y} when X > Y -> 1;" + "_ -> 0"])))]. + +quote_comment_test_() -> + [?_assertEqual("%% comment preserved\n" + "{foo, 42}", + f(?Q(["%% comment preserved", + "{foo, 42}"]))), + ?_assertEqual("{foo, 42}" + "%% comment preserved\n", + f(?Q(["{foo, 42}", + "%% comment preserved"]))), + ?_assertEqual(" % just a comment (with indent)\n", + f(?Q(" % just a comment (with indent)"))) + ]. + +metavar_test_() -> + [?_assertEqual("'@foo'", f(merl:tree(merl:template(?Q("'@foo'"))))), + ?_assertEqual("'@foo'", f(merl:tree(merl:template(?Q("_@foo"))))), + ?_assertEqual("'@foo'", f(merl:tree(merl:template(?Q("\"'@foo\""))))), + ?_assertEqual("{'@foo'}", f(merl:tree(merl:template(?Q("{_@foo}"))))), + ?_assertEqual("'@foo'", f(merl:tree(merl:template(?Q("{_@_foo}"))))), + ?_assertEqual("909123", f(merl:tree(merl:template(?Q("{9090123}"))))), + ?_assertEqual("{'@foo'}", + f(merl:tree(merl:template(?Q("{{{_@__foo}}}"))))), + ?_assertEqual("{909123}", + f(merl:tree(merl:template(?Q("{{{90900123}}}"))))), + ?_assertEqual("{'@@foo'}", + f(merl:tree(merl:template(?Q("{{{_@__@foo}}}"))))), + ?_assertEqual("{9099123}", + f(merl:tree(merl:template(?Q("{{{909009123}}}"))))) + ]. + +subst_test_() -> + [?_assertEqual("42", + f(merl:subst(?Q("_@foo"), [{foo, merl:term(42)}]))), + ?_assertEqual("'@foo'", + f(merl:subst(?Q("_@foo"), []))), + ?_assertEqual("{42}", + f(merl:subst(?Q("{_@foo}"), + [{foo, merl:term(42)}]))), + ?_assertEqual("{'@foo'}", + f(merl:subst(?Q("{_@foo}"), []))), + ?_assertEqual("fun bar/0", + f(merl:subst(merl:template(?Q("fun '@foo'/0")), + [{foo, merl:term(bar)}]))), + ?_assertEqual("fun foo/3", + f(merl:subst(merl:template(?Q("fun foo/9091")), + [{1, merl:term(3)}]))), + ?_assertEqual("[42]", + f(merl:subst(merl:template(?Q("[_@foo]")), + [{foo, merl:term(42)}]))), + ?_assertEqual("[foo, bar]", + f(merl:subst(merl:template(?Q("[_@foo]")), + [{foo, [merl:term(foo),merl:term(bar)]}]))), + ?_assertEqual("{fee, fie, foe, fum}", + f(merl:subst(merl:template(?Q("{fee, _@foo, fum}")), + [{foo, [merl:term(fie),merl:term(foe)]}]))), + ?_assertEqual("[foo, bar]", + f(merl:subst(merl:template(?Q("[_@@foo]")), + [{foo, [merl:term(foo),merl:term(bar)]}]))), + ?_assertEqual("{fee, fie, foe, fum}", + f(merl:subst(merl:template(?Q("{fee, _@@foo, fum}")), + [{foo, [merl:term(fie),merl:term(foe)]}]))), + ?_assertEqual("['@@foo']", + f(merl:subst(merl:template(?Q("[_@@foo]")), []))), + ?_assertEqual("foo", + f(merl:subst(merl:template(?Q("[_@_foo]")), + [{foo, merl:term(foo)}]))), + ?_assertEqual("{'@foo'}", + f(merl:subst(merl:template(?Q("{[_@_foo]}")), []))), + ?_assertEqual("{'@@foo'}", + f(merl:subst(merl:template(?Q("{[_@_@foo]}")), []))), + ?_assertEqual("-export([foo/1, bar/2]).", + f(merl:subst(merl:template(?Q("-export(['@_@foo'/0]).")), + [{foo, [erl_syntax:arity_qualifier( + merl:term(foo), + merl:term(1)), + erl_syntax:arity_qualifier( + merl:term(bar), + merl:term(2)) + ]} + ]))) + ]. + +match_test_() -> + [?_assertEqual({ok, []}, merl:match(?Q("foo"), ?Q("foo"))), + ?_assertEqual(error, merl:match(?Q("foo"), ?Q("bar"))), + ?_assertEqual({ok,[]}, merl:match(?Q("{foo,42}"), ?Q("{foo,42}"))), + ?_assertEqual(error, merl:match(?Q("{foo,42}"), ?Q("{foo,bar}"))), + ?_assertEqual({ok,[]}, merl:match(?Q("[foo,[42]]"), ?Q("[foo,[42]]"))), + ?_assertEqual(error, merl:match(?Q("[foo,[42]]"), ?Q("[foo,{42}]"))), + ?_assertEqual({ok,[]}, merl:match(?Q("[foo,[_@_]]"), + ?Q("[foo,[42]]"))), + ?_assertEqual({ok,[]}, merl:match(?Q("[foo,[9090]]"), + ?Q("[foo,[42]]"))), + ?_assertEqual({ok,[]}, merl:match(?Q("{_@_,[_@_,2]}"), + ?Q("{foo,[1,2]}"))), + ?_assertEqual(error, merl:match(?Q("{_@_,[_@_,2]}"), + ?Q("{foo,[1,3]}"))), + ?_assertEqual({ok,[]}, merl:match(?Q("[foo,[9090,9090]]"), + ?Q("[foo,[1,2]]"))), + ?_assertEqual(error, merl:match(?Q("[foo,[9090,9090]]"), + ?Q("[foo,[1,2,3]]"))), + ?_assertEqual([{foo,"42"}], + fe(ok(merl:match(?Q("_@foo"), ?Q("42"))))), + ?_assertEqual([{foo,"42"}], + fe(ok(merl:match(?Q("{_@foo}"), ?Q("{42}"))))), + ?_assertEqual([{1,"0"},{foo,"bar"}], + fe(ok(merl:match(?Q("fun '@foo'/9091"), + ?Q("fun bar/0"))))), + ?_assertEqual([{line,"17"},{text,"\"hello\""}], + fe(ok(merl:match(?Q("{_@line, _@text}"), + ?Q("{17, \"hello\"}"))))), + ?_assertEqual([{line,"17"},{text,"\"hello\""}], + fe(ok(merl:match(?Q("foo(_@line, _@text)"), + ?Q("foo(17, \"hello\")"))))), + ?_assertEqual([{foo,""}], + fe(ok(merl:match(?Q("f(_@@foo)"), + ?Q("f()"))))), + ?_assertEqual([{foo,"fee"}], + fe(ok(merl:match(?Q("f(_@@foo)"), + ?Q("f(fee)"))))), + ?_assertEqual([{foo,"feefiefum"}], + fe(ok(merl:match(?Q("f(_@@foo)"), + ?Q("f(fee, fie, fum)"))))), + ?_assertEqual([{foo,""}], + fe(ok(merl:match(?Q("[_@@foo]"), + ?Q("[]"))))), + ?_assertEqual([{foo,"fee"}], + fe(ok(merl:match(?Q("[_@@foo]"), + ?Q("[fee]"))))), + ?_assertEqual([{foo,"feefiefoefum"}], + fe(ok(merl:match(?Q("[_@@foo]"), + ?Q("[fee, fie, foe, fum]"))))), + ?_assertEqual([{foo,""}], + fe(ok(merl:match(?Q("{_@@foo}"), + ?Q("{}"))))), + ?_assertEqual([{foo,"fee"}], + fe(ok(merl:match(?Q("{_@@foo}"), + ?Q("{fee}"))))), + ?_assertEqual([{foo,"feefiefoefum"}], + fe(ok(merl:match(?Q("{_@@foo}"), + ?Q("{fee, fie, foe, fum}"))))), + ?_assertEqual([{foo,"fie"}], + fe(ok(merl:match(?Q("{fee, _@@foo}"), + ?Q("{fee, fie}"))))), + ?_assertEqual([{foo,"fiefoefum"}], + fe(ok(merl:match(?Q("{fee, _@@foo}"), + ?Q("{fee, fie, foe, fum}"))))), + ?_assertEqual([{foo,"fie"}], + fe(ok(merl:match(?Q("{_@@foo, foe, fum}"), + ?Q("{fie, foe, fum}"))))), + ?_assertEqual([{foo,"feefie"}], + fe(ok(merl:match(?Q("{_@@foo, foe, fum}"), + ?Q("{fee, fie, foe, fum}"))))), + ?_assertEqual([{foo,"fie"}], + fe(ok(merl:match(?Q("{fee, _@@foo, fum}"), + ?Q("{fee, fie, fum}"))))), + ?_assertEqual([{foo,"fiefoe"}], + fe(ok(merl:match(?Q("{fee, _@@foo, fum}"), + ?Q("{fee, fie, foe, fum}"))))), + ?_assertEqual([{foo,"fiefoe"},{post,"fum"},{pre,"fee"}], + fe(ok(merl:match(?Q("{_@pre, _@@foo, _@post}"), + ?Q("{fee, fie, foe, fum}"))))), + ?_assertThrow({error, "multiple glob variables"++_}, + fe(ok(merl:match(?Q("{_@@foo, _@@bar}"), + ?Q("{fee, fie, foe, fum}"))))), + ?_assertEqual([], + fe(ok(merl:match(?Q("{fee, _@@_}"), + ?Q("{fee, fie, foe, fum}"))))), + ?_assertEqual([], + fe(ok(merl:match(?Q("{_@@_, foe, fum}"), + ?Q("{fee, fie, foe, fum}"))))), + ?_assertEqual([{post,"fum"},{pre,"fee"}], + fe(ok(merl:match(?Q("{_@pre, _@@_, _@post}"), + ?Q("{fee, fie, foe, fum}"))))) + ]. + +switch_test_() -> + [?_assertEqual(42, merl:switch(?Q("foo"), [fun () -> 42 end])), + ?_assertEqual(17, merl:switch(?Q("foo"), [fun () -> 17 end, + fun () -> 42 end])), + ?_assertEqual(17, merl:switch(?Q("foo"), [{?Q("foo"), + fun ([]) -> 17 end}, + fun () -> 42 end])), + ?_assertEqual(17, + merl:switch(?Q("foo"), [{?Q("bar"), fun ([]) -> 0 end}, + {?Q("foo"), fun ([]) -> 17 end}, + fun () -> 42 end])), + ?_assertEqual([{foo,"17"}], + merl:switch(?Q("{foo,17}"), + [{?Q("{bar, _@foo}"), fun (_) -> 0 end}, + {?Q("{foo, _@foo}"), fun fe/1}, + fun () -> 42 end])), + ?_assertEqual(17, + merl:switch(?Q("{foo, 17}"), + [{?Q("{foo, _@foo}"), + fun ([{foo, X}]) -> f(X) =:= "17" end, + fun (_) -> 17 end}, + fun () -> 42 end])), + ?_assertEqual([{foo,"17"}], + merl:switch(?Q("{foo, 17}"), + [{?Q("{foo, _@foo}"), + fun ([{foo, X}]) -> f(X) =:= "42" end, + fun (_) -> 0 end}, + {?Q("{foo, _@foo}"), fun fe/1}, + fun () -> 42 end])), + ?_assertEqual(17, + merl:switch(?Q("{foo, 17}"), + [{?Q("{foo, _@foo}"), + [{fun ([{foo, X}]) -> f(X) =:= "17" end, + fun (_) -> 17 end}, + fun (_) -> 0 end]}, + fun () -> 42 end])), + ?_assertEqual([{foo,"17"}], + merl:switch(?Q("{foo, 17}"), + [{?Q("{foo, _@foo}"), + [{fun ([{foo, X}]) -> f(X) =:= "42" end, + fun (_) -> 0 end}, + fun fe/1]}, + fun () -> 42 end])) + ]. + +-ifndef(MERL_NO_TRANSFORM). + +inline_meta_test_() -> + [?_assertEqual("{foo}", + f(begin + Foo = ?Q("foo"), + ?Q("{_@Foo}") + end)), + ?_assertEqual("{foo, '@bar'}", + f(begin + Foo = ?Q("foo"), + ?Q("{_@Foo,_@bar}") + end)), + ?_assertEqual("{foo, '@bar'}", + f(begin + Q1 = ?Q("foo"), + ?Q("{90919,_@bar}") + end)) + ]. + +inline_meta_autoabstract_test_() -> + [?_assertEqual("{foo}", + f(begin + Foo = foo, + ?Q("{_@Foo@}") + end)), + ?_assertEqual("{foo, '@bar@'}", + f(begin + Foo = foo, + ?Q("{_@Foo@,_@bar@}") + end)), + ?_assertEqual("{foo, '@bar@'}", + f(begin + Q1 = foo, + ?Q("{909199,_@bar@}") + end)) + ]. + +meta_match_test_() -> + [?_assertEqual("{[bar], baz()}", + f(begin + Tree = ?Q("{foo, [bar], baz()}"), + ?Q("{foo, _@Bar, '@Baz'}") = Tree, + ?Q("{_@Bar, _@Baz}") + end)), + ?_assertEqual("{[bar], baz()}", + f(begin + Tree = ?Q("{foo, [bar], baz()}"), + ?Q("{foo, 90919, 90929}") = Tree, + ?Q("{_@Q1, _@Q2}") + end)), + ?_assertError({badmatch,error}, + f(begin + Tree = ?Q("{foo, [bar], baz()}"), + ?Q("{fie, _@Bar, '@Baz'}") = Tree, + ?Q("{_@Bar, _@Baz}") + end)) + ]. + +meta_case_test_() -> + [?_assertEqual("{[bar], baz()}", + f(begin + Tree = ?Q("{foo, [bar], baz()}"), + case Tree of + ?Q("{foo, _@Bar, '@Baz'}") -> ?Q("{_@Bar, _@Baz}") + end + end)), + ?_assertEqual("{foo, [bar], baz()}", + f(begin + Tree = ?Q("{foo, [bar], baz()}"), + case Tree of + ?Q("{fie, _@Bar, '@Baz'}") -> ?Q("{_@Bar, _@Baz}"); + _ -> Tree + end + end)), + ?_assertError(merl_switch_clause, + f(begin + Tree = ?Q("{foo, [bar], baz()}"), + case Tree of + ?Q("{fie, _@Bar, '@Baz'}") -> ?Q("{_@Bar, _@Baz}") + end + end)), + ?_assertEqual("{foo, 4}", + f(begin + Tree = ?Q("{foo, 3}"), + case Tree of + ?Q("{foo, _@N}") -> + N1 = erl_syntax:concrete(N) + 1, + ?Q("{foo, _@N1@}"); + _ -> Tree + end + end)), + ?_assertEqual("-export([f/4]).", + f(begin + Tree = ?Q("-export([f/3])."), + case Tree of + ?Q("-export([f/90919]).") -> + Q2 = erl_syntax:concrete(Q1) + 1, + ?Q("-export([f/909299])."); + _ -> Tree + end + end)), + ?_assertEqual("{1, [bar], baz()}", + f(begin + Tree = ?Q("{foo, [bar], baz()}"), + case Tree of + ?Q("{foo, _@Bar, '@Baz'}") -> + ?Q("{1, _@Bar, _@Baz}"); + ?Q("{fie, _@Bar, '@Baz'}") -> + ?Q("{2, _@Bar, _@Baz}"); + _ -> Tree + end + end)), + ?_assertEqual("{2, [bar], baz()}", + f(begin + Tree = ?Q("{fie, [bar], baz()}"), + case Tree of + ?Q("{foo, _@Bar, '@Baz'}") -> + ?Q("{1, _@Bar, _@Baz}"); + ?Q("{fie, _@Bar, '@Baz'}") -> + ?Q("{2, _@Bar, _@Baz}"); + _ -> Tree + end + end)), + ?_assertEqual("{2, baz()}", + f(begin + Tree = ?Q("{foo, [bar], baz()}"), + case Tree of + ?Q("{foo, [_@Bar], '@Baz'}") + when erl_syntax:is_atom(Bar, foo) -> + ?Q("{1, _@Baz}"); + ?Q("{foo, [_@Bar], '@Baz'}") + when erl_syntax:is_atom(Bar, bar) -> + ?Q("{2, _@Baz}"); + ?Q("{foo, [_@Bar], '@Baz'}") -> + ?Q("{3, _@Baz}"); + _ -> Tree + end + end)), + ?_assertEqual("{2, 42}", + f(begin + Tree = ?Q("{foo, [bar], 42}"), + case Tree of + ?Q("{foo, [_@Bar], '@Baz'}") + when erl_syntax:is_atom(Bar, bar), + erl_syntax:is_integer(Baz, 17) -> + ?Q("{1, _@Bar}"); + ?Q("{foo, [_@Bar], '@Baz'}") + when erl_syntax:is_atom(Bar, bar), + erl_syntax:is_integer(Baz, 42) -> + ?Q("{2, _@Baz}"); + ?Q("{foo, [_@Bar], '@Baz'}") -> + ?Q("{3, _@Baz}"); + _ -> Tree + end + end)), + ?_assertEqual("{2, 42}", + f(begin + Tree = ?Q("{foo, [baz], 42}"), + case Tree of + ?Q("{foo, [_@Bar], '@Baz'}") + when erl_syntax:is_atom(Bar, bar), + erl_syntax:is_integer(Baz, 17) + ; erl_syntax:is_atom(Bar, baz), + erl_syntax:is_integer(Baz, 17) -> + ?Q("{1, _@Bar}"); + ?Q("{foo, [_@Bar], '@Baz'}") + when erl_syntax:is_atom(Bar, bar), + erl_syntax:is_integer(Baz, 42) + ; erl_syntax:is_atom(Bar, baz), + erl_syntax:is_integer(Baz, 42) -> + ?Q("{2, _@Baz}"); + ?Q("{foo, [_@Bar], '@Baz'}") -> + ?Q("{3, _@Baz}"); + _ -> Tree + end + end)), + ?_assertEqual("{2, foo, Bar, Baz, Bar(), Baz()}", + f(begin + Tree = ?Q("foo(Bar, Baz) -> Bar(), Baz()."), + case Tree of + ?Q("'@Func'(_@Args) -> _@Body.") -> + ?Q("{1, _@Func, _@Args, _@Body}"); + ?Q("'@Func'(_@@Args) -> _@@Body.") -> + ?Q("{2, _@Func, _@Args, _@Body}"); + ?Q("'@Func'(_@Args, Baz) -> _@Body1, _@Body2.") -> + ?Q("{3, _@Func, _@Args, _@Body1, _@Body2}") + end + end)) + ]. + +-endif. diff --git a/lib/syntax_tools/src/merl_transform.erl b/lib/syntax_tools/src/merl_transform.erl new file mode 100644 index 0000000000..66b06c8137 --- /dev/null +++ b/lib/syntax_tools/src/merl_transform.erl @@ -0,0 +1,262 @@ +%% --------------------------------------------------------------------- +%% 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. +%% +%% @author Richard Carlsson <[email protected]> +%% @copyright 2012-2015 Richard Carlsson +%% @doc Parse transform for merl. Enables the use of automatic metavariables +%% and using quasi-quotes in matches and case switches. Also optimizes calls +%% to functions in `merl' by partially evaluating them, turning strings to +%% templates, etc., at compile-time. +%% +%% Using `-include_lib("syntax_tools/include/merl.hrl").' enables this +%% transform, unless the macro `MERL_NO_TRANSFORM' is defined first. + +-module(merl_transform). + +-export([parse_transform/2]). + +%% NOTE: We cannot use inline metavariables or any other parse transform +%% features in this module, because it must be possible to compile it with +%% the parse transform disabled! +-include("merl.hrl"). + +%% TODO: unroll calls to switch? it will probably get messy + +%% TODO: use Igor to make resulting code independent of merl at runtime? + +parse_transform(Forms, _Options) -> + erl_syntax:revert_forms(expand(erl_syntax:form_list(Forms))). + +expand(Tree0) -> + Tree = pre(Tree0), + post(case erl_syntax:subtrees(Tree) of + [] -> + Tree; + Gs -> + erl_syntax:update_tree(Tree, + [[expand(T) || T <- G] || G <- Gs]) + end). + +pre(T) -> + merl:switch( + T, + [{?Q("merl:quote(_@line, _@text) = _@expr"), + fun ([{expr,_}, {line,Line}, {text,Text}]) -> + erl_syntax:is_literal(Text) andalso erl_syntax:is_literal(Line) + end, + fun ([{expr,Expr}, {line,Line}, {text,Text}]) -> + pre_expand_match(Expr, erl_syntax:concrete(Line), + erl_syntax:concrete(Text)) + end}, + {?Q(["case _@expr of", + " merl:quote(_@_, _@text) when _@__@_ -> _@@_; _@_@_ -> 0", + "end"]), + fun case_guard/1, + fun (As) -> case_body(As, T) end}, + fun () -> T end + ]). + +case_guard([{expr,_}, {text,Text}]) -> + erl_syntax:is_literal(Text). + +case_body([{expr,Expr}, {text,_Text}], T) -> + pre_expand_case(Expr, erl_syntax:case_expr_clauses(T), + erl_syntax:get_pos(T)). + +post(T) -> + merl:switch( + T, + [{?Q("merl:_@function(_@@args)"), + [{fun ([{args, As}, {function, F}]) -> + lists:all(fun erl_syntax:is_literal/1, [F|As]) + end, + fun ([{args, As}, {function, F}]) -> + Line = erl_syntax:get_pos(F), + [F1|As1] = lists:map(fun erl_syntax:concrete/1, [F|As]), + eval_call(Line, F1, As1, T) + end}, + fun ([{args, As}, {function, F}]) -> + merl:switch( + F, + [{?Q("qquote"), fun ([]) -> expand_qquote(As, T, 1) end}, + {?Q("subst"), fun ([]) -> expand_template(F, As, T) end}, + {?Q("match"), fun ([]) -> expand_template(F, As, T) end}, + fun () -> T end + ]) + end]}, + fun () -> T end]). + +expand_qquote([Line, Text, Env], T, _) -> + case erl_syntax:is_literal(Line) of + true -> + expand_qquote([Text, Env], T, erl_syntax:concrete(Line)); + false -> + T + end; +expand_qquote([Text, Env], T, Line) -> + case erl_syntax:is_literal(Text) of + true -> + As = [Line, erl_syntax:concrete(Text)], + %% expand further if possible + expand(merl:qquote(Line, "merl:subst(_@tree, _@env)", + [{tree, eval_call(Line, quote, As, T)}, + {env, Env}])); + false -> + T + end; +expand_qquote(_As, T, _StartPos) -> + T. + +expand_template(F, [Pattern | Args], T) -> + case erl_syntax:is_literal(Pattern) of + true -> + Line = erl_syntax:get_pos(Pattern), + As = [erl_syntax:concrete(Pattern)], + merl:qquote(Line, "merl:_@function(_@pattern, _@args)", + [{function, F}, + {pattern, eval_call(Line, template, As, T)}, + {args, Args}]); + false -> + T + end; +expand_template(_F, _As, T) -> + T. + +eval_call(Line, F, As, T) -> + try apply(merl, F, As) of + T1 when F =:= quote -> + %% lift metavariables in a template to Erlang variables + Template = merl:template(T1), + Vars = merl:template_vars(Template), + case lists:any(fun is_inline_metavar/1, Vars) of + true when is_list(T1) -> + merl:qquote(Line, "merl:tree([_@template])", + [{template, merl:meta_template(Template)}]); + true -> + merl:qquote(Line, "merl:tree(_@template)", + [{template, merl:meta_template(Template)}]); + false -> + merl:term(T1) + end; + T1 -> + merl:term(T1) + catch + throw:_Reason -> T + end. + +pre_expand_match(Expr, Line, Text) -> + {Template, Out, _Vars} = rewrite_pattern(Line, Text), + merl:qquote(Line, "{ok, _@out} = merl:match(_@template, _@expr)", + [{expr, Expr}, + {out, Out}, + {template, erl_syntax:abstract(Template)}]). + +rewrite_pattern(Line, Text) -> + %% we must rewrite the metavariables in the pattern to use lowercase, + %% and then use real matching to bind the Erlang-level variables + T0 = merl:template(merl:quote(Line, Text)), + Vars = [V || V <- merl:template_vars(T0), is_inline_metavar(V)], + {merl:alpha(T0, [{V, var_to_tag(V)} || V <- Vars]), + erl_syntax:list([erl_syntax:tuple([erl_syntax:abstract(var_to_tag(V)), + erl_syntax:variable(var_name(V))]) + || V <- Vars]), + Vars}. + +var_name(V) when is_integer(V) -> + V1 = if V > 99, (V rem 100) =:= 99 -> + V div 100; + V > 9, (V rem 10) =:= 9 -> + V div 10; + true -> V + end, + list_to_atom("Q" ++ integer_to_list(V1)); +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))). + +pre_expand_case(Expr, Clauses, Line) -> + merl:qquote(Line, "merl:switch(_@expr, _@clauses)", + [{clauses, erl_syntax:list([pre_expand_case_clause(C) + || C <- Clauses])}, + {expr, Expr}]). + +pre_expand_case_clause(T) -> + %% note that the only allowed non ``?Q(...) -> ...'' clause is ``_ -> ...'' + merl:switch( + T, + [{?Q("(merl:quote(_@line, _@text)) when _@__@guard -> _@@body"), + fun ([{body,_}, {guard,_}, {line,Line}, {text,Text}]) -> + erl_syntax:is_literal(Text) andalso erl_syntax:is_literal(Line) + end, + fun ([{body,Body}, {guard,Guard}, {line,Line}, {text,Text}]) -> + pre_expand_case_clause(Body, Guard, erl_syntax:concrete(Line), + erl_syntax:concrete(Text)) + end}, + {?Q("_ -> _@@body"), + fun (Env) -> merl:qquote("fun () -> _@body end", Env) end} + ]). + +pre_expand_case_clause(Body, Guard, Line, Text) -> + %% this is similar to a meta-match ``?Q("...") = Term'' + %% (note that the guards may in fact be arbitrary expressions) + {Template, Out, Vars} = rewrite_pattern(Line, Text), + GuardExprs = rewrite_guard(Guard), + Param = [{body, Body}, + {guard,GuardExprs}, + {out, Out}, + {template, erl_syntax:abstract(Template)}, + {unused, dummy_uses(Vars)}], + case GuardExprs of + [] -> + merl:qquote(Line, ["{_@template, ", + " fun (_@out) -> _@unused, _@body end}"], + Param); + _ -> + merl:qquote(Line, ["{_@template, ", + " fun (_@out) -> _@unused, _@guard end, ", + " fun (_@out) -> _@unused, _@body end}"], + Param) + end. + +%% We have to insert dummy variable uses at the beginning of the "guard" and +%% "body" function bodies to avoid warnings for unused variables in the +%% generated code. (Expansions at the Erlang level can't be marked up as +%% compiler generated to allow later compiler stages to ignore them.) +dummy_uses(Vars) -> + [?Q("_ = _@var", [{var, erl_syntax:variable(var_name(V))}]) + || V <- Vars]. + +rewrite_guard([]) -> []; +rewrite_guard([D]) -> [make_orelse(erl_syntax:disjunction_body(D))]. + +make_orelse([]) -> []; +make_orelse([C]) -> make_andalso(erl_syntax:conjunction_body(C)); +make_orelse([C | Cs]) -> + ?Q("_@expr orelse _@rest", + [{expr, make_andalso(erl_syntax:conjunction_body(C))}, + {rest, make_orelse(Cs)}]). + +make_andalso([E]) -> E; +make_andalso([E | Es]) -> + ?Q("_@expr andalso _@rest", [{expr, E}, {rest, make_andalso(Es)}]). + +is_inline_metavar(Var) when is_atom(Var) -> + is_erlang_var(atom_to_list(Var)); +is_inline_metavar(Var) when is_integer(Var) -> + Var > 9 andalso (Var rem 10) =:= 9; +is_inline_metavar(_) -> false. + +is_erlang_var([C|_]) when C >= $A, C =< $Z ; C >= $À, C =< $Þ, C /= $× -> + true; +is_erlang_var(_) -> + false. diff --git a/lib/syntax_tools/src/syntax_tools.app.src b/lib/syntax_tools/src/syntax_tools.app.src index 83dcb5fe23..e207901def 100644 --- a/lib/syntax_tools/src/syntax_tools.app.src +++ b/lib/syntax_tools/src/syntax_tools.app.src @@ -11,8 +11,10 @@ erl_syntax_lib, erl_tidy, igor, + merl, + merl_transform, prettypr]}, {registered,[]}, {applications, [stdlib]}, {env, []}, - {runtime_dependencies, ["stdlib-2.0","kernel-3.0","erts-6.0"]}]}. + {runtime_dependencies, ["stdlib-2.5","kernel-3.0","erts-6.0"]}]}. diff --git a/lib/syntax_tools/test/Makefile b/lib/syntax_tools/test/Makefile index f67e3f8984..569c044b1a 100644 --- a/lib/syntax_tools/test/Makefile +++ b/lib/syntax_tools/test/Makefile @@ -6,7 +6,8 @@ include $(ERL_TOP)/make/$(TARGET)/otp.mk # ---------------------------------------------------- MODULES= \ - syntax_tools_SUITE + syntax_tools_SUITE \ + merl_SUITE ERL_FILES= $(MODULES:%=%.erl) diff --git a/lib/syntax_tools/test/merl_SUITE.erl b/lib/syntax_tools/test/merl_SUITE.erl new file mode 100644 index 0000000000..08b0f7a696 --- /dev/null +++ b/lib/syntax_tools/test/merl_SUITE.erl @@ -0,0 +1,91 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +-module(merl_SUITE). + +-include_lib("test_server/include/test_server.hrl"). + +%% include the Merl header file +-include_lib("syntax_tools/include/merl.hrl"). + +%% for assert macros +-include_lib("eunit/include/eunit.hrl"). + +%% Test server specific exports +-export([all/0, suite/0,groups/0,init_per_suite/1, end_per_suite/1, + init_per_group/2,end_per_group/2]). + +%% Test cases +-export([merl_smoke_test/1]). + +suite() -> [{ct_hooks,[ts_install_cth]}]. + +all() -> + [merl_smoke_test]. + +groups() -> + []. + +init_per_suite(Config) -> + Config. + +end_per_suite(_Config) -> + ok. + +init_per_group(_GroupName, Config) -> + Config. + +end_per_group(_GroupName, Config) -> + Config. + +-define(tokens2str(X), ??X). + +merl_smoke_test(Config) when is_list(Config) -> + ?assertThrow({error, "1: syntax error before: '{'" ++ _}, + f(merl:quote("{"))), + ?assertEqual(tuple, erl_syntax:type(merl:term({}))), + ?assertEqual("{foo, 42}", f(merl:term({foo, 42}))), + ?assertEqual("f(X) -> {ok, X}.", f(?Q("f(X) -> {ok, X}."))), + ?assertEqual("{foo, 42}", f(?Q("{foo, 42}"))), + ?assertEqual("2 + 2", f(?Q("2 + 2"))), + ?assertEqual("%% comment preserved\n{foo, 42}", + f(?Q(["%% comment preserved", "{foo, 42}"]))), + ?assertEqual("'@foo'", f(merl:tree(merl:template(?Q("'@foo'"))))), + ?assertEqual("42", f(merl:subst(?Q("_@foo"), [{foo, merl:term(42)}]))), + ?assertEqual({ok, []}, merl:match(?Q("foo"), ?Q("foo"))), + ?assertEqual(42, merl:switch(?Q("foo"), [fun () -> 42 end])), + ?assertEqual("{foo}", f(begin Foo = ?Q("foo"), ?Q("{_@Foo}") end)), + ?assertEqual("{foo}", f(begin Foo = foo, ?Q("{_@Foo@}") end)), + ?assertEqual("{[bar], baz()}", + f(begin + Tree = ?Q("{foo, [bar], baz()}"), + ?Q("{foo, _@Bar, '@Baz'}") = Tree, + ?Q("{_@Bar, _@Baz}") + end)), + ?assertEqual("{[bar], baz()}", + f(begin + Tree = ?Q("{foo, [bar], baz()}"), + case Tree of + ?Q("{foo, _@Bar, '@Baz'}") -> ?Q("{_@Bar, _@Baz}") + end + end)), + ok. + +%% utilities + +f(Ts) when is_list(Ts) -> + lists:flatmap(fun erl_prettypr:format/1, Ts); +f(T) -> + erl_prettypr:format(T). diff --git a/lib/test_server/src/erl2html2.erl b/lib/test_server/src/erl2html2.erl index 2e443c7b8b..b0b5c40965 100644 --- a/lib/test_server/src/erl2html2.erl +++ b/lib/test_server/src/erl2html2.erl @@ -109,27 +109,26 @@ parse_file(File, InclPath) -> Error end. -parse_preprocessed_file(Epp,File,InCorrectFile) -> +parse_preprocessed_file(Epp, File, InCorrectFile) -> case epp:parse_erl_form(Epp) of {ok,Form} -> case Form of {attribute,_,file,{File,_}} -> - parse_preprocessed_file(Epp,File,true); + parse_preprocessed_file(Epp, File, true); {attribute,_,file,{_OtherFile,_}} -> - parse_preprocessed_file(Epp,File,false); + parse_preprocessed_file(Epp, File, false); {function,L,F,A,Cs} when InCorrectFile -> {CLs,LastCL} = find_clause_lines(Cs, []), - Clauses = [{clause,get_line(CL)} || - {clause,CL,_,_,_} <- tl(CLs)], - [{atom_to_list(F),A,get_line(L),get_line(LastCL)} | Clauses] ++ - parse_preprocessed_file(Epp,File,true); + %% tl(CLs) cause we know the start line already + [{atom_to_list(F),A,get_line(L),LastCL} | tl(CLs)] ++ + parse_preprocessed_file(Epp, File, true); _ -> - parse_preprocessed_file(Epp,File,InCorrectFile) + parse_preprocessed_file(Epp, File, InCorrectFile) end; {error,Reason={_L,epp,{undefined,_Macro,none}}} -> throw({error,Reason,InCorrectFile}); {error,_Reason} -> - parse_preprocessed_file(Epp,File,InCorrectFile); + parse_preprocessed_file(Epp, File, InCorrectFile); {eof,_Location} -> [] end. @@ -150,9 +149,8 @@ parse_non_preprocessed_file(Epp, File, Location) -> try erl_syntax:revert(Tree) of {function,L,F,A,Cs} -> {CLs,LastCL} = find_clause_lines(Cs, []), - Clauses = [{clause,get_line(CL)} || - {clause,CL,_,_,_} <- tl(CLs)], - [{atom_to_list(F),A,get_line(L),get_line(LastCL)} | Clauses] ++ + %% tl(CLs) cause we know the start line already + [{atom_to_list(F),A,get_line(L),LastCL} | tl(CLs)] ++ parse_non_preprocessed_file(Epp, File, Location1); _ -> parse_non_preprocessed_file(Epp, File, Location1) @@ -172,17 +170,21 @@ get_line(Anno) -> %%% Find the line number of the last expression in the function find_clause_lines([{clause,CL,_Params,_Op,Exprs}], CLs) -> % last clause try tuple_to_list(lists:last(Exprs)) of - [_Type,ExprLine | _] -> - {lists:reverse([{clause,CL}|CLs]), ExprLine}; + [_Type,ExprLine | _] when is_integer(ExprLine) -> + {lists:reverse([{clause,get_line(CL)}|CLs]), get_line(ExprLine)}; + [tree,_ | Exprs1] -> + find_clause_lines([{clause,CL,undefined,undefined,Exprs1}], CLs); + [macro,{_var,ExprLine,_MACRO} | _] when is_integer(ExprLine) -> + {lists:reverse([{clause,get_line(CL)}|CLs]), get_line(ExprLine)}; _ -> - {lists:reverse([{clause,CL}|CLs]), CL} + {lists:reverse([{clause,get_line(CL)}|CLs]), get_line(CL)} catch _:_ -> - {lists:reverse([{clause,CL}|CLs]), CL} + {lists:reverse([{clause,get_line(CL)}|CLs]), get_line(CL)} end; find_clause_lines([{clause,CL,_Params,_Op,_Exprs} | Cs], CLs) -> - find_clause_lines(Cs, [{clause,CL}|CLs]). + find_clause_lines(Cs, [{clause,get_line(CL)}|CLs]). %%%----------------------------------------------------------------- %%% Add a link target for each line and one for each function definition. @@ -190,18 +192,18 @@ build_html(SFd,DFd,Encoding,FuncsAndCs) -> build_html(SFd,DFd,Encoding,file:read_line(SFd),1,FuncsAndCs, false,undefined). -%% function start line found -build_html(SFd,DFd,Enc,{ok,Str},L0,[{F,A,L0,LastL}|FuncsAndCs], - _IsFuncDef,_FAndLastL) -> - FALink = test_server_ctrl:uri_encode(F++"-"++integer_to_list(A),utf8), - file:write(DFd,["<a name=\"",to_raw_list(FALink,Enc),"\"/>"]), - build_html(SFd,DFd,Enc,{ok,Str},L0,FuncsAndCs,true,{F,LastL}); %% line of last expression in function found build_html(SFd,DFd,Enc,{ok,Str},LastL,FuncsAndCs,_IsFuncDef,{F,LastL}) -> LastLineLink = test_server_ctrl:uri_encode(F++"-last_expr",utf8), file:write(DFd,["<a name=\"", to_raw_list(LastLineLink,Enc),"\"/>"]), build_html(SFd,DFd,Enc,{ok,Str},LastL,FuncsAndCs,true,undefined); +%% function start line found +build_html(SFd,DFd,Enc,{ok,Str},L0,[{F,A,L0,LastL}|FuncsAndCs], + _IsFuncDef,_FAndLastL) -> + FALink = test_server_ctrl:uri_encode(F++"-"++integer_to_list(A),utf8), + file:write(DFd,["<a name=\"",to_raw_list(FALink,Enc),"\"/>"]), + build_html(SFd,DFd,Enc,{ok,Str},L0,FuncsAndCs,true,{F,LastL}); build_html(SFd,DFd,Enc,{ok,Str},L,[{clause,L}|FuncsAndCs], _IsFuncDef,FAndLastL) -> build_html(SFd,DFd,Enc,{ok,Str},L,FuncsAndCs,true,FAndLastL); diff --git a/lib/test_server/src/test_server.app.src b/lib/test_server/src/test_server.app.src index 5538e8b851..bdd9d28444 100644 --- a/lib/test_server/src/test_server.app.src +++ b/lib/test_server/src/test_server.app.src @@ -32,7 +32,7 @@ test_server_break_process]}, {applications, [kernel,stdlib]}, {env, []}, - {runtime_dependencies, ["tools-2.6.14","stdlib-2.0","runtime_tools-1.8.14", - "observer-2.0","kernel-3.0","inets-5.10", - "syntax_tools-1.6.16","erts-7.0"]}]}. + {runtime_dependencies, ["tools-2.8","stdlib-2.5","runtime_tools-1.8.16", + "observer-2.1","kernel-4.0","inets-6.0", + "syntax_tools-1.7","erts-7.0"]}]}. diff --git a/lib/test_server/src/ts.erl b/lib/test_server/src/ts.erl index 469593e947..85f97656ff 100644 --- a/lib/test_server/src/ts.erl +++ b/lib/test_server/src/ts.erl @@ -262,18 +262,28 @@ run_all(_Vars) -> run_some([], _Opts) -> ok; -run_some([{App,Mod}|Apps], Opts) -> +run_some(Apps, Opts) -> + case proplists:get_value(test_category, Opts) of + bench -> + check_and_run(fun(Vars) -> ts_benchmark:run(Apps, Opts, Vars) end); + _Other -> + run_some1(Apps, Opts) + end. + +run_some1([], _Opts) -> + ok; +run_some1([{App,Mod}|Apps], Opts) -> case run(App, Mod, Opts) of ok -> ok; Error -> io:format("~p: ~p~n",[{App,Mod},Error]) end, - run_some(Apps, Opts); -run_some([App|Apps], Opts) -> + run_some1(Apps, Opts); +run_some1([App|Apps], Opts) -> case run(App, Opts) of ok -> ok; Error -> io:format("~p: ~p~n",[App,Error]) end, - run_some(Apps, Opts). + run_some1(Apps, Opts). %% This can be used from command line. Both App and %% TestCategory must be specified. App may be 'all' diff --git a/lib/test_server/test/erl2html2_SUITE.erl b/lib/test_server/test/erl2html2_SUITE.erl index 908985c879..796b84dedd 100644 --- a/lib/test_server/test/erl2html2_SUITE.erl +++ b/lib/test_server/test/erl2html2_SUITE.erl @@ -130,15 +130,7 @@ groups() -> %% @end %%-------------------------------------------------------------------- all() -> - [m1]. - -%%-------------------------------------------------------------------- -%% @spec TestCase() -> Info -%% Info = [tuple()] -%% @end -%%-------------------------------------------------------------------- -m1() -> - []. + [macros_defined, macros_undefined]. %%-------------------------------------------------------------------- %% @spec TestCase(Config0) -> @@ -149,19 +141,29 @@ m1() -> %% Comment = term() %% @end %%-------------------------------------------------------------------- -m1(Config) -> - {Src,Dst} = convert_module("m1",Config), +macros_defined(Config) -> + %% let erl2html2 use epp as parser + DataDir = ?config(data_dir,Config), + InclDir = filename:join(DataDir, "include"), + {Src,Dst} = convert_module("m1",[InclDir],Config), {true,L} = check_line_numbers(Src,Dst), - ok = check_link_targets(Src,Dst,L,[{baz,0}]), + ok = check_link_targets(Src,Dst,L,[{baz,0}],[]), ok. -convert_module(Mod,Config) -> +macros_undefined(Config) -> + %% let erl2html2 use epp_dodger as parser + {Src,Dst} = convert_module("m1",[],Config), + {true,L} = check_line_numbers(Src,Dst), + ok = check_link_targets(Src,Dst,L,[{baz,0}],[{quux,0}]), + ok. + +convert_module(Mod,InclDirs,Config) -> DataDir = ?config(data_dir,Config), PrivDir = ?config(priv_dir,Config), Src = filename:join(DataDir,Mod++".erl"), Dst = filename:join(PrivDir,Mod++".erl.html"), io:format("<a href=\"~s\">~s</a>\n",[Src,filename:basename(Src)]), - ok = erl2html2:convert(Src, Dst, [], "<html><body>"), + ok = erl2html2:convert(Src, Dst, InclDirs, "<html><body>"), io:format("<a href=\"~s\">~s</a>\n",[Dst,filename:basename(Dst)]), {Src,Dst}. @@ -229,36 +231,46 @@ check_line_number(Last,Line,OrigLine) -> %% function. %% The test module has -compile(export_all), so all functions are %% found by listing the exported ones. -check_link_targets(Src,Dst,L,RmFncs) -> +check_link_targets(Src,Dst,L,RmFncs,ShouldRemain) -> Mod = list_to_atom(filename:basename(filename:rootname(Src))), Exports = Mod:module_info(exports)--[{module_info,0},{module_info,1}|RmFncs], - {ok,{[],L},_} = xmerl_sax_parser:file(Dst, - [{event_fun,fun sax_event/3}, - {event_state,{Exports,0}}]), + LastExprFuncs = [Func || {Func,_A} <- Exports], + {ok,{FAs,Fs,L},_} = + xmerl_sax_parser:file(Dst, + [{event_fun,fun sax_event/3}, + {event_state,{Exports,LastExprFuncs,0}}]), + true = (length(FAs) == length(ShouldRemain)), + [] = [FA || FA <- FAs, not lists:member(FA,ShouldRemain)], + [] = [F || F <- Fs, not lists:keymember(F,1,ShouldRemain)], ok. sax_event(Event,_Loc,State) -> sax_event(Event,State). -sax_event({startElement,_Uri,"a",_QN,Attrs},{Exports,PrevLine}) -> +sax_event({startElement,_Uri,"a",_QN,Attrs},{Exports,LastExprFuncs,PrevLine}) -> {_,_,"name",Name} = lists:keyfind("name",3,Attrs), case catch list_to_integer(Name) of Line when is_integer(Line) -> case PrevLine + 1 of Line -> -% erlang:display({found_line,Line}), - {Exports,Line}; + {Exports,LastExprFuncs,Line}; Other -> ct:fail({unexpected_line_number_target,Other}) end; {'EXIT',_} -> - {match,[FStr,AStr]} = - re:run(Name,"^(.*)-([0-9]+)$",[{capture,all_but_first,list}]), + {match,[FStr,EndStr]} = + re:run(Name,"^(.*)-(last_expr|[0-9]+)$", + [{capture,all_but_first,list}]), F = list_to_atom(http_uri:decode(FStr)), - A = list_to_integer(AStr), -% erlang:display({found_fnc,F,A}), - A = proplists:get_value(F,Exports), - {lists:delete({F,A},Exports),PrevLine} + case EndStr of + "last_expr" -> + true = lists:member(F,LastExprFuncs), + {Exports,lists:delete(F,LastExprFuncs),PrevLine}; + _ -> + A = list_to_integer(EndStr), + A = proplists:get_value(F,Exports), + {lists:delete({F,A},Exports),LastExprFuncs,PrevLine} + end end; sax_event(_,State) -> State. diff --git a/lib/test_server/test/erl2html2_SUITE_data/include/header3.hrl b/lib/test_server/test/erl2html2_SUITE_data/include/header3.hrl new file mode 100644 index 0000000000..2a20850a3a --- /dev/null +++ b/lib/test_server/test/erl2html2_SUITE_data/include/header3.hrl @@ -0,0 +1 @@ +-define(EPP_SWITCH, on). diff --git a/lib/test_server/test/erl2html2_SUITE_data/m1.erl b/lib/test_server/test/erl2html2_SUITE_data/m1.erl index 156f1d0a51..1d405963a5 100644 --- a/lib/test_server/test/erl2html2_SUITE_data/m1.erl +++ b/lib/test_server/test/erl2html2_SUITE_data/m1.erl @@ -7,9 +7,15 @@ -include("header1.hrl"). -include("header2.hrl"). +-include("header3.hrl"). -define(MACRO1,value). +%% This macro is used to select parser in erl2html2. +%% If EPP_SWITCH is defined epp is used, else epp_dodger. +epp_switch() -> + ?EPP_SWITCH. + %%% Comment foo(x) -> %% Comment diff --git a/lib/test_server/vsn.mk b/lib/test_server/vsn.mk index 2a2ed2b3b0..fd9e4e6d74 100644 --- a/lib/test_server/vsn.mk +++ b/lib/test_server/vsn.mk @@ -1 +1 @@ -TEST_SERVER_VSN = 3.8.1 +TEST_SERVER_VSN = 3.9 diff --git a/lib/tools/doc/src/cprof.xml b/lib/tools/doc/src/cprof.xml index 553597837e..bfddb9f5a8 100644 --- a/lib/tools/doc/src/cprof.xml +++ b/lib/tools/doc/src/cprof.xml @@ -66,7 +66,7 @@ <func> <name>analyse() -> {AllCallCount, ModAnalysisList}</name> <name>analyse(Limit) -> {AllCallCount, ModAnalysisList}</name> - <name>analyse(Mod) -> ModAnlysis</name> + <name>analyse(Mod) -> ModAnalysis</name> <name>analyse(Mod, Limit) -> ModAnalysis</name> <fsummary>Collect and analyse call counters.</fsummary> <type> diff --git a/lib/tools/src/tools.app.src b/lib/tools/src/tools.app.src index a4e5d85f92..8458941761 100644 --- a/lib/tools/src/tools.app.src +++ b/lib/tools/src/tools.app.src @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2012. All Rights Reserved. +%% Copyright Ericsson AB 1996-2015. All Rights Reserved. %% %% The contents of this file are subject to the Erlang Public License, %% Version 1.1, (the "License"); you may not use this file except in @@ -40,7 +40,7 @@ {env, [{file_util_search_methods,[{"", ""}, {"ebin", "esrc"}, {"ebin", "src"}]} ] }, - {runtime_dependencies, ["webtool-0.8.10","stdlib-2.0","runtime_tools-1.8.14", + {runtime_dependencies, ["webtool-0.8.10","stdlib-2.5","runtime_tools-1.8.14", "kernel-3.0","inets-5.10","erts-7.0", "compiler-5.0"]} ] diff --git a/lib/webtool/vsn.mk b/lib/webtool/vsn.mk index a79c273d9f..4a701ae6e0 100644 --- a/lib/webtool/vsn.mk +++ b/lib/webtool/vsn.mk @@ -1 +1 @@ -WEBTOOL_VSN=0.8.10 +WEBTOOL_VSN=0.9 diff --git a/lib/wx/c_src/wxe_driver.c b/lib/wx/c_src/wxe_driver.c index ea52737fa2..ec1ba7f566 100644 --- a/lib/wx/c_src/wxe_driver.c +++ b/lib/wx/c_src/wxe_driver.c @@ -146,7 +146,12 @@ wxe_driver_stop(ErlDrvData handle) if(sd->port_handle != WXE_DRV_PORT_HANDLE) { // fprintf(stderr, "%s:%d: STOP \r\n", __FILE__,__LINE__); meta_command(DELETE_PORT,sd); - free(handle); + } else { + // fprintf(stderr, "%s:%d: STOP \r\n", __FILE__,__LINE__); + stop_native_gui(wxe_master); + unload_native_gui(); + free(wxe_master); + wxe_master = NULL; } } @@ -154,10 +159,6 @@ static void wxe_driver_unload(void) { // fprintf(stderr, "%s:%d: UNLOAD \r\n", __FILE__,__LINE__); - stop_native_gui(wxe_master); - unload_native_gui(); - free(wxe_master); - wxe_master = NULL; } static ErlDrvSSizeT diff --git a/lib/wx/c_src/wxe_impl.cpp b/lib/wx/c_src/wxe_impl.cpp index ef648e008c..2fd5f0c52c 100644 --- a/lib/wx/c_src/wxe_impl.cpp +++ b/lib/wx/c_src/wxe_impl.cpp @@ -89,7 +89,7 @@ void push_command(int op,char * buf,int len, wxe_data *sd) } void meta_command(int what, wxe_data *sd) { - if(what == PING_PORT) { + if(what == PING_PORT && wxe_status == WXE_INITIATED) { erl_drv_mutex_lock(wxe_batch_locker_m); if(wxe_batch_caller > 0) { wxe_queue->Add(WXE_DEBUG_PING, NULL, 0, sd); @@ -98,9 +98,12 @@ void meta_command(int what, wxe_data *sd) { wxWakeUpIdle(); erl_drv_mutex_unlock(wxe_batch_locker_m); } else { - if(sd) { + if(sd && wxe_status == WXE_INITIATED) { wxeMetaCommand Cmd(sd, what); wxTheApp->AddPendingEvent(Cmd); + if(what == DELETE_PORT) { + free(sd); + } } } } @@ -169,6 +172,7 @@ void WxeApp::MacOpenFile(const wxString &filename) { #endif void WxeApp::shutdown(wxeMetaCommand& Ecmd) { + wxe_status = WXE_EXITING; ExitMainLoop(); delete wxe_queue; delete wxe_queue_cb_saved; @@ -200,6 +204,10 @@ void handle_event_callback(ErlDrvPort port, ErlDrvTermData process) { WxeApp * app = (WxeApp *) wxTheApp; ErlDrvMonitor monitor; + + if(wxe_status != WXE_INITIATED) + return; + // Is thread safe if pdl have been incremented if(driver_monitor_process(port, process, &monitor) == 0) { // Should we be able to handle commands when recursing? probably @@ -217,6 +225,8 @@ void handle_event_callback(ErlDrvPort port, ErlDrvTermData process) void WxeApp::dispatch_cmds() { + if(wxe_status != WXE_INITIATED) + return; erl_drv_mutex_lock(wxe_batch_locker_m); recurse_level++; int level = dispatch(wxe_queue_cb_saved, 0, WXE_STORED); diff --git a/lib/wx/c_src/wxe_impl.h b/lib/wx/c_src/wxe_impl.h index a0a1c84718..b251d5f0f9 100644 --- a/lib/wx/c_src/wxe_impl.h +++ b/lib/wx/c_src/wxe_impl.h @@ -46,7 +46,8 @@ typedef wxString wxeLocaleC; #define WXE_NOT_INITIATED 0 #define WXE_INITIATED 1 -#define WXE_EXITED 2 +#define WXE_EXITING 2 +#define WXE_EXITED 3 #define WXE_ERROR -1 void send_msg(const char *, const wxString *); // For debugging and error msgs diff --git a/lib/xmerl/src/xmerl.app.src b/lib/xmerl/src/xmerl.app.src index 45cfe9d250..aed9cf176f 100644 --- a/lib/xmerl/src/xmerl.app.src +++ b/lib/xmerl/src/xmerl.app.src @@ -40,5 +40,5 @@ {registered, []}, {env, []}, {applications, [kernel, stdlib]}, - {runtime_dependencies, ["stdlib-2.0","kernel-3.0","erts-6.0"]} + {runtime_dependencies, ["stdlib-2.5","kernel-3.0","erts-6.0"]} ]}. |