aboutsummaryrefslogtreecommitdiffstats
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/.gitignore2
-rw-r--r--lib/asn1/doc/src/asn1ct.xml18
-rw-r--r--lib/compiler/src/beam_bsm.erl6
-rw-r--r--lib/compiler/src/compile.erl6
-rw-r--r--lib/compiler/src/compiler.app.src4
-rw-r--r--lib/compiler/test/warnings_SUITE.erl17
-rw-r--r--lib/cosNotification/src/cosNotification.app.src2
-rw-r--r--lib/crypto/test/crypto_SUITE.erl5
-rw-r--r--lib/crypto/test/old_crypto_SUITE.erl6
-rw-r--r--lib/debugger/src/debugger.app.src4
-rw-r--r--lib/debugger/test/map_SUITE.erl4
-rw-r--r--lib/dialyzer/src/dialyzer.app.src4
-rw-r--r--lib/edoc/src/edoc.app.src2
-rw-r--r--lib/erl_docgen/src/erl_docgen.app.src2
-rw-r--r--lib/eunit/src/eunit.app.src2
-rw-r--r--lib/hipe/main/hipe.app.src4
-rw-r--r--lib/kernel/src/application_controller.erl3
-rw-r--r--lib/kernel/src/code.erl11
-rw-r--r--lib/kernel/src/inet_parse.erl30
-rw-r--r--lib/kernel/src/kernel.app.src2
-rw-r--r--lib/kernel/src/user_drv.erl48
-rw-r--r--lib/kernel/test/inet_SUITE.erl3
-rw-r--r--lib/megaco/src/app/megaco.app.src4
-rw-r--r--lib/megaco/vsn.mk4
-rw-r--r--lib/parsetools/src/parsetools.app.src2
-rw-r--r--lib/snmp/src/app/snmp.app.src4
-rw-r--r--lib/snmp/vsn.mk2
-rw-r--r--lib/ssh/doc/src/ssh.xml102
-rw-r--r--lib/ssh/src/ssh.erl148
-rw-r--r--lib/ssh/src/ssh_auth.erl66
-rw-r--r--lib/ssh/src/ssh_auth.hrl2
-rw-r--r--lib/ssh/src/ssh_connection_handler.erl319
-rw-r--r--lib/ssh/src/ssh_transport.erl132
-rw-r--r--lib/ssh/test/Makefile3
-rw-r--r--lib/ssh/test/ssh_basic_SUITE.erl237
-rw-r--r--lib/ssh/test/ssh_connection_SUITE.erl1
-rw-r--r--lib/ssh/test/ssh_relay.erl407
-rw-r--r--lib/ssh/test/ssh_sftp_SUITE.erl1
-rw-r--r--lib/ssh/test/ssh_sftpd_SUITE.erl1
-rw-r--r--lib/ssh/test/ssh_sftpd_erlclient_SUITE.erl1
-rw-r--r--lib/ssh/test/ssh_to_openssh_SUITE.erl10
-rw-r--r--lib/ssh/test/ssh_unicode_SUITE.erl1
-rw-r--r--lib/ssl/test/ssl_alpn_handshake_SUITE.erl6
-rw-r--r--lib/ssl/test/ssl_basic_SUITE.erl10
-rw-r--r--lib/ssl/test/ssl_npn_handshake_SUITE.erl6
-rw-r--r--lib/ssl/test/ssl_sni_SUITE.erl51
-rw-r--r--lib/ssl/test/ssl_test_lib.erl3
-rw-r--r--lib/ssl/test/ssl_to_openssl_SUITE.erl53
-rw-r--r--lib/stdlib/doc/src/ets.xml4
-rw-r--r--lib/stdlib/src/erl_lint.erl66
-rw-r--r--lib/stdlib/src/ets.erl43
-rw-r--r--lib/stdlib/src/stdlib.app.src2
-rw-r--r--lib/stdlib/test/binary_module_SUITE.erl50
-rw-r--r--lib/stdlib/test/ets_SUITE.erl31
-rw-r--r--lib/stdlib/test/io_proto_SUITE.erl2
-rw-r--r--lib/stdlib/test/maps_SUITE.erl7
-rw-r--r--lib/stdlib/test/rand_SUITE.erl2
-rw-r--r--lib/stdlib/test/unicode_SUITE.erl3
-rw-r--r--lib/syntax_tools/doc/overview.edoc83
-rw-r--r--lib/syntax_tools/doc/src/Makefile2
-rw-r--r--lib/syntax_tools/doc/src/ref_man.xml13
-rw-r--r--lib/syntax_tools/examples/merl/Makefile22
-rw-r--r--lib/syntax_tools/examples/merl/basic.erl77
-rw-r--r--lib/syntax_tools/examples/merl/basic_test.erl77
-rw-r--r--lib/syntax_tools/examples/merl/basicc.erl149
-rw-r--r--lib/syntax_tools/examples/merl/lisp.erl160
-rw-r--r--lib/syntax_tools/examples/merl/lisp_test.erl98
-rw-r--r--lib/syntax_tools/examples/merl/lispc.erl102
-rw-r--r--lib/syntax_tools/examples/merl/merl_build.erl104
-rw-r--r--lib/syntax_tools/include/merl.hrl29
-rw-r--r--lib/syntax_tools/src/Makefile21
-rw-r--r--lib/syntax_tools/src/merl.erl1230
-rw-r--r--lib/syntax_tools/src/merl_tests.erl539
-rw-r--r--lib/syntax_tools/src/merl_transform.erl262
-rw-r--r--lib/syntax_tools/src/syntax_tools.app.src4
-rw-r--r--lib/syntax_tools/test/Makefile3
-rw-r--r--lib/syntax_tools/test/merl_SUITE.erl91
-rw-r--r--lib/tools/src/tools.app.src4
-rw-r--r--lib/tools/test/lcnt_SUITE.erl10
-rw-r--r--lib/wx/c_src/wxe_driver.c11
-rw-r--r--lib/wx/c_src/wxe_impl.cpp14
-rw-r--r--lib/wx/c_src/wxe_impl.h3
-rw-r--r--lib/xmerl/src/xmerl.app.src2
83 files changed, 4507 insertions, 574 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/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 3076400f58..0bfd998301 100644
--- a/lib/compiler/src/compiler.app.src
+++ b/lib/compiler/src/compiler.app.src
@@ -70,5 +70,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/crypto/test/crypto_SUITE.erl b/lib/crypto/test/crypto_SUITE.erl
index 72944eea8e..ff7af1f2c1 100644
--- a/lib/crypto/test/crypto_SUITE.erl
+++ b/lib/crypto/test/crypto_SUITE.erl
@@ -1884,8 +1884,9 @@ dss_params() ->
18320614775012672475365915366944922415598782131828709277168615511695849821411624805195787607930033958243224786899641459701930253094446221381818858674389863050420226114787005820357372837321561754462061849169568607689530279303056075793886577588606958623645901271866346406773590024901668622321064384483571751669].
ec_key_named() ->
- {D2_pub, D2_priv} = crypto:generate_key(ecdh, sect113r2),
- {[D2_priv, sect113r2], [D2_pub, sect113r2]}.
+ Curve = secp112r2,
+ {D2_pub, D2_priv} = crypto:generate_key(ecdh, Curve),
+ {[D2_priv, Curve], [D2_pub, Curve]}.
ec_msg() ->
<<99,234,6,64,190,237,201,99,80,248,58,40,70,45,149,218,5,246,242,63>>.
diff --git a/lib/crypto/test/old_crypto_SUITE.erl b/lib/crypto/test/old_crypto_SUITE.erl
index 040edbf092..80306927c5 100644
--- a/lib/crypto/test/old_crypto_SUITE.erl
+++ b/lib/crypto/test/old_crypto_SUITE.erl
@@ -1887,9 +1887,9 @@ ec(Config) when is_list(Config) ->
ec_do() ->
%% test for a name curve
- {D2_pub, D2_priv} = crypto:generate_key(ecdh, sect113r2),
- PrivECDH = [D2_priv, sect113r2],
- PubECDH = [D2_pub, sect113r2],
+ {D2_pub, D2_priv} = crypto:generate_key(ecdh, secp112r2),
+ PrivECDH = [D2_priv, secp112r2],
+ PubECDH = [D2_pub, secp112r2],
%%TODO: find a published test case for a EC key
%% test for a full specified curve and public key,
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/debugger/test/map_SUITE.erl b/lib/debugger/test/map_SUITE.erl
index 12fdd184b8..74847e161f 100644
--- a/lib/debugger/test/map_SUITE.erl
+++ b/lib/debugger/test/map_SUITE.erl
@@ -1308,7 +1308,7 @@ t_guard_receive(Config) when is_list(Config) ->
done = call(Pid, done),
ok.
--define(t_guard_receive_large_procs, 150).
+-define(t_guard_receive_large_procs, 50).
t_guard_receive_large(Config) when is_list(Config) ->
M = lists:foldl(fun(_,#{procs := Ps } = M) ->
@@ -1326,7 +1326,7 @@ guard_receive_large_loop(M) ->
receive
#{pid := Pid, msg := hello} ->
case M of
- #{done := Count, procs := #{Pid := 150}} ->
+ #{done := Count, procs := #{Pid := 15}} ->
Pid ! {self(), done},
guard_receive_large_loop(M#{done := Count + 1});
#{procs := #{Pid := Count} = Ps} ->
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/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/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/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/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_parse.erl b/lib/kernel/src/inet_parse.erl
index a88c94a453..a694642b19 100644
--- a/lib/kernel/src/inet_parse.erl
+++ b/lib/kernel/src/inet_parse.erl
@@ -675,28 +675,22 @@ ipv6_addr_done(Ar, Br, N) ->
ipv6_addr_done(Ar) ->
list_to_tuple(lists:reverse(Ar)).
-%% Collect Hex digits
-hex(Cs) -> hex(Cs, []).
-%%
-hex([C|Cs], R) when C >= $0, C =< $9 ->
- hex(Cs, [C|R]);
-hex([C|Cs], R) when C >= $a, C =< $f ->
- hex(Cs, [C|R]);
-hex([C|Cs], R) when C >= $A, C =< $F ->
- hex(Cs, [C|R]);
-hex(Cs, [_|_]=R) when is_list(Cs) ->
+%% Collect 1-4 Hex digits
+hex(Cs) -> hex(Cs, [], 4).
+%%
+hex([C|Cs], R, N) when C >= $0, C =< $9, N > 0 ->
+ hex(Cs, [C|R], N-1);
+hex([C|Cs], R, N) when C >= $a, C =< $f, N > 0 ->
+ hex(Cs, [C|R], N-1);
+hex([C|Cs], R, N) when C >= $A, C =< $F, N > 0 ->
+ hex(Cs, [C|R], N-1);
+hex(Cs, [_|_]=R, _) when is_list(Cs) ->
{lists:reverse(R),Cs};
-hex(_, _) ->
+hex(_, _, _) ->
erlang:error(badarg).
%% Hex string to integer
-hex_to_int(Cs0) ->
- case strip0(Cs0) of
- Cs when length(Cs) =< 4 ->
- erlang:list_to_integer("0"++Cs, 16);
- _ ->
- erlang:error(badarg)
- end.
+hex_to_int(Cs) -> erlang:list_to_integer(Cs, 16).
%% Dup onto head of existing list
dup(0, _, L) ->
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/inet_SUITE.erl b/lib/kernel/test/inet_SUITE.erl
index 44a32fc1ec..c77de9316f 100644
--- a/lib/kernel/test/inet_SUITE.erl
+++ b/lib/kernel/test/inet_SUITE.erl
@@ -569,8 +569,11 @@ parse_address(Config) when is_list(Config) ->
"::-1",
"::g",
"f:f11::10100:2",
+ "f:f11::01100:2",
"::17000",
+ "::01700",
"10000::",
+ "01000::",
"::8:7:6:5:4:3:2:1",
"8:7:6:5:4:3:2:1::",
"8:7:6:5:4::3:2:1",
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/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/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/ssh.xml b/lib/ssh/doc/src/ssh.xml
index df13442fc6..cf58806aa8 100644
--- a/lib/ssh/doc/src/ssh.xml
+++ b/lib/ssh/doc/src/ssh.xml
@@ -35,13 +35,15 @@
<section>
<title>SSH</title>
-
+ <marker id="supported"/>
<list type="bulleted">
<item>For application dependencies see <seealso marker="SSH_app"> ssh(6)</seealso> </item>
<item>Supported SSH version is 2.0.</item>
+ <item>Supported public key algorithms: ssh-rsa and ssh-dss.</item>
<item>Supported MAC algorithms: hmac-sha2-256 and hmac-sha1.</item>
<item>Supported encryption algorithms: aes128-ctr, aes128-cb and 3des-cbc.</item>
<item>Supported key exchange algorithms: diffie-hellman-group1-sha1.</item>
+ <item>Supported compression algorithms: none, zlib, [email protected],</item>
<item>Supports unicode filenames if the emulator and the underlaying OS support it.
See section DESCRIPTION in the
<seealso marker="kernel:file">file</seealso> manual page in <c>kernel</c>
@@ -79,6 +81,18 @@
<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>algs_list() =</c></tag>
+ <item><p><c>list( alg_entry() )</c></p></item>
+
+ <tag><c>alg_entry() =</c></tag>
+ <item><p><c>{kex, simple_algs()} | {public_key, simple_algs()} | {cipher, double_algs()} | {mac, double_algs()} | {compression, double_algs()}</c></p></item>
+
+ <tag><c>simple_algs() =</c></tag>
+ <item><p><c>list( atom() )</c></p></item>
+
+ <tag><c>double_algs() =</c></tag>
+ <item><p><c>[{client2serverlist,simple_algs()},{server2client,simple_algs()}] | simple_algs()</c></p></item>
</taglist>
</section>
@@ -160,19 +174,58 @@
and <c>password</c>. However, those optins are not always desirable
to use from a security point of view.</p>
</item>
+
<tag><c><![CDATA[{public_key_alg, 'ssh-rsa' | 'ssh-dss'}]]></c></tag>
<item>
+ <note>
+ <p>This option is kept for compatibility. It is ignored if the <c>preferred_algorithms</c>
+ option is used. The equivalence of <c>{public_key_alg,'ssh-dss'}</c> is
+ <c>{preferred_algorithms, [{public_key,['ssh-dss','ssh-rsa']}]}</c>.</p>
+ </note>
<p>Sets the preferred public key algorithm to use for user
authentication. If the preferred algorithm fails,
the other algorithm is tried. The default is
to try <c><![CDATA['ssh-rsa']]></c> first.</p>
</item>
+
<tag><c><![CDATA[{pref_public_key_algs, list()}]]></c></tag>
<item>
+ <note>
+ <p>This option is kept for compatibility. It is ignored if the <c>preferred_algorithms</c>
+ option is used. The equivalence of <c>{pref_public_key_algs,['ssh-dss']}</c> is
+ <c>{preferred_algorithms, [{public_key,['ssh-dss']}]}</c>.</p>
+ </note>
<p>List of public key algorithms to try to use.
<c>'ssh-rsa'</c> and <c>'ssh-dss'</c> are available.
Overrides <c><![CDATA[{public_key_alg, 'ssh-rsa' | 'ssh-dss'}]]></c></p>
</item>
+
+ <tag><c><![CDATA[{preferred_algorithms, algs_list()}]]></c></tag>
+ <item>
+ <p>List of algorithms to use in the algorithm negotiation. The default <c>algs_list()</c> can
+ be obtained from <seealso marker="#default_algorithms/0">default_algorithms/0</seealso>.
+ </p>
+ <p>Here is an example of this option:</p>
+ <code>
+{preferred_algorithms,
+ [{public_key,['ssh-rsa','ssh-dss']},
+ {cipher,[{client2server,['aes128-ctr']},
+ {server2client,['aes128-cbc','3des-cbc']}]},
+ {mac,['hmac-sha2-256','hmac-sha1']},
+ {compression,[none,zlib]}
+}
+</code>
+ <p>The example specifies different algorithms in the two directions (client2server and server2client), for cipher but specifies the same
+algorithms for mac and compression in both directions. The kex (key exchange) and public key algorithms are set to their default values,
+kex is implicit but public_key is set explicitly.</p>
+
+ <warning>
+ <p>Changing the values can make a connection less secure. Do not change unless you
+ know exactly what you are doing. If you do not understand the values then you
+ are not supposed to change them.</p>
+ </warning>
+ </item>
+
<tag><c><![CDATA[{connect_timeout, timeout()}]]></c></tag>
<item>
<p>Sets a time-out on the transport layer
@@ -341,6 +394,33 @@
user. From a security perspective this option makes
the server very vulnerable.</p>
</item>
+
+ <tag><c><![CDATA[{preferred_algorithms, algs_list()}]]></c></tag>
+ <item>
+ <p>List of algorithms to use in the algorithm negotiation. The default <c>algs_list()</c> can
+ be obtained from <seealso marker="#default_algorithms/0">default_algorithms/0</seealso>.
+ </p>
+ <p>Here is an example of this option:</p>
+ <code>
+{preferred_algorithms,
+ [{public_key,['ssh-rsa','ssh-dss']},
+ {cipher,[{client2server,['aes128-ctr']},
+ {server2client,['aes128-cbc','3des-cbc']}]},
+ {mac,['hmac-sha2-256','hmac-sha1']},
+ {compression,[none,zlib]}
+}
+</code>
+ <p>The example specifies different algorithms in the two directions (client2server and server2client), for cipher but specifies the same
+algorithms for mac and compression in both directions. The kex (key exchange) and public key algorithms are set to their default values,
+kex is implicit but public_key is set explicitly.</p>
+
+ <warning>
+ <p>Changing the values can make a connection less secure. Do not change unless you
+ know exactly what you are doing. If you do not understand the values then you
+ are not supposed to change them.</p>
+ </warning>
+ </item>
+
<tag><c><![CDATA[{pwdfun, fun(User::string(), password::string()) -> boolean()}]]></c></tag>
<item>
<p>Provides a function for password validation. This function is called
@@ -445,6 +525,26 @@
</desc>
</func>
+ <func>
+ <name>default_algorithms() -> algs_list()</name>
+ <fsummary>Get a list declaring the supported algorithms</fsummary>
+ <desc>
+ <p>Returns a key-value list, where the keys are the different types of algorithms and the values are the
+ algorithms themselves. An example:</p>
+ <code>
+20> ssh:default_algorithms().
+[{kex,['diffie-hellman-group1-sha1']},
+ {public_key,['ssh-rsa','ssh-dss']},
+ {cipher,[{client2server,['aes128-ctr','aes128-cbc','3des-cbc']},
+ {server2client,['aes128-ctr','aes128-cbc','3des-cbc']}]},
+ {mac,[{client2server,['hmac-sha2-256','hmac-sha1']},
+ {server2client,['hmac-sha2-256','hmac-sha1']}]},
+ {compression,[{client2server,[none,zlib]},
+ {server2client,[none,zlib]}]}]
+21>
+</code>
+ </desc>
+ </func>
<func>
<name>shell(Host) -> </name>
diff --git a/lib/ssh/src/ssh.erl b/lib/ssh/src/ssh.erl
index 71e7d77475..57f7ae8b5e 100644
--- a/lib/ssh/src/ssh.erl
+++ b/lib/ssh/src/ssh.erl
@@ -28,6 +28,7 @@
-export([start/0, start/1, stop/0, connect/3, connect/4, close/1, connection_info/2,
channel_info/3,
daemon/1, daemon/2, daemon/3,
+ default_algorithms/0,
stop_listener/1, stop_listener/2, stop_daemon/1, stop_daemon/2,
shell/1, shell/2, shell/3]).
@@ -208,6 +209,11 @@ shell(Host, Port, Options) ->
end.
%%--------------------------------------------------------------------
+%%--------------------------------------------------------------------
+default_algorithms() ->
+ ssh_transport:default_algorithms().
+
+%%--------------------------------------------------------------------
%%% Internal functions
%%--------------------------------------------------------------------
fix_idle_time(SshOptions) ->
@@ -259,7 +265,7 @@ do_start_daemon(Host, Port, Options, SocketOptions) ->
end.
handle_options(Opts) ->
- try handle_option(proplists:unfold(Opts), [], []) of
+ try handle_option(algs_compatibility(proplists:unfold(Opts)), [], []) of
{Inet, Ssh} ->
{handle_ip(Inet), Ssh}
catch
@@ -267,6 +273,35 @@ handle_options(Opts) ->
Error
end.
+
+algs_compatibility(Os) ->
+ %% Take care of old options 'public_key_alg' and 'pref_public_key_algs'
+ comp_pk(proplists:get_value(preferred_algorithms,Os),
+ proplists:get_value(pref_public_key_algs,Os),
+ proplists:get_value(public_key_alg, Os),
+ [{K,V} || {K,V} <- Os,
+ K =/= public_key_alg,
+ K =/= pref_public_key_algs]
+ ).
+
+comp_pk(undefined, undefined, undefined, Os) -> Os;
+comp_pk( PrefAlgs, _, _, Os) when PrefAlgs =/= undefined -> Os;
+
+comp_pk(undefined, undefined, ssh_dsa, Os) -> comp_pk(undefined, undefined, 'ssh-dss', Os);
+comp_pk(undefined, undefined, ssh_rsa, Os) -> comp_pk(undefined, undefined, 'ssh-rsa', Os);
+comp_pk(undefined, undefined, PK, Os) ->
+ PKs = [PK | ssh_transport:supported_algorithms(public_key)--[PK]],
+ [{preferred_algorithms, [{public_key,PKs}] } | Os];
+
+comp_pk(undefined, PrefPKs, _, Os) when PrefPKs =/= undefined ->
+ PKs = [case PK of
+ ssh_dsa -> 'ssh-dss';
+ ssh_rsa -> 'ssh-rsa';
+ _ -> PK
+ end || PK <- PrefPKs],
+ [{preferred_algorithms, [{public_key,PKs}]} | Os].
+
+
handle_option([], SocketOptions, SshOptions) ->
{SocketOptions, SshOptions};
handle_option([{system_dir, _} = Opt | Rest], SocketOptions, SshOptions) ->
@@ -279,8 +314,6 @@ handle_option([{silently_accept_hosts, _} = Opt | Rest], SocketOptions, SshOptio
handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]);
handle_option([{user_interaction, _} = Opt | Rest], SocketOptions, SshOptions) ->
handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]);
-handle_option([{public_key_alg, _} = Opt | Rest], SocketOptions, SshOptions) ->
- handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]);
handle_option([{connect_timeout, _} = Opt | Rest], SocketOptions, SshOptions) ->
handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]);
handle_option([{user, _} = Opt | Rest], SocketOptions, SshOptions) ->
@@ -297,10 +330,6 @@ handle_option([{pwdfun, _} = Opt | Rest], SocketOptions, SshOptions) ->
handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]);
handle_option([{key_cb, _} = Opt | Rest], SocketOptions, SshOptions) ->
handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]);
-handle_option([{role, _} = Opt | Rest], SocketOptions, SshOptions) ->
- handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]);
-handle_option([{compression, _} = Opt | Rest], SocketOptions, SshOptions) ->
- handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]);
%%Backwards compatibility
handle_option([{allow_user_interaction, Value} | Rest], SocketOptions, SshOptions) ->
handle_option(Rest, SocketOptions, [handle_ssh_option({user_interaction, Value}) | SshOptions]);
@@ -331,7 +360,7 @@ handle_option([{exec, _} = Opt | Rest], SocketOptions, SshOptions) ->
handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]);
handle_option([{auth_methods, _} = Opt | Rest], SocketOptions, SshOptions) ->
handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]);
-handle_option([{pref_public_key_algs, _} = Opt | Rest], SocketOptions, SshOptions) ->
+handle_option([{preferred_algorithms,_} = Opt | Rest], SocketOptions, SshOptions) ->
handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]);
handle_option([{quiet_mode, _} = Opt|Rest], SocketOptions, SshOptions) ->
handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]);
@@ -367,19 +396,8 @@ handle_ssh_option({silently_accept_hosts, Value} = Opt) when is_boolean(Value) -
Opt;
handle_ssh_option({user_interaction, Value} = Opt) when is_boolean(Value) ->
Opt;
-handle_ssh_option({public_key_alg, ssh_dsa}) ->
- {public_key_alg, 'ssh-dss'};
-handle_ssh_option({public_key_alg, ssh_rsa}) ->
- {public_key_alg, 'ssh-rsa'};
-handle_ssh_option({public_key_alg, Value} = Opt) when Value == 'ssh-rsa'; Value == 'ssh-dss' ->
- Opt;
-handle_ssh_option({pref_public_key_algs, Value} = Opt) when is_list(Value), length(Value) >= 1 ->
- case handle_pref_algs(Value, []) of
- {true, NewOpts} ->
- NewOpts;
- _ ->
- throw({error, {eoptions, Opt}})
- end;
+handle_ssh_option({preferred_algorithms,[_|_]} = Opt) ->
+ handle_pref_algs(Opt);
handle_ssh_option({connect_timeout, Value} = Opt) when is_integer(Value); Value == infinity ->
Opt;
handle_ssh_option({max_sessions, Value} = Opt) when is_integer(Value), Value>0 ->
@@ -465,23 +483,83 @@ handle_inet_option({reuseaddr, _} = Opt) ->
%% Option verified by inet
handle_inet_option(Opt) ->
Opt.
+
+
%% Check preferred algs
-handle_pref_algs([], Acc) ->
- {true, lists:reverse(Acc)};
-handle_pref_algs([H|T], Acc) ->
- case H of
- ssh_dsa ->
- handle_pref_algs(T, ['ssh-dss'| Acc]);
- ssh_rsa ->
- handle_pref_algs(T, ['ssh-rsa'| Acc]);
- 'ssh-dss' ->
- handle_pref_algs(T, ['ssh-dss'| Acc]);
- 'ssh-rsa' ->
- handle_pref_algs(T, ['ssh-rsa'| Acc]);
- _ ->
- false
+
+handle_pref_algs({preferred_algorithms,Algs}) ->
+ try alg_duplicates(Algs, [], []) of
+ [] ->
+ {preferred_algorithms,
+ [try ssh_transport:supported_algorithms(Key)
+ of
+ DefAlgs -> handle_pref_alg(Key,Vals,DefAlgs)
+ catch
+ _:_ -> throw({error, {{eoptions, {preferred_algorithms,Key}},
+ "Bad preferred_algorithms key"}})
+ end || {Key,Vals} <- Algs]
+ };
+
+ Dups ->
+ throw({error, {{eoptions, {preferred_algorithms,Dups}}, "Duplicates found"}})
+ catch
+ _:_ ->
+ throw({error, {{eoptions, preferred_algorithms}, "Malformed"}})
end.
+alg_duplicates([{K,V}|KVs], Ks, Dups0) ->
+ Dups =
+ case lists:member(K,Ks) of
+ true ->
+ [K|Dups0];
+ false ->
+ Dups0
+ end,
+ case V--lists:usort(V) of
+ [] ->
+ alg_duplicates(KVs, [K|Ks], Dups);
+ Ds ->
+ alg_duplicates(KVs, [K|Ks], Dups++Ds)
+ end;
+alg_duplicates([], _Ks, Dups) ->
+ Dups.
+
+handle_pref_alg(Key,
+ Vs=[{client2server,C2Ss=[_|_]},{server2client,S2Cs=[_|_]}],
+ [{client2server,Sup_C2Ss},{server2client,Sup_S2Cs}]
+ ) ->
+ chk_alg_vs(Key, C2Ss, Sup_C2Ss),
+ chk_alg_vs(Key, S2Cs, Sup_S2Cs),
+ {Key, Vs};
+
+handle_pref_alg(Key,
+ Vs=[{server2client,[_|_]},{client2server,[_|_]}],
+ Sup=[{client2server,_},{server2client,_}]
+ ) ->
+ handle_pref_alg(Key, lists:reverse(Vs), Sup);
+
+handle_pref_alg(Key,
+ Vs=[V|_],
+ Sup=[{client2server,_},{server2client,_}]
+ ) when is_atom(V) ->
+ handle_pref_alg(Key, [{client2server,Vs},{server2client,Vs}], Sup);
+
+handle_pref_alg(Key,
+ Vs=[V|_],
+ Sup=[S|_]
+ ) when is_atom(V), is_atom(S) ->
+ chk_alg_vs(Key, Vs, Sup),
+ {Key, Vs};
+
+handle_pref_alg(Key, Vs, _) ->
+ throw({error, {{eoptions, {preferred_algorithms,[{Key,Vs}]}}, "Badly formed list"}}).
+
+chk_alg_vs(OptKey, Values, SupportedValues) ->
+ case (Values -- SupportedValues) of
+ [] -> Values;
+ Bad -> throw({error, {{eoptions, {OptKey,Bad}}, "Unsupported value(s) found"}})
+ end.
+
handle_ip(Inet) -> %% Default to ipv4
case lists:member(inet, Inet) of
true ->
diff --git a/lib/ssh/src/ssh_auth.erl b/lib/ssh/src/ssh_auth.erl
index 45c4d52d7e..197808754c 100644
--- a/lib/ssh/src/ssh_auth.erl
+++ b/lib/ssh/src/ssh_auth.erl
@@ -30,7 +30,8 @@
-export([publickey_msg/1, password_msg/1, keyboard_interactive_msg/1,
service_request_msg/1, init_userauth_request_msg/1,
userauth_request_msg/1, handle_userauth_request/3,
- handle_userauth_info_request/3, handle_userauth_info_response/2
+ handle_userauth_info_request/3, handle_userauth_info_response/2,
+ default_public_key_algorithms/0
]).
%%--------------------------------------------------------------------
@@ -115,33 +116,16 @@ init_userauth_request_msg(#ssh{opts = Opts} = Ssh) ->
service = "ssh-connection",
method = "none",
data = <<>>},
- case proplists:get_value(pref_public_key_algs, Opts, false) of
- false ->
- FirstAlg = proplists:get_value(public_key_alg, Opts, ?PREFERRED_PK_ALG),
- SecondAlg = other_alg(FirstAlg),
- Prefs = method_preference(FirstAlg, SecondAlg),
- ssh_transport:ssh_packet(Msg, Ssh#ssh{user = User,
- userauth_preference = Prefs,
- userauth_methods = none,
- service = "ssh-connection"});
- Algs ->
- FirstAlg = lists:nth(1, Algs),
- case length(Algs) =:= 2 of
- true ->
- SecondAlg = other_alg(FirstAlg),
- Prefs = method_preference(FirstAlg, SecondAlg),
- ssh_transport:ssh_packet(Msg, Ssh#ssh{user = User,
- userauth_preference = Prefs,
- userauth_methods = none,
- service = "ssh-connection"});
- _ ->
- Prefs = method_preference(FirstAlg),
- ssh_transport:ssh_packet(Msg, Ssh#ssh{user = User,
- userauth_preference = Prefs,
- userauth_methods = none,
- service = "ssh-connection"})
- end
- end;
+
+
+ Algs = proplists:get_value(public_key,
+ proplists:get_value(preferred_algorithms, Opts, []),
+ default_public_key_algorithms()),
+ Prefs = method_preference(Algs),
+ ssh_transport:ssh_packet(Msg, Ssh#ssh{user = User,
+ userauth_preference = Prefs,
+ userauth_methods = none,
+ service = "ssh-connection"});
{error, no_user} ->
ErrStr = "Could not determine the users name",
throw(#ssh_msg_disconnect{code = ?SSH_DISCONNECT_ILLEGAL_USER_NAME,
@@ -287,20 +271,20 @@ handle_userauth_info_response(#ssh_msg_userauth_info_response{},
"keyboard-interactive",
language = "en"}).
+
+default_public_key_algorithms() -> ?PREFERRED_PK_ALGS.
+
%%--------------------------------------------------------------------
%%% Internal functions
%%--------------------------------------------------------------------
-method_preference(Alg1, Alg2) ->
- [{"publickey", ?MODULE, publickey_msg, [Alg1]},
- {"publickey", ?MODULE, publickey_msg,[Alg2]},
- {"password", ?MODULE, password_msg, []},
- {"keyboard-interactive", ?MODULE, keyboard_interactive_msg, []}
- ].
-method_preference(Alg1) ->
- [{"publickey", ?MODULE, publickey_msg, [Alg1]},
- {"password", ?MODULE, password_msg, []},
- {"keyboard-interactive", ?MODULE, keyboard_interactive_msg, []}
- ].
+method_preference(Algs) ->
+ lists:foldr(fun(A, Acc) ->
+ [{"publickey", ?MODULE, publickey_msg, [A]} | Acc]
+ end,
+ [{"password", ?MODULE, password_msg, []},
+ {"keyboard-interactive", ?MODULE, keyboard_interactive_msg, []}
+ ],
+ Algs).
user_name(Opts) ->
Env = case os:type() of
@@ -418,10 +402,6 @@ keyboard_interact_fun(KbdInteractFun, Name, Instr, PromptInfos, NumPrompts) ->
language = "en"}})
end.
-other_alg('ssh-rsa') ->
- 'ssh-dss';
-other_alg('ssh-dss') ->
- 'ssh-rsa'.
decode_public_key_v2(<<?UINT32(Len0), _:Len0/binary,
?UINT32(Len1), BinE:Len1/binary,
?UINT32(Len2), BinN:Len2/binary>>
diff --git a/lib/ssh/src/ssh_auth.hrl b/lib/ssh/src/ssh_auth.hrl
index 6cd8e6bf14..764c9f4246 100644
--- a/lib/ssh/src/ssh_auth.hrl
+++ b/lib/ssh/src/ssh_auth.hrl
@@ -23,7 +23,7 @@
-define(SUPPORTED_AUTH_METHODS, "publickey,keyboard-interactive,password").
--define(PREFERRED_PK_ALG, 'ssh-rsa').
+-define(PREFERRED_PK_ALGS, ['ssh-rsa','ssh-dss']).
-define(SSH_MSG_USERAUTH_REQUEST, 50).
-define(SSH_MSG_USERAUTH_FAILURE, 51).
diff --git a/lib/ssh/src/ssh_connection_handler.erl b/lib/ssh/src/ssh_connection_handler.erl
index 2c7f132916..ca63d2194f 100644
--- a/lib/ssh/src/ssh_connection_handler.erl
+++ b/lib/ssh/src/ssh_connection_handler.erl
@@ -33,7 +33,7 @@
-include("ssh_transport.hrl").
-include("ssh_auth.hrl").
-include("ssh_connect.hrl").
-
+-compile(export_all).
-export([start_link/3]).
%% Internal application API
@@ -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{} |
@@ -592,33 +598,6 @@ handle_event(#ssh_msg_debug{always_display = Display, message = DbgMsg, language
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()} |
@@ -1141,54 +1156,38 @@ init_ssh(server = Role, Vsn, Version, Options, Socket) ->
supported_host_keys(client, _, Options) ->
try
- case extract_algs(proplists:get_value(pref_public_key_algs, Options, false), []) of
- false ->
- ["ssh-rsa", "ssh-dss"];
- Algs ->
- Algs
+ case proplists:get_value(public_key,
+ proplists:get_value(preferred_algorithms,Options,[])
+ ) of
+ undefined ->
+ ssh_auth:default_public_key_algorithms();
+ L ->
+ L -- (L--ssh_auth:default_public_key_algorithms())
end
+ of
+ [] ->
+ {stop, {shutdown, "No public key algs"}};
+ Algs ->
+ [atom_to_list(A) || A<-Algs]
catch
exit:Reason ->
{stop, {shutdown, Reason}}
end;
supported_host_keys(server, KeyCb, Options) ->
- lists:foldl(fun(Type, Acc) ->
- case available_host_key(KeyCb, Type, Options) of
- {error, _} ->
- Acc;
- Alg ->
- [Alg | Acc]
- end
- end, [],
- %% Prefered alg last so no need to reverse
- ["ssh-dss", "ssh-rsa"]).
-extract_algs(false, _) ->
- false;
-extract_algs([],[]) ->
- false;
-extract_algs([], NewList) ->
- lists:reverse(NewList);
-extract_algs([H|T], NewList) ->
- case H of
- 'ssh-dss' ->
- extract_algs(T, ["ssh-dss"|NewList]);
- 'ssh-rsa' ->
- extract_algs(T, ["ssh-rsa"|NewList])
- end.
-available_host_key(KeyCb, "ssh-dss"= Alg, Opts) ->
- case KeyCb:host_key('ssh-dss', Opts) of
- {ok, _} ->
- Alg;
- Other ->
- Other
- end;
-available_host_key(KeyCb, "ssh-rsa" = Alg, Opts) ->
- case KeyCb:host_key('ssh-rsa', Opts) of
- {ok, _} ->
- Alg;
- Other ->
- Other
- end.
+ Algs=
+ [atom_to_list(A) || A <- proplists:get_value(public_key,
+ proplists:get_value(preferred_algorithms,Options,[]),
+ ssh_auth:default_public_key_algorithms()
+ ),
+ available_host_key(KeyCb, A, Options)
+ ],
+ Algs.
+
+
+%% Alg :: atom()
+available_host_key(KeyCb, Alg, Opts) ->
+ element(1, catch KeyCb:host_key(Alg, Opts)) == ok.
+
send_msg(Msg, #state{socket = Socket, transport_cb = Transport}) ->
Transport:send(Socket, Msg).
@@ -1282,8 +1281,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 +1464,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 +1661,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/src/ssh_transport.erl b/lib/ssh/src/ssh_transport.erl
index d6414bab6c..7162d18b19 100644
--- a/lib/ssh/src/ssh_transport.erl
+++ b/lib/ssh/src/ssh_transport.erl
@@ -31,6 +31,8 @@
-export([versions/2, hello_version_msg/1]).
-export([next_seqnum/1, decrypt_first_block/2, decrypt_blocks/3,
+ supported_algorithms/0, supported_algorithms/1,
+ default_algorithms/0, default_algorithms/1,
is_valid_mac/3,
handle_hello_version/1,
key_exchange_init_msg/1,
@@ -42,6 +44,68 @@
unpack/3, decompress/2, ssh_packet/2, pack/2, msg_data/1,
sign/3, verify/4]).
+%%%----------------------------------------------------------------------------
+%%%
+%%% There is a difference between supported and default algorithms. The
+%%% SUPPORTED algorithms can be handled (maybe untested...). The DEFAULT ones
+%%% are announced in ssh_msg_kexinit and in ssh:default_algorithms/0 to the
+%%% user.
+%%%
+%%% A supported algorithm can be requested in the option 'preferred_algorithms',
+%%% but may give unexpected results because of being promoted to default.
+%%%
+%%% This makes it possible to add experimental algorithms (in supported_algorithms)
+%%% and test them without letting the default users know about them.
+%%%
+
+default_algorithms() -> [{K,default_algorithms(K)} || K <- algo_classes()].
+
+algo_classes() -> [kex, public_key, cipher, mac, compression].
+
+default_algorithms(compression) ->
+ %% Do not announce '[email protected]' because there seem to be problems
+ supported_algorithms(compression, same(['[email protected]']));
+default_algorithms(Alg) ->
+ supported_algorithms(Alg).
+
+
+supported_algorithms() -> [{K,supported_algorithms(K)} || K <- algo_classes()].
+
+supported_algorithms(kex) ->
+ ['diffie-hellman-group1-sha1'];
+supported_algorithms(public_key) ->
+ ssh_auth:default_public_key_algorithms();
+supported_algorithms(cipher) ->
+ Supports = crypto:supports(),
+ CipherAlgos = [{aes_ctr, 'aes128-ctr'}, {aes_cbc128, 'aes128-cbc'}, {des3_cbc, '3des-cbc'}],
+ Algs = [SshAlgo ||
+ {CryptoAlgo, SshAlgo} <- CipherAlgos,
+ lists:member(CryptoAlgo, proplists:get_value(ciphers, Supports, []))],
+ same(Algs);
+supported_algorithms(mac) ->
+ Supports = crypto:supports(),
+ HashAlgos = [{sha256, 'hmac-sha2-256'}, {sha, 'hmac-sha1'}],
+ Algs = [SshAlgo ||
+ {CryptoAlgo, SshAlgo} <- HashAlgos,
+ lists:member(CryptoAlgo, proplists:get_value(hashs, Supports, []))],
+ same(Algs);
+supported_algorithms(compression) ->
+ same(['none','zlib','[email protected]']).
+
+
+supported_algorithms(Key, [{client2server,BL1},{server2client,BL2}]) ->
+ [{client2server,As1},{server2client,As2}] = supported_algorithms(Key),
+ [{client2server,As1--BL1},{server2client,As2--BL2}];
+supported_algorithms(Key, BlackList) ->
+ supported_algorithms(Key) -- BlackList.
+
+
+
+
+same(Algs) -> [{client2server,Algs}, {server2client,Algs}].
+
+
+%%%----------------------------------------------------------------------------
versions(client, Options)->
Vsn = proplists:get_value(vsn, Options, ?DEFAULT_CLIENT_VERSION),
{Vsn, format_version(Vsn, software_version(Options))};
@@ -128,62 +192,45 @@ key_exchange_init_msg(Ssh0) ->
kex_init(#ssh{role = Role, opts = Opts, available_host_keys = HostKeyAlgs}) ->
Random = ssh_bits:random(16),
- Compression = case proplists:get_value(compression, Opts, none) of
- openssh_zlib -> ["[email protected]", "none"];
- zlib -> ["zlib", "none"];
- none -> ["none", "zlib"]
- end,
- kexinit_messsage(Role, Random, Compression, HostKeyAlgs).
+ PrefAlgs =
+ case proplists:get_value(preferred_algorithms,Opts) of
+ undefined ->
+ default_algorithms();
+ Algs0 ->
+ Algs0
+ end,
+ kexinit_message(Role, Random, PrefAlgs, HostKeyAlgs).
key_init(client, Ssh, Value) ->
Ssh#ssh{c_keyinit = Value};
key_init(server, Ssh, Value) ->
Ssh#ssh{s_keyinit = Value}.
-available_ssh_algos() ->
- Supports = crypto:supports(),
- CipherAlgos = [{aes_ctr, "aes128-ctr"}, {aes_cbc128, "aes128-cbc"}, {des3_cbc, "3des-cbc"}],
- Ciphers = [SshAlgo ||
- {CryptoAlgo, SshAlgo} <- CipherAlgos,
- lists:member(CryptoAlgo, proplists:get_value(ciphers, Supports, []))],
- HashAlgos = [{sha256, "hmac-sha2-256"}, {sha, "hmac-sha1"}],
- Hashs = [SshAlgo ||
- {CryptoAlgo, SshAlgo} <- HashAlgos,
- lists:member(CryptoAlgo, proplists:get_value(hashs, Supports, []))],
- {Ciphers, Hashs}.
-
-kexinit_messsage(client, Random, Compression, HostKeyAlgs) ->
- {CipherAlgs, HashAlgs} = available_ssh_algos(),
- #ssh_msg_kexinit{
- cookie = Random,
- kex_algorithms = ["diffie-hellman-group1-sha1"],
- server_host_key_algorithms = HostKeyAlgs,
- encryption_algorithms_client_to_server = CipherAlgs,
- encryption_algorithms_server_to_client = CipherAlgs,
- mac_algorithms_client_to_server = HashAlgs,
- mac_algorithms_server_to_client = HashAlgs,
- compression_algorithms_client_to_server = Compression,
- compression_algorithms_server_to_client = Compression,
- languages_client_to_server = [],
- languages_server_to_client = []
- };
-kexinit_messsage(server, Random, Compression, HostKeyAlgs) ->
- {CipherAlgs, HashAlgs} = available_ssh_algos(),
+kexinit_message(_Role, Random, Algs, HostKeyAlgs) ->
#ssh_msg_kexinit{
cookie = Random,
- kex_algorithms = ["diffie-hellman-group1-sha1"],
+ kex_algorithms = to_strings( get_algs(kex,Algs) ),
server_host_key_algorithms = HostKeyAlgs,
- encryption_algorithms_client_to_server = CipherAlgs,
- encryption_algorithms_server_to_client = CipherAlgs,
- mac_algorithms_client_to_server = HashAlgs,
- mac_algorithms_server_to_client = HashAlgs,
- compression_algorithms_client_to_server = Compression,
- compression_algorithms_server_to_client = Compression,
+ encryption_algorithms_client_to_server = c2s(cipher,Algs),
+ encryption_algorithms_server_to_client = s2c(cipher,Algs),
+ mac_algorithms_client_to_server = c2s(mac,Algs),
+ mac_algorithms_server_to_client = s2c(mac,Algs),
+ compression_algorithms_client_to_server = c2s(compression,Algs),
+ compression_algorithms_server_to_client = s2c(compression,Algs),
languages_client_to_server = [],
languages_server_to_client = []
}.
+c2s(Key, Algs) -> x2y(client2server, Key, Algs).
+s2c(Key, Algs) -> x2y(server2client, Key, Algs).
+
+x2y(DirectionKey, Key, Algs) -> to_strings(proplists:get_value(DirectionKey, get_algs(Key,Algs))).
+
+get_algs(Key, Algs) -> proplists:get_value(Key, Algs, default_algorithms(Key)).
+
+to_strings(L) -> lists:map(fun erlang:atom_to_list/1, L).
+
new_keys_message(Ssh0) ->
{SshPacket, Ssh} =
ssh_packet(#ssh_msg_newkeys{}, Ssh0),
@@ -448,6 +495,7 @@ select_algorithm(Role, Client, Server) ->
decompress = Decompression,
c_lng = C_Lng,
s_lng = S_Lng},
+%%ct:pal("~p~n Client=~p~n Server=~p~n Alg=~p~n",[Role,Client,Server,Alg]),
{ok, Alg}.
select_encrypt_decrypt(client, Client, Server) ->
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 242c9a3bd9..cff695681e 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,
@@ -54,6 +56,7 @@ all() ->
ssh_daemon_minimal_remote_max_packet_size_option,
ssh_msg_debug_fun_option_client,
ssh_msg_debug_fun_option_server,
+ preferred_algorithms,
id_string_no_opt_client,
id_string_own_string_client,
id_string_random_client,
@@ -69,6 +72,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,
@@ -84,12 +88,12 @@ 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].
%%--------------------------------------------------------------------
init_per_suite(Config) ->
+ catch crypto:stop(),
case catch crypto:start() of
ok ->
Config;
@@ -287,7 +291,7 @@ exec_compressed(Config) when is_list(Config) ->
UserDir = ?config(priv_dir, Config),
{Pid, Host, Port} = ssh_test_lib:daemon([{system_dir, SystemDir},{user_dir, UserDir},
- {compression, zlib},
+ {preferred_algorithms,[{compression, [zlib]}]},
{failfun, fun ssh_test_lib:failfun/2}]),
ConnectionRef =
@@ -333,25 +337,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) ->
@@ -912,6 +1066,57 @@ ssh_daemon_minimal_remote_max_packet_size_option(Config) ->
ssh:stop_daemon(Server).
%%--------------------------------------------------------------------
+%% This test try every algorithm by connecting to an Erlang server
+preferred_algorithms(Config) ->
+ SystemDir = ?config(data_dir, 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),
+
+ {Server, Host, Port} = ssh_test_lib:daemon([{system_dir, SystemDir},
+ {user_dir, UserDir},
+ {user_passwords, [{"vego", "morot"}]},
+ {failfun, fun ssh_test_lib:failfun/2}]),
+ Available = ssh:default_algorithms(),
+ Tests = [[{Tag,[Alg]}] || {Tag, SubAlgs} <- Available,
+ is_atom(hd(SubAlgs)),
+ Alg <- SubAlgs]
+ ++ [[{Tag,[{T1,[A1]},{T2,[A2]}]}] || {Tag, [{T1,As1},{T2,As2}]} <- Available,
+ A1 <- As1,
+ A2 <- As2],
+ ct:log("TESTS: ~p",[Tests]),
+ [connect_exec_channel(Host,Port,PrefAlgs) || PrefAlgs <- Tests],
+ ssh:stop_daemon(Server).
+
+
+connect_exec_channel(_Host, Port, Algs) ->
+ ct:log("Try ~p",[Algs]),
+ ConnectionRef = ssh_test_lib:connect(Port, [{silently_accept_hosts, true},
+ {user_interaction, false},
+ {user, "vego"},
+ {password, "morot"},
+ {preferred_algorithms,Algs}
+ ]),
+ chan_exec(ConnectionRef, "2*21.", <<"42\n">>),
+ ssh:close(ConnectionRef).
+
+chan_exec(ConnectionRef, Cmnd, Expected) ->
+ {ok, ChannelId0} = ssh_connection:session_channel(ConnectionRef, infinity),
+ success = ssh_connection:exec(ConnectionRef, ChannelId0,Cmnd, infinity),
+ Data0 = {ssh_cm, ConnectionRef, {data, ChannelId0, 0, Expected}},
+ case ssh_test_lib:receive_exec_result(Data0) of
+ expected ->
+ ssh_test_lib:receive_exec_end(ConnectionRef, ChannelId0);
+ {unexpected_msg,{ssh_cm, ConnectionRef, {exit_status, ChannelId0, 0}}
+ = ExitStatus0} ->
+ ct:pal("0: Collected data ~p", [ExitStatus0]),
+ ssh_test_lib:receive_exec_result(Data0,
+ ConnectionRef, ChannelId0);
+ Other0 ->
+ ct:fail(Other0)
+ end.
+
+%%--------------------------------------------------------------------
id_string_no_opt_client(Config) ->
{Server, _Host, Port} = fake_daemon(Config),
{error,_} = ssh:connect("localhost", Port, [], 1000),
@@ -1081,12 +1286,15 @@ openssh_zlib_basic_test(Config) ->
{Pid, Host, Port} = ssh_test_lib:daemon([{system_dir, SystemDir},
{user_dir, UserDir},
+ {preferred_algorithms,[{compression, ['[email protected]']}]},
{failfun, fun ssh_test_lib:failfun/2}]),
ConnectionRef =
ssh_test_lib:connect(Host, Port, [{silently_accept_hosts, true},
{user_dir, UserDir},
{user_interaction, false},
- {compression, openssh_zlib}]),
+ {preferred_algorithms,[{compression, ['[email protected]',
+ none]}]}
+ ]),
ok = ssh:close(ConnectionRef),
ssh:stop_daemon(Pid).
@@ -1300,3 +1508,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 db51f65509..f0c337cf2f 100644
--- a/lib/ssh/test/ssh_connection_SUITE.erl
+++ b/lib/ssh/test/ssh_connection_SUITE.erl
@@ -65,6 +65,7 @@ ptty() ->
%%--------------------------------------------------------------------
init_per_suite(Config) ->
+ catch crypto:stop(),
case catch crypto:start() of
ok ->
Config;
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/ssh/test/ssh_sftp_SUITE.erl b/lib/ssh/test/ssh_sftp_SUITE.erl
index cb74a27638..850b1cbf6b 100644
--- a/lib/ssh/test/ssh_sftp_SUITE.erl
+++ b/lib/ssh/test/ssh_sftp_SUITE.erl
@@ -49,6 +49,7 @@ all() ->
init_per_suite(Config) ->
+ catch crypto:stop(),
case (catch crypto:start()) of
ok ->
ssh:start(),
diff --git a/lib/ssh/test/ssh_sftpd_SUITE.erl b/lib/ssh/test/ssh_sftpd_SUITE.erl
index 0ce8eec906..925b02a437 100644
--- a/lib/ssh/test/ssh_sftpd_SUITE.erl
+++ b/lib/ssh/test/ssh_sftpd_SUITE.erl
@@ -68,6 +68,7 @@ groups() ->
%%--------------------------------------------------------------------
init_per_suite(Config) ->
+ catch crypto:stop(),
case (catch crypto:start()) of
ok ->
DataDir = ?config(data_dir, Config),
diff --git a/lib/ssh/test/ssh_sftpd_erlclient_SUITE.erl b/lib/ssh/test/ssh_sftpd_erlclient_SUITE.erl
index cc34cc0793..eac7575486 100644
--- a/lib/ssh/test/ssh_sftpd_erlclient_SUITE.erl
+++ b/lib/ssh/test/ssh_sftpd_erlclient_SUITE.erl
@@ -52,6 +52,7 @@ groups() ->
init_per_suite(Config) ->
catch ssh:stop(),
+ catch crypto:stop(),
case catch crypto:start() of
ok ->
DataDir = ?config(data_dir, Config),
diff --git a/lib/ssh/test/ssh_to_openssh_SUITE.erl b/lib/ssh/test/ssh_to_openssh_SUITE.erl
index a61fd2dd41..277e3a1b08 100644
--- a/lib/ssh/test/ssh_to_openssh_SUITE.erl
+++ b/lib/ssh/test/ssh_to_openssh_SUITE.erl
@@ -60,6 +60,7 @@ groups() ->
].
init_per_suite(Config) ->
+ catch crypto:stop(),
case catch crypto:start() of
ok ->
case gen_tcp:connect("localhost", 22, []) of
@@ -166,9 +167,11 @@ erlang_client_openssh_server_exec_compressed() ->
[{doc, "Test that compression option works"}].
erlang_client_openssh_server_exec_compressed(Config) when is_list(Config) ->
+ CompressAlgs = [zlib, '[email protected]',none],
ConnectionRef = ssh_test_lib:connect(?SSH_DEFAULT_PORT, [{silently_accept_hosts, true},
{user_interaction, false},
- {compression, zlib}]),
+ {preferred_algorithms,
+ [{compression,CompressAlgs}]}]),
{ok, ChannelId} = ssh_connection:session_channel(ConnectionRef, infinity),
success = ssh_connection:exec(ConnectionRef, ChannelId,
"echo testing", infinity),
@@ -326,8 +329,11 @@ erlang_server_openssh_client_exec_compressed(Config) when is_list(Config) ->
PrivDir = ?config(priv_dir, Config),
KnownHosts = filename:join(PrivDir, "known_hosts"),
+%% CompressAlgs = [zlib, '[email protected]'], % Does not work
+ CompressAlgs = [zlib],
{Pid, Host, Port} = ssh_test_lib:daemon([{system_dir, SystemDir},
- {compression, zlib},
+ {preferred_algorithms,
+ [{compression, CompressAlgs}]},
{failfun, fun ssh_test_lib:failfun/2}]),
ct:sleep(500),
diff --git a/lib/ssh/test/ssh_unicode_SUITE.erl b/lib/ssh/test/ssh_unicode_SUITE.erl
index cc916673b3..07d51335c6 100644
--- a/lib/ssh/test/ssh_unicode_SUITE.erl
+++ b/lib/ssh/test/ssh_unicode_SUITE.erl
@@ -55,6 +55,7 @@ all() ->
init_per_suite(Config) ->
+ catch crypto:stop(),
case {file:native_name_encoding(), (catch crypto:start())} of
{utf8, ok} ->
ssh:start(),
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 3495b978b7..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),
@@ -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
index 46cd644e4d..b059ff991b 100644
--- a/lib/ssl/test/ssl_sni_SUITE.erl
+++ b/lib/ssl/test/ssl_sni_SUITE.erl
@@ -1,7 +1,7 @@
%%
%% %CopyrightBegin%
%%
-%% Copyright Ericsson AB 2008-2015. All Rights Reserved.
+%% 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
@@ -16,7 +16,6 @@
%%
%% %CopyrightEnd%
%%
-
%%
-module(ssl_sni_SUITE).
@@ -31,7 +30,12 @@
%%--------------------------------------------------------------------
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].
+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(),
@@ -39,11 +43,11 @@ init_per_suite(Config0) ->
ok ->
ssl:start(),
Result =
- (catch make_certs:all(?config(data_dir, Config0),
- ?config(priv_dir, Config0))),
+ (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 _:_ ->
+ catch _:_ ->
{skip, "Crypto did not start"}
end.
@@ -76,8 +80,6 @@ sni_no_match_fun(Config) ->
%%--------------------------------------------------------------------
%% Internal Functions ------------------------------------------------
%%--------------------------------------------------------------------
-
-
ssl_recv(SSLSocket, Expect) ->
ssl_recv(SSLSocket, "", Expect).
@@ -93,20 +95,21 @@ ssl_recv(SSLSocket, CurrentData, ExpectedData) ->
end;
Other ->
ct:fail({unexpected_message, Other})
- after 4000 ->
+ 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.
+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);
@@ -116,12 +119,15 @@ rdn_to_string({printableString, 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),
+ #'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]),
+ 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}],
@@ -142,11 +148,14 @@ run_sni_fun_handshake(Config, SNIHostname, ExpectedSNIHostname, ExpectedCN) ->
{host, Hostname}, {from, self()},
{mfa, {?MODULE, recv_and_certificate, []}},
{options, ClientOptions}]),
- ssl_test_lib:check_result(Server, ExpectedSNIHostname, Client, ExpectedCN).
-
+ 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]),
+ 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
@@ -165,4 +174,6 @@ run_handshake(Config, SNIHostname, ExpectedSNIHostname, ExpectedCN) ->
{host, Hostname}, {from, self()},
{mfa, {?MODULE, recv_and_certificate, []}},
{options, ClientOptions}]),
- ssl_test_lib:check_result(Server, ExpectedSNIHostname, Client, ExpectedCN).
+ 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 8b98e6f16b..a3bfdf8893 100644
--- a/lib/ssl/test/ssl_test_lib.erl
+++ b/lib/ssl/test/ssl_test_lib.erl
@@ -949,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 0413415e49..aca34cb6e9 100644
--- a/lib/ssl/test/ssl_to_openssl_SUITE.erl
+++ b/lib/ssl/test/ssl_to_openssl_SUITE.erl
@@ -1243,15 +1243,16 @@ run_suites(Ciphers, Version, Config, Type) ->
ct:fail(cipher_suite_failed_see_test_case_log)
end.
-client_read_check([], _NewData) -> ok;
-client_read_check([Hd | T], NewData) ->
- case binary:match(NewData, list_to_binary(Hd)) of
+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, NewData)
+ client_read_check(T, Data)
end.
-client_read_bulk(Port, DataExpected, DataReceived) ->
+client_check_result(Port, DataExpected, DataReceived) ->
receive
{Port, {data, TheData}} ->
Data = list_to_binary(TheData),
@@ -1261,15 +1262,14 @@ client_read_bulk(Port, DataExpected, DataReceived) ->
ok ->
ok;
_ ->
- client_read_bulk(Port, DataExpected, NewData)
- end;
- _ ->
- ct:fail("unexpected_message")
- after 4000 ->
- ct:fail("timeout")
+ client_check_result(Port, DataExpected, NewData)
+ end
+ after 3000 ->
+ ct:fail({"Time out on opensssl Client", {expected, DataExpected},
+ {got, DataReceived}})
end.
-client_read_bulk(Port, DataExpected) ->
- client_read_bulk(Port, DataExpected, <<"">>).
+client_check_result(Port, DataExpected) ->
+ client_check_result(Port, DataExpected, <<"">>).
send_and_hostname(SSLSocket) ->
ssl:send(SSLSocket, "OK"),
@@ -1292,9 +1292,12 @@ erlang_server_openssl_client_sni_test(Config, SNIHostname, ExpectedSNIHostname,
end,
ct:log("Options: ~p", [[ServerOptions, ClientCommand]]),
ClientPort = open_port({spawn, ClientCommand}, [stderr_to_stdout]),
- ssl_test_lib:check_result(Server, ExpectedSNIHostname),
+
+ %% Client check needs to be done befor server check,
+ %% or server check might consume client messages
ExpectedClientOutput = ["OK", "/CN=" ++ ExpectedCN ++ "/"],
- ok = client_read_bulk(ClientPort, ExpectedClientOutput),
+ client_check_result(ClientPort, ExpectedClientOutput),
+ ssl_test_lib:check_result(Server, ExpectedSNIHostname),
ssl_test_lib:close_port(ClientPort),
ssl_test_lib:close(Server),
ok.
@@ -1318,12 +1321,14 @@ erlang_server_openssl_client_sni_test_sni_fun(Config, SNIHostname, ExpectedSNIHo
end,
ct:log("Options: ~p", [[ServerOptions, ClientCommand]]),
ClientPort = open_port({spawn, ClientCommand}, [stderr_to_stdout]),
- ssl_test_lib:check_result(Server, ExpectedSNIHostname),
+
+ %% Client check needs to be done befor server check,
+ %% or server check might consume client messages
ExpectedClientOutput = ["OK", "/CN=" ++ ExpectedCN ++ "/"],
- ok = client_read_bulk(ClientPort, ExpectedClientOutput),
+ client_check_result(ClientPort, ExpectedClientOutput),
+ ssl_test_lib:check_result(Server, ExpectedSNIHostname),
ssl_test_lib:close_port(ClientPort),
- ssl_test_lib:close(Server),
- ok.
+ ssl_test_lib:close(Server).
cipher(CipherSuite, Version, Config, ClientOpts, ServerOpts) ->
@@ -1664,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]),
@@ -1683,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]) ->
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/src/erl_lint.erl b/lib/stdlib/src/erl_lint.erl
index c68ec601bf..ac92004061 100644
--- a/lib/stdlib/src/erl_lint.erl
+++ b/lib/stdlib/src/erl_lint.erl
@@ -127,7 +127,6 @@ value_option(Flag, Default, On, OnVal, Off, OffVal, Opts) ->
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
@@ -610,22 +609,30 @@ pack_warnings(Ws) ->
%% add_warning(ErrorDescriptor, State) -> State'
%% add_warning(Line, Error, State) -> State'
-add_error(E, St) -> St#lint{errors=[{St#lint.file,E}|St#lint.errors]}.
+add_error(E, St) -> add_lint_error(E, St#lint.file, St).
add_error(Anno, E, St) ->
- {File,Location} = loc(Anno),
- add_error({Location,erl_lint,E}, St#lint{file = File}).
+ {File,Location} = loc(Anno, St),
+ add_lint_error({Location,erl_lint,E}, File, St).
-add_warning(W, St) -> St#lint{warnings=[{St#lint.file,W}|St#lint.warnings]}.
+add_lint_error(E, File, St) ->
+ St#lint{errors=[{File,E}|St#lint.errors]}.
+
+add_warning(W, St) -> add_lint_warning(W, St#lint.file, St).
add_warning(FileLine, W, St) ->
- {File,Location} = loc(FileLine),
- add_warning({Location,erl_lint,W}, St#lint{file = File}).
+ {File,Location} = loc(FileLine, St),
+ add_lint_warning({Location,erl_lint,W}, File, St).
+
+add_lint_warning(W, File, St) ->
+ St#lint{warnings=[{File,W}|St#lint.warnings]}.
-loc(Anno) ->
- File = erl_anno:file(Anno),
+loc(Anno, St) ->
Location = erl_anno:location(Anno),
- {File,Location}.
+ case erl_anno:file(Anno) of
+ undefined -> {St#lint.file,Location};
+ File -> {File,Location}
+ end.
%% forms([Form], State) -> State'
@@ -642,8 +649,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
@@ -670,11 +675,21 @@ eval_file_attribute(Forms, St) ->
eval_file_attr([{attribute,_L,file,{File,_Line}}=Form | Forms], _File) ->
[Form | eval_file_attr(Forms, File)];
eval_file_attr([Form0 | Forms], File) ->
- Form = set_file(Form0, File),
+ Form = set_form_file(Form0, File),
[Form | eval_file_attr(Forms, File)];
eval_file_attr([], _File) ->
[].
+%% Sets the file only on the form. This is used on post-traversal.
+%% For the remaining of the AST we rely on #lint.file.
+
+set_form_file({attribute,L,K,V}, File) ->
+ {attribute,erl_anno:set_file(File, L),K,V};
+set_form_file({function,L,N,A,C}, File) ->
+ {function,erl_anno:set_file(File, L),N,A,C};
+set_form_file(Form, _File) ->
+ Form.
+
set_file(T, File) ->
F = fun(Anno) -> erl_anno:set_file(File, Anno) end,
erl_parse:map_anno(F, T).
@@ -799,10 +814,10 @@ disallowed_compile_flags(Forms, St0) ->
%% There are (still) no line numbers in St0#lint.compile.
Errors0 = [ {St0#lint.file,{L,erl_lint,disallowed_nowarn_bif_clash}} ||
{attribute,A,compile,nowarn_bif_clash} <- Forms,
- {_,L} <- [loc(A)] ],
+ {_,L} <- [loc(A, St0)] ],
Errors1 = [ {St0#lint.file,{L,erl_lint,disallowed_nowarn_bif_clash}} ||
{attribute,A,compile,{nowarn_bif_clash, {_,_}}} <- Forms,
- {_,L} <- [loc(A)] ],
+ {_,L} <- [loc(A, St0)] ],
Disabled = (not is_warn_enabled(bif_clash, St0)),
Errors = if
Disabled andalso Errors0 =:= [] ->
@@ -927,7 +942,7 @@ behaviour_conflicting(AllBfs, St) ->
behaviour_add_conflicts(R, St).
behaviour_add_conflicts([{Cb,[{FirstLoc,FirstB}|Cs]}|T], St0) ->
- FirstL = element(2, loc(FirstLoc)),
+ FirstL = element(2, loc(FirstLoc, St0)),
St = behaviour_add_conflict(Cs, Cb, FirstL, FirstB, St0),
behaviour_add_conflicts(T, St);
behaviour_add_conflicts([], St) -> St.
@@ -1145,7 +1160,7 @@ check_unused_records(Forms, St0) ->
end, St0#lint.records, UsedRecords),
Unused = [{Name,FileLine} ||
{Name,{FileLine,_Fields}} <- dict:to_list(URecs),
- element(1, loc(FileLine)) =:= FirstFile],
+ element(1, loc(FileLine, St0)) =:= FirstFile],
foldl(fun ({N,L}, St) ->
add_warning(L, {unused_record, N}, St)
end, St0, Unused);
@@ -1338,14 +1353,15 @@ check_on_load(St) -> St.
-spec call_function(line(), atom(), arity(), lint_state()) -> lint_state().
%% Add to both called and calls.
-call_function(Line, F, A, #lint{usage=Usage0,called=Cd,func=Func}=St) ->
+call_function(Line, F, A, #lint{usage=Usage0,called=Cd,func=Func,file=File}=St) ->
#usage{calls = Cs} = Usage0,
NA = {F,A},
Usage = case Cs of
undefined -> Usage0;
_ -> Usage0#usage{calls=dict:append(Func, NA, Cs)}
end,
- St#lint{called=[{NA,Line}|Cd], usage=Usage}.
+ Anno = erl_anno:set_file(File, Line),
+ St#lint{called=[{NA,Anno}|Cd], usage=Usage}.
%% function(Line, Name, Arity, Clauses, State) -> State.
@@ -2124,7 +2140,7 @@ expr({'receive',Line,Cs,To,ToEs}, Vt, St0) ->
{Cvt,St3} = icrt_clauses(Cs, Vt, St2),
%% Csvts = [vtnew(Tevt, Vt)|Cvt], %This is just NEW variables!
Csvts = [Tevt|Cvt],
- Rvt = icrt_export(Csvts, Vt, {'receive',Line}),
+ Rvt = icrt_export(Csvts, Vt, {'receive',Line}, St3),
{vtmerge([Tvt,Tevt,Rvt]),St3};
expr({'fun',Line,Body}, Vt, St) ->
%%No one can think funs export!
@@ -2985,7 +3001,7 @@ check_unused_types(Forms, #lint{usage=Usage, types=Ts, exp_types=ExpTs}=St) ->
UsedTypes = gb_sets:from_list(L),
FoldFun =
fun(Type, #typeinfo{line = FileLine}, AccSt) ->
- case loc(FileLine) of
+ case loc(FileLine, AccSt) of
{FirstFile, _} ->
case gb_sets:is_member(Type, UsedTypes) of
true -> AccSt;
@@ -3023,7 +3039,7 @@ check_local_opaque_types(St) ->
icrt_clauses(Cs, In, Vt, St0) ->
{Csvt,St1} = icrt_clauses(Cs, Vt, St0),
- UpdVt = icrt_export(Csvt, Vt, In),
+ UpdVt = icrt_export(Csvt, Vt, In, St1),
{UpdVt,St1}.
%% icrt_clauses(Clauses, ImportVarTable, State) ->
@@ -3040,8 +3056,8 @@ icrt_clause({clause,_Line,H,G,B}, Vt0, St0) ->
{Bvt,St3} = exprs(B, vtupdate(Vt2, Vt0), St2),
{vtupdate(Bvt, Vt2),St3}.
-icrt_export(Vts, Vt, {Tag,Attrs}) ->
- {_File,Loc} = loc(Attrs),
+icrt_export(Vts, Vt, {Tag,Attrs}, St) ->
+ {_File,Loc} = loc(Attrs, St),
icrt_export(lists:merge(Vts), Vt, {Tag,Loc}, length(Vts), []).
icrt_export([{V,{{export,_},_,_}}|Vs0], [{V,{{export,_}=S0,_,Ls}}|Vt],
@@ -3398,7 +3414,7 @@ vtupdate(Uvt, Vt0) ->
%% Return all new variables in UpdVarTable as unsafe.
vtunsafe({Tag,FileLine}, Uvt, Vt) ->
- {_File,Line} = loc(FileLine),
+ Line = erl_anno:location(FileLine),
[{V,{{unsafe,{Tag,Line}},U,Ls}} || {V,{_,U,Ls}} <- vtnew(Uvt, Vt)].
%% vtmerge(VarTable, VarTable) -> VarTable.
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/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/binary_module_SUITE.erl b/lib/stdlib/test/binary_module_SUITE.erl
index 5248870744..8d26c77c9b 100644
--- a/lib/stdlib/test/binary_module_SUITE.erl
+++ b/lib/stdlib/test/binary_module_SUITE.erl
@@ -993,43 +993,51 @@ random_parts(X,N) ->
random_ref_comp(doc) ->
["Test pseudorandomly generated cases against reference imlementation"];
random_ref_comp(Config) when is_list(Config) ->
- ?line put(success_counter,0),
- ?line random:seed({1271,769940,559934}),
- ?line do_random_match_comp(5000,{1,40},{30,1000}),
+ put(success_counter,0),
+ random:seed({1271,769940,559934}),
+ Nr = {1,40},
+ Hr = {30,1000},
+ I1 = 1500,
+ I2 = 5,
+ do_random_match_comp(I1,Nr,Hr),
io:format("Number of successes: ~p~n",[get(success_counter)]),
- ?line do_random_match_comp2(5000,{1,40},{30,1000}),
+ do_random_match_comp2(I1,Nr,Hr),
io:format("Number of successes: ~p~n",[get(success_counter)]),
- ?line do_random_match_comp3(5000,{1,40},{30,1000}),
+ do_random_match_comp3(I1,Nr,Hr),
io:format("Number of successes: ~p~n",[get(success_counter)]),
- ?line do_random_match_comp4(5000,{1,40},{30,1000}),
+ do_random_match_comp4(I1,Nr,Hr),
io:format("Number of successes: ~p~n",[get(success_counter)]),
- ?line do_random_matches_comp(5000,{1,40},{30,1000}),
+ do_random_matches_comp(I1,Nr,Hr),
io:format("Number of successes: ~p~n",[get(success_counter)]),
- ?line do_random_matches_comp2(5000,{1,40},{30,1000}),
+ do_random_matches_comp2(I1,Nr,Hr),
io:format("Number of successes: ~p~n",[get(success_counter)]),
- ?line do_random_matches_comp3(5,{1,40},{30,1000}),
- ?line erts_debug:set_internal_state(available_internal_state,true),
- ?line io:format("oldlimit: ~p~n",[ erts_debug:set_internal_state(binary_loop_limit,100)]),
- ?line do_random_match_comp(5000,{1,40},{30,1000}),
- ?line do_random_matches_comp3(5,{1,40},{30,1000}),
- ?line io:format("limit was: ~p~n",[ erts_debug:set_internal_state(binary_loop_limit,default)]),
- ?line erts_debug:set_internal_state(available_internal_state,false),
+ do_random_matches_comp3(I2,Nr,Hr),
+ erts_debug:set_internal_state(available_internal_state,true),
+ io:format("oldlimit: ~p~n",[ erts_debug:set_internal_state(binary_loop_limit,100)]),
+ do_random_match_comp(I1,Nr,Hr),
+ do_random_matches_comp3(I2,Nr,Hr),
+ io:format("limit was: ~p~n",[ erts_debug:set_internal_state(binary_loop_limit,default)]),
+ erts_debug:set_internal_state(available_internal_state,false),
ok.
random_ref_sr_comp(doc) ->
["Test pseudorandomly generated cases against reference imlementation of split and replace"];
random_ref_sr_comp(Config) when is_list(Config) ->
- ?line put(success_counter,0),
- ?line random:seed({1271,769940,559934}),
- ?line do_random_split_comp(5000,{1,40},{30,1000}),
+ put(success_counter,0),
+ random:seed({1271,769940,559934}),
+ Nr = {1,40},
+ Hr = {30,1000},
+ I1 = 1500,
+ do_random_split_comp(I1,Nr,Hr),
io:format("Number of successes: ~p~n",[get(success_counter)]),
- ?line do_random_replace_comp(5000,{1,40},{30,1000}),
+ do_random_replace_comp(I1,Nr,Hr),
io:format("Number of successes: ~p~n",[get(success_counter)]),
- ?line do_random_split_comp2(5000,{1,40},{30,1000}),
+ do_random_split_comp2(I1,Nr,Hr),
io:format("Number of successes: ~p~n",[get(success_counter)]),
- ?line do_random_replace_comp2(5000,{1,40},{30,1000}),
+ do_random_replace_comp2(I1,Nr,Hr),
io:format("Number of successes: ~p~n",[get(success_counter)]),
ok.
+
random_ref_fla_comp(doc) ->
["Test pseudorandomly generated cases against reference imlementation of split and replace"];
random_ref_fla_comp(Config) when is_list(Config) ->
diff --git a/lib/stdlib/test/ets_SUITE.erl b/lib/stdlib/test/ets_SUITE.erl
index 41bd4af241..fff6b11a38 100644
--- a/lib/stdlib/test/ets_SUITE.erl
+++ b/lib/stdlib/test/ets_SUITE.erl
@@ -3061,13 +3061,13 @@ time_lookup(Config) when is_list(Config) ->
"~p ets lookups/s",[Values]))}.
time_lookup_do(Opts) ->
- ?line Tab = ets_new(foo,Opts),
- ?line fill_tab(Tab,foo),
- ?line ets:insert(Tab,{{a,key},foo}),
- ?line {Time,_} = ?t:timecall(test_server,do_times,
- [10000,ets,lookup,[Tab,{a,key}]]),
- ?line true = ets:delete(Tab),
- round(10000 / Time). % lookups/s
+ Tab = ets_new(foo,Opts),
+ fill_tab(Tab,foo),
+ ets:insert(Tab,{{a,key},foo}),
+ {Time,_} = ?t:timecall(test_server,do_times,
+ [100000,ets,lookup,[Tab,{a,key}]]),
+ true = ets:delete(Tab),
+ round(100000 / Time). % lookups/s
badlookup(doc) ->
["Check proper return values from bad lookups in existing/non existing "
@@ -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/io_proto_SUITE.erl b/lib/stdlib/test/io_proto_SUITE.erl
index 858a78b1d2..78432789cd 100644
--- a/lib/stdlib/test/io_proto_SUITE.erl
+++ b/lib/stdlib/test/io_proto_SUITE.erl
@@ -482,7 +482,7 @@ unicode_options_gen(Config) when is_list(Config) ->
PrivDir = ?config(priv_dir, Config),
AllModes = [utf8,utf16,{utf16,big},{utf16,little},
utf32,{utf32,big},{utf32,little}],
- FSize = 17*1024,
+ FSize = 9*1024,
NumItersRead = 2,
NumItersWrite = 2,
Dir = filename:join(PrivDir, "GENDATA1"),
diff --git a/lib/stdlib/test/maps_SUITE.erl b/lib/stdlib/test/maps_SUITE.erl
index 21e146ae3d..f8f241d834 100644
--- a/lib/stdlib/test/maps_SUITE.erl
+++ b/lib/stdlib/test/maps_SUITE.erl
@@ -38,8 +38,11 @@
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]}].
diff --git a/lib/stdlib/test/rand_SUITE.erl b/lib/stdlib/test/rand_SUITE.erl
index 9a1f37aa75..39ce1bd89a 100644
--- a/lib/stdlib/test/rand_SUITE.erl
+++ b/lib/stdlib/test/rand_SUITE.erl
@@ -33,7 +33,7 @@
-include_lib("test_server/include/test_server.hrl").
% Default timetrap timeout (set in init_per_testcase).
--define(default_timeout, ?t:minutes(1)).
+-define(default_timeout, ?t:minutes(3)).
-define(LOOP, 1000000).
init_per_testcase(_Case, Config) ->
diff --git a/lib/stdlib/test/unicode_SUITE.erl b/lib/stdlib/test/unicode_SUITE.erl
index 613be99ccd..9f5d485df6 100644
--- a/lib/stdlib/test/unicode_SUITE.erl
+++ b/lib/stdlib/test/unicode_SUITE.erl
@@ -87,8 +87,9 @@ ex_binaries_errors_utf8(Config) when is_list(Config) ->
%% Now, try with longer binary (trapping)
BrokenPart = list_to_binary(lists:seq(128,255)),
BrokenSz = byte_size(BrokenPart),
+ Seq255 = lists:seq(1,255),
[ begin
- OKList = lists:flatten(lists:duplicate(N,lists:seq(1,255))),
+ OKList = lists:flatten(lists:duplicate(N,Seq255)),
OKBin = unicode:characters_to_binary(OKList),
OKLen = length(OKList),
%% Copy to avoid that the binary get's writable
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/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/tools/test/lcnt_SUITE.erl b/lib/tools/test/lcnt_SUITE.erl
index 010dffe138..de68486b1b 100644
--- a/lib/tools/test/lcnt_SUITE.erl
+++ b/lib/tools/test/lcnt_SUITE.erl
@@ -97,12 +97,12 @@ t_conflicts_file([File|Files]) ->
{ok, _} = lcnt:start(),
ok = lcnt:load(File),
ok = lcnt:conflicts(),
- THs = [-1, 0, 100, 1000],
+ THs = [-1, 5],
Print = [name , id , type , entry , tries , colls , ratio , time , duration],
Opts = [
[{sort, Sort}, {reverse, Rev}, {max_locks, ML}, {combine, Combine}, {thresholds, [TH]}, {print, [Print]}] ||
- Sort <- [name , id , type , tries , colls , ratio , time , entry],
- ML <- [none, 1 , 32, 4096],
+ Sort <- [name , type , tries , colls , ratio , time],
+ ML <- [none, 32],
Combine <- [true, false],
TH <- [{tries, Tries} || Tries <- THs] ++ [{colls, Colls} || Colls <- THs] ++ [{time, Time} || Time <- THs],
Rev <- [true, false]
@@ -131,12 +131,12 @@ t_locations_file([File|Files]) ->
{ok, _} = lcnt:start(),
ok = lcnt:load(File),
ok = lcnt:locations(),
- THs = [-1, 0, 100, 1000],
+ THs = [-1, 0, 100],
Print = [name , id , type , entry , tries , colls , ratio , time , duration],
Opts = [
[{full_id, Id}, {sort, Sort}, {max_locks, ML}, {combine, Combine}, {thresholds, [TH]}, {print, Print}] ||
Sort <- [name , id , type , tries , colls , ratio , time , entry],
- ML <- [none, 1 , 64],
+ ML <- [none, 64],
Combine <- [true, false],
TH <- [{tries, Tries} || Tries <- THs] ++ [{colls, Colls} || Colls <- THs] ++ [{time, Time} || Time <- THs],
Id <- [true, false]
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"]}
]}.